MICRO COMMON LISP

T3X SOURCE CODE   |   LISP SOURCE CODE

This is the low-level part of the source code of the MICRO COMMON LISP interpreter, written in T3X/0. There is also a translation of this program to C (C89, ANSI C), but the T3X version is where the development takes place.

!! MICRO COMMON LISP, A Microscopic Common LISP Subset
!! Nils M Holm, 2019, 2020, 2024, 2025
!! In the public domain or distributed under the 0BSD license

! This program will use basic memory operations and I/O
! functions, as well as the console interface.

use t3x: t;
use console: con;

! ******************************
! ***** GLOBAL DEFINITIONS *****
! ******************************

! We will assume that the console has 80x24 characters,
! like a VT100 terminal.

! Note: COLUMNS cannot be larger than BUFLEN, below.

const	COLUMNS = 80,
	LINES	= 24;

! There are NNODES Nodes in the node pool. A Cons cell
! allocates one node, a symbol uses 4+N nodes, where N
! is one per two characters in the symbol name, i.e.
! one for one- and two-character names, two for three-
! and four-character names, etc.

const	NNODES	= 7168;

! A Symbol can be up to 64 characters long.

const	SYMLEN	= 64;

! I/O buffers are 128 characters wide. Note that buffers
! are mostly used for keyboard input, so 128 is plenty.
! There is not much disk I/O going on in this program.

! ***** Increasing this value will add to memory footprint
! ***** significantly!

const	BUFLEN	= 128;

! EXDEPTH is how often the macro expander can recurse.
! That is, this is roughly the number of clauses that
! can be in a single COND or bindings that can be in
! a single LET*.

const	EXDEPTH	= 128;

! When printing a list that is nested more than PRDEPTH
! times, printing will be aborted (assuming that the
! printed structure is cyclic).

const	PRDEPTH	= 64;

! NLOAD is the number of times LOAD can be nested, where
! one would mean that a LOADed program cannot LOAD another.

! ***** Increasing this value will add to memory footprint
! ***** significantly!

const	NLOAD	= 3;

! Special Nodes get values outside of the node pool.
! Valid node addresses are zero through NNODES-1.
! A special node is a node that represents some object
! that is neither a symbol nor a cons.

const	SPCL	= NNODES;

! Special nodes: NIL, End of Text, the dot in dotted
! pairs, the right parenthesis, and the "undefined"
! value for indicating that a symbol is not bound.

! Yes, NIL is a special object in this implementation.
! This detail will be invisible to the user, though.

const	NIL	= NNODES+1;
const	EOT	= NNODES+2;
const	DOT	= NNODES+3;
const	RPAREN	= NNODES+4;
const	UNDEF	= NNODES+5;

! ****************************
! ***** STRING FUNCTIONS *****
! ****************************

! We could import the STRING module, but we only need
! a few functions, so let's define them here.

! The length of a string, limited to 32766 characters.

strlen(s) return t.memscan(s, 0, 32767);

! Are two strings equal?

strequ(a, b) return t.memcomp(a, b, strlen(a)+1) = 0;

! Copy string B to A.

strcopy(a, b) t.memcopy(a, b, strlen(b)+1);

! Convert an unsigned integer to an ASCII string and
! return a pointer to the string. An internal buffer
! will be used for the string, so subsequent calls to
! NTOA will overwrite the buffer.

var Ntoab::20;

ntoa(n) do var q, p;
	p := @Ntoab::19;
	q := p;
	p::0 := 0;
	while (n \/ p = q) do
		p := p-1;
		p::0 := n mod 10 + '0';
		n := n ./ 10;
	end
	return p;
end

! *****************************
! ***** CONSOLE INTERFACE *****
! *****************************

! The interpreter will use the CONSOLE interface of T3X/0,
! so it can provide some basic command line editing.

! XPOS and YPOS are the X and Y positions of the cursor on
! the screen.

var	Xpos, Ypos;

! Clear the screen.

clear() do
	con.clrscr();
	Xpos := 0;
	Ypos := 0;
end

! When a message is posted to the status line of the
! interpreter, store it in MSG, so it can be redrawn
! after scrolling the screen.

var	Msg;

! Batch mode disables the CONSOLE interface. When the
! interpreter runs in Batch mode (BATCH=%1), command line
! editing is disabled and input is read directly from
! SYSIN. No messages will be posted to the status line.

var	Batch;

! Post a message to the status line.

message(s) do
	if (Batch) return;
	con.move(0, LINES-1);
	con.standout();
	con.clreol();
	con.writes(s);
	con.normal();
	con.move(Xpos, Ypos);
	Msg := s;
end

! Scroll the screen up by one line
! without scrolling the status line.

scroll() do
	con.move(0, LINES-1);
	con.clreol();
	con.scroll();
	message(Msg);
end

! Print the string S on the console screen. In Batch mode,
! just write the string to SYSOUT.

! When writing to the console, interpret CR and LF characters
! and scroll the screen when necessary.

pr(s) do var i;
	ie (Batch) do
		t.write(T3X.SYSOUT, s, strlen(s));
	end
	else do
		i := 0;
		while (s::i) do
			ie (s::i = '\n') do
				Ypos := Ypos+ 1;
				con.move(Xpos, Ypos);
			end
			else ie (s::i = '\r') do
				Xpos := 0;
				con.move(Xpos, Ypos);
			end
			else do
				con.wrch(s::i);
				Xpos := Xpos + 1;
			end
			if (Xpos >= COLUMNS) do
				Xpos := 0;
				Ypos := Ypos + 1;
				con.move(Xpos, Ypos);
			end
			if (Ypos >= LINES-1) do
				scroll();
				Ypos := LINES - 2;
				con.move(Xpos, Ypos);
			end
			i := i+1;
		end
	end
end

! Write a "newline" sequence to the console (or to SYSOUT
! in Batch mode).

nl() do var b::3;
	ie (Batch)
		pr(t.newline(b));
	else
		pr("\r\n");
end

! These are the History buffers. Three input lines will be
! kept in memory: the one currently being edited, and the
! two ones recently submitted.

var	Auxb1::BUFLEN, Auxb2::BUFLEN;

! Rotate the contents of the history buffers through the
! current editing buffer B, so that the content of AUXB1
! will end up in B, AUXB2 in AUXB1, and B in AUXB2:
!
! +---+      +-------+      +-------+
! | B | <--- | AUXB1 | <--- | AUXB2 | <---+
! +---+      +-------+      +-------+     |
!   |                                     |
!   +-------------------------------------+

rotatebufs(b) do var i, c;
	for (i=0, BUFLEN) do
		c := Auxb1::i;
		Auxb1::i := Auxb2::i;
		Auxb2::i := b::i;
		b::i := c;
	end
end

! The error handler will be defined later.

decl error(2);

! READCON reads a line from the console into the buffer B
! with command line editing. It returns the number of
! characters in B.

! The following keys are interpreted (^X = Control+x):
! ^A         Move to beginning of line
! ^B         Move left/back
! ^C         Abort input, signal an error
! ^D         Delete character; on empty line: send EOT
! ^E         Move to end of line
! ^F         Move right/forward
! Backspace  Delete character on the left
! ^L         Clear screen
! Enter      Submit input
! ^P         Go through history
! ^U         Delete line, keep editing

readcon(b) do var p0, p, r, m, k, n;
	m := COLUMNS - 4;
	p0 := Xpos;
	p := 0;
	r := 1;
	n := 0;
	b::0 := 0;
	while (%1) do
		if (r) do
			con.move(p0, Ypos);
			con.writes(b);
			con.wrch('\s');
			r := 0;
		end
		con.move(p+p0, Ypos);
		k := con.getkey();
		ie (k = 2) do		! ^B
			if (p > 0) p := p-1;
		end
		else ie (k = 6) do	! ^F
			if (p < n) p := p+1;
		end
		else ie (k = 1) do	! ^A
			p := 0;
		end
		else ie (k = 5) do	! ^E
			p := n;
		end
		else ie (k = 12) do	! ^L
			clear();
			if (p0) pr("* ");
			r := 1;
		end
		else ie (k = 16) do	! ^P
			rotatebufs(b);
			n := strlen(b);
			p := n;
			r := 1;
			con.move(Xpos, Ypos);
			con.clreol();
		end
		else ie (k = '\r' \/ k = '\n') do
			if (n > 0) do
				if (Auxb1::0 \= 0)
					strcopy(Auxb2, Auxb1);
				strcopy(Auxb1, b);
			end
			b::n := k;
			n := n+1;
			b::n := 0;
			nl();
			return n;
		end
		else ie (k = 3) do	! ^C
			nl();
			b::0 := 0;
			error("abort", UNDEF);
			return 0;
		end
		else ie (k = 21) do	! ^U
			b::0 := 0;
			n := 0;
			p := 0;
			r := 1;
			con.move(p0, Ypos);
			con.clreol();
		end
		else ie ((k = '\b' \/ k = 127) /\ p > 0 \/
			 k = 4 /\ p < n)
		do
			n := n-1;
			if (k \= 4) p := p-1;
			t.memcopy(@b::p, @b::(p+1), n-p);
			b::n := 0;
			r := 1;
		end
		else ie (k = 4 /\ n = 0) do	! ^D
			b::n := 4;
			b::(n+1) := 0;
			pr("^D");
			nl();
			return n;
		end
		else if ('\s' <= k /\ k <= '~') do
			if (n >= m) loop;
			t.memcopy(@b::(p+1), @b::p, n-p);
			b::p := k;
			p := p+1;
			n := n+1;
			b::n := 0;
			r := 1;
		end
	end
