|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 69888 (0x11100)
Types: TextFile
Names: »ftnpass33tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »ftnpass33tx «
; rc4tran pass 3 ret 3.1.78
; rc4tran pass 3 ret 10.7.70
; rc4tran pass3 ret 30.6.70
; rc4tran pass 3 ret 11.6.70
; rc4tran pass3 ret 29-5 70
; rc4tran pass 3 ret 6-5-70
; rc4tran pass3 ret 21-4-70
; rc4tran pass 3 ret 13-4-70
; rc4tran ret 6-4-70
;rc4tran pass3 26.11.69
; rc4000 fortran pass3 start side
s. a500
k= e0
w. i.
pass3lng ; length of pass 3
h.
inpa3, 3<1 ; entry, pass no no direction change
; definition of bases and symbols for
; input bytes
ib1 = 42
ib2 = 43
ib3 = 44
ib4 = 45
ib5 = 46
ib6 = 47
ib7 = 48
ib8 = 50
ib9 = 51
ib10 = 52
ib11 = 54
ib12 = 55
ib13 = 104
ib14 = 106
ib15 = 107
ib16 = 512
endfori= ib13
confori= ib13+ 1
commai = ib11
cpconsi= ib7 + 1
dbconsi= ib7
begforci= ib12+ 47
begforoi= ib12+ 48
equi = ib12+2
functi = ib12+ 32
endstmi= ib12+17
enduni=ib1+0
iconsi= ib4
identi = ib16
inconsi= ib4
logicali= ib12+34
leftpi = ib8
lnconsi = ib5
lgconsi = ib3
minusi= ib10+ 1
plusi= ib10
\f
;rc4000 fortran ,pass 3 definitions side 2
; definition of symbols for input bytes
rightpi = ib9
rghtpi= rightpi
reconsi = ib6
slashi = ib12+1
stari = ib12
toi = ib12+19
; symbols for input classes
docl= 19
identcl= 11 ; identificr
constcl= 2 ; constant
goasscl= 15 ; goto assigned
speclim= identcl+ 1 ; limit for special stm types
gcomcl = 14 ; goto computed
arifcl = 16 ; aritm if
rparcl= 10
logifcl= 16 ; logical if
stmbase= identcl ; start of class values
; for key bytes
identlim= 512 ; limit for ident byte values
\f
;rc4000 fortran ,pass 3 definitions side 3
; definition of bases for output byte
;values
ob1 = 1
ob2 = ob1+9
ob3 = ob2+6
ob4 = ob3+3
ob5 = ob4+5
ob6 = ob5+8
ob7 = ob6+2
ob8 = ob7+3
ob9 = ob8+5
ob10= ob9+3
ob11= ob10+9
ob12= 60
ob13= ob12+8
ob14= ob13+2
ob15= ob14+9
ob16= ob15+9
ob17= ob16+2
ob18= ob17+4
ob19= ob18+6
ob20= ob19+2
ob21= ob20+1
ob22= ob21+3
ob23= ob22+7
ob24= ob23+2
ob25= ob24+6
ob26= ob25+1
\f
;rc4000 fortran, pass 3 definitions side 4
;definition of symbols for output bytes
; and related symbols
ariteq = ob17
program=ob1+6
bndleft = ob5
bndrght = ob5+1
blcom= 511
common = ob4+1
call = ob9+2
declabel= ob10+8
doterm = ob23+0
doterror= ob23+1
doeq = ob17+2
doinit = ob15
dyadic = 0
dyaminus = ob12+ 2
dostepc = ob15+6
datacon = ob16+1
datastar= ob16
data = ob7+1
endlogif= ob26+ 5
endcall= ob24+ 1
endata= ob26+ 6
endequiv= ob6+1
endecl = ob6
endstyp= ob26
endstm = ob8+4
eqlsleft= ob9
eqlsrght= ob9+1
equival = ob4
formlab= ob10+7
endifex = ob25
errorbas = e84- 1
; create error code base for following passes
extident= ob11+2
genform= ob11+ 0
giveupsf= ob5+7
implrea= ob3+1
icons = ob10+1
impinit= ob14
impstepc= ob14+6
implabel= ob3+2
\f
;rc4000 fortran ,pass 3 definitions side 5
; definition of symbols for output bytes
listcom = ob13
listleft = ob9
listrght = ob9+1
logfnc = ob1
logical= ob2
monadic = 1
nzspec = ob5+4
prepass= ob17+ 3
psfleft = ob5+5
psfrght = ob5+6
return= ob7+ 2
subrout= ob1+ 7
stop= ob22+ 4
spark= ob24+ 2
stmlab = ob10+6
trouble = ob11+3
vanopnd= ob26
zoneleft = ob5+2
zonerght = ob5+3
aritleft = ob24
aritrght = ob24+3
iorght = ob24+4
imprght = ob24+5
iocom = ob13+ 1
nbyt= 0
inexp= 1
inexpim= 2
inliva= 3
inlico= 4
inlibo= 5
qqq= 1<11
esm= 3<10
\f
;rc4000 fortran , pass 3 main control table (mct) side 1
; state ,input , ibyte ,new state, action , obyte
mbas:
enx1: ent1 = enx1 - mbas ; program / entry
qqq+nbyt , identi , entx , prgra , 0
enx2: ent2 = enx2-mbas ; subroutine ,function
qqq+nbyt , identi ,ent2+5 , subra , 0
;+5
esm+nbyt , leftpi ,ent2+10 , empa , 0 ; exp leftp or es
;+10
qqq+inliva , rightpi,entx , empa , 0 ; formal list
enx3: ent3 = enx3 - mbas ; type
qqq+nbyt , functi , ent2 , funca , logfnc ; type function
identi , ent3+9 , type2a , 0 ; type list
;+9
esm+inliva, leftpi ,ent3+14 , outa , bndleft ; bound left
;+14
qqq+inlibo, rightpi,ent3+19 , type3a , bndrght ; bound right
; +19
esm+ nbyt, commai, ent3+9, empa, 0
enx4: ent4 = enx4 - mbas ; common
qqq+nbyt , slashi , ent4+9 , empa , 0 ; / before co name
identi , ent4+23 , blank1a, 0 ; slashes omitted
;state , input ibyte , new stat, action ,obyte ,
;+9
qqq+nbyt, slashi , ent4+23 , blanka , 0 ; // for blank c
identi , ent4+18 , outbta , 0 ; com name
;+18
qqq+nbyt, slashi , ent4+23 , empa , 0 ; / after co name
;+23
esm+inliva,slashi,ent4+9 , outa , common ; com name
leftpi , ent4+32 , outa , bndleft ; bound lft in com
;+32
qqq+inlico,rightpi, ent4+37 , outa , bndrght ; bound right in com
;+37
esm+nbyt ,commai , ent4+23 , empa , 0 ; comma or es
slashi , ent4+9 , outa , common ; new 1 for co name
enx5: ent5 = enx5-mbas ; dimension
qqq+nbyt ,identi , ent5+5 , outbta , 0 ; dimens name
;+5
qqq+nbyt ,leftpi , ent5+10 , outa , bndleft ; bound left
;+10
qqq+inlibo,rightpi, ent5+15 , outa , bndrght ; bound right
;+15
esm+nbyt , commai, ent5 , empa , 0 ; comma or es
\f
;rc4000 fortran , pass 3 main control table (mct) side 3
;state , input , ibyte ,new stat ,action , obyte
enx6: ent6 =enx6-mbas ; zone
qqq+nbyt , identi ,ent6+5 , outbta, 0 ; zone name
;+5
qqq+nbyt , leftpi ,ent6+18 , outa , zoneleft ; leftp in zone decl
commai ,ent6 , outa , nzspec ; zone specification
endstmi , 0 , zspeca, nzspec
;+18
qqq+nbyt , iconsi , ent6+23 , cskipa, 0 ; bufsize,skip comma
;+23
qqq+nbyt , iconsi , ent6+28 ,cskipa , 0 ; shares , skip comma
;+28
qqq+nbyt , identi , ent6+33 , outbta, 0 ; blockproc
;+33
qqq+nbyt , rightpi , ent6+38 , outa ,zonerght ; rightp in zone decl
;+38
esm+nbyt , commai , ent6 , empa , 0 ; comma or es
enx7: ent7 = enx7 - mbas ; external
qqq+inliva, endstmi , 0 , esacta, 0 ; variable list es
\f
;rc4000 fortran ,pass 3 main control table (mct) side 4
enx8: ent8 = enx8 - mbas ; enquivalence
qqq+nbyt ,leftpi ,ent8+5 , empa , 0 ; equivalence leftp
;+5
qqq+inliva,rightpi,ent8+28, empa, 0 ; end of eq - group
leftpi ,ent8+14 , outa , eqlsleft ; list left in equival
;+14
qqq+inlico ,rightpi,ent8+19, outa ,eqlsrght ; list right in equival
;+19
qqq+nbyt ,commai ,ent8+5 , empa , 0 ; comma in eq - equival
rightpi,ent8+28, empa , 0 ; end of eq-group
;+28
esm+nbyt ,commai , ent8 , outa ,equival ; equial comma
enx9: ent9 = enx9 - mbas ; data
qqq+inliva, slashi ,ent9+23, data1a,datacon ; / after, var list
leftpi ,ent9+9 , listlea, 0 ; listleft in data
;+9
qqq+ nbyt, iconsi, ent9+ 83, outca, 0 ; subscript constant
;+14
qqq+nbyt , commai , ent9 , empa , 0 ; comma in var list
slashi , ent9+23, data1a, datacon ; /after var list
\f
;rc4000 fortran , pass 3 main control table (mct) side 5
;+23
qqq+nbyt ,lgconsi ,ent9+56 , outca , 0 ; data constant
inconsi ,ent9+65 , outca , 0 ; may be repeat fact
lnconsi ,ent9+56 , outca , 0 ;
reconsi ,ent9+56 , outca , 0
dbconsi ,ent9+56 , outca , 0
cpconsi ,ent9+56 , outca , 0
plusi, ent9+ 23, signpa, 0 ; monadic +
minusi, ent9+ 23, signma, dyaminus ; monadic -
;+56
qqq+nbyt ,commai ,ent9+23 , data2a , 0 ; comma in const list
slashi ,ent9+78 , outa , endata ; / after const list
;+65
qqq+nbyt ,commai ,ent9+23 ,data2a , 0 ; comma in const list
slashi ,ent9+78 , outa , endata ; / after const list
stari ,ent9+23 , data3a ,datastar; repeat star
;+78
esm+nbyt,commai ,ent9 , outa , data ; more data groups
; +83
qqq+ nbyt, commai, ent9+ 9,listcoa, 0 ; list comma
rightpi, ent9+ 14, listrga, 0 ; list right
enx10: ent10= enx10- mbas ; format
qqq+ nbyt, confori, ent10, confora, 0 ; continue format
endfori, entx, confora, 0 ; end form
enx20: ent20 = enx20 - mbas ; ident
qqq+ inexp, equi, ent20+ 5, ariteqa, 0
esm+ inexp, equi, ent20+ 5 , ariteqa, ariteq ;esm or mult assign
enx21: ent21 = enx21 - mbas ; assign
qqq+nbyt , iconsi , ent21+5, outlaba , stmlab ; statem label
;+5
qqq+nbyt , toi , ent21+10, outbta , 0 ; to
;+10
qqq+nbyt , identi , entx , implaba , implabel ; label variable
\f
;rc4000 fortran ,pass 3 main control table (mct) side 6
enx22: ent22 = enx22 - mbas ; goto
qqq+nbyt ,iconsi ,entx ,outlaba, stmlab ; simple goto
identi ,ent22+ 32 ,gasa , implabel ; assigned goto
leftpi ,ent22+13,gcoma , 0 ; computed goto
;+13
qqq+nbyt ,iconsi ,ent22+18,outlaba, stmlab
;+18
qqq+nbyt ,commai ,ent22+13,empa , 0
rghtpi ,ent22+27,comskipa, 0 ;end lab list skip com
;+27
qqq+inexp,endstmi , 0 ,esacta, 0 ; comp express es
; + 32
esm+ nbyt, commai, ent22+ 32, empa, 0
inconsi, ent22+ 32, skipia, 0
leftpi, ent22+ 32, empa, 0
rightpi, ent22+ 32, empa, 0
enx24: ent24 = enx24 - mbas ; call
qqq+nbyt ,identi ,ent24+5 ,calla , call
;+5
esm+nbyt ,leftpi ,ent24+14 ,callea , 0 ; param left par
endstmi, ent24+14, callesa, endcall ; paramless call
;+14
qqq+inexp,commai ,ent24+14 ,listcoa ,0
rightpi ,entx ,listrga ,0 ; end param list
enx26: ent26 = enx26 - mbas ; stop
qqq+nbyt ,iconsi ,entx ,outca, 0
endstmi, 0, stopa, 0 ; missing icons
; if , special treatm entof logical if in action ifa
enx27: ent27 = enx27 - mbas
qqq+nbyt , leftpi ,ent27+5 ,empa , 0
;+5
qqq+inexp,rightpi ,ent27+10 ,ifa , endifex ; end if expression
;+10
qqq+nbyt ,iconsi ,ent27+15 ,arifa , stmlab
; +15
qqq+nbyt, commai, ent27+ 10, empa, 0 ;after label
endstmi , 0 ,arifesa,0 ; end arit if stm
enx29: ent29 = enx29 - mbas ; do
qqq+nbyt ,iconsi ,ent29+5 ,dolaba, 0 ; do label
;+5
qqq+nbyt ,identi ,ent29+10 ,outbta, 0 ; controlled variable
;+10
qqq+nbyt ,equi ,ent29+15,doliga, doeq ; equals
;+15
qqq+inexp ,commai ,ent29+15,docoma, doinit ; do parameters
endstmi , 0 ,doesa , doinit
\f
;rc4000 fortran , pass 3 main control table (mct) side 7
enx31: ent31 = enx31 - mbas
qqq+nbyt ,leftpi ,ent31+5 ,callea , 0
;+5
qqq+inexp ,rightpi,ent31+28, rwrga , 0 ; unformatted r/w
commai ,ent31+14 ,listcoa ,0 ; formatted r/w
;+14
qqq+nbyt ,identi ,ent31+23,outbta, 0 ; format array
iconsi ,ent31+23,outlaba,formlab; format label
;+23
qqq+nbyt ,rightpi,ent31+28, rwrga , 0
;+28
esm+inexpim ,commai ,ent31+28,outa ,iocom ; io-list
enx32: ent32= enx32- mbas
qqq+ nbyt, identi, entx, outbta, 0 ; ident after entry
enxx: entx = enxx - mbas ; expecting end statement
qqq+nbyt ,endstmi, 0 ,esacta , 0
\f
;rc4000 fortran, pass 3 byte table (bt) side 1
;key<8
w.
btbase: h.;+class,entmct , btact ,btobyt , inbyte
5<8 + 12, 0 , endunita, ob8+0 ; 0 end unit
12, 0 , endpassa, ob8+1 ; end pass
7<8 + 2, 0 , 0, ob10+0 ; 2 lgcons
0<8 + 2, 0 , labela , ob10+1 ; intcons
7<8 + 2, 0 , 0, ob10+3 ; 4 lncons
7<8 + 2, 0 , 0, ob10+2 ; recons
7<8 + 2, 0 , 0, ob10+4 ; 6 dbcons
7<8 + 2, 0 , 0, ob10+5 ; cpcons
7<8 + 8, 0 , 0, ob9+0 ; 8 listleft
7<8 +10, 0 , 0, ob9+1 ; listrght
7<8 + 3, 0 , 0, ob12+0 ;10 +
7<8 + 3, 0 , 0, ob12+2 ; -
7<8 + 9, 0 , 0, ob13+0 ; 12 comma
7<8 + 4, 0 , 0, ob12+4 ; *
7<8 + 4, 0 , 0, ob12+5 ; 14 /
7<8 + 1, 0 , 0, ob17+1 ; =
7<8 +12, 0 , 0, ob11+3 ; 16 .
12, 0 ,begunita , ob8 +2 ; beg unit
7<8 + 4, 0 , 0, ob12+6 ; 18 **
7<8 + 6, 0 , 0, ob18+0 ; lt
7<8 + 6, 0 , 0, ob18+1 ; 20 le
7<8 + 6, 0 , 0, ob18+2 ; eq
7<8 + 6, 0 , 0, ob18+3 ; 22 ge
7<8 + 6, 0 , 0, ob18+4 ; gt
7<8 + 6, 0 , 0, ob18+5 ; 24 ne
7<8 + 5, 0 , 0, ob19+0 ; and
7<8 + 5, 0 , 0, ob19+1 ; 26 or
7<8 + 7, 0 , 0, ob20+0 ; not
7<8 + 4, 0 , 0, ob12+7 ; 28 shift
7<8 +12, 0 , 0, ob11+3 ; string
4<8 +12, 0 , esacta, ob26+0 ; 30 end stm
\f
;rc4000 fortran, pass 3 byte table (bt) side 2
;key<8
;+class ,entmct ,btact ,btobyt , , inbyte
12, 0,declaba ,ob10+8 ; end label
7<8 + 12, 0, outbta, ob22+ 3 ; 32 to
4<8 + 13, ent22 , outbta ,ob22+0 ; go to
4<8 + 12, ent27 , outbta ,ob22+1 ; 34 if
4<8 + 12, ent29 , dovala ,ob22+2 ; do
4<8 + 12, ent21 , 0 , 0 ; 36 assign
4<8 + 12, ent24 , empa ,ob9+2 ; call
4<8 + 12, entx , 0 , 0 ; 38 continue
4<8 + 12, entx , outbta ,ob7+2 ; return
4<8 + 12, ent26 , outbta ,ob22+4 ; 40 stop
4<8 + 20, ent31 , outbta ,ob22+5 ; read
4<8 + 20, ent31 , outbta ,ob22+6 ; 42 write
1<8 + 12, ent1 , outbta ,ob1+6 ; program
1<8 + 12, ent2 , outbta ,ob1+7 ; 44 subroutine
1<8 + 12, ent2 , outbta ,ob1+8 ; function
4<8 + 12, ent32 , outbta ,ob7+0 ; 46 entry
3<8 + 12, ent3 , typea ,ob2 +0 ; logical
3<8 + 12, ent3 , typea ,ob2 +1 ; 48 integer
3<8 + 12, ent3 , typea ,ob2+3 ; long
3<8 + 12, ent3 , typea ,ob2+2 ; 50 real
3<8 + 12, ent3 , typea ,ob2 +4 ; double
3<8 + 12, ent3 , typea ,ob2 +5 ; 52 complex
2<8 + 12, ent5 , outbta ,ob4 +2 ; dimension
2<8 + 12, ent4 , outbta ,ob4 + 1 ; 54 common
2<8 + 12, ent9 , outbta ,ob7+1 ; data
6<8 + 12, ent8 , outbta ,ob4 + 0 ; 56 equivalence
2<8 + 12, ent7 , outbta ,ob4+3 ; external
2<8 + 12, ent6 , outbta ,ob4+4 ; 58 zone
\f
;rc4000 fortran, pass 3 byte table (bt)
;key<8
;+clacc, entmct, btact , btobyt , inbyte
0, 0, endla, ob8+3 ; endline
8<8+ 12, ent10, begfora, ob21+0 ; 60 begforc
8<8+ 12, ent10, begfora, ob21+1 ; begforo
7<8+12, 0, 0, ob11+0 ; 62 endfor
7<8+12, 0, 0, ob11+1 ; confor
0, 0, trouba , ob11+3 ; 64 trouble
0, 0, extida , ob11+2 ; extident
0, 0, outbta , ob3+0 ; impl int
0, 0, outbta , ob3+1 ; impl real
btident:
4<8+11 , ent20 , identa, 0 ; identifier
; obyte tables for leftpar, rghtpar and comma
lparbyt: h.
0 ,aritleft, listleft,
aritleft, 0, 0
rparbyt:
0 ,aritrght,listrght,
aritrght,iorght ,imprght ,
commabyt:
0 , 0 ,listcom ,
iocom , iocom , 0
w.
\f
;rc4000 fortran, pass 3 definitions dside 8
; input bytes are classified in relation
; to then statement type they introduce
; when heading a statement
;key 0 miscelleaneous bytes
; 1 program heading bytes
; (program,function, e.t.c.)
; 2 declaratives
; (dimension, common, e.t.c.)
; 3 integer, real, etc
; 4 executable statements
; (do, if, e.t.c.)
; 5 end
; 6 equivalence
; 7 illegal as key byte
; 8 format
;************************* key8 boer ogsaa indeholde data (og entry)
\f
;rc4000 fortran pass 3 definitions side 9
; tables for control of program structure
; the following program states are defined
; 0 after begin program unit
; 1 in declarative statements
; 2 in equivalences
; 3 in executable statements
; each statement type has a key value
; ranging from 0-6 . the key value
; determines together with the present
; program state
; a. if the statement type is legal
; b. the new program state
; the legality is given by the table
; keybits, the new state by the table
; prstable. key value 0 indicates
; bytes beyond the structure rules.
; legal key values
keybits:
h. 2.011111 101000 ; 0-1,3
2.001111 101000 ; 1-2,3,4,5,6
2.000011 101000 ; 2-4,5,6
2.000011 001000 ; 3-4,5
prstable:
0,1,0,3,3,2,0-0,1 ; key 1-6
w.
prstart=0
prstdecl= 1
prstequ= 2
prstex = 3 ; progr. st. in executable part
\f
;rc4000 fortran ' pass 3 definitions side 10
; global variables
btstate : 0 ; prstable (bt (ibyte,key))
dosavlab : 0 ; saved do-label
exprtyp : 0 ; type of current expres
; sion read by inexp
firstlft : 0 ; boolean for first left
; par in expression used
; for treatm of io-lists
impcnt : 0 ; comma counter for do
comcnt : 0 ; and imp do
iflab : 0 ; counter for arit if labels
incount : 0 ; element count in inlist
inlisw : 0 ; flip-flop word in inlist
ibyte : 0 ; current input byte
prstate : 0 ; current program state
pointer : 0 ; stack pointer
prgcnt: 0 ; counter for main programs
putype: 0 ; 0: head missing, 1: mainprogr, 2: subrout or fnct
pucnt : 0 ; counter for program units
repeat : 0 ; boolean for nextbyte
; to repeat last byte
stacklim : 0 ; limit for stack pointer
savtyp : 0 ; work for mct action
; type function
wlabel : 0 ; buffer for label value
wstar : 0 ; boolean for star occur
stmclas: 0 ; statement type
logifcnt: 0 ; count for log if nesting
wsign: 0 ; boolean for monadic sign in data
eqcount: 0 ; counter for multiple assignments
\f
;rc4000 fortran, pass 3 definitions side 11
; constants and symbol values
cn17t0 : 8.377
cn7: 7
cn18t0: 8.777
cinliva : 8.00010000 ; control parameters for
cinlico : 8.10000000 ; inlist, indicalting allowed
cinlibo : 8.10010000 ; classes
stackmsk:8.07777777 ; to extract label of stack
; element
; gpa entries
inbyte : jl. e2.
outbyte : jl. e3.
gpael : jl. e1.
alarm = e5
stacktxt = e10
gpalastw = e9+4 ; addr last work for pass
gpaendp: jl. e7.
\f
;rc4000 fortran, pass 3 definitions side 12
; words from current bt, mct and ect-entru and stack
h.
btbits : 0 ; key <8 + class
entmct : 0 ; index to mct entry
btact : 0 ; action adress rel actionbase
btobyt : 0 ; value or base value of output byte
; mct bytes
mctnew : 0 ; new mct index
mctobyt : 0 ; value or base value of output byte
; ect bytes
ecstate : 0 ; new ec state
ecact : 0 ; action
w.
mctrecl= 4 ; reclength for mct
btclass: 0;bt subfiels
\f
;rc4000 fortran, pass 3 definitions side 13
; acbas for action addresses
; btbase start of byte table
; mbas start of main control table
; stackbas start of stack
; pass 3 end end of code for pass 3
\f
w.
;rc4000 fortran pass 3 main side
acbas:
; error administration entered in error+ errrorcode<1
error: am -1 , r.9 ; 9 error codes defined
al w1 errorbas+ 9 ; w1 = error code
al w0 trouble
jl. w3 outbyte.
al w0 x1
jl. w3 outbyte. ; outbyte( trouble, errcode,0,0)
al w0 0
jl. w3 outbyte.
rl. w0 btclass.
jl.w3 outbyte.
al w1 0 ; suppres statement types
rs. w1 logifcnt. ; bytes except enddo
rl. w0 stmclas.
se w0 docl
rs. w1 stmclas.
; skip all except identifiers and constants until end statement
skipon: rl. w0 ibyte.
sn w0 endstmi ; if ibyte eq endstmi then goto
jl. esact. ; endstm action
sn w0 enduni
jl. euact.
sh w0 begforci-1 ; skip trailers in format bytes
jl. noform.
sl w0 confori+ 1
jl. noform.
jl. w3 skiptwo.
jl. skipnxt.
noform:
al w0 0
rl. w1 btclass.
se w1 identcl ; if clas eq identifier then output
jl. constest. ; else goto test for const
jl. w3 outbt.
skipnxt: jl. w3 nextbyte.
jl. skipon.
constest: se w1 constcl
jl. skipnxt.
al w0 vanopnd
jl. w3 outbyte.
jl. w3 skipix. ; skip trilers i n const
jl. skipnxt. ; and goto take next byte
; end unit found during trouble skip
euact: al w0 1 ;
rs. w0 repeat. ; repeat(end unit byte)
; simulate an end statement byte
; end statement action
esact: rl. w1 stmclas.
al w1 x1- speclim ; if special stm type
sh w1 0 ; then output byte
jl. esout. ; for statement type
al w0 x1+ endstyp
jl. w3 outbyte.
esout: rl. w1 logifcnt. ; output possible log if
sh w1 0 ; bytes
jl. obesm.
al w0 endlogif
esloop: jl. w3 outbyte.
al w1 x1- 1 ; count log ifs down
se w1 0
jl. esloop.
rs. w1 logifcnt.
obesm: al w0 endstm ; output end statement
jl. w3 outbyte.
rl. w1 putype.
se w1 0
jl. cleanup.
jl. w3 outhead.
; use of registers: w0, relevant obyte for do termination
; w1, working reg w2, controlled varable w3, stackindex for first found elem
cleanup: rl. w2 pointer. ; cleanup possible parentheses
sh w2 0
jl. dosearch.
bz. w1 x2+ stackbas. ; in stack
ls w1 -9
sh w1 1
jl. dosearch.
al w2 x2 -2
rs. w2 pointer.
jl. cleanup.
dosearch: al w3 0 ; found = 0
sl. w3 (wlabel.) ; if current statm unlabelled
jl. newstm. ; then skip search
al w0 doterm ; obyte for correct termination
al w2 0
jl. dosstep. ; for w2 = 2 step 2 until pointer do
dosloop: rl. w1 x2+ stackbas. ; if found eq 0 then
la. w1 stackmsk. ; begin
se w3 0 ; if stacked label eq wlabel then
jl. donotfnd. ; found = w2
\f
;rc4000 fortran pass3 main side
sn. w1 (wlabel.) ; end if found
al w3 x2
dosstep: al w2 x2+ 2
sh. w2 (pointer.)
jl. dosloop.
jl. dosout. ; end of search goto possible output
donotfnd: se. w1 (wlabel.) ; else if stacked label nq wlabel
al w0 doterror ; then w0 = do termination error
jl. dosstep.
; output do termination bytes for all found or erroneous do elements
; and unstack elements
; at entry w0 contains the relevant output byte
; w3 the pointer value for first involved stack element or 0 if none found
dosout: sh w3 0 ; if none found goto new statement
jl. newstm.
al w2 x3- 2 ; save for later adjustment of pointer
al w1 x3
dosocal: jl. w3 outbyte.
al w1 x1+ 2
sh. w1 (pointer.)
jl. dosocal.
rs. w2 pointer. ; set new pointer
jl. newstm. ; end of end statem action
\f
;rc4000 fortran pass3 main side
; entry to pass3
inpass3: al. w1 pass3end.
inpa3= inpass3-e0
ac w1 x1
wa. w1 gpalastw.
rs. w1 stacklim. ; set stack limit
newstm: al w0 -1
rs. w0 wlabel. ; set no label or endlabel read
mainext: jl. w3 nextbyte.
bz. w1 btbits.
ls w1 -8 ; w1 = btkey
sn w1 0
jl. btperfa. ; if neutral byte skip prog structure test
rl. w3 prstate.
bz. w0 x3+ keybits. ; w0 = keybits(prstate)
ls w0 x1 12 ; relevant keybit to sign pos
sl w0 0
jl. error.+ 1<1 ; if illegal keybyte then error(1)
bz. w0 x1+ prstable.- 1 ; btstate = prstable(btkey)
rs. w0 btstate.
manola: rl. w1 prstate.
sl. w1 (btstate.) ; if state change then begin
jl. btperf. ;
sn w1 prstart
jl. w3 outhead.
al w0 endecl ; if prstate= in declaratives
sn w1 prstdecl ; then outbyte( endecl)
jl. w3 outbyte.
al w0 endequiv ; if in equivalences then
sn w1 prstequ ; outbyte(endequiv)
jl. w3 outbyte.
al w1 x1+ 1
rs. w1 prstate. ; increase prstate
jl. manola. ; repeat
btperf: rl. w1 prstate. ; or after no before format
sl w1 prstex
jl. wrlabel.
btperfa: rl. w1 ibyte.
se w1 begforoi
sn w1 begforci
jl. 4
jl. btperf1.
wrlabel: rl. w1 logifcnt. ; if in logical if
se w1 0 ; dont output label
jl. btperf1.
rl. w1 wlabel.
sh w1 0 ; if label read output
jl. btperf1.
al w0 declabel ; output (declabel,labelvalue)
jl. w3 outbyte.
bz. w0 wlabel.
jl. w3 outbyte.
bz. w0 wlabel.+ 1
jl. w3 outbyte.
btperf1: rl. w0 entmct. ; set mct entry index
hs. w0 mctnew.
bz. w0 btbits. ; set statem type
la. w0 cn17t0.
rs. w0 stmclas.
bl. w3 btact.
se w3 0
jl. w3 x3+ acbas. ; if btact nq 0 perform btaction
nxmct: bz. w2 mctnew.
bz. w1 x2+ mbas. ; w1 = input case
la. w1 cn7.
ls w1 2 ; mult by 4 and clear flagbits
al. w3 inpretur. ; prepare return
jl. x1+2 ; switch to input case
jl. nextbyte. ; 0, nextbyte
am ; filler
al w1 0
jl. inexpx. ; 1, inexp (no implied)
al w1 1 ; 2, inexp ( imlied)
jl. inexpx.
rl. w1 cinliva. ; 3, inlist( variables only)
jl. inlist.
rl. w1 cinlico. ; 4, inlist( constants only)
jl. inlist.
rl. w1 cinlibo.
jl. inlist. ; 5, inlist ( varbs and constants)
inpretur: bz. w2 mctnew.
al w2 x2+ 1 ; mctinx now point to firstregular entry
; search mct section for entry with mctib eq to actual ibyte
mctsearc: bl. w1 x2+ mbas.
sh w1 0 ; if end if section then test for end stm
jl. mctesec.
sn. w1 (ibyte.) ; if mctib eq ibyte then goto ibfound
jl. ibfound. ; else increase mctinx
al w2 x2+ mctrecl
jl. mctsearc. ; and try next entry
ibfound: bz. w1 x2+ mbas.+ 1
hs. w1 mctnew. ; move mctbytes
bz. w1 x2+ mbas.+ 3
hs. w1 mctobyt.
bz. w1 x2+ mbas.+ 2 ; perform mct action
jl. w3 x1+ acbas.
;mct actions may return normally or jump direci to nxmct
jl. nxmct. ; if normal return from action
mctesec: rl. w0 ibyte.
se w0 endstmi
jl. error.+ 3<1 ; if not end stm then error(3)
bz. w2 mctnew.
bz. w2 x2+ mbas. ; fetch section start byte
so w2 1<10
jl. error.+ 3<1 ; if end stm not legal then error(3)
jl. esact. ; else jump to standard end stm action
; end of main \f
;rc4000 fortran pass 3 inlist side
; input and control list of identifiers and/or constants
; entry with w1 = control mask, bit 23 - i = 1 for class i legal
inlist: rs. w3 inliret. ; save return
rs. w1 inlisw.
al w1 0 ; initiate element count
rs. w1 incount.
jl. inliele.
inliloo: jl. w3 nextbyte.
sn w2 commai ; accept and skip comma
jl. inliele.
rl. w1 incount. ; else if not empty list
se w1 0
jl. (inliret.) ; then return
se w2 endstmi
jl. error. +6<1 ; accept empty list if endstatem
jl. (inliret.)
inliele: jl. w3 nextbyte.
rl. w0 inlisw.
ls. w0 (btclass.) ; check if correct element class
sl w0 0
jl. error. +6<1 ; else error(6)
rl. w2 incount.
al w2 x2 +1 ; count element
rs. w2 incount.
rl. w2 ibyte.
sn w2 identi
jl. inident. ; copy identifier
se w2 inconsi ; integer only allowed
jl. error.+ 6<1
jl. w3 outcx. ; output constant
jl. inliloo.
inident: jl. w3 outbt.
jl. inliloo.
inliret: 0
;rc4000 fortran pass 3 general subroutines side
; setexp, set current expression type
; values : 0 empty expr
; 1 constant
; 2 simple variable
; 3 general expr
; entry: w1 = new expr type
setexp: rl. w0 exprtyp.
sh w0 x1
rs. w1 exprtyp. ; set max(new , current)
jl x3
; outcase output byte from specifeed table indexed by paretheses type
; given in stack top
; entry : w1 = base of byte table, w0,1,3 changed
outcase: rs. w3 outcw3.
rl. w3 pointer.
bz. w3 x3+ stacont. ; w3 = parent type
am x3
bz w0 x1 ; w0 = byte value
jl. w3 outbyte.
jl. (outcw3.)
outcw3: 0 ; sawed return
; outbt, outmct : output byte from btobyt/mctobyt incremented
; by value in w0, w0,3 changed
outbt: rs. w3 outsw3.
ba. w0 btobyt. ; add obyte from bt
jl. outret.
outmct: rs. w3 outsw3.
ba. w0 mctobyt. ; add obyte from mct
outret: jl. w3 outbyte.
jl. (outsw3.)
outsw3: 0
; outcopy : copy no of bytes given in w1
outcopy: rs. w3 outsw3.
jl. w3 inbyte.
al w0 x2
jl. w3 outbyte.
al w1 x1- 1
sl w1 1
jl. outcopy.+ 2
jl. (outsw3.)
; stack, create new stack word, entry : w0= element type, w1= content of element
stack: rl. w2 pointer.
al w2 x2+ 2 ; increase stack pointer
sh. w2 (stacklim.) ; check for core overflow
jl. stackok.
al. w1 stacktxt.
jl. w3 alarm. ; go to rs entry alarm
stackok: ls w1 3 ; concatenate type and content
ld w1 -3
rs. w1 x2+ stackbas. ; set new entry
rs. w2 pointer. ;set new stack pointer
jl x3
skipix: rs. w3 genretur. ; skip const trailers
rl. w1 ibyte.
al w1 x1- lgconsi
bl. w1 x1+ coptab.
jl. w3 inbyte.
al w1 x1- 1
sl w1 1
jl. -6
jl. (genretur.)
skiptwo: rs. w3 genretur. ; skip two trailerds
jl. w3 inbyte.
jl. w3 inbyte.
jl. (genretur.)
\f
;rc4000 fortran pass 3 general suroutines side
; copy constant according to ibyte
outcx: rs. w3 genretur.
al w0 0
jl. w3 outbt. ; output header byte
rl. w1 ibyte.
al w1 x1- lgconsi
bz. w1 x1+ coptab. ; find no of trailer bytes
jl. w3 outcopy. ; copy trailer bytes
jl. (genretur.)
coptab:
h. 1,2,4,4,8,8
w.
; nextbyte, read next input byte
; if identifier substitute with standard ident value and set actual
; ident value in btobyt for output
; if class eq 0 perform action specified in bt and take next byte
; return with byte value in ibyte and w2 , corresponding bt-entry
; moved to simple bytes btbits,entmct,btact,btobyt and btclass
nextbyte: rs. w3 nbw3save.
nbagain: am. (repeat.)
sn w3 x3
jl. nbnew. ; no repeating
al w2 0
rs. w2 repeat. ; repeat := false
rl. w2 ibyte. ; repeat last byte
jl. (nbw3save.)
nbnew: jl. w3 inbyte. ; take new byte
sh w2 identlim- 1
jl. noident.
hs. w2 btident.+ 3 ; set ident value for output
al w2 identlim ; and replace with ident value base
dl. w1 btident.+ 2
jl. nbstore.
noident: al w1 x2- ib1
ls w1 2
dl. w1 x1+ btbase.+ 2 ; move bt-entry
nbstore: rs. w2 ibyte.
ds. w1 btact. ; to simple bytes
ls w0 -12
la. w0 cn17t0. ; extract class
sl w0 stmbase+ 1 ; if class gt ident class then replace
al w0 stmbase+1 ;with else class
rs. w0 btclass.
se w0 0 ; ifnot neutral byte (class 0) then
jl. (nbw3save.) ; return
bl. w3 btact. ; else perform btaction
jl. w3 x3+ acbas.
jl. nbagain. ; take next byte if action returns
nbw3save: 0
; blanc common
h.
blcbyt: 8, 539, implrea, extident, 4, w.<:9blcom:>, h.
; missing heading
heabyt: 10, program, 540, implrea, extident,4,w.<:missng:>, h. endstm
;in the above line, program can be exchanged by subrout
; trouble no of mainprograms
troubyt: 4, trouble, errorbas+ 9,0,0
; return statement
retubyt: 2,return, endstm
; stop statement
stobyt: 5,stop, icons, 0, 1111, endstm
; iconstant 0
zerobyt: 3, icons,0,0
w.
; outseq, ou.put sequence of bytes
; srtart given in w1, no of bytes in first byte
outseq: rs. w3 seqsav.
al w2 x1+ 1
ba w2 x1
seqloop: al w1 x1+ 1
sl w1 x2
jl. (seqsav.)
bl w0 x1
jl. w3 outbyte.
jl. seqloop.
seqsav: 0
0 ; w1
ohw2sav: 0 ; w2
ohw3sav: 0 ; w3
outhead: rs. w3 ohw3sav. ;
ds. w2 ohw2sav. ;
al w1 prstdecl ;
rs. w1 prstate. ;
rl. w1 prgcnt. ;
al w2 subrout ;
se w1 0 ;
hs. w2 heabyt.+1 ; if prgcnt <> 0 then set heading to subrout
al w2 1 ;
se w1 0 ;
al w2 2 ;
rs. w2 putype. ; putype:=if prgcnt=0 then mainprg else subr
rs. w2 prgcnt. ; main prg occured := true
al. w1 troubyt. ;
sn w2 2 ;
jl. w3 outseq. ; if subr then outseq(illegal number of main programs)
al. w1 heabyt. ;
jl. w3 outseq. ;
dl. w2 ohw2sav. ;
jl. (ohw3sav.) ;
\f
;rc4000 fortran pass 3 general actions side
outbtx: rs. w3 genretur. ; outbt(0)
al w0 0
jl. w3 outbt.
jl. (genretur.)
genretur: 0
emptx: jl x3 ;empty action
outx: rs. w3 genretur.
al w0 0
jl. w3 outmct. ; outmct(0)
jl. (genretur.)
\f
;rc4000 fortran pass3 inexp side
; inexpx : input and process expression according to
; expression control table (ect)
; ect contains a row for each expr cont state and a coloumn pr input class
; each table entry consists of 2 bytes:
; byte 1: new state
; byte 2: action address
; the action address is given relative to label inexp
; if the combination actual state and actual input class is illegal
; byte 1 contains 1<11 + error code
ectbas:
; expression control table
h.
; ecstate 1, before expression
ecst1x: 1<11 +2, 0 ; =
ecst3, ecact2a ; const
ecst4, ecact3a ; +-
1<11+ 2, 0 ;mult / pilup shift
1<11+ 2, 0 ; and or
1<11+2, 0 ; relation
ecst5, ecact4a ; not
ecst1, lparaa ; leftp , aritmetic
1<11+ 2, 0 ; comma
1<11+2 , 0 ;right par
ecst2, ecact1a ; ident
1<11+2, 0 ;else class
; ecstate 2, after identifier
ecst2x: ecst1, eqacta ; 11 =
1<11+ 2, 0 ; 2, constant
ecst4, ecact4a ; 3, + -
ecst4, ecact4a ; 4, star / starstar shift
ecst1, ecact4a ; 5, and or
ecst5, ecact4a ; 6, relation
1<11+ 2, 0 ; 7, not
ecst1, lparla ; 8, left par , list
ecst1, comacta ; 9,comma
ecst3, rpara ; 10, right par
1< 11+ 2, 0 ; ident
0, exretura ; 12, else class return
;rc4000 fortran pass 3 expression control table side
; ecstate 3, after constant
ecst3x: 0, exretura ; =
1<11+ 2, 0
ecst4, ecact4a
ecst4, ecact4a
ecst1, ecact4a
ecst5, ecact4a
1<11+ 2, 0
1<11+ 2, 0
ecst1, comacta
ecst3, rpara
1<11+2, 0
0, exretura
; ecstate 4, after - + star / starstar shift
ecst4x: 1<11+ 2, 0 ; =
ecst3, ecact2a
1<11+ 2,0
1<11+2 , 0
1<11+ 2,0
1<11+2 ,0
1<11+2, 0
ecst1, lparaa
1<11+ 2,0
1<11+ 2,0
ecst2, ecact1a ; ident
1<11+ 2,0
; ecstate 5, after not , after relational operator
ecst5x: 1< 11+ 2, 0
ecst3, ecact2a
ecst4, ecact3a
1<11+ 2,0
1<11+ 2,0
1<11+ 2,0
1<11+ 2,0
ecst1, lparaa
1<11+ 2,0
1<11+ 2,0
ecst2, ecact1a
1<11+ 2,0
; ecstste 6, after io,imp right par
ecst6x: 1<11+2 , 0
1<11+2 , 0
1<11+2 , 0
1<11+2 , 0
1<11+2 , 0
1<11+2 , 0
1<11+2 , 0
1<11+2 , 0
ecst1 ,comacta ; 9 comma
ecst3 , rpara ; 10 right par
1<11+2 , 0
0 , exretura ; 12 else
\f
;rc4000 fortran pass 3 inexp side
; inexp, control and process next expression
; if w1 eq 1 at entry accept implied do loops
w.
; exit with terminating byte in ibyte ,expression type in exprtyp
inexpx: rs. w3 ineret.
rs. w1 sinio.
al w1 1
rs. w1 firstlft. ;firstlft = true, pars may be io-pars
al w1 ecst1
rs. w1 ecstate. ; set initial state
al w0 3 ; set exprtyp to 0
al w1 0 ; and stack empty parenteses element
rs. w1 exprtyp.
jl. w3 stack.
inenxt: jl. w3 nextbyte. ; start of control loop
rl. w1 btclass.
ls w1 1 ; class*2
ba. w1 ecstate. ; + ecstate
rl. w1 x1+ ectbas.- 2
rs. w1 ecstate. ; move ect word to simple bytes
sh w1 0 ; if new state lt 0
jl. ecerr. ; then goto express error
bz. w1 ecact. ; else go to action
jl. x1+ acbas.
ineret: 0 ; return addr
sinio: 0 ; input param specifying impl do legality
ecerr: ls w1 1
ls w1-12 ; go to error+ error code<1
jl. x1+ error.
; return administration called by actions at expression termination
exreturn: rl. w2 pointer.
bz. w1 x2+ stackbas. ; check for open left paretheses
ls w1 -9
se w1 3
jl. (ineret.) ; if not parent elem then return
bz. w1 x2+ stacont.
se w1 0
jl. error. + 4<1 ; if parent elem not empty then error(4)
al w2 x2- 2
rs. w2 pointer. ; else unstack element
jl. (ineret.)
\f
;rc4000 fortran pass 3 inexp actions side
; standard actions
ecact1x: al w1 2
jl. w3 setexp. ; expr typ up to simple var
al w0 0
jl. w3 outbt.
jl. ecacret.
ecact2x: al w1 1
jl. w3 setexp. ; expr typ constant
jl. w3 outcx. ; output header for constant
jl. ecacret.
ecact3x: al. w1 zerobyt.
jl. w3 outseq.
ecact4x: al w0 dyadic
ecact42: jl. w3 outbt. ; output monadic or dyadic operator
ecact44: al w1 3
jl. w3 setexp. ; exprtyp general
ecacret: al w0 0
rs. w0 firstlft. ; no more leading left pars
jl. inenxt.
; actions for left par
; aritmetcal left
lparax: al w1 3
jl. w3 setexp. ; expr typ general
al w1 0
se. w1 (sinio.) ; leftp typ = if sinio and firstleft then
sl. w1 (firstlft.) ; arit/io else aritmeticcal
am -2
al w1 3
al w0 3
jl. w3 stack. ; stack left par
jl. leftout.
; list left par
lparlx: al w1 3
jl. w3 setexp. ; expr typ general
al w1 2
al w0 3
jl. w3 stack. ; stack left par
al w1 1 ; intiate list elem coynt
ba. w1 x2+ stackbas.
hs. w1 x2+ stackbas.
leftout: al. w1 lparbyt. ; base for left par byte table
jl. w3 outcase. ; output leftp byte from table
jl. inenxt. ; end action
\f
;rc 4000 fortran pass 3 inexp actions side
; actions for comma
comactx: al w1 1
rs. w1 firstlft. ; left pars are leading
rl. w2 pointer.
bz. w1 x2+ stacont. ; w1 = parent type
ls w1 1
jl. x1+ 2 ; switch on parent type
jl. exreturn. ; empty par
jl. exreturn. ; aritmetic
jl. comlist. ; list
jl. comario. ; arit/ io
jl. comio. ; io
jl. comimp. ; implied
comlist: al. w1 commabyt. ; list comma
jl. w3 outcase. ; output byte from commatable
bl. w1 x2+ stackbas.
al w1 x1+ 1 ; count list elements
hs. w1 x2+ stackbas.
jl. inenxt.
comario: al w1 4
hs. w1 x2+ stacont. ; set parent type to io
jl. comio.
comio: al w1 0
rs. w1 exprtyp. ; clear expr typ
al. w1 commabyt. ; output byte from commatable
jl. w3 outcase.
jl. inenxt.
comimp: rl. w1 impcnt.
sl w1 7
jl. error.+ 5<1 ; if imppl comma count gt 3 then error(5)
al w1 x1+ 3
rs. w1 impcnt. ; count commas
wa. w1 exprtyp.
al w0 x1+ impinit- 4
jl. w3 outbyte.
al w1 0
rs. w1 exprtyp. ; clear expr typ
jl. inenxt. ; end action
; action for = in implied do loops
eqactx: rl. w2 sinio.
sn w2 0 ; if not in io-stm return
jl. exreturn.
rl. w2 pointer.
rl. w0 exprtyp. ; if exprtyp is not simple ident
se w0 2 ; then errror(5)
jl. error.+ 5<1
bz. w0 x2+ stacont.
se w0 4 ; if parent typ is not io then
jl. error.+ 2<1 ; error(2)
al w0 5
hs. w0 x2+ stacont. ; set parent typ to implied
al w0 0
rs. w0 exprtyp. ; clear exprtyp
rs. w0 impcnt. ; implied comma count = 0
jl. w3 outbt. ; outbt (0)
jl. inenxt. ; end action
\f
;rc4000 fortran pass 3 inexp actions side
; actions for right parenthesis
rparx: rl. w2 pointer.
bz. w1 x2+ stacont.
ls w1 1
jl. x1+ 2 ; switch on parent type in stack
jl. exreturn. ; empty parent
jl. eunstack. ; arithmetical
jl. listrp . ; list
jl. eunstack. ; arit/ io
jl. ioright. ; io
jl. imright. ; implied
imright: rl. w1 exprtyp. ; (6)
wa. w1 impcnt.
al w0 x1+ impinit- 1
jl. w3 outbyte.
rl. w1 impcnt.
sh w1 0
jl. error.+ 5<1 ; if impcnt lt 1 then error (6)
sl w1 6
jl. ioright.
al w0 icons
jl. w3 outbyte. ; generate step 1
al w0 0
jl. w3 outbyte.
al w0 1
jl. w3 outbyte.
al w0 impstepc
jl. w3 outbyte.
ioright: al. w1 rparbyt. ; table of obytes for right parent
jl. w3 outcase.
al w0 ecst6m2
hs. w0 ecstate.
jl. eunst4.
listrp: al. w1 rparbyt.
jl. w3 outcase.
bl. w0 x2+ stackbas.
la. w0 cn18t0.
jl. w3 outbyte.
al w0 spark
jl. w3 outbyte.
jl. eunst4.
jl. inenxt. ; counter
eunstack: al. w1 rparbyt.
jl. w3 outcase. ; output rpar byte from table
eunst4: al w2 x2- 2
rs. w2 pointer. ; unstack parent element
jl. inenxt. ; end action
\f
;definitions of action symbols for inexp
ecact1a = ecact1x- acbas
ecact2a = ecact2x- acbas
ecact3a = ecact3x- acbas
ecact4a = ecact4x- acbas
lparaa = lparax- acbas
lparla = lparlx- acbas
rpara = rparx - acbas
comacta = comactx- acbas
eqacta = eqactx- acbas
exretura = exreturn- acbas
; definition of state symbols for inexp
ecst1 = ecst1x- ectbas
ecst2 = ecst2x- ectbas
ecst3 = ecst3x- ectbas
ecst4 = ecst4x- ectbas
ecst5 = ecst5x- ectbas
ecst6m2= ecst6x-ectbas
\f
;rc4000 fortran , pass 3 actions side 1
; bt actions/1
; end program unit
endunitx : rl. w0 prstate. ; if program state in declaration or
sn w0 prstequ ; in equivalences then output
jl. enduneq. ; poss missing endeclaration
sl w0 prstequ ; and endequivalence
jl. endunok. ; prstate gt in equiv
al w0 endecl
jl. w3 outbyte.
enduneq: al w0 endequiv
jl. w3 outbyte.
endunok: rl. w2 pointer. ; process possible open do-ranges
se w2 0
jl. odoterr. ; if open do-range outbyte(doterr)
rl. w0 putype. ; if subr or fnct generate return
al. w1 retubyt. ; else generate stop
se w0 2
al. w1 stobyt.
jl. w3 outseq.
al w0 0
jl. w3 outbt. ; outbyte (endunit, linecount)
rl. w1 pucnt. ; count progr units
al w1 x1+ 1
rs. w1 pucnt.
jl. mainext. ; end action
odoterr: al w0 doterror ;
jl. w3 outbyte. ; outbyte (do term in error)
al w2 x2-2
rs. w2 pointer. ; decrease stack pointer
jl. endunok.
; end pass
endpassx: rl. w1 pucnt. ; if no of prunits gt 1 and no main program
rl. w0 prgcnt. ; then output trouble no of prmaimprg
sl w1 2
se w0 0
jl. endpok.
al. w1 troubyt.
jl. w3 outseq.
endpok: al w0 0
jl. w3 outbt.
jl. gpaendp. ; return to gpa
prgrx: al w1 1 ; ident after program, set head ok,mainprgr
rs. w1 putype.
al w1 prstdecl ;
rs. w1 prstate. ;
rl. w1 prgcnt.
se w1 0 ; if already one main prgr then error 8
jl. error.+ 9<1
rs. w0 prgcnt. ; else set main prgr occured
jl. outbtx.
\f
;rc4000 fortran, pass 3 actions side 2
;bt actions/2
; tabel declaration
labelx: am. (wlabel.)
sh w1 x1 ; if label or endlabel read
jl. w3 error.+3<1 ; then error(15)
jl. w3 inbyte.
hs. w2 wlabel. ; wlabel = 2 next bytes
jl. w3 inbyte.
hs. w2 wlabel.+ 1
jl. mainext. ; end action
; end label
declabx: am. (wlabel.) ; if no label read then
sh w1 x1
jl. mainext. ; wlabel=0
al w0 0
rs. w0 wlabel.
jl. mainext. ; end action
; ident after subroutine or function
subrx: al w1 2
rs . w1 putype. ; set head ok subr or funct
al w1 prstdecl ;
rs. w1 prstate. ;
jl. outbtx. ; return via outbta
\f
;rc4000 fortran ,pass 3 actions side 3
; bt actions/3
;begin unit
begunitx: al w0 0
rs. w0 prstate.
rs. w0 putype. ; set head missing
jl. w3 outbt.
jl. mainext. ; end action
\f
;rc4000 fortran ,pass 3 actions side 4
; btactions/4
dovalx: rs. w3 extiret.
rl. w0 logifcnt.
se w0 0
jl. error.+ 8<1 ; do after logical if
jl. w3 outbt.
jl. (extiret.)
typex : bz. w0 btobyt. ; save obyte of type expecting
rs. w0 savtyp. ; function or ident
jl x3 ; return
begforx: rl. w0 wlabel. ; begin format
sh w0 0 ; if unlabelled format
jl. error.+7<1 ; then error(13)
conforx: al w0 0 ; action for continue format
rs. w0 wlabel. ; clear format label
al w0 genform
jl. w3 outbyte. ; output general format byte
al w0 0 ; folloved by normal format byts
jl. w3 outbt. ; else copy begin format
al w1 2
jl. w3 outcopy.
jl. nxmct. ; goto take next byte
\f
;rc4000 fortran pass 3 actions side 5
; btactions/5
troubx: al w0 0 ; action for trouble
jl. w3 outbt.
al w1 3 ; copy trouble bytes
jl. w3 outcopy.
jl. w3 nextbyte. ; read next byte
jl. skipon. ; proceed with error treatment in main
extidx: rs. w3 extiret. ; action for external repr bytes
al w0 0
jl. w3 outbt. ; copy control byte
jl. w3 inbyte. ; w2 = no of bytes
al w1 x2
extcopy: al w0 x2
jl. w3 outbyte. ; copy no and trailers
sh w1 0
jl. (extiret.)
al w1 x1- 1
jl. w3 inbyte.
jl. extcopy.
extiret: 0
\f
;rc4000 fortran ,pass 3 actions side 6
endlx: rs. w3 endlsav.
jl. w3 outbt.
jl. w3 gpael.
jl. (endlsav.)
endlsav : 0
identx: al w0 0 ; initiate count for mult assign
rs. w0 eqcount.
al w0 1
rs. w0 repeat. ; repeat ident in inexpression
jl x3
; mctactions/1
; function after type
funcx: rl. w0 prstate. ; if after heading then error
se w0 0
jl. w3 error. +1<1
al w0 prstdecl ; else set prstate
rs. w0 prstate. ; in declaratives
rl. w1 savtyp.
al w0 x1- logical ; compute increment
jl. w3 outmct. ; output byte
jl. nxmct. ; end action
; ident after type
type2x: rl. w0 prstate. ; if before heading
sn w0 0 ; then error
jl. w3 outhead. ;
rl. w0 savtyp.
jl. w3 outbyte. ; outbyte (saved type)
al w0 1
rs. w0 repeat. ; repeat identifier in list
jl. nxmct.
\f
;rc4000 fortran ,pass 3 actions side 7
; assign =
ariteqx: rl. w1 eqcount. ; if eqcount = 0 then
al w0 prepass ; outbyte (prepass)
se w1 0
al w0 ariteq
jl. w3 outbyte.
al w1 x1+ 1
rs. w1 eqcount. ; count equals
jl. nxmct.
;mct actions/2
;bound left in type list
type3x: al w0 0
jl. w3 outmct. ; out byte (bound right)
jl. nxmct. ; end action
; blank common actions
blank1x: al w0 1 ; repeat ident from common
rs. w0 repeat. ; variable list
blankx: al. w1 blcbyt. ; output identbytes for
jl. w3 outseq. ; blank common
jl. nxmct.
\f
;rc4000 fortran, pass 3 actions side 8
;mct actions/3
; es in zone specifications
zspecx: al w0 0
jl. w3 outmct.
jl. esact.
; actions for listleft,listrght and listcomma
listlex: al w0 1
rs. w0 incount. ; initiate elem counter
jl. outbtx.
listcox: rl. w1 incount. ; count list elements
al w1 x1+ 1
rs. w1 incount.
jl. outbtx.
listrgx: rs. w3 listw3.
al w0 0
jl. w3 outbt. ; output listrght
rl. w0 incount.
jl. w3 outbyte. ; output listelem count
al w0 spark
jl. w3 outbyte.
jl. (listw3.)
; rw listright par
rwrgx: jl. w3 listrgx. ; process listright
jl. w3 nextbyte.
sn w2 endstmi ; check for empty iolist
jl. esact.
rs. w2 repeat. ; repeat byte if not endstm
jl. nxmct. ; end action
listw3: 0
; skip comma after copying constant
cskipx: jl. w3 outcx.
comskipx: jl. w3 nextbyte.
sn w2 commai
jl. nxmct.
jl. error. + 6<1
\f
;rc4000 fortran ,pass 3 actions side 9
; mct actions/4
;actions for data constant list
data1x: al w0 0 ; start of const list
rs. w0 wstar. ; wstar=false, star allowed
rs. w0 wsign. ; set monadic sign allowed
jl. w3 outmct.
jl. nxmct.
data2x: al w0 0 ; comma in const list
rs. w0 wstar. ; star allowed
rs. w0 wsign. ; set monadic sign allowed
jl. nxmct.
data3x: rl. w0 wstar. ; after iconst
se w0 0 ; if star then error(3)
jl. error.+ 2<1
jl. w3 outmct. ; else outmct
al w0 1
rs. w0 wstar. ; set star illegal
jl. nxmct.
signmx: al w0 0 ; monadic - in data
rl. w1 wsign.
se w1 0
jl. error.+ 2<1 ; only one sign allowed
al w1 1
rs. w1 wsign. ; set sign met
se w0 0 ; if monadic -
jl. nxmct. ; then output icons 0 dyaminus
al. w1 zerobyt.
jl. w3 outseq.
al w0 0
jl. w3 outmct.
jl. nxmct. ; end action
signpx: al w0 1 ; monadic + in data
jl. signmx.+2 ; go to check no of signs
\f
;rc4000 fortran,pass 3 actions side 12
; leftpar after goto, computed goto
gcomx: al w0 gcomcl
rs. w0 stmclas.
jl. nxmct. ; end action
; identifier connected with call,assign,ass goto
callx:
implabx: al w0 0
jl. w3 outbt. ; output ident
jl. w3 nextbyte. ; copy poss imlied type
al w0 1 ; and extrepr, set repeat
rs. w0 repeat.
al w0 0
jl. w3 outmct. ; output imlied label nyte
jl. nxmct. ; or call byte
gasx: al w0 goasscl
rs. w0 stmclas. ; set statemnt type
jl. implabx.
; list left after call
callex: al w0 1
rs. w0 incount. ; initiate list elem count
jl. nxmct.
; esm after simple call
callesx: jl. w3 outx. ; outbyte (endcall)
al w0 spark ; for unstack-action in pass 6
jl. w3 outbyte. ;
jl. esact.
; label const in aritm if
arifx: rl. w1 iflab.
al w1 x1+1 ; iflab=iflab+1
rs. w1 iflab.
sl w1 4 ; if more than 3 labes then
jl. w3 error.+3<1 ; error(4)
jl. w3 outlabx. ; output label
stopx: al. w1 zerobyt.
jl. w3 outseq.
jl. esact.
\f
;rc4000 fortran ,pass 3 actions side 13
; right par after if expression
ifx: rs. w3 ifxretur.
al w0 0
jl. w3 outmct. ; outbyte (end if expr)
jl. w3 nextbyte. ; nextbyte to w2 and ibyte
sn w2 inconsi ; if ibyte eq integer const
jl. ifxarit. ; then aritm if else
rl. w1 logifcnt.
al w1 x1+ 1 ; count log if nesting
rs. w1 logifcnt.
al w0 1 ; if logical if repeat last byte
rs. w0 repeat.
jl. mainext. ; and start new statement
ifxarit: al w0 0
rs. w0 iflab. ; initiate count of labels
al w0 1
rs. w0 repeat. ; repeat last byte
al w0 arifcl
rs. w0 stmclas.
jl. (ifxretur.) ; end action
ifxretur: 0
\f
;rc4000 fortran , pass 3 actions side 14
; end stm in aritm if
arifesx: rl. w0 iflab.
se w0 3 ; if no of labels not 3
jl. w3 error.+3<1 ; then error(4)
jl. esact. ; goto end stm action
; actions for do statement
; do label
dolabx: jl. w3 inbyte. ; get label value
hs. w2 dosavlab.
jl. w3 inbyte.
hs. w2 dosavlab.+1
al w0 stmlab ; output label bytes
jl. w3 outbyte.
bl. w0 dosavlab.
jl. w3 outbyte.
bl. w0 dosavlab.+ 1
jl. w3 outbyte.
jl. nxmct. ; end action
\f
;rc4000 fortran ,pass 3 actions side 15
; equal in do
doligx: al w0 0 ; comma count=0
rs. w0 comcnt.
jl. w3 outmct. ; outmct(0)
jl. nxmct.
;comma in do list
docomx: al w0 -1 ; compute increment for
wa. w0 exprtyp. ; do-byte
wa. w0 comcnt.
jl. w3 outmct.
rl. w1 comcnt. ; increase comma count
al w1 x1+3
rs. w1 comcnt.
sh w1 6 ; if comma count gt 6
jl. nxmct.
jl w3 error. +5<1 ; then error(6)
\f
;rc4000 fortran ,pass 3 actions side 16
; end stm in do
doesx: al w0 -1 ; compute increment
wa. w0 exprtyp.
wa. w0 comcnt.
jl. w3 outmct.
rl. w0 comcnt.
sh w0 2 ; if comcnt tt 3
jl. w3 error.+5<1 ; then error(6)
se w0 3
jl. dostack.
al w0 icons ; outbyte(icons, 1, dostepc)
jl. w3 outbyte.
al w0 0
jl. w3 outbyte.
al w0 1
jl. w3 outbyte.
al w0 dostepc
jl. w3 outbyte.
dostack: al w0 1
rl. w1 dosavlab. ; stack do label
jl. w3 stack.
al w0 docl ; set statemt class to do
rs. w0 stmclas.
jl. esact. ; end action
\f
;rc4000 fortran, pass 3 actions side 17
; output label const
outlabx: al w0 0
jl. w3 outmct. ; output header
al w1 2 ; no of trailers
jl. w3 outcopy. ; copy trailers
jl. nxmct.
\f
;rc4000 fortran ,pass 3 definitions side 6
; definition of symbols used in bt, mct
; for actions and states /1
endunita = endunitx - acbas
endpassa = endpassx - acbas
labela = labelx - acbas
begfora = begforx - acbas
confora = conforx - acbas
trouba = troubx - acbas
extida = extidx - acbas
funca = funcx - acbas
type2a = type2x - acbas
outa = outx - acbas
type3a = type3x - acbas
blank1a = blank1x - acbas
blanka = blankx - acbas
zspeca = zspecx - acbas
comskipa = comskipx- acbas
cskipa = cskipx - acbas
esacta = esact - acbas
data1a = data1x - acbas
outca = outcx - acbas
data2a = data2x - acbas
data3a = data3x - acbas
rwrga= rwrgx- acbas
outbta= outbtx- acbas
empa= emptx- acbas
begunita= begunitx- acbas
implaba = implabx - acbas
declaba= declabx- acbas
dovala= dovalx- acbas
typea= typex- acbas
outlaba= outlabx- acbas
ariteqa= ariteqx- acbas
identa= identx- acbas
endla= endlx- acbas
callea= callex- acbas
callesa= callesx- acbas
prgra = prgrx- acbas
subra= subrx- acbas
stopa= stopx- acbas
skipia= skipix- acbas
\f
\f
;rc4000 fortran, pass 3 definitions side 7
;definition of symbols used in bt, mct
;for actions and states/2
gasa = gasx - acbas
gcoma = gcomx - acbas
calla = callx - acbas
ifa = ifx - acbas
arifa = arifx - acbas
arifesa = arifesx - acbas
dolaba = dolabx - acbas
doliga = doligx - acbas
docoma = docomx - acbas
doesa = doesx - acbas
listlea= listlex- acbas
listcoa= listcox- acbas
listrga= listrgx- acbas
signma= signmx- acbas
signpa= signpx- acbas
\f
pass3end:
stackbas:
stacont= stackbas+ 1
pass3lng = pass3end - e0
e30 = e30 + pass3lng ; length := length + length pass 3;
m. rc 83.08.29 fortran, pass 3
i.
e.
▶EOF◀