/pdp-1 fortran part 4

/dss flc fdc fad fsb fmp fdv
/dss bad jps

final=7000
sct=7001
tem=7002
stmnt=7003
tp=7005
dfg=7006
cct=7007
fg1=7010
nct=7011
rp2=7012
fv=7014
fcn=7077
ilist=7244
dolist=7411
buffer=7543


/output a char.
/entry_.	lio char.
/	jda output
supres,	0
a,	0
output,	0
	dap eput
	dio feed
	law 77
	and feed
	dac a	/char. to be output
	law 1
	sas fg1
	jmp rausit
	dzm fg1
	lac jps-1
	sza i
	jmp nojp
	sas stmnt
	jmp dif
	lac jps-2
	sad stmnt+1
	jmp nojp
dif,	law 36
	jda parity
	lac (flexo jmp
	jda d
	cla
	jda parity
	law 2223
	jda d
	lac jps-1
	jda d
	lac jps-2
	jda d
	law 77
	jda parity






                
l                                nojp,	dzm jps-1
	dzm jps-2
	lac stmnt
	sza i
	jmp c
	law 2223
	jda d
	lac stmnt
	jda d
	lac stmnt+1
	jda d
	law 33
	jda d
c,	szf 4
	jmp .+3	/flag 4 on for decal insert
	law 36
	jda parity
rausit,	lac a
	jda parity
	lio feed
	lac output
eput,	jmp 0	/return
e,	0
d,	0
	dap g
	law i 3
	dac e
f,	cla
	lio d
	rcl 6s
	dio d
	sza
	jda parity
	isp e
	jmp f
g,	jmp 0

parity,	0
	dap h
	law 1
	sad supres
	jmp h	/if "supres" is set there is to be no normal output
	law 77
	and parity
	szs i 30
	jmp .+5
	sas del+13	/if sw.3 is on suppress redundant carriage returns
	jmp .+3
	sad lstc
	jmp h
	dac lstc
	dap pab
	ior (673000
	dac paa
	law 2525
paa,	0
pab,	law 0
	spi i
	ior (200
	rcr 9s






                
_                                	rcr 9s
	jsp ppago
h,	jmp 0
lstc,	0






























































                
>>14<<                                
/feed blank tape
feed,	0
	dap exit
	cli
	jsp ppago
	isp feed
	jmp .-2
exit,	jmp 0

	0
ppago,	dap exit
	dio ppago-1
	cks
	ril 4s
	spi i
	jmp .-3
	lio ppago-1
	ppa
exit,	jmp 0

del,	77
	77
	77
	77
	77
	77
	777720	/[  left bracket
	777722	/]  right bracket
	777723	/+  plus
	777744	/=  equals
	777704	/x  multiply
	77	/   carriage return
	77
	77
	57	/(  left paren.
	55	/)  right paren.
	54	/-  minus
	33	/,  comma
	73	/.  dec.point
	21	//  divide


/check for a delimiter
delim,	0
	dap exit
	law i 20.
	dac stemp
	law del
	dac tem
b,	lac delim
	sad i tem
	jmp c
	idx tem
	isp stemp
	jmp b
	jmp exit
c,	idx exit
exit,	jmp 0	/returns to +1 if a delimiter







                
s                                
/buffer in paper tape
sw,	0
buf,	dap exit
	lac sw
	sza i
	jmp fillit
	idx wh
	sad endb
	jmp fillit
pick,	lac i wh
exit,	jmp 0
b,	.+40./
endb,	endb
wh,	0
fillit,	law b
	dac wh
	dac sw
a,	rpa
	dio i wh
	lac i wh
	sza i
	jmp a	/ignore blank tape
	sad (13
	jmp aa
	rar 7s	/check for delete (level 7 punched)
	spa
	jmp a	/ignore tape with 7th level punched
	lac i wh
	ior (671000
	dac .+2
	law 2525
	0
	sma
	jmp parng
bb,	idx wh
	sas endb
	jmp a
aa,	law b
	dac wh
	jmp pick
/parity error found
/type out "fpe" and stop program (no go)
parng,	law fpe
	jda ttext
	cla>>05<<cma>>05<<cli>>05<<stf 7
	jmp .-1
fpe,	text /
fpe
/
















                
-                                
/punch out a number with no leading zeros
numb,	0
	dap b-1
	clf 6
	law i 6.
	dac stemp
a,	cla
	lio numb
	rcl 3s
	dio numb
	sza i
	jmp b
	dac tem
	stf 6
	lio tem
	jda output
c,	isp stemp
	jmp a
	jmp 0
b,	szf 6
	jmp d
	law i 1
	sas stemp
	jmp c
d,	lio (20
	jmp c-1

/type c/r
typcr,	dap .+3
	lio del+13	/c/r
	tyo
	jmp 0

/check for 3 numeric char.
number,	0
	dap b
	law i 3
	dac stemp
a,	cla
	lio number
	rcl 6s
	dio number
	jda digit
	jmp b
	isp stemp
	jmp a
	idx b
b,	jmp 0	/returns to +1 if a number

















                
>>76<<                                
/check for digit in right 6 bits of AC  (00 is a digit)
digit,	0
	dap exit
	lac digit
	sad (20
	jmp a
	sub (10.
	spa
a,	idx exit
exit,	jmp 0	/returns to +1 if a digit

/check for a fixed point variable name
fixed,	0
	dap b+1
	law i 3
	dac stemp
a,	cla
	lio fixed
	rcl 6s
	dio fixed
	sza i
	jmp c	/ignore spaces
	sad (flexo   i
	jmp b
	sad (flexo   j
	jmp b
	sad (flexo   k
	jmp b
	sad (flexo   l
	jmp b
	sad (flexo   m
	jmp b
	sad (flexo   n
	jmp b
	jda digit	/if a digit name of variable is illegal
	jmp b+1
	law 46.
	jmp bad	/name begins with digit
b,	idx .+1
	jmp 0
c,	isp stemp
	jmp a
	jmp b+1	/if word is zero make a normal return






















                
/                                
stemp,	0

/floating constants
fltcon,	dap exit
	law i 1	/backup rp2 to first digits
	add rp2
	dac rp2
	lac i rp2
	jda number
	jmp .+2
	jmp fltcon+1
	idx rp2
	dac addr	/save addr. of first digits
	dzm w1
	dzm w1+1
	dzm w2
	dzm w2+1
	jsp convert
	dac w1
	dio w1+1
	idx addr	/skip over dec. pt.
	jsp convert
	dac w2
	dio w2+1
	lac cntr
	cma
	dac cntr
	jsp flc
	d1
frlp,	jsp fmp
	d10
	jsp fdc
	ftemp
	isp cntr
	jmp frlp
	jsp flc
	w2
	jsp fdv
	ftemp
	jsp fad
	w1
	jsp fdc
	w1
	lac word2	/check for e, as in a=12.34e6
	sza i
	jmp eno
lky,	lio d1+1	/force a dummy exp. into flt.pt. zero
	lac w1
	sza i
	dio w1+1
	law fcn
	dac tempo
	lac fcn-1
	dac cntr
search,	lac w1
	sad i tempo
	jmp fnd
	idx tempo
idxsrch,	idx tempo






                
t                                	sad nct
	jmp .+3
	isp cntr
	jmp se>>60<<rch
/not on list, add it
	isp cct
	jmp strit
	law 12.	/error 12 = too many flt. const.
	jmp bad
fnd,	lac tempo
	dac addr
	idx tempo
	lac i tempo
	sas w1+1
	jmp idxsrch
	jmp onlist
strit,	lac nct
	dac addr
	lac w1
	dac i nct
	idx nct
	lac w1+1
	dac i nct
	idx nct
onlist,	law 14
	dac i rp2
	idx rp2
	law fcn-1
	sub addr
	cma
	add (1
	sar 1s	/divide by 2
	dac i rp2
step,	idx rp2
	lac i rp2
	sad (73	/dec. pt.
	jmp .+3
	jda number
	jmp .+3
	dzm i rp2
	jmp step
	lac rp2
exit,	jmp 0

addr,	0
cntr,	0
tempo,	0
	0
c3,	0
tp2,	0
save,	0
	0
w1,	0
	0
w2,	0
	0
ftemp,	0
	0
d1,	200000
	002000






                
	                                d10,	240000
	010000

out,	lac tempo+1
	sad (flexo   e
	dzm word2
	lac save
	lio save+1
exit2,	jmp 0

convert,	dap exit2
	law i 1
	dac word2
	dzm save
	dzm save+1
	dzm cntr
back,	lac i addr
	dac store
	law i 3
	dac c3
octloop,	cla
	lio store
	rcl 6s
	dio store
	dac tempo+1
	jda digit
	jmp out
	lac tempo+1
	sza i
	jmp nxtdig
	sad (20
	cla
	cli
	jda float
	17.
	dac tempo
	dio tempo+1
	lac save
	sza
	jmp useit
	lac save+1
	sza
	jmp useit
	lac tempo
	dac save
	lac tempo+1
	dac save+1
	jmp idxit
useit,	jsp flc
	save
	jsp fmp
	d10
	jsp fad
	tempo
	jsp fdc
	save
idxit,	idx cntr
	sub (10.
	sma>>05<<sza
	jmp e42






                
w                                nxtdig,	isp c3
	jmp octloop
	idx addr
	jmp back
e42,	law 42.	/error 42 = over 10 digits
	jmp bad
eno,	dzm scratch
	law i 0
	dac ftemp
	law i 1
	sad c3
	jmp .+4
	lac store
	dac i addr
	jmp eny
	dzm i addr
	idx addr
	lac i addr
	sas del+20	/-
	jmp .+4
	dzm ftemp
	dzm i addr
	idx addr
eny,	law i 3
	dac c3
	lac i addr
	dac store
en1,	cla
	lio store
	rcl 6s
	dio store
	sza i
	jmp enx
	sad (20
	cla
	dac ftemp+1
	jda digit
	jmp enn	/no more digits
	lac scratch
	sal 2s
	add scratch
	sal 1s
	add ftemp+1
	dac scratch
enx,	isp c3
	jmp en1
	idx addr
	jmp eny

enn,	lac scratch
	sza i
	jmp lky
	cma
	dac scratch
en2,	jsp flc
	w1
	lac ftemp
	sma
	jmp dit
	jsp fmp






                
                                 	d10
	jmp en3
dit,	jsp fdv
	d10
en3,	jsp fdc
	w1
	isp scratch
	jmp en2
	jmp lky

























































                
>>12<<                                
/entry_.	,sign,34,sign number in AC-IO
/	jda float
/	..K	/binary scale factor, i.e., b17 would be  dec 17 or oct 21
/	,return - 8/28 flt.pt. number in AC-IO

/subroutine does not use the flt.pt. package (flip)

/exponent(8/28) = scale factor- no.shifts to normalize  b17-15shifts=exp.2

float,flt,	0
	dap exit
	lac i exit
	dac ea
	idx exit
	dio ap
	lac flt
	spa
	error 6	/halt - negative number - compiler error
	law i 1
	and ap
	dac ap
	cla
	sas flt
	jmp .+3
	sad ap	/zero number
	jmp zero
	lio ap
loop,	lac flt
	rcl 1s
	spa
	jmp .+6
	dac flt
	law i 1
	add ea
	dac ea
	jmp loop
	rcr 1s
	dac flt
	jmp .+2
zero,	lio ap
	lac ea
	scr 8s
	lac flt
exit,	jmp 0
ea,	0
ap,	0



















                
-                                
setit,	dap .+5
	law i 3
	dac tp
	lac i define
	dac store1
	jmp 0

scratch,	0
scratch1,	0
store,	0
store1,	0
word2,	0
strw2,	0
lpx,	0
fvc,	0
fvn,	0
ict,	0
inxt,	0

define,	0
	dap return
	dzm scratch1
	law scratch
	dac store
	jsp setit
	law i 2
	dac lpx
reset,	dzm i store
	law i 3
	dac word2
	jsp nxtc	/get a char.
	rcr 6s
	lac i store
	rcl 6s
	dac i store
	isp word2
	jmp reset+3
	idx store
	isp lpx
	jmp reset
	jsp nxtc	/6 char. are packed
	law 33.	/error 33 = var. name too long
	jmp bad


nxtc,	dap extc
	lac store1
	dzm feed
	lio (1
	sad del+16
	dio feed	/temp. flag to indicate subsc. var.
a0,	cla
	lio store1
	rcl 6s
	dio store1
	sza
	jmp valid
	isp tp
	jmp a0






                
                                	idx define
	jsp setit
	jmp nxtc+1

valid,	dac strw2
	jda delim
	jmp .+2
	jmp .+3
	lac strw2
extc,	jmp 0
	law i 3
	dac rp2
	dac tp
	law 77
	and scratch
	sza
	jmp a
	lac scratch
	rar 6s
	dac scratch
	isp tp
	jmp .-10
a,	law i 7777	/mask = 770000
	and scratch1
	sza
	jmp b
	lac scratch1
	ral 6s
	dac scratch1
	isp rp2
	jmp a
b,	law i 6
	dac tp
	law i 7777	/mask = 770000
	and scratch
	lio scratch1
	sza
	jmp c
	lac scratch
	rcl 6s
	dac scratch
	dio scratch1
	isp tp
	jmp b+2
c,	lac scratch	/does name end in f
	lio scratch1
	jmp .+2
b2,	lac rp2
	rcr 6s
	dac rp2
	and (770000
	sza i
	jmp b2
	sas (flexo f  
	jmp c2
	law 36.	/error 36 = var. name ends with f
	jmp bad

/look up on ilist
c2,	lac (1






                
q                                	dac define
	lac scratch
	jda fixed
	dzm define
/if name being defined is flt.pt. "define" is zero, if fixed pt. "define" contains 1 (one)
	law ilist
	dac word2
	lac ilist-1
	dac tp
r9,	lac scratch
	sad i word2
	jmp fnd
	idx word2
d,	idx word2
	sad inxt
	jmp .+3
	isp tp
	jmp r9
/not on ilist, is it on fv
	law fv
	dac word2
	lac fv-1
	dac tp
l1,	lac scratch
	sad i word2
	jmp l4
	idx word2
l2,	idx word2
	sad fvn
	jmp .+3
	isp tp
	jmp l1
/not on ilist or fv
	law 1
	sad feed
	jmp adf	/add to fv
	isp ict	/add to ilist
	jmp .+3
	law 34.	/error 34 = too many unsubsc. var.
	jmp bad

	lac scratch
	dac i inxt
	idx inxt
	lac scratch1
	dac i inxt
	idx inxt
	jmp return

fnd,	idx word2
	lac i word2
	sas scratch1
	jmp d
	law 1
	sas feed
return,	jmp 0
	law 37.	/error 37 = subsc. var. found on ilist
	jmp bad

l4,	idx word2






                
g                                	lac i word2
	sas scratch1
	jmp l2
	law 1	/is on fv
	sad feed
	jmp return
	law 38.	/undimensioned var. found with subsc.
	jmp bad

adf,	sad dfg
	jmp .+3
	law 39.	/subsc. var. has not been dimensioned
	jmp bad
	isp fvc
	jmp .+3
	law 40.	/too many dimensioned var.
	jmp bad
	lac scratch
	dac i fvn
	idx fvn
	lac scratch1
	dac i fvn
	idx fvn
	jmp return










































                
>>16<<                                
punch,	jda output
/dec. output
typflg,	0
bindec,	0
	dap exit
	law 1
	lio (730003
	sas typflg
	lio punch
	dio it
	lac (100000.
	dac t1
	law dtb
	dac ptr
	lac bindec
	sza i
	jmp zero
	jmp .+2
aa,	lac i ptr
	scr 9s
	scr 8s
	div t1
	hlt
	dac i ptr
	idx ptr
	dio i ptr
	lac t1
	sad (10.
	jmp cc
	scr 9s
	scr 8s
	div (10.
	hlt
	dac t1
	jmp aa
cc,	law dtb-1	/skip leading zeros and output
	dac ptr
dd,	idx ptr
	lac i ptr
	sza i
	jmp dd
ee,	lac i ptr
	sza i
z,	law 20
	rcr 9s
	rcr 9s
	xct it
	idx ptr
	sas tbc
	jmp ee
exit,	jmp 0
zero,	lio z
	xct it
	jmp exit
ptr,	0
t1,	0
it,	0
dtb,	.+7/
tbc,	.-1






                
d                                
/type out 3 alphas from the AC
message,	0
	dap a
	lac (730003
	dac crash
	lac message
	jda alpha
	lac punch
	dac crash
a,	jmp 0

/punch out 3 alphas from the AC
alpha,	0
	dap c
	law i 3
	dac sct
	lac alpha
	and (777700
	sas (777700
	jmp .+6
	lac alpha
	cma
	ral 6s
	ior (740072
	dac alpha
d,	cla
	lio alpha
	rcl 6s
	dio alpha
	sza i
	jmp crash+1
	sad (13
	jmp c
	sad (76
	jmp crash+1
	rcr 9s
	rcr 9s
crash,	jda output
	isp sct
	jmp d
c,	jmp 0
























                
z                                
/punch out text packed with text /  /
/entry_.	law text
/	jda ptext
ptext,	0
	dap a
c,	lac i ptext
	dac tem
	law i 3
	dac sct
b,	cla
	lio tem
	rcl 6s
	dio tem
	sad (13
a,	jmp 0
	rcr 9s
	rcr 9s
d,	jda output
	isp sct
	jmp b
	idx ptext
	jmp c
/type out text
ttext,	0
	dap e
	lac (730003
	dac d
	lac ttext
	jda ptext
	lac punch
	dac d
e,	jmp 0

txt,	dap exit
	law i 400.
	jda feed
	law gomsg
	jda ptext
exit,	jmp 0

gomsg,	text /
/dss xf ff dff cff dof f1f f2f f3f f4f f5f f6f arf i1f i2f
/dss rdf wrf tif tof fdf eff prf eof
mainprog,	lac laf
	jda arf
/



















                
v