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