# This is a shell archive. Remove anything before this line, # then unpack it by saving it in a file and typing "sh file". # # Wrapped by Aubrey Jaffer on Mon Jun 15 22:49:08 1992 # # This archive contains: # ANNOUNCE README ChangeLog require.doc # record.doc sc-macro.doc format.doc oop.doc # values.doc queue.doc Makefile require.scm # Template.scm mitscheme.init scheme2c.init scheme48.init # gambit.init t3.init stdio.scm format.scm # genwrite.scm obj2str.scm pp.scm pp2str.scm # ppfile.scm debug.scm eval.scm sort.scm # comlist.scm logical.scm random.scm sc4opt.scm # sc4-sc3.scm sc2.scm sc3.scm mularg.scm # mulapply.scm ratize.scm randinex.scm modular.scm # prime.scm charplot.scm r4rsyn.scm sc-macro.scm # synclo.scm synrul.scm synchk.scm record.scm # promise.scm values.scm queue.scm process.scm # priorque.scm hash.scm hashtab.scm alist.scm # test.scm plottest.scm formatst.scm macrotst.scm # scmactst.scm oop.scm # LANG=""; export LANG PATH=/bin:/usr/bin:$PATH; export PATH echo x - ANNOUNCE cat >ANNOUNCE <<'@EOF' This message announces the availability of Scheme Library release slib1b8. New in release slib1b8 are: scheme48.init, hash.scm, and hashtab.scm, alist.scm, priorque.scm and several bug fixes. The functions in hash.scm provide bounded time modular hash functions corresponding to each of the equality predicates eq?, eqv?, equal?, =, char=?, char-ci=?, string=?, and string-ci=?. hashtab.scm provides hash tables using the functions from hash.scm. alist.scm has functions similar to hashtab.scm but for association lists. Macro:repl, a read-macro:eval:print loop has been added to sc-macro.scm. Priority queues are implemented in priorque.scm. SLIB is a portable scheme library meant to provide compatibiliy and utility functions for all standard scheme implementations. SLIB includes initialization files for GAMBIT, MITScheme, scheme->C, Scheme48, and T3.1. Scm4a also supports SLIB. Documentation includes a manifest, installation instructions, and proposed coding standards for the library. Documentation on each library package is supplied. SLIB can be obtained via ftp (detailed instructions follow) from: altdorf.ai.mit.edu:archive/scm/slib1b8.shar altdorf.ai.mit.edu:archive/scm/slib1b8.tar.Z nexus.yorku.ca:pub/scheme/new/slib1b8.shar nexus.yorku.ca:pub/scheme/new/slib1b8.tar.Z ftp altdorf.ai.mit.edu [18.43.0.246] (anonymous) cd archive/scm or ftp nexus.yorku.ca (anonymous) cd pub/scheme/new `slib1b8.shar' is a shar file of a Scheme Library. `slib1b8.tar.Z' is a compressed tar file of a Scheme Library. Remember to use binary mode when transferring the *.tar.Z files. @EOF chmod 666 ANNOUNCE echo x - README cat >README <<'@EOF' This directory contains the distribution of the Scheme Library slib1b. Slib conforms to Revised^4 Report on the Algorithmic Language Scheme and the IEEE P1178 specification. Slib supports Unix and similar systems, VMS, and MS-DOS. The maintainer can be reached at jaffer@ai.mit.edu or Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880. MANIFEST `README' is this file. It contains a MANIFEST, INSTALLATION INSTRUCTIONS, and proposed coding standards. `ChangeLog' documents changes to slib. `Template.scm' Example configuration file. Copy and customize to reflect your system. `gambit.init' is a configuration file for Gambit Scheme. `mitscheme.init' is a configuration file for MIT Scheme. `scheme2c.init' is a configuration file for DEC's scheme->c. `scheme48.init' is a configuration file for Scheme48. `t3.init' is a configuration file for T3.1 in Scheme mode. `require.scm' has code which allows system independent access to the library files. `require.doc' documents the functions in require.scm. `format.scm' has Common-Lisp style format. `format.doc' documents format. `formatst.scm' has code to test format.scm `pp.scm' has pretty-print. `ppfile.scm' has pprint-file. `pp2str.scm' has pretty-print-to-string. `obj2str.scm' has object-to-string. `genwrite.scm' has a generic-write which is used by pp.scm, pp2str.scm and obj2str.scm `stdio.scm' has printf, fprintf, and sprintf compatible with C. `debug.scm' has qp, a printer save for circular structures, tracef and untracef for tracing function execution, and break and continue. `test.scm' has routines useful for testing and reporting problems. `alist.scm' has functions accessing and modifying association lists. `hash.scm' defines hash, hashq, and hashv. `hashtab.scm' has hash tables. `logical.scm' emulates 2's complement logical operations. `random.scm' has random number generator compatible with Common Lisp. `randinex.scm' has inexact real number distributions. `prime.scm' has prime? and factor. `charplot.scm' has procedure for plotting on character screens. `plottest.scm' has code to test charplot.scm. `record.scm' a MITScheme user-definable datatypes package `record.doc' documentation for record.scm `promise.scm' has code from R4RS for supporting DELAY and FORCE. `sc-macro.scm' is a syntactic closure R4RS macro package. r4rsyn.scm, synclo.scm, synrul.scm have syntax definitions and support. `sc-macro.doc is documentation on syntactic closures. `macrotst.scm' is code from R4RS for testing macros. `scmactst.scm' is code for testing SYNTACTIC CLOSURE macros. `values.scm' is multiple values. `values.doc' is documentation for values. `queue.scm' has queues and stacks. `queue.doc' is documentation for queues. `oop.scm' is object oriented programming (using R4RS macros). `oop.doc' is documentation for oop.scm. `priorque.scm' has code and documentation for priority queues. `process.scm' has multi-processing primitives. `sort.scm' has sorted?, sort, sort!, merge, and merge! `comlist.scm' has many common list and mapping procedures. `eval.scm' has eval. `sc4opt.scm' has optional rev4 procedures. `sc4-sc3.scm' has procedures to make a rev3 implementation run rev4 code. `sc2.scm' has rev2 procedures eliminated in subsequent versions. `sc3.scm' has rev3 procedures eliminated in subsequent versions. `mularg.scm' redefines - and / to take more than 2 arguments. `mulapply.scm' redefines apply to take more than 2 arguments. `ratize.scm' has function rationalize from Revised^4 spec. INSTALLATION INSTRUCTIONS Check the manifest to see if a configuration file for your Scheme implementation has already been created. If so, customize it and use it. If not, you will have to create one. Please mail new working configuration files to jaffer@ai.mit.edu so that they can be included in the SLIB distribution. Template.scm is an example configuration file. The comments inside will direct you on how to customize it to reflect your system. Your customized version should then be loaded as part of your scheme implementation's initialization. It will load "require.scm" from the library; this will allow the use of PROVIDE, PROVIDED?, and REQUIRE along with the VICINITY functions. The rest of the library will then be accessible in a system independent fashion. CODING STANDARDS All library packages are written in IEEE P1178 Scheme and assume that a configuration file and require.scm package have already been loaded. Other versions of Scheme can be supported in library packages as well by using (PROVIDED? 'REV3-REPORT) or (REQUIRE 'REV3-REPORT). Require.scm defines *catalog*, an alist of module names and filenames. When a new package is added to the library an entry should be added to vicintiy.scm. Local packages can also be added to *catalog* and even shadow entries already in the table. The module name and `:' should prefix each symbol defined in the package. Definitions for external use should then be exported by having (define foo module-name:foo). Submitted packages should not duplicate routines which are already in SLIB files. Use REQUIRE to force those features to be supported in your package. Care should be taken that there are no circularities in the REQUIREs and LOADs between the library packages. Documentation should be provided either at the beginning of a library file or in a separate file whose name has `doc' as a suffix rather than `scm'. For instance, the documentation for require.scm is in require.doc. @EOF chmod 666 README echo x - ChangeLog sed 's/^@//' >ChangeLog <<'@EOF' Sun Jun 14 22:57:32 1992 Aubrey Jaffer (jaffer at Ivan) * slib1b8 released. Sat Jun 13 17:01:41 1992 Aubrey Jaffer (jaffer at Ivan) * alist.scm: added. * hash.scm hashtab.scm scheme48.init: added. * sc-macro.scm (macro:repl): created. macro:load now uses eval:eval!. * eval.scm (eval:eval!) created and eval done in terms of it. * prime.scm (prime:prime?) fixed misplaced parenthesis. Wed May 27 16:13:17 1992 Aubrey Jaffer (jaffer at Ivan) From: "Chris Hanson" * synrul.scm (generate-match): fixed for CASE syntax. Wed May 20 00:25:40 1992 Aubrey Jaffer (jaffer at Ivan) * slib1b6 released. * Template.scm gambit.init mitscheme.init scheme2c.init: rearranged *features*. Tue May 19 22:51:28 1992 Aubrey Jaffer (jaffer at Ivan) * scmactst.scm: test cases fixed. From: "Chris Hanson" * r4syn.scm (make-r4rs-primitive-macrology): TRANSFORMER added back in. * require.scm (load): load now passes through additional arguments to *old-load*. Mon May 18 00:59:36 1992 Aubrey Jaffer (jaffer at Ivan) * mulapply.scm (apply): written. * record.scm record.doc (make-record-sub-type): added. Fri May 8 17:55:14 1992 Aubrey Jaffer (jaffer at Ivan) * process.scm: created, but not finished. From: hugh@ear.mit.edu (Hugh Secker-Walker) * comlist.scm (nreverse make-list): non-recursive versions added. * sc2.scm (1+ -1+): versions which capture +. * mularg.scm (- /): created. Wed Apr 8 00:05:30 1992 Aubrey Jaffer (jaffer at Ivan) * require.scm sc-macro.scm (catalog): Now uses macro:load if 'macro is part of catalog entry. From: Andrew Wilcox (awilcox@astro.psu.edu) * queue.scm: created. Sun Mar 15 12:23:06 1992 Aubrey Jaffer (jaffer at Ivan) * comlist.scm (notevery): fixed. Now (not (every ..)). * eval.scm (eval:eval): renamed to slib:eval. * record.scm: replaced with version from From: david carlton . I changed updater => modifier, put record-predicate into the rtd, and bummed code mercilessly. From: plogan@std.mentor.com (Patrick Logan) * sc3.scm (last-pair): changed from testing null? to pair?. @EOF chmod 666 ChangeLog echo x - require.doc cat >require.doc <<'@EOF' VICINITY A vicinity is a descriptor for a place in the file system. Vicinities hide from the programmer the concepts of host, volume, directory, and version. Vicinities express only the concept of a file environment where a file name can be resolved to a file in a system independent manner. Vicinities can even be used on `flat' file systems (which have no directory structure) by having the vicinity express constraints on the file name. On most systems a vicinity would be a string. All of these procedures are file system dependent. (make-vicinity ) procedure Returns the vicinity of for use by in-vicinity. (program-vicinity) procedure Returns the vicinity of the currently loading Scheme code. For an interpreter this would be the directory containing source code. For a compiled system (with multiple files) this would be the directory where the object or executable files are. If no file is currently loading it the result is undefined. (library-vicinity) procedure Returns the vicinity of the shared Scheme library. (implementation-vicinity) procedure Returns the vicinity of the underlying Scheme implementation. This vicinity will likely contain startup code and messages and a compiler. (user-vicinity) procedure Returns the vicinity of the current directory of the user. On most systems this is "". (scheme-file-suffix) procedure Returns the default filename suffix for scheme source files. On most systems this is ".scm". (in-vicinity ) procedure (in-vicinity ) procedure Returns a filename suitable for use by load, open-input-file, open-output-file, etc. The returned filename is , with optional appended, in . In-vicinity should allow to override when is an absolute pathname and is equal to the value of (user-vicinity). The behavior of in-vicinity when is absolute and is not equal to the value of (user-vicinity) is unspecified. For most systems in-vicinity can be string-append. (sub-vicinity ) procedure Returns the vicinity of restricted to . This is used for large systems where names of files in subsystems could conflict. On systems with directory structure sub-vicinity will return a pathname of the subdirectory of . REQUIRE *features* variable Is a list of symbols denoting features supported in this implementation. *modules* variable Is a list of pathnames denoting files which have been loaded. *catalog* variable Is an association list of features (symbols) and pathnames which will supply those features. In the following three functions if is not a symbol it is assumed to be a pathname. (provided? ) procedure Returns #t if is a member of *features* or *modules* or if is supported by a file already loaded and #f otherwise. (require ) procedure If (not (provided? )) it is loaded if a pathname or if (assq *catalog*) (provide ) procedure Assures that is contained in *features* if is a symbol and *modules* otherwise. @EOF chmod 666 require.doc echo x - record.doc sed 's/^@//' >record.doc <<'@EOF' Date: Fri, 01 Sep 89 13:50:16 PDT @From: Pavel.pa@xerox.com May 17 1992, MAKE-RECORD-SUB-TYPE added by jaffer@ai.mit.edu. (MAKE-RECORD-TYPE type-name field-names) Returns a ``record-type descriptor'', a value representing a new data type, disjoint from all others. The type-name argument must be a string, but is only used for debugging purposes (such as the printed representation of a record of the new type). The field-names argument is a list of symbols naming the ``fields'' of a record of the new type. It is an error if the list contains any duplicates. It is unspecified how record-type descriptors are represented. (MAKE-RECORD-SUB-TYPE type-name field-names rtd) Returns a ``record-type descriptor'', a value representing a new data type, disjoint from all others. The type-name argument must be a string. The field-names argument is a list of symbols naming the additional ``fields'' to be appended to filed-names of rtd. It is an error if the combinded list contains any duplicates. Record-modifiers and record-accessors for rtd work for the new record-sub-type as well. But record-modifiers and record-accessors for the new record-sub-type will not neccessarily work for rtd. (RECORD-CONSTRUCTOR rtd [field-names]) Returns a procedure for constructing new members of the type represented by rtd. The returned procedure accepts exactly as many arguments as there are symbols in the given list, field-names; these are used, in order, as the initial values of those fields in a new record, which is returned by the constructor procedure. The values of any fields not named in that list are unspecified. The field-names argument defaults to the list of field-names in the call to MAKE-RECORD-TYPE that created the type represented by rtd; if the field-names argument is provided, it is an error if it contains any duplicates or any symbols not in the default list. (RECORD-PREDICATE rtd) Returns a procedure for testing membership in the type represented by rtd. The returned procedure accepts exactly one argument and returns a true value if the argument is a member of the indicated record type; it returns a false value otherwise. (RECORD-ACCESSOR rtd field-name) Returns a procedure for reading the value of a particular field of a member of the type represented by rtd. The returned procedure accepts exactly one argument which must be a record of the appropriate type; it returns the current value of the field named by the symbol field-name in that record. The symbol field-name must be a member of the list of field-names in the call to MAKE-RECORD-TYPE that created the type represented by rtd. (RECORD-MODIFIER rtd field-name) Returns a procedure for writing the value of a particular field of a member of the type represented by rtd. The returned procedure accepts exactly two arguments: first, a record of the appropriate type, and second, an arbitrary Scheme value; it modifies the field named by the symbol field-name in that record to contain the given value. The returned value of the modifier procedure is unspecified. The symbol field-name must be a member of the list of field-names in the call to MAKE-RECORD-TYPE that created the type represented by rtd. (RECORD? obj) Returns a true value if obj is a record of any type and a false value otherwise. Note that RECORD? may be true of any Scheme value; of course, if it returns true for some particular value, then RECORD-TYPE-DESCRIPTOR is applicable to that value and returns an appropriate descriptor. (RECORD-TYPE-DESCRIPTOR record) Returns a record-type descriptor representing the type of the given record. That is, for example, if the returned descriptor were passed to RECORD-PREDICATE, the resulting predicate would return a true value when passed the given record. Note that it is not necessarily the case that the returned descriptor is the one that was passed to RECORD-CONSTRUCTOR in the call that created the constructor procedure that created the given record. (RECORD-TYPE-NAME rtd) Returns the type-name associated with the type represented by rtd. The returned value is EQV? to the type-name argument given in the call to MAKE-RECORD-TYPE that created the type represented by rtd. (RECORD-TYPE-FIELD-NAMES rtd) Returns a list of the symbols naming the fields in members of the type represented by rtd. The returned value is EQUAL? to the field-names argument given in the call to MAKE-RECORD-TYPE that created the type represented by rtd. @EOF chmod 666 record.doc echo x - sc-macro.doc sed 's/^@//' >sc-macro.doc <<'@EOF' @From andrew@astro.psu.edu Mon Feb 10 10:07:27 1992 Return-Path: Date: Sun, 9 Feb 92 10:10:03 EST @From: Andrew Wilcox To: jaffer@altdorf.ai.mit.edu Subject: synclo.doc for SLIB Cc: cph@altdorf.ai.mit.edu I grabbed a copy of synclo.dvi from altdorf, ran it through dvi2tty, and touched up the result a bit. Andrew Wilcox Department of Astronomy & Astrophysics, Pennsylvania State University (awilcox@astro.psu.edu) A Syntactic Closures Macro Facility by Chris Hanson 9 November 1991 This document describes "syntactic closures", a low-level macro facility for the Scheme programming language. The facility is an alternative to the low-level macro facility described in the "Revised^4 Report on Scheme." This document is an addendum to that report. The syntactic closures facility extends the BNF rule for to allow a new keyword that introduces a low-level macro transformer: := (transformer ) Additionally the following procedures are added: make-syntactic-closure capture-syntactic-environment identifier? identifier=? The description of the facility is divided into three parts. The first part defines basic terminology. The second part describes how macro transformers are defined. The third part describes the use of "identifiers", which extend the syntactic closure mechanism to be compatible with `syntax-rules'. Terminology This section defines the concepts and data types used by the syntactic closures facility. o "Forms" are the syntactic entities out of which programs are recursively constructed. A form is any expression, any definition, any syntactic keyword, or any syntactic closure. The variable name that appears in a `set!' special form is also a form. Examples of forms: 17 #t car (+ x 4) (lambda (x) x) (define pi 3.14159) if define o An "alias" is an alternate name for a given symbol. It can appear anywhere in a form that the symbol could be used, and when quoted it is replaced by the symbol; however, it does not satisfy the predicate `symbol?'. Macro transformers rarely distinguish symbols from aliases, referring to both as identifiers. o A "syntactic" environment maps identifiers to their meanings. More precisely, it determines whether an identifier is a syntactic keyword or a variable. If it is a keyword, the meaning is an interpretation for the form in which that keyword appears. If it is a variable, the meaning identifies which binding of that variable is referenced. In short, syntactic environments contain all of the contextual information necessary for interpreting the meaning of a particular form. o A "syntactic closure" consists of a form, a syntactic environment, and a list of identifiers. All identifiers in the form take their meaning from the syntactic environment, except those in the given list. The identifiers in the list are to have their meanings determined later. A syntactic closure may be used in any context in which its form could have been used. Since a syntactic closure is also a form, it may not be used in contexts where a form would be illegal. For example, a form may not appear as a clause in the cond special form. A syntactic closure appearing in a quoted structure is replaced by its form. Transformer Definition This section describes the `transformer' special form and the procedures `make-syntactic-closure' and `capture-syntactic-environment'. transformer EXPRESSION syntax Syntax: It is an error if this syntax occurs except as a . Semantics: The EXPRESSION is evaluated in the standard transformer environment to yield a macro transformer as described below. This macro transformer is bound to a macro keyword by the special form in which the `transformer' expression appears (for example, `let-syntax'). A "macro transformer" is a procedure that takes two arguments, a form and a syntactic environment, and returns a new form. The first argument, the "input form", is the form in which the macro keyword occurred. The second argument, the "usage environment", is the syntactic environment in which the input form occurred. The result of the transformer, the "output form", is automatically closed in the "transformer environment", which is the syntactic environment in which the `transformer' expression occurred. For example, here is a definition of a push macro using syntax-rules: (define-syntax push (syntax-rules () ((push item list) (set! list (cons item list))))) Here is an equivalent definition using transformer: (define-syntax push (transformer (lambda (exp env) (let ((item (make-syntactic-closure env '() (cadr exp))) (list (make-syntactic-closure env '() (caddr exp)))) `(set! ,list (cons ,item ,list)))))) In this example, the identifiers `set!' and `cons' are closed in the transformer environment, and thus will not be affected by the meanings of those identifiers in the usage environment `env'. Some macros may be non-hygienic by design. For example, the following defines a loop macro that implicitly binds `exit' to an escape procedure. The binding of `exit' is intended to capture free references to `exit' in the body of the loop, so `exit' must be left free when the body is closed: (define-syntax loop (transformer (lambda (exp env) (let ((body (cdr exp))) `(call-with-current-continuation (lambda (exit) (let f () ,@(map (lambda (exp) (make-syntactic-closure env '(exit) exp)) body) (f)))))))) To assign meanings to the identifiers in a form, use `make-syntactic-closure' to close the form in a syntactic environment. make-syntactic-closure ENVIRONMENT FREE-NAMES FORM procedure ENVIRONMENT must be a syntactic environment, FREE-NAMES must be a list of identifiers, and FORM must be a form. `make-syntactic-closure' constructs and returns a syntactic closure of FORM in ENVIRONMENT, which can be used anywhere that FORM could have been used. All the identifiers used in FORM, except those explicitly excepted by FREE-NAMES, obtain their meanings from ENVIRONMENT. Here is an example where FREE-NAMES is something other than the empty list. It is instructive to compare the use of FREE-NAMES in this example with its use in the `loop' example above: the examples are similar except for the source of the identifier being left free. (define-syntax let1 (transformer (lambda (exp env) (let ((id (cadr exp)) (init (caddr exp)) (exp (cadddr exp))) `((lambda (,id) ,(make-syntactic-closure env (list id) exp)) ,(make-syntactic-closure env '() init)))))) `let1' is a simplified version of `let' that only binds a single identifier, and whose body consists of a single expression. When the body expression is syntactically closed in its original syntactic environment, the identifier that is to be bound by `let1' must be left free, so that it can be properly captured by the `lambda' in the output form. To obtain a syntactic environment other than the usage environment, use `capture-syntactic-environment'. capture-syntactic-environment PROCEDURE procedure `capture-syntactic-environment' returns a form that will, when transformed, call PROCEDURE on the current syntactic environment. PROCEDURE should compute and return a new form to be transformed, in that same syntactic environment, in place of the form. An example will make this clear. Suppose we wanted to define a simple `loop-until' keyword equivalent to (define-syntax loop-until (syntax-rules () ((loop-until id init test return step) (letrec ((loop (lambda (id) (if test return (loop step))))) (loop init))))) The following attempt at defining loop-until has a subtle bug: (define-syntax loop-until (transformer (lambda (exp env) (let ((id (cadr exp)) (init (caddr exp)) (test (cadddr exp)) (return (cadddr (cdr exp))) (step (cadddr (cddr exp))) (close (lambda (exp free) (make-syntactic-closure env free exp)))) `(letrec ((loop (lambda (,id) (if ,(close test (list id)) ,(close return (list id)) (loop ,(close step (list id))))))) (loop ,(close init '()))))))) This definition appears to take all of the proper precautions to prevent unintended captures. It carefully closes the subexpressions in their original syntactic environment and it leaves the `id' identifier free in the `test', `return', and `step' expressions, so that it will be captured by the binding introduced by the `lambda' expression. Unfortunately it uses the identifiers `if' and `loop' within that `lambda' expression, so if the user of `loop-until' just happens to use, say, `if' for the identifier, it will be inadvertently captured. The syntactic environment that `if' and `loop' want to be exposed to is the one just outside the `lambda' expression: before the user's identifier is added to the syntactic environment, but after the identifier loop has been added. `capture-syntactic-environment' captures exactly that environment as follows: (define-syntax loop-until (transformer (lambda (exp env) (let ((id (cadr exp)) (init (caddr exp)) (test (cadddr exp)) (return (cadddr (cdr exp))) (step (cadddr (cddr exp))) (close (lambda (exp free) (make-syntactic-closure env free exp)))) `(letrec ((loop ,(capture-syntactic-environment (lambda (env) `(lambda (,id) (,(make-syntactic-closure env '() `if) ,(close test (list id)) ,(close return (list id)) (,(make-syntactic-closure env '() `loop) ,(close step (list id))))))))) (loop ,(close init '()))))))) In this case, having captured the desired syntactic environment, it is convenient to construct syntactic closures of the identifiers `if' and the `loop' and use them in the body of the `lambda'. A common use of `capture-syntactic-environment' is to get the transformer environment of a macro transformer: (transformer (lambda (exp env) (capture-syntactic-environment (lambda (transformer-env) ...)))) Identifiers This section describes the procedures that create and manipulate identifiers. Previous syntactic closure proposals did not have an identifier data type -- they just used symbols. The identifier data type extends the syntactic closures facility to be compatible with the high-level `syntax-rules' facility. As discussed earlier, an identifier is either a symbol or an "alias". An alias is implemented as a syntactic closure whose "form" is an identifier: (make-syntactic-closure env '() 'a) ==> an alias Aliases are implemented as syntactic closures because they behave just like syntactic closures most of the time. The difference is that an alias may be bound to a new value (for example by `lambda' or `let-syntax'); other syntactic closures may not be used this way. If an alias is bound, then within the scope of that binding it is looked up in the syntactic environment just like any other identifier. Aliases are used in the implementation of the high-level facility `syntax-rules'. A macro transformer created by `syntax-rules' uses a template to generate its output form, substituting subforms of the input form into the template. In a syntactic closures implementation, all of the symbols in the template are replaced by aliases closed in the transformer environment, while the output form itself is closed in the usage environment. This guarantees that the macro transformation is hygienic, without requiring the transformer to know the syntactic roles of the substituted input subforms. identifier? OBJECT procedure Returns `#t' if OBJECT is an identifier, otherwise returns `#f'. Examples: (identifier? 'a) ==> #t (identifier? (make-syntactic-closure env '() 'a)) ==> #t (identifier? "a") ==> #f (identifier? #\a) ==> #f (identifier? 97) ==> #f (identifier? #f) ==> #f (identifier? '(a)) ==> #f (identifier? '#(a)) ==> #f The predicate `eq?' is used to determine if two identifers are "the same". Thus `eq?' can be used to compare identifiers exactly as it would be used to compare symbols. Often, though, it is useful to know whether two identifiers "mean the same thing". For example, the `cond' macro uses the symbol `else' to identify the final clause in the conditional. A macro transformer for `cond' cannot just look for the symbol `else', because the `cond' form might be the output of another macro transformer that replaced the symbol `else' with an alias. Instead the transformer must look for an identifier that "means the same thing" in the usage environment as the symbol `else' means in the transformer environment. procedure identifier=? ENVIRONMENT1 IDENTIFIER1 ENVIRONMENT2 IDENTIFIER2 ENVIRONMENT1 and ENVIRONMENT2 must be syntactic environments, and IDENTIFIER1 and IDENTIFIER2 must be identifiers. `identifier=?' returns `#t' if the meaning of IDENTIFIER1 in ENVIRONMENT1 is the same as that of IDENTIFIER2 in ENVIRONMENT2, otherwise it returns `#f'. Examples: (let-syntax ((foo (transformer (lambda (form env) (capture-syntactic-environment (lambda (transformer-env) (identifier=? transformer-env 'x env 'x))))))) (list (foo) (let ((x 3)) (foo)))) ==> (#t #f) (let-syntax ((bar foo)) (let-syntax ((foo (transformer (lambda (form env) (capture-syntactic-environment (lambda (transformer-env) (identifier=? transformer-env 'foo env (cadr form)))))))) (list (foo foo) (foobar)))) ==> (#f #t) Acknowledgments The syntactic closures facility was invented by Alan Bawden and Jonathan Rees. The use of aliases to implement `syntax-rules' was invented by Alan Bawden (who prefers to call them "synthetic names"). Much of this proposal is derived from an earlier proposal by Alan Bawden. @EOF chmod 666 sc-macro.doc echo x - format.doc sed 's/^@//' >format.doc <<'@EOF' Documentation of SLIB format Version 2.1 Please consult a Common LISP format reference manual for a detailed description of the format string syntax. (I haven't the time to copy the CL format standard text in here). For a demonstration of the implemented directives see "formatst.scm". This implementation supports directive parameters and modifiers (`:' and `@' characters). Multiple parameters must be separated by a `,'. Parameters can be numerical parameters (positive or negative), character parameters (prefixed by a quote character), variable parameters (`v'), number of rest arguments parameter (`#'), empty and default parameters. Directive characters are case independent. The general form of a directive is: directive ::= ~{,}[:][@] directive-parameter ::= [ [-|+]{0-9}+ | ' | v | # ] Documentation syntax -------------------- Uppercase characters represent the corresponding control directive characters. Lowercase characters represent control directive parameter descriptions. Compatibility to other FORMAT implementations --------------------------------------------- SLIB format 2.x: see format.scm. SLIB format 1.4: Downward compatible except for padding support and ~A,~S,~P,~X uppercase printing. SLIB format 1.4 uses C-style printf padding support which is completely replaced by the CL format padding style. MIT C-Scheme 7.1: Downward compatible except for ~; which is not documented (ignores all characters inside the format string up to a newline character). (7.1 implements ~a, ~s, ~, ~~, ~%, numerical and variable parameters and :/@ modifiers in the CL sense). Elk 1.5: Downward compatible except for ~A and ~S which print in uppercase. (1.5 implements ~a, ~s ~~ and ~% (no directive parameters or modifiers)). Scheme->C 01nov91: Downward compatible except for an optional destination parameter: S2C accepts a format call without a destination which returns a formatted string. This is equivalent to a #f destination in S2C. (S2C implements ~a,~s,~c,~% and ~~ (no directive parameters or modifiers)). T 3.1: Downward compatible. This SLIB format version does not run on T 3.1 now due to missing R4RS essential procedures. (T 3.1 implements ~a,~b,~d,~o,~p, ~nr,~s,~t,~x,~%,~&,~_ and ~~). SLIB format may be used apart from the SLIB context. In this case you have to modify the implementation dependent code marked at the beginning of "format.scm". Implemented control directives ------------------------------ @~A Ascii (print as `display' does). ~@A left pad. ~mincol,colinc,minpad,padcharA padding (colinc is not supported). @~S S-expression (print as `write' does). ~@S left pad. ~mincol,colinc,minpad,padcharS padding (colinc is not supported). @~D Decimal. ~@D print number sign. ~:D print comma separated. ~mincol,padchar,commacharD padding. @~X Hexadecimal. ~@X print number sign. ~:X print comma separated. ~mincol,padchar,commacharX padding. @~O Octal. ~@O print number sign. ~:O print comma separated. ~mincol,padchar,commacharO padding. @~B Binary. ~@B print number sign. ~:B print comma separated. ~mincol,padchar,commacharB padding. @~nR Radix (prints number to radix n). ~n@R print number sign. ~:B print comma separated. ~n,mincol,padchar,commacharR padding. @~P Plural. ~@P prints `y' and `ies'. ~:P as ~P but jumps 1 argument backward. ~:@P as ~@P but jumps 1 argument backward. @~C Character. ~@C print as `write' does. @~% Newline. ~n% prints n newlines. @~| Page Separator. ~n| prints n page separators. @~~ Tilde. ~n~ prints n tildes. @~#\newline Continuation Line (#\newline stands for a newline character). ~:#\newline newline is ignored, white space left. ~@#\newline newline is left, white space ignored. @~T Tabulator. ~nT prints n tabs. @~? Indirection (expects indirect arguments as a list). ~@? extracts indirect arguments from format arguments. @~(str~) Case conversion (converts by string-downcase). ~:(str~) converts by string-capitalize. ~@(str~) converts by string-capitalize-first. ~:@(str~) converts by string-upcase. @~* Argument Jumping (jumps 1 argument forward). ~n* jumps n arguments forward. ~:* jumps 1 argument backward. ~n:* jumps n arguments backward. ~@* jumps to the 0th argument. ~n@* jumps to the nth argument (beg. from 0) @~[str0~;str1~;...~;strn~] Conditional Expression (numerical clause conditional). ~n[ take argument from n. ~@[ true test conditional. ~:[ if-else-then conditional. ~; clause separator. ~:; default clause follows. @~{str~} Iteration (args come from the next argument (a list)). ~n{ at most n iterations. ~:{ args from next arg (a list of lists). ~@{ args from the rest of arguments. ~:@{ args from the rest args (lists). @~^ Up and out. ~n^ aborts if n = 0 ~n,m^ aborts if n = m ~n,m,k^ aborts if n <= m <= k NOT implemented control directives ---------------------------------- @~:A @~:S @~R @~& @~@T @~colnum,colincT @~<~> @~:^ (what is the `entire' iteration process?) Extended, replaced and added control directives ----------------------------------------------- @~mincol,padchar,commachar,commawidthD commawidth is the number of characters @~mincol,padchar,commachar,commawidthX between two comma characters. @~mincol,padchar,commachar,commawidthO @~mincol,padchar,commachar,commawidthB @~n,mincol,padchar,commachar,commawidthR @~-mincol,colinc,minpad,padcharA negative field width specified by @~-mincol,colinc,minpad,padcharS mincol forces a field truncation to @~-mincol,padchar,commachar,commawidthD mincol characters. If the printed @~-mincol,padchar,commachar,commawidthX object exceeds the field width a `>' or @~-mincol,padchar,commachar,commawidthO a `<' character is added according to @~-mincol,padchar,commachar,commawidthB the padding direction. @~n,-mincol,padchar,commachar,commawidthR @~Y Pretty print formatting of an argument for scheme code lists. (Works only on current-output-port yet). @~& Same as ~%. @~K Same as ~?. @~! Flushes the output if format destination is a port. @~_ Prints a #\space character ~n_ prints n #\space characters. @~nC Takes n as an integer representation for a character. No arguments are consumed. n is converted to a character by integer->char. n must be a positive decimal number. @~F,~E,~G,~$ Floating point. Just put out the argument by number->string. No parameters implemented yet. @EOF chmod 666 format.doc echo x - oop.doc cat >oop.doc <<'@EOF' "oop.doc" A simple object system for Scheme based on the paper by Norman Adams and Jonathan Rees: "Object Oriented Programming in Scheme", Proceedings of the 1988 ACM Conference on LISP and Functional Programming, July 1988 [ACM #552880]. INTERFACE: (DEFINE-OPERATION (opname self arg ...) default-body) (DEFINE-PREDICATE opname) (OBJECT ((name self arg ...) body) ... ) (OBJECT-WITH-ANCESTORS ( (ancestor1 init1) ...) operation ...) ;; in an operation {a.k.a. send-to-super} (OPERATE-AS component operation self arg ...) TERMS: Object -- any Scheme data object Instance -- an instance of the OO system; an "object" Operation -- a "method" NOTES: The object system supports multiple inheritance. An instance can inherit from 0 or more ancestors. In the case of multiple inherited operations with the same identity, the operation used is that from the first ancestor which contains it (in the ancestor let). An operation may be applied to any Scheme data object--not just instances. As code which creates instances is just code, there are no "classes" and no meta-. DISCLAIMER: There are a number of optimizations which can be made. This implementation is expository (although performance should be quite reasonable). See the L&FP paper for some suggestions. EXAMPLES: (define-operation (PRINT obj port) (format port (if (instance? obj) "#" "~s") obj ) ) (define-operation (SIZE obj) (cond ((vector? obj) (vector-length obj)) ((list? obj) (length obj)) ((pair? obj) 2) ((string? obj) (string-length obj)) ((char? obj) 1) (else (error "Operation not supported: size" obj)) ) ) (define-predicate CELL?) (define-operation (FETCH obj)) (define-operation (STORE! obj newValue)) (define (MAKE-CELL value) (object ((CELL? self) #t) ((FETCH self) value) ((STORE! self newValue) (set! value newValue) newValue ) ((SIZE self) 1) ((PRINT self port) (format port "#" (fetch self)) ) ) ) (define-operation (DISCARD obj value) (format #t "Discarding ~s~%" value) ) (define (MAKE-FILTERED-CELL value filter) (object-with-ancestors ( (cell (make-cell value)) ) ((STORE! self newValue) (if (filter newValue) (store! cell newValue) (discard self newValue)) ) ) ) (define-predicate ARRAY?) (define-operation (ARRAY-REF array index)) (define-operation (ARRAY-SET! array index value)) (define (MAKE-ARRAY num-slots) (let ( (anArray (make-vector num-slots)) ) (object ((ARRAY? self) #t) ((SIZE self) num-slots) ((ARRAY-REF self index) (vector-ref anArray index)) ((ARRAY-SET! self index newValue) (vector-set! anArray index newValue)) ((PRINT SELF port) (format port "#" (size self))) ) ) ) (define-operation (POSITION obj)) (define-operation (DISCARDED-VALUE obj)) (define (MAKE-CELL-WITH-HISTORY value filter size) (let ( (pos 0) (most-recent-discard #f) ) (object-with-ancestors ( (cell (make-filtered-call value filter)) (sequence (make-array size)) ) ((ARRAY? self) #f) ((POSITION self) pos) ((STORE! self newValue) (operate-as cell store! self newValue) (array-set! self pos newValue) (set! pos (+ pos 1)) ) ((DISCARD self value) (set! most-recent-discard value) ) ((DISCARDED-VALUE self) most-recent-discard) ((PRINT self port) (format port "#" (fetch self)) ) ) ) ;; --- E O F --- @EOF chmod 666 oop.doc echo x - values.doc cat >values.doc <<'@EOF' Value.scm implements John Ramsdell's multiple values proposal for R5RS. I'm including his TeX version of the proposal at the end of this file; what it does is adds two functions to Scheme, namely VALUES and CALL-WITH-VALUES. The former takes an arbitrary number of arguments and passes them to its continuation; the latter takes a thunk and a function, calls the thunk, and passes the values that the thunk returns to the function. CALL-WITH-VALUES is the only way that a continuation can be created that takes zero arguments or more than one argument; if a continuation which is created in another manner is passed other than one argument, the behaviour is unspecified. This implementation depends on records being available, and isn't a particularly fast implementation; but you won't get a fast one without compiler/interpreter support. It was written by david carlton, carlton@husc.harvard.edu, and is in the public domain. Here's John's proposal: %%% Multiple values compromise proposal of December 4, 1989. %%% This is raw TeX. \advance\hsize by -5cm \def\mvcall{call-with-values} \def\mvcontinue{values} The editors are directed to add text to R$^5$RS so as to include the procedures {\tt \mvcontinue{}} and {\tt\mvcall{}} consistent with the following definitions. The {\tt \mvcontinue{}} procedure takes any number of arguments, and simply passes them to its continuation. The {\tt\mvcall{}} procedure takes a thunk and a procedure, and calls the thunk with a continuation that, when passed some values, calls the procedure that was the second argument to the {\tt\mvcall{}} procedure with those values as arguments. Except for continuations created by the {\tt\mvcall{}} procedure, all continuations take exactly one value, as now; the effect of passing no value or more than one value to continuations that were not created by the {\tt\mvcall{}} procedure is unspecified (as indeed it is unspecified now). Suggested formal semantics: $$\hbox{\it \mvcontinue{}} = \lambda\epsilon^*\kappa . \kappa\epsilon^*$$ $$\hbox{\it \mvcall{}} = \hbox{\it twoarg }(\lambda \epsilon_1 \epsilon_2\kappa . \hbox{ \it applicate } \epsilon_1 \langle \rangle \lambda \epsilon^* . \hbox{ \it applicate } \epsilon_2 \epsilon^* \kappa)$$ \end @EOF chmod 666 values.doc echo x - queue.doc cat >queue.doc <<'@EOF' Queues ****** A "queue" is a list where elements can be added to both the front and rear, and removed from the front. A queue may also be used like a stack. * procedure+: make-queue Returns a new, empty queue. * procedure+: queue? OBJ Returns `#t' if OBJ is a queue. * procedure+: queue-empty? Q Returns `#t' if the queue Q is empty. * procedure+: queue-push! Q DATUM Adds DATUM to the front of queue Q. * procedure+: enqueue! Q DATUM Adds DATUM to the rear of queue Q. All of the following functions raise an error if the queue Q is empty. * procedure+: queue-front Q Returns the DATUM at the front of the queue. * procedure+: queue-rear Q Returns the DATUM at the rear of the queue. * procedure+: queue-pop! Q * procedure+: dequeue! Q Both of these procedures remove and return the DATUM at the front of the queue. `queue-pop!' is used to suggest that the queue is being used like a stack. @EOF chmod 666 queue.doc echo x - Makefile cat >Makefile <<'@EOF' # Makefile for Scheme Library # Copyright (C) 1991 Aubrey Jaffer. ffiles = stdio.scm format.scm genwrite.scm obj2str.scm pp.scm pp2str.scm \ ppfile.scm debug.scm lfiles = eval.scm sort.scm comlist.scm logical.scm random.scm rfiles = sc4opt.scm sc4-sc3.scm sc2.scm sc3.scm mularg.scm mulapply.scm afiles = ratize.scm randinex.scm modular.scm prime.scm charplot.scm bfiles = oop.scm cfiles = r4rsyn.scm sc-macro.scm synclo.scm synrul.scm synchk.scm efiles = record.scm promise.scm values.scm queue.scm process.scm \ priorque.scm hash.scm hashtab.scm alist.scm dfiles = ANNOUNCE README ChangeLog require.doc record.doc sc-macro.doc \ format.doc oop.doc values.doc queue.doc mfiles = Makefile require.scm Template.scm mitscheme.init scheme2c.init \ scheme48.init gambit.init t3.init tfiles = test.scm plottest.scm formatst.scm macrotst.scm scmactst.scm sfiles = $(ffiles) $(lfiles) $(rfiles) $(afiles) $(cfiles) $(efiles) shar: slib.shar slib.shar: $(dfiles) $(mfiles) $(sfiles) $(tfiles) $(bfiles) shar $(dfiles) $(mfiles) $(sfiles) $(tfiles) $(bfiles) >slib.shar tar: slib.tar slib.tar: $(dfiles) $(mfiles) $(sfiles) $(tfiles) $(bfiles) tar -cf slib.tar $(dfiles) $(mfiles) $(sfiles) $(tfiles) $(bfiles) tar.Z: slib.tar.Z slib.tar.Z: slib.tar compress slib.tar shar.Z: slib.shar.Z slib.shar.Z: slib.shar compress slib.shar tagfiles = README require.doc $(mfiles) $(sfiles) $(bfiles) #tagfiles = $(bfiles) $(cfiles) macrotst.scm tags: $(tagfiles) etags $(tagfiles) test: $(sfiles) scheme Template.scm $(sfiles) clean: -rm -f *~ *.orig *.rej eval_* core a.out *.o \#* realclean: -rm -f *~ *.orig *.rej eval_* TAGS core a.out *.o \#* @EOF chmod 666 Makefile echo x - require.scm cat >require.scm <<'@EOF' ;;;; Implementation of VICINITY and MODULES for Scheme ;;; Copyright (C) 1991, 1992 Aubrey Jaffer. ;;;; WARNING: this code redefines LOAD. (define (user-vicinity) (case (software-type) ((VMS) "[.]") (else ""))) (define program-vicinity (let ((*vicinity-suffix* (case (software-type) ((NOSVE) '(#\: #\.)) ((AMIGA) '(#\: #\/)) ((UNIX) '(#\/)) ((VMS) '(#\: #\])) ((MSDOS ATARIST) '(#\\)) ((MACOS THINKC) '(#\:))))) (lambda () (let loop ((i (- (string-length *load-pathname*) 1))) (cond ((negative? i) "") ((memv (string-ref *load-pathname* i) *vicinity-suffix*) (substring *load-pathname* 0 (+ i 1))) (else (loop (- i 1)))))))) (define sub-vicinity (case (software-type) ((VMS) (lambda (vic name) (let ((l (string-length vic))) (if (or (zero? (string-length vic)) (not (char=? #\] (string-ref vic (- l 1))))) (string-append vic "[" name "]") (string-append (substring vic 0 (- l 1)) "." name "]"))))) (else (let ((*vicinity-suffix* (case (software-type) ((NOSVE) ".") ((UNIX AMIGA) "/") ((MSDOS ATARIST) "\\")))) (lambda (vic name) (string-append vic name *vicinity-suffix*)))))) (define in-vicinity string-append) (define (make-vicinity ) ) (define *catalog* (map (lambda (p) (cons (car p) (if (pair? (cdr p)) (cons (cadr p) (in-vicinity (library-vicinity) (cddr p) (scheme-file-suffix))) (in-vicinity (library-vicinity) (cdr p) (scheme-file-suffix))))) '( (rev4-optional-procedures . "sc4opt") (rev3-procedures . "sc3") (rev2-procedures . "sc2") (multiarg/and- . "mularg") (multiarg-apply . "mulapply") (rationalize . "ratize") (alist . "alist") (hash . "hash") (hash-table . "hashtab") (logical . "logical") (random . "random") (random-inexact . "randinex") (modular . "modular") (prime . "prime") (charplot . "charplot") (sort . "sort") (common-list-functions . "comlist") (format . "format") (generic-write . "genwrite") (pretty-print . "pp") (pprint-file . "ppfile") (pretty-print-to-string . "pp2str") (object->string . "obj2str") (stdio . "stdio") (debug . "debug") (eval . "eval") (record . "record") (promise . "promise") (synchk . "synchk") (sc-macro . "sc-macro") (macro . "sc-macro") (oop macro . "oop") (values . "values") (queue . "queue") (priority-queue . "priorque") (process . "process") (test . "test") ))) (define *load-pathname* #f) (let ((*old-load* load)) (set! load ;WARNING: redefining LOAD (lambda ( . extra) (let ((old-load-pathname *load-pathname*)) (set! *load-pathname* ) (apply *old-load* extra) (require:provide ) (set! *load-pathname* old-load-pathname))))) ;;;; MODULES (define *modules* '()) (define (require:provided? feature) (if (symbol? feature) (if (memq feature *features*) #t (let ((path (cdr (or (assq feature *catalog*) '(#f . #f))))) (and path (member path *modules*) #t))) (and (member feature *modules*) #t))) (define (require:require feature) (if (symbol? feature) (or (memq feature *features*) (let ((path (cdr (or (assq feature *catalog*) '(#f . #f))))) (cond ((not path) (newline) (display ";required feature not supported: ") (display feature) (newline) (slib:error ";required feature not supported: " feature)) ((member (if (pair? path) (cdr path) path) *modules*)) ((pair? path) (require (car path)) (macro:load (cdr path)) (require:provide feature)) (else (load path) (require:provide feature))))) (or (member feature *modules*) (begin (load feature) (require:provide feature)))) #t) (define (require:provide feature) (if (symbol? feature) (if (not (memq feature *features*)) (set! *features* (cons feature *features*))) (if (not (member feature *modules*)) (set! *modules* (cons feature *modules*))))) (require:provide 'vicinity) (define provide require:provide) (define provided? require:provided?) (define require require:require) (if (inexact? (string->number "0.0")) (provide 'inexact)) (if (rational? (string->number "1/19")) (provide 'rational)) (if (real? (string->number "0.0")) (provide 'real)) (if (complex? (string->number "1+i")) (provide 'complex)) (if (exact? (string->number "9999999999999999999999999999999")) (provide 'bignum)) @EOF chmod 666 require.scm echo x - Template.scm cat >Template.scm <<'@EOF' ;;;; Template for configuration of *features* for Scheme ;;; Copyright (C) 1991, 1992 Aubrey Jaffer. ;;; (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MSDOS are supported. (define (software-type) 'UNIX) ;;; *features* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: (define *features* '( rev4-report ;conforms to ; rev3-report ;conforms to ieee-p1178 ;conforms to ; sicp ;runs code from Structure and ;Interpretation of Computer ;Programs by Abelson and Sussman. rev4-optional-procedures rev3-procedures rev2-procedures multiarg/and- multiarg-apply ; rationalize ; delay ;has delay and force ; i/o-redirection ;with-input-from-file ;with-output-from-file ; char-ready? ;has ; transcript ;transcript-on and transcript-off ; macro ;has r4rs high level macros ; eval ;slib:eval is single argument eval. ; record ;has user defined data structures ; values ;proposed multiple values ; ieee-floating-point ;conforms to full-continuation ;can return multiple times ; sort ; queue ;queues ; pretty-print ; format ; compiler ;has (compiler) ; ed ;(ed) is editor system ;posix (system ) getenv ;posix (getenv ) tmpnam ;posix (tmpnam) program-arguments ;returns list of strings (argv) ; Xwindows ;X support ; curses ;screen management package ; termcap ;terminal description package ; terminfo ;sysV terminal description )) ;;; (OUTPUT-PORT-WIDTH ) (define (output-port-width . arg) 79) ;;; FORCE-OUTPUT flushes any pending output on optional arg output port ;;; use this definition if your system doesn't have such a procedure. (define (force-output . arg) #t) ;;; MOST-POSITIVE-FIXNUM is used in modular.scm (define most-positive-fixnum #x0FFFFFFF) ;;; If your implementation provides eval SLIB:EVAL is single argument ;;; eval using the top-level (user) environment. SLIB:EVAL! is the ;;; same but doesn't neccessarily return a value. ;(define slib:eval eval) ;(define slib:eval! slib:eval) ;;; If your implementation provides R4RS macros: ;(define macro:eval! slib:eval!) ;(define macro:eval slib:eval) ;(define macro:load load) ;;; define an error procedure for the library ;(define slib:error error) ;;; define these as appropriate for your system. (define slib:tab (integer->char 9)) (define slib:form-feed (integer->char 12)) ;;; Define these if your implementation's syntax can support it and if ;;; they are not already defined. ;(define (1+ n) (+ n 1)) ;(define (-1+ n) (+ n -1)) ;(define 1- -1+) ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. (define (implementation-vicinity) (case (software-type) ((UNIX) "/usr/src/scheme/") ((VMS) "scheme$src:") ((MSDOS) "C:\\scheme\\"))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. (define library-vicinity (let ((library-path (if (memq 'getenv *features*) (or (getenv "SCHEME_LIBRARY_PATH") "") ;;; Uses this path if your scheme does not support GETENV. (case (software-type) ((UNIX) "/usr/lib/scheme/") ((VMS) "lib$scheme:") ((MSDOS) "C:\\SLIB\\") (else ""))))) (lambda () library-path))) (define scheme-file-suffix (case (software-type) ((NOSVE) (lambda () "_scm")) (else (lambda () ".scm")))) (define in-vicinity string-append) (load (in-vicinity (library-vicinity) "require" (scheme-file-suffix))) @EOF chmod 666 Template.scm echo x - mitscheme.init cat >mitscheme.init <<'@EOF' ;;;; Initializaiton for SLIB for MITScheme -*-scheme-*- ;;; Copyright (C) 1991, 1992 Aubrey Jaffer. ;;; Make this part of your ~/.scheme.init file. ;;; (software-type) should be set to the generic operating system type. (define (software-type) 'UNIX) ;;; *features* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: (define *features* '( rev4-report ;conforms to ; rev3-report ;conforms to ieee-p1178 ;conforms to sicp ;runs code from Structure and ;Interpretation of Computer ;Programs by Abelson and Sussman. rev4-optional-procedures rev3-procedures rev2-procedures multiarg/and- multiarg-apply rationalize object-hash delay ;has delay and force i/o-redirection ;with-input-from-file ;with-output-from-file char-ready? ;has transcript ;transcript-on and transcript-off ; macro ;has r4rs high level macros eval ;slib:eval is single argument eval. record ;has user defined data structures ; values ;proposed multiple values ieee-floating-point ;conforms to full-continuation ;can return multiple times sort queue ;queues pretty-print ; format compiler ;has (compiler) ; ed ;(ed) is editor ; system ;posix (system ) getenv ;posix (getenv ) ; tmpnam ;posix (tmpnam) ; program-arguments ;returns list of strings (argv) Xwindows ;X support ; curses ;screen management package ; termcap ;terminal description package ; terminfo ;sysV terminal description )) (define getenv get-environment-variable) ;;; (OUTPUT-PORT-WIDTH ) (define output-port-width output-port/x-size) ;;; FORCE-OUTPUT flushes any pending output on optional arg output port ;;; use this definition if your system doesn't have such a procedure. ;(define (force-output . arg) #t) (define force-output flush-output) ;; MOST-POSITIVE-FIXNUM is used in modular.scm (define most-positive-fixnum #x03FFFFFF) ;;; If your implementation provides eval, SLIB:EVAL is single argument ;;; eval using the top-level (user) environment. SLIB:EVAL! is the ;;; same but doesn't neccessarily return a value. ;(define (slib:eval form) (eval form (repl/environment (nearest-repl)))) (define (slib:eval form) (eval form user-initial-environment)) (define slib:eval! slib:eval) ;;; If your implementation provides R4RS macros: ;(define macro:eval! slib:eval!) ;(define macro:eval slib:eval) ;(define macro:load load) ;; define an error procedure for the library (define slib:error error) ;; define these as appropriate for your system. (define slib:tab (integer->char 9)) (define slib:form-feed (integer->char 12)) ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. (define (implementation-vicinity) (case (software-type) ((UNIX) "/usr/src/scheme/") ((VMS) "scheme$src:"))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. (define library-vicinity (let ((library-path (if (memq 'getenv *features*) (or (getenv "SCHEME_LIBRARY_PATH") "") ;;; Uses this path if your scheme does not support GETENV. (case (software-type) ((UNIX) "/usr/lib/scheme/") ((VMS) "lib$scheme:") (else ""))))) (lambda () library-path))) (define (scheme-file-suffix) ".scm") (define in-vicinity string-append) (load (in-vicinity (library-vicinity) "require" (scheme-file-suffix))) @EOF chmod 666 mitscheme.init echo x - scheme2c.init cat >scheme2c.init <<'@EOF' ;;;; Initialisation for SLIB for Scheme->C on Sun -*-scheme-*- ;;; Copyright (C) 1991, 1992 Aubrey Jaffer ;;; and David Love (d.love@daresbury.ac.uk) 10/12/91 ;; NB this is for the 01nov91 version (and, presumably, later ones, ;; although those may not need the bug fixes done at the end). ;; Earlier versions definitely aren't rev4 conformant. Check ;; `ieee-floating-point' and `system' in *features* for non-Sun un*x ;; versions and `system' and the vicinity stuff (at least) for ;; non-un*x versions. ;; Of course, if you make serious use of library functions you'll want ;; to compile them and use Scheme->C modules. (define (software-type) 'UNIX) ;;; *features* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: (define *features* '( rev4-report ;conforms to ;; Follows rev4 as far as I can tell, modulo '() being false, ;; number syntax (see doc), incomplete tail recursion (see ;; docs) and a couple of bugs -- see below. rev3-report ;conforms to ; ieee-p1178 ;conforms to ;; ieee conformance is ruled out by '() being false, if ;; nothing else. ; sicp ;runs code from Structure and ;Interpretation of Computer ;Programs by Abelson and Sussman. rev4-optional-procedures rev3-procedures rev2-procedures multiarg/and- multiarg-apply rationalize object-hash delay ;has delay and force i/o-redirection ;with-input-from-file ;with-output-from-file char-ready? ;has transcript ;transcript-on and transcript-off ; macro ;has r4rs high level macros eval ;slib:eval is single argument eval. ; record ;has user defined data structures ; values ;proposed multiple values ieee-floating-point ;conforms to full-continuation ;can return multiple times ; sort ; queue ;queues pretty-print format ; compiler ;has (compiler) ; ed ;(ed) is editor system ;posix (system ) ;; next three could be added easily to the interpreter ; getenv ;posix (getenv ) ; tmpnam ;posix (tmpnam) ; program-arguments ;returns list of strings (argv) ; Xwindows ;X support ; curses ;screen management package ; termcap ;terminal description package ; terminfo ;sysV terminal description )) (define pretty-print pp) ;;; (OUTPUT-PORT-WIDTH ) (define (output-port-width . arg) 79) ;;; FORCE-OUTPUT flushes any pending output on optional arg output port ;;; use this definition if your system doesn't have such a procedure. ;(define (force-output . arg) #t) (define force-output flush-buffer) ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. (define (implementation-vicinity) (case (software-type) ((UNIX) "/usr/local/lib/scheme/") ((VMS) "scheme$src:") ((MSDOS) "C:\\scheme\\"))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. (define library-vicinity (let ((library-path (if (memq 'getenv *features*) (or (getenv "SCHEME_LIBRARY_PATH") "") ;;; Uses this path if your scheme does not support GETENV. (case (software-type) ((UNIX) "/usr/local/lib/scheme/") ((VMS) "lib$scheme:") ((MSDOS) "C:\\SLIB\\") (else ""))))) (lambda () library-path))) (define scheme-file-suffix (case (software-type) ((NOSVE) (lambda () "_scm")) (else (lambda () ".scm")))) (define in-vicinity string-append) (load (in-vicinity (library-vicinity) "require" (scheme-file-suffix))) ;; MOST-POSITIVE-FIXNUM is used in modular.scm (define most-positive-fixnum 536870911) ;; define an error procedure for the library ;;; If your implementation provides eval, SLIB:EVAL is single argument ;;; eval using the top-level (user) environment. SLIB:EVAL! is the ;;; same but doesn't neccessarily return a value. (define slib:eval eval) (define slib:eval! slib:eval) ;;; If your implementation provides R4RS macros: ;(define macro:eval! slib:eval!) ;(define macro:eval slib:eval) ;(define macro:load load) (define (slib:error . args) (error 'slib-error: "~a" (apply string-append (map (lambda (a) (format " ~a" a)) args)))) ;; define these as appropriate for your system. (define slib:tab (integer->char 9)) (define slib:form-feed (integer->char 12)) ;;; bug fixes for Scheme->C: ;; GCD fails with 0 as argument (define old-gcd gcd) (set! gcd (lambda args (apply old-gcd (remv! 0 args)))) ;; STRING->SYMBOL doesn't allocate a new string (set! string->symbol (let ((fred string->symbol)) (lambda (a) (fred (string-append a ""))))) ;; NUMBER->STRING can generate a leading #? (set! number->string (let ((fred number->string)) (lambda (num . radix) (let ((joe (apply fred num radix))) (if (char=? #\# (string-ref joe 0)) (substring joe 2 (string-length joe)) joe))))) ;; Another bug is bad expansion of LETREC when the body starts with a ;; DEFINE as shown by test.scm -- not fixed here. @EOF chmod 666 scheme2c.init echo x - scheme48.init cat >scheme48.init <<'@EOF' ;;;; Initialisation for SLIB for Scheme48 -*-scheme-*- ;;; Copyright (C) 1992 Aubrey Jaffer. ;;; (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MSDOS are supported. (define (software-type) 'UNIX) ;;; *features* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: (define *features* '( rev4-report ;conforms to ; rev3-report ;conforms to ieee-p1178 ;conforms to ; sicp ;runs code from Structure and ;Interpretation of Computer ;Programs by Abelson and Sussman. rev4-optional-procedures ; rev3-procedures ; rev2-procedures multiarg/and- multiarg-apply rationalize delay ;has delay and force i/o-redirection ;with-input-from-file ;with-output-from-file char-ready? ;has ; transcript ;transcript-on and transcript-off ; macro ;has r4rs high level macros eval ;slib:eval is single argument eval. ; record ;has user defined data structures ; values ;proposed multiple values ; ieee-floating-point ;conforms to full-continuation ;can return multiple times ; sort ; queue ;queues ; pretty-print ; format ; compiler ;has (compiler) ; ed ;(ed) is editor ; system ;posix (system ) ; getenv ;posix (getenv ) ; tmpnam ;posix (tmpnam) ; program-arguments ;returns list of strings (argv) ; Xwindows ;X support ; curses ;screen management package ; termcap ;terminal description package ; terminfo ;sysV terminal description )) ;;; (OUTPUT-PORT-WIDTH ) (define (output-port-width . arg) 79) ;;; FORCE-OUTPUT flushes any pending output on optional arg output port ;;; use this definition if your system doesn't have such a procedure. (define (force-output . arg) ((access-scheme48 'force-output) (if (null? arg) (current-output-port) (car arg)))) ;;; MOST-POSITIVE-FIXNUM is used in modular.scm (define most-positive-fixnum #x1FFFFFFF) ;;; If your implementation provides eval, SLIB:EVAL is single argument ;;; eval using the top-level (user) environment. SLIB:EVAL! is the ;;; same but doesn't neccessarily return a value. (define (slib:eval form) ((access-scheme48 'eval) form (access-scheme48 'user-package))) (define slib:eval! slib:eval) ;;; If your implementation provides R4RS macros: ;(define macro:eval! slib:eval!) ;(define macro:eval slib:eval) ;(define macro:load load) ;;; define an error procedure for the library (define slib:error (access-scheme48 'error)) ;;; define these as appropriate for your system. (define slib:tab (integer->char 9)) (define slib:form-feed (integer->char 12)) ;;; Define these if your implementation's syntax can support them and if ;;; they are not already defined. ;(define (1+ n) (+ n 1)) ;(define (-1+ n) (+ n -1)) ;(define 1- -1+) ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxiliary files to your Scheme ;;; implementation reside. ; For scheme48, perhaps something like /usr/local/src/scheme48/misc/ ? ;(define (implementation-vicinity) ; (case (software-type) ; ((UNIX) "/usr/src/scheme/") ; ((VMS) "scheme$src:") ; ((MSDOS) "C:\\scheme\\"))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. (define (library-vicinity) "~jar/slib/") (define scheme-file-suffix (case (software-type) ((NOSVE) (lambda () "_scm")) (else (lambda () ".scm")))) (define in-vicinity string-append) (load (in-vicinity (library-vicinity) "require" (scheme-file-suffix))) @EOF chmod 666 scheme48.init echo x - gambit.init cat >gambit.init <<'@EOF' ;;;; Initialisation for SLIB for Gambit -*-scheme-*- ;;; Copyright (C) 1991, 1992 Aubrey Jaffer ;;; Updated 1992 February 1 for Gambit v1.71 -- by Ken Dickey (define (SOFTWARE-TYPE) 'UNIX) ; 'Amiga 'Mac ... ? ;;; *features* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: (define *features* '( rev4-report ;conforms to ; rev3-report ;conforms to ieee-p1178 ;conforms to sicp ;runs code from Structure and ;Interpretation of Computer ;Programs by Abelson and Sussman. rev4-optional-procedures rev3-procedures rev2-procedures multiarg/and- multiarg-apply object-hash rationalize delay ;has delay and force i/o-redirection ;with-input-from-file ;with-output-from-file char-ready? ;has transcript ;transcript-on and transcript-off ; macro ;has r4rs high level macros eval ;slib:eval is single argument eval. ; record ;has user defined data structures ; values ;proposed multiple values ieee-floating-point ;conforms to full-continuation ;can return multiple times ; sort ; queue ;queues ; pretty-print ; format ; compiler ;has (compiler) ; ed ;(ed) is editor system ;posix (system ) ; getenv ;posix (getenv ) ; tmpnam ;posix (tmpnam) ; program-arguments ;returns list of strings (argv) ; Xwindows ;X support ; curses ;screen management package ; termcap ;terminal description package ; terminfo ;sysV terminal description )) ;;; (OUTPUT-PORT-WIDTH ) (define (output-port-width . arg) 79) ;;; FORCE-OUTPUT flushes any pending output on optional arg output port ;;; use this definition if your system doesn't have such a procedure. (define (force-output . arg) #t) ;; MOST-POSITIVE-FIXNUM is used in modular.scm (define most-positive-fixnum #x1FFFFFFF) ;; 3-bit tag for 68K ;;; If your implementation provides eval, SLIB:EVAL is single argument ;;; eval using the top-level (user) environment. SLIB:EVAL! is the ;;; same but doesn't neccessarily return a value. (define SLIB:EVAL ##eval-global);; Gambit v1.71 (define slib:eval! slib:eval) ;;; If your implementation provides R4RS macros: ;(define macro:eval! slib:eval!) ;(define macro:eval slib:eval) ;(define macro:load load) ;; define an error procedure for the library (define SLIB:ERROR error) (define SYSTEM ##unix-system) ;; obviously for Unix ;; define these as appropriate for your system. (define slib:tab (integer->char 9)) (define slib:form-feed (integer->char 12)) (define (1+ n) (+ n 1)) (define (-1+ n) (- n 1)) (define 1- -1+) ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. (define (implementation-vicinity) (case (software-type) ((UNIX) "/usr/local/lib/scheme/") ((VMS) "scheme$src:") ((AMIGA) "dh0:scm/") ((MACOS) "::Scheme Code:"))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. (define library-vicinity (let ((library-path (if (memq 'getenv *features*) (or (getenv "SCHEME_LIBRARY_PATH") "") ;;; Uses this path if your scheme does not support GETENV. (case (software-type) ((UNIX) "/usr/local/lib/scheme/") ((AMIGA) "dh0:scm/Library/") ((VMS) "lib$scheme:") ((MSDOS) "C:\\SLIB\\") (else ""))))) (lambda () library-path))) (define (scheme-file-suffix) ".scm") (define in-vicinity string-append) (load (in-vicinity (library-vicinity) "require" (scheme-file-suffix))) ;;; --- E O F --- @EOF chmod 666 gambit.init echo x - t3.init cat >t3.init <<'@EOF' ;;;; Initialization file for SLIB for T3.1. ;;; Copyright (C) 1991, 1992 Aubrey Jaffer and David Carlton. ;;; To get into the scheme mode in T, type (scheme-reset) or ;;; (scheme-breakpoint). ;;; (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MSDOS are supported. (define (software-type) 'UNIX) ;;; *features* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: (define *features* '( ; rev4-report ;conforms to rev3-report ;conforms to ; ieee-p1178 ;conforms to ; sicp ;runs code from Structure and ;Interpretation of Computer ;Programs by Abelson and Sussman. rev4-optional-procedures rev3-procedures rev2-procedures multiarg/and- multiarg-apply rationalize object-hash delay ;has delay and force i/o-redirection ;with-input-from-file ;with-output-from-file char-ready? ;has transcript ;transcript-on and transcript-off ; macro ;has r4rs high level macros eval ;slib:eval is single argument eval. ; record ;has user defined data structures ; values ;proposed multiple values ; ieee-floating-point ;conforms to full-continuation ;can return multiple times ; sort ; queue ;queues ; pretty-print format ; compiler ;has (compiler) ; ed ;(ed) is editor ; system ;posix (system ) ; getenv ;posix (getenv ) ; tmpnam ;posix (tmpnam) program-arguments ;returns list of strings (argv) ; Xwindows ;X support ; curses ;screen management package ; termcap ;terminal description package ; terminfo ;sysV terminal description )) (set ((*value scheme-internal-env 'standard-early-binding-env) 'list?) #f) (define list? proper-list?) (define program-arguments command-line) (define pretty-print-to-string (lambda (obj) (with-output-to-string str (pretty-print obj str)))) ;;; (OUTPUT-PORT-WIDTH ) (define output-port-width (lambda x (if (null? x) (line-length (standard-input)) (line-length (car x))))) ;;; FORCE-OUTPUT flushes any pending output on optional arg output port ;;; use this definition if your system doesn't have such a procedure. ;;; T already has it. ;;; MOST-POSITIVE-FIXNUM is used in modular.scm ;;; T already has it. ;;; If your implementation provides eval, SLIB:EVAL is single argument ;;; eval using the top-level (user) environment. SLIB:EVAL! is the ;;; same but doesn't neccessarily return a value. (define (slib:eval form) (eval form scheme-env)) (define slib:eval! slib:eval) ;;; If your implementation provides R4RS macros: ;(define macro:eval! slib:eval!) ;(define macro:eval slib:eval) ;(define macro:load load) ;;; define an error procedure for the library (define slib:error error) ;;; define these as appropriate for your system. (define slib:tab #\tab) (define slib:form-feed #\form) ;;; Define these if your implementation's syntax can support it and if ;;; they are not already defined. ;(define (1+ n) (+ n 1)) (define (1- n) (+ n -1)) ;(define (-1+ n) (+ n -1)) ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. (define (implementation-vicinity) (case (software-type) ((UNIX) "/usr/local/lib/tsystem/") ; Differs at different sites. ((VMS) "tsystem:") ((MSDOS) "C:\\tsystem\\"))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. (define library-vicinity (let ((library-path (if (memq 'getenv *features*) (or (getenv "SCHEME_LIBRARY_PATH") "") ;;; Uses this path if your scheme does not support GETENV. (case (software-type) ((UNIX) "/usr/lib/scheme/") ((VMS) "lib$scheme:") ((MSDOS) "C:\\SLIB\\") (else ""))))) (lambda () library-path))) (define scheme-file-suffix (case (software-type) ((NOSVE) (lambda () "_scm")) (else (lambda () ".scm")))) (define in-vicinity string-append) (load (in-vicinity (library-vicinity) "require" (scheme-file-suffix))) @EOF chmod 666 t3.init echo x - stdio.scm cat >stdio.scm <<'@EOF' ;;;; Implementation of functions for Scheme ;;; Copyright (C) 1991 Aubrey Jaffer. ;;; Floating point is not handled yet. It should not be hard to do. (define (stdio:iprintf out format . args) (let loop ((pos 0) (args args)) (if (< pos (string-length format)) (case (string-ref format pos) ((#\\ ) (set! pos (+ pos 1)) (case (string-ref format pos) ((#\n #\N) (out #\newline)) ((#\t #\T) (out slib:tab)) ((#\r #\R) (out #\return)) ((#\f #\F) (out slib:form-feed)) (else (out (string-ref format pos)))) (loop (+ pos 1) args)) ((#\%) (set! pos (+ pos 1)) (letrec ((left-adjust #f) (pad-char (if (char=? #\0 (string-ref format pos)) #\0 #\ )) (width 0) (prec #f) (pad (lambda (s) (cond ((<= width (string-length s)) s) (left-adjust (string-append s (make-string (- width (string-length s)) #\ ))) (else (string-append (make-string (- width (string-length s)) pad-char) s)))))) (let ilp ((pos pos)) (case (string-ref format pos) ((#\d #\D #\u #\U) (out (pad (cond ((symbol? (car args)) (symbol->string (car args))) ((number? (car args)) (number->string (car args))) ((not (car args)) "0") (else "1")))) (loop (+ pos 1) (cdr args))) ((#\c #\C) (out (pad (string (car args)))) (loop (+ pos 1) (cdr args))) ((#\o #\O) (out (pad (number->string (car args) 8))) (loop (+ pos 1) (cdr args))) ((#\x #\X) (out (pad (number->string (car args) 16))) (loop (+ pos 1) (cdr args))) ((#\l #\L) (ilp (+ pos 1))) ((#\-) (set! left-adjust #t) (ilp (+ pos 1))) ((#\.) (set! prec 0) (set! pos (+ 1 pos)) (let iilp () (case (string-ref format pos) ((#\*) (set! prec (car args)) (set! args (cdr args)) (ilp (+ pos 1))) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (set! prec (+ (* prec 10) (- (char->integer (string-ref format pos)) (char->integer #\0)))) (set! pos (+ 1 pos)) (iilp)) (else (ilp pos))))) ((#\%) (out #\%) (loop (+ pos 1) args)) ((#\s #\S) (if (or (not prec) (>= prec (string-length (car args)))) (out (pad (car args))) (out (pad (substring (car args) 0 prec)))) (loop (+ pos 1) (cdr args))) ((#\*) (set! width (car args)) (set! args (cdr args)) (ilp (+ pos 1))) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (set! width (+ (* width 10) (- (char->integer (string-ref format pos)) (char->integer #\0)))) (ilp (+ pos 1))) (else (out #\%) (out (string-ref format pos)) (loop (+ pos 1) args)))))) (else (out (string-ref format pos)) (loop (+ pos 1) args)))))) (define (stdio:printf format . args) (apply stdio:iprintf display format args)) (define (stdio:fprintf port format . args) (if (equal? port (current-output-port)) (apply stdio:iprintf display format args) (apply stdio:iprintf (lambda (x) (display x port)) format args))) (define (stdio:sprintf s format . args) (let ((p 0)) (apply stdio:iprintf (lambda (x) (cond ((string? x) (do ((i 0 (+ i 1))) ((>= i (string-length x))) (string-set! s p (string-ref x i)) (set! p (+ p 1)))) ((char? x) (string-set! s p x) (set! p (+ p 1))) (else (string-set! s p #\?) (set! p (+ p 1))))) format args) p)) (define printf stdio:printf) (define fprintf stdio:fprintf) (define sprintf stdio:sprintf) (define stdin (current-input-port)) (define stdout (current-output-port)) (define stderr (current-output-port)) @EOF chmod 666 stdio.scm echo x - format.scm cat >format.scm <<'@EOF' ;;;; Common LISP like text output formatter for R4RS Scheme ; ; Copyright (C) Feb 1992 Dirk Lutzebaeck (lutzebaeck@fokus.gmd.berlin.dbp.de) ; ; Authors of the original version were Ken Dickey and Aubrey Jaffer. ; Please send error reports to the email address above. ; ; Version 2.1 ; ; Exports: ; ; (format destination format-string . arguments) procedure ; ; Returns #t, #f or a string; has side effect of printing according to ; . If is #t, the output is to the current ; output port and #t is returned. If is #f, a formatted ; string is returned as the result of the call. If is a ; string, the output is appended to that string by string-append (note: ; this returns a newly allocated string). Otherwise must ; be an output port and #t is returned. must be a ; string. In case of a formatting error format returns #f and prints a ; message on the current output port. Characters are output as if the ; string were output by the DISPLAY function with the exception of those ; prefixed by a tilde (~). For a detailed description of the ; syntax please consult a Common LISP format reference ; manual. For a quick overview of implemented, not supported and ; extended control properties of see "format.doc". For a ; test suite to verify this format implemention load "formatst.scm". ; ; (obj->string arbitray-scheme-object) procedure ; (string-upcase string) procedure ; (string-downcase string) procedure ; (string-capitalize string) procedure ; (string-capitalize-first string) procedure ; ; For a documentation of these procedures see below. ; ; Changelog: ; ; Version 2.1 [dl] ; * Tested with scm3c11, Elk 1.5, MIT C-Scheme 7.1, UMB Scheme 2.5, ; and Scheme->C 01nov91 (see "formatst.scm" for error reports) ; * ~e,~f,~g,~$ fake floating point formatting by number->string; ; no directive parameters are implemented ; * replaced ~g by ~y due to ~g CL floating point formatting directive ; * ~{~} with modifiers implemented (nested iterations allowed) ; * errors in format-string are showed by a "<--" in the format string ; * `.' as a directive parameter separator is not supported anymore ; * ~[ ~; ~] with modifiers implemented (nested conditionals allowed) ; * ~? expects a list now (as CL does) ; ~@? works now as ~? in 2.0 did. ; * ~*, ~n*, ~:*, ~n:*, ~@*, ~n@* implemented ; * ~:p implemented ; * don't strip the argument error messages anymore ; * format returns now #t instead of () if destination is an output port ; ; Version 2.0 [dl] ; * Tested with scm3c11, Elk 1.5, MIT C-Scheme 7.1, UMB Scheme 2.5 and ; Scheme->C 01nov91. (see "formatst.scm" for error reports) ; * completely rewritten Version of SLIB format Version 1.4 ; * removed C-style padding support ; ;;; SCHEME IMPLEMENTATION DEPENDENCIES --------------------------------------- ;; SCM/SLIB configuration below ;; (for other interpreters/libraries configure as apropriate) ;; The pretty printer (format:pp arg . port). (require 'pretty-print) (define format:pp pretty-print) ;(define format:pp pp) ;; The form feed character. (define format:form-feed slib:form-feed) ;(define format:form-feed (integer->char 12)) ;; The tabulator character. (define format:tab slib:tab) ;(define format:tab (integer->char 9)) ;; Flushes an output port (format:force-output output-port). (define format:force-output force-output) ;(define (format:force-output port) #t) ;; A null argument closure to jump to the interpreters toplevel continuation; ;; format:abort may return and in this case the format returns properly ;; and returns #f. (define format:abort slib:error) ;(define (format:abort) #t) ;; format:char->string converts a character into a slashified string as ;; done by `write'. The following procedure is dependent on the integer ;; representation of characters and assumes a character number according to ;; the ASCII character set. (define (format:char->string ch) (let ((int-rep (char->integer ch))) (string-append "#\\" (cond ; THIS IS IMPLEMENTATION DEPENDENT ((char=? ch #\newline) "newline") ((and (>= int-rep 0) (<= int-rep 32)) (vector-ref format:ascii-non-printable-charnames int-rep)) ((= int-rep 127) "del") ((>= int-rep 128) (number->string int-rep 8)) ; octal repr. (else (string ch)))))) (define format:ascii-non-printable-charnames '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "ht" "nl" "vt" "np" "cr" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak" "syn" "etb" "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space")) ;;;-------------------------------------------------------------------------- (define format:destination #f) (define format:output-buffer "") (define format:flush-output #f) (define format:case-conversion #f) (define format:error-continuation #f) (define format:args #f) (define (format:out-str str) ; append to format:output-buffer (set! format:output-buffer (string-append format:output-buffer (if (procedure? format:case-conversion) (format:case-conversion str) str)))) (define (format:out-char ch) (format:out-str (string ch))) (define (format:error . args) ; applies format:error-continuation (let ((error-continuation format:error-continuation) (format-args format:args)) (format:format #t "FORMAT: ") (apply format:format `(#t ,@args)) (format:format #t ", ARGS: ~a~%" format-args) (format:abort "") ; we might jump to the top level cont. (error-continuation #f))) ; or to the local error continuation (define (format:format . args) ; the format wrapper (call-with-current-continuation (lambda (cont) (set! format:error-continuation cont) (set! format:args args) (if (< (length args) 2) (format:error "not enough arguments")) (let ((destination (car args)) (format-string (cadr args)) (arglist (cddr args))) (set! format:destination (cond ((boolean? destination) (if destination (current-output-port) #f)) ((output-port? destination) destination) ((string? destination) destination) (else (format:error "illegal destination `~a'" destination)))) (if (not (string? format-string)) (format:error "illegal format string `~a'" format-string)) (set! format:output-buffer "") (set! format:flush-output #f) (set! format:case-conversion #f) ; modifier case conversion procedure (let ((arg-pos (format:format-work format-string arglist)) (arg-len (length arglist))) (cond ((< arg-pos arg-len) (format:error "~a superfluous argument~:p" (- arg-len arg-pos))) ((> arg-pos arg-len) (format:error "~a missing argument~:p" (- arg-pos arg-len))) ((output-port? format:destination) (display format:output-buffer format:destination) (if format:flush-output (format:force-output format:destination)) #t) ((string? format:destination) (string-append format:destination format:output-buffer)) (else format:output-buffer))))))) (define format:parameter-characters '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\')) (define (format:format-work format-string arglist) ; does the formatting work (letrec ((format-string-len (string-length format-string)) (pos 0) ; input format-string position (arg-pos 0) ; argument position in arglist (arg-len (length arglist)) ; number of arguments (modifier #f) ; 'colon | 'at | 'colon-at | #f (params '()) ; directive parameter list (param-value-found #f) ; a directive parameter value found (conditional-nest 0) ; conditional nesting level (clause-pos 0) ; last cond. clause beginning char pos (clause-default #f) ; conditional default clause string (clauses '()) ; conditional clause string list (conditional-type #f) ; reflects the contional modifiers (conditional-arg #f) ; argument to apply the conditional (iteration-nest 0) ; iteration nesting level (iteration-pos pos) ; iteration string beginning char pos (iteration-type #f) ; reflects the iteration modifiers (max-iterations #f) ; maximum number of iterations (next-char ; gets the next char from format-string (lambda () (let ((ch (peek-next-char))) (set! pos (+ 1 pos)) ch))) (peek-next-char (lambda () (if (>= pos format-string-len) (format:error "illegal format string") (string-ref format-string pos)))) (one-positive-integer? (lambda (params) (cond ((null? params) #f) ((and (integer? (car params)) (>= (car params) 0) (= (length params) 1)) #t) (else (fail "one positive integer parameter expected"))))) (next-arg (lambda () (if (>= arg-pos arg-len) (format:error "missing argument(s)")) (add-arg-pos 1) (list-ref arglist (- arg-pos 1)))) (prev-arg (lambda () (add-arg-pos -1) (if (negative? arg-pos) (format:error "missing backward argument(s)")) (list-ref arglist arg-pos))) (rest-args (lambda () (let loop ((l arglist) (k arg-pos)) ; list-tail definition (if (zero? k) l (loop (cdr l) (- k 1)))))) (add-arg-pos (lambda (n) (set! arg-pos (+ n arg-pos)))) (fail (lambda (fmt . args) (apply format:error `(,(string-append fmt ", POS: \"~a\"") ,@args ,(string-append (substring format-string 0 pos) "<--" (substring format-string pos format-string-len)))))) (anychar-dispatch ; dispatches the format-string (lambda () (if (>= pos format-string-len) arg-pos ; used for ~? continuance (let ((char (next-char))) (cond ((char=? char #\~) (set! modifier #f) (set! params '()) (set! param-value-found #f) (tilde-dispatch)) (else (if (and (zero? conditional-nest) (zero? iteration-nest)) (format:out-char char)) (anychar-dispatch))))))) (tilde-dispatch (lambda () (cond ((>= pos format-string-len) (format:out-str "~") ; tilde at end of string is just output arg-pos) ; used for ~? continuance ((and (or (zero? conditional-nest) (memv (peek-next-char) ; find conditional directives (append '(#\[ #\] #\; #\: #\@ #\^) format:parameter-characters))) (or (zero? iteration-nest) (memv (peek-next-char) ; find iteration directives (append '(#\{ #\} #\: #\@ #\^) format:parameter-characters)))) (case (char-upcase (next-char)) ;; format directives ((#\A) ; Any -- for humans (format:out-str (format:obj->str-padded (memq modifier '(at colon-at)) (next-arg) #f params)) (anychar-dispatch)) ((#\S) ; Slashified -- for parsers (format:out-str (format:obj->str-padded (memq modifier '(at colon-at)) (next-arg) #t params)) (anychar-dispatch)) ((#\D) ; Decimal (format:out-str (format:num->str-padded modifier (next-arg) params 10 "#d")) (anychar-dispatch)) ((#\X) ; Hexadecimal (format:out-str (format:num->str-padded modifier (next-arg) params 16 "#x")) (anychar-dispatch)) ((#\O) ; Octal (format:out-str (format:num->str-padded modifier (next-arg) params 8 "#o")) (anychar-dispatch)) ((#\B) ; Binary (format:out-str (format:num->str-padded modifier (next-arg) params 2 "#b")) (anychar-dispatch)) ((#\R) ; any Radix (if (null? params) (fail "~~r not implemented") (format:out-str (format:num->str-padded modifier (next-arg) (cdr params) (car params) "#r"))) (anychar-dispatch)) ((#\E #\F #\G #\$) ; Floating point (not implemented) (format:out-str (number->string (next-arg))) (anychar-dispatch)) ((#\C) ; Character (let ((ch (if (one-positive-integer? params) (integer->char (car params)) (next-arg)))) (if (not (char? ch)) (fail "~~c expects a character")) (if (eq? modifier 'at) (format:out-str (obj->string ch 'slashify)) (format:out-char ch))) (anychar-dispatch)) ((#\P) ; Plural (if (memq modifier '(colon colon-at)) (prev-arg)) (let ((arg (next-arg))) (if (not (number? arg)) (fail "~~p expects a number argument")) (if (= arg 1) (if (memq modifier '(at colon-at)) (format:out-str "y")) (if (memq modifier '(at colon-at)) (format:out-str "ies") (format:out-str "s")))) (anychar-dispatch)) ((#\~) ; Tilde (if (one-positive-integer? params) (format:out-str (make-string (car params) #\~)) (format:out-str "~")) (anychar-dispatch)) ((#\% #\&) ; Newline (Freshline is the same) (if (one-positive-integer? params) (format:out-str (make-string (car params) #\newline)) (format:out-char #\newline)) (anychar-dispatch)) ((#\_) ; Space (if (one-positive-integer? params) (format:out-str (make-string (car params) #\space)) (format:out-str " ")) (anychar-dispatch)) ((#\T) ; Tab (if (one-positive-integer? params) (format:out-str (make-string (car params) format:tab)) (format:out-char format:tab)) (anychar-dispatch)) ((#\|) ; Page Seperator (if (one-positive-integer? params) (format:out-str (make-string (car params) format:form-feed)) (format:out-char format:form-feed)) (anychar-dispatch)) ((#\Y) ; Pretty-print (if (not format:destination) (fail "~y not supported with string output") (format:pp (next-arg))) (anychar-dispatch)) ((#\? #\K) ; Indirection (is "~K" in T) (cond ((memq modifier '(colon colon-at)) (fail "illegal modifier in ~~?")) ((eq? modifier 'at) (let* ((frmt (next-arg)) (args (rest-args))) (add-arg-pos (format:format-work frmt args)))) (else (let* ((frmt (next-arg)) (args (next-arg))) (format:format-work frmt args)))) (anychar-dispatch)) ((#\!) ; Flush output (set! format:flush-output #t) (anychar-dispatch)) ((#\newline) ; Continuation lines (if (eq? modifier 'at) (format:out-char #\newline)) (if (< pos format-string-len) (do ((ch (peek-next-char) (peek-next-char))) ((or (not (char-whitespace? ch)) (= pos (- format-string-len 1)))) (if (eq? modifier 'colon) (format:out-char (next-char)) (next-char)))) (anychar-dispatch)) ((#\*) ; Argument jumping (case modifier ((colon) ; jump backwards (if (one-positive-integer? params) (do ((i 0 (+ i 1))) ((= i (car params))) (prev-arg)) (prev-arg))) ((at) ; jump absolute (set! arg-pos (if (one-positive-integer? params) (car params) 0))) ((colon-at) (fail "illegal modifier `:@' in ~~* directive")) (else ; jump forward (if (one-positive-integer? params) (do ((i 0 (+ i 1))) ((= i (car params))) (next-arg)) (next-arg)))) (anychar-dispatch)) ((#\() ; Case conversion begin (set! format:case-conversion (case modifier ((at) string-capitalize-first) ((colon) string-capitalize) ((colon-at) string-upcase) (else string-downcase))) (anychar-dispatch)) ((#\)) ; Case conversion end (if (not format:case-conversion) (fail "missing ~~(")) (set! format:case-conversion #f) (anychar-dispatch)) ((#\[) ; Conditional begin (set! conditional-nest (+ conditional-nest 1)) (cond ((= conditional-nest 1) (set! clause-pos pos) (set! clause-default #f) (set! clauses '()) (set! conditional-type (case modifier ((at) 'if-then) ((colon) 'if-else-then) ((colon-at) (fail "illegal modifier in ~~[")) (else 'num-case))) (set! conditional-arg (if (one-positive-integer? params) (car params) (next-arg))))) (anychar-dispatch)) ((#\;) ; Conditional separator (if (zero? conditional-nest) (fail "~~; not in ~~[~~] conditional")) (if (not (null? params)) (fail "no parameter allowed in ~~;")) (if (= conditional-nest 1) (let ((clause-str (cond ((eq? modifier 'colon) (set! clause-default #t) (substring format-string clause-pos (- pos 3))) ((memq modifier '(at colon-at)) (fail "illegal modifier in ~~;")) (else (substring format-string clause-pos (- pos 2)))))) (set! clauses (append clauses (list clause-str))) (set! clause-pos pos))) (anychar-dispatch)) ((#\]) ; Conditional end (if (zero? conditional-nest) (fail "missing ~~[")) (set! conditional-nest (- conditional-nest 1)) (if modifier (fail "no modifier allowed in ~~]")) (if (not (null? params)) (fail "no parameter allowed in ~~]")) (cond ((zero? conditional-nest) (let ((clause-str (substring format-string clause-pos (- pos 2)))) (if clause-default (set! clause-default clause-str) (set! clauses (append clauses (list clause-str))))) (case conditional-type ((if-then) (if conditional-arg (format:format-work (car clauses) (list conditional-arg)))) ((if-else-then) (add-arg-pos (format:format-work (if conditional-arg (cadr clauses) (car clauses)) (rest-args)))) ((num-case) (if (or (not (integer? conditional-arg)) (< conditional-arg 0)) (fail "argument not a positive integer")) (if (not (and (>= conditional-arg (length clauses)) (not clause-default))) (add-arg-pos (format:format-work (if (>= conditional-arg (length clauses)) clause-default (list-ref clauses conditional-arg)) (rest-args)))))))) (anychar-dispatch)) ((#\{) ; Iteration begin (set! iteration-nest (+ iteration-nest 1)) (cond ((= iteration-nest 1) (set! iteration-pos pos) (set! iteration-type (case modifier ((at) 'rest-args) ((colon) 'sublists) ((colon-at) 'rest-sublists) (else 'list))) (set! max-iterations (if (one-positive-integer? params) (car params) #f)))) (anychar-dispatch)) ((#\}) ; Iteration end (if (zero? iteration-nest) (fail "missing ~~{")) (set! iteration-nest (- iteration-nest 1)) (case modifier ((colon) (if (not max-iterations) (set! max-iterations 1))) ((colon-at at) (fail "illegal modifier")) (else (if (not max-iterations) (set! max-iterations 100)))) (if (not (null? params)) (fail "no parameters allowed in ~~}")) (if (zero? iteration-nest) (let ((iteration-str (substring format-string iteration-pos (- pos (if modifier 3 2))))) (if (string=? iteration-str "") (set! iteration-str (next-arg))) (case iteration-type ((list) (let ((args (next-arg)) (args-len 0)) (if (not (list? args)) (fail "expected a list argument")) (set! args-len (length args)) (do ((arg-pos 0 (+ arg-pos (format:format-work iteration-str (list-tail args arg-pos)))) (i 0 (+ i 1))) ((or (>= arg-pos args-len) (>= i max-iterations)))))) ((sublists) (let ((args (next-arg)) (args-len 0)) (if (not (list? args)) (fail "expected a list argument")) (set! args-len (length args)) (do ((arg-pos 0 (+ arg-pos 1))) ((or (>= arg-pos args-len) (>= arg-pos max-iterations))) (let ((sublist (list-ref args arg-pos))) (if (not (list? sublist)) (fail "expected a list of lists argument")) (format:format-work iteration-str sublist))))) ((rest-args) (let* ((args (rest-args)) (args-len (length args)) (usedup-args (do ((arg-pos 0 (+ arg-pos (format:format-work iteration-str (list-tail args arg-pos)))) (i 0 (+ i 1))) ((or (>= arg-pos args-len) (>= i max-iterations)) arg-pos)))) (add-arg-pos usedup-args))) ((rest-sublists) (let* ((args (rest-args)) (args-len (length args)) (usedup-args (do ((arg-pos 0 (+ arg-pos 1))) ((or (>= arg-pos args-len) (>= arg-pos max-iterations)) arg-pos) (let ((sublist (list-ref args arg-pos))) (if (not (list? sublist)) (fail "expected list arguments")) (format:format-work iteration-str sublist))))) (add-arg-pos usedup-args))) (else (fail "internal error in ~~}"))))) (anychar-dispatch)) ((#\^) ; Up and out (let* ((continue (cond ((not (null? params)) (not (case (length params) ((1) (zero? (car params))) ((2) (= (list-ref params 0) (list-ref params 1))) ((3) (<= (list-ref params 0) (list-ref params 1) (list-ref params 2))) (else (fail "too much parameters"))))) (format:case-conversion ; if conversion stop conversion (set! format:case-conversion string-copy) #t) ((= iteration-nest 1) #t) ((= conditional-nest 1) #t) ((>= arg-pos arg-len) (set! pos format-string-len) #f) (else #t)))) (if continue (anychar-dispatch)))) ;; format directive modifiers and parameters ((#\@) ; `@' modifier (if (eq? modifier 'colon-at) (fail "double `@' modifier")) (set! modifier (if (eq? modifier 'colon) 'colon-at 'at)) (tilde-dispatch)) ((#\:) ; `:' modifier (if modifier (fail "illegal `:' modifier position")) (set! modifier 'colon) (tilde-dispatch)) ((#\') ; Character parameter (if modifier (fail "misplaced modifier")) (set! params (append params (list (char->integer (next-char))))) (set! param-value-found #t) (tilde-dispatch)) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr (if modifier (fail "misplaced modifier")) (let ((num-str-beg (- pos 1)) (num-str-end pos)) (do ((ch (peek-next-char) (peek-next-char))) ((not (char-numeric? ch))) (next-char) (set! num-str-end (+ 1 num-str-end))) (set! params (append params (list (string->number (substring format-string num-str-beg num-str-end)))))) (set! param-value-found #t) (tilde-dispatch)) ((#\V) ; Variable parameter from next argum. (if modifier (fail "misplaced modifier")) (set! params (append params (list (next-arg)))) (set! param-value-found #t) (tilde-dispatch)) ((#\#) ; Parameter is number of remaining args (if modifier (fail "misplaced modifier")) (set! params (append params (list (length (rest-args))))) (set! param-value-found #t) (tilde-dispatch)) ((#\,) ; Parameter separators (if modifier (fail "misplaced modifier")) (if (not param-value-found) (set! params (append params '(#f)))) ; append empty paramtr (set! param-value-found #f) (tilde-dispatch)) (else ; Unknown tilde directive (fail "unknown control character `~c'" (string-ref format-string (- pos 1)))))) (else (anychar-dispatch)))))) ; in case of conditional (anychar-dispatch) ; start the formatting arg-pos)) ; return the position in the arg. list (define (format:obj->str-padded pad-left obj slashify params) (let ((mincol 0) (colinc 1) ; sorry I don't understand this CL parm (minpad 0) (padchar #\space) (objstr (if slashify (obj->string obj 'slashify) (obj->string obj)))) (if (null? params) objstr (begin (set! params (append params '(#f #f #f #f))) (if (list-ref params 0) (set! mincol (list-ref params 0))) (if (list-ref params 1) (set! colinc (list-ref params 1))) (if (list-ref params 2) (set! minpad (list-ref params 2))) (if (list-ref params 3) (set! padchar (integer->char (list-ref params 3)))) (format:pad-str objstr (negative? mincol) pad-left (abs mincol) minpad padchar))))) (define (format:num->str-padded modifier number params radix-num radix-prefix) (if (not (number? number)) (format:error "argument not a number")) (let ((mincol 0) (padchar #\space) (commachar #\,) (commawidth 3) ; an extension to CL (numstr-len 0) (numstr (number->string number radix-num))) (if (and (null? params) (not modifier)) numstr (begin (set! params (append params '(#f #f #f #f))) (if (list-ref params 0) (set! mincol (list-ref params 0))) (if (list-ref params 1) (set! padchar (integer->char (list-ref params 1)))) (if (list-ref params 2) (set! commachar (integer->char (list-ref params 2)))) (if (list-ref params 3) (set! commawidth (list-ref params 3))) (set! numstr-len (string-length numstr)) (if (and (memq modifier '(colon colon-at)) ; insert comma character (integer? number)) ; only integers are ,-separated (set! numstr (do ((s "") (i (- numstr-len commawidth) (- i commawidth))) ((or (zero? i) (negative? i)) (string-append (substring numstr 0 (+ i commawidth )) s)) (set! s (string-append (string commachar) (substring numstr i (+ i commawidth)) s))))) (if (memq modifier '(at colon-at)) ; append numerical prefix (set! numstr (string-append radix-prefix numstr))) (format:pad-str numstr (negative? mincol) #t (abs mincol) 0 padchar))))) (define (format:pad-str objstr fixed-field pad-left mincol minpad padchar) (let ((objstr-len (string-length objstr))) (if fixed-field (if (> objstr-len (- mincol 1)) (if pad-left (string-append "<" (substring objstr (- objstr-len (- mincol 1)) objstr-len)) (string-append (substring objstr 0 (- mincol 1)) ">")) (if pad-left (string-append (make-string (- mincol objstr-len) padchar) objstr) (string-append objstr (make-string (- mincol objstr-len) padchar)))) (if (> objstr-len mincol) (if pad-left (string-append (make-string minpad padchar) objstr) (string-append objstr (make-string minpad padchar))) (if pad-left (string-append (make-string (- mincol objstr-len) padchar) objstr) (string-append objstr (make-string (- mincol objstr-len) padchar))))) )) ;; obj->string converts an arbitrary scheme object to a string. ;; `options' is a list of options which may contain the following symbols: ;; slashify: slashifies output string as `write' does ;; obj->string imports format:char->string which converts a character into ;; a slashified string as `write' does and which is implementation dependent. (define (obj->string obj . options) (cond ((string? obj) (if (memq 'slashify options) (let ((obj-len (string-length obj))) (string-append "\"" (let loop ((i 0) (j 0)) ; modified from Marc Feeley from pp.scm (if (= j obj-len) (string-append (substring obj i j) "\"") (let ((c (string-ref obj j))) (if (or (char=? c #\\) (char=? c #\")) (string-append (substring obj i j) "\\" (loop j (+ j 1))) (loop i (+ j 1)))))))) obj)) ((boolean? obj) (if obj "#t" "#f")) ((number? obj) (number->string obj)) ((symbol? obj) (symbol->string obj)) ((char? obj) (if (memq 'slashify options) (format:char->string obj) (string obj))) ((null? obj) "()") ((procedure? obj) "#[procedure]") ((output-port? obj) "#[output-port]") ((input-port? obj) "#[input-port]") ((list? obj) (string-append "(" (let loop ((obj-list obj)) (if (null? (cdr obj-list)) (obj->string (car obj-list) 'slashify) (string-append (obj->string (car obj-list) 'slashify) " " (loop (cdr obj-list))))) ")")) ((pair? obj) (string-append "(" (obj->string (car obj) 'slashify) " . " (obj->string (cdr obj) 'slashify) ")")) ((eof-object? obj) "#[eof-object]") ((vector? obj) (string-append "#" (obj->string (vector->list obj) 'slashify))) (else "#[non-printable-object]")) ) ;; string-upcase, string-downcase, string-capitalize, string-capitalize-first ;; are obvious string conversion procedures and are non destructive. (define (string-upcase str) (let ((up-str (string-copy str))) (do ((i (- (string-length str) 1) (- i 1))) ((< i 0) up-str) (string-set! up-str i (char-upcase (string-ref str i)))))) (define (string-downcase str) (let ((down-str (string-copy str))) (do ((i (- (string-length str) 1) (- i 1))) ((< i 0) down-str) (string-set! down-str i (char-downcase (string-ref str i)))))) (define (string-capitalize str) ; "hello" -> "Hello" (let ((cap-str (string-copy str)) ; "hELLO" -> "Hello" (non-first-alpha #f) ; "*hello" -> "*Hello" (str-len (string-length str))) ; "hello you" -> "Hello You" (do ((i 0 (+ i 1))) ((= i str-len) cap-str) (let ((c (string-ref str i))) (if (char-alphabetic? c) (if non-first-alpha (string-set! cap-str i (char-downcase c)) (begin (set! non-first-alpha #t) (string-set! cap-str i (char-upcase c)))) (set! non-first-alpha #f)))))) (define (string-capitalize-first str) ; "hello" -> "Hello" (let ((cap-str (string-copy str)) ; "hELLO" -> "Hello" (non-first-alpha #f) ; "*hello" -> "*Hello" (str-len (string-length str))) ; "hello you" -> "Hello you" (do ((i 0 (+ i 1))) ((= i str-len) cap-str) (let ((c (string-ref str i))) (if (char-alphabetic? c) (if non-first-alpha (string-set! cap-str i (char-downcase c)) (begin (set! non-first-alpha #t) (string-set! cap-str i (char-upcase c))))))))) (define format format:format) @EOF chmod 666 format.scm echo x - genwrite.scm cat >genwrite.scm <<'@EOF' ; File: "genwrite.scm" (c) 1991, Marc Feeley ; 'generic-write' is a procedure that transforms a Scheme data value (or ; Scheme program expression) into its textual representation. The interface ; to the procedure is sufficiently general to easily implement other useful ; formatting procedures such as pretty printing, output to a string and ; truncated output. ; ; Parameters: ; ; OBJ Scheme data value to transform. ; DISPLAY? Boolean, controls whether characters and strings are quoted. ; WIDTH Extended boolean, selects format: ; #f = single line format ; integer > 0 = pretty-print (value = max nb of chars per line) ; OUTPUT Procedure of 1 argument of string type, called repeatedly ; with successive substrings of the textual representation. ; This procedure can return #f to stop the transformation. ; ; The value returned by 'generic-write' is undefined. ; ; Examples: ; ; (write obj) = (generic-write obj #f #f display-string) ; (display obj) = (generic-write obj #t #f display-string) ; ; where display-string = (lambda (s) (for-each write-char (string->list s)) #t) (define (generic-write obj display? width output) (define (read-macro? l) (define (length1? l) (and (pair? l) (null? (cdr l)))) (let ((head (car l)) (tail (cdr l))) (case head ((QUOTE QUASIQUOTE UNQUOTE UNQUOTE-SPLICING) (length1? tail)) (else #f)))) (define (read-macro-body l) (cadr l)) (define (read-macro-prefix l) (let ((head (car l)) (tail (cdr l))) (case head ((QUOTE) "'") ((QUASIQUOTE) "`") ((UNQUOTE) ",") ((UNQUOTE-SPLICING) ",@")))) (define (out str col) (and col (output str) (+ col (string-length str)))) (define (wr obj col) (define (wr-expr expr col) (if (read-macro? expr) (wr (read-macro-body expr) (out (read-macro-prefix expr) col)) (wr-lst expr col))) (define (wr-lst l col) (if (pair? l) (let loop ((l (cdr l)) (col (wr (car l) (out "(" col)))) (and col (cond ((pair? l) (loop (cdr l) (wr (car l) (out " " col)))) ((null? l) (out ")" col)) (else (out ")" (wr l (out " . " col))))))) (out "()" col))) (cond ((pair? obj) (wr-expr obj col)) ((null? obj) (wr-lst obj col)) ((vector? obj) (wr-lst (vector->list obj) (out "#" col))) ((boolean? obj) (out (if obj "#t" "#f") col)) ((number? obj) (out (number->string obj) col)) ((symbol? obj) (out (symbol->string obj) col)) ((procedure? obj) (out "#[procedure]" col)) ((string? obj) (if display? (out obj col) (let loop ((i 0) (j 0) (col (out "\"" col))) (if (and col (< j (string-length obj))) (let ((c (string-ref obj j))) (if (or (char=? c #\\) (char=? c #\")) (loop j (+ j 1) (out "\\" (out (substring obj i j) col))) (loop i (+ j 1) col))) (out "\"" (out (substring obj i j) col)))))) ((char? obj) (if display? (out (make-string 1 obj) col) (out (case obj ((#\space) "space") ((#\newline) "newline") (else (make-string 1 obj))) (out "#\\" col)))) ((input-port? obj) (out "#[input-port]" col)) ((output-port? obj) (out "#[output-port]" col)) ((eof-object? obj) (out "#[eof-object]" col)) (else (out "#[unknown]" col)))) (define (pp obj col) (define (spaces n col) (if (> n 0) (if (> n 7) (spaces (- n 8) (out " " col)) (out (substring " " 0 n) col)) col)) (define (indent to col) (and col (if (< to col) (and (out (make-string 1 #\newline) col) (spaces to 0)) (spaces (- to col) col)))) (define (pr obj col extra pp-pair) (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines (let ((result '()) (left (min (+ (- (- width col) extra) 1) max-expr-width))) (generic-write obj display? #f (lambda (str) (set! result (cons str result)) (set! left (- left (string-length str))) (> left 0))) (if (> left 0) ; all can be printed on one line (out (reverse-string-append result) col) (if (pair? obj) (pp-pair obj col extra) (pp-list (vector->list obj) (out "#" col) extra pp-expr)))) (wr obj col))) (define (pp-expr expr col extra) (if (read-macro? expr) (pr (read-macro-body expr) (out (read-macro-prefix expr) col) extra pp-expr) (let ((head (car expr))) (if (symbol? head) (let ((proc (style head))) (if proc (proc expr col extra) (if (> (string-length (symbol->string head)) max-call-head-width) (pp-general expr col extra #f #f #f pp-expr) (pp-call expr col extra pp-expr)))) (pp-list expr col extra pp-expr))))) ; (head item1 ; item2 ; item3) (define (pp-call expr col extra pp-item) (let ((col* (wr (car expr) (out "(" col)))) (and col (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))) ; (item1 ; item2 ; item3) (define (pp-list l col extra pp-item) (let ((col (out "(" col))) (pp-down l col col extra pp-item))) (define (pp-down l col1 col2 extra pp-item) (let loop ((l l) (col col1)) (and col (cond ((pair? l) (let ((rest (cdr l))) (let ((extra (if (null? rest) (+ extra 1) 0))) (loop rest (pr (car l) (indent col2 col) extra pp-item))))) ((null? l) (out ")" col)) (else (out ")" (pr l (indent col2 (out "." (indent col2 col))) (+ extra 1) pp-item))))))) (define (pp-general expr col extra named? pp-1 pp-2 pp-3) (define (tail1 rest col1 col2 col3) (if (and pp-1 (pair? rest)) (let* ((val1 (car rest)) (rest (cdr rest)) (extra (if (null? rest) (+ extra 1) 0))) (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3)) (tail2 rest col1 col2 col3))) (define (tail2 rest col1 col2 col3) (if (and pp-2 (pair? rest)) (let* ((val1 (car rest)) (rest (cdr rest)) (extra (if (null? rest) (+ extra 1) 0))) (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2))) (tail3 rest col1 col2))) (define (tail3 rest col1 col2) (pp-down rest col2 col1 extra pp-3)) (let* ((head (car expr)) (rest (cdr expr)) (col* (wr head (out "(" col)))) (if (and named? (pair? rest)) (let* ((name (car rest)) (rest (cdr rest)) (col** (wr name (out " " col*)))) (tail1 rest (+ col indent-general) col** (+ col** 1))) (tail1 rest (+ col indent-general) col* (+ col* 1))))) (define (pp-expr-list l col extra) (pp-list l col extra pp-expr)) (define (pp-LAMBDA expr col extra) (pp-general expr col extra #f pp-expr-list #f pp-expr)) (define (pp-IF expr col extra) (pp-general expr col extra #f pp-expr #f pp-expr)) (define (pp-COND expr col extra) (pp-call expr col extra pp-expr-list)) (define (pp-CASE expr col extra) (pp-general expr col extra #f pp-expr #f pp-expr-list)) (define (pp-AND expr col extra) (pp-call expr col extra pp-expr)) (define (pp-LET expr col extra) (let* ((rest (cdr expr)) (named? (and (pair? rest) (symbol? (car rest))))) (pp-general expr col extra named? pp-expr-list #f pp-expr))) (define (pp-BEGIN expr col extra) (pp-general expr col extra #f #f #f pp-expr)) (define (pp-DO expr col extra) (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr)) ; define formatting style (change these to suit your style) (define indent-general 2) (define max-call-head-width 5) (define max-expr-width 50) (define (style head) (case head ((LAMBDA LET* LETREC DEFINE) pp-LAMBDA) ((IF SET!) pp-IF) ((COND) pp-COND) ((CASE) pp-CASE) ((AND OR) pp-AND) ((LET) pp-LET) ((BEGIN) pp-BEGIN) ((DO) pp-DO) (else #f))) (pr obj col 0 pp-expr)) (if width (out (make-string 1 #\newline) (pp obj 0)) (wr obj 0))) ; (reverse-string-append l) = (apply string-append (reverse l)) (define (reverse-string-append l) (define (rev-string-append l i) (if (pair? l) (let* ((str (car l)) (len (string-length str)) (result (rev-string-append (cdr l) (+ i len)))) (let loop ((j 0) (k (- (- (string-length result) i) len))) (if (< j len) (begin (string-set! result k (string-ref str j)) (loop (+ j 1) (+ k 1))) result))) (make-string i))) (rev-string-append l 0)) @EOF chmod 666 genwrite.scm echo x - obj2str.scm cat >obj2str.scm <<'@EOF' ; File: "obj2str.scm" (c) 1991, Marc Feeley (require 'generic-write) ; (object->string obj) returns the textual representation of 'obj' as a ; string. ; ; Note: (write obj) = (display (object->string obj)) (define (object->string obj) (let ((result '())) (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t)) (reverse-string-append result))) ; (object->limited-string obj limit) returns a string containing the first ; 'limit' characters of the textual representation of 'obj'. (define (object->limited-string obj limit) (let ((result '()) (left limit)) (generic-write obj #f #f (lambda (str) (let ((len (string-length str))) (if (> len left) (begin (set! result (cons (substring str 0 left) result)) (set! left 0) #f) (begin (set! result (cons str result)) (set! left (- left len)) #t))))) (reverse-string-append result))) @EOF chmod 666 obj2str.scm echo x - pp.scm cat >pp.scm <<'@EOF' ; File: "pp.scm" (c) 1991, Marc Feeley (require 'generic-write) ; (pretty-print obj port) pretty prints 'obj' on 'port'. The current ; output port is used if 'port' is not specified. (define (pp:pretty-print obj . opt) (let ((port (if (pair? opt) (car opt) (current-output-port)))) (generic-write obj #f 79 (lambda (s) (display s port) #t)))) (define pretty-print pp:pretty-print) @EOF chmod 666 pp.scm echo x - pp2str.scm cat >pp2str.scm <<'@EOF' ; File: "pp2str.scm" (c) 1991, Marc Feeley (require 'generic-write) ; (pretty-print-to-string obj) returns a string with the pretty-printed ; textual representation of 'obj'. (define (pp:pretty-print-to-string obj) (let ((result '())) (generic-write obj #f 79 (lambda (str) (set! result (cons str result)) #t)) (reverse-string-append result))) (define pretty-print-to-string pp:pretty-print-to-string) @EOF chmod 666 pp2str.scm echo x - ppfile.scm cat >ppfile.scm <<'@EOF' ;;;; "ppfile.scm". Pretty print a Scheme file. ; ; (pprint-file ifile ofile) procedure ; ;Pretty-prints all the Scheme code in ifile to ofile. ; ; (pprint-file ifile) procedure ; ;Pretty-prints all the Scheme code in ifile. ; (require 'pretty-print) (define (pprint-file ifile . optarg) (let ((lst (call-with-input-file ifile (lambda (iport) (do ((obj (read iport) (read iport)) (lst '() (cons obj lst))) ((eof-object? obj) lst)))))) (if (null? optarg) (for-each pretty-print (reverse lst)) (call-with-output-file (car optarg) (lambda (oport) (for-each (lambda (x) (pretty-print x oport)) (reverse lst))))))) @EOF chmod 666 ppfile.scm echo x - debug.scm cat >debug.scm <<'@EOF' ;;;; Utility functions for debugging in Scheme. ;;; Copyright (C) 1991 Aubrey Jaffer. ;;; Print writes all its arguments, separated by spaces. Print ;;; outputs a newline at the end and returns the value of the last ;;; argument. (define (debug:print . args) (define result #f) (for-each (lambda (x) (set! result x) (write x) (display #\ )) args) (newline) result) ;;; Qp writes its arguments, separated by spaces to ;;; (current-output-port). Qp compresses printing by substituting ;;; `...' for substructure it does not have sufficient room to print. ;;; *qp-width* is the largest number of characters that qp uses. Qp ;;; outputs a newline before returning. Qpr is like qp except that it ;;; returns its last argument. (define *qp-width* (output-port-width (current-output-port))) (define debug:qpr (let ((- -) (apply apply) (length length) (list-ref list-ref)) (lambda objs (apply debug:qp objs) (list-ref objs (- (length objs) 1))))) (define debug:qp (let ((+ +) (- -) (< <) (= =) (apply apply) (boolean? boolean?) (car car) (cdr cdr) (char? char?) (display display) (eq? eq?) (for-each for-each) (input-port? input-port?) (newline newline) (not not) (null? null?) (number->string number->string) (number? number?) (output-port? output-port?) (procedure? procedure?) (string-length string-length) (string? string?) (substring substring) (symbol->string symbol->string) (symbol? symbol?) (vector-length vector-length) (vector-ref vector-ref) (vector? vector?) (write write)) (letrec ((num-cdrs (lambda (pairs max-cdrs) (cond ((null? pairs) 0) ((< max-cdrs 1) 1) ((pair? pairs) (+ 1 (num-cdrs (cdr pairs) (- max-cdrs 1)))) (else 1)))) (l-elt-room (lambda (room pairs) (quotient room (num-cdrs pairs (quotient room 8))))) (qp-pairs (lambda (cdrs room) (cond ((null? cdrs) 0) ((not (pair? cdrs)) (display " . ") (+ 3 (qp-obj cdrs (l-elt-room (- room 3) cdrs)))) ((< 11 room) (display #\ ) ((lambda (used) (+ (qp-pairs (cdr cdrs) (- room used)) used)) (+ 1 (qp-obj (car cdrs) (l-elt-room (- room 1) cdrs))))) (else (display " ...") 4)))) (v-elt-room (lambda (room vleft) (quotient room (min vleft (quotient room 8))))) (qp-vect (lambda (vect i room) (cond ((= (vector-length vect) i) 0) ((< 11 room) (display #\ ) ((lambda (used) (+ (qp-vect vect (+ i 1) (- room used)) used)) (+ 1 (qp-obj (vector-ref vect i) (v-elt-room (- room 1) (- (vector-length vect) i)))))) (else (display " ...") 4)))) (qp-string (lambda (str room) (cond ((< (string-length str) room) (display str) (string-length str)) (else (display (substring str 0 (- room 3))) (display "...") room)))) (qp-obj (lambda (obj room) (cond ((null? obj) (write obj) 2) ((boolean? obj) (write obj) 2) ((char? obj) (write obj) 8) ((number? obj) (qp-string (number->string obj) room)) ((string? obj) (display #\") ((lambda (ans) (display #\") ans) (+ 2 (qp-string obj (- room 2))))) ((symbol? obj) (qp-string (symbol->string obj) room)) ((input-port? obj) (display "#[input]") 8) ((output-port? obj) (display "#[output]") 9) ((procedure? obj) (display "#[proc]") 7) ((vector? obj) (set! room (- room 3)) (display "#(") ((lambda (used) (display #\)) (+ used 3)) (cond ((= 0 (vector-length obj)) 0) ((< room 8) (display "...") 3) (else ((lambda (used) (+ (qp-vect obj 1 (- room used)) used)) (qp-obj (vector-ref obj 0) (v-elt-room room (vector-length obj)))))))) ((pair? obj) (set! room (- room 2)) (display #\() ((lambda (used) (display #\)) (+ 2 used)) (if (< room 8) (begin (display "...") 3) ((lambda (used) (+ (qp-pairs (cdr obj) (- room used)) used)) (qp-obj (car obj) (l-elt-room room obj)))))) (else (display "#[unknown]") 10))))) (lambda objs (qp-pairs (cdr objs) (- *qp-width* (qp-obj (car objs) (l-elt-room *qp-width* objs)))) (newline))))) ;;; to TRACE type ;;; (set! (tracef )) or ;;; (set! (tracef ')) or ;;; (define (tracef )) or ;;; (define (tracef ')) ;;; to UNTRACE type ;;; (set! (untracef )) (define debug:indent 0) (define debug:tracef (let ((null? null?) ;These bindings are so that (not not) ;tracef will not trace parts (car car) ;of itself. (cdr cdr) (eq? eq?) (apply apply) (qp debug:qp)) (lambda (function . optname) (set! debug:indent 0) (let ((name (if (null? optname) function (car optname)))) (lambda args (cond ((and (not (null? args)) (eq? (car args) 'debug:untrace-object) (null? (cdr args))) function) (else (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ )) (apply qp "CALLED" name args) (set! debug:indent (modulo (+ 1 debug:indent) 8)) (let ((ans (apply function args))) (set! debug:indent (modulo (+ -1 debug:indent) 8)) (do ((i debug:indent (+ -1 i))) ((zero? i)) (display #\ )) (qp "RETURNED" name ans) ans)))))))) ;;; the reason I use a symbol for debug:untrace-object is so ;;; that functions can still be untraced if this file is read in twice. (define (debug:untracef function) (set! debug:indent 0) (function 'debug:untrace-object)) ;;;; BREAKPOINTS ;;; Typing (init-debug) at top level sets up a continuation for break. ;;; When (break arg1 ...) is then called it returns from the top level ;;; continuation and pushes the continuation from which it was called ;;; on debug:break-continuation-stack. If (continue) is later ;;; called, it pops the topmost continuation off of ;;; debug:break-continuation-stack and returns #f to it. (define debug:break-continuation-stack '()) (define debug:break (let ((call-with-current-continuation call-with-current-continuation) (apply apply) (qp debug:qp) (cons cons) (length length)) (lambda args (apply qp "BREAK:" args) (call-with-current-continuation (lambda (x) (set! debug:break-continuation-stack (cons x debug:break-continuation-stack)) (debug:top-continuation (length debug:break-continuation-stack))))))) (define debug:continue (let ((null? null?) (car car) (cdr cdr)) (lambda () (cond ((null? debug:break-continuation-stack) #f) (else (let ((cont (car debug:break-continuation-stack))) (set! debug:break-continuation-stack (cdr debug:break-continuation-stack)) (cont #f))))))) (define debug:top-continuation (if (provided? 'abort) (lambda (val) (display val) (newline) (abort)) (begin (display "; type (init-debug)") #f))) (define (init-debug) (call-with-current-continuation (lambda (x) (set! debug:top-continuation x)))) (define print debug:print) (define qp debug:qp) (define qpr debug:qpr) (define tracef debug:tracef) (define untracef debug:untracef) (define break debug:break) (define continue debug:continue) @EOF chmod 666 debug.scm echo x - eval.scm cat >eval.scm <<'@EOF' ;;; Copyright (C) 1991 Aubrey Jaffer. ; `Load' as defined in Revised^3.99 Report on the Algorithmic ; Language Scheme [Draft August 31, 1989] opens a back door to eval ; owing to its dynamic nature: ; (eval ) procedure ; (eval! ) procedure ; Eval returns the value of in the current top level ; environment. Eval! returns an unspecified value. Side effects of ; will effect the top level environment. ; (program-vicinity) will be incorrect during the evaluation of ; . (define eval:global-return #f) (define eval:depth-cntr 0) (define eval:temp-filenames '()) (define slib:eval! (let ((eval:load load)) (lambda (frob) (set! eval:depth-cntr (+ 1 eval:depth-cntr)) (let ((filename (cond ((> eval:depth-cntr (length eval:temp-filenames)) (set! eval:temp-filenames (cons (if (provided? 'tmpnam) (tmpnam) (string-append "eval_" (number->string (+ 100 eval:depth-cntr)))) eval:temp-filenames)) (car eval:temp-filenames)) (else (list-ref eval:temp-filenames (- (length eval:temp-filenames) eval:depth-cntr)))))) (call-with-output-file filename (lambda (file) (write frob file))) (eval:load filename)) (set! eval:depth-cntr (- eval:depth-cntr 1))))) (define (slib:eval frob) (slib:eval! (list 'set! 'eval:global-return frob)) eval:global-return) (define eval! slib:eval!) (define eval slib:eval) @EOF chmod 666 eval.scm echo x - sort.scm cat >sort.scm <<'@EOF' ;;; File : sort.scm ;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren) ;;; Updated: 11 June 1991 ;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991 ;;; Defines: sorted?, merge, merge!, sort, sort! ;;; -------------------------------------------------------------------- ; Many Scheme systems provide some kind of sorting functions. They do ; not, however, always provide the _same_ sorting functions, and those ; that I have had the opportunity to test provided inefficient ones (a ; common blunder is to use quicksort which does not perform well). ; Because sort and sort! are not in the standard, there is very little ; agreement about what these functions look like. For example, Dybvig ; says that Chez Scheme provides ; (merge predicate list1 list2) ; (merge! predicate list1 list2) ; (sort predicate list) ; (sort! predicate list), ; while the MIT Scheme 7.1 manual, following Common Lisp, offers ; (sort list predicate), ; TI PC Scheme offers ; (sort! list/vector predicate?) ; and Elk offers ; (sort list/vector predicate?) ; (sort! list/vector predicate?) ; Here is a comprehensive catalogue of the variations I have found. ; (1) Both sort and sort! may be provided. ; (2) sort may be provided without sort! ; (3) sort! may be provided without sort ; (4) Neither may be provided ; --- ; (5) The sequence argument may be either a list or a vector. ; (6) The sequence argument may only be a list. ; (7) The sequence argument may only be a vector. ; --- ; (8) The comparison function may be expected to behave like < ; (9) or it may be expected to behave like <= ; --- ; (10) The interface may be (sort predicate? sequence) ; (11) or (sort sequence predicate?) ; (12) or (sort sequence &optional (predicate? <)) ; --- ; (13) The sort may be stable ; (14) or it may be unstable. ; --- ; All of this variation really does not help anybody. A nice simple ; merge sort is both stable and fast (quite a lot faster than `quick' ; sort). ; I am providing this source code with no restrictions at all on its ; use (but please retain D.H.D.Warren's credit for the original idea). ; You may have to rename some of these functions in order to use them ; in a system which already provides incompatible or inferior sorts. ; For each of the functions, only the top-level define needs to be ; edited to do that. ; I could have given these functions names which would not clash with ; any Scheme that I know of, but I would like to encourage implementors ; to converge on a single interface, and this may serve as a hint. ; The argument order for all functions has been chosen to be as close ; to Common Lisp as made sense, in order to avoid NIH-itis. ; ; Each of the five functions has a required *last* parameter which is ; a comparison function. A comparison function f is a function of 2 ; arguments which acts like <. For example, ; (not (f x x)) ; (and (f x y) (f y z)) => (f x z) ; The standard functions <, >, char?, char-ci?, ; string?, string-ci? are suitable for ; use as comparison functions. Think of (less? x y) as saying when ; x must *not* precede y. ; ; (sorted? sequence less?) ; returns #t when the sequence argument is in non-decreasing order ; according to less? (that is, there is no adjacent pair ... x y ... ; for which (less? y x)) ; returns #f when the sequence contains at least one out-of-order pair. ; It is an error if the sequence is neither a list nor a vector. ; ; (merge list1 list2 less?) ; This merges two lists, producing a completely new list as result. ; I gave serious consideration to producing a Common-Lisp-compatible ; version. However, Common Lisp's `sort' is our `sort!' (well, in ; fact Common Lisp's `stable-sort' is our `sort!', merge sort is ; *fast* as well as stable!) so adapting CL code to Scheme takes a ; bit of work anyway. I did, however, appeal to CL to determine ; the *order* of the arguments. ; ; (merge! list1 list2 less?) ; merges two lists, re-using the pairs of list1 and list2 to build ; the result. If the code is compiled, and less? constructs no new ; pairs, no pairs at all will be allocated. The first pair of the ; result will be either the first pair of list1 or the first pair ; of list2, but you can't predict which. ; ; The code of merge and merge! could have been quite a bit simpler, ; but they have been coded to reduce the amount of work done per ; iteration. (For example, we only have one null? test per iteration.) ; ; (sort sequence less?) ; accepts either a list or a vector, and returns a new sequence which ; is sorted. The new sequence is the same type as the input. Always ; (sorted? (sort sequence less?) less?). ; The original sequence is not altered in any way. The new sequence ; shares its _elements_ with the old one; no elements are copied. ; ; (sort! sequence less?) ; returns its sorted result in the original boxes. If the original ; sequence is a list, no new storage is allocated at all. If the ; original sequence is a vector, the sorted elements are put back ; in the same vector. ; ; Note that these functions do NOT accept a CL-style ":key" argument. ; A simple device for obtaining the same expressiveness is to define ; (define (keyed less? key) (lambda (x y) (less? (key x) (key y)))) ; and then, when you would have written ; (sort a-sequence #'my-less :key #'my-key) ; in Common Lisp, just write ; (sort! a-sequence (keyed my-less? my-key)) ; in Scheme. ;;; -------------------------------------------------------------------- ;;; (sorted? sequence less?) ;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm) ;;; such that for all 1 <= i <= m, ;;; (not (less? (list-ref list i) (list-ref list (- i 1)))). (define (sort:sorted? seq less?) (cond ((null? seq) #t) ((vector? seq) (let ((n (vector-length seq))) (if (<= n 1) #t (do ((i 1 (+ i 1))) ((or (= i n) (less? (vector-ref seq (- i 1)) (vector-ref seq i))) (= i n)) )) )) (else (let loop ((last (car seq)) (next (cdr seq))) (or (null? next) (and (not (less? (car next) last)) (loop (car next) (cdr next)) )) )) )) ;;; (merge a b less?) ;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?) ;;; and returns a new list in which the elements of a and b have been stably ;;; interleaved so that (sorted? (merge a b less?) less?). ;;; Note: this does _not_ accept vectors. See below. (define (sort:merge a b less?) (cond ((null? a) b) ((null? b) a) (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b))) ;; The loop handles the merging of non-empty lists. It has ;; been written this way to save testing and car/cdring. (if (less? y x) (if (null? b) (cons y (cons x a)) (cons y (loop x a (car b) (cdr b)) )) ;; x <= y (if (null? a) (cons x (cons y b)) (cons x (loop (car a) (cdr a) y b)) )) )) )) ;;; (merge! a b less?) ;;; takes two sorted lists a and b and smashes their cdr fields to form a ;;; single sorted list including the elements of both. ;;; Note: this does _not_ accept vectors. (define (sort:merge! a b less?) (define (loop r a b) (if (less? (car b) (car a)) (begin (set-cdr! r b) (if (null? (cdr b)) (set-cdr! b a) (loop b a (cdr b)) )) ;; (car a) <= (car b) (begin (set-cdr! r a) (if (null? (cdr a)) (set-cdr! a b) (loop a (cdr a) b)) )) ) (cond ((null? a) b) ((null? b) a) ((less? (car b) (car a)) (if (null? (cdr b)) (set-cdr! b a) (loop b a (cdr b))) b) (else ; (car a) <= (car b) (if (null? (cdr a)) (set-cdr! a b) (loop a (cdr a) b)) a))) ;;; (sort! sequence less?) ;;; sorts the list or vector sequence destructively. It uses a version ;;; of merge-sort invented, to the best of my knowledge, by David H. D. ;;; Warren, and first used in the DEC-10 Prolog system. R. A. O'Keefe ;;; adapted it to work destructively in Scheme. (define (sort:sort! seq less?) (define (step n) (cond ((> n 2) (let* ((j (quotient n 2)) (a (step j)) (k (- n j)) (b (step k))) (sort:merge! a b less?))) ((= n 2) (let ((x (car seq)) (y (cadr seq)) (p seq)) (set! seq (cddr seq)) (if (less? y x) (begin (set-car! p y) (set-car! (cdr p) x))) (set-cdr! (cdr p) '()) p)) ((= n 1) (let ((p seq)) (set! seq (cdr seq)) (set-cdr! p '()) p)) (else '()) )) (if (vector? seq) (let ((n (vector-length seq))) (set! seq (vector->list seq)) (do ((p (step n) (cdr p)) (i 0 (+ i 1))) ((null? p) vector) (vector-set! vector i (car p)) )) ;; otherwise, assume it is a list (step (length seq)) )) ;;; (sort sequence less?) ;;; sorts a vector or list non-destructively. It does this by sorting a ;;; copy of the sequence. My understanding is that the Standard says ;;; that the result of append is always "newly allocated" except for ;;; sharing structure with "the last argument", so (append x '()) ought ;;; to be a standard way of copying a list x. (define (sort:sort seq less?) (if (vector? seq) (list->vector (sort:sort! (vector->list seq) less?)) (sort:sort! (append seq '()) less?))) ;;; eof (define sorted? sort:sorted?) (define merge sort:merge) (define merge! sort:merge!) (define sort sort:sort) (define sort! sort:sort!) @EOF chmod 666 sort.scm echo x - comlist.scm cat >comlist.scm <<'@EOF' ;;;; Implementation of COMMON LISP list functions for Scheme ;;; Copyright (C) 1991 Aubrey Jaffer. ;;; Some of these functions may be already defined in your Scheme. ;;; Comment out those definitions for functions which are already defined. ;;;; LIST FUNCTIONS FROM COMMON LISP ;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) (define (make-list k . init) (set! init (if (pair? init) (car init))) (do ((k k (+ -1 k)) (result '() (cons init result))) ((<= k 0) result))) (define (copy-list lst) (append lst '())) (define (adjoin e l) (if (memq e l) l (cons e l))) (define (union l1 l2) (cond ((null? l1) l2) ((null? l2) l1) (else (union (cdr l1) (adjoin (car l1) l2))))) (define (position obj lst) (letrec ((pos (lambda (n lst) (cond ((null? lst) #f) ((eqv? obj (car lst)) n) (else (pos (+ 1 n) (cdr lst))))))) (pos 0 lst))) (define (reduce-init p init l) (if (null? l) init (reduce-init p (p init (car l)) (cdr l)))) (define (reduce p l) (cond ((null? l) l) ((null? (cdr l)) (car l)) (else (reduce-init p (car l) (cdr l))))) (define (some pred l) (and (not (null? l)) (or (pred (car l)) (some pred (cdr l))))) (define (every pred l) (or (null? l) (and (pred (car l)) (every pred (cdr l))))) (define (notevery pred l) (not (every pred l))) (define (find-if t l) (cond ((null? l) #f) ((t (car l)) (car l)) (else (find-if t (cdr l))))) (define (member-if t l) (cond ((null? l) #f) ((t (car l)) l) (else (member-if t (cdr l))))) (define (remove-if p l) (cond ((null? l) l) ((p (car l)) (remove-if p (cdr l))) (else (cons (car l) (remove-if p (cdr l)))))) (define (remove-if-not p l) (cond ((null? l) l) ((p (car l)) (cons (car l) (remove-if-not p (cdr l)))) (else (remove-if-not p (cdr l))))) (define nconc (lambda args (cond ((null? args) '()) ((null? (cdr args)) (car args)) ((null? (car args)) (apply nconc (cdr args))) (else (set-cdr! (last-pair (car args)) (apply nconc (cdr args))) (car args))))) ;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) (define (nreverse rev-it) ;;; Reverse order of elements of LIST by mutating cdrs. (cond ((null? rev-it) rev-it) ((not (list? rev-it)) (slib:error "nreverse: Not a list in arg1" rev-it)) (else (do ((reved '() rev-it) (rev-cdr (cdr rev-it) (cdr rev-cdr)) (rev-it rev-it rev-cdr)) ((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it))))) (define (butlast lst n) (letrec ((l (- (length lst) n)) (bl (lambda (lst n) (cond ((null? lst) lst) ((positive? n) (cons (car lst) (bl (cdr lst) (+ -1 n)))) (else '()))))) (bl lst (if (negative? n) (slib:error "negative argument to butlast" n) l)))) ;;;; CONDITIONALS (define (and? . args) (cond ((null? args) #t) ((car args) (apply and? (cdr args))) (else #f))) (define (or? . args) (cond ((null? args) #f) ((car args) #t) (else (apply or? (cdr args))))) (define (identity x) x) (require 'rev3-procedures) @EOF chmod 666 comlist.scm echo x - logical.scm cat >logical.scm <<'@EOF' ;;;; logical.scm, bit access and operations for integers for Scheme ;;; Copyright (C) 1991 Aubrey Jaffer. ; ; (logand n1 n2) procedure ; ;Returns the integer which is the bit-wise AND of the two integer ;arguments. ; ; (logor n1 n2) procedure ; ;Returns the integer which is the bit-wise OR of the two integer ;arguments. ; ; (logxor n1 n2) procedure ; ;Returns the integer which is the bit-wise XOR of the two integer ;arguments. ; ; (lognot n) procedure ; ;Returns the integer which is the 2s-complement of the integer argument. ; ; (ash int count) procedure ; ;Returns an integer equivalent to ;(inexact->exact (floor (* int (expt 2 count)))) ; ; (logcount n) procedure ; ;Returns the number of bits in integer n. If integer is positive, the ;1-bits in its binary representation are counted. If negative, the ;0-bits in its two's-complement binary representation are counted. If ;0, 0 is returned. ; ; (integer-length n) procedure ; ;Returns the number of bits neccessary to represent n. ; ; (integer-expt n k) procedure ; ;Returns n raised to the non-negative integer exponent k. ; ; (bit-extract n ) procedure ; ;Returns the integer composed of the (inclusive) through ;(exclusive) bits of n. The th bit becomes the 0-th bit in ;the result. ; ;;;;------------------------------------------------------------------ (define logical:integer-expt (if (provided? 'inexact) expt (lambda (n k) (logical:ipow-by-squaring n k 1 *)))) (define (logical:ipow-by-squaring x k acc proc) (cond ((zero? k) acc) ((= 1 k) (proc acc x)) (else (logical:ipow-by-squaring (proc x x) (quotient k 2) (if (even? k) acc (proc acc x)) proc)))) (define (logical:logand n1 n2) (cond ((= n1 n2) n1) ((zero? n1) 0) ((zero? n2) 0) (else (+ (* (logical:logand (logical:ash-4 n1) (logical:ash-4 n2)) 16) (vector-ref (vector-ref logical:boole-and (modulo n1 16)) (modulo n2 16)))))) (define (logical:logor n1 n2) (cond ((= n1 n2) n1) ((zero? n1) n2) ((zero? n2) n1) (else (+ (* (logical:logor (logical:ash-4 n1) (logical:ash-4 n2)) 16) (- 15 (vector-ref (vector-ref logical:boole-and (- 15 (modulo n1 16))) (- 15 (modulo n2 16)))))))) (define (logical:logxor n1 n2) (cond ((= n1 n2) 0) ((zero? n1) n2) ((zero? n2) n1) (else (+ (* (logical:logxor (logical:ash-4 n1) (logical:ash-4 n2)) 16) (vector-ref (vector-ref logical:boole-xor (modulo n1 16)) (modulo n2 16)))))) (define (logical:lognot n) (- -1 n)) (define (logical:bit-extract n start end) (logical:logand (- (logical:integer-expt 2 (- end start)) 1) (logical:ash n (- start)))) (define (logical:ash int cnt) (if (negative? cnt) (let ((n (logical:integer-expt 2 (- cnt)))) (if (negative? int) (+ -1 (quotient (+ 1 int) n)) (quotient int n))) (* (logical:integer-expt 2 cnt) int))) (define (logical:ash-4 x) (if (negative? x) (+ -1 (quotient (+ 1 x) 16)) (quotient x 16))) (define (logical:logcount n) (cond ((zero? n) 0) ((negative? n) (logical:logcount (logical:lognot n))) (else (+ (logical:logcount (logical:ash-4 n)) (vector-ref '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4) (modulo n 16)))))) (define (logical:integer-length n) (case n ((0 -1) 0) ((1 -2) 1) ((2 3 -3 -4) 2) ((4 5 6 7 -5 -6 -7 -8) 3) (else (+ 4 (logical:integer-length (logical:ash-4 n)))))) (define logical:boole-xor '#(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) #(1 0 3 2 5 4 7 6 9 8 11 10 13 12 15 14) #(2 3 0 1 6 7 4 5 10 11 8 9 14 15 12 13) #(3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12) #(4 5 6 7 0 1 2 3 12 13 14 15 8 9 10 11) #(5 4 7 6 1 0 3 2 13 12 15 14 9 8 11 10) #(6 7 4 5 2 3 0 1 14 15 12 13 10 11 8 9) #(7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8) #(8 9 10 11 12 13 14 15 0 1 2 3 4 5 6 7) #(9 8 11 10 13 12 15 14 1 0 3 2 5 4 7 6) #(10 11 8 9 14 15 12 13 2 3 0 1 6 7 4 5) #(11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4) #(12 13 14 15 8 9 10 11 4 5 6 7 0 1 2 3) #(13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2) #(14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1) #(15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0))) (define logical:boole-and '#(#(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) #(0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1) #(0 0 2 2 0 0 2 2 0 0 2 2 0 0 2 2) #(0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3) #(0 0 0 0 4 4 4 4 0 0 0 0 4 4 4 4) #(0 1 0 1 4 5 4 5 0 1 0 1 4 5 4 5) #(0 0 2 2 4 4 6 6 0 0 2 2 4 4 6 6) #(0 1 2 3 4 5 6 7 0 1 2 3 4 5 6 7) #(0 0 0 0 0 0 0 0 8 8 8 8 8 8 8 8) #(0 1 0 1 0 1 0 1 8 9 8 9 8 9 8 9) #(0 0 2 2 0 0 2 2 8 8 10 10 8 8 10 10) #(0 1 2 3 0 1 2 3 8 9 10 11 8 9 10 11) #(0 0 0 0 4 4 4 4 8 8 8 8 12 12 12 12) #(0 1 0 1 4 5 4 5 8 9 8 9 12 13 12 13) #(0 0 2 2 4 4 6 6 8 8 10 10 12 12 14 14) #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))) (define logand logical:logand) (define logor logical:logor) (define logxor logical:logxor) (define lognot logical:lognot) (define ash logical:ash) (define logcount logical:logcount) (define integer-length logical:integer-length) (define bit-extract logical:bit-extract) (define ipow-by-squaring logical:ipow-by-squaring) (define integer-expt logical:integer-expt) @EOF chmod 666 logical.scm echo x - random.scm cat >random.scm <<'@EOF' ;;;; Pseudo-Random number generator for scheme. ;;; Copyright (C) 1991 Aubrey Jaffer. ; ; (random n) procedure ; (random n state) procedure ; ;Accepts a positive integer or real n and returns a number of the ;same type between zero (inclusive) and n (exclusive). The values ;returned have a uniform distribution. ; ;The optional argument state must be of the type produced by ;(make-random-state). It defaults to the value of the variable ;*random-state*. This object is used to maintain the state of the ;pseudo-random-number generator and is altered as a side effect of the ;RANDOM operation. ; ; *random-state* variable ; ;Holds a data structure that encodes the internal state of the ;random-number generator that RANDOM uses by default. The nature of ;this data structure is implementation-dependent. It may be printed ;out and successfully read back in, but may or may not function ;correclty as a random-number state object in another implementation. ; ; (make-random-state) procedure ; (make-random-state state) procedure ; ;Returns a new object of type suitable for use as the value of the ;variable *random-state* and as second argument to RANDOM. If argument ;state is given, a copy of it is returned. Otherwise a copy of ;*random-state* is returned. ; ;If inexaxt numbers are support by the Scheme implementation, ;randinex.scm will be loaded as well. Randinex.scm contains ;procedures for generating inexact distributions. ;;;;------------------------------------------------------------------ (require 'logical) (define random:tap-1 24) (define random:size 55) (define (random:size-int l) (if (exact? (string->number (make-string l #\f) 16)) l (random:size-int (- l 1)))) (define random:chunk-size (* 4 (random:size-int 8))) (define random:MASK (string->number (make-string (quotient random:chunk-size 4) #\f) 16)) (define *random-state* '#( "d909ef3e" "fd330ab3" "e33f7843" "76783fbd" "f3675fb3" "b54ef879" "0be45590" "a6794679" "0bcd56d3" "fabcdef8" "9cbd3efd" "3fd3efcd" "e064ef27" "dddecc08" "34444292" "85444454" "4c519210" "c0366273" "54734567" "70abcddc" "1bbdac53" "616c5a86" "a982efa9" "105996a0" "5f0cccba" "1ea055e1" "fe2acd8d" "1891c1d4" "e6690270" "6912bccc" "2678e141" "61222224" "907abcbb" "4ad6829b" "9cdd1404" "57798841" "5b892496" "871c9cd1" "d1e67bda" "8b0a3233" "578ef23f" "28274ef6" "823ef5ef" "845678c5" "e67890a5" "5890abcb" "851fa9ab" "13efa13a" "b12278d6" "daf805ab" "a0befc36" "0068a7b5" "e024fd90" "a7b690e2" "27f3571a" 0)) (let ((random-strings *random-state*)) (set! *random-state* (make-vector (+ random:size 1) 0)) (let ((nibbles (quotient random:chunk-size 4))) (do ((i 0 (+ i 1))) ((= i random:size)) (vector-set! *random-state* i (string->number (substring (vector-ref random-strings i) 0 nibbles) 16))))) ;;; random:chunk returns an integer in the range of ;;; 0 to (- (expt 2 random:chunk-size) 1) (define (random:chunk v) (let* ((p (vector-ref v random:size)) (i (modulo (- p random:tap-1) random:size)) (ans (vector-ref v p))) (vector-set! v p (logical:logxor (vector-ref v i) ans)) (vector-set! v random:size (modulo (- p 1) random:size)) ans)) (define (random:bits n state) (cond ((= n random:chunk-size) (random:chunk state)) ((< n random:chunk-size) (logical:logand (random:chunk state) (- (logical:ash 1 n) 1))) (else (+ (* (random:bits (- n random:chunk-size) state) (+ 1 random:MASK)) (random:chunk state))))) (define (random:random modu . args) (let ((state (if (null? args) *random-state* (car args)))) (if (exact? modu) (let ((ilen (integer-length modu))) (do ((r (random:bits ilen state) (random:bits ilen state))) ;this could be improved. ((< r modu) r))) (* (random:uniform state) modu)))) ;;;random:uniform is in randinex.scm. It is needed only if inexact is ;;;supported. (define (random:make-random-state . args) (let ((state (if (null? args) *random-state* (car args)))) (list->vector (vector->list state)))) (define random random:random) (define make-random-state random:make-random-state) (provide 'random) ;to prevent loops (if (provided? 'inexact) (require 'random-inexact)) @EOF chmod 666 random.scm echo x - sc4opt.scm cat >sc4opt.scm <<'@EOF' ;;;; Implementation of optional Scheme^4 functions for IEEE Scheme ;;; Copyright (C) 1991 Aubrey Jaffer. ;;; See the file `COPYING' for terms applying to this program. ;;; Some of these functions may be already defined in your Scheme. ;;; Comment out those definitions for functions which are already defined. ;;; This code conforms to: William Clinger and Jonathan Rees, editors. ;;; Revised^4 Report on the Algorithmic Language Scheme. (define (list-tail l p) (if (< p 1) l (list-tail (cdr l) (- p 1)))) (define (string->list s) (do ((i (- (string-length s) 1) (- i 1)) (l '() (cons (string-ref s i) l))) ((< i 0) l))) (define (list->string l) (apply string l)) (define (string-copy s) (do ((v (make-string (string-length s))) (i (- (string-length s) 1) (- i 1))) ((< i 0) v) (string-set! v i (string-ref s i)))) (define (string-fill! s obj) (do ((i (- (string-length s) 1) (- i 1))) ((< i 0)) (string-set! s i obj))) (define (list->vector l) (apply vector l)) (define (vector->list s) (do ((i (- (vector-length s) 1) (- i 1)) (l '() (cons (vector-ref s i) l))) ((< i 0) l))) (define (vector-fill! s obj) (do ((i (- (vector-length s) 1) (- i 1))) ((< i 0)) (vector-set! s i obj))) @EOF chmod 666 sc4opt.scm echo x - sc4-sc3.scm cat >sc4-sc3.scm <<'@EOF' ;;;; Implementation of rev4 procedures for rev3. ;;; Copyright (C) 1991 Aubrey Jaffer. ;;;; peek-char, number->string, and string->number need to be written here. ;;; APPEND, +, *, -, /, =, <, >, <=, >=, MAP, and FOR-EACH need to ;;; accept more general number or arguments. (define (list? x) (let loop ((fast x) (slow x)) (or (null? fast) (and (pair? fast) (let ((fast (cdr fast))) (or (null? fast) (and (pair? fast) (let ((fast (cdr fast)) (slow (cdr slow))) (and (not (eq? fast slow)) (loop fast slow)))))))))) @EOF chmod 666 sc4-sc3.scm echo x - sc2.scm cat >sc2.scm <<'@EOF' ;;;; Implementation of rev2 procedures eliminated in subsequent versions. ;;; Copyright (C) 1991 Aubrey Jaffer. ; ; (substring-move-left! string1 start1 end1 string2 start2) ; (substring-move-right! string1 start1 end1 string2 start2) ; procedure ; ;String1 and string2 must be a strings, and start1, start2 and ;end1 must be exact integers satisfying ; ; 0 <= start1 <= end1 <= (string-length string1) ; 0 <= start2 <= end1-start1+start2 <= (string-length string2). ; ;Substring-move-left! and substring-move-right! store characters of ;string1 beginning with index start1 (inclusive) and ending with ;index end1 (exclusive) into string2 beginning with index start2 ;(inclusive). ; ;Substring-move-left! stores characters in time order of increasing ;indeces. Substring-move-right! stores characters in time order of ;decreasing indeces. ;---------------------------------------------------------------------- (require 'rev3-procedures) (define (substring-move-left! string1 start1 end1 string2 start2) (do ((i start1 (+ i 1)) (j start2 (+ j 1)) (l (- end1 start1) (- l 1))) ((<= l 0)) (string-set! string2 j (string-ref string1 i)))) (define (substring-move-right! string1 start1 end1 string2 start2) (do ((i (+ start1 (- end1 start1) -1) (- i 1)) (j (+ start2 (- end1 start1) -1) (- j 1)) (l (- end1 start1) (- l 1))) ((<= l 0)) (string-set! string2 j (string-ref string1 i)))) (define (substring-fill! string start end char) (do ((i start (+ i 1)) (l (- end start) (- l 1))) ((<= l 0)) (string-set! string j char))) (define (string-null? str) (= 0 (string-length str))) (define append! (lambda args (cond ((null? args) '()) ((null? (cdr args)) (car args)) ((null? (car args)) (cadr args)) (else (set-cdr! (last-pair (car args)) (apply append! (cdr args))) (car args))))) ;;;; need to add code for OBJECT-HASH and OBJECT-UNHASH (define 1+ (let ((+ +)) (lambda (n) (+ n 1)))) (define -1+ (let ((+ +)) (lambda (n) (+ n -1)))) (define ? >) (define >=? >=) @EOF chmod 666 sc2.scm echo x - sc3.scm cat >sc3.scm <<'@EOF' ;;;; Implementation of rev3 procedures eliminated in subsequent versions. ;;; Copyright (C) 1991 Aubrey Jaffer. (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) (define t #t) (define nil #f) ;;;I can't find procedure APPROXIMATE in the Revised^3 Report. @EOF chmod 666 sc3.scm echo x - mularg.scm cat >mularg.scm <<'@EOF' ;;;; "multarg.scm" Redefine - and / to take more than 2 arguments. ;;; From: hugh@ear.mit.edu (Hugh Secker-Walker) ;;; redefine / to take more than two arguments (define two-arg:/ /) (set! / (lambda (dividend . divisors) (cond ((null? divisors) (two-arg:/ dividend)) ((null? (cdr divisors)) (two-arg:/ dividend (car divisors))) (else (for-each (lambda (divisor) (set! dividend (two-arg:/ dividend divisor))) divisors) dividend)))) ;;; redefine - to take more than two arguments (define two-arg:- -) (set! - (lambda (minuend . subtrahends) (cond ((null? subtrahends) (two-arg:- minuend)) ((null? (cdr subtrahends)) (two-arg:- minuend (car subtrahends))) (else (for-each (lambda (subtrahend) (set! minuend (two-arg:- minuend subtrahend))) subtrahends) minuend)))) @EOF chmod 666 mularg.scm rm -f /tmp/uud$$ (echo "begin 666 /tmp/uud$$\n#;VL*n#6%@x\n \nend" | uudecode) >/dev/null 2>&1 if [ X"`cat /tmp/uud$$ 2>&1`" = Xok ] then unpacker=uudecode else echo Compiling unpacker for non-ascii files pwd=`pwd`; cd /tmp cat >unpack$$.c <<'EOF' #include #define C (*p++ - ' ' & 077) main() { int n; char buf[128], *p, a,b; scanf("begin %o ", &n); gets(buf); if (freopen(buf, "w", stdout) == NULL) { perror(buf); exit(1); } while (gets(p=buf) && (n=C)) { while (n>0) { a = C; if (n-- > 0) putchar(a << 2 | (b=C) >> 4); if (n-- > 0) putchar(b << 4 | (a=C) >> 2); if (n-- > 0) putchar(a << 6 | C); } } exit(0); } EOF cc -o unpack$$ unpack$$.c rm unpack$$.c cd $pwd unpacker=/tmp/unpack$$ fi rm -f /tmp/uud$$ echo x - mulapply.scm '[non-ascii]' $unpacker <<'@eof' begin 666 mulapply.scm M.SL[.R B;75L=&%P<&QY+G-C;2(@4F5D969I;F4@05!03%D@=&%K92!M;W)EX M('1H86X@,B!Aratize.scm <<'@EOF' ;;;; Rationalize ;;; The procedure rationalize is interesting because most programming ;;; languages do not provide anything analogous to it. For ;;; simplicity, we present an algorithm which computes the correct ;;; result for exact arguments (provided the implementation supports ;;; exact rational numbers of unlimited precision), and produces a ;;; reasonable answer for inexact arguments when inexact arithmetic is ;;; implemented using floating-point. We thank Alan Bawden for ;;; contributing this algorithm. (define (rationalize x e) (simplest-rational (- x e) (+ x e))) (define (simplest-rational x y) (define (simplest-rational-internal x y) ;; assumes 0 < X < Y (let ((fx (floor x)) (fy (floor y))) (cond ((not (< fx x)) fx) ((= fx fy) (+ fx (/ (simplest-rational-internal (/ (- y fy)) (/ (- x fx)))))) (else (+ 1 fx))))) ;; do some juggling to satisfy preconditions ;; of simplest-rational-internal. (cond ((< y x) (simplest-rational y x)) ((not (< x y)) (if (rational? x) x (slib:error))) ((positive? x) (simplest-rational-internal x y)) ((negative? y) (- (simplest-rational-internal (- y) (- x)))) (else (if (and (exact? x) (exact? y)) 0 0.0)))) @EOF chmod 666 ratize.scm echo x - randinex.scm cat >randinex.scm <<'@EOF' ;;;; Pseudo-Random inexact real numbers for scheme. ;;; Copyright (C) 1991 Aubrey Jaffer. ;This file is loaded by random.scm if inexact numbers are supported by ;the implementation. ; (random:uniform state) procedure ;Returns an uniformly distributed inexact real random number in the ;range between 0 and 1. ; (random:solid-sphere! ) procedure ; (random:solid-sphere! state) procedure ;Fills with inexact real random numbers the sum of whose ;squares is less than 1.0. Thinking of as coordinates in space ;of dimension n = (vector-length ), the coordinates are ;uniformly distributed within the unit n-shere. The sum of the ;squares of the numbers is returned. ;Random:solid-sphere! is inefficient for large . ; (random:hollow-sphere! ) procedure ; (random:hollow-sphere! state) procedure ;Fills with inexact real random numbers the sum of whose ;squares is equal to 1.0. Thinking of as coordinates in space ;of dimension n = (vector-length ), the coordinates are ;uniformly distributed over the surface of the unit n-shere. ;Random:hollow-sphere! is inefficient for large . ; (random:normal) procedure ; (random:normal state) procedure ;Returns an inexact real in a normal distribution with mean 0 and ;standard deviation 1. For a normal distribution with mean M and ;standard deviation D use (+ M (* D (random:normal))). ; (random:exp) procedure ; (random:exp state) procedure ;Returns an inexact real in an exponential distribution with mean 1. ;For an exponential distribution with mean U use (* U (random:exp)). ;;;;----------------------------------------------------------------- (define random:float-radix (+ 1 (exact->inexact random:MASK))) ;;; This determines how many chunks will be neccessary to completely ;;; fill up an inexact real. (define (random:size-float l x) (if (= 1.0 (+ 1 x)) l (random:size-float (+ l 1) (/ x random:float-radix)))) (define random:chunks/float (random:size-float 1 1.0)) (define (random:uniform-chunk n state) (if (= 1 n) (/ (exact->inexact (random:chunk state)) random:float-radix) (/ (+ (random:uniform-chunk (- n 1) state) (exact->inexact (random:chunk state))) random:float-radix))) ;;; Generate an inexact real between 0 and 1. (define (random:uniform state) (random:uniform-chunk random:chunks/float state)) (define (random:solid-sphere! vect . args) (let ((state (if (null? args) *random-state* (car args))) (x 0) (x2 0) (ms 0)) (do ((n (vector-length vect) (- n 1))) ((zero? n)) (set! x (- (* 2 (random:uniform state)) 1)) (vector-set! vect (- n 1) x) (set! x2 (* x x)) (set! ms (+ ms x2))) (do ((i 0 (modulo (- i 1) (vector-length vect)))) ((<= ms 1.0) ms) (set! ms (- ms x2)) (set! x (random:uniform state)) (vector-set! vect i x) (set! x2 (* x x)) (set! ms (+ ms x2))))) (define (random:hollow-sphere! vect . args) (let ((ms (sqrt (apply random:solid-sphere! vect args)))) (do ((n (vector-length vect) (- n 1))) ((zero? n)) (vector-set! vect (- n 1) (/ (vector-ref vect (- n 1)) ms))))) ;;; These two distributions from algorithms in Knuth Vol. II. (define (random:normal . args) (let* ((v (make-vector 2 0.0)) (s (apply random:solid-sphere! v args))) (* (vector-ref v 0) (sqrt (/ (* -2 (log s)) s))))) (define (random:exp . args) (let ((state (if (null? args) *random-state* (car args)))) (- (log (random:uniform state))))) (require 'random) @EOF chmod 666 randinex.scm echo x - modular.scm cat >modular.scm <<'@EOF' ;;;; modular.scm, modular fixnum arithmetic for Scheme ;;; Copyright (C) 1991 Aubrey Jaffer. ; ; (extended-euclid n1 n2) procedure ; ;Returns a list of 3 integers (d x y) such that d=gcd(n1,n2)=n1*x+n2*y. ; ; For all of these procedures all arguments should be exact ; non-negative integers such that k1 > k2 and k1 > k3. The returned ; value will be an exact non-negative integer less than k1. If all ; the arguments are fixnums the compuation will use only fixnums. ; ; (modular:invert k1 k2) procedure ; ;Returns an integer n such that 1 = (n * k2) mod k1. If k2 has no ;inverse mod k1 an error is signaled. ; ; (modular:negate k1 k2) procedure ; ;Returns (-k2) mod k1. ; ; (modular:+ k1 k2 k3) procedure ; ;Returns (k2 + k3) mod k1. ; ; (modular:- k1 k2 k3) procedure ; ;Returns (k2 - k3) mod k1. ; ; (modular:* k1 k2 k3) procedure ; ;Returns (k2 * k3) mod k1. ; ; (modular:expt k1 k2 k3) procedure ; ;Returns (k2 ^ k3) mod k1. ; ;;;;-------------------------------------------------------------- (require 'logical) ;;; from: ;;; Introduction to Algorithms by T. Cormen, C. Leiserson, R. Rivest. ;;; 1989 MIT Press. ;;; (extended-euclid a b) returns a list (d x y) such that ;;; d=gcd(a,b)=a*x+b*y. (define (modular:extended-euclid a b) (if (zero? b) (list a 1 0) (let ((res (modular:extended-euclid b (modulo a b)))) (list (car res) (caddr res) (- (cadr res) (* (quotient a b) (caddr res))))))) (define (modular:invert m a) (let ((d (modular:extended-euclid a m))) (if (= 1 (car d)) (modulo (cadr d) m) (slib:error "modular:invert can't invert" m a)))) (define modular:negate -) (define (modular:+ m a b) (modulo (+ (- a m) b) m)) (define (modular:- m a b) (modulo (- a b) m)) ;;; See: L'Ecuyer, P. and Cote, S. "Implementing a Random Number Package ;;; with Splitting Facilities." ACM Transactions on Mathematical ;;; Software, 17:98-111 (1991) ;;; modular:r = 2**((nb-2)/2) where nb = number of bits in a word. (define modular:r (ash 1 (quotient (integer-length most-positive-fixnum) 2))) (define (modular:* m a b) (let ((a0 a) (p 0)) (cond ((< a modular:r)) ((< b modular:r) (set! a b) (set! b a0) (set! a0 a)) (else (set! a0 (modulo a modular:r)) (let ((a1 (quotient a modular:r)) (qh (quotient m modular:r)) (rh (modulo m modular:r))) (cond ((>= a1 modular:r) (set! a1 (- a1 modular:r)) (set! p (modulo (- (* modular:r (modulo b qh)) (* (quotient b qh) rh)) m)))) (cond ((not (zero? a1)) (let ((q (quotient m a1))) (set! p (- p (* (quotient b q) (modulo m a1)))) (set! p (modulo (+ (if (positive? p) (- p m) p) (* a1 (modulo b q))) m))))) (set! p (modulo (- (* modular:r (modulo p qh)) (* (quotient p qh) rh)) m))))) (if (zero? a0) p (let ((q (quotient m a0))) (set! p (- p (* (quotient b q) (modulo m a0)))) (modulo (+ (if (positive? p) (- p m) p) (* a0 (modulo b q))) m))))) (define (modular:expt m a b) (cond ((= a 1) 1) ((= a (- m 1)) (if (odd? b) a 1)) ((zero? a) 0) (else ;Fermat's theorem (logical:ipow-by-squaring a (modulo b (- m 1)) 1 (lambda (c d) (modular:* m c d)))))) (define extended-euclid modular:extended-euclid) @EOF chmod 666 modular.scm echo x - prime.scm cat >prime.scm <<'@EOF' ;;;; prime.scm, prime test and factorization for Scheme ;;; Copyright (C) 1991, 1992 Aubrey Jaffer. ; (jacobi-symbol p q) procedure ;Returns the value (+1, -1, or 0) of the Jacobi-Symbol of exact ;non-negative integer p and exact positive odd integer q. ; (prime? p) procedure ;Returns #f if p is composite; #t if p is prime. There is a ;slight chance (expt 2 (- prime:trials)) that a composite will ;return #t. ; prime:trials procedure ;Is the maxinum number of iterations of Solovay-Strassen that will ;be done to test a number for primality. ; (factor k) procedure ;Returns a list of the prime factors of k. The order of the factors ;is unspecified. In order to obtain a sorted list do ;(sort! (factor k) <) ;;;;-------------------------------------------------------------- (require 'random) (require 'modular) ;;; (modulo p 16) is because we care only about the low order bits. ;;; The odd? tests are inline of (expt -1 ...) (define (prime:jacobi-symbol p q) (cond ((zero? p) 0) ((= 1 p) 1) ((odd? p) (if (odd? (quotient (* (- (modulo p 16) 1) (- q 1)) 4)) (- (prime:jacobi-symbol (modulo q p) p)) (prime:jacobi-symbol (modulo q p) p))) (else (let ((qq (modulo q 16))) (if (odd? (quotient (- (* qq qq) 1) 8)) (- (prime:jacobi-symbol (quotient p 2) q)) (prime:jacobi-symbol (quotient p 2) q)))))) ;;;; Solovay-Strassen Prime Test ;;; if n is prime, then J(a,n) is congruent mod n to a**((n-1)/2) ;;; See: ;;; Robert Solovay and Volker Strassen, ;;; "A Fast Monte-Carlo Test for Primality," ;;; SIAM Journal on Computing, 1977, pp 84-85. ;;; checks if n is prime. Returns nil if not prime. True if (probably) prime. ;;; probability of a mistake = (expt 2 (- prime:trials)) ;;; choosing prime:trials=30 should be enough (define prime:trials 30) ;;; prime:product is a product of small primes that is a fixnum. (define prime:product (let ((p 210)) (for-each (lambda (s) (set! p (or (string->number s) p))) '("2310" "30030" "510510" "9699690" "223092870")) p)) (define (prime:prime? n) (set! n (abs n)) (cond ((<= n 31) (memv n '(2 3 5 7 11 13 17 19 23 31))) ((= 1 (gcd n prime:product)) (do ((i prime:trials (- i 1)) (a (+ 1 (random (- n 1))) (+ 1 (random (- n 1))))) ((not (and (positive? i) (= (gcd a n) 1) (= (modulo (jacobi-symbol a n) n) (modular:expt n a (quotient (- n 1) 2))))) (if (positive? i) #f #t)))) (else #f))) ;;;;Lankinen's recursive factoring algorithm: ;From: ld231782@longs.LANCE.ColoState.EDU (L. Detweiler) ; | undefined if n<0, ; | (u,v) if n=0, ;Let f(u,v,b,n) := | [otherwise] ; | f(u+b,v,2b,(n-v)/2) or f(u,v+b,2b,(n-u)/2) if n odd ; | f(u,v,2b,n/2) or f(u+b,v+b,2b,(n-u-v-b)/2) if n even ;Thm: f(1,1,2,(m-1)/2) = (p,q) iff pq=m for odd m. ;It may be illuminating to consider the relation of the Lankinen function in ;a `computational hierarchy' of other factoring functions.* Assumptions are ;made herein on the basis of conventional digital (binary) computers. Also, ;complexity orders are given for the worst case scenarios (when the number to ;be factored is prime). However, all algorithms would probably perform to ;the same constant multiple of the given orders for complete composite ;factorizations. ;Thm: Eratosthenes' Sieve is very roughtly O(ln(n)/n) in time and ; O(n*log2(n)) in space. ;Pf: It works with all prime factors less than n (about ln(n)/n by the prime ; number thm), requiring an array of size proportional to n with log2(n) ; space for each entry. ;Thm: `Odd factors' is O((sqrt(n)/2)*log2(n)) in time and O(log2(n)) in ; space. ;Pf: It tests all odd factors less than the square root of n (about ; sqrt(n)/2), with log2(n) time for each division. It requires only ; log2(n) space for the number and divisors. ;Thm: Lankinen's algorithm is O(sqrt(n)/2) in time and O((sqrt(n)/2)*log2(n)) ; in space. ;Pf: The algorithm is easily modified to seach only for factors pcharplot.scm <<'@EOF' ;;;; charplot.scm, plotting on character devices for Scheme ;;; Copyright (C) 1992 Aubrey Jaffer. ; (plot! coords xlabel ylabel) procedure ;Coords is a list of pairs of x and y coordinates. Xlabel and ylabel ;are strings with names to label the x and y axii with. ;;;;--------------------------------------------------------------- (require 'sort) (define rows 24) (define columns 80) (define charplot:xborder #\_) (define charplot:yborder #\|) (define charplot:xaxchar #\-) (define charplot:yaxchar #\:) (define charplot:curve1 #\*) (define charplot:xtick #\.) (define charplot:height (- rows 5)) (define charplot:width (- columns 15)) (define (charplot:printn! n char) (cond ((positive? n) (write-char char) (charplot:printn! (+ n -1) char)))) (define (charplot:center-print! str width) (let ((lpad (quotient (- width (string-length str)) 2))) (charplot:printn! lpad #\ ) (display str) (charplot:printn! (- width (+ (string-length str) lpad)) #\ ))) (define (scale-it z scale) (if (and (exact? z) (integer? z)) (quotient (* z (car scale)) (cadr scale)) (inexact->exact (round (/ (* z (car scale)) (cadr scale)))))) (define (find-scale isize delta) (if (inexact? delta) (set! isize (exact->inexact isize))) (do ((d 1 (* d 10))) ((<= delta isize) (do ((n 1 (* n 10))) ((>= (* delta 10) isize) (list (* n (cond ((< (* delta 8) isize) 8) ((< (* delta 6) isize) 6) ((< (* delta 5) isize) 5) ((< (* delta 4) isize) 4) ((< (* delta 3) isize) 3) ((< (* delta 2) isize) 2) (else 1))) d)) (set! delta (* delta 10)))) (set! isize (* isize 10)))) (define (charplot:iplot! data xlabel ylabel xmin xscale ymin yscale) (define xaxis (- (scale-it ymin yscale))) (define yaxis (- (scale-it xmin xscale))) (charplot:center-print! ylabel 11) (charplot:printn! (+ charplot:width 1) charplot:xborder) (newline) (set! data (sort! data (lambda (x y) (if (= (cdr x) (cdr y)) (< (car x) (car y)) (> (cdr x) (cdr y)))))) (do ((ht (- charplot:height 1) (- ht 1))) ((negative? ht)) (let ((a (make-string (+ charplot:width 1) (if (= ht xaxis) charplot:xaxchar #\ ))) (ystep (if (= 1 (gcd (car yscale) 3)) 2 3))) (string-set! a charplot:width charplot:yborder) (if (< -1 yaxis charplot:width) (string-set! a yaxis charplot:yaxchar)) (do () ((or (null? data) (not (>= (cdar data) ht)))) (string-set! a (caar data) charplot:curve1) (set! data (cdr data))) (if (zero? (modulo (- ht xaxis) ystep)) (let* ((v (number->string (/ (* (- ht xaxis) (cadr yscale)) (car yscale)))) (l (string-length v))) (if (> l 10) (display (substring v 0 10)) (begin (charplot:printn! (- 10 l) #\ ) (display v))) (display charplot:yborder) (display charplot:xaxchar)) (begin (charplot:printn! 10 #\ ) (display charplot:yborder) (display #\ ))) (display a) (newline))) (let* ((xstep (if (= 1 (gcd (car xscale) 3)) 10 12)) (xstep/2 (quotient (- xstep 2) 2)) (fudge (modulo yaxis xstep))) (charplot:printn! 10 #\ ) (display charplot:yborder) (charplot:printn! (+ 1 fudge) charplot:xborder) (display charplot:yaxchar) (do ((i fudge (+ i xstep))) ((> (+ i xstep) charplot:width) (charplot:printn! (modulo (- charplot:width (+ i 1)) xstep) charplot:xborder)) (charplot:printn! xstep/2 charplot:xborder) (display charplot:xtick) (charplot:printn! xstep/2 charplot:xborder) (display charplot:yaxchar)) (display charplot:yborder) (newline) (charplot:center-print! xlabel (+ 12 fudge (- xstep/2))) (do ((i fudge (+ i xstep))) ((> (+ i xstep) charplot:width)) (charplot:center-print! (number->string (/ (* (- i yaxis) (cadr xscale)) (car xscale))) xstep)) (newline))) (define (charplot:plot! data xlabel ylabel) (define xmax (apply max (map car data))) (define xmin (apply min (map car data))) (define xscale (find-scale charplot:width (- xmax xmin))) (define ymax (apply max (map cdr data))) (define ymin (apply min (map cdr data))) (define yscale (find-scale charplot:height (- ymax ymin))) (define ixmin (scale-it xmin xscale)) (define iymin (scale-it ymin yscale)) (charplot:iplot! (map (lambda (p) (cons (- (scale-it (car p) xscale) ixmin) (- (scale-it (cdr p) yscale) iymin))) data) xlabel ylabel xmin xscale ymin yscale)) (define plot! charplot:plot!) @EOF chmod 666 charplot.scm echo x - r4rsyn.scm cat >r4rsyn.scm <<'@EOF' ;;; -*-Scheme-*- ;;; ;;; Copyright (c) 1989-91 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. ;;;; R4RS Syntax (define scheme-syntactic-environment #f) (define (initialize-scheme-syntactic-environment!) (set! scheme-syntactic-environment ((compose-macrologies (make-core-primitive-macrology) (make-binding-macrology syntactic-binding-theory 'LET-SYNTAX 'LETREC-SYNTAX 'DEFINE-SYNTAX) (make-binding-macrology variable-binding-theory 'LET 'LETREC 'DEFINE) (make-r4rs-primitive-macrology) (make-core-expander-macrology) (make-syntax-rules-macrology)) root-syntactic-environment))) ;;;; Core Primitives (define (make-core-primitive-macrology) (make-primitive-macrology (lambda (define-classifier define-compiler) (define-classifier 'BEGIN (lambda (form environment definition-environment) (syntax-check '(KEYWORD * FORM) form) (make-body-item (classify/subforms (cdr form) environment definition-environment)))) (define-compiler 'DELAY (lambda (form environment) (syntax-check '(KEYWORD EXPRESSION) form) (output/delay (compile/subexpression (cadr form) environment)))) (define-compiler 'IF (lambda (form environment) (syntax-check '(KEYWORD EXPRESSION EXPRESSION ? EXPRESSION) form) (output/conditional (compile/subexpression (cadr form) environment) (compile/subexpression (caddr form) environment) (if (null? (cdddr form)) (output/unspecific) (compile/subexpression (cadddr form) environment))))) (define-compiler 'QUOTE (lambda (form environment) environment ;ignore (syntax-check '(KEYWORD DATUM) form) (output/literal-quoted (strip-syntactic-closures (cadr form)))))))) ;;;; Bindings (define (make-binding-macrology binding-theory let-keyword letrec-keyword define-keyword) (make-primitive-macrology (lambda (define-classifier define-compiler) (let ((pattern/let-like '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM)) (compile/let-like (lambda (form environment body-environment output/let) ;; Force evaluation order. (let ((bindings (let loop ((bindings (map (lambda (binding) (cons (car binding) (classify/subexpression (cadr binding) environment))) (cadr form)))) (if (null? bindings) '() (let ((binding (binding-theory body-environment (caar bindings) (cdar bindings)))) (if binding (cons binding (loop (cdr bindings))) (loop (cdr bindings)))))))) (output/let (map car bindings) (map (lambda (binding) (compile-item/expression (cdr binding))) bindings) (compile-item/expression (classify/body (cddr form) body-environment))))))) (define-compiler let-keyword (lambda (form environment) (syntax-check pattern/let-like form) (compile/let-like form environment (internal-syntactic-environment environment) output/let))) (define-compiler letrec-keyword (lambda (form environment) (syntax-check pattern/let-like form) (let ((environment (internal-syntactic-environment environment))) (reserve-names! (map car (cadr form)) environment) (compile/let-like form environment environment output/letrec))))) (define-classifier define-keyword (lambda (form environment definition-environment) (syntax-check '(KEYWORD IDENTIFIER EXPRESSION) form) (syntactic-environment/define! definition-environment (cadr form) (make-reserved-name-item)) (make-definition-item binding-theory (cadr form) (make-promise (lambda () (classify/subexpression (caddr form) environment))))))))) ;;;; Bodies (define (classify/body forms environment) (let ((environment (internal-syntactic-environment environment))) (let forms-loop ((forms forms) (bindings '())) (if (null? forms) (syntax-error "no expressions in body" "") (let items-loop ((items (item->list (classify/subform (car forms) environment environment))) (bindings bindings)) (cond ((null? items) (forms-loop (cdr forms) bindings)) ((definition-item? (car items)) (items-loop (cdr items) (let ((binding (bind-definition-item! environment (car items)))) (if binding (cons binding bindings) bindings)))) (else (let ((body (make-body-item (append items (flatten-body-items (classify/subforms (cdr forms) environment environment)))))) (make-expression-item (lambda () (output/letrec (map car bindings) (map (lambda (binding) (compile-item/expression (cdr binding))) bindings) (compile-item/expression body)))))))))))) ;;;; R4RS Primitives (define (make-r4rs-primitive-macrology) (make-primitive-macrology (lambda (define-classifier define-compiler) (define (transformer-keyword expander->classifier) (lambda (form environment definition-environment) definition-environment ;ignore (syntax-check '(KEYWORD EXPRESSION) form) (let ((item (classify/subexpression (cadr form) scheme-syntactic-environment))) (let ((transformer (base:eval (compile-item/expression item)))) (if (procedure? transformer) (make-keyword-item (expander->classifier transformer environment)) (syntax-error "transformer not a procedure" transformer)))))) (define-classifier 'TRANSFORMER ;; "Syntactic Closures" transformer (transformer-keyword sc-expander->classifier)) (define-classifier 'ER-TRANSFORMER ;; "Explicit Renaming" transformer (transformer-keyword er-expander->classifier)) (define-compiler 'LAMBDA (lambda (form environment) (syntax-check '(KEYWORD R4RS-BVL + FORM) form) (let ((environment (internal-syntactic-environment environment))) ;; Force order -- bind names before classifying body. (let ((bvl-description (let ((rename (lambda (identifier) (bind-variable! environment identifier)))) (let loop ((bvl (cadr form))) (cond ((null? bvl) '()) ((pair? bvl) (cons (rename (car bvl)) (loop (cdr bvl)))) (else (rename bvl))))))) (output/lambda bvl-description (compile-item/expression (classify/body (cddr form) environment))))))) (define-compiler 'SET! (lambda (form environment) (syntax-check '(KEYWORD FORM EXPRESSION) form) (output/assignment (let loop ((form (cadr form)) (environment environment)) (cond ((identifier? form) (let ((item (syntactic-environment/lookup environment form))) (if (variable-item? item) (variable-item/name item) (syntax-error "target of assignment not a variable" form)))) ((syntactic-closure? form) (let ((form (syntactic-closure/form form)) (environment (filter-syntactic-environment (syntactic-closure/free-names form) environment (syntactic-closure/environment form)))) (loop form environment))) (else (syntax-error "target of assignment not an identifier" form)))) (compile/subexpression (caddr form) environment)))) ;; end MAKE-R4RS-PRIMITIVE-MACROLOGY ))) ;;;; Core Expanders (define (make-core-expander-macrology) (make-er-expander-macrology (lambda (define-expander base-environment) (let ((keyword (make-syntactic-closure base-environment '() 'DEFINE))) (define-expander 'DEFINE (lambda (form rename compare) compare ;ignore (if (syntax-match? '((IDENTIFIER . R4RS-BVL) + FORM) (cdr form)) `(,keyword ,(caadr form) (,(rename 'LAMBDA) ,(cdadr form) ,@(cddr form))) `(,keyword ,@(cdr form)))))) (let ((keyword (make-syntactic-closure base-environment '() 'LET))) (define-expander 'LET (lambda (form rename compare) compare ;ignore (if (syntax-match? '(IDENTIFIER (* (IDENTIFIER EXPRESSION)) + FORM) (cdr form)) (let ((name (cadr form)) (bindings (caddr form))) `((,(rename 'LETREC) ((,name (,(rename 'LAMBDA) ,(map car bindings) ,@(cdddr form)))) ,name) ,@(map cadr bindings))) `(,keyword ,@(cdr form)))))) (define-expander 'LET* (lambda (form rename compare) compare ;ignore (if (syntax-match? '((* (IDENTIFIER EXPRESSION)) + FORM) (cdr form)) (let ((bindings (cadr form)) (body (cddr form)) (keyword (rename 'LET))) (if (null? bindings) `(,keyword ,bindings ,@body) (let loop ((bindings bindings)) (if (null? (cdr bindings)) `(,keyword ,bindings ,@body) `(,keyword (,(car bindings)) ,(loop (cdr bindings))))))) (ill-formed-syntax form)))) (define-expander 'AND (lambda (form rename compare) compare ;ignore (if (syntax-match? '(* EXPRESSION) (cdr form)) (let ((operands (cdr form))) (if (null? operands) `#T (let ((if-keyword (rename 'IF))) (let loop ((operands operands)) (if (null? (cdr operands)) (car operands) `(,if-keyword ,(car operands) ,(loop (cdr operands)) #F)))))) (ill-formed-syntax form)))) (define-expander 'OR (lambda (form rename compare) compare ;ignore (if (syntax-match? '(* EXPRESSION) (cdr form)) (let ((operands (cdr form))) (if (null? operands) `#F (let ((let-keyword (rename 'LET)) (if-keyword (rename 'IF)) (temp (rename 'TEMP))) (let loop ((operands operands)) (if (null? (cdr operands)) (car operands) `(,let-keyword ((,temp ,(car operands))) (,if-keyword ,temp ,temp ,(loop (cdr operands))))))))) (ill-formed-syntax form)))) (define-expander 'CASE (lambda (form rename compare) (if (syntax-match? '(EXPRESSION + (DATUM + EXPRESSION)) (cdr form)) (letrec ((process-clause (lambda (clause rest) (cond ((null? (car clause)) (process-rest rest)) ((and (identifier? (car clause)) (compare (rename 'ELSE) (car clause)) (null? rest)) `(,(rename 'BEGIN) ,@(cdr clause))) ((list? (car clause)) `(,(rename 'IF) (,(rename 'MEMV) ,(rename 'TEMP) ',(car clause)) (,(rename 'BEGIN) ,@(cdr clause)) ,(process-rest rest))) (else (syntax-error "ill-formed clause" clause))))) (process-rest (lambda (rest) (if (null? rest) (unspecific-expression) (process-clause (car rest) (cdr rest)))))) `(,(rename 'LET) ((,(rename 'TEMP) ,(cadr form))) ,(process-clause (caddr form) (cdddr form)))) (ill-formed-syntax form)))) (define-expander 'COND (lambda (form rename compare) (letrec ((process-clause (lambda (clause rest) (cond ((or (not (list? clause)) (null? clause)) (syntax-error "ill-formed clause" clause)) ((and (identifier? (car clause)) (compare (rename 'ELSE) (car clause))) (cond ((or (null? (cdr clause)) (and (identifier? (cadr clause)) (compare (rename '=>) (cadr clause)))) (syntax-error "ill-formed ELSE clause" clause)) ((not (null? rest)) (syntax-error "misplaced ELSE clause" clause)) (else `(,(rename 'BEGIN) ,@(cdr clause))))) ((null? (cdr clause)) `(,(rename 'OR) ,(car clause) ,(process-rest rest))) ((and (identifier? (cadr clause)) (compare (rename '=>) (cadr clause))) (if (and (pair? (cddr clause)) (null? (cdddr clause))) `(,(rename 'LET) ((,(rename 'TEMP) ,(car clause))) (,(rename 'IF) ,(rename 'TEMP) (,(caddr clause) ,(rename 'TEMP)) ,(process-rest rest))) (syntax-error "ill-formed => clause" clause))) (else `(,(rename 'IF) ,(car clause) (,(rename 'BEGIN) ,@(cdr clause)) ,(process-rest rest)))))) (process-rest (lambda (rest) (if (null? rest) (unspecific-expression) (process-clause (car rest) (cdr rest)))))) (let ((clauses (cdr form))) (if (null? clauses) (syntax-error "no clauses" form) (process-clause (car clauses) (cdr clauses))))))) (define-expander 'DO (lambda (form rename compare) compare ;ignore (if (syntax-match? '((* (IDENTIFIER EXPRESSION ? EXPRESSION)) (+ EXPRESSION) * FORM) (cdr form)) (let ((bindings (cadr form))) `(,(rename 'LETREC) ((,(rename 'DO-LOOP) (,(rename 'LAMBDA) ,(map car bindings) (,(rename 'IF) ,(caaddr form) ,(if (null? (cdaddr form)) (unspecific-expression) `(,(rename 'BEGIN) ,@(cdaddr form))) (,(rename 'BEGIN) ,@(cdddr form) (,(rename 'DO-LOOP) ,@(map (lambda (binding) (if (null? (cddr binding)) (car binding) (caddr binding))) bindings))))))) (,(rename 'DO-LOOP) ,@(map cadr bindings)))) (ill-formed-syntax form)))) (define-expander 'QUASIQUOTE (lambda (form rename compare) (define (descend-quasiquote x level return) (cond ((pair? x) (descend-quasiquote-pair x level return)) ((vector? x) (descend-quasiquote-vector x level return)) (else (return 'QUOTE x)))) (define (descend-quasiquote-pair x level return) (cond ((not (and (pair? x) (identifier? (car x)) (pair? (cdr x)) (null? (cddr x)))) (descend-quasiquote-pair* x level return)) ((compare (rename 'QUASIQUOTE) (car x)) (descend-quasiquote-pair* x (+ level 1) return)) ((compare (rename 'UNQUOTE) (car x)) (if (zero? level) (return 'UNQUOTE (cadr x)) (descend-quasiquote-pair* x (- level 1) return))) ((compare (rename 'UNQUOTE-SPLICING) (car x)) (if (zero? level) (return 'UNQUOTE-SPLICING (cadr x)) (descend-quasiquote-pair* x (- level 1) return))) (else (descend-quasiquote-pair* x level return)))) (define (descend-quasiquote-pair* x level return) (descend-quasiquote (car x) level (lambda (car-mode car-arg) (descend-quasiquote (cdr x) level (lambda (cdr-mode cdr-arg) (cond ((and (eq? car-mode 'QUOTE) (eq? cdr-mode 'QUOTE)) (return 'QUOTE x)) ((eq? car-mode 'UNQUOTE-SPLICING) (if (and (eq? cdr-mode 'QUOTE) (null? cdr-arg)) (return 'UNQUOTE car-arg) (return 'APPEND (list car-arg (finalize-quasiquote cdr-mode cdr-arg))))) ((and (eq? cdr-mode 'QUOTE) (list? cdr-arg)) (return 'LIST (cons (finalize-quasiquote car-mode car-arg) (map (lambda (element) (finalize-quasiquote 'QUOTE element)) cdr-arg)))) ((eq? cdr-mode 'LIST) (return 'LIST (cons (finalize-quasiquote car-mode car-arg) cdr-arg))) (else (return 'CONS (list (finalize-quasiquote car-mode car-arg) (finalize-quasiquote cdr-mode cdr-arg)))))))))) (define (descend-quasiquote-vector x level return) (descend-quasiquote (vector->list x) level (lambda (mode arg) (case mode ((QUOTE) (return 'QUOTE x)) ((LIST) (return 'VECTOR arg)) (else (return 'LIST->VECTOR (list (finalize-quasiquote mode arg)))))))) (define (finalize-quasiquote mode arg) (case mode ((QUOTE) `(,(rename 'QUOTE) ,arg)) ((UNQUOTE) arg) ((UNQUOTE-SPLICING) (syntax-error ",@ in illegal context" arg)) (else `(,(rename mode) ,@arg)))) (if (syntax-match? '(EXPRESSION) (cdr form)) (descend-quasiquote (cadr form) 0 finalize-quasiquote) (ill-formed-syntax form)))) ;;; end MAKE-CORE-EXPANDER-MACROLOGY ))) @EOF chmod 666 r4rsyn.scm echo x - sc-macro.scm cat >sc-macro.scm <<'@EOF' ;;; -*- Scheme -*- ;;;; sc-macro.scm: Chris Hanson's Syntactic Closures macro implementation. ; (macro:expand ) procedure ;Returns scheme code with the macros and derived expression types of ; expanded to primitive expression types. ; (macro:eval! ) procedure ; (macro:eval ) procedure ;Macro:eval returns the value of in the current top level ;environment. Macro:eval! returns an unspecified value. ;can contain macro definitions. Side effects of will ;effect the top level environment. ; (macro:load ) procedure ;Filename should be a string. If filename names an existing file, the ;macro:load procedure reads Scheme source code expressions and ;definintions from the file and evaluates them sequentially. These ;source code expressions and definitions may contain macro ;definitions. The macro:load procedure does not affect the values ;returned by current-input-port and current-output-port. ; (macro:repl) procedure ;READs, MACRO:EVALs, and WRITEs expressions from (current-input-port) ;to (current-output-port) until an end-of-file is encountered. ;;;;-------------------------------------------------------------- ;;;; Syntaxer Output Interface (define syntax-error slib:error) (define impl-error slib:error) (define (append-map procedure . lists) (apply append (apply map (cons procedure lists)))) (define *counter* 0) (define (make-name-generator) (let ((suffix-promise (make-promise (lambda () (string-append "." (number->string (begin (set! *counter* (+ *counter* 1)) *counter*))))))) (lambda (identifier) (string->symbol (string-append "." (symbol->string (identifier->symbol identifier)) (promise:force suffix-promise)))))) (define (output/variable name) name) (define (output/literal-unquoted datum) datum) (define (output/literal-quoted datum);was output/constant (inefficient) `(QUOTE ,datum)) (define (output/assignment name value) `(SET! ,name ,value)) (define (output/top-level-definition name value) `(DEFINE ,name ,value)) (define (output/conditional predicate consequent alternative) `(IF ,predicate ,consequent ,alternative)) (define (output/sequence expressions) (if (null? (cdr expressions)) (car expressions) `(BEGIN ,@expressions))) (define (output/combination operator operands) `(,operator ,@operands)) (define (output/lambda pattern body) `(LAMBDA ,pattern ,body)) (define (output/delay expression) `(DELAY ,expression)) (define (output/unassigned) `'*UNASSIGNED*) (define (output/unspecific) `'*UNSPECIFIC*) (require 'promise) ; Portable support for force and delay. (require 'record) (require 'eval) (require 'synchk) ; Syntax checker. ;;; This file is the macro expander proper. (load (in-vicinity (library-vicinity) "synclo" (scheme-file-suffix))) ;;; These files define the R4RS syntactic environment. (load (in-vicinity (library-vicinity) "r4rsyn" (scheme-file-suffix))) (load (in-vicinity (library-vicinity) "synrul" (scheme-file-suffix))) ;;; OK, time to build the databases. (initialize-scheme-syntactic-environment!) ;;; MACRO:EXPAND is for you to use. It takes an R4RS expression, macro-expands ;;; it, and returns the result of the macro expansion. (define (macro:expand expression) (set! *counter* 0) (compile/top-level (list expression) scheme-syntactic-environment)) ;;; Here are EVAL, EVAL! and LOAD which expand macros. You can replace the ;;; implementation's eval and load with them if you like. (define base:eval! slib:eval!) (define base:eval slib:eval) (define base:load load) (define (macro:eval! x) (base:eval! (macro:expand x))) (define (macro:eval x) (base:eval (macro:expand x))) (define (macro:load ) (call-with-input-file (lambda (port) (do ((o (read port) (read port))) ((eof-object? o)) (macro:eval! o))))) ;;; Here is a read-eval-print-loop which evaluates forms with macros. (define (macro:repl) (display "> ") (force-output (current-output-port)) (let ((obj (read))) (cond ((eof-object? obj) (write obj) (newline)) (else (write (macro:eval obj)) (newline) (macro:repl))))) (provide 'macro) ;Here because we may have ;(require 'sc-macro) @EOF chmod 666 sc-macro.scm echo x - synclo.scm cat >synclo.scm <<'@EOF' ;;; -*-Scheme-*- ;;; ;;; Copyright (c) 1989-91 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. ;;;; Syntactic Closures ;;; written by Alan Bawden ;;; extensively modified by Chris Hanson ;;; See "Syntactic Closures", by Alan Bawden and Jonathan Rees, in ;;; Proceedings of the 1988 ACM Conference on Lisp and Functional ;;; Programming, page 86. ;;;; Classifier ;;; The classifier maps forms into items. In addition to locating ;;; definitions so that they can be properly processed, it also ;;; identifies keywords and variables, which allows a powerful form ;;; of syntactic binding to be implemented. (define (classify/form form environment definition-environment) (cond ((identifier? form) (syntactic-environment/lookup environment form)) ((syntactic-closure? form) (let ((form (syntactic-closure/form form)) (environment (filter-syntactic-environment (syntactic-closure/free-names form) environment (syntactic-closure/environment form)))) (classify/form form environment definition-environment))) ((pair? form) (let ((item (classify/subexpression (car form) environment))) (cond ((keyword-item? item) ((keyword-item/classifier item) form environment definition-environment)) ((list? (cdr form)) (let ((items (classify/subexpressions (cdr form) environment))) (make-expression-item (lambda () (output/combination (compile-item/expression item) (map compile-item/expression items)))))) (else (syntax-error "combination must be a proper list" form))))) (else (make-expression-item ;don't quote literals evaluating to themselves (if (or (boolean? form) (char? form) (number? form) (string? form)) (lambda () (output/literal-unquoted form)) (lambda () (output/literal-quoted form))))))) (define (classify/subform form environment definition-environment) (classify/form form environment definition-environment)) (define (classify/subforms forms environment definition-environment) (map (lambda (form) (classify/subform form environment definition-environment)) forms)) (define (classify/subexpression expression environment) (classify/subform expression environment null-syntactic-environment)) (define (classify/subexpressions expressions environment) (classify/subforms expressions environment null-syntactic-environment)) ;;;; Compiler ;;; The compiler maps items into the output language. (define (compile-item/expression item) (let ((illegal (lambda (item name) (syntax-error (string-append name " may not be used as an expression") "")))) (cond ((variable-item? item) (output/variable (variable-item/name item))) ((expression-item? item) ((expression-item/compiler item))) ((body-item? item) (let ((items (flatten-body-items (body-item/components item)))) (if (null? items) (illegal item "empty sequence") (output/sequence (map compile-item/expression items))))) ((definition-item? item) (illegal item "definition")) ((keyword-item? item) (illegal item "keyword")) (else (impl-error "unknown item" item))))) (define (compile/subexpression expression environment) (compile-item/expression (classify/subexpression expression environment))) (define (compile/top-level forms environment) ;; Top-level syntactic definitions affect all forms that appear ;; after them. (output/top-level-sequence (let forms-loop ((forms forms)) (if (null? forms) '() (let items-loop ((items (item->list (classify/subform (car forms) environment environment)))) (cond ((null? items) (forms-loop (cdr forms))) ((definition-item? (car items)) (let ((binding (bind-definition-item! environment (car items)))) (if binding (cons (output/top-level-definition (car binding) (compile-item/expression (cdr binding))) (items-loop (cdr items))) (items-loop (cdr items))))) (else (cons (compile-item/expression (car items)) (items-loop (cdr items)))))))))) ;;;; Syntactic Closures (define syntactic-closure-type (make-record-type "syntactic-closure" '(ENVIRONMENT FREE-NAMES FORM))) (define make-syntactic-closure (record-constructor syntactic-closure-type '(ENVIRONMENT FREE-NAMES FORM))) (define syntactic-closure? (record-predicate syntactic-closure-type)) (define syntactic-closure/environment (record-accessor syntactic-closure-type 'ENVIRONMENT)) (define syntactic-closure/free-names (record-accessor syntactic-closure-type 'FREE-NAMES)) (define syntactic-closure/form (record-accessor syntactic-closure-type 'FORM)) (define (make-syntactic-closure-list environment free-names forms) (map (lambda (form) (make-syntactic-closure environment free-names form)) forms)) (define (strip-syntactic-closures object) (cond ((syntactic-closure? object) (strip-syntactic-closures (syntactic-closure/form object))) ((pair? object) (cons (strip-syntactic-closures (car object)) (strip-syntactic-closures (cdr object)))) ((vector? object) (let ((length (vector-length object))) (let ((result (make-vector length))) (do ((i 0 (+ i 1))) ((= i length)) (vector-set! result i (strip-syntactic-closures (vector-ref object i)))) result))) (else object))) (define (identifier? object) (or (symbol? object) (synthetic-identifier? object))) (define (synthetic-identifier? object) (and (syntactic-closure? object) (identifier? (syntactic-closure/form object)))) (define (identifier->symbol identifier) (cond ((symbol? identifier) identifier) ((synthetic-identifier? identifier) (identifier->symbol (syntactic-closure/form identifier))) (else (impl-error "not an identifier" identifier)))) (define (identifier=? environment-1 identifier-1 environment-2 identifier-2) (let ((item-1 (syntactic-environment/lookup environment-1 identifier-1)) (item-2 (syntactic-environment/lookup environment-2 identifier-2))) (or (eq? item-1 item-2) ;; This is necessary because an identifier that is not ;; explicitly bound by an environment is mapped to a variable ;; item, and the variable items are not cached. Therefore ;; two references to the same variable result in two ;; different variable items. (and (variable-item? item-1) (variable-item? item-2) (eq? (variable-item/name item-1) (variable-item/name item-2)))))) ;;;; Syntactic Environments (define syntactic-environment-type (make-record-type "syntactic-environment" '(PARENT LOOKUP-OPERATION RENAME-OPERATION DEFINE-OPERATION BINDINGS-OPERATION))) (define make-syntactic-environment (record-constructor syntactic-environment-type '(PARENT LOOKUP-OPERATION RENAME-OPERATION DEFINE-OPERATION BINDINGS-OPERATION))) (define syntactic-environment? (record-predicate syntactic-environment-type)) (define syntactic-environment/parent (record-accessor syntactic-environment-type 'PARENT)) (define syntactic-environment/lookup-operation (record-accessor syntactic-environment-type 'LOOKUP-OPERATION)) (define (syntactic-environment/assign! environment name item) (let ((binding ((syntactic-environment/lookup-operation environment) name))) (if binding (set-cdr! binding item) (impl-error "can't assign unbound identifier" name)))) (define syntactic-environment/rename-operation (record-accessor syntactic-environment-type 'RENAME-OPERATION)) (define (syntactic-environment/rename environment name) ((syntactic-environment/rename-operation environment) name)) (define syntactic-environment/define! (let ((accessor (record-accessor syntactic-environment-type 'DEFINE-OPERATION))) (lambda (environment name item) ((accessor environment) name item)))) (define syntactic-environment/bindings (let ((accessor (record-accessor syntactic-environment-type 'BINDINGS-OPERATION))) (lambda (environment) ((accessor environment))))) (define (syntactic-environment/lookup environment name) (let ((binding ((syntactic-environment/lookup-operation environment) name))) (cond (binding (let ((item (cdr binding))) (if (reserved-name-item? item) (syntax-error "premature reference to reserved name" name) item))) ((symbol? name) (make-variable-item name)) ((synthetic-identifier? name) (syntactic-environment/lookup (syntactic-closure/environment name) (syntactic-closure/form name))) (else (impl-error "not an identifier" name))))) (define root-syntactic-environment (make-syntactic-environment #f (lambda (name) name #f) (lambda (name) name) (lambda (name item) (impl-error "can't bind name in root syntactic environment" name item)) (lambda () '()))) (define null-syntactic-environment (make-syntactic-environment #f (lambda (name) (impl-error "can't lookup name in null syntactic environment" name)) (lambda (name) (impl-error "can't rename name in null syntactic environment" name)) (lambda (name item) (impl-error "can't bind name in null syntactic environment" name item)) (lambda () '()))) (define (top-level-syntactic-environment parent) (let ((bound '())) (make-syntactic-environment parent (let ((parent-lookup (syntactic-environment/lookup-operation parent))) (lambda (name) (or (assq name bound) (parent-lookup name)))) (lambda (name) name) (lambda (name item) (let ((binding (assq name bound))) (if binding (set-cdr! binding item) (set! bound (cons (cons name item) bound))))) (lambda () (alist-copy bound))))) (define (internal-syntactic-environment parent) (let ((bound '()) (free '())) (make-syntactic-environment parent (let ((parent-lookup (syntactic-environment/lookup-operation parent))) (lambda (name) (or (assq name bound) (assq name free) (let ((binding (parent-lookup name))) (if binding (set! free (cons binding free))) binding)))) (make-name-generator) (lambda (name item) (cond ((assq name bound) => (lambda (association) (if (and (reserved-name-item? (cdr association)) (not (reserved-name-item? item))) (set-cdr! association item) (impl-error "can't redefine name; already bound" name)))) ((assq name free) (if (reserved-name-item? item) (syntax-error "premature reference to reserved name" name) (impl-error "can't define name; already free" name))) (else (set! bound (cons (cons name item) bound))))) (lambda () (alist-copy bound))))) (define (filter-syntactic-environment names names-env else-env) (if (or (null? names) (eq? names-env else-env)) else-env (let ((make-operation (lambda (get-operation) (let ((names-operation (get-operation names-env)) (else-operation (get-operation else-env))) (lambda (name) ((if (memq name names) names-operation else-operation) name)))))) (make-syntactic-environment else-env (make-operation syntactic-environment/lookup-operation) (make-operation syntactic-environment/rename-operation) (lambda (name item) (impl-error "can't bind name in filtered syntactic environment" name item)) (lambda () (map (lambda (name) (cons name (syntactic-environment/lookup names-env name))) names)))))) ;;;; Items ;;; Reserved name items do not represent any form, but instead are ;;; used to reserve a particular name in a syntactic environment. If ;;; the classifier refers to a reserved name, a syntax error is ;;; signalled. This is used in the implementation of LETREC-SYNTAX ;;; to signal a meaningful error when one of the s refers to ;;; one of the names being bound. (define reserved-name-item-type (make-record-type "reserved-name-item" '())) (define make-reserved-name-item (record-constructor reserved-name-item-type '())) (define reserved-name-item? (record-predicate reserved-name-item-type)) ;;; Keyword items represent macro keywords. (define keyword-item-type (make-record-type "keyword-item" '(CLASSIFIER))) (define make-keyword-item (record-constructor keyword-item-type '(CLASSIFIER))) (define keyword-item? (record-predicate keyword-item-type)) (define keyword-item/classifier (record-accessor keyword-item-type 'CLASSIFIER)) ;;; Variable items represent run-time variables. (define variable-item-type (make-record-type "variable-item" '(NAME))) (define make-variable-item (record-constructor variable-item-type '(NAME))) (define variable-item? (record-predicate variable-item-type)) (define variable-item/name (record-accessor variable-item-type 'NAME)) ;;; Expression items represent any kind of expression other than a ;;; run-time variable or a sequence. The ANNOTATION field is used to ;;; make expression items that can appear in non-expression contexts ;;; (for example, this could be used in the implementation of SETF). (define expression-item-type (make-record-type "expression-item" '(COMPILER ANNOTATION))) (define make-special-expression-item (record-constructor expression-item-type '(COMPILER ANNOTATION))) (define expression-item? (record-predicate expression-item-type)) (define expression-item/compiler (record-accessor expression-item-type 'COMPILER)) (define expression-item/annotation (record-accessor expression-item-type 'ANNOTATION)) (define (make-expression-item compiler) (make-special-expression-item compiler #f)) ;;; Body items represent sequences (e.g. BEGIN). (define body-item-type (make-record-type "body-item" '(COMPONENTS))) (define make-body-item (record-constructor body-item-type '(COMPONENTS))) (define body-item? (record-predicate body-item-type)) (define body-item/components (record-accessor body-item-type 'COMPONENTS)) ;;; Definition items represent definitions, whether top-level or ;;; internal, keyword or variable. (define definition-item-type (make-record-type "definition-item" '(BINDING-THEORY NAME VALUE))) (define make-definition-item (record-constructor definition-item-type '(BINDING-THEORY NAME VALUE))) (define definition-item? (record-predicate definition-item-type)) (define definition-item/binding-theory (record-accessor definition-item-type 'BINDING-THEORY)) (define definition-item/name (record-accessor definition-item-type 'NAME)) (define definition-item/value (record-accessor definition-item-type 'VALUE)) (define (bind-definition-item! environment item) ((definition-item/binding-theory item) environment (definition-item/name item) (promise:force (definition-item/value item)))) (define (syntactic-binding-theory environment name item) (if (or (keyword-item? item) (variable-item? item)) (begin (syntactic-environment/define! environment name item) #f) (syntax-error "syntactic binding value must be a keyword or a variable" item))) (define (variable-binding-theory environment name item) ;; If ITEM isn't a valid expression, an error will be signalled by ;; COMPILE-ITEM/EXPRESSION later. (cons (bind-variable! environment name) item)) (define (overloaded-binding-theory environment name item) (if (keyword-item? item) (begin (syntactic-environment/define! environment name item) #f) (cons (bind-variable! environment name) item))) ;;;; Classifiers, Compilers, Expanders (define (sc-expander->classifier expander keyword-environment) (lambda (form environment definition-environment) (classify/form (expander form environment) keyword-environment definition-environment))) (define (er-expander->classifier expander keyword-environment) (sc-expander->classifier (er->sc-expander expander) keyword-environment)) (define (er->sc-expander expander) (lambda (form environment) (capture-syntactic-environment (lambda (keyword-environment) (make-syntactic-closure environment '() (expander form (let ((renames '())) (lambda (identifier) (let ((association (assq identifier renames))) (if association (cdr association) (let ((rename (make-syntactic-closure keyword-environment '() identifier))) (set! renames (cons (cons identifier rename) renames)) rename))))) (lambda (x y) (identifier=? environment x environment y)))))))) (define (classifier->keyword classifier) (make-syntactic-closure (let ((environment (internal-syntactic-environment null-syntactic-environment))) (syntactic-environment/define! environment 'KEYWORD (make-keyword-item classifier)) environment) '() 'KEYWORD)) (define (compiler->keyword compiler) (classifier->keyword (compiler->classifier compiler))) (define (classifier->form classifier) `(,(classifier->keyword classifier))) (define (compiler->form compiler) (classifier->form (compiler->classifier compiler))) (define (compiler->classifier compiler) (lambda (form environment definition-environment) definition-environment ;ignore (make-expression-item (lambda () (compiler form environment))))) ;;;; Macrologies ;;; A macrology is a procedure that accepts a syntactic environment ;;; as an argument, producing a new syntactic environment that is an ;;; extension of the argument. (define (make-primitive-macrology generate-definitions) (lambda (base-environment) (let ((environment (top-level-syntactic-environment base-environment))) (let ((define-classifier (lambda (keyword classifier) (syntactic-environment/define! environment keyword (make-keyword-item classifier))))) (generate-definitions define-classifier (lambda (keyword compiler) (define-classifier keyword (compiler->classifier compiler))))) environment))) (define (make-expander-macrology object->classifier generate-definitions) (lambda (base-environment) (let ((environment (top-level-syntactic-environment base-environment))) (generate-definitions (lambda (keyword object) (syntactic-environment/define! environment keyword (make-keyword-item (object->classifier object environment)))) base-environment) environment))) (define (make-sc-expander-macrology generate-definitions) (make-expander-macrology sc-expander->classifier generate-definitions)) (define (make-er-expander-macrology generate-definitions) (make-expander-macrology er-expander->classifier generate-definitions)) (define (compose-macrologies . macrologies) (lambda (environment) (do ((macrologies macrologies (cdr macrologies)) (environment environment ((car macrologies) environment))) ((null? macrologies) environment)))) ;;;; Utilities (define (bind-variable! environment name) (let ((rename (syntactic-environment/rename environment name))) (syntactic-environment/define! environment name (make-variable-item rename)) rename)) (define (reserve-names! names environment) (let ((item (make-reserved-name-item))) (for-each (lambda (name) (syntactic-environment/define! environment name item)) names))) (define (capture-syntactic-environment expander) (classifier->form (lambda (form environment definition-environment) form ;ignore (classify/form (expander environment) environment definition-environment)))) (define (unspecific-expression) (compiler->form (lambda (form environment) form environment ;ignore (output/unspecific)))) (define (unassigned-expression) (compiler->form (lambda (form environment) form environment ;ignore (output/unassigned)))) (define (syntax-quote expression) `(,(compiler->keyword (lambda (form environment) environment ;ignore (syntax-check '(KEYWORD DATUM) form) (output/literal-quoted (cadr form)))) ,expression)) (define (flatten-body-items items) (append-map item->list items)) (define (item->list item) (if (body-item? item) (flatten-body-items (body-item/components item)) (list item))) (define (output/let names values body) (if (null? names) body (output/combination (output/lambda names body) values))) (define (output/letrec names values body) (if (null? names) body (output/let names (map (lambda (name) name (output/unassigned)) names) (output/sequence (list (if (null? (cdr names)) (output/assignment (car names) (car values)) (let ((temps (map (make-name-generator) names))) (output/let temps values (output/sequence (map output/assignment names temps))))) body))))) (define (output/top-level-sequence expressions) (if (null? expressions) (output/unspecific) (output/sequence expressions))) @EOF chmod 666 synclo.scm echo x - synrul.scm cat >synrul.scm <<'@EOF' ;;; -*-Scheme-*- ;;; ;;; Copyright (c) 1989-91 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. ;;;; Rule-based Syntactic Expanders ;;; See "Syntactic Extensions in the Programming Language Lisp", by ;;; Eugene Kohlbecker, Ph.D. dissertation, Indiana University, 1986. ;;; See also "Macros That Work", by William Clinger and Jonathan Rees ;;; (reference? POPL?). This implementation is derived from an ;;; implementation by Kent Dybvig, and includes some ideas from ;;; another implementation by Jonathan Rees. ;;; The expansion of SYNTAX-RULES references the following keywords: ;;; ER-TRANSFORMER LAMBDA IF BEGIN SET! QUOTE ;;; and the following procedures: ;;; CAR CDR NULL? PAIR? EQUAL? MAP LIST CONS APPEND ;;; ILL-FORMED-SYNTAX ;;; it also uses the anonymous keyword SYNTAX-QUOTE. ;;; For testing. ;;;(define (run-sr form) ;;; (expand/syntax-rules form (lambda (x) x) eq?)) (define (make-syntax-rules-macrology) (make-er-expander-macrology (lambda (define-classifier base-environment) base-environment ;ignore (define-classifier 'SYNTAX-RULES expand/syntax-rules)))) (define (expand/syntax-rules form rename compare) (if (syntax-match? '((* IDENTIFIER) + ((IDENTIFIER . DATUM) EXPRESSION)) (cdr form)) (let ((keywords (cadr form)) (clauses (cddr form))) (if (let loop ((keywords keywords)) (and (pair? keywords) (or (memq (car keywords) (cdr keywords)) (loop (cdr keywords))))) (syntax-error "keywords list contains duplicates" keywords) (let ((r-form (rename 'FORM)) (r-rename (rename 'RENAME)) (r-compare (rename 'COMPARE))) `(,(rename 'ER-TRANSFORMER) (,(rename 'LAMBDA) (,r-form ,r-rename ,r-compare) ,(let loop ((clauses clauses)) (if (null? clauses) `(,(rename 'ILL-FORMED-SYNTAX) ,r-form) (let ((pattern (caar clauses))) (let ((sids (parse-pattern rename compare keywords pattern r-form))) `(,(rename 'IF) ,(generate-match rename compare keywords r-rename r-compare pattern r-form) ,(generate-output rename compare r-rename sids (cadar clauses) syntax-error) ,(loop (cdr clauses)))))))))))) (ill-formed-syntax form))) (define (parse-pattern rename compare keywords pattern expression) (let loop ((pattern pattern) (expression expression) (sids '()) (control #f)) (cond ((identifier? pattern) (if (memq pattern keywords) sids (cons (make-sid pattern expression control) sids))) ((and (or (zero-or-more? pattern rename compare) (at-least-one? pattern rename compare)) (null? (cddr pattern))) (let ((variable ((make-name-generator) 'CONTROL))) (loop (car pattern) variable sids (make-sid variable expression control)))) ((pair? pattern) (loop (car pattern) `(,(rename 'CAR) ,expression) (loop (cdr pattern) `(,(rename 'CDR) ,expression) sids control) control)) (else sids)))) (define (generate-match rename compare keywords r-rename r-compare pattern expression) (letrec ((loop (lambda (pattern expression) (cond ((identifier? pattern) (if (memq pattern keywords) (let ((temp (rename 'TEMP))) `((,(rename 'LAMBDA) (,temp) (,(rename 'IF) (,(rename 'IDENTIFIER?) ,temp) (,r-compare ,temp (,r-rename ,(syntax-quote pattern))) #f)) ,expression)) `#t)) ((and (zero-or-more? pattern rename compare) (null? (cddr pattern))) (do-list (car pattern) expression)) ((and (at-least-one? pattern rename compare) (null? (cddr pattern))) `(,(rename 'IF) (,(rename 'NULL?) ,expression) #F ,(do-list (car pattern) expression))) ((pair? pattern) (let ((generate-pair (lambda (expression) (conjunction `(,(rename 'PAIR?) ,expression) (conjunction (loop (car pattern) `(,(rename 'CAR) ,expression)) (loop (cdr pattern) `(,(rename 'CDR) ,expression))))))) (if (identifier? expression) (generate-pair expression) (let ((temp (rename 'TEMP))) `((,(rename 'LAMBDA) (,temp) ,(generate-pair temp)) ,expression))))) ((null? pattern) `(,(rename 'NULL?) ,expression)) (else `(,(rename 'EQUAL?) ,expression (,(rename 'QUOTE) ,pattern)))))) (do-list (lambda (pattern expression) (let ((r-loop (rename 'LOOP)) (r-l (rename 'L)) (r-lambda (rename 'LAMBDA))) `(((,r-lambda (,r-loop) (,(rename 'BEGIN) (,(rename 'SET!) ,r-loop (,r-lambda (,r-l) (,(rename 'IF) (,(rename 'NULL?) ,r-l) #T ,(conjunction `(,(rename 'PAIR?) ,r-l) (conjunction (loop pattern `(,(rename 'CAR) ,r-l)) `(,r-loop (,(rename 'CDR) ,r-l))))))) ,r-loop)) #F) ,expression)))) (conjunction (lambda (predicate consequent) (cond ((eq? predicate #T) consequent) ((eq? consequent #T) predicate) (else `(,(rename 'IF) ,predicate ,consequent #F)))))) (loop pattern expression))) (define (generate-output rename compare r-rename sids template syntax-error) (let loop ((template template) (ellipses '())) (cond ((identifier? template) (let ((sid (let loop ((sids sids)) (and (not (null? sids)) (if (eq? (sid-name (car sids)) template) (car sids) (loop (cdr sids))))))) (if sid (begin (add-control! sid ellipses syntax-error) (sid-expression sid)) `(,r-rename ,(syntax-quote template))))) ((or (zero-or-more? template rename compare) (at-least-one? template rename compare)) (optimized-append rename compare (let ((ellipsis (make-ellipsis '()))) (generate-ellipsis rename ellipsis (loop (car template) (cons ellipsis ellipses)))) (loop (cddr template) ellipses))) ((pair? template) (optimized-cons rename compare (loop (car template) ellipses) (loop (cdr template) ellipses))) (else `(,(rename 'QUOTE) ,template))))) (define (add-control! sid ellipses syntax-error) (let loop ((sid sid) (ellipses ellipses)) (let ((control (sid-control sid))) (cond (control (if (null? ellipses) (syntax-error "missing ellipsis in expansion" #f) (let ((sids (ellipsis-sids (car ellipses)))) (cond ((not (memq control sids)) (set-ellipsis-sids! (car ellipses) (cons control sids))) ((not (eq? control (car sids))) (syntax-error "illegal control/ellipsis combination" control sids))))) (loop control (cdr ellipses))) ((not (null? ellipses)) (syntax-error "extra ellipsis in expansion" #f)))))) (define (generate-ellipsis rename ellipsis body) (let ((sids (ellipsis-sids ellipsis))) (let ((name (sid-name (car sids))) (expression (sid-expression (car sids)))) (cond ((and (null? (cdr sids)) (eq? body name)) expression) ((and (null? (cdr sids)) (pair? body) (pair? (cdr body)) (eq? (cadr body) name) (null? (cddr body))) `(,(rename 'MAP) ,(car body) ,expression)) (else `(,(rename 'MAP) (,(rename 'LAMBDA) ,(map sid-name sids) ,body) ,@(map sid-expression sids))))))) (define (zero-or-more? pattern rename compare) (and (pair? pattern) (pair? (cdr pattern)) (identifier? (cadr pattern)) (compare (cadr pattern) (rename '...)))) (define (at-least-one? pattern rename compare) ;;; (and (pair? pattern) ;;; (pair? (cdr pattern)) ;;; (identifier? (cadr pattern)) ;;; (compare (cadr pattern) (rename '+))) pattern rename compare ;ignore #f) (define (optimized-cons rename compare a d) (cond ((and (pair? d) (compare (car d) (rename 'QUOTE)) (pair? (cdr d)) (null? (cadr d)) (null? (cddr d))) `(,(rename 'LIST) ,a)) ((and (pair? d) (compare (car d) (rename 'LIST)) (list? (cdr d))) `(,(car d) ,a ,@(cdr d))) (else `(,(rename 'CONS) ,a ,d)))) (define (optimized-append rename compare x y) (if (and (pair? y) (compare (car y) (rename 'QUOTE)) (pair? (cdr y)) (null? (cadr y)) (null? (cddr y))) x `(,(rename 'APPEND) ,x ,y))) (define sid-type (make-record-type "sid" '(NAME EXPRESSION CONTROL OUTPUT-EXPRESSION))) (define make-sid (record-constructor sid-type '(NAME EXPRESSION CONTROL))) (define sid-name (record-accessor sid-type 'NAME)) (define sid-expression (record-accessor sid-type 'EXPRESSION)) (define sid-control (record-accessor sid-type 'CONTROL)) (define sid-output-expression (record-accessor sid-type 'OUTPUT-EXPRESSION)) (define set-sid-output-expression! (record-modifier sid-type 'OUTPUT-EXPRESSION)) (define ellipsis-type (make-record-type "ellipsis" '(SIDS))) (define make-ellipsis (record-constructor ellipsis-type '(SIDS))) (define ellipsis-sids (record-accessor ellipsis-type 'SIDS)) (define set-ellipsis-sids! (record-modifier ellipsis-type 'SIDS)) @EOF chmod 666 synrul.scm echo x - synchk.scm cat >synchk.scm <<'@EOF' ;;; -*-Scheme-*- ;;; ;;; Copyright (c) 1989-91 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. ;;;; Syntax Checking ;;; written by Alan Bawden ;;; modified by Chris Hanson (define (syntax-check pattern form) (if (not (syntax-match? (cdr pattern) (cdr form))) (syntax-error "ill-formed special form" form))) (define (ill-formed-syntax form) (syntax-error "ill-formed special form" form)) (define (syntax-match? pattern object) (let ((match-error (lambda () (impl-error "ill-formed pattern" pattern)))) (cond ((symbol? pattern) (case pattern ((IDENTIFIER) (identifier? object)) ((DATUM EXPRESSION FORM) #t) ((R4RS-BVL) (let loop ((seen '()) (object object)) (or (null? object) (if (identifier? object) (not (memq object seen)) (and (pair? object) (identifier? (car object)) (not (memq (car object) seen)) (loop (cons (car object) seen) (cdr object))))))) ((MIT-BVL) (lambda-list? object)) (else (match-error)))) ((pair? pattern) (case (car pattern) ((*) (if (pair? (cdr pattern)) (let ((head (cadr pattern)) (tail (cddr pattern))) (let loop ((object object)) (or (and (pair? object) (syntax-match? head (car object)) (loop (cdr object))) (syntax-match? tail object)))) (match-error))) ((+) (if (pair? (cdr pattern)) (let ((head (cadr pattern)) (tail (cddr pattern))) (and (pair? object) (syntax-match? head (car object)) (let loop ((object (cdr object))) (or (and (pair? object) (syntax-match? head (car object)) (loop (cdr object))) (syntax-match? tail object))))) (match-error))) ((?) (if (pair? (cdr pattern)) (or (and (pair? object) (syntax-match? (cadr pattern) (car object)) (syntax-match? (cddr pattern) (cdr object))) (syntax-match? (cddr pattern) object)) (match-error))) ((QUOTE) (if (and (pair? (cdr pattern)) (null? (cddr pattern))) (eqv? (cadr pattern) object) (match-error))) (else (and (pair? object) (syntax-match? (car pattern) (car object)) (syntax-match? (cdr pattern) (cdr object)))))) (else (eqv? pattern object))))) @EOF chmod 666 synchk.scm echo x - record.scm cat >record.scm <<'@EOF' ; Record.scm. This more or less implements the records that are ; proposed for R5RS - unfortunately, all records created in this ; manner look like vectors. I believe the original record proposal ; was made by Jonathan Rees. This implementation defines some symbols ; other than those that are part of the record proposal - this ; wouldn't be a problem if Scheme had a module system, but it doesn't. ; Written by David Carlton, carlton@husc.harvard.edu. This code is in ; the public domain. ; Extensively Modified for SLIB by Aubrey Jaffer, jaffer@ai.mit.edu. ; May 17 1992, MAKE-RECORD-SUB-TYPE added by jaffer. (require 'common-list-functions) ; Tags to help identify rtd's. (A record is identified by the rtd ; that begins it.) (define record:*rtd-tag* (cons 'rtd '())) ; Checks to see if a list has any duplicates. Also checks to see if ; it a list, for that matter. (define (record:has-duplicates? lst) (cond ((null? lst) #f) ((not (pair? lst)) #t) ((memq (car lst) (cdr lst)) #t) (else (record:has-duplicates? (cdr lst))))) ; Various accessor functions. No error checking; if you call these, ; you should know that they will work. (define (record:rtd-tag x) (vector-ref x 0)) (define (record:rtd-name rtd) (vector-ref rtd 1)) (define (record:rtd-supers rtd) (vector-ref rtd 2)) (define (record:rtd-fields rtd) (vector-ref rtd 3)) ;; rtd-vfields is padded out to the length of the vector, which is 1 ;; more than the number of fields (define (record:rtd-vfields rtd) (cons #f (record:rtd-fields rtd))) ;; rtd-length is the length of the vector. (define (record:rtd-length rtd) (vector-ref rtd 4)) (define (record:record-rtd x) (vector-ref x 0)) (define (record:record-supers x) (vector-ref (vector-ref x 0) 2)) (define (record-predicate rtd) (if (not (record:rtd? rtd)) (slib:error "record-predicate: invalid argument." rtd)) (vector-ref rtd 5)) (define (make-record-type type-name field-names) (if (not (string? type-name)) (slib:error "make-record-type: non-string type-name argument." type-name)) (if (or (record:has-duplicates? field-names) (notevery symbol? field-names)) (slib:error "make-record-type: illegal field-names argument." field-names)) (let* ((corrected-length (+ 1 (length field-names))) (rtd (vector record:*rtd-tag* type-name '() field-names corrected-length #f))) (vector-set! rtd 5 (lambda (x) (and (vector? x) (= (vector-length x) corrected-length) (eq? (record:record-rtd x) rtd)))) rtd)) (define (make-record-sub-type type-name field-names rtd) (if (not (string? type-name)) (slib:error "make-record-sub-type: non-string type-name argument." type-name)) (if (not (record:rtd? rtd)) (slib:error "make-record-sub-type: non-rtd rtd argument." rtd)) (let ((xfield-names (append (record:rtd-fields rtd) field-names))) (if (or (record:has-duplicates? xfield-names) (notevery symbol? field-names)) (slib:error "make-record-sub-type: illegal field-names argument." field-names)) (let* ((corrected-length (+ 1 (length xfield-names))) (rtd (vector record:*rtd-tag* type-name (cons rtd (record:rtd-supers rtd)) xfield-names corrected-length #f))) (vector-set! rtd 5 (lambda (x) (and (vector? x) (= (vector-length x) corrected-length) (eq? (record:record-rtd x) rtd)))) rtd))) ; Determines whether or not a certain object looks like an rtd. ; Doesn't do as much error-checking as it could, but it would be quite ; unlikely for somebody to accidentally fool this function. (define (record:rtd? object) (and (vector? object) ;; Could check for the exact value here, but then I'd have to ;; keep changing this as I change the format of a rtd. This ;; is good enough to get the vector-ref to work. (not (= (vector-length object) 0)) (eq? (record:rtd-tag object) record:*rtd-tag*))) (define (record-constructor rtd . field-names) (if (not (record:rtd? rtd)) (slib:error "record-constructor: illegal rtd argument." rtd)) (if (or (null? field-names) (equal? field-names (record:rtd-fields rtd))) (let ((record-length (- (record:rtd-length rtd) 1))) (lambda elts (if (= (length elts) record-length) #t (slib:error "record-constructor: " (record:rtd-name rtd) ": wrong number of arguments.")) (apply vector rtd elts))) (let ((record-vfields (record:rtd-vfields rtd)) (corrected-record-length (record:rtd-length rtd)) (field-names (car field-names))) (if (or (record:has-duplicates? field-names) (notevery (lambda (x) (memq x record-vfields)) field-names)) (slib:error "record-constructor: invalid field-names argument." (cdr record-vfields))) (let ((field-length (length field-names)) (offsets (map (lambda (field) (position field record-vfields)) field-names))) (lambda elts (if (= (length elts) field-length) #t (slib:error "record-constructor: " (record:rtd-name rtd) ": wrong number of arguments.")) (let ((result (make-vector corrected-record-length))) (vector-set! result 0 rtd) (for-each (lambda (offset elt) (vector-set! result offset elt)) offsets elts) result)))))) (define (record-accessor rtd field-name) (if (not (record:rtd? rtd)) (slib:error "record-accessor: invalid rtd argument." rtd)) (let ((index (position field-name (record:rtd-vfields rtd))) (corrected-length (record:rtd-length rtd))) (if (not index) (slib:error "record-accessor: invalid field-name argument." field-name)) (lambda (x) (if (and (vector? x) (>= (vector-length x) corrected-length) (or (eq? rtd (record:record-rtd x)) (memq rtd (record:record-supers x)))) #t (slib:error "record-accessor: wrong record type." x "not" rtd)) (vector-ref x index)))) (define (record-modifier rtd field-name) (if (not (record:rtd? rtd)) (slib:error "record-modifier: invalid rtd argument." rtd)) (let ((index (position field-name (record:rtd-vfields rtd))) (corrected-length (record:rtd-length rtd))) (if (not index) (slib:error "record-modifier: invalid field-name argument." field-name)) (lambda (x y) (if (and (vector? x) (>= (vector-length x) corrected-length) (or (eq? rtd (record:record-rtd x)) (memq rtd (record:record-supers x)))) #t (slib:error "record-modifier: wrong record type." x "not" rtd)) (vector-set! x index y)))) (define (record? obj) (and (vector? obj) (>= (vector-length obj) 1) (record:rtd? (record:record-rtd obj)) (= (vector-length obj) (record:rtd-length (record:record-rtd obj))))) (define (record-type-descriptor record) (if (not (record? record)) (slib:error "record-type-descriptor: invalid argument." record)) (record:record-rtd record)) (define (record-type-name rtd) (if (not (record:rtd? rtd)) (perror "record-type-name: invalid argument.")) (record:rtd-name rtd)) ; For this function, make a copy of the value returned in order to ; make it a bit harder for the user to screw things up. (define (record-type-field-names rtd) (if (not (record:rtd? rtd)) (slib:error "record-type-field-names: invalid argument." rtd)) (append (record:rtd-fields rtd))) @EOF chmod 666 record.scm echo x - promise.scm cat >promise.scm <<'@EOF' ;From Revised^4 Report on the Algorithmic Language Scheme ;William Clinger and Jonathon Rees (Editors) (define promise:force (lambda (object) (object))) (define make-promise (lambda (proc) (let ((result-ready? #f) (result #f)) (lambda () (if result-ready? result (let ((x (proc))) (if result-ready? result (begin (set! result-ready? #t) (set! result x) result)))))))) ;;; change occurences of (DELAY ) to ;;; (MAKE-PROMISE (LAMBDA () )) ;;; and (define force promise:force) @EOF chmod 666 promise.scm echo x - values.scm cat >values.scm <<'@EOF' ; By david carlton, carlton@husc.harvard.edu. This code is in the ; public domain. (require 'record) (define values:*values-rtd* (make-record-type "values" '(values))) (define values (let ((make-values (record-constructor values:*values-rtd*))) (lambda x (if (and (not (null? x)) (null? (cdr x))) (car x) (make-values x))))) (define call-with-values (let ((access-values (record-accessor values:*values-rtd* 'values)) (values-predicate? (record-predicate values:*values-rtd*))) (lambda (producer consumer) (let ((result (producer))) (if (values-predicate? result) (apply consumer (access-values result)) (consumer result)))))) @EOF chmod 666 values.scm echo x - queue.scm cat >queue.scm <<'@EOF' ; queue.scm Queues/Stacks for Scheme ; Copyright Andrew Wilcox 1992. ; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992. ; This code is in the public domain. (require 'record) ; Elements in a queue are stored in a list. The last pair in the list ; is stored in the queue type so that datums can be added in constant ; time. (define queue:record-type (make-record-type "queue" '(first-pair last-pair))) (define make-queue (let ((construct-queue (record-constructor queue:record-type))) (lambda () (construct-queue '() '())))) (define queue? (record-predicate queue:record-type)) (define queue:first-pair (record-accessor queue:record-type 'first-pair)) (define queue:set-first-pair! (record-modifier queue:record-type 'first-pair)) (define queue:last-pair (record-accessor queue:record-type 'last-pair)) (define queue:set-last-pair! (record-modifier queue:record-type 'last-pair)) (define (queue-empty? q) (null? (queue:first-pair q))) (define (queue-front q) (let ((first-pair (queue:first-pair q))) (if (null? first-pair) (slib:error "queue is empty" q)) (car first-pair))) (define (queue-rear q) (let ((last-pair (queue:last-pair q))) (if (null? last-pair) (slib:error "queue is empty" q)) (car last-pair))) (define (queue-push! q datum) (let* ((old-first-pair (queue:first-pair q)) (new-first-pair (cons datum old-first-pair))) (queue:set-first-pair! q new-first-pair) (if (null? old-first-pair) (queue:set-last-pair! q new-first-pair))) q) (define (enqueue! q datum) (let ((new-pair (cons datum '()))) (cond ((null? (queue:first-pair q)) (queue:set-first-pair! q new-pair)) (else (set-cdr! (queue:last-pair q) new-pair))) (queue:set-last-pair! q new-pair)) q) (define (dequeue! q) (let ((first-pair (queue:first-pair q))) (if (null? first-pair) (slib:error "queue is empty" q)) (let ((first-cdr (cdr first-pair))) (queue:set-first-pair! q first-cdr) (if (null? first-cdr) (queue:set-last-pair! q '())) (car first-pair)))) (define queue-pop! dequeue!) @EOF chmod 666 queue.scm echo x - process.scm cat >process.scm <<'@EOF' ;;;; "process.scm", Multi-Processing for Scheme ;;; Copyright (C) 1992 Aubrey Jaffer. ;;;;STILL NOT WORKING ; (add-process! proc) procedure ; ;Adds proc, which must be a procedure (or continuation) capable of ;accepting accepting one argument, to the process:queue. The value ;returned is unspecified. The argument to proc should be ignored. If ;proc returns the process is killed. ; ; (process:schedule!) procedure ; ;Saves the current process on process:queue and runs the next process ;from process:queue. The value returned is unspecified. ; ; (kill-process!) procedure ; ;Kills the current process and runs the next process from ;process:queue. If there are no more processes on process:queue ;(quit) is called. ; ;;;;---------------------------------------------------------------------- (require 'full-continuation) (require 'queue) (define (add-process! thunk1) (cond ((procedure? thunk1) (defer-ints) (enqueue! process:queue thunk1) (allow-ints)) (else (error "add-process!: wrong type argument " thunk1)))) (define (process:schedule!) (defer-ints) (cond ((queue-empty? process:queue) (allow-ints) 'still-running) (else (call-with-current-continuation (lambda (cont) (enqueue! process:queue cont) (let ((proc (dequeue! process:queue))) (allow-ints) (proc 'run)) (kill-process!)))))) (define (kill-process!) (defer-ints) (cond ((queue-empty? process:queue) (allow-ints) (quit)) (else (let ((proc (dequeue! process:queue))) (allow-ints) (proc 'run)) (kill-process!)))) (define ints-disabled #f) (define alarm-deferred #f) (define (defer-ints) (set! ints-disabled #t)) (define (allow-ints) (set! ints-disabled #f) (cond (alarm-deferred (set! alarm-deferred #f) (alarm-interrupt)))) ;;; Make THE process queue. (define process:queue (make-queue)) (define (alarm-interrupt) (alarm 1) (if ints-disabled (set! alarm-deferred #t) (process:schedule!))) @EOF chmod 666 process.scm echo x - priorque.scm cat >priorque.scm <<'@EOF' ;;;; "priorque.scm" priority queues for Scheme. ;;; Copyright (C) 1992 Aubrey Jaffer. ; (make-heap pred s (vector-length ra)) (let ((nra (make-vector (+ s (quotient s 2))))) (do ((i (+ -1 (vector-length ra)) (+ -1 i))) ((negative? i) (am a nra)) (vector-set! nra i (vector-ref ra i))))) (sm a s))))) (define (heap-parent i) (quotient i 2)) (define (heap-left i) (* 2 i)) (define (heap-right i) (+ 1 (* 2 i))) (define (heapify a i) (define l (heap-left i)) (define r (heap-right i)) (define largest (if (and (<= l (heap-size a)) ((heap i 1) ((heap?)) (heap-insert! heap #\A) (heap-insert! heap #\Z) (heap-insert! heap #\G) (heap-insert! heap #\B) (heap-insert! heap #\G) (heap-insert! heap #\Q) (heap-insert! heap #\S) (heap-insert! heap #\R) (print (heap-extract-max heap)) (print (heap-extract-max heap)) (print (heap-extract-max heap)) (print (heap-extract-max heap)) (print (heap-extract-max heap)) (print (heap-extract-max heap)) (print (heap-extract-max heap)) (print (heap-extract-max heap)) ) @EOF chmod 666 priorque.scm echo x - hash.scm cat >hash.scm <<'@EOF' ; "hash.scm", hashing functions for Scheme. ; Copyright (c) 1992, Aubrey Jaffer ;This hashing functions are for use in quickly classifying objects. ;Hash tables use these functions. ; (hashq obj k) procedure ; (hashv obj k) procedure ; (hash obj k) procedure ;Returns an exact non-negative integer less than k. For each ;non-negative integer less than k there are arguments obj for which ;the hashing functions applied to obj and k returns that integer. ;For HASHQ (EQ? obj1 obj2) implies (= (HASHQ obj1 k) (HASHQ obj2)). ;For HASHV (EQV? obj1 obj2) implies (= (HASHV obj1 k) (HASHV obj2)). ;For HASH (EQUAL? obj1 obj2) implies (= (HASH obj1 k) (HASH obj2)). ;HASH, HASHV, and HASHQ return in time bounded by a constant. Notice ;that HASH implies HASHV implies HASHQ. ; (predicate->hash pred) procedure ;Returns a hash function (like HASHQ, HASHV, or HASH) corresponding to ;the equality predicate pred. Pred should be EQ?, EQV?, EQUAL?, =, ;CHAR=?, CHAR-CI=?, STRING=?, or STRING-CI=?. (define (hash:hash-char char n) (modulo (char->integer char) n)) (define (hash:hash-char-ci char n) (modulo (char->integer (char-downcase char)) n)) (define (hash:hash-symbol sym n) (hash:hash-string (symbol->string sym) n)) ;;; I am trying to be careful about overflow and underflow here. (define (hash:hash-number num n) (if (exact? num) (modulo (cond ((integer? num) num) ((rational? num) (- (abs (numerator num)) (denominator num)))) n) (let ((anum (abs (if (real? num) num (abs (- (real-part num) (imag-part num))))))) (inexact->exact (floor (if (< anum n) anum (* n (/ n anum)))))))) (define (hash:hash-string str n) (let ((len (string-length str))) (if (> len 5) (let loop ((h 0) (i 5)) (if (positive? i) (loop (modulo (+ (* h 256) (char->integer (string-ref str (modulo h len)))) n) (- i 1)) h)) (let loop ((h (modulo 264 n)) (i (- len 1))) (if (>= i 0) (loop (modulo (+ (* h 256) (char->integer (string-ref str i))) n) (- i 1)) h))))) (define (hash:hash-string-ci str n) (let ((len (string-length str))) (if (> len 5) (let loop ((h 0) (i 5)) (if (positive? i) (loop (modulo (+ (* h 256) (char->integer (char-downcase (string-ref str (modulo h len))))) n) (- i 1)) h)) (let loop ((h (modulo 264 n)) (i (- len 1))) (if (>= i 0) (loop (modulo (+ (* h 256) (char->integer (char-downcase (string-ref str i)))) n) (- i 1)) h))))) (define (hash:hash obj n) (let hs ((d 10) (obj obj)) (cond ((number? obj) (hash:hash-number obj n)) ((char? obj) (modulo (char->integer obj) n)) ((symbol? obj) (hash:hash-symbol obj n)) ((string? obj) (hash:hash-string obj n)) ((vector? obj) (let ((len (vector-length obj))) (if (> len 5) (let lp ((h 1) (i (quotient d 2))) (if (positive? i) (lp (modulo (+ (* h 256) (hs 2 (vector-ref obj (modulo h len)))) n) (- i 1)) h)) (let loop ((h (- n 1)) (i (- len 1))) (if (>= i 0) (loop (modulo (+ (* h 256) (hs (quotient d len) (vector-ref obj i))) n) (- i 1)) h))))) ((pair? obj) (if (positive? d) (modulo (+ (hs (quotient d 2) (car obj)) (hs (quotient d 2) (cdr obj))) n) 1)) (else (modulo (cond ((null? obj) 256) ((boolean? obj) (if obj 257 258)) ((eof-object? obj) 259) ((input-port? obj) 260) ((output-port? obj) 261) ((procedure? obj) 262) ((and (provided? 'RECORD) (record? obj)) (let* ((rtd (record-type-descriptor obj)) (fns (record-type-field-names rtd)) (len (length fns))) (if (> len 5) (let lp ((h (modulo 266 n)) (i (quotient d 2))) (if (positive? i) (lp (modulo (+ (* h 256) (hs 2 ((record-accessor rtd (list-ref fns (modulo h len))) obj))) n) (- i 1)) h)) (let loop ((h (- n 1)) (i (- len 1))) (if (>= i 0) (loop (modulo (+ (* h 256) (hs (quotient d len) ((record-accessor rtd (list-ref fns (modulo h len))) obj))) n) (- i 1)) h))))) (else 263)) n))))) (define hash hash:hash) (define hashv hash:hash) ;;; Object-hash is somewhat expensive on copying GC systems (like ;;; PC-Scheme and MITScheme). We use it only on strings, pairs, ;;; vectors, and records. This also allows us to use it for both ;;; hashq and hashv. (if (provided? 'object-hash) (set! hashv (if (provided? 'record) (lambda (obj k) (if (or (string? obj) (pair? obj) (vector? obj) (record? obj)) (modulo (object-hash obj) k) (hash:hash obj k))) (lambda (obj k) (if (or (string? obj) (pair? obj) (vector? obj)) (modulo (object-hash obj) k) (hash:hash obj k)))))) (define hashq hashv) (define (predicate->hash pred) (cond ((eq? pred eq?) hashq) ((eq? pred eqv?) hashv) ((eq? pred equal?) hash) ((eq? pred =) hash:hash-number) ((eq? pred char=?) hash:hash-char) ((eq? pred char-ci=?) hash:hash-char-ci) ((eq? pred string=?) hash:hash-string) ((eq? pred string-ci=?) hash:hash-string-ci) (else (slib:error "unknown predicate for hash" pred)))) @EOF chmod 666 hash.scm echo x - hashtab.scm cat >hashtab.scm <<'@EOF' ; "hashtab.scm", hash tables for Scheme. ; Copyright (c) 1992, Aubrey Jaffer ;A hash table is a vector of association lists. ; (make-hash-table k) procedure ;Returns a vector of empty (association) lists. ;Hash table functions provide utilities for an associative database. ;These functions take an equality predicate, pred, as an argument. ;Pred should be EQ?, EQV?, EQUAL?, =, CHAR=?, CHAR-CI=?, STRING=?, or ;STRING-CI=?. ; (predicate->hash-asso pred) procedure ;Returns an hash association function of 2 arguments, key and hashtab, ;corresponding to pred. The returned function returns a key-value ;pair whose key is pred equal to its first argument or #f if no key in ;hashtab is pred equal to the first argument. ; (hash-inquirer pred) procedure ;Returns a procedure of 2 arguments, hashtab and key, which returns ;the value associated with key in hashtab or #f if key does not appear ;in hash. ; (hash-associator pred) procedure ;Returns a procedure of 3 arguments, hashtab, key, and value, which ;modifies hashtab so that key and value associated. Any previous ;value associated with key will be lost. ; (hash-remover pred) procedure ;Returns a procedure of 2 arguments, hashtab and key, which modifies ;hashtab so that the association whose key is key removed. (require 'hash) (require 'alist) (define (make-hash-table k) (make-vector k '())) (define (predicate->hash-asso pred) (let ((hashfun (predicate->hash pred)) (asso (predicate->asso pred))) (lambda (key hashtab) (asso key (vector-ref hashtab (hashfun key (vector-length hashtab))))))) (define (hash-inquirer pred) (let ((hashfun (predicate->hash pred)) (ainq (alist-inquirer pred))) (lambda (hashtab key) (ainq (vector-ref hashtab (hashfun key (vector-length hashtab))) key)))) (define (hash-associator pred) (let ((hashfun (predicate->hash pred)) (asso (alist-associator pred))) (lambda (hashtab key val) (let* ((num (hashfun key (vector-length hashtab)))) (vector-set! hashtab num (asso (vector-ref hashtab num) key val)))))) (define (hash-remover pred) (let ((hashfun (predicate->hash pred)) (arem (alist-remover pred))) (lambda (hashtab key) (let* ((num (hashfun key (vector-length hashtab)))) (vector-set! hashtab num (arem (vector-ref hashtab num) key)))))) @EOF chmod 666 hashtab.scm echo x - alist.scm cat >alist.scm <<'@EOF' ;;;"alist.scm", alist functions for Scheme. ;;;Copyright (c) 1992, Aubrey Jaffer ;Alist functions provide utilities for treating a list of key-value ;pairs as an associative database. These functions take an equality ;predicate, pred, as an argument. This predicate should be ;repeatable, symmetric, and transitive. ;Alist functions can be used with a secondary index method like hash ;tables for improved performance. ; (predicate->asso pred) procedure ;Returns an association function (like ASSQ, ASSV, or ASSOC) ;corresponding to pred. The returned function returns a key-value ;pair whose key is pred equal to its first argument or #f if no key in ;the alist is pred equal to the first argument. ; (alist-inquirer pred) procedure ;Returns a procedure of 2 arguments, alist and key, which returns the ;value associated with key in alist or #f if key does not appear in ;alist. ; (alist-associator pred) procedure ;Returns a procedure of 3 arguments, alist, key, and value, which ;returns an alist with key and value associated. Any previous value ;associated with key will be lost. This returned procedure may or may ;not have side effects on its alist argument. An example of correct ;usage is: ;(define put (alist-associator string-ci=?)) ;(define alist '()) ;(set! alist (put alist "Foo" 9)) ; (alist-remover pred) procedure ;Returns a procedure of 2 arguments, alist and key, which returns an ;alist with an association whose key is key removed. This returned ;procedure may or may not have side effects on its alist argument. An ;example of correct usage is: ;(define rem (alist-remover string-ci=?)) ;(set! alist (rem alist "fOO")) (define (predicate->asso pred) (cond ((eq? eq? pred) assq) ((eq? eqv? pred) assv) ((eq? equal? pred) assoc) (else (lambda (key alist) (let l ((al alist)) (cond ((null? al) #f) ((pred key (caar al)) (car al)) (else (l (cdr al))))))))) (define (alist-inquirer pred) (let ((assofun (predicate->asso pred))) (lambda (alist key) (let ((pair (assofun key alist))) (and pair (cdr pair)))))) (define (alist-associator pred) (let ((assofun (predicate->asso pred))) (lambda (alist key val) (let* ((pair (assofun key alist))) (cond (pair (set-cdr! pair val) alist) (else (cons (cons key val) alist))))))) (define (alist-remover pred) (lambda (alist key) (cond ((null? alist) alist) ((pred key (caar alist)) (cdr alist)) ((null? (cdr alist)) alist) ((pred key (caadr alist)) (set-cdr! alist (cddr alist)) alist) (else (let l ((al (cdr alist))) (cond ((null? (cdr al)) alist) ((pred key (caadr al)) (set-cdr! al (cddr al)) alist) (else (l (cdr al))))))))) @EOF chmod 666 alist.scm echo x - test.scm cat >test.scm <<'@EOF' ;;;; "test.scm", routines for testing. ;;; Copyright (C) 1991 Aubrey Jaffer. (define cur-section '()) (define errs '()) (define SECTION (lambda args (display "SECTION") (write args) (newline) (set! cur-section args) #t)) (define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) (define test (lambda (expect fun . args) (write (cons fun args)) (display " ==> ") ((lambda (res) (write res) (newline) (cond ((not (equal? expect res)) (record-error (list res expect (cons fun args))) (display " BUT EXPECTED ") (write expect) (newline) #f) (else #t))) (if (procedure? fun) (apply fun args) (car args))))) (define (report-errs) (newline) (if (null? errs) (display "Passed all tests") (begin (display "errors were:") (newline) (display "(SECTION (got expected (call)))") (newline) (for-each (lambda (l) (write l) (newline)) errs))) (newline)) @EOF chmod 666 test.scm echo x - plottest.scm cat >plottest.scm <<'@EOF' (require 'charplot) (require 'random) (define strophoid (let ((l '())) (do ((x -1.0 (+ x .05))) ((> x 4.0)) (let* ((a (/ (- 2 x) (+ 2 x)))) (if (>= a 0.0) (let* ((y (* x (sqrt a)))) (set! l (cons (cons x y) l)) (set! l (cons (cons x (- y)) l)))))) l)) (plot! strophoid "x" "y") (newline) (define unif (let* ((l 6) (v (make-vector l))) (do ((i (- l 1) (- i 1))) ((negative? i)) (vector-set! v i (cons i 0))) (do ((i 24 (- i 1)) (r (random l) (random l))) ((zero? i) (vector->list v)) (set-cdr! (vector-ref v r) (+ 1 (cdr (vector-ref v r))))))) (plot! unif "n" "occur") @EOF chmod 666 plottest.scm echo x - formatst.scm cat >formatst.scm <<'@EOF' ;; ;; SLIB FORMAT Version 2.1 conformance test ;; ;; Test run: (load "format.scm") (load "formatst.scm") ;; ; ; Failure reports for various scheme interpreters: ; ; scm3c11: ; none. ; Elk 1.5: ; none. ; scheme->C 01nov91: ; symbols are generally converted to uppercase strings. ; number to string conversions have always a number prefix. ; MIT C-Scheme 7.1: ; the empty list is a boolean and consequently represented as `#f'. ; UMB Scheme 2.5: ; a `\' is missing in slashified 8bit characters. ; T 3.1: ; does not run due to missing R4RS essential procedures (e.g. string). ; (define fails 0) (define total 0) (define show-test #f) ; set this to #t if you like (define (test format-args out-str) (set! total (+ total 1)) (if (not show-test) (if (zero? (modulo total 10)) (begin (display total) (display ",")))) (let ((format-out (apply format `(#f ,@format-args)))) (if (string=? out-str format-out) (if show-test (begin (display "Verified ") (write format-args) (newline))) (begin (set! fails (+ fails 1)) (if (not show-test) (newline)) (display "Failed ") (write format-args) (display " returns ") (write format-out) (display " instead of ") (write out-str) (newline))))) ; any object test (test '("abc") "abc") (test '("~a" 10) "10") (test '("~a" -1.2) "-1.2") (test '("~a" a) "a") (test '("~a" #t) "#t") (test '("~a" #f) "#f") (test '("~a" "abc") "abc") (test '("~a" #(1 2 3)) "#(1 2 3)") (test '("~a" ()) "()") (test '("~a" (a)) "(a)") (test '("~a" (a b)) "(a b)") (test '("~a" (a (b c) d)) "(a (b c) d)") (test '("~a" (a . b)) "(a . b)") (test '("~a" (a (b c . d))) "(a (b . (c . d)))") ; this is ugly (test `("~a" ,display) "#[procedure]") (test `("~a" ,(current-input-port)) "#[input-port]") (test `("~a" ,(current-output-port)) "#[output-port]") ; # argument test (test '("~a ~a" 10 20) "10 20") (test '("~a abc ~a def" 10 20) "10 abc 20 def") ; numerical test (test '("~d" 100) "100") (test '("~x" 100) "64") (test '("~o" 100) "144") (test '("~b" 100) "1100100") (test '("~@d" 100) "#d100") (test '("~@x" 100) "#x64") (test '("~@o" 100) "#o144") (test '("~@b" 100) "#b1100100") (test '("~10d" 100) " 100") (test '("~:d" 12345678) "12,345,678") (test '("~-6d" 12345678) "<45678") (test '("~10,'*d" 100) "*******100") (test '("~10,,'|:d" 12345678) "12|345|678") (test '("~10,,,2:d" 12345678) "12,34,56,78") (test '("~14,'*,'|,4:@d" 12345678) "***#d1234|5678") (test '("~10r" 100) "100") (test '("~2r" 100) "1100100") (test '("~8r" 100) "144") (test '("~16r" 100) "64") (test '("~16,10,'*r" 100) "********64") ; character test (test '("~c" #\a) "a") (test '("~@c" #\a) "#\\a") (test `("~@c" ,(integer->char 32)) "#\\space") (test `("~@c" ,(integer->char 0)) "#\\nul") (test `("~@c" ,(integer->char 27)) "#\\esc") (test `("~@c" ,(integer->char 127)) "#\\del") (test `("~@c" ,(integer->char 128)) "#\\200") (test '("~65c") "A") (test '("~7@c") "#\\bel") ; plural test (test '("test~p" 1) "test") (test '("test~p" 2) "tests") (test '("test~p" 0) "tests") (test '("tr~@p" 1) "try") (test '("tr~@p" 2) "tries") (test '("tr~@p" 0) "tries") (test '("~a test~:p" 10) "10 tests") (test '("~a test~:p" 1) "1 test") ; tilde test (test '("~~~~") "~~") (test '("~3~") "~~~") ; whitespace character test (test '("~%") " ") (test '("~3%") " ") (test '("~|") " ") (test '("~_~_~_") " ") (test '("~3_") " ") (test '("~t") " ") (test '("~3t") " ") ; indirection test (test '("~a ~? ~a" 10 "~a ~a" (20 30) 40) "10 20 30 40") (test '("~a ~@? ~a" 10 "~a ~a" 20 30 40) "10 20 30 40") ; minimum field test (test '("~10a" "abc") "abc ") (test '("~10@a" "abc") " abc") (test '("~10a" "0123456789abc") "0123456789abc") (test '("~10@a" "0123456789abc") "0123456789abc") ; maximum field test (test '("~-10a" "abc") "abc ") (test '("~-10a" "0123456789abc") "012345678>") (test '("~-10@a" "0123456789abc") "<456789abc") (test '("~-10a" (a (b c (d e) f) g)) "(a (b c (>") ; pad character field test (test '("~10,,,'*a" "abc") "abc*******") (test '("~10,,,'Xa" "abc") "abcXXXXXXX") (test '("~10,,,42a" "abc") "abc*******") (test '("~10,,,'*@a" "abc") "*******abc") (test '("~-10,,,'*a" "0123456789abc") "012345678>") (test '("~10,,3,'*a" "abc") "abc*******") (test '("~10,,3,'*a" "0123456789abc") "0123456789abc***") ; min. padchar length (test '("~10,,3,'*@a" "0123456789abc") "***0123456789abc") (test '("~-10,,3,'*a" "0123456789abc") "012345678>") (test '("~-10,,3,'*@a" "0123456789abc") "<456789abc") (test '("~10,99,3,'*a" "abc") "abc*******") ; 2nd parameter has no effect yet ; slashify test (test '("~s" "abc") "\"abc\"") (test '("~s" "abc \\ abc") "\"abc \\\\ abc\"") (test '("~a" "abc \\ abc") "abc \\ abc") (test '("~s" "abc \" abc") "\"abc \\\" abc\"") (test '("~a" "abc \" abc") "abc \" abc") (test '("~s" #\space) "#\\space") (test '("~s" #\newline) "#\\newline") (test '("~s" #\tab) "#\\ht") (test '("~s" #\a) "#\\a") (test '("~a" (a "b" c)) "(a \"b\" c)") ; continuation line test (test '("abc~ 123") "abc123") (test '("abc~ 123") "abc123") (test '("abc~ ") "abc") (test '("abc~: def") "abc def") (test '("abc~@ def") "abc def") ; flush output (can't test it here really) (test '("abc ~! xyz") "abc xyz") ; string case conversion (test '("~a ~(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc hello world xyz") (test '("~a ~:(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc Hello World xyz") (test '("~a ~@(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc Hello world xyz") (test '("~a ~:@(~a~) ~a" "abc" "hello world" "xyz") "abc HELLO WORLD xyz") (test '("~:@(~a~)" (a b c)) "(A B C)") (test '("~:@(~x~)" 255) "FF") (test '("~:@(~p~)" 2) "S") (test `("~:@(~a~)" ,display) "#[PROCEDURE]") (test '("~:(~a ~a ~a~) ~a" "abc" "xyz" "123" "world") "Abc Xyz 123 world") ; variable parameter (test '("~va" 10 "abc") "abc ") (test '("~v,,,va" 10 42 "abc") "abc*******") ; number of remaining arguments as parameter (test '("~#,,,'*@a ~a ~a ~a" 1 1 1 1) "***1 1 1 1") ; argument jumping (test '("~a ~* ~a" 10 20 30) "10 30") (test '("~a ~2* ~a" 10 20 30 40) "10 40") (test '("~a ~:* ~a" 10) "10 10") (test '("~a ~a ~2:* ~a ~a" 10 20) "10 20 10 20") (test '("~a ~a ~@* ~a ~a" 10 20) "10 20 10 20") (test '("~a ~a ~4@* ~a ~a" 10 20 30 40 50 60) "10 20 50 60") ; conditionals (test '("~[abc~;xyz~]" 0) "abc") (test '("~[abc~;xyz~]" 1) "xyz") (test '("~[abc~;xyz~:;456~]" 99) "456") (test '("~0[abc~;xyz~:;456~]") "abc") (test '("~1[abc~;xyz~:;456~] ~a" 100) "xyz 100") (test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]") "no arg") (test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10) "10") (test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10 20) "10 and 20") (test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10 20 30) "10, 20 and 30") (test '("~:[hello~;world~] ~a" #t 10) "world 10") (test '("~:[hello~;world~] ~a" #f 10) "hello 10") (test '("~@[~a tests~]" #f) "") (test '("~@[~a tests~]" 10) "10 tests") (test '("~@[~a test~:p~] ~a" 10 done) "10 tests done") (test '("~@[~a test~:p~] ~a" 1 done) "1 test done") (test '("~@[~a test~:p~] ~a" 0 done) "0 tests done") (test '("~@[~a test~:p~] ~a" #f done) " done") (test '("~@[ level = ~d~]~@[ length = ~d~]" #f 5) " length = 5") (test '("~[abc~;~[4~;5~;6~]~;xyz~]" 0) "abc") ; nested conditionals (irrghh) (test '("~[abc~;~[4~;5~;6~]~;xyz~]" 2) "xyz") (test '("~[abc~;~[4~;5~;6~]~;xyz~]" 1 2) "6") ; iteration (test '("~{ ~a ~}" (a b c)) " a b c ") (test '("~{ ~a ~}" ()) "") (test '("~{ ~a ~5,,,'*a~}" (a b c d)) " a b**** c d****") (test '("~{ ~a,~a ~}" (a 1 b 2 c 3)) " a,1 b,2 c,3 ") (test '("~2{ ~a,~a ~}" (a 1 b 2 c 3)) " a,1 b,2 ") (test '("~3{~a ~} ~a" (a b c d e) 100) "a b c 100") (test '("~0{~a ~} ~a" (a b c d e) 100) " 100") (test '("~:{ ~a,~a ~}" ((a b) (c d e f) (g h))) " a,b c,d g,h ") (test '("~2:{ ~a,~a ~}" ((a b) (c d e f) (g h))) " a,b c,d ") (test '("~@{ ~a,~a ~}" a 1 b 2 c 3) " a,1 b,2 c,3 ") (test '("~2@{ ~a,~a ~} <~a|~a>" a 1 b 2 c 3) " a,1 b,2 ") (test '("~:@{ ~a,~a ~}" (a 1) (b 2) (c 3)) " a,1 b,2 c,3 ") (test '("~2:@{ ~a,~a ~} ~a" (a 1) (b 2) (c 3)) " a,1 b,2 (c 3)") (test '("~{~}" "<~a,~a>" (a 1 b 2 c 3)) "") (test '("~{ ~a ~{<~a>~}~} ~a" (a (1 2) b (3 4)) 10) " a <1><2> b <3><4> 10") ; up and out (test '("abc ~^ xyz") "abc ") (test '("~@(abc ~^ xyz~) ~a" 10) "ABC xyz 10") (test '("done. ~^ ~d warning~:p. ~^ ~d error~:p.") "done. ") (test '("done. ~^ ~d warning~:p. ~^ ~d error~:p." 10) "done. 10 warnings. ") (test '("done. ~^ ~d warning~:p. ~^ ~d error~:p." 10 1) "done. 10 warnings. 1 error.") (test '("~{ ~a ~^<~a>~} ~a" (a b c d e f) 10) " a c e 10") (test '("~{ ~a ~^<~a>~} ~a" (a b c d e) 10) " a c e 10") (test '("abc~0^ xyz") "abc") (test '("abc~9^ xyz") "abc xyz") (test '("abc~7,4^ xyz") "abc xyz") (test '("abc~7,7^ xyz") "abc") (test '("abc~3,7,9^ xyz") "abc") (test '("abc~8,7,9^ xyz") "abc xyz") (test '("abc~3,7,5^ xyz") "abc xyz") ; complexity tests (oh my god, I hardly understand them myself (see CL std)) (define fmt "Items:~#[ none~; ~a~; ~a and ~a~:;~@{~#[~; and~] ~a~^,~}~].") (test `(,fmt ) "Items: none.") (test `(,fmt foo) "Items: foo.") (test `(,fmt foo bar) "Items: foo and bar.") (test `(,fmt foo bar baz) "Items: foo, bar, and baz.") (test `(,fmt foo bar baz zok) "Items: foo, bar, baz, and zok.") (if (not show-test) (display "done.")) (format #t "~%~a Test~:p completed. (~a failure~:p)~2%" total fails) @EOF chmod 666 formatst.scm echo x - macrotst.scm cat >macrotst.scm <<'@EOF' ;;;; macrotst.scm Test for R4RS Macros ;;; From Revised^4 Report on the Algorithmic Language Scheme ;;; William Clinger and Jonathon Rees (Editors) ;;; To run this code type ;;; (require 'macro) ;;; (macro:load "macrotst.scm") (write "this code should print now, outer, and 7") (newline) (write (let-syntax ((when (syntax-rules () ((when test stmt1 stmt2 ...) (if test (begin stmt1 stmt2 ...)))))) (let ((if #t)) (when if (set! if 'now)) if))) (newline) ;;; ==> now (write (let ((x 'outer)) (let-syntax ((m (syntax-rules () ((m) x)))) (let ((x 'inner)) (m))))) (newline) ;;; ==> outer (write (letrec-syntax ((or (syntax-rules () ((or) #f) ((or e) e) ((or e1 e2 ...) (let ((temp e1)) (if temp temp (or e2 ...))))))) (let ((x #f) (y 7) (temp 8) (let odd?) (if even?)) (or x (let temp) (if y) y)))) (newline) ;;; ==> 7 @EOF chmod 666 macrotst.scm echo x - scmactst.scm cat >scmactst.scm <<'@EOF' ;;;;From "sc-macro.doc", A Syntactic Closures Macro Facility by Chris Hanson (require 'test) (require 'sc-macro) (macro:expand '(define-syntax push (syntax-rules () ((push item list) (set! list (cons item list)))))) (test '(set! foo (cons bar foo)) 'push (macro:expand '(push bar foo))) (macro:expand '(define-syntax push1 (transformer (lambda (exp env) (let ((item (make-syntactic-closure env '() (cadr exp))) (list (make-syntactic-closure env '() (caddr exp)))) `(set! ,list (cons ,item ,list))))))) (test '(set! foo (cons bar foo)) 'push1 (macro:expand '(push1 bar foo))) (macro:expand '(define-syntax loop (transformer (lambda (exp env) (let ((body (cdr exp))) `(call-with-current-continuation (lambda (exit) (let f () ,@(map (lambda (exp) (make-syntactic-closure env '(exit) exp)) body) (f))))))))) (macro:expand '(define-syntax let1 (transformer (lambda (exp env) (let ((id (cadr exp)) (init (caddr exp)) (exp (cadddr exp))) `((lambda (,id) ,(make-syntactic-closure env (list id) exp)) ,(make-syntactic-closure env '() init))))))) (test 93 'let1 (macro:eval '(let1 a 90 (+ a 3)))) (macro:expand '(define-syntax loop-until (syntax-rules () ((loop-until id init test return step) (letrec ((loop (lambda (id) (if test return (loop step))))) (loop init)))))) (test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33))))) (loop 3))) 'loop (macro:expand '(loop-until foo 3 #t 12 33))) (macro:expand '(define-syntax loop-until1 (transformer (lambda (exp env) (let ((id (cadr exp)) (init (caddr exp)) (test (cadddr exp)) (return (cadddr (cdr exp))) (step (cadddr (cddr exp))) (close (lambda (exp free) (make-syntactic-closure env free exp)))) `(letrec ((loop ,(capture-syntactic-environment (lambda (env) `(lambda (,id) (,(make-syntactic-closure env '() `if) ,(close test (list id)) ,(close return (list id)) (,(make-syntactic-closure env '() `loop) ,(close step (list id))))))))) (loop ,(close init '())))))))) (test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33))))) (loop 3))) 'loop1 (macro:expand '(loop-until1 foo 3 #t 12 33))) (test '#t 'identifier (identifier? 'a)) ;;; this needs to setup ENV. ;;;(test '#t 'identifier ;;; (identifier? (macro:expand (make-syntactic-closure env '() 'a)))) (test #f 'identifier (identifier? "a")) (test #f 'identifier (identifier? #\a)) (test #f 'identifier (identifier? 97)) (test #f 'identifier (identifier? #f)) (test #f 'identifier (identifier? '(a))) (test #f 'identifier (identifier? '#(a))) (test '(#t #f) 'syntax (macro:eval '(let-syntax ((foo (transformer (lambda (form env) (capture-syntactic-environment (lambda (transformer-env) (identifier=? transformer-env 'x env 'x))))))) (list (foo) (let ((x 3)) (foo)))))) (test '(#f #t) 'syntax (macro:eval '(let-syntax ((bar foo)) (let-syntax ((foo (transformer (lambda (form env) (capture-syntactic-environment (lambda (transformer-env) (identifier=? transformer-env 'foo env (cadr form)))))))) (list (foo foo) (foo bar)))))) (report-errs) @EOF chmod 666 scmactst.scm echo x - oop.scm cat >oop.scm <<'@EOF' ;; FILE "oop.scm" ;; IMPLEMENTS Yet Another Scheme Object System ;; AUTHOR Kenneth Dickey ;; DATE 1992 March 1 ;; LAST UPDATED 1992 March 4 ;; SEE ALSO "oop.doc" ;; REQUIRES R4RS Syntax System ;; INSTANCES ; (define-predicate instance?) ; (define (make-instance dispatcher) ; (object ; ((instance? self) #t) ; ((dispatcher self) dispatcher) ; ) ) ; If you can't make this native, you can redefine the WRITE and ; DISPLAY routines to use PRINT (see "oop.doc") to hide the ; (instance . #[proc]) output. (define make-instance 'bogus) ;; defined below (define instance? 'bogus) (define instance-dispatcher 'bogus) (let ( (instance-tag (list 'instance)) ) ;; Make a unique tag. Nothing else ;; is EQ? to this tag. (set! MAKE-INSTANCE (lambda (dispatcher) (cons instance-tag dispatcher))) (set! INSTANCE? (lambda (obj) (and (pair? obj) (eq? (car obj) instance-tag)))) (set! INSTANCE-DISPATCHER cdr) ) ;; DEFINE-OPERATION (define-syntax DEFINE-OPERATION (syntax-rules () ((define-operation ( ...) ...) ;;=> (define (letrec ( (self (lambda ( ...) (cond ((and (instance? ) ((instance-dispatcher ) self)) => (lambda (method) (method ...)) ) (else ...) ) ) ) ) self) )) ((define-operation ( ...) ) ;; no body ;;=> (define (letrec ( (self (lambda ( ...) (cond ((and (instance? ) ((instance-dispatcher ) self)) => (lambda (method) (method ...)) ) (else (error "Operation not handled" ' )) ) ) ) ) self) )) ) ) ;; DEFINE-PREDICATE (define-syntax DEFINE-PREDICATE (syntax-rules () ((define-predicate ) ;;=> (define-operation ( obj) #f) ) ) ) ;; OBJECT (define-syntax OBJECT (syntax-rules () ((object (( ...) ...) ...) ;;=> (make-instance (lambda (op) (cond ((assq op (list (cons (lambda ( ...) ...)) ... ) ) => cdr ) (else #f) ) )) ) ) ) ;; OBJECT with MULTIPLE INHERITANCE {First Found Rule} (define-syntax OBJECT-WITH-ANCESTORS (syntax-rules () ((object-with-ancestors ( ( ) ... ) ...) ;;=> (let ( ( ) ... ) (let ( (child (object ...)) ) (make-instance (lambda (op) (or ((instance-dispatcher child) op) ((instance-dispatcher ) op) ... ) ) ) ))) ) ) ;; OPERATE-AS {a.k.a. send-to-super} ; used in operations/methods (define-syntax OPERATE-AS (syntax-rules () ((operate-as ...) ;;=> (((instance-dispatcher ) ) ...) )) ) ;; --- E O F --- @EOF chmod 666 oop.scm rm -f /tmp/unpack$$ exit 0