diff --git a/Makefile b/Makefile index 97504701..83ed4096 100644 --- a/Makefile +++ b/Makefile @@ -9,7 +9,7 @@ SRC = system syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ inquir acount gz sys decsys ecc alan sail kcc kcc_sy c games archy dcp \ spcwar rwg libmax rat z emaxim rz maxtul aljabr cffk das ell ellen \ jim jm jpg macrak maxdoc maxsrc mrg munfas paulw reh rlb rlb% share \ - tensor transl wgd zz graphs lmlib pratt nschem + tensor transl wgd zz graphs lmlib pratt nschem scheme DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc chprog BIN = sys2 emacs _teco_ lisp liblsp alan inquir sail comlap c decsys moon graphs diff --git a/build/build.tcl b/build/build.tcl index 1db0acd2..a43b9321 100644 --- a/build/build.tcl +++ b/build/build.tcl @@ -2022,6 +2022,17 @@ respond "*" ":link lisp;defns mid,l;defns >\r" respond "*" ":midas liblsp;_libdoc;fft\r" respond "*" ":midas liblsp;_libdoc;phase\r" +# Old? Scheme interpreter +respond "*" "complr\013" +respond "_" "scheme;_nschsy\r" +respond "_" "\032" +type ":kill\r" +respond "*" ":lisp\r" +respond "Alloc?" "n" +respond "*" {(load "scheme; nschsy fasl")} +respond "\n" "(schemedump)" +respond "==>" "(quit)" + # New Scheme interpreter respond "*" "complr\013" respond "_" "nschem;scheme interp_schint lsp\r" diff --git a/doc/scheme/docume.89 b/doc/scheme/docume.89 new file mode 100755 index 00000000..97c5b872 --- /dev/null +++ b/doc/scheme/docume.89 @@ -0,0 +1,2194 @@ +.xgp +.vsp 11 +.squish +.ltrspc 0 +.c << text font >> +.font 0 25fr1 +.c << SCHEME font >> +.font 1 22fg +.c << heading fonts >> +.font 2 30vrb +.font 3 66vr +.font 4 gls;foo1 +.quote  +.dummy _ +.twinch 6.25 +.tlinch 9 +.sidm 53 +.c << want to flush losing multiple cr's >> +.crcomp +.c << want to make leading spaces on line small >> +.c << want to have at least 3 lines of a section on a page >> +.sblock 5 +.spw 16 +.adjust +.center +2MASSACHUSETTS INSTITUTE OF TECHNOLOGY +.CENTER +ARTIFICIAL INTELLIGENCE LABORATORY +.sp +.spread +/0AI Memo No. 452//January 1978 +.sp +.center +2THE__REVISED__REPORT__ON +.sp 2 +.center +3SCHEME +.sp +.center +2A__DIALECT__OF__LISP +.sp +.center +0by +.sp +.center +Guy Lewis Steele Jr. * and Gerald Jay Sussman +.sp 2 +0Abstract: +.br + SCHEME is a dialect of LISP. +It is an expression-oriented, applicative order, +interpreter-based language which allows one to +manipulate programs as data. +It differs from most current dialects of LISP +in that it closes all lambda-expressions +in the environment of their definition or declaration, +rather than in the execution environment. +This has the consequence that variables are normally lexically scoped, +as in ALGOL. However, in contrast with ALGOL, +SCHEME treats procedures as a first-class data type. +They can be the values of variables, the returned values of +procedures, and components of data structures. +Another difference from LISP is that SCHEME is +implemented in such a way that tail-recursions execute +without net growth of the interpreter stack. +The effect of this is that a procedure call behaves like a GOTO, +and thus procedure calls can be used to implement iterations, +as in PLASMA. + Here we give a complete "user manual" for the SCHEME +language. Some features described here were not documented in the original +report on SCHEME (for instance particular macros). +Other features have been added, changed, or deleted +as our understanding of certain language issues evolved. +Annotations to the manual describe the motivations +for these changes. + + +.sp +.in 4 +.un 4 +Keywords:__LISP, SCHEME, LISP-like languages, +lambda-calculus, environments, lexical scoping, dynamic scoping, +fluid variables, control structures, macros, extensible syntax, +extensible languages +.in 0 + +.sp +This report describes research done at the Artificial Intelligence +Laboratory of the Massachusetts Institute of Technology. +Support for the laboratory's artificial intelligence research +is provided in part by the Advanced Research Projects Agency +of the Department of Defense under Office of Naval Research contract N00014-75-C-0643. +.sp +*__NSF Fellow + +.page +.spage +.php1 +.he1 +1Steele and Sussman +.he2 +1The Revised Report on SCHEME0 + +.section +A.__The Representation of SCHEME Procedures as S-expressions +.sp + SCHEME programs are represented as LISP s-expressions. +The evaluator interprets these s-expressions in a specified way. +This specification constitutes the definition of the language. + The definition of SCHEME is a little fuzzy around the edges. +This is because of the inherent extensibility of LISP-like languages +{Note LISP Is a Ball of Mud}. +We can define a few essential features +which constitute the "kernel" of the language, +and also enumerate several syntactic and semantic extensions +which are convenient and normally included in a given implementation. +The existence of a mechanism for such extensions +is a part of the kernel of SCHEME; however, any particular +such extension is not necessarily part of the kernel. +.sp + For those who like this sort of thing, +here is the BNF for SCHEME programs {Note LISP BNF}: +.sp +.nofill +.spw 13 +.in 4 +1
::= | | | + ::= + ::= + | (QUOTE ) + | (IF ) + | (IF ) + | (LABELS ( ) ) + | (DEFINE ) + | (DEFINE ( ) ) + | (DEFINE ( ) ) + | (ASET' ) + | (FLUIDBIND ( ) ) + | (FLUID ) + | (FLUIDSET' ) + | (CATCH ) + | + ::= (LAMBDA ( ) ) + ::= | + ::= + ::= + | ( ) + ::= | ( ) + ::= ( ) + ::= | + ::= ( . ) + ::= + ::= | | | ...0 +.in 0 +.spw 16 +.adjust +.sp + Atoms which are not atomic symbols (identifiers) evaluate to themselves. +Typical examples of such atoms are numbers, arrays, and strings (character arrays). +Symbols are treated as identifiers or variables. +They may be lexically bound by lambda-expressions. +There is a global environment containing values for (some) free variables. +Many of the variables in this global environment initially +have as their values primitive operations such as, for example, +1CAR0, 1CONS0, and 1PLUS0. +SCHEME differs from most LISP systems in that the atom 1CAR0 +is not itself an operation (in the sense of being an invocable object, +e.g. a valid first argument to 1APPLY*), +but only has one as a value when considered as an identifier. + Non-atomic forms are divided by the evaluator into two classes: +combinations and "magic (special) forms". +The BNF given above is ambiguous; any magic form can also be parsed +as a combination. The evaluator always treats an ambiguous case as +a magic form. Magic forms are recognized by the presence of a +"magic (reserved) word" in the car position of the form. +All non-atomic forms which are not magic forms +are considered to be combinations. +The system has a small initial set of magic words; +there is also a mechanism for creating new ones +{Note FUNCALL is a Pain}. + A combination is considered to be a list +of subforms. These subforms are all evaluated. +The first value must be a procedure; it is applied +to the other values to get the value of the combination. +There are four important points here: +.sp +.in 3 +(1)__The procedure position is always evaluated +just like any other position. (This is why the primitive +operators are the values of global identifiers.) +.sp +(2)__The procedure is never "re-evaluated"; if the first subform fails to +evaluate to an applicable procedure, it is an error. +Thus, unlike most LISP systems, SCHEME always evaluates the +first subform of a combination exactly once. +.sp +(3)__The arguments are all completely evaluated +before the procedure is applied; that is, SCHEME, +like most LISP systems, is an applicative-order language. +Many SCHEME programs exploit this fact. +.sp +(4)__The argument forms (and procedure form) may in principle +be evaluated in any order. This is unlike the usual LISP left-to-right order. +(All SCHEME interpreters implemented so far have in fact +performed left-to-right evaluation, but we do not wish programs +to depend on this fact. Indeed, there are some reasons why +a clever interpreter might want to evaluate them right-to-left, +e.g. to get things on a stack in the correct order.) +.in 0 + +.page + +.section +B.__Catalogue of Magic Forms +.sp +.section +B.1.__Kernel Magic Forms +.sp + The magic forms in this section are all part of the kernel of SCHEME, +and so must exist in any SCHEME implementation. + +.in 3 + +.sp 2 +.block 4 +.un 3 +1(LAMBDA ( ) )0 +.sp + Lambda-expressions evaluate to procedures. +Unlike most LISP systems, SCHEME does not consider a lambda-expression +(an s-expression whose car is the atom 1LAMBDA0) +to be a procedure. A lambda-expression only evaluates to a procedure. +A lambda-expression should be thought of as a partial +description of a procedure; a procedure and a description +of it are conceptually distinct objects. +A lambda-expression must be "closed" (associated with an +environment) to produce a procedure object. +Evaluation of a lambda-expression performs such a closure operation. + The resulting procedure takes as many arguments as there are +identifiers in the identifier list of the lambda-expression. +When the procedure is eventually invoked, +the intuitive effect is that the evaluation of the procedure call is +equivalent to the evaluation +of the 10 in an environment consisting of +(a)_the environment in which the lambda-expression had been evaluated to +produce the procedure, plus (b)_the pairing of the +identifiers of the 10 with the arguments supplied +to the procedure. The pairings (b) take precedence over the environment (a), +and to prevent confusion no identifier may appear twice +in the 1*. +The net effect is to implement ALGOL-style lexical +scoping [Naur], and to "solve the funarg problem" [Moses]. + +.sp 2 +.block 4 +.un 3 +1(IF )0 +.sp + This is a primitive conditional operator. +The predicate form is evaluated. If the result +is non-1NIL0 {Note 1IF* Is Data-Dependent}, +then the consequent is evaluated, and otherwise the alternative is evaluated. +The resulting value (if there is one) is the value of the 1IF0 form. + +.sp 2 +.block 4 +.un 3 +1(IF )0 +.sp + As above, but if the predicate evaluates to 1NIL0, +then 1NIL0 is the value of the 1IF0 form. (As a matter of style, +this is usually used +only when the value of the 1IF0 form doesn't matter, +for example, when the consequent is intended to cause a side effect.) + + +.sp 2 +.block 4 +.un 3 +1(QUOTE )0 +.sp + As in LISP, this quotes the argument form so +that it will be passed verbatim as data; the value of +this form is 10. +If a SCHEME implementation has the MacLISP read-macro-character feature, then +the abbreviation 1'FOO0 may be used instead of 1(QUOTE FOO)0. + +.sp 2 +.block 4 +.un 3 +1(LABELS ( ) )0 + where 1 ::=0 +1 | ( ) 0 +.sp + This has the effect of evaluating the 10 in an environment +where all the identifiers (which, as for 1LAMBDA*, must all be distinct) +in the labels list evaluate to +the values of the respective lambda-expressions. +Furthermore, the procedures which are the values of +the lambda-expressions are themselves closed in that environment, +and not in the outer environment; this allows the procedures to call +themselves and each other recursively. +For example, consider a procedure which counts all the atoms in a list +structure recursively to all levels, but which doesn't count the 1NIL0s +which terminate lists (but 1NIL0s in the car of a list count). +In order to perform this we define two mutually recursive procedures, +one to count the car and one to count the cdr, as follows: +.sp +.block 14 +.nofill +.spw 13 + 1(DEFINE COUNT + (LAMBDA (L) + (LABELS ((COUNTCAR + (LAMBDA (L) + (IF (ATOM L) 1 + (+ (COUNTCAR (CAR L)) + (COUNTCDR (CDR L)))))) + (COUNTCDR + (LAMBDA (L) + (IF (ATOM L) + (IF (NULL L) 0 1) + (+ (COUNTCAR (CAR L)) + (COUNTCDR (CDR L))))))) + (COUNTCDR L))))0 +.spw 16 +.adjust +.sp + (We have decided not to use the traditional LISP +1LABEL0 primitive in SCHEME because it is difficult to define several mutually +recursive procedures using only 1LABEL0. +Although 1LABELS* is a little more complicated than 1LABEL*, +it is considerably more convenient. +Contrast this design decision with the choice of +1IF* over the more traditional 1COND*, where the definitional +simplicity of 1IF* outweighed the somewhat greater convenience of 1COND*.) + + +.in 0 + +.sp 2 +.section +B.2.__Side Effects +.sp + These magic forms produce side effects in the environment. + +.in 3 + +.sp 2 +.block 4 +.un 3 +1(DEFINE )0 +.sp + This is used for defining a procedure in the "global environment" permanently, +as opposed to 1LABELS0, which is used for temporary procedure definitions +in a local environment. 1DEFINE0 takes a name and a lambda-expression; +it evaluates the lambda-expression in the global environment and +causes the result to be the global value of the identifier. +(1DEFINE0 may perform other implementation-dependent operations as well, +such as keeping track of defined procedures for an editor. +For this reason it is the preferred way to define a globally +available procedure.) + +.sp 2 +.block 4 +.un 3 +1(DEFINE ( ) )0 +.br +.un 3 +1(DEFINE ( ) )0 +.sp +These alternative syntaxes permitted by 1DEFINE0 +are equivalent to: +.sp +.block 3 +.nofill +.spw 13 + 1(DEFINE + (LAMBDA ( ) + (BLOCK )))0 +.spw 16 +.adjust +.sp +where 1BLOCK* is a syntactic extension defined below. +For example, these three definitions are equivalent: +.sp +.nofill +.spw 13 +.block 3 + 1(DEFINE CIRCULATE (LAMBDA (X) (RPLACD X X))) + (DEFINE CIRCULATE (X) (RPLACD X X)) + (DEFINE (CIRCULATE X) (RPLACD X X))0 +.spw 16 +.adjust +.sp +These forms are provided to support stylistic diversity. + + +.sp 2 +.block 4 +.un 3 +1(ASET' )0 +.sp + This is analogous to the LISP primitive 1SETQ0. +For example, to define a cell [Smith and Hewitt], +we may use 1ASET'0 as follows: +.sp +.block 12 +.nofill +.spw 13 + 1(DEFINE CONS-CELL + (LAMBDA (CONTENTS) + (LABELS ((THE-CELL + (LAMBDA (MSG) + (IF (EQ MSG 'CONTENTS?) CONTENTS + (IF (EQ MSG 'CELL?) 'YES + (IF (EQ (CAR MSG) '<-) + (BLOCK (ASET' CONTENTS (CADR MSG)) + THE-CELL) + (ERROR '|UNRECOGNIZED MESSAGE - CELL| + MSG + 'WRNG-TYPE-ARG))))))) + THE-CELL)))0 +.spw 16 +.adjust +.sp +Note that 1ASET'0 may be used on global identifiers as well as locally bound identifiers +{Note 1ASET0 Has Disappeared}. + +.in 0 + +.sp 2 +.section +B.3.__Dynamic Magic +.sp + These magic forms implement escape objects and fluid (dynamic) +variables. They are not a part of the essential kernel. +For a further explication of their semantics in terms of kernel primitives, +see [Imperative]. + +.in 3 + +.sp 2 +.block 4 +.un 3 +1(FLUIDBIND ( ) )0 + where 1 ::=0 +1 | ( ) 0 +.sp + This evaluates the 10 in the environment of the +1FLUIDBIND0 form, with a dynamic environment to which +dynamic bindings of the identifiers in the 10 +have been added. Any procedure dynamically called by +the form, even if not lexically apparent to the 1FLUIDBIND0 form, +will see this dynamic environment (unless modified by further +1FLUIDBIND0s, of course). The dynamic environment is restored +on return from the form. + Most LISP systems use a dynamic environment for +all variables. A SCHEME which implements 1FLUIDBIND0 provides two +distinct environments. The fluid variable named 1FOO0 is completely +unrelated to a normal lexical variable named 1FOO0 +{Note Global Fluid Environment}, +and the access mechanisms for the two are distinct. + +.sp 2 +.block 4 +.un 3 +1(FLUID )0 +.sp + The value of this form is the value of the 1* in +the current dynamic environment. In SCHEME implementations +which have the MacLISP read-macro-character feature, +1(FLUID FOO)0 may be abbreviated to 1FOO0. + +.sp 2 +.block 4 +.un 3 +1(FLUIDSET' )0 +.sp + The value of the 10 is assigned to the 10 in the +current dynamic environment. + +.sp 2 +.block 4 +.un 3 +1(STATIC )0 +.sp + The value of this is the value of the lexical identifier; +writing this is the same as writing just 10 +{Note What Good Is It?}. + +.sp 2 +.block 4 +.un 3 +1(CATCH )0 +.sp + This evaluates the form in an environment where the identifier is bound to +an "escape object" [Landin] [Reynolds]. +This is a strange object which can be invoked as if +it were a procedure of one argument. When the escape object is so invoked, +then control proceeds as if the 1CATCH0 expression had returned with the +supplied argument as its value +{Note Multiple Throw}. + If both 1CATCH0 and 1FLUIDBIND0 are implemented, then their +semantics are intertwined. When the escape object is called, +then the dynamic environment is restored to +the one which was current at the time the 1CATCH0 form was evaluated +{Note Environment Symmetry}. + For a contorted example, +consider the following obscure definition of 1SQRT0 +(Sussman's least favorite style/Steele's favorite; but see [SCHEME]): +.sp +.block 13 +.nofill +.spw 13 + 1(DEFINE SQRT + (LAMBDA (X EPSILON) + ((LAMBDA (ANS TAG GO) + (CATCH RETURN + (BLOCK + (CATCH M (ASET' TAG M)) ;CREATE PROG TAG + (IF (< (ABS (-$ (*$ ANS ANS) X)) EPSILON) ;CAMGE + (RETURN ANS)) ;POPJ + (ASET' ANS (//$ (+$ (//$ X ANS) ANS) 2.0)) ;MOVEM + (GO TAG)))) ;JRST + 1.0 + NIL + (LAMBDA (F) (F NIL)))))0 +.spw 16 +.adjust +.sp +This example differs slightly from the version given in [SCHEME]; +notice the forms 1(RETURN ANS)0 and 1(GO TAG)0. + As another example, we can define a 1THROW0 function, +which may then be used with 1CATCH0 much as it is in MacLISP [Moon] +(except that in MacLISP the tag is written after the body of the 1CATCH0, +not before): +.sp +.nofill +.spw 13 + 1(DEFINE THROW (LAMBDA (TAG RESULT) (TAG RESULT)))* +.spw 16 +.adjust +.sp +An example of its use: +.sp +.nofill +.spw 13 +.block 3 + 1(CATCH LOSE + (MAPCAR (LAMBDA (X) (IF (MINUSP X) (THROW LOSE NIL) (SQRT X))) + NUMLIST))0 +.spw 16 +.adjust +.sp +Indeed, note the similarity between 1THROW0 and the definition of +1GO0 in the first example. + +.in 0 + +.page + +.section +C.__Syntactic Extensions +.sp + SCHEME has a syntactic extension mechanism which provides +a way to define an identifier to be a magic word, +and to associate a function with that word. +The function accepts the magic form as an argument, +and produces a new form; this new form is then evaluated +in place of the original (magic) form. +This is precisely the same as the MacLISP macro facility. + +.sp 2 +.section +C.1.__System-Provided Extensions +.sp + Some standard syntactic extensions are provided by the system +for convenience in ordinary programming. They are distinguished +from other magic words in that they are semantically defined in terms of others +rather than being primitive {Note FEXPRs Are Okay by Us}. +For expository purposes they are described here in a +pattern-matching/production-rule kind of language. +The matching is on s-expression structure, not on character string syntax, +and takes advantage of the definition of list notation: +1(A_B_C) = (A_._(B_._(C_._NIL)))0. +Thus the pattern 1(x_._r)0 matches 1(A_B_C)0, with 1x_=_A0 +and 1r_=_(B C)0. +The ordering of the "productions" is significant; +the first one which matches is to be used. + + +.in 3 + +.sp 2 +.block 4 +.nofill +.spw 13 +.un 3 +1(BLOCK x1 x2 ... xn )0 +.sp +1 (BLOCK x) 41 x0 +1 (BLOCK x . r) 41 ((LAMBDA (A B) (B)) x (LAMBDA () (BLOCK . r)))0 +.spw 16 +.adjust +.sp +1BLOCK0 sequentially evaluates the subforms 1xi 0 from left to right. +For example: +.sp +.nofill +.spw 13 +1 (BLOCK (ASET' X 43) (PRINT X) (+ X 1))0 +.spw 16 +.adjust +.sp +returns 1440 after setting 1X0 to 143* and then printing it +{Note 1BLOCK0 Exploits Applicative Order}. + +.sp 2 +.block 4 +.nofill +.spw 13 +.un 3 +1(LET ((v1 x1 ) (v2 x2 ) ... (vn xn )) . body)0 +.sp + 41 ((LAMBDA (v1 v2 ... vn ) (BLOCK . body)) x1 x2 ... xn )0 +.spw 16 +.adjust +.sp +1LET0 provides a convenient syntax for binding several +variables to corresponding quantities. It allows the +forms for the quantities to appear textually adjacent +to their corresponding variables. Notice that the +variables are all bound simultaneously, not sequentially, +and that the initialization forms 1xi * may be evaluated +in any order. +For convenience, 1LET0 also supplies a 1BLOCK0 around the forms constituting its body. + + + +.sp 2 +.nofill +.spw 13 +.block 10 +.un 3 +1(DO ((v1 x1 s1 ) ... (vn xn sn )) (test . done) . body)0 +.sp +.block 8 +.nofill +.spw 13 + 41 (LET ((A1 (LAMBDA () x1 )) + (B1 (LAMBDA (v1 ... vn ) s1 )) + ... + (An (LAMBDA () xn )) + (Bn (LAMBDA (v1 ... vn ) sn )) + (TS (LAMBDA (v1 ... vn ) test)) + (DN (LAMBDA (v1 ... vn ) (BLOCK . done))) + (BD (LAMBDA (v1 ... vn ) (BLOCK . body)))) +.block 9 + (LABELS ((LOOP + (LAMBDA (Z1 ... Zn) + (IF (TS Z1 ... Zn) + (DN Z1 ... Zn) + (BLOCK (BD Z1 ... Zn) + (LOOP (B1 Z1 ... Zn) + ... + (Bn Z1 ... Zn))))))) + (LOOP (A1) ... (An))))0 +.spw 16 +.adjust +.sp +This is essentially the MacLISP "new-style" 1DO0 loop [Moon]. +The variables 1vi 0 are bound to the values of the corresponding 1xi 0, +and stepped in parallel after every execution of the body by the 1si 0 +(by "step" we mean "set to the value of", not "increment by"). +If an 1si 0 is omitted, 1vi 0 is assumed; this results in the variable +not being stepped. If in addition 1xi 0 is omitted, 1NIL0 is assumed. +The loop terminates when the test evaluates non-1NIL0; it is +evaluated before each execution of the body. When this occurs, +the 1done0 part is evaluated as a 1BLOCK0. + The complexity of the definition shown is due to an effort to +avoid conflict of variable names, as for 1BLOCK0. +The auxiliary variables 1Ai0, 1Bi0, and 1Zi0 must be generated +to produce as many as are needed, but they need not be chosen +different from all variables appearing in 1xi 0, 1si 0, 1body0, etc. + The iteration is effected entirely by procedure calls. +In this manner the definition of 1DO* exploits the tail-recursive +properties of SCHEME [SCHEME] [Imperative]. + As an example, here is a definition of a function +to find the length of a list: +.sp +.nofill +.spw 13 + 1(DEFINE (LENGTH X) + (DO ((Z X (CDR Z)) + (N 0 (+ N 1))) + ((NULL Z) N)))0 +.spw 16 +.adjust +.sp + The initializations forms 1xi * may be evaluated in any order, +and on each iteration the stepping form 1si * may be evaluated in any order. +This differs from the MacLISP definition of 1DO*. +For example, this definition of 1NREVERSE* (destructively reverse a list) +would work in MacLISP but not necessarily in SCHEME: +.sp +.nofill +.spw 13 +.block 4 +1 (DEFINE NREVERSE (X) + (DO ((A X (CDR A)) + (B NIL (RPLACD A B))) + ((NULL A) B)))0 +.spw 16 +.adjust +.sp +This definition depends on the 1CDR* occurring before the 1RPLACD*. +In SCHEME we must instead write: +.sp +.nofill +.spw 13 +.block 4 + 1(DEFINE NREVERSE (X) + (DO ((A X (PROG1 (CDR A) (RPLACD A B))) + (B NIL A)) + ((NULL A) B)))* +.spw 16 +.adjust +.sp +where by 1(PROG1 x y)* we mean 1((LAMBDA (P_Q) (BLOCK_(Q)_P)) x_(LAMBDA_()_y))* +(but 1PROG1* is not really a defined SCHEME primitive). + Note also that the effect of an 1ASET'0 on a 1DO0 variable does not +survive to the next iteration; this differs from using 1SETQ0 +on a 1DO0 variable in MacLISP. + + +.sp 2 +.block 6 +.un 3 +1(ITERATE name ((v1 e1 ) ... (vn en )) . body)0 +.sp +.nofill +.spw 13 + 41 (LABELS ((name (LAMBDA (v1 ... vn ) (BLOCK . body)))) + (name e1 ... en ))0 +.spw 16 +.adjust +.sp + This defines a looping construct more general than 1DO0. +For example, consider a function to sort out a list of +s-expressions into atoms and lists: +.sp +.nofill +.spw 13 +.block 9 + 1(DEFINE COLLATE + (LAMBDA (X) + (ITERATE COL + ((Z X) (ATOMS NIL) (LISTS NIL)) + (IF (NULL Z) + (LIST ATOMS LISTS) + (IF (ATOM (CAR Z)) + (COL (CDR Z) (CONS (CAR Z) ATOMS) LISTS) + (COL (CDR Z) ATOMS (CONS (CAR Z) LISTS)))))))0 +.spw 16 +.adjust +.sp +We have found many situations involving loops where there may be more +than one condition on which to exit and/or more than one condition +to iterate, where 1DO0 is too restrictive but 1ITERATE0 suffices. +Notice that because each loop has a name, one can +specify from an inner loop that the next iteration of any outer +loop is to occur. Here is a function very similar to the one used +in one SCHEME implementation for variable lookup: +there are two lists of lists, one containing names and the other values. +.sp +.nofill +.spw 13 +.block 4 + 1(DEFINE (LOOKUP NAME VARS VALUES) + (ITERATE MAJOR-LOOP + ((VARS-BACKBONE VARS) + (VALUES-BACKBONE VALUES)) +.block 5 + (IF (NULL VARS-BACKBONE) + NIL + (ITERATE MINOR-LOOP + ((VARS-RIB (CAR VARS-BACKBONE)) + (VALUES-RIB (CAR VALUES-BACKBONE))) +.block 3 + (IF (NULL VARS-RIB) + (MAJOR-LOOP (CDR VARS-BACKBONE) + (CDR VALUES-BACKBONE)) +.block 4 + (IF (EQ (CAR VARS-RIB) NAME) + VALUES-RIB + (MINOR-LOOP (CDR VARS-RIB) + (CDR VALUES-RIB))))))))0 +.spw 16 +.adjust +.sp + (We had originally wanted to call this construct 1LOOP0, +but see {Note 1FUNCALL0 is a Pain}. Compare this with looping constructs +appearing in [Hewitt].) + It happens that 1ITERATE* is a misleading name; the construct can actually +be used for recursion ("true" recursion, as opposed to tail-recursion) as well. +If the 1name* is invoked from a non-tail-recursive situation, +the argument evaluation in which the call is embedded is not +aborted. It just so happens that we have found 1ITERATE0 useful +primarily to implement complicated iterations. +One can draw the rough analogy 1ITERATE* : 1LABELS* :: +1LET* : 1LAMBDA*. + + + +.sp 2 +.block 6 +.un 3 +1(TEST pred fn alt)0 +.sp +.nofill +.spw 13 + 41 ((LAMBDA (P F A) (IF P ((F) P) (A))) + pred + (LAMBDA () fn) + (LAMBDA () alt))0 +.spw 16 +.adjust +.sp +The predicate is evaluated; if its value is non-1NIL0 +then the form 1fn0 should evaluate to a procedure of one argument, +which is then invoked on the value of the predicate. Otherwise +the alternative 1alt0 is evaluated. + This construct is of occasional use with LISP "predicates" which +return a "useful" non-1NIL0 value. For the consequent of an 1IF0 +to get at the non-1NIL0 value of the predicate, one might first +bind a variable to the value of the predicate, and this variable +would then be visible to the alternative as well. With 1TEST0, the use +of the variable is restricted to the consequent. + An example: +.sp +.nofill +.spw 13 + 1(TEST (ASSQ VARIABLE ENVIRONMENT) + CDR + (GLOBALVALUE VARIABLE))0 +.spw 16 +.adjust +.sp +Using an a-list to represent an environment, one wants +to use the cdr of the result of 1ASSQ0 if it is non-1NIL0; +but if it is 1NIL0, then the variable was not in the environment, +and one must look elsewhere. + +.sp 2 +.block 8 +.nofill +.spw 13 +.un 3 +1(COND (p1 . e1 ) ... (pn . en ))0 +.sp +.nofill +.spw 13 +.block 6 + 1(COND) 41 'NIL + (COND (p) . r) 41 ((LAMBDA (V R) (IF V V (R))) + p + (LAMBDA () (COND . r))) + (COND (p => f) . r) 41 (TEST p f (COND . r)) + (COND (p . e) . r) 41 (IF p (BLOCK . e) (COND . r))0 +.spw 16 +.adjust +.sp +This 1COND0 is a superset of the MacLISP 1COND0. +As in MacLISP, singleton clauses return the value of the predicate if it is non-1NIL0, and +clauses with two or more forms treat the first as the predicate +and the rest as constituents of a 1BLOCK0, thus evaluating them +in order. + The extension to the MacLISP 1COND0 made in SCHEME is flagged +by the atom 1=>0. +(It cannot be confused with the more general case of two 1BLOCK0 +constituents because having the atom 1=>0 as the first element of a 1BLOCK0 +is not useful.) In this situation the form 1f0 following the 1=>0 +should have as its value a function of one argument; +if the predicate 1p0 is non-1NIL0, this function is determined +and invoked on the value returned by the predicate. +This is useful for the common situation encountered in LISP: +.sp +.nofill +.spw 13 +.block 2 + 1(COND ((SETQ IT (GET X 'PROPERTY)) (HACK IT)) + ...)0 +.spw 16 +.adjust +.sp +which in SCHEME can be rendered without using a variable global to the 1COND0: +.sp +.nofill +.spw 13 +.block 3 + 1(COND ((GET X 'PROPERTY) + => (LAMBDA (IT) (HACK IT))) + ...)0 +.spw 16 +.adjust +.sp +or, in this specific instance, simply as: +.sp +.nofill +.spw 13 +.block 2 + 1(COND ((GET X 'PROPERTY) => HACK) + ...)0 +.spw 16 +.adjust +.sp + + +.sp 2 +.block 5 +.un 3 +1(OR x1 x2 ... xn )0 +.sp +.nofill +.spw 13 +1 (OR) 41 'NIL + (OR x) 41 x + (OR x . r) 41 (COND (x) (T (OR . r)))0 +.spw 16 +.adjust +.sp +This standard LISP primitive evaluates the forms 1xi 0 in order, +returning the first non-1NIL0 value (and ignoring all following forms). +If all forms produce 1NIL0, then 1NIL0 is returned +{Note Tail-Recursive 1OR0}. + +.sp 2 +.block 5 +.un 3 +1(AND x1 x2 ... xn )0 +.sp +.nofill +.spw 13 +1 (AND) 41 'T + (AND x) 41 x + (AND x . r) 41 (COND (x (AND . r)))0 +.spw 16 +.adjust +.sp +This standard LISP primitive evaluates the forms 1xi 0 in order. +If any form produces 1NIL0, then 1NIL0 is returned, and succeeding forms 1xi 0 +are ignored. If all forms produce non-1NIL0 values, the value of the +last is returned +{Note Tail-Recursive 1AND0}. + +.sp 2 +.block 10 +.un 3 +1(AMAPCAR f x1 x2 ... xn )0 +.sp +.nofill +.spw 13 +.block 8 + 41 (DO ((FN f) + (V1 x1 (CDR V1)) + (V2 x2 (CDR V2)) + ... + (Vn xn (CDR Vn)) + (Q 'NIL (CONS (FN (CAR V1) (CAR V2) ... (CAR Vn)) Q))) + ((OR (NULL V1) (NULL V2) ... (NULL Vn)) + (NREVERSE Q)))0 +.spw 16 +.adjust +.sp +1AMAPCAR0 is analogous to the MacLISP 1MAPCAR0 function. The function 1f0, +a function of 1n0 arguments, +is mapped simultaneously down the lists 1x1 0, 1x2 0, ..., 1xn 0; +that is, 1f0 is applied to tuples of successive elements of the lists. +The values returned by 1f0 are collected and returned as a list. +Note that 1AMAPCAR0 of a fixed number of arguments could easily +be written as a function in SCHEME. It is a syntactic extension +only so that it may accommodate any number of arguments, +which saves the trouble of defining an entire set of primitive +functions 1AMAPCAR10, 1AMAPCAR20, ... where 1AMAPCARn0 takes 1n+10 arguments. + +.sp 2 +.block 10 +.un 3 +1(AMAPLIST f x1 x2 ... xn )0 +.sp +.nofill +.spw 13 +.block 8 + 41 (DO ((FN f) + (V1 x1 (CDR V1)) + (V2 x2 (CDR V2)) + ... + (Vn xn (CDR Vn)) + (Q 'NIL (CONS (FN V1 V2 ... Vn) Q))) + ((OR (NULL V1) (NULL V2) ... (NULL Vn)) + (NREVERSE Q)))0 +.spw 16 +.adjust +.sp +1AMAPLIST0 is analogous to the MacLISP 1MAPLIST0 function. The function 1f0, +a function of 1n0 arguments, +is applied to tuples of successive tails of the lists. +The values returned by 1f0 are collected and returned as a list. + + +.sp 2 +.block 10 +.un 3 +1(AMAPC f x1 x2 ... xn )0 +.sp +.nofill +.spw 13 +.block 8 + 41 (DO ((FN f) + (X1 x1 (CDR X1)) + (X2 x2 (CDR X2)) + ... + (Xn xn (CDR Xn))) + ((OR (NULL X1) (NULL X2) ... (NULL Xn)) + 'NIL) + (FN (CAR X1) (CAR X2) ... (CAR Xn)))0 +.spw 16 +.adjust +.sp +1AMAPC0 is analogous to the MacLISP 1MAPC0 function. The procedure 1f0, +a procedure taking 1n0 arguments, +is mapped simultaneously down the lists 1x1 0, 1x2 0, ..., 1xn 0; +that is, 1f0 is applied to tuples of successive elements of the lists. +Thus 1AMAPC0 is similar to 1AMAPCAR0, except that no values are expected +from 1f0; therefore 1f0 need not be a function, but may be any procedure. + +.sp 2 +.block 4 +.un 3 +1(PROG varlist s1 s2 ... sn )0 +.sp + The SCHEME 1PROG0 is like the ordinary LISP 1PROG0. +There is no simple way to describe the transformation +of 1PROG0 syntax into SCHEME primitives. +The basic idea is that a large 1LABELS0 statement is created, +with a labelled procedure (of zero arguments) for each 1PROG0 statement. +Each statement is transformed in such a way that each one that +"drops through" is made to call the labelled procedure for the succeeding +statement; each appearance of 1(GO tag)0 is converted to a call +on the labelled procedure for the statement following the tag; +and each appearance of 1(RETURN value)0 is replaced by 1value0. + Practical experience with SCHEME has shown that 1PROG0 +is almost never used. It is usually more convenient just +to write the corresponding 1LABELS0 directly. This allows one to +write 1LABELS0 procedures which take arguments, which tends to +clarify the flow of data [Imperative]. + +.in 0 + +.sp 2 + The rest of this section (FSUBRs) applies only to the PDP-10 MacLISP +implementation of SCHEME. + +.in 3 + +.sp 2 +.block 2 +.un 3 +FSUBRs +.sp + As a user convenience, the PDP-10 MacLISP implementation +of SCHEME treats FSUBRs specially; any FSUBR provided by the MacLISP +system is automatically a SCHEME primitive (but user FSUBRs are not). +Of course, if the FSUBR tries to evaluate some form obtained from its +argument, the variable references will not refer to SCHEME variables. +As a special case, the SCHEME syntactic extension +1AARRAYCALL0 is provided to get the +effect of the MacLISP FSUBR 1ARRAYCALL0. + +.in 0 + +.sp 2 +.section +C.2.__User-Provided Extensions +.sp + + A SCHEME implementation should have one or more ways for the user to extend +the inventory of magic words. The methods provided will vary +from implementation to implementation. The following primitive +(1SCHMAC0) is provided in the PDP-10 MacLISP implementation of SCHEME. + +.in 3 + +.sp 2 +.block 2 +.un 3 +1(SCHMAC name pattern body)0 +.sp + After execution of this form, a syntactic extension keyed on the +atom 1name0 is defined. When a form 1(name_._rest)0 is to be evaluated, +1rest0 is matched against the pattern, which is a (possibly "dotted") +list of variables. The 1body0 is then evaluated in an environment +where the variables in the pattern have as values the corresponding parts +of rest. This should result in a form to be evaluated in place of the +form 1(name_._rest)0. + The body is not necessarily SCHEME code, but rather code +in the same meta-language used to write the evaluator. +In the PDP-10 MacLISP SCHEME implementation, the body is MacLISP code. + As an example, here is a definition of 1TEST0: +.sp +.nofill +.spw 13 +.block 5 + 1(SCHMAC TEST (PRED FN ALT) + (LIST '(LAMBDA (P F A) (IF P ((F) P) (A))) + PRED + (LIST 'LAMBDA '() FN) + (LIST 'LAMBDA '() ALT)))0 +.spw 16 +.adjust +.sp + The body of a SCHMAC almost always performs a complicated consing-up +of a program structure. Often one needs to make a copy of a +standard structure, with a few values filled in. +To make this easier, SCHEME provides an "unquoting quote" feature. +An expression of the form 1"0 is just like 1'0, +except that sub-expressions preceded by "1,0" or "1@0" represent +expressions whose values are to be made part of (a copy of) +the s-expression at that point. A "1,0" denotes simple inclusion, +while "1@0" denotes "splicing" or "segment" inclusion. +(Compare this with the treatment of lists with embedded forms +in MUDDLE [Galley and Pfister], which in turn inspired the 1!"0 syntax of CONNIVER [McDermott and Sussman], +from which SCHEME's 1"0 syntax is derived.) +Using this, one can define 1TEST0 as follows: +.sp +.nofill +.spw 13 +.block 5 +1 (SCHMAC TEST (PRED FN ALT) + "((LAMBDA (P F A) (IF P ((F) P) (A))) + ,PRED + (LAMBDA () ,FN) + (LAMBDA () ,ALT)))0 +.spw 16 +.adjust +.sp +Similarly, 1LET0 can be defined as: +.sp +.nofill +.spw 13 +.block 4 + 1(SCHMAC LET (DEFNS . BODY) + "((LAMBDA ,(MAPCAR 'CAR DEFNS) + (BLOCK . ,BODY)) + @(MAPCAR 'CADR DEFNS)))0 +.spw 16 +.adjust +.sp +One could also write 1(BLOCK_@BODY)0 instead of 1(BLOCK_._,BODY)0. + Notice the use of 1(MAPCAR 'CAR DEFNS)0 rather than +1(AMAPCAR CAR DEFNS)0, and recall that, as stated above, +the body of a 1SCHMAC0 is MacLISP code, not SCHEME code. +Consider too this definition of 1COND0: +.sp +.nofill +.spw 13 +.block 11 + 1(SCHMAC COND CLAUSES + (COND ((NULL CLAUSES) ''NIL) + ((NULL (CDAR CLAUSES)) + "((LAMBDA (V R) (IF V V R)) + ,(CAAR CLAUSES) + (LAMBDA () (COND . ,(CDR CLAUSES))))) + ((EQ (CADAR CLAUSES) '=>) + "(TEST ,(CAAR CLAUSES) ,(CADDAR CLAUSES) (COND . ,(CDR CLAUSES)))) + (T "(IF ,(CAAR CLAUSES) + (BLOCK . ,(CDAR CLAUSES)) + (COND . ,(CDR CLAUSES))))))0 +.spw 16 +.adjust +.sp +We have used 1COND0 to define 1COND0! The definition is not circular, however; +the MacLISP 1COND0 is being used to define the SCHEME 1COND0, +and indeed the two have slightly different semantics. +The definition would have been circular had we written +1(COND (V) (R))0 instead of 1(IF V V R)0, for the latter is part +of the generated SCHEME code. + + +.sp 2 +.block 2 +.un 3 +1(MACRO name pattern body)0 +.sp + This is just like 1SCHMAC*, except that 1body* is SCHEME +code rather than MacLISP code. While macros defined with 1SCHMAC* +run only in a MacLISP implementation of SCHEME, those defined +with 1MACRO* should be completely transportable. +(We described 1SCHMAC* first to emphasize the fact that macros +are conceptually part of the interpreter, and so conceptually +written in the meta-language. It so happens, however, that +SCHEME is a good meta-language for SCHEME, and so introducing +this meta-circularity provides no serious problems. +Contrast this with writing PL/I macros in PL/I!) + The example of defining 1COND* using 1SCHMAC* above +would be circular if we changed the word 1SCHMAC* to 1MACRO*. +However, we can avoid this by avoiding the use of 1COND* +in the definition: +.sp +.nofill +.spw 13 +.block 11 + 1(MACRO COND CLAUSES + (IF (NULL CLAUSES) ''NIL + (IF (NULL (CDAR CLAUSES)) + "((LAMBDA (V R) (IF V V R)) + ,(CAAR CLAUSES) + (LAMBDA () (COND . ,(CDR CLAUSES)))) + (IF (EQ (CADAR CLAUSES) '=>) + "(TEST ,(CAAR CLAUSES) + ,(CADDAR CLAUSES) + (COND . ,(CDR CLAUSES))) + "(IF ,(CAAR CLAUSES) + (BLOCK . ,(CDAR CLAUSES)) + (COND . ,(CDR CLAUSES)))))))0 +.spw 16 +.adjust +.sp + We strongly encourage the use of 1MACRO* instead of 1SCHMAC* +in practice so that macro definitions will not be dependent on +the properties of a specific implementation. + +.in 0 + +.page + +.section +D.__Primitive SCHEME Functions +.sp + All the usual MacLISP SUBRs are available in SCHEME +as procedures which are the values of global variables. +The particular primitives 1CONS0, 1CAR0, 1CDR0, 1ATOM0, and 1EQ0 +are part of the kernel of SCHEME! Others, such as 1+0, 1-0, 1*0, 1//0, 1=0, +1EQUAL0, 1RPLACA0, 1RPLACD0, etc. are quite convenient to have. + Although there is no way in SCHEME to write a LEXPR +(a function of a variable number of arguments), +MacLISP LSUBRs are also available to the SCHEME user. +One may wish to regard these as syntactic extensions +in much the same way 1AMAPCAR0 is; for example, 1LIST0 may be thought of +as a syntactic extension such that: +.sp +.block 2 +.nofill +.spw 13 +1 (LIST) 41 'NIL + (LIST x . r) 41 (CONS x (LIST . r))0 +.spw 16 +.adjust +.sp + Below we also describe some additional primitive functions +provided with SCHEME. Their names do not have any special syntactic +properties in the way that the magic words for syntactic extensions described +in the previous section do. However, they do deal with +the underlying implementation, and so could not be programmed +directly by the user were they not provided as primitives. + +.sp 2 + The following primitive functions (1PROCP0 and +1ENCLOSE0) are part of the kernel of SCHEME. + +.in 3 + +.sp 2 +.block 4 +.un 3 +1(PROCP thing)0 +.sp + This is a predicate which is true of procedures, and not of +anything else. Thus if 1(PROCP X)0 is true, then it is safe +to invoke the value of 1X0. + More precisely, if 1PROCP0 returns a non-1NIL0 value, then +the value describes the number of arguments accepted by the procedure. +For SCHEME procedures this will be an integer, the number of arguments. +For primitive functions, this may be implementation-dependent; +in the PDP-10 MacLISP implementation of SCHEME, 1PROCP0 of an LSUBR +returns the MacLISP 1ARGS0 property for that LSUBR. +If an object given to 1PROCP0 is a procedure but +the number of arguments it requires cannot be determined for some reason, +then 1PROCP0 returns 1T0. + +.sp 2 +.block 4 +.un 3 +1(ENCLOSE fnrep envrep)0 +.sp + 1ENCLOSE0 takes two s-expressions, one representing the code +for a procedure, and the other representing the (lexical) environment +in which the procedure is to run. 1ENCLOSE0 returns a (closed) procedure +which can be invoked. + The representation of the code is the standard +s-expression description (a lambda-expression). +The representation of the environment is an association list (a-list) +of the traditional kind: +.sp +.nofill +.spw 13 +1 ((var1 . value1) (var2 . value2) ...)0 +.spw 16 +.adjust +.sp +1NIL0 represents the global lexical environment. + This description of 1ENCLOSE0 should not be construed as describing how the +implementation of SCHEME represents either environment or code +internally. Indeed, 1ENCLOSE0 could be as simple as 1CONS0, or as complicated +as a compiler. All that 1ENCLOSE0 guarantees to do is to +compute a procedure object given a description of its desired behavior. +The description must be in the prescribed form; but the result may be in any form +convenient to the implementation, as long as it satisfies the predicate 1PROCP0 +{Note 1EVALUATE0 Has Disappeared} +{Note S-expressions Are Not Functions}. + As an example, we can write 1APPLY0 using 1ENCLOSE0. +One way is to generate a lot of names for the arguments involved: +.sp +.nofill +.spw 13 +.block 7 +1 (DEFINE APPLY + (LAMBDA (FN ARGS) + (LET ((VARS (AMAPCAR (LAMBDA (X) (GENSYM)) ARGS)) + (FNVAR (GENSYM))) + ((ENCLOSE "(LAMBDA () (,FNVAR @VARS)) + (CONS (CONS FNVAR FN) + (AMAPCAR CONS VARS ARGS)))))))0 +.spw 16 +.adjust +.sp +Here a procedure which will call the procedure 1FN0 on the required +number of arguments is enclosed in an environment with all +the variables bound to the appropriate values. For those +who don't like 1GENSYM0, here is another way to do it: +.sp +.nofill +.spw 13 +.block 7 +1 (DEFINE APPLY + (LAMBDA (FN ARGS) + (DO ((TAIL 'A "(CDR ,TAIL)) + (REFS NIL (CONS "(CAR ,TAIL) REFS)) + (COUNT ARGS (CDR COUNT))) + ((NULL COUNT) + ((ENCLOSE "(LAMBDA (F A) (F @(REVERSE REFS))) NIL) + FN ARGS)))))0 +.spw 16 +.adjust +.sp +In this version we create a series of forms 1(CAR_A)0, 1(CAR_(CDR_A))0, +1(CAR_(CDR (CDR_A)))0, ... +to be used to access the arguments. (In a way, these are distinct names +for the arguments in the same way that the gensyms were for the first version.) +The values 1FN0 and 1ARGS0 are passed in as arguments to the enclosed +procedure, rather than giving a non-1NIL0 environment representation to 1ENCLOSE0. + As another example, we define a function called 1*LAMBDA*: +.sp +.nofill +.spw 13 +.block 2 + 1(DEFINE (*LAMBDA VARS BODY) + (ENCLOSE "(LAMBDA ,VARS ,BODY) NIL))* +.spw 16 +.adjust +.sp +Writing 1(*LAMBDA '(X Y) '(FOO Y X))* is just like writing +1(LAMBDA (X Y) (FOO Y X))*. However, if there are any free variables +in the supplied body, then 1*LAMBDA* will cause them to refer to the +global environment, not the current one. +We cannot in general simulate 1LAMBDA* by using 1*LAMBDA*, +because SCHEME (purposefully) does not provide a general way to get a representation +of the current environment. +We could, of course, require the user to give 1*LAMBDA* +a representation of the current environment, but this hardly +seems worthwhile. + + + +.in 0 + +.sp 3 + The following primitive functions allow for multiprocessing. +We do not pretend that they are "right" in any sense, and are not +particularly attached to these specific definitions. +They are not part of the kernel of SCHEME. +(Their primary use in practice is for bootstrapping SCHEME by creating +an initial process for the top-level user interface loop.) + There are no primitives for process synchronization, +as we have no good theory of how best to do this. +However, in the PDP-10 MacLISP implementation of SCHEME +we guarantee that SUBRs and LSUBRs execute in an uninterruptible +fashion; that is, such functions can be considered "atomic" +for synchronization purposes. The user is invited to exploit this +fact to invent his own synchronization primitives +{Note 1EVALUATE!UNINTERRUPTIBLY0 Has Disappeared}. + +.in 3 + +.sp 2 +.block 4 +.un 3 +1(CREATE!PROCESS proc)0 +.sp + This is the process generator for multiprocessing. +It takes one argument, a procedure of no arguments. +If the procedure ever terminates, the entire process +automatically terminates. The value of 1CREATE!PROCESS0 +is a process ID for the newly generated process. +Note that the newly created process will not actually +run until it is explicitly started. When started, +the procedure will be invoked (with no arguments), and the process will run +"in parallel" with all other active processes. + +.sp 2 +.block 4 +.un 3 +1(START!PROCESS procid)0 +.sp + This takes one argument, a process id, and +starts up or resumes that process, which then runs. + +.sp 2 +.block 4 +.un 3 +1(STOP!PROCESS procid)0 +.sp + This also takes a process id, but stops the +process. The stopped process may be continued from +where it was stopped by using 1START!PROCESS0 +again on it. The global variable 1**PROCESS**0 +always contains the process id of the currently running +process; thus a process can stop itself by doing +1(STOP!PROCESS **PROCESS**)0. + + +.sp 2 +.block 4 +.un 3 +1(TERMINATE)0 +.sp + This primitive stops and kills the process which invokes it. +The process may not be resumed by 1START!PROCESS0. +Some other process is selected to run. If the last process is +terminated, SCHEME automatically +prints a warning message, and then creates a new process +running the standard SCHEME "read-eval-print" +(actually "read4-0stick_1(LAMBDA_()_.)0_around4-0enclose_in_top-level_environment4-0invoke4-0print") +loop. + An example of the use of 1TERMINATE*: +.sp +.nofill +.spw 13 +1 (TERMINATE)* +.spw 16 +.adjust +.sp + +.in 0 + +.page + +.section +Notes +.sp + +.in 3 +{Note Notes Are in Alphabetical Order} + + +.sp 3 +.block 5 +.un 3 +{1ASET0 Has Disappeared} +.sp + The more general primitive 1ASET0 described in [SCHEME] +has been removed from the SCHEME language. +Although the case of a general evaluated expression +for the variable name causes no real semantic difficulty +(it can be viewed as a syntactic extension representing +a large 1CASE0 statement, as pointed out in [Declarative]), +it can be confusing to the reader. Moreover, in two +years we have not found a use for it. Therefore +we have replaced 1ASET0 with 1ASET'0, which requires the name of +the variable to be modified to appear manifestly. + We confess to being "cute" when we say that the name +of the primitive is 1ASET'0. We have not changed the implementation at all, +but merely require that the first argument be quoted. +The form 1(ASET' FOO BAR)0 is parsed by the MacLISP reader +as 1(ASET (QUOTE FOO) BAR)0. Of course, a different implementation of SCHEME +might actually take 1ASET'0 as a single name. +We apologize for this nonsense. + +.sp 3 +.block 5 +.un 3 +{1BLOCK0 Exploits Applicative Order} +.sp + The definition shown for 1BLOCK0 exploits the applicative order +of evaluation of SCHEME to perform this +{Note Normal Order Loses}. +It does not depend on left-to-right evaluation of arguments to functions! +Notice also that in +.sp +.nofill +.spw 13 +1 (BLOCK x . r) 41 ((LAMBDA (A B) (B)) x (LAMBDA () (BLOCK . r)))0 +.spw 16 +.adjust +.sp +there can be no conflict between the auxiliary +variables 1A0 and 1B0 and any variables occurring in 1x0 and 1r.0 +It is thus unnecessary to choose variables different from +any others appearing in the code. In this respect this definition +is an improvement over the one given in [Imperative]. +This trick (which is actually a deep property of the lexical +scoping rules) is used in a general way in most of the definitions +of syntactic extensions: one wraps all the "user code" +in lambda-expressions in the outer environment, +passes them in bound to internal names, and +then invokes them as necessary +within the internal code for the definition. + + +.sp 3 +.block 5 +.un 3 +{Environment Symmetry} +.sp + One may think of an escape object as being "closed" +with respect to a dynamic environment (and here we mean not only fluid +variables but the chain of pending procedure calls) +in much the same way that an ordinary procedure is closed +with respect to a lexical environment. Just as a procedure +cannot execute properly except in conjunction with a static environment +of the appropriate form, so an escape object cannot properly +resume control except in a dynamic environment of the appropriate form. + +.sp 3 +.block 5 +.un 3 +{1EVALUATE0 Has Disappeared} +.sp + The 1EVALUATE0 primitive described in [SCHEME] has +been removed from the language. We discovered (the hard way) +that the straightforward implementation of 1EVALUATE0 +(evaluate the given expression in the current environment) +destroys referential transparency. +We then altered it to evaluate the expression in the top-level +environment, but were still disturbed by the extent to +which one is tied to a particular representation of a +procedure to be executed. + We eventually invented an 1ENCLOSE0 +of one argument (a lambda-expression), which enclosed +the procedure in the top-level environment. +This allowed one to remove the dependence on representation +by making a procedure, and then to pass the procedure around +for a while before invoking it. +We had no provision for closing in an arbitrary environment, +because we did not want to provide the user with direct +access to environments as data objects. +The excellent idea of allowing 1ENCLOSE0 to accept a +representation of an environment was suggested to us +by R. M. Fano. + +.sp 3 +.block 5 +.un 3 +{1EVALUATE!UNINTERRUPTIBLY0 Has Disappeared} +.sp + The 1EVALUATE!UNINTERRUPTIBLY0 primitive described in [SCHEME] +has been removed from the language. This primitive was +half a joke, and we have since discovered that it had a serious +flaw in its definition, namely that the scope of the uninterruptibility +is lexical. This worked in our limited examples only by virtue of the +fact that SUBRs were atomic operations. In general, +this primitive is worse than useless for synchronization purposes. +Synchronization is clearly a dynamic and not a static phenomenon. +We have no good theory of synchronization (primitives for this +were included in [SCHEME] primarily to show that it could be done, +however kludgily), and so have defined no replacement for +1EVALUATE!UNINTERRUPTIBLY0. +We apologize for any confusion this mistake may have caused. + +.sp 3 +.block 5 +.un 3 +{FEXPRs Are Okay by Us} +.sp + While the syntactic extensions are defined in terms of other +constructs, they need not be implemented in terms of them. +For example, in the current PDP-10 MacLISP implementation of SCHEME, +1BLOCK0 is actually implemented in the same way 1IF0 and 1QUOTE0 +are, rather than as a macro in terms of 1LAMBDA0. +This was done purely to speed up the interpreter. +The compiler still uses the macro definition (though we could change that too +if warranted). The point is that the user doesn't have to know about all this. + It is somewhat an accident that magic forms look like procedure calls +(see also {Note 1FUNCALL0 is a Pain}): a name appearing in the car of a list +may represent either a procedure or a magic word, but not both. +(We could, for example, say that magic forms are distinguished +by a magic word in the cadr of a list, thus allowing forms +such as 1(FOO := (+ FOO 1))0, where 1:=0 is a magic word for assignment. +PLASMA [Smith and Hewitt] +allowed just this ability with its "italics" or "reserved word" feature.) +Thanks to this accident many LISP interpreters store the magic function definition +in the place where an ordinary procedure definition is stored. +A special marker (traditionally EXPR/SUBR or FEXPR/FSUBR) distinguishes +ordinary functions from magic ones. +This allows the lookup for a magic word definition and an ordinary value +to be simultaneous, thus speeding up the implementation; it is purely +an engineering trick and not a semantic essence. +However, this trick has led to a generalization wherein 1QUOTE* and 1COND* are regarded as +functions on an equal basis with 1CAR* and 1CONS*; to be sure, they take their arguments +in a funny way 4-0 unevaluated 4-0 but they are still regarded as functions. +This leads to all manner of confusion, which has its roots in +a confusion between a procedure and its representation. + It is helpful to consider a simple thought experiment. +Let us postulate a toy language called "Number-LISP". +Programs in this language are written as s-expressions, as usual; +the kernel primitives 1LAMBDA0, 1IF0, 1LABELS0, etc. are all present. +However, the primitive functions 1CONS0, 1CAR0, and 1CDR0 are absent; +one has only 1+0, 1-0, 1*0, 1//0, and 1=0. +1QUOTE0 is not available; the only constants one can write are numbers. + Now Number-LISP can be used to perform all kinds of +arithmetic, but it is clearly a poor language in which to write +a LISP interpreter. Now consider the magic form processors +and syntactic extension +functions for Number-LISP. They are procedures on s-expressions +or functions from s-expressions +to s-expressions which transform one form into another. +Whatever processes 1IF0 or 1LABELS0 or 1BLOCK* is clearly not a Number-LISP +procedure, because it must deal with the text +of a Number-LISP procedure, not just the data to be operated on by that procedure. +The 1IF0-processor (a "FEXPR") for Number-LISP must be coded in the meta-language +for Number-LISP, whatever that may be. + Now it is one of the great features of ordinary LISP +that it can serve as its own meta-language. This provides great power, +but also permits great confusion. If the implementation allows +mixing of levels of definition, we must keep them separate in our minds. +For this reason we don't mind using the "FEXPR hack" to +implement syntactic forms, but we do mind thinking of them +as functions just like EXPRs. + + +.sp 3 +.block 5 +.un 3 +{1FUNCALL0 is a Pain} +.sp + The ambiguity between magic forms and combinations +could be eliminated by reserving a special subclass +of lists to represent combinations, and allowing all others +to represent magic forms. For example, we might say that +all lists beginning with the atom 1CALL0 are combinations. +Then we would write 1(CALL CONS A B)0 rather than 1(CONS A B)0. +One could then have a procedure named 1LAMBDA0, for example; +there could be no confusion between 1(LAMBDA (A) (B A))0 +and 1(CALL LAMBDA (CALL A) (CALL B A))0, as there would be +between 1(LAMBDA (A) (B A))0 as a combination and as a magic form +denoting a procedure. +Notice that 1CALL0 is intended to be +merely a syntactic marker, like 1LAMBDA0 or 1IF0, +and not a function as 1FUNCALL0 is in MacLISP [Moon]. + If this 1CALL0 convention were adopted, there could be no +confusion between combinations and other kinds of forms. +Not all expressions would have meaningful interpretations; +for example 1(FOO A B)0 would not mean anything (certainly +not a call to the function 1FOO0, which would be written +as 1(CALL FOO A B)0). The space of meaningful s-expressions +would be a very sparse subset of all s-expressions, +rather than a dense one. +It would also make writing SCHEME code very clumsy. +(These two facts are of course correlated.) +Combinations occur about as often as all other non-atomic forms put together; +we would like to write as little as possible to denote a call. +As in traditional LISP, we agree to tolerate the ambiguity +in SCHEME as the price of notational convenience. +Indeed, this ambiguity is sometimes exploited; it is convenient +not to have to know whether 1AMAPCAR0 is a function or a magic word. + This compromise does lead to difficulties, however. +For example, we had wanted to define an iteration feature: +.sp +.nofill +.spw 13 +1 (LOOP name varspecs body)0 +.spw 16 +.adjust +.sp +Unfortunately, there is a great deal of existing code written in +SCHEME of the form: +.sp +.nofill +.spw 13 +.block 2 + 1(LABELS ((LOOP (LAMBDA ... (LOOP ...) ...))) + (LOOP ...))0 +.spw 16 +.adjust +.sp +because 1LOOP0 has become a standard name for use in a 1LABELS0 +procedure which implements an iteration (see, for example, +our definition of 1DO0!). If 1LOOP0 +were to become a new magic word, then all this existing code +would no longer work. We were therefore forced to name it 1ITERATE* instead +(after verifying that no existing code used the name 1ITERATE* for another purpose!). +There would have been no problem if +all this code had been written as: +.sp +.nofill +.spw 13 +.block 2 + 1(LABELS ((LOOP (LAMBDA ... (CALL LOOP ...) ...))) + (CALL LOOP ...))0 +.spw 16 +.adjust +.sp +To this extent SCHEME has unfortunately, despite our best intentions, +inherited a certain amount of referential opacity. + +.sp 3 +.block 5 +.un 3 +{Global Fluid Environment} +.sp + There is a question as to the meaning of the global fluid environment. +In the PDP-10 MacLISP implementation of SCHEME, the global lexical +and fluid environments coincide, but this was an arbitrary choice of +convenience influenced by the structure of MacLISP. +We recommend that the two global environments be kept distinct. + +.sp 3 +.block 5 +.un 3 +{1IF* Is Data-Dependent} +.sp + We should note that the usefulness of the definition of 1IF* +explicitly depends on the particular kinds of data types and the +particular primitive functions available; we expect to use 1IF* +with primitive predicates such as 1ATOM0 and 1EQ0. +This is in contrast to other kernel forms such as 1LAMBDA* and 1LABELS0 +expressions, whose semantics are independent of the data. + We erred in [SCHEME] when we stated that a practical +interpreter must have a little of each of call-by-value and call-by-name +in it. The argument was roughly that a call-by-name interpreter +must become call-by-value when a primitive operator is to be +applied, and a call-by-value interpreter must have some +primitive conditional such as 1IF*. +We did mention the trick of eliminating 1IF* in a call-by-name interpreter +by defining predicates to return 1(LAMBDA_(X_Y)_X)* for TRUE +and 1(LAMBDA_(X_Y)_Y)* for FALSE, whereupon +one typically writes: +.sp +.nofill +.spw 13 + 1((= A B) )* +.spw 16 +.adjust +.sp +but noted that it depends +critically on the use of normal order evaluation. + What we had not fully understood at that point was the trick of +simulating call-by-name in terms of call-by-value +by using lambda-expressions +(our use of it in the TRY!TWO!THINGS!IN!PARALLEL example notwithstanding!); +this trick was described generally in [Imperative]. A special case of this trick +is to define the primitive predicates in a call-by-value interpreter +to return 1(LAMBDA_(X_Y)_(X))* for TRUE and 1(LAMBDA_(X_Y)_(Y))* +for FALSE. +Then one can write things like: +.sp +.nofill +.spw 13 +.block 3 + 1((= A B) + (LAMBDA () ) + (LAMBDA () ))* +.spw 16 +.adjust +.sp +and so eliminate a call-by-name-like magic form such as 1IF*. +One can make the dependence of the conditional +on the primitive data operations even more explicit by defining predicates +not to return any particular value, but to require two "continuations" +as arguments, of which it will invoke one: +.sp +.nofill +.spw 13 +.block 3 + 1(= A B + (LAMBDA () ) + (LAMBDA () ))* +.spw 16 +.adjust +.sp +We were correct when we said that a practical interpreter must have call-by-name +to some extent in that there must be some way to designate +two pieces of as yet uninterpreted program text of which +only one is to be evaluated. We simply did not notice +that 1LAMBDA* provides this ability, and so a separate +primitive such as 1IF0 is not necessary. +We have chosen to retain 1IF0 in the language because +it is traditional, because its implementation is easy to +understand, and because it allows us to take advantage of +many existing predicates in the host language in the PDP-10 MacLISP +implementation. + +.sp 3 +.block 6 +.un 3 +{LISP BNF} +.sp + These rules refer to the following rules for LISP s-expressions: +.sp +.nofill +.spw 13 +1 ::= +.block 2 + ::= | + ::= | | / + ::= A | B | ... | Y | Z | * | $ | % | ... + ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 + ::= +.block 3 + ::= " " + ::= | + ::= | / 0 +.spw 16 +.adjust +.sp +(In the PDP-10 MacLISP implementation of SCHEME, we use the " character +for another purpose because PDP-10 MacLISP does not have a string data type. +We mention strings only as a familiar example other than numbers +of an atomic data type other than identifiers.) + In addition, we assume the usual interchangeability of list notation and +dot notation for s-expressions: 1(A_B_C) = (A_._(B_._(C_._NIL)))0. +Thus the pattern 1(_ . _)0 may match +the list 1(COND (A_B) (T_C))0. It is the s-expression representation +we care about, not particular character strings. + + +.sp 3 +.block 5 +.un 3 +{LISP Is a Ball of Mud} +.sp + LISP is extensible in two ways. First, there is the simple +ability to define new functions; these are used in a way that is +both syntactically and semantically identical to built-in primitive functions +like 1CAR0. This is in contrast to "algebraic" programming languages, +which either make an arbitrary syntactic distinction between addition, say, +and a user function, or wander into the quagmire of extensible parsers. +Second, there is a uniform macro facility for transforming one syntactic form +into another; this facility is based on internal data structures rather than +external character-string syntax. + Joel Moses (private communication) once made some remarks on the difference +between LISP and APL, which we paraphrase here: +"APL is like a diamond. It has a beautiful crystal structure; all of its parts +are related in a uniform and elegant way. But if you try to extend this structure +in any way 4-0 even by adding another diamond 4-0 you get an ugly kludge. +LISP, on the other hand, is like a ball of mud. You can add any amount of +mud to it (e.g. MICRO-PLANNER or CONNIVER) and it still looks like a ball of mud!" + + +.sp 3 +.block 5 +.un 3 +{Multiple Throw} +.sp + A full implementation of SCHEME allows this to work even if +the CATCH has already been "returned from"; that is, the escape object can be used +to "return from the catch" several times. However, we allow the possibility +that an implementation may allow +the escape object to be invoked only from within the execution of the form +inside the catch. (This is essentially the restriction that MacLISP +makes on its 1CATCH0 construct [Moon].) +This restriction permits a stack discipline for the allocation +of continuations, and also greatly simplifies the flow analysis +problem for a compiler [RABBIT]. + +.sp 3 +.block 5 +.un 3 +{Normal Order Loses} +.sp + Our definition of 1BLOCK0 exploits the fact that SCHEME +is an applicative-order (call-by-value) language in order to enforce +sequencing. Sussman has proved that one cannot do a similar thing +in a normal-order (call-by-name) language: +.sp +.block 4 +.in 11 +.un 4 +Theorem: Normal order, as such, is incapable of +enforcing sequencing (whereas applicative order is) +in the form of the 1BLOCK0 construct. +.un 4 +(Informal) proof: The essence of 1(BLOCK_a_b)0 is that 1a0 is evaluated before +1b0, and that the value of 1b0 is the value of the 1BLOCK0 (or, more +correctly, the value or meaning of the 1BLOCK0 is independent of 1a0; +1a0 is executed only for its side effects). +Now we know that if 1(BLOCK_a_b)0 has any value at all, +it can be found by using normal order (normal order terminates +if any order does). Now suppose that the computation of 1a0 +does not terminate, but the computation of 1b0 does. +Then 1(BLOCK_a_b)0 must terminate under normal order, +because the value of the block is the value of 1b0; +but this contradicts the requirement that 1a0 finish before +1b0 is calculated. QED +.sp +.in 3 +This is an informal indication that normal order is less useful +(or at least less powerful) +in a programming language than applicative order. +We also noted in [SCHEME] that normal order iterations +tend to consume more space that applicative order iterations, +because of the buildup of thunk structure. +Given that one can simulate normal order in applicative order by +explicitly creating closures [Imperative], there seems to be little +to recommend normal order over applicative order in a practical +programming language. + +.sp 3 +.block 5 +.un 3 +{Notes Are in Alphabetical Order} +.sp + The notes are ordered alphabetically by name, not in order of reference +within the text. + +.sp 3 +.block 5 +.un 3 +{S-expressions Are Not Functions} +.sp + Recall that a lambda-expression (i.e. an s-expression +whose car is the atomic symbol 1LAMBDA0) is not itself a valid +procedure. It is necessary to 1ENCLOSE0 it in order to invoke it. + Moreover, the particular representations we have chosen +for procedures and environments are arbitrary. +In principle, one could have several kinds of ENCLOSE, each +transforming instances of a particular representation into procedures. +For example, someone might actually want to implement +a primitive 1ALGOL-ENCLOSE0, taking a string and a 2-by-N array +representing code and environment for an ALGOL procedure: +.sp +.nofill +.spw 13 +.block 4 + 1(ALGOL-ENCLOSE "integer procedure fact(n); value n; integer n; + fact := if n=0 then 1 else n*fact(n-1)" + NULL-ARRAY)0 +.spw 16 +.adjust +.sp +This could return a factorial function completely acceptable to SCHEME. +Of course, the implementation of the primitive 1ALGOL-ENCLOSE0 +would have to know about the internal representations of procedures +used by the implementation of SCHEME; but this is hidden from the user. + Similarly, one could have 1APL-ENCLOSE0, 1BASIC-ENCLOSE0, +1COBOL-ENCLOSE0, 1FORTRAN-ENCLOSE0, 1RPG-ENCLOSE0 ... + +.sp 3 +.block 5 +.un 3 +{Tail-Recursive 1AND0} +.sp + The definition of 1AND0 has three rules, +not only for the same reasons 1OR0 does, but because +1AND0 is not a precise dual to 1OR0. 1OR0, on failure, +returns 1NIL0, but 1AND0 does not just return non-1NIL0 +on success. It must return the non-1NIL0 thing +returned by its last form. + + +.sp 3 +.block 5 +.un 3 +{Tail-Recursive 1OR0} +.sp + We might have defined 1OR0 with only two rules: +.sp +.nofill +.spw 13 +1 (OR) 41 'NIL + (OR x . r) 41 (COND (x) (T (OR . r)))0 +.spw 16 +.adjust +.sp +However, because of the way 1OR0 is sometimes used, +it is a technical convenience to be able +to guarantee to the user that the last form +in an 1OR0 is evaluated without an extra "stack frame"; +that is, a function called as the last form in an +1OR0 will be invoked tail-recursively. +For example: +.sp +.nofill +.spw 13 +1 (DEFINE NOT-ALL-NIL-P + (LAMBDA (X) + (LABELS ((LOOP + (LAMBDA (Z) + (OR (CAR Z) (LOOP (CDR Z)))))) + (LOOP X))))0 +.spw 16 +.adjust +.sp +executes iteratively in SCHEME, but would not execute +iteratively if the two-rule definition of 1OR0 were used. + +.sp 3 +.block 5 +.un 3 +{What Use Is It?} +.sp + We should perhaps say instead that 10 is treated the same +as 1(STATIC )0. The 1STATIC0 construction is included in SCHEME +primarily for pedagogical purposes, to provide symmetry to 1(FLUID )0. +The fact that lone atomic symbols are interpreted as lexical variables +rather than dynamic ones is in some sense arbitrary. +Some critics of SCHEME [personal communications] have expressed a certain horror that +there are two kinds of variables, perhaps imagining some confusion in +the interpretation of simple identifiers. +We can have as many kinds of variables as we like (though we have so +far discovered only two kinds of any great use), as long as we +can distinguish them. In SCHEME we distinguish them with +a special marker, such as 1STATIC0 or 1FLUID0; then, as a convenience, +we prescribe that simple atomic symbols, not marked by such a keyword, +shall also be interpreted as lexical variables, because that is the kind +we use most often in SCHEME. We could as easily have defined simple +symbols to be interpreted as fluid variables, or for that matter +as constants (as numbers and strings are). We could also have prescribed +a different method of distinguishing types, e.g. "all variables +beginning with I, J, K, L, M, or N shall be fluid". +(This is not as silly as it sounds. A fairly wide-spread LISP convention +is to spell global variables with leading and trailing 1**, +as in 1*FOO**, and some programmers have wished that the compiler +would automatically treat variables so spelled as SPECIAL.) +Indeed, given the read-macro-character facility, we effectively have +the syntactic rule "all variables beginning with 10 shall be fluid". +We have settled on the current definition of SCHEME as being the +most convenient both to implement and to use. + Compare the use of syntactic markers and read-macro-characters +to the constructions 10 = 1,X =0 "global value of 1X0" +and 10 = 1.X =0 "local value of 1X0" +in MUDDLE [Galley and Pfister]. Indeed, in MUDDLE +a simple atomic symbol is regarded as a constant, not as an identifier. + All this suggests another solution to the problem +posed in {Note 1FUNCALL0 is a Pain} (the confusion of magic forms +with combinations). The real problem is distinguishing a magic word +from a variable. Let us abbreviate 1(STATIC_FOO)0 to 1FOO0, +just as 1(FLUID_FOO)0 can be abbreviated as 1FOO0. +Then 1(LOOP_A_B)0 would have to be a call on the function 1LOOP0, +and not a magic form. Similarly, we could write 1(MAGICWORD COND)0 +instead of 1COND0, and invent an abbreviation for that too. +This all raises as many problems as it solves by becoming too clumsy; +but then again, maybe it isn't asking too much to require the user to write +all magic words in boldface (as in the ALGOL reference language) or in italics +(as in an early version of PLASMA [Smith and Hewitt])... + +.in 0 + + + +.sp 4 +.block 6 +.section +Acknowledgements +.sp + Comments by Carl Hewitt and Berthold Horn were of considerable value +in preparing this paper. Ed Barton (who is also helping to maintain the +PDP-10 MacLISP SCHEME implementation) made important contributions +to the revisions of the language definition. + + +.page + +.section +References +.sp 2 +.in 8 + +.block 4 +.un 8 +[Declarative] +.br +Steele, Guy Lewis Jr. +LAMBDA: The Ultimate Declarative. +AI Memo 379. MIT AI Lab (Cambridge, November 1976). +.sp +.block 4 +.un 8 +[Galley and Pfister] +.br +Galley, S.W. and Pfister, Greg. +The MDL Language. +Programming Technology Division Document SYS.11.01. +Project MAC, MIT (Cambridge, November 1975). +.sp +.block 4 +.un 8 +[Hewitt] +.br +Hewitt, Carl. +"Viewing Control Structures as Patterns of Passing Messages." +AI Journal 8, 3 (June 1977), 323-364. +.sp +.block 4 +.un 8 +[Imperative] +.br +Steele, Guy Lewis Jr., and Sussman, Gerald Jay. +LAMBDA: The Ultimate Imperative. +AI Memo 353. MIT AI Lab (Cambridge, March 1976). +.sp +.block 4 +.un 8 +[Landin] +.br +Landin, Peter J. +"A Correspondence between ALGOL 60 and Church's Lambda-Notation." +Comm. ACM 8, 2-3 (February and March 1965). +.sp +.block 4 +.un 8 +[McDermott and Sussman] +.br +McDermott, Drew V. and Sussman, Gerald Jay. +The CONNIVER Reference Manual. +AI Memo 295a. MIT AI Lab (Cambridge, January 1974). +.sp +.block 4 +.un 8 +[Moon] +.br +Moon, David A. +MacLISP Reference Manual, Revision 0. +Project MAC, MIT (Cambridge, April 1974). +.sp +.block 4 +.un 8 +[Moses] +.br +Moses, Joel. +The Function of FUNCTION in LISP. +AI Memo 199, MIT AI Lab (Cambridge, June 1970). +.sp +.block 4 +.un 8 +[Naur] +.br +Naur, Peter (ed.), et al. +"Revised Report on the Algorithmic Language ALGOL 60." +Comm. ACM 6, 1 (January 1963), 1-20. +.sp +.block 4 +.un 8 +[RABBIT] +.br +Steele, Guy Lewis Jr. +Compiler Optimization Based on Viewing LAMBDA as Rename plus Goto. +S.M. thesis. MIT (Cambridge, May 1977). +.sp +.block 4 +.un 8 +[Reynolds] +.br +Reynolds, John C. +"Definitional Interpreters for Higher Order Programming Languages." +ACM Conference Proceedings 1972. +.sp +.block 4 +.un 8 +[SCHEME] +.br +Sussman, Gerald Jay, and Steele, Guy Lewis Jr. +SCHEME: An Interpreter for Extended Lambda Calculus. +AI Memo 349. MIT AI Lab (Cambridge, December 1975). +.sp +.block 4 +.un 8 +[Smith and Hewitt] +.br +Smith, Brian C. and Hewitt, Carl. +A PLASMA Primer (draft). +MIT AI Lab (Cambridge, October 1975). +.in 0 diff --git a/doc/scheme/meta.43 b/doc/scheme/meta.43 new file mode 100755 index 00000000..e7c8b67d --- /dev/null +++ b/doc/scheme/meta.43 @@ -0,0 +1,1809 @@ +.vsp 8 +.squish +.c j 2sgronk <:s-bcode; .nofill 15.i 12.i ! +.c ! i.select 1 15.i 12.i ! +.c ! i.spw 13 15.i 12.i ! +.c ! i.block  .( 0u8 ! +.c ! :k i.spw 16 15.i 12.i ! +.c ! i.select 0 15.i 12.i ! +.c ! i.adjust 15.i 12.i ! +.c ! i.sp )j q8\> !gronk! +.c << text font >> +.font 0 25fr1 +.c << SCHEME font >> +.font 1 22fg +.c << heading fonts >> +.font 2 30vrb +.font 4 gls;foo1 +.ulfont 5 +.quote  +.dummy _ +.twinch 6.25 +.tlinch 9 +.sidm 53 +.c << want to flush losing multiple cr's >> +.crcomp +.c << want to make leading spaces on line small >> +.spw 16 +.c << want to have at least 3 lines of a section on a page >> +.sblock 5 +.adjust +.center +2MASSACHUSETTS INSTITUTE OF TECHNOLOGY +.CENTER +ARTIFICIAL INTELLIGENCE LABORATORY +.sp 2 +.spread +/0AI Memo No. 453//December 1977 +.sp 2 +.center +2Some Little Interpreters for LISP-Like Languages +.sp +.center +or, The Art of the Interpreter +.sp 2 +.center +0by +.sp +.center +Guy Lewis Steele Jr. * and Gerald Jay Sussman +.sp 2 +0Abstract: +.sp + + +.sp 2 +.in 10 +.un 10 +Keywords:__LISP, SCHEME, LISP-like languages, +lambda-calculus, lexical scoping, dynamic scoping, +fluid variables, control structures, environments +.in 0 + +.sp 2 +This report describes research done at the Artificial Intelligence +Laboratory of the Massachusetts Institute of Technology. +Support for the laboratory's artificial intelligence research +is provided in part by the Advanced Research Projects Agency +of the Department of Defense under Office of Naval Research contract N00014-75-C-0643. +.sp +*__NSF Fellow + +.page +.spage +.php1 +.he1 +1Steele and Sussman  +.he2 +1Some Little Interpreters0 + + +.nofill +.crreta +What we got here: + +REVAL 0 1 7 recursion equation interpreter - no LAMBDA + +Environments +TEVAL 0 1 7 +FEVAL 1 3 7 has fluids +FEVAL1 has fluids, no funargs +FEVAL2 0 1 3 7 has lexicals AND fluids + +Normal Order +NEVAL 0 2 7 normal order +NFEVAL normal w/lexical and fluid + +Neat things you can do by hacking LOOKUP + Shallow vs. deep? Property of lookup only. + Call-by-need + +Neat ways to do PRIMOP/DEFINE + +CPSEVAL 0 1 7 9 cps-style primitives + meta-circular + lifted + +Additional magic forms +FOOEVAL FEVAL2 with ASETQ, FLUIDSETQ, and LABELS +SEVAL 0 1 4 6 has extensible syntax (dispatched syntax lookup) +BSEVAL 0 1 4 5 6 bound syntaxfns (??) + +SCHEVAL 0 1 3 4 6 8 the quintessential language + + + +0. lexicals +1. applicative order +2. normal order +3. fluids +4. extra syntax +5. bound syntax +6. global environment +7. wired-in primops +8. has CATCH +9. CPS +.crcomp +.adjust + + + +.page + +.section +@.__General Structure of Interpreters for LISP-Like Languages +.sp + The core of a LISP interpreter +is the two procedures 1EVAL* and 1APPLY*. +1EVAL* interprets an expression relative to a given environment. + + + + + + +.page + + + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (BIND VARS ARGS ENV) + (COND ((= (LENGTH VARS) (LENGTH ARGS)) + (CONS (CONS VARS ARGS) ENV)) + (T (ERROR '|WRONG NUMBER OF ARGUMENTS| (LIST VARS ARGS))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (VALUE NAME ENV) + (VALUE1 NAME (LOOKUP NAME ENV))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 4 +(DEFINE (VALUE1 NAME SLOT) + (COND ((EQ SLOT '&UNBOUND) + (ERROR '|CAN'T REFERENCE UNBOUND VARIABLE| NAME)) + (T (CAR SLOT)))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 3 +(DEFINE (LOOKUP NAME ENV) + (COND ((NULL ENV) '&UNBOUND) + (T (LOOKUP1 NAME (CAAR ENV) (CDAR ENV) (CDR ENV))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 6 +(DEFINE (LOOKUP1 NAME VARS VALS REST) + (COND ((NULL VARS) + (LOOKUP NAME REST)) + ((EQ NAME (CAR VARS)) + VALS) + (T (LOOKUP1 NAME (CDR VARS) (CDR VALS) REST)))) +.spw 16 +.select 0 +.adjust +.sp + +.page + + +.section +A.__REQ:__A Complete Metacircular Interpreter for Recursion Equations +.sp + The language interpreted by REQ is a dialect of LISP +which allows no free variables except for names of primitive +or defined procedures, and no definitions of procedures +within other procedures. +This universal language is essentially that of +Kleene recursion equations {ref}. + The driver loop reads in definitions of +procedures of the abstract form: +.sp +.nofill + f(a,b,c,...) = +.adjust +.sp +and saves them. It can also read in requests to +apply some defined procedure to some arguments +(or, more generally, to evaluate any expression, +which may refer to defined functions, but need not, +for example a request to see the value of a variable), +in which case it prints the resulting value. +The defined procedures may refer to each other +and to initially supplied primitive procedures +(such as 1CAR*, 1CONS*, etc.). +Definitions may contain "forward references", +as long as all necessary definitions are +present at the time of a request for a computation. + Definitions are written as LISP s-expressions +in the form: +.sp +.nofill +.select 1 +.spw 13 +.block 1 + (DEFINE (F A B C ...) ) +.spw 16 +.select 0 +.adjust +.sp +An expression may consist of variable references, +constants (numbers and quoted s-expressions), +procedure calls, and conditional expressions (1COND*). +The interpreter is presented here as a set of such definitions, +and so is meta-circular {ref}. + The language processed by REQ is intended to be evaluated in applicative +order; that is, all arguments to a function are fully evaluated +before an attempt is made to apply the function to the arguments. +(It is necessary to state this explicitly here, as it is not inherent +in the form of the meta-circular definition. See [Reynolds] +for an explication of this problem.) + The driver loop is conceptually started by a request +to invoke 1DRIVER* with no arguments. The expression +1* is intended to represent +a constant list structure containing definitions +of primitive functions. + Note carefully the use of the variable 1TOPENV*. +When 1DRIVER-LOOP-1* calls 1EVAL* it passes as both 1ENV* +and 1TOPENV* the current top-level environment, +which contains definitions of all primitive functions +and all functions defined so far by the user. +1TOPENV* is passed around by 1EVAL* and 1APPLY*, +and is used only in 1APPLY*. The bodies of user functions +are evaluated in an environment consisting of 1TOPENV* +plus the formal parameters of the function bound to the +respective arguments. Thus, the only variables visible +to the body of a function are its formal parameters +plus the global function definitions, with the former having priority. +We shall have occasion to refer to this situation later. + + + + +.sp + + + + + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (DRIVER) + (DRIVER-LOOP (PRINT '|LITHP ITH LITHTENING|))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (DRIVER-LOOP TOPENV HUNOZ) + (DRIVER-LOOP-1 TOPENV (READ))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 9 +(DEFINE (DRIVER-LOOP-1 TOPENV FORM) + (COND ((ATOM FORM) + (DRIVER-LOOP TOPENV (PRINT (EVAL FORM TOPENV TOPENV)))) + ((EQ (CAR FORM) 'DEFINE) + (DRIVER-LOOP (BIND (LIST (CAADR FORM)) + (LIST (LIST '&FUNCTION (CDADR FORM) (CADDR FORM))) + TOPENV) + (PRINT (CAADR FORM)))) + (T (DRIVER-LOOP TOPENV (PRINT (EVAL FORM TOPENV TOPENV)))))) +.spw 16 +.select 0 +.adjust +.sp + +.c REVAL - recursion equations interpreter + +.nofill +.select 1 +.spw 13 +.block 11 +(DEFINE (EVAL EXP ENV TOPENV) + (COND ((ATOM EXP) + (COND ((NUMBERP EXP) EXP) + (T (VALUE EXP ENV)))) + ((EQ (CAR EXP) 'QUOTE) + (CADR EXP)) + ((EQ (CAR EXP) 'COND) + (EVCOND (CDR EXP) ENV TOPENV)) + (T (APPLY (EVAL (CAR EXP) ENV TOPENV) + (EVLIS (CDR EXP) ENV TOPENV) + TOPENV)))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 7 +(DEFINE (APPLY FUN ARGS TOPENV) + (COND ((PRIMOP FUN) (PRIMOP-APPLY FUN ARGS)) + ((EQ (CAR FUN) '&FUNCTION) + (EVAL (CADADR FUN) + (BIND (CAADR FUN) ARGS TOPENV) + TOPENV)) + (T (ERROR '|UNKNOWN FUNCTION| (LIST FUN ARGS))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 5 +(DEFINE (EVCOND CLAUSES ENV TOPENV) + (COND ((NULL CLAUSES) NIL) + ((EVAL (CAAR CLAUSES) ENV TOPENV) + (EVAL (CADAR CLAUSES) ENV TOPENV)) + (T (EVCOND (CDR CLAUSES) ENV TOPENV)))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 4 +(DEFINE (EVLIS ARGLIST ENV TOPENV) + (COND ((NULL ARGLIST) NIL) + (T (CONS (EVAL (CAR ARGLIST) ENV TOPENV) + (EVLIS (CDR ARGLIST) ENV TOPENV))))) +.spw 16 +.select 0 +.adjust +.sp + + +{topenv is the gritch that probably caused fluids to get invented in the first place} + + + +.page + + +.section +B.__REQVC:__A Metacircular Interpreter for Recursion Equations Using Value Cells +.sp + The definition of REQ is conceptually clean +in that (except for 1READ* and 1PRINT*) no side +effects are necessary in its operation. +The top level driver loop iterates, reading in expressions, +and on seeing a 1DEFINE*-form augments the top-level +environment simply by adding a new binding to it. + One consequence of this, however, is that +less recent bindings get pushed farther and farther down, +and so become more and more expensive to access. +One would like to be able to access function definitions +quickly, because they are used all the time. +One needs a way to access a variable binding in constant +time given the atomic symbol representing that variable. + The solution adopted in most LISP systems +is to regard atomic symbols as data structures having +accessible components. (Given this view, they are +no longer conceptually "atomic" or indivisible!) +Typical components are the "property list" and "value cell". +We shall assume that there are two primitive procedures +which our interpreter can use. 1(GETVC )* +will deliver as its value the contents of the value cell +of the specified atomic symbol. 1(SETVC )* +will put the given s-expression in the value cell of the given +symbol (a side effect!). + We can then define the top-level environment +to be those values which are in the value cells of the +atomic symbols. We assume that the symbols representing +primitive procedures initially have those procedures in their value +cells, and that all other symbols initially have 1&UNBOUND* +in their value cells. + We will use 1SETVC* only in a controlled +way, by redefining some of our utility and driver +routines. + +.sp + +.nofill +.select 1 +.spw 13 +.block 4 +(DEFINE (VALUE1 NAME SLOT) + (COND ((EQ SLOT '&UNBOUND) + (COND ((EQ (GETVC NAME) '&UNBOUND) + (ERROR '|CAN'T REFERENCE UNBOUND VARIABLE| NAME)) + (T (GETVC NAME)))) + (T (CAR SLOT)))) +.spw 16 +.select 0 +.adjust +.sp + + We arrange for 1NIL* to represent the top-level +environment by changing 1VALUE1* to check the value +cell of a symbol if 1LOOKUP* cannot find a value for it. +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (DRIVER) + (DRIVER-LOOP NIL (PRINT '|LITHP ITH LITHTENING|))) +.spw 16 +.select 0 +.adjust +.sp + + The top-level environment resides in the global state +of all the value cells, and so we do not represent it explicitly +in our recursion equations. + +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (DRIVER-LOOP HUNOZ HUKAIRZ) + (DRIVER-LOOP-1 (READ))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 9 +(DEFINE (DRIVER-LOOP-1 TOPENV FORM) + (COND ((ATOM FORM) + (DRIVER-LOOP TOPENV (PRINT (EVAL FORM TOPENV TOPENV)))) + ((EQ (CAR FORM) 'DEFINE) + (DRIVER-LOOP (SETVC (CAADR FORM) + (LIST '&FUNCTION (CDADR FORM) (CADDR FORM))) + (PRINT (CAADR FORM)))) + (T (DRIVER-LOOP TOPENV (PRINT (EVAL FORM TOPENV TOPENV)))))) +.spw 16 +.select 0 +.adjust +.sp + When a 1DEFINE*-form is encountered, +we use 1SETVC* to install the new definition +in the value cell of the symbol which represents the name +of the defined procedure. + + + + + + +.page +.section +C.__LEX with Bug:__An Incorrect Interpreter for Lexically Scoped LISP +.sp + + The interpreter LEX (and all following interpreters, until +further notice), are written as recursion equations suitable +for interpretation by REQ (or REQVC). Thus these interpreters are +not necessarily meta-circular (though they may be if +the language they interpret is only an extension of REQ's). +For example, if the whole of LEX were read into REQ and then +the form 1(DRIVER)* were read in, one would then be +able to read in definitions in the LEX language (running +by two levels of interpretation: REQ interpreting LEX +interpreting whatever followed). + The dialect of LISP interpreted by LEX allows +the free use of functional arguments. An expression of the form +.sp +.nofill +.select 1 +.spw 13 +.block 1 + 1(LAMBDA (A B C ...) ) +.spw 16 +.select 0 +.adjust +.sp +evaluates to a function, which may then be used as if +it had been given a name 1F* by a definition +1(DEFINE_(F_...)_...)* and then the name 1F* were referred to. +However, if any free variable reference appears in the body of the +1LAMBDA*-expression, and there is a binding of that variable +in some other 1LAMBDA*-expression (or 1DEFINE*-form) which +lexically contains it, then the variable reference is construed to +refer to the innermost (nearest) such surrounding binding of that +variable. Thus, variables in this language are scoped as in ALGOL [Naur]. +The 1LAMBDA*-expressions in this language are intended +to reflect the behavior of lambda-calculus {ref}. + The LEX interpreter exhibited here is modelled +on the interpreter REQ. As we will see shortly, +this will produce a bug, which will arise from the +attempt to mix 1LAMBDA*-calculus with recursion equations. +In the next section we will correct this bug. + The 1EVAL* in LEX is similar to that in REQ, +except that 1TOPENV* is not passed around, and a new clause +has been added to recognize 1LAMBDA*-expressions. +When one is seen, a 1&FUNARG* object is produced, +which is intended to be the function denoted +by the 1LAMBDA*-expression with respect to +the environment in which it was encountered +(this is the parameter 1ENV* passed to 1EVAL*). +A 1&FUNARG* object differs from a 1&FUNCTION* object +as used by REQ in that +it contains an environment in which the "code" or "script" {ref} +for the function is closed. +This environment contains values for variables lexically apparent +to the 1LAMBDA*-expression. +In REQ this was unnecessary because all functions +referred only to their parameters and the global environment, +and so all functions were, in effect, closed in the top-level +environment. In LEX, functions can refer to bound variables other +than its own parameters, and so each function must specify +precisely which free variables are visible to its body. + The 1APPLY* in LEX differs from the one in REQ +in that when applying a 1&FUNARG* object it binds +the parameters onto the environment contained in the +1&FUNARG* object, rather than onto the top-level environment. +In this way the body of the 1LAMBDA*-expression +sees variables lexically apparent to the 1LAMBDA*-expression, +plus the parameter bindings, with the latter having precedence. + The driver for LEX differs from the one for REQ. +In 1DRIVER-LOOP-1*, there are two changes. +First, only one copy of TOPENV is given to 1EVAL*, not two, +because in LEX 1EVAL* and 1APPLY* evidently do not need to pass 1TOPENV* +around for the sake of providing an environment to bind onto. +Second, functions produced by 1DEFINE* are 1&FUNARG* +objects, and so must contain an environment. Thus we put a pointer to 1TOPENV* +in the 1&FUNARG* object. + This is where the bug arises. We want functions +to be able to refer to other functions whose 1DEFINE* forms +may not have been read in yet. If, however, a pointer to 1TOPENV* +is included in the 1&FUNARG* object for the earlier function, +that version of 1TOPENV* will not contain the definition +of the later function. In providing for the correct modelling +of lambda-calculus, we have lost the ability to model recursion equations. +Of course, this interpreter will suffice if all we want to do is model lambda-calculus, +which does not permit such circular references. + +.sp + + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (DRIVER) + (DRIVER-LOOP (PRINT '|LITHP ITH LITHTENING|))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (DRIVER-LOOP TOPENV HUNOZ) + (DRIVER-LOOP-1 TOPENV (READ))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 9 +(DEFINE (DRIVER-LOOP-1 TOPENV FORM) + (COND ((ATOM FORM) + (DRIVER-LOOP TOPENV (PRINT (EVAL FORM TOPENV)))) + ((EQ (CAR FORM) 'DEFINE) + (DRIVER-LOOP (BIND (LIST (CAADR FORM)) + (LIST (LIST '&FUNARG (CDADR FORM) (CADDR FORM) TOPENV)) + TOPENV) + (PRINT (CAADR FORM)))) + (T (DRIVER-LOOP TOPENV (PRINT (EVAL FORM TOPENV)))))) +.spw 16 +.select 0 +.adjust +.sp + + +.c TEVAL - simple lexical interpreter with funargs + +.nofill +.select 1 +.spw 13 +.block 12 +(DEFINE (EVAL EXP ENV) + (COND ((ATOM EXP) + (COND ((NUMBERP EXP) EXP) + (T (VALUE EXP ENV)))) + ((EQ (CAR EXP) 'QUOTE) + (CADR EXP)) + ((EQ (CAR EXP) 'LAMBDA) + (LIST '&FUNARG (CADR EXP) (CADDR EXP) ENV)) + ((EQ (CAR EXP) 'COND) + (EVCOND (CDR EXP) ENV)) + (T (APPLY (EVAL (CAR EXP) ENV) + (EVLIS (CDR EXP) ENV))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 8 +(DEFINE (APPLY FUN ARGS) + (COND ((PRIMOP FUN) (PRIMOP-APPLY FUN ARGS)) + ((EQ (CAR FUN) '&FUNARG) + (EVAL (CADDR FUN) + (BIND (CADR FUN) + ARGS + (CADDDR FUN)))) + (T (ERROR '|UNKNOWN FUNCTION| (LIST FUN ARGS))))) +.spw 16 +.select 0 +.adjust +.sp + + +.nofill +.select 1 +.spw 13 +.block 5 +(DEFINE (EVCOND CLAUSES ENV) + (COND ((NULL CLAUSES) NIL) + ((EVAL (CAAR CLAUSES) ENV) + (EVAL (CADAR CLAUSES) ENV)) + (T (EVCOND (CDR CLAUSES) ENV)))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 4 +(DEFINE (EVLIS ARGLIST ENV) + (COND ((NULL ARGLIST) NIL) + (T (CONS (EVAL (CAR ARGLIST) ENV) + (EVLIS (CDR ARGLIST) ENV))))) +.spw 16 +.select 0 +.adjust +.sp + + +.page + +.section +D.__LEX:__A Correct Interpreter for Lexically Scoped LISP +.sp + + Our basic problem is that we wish to provide +at the top level a means of incrementally modifying +the top-level environment so that circular definitions +can be used. Achieving this circularity requires some +kind of conceptual side-effect. + One way we can accomplish this is to use value +cells, just as we did for REQVC. The primitive 1SETVC* +provides us with the necessary side-effect for modifying +the top-level environment. However, the local environments +stored in 1&FUNARG* objects are not subject to modification. +As before, 1NIL* represents the top-level environment, +and we use the 1VALUE1* routine of REQVC, which +first searches the given local environment, and then checks +the top-level environment if necessary. +The driver loop makes up 1&FUNARG* objects which +contain 1NIL* as the environment of closure. + +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (DRIVER) + (DRIVER-LOOP NIL (PRINT '|LITHP ITH LITHTENING|))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (DRIVER-LOOP HUNOZ HUKAIRZ) + (DRIVER-LOOP-1 (READ))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 9 +(DEFINE (DRIVER-LOOP-1 FORM) + (COND ((ATOM FORM) + (DRIVER-LOOP NIL (PRINT (EVAL FORM TOPENV)))) + ((EQ (CAR FORM) 'DEFINE) + (DRIVER-LOOP (SETVC (CAADR FORM) + (LIST '&FUNARG (CDADR FORM) (CADDR FORM) NIL)) + (PRINT (CAADR FORM)))) + (T (DRIVER-LOOP NIL (PRINT (EVAL FORM TOPENV)))))) +.spw 16 +.select 0 +.adjust +.sp + + Another way we could have solved our problem +would be to pass around 1TOPENV* as we did in REQ; +but instead of using 1TOPENV* within 1APPLY*, +we would pass it to 1VALUE* along with the local environment. +1VALUE* would first check the local environment using 1LOOKUP*, +and then check the top-level environment in the same manner. +The effect is that we have broken the environment +of every 1&FUNARG* object into two parts, local and global, +such that we can shoehorn extra function definitions +into the second part incrementally. +Thus, alhough we avoid the particular side-effect +of the primitive 1SETVC*, we have introduced a conceptual +side-effect in that the meaning of a 1&FUNARG* object can still +change over time, thanks to the alteration of the second part. + In either of these ways we can achieve a synthesis of the recursion +equation approach and the lambda-calculus approach. +As long as we make use only of locally bound variables, +our programs will emulate lambda-calculus; +if we make use only of global variables and immediately +bound parameters, our programs will emulate recursion equations. + But what of the interactions between the two worlds? +Can we be sure that our synthesis has not somehow destroyed the intuitive +semantics of one or the other discipline? Are there +other possible extensions of either which excludes the other? + +.page + +.section +E.__FLU:__An Interpreter for LISP with Fluid (Dynamically Bound) Variables +.sp + + Let us go back to our original definition of REQ, +and consider afresh the possibility of introducing +lambda-notation into the language, so that function definitions +may be mentioned within other functions. +We naturally want to do this with minimal perturbation +to the existing interpreter. + Let us suppose that we start with a version of REQ +which does not pass around 1TOPENV*; all functions +remain the same, except that 1EVAL* and 1APPLY* take +one fewer parameter each. We still need the contents of +1TOPENV*, however, in order to perform the 1BIND* in 1APPLY*. +We notice, however, that 1APPLY* is called only +from 1EVAL*, and that 1EVAL* has available to it the +paremeter 1ENV*. Now 1ENV* is guaranteed to contain +the top-level environment within it -- possibly with +other bindings as well, but that will not affect the +behavior of properly written recursion equations. +We therefore alter 1APPLY* to take an additional parameter +1ENV*, and alter 1EVAL* to pass its environment along. + Now, in order to allow lambda-notation, +we add a clause to 1EVAL* which will detect 1LAMBDA*-expressions +and produce an appropriate 1FUNCTION* object just like the +1&FUNCTION* objects made up by REQ's top-level driver. + In this way we have produced a version of REQ +which is simpler (because we don't have to pass around 1TOPENV*) +and which allows lambda-notation. However, it does not +model lambda-calculus, because no care is taken to ensure +that a 1&FUNCTION* object gets run in the associated +lexical environment. Instead, it is applied in whatever +environment is extant at the time it is invoked. +What we have, in fact, is the "fluid" or "dynamic" +variable binding behavior usually attributed to LISP. + Notice that we have shown 1EVAL* as +including an environment in the 1&FUNCTION* object +even though it is not later used. We have done this to make +a point. Suppose we were to alter the third argument to 1BIND* +in 1APPLY* from 1ENV* to 1(CADDDR_FUN)*. +Comparing the result with the LEX interpreter, we see +that we would then have a lexically scoped language! + Our point is that the difference between lexical +and fluid scoping is a very tiny one. There are two +environments floating around in 1APPLY*, one in the 1&FUNCTION* object +and one passed from 1EVAL*. Which discipline of variable scoping +you get depends only on which one you grab when it is time +to 1BIND*. + +.sp + +.c FEVAL - simple fluid interpreter (CRUFTY OLD LISP) + +.nofill +.select 1 +.spw 13 +.block 13 +(DEFINE (EVAL EXP ENV) + (COND ((ATOM EXP) + (COND ((NUMBERP EXP) EXP) + (T (VALUE EXP ENV)))) + ((EQ (CAR EXP) 'QUOTE) + (CADR EXP)) + ((EQ (CAR EXP) 'LAMBDA) + (LIST '&FUNCTION (CADR EXP) (CADDR EXP) ENV)) + ((EQ (CAR EXP) 'COND) + (EVCOND (CDR EXP) ENV)) + (T (APPLY (EVAL (CAR EXP) ENV) + (EVLIS (CDR EXP) ENV) + ENV)))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 8 +(DEFINE (APPLY FUN ARGS ENV) + (COND ((PRIMOP FUN) (PRIMOP-APPLY FUN ARGS)) + ((EQ (CAR FUN) '&FUNCTION) + (EVAL (CADDR FUN) + (BIND (CADR FUN) + ARGS + ENV))) + (T (ERROR '|UNKNOWN FUNCTION| (LIST FUN ARGS))))) +.spw 16 +.select 0 +.adjust +.sp + + + +{Can be bummed: &funarg => lambda, and don't cons in env} +{cf. recursion eqns interpreter} + +.page + +.section +F.__FLUBUM:__A Bummed Version of the Fluid Interpreter +.sp + + Now, being good hackers, we want to eliminate unnecessary code. +We can either not include an environment in the 1&FUNCTION* +object, or we can not pass an environment from 1EVAL* to 1APPLY*. +We did the latter in LEX. + If, however, we were starting from REQ without a 1TOPENV*, as postulated, +we would more likely do the former. This would be more consistent +with the existing format of functions in REQ, and also it's +very easy to pass 1ENV* from 1EVAL* to 1APPLY*. +(In a machine language implementation it would probably take no effort at all -- +the environment most likely would be sitting around in some register +anyway!) + We still have the problem of how the incremental changes +to the top-level environment are to take effect, if we do not +pass around 1TOPENV* explicitly. We will assume that +we adopt the method of value cells. + Now, if we do not include an environment in our +1&FUNCTION* objects, we notice the following neat hack: +we can use the word 1LAMBDA* as a substitute for 1&FUNCTION*, +and then we do not need to "cons up" a functional object at all! +Instead, we can just return the 1LAMBDA*-expression itself +from 1EVAL*, knowing that 1APPLY* will treat it as a function object! + Next, we note that we can save a little code in 1EVAL*. +Rather than having a special test for 1LAMBDA*, +we can just require the user to write 1(QUOTE (LAMBDA_...))* +instead of simply 1(LAMBDA_...)*, because after all 1EVAL* +will only return the same 1LAMBDA*-expression anyway. + By this sequence of hacks and bums we have progressed from +a simple recursion equations interpreter to what is essentially +LISP 1.5. + +.sp + +.c FEVAL1 - bummed simple fluid interpreter + +.nofill +.select 1 +.spw 13 +.block 13 +(DEFINE (EVAL EXP ENV) + (COND ((ATOM EXP) + (COND ((NUMBERP EXP) EXP) + (T (VALUE EXP ENV)))) + ((EQ (CAR EXP) 'QUOTE) + (CADR EXP)) + ((EQ (CAR EXP) 'LAMBDA) + EXP) + ((EQ (CAR EXP) 'COND) + (EVCOND (CDR EXP) ENV)) + (T (APPLY (EVAL (CAR EXP) ENV) + (EVLIS (CDR EXP) ENV) + ENV)))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 8 +(DEFINE (APPLY FUN ARGS ENV) + (COND ((PRIMOP FUN) (PRIMOP-APPLY FUN ARGS)) + ((EQ (CAR FUN) 'LAMBDA) + (EVAL (CADDR FUN) + (BIND (CADR FUN) + ARGS + ENV))) + (T (ERROR '|UNKNOWN FUNCTION| (LIST FUN ARGS))))) +.spw 16 +.select 0 +.adjust +.sp + + +{could just flush the test for LAMBDA in EVAL and use QUOTE!} +{we have coerced the representation for the function to BE the function?!} + +.page + +.c FEVAL2 mixed implementation of lexicals and fluids + +.nofill +.select 1 +.spw 13 +.block 17 +(DEFINE (EVAL EXP ENV FENV) + (COND ((ATOM EXP) + (COND ((NUMBERP EXP) EXP) + (T (VALUE EXP ENV)))) + ((EQ (CAR EXP) 'QUOTE) + (CADR EXP)) + ((EQ (CAR EXP) 'LAMBDA) + (LIST '&FUNARG (CADR EXP) (CADDR EXP) ENV)) + ((EQ (CAR EXP) 'FLAMBDA) + (LIST '&FLUNARG (CADR EXP) (CADDR EXP) ENV)) + ((EQ (CAR EXP) 'COND) + (EVCOND (CDR EXP) ENV)) + ((EQ (CAR EXP) 'FLUID) + (VALUE (CADR EXP) FENV)) + (T (APPLY (EVAL (CAR EXP) ENV) + (EVLIS (CDR EXP) ENV) + FENV)))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 15 +(DEFINE (APPLY FUN ARGS FENV) + (COND ((PRIMOP FUN) (PRIMOP-APPLY FUN ARGS FENV)) + ((EQ (CAR FUN) '&FUNARG) + (EVAL (CADDR FUN) + (BIND (CADR FUN) + ARGS + (CADDDR FUN)) + FENV)) + ((EQ (CAR FUN) '&FLUNARG) + (EVAL (CADDR FUN) + (CADDDR FUN) + (BIND (CADR FUN) + ARGS + FENV))) + (T (ERROR '|UNKNOWN FUNCTION| (LIST FUN ARGS))))) +.spw 16 +.select 0 +.adjust +.sp + +.page +.c NEVAL - simple lexical interpreter with call-by-name + +.nofill +.select 1 +.spw 13 +.block 12 +(DEFINE (EVAL EXP ENV) + (COND ((ATOM EXP) + (COND ((NUMBERP EXP) EXP) + (T (VALUE EXP ENV)))) + ((EQ (CAR EXP) 'QUOTE) + (CADR EXP)) + ((EQ (CAR EXP) 'LAMBDA) + (LIST '&FUNARG (CADR EXP) (CADDR EXP) ENV)) + ((EQ (CAR EXP) 'COND) + (EVCOND (CDR EXP) ENV)) + (T (APPLY (EVAL (CAR EXP) ENV) + (THUNKLIS (CDR EXP) ENV))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 8 +(DEFINE (APPLY FUN ARGS) + (COND ((PRIMOP FUN) (PRIMOP-APPLY FUN (DETHUNKLIS ARGS))) + ((EQ (CAR FUN) '&FUNARG) + (EVAL (CADDR FUN) + (BIND (CADR FUN) + ARGS + (CADDDR FUN)))) + (T (ERROR '|UNKNOWN FUNCTION| (LIST FUN ARGS))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (VALUE NAME ENV) + (VALUE1 NAME (LOOKUP NAME ENV))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 4 +(DEFINE (VALUE1 NAME SLOT) + (COND ((EQ SLOT '&UNBOUND) + (ERROR '|CAN'T REFERENCE UNBOUND VARIABLE| NAME)) + (T (DETHUNK (CAR SLOT))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (DETHUNK THUNK) + (EVAL (CAR THUNK) (CDR THUNK))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (MAKE-THUNK EXP ENV) + (CONS EXP ENV)) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 4 +(DEFINE (THUNKLIS ARGLIST ENV) + (COND ((NULL ARGLIST) NIL) + (T (CONS (MAKE-THUNK (CAR ARGLIST) ENV) + (THUNKLIS (CDR ARGLIST) ENV))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 4 +(DEFINE (DETHUNKLIS THUNKLIST) + (COND ((NULL THUNKLIST) NIL) + (T (CONS (DETHUNK (CAR THUNKLIST)) + (DETHUNKLIS (CDR THUNKLIST)))))) +.spw 16 +.select 0 +.adjust +.sp + + +.page +.c NFEVAL - simple lexical interpreter with call-by-name and fluids + +.nofill +.select 1 +.spw 13 +.block 17 +(DEFINE (EVAL EXP ENV FENV) + (COND ((ATOM EXP) + (COND ((NUMBERP EXP) EXP) + (T (VALUE EXP ENV)))) + ((EQ (CAR EXP) 'QUOTE) + (CADR EXP)) + ((EQ (CAR EXP) 'LAMBDA) + (LIST '&FUNARG (CADR EXP) (CADDR EXP) ENV)) + ((EQ (CAR EXP) 'FLAMBDA) + (LIST '&FLUNARG (CADR EXP) (CADDR EXP) ENV)) + ((EQ (CAR EXP) 'COND) + (EVCOND (CDR EXP) ENV)) + ((EQ (CAR EXP) 'FLUID) + (VALUE (CADR EXP) FENV)) + (T (APPLY (EVAL (CAR EXP) ENV) + (THUNKLIS (CDR EXP) ENV) + FENV)))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 15 +(DEFINE (APPLY FUN ARGS FENV) + (COND ((PRIMOP FUN) (PRIMOP-APPLY FUN (DETHUNKLIS ARGS FENV))) + ((EQ (CAR FUN) '&FUNARG) + (EVAL (CADDR FUN) + (BIND (CADR FUN) + ARGS + (CADDDR FUN)) + FENV)) + ((EQ (CAR FUN) '&FLUNARG) + (EVAL (CADDR FUN) + (CADDDR FUN) + (BIND (CADR FUN) + ARGS + FENV))) + (T (ERROR '|UNKNOWN FUNCTION| (LIST FUN ARGS))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (VALUE NAME ENV) + (VALUE1 (LOOKUP NAME ENV))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 4 +(DEFINE (VALUE1 NAME SLOT) + (COND ((EQ SLOT '&UNBOUND) + (ERROR '|CAN'T REFERENCE UNBOUND VARIABLE| NAME)) + (T (DETHUNK (CAR SLOT))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (DETHUNK THUNK FENV) + (EVAL (CAR THUNK) (CDR THUNK) FENV)) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (MAKE-THUNK EXP ENV) + (CONS EXP ENV)) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 4 +(DEFINE (THUNKLIS ARGLIST ENV) + (COND ((NULL ARGLIST) NIL) + (T (CONS (MAKE-THUNK (CAR ARGLIST) ENV) + (THUNKLIS (CDR ARGLIST) ENV))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 4 +(DEFINE (DETHUNKLIS THUNKLIST FENV) + (COND ((NULL THUNKLIST) NIL) + (T (CONS (DETHUNK (CAR THUNKLIST) FENV) + (DETHUNKLIS (CDR THUNKLIST) FENV))))) +.spw 16 +.select 0 +.adjust +.sp + +.page + +.c CPSEVAL - tail-recursive recursion eqns meta-circular - slightly bummed + + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (DRIVER) + (DRIVER-LOOP THE-INITIAL-ENVIRONMENT (PRINT '|LITHP ITH LITHTENING|))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (DRIVER-LOOP ENV HUNOZ) + (DRIVER-LOOP-1 ENV (READ))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 9 +(DEFINE (DRIVER-LOOP-1 ENV FORM) + (COND ((ATOM FORM) + (EVAL FORM ENV ENV (LIST DRIVER-LOOP-2))) + ((EQ (CAR FORM) 'DEFINE) + (DRIVER-LOOP (BIND (LIST (CAADR FORM)) + (LIST (LIST '&FUNCTION (CDADR FORM) (CADDR FORM))) + ENV) + (PRINT (CAADR FORM)))) + (T (EVAL FORM ENV ENV (LIST DRIVER-LOOP-2))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (DRIVER-LOOP-2 RESULT ENV) + (DRIVER-LOOP ENV (PRINT RESULT))) +.spw 16 +.select 0 +.adjust +.sp + + +.nofill +.select 1 +.spw 13 +.block 17 +(DEFINE (EVAL EXP ENV TOPENV PDL) + (COND ((ATOM EXP) + (COND ((NUMBERP EXP) + (POPJ EXP TOPENV PDL)) + (T (POPJ (VALUE EXP ENV) TOPENV PDL)))) + ((EQ (CAR EXP) 'QUOTE) + (POPJ (CADR EXP) TOPENV PDL)) + ((EQ (CAR EXP) 'COND) + (EVCOND (CDR EXP) ENV TOPENV PDL)) + ((EQ (CAR EXP) 'CATCH) + (EVAL (CADDR EXP) + (BIND (LIST (CADR EXP)) + (LIST (CONS '&ESCAPE PDL)) + ENV) + TOPENV + PDL)) + (T (EVAL (CAR EXP) ENV TOPENV (CONS EVLIS (CONS (CDR EXP) (CONS ENV PDL))))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (POPJ RESULT TOPENV PDL) + ((CAR PDL) RESULT TOPENV (CDR PDL))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (EVLIS FN TOPENV PDL) ;PDL = (ARGS ENV . PDL) + (EVLIS1 (CAR PDL) NIL (CADR PDL) TOPENV (CONS FN (CDDR PDL)))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 10 +(DEFINE (EVLIS1 ARGLIST EVALARGS ENV TOPENV PDL) ;PDL = (FN . PDL) + (COND ((NULL ARGLIST) + (APPLY (CAR PDL) (REVERSE EVALARGS) TOPENV (CDR PDL))) + (T (EVAL (CAR ARGLIST) + ENV + TOPENV + (CONS EVLIS2 + (CONS (CDR ARGLIST) + (CONS EVALARGS + (CONS ENV PDL)))))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (EVLIS2 ARG TOPENV PDL) ;PDL = (ARGLIST EVALARGS ENV . PDL) + (EVLIS1 (CAR PDL) (CONS ARG (CADR PDL)) (CADDR PDL) TOPENV (CDDDR PDL))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 6 +(DEFINE (EVCOND CLAUSES ENV TOPENV PDL) + (COND ((NULL CLAUSES) (POPJ NIL TOPENV PDL)) + (T (EVAL (CAAR CLAUSES) + ENV + TOPENV + (CONS EVCOND1 (CONS CLAUSES (CONS ENV PDL))))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 3 +(DEFINE (EVCOND1 PRED TOPENV PDL) ;PDL = (CLAUSES ENV . PDL) + (COND (PRED (EVAL (CADAAR PDL) (CADR PDL) TOPENV (CDDR PDL))) + (T (EVCOND (CDAR PDL) (CADR PDL) TOPENV (CDDR PDL))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 10 +(DEFINE (APPLY FUN ARGS TOPENV PDL) + (COND ((PRIMOP FUN) (POPJ (PRIMOP-APPLY FUN ARGS) TOPENV PDL)) + ((EQ (CAR FUN) '&FUNCTION) + (EVAL (CADADR FUN) + (BIND (CAADR FUN) ARGS TOPENV) + TOPENV + PDL)) + ((EQ (CAR FUN) '&ESCAPE) + (POPJ (CAR ARGS) TOPENV (CDR FUN))) + (T (ERROR '|UNKNOWN FUNCTION| (LIST FUN ARGS))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (VALUE NAME ENV) + (VALUE1 (LOOKUP NAME ENV))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 4 +(DEFINE (VALUE1 NAME SLOT) + (COND ((EQ SLOT '&UNBOUND) + (ERROR '|CAN'T REFERENCE UNBOUND VARIABLE| NAME)) + (T (CAR SLOT)))) +.spw 16 +.select 0 +.adjust +.sp + +{explain how to eliminate "second-order-ness" by putting a COND dispatch in POPJ} +{installing fluids would just pass around fenv like mad in parallel to pdl} +{explain how this would affect CATCH} + +.page + +.c an FEVAL2 with lexicals, fluids, and CATCH, using CATCH in the host language + + +.nofill +.select 1 +.spw 13 +.block 22 +(DEFINE (EVAL EXP ENV FENV) + (COND ((ATOM EXP) + (COND ((NUMBERP EXP) EXP) + (T (VALUE EXP ENV)))) + ((EQ (CAR EXP) 'QUOTE) + (CADR EXP)) + ((EQ (CAR EXP) 'LAMBDA) + (LIST '&FUNARG (CADR EXP) (CADDR EXP) ENV)) + ((EQ (CAR EXP) 'FLAMBDA) + (LIST '&FLUNARG (CADR EXP) (CADDR EXP) ENV)) + ((EQ (CAR EXP) 'COND) + (EVCOND (CDR EXP) ENV)) + ((EQ (CAR EXP) 'FLUID) + (VALUE (CADR EXP) FENV)) + ((EQ (CAR EXP) 'CATCH) + (CATCH J (EVAL (CADDR EXP) + (BIND (LIST (CADR EXP)) + (LIST (CONS '&CATCHTAG J)) + ENV)))) + (T (APPLY (EVAL (CAR EXP) ENV) + (EVLIS (CDR EXP) ENV) + FENV)))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 17 +(DEFINE (APPLY FUN ARGS FENV) + (COND ((PRIMOP FUN) (PRIMOP-APPLY FUN ARGS FENV)) + ((EQ (CAR FUN) '&FUNARG) + (EVAL (CADDR FUN) + (BIND (CADR FUN) + ARGS + (CADDDR FUN)) + FENV)) + ((EQ (CAR FUN) '&FLUNARG) + (EVAL (CADDR FUN) + (CADDDR FUN) + (BIND (CADR FUN) + ARGS + FENV))) + ((EQ (CAR FUN) '&CATCHTAG) + ((CDR FUN) (CAR ARGS))) + (T (ERROR '|UNKNOWN FUNCTION| (LIST FUN ARGS))))) +.spw 16 +.select 0 +.adjust +.sp + + +.page + +.c FEVAL2 with ASETQ, FLUIDSETQ, LABELS + +.nofill +.select 1 +.spw 13 +.block 27 +(DEFINE (EVAL EXP ENV FENV) + (COND ((ATOM EXP) + (COND ((NUMBERP EXP) EXP) + (T (VALUE EXP ENV)))) + ((EQ (CAR EXP) 'QUOTE) + (CADR EXP)) + ((EQ (CAR EXP) 'LAMBDA) + (LIST '&FUNARG (CADR EXP) (CADDR EXP) ENV)) + ((EQ (CAR EXP) 'FLAMBDA) + (LIST '&FLUNARG (CADR EXP) (CADDR EXP) ENV)) + ((EQ (CAR EXP) 'COND) + (EVCOND (CDR EXP) ENV)) + ((EQ (CAR EXP) 'FLUID) + (VALUE (CADR EXP) FENV)) + ((EQ (CAR EXP) 'ASETQ) + (ASSIGN (EVAL (CADDR EXP) ENV FENV) + (CADR EXP) + ENV)) + ((EQ (CAR EXP) 'FLUIDSETQ) + (ASSIGN (EVAL (CADDR EXP) ENV FENV) + (CADR EXP) + FENV)) + ((EQ (CAR EXP) 'LABELS) + (EVAL (CADDR EXP) (LABELSBIND (CADR EXP) ENV FENV) FENV)) + (T (APPLY (EVAL (CAR EXP) ENV) + (EVLIS (CDR EXP) ENV) + FENV)))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 15 +(DEFINE (APPLY FUN ARGS FENV) + (COND ((PRIMOP FUN) (PRIMOP-APPLY FUN ARGS FENV)) + ((EQ (CAR FUN) '&FUNARG) + (EVAL (CADDR FUN) + (BIND (CADR FUN) + ARGS + (CADDDR FUN)) + FENV)) + ((EQ (CAR FUN) '&FLUNARG) + (EVAL (CADDR FUN) + (CADDDR FUN) + (BIND (CADR FUN) + ARGS + FENV))) + (T (ERROR '|UNKNOWN FUNCTION| (LIST FUN ARGS))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (ASSIGN VALUE VAR ENV) + (ASSIGN1 VAR (LOOKUP VAR ENV) VALUE)) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 4 +(DEFINE (ASSIGN1 VAR SLOT VALUE) + (COND ((EQ SLOT '&UNBOUND) + (ERROR '|CAN'T ASSIGN TO AN UNBOUND VARIABLE| VAR)) + (T (CAR (RPLACA SLOT VALUE))))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (LABELSBIND DEFNS ENV FENV) + (LABELSEVLIS DEFNS NIL (LABELSENV DEFNS NIL NIL ENV) FENV)) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 6 +(DEFINE (LABELSENV DEFNS VARS VALS ENV) + (COND ((NULL DEFNS) (BIND VARS VALS ENV)) + (T (LABELSENV (CDR DEFNS) + (CONS (CAR DEFNS) VARS) + (CONS '&UNASSIGNED VALS) + ENV)))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 7 +(DEFINE (LABELSEVLIS DEFNS VALS ENV FENV) + (COND ((NULL DEFNS) + (LABELSRET (RPLACD (CAR ENV) VALS) ENV)) + (T (LABELSEVLIS (CDR DEFNS) + (CONS (EVAL (CADAR DEFNS) ENV FENV) VALS) + ENV + FENV)))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (LABELSRET GARBAGE ENV) + ENV) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 2 +(DEFINE (VALUE NAME ENV) + (VALUE1 NAME (LOOKUP NAME ENV))) +.spw 16 +.select 0 +.adjust +.sp + +.nofill +.select 1 +.spw 13 +.block 6 +(DEFINE (VALUE1 NAME SLOT) + (COND ((EQ SLOT '&UNBOUND) + (ERROR '|CAN'T REFERENCE UNBOUND VARIABLE| NAME)) + ((EQ (CAR SLOT) '&UNASSIGNED) + (ERROR '|CAN'T REFERENCE UNASSIGNED LABELS VARIABLE| NAME)) + (T (CAR SLOT)))) +.spw 16 +.select 0 +.adjust +.sp + + + +.section +Notes + + +.page + +.section +References +.sp 2 +.in 8 + +.block 4 +.un 8 +[Declarative] +.br +Steele, Guy Lewis Jr. +LAMBDA: The Ultimate Declarative. +AI Memo 379. MIT AI Lab (Cambridge, November 1976). +.block 4 +.un 8 +[Imperative] +.br +Steele, Guy Lewis Jr., and Sussman, Gerald Jay. +LAMBDA: The Ultimate Imperative. +AI Memo 353. MIT AI Lab (Cambridge, March 1976). +.block 4 +.un 8 +[Landin] +.br +Landin, Peter J. +"A Correspondence between ALGOL 60 and Church's Lambda-Notation." +Comm. ACM 8, 2-3 (February and March 1965). +.block 4 +.un 8 +[Moon] +.br +Moon, David A. +MacLISP Reference Manual, Revision 0. +Project MAC, MIT (Cambridge, April 1974). +.block 4 +.un 8 +[Moses] +.br +Moses, Joel. +The Function of FUNCTION in LISP. +AI Memo 199, MIT AI Lab (Cambridge, June 1970). +.block 4 +.un 8 +[Naur] +.br +Naur, Peter (Ed.), et al. +"Revised Report on the Algorithmic Language ALGOL 60." +Comm. ACM 6, 1 (January 1963), 1-20. +.block 4 +.un 8 +[RABBIT] +.br +Steele, Guy Lewis Jr. +Compiler Optimization Based on Viewing LAMBDA as Rename plus Goto. +S.M. thesis. MIT (Cambridge, May 1977). +.block 4 +.un 8 +[Reynolds] +.br +Reynolds, John C. +"Definitional Interpreters for Higher Order Programming Languages." +ACM Conference Proceedings 1972. +.block 4 +.un 8 +[SCHEME] +.br +Sussman, Gerald Jay, and Steele, Guy Lewis Jr. +SCHEME: An Interpreter for Extended Lambda Calculus. +AI Memo 349. MIT AI Lab (Cambridge, December 1975). +.block 4 +.un 8 +[Smith and Hewitt] +.br +Smith, Brian C. and Hewitt, Carl. +A PLASMA Primer (Draft). +MIT AI Lab (Cambridge, October 1975). +.in 0 diff --git a/src/scheme/nschsy.(init) b/src/scheme/nschsy.(init) new file mode 100644 index 00000000..b4bc9574 --- /dev/null +++ b/src/scheme/nschsy.(init) @@ -0,0 +1,13 @@ +;;; -*-LISP-*- + +(comment list 40000. symbols 4000.) + +(progn (setq pure 1) + (fasload (ai scheme) nschsy fasl) + (setq **swapping** nil) ;Default is not to time-share. + (setq *displace-save-sw* nil) + ((lambda (fn) (and (probef fn) (apply 'uread fn))) + (list (list 'dsk (status homedir)) (status userid) 'scheme)) + (defaultf (list (list 'dsk (status udir)) + 'foo '>)) + (scheme t '|SCHEME: Top Level|)) diff --git a/src/scheme/nschsy.99 b/src/scheme/nschsy.99 new file mode 100644 index 00000000..338fc79c --- /dev/null +++ b/src/scheme/nschsy.99 @@ -0,0 +1,1583 @@ +;;; SCHEME IN MACLISP -*- LISP -*- + +;;; To create a TS SCHEME dump, FASLOAD this file, then say (scheme-dump). + + +(eval-when (eval compile) + (and ;(status feature maclisp) ;implicit! + (not (status macro /#)) + (fasload (LISP) SHARPM)) +) + +(eval-when (eval load compile) + (setq backquote-expand-when 'read) +) + +; These utility functions are generally used for definitions. + +(declare (mapex t)) + +(declare (special *displace-sw* *displace-save-sw* *displace-list* *displace-count*)) + +(eval-when (eval load compile) +(defun careful-displace (x y) + (cond ((atom y) y) + (*displace-sw* + (cond (*displace-save-sw* + (setq *displace-count* (1+ *displace-count*)) + (setq *displace-list* + (cons (cons (cons (car x) (cdr x)) + x) + *displace-list*)))) + (rplaca x (car y)) + (rplacd x (cdr y)) + x) + (t y)) ) + +(or (boundp '*displace-sw*) + (setq *displace-sw* t)) + +(or (boundp '*displace-save-sw*) + (setq *displace-save-sw* t)) + +(or (boundp '*displace-list*) + (setq *displace-list* nil)) + +(or (boundp '*displace-count*) + (setq *displace-count* 0)) + +(defun replace () + ((lambda (n) + (declare (fixnum n)) + (cond ((not (= n *displace-count*)) + (terpri) (princ '|Someone's been hacking my *displace-list*!!!|) + (terpri) (princ '|Do it again and I won't speak to you anymore.|) + (break replace-lossage t))) + (mapc '(lambda (z) + (rplaca (cdr z) (caar z)) + (rplacd (cdr z) (cdar z))) + *displace-list*) + (setq *displace-count* 0) + (setq *displace-list* nil)) + (length *displace-list*))) + +;;; Read-macro characters. + +;;; Make FOO read as (FLUID FOO). + +(defun fmac () (list 'fluid (read))) + +(sstatus macro / 'fmac) + +) ;NEHW-LAVE + +(declare (special **exp** **template** **display** **unevlis** **evlis** **pc** **clink** + **fun** **val** **tem** **fluidvars** **fluidvals** + **cont** **env** **nargs** + **argument-registers** **cont+arg-regs** **number-of-arg-regs** + **one** **two** **three** **four** **five** **six** **seven** **eight** + **queue** **tick** **quantum** **process** **procnum** + **jpcr** **jrst** **break-flag** **no-args-check** **unassigned** + *noprint* version lispversion)) + +(setq *noprint* (list '*noprint*)) + +(setq **unassigned** (list '**unassigned**)) + +;Control stack formats and utilities + +(defun push macro (l) (list 'setq '**clink** (push1 (cdr l)))) + +(declare (eval (read))) + +(defun push1 (x) + (cond ((null x) '**clink**) + (t (list 'cons (car x) (push1 (cdr x)))))) + +(defun top macro (l) + (list + (list 'lambda '(ltem) + (cons 'setq + (mapcan '(lambda (x) + (list x '(car ltem) 'ltem '(cdr ltem) )) + (cdr l)))) + '**clink**)) + +(defun pop macro (l) + (list 'setq '**clink** + (list + (list 'lambda '(ltem) + (cons 'setq + (mapcan '(lambda (x) + (list x '(car ltem) 'ltem '(cdr ltem) )) + (cdr l)))) + '**clink**))) + +(defun 1st macro (l) (list 'car '**clink**)) +(defun 2nd macro (l) (list 'cadr '**clink**)) +(defun 3rd macro (l) (list 'caddr '**clink**)) + + +;Environment structure for Interpretive code. + +;The environment is stored as **template** and **display**. +; **template** is the template containing the currently active variable names, +; and the script of the current lambda. It also points back to the previous template. +; **display** contains the values of the currently active variables. + +(defun make-display macro (l) `(cons ,(cadr l) ,(caddr l))) + +(defun values macro (l) `(car ,(cadr l))) + +(defun previous-display macro (l) `(cdr ,(cadr l))) + +(defun set-vals macro (l) `(rplaca ,(cadr l) ,(caddr l))) + + +;Template structure is (( . ) . ( . )) + +(defun make-template (vars body parent-template name) + (cons (cons vars body) + (cons name parent-template))) + +(defun variables macro (l) `(caar ,(cadr l))) + +(defun previous-template macro (l) `(cddr ,(cadr l))) + +(defun template-body macro (l) `(cdar ,(cadr l))) + +(defun template-name macro (l) `(cadr ,(cadr l))) + +(defun set-template-name macro (l) `(rplaca (cdr ,(cadr l)) ,(caddr l))) + +(defun lookup (identifier templ displ) + (prog (vl dl) + next-display + (cond ((null templ) (return nil))) + (setq vl (variables templ)) + (setq dl (values displ)) + next-var + (cond ((null vl) + (setq templ (previous-template templ)) + (setq displ (previous-display displ)) + (go next-display)) + ((eq identifier (car vl)) + (return dl))) + (setq vl (cdr vl)) + (setq dl (cdr dl)) + (go next-var))) + +(defun locin macro (l) + (list 'car (cadr l))) + +(defun lambda-to-script (lambda-exp template) + (or (eq (car lambda-exp) 'lambda) + (error '|Bad LAMBDA - lambda-to-script| lambda-exp 'fail-act)) + (cons 'lambda-script + (make-template (reverse (cadr lambda-exp)) + (caddr lambda-exp) + template + (list 'lambda-expression (cadr lambda-exp))))) + +(defun betacons (script display) + (cons 'beta + (cons (cdr script) + display))) + +(defun beta-template macro (l) `(cadr ,(cadr l))) + +(defun beta-display macro (l) `(cddr ,(cadr l))) + +;Enclose is the user level operator for making lambda expressions into closures. +; The first argument is the lambda expression, the second is an alist describing +; the enclosing environment. If second arg is non-NIL atom, closure is so named. + +(defun enclose nargs + (prog (parent-template previous-display closure-name) + (cond ((= nargs 1.) + (setq parent-template nil + previous-display nil + closure-name nil)) + ((and (= nargs 2.) + (or (null (arg 2)) + (not (atom (arg 2))))) + ;;; have alist 2nd arg + (setq parent-template + (make-template (mapcar 'car (arg 2)) ;vars + nil ;body + nil ;parent-template + '*enclosure*) + previous-display + (make-display (mapcar 'cdr (arg 2)) nil) + closure-name nil)) + ((= nargs 2.) + ;;; have atomic 2nd arg + (setq parent-template nil + previous-display nil + closure-name (arg 2))) + (t (error '|Wrong number of ENCLOSE args| + (listify nargs) + 'fail-act))) + (setq **tem** (betacons (lambda-to-script (arg 1) parent-template) + previous-display)) + (and closure-name (name-closure **tem** closure-name)) + (return **tem**))) + +;Often a user wants to give a closure a name for debugging purposes: + +(defun name-closure (closure name) + (set-template-name (beta-template closure) name)) + +(defun procp (x) + (and (not (atom x)) + (cond ((eq (car x) 'beta) + (length (variables (beta-template x)))) + ((eq (car x) 'subr) + (or (cdr (args (subr (maknum (cadr x))))) t)) + ((eq (car x) 'lsubr) t) + ((eq (car x) 'expr) + (cond ((atom (cadr x)) (procp (getl (cadr x) '(expr subr lsubr)))) + ((and (cadadr x) (atom (cadadr x))) t) + (t (length (cadadr x))))) + ((eq (car x) 'delta) 1) + ((eq (car x) 'cbeta) + (or (get (subr (maknum (cadr x))) 'number-of-args) t)) + ((eq (car x) 'epsilon) 1) + ((eq (car x) 'debugfn) + (procp (caadr x)))))) + +;The `machine` + +(defun mloop () + (do ((**tick** nil)) (nil) + (and **break-flag** (funcall **break-flag**)) ;Debugging escape. + (and **tick** (schedule)) + (fastcall **pc**))) + +; Multi-process stuff + +(declare (special **swapping**)) + +(setq **swapping** nil) ;LISP alarmclock bug. +(setq **quantum** 1000000.) + +(defun setalarmclock () + (and **swapping** (alarmclock 'runtime **quantum**))) + +(defun schedule () + (and **queue** (swap!process)) + (setq **tick** nil) + (setalarmclock)) + +(defun swap!process () ;**queue** must be non-empty + (swapoutprocess) + (nconc **queue** (list **process**)) + (setq **process** (car **queue**)) + (setq **queue** (cdr **queue**)) + (swapinprocess)) + +(declare (special **process-format**)) + +(eval-when (eval load compile) +(setq **process-format** + '(**pc** **clink** **val** + **fun** **evlis** **unevlis** + **exp** **template** **display** + **fluidvars** **fluidvals** **tem** + **cont** **env** **nargs** + **one** **two** **three** **four** + **five** **six** **seven** **eight**))) + +(defun swapoutprocess1 macro (m) + `(list ,@**process-format**)) + +(defun swapoutprocess () + (putprop **process** (swapoutprocess1) '**process**)) + +(defun swapinprocess () + (mapc 'set + **process-format** + (get **process** '**process**))) + +(defun settick (x) (setq **tick** t)) + +(defun procstart () + (setq **pc** 'procstop) + (sapply)) + +(defun procstop () + (terminate)) + +;The essence of the evaluator starts here. + +(defun symbol-value (symbol template display) + (cond ((setq **tem** (lookup symbol template display)) + (cond ((eq (locin **tem**) **unassigned**) + (symbol-value (error '|Unassigned Symbol| symbol 'unbnd-vrbl) + template display)) + (t (locin **tem**)))) + ((getl symbol '(subr expr lsubr debugfn))) + ((boundp symbol) (symeval symbol)) + (t (symbol-value (error '|Unbound Symbol| symbol 'unbnd-vrbl) template display)))) + +(defun dispatch () + (cond ((atom **exp**) + (cond ((numberp **exp**) (setq **val** **exp**)) + (t (setq **val** (symbol-value **exp** **template** **display**))))) + ((eq (car **exp**) 'lambda-script) + (setq **val** (betacons **exp** **display**))) + (t (dispatch1)))) + +(defun dispatch1 () ;This winning bum is due to Charlie Rich. + (cond ((atom (car **exp**)) + (cond ((setq **tem** (get (car **exp**) 'aint)) + (fastcall **tem**)) + (t (setq **fun** (symbol-value (car **exp**) **template** **display**)) + (setq **unevlis** (cdr **exp**) **evlis** nil) + (evlis-nopush)))) + ((eq (caar **exp**) 'lambda-script) + (setq **fun** (betacons (car **exp**) **display**)) + (setq **unevlis** (cdr **exp**) **evlis** nil) + (evlis-nopush)) + ((null (cdr **exp**)) + (push **pc**) + (setq **exp** (car **exp**) **pc** 'nargs) + (dispatch1)) + (t (push **exp** **template** **display** **pc**) + (setq **exp** (car **exp**) **pc** 'gotfun) + (dispatch1)))) + +(defun evlis-nopush () + (cond ((null **unevlis**) + (setq **unevlis** **pc** **pc** 'tapply)) + ((atom (car **unevlis**)) + (setq **evlis** + (cons (cond ((numberp (car **unevlis**)) + (car **unevlis**)) + (t (symbol-value (car **unevlis**) **template** **display**))) + **evlis**) + **unevlis** (cdr **unevlis**)) + (evlis-nopush)) + ((eq (caar **unevlis**) 'lambda-script) + (setq **evlis** + (cons (betacons (car **unevlis**) **display**) + **evlis**) + **unevlis** (cdr **unevlis**)) + (evlis-nopush)) + ((null (cdr **unevlis**)) + (push **evlis** **fun** **pc**) + (setq **exp** (car **unevlis**) **pc** 'evlast) + (dispatch1)) + (t (push **evlis** **unevlis** **fun** **template** **display** **pc**) + (setq **exp** (car **unevlis**) **pc** 'evlis1) + (dispatch1)))) + +(defun tapply () (setq **pc** **unevlis**) (sapply)) + +(defun gotfun () + (pop **exp**) + (push **val**) ;stack = fun,template,display,pc. + (setq **unevlis** (cdr **exp**) **evlis** nil) + (evlis)) + +(defun evlis () + (cond ((null **unevlis**) + (pop **fun** **template** **display** **pc**) + (sapply)) + ((atom (car **unevlis**)) + (setq **evlis** + (cons (cond ((numberp (car **unevlis**)) + (car **unevlis**)) + (t (symbol-value (car **unevlis**) (2nd) (3rd)))) + **evlis**) + **unevlis** (cdr **unevlis**)) + (evlis)) + ((eq (caar **unevlis**) 'lambda-script) + (setq **evlis** + (cons (betacons (car **unevlis**) (3rd)) + **evlis**) + **unevlis** (cdr **unevlis**)) + (evlis)) + ((null (cdr **unevlis**)) + (pop **fun** **template** **display**) + (push **evlis** **fun**) + (setq **exp** (car **unevlis**) **pc** 'evlast) + (dispatch1)) + (t (top **fun** **template** **display**) + (push **evlis** **unevlis**) + (setq **exp** (car **unevlis**) **pc** 'evlis1) + (dispatch1)))) + +(defun evlis1 () + (pop **evlis** **unevlis**) + (setq **evlis** (cons **val** **evlis**) **unevlis** (cdr **unevlis**)) + (evlis)) + +(defun evlast () + (pop **evlis** **fun** **pc**) + (setq **evlis** (cons **val** **evlis**)) + (sapply)) + +(defun nargs () + (pop **pc**) + (setq **evlis** nil **fun** **val**) + (sapply)) + +(defun sapply () + (cond ((eq (car **fun**) 'subr) + (setq **val** (revsubrapply **fun** **evlis**))) + ((eq (car **fun**) 'lsubr) + (setq **val** (revlsubrapply **fun** **evlis**))) + ((eq (car **fun**) 'beta) + (setq **template** (beta-template **fun**)) + (or **no-args-check** + (= (length (variables **template**)) + (length **evlis**)) + ((lambda (prinlevel) + (error '|Wrong number of args to BETA -- SAPPLY| + (list (reverse (variables **template**)) + (reverse **evlis**)) + 'fail-act)) + 3.)) + (setq **display** (make-display **evlis** + (beta-display **fun**)) + **exp** (template-body **template**)) + (dispatch)) + ((eq (car **fun**) 'expr) + (setq **val** (revapply (cadr **fun**) **evlis**))) + ((eq (car **fun**) 'cbeta) + (compiled-beta-entry)) + ((eq (car **fun**) 'delta) + (or **no-args-check** + (= (length **evlis**) 1) + ((lambda (prinlevel) + (error '|Not exactly one arg to CATCH tag -- SAPPLY| + (reverse **evlis**) + 'fail-act)) + 3.)) + (setq **clink** (cadr **fun**)) + (pop **template** **display** **fluidvars** **fluidvals** **pc**) + (setq **val** (car **evlis**))) + ((eq (car **fun**) 'debugfn) + (setq **fun** (caadr **fun**)) + (sapply)) + (t (error '|Bad Function - Evlis| **fun** 'fail-act)))) + +(setq **no-args-check** nil) ;default, check arg num + +;Speedup hacks -- implementation dependent stuff. + +(defun revapply (fn vals) + (prog (a b c d e temp) + (or vals (return (funcall fn))) + (setq a (car vals) temp vals vals (cdr vals)) + (or vals (return (funcall fn a))) + (setq b (car vals) vals (cdr vals)) + (or vals (return (funcall fn b a))) + (setq c (car vals) vals (cdr vals)) + (or vals (return (funcall fn c b a))) + (setq d (car vals) vals (cdr vals)) + (or vals (return (funcall fn d c b a))) + (setq e (car vals) vals (cdr vals)) + (or vals (return (funcall fn e d c b a))) + (return (apply fn (reverse temp))))) + +(defun revsubrapply (fn vals) + (prog (a b c d e) + (or vals (return (subrcall nil (cadr fn)))) + (setq a (car vals) vals (cdr vals)) + (or vals (return (subrcall nil (cadr fn) a))) + (setq b (car vals) vals (cdr vals)) + (or vals (return (subrcall nil (cadr fn) b a))) + (setq c (car vals) vals (cdr vals)) + (or vals (return (subrcall nil (cadr fn) c b a))) + (setq d (car vals) vals (cdr vals)) + (or vals (return (subrcall nil (cadr fn) d c b a))) + (setq e (car vals) vals (cdr vals)) + (or vals (return (subrcall nil (cadr fn) e d c b a))) + (error '|Too Many Arguments to a Subr| (cons fn vals) 'wrng-no-args))) + +(defun revlsubrapply (fn vals) + (prog (a b c d e temp) + (setq temp vals) + (or temp (return (lsubrcall nil (cadr fn)))) + (setq a (car temp) temp (cdr temp)) + (or temp (return (lsubrcall nil (cadr fn) a))) + (setq b (car temp) temp (cdr temp)) + (or temp (return (lsubrcall nil (cadr fn) b a))) + (setq c (car temp) temp (cdr temp)) + (or temp (return (lsubrcall nil (cadr fn) c b a))) + (setq d (car temp) temp (cdr temp)) + (or temp (return (lsubrcall nil (cadr fn) d c b a))) + (setq e (car temp) temp (cdr temp)) + (or temp (return (lsubrcall nil (cadr fn) e d c b a))) + (setplist 'the-lsubr-apply-atom fn) + (return (apply 'the-lsubr-apply-atom (reverse vals))))) + + +(defun fastcall (atsym) + (cond ((eq (car (plist atsym)) 'subr) + (subrcall nil (cadr (plist atsym)))) + (t ((lambda (subr) + (cond ((and subr + (null (get atsym 'expr)) ;don't screw TRACE + (null (get atsym 'debugfn))) ;don't screw scheme-broken fns + (remprop atsym 'subr) + (putprop atsym subr 'subr) + (subrcall nil subr)) + (t (apply atsym nil)))) + (get atsym 'subr))))) + +; Compiled code linker and run-time environment. + +(setq **argument-registers** '(**one** **two** **three** **four** + **five** **six** **seven** **eight**)) + +(setq **cont+arg-regs** (cons '**cont** **argument-registers**)) + +(setq **env+cont+arg-regs** (cons '**env** **cont+arg-regs**)) + +(setq **number-of-arg-regs** (length **argument-registers**)) + +(setq **jrst** nil) + +(defun cheapy-jpc () + (mapcar '(lambda (x) (subr (cadr x))) **jrst**)) + +(defun rabbit-jpc () + (mapcar '(lambda (x) (list (get (subr (cadr x)) + 'user-function) + (caddr x))) + **jrst**)) + +(defun jrsticate () + (cond ((eq (car **fun**) 'cbeta) + (setq **env** (cddr **fun**)) + (and **jrst** + (setq **jrst** (cons **fun** **jrst**))) + (subrcall nil (cadr **fun**))) + ((eq (car **fun**) 'subr) + (setq **one** (spreadsubrcall)) + (setq **fun** **cont**) + (jrsticate)) + ((eq (car **fun**) 'lsubr) + (setq **one** (spreadlsubrcall)) + (setq **fun** **cont**) + (jrsticate)) + ((eq (car **fun**) 'expr) + (setq **one** (spreadexprcall)) + (setq **fun** **cont**) + (jrsticate)) + ((eq (car **fun**) 'beta) + (setq **template** (beta-template **fun**)) + (or **no-args-check** + (= **nargs** + (length (variables **template**))) + ((lambda (prinlevel) + (error '|Wrong number of args to BETA -- JRSTICATE| + (list (reverse (variables **template**)) + (reverse (gather-evlis))) + 'fail-act)) + 3.)) + (setq **display** + (make-display (gather-evlis) + (beta-display **fun**))) + (setq **exp** (template-body **template**)) + (cond ((eq (car **cont**) 'epsilon) + (setq **clink** (cadr **cont**)) + (pop **pc**)) + (t (setq **clink** **cont**) + (setq **pc** 'jrsticate1))) + (dispatch)) + ((eq (car **fun**) 'epsilon) + (setq **clink** (cadr **fun**)) + (pop **pc**) + (setq **val** **one**)) + ((eq (car **fun**) 'delta) + (setq **clink** (cadr **fun**)) + (pop **template** **display** **fluidvars** **fluidvals** **pc**) + (setq **val** **one**)) + ((eq (car **fun**) 'debugfn) + (setq **fun** (caadr **fun**)) + (jrsticate)) + (t (error '|Bad Function - Jrsticate| **fun** 'fail-act)))) + +(defun jrsticate1 () + (setq **one** **val**) + (setq **fun** **clink**) + (setq **pc** 'jrsticate) ;must set up pc + (jrsticate)) ;faster than going through MLOOP + +(defun compiled-beta-entry () + (setq **env** (cddr **fun**)) + (setq **cont** + (list 'epsilon + ((lambda (**clink**) + (push **pc**) + **clink**) + **clink**))) + (spread-evlis **evlis**) + (setq **pc** 'jrsticate) + (subrcall nil (cadr **fun**))) + +(defun spread-evlis (evlis) + (cond ((> (length evlis) **number-of-arg-regs**) + (setq **one** (reverse evlis))) + (t (spread-evlis1 evlis)))) + +(defun spread-evlis1 (evlis) + (cond (evlis + ((lambda (tem) + (set (car tem) + (car evlis)) + (cdr tem)) + (spread-evlis1 (cdr evlis)))) + (t **argument-registers**))) + +(defun gather-evlis () + (cond ((> **nargs** **number-of-arg-regs**) (reverse **one**)) + (t (do ((n 0 (+ 1 n)) + (argl nil (cons (symeval (car regl)) argl)) + (regl **argument-registers** (cdr regl))) + ((= n **nargs**) + argl))))) + +(defun spreadsubrcall () + (cond ((= **nargs** 0) + (subrcall nil (cadr **fun**))) + ((= **nargs** 1) + (subrcall nil (cadr **fun**) **one**)) + ((= **nargs** 2) + (subrcall nil (cadr **fun**) **one** **two**)) + ((= **nargs** 3) + (subrcall nil (cadr **fun**) **one** **two** **three**)) + ((= **nargs** 4) + (subrcall nil (cadr **fun**) **one** **two** **three** **four**)) + ((= **nargs** 5) + (subrcall nil (cadr **fun**) **one** **two** **three** **four** **five**)) + (t (error '|Too many arguments to a SUBR -- SPREAD| + (list **fun** **nargs**) + 'fail-act)))) + +(defun spreadlsubrcall () + (cond ((= **nargs** 0) + (lsubrcall nil (cadr **fun**))) + ((= **nargs** 1) + (lsubrcall nil (cadr **fun**) **one**)) + ((= **nargs** 2) + (lsubrcall nil (cadr **fun**) **one** **two**)) + ((= **nargs** 3) + (lsubrcall nil (cadr **fun**) **one** **two** **three**)) + ((= **nargs** 4) + (lsubrcall nil (cadr **fun**) **one** **two** **three** **four**)) + ((= **nargs** 5) + (lsubrcall nil (cadr **fun**) **one** **two** **three** **four** **five**)) + ((= **nargs** 6) + (lsubrcall nil (cadr **fun**) **one** **two** **three** **four** + **five** **six**)) + ((= **nargs** 7) + (lsubrcall nil (cadr **fun**) **one** **two** **three** **four** + **five** **six** **seven**)) + ((= **nargs** 8.) + (lsubrcall nil (cadr **fun**) **one** **two** **three** **four** + **five** **six** **seven** **eight**)) + (t (setplist 'the-lsubr-apply-atom **fun**) + (apply 'the-lsubr-apply-atom **one**)))) + +(defun spreadexprcall () + (cond ((= **nargs** 0) + (funcall nil (cadr **fun**))) + ((= **nargs** 1) + (funcall nil (cadr **fun**) **one**)) + ((= **nargs** 2) + (funcall nil (cadr **fun**) **one** **two**)) + ((= **nargs** 3) + (funcall nil (cadr **fun**) **one** **two** **three**)) + ((= **nargs** 4) + (funcall nil (cadr **fun**) **one** **two** **three** **four**)) + ((= **nargs** 5) + (funcall nil (cadr **fun**) **one** **two** **three** **four** **five**)) + ((= **nargs** 6) + (funcall nil (cadr **fun**) **one** **two** **three** **four** + **five** **six**)) + ((= **nargs** 7) + (funcall nil (cadr **fun**) **one** **two** **three** **four** + **five** **six** **seven**)) + ((= **nargs** 8.) + (funcall nil (cadr **fun**) **one** **two** **three** **four** + **five** **six** **seven** **eight**)) + (t (apply (cadr **fun**) **one**)))) + +; AINTs are special syntactic forms + +(defprop if aif aint) + +(defun aif () + (push **exp** **template** **display** **pc**) + (setq **exp** (cadr **exp**) **pc** 'if1) + (dispatch)) + +(defun if1 () + (pop **exp** **template** **display** **pc**) + (setq **exp** (cond (**val** (caddr **exp**)) (t (cadddr **exp**)))) + (dispatch)) + + +(defprop block ablock aint) + + +(defun ablock () + (push **template** **display** **pc**) + (setq **unevlis** + (or (cdr **exp**) + (error '|Strange Block -- Ablock| **exp** 'fail-act))) + (ablock1)) + +(defun ablock1 () + (cond ((cdr **unevlis**) + (top **template** **display**) + (push **unevlis**) + (setq **pc** 'ablock2)) + (t (pop **template** **display** **pc**))) + (setq **exp** (car **unevlis**)) + (dispatch)) + +(defun ablock2 () + (pop **unevlis**) + (setq **unevlis** (cdr **unevlis**)) + (ablock1)) + + +(defprop quote aquote aint) + +(defun aquote () (setq **val** (cadr **exp**))) + +;Amacros for SCHEME syntax extension. + +(defun amacro () + (setq **tem** + (or (getl (car **exp**) '(amacro smacro)) ;If both a LISP macro and a SCHEME + (getl (car **exp**) '(macro)))) ; macro is defined, prefer the latter. + (cond ((not (eq (car **tem**) 'smacro)) + (setq **exp** (funcall (cadr **tem**) **exp**)) + (dispatch)) + (t (push **template** **display** **pc**) + (setq **fun** (symeval (cadr **tem**))) + (setq **evlis** (list **exp**)) + (setq **pc** 'amacro1) + (sapply)))) + +(defun amacro1 () + (setq **exp** **val**) + (pop **template** **display** **pc**) + (dispatch)) + +(defprop lambda lambda-crunch amacro) +(defprop lambda amacro aint) + +(defun lambda-crunch (lamb) + (careful-displace lamb + (lambda-to-script lamb **template**))) + + +(defprop labels labels-crunch amacro) +(defprop labels amacro aint) + +(defun labels-crunch (labels-exp) + (careful-displace labels-exp (labels-sort labels-exp))) + + +(defun labels-sort (labels-exp) + (labels-to-script + (cons 'labels + (cons + (mapcar '(lambda(x) + (cond((atom (car x)) + (cond((eq 'lambda (caadr x)) + x) + (t (cons (car x) + (list (append '(lambda) + (cdr x))))))) + (t (cons (caar x) + (list (append + (cons 'lambda (list (cdar x))) + (cdr x))))))) + (cadr labels-exp)) + (cddr labels-exp))))) + +(defun labels-to-script (labels-exp) + ((lambda (deflist body genvars) + `((lambda ,(mapcar 'car deflist) + (block ((lambda ,genvars + (block ,@(mapcar '(lambda (fd iv) + `(aset' ,(car fd) ,iv)) + deflist + genvars))) + ,@(mapcar 'cadr deflist)) + ,body)) + ,@(mapcar '(lambda (x) '**unassigned**) deflist))) + (cadr labels-exp) + (caddr labels-exp) + (mapcar '(lambda (x) (gensym)) (cadr labels-exp)))) + +;Side effects. + +(defprop define adefine aint) + +(defun adefine () (setq **val** (eval **exp**))) + +(defun define fexpr (l) + (cond ((null (cdr l)) (*define (car l) nil l)) + ((not (atom (car l))) + (*define (caar l) + `(lambda ,(cdar l) ,(blockify (cdr l))) + l)) + ((cddr l) + (*define (car l) `(lambda ,(cadr l) ,(blockify (cddr l))) l)) + (t (*define (car l) (cadr l) l)))) + +(defun *define (name defn l) + (setq **tem** + (cond (defn + (and (eq (car defn) 'lambda) + (putprop name + defn + 'scheme!function))) + ((get name 'scheme!function)))) + (or (and (eq (typep name) 'symbol) + **tem**) + (error '|Bad Definition| (cons 'define l) 'fail-act)) + (setq **tem** (enclose **tem** nil)) + (set name **tem**) + (name-closure **tem** name) + name) + +(defprop aset aaset aint) + +(defun aaset () + (push **exp** **template** **display** **pc**) + (setq **exp** (cadr **exp**) **pc** 'aset1) + (dispatch)) + +(defun aset1 () + (pop **exp**) + (top **template** **display**) + (setq **exp** (caddr **exp**) **pc** 'aset2) + (push **val**) + (dispatch)) + +(defun aset2 () + (pop **tem** **template** **display** **pc**) ; tem is the identifier to be clobbered. + ((lambda (vc) + (cond (vc (rplaca vc **val**)) + (t (set **tem** **val**)))) + (lookup **tem** **template** **display**))) + +;Multiprocessing crap + +(setq **procnum** 0) + +(defun genprocname () + ((lambda (base *nopoint) + (maknam (append '(p r o c e s s) + (exploden (setq **procnum** (1+ **procnum**)))))) + 10. t)) + +(defun create!process (fun) + ((lambda (**process** + **exp** **template** **display** **evlis** **unevlis** **pc** **clink** + **fun** **fluidvars** **fluidvals** **val** **tem** **cont** **env** **nargs** + **one** **two** **three** **four** **five** **six** **seven** **eight**) + (setq **clink** (list **process**)) + ;;; **clink** starts this way so the originating process + ;;; of a DELTA can be clumsily identified + (swapoutprocess) + **process**) + (genprocname) + nil nil nil nil nil 'procstart nil + fun nil nil nil nil nil nil 0 + nil nil nil nil nil nil nil nil)) + +(defun start!process (p) + (cond ((or (not (eq (typep p) 'symbol)) (not (get p '**process**))) + (error '|Bad Process - START!PROCESS| p 'fail-act))) + (or (eq p **process**) (memq p **queue**) + (setq **queue** (nconc **queue** (list p)))) + p) + +(defun stop!process (p) + (cond ((memq p **queue**) + (setq **queue** (delq p **queue**)) + p) + ((eq p **process**) + (setq **val** p) + (suspend!process)))) + +(defun terminate () + ((lambda (proc) (prog2 nil + (suspend!process) + (remprop proc '**process**))) + **process**)) + +(defun suspend!process () + (swapoutprocess) + (cond ((null **queue**) + (setq **template** nil) + (setq **display** nil) + (setq **fluidvars** nil) + (setq **fluidvals** nil) + (setq **process** (make-ear '|Queue Ran Out| '|==> |))) + (t (setq **process** (car **queue**)) + (setq **queue** (cdr **queue**)))) + (swapinprocess) + **val**) + +(defun make-ear (msg prompt) + (create!process (enclose `(lambda () (**top** ',msg ',prompt)) nil))) + +;Catch + +(defprop catch acatch aint) + +(defun acatch () + (setq **template** + (make-template (list (cadr **exp**)) + (caddr **exp**) + **template** + (list 'catch-expression (cadr **exp**)))) + (setq **display** + (make-display (list (list 'delta + ((lambda (**clink**) + (push **template** + **display** + **fluidvars** + **fluidvals** + **pc**) + **clink**) + **clink**) + (cadr **exp**))) + **display**)) + (setq **exp** (caddr **exp**)) + (dispatch)) + + +;Utilities + +(declare (macros t)) + +(defun if macro (x) ;for MacLISP code + (careful-displace x + `(cond (,(cadr x) ,(caddr x)) + (t ,(cadddr x))))) + +(defun blockify (x) + (cond ((null x) nil) + ((null (cdr x)) (car x)) + (t `(block . ,x)))) + +(defun orify (x) + (cond ((null x) nil) + ((null (cdr x)) (car x)) + (t (cons 'or x)))) + +(defun afsubr (x) `(eval ',x)) + +(defprop proclaim afsubr amacro) (defprop proclaim amacro aint) + +(defun proclaim fexpr (x) 'proclamation) + +; Defmac's allow for variable lists of the form (a1 ,,, an) +; or alternatively, allow a dotted list construction (a1 ,,, an-1 . an) +; so that an will be bound to the remainder of the calling form. +; In addition, the list of arguments will be bound to the given +; variable in LSUBR fashion if a variable (not a list) is supplied. + +(declare (defun /@define fexpr (x) nil) + (/@define defmac |lisp macro|)) + +(defprop defmac amacro aint) + +(defun defmac macro (x) ;define MacLISP macro + (careful-displace x + `(progn + 'compile + (defprop ,(cadr x) amacro aint) + (defun ,(cadr x) macro (*z*) + (careful-displace *z* + ((lambda ,(do ((a (caddr x) (cdr a)) + (b nil (cons (car a) b))) + ((or (null a) (eq (typep a) 'symbol)) + (cond ((null a) (nreverse b)) + (t (nreverse (cons a b)))))) + ,(cadddr x)) + ,@(do ((a (caddr x) (cdr a)) + (b '(cdr *z*) `(cdr ,b)) + (c nil (cons `(car ,b) c))) + (nil) + (cond ((null a) (return (nreverse c))) + ((eq (typep a) 'symbol) + (return + (nreverse (cons b c)))))))))))) + +;SCHMACs are for SCHEME what DEFMACs are for LISP, with similar syntax. + +(declare (/@define schmac |scheme macro|)) + +(defprop schmac amacro aint) + +(defun schmac macro (x) ;define SCHEME macro + ((lambda (newname) + (careful-displace x + `(progn 'compile + (defprop ,(cadr x) amacro aint) + (defprop ,(cadr x) ,newname amacro) + (defun ,newname (*z*) + (careful-displace *z* + ((lambda ,(do ((a (caddr x) (cdr a)) + (b nil (cons (car a) b))) + ((or (null a) + (eq (typep a) 'symbol)) + (cond ((null a) (nreverse b)) + (t (nreverse + (cons a b)))))) + ,(cadddr x)) + ,@(do ((a (caddr x) (cdr a)) + (b '(cdr *z*) `(cdr ,b)) + (c nil (cons `(car ,b) c))) + (nil) + (cond ((null a) (return (nreverse c))) + ((eq (typep a) 'symbol) + (return + (nreverse (cons b c)))))))))))) + (implode (append (explodec (cadr x)) '(- a m a c r o))))) + +(defprop macro amacro aint) + +(defun macro macro (x) + ((lambda (newname) + (careful-displace x + `(progn 'compile + (defprop ,(cadr x) amacro aint) + (defprop ,(cadr x) ,newname smacro) + (define ,newname (*z*) + (careful-displace *z* + ((lambda ,(do ((a (caddr x) (cdr a)) + (b nil (cons (car a) b))) + ((or (null a) + (eq (typep a) 'symbol)) + (cond ((null a) (nreverse b)) + (t (nreverse + (cons a b)))))) + ,(cadddr x)) + ,@(do ((a (caddr x) (cdr a)) + (b '(cdr *z*) `(cdr ,b)) + (c nil (cons `(car ,b) c))) + (nil) + (cond ((null a) (return (nreverse c))) + ((eq (typep a) 'symbol) + (return + (nreverse (cons b c)))))))))))) + (implode (append (explodec (cadr x)) '(- s m a c r o))))) + +(schmac let (defns . body) + `((lambda ,(mapcar 'car defns) ,(blockify body)) + ,@(mapcar 'cadr defns)))) + +(declare (special **doname** **dobody**)) + +(setq **doname** (maknam (explodec '*doloop*))) + +(schmac do (specs end . body) + `(labels ((,**doname** + (lambda ,(mapcar 'car specs) + (if ,(car end) + ,(blockify (cdr end)) + ,(blockify + (append body + `((,**doname** + ,@(mapcar '(lambda (y) + (cond ((and (cdr y) + (cddr y)) + (caddr y)) + (t (car y)))) + specs))))))))) + (,**doname** ,@(mapcar '(lambda (y) (and (cdr y) (cadr y))) specs)))) + +(schmac iterate (name varinits . body) + `(labels ((,name (lambda ,(mapcar 'car varinits) ,(blockify body)))) + (,name . ,(mapcar 'cadr varinits)))) + +(schmac test (pred fn alt) + `((lambda (p f a) + (if p ((f) p) (a))) + ,pred + (lambda () ,fn) + (lambda () ,alt))) + +(schmac cond clauses + (cond ((null clauses) nil) + ((eq (caar clauses) 't) + (blockify (cdar clauses))) ;bum + ((null (cdar clauses)) + `(or ,(caar clauses) + (cond . ,(cdr clauses)))) + ((eq (cadar clauses) '=>) + `(test ,(caar clauses) + ,(caddar clauses) + (cond . ,(cdr clauses)))) + (t `(if ,(caar clauses) + ,(blockify (cdar clauses)) + (cond . ,(cdr clauses)))))) + +(schmac or args + (cond ((null args) nil) + ((null (cdr args)) (car args)) + (t `((lambda (p r) (if p p (r))) + ,(car args) + (lambda () (or . ,(cdr args))))))) + +(schmac and args + (cond ((null args) t) + ((null (cdr args)) (car args)) + (t `(if ,(car args) (and . ,(cdr args)) nil)))) + +(schmac amapcar (fn . arglists) + ((lambda (fnname result names) + `(do ((,fnname ,fn) + ,@(mapcar '(lambda (y n) `(,n ,y (cdr ,n))) + arglists + names) + (,result + nil + (cons (,fnname ,@(mapcar '(lambda (y) `(car ,y)) + names)) + ,result))) + (,(orify (mapcar '(lambda (n) `(null ,n)) names)) + (nreverse ,result)))) + (gensym) + (gensym) + (mapcar '(lambda (x) (gensym)) arglists))) + +(schmac amaplist (fn . arglists) + ((lambda (fnname result names) + `(do ((,fnname ,fn) + ,@(mapcar '(lambda (y n) `(,n ,y (cdr ,n))) + arglists + names) + (,result nil (cons (,fnname ,@names) ,result))) + (,(orify (mapcar '(lambda (n) `(null ,n)) names)) + (nreverse ,result)))) + (gensym) + (gensym) + (mapcar '(lambda (x) (gensym)) arglists))) + +(schmac amapc (fn . arglists) + ((lambda (fnname names) + `(do ((,fnname ,fn) + ,@(mapcar '(lambda (y n) `(,n ,y (cdr ,n))) + arglists + names)) + (,(orify (mapcar '(lambda (n) `(null ,n)) names)) + nil) + (,fnname ,@(mapcar '(lambda (y) `(car ,y)) + names)))) + (gensym) + (mapcar '(lambda (x) (gensym)) arglists))) + +(schmac aarraycall (type . args) + `(funcall ,@args)) + +;Fluid variable stuff. + +(schmac FLUIDBIND (vars expression) + `(FLUIDBIND-HANDLER ',(mapcar 'car vars) + (LIST ,@(mapcar 'cadr vars)) + (LAMBDA () ,expression))) + +(define FLUIDBIND-HANDLER + (lambda (vars vals c) + (let ((ovars **fluidvars**) + (ovals **fluidvals**)) + (block (set' **fluidvars** (append vars ovars)) ;not NCONC + (set' **fluidvals** (append vals ovals)) + (let ((val (c))) + (block (set' **fluidvars** ovars) + (set' **fluidvals** ovals) + val)))))) + +(schmac FLUID (var) + `(FLUID-HANDLER ',var)) + +(define FLUID-HANDLER + (lambda (var) + (let ((vc (fluidlookup var **fluidvars** **fluidvals**))) + (if vc + (car vc) + (if (boundp var) + (symeval var) + (fluid-handler + (error '|Unbound Fluid Variable -- FLUID-HANDLER| + var 'unbnd-vrbl)))))))) + + +(defun fluidset (var val) + ((lambda (vc) + (cond (vc (rplaca vc val)) + (t (set var val)))) + (fluidlookup var **fluidvars** **fluidvals**))) + +(defun fluidlookup (id vars vals) + (prog () + lp (cond ((null vars) (return nil)) + ((eq id (car vars)) + (cond ((null vals) (error '|Vals too short -- fluidlookup| id 'fail-act))) + (return vals)) + ((null vals) (error '|Too few vals - fluidlookup| id 'fail-act))) + (setq vars (cdr vars) vals (cdr vals)) + (go lp))) + +(schmac STATIC (var) var) + + +(declare (special **genprogtag**)) + +(defun genprogtag () + ((lambda (base *nopoint) + (maknam (append '(T A G) + (explodec (setq **genprogtag** + (1+ **genprogtag**)))))) + 10. + t)) + +(setq **genprogtag** 0) + +(defprop prog aprog amacro) (defprop prog amacro aint) + +(defun aprog (x) + (careful-displace x (aprog1 (cdr x) nil nil))) + +(defun aprog1 (x rnl ret) + `((lambda ,(car x) ,(aprog2 (cdr x) rnl ret)) + ,@(mapcar '(lambda (x) nil) (car x)))) + +(defun aprog2 (body rnl ret) + ((lambda (stuff) + `(labels ,(maplist '(lambda (z) + `(,(caar z) + (lambda () + ,(aprogx (cadar z) + (cond ((cdr z) (caadr z)) + (t ret)) + (cdr stuff) + ret)))) + (car stuff)) + (,(caaar stuff)))) + (aprog3 body rnl ret))) + +(defun aprog3 (body rnl ret) + (do ((b body (cdr b)) + (r rnl) + (tags nil + (and (atom (car b)) (cons (car b) tags))) + (x nil + (cond ((atom (car b)) x) + (t ((lambda (g) + (setq r (do ((z tags (cdr z)) + (y r (cons (cons (putprop g (car z) 'gotag) + g) + y))) + ((null z) y))) + (cons (list g (car b)) x)) + (genprogtag)))))) + ((null b) + (cons (nreverse x) + (do ((z tags (cdr z)) + (y r (cons (cons (car z) ret) y))) + ((null z) y)))))) + +(defun aprogx (form next rnl ret) + (cond ((atom form) + (cond (next `(,next)) + (t (error '|What The Hell? - PROG| form 'fail-act)))) + ((eq (car form) 'go) + ((lambda (x) + (cond ((null x) + (error '|Illegal GO| form 'unseen-go-tag)) + (t `(,(cdr x))))) + (assq (cadr form) rnl))) + ((eq (car form) 'return) + (cond (ret `(,ret)) + (t (cadr form)))) + ((eq (car form) 'if) + `(if ,(cadr form) + ,(aprogx (caddr form) next rnl ret) + ,(aprogx (cadddr form) next rnl ret))) + ((eq (car form) 'lambda) + `(lambda ,(cadr form) ,(aprogx (caddr form) next rnl ret))) + ((eq (car form) 'labels) + `(labels ,@(mapcar '(lambda (x) `(,(car x) + ,(aprogx (cadr x) next rnl ret))) + (cadr form)) + ,(aprogx (caddr form) next rnl ret))) + ((eq (car form) 'prog) + (aprog1 (cdr form) rnl next)) + ((and (atom (car form)) + (get (car form) 'amacro)) + (aprogx (apply (get (car form) 'amacro) form) + next rnl ret)) + (t ((lambda (fm) + (cond (next `(block ,fm (,next))) + (t fm))) + (mapcar '(lambda (x) + (cond ((atom x) x) + ((eq (car x) 'lambda) + (aprogx x next rnl ret)) + (t x))) + form))))) + +;Getting the whole thing started up. + +(defun version macro (x) + (cond (compiler-state + (list 'quote + (cond ((status feature newio) + (list (namestring (truename infile)) + '|compiled by| + (STATUS USERID))) + (t (status uread))))) + (t (rplaca x 'quote) + (rplacd x (list version)) + (list 'quote version)))) + +(eval-when (compile) +(setq version ((lambda (compiler-state) (version)) t)) +) + +(defprop moonphase (phase fasl dsk liblsp) autoload) +(defprop phaseprinc (phsprt fasl dsk liblsp) autoload) +(defprop datimprinc (phsprt fasl dsk liblsp) autoload) +(defprop sunposprinc (phsprt fasl dsk liblsp) autoload) + +; Interpreter initialization + +(defun scheme (garbagep msg) + (cond (garbagep + (setq version (version)) + (setq lispversion (status lispversion)) + (terpri) + (princ '|This is SCHEME |) + (princ version) + (princ '| running in LISP |) + (princ lispversion) + (princ '|.|) + (terpri) + (princ '| |) + (phaseprinc (moonphase)) + (terpri) + (princ '| |) + (sunposprinc) + (terpri) + (princ '| |) + (datimprinc 'hack))) + (setq **break-flag** nil) + (setq **jpcr** nil) + (setq **queue** nil) + (setq **process** (make-ear msg '|==> |)) + (swapinprocess) + (setq alarmclock 'settick) + (setalarmclock) + (mloop)) + +(defun schemestart nargs + (sstatus toplevel '(schemestart1)) + (nointerrupt nil) + (^g)) + +(defun schemestart1 () + (sstatus toplevel nil) + (cond ((not (= tty 5)) (scheme nil '|Quit|)) + (t (scheme t '|SCHEME: Top Level|)))) + +(cond ((status feature newio) + (sstatus ttyint '/ 'schemestart)) + (t (sstatus interrupt 16. 'schemestart))) + +(defun punt-once () ;atomic + (and **queue** + (progn (putprop **process** t '**punt**) + (swap!process) + (remprop **process** '**punt**) ;great obscurity + **val**))) + +(define punt + (lambda () + (iterate search + ((q **queue**)) + (if (null q) + nil + (if (get (car q) '**punt**) + (search (cdr q)) + (block (punt-once) (punt))))))) + +;The read-eval-print loop. + +(define **top** + (lambda (message prompt) + (block (set '-- nil) + (terpri) + (princ message) + (iterate the-top-level-loop + () + (block (punt) + (terpri) + (princ prompt) + (set' ++ --) + (set' -- (read)) + (set' ** ((enclose `(lambda () ,--) nil))) + (if (not ^q) + (if (not (eq ** *noprint*)) (terpri)) + (if (> (charpos (symeval 'tyo)) 10.) + (block (terpri) (princ '| |)))) + (if (not (eq ** *noprint*)) + (if scheme-prin1 + (scheme-prin1 **) + (schprin1 **))) + (princ '| |) + (the-top-level-loop)))))) + +(setq scheme-prin1 nil) + +(defun schprin1 (x) + (cond (prin1 (funcall prin1 x)) + (t (prin1 x)))) + +(defun where () + (do ((b **template** (previous-template b))) + ((null b) nil) + (print (template-name b)))) + + +(defun schval fexpr (l) + (locin (lookup (car l) **template** **display**))) + +;; The following let the grinder (sprinter, sprin1) know about SCHEME's +;; circular data structures. For endless beauty, say (SETQ PRIN1 'SPRIN1) + +(defun grind-a-procedure (&AUX temp) + (declare (special l m)) + (princ '|#<|) + (prin1 (car l)) + (princ '| |) + (prin1 (maknum l)) + (cond ((and (eq (car l) 'beta) + (symbolp (setq temp (template-name (beta-template l))))) + (princ '| |) + (prin1 temp)) + ((eq (car l) 'delta) + (princ '| |) + (prin1 (caddr l)))) + (princ '|>|)) + +(mapcar '(lambda (marker) + (putprop marker '+INTERNAL-DWIM-PREDICTFUN 'grindpredict) + (putprop marker 'grind-a-procedure 'grindmacro)) + '(beta cbeta subr lsubr expr delta epsilon debugfn)) + +(defprop sprin1 #.(get 'sprinter 'autoload) autoload) + + +;;; Function to load SCHEME stuff from a file. +;;; Works on FASL or SCHEME files. Attempts to duplicate LOAD algorithm; +;;; in particular, if no second filename is given `FASL` is tried first. + +(declare (special defaultf)) + +(define SCHLOAD + (lambda (f0) + (let ((f (mergef f0 '((* *) * *)))) + (let ((fn2 (caddr f)) + (>0 (mergef (mergef f '((* *) * >)) + (symeval 'defaultf))) + (fasl0 (mergef (mergef f '((* *) * fasl)) + (symeval 'defaultf)))) + (let ((> (probef >0)) + (fasl (probef fasl0)) + (initname (implode (append '(i n i t -) + (exploden (cadr fasl0)))))) + (cond ((null >) + ;;; no file there at at all + (let ((tyo (symeval 'tyo))) + (terpri tyo) + (princ (namestring >0)) + (princ '| file not found -- SCHLOAD| tyo) + (terpri tyo) + (princ '|Use what filename instead? | tyo) + (schload (readline (symeval 'tyi))))) + ((and (eq fn2 '*) + ;;; no second filename -- try FASL + fasl + (faslp fasl)) + (let ((v (apply 'fasload (list (cadr fasl) + (caddr fasl) + (caar fasl) + (cadar fasl))))) + (block (and (boundp initname) + (procp (symeval initname)) + ((symeval initname))) + v))) + ((faslp >) + ;;; got fasl file + (let ((v (apply 'fasload (list (cadr >) + (caddr >) + (caar >) + (cadar >))))) + (block (and (boundp initname) + (procp (symeval initname)) + ((symeval initname))) + v))) + (t (let ((file (open > '(dsk in))) + (eof (list 'eof))) + (iterate readloop () + (let ((x (read file eof))) + (if (eq x eof) + (block (close file) t) + (block + ((enclose `(lambda () ,x) + nil)) + (readloop))))))))))))) + + +;; Utility to dump out a TS SCHEME. + +(eval-when (eval load) + (alloc '(LIST (40000. 100000. .2) SYMBOL (5000. 10000. 512.)))) + +;; Before loading NSCHSY, do a (setq pure 1). +(defun schemedump (&OPTIONAL (file '|SCHEME;TS SCHEME|)) + (or (getl 'moonphase '(subr lsubr)) + (and (get 'moonphase 'autoload) (load (get 'moonphase 'autoload)))) + (sstatus flush 't) + (gc) + (suspend () file) + (setq defaultf `((DSK ,(STATUS UDIR)) FOO >)) + (setq pure 1) + (setq **swapping** nil) ;Default is not to time-share. + (setq *displace-save-sw* nil) + ((lambda (fn) (and (probef fn) (apply 'uread fn))) + (list (list 'dsk (status homedir)) (status userid) 'scheme)) + (scheme t '|SCHEME: Top Level|)) + + +;Various LISP FSUBRS are useful in SCHEME. +;This must be at the end of the file. + +(mapatoms '(lambda (x) + (cond ((and (get x 'fsubr) (not (get x 'aint))) + (putprop x 'afsubr 'amacro) + (putprop x 'amacro 'aint))))) + +(defprop grindef afsubr amacro) (defprop grindef amacro aint) +(defprop trace afsubr amacro) (defprop trace amacro aint) +(defprop untrace afsubr amacro) (defprop untrace amacro aint) +(defprop debug afsubr amacro) (defprop debug amacro aint) +(defprop ledit afsubr amacro) (defprop ledit amacro aint)