                          
lisp for ts_ 1/1/66

test=sas hih

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

ct=(1t
cn=(1nil
c1=(1
c3=(3
cpde=(pde

repeat 1-if2,equals halt,stop
bind=jdp bn
push=jda pwl
pop=jsp po
zorch=jdp zo

0/	jmp begin
	law rd1
	dap rdx
loop,	dzm pa3
	dzm pa4
	law pde
	dap pdl
	cal read
	cal eval
	cal print
	jmp loop

	lac 100
pwl,	0	/push
	dap psx
	law i 1
	adm pdl
	sad snd
	jmp pce
	lac pwl
	dac i pdl
psx,	jmp .

po,	dap pox	/pop
pdl,	lac pde
	dac pwl
	idx pdl
	lac pwl
pox,	jmp .
                
                                
bn,t4,	0	/bind
	push
	lac i pwl
	dio i pwl
	push
	jmp i bn

cddr,	add (1		/"cddr"
cdar,	cal car		/"cdar"
cdr,	idx 100		/"cdr"
quote,			/"quote"
car,	lac i 100		/"car"
	sza i
	jmp cva
x,	dac 100
	pop
	ral 1s
	spa
	jmp pwl-1
	lio pwl
	pop
	dio i pwl
	jmp x 1

cadr,	add (1		/"cadr"
caar,	cal car		/"caar"
	jmp car

number,	sma		/"numberp"
	jmp fal
	sub cpde

atom,	sma		/"atom"
	jmp fal
tru,	lac ct
	jmp x

zerop,	cal vag		/"zerop"
	sza
	jmp fal
	jmp tru

g4,t1,	0
g1,t2,	0

repeat ifm 100-.,[printx /No room.
/]
101/	dap pox
	sub (1
	dap . 1
	lac . 
	dap . 4
	lac pox
	push
	lac 100
	jmp .

cva,	error cva,-2
	jmp u2
                
                                
vag,	sma
	jmp nna
	sub cpde
	sma
	jmp nna
	lac i 100
	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

valp,	sma		/"valp"
	jmp ana
	cla
	sas i 100
	jmp tru
fal,	lac cn
	jmp x

ana,	error ana,-2
	jmp u2

nna,	error nna,-2
	cal print
nnx,	cla>>05<<cli>>05<<stf 4
	jmp x
                
                                
in,	stf 4
	szs 50
	jmp tin
ras,	skp 600	/skip if reader not assigned
	jmp ra2
	law 51
	jdp asg
	dap ras
ra2,	rpa
	rir 7s
	sni i
	spi
	jmp in
	ril 7s
	lai
	ior (rar
	dac . 2
	law 2525
	0
	spa
	jmp gtc
	error ilp
	jmp in

tin,	law i 51	/entry for stop
	xct ras
	arq	/dismiss reader
	law 600
	dap ras
	tyi
gtc,	lai
	and (77
	sas (74	/upper case
	sad (72	/lower case
	dac cas
	jmp x

asg,	0
	arq
	jmp bsy
	cla
	jmp i asg
bsy,	error bsy
	stf 4
	tyi
	law i 2
	adm asg
	jmp i asg

stop=.	cal tin		/"stop"
	jmp fal

cas,	72
                
                                
p4,	lio pcc
	spi i
	jmp p2
	jmp p3
	lac i a3
p3,	cal out
p2,	cal out

out,	law 77
	and 100
	sas cas
	sad (76
	jmp oux
	sad (77
ou4,	dac pcc
	ior (ral
	dac oug
	law 252
oug,	0
	and (200
	adm oug
	lia
	szs i 34
	jmp ou1
pas,	skp 600	/skip if punch not asigned
	jmp ou2
	law 47
	jdp asg
	dap pas
ou2,	lio oug
	ppa
	jmp ou3
ou1,	law i 47
	xct pas
	arq
	law 600
	dap pas
ou3,	szs i 64
	tyo
	law 77
	and 100
	sas (74
	sad (72
	jmp oux-1
	sas (56
	sad (40
	jmp oux
	law i 1
	adm pcc
	jmp oux
	dac cas
oux,	lac 100
	rar 6s
	jmp x
pcc,	0

                
                                
read,	cla>>05<<stf 5		/"read"
	push
	lac pdl
	dap re2
	jmp rdx
iif,	error iif
re2,	law .	/old pdl
	dap pdl
	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 sy2
	dac sy1
	dap pt1
	idx sy2
	sub pdl
	add (3
	sma
	jmp pce
	lac (add-7	/character count
	dac t2
	lio (767676
	dio i sy1
	dio i sy2
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
	scr 1s
	lai
	lio 100
	rir 5s
	spi i
	add 100
	dac a1
	jmp rsl 1
min,	stf 3	/-
	jmp rsl 1
bsp,	lac i sy1	/backspace
	sad (767676
	jmp re2
	jmp rd1
                
                                
tb1,	20+100xnum	/dispatch table
	54+100xmin
	55+100xrpr+add
	57+100xlpr+add
	73+100xper+add
	00+100xrd1+add
	33+100xrd1+add
	36+100xrd1+add
tb2,	56+100xvb
	75+100xbsp
	13+100xrlp
	77+100xrlp
tb3,vb,	cal in	/.
rsl,	stf 6	/letter seen
	isp t2	/pack character
	jmp rlp
	sad (add-3
	idx pt1
pt1,	lac .
	lio 100
	rcr 6s
	dac i pt1
	jmp rlp
tbs,	lac .
	lia
	rar 6s
	dap rdx
	spi i
	jmp rdx
	law i 4000
	adm rdx
	lac i sy1
	sad (767676
rdx,	jmp .	/no atom
	szf 5 i
	jmp iif
	cal mka
	jmp rxy+2
putob,	law sym	/oblist lookup
	dap pt1
sy1,	lac .
	sas i pt1
	jmp id1-1
	idx pt1
sy2,	lac .
	sas i pt1
	jmp id1
fou,	idx pt1
	add (lac
	jmp x
	idx pt1
id1,	law 3
	adm pt1
	sas snd
	jmp sy1
	idx pt1
	dac snd
	idx snd
	dzm i snd
	idx snd
	lac cn
	dac i snd
	idx snd
	jmp fou
                
                                lpr,	szf i 5	/(
	jmp iif
	lac cn
	push
	jmp rd1
per,	lac i pdl	/.
	sad cn
	jmp iif
	rar 1s
	spq 5
	jmp iif
	idx i pdl
	jmp rd1
rpr,	law rd1	/)
	dap rdx
	lac i pdl
	rar 1s
	spq
	jmp iif
	pop
	szf 5
	sad cn
	jmp rxy
	idx pwl
	lio cn
	lac i pwl
	dio i pwl
rxy,	stf 5
	dac 100
	pop
	sza i
	jmp x 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
mka,	sas (547676	/make atom
	szf 6
	jmp putob	/atomic symbol
	cal p10		/number
	szf 3
	cma
                
                                
crn,	lio cn	/create number
	dio g1
	cal cons 1
	add (add
	jmp x

pce,	law pde
	dap pdl
	error pce
	jmp 0

fre,	0

snd,	lac esy

err-2,	lio 100
	dio a1
err,	dap erx
	clf 4
	cal terpri
	lac i erx
	cal p3
	cal terpri
	idx erx
	lac a1
erx,	jmp .
                
                                
prin1,	sma		/"prin1"
	jmp ana
	sub cpde
	sma
	jmp prs	/symbol
	lac i 100
	lia
	spa
	cma
	dac a3
	dzm t3
	law 54
	spi
	cal out
dpl,	lac a3
	dac t4
	mul (1
	div rad
rad,	10.
	sas t3
	jmp dpl 1
	lai
	sza i
	law 20
	cal out
	lac t4
	dac t3
	sas a3
	jmp dpl
	jmp p10

prs,	law i 2
	add 100
	dac a3
	cal p3-1
	idx a3
	cal p3-1
p10,	law 10.
	szs 40
	law 10
	dac rad
	lac a1
	jmp x
                
                                
	cal print
terpri,	law 7772		/"terpri"
	cal p2
	jmp fal

print,	dac t1		/"print"
	cal terpri
	cla
	push
	lac t1
pn1,	spa
	jmp pn2
	law i 2005
pn5,	cal p4
	lac t1
	cal cdr
	push
	lac i t1
	dac t1
	jmp pn1
pn2,	cal prin1 2
pn6,	pop
	dac t1
	sza i
	jmp pn7
	law i 7705
	lio t1
	spi i
	jmp pn5
	lac t1
	sad cn
	jmp pn3
	law i 405
	cal p4
	lac t1
	cal prin1 2
pn3,	law i 2205
	cal p4
	jmp pn6
pn7,	law i 7705
	cal p4
	lac a1
	jmp x
                
                                
cons-2,	cal eval-1
cons-1,	lio cn
cons,	dzm g1		/"cons"
	lac fre
	sza i
	jmp gc
con2,	dac t1
	lac 100
	dac i fre
	idx fre
	lac i fre
	dio i fre
	dac fre
	lac t1
	lia
	jmp x

null=.	xor cn		/"null"
	jmp zerop 1

setq,	push		/"setq"
	cal eval-2
	lia
	pop
	cal car
	dio i 100
	jmp prog2

rplacd,	idx 100		/"rplacd"
	sub (1

rplaca,	dio i 100		/"rplaca"
	jmp x

evlis-1,	lac a2
evlis,
list,	szf 2		/"list"
	sad cn
	jmp x
	push
	cal cons-2
	lac i pdl
	dac pwl
	dio i pdl
	jmp el2
ele,	push
	cal cons-2
	pop
el2,	zorch
	sas cn
	jmp ele
	lio cn
el5,	pop
	idx pwl
	lac i pwl
	dio i pwl
	jmp x
                
                                
gfr,	dap gfx	/list marker
	lac i pt1
	ral 1s
	spq
	jmp gfx
	law i 1
	and i pt1
	cli>>05<<swp
in1,	dac g1
in2,	dac g3
	idx g3
in3,	dio g2
	dio g4
	idx g4
	lac i g4
	and (dip
	sza i
	jmp gcn
	lac g1
	sza i
gfx,	jmp .
	lac i g3
	ral 1s
	spa
	jmp gcb
	lac i g3
	and (-dip
	lia
	lac i g1
	ior (dip
	dac i g3
	lac g2
	dac i g1
	jmp in3
gcb,	lio g1
	lac i g3
	and (-dip
	dac g1
	lac g2
	ior (lac
	dac i g3
	lac g1
	jmp in2

gcn,	lac g2
	sma
	jmp gcl
	sub cpde
	sma
	jmp gfx-2
	lio i g4
	lac g1
	ior (dip
	dac i g4
in4,	lac g2
	jmp in1
gcl,	lio i g2
	lac (xct
	adm i g4
	lac g1
	dac i g2
	jmp in4
                
                                
gc,	dio a1	/garbage collector
	clc>>05<<lia
	dpy 400
	law 100
	dap pt1
	lac g1
	sza i
	jsp gfr
	law sym
	dap pt1
oblp,	law 2
	adm pt1
	jsp gfr
	idx pt1
	jsp gfr
	idx pt1
	sas snd
	jmp oblp
	lac pdl
	dap pt1
pdlp,	jsp gfr
	idx pt1
	sas el1	/>lac a2
	jmp pdlp
low,	law frs
	dac t1
swlp,	idx t1
	lac i t1
	lia
	and (-lac
	dac i t1
	ril 1s
	spi
	jmp swlf
	lac fre
	dac i t1
	law i 1
	add t1
	dac fre
swlf,	idx t1
	test
	jmp swlp
	cla>>05<<cli
	dpy 300
	lio a1
	lac fre
	sza
	jmp con2
	error sce
	jmp 0
                
                                
prog2,	lai		/"prog2"
	jmp x

return,	dac pa3		/"return"
go,	dac pa4		/"go"
	jmp x

prog,	lac i a1		/"prog"
	sad cn
	jmp pr2
	dac 100	/get a prog variable
	lac i 100
	lio cn
	bind
	lac 100
	cal cdr
	jmp prog 1

pr2,	lac a1
pr3,	cal cdr

	sad cn
	jmp pr35
	lia
	cal car
	spa
	bind
	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

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

                
                                
apply,	clf 2		/"apply"
	jmp apl

ikd,	pop
	sad . 1
	jmp ik2
	push
	error icd
	jmp tfa 2
cn2,	pop
	cal cdr
cond,	sad cn		/"cond"
	jmp ikd
	push
	cal caar
	cal eval
	sad cn
	jmp cn2
	pop
	cal car

eval-2,	cal cdr
eval-1,	cal car
eval,	dac a1		/"eval"
	sma
	jmp ev2	/not atomic
	sub cpde
	spa
	jmp x 1	/number
	lac i a1	/atomic symbol
	sza
	jmp x
	error uas
u2,	cal terpri-1
	jmp tfa 2
ev2,	lio i a1
	cal cdr
	dac a2	/argument list
	stf 2
	dio a1	/function
apl,	lac a1
	sma
	jmp e3	/non-atomic function
	sub cpde	/atomic function
	sma
	jmp e4	/symbol
	lac a1	/number
	cal cdr
	sad (1subr
	jmp esu
	sas (1fsubr
	jmp uaf
	lac i a1	/function is fsubr
	dap exs
	lac a2
	dac a1
exg,	lio a2
	dac 100
exs,	jmp .
                
                                
esu,	lac i a1	/function is subr
	push
	cal evlis-1
	pop
	dap exs
	ral 6s
	and (3
	add (a1
	dac t2
	law a1
	dac t1
sp1,	sad t2
	jmp sp9
	lac 100
	sad cn
	jmp tfa
	lac i 100
	dac i t1
	lac 100
	cal cdr
	idx t1
	jmp sp1
sp9,	lac 100
	sas cn
	jmp tma
	lac a1
	jmp exg

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

uaf,	error uaf
	jmp u2

e3,	lac i a1	/function is not atomic
	sad (1lambda
	jmp ela
	sad (1nlamda
	jmp enl
	sad (1label
	jmp elb
	lac a2	/evaluate entire function
	push
	lac a1
	cal eval
	pop
	lio 100
	jmp apl-3
                
                                
ela,	lac a1	/function is "lambda"
	push
	cal evlis-1
	dac a2
	pop
	dac a1	/args in a2,function in a1
	cal cadr	/get lambda variables
/pair lambda list with arg list
el1,	lac a2
	sad cn
	jmp el9	/no more args
	lac 100
	sad cn
	jmp tma
	lac i 100
	lio i a2
	bind
	idx a2
	lac i a2
	dac a2
	lac 100
	cal cdr
	jmp el1
el9,	lac 100
	sas cn
	jmp tfa
	lac a1
	cal cddr
	jmp eval-1

enl,	lac a1	/function is "nlamda"
	cal cadr
	sad cn
	jmp tma
	lac i 100
	lio a2
	bind
	idx 100
	lac i 100
	jmp el9 1

elb,	lac a1	/function is "label"
	cal cdr
	dac a1
	cal cadr
	lia
	lac i a1
	bind
	jmp apl-1

tfa,	error tfa
	stf 4
	szs 10
	jmp 0
	jmp fal

tma,	error tma
	jmp tfa 2

constants
                
                                
define here x,y
x
y
terminate

define put z
here [define here 123,456
123],[z
456
terminate]
terminate

define pack q
n2=q
n1=767676
repeat 3,n2=n2x100	repeat ifn n2^77,n1=n2~n1^77~n1xi
n1
terminate

define pname name,val
pack text1 /name/
pack text2 /name/
1'name=add .
val	1nil
terminate

define su name,num,/g
pname name,add g
put [s name,num,g]
terminate

define fsu name,/g
pname name,add g
put [f name,g]
terminate

define apval name
pname name,1'name
terminate

define thing name
pname name,0
terminate

equals s,if2
equals f,if2
repeat 1-if2,define kill x	terminate
repeat if2,define kill x	equals x,if2	terminate

hih,	20000

.+.^1/

sym,
                
                                
su cons,2
fsu quote
su car,1
su cdr,1
su caar,1
su cadr,1
su cdar,1
su cddr,1
su null,1
su rplacd,2
su rplaca,2
fsu setq
fsu prog
su go,1
su return,1
apval t
apval nil
su zerop,1
thing lambda
thing nlamda
thing label
fsu cond
su apply,2
su eval,1
fsu list
su terpri,0
su valp,1
su number,1
su atom,1
su prog2,2
su read,0
su prin1,1
su print,1
su stop,0
thing subr
thing fsubr
su eq,2
su equal,2
su minus,1
fsu plus
fsu times
fsu logand
fsu logor
fsu logxor
su greate,2
su remain,2
su quotie,2
fsu and
fsu or
su maplis,2
su append,2
su nconc,2
su member,2
su gensym,0
su sassoc,3

fsu prinde
fsu dex
su subst,3
fsu fix
su revers,1
fsu trace
tsy,
fsu untrac
thing 99g
thing enter
thing value
                
                                
esy,
/free storage maker

begin,	eem
	lio .-1
	dio 0
	law 6301
	jdp asg
	clf 4
	szs 10 i
	jmp nxp
xpl,	lac (lac-2
	add a2
	dac a1
	cal print
	tyi
	lai
	sas (charac rx
	jmp nxp
	law i 4
	adm a2
	dac snd
	lac i a1
	dap ta5
	sma
	jmp xpl
	lac i ta5
	add (1
	and (-1
	dap low
	jmp xpl
nxp,	cli
	xct low
gc9,	sad (frs
ta5,	law fr2
	dac t1
	dac g1
	idx t1
	dio i t1
	lio g1
	idx t1
	test
	jmp gc9
	dio fre
	jmp 0
constants
sym 2100/
pde,
pa3,	0
pa4,	0
a1,	0
a2,g3,	lac tsy
a3,g2,	0
                
                                
eq,	xor a2		/"eq"
	jmp zerop 1

eq4,	pop
	cal cdr
	lia
	pop
	cal cdr

equal,	dio t1		/"equal"
	sad t1
	jmp tru
	spa>>05<<spi
	jmp eq3
	sma
	spi
	jmp fal
	push
	lai
	push
	lac i 100
	lio i pwl
	cal equal
	sas cn
	jmp eq4
	pop
ppf,	pop
	jmp fal

eq3,	sub cpde
	swp
	sub cpde
	spa>>05<<spi i
	jmp fal
	lac i 100
	xor i t1
	jmp zerop 1

minus,	cal vag		/"minus"
	jmp crn-1

plus,	cal evlis		/"plus"
	law cadt2

	dzm t2
nmop,	dap nm2
	lac 100
nm1,	dac a2
	sad cn
	jmp nm9
	lac i a2
	cal vag
nm2,	xct .
	dac t2
nm3,	lac a2
	cal cdr
	jmp nm1
nm9,	lac t2
	jmp crn
cadt2,	add t2
                
                                
times,	cal evlis		/"times"
	law 1
	dac t2
	jsp nmop
	jmp . 1
	mul t2
	scr 1s
	dio t2
	adm t2
	jmp nm3

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

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

logxor,	cal evlis		/"logxor"
	jsp nmop-1
	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 ovf
	jmp nnx

quotie,	cal divi		/"quotient"
	jmp crn
                
                                
and2,	sad cn		/"and"
	jmp tru
	push
	cal eval-1
	sad cn
	jmp ppf
	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

maplis,	sad cn		/"maplist"
	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-1
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 prog2
	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 1

nconc,	sad cn		/"nconc"
	jmp prog2
	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
                
                                
gensym,	law gst		/"gensym"
	dac t1
gen2,	idx i t1
	sad (21
	law 1
	dac i t1
	sas (12
	jmp gen3
	law 20
	dac i t1
	idx t1
	jmp gen2
gen3,	lac snd
	dac sy2
	dac sy1
	idx sy2
	sub pdl
	add c3
	sma
	jmp pce
	law charac mg
	ior gst 3
	ral 6s
	ior gst 4
	ral 6s
	dac i sy1
	lac gst
	ral 6s
	ior gst 1
	ral 6s
	ior gst 2
	dac i sy2
	jmp putob

constants

gst,	repeat 5,20

sassoc,	lac a2		/"sassoc"
	sad cn
	jmp ss2
	cal car
	lac i 100
	sad a1
	jmp x 1
	lac a2
	cal cdr
	dac a2
	jmp sassoc 1
ss2,	lio a3
	lac cn
	jmp ev2 2
                
                                
prinde,	sad cn		/"prindef"
	jmp pf1
	push
	cal caar
	cal cons-1
	lac pq
	cal cons
	cal cons-1
	lac i pdl
	cal car
	swp
	push
	swp
	cal cons-1
	lac pq
	cal cons
	pop
	swp
	cal cons
	lac (1rplaca
	cal cons
	cal terpri-1
	pop
	cal cdr
	jmp prinde
pq,	1quote
pf1,	lac (1stop
	dac 100
	jmp cons-1

constants

dex,	cal cdr		/"dex"
	lia
	lac i a1
	dac a1
	lac lam
	cal cons
	dio i a1
	jmp pn7 2
lam,	1lambda
                
                                
subst,	push		/"subst"
	lai
	push
	cal subs1
	pop
	pop
	jmp x 1

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

fix,	cal cdr		/"fix"
	lio i 100
	dio a2
	cal cadr
	push
	cal car
	dac a3
	lac i a1
	dac a1
	cal subst
	lia
	pop
	dio h pwl
	jmp x

revers,	lio cn		/"reverse"
	sad cn
	jmp prog2
	push
	cal car
	cal cons
	pop
	cal cdr
	jmp reverse 1
                
                                
trace,	sad cn		/"trace"
	jmp tru
	push
	lac i pwl
	dac t3
	lac i t3
	sza i
	jmp tr2
	cal car
	sas lam
	jmp tr2
	lac (199g
	cal cons-1
	dac t4
	lac (1print
	cal cons
	cal cons-1
	lac (1return
	cal cons
	cal cons-1
	lio i pdl
	push
	lai
	cal car
	cal cons-1
	lac (1value
	cal cons
	cal cons-1
	lac pq
	cal cons
	cal cons-1
	lac (1print
	cal cons
	lio i pdl
	cal cons
	dio i pdl
	lac i t3
	cal cddr
	cal car
	cal cons-1
	lac (199g
	cal cons
	lac (1setq
	cal cons
	lio i pdl
	cal cons
	dio i pdl
	lac i t3
	cal cadr
	lia
	lac (1list
	cal cons
                
                                
	cal cons-1
	lac (1print
	cal cons
	lio i pdl
	cal cons
	dio i pdl
	lac t3
	cal cons-1
	lac (1enter
	cal cons
	cal cons-1
	lac pq
	cal cons
	cal cons-1
	lac (1print
	cal cons
	lio i pdl
	cal cons
	lac t4
	cal cons
	lac (1prog
	cal cons
	lac i t3
	cal cddr
	dio i 100
	idx pdl
tr2,	pop
	cal cdr
	jmp trace

untrac,	sad cn		/"untrace"
	jmp tru
	cal car
	lac i 100
	sza i
	jmp ut2
	cal cddr
	dac t2
	cal cdar
	dac t1
	cal caar
	sas (199g
	jmp ut2
	lac t1
	cal cddr
	cal cadr
	cal cddr
	cal car
	dac i t2
ut2,	lac a1
	cal cdr
	dac a1
	jmp untrac

constants
                
                                
.+.^1/
frs,
and=and2

equals put,if2
equals pname,if2
equals su,if2
equals fsu,if2
equals apval,if2
equals thing,if2

define s name,num,g
g,jmp ixnum name
1subr
kill g
terminate

define f name,g
g,jmp name
1fsubr
kill g
terminate

here
and=i i
fr2,
equals n1,if2
equals n2,if2
equals n3,if2
equals q,if2
start
                
                                                                                                                                                                                                                                          

