
Mag tape doctor

l=1	r=0	nsy=151

define	oper a, b
	zz1=a-lis+44
	zz2=b-lis+44
	2000Xzz2+2Xzz1
	termin

define	disp a
	oper a, a
	termin

define	letter a, b
	oper a+lis-44, b
	termin

syt=.-1

lis,	llr bki		|entry point
bk1,	slr chc		|restore break instr

lse,	tsx lcr
lss,	clc
	sto chi
	stz wrd
pl1,	llr eql		|lac
lsq,	slr sgn
lsp,	stz num
	stz dnm
lst,	stz sym l
	stz sym r
	stz fsm
	stz chc
	stz let

lsr,	move ptc, ta7
	init srw, msk
	cal 1

ls1,	lcc
	trn ls1
	ldx six
	cyl
	tix .-1
	axr
	lax dtb+177
	ldx cas
	cyr
	tix .-1
	cll+alr-opr
	add m44
	trn ln
	add tls
	sto lsx
	add (-tra-lnr
	trn lsy

	llr num
	lda let
	tze sgn
	tsx es
	tze sgn
	lda (flex U	|undefined
erp,	tsx p3
	tra ptb

sgn,	xx		|lac or lcc
	add wrd
	sto wrd
lsy,	ldx cc
cc,	lda chi
	llr lwt
	trn .+3
	llr wrd
	ldx crs
lsx,	xx		|exit to routines

uc,	lda elv
lc,	sto cas
	tra lsr

err,	lda (flex X
	tsx p3
	tra lsr		|ignored

del,	lda (flex x
	tra erp

dot,	lda chc
	tze do1
	move dnm, num
	tra lsr

do1,	lda baa
	tra lsd

quo,	lda fsm
	tra lsd

kil,	load est, syb
	tra lse

rad,	lda (vsf-opn
oad,	add opc
	sto asw
	tra lse

cns,	lda (opt-vs1
ins,	add (tra vs1
	sto pt
	tra lse

dnp,	add six
onp,	add (add odv+5
	sto rdx
	tra lse

imp,	ldx lwt
	tra .+2

cma,	ldx baa
	stz org
	sxa org
rp,	lda let		|define symbol
	tze err
	ldx pix

dfs,	sxa dfx
	tsx es
	llr org
	tze df1
	ldx est		|not def
	aux mtw
	lda sym r
	stx 0
	slx 1
	lda sym l
	tze df2
	tix .+1
	add tn
	stx 0
df2,	sxa est
dfx,	tra .

df1,	slx syt+1
lnr,	tra dfx		|last no-eval routine

alm,	add one		|a, l, x, f, m logic
	add one
	add one
	add one
	add (ac
lsd,	sto num
	sto dnm
lsi,	stz chi
	tra lst

ta,	slx 0		|tab
	lxr
	sxa baa
ta3,	tsx lcr
	lda baa
	tsx opa		|print addr
	lda hcn
	pno
	ldx baa

ta6,	sxa crs		|open register
	llx 0
	tsx lcts
ta7,	xx		|tsx pt, opt, or vs1
ptb,	ldx cr1
	tra lct

fs,	lda mtw		|forward space
	add baa
	sto baa
	lda chi

bs,	trn .+2		|backspace
	slx 0
	ado baa
	tra ta3

lp,	add (opt-vs1
sls,	add pic
	sto ta7
	lda chi

bar,	lxr
	trn ta6
	stz baa
	sxa baa
	tra ta6

cr,	trn .+2
crs,	slr chi		|addr of reg open
	slr lwt
	ldx cc
	sxa crs
	lda (111101
	tsx p3
cr1,	tra lss

up6,	ldx (tb1		|mag or parer tape setup
	llr (tra magrb
	lda (tra magrb
	tra 6and9

up9,	ldx (rbk
	llr (sxa rbx
	lda (r3cUcom

6and9,	sxa tb1-1
	sto soi
	slr rbk
	tra lse

pls,	tra pl1

min,	llr ls1		|minus
	tra lsq

q,	lda lwt
	tra lsd

sor,	slr org
	slr lwt
	tra lss

bk,	trn ebk		|breakpoint
	slr lwt
bk3,	lxr
	sxa bk1
	tra lse

ebk,	llr cc
	tra bk3

pr,	orl		|set proceed count
pra,	lda prc		|get instr to execute
	sto bix

pr1,	lcc
	add one
	sto chi
	tsx lcr
	ldx bk1
	llx 0		|set breakpoint
	slr bki
	llr (tra tr
	slx 0
	llr lr
	ldx xr

pr2,	lda ac
bix,	tra err
prc,	tra err

xec,	slr xe1		|execute
	llr .-1

beg,	trn err		|go to
	lda .+4
	sto bix
	lxr+lro-opr
	sxa bix
	tra pr1

pfl,	tsx lcts		|print as flexo
	tsx p3
	tra ptb

nws,	llr cm
	tra ser+1

eas,	init srw, msa

ser,	llr nop
	trn err		|word search
	slr srs
	tsx lcr
	lda ll
	sto adr
	tra .+1
sr3,	tsx asq
rtn,	trn lse
	llr wrd
	lax 0
	lpd
srw,	llr		|msk or msa
	ana
	trn .+2
	tze srs
	clc
srs,	xx		|com or nop
	trn sr3
	tsx pac
	tsx lcr
	tra sr3

hed,	tsx lcr		|title punch
	tsx fee

he1,	lro 1
	lcc
	trn .-1
	lal
	ldx six
	cyl
	tix .-1
nop,	axr
	lax ftp-200
	sto chi
	trn chi
	p6h
	p6o
	lax ftp-177
	p6h
	p6h
	p6o
	p6s
	tra he1

p1r,	trn .+2
	slx 0
	llr crs
	slr org
	cla

pun,	trn err		|punch binary blocks
	ldx rtn
pu1,	sxa pu2
	lda msa
	anc
	sto wrd
	lda org
	llr msa
	ana+lro-opr
	sto org
pu3,	add wrd
	com
pu2,	trn .		|exit
	lda c77
	orc
	sto let
	llr wrd
	lcd
	trn psw
	slr let		|last block
psw,	tra pbf		|or pri

jbk,	trn err		|start block
	tsx fee
	lda wrd
	add cad
	tsx p3c
	tsx fee
fer,	ldx rtn

fee,	sxa fex
	ldx c33
	p6s 200
	tix .-1
fex,	tra .

rd,	tsx soi		|read
rdl,	tsx gwd
	tsx asq
	trn rdl
	slx 0
	tra rdl

vfy,	tsx lcr		|verify
	tsx soi
vfl,	tsx gwd
	tsx asq
	trn vfl
	lax 0
	lpd
	trn .+2
	tze vfl
	tsx pac
	tsx lct
	ldx gwg
	lax 0
ptc,	tsx pt
	tsx lcr
	tra vfl

tbl,	lda msa		|table
	anc+lro-opr
	slr chc		|+
	sto wrd		|-
	tsx soi
	tsx rbk

tb1,	tsx gwd
	slr sym l
	tsx gwd
	slr sym r
	lac
	tze tbs
	tsx gwd
	slr org
	lda sym l
	llr mopr
	anp 40
	trn tb1
	cyl
	trn tb3
	tra tb1

zro,	move ll, chc
	move ul, let
	ldx (17755
	lro
	trn .+3
	llr org
	ldx wrd
	slr ll
	slr adr
	sxa ul
	lro
zr1,	tsx asq
	trn zr2
	slx 0
	tra zr1

zr2,	move chc, ll
	move let, ul
	tra lse

pi,	ldx sls		|print as instr
lcts,	slr lwt
lct,	lda (100101+222202
	tra p3

pic,	tsx vs1
pix,	tra ptb

eql,	lac		|equal sign
	ldx pix		|last addressable routine

opt,	sxa opx
	sto lwt
opn,	com
	sto tem
	llr (tze dvs
	lda m5
	sto chi
	slr dvt

dvl,	add rdx
	sto dv1
	sto dv2
	ldx one
	lda tem

dvv,	aux mon
	trn dv3
dv1,	xx
	tra dvv

dv3,	sto tem
dv2,	xx
	trn dvv
	xac
	llr nop
dvt,	xx		|tze or nop
	slr dvt
	tsx gch
	pno
dvs,	ado chi
	tze dvl-1
	trn dvl
opx,	tra .

odv,	100000
	10000
cxs,	1000
hun,	100
	10
	1

ddv,	100000.
	10000.
	1000.
	100.
	10.
	1.

tb3,	slr sym l	|more table
	lda sym r
	llr mopr
	anp 40
	slr sym r
	trn tb2
	cyl
	llr chc
	trn .+2
	llr wrd
	lac
	add org
	sto org
tb2,	tsx dfs
	tra tb1

tbs,	tsx lct
	lda est
	tsx opt
	tsx rbk		|skip rest of tape
	tra .-1

gwd,	sxa gwx
gw2,	ldx fsm
	tix gw1
	tsx rbk
	tra gw2

gw1,	sxa fsm
	ado gwg
gwg,	llr
gwx,	tra .

asq,	sxa asx		|address sequencer
	aux mtw
	sxa asy		|ng
	ldx adr
	sxa adr2
	ado adr
	xcc
	add est		|bottom of pgm
	trn as1
asd,	xcc
	add ll
	com
	trn asy
	xcc
	add ul
asx,	tra .		|ok

as1,	xcc
	add (ul		|top of pgm
	trn asd
asy,	tra .		|ng

pir,	load org, trn 17756	|punch input routine
	ldx prk
	sxa psw
	tsx fee
	llr msa
	tsx pu1
pi3,	lda (trn 17756
	tsx p3c
	ldx (pbf
pi4,	sxa psw
	tra fer

pi2,	tsx fee
	tra pi3

prs,	ldx prk
	tra pi4

pbf,	stz tem		|punch block format
	tsx p3g
	lda let
	tsx p3c
pb2,	ldx org
	lax 0
	tsx p3c
	ado org
	add let
	trn pb2
	lda tem
	com
	tsx p3c
	tra pr3

pri,	tsx p3g		|punch read-in mode
	ldx org
	lax 0
	tsx p3c
	ado org
	add let
prk,	trn pri

pr3,	ldx m4
	p6s 200
	tix .-1
	lda org
	llr org
	tra pu3

p3g,	lda org
p3c,	p7h		|punch one word
	p7h
	p7h+cyl-cyr
	cyl
	add tem
	sto tem
pxx,	trx 0

ln,	add c33		|letter number logic
	trn n
	sto let

ln1,	stz chi
	ado chc
	add m4
	tze ln2
	add (trn 4-7
	trn lsr
ln4,	lda sym r
	cyl
	cyl
	add sym r
	cyl
	cyl
	cyl
	lad
	add one
	sto sym r
	lda chc
	add (trn-4
	trn lsr
	lcc
	tsx gch
	llr chm
	ano 10
	cyl
	cyl
	add fsm
	cyr
	sto fsm
	tra lsr

ln2,	lda sym r
	sto sym l
	stz sym r
	tra ln4

n,	lda num
	cyl
	cyl
	cyl
	lad
	sto num
	lda dnm
	cyl
	cyl
	add dnm
	cyl
	lad
	sto dnm
	tra ln1

pac,	sxa xe1		|print addr and contents
	lda adr2
	tsx opa
	lda hcn
	tsx p3
	ldx adr2
	lax 0
	ldx xe1

pt,	tra vs1		|print word sw

opa,	sxa opx		|print addr
	sto tem
	sto chi
asw,	tra vsf		|address mode sw

tr,	sto ac		|break trap
	ado chi
	trn pr2
	slr lr
	xac
	sto xr
	lda bk1
	add (lda-slr
	sto pra
	add (tra-lda+1
	sto prc
	lda (flex ac 
	tsx p3
	lda ac
	tsx pt
	tsx lct
	lda (flex lr 
	tsx p3
	lda lr
	tsx pt
	tsx lct
	lda (flex xr 
	tsx p3
	lda xr
	tsx pt
tls,	tra lis

xe1,	0		|execute trap
	sto ac
	slr lr
	xac
	sto xr
	tra lis

es,	sxa esx		|evaluate symbol
	ldx est
	aux (-syt
	llr sym l
esl,	lax syt
	trn esn
	cla
es3,	lcd
	tze es2
esi,	tix .+1
	tix esl
esf,	llx syt+1
esx,	tra .

esn,	tix .+1
	add mtn
	tra es3

es2,	lax syt
cm,	com
	add sym r
	tze esf
	tra esi

vs1,	sxa opx		|print as instr
	sto tem
	sto chi
	llr (760000
	anl+com-opr
	trn vsp
	cyl
	trn vsp
	tra vsf

vsp,	slr chi		|addressable
	tsx vsy
	lda cxs
	pno

vsf,	tsx vsy		|op class or address
	lda cxp
	pno
	lda tem
opc,	tra opn

vsy,	sxa vsx
	move mtn, let
	ldx est
	aux (-syt
ev1,	lax syt
	trn evn
	cla
eva,	sto sym r
	tix .+1
	lax syt
	llr chi
	lpd
	trn ev2
	com+cry-opr
	tze ev3
	trn ev2

	alr+com-opr
	add let
	trn ev2
	slr let
	sxa slo

ev5,	lda sym r
	com
	sto sym l
ev2,	tix ev1

ev4,	ldx slo
	lax syt		|get best value
	com
	add tem
	sto tem
	lax syt-1
	com
	sto sym r
	tsx spt
	lda tem
	tze opx
	sto chi
vsx,	tra .

ev3,	sxa slo
	xro
	tra ev5

evn,	tix .+1
	add mtn
	tra eva

lcr,	lda (101001+222202

p3,	sxa p3x		|print 3 chars
	ldx two
p31,	llr al6s
	anp
	tze p32
	add (-111101
	tze dns
	add hun
	tze ups
	add ucx
	prt
p32,	lar
	tix p31
	lda lwt
p3x,	tra .

ups,	lda cas
	tze .+2
	tra p32
	lda ucx
	pno
	lda elv
up3,	sto cas
	tra p32

dns,	lda cas
	tze p32
	lda lcx
	pno 40
	tra up3

	r3c
soi,	r3c+com-opr
	trn .-2

rbk,	sxa rbx		|read binary block
	init rbs, buf-1
	sxa gwg
	r3c
	alr
	sto adr
	add .
	trn lse
	r3c+lad-opr
	alr+xro-opr
	add mon
	sto fsm

rbl,	ado rbs
	r3c
rbs,	sto
	lad
	alo
	tix rbl
	r3c+lad-opr
rbx,	tze .
	clc
	hlt+alr-opr
	tra rbk+1

magrb,	sxa magrbx	|mag tape read block
	init magrbs,buf-1
	sxa gwg

magnew,	rtb 1
	cpyUlac
	trn mag6o4
	sto adr
	lal
	trn lse
	cpyUlac
	add adr
	axr
	sto chi
	add mon
	sto fsm

magrlp,	ado magrbs
	add (-sto-buf-100+trn
	trn magrbx+1
	cpyUlac

magrbs,	sto .
	add chi
	sto chi
	tix magrlp
	cpyUlad

magrbx,	tze .
	hltUcal+40
	tac
	trn magrb+1
	bsr 1
	tra magrb+1

mag6o4,	cyl
	trn magnew
	tra lse

spt,	sxa spx		|symbol print
	ldx one
spc,	llx sym
	sxa chc
	lda (add spd
	sto spa

spq,	ldx mon
	lac

spr,	alr
spa,	xx		|add spd
	aux one
	trn spr

spp,	xcc
	tze sps
	add one
	tsx gch
	pno
sps,	ado spa
	add (-add-spd-2
	trn spq
	ldx chc
	tix spc
spx,	tra .

spd,	50X50
	50
one,	1

gch,	sxa gcx
	cyrUcom
	axr
	trn gc1
	lax gct
gcx,	tra .

gc1,	lax gct
	cyr
	tra gcx

gct,	text .01 23 45 67 89 ab cd ef gh .
	text .ij kl mn op qr st uv wx yz .
	111001+222202

dtb,	disp del		|delete
	letter 0, dnp	|0
	disp lc		|l. c.
	letter 37, vfy	|v
rdx,	add odv+5
	letter 41, alm+2	|x
	disp uc		|u. c.
	letter 26, alm	|m
ucx,	111001
	letter 9, up9	|9
lcx,	111101
	letter 20, beg	|g
al6s,	666666
	letter 13, bk	|b
	disp i		|stop
	letter 30, oad	|o
cxp,	char r+
	letter 32, q	|q
c33,	33
	letter 31, pr	|p
c77,	77
	letter 42, rd	|y
	disp cr		|car ret
	letter 21, hed	|h
mopr,	-opr
	letter 40, ser	|w
	disp ta		|tab
	letter 25, alm+3	|l
	disp bs		|backsp
	letter 43, zro	|z
cad,	add
	letter 35, tbl	|t
adr2,	0
	letter 24, kil	|k
	oper min, p1r	|-_
	letter 14, cns	|c
	letter 6, up6	|6
	letter 17, alm+1	|f
	oper cma, lp	|,(
	letter 27, nws	|n
	letter 7, i	|7
	letter 23, jbk	|j
	letter 1, quo	|1
	letter 33, rad	|r
	letter 5, i	|5
	letter 15, pun	|d
	oper dot, rp	|.)
	disp lsr		|color

	letter 2, i	|2
	letter 36, xec	|u
	oper pls, sls	|+/
	letter 22, pi	|i
	letter 4, i	|4
	letter 34, ins	|s
	oper eql, sor	|=:
	disp pls		|space
	letter 3, pfl	|3
	letter 12, alm+4	|a
	oper bar, imp	|||
	0
	letter 8, onp	|8
	letter 16, eas	|e
	0
	disp fs		|tf

i=err

ftp,	tra he1	mtw,-2	m44,-44	tn,trn
	313113	701007	212112	343443
msa,	17777	mtn,-trn	chm,111111	000000
	211311	344744	210012	343443
	0	0	003030	007070
	212012	303443	021300	322722
	200002	311113	000300	011711
	111112	444443	210213	344307

	tra he1	six,6	22	elv,11
	311113	344443	313012	703443
	311311	344324	020002	111113
	000012	444443	300000	742111
	131111	445564	two,2	11
	313111	701000	213112	303443
	211112	340043	000300	000700
	111311	421124	sym,0	0

	300000	711111	mon,-1	fsm,0
	300213	742007	tra pi2	let,0
	111113	svn,7	tra prs	chi,0
	111132	445562	slo,-0	chc,0
	111311	444744	tra pir	cas,11
	120000	421111	lwt,0	tem,0
	311311	344300	num,0	dnm,0
	211112	344525	bki,0	baa,0

	211112	344443	232232	272272
	313113	343443	m4,-4	adr,0
	211112	300743	m5,-5	org,0
	211202	344743	0	wrd,0
	131111	465544	130000	260000
	120021	421124	0	hcn,200303
	111220	444231	320000	640000
	211112	344443	333333	777777

constants

ac,	0
lr,	0
xr,	0
est,	syb
msk,	-0
ll,	0
ul,	17777

buf,

define	sqoze a, b, c
	zz=50Xa+b
	50Xzz+c
	termin

lis-nsy-nsy-12|

syb,	sqoze 45, 13, 46		ac
	sqoze 45, 26, 46		lr
	sqoze 45, 42, 46		xr
	sqoze 45, 20, 46		est
	sqoze 45, 27, 46		msk

|Doctor vocabulary

	sqoze 13, 16, 16		add
	sqoze 13, 16, 31		ado
	sqoze 13, 16, 42		adx
	sqoze 13, 26, 15		alc
	sqoze 13, 26, 26		all
	sqoze 13, 26, 31		alo
	sqoze 13, 26, 34		alr
	sqoze 13, 26, 42		alx
	sqoze 13, 27, 44		amz
	sqoze 13, 30, 13		ana
	sqoze 13, 30, 26		anl
	sqoze 13, 30, 31		ano
	sqoze 13, 34, 42		arx
	sqoze 13, 37, 42		aux
	sqoze 13, 42, 15		axc
	sqoze 13, 42, 31		axo
	sqoze 13, 42, 34		axr
	sqoze 14, 35, 34		bsr
	sqoze 15, 13, 26		cal
	sqoze 15, 13, 42		cax
	sqoze 15, 26, 13		cla
	sqoze 15, 26, 15		clc
	sqoze 15, 26, 26		cll
	sqoze 15, 26, 34		clr
	sqoze 15, 31, 27		com
	sqoze 15, 32, 20		cpf
	sqoze 15, 32, 43		cpy
	sqoze 15, 34, 43		cry
	sqoze 15, 43, 26		cyl
	sqoze 15, 43, 34		cyr
	sqoze 16, 23, 35		dis
	sqoze 16, 35, 31		dso
	sqoze 22, 26, 36		hlt
	sqoze 23, 13, 16		iad
	sqoze 23, 13, 26		ial
	sqoze 23, 42, 26		ixl
	sqoze 26, 13, 15		lac
	sqoze 26, 13, 16		lad
	sqoze 26, 13, 26		lal
	sqoze 26, 13, 34		lar
	sqoze 26, 13, 42		lax
	sqoze 26, 13, 44		laz
	sqoze 26, 15, 15		lcc
	sqoze 26, 15, 16		lcd
	sqoze 26, 16, 13		lda
	sqoze 26, 16, 42		ldx
	sqoze 26, 26, 34		llr
	sqoze 26, 26, 42		llx
	sqoze 26, 32, 16		lpd
	sqoze 26, 34, 31		lro
	sqoze 26, 42, 34		lxr

	sqoze 31, 32, 34		opr
	sqoze 31, 34, 13		ora
	sqoze 31, 34, 26		orl
	sqoze 31, 34, 31		oro
	sqoze 32, 7, 14		p6b
	sqoze 32, 7, 22		p6h
	sqoze 32, 7, 31		p6o
	sqoze 32, 7, 35		p6s
	sqoze 32, 10, 22		p7h
	sqoze 32, 10, 31		p7o
	sqoze 32, 17, 30		pen
	sqoze 32, 30, 15		pnc
	sqoze 32, 30, 31		pno
	sqoze 32, 30, 36		pnt
	sqoze 32, 34, 36		prt
	sqoze 34, 2, 15		r1c
	sqoze 34, 2, 34		r1r
	sqoze 34, 4, 15		r3c
	sqoze 34, 13, 42		rax
	sqoze 34, 16, 35		rds
	sqoze 34, 17, 41		rew
	sqoze 34, 32, 20		rpf
	sqoze 34, 36, 14		rtb
	sqoze 34, 36, 16		rtd
	sqoze 34, 42, 13		rxa
	sqoze 35, 22, 34		shr
	sqoze 35, 26, 34		slr
	sqoze 35, 26, 42		slx
	sqoze 35, 32, 20		spf
	sqoze 35, 36, 31		sto
	sqoze 35, 36, 42		stx
	sqoze 35, 36, 44		stz
	sqoze 35, 42, 13		sxa
	sqoze 36, 13, 15		tac
	sqoze 36, 14, 34		tbr
	sqoze 36, 23, 42		tix
	sqoze 36, 26, 40		tlv
	sqoze 36, 32, 26		tpl
	sqoze 36, 34, 13		tra
	sqoze 36, 34, 30		trn
	sqoze 36, 34, 42		trx
	sqoze 36, 35, 42		tsx
	sqoze 36, 43, 32		typ
	sqoze 36, 44, 17		tze
	sqoze 41, 34, 35		wrs
	sqoze 41, 36, 14		wtb
	sqoze 41, 36, 16		wtd
	sqoze 42, 13, 15		xac
	sqoze 42, 13, 16		xad
	sqoze 42, 13, 26		xal
	sqoze 42, 15, 15		xcc
	sqoze 42, 15, 16		xcd
	sqoze 42, 26, 34		xlr
	sqoze 42, 34, 31		xro

lis,

start add lis
0