hyung-hwan/qse
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Browse Source
This commit is contained in:
hyung-hwan 2008-01-01 07:02:50 +00:00
parent 5af68ab11b
commit efebade205
16 changed files with 2328 additions and 276 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

147
ase/test/awk/lisp/Impl-notes Normal file
View File

@ -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

238
ase/test/awk/lisp/Manual Normal file
View File

@ -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 <optional-Lisp-source-files>
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 <parameters> <body>),
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 <x>) is <x>. There's a shorthand for this form: '<x>.
E.g., the value of '(+ 2 2) is (+ 2 2), -not- 4.
(lambda <parameters> <body>) returns itself: e.g., the value of (lambda (x) x)
is (lambda (x) x).
To evaluate (if <test-expr> <then-exp> <else-exp>), first evaluate <test-expr>.
If the value is true (non-nil), then return the value of <then-exp>, otherwise
return the value of <else-exp>. (<else-exp> is optional; if it's left out,
pretend there's a nil there.) Example: (if nil 'yes 'no) returns no.
To evaluate (begin <expr-1> <expr-2>...), evaluate each of the subexpressions
in order, returning the value of the last one.
To evaluate (while <test> <expr-1> <expr-2>...), first evaluate <test>. If
it's nil, return nil. Otherwise, evaluate <expr-1>, <expr-2>,... in order,
and then repeat.
To evaluate (set! <variable> <expr>), evaluate <expr>, and then set the value
of <variable> 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 <expr>.
(define <variable> <expr>) is like set!, except it's used to introduce new
bindings, and the value returned is <variable>.
It's possible to define new special forms using the macro facility provided in
the startup file. The macros defined there are:
(let ((<var> <expr>)...)
<body>...)
Bind each <var> to its corresponding <expr> (evaluated in the current
environment), and evaluate <body> in the resulting environment.
(cond (<test-expr> <result-expr>...)... (else <result-expr>...))
where the final else clause is optional. Evaluate each <test-expr> in
turn, and for the first non-nil result, evaluate its <result-expr>. If
none are non-nil, and there's no else clause, return nil.
(and <expr>...)
Evaluate each <expr> in order, until one returns nil; then return nil.
If none are nil, return the value of the last <expr>.
(or <expr>...)
Evaluate each <expr> in order, until one returns non-nil; return that value.
If all are nil, return nil.
4. Built-in procedures
List operations:
(null? <x>) returns true (non-nil) when <x> is nil.
(atom? <x>) returns true when <x> is an atom.
(pair? <x>) returns true when <x> is a pair.
(car <pair>) returns the car of <pair>.
(cdr <pair>) returns the cdr of <pair>.
(cadr <pair>) returns the car of the cdr of <pair>. (i.e., the second element.)
(cddr <pair>) returns the cdr of the cdr of <pair>.
(cons <x> <y>) returns a new pair whose car is <x> and whose cdr is <y>.
(list <x>...) returns a list of its arguments.
(set-car! <pair> <x>) changes the car of <pair> to <x>.
(set-cdr! <pair> <x>) changes the cdr of <pair> to <x>.
(reverse! <list>) reverses <list> in place, returning the result.
Numbers:
(number? <x>) returns true when <x> is a number.
(+ <n> <n>) returns the sum of its arguments.
(- <n> <n>) returns the difference of its arguments.
(* <n> <n>) returns the product of its arguments.
(quotient <n> <n>) returns the quotient. Rounding is towards zero.
(remainder <n> <n>) returns the remainder.
(< <n1> <n2>) returns true when <n1> is less than <n2>.
I/O:
(write <x>) writes <x> followed by a space.
(newline) writes the newline character.
(read) reads the next expression from standard input and returns it.
Meta-operations:
(eval <x>) evaluates <x> in the current environment, returning the result.
(apply <proc> <list>) calls <proc> with arguments <list>, returning the result.
Miscellany:
(eq? <x> <y>) returns true when <x> and <y> are the same object. Be careful
using eq? with lists, because (eq? (cons <x> <y>) (cons <x> <y>)) is false.
(put <x> <y> <z>)
(get <x> <y>) returns the last value <z> that was put for <x> and <y>, or nil
if there is no such value.
(symbol? <x>) returns true when <x> is a symbol.
(gensym) returns a new symbol distinct from all symbols that can be read.
(random <n>) returns a random integer between 0 and <n>-1 (if <n> is positive).
(error <x>...) 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.

30
ase/test/awk/lisp/README Normal file
View File

@ -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.

276
ase/test/awk/lisp.awk → ase/test/awk/lisp/awklisp
View File

@ -7,282 +7,6 @@
# of ASEAWK.
#
# <<README>>
#
# 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.
# <<Manual>>
#
# 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 <optional-Lisp-source-files>
#
# 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 <parameters> <body>),
# 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 <x>) is <x>. There's a shorthand for this form: '<x>.
# E.g., the value of '(+ 2 2) is (+ 2 2), -not- 4.
#
# (lambda <parameters> <body>) returns itself: e.g., the value of (lambda (x) x)
# is (lambda (x) x).
#
# To evaluate (if <test-expr> <then-exp> <else-exp>), first evaluate <test-expr>.
# If the value is true (non-nil), then return the value of <then-exp>, otherwise
# return the value of <else-exp>. (<else-exp> is optional; if it's left out,
# pretend there's a nil there.) Example: (if nil 'yes 'no) returns no.
#
# To evaluate (begin <expr-1> <expr-2>...), evaluate each of the subexpressions
# in order, returning the value of the last one.
#
# To evaluate (while <test> <expr-1> <expr-2>...), first evaluate <test>. If
# it's nil, return nil. Otherwise, evaluate <expr-1>, <expr-2>,... in order,
# and then repeat.
#
# To evaluate (set! <variable> <expr>), evaluate <expr>, and then set the value
# of <variable> 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 <expr>.
#
# (define <variable> <expr>) is like set!, except it's used to introduce new
# bindings, and the value returned is <variable>.
#
# It's possible to define new special forms using the macro facility provided in
# the startup file. The macros defined there are:
#
# (let ((<var> <expr>)...)
# <body>...)
#
# Bind each <var> to its corresponding <expr> (evaluated in the current
# environment), and evaluate <body> in the resulting environment.
#
# (cond (<test-expr> <result-expr>...)... (else <result-expr>...))
#
# where the final else clause is optional. Evaluate each <test-expr> in
# turn, and for the first non-nil result, evaluate its <result-expr>. If
# none are non-nil, and there's no else clause, return nil.
#
# (and <expr>...)
#
# Evaluate each <expr> in order, until one returns nil; then return nil.
# If none are nil, return the value of the last <expr>.
#
# (or <expr>...)
#
# Evaluate each <expr> in order, until one returns non-nil; return that value.
# If all are nil, return nil.
#
#
# 4. Built-in procedures
#
# List operations:
# (null? <x>) returns true (non-nil) when <x> is nil.
# (atom? <x>) returns true when <x> is an atom.
# (pair? <x>) returns true when <x> is a pair.
# (car <pair>) returns the car of <pair>.
# (cdr <pair>) returns the cdr of <pair>.
# (cadr <pair>) returns the car of the cdr of <pair>. (i.e., the second element.)
# (cddr <pair>) returns the cdr of the cdr of <pair>.
# (cons <x> <y>) returns a new pair whose car is <x> and whose cdr is <y>.
# (list <x>...) returns a list of its arguments.
# (set-car! <pair> <x>) changes the car of <pair> to <x>.
# (set-cdr! <pair> <x>) changes the cdr of <pair> to <x>.
# (reverse! <list>) reverses <list> in place, returning the result.
#
# Numbers:
# (number? <x>) returns true when <x> is a number.
# (+ <n> <n>) returns the sum of its arguments.
# (- <n> <n>) returns the difference of its arguments.
# (* <n> <n>) returns the product of its arguments.
# (quotient <n> <n>) returns the quotient. Rounding is towards zero.
# (remainder <n> <n>) returns the remainder.
# (< <n1> <n2>) returns true when <n1> is less than <n2>.
#
# I/O:
# (write <x>) writes <x> followed by a space.
# (newline) writes the newline character.
# (read) reads the next expression from standard input and returns it.
#
# Meta-operations:
# (eval <x>) evaluates <x> in the current environment, returning the result.
# (apply <proc> <list>) calls <proc> with arguments <list>, returning the result.
#
# Miscellany:
# (eq? <x> <y>) returns true when <x> and <y> are the same object. Be careful
# using eq? with lists, because (eq? (cons <x> <y>) (cons <x> <y>)) is false.
# (put <x> <y> <z>)
# (get <x> <y>) returns the last value <z> that was put for <x> and <y>, or nil
# if there is no such value.
# (symbol? <x>) returns true when <x> is a symbol.
# (gensym) returns a new symbol distinct from all symbols that can be read.
# (random <n>) returns a random integer between 0 and <n>-1 (if <n> is positive).
# (error <x>...) 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 {

140
ase/test/awk/lisp/eliza.lsp Normal file
View File

@ -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)))))

7
ase/test/awk/lisp/fib.lsp Normal file
View File

@ -0,0 +1,7 @@
(define fib
(lambda (n)
(if (< n 2)
1
(+ (fib (- n 1))
(fib (- n 2))))))
(fib 20)

69
ase/test/awk/lisp/lists Normal file
View File

@ -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))))))

33
ase/test/awk/lisp/numbers Normal file
View File

@ -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)))

517
ase/test/awk/lisp/old-awklisp Normal file
View File

@ -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("#<Primitive %s>", 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)
}

652
ase/test/awk/lisp/perlisp Normal file
View File

@ -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("#<Primitive %s>", $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 = '<STDIN>';
$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);
}

55
ase/test/awk/lisp/scheme.lsp Normal file
View File

@ -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)

48
ase/test/awk/lisp/scmhelp.lsp Normal file
View File

@ -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))))

141
ase/test/awk/lisp/startup Normal file
View File

@ -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))))

160
ase/test/awk/lisp/tail.lsp Normal file
View File

@ -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)

21
ase/test/awk/lisp/test.scm Normal file
View File

@ -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)

70
ase/test/awk/lisp/trace Normal file
View File

@ -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)))))