Lisp compiler source

Here is a pretty-printed listing of the first Lisp compiler's source code. Click on a reference to a function to be taken to its definition. Prog tags are also hyperlinked. The entry point is the compile function.

See below, after the listing, for notes on the formatting.

define ((
(length
(λ (m)
(prog  (n)
(setq n 0)
a (cond (
(null m)
(return n)))
(setq n (add1 n))
(setq m (cdr m))
(go a))))
(reverse
(λ (x)
(prog  (y)
a (cond (
(null x)
(return y)))
(setq y (cons (car x) y))
(setq x (cdr x))
(go a))))
(member
(λ (u v)
(cond
(
(null v)
nil)
(
(equal (car v) u)
t)
(
t
(member u (cdr v))))))
(comval
(λ (exp stomap name)
(prog  nil
(cond
(
(or
(atom exp)
(member (car exp) (quote (quote special))))
(lac exp))
(
(eq (car exp) (quote setq))
(prog  nil
(comval (caddr exp) stomap name)
(attach (list (cons (quote sto) (locate (cadr exp)))))))
(
(eq (car exp) (quote cond))
(comcond (cdr exp) t))
(
(eq (car exp) (quote prog))
(comprog (cddr exp) (cadr exp) name))
(
(eq (car exp) (quote or))
(combool f f (cdr exp) nil))
(
(eq (car exp) (quote and))
(combool t f (cdr exp) nil))
(
(atom (car exp))
(call (car exp) (comlis (cdr exp))))
(
t
(prog  nil
(comply (car exp) (cdr exp))
(comval (caddar exp) stomap name))))
(setq ac name)
(return name))))
(comply
(λ (fn args)
(map
(pair (cadr fn) args)
(function
(λ (j)
(prog  nil
(comval (cdar j) stomap (gensym))
(store (caar j) t)))))))
(comlis
(λ (exp)
(prog  (x)
(return (maplist exp (function
(λ (j)
(cond
(
(or
(eq (caar j) (quote quote))
(atom (car j)))
(car j))
(
x
(prog2
(store ac t)
(comval (car j) stomap (gensym))))
(
t
(prog2
(setq x t)
(comval (car j) stomap (gensym))))))))))))
(lac
(λ (x)
(cond
(
(equal ac x)
nil)
(
t
(attach (list (cons (quote cla) (locate x))))))))
(store
(λ (x y)
(prog  nil
(cond (
(or
(null x)
(eq (car x) (quote quote)))
(return nil)))
(setq stomap (cons
(cons x (list
(list
(add1 (caadar stomap))
(quote *n))
1))
stomap))
(cond (
y
(attach (list (cons (quote sto) (locate x))))))
(setq length (max length (caadar stomap))))))
(phase2x
(λ (j)
(and
(eq (caadr exp) (cadar j))
(eq (caar j) (quote null))
(equal (cadr j) (quote (quote nil))))))
(phase2y
(λ (j)
(list (cond
(
(lessp j 3)
0)
(
t
(difference (times j 2) 4))))))
(phase2
(λ (exp name)
(prog  (ac listing stomap length)
(cond (
(phase2x (cadar (cddr exp)))
(prog2
(attach (quote ((tze 1 4))))
(setq exp (list
(car exp)
(cadr exp)
(cons (quote cond) (cddar (cddr exp))))))))
(attach (list
(list
(quote tnx)
(list (quote e) name)
1
(quote *mn))
(append
(quote (tsx *move 1))
(phase2y (length (cadr exp))))))
(setq length 0)
(setq stomap (quote ((nil (0 *n) 1))))
(map (cadr exp) (function
(λ (j)
(store (car j) f))))
(setq ac nil)
(comval (caddr exp) stomap nil)
(cond (
(not (member (caaddr exp) (quote (cond prog))))
(attach (quote ((txi *return 1 *mn))))))
(setq exp (reverse listing))
(return (list exp (list
(cons (quote *mn) (plus length 2))
(cons (quote *n) (difference −2 length))))))))
(comprog
(λ (exp proglis retn)
(prog  (golist hold name sets s)
(setq hold exp)
a (cond
(
(null hold)
(go b))
(
(atom (car hold))
(setq golist (cons (cons (car hold) (gensym)) golist)))
(
(not sets)
(cond
(
(eq (caar hold) (quote specbind))
(setq s (cadadr hold)))
(
t
(setq sets t)))))
(setq hold (cdr hold))
(go a)
b (setq hold proglis)
c (cond (
(null hold)
(go g)))
(store (car hold) nil)
(cond (
(not (eq (car hold) s))
(attach (list (cons (quote stz) (locate (car hold)))))))
(setq hold (cdr hold))
(go c)
g (setq hold exp)
d (setq ac nil)
(setq name (gensym))
(cond
(
(null hold)
(go e))
(
(atom (car hold))
(attach (list (cdr (sassoc (car hold) golist nil)))))
(
(eq (caar hold) (quote go))
(attach (list (list
(quote tra)
(cdr (sassoc
(cadar hold)
golist
(function
(λ nil
(error (quote go))))))))))
(
(eq (caar hold) (quote cond))
(comcond (cdar hold) f))
(
t
(comval (car hold) stomap name)))
(setq hold (cdr hold))
(go d)
e (cond (
retn
(attach (list retn)))))))
(compact
(λ (exp name)
(cond
(
(eq (car exp) (quote null))
(prog2
(setq switch (not switch))
(compact (cadr exp) name)))
(
(equal exp (quote (quote *t*)))
(cond
(
switch
(attach (list (list (quote tra) name))))
(
t
(setq flag f))))
(
(eq (car exp) (quote or))
(combool f t (cdr exp) switch))
(
(eq (car exp) (quote and))
(combool t t (cdr exp) switch))
(
t
(prog2
(cond
(
(eq (car exp) (quote eq))
(ceq exp stomap))
(
t
(comval exp stomap (gensym))))
(attach (list (list
(cond
(
switch
(quote tnz))
(
t
(quote tze)))
name))))))))
(combool
(λ (fn mode exp a)
(prog  (gen switch)
(setq gen (gensym))
a (setq switch nil)
(cond
(
(null exp)
(go c))
(
(and
mode
(null (cdr exp))
(eq a fn))
(go b)))
(compact
(cond
(
fn
(car exp))
(
t
(list (quote null) (car exp))))
(cond
(
(and mode (not a))
(cond
(
fn
name)
(
t
gen)))
(
t
(cond
(
(not mode)
gen)
(
fn
gen)
(
t
name)))))
(setq ac (cond
(
(eq (caar listing) (quote tnz))
(quote (quote nil)))
(
t
(quote (quote *t*)))))
(setq exp (cdr exp))
(go a)
b (compact
(cond
(
fn
(list (quote null) (car exp)))
(
t
(car exp)))
name)
c (cond (
(not mode)
(attach (list
(quote (tra (* 2)))
(list
(quote cla)
(list (quote quote) fn))))))
(attach (list gen))
(cond (
(not mode)
(attach (list (list
(quote cla)
(list
(quote quote)
(not fn))))))))))
(comcond
(λ (exp mode)
(prog  (flag switch gen)
(setq flag t)
a (cond (
(null exp)
(go b)))
(setq gen (gensym))
(setq switch nil)
(cond (
(and
(not mode)
(eq (caadar exp) (quote go)))
(go c)))
(compact (caar exp) gen)
(setq ac (cond
(
switch
(quote (quote nil)))
(
t
nil)))
(comval (cadar exp) stomap name)
(cond (
(or
(and name (null (cdr exp)))
(member (caadar exp) (quote (return go))))
(go l)))
(attach (list (cond
(
name
(list (quote tra) name))
(
t
(quote (txi *return 1 *mn))))))
l (attach (list gen))
d (setq exp (cdr exp))
(setq ac (cond
(
switch
(quote nil))
(
t
(quote (quote nil)))))
(go a)
b (cond (
name
(attach (list name))))
(return nil)
c (compact
(list (quote null) (caar exp))
(cdr (sassoc
(cadr (cadar exp))
golist
(function
(λ (v)
(error (quote go)))))))
(go d))))
(ceq
(λ (exp stomap)
(prog  (a)
(setq a (comlis (cdr exp)))
(cond
(
(equal (car a) ac)
(attach (list (cons
(quote sub)
(locate (cadr a))))))
(
t
(prog2
(lac (cadr a))
(attach (list (cons
(quote sub)
(locate (car a))))))))
(setq switch (not switch)))))
(call
(λ (fn args)
(prog  (hold item num)
(cond
(
(member fn (quote (specbind specrstr list return go)))
(go e))
(
(null args)
(go d))
(
(null (cdr args))
(go c)))
(setq hold (reverse (cddr args)))
(setq num (length args))
(cond (
(greaterp num 20)
(error (quote args))))
a (cond (
(null hold)
(go b)))
(setq item (car hold))
(cond
(
(equal item (quote (quote nil)))
(attach (list (list
(quote stz)
(list (quote $alist) num)))))
(
(equal item ac)
(attach (list (list
(quote sto)
(list (quote $alist) num)))))
(
t
(attach (list
(list
(quote stq)
(list (quote $alist) num))
(cons (quote ldq) (locate item))))))
(setq hold (cdr hold))
(setq num (sub1 num))
(go a)
b (cond
(
(equal ac (cadr args))
(cond
(
(equal ac (car args))
(attach (quote (
(ldq ($alist 2))
(sto ($alist 2))))))
(
t
(attach (quote ((xca)))))))
(
t
(attach (list (cons
(quote ldq)
(locate (cadr args)))))))
c (lac (car args))
d (attach (list (list
(quote str)
(list (quote e) fn)
7
(length args))))
(return nil)
e (cond
(
(eq fn (quote go))
(error (quote go)))
(
(eq fn (quote return))
(prog  nil
(lac (car args))
(attach (list (cond
(
retn
(list (quote tra) retn))
(
t
(quote (txi *return 1 *mn))))))))
(
(eq fn (quote list))
(prog  (x)
(cond (
(null args)
(return (attach (quote ((cla (quote nil))))))))
(cond (
ac
(locate ac)))
(attach (quote ((tsx *list 4))))
(attach (list (cons
(times (length args) 1q6)
(locate (car args)))))
(setq x (cdr args))
a (cond (
(null x)
(return nil)))
(attach (list (cons 0 (locate (car x)))))
(setq x (cdr x))
(go a)))
(
(member fn (quote (specbind specrstr)))
(prog  nil
(attach (list (list
(quote tsx)
fn
4)))
(maplist
(cadar args)
(function
(λ (j)
(attach (list (list
(cond
(
(cdr j)
0)
(
t
(quote str)))
(car (locate (car j)))
1
(list
(quote special)
(car j))))))))))))))
(attach
(λ (a)
(cond
(
(and
(equal (car a) (quote (txi *return 1 *mn)))
(member (caar listing) (quote (txi tra))))
nil)
(
t
(setq listing (append a listing))))))
(locate
(λ (x)
(cond
(
(or
(eq (car x) (quote quote))
(eq (car x) (quote special))
(eq x (quote $alist)))
(list x))
(
t
(cdr (sassoc
x
stomap
(function
(λ nil
(cond
(
(eq x ac)
(prog  nil
(store ac t)
(return (sassoc
x
stomap
(function nil)))))
(
t
(error (list x (quote undeclared)))))))))))))
(deletel
(λ (l m)
(mapcon m (function
(λ (j)
(cond
(
(member (car j) l)
nil)
(
t
(list (car j)))))))))
(passone
(λ (name fn)
(palam (progiter name fn) nil)))
(pa1
(λ (l)
(maplist l (function
(λ (j)
(paform (car j) b))))))
(pa4
(λ (coms specs g)
(cond
(
(and
(null coms)
(null specs))
(list
(quote λ)
(cadr fn)
(paform
(caddr fn)
(append (cadr fn) b))))
(
t
(list
(quote λ)
(cadr fn)
(conc
(list (quote prog) (list g))
(pa11 coms (quote combind))
(pa9 specs (quote specbind))
(list (list
(quote setq)
g
(paform (caddr fn) (append (cadr fn) b))))
(pa9 specs (quote specrstr))
(pa14 coms)
(pa12 g)))))))
(pa3
(λ (l)
(cond
(
(null (cdr l))
(list (list
(quote (quote *t*))
(paform (car l) b))))
(
t
(cons
(list
(list
(quote eq)
g
(paform (caar l) b))
(paform (cadar l) b))
(pa3 (cdr l)))))))
(pa5
(λ (vars prop)
(cond
(
(null vars)
nil)
(
(get (car vars) prop)
(cons
(car vars)
(pa5 (cdr vars) prop)))
(
t
(pa5 (cdr vars) prop)))))
(pa6
(λ (kind var)
(list (list kind
(list (quote quote) var)
(cons (quote list) var)))))
(pa7
(λ (l b)
(cond
(
(null l)
(quote ((return (quote nil)))))
(
(and
(null (cdr l))
(eq (caar l) (quote go)))
l)
(
(atom (car l))
(cons
(car l)
(pa7 (cdr l) b)))
(
t
(cons
(paform (car l) b)
(pa7 (cdr l) b))))))
(pa11
(λ (vars func)
(cond
(
vars
(pa6 func vars))
(
t
nil))))
(pa14
(λ (coms)
(cond
(
coms
(list (list
(quote comrstr)
(list (quote quote) (length coms)))))
(
t
nil))))
(pa12
(λ (g)
(list (list (quote return) g))))
(compile
(λ (l)
(maplist l (function
(λ (j)
(com1
(car j)
(get (car j) (quote expr))
(get (car j) (quote fexpr))))))))
(com1
(λ (n a b)
(prog2
(cond
(
a
(com2 (quote subr) (length (cadr a)) a n))
(
b
(com2 (quote fsubr) (length (cadr b)) b n))
(
t
(print (list n (quote undefined)))))
n)))
(com2
(λ (type length exp name)
(prog  (listing)
(setq listing (phase2 (passone name exp) name))
(terpri)
(terpri)
(terpri)
(print (list name type length))
(map
(car listing)
(function
(λ (j)
(print (car j)))))
(terpri)
(lap
(cons
(list name type length)
(car listing))
(cadr listing))
(remprop name (quote expr))
(remprop name (quote fexpr))
(return name))))
(common
(λ (l)
(flag l (quote common))))
(uncommon
(λ (l)
(remflag l (quote common))))
(special
(λ (x)
(maplist x (function
(λ (j)
(deflist
(list (list (car j) (list nil)))
(quote special)))))))
(unspecial
(λ (l)
(map l (function
(λ (j)
(remprop (car j) (quote special)))))))
(progiter1
(λ (g1 g2 vs gs)
(list
(quote λ)
vs
(cons
(quote prog)
(cons gs (cons g1 (pi3
(cdaddr exp)
nil
(cons g2 (pairmap
vs
gs
(function pi2)
(list (list (quote go) g1)))))))))))
(progiter
(λ (name exp)
(cond
(
(and
(eq (caaddr exp) (quote cond))
(pi1 (cdaddr exp)))
(progiter1
(gensym)
(gensym)
(cadr exp)
(maplist (cadr exp) (function gensym))))
(
t
exp))))
(pi1
(λ (l)
(cond
(
(null l)
f)
(
(eq (caadar l) name)
t)
(
t
(pi1 (cdr l))))))
(pi2
(λ (j k)
(list (quote setq) j k)))
(pi31
(λ (g3)
(pi3
(cdr l)
(nconc c (list (list (caar l) (list (quote go) g3))))
(cons g3 (pairmap
gs
(cdadar l)
(function pi2)
(cons (list (quote go) g2) s))))))
(pi3
(λ (l c s)
(cond
(
(null l)
(cons (cons (quote cond) c) s))
(
(eq (caadar l) name)
(pi31 (gensym)))
(
t
(pi3
(cdr l)
(nconc c (list (list
(caar l)
(list
(quote return)
(cadar l)))))
s)))))
(palam
(λ (fn b)
(cond
(
(atom fn)
fn)
(
(eq (car fn) (quote λ))
(pa4
(pa5 (cadr fn) (quote common))
(pa5 (cadr fn) (quote special))
(gensym)))
(
(eq (car fn) (quote label))
(comp (cadr fn) (caddr fn)))
(
t
(error (cons fn (quote (not function))))))))
(paform
(λ (form b)
(cond
(
(atom form)
(cond
(
(or
(numberp form)
(member form (quote (nil *t*))))
(list (quote quote) form))
(
(eq form (quote t))
(quote (quote *t*)))
(
(eq form (quote f))
(quote (quote nil)))
(
(get form (quote common))
(list
(quote eval)
(list (quote quote) form)
(quote $alist)))
(
(get form (quote special))
(list (quote special) form))
(
(member form b)
form)
(
t
(prog  nil
(print (cons form (quote (undeclared))))
(return (list
(quote eval)
(list (quote quote) form)
(quote $alist)))))))
(
(atom (car form))
(cond
(
(or
(get (car form) (quote fsubr))
(get (car form) (quote fexpr)))
(cond
(
(member (car form) (quote (and or)))
(cons (car form) (pa1 (cdr form))))
(
(member (car form) (quote (max min plus times logor logand logxor)))
(list
(car form)
(cons (quote list) (pa1 (cdr form)))
(quote $alist)))
(
t
(select (car form)
(
(quote cond)
(cons
(quote cond)
(maplist
(cdr form)
(function
(λ (j)
(list
(paform (caar j) b)
(paform (cadar j) b)))))))
(
(quote list)
(cons (quote list) (pa1 (cdr form))))
(
(quote quote)
form)
(
(quote prog)
(pa8
(pa5 (cadr form) (quote common))
(pa5 (cadr form) (quote special))
(gensym)))
(
(quote function)
(list
(quote func)
(list (quote quote) (comp (gensym) (cadr form)))
(quote $alist)))
(
(quote setq)
(cond
(
(get (cadr form) (quote common))
(list
(quote setc)
(list (quote quote) (cadr form))
(paform (caddr form) b)))
(
t
(list
(quote setq)
(paform (cadr form) b)
(paform (caddr form) b)))))
(
(quote go)
form)
(
(quote csetq)
(list
(quote cset)
(list (quote quote) (cadr form))
(paform (caddr form) b)))
(
(quote select)
(
(λ (g)
(list
(list
(quote λ)
(list g)
(cons
(quote cond)
(pa3 (cddr form))))
(paform (cadr form) b)))
(gensym)))
(
(quote conc)
(pa2 (cdr form)))
(list
(car form)
(list (quote quote) (cdr form))
(quote $alist))))))
(
(eq (car form) (quote not))
(list
(quote null)
(paform (cadr form) b)))
(
(eq (car form) (quote set))
(list
(quote setc)
(paform (cadr form) b)
(paform (caddr form) b)))
(
t
(cons (car form) (pa1 (cdr form))))))
(
(or
(eq (caar form) (quote λ))
(eq (caar form) (quote label)))
(cons
(palam (car form) b)
(pa1 (cdr form))))
(
t
(list
(quote apply)
(paform (car form) b)
(cons (quote list (pa1 (cdr form)))
(quote $alist))))))
(pairmap
(λ (l m farg z)
(prog  (a b)
(cond (
(null l)
(return z)))
(setq a (setq b (cons
(farg (car l) (car m))
z)))
a (setq l (cdr l))
(setq m (cdr m))
(cond (
(null l)
(return a)))
(setq b (cdr (rplacd b (cons
(farg (car l) (car m))
z))))
(go a))))
(pa8
(λ (coms specs g)
(cond
(
(and (null coms) (null specs))
(cons
(quote prog)
(cons
(cadr form)
(pa7 (cddr form) (append (cadr form) b)))))
(
t
(conc
(list
(quote prog)
(cons g (append coms specs)))
(pa11 coms (quote combind))
(pa9 specs (quote specbind))
(list (list
(quote setq)
g
(cons
(quote prog)
(cons
(deletel (append coms specs) (cadr form))
(pa7 (cddr form) (append (cadr form) b))))))
(pa9 specs (quote specrstr))
(pa14 coms)
(pa12 g))))))
(comp
(λ (n e)
(cond
(
(atom e)
e)
(
t
(com2
(quote subr)
(length (cadr e))
e
n)))))
(pa9
(λ (v k)
(cond
(
v
(list (list k (list (quote quote) v))))
(
t
nil))))
(pa2
(λ (l)
(cond
(
(null l)
(quote (quote nil)))
(
t
(list
(quote append)
(paform (car l) b)
(pa2 (cdr l)))))))
))

Formatting notes

The style of formatting used above is inspired by Algol listings from the 1960s and 1970s. Probably the most notable feature is that the pre­dominant typeface is proportional, rather than monospace. Semantic differences between lexical units is indicated by changes in font, not in color, following the conventions of mathematical publishing. A stun­ning demonstration of the style can be found in Donald Knuth's TeX: The Program, where the language is (an augmented variant of) Pascal. Knuth and Levy's CWEB applies it to C.

Lisp code presents some challenges, when compared to Pascal and C. The main issue is that Lisp often contains deeply nested structure. In Algol-like languages, indentation is generally in fixed increments relative to the left margin (Algol 68 being an exception); in Lisp, the left margin can vary. Thus alignment of text is critical to making Lisp code readable. If a monospace typeface were used, then this would be trivial—but of course we are using proportional text.

The solution adopted here is due to a suggestion by David Carlisle; see my (now closed) question on the User Experience StackExchange site for additional information. Essentially, nested <table>s mimic s‑expressions. There are over a thousand table elements on this page.