%BEGIN
%ROUTINESPEC READ SYM(%INTEGERNAME I)
%ROUTINESPEC READ PS
%ROUTINESPEC READ LINE
%INTEGERFNSPEC COMPARE(%INTEGER PSP)
%ROUTINESPEC SS
%ROUTINESPEC FAULT(%INTEGER A,B,C,D)
%ROUTINESPEC OUT(%INTEGER I)
%INTEGERFNSPEC CHNEXT
%INTEGERFNSPEC NEWCELL
%INTEGERFNSPEC RETURN CELL(%INTEGER I)
%ROUTINESPEC PRINT NAME(%INTEGER I)
%ROUTINESPEC PRINT LABEL(%INTEGER I)
%ROUTINESPEC SHOW TAGS
%INTEGER I,J,AP,APP,TP,ASL,BTN,CTN,CHP,FAULTS,NL,LEVEL,CA,COMP,SCF,PARS
%INTEGERARRAY PS(-1000:-620) ;! REDUCED PHRASE STRUCTURE
%INTEGERARRAY CHL,TAGL(0:255)
%INTEGERARRAY TAG,LINK(1:1000) ;! TAGS LISTS
%INTEGERARRAY A,PN,NP(1:200) ;! ANALYSIS RECORD
%INTEGERARRAY T(1:300) ;! SOURCE TEXT
%INTEGERARRAY BAT,COT(0:1023) ;! BRANCH, CONST TABLES
%INTEGERARRAY CH(1:512) ;! NAME CHAR TABLE
%INTEGERARRAY JUMP,STAR,BRT,NAME,RTP,BR,START,RAD(0:15);!LEVEL INFO
%INTEGERARRAY TRUE,FALSE(1:6) ;! CONDITIONAL BRANCH INSTR
%INTEGERARRAY PREC,UCN(1:12) ;! OPERATOR PRECS, TYPES
%INTEGERARRAY OPR(0:12) ;! MACHINE OPERATIONS
%INTEGERARRAY PT,PI(1:15) ;! FOR RT SPECS, HEADINGS
!****
%EXTERNALROUTINESPEC DEFINE(%STRING(63) S)
DEFINE('STREAM01,SKIMPPS+SKIMPI')
SELECT INPUT(1)
DEFINE('STREAM02,SKIMPO')
SELECT OUTPUT(2)
!****
READ PS
I=0
10: CHL(I)=0 ; TAGL(I)=0 ;! CLEAR HASHING ARRAY
I=I+1
%IF I<=255 %THEN ->10
I=1
11: TAG(I)=0 ; LINK(I)=I+1 ;! SET UP SPACE LIST
I=I+1
%IF I<1000 %THEN ->11
LINK(1000)=0
ASL=1
! BASE REGISTER MNEMONICS
BR(0)=M'BR0' ; BR(1)=M'BR1' ; BR(2)=M'BR2' ; BR(3)=M'BR3'
BR(4)=M'BR4' ; BR(5)=M'BR5' ; BR(6)=M'BR6' ; BR(7)=M'BR7'
BR(8)=M'BR8' ; BR(9)=M'BR9' ; BR(10)=M'BR10'; BR(11)=M'BR11'
BR(12)=M'BR12'; BR(13)=M'BR13'; BR(14)=M'BR14'; BR(15)=M'BR15'
! CONDITIONAL BRANCH MNEMONICS
TRUE(1)=M'BZ' ; FALSE(1)=M'BNZ'
TRUE(2)=M'BNZ' ; FALSE(2)=M'BZ'
TRUE(3)=M'BNG' ; FALSE(3)=M'BG'
TRUE(4)=M'BL' ; FALSE(4)=M'BNL'
TRUE(5)=M'BNL' ; FALSE(5)=M'BL'
TRUE(6)=M'BG' ; FALSE(6)=M'BNG'
! INSTRUCTION MNEMONICS, PRECEDENCES & TYPES
! 4 : HIGHEST PRECEDENCE, 1 : LOWEST PRECEDENCE
! 1 : UNARY, 2 : BINARY COMMUTATIVE, 3 : BINARY NON-COMMUTATIVE TYPES
OPR(0)=M'LOAD'
OPR(1)=M'SHL' ; PREC(1)=3 ; UCN(1)=3 ;! <<
OPR(2)=M'SHR' ; PREC(2)=3 ; UCN(2)=3 ;! >>
OPR(3)=M'AND' ; PREC(3)=2 ; UCN(3)=2 ;! &
OPR(4)=M'XOR' ; PREC(4)=1 ; UCN(4)=2 ;! !!
OPR(5)=M'OR' ; PREC(5)=1 ; UCN(5)=2 ;! !
OPR(6)=M'EXP' ; PREC(6)=3 ; UCN(6)=3 ;! **
OPR(7)=M'DIV' ; PREC(7)=2 ; UCN(7)=3 ;! /
OPR(8)=M'MLT' ; PREC(8)=2 ; UCN(8)=2 ;! *
OPR(9)=M'ADD' ; PREC(9)=1 ; UCN(9)=2 ;! +
OPR(10)=M'SUB' ; PREC(10)=1 ; UCN(10)=3 ;! -
OPR(11)=M'NEG' ; PREC(11)=1 ; UCN(11)=1 ;! -
OPR(12)=M'NOT' ; PREC(12)=4 ; UCN(12)=1 ;! \
BTN=0 ;! BRANCH TABLE POINTER
CTN=0 ;! CONSTANT 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)=10 ;! NEXT REL ADDR TO ALLOCATE
PARS=10 ;! NEXT PARAMETER REL ADDR
CA=0 ;! CURRENT CODE DUMPING ADDRESS
PRINT LABEL(M'PR') ;! LABEL AT START OF CODE
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
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
I=1 ;! PRINT OUT ANALYSIS REC
J=1
5: WRITE(J,5) ;! INDEX TO ANALYSIS REC
J=J+1
%IF J<=I+11 %AND J<=AP %THEN ->5
NEWLINE
J=I
6: SPACES(2) ;! PHRASE NAMES
OUT(PN(J))
J=J+1
%IF J<=I+11 %AND J<=AP %THEN ->6
NEWLINE
J=I
7: WRITE(A(J),5) ;! ALTERNATIVE NUMBERS
J=J+1
%IF J<=I+11 %AND J<=AP %THEN ->7
NEWLINE
J=I
8: WRITE(NP(J),5) ;! NEXT PHRASE POSITION
J=J+1
%IF J<=I+11 %AND J<=AP %THEN ->8
NEWLINES(2)
I=I+12
%IF J<=AP %THEN ->5
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(M'SYNT',M'AX ',0,0) ;! 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 SYM(%INTEGERNAME I)
READ SYMBOL(I)
PRINT SYMBOL(I)
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE READ PS
! READ IN AND REDUCE PHRASE STRUCTURE
%INTEGER PNP,ALT,P,I,J,K
%INTEGERARRAY PN,PSP(256:300) ;! PHRASE NAME CHARS & POINTERS
%ROUTINESPEC INSERT LIT
%INTEGERFNSPEC GET PN
PNP=256 ;! PN POINTER
P=-1000 ;! PS POINTER
1: READ SYM(I)
%IF I='B' %THEN %START ;! BUILT-IN PHRASE
2: READ SYM(I) ;! SKIP TO <
%IF I\='<' %THEN ->2
J=GET PN ;! READ PHRASE NAME ETC
3: READ SYM(I) ;! SKIP TO =
%IF I\='=' %THEN ->3
READ(K) ;! READ PHRASE NUMBER
WRITE(K,1)
NEWLINE
PSP(J)=K ;! FILL IN PHRASE NUMBER
->1 ; %FINISH ;! GO DEAL WITH NEXT PHRASE
%IF I='P' %THEN %START ;! PHRASE
4: READ SYM(I) ;! SKIP TO <
%IF I\='<' %THEN ->4
J=GET PN ;! READ PHRASE NAME
PS(P)=PN(J) ;! STORE NAME
PSP(J)=P ;! FILL IN POSITION
P=P+1
7: ALT=P ;! REMEMBER START POSITION
6: P=P+1 ;! NEXT PS POSITION
5: READ SYM(I) ;! START OF NEXT ITEM
%IF I='''' %THEN %START ;! LITERAL TEXT
INSERT LIT ;! READ LITERAL & INSERT
->5 ; %FINISH ;! GO FOR NEXT ITEM
%IF I='<' %THEN %START ;! ITEM IS A PHRASE NAME
PS(P)=GET PN ;! READ PHRASE NAME & FILL IN
->6 ; %FINISH ;! GO FOR NEXT ITEM
%IF I=',' %THEN %START ;! END OF THIS ALTERNATIVE
PS(ALT)=P ;! FILL IN POINTER TO END
->7 ; %FINISH ;! GO FOR START OF NEXT ALT
%IF I=';' %THEN %START ;! END OF PHRASE DEFINITION
PS(ALT)=P ;! FILL IN POINTER TO END
PS(P)=0 ;! FILL IN END MARKER
P=P+1 ;! NEXT PS POSITION
->1 ; %FINISH ;! GO FOR NEXT PHRASE
->5 ; %FINISH ;! SKIP
%IF I='E' %THEN %START ;! END OF PHRASE STRUCTURE
NEWPAGE ;! REPLACE ALL POINTERS TO PS
I=-1000 ;! & PRINT OUT REDUCED FORM
J=0
8: %IF J=0 %THEN %START ;! 8 PER LINE
NEWLINE
WRITE(I,4) ;! INDEX TO PS
SPACES(3)
%FINISH
K=PS(I)
%IF K>=256 %AND K<=300 %THEN PS(I)=PSP(K) ;! PHRASES
%IF PS(I)<=256 %THEN WRITE(PS(I),7) %ELSE %START
SPACES(4)
OUT(K)
%FINISH
I=I+1
J=(J+1)&7
%IF I\=P %THEN ->8
NEWPAGE
%RETURN ; %FINISH
->1 ;! SKIP
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE INSERT LIT
! INSERT LITERAL TEXT INTO 'PS'
%INTEGER SH,I
SH=0 ;! % SHIFT VALUE TO 0
1: READ SYM(I)
%IF I='''' %THEN %START
%IF NEXT SYMBOL\='''' %THEN %RETURN ;! END OF LITERAL
READ SYM(I) ;! QUOTE INSIDE LITERAL - IGNORE
%FINISH
%IF I='%' %THEN SH=128 %ELSE %START ;! SHIFT VALUE TO 128 FOR %
%IF I<'A' %OR I>'Z' %THEN SH=0 ;! END OF KEYWORD - SHIFT VAL
PS(P)=I+SH ;! STORE SHIFTED (POSSIBLY) CHAR
P=P+1 ;! MOVE TO NEXT POSITION IN PS
%FINISH
->1
%END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%INTEGERFN GET PN
! READ IN PHRASE NAME AND GET INDEX IN 'PSP'
%INTEGER NP,I
NP=M' ' ;! TO ACCUMULATE PHRASE NAME CHARS
1: READ SYM(I)
%IF I\='>' %THEN %START ;! NOT END OF NAME YET
NP=NP<<8!I ;! PACK NEXT CHAR OF PHRASE NAME
->1 ; %FINISH
%IF PNP\=256 %THEN %START ;! NOT FIRST PHRASE NAME
I=256 ;! SCAN NAMES TO FIND IF ALREADY IN
2: %IF NP=PN(I) %THEN %RESULT=I
I=I+1
%IF I\=PNP %THEN ->2
%FINISH
PN(PNP)=NP ;! INSERT NEW NAME IN DICTIONARY
PSP(PNP)=M'????' ;! UNDEFINED PHRASE MARKER
PNP=PNP+1 ;! MOVE TO NEXT DICTIONARY POSITION
%RESULT=PNP-1
%END
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE READ LINE
! LEXICAL PHASE - READ & CLEAN UP NEXT LINE OF TEXT
%ROUTINESPEC STORE(%INTEGER I)
%INTEGER SH,I
NEWLINES(2)
SH=0 ;! % & LITERAL SHIFT VALUE TO 0
TP=1 ;! POINTER TO TEXT ARRAY T
1: READ SYM(I)
%IF I='''' %THEN %START
SH=0 ;! SHIFT VALUE FOR LITERAL
2: STORE(I) ;! STORE CHAR IN TEXT A
READ SYM(I)
%IF I\='''' %THEN ->2 ;! NOT END OF LITERAL YET
READ SYM(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 %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(M'STAT',M'MNT ',M'TOO ',M'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>
%INTEGER APP,TPP,AE,N
TPP=TP ;! PRESERVE INITIAL TEXT POINTER
APP=AP ;! PRESERVE INITIAL ANAL REC PTR
A(AP)=1 ;! ALTERNATIVEE 1 FIRST
PN(AP)=PS(PSP)
PSP=PSP+1
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
AP=AP+1 ;! NEXT ANALYSIS RECORD POSITION
%IF AP>200 %THEN %START
FAULT(M'ANAL',M' REC',M' FUL',M'L ')
%STOP ; %FINISH
%IF COMPARE(N)=1 %THEN ->12 ;! SUCCESSFUL COMPARISON
->13 ; %FINISH ;! UNSUCCESSFUL - GO FOR NEXT ALT
%IF N=1 %THEN %START ;! BUILT-IN PHRASE <NAME>
%IF NAME=1 %THEN ->12 ;! SUCCESS
->13 ; %FINISH ;! FAILURE
%IF N=2 %THEN %START ;! BUILT-IN PHRASE CNST
%IF CNST=1 %THEN ->12 ;! SUCCESS
->13 ; %FINISH ;! FAILURE
%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
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%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)='''') %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(M'DICT',M'IONA',M'RY F',M'ULL ')
%STOP ; %FINISH
->2 ; %FINISH
CHL(K)=J ;! STORE CHAR ARRAY POSITION
3: AP=AP+1 ;! NEXT ANALYSIS RECORD POSITION
%IF AP>200 %THEN %START
FAULT(M'ANAL',M' REC',M' FUL',M'L ')
%STOP ; %FINISH
A(AP)=K ;! STORE IDENTIFICATION NO OF NAME
PN(AP)=M'NAME' ;! PHRASE <NAME> MATCHED
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>4 %THEN FAULT(M'STRI',M'NG T',M'OO L',M'ONG ')
->2 ; %FINISH
%IF I<'0' %OR I>'9' %THEN %RESULT=0 ;! NOT A CONSTANT
J=0
K=0
3: %IF J<214748364 %OR (J=214748364 %AND I<='7') %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(M'CONS',M'T TO',M'O BI',M'G ')
2: AP=AP+1 ;! NEXT ANALYSIS REC POSITION
%IF AP>200 %THEN %START
FAULT(M'ANAL',M' REC',M' FUL',M'L ')
%STOP ; %FINISH
A(AP)=J ;! FILL IN VALUE OF CONSTANT
PN(AP)=M'CNST' ;! PHRASE <CNST> MATCHED
NP(AP)=AP+1 ;! NEXT PHRASE
%RESULT=1 ;! SUCCESS
%END
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE SS
! COMPILE SOURCE STATEMENT
%ROUTINESPEC UI
%ROUTINESPEC SCCOND(%INTEGERNAME LABEL)
%ROUTINESPEC SEXPR
%INTEGERFNSPEC FIND LABEL
%ROUTINESPEC CHECK
%ROUTINESPEC UNSET
%ROUTINESPEC PUSH START(%INTEGER FLAG,LABEL)
%INTEGERFNSPEC BT NEXT
%INTEGERFNSPEC CT 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
%INTEGER I,J,K,L,M,N,P,Q,R,WS,LABEL
I=A(AP) ;! ANALYSIS RECORD ENTRY
AP=AP+1 ;! FOR FOLLOWING ENTRY
WS=2 ;! SET WORKSPACE POINTER
%IF I=1 %THEN ->10 ;! UNCONDITIONAL INSTRUCTION
%IF I=2 %THEN ->20 ;! CONDITIONAL STATEMENT
%IF I=3 %THEN ->30 ;! LABEL
%IF I=4 %THEN ->40 ;! %FINISH
%IF I=5 %THEN ->50 ;! DECLARATIONS
%IF I=6 %THEN ->60 ;! ROUTINE/FN SPEC
%IF I=7 %THEN ->70 ;! %END
%IF I=8 %THEN ->80 ;! %BEGIN
%IF I=9 %THEN ->90 ;! %ENDOFPROGRAM
%RETURN ;! <SEP>
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
10: UI ;! COMPILE UNCONDITIONAL INSTR
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %IF - - - %THEN - - - %ELSE
20: SCCOND(I) ;! COMPILE CONDITION
%IF A(AP)=2 %THEN %START ;! AP ON <UI> - JUMP INSTR
AP=AP+2 ;! AP ON <ELSE>
J=-1 ;! MARKER FOR 'JUMP'
%FINISH %ELSE %START ;! NOT A JUMP
%IF A(AP)=3 %THEN %START ;! %START
%IF A(AP+1)=1 %THEN FAULT(M'%STA',M'RT %',M'ELSE',M' ')
PUSH START(0,I)
%RETURN ; %FINISH
UI ;! COMPILE REMAINING UI
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('B',0,M'BT',J)
%FINISH
%IF I>=0 %THEN BAT(I)=CA ;! FILL IN LAB ON <ELSE>-CLAUSE
AP=AP+1 ;! AP ON <UI>
%IF A(AP)=3 %THEN %START ;! %START
PUSH START(1,J)
%RETURN ; %FINISH
UI ;! COMPILE REMAINING <UI>S
I=J ;! JUMP AROUND LABEL
%FINISH
%IF I>=0 %THEN BAT(I)=CA ;! TO BRANCH ROUND THE UI
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! CONST: - - -
30: 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(M'LABE',M'L SE',M'T TW',M'ICE ')
%FINISH
BAT(I)=CA ;! FILL IN LABEL ADDRESS
%FINISH
SS ;! COMPILE STATEMENT AFTER LAB
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %FINISH - - -
40: I=START(LEVEL) ;! LINK TO FIRST CELL
%IF I=0 %THEN %START ;! NO CELLS IN LIST
FAULT(M'SPUR',M'IOUS',M' %FI',M'NISH')
%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(M'TWO ',M'%ELS',M'ES !',0)
K=BT NEXT ;! JUMP AROUND <UI>
DUMP('B',0,M'BT',K)
%IF J\=65535 %THEN BAT(J)=CA ;! FILL IN LABEL ON <UI>
AP=AP+1 ;! AP ON <UI>
%IF A(AP)=3 %THEN %START ;! %START
PUSH START(1,K)
%RETURN ; %FINISH
UI ;! COMPILE REMAINING <UI>S
J=K ;! JUMP AROUND LABEL
%FINISH
%IF J\=65535 %THEN BAT(J)=CA ;! FILL IN JUMP AROUND LAB
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! DECLARATIONS
50: %IF A(AP)=1 %THEN %START ;! <ARR> = %ARRAY
APP=AP ;! SAVE AP
AP=NP(AP+2) ;! AP ON <+-\>
SEXPR ;! COMPILE EXPR
DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT) ;! STORE VALUE IN WRK
SEXPR ;! COMPILE EXPR
DUMP(M'LDA',M'ACC',M'ACC',1) ;! INCREMENT VALUE
DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT)
WS=WS-2 ;! RESTORE WORKSPACE
I=1 ;! NO OF DIMS
J=2 ;! TAG FOR 'ARRAY'
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
DUMP(M'SUB',M'STP',BR(LEVEL),WS)
DUMP(M'STR',M'STP',BR(LEVEL),RAD(LEVEL))
DUMP(M'ADD',M'STP',BR(LEVEL),WS+1)
%FINISH
RAD(LEVEL)=RAD(LEVEL)+1
AP=AP+2 ;! AP ON <NAMS>
%IF A(AP)=1 %THEN ->52 ;! MORE NAMES
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! RT SPEC - - -
60: 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=10 ;! 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(M'TOO ',M'MANY',M' PAR',M'AMS ')
->61 ; %FINISH ;! IGNORE PARAMS
PT(L)=P!M ;! STORE TAG
PI(L)=A(AP+1) ;! STORE IDENT
M=M+1 ;! 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
%IF LEVEL=0 %THEN BAT(BTN-1)=K+65536 ;! FLAG FOR EXT RT
%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(M'RT N',M'OT A',M'S SP',M'EC ')
%FINISH
%IF BAT(TAG(N)&65535)>=0 %THEN %START
PRINT NAME(K)
FAULT(M'RT A',M'PPEA',M'RS T',M'WICE')
%FINISH
P=TAG(N)>>20&15 ;! NO OF PARAMS
%IF L\=P %THEN %START
FAULT(M'PARS',M' NOT',M' AS ',M'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(M'PAR ',M'NOT ',M'AS S',M'PEC ')
%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(M'NAME',M' SET',M' TWI',M'CE ')
%FINISH
%FINISH
%IF J=2 %THEN %START ;! STATEMENT NOT SPEC
BRT(LEVEL)=BT NEXT ;! BRANCH ROUND RT
DUMP('B',0,M'BT',BRT(LEVEL))
BAT(TAG(TAGL(K))&65535)=CA ;! FILL IN ADDR
%IF LEVEL=15 %THEN FAULT(M'TOO ',M'MANY',M' LEV',M'ELS ') %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
70: SHOW TAGS ;! PRINT OUT TAGS
CHECK ;! CHECK LABS & STARTS
COT(STAR(LEVEL))=RAD(LEVEL) ;! STORE STATIC ALLOC
UNSET ;! UNSET NAMES DECLARED
%IF RTP(LEVEL)\=0 %THEN DUMP(M'STOP',0,0,0) ;! %STOP FOR FNS
RETURN ;! DUMP %RETURN CODE
LEVEL=LEVEL-1 ;! DECREMENT TEXT LEV
%IF LEVEL<1 %THEN %START ;! NOT OUTER LEV
FAULT(M'EXCE',M'SS %',M'END ',0)
->71 ; %FINISH ;! TREAT AS %ENDOFPROG
BAT(BRT(LEVEL))=CA ;! FILL ADDR FOR BRANCH
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %BEGIN
80: %IF LEVEL\=0 %THEN %START
FAULT(M'%BEG',M'IN E',M'XTRA',0) ;! NO INTERNAL BLOCKS
%RETURN ; %FINISH
%IF CA\=0 %OR RAD(0)\=10 %THEN %START
FAULT(M'%BEG',M'IN N',M'OT F',M'IRST')
%RETURN ; %FINISH
LEVEL=1 ;! TEXTUAL LEVEL COUNT TO 1
ENTER(-1,10)
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %ENDOFPROGRAM
90: SHOW TAGS ;! PRINT OUT NAME TAGS
CHECK ;! CHECK LABELS & START
COT(STAR(LEVEL))=RAD(LEVEL) ;! FILL IN STATIC ALLOCATION
UNSET ;! UNSET NAMES DECLARED
%IF LEVEL\=1 %THEN FAULT(M'TOO ',M'FEW ',M'%END',M'S ')
71: DUMP(M'STOP',0,0,0) ;! %STOP
PRINT LABEL(M'BT')
CA=0
93: %IF CA\=BTN %THEN %START
DUMP('B',0,M'PR',BAT(CA)) ;! BRANCH RELATIVE TO START
->93 ; %FINISH
PRINT LABEL(M'CT')
CA=0
91: %IF CA\=CTN %THEN %START
DUMP(0,0,0,COT(CA))
->91 ; %FINISH
PRINT LABEL(M'ST')
WRITE(FAULTS,1) ;! NUMBER OF PROGRAM FAULTS
FAULT(M' FAU',M'LTS ',M'IN P',M'ROG.')
%STOP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE UI
! COMPILE UNCONDITIONAL INSTRUCTION
%INTEGER I,J,K,L
I=A(AP) ;! NEXT ANALYSIS RECORD ENTRY
AP=AP+1
%IF I=1 %THEN ->10 ;! ROUTINE CALL OR ASSIGNMENT
%IF I=2 %THEN ->20 ;! JUMP INSTRUCTION
%IF I=3 %THEN ->30 ;! %START
%IF I=4 %THEN ->40 ;! %RETURN
%IF I=5 %THEN ->50 ;! %RESULT=
DUMP(M'STOP',0,0,0) ;! %STOP
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! NAME APP ASS
10: I=TAGL(A(AP)) ;! POINTER TO NAME TAGS
%IF I=0 %THEN %START
PRINT NAME(A(AP))
FAULT(M'NAME',M' NOT',M' SET',0)
%FINISH %ELSE I=TAG(I) ;! NAME TAGS OR ZERO
J=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=J ;! RESTORE AP TO <NAME>
RT ;! CALL ROUTINE
%FINISH %ELSE %START
%IF I\=0 %THEN %START
PRINT NAME(A(J))
FAULT(M'NOT ',M'ROUT',M'INE ',M'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(M'NAME',M' NOT',M' A D',M'ESTN') ;! ROUTINE/FN FORM
I=0 ;! CLEAR TAGS TO AVOID
%FINISH
AP=AP+1 ;! AP ON <+-\>
SEXPR
%IF I=0 %THEN %RETURN ;! LHS NAME NOT SET
%IF K>=2 %THEN %START ;! LHS AN ARRAY TYPE
DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT) ;! PRESERVE ACCUMMULATOR
K=AP ;! PRESERVE AP
AP=J ;! RESTORE ANAL REC PTR
ARRAD ;! CALCULATE ARRAY ADDR
WS=WS-1 ;! RESTORE WORKSPACE PTR
DUMP(M'LOAD',M'WK',BR(LEVEL),WS) ;! RESTORE ACCUMMULATOR
DUMP(M'STR',M'WK',M'ACC',0) ;! DUMP ASSIGNMENT
AP=K ;! RESTORE AP TO <UI>+1
%RETURN ; %FINISH
%IF K=1 %THEN %START
DUMP(M'LOAD',M'WK',BR(I>>16&15),I&65535);! INDIRECT ASSIGMENT
DUMP(M'STR',M'ACC',M'WK',0)
%FINISH %ELSE DUMP(M'STR',M'ACC',BR(I>>16&15),I&65535)
%IF A(J+1)=1 %THEN %START
PRINT NAME(A(J))
FAULT(M'SCAL',M'AR H',M'AS P',M'ARAM')
%FINISH
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! -> CONST
20: DUMP('B',0,M'BT',FIND LABEL) ;! SCAN/INSERT JUMP LIST
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %START
30: FAULT(M'%STA',M'RT ',0,0) ;! %START ALONE ILLEGAL
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %RETURN
40: %IF RTP(LEVEL)\=0 %THEN FAULT(M'%RET',M'URN ',M'CONT',M'EXT ')
RETURN ;! DUMP %RETURN CODE
%RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %RESULT=
50: I=RTP(LEVEL) ;! ROUTINE/FN TYPE
%IF I<=0 %THEN FAULT(M'%RES',M'ULT ',M'CONT',M'EXT ') ;! %BEGIN/%RT
SEXPR ;! COMPILE RESULT EXPR
RETURN ;! LEAVE RESULT IN ACC
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE SEXPR
! COMPILE ARITHMETIC EXPRESSION
%ROUTINESPEC TORP
%ROUTINESPEC STORE(%INTEGER I,J)
%ROUTINESPEC EVAL(%INTEGER P)
%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(M'NAME',M' NOT',M' SET',0)
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(M'SCAL',M'AR H',M'AS P',M'ARAM')
%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(M'ROUT',M'INE ',M'IN E',M'XPR ')
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(M'EXPR',M' TOO',M' LON',M'G ')
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
%ROUTINESPEC OPN(%INTEGER OP,L)
%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
DUMP(OPR(J),M'ACC',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(M'STR',M'ACC',BR(LEVEL),WS NEXT) ;! & STORE IT
EVAL(I) ;! EVALUATE 1ST OPD
WS=WS-1 ;! RESTORE WORKSPACE
DUMP(OPR(J),M'ACC',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(M'STR',M'ACC',BR(LEVEL),WS NEXT) ;! STORE VALUE OF 2ND
OPN(0,I) ;! LOAD 1ST OPERAND
WS=WS-1 ;! RESTORE WORKSPACE
DUMP(OPR(J),M'ACC',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
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE OPN(%INTEGER OP,L)
! DUMP SIMPLE OPERATION, OP=OPERATOR, L=RP POSITION OF OPERAND
%INTEGER I,J
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(M'LOAD',M'ACC',M'ACC',0) ;! LOAD VALUE
%RETURN ; %FINISH
%IF I=-3 %THEN %START ;! SCALAR TYPE
%IF AP>>28=1 %THEN %START ;! %NAME TYPE
DUMP(M'LOAD',M'WK',BR(AP>>16&15),AP&65535) ;! LOAD INDIRECT
DUMP(OPR(OP),M'ACC',M'WK',0)
%FINISH %ELSE DUMP(OPR(OP),M'ACC',BR(AP>>16&15),AP&65535)
%RETURN ; %FINISH
%IF OP\=0 %OR AP>65535 %THEN %START ;! NOT 'LDA'-ABLE
J=CT NEXT ;! NEXT HOLE IN CT
COT(J)=AP ;! STORE VALUE
DUMP(OPR(OP),M'ACC',M'CT',J)
%FINISH %ELSE DUMP(M'LDA',M'ACC',0,AP)
%END
%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 TF(I)=1 %THEN L=FALSE(COMP) %ELSE L=TRUE(COMP)
DUMP(L,M'ACC',M'BT',LBL(JMP(I))) ;! BRANCH TO REQ POS
%IF I<K-1 %THEN %START
%IF LBL(I)>=0%THEN BAT(LBL(I))=CA
I=I+1 ;! FILL IN LABEL ADDR
->4 ; %FINISH ;! MORE COMPARISONS
%IF LBL(I)>=0 %AND TF(I)=1 %THEN BAT(LBL(I))=CA ;! NOT FOR UI JUMP
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(M'COND',M'N TO',M'O LO',M'NG ')
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(M' LAB',M'EL N',M'OT S',M'ET ')
%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(M'%FIN',M'ISH ',M'MISS',M'ING ')
I=RETURN CELL(I) ;! POP UP CELL
->2 ; %FINISH
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE UNSET
! UNSET NAMES AND CHECK FOR MISSING ROUTINES
%INTEGER I,J,K
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(M'ROUT',M'INE ',M'MISS',M'ING ')
%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 DUMP(M'LDA',M'STP',M'ST',0) %ELSE %C
DUMP(M'STR',BR(LEVEL),M'STP',0) ;! ENTRY SEQUENCE
DUMP(M'LDA',BR(LEVEL),M'STP',0)
DUMP(M'STR',M'WK',M'STP',1)
I=CT NEXT ;! STATIC ALLOC HOLE
DUMP(M'ADD',M'STP',M'CT',I)
STAR(LEVEL)=I ;! REMEMBER POS OF HOLE
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 RETURN
! DUMP CODE FOR %RETURN
DUMP(M'LDA',M'STP',BR(LEVEL),0) ;! RESTORE DISPLAY
DUMP(M'LOAD',BR(LEVEL),M'STP',0)
DUMP(M'LOAD',M'WK',M'STP',1)
DUMP('B',0,M'WK',0) ;! 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>10 %THEN DUMP(M'LDA',M'STP',M'STP',PARS)
PP=PARS
PARS=10
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(M'BAL',M'WK',M'BT',J&65535) ;! DUMP BRANCH
%IF K>0 %THEN FAULT(M'TOO ',M'FEW ',M'PARA',M'MS ')
PARS=PP
%IF PARS>10 %THEN %START
I=CT NEXT
COT(I)=PARS
DUMP(M'SUB',M'STP',M'CT',I)
%FINISH
%RETURN ; %FINISH
%IF K<=0 %THEN %START ;! TOO MANY PARAMS
%IF K=0 %THEN FAULT(M'TOO ',M'MANY',M' PAR',M'AMS ')
->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(M'NOT ',M'A NA',M'ME P',M'ARAM')
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(M'NAME',M' NOT',M' SET',M' ')
->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(M'SCAL',M'AR H',M'AS P',M'ARAM')
->2 ; %FINISH
%IF A(AP+4)=1 %THEN ->5 ;! FURTHER OPERAND
%IF N>>28=1 %THEN P=M'LOAD' %ELSE P=M'LDA';! LOAD FOR NAME
DUMP(P,M'ACC',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(M'NOT ',M'AN A',M'RRAY',M' NME')
->2 ; %FINISH
DUMP(M'LOAD',M'ACC',BR(N>>16&15),N&65535)
%FINISH
AP=AP+5 ;! AP ON <EXPS>
3: DUMP(M'STR',M'ACC',M'STP',L&65535)
PARS=PARS+1
->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
SEXPR ;! COMPILE EXPR
%IF A(AP)=1 %THEN %START ;! 2ND INDEX PRESENT
PRINT NAME(L)
FAULT(M'TOO ',M'MANY',M' IND',M'EXES')
AP=NP(AP) ;! SKIP EXCESS INDEXES
%FINISH %ELSE AP=AP+1 ;! AP AFTER EXPR
DUMP(M'ADD',M'ACC',BR(J>>16&15),J&65535)
%FINISH %ELSE %START
PRINT NAME(L)
FAULT(M'NO A',M'RRAY',M' IND',M'EXES')
%FINISH
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%INTEGERFN BT NEXT
! ALLOCATE NEXT POSITION IN BRANCH TABLE
%IF BTN>1023 %THEN %START ;! FULL
FAULT(M'TOO ',M'MANY',M'LABE',M'LS ')
BTN=0 ;! TRY TO CONTINUE
%FINISH
BAT(BTN)=-1 ;! MARKER
BTN=BTN+1 ;! NEXT POSITION
%RESULT=BTN-1 ;! THIS POSITION
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%INTEGERFN CT NEXT
! ALLOCATE NEXT POSITION IN CONSTANT TABLE
%IF CTN>1023 %THEN %START ;! FULL
FAULT(M'TOO ',M'MANY',M' CON',M'STS ')
CTN=0 ;! TRY TO CONTINUE
%FINISH
COT(CTN)=-1
CTN=CTN+1 ;! NEXT POSITION
%RESULT=CTN-1 ;! THIS POSITION
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%INTEGERFN WS NEXT
! ALLOCATE NEXT WORK SPACE POSITION
WS=WS+1
%IF WS=11 %THEN FAULT(M'COMP',M'ILER',M' WKS',M'PACE')
%RESULT=WS-1
%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(M'INVA',M'LID ',M'LABE',M'L ')
%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(M'NAME',M' SET',M' TWI',M'CE ')
%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)
! PRINT OUT CURRENT ADDRESS, OPERATION MNEMONIC & OPERANDS
%ROUTINESPEC PMN(%INTEGER I)
WRITE(CA,5) ;! CURRENT ADDRESS
PRINT SYMBOL('.')
SPACES(10)
PMN(OP) ;! OPERATOR MNEMONIC
PMN(REG) ;! REGISTER MNEMONIC
%IF BASE=M'PR' %AND DISP>=65536 %THEN PRINT NAME(DISP-65536) %C
%ELSE %START
PMN(BASE) ;! BASE MNEMONIC
WRITE(DISP,1) ;! DISPLACEMENT
%FINISH
NEWLINE
CA=CA+1 ;! INCREMENT CURRENT ADDR
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
%ROUTINE PMN(%INTEGER I)
! PRINT MNEMONIC - CHARS INTO ONE WORD
%INTEGER J,K,L
J=2 ;! AT LEAST TWO SPACES
K=24 ;! FIRST SHIFT VALUE
1: L=I>>K&255 ;! UNPACK NEXT CHARACTER
%IF L=0 %THEN J=J+1 %ELSE PRINT SYMBOL(L)
K=K-8 ;! NEXT SHIFT VALUE
%IF K>=0 %THEN ->1 ;! MORE CHARS POSSIBLY YET
%IF I=M'BT' %OR I=M'CT' %OR I=M'PR' %OR I=M'ST' %THEN %C
PRINT SYMBOL('+') %ELSE %START
PRINT SYMBOL(',')
SPACES(J) ;! TO ALLIGN FIELDS
%FINISH
%END
%END
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE FAULT(%INTEGER A,B,C,D)
! MONITOR FAULT - A 'PRINT STRING' ROUTINE
OUT(A)
OUT(B)
OUT(C)
OUT(D)
NEWLINE
FAULTS=FAULTS+1 ;! INCREMENT FAULT COUNT
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE OUT(%INTEGER I)
! PRINT OUT PACKED CHARS
PRINT SYMBOL(I>>24)
PRINT SYMBOL(I>>16&255)
PRINT SYMBOL(I>>8&255)
PRINT SYMBOL(I&255)
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%INTEGERFN CH NEXT
! ALLOCATE NEXT POSITION IN 'CH' ARRAY
%IF CHP>512 %THEN %START ;! CHARACTER ARRAY FULL
FAULT(M'NAME',M'S TO',M'O LO',M'NG ')
%STOP ; %FINISH
CHP=CHP+1
%RESULT=CHP-1
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%INTEGERFN NEWCELL
! ALLOCATE NEW CELL FOR LIST PROCESSING
%INTEGER I
%IF ASL=0 %THEN %START ;! END OF AVAILABLE SPACE LIST
FAULT(M'ASL ',M'EMPT',M'Y ',M' ')
%STOP ; %FINISH
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 PRINT LABEL(%INTEGER I)
! PRINT PACKED LABEL NAME
PRINT SYMBOL('.')
OUT(I)
PRINT SYMBOL(':')
NEWLINE
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ROUTINE SHOW TAGS
! DISPLAY TAGS OF NAMES IN SCOPE
%INTEGER I,J,K,L,M
I=0 ;! EXAMINE TAGS FROM 0 UP
1: %IF CHL(I)=0 %THEN ->2 ;! NO NAME WITH IDENTIFICATION
NEWLINE
WRITE(I,10) ;! IDENT NO
SPACES(4)
PRINT NAME(I)
NEWLINE
J=TAGL(I) ;! POINTER TO NAME TAGS
%IF J=0 %THEN ->2 ;! IN CASE NO TAG SET UP
SPACES(11)
7: SPACES(4)
K=TAG(J) ;! FIRST TAGS WORD
L=28 ;! FIRST SHIFT VALUE
6: M=K>>L&15 ;! NEXT HEX DIGIT
%IF M<10 %THEN PRINT SYMBOL(M+'0') %ELSE PRINT SYMBOL(M+'A'-10)
L=L-4 ;! NEXT SHIFT
%IF L>=0 %THEN ->6 ;! MORE DIGITS IN THIS WORD
J=LINK(J) ;! POINTER TO NEXT CELL
%IF J\=0 %THEN ->7 ;! MORE CELLS
2: I=I+1
%IF I<=255 %THEN ->1 ;! MORE NAMES TO CONSIDER
NEWLINES(2)
%END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
%ENDOFPROGRAM