diff --git a/ase/test/awk/lisp/Impl-notes b/ase/test/awk/lisp/Impl-notes new file mode 100644 index 00000000..d38096f6 --- /dev/null +++ b/ase/test/awk/lisp/Impl-notes @@ -0,0 +1,147 @@ +Implementation notes + + +1. Overview + +Since the code should be self-explanatory to anyone knowledgeable +about Lisp implementation, these notes assume you know Lisp but not +interpreters. I haven't got around to writing up a complete +discussion of everything, though. + +The code for an interpreter can be pretty low on redundancy -- this is +natural because the whole reason for implementing a new language is to +avoid having to code a particular class of programs in a redundant +style in the old language. We implement what that class of programs +has in common just once, then use it many times. Thus an interpreter +has a different style of code, perhaps denser, than a typical +application program. + + +2. Data representation + +Conceptually, a Lisp datum is a tagged pointer, with the tag giving +the datatype and the pointer locating the data. We follow the common +practice of encoding the tag into the two lowest-order bits of the +pointer. This is especially easy in awk, since arrays with +non-consecutive indices are just as efficient as dense ones (so we can +use the tagged pointer directly as an index, without having to mask +out the tag bits). (But, by the way, mawk accesses negative indices +much more slowly than positive ones, as I found out when trying a +different encoding.) + +This Lisp provides three datatypes: integers, lists, and symbols. (A +modern Lisp provides many more.) + +For an integer, the tag bits are zero and the pointer bits are simply +the numeric value; thus, N is represented by N*4. This choice of the +tag value has two advantages. First, we can add and subtract without +fiddling with the tags. Second, negative numbers fit right in. +(Consider what would happen if N were represented by 1+N*4 instead, +and we tried to extract the tag as N%4, where N may be either positive +or negative. Because of this problem and the above-mentioned +inefficiency of negative indices, all other datatypes are represented +by positive numbers.) + + +3. The evaluation/saved-bindings stack + +The following is from an email discussion; it doesn't develop +everything from first principles but is included here in the hope +it will be helpful. + +Hi. I just took a look at awklisp, and remembered that there's more +to your question about why we need a stack -- it's a good question. +The real reason is because a stack is accessible to the garbage +collector. + +We could have had apply() evaluate the arguments itself, and stash +the results into variables like arg0 and arg1 -- then the case for +ADD would look like + +if (proc == ADD) return is(a_number, arg0) + is(a_number, arg1) + +The obvious problem with that approach is how to handle calls to +user-defined procedures, which could have any number of arguments. +Say we're evaluating ((lambda (x) (+ x 1)) 42). (lambda (x) (+ x 1)) +is the procedure, and 42 is the argument. + +A (wrong) solution could be to evaluate each argument in turn, and +bind the corresponding parameter name (like x in this case) to the +resulting value (while saving the old value to be restored after we +return from the procedure). This is wrong because we must not +change the variable bindings until we actually enter the procedure -- +for example, with that algorithm ((lambda (x y) y) 1 x) would return +1, when it should return whatever the value of x is in the enclosing +environment. (The eval_rands()-type sequence would be: eval the 1, +bind x to 1, eval the x -- yielding 1 which is *wrong* -- and bind +y to that, then eval the body of the lambda.) + +Okay, that's easily fixed -- evaluate all the operands and stash them +away somewhere until you're done, and *then* do the bindings. So +the question is where to stash them. How about a global array? +Like + + for (i = 0; arglist != NIL; ++i) { + global_temp[i] = eval(car[arglist]) + arglist = cdr[arglist] + } + +followed by the equivalent of extend_env(). This will not do, because +the global array will get clobbered in recursive calls to eval(). +Consider (+ 2 (* 3 4)) -- first we evaluate the arguments to the +, +like this: global_temp[0] gets 2, and then global_temp[1] gets the +eval of (* 3 4). But in evaluating (* 3 4), global_temp[0] gets set +to 3 and global_temp[1] to 4 -- so the original assignment of 2 to +global_temp[0] is clobbered before we get a chance to use it. By +using a stack[] instead of a global_temp[], we finesse this problem. + +You may object that we can solve that by just making the global array +local, and that's true; lots of small local arrays may or may not be +more efficient than one big global stack, in awk -- we'd have to try +it out to see. But the real problem I alluded to at the start of this +message is this: the garbage collector has to be able to find all the +live references to the car[] and cdr[] arrays. If some of those +references are hidden away in local variables of recursive procedures, +we're stuck. With the global stack, they're all right there for the +gc(). + +(In C we could use the local-arrays approach by threading a chain of +pointers from each one to the next; but awk doesn't have pointers.) + +(You may wonder how the code gets away with having a number of local +variables holding lisp values, then -- the answer is that in every +such case we can be sure the garbage collector can find the values +in question from some other source. That's what this comment is +about: + +# All the interpretation routines have the precondition that their +# arguments are protected from garbage collection. + +In some cases where the values would not otherwise be guaranteed to +be available to the gc, we call protect().) + +Oh, there's another reason why apply() doesn't evaluate the arguments +itself: it's called by do_apply(), which handles lisp calls like +(apply car '((x))) -- where we *don't* want the x to get evaluated +by apply(). + + +4. Um, what I was going to write about + +more on data representation +is_foo procedures slow it down by a few percent but increase clarity +(try replacing them and other stuff with macros, time it.) + +gc: overview; how to write gc-safe code using protect(); point out + that relocating gcs introduce further complications + +driver loop, macros + +evaluation +globals for temp values because of recursion, space efficiency +environment -- explicit stack needed because of gc + +error handling, or lack thereof +strategies for cheaply adding error recovery + +I/O diff --git a/ase/test/awk/lisp/Manual b/ase/test/awk/lisp/Manual new file mode 100644 index 00000000..88d52ddf --- /dev/null +++ b/ase/test/awk/lisp/Manual @@ -0,0 +1,238 @@ + awklisp: a Lisp interpreter in awk + version 1.2 + + Darius Bacon + darius@accesscom.com + http://www.accesscom.com/~darius/ + + +1. Usage + + mawk [-v profiling=1] -f awklisp + +The -v profiling=1 option turns call-count profiling on. + +If you want to use it interactively, be sure to include '-' (for the standard +input) among the source files. For example: + + mawk -f awklisp startup - + +It should work with nawk and gawk, too, but even less quickly. + + +2. Overview + +This program arose out of one-upmanship. At my previous job I had to +use MapBasic, an interpreter so astoundingly slow (around 100 times +slower than GWBASIC) that one must wonder if it itself is implemented +in an interpreted language. I still wonder, but it clearly could be: +a bare-bones Lisp in awk, hacked up in a few hours, ran substantially +faster. Since then I've added features and polish, in the hope of +taking over the burgeoning market for stately language +implementations. + +This version tries to deal with as many of the essential issues in +interpreter implementation as is reasonable in awk (though most would +call this program utterly unreasonable from start to finish, perhaps...). +Awk's impoverished control structures put error recovery and tail-call +optimization out of reach, in that I can't see a non-painful way to code +them. The scope of variables is dynamic because that was easier to +implement efficiently. Subject to all those constraints, the language +is as Schemely as I could make it: it has a single namespace with +uniform evaluation of expressions in the function and argument positions, +and the Scheme names for primitives and special forms. + +The rest of this file is a reference manual. My favorite tutorial would be +_The Little LISPer_ (see section 5, References); don't let the cute name +and the cartoons turn you off, because it's a really excellent book with +some mind-stretching material towards the end. All of its code will work +with awklisp, except for the last two chapters. (You'd be better off +learning with a serious Lisp implementation, of course.) + +The file Impl-notes in this distribution gives an overview of the +implementation. + + +3. Expressions and their evaluation + +Lisp evaluates expressions, which can be simple (atoms) or compound (lists). + +An atom is a string of characters, which can be letters, digits, and most +punctuation; the characters may -not- include spaces, quotes, parentheses, +brackets, '.', '#', or ';' (the comment character). In this Lisp, case is +significant ( X is different from x ). + +Atoms: atom 42 1/137 + ok? hey:names-with-dashes-are-easy-to-read +Not atoms: don't-include-quotes (or spaces or parentheses) + +A list is a '(', followed by zero or more objects (each of which is an atom +or a list), followed by a ')'. + +Lists: () (a list of atoms) ((a list) of atoms (and lists)) +Not lists: ) ((()) (two) (lists) + +The special object nil is both an atom and the empty list. That is, +nil = (). A non-nil list is called a -pair-, because it is represented by a +pair of pointers, one to the first element of the list (its -car-), and one to +the rest of the list (its -cdr-). For example, the car of ((a list) of stuff) +is (a list), and the cdr is (of stuff). It's also possible to have a pair +whose cdr is not a list; the pair with car A and cdr B is printed as (A . B). + +That's the syntax of programs and data. Now let's consider their meaning. You +can use Lisp like a calculator: type in an expression, and Lisp prints its +value. If you type 25, it prints 25. If you type (+ 2 2), it prints 4. In +general, Lisp evaluates a particular expression in a particular environment +(set of variable bindings) by following this algorithm: + +If the expression is a number, return that number. + +If the expression is a non-numeric atom (a -symbol-), return the value of that +symbol in the current environment. If the symbol is currently unbound, that's +an error. + +Otherwise the expression is a list. If its car is one of the symbols: quote, +lambda, if, begin, while, set!, or define, then the expression is a -special- +-form-, handled by special rules. Otherwise it's just a procedure call, +handled like this: evaluate each element of the list in the current environment, +and then apply the operator (the value of the car) to the operands (the values +of the rest of the list's elements). For example, to evaluate (+ 2 3), we +first evaluate each of its subexpressions: the value of + is (at least in the +initial environment) the primitive procedure that adds, the value of 2 is 2, +and the value of 3 is 3. Then we call the addition procedure with 2 and 3 as +arguments, yielding 5. For another example, take (- (+ 2 3) 1). Evaluating +each subexpression gives the subtraction procedure, 5, and 1. Applying the +procedure to the arguments gives 4. + +We'll see all the primitive procedures in the next section. A user-defined +procedure is represented as a list of the form (lambda ), +such as (lambda (x) (+ x 1)). To apply such a procedure, evaluate its body +in the environment obtained by extending the current environment so that the +parameters are bound to the corresponding arguments. Thus, to apply the above +procedure to the argument 41, evaluate (+ x 1) in the same environment as the +current one except that x is bound to 41. + +If the procedure's body has more than one expression -- e.g., +(lambda () (write 'Hello) (write 'world!)) -- evaluate them each in turn, and +return the value of the last one. + +We still need the rules for special forms. They are: + +The value of (quote ) is . There's a shorthand for this form: '. +E.g., the value of '(+ 2 2) is (+ 2 2), -not- 4. + +(lambda ) returns itself: e.g., the value of (lambda (x) x) +is (lambda (x) x). + +To evaluate (if ), first evaluate . +If the value is true (non-nil), then return the value of , otherwise +return the value of . ( is optional; if it's left out, +pretend there's a nil there.) Example: (if nil 'yes 'no) returns no. + +To evaluate (begin ...), evaluate each of the subexpressions +in order, returning the value of the last one. + +To evaluate (while ...), first evaluate . If +it's nil, return nil. Otherwise, evaluate , ,... in order, +and then repeat. + +To evaluate (set! ), evaluate , and then set the value +of in the current environment to the result. If the variable is +currently unbound, that's an error. The value of the whole set! expression +is the value of . + +(define ) is like set!, except it's used to introduce new +bindings, and the value returned is . + +It's possible to define new special forms using the macro facility provided in +the startup file. The macros defined there are: + +(let (( )...) + ...) + + Bind each to its corresponding (evaluated in the current + environment), and evaluate in the resulting environment. + +(cond ( ...)... (else ...)) + + where the final else clause is optional. Evaluate each in + turn, and for the first non-nil result, evaluate its . If + none are non-nil, and there's no else clause, return nil. + +(and ...) + + Evaluate each in order, until one returns nil; then return nil. + If none are nil, return the value of the last . + +(or ...) + + Evaluate each in order, until one returns non-nil; return that value. + If all are nil, return nil. + + +4. Built-in procedures + +List operations: +(null? ) returns true (non-nil) when is nil. +(atom? ) returns true when is an atom. +(pair? ) returns true when is a pair. +(car ) returns the car of . +(cdr ) returns the cdr of . +(cadr ) returns the car of the cdr of . (i.e., the second element.) +(cddr ) returns the cdr of the cdr of . +(cons ) returns a new pair whose car is and whose cdr is . +(list ...) returns a list of its arguments. +(set-car! ) changes the car of to . +(set-cdr! ) changes the cdr of to . +(reverse! ) reverses in place, returning the result. + +Numbers: +(number? ) returns true when is a number. +(+ ) returns the sum of its arguments. +(- ) returns the difference of its arguments. +(* ) returns the product of its arguments. +(quotient ) returns the quotient. Rounding is towards zero. +(remainder ) returns the remainder. +(< ) returns true when is less than . + +I/O: +(write ) writes followed by a space. +(newline) writes the newline character. +(read) reads the next expression from standard input and returns it. + +Meta-operations: +(eval ) evaluates in the current environment, returning the result. +(apply ) calls with arguments , returning the result. + +Miscellany: +(eq? ) returns true when and are the same object. Be careful + using eq? with lists, because (eq? (cons ) (cons )) is false. +(put ) +(get ) returns the last value that was put for and , or nil + if there is no such value. +(symbol? ) returns true when is a symbol. +(gensym) returns a new symbol distinct from all symbols that can be read. +(random ) returns a random integer between 0 and -1 (if is positive). +(error ...) writes its arguments and aborts with error code 1. + + +5. References + +Harold Abelson and Gerald J. Sussman, with Julie Sussman. + Structure and Interpretation of Computer Programs. MIT Press, 1985. + +John Allen. Anatomy of Lisp. McGraw-Hill, 1978. + +Daniel P. Friedman and Matthias Felleisen. The Little LISPer. Macmillan, 1989. + +Roger Rohrbach wrote a Lisp interpreter, in old awk (which has no +procedures!), called walk . It can't do as much as this Lisp, but it +certainly has greater hack value. Cooler name, too. It's available at +http://www-2.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/impl/awk/0.html + + +6. Bugs + +Eval doesn't check the syntax of expressions. This is a probably-misguided +attempt to bump up the speed a bit, that also simplifies some of the code. +The macroexpander in the startup file would be the best place to add syntax- +checking. diff --git a/ase/test/awk/lisp/README b/ase/test/awk/lisp/README new file mode 100644 index 00000000..7102826f --- /dev/null +++ b/ase/test/awk/lisp/README @@ -0,0 +1,30 @@ +See the Manual file for documentation. + +This release also has a Perl version, perlisp, contributed by the Perl +Avenger, who writes: + + It has new primitives: a reentrant "load", a "trace" command, and more + error reporting. Perlisp will attempt to load a program called + "testme" before anything else, when it runs. After that, it will load + $HOME/.perlisprc if that file exists, before reverting to the + interactive read/eval/print loop. + +The awk code is still essentially the code posted to alt.sources (May +31, 1994), but with a garbage collector added. + + +Copyright (c) 1994, 2001 by Darius Bacon. + +Permission is granted to anyone to use this software for any +purpose on any computer system, and to redistribute it freely, +subject to the following restrictions: + +1. The author is not responsible for the consequences of use of + this software, no matter how awful, even if they arise from + defects in it. + +2. The origin of this software must not be misrepresented, either + by explicit claim or by omission. + +3. Altered versions must be plainly marked as such, and must not + be misrepresented as being the original software. diff --git a/ase/test/awk/lisp.awk b/ase/test/awk/lisp/awklisp similarity index 53% rename from ase/test/awk/lisp.awk rename to ase/test/awk/lisp/awklisp index a2d37247..afe187df 100644 --- a/ase/test/awk/lisp.awk +++ b/ase/test/awk/lisp/awklisp @@ -7,282 +7,6 @@ # of ASEAWK. # -# <> -# -# See the Manual file for documentation. -# -# This release also has a Perl version, perlisp, contributed by the Perl -# Avenger, who writes: -# -# It has new primitives: a reentrant "load", a "trace" command, and more -# error reporting. Perlisp will attempt to load a program called -# "testme" before anything else, when it runs. After that, it will load -# $HOME/.perlisprc if that file exists, before reverting to the -# interactive read/eval/print loop. -# -# The awk code is still essentially the code posted to alt.sources (May -# 31, 1994), but with a garbage collector added. -# -# -# Copyright (c) 1994, 2001 by Darius Bacon. -# -# Permission is granted to anyone to use this software for any -# purpose on any computer system, and to redistribute it freely, -# subject to the following restrictions: -# -# 1. The author is not responsible for the consequences of use of -# this software, no matter how awful, even if they arise from -# defects in it. -# -# 2. The origin of this software must not be misrepresented, either -# by explicit claim or by omission. -# -# 3. Altered versions must be plainly marked as such, and must not -# be misrepresented as being the original software. - -# <> -# -# awklisp: a Lisp interpreter in awk -# version 1.2 -# -# Darius Bacon -# darius@accesscom.com -# http://www.accesscom.com/~darius/ -# -# -# 1. Usage -# -# mawk [-v profiling=1] -f awklisp -# -# The -v profiling=1 option turns call-count profiling on. -# -# If you want to use it interactively, be sure to include '-' (for the standard -# input) among the source files. For example: -# -# mawk -f awklisp startup - -# -# It should work with nawk and gawk, too, but even less quickly. -# -# -# 2. Overview -# -# This program arose out of one-upmanship. At my previous job I had to -# use MapBasic, an interpreter so astoundingly slow (around 100 times -# slower than GWBASIC) that one must wonder if it itself is implemented -# in an interpreted language. I still wonder, but it clearly could be: -# a bare-bones Lisp in awk, hacked up in a few hours, ran substantially -# faster. Since then I've added features and polish, in the hope of -# taking over the burgeoning market for stately language -# implementations. -# -# This version tries to deal with as many of the essential issues in -# interpreter implementation as is reasonable in awk (though most would -# call this program utterly unreasonable from start to finish, perhaps...). -# Awk's impoverished control structures put error recovery and tail-call -# optimization out of reach, in that I can't see a non-painful way to code -# them. The scope of variables is dynamic because that was easier to -# implement efficiently. Subject to all those constraints, the language -# is as Schemely as I could make it: it has a single namespace with -# uniform evaluation of expressions in the function and argument positions, -# and the Scheme names for primitives and special forms. -# -# The rest of this file is a reference manual. My favorite tutorial would be -# _The Little LISPer_ (see section 5, References); don't let the cute name -# and the cartoons turn you off, because it's a really excellent book with -# some mind-stretching material towards the end. All of its code will work -# with awklisp, except for the last two chapters. (You'd be better off -# learning with a serious Lisp implementation, of course.) -# -# The file Impl-notes in this distribution gives an overview of the -# implementation. -# -# -# 3. Expressions and their evaluation -# -# Lisp evaluates expressions, which can be simple (atoms) or compound (lists). -# -# An atom is a string of characters, which can be letters, digits, and most -# punctuation; the characters may -not- include spaces, quotes, parentheses, -# brackets, '.', '#', or ';' (the comment character). In this Lisp, case is -# significant ( X is different from x ). -# -# Atoms: atom 42 1/137 + ok? hey:names-with-dashes-are-easy-to-read -# Not atoms: don't-include-quotes (or spaces or parentheses) -# -# A list is a '(', followed by zero or more objects (each of which is an atom -# or a list), followed by a ')'. -# -# Lists: () (a list of atoms) ((a list) of atoms (and lists)) -# Not lists: ) ((()) (two) (lists) -# -# The special object nil is both an atom and the empty list. That is, -# nil = (). A non-nil list is called a -pair-, because it is represented by a -# pair of pointers, one to the first element of the list (its -car-), and one to -# the rest of the list (its -cdr-). For example, the car of ((a list) of stuff) -# is (a list), and the cdr is (of stuff). It's also possible to have a pair -# whose cdr is not a list; the pair with car A and cdr B is printed as (A . B). -# -# That's the syntax of programs and data. Now let's consider their meaning. You -# can use Lisp like a calculator: type in an expression, and Lisp prints its -# value. If you type 25, it prints 25. If you type (+ 2 2), it prints 4. In -# general, Lisp evaluates a particular expression in a particular environment -# (set of variable bindings) by following this algorithm: -# -# If the expression is a number, return that number. -# -# If the expression is a non-numeric atom (a -symbol-), return the value of that -# symbol in the current environment. If the symbol is currently unbound, that's -# an error. -# -# Otherwise the expression is a list. If its car is one of the symbols: quote, -# lambda, if, begin, while, set!, or define, then the expression is a -special- -# -form-, handled by special rules. Otherwise it's just a procedure call, -# handled like this: evaluate each element of the list in the current environment, -# and then apply the operator (the value of the car) to the operands (the values -# of the rest of the list's elements). For example, to evaluate (+ 2 3), we -# first evaluate each of its subexpressions: the value of + is (at least in the -# initial environment) the primitive procedure that adds, the value of 2 is 2, -# and the value of 3 is 3. Then we call the addition procedure with 2 and 3 as -# arguments, yielding 5. For another example, take (- (+ 2 3) 1). Evaluating -# each subexpression gives the subtraction procedure, 5, and 1. Applying the -# procedure to the arguments gives 4. -# -# We'll see all the primitive procedures in the next section. A user-defined -# procedure is represented as a list of the form (lambda ), -# such as (lambda (x) (+ x 1)). To apply such a procedure, evaluate its body -# in the environment obtained by extending the current environment so that the -# parameters are bound to the corresponding arguments. Thus, to apply the above -# procedure to the argument 41, evaluate (+ x 1) in the same environment as the -# current one except that x is bound to 41. -# -# If the procedure's body has more than one expression -- e.g., -# (lambda () (write 'Hello) (write 'world!)) -- evaluate them each in turn, and -# return the value of the last one. -# -# We still need the rules for special forms. They are: -# -# The value of (quote ) is . There's a shorthand for this form: '. -# E.g., the value of '(+ 2 2) is (+ 2 2), -not- 4. -# -# (lambda ) returns itself: e.g., the value of (lambda (x) x) -# is (lambda (x) x). -# -# To evaluate (if ), first evaluate . -# If the value is true (non-nil), then return the value of , otherwise -# return the value of . ( is optional; if it's left out, -# pretend there's a nil there.) Example: (if nil 'yes 'no) returns no. -# -# To evaluate (begin ...), evaluate each of the subexpressions -# in order, returning the value of the last one. -# -# To evaluate (while ...), first evaluate . If -# it's nil, return nil. Otherwise, evaluate , ,... in order, -# and then repeat. -# -# To evaluate (set! ), evaluate , and then set the value -# of in the current environment to the result. If the variable is -# currently unbound, that's an error. The value of the whole set! expression -# is the value of . -# -# (define ) is like set!, except it's used to introduce new -# bindings, and the value returned is . -# -# It's possible to define new special forms using the macro facility provided in -# the startup file. The macros defined there are: -# -# (let (( )...) -# ...) -# -# Bind each to its corresponding (evaluated in the current -# environment), and evaluate in the resulting environment. -# -# (cond ( ...)... (else ...)) -# -# where the final else clause is optional. Evaluate each in -# turn, and for the first non-nil result, evaluate its . If -# none are non-nil, and there's no else clause, return nil. -# -# (and ...) -# -# Evaluate each in order, until one returns nil; then return nil. -# If none are nil, return the value of the last . -# -# (or ...) -# -# Evaluate each in order, until one returns non-nil; return that value. -# If all are nil, return nil. -# -# -# 4. Built-in procedures -# -# List operations: -# (null? ) returns true (non-nil) when is nil. -# (atom? ) returns true when is an atom. -# (pair? ) returns true when is a pair. -# (car ) returns the car of . -# (cdr ) returns the cdr of . -# (cadr ) returns the car of the cdr of . (i.e., the second element.) -# (cddr ) returns the cdr of the cdr of . -# (cons ) returns a new pair whose car is and whose cdr is . -# (list ...) returns a list of its arguments. -# (set-car! ) changes the car of to . -# (set-cdr! ) changes the cdr of to . -# (reverse! ) reverses in place, returning the result. -# -# Numbers: -# (number? ) returns true when is a number. -# (+ ) returns the sum of its arguments. -# (- ) returns the difference of its arguments. -# (* ) returns the product of its arguments. -# (quotient ) returns the quotient. Rounding is towards zero. -# (remainder ) returns the remainder. -# (< ) returns true when is less than . -# -# I/O: -# (write ) writes followed by a space. -# (newline) writes the newline character. -# (read) reads the next expression from standard input and returns it. -# -# Meta-operations: -# (eval ) evaluates in the current environment, returning the result. -# (apply ) calls with arguments , returning the result. -# -# Miscellany: -# (eq? ) returns true when and are the same object. Be careful -# using eq? with lists, because (eq? (cons ) (cons )) is false. -# (put ) -# (get ) returns the last value that was put for and , or nil -# if there is no such value. -# (symbol? ) returns true when is a symbol. -# (gensym) returns a new symbol distinct from all symbols that can be read. -# (random ) returns a random integer between 0 and -1 (if is positive). -# (error ...) writes its arguments and aborts with error code 1. -# -# -# 5. References -# -# Harold Abelson and Gerald J. Sussman, with Julie Sussman. -# Structure and Interpretation of Computer Programs. MIT Press, 1985. -# -# John Allen. Anatomy of Lisp. McGraw-Hill, 1978. -# -# Daniel P. Friedman and Matthias Felleisen. The Little LISPer. Macmillan, 1989. -# -# Roger Rohrbach wrote a Lisp interpreter, in old awk (which has no -# procedures!), called walk . It can't do as much as this Lisp, but it -# certainly has greater hack value. Cooler name, too. It's available at -# http://www-2.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/impl/awk/0.html -# -# -# 6. Bugs -# -# Eval doesn't check the syntax of expressions. This is a probably-misguided -# attempt to bump up the speed a bit, that also simplifies some of the code. -# The macroexpander in the startup file would be the best place to add syntax- -# checking. - - - # --- Representation of Lisp data BEGIN { diff --git a/ase/test/awk/lisp/eliza.lsp b/ase/test/awk/lisp/eliza.lsp new file mode 100644 index 00000000..2585f5bf --- /dev/null +++ b/ase/test/awk/lisp/eliza.lsp @@ -0,0 +1,140 @@ +; Simple Eliza program -- see Norvig, _Paradigms of AI Programming_. +; Uses: startup lists + +(define rule-pattern car) +(define rule-answers cdr) + +(define rules + '(((hello) + (How do you do -- please state your problem)) + ((I want) + (What would it mean if you got -R-) + (Why do you want -R-) + (Suppose you got -R- soon)) + ((if) + (Do you really think its likely that -R-) + (Do you wish that -R-) + (What do you think about -R-) + (Really-- if -R-)) + ((I was) + (Were you really?) + (Perhaps I already knew you were -R-) + (Why do you tell me you were -R- now?)) + ((I am) + (In what way are you -R-) + (Do you want to be -R-)) + ((because) + (Is that the real reason?) + (What other reasons might there be?) + (Does that reason seem to explain anything else?)) + ((I feel) + (Do you often feel -R-)) + ((I felt) + (What other feelings do you have?)) + ((yes) + (You seem quite positive) + (You are sure) + (I understand)) + ((no) + (Why not?) + (You are being a bit negative) + (Are you saying no just to be negative?)) + ((someone) + (Can you be more specific?)) + ((everyone) + (Surely not everyone) + (Can you think of anyone in particular?) + (Who for example?) + (You are thinking of a special person)) + ((perhaps) + (You do not seem quite certain)) + ((are) + (Did you think they might not be -R-) + (Possibly they are -R-)) + (() + (Very interesting) + (I am not sure I understand you fully) + (What does that suggest to you?) + (Please continue) + (Go on) + (Do you feel strongly about discussing such things?)))) + +(define eliza + (lambda () + (say '(Hello-- please state your problem)) + (let ((sentence '*)) + (while (begin + (write '>) + (not (eq? the-eof-object (set! sentence (read))))) + (say (eliza-answer sentence)))))) + +(define eliza-answer + (lambda (sentence) + (some + (lambda (rule) + (let ((env (match (rule-pattern rule) sentence))) + (and env + (flatten + (sublis (switch-roles env) + (random-element (rule-answers rule))))))) + rules))) + +(define switch-roles + (lambda (words) + (sublis '(('I . 'you) ('you . 'I) ('me . 'you) ('am . 'are)) + words))) + +; Matching + +; If sublist is a sublist of lst , then return an a-list with -R- bound to +; the part of lst after sublist . Else return nil. +(define match + (lambda (sublist lst) + (cond + ((matches-head? sublist lst) + (list (cons '-R- (after-head sublist lst)))) + ((null? lst) nil) + (else (match sublist (cdr lst)))))) + +(define matches-head? + (lambda (alleged-head lst) + (cond + ((null? lst) (null? alleged-head)) + ((null? alleged-head) t) + (else + (and (eq? (car alleged-head) (car lst)) + (matches-head? (cdr alleged-head) (cdr lst))))))) + +(define after-head + (lambda (head lst) + (if (null? head) + lst + (after-head (cdr head) (cdr lst))))) + +; Help functions + +(define some + (lambda (test? lst) + (let ((result nil)) + (while (and lst (not (set! result (test? (car lst))))) + (set! lst (cdr lst))) + result))) + +(define flatten + (lambda (lst) + (cond + ((null? lst) '()) + ((null? (car lst)) (flatten (cdr lst))) + ((atom? (car lst)) + (cons (car lst) (flatten (cdr lst)))) + (else (append (flatten (car lst)) + (flatten (cdr lst))))))) + +(define say + (lambda (sentence) + (for-each write sentence) + (newline))) + +(define random-element + (lambda (lst) + (list-ref lst (random (length lst))))) diff --git a/ase/test/awk/lisp/fib.lsp b/ase/test/awk/lisp/fib.lsp new file mode 100644 index 00000000..70898acc --- /dev/null +++ b/ase/test/awk/lisp/fib.lsp @@ -0,0 +1,7 @@ +(define fib + (lambda (n) + (if (< n 2) + 1 + (+ (fib (- n 1)) + (fib (- n 2)))))) +(fib 20) diff --git a/ase/test/awk/lisp/lists b/ase/test/awk/lisp/lists new file mode 100644 index 00000000..d6511c30 --- /dev/null +++ b/ase/test/awk/lisp/lists @@ -0,0 +1,69 @@ +; List-processing procedures +; Uses: startup + +(define reverse + (lambda (L) (revappend L '()))) + +(define revappend + (lambda (L1 L2) + (while L1 + (set! L2 (cons (car L1) L2)) + (set! L1 (cdr L1))) + L2)) + +(define append! + (lambda (L1 L2) + (set-cdr! (last-pair L1) L2) + L1)) + +(define last-pair + (lambda (lst) + (while (cdr lst) + (set! lst (cdr lst))) + lst)) + +(define memq (lambda (x lst) (member:test eq? x lst))) +(define member (lambda (x lst) (member:test equal? x lst))) + +(define member:test + (lambda (=? x lst) + (while (and lst (not (=? x (car lst)))) + (set! lst (cdr lst))) + lst)) + +(define assq (lambda (key pairs) (assoc:test eq? key pairs))) +(define assoc (lambda (key pairs) (assoc:test equal? key pairs))) + +(define assoc:test + (lambda (=? key pairs) + (while (and pairs (not (=? key (caar pairs)))) + (set! pairs (cdr pairs))) + (and pairs (car pairs)))) + +(define sublis + (lambda (a-list exp) + (cond + ((null? exp) '()) + ((atom? exp) + (let ((binding (assq exp a-list))) + (if binding (cdr binding) exp))) + (else + (cons (sublis a-list (car exp)) + (sublis a-list (cdr exp))))))) + +(define remove + (lambda (key lst) + (if (null? lst) + '() + (if (eq? key (car lst)) + (cdr lst) + (cons (car lst) + (remove key (cdr lst))))))) + +(define list-ref + (lambda (lst n) + (if (null? lst) + '() + (if (= n 0) + (car lst) + (list-ref (cdr lst) (- n 1)))))) diff --git a/ase/test/awk/lisp/numbers b/ase/test/awk/lisp/numbers new file mode 100644 index 00000000..c7851201 --- /dev/null +++ b/ase/test/awk/lisp/numbers @@ -0,0 +1,33 @@ +; Numeric procedures +; Uses: startup + +(define > (lambda (n1 n2) (< n2 n1))) +(define <= (lambda (n1 n2) (not (< n2 n1)))) +(define >= (lambda (n1 n2) (not (< n1 n2)))) + +(define abs + (lambda (n) + (if (< n 0) (- 0 n) n))) + +(define minus (lambda (n) (- 0 n))) + +(define even? (lambda (n) (= (remainder n 2) 0))) +(define odd? (lambda (n) (not (even? n)))) + +(define zero? (lambda (n) (= n 0))) + +(define 1+ (lambda (n) (+ n 1))) +(define -1+ (lambda (n) (- n 1))) + +(define min (lambda (n1 n2) (if (< n1 n2) n1 n2))) +(define max (lambda (n1 n2) (if (< n1 n2) n2 n1))) + +(define expt ; Pre: 0 <= power + (lambda (base power) + (if (= power 0) + 1 + (if (even? power) + (square (expt base (quotient power 2))) + (* base (expt base (- power 1))))))) + +(define square (lambda (n) (* n n))) diff --git a/ase/test/awk/lisp/old-awklisp b/ase/test/awk/lisp/old-awklisp new file mode 100644 index 00000000..eb050a5a --- /dev/null +++ b/ase/test/awk/lisp/old-awklisp @@ -0,0 +1,517 @@ +#!/usr/bin/gawk -f + +# GNU Awk 3.0.4 crashes on the most recent awklisp, so here's the old +# version for you to use instead. + + +# --- Representation of Lisp data + +BEGIN { + a_number = 0 + pair_ptr = a_pair = 1 + symbol_ptr = a_symbol = 2 + + type_name[a_number] = "number" + type_name[a_pair] = "pair" + type_name[a_symbol] = "symbol" +} + +function is(type, expr) +{ + if (expr % 4 != type) + error("Expected a " type_name[type] ", not a " type_name[expr % 4]) + return expr +} + +function is_number(expr) { return expr % 4 == 0 } +function is_pair(expr) { return expr % 4 == 1 } +function is_symbol(expr) { return expr % 4 == 2 } +function is_atom(expr) { return expr % 4 != 1 } + +function make_number(n) { return n * 4 } + +function numeric_value(expr) +{ + if (expr % 4 != 0) error("Not a number") + return expr / 4 +} + +# Make a new pair. +function cons(the_car, the_cdr) +{ + if (free_list == NIL) + gc(the_car, the_cdr) + result = free_list + free_list = cdr[free_list] + car[result] = the_car + cdr[result] = the_cdr + return result +} + +# Return the symbol :string names. +function string_to_symbol(string) +{ + if (string in intern) + return intern[string] + symbol_ptr += 4 + intern[string] = symbol_ptr + printname[symbol_ptr] = string + return symbol_ptr +} + +# Define a primitive procedure, with :nparams parameters, +# bound to the symbol named :name. +function def_prim(name, nparams, sym) +{ + sym = string_to_symbol(name) + value[sym] = string_to_symbol(sprintf("#", name)) + if (nparams != "") + num_params[value[sym]] = nparams + return value[sym] +} + +# --- Garbage collection + +function expand_heap( limit) +{ + if (loud_gc) + printf("Expanding heap...") >"/dev/stderr" + limit = pair_ptr + 4 * (heap_increment ? heap_increment : 1500) + for (; pair_ptr < limit; pair_ptr += 4) { + cdr[pair_ptr] = free_list + free_list = pair_ptr + } +} + +function protect(object) { protected[++protected_ptr] = object } +function unprotect() { --protected_ptr } + +function mark(object) +{ + while (is_pair(object) && !(object in marks)) { #** speed + marks[object] = 1 + mark(car[object]) + object = cdr[object] + } +} + +function sweep() +{ + free_list = NIL + for (p = a_pair; p < pair_ptr; p += 4) # for (p in car) might be faster + if (!(p in marks)) { + cdr[p] = free_list + free_list = p + } else + delete marks[p] +} + +function gc(the_car, the_cdr, p, i) +{ + if (loud_gc) + printf("\nGC...") >"/dev/stderr" + mark(the_car); mark(the_cdr) + for (p in protected) + mark(protected[p]) + for (p in stack) + mark(stack[p]) + for (p in value) + mark(value[p]) + for (p in property) { + i = index(SUBSEP, p) + mark(substr(p, 1, i-1)) + mark(substr(p, i+1)) + mark(property[p]) + } + sweep() + if (free_list == NIL) + expand_heap() +} + +# --- Set up + +BEGIN { + srand() + + frame_ptr = stack_ptr = 0 + + NIL = string_to_symbol("nil") + T = string_to_symbol("t") + + value[NIL] = NIL + value[T] = T + + car[NIL] = cdr[NIL] = NIL # this is convenient in a couple places... + + free_list = NIL; expand_heap() + THE_EOF_OBJECT = string_to_symbol("#eof") + value[string_to_symbol("the-eof-object")] = THE_EOF_OBJECT + + eof = "(eof)" + + QUOTE = string_to_symbol("quote"); is_special[QUOTE] = 1 + LAMBDA = string_to_symbol("lambda"); is_special[LAMBDA] = 1 + IF = string_to_symbol("if"); is_special[IF] = 1 + SETQ = string_to_symbol("set!"); is_special[SETQ] = 1 + DEFINE = string_to_symbol("define"); is_special[DEFINE] = 1 + PROGN = string_to_symbol("begin"); is_special[PROGN] = 1 + WHILE = string_to_symbol("while"); is_special[WHILE] = 1 + + EQ = def_prim("eq?", 2) + NULL = def_prim("null?", 1) + CAR = def_prim("car", 1) + CDR = def_prim("cdr", 1) + CADR = def_prim("cadr", 1) + CDDR = def_prim("cddr", 1) + CONS = def_prim("cons", 2) + LIST = def_prim("list") + EVAL = def_prim("eval", 1) + APPLY = def_prim("apply", 2) + READ = def_prim("read", 0) + WRITE = def_prim("write", 1) + NEWLINE = def_prim("newline", 0) + ADD = def_prim("+", 2) + SUB = def_prim("-", 2) + MUL = def_prim("*", 2) + DIV = def_prim("quotient", 2) + MOD = def_prim("remainder", 2) + LT = def_prim("<", 2) + GET = def_prim("get", 2) + PUT = def_prim("put", 3) + ATOMP = def_prim("atom?", 1) + PAIRP = def_prim("pair?", 1) + SYMBOLP = def_prim("symbol?", 1) + NUMBERP = def_prim("number?", 1) + SETCAR = def_prim("set-car!", 2) + SETCDR = def_prim("set-cdr!", 2) + NREV = def_prim("reverse!", 1) + GENSYM = def_prim("gensym", 0) + RANDOM = def_prim("random", 1) + ERROR = def_prim("error") + + DRIVER = string_to_symbol("top-level-driver") +} + +# --- The interpreter + +BEGIN { + for (;;) { + if (DRIVER in value && value[DRIVER] != NIL) + apply(value[DRIVER]) + else { + expr = read() + if (expr == THE_EOF_OBJECT) + break; + protect(expr) + print_expr(eval(expr)) + unprotect() + } + } + + if (profiling) + for (proc in call_count) { + printf("%5d ", call_count[proc]) + print_expr(proc) + } +} + +# All the interpretation routines have the precondition that their +# arguments are protected from garbage collection. + +function eval(expr, old_frame_ptr) +{ + if (is_atom(expr)) #** speed + if (is_symbol(expr)) { + if (!(expr in value)) error("Unbound variable: " printname[expr]) + return value[expr] + } else + return expr + + op = car[expr] # op is global to save awk stack space + + if (!(op in is_special)) { + old_frame_ptr = frame_ptr + frame_ptr = stack_ptr + + eval_rands(cdr[expr]) + protect(proc = eval(car[expr])) + result = apply(proc) + unprotect() + + stack_ptr = frame_ptr + frame_ptr = old_frame_ptr + return result + } + + if (op == QUOTE) return car[cdr[expr]] + if (op == LAMBDA) return expr + if (op == IF) return eval(car[cdr[expr]]) != NIL \ + ? eval(car[cdr[cdr[expr]]]) \ + : eval(car[cdr[cdr[cdr[expr]]]]) + if (op == PROGN) return progn(cdr[expr]) + if (op == SETQ) { + if (!(car[cdr[expr]] in value)) + error("Unbound variable: " printname[car[cdr[expr]]]) + return value[car[cdr[expr]]] = eval(car[cdr[cdr[expr]]]) + } + if (op == WHILE) { + while (eval(car[cdr[expr]]) != NIL) + progn(cdr[cdr[expr]]) + return NIL + } + if (op == DEFINE) { + value[car[cdr[expr]]] = eval(car[cdr[cdr[expr]]]) + return car[cdr[expr]] + } + + error("BUG: Unknown special form") +} + +# Evaluate a sequence of expressions, returning the last value. +function progn(exprs) +{ + for (; cdr[exprs] != NIL; exprs = cdr[exprs]) + eval(car[exprs]) + return eval(car[exprs]) +} + +# Evaluate the operands of a procedure, pushing the results on the stack. +function eval_rands(rands) +{ + for (; rands != NIL; rands = cdr[rands]) + stack[stack_ptr++] = eval(car[rands]) +} + +# Call the procedure :proc, with args stack[frame_ptr]..stack[stack_ptr-1] +# (in that order). +function apply(proc) +{ + if (profiling) + ++call_count[proc] + if (car[proc] == LAMBDA) { + extend_env(car[cdr[proc]]) + result = progn(cdr[cdr[proc]]) # result is global to save stack space + unwind_env(car[cdr[proc]]) + return result + } + if (proc in num_params && num_params[proc] != stack_ptr - frame_ptr) + error("Wrong number of arguments to " printname[cdr[proc]]) + + if (proc == CAR) return car[is(a_pair, stack[frame_ptr])] + if (proc == CDR) return cdr[is(a_pair, stack[frame_ptr])] + if (proc == CONS) return cons(stack[frame_ptr], stack[frame_ptr+1]) + if (proc == NULL) return stack[frame_ptr] == NIL ? T : NIL + if (proc == EQ) return stack[frame_ptr] == stack[frame_ptr+1] ? T : NIL + if (proc == ATOMP) return is_atom(stack[frame_ptr]) ? T : NIL + if (proc == ADD) return is(a_number, stack[frame_ptr]) + is(a_number, stack[frame_ptr+1]) + if (proc == SUB) return is(a_number, stack[frame_ptr]) - is(a_number, stack[frame_ptr+1]) + if (proc == MUL) return make_number(numeric_value(stack[frame_ptr]) * numeric_value(stack[frame_ptr+1])) + if (proc == DIV) return make_number(int(numeric_value(stack[frame_ptr]) / numeric_value(stack[frame_ptr+1]))) + if (proc == MOD) return make_number(numeric_value(stack[frame_ptr]) % numeric_value(stack[frame_ptr+1])) + if (proc == LT) return (stack[frame_ptr] + 0 < stack[frame_ptr+1] + 0) ? T : NIL + if (proc == GET) return (stack[frame_ptr], stack[frame_ptr+1]) in property ? property[stack[frame_ptr], stack[frame_ptr+1]] : NIL + if (proc == PUT) return property[stack[frame_ptr], stack[frame_ptr+1]] = stack[frame_ptr+2] + if (proc == CADR) return car[is(a_pair, cdr[is(a_pair, stack[frame_ptr])])] + if (proc == CDDR) return cdr[is(a_pair, cdr[is(a_pair, stack[frame_ptr])])] + if (proc == LIST) return listify_args() + if (proc == SYMBOLP)return is_symbol(stack[frame_ptr]) ? T : NIL + if (proc == PAIRP) return is_pair(stack[frame_ptr]) ? T : NIL + if (proc == NUMBERP)return is_number(stack[frame_ptr]) ? T : NIL + if (proc == SETCAR) return car[is(a_pair, stack[frame_ptr])] = stack[frame_ptr+1] + if (proc == SETCDR) return cdr[is(a_pair, stack[frame_ptr])] = stack[frame_ptr+1] + if (proc == APPLY) return do_apply(stack[frame_ptr], stack[frame_ptr+1]) + if (proc == EVAL) return eval(stack[frame_ptr]) + if (proc == NREV) return nreverse(stack[frame_ptr], NIL) + if (proc == WRITE) { write_expr(stack[frame_ptr]); printf(" "); return NIL } + if (proc == NEWLINE){ printf("\n"); return NIL } + if (proc == READ) return read() + if (proc == RANDOM) return make_number(int(rand() * numeric_value(stack[frame_ptr]))) + if (proc == GENSYM) return string_to_symbol("#G" ++gensym_counter) + if (proc == ERROR) { printf("Error!\n"); print_expr(listify_args()); exit(1) } + error("Unknown procedure type") +} + +function do_apply(proc, args, old_frame_ptr) +{ + old_frame_ptr = frame_ptr + frame_ptr = stack_ptr + + for (; is_pair(args); args = cdr[args]) + stack[stack_ptr++] = car[args] + if (args != NIL) + error("Bad argument to APPLY: not a proper list") + result = apply(proc) + + stack_ptr = frame_ptr + frame_ptr = old_frame_ptr + return result +} + +function listify_args( p, result) +{ + result = NIL + for (p = stack_ptr - 1; frame_ptr <= p; --p) + result = cons(stack[p], result) + return result +} + +# --- The environment +# The current environment is represented by the set of values +# value[sym] where sym is a symbol. extend_env(vars) adds a new +# set of bindings for vars, saving the old values; unwind_env(vars) +# restores those old values. The new value for the nth member of +# vars is frame_ptr[n]; coincidentally, that's also where we +# store away the old value, since that stack frame's not needed +# for anything else after the extend_env() call. + +function extend_env(vars, p, temp) +{ + for (p = frame_ptr; vars != NIL; vars = cdr[vars]) { + if (p == stack_ptr) + error("Too many arguments to procedure") + temp = value[car[vars]] + value[car[vars]] = stack[p] + stack[p] = temp + ++p + } + if (p != stack_ptr) + error("Not enough arguments to procedure") +} + +function unwind_env(vars, p) +{ + for (p = frame_ptr; vars != NIL; vars = cdr[vars]) { + if (stack[p] == "") + delete value[car[vars]] + else + value[car[vars]] = stack[p] + ++p + } +} + +# --- Output + +function print_expr(expr) +{ + write_expr(expr) + print "" +} + +function write_expr(expr) +{ + if (is_atom(expr)) { + if (!is_symbol(expr)) + printf("%d", numeric_value(expr)) + else { + if (!(expr in printname)) + error("BUG: " expr " has no printname") + printf("%s", printname[expr]) + } + } else { + printf("(") + write_expr(car[expr]) + for (expr = cdr[expr]; is_pair(expr); expr = cdr[expr]) { + printf(" ") + write_expr(car[expr]) + } + if (expr != NIL) { + printf(" . ") + write_expr(expr) + } + printf(")") + } +} + +# --- Input + +function read( committed, result) +{ + skip_blanks() + if (token == eof) + if (committed) + error("Unexpected EOF") + else + return THE_EOF_OBJECT + if (token == "(") { # read a list + advance() + result = NIL + for (;;) { + skip_blanks() + if (token == ".") { + advance() + after_dot = read(1) + skip_blanks() + if (token != ")") + error("')' expected") + advance() + return nreverse(result, after_dot) + } else if (token == ")") { + advance() + return nreverse(result, NIL) + } else { + protect(result) + result = cons(read(1), result) + unprotect() + } + } + } else if (token == "'") { # a quoted expression + advance() + return cons(QUOTE, cons(read(1), NIL)) + } else if (token ~ /^-?[0-9]+$/) { # a number + result = make_number(token) + advance() + return result + } else { # a symbol + result = string_to_symbol(token) + advance() + return result + } +} + +function skip_blanks() +{ + while (token ~ /^[ \t]*$/) + advance() +} + +function advance() +{ + if (token == eof) return eof + if (token == "") { + if (getline line <= 0) { + token = eof + return + } + } + if (match(line, "^[()'.]") || + match(line, "^[_A-Za-z0-9=!@$%&*<>?+\\-*/:]+") || + match(line, "^[ \\t]+")) { + token = substr(line, RSTART, RLENGTH) + line = substr(line, RLENGTH+1) + } else if (line == "" || substr(line, 1, 1) == ";") + token = "" # this kludge permits interactive use + else + error("Lexical error starting at " line) +} + +# --- Miscellany + +# Destructively reverse :list and append :reversed_head. +function nreverse(list, reversed_head, tail) +{ + while (is_pair(list)) { #** speed? + tail = cdr[list] + cdr[list] = reversed_head + reversed_head = list + list = tail + } + if (list != NIL) + error("Not a proper list - reverse!") + return reversed_head +} + +function error(reason) +{ + print "ERROR: " reason >"/dev/stderr" + exit(1) +} diff --git a/ase/test/awk/lisp/perlisp b/ase/test/awk/lisp/perlisp new file mode 100644 index 00000000..526274c0 --- /dev/null +++ b/ase/test/awk/lisp/perlisp @@ -0,0 +1,652 @@ +#!/usr/bin/perl + +use FileHandle; + +# --- Representation of Lisp data + + $a_number = 0; + $pair_ptr = $a_pair = 1; + $symbol_ptr = $a_symbol = 2; + + $type_name{$a_number} = "number"; + $type_name{$a_pair} = "pair"; + $type_name{$a_symbol} = "symbol"; + +sub is { + local($type, $expr)=@_; + if ($expr % 4 != $type) { + error(__LINE__,"Expected a ".$type_name{$type}.", not a " + . $type_name{$expr % 4}) ; + } + $expr; +} + +sub is_number { local($expr)=@_; $expr % 4 == 0; } +sub is_pair { local($expr)=@_; $expr % 4 == 1; } +sub is_symbol { local($expr)=@_; $expr % 4 == 2; } +sub is_atom { local($expr)=@_; $expr % 4 != 1; } + +sub make_number { local($n)=@_; $n * 4 ;} + +sub numeric_value { + local($expr)=@_; + if ($expr % 4 != 0) { error(__LINE__,"Not a number"); } + $expr / 4; +} + +# Make a new pair. +sub cons { + local($the_car, $the_cdr)= @_; + if ($free_list == $NIL) { gc($the_car, $the_cdr); } + $result = $free_list; + $free_list = $cdr{$free_list}; + $car{$result} = $the_car; + $cdr{$result} = $the_cdr; + $result; +} + +# Return the symbol :string names. +sub string_to_symbol{ + local($string)=@_; + if (defined ($intern{$string}) ) { return $intern{$string}; } + $symbol_ptr += 4; + $intern{$string} = $symbol_ptr; + $printname{$symbol_ptr} = $string; + $symbol_ptr; +} + +# Define a primitive procedure, with :nparams parameters, +# bound to the symbol named :name. +sub def_prim { + local($name, $nparams)=@_; + local($sym); + $sym = string_to_symbol($name); + $value{$sym} = string_to_symbol(sprintf("#", $name)); + if ($nparams ne "") { + $num_params{$value{$sym}} = $nparams; } + $value{$sym}; +} + +# --- Garbage collection + +sub expand_heap { + local($limit); + if ($loud_gc) { + printf STDERR "Expanding heap..." ; } + $limit = $pair_ptr + 4 * ($heap_increment ? $heap_increment : 1500); + for (; $pair_ptr < $limit; $pair_ptr += 4) { + $cdr{$pair_ptr} = $free_list; + $free_list = $pair_ptr; + } +} + +sub protect { local($object)=@_; $protected{++$protected_ptr} = $object; } +sub unprotect { --$protected_ptr; } + +sub mark { + local($object)=@_; + while (is_pair($object) && !(defined $marks{$object})) { #** speed + $marks{$object} = 1; + mark($car{$object}); + $object = $cdr{$object}; + } +} + +sub sweep { + $free_list = $NIL; + for ($p = $a_pair; $p < $pair_ptr; $p += 4) { # for defined($car{$p}) might be faster + if (!(defined $marks{$p})) { + $cdr{$p} = $free_list; + $free_list = $p; + } else { + delete $marks{$p}; + } + } +} + +sub gc { + local ($the_car, $the_cdr) = @_; + local($p, $i); + if ($loud_gc) { + printf STDERR "\nGC..." } + mark($the_car); mark($the_cdr); + for (defined $protected{$p}) { mark($protected{$p}); } + for (defined $stack{$p}) { mark($stack{$p}); } + for (defined $value{$p}) { mark($value{$p}); } + for (defined $property{$p}) { + $i = index($;, $p); # SUBSEP + mark(substr($p, 1, $i-1)); + mark(substr($p, $i+1)); + mark(property{$p}); + } + sweep(); + if ($free_list == $NIL) { expand_heap(); } +} + +# --- Set up + +# BEGIN { + $trace = 0; + $lineno = 0; + $filehandle = \*STDIN; + $filename = ''; + $interactive = 1; + @filestack = (); + $pline = "**prev**"; + $sline = "**BOF**"; + $gensym_counter=0; + srand(); + $token = ""; + + $frame_ptr = $stack_ptr = 0; + + $NIL = string_to_symbol("nil"); + $T = string_to_symbol("t"); + ; + $value{$NIL} = $NIL; + $value{$T} = $T; + ; + $car{$NIL} = $cdr{$NIL} = $NIL; # this is convenient in a couple places...; + + $free_list = $NIL; expand_heap(); + $THE_EOF_OBJECT = string_to_symbol("#eof"); + $value{string_to_symbol("the-eof-object")} = $THE_EOF_OBJECT; + ; + $eof = "(eof)"; + + $QUOTE = string_to_symbol("quote"); $is_special{$QUOTE} = 1; + $LAMBDA = string_to_symbol("lambda"); $is_special{$LAMBDA} = 1; + $IF = string_to_symbol("if"); $is_special{$IF} = 1; + $SETQ = string_to_symbol("set!"); $is_special{$SETQ} = 1; + $DEFINE = string_to_symbol("define"); $is_special{$DEFINE} = 1; + $PROGN = string_to_symbol("begin"); $is_special{$PROGN} = 1; + $WHILE = string_to_symbol("while"); $is_special{$WHILE} = 1; + + $QUIT = string_to_symbol("quit"); $is_special{$QUIT} = 1; + + $EQ = def_prim("eq?", 2); + $NULL = def_prim("null?", 1); + $CAR = def_prim("car", 1); + $CDR = def_prim("cdr", 1); + $CADR = def_prim("cadr", 1); + $CDDR = def_prim("cddr", 1); + $CONS = def_prim("cons", 2); + $LIST = def_prim("list"); + $EVAL = def_prim("eval", 1); + $APPLY = def_prim("apply", 2); + $LREAD = def_prim("read", 0); + $LWRITE = def_prim("write", 1); + + $LOAD = def_prim('load', 1); + $TRACE = def_prim('trace', 0); + $LINENO = def_prim('f_lineno', 0); + $INTER = def_prim('f_interactive', 0); + $FILE = def_prim('f_file', 0); + + $NEWLINE = def_prim("newline", 0); + $ADD = def_prim("+", 2); + $SUB = def_prim("-", 2); + $MUL = def_prim("*", 2); + $DIV = def_prim("quotient", 2); + $MOD = def_prim("remainder", 2); + $LT = def_prim("<", 2); + $GET = def_prim("get", 2); + $PUT = def_prim("put", 3); + $ATOMP = def_prim("atom?", 1); + $PAIRP = def_prim("pair?", 1); + $SYMBOLP = def_prim("symbol?", 1); + $NUMBERP = def_prim("number?", 1); + $SETCAR = def_prim("set-car!", 2); + $SETCDR = def_prim("set-cdr!", 2); + $NREV = def_prim("reverse!", 1); + $GENSYM = def_prim("gensym", 0); + $RANDOM = def_prim("random", 1); + $ERROR = def_prim("error"); + + $EXPLODE = def_prim("explode"); + $IMPLODE = def_prim("implode"); + $OPEN = def_prim("open"); + $CLOSE = def_prim("close"); + $READCHAR = def_prim("readchar"); + $WRITEFI = def_prim("writefi"); + $PRINTF = def_prim("printf"); + + $HASH = def_prim("hash"); + + $DRIVER = string_to_symbol("top-level-driver"); +# } + +# --- The interpreter + +# BEGIN { + $ts = "testme"; + if ( -f $ts ) { load($ts); } + $rc = "$ENV{'HOME'}/.perlisprc"; + if ( -f $rc ) { load($rc); } + + READLOOP: for (;;) { + eval { + for (;;) { + if (defined($value{$DRIVER}) && $value{$DRIVER} != $NIL) { + apply($value{$DRIVER}); + } else { + $expr = lread(); + if ($trace) { + print_expr($expr); + print "%$expr%\n"; } + if ($expr == $THE_EOF_OBJECT) { last READLOOP; } + protect($expr); + $result = l_eval($expr); + if ($interactive) { print "Interactive p e\n "; print_expr($result); } + unprotect(); + } + } + }; + print "\n\nRestarting\n\n"; + $frame_ptr = $stack_ptr = 0; + } + + if ($profiling) { + while (defined $call_count{$proc}) { + printf "%5d ", $call_count{$proc} ; + print_expr($proc); + } + } +# } + +# All the interpretation routines have the precondition that their +# arguments are protected from garbage collection. + +sub l_eval { + local($expr)=@_; + local($old_frame_ptr); + if (is_atom($expr)) { #** speed + if (is_symbol($expr)) { + if (!(defined $value{$expr} )) { + error(__LINE__,"Unbound variable: ".$printname{$expr}); } + return $value{$expr}; + } else { + return $expr; + } + } + + $op = $car{$expr}; # op is global to save awk stack space + + if ($trace) { print "eval called ".$printname{$op}. + " with ". ($stack_ptr - $frame_ptr) ." args" . "\n"; } + if (!(defined $is_special{$op})) { + $old_frame_ptr = $frame_ptr; + $frame_ptr = $stack_ptr; + + l_eval_rands($cdr{$expr}); + protect($tmp_proc = l_eval($car{$expr})); + $result = apply($tmp_proc); + unprotect(); + + $stack_ptr = $frame_ptr; + $frame_ptr = $old_frame_ptr; + return $result; + } + + if ($op == $QUOTE) { return $car{$cdr{$expr}}; } + if ($op == $LAMBDA) { return $expr; } + if ($op == $IF) { return ( l_eval($car{$cdr{$expr}}) != $NIL ) + ? l_eval($car{$cdr{$cdr{$expr}}}) + : l_eval($car{$cdr{$cdr{$cdr{$expr}}}}); }; + if ($op == $PROGN) { return progn($cdr{$expr}); }; + if ($op == $SETQ) { + if (! defined( $value{$car{$cdr{$expr}}} )) { + error(__LINE__,"Unbound variable: ".$printname{$car{$cdr{$expr}}}); + } + return $value{$car{$cdr{$expr}}} = l_eval($car{$cdr{$cdr{$expr}}}); + }; + if ($op == $WHILE) { + while (l_eval($car{$cdr{$expr}}) != $NIL) { + progn($cdr{$cdr{$expr}}); + } + return $NIL + } + if ($op == $DEFINE) { + $value{$car{$cdr{$expr}}} = l_eval($car{$cdr{$cdr{$expr}}}); + return $car{$cdr{$expr}}; + } + if ($op == $QUIT) { exit(); } + + error(__LINE__,"BUG: Unknown special form"); +} + +sub progn { + local ($exprs) = @_; + for (; $cdr{$exprs} != $NIL; $exprs = $cdr{$exprs}) { + l_eval($car{$exprs}); + } + return l_eval($car{$exprs}); +} + +sub l_eval_rands { + local ($rands) = @_; + for (; $rands != $NIL; $rands = $cdr{$rands}) { + $stack[$stack_ptr++] = l_eval($car{$rands}); + } +} + +sub apply { + local ($proc) = @_; + if ($profiling) { + ++$call_count[$proc]; + } + if (is_pair($proc) && $car{$proc} == $LAMBDA) { + extend_env($car{$cdr{$proc}}); + $result = progn($cdr{$cdr{$proc}});# result is global to save stack space + unwind_env($car{$cdr{$proc}}); + return $result; + } + if (defined($num_params{$proc}) && + $num_params{$proc} != $stack_ptr - $frame_ptr) { + error(__LINE__,'Wrong number of arguments to '.$printname{$cdr{$proc}}); } + if ($trace) { print "Proc called ".$printname{$cdr{$proc}}. + " with ". ($stack_ptr - $frame_ptr) ." args" . "\n"; } + if ($proc == $CAR) { return $car{ is($a_pair, $stack[$frame_ptr])}; } + if ($proc == $CDR) { return $cdr{ is($a_pair, $stack[$frame_ptr])}; } + if ($proc == $CONS) { return cons( $stack[$frame_ptr], $stack[$frame_ptr+1]); } + if ($proc == $NULL) { return $stack[$frame_ptr] == $NIL ? $T : $NIL;} + if ($proc == $EQ) { return $stack[$frame_ptr] == $stack[$frame_ptr+1] ? $T : $NIL} + if ($proc == $ATOMP){ return is_atom($stack[$frame_ptr]) ? $T : $NIL} + if ($proc == $ADD) { return is($a_number, $stack[$frame_ptr]) + is($a_number, $stack[$frame_ptr+1]); } + if ($proc == $SUB) { return is($a_number, $stack[$frame_ptr]) - is($a_number, $stack[$frame_ptr+1])} + if ($proc == $MUL) { return make_number(numeric_value($stack[$frame_ptr]) * numeric_value($stack[$frame_ptr+1])); } + if ($proc == $DIV) { return make_number(int(numeric_value($stack[$frame_ptr]) / numeric_value($stack[$frame_ptr+1]))); } + if ($proc == $MOD) { return make_number(numeric_value($stack[$frame_ptr]) % numeric_value($stack[$frame_ptr+1]))} + if ($proc == $LT) { return ($stack[$frame_ptr] + 0 < $stack[$frame_ptr+1] + 0) ? $T : $NIL} +# what does this mean? a list of args to property. + if ($proc == $GET) { return + defined( $property{$stack[$frame_ptr], $stack[$frame_ptr+1]} ) ? + $property{ $stack[$frame_ptr], $stack[$frame_ptr+1] } : $NIL; } + if ($proc == $PUT) { return + ( $property{$stack[$frame_ptr], $stack[$frame_ptr+1] } = + $stack[$frame_ptr+2]); } + if ($proc == $CADR) { return $car{is($a_pair, $cdr{is($a_pair, + $stack[$frame_ptr])})} ; } + if ($proc == $CDDR) { return $cdr{is($a_pair, $cdr{is($a_pair, $stack[$frame_ptr])})}; } + if ($proc == $LIST) { return listify_args()} + if ($proc == $SYMBOLP) { return is_symbol($stack[$frame_ptr]) ? $T : $NIL} + if ($proc == $PAIRP) { return is_pair($stack[$frame_ptr]) ? $T : $NIL} + if ($proc == $NUMBERP) { return is_number($stack[$frame_ptr]) ? $T : $NIL;} + if ($proc == $SETCAR) { return $car{is($a_pair, $stack[$frame_ptr] = $stack[$frame_ptr + 1])}; } + if ($proc == $SETCDR) { return $cdr{is($a_pair, $stack[$frame_ptr] = $stack[$frame_ptr+1])}; } + if ($proc == $APPLY) { return do_apply() } + if ($proc == $EVAL) { return l_eval($stack[$frame_ptr]) } + if ($proc == $NREV) { return nreverse($stack[$frame_ptr], $NIL)} + if ($proc == $LWRITE) { lwrite_expr($stack[$frame_ptr]); + printf(" "); { return $NIL }} + if ($proc == $NEWLINE) { printf("\n"); return $NIL ; } + if ($proc == $LREAD) { return lread(); } + +# source file handling functions + if ($proc == $LOAD) { $xyz = load($printname{$stack[$frame_ptr]}); + return make_number($xyz); } + if ($proc == $INTER) { return($interactive ? $T : $NIL); } + if ($proc == $FILE) { return string_to_symbol($filename); } + if ($proc == $LINENO) { return make_number(($lineno)+1); } + if ($proc == $TRACE) { if ($trace) { $trace = 0;} + else { $trace = 1; } return $NIL; } + + if ($proc == $RANDOM) { + return make_number(int(rand() * numeric_value($stack[$frame_ptr])))} + if ($proc == $GENSYM) { return string_to_symbol("#G". ++$gensym_counter)} + if ($proc == $ERROR) { + printf("Error!\n"); print_expr(listify_args()); exit(1); + } + error(__LINE__,'Unknown procedure type'); + } + +sub load { + local($file) = @_; + local($err); + $hand = new FileHandle; + $err=open($hand,"<$file"); + if ($err <= 0 ) { return $err; } + push @filestack, $filename; + push @filestack, $filehandle; + push @filestack, $lineno; + push @filestack, $sline; + push @filestack, $pline; + push @filestack, $interactive; + $lineno = 0; + $filehandle = $hand; + $filename = $file; + $interactive = 0; + $pline = ""; +} + +sub endfile { + $interactive = pop @filestack; + $pline = pop @filestack; + $sline = pop @filestack; + $lineno = pop @filestack; + $filehandle = pop @filestack; + $filename = pop @filestack; +} + + sub do_apply { + local($old_frame_ptr, $proc, $args) = @_; + $proc = $stack[$frame_ptr]; + $args = $stack[$frame_ptr+1]; + + $old_frame_ptr = $frame_ptr; + $frame_ptr = $stack_ptr; + + for (; is_pair($args); $args = $cdr{$args}) { + $stack[$stack_ptr++] = $car{$args}; + } + if ($args != $NIL) { + error(__LINE__,"Bad argument to APPLY: not a proper list"); } + + $result = apply($proc); + + $stack_ptr = $frame_ptr; + $frame_ptr = $old_frame_ptr; + return $result; +} + +sub listify_args { + local($p, $result)= @_; + + $result = $NIL; + for ($p = $stack_ptr - 1; $frame_ptr <= $p; --$p) { + $result = cons($stack[$p], $result); + } + return $result; +} + +# --- The environment + +# Clobbers the stack frame. + sub extend_env { + local( $vars ) = @_; local($p, $temp); + for ($p = $frame_ptr; $vars != $NIL; $vars = $cdr{$vars}) { + if ($p == $stack_ptr) { + error(__LINE__,"Too many arguments to procedure"); + } + $temp = $value{$car{$vars}}; + $value{$car{$vars}} = $stack[$p]; + $stack[$p] = $temp; + ++$p; + } + if ($p != $stack_ptr) { + error(__LINE__,"Not enough arguments to procedure"); + } +} + + sub unwind_env { + local ($vars, $p) = @_; + for ($p = $frame_ptr; $vars != $NIL; $vars = $cdr{$vars}) { + if (!defined ($stack[$p])) { + delete $value{$car{$vars}}; + } else { + $value{$car{$vars}} = $stack[$p]; + } + ++$p; + } +} + +# --- Output + +sub print_expr { + local($expr)=@_; + lwrite_expr($expr); + print "\n"; + } + +sub lwrite_expr { + local($expr) = @_; + + if (is_atom($expr)) { + if (!is_symbol($expr)) { + printf("%d", numeric_value($expr)); + } else { + if (!(defined($printname{$expr}))) { + error(__LINE__,"BUG: ". $expr." has no printname"); + } + printf("%s", $printname{$expr}); + } + } else { + printf("("); + lwrite_expr($car{$expr}); + for ($expr = $cdr{$expr}; is_pair($expr); $expr = $cdr{$expr}) { + printf(" "); + lwrite_expr($car{$expr}); + } + if ($expr != $NIL) { + printf(" . "); + lwrite_expr($expr); + } + printf(")"); + } + } + +# --- Input + +sub lread { +# my (@a); +# foreach $i (@-) { +# print '@'; lwrite_expr($i); print '@'; +# } +# @a=do_lread(@_); +# foreach $i (@a) { +# print '#'; lwrite_expr($i); print '#'; +# } +# return (@a); +# } +# sub do_lread { + local($committed, $result) = @_; + skip_blanks(); + if ($token eq $eof) { + if ($committed) { + error(__LINE__,"Unexpected EOF"); + } else { + return $THE_EOF_OBJECT; + } + } + if ($token eq "(") { # lread a list + advance(); + $result = $NIL; + for (;;) { + skip_blanks(); + if ($token eq ".") { + advance(); + $after_dot = lread(1); + skip_blanks(); + if ($token ne ")") { + error(__LINE__,"')' expected"); + } + advance(); + return nreverse($result, $after_dot); + } elsif ($token eq ")" ) { + advance(); + return nreverse($result, $NIL); + } else { + protect($result); + $result = cons(lread(1), $result); + unprotect() + } + } + } elsif ($token eq "'") { # a quoted expression + advance(); + return cons($QUOTE, cons(lread(1), $NIL)); + } elsif ($token =~ /^-?[0-9]+$/) { # a number + $result = make_number($token); + advance(); + return $result; + } else { # a symbol + if ($trace) { print "A symbol $token\n"; } + $result = string_to_symbol($token); + advance(); + return $result; + } + } + + sub skip_blanks { + while ($token =~ /^[ \t]*$/) { + advance(); + } +} +# + sub advance { + if ($token eq $eof) { return $eof; } + if ($token eq "") { + RLOOP: for (;;) { + $lineno++; + if ( $interactive && ( ! defined($value{$DRIVER}) ) ) { + print "$lineno> "; } + $pline = $sline; + if ( ($line = <$filehandle> ) ne "" ) { last RLOOP; } + if (@filestack > 0) { endfile(); } + else { + $token = $eof; + return; + } + } + chop $line; + $sline = $line; + } + if ( ($line =~ /^[(\)'.]/ ) || + ($line =~/^[_A-Za-z0-9\.=!\@\$%&\*<>\?\+\\\-\/\:]+/) || + ($line =~ /^[ \t]+/)) { + $token = substr($line, length($`), length($&)); + $line = substr($line, length($&)); + } elsif ($line eq "" || substr($line, 0, 1) eq ";") { + $token = ""; # this kludge permits interactive use + } else { + error(__LINE__,"Lexical error starting at ".$line); + } + if ($trace) { print ":$token:"; flush STDOUT; } + } + +# --- Miscellany + +# Destructively reverse :list and append :reversed_head. +sub nreverse { + local($list, $reversed_head, $tail) = @_; + + while (is_pair($list)) { #** speed? + $tail = $cdr{$list}; + $cdr{$list} = $reversed_head; + $reversed_head = $list; + $list = $tail; + } + if ($list != $NIL) { + error(__LINE__,"Not a proper list - reverse!"); + } + return $reversed_head; +} + + +sub error { + local($line,$reason)=@_; + print STDERR "Error $line \t: file-$filename line-$lineno $reason:\n"; + print STDERR " \t: $pline\n"; + print STDERR " near $token\t: $sline\n"; + $token=""; + die($reason); +} diff --git a/ase/test/awk/lisp/scheme.lsp b/ase/test/awk/lisp/scheme.lsp new file mode 100644 index 00000000..5857642d --- /dev/null +++ b/ase/test/awk/lisp/scheme.lsp @@ -0,0 +1,55 @@ +; This ain't a Scheme interpreter, despite the filename. +; Uses: startup scmhelp.lsp + +(define read-eval-print-loop + (lambda () + (let ((exp '*)) + (while (begin + (write '>) + (not (eq? the-eof-object (set! exp (read))))) + (print (eval-exp (macroexpand exp) init-env)))))) + +(define eval-exp + (lambda (exp env) + ((evaluator exp) exp env))) + +(define evaluator + (lambda (exp) + (if (atom? exp) + (if (symbol? exp) lookup-variable self-evaluating) + (or (get (car exp) 'evaluator) + (lambda (exp env) + (apply-proc (eval-exp (car exp) env) + (map (lambda (rand) (eval-exp rand env)) (cdr exp)))))))) + +(define self-evaluating + (lambda (exp env) exp)) + +(put 'quote 'evaluator + (lambda (exp env) (cadr exp))) + +(put 'lambda 'evaluator make-closure) + +(put 'if 'evaluator + (lambda (exp env) + (if (eval-exp (test-exp exp) env) + (eval-exp (then-exp exp) env) + (eval-exp (else-exp exp) env)))) + +(put 'define 'evaluator + (lambda (exp env) + (define-variable-value (cadr exp) (eval-exp (caddr exp) env) env) + (cadr exp))) + +(define apply-proc + (lambda (proc args) + (if (primitive? proc) + (apply proc args) + (eval-exp (closure-body proc) + (extend-env (closure-formals proc) args (closure-env proc)))))) + +; Here we go + +(define init-env (extend-env '() '() '())) + +(read-eval-print-loop) diff --git a/ase/test/awk/lisp/scmhelp.lsp b/ase/test/awk/lisp/scmhelp.lsp new file mode 100644 index 00000000..44f1d1c0 --- /dev/null +++ b/ase/test/awk/lisp/scmhelp.lsp @@ -0,0 +1,48 @@ +; Stuff common to scheme.lsp and tail.lsp. + +; Environment operations + +(define extend-env + (lambda (vars vals env) + (cons (cons vars vals) env))) + +(define lookup-variable + (lambda (var env) + (if (null? env) + (eval var) ; to give access to Lisp primitives and constants + (lookup-in-frame var (caar env) (cdar env) (cdr env))))) + +(define lookup-in-frame + (lambda (var vars vals enclosing-env) + (if (null? vars) + (lookup-variable var enclosing-env) + (if (eq? (car vars) var) + (car vals) + (lookup-in-frame var (cdr vars) (cdr vals) enclosing-env))))) + +(define define-variable-value + (lambda (var value env) + (let ((frame (car env))) + (set-car! frame (cons var (car frame))) + (set-cdr! frame (cons value (cdr frame)))))) + +; Syntax + +(define cadar (lambda (lst) (cadr (car lst)))) +(define cdddr (lambda (lst) (cddr (cdr lst)))) +(define caddar (lambda (lst) (cadr (cdr (car lst))))) + +(define test-exp cadr) +(define then-exp caddr) +(define else-exp (lambda (exp) (if (cdddr exp) (cadddr exp) nil))) + +(define make-closure cons) +(define closure-formals cadar) +(define closure-body caddar) +(define closure-env cdr) + +(define primitive? + (lambda (object) + (and (pair? object) + (eq? (car object) '%prim)))) + diff --git a/ase/test/awk/lisp/startup b/ase/test/awk/lisp/startup new file mode 100644 index 00000000..b5a191b8 --- /dev/null +++ b/ase/test/awk/lisp/startup @@ -0,0 +1,141 @@ +; Syntax and shorthands + +(define = eq?) +(define not null?) + +(define caar (lambda (lst) (car (car lst)))) +(define cdar (lambda (lst) (cdr (car lst)))) +(define caddr (lambda (lst) (car (cddr lst)))) +(define cadddr (lambda (lst) (cadr (cddr lst)))) + +; I/O + +(define print + (lambda (object) + (write object) + (newline))) + +; The least dispensable list operations + +(define equal? + (lambda (x1 x2) + (if (eq? x1 x2) + t + (if (pair? x1) + (if (pair? x2) + (if (equal? (car x1) (car x2)) + (equal? (cdr x1) (cdr x2)))))))) + +(define length + (lambda (lst) + ((lambda (n) + (while lst + (set! n (+ n 1)) + (set! lst (cdr lst))) + n) + 0))) + +(define append + (lambda (L1 L2) + (if (null? L1) + L2 + (cons (car L1) + (append (cdr L1) L2))))) + +(define map + (lambda (proc lst) + ((lambda (result) + (while lst + (set! result (cons (proc (car lst)) result)) + (set! lst (cdr lst))) + (reverse! result)) + '()))) + +(define for-each + (lambda (proc lst) + (while lst + (proc (car lst)) + (set! lst (cdr lst))))) + +; Macros + +(define macroexpand + (lambda (exp) + (if (atom? exp) + exp + (if (get (car exp) 'special-form) + ((get (car exp) 'special-form) exp) + (if (get (car exp) 'macro) + (macroexpand ((get (car exp) 'macro) (cdr exp))) + (map macroexpand exp)))))) + +(put 'quote 'special-form + (lambda (exp) exp)) + +(put 'lambda 'special-form + (lambda (exp) + (cons 'lambda + (cons (cadr exp) + (map macroexpand (cddr exp)))))) + +; Other special forms don't need special treatment, but you might want +; to add syntax-checking. + +(define define-macro + (lambda (keyword expander) + (put keyword 'macro expander))) + +(define-macro 'and + (lambda (args) + (if (null? args) + t + (if (null? (cdr args)) + (car args) + (list 'if (car args) (cons 'and (cdr args))))))) + +(define-macro 'or + (lambda (args) + (if (null? args) + nil + (if (null? (cdr args)) + (car args) + (list + ((lambda (test-var) + (list 'lambda (list test-var) + (list 'if test-var test-var (cons 'or (cdr args))))) + (gensym)) + (car args)))))) + +(define-macro 'let + (lambda (args) + (cons + (cons 'lambda (cons (map car (car args)) (cdr args))) + (map cadr (car args))))) + +(define make-begin + (lambda (lst) + (if (null? (cdr lst)) + (car lst) + (cons 'begin lst)))) + +(define-macro 'cond + (lambda (clauses) + (if (null? clauses) + nil + (if (eq? (caar clauses) 'else) + (make-begin (cdar clauses)) + (list 'if + (caar clauses) + (make-begin (cdar clauses)) + (cons 'cond (cdr clauses))))))) + +; This procedure replaces the system default read-eval-print loop: + +(define top-level-driver + (lambda () + (write '>) + ((lambda (exp) + (if (eq? the-eof-object exp) + (set! top-level-driver nil) + (print (eval (macroexpand exp))))) + (read)))) diff --git a/ase/test/awk/lisp/tail.lsp b/ase/test/awk/lisp/tail.lsp new file mode 100644 index 00000000..928895f2 --- /dev/null +++ b/ase/test/awk/lisp/tail.lsp @@ -0,0 +1,160 @@ +; Tail-recursive Scheme interpreter +; Uses: startup scmhelp.lsp +; Based on Abelson & Sussman, chapter 5. +; The most glaring omissions are error-checking, set!, begin, and call/cc. + +(define next '*) + +(define exp '*) +(define env '*) +(define proc '*) +(define rands '*) +(define args '*) +(define value '*) +(define cont '*) + +(define read-eval-print-loop + (lambda () + (while (begin + (write '>) + (not (eq? the-eof-object (set! exp (read))))) + (set! exp (macroexpand exp)) + (set! env init-env) + (set! cont (lambda () 'halt)) + (set! next eval-exp) + (run) + (print value)))) + +(define run + (lambda () + (while (not (eq? (next) 'halt))))) + +(define goto + (lambda (procedure) + (set! next procedure))) + +(define return + (lambda (val) + (set! value val) + (set! next cont))) + +(define eval-exp + (lambda () + (if (atom? exp) + (return + (if (symbol? exp) + (lookup-variable exp env) + exp)) + (let ((handler (get (car exp) 'evaluator))) + (if handler + (handler) + (begin ; procedure call + (push cont) ; this eventually is popped by apply-proc + (push env) + (push (cdr exp)) ; save the operands + (set! exp (car exp)) ; evaluate the operator + (set! cont eval-rands) + (goto eval-exp))))))) + +(define eval-rands + (lambda () + (set! rands (pop)) + (set! env (pop)) + (set! args '()) + (push value) ; save the procedure + (goto rands-loop))) + +(define rands-loop + (lambda () + (if (null? rands) + (begin + (set! args (reverse! args)) + (set! proc (pop)) + (goto apply-proc)) + (begin + (set! exp (car rands)) + (push env) + (push args) + (push (cdr rands)) + (set! cont add-arg) + (goto eval-exp))))) + +(define add-arg + (lambda () + (set! rands (pop)) + (set! args (cons value (pop))) + (set! env (pop)) + (goto rands-loop))) + +(put 'quote 'evaluator + (lambda () + (return (cadr exp)))) + +(put 'lambda 'evaluator + (lambda () + (return (make-closure exp env)))) + +(put 'if 'evaluator + (lambda () + (push cont) + (push env) + (push exp) + (set! cont decide) + (set! exp (test-exp exp)) + (goto eval-exp))) + +(define decide + (lambda () + (set! exp (pop)) + (set! env (pop)) + (set! cont (pop)) + (set! exp (if value (then-exp exp) (else-exp exp))) + (goto eval-exp))) + +(put 'define 'evaluator + (lambda () + (push cont) + (push env) + (push (cadr exp)) ; save the variable being defined + (set! exp (caddr exp)) ; evaluate the defining expression + (set! cont do-definition) + (goto eval-exp))) + +(define do-definition + (lambda () + (set! exp (pop)) + (set! env (pop)) + (set! cont (pop)) + (define-variable-value exp value env) + (return exp))) + +(define apply-proc + (lambda () + (set! cont (pop)) + (if (primitive? proc) + (return (apply proc args)) + (begin + (set! exp (closure-body proc)) + (set! env + (extend-env (closure-formals proc) args (closure-env proc))) + (goto eval-exp))))) + +; Stack operations + +(define stack '()) + +(define push + (lambda (x) + (set! stack (cons x stack)))) + +(define pop + (lambda () + (let ((result (car stack))) + (set! stack (cdr stack)) + result))) + +; Here we go + +(define init-env (extend-env '() '() '())) + +(read-eval-print-loop) diff --git a/ase/test/awk/lisp/test.scm b/ase/test/awk/lisp/test.scm new file mode 100644 index 00000000..f0fd85d6 --- /dev/null +++ b/ase/test/awk/lisp/test.scm @@ -0,0 +1,21 @@ +; Sample Scheme code to test scheme.lsp or tail.lsp + +(define add-c (lambda (c) (lambda (n) (+ c n)))) + +(let ((compose (lambda (f g) (lambda (x) (f (g x)))))) + ((compose (add-c 5) (add-c 3)) 2)) + +(define Y ; The famous Y combinator! + (lambda (f) + (let ((future + (lambda (future) + (f (lambda (arg) + ((future future) arg)))))) + (future future)))) + +((Y (lambda (factorial) + (lambda (n) + (if (= n 0) + 1 + (* n (factorial (- n 1))))))) + 3) diff --git a/ase/test/awk/lisp/trace b/ase/test/awk/lisp/trace new file mode 100644 index 00000000..49889eb1 --- /dev/null +++ b/ase/test/awk/lisp/trace @@ -0,0 +1,70 @@ +;** allow primitives +; Procedure call/return tracing +; Uses: startup + +(define trace + (lambda (var) + (if (get var 'traced) + (list var 'already 'traced) + (if (not (bound-to-lambda? var)) + '(not a defined-procedure name) + (begin + (put var 'traced (eval var)) + (set var (make-traced var)) + var))))) + +(define untrace + (lambda (var) + (if (not (get var 'traced)) + (list var 'not 'traced) + (begin + (set var (get var 'traced)) + var)))) + +(define bound-to-lambda? + (lambda (var) + (and (symbol? var) + (let ((value (eval var))) + (and (pair? value) + (eq? (car value) 'lambda)))))) + +(define make-traced + (lambda (var) + (let ((proc (eval var))) + (list 'lambda (cadr proc) + (list '=enter= (list 'quote var) (cons 'list (cadr proc))) + (list '=exit= (list 'quote var) + (cons (list 'get (list 'quote var) (list 'quote 'traced)) + (cadr proc))))))) + +(define =enter= + (lambda (name args) + (tab *indentation*) + (set! *indentation* (+ *indentation* 1)) + (write 'entering) + (write name) + (write ':) + (for-each write args) + (newline))) + +(define =exit= + (lambda (name result) + (set! *indentation* (- *indentation* 1)) + (tab *indentation*) + (write 'exiting) + (write name) + (write ':) + (print result) + result)) + +(define *indentation* 0) + +(define tab + (lambda (n) + (while (< 0 n) + (write '>) + (set! n (- n 1))))) + +(define set + (lambda (var value) + (eval (list 'set! var (list 'quote value)))))