|
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: 185088 (0x2d300)
Types: TextFile
Names: »ftnpass73tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »ftnpass73tx «
;/
; alan wessel
; rc finsensvej 9
; pass 7,
; aw 85
s. a1200, b0, c0 ; slang names, a-names for symslang
k = e0 ; e-names in file processor
; introduction.
; pass 7 of the rc4000 fortran compiler is written in symbolic
; slang which allows proper names and discriminates these on
; the first 8 characters. the code must therefore be transformed
; into slang code by the symslang program.
; the use of slang and the 12-bit address part in rc4000 restricts
; the order of code parts and definitions. to find a particular
; code, help may be found in the index of contents, and also in
; the alphabetically ordered action address table, where the
; corresponding code is referenced.
; the arrangement of the process area at translation is:
; 1. file processor
; 2. pass 0, resident part
; 3. pass 7, resident part, see contents
; 4a. pass 7, initiation
; 4b. action stack and operand stack
; 5. *** used operands in forward stack
; 6. *** performed actions in backward stack.
; the *** indicates that this is a test facility.
\f
;/ contents
; contents.
; introduction 1
; contents 2
; purpose and funtioning of pass 7 3
; structure of pass 7 output 4
; definition of names 5
; directing bytes for pass 8 5
; running system entries 9
; general pass or pass 0 10
; types, kinds, and registers 11
; pass 7 start of instructions 12
; words for test printing 12
; error messages 13
; testing, and end statement 14
; actions for initiation and termination 16
; pass end, unit initiation and end line 16
; declarations for arrays and zones 18
; data initiation 19
; operand stack 20
; definition of names in operand stack 20
; description of contents of the operand stack 22
; operand actions 24
; register operations 24
; operand descriptor actions 26
; operand exchanging 27
; load and release operands 28
; operand address handling 30
; working variables 32
; input, output, and copying 35
; transmission of lists, copying of single bytes 35
; input of operands 36
; output of operands 38
; internal variables for pass 7 41
; stepping stones and pass 7 pointers 42
; main control on directing bytes from pass 6 43
; standard actions 44
; action stack actions 46
; interrupt handling in pass 7 47
; actions on executable statements 48
; arithmetic 48
; description of results 50
; array and zone variables 51
; relations 52
; masking and shift 54
; storing 55
; constant operand test, and conversions in pass 7 56
; if statements 57
; do statements 58
; actions for procedure calls 59
; call of procedures 59
; parameter transmission 60
; return from program units 62
; test initiation 63
; action address table, alphabetic list of actions 64
; auxiliary action table, alphabetically ordered 67
; special action table 69
; main action table 70
; initiation of pass 7 74
\f
;/purpose and function
; purpose and functioning of pass 7.
; the purpose of pass 7 is to transform the byte string from pass 6
; into a string for pass 8 suited for generation of machine code.
; pass 7 disposes the use of registers and of working variables by
; keeping track of the operands.
; pass 6 delivers a sequence of bytes which is an inverse polish
; representation of the fortran program. the structure of the byte
; string is divided into elements of the classes: operators, operands,
; and lists, when these classes are taken in their widest sense.
; 1. operators: a. the operator directing byte
; b. sometimes followed by one or more parameter bytes
; 2. operands : a. the operand directing byte
; b. a number of bytes describing the operand
; 3. lists : a. the list directing byte
; b. a byte giving the number of bytes in the list
; c. the list consisting of a number of bytes, see 3b
; a detailed description of pass 6 output is given in pass 6, chapter 3.
; pass 7 will act on the directing bytes from pass 6 by fetching the
; corresponding action entry from the action table (see at the end
; of pass 7) and put it into the action stack. then the first action
; of this entry is performed.
; each action entry consists of actlng (at present 4) actions, each
; action consists of a standard action and a parameter for this
; packed into one byte as: parameter < b0 + standard action.
; the standard actions are:
;
; name parameter function
; doo reference to code some pass 7 code is activated
; out directing byte for pass 8 the byte is output
; aux auxiliary action entry new actions are put into stack
; con auxiliary action entry current actions are overwritten
; nex - next directing byte from pass 6
; err - error in action table
; operators from pass 6 generally activates code and will often
; operate on the operand stack.
; operands are entered into an operand stack. the structure of
; this is described in the operand stack section.
; lists are usually just copied to pass 8.
\f
;/structure of output
; structure of pass 7 output.
; the output from pass 7 is made to suit the backwards working pass 8.
; the structure of the output may be described in syntactic form in
; which :a:b: means that the prestanding element may occur from a to
; b times, and a * for b indicates an unlimited number of times.
; <pass 7 output> ::= ( <operator> ( <operand> ):0:*: )
; ( <label directing byte> )
; ( <list> ) :1:*:
; <operator> ::= ( <parameter byte> ):0:*: <operator dir.byte>
; <operand> ::= ( <parameter byte> ):1:*: <operand dir.byte>
; <label dir.byte>::= <integer label number>
; <list> ::= (<byte>):n:n: <integer byte n> <list dir.byte>
; the directing bytes are defined in the section directing bytes.
; the structure of the operands are:
; <operand> ::= ( (<integer> ) ( opx0 ) )
; ( (-s:variable> ) ( opx1 ) )
; ( ( opx2 ) )
; ( ( opx3 ) )
; ( ( opx0i ) )
; ( ( opx2i ) )
; ( ( opx3i ) )
; ( <comno><c:variable> opcommon )
; ( <external number> opext )
; ( < 2 bytes > literal2 )
; ( < 4 bytes > literal4 )
; ( < 8 bytes > literal8 )
; the transformation of pass 7 output into generated code is described
; somewhere
; special nomenclature.
; in the description and comments to the code the following symbols
; are used
;
; symbol meaning
; a: absolute address of
; c: relative within common
; d: relative within description
; g: relative within global segment
; r: relative on present segment
; s: relative to stack pointer, x2-relative
; -s: indicating negative sign of s:
; t: relative to stack pointer 2, i.e. in array/zone area
\f
;/directing bytes
; directing bytes for pass 8.
; ---------------------------
; the definition of the directing bytes for pass 8 are placed
; as the first symslang names. in this way the a-names of the
; symslang translation includes the value of the directing byte.
; the symslang identifier listing will then hold:
; a <directing byte value> <directing byte name>
; when directing bytes are used as parameters to the standard
; action out only, the definition includes the b0-shift.
b0=3 ; structure of action: action parameter < b0 + main action
; for output dir.byte: dirbyte value < b0 + out
;count , name ;
c0=0 ; ; units, lists, entries.
c0=c0+1, end7 =c0 ; end pass 7
c0=c0+1, pass7 =c0<b0; pass 7 start for pass 8
c0=c0+1, unit7 =c0<b0; begin program unit
c0=c0+1, funit7 =c0<b0; end program unit
c0=c0+1, newline =c0<b0; new line
c0=c0+1, glolist =c0<b0; list of global entries
c0=c0+1, comlist =c0<b0; list of commons
c0=c0+1, comzones =c0<b0; list of zones in commons
c0=c0+1, extlist =c0<b0; list of externals
c0=c0+1, entryvalue=c0<b0; list of local entry points
c0=c0+1, labvarinit=c0<b0; list of label variables
c0=c0+1, entrypoint=c0<b0; main entry point
c0=c0+1, dataentry =c0<b0; data entry point
c0=c0+1, dataexist =c0 ; data in program unit
c0=c0+1, suite =c0<b0; reserve suite on segment
; ; declarations.
c0=c0+1, entry =c0<b0; entry declaration
c0=c0+1, label =c0<b0; label declaration
c0=c0+1, locinit =c0<b0; initiate local array/zone
c0=c0+1, rlw1 =c0 ; register load w1
c0=c0+1, cominit =c0<b0; initiate common array/zone
c0=c0+1, zoninit =c0<b0; initiate local zone
c0=c0+1, starray =c0<b0; initiate parameter array
c0=c0+1, extzone =c0<b0; external zone
; ; operands.
c0=c0+1, opx0 =c0 ; direct indexing
c0=c0+1, opx1 =c0 ;
c0=c0+1, opx2 =c0 ;
c0=c0+1, opx3 =c0 ;
c0=c0+1, opx0i =c0 ; indirect indexing
c0=c0+1, opx2i =c0 ;
c0=c0+1, opx3i =c0 ;
c0=c0+1, opcommon =c0 ; common operand
c0=c0+1, opext =c0 ; external operand (standard variable)
c0=c0+1, literal2 =c0 ; 2 byte operand
c0=c0+1, literal4 =c0 ; 4 byte operand
c0=c0+1, literal8 =c0 ; 8 byte operand
\f
;/directing bytes 2
; ; register w1, arithmetic, masking.
c0=c0+1, hlw1 =c0 ; logical arithmetic
c0=c0+1, hsw1 =c0 ;
c0=c0+1, rsw1 =c0 ; register store w1
c0=c0+1, loadw1 =c0 ; register load w1, address of value
c0=c0+1, addw1 =c0 ; integer or address arithmetic
c0=c0+1, subw1 =c0 ;
c0=c0+1, dosub =c0<b0; subtract and complement
c0=c0+1, mulw1 =c0 ;
c0=c0+1, divw1 =c0 ;
c0=c0+1, alw1 =c0<b0; load address
c0=c0+1, acw1 =c0<b0; complement
c0=c0+1, lsw1 =c0 ; shift single
c0=c0+1, ldw1 =c0 ; shift double
c0=c0+1, notw1 =c0 ; not single
c0=c0+1, notw01 =c0 ; not double
c0=c0+1, law1 =c0 ; and single
c0=c0+1, law01 =c0 ; and double
c0=c0+1, low1 =c0 ; or single
c0=c0+1, low01 =c0 ; or double
c0=c0+1, dlw1 =c0 ; double register
c0=c0+1, dsw1 =c0 ;
c0=c0+1, faw1 =c0 ; real arithmetic
c0=c0+1, fsw1 =c0 ;
c0=c0+1, fmw1 =c0 ;
c0=c0+1, fdw1 =c0 ;
c0=c0+1, aaw1 =c0 ; long arithmetic
c0=c0+1, ssw1 =c0 ;
c0=c0+1, signlong =c0 ; w0 := sign(long)
c0=c0+1, signdoub =c0 ; w0 := sign(double)
; ; registers w0, w2, w3, uv, dr.
c0=c0+1, loadw0 =c0 ; w0
c0=c0+1, rlw3 =c0<b0; w3
c0=c0+1, rsw3 =c0<b0;
c0=c0+1, addw3 =c0<b0;
c0=c0+1, regtouv =c0<b0; uv register
c0=c0+1, reguv0 =c0<b0;
c0=c0+1, uvtow01 =c0 ;
c0=c0+1, drload =c0 ; dr register
c0=c0+1, drstore =c0 ;
c0=c0+1, draddr =c0<b0;
; ; conversion.
c0=c0+1, iconvl =c0<b0; integer to long
c0=c0+1, lconvi =c0<b0; long to integer
c0=c0+1, ifloatr =c0<b0; integer to real
c0=c0+1, rtrunci =c0<b0; real to integer
c0=c0+1, rconvc =c0<b0; real to complex
c0=c0+1, ctruncr =c0<b0; complex to real
\f
;/directing bytes 3
; ; skip, relation, check.
c0=c0+1, shw0 =c0 ; sh w0
c0=c0+1, shw1 =c0 ; sh w1
c0=c0+1, slw1 =c0 ; sl w1
c0=c0+1, ; (not used)
c0=c0+1, relation =c0<b0; relation skip
c0=c0+1, amodify =c0 ; am instruction
c0=c0+1, chlower =c0<b0; check lower index
c0=c0+1, zindex =c0<b0; check zone index
c0=c0+1, zrechk =c0<b0; check zone record length
c0=c0+1, chzono =c0<b0; check number of zones
; ; jumps, points.
c0=c0+1, xxforw =c0<b0; bypass label forwards
c0=c0+1, goforw =c0 ; goto bypass label forwards
c0=c0+1, xxback =c0<b0; bypass label backwards (data statement, optimised)
c0=c0+1, gosimpl =c0<b0; goto label
c0=c0+1, goif =c0<b0; goto arithmetical
c0=c0+1, goiforw =c0<b0; goto conditional
c0=c0+1, prepjump =c0<b0; prepare jump
c0=c0+1, xxbackw =c0<b0; bypass label backwards (general form)
c0=c0+1, gobackw =c0<b0; goto bypass label backwards
c0=c0+1, goexternal=c0 ; goto external procedure
c0=c0+1, goformal =c0 ; goto formal procedure
; ; statements.
c0=c0+1, complist =c0<b0; computed goto list
c0=c0+1, rsw2 =c0<b0; first do-loop := false
c0=c0+1, domul =c0<b0; test sign of do
c0=c0+1, doclear =c0<b0; w0w1 := 0
c0=c0+1, dogofor =c0<b0; conditional goto after-do-loop
c0=c0+1, xxchang =c0<b0; exchange the top two xx-labels
c0=c0+1, ; (not used)
c0=c0+1, ; (not used)
c0=c0+1, ; (not used)
c0=c0+1, ; (not used)
c0=c0+1, ; (not used)
c0=c0+1, ; (not used)
c0=c0+1, ; (not used)
c0=c0+1, ; (not used)
c0=c0+1, parproc =c0 ; parameter procedure
c0=c0+1, lastused =c0 ; set parameter formals
c0=c0+1, point01 =c0<b0; call
c0=c0+1, return =c0<b0; return from program unit
\f
;/directing bytes 4
; ; formats.
c0=c0+1, begfor =c0<b0; format begin
c0=c0+1, contfor =c0<b0; format continue
c0=c0+1, openfor =c0<b0; format open
c0=c0+1, closfor =c0<b0; format closed
; ; call running system.
c0=c0+1, gors =c0<b0; jump to running system,
; ; trouble.
c0=c0+1, trouble =c0 ; trouble
c0=c0+1, troublop =c0 ; trouble operand
; directing bytes also used in out actions
opx0a = opx0 <b0
opx1a = opx1 <b0
opx2a = opx2 <b0
opx3a = opx3 <b0
opx2ia = opx2i <b0
rlw1a = rlw1 <b0
rsw1a = rsw1 <b0
loadw1a = loadw1 <b0
addw1a = addw1 <b0
subw1a = subw1 <b0
mulw1a = mulw1 <b0
lsw1a = lsw1 <b0
loadw0a = loadw0 <b0
dlw1a = dlw1 <b0
dsw1a = dsw1 <b0
drloada = drload <b0
shw0a = shw0 <b0
chupper = shw1 <b0
amodifa = amodify<b0
goforwa = goforw <b0
troubla = trouble<b0
\f
;/running system entries
; running system entries
; ----------------------
; entry to running system is described to pass 8 as:
; <running system number> gors
frsno = 150 ; base number for fortran running
; ; system entries (see also pass8, pass9)
coxadd = (:frsno+14:) ; complex arithmetic
coxsub = (:frsno+15:) ;
coxmul = (:frsno+16:) ;
coxdiv = (:frsno+17:) ;
dbladd = (:frsno+10:) ; double arithmetic
dblsub = (:frsno+11:) ;
dblmul = (:frsno+12:) ;
dbldiv = (:frsno+13:) ;
longmul = (:frsno+ 0:) ; long arithmetic
longdiv = (:frsno+ 1:) ;
iexpoi = (:frsno+ 2:)<b0 ; exponentiation
lexpoi = (:frsno+ 3:)<b0 ;
rexpoi = 2 <b0 ;
rexpor = 1 <b0 ;
dexpod = (:frsno+ 4:)<b0 ;
lfloatr = 46 <b0 ; conversions
lfloatd = (:frsno+ 5:)<b0 ;
rtruncl = 47 <b0 ;
rconvl = 43 ; (rounding real to long)
rconvd = (:frsno+ 6:)<b0 ;
dtruncl = (:frsno+ 7:)<b0 ;
dtruncr = (:frsno+ 8:)<b0 ;
readinit = (:frsno+18:)<b0 ; read
readcall = (:frsno+20:)<b0 ;
writeinit= (:frsno+19:)<b0 ; write
writecall= (:frsno+21:)<b0 ;
gopoint = 53 <b0 ; goto point
endreg = 6 <b0 ; end register expression
endaddr = 8 <b0 ; end address expression
initzone = 9 <b0 ; zone initiation
zonerel = 10 <b0 ; zone release
noroom = 17 <b0 ; array index error
stop = 45 <b0 ; stop fortran run
\f
;/general pass names
; gpa: general pass entries.
; --------------------------
; obs may be substituted by stepping stones
; name function of jl.w3 name. unchanged reg
take = e2 ; w2 := next input byte 0 1
give = e3 ; output byte (w0) 0 1 2
ees0 = e87+1000 ; warning.yes
message0 = e4 ; message(w1=a:text) 0 2
alarm = e5 ; alarm (w1=a:text) 0 2
intpass0 = e36 ; interrupt(w2=a:dump words), terminate
carret = e1 ; count in gpa:lineno 0 1 2
printbyte= e16 ; print byte (w0) 0 1 2
endpass = e7 ; terminate pass
writechar= e12 ; writechar(w0=char) 0 1 2
writetext= e13 ; writetext(w1=a:text) 0 2
writeint = e14 ; write integer(w0=integer) 0 1 2
; name variable holding
lineno = e6 ; actual line number
stackover= e10 ; text: process too small
modebits = e17 ; mode of translation
modebit2 = e29 ; (more modebits)
chindex = 1<3 ; bit when index check
spillbit = 1<6 ; bit when interrupt on integer overflow
truncbit = 1<0 ; bit when truncation instead of rounding
loadmap = 1<3 ; bit when loadmap wanted
lastword = e9+4; a:last word for use by pass 7
\f
;/definitions
; definition of types and kinds
; ----------------------------
notype = 0
logical = 1
integer = 2
real = 3
long = 4
double = 5
complex = 6
undefin = 7 ; undefined used when trouble
; kinds for parameter transmission etc
pproc = 0 ; procedure
parray = 16 ; zone array and array-type
pzone = 23 ; zone
psimple = 24 ; simple-type
plabel = 31 ; label
procval = -3 ; a:value of procedure is stored in x2+procval
parbytes= 4 ; number of return description bytes in calls
; names on registers and register parts
; -------------------------------------
reg0 = 0 , reg0last = 1 , byte0 = 0
reg1 = 2
reg2 = 4 , reg2last = 5
reg3 = 6 , reg3last = 7
; sizes of common descriptions, as transmitted between
; pass 6 and pass 8
comsize = 12 ; size of common description
entrsize= 12 ; size of entry description
extsize = 12 ; size of external description
zcomsize= 17 ; size of zone-common description
\f
;/pass 7 start
; pass 7 start of instructions
; ----------------------------
w.
start7: length7 ; length of pass 7 in bytes
h.
entry7 ; pass 7 entry relative to start7
7<1 +0 ; pass number<1 + no change of direction
w.
entry7 = k - start7
jl. init7. ; goto initialise via stepping stone
; words for print addresses for test output
; the following words are placed at the start of pass 7 to be used when
; calling the file processor utility program: print when testing the
; performance of pass 7
; with the present file processor (system 1) and pass 0 (1.7.70)
; the first word of pass 7 is in byte 2658 of the process area.
; when the etest is included a nice printing of the core area
; dumped to the area pass7dump is given by:
; head 1
; u = set bs pass7dump 0 0 0 7.0
; print u 2658.2688 2664.2666.i integer 2668.2670.i
; head 1
; message pass7 operand stack and used operands
; print u byte words.5 2672.2674.i 2676.2678.i
; head 1
; message pass7 performed actions backwards stack
; print u byte words.4 2680.2682.i
ppp1:
0 ; a:pointer and stepping stone area
ppp2:
0 ;
pwk1:
0 ; a:work pointers
pwk2:
0 ;
pop1:
0 ; a:operand stack area
pop2:
0 ;
pup1:
0 ; a:used operands area
pup2:
0 ;
pac1:
0 ; a:actions performed area
pac2:
0 ;
opprint = 200
popinit = 100
pupinit = opprint+800
pacinit =-2000
\f
;/error messages
conindex: <:constant index<0>:> ; constant index error checked in pass 7
overflow: <:overflow<0>:> ; overflow in constant arithmetic
notdone: <:not implemented<0>:> ; unknown byte from pass 6
stacktxt: <:run stack full<0>:> ; running stack will exceed 2048 bytes
; <:operand stack<0>:> ; operand stack not empty
; <:more actions<0>:> ; action stack not empty
; <:stack pointer<0>:> ; w1 <> opandtop
; <:wrong standard action:>; error in action tables
; <:process too small:> ; too many operands in stack
; other messages are given when tests are included
runstack: al.w1 stacktxt. ; running stack overflow.
jl. alarm. ; gpa:alarm
notimplx: ; directing byte not implemented.
am notdone -overflow;
overmess: ; overflow in constant arithmetic.
am overflow-conindex;
errconix: ; error in constant index.
al.w1 conindex. ; w1 := a:text
errmess:
; ; error message during pass 7.
; ; call: w1 := a:text
; ; jl.w3 errmess.
; ; exit: w1 := a:top operand descriptor
; ; w0,w2 unchanged
; ; output
; ;
; ; line xxx error message
ds.w0 save30. ; save w3 and w0
jl.w3 message. ; gpa:message(error text)
al w0 trouble ;
jl.w3 outbyte. ; gpa:outbyte(trouble)
rl.w0 save30. ; restore w0
rl.w1 opandtop. ; w1 := a:top operand descriptor
jl. (savew3.) ; return
\f
;/testing
; pass 7 includes test facilities for running in of the code:
atest= 1 ; counting the number of inbytes to and outbytes from
; pass 7, the result is given as the 4.th and 5.th values
; in pass information.
; storage requirement: 18 words
; time requirement : 9 milliseconds per segment(512 bytes)
btest= 1 ; testing of stacks empty at statement end
; error messages: opstack error operand stack not empty
; or under limit
; more actions last actions not performed
; storage requirement: 34 words
ctest= 1 ; testing that the w1-register holds the address of the
; top operand descriptor
; error message: top not in w1
; storage requirement: 29 words
dtest= 1 ; testing wrong entries to tables and stacks
; error message: action stack error actions in operand stack
; storage requirement: 17 words
etest=-1 ; comprising the thorough test output in the process area
; should only be used for reasonably small test programs
; 1. zeroing of non-resident part of pass 7 and rest of
; process area at initiation
; 2. zeroing of operand entries at time of release
; this spoils the use of multiple assignment in programs
; 3. preparation of the printing of test output stored in
; the process area:
; a. operand descriptions at time of release
; b. performed actions as 2 bytes: standard action, parameter
; storage requirement: 70 words
; the xtest is included in the slang translation when the value >= 0
; while it is excluded by giving xtest a negative value.
; the tests are placed in such a way that no definition of names
; are included, thus all symslang or slang names are defined and
; an automatic generation of the compressed byte value - symslang
; name table is possible.
\f
;/testing 2
endstatx: ; end statement.
al w2 0 ; set working variable pointers
rs.w2 workrel. ; workrel = 0
rs.w2 worklev. ; worklevel = 0
rl.w2 workinit. ; present bottom of working variables
rs.w2 workfree. ; workfree = workinit
c. btest
rl.w1 opandtop. ;***
sn.w1 (opandbot.);*** if operandstack empty
jl. actest. ;*** then goto test action stack
sh.w1 (opandbot.);*** if w1 < opandbot
rl.w1 opandbot. ;*** then w1 := opandbot
rs.w1 opandtop. ;*** set opandtop
al.w3 0 ;*** return to here if not empty
al w2 opfault ;*** set error check
hs w2 x1+opcheck ;***
se.w1 (opandbot.);*** if opstack not empty
jl. topdownx. ;*** then reduce opstack
al.w1 optext. ;*** error message(opstack not empty)
jl.w3 errmess. ;***
z.
actest:
c. btest
rl.w1 acstabot. ;*** a:action stack
al w1 x1+actlng ;*** ;
rl w2 x1 ;*** last actions
se w2 0 ;*** if more proper actions
jl. acterror. ;*** then goto error in action stack
sn.w1 (acstatop.);*** if action stack pointer at bottom
z.
jl. curract. ; then goto current actions
acterror:
c. btest
al.w3 curract. ; set return
rs.w1 acstatop. ;*** acstatop := acstabot + action length
al.w1 actext. ;***
jl.w3 errmess. ;*** error message(more actions)
z.
jl. curract. ; goto current actions
optext:
c. btest, <:operand stack<0>:> z. ;***
actext:
c. btest, <:more actions<0>:> z. ;***
; *** test facility for operand stack
; a message is given when w1 <> opandtop
; call jl.w3 topinw1. , see stepping stones
; exit w1 := opandtop , w0,w2 unchanged
topinw1x:
c. ctest
sn.w1 (opandtop.) ; if w1 = opandtop
jl x3 ; then return
ds.w0 topin0. ; save w30
al.w1 topmess. ; w1 := a:text
jl.w3 message. ; gpa:message
ac.w0 start7. ; - a:pass7 start
wa.w0 topin3. ; program relative of call point
jl.w3 printbyte. ; gpa:printbyte
rl.w0 topin0. ; restore w0
rl.w1 opandtop. ; w1 := a:opandtop
jl. (topin3.) ; return
z.
topin3: 0 ; return address
topin0: 0 ; save w0
topmess: <:stack pointer:> ; error message
\f
;/ pass end and unit initiation
passendx: ; end of pass 7.
c. etest
rl.w1 opandmax. ;*** set test print pointers correct
sn w1 0 ;***
rl.w1 opandtop. ;***
rs.w1 pop2. ;***
rl.w1 opused. ;***
al w1 x1+oplength ;***
rs.w1 pup2. ;***
rl.w1 watch. ;***
wa.w1 opandlim. ;***
rs.w1 pac1. ;***
z.
c. atest
rl.w1 passin. ;***
rs.w1 e9. ;*** pass information 1 = no.of inbytes
rl.w1 passout. ;***
rs.w1 e9.+2 ;*** pass information 2 = no.of outbytes
z.
jl. endpass. ; gpa:end pass
\f
;/pass end and unit initiation 2
areasx: ; output pass information.
jl.w3 inbyte. ; gpa:inbyte(first byte of buf.inf)
hs.w2 savebyte. ;
jl.w3 inbyte. ; gpa:inbyte(second byte of buf.inf)
hs.w2 savelast. ; savebyte := buffer length
jl.w3 inbyte. ; w2 := maximal parameter number
ls w2 2 ; 4 bytes for each parameter(formal)
al w2 x2+parbytes ; + bytes for parameter information
rs.w2 savew2. ; savew2 := size of parameter area
al w0 x2 ; for use by initiation of in-output
jl.w3 outbyte. ; outbyte(parameter area - 2)
rl.w2 workmax. ; w2 := -s:free stack variable
ws.w2 savebyte. ; -size of array and zone area
ws.w2 savew2. ; -size of parameter area
rl.w0 modebit2. ; w0 := modebit2;
so w0 loadmap ; if loadmap not wanted then
jl. outlit2. ; output(-stacksize) as two byte literal;
al.w1 localtxt. ;
jl.w3 writetext. ; writetext (<:local variables:>);
ac w0 x2 ; w0 := stacksize;
sz w0 1 ; if stacksize odd then
ba.w0 1 ; make stacksize even;
jl.w3 writeint. ; write integer (stacksize);
32<12+8 ;
jl. outlit2. ; output(-stacksize) as two byte literal;
localtxt: <:<10>local variables: <0>:>
spacetxt: <: :>
h. ;
listelem: 0, r. zcomsize ;
w. ;
txtcommon: 8<12 + comsize , <:<10>common list:<0>:>
txtextern: extsize , <:<10>external list:<0>:>
txtzcomm: 8<12 + zcomsize , <:<10>zone common list:<0>:>
outextx: am txtextern-txtcommon;
outcomx: am txtcommon-txtzcomm;
outzcomx: al.w2 txtzcomm.+2 ; w2 := start of heading text;
rs.w2 savew2. ; save heading address;
bz w0 x2-2 ; get index for size-word;
hs.w0 sizendx. ;
bz w1 x2-1 ; param := size of descriptor;
rs.w1 savew1. ; common-descr size := param;
rs.w1 savew0. ; printed := descr size;
nxtentry: ; next entry:
rl.w1 savebyte. ;
ws.w1 savew0. ;
sh w1 -1 ; if no.list size < printed then
jl. restlist. ; goto copy rest of list;
al w1 0 ; count := 0;
copylist: ;
jl.w3 inbyte. ; w2 := gpa:inbyte;
hs.w2 x1+listelem. ; listelem(count) := byte;
al w0 x2 ; w0 := inbyte;
jl.w3 outbyte. ; gpa:outbyte(inbyte);
al w1 x1+1 ; increase(count);
se.w1 (savew1.) ; if count <> descr size then
jl. copylist. ; goto copylist;
wa.w1 savew0. ; printed := printed
rs.w1 savew0. ; + descr size;
rl.w0 modebit2. ; if loadmap not wanted then
so w0 loadmap ;
jl. nxtentry. ; goto next entry;
al w1 0 ;
rx.w1 savew2. ; heading := false;
se w1 0 ; if old heading <> 0 then
jl.w3 writetext. ; writetext (heading);
al w0 10 ;
jl.w3 writechar. ; writechar (newline);
al w2 ; size index ; w2 := index;
sizendx = k-1
sn w2 0 ; if index <> 0 then
jl. entrname. ;
rl.w0 x2+listelem. ;
jl.w3 writeint. ; write integer (listelem.index);
32<12+11 ;
entrname: al.w1 spacetxt. ;
jl.w3 writetext. ; writetext(name of common);
jl. nxtentry. ; goto next entry;
restlist: ; copy rest of list:
wa.w1 savew1. ; w1 := number of rest bytes;
jl.w3 inoutn. ; copy n bytes;
jl. saveoutx. ; goto outbyte(no.list size);
getentrx: ; copy whole entry-list to stack:
rl.w2 opandlim. ;
ws.w2 savebyte. ; reserve room for entry-list;
rs.w2 opandlim. ;
al.w1 stackover. ;
sh.w2 (opandbot.) ; if no room for list then
jl.w3 alarm. ; alarm (<:stack overflow:>);
al w1 0 ; count := 0;
readlist: ;
jl.w3 inbyte. ; w2 := gpa:inbyte;
am. (opandlim.) ;
hs w2 x1+oplength ; entry-list(count) := byte;
al w0 x2 ; w0 := inbyte;
jl.w3 outbyte. ; gpa:outbyte(inbyte);
al w1 x1+1 ; increase(count);
se.w1 (savebyte.) ; if count <> savebyte then
jl. readlist. ; goto readlist;
jl. saveoutx. ; goto outbyte (no.list size);
newltxt: <:<10> <0>:>
entrytxt: <:<10><10><10>entry list:<0>:>
outentrx: ; output part of entry point list:
jl.w3 inbyte. ; w2 := number of local entries := inbyte;
rl.w0 modebit2. ;
so w0 loadmap ; if loadmap not wanted then
jl. curract. ; goto current actions;
al.w1 entrytxt. ;
jl.w3 writetext. ; writetext (<:entry list:>);
; al w2 1 ; **** preliminary ****
; jl.w3 inbyte. ; w2 := number of local entries := inbyte;
entrnxt: ; next entry:
al.w1 newltxt. ;
jl.w3 writetext. ; writetext (newline + spaces);
rl.w1 opandlim. ;
al w0 x1+entrsize ; release part of stack;
rs.w0 opandlim. ;
al w1 x1+oplength ;
jl.w3 writetext. ; writetext (name of entry);
al w2 x2-1 ; decrease (number of entries);
se w2 0 ; if number of entries <> 0 then
jl. entrnxt. ; goto next entry;
jl. curract. ; goto current actions;
uninitx: ; initialise for program unit.
al w0 0 ;
hs.w0 datatrue. ; datatrue := 0
c. etest
rl.w2 opandbot. ;*** initiate print words for testing
rs.w2 pop1.
al w2 x2+opprint
rs.w2 pup1.
rl.w2 opandbot.
al w2 x2+popinit
rs.w2 pop2.
al w2 x2+pupinit
rs.w2 pup2.
rl.w2 opandlim.
rs.w2 pac2.
al w2 x2+pacinit
rs.w2 pac1.
al.w2 init7.
rs.w2 ppp1.
al.w2 opused.
rs.w2 ppp2.
al.w2 workfree.
rs.w2 pwk1.
al.w2 workrel.
rs.w2 pwk2. ;*** end initiate print words
z.
jl. curract. ; goto current actions
endlinex: ; count line number.
al.w3 curract. ; set return do current actions
jl. carret. ; goto gpa:car return
\f
;/ declarations
declbegx: ; begin declare array or zone.
jl.w3 inbyte. ; gpa:inbyte
rs.w2 savebyte. ; savebyte := inbyte
al w1 2 ;
jl.w3 inoutn. ; copy 2 bytes
al w0 literal2 ;
jl. outcurr. ; outbyte(literal2); goto current act
loczonex: ; local zone information.
al w1 5 ;
al.w3 curract. ; set return
jl. inoutn. ; copy 5 bytes
paramarx: ; parameter array declaration.
c. ctest, jl.w3 topinw1. z. ; *** *** test w1 = opandtop
rl.w2 type. ;
rs.w2 savetype. ; savetype := type of array
jl.w3 inbyte. ; w2 := -s:a:array0
hs w2 x1+opcopy ; opcopy := w2
jl. arrayopx. ; get rest of array descriptor
; 6 bytes is read into operand stack
initarrx: ; initiate parameter array.
; ; entry: savetype := type of array
rl.w2 savetype. ; w2 := type of array
al w0 2.10011 ; w0 := real type mask
se w2 real ; if type <> real
al w0 2.10111 ; then w0 := not real type mask
jl.w3 outbyte. ; gpa:outbyte(type mask)
al w0 2.10000 ; w0 := compare base mask
wa.w0 savetype. ; w0 := compare type mask (:=w0+type)
jl.w3 outbyte. ; gpa:outbyte(compare mask)
bl.w2 x2+sort. ; w2 := sort(type)
bl.w0 x2+length. ; w0 := length(sort)
jl. outcurr. ; outbyte(length); goto current action
fixarrx: ; calculate test for fix array.
c. ctest, jl.w3 topinw1. z. ; *** *** test w1 = opandtop
rl w2 x1+opupper ;
ws w2 x1+oplower ;
am. (type.) ;
bl.w3 sort. ; w3 := length(sort);
ac w3 x3 ;
ls w2 x3 ; test := (upper-lower) shift (-length);
jl. outlit2. ; output test as 2 byte literal
pzarrayx: ; zone/zone array as parameter.
bl.w0 savelast. ; w0 := savebyte (no.zones descr)
al.w3 nextact. ; parameter kind decides return :=
se w0 0 ; if zone then next actions
al.w3 curract. ; else (zone array) current actions
sl w0 0 ; if not adjustable zone array
jl. inbyte. ; then dummy gpa:inbyte ; return
al w2 zparact ;
jl. newspact. ; goto enter adj.zone array actions
\f
;/ declarations
ixformlx: ; check size of formal array:
; resulting sequence:
; ls w1 length (or rl w3 length)
; ; w0 = size of actual array
; ; w1 = size of formal array
; sh w1 (0)
; sh w1 0
; jl. indexalarm.
al w0 0 ;
jl.w3 outbyte. ; outbyte(0);
al w0 opx0i ;
jl.w3 outbyte. ; outbyte(opx0i);
al w0 chlower>b0 ;
jl.w3 outbyte. ; outbyte(chlower);
al w2 0 ;
jl.w3 outconst. ; outconst(0);
jl. curract. ; goto current action;
\f
;/ data initiation
dataexix: ; if data statement in program unit
datatrue= k+1 ; then outbyte(dataexist).
al w0 0 ; w0 := datatrue (initial value = 0)
sn w0 dataexist ; if datatrue = dataexist
jl.w3 outbyte. ; then gpa:outbyte(dataexist)
jl. curract. ; goto current actions
datax: ; set data exists.
al w0 dataexist ;
hs.w0 datatrue. ; datatrue := dataexist
jl. curract. ; goto current actions
datasetx: ; make pointers to data array.
c. ctest, jl.w3 topinw1. z. ; *** *** test w1 = opandtop
rl.w2 type. ;
bl.w2 x2+sort. ; w2 := sort(type of data array)
rs.w2 savesort. ; savesort := sort
jl.w3 datalast. ; save data last in work
rs.w2 workrel. ; workrel := -s:work(data last)
rl.w3 worklev. ; worklev = worklev + 1
al w3 x3+1 ;
rs.w3 worklev. ;
al.w3 curract. ; set return to current actions
jl. towork2x. ; save data pointer in work
databytx: ; byte length of data array to set.
rl w2 x1+opcon ; w2 := constant before data star
am. (savesort.) ;
ls w2 0 ; w2 := constant shift sort(datarray)
jl. outlit2. ; goto output bytelength as literal2
datavalx: ; update data pointer, store value.
am. (savesort.) ;
bl.w2 length. ; w2 := length(savesort)
jl.w3 outconst. ; outbyte(length); outbyte(opx0)
am. (savesort.) ;
bl.w0 regstore. ; w0 := regstore(savesort)
jl. outcurr. ; outbyte(regstore); goto current act
datasuix: ; send sort of data.
rl.w0 savesort. ; w0 := sort of data to initiate
jl. outcurr. ; outbyte(sort); goto current actions
\f
;/operand stack
; operand stack, definition of elements and variables
; ---------------------------------------------------
; obs if the organisation of the operand stack layout is changed
; the action opexch may have to be revised
opcopy = 0 , opcomno = 0 , oplabel = 0
opplace = 1 , opcomrel = 1
opzoneno = 2
opbytix = 3
opupper = 5
oplower = 7 , oprange = 7 , opcon = 7
opcheck = 8 ,
opdescr = opcheck+1 ; opcheck,opdescr must be in common word
oplength = 10 ; length of operand stack entry
; operand kinds
; ------------- ; obs change of the numeration of kinds must
; be accompanied by changes in tables:
; toparts, addrset, workbyte
c0 = 0 ; kind: operand:
c0 = c0+1, labelk = c0 ; label
c0 = c0+1, labvark = c0 ; label variable
c0 = c0+1, simlock = c0 ; simple local variable
c0 = c0+1, simcomk = c0 ; simple common variable
c0 = c0+1, simformk = c0 ; simple formal variable
c0 = c0+1, arrayk = c0 ; array
c0 = c0+1, rangek = c0 ; range
c0 = c0+1, subconk = c0 ; subscripted with constant subscript
c0 = c0+1, subscrk = c0 ; subscripted with variable subscript
;c0 = c0+1, suboptk = c0 ; subscripted optimised --- not implemented
c0 = c0+1, zonek = c0 ; zone
c0 = c0+1, arreqzk = c0 ; array equivalenced to zone
c0 = c0+1, externk = c0 ; external
c0 = c0+1, extformk = c0 ; formal external
c0 = c0+1, constk = c0 ; constant or literal
; operand description checkbits.
w.;------------------------------
inw01 = 1<0 ; in w01 register
inuv = 1<1 ; in uv register
indr = 1<2 ; in dr register
addr = 1<3 ; address
inwork = 1<4 ; in working storage
opfault = 1<10 ; error operand
\f
;/operand stack 2
; operand description masks and operands.
w.;---------------------------------------
sortmask : 2.111 ; sort mask
nopsort : 8.7770 ; 1-complement of sort mask
getkind = -3 ; remove sort by shift
logsort = 0
intsort = 1
realsort = 2
longsort = 2
drsort = 3
subconm = subconk>getkind ;
subscrm = subscrk>getkind ;
simlocm = simlock>getkind ;
constint = constk >getkind + intsort ; constant integer check bits
\f
;/operand stack 3
; structure of the operand stack.
; the special nomenclature and the names used in the description
; of the operand stack is described above.
; the operand stack holds entries of oplength bytes.
; the opdescr byte holds: operand kind < -getkind + sort of operand
; the opcheck byte holds: checkbits telling the whereabouts of operands
; the rest of each operand stack entry is used to describe the operand
; in different ways for each kind, only the bytes used are described:
; kind byte content
; label oplabel label number
; label variable opplace -s:label variable
; simple local opplace -s:variable
; -s:work(expression)
; simple common opcomno common number
; opcomrel c:common variable
; simple formal opplace +s:a:actual variable
; array opcopy -s:a:array element 0
; opplace -s:a:array element 0
; -s:work(dope vector)
; opupper (word) upper limit constant
; -s:upper limit adjustable
; oplower (word) lower limit constant
; -s:lower limit adjustable
; range opplace -s:work(range in dope vector)
; oprange (word) range constant
; -s:range variable
; subscr constant as array except:
; opplace -s:a:array element 0
; -s:work(a:element)
; opbytix (word) constant byte index
; subscripted as array except:
; opplace -s:a:array element 0
; -s:work(a:element)
; zone opcopy -s:work(zone array index i)
; opplace -s:a:zone 0 descriptor
; -s:work(a:zone i descriptor)
; opzoneno number of zones, 0 simple zone
; -s:adjustable number of zones
; array eq zone opcopy zone descriptor displacement
; opplace -s:a:zone 0 descriptor
; -s:work(dope vector)
; opbytix (word) array to record base displacement
; opupper as array
; oplower as array
; external opplace external number
; formal external opplace +s:formal
\f
;/operand stack 4
; constants:
; opplace -s:work(constant)
; literal1 opcon-1 0
; opcon byte1 of logical constant
; literal2 opcon-1 byte1
; opcon byte2 of integer constant
; literal4 opcon-3 byte1
; opcon byte4 of real/long constant
; literal8 opcon-7 byte1
; opcon byte8 of double/complex constant
; the array kind includes both local and common arrays.
; the zone kind comprises all zone variants: zone z, zone array zz,
; zone array element zz(i), zone record z(r), and zone array record
; zz(i,r)
; whenever an operand has entered calculations the resulting expression
; is described as a simple local entity.
\f
;/operand actions
occuvx: ; set register uv occupied.
; ; call and exit as occ01x
rs.w1 useuv. ; useuv := a:operand descriptor
al w0 inuv ; w0 := in uv mask bit
jl. setcheck. ; goto set checkbits
occdrx: ; set register dr occupied.
; ; call and exit as occ01x
rs.w1 usedr. ; usedr := a:operand descriptor
al w0 indr ; w0 := in dr mask bit
jl. setcheck. ; goto set checkbits
occ01x: ; set register w01 occupied.
; ; call: w1 := a:operand descriptor
; ; jl.w3 reg01set.
; ; exit: w1,w2 unchanged
; ;
rs.w1 use01. ; use01 := a:operand descriptor
al w0 inw01 ; w0 := in w01 mask bit
jl. setcheck. ; goto set checkbits
setaddrx: al w0 addr ; set address operand.
setcheck: ; set checkbit in operand check.
; ; entry: w0 := bit to set
; ; w1 := a:operand descriptor
rs.w2 savew2. ; save register 2
bz w2 x1+opcheck ; get checkbits
so w2 (reg0) ; if bit not set
ba w2 reg0last ; then add bit
hs w2 x1+opcheck ; save checkbits
rl.w2 savew2. ; restore register 2
jl x3 ; return
addrof: ; cancel address checkbit.
; ; call: w1 := a:operand descriptor
; ; jl.w3 addrof.
al w2 zerorel ; w2 := dummy zero to use regoff
al w0 addr ; w0 := checkbit describing address
jl. regoff. ; goto cancel bit (reg not used)
regdrofx: ; set dr register not used.
; ; call: w1 := a:operand descriptor
; ; jl.w3 regdroff.
; ; exit: w1 unchanged
al w2 usedrrel ; w2 := register relative to use01
al w0 indr ; w0 := bit describing dr register
jl. regoff. ; goto set register not used
reguvofx: ; set uv register not used.
; ; call: w1 := a:operand descriptor
; ; jl.w3 reguvoff.
; ; exit: w1 unchanged
al w2 useuvrel ; w2 := register relative to use01
al w0 inuv ; w0 := bit describing uv register
jl. regoff. ; goto set register not used
reg01ofx: ; set register w01 not used.
; ; call: w1 := a:operand descriptor
; ; jl.w3 reg01off.
; ; exit: w1 unchanged
; ;
al w2 0 ; w2 := use01 - use01
al w0 inw01 ; remove reg01
\f
;/operand actions 2
regoff: ; set register not used.
; ; entry: w1 := a:operand descriptor
; ; w2 := usereg - use01
; ; w0 := bit to be removed
ls w0 12 ; shift to first byte of register 0
lx.w0 allones. ; w0 := ones except bit to be removed
la w0 x1+opdescr ; w0 := operand descriptor without bit
rs w0 x1+opdescr ; set operand descriptor
al w0 0 ;
rs.w0 x2+use01. ; usereg := 0
jl x3 ; return
rescuuvx: ; rescue uv register if used.
; ; call: jl.w3 rescuuvx.
; ; exit: w1 := a:operand in uv
rl.w1 useuv. ; w1 := a:operand using uv
sn w1 0 ; if uv not used
jl x3 ; then return
uvover01: rs.w3 over3. ; save w3
jl.w3 rescu01x. ; rescue register 01 if used
al w0 uvtow01 ;
jl.w3 outbyte. ; gpa:outbyte(uv to w01)
rl.w1 useuv. ; w1 := a:operand in uv register
jl.w3 reguvofx. ; set uv register not used
rl.w3 over3. ; set return
jl. occ01x. ; operand is now in register 01
rescudrx: ; rescue dr register if used.
; ; call: jl.w3 rescudrx.
; ; exit: w1 := a:operand in dr register
rl.w2 usedr. ; w2 := a:operand in dr register
sn w2 0 ; if dr register not used
jl x3 ; then return
draway: rl.w1 usedr. ; w1 := a:operand using dr
rs.w3 over3. ; save return
jl.w3 rescu01x. ; rescue register 01 if used
rl.w1 usedr. ; w1 := a:operand using dr register
jl.w3 towork8x. ; move dr register to work area
jl.w3 regdrofx. ; set dr register not used
jl. (over3.) ; return
over3: 0 ; for saving of return address
rescu01x: ; rescue 01 register if used.
; ; call: jl.w3 rescu01x.
; ; exit: w1 := a:operand in 01
rl.w2 use01. ; w2 := a:operand using 01
sn w2 0 ; if register 01 not used
jl x3 ; then return
ww01away: rl.w1 use01. ; w1 : a:operand using 01
rs.w3 resc3. ; save return from rescue 01
al.w3 regsaved. ; set return to register saved
bz w2 x1+opcheck ;
sz w2 addr ; if register holds address
jl. towork2x. ; then save in 2 bytes
rl.w2 sortmask. ;
la w2 x1+opdescr ; w2 := sort(operand in w01)
jl.w3 toworkp. ; move operand in w01 to work area
regsaved: jl.w3 reg01ofx. ; set 01 register not used
jl. (resc3.) ; return
resc3: 0 ; for saving return address
\f
;/operand actions 3
resinuvx: ; result in uv.
jl.w3 addrof. ; remove address checkbit
jl.w3 reg01ofx. ; remove in register 01
jl.w3 regdrofx. ; remove in dr register
jl.w3 occuvx. ; set in uv register
jl. curract. ; goto current actions
typ8x: am double-real ; set double/complex type.
typ4x: am real-integer ; set real /long type.
typintx: al w2 integer ; set integer type.
rs.w2 type. ; type := w2
jl. curract. ; goto current actions
; ; set operand sort in descriptor.
; ; call: w1 := a:operand descriptor
; ; jl.w3 setqqq.
set8x: am double-real ; w2 := double or complex type
set4x: am real-integer ; w2 := long or real type
setintx: al w2 integer ; w2 := integer type
rs.w2 type. ; type := chosen type
al.w3 curract. ; set return
toptype: ; insert operand sort in descriptor.
; ; call: w1 := a:operand descriptor
rl.w2 type. ; jl.w3 toptype.
topsort: ; call: w1 := a:operand ; w2 := type
; ; jl.w3 topsort.
; ; exit: w1 unchanged ; w2 := type
; ;
rl w0 x1+opdescr ; get operand descriptor
la.w0 nopsort. ; w0 := operand descriptor & nopsort
topdescr: ;
ba.w0 x2+sort. ; + operand sort
hs w0 x1+opdescr ; set operand descriptor with sort
jl x3 ; return
topoldx: ; old operand description to top.
; ; used with multiple assignment
; ; only part of the description moved
; ; entry: w1 := a:operand to be set
jl.w3 topfreex. ; release operand top
jl.w3 topupx. ; but point at same entry
rl w0 x1+opdescr+oplength;
rs w0 x1+opdescr ; operand descriptor := old ditto
rl w0 x1+opplace+oplength;
rs w0 x1+opplace ; operand place word := old ditto
al.w3 curract. ; set return to current actions
bz w0 x1+opcheck ; w0 := checkbits
so w0 indr ; if operand in 01 register
jl. occ01x. ; then occupy 01 register
jl. occdrx. ; else occupy dr register
topkind: ; get kind of top operand.
rl.w1 opandtop. ; w1 := a:top operand descriptor
opkind: bz w2 x1+opdescr ;
ls w2 getkind ; w2 := kind(top operand)
jl x3 ; return
\f
;/operand actions 4
topnextx: ; exchange top and next operand.
rl.w1 opandtop. ; w1 := a: top operand
al w2 x1-oplength ; w2 := a:next operand
exchcurr:
al.w3 curract. ; set return
opexchx: ; exchange 2 operand stack elements.
; ; call: w1 := a:element a (10 bytes)
; ; w2 := a:element b (10 bytes)
; ; jl.w3 opexchx.
; ; exit: w0,w1,w2 unchanged
ds.w0 save30. ; save w0 and return
rl.w0 use01. ; w0 := a:element in w01
sn w0 x1 ; if element a in w01
rs.w2 use01. ; then use01 := w2
sn w0 x2 ; if element b in w01
rs.w1 use01. ; then use01 := w1
rl.w0 useuv. ; w0 := a:element in uv
sn w0 x1 ; if element a in uv
rs.w2 useuv. ; then useuv := w2
sn w0 x2 ; if element b in uv
rs.w1 useuv. ; then useuv := w1
rl.w0 usedr. ; w0 := element in dr register
sn w0 x1 ; if element a in dr
rs.w2 usedr. ; then usedr := w2
sn w0 x2 ; if element b in dr
rs.w1 usedr. ; then usedr := w1
dl w0 x2+2 ; exchange a(0:3) and b(0:3)
rx w3 x1 ; ...
rx w0 x1+2 ; ...
ds w0 x2+2 ; ...
dl w0 x2+6 ; exchange a(4:7) and b(4:7)
rx w3 x1+4 ; ...
rx w0 x1+6 ; ...
ds w0 x2+6 ; ...
rl w0 x2+8 ; exchange a(8:9) and b(8:9)
rx w0 x1+8 ; ...
rs w0 x2+8 ; ...
dl.w0 save30. ; restore w30
jl x3 ; return
; ; top operand to register.
toplogx: al w2 logical ; logical
jl. topset. ;
top01x: al w2 real ; real or long
jl. topset. ;
top1x: al w2 integer ; integer or address
topset: rl.w1 opandtop. ; w1 := a:top operand descriptor
jl.w3 topsort. ; set sort in operand descriptor
jl. topget. ; w2 := type ; goto get top
topregx: rl.w1 opandtop. ; w1 := a:top operand descriptor
rl.w2 type. ; w2 := type
\f
;/ operand actions 5
topget: ; get top operand.
; ; entry: w1 := a:operand descriptor
; ; w2 := type
bz.w2 x2+sort. ; w2 := sort of top operand
rs.w2 savesort. ; save sort
sn w2 drsort ; if sort = drsort
jl. gettodr. ; then goto get to dr register
rl.w0 use01. ; top operand to register 01.
sn w0 0 ; if register 01 not used
jl. free01. ; then goto register 01 free
se w0 x1 ; if top operand not in reg 01
jl. getaway. ; then goto get away to work
bz w0 x1+opcheck ; w0 := top operand checkbits
so w0 addr ; if top operand already in register
jl. curract. ; then goto current actions
bl.w0 x2+regload. ; w0 := regload(sort)
jl.w3 outbyte. ; outbyte(register load)
jl.w3 addrof. ; cancel address checkbit
al w0 0 ;
al.w3 addrinw1. ; set return from outbyte
jl. outbyte. ; outbyte(0); goto address in reg 1
getaway: jl.w3 ww01away. ; move operand in w01 to work area
rl.w1 opandtop. ; w1 := a:top operand descriptor
free01: bz w2 x1+opcheck ; w2 := checkbits for top operand
so w2 inuv ; if not in uv register
jl. load01. ; then goto load 01 register
al.w3 curract. ; set return to current actions
jl. uvover01. ; move uv register to w01
gettodr: jl.w3 rescu01x. ; save w01 if used
rl.w1 opandtop. ; w1 := a: top operand descriptor
rl.w0 usedr. ; top operand to dr register.
sn w0 0 ; if dr register not used
jl. loaddr. ; then goto load dr register
sn w0 x1 ; if dr register used for top operand
jl. curract. ; then goto current actions
jl.w3 draway. ; move dr register to work area
rl.w1 opandtop. ; w1 := a:top operand descriptor
loaddr: bz w2 x1+opcheck ; w2 := checkbits for top operand
am occdrx-occ01x ; w3 := a:occupy dr register action
load01: al.w3 occ01x. ; w3 := a:occupy 01 register action
rs.w3 savew3. ; savew3 := a:occupy action
am. (savesort.) ;
bz.w0 regload. ;
jl.w3 outbyte. ; outbyte(register load(sort of top))
al.w3 outopx. ; set return
so w2 addr+inwork ; if not operand address in work
jl. (savew3.) ; then occupy register; out operand
jl.w3 addrof. ; else cancel address checkbit
jl.w3 (savew3.) ; occupy register
rl.w3 addrwork. ; w3 := indirect addressing work
jl. outopy. ; goto output operand
; ; continue current actions
h. ; register load byte table.
regload: hlw1 ; logical
loadw1 ; integer or address
dlw1 ; long or real
drload ; double or complex
w.
\f
;/operand actions 6
topfreex: ; release top operand.
rl.w1 opandtop. ; w1 := old opandtop
bz w2 x1+opcheck ; w2 := operand opcheck
sn w2 0 ; if no checkbits
jl. topdownx. ; then goto reduce operand stack
ds.w3 savew3. ; save return and checkbits
sz w2 inwork ; if operand in work
jl.w3 downwork. ; then release work
dl.w3 savew3. ; restore return and checkbits
al w0 0 ; w0 := 0 (register not used)
sz w2 inw01 ; if operand in register 01
rs.w0 use01. ; then reg01 not used
sz w2 inuv ; if operand in uv
rs.w0 useuv. ; then uv not used
sz w2 indr ; if operand in dr
rs.w0 usedr. ; then dr not used
topdownx: ; reduce operand stack.
; call: w1 := a:operand top descr
; jl.w3 topdownx.
; exit w1 := a:new operand top d
; w0,w2 unchanged
c. etest, ds.w0 topd30. ; *** test
c. ctest, jl.w3 topinw1. z. ; *** test w1 = a:top operand descriptor
rs.w2 topdw2. ;***
rl.w2 opused. ;***
al w2 x2+oplength ;*** operand to used operand area
rs.w2 opused. ;***
dl w0 x1+2 ;*** move operand
ds w0 x2+2 ;***
dl w0 x1+6 ;***
ds w0 x2+6 ;***
rl w0 x1+8 ;***
rs w0 x2+8 ;***
rl.w2 topdw2. ;***
ld w0 65 ;*** set
ds w0 x1+2 ;*** operand
ds w0 x1+6 ;*** descriptor
rs w0 x1+8 ;*** := 0
dl.w0 topd30. ;***
z.
toplowx: ;entry for next
rl.w1 opandtop. ;
sl.w1 (opandbot.) ; allow only 1 record underflow
al w1 x1-oplength ; w1 := a:new operand top descriptor
rs.w1 opandtop. ; opandtop := w1
jl x3 ; return
topdw2: 0 ;***
topdw3: 0 ;***
topd30: 0 ;***
\f
;/ operand actions 7
getaddrx: rl.w1 opandtop. ; get address of top operand.
; ; call: jl. getaddrx.
; ; w1 := a:operand descriptor
rl.w2 use01. ; w2 := a:operand in 01 register
rs.w1 savew1. ; save a:operand descriptor
se.w2 (savew1.) ; if other operand in 01 register
jl.w3 rescu01x. ; then rescue 01 register
rl.w1 savew1. ; restore a:operand descriptor
jl.w3 opkind. ; w2 := kind(operand)
al w3 2.1111 ; mask index
la w2 reg3 ;
bl.w2 x2+addrset. ; w2 := address set action
al w2 x2+aux ; make auxiliary action
jl. singlact. ; goto perform single action
addrset = k-3 ; table of address set actions.
h. ; index is kind(operand)
addrsim ; simple local
addrget ; simple common
addrget ; simple formal
addrget ; array
0 ; range
addrget ; subscripted constant
addrsim ; subscripted variable
addrop ; zone
addrget ; array equivalenced zone
addrget ; external
0 ; formal external
addrcon ; constant
w.
h. ; sort of operand, table.
; index is type
sort: intsort ; 0 no type
logsort ; 1 logical
intsort ; 2 integer
realsort ; 3 real
longsort ; 4 long
drsort ; 5 double
drsort ; 6 complex
intsort ; 7 undefined, treated as integer
h. ; length of operand, table.
; index is sort of operand
length: 1 ; 0 type is logical
2 ; 1 integer
4 ; 2 real, long
8 ; 3 double, complex
w.
\f
;/operand actions 8
; the following decision table explains the addrout action
; operand checkbits
; addr in01 inuv indr (work) actions taken
; y y - - - a1. continue
; y n y - - a2. rescuuv
; y n n - - a3. outbyte(al w1); out top operand
; n y - - - a4. rescu01; goto a3
; n n y - - a5. rescuuv; goto a4
; n n n y - a6. rescudr; goto a3
; n n n n - a3. outbyte(al w1); out top operand
addroutx: ; make address in register 1.
bz w2 x1+opcheck ; w2 := operand checkbits
sz w2 inwork ; if inwork checkbit
al w2 x2-inwork ; then remove inwork
al w3 2.1111 ; mask checkbits
la w2 reg3 ;
bl.w2 x2+detab. ; take action from decision table
detabase: jl. x2 ; goto chosen action
deta6: jl.w3 rescudrx. ; call rescue dr register to work
jl. deta3. ; goto decision action 3
deta5: jl.w3 rescuuvx. ; call rescue uv register to w01
deta4: jl.w3 rescu01x. ; call rescue 01 register to work
deta3: al w2 addrget ; auxiliary al w1 address
al w2 x2+con ; make continuation action
jl. singlact. ; goto perform single action
deta2: jl.w3 rescuuvx. ; call rescue uv register to w01
jl. curract. ; goto current actions
detab: ; decision table for addrout action.
; ; the table must be changed if checkbits alters
h. ; addr indr inuv in01
deta3 -detabase ; n n n n
deta4 -detabase ; n n n y
deta5 -detabase ; n n y n
deta4 -detabase ; n n y y
deta6 -detabase ; n y n n
deta4 -detabase ; n y n y
deta5 -detabase ; n y y n
deta4 -detabase ; n y y y
deta3 -detabase ; y n n n
curractd ; y n n y
deta2 -detabase ; y n y n
curractd ; y n y y
deta3 -detabase ; y y n n
curractd ; y y n y
deta2 -detabase ; y y y n
curractd ; y y y y
w.
\f
;/working variables
; working variables
w.;-----------------
; working variables are disposed during pass 7 and will be placed
; between the simple local variables + descriptor words and the
; array buffers + zone areas.
; in the running program the working variables are referred to rela-
; tively to x2, the addresses being described -s:work
; the following variables appears in the working variable procedures
workinit: 0 ; holding the initial -s:worknext - one word
; ; for each general do-loop in program unit
workfree: 0 ; holding -s:worknext, i.e. the address part of
; ; the next working variable.
; ; the initial value -s: first free stackword
; ; is deduced from pass information <no.bytes for
; ; simple variables etc.>
workmax: 0 ; holding the maximal absolute value of workfree
; ; during the passing of the present program unit.
; ; the terminal value is pass 8 information
worklev: 0 ; counter for work group releasing
workrel: 0 ; variable for releasing of groups of works
; ; used in connection with workdown.
worksetx: ; initialise work.
al w2 0 ;
rs.w2 worklev. ; work level counter := 0
rs.w2 workrel. ; work release := 0
jl.w3 inbyte. ; w2 := gpa:inbyte( -s:free )
bl w2 reg2last ; extend sign of w2
rs.w2 workinit. ; workinit = -s:free
rs.w2 workfree. ; workfree := -s:free
rs.w2 workmax. ; workmax := -s:free
jl. curract. ; goto current actions
datalast: ; data last pointer to work.
zinworkx: ; zone index to work.
al w0 opcopy ; w0 := op.index for work information
c. ctest
rs.w3 savew3. ;***
jl.w3 topinw1. ;*** *** test w1 = opandtop
rl.w3 savew3. ;***
z.
al w2 intsort ; w2 := sort integer
jl. towork. ; goto register to work
\f
;/working variables 2
; ; save register in work.
; work address to opplace.
towork8x: am 1 ; 8 byte operands, drstore
towork4x: am 1 ; 4 byte operands, dsw1
towork2x: am 1 ; 2 byte operands, rsw1
towork1x: al w2 0 ; 1 byte operands, hsw1
toworkp: al w0 opplace ; w0 := operand index
towork: ; register to work.
; ; work address to operand descriptor.
; ; call: w0 := op.index for -s:work
; ; w1 := a:operand descriptor
; ; w2 := sort
; ; exit: w2 := -s:work
rs.w3 savew3. ; save return
hs.w0 workopix. ; save operand index for -s:work
bl.w0 x2+regstore. ; w0 := regstore directing byte
jl.w3 outbyte. ; gpa:outbyte(regstore)
sn w2 logsort ; if sort = logical sort
workint: al w2 intsort ; then sort = integer sort
bl.w2 x2+length. ;
ac w2 (reg2) ; w2 :=-length(sort),i.e.work bytes
bz w3 x1+opdescr ; if kind = array eq zone
ls w3 getkind ;
sn w3 arreqzk ; then
am 2 ; save opplace
al.w3 workop. ; set continue
; ; reserve work.
workres: ; call: w2 := - no.bytes to reserve
; ; jl.w3 workres.
; ; exit: w2 := -s:work (stack relative)
wa.w2 workfree. ; w2 := workfree - no.bytes
sh w2 -2048 ; if local stack overflow
jl. runstack. ; then goto run stack exceeded
sh.w2 (workmax.) ; if new workfree < workmax
rs.w2 workmax. ; then workmax := new workfree(w2)
rx.w2 workfree. ; w2 := -s:work ; workfree := w2
jl x3 ; return
workopix = k+1 ; set index of work information
workop: hs w2 x1 ; operand(index ) := -s:work
al w0 x2 ; w0 := -s:work
jl.w3 outbyte. ; gpa:outbyte(-s:work)
al w0 opx2 ;
jl.w3 outbyte. ; gpa:outbyte(opx2)
al w0 inwork ; set in work
jl.w3 setcheck. ; operand(descriptor) with inwork
bz w0 x1+opcheck ; get checkbits
sz w0 addr ; if address saved in work
jl. (savew3.) ; then return
bz w3 x1+opdescr ; if kind = array eq zone
ls w3 getkind ;
se w3 zonek ; or kind = zone then
sn w3 arreqzk ; save kind
jl. (savew3.) ;
la.w3 sortmask. ; w3 := operand sort
al w3 x3+simlocm ; + simple local kind
hs w3 x1+opdescr ; value in work is simple local
jl. (savew3.) ; return for towork
h.
regstore: hsw1 ; store logical
rsw1 ; store integer, address
dsw1 ; store long , real
drstore ; store double , complex
w.
\f
;/working variables 3
worknotx: ; set do not release work.
rl.w0 workfree. ;
rl.w2 worklev. ;
al w2 x2+1 ;
rs.w2 worklev. ; work level := work level + 1
sn w2 1 ; if first work level then
rs.w0 workrel. ; workrel := -s:first free work
jl x3 ; return
downwork: ; release work holding operand.
; ; call: w1 := a:operand
; ; jl.w3 downwork
; ; exit: w2 := -s:work
bz w2 x1+opdescr ; w2 := operand descriptor
ls w2 getkind ; w2 := kind(operand)
bl.w2 x2+workbyte. ; w2 := workbyte(kind)
am x1 ;
bl w2 x2 ; w2 := operand(-s:work)
sh.w2 (workfree.) ; if -s:work < workfree
jl x3 ; then return
rl.w0 workrel. ; <>0 means wait to release work
sn w0 0 ; if immediate work release
jl. workback. ; then goto work release
sl.w2 (workrel.) ; if -s:work > workrel
rs.w2 workrel. ; then workrel := -s:work
jl x3 ; return
workdwnx: ; release group of working storage.
rl.w2 worklev. ;
al w2 x2-1 ;
rs.w2 worklev. ; work level := work level - 1
se w2 0 ; if not last work level
jl x3 ; then return
rx.w2 workrel. ; w2 := workrel; workrel := 0
workback: ; release working variable(s).
rs.w2 workfree. ; release, i.e. set workfree back
jl x3 ; return
h.
workbyte: ; table holding index in operand description
; ; for byte giving stack address of work.
; ; obs: content depending of enumeration of kinds
opplace ; not used
opplace ; label
opplace ; label variable
opplace ; simple local, expression
opplace ; simple common
opplace ; simple formal
opplace ; array
opplace ; range
opplace ; subscripted constant
opplace ; subscripted variable
;-1 ; subscripted optimised
opcopy ; zone
opplace ; array eq zone
opplace ; external
opplace ; formal external
opplace ; constant
w.
\f
;/copy
outlistx: ; transmit list.
jl.w3 inbyte. ; w2 := gpa:inbyte
rs.w2 savebyte. ; savebyte := no.list bytes
al w1 x2 ; w1 := no.list bytes
jl.w3 inoutn. ; call copy w1 bytes
jl. saveoutx. ; outbyte(no.); goto current actions
copy1x:
inout1: ; copy 1 byte. call: jl.w3 inout1.
al w0 x3 ; w0 := return address
jl.w3 inbyte. ; w2 := gpa:inbyte
rl w3 reg0 ; w3 := return address from outbyte
al w0 x2 ; w0 := inbyte
jl. outbyte. ; gpa:outbyte(inbyte)
inoutn: ; copy n bytes.
; call: w1:=n ; jl.w3 inoutn.
rs.w3 savew3. ; save return
al.w3 0 ; for
al w1 x1-1 ; n := n - 1
sl w1 0 ; while n >= 0
jl. inout1. ; do inout1 (return to for)
jl. (savew3.) ; return from inoutn
copy3x: al w1 3 ; copy 3 bytes.
al.w3 curract. ; set return to current actions
jl. inoutn. ; goto copy n=3 bytes
\f
;/input operands
saveinx: ; save inbyte in savebyte.
jl.w3 inbyte. ; w2 := gpa:inbyte
rs.w2 savebyte. ; savebyte := 0, inbyte
jl. curract. ; goto current actions
opsetx: ; set operand description in stack.
dl.w3 (acstatop.) ; operand description kind
bz w0 reg3last ; = next action used as parameter
ls w0 -getkind ; move kind
ld w3 -12 ; remove description kind
ds.w3 (acstatop.) ; save rest of actions
jl.w3 topupx. ; w1 := operand stack pointer
rs w0 x1+opdescr ; set operand description
jl. curract. ; goto current actions
arrayopx: ; array operand to stack.
jl.w3 inbyte. ; w2 := gpa:inbyte
hs w2 x1+opplace ; operand(top,opplace) := inbyte
al w0 x1+oplower ; w0 := a:last byte to set
al w1 x1+opupper-2 ; w1 :: a=first byte before upper
jl. opbytes. ; goto input operand bytes to stack
zoneopx: ; zone operand to stack.
al w0 x1+opzoneno ; w0 := a:last byte to set
jl. atplace. ; goto set first at opplace
subcnopx: ; constant subscripted operand.
al w0 x1+opbytix ; w0 := a:last byte to set
atplace: al w1 x1+opplace-1 ; w1 := a:first byte is before opplace
jl. opbytes. ; goto input operand bytes to stack
arrqzx: ; array equivalenced to zone.
al w0 x1+oplower ; w0 := a:last byte to set
jl. atcopy. ; goto set first at opcopy
simqzx: ; simple equivalenced to zone.
al w0 x1+opbytix ; w0 := a:last byte to set
atcopy: al w1 x1+opcopy-1 ; w1 := a:first byte is before opcopy
jl. opbytes. ; goto input operand bytes to stack
constopx: ; constant operand to stack.
c. ctest, jl.w3 topinw1. z. ; *** *** test w1 = opandtop
ld w0 65 ; for the sake of constant arithmetic
ds w0 x1+opcon ; zero in last 4 bytes of constant
al w0 constk<b0 ;
rs w0 x1+opdescr ; operand desriptor := constant val
jl.w3 toptype. ; insert operand sort ; w2 := type
al w0 x1+opcon ; w0 := a:last byte of constant
rl w1 reg0 ;
bl.w2 x2+sort. ; w1 := w0 - length(sort(type))
bs.w1 x2+length. ; w1 := a:first byte of constant - 1
\f
;/input operands 2
opbytes: al w1 x1+1 ; w1 := a:byte to be set
jl.w3 inbyte. ; w2 := gpa:inbyte
hs w2 x1 ; opstack(top,byte) := inbyte
se w0 x1 ; if more bytes to set
jl. opbytes. ; then goto input operand bytes
rl.w1 opandtop. ; else w1 := a:top operand
jl. curract. ; goto current actions
copyopx: ; copy of operand place.
rl.w1 opandtop. ; x1 := operand stack pointcr
bl w0 x1+opplace ;
hs w0 x1+opcopy ; opcopy := opplace
jl. curract. ; goto current actions
topupx: ; increase operand stack pointer.
rl.w1 opandtop. ; x1 := operand stack pointer
al w1 x1+oplength ; + oplength
rs.w1 opandtop. ; a:next operand stack entry
c. etest, sl.w1 (opandmax.) ; *** *** test max opandstack
rs.w1 opandmax. z. ; ***
sh.w1 (opandlim.) ; if not over operand stack limit
jl x3 ; then return
al.w1 stackover. ; else stack overflow alarm
jl.w3 alarm. ; gpa:alarm
simcopx: ; simple common operand.
c. ctest, jl.w3 topinw1. z. ; *** *** test w1 = opandtop
jl.w3 inbyte. ; w2 := gpa:inbyte
hs w2 x1+opcomno ; opstack(top,comno) := inbyte
placeopx: ; operand addressing information.
c. ctest, jl.w3 topinw1. z. ; *** *** test w1 = opandtop
jl.w3 inbyte. ; w2 := gpa:inbyte
setplace: hs w2 x1+opplace ; opstack(top,opplace) := inbyte
jl. curract. ; goto current actions
labelopx: ; label operand.
c. ctest, jl.w3 topinw1. z. ; *** *** test w1 = opandtop
rl.w2 labelno. ;
hs w2 x1+oplabel ; opstack(top,oplabel) := labelno
jl. curract. ; goto current actions
rangeopx: ; put ranges into operand stack.
jl.w3 inbyte. ; w2 := no.indices
morange: al w2 x2-1 ; w2 := no.ranges
sh w2 0 ; if no.ranges = 0
jl. curract. ; then goto current actions
hs.w2 rangeno. ; rangeno := no.ranges
jl.w3 topupx. ; call increase operandstack pointer
al w2 rangek>getkind;
rs w2 x1+opdescr ; opstack(top,opdescr) := range kind
jl.w3 inbyte. ; gpa:inbyte
hs w2 x1+oprange-1 ; opstack(top,rangebyte1) := inbyte
jl.w3 inbyte. ; gpa:inbyte
hs w2 x1+oprange ; opstack(top,rangebyte2) := inbyte
rangeno = k+1
al w2 0 ; w2 := no.ranges
jl. morange. ; goto more ranges
\f
;/output operands
saveoutx: ; output savebyte.
rl.w0 savebyte. ; w0 := savebyte
jl. outcurr. ; outbyte; goto current actions
outlit2: ; output 2 byte literal.
bl w0 reg2 ; entry: w2 := 2 byte literal
jl.w3 outbyte. ; gpa:outbyte(first byte)
bl w0 reg2last ;
jl.w3 outbyte. ; gpa:outbyte(last byte)
al w0 literal2 ;
jl. outcurr. ; outbyte(literal2); goto current act
zonedisx: ; out zone descriptor displacement.
bz w2 x1+opcopy ; w2 := zone descr displ
jl. outconst. ; goto output constant
zonenox: ; output zone number operand.
bl w2 x1+opzoneno ; w2 := zone number operand
zonout: sl w2 0 ; if zone number = constant
jl. outconst. ; then goto output constant byte
al w0 x2 ; else
jl.w3 outbyte. ; outbyte(-s:zoneno)
al w0 opx2 ;
jl. outcurr. ; outbyte(opx2 indirect); goto current act
znosavex: ; output zone number from savebyte.
bl.w2 savelast. ; w2 := zone number operand
jl. zonout. ; goto output zone number
zonerecx: ; get zone record base address.
rl.w3 addrwork. ; indirect addressing to get base addr
jl. outopy. ; output operand
outarrbx: ; output array base addr. of param.
jl.w3 topkindy. ; getkind
se w2 arreqzk ; if kind=arrey eq zone
jl. outbasex. ;
bl w0 x1+opplace ; then get base
jl. outbyx2. ; of zone
outcopyx: ; output data last pointer.
outzinx: ; output zone array index.
outbasex: ; output array base address.
; operand(opcopy) := -s:a:array0
c. ctest, jl.w3 topinw1. z. ; *** *** test w1 = opandtop
bl w0 x1+opcopy ; w0 := -s:a:array0
outbyx2: jl.w3 outbyte. ; gpa:outbyte
al w0 opx2 ; w0 := operand x2 marked
jl. outcurr. ; outbyte(opx2); goto current actions
; ; output 2 byte operand parts.
; ; array to rec.base displacement
zrbytix: am opbytix-oprange ; zone byteindex rel. rec.base
rangex: am oprange-oplower ; range
lowerx: am oplower-opupper ; lower limit
upperx: al w3 opupper ; upper limit
am x3 ;
rl w0 x1 ; w0 := operand descriptor part
rl.w2 varx2. ; w2 := variable in stack
sh w0 -1 ; if not sign bit of operand part
sn w3 opbytix ; or byteindex
rl.w2 lit2. ; then w2 := 2 byte literal
setopy: ls w3 12 ; w3 := operand index to first byte
wa w3 reg2 ; w3 := w3 + w2
jl. outopy. ; goto outopy
\f
;/output operands 2
outbytop: jl.w3 outbyte. ; gpa:outbyte
outopx: ; output operand.
rl.w1 opandtop. ; w1 := a:top operand descriptor
bz w2 x1+opdescr ; w2 := operand descriptor
rl.w0 sortmask. ;
la w0 reg2 ; w0 := sort of operand
ls w2 getkind ; w2 := kind of operand
sn w2 constk ; if kind = constant kind
wa w2 reg0 ; then w2 := w2 + sort
am x2 ; make byteindex to toparts table
rl.w3 x2+toparts. ; get output description
se w3 0 ; if outop operation
jl. outopy. ; then goto out top operand
al.w3 outopx. ; else set return to top op
jl. topdownx. ; reduce operand stack
outopy: ; entry: w1 := a:operand descriptor
; ; w3 := word as in toparts
; ; number of bytes <18 +
; ; operand index <12 +
; ; operand byte descriptor
hs.w3 outopz. ; save operand byte descriptor
ls w3 -6 ; split w3:in components:
bz w2 reg3 ; w2 := number of bytes
bz w3 reg3last ;
ls w3 -6 ; w3 := index of last output byte
wa w1 reg3 ; w1 := a:last output byte
ac w2 x2 ; w2 := - number of bytes to output
wa w2 reg1 ; w2 := a:first output byte - 1
outbytes: al w2 x2+1 ; w2 := a:output byte
bl w0 x2 ; w0 := output byte
jl.w3 outbyte. ; gpa:outbyte
se w1 x2 ; if not last byte
jl. outbytes. ; then goto output bytes
outopz = k+1 ;
al w0 ; operand descriptor byte
rl.w1 opandtop. ; w1 := a:top operand descriptor
sh w0 0 ; if not operand directing byte
jl. outspec. ; then goto special output
bz w2 x1+opcheck ; w2 := operand checkbits
so w2 addr ; if value operand
jl. outcurr. ; then outbyte; goto current acti
al w0 opx2i ; w0 := x2 indirect addressing
sn w2 inw01 ; if address in register w1
addrinw1: al w0 opx1 ; then w0 := x1 addressing
jl. outcurr. ; outbyte; goto current actions
outspec: sn w0 0 ; if no output
jl. curract. ; then goto current actions
ac w0 (reg0) ; w0 := - special operand
jl.w3 outbyte. ; gpa:outbyte
rl.w3 modif2. ; w3 := modification entry
jl. outopy. ; goto output operand
sortconx: ; output sort constant operand.
; ; call: savetype := type
; ; jl.w3 sortcon.
am. (savetype.) ;
bl.w2 sort. ; w2 := sort(savetype)
jl. concurr. ; output sort constant
; goto current actions
out12x: am 10 ; output constant 12 operand.
out2x: am 1 ; output constant 2 operand.
out1x: al w2 1 ; output constant 1 operand.
concurr: al.w3 curract. ; set return
\f
;/output operands 3
outconst: ; output constant operand.
; ; call: w2 := constant
; ; jl.w3 outconst.
; ; exit: w1,w2 unchanged
rs.w3 savew3. ; save w3 return address
al w0 x2 ;
jl.w3 outbyte. ; gpa:outbyte(constant)
al w0 opx0 ;
jl.w3 outbyte. ; gpa:outbyte(opx0)
jl. (savew3.) ; return
h.
toparts: ; table for output of operands.
; ; the value describes the operand
; ; to be output from the operand
; ; stack
; ; a: number of bytes to output<18
; ; b: + index of last operandbyte<12
; ; c: + operand directing byte
; ; if c < 0 special actions are taken
;a b c ; kind of operand
1 <6+ opplace , troublop ; 0 not used
1 <6+ oplabel , 0 ; 1 label
1 <6+ opplace , opx2 ; 2 label variable
1 <6+ opplace , opx2 ; 3 simple local variable
2 <6+ opcomrel, opcommon ; 4 simple common variable
addrwork: ; address in work, treated as
1 <6+ opplace , opx2i ; 5 simple formal variable
1 <6+ opplace , opx2 ; 6 array
0 , 0 ; 7 range
1 <6+ opplace , -opx2i ; 8 subscripted, constant subscript
1 <6+ opplace , opx2 ; 9 subscripted, variable subscript
;0 , 0 ; -- subscripted, optimise subscript
1 <6+ opplace , opx2 ; 10 zone
1 <6+ opplace , opx2 ; 11 array equivalenced to zone
1 <6+ opplace , opext ; 12 external
1 <6+ opplace , opx2 ; 13 formal external
1 <6+ opcon , opx0 ; 14 constant, sort 0: logical
2 <6+ opcon , literal2 ; 15 constant, sort 1: integer
4 <6+ opcon , literal4 ; 16 constant, sort 2: real, long
8 <6+ opcon , literal8 ; 17 constant, sort 3: double, compl
lit2: 2<6 , literal2 ; 2 byte literal without index
varx2: 1<6 , opx2 ; stack variable without index
modif2:
2 <6+ opbytix , amodify ; 2 byte modifier
w.
\f
;/ internal variables
; variables for saving
w.;-------------------
savew0: 0 ; save register w0
savew1: 0 ; save register w1
savew2: 0 ; save register w2
savew3: 0 ; save register w3
save30: 0 ; for double store w0 (w30)
savetype: 0 ; save type of directing byte
savesort: 0 ; save sort of directing byte, i.e. of operand
savelast = k + 1 ; address of last byte in savebyte
savebyte: 0 ; save input byte
; internal variables
type: 0 ; type of typedependant directing bytes
labelno: 0 ; label number, internal representation
; use of registers.
; ----------------
; the planned use of the registers during execution of the program
; is mirrored in the variables:
use01: 0 ; the content of these pointers will be
usedr: 0 ; a:operandstack(element) in case the register
useuv: 0 ; is used
use3 : 0 ; otherwise zero.
zero : 0 ; for use in cancelling address checkbit
use01rel = use01 - use01
usedrrel = usedr - use01
useuvrel = useuv - use01
use3rel = use3 - use01
zerorel = zero - use01
; mask constants
w.;-------------
actmask:
askmask:
typemask: 2.111 ; 3 bit masks
allones: 8.77777777 ; 24 1-bits
; action parameters
ask0w1 = (: 1<3 + 0 :)<b0 ; for logical and, see relations
ask7w1 = (: 1<3 + 7 :)<b0 ; for logical or , see relations
; action table + auxiliary action table
; acttab ; first action table entry
; acttabhi ; last action table entry
actlng = 4 ; 4 bytes in action entry
; auxtab ; first auxiliary table entry
; auxtabhi ; last auxiliary table entry
; maxact = (:acttabhi - acttab:)/actlng
\f
;/stepping stones and pointers
; stepping stones
addrofy: jl. addrof. ; goto cancel address bit
topdowny: jl. topdownx. ; goto reduce operand stack
topsorty: jl. topsort. ; goto insert sort in description
topkindy: jl. topkind. ; goto insert kind in top operand
toptypey: jl. toptype. ; goto inset sort in top operand
rescu01y: jl. rescu01x. ; goto rescue 01 register
errindex: jl. errconix. ; goto error in constant index
errover: jl. overmess. ; goto error in constant arithmetic
message: rs.w0 svw0. ; save w0 ; goto gpa:message
rs.w1 svw1. ; save w1
al w1 -1000 ;
al w0 2 ; set
rs.w0 x1+ees0. ; warning.yes
rl.w0 svw0. ; get saved w0
rl.w1 svw1. ; get saved w1
am -2048 ;
jl. message0.+2048; goto gpa:message
svw0: 0
svw1: 0
intpass: jl. intpass0. ; goto gpa:interrupt handling
topinw1: jl. topinw1x. ; goto test top operand descriptor
opexchy: jl. opexchx. ; goto operand exchange
init7: jl. init7y. ; goto initialise
inbyte: ; stepping stone inbyte.
c. atest
rs.w1 keep. ;***
rl.w1 passin. ;***
al w1 x1+1 ;*** count input bytes
rs.w1 passin. ;***
rl.w1 keep. ;***
z.
am -2048 ;
jl. take.+2048 ; gpa:inbyte
outbyte: ; stepping stone outbyte.
c.atest
rs.w1 keep. ;***
rl.w1 passout. ;***
al w1 x1+1 ;*** count output bytes
rs.w1 passout. ;***
rl.w1 keep. ;***
z.
am -2048 ;
jl. give.+2048 ; gpa:outbyte
watch: 0 ;*** counter for actions
keep: 0 ;*** save register 1
passin: 0 ;*** count pass input
passout: 0 ;*** count pass output
; addresses and pointers
w.;----------------------
; action stack
acstabot: 0 ; bottom , init = a:action stack
acstalim: 0 ; limit , init = a:operand stack
acstatop: 0 ; pointer, init = a:action stack
; operand stack
opandbot: 0 ; bottom , init = a:operand stack - oplength
opandlim: 0 ; limit , init = a:lastword - oplength
opandtop: 0 ; pointer, init = a:operand 0 - oplength
opandmax: 0 ;*** for testing of pass 7
opused: 0 ;*** operand counter
\f
;/main control
; main administration on pass 6 directing bytes.
; ----------------------------------------------
; the directing bytes for pass 7 are divided into 3 groups:
;
; 0 ,typedep ,dirmax
; ----------------------,---------------------,---------------->
; type independant type dependant labels
;
; the value of the directing byte is related to the main action
; table or to the label number
;
;
; type independant : (index to) main action
; type dependant : typedep + (main action - typedep)<b0 + type
;
; typedep ; value of first type dependant directing byte
; dirmax : maximal value of directing byte from pass 6
dirbyte: jl.w3 inbyte. ; directing byte. w2:=gpa:inbyte
sl w2 dirmax ; if dirbyte >= first label byte
jl. labelset. ; then goto get label action
sl w2 typedep ; if dirbyte is type dependant
jl. typebyte. ; then goto extract type
ls w2 2 ; action table index := 4*dirbyte
jl. actload. ; goto load action
typebyte: al w2 x2+typedepn ; w2 := (actno - typedep)<3 + type
al w3 2.111 ; typemask
la w3 reg2 ; w3 := extracted type
rs.w3 type. ; type := extracted type
ws.w2 type. ; (actno - typedep)<3
ls w2 -1 ; 4*actno - 4*typedep
al w2 x2+typedep4 ; index:= 4*actno
actload: dl.w0 x2+acttab. ; w30 := action entry
jl. getact. ; goto get next action
labelset: ; label operand.
rs.w2 labelno. ; labelno := dirbyte
al w2 labelact ; label action entry
jl. getspact. ; goto get special action
\f
;/main control 2
; get action entry
w.;---------------
nextact: al w3 -actlng ; next action entry.
wa.w3 acstatop. ; w3 := action stack top - 1
sn.w3 (acstabot.) ; if action stack empty
jl. dirbyte. ; then goto take directing byte
setatop: rs.w3 acstatop. ; set action stack top
curract: dl.w0 (acstatop.) ; w30 := current actions
getact: bz w2 reg0last ; w2 := next action
removact: ld w0 -12 ; remove action
ds.w0 (acstatop.) ; current actions := rest actions
singlact: ; treat and split action
rl.w3 actmask. ; action kind mask
la w3 reg2 ; w3 := action kind
ls w2 -b0 ; w2 := action parameter
c. etest
ds.w1 savew1. ;*** test: action and parameter in print area
ds.w3 savew3. ;*** save registers
sn w3 nex ;*** if take next action
jl. watchend. ;*** then goto do not save action
se w3 out ;*** if not action outbyte
ls w2 b0 ;*** then w2last := slang byte value
hs w3 reg2 ;*** w2first := standard action
rl.w1 watch. ;***
al w1 x1-2 ;*** watch := watch - 2
rs.w1 watch. ;***
wa.w1 opandlim. ;***
rs w2 x1 ;*** save action taken in watch area
dl.w1 savew1. ;*** restore registers
dl.w3 savew3. ;***
z.
watchend:
bl.w3 x3+standact. ; standard action address
acbranch: jl.w3 x3 ; call standard action
jl. curract. ; continue current actions
; set auxiliary actions in action stack: aux
w.;------------------------------------------
; auxact is a standard action that takes an action entry from the
; auxiliary action entry table, increases the action stack pointer,
; and starts these new actions
; w2 := byte index of auxiliary action table
auxact: ; get auxiliary actions.
; w2 := byteindex to auxact table
dl.w0 x2+auxtab. ; w30 := auxiliary actions
newact: ; enter new actions.
; entry: w30 := action entry
al w2 actlng ; each action entry of actlng bytes
wa.w2 acstatop. ; action stack pointer increased
c. dtest
sh.w2 (acstalim.);*** if trying to spoil operand stack
jl. acstaok. ;*** then
al.w1 actover. ;***
jl.w3 message. ;*** gpa:message
rl.w1 opandtop. ;***
z.
acstaok: ;
rs.w2 acstatop. ; action stack pointer
jl. getact. ; goto get next action
actover: <:action stack error<0>:>
\f
;/main control 3
; get continuation actions to action stack: con
w.;---------------------------------------------
; contact is a standard action used only when an action entry
; must be continued with further actions
; contact is used instead of auxact to avoid having finished (empty)
; actions in the action stack as the continuation actions overwrites
; the current actions. (the action stack pointer is not increased.)
; w2 := byte index of auxiliary action table
contact: ; get continuation (aux)actions.
; ; w2 :=byteindex to auxact table
dl.w0 x2+auxtab. ; w30 := auxiliary continuation acts
jl. getact. ; goto get next action
; perform general action: doo
w.;----------------------------
; perform is a standard action that transfers control to a general
; action code of pass 7
; w2 := byteindex to the action address table
; the action address table contains the addresses of the general
; actions relative to the action base address: base
perform:
bl.w3 x2+aat. ; w3 := actbase: pass 7 action code
base: jl.w3 x3 ; goto chosen action
jl. curract. ; return to current action
; output byte: out
w.;------------------
; byteout is a standard action that outputs one byte to pass 8
; w2 := value of output byte
byteout: al w0 x2 ; w0 := output byte
outcurr: al.w3 curract. ; set return to current actions
jl. outbyte. ; gpa:outbyte
; error in action table
w.;---------------------
; message on error in action table
erract: al.w1 actmess. ; w1 := a:text
al.w3 curract. ; set return
jl. message. ; gpa:message
actmess: <: wrong standard action :>
standact: ; standard action table
h. ; ---------------------
;name standact ; function
nex = 0, nextact-acbranch ; next action from action stack
aux = 1, auxact -acbranch ; auxiliary actions (w2) to action stack
con = 2, contact-acbranch ; continue actions (w2) to action stack
doo = 3, perform-acbranch ; perform jump to named action of pass 7
out = 4, byteout-acbranch ; outbyte (w2) by call of general pass
err = 5, erract -acbranch ;
err = 6, erract -acbranch ;
err = 7, erract -acbranch ;
w.
\f
;/action stack actions
leavex: ; leave action in action stack.
; ; this naughty action will leave
; ; the rest of the current actions
; ; in the action stack
al w3 actlng ; each action entry holds actlng bytes
wa.w3 acstatop. ; increase action stack pointer
rs.w3 acstatop. ;
jl. dirbyte. ; goto read next directing byte
changex: ; change of action suite.
; ; the following action is taken instead
; ; of the first action in the previous
; ; entry
rl.w3 acstatop. ;
bz w2 x3+1 ; w2 := following action
al w3 x3-actlng ;
rs.w3 acstatop. ; reduce action stack
dl.w0 (acstatop.) ; w30 := previous action entry
jl. removact. ; goto remove action
newspact: ; enter special actions.
dl.w0 x2+spact. ; w30 := special actions
jl. newact. ; goto enter new actions
getspact: ; get special actions.
dl.w0 x2+spact. ; w30 := special actions
jl. getact. ; goto insert these actions
curractd = curract - detabase
\f
;/interrupt in pass 7
intrupt: ; interrupt handling in pass 7.
0 ; working register 0
0 ; working register 1
0 ; working register 2
0 ; working register 3
0 ; exception register
intretur: 0 ; instruction counter
intcause: 0 ; cause of interrupt
jl. 2,r.(:intrupt.+e100+2:)>1
al.w2 intrupt. ; w2 := a:interrupt dump words
rl.w0 intcause. ; w0 := cause of interrupt value
se w0 0 ; if cause = protection violation or
sl w0 5 ; cause <> arithmetic overflow
jl. intpass. ; then transfer interrupt to gpa
mulflow: jl.w3 errover. ; error message:overflow, trouble
; ; w1 := a:top operand description
; ; w2 is unimportant, not restored
ld w0 65 ; w30 := zeroed dummy constant
jl. (intretur.) ; return
intflow: ; integer overflow in multiplication.
; ; software interrupt (hand made)
rs.w3 intretur. ; save return
wm w0 x1+opcon ; multiply constants
sh w0 -1 ; make the test on w3
am -1 ; all bits of w3 equal sign of w0
se w3 0 ; if overflow in multiplication
jl. mulflow. ; then goto interrupt action
jl. (intretur.) ; else return
intdiv: ; integer division:
; (extend sign)
rs.w3 intretur. ; save(return);
bl w3 reg0 ;
bl w3 reg3 ; w3 := sign(w0);
wd w0 x1+opcon ; w3w0 := result of division;
jl. (intretur.) ; return;
\f
;/arithmetic
multx: am 2 ; multiply. arith number := 2
plusx: al w2 0 ; add. arith number := 0
hs.w2 arithno. ; save arithmetical operator number
rl.w1 opandtop. ;
al w1 x1-oplength ; w1 := a:next operand descriptor
rl.w2 type. ; w2 := type(operator)
bz.w0 x2+sort. ; w0 := sort(operator)
sn w0 drsort ; if sort = drsort
am usedr-use01 ; then test dr register
sn.w1 (use01.) ; if next operand in register(sort)
jl. exchange. ; then goto exchange top and next
jl. aritype. ; else goto choose operation
dividex: am 2 ; divide. arith number := 3
minusx : al w2 1 ; subtract. arith number := 1
hs.w2 arithno. ; save arithmetical number
exchange: rl.w1 opandtop. ; w1 := a:top operand descriptor
al w2 x1-oplength ; w2 := a:next operand descriptor
jl.w3 opexchx. ; exchange top and next operand
aritype: rl.w2 type. ;
ls w2 2 ; w2 := 4*type
arithno = k+1 ;
al w2 x2 ; + arithmetical operator number
hs.w2 arisult. ; save table index
bl.w0 x2+operator. ; w0 := operator(type,arith.no.)
hs.w0 aribyte. ; save operator information
rl.w1 opandtop. ; w1:= a:top operand descriptor
sh w0 0 ; if running system arithmetic
jl. addruv. ; then goto next opand addr to uv
bz w0 x1+opdescr ; make description(top) .and.
la w0 x1+opdescr-oplength; description(next)
ls w0 getkind ; w0 := kind(top .and. next)
sn w0 constk ; if two constant operands
jl. arithin7. ; then perform arithmetic now
jl. curract. ; else goto current actions
addruv:
jl.w3 worknotx. ; set release work after rs call
rl.w2 type. ;
sh w2 long ; if type < double
am addr2uv ; then 2 addresses to uv register
al w2 addrnext ; next address to uv actions
jl. newspact. ; goto enter special action
h.
operator = k - 8 ; table of operator bytes.
; ; minus indicates running system arithmetic
; ; the definition of operator is k-8 as
; ; no type and logical type will not occur
; + , - , * , / , type
addw1 , subw1 , mulw1 , divw1 ; integer
faw1 , fsw1 , fmw1 , fdw1 ; real
aaw1 , ssw1 , -longmul , -longdiv ; long
-dbladd , -dblsub , -dblmul , -dbldiv ; double
-coxadd , -coxsub , -coxmul , -coxdiv ; complex
trouble , trouble , trouble , trouble ; error
w.
\f
;/ arithmetic 2
arithin7: ; constant arithmetic in pass 7.
; ; w2 := 4*type + arith.operator number
; ; w1 := a:top operand descriptor
am x2 ; 2*w2 is byte index to table
rl.w0 x2+arinstr. ; load slang instruction(operator)
rs.w0 aricode. ; insert slang instruction
jl.w3 toplowx. ; reduce operand stack
dl w0 x1+opcon+oplength; take 4 byte of constant operand 1
aricode: 0 ; arithmetical instruction inserted
ds w0 x1+opcon ; save result as constant top operand
conbase: jl. nextact. ; goto next action entry
arinstr = k - 16 ; table of slang instructions for arithmetic in 7.
; ; the definition of arinstr can be k-16 as
; ; no type and logical type will not occur
wa w0 x1+opcon ; integer +
ws w0 x1+opcon ; integer -
mulset: wm w0 x1+opcon ; integer *, spill.no
jl.w3 intdiv-aricode; integer /
fa w0 x1+opcon ; real +
fs w0 x1+opcon ; real -
fm w0 x1+opcon ; real *
fd w0 x1+opcon ; real /
aa w0 x1+opcon ; long +
ss w0 x1+opcon ; long -
mulspill: jl.w3 intflow-aricode; integer * , spill.yes
aribyte = k+1 ; generate code for arithmetic.
arithopx: al w0 ; w0 := operator(type,arith.no.)
sl w0 0 ; if not running system arithmetic
jl. outbytop. ; then goto outbyte and outop
ac w0 (0) ; w0 := -(-running system number)
jl.w3 outbyte. ; outbyte(running system number)
al w0 gors>b0 ;
jl. outcurr. ; outbyte(go running system)
squarex: ; multiply if operand ** 2.
jl.w3 topkind. ; w1 := a:top operand descriptor
; ; w2 := kind(top operand)
se w2 constk ; if kind <> constant
jl. curract. ; then goto current actions
rl w2 x1+opcon ; w2 := constant exponent
se w2 2 ; if not squaring
jl. curract. ; then goto current actions
jl.w3 topdownx. ; reduce operand stack
jl.w3 toptype. ; insert sort in operand descriptor
jl.w3 rescu01x. ; rescue 01 register if used
jl.w3 topupx. ; increase operand stack
al w2 x1-oplength ; w2 := a:radicand descriptor
dl w0 x2+2 ;
ds w0 x1+2 ;
dl w0 x2+6 ; make copy of radicand descriptor
ds w0 x1+6 ;
rl w0 x2+8 ; nb: change code if oplength changes
rs w0 x1+8 ;
al w2 squaract ; get multiplication action
jl. getspact. ; goto insert special actions
\f
;/describe result
getuv: rs.w3 pickw3. ; uv to 01 register.
jl.w3 occuvx. ; occupy uv register
jl.w3 rescuuvx. ; rescue uv register
jl. (pickw3.) ; return
getdr: rs.w3 pickw3. ; dr register to work.
jl.w3 occdrx. ; occupy dr register
jl.w3 rescudrx. ; rescue dr register
jl. (pickw3.) ; return
pickw3: 0 ; for return
conresx: ; send constant to work.
rl.w2 sortmask. ;
la w2 x1+opdescr ; w2 := sort(constant)
al w0 x2+simlocm ; w0 := simpel local description with sort
rs w0 x1+opdescr ; set description
hs.w2 consort. ; save constant sort
sn w2 drsort ; if sort = drsort
am regdrofx-reg01ofx; then release dr register
jl.w3 reg01ofx. ; else release 01 register
al.w3 curract. ; set return
consort = k+1 ;
al w2 ; w2 := sort of constant
jl. toworkp. ; send constant to work area
simresx: ; describe simple result.
rl.w2 type. ; w2 := type
ls w2 2 ; w2 := 4*type
setres: hs.w2 arisult. ; set table index
descresx: ; set descriptor of arithmetic result.
rs.w3 savew3. ; save return
c. ctest, jl.w3 topinw1. z. ; ***
bz w2 x1+opcheck ; w2 := operand checkbits
sz w2 inwork ; if operand in work
sz w2 indr ; if operand in drreg
jl. 4 ; then dont release
jl.w3 downwork. ; then goto release work
jl.w3 addrof. ; (remove addrbit, in case of long etc)
al w0 simlocm ;
rs w0 x1+opdescr ; set description simpel local
jl.w3 toptype. ; insert sort in descriptor; w2:=type
rl.w3 savew3. ; set return
arisult = k+1 ;
al w2 ; w2 := table index
bl.w2 x2+arireg. ; w2 := occupyx - occ01x
jl. x2+occ01x. ; goto occupy action
arireg = k-8 ; table of resulting register.
h.; ; no type and logical type do not occur
occ01x-occ01x,occ01x-occ01x,occ01x-occ01x,occ01x-occ01x; integer
occ01x-occ01x,occ01x-occ01x,occ01x-occ01x,occ01x-occ01x; real
occ01x-occ01x,occ01x-occ01x,getuv -occ01x,getuv -occ01x; long
occdrx-occ01x,occdrx-occ01x,occdrx-occ01x,occdrx-occ01x; double
occdrx-occ01x,occdrx-occ01x,occdrx-occ01x,occdrx-occ01x; complex
occ01x-occ01x,occ01x-occ01x,occ01x-occ01x,occ01x-occ01x; trouble
uvres = k-arireg, getuv -occ01x ; result in uv register
drres = k-arireg, occdrx-occ01x ; result in dr register
w.
powresx: ; describe result of exponentiation.
rl.w2 type. ; w2 := type of exponentiation result
sn w2 double ; if type is double
am drres-uvres ; then result in dr register
al w2 uvres ; else result in uv register
jl. setres. ; goto set result of calculation
\f
;/array and zone variables
indicx: ; array indexing.
c. ctest, jl.w3 topinw1. z. ; *** *** test w1 = opandtop
am. (type.) ; type of array to be subscripted
bl.w2 sort. ; w2 := sort(type)
bl w0 x1+opdescr ; w0 := operand description
se w0 constint ; if operand not constant integer
jl. varindex. ; then goto variable index
rl w0 x1+opupper-oplength; w0 := next(upper)
sh w0 0 ; if next opand adjustable array
jl. varindex. ; then goto variable index
; ; constant subscript variable.
rl w0 x1+opcon ; w0 := constant integer index
jl.w3 topdownx. ; call reduce operand stack
ls w0 x2 ; w0 := byteindex for array
sh w0(x1+opupper) ; if byteindex > upper
sh w0(x1+oplower) ; or byteindex <= lower
jl.w3 errindex. ; then goto error in const index
rs w0 x1+opbytix ; operand byteindex := byteindex
al w2 x2+subconm ; w2 := subscript constant + sort
rs w2 x1+opdescr ; operand description := w2
jl. nextact. ; goto next action (skip indic act)
zqindexx: ; zone equivalenced to array.
am. (type.) ;
bl.w2 sort. ; w2 := sort(type)
varindex: ; variable array subscript.
hs.w2 shindex1. ; save sort of array
al w2 indexact ; index operand action
jl. newspact. ; goto enter special actions
shindex1 = k+1
shindexx: ; shift index to byteindex.
al w2 ; w2 := sort of array
al w0 lsw1 ;
jl.w3 outbyte. ; gpa:outbyte(lsw1)
jl.w3 outconst. ; call outconst(sort)
checkix: ; check index.
jl. ; switch set at initiation
;(1) jl. curract. ; if index.no then goto current act
;(2) jl. swindex. ; if index.yes then
swindex: al w2 checkact ; check index action
jl. newspact. ; goto enter special actions
zelemx: ; zone element as simple local addr.
al w0 simlocm ; w0 := simple local descriptor
al w2 real ; w2 := type real
jl. setdescr. ; goto set operand descriptor
asubscrx: ; set subscripted operand address.
al w0 subscrm ; w0 := subscripted descriptor
rl.w2 type. ; w2 := type
setdescr: ; set operand descriptor.
; ; entry: w0 := description (-sort)
; ; w2 := type
c. ctest, jl.w3 topinw1. z. ; *** *** test w1 = opandtop
jl.w3 topdescr. ; insert sort in description
addrin1x: ; set address bit and occupy w01:
jl.w3 setaddrx. ; set address in checkbits
al.w3 curract. ; set return to current actions
jl. occ01x. ; call set w01 used
\f
;/relations
; relation.
; relations appear in logical expressions. a special case of these
; are single relations in logical if statements which are given a
; special treatment. x relationoperator y will come to pass 7
; in the form x y relation relask+(= 0<10+ ask<3 + type)
; or in logif x y relation ifask+(= 1<10+ ask<3 + type)
; the parameter for relation being described in the parenthesis.
; if either x og y is evaluated in a register the generated code is
; optimised. if y is in register or neither x nor y is evaluated
; test1 is used on register ww decided by the operands type.
; if x is in register the top and next operands are exchanged and
; test2 is used
; program operator test 1 test 2 , ask code
; .and. , 0 so ww 1
; .lt. < 1 (001) 4 (100) , 1 sh ww 0
; .le. <= 3 (011) 6 (110) , 2 se ww 0
; .eq. = 2 (010) 2 (010) , 3 sh ww -1
; .ge. >= 6 (110) 3 (011) , 4 sl ww 0
; .gt. > 4 (100) 1 (001) , 5 sn ww 0
; .ne. <> 5 (101) 5 (101) , 6 sl ww 1
; .or. , 7 sz ww 1
ifrelask: 0 ; byte1 = ifrel, byte2 = ask
relx: jl.w3 inbyte. ; w2 := gpa:inbyte := parameter
al w0 2.111 ; typemask
la w0 reg2 ;
rs.w0 type. ; type := parameter & typemask
ls w2 2 ; ifrel to last bit of first byte
rs.w2 ifrelask. ; save ifrel
ls w2 -5 ; ask in unit position
la.w2 askmask. ; w2 := ask
hs.w2 ifrelask.+1 ; ask := ask from parameter
al w0 1 ; arith.number for minus := 1
hs.w0 arithno. ; set arithmetical operator number
al w0 x1-oplength ; w0 := a:operand next
se.w0 (use01.) ; if opnext not in register
jl. aritype. ; then goto minus exchanged
bz.w2 x2+askturn. ;
hs.w2 ifrelask.+1 ; ask := inverse relation
jl. exchange. ; call minus
askturn = k-1 ; relation turn table.
; 1, 2, 3, 4, 5, 6 ; ask of given relation
h. 4, 2, 6, 1, 5, 3 ; ask of turned relation
w.
\f
;/ relations 2
relsignx: ; make test on sign
; ; top operand must be in register
rl.w2 type. ; w2 := type (not logical or complex)
; ; a fast test for integer and real
; ; the code depends on real < long
sh w2 real ; if integer or real
jl. relww. ; then goto relww
al w0 signlong ; w0 :=
se w2 long ; if long then signlong
al w0 signdoub ; else signdoub
; ; register 01 is unused at call
; ; of double minus
jl.w3 outbyte. ; gpa:outbyte(w0)
relww: al w0 0 ; ww := 0
sn w2 integer ; if type = integer
al w0 1<3 ; then ww := 1
ba.w0 ifrelask.+1 ; + ask
jl.w3 outbyte. ; gpa:outbyte( ww<3 + ask )
bl.w0 ifrelask. ; w0 := logical if or relation
se w0 0 ; if logical if
jl. logifrel. ; then goto logical if
jl.w3 occ01x. ; else relation in w1
al.w2 logical ; w2 := logical
al.w3 curract. ; set return
jl. toplogx. ; top operand is logical
logifrel: al w0 goiforw>b0 ;
jl.w3 outbyte. ; gpa:outbyte(goiforw)
al.w3 nextact. ; set return, cancel normal actions
jl. topfreex. ; goto release top operand
\f
;/masking and shift
notx: ; not.
rl.w2 type. ; w2 := type
al w0 notw1 ; w0 := notw1
sl w2 real ; if type real or long
al w0 notw01 ; then w0 := notw01
jl. outcurr. ; outbyte(notww) ; goto current actions
orsplitx: am actlng ; or. modifier of or-entry
andx: al w3 0 ; and. split depending on type
rl.w2 type. ;
se w2 logical ; if type = not logical
jl. maskexpr. ; then goto mask expression
al w2 x3+andlogact ; get and/or logical actions
jl. getspact. ; goto get special actions
maskexpr:
se w3 0 ; w3 := if andmask then 0
al w3 low1-law1 ; else orbyte - andbyte
hs.w3 maskmod. ; save maskmod
rl.w1 opandtop. ; w1 := a:top operand descriptor
al w2 x1-oplength ; w2 := a:next operand
se.w2 (use01.) ; if next operand in register
jl.w3 opexchx. ; then exchange top and next
jl. curract. ; goto current actions
maskx: ; masking.
rl.w2 type. ; w2 := masking type
al w3 0 ;
se w2 integer ; w3 := if type integer then 0
al w3 law01-law1 ; else andlong - andinteger
maskmod = k+1
al w3 x3 ; w3 := w3 + maskmod
al w0 x3+law1 ; w0 := law1,low1,law01,low01
jl. outbytop. ; goto outbyte and top operand
shiftx: ; shift.
rl.w2 type. ; w2 := shifting type
al w0 lsw1 ;
se w2 integer ; w0 := if integer then lsw1
al w0 ldw1 ; else ldw1
jl. outbytop. ; outbyte and out operand
\f
;/storing
storex: ; outbyte (register store(type)).
; entry: type := type of operand
am. (type.) ;
bz.w2 sort. ; w2 := sort(type)
bl.w0 x2+regstore. ; w0 := register store(sort)
jl. outbytop. ; goto outbyte and output top operand
\f
;/constant test and conversion
monoconx: ; test constant operand.
; ; entry: w1 := a:operand descriptor
; ; exit: w1 is unchanged
; ; if operand is a constant
; ; then next action is performed
; ; else next action is skipped
bz w2 x1+opdescr ; w2 := operand descriptor byte
ls w2 getkind ; w2 := kind of operand
dl.w0 (acstatop.) ; w30 := current actions
se w2 constk ; if kind <> constant
ld w0 -12 ; then skip next action
jl. getact. ; goto get next action
; conversion of constant operands performed during translation
; to save run time conversions
conrtoix: ; convert real constant to integer.
; entry: w1 := a:operand descriptor
dl w0 x1+opcon ; w30 := real constant
truncmod: jl. truncate. ; *** modified if trunc.no ***
; cf w0 0 ; w0 := integer(real)
rs w0 x1+opcon ; set integer constant in stack
jl. setintx. ; goto set integer operand in stack
truncate: ; truncate real constant to integer:
al w2 x3 ; w2 := sign(operand);
sh w2 -1 ;
fm.w0 neg1point. ; w3w0 := abs (operand)
fs.w0 point5. ; - 0.5;
cf w0 0 ; w0 := entier (abs(operand));
sh w2 -1 ;
ac w0 (0) ; w0 := ifix(operand);
rs w0 x1+opcon ; set integer constant in stack;
jl. setintx. ; goto set integer operand in stack;
f.
neg1point: -1.0 ; floating negate sign
point5: 0.5 ; floating half
w.
conitorx: ; convert integer constant to real.
; entry: w1 := a:operand descriptor
rl w0 x1+opcon ; w0 := integer constant
ci w0 0 ; w30 := real(integer)
jl. con4. ; goto stack 4 byte constant operand
conitolx: ; convert integer constant to long.
; entry: w1 := a:operand descriptor
rl w0 x1+opcon ; w0 := integer constant
bl w3 reg0 ; w3 := first byte of w0, sign extend
bl w3 reg3 ; w3 := extended sign of w0
con4: ds w0 x1+opcon ; set 4 byte constant in stack
jl. set4x. ; goto set 4 byte
conltoix: ; convert long constant to integer.
; ; entry: w1 := a:operand descriptor
dl w0 x1+opcon ; w30 := long constant
ad w0 24 ; shift error will produce interrupt
jl. curract. ; constant is still in operand stack
\f
;/if statements
ifsplitx: ; if. split depending on type
rl.w2 type. ;
se w2 logical ; if type = not logical
jl. curract. ; goto current actions
al w2 iflogact ; replace actions by iflog actions
jl. getspact. ; goto get special action
ifarithx: ; arithmetical if.
rl.w2 type. ;
al w0 0 ; w0 := choose(w0)
sn w2 integer ; if type = integer
al w0 1<3 ; then w0 := choose(w1)
rs.w0 savebyte. ; if integer then w1 else w0
sh w2 real ; if type = integer or real
jl. curract. ; then goto current actions
bl.w0 x2+signtow0. ; w0 := byte to get sign to w0
jl. outcurr. ; outbyte ; goto current actions
signtow0 = k-long ; table of directing bytes to make
h.
signlong ; w0 := sign of long in w01
signdoub ; w0 := sign of double in dr
ctruncr ; w0 := real part of complex in dr
trouble ; not used
w.
arifposx: am 2 ; output parameter for goif.
arif0x: al w0 4 ; ask := if pos then 6 else 4
ba.w0 savelast. ; param := ww + ask
jl. outcurr. ; outbyte ; goto current actions
compgox: ; computed goto action.
jl.w3 inbyte. ; w2 := gpa:inbyte(no.labels)
rs.w2 savebyte. ; savebyte := no.labels
rs.w1 savew1. ; savew1 := a:last label operand
al w0 oplength ;
wm.w0 savebyte. ; w0 := oplength * no.labels
ws w1 reg0 ; w1 := a:operand before labels
rs.w1 opandtop. ; release all labels from opandstack
labloop: al w1 x1+oplength ; for w1 := a:next label operand
bl w0 x1+oplabel ; do
jl.w3 outbyte. ; gpa:outbyte(label)
al w0 0 ;
hs w0 x1+oplabel ; cancel label
se.w1 (savew1.) ; while w1 <> a:last label operand
jl. labloop. ;
rl.w1 opandtop. ; effectuate label release
jl. saveoutx. ; outbyte(no.labels);goto current act
\f
;/do statements
c. -1 ; the following optimization has not been adopted by the
; new implementation
dospactx: ; do special action on sign of step.
rl w0 x1+opcon ; w0 := step
al w2 -1 ; w2 := -1
sh w0 -1 ; if step < 0
al w2 1 ; then w2 :=1
hs.w2 signstep. ; w2 := -sign(step)
jl.w3 topfreex. ; reduce operand top
signstep = k+1 ;
al w2 ; w2 = -sign(step)
bz w0 x1+opdescr ;
ls w0 getkind ; w0 := kind(operandtop)
se w0 constk ; if kind <> constant
jl. dospvar. ; then goto variable until
ac w0 x2 ; w0 := sign(step)
wa w0 x1+opcon ; + untilconstant
rs w0 x1+opcon ; operandtop := skipconstant
jl. dospskip. ; else
dospvar: al w0 addw1 ;
jl.w3 outbyte. ; gpa:outbyte(addw1)
jl.w3 outconst. ; outconstant(-sign(step))
dospskip: al w0 slw1 ;
sl w2 0 ; w0 := if step > 0 then slw1
al w0 shw1 ; else shw1
al.w3 curract. ; set return
jl. outcurr. ; outbyte(skip) ; goto current act
z. ;
doexchx: ; alter operand stack:
rl.w1 opandtop. ;
al w2 x1-3*oplength ; exchange (top, next3);
jl.w3 opexchy. ; (i.e. step, boolean first)
al w1 x1-oplength ;
al w2 x1-oplength ; exchange (next1, next2);
jl.w3 opexchy. ; (i.e. until, control)
jl. curract. ; goto current actions;
\f
;/call of procedures
callx: ; call.
rl.w1 opandtop. ; w1 := a:operand descriptor
bl w2 x1+opdescr ; w2 := operand description
ls w2 getkind ; w2 := kind of called procedure
al w0 goexternal ; if external call
hs.w0 callsave. ; callsave := goexternal
sn w2 externk ;
jl. outopx. ; goto output top operand
al w0 goformal ; else (formal call)
hs.w0 callsave. ; callsave := goformal
jl.w3 outbyte. ; outbyte(goformal)
jl. outopx. ; goto output top operand
callresx: ; make result of call.
callsave = k+1
al w0 ; w0 := goformal or goexternal
sn w0 goexternal ; if w0 = goexternal
jl.w3 outbyte. ; then outbyte(goexternal)
rl.w2 type. ; w2 := type of called program unit
al.w3 curract. ; set return to current actions
se w2 undefin ; if type = undefined
sn w2 notype ; or type = notype
jl. topdowny. ; then goto reduce operand stack
al w0 simlocm ; simple local description
rs w0 x1+opdescr ; operand description is simple local
jl.w3 topsorty. ; set sort of result
al w0 xxforw>b0 ;
jl.w3 outbyte. ; gpa:outbyte(xxforw)
al.w3 nextact. ; set return to next action
sh w2 long ; if logical,integer,real, or long
jl. getuv. ; then result in uv register
jl. getdr. ; else result in double register
parcount: 0 ; parameter counter.
parpoint: 0 ; parameter pointer.
parnox: ; parameter number initiation.
al w2 lastused ;
hs.w2 lastout. ; lastout := lastused
jl.w3 inbyte. ; w2 := gpa:inbyte
rs.w2 parcount. ; parcount := total parameter number
rs.w2 parpoint. ; parpoint:= total no. of parameters
rl.w3 opandtop. ; w3:=address of top operand (last param)
loopx: rl.w2 parpoint. ; for i:=parpoint-1 step -1 until 1 do
al w2 x2-1 ; begin
sh w2 0 ; w3:=address of next parameter
jl. afloopx. ; if w3.checkbits=inwork+addr+inw01
rs.w2 parpoint. ; then clear inw01
al w3 x3-oplength ; end
bz w2 x3+opcheck ;
sn w2 inwork+addr+inw01;
al w2 inwork+addr ;
hs w2 x3+opcheck ;
jl. loopx. ;
afloopx: rl.w2 parcount. ; w2:=total number of parameters
ls w2 2 ; 4*parameter number
al w2 x2+parbytes ; +bytes reserved for return info
rs.w2 parpoint. ; parpoint := s:last parameter byte
jl.w3 worknotx. ; set release work after call
jl. curract. ; goto current actions
parnoutx: ; outbyte(no.of parameters).
al w0 0 ;
jl.w3 outbyte. ; gpa:outbyte(0) easier for pass 8
rl.w0 parcount. ;
jl. outcurr. ; outbyte(no.of parameters)
parlow4x: am -2 ; parameter pointer back 2 formals.
parlow2x: al w0 -2 ; parameter pointer back 1 formal.
wa.w0 parpoint. ; next parpoint := parpoint - 4 bytes
rx.w0 parpoint. ; w0 := parpoint; parpoint := next do.
jl. outcurr. ; outbyte(+s:formal); goto current actions
\f
;/ parameter transmission
setlastx: ; set lastused for parameter formals.
lastout = k+1 ;
al w0 ; lastused(at first call) or zero
sn w0 0 ; if lastused has been output
jl. curract. ; then goto current actions
al w2 0 ;
hs.w2 lastout. ; lastout := 0
jl. outcurr. ; outbyte(lastused); goto current act
arrzonex: ; parameter can be array equival zone.
jl.w3 topkindy. ; w2 := kind(top operand)
se w2 arreqzk ; if kind <> array equival. zone
jl. curract. ; then goto current actions
al w2 arrezact ; actions for array eq zone
am -1000 ; setpping stone
rl.w3 sortmask.+1000; lapperi: set kind to simpel local
la w3 x1+opdescr ; w3=operand sort+
al w3 x3+simlocm ; simple local kind
hs w3 x1+opdescr ;
jl. newspact. ; goto enter special actions
rangoutx: ; send ranges to dope vector in work.
jl.w3 rescu01y. ; save register 01 if used
jl.w3 topkindy. ; w2 := kind(top operand)
se w2 rangek ; if kind <> range
jl. nextact. ; then goto previous action entry
jl. curract. ; else goto current actions
psubarrx: ; choose array or zone subscripted.
jl.w3 topkindy. ; w2 := kind(top operand)
se w2 simlock ; if kind <> zone(element)
am arrspact ; then subscripted array action
al w2 subzone ; else subscripted zone action
jl. newspact. ; goto enter special actions
psubadrx: ; remove address checkbit.
jl.w3 addrofy. ; cancel address checkbit
jl. outbasex. ; goto output top operand
neglngx: ; output negative length of element.
rl.w2 type. ; w2 := type
am sort-base ;
bl.w2 x2+base. ; w2 := sort(type);
am length-base ;
bl.w2 x2+base. ; w2 := length(sort(type));
ac w0 x2 ; w0 := - length;
jl. outcurr. ; outbyte(-length); goto current act
simspltx: ; split on simpel label parameter.
jl.w3 rescu01y. ; save register 01 if used
rl.w2 type. ; w2 := type(simpel parameter)
sn w2 notype ; if type = label
jl. curract. ; then goto current actions
al w2 parsimct ; simpel parameter action
jl. getspact. ; goto get special actions
parextx: ; set external in formal.
al w2 ; w2 := kind(procedure parameter)
al w0 parproc ; (prepare external procedure)
sn w2 externk ; if kind = external then
jl. outcurr. ; outbyte(parproc)
al w2 parform ; else
ls w2 -b0 ;
jl. contact. ; continue actions(parform);
prcspltx: ; set formal external in formal.
jl.w3 rescu01y. ; save register 01 if used
jl.w3 topkindy. ; w2 := kind(top operand)
hs.w2 parextx.+1 ; parext := kind(procedure parameter)
sn w2 externk ; if kind = external
jl. curract. ; then goto current actions
al w0 dlw1 ;
jl. outcurr. ; outbyte(dlw1); goto current actions
\f
;/ parameter transmission 2
; ; make formal 1 of parameter words.
kindprcx: am -1<5+pproc -plabel ; kind procedure
kindlabx: am plabel-psimple; kind label (type := 0)
kindsimx: al w2 psimple ; kind simple
wa.w2 type. ; + type
jl. outconst. ; goto output constant byte
arrforml: 4<12 + parray ; doperel<12 + kind array-type
kindarrx: rl.w2 arrforml. ; formal 1 for parameter array
wa.w2 type. ; + type
jl. outlit2. ; goto output literal 2 constant
zonforml: 6<12 + pzone ; doperel<12 + kind zone
kindzonx: rl.w2 zonforml. ; formal 1 for zone
jl. outlit2. ; goto output literal 2 constant
kindzarx: al w2 0 ;
jl. addzar. ; goto add zone array kind
zarspltx: ; split on adjustable zone.
bl w2 x1+opzoneno ; w2 := number of zones
sl w2 0 ; if not adjustable zone array
jl. zarload. ; then goto zone array param
al w2 adjzarct ; adjustable zone array action
jl. getspact. ; goto get special actions
zarload: al w0 loadw0 ;
jl.w3 outbyte. ; gpa:outbyte(loadw0)
ls w2 12 ; number of zones < 12
addzar: al w2 x2+parray ; + kind zone array
jl. outlit2. ; goto output literal 2 constant
\f
;/return from program unit
retexitx: ; return, release zones.
jl.w3 inbyte. ; w2 := release zones<2 + sort of unit
hs.w2 returno. ; save sort of unit
so w2 1<2 ; if no release zones
jl. curract. ; then goto current actions
al w2 x2-1<2 ; remove release zone bit
hs.w2 returno. ; save sort of unit
al w2 auxrelz ; special action aux+relzone
jl. newspact. ; goto enter special action
returno = k+1 ; choose return from sort of unit.
retwayx: al w2 ; w2 := sort of unit
ls w2 2 ; byteindex for return action
al w2 x2+subrout ; load special action
jl. newspact. ; goto enter return actions
loadresx: ; load function result.
al w0 procval ; value in x2+procval at run time
jl. outcurr. ; outbyte ; goto current actions
\f
;/test initiation
w.
testinit:
ld w0 65 ;*** initiate test.
c. atest
ds.w0 passout. ;*** in and out counters = 0
z.
zerofill:
c. etest
ds w0 x2 ;***
al w2 x2-4 ;*** fill action and opstack with
sl w2 (reg1) ;*** zeroes.
jl. zerofill. ;***
z.
c. dtest
al.w1 opstack. ;***
rs.w1 acstalim. ;***
rs.w1 opandbot. ;*** leave oplength for extra actions
rs.w1 opandtop. ;***
; initialize bottom- and next lower operand to reasonable values
al w0 3<3 ; kind:=simloc
rs w0 x1+opdescr ;
rs w0 x1+opdescr-oplength ;
al w0 -7 ; addr. in stack
hs w0 x1+opplace ;
hs w0 x1+opplace-oplength ;
z.
c. etest
al w1 x1+opprint ;***
rs.w1 opused. ;***
z.
rl.w1 opandtop. ; w1 := a:top operand descriptor
jl. dirbyte. ; goto get first directing byte
init7y: jl. init7x. ; go on to initiation
\f
;/action address table
aat: ; action address table
h. ; --------------------
;action name definition page
addrin1 =(:k-aat:)<b0, addrin1x-base; 51 set address bit and occupy w01
addrout =(:k-aat:)<b0, addroutx-base; 31 make address in register 1
and =(:k-aat:)<b0, andx -base; 54 and,split on type
areas =(:k-aat:)<b0, areasx -base; 17 area pass information
arifpos =(:k-aat:)<b0, arifposx-base; 57 output parameter for goif
arif0 =(:k-aat:)<b0, arif0x -base; 57 output parameter for goif
arithop =(:k-aat:)<b0, arithopx-base; 49 arithmetical operations
arrayop =(:k-aat:)<b0, arrayopx-base; 36 array operand to stack
arrqz =(:k-aat:)<b0, arrqzx -base; 36 array equivalenced zone
arrzone =(:k-aat:)<b0, arrzonex-base; 60 split if array equival zone
asubscr =(:k-aat:)<b0, asubscrx-base; 51 set element address
call =(:k-aat:)<b0, callx -base; 59 call program unit
callres =(:k-aat:)<b0, callresx-base; 59 make result of call
change =(:k-aat:)<b0, changex -base; 46 change of action suite
compgo =(:k-aat:)<b0, compgox -base; 57 computed goto
conitol =(:k-aat:)<b0, conitolx-base; 56 integer to long constant
conitor =(:k-aat:)<b0, conitorx-base; 56 integer to real constant
conltoi =(:k-aat:)<b0, conltoix-base; 56 long to integer constant
conres =(:k-aat:)<b0, conresx -base; 50 send constant to work area
conrtoi =(:k-aat:)<b0, conrtoix-base; 56 real to integer constant
constop =(:k-aat:)<b0, constopx-base; 36 constant operand
copyop =(:k-aat:)<b0, copyopx -base; 37 copy of operand place
copy1 =(:k-aat:)<b0, copy1x -base; 35 copy one byte
copy3 =(:k-aat:)<b0, copy3x -base; 35 copy three bytes
data =(:k-aat:)<b0, datax -base; 19 set dataexist
databyt =(:k-aat:)<b0, databytx-base; 19 make length of data array
dataexi =(:k-aat:)<b0, dataexix-base; 19 if data output dataexist
dataset =(:k-aat:)<b0, datasetx-base; 19 make data array pointers
datasui =(:k-aat:)<b0, datasuix-base; 19 send sort of data
dataval =(:k-aat:)<b0, datavalx-base; 19 update data pointer
declbeg =(:k-aat:)<b0, declbegx-base; 18 declare array or zone
descres =(:k-aat:)<b0, descresx-base; 50 set description of result
divide =(:k-aat:)<b0, dividex -base; 48 division
doexch =(:k-aat:)<b0, doexchx -base; 58 alter operand stack
endline =(:k-aat:)<b0, endlinex-base; 16 end of program line
endstat =(:k-aat:)<b0, endstatx-base; 15 end of program statement
fixarr =(:k-aat:)<b0, fixarrx -base; 18 make test for fix array
getaddr =(:k-aat:)<b0, getaddrx-base; 30 get address of operand
getentr =(:k-aat:)<b0, getentrx-base; 17 get entry point list
ifarith =(:k-aat:)<b0, ifarithx-base; 57 arithmetical if
ifsplit =(:k-aat:)<b0, ifsplitx-base; 57 if,split on type
indic =(:k-aat:)<b0, indicx -base; 51 array indexing
initarr =(:k-aat:)<b0, initarrx-base; 18 initiate param array
ixforml =(:k-aat:)<b0, ixformlx-base; 18 check size of formal array
kindarr =(:k-aat:)<b0, kindarrx-base; 61 set kind array
kindlab =(:k-aat:)<b0, kindlabx-base; 61 set kind label
kindprc =(:k-aat:)<b0, kindprcx-base; 61 set kind procedure
kindsim =(:k-aat:)<b0, kindsimx-base; 61 set kind simple
kindzar =(:k-aat:)<b0, kindzarx-base; 61 set kind zone (array adj)
kindzon =(:k-aat:)<b0, kindzonx-base; 61 set kind zone(zone array)
labelop =(:k-aat:)<b0, labelopx-base; 37 label operand
leave =(:k-aat:)<b0, leavex -base; 46 leave action in stack
loadres =(:k-aat:)<b0, loadresx-base; 62 load function result
loczone =(:k-aat:)<b0, loczonex-base; 18 copy local zone info
lower =(:k-aat:)<b0, lowerx -base; 38 output array lower limit
\f
;/action address table 2
mask =(:k-aat:)<b0, maskx -base; 54 masking
minus =(:k-aat:)<b0, minusx -base; 48 subtraction
monocon =(:k-aat:)<b0, monoconx-base; 56 next action if const opand
mult =(:k-aat:)<b0, multx -base; 48 multiplication
neglng =(:k-aat:)<b0, neglngx -base; 60 negative length of element
not =(:k-aat:)<b0, notx -base; 54 not
notimpl =(:k-aat:)<b0, notimplx-base; 13 not implemented
occdr =(:k-aat:)<b0, occdrx -base; 24 dr register occupied
occuv =(:k-aat:)<b0, occuvx -base; 24 register uv occupied
occ01 =(:k-aat:)<b0, occ01x -base; 24 register 01 occupied
opset =(:k-aat:)<b0, opsetx -base; 36 set operand description
orsplit =(:k-aat:)<b0, orsplitx-base; 54 or,split on type
outarrb =(:k-aat:)<b0, outarrbx-base; 38 output array base for param
outbase =(:k-aat:)<b0, outbasex-base; 38 output array base
outcom =(:k-aat:)<b0, outcomx -base; 17 copy common list
outcopy =(:k-aat:)<b0, outcopyx-base; 38 output operand copy
outentr =(:k-aat:)<b0, outentrx-base; 17 output entry list
outext =(:k-aat:)<b0, outextx -base; 17 output external list
outlist =(:k-aat:)<b0, outlistx-base; 35 copying of lists
outop =(:k-aat:)<b0, outopx -base; 39 output operand (general)
outzin =(:k-aat:)<b0, outzinx -base; 38 output zone array index
out1 =(:k-aat:)<b0, out1x -base; 39 output the constant 1
out2 =(:k-aat:)<b0, out2x -base; 39 output the constant 2
out12 =(:k-aat:)<b0, out12x -base; 39 output the constant 12
paramar =(:k-aat:)<b0, paramarx-base; 18 parameter array declare
parext =(:k-aat:)<b0, parextx -base; 60 set external in formal
parlow2 =(:k-aat:)<b0, parlow2x-base; 59 parameter pointer back 1 formal
parlow4 =(:k-aat:)<b0, parlow4x-base; 59 parameter pointer back 2
parno =(:k-aat:)<b0, parnox -base; 59 initiate param.pointer
parnout =(:k-aat:)<b0, parnoutx-base; 59 output no.of parameters
passend =(:k-aat:)<b0, passendx-base; 16 end pass7, call pass8
placeop =(:k-aat:)<b0, placeopx-base; 37 operand addressing info
plus =(:k-aat:)<b0, plusx -base; 48 addition
powres =(:k-aat:)<b0, powresx -base; 50 set exponentiation result
prcsplt =(:k-aat:)<b0, prcspltx-base; 60 set formal external in formal
psubadr =(:k-aat:)<b0, psubadrx-base; 60 no address in param array
psubarr =(:k-aat:)<b0, psubarrx-base; 60 array or zone subscripted
pzarray =(:k-aat:)<b0, pzarrayx-base; 18 zone(array) as parameter
range =(:k-aat:)<b0, rangex -base; 38 output range
rangeop =(:k-aat:)<b0, rangeopx-base; 37 range operands to stack
rangout =(:k-aat:)<b0, rangoutx-base; 60 ranges to dope vector in work
regdrof =(:k-aat:)<b0, regdrofx-base; 24 dr register free
reg01of =(:k-aat:)<b0, reg01ofx-base; 24 01 register free
rel =(:k-aat:)<b0, relx -base; 52 relation,may be optimised
relsign =(:k-aat:)<b0, relsignx-base; 53 test sign of relation
rescudr =(:k-aat:)<b0, rescudrx-base; 25 rescue dr register
rescuuv =(:k-aat:)<b0, rescuuvx-base; 25 rescue uv register
rescu01 =(:k-aat:)<b0, rescu01x-base; 25 rescue 01 register
resinuv =(:k-aat:)<b0, resinuvx-base; 26 result in uv register
retexit =(:k-aat:)<b0, retexitx-base; 62 return release zones
retway =(:k-aat:)<b0, retwayx -base; 62 choose sort of return
savein =(:k-aat:)<b0, saveinx -base; 36 save inbyte
saveout =(:k-aat:)<b0, saveoutx-base; 38 output saved byte
setint =(:k-aat:)<b0, setintx -base; 26 set operand sort in descr
setlast =(:k-aat:)<b0, setlastx-base; 60 lastused for parameter set up
set4 =(:k-aat:)<b0, set4x -base; 26 set operand sort in descr
set8 =(:k-aat:)<b0, set8x -base; 26 set operand sort in sescr
\f
;/ action address table 3
shift =(:k-aat:)<b0, shiftx -base; 54 shift
shindex =(:k-aat:)<b0, shindexx-base; 51 shift integer index
simcop =(:k-aat:)<b0, simcopx -base; 37 simple common operand
simqz =(:k-aat:)<b0, simqzx -base; 36 simple equivalenced zone
simres =(:k-aat:)<b0, simresx -base; 50 set simple result
simsplt =(:k-aat:)<b0, simspltx-base; 60 split on label parameter
sortcon =(:k-aat:)<b0, sortconx-base; 39 output sort constant
square =(:k-aat:)<b0, squarex -base; 49 multiply if **2
store =(:k-aat:)<b0, storex -base; 55 outbyte regstore
subcnop =(:k-aat:)<b0, subcnopx-base; 36 constant subscripted op
topdown =(:k-aat:)<b0, topdownx-base; 29 reduce operand stack
topfree =(:k-aat:)<b0, topfreex-base; 29 release top operand
toplog =(:k-aat:)<b0, toplogx -base; 27 top logical to register
toplow =(:k-aat:)<b0, toplowx -base; 29 topdown in next action
topnext =(:k-aat:)<b0, topnextx-base; 27 exchange top and next
topold =(:k-aat:)<b0, topoldx -base; 26 save part of old descr
topreg =(:k-aat:)<b0, topregx -base; 27 top to register
topup =(:k-aat:)<b0, topupx -base; 37 increase operand stack
top1 =(:k-aat:)<b0, top1x -base; 27 top to register w1
typint =(:k-aat:)<b0, typintx -base; 26 set integer type
typ4 =(:k-aat:)<b0, typ4x -base; 26 set real or long type
typ8 =(:k-aat:)<b0, typ8x -base; 26 set double or complex
towork2 =(:k-aat:)<b0, towork2x-base; 33 save register in work
uninit =(:k-aat:)<b0, uninitx -base; 17 initiate new program unit
upper =(:k-aat:)<b0, upperx -base; 38 output array upper limit
workdwn =(:k-aat:)<b0, workdwnx-base; 34 reduce workpointer
worknot =(:k-aat:)<b0, worknotx-base; 34 protect work
workset =(:k-aat:)<b0, worksetx-base; 32 initiate workpointers
zarsplt =(:k-aat:)<b0, zarspltx-base; 61 pslit on adjustable zone
outzcom =(:k-aat:)<b0, outzcomx-base; 17 output zone common list
zelem =(:k-aat:)<b0, zelemx -base; 51 zone element as simple
zinwork =(:k-aat:)<b0, zinworkx-base; 32 zone index to work
znosave =(:k-aat:)<b0, znosavex-base; 38 output zone no. saved
zonedis =(:k-aat:)<b0, zonedisx-base; 38 output zone descr displ
zoneno =(:k-aat:)<b0, zonenox -base; 38 output zone no. operand
zoneop =(:k-aat:)<b0, zoneopx -base; 36 zone operand to stack
zonerec =(:k-aat:)<b0, zonerecx-base; 38 get zone record base address
zrbyti =(:k-aat:)<b0, zrbytix -base; 38 output zone rec byteindex
zqindex =(:k-aat:)<b0, zqindexx-base; 51 zone equivalenced array
\f
;/ auxiliary action table
w.
aut: ; auxiliary action entry table.
h. ; -----------------------------
auxtab = k + 3 ; auxtab is used for addressing
; ; of an auxiliary table entry
; the auxiliary table entries consist each of 4 bytes describing
; an action.
; the name of the auxiliary action is defined relatively to the
; out name of the auxiliary action entry table.
; care must be taken that names are defined when used in expressions
; therefore the auxiliary table is divided into 2 alfabetically ordered
; parts. both must be placed before the general action entry table.
; (these restrictions are caused by slang.)
; the action table can have a maximum of 2**7=128 entries at present
; part 1 of auxiliary action table
; auxiliary name , action4 , action3 , action2 , action1
chforml=(:k-aut:)<b0, 0 ,doo+topfree,doo+ixforml,out+chupper
free2 =(:k-aut:)<b0, 0 , 0 ,doo+topfree,doo+topfree
gocond =(:k-aut:)<b0, 0 ,doo+topdown,doo+outop ,out+goif
outopf =(:k-aut:)<b0, 0 , 0 ,doo+topfree,doo+outop
pardow2=(:k-aut:)<b0,out+opx3a ,doo+parlow2,out+rsw1a ,doo+setlast
pardow4=(:k-aut:)<b0,out+opx3a ,doo+parlow4,out+dsw1a ,doo+setlast
parform=(:k-aut:)<b0, 0 , 0 ,doo+topfree,aux+pardow4
parfor1=(:k-aut:)<b0, 0 , 0 ,doo+topfree,aux+pardow2
power =(:k-aut:)<b0, 0 , 0 ,doo+powres ,out+gors
reg01uv=(:k-aut:)<b0, 0 , 0 ,doo+reg01of,out+regtouv
topint =(:k-aut:)<b0, 0 , 0 ,doo+setint ,doo+topreg
topregf=(:k-aut:)<b0, 0 , 0 ,doo+topfree,doo+topreg
top1f =(:k-aut:)<b0, 0 , 0 ,doo+topfree,doo+top1
top4 =(:k-aut:)<b0,doo+set4 ,doo+occ01 ,doo+topreg ,doo+rescu01
top8 =(:k-aut:)<b0,doo+set8 ,doo+occdr ,doo+topreg ,doo+rescudr
zoneq2 =(:k-aut:)<b0,doo+zelem ,out+zrechk ,doo+zonedis,out+addw3
zoneq1 =(:k-aut:)<b0,con+zoneq2 ,doo+outop ,out+rlw3 ,doo+zrbyti
c. (:(:k-aut:) a. 2.11:) - 1
m.*** formaterror of auxiliary action table part 1
z.
; part 2 of auxiliary action table
addrcon=(:k-aut:)<b0, 0 ,doo+addrout,doo+conres ,doo+topreg
addrget=(:k-aut:)<b0, 0 , 0 ,doo+outop ,out+alw1
addrop =(:k-aut:)<b0, 0 , 0 ,doo+outop ,out+rlw1a
addrsim=(:k-aut:)<b0, 0 , 0 , 0 ,doo+addrout
adjarr1=(:k-aut:)<b0,con+chforml,doo+sortcon,out+rlw3 ,doo+lower
arifneg=(:k-aut:)<b0,doo+topdown,doo+outop ,out+gosimpl,aux+gocond
arrbase=(:k-aut:)<b0,doo+outbase,out+rsw1a ,doo+lower ,out+subw1a
arrezp =(:k-aut:)<b0,doo+zrbyti ,out+addw1a ,out+opx1a ,out+0
arrfor1=(:k-aut:)<b0, 0 , 0 ,doo+kindarr,out+loadw0a
arrinit=(:k-aut:)<b0,out+starray,doo+initarr,doo+outop ,out+dlw1a
asslab =(:k-aut:)<b0,doo+topdown,doo+outop ,out+rsw1a ,doo+topdown
byteix =(:k-aut:)<b0, 0 , 0 ,doo+sortcon,out+lsw1a
callout=(:k-aut:)<b0,doo+workdwn,out+point01,doo+parnout,doo+setlast
ctor =(:k-aut:)<b0, 0 ,out+ctruncr,doo+regdrof,aux+top4
datacon=(:k-aut:)<b0,out+opx3a ,out+0 ,doo+dataval,out+addw3
datafin=(:k-aut:)<b0,doo+outcopy,out+rsw1a ,doo+outcopy,out+addw1a
datanew=(:k-aut:)<b0, 0 , 0 ,doo+dataset,doo+lower
dataux2=(:k-aut:)<b0,out+suite ,doo+datasui,doo+outop ,out+rsw3
dataux1=(:k-aut:)<b0,con+datacon,doo+outop ,out+rlw3 ,aux+topregf
declare=(:k-aut:)<b0,out+opx2a ,doo+saveout,out+rsw1a ,doo+declbeg
doass =(:k-aut:)<b0, 0 ,doo+store ,aux+topregf,doo+setint
dofirst=(:k-aut:)<b0,doo+topup ,doo+outop ,out+dogofor,doo+toplow
doinit2=(:k-aut:)<b0,out+xxchang,out+xxbackw,out+goforwa,doo+towork2
doinit1=(:k-aut:)<b0,con+doinit2,out+opx0a ,out+0<b0 ,out+alw1
doinit =(:k-aut:)<b0, 0 ,con+doinit1, simlock ,doo+opset
doloop =(:k-aut:)<b0, 0 ,out+xxforw ,doo+outop ,out+rsw2
domult1=(:k-aut:)<b0, 0 , 0 ,con+outopf ,out+domul
domult =(:k-aut:)<b0,con+domult1,out+opx1a ,out+0<b0 ,out+acw1
doparr =(:k-aut:)<b0,con+parform,aux+arrfor1,doo+getaddr,doo+towork2
doplow =(:k-aut:)<b0, 0 ,doo+towork2,doo+lower ,out+loadw1a
doprang=(:k-aut:)<b0,doo+topfree,doo+towork2,doo+range ,out+loadw1a
dopupp =(:k-aut:)<b0, 0 ,doo+towork2,doo+upper ,out+loadw1a
\f
;/auxiliary action table 2
dostep3=(:k-aut:)<b0, 0 ,con+free2 ,doo+arithop,doo+minus
dostep2=(:k-aut:)<b0,con+dostep3,doo+store ,doo+arithop,doo+plus
dostep1=(:k-aut:)<b0,con+dostep2,aux+outopf ,out+doclear,doo+doexch
dostep =(:k-aut:)<b0, 0 ,con+dostep1,doo+rescu01,doo+topreg
dotest =(:k-aut:)<b0, 0 , 0 ,out+goiforw,out+3<b0
dtol =(:k-aut:)<b0,out+gors ,out+dtruncl,doo+resinuv,aux+top4
dtor =(:k-aut:)<b0,out+gors ,out+dtruncr,doo+resinuv,aux+top4
formal =(:k-aut:)<b0, 0 ,out+opx2a ,doo+copy1 ,out+dlw1a
funcval=(:k-aut:)<b0, 0 , 0 ,out+opx2ia ,doo+loadres
goaddr =(:k-aut:)<b0, 0 , 0 ,out+gors ,out+endaddr
;gocond see auxiliary table start
itol =(:k-aut:)<b0, 0 , 0 ,out+iconvl ,aux+top4
itolin7=(:k-aut:)<b0, 0 , 0 ,doo+set4 ,doo+conitol
itorin7=(:k-aut:)<b0, 0 , 0 ,doo+set4 ,doo+conitor
itor =(:k-aut:)<b0,out+ifloatr,aux+top4 ,con+itorin7,doo+monocon
lowerix=(:k-aut:)<b0, 0 ,con+byteix ,doo+out1 ,out+subw1a
ltod =(:k-aut:)<b0,con+power ,out+lfloatd,aux+reg01uv,aux+top8
ltoi =(:k-aut:)<b0, 0 , 0 ,out+lconvi ,aux+topint
ltor =(:k-aut:)<b0, 0 ,out+gors ,out+lfloatr,aux+loadres
ltoiin7=(:k-aut:)<b0, 0 , 0 ,doo+setint ,doo+conltoi
nexaddr=(:k-aut:)<b0, 0 ,doo+topup ,doo+getaddr,doo+toplow
;outopf - parfor2 see auxiliary table start
pararr =(:k-aut:)<b0,con+doparr ,doo+arrzone,doo+outarrb,out+loadw1a
parlab =(:k-aut:)<b0, 0 ,con+parform,doo+kindlab,out+loadw0a
parzone=(:k-aut:)<b0,doo+znosave,out+chzono ,doo+pzarray,doo+savein
procfor=(:k-aut:)<b0, 0 ,con+parform,doo+kindprc,out+loadw0a
rangpar=(:k-aut:)<b0, 0 ,con+rangpar,aux+doprang,doo+rangout
relasub=(:k-aut:)<b0,doo+descres,doo+arithop,aux+topregf,doo+rel
relzone=(:k-aut:)<b0, 0 , 0 ,out+gors ,out+zonerel
rpowi =(:k-aut:)<b0, 0 ,con+power ,out+rexpoi ,doo+typ4
rsuv0 =(:k-aut:)<b0, 0 ,out+reguv0 ,aux+nexaddr,aux+reg01uv
rsuv01 =(:k-aut:)<b0,con+rsuv0 ,doo+getaddr,doo+rescu01,doo+rescuuv
rtoc =(:k-aut:)<b0,doo+powres ,out+rconvc ,doo+reg01of,aux+top8
rtod =(:k-aut:)<b0,con+power ,out+rconvd ,aux+reg01uv,aux+top8
rtoiin7=(:k-aut:)<b0, 0 , 0 ,doo+setint ,doo+conrtoi
rtoi =(:k-aut:)<b0,out+rtrunci,aux+topint ,con+rtoiin7,doo+monocon
rtol =(:k-aut:)<b0, 0 ,out+gors ,out+rtruncl,doo+topreg
saveset=(:k-aut:)<b0, 0 ,out+opx2a ,doo+saveout,out+rsw1a
shift12=(:k-aut:)<b0, 0 , 0 ,doo+out12 ,out+lsw1a
simeqz =(:k-aut:)<b0, 0 ,aux+zoneq1 ,out+loadw1a,doo+rescu01
sspower=(:k-aut:)<b0,doo+topfree,aux+rsuv01 ,doo+worknot,doo+rescu01
subform=(:k-aut:)<b0, 0 ,con+parfor1,doo+kindsim,out+addw1a
submove=(:k-aut:)<b0,con+subform,out+opx0a ,out+5<b0 ,out+lsw1a
subrest=(:k-aut:)<b0,con+submove,out+opx1a ,doo+neglng ,out+acw1
subz1 =(:k-aut:)<b0,con+subrest,out+amodifa,out+4<b0 ,out+0
;topint,top8,top4 see auxiliary table start
xdexpod=(:k-aut:)<b0,con+power ,out+dexpod ,aux+sspower,doo+typ8
xipow =(:k-aut:)<b0, 0 ,con+rtoi ,aux+rpowi ,aux+sspower
xitor =(:k-aut:)<b0,con+xipow ,doo+typ4 ,doo+topup ,aux+itor
zarform=(:k-aut:)<b0, 0 ,doo+zoneno ,out+loadw1a,aux+pardow2
zarset =(:k-aut:)<b0,con+parfor1,doo+kindzar,out+addw1a ,aux+shift12
zcomma =(:k-aut:)<b0,doo+outop ,out+addw1a ,out+zindex ,doo+zoneno
zinzar =(:k-aut:)<b0,con+zarset ,doo+out1 ,out+addw1a ,doo+outzin
;zoneq2,zoneq1 see auxiliary table start
zrbase =(:k-aut:)<b0,doo+out2 ,out+lsw1a ,doo+outop ,out+rlw3
c. (:(:k-aut:) a. 2.11:) - 1
m.*** formaterror of auxiliary action table part 2
z.
\f
;/special action table
w.
sat: ; special action entry table
h. ;----------------------------
spact = k + 3
; the following action entries are used when in an action a different
; suite of actions should be taken.
; action name , action4 , action3 , action2 , action1
iflogact = k-sat ; same as andlogact. obs orlogact must follow
andlogact= k-sat , 0 ,out+goiforw,out+ask0w1 ,aux+topregf
orlogact = k-sat , 0 ,out+goiforw,out+ask7w1 ,aux+topregf
addrnext = k-sat ,con+reg01uv,aux+nexaddr,doo+rescu01,doo+rescuuv
addr2uva = k-sat , 0 ,doo+topfree,doo+change ,aux+rsuv01
adjzarct = k-sat , 0 , 0 ,con+zarset ,aux+zarform
auxrelz = k-sat , 0 , 0 , 0 ,con+relzone
arrezact = k-sat ,con+arrezp ,out+rlw1a ,doo+zonedis,out+addw1a
checkact = k-sat ,doo+lower ,out+chlower,doo+upper ,out+chupper
indexact = k-sat , 0 ,doo+shindex,doo+topfree,doo+top1
labelact = k-sat , 0 ,doo+labelop, labelk ,doo+opset
parsimct = k-sat ,con+parform,doo+kindsim,out+loadw0a,doo+getaddr
squaract = k-sat ,doo+descres,doo+arithop,aux+topregf,doo+mult
subarr = k-sat ,con+subrest,doo+upper ,out+subw1a ,doo+psubadr
subzone = k-sat ,con+subz1 ,doo+zonerec,out+subw1a ,doo+zonerec
zparact = k-sat ,con+saveset,out+opx2ia ,doo+copy1 ,out+loadw1a
subrout = k-sat , 0 , 0 , 0 ,con+goaddr
uvfunct = k-sat ,out+gors ,out+endreg ,aux+funcval,out+dlw1a
drfunct = k-sat ,con+goaddr ,out+draddr ,aux+funcval,out+drloada
; the subrout, uvfunct, and drfunct actions must be in sequence
; see retway action
addr2uv = addr2uva - addrnext
arrspact = subarr - subzone
c. (:(:k-sat:) a. 2.11:) - 1
m.*** formaterror special action table
z.
\f
;/ main action table
; action table.
h.;-------------
acttab = k-1
; the order of the action table corresponds to the values of the
; directing bytes from pass 6. the action entry is put into the action
; stack.
; each action table entry consists of a double word holding 4
; actions of 1 byte each and action 1 in the last byte.
; the structure of an action is: action name<b0 + standard action
; the standard actions are:
; 0 : next action entry from action stack, if empty new dir.byte
; aux: place auxiliary actions in action stack
; con: continuation actions to action stack
; doo: perform named instructions of pass 7 code
; out: output (directing) byte for pass 8
; action4 , action3 , action2 , action1 ; byte from pass 6
; ; h0+ unit separator.
0 , 0 ,doo+uninit ,out+unit7 ; 0 begin unit
0 , 0 , 0 ,out+funit7 ; 1 end unit
0 ,doo+passend,out+pass7 ,doo+copy1 ; 2 end pass
; ; h1+ lists.
0 ,out+glolist,doo+getentr,doo+savein ; 0 global entries
0 ,out+comlist,doo+outcom ,doo+savein ; 1 common list
0 ,out+comzones,doo+outzcom,doo+savein ; 2 zones in common
0 ,out+extlist,doo+outext ,doo+savein ; 3 external list
0 , doo+dataexi ,out+entryvalue,doo+outlist; 4 local entries
0 , 0 ,out+labvarinit,doo+outlist; 5 label var.list
; ; h2+ declarations.
con+parzone,aux+saveset,aux+formal ,doo+savein ; 0 parameter zone
0 , 0 ,con+declare,out+locinit; 1 local array
out+zoninit,doo+loczone,aux+declare,out+locinit; 2 local zone
0 , 0 ,con+declare,out+cominit; 3 common array
0 , 0 ,con+declare,out+cominit; 4 common zone
0 ,out+extzone,doo+copy1 ,doo+copy1 ; 5 external zone
; ; h3+ parameter array.
doo+lower ,out+rsw1a ,aux+lowerix,aux+top1f ; 0 adjustable lower
doo+upper ,out+rsw1a ,aux+byteix ,aux+top1f ; 1 adjustable upper
0 , 0 ,con+arrbase,aux+arrinit; 2 initiate array
con+chforml,aux+byteix ,doo+fixarr ,out+loadw1a; 3 fixedlimit array
ixcheck1=k-1; (the action is blind if index.no)
con+adjarr1,out+subw1a ,doo+upper ,out+rlw1a ; 4 adjustable array
ixcheck2=k-1; (the action is blind if index.no)
; ; h4+ data.
con+datafin,doo+topfree,doo+databyt,out+loadw1a; 0 data star
con+dataux2,doo+outcopy,out+rsw3 ,aux+dataux1; 1 data single
con+dataux2,doo+outcopy,out+xxback ,aux+dataux1; 2 data multiple
0 , 0 ,doo+topdown,doo+workdwn; 3 data array end
\f
;/action table 2
; action4 , action3 , kind , action1 ;
; ; h5+ operands.
0 ,doo+placeop, simlock ,doo+opset ; 0 local simple
0 ,doo+simcop , simcomk ,doo+opset ; 1 common simple
0 ,doo+placeop, simformk ,doo+opset ; 2 formal simple
doo+copyop ,doo+subcnop, subconk ,doo+opset ; 3 simple eq array
con+simeqz ,doo+simqz , simlock ,doo+opset ; 4 simple eq zone
0 ,doo+placeop, labvark ,doo+opset ; 5 label variable
0 ,doo+placeop, simlock ,doo+opset ; 6 procedure name
doo+copyop ,doo+arrayop, arrayk ,doo+opset ; 7 array
0 ,doo+arrqz , arreqzk ,doo+opset ; 8 array eq zone
0 ,doo+zoneop , zonek ,doo+opset ; 9 zone
0 ,doo+placeop, externk ,doo+opset ; 10 external
0 ,doo+placeop, extformk ,doo+opset ; 11 formal external
; 0 ,doo+statfop, statfunk ,doo+opset ; - statem.func
; 0 ,doo+statfop, simlock ,doo+opset ; - stat.func.form
; , action2 , ; h7+ end bytes.
0 , 0 , 0 ,doo+endstat; 0 end statement
0 , 0 ,out+newline,doo+endline; 1 end line
0 , 0 , 0 ,doo+notimpl; 2
0 , 0 , 0 ,out+xxforw ; 3 end logical if
con+arifneg,doo+arif0 ,aux+gocond ,doo+arifpos; 4 end arith. if
0 ,out+openfor,doo+copy1 ,doo+copy1 ; 5 open format
0 ,out+closfor,doo+copy1 ,doo+copy1 ; 6 closed format
0 , 0 , 0 ,out+entrypoint; 7 main entry
0 , 0 ,doo+data,out+dataentry ; 8 data entry
0 , 0 , 0 ,out+xxforw ; 9 end formal decl
; ; h8+ format.
0 ,out+begfor ,doo+copy1 ,doo+copy1 ; 0 format begin
0 ,out+contfor,doo+copy1 ,doo+copy1 ; 1 format continue
; ; h9+ parameters.
con+parform,doo+kindzon,out+loadw0a,doo+getaddr; 0 par zone
0 ,con+parform,doo+zarsplt,doo+getaddr; 1 par zone array
;con+zinzar ,out+subw1a ,aux+zarform,doo+getaddr; 2 par zone indic (not used)
0 , 0 , 0 ,doo+notimpl; (2 par zone indic not impl)
; ; h10+ zone commas.
doo+towork2,aux+zcomma ,out+chupper,aux+top1f ; 0 zone indic comma
out+zrechk ,doo+zelem ,aux+zrbase ,aux+top1f ; 1 zone subscript
; ; h11+ parameterno.
doo+parno ,doo+rescu01,doo+rescuuv,doo+rescudr; 0 parameter count
; ; h12+ array range.
0 , 0 , 0 ,doo+rangeop; 0 ranges
; ; h13+ enter + exit.
0 , 0 ,doo+topdown,out+entry ; 0 entry
0 ,doo+retway ,doo+retexit,out+return ; 1 return
0 ,out+gors ,out+stop ,aux+top1f ; 2 stop
; ; h14+ goto + labels.
con+asslab ,doo+outop ,out+prepjump,doo+topnext; 0 assign label
0 , 0 ,out+label ,doo+copy1 ; 1 declare label
0 ,doo+topdown,doo+outop ,out+gosimpl; 2 goto label
0 ,out+gors ,out+gopoint,aux+top1f ; 3 goto assigned
0 ,out+complist,doo+compgo ,aux+top1f ; 4 goto computed
; ; h15+ logical ops.
out+relation,doo+relsign,doo+topreg,aux+relasub; 0 relation
0 , 0 ,out+xxforw ,doo+toplog ; 1 logpoint
\f
;/action table 3
; action4 , action3 , action2 , action1 ;
; ; h16+ do.
0 , 0 ,con+doloop ,aux+doinit ; 0 do general
0 , 0 , 0 , 0 ; 1 do special
0 , 0 ,con+dofirst,doo+rescu01; 2 do equal general
0 , 0 , 0 , 0 ; 3 do equal special
0 , 0 ,out+xxforw ,aux+doass ; 4 do init general
doo+topnext,aux+doloop ,aux+doinit ,aux+doass ; 5 do init special
0 , 0 , 0 , 0 ; 6 do until
con+dotest ,aux+domult ,aux+dostep ,doo+setint ; 7 do step
0 ,out+xxforw ,out+gobackw,out+xxchang; 8 do terminate
; ; h17+ read-write.
out+xxforw ,out+gors ,out+readinit ,aux+callout; 0 read initiate
out+xxforw ,out+gors ,out+writeinit,aux+callout; 1 write initiate
out+xxforw ,out+gors ,out+readcall ,aux+callout; 2 read call
out+xxforw ,out+gors ,out+writecall,aux+callout; 3 write call
; ; h18+ implied do.
0 , 0 , 0 ,con+doinit ; 0 implied begin
0 , 0 , 0 ,con+doloop ; 1 implied do
; ; h19+ trouble.
0 , 0 , 0 ,out+troubla; 0 trouble
0 , simlock ,doo+opset ,out+troubla; 1 trouble operand
; ; h20+ conversion.
con+itol ,con+itolin7,doo+monocon,doo+typint ; 0 i conv l
0 , 0 ,con+itor ,doo+typint ; 1 i float r
0 ,con+rtod ,aux+itor ,doo+typint ; 2 i float d
0 ,con+rtoc ,aux+itor ,doo+typint ; 3 i float c
con+ltoi ,con+ltoiin7,doo+monocon,doo+typ4 ; 4 l conv i
0 , 0 ,con+ltor ,doo+typ4 ; 5 l float r
0 , 0 ,con+ltod ,doo+typ4 ; 6 l float d
0 ,con+rtoc ,aux+ltor ,doo+typ4 ; 7 l float c
0 , 0 ,con+rtoi ,doo+typ4 ; 8 r trunc i
0 , 0 ,con+rtol ,doo+typ4 ; 9 r trunc l
0 , 0 ,con+rtod ,doo+typ4 ; 10 r conv d
0 , 0 ,con+rtoc ,doo+typ4 ; 11 r conv c
0 ,con+rtoi ,aux+dtor ,doo+typ8 ; 12 d trunc i
0 , 0 ,con+dtol ,doo+typ8 ; 13 d trunc l
0 , 0 ,con+dtor ,doo+typ8 ; 14 d trunc r
0 ,con+rtoc ,aux+dtor ,doo+typ8 ; 15 d conv c
0 ,con+rtoi ,aux+ctor ,doo+typ8 ; 16 c trunc i
0 ,con+rtol ,aux+ctor ,doo+typ8 ; 17 c trunc l
0 , 0 ,con+ctor ,doo+typ8 ; 18 c conv r
0 ,con+rtod ,aux+ctor ,doo+typ8 ; 19 c conv d
0 ,doo+topup ,doo+leave ,doo+toplow ; 20 next
; ; h29+ exponents.
con+xitor ,doo+toplow ,doo+square ,doo+typint ; 0 integer**integer
con+rpowi ,aux+sspower,doo+square ,doo+typ4 ; 1 real **integer
con+power ,out+lexpoi ,aux+sspower,doo+typ4 ; 2 long **integer
con+xdexpod,aux+rtod ,aux+itor ,doo+typint ; 3 double **integer
con+power ,out+rexpor ,aux+sspower,doo+typ4 ; 4 real **real
0 , 0 ,con+xdexpod,doo+rescudr; 5 double **double
0 ,con+xdexpod,aux+rtod ,doo+typ4 ; 6 double **real
; ; h30+ pass info.
0 , 0 ,doo+outentr,doo+workset; 0 area simple
0 , 0 ,doo+copy3 ,doo+areas ; 1 area
c. (:(:k-1-acttab:) a. 2.11:) - 1
m.*** formaterror main action table
z.
\f
;/ action table 4
typedep4 = k + 3 - acttab ; byteindex of first type action
typedep = typedep4 > 2
typedepn = -(:(:typedep+7:)>3:)<3
; action4 , action3 , action2 , action1 ; typedependant bytes.
; ; h21+ data init.
con+datanew,out+addw1a ,doo+outop ,out+loadw1a; 0 data initiate
; ; h22+ arithmetic.
0 , 0 , 0 ,doo+notimpl; 0 monadic minus
doo+descres,doo+arithop,aux+topregf,doo+minus ; 1 dyadic minus
doo+descres,doo+arithop,aux+topregf,doo+plus ; 2 plus
doo+descres,doo+arithop,aux+topregf,doo+mult ; 3 multiply
doo+descres,doo+arithop,aux+topregf,doo+divide ; 4 divide
; ; h23+ logicals.
0 , 0 ,doo+not ,doo+topreg ; 0 not
doo+simres ,doo+mask ,aux+topregf,doo+and ; 1 and
doo+simres ,doo+mask ,aux+topregf,doo+orsplit; 2 or
doo+simres ,doo+shift ,aux+topregf,doo+topnext; 3 shift
; ; h24+ assignments.
0 ,doo+topfree,doo+store ,aux+topregf; 0 assignment
0 ,doo+topold ,doo+store ,aux+topregf; 1 multiple assign
; ; h25+ subscript.
doo+asubscr,doo+outop ,out+addw1a ,doo+indic ; 0 indic
0 ,con+zoneq1 ,out+addw1a ,doo+zqindex; 1 zone eq array
; ; h26+
out+xxforw ,doo+callres,doo+call ,aux+callout; 0 call
; ; h27+ parameters.
con+parlab ,doo+outop ,out+prepjump,doo+simsplt; 0 par simple
doo+psubarr,out+subw1a ,aux+pardow2,doo+getaddr; 1 par subscr array
con+pararr ,aux+dopupp ,aux+doplow ,aux+rangpar; 2 par array
con+procfor,doo+parext ,doo+outop ,doo+prcsplt; 3 par procedure
; ; h28+ if.
doo+ifarith,doo+topfree,doo+topreg ,doo+ifsplit; 0 if
; ; h6+ constant.
0 ,doo+constop, constk ,doo+opset ; 0
; ; h31+ pararameter array.
0 ,doo+paramar, arrayk ,doo+opset ; 0
dirmax = (:k+3 - acttab - typedep4:)<1 - typedepn
; maximal value for pass 6 directing bytes
c. (:(:k+3-acttab-typedep4:) a. 2.11:) - 1
m.*** formaterror typedependant action table
z.
\f
;/initiation of pass 7
w.
actstack = k + actlng - 2 ; action stack.
; ; 5 double word entries are;
; ; reserved for the action stack
opstack = actstack + 5*actlng +2; operand stack.
; ; entries of oplength are placed in
; ; the operand stack
init7x: ; initiate pass 7.
; ; the code is overwritten by the
; ; action and operand stacks
al w0 end7 ;
am. (endbyte.) ;
jl.w3 endbyte. ; gpa:outbyte(end of pass 7)
am. (mode2.) ;
rl.w2 mode2. ; w2 := gpa:more modebits for compilation
rl.w0 cfw00. ; w0 := simple convert real to integer;
so w2 truncbit ; if trunc.no then
am. (trcinit.) ;
rs.w0 trcinit. ; modify code;
am. (mode.) ; set index check switch.
rl.w2 mode. ; w2 := gpa:modebits for compilation
al w0 swindex-checkix; w0 := set switch to take index act
so w2 chindex ; if index.no
al w0 curract-checkix; then w0 := switch to current act
am. (ixcheck.) ;
hs.w0 ixcheck. ; set index check switch
al w0 doo+topfree ; w0 := dummy action
so w2 chindex ; if index.no then
rs.w0 ixcheck1. ; make no indexcheck with
so w2 chindex ; formal- or actual arrays;
rs.w0 ixcheck2. ;
; ; prepare arithmetic interrupt.
al w0 -1 ; interrupt bit1 := bit2 := 1
so w2 spillbit ; if spill.no
ls w0 -2 ; then bit1 := 0 ; bit2 := 1
am. (intinit.) ;
al.w3 intinit. ; w3 := a:interrupt sequence
jd 1<11 + 0 ; call monitor: set interrupt
; ; only bit1 and bit2 of w0 is used
; ; high precision set in pass 2
am. (mulinit.) ;
rl.w1 mulinit. ; constant integer arithmetic instruction
sh w0 0 ; if spill.yes
am. (mulsoft.) ;
rs.w1 mulsoft. ; then set software interrupt in mult
\f
;/initiation 2
; ; initiate pointers.
al.w1 actstack. ; w1 := a:action stack
am. (aastatop.) ;
rs.w1 aastatop. ; action table top pointer
al w1 x1-actlng ;
am. (aastabot.) ;
rs.w1 aastabot. ; initiate action stack bottom
al.w1 opstack.-oplength ; w1 := a:operand stack - oplength
am. (ooandbot.) ;
rs.w1 ooandbot. ; operand stack bottom
am. (ooandtop.) ;
rs.w1 ooandtop. ; operand stack top pointer
am. (last.) ; lastword defined at end
rl.w2 last. ; w1 := a:last word to use
al w2 x2-oplength ; - oplength
am. (ooandlim.) ;
rs.w2 ooandlim. ; operand stack limit
jl. testinit. ; goto get directing byte
endbyte: outbyte. ; distances used for far reaching
mode: modebits. ;
mode2: modebit2. ;
trcinit: truncmod. ;
cfw00: cf w0 0 ; (simple conversion)
ixcheck: checkix.+1 ;
intinit: intrupt. ;
mulinit: mulspill. ;
mulsoft: mulset. ;
aastabot: acstabot. ;
aastatop: acstatop. ;
ooandbot: opandbot. ;
ooandtop: opandtop. ;
ooandlim: opandlim. ;
last: lastword. ; distance to pass 0 lastword
length7 = k - start7 ; length of pass in bytes
e30 = e30 + length7 ; length := length + length pass 7;
; end of pass 7 instructions
i.
m. rc 83.08.29 fortran, pass 7
e.
▶EOF◀