%EXTERNALROUTINE ISKIMP(%STRING(63) S)
%ROUTINESPEC READ LINE
%INTEGERFNSPEC COMPARE(%INTEGER PSP)
%ROUTINESPEC SS
%ROUTINESPEC FAULT(%STRING(63) S)
%INTEGERFNSPEC CHNEXT
%INTEGERFNSPEC NEWCELL
%INTEGERFNSPEC RETURN CELL(%INTEGER I)
%ROUTINESPEC PRINT NAME(%INTEGER I)
%ROUTINESPEC PHEX(%INTEGER I,J)
%INTEGER I,J,AP,APP,TP,ASL,BTN,CHP,FAULTS,NL,LEVEL,CA,COMP,SCF,PARS
%INTEGER LOPR,ASSOPP,LSTPP
%OWNSHORTINTEGERARRAY PS(-1000:-573)=%C
-997,-910,-855,-984, 201, 198,-775,-761, 212, 200, 197, 206,
-910,-863,-872,-855,-980, 2, 58,-1000,-971, 198, 201, 206,
201, 211, 200,-872,-855,-961, 201, 206, 212, 197, 199, 197,
210,-717,-855,-955,-673,-654, 1,-647,-855,-950, 197, 206,
196,-855,-943, 194, 197, 199, 201, 206,-855,-929, 197, 206,
196, 207, 198, 208, 210, 207, 199, 210, 193, 205,-855,-924,
42, 3,-599,-855,-918, 42,-841, 2,-578,-855,-913, 42,
42, 2,-855,-911,-855, 0,-906, 1,-850,-782,-902, 45,
62, 2,-896, 211, 212, 193, 210, 212,-889, 210, 197, 212,
213, 210, 206,-878, 210, 197, 211, 213, 204, 212, 61,-841,
-833,-821,-873, 211, 212, 207, 208, 0,-865, 197, 204, 211,
197,-910,-863,-864, 0,-857, 193, 206, 196,-910,-863,-856,
0,-853, 10,-851, 59, 0,-843, 40,-841,-833,-821,-790,
41,-842, 0,-839, 43,-837, 45,-835, 92,-834, 0,-830,
1,-850,-828, 2,-822, 40,-841,-833,-821, 41, 0,-817,
-815,-833,-821,-816, 0,-812, 60, 60,-809, 62, 62,-807,
38,-804, 33, 33,-802, 33,-799, 42, 42,-797, 47,-795,
42,-793, 43,-791, 45, 0,-784, 44,-841,-833,-821,-790,
-783, 0,-777, 61,-841,-833,-821,-776, 0,-767,-841,-833,
-821,-733,-841,-833,-821,-762, 40,-775,-761, 41, 0,-755,
193, 206, 196,-775,-748,-750, 207, 210,-775,-740,-749, 0,
-742, 193, 206, 196,-775,-748,-741, 0,-735, 207, 210,-775,
-740,-734, 0,-731, 61,-728, 92, 61,-725, 60, 61,-723,
60,-720, 62, 61,-718, 62, 0,-699, 193, 210, 210, 193,
217, 1,-695, 40,-841,-833,-821, 58,-841,-833,-821, 41,
-689,-696, 1,-695, 0,-691, 44, 1,-695,-690, 0,-675,
44, 1,-695, 40,-841,-833,-821, 58,-841,-833,-821, 41,
-689,-674, 0,-665, 210, 207, 213, 212, 201, 206, 197,-655,
201, 206, 212, 197, 199, 197, 210, 198, 206, 0,-649, 211,
208, 197, 195,-648, 0,-633, 40, 201, 206, 212, 197, 199,
197, 210,-631, 1,-695,-614, 41,-632, 0,-621, 193, 210,
210, 193, 217, 206, 193, 205, 197,-616, 206, 193, 205, 197,
-615, 0,-601, 44, 201, 206, 212, 197, 199, 197, 210,-631,
1,-695,-614,-600, 0,-594, 4, 2, 44, 2,-589, 5,
2, 44,-588, 0,-586, 1,-582, 60, 2, 62,-579, 2,
-578, 0,-574, 40, 2, 41,-573, 0
%OWNINTEGERARRAY ASSOP(0:255)=%C
0,M'BALR',M'BTCR',M'BFCR',M'NHR',M'CLHR',M'OHR',M'XHR',M'LHR',M'CHR',
M'AHR',M'SHR',M'MHR',M'DHR',M'ACHR',M'SCHR',0(16),M'BTBS',M'BTFS',
M'BFBS',M'BFFS',M'LIS',M'LCS',M'AIS',M'SIS',M'LER',M'CER',M'AER',
M'SER',M'MER',M'DER',0(18),M'STH',M'BAL',M'BTC',M'BFC',M'NH',M'CLH',
M'OH',M'XH',M'LH',M'CH',M'AH',M'SH',M'MH',M'DH',M'ACH',M'SCH',0(16),
M'STE',M'AHM',0,0,M'ATL',M'ABL',M'RTL',M'RBL',M'LE',M'CE',M'AE',
M'SE',M'ME',M'DE',0(34),M'SRLS',M'SLLS',M'STBR',M'LBR',M'EXBR',
M'EPSR',M'WBR',M'RBR',M'WHR',M'RHR',M'WDR',M'RDR',M'MHUR',M'SSR',
M'OCR',M'AIR',0(32),M'BXH',M'BXLE',M'LPSW',M'THI',M'NHI',M'CLHI',
M'OHI',M'XHI',M'LHI',M'CHI',M'AHI',M'SHI',M'SRHL',M'SLHL',M'SRHA',
M'SLHA',M'STM',M'LM',M'STB',M'LB',M'CLB',M'AL',M'WB',M'RB',M'WH',
M'RH',M'WD',M'RD',M'MHU',M'SS',M'OC',M'AI',0,M'SVC',M'SINT',0(7),
M'RRL',M'RLL',M'SRL',M'SLL',M'SRA',M'SLA',0(16)
%OWNBYTEINTEGERARRAY ASST(0:255)=2(16),0(16),2(16),0(16),4(16),
0(16),4(16),0(32),2(16),0(32),4(48),0(16)
%OWNINTEGERARRAY CHL(0:255)=0(256)
%OWNINTEGERARRAY TAGL(0:255)=0(256)
%OWNINTEGERARRAY TAG(1:1000)=0(1000) ;! TAGS LISTS
%INTEGERARRAY LINK(1:1000)
%INTEGERARRAY A,NP(1:200) ;! ANALYSIS RECORD
%INTEGERARRAY T(1:300) ;! SOURCE TEXT
%INTEGERARRAY BAT(0:1023)
%INTEGERARRAY CH(1:512) ;! NAME CHAR TABLE
%INTEGERARRAY JUMP,STAR,BRT,NAME,RTP,START,RAD(0:15);!LEVEL INFO
%OWNINTEGERARRAY BR(0:6)=0,13,12,11,10,9,8
%OWNINTEGERARRAY TRUE(1:6)=X'433',X'423',X'432',X'421',X'431',X'422'
%OWNINTEGERARRAY FALSE(1:6)=X'423',X'433',X'422',X'431',X'421',X'432'
%OWNINTEGERARRAY PREC(1:12)=3,3,2,1,1,3,2,2,1,1,1,4
%OWNINTEGERARRAY UCN(1:12)=3,3,2,2,2,3,3,2,2,3,1,1,
%OWNINTEGERARRAY OPR(0:12)=X'48',X'CD',X'CC',
X'44',X'47',X'46',0,X'4D',X'4C',X'4A',X'4B',0,0
%INTEGERARRAY PT,PI(1:15) ;! FOR RT SPECS, HEADINGS
%EXTERNALROUTINESPEC DEFINE(%STRING(63) S)
%OWNSTRING(63) S1,S2,S3
%SYSTEMROUTINESPEC OUTFILE(%STRING(15) S,%INTEGER LENGTH,MAX,PROT, %C
%INTEGERNAME CONNAD,FLAG)
%INTEGER CONNAD,FLAG
%BYTEINTEGERARRAYNAME CODE
%BYTEINTEGERARRAYFORMAT CODEF(0:65515)
%IF S->S1.(',').S2 %THEN %START
%IF S2->S2.(',').S3 %THEN %START ; %FINISH
%FINISH %ELSE S1=S
%IF S1='' %THEN S1='.TT'
%IF S2='' %THEN S2='SS#OBJ'
%IF S3='' %THEN S3='SS#LIST'
DEFINE('STREAM01,'.S1)
SELECT INPUT(1)
DEFINE('STREAM02,'.S3)
SELECT OUTPUT(2)
PRINT STRING('
INTERDATA SKIMP COMPILER 12/11/76
SOURCE : '.S1.'
OBJECT : '.S2.'
LISTING: '.S3.'
')
OUTFILE(S2,65536,65536,0,CONNAD,FLAG)
%UNLESS FLAG=0 %THEN %MONITORSTOP
INTEGER(CONNAD+4)=16
INTEGER(CONNAD+8)=65536
INTEGER(CONNAD+12)=0
CODE==ARRAY(CONNAD+20,CODEF)
I=1
11: LINK(I)=I+1 ;! SET UP SPACE LIST
I=I+1
%IF I<1000 %THEN ->11
LINK(1000)=0
ASL=1
BTN=0 ;! BRANCH TABLE POINTER
CHP=1 ;! NAME CHARACTER TABLE POINTER
FAULTS=0 ;! FAULT COUNT
NL='
' ;! VALUE OF NEWLINE CHAR
LEVEL=0 ;! TEXTUAL LEVEL
SCF=0 ;! CONDITION FLAG
JUMP(0)=0 ;! JUMP LIST POINTER
STAR(0)=0 ;! STORAGE ALLOCATION POSITION
NAME(0)=0 ;! NAME LIST POINTER
RTP(0)=-1 ;! ROUTINE TYPE
START(0)=0 ;! START/FINISH LIST
RAD(0)=20 ;! NEXT REL ADDR TO ALLOCATE
PARS=20 ;! NEXT PARAMETER REL ADDR
CA=0 ;! CURRENT CODE DUMPING ADDRESS
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
1: READ LINE
TP=1 ;! TEXT POINTER
2: %IF T(TP)='!' %THEN ->3 ;! COMMENT - SKIP TO END
AP=1 ;! ANALYSIS REC POINTER
%IF COMPARE(-1000)=1 %THEN %START ;! SUCCESSFUL ANALYSIS
AP=1 ;! ANALYSIS REC POINTER
SS ;! PROCESS SOURCE STAT
%IF T(TP-1)=';' %THEN ->2 ;! FURTHER STAT ON LINE
->1 ; %FINISH ;! GO TO READ NEXT LINE
FAULT('SYNTAX') ;! UNSUCCESSFUL ANALYSIS
4: %IF T(TP)=NL %THEN ->1 ;! READ NEXT LINE
%IF T(TP)=';' %THEN %START ;! END OF STATEMENT
TP=TP+1 ;! TP TO START OF NEXT
->2 ; %FINISH ;! GO TO EXAMINE NEXT
3: TP=TP+1 ;! SKIP TO NEXT CHARACTER
->4
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE READ LINE
! LEXICAL PHASE - READ & CLEAN UP NEXT LINE OF TEXT
%ROUTINESPEC STORE(%INTEGER I)
%INTEGER SH,I
SH=0 ;! % & LITERAL SHIFT VALUE TO 0
TP=1 ;! POINTER TO TEXT ARRAY T
PHEX(CA,0)
SPACES(4)
1: READ SYMBOL(I)
%IF I#NL %OR TP>1 %THEN PRINT SYMBOL(I)
%IF I='''' %THEN %START
SH=0 ;! SHIFT VALUE FOR LITERAL
2: STORE(I) ;! STORE CHAR IN TEXT A
READ SYMBOL(I)
PRINT SYMBOL(I)
%IF I=NL %THEN SPACES(8)
%IF I\='''' %THEN ->2 ;! NOT END OF LITERAL YET
READ SYMBOL(I)
PRINT SYMBOL(I)
%IF I='''' %THEN ->2 ;! QUOTE IN LITERAL, IGNORE ONE
STORE(''''+128) ;! STORE SHIFTED VAL
%FINISH
%IF I='%' %THEN %START ;! SHIFT VALUE TO 128 FOR KEYWD
SH=128
->1 ; %FINISH
%IF I<'A' %OR I>'Z' %THEN SH=0 ;! SHIFT VALUE TO 0 FOR END
%IF I=' ' %THEN ->1 ;! IGNORE SPACES
STORE(I)
%IF I\=NL %THEN ->1 ;! NEWLINE CHAR
%IF TP>2 %THEN %START ;! IGNORE BLANK LINES
%IF T(TP-2)='C'+128 %THEN TP=TP-2 %AND SPACES(8) %ELSE %RETURN
;! MOVE POINTER BACK IF % C
%FINISH %ELSE TP=1
->1
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE STORE(%INTEGER I)
! STORE (POSSIBLY) SHIFTED CHAR IN TEXT ARRAY & CHECK LINE NOT TOO LONG
%IF TP>300 %THEN %START
FAULT('STATMNT TOO LONG')
TP=1
%FINISH
T(TP)=I+SH ;! STORE CHAR IN TEXT ARRAY
TP=TP+1 ;! MOVE TO NEXT POSITION
%END
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%INTEGERFN COMPARE(%INTEGER PSP)
! ANALYSE PHRASE
%INTEGERFNSPEC NAME ;! BUILT-IN PHRASE <NAME>
%INTEGERFNSPEC CNST ;! BUILT-IN PHRASE <CNST>
%INTEGERFNSPEC ASSI
%ROUTINESPEC INCAP
%INTEGER APP,TPP,AE,N
%SWITCH BIP(1:9)
TPP=TP ;! PRESERVE INITIAL TEXT POINTER
APP=AP ;! PRESERVE INITIAL ANAL REC PTR
A(AP)=1 ;! ALTERNATIVEE 1 FIRST
11: AE=PS(PSP) ;! POINTER TO END OF ALTERNATIVE
PSP=PSP+1 ;! FIRST ITEM OF ALTERNATIVE DEF
12: %IF PSP=AE %THEN %START ;! END OF ALT REACHED - SUCCESS
NP(APP)=AP+1 ;! POINTER TO NEXT PHRASE
%RESULT=1 ; %FINISH
N=PS(PSP) ;! NEXT ITEM OF ALT DEFN
PSP=PSP+1 ;! FOR FOLLOWING ITEM
%IF N<0 %THEN %START ;! SUB-PHRASEE
INCAP
%IF COMPARE(N)=1 %THEN ->12 ;! SUCCESSFUL COMPARISON
->13 ; %FINISH ;! UNSUCCESSFUL - GO FOR NEXT ALT
%IF N<=9 %THEN ->BIP(N)
%IF N=T(TP) %THEN %START ;! LITERAL - MATCHES SOURCE CHAR
TP=TP+1 ;! MOVE TO NEXT SOURCE CHAR
->12 ; %FINISH ;! GO FOR NEXT ITEM
13: %IF PS(AE)=0 %THEN %RESULT=0 ;! END OF PHRASE
PSP=AE ;! START OF DEFN OF NEXT ALT
TP=TPP ;! BACKTRACK SOURCE TEXT
AP=APP ;! AND ANALYSIS RECORD POINTER
A(AP)=A(AP)+1 ;! COUNT ALTERNATIVE NUMBER ON
->11 ;! GO TO ANALYSE NEW ALTERNATIVE
BIP(1):%IF NAME=1 %THEN ->12 %ELSE ->13
BIP(2):%IF CNST=1 %THEN ->12 %ELSE ->13
BIP(3):%IF ASSI=1 %THEN ->12 %ELSE ->13
BIP(4):%IF ASST(ASSOPP)#2 %THEN ->13
BIP(5):INCAP
A(AP)=ASSOPP
NP(AP)=AP+1
->12
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%INTEGERFN NAME
! RECOGNISE AND INSERT NAME IN HASHING AREA OF TAG/LINK ARRAYS
%INTEGER I,J,K,L,M,N
I=T(TP) ;! FIRST SOURCE CHAR
%IF I<'A' %OR I>'Z' %OR (I='M' %AND T(TP+1)='''') %C
%OR (I='X' %AND T(TP+1)='''') %THEN %RESULT=0
;! FAILURE - NOT A CONSTANT
J=CHP ;! NEXT POSITION IN CHAR ARRAY
K=I<<16 ;! LEAVE HOLE FOR LENGTH & PACK
L=1 ;! NO OF CHARS
M=8 ;! NEXT SHIFT VALUE FOR PACKING
N=I ;! SUM VALUE OF CHARS FOR HASHING
1: TP=TP+1
I=T(TP) ;! NEXT CHAR FROM TEXT ARRAY
%IF ('0'<=I %AND I<='9') %OR ('A'<=I %AND I<='Z') %THEN %START
;! A DIGIT OR A LETTER
K=K!I<<M ;! PACK NEXT LETTER
L=L+1 ;! CHARACTER COUNT
M=M-8 ;! NEXT SHIFT
N=N+I ;! SUM OF LETTERS
%IF M<0 %THEN %START ;! PACKED WORD OF CHARS FULL
CH(CH NEXT)=K ;! STORE WORD IN CHAR ARRAY
K=0 ;! PACKING WORD TO ZERO
M=24 ;! NEW SHIFT VALUE
%FINISH
->1 ; %FINISH ;! GO FOR NEXT CHAR
%IF K\=0 %THEN CH(CH NEXT)=K ;! STORE ANY REMAINING CHARS
CH(J)=CH(J)!L<<24 ;! FILL IN LENGTH IN HOLE LEFT
I=(N<<4!!N>>4)&255 ;! HASH VALUE
K=I ;! SCAN DICTIONARY FOR NAME
2: %IF CHL(K)\=0 %THEN %START ;! A NAME IN THIS POSITION
L=CHL(K) ;! CHAR ARRAY POSITION
M=J ;! CHAR ARRAY POSITION OF NEW NAME
4: %IF CH(L)=CH(M) %THEN %START ;! PACKED WORDS MATCH
M=M+1 ;! NEXT WORD OF NEW NAME
%IF M=CHP %THEN %START ;! NAMES MATCH
CHP=J ;! MOVE CHP BACK SINCE NAME IN
->3 ; %FINISH
L=L+1 ;! NEXT WORD OF OLD NAME
->4 ; %FINISH ;! GO FOR NEXT WORD
K=(K+1)&255 ;! NO MATCH SO TRY NEXT POSITION
%IF K=I %THEN %START ;! STARTING POSITION REACHED AGAIN
FAULT('DICTIONARY FULL')
%STOP ; %FINISH
->2 ; %FINISH
CHL(K)=J ;! STORE CHAR ARRAY POSITION
3: INCAP
A(AP)=K ;! STORE IDENTIFICATION NO OF NAME
NP(AP)=AP+1 ;! NEXT PHRASE
%RESULT=1 ;! SUCCESS
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%INTEGERFN CNST
! RECOGNISE INTEGER AND LITERAL TEXT CONSTANTS
%INTEGER I,J,K
I=T(TP) ;! FIRST CHAR
%IF I='M' %AND T(TP+1)='''' %THEN %START ;! M-TYPE CONSTANT
TP=TP+1 ;! IGNORE THE M
I=''''
%FINISH
%IF I='''' %THEN %START ;! START OF A LITERAL
J=0 ;! TO ACCUMULATE LITERAL VALUE
K=0 ;! CHARACTER COUNT
1: TP=TP+1
I=T(TP) ;! NEXT CHAR
%IF I\=''''+128 %THEN %START ;! NOT END OF LITERAL
J=J<<8!I ;! PACK CHAR
K=K+1 ;! COUNT CHAR
->1 ; %FINISH
TP=TP+1 ;! POINTER AFTER QUOTE
%IF K>2 %THEN FAULT('STRING TOO LONG')
->2 ; %FINISH
%IF I='X' %AND T(TP+1)='''' %THEN %START
TP=TP+1
J=0
K=0
5: TP=TP+1
I=T(TP)
%IF I#''''+128 %THEN %START
%IF '0'<=I<='9' %THEN I=I-'0' %AND ->4
%IF 'A'<=I<='F' %THEN I=I-'A'+10 %AND ->4
FAULT('NOT A HEX CNST')
I=0
4: J=J<<4!I
K=K+1
->5 ; %FINISH
TP=TP+1
%IF K>4 %THEN FAULT('HEX CNST TOO LNG')
->2 ; %FINISH
%IF I<'0' %OR I>'9' %THEN %RESULT=0 ;! NOT A CONSTANT
J=0
K=0
3: %IF J<6553 %OR (J=6553 %AND I<='5') %THEN %C
J=10*J+I-'0' %ELSE K=1 ;! CHECK AND ACCUMULATE VALUE
TP=TP+1
I=T(TP) ;! NEXT CHAR
%IF '0'<=I %AND I<='9' %THEN ->3 ;! A DIGIT - PART OF CONSTANT
%IF K\=0 %THEN FAULT('CONST TOO BIG')
2: INCAP
A(AP)=J ;! FILL IN VALUE OF CONSTANT
NP(AP)=AP+1 ;! NEXT PHRASE
%RESULT=1 ;! SUCCESS
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%INTEGERFN ASSI
%INTEGER I,J
I=T(TP)
%IF I<'A' %OR I>'Z' %OR (I='M' %AND T(TP+1)='''') %C
%OR (I='X' %AND T(TP+1)='''') %THEN %RESULT=0
1: TP=TP+1
J=T(TP)
%IF 'A'<=J<='Z' %THEN I=I<<8!J %AND ->1
%CYCLE ASSOPP=0,1,255
%IF ASSOP(ASSOPP)=I %THEN %RESULT=1
%REPEAT
%RESULT=0
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE INCAP
AP=AP+1
%IF AP>200 %THEN FAULT('ANAL REC FULL') %AND %MONITORSTOP
%END
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE SS
! COMPILE SOURCE STATEMENT
%ROUTINESPEC UI
%ROUTINESPEC SCCOND(%INTEGERNAME LABEL)
%ROUTINESPEC SEXPR
%INTEGERFNSPEC SEXFNS(%INTEGER AP)
%INTEGERFNSPEC FIND LABEL
%ROUTINESPEC CHECK
%ROUTINESPEC UNSET
%ROUTINESPEC PUSH START(%INTEGER FLAG,LABEL)
%INTEGERFNSPEC BT NEXT
%INTEGERFNSPEC WS NEXT
%ROUTINESPEC STORE TAG(%INTEGER NAM,FORM,TYPE,DIM,LEV,AD)
%ROUTINESPEC DUMP(%INTEGER OP,REG,BASE,DISP)
%ROUTINESPEC RT
%ROUTINESPEC ARRAD
%ROUTINESPEC ENTER(%INTEGER TYPE,ALLOC)
%ROUTINESPEC RETURN
%ROUTINESPEC PMN(%INTEGER I)
%INTEGER I,J,K,L,M,N,P,Q,R,WS,LABEL,U
%SWITCH ALT(1:13)
I=A(AP) ;! ANALYSIS RECORD ENTRY
AP=AP+1 ;! FOR FOLLOWING ENTRY
WS=4 ;! SET WORKSPACE POINTER
->ALT(I)
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! UI
ALT(1):UI
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %IF - - - %THEN - - - %ELSE
ALT(2):SCCOND(I) ;! COMPILE CONDITION
%IF A(AP)=2 %THEN %START ;! AP ON <UI> - JUMP INSTR
AP=AP+3 ;! AP ON <ELSE>
%IF A(AP-1)=1 %THEN FAULT('JUMP %AND ?') %AND AP=NP(AP-1)
J=-1 ;! MARKER FOR 'JUMP'
%FINISH %ELSE %START ;! NOT A JUMP
K=0
20: %IF A(AP)=3 %AND K=0 %THEN PUSHSTART(0,I) %AND AP=AP+1 %C
%AND K=1 %ELSE UI
AP=AP+1
%IF A(AP-1)=1 %THEN ->20
%IF K=1 %THEN %START
%IF A(AP)=1 %THEN FAULT('%START...%ELSE')
%RETURN ; %FINISH
J=0 ;! 'NOT JUMP' MARKER
%FINISH
%IF A(AP)=1 %THEN %START ;! <ELSE>-CLAUSE PRESENT
%IF J=0 %THEN %START ;! <UI> WAS NOT A JUMP
J=BT NEXT ;! JUMP ROUND <ELSE>-CLAUSE
DUMP(X'43',0,M'BT',J)
%FINISH
%IF I>=0 %THEN BAT(I)=CA<<16!BAT(I)&X'FFFF'
AP=AP+1 ;! AP ON <UI>
K=0
21: %IF A(AP)=3 %AND K=0 %THEN PUSHSTART(1,J) %AND AP=AP+1 %C
%AND K=1 %ELSE UI
AP=AP+1
%IF A(AP-1)=1 %THEN ->21
%IF K=1 %THEN %RETURN
I=J ;! JUMP AROUND LABEL
%FINISH
%IF I>=0 %THEN BAT(I)=CA<<16!BAT(I)&X'FFFF'
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! CONST: - - -
ALT(3):I=FIND LABEL ;! LOCATE/INSERT LABEL IN JUMP
%IF I>=0 %THEN %START ;! VALID LABEL
%IF BAT(I)>=0 %THEN %START
WRITE(LABEL,1)
SPACES(2)
FAULT('LABEL SET TWICE')
%FINISH
BAT(I)=CA<<16!BAT(I)&X'FFFF'
%FINISH
SS ;! COMPILE STATEMENT AFTER LAB
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %FINISH - - -
ALT(4):I=START(LEVEL) ;! LINK TO FIRST CELL
%IF I=0 %THEN %START ;! NO CELLS IN LIST
FAULT('SPURIOUS %FINISH')
%RETURN ; %FINISH
J=TAG(I)&65535 ;! JUMP AROUND LABEL
K=TAG(I)>>16 ;! BEFORE/AFTER %ELSE MARK
START(LEVEL)=RETURN CELL(I) ;! POP UP CELL
%IF A(AP)=1 %THEN %START ;! %ELSE PRESENT
%IF K=1 %THEN FAULT('TWO %ELSES !')
K=BT NEXT ;! JUMP AROUND <UI>
DUMP(X'43',0,M'BT',K)
%IF J\=65535 %THEN BAT(J)=CA<<16!BAT(J)&X'FFFF'
AP=AP+1 ;! AP ON <UI>
L=0
41: %IF A(AP)=3 %AND L=0 %THEN PUSHSTART(1,K) %AND AP=AP+1 %C
%AND L=1 %ELSE UI
AP=AP+1
%IF A(AP-1)=1 %THEN ->41
%IF L=1 %THEN %RETURN
J=K ;! JUMP AROUND LABEL
%FINISH
%IF J\=65535 %THEN BAT(J)=CA<<16!BAT(J)&X'FFFF'
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! DECLARATIONS
ALT(5):50:%IF A(AP)=1 %THEN %START ;! <ARR> = %ARRAY
APP=AP ;! SAVE AP
AP=NP(AP+2) ;! AP ON <+-\>
%IF A(AP+1)=2 %AND A(AP+3)=2 %THEN %START
L=A(AP+2)
%IF A(AP)=2 %THEN L=-L
%IF A(AP)=3 %THEN L=\L
L=2*L
AP=AP+4
WS=WS+2
%FINISH %ELSE %START
L=999999
SEXPR ;! COMPILE EXPR
DUMP(X'91',3,1,-1)
DUMP(X'40',3,BR(LEVEL),WS NEXT) ;! STORE VALUE IN WRK
%FINISH
%IF A(AP+1)=2 %AND A(AP+3)=2 %THEN %START
U=A(AP+2)
%IF A(AP)=2 %THEN U=-U
%IF A(AP)=3 %THEN U=\U
U=2*(U+1)
AP=AP+4
WS=WS+2
%FINISH %ELSE %START
U=999999
SEXPR ;! COMPILE EXPR
DUMP(X'26',3,1,-1) ;! INCREMENT VALUE
DUMP(X'91',3,1,-1)
DUMP(X'40',3,BR(LEVEL),WS NEXT)
%FINISH
WS=WS-4 ;! RESTORE WORKSPACE
I=1 ;! NO OF DIMS
J=2 ;! TAG FOR 'ARRAY'
K=AP
AP=APP ;! RESTORE AP
%FINISH %ELSE %START ;! SCALAR DECLARATIIONS
I=0 ;! DIMS=0 FOR SCALARS
J=0 ;! TAG FOR SCALAR
%FINISH
52: STORE TAG(A(AP+1),J,1,0,LEVEL,RAD(LEVEL)) ;! PUSHDOWN TAG
%IF I=1 %THEN %START ;! 1-DIM ARRAYS
%IF L<999999 %THEN %START
%IF -15<=L<=15 %THEN %START
%IF L>0 %THEN DUMP(X'27',15,L,-1)
%IF L<0 %THEN DUMP(X'26',15,-L,-1)
%FINISH %ELSE DUMP(X'CB',15,0,L&X'FFFF')
%FINISH %ELSE DUMP(X'4B',15,BR(LEVEL),WS)
%IF L\=0 %OR U\=0 %THEN DUMP(X'40',15,BR(LEVEL),RAD(LEVEL))
%IF U<999999 %THEN %START
%IF -15<=U<=15 %THEN %START
%IF U>0 %THEN DUMP(X'26',15,U,-1)
%IF U<0 %THEN DUMP(X'27',15,-U,-1)
%FINISH %ELSE DUMP(X'CA',15,0,U&X'FFFF')
%FINISH %ELSE DUMP(X'4A',15,BR(LEVEL),WS+2)
%FINISH
RAD(LEVEL)=RAD(LEVEL)+2
AP=AP+2 ;! AP ON <NAMS>
%IF A(AP)=1 %THEN ->52 ;! MORE NAMES
%IF J=2 %AND A(K)=1 %THEN AP=K %AND ->50
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! RT SPEC - - -
ALT(6):I=A(AP)-1 ;! ROUTINE/FN
J=A(AP+1) ;! SPEC
K=A(AP+2) ;! NAME OF ROUTINE
AP=AP+3 ;! AP ON <FPP>
L=0 ;! PARAMETER COUNT
M=20 ;! FIRST REL ADDR
63: %IF A(AP)=1 %THEN %START ;! PARAMETERS
AP=AP+1 ;! AP ON <ARRN>
%IF A(AP)=1 %THEN N=3 %ELSE N=3-A(AP) ;! SET TAG FOR PARAM
P=N<<28!1<<24!(LEVEL+1)<<16 ;! SET UP PATTERN
62: L=L+1 ;! PARAMETER COUNT
%IF L>15 %THEN %START
FAULT('TOO MANY PARAMS')
->61 ; %FINISH ;! IGNORE PARAMS
PT(L)=P!M ;! STORE TAG
PI(L)=A(AP+1) ;! STORE IDENT
M=M+2 ;! NEXT REL ADDR
AP=AP+2 ;! AP ON <NAMS>
%IF A(AP)=1 %THEN ->62 ;! MORE NAMES
AP=AP+1 ;! AP ON <FPS>
->63 ; %FINISH
61: N=TAGL(K) ;! LINK TO TAG
%IF N=0 %OR TAG(N)>>16&15<LEVEL %THEN %START ;! NAME NOT SET
STORE TAG(K,4,I,L,LEVEL,BT NEXT) ;! PUSHDOWN TAG
%IF L>0 %THEN %START ;! PARAMETERS
P=1 ;! PARAMETER COUNT
Q=TAGL(K) ;! 'INSERT AFTER' PTR
64: R=NEWCELL ;! PUSHDOWN TAG
TAG(R)=PT(P)
LINK(R)=LINK(Q)
LINK(Q)=R
Q=R ;! NEW VALUE FOR PTR
P=P+1 ;! PARAMETER COUNT
%IF P<=L %THEN ->64 ;! MORE PARAMETERS
%FINISH
%FINISH %ELSE %START ;! NAME ALREADY SET
%IF J=2 %AND TAG(N)>>28=4 %THEN %START ;! STATEMENT NOT SPEC
%IF TAG(N)>>24&15\=I %THEN %START
PRINT NAME(K)
FAULT('RT NOT AS SPEC')
%FINISH
%IF BAT(TAG(N)&65535)>=0 %THEN %START
PRINT NAME(K)
FAULT('RT APPEARS TWICE')
%FINISH
P=TAG(N)>>20&15 ;! NO OF PARAMS
%IF L\=P %THEN %START
FAULT('PARS NOT AS SPEC')
%IF L>P %THEN L=P ;! IGNORE PARAMS
%FINISH
%IF L>0 %THEN %START ;! PARAMS PRESENT
P=1 ;! PARAM COUNT
Q=LINK(N) ;! LINK TO TAG
67: %IF PT(P)\=TAG(Q) %THEN %START
PRINT NAME(PI(P))
FAULT('PAR NOT AS SPEC')
%FINISH
P=P+1 ;! PARAM COUNT
Q=LINK(Q) ;! NEXT TAG CELL
%IF P<=L %THEN ->67 ;! MORE PARAMS
%FINISH
%FINISH %ELSE %START
PRINT NAME(K)
FAULT('NAME SET TWICE')
%FINISH
%FINISH
%IF J=2 %THEN %START ;! STATEMENT NOT SPEC
BRT(LEVEL)=BT NEXT ;! BRANCH ROUND RT
DUMP(X'43',0,M'BT',BRT(LEVEL))
P=TAG(TAGL(K))&65535
BAT(P)=CA<<16!BAT(P)&X'FFFF'
%IF LEVEL=5 %THEN FAULT('TOO MANY LEVELS') %C
%ELSE LEVEL=LEVEL+1
ENTER(I,M)
%IF L>0 %THEN %START ;! PARAMS PRESENT
P=1 ;! PARAM COUNT
69: I=PT(P) ;! PUSHDOWN TAGS
STORE TAG(PI(P),I>>28,1,0,LEVEL,I&65535)
P=P+1
%IF P<=L %THEN ->69 ;! MORE PARAMS
%FINISH
%FINISH %ELSE %START ;! STATEMENT A SPEC
%IF L>0 %THEN %START ;! PARAMS PRESENT
P=1
68: I=PI(P) ;! PARAM IDENT
%IF TAGL(I)=0 %THEN %START ;! NO TAG SET UP
%IF CHP>CHL(I) %THEN CHP=CHL(I) ;! MOVE CHP BACK
CHL(I)=0 ;! CLEAR NAME LINK
%FINISH
P=P+1
%IF P<=L %THEN ->68 ;! MORE PARAMS
%FINISH
%FINISH
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %END
ALT(7):CHECK
UNSET ;! UNSET NAMES DECLARED
%IF RTP(LEVEL)\=0 %THEN DUMP(X'C8',3,0,X'8000') %C
%AND DUMP(X'95',2,3,-1) %ELSE RETURN ;!&&&&
;! DUMP %RETURN CODE
LEVEL=LEVEL-1 ;! DECREMENT TEXT LEV
%IF LEVEL<1 %THEN %START ;! NOT OUTER LEV
FAULT('EXCESS %END')
->71 ; %FINISH ;! TREAT AS %ENDOFPROG
I=BRT(LEVEL)
BAT(I)=CA<<16!BAT(I)&X'FFFF'
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %BEGIN
ALT(8):%IF LEVEL\=0 %THEN %START
FAULT('%BEGIN EXTRA') ;! NO INTERNAL BLOCKS
%RETURN ; %FINISH
%IF RAD(0)\=20 %THEN FAULT('%BEGIN NOT FIRST')
LEVEL=1 ;! TEXTUAL LEVEL COUNT TO 1
ENTER(-1,20)
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %ENDOFPROGRAM
ALT(9):CHECK
UNSET ;! UNSET NAMES DECLARED
%IF LEVEL\=1 %THEN FAULT('TOO FEW %ENDS')
71: DUMP(X'C8',3,0,X'8000')
DUMP(X'95',2,3,-1)
CODE(LSTPP)=CA>>8&255
CODE(LSTPP+1)=CA&255
%IF BTN=0 %THEN ->91
%CYCLE I=0,1,BTN-1
J=BAT(I)>>16
K=BAT(I)&X'FFFF'
%WHILE K#X'FFFF' %CYCLE
L=CODE(K)<<8!CODE(K+1)
CODE(K)=J>>8
CODE(K+1)=J&255
K=L
%REPEAT
%REPEAT
91: NEWLINES(2)
I=0
92: PHEX(I,0)
SPACES(8)
J=CODE(I)
K=CODE(I+1)
%IF ASST(J)=2 %THEN %START
PHEX(J<<8!K,12)
SPACES(12)
PMN(J)
WRITE(K>>4,1)
PRINT SYMBOL(',')
WRITE(K&15,1)
I=I+2
%FINISH %ELSE %START
L=CODE(I+2)<<8!CODE(I+3)
PHEX(J<<24!K<<16!L,28)
SPACES(8)
PMN(J)
WRITE(K>>4,1)
PRINT SYMBOL(',')
WRITE(L,1)
%IF K&15#0 %THEN PRINT SYMBOL('(') %AND WRITE(K&15,1) %C
%AND PRINT SYMBOL(')')
I=I+4
%FINISH
NEWLINE
%IF I<CA %THEN ->92
I=0
J=0
93: J=J+CODE(I)
I=I+1
%IF I<CA %THEN ->93
CODE(CA)=J>>24
CODE(CA+1)=J>>16&255
CODE(CA+2)=J>>8&255
CODE(CA+3)=J&255
SELECT OUTPUT(0)
WRITE(FAULTS,1) ;! NUMBER OF PROGRAM FAULTS
PRINT STRING(' FAULTS IN PROGRAM
')
INTEGER(CONNAD)=CA+24
SHORT INTEGER(CONNAD+16)=-1
SHORT INTEGER(CONNAD+18)=CA
%STOP
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! * <ASSI>
ALT(10):M=A(AP+1)
N=A(AP+2)
%IF A(AP)=1 %THEN DUMP(M,N,A(AP+3),-1) %AND AP=AP+4 %AND %RETURN
%IF A(AP+3)=1 %THEN %START
I=A(AP+4)
AP=AP+5
%IF TAGL(I)=0 %THEN PRINT NAME(I) %AND FAULT('NAME NOT SET') %C
%AND I=0 %ELSE I=TAG(TAGL(I))
J=I&X'FFFF'
I=BR(I>>16&15)
%FINISH %ELSE %START
%IF A(AP+3)=2 %THEN %START
AP=AP+4
I=M'BT'
J=FIND LABEL
AP=AP+1
%FINISH %ELSE %START
J=A(AP+4)
%IF A(AP+5)=1 %THEN I=A(AP+6) %AND AP=AP+7 %ELSE %C
I=0 %AND AP=AP+6
%FINISH
%FINISH
DUMP(M,N,I,J)
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! * <+-\> <CNST>
ALT(11):I=A(AP+1)
J=A(AP)
%IF J=2 %THEN I=-I
%IF J=3 %THEN I=\I
%IF A(AP+2)=1 %THEN %START
J=A(AP+3)
%IF J=0 %THEN J=1
%FINISH %ELSE J=1
%CYCLE K=1,1,J
DUMP(I>>8&255,I>>4&15,I&15,-1)
%REPEAT
%RETURN
ALT(12):! **<CNST>
I=A(AP)
%IF I&1#0 %THEN FAULT('INVALID ** ADDRESS') %AND %RETURN
%IF I<CA %THEN FAULT('** ADDRESS TOO LOW') %AND %RETURN
%WHILE CA<I %THEN CODE(CA)=0 %AND CA=CA+1
ALT(13):%RETURN
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE UI
! COMPILE UNCONDITIONAL INSTRUCTION
%INTEGER I,J,K,L,APP,APPP,LFN
%SWITCH ALT(1:6)
I=A(AP) ;! NEXT ANALYSIS RECORD ENTRY
AP=AP+1
->ALT(I)
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! NAME APP ASS
ALT(1):I=TAGL(A(AP))
%IF I=0 %THEN %START
PRINT NAME(A(AP))
FAULT('NAME NOT SET')
%RETURN
%FINISH %ELSE I=TAG(I) ;! NAME TAGS OR ZERO
APP=AP ;! PRESERVE ANAL REC PTR
AP=NP(AP+1) ;! AP ON <ASS>
%IF A(AP)=2 %THEN %START ;! ROUTINE CALL
%IF I>>24=64 %THEN %START ;! 'FORM/TYPE' IS ROUTINE
AP=APP ;! RESTORE AP TO <NAME>
RT ;! CALL ROUTINE
%FINISH %ELSE %START
%IF I\=0 %THEN %START
PRINT NAME(A(APP))
FAULT('NOT ROUTINE NAME')
%FINISH
%FINISH
AP=AP+1 ;! AP AFTER <UI>
%RETURN ; %FINISH
K=I>>28 ;! 'FORM' OF NAME
%IF K=4 %THEN %START
PRINT NAME(A(J))
FAULT('NAME NOT A DESTN') ;! ROUTINE/FN FORM
I=0 ;! CLEAR TAGS TO AVOID
%RETURN ; %FINISH
AP=AP+1 ;! AP ON <+-\>
%IF K>=2 %THEN %START
%IF A(AP+1)=2 %AND A(AP+3)=2 %THEN %START ;! CNST
L=A(AP+2)
%IF A(AP)=2 %THEN L=-L
%IF A(AP)=3 %THEN L=\L
APPP=AP+4
AP=APP
ARRAD
%IF -15<=L<=15 %THEN %START
%IF L>=0 %THEN DUMP(X'24',7,L,-1)%ELSE DUMP(X'25',7,-L,-1)
%FINISH %ELSE DUMP(X'C8',7,0,L&X'FFFF')
DUMP(X'40',7,3,0)
AP=APPP
%RETURN ; %FINISH
%IF A(APP+1)=1 %THEN LFN=SEXFNS(APP+2) %ELSE LFN=0
%IF LFN=0 %THEN %START ;! NO FNS ON LHS
%IF A(AP)=4 %AND A(AP+1)=1 %AND A(AP+3)=2 %AND A(AP+4)=2 %C
%THEN %START
L=TAGL(A(AP+2))
%IF L\=0 %AND TAG(L)>>28<2 %THEN %START
I=TAG(L)
APPP=AP+5
AP=APP
ARRAD
%IF I>>28=1 %THEN %START
DUMP(X'48',7,BR(I>>16&15),I&X'FFFF')
DUMP(X'48',4,7,0)
%FINISH %ELSE DUMP(X'48',4,BR(I>>16&15),I&X'FFFF')
DUMP(X'40',4,3,0)
AP=APPP
%RETURN ; %FINISH
%FINISH
SEXPR
APPP=AP
DUMP(X'08',8,3,-1)
AP=APP
ARRAD
DUMP(X'40',8,3,0)
AP=APPP
%RETURN ; %FINISH
SEXPR
APPP=AP
DUMP(X'40',3,BR(LEVEL),WSNEXT)
AP=APP
ARRAD
WS=WS-2
DUMP(X'48',7,BR(LEVEL),WS)
DUMP(X'40',7,3,0)
AP=APPP
%RETURN ; %FINISH
SEXPR
%IF K=1 %THEN %START
DUMP(X'48',7,BR(I>>16&15),I&65535);! INDIRECT ASSIGMENT
DUMP(X'40',3,7,0)
%FINISH %ELSE DUMP(X'40',3,BR(I>>16&15),I&65535)
%IF A(APP+1)=1 %THEN %START
PRINT NAME(A(APP))
FAULT('SCALAR HAS PARAM')
%FINISH
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! -> CONST
ALT(2):DUMP(X'43',0,M'BT',FIND LABEL)
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %START
ALT(3):FAULT('%START INVALID')
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %RETURN
ALT(4):%IF RTP(LEVEL)\=0 %THEN FAULT('%RETURN CONTEXT')
RETURN ;! DUMP %RETURN CODE
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %RESULT=
ALT(5):I=RTP(LEVEL) ;! ROUTINE/FN TYPE
%IF I<=0 %THEN FAULT('%RESULT CONTEXT') ;! %BEGIN/%RT
SEXPR ;! COMPILE RESULT EXPR
RETURN ;! LEAVE RESULT IN ACC
%RETURN ;!&&&&
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %STOP
ALT(6):DUMP(X'C8',3,0,X'8000')
DUMP(X'95',2,3,-1)
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE SEXPR
! COMPILE ARITHMETIC EXPRESSION
%ROUTINESPEC TORP
%ROUTINESPEC STORE(%INTEGER I,J)
%ROUTINESPEC EVAL(%INTEGER P)
%ROUTINESPEC OPN(%INTEGER OP,L)
%ROUTINESPEC DUMPOPR(%INTEGER OP,R,B,D)
%INTEGER RPP,APP,PSTP
%INTEGERARRAY RP,PT,PST(1:32) ;! REV POL, TYPES, PS-EVAL
RPP=1 ;! RP POINTER
PSTP=0 ;! PSEUDO-EVAL STACK PTR
TORP ;! EXPR TO REV POLISH
%IF SCF=1 %THEN %START ;! PART OF A SIMPLE COND
SCF=0 ;! RESET FLAG
COMP=A(AP) ;! COMPARATOR NUMBER
%IF A(AP+3)=0 %AND A(AP+4)=2 %THEN AP=AP+5 %ELSE %START
AP=AP+1 ;! 2ND EXPR NON-ZERO
TORP ;! 2ND EXPRESSION TO REV POL
STORE(10,1) ;! STORE 1ST-2ND
%FINISH
%FINISH
APP=AP ;! SAVE FINAL ANAL REC PTR
EVAL(RPP-1) ;! DUMP CODE FOR EXPR EVAL
AP=APP ;! RESTORE ANAL REC PTR
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE TORP
! TRANSFORM EXPRESSION TO REVERSE POLISH
%INTEGERARRAY OP(1:4)
%INTEGER OPP,I,J,K
%IF A(AP)=2 %OR A(AP)=3 %THEN %START ;! UNARY - OR \
OP(1)=A(AP)+9 ;! STACK UNARY OPERATOR
OPP=1
%FINISH %ELSE OPP=0
AP=AP+1 ;! AP ON <OPD>
3: %IF A(AP)=3 %THEN %START ;! SUB-EXPRESSION
AP=AP+1 ;! AP ON <+-\>
TORP ;! CONVERT SUB-EXPR TO RP
->1 ; %FINISH
%IF A(AP)=2 %THEN %START ;! CONSTANT
STORE(A(AP+1),-4) ;! STORE VALUE OF CONST
AP=AP+2 ;! AP ON <EXPR>
->1 ; %FINISH
I=A(AP+1) ;! NAME IDENT NUMBER
J=TAGL(I) ;! LINK TO TAG OF NAME
%IF J=0 %THEN %START ;! NAME NOT SET
PRINT NAME(I)
FAULT('NAME NOT SET')
STORE(0,-3) ;! STORE DUMMY TAG
->2 ; %FINISH
K=TAG(J) ;! TAG OF NAME
%IF K>>28<=1 %THEN %START ;! SCALAR VARIABLE
%IF A(AP+2)=1 %THEN %START ;! PARAMETERS PRESENT
PRINT NAME(I)
FAULT('SCALAR HAS PARAM')
%FINISH
STORE(K,-3) ;! STORE TAG & TYPE -3
->2 ; %FINISH
%IF K>>28<=3 %THEN %START ;! ARRAY VARIABLE
STORE(AP+1,-2) ;! STORE ANAL REC POSITION
->2 ; %FINISH
%IF K>>24&15=0 %THEN %START ;! %ROUTINE TYPE
PRINT NAME(I)
FAULT('ROUTINE IN EXPR')
STORE(0,-3) ;! STORE DUMMY TAG
->2 ; %FINISH
STORE(AP+1,-1) ;! STORE ANAL REC POSITION
2: AP=NP(AP+2) ;! AP TO AFTER <APP>
1: %IF A(AP)=1 %THEN %START ;! ANOTHER OPERAND YET
I=A(AP+1) ;! NEXT OPERATOR
AP=AP+2 ;! AP TO <OPD>
4: %IF OPP=0 %OR PREC(I)>PREC(OP(OPP)) %THEN %START ;! HIGHER PREC
OPP=OPP+1 ;! SO STACK NEW OPERATOR
OP(OPP)=I
->3 ; %FINISH ;! GO FOR NEXT OPERAND
STORE(OP(OPP),1) ;! UNSTACK TOP OPERATOR
OPP=OPP-1
->4 ; %FINISH ;! COMPARE WITH PREVIOUS OP
5: %IF OPP>0 %THEN %START ;! OPERATORS LEFT IN STACK
STORE(OP(OPP),1) ;! SO UNSTACK THEM
OPP=OPP-1
->5 ; %FINISH ;! ANY MORE OPERATORS LEFT ?
AP=AP+1 ;! AP AFTER <EXPR>
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE STORE(%INTEGER I,J)
! STORE IN RP & PT ARRAYS & PSEUDO-EVALUATE
%IF RPP>32 %THEN %START ;! REV POL ARRAY FULL
FAULT('EXPR TOO LONG')
RPP=1 ;! IN ORDER TO CONTINUE
%FINISH
%IF J>0 %THEN %START ;! OPERATOR
%IF I<=10 %THEN %START ;! BINARY OP
PSTP=PSTP-1 ;! UNSTACK TOP ITEM
J=PST(PSTP) ;! POINTER TO 1ST OPERAND
%FINISH
%FINISH %ELSE PSTP=PSTP+1 ;! OPERAND
RP(RPP)=I ;! STORE OP/OPD
PT(RPP)=J ;! STORE POINTER OR TYPE
PST(PSTP)=RPP ;! STACK NEXT POINTER
RPP=RPP+1 ;! NEXT POSITION
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE EVAL(%INTEGER P)
! DUMP CODE FOR EVALUATION OF EXPRESSION
%INTEGER I,J,K
I=PT(P) ;! PTR/TYPE OF LAST
%IF I<0 %THEN %START ;! OPERAND
OPN(0,P) ;! LOAD OPERAND
%RETURN ; %FINISH
J=RP(P) ;! OPERATOR
K=P-1 ;! START OF 2ND OPD
%IF UCN(J)=1 %THEN %START ;! UNARY OPERATOR
%IF PT(K)>=-2 %THEN EVAL(K) %ELSE OPN(0,K) ;! EVAL IF NODE
DUMPOPR(J,3,0,0) ;! DUMP UNARY OPN
%RETURN ; %FINISH
%IF PT(I)>=-2 %THEN %START ;! FIRST OPD A NODE
%IF PT(K)>=-2 %THEN %START ;! SECOND OPD A NODE
EVAL(K) ;! EVALUATE 2ND OPD
DUMP(X'40',3,BR(LEVEL),WS NEXT) ;! & STORE IT
EVAL(I) ;! EVALUATE 1ST OPD
WS=WS-2 ;! RESTORE WORKSPACE
DUMPOPR(J,3,BR(LEVEL),WS) ;! DUMP OPERATION
%FINISH %ELSE %START ;! 2ND OPD NOT NODE
EVAL(I) ;! EVALUATE 1ST OPD
OPN(J,K) ;! OPERATION WITH 2ND
%FINISH
%FINISH %ELSE %START ;! 1ST OPD NOT NODE
%IF PT(K)>=-2 %THEN %START ;! 2ND OPERAND A NODE
EVAL(K) ;! EVALUATE 2ND OPD
%IF UCN(J)=2 %THEN %START ;! OPERATOR IS COMM
OPN(J,I) ;! OPERATION WITH 1ST
%RETURN ; %FINISH
DUMP(X'40',3,BR(LEVEL),WS NEXT) ;! STORE VALUE OF 2ND
OPN(0,I) ;! LOAD 1ST OPERAND
WS=WS-2 ;! RESTORE WORKSPACE
DUMPOPR(J,3,BR(LEVEL),WS) ;! DUMP OPN WITH 2ND
%FINISH %ELSE %START ;! 2ND OPD NOT NODE
OPN(0,I) ;! LOAD 1ST OPERAND
OPN(J,K) ;! OPERATION WITH 2ND
%FINISH
%FINISH
%RETURN
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE OPN(%INTEGER OP,L)
! DUMP SIMPLE OPERATION, OP=OPERATOR, L=RP POSITION OF OPERAND
%INTEGER I,J,LAST
%SWITCH COP(0:10)
I=PT(L) ;! KIND OF OPERAND
AP=RP(L) ;! ANAL REC POINTER
%IF I=-1 %THEN %START ;! ROUTINE/FN TYPE
RT ;! DUMP CALL ON FN
%RETURN ; %FINISH
%IF I=-2 %THEN %START ;! ARRAY ACCESS
ARRAD ;! CALC ARRAY ADDR
DUMP(X'48',3,3,0) ;! LOAD VALUE
%RETURN ; %FINISH
%IF I=-3 %THEN %START ;! SCALAR TYPE
%IF AP>>28=1 %THEN %START ;! %NAME TYPE
DUMP(X'48',7,BR(AP>>16&15),AP&65535) ;! LOAD INDIRECT
DUMPOPR(OP,3,7,0)
%FINISH %ELSE DUMPOPR(OP,3,BR(AP>>16&15),AP&65535)
%RETURN ; %FINISH
->COP(OP)
COP(1):DUMP(X'91',3,AP&15,-1)
%RETURN
COP(2):DUMP(X'90',3,AP&15,-1)
%RETURN
COP(0):%IF AP<=15 %THEN I=X'24' %AND ->1 %ELSE ->2
COP(9):%IF AP<=15 %THEN I=X'26' %AND ->1 %ELSE ->2
COP(10):%IF AP<=15 %THEN I=X'27' %ELSE ->2
1: DUMP(I,3,AP,-1)
%RETURN
2:COP(3):COP(4):COP(5):DUMP(OPR(OP)!X'80',3,0,AP)
%RETURN
COP(6):DUMPOPR(OP,3,M'CNST',AP)
%RETURN
COP(7):COP(8):LAST=LOPR
%IF AP<=15 %THEN DUMP(X'24',4,AP,-1) %ELSE DUMP(X'C8',4,0,AP)
%IF OP=7 %AND LAST\=X'4C' %AND LAST\=X'0C' %THEN %C
DUMP(X'08',2,3,-1) %AND DUMP(X'EE',2,0,16)
DUMP(OPR(OP)&15,2,4,-1)
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE DUMPOPR(%INTEGER OP,R,B,D)
%SWITCH TYPE(0:12)
->TYPE(OP)
TYPE(1):TYPE(2):! << >>
DUMP(X'48',4,B,D)
B=4
D=0
1:TYPE(0):TYPE(3):TYPE(4):TYPE(5):TYPE(9):TYPE(10):DUMP(OPR(OP),R,B,D)
%RETURN
TYPE(6):! **
DUMP(X'08',4,R,-1)
DUMP(X'24',R,1,-1)
DUMP(X'40',7,BR(LEVEL),WS NEXT)
%IF B=M'CNST' %THEN DUMP(X'C8',7,0,D) %ELSE DUMP(X'48',7,B,D)
DUMP(X'23',2,8,-1)
DUMP(X'24',5,0,-1)
DUMP(X'24',6,1,-1)
DUMP(X'0C',R-1,4,-1)
DUMP(X'C0',5,14,CA-2)
WS=WS-2
DUMP(X'48',7,BR(LEVEL),WS)
%RETURN
TYPE(7):! /
%IF LOPR\=X'4C' %AND LOPR\=X'0C' %THEN %C
DUMP(X'08',R-1,R,-1) %AND DUMP(X'EE',R-1,0,16)
TYPE(8):! *
R=R-1
->1
TYPE(11):! -
TYPE(12):! \
DUMP(X'C7',R,0,X'FFFF')
%IF OP=11 %THEN DUMP(X'26',R,1,-1)
%END
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE SCCOND(%INTEGERNAME LABEL)
! COMPILE CONDITION <SC><COND>, LABEL SET FOR POSITION AFTER UI
%ROUTINESPEC SC
%ROUTINESPEC COND
%ROUTINESPEC STORE(%INTEGER FT)
%INTEGER I,J,K,L,APP
%INTEGERARRAY CAP,LVL,TF,JMP,LBL(1:16) ;! ANAL REC PTRS,
;! NESTING LEVEL, TRUE/FALSE, JUMP ARRAYS
I=1 ;! INDEX TO ARRAYS
L=0 ;! NESTING LEVEL
SC ;! PROCESS <SC>
COND ;! PROCESS <COND>
APP=AP ;! PRESERVE ANAL PTR
L=-1
STORE(1) ;! PSEUDO-FALSE
L=-2
STORE(2) ;! PSEUDO-TRUE
K=I-1 ;! LAST POS FILLED IN
I=1
2: J=I ;! FIND JUMPS
L=LVL(I)
1: J=J+1
%IF LVL(J)>=L %THEN ->1 ;! SKIP HIGHER LEVELS
L=LVL(J)
%IF TF(J)=TF(I) %THEN ->1
JMP(I)=J ;! JUMP TO COMPARISON
I=I+1
%IF I<K %THEN ->2 ;! MORE JUMPS TO FILL
%IF A(AP)=2 %THEN %START ;! UI A JUMP INST
AP=AP+1 ;! TO <CONST>
J=K-1 ;! LAST POS FILLED
TF(J)=2 ;! SET AS 'TRUE'
JMP(J)=J ;! SET JUMP AS UI JMP
LBL(J)=FIND LABEL ;! FILL IN BRANCH
%FINISH
I=1 ;! FILL IN PSEUDO-LAB
3: %IF LBL(JMP(I))<0 %THEN LBL(JMP(I))=BT NEXT ;! NEXT BAT POSITION
I=I+1
%IF I<K %THEN ->3 ;! MORE TO FILL IN
I=1
4: AP=CAP(I) ;! ANAL REC PTR 1ST
SCF=1 ;! SET FLAG FOR SEXPR
SEXPR ;! TO EVAL 1ST-2ND
%IF LOPR=X'4C' %OR LOPR=X'4D' %OR LOPR=X'C0' %OR %C
LOPR=X'44' %OR LOPR=X'46' %OR LOPR=X'47' %OR LOPR=X'41' %C
%OR LOPR=X'C7' %THEN DUMP(X'08',3,3,-1)
%IF TF(I)=1 %THEN L=FALSE(COMP) %ELSE L=TRUE(COMP)
DUMP(L>>4,L&15,M'BT',LBL(JMP(I)))
%IF I<K-1 %THEN %START
L=LBL(I)
%IF L>=0 %THEN BAT(L)=CA<<16!BAT(L)&X'FFFF'
I=I+1 ;! FILL IN LABEL ADDR
->4 ; %FINISH ;! MORE COMPARISONS
L=LBL(I)
%IF L>=0 %AND TF(I)=1 %THEN BAT(L)=CA<<16!BAT(L)&X'FFFF'
LABEL=LBL(K) ;! FINAL LABEL
AP=APP ;! FINAL ANAL REC PTR
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE STORE(%INTEGER FT)
! STORE LEVEL & TRUE/FALSE FLAG
%IF I>16 %THEN %START ;! ARRAYS FULL
FAULT('CONDN TOO LONG')
I=1 ;! TO CONTINUE
%FINISH
LVL(I)=L ;! SAVE NESTING LEVEL
TF(I)=FT ;! SAVE TRUE/FALSE FLAG
LBL(I)=-1 ;! SET 'LAB NOT FILLED'
I=I+1 ;! NEXT ARRAY POSITION
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE SC
AP=AP+1
%IF A(AP-1)=2 %THEN %START
L=L+1 ;! NESTING LEVEL UP 1
SC ;! PROCESS SUB-<SC>
COND ;! PROCESS SUB-<COND>
L=L-1 ;! NESTING LEVEL DOWN
%FINISH %ELSE %START
CAP(I)=AP ;! ANAL REC POINTERP
AP=NP(NP(AP+1)) ;! SKIP 1ST EXPR
AP=NP(NP(AP+2)) ;! SKIP COMP & 2ND EXPR
%FINISH
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE COND
! PROCESS <COND> FOR SIMPLE COMPARISONS
%INTEGER I
I=A(AP) ;! <COND>
AP=AP+1 ;! AP ON <SC>
%IF I\=3 %THEN %START ;! NOT NULL ALT OF <COND>
1: STORE(I) ;! SAVE %AND OR %OR TYPE
SC ;! PROCESS <SC>
AP=AP+1
%IF A(AP-1)=1 %THEN ->1 ;! MORE %ANDS OR %ORS
%FINISH
%END
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE CHECK
! CHECK LABELS ALL SET & STARTS MATCH FINISHES
%INTEGER I,J
I=JUMP(LEVEL) ;! POINTER TO JUMP LIST
1: %IF I\=0 %THEN %START ;! NO LABELS OR JUMPS
%IF BAT(TAG(I)&65535)<0 %THEN %START ;! LABEL SET INCORRECTLY
WRITE(TAG(I)>>16,1) ;! PRINT OUT LABEL NO
FAULT(' LABEL NOT SET')
%FINISH
I=RETURN CELL(I) ;! RETURN JUMP LIST CELL
->1 ; %FINISH
I=START(LEVEL) ;! LINK TO START LIST
2: %IF I\=0 %THEN %START ;! A CELL STILL IN LIST
FAULT('%FINISH MISSING')
I=RETURN CELL(I) ;! POP UP CELL
->2 ; %FINISH
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE UNSET
! UNSET NAMES AND CHECK FOR MISSING ROUTINES
%INTEGER I,J,K
CODE(STAR(LEVEL))=RAD(LEVEL)>>8&255
CODE(STAR(LEVEL)+1)=RAD(LEVEL)&255
I=NAME(LEVEL) ;! NAME LIST POINTER
1: %IF I\=0 %THEN %START ;! UNSET NAMES DECLARED
J=TAG(I) ;! NAME IDENT NO
K=TAG(TAGL(J)) ;! TAG WORD AT TOP
TAGL(J)=RETURN CELL(TAGL(J)) ;! POP UP CELL
%IF K>>28=4 %THEN %START ;! ROUTINE/FN TYPE
%IF BAT(K&65535)<0 %THEN %START
PRINT NAME(J)
FAULT('ROUTINE MISSING')
%FINISH
K=K>>20&15 ;! NO OF PARAMS
2: %IF K\=0 %THEN %START ;! PARAMS PRESENT
TAGL(J)=RETURN CELL(TAGL(J)) ;! POP UP CELLS
K=K-1 ;! PARAM COUNT
->2 ; %FINISH
%FINISH
%IF TAGL(J)=0 %THEN %START ;! NO PREVIOUS DECLN
%IF CHP>CHL(J) %THEN CHP=CHL(J) ;! MOVE CHP BACK
CHL(J)=0 ;! CLEAR NAME LINK
%FINISH
I=RETURN CELL(I) ;! RETURN NAMELIST CELL
->1 ; %FINISH
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE PUSH START(%INTEGER FLAG,LABEL)
! PUSHDOWN START/FINISH BLOCK INFORMATION
%INTEGER I
I=NEWCELL
%IF LABEL<0 %THEN LABEL=65535
TAG(I)=FLAG<<16!LABEL ;! PACK FLAG & LABEL
LINK(I)=START(LEVEL) ;! PUSH CELL DOWN
START(LEVEL)=I ;! ONTO START LIST
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE ENTER(%INTEGER TYPE,ALLOC)
! DUMP CODE FOR NEW LEVEL & INITIALISE LEVEL ARRAYS
%INTEGER I
%IF LEVEL=1 %THEN %START
DUMP(X'C8',0,0,X'030E')
DUMP(X'40',0,0,0)
DUMP(X'41',14,0,0)
DUMP(X'27',14,12,-1)
DUMP(X'C8',15,14,0)
LSTPP=CA-2
DUMP(X'08',BR(1),15,-1)
%FINISH %ELSE %START
DUMP(X'40',BR(LEVEL),15,0)
DUMP(X'08',BR(LEVEL),15,-1)
DUMP(X'40',7,15,2)
%FINISH
DUMP(X'CA',15,0,0)
STAR(LEVEL)=CA-2
JUMP(LEVEL)=0 ;! NO JUMPS AT NEW LEVEL
NAME(LEVEL)=0 ;! NO NAMES AT NEW LEVEL
RTP(LEVEL)=TYPE ;! BLOCK/ROUTINE/FN TYPE
START(LEVEL)=0 ;! NO START/FINISH BLOCK
RAD(LEVEL)=ALLOC ;! NEXT RELATIVE ADDRESS
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE PMN(%INTEGER I)
%INTEGER J,K,L
J=ASSOP(I)
%CYCLE K=24,-8,0
L=J>>K&255
%IF L#0 %THEN PRINT SYMBOL(L)
%REPEAT
PRINT STRING(', ')
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE RETURN
! DUMP CODE FOR %RETURN
DUMP(X'08',15,BR(LEVEL),-1) ;! RESTORE DISPLAY
DUMP(X'48',BR(LEVEL),15,0)
DUMP(X'48',7,15,2)
DUMP(X'03',0,7,-1) ;! BRANCH TO RETRN ADDR
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE RT
! DUMP CODE FOR A ROUTINE OR FUNCTION CALL
%INTEGER I,J,K,L,M,N,P,PP
%IF PARS>20 %THEN DUMP(X'CA',15,0,PARS)
PP=PARS
PARS=20
I=TAGL(A(AP)) ;! LINK TO TAG
AP=AP+1 ;! AP ON <APP>
J=TAG(I) ;! TAG OF NAME
K=J>>20&15+1 ;! PARAMS+1
1: K=K-1 ;! COUNT PARAMS
AP=AP+1 ;! AP ON <APP>+1
%IF A(AP-1)=2 %THEN %START ;! PARAMS ABSENT
DUMP(X'41',7,M'BT',J&65535) ;! DUMP BRANCH
%IF K>0 %THEN FAULT('TOO FEW PARAMS')
PARS=PP
%IF PARS>20 %THEN DUMP(X'CB',15,0,PARS)
%RETURN ; %FINISH
%IF K<=0 %THEN %START ;! TOO MANY PARAMS
%IF K=0 %THEN FAULT('TOO MANY PARAMS')
->2 ; %FINISH
I=LINK(I) ;! LINK TO NEXT CELL
L=TAG(I) ;! TAG OF PARAMETER
%IF L>>28=0 %THEN %START ;! SCALAR VALUE
SEXPR ;! COMPILE EXPR
->3 ; %FINISH
%IF A(AP)=4 %AND A(AP+1)=1 %THEN ->4 ;! <+-\> IS NULL
5: FAULT('NOT A NAME PARAM')
2: AP=NP(NP(AP+1)) ;! SKIP INVALID EXPR
->1
4: M=TAGL(A(AP+2)) ;! LINK TO TAG
%IF M=0 %THEN %START
PRINT NAME(A(AP+2))
FAULT('NAME NOT SET')
->2 ; %FINISH
N=TAG(M) ;! TAG OF ACTUAL PARAM
%IF L>>28=1 %THEN %START ;! PARAM SCALAR
%IF N>>28=4 %THEN %START ;! ACTUAL IS RT
PRINT NAME(A(AP+2))
->5 ; %FINISH
%IF N>>28>=2 %THEN %START ;! ACTUAL IS ARRAY
AP=AP+2 ;! AP ON <NAME>
ARRAD ;! GET ELEMENT ADDR
AP=AP+1 ;! AP <EXPR>+1
%IF A(AP-1)=1 %THEN ->5 ;! FURTHER OPERANDS
->3 ; %FINISH
%IF A(AP+3)=1 %THEN %START ;! <APP> NOT NULL
PRINT NAME(A(AP+2))
FAULT('SCALAR HAS PARAM')
->2 ; %FINISH
%IF A(AP+4)=1 %THEN ->5 ;! FURTHER OPERAND
%IF N>>28=1 %THEN P=X'48' %ELSE P=X'C8';! LOAD FOR NAME
DUMP(P,3,BR(N>>16&15),N&65535)
%FINISH %ELSE %START ;! PARAM IS ARRAY
%IF A(AP+3)\=2 %OR A(AP+4)\=2 %THEN ->5 ;! <APP> NOT NULL
%IF N>>28&2=0 %THEN %START
PRINT NAME(A(AP+2))
FAULT('NOT AN ARRAY NME')
->2 ; %FINISH
DUMP(X'48',3,BR(N>>16&15),N&65535)
%FINISH
AP=AP+5 ;! AP ON <EXPS>
3: DUMP(X'40',3,15,L&65535)
PARS=PARS+2
->1
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE ARRAD
! DUMP CODE TO CALCULATE ARRAY ELEMENT ADDRESS
%INTEGER I,J,K,L
L=A(AP)
I=TAGL(L) ;! LINK TO TAG
J=TAG(I)
AP=AP+2 ;! AP ON <APP>+1
%IF A(AP-1)=1 %THEN %START ;! INDEXES PRESENT
%IF A(AP+1)=2 %AND A(AP+3)=2 %THEN %START
K=A(AP+2)
%IF A(AP)=2 %THEN K=-K
%IF A(AP)=3 %THEN K=\K
K=2*K
AP=AP+4
%IF -15<=K<=15 %THEN %START
%IF K>=0 %THEN DUMP(X'24',3,K,-1)%ELSE DUMP(X'25',3,-K,-1)
%FINISH %ELSE DUMP(X'C8',3,0,K&X'FFFF')
%FINISH %ELSE %START
SEXPR ;! COMPILE EXPR
DUMP(X'91',3,1,-1)
%FINISH
%IF A(AP)=1 %THEN %START ;! 2ND INDEX PRESENT
PRINT NAME(L)
FAULT('TOO MANY INDEXES')
AP=NP(AP) ;! SKIP EXCESS INDEXES
%FINISH %ELSE AP=AP+1 ;! AP AFTER EXPR
DUMP(X'4A',3,BR(J>>16&15),J&65535)
%FINISH %ELSE %START
PRINT NAME(L)
FAULT('NO ARRAY INDEXES')
%FINISH
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%INTEGERFN BT NEXT
! ALLOCATE NEXT POSITION IN BRANCH TABLE
%IF BTN>1023 %THEN PRINT STRING('
TOO MANY LABELS') %AND %MONITORSTOP
BAT(BTN)=-1 ;! MARKER
BTN=BTN+1 ;! NEXT POSITION
%RESULT=BTN-1 ;! THIS POSITION
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%INTEGERFN WS NEXT
! ALLOCATE NEXT WORK SPACE POSITION
WS=WS+2
%IF WS=22 %THEN FAULT('COMPILER WORKSPACE')
%RESULT=WS-2
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%INTEGERFN SEXFNS(%INTEGER AP)
%INTEGER I
AP=AP+1
1: %IF A(AP)=1 %THEN %START
I=TAGL(A(AP+1))
%IF I\=0 %AND TAG(I)>>28=4 %THEN %RESULT=1
%IF A(AP+2)=1 %THEN %START
%IF SEXFNS(AP+3)=1 %THEN %RESULT=1 %ELSE AP=NP(AP+2)
%FINISH %ELSE AP=AP+3
%FINISH %ELSE %START
%IF A(AP)=2 %THEN AP=AP+2 %ELSE %START
%IF SEXFNS(AP+1)=1 %THEN %RESULT=1 %ELSE AP=NP(AP)
%FINISH
%FINISH
%IF A(AP)=1 %THEN AP=AP+2 %AND ->1
%RESULT=0
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%INTEGERFN FIND LABEL
! CHECK & LOCATE OR INSERT LABEL IN JUMP LIST FOR THIS LEVEL
%INTEGER I,J
LABEL=A(AP) ;! VALUE OF CONST
AP=AP+1 ;! AFTER <CONST>
%IF LABEL>>16\=0 %THEN %START ;! INVALID LABEL NUMBER
WRITE(LABEL,1)
SPACES(2)
FAULT('INVALID LABEL')
%RESULT=-1 ;! 'FAULTY' RESULT
%FINISH
I=JUMP(LEVEL) ;! JUMP LIST POINTER
1: %IF I\=0 %THEN %START ;! SOMETHING IN LIST
%IF LABEL=TAG(I)>>16 %THEN %RESULT=TAG(I)&65535 ;! LABEL ALREADY
I=LINK(I) ;! NEXT CELL IN LIST
->1 ; %FINISH
I=NEWCELL ;! LABEL NOT IN LIST
J=BT NEXT ;! GET NEXT BRANCH TABLE
TAG(I)=LABEL<<16!J ;! FILL IN LIST ENTRY
LINK(I)=JUMP(LEVEL) ;! PUSHDOWN
JUMP(LEVEL)=I ;! NEW JUMP LIST POINTER
%RESULT=J ;! NEW BRANCH TABLE POS
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE STORE TAG(%INTEGER NAM,FORM,TYPE,DIM,LEV,AD)
! STORE TAGS - SET NAME & CHECK NOT SET ALREADY
%INTEGER M,N
M=TAGL(NAM) ;! PTR TO EXISTING TAG
%IF M\=0 %AND LEV=TAG(M)>>16&15 %AND FORM\=4 %THEN %START
PRINT NAME(NAM)
FAULT('NAME SET TWICE')
%RETURN ; %FINISH
N=NEWCELL ;! NEW CELL FOR TAGS
TAG(N)=FORM<<28!TYPE<<24!DIM<<20!LEV<<16!AD ;! FILL IN TAGS
LINK(N)=TAGL(NAM) ;! PUSHDOWN ON TAGS LIST
TAGL(NAM)=N
N=NEWCELL
TAG(N)=NAM ;! PUSHDOWN ON NAME LIST
LINK(N)=NAME(LEVEL)
NAME(LEVEL)=N
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE DUMP(%INTEGER OP,REG,BASE,DISP)
%INTEGER I
%IF CA>=65514 %THEN PRINT STRING('
CODE ARRAY FULL') %AND %MONITORSTOP
CODE(CA)=OP
LOPR=OP
%IF BASE=M'BT' %THEN %START
I=DISP
DISP=BAT(I)&X'FFFF'
BAT(I)=BAT(I)&X'FFFF0000'!(CA+2)
BASE=14
%FINISH
CODE(CA+1)=REG<<4!BASE
CA=CA+2
%IF DISP>=0 %THEN CODE(CA)=DISP>>8&255 %AND CODE(CA+1)=DISP&255 %C
%AND CA=CA+2
%END
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE FAULT(%STRING(63) S)
PRINT STRING('* FAULT : '.S)
NEWLINE
FAULTS=FAULTS+1 ;! INCREMENT FAULT COUNT
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%INTEGERFN CH NEXT
! ALLOCATE NEXT POSITION IN 'CH' ARRAY
%IF CHP>512 %THEN PRINT STRING('
NAMES TOO LONG') %AND %MONITORSTOP
CHP=CHP+1
%RESULT=CHP-1
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%INTEGERFN NEWCELL
! ALLOCATE NEW CELL FOR LIST PROCESSING
%INTEGER I
%IF ASL=0 %THEN PRINT STRING('
ASL EMPTY') %AND %MONITORSTOP
I=ASL ;! POINTER TO TOP CELL OF ASL
ASL=LINK(ASL) ;! ASL POINTER TO NEXT CELL DOW
TAG(I)=0 ;! CLEAR NEW CELL OUT
LINK(I)=0
%RESULT=I ;! INDEX TO NEW CELL
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%INTEGERFN RETURN CELL(%INTEGER I)
! DEALLOCATE CELL AND RETURN IT TO ASL
%INTEGER J
J=LINK(I) ;! PRESENT LINK VALUE OF CELL
LINK(I)=ASL ;! LINK TO TOP OF ASL
ASL=I ;! ASL POINTER TO RETURNED CELL
%RESULT=J ;! RETURN VALUE OF LINK
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE PRINT NAME(%INTEGER I)
! PRINT NAME FROM HASH POSITION
%INTEGER J,K,L,M
J=CHL(I) ;! POINTER TO CH ARRAY
K=CH(J) ;! LENGTH & FIRST 3 CHARS
L=K>>24 ;! NUMBER OF CHARS IN NAME
M=16 ;! FIRST SHIFT VALUE
1: PRINT SYMBOL(K>>M&255)
L=L-1
%IF L=0 %THEN %START
SPACES(2)
%RETURN ; %FINISH
M=M-8 ;! NEXT SHIFT VALUE
%IF M<0 %THEN %START
J=J+1
K=CH(J) ;! NEXT WORD OF CHARS
M=24
%FINISH
->1
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE PHEX(%INTEGER I,J)
%INTEGER K,L,M
%OWNBYTEINTEGERARRAY H(0:15)='0','1','2','3','4','5','6','7',
'8','9','A','B','C','D','E','F'
%IF J=0 %THEN J=12 %AND K=0 %ELSE K=1
%CYCLE L=J,-4,0
M=I>>L&15
%IF M=0 %AND K=0 %THEN %START
SPACE
%IF L=4 %THEN K=1
%FINISH %ELSE PRINT SYMBOL(H(M)) %AND K=1
%REPEAT
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%END
%ENDOFFILE