            lisp 29 may 1970
/assemble with SS3 up to include pprint
repeat ifup 3,[printx .with pprint
.]

/F1 - push down buffers
/F2 - apply
/F3 - read (minus seen)
/F4 - 0 if printing error
/F5 - read (xx.xx seen)
/F6 - read (letter seen)

size.=100	/size of pdl buffers
atoms.=220	/min. non-initial syms
syms.=400	/words for printnames
dfd.=15

repeat 1-if2,[equals retn return
equals u character	equals r repeat]

function even x
retn [x-1]>>05<<37+1
termin

define error who,where
q.=flexo who
jsp err'where
[q^77xi]>>05<<[q^7700]>>05<<[q^770000x100]
terminate

cn=(1nil
cfrs=(frs
c1frs=(100000-frs
c1=(1
cp12=(lac pd1+pd2-1

bind=jdp bn
push=jda pwl
pop=jdp po
zorch=jdp zo


























                
>>75<<                                
0/	jmp 102

100/	0
	ior (400000	/makes into a jmp (because of extend mode)
102,	jmp pd1	/becomes jmp be0, then push
	sub c1
	dap .+1
	lac .
	dap pwl
pwl-1,	lac 100
pwl,	0	/push
	dap psx
	idx pdl
	sad top
	jmp p1
pw2,	lac pwl
	dac i pdl
psx,	jmp .

tru,	lac (1t
	jmp x

po,	0	/pop
pdl,	lac .
	dac pwl
	law i 1
	adm pdl
	sad bot
	jmp ps2
po2,	lac pwl
	jmp i po

caddr,	cal cdr	/"caddr"
cadr,	SAA		/"cadr"
caar,	cal car		/"caar"
	jmp car

cddr,	SAA		/"cddr"
cdar,	cal car		/"cdar"
cdr,	idx 100		/"cdr"
car,	lac i 100		/"car"
	sza
	jmp x
	error cva,+1
fal,	lac cn
	jmp x



















                
0                                
/jmp here on fatal error
stops,	xct sect+3
	jmp .stop

loop,	law 10
	dap ers
	xct sect+1
	cal read
	xct sect
	lac 100
	cal eval
	xct sect+2
	lac 100
	cal print
	jmp loop

cons-1,	lio cn
cons,	lxr fre	/"cons"
	TXXP|
	cal gc
	iam
	dac i 0
	lac i 1
	dio i 1
	dac fre
	TXAIX
	dac t1	/for zorch
x-1,	nam
quote,list,
x,	dac 100
	pop
	ral 1s
	spa
	jmp pwl-1
	lio pwl
	pop
	dio i pwl
	jmp x+1

imr,	nam
	error imr
	jmp stops























                
>>16<<                                
/entries to "read" section
read,	jsp rdb
gensym,	jsp rdb
readc,	law rdb

rdb,	dap rbx
	lac sect+1
rdb+2,	dac .+3
	lac sect+4	/to get back to this section
cpush,	push
	0	/get section wanted
	jmp sect+5

/entries to "print" section
print,	jsp pdb
prin1,	jsp pdb
r ifup 3,pprint,	jsp pdb
terpri,	jsp pdb
prindef,	jsp pdb
1err,	jsp pdb
out,	jsp pdb
character=.	law pdb

pdb,	dap rbx
	lac sect+2
	jmp rdb+2

/entries to "trace" section
trace,	jsp tdb
untrace,	jsp tdb
dex,	jsp tdb
gc,	jsp tdb
stop=.	law tdb

tdb,	dap rbx
	lac sect+3
	jmp rdb+2

biw,	0	/bring in drum section
biw+1,	dap .+3
	law sect
	mta
	lac .
	ivk dfd
	hlt
	lio ios
	jmp i biw

xr,	dac 100	/return from drum section
	pop
	dap .+1
	xct .
	jmp x+1












                

                                
pa3,	0	/prog return value
pa4,	0	/prog current location
a1,	0	/arguments to subr's
a2,	0
a3,	0
t1,	0
t2,	0
rad,	10.	/radix
gst,	0	/gensym counter
top,	lac .	/top of current buffer
bot,	lac .
dp,	0	/next pushdown buffer
ios,	0	/saved io during drum swaps
rbx,	jmp .	/entry to drum sections
cas,	72	/typewriter case
chrct,	0	/print position
ers,	szs 10	/error recovery switch
hih,	i	/end of core
snd,	lac esy	/end of active symbol table
hnd,	enh	/end of active heads
low,	frs	/beg. of free storage
rdx,	jmp rd1	/last break character
rpc,	0	/stuff for input file
rip,	rbf
rdp,	0
ins,	0	/input source (isp rpc or jmp tin)
ous,	0	/output destination
odp,	0	/stuff for output file
oup,	0
ocp,	0
fre,	0	/free storage pointer


































                
r                                
p1,	szf 1 i	/push overflow
	jmp p1a	/in upper buffer
	clf 1	/in lower buffer
p1b,	law pd2~pd3	/switch buffers
	xor top
	dac top
	law [pd1-1]~[pd2-1]
	xor bot
	dac bot
	SAA
	dac pdl	/reset to bottom
	jmp pw2

p1a,	dio ios	/write out lower buffer
	lac cp12
	sub bot
	mta
	lio dp
	law size+20
	ivk dfd
	hlt
	law size
	adm dp
	lio ios
	sas (i
	jmp p1b
pce,	lac bot
	dap pdl
	error pce
	jmp stops

ps2,	szf 1	/pop overflow
	jmp p2a	/in lower buffer
	stf 1	/in upper buffer
p2b,	law [pd1-1]~[pd2-1]	/switch buffers
	xor bot
	dac bot
	law pd2~pd3
	xor top
	dac top
	sub c1
	dac pdl	/reset to top
	jmp po2

p2a,	dio ios	/read in lower buffer
	law i size
	adm dp
	lia
	lac cp12
	sub bot
	mta
	law size
	ivk dfd
	hlt
	lio ios
	jmp p2b









                
v                                
crn,	TAAI>P	/create number
	cma
	sub (20000
	A.IAM
	TI<
	jmp cr2
	add (260000	/short format number
	ral 1s
	jmp x

cr2,	cal cons-1	/long format number
x4,	xor (400000
	jmp x

vag,	sma	/get value of number
	jmp nna
	sub cfrs
	sma
	jmp nna
	sub c1frs
	sma
	jmp car	/long format
	rar 1s	/short
	sub (220000
	jmp x

zo,t3,	0	/zorch
	idx i pdl
	dac t2
	idx t1
	lac i t2
	dac i t1
	dio i t2
	dio i pdl
	idx pwl
	lac i pwl
	jmp i zo

err-2,	lio a1	/error, print a1
	jmp err+2
err,	ZIP
err+1,	lio 100	/error, print 100
	dap erx
	lac i erx
	cal 1err
erx,	jmp .

constants

















                

                                
pd1,	law dfd	/first pushdown buffer and setup routine
	mta 204
	mta 300
	bpt
	law be0
	dap 102
	law 100
	mta
	lia
	law 7720
	ivk dfd	/save program
	hlt
	cli
	law 60	/in case started at 0
	ivk dfd
	hlt
be0,	eem
	iam
	lac cpush	/repair cal handler
	dac 102
	law 2
	mta 400
	sza i
	jmp be1
	law sect	/read e.t.'s current page pointer
	mta
	lio (340
	law 40
	ivk 2
	hlt
	law i 1
	add sect+373-340
	TAI
	rcr 5s
	ril 5s
	ral 5s
	dio rdp
	adm rip
be1,	tyi	/read memory bound
	law 7
	A^IA
	A~IP
	law 1	/assume 4k
	rar 6s
	dac hih
	mta 207	/set memory bound
	bpt
	law imr
	mta 203	/set illegal memory return
	lio ([oev ene-sect]^777740
	law end-oev-ene sect [oev ene-sect]^777740
	mta
	law even[oiv]-[oev ene-sect]^777740
	ivk dfd	/read in atom heads 
	hlt
	lio (oiv^777740
	law frs-oiv oiv^777740
	mta
	law even[oiv tsy-frs]-oiv^777740






                
>>76<<                                	ivk dfd	/read in initial values
	hlt
	lio cn	/set up non-initial heads
 	lxr (enh
	dzm i 0
	dio i 1
	SXX
	SXXA
	sas cfrs
	jmp .-5
	lio (be9 sr spr
	law sym
	mta
	law otv-be9-sr-spr
	ivk dfd
	hlt
	lio (otv
	law sect
	mta
	law st
	ivk dfd	/get "trace" section
	hlt
	lxr (tsy
	cli	/chain up free storage
be7,	dio i 1
	TXXI
	law 2
	A+XAX
	sas hih
	jmp be7
	sub (2
	dac fre
	nam
	jmp stops
constants
eni,
be9=even[.]

pd1+size/
pd2,	pd2+size/	/second buffer
pd3_,

























                
>>32<<                                
/"read" section
offset be9-sect
sect,	jsp ger	/instruction to get eval
	nop	/or read
	jsp gpr	/or print
	jsp gtr	/or trace
	jmp sect+1	/get this section

	law .+3-read
	adm rbx
	lac 100
	jmp rbx
	jmp .read
	jmp .gensym
	jmp .readc

chs,	-2	/goes to 0 if printnames change
chb,	1	/goes to 0 if input buffer read
chr,	0	/rewrite printnames if changed
	dac biw
	dio ios
	isp chs
	jmp i chr
.r1.=be9 sr spr [esy-sym]^777740
.r2.=sin-[esy-sym]^777740
.r3.=sym [esy-sym]^777740
r if2,r ifm .r2,.r1.=be9 sr spr	.r2.=40	.r3.=sym
	law .r3
	mta
	lio (.r1
	law .r2+20
	ivk dfd	/write out symbols
	hlt
	jmp i chr

ger,	jdp chr	/get eval from read
	lio (oev
	jsp biw 1
	se

gpr,	jdp chr	/get print section
	lio (be9+sr
	jsp biw 1
	sp

gtr,	jdp chr	/get trace section
	lio (otv
	jsp biw 1
	st
















                
                                
in,	xct ins
	jmp rn2
	law i 3
	dac rpc
	idx rip
	sas (rbf+40
	jmp rn2
	law rbf
	dac rip
	law 40
rn1,	adm rdp
	dzm chb
	TAI
	rcl 6s
	dap .+5
	rir 6s
	law rbf
	mta
	law 40
	ivk .
	hlt
rn2,	cla
	sas chb
	jmp rn1
	lio i rip
	lac rpc
	rir 6s
	SAAP
	jmp .-2
	rcl 6s
	sad (77
	dzm rpc
	jmp gtc

tin,	tyi
	lai
gtc,	sas (74	/upper case
	sad (72	/lower case
	dac cas
	jmp x

.readc,	cal in
	sad cas
	jmp .readc
	lio cas
	rir 2s
	spi i
	add (100
	cal crn
	jmp xr 1

rbf,	.+40/	/input buffer













                
m                                
.read,	cla>>05<<stf 5		/"read"
	push
	jmp rdx

bsp,	lac i snd	/backspace
	sas (767676
	jmp rd1
re2,	lac i pdl
	sza i
	jmp .+3
	pop
	jmp re2
	cal terpri
	stf 5
rd1,	clf 6	/on if letter seen
	clf 3	/on if minus sign seen
	dzm a1	/value of number
	lac snd
	dac pt1
rd2,	sad (lac end
	jmp nce
	lac (767676
	dac i pt1
rlp,	cal in
	lio cas
	rir 2s
	law tb1	/lower case origin
	spi i
	law tb2	/upper case origin
	dap tbs
tb0,	law 77
	and i tbs
	sad 100
	jmp tbs
	idx tbs
	sas (lac tb3
	jmp tb0
	lac 100
	sub rad
	sma
	jmp rsl
num,	lac a1
	mul rad
	rcr 1s
	lac 100
	sas (20
	A+II
	dio a1
	jmp pt1

min,	stf 3	/-
	jmp pt1













                
>>52<<                                
vb,	cal in	/.
rsl,	stf 6	/letter seen
pt1,	lac .
	lio 100
	rcr 6s
	dac i pt1
	and (77
	sad (76
	jmp rlp
	idx pt1
	jmp rd2

tbs,	lac .
	lia
	rar 6s
	dap rdx
	spi i
	jmp rdx
	law i 4000
	adm rdx
	lac i snd
	sad (767676
	jmp rdx	/no atom
	szf 5 i
	jmp iif
	sas (547676
	szf 6
	jmp int	/atomic symbol
	lac a1	/number
	szf 3
	cma
	cal crn
	jmp rxy+2

int,	law sym	/oblist lookup
	dap pt2
	dzm chr	/symbol count
	idx pt1
int2,	lac snd
	dap sy1
pt2,	lac .
sy1,	sad .
	jmp id2
	and (77	/go to next name
	sad (76
	jmp id1
	idx pt2
	xct pt2
	jmp .-5

id1,	idx chr
	idx pt2
	sas snd
	jmp int2
	law frs
	sad hnd
	jmp ace
	lac pt1
	dac snd






                
>>32<<                                	law 2
	adm hnd
	dzm chs
fou,	lac chr
	sal 1s
	add (add end
	jmp rxy+1

id2,	idx sy1
	xor (sad~lac
	sad pt1
	jmp fou
	idx pt2
	jmp pt2

ace,	error ace
	jmp stops
nce,	error nce
	jmp stops
iif,	error iif
	jmp stops













































                
                                
LPR=	SZF I >>05<<	?[
	JMP IIF
	LAC CN
	PUSH
	JMP RD"
PER=	LAC I PDL	?x
	SAD CN
	JMP IIF
	RAR "S
	SPQ >>05<<
	JMP IIF
	IDX I PDL
	JMP RD"
RPR=	LAW RD"	?]
	DAP RDX
	LAC I PDL
	RAR "S
	SPQ
	JMP IIF
	POP
	SZF >>05<<
	SAD CN
	JMP RXY
	IDX PWL
	LIO CN
	LAC I PWL
	DIO I PWL
RXY=	STF >>05<<
	DAC "..
	POP
	SZA I
	JMP XR+1
	push
	rar 1s
	spa
	jmp rd5
	lac 100
	cal cons-1
	lac i pdl
	sad cn
	jmp rdn
	zorch
	jmp rdx
rdn,	idx t1
	dio i t1
	jmp rd7
rd5,	lio i pwl
	lac 100
	dac i pwl
	clf 5
rd7,	dio i pdl
	jmp rdx













                
>>53<<                                
tb1,	20+100xnum	/dispatch table
	54+100xmin
	55+100xrpr+add
	57+100xlpr+add
	73+100xper+add
	00+100xrd1+add
	36+100xrd1+add
	77+100xrd1+add
tb2,	56+100xvb
	75+100xbsp
	13+100xrlp
tb3,





















































                
c                                
.gensym,	cla		/"gensym"
	push	/this fools int
	lac snd
	dap gen1
	SAA
	dap pt1
	sub (lac end-1
	sma
	jmp nce
	idx gst
	lio (767676
	cal gen2
	rir 6s
	dio i pt1
	cal gen2
	cal gen2
	lac (u lg
	rcl 6s
gen1,	dio .
	jmp int

gen2,	dio t1
	mul c1
	div (10.
gn1,	0
	dac gn1
	lac t1
	A.IAP|
	law 20
	rar 6s
	rcl 6s
	lac gn1
	jmp x

constants
enr,
sr=even[.-sect]




























                
6                                
/"print" section
offset be9+sr-sect
sect/	jsp gep	/instruction to get eval
	jsp grp	/or read
	nop	/or print
	jsp gtp
	jmp sect+2

	law .+3-print
	adm rbx
	lac 100
	jmp rbx
	jmp .print
	jmp .prin1
r ifup 3,jmp .pprint
	jmp .terpri
	jmp .prindef
	jmp .err
	jmp .out
	jmp .character

chw,	1	/goes to 0 if obf contains data
rwb,	0	/write out obf if needed
	dac biw
	dio ios
	lac chw
	sza
	jmp i rwb
	law obf
	mta
	lio odp
	cla
	rcl 6s
	rir 6s
	dap .+2
	law 60
	ivk .
	hlt
	jmp i rwb

grp,	jdp rwb	/get read from print
	lio (be9
	jsp biw 1
	sr

gep,	jdp rwb	/get eval from print
	lio (oev
	jsp biw 1
	se

gtp,	jdp rwb
	lio (otv
	jsp biw 1
	st











                
.                                
.err,	clf 4
	dio t2
	dac pr0
	idx erx
	law 3577
	cal p2
	lac pr0
	cal p3
	lac t2
	sza
	cal print
	law 34
	cal out
	cla>>05<<stf 4
	dap ers
	jmp xr

















































                
>>76<<                                
.chara,	TAX
	push
	jmp ch3

ch1,	cal cdr
	push
	dio a2
	lio i a2
ch3,	TIAI<M
	jmp ch1
	sad cn
	jmp ch2
	cal vag
	dac a2
	rar 5s
	xor cas
	rcr 2s
	law 6
	xor cas
	spi i
	cal out
	lac a2
	cal out
ch2,	 pop
	X.AIP
	jmp ch3
	jmp xr

p4,	cal out
	lac chrct	/check end of line
	spa
	cal terpri
	jmp x

p3,	cal out
p2,	cal out
	cal out
	jmp x

.out,	and (77
	dap oul
	sad (76
	jmp oux
	szf i 4
	jmp toy
ou1,	xct ous
	sad chw
	jmp ou0
	law obf	/read last buffer
	mta
	lio odp
	cla
	rcl 6s
	rir 6s
	dap .+2
	law 40
	ivk .
	hlt
	dzm chw






                
p                                ou0,	lac 100
	lio i oup
	rar 6s
	rcl 6s
	dio i oup
	isp ocp
	jmp ou3
	law i 3
	dac ocp
	idx oup
	sas (obf+40
	jmp oul
	jdp rwb	/write out buffer
	law obf
	dac oup
	law 40
	adm odp
	and (770000
	sas odp
	jmp oul
	TAI
	rcl 6s
	mta 300
	bpt	/can't assign field
	jmp oul

ou3,	xct oul
	sas (77
	sad (13
	jmp ou0	/continue these to end of word
oul,	law .
	sas (74
	sad (72
	jmp oux-1
	law i 1
	adm chrct
	jmp oux
	dac cas
oux,	lac 100
	rar 6s
	jmp xr

toy,	lia
	tyo
	jmp oul

obf,	obf+40/



















                
n                                
r ifup 3,[
flatsz,	law (jmp flat2
	dap ou1
	dzm flat1
	lac 100
	cal prin1
	law ous
	dap ou1
	lac flat1
	jmp x

flat2,	idx flat1
	jmp oux
flat1,	0

.pprint,	dac l		/"pprint"
	cal terpri
	law 76
	dac n
	dzm m
	cal sprint
	jmp fax

sprint,	lac n
	sub chrct
	TAX<
	jmp .+4
	cal out
	SXXP
	jmp .-2
	lac l
	spa
	jmp s13
	cal flatsz
	add m
	sub chrct
	spq
	jmp spr1
	law u (
	cal out
	lac chrct
	dac f
	lac i l
	sas (1prog
	dzm f
	sma	/?
	jmp sp3
	lac l
	dac lp
	cal cdr
	spa
	jmp sp3
	lac chrct
	dac np
	lac m
	dac mp
	cal panmax
	sad cn
	jmp sp3






                
j                                	dac n
/might want to jmp sp3 from here in some cases
	lac l	/compute (last l)
	lia
	cal cdr
	sas cn
	jmp .-3
	dio lp
	lai
	cal flatsz
	dac np
	lac l
	cal flatsz
	cma
	add chrct
	adm np
	lac m
	dac mp
	cal panmax
	sad cn
	ZAP
	sub n
	dac g	/sign bit
sr2,	lac i l
	cal prin1
	cla
	cal out
	lac l
	cal cdr
	dac l
	cal cdr
	sad cn
	jmp sp3
	lac g
	spa
	jmp sr2
sp3,	lac chrct
	dac n
	lac i l
	sad (1lambda
	jmp sp4
	sas (1nlambda
	sad (1nlamda
	jmp sp4
	sad (1prog
	jmp sp4
	sad (1setq
	jmp sp4
	sad (1label
	jmp sp4
	ZAP
sp4,	law i 2
	dac h
sp5,	lac m
	push
	lac f
	push
	lac h
	push
	lac n






                
y                                	push
	lac i l
	sma
	jmp sp6
	lac f
	sza i
	jmp sp6
	dac n
sp7,	push	/g
	lac l
	cal cdr
	push
	sad cn
	jmp spr2
	sma
	jmp spr3
	cal flatsz
	add (4
sp8,	adm m
	lac i l
	dac l
	cal sprint
	pop
	dac l
	pop
	dac g
	pop
	dac n
	pop
	dac h
	pop
	dac f
	pop
	dac m
	lac l
	sma
	jmp sp10
	sad cn
	jmp sp9
	law flexo  . 
	cal p3
	lac l
	cal prin1
sp9,	law u )
	cal out
	jmp x

spr1,	lac l
s13,	cal prin1
	jmp x

sp6,	cla
	jmp sp7

spr2,	law 1
	jmp sp8

spr3,	dzm m
	jmp sp8+1







                
h                                sp10,	isp h
	jmp sp11
	lac chrct
	sub n
	spa
	jmp sp12
	lac g
	sza i
	jmp sp5
	lac i l
	sma
	jmp sp5
sp12,	cal terpri
	jmp sp5

sp11,	cla
	cal out
	jmp sp5
l,	0
n,	0
m,	0
f,	0
g,	0
h,	0


panmax,	lac np
	sub mp
	spq
	jmp fal
	lac lp
	cal flatsz
	add mp
	sub np
	spq
	jmp pan1
	lac lp
	spa
	jmp fal
	cal cdr
	spa
	jmp maxpan
	lio i lp
	A.IA<M
	jmp maxpan
	dio lp
	cal flatsz
	cma
	sub (2
	adm np
maxpan,	law i 1
	adm np
	cla
	dac gp
pm1,	push	/ok to push numbers, no cons will happen
	lac mp
	push
	lac lp
	cal cdr
	push






                
p                                	sad cn
	jmp pan2
	sma
	jmp pan3
	cal flatsz
	add (4
pm2,	adm mp
	lac i lp
	dac lp
	cal panmax
	pop
	dac lp
	lia
	pop
	dac mp
	pop
	dac gp
	lac 100
	sad cn
	jmp x
	adm gp
	spi i
	jmp pm1
	jmp x

pan1,	law 1
	jmp x

pan2,	law 1
	jmp pm2

pan3,	dzm mp
	jmp pm2+1

lp,	0
np,	0
mp,	0
gp,	0
]



























                
>>12<<                                
pra,	sub cfrs	/print atom
	sma
	jmp prs	/symbol
	lac 100
	cal vag
	TAAI>P
	cma
	dac pr0
	law u r-
	spi
	cal out
	dzm 100
dpl,	lac pr0
	dac t2
	mul c1
	div rad
pr0,	0
	sas 100
	jmp dpl+1
	TIAP|
	law u r0
	cal out
	lac t2
	dac 100
	sas pr0
	jmp dpl
	jmp x+1

prs,	add (frs-end-add
	sar 1s
	SAA
	cma
	dac pr0
	law sym-1
	dac t2
	jmp prp

	idx t2	/find printname
	law 77
	and i t2
	sas (76
	jmp .-4
prp,	isp pr0
	jmp .-6
	idx t2	/print it
	lac i t2
	cal p3
	and (77
	sas (76
	jmp .-5
	jmp x+1














                
4                                
.terpri,	law 77		/"terpri"
	dac chrct
	cal out
fax,	lac cn
	jmp xr

.prin1,	TAI		/"prin1"
	push
pn1,	dio t1
	TIA>P
	jmp pn2
	law u r(
pn5,	xct ers
	jmp pn6
	cal p4
	lac t1
	cal cdr
	push
	lio i t1
	jmp pn1

pn2,	cal pra
pn6,	pop
	dac t1
	sza i
	jmp pn7
	TAI>P
	xct ers
	jmp pn5	/print next item on list
	lai
	sad cn
	jmp pn3
	law flexo  . 
	cal p3
	lac t1
	cal pra
pn3,	law u r)
	cal p4
	jmp pn6

.print,	dac t1		/"print"
	cal terpri
	lac t1
	cal prin1
	law 0
	cal p4
pn7,	lac a1
	jmp xr

















                
a                                
.prinde,	sad cn		/"prindef"
	jmp pf1
	push
	cal caar
	cal cons-1
	lac (1quote
	cal cons
	cal cons-1
	lac i pdl
	cal car
	swp
	push
	swp
	cal cons-1
	lac (1quote
	cal cons
	pop
	swp
	cal cons
	lac (1rplaca
	cal cons
	cal print
	cal terpri
	pop
	cal cdr
	jmp .prinde
pf1,	lac (1stop
	cal cons-1
	jmp xr

constants
enp,
sp=even[enp-sect]
spr=sp
r ifm sp-sr,spr=sr
sym=spr+sect





























                
b                                
/"trace" section
offset otv-sect
sect/	jsp get	/instruction to bring in eval
	jsp grt	/or read
	jsp gpt	/or print
	nop	/or trace
	jmp sect+3	/get this section

	law .+3-trace
	adm rbx
	lac 100
	jmp rbx
	jmp .trace
	jmp .untrace
	jmp .dex
	jmp .gc
	jmp .stop

get,	dio ios
	lio (oev
	jda biw
	se

grt,	dac biw
	dio ios
	law sym
	mta
	lio (be9+sr+spr
	law sin
	ivk dfd
	hlt
	lio (be9
	jsp biw 1
	sr

gpt,	dio ios
	lio (be9+sr
	jda biw
	spr+sin
constants

























                
m                                
.trace,	sad cn		/"trace"
	jmp xr
	push
	lac i pwl
	dac t2
	lac i t2
	sza i
	jmp tr2
	cal car
	sas (1nlambda
	sad (1nlamda
	jmp .+3
	sas (1lambda
	jmp tr2
	lac (199g
	cal cons-1
	dac a1
	lac (1print
	cal cons
	cal cons-1
	lac (1return
	cal cons
	cal cons-1
	push
	lac t2
	cal cons-1
	lac (1value
	cal cons
	cal cons-1
	lac (1quote
	cal cons
	cal cons-1
	lac (1print
	cal cons
	lio i pdl
	cal cons
	dio i pdl
	lac i t2
	cal caddr
	cal cons-1
	lac (199g
	cal cons
	lac (1setq
	cal cons
	lio i pdl
	cal cons
	dio i pdl
	lac i t2
	cal cadr
	lia
	lac (1list
	cal cons
	cal cons-1
	lac (1print
	cal cons
	lio i pdl
	cal cons
	dio i pdl
	lac t2






                
                                	CAL CONS+"
	LAC ["ENTER
	CAL CONS
	CAL CONS+"
	LAC ["QUOTE
	CAL CONS
	CAL CONS+"
	LAC ["PRINT
	CAL CONS
	LIO I PDL
	CAL CONS
	LAC A"
	CAL CONS
	LAC ["PROG
	CAL CONS
	LAC I T'
	CAL CDDR
	DIO I "..
	POP
TR'=	POP
	CAL CDR
	JMP xTRACE

xUNTRAC=	SAD CN		?"untrace"
	jmp xr
	cal car
	lac i 100
	sza i
	jmp ut2
	cal cddr
	dac t2
	cal cdar
	lia
	cal caar
	sas (199g
	jmp ut2
	lai
	cal cddr
	cal cadr
	cal caddr
	dac i t2
ut2,	idx a1
	lac i a1
	dac a1
	jmp .untrac





















                
n                                
.dex,	cal cdr	/"dex"
	lia
	lac i a1
	dac t2
	lac (1lambda
	cal cons
	dio i t2
	lac t2
	jmp xr
























































                
(                                
.stop,	cli>>05<<cmi		/"stop"
	tyo
	lio (5435
	tyo
	rir 6s
	tyo
	law 72
	dac cas
	law rd1
	dap rdx
	dzm pa3
	dzm pa4
	law pdo
	dac dp
	law pd2
	dap top
	law pd1-1
	dap bot
	law pd1
	dap pdl
	stf 7
	lac ous
	sas (cla
	jmp oct-2
	cal terpri
	law 13
	cal out
	law i obf	/rewrite end of text pointer
	add oup
	sub (50000
	add odp
	dac etj2
	law etj2-372+340
	mta
	lio (340
	law 60
	ivk 7
	hlt
	law 10.
	skp i
oct,	law 8.
	dac rad
stp,	tyi
	cla>>05<<swp
	sad (u b
	jmp stb
	sad (u o
	jmp oct
	sad (u s
	jmp st1
	sad (u e
st4,	lio (isp rpc
	sad (u t
	lio (jmp tin
	sni
	jmp stp
	dio ins	/input source
stu,	tyi
	cla>>05<<swp






                
h                                	sad (u b
	jmp stb
	sad (u s
	jmp bgf
	sad (u e
	jmp ctf
	sad (u t
	lio (jmp toy
	sad (u n
	lio (jmp xr
	sni
	jmp stu
st3,	dio ous	/output
	cli>>05<<cmi
	tyo
	lio (34
	tyo
	jmp loop

stb,	lio (34
	tyo
	clc
	mta 203	/remove illegal memory return
	dsm

st1,	law rbf+37	/start new input file
	dac rip
	lac (20340
	dac rdp
	dzm rpc
	jmp st4

bgf,	law 7	/create new output file
	mta 300
	bpt
	law etjunk-372+340
	mta
	lio (340
	law 60
	ivk 7
	hlt
	lac etjunk
	jmp st2

ctf,	law 7	/continue output file
	mta 400
	sza i
	jmp bgf	/doesn't exist
	law .gc	/read end of text pointer
	mta	/on top of gc
	lio (340
	law 40
	ivk 7
	hlt
	lac .gc+372-340
st2,	add (50000
	cli
	rcr 5s
	ril 5s
	ral 5s






                
_                                	dac odp
	law obf
	A+IA
	dac oup
	law i 3
	dac ocp
	lio (cla
	jmp st3
etjunk,	20400	20400
etj2,	0	20400
























































                
p                                
/garbage collector
/saves AC (in t3),IO,pa3,pa4,push-down stack,atomic symbols
/clobbers t1
.gc,	dio iog
	pop
	TAX	/old drum section
	pop
	lio i pdl	/cons return
	push
	TXA
	push
	dam	/or iam
	lac (jmp x4	/was cons called by crn?
	A~IP|
	jmp .+3	/yes, don't mark car
	lac 100
	jdp gfr
	lac pa3
	jdp gfr
	lac pa4
	jdp gfr
	lac iog	/contains IO
	jdp gfr
	law end
	dac dp2
obl,	TAX	/mark car and cdr of each atom
	lac i
	jdp gfr
	idx dp2
	sas hnd
	jmp obl
	szf 1
	jmp pl1
	lac cp12	/both pd buffers in use
	sub bot
	mta
	lio dp
	law size+20
	ivk dfd	/write out lower one
	hlt
	law size
	adm dp
	sad (i
	jmp gpce
	stf 1
pl1,	lac (1-lac
	add bot
	mta
	lio dp
	law size+20
	ivk dfd	/write out current buffer
	hlt
	lac pdl
	sub bot
	dap gcs
	lac dp
	dac dp2
pdp,	xct pdl
	and (700000






                
j                                	sad (600000
	jmp .+4	/not an object
	xct pdl
	and (-1
	jdp gfr
	pop	/works in dam
	lac dp
	sas (pdo
	jmp pdp
	law 1
	add bot
	sas pdl
	jmp pdp
gcs,	law .
	add bot
	dap pdl
	lio dp2
	dio dp
	lac (1-lac
	add bot
	mta
	law size
	ivk dfd	/read current buffer back
	hlt
	lxr low
	dzm g1
	cli
slp,	law i 1
	and i 1
	sas i 1
	jmp slf
	dio i 1
	TXXI|
slf,	dac i 1
	law 2
	A+XAX
	sas hih
	jmp slp
	dio fre
	nam
	TIXP|
	jmp sce
	lio iog
	lac 100
	jmp xr
gpce,	nam
	jmp pce
sce,	error sce
	jmp stops

dp2,	0	/saved dp
iog,	0	/saved IO

g1,	0












                
.                                
gfr,	0	/marker
	rar 1s
	spq
	jmp i gfr
	ral 1s
	TAI|
in2,	TXA
	dac g1
in3,	TIAIX>P
	jmp gca
	lac i 1	/concatenation
	rar 1s
	spa
	jmp gfx
	idx i 1	/turn on mark bit
	lio i 0
	law 1
	ior g1
	dac i 0	/point car back at previous thing
	jmp in2	/start working on car

gca,	sub (100000	/atom
	spa
	jmp gfx	/direct number
	add c1frs
	sma
	jmp gfx	/atomic symbol
	law 1	/indirect number
	ior i 1
	dac i 1
gfx,	lxr g1	/thing in IO is marked
	TXXP|
	jmp i gfr
	law i 1	/back up
	and i 1
	dac g1
	law 1
	ior i 0
	sas i 0
	jmp gcb
	dac i 1	/point cdr back at previous thing
	dio i 0	/replace car
	lio g1
	jmp in2	/start working on cdr

gcb,	X.IA	/returning from cdr
	ior (1
	dac i 1	/replace cdr
	jmp in3

constants
ent,
st=even[.-sect]












                
>>16<<                                
/"eval" section
offset oev-sect
sect/	nop	/instruction to bring in eval
	jsp gre	/or read
	jsp gpe	/or print
	jsp gte	/or trace
	jmp sect	/get this section

gre,	dac biw	/get read
	dio ios
	law sym	/get names
	mta
	lio (be9+sr+spr
	law sin
	ivk dfd
	hlt
	lio (be9
	jsp biw 1
	sr
constants

gpe,	dio ios
	lio (be9+sr
	jda biw
	spr+sin

gte,	dio ios
	lio (otv
	jda biw
	st



































                
z                                
return=.	dac pa3		/"return"
go,	dac pa4		/"go"
	jmp x

prog,	lio cn		/"prog"
	lac i a1
	dac 100
prog+3,	spa
	jmp pr2
	lac i 100	/get a prog variable
	bind
	lac 100
	cal cdr
	jmp prog+3

pr2,	lac a1
pr3,	cal cdr

	TAAI>P
	jmp pr35
	cal car
	spa
	bind	/bind prog tags
	lai
	jmp pr3

pr35,	lac pa3
	push
	lac pa4
	push
	dzm pa3
	lac a1
pr4,	cal cdr
	dac pa4
	sad cn
	jmp pr6	/program finished
	lac i pa4
	cal eval
ik2,	lac pa4
	lio pa3
	sni
	jmp pr4
	lai	/program returned

pr6,	dac 100
	pop
	dac pa4
	pop
	dac pa3
	jmp x+1















                

                                
ikd,	pop
	sad .+1
	jmp ik2
	push
	error icd
	jmp fal

cn2,	pop
	cal cdr
cond,	spa	/"cond"
	jmp ikd
	push
	cal caar
	cal eval
	sad cn
	jmp cn2
	pop
	lac i pwl
	dac pwl
prog3,	idx pwl
	lac i pwl
	spa
	jmp x+1
prog2,	push	/"prog2"
	cal eval-1
	pop
	jmp prog3






































                
l                                
enl,	spi	/function is "nlamda"
	jmp tma
	lac i 100
	lio a2
	bind
	clc
	jmp el7

elb,	lac a1	/function is "label"
	cal cadr
	swp>>05<<clf 2
	bind
	jmp apl-1

tfa,	error tfa
	jmp fal

tma,	error tma
	jmp fal

el1,	lac a2	/function is "lambda"
	spa
	jmp el9	/no more args
	lac 100
	spa
	jmp tma
	lac i 100
	lio i a2
	bind
	idx a2
	lac i a2
el7,	dac a2
	lac 100
	cal cdr
	jmp el1
el9,	lac 100
	sas cn
	jmp tfa
	lac a1


























                
)                                
eval-2,	cal cdr
eval-1,	cal car
eval,	dac a1	/"eval"
	sma
	jmp ev2	/not atomic
	sub cfrs
	spa
	jmp x+1	/number
	lac i a1	/atomic symbol
	sza
	jmp x
	error uas,-2
	jmp fal
ev2,	lio i a1
	cal cdr
apl-3,	dac a2	/argument list
	stf 2
apl-1,	dio a1	/function
apl,	lac a1
	xct ers	/szs 10 unless recovering from error
	jmp fal
	sma
	jmp e3	/non-atomic function
	sub cfrs	/atomic funcion
	sma
	jmp e4	/symbol
	sub c1frs
	spa
	jmp uaf
	lac a1	/number
	cal cdr
	sas (1t
	jmp uaf
	lac i a1
	push
	ral 2s
	sma
	cal evlis	/evaluate arguments
	lio a2
	dio a1
	dio 100
	pop
	dap exs
	ral 3s
	spa
	jmp exg
	ral 3s
	and (3
	CAI
	law a1
	dap sp2
sp1,	SII>|
	jmp sr9
	lac i 100
sp2,	dac .
	idx sp2
	lac 100
	spa
	jmp tfa






                
>>37<<                                	cal cdr
	jmp sp1
sr9,	lac 100
	sas cn
	jmp tma
exg,	lac a1
	lio a2
	dac 100
exs,	jmp .

























































                
(                                
e4,	lac i a1	/function is symbol
	sza
	sad a1
	jmp uaf
	dac a1
	jmp apl

uaf,	error uaf,-2
	jmp fal

e3,	lac a1	/function is not atomic
	push
	lac i a1
	sad (1nlambda
	jmp .+3
	sas (1nlamda
	cal evlis	/evaluate arguments
	pop
	dac a3	/entire function
	cal cdr
	dac a1	/cdr of function
	cal car	/leave lambda list in 100
	lia
	lac i a3
	sas (1nlambda
	sad (1nlamda
	jmp enl
	sad (1lambda
	jmp el1
	sad (1label
	jmp elb
	lac a2	/evaluate entire function
	push
	lac a3
	cal eval
	dac a1	/evaluated function
	pop
	dac a2	/arg list
apply,	clf 2	/"apply"
	jmp apl

























                
s                                
evlis,	lac a2
	szf 2
	sad cn
	jmp x
	push
	cal eval-1
	cal cons-1
	lac i pdl
	dac pwl
	dio i pdl
	jmp el2
ele,	push
	cal eval-1
	cal cons-1
	pop
el2,	zorch
	sma
	jmp ele
el5,	lio cn
	pop
el5+2,	idx pwl
	lac i pwl
	dio i pwl
	dac a2	/evaluated args
	jmp x

bn,	0	/bind
	push
	lac i pwl
	dio i pwl
	push
	jmp i bn

zerop,	cal vag	/"zerop"
	ZIP
null,	lio cn	/"null"
eq,	A~IP	/"eq"
	jmp fal
	jmp tru

number,	sma		/"numberp"
	jmp fal
	sub cfrs

atom,	sma		/"atom"
	jmp fal
	jmp tru

minusp,	cal vag	/"minusp"
	jmp atom















                
y                                
eq4,	pop
	cal cdr
	lia
	pop
	cal cdr

equal,	A~IP|	/"equal"
	jmp tru
	A^I>P
	jmp eq3
	A~I>P
	jmp fal
	push
	lai
	push
	lac i 100
	lio i pwl
	cal equal
	sas cn
	jmp eq4
pxx,	pop
	pop
	jmp x+1

eq3,	lxr cfrs
	XMA.<
	XMI>
	jmp fal
	cal vag
	swp
	cal vag
	jmp eq

minus,	jsp nmop-1	/"minus"
	jmp .+1
minus+2,	add t2
	CAAM|
	cla	/fix -0
	jmp nm3

times,	law 1	/"times"
	dac t2
	jsp nmop
	jmp .+1
	mul t2
	scr 1s
	A+IA
	jmp nm3

















                
r                                
plus,	law minus+2	/"plus"

nmop-1,	dzm t2
nmop,	dap nm2
	lac 100
nm1,	dac a2
	spa
	jmp nm9
	lac i a2
	cal vag
nm2,	xct nm9+1	/return 0 if nna error
nm3,	dac t2
	lac a2
	cal cdr
	jmp nm1

add1,	cal vag	/"add1"
	SAA|
nm9,	lac t2
nm9+1,	jmp crn

logand,	clc	/"logand"
	dac t2
	jsp nmop
	and t2

logor,	jsp nmop-1	/"logor"
	ior t2

logxor,	jsp nmop-1	/"logxor"
	xor t2

greate,	cal vag		/"greaterp"
	dac a1
	lac a2
	cal vag
	clo
	sub a1
	szo
	lac 100
	jmp atom

remain,	cal divi		/"remainder"
	swp
	jmp crn

divi,	lai
	cal vag
	dac a2
	lac a1
	cal vag
	mul c1
	div a2
	jmp .+2
	jmp x
	error dze
	jmp nna+2

quotie,	cal divi		/"quotient"






                
.                                	jmp crn

nna,	error nna,+1
nna+2,	cla>>05<<cli
	jmp x

sub1,	cal vag	/"sub1"
sub1+1,	sub c1
	jmp crn

























































                
k                                
and2,	sad cn		/"and"
	jmp tru
	push
	cal eval-1
	sad cn
	jmp pxx+1
	pop
	cal cdr
	jmp and2

or1,	pop
	cal cdr

or,	sad cn		/"or"
	jmp fal
	push
	cal eval-1
	sad cn
	jmp or1
ppt,	pop
	jmp tru

mapcar,	sad cn		/"mapcar"
	jmp x
	push
	cal map
	lac i pdl
	dac pwl
	dio i pdl
	jmp mp2
mp1,	push
	cal map
	pop
mp2,	zorch
	sas cn
	jmp mp1
	jmp el5
map,	lac a2
	push
	lac i 100
	cal cons-1
	lac i pdl
	dac a1
	dio a2
	cal apply
	cal cons-1
	pop
	dac a2
	jmp x
















                
	                                
append,	sad cn		/"append"
	jmp xi
	swp
	push
	swp
	push
	cal car
	cal cons-1
	lac i pdl
	dac pwl
	dio i pdl
	jmp apn2
apn1,	push
	cal car
	cal cons-1
	pop
apn2,	zorch
	sas cn
	jmp apn1
	pop
	lia
	pop
	dio pwl
	lia
	jmp el5+2

nconc,	sad cn		/"nconc"
	jmp xi
	dac a2
	cal cdr
	sas cn
	jmp .-3
	idx a2
	dio i a2
	lac a1
	jmp x

member,	lai		/"member"
	sad cn
	jmp fal
	dac a2
	lac i a2
	lio a1
	cal equal
	sas cn
	jmp x
	lac a2
	cal cdr
	jmp member+1
















                
>>32<<                                
sassoc,	iam	/"sassoc"
	TIX>P
	jmp ss2
	lio i 1
	lxr i 0
	sas i 0
	jmp sassoc+1
	nam
	TXA
	jmp x

ss2,	nam
	lac cn
	lio a3
	jmp apl-3

valp,	sma		/"valp"
	jmp fal
	sub cfrs
	TA<M
	sas i 100
	jmp tru
	jmp fal

rplacd,	idx 100		/"rplacd"
	sub c1

rplaca,	dio i 100		/"rplaca"
	jmp x

fix,	lac a3	/"fix"
	push	/name
	lac i a3
	dac a3
	lac a1
	cal subst
	lia
	pop
	dio i pwl
	jmp x

























                
>>52<<                                
subst,	push		/"subst"
	lai
	push
	cal subs1
	jmp pxx

subs1,	lio a2
	lac a3
	cal equal
	sad cn
	jmp .+3
	lac a1
	jmp x
	lac a3
	spa
	jmp x
	cal cdr
	push
	lac i a3
	dac a3
	cal subs1
	lio i pdl
	dac i pdl
	dio a3
	cal subs1
	lia
	pop
	dac 100
	jmp cons

revers,	lio cn		/"reverse"
	sad cn
	jmp xi
	push
	cal car
	cal cons
	pop
	cal cdr
	jmp revers+1

setq,	push	/"setq"
	lai
	cal eval
	lia
	pop
	dac 100

setqq,	dio i 100	/"setqq"
xi,	dio 100
	jmp x+1















                
>>75<<                                
nth,	cal vag	/"nth"
	cma>>05<<swp
	SII.<
	jmp x
	cal cdr
	jmp .-3

length,	iam	/"length"
	TAX|
	lxr i 1
	SAA
	TXX<M
	jmp .-3
	nam
	jmp sub1 1

constants
ene,
se=even[.-sect]
ste=st
r ifm st-se,ste=se












































                
>>52<<                                
define here
apval nil
su cons,2
su quote,11
su car,1
su cdr,1
su caar,1
su cadr,1
su cdar,1
su cddr,1
su caddr,1
su null,1
2rplac.=9rplac
su rplacd,2
9rplac.=2rplac
2rplac.=8rplac
su rplaca,2
8rplac.=2rplac
su setq,12
su setqq,12
su prog,14
su go,1
su return,1
apval t
su zerop,1
thing lambda
thing nlambda
thing nlamda
thing label
su cond,14
su apply,2
su eval,1
su list,4
su terpri,0
su valp,1
su numberp,1
su atom,1
su prog2,14
su read,0
su readc,0
su prin1,1
su print,1
su character,4
su stop,0
su eq,2
su equal,2
su add1,1
su sub1,1
2minus.=9minus
su minusp,1
9minus.=2minus
2minus.=8minus
su minus,4
8minus.=2minus
su plus,4
su times,4
su logand,4
su logor,4
su logxor,4






                
8                                su greaterp,2
su remainder,2
su quotient,2
su and,14
su or,14
su mapcar,2
su append,2
su nconc,2
su member,2
su gensym,0
su sassoc,3
su prindef,14
su dex,14
su subst,3
su fix,13
su reverse,1
su length,1
su nth,2
su trace,14
su untrace,14
r ifup 3,su pprint,1
thing 99g
thing enter
thing value
scar 0,space
scar 57,lpar
scar 55,rpar
scar 35,red
scar 34,black
scar 73,period
scar 77,carret
scar 36,tabul
scar 75,backspace
terminate
































                
j                                
sym=sect+spr

p.=777700
v.=767676
define pname name
z=v
irpc w,name
z=[z^p u r'w]xi
r ifn z^77-76,z	z=v
terminate
z
terminate

define su name,num
pname name
terminate

define apval name
pname name
terminate

define thing name
pname name
terminate

define scar name,sname
namexi 7676
pname sname
terminate

offset be9+sr+spr-sym
sym/	here	/names
esy,

sin=even[syms esy-sym]
r ifm sin spr-ste,sin=ste-spr
end=sym sin
sin=ste-spr
r ifm sin-1,sin=40	/crock
end=end^1+end
oev=even[esy-sym]
otv=be9 sr spr sin
r ifm sin-oev,otv=otv-sin oev
oev=otv st

define su name,num
1'name.=add .
2'name	1nil
terminate

define apval name
1'name.=add .
1'name	1nil
terminate

define thing name
1'name.=add .
0	1nil
terminate






                
9                                
define scar name,sname
2'sname.=add .
0	1nil
2'sname	1nil
terminate

offset oev ene-sect-end
end/	here	/heads
enh,
frs=2xatoms+enh
oiv=oev+ene-sect+enh-end

define su name,num
2'name.=add .
jmp ixnum+name
1t
terminate

define apval name
terminate

define thing name
terminate

define scar
terminate

offset oiv-frs
	and.=and2
frs/	here	/values
	and.=20000
tsy,
pdo=[oiv+tsy-frs-1]>>05<<[size-1]+1
r 1-if2,start

define wr x,what
printx /what	/
printo x	printc 36
decimal	printo x	octal
printc 77
terminate

wr [[i-frs]>2],[free storage]	/size of free storage in 4K
wr i-pdo,[pushdown capacity]
wr end-esy,[symbol table]	/size
wr frs,frs	/origin of program space
wr pd1,[common section]	/size
wr ene-sect,[eval]	/size
wr ent-sect,trace	/size
wr enp-sect,print	/size
wr enr-sect,read	/size
wr end-ene,[space above eval]	/ wasted because syms is large
wr pd3-eni,[setup margin]
start 102











                
c                                                                                                              