end

! ***************************
! ***** INPUT BUFFERING *****
! ***************************

! Current input file.

var	Input;

! Input buffer, pointer to next character, number
! of characters in the buffer.

var	Inbuf, Inp, Ink;

! Default input buffer, used for console input

var	Buffer::BUFLEN;

! Single-character reject buffer for putting characters
! back for later reading. When Rejected=EOT, there is no
! character in the reject buffer.

var	Rejected;

! Line counter for reporting errors in files.

var	Line;

! Flush any pending input and restore the default
! input channel. This will be done when initializing
! the system, and also in case of an error so the
! interpreter does not keep reading input after
! aborting.

flushinp() do
	Input := T3X.SYSIN;
	Inbuf := Buffer;
	Inp := 0;
	Ink := 0;
	Rejected := EOT;
end

! RDCH reads a single character through the buffered
! interface and returns it. It returns EOT when reading a
! Control-D (4) or Control-Z (26) character or when no
! input can be read from the current input file or device.

! Note that Control-Z is for DOS and CP/M. The console
! interface does not pass through Control-Z.

rdch() do var c;
	if (Rejected \= EOT) do
		c := Rejected;
		Rejected := EOT;
		return c;
	end
	if (Inp >= Ink) do
		ie (Input = T3X.SYSIN /\ \Batch)
			Ink := readcon(Inbuf);
		else
			Ink := t.read(Input, Inbuf, BUFLEN);
		if (Ink < 1) return EOT;
		Inp := 0;
	end
	c := Inbuf::Inp;
	Inp := Inp+1;
	if (c = 4 \/ c = 26) return EOT;
	if (Line /\ c = '\n') Line := Line + 1;
	return c;
end

! Read a single character and convert letters to
! upper case. CI = case insensitive.

rdchci() do var c;
	c := rdch();
	if (c >= 'a' /\ c <= 'z') return c-32;
	return c;
end

! **************************
! ***** ERROR HANDLING *****
! **************************

! When ERRFLAG is set, no more input will be read,
! evaluation will stop, and no more errors will be
! reported.

var	Errflag;

! The S-expression printer and the shutdown routine
! will be defined later.

decl print(1), fini(1);

! ERROR is called whenever an error is detected while
! reading or evaluating an expression. It prints the
! error message M and the optional argument N, flushes
! pending input and sets the error flag. In Batch mode
! it also shuts down the interpreter.

error(m, n) do
	if (Errflag) return;
	pr("? ");
	if (Line) do
		pr(ntoa(Line));
		pr(" ");
	end
	pr(m);
	if (n \= UNDEF) do
		pr(": ");
		print(n);
	end
	nl();
	flushinp();
	Errflag := %1;
	if (Batch) fini(1);
	return NIL;
end

! FATAL is called in case of unrecoverable errors.
! It always shuts down the interpreter.

fatal(m) do
	error(m, UNDEF);
	pr("? aborting");
	nl();
	fini(1);
end

! ****************************************************
! ***** MEMORY ALLOCATION AND GARBAGE COLLECTION *****
! ****************************************************

! The node pool pool consists of three arrays, one
! containg the CAR fields of Conses, one containing
! their CDR fields, and one containing the tag bits
! of the node.

! A node with no tag bits set is a Cons cell. Symbols
! are composed of multiple nodes, of which some have
! the ATOMB bit set. This will be explained in greater
! detail further below.

! A Cons node has an address in both the CAR and CDR
! field. An atomic node has a value in the CAR field
! and an address in the CDR field. All addresses are
! offsets in the CAR, CDR, and TAG arrays.

var	Car[NNODES],
	Cdr[NNODES];

var	Tag::NNODES;

const	ATOMB	= 0x01;

! The MARKB and SWAPB tag bits are used during garbage
! collection. See below.

const	MARKB	= 0x02;
const	SWAPB	= 0x04;

! The Freelist is a linked list of free nodes. The CAR
! field of each free node is unimportant (the node is
! inactive anyway), and the CDR field has the address
! of the next free node.

! As long as the freelist is not empty, allocating a
! node is a fast and simple as removing the head of the
! freelist and returning its address.

var	Freelist;

!! Deutsch/Schorr/Waite graph marker

! When the Freelist is empty, the garbage collector
! marks all nodes that are currently used by the LISP
! system and then adds all unmarked nodes to the
! Freelist. A node is used, if it is either a symbol
! used by the system or part of a cons tree used by
! the system.

! The MARK procedure marks all nodes that are part of
! the cons tree whose root is N.

! It uses the constant-space Deutsch/Schorr/Waite graph
! marking algorithm, also known as the Pointer Reversal
! algorithm. Its fundamental idea is to store the address
! of the parent node in the current node instead of a
! stack. Hence it needs no extra space.

! It works like this:
! A = CAR field      D = CDR field
! N = current node   P = parent of N   G = grandparent of N
! --- = untraversed node (MARKB=0)     S = SWAPB bit
! === = traversed node   (MARKB=1)
!
!     N R  P=G        P R             P R               R      
!      \|              \|              \|               |      
!     +===+           +===+           +===+           +===+    
!     |A|D| S=0       |G|D| S=1       |A|G| S=0       |A|D| S=0
!     +===+       N   +===+           +===+   N       +===+    
!    /     \       \ /     \         /     \ /       /     \   
! +---+   +---+   +===+   +---+   +===+   +===+   +===+   +===+
! |A|D|   |A|D|   |A|D|   |A|D|   |A|D|   |A|D|   |A|D|   |A|D|
! +---+   +---+   +===+   +---+   +===+   +===+   +===+   +===+
!
!      (1)             (2)             (3)             (4)

! (1) N points to an untraversed tree with root R. Every node
!     is marked (MARKB=1) as soon as it is visited.
! (2) When moving the pointer N from the node R to the CAR child
!     of R, the parent pointer P moves the R. Of course now the
!     parent of the parent (G) has to be stored somewhere.
!     Because N=CAR[P], we can use CAR[P] to store G. We also set
!     the SWAPB bit (S=1) of P.
! (3) When returning to P after traversing CAR[P], the SWAPB bit
!     of P is one, so CDR[P] also needs to be traversed. The
!     same mechanism is used, only G is stored in CDR[P] now, and
!     the original CAR[P] is restored from N. The SWAPB bit of P
!     is cleared.
! (4) When returning to P after traversing CDR[P], the SWAPB bit
!     of P is zero. CDR[P] is restored from N, and traversal
!     returns to G by setting P=G and then N=P.

! When an already-marked node or a special node is found,
! traversal returns to the parent immediately. When an ATOM is
! found (ATOMB=1), its CAR field is ignored and traversal
! immediately proceeds with its CDR field. When returning
! from a node with no parent (P=NIL), traversal ends and the
! entire tree N has been marked.

mark(n) do var p, x;
	p := NIL;
	while (%1) do
		ie (n >= SPCL \/ Tag::n & MARKB) do
			if (p = NIL) leave;
			ie (Tag::p & SWAPB) do	! (3)
				x := Cdr[p];
				Cdr[p] := Car[p];
				Car[p] := n;
				Tag::p := Tag::p & ~SWAPB;
				n := x;
			end
			else do			! (4)
				x := p;
				p := Cdr[x];
				Cdr[x] := n;
				n := x;
			end
		end
		else ie (Tag::n & ATOMB) do
			x := Cdr[n];
			Cdr[n] := p;
			p := n;
			n := x;
			Tag::p := Tag::p | MARKB;
		end
		else do				! (2)
			x := Car[n];
			Car[n] := p;
			Tag::n := Tag::n | MARKB | SWAPB;
			p := n;
			n := x;
		end
	end
end

! Objects pointed to by the following variables are currently
! used by the LISP system. The variables are called "GC Roots",
! because they are the roots of trees in the node pool. Marking
! the GC roots with MARK will mark all currently used nodes.

! SYMBOLS is the list of all symbols known by the system.
! A symbol contained in this list is an Interned Symbol.

var	Symbols;

! ACC is the Accumulator: a register that contains a (partially
! evaluated) expression during the process of evaluation.

var	Acc;

! ENV is the current lexical environment. Its structure will be
! outlined later.

var	Env;

! STACK is a stack (list) that is used to store all kinds of
! temporary values during evaluation, like suspended environments
! or the addresses of nodes that need temporary protection from
! the GC.

var	Stack;

! MSTACK (Mode Stack) is a stack of atoms that indicate the current
! state (mode) of the evaluator.

var	Mstack;

! TMPCAR and TMPCDR protect the CAR and CDR arguments while
! allocating a cons cell.

var	Tmpcar, Tmpcdr;

! The ZNODE is a pair of the form (NIL . NIL) that is
! returned by the node allocator when running out of
! nodes. Some cons cell has to be returned, because
! code may attempt to modify the returned CONS, so just
! returning NIL is not an option.

var	Znode;

! When the VERBOSE_GC flag is set, the number of free
! nodes will be reported after each garbage collection.
! This is not a GC root.

var	Verbose_GC;

! GC is a Mark & Sweep garbage collector.
! In the Mark phase, it marks all GC roots.
! In the Sweep phase, it adds all unmarked
! nodes to the Feelist and unmarks all marked
! nodes.

gc() do var i, k;
	if (Verbose_GC) pr("GC: ");
	mark(Znode);
	mark(Acc);
	mark(Env);
	mark(Symbols);
	mark(Stack);
	mark(Mstack);
	mark(Tmpcar);
	mark(Tmpcdr);
	k := 0;
	Freelist := NIL;
	for (i=0, NNODES) do
		ie (Tag::i & MARKB) do
			Tag::i := Tag::i & ~MARKB;
		end
		else do
			Cdr[i] := Freelist;
			Freelist := i;
			k := k+1;
		end
	end
	if (Verbose_GC) do
		pr(ntoa(k));
		pr(" NODES");
		nl();
	end
	return k;
end

! CONS3 is the principal node allocator of the LISP system.
! A is the CAR value of the new node, D is its new CDR value,
! and if TA is non-zero, the new node is an atomic node.
! CONS3 always returns a node.
! When no free nodes are available, it reports an error and
! the computation in progress is aborted.

cons3(a, d, ta) do var n;
	if (Freelist = NIL) do
		Tmpcdr := d;
		if (\ta) Tmpcar := a;
		gc();
		Tmpcar := NIL;
		Tmpcdr := NIL;
		if (Freelist = NIL) do
			error("out of nodes", UNDEF);
			return Znode;
		end
	end
	n := Freelist;
	Freelist := Cdr[Freelist];
	Car[n] := a;
	Cdr[n] := d;
	Tag::n := ta;
	return n;
end

! CONS allocates and returns a fresh CONS cell.

cons(a, d) return cons3(a, d, 0);

! SAVE saves the node N on the stack.

save(n) Stack := cons(n, Stack);

! UNSAVE removes K nodes from the stack and returns the
! one removed last. E.g. given the stack (N1 N2 N3 N4)
! calling UNSAVE(2) will return N2 and leave N3 and N4 on
! the stack.

unsave(k) do var n;
	while (k) do
		if (Stack = NIL) fatal("stack empty");
		n := Car[Stack];
		Stack := Cdr[Stack];
		k := k-1;
	end
	return n;
end

! *********************
! ***** ACCESSORS *****
! *********************

! These accessors will only be used in this file.
! The actual LISP functions will be defined in the
! LISP part of the system.

caar(x) return Car[Car[x]];
cadr(x) return Car[Cdr[x]];
cdar(x) return Cdr[Car[x]];
cddr(x) return Cdr[Cdr[x]];

caadr(x) return Car[Car[Cdr[x]]];
cadar(x) return Car[Cdr[Car[x]]];
caddr(x) return Car[Cdr[Cdr[x]]];
cdadr(x) return Cdr[Car[Cdr[x]]];
cddar(x) return Cdr[Cdr[Car[x]]];
cdddr(x) return Cdr[Cdr[Cdr[x]]];

caddar(x) return Car[Cdr[Cdr[Car[x]]]];
cdddar(x) return Cdr[Cdr[Cdr[Car[x]]]];

! ***********************************
! ***** SYMBOL TABLE MANAGEMENT *****
! ***********************************

! MKSYM creates an Uninterned Symbol from the string S.
! An uninterned symbols is a symbol that is NOT contained
! in the list of symbols known to the system. Comparing
! uninterned symbols with EQ will always yield NIL.

! The internal structure of an uninterned symbol is as
! follows:
!
!     +---+-------+
!     | O | UNDEF |
!     +-|-+-------+
!       |
!       V
!   +---+---+      +---+---+
!  A|C12| O-----> A|C34| O------> ...
!   +---+---+      +---+---+
!
!  A   = ATOMB bit set
!  C12 = first and second character of the symbol name
!  C34 = third and fourth character of the symbol name (if any)
!
! There is one atomic node for each two characters of the
! symbol name. When the name has an odd number of characters,
! the last character will be NUL.

mksym(s) do var i, n;
        i := 0;
        if (s::i = 0) return NIL;
	n := cons3(NIL, NIL, ATOMB);
        save(n);
        while (%1) do
                Car[n] := s::i << 8 | s::(i+1);
                if (s::(i+1) = 0 \/ s::(i+2) = 0) leave;
                Cdr[n] := cons3(NIL, NIL, ATOMB);
                n := Cdr[n];
                i := i + 2;
        end
        n := unsave(1);
        return cons(n, UNDEF);
end

! SYMSTR returns a string containing the name of the
! (interned of uninterned) symbol N. It writes the name
! to an internal buffer. Subsequent calls to SYMSTR will
! overwrite the buffer.
! SYMSTR returns a pointer to the name in the buffer.

var Symb::SYMLEN+2;

symstr(n) do var i;
        i := 0;
        n := Car[n];
        while (n \= NIL) do
                Symb::i := Car[n] >> 8;
                Symb::(i+1) := Car[n] & 0xff;
                i := i + 2;
                n := Cdr[n];
        end
        Symb::i := 0;
        return Symb;
end

! Find the symbol named S in the list of interned symbols.
! If the symbol is in the list, return it, and otherwise
! return NIL.

findsym(s) do var p;
	p := Symbols;
	while (p \= NIL) do
		if (strequ(s, symstr(Car[p])))
			return Car[p];
		p := Cdr[p];
	end
	return NIL;
end

! Create a pair of boxes for Value and Function bindings.
! Initialize with V=value and F=function.

mkboxes(v, f) return cons(v, cons(f, NIL));

! ADDSYM adds a new symbol to the list of interned symbols.
! When a symbol named S already exists, it returns it.
! Otherwise an uninterned symbol will be created and added
! to the SYMBOLS list. ADDSYM always returns a symbol named S.

! An interned symbol has a Value Box and a Function Box for
! binding it in the function and value namespaces. The internal
! structure of an interned symbol is similar to the structure
! of an uninterned symbol, except for the value boxes:
!
!                     Value Box     Function Box
!     +---+---+       +---+---+      +---+---+
!     | O | O-------> | O | O------> | O |NIL|
!     +-|-+---+       +-|-+---+      +-|-+---+
!       |               |              |
!       |               V              V
!       V             Value          Value
!   +---+---+
!  A|C12| O-----> ...
!   +---+---+

! Normally all value boxes of the new symbol will contain
! the special value UNDEF, which means that the symbol has no
! bindings. When the parameter SELF of ADDSYM is set to a
! non-zero value, though, the new symbol will refer to itself
! through the function box. This is how built-in functions
! are implemented in MICRO COMMON LISP. E.g.:
!
! (FUNCTION CONS)  ==>  CONS
!
! EVAL identifies built-in function by symbol identity.

addsym(s, self) do var n;
	n := findsym(s);
	if (n \= NIL) return n;
	n := mksym(s);
	Symbols := cons(n, Symbols);
	Cdr[n] := mkboxes(UNDEF, self-> n: UNDEF);
	return n;
end

! LOOKUP looks up the symbol X in the current Lexical
! Environment. If FBOX is zero, it looks up the value binding
! of the symbol, if FBOX=1 it looks up the function binding.
! When X is not in the current lexical environment, it looks
! up its global bindings.

! LOOKUP returns the requested binding box of the symbol.

! Note that the same box of a symbol can have multiple
! bindings in different environments, but every box of a
! symbol has only one global binding, which is outlined in
! the description of ADDSYM, above.

! A lexical environment is a list of Association Lists
! (Alists):
!
! (Alist1 Alist2 ...)
!
! A new Alist is added whenever arguments are bound to
! variables in a function call. Each value field of the
! Alist is a list of values, one for each namespace:
!
! ((SYMBOL . (VALUE FUNCTION-VALUE)) ... )
!
! Basically each association in the Alist of a lexical
! environment has the same structure as an interned symbol,
! but with a complete symbol in the CAR fielf instead of
! the characters of the symbol name:
!
!                   Value Box     Function Box
!   +---+---+       +---+---+      +---+---+
!   | O | O-------> | O | O------> | O |NIL|
!   +-|-+---+       +-|-+---+      +-|-+---+
!     |               |              |
!     V               V              V
!   SYMBOL          Value          Value

lookup(x, fbox) do var a ,e;
	e := Env;
	while (e \= NIL) do
		a := Car[e];
		while (a \= NIL) do
			if (caar(a) = x) do
				a := cdar(a);
				if (fbox) a := Cdr[a];
				return a;
			end
			a := Cdr[a];
		end
		e := Cdr[e];
	end
	a := Cdr[x];
	if (fbox) a := Cdr[a];
	return a;
end

! These functions return the Value Box
! and Function Box of a symbol:

valbox(x) return lookup(x, 0);
funbox(x) return lookup(x, 1);

! *******************************
! ***** S-EXPRESSION READER *****
! *******************************

! Keep track of open parentheses.

var	Parens;

! The list reader will have to read S-expressions
! and the S-expression reader will read lists, so
! they are mutually recursive.

decl read(0);

! RDLIST reads a list. It recurses through READ to read
! every member of the list, so it also reads nested lists.
! There are special cases for the dotted pair (X . Y) and
! the empty list (). In a pair the procedure makes sure
! that the pair is valid. Malformed pairs like ( . X) and
! (X . ) will be reported. NIL is returned for ().

! The function uses the append pointer A to append elements
! to the result list. The append pointer will always point
! to the most recently added element:
!
!                    A
!                    |
!                    V
! +---+---+      +---+---+      +---+---+
! | O | O------> | O | O------> |NIL|NIL|
! +-|-+---+      +-|-+---+      +---+---+
!   |              |
!   V              |
! +---+          +---+
! | X |          | Y |
! +---+          +---+

! When adding a new member, A will move to CDR[A], the
! new element will be inserted at CAR[A], and a fresh pair
! of the form (NIL . NIL) will be attached to CDR[A].
!
! Only when inserting the first element, A is NIL and
! will move to LST before inserting the element. See the
! code for details.

rdlist() do var n, lst, a, badpair;
	badpair := "bad pair";
	Parens := Parens+1;
	lst := cons(NIL, NIL);
	save(lst);
	a := NIL;
	while (%1) do
		if (Errflag) return NIL;
		n := read();
		if (n = EOT) return error("missing ')'", UNDEF);
		if (n = DOT) do
			if (a = NIL) return error(badpair, UNDEF);
			n := read();
			Cdr[a] := n;
			if (n = RPAREN \/ read() \= RPAREN)
				return error(badpair, UNDEF);
			unsave(1);
			Parens := Parens-1;
			return lst;
		end
		if (n = RPAREN) leave;
		ie (a = NIL) 
			a := lst;
		else
			a := Cdr[a];
		Car[a] := n;
		Cdr[a] := cons(NIL, NIL);
	end
	Parens := Parens-1;
	if (a \= NIL) Cdr[a] := NIL;
	unsave(1);
	return a = NIL-> NIL: lst;
end

! These characters can appear in a symbol name.
! Note that '\\' is an escape character and not
! really a symbolic character.

symbolic(c) return c >= 'a' /\ c <= 'z' \/
		   c >= 'A' /\ c <= 'Z' \/
		   c >= '0' /\ c <= '9' \/
		   c  = '-' \/ c  = '\\' \/
		   c  = '*' \/ c  = '&';

! The following variables refer to symbols naming
! the special operators of MICRO COMMON LISP. E.g.,
! S_lambda refers to the symbol LAMBDA.

! Other symbols included here that are not standard
! Common LISP symbols are FSETQ, IFNOT, and MACRO.
! S_closure is an internal marker for closures.
! These will be discussed later.

var	S_fsetq, S_function, S_if, S_ifnot, S_lambda,
	S_closure, S_macro, S_progn, S_quote, S_quasiquote,
	S_unquote, S_unquote_splice, S_setq;

! These variables refer to the names of built-in LISP
! functions and other symbols. S_t is T, S_restarg
! is &REST.

var	S_t, S_restarg, S_apply, S_cons, S_car, S_cdr, S_atom,
	S_eq, S_funcall, S_gensym, S_last, S_suspend, S_gc, S_eofp,
	S_load, S_macro_function, S_rplaca, S_rplacd, S_read,
	S_princ, S_terpri, S_error, S_symbols;

! RDSYM reads the characters of a symbol and returns
! an interned symbol. When reading the string "NIL",
! it will return NIL, which is a special value in this
! implementation. Symbol names are folded to upper case.

! Symbols can contain non-symbolic characters when
! escaped with a backslash. Escaped letters are not
! converted to upper case, so FOO is different from
! F\o\o.

rdsym(c) do var s::SYMLEN+1, i;
	i := 0;
	while (symbolic(c)) do
		if (c = '\\') c := rdch();
		ie (SYMLEN = i)
			error("long symbol", UNDEF);
		else if (i < SYMLEN) do
			s::i := c;
			i := i+1;
		end
		c := rdchci();
	end
	s::i := 0;
	Rejected := c;
	if (strequ(s, "NIL")) return NIL;
	return addsym(s, 0);
end

! Report a syntax error. Return zero.

syntax(x) error("syntax", x);

! Return a fresh expression of the form (Q N).
! Used to create quotations like (QUOTE N) or
! (UNQUOTE N), but also forms like (FUNCTION N).

quote(q, n) return cons(q, cons(n, NIL));

! Read a pseudo-string. A pseudo-string is an
! uninterned symbol that consists of exactly the
! characters between two quote (") characters.
! It is intended for use with LOAD and SUSPEND.

rdstr() do var c, s::SYMLEN+1, i;
	i := 0;
	c := rdch();
	while (c \= '"') do
		ie (SYMLEN = i)
			error("long symbol", UNDEF);
		else if (i < SYMLEN) do
			s::i := c;
			i := i+1;
		end
		c := rdch();
	end
	s::i := 0;
	return quote(S_quote, mksym(s));
end

! READ implements the LISP reader. It reads and returns
! a complete S-expression, which is either a symbol or
! a pair/list. The reader skips over whitespace characters
! and comments before reading an S-expression. Whitespace
! characters include the blank, CR, LF, and HT (tab)
! characters. A comment starts with a semicolon an extends
! up to the end of the current line. Because lists contain
! S-expressions, comments can appear inside of lists.

! The MICRO COMMON LISP reader accepts and expands the
! following abbreviations
!
!  'X  = (QUOTE X)
!  `X  = (QUASIQUOTE X)
!  ,X  = (UNQUOTE X)
! ,@X  = (UNQUOTE-SPLICE X)
! #'X  = (FUNCTION X)

! A percent character will be interpreted as the end of file.
! This is not compatible to Common LISP.

read() do var c;
	c := rdchci();
	while (%1) do
		while (c = ' ' \/ c = '\t' \/ c = '\n' \/ c = '\r') do
			if (Errflag) return NIL;
			c := rdchci();
		end
		if (c \= ';') leave;
		while (c \= '\n' /\ c \= '\r') c := rdch();
	end
	if (c = EOT \/ c = '%') return EOT;
	if (c = '(') do
		return rdlist();
	end
	if (c = '\'') do
		return quote(S_quote, read());
	end
	if (c = '`') do
		return quote(S_quasiquote, read());
	end
	if (c = ',') do
		c := rdchci();
		if (c = '@') return quote(S_unquote_splice, read());
		Rejected := c;
		return quote(S_unquote, read());
	end
	if (c = '#') do
		c := rdch();
		if (c \= '\'') syntax(UNDEF);
		return quote(S_function, read());
	end
	if (c = ')') do
		if (\Parens) error("extra paren", UNDEF);
		return RPAREN;
	end
	if (c = '.') do
		if (\Parens) error("free dot", UNDEF);
		return DOT;
	end
	if (symbolic(c)) do
		return rdsym(c);
	end
	if (c = '"') do
		return rdstr();
	end
	syntax(UNDEF);
	return UNDEF;
end

! ********************************
! ***** S-EXPRESSION PRINTER *****
! ********************************

! An Atom is everything that is not a list. In MICRO COMMON LISP
! this includes all symbols (interned or uninterned) as well as
! all special nodes, like NIL, the EOT, of the undefined value.

! Note, again, that a symbol is a CONS whose CAR field has the
! ATOMB bit set!

! ATOMP returns truth, if N is an atom.

atomp(n) return n >= SPCL \/ Car[n] < SPCL /\ Tag::Car[n] & ATOMB;

! ATOMIC is like ATOMP, but also recognizes functions as atoms,
! which are conses internally. It is mostly used for type checking.

atomic(n) return atomp(n) \/ Car[n] = S_closure;

! SYMBOLP returns truth, if N is a symbol. This excludes all
! special nodes.

symbolp(n) return n < SPCL /\ Car[n] < SPCL /\ Tag::Car[n] & ATOMB;

! PRINT2 prints the S-expression N. The parameter D is used
! to keep track of the depth of a list while printing. When
! the depth exceeds the PRDEPTH constant, printing is aborted,
! assuming that the printed structure is cyclic.

! PRINT2 will print <EOT> for the special value EOT and
! <FUNCTION> for function objects, which have the internal
! form (<CLOSURE> ...). It will print <UNPRINTABLE> for
! objects that it cannot print.

print2(n, d) do
	if (d > PRDEPTH) error("print depth", UNDEF);
	if (Errflag) return error("stop", UNDEF);
	ie (n = NIL) do
		pr("NIL");
	end
	else ie (n = EOT) do
		pr("<EOT>");
	end
	else ie (n >= SPCL \/ Tag::n & ATOMB) do
		pr("<UNPRINTABLE>");
	end
	else ie (symbolp(n)) do
		pr(symstr(n));
	end
	else do	! List
		if (\atomp(n) /\ Car[n] = S_closure) do
			pr("<FUNCTION>");
			return;
		end
		pr("(");
		while (n \= NIL) do
			print2(Car[n], d+1);
			n := Cdr[n];
			ie (symbolp(n)) do
				pr(" . ");
				print2(n, d+1);
				n := NIL;
			end
			else if (n \= NIL) do
				pr(" ");
			end
		end
		if (\Errflag) pr(")");
	end
end

! PRINT is the LISP printer.

print(n) print2(n, 0);

! **************************
! ***** IMAGE FILE I/O *****
! **************************

! The magic identifier identifying a
! MICRO COMMON LISP image file.
! Will be initialized in INIT.

var	Magic;

! The number to be appended to GENSYM symbols.
! Needs to be stored in the image file, so no
! duplicates will be generated.

var	Id;

! Write buffer B of length K to file FD.
! Report an error when the write fails.

dowrite(fd, b, k)
	if (t.write(fd, b, k) \= k)
		error("image write error", UNDEF);

! SUSPEND writes a LISP image to the file S.
! The image consists of the following parts:
!
!           OFFSET       SIZE   DESCRIPTION
! +---------------------------------------------------------+
! |              0 |        4 | Magic identifier            |
! |              4 |        2 | Number of nodes in the pool |
! |              6 |        2 | Bytes per machine word (W)  |
! |              8 |        2 | Address of the Freelist     |
! |             10 |        2 | Address of the Symbols list |
! |             12 |        2 | Current GENSYM id           |
! |             14 | W*NNODES | CAR fields of the node pool |
! |  W*NNODES + 14 | W*NNODES | CDR fields of the node pool |
! | 2W*NNODES + 14 |   NNODES | TAG fields of the node pool |
! +----------------+----------+-----------------------------+
! | 2W*NNODES      |          |                             |
! |  + NNODES + 14 |          | End of file / total size    |
! +---------------------------------------------------------+
!
! W = machine word size
! All numbers and addresses in the header are in Big Endian order.
! All addresses in the CAR and CDR pools are in native order.

suspend(s) do var fd, k, buf::20;
	fd := t.open(s, T3X.OWRITE);
	if (fd < 0) error("suspend", mksym(s));
	k := strlen(Magic);
	t.memcopy(buf, Magic, k);
	buf::(k) := (NNODES >> 8);
	buf::(k+1) := NNODES;
	buf::(k+2) := 0;
	buf::(k+3) := t.bpw();
	buf::(k+4) := (Freelist >> 8);
	buf::(k+5) := Freelist;
	buf::(k+6) := (Symbols >> 8);
	buf::(k+7) := Symbols;
	buf::(k+8) := (Id >> 8);
	buf::(k+9) := Id;
	dowrite(fd, buf, k+10);
	dowrite(fd, Car, NNODES * t.bpw());
	dowrite(fd, Cdr, NNODES * t.bpw());
	dowrite(fd, Tag, NNODES);
	t.close(fd);
end

! Read K bytes from file FD into buffer B.
! Report an error when fewer than K bytes were read.

doread(fd, b, k)
	if (t.read(fd, b, k) \= k)
		fatal("image read error");

! FASLOAD loads an image file. When the image cannot be
! opened, it returns silently. In this case the interpreter
! will run in a minimal configuration that is sufficient
! for bootstrapping the LISP system.

! The image file S must have a valid Magic ID, the
! same machine word size as the LISP system, and the
! same node pool size. It should probably also check
! endianness, but currently does not.

fasload(s) do var fd, k, n, m, buf::20;
	fd := t.open(s, T3X.OREAD);
	if (fd < 0) return;
	k := strlen(Magic);
	doread(fd, buf, k+10);
	n := buf::k << 8 | buf::(k+1);
	m := buf::(k+2) << 8 | buf::(k+3);
	if (n \= NNODES \/ m \= t.bpw() \/ t.memcomp(buf, Magic, k))
		fatal("bad image");
	Freelist := buf::(k+4) << 8 | buf::(k+5);
	Symbols := buf::(k+6) << 8 | buf::(k+7);
	Id := buf::(k+8) << 8 | buf::(k+9);
	doread(fd, Car, NNODES * t.bpw());
	doread(fd, Cdr, NNODES * t.bpw());
	doread(fd, Tag, NNODES);
	t.close(fd);
end

! ***********************************
! ***** BUILT-IN LISP FUNCTIONS *****
! ***********************************

! CHECK checks the parameters of a function call.
!
! X is the S-expression of the function call.
! K0 is the minimum number of expected arguments + 1
! KN is the maximum number of expected arguments + 1.
! When KN is -1, there is no upper limit.
!
! When the number of arguments is not in the expected
! range, an error is reported.

check(x, k0, kn) do var i, a;
	i := 0;
	a := x;
	while (a \= NIL) do
		i := i+1;
		a := Cdr[a];
	end;
	if (i < k0 \/ (kn \= %1 /\ i > kn))
		syntax(x);
end

! The number of nested LOAD calls.

var	Loads;

! Input buffer for LOAD. Each time LOAD is called,
! another segment of the buffer is used:
!
! +-----...-----+-----...-----+ ... +-----...-----+
! |             |             |     |             |
! +-----...-----+-----...-----+ ... +-----...-----+
!  First LOAD    Second LOAD         NLOAD'th LOAD

var	Tmpbuf::NLOAD*BUFLEN;

! LOAD needs EVAL.

decl eval(1);

! LOAD saves all parameters of the buffered input mechanism,
! then resets them and allocates a new buffer from TMPBUF
! above. It then reads expressions from its imput file (S)
! and evaluates them. It stops when the end of the input
! file is reached or an evaluation fails. Before exiting
! it restores the original parameters for input buffering,
! so that input will be read from the previous source again.

! The file name S is converted to all-lowercase.

load(s) do var fd, ib, ip, ik, in, re;
	if (Loads >= NLOAD) return error("load limit", UNDEF);
	fd := t.open(s, T3X.OREAD);
	if (fd < 0) return error("load", mksym(s));
	in := Input;
	ip := Inp;
	ik := Ink;
	ib := Inbuf;
	re := Rejected;
	Input := fd;
	Inbuf := @Tmpbuf::(Loads*BUFLEN);
	Inp := 0;
	Ink := 0;
	Rejected := EOT;
	Loads := Loads+1;
	Line := 1;
	while (\Errflag) do
		Acc := read();
		if (Acc = EOT) leave;
		eval(Acc);
	end
	Line := 0;
	t.close(fd);
	Loads := Loads-1;
	Rejected := re;
	Inbuf := ib;
	Ink := ik;
	Inp := ip;
	Input := in;
end

! Signal a type error in the expression X, return NIL;

type(x) return error("type", x);

! BUILTIN evaluates calls of built-in functions
! and returns their values. The patterns is similar
! for all functions:
!
! - check the number of arguments
! - check the types of the arguments
! - handle any special cases
! - apply the function and return its value
!
! Type checking is skipped, if the function has
! no limited domain, like CONS, PRINT, EQ, etc.

! Functions implemented here include the following
! standard Common LISP functions:
!
! CAR, CDR, EQ, ATOM, CONS, RPLACA, RPLACD, GENSYM,
! MACRO-FUNCTION, READ, PRIN1, TERPRI, LOAD.
!
! They appear in this order so that fast and
! frequently-used function will be identified early.

! BUILTIN also implements the following non-standard
! functions:
!
! (EOFP X)     Return T, if X is the EOT object.
! (ERROR M X)  Abort computation with error message M
!              and optional argument X.
! (GC)         Perform a garbage collection and return
! (GC T/NIL)   the number of free nodes as an uninterned
!              symbol. Optionally enable or disable
!              verbose garbage collections.
! (SUSPEND S)  Write image to file S.
! (SYMBOLS)    Return the list of interned symbols.

! Also note that built-in functions are just symbols.
! (FUNCTION X) ==> X for any built-in function symbol.

builtin(x) do var s, n;
	if (S_car = Car[x]) do
		check(x, 2, 2);
		n := cadr(x);
		if (n = NIL) return NIL;
		if (atomic(n)) return type(x);
		return Car[n];
	end
	if (S_cdr = Car[x]) do
		check(x, 2, 2);
		n := cadr(x);
		if (n = NIL) return NIL;
		if (atomic(n)) return type(x);
		return Cdr[n];
	end
	if (S_eq = Car[x]) do
		check(x, 3, 3);
		return cadr(x) = caddr(x)-> S_t: NIL;
	end
	if (S_atom = Car[x]) do
		check(x, 2, 2);
		return atomic(cadr(x))-> S_t: NIL;
	end
	if (S_cons = Car[x]) do
		check(x, 3, 3);
		return cons(cadr(x), caddr(x));
	end
	if (S_rplaca = Car[x]) do
		check(x, 3, 3);
		if (atomic(cadr(x))) return type(x);
		Car[cadr(x)] := caddr(x);
		return cadr(x);
	end
	if (S_rplacd = Car[x]) do
		check(x, 3, 3);
		if (atomic(cadr(x))) return type(x);
		Cdr[cadr(x)] := caddr(x);
		return cadr(x);
	end
	if (S_gensym = Car[x]) do
		check(x, 1, 1);
		Id := Id+1;
		s := ntoa(Id);
		s := s-1;
		s::0 := '#';
		return addsym(s, 0);
	end
	if (S_macro_function = Car[x]) do
		check(x, 2, 2);
		n := cadr(x);
		if (\symbolp(n)) return type(x);
		n := Car[funbox(n)];
		if (n = UNDEF \/ Car[n] \= S_macro) return NIL;
		return Cdr[n];
	end
	if (S_eofp = Car[x]) do
		check(x, 2, 2);
		return cadr(x) = EOT-> S_t: NIL;
	end
	if (S_read = Car[x]) do
		check(x, 1, 1);
		return read();
	end
	if (S_princ = Car[x]) do
		check(x, 2, 2);
		print(cadr(x));
		return cadr(x);
	end
	if (S_terpri = Car[x]) do
		check(x, 1, 1);
		nl();
		return S_t;
	end
	if (S_load = Car[x]) do
		check(x, 2, 2);
		if (\symbolp(cadr(x))) return type(x);
		load(symstr(cadr(x)));
		return S_t;
	end
	if (S_error = Car[x]) do
		check(x, 2, 3);
		if (\symbolp(cadr(x))) return type(x);
		ie (cddr(x) = NIL)
			error(symstr(cadr(x)), UNDEF);
		else
			error(symstr(cadr(x)), caddr(x));
		return UNDEF;
	end
	if (S_gc = Car[x]) do
		check(x, 1, 2);
		if (Cdr[x] \= NIL)
			Verbose_GC := cadr(x) \= NIL;
		return mksym(ntoa(gc()));
	end
	if (S_suspend = Car[x]) do
		check(x, 2, 2);
		if (\symbolp(cadr(x))) return type(x);
		suspend(symstr(cadr(x)));
		return S_t;
	end
	if (S_symbols = Car[x]) do
		check(x, 1, 1);
		return Symbols;
	end
	syntax(x);
	return UNDEF;
end

! **************************************
! ***** BUILT-IN SPECIAL OPERATORS *****
! **************************************

! Return truth, if N is a symbol denoting a
! built-in special operator. Again, ordered
! for fast lookup.

specialp(n)
	return	n = S_quote \/
		n = S_if \/
		n = S_progn \/
		n = S_ifnot \/
		n = S_lambda \/
		n = S_function \/
		n = S_closure \/
		n = S_setq \/
		n = S_fsetq;

! The evaluator is always in one of the following
! modes/states:

! MHALT - halt evaluation, return result
! MEXPR - start evaluation of expression
! MLIS1 - evaluate function of function call
! MLIST - evaluate arguments of function call
! MCALL - perform function call
! MRETN - return from function call
! MPRED - evaluate predicate of IF
! MNOTP - evaluate predicate of IFNOT
! MPROG - evaluate body of PROGN
! MSETQ - evaluate value of SETQ
! MFSET - evaluate value of FSETQ

struct MODES =	MHALT, MEXPR, MLIS1, MLIST, MCALL, MRETN,
		MPRED, MNOTP, MPROG, MSETQ, MFSET;

! Save (push) current state on MSTACK.

msave(n) Mstack := cons3(n, Mstack, ATOMB);

! Restore (pop) saved state from MSTACK.

munsave() do var n;
	if (Mstack = NIL) fatal("mstack empty");
	n := Car[Mstack];
	Mstack := Cdr[Mstack];
	return n;
end

! Check the syntax of the &REST argument. There must
! be exactly one argument after &REST. I.e. (&REST) is
! wrong, and so is (&REST X Y).

ckrest(p, x) do
	if (Cdr[p] = NIL \/ cddr(p) \= NIL) return syntax(x);
	return %1;
end

! Check the syntax of LAMBDA. There must be at least two
! arguments and the first one, the argument list, must be
! a list of symbols. The argument list may contain one
! &REST keyword, as described above.

! The argument list may be dotted, where the variable
! after the dot serves as a &REST argument. This is *not*
! valid Common LISP syntax, but MICRO COMMON LISP uses
! this notation internally. When CKLAM finds a &REST
! keywords, it replaces the cons cell of &REST with the
! argument following &REST.

! The transformations
!   (&REST X) -> X       and
! (X &REST Y) -> (X . Y)
! are performed in-situ, which is why CKLAM also has to
! accept the dotted list syntax.

! Another side effect is that dotted argument lists may
! appear in error messages.

! This could be fixed by making a flat copy of the LAMBDA
! expression and replacing the argument list in the copy.

cklam(x) do var p, q;
	check(x, 3, %1);
	p := cadr(x);
	if (Car[p] = S_restarg) do
		if (ckrest(p, x)) Car[Cdr[x]] := cadr(p);
		return;
	end
	while (\atomp(p)) do
		if (\symbolp(Car[p])) syntax(x);
		if (Car[p] = S_restarg) do
			if (ckrest(p, x)) Cdr[q] := cadr(p);
			return;
		end
		q := p;
		p := Cdr[p];
	end
end

! Create a function/closure from the lambda form X.
! A function has the internal form
!
! (<CLOSURE> ENV (ARG ...) EXPR ...)
!
! where ENV is the lexical environment of the function
! and <CLOSURE> is an internal symbol.

mkfun(x) return cons(S_closure, cons(Env, Cdr[x]));

! Report an unbound symbol.

undefd(x) return error("undefined", x);

! SPECIAL evaluates special forms and returns their
! values. Its internal mechanism is similar to the
! BUILTIN procedure, but in addition it can modify
! the evaluator mode (PM[0]) and the MSTACK.

! X is a function application with its arguments
! unevaluated. PM is the address of the evaluator mode,
! so changing PM[0] will change the mode.

! SPECIAL can return expressions that need evaulation.
! For example, in the evaluation of (IF P X Y), the
! nest step would be the evaluation of the predicate
! P, so SPECIAL would set the evaluator mode to MEXPR
! and return P. It would also push MPRED to the MSTACK,
! so the evaluator will continue the evaluation of the
! IF form as soon as the value of P is known.

! When SPECIAL returns an expression to evaluate, it
! will typically also store other expressions on the
! stack for later evaluation. For example, when
! evaluating (IF P X Y), it will push (X Y) to the
! stack, push MPRED to the MSTACK, set the mode to
! MEXPR and return P.
! The evaluator will then evaluate P, and when it is
! done it will pop MPRED from the MSTACK. In MPRED
! mode, it will check the value of P (now in ACC) and
! then select either X or Y from the stack and go back
! to MEXPR mode in order to evaluate it.

! In many other cases SPECIAL will just return a value,
! like in QUOTE, FUNCTION, LAMBDA, etc. In these cases
! it will immediately restore the previous mode from
! the MSTACK, because the evaluation of the special
! form is complete.

! The FSETQ and IFNOT special forms are not Common LISP
! forms.
!
! (FSETQ X Y)    is like SETQ, but modifies the function
! (FSETQ X Y T)  box of a symbol. When a third argument
!                is given (no matter which), it always
!                modified the global function box of F.
! (IFNOT X Y)    evalutes to X, if X it not NIL and
!                otherwise to Y. X is never evaluated
!                twice, so IFNOT can, for example,
!                implement OR without using LET.

special(x, pm) do
	if (S_quote = Car[x]) do
		check(x, 2, 2);
		pm[0] := munsave();
		return cadr(x);
	end
	if (S_if = Car[x]) do
		check(x, 4, 4);
		msave(MPRED);
		pm[0] := MEXPR;
		save(cddr(x));
		return cadr(x);
	end
	if (S_progn = Car[x]) do
		pm[0] := MEXPR;
		if (Cdr[x] = NIL) return NIL;
		if (cddr(x) = NIL) return cadr(x);
		msave(MPROG);
		save(cddr(x));
		return cadr(x);
	end
	if (S_ifnot = Car[x]) do
		check(x, 3, 3);
		msave(MNOTP);
		pm[0] := MEXPR;
		save(caddr(x));
		return cadr(x);
	end
	if (S_lambda = Car[x]) do
		cklam(x);
		pm[0] := munsave();
		return mkfun(x);
	end
	if (S_function = Car[x]) do var n, m;
		n := cadr(x);
		pm[0] := munsave();
		ie (S_lambda = Car[n]) do
			cklam(n);
			return mkfun(n);
		end
		else do
			m := Car[funbox(n)];
			if (m = UNDEF \/ Car[m] = S_macro)
				undefd(n);
			return m;
		end
	end
	if (S_closure = Car[x]) do
		pm[0] := munsave();
		return x;
	end
	if (S_setq = Car[x] \/ S_fsetq = Car[x]) do
		check(x, 3, 4);
		if (\symbolp(cadr(x))) syntax(x);
		msave(Car[x] = S_setq-> MSETQ: MFSET);
		pm[0] := MEXPR;
		save(Cdr[x]);
		return caddr(x);
	end
	syntax(x);
	return UNDEF;
end

! **************************
! ***** MACRO EXPANDER *****
! **************************

! NREVERSE reverses a list in situ and returns the
! reversed list. Note that just doing nreverse(X) will
! not reverse X! This is because the head of the
! original list will become the tail of the new list:
!
!     X = (A B C D E)
!          |
!          V
! (E D C B A)
!
! So after nreverse(X), X will be (A). In order to
! make X point to the reversed list, the statement
!
! X := nreverse(X);
!
! has to be used. The same caveat applies to the LISP
! function NREVERSE.

nreverse(n) do var m, h;
	m := NIL;
	while (n \= NIL) do
		h := Cdr[n];
		Cdr[n] := m;
		m := n;
		n := h;
	end
	return m;
end

! Count nested macro expansion.

var	Exlev;

! EXPAND expands all macros in the expression X.

! A macro is an object of the form (MACRO . <FUNCTION>)
! that is bound in the function box of a symbol.
! <FUNCTION> is the macro expander of the macro. It
! converts the macro application to its expanded form.

! If the M in an expression X = (M A B ...) is a macro,
! EXPAND will create a new expression of the form
!
! (APPLY EXP `(QUOTE ,(CDR X)))
!
! where EXP is the macro-expander associated with the
! macro M.

! EXPAND then submits the expression
! (APPLY EXP `(QUOTE ,(CDR X)))
! for evaluation and expands the returned value again
! to expand any macros that are left in the expanded
! form or have been introduced during expansion.

! If the M in X = (M A B ...) is not a macro, EXPAND
! will expand every member of the list (M A B ...).

! If the expression to expand is a lambda function,
! EXPAND will expand every expression in the body of
! the function, but will skip over the keyword LAMBDA
! and the argument list.

! EXPAND returns a new expression with all macro
! applications expanded.

! EXPAND will not recurse more than EXDEPTH times,
! mostly in order to avoid stack overflows due to
! infinte expansion.

! Macro expansion costs 12 bytes per recursion level,
! so with the default EXDEPTH, it will stop at a
! stack depth of 12 * 128 = 1536 bytes.

expand(x) do var n, m, skip;
	if (atomp(x)) return x;
	if (Car[x] = S_quote) return x;
	if (Exlev >= EXDEPTH)
		return error("expansion limit", UNDEF);
	Exlev := Exlev + 1;
	n := symbolp(Car[x])-> Car[funbox(Car[x])]: UNDEF;
	if (n \= UNDEF /\ Car[n] = S_macro) do
		m := quote(S_quote, Cdr[x]);
		m := cons(m, NIL);
		m := cons(Cdr[n], m);
		m := cons(S_apply, m);
		save(m);
		n := eval(m);
		Car[Stack] := n;
		n := expand(n);
		unsave(1);
		Exlev := Exlev - 1;
		return n;
	end
	m := x;
	while (\atomp(m)) m := Cdr[m];
	if (symbolp(m)) do
		Exlev := Exlev - 1;
		return x;
	end
	save(x);
	n := NIL;
	save(n);
	skip := Car[x] = S_lambda-> 2: 0;
	while (x \= NIL) do
		m := skip-> Car[x]: expand(Car[x]);
		n := cons(m, n);
		Car[Stack] := n;
		x := Cdr[x];
		if (skip) skip := skip-1;
	end
	n := nreverse(unsave(1));
	unsave(1);
	Exlev := Exlev - 1;
	return n;
end

! *********************
! ***** EVALUATOR *****
! *********************

! BINDARGS creates a pair of new binding boxes for each
! variable in the list V and stores the corresponding
! argument value from the list A in its value box. The
! function box of each variable will be set to UNDEF
! (undefined).

! If V is a NIL-terminated list, there must be exactly
! one argument for each variable, i.e. the lists V and
! A must have the same length.

! If V is a dotted list, the list A may be longer than
! the list V. In this case a list of all extra arguments
! will be bound to the symbol after the dot.

! All new bingings created by BINDARGS will be put in
! an Alist and the new Alist will then be consed to the
! lexical environment Env. Hence the bindings in the new
! Alist will override or shadow all existing bindings in
! Env.

! An error is reported when there are too few or too
! many arguments in A.

bindargs(v, a) do var e, n;
	e := NIL;
	save(e);
	while (\atomp(v)) do
		if (a = NIL) return error("too few args", Acc);
		n := cons(Car[v], mkboxes(Car[a], UNDEF));
		e := cons(n, e);
		Car[Stack] := e;
		v := Cdr[v];
		a := Cdr[a];
	end
	ie (symbolp(v)) do
		n := cons(v, mkboxes(a, UNDEF));
		e := cons(n, e);
		Car[Stack] := e;
	end
	else if (a \= NIL) do
		return error("extra args", Acc);
	end
	Env := cons(e, Env);
	unsave(1);
end

! FUNCALL performs a call to a lambda function. Calls
! to built-in functions will be handled by the BUILTIN
! procedure discussed earlier.

! A function is called by
!
! - saving the current lexical environment (Env)
! - fetching a new lexical environment from the function
! - binding the function arguments to the function's
!   variables
! - saving the MRETN mode on the MSTACK, which will
!   later restore the saved environment
! - returning the body of the function for evaluation
!
! Because the body may consist of multiples expressions,
! a PROGN form is wrapped around the body.

! FUNCALL also performs tail call optimization (TCO).
! If the MRETN mode is currently on the top of the
! MSTACK, the current function call is a tail call. In
! this case the current environment does not need to
! be saved or restored later.
! This optimization basically turns a function call
! into a jump to the function. It makes sure that
! tail-recursive programs evaluate in constant space.
!
! This is important, because MICRO COMMON LISP uses
! tail recursion to implement loops.

! The layout of the components in the function call
! is as follows:
!
! X = ((<CLOSURE> ENV VARS BODY ...) ARG ...)
!
!     [o|o]--->[o|o]---> ...
!      |        |
!      |        V
!      |       ARG
!      V
!    [o|o]--->[o|o]--->[o|o]---> BODY
!     |        |        |
!     V        V        V
! <CLOSURE>   ENV      VARS
!
! So: (CADAR X)  is ENV
!     (CADDAR X) is VARS
!     (CDDDAR X) is BODY

funcall(x) do
	if (atomp(Car[x]) \/ caar(x) \= S_closure)
		syntax(x);
	ie (Mstack \= NIL /\ Car[Mstack] = MRETN) do
		Env := cadar(x);
		bindargs(caddar(x), Cdr[x]);
	end
	else do
		save(Env);
		Env := cadar(x);
		bindargs(caddar(x), Cdr[x]);
		msave(MRETN);
	end
	return cons(S_progn, cdddar(x));
end

! EVAL evaluates the expression X and returns its value.

! EVAL is a push-down state machine with eleven states
! enumerated earlier in the MODES struct. It starts with
! MHALT on the mode stack so that it will halt after
! evaluating X. Its initial mode is MEXPR. While an
! expression evaluates, its intermediate results are
! kept in the Accumulator ACC.

! In MEXPR mode EVAL evaluates symbols to their values
! and special nodes (like NIL) to themselves. It applies
! special operators directly. When a function call is
! found in MEXPR mode, the evaluator saves the tail of
! the list as well as NIL on the stack and loads ACC
! with the head of the list. This causes the head of
! the list to be evaluated in the next iteration. It
! also pushes MLIS1 to the MSTACK.

! In MLIS1 and MLIST mode, the result in ACC is consed
! to the list on top of the stack, and the next element is
! extracted from the second element on the stack. After
! evaluating the first list element in MLIS1 mode, the
! evaluator switches to MLIST mode for the remaining
! elements.

! The difference between the two modes is that only
! symbols and LAMBDA expressions will be accepted in MEXPR
! mode when MLIS1 is on top of the MSTACK and values of
! symbols will be looked up in their function boxes. When
! MLIST (or anything else, in fact) is on top of the MSTACK,
! all kinds of expressions are accepcted and values of
! symbols are looked up in their value boxes.

! The evaluator oscillates between MLIST and MEXPR mode
! until all elements of list have been evaluated. When the
! source list (second stack element) is empty, it reverses
! the result list (top of stack) in situ and switches to
! MCALL mode.

! In MCALL mode the evaluator performs a function call.
! If the first element of the evaluated list is still a
! symbol, it runs a built-in function and otherwise it
! performs a lambda function call. A built-in function
! returns a value immediately, so the evaluator switches
! back to the previous mode. The FUNCALl function returns
! a function body, so EVAL switches to MEXPR mode to
! evaluate the body.

! FUNCALL also pushes the MRETN mode (except in a tail call),
! so after evaluating the body, the evaluator enters MRETN
! mode, in which it restores the lexical environment of the
! caller and returns to the previous mode.

! Other modes:

! MPRED mode processes IF expressions. Given an expression
! (IF P X Y), SPECIAL pushes MPRED to the MSTACK and (X Y)
! to the stack and returns P in MEXPR mode. After evaluating
! P, MPRED mode selects X or Y depending on the value of ACC.

! MNOTP is similar, but processes (IFNOT X Y).

! MSETQ and MFSET process the (SETQ X Y), (FSETQ X Y), and
! (FSETQ X Y T) special forms. In all cases SPECIAL sets up
! the evaluation of Y and pushes (X Y) [or (X Y T)] on the
! stack. The MSETQ or MFSET mode then stores the value of ACC
! in the corresponding box of X. If FSETQ has an additional
! argument, the value will be stored in the global function
! box of X, even if a local X exists.

! MPROG processes PROGN forms with at least two expressions.
! PROGN forms with fewer expressions are evaluated directly
! without pushing MPROG. MPROG simply evaluates the next
! expression from a list pushed by SPECIAL until there is
! only one expresion left. For this last expression MPROG
! switches to MEXPR mode without pushing MPROG again.

! MHALT returns ACC, thereby ending evaluation.

! Before evaluation starts, EVAL macro-expands the expression 
! passed to it. Macro expansion involves the recursive
! application of EVAL.

! Then there is one nice hack in EVAL. You may have noticed
! that the APPLY and FUNCALL functions are not implemented
! in the BUILTIN procedure. This is because both of them
! involve function calls and doing so inside of BUILTIN would
! break tail call optimization. So EVAL is making use of two
! simple observations: after evaluating the arguments of APPLY
! and FUNCALL,
!
! (FUNCALL F X ...)  ==  (F X ...)
!
! and
!
! (APPLY F (X ...))  ==  (CONS F (X ...))  ==  (F X ...)
!
! The effect of FUNCALL is to look up a function binding in
! the value/variable namespace. When evaluating all members
! of the function call (FUNCALL F ...), F is in the second
! slot, so it is automatically been looked up in the value
! namespace. So the FUNCALL symbol can simply be removed at
! this point.
!
! The effect of (APPLY F LIST) is to apply the function F
! to the arguments in LIST, so after evaluating the arguments
! F and LIST, F can simply be consed to LIST and the resulting
! function call can then be performed.
!
! EVAL performs these transformations in the MCALL state.
! It performs the transformtions in a loop to also allow
! for constructs like
! (APPLY #'FUNCALL ...) and (FUNCALL #'APPLY ...).

eval(x) do var n, m;
	Acc := x;
	if (\Exlev) Acc := expand(Acc);
	msave(MHALT);
	m := MEXPR;
	while (\Errflag) do
		ie (m = MEXPR) do
			if (\Batch /\ con.pollkey() = 3)
				error("stop", UNDEF);
			if (Car[Mstack] = MLIS1) do
				if (symbolp(Acc)) do
					n := Car[funbox(Acc)];
					if (n = UNDEF) undefd(Acc);
					Acc := n;
					m := munsave();
					loop;
				end
				if (Car[Acc] \= S_lambda) syntax(Acc);
			end
			ie (symbolp(Acc)) do
				n := Car[valbox(Acc)];
				if (n = UNDEF) undefd(Acc);
				Acc := n;
				m := munsave();
			end
			else ie (atomp(Acc)) do
				m := munsave();
			end
			else ie (specialp(Car[Acc])) do
				Acc := special(Acc, @m);
			end
			else do
				save(Cdr[Acc]);
				Acc := Car[Acc];
				save(NIL);
				msave(MLIS1);
			end
		end
		else ie (m = MLIS1 \/ m = MLIST) do
			n := cadr(Stack);
			ie (atomp(n)) do
				if (n \= NIL) syntax(UNDEF);
				Acc := nreverse(cons(Acc, unsave(1)));
				unsave(1);
				m := MCALL;
			end
			else do
				Car[Stack] := cons(Acc, Car[Stack]);
				Acc := caadr(Stack);
				Car[Cdr[Stack]] := cdadr(Stack);
				msave(MLIST);
				m := MEXPR;
			end
		end
		else ie (m = MCALL) do
			while (%1) do
				ie (Car[Acc] = S_funcall)
					Acc := Cdr[Acc];
				else ie (Car[Acc] = S_apply)
					Acc := cons(cadr(Acc), caddr(Acc));
				else
					leave;
			end
			ie (symbolp(Car[Acc])) do
				Acc := builtin(Acc);
				m := munsave();
			end
			else do
				Acc := funcall(Acc);
				m := MEXPR;
			end
		end
		else ie (m = MRETN) do
			Env := unsave(1);
			m := munsave();
		end
		else ie (m = MPRED) do
			n := unsave(1);
			ie (Acc = NIL)
				Acc := cadr(n);
			else
				Acc := Car[n];
			m := MEXPR;
		end
		else ie (m = MNOTP) do
			n := unsave(1);
			ie (Acc = NIL) do
				Acc := n;
				m := MEXPR;
			end
			else do
				m := munsave();
			end
		end
		else ie (m = MSETQ \/ m = MFSET) do
			n := unsave(1);
			ie (m = MSETQ)
				Car[valbox(Car[n])] := Acc;
			else ie (cddr(n) \= NIL)
				Car[cddar(n)] := Acc;
			else
				Car[funbox(Car[n])] := Acc;
			m := munsave();
		end
		else ie (m = MPROG) do
			ie (cdar(Stack) = NIL) do
				Acc := Car[unsave(1)];
				m := MEXPR;
			end
			else do
				Acc := caar(Stack);
				Car[Stack] := cdar(Stack);
				msave(MPROG);
				m := MEXPR;
			end
		end
		else ie (m = MHALT) do
			return Acc;
		end
		else do
			fatal("bad mode");
		end
	end
	return NIL;
end

! ***************************************
! ***** INITIALIZATION AND SHUTDOWN *****
! ***************************************

! RESET resets all reader and evaluator variables
! (and a few more). This will be done each time
! the REPL starts over.

! When the parameter Z is not zero, the ZNODE
! will be cleared. This is not possible when
! calling RESET for the first time, because
! the ZNODE has not yet been allocated.

! RESET is called with Z=0 to initialize the
! GC roots (with NIL) before running the first GC.

reset(z) do
	Exlev := 0;
	Parens := 0;
	Loads := 0;
	Errflag := 0;
	Line := 0;
	Acc := NIL;
	Env := NIL;
	Stack := NIL;
	Mstack := NIL;
	Tmpcar := NIL;
	Tmpcdr := NIL;
	if (z) do
		Car[Znode] := NIL;
		Cdr[Znode] := NIL;
	end
end

! INIT Initializes the system:
!
! - Set up the CONSOLE interface
!   (except when in Batch mode)
! - Set up the Magic ID
! - Clear the Symbol list and the Freelist
! - Clear the history buffers
! - Set the GENSYM ID to 0
! - Flush the input channel
! - Make garbage collection non-verbose
! - Clear all TAG bits so that no nodes
!   have their MARKB bit set
! - Allocate the Znode
! - Reset the evaluator state

! The rest of the procedure adds all kinds of symbols,
! like the names of the special operators (with UNDEF
! bindings, so they appear to be undefined) and the
! names of built-in function (which are bound to their 
! own names via the function box).

! The symbol T refers to itself through the value box.

! The console is set up for a VT100 terminal on CP/M.
! The CON.SETUP parameter is ignored on Unix and DOS.

init() do
	if (\Batch) do
		con.setup([LINES, "\e[H\e[J", "\e[K", "\e[%yd1;%xd1H",
			"\eM", "\e[?25l", "\e[?25h", "\e[7m", "\e[m"]);
		clear();
		if (COLUMNS > BUFLEN)
			fatal("screen too wide");
	end
	Magic := "MC06";
	Symbols := NIL;
	Freelist := NIL;
	Auxb1::0 := 0;
	Auxb2::0 := 0;
	Id := 0;
	flushinp();
	Verbose_GC := 0;
	t.memfill(Tag, 0, NNODES);
	reset(0);
	Znode := NIL;
	Znode := cons(NIL, NIL);
	S_t := addsym("T", 0); Car[valbox(S_t)] := S_t;
	S_restarg := addsym("&REST", 0);
	S_closure := addsym("<CLOSURE>", 0);
	S_macro := addsym("MACRO", 0);
	S_fsetq := addsym("FSETQ", 0);
	S_function := addsym("FUNCTION", 0);
	S_if := addsym("IF", 0);
	S_ifnot := addsym("IFNOT", 0);
	S_lambda := addsym("LAMBDA", 0);
	S_progn := addsym("PROGN", 0);
	S_quote := addsym("QUOTE", 0);
	S_quasiquote := addsym("QUASIQUOTE", 0);
	S_unquote := addsym("UNQUOTE", 0);
	S_unquote_splice := addsym("UNQUOTE-SPLICE", 0);
	S_setq := addsym("SETQ", 0);
	S_last := addsym("*", 0);
	S_apply := addsym("APPLY", %1);
	S_macro_function := addsym("MACRO-FUNCTION", %1);
	S_cons := addsym("CONS", %1);
	S_car := addsym("CAR", %1);
	S_cdr := addsym("CDR", %1);
	S_atom := addsym("ATOM", %1);
	S_eq := addsym("EQ", %1);
	S_eofp := addsym("EOFP", %1);
	S_funcall := addsym("FUNCALL", %1);
	S_rplaca := addsym("RPLACA", %1);
	S_rplacd := addsym("RPLACD", %1);
	S_gensym := addsym("GENSYM", %1);
	S_read := addsym("READ", %1);
	S_princ := addsym("PRINC", %1);
	S_terpri := addsym("TERPRI", %1);
	S_error := addsym("ERROR", %1);
	S_load := addsym("LOAD", %1);
	S_gc := addsym("GC", %1);
	S_suspend := addsym("SUSPEND", %1);
	S_symbols := addsym("SYMBOLS", %1);
	reset(1);
end

! Shut down and exit.

fini(x) do
	message("");
	if (\Batch) con.shutdown();
	ie (x) halt 1; else halt 0;
end

! ********************************
! ***** READ-EVAL-PRINT LOOP *****
! ********************************

! When the interpreter starts, it reads a single
! parameter from the command line. When it is a
! single minus sign (-), it enters Batch mode and
! otherwise it attempts to load an image file with
! the given name. When no parameter is given, it
! tries to load an image file named "mclisp".

! The REPL itself is simple:
!
! - reset the interpreter state
! - prompt and read an expression X
! - in case of a read error, loop
! - when X is the EOT, exit
! - evaluate the expression
! - in case of an error, loop
! - print the value of the expression
! - store the value in the variable * (S_last)
! - loop

! In interactive (non-batch) mode, the interpreter
! will announce its current state (READ, EVAL, PRINT)
! in the status line.

do var a::14, c;
	c := t.getarg(1, a, 14);
	Batch := 0;
	if (c > 0 /\ strequ(a, "-")) Batch := %1;
	init();
	fasload(c>0 /\ \Batch-> a: "mclisp");
	pr("MICRO COMMON LISP "); pr(@Magic::2); nl();
	if (\Batch) do
		pr(ntoa(gc()));
		pr(" NODES"); nl();
	end
	while (%1) do
		reset(1);
		message("[READ]");
		pr("*\s");
		Acc := read();
		if (Errflag) loop;
		if (Acc = EOT) leave;
		message("[EVAL]");
		Acc := eval(Acc);
		if (Errflag) loop;
		message("[PRINT]");
		print(Acc);
		nl();
		Car[valbox(S_last)] := Acc;
	end
	if (Batch) nl();
	fini(0);
end