ROUTINESPEC READ SYMBOL(INTEGERNAME I)
INTEGERFNSPEC NEXT SYMBOL
ROUTINESPEC SKIP SYMBOL
ROUTINESPEC PRINT SYMBOL(INTEGER I)
ROUTINESPEC READ(INTEGERNAME I)
ROUTINESPEC WRITE(INTEGER I,J)
ROUTINESPEC SPACE
ROUTINESPEC SPACES(INTEGER I)
ROUTINESPEC NEWLINE
ROUTINESPEC NEWLINES(INTEGER I)
ROUTINESPEC NEWPAGE
BEGIN
ROUTINESPEC READ PS
ROUTINESPEC READ LINE
INTEGERFNSPEC COMPARE
ROUTINESPEC SS
ROUTINESPEC FAULT(INTEGER A,B,C,D)
INTEGERFNSPEC CHNEXT
INTEGERFNSPEC NEWCELL
INTEGERFNSPEC RETURN CELL(INTEGER I)
ROUTINESPEC PRINT NAME(INTEGER I)
INTEGER AP,APP,TP,PSP,ASL,BTN,CTN,CHP,FAULTS,LEVEL,CA,COMP,SCF
INTEGERARRAY PS(-1000:-600) ; ! REDUCED PHRASE STRUCTURE
INTEGERARRAY TAG,LINK(0:1023) ; ! TAGS LISTS
INTEGERARRAY A(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,CHPP,START,RAD(0:15) ; ! LEVEL INFORMATION
INTEGERARRAY TRUE,FALSE(1:6) ; ! CONDITIONAL BRANCH INSTRUCTIONS
INTEGERARRAY PREC,UCN(1:12) ; ! OPERATOR PRECEDENCES, TYPES
INTEGERARRAY OPR(0:12) ; ! MACHINE OPERATIONS
INTEGERARRAY PT,PN,PTC(1:15) ; ! FOR RT SPECS, HEADINGS
READ PS ;! READ IN AND REDUCE PHRASE STRUCTURE
ASL=0 ;! CLEAR HASHING AREA &
10: TAG(ASL)=0 ;! CREATE AVAILABLE SPACE LIST
LINK(ASL)=0 ;! IN REMAINDER
IF ASL>=256 AND ASL<1023 THEN LINK(ASL)=ASL+1
ASL=ASL+1
IF ASL<=1023 THEN ->10
ASL=256 ;! AVAILABLE SPACE LIST POINTER
BR(0)=M'BR0' ;! BASE REGISTER MNEMONICS
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'
TRUE(1)=M'BZ' ;! CONDITIONAL BRANCH MNEMONICS
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'
PREC(1)=3 ;! OPERATOR PRECEDENCES
PREC(2)=3 ;! 4 : HIGHEST
PREC(3)=2 ;! 1 : LOWEST
PREC(4)=1
PREC(5)=1
PREC(6)=3
PREC(7)=2
PREC(8)=2
PREC(9)=1
PREC(10)=1
PREC(11)=1
PREC(12)=4
OPR(0)=M'LOAD' ;! MACHINE INSTRUCTION MNEMONICS
OPR(1)=M'SHL'
OPR(2)=M'SHR'
OPR(3)=M'AND'
OPR(4)=M'XOR'
OPR(5)=M'OR'
OPR(6)=M'EXP'
OPR(7)=M'DIV'
OPR(8)=M'MLT'
OPR(9)=M'ADD'
OPR(10)=M'SUB'
OPR(11)=M'NEG'
OPR(12)=M'NOT'
UCN(1)=3 ;! OPERATOR TYPES
UCN(2)=3 ;! 1 : UNARY
UCN(3)=2 ;! 2 : BINARY COMMUTATIVE
UCN(3)=2 ;! 3 : BINARY NON-COMMUTATIVE
UCN(4)=2
UCN(5)=2
UCN(6)=3
UCN(7)=3
UCN(8)=2
UCN(9)=2
UCN(10)=3
UCN(11)=1
UCN(12)=1
BTN=0 ;! BRANCH TABLE POINTER
CTN=0 ;! CONSTANT TABLE POINTER
CHP=1 ;! NAME CHARACTER TABLE POINTER
FAULTS=0 ;! FAULT COUNT
LEVEL=0 ;! TEXTUAL LEVEL
SCF=0 ;! CONDITION FLAG
JUMP(0)=0 ;! JUMP LIST POINTER
STAR(0)=0 ;! STORAGE ALLOCATION POSITION IN COT
NAME(0)=0 ;! NAME LIST POINTER
RTP(0)=-1 ;! ROUTINE TYPE
CHPP(0)=0 ;! NAME CHARACTER TABLE POSITION
START(0)=0 ;! START/FINISH LIST
RAD(0)=10 ;! NEXT RELATIVE ADDRESS TO BE ALLOCATED
CA=0 ;! CURRENT CODE DUMPING ADDRESS
PRINT SYMBOL('P')
PRINT SYMBOL('R')
PRINT SYMBOL('G')
PRINT SYMBOL(':')
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
1: READ LINE
TP=1 ;! TEXT POINTER
2: IF T(TP)='!' THEN ->3 ; ! COMMENT - SKIP TO END
PSP=-1000 ;! START OF <SS> IN PHRASE STRUCTURE TABLES
AP=1
IF COMPARE=1 THEN START ; ! SUCCESSFUL ANALYSIS
AP=1 ;! ANALYSIS RECORD POINTER
SS ;! PROCESS SOURCE STATEMENT
IF T(TP-1)=';' THEN ->2 ; ! FURTHER STATEMENT ON THIS LINE
->1 ; FINISH ; ! GO TO READ NEXT LINE
FAULT(M'SYNT',M'AX ?',M' ',M' ') ;! UNSUCCESSFUL ANALYSIS
5: IF T(TP)=10 THEN ->1 ; ! NEWLINE - READ NEXT LINE
IF T(TP)=';' THEN START ; ! END OF STATEMENT
TP=TP+1 ;! TP TO START OF NEXT STATEMENT
->2 ; FINISH ; ! GO TO EXAMINE NEXT STATEMENT
3: TP=TP+1 ;! SKIP TO NEXT CHARACTER OF STATEMENT
->5
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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 TO START OF PHRASES IN PS
ROUTINESPEC INSERT LIT
INTEGERFNSPEC GET PN
PNP=256 ;! PN POINTER
P=-1000 ;! PS POINTER
1: READ SYMBOL(I)
IF I='B' THEN START ; ! BUILT-IN PHRASE
2: READ SYMBOL(I) ;! SKIP TO <
IF I¬='<' THEN ->2
J=GET PN ;! READ PHRASE NAME & GET POSITION IN PSP
3: READ SYMBOL(I) ;! SKIP TO =
IF I¬='=' THEN ->3
READ(K) ;! READ PHRASE NUMBER
PSP(J)=K ;! FILL IN PHRASE NUMBER
->1 ; FINISH ; ! GO TO DEAL WITH NEXT PHRASE
IF I='P' THEN START ; ! PHRASE
4: READ SYMBOL(I) ;! SKIP TO <
IF I¬='<' THEN ->4
PSP(GET PN)=P ;! READ PHRASE NAME & FILL IN PS POSITION
7: ALT=P ;! REMEMBER START POSITION IN PS OF THIS ALTERNATIVE
6: P=P+1 ;! NEXT PS POSITION
5: READ SYMBOL(I) ;! START OF NEXT ITEM IN THIS ALTERNATIVE
IF I='''' THEN START ; ! LITERAL TEXT
INSERT LIT ;! READ LITERAL & INSERT IN PS
->5 ; FINISH ; ! GO FOR NEXT ITEM
IF I='<' THEN START ; ! ITEM IS A PHRASE NAME
PS(P)=GET PN ;! READ PHRASE NAME & FILL IN PS WITH PSP POSITION
->6 ; FINISH ; ! GO FOR NEXT ITEM
IF I=',' THEN START ; ! END OF THIS ALTERNATIVE
PS(ALT)=P ;! FILL IN POINTER TO END OF ALTERNATIVE
->7 ; FINISH ; ! GO FOR START OF NEXT ALTERNATIVE
IF I=';' THEN START ; ! END OF PHRASE DEFINITION
PS(ALT)=P ;! FILL IN POINTER TO END OF ALTERNATIVE
PS(P)=0 ;! FILL IN END OF PHRASE MARKER
P=P+1 ;! NEXT PS POSITION FOR START OF NEXT PHRASE DEFINITION
->1 ; FINISH ; ! GO FOR NEXT PHRASE
->5 ; FINISH ; ! SKIP TO SOMETHING SIGNIFICANT
IF I='E' THEN START ; ! END OF PHRASE STRUCTURE DEFINITIONS
I=-1000 ;! REPLACE ALL POINTERS TO PSP WITH CORRECT PS POINTERS
8: IF PS(I)>=256 THEN PS(I)=PSP(PS(I))
I=I+1
IF I¬=P THEN ->8
RETURN ; FINISH
->1 ;! SKIP TO SOMETHING SIGNIFICANT
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
ROUTINE INSERT LIT
! INSERT LITERAL TEXT INTO 'PS'
INTEGER SH,I
SH=0 ;! % SHIFT VALUE TO 0
1: READ SYMBOL(I)
IF I='''' THEN START
IF NEXT SYMBOL¬='''' THEN RETURN ; ! END OF LITERAL
READ SYMBOL(I) ;! QUOTE INSIDE LITERAL - IGNORE ONE
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 VALUE TO 0
PS(P)=I+SH ;! STORE SHIFTED (POSSIBLY) CHAR IN PS
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,S,I
NP=0 ;! TO ACCUMULATE PHRASE NAME CHARS
S=24 ;! INITIAL SHIFT VALUE TO PACK CHARS
1: READ SYMBOL(I)
IF I¬='>' THEN START ; ! NOT END OF NAME YET
NP=NP!I<<S ;! PACK NEXT CHAR OF PHRASE NAME
S=S-8 ;! REDUCE SHIFT VALUE FOR NEXT CHAR
->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)=99999 ;! 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)
PRINT SYMBOL(';')
SH=0 ;! % & LITERAL SHIFT VALUE TO 0
TP=1 ;! POINTER TO TEXT ARRAY T
1: READ SYMBOL(I)
IF I=10 AND TP=1 THEN ->1
PRINT SYMBOL(I)
IF I='''' THEN START
SH=128 ;! SHIFT VALUE FOR LITERAL
2: STORE(I) ;! STORE SHIFTED CHAR IN TEXT ARRAY
READ SYMBOL(I)
PRINT SYMBOL(I)
IF I=10 THEN PRINT SYMBOL(';')
IF I¬='''' THEN ->2 ; ! NOT END OF LITERAL YET
READ SYMBOL(I)
PRINT SYMBOL(I)
IF I='''' THEN ->2 ; ! QUOTE IN LITERAL - IGNORE ONE
SH=0 ;! SHIFT VALUE TO 0 FOR END OF LITERAL
STORE('''') ;! STORE UNSHIFTED VALUE TO MARK END
FINISH
IF I='%' THEN SH=128 ELSE START ; ! SHIFT VALUE TO 128 FOR KEYWORD
IF I<'A' OR I>'Z' THEN SH=0 ; ! SHIFT VALUE TO 0 FOR END OF KEYWORD
IF I¬=' ' THEN START ; ! IGNORE SPACES
STORE(I)
IF I=10 THEN START ; ! NEWLINE CHAR
IF T(TP-2)='C'+128 THEN START
TP=TP-2
PRINT SYMBOL(';')
FINISH ELSE RETURN
FINISH
FINISH
FINISH
->1
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
ROUTINE STORE(INTEGER I)
! STORE (POSSIBLY) SHIFTED CHARACTER 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
! ANALYSE PHRASE
INTEGERFNSPEC NAME ; ! BUILT-IN PHRASE NAME
INTEGERFNSPEC CNST ; ! BUILT-IN PHRASE <CNST>
INTEGER APP,TPP,PSPP,AE,N
TPP=TP ;! PRESERVE INITIAL TEXT POINTER
APP=AP ;! PRESERVE INITIAL ANALYSIS RECORD
A(AP)=1 ;! ALTERNATIVE 1 FIRST
11: AE=PS(PSP) ;! POINTER TO END OF ALTERNATIVE
PSP=PSP+1 ;! FIRST ITEM OF ALTERNATIVE DEFN
12: IF PSP=AE THEN RESULT=1 ; ! END OF ALT REACHED - SUCCESS
N=PS(PSP) ;! NEXT ITEM OF ALT DEFN
PSP=PSP+1 ;! FOR FOLLOWING ITEM
IF N<0 THEN START ; ! SUB-PHRASE
PSPP=PSP ;! PRESERVE PS POINTER
PSP=N ;! POINTER TO DEFN OF SUB-PHRASE
AP=AP+1 ;! NEXT ANALYSIS RECORD POSITION
N=COMPARE ;! RECURSIVE COMPARISON FOR SUB-PHRASE
PSP=PSPP ;! RESTORE PS POINTER
IF N=1 THEN ->12 ; ! SUCCESSFUL COMPARISON - GO FOR NEXT ITEM
->13 ; FINISH ; ! UNSUCCESSFUL - GO FOR NEXT ALTERNATIVE
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 ALTERNATIVE
TP=TPP ;! BACKTRACK SOURCE TEXT
AP=APP ;! AND ANALYSIS RECORD POINTERS
A(AP)=A(AP)+1 ;! COUNT ALTERNATIVE NUMBER ON ONE
->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)=''''+128) THENRESULT=0
;! FAILURE - NOT A LETTER OR AN M-TYPE CONSTANT
J=CHP ;! NEXT POSITION IN CHARACTER ARRAY
K=I<<16 ;! LEAVE HOLE FOR LENGTH & PACK FIRST CHAR
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 IN CHAR ARRAY
CH(J)=CH(J)!L<<24 ;! FILL IN LENGTH IN HOLE LEFT IN FIRST WORD
I=(N&15)<<4!N>>4&15 ;! HASH VALUE
K=I ;! SCAN DICTIONARY FOR NAME
2: IF TAG(K)¬=0 THEN START ; ! A NAME IN THIS POSITION
L=TAG(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 ALREADY 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 DICTIONARY POSITION
IF K=I THEN START ; ! STARTING POSITION REACHED AGAIN
FAULT(M'DICT',M'IONA',M'RY F',M'ULL ')
STOP ; FINISH
->2 ; FINISH
TAG(K)=J ;! STORE CHAR ARRAY POSITION OF NAME
3: AP=AP+1 ;! NEXT ANALYSIS RECORD POSITION
A(AP)=K ;! STORE IDENTIFICATION NO OF NAME
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)=''''+128 THEN START ; ! M-TYPE CONSTANT
TP=TP+1 ;! IGNORE THE M
I=T(TP)
FINISH
IF I=''''+128 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¬='''' THEN START ; ! NOT END OF LITERAL
J=J<<8!I&127 ;! 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
3: J=10*J+I-'0' ;! ACCUMULATE DECIMAL VALUE
TP=TP+1
I=T(TP) ;! NEXT CHAR
IF '0'<=I AND I<='9' THEN ->3 ; ! A DIGIT - STILL PART OF CONSTANT
2: AP=AP+1 ;! NEXT ANALYSIS RECORD POSITION
A(AP)=J ;! FILL IN VALUE OF CONSTANT
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 NAME,FORM,TYPE,DIM,LEV,AD)
ROUTINESPEC DUMP(INTEGER OP,REG,BASE,DISP)
ROUTINESPEC SKIP SEXPR
ROUTINESPEC SKIP APP
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>
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! UI
10: UI ;! COMPILE UNCONDITIONAL INSTRUCTION
RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %IF . . . %THEN . . . %ELSE
20: SCCOND(I) ;! COMPILE CONDITION
IF A(AP)=2 THEN START ; ! AP ON <UI> - JUMP INSTRUCTION
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 UNCOND. INSTNS.
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 <UI>
DUMP('B',0,M'BT',J)
FINISH
IF I>=0 THEN BAT(I)=CA ; ! FILL IN LABEL ON <ELSE>-CLAUSE <UI>
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 LIST
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 LABEL
RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %FINISH . . .
40: I=START(LEVEL) ;! LINK TO FIRST CELL IN START LIST
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 OR AFTER %ELSE MARKER
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 !',M' ')
K=BT NEXT ;! JUMP AROUND <UI>
DUMP('B',0,M'BT',K)
IF J¬=65535 THEN BAT(J)=CA ; ! FILL IN LABEL ON <UI> IF NECESSARY
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 LABEL IF NECESSARY
RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! DECLARATIONS
50: IF A(AP)=1 THEN START ; ! <ARR> = %ARRAY
APP=AP ;! SAVE AP
51: AP=AP+2 ;! AP ON <NAMS>
IF A(AP)=1 THEN ->51 ; ! SKIP DOWN TO END OF LIST OF NAMES
AP=AP+1 ;! AP ON <+-¬>
SEXPR ;! COMPILE EXPRESSION - LOWER BOUND
DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT) ;! STORE VALUE IN WORKSPACE
SEXPR ;! COMPILE EXPRESSION - UPPER BOUND
DUMP(M'LDA',M'ACC',M'ACC',1) ;! INCREMENT VALUE BY 1
IF A(AP)=1 THEN START ; ! 2-DIM ARRAYS
DUMP(M'SUB',M'ACC',BR(LEVEL),WS-1) ;! PERFORM 2-DIM ARRAY DECLARATION CALCULATIONS
DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT)
AP=AP+1
SEXPR ;! LOWER BOUND EXPR FOR 2ND DIM
DUMP(M'MLT',M'ACC',BR(LEVEL),WS-1)
DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT)
SEXPR ;! UPPER BOUND EXPR FOR 2ND DIM
DUMP(M'LDA',M'ACC',M'ACC',1)
DUMP(M'MLT',M'ACC',BR(LEVEL),WS-2)
DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT)
WS=WS-4 ;! RESTORE WORKSPACE POINTER
I=2 ;! NO OF DIMS
FINISH ELSE START ; ! 1-DIM ARRAYS
DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT)
WS=WS-2 ;! RESTORE WORKSPACE POINTER
I=1 ;! NO OF DIMS
FINISH
J=2 ;! TAG FOR 'ARRAY'
AP=APP ;! RESTORE AP TO BEFORE LIST OF NAMES
FINISH ELSE START ; ! SCALAR DECLARATIONS
I=0 ;! DIMS=0 FOR SCALARS
J=0 ;! TAG FOR SCALAR
FINISH
52: STORE TAG(A(AP+1),J,1,I,LEVEL,RAD(LEVEL)) ;! PUSHDOWN TAG FOR THIS NAME
IF I=0 THEN RAD(LEVEL)=RAD(LEVEL)+1 ELSE START; ! ONE RELATIVE LOCATION FOR SCALARS
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 ELSE START ; ! 2-DIM ARRAYS
DUMP(M'LOAD',M'ACC',BR(LEVEL),WS+1)
DUMP(M'STR',M'ACC',BR(LEVEL),RAD(LEVEL))
DUMP(M'SUB',M'STP',BR(LEVEL),WS+2)
DUMP(M'LDA',M'ACC',M'STP',0)
DUMP(M'SUB',M'ACC',BR(LEVEL),WS)
DUMP(M'STR',M'ACC',BR(LEVEL),RAD(LEVEL)+1)
DUMP(M'ADD',M'STP',BR(LEVEL),WS+3)
FINISH
RAD(LEVEL)=RAD(LEVEL)+2 ;! 2 RELATIVE LOCATIONS FOR ARRAYS
FINISH
AP=AP+2 ;! AP ON <NAMS>
IF A(AP)=1 THEN ->52 ; ! MORE NAMES IN LIST OF NAMES
RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! RT SPEC? . . .
60: I=A(AP)-1 ;! ROUTINE/FN
J=A(AP+1) ;! SPEC ?
K=A(AP+2) ;! NAME OF ROUTIINE OR FN
AP=AP+3 ;! AP ON <FPP>
L=0 ;! PARAMETER COUNT
M=10 ;! FIRST RELATIVE ADDRESS TO BE ALLOCATED
63: IF A(AP)=1 THEN START ; ! PARAMETERS PRESENT
AP=AP+1 ;! AP ON <ARRN>
IF A(AP)=1 THEN N=3 ELSE N=3-A(AP) ; ! SET TAG FOR PARAMETER FORM
P=N<<28!1<<24!(LEVEL+1)<<16 ;! SET UP PATTERN FOR WHOLE TAG
62: L=L+1 ;! PARAMETER COUNT
IF L>15 THEN START
FAULT(M'TOO ',M'MANY',M' PAR',M'AMS ')
->61 ; FINISH ; ! IGNORE SUPERFLUOUS PARAMS
PT(L)=P!M ;! STORE TAG FOR THIS PARAM
PN(L)=A(AP+1) ;! STORE THE NAMES IDENT. NO
IF N=3 THEN M=M+2 ELSE M=M+1 ; ! NEXT RELATIVE ADDRESS
AP=AP+2 ;! AP ON <NAMS>
IF A(AP)=1 THEN ->62 ; ! MORE NAMES IN LIST
AP=AP+1 ;! AP ON <FPS>
->63 ; FINISH
61: N=LINK(K) ;! LINK TO TAG FOR NAME OF ROUTINE OR FN
IF N=0 OR TAG(N)>>16&15<LEVEL THEN START ; ! NAME NOT SET OR SET AT LOWER LEVEL
IF L>0 THEN START ; ! PARAMETERS PRESENT
P=1 ;! PARAMETER COUNT
Q=K ;! 'INSERT AFTER' POINTER
64: R=NEWCELL ;! PUSHDOWN TAG FOR PARAMETER
TAG(R)=PT(P)
LINK(R)=LINK(Q)
PTC(P)=R ;! SAVE POINTER TO TAG CELL
LINK(Q)=R
Q=R ;! NEW VALUE FOR 'INSERT AFTER' POINTER
P=P+1 ;! PARAMETER COUNT
IF P<=L THEN ->64 ; ! MORE PARAMETERS YET
FINISH
STORE TAG(K,4,I,L,LEVEL,BT NEXT) ;! PUSHDOWN TAG FOR NAME OF ROUTINE OR FN
IF LEVEL=0 THEN BAT(BTN-1)=K+65536 ; ! FLAG FOR EXTERNAL SPECS
FINISH ELSE START ; ! NAME ALREADY SET AT THIS LEVEL
IF J=2 AND TAG(N)>>28=4 THEN START ; ! STATEMENT NOT A SPEC & FORM OF NAME IS RT
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 IN SPEC
IF L¬=P THEN START
FAULT(M'PARS',M' NOT',M' AS ',M'SPEC')
IF L>P THEN L=P ; ! IGNORE SUPERFLUOUS PARAMS
FINISH
IF L>0 THEN START ; ! PARAMS PRESENT
P=1 ;! PARAM COUNT
Q=LINK(N) ;! LINK TO TAG OF FIRST PARAM
67: IF PT(P)!TAG(Q)&15<<20¬=TAG(Q) THEN START
PRINT NAME(PN(P))
FAULT(M'PAR ',M'NOT ',M'AS S',M'PEC ')
FINISH
PTC(P)=Q ;! SAVE POINTER TO TAG CELL
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
68: IF J=2 THEN START ; ! STATEMENT NOT A SPEC
BRT(LEVEL)=BT NEXT ;! BRANCH ROUND ROUTINE OR FN
DUMP('B',0,M'BT',BRT(LEVEL))
BAT(TAG(LINK(K))&65535)=CA ;! FILL IN ADDRESS OF THIS ROUTINE OR FN
IF LEVEL=15 THEN FAULT(M'TOO ',M'MANY',M' LEV',M'ELS ') C
ELSE LEVEL=LEVEL+1 ; ! NEXT TEXTUAL LEVEL
ENTER(I,M)
IF L>0 THEN START ; ! PARAMS PRESENT
P=1 ;! PARAM COUNT
69: I=PT(P) ;! PUSHDOWN TAGS FOR PARAMS
IF I>>28=3 THEN STORE TAG(PN(P),3,1,0,LEVEL,PTC(P)) C
ELSE STORE TAG(PN(P),I>>28,1,0,LEVEL,I&65535) ; ! TREAT ARRAYNAMES SPECIALLY
P=P+1
IF P<=L THEN ->69 ; ! MORE PARAMS YET
FINISH
FINISH
RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %END
70: CHECK ;! CHECK LABELS & START/FINISH BLOCKS
COT(STAR(LEVEL))=RAD(LEVEL) ;! STORE STATIC ALLOCATION FOR THIS LEVEL
UNSET ;! UNSET NAMES DECLARED AT THIS LEVEL
CHP=CHPP(LEVEL)
IF RTP(LEVEL)¬=0 THEN DUMP(M'STOP',0,0,0) ; ! %STOP FOR FNS
RETURN ;! DUMP %RETURN CODE
LEVEL=LEVEL-1 ;! DECREMENT TEXTUAL LEVEL COUNT
IF LEVEL<1 THEN START ; ! NOT BACK AT OUTER LEVEL YET
FAULT(M'EXCE',M'SS %',M'END ',M' ')
->71 ; FINISH ; ! TREAT AS %ENDOFPROGRAM
BAT(BRT(LEVEL))=CA ;! FILL ADDR FOR BRANCH ROUND ROUTINE/FN
RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %BEGIN
80: IF LEVEL¬=0 THEN START
FAULT(M'%BEG',M'IN E',M'XTRA',M' ') ;! NO INTERNAL BLOCKS ALLOWED
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: CHECK ;! CHECK LABELS & START/FINISHES
COT(STAR(LEVEL))=RAD(LEVEL) ;! FILL IN STATIC ALLOCATION FOR OUTER BLOCK
UNSET ;! UNSET NAMES DECLARED AT THIS LEVEL
IF LEVEL¬=1 THEN FAULT(M'TOO ',M'FEW ',M'%END',M'S ')
71: DUMP(M'STOP',0,0,0) ;! %STOP
PRINT SYMBOL('B') ;! PRINT OUT BRANCH TABLE
PRINT SYMBOL('T')
PRINT SYMBOL(':')
NEWLINE
CA=0
93: IF CA¬=BTN THEN START
DUMP('B',0,M'PRG',BAT(CA)) ;! BRANCH RELATIVE TO START OF PROGRAM
->93 ; FINISH
PRINT SYMBOL('C') ;! PRINT OUT CONSTANT TABLE
PRINT SYMBOL('T')
PRINT SYMBOL(':')
NEWLINE
I=0
91: IF I¬=CTN THEN START
WRITE(COT(I),10)
NEWLINE
I=I+1
->91 ; FINISH
PRINT SYMBOL(';')
WRITE(FAULTS,1) ;! NUMBER OF PROGRAM FAULTS
FAULT(M' FAU',M'LTS ',M'IN P',M'ROGM')
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 STATEMENT
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=LINK(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 TO AVOID DIAGNOSTICS
J=AP ;! PRESERVE ANALYSIS RECORD POINTER
AP=AP+1 ;! AP ON <APP>
SKIP APP ;! SKIP TO <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 FURTHER DIAGNOSTIC
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 INITIALANAL REC POINTER
ARRAD ;! CALCULATE ARRAY ELEMENT ADDRESS
WS=WS-1 ;! RESTORE WORKSPACE POINTER
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 AFTER <UI>
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
PRINT SYMBOL('B') ;! PRINT OUT BRANCH TABLE
PRINT SYMBOL('T')
PRINT SYMBOL(':')
NEWLINE
CA=0
93: IF CA¬=BTN THEN START
DUMP('B',0,M'PRG',BAT(CA)) ;! BRANCH RELATIVE TO START OF PROGRAM
->93 ; FINISH
PRINT SYMBOL('C') ;! PRINT OUT CONSTANT TABLE
PRINT SYMBOL('T')
PRINT SYMBOL(':')
NEWLINE
I=0
91: IF I¬=CTN THEN START
WRITE(COT(I),10)
NEWLINE
I=I+1
->91 ; FINISH
PRINT SYMBOL(';')
WRITE(FAULTS,1) ;! NUMBER OF PROGRAM FAULTS
FAULT(M' FAU',M'LTS ',M'IN P',M'ROGM')
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 STATEMENT
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=LINK(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 TO AVOID DIAGNOSTICS
J=AP ;! PRESERVE ANALYSIS RECORD POINTER
AP=AP+1 ;! AP ON <APP>
SKIP APP ;! SKIP TO <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 FURTHER DIAGNOSTIC
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 INITIALANAL REC POINTER
ARRAD ;! CALCULATE ARRAY ELEMENT ADDRESS
WS=WS-1 ;! RESTORE WORKSPACE POINTER
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 AFTER <UI>
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 AND DUMP JUMP
RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %START
30: FAULT(M'%STA',M'RT ?',M' ',M' ') ;! %START ALONE SHOULD NOT BE A SOURCE STATEMENT
RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %RETURN
40: IF RTP(LEVEL)¬=0 THEN FAULT(M'%RET',M'URN ',M'CONT',M'EXT ')
RETURN ;! DUMP %RETURN CODE - INCORRECT FOR FN
RETURN
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
! %RESULT=
50: I=RTP(LEVEL) ;! ROUTINE/FN TYPE
IF I<=0 THEN FAULT(M'%RES',M'ULT ',M'CONT',M'EXT ') ; ! %BEGIN/%ROUTINE
SEXPR ;! COMPILE RESULT EXPRESSION
RETURN ;! LEAVE RESULT IN ACC & DUMP RETURN CODE
END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ROUTINE SEXPR
! COMPILE ARITHMETIC EXPRESSION
ROUTINESPEC TORP
ROUTINESPEC PSEVAL
ROUTINESPEC EVAL(INTEGER P)
INTEGER RPP,APP
INTEGERARRAY RP,PT(1:32) ; ! REVERSE POLISH, POINTER/TYPE ARRAYS
RPP=1 ;! RP POINTER
TORP ;! EXPR TO REV POLISH
IF SCF=1 THEN START ; ! PART OF A SIMPLE CONDITION
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 REVERSE POLISH
RP(RPP)=10 ;! CODE FOR '-' I.E. (1ST-2ND)
PT(RPP)=1 ;! FLAG=OPERATOR
RPP=RPP+1 ;! INCREMENT RP POINTER
FINISH
FINISH
APP=AP ;! SAVE FINAL ANAL REC POINTER
PSEVAL ;! PSEUDO-EVALUATE EXPRESSION
EVAL(RPP-1) ;! DUMP CODE FOR EXPR EVALUATION
AP=APP ;! RESTORE FINAL ANAL REC POINTER
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
ROUTINE TORP
! TRANSFORM EXPRESSION TO REVERSE POLISH
ROUTINESPEC STORE(INTEGER I,J)
INTEGERARRAY OP(1:4)
INTEGER OPP,I
OPP=0 ;! OPERATOR STACK POINTER
I=A(AP) ;! <+-¬>
AP=AP+1
IF I=1 OR I=4 THEN ->1 ; ! + OR NULL
I=I+9 ;! CODES FOR - & ¬
3: OPP=OPP+1 ;! STACK OPERATOR
OP(OPP)=I
1: I=A(AP) ;! <OPD>
IF I=3 THEN START ; ! SUB-EXPRESSION
AP=AP+1 ;! AP TO <+-¬>
TORP ;! TRANSFORM SUB-EXPR TO REV POL
FINISH ELSE START
STORE(AP,0) ;! STORE ANAL REC POSITION OF OPERAND
AP=AP+2 ;! AP ON <APP> OR AFTER <CNST>
IF I=1 THEN SKIP APP ; ! OPERAND A NAME
FINISH
IF A(AP)=2 THEN START ; ! END OF <EXPR>
AP=AP+1 ;! AP AFTER EXPRESSION
2: IF OPP=0 THEN RETURN ; ! OPERATOR STACK EMPTIED
STORE(OP(OPP),1) ;! UNSTACK REMAINING OPERATORS
OPP=OPP-1
->2 ; FINISH
I=A(AP+1) ;! <OP>
AP=AP+2 ;! AP ON <EXPR>
4: IF OPP=0 OR PREC(I)>PREC(OP(OPP)) THEN ->3 ; ! OP STACK EMPTY OR NEW OP HIGHER PREC
STORE(OP(OPP),1) ;! UNSTACK TOP OPERATOR
OPP=OPP-1
->4
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
ROUTINE STORE(INTEGER I,J)
! STORE IN RP & PT ARRAYS, I=ANAL REC PTR , J= OP/OPD FLAG
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
RP(RPP)=I ;! STORE OP/OPD
PT(RPP)=J ;! STORE FLAG
RPP=RPP+1 ;! NEXT POSITION
END
END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
ROUTINE PSEVAL
! PSEUDO-EVALUATION, CHECKING OPERANDS
INTEGERARRAY PST(1:32) ; ! OPERAND POINTER STACK
INTEGER PSTP,I,J,K
PSTP=0 ;! PST POINTER
I=1 ;! REV POL ARRAY POINTER
3: AP=RP(I) ;! ANAL REC POSITION OF OPERAND
IF A(AP)=1 THEN START ; ! OPERAND A NAME
J=LINK(A(AP+1)) ;! LINK TO TAG OF NAME
IF J=0 THEN START
PRINT NAME(A(AP+1))
FAULT(M'NAME',M' NOT',M' SET',0)
K=0 ;! DUMMY TAG VALUE
->1 ; FINISH
K=TAG(J) ;! TAG OF NAME
J=K>>28 ;! 'FORM' OF NAME
IF J>1 THEN START ; ! ARRAY OR ROUTINE/FN TYPE
RP(I)=AP+1 ;! STORE ANAL REC POSITION OF <NAME>
IF J=4 THEN START ; ! NAME IS ROUTINE/FN TYPE
IF K>>24&15=0 THEN START
PRINT NAME(A(AP+1))
FAULT(M'RT N',M'AME ',M'IN E',M'XPR ')
K=0 ;! DUMMY TAG VALUE
->1 ; FINISH
PT(I)=-1 ;! FLAG FOR FUNCTION
FINISH ELSE PT(I)=-2 ; ! FLAG FOR ARRAY
->2 ; FINISH ; ! GO TO STACK POINTER
IF A(AP+2)=1 THEN START
PRINT NAME(A(AP+1))
FAULT(M'SCAL',M'AR H',M'AS P',M'ARAM')
FINISH
1: RP(I)=K ;! STORE TAG OF NAME FOR SCALARS
PT(I)=-3 ;! FLAG FOR SCALARS
FINISH ELSE START ; ! OPERAND IS A <CNST>
RP(I)=A(AP+1) ;! STORE VALUE OF CONSTANT
PT(I)=-4 ;! FLAG FOR CONSTANTS
FINISH
2: PSTP=PSTP+1 ;! STACK OPERAND POINTER
4: PST(PSTP)=I
I=I+1 ;! REV POL ARRAY POINTER
IF I<RPP THEN START ; ! NOT END OF REV POL YET
IF PT(I)=0 THEN ->3 ; ! AN OPERAND IS NEXT
IF RP(I)<=10 THEN START ; ! BINARY OPERATORS
PSTP=PSTP-1 ;! PSEUDO-EVALUATE POINTERS
PT(I)=PST(PSTP) ;! STACK POINTER TO RESULT
FINISH
->4 ; FINISH
END
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
ROUTINE EVAL(INTEGER P)
! DUMP CODE FOR EVALUATION OF EXPRESSION
ROUTINESPEC OPN(INTEGER OP,L)
INTEGER I,J,K
I=PT(P) ;! POINTER/TYPE OF LAST REV POL ENTRY
IF I<0 THEN START ; ! OPERAND
OPN(0,P) ;! LOAD OPERAND
RETURN ; FINISH
J=RP(P) ;! OPERATOR
K=P-1 ;! START OF 2ND OPERAND
IF UCN(J)=1 THEN START ; ! UNARY OPERATOR
IF PT(K)>=-2 THEN EVAL(K) ELSE OPN(0,K) ; ! EVAL IF NODE OTHERWISE LOAD OPERAND
DUMP(OPR(J),M'ACC',0,0) ;! DUMP UNARY OPERATION
RETURN ; FINISH
IF PT(I)>=-2 THEN START ; ! FIRST OPERAND A NODE
IF PT(K)>=-2 THEN START ; ! SECOND OPERAND A NODE
EVAL(K) ;! EVALUATE 2ND OPERAND
DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT) ;! & STORE IT IN WORKSPACE
EVAL(I) ;! EVALUATE 1ST OPERAND
WS=WS-1 ;! RESTORE WORKSPACE POINTER
DUMP(OPR(J),M'ACC',BR(LEVEL),WS) ;! DUMP OPERATION
FINISH ELSE START ; ! 2ND OPERAND NOT A NODE
EVAL(I) ;! EVALUATE 1ST OPERAND
OPN(J,K) ;! OPERATION WITH 2ND OPERAND
FINISH
FINISH ELSE START ; ! 1ST OPERAND NOT A NODE
IF PT(K)>=-2 THEN START ; ! 2ND OPERAND A NODE
EVAL(K) ;! EVALUATE 2ND OPERAND
IF UCN(J)=2 THEN START ; ! OPERATOR IS COMMUTATIVE
OPN(J,I) ;! OPERATION WITH 1ST OPERAND
RETURN ; FINISH
DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT) ;! STORE VALUE OF 2ND OPERAND IN WORKSPACE
OPN(0,I) ;! LOAD 1ST OPERAND
WS=WS-1 ;! RESTORE WORKSPACE POINTER
DUMP(OPR(J),M'ACC',BR(LEVEL),WS) ;! DUMP OPERATION WITH 2ND OPERAND
FINISH ELSE START ; ! 2ND OPERAND NOT A NODE
OPN(0,I) ;! LOAD 1ST OPERAND
OPN(J,K) ;! OPERATION WITH 2ND OPERAND
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 OR NAME TAGS
IF I=-1 THEN START ; ! ROUTINE/FN TYPE
RT ;! DUMP CALL ON FUNCTION
RETURN ; FINISH
IF I=-2 THEN START ; ! ARRAY ACCESS
ARRAD ;! CALCULATE ARRAY ELEMENT ADDRESS
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 ; ! CONSTANT NOT 'LDA'-ABLE
J=CT NEXT ;! NEXT HOLE IN CONSTANT TABLE
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 SKIP SEXPR
! SKIP PAST <+-¬><OPD><EXPR> IN ANALYSIS RECORD, AP INITIALLY ON <+-¬>
1: AP=AP+2 ;! AP ON <OPD>+1
IF A(AP-1)=3 THEN SKIP SEXPR ELSE START ; ! SKIP SUB-EXPR ELSE <NAME> OR <CNST>
AP=AP+1 ;! AP ON <APP> OR AFTER <CNST>
IF A(AP-2)=1 THEN SKIP APP ; ! OPERAND IS A NAME
FINISH
AP=AP+1 ;! AP AFTER <EXPR>
IF A(AP-1)=1 THEN ->1 ; ! MORE OPERANDS
END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ROUTINE SKIP APP
! SKIP PAST <APP> IN ANALYSIS RECORD
1: AP=AP+1 ;! POINTER TO <APP>+1 OR <EXPS>+1
IF A(AP-1)=1 THEN START ; ! EXPRESSIONS TO SKIP
SKIP SEXPR
->1 ; FINISH
END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ROUTINE SCCOND(INTEGERNAME LABEL)
! COMPILE CONDITION I.E. <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 POINTERS, NESTING LEVEL,
;! TRUE/FALSE, JUMP & LABEL ARRAYS
I=1 ;! INDEX TO ARRAYS
L=0 ;! NESTING LEVEL
SC ;! PROCESS <SC>
COND ;! PROCESS <COND>
APP=AP ;! PRESERVE FINAL ANAL REC POINTER
L=-1
STORE(1) ;! PSEUDO-FALSE AT LEVEL -1
L=-2
STORE(2) ;! PSEUDO-TRUE AT LEVEL -2
K=I-1 ;! LAST POSITION FILLED IN IN ARRAYS
I=1
2: J=I ;! FIND POSITIONS TO JUMP TO
1: J=J+1 ;! AFTER COMPARISONS
IF LVL(J)>=LVL(I) OR TF(J)=TF(I) THEN ->1 ; ! SKIP HIGHER LEVELS ETC
JMP(I)=J ;! JUMP TO COMPARISON POSITION J
I=I+1
IF I<K THEN ->2 ; ! MORE JUMPS TO FILL IN YET
IF A(AP)¬=2 THEN ->3 ; ! UI NOT A JUMP INSTRUCTION
AP=AP+1 ;! TO <CONST>
J=K-1 ;! LAST POSITION FILLED IN
TF(J)=2 ;! SET AS 'TRUE'
JMP(J)=J ;! SET JUMP AS THE UI JUMP
LBL(J)=FIND LABEL ;! FILL IN BRANCH TABLE POSITION
3: I=1 ;! FILL IN PSEUDO-LABELS FOR INNER JUMPS
4: IF LBL(JMP(I))<0 THEN LBL(JMP(I))=BT NEXT ; ! NEXT BAT POSITION
I=I+1
IF I<K THEN ->4 ; ! MORE TO FILL IN
I=1
7: AP=CAP(I) ;! ANAL REC POINTER FOR 1ST EXPR OF COMP
SCF=1 ;! SET FLAG FOR SEXPR
SEXPR ;! TO EVALUATE (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 REQUIRED POSITION
IF LBL(I)>=0 AND (I¬=K-1 OR TF(I)=1) THEN BAT(LBL(I))=CA
I=I+1 ;! FILL IN LABEL ADDRESS
IF I<K THEN ->7 ; ! MORE COMPARISONS YET
LABEL=LBL(K) ;! FINAL LABEL
AP=APP ;! FINAL ANALYSIS RECORD POINTER
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
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 'LABEL NOT FILLED IN YET' FLAG
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 FOR SUB-CONDITION
SC ;! PROCESS SUB-<SC>
COND ;! PROCESS SUB-<COND>
L=L-1 ;! NESTING LEVEL DOWN AFTER SUB-CONDITION
FINISH ELSE START
CAP(I)=AP ;! ANAL REC POINTER FOR SIMPLE COMPARISON
SKIP SEXPR ;! SKIP 1ST EXPR OF COMPARISON
AP=AP+1 ;! SKIP COMPARATOR
SKIP SEXPR ;! SKIP 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 ALTERNATIVE OF <COND>
1: STORE(I) ;! SAVE %AND OR %OR TYPE OF CONDITION
SC ;! PROCESS <SC>
AP=AP+1 ;! POINTER ON <ANDC>+1 OR <ORC>+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 FOR THIS LEVEL
1: IF I¬=0 THEN START ; ! NO LABELS OR JUMPS USED AT THIS LEVEL
IF BAT(TAG(I)&65535)<0 THEN START ; ! LABEL SET INCORRECTLY
WRITE(TAG(I)>>16,1) ;! PRINT OUT LABEL NO OF LABEL NOT SET
FAULT(M' LAB',M'EL N',M'OT S',M'ET ')
FINISH
I=RETURN CELL(I) ;! RETURN JUMP LIST CELL TO ASL
->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 AT THIS LEVEL
J=TAG(I) ;! NAME IDENT NO
K=TAG(LINK(J)) ;! TAG WORD AT TOP OF LIST
LINK(J)=RETURN CELL(LINK(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
LINK(J)=RETURN CELL(LINK(J)) ;! POP UP CELLS
K=K-1 ;! PARAM COUNT
->2 ; FINISH
FINISH
IF LINK(J)=0 THEN TAG(J)=0 ; ! A PREVIOUS DECLARATION OF SAME NAME
I=RETURN CELL(I) ;! RETURN NAME LIST CELL
->1 ; FINISH
END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ROUTINE PUSH START(INTEGER FLAG,LABEL)
! PUSHDOWN START/FINISH BLOCK INFORMATION
INTEGER I
I=NEWCELL
TAG(I)=FLAG<<16!LABEL&65535 ;! 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
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 ALLOCATION HOLE IN CONST TABLE
DUMP(M'ADD',M'STP',M'CT',I)
STAR(LEVEL)=I ;! REMEMBER POSITION OF HOLE
JUMP(LEVEL)=0 ;! NO JUMPS AT NEW LEVEL YET
NAME(LEVEL)=0 ;! NO NAMES AT NEW LEVEL YET
RTP(LEVEL)=TYPE ;! BLOCK/ROUTINE/FN TYPE
CHPP(LEVEL)=CHP ;! SAVE CHARACTER ARRAY POINTER
START(LEVEL)=0 ;! NO START/FINISH BLOCKS YET
RAD(LEVEL)=ALLOC ;! NEXT RELATIVE ADDRESS TO BE ASSIGNED
END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ROUTINE RETURN
! DUMP CODE FOR %RETURN
DUMP(M'LDA',M'STP',BR(LEVEL),0) ;! RESTORE DIJKSTRA 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 RETURN ADDRESS
END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ROUTINE RT
! DUMP CODE FOR A ROUTINE OR FUNCTION CALL
INTEGER I,J,K,L,M,N,P
I=LINK(A(AP)) ;! LINK TO TAG FOR NAME
AP=AP+1 ;! AP ON <APP>
J=TAG(I) ;! TAG OF NAME
K=J>>20&15+1 ;! NO OF PARAMS +1
1: K=K-1 ;! COUNT PARAMS
AP=AP+1 ;! AP ON <APP>+1
IF A(AP-1)=2 THEN START ; ! PARAMS ABSENT OR NO MORE TO PROCESS
DUMP(M'BAL',M'WK',M'BT',J&65535) ;! DUMP BRANCH TO ROUTINE/FN
IF K>0 THEN FAULT(M'TOO ',M'FEW ',M'PARA',M'MS ')
RETURN ; FINISH
IF K<=0 THEN START ; ! MORE PARAMS THAN SPEC
IF K=0 THEN FAULT(M'TOO ',M'MANY',M' PAR',M'AMS ') ; ! ONLY MONITOR ONCE
->2 ; FINISH
I=LINK(I) ;! LINK TO NEXT PARAM CELL
L=TAG(I) ;! TAG OF PARAM
IF L>>28=0 THEN START ; ! SCALAR VALUE
SEXPR ;! COMPILE EXPRESSION
->3 ; FINISH
IF A(AP)=4 AND A(AP+1)=1 THEN ->4 ; ! <+-¬> IS NULL & <OPD> IS A NAME
5: FAULT(M'NOT ',M'A NA',M'ME P',M'ARAM')
2: SKIP SEXPR ;! SKIP INVALID PARAM TO CONTINUE
->1
4: M=LINK(A(AP+2)) ;! LINK TO TAG FOR PARAM NAME
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 PARAM NAME
IF L>>28=1 THEN START ; ! PARAM IS SCALAR NAME TYPE
IF N>>28=4 THEN START ; ! ACTUAL NAME IS ROUTINE/FN TYPE
PRINT NAME(A(AP+2))
->5 ; FINISH
IF N>>28>=2 THEN START ; ! ACTUAL NAME IS AN ARRAY
AP=AP+2 ;! AP ON <NAME>
ARRAD ;! CALCULATE ARRAY ELEMENT ADDRESS
AP=AP+1 ;! AP ON <EXPR>+1 - SHOULD BE <EXPS>
IF A(AP-1)=1 THEN ->5 ; ! FURTHER OPERAND - INVALID
->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 OPERANDS - INVALID
IF N>>28=1 THEN P=M'LOAD' ELSE P=M'LDA' ; ! LOAD FOR NAME TYPE & LDA FOR VALUE TYPE
DUMP(P,M'ACC',BR(N>>16&15),N&65535)
FINISH ELSE START ; ! PARAM IS ARRAY NAME
IF A(AP+3)¬=2 OR A(AP+4)¬=2 THEN ->5 ; ! <APP> NOT NULL OR MORE OPERANDS
IF N>>28&2=0 THEN START ; ! 'FORM' OF ACTUAL IS NOT ARRAY
PRINT NAME(A(AP+2))
FAULT(M'NOT ',M'AN A',M'RRAY',M' NME')
->2 ; FINISH
IF N>>28=3 THEN START ; ! ACTUAL IS ARRAY NAME
M=N&65535 ;! POINTER TO TAG CELL OF PARAM LIST
N=TAG(M) ;! CORRECT TAG FOR PARAM
FINISH
IF N>>20&15¬=L>>20&15 THEN START ; ! DIMENSIONS DIFFERENT
IF L>>20&15=0 THEN START ; ! FORMAL PARAM DIMENSION UNKNOWN
L=TAG(I)!N&15<<20 ;! FILL FORMAL TAG WITH DIMENSION
TAG(I)=L ;! OF ACTUAL PARAM
FINISH ELSE START ; ! DIMENSION OF FORMAL KNOWN
IF N>>20&15=0 THEN TAG(M)=TAG(M)!L&15<<20 ELSE START
;! FILL IN DIMENSION OF ACTUAL IF UNKNOWN
PRINT NAME(A(AP+2))
FAULT(M'ARRA',M'Y DI',M'MENS',M'ION?')
->2 ; FINISH
FINISH
FINISH
DUMP(M'LOAD',M'ACC',BR(N>>16&15),N&65535)
IF L>>20&15¬=1 THEN START ; ! NOT 1-DIM ARRAY
DUMP(M'STR',M'ACC',M'STP',L&65535)
DUMP(M'LOAD',M'ACC',BR(N>>16&15),N&65535+1)
L=L+1
FINISH
FINISH
AP=AP+5 ;! AP ON <EXPS>
3: DUMP(M'STR',M'ACC',M'STP',L&65535)
->1
END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ROUTINE ARRAD
! DUMP CODE TO CALCULATE ARRAY ELEMENT ADDRESS
INTEGER I,J,K,L
L=A(AP)
I=LINK(L) ;! LINK TO TAG FOR NAME OF ARRAY
J=TAG(I)
IF J>>28=3 THEN START ; ! NAME IS AN ARRAY NAME
I=J&65535 ;! SUBSTITUTE CORRECT TAG VALUE
J=TAG(I)
FINISH
AP=AP+2 ;! AP ON <APP>+1
IF A(AP-1)=1 THEN START ; ! INDEXES PRESENT
SEXPR ;! COMPILE EXPR FOR FIRST INDEX
AP=AP+1 ;! AP ON <EXPS>+1
IF A(AP-1)=1 THEN START ; ! 2ND INDEX PRESENT
DUMP(M'STR',M'ACC',BR(LEVEL),WS NEXT) ;! STORE 1ST INDEX IN WORKSPACE
SEXPR ;! COMPILE EXPR FOR 2ND INDEX
IF A(AP)=1 THEN START ; ! 3RD INDEX PRESENT
PRINT NAME(L)
FAULT(M'TOO ',M'MANY',M' IND',M'EXES')
SKIP APP ;! SKIP EXCESS INDEXES
FINISH ELSE AP=AP+1 ; ! AP AFTER EXPRESSION
DUMP(M'MLT',M'ACC',BR(J>>16&15),J&65535)
WS=WS-1 ;! RESTORE WORKSPACE POINTER
DUMP(M'ADD',M'ACC',BR(LEVEL),WS)
DUMP(M'ADD',M'ACC',BR(J>>16&15),J&65535+1)
K=2 ;! DIMENSION MARKER
FINISH ELSE START ; ! ONLY ONE INDEX PRESENT
DUMP(M'ADD',M'ACC',BR(J>>16&15),J&65535)
K=1 ;! DIMENSION MARKER
FINISH
IF K¬=J>>20&15 THEN START ; ! DIMS FOUND DO NOT AGREE WITH TAG
IF J>>20&15=0 THEN TAG(I)=TAG(I)!K<<20 ELSE C
PRINT NAME(L)
FAULT(M'ARRA',M'Y DI',M'MENS',M'ION?') ;! FILL IN DIMS IF UNKNOWN
FINISH
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 FOR ADDRESS NOT FILLED IN YET
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
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 IN
I=LINK(I) ;! NEXT CELL IN LIST
->1 ; FINISH
I=NEWCELL ;! LABEL NOT IN LIST SO GET NEW CELL
J=BT NEXT ;! GET NEXT BRANCH TABLE POSITION
TAG(I)=LABEL<<16!J ;! FILL IN LIST ENTRY
LINK(I)=JUMP(LEVEL) ;! PUSHDOWN ONTO JUMP LIST
JUMP(LEVEL)=I ;! NEW JUMP LIST POINTER
RESULT=J ; ! NEW BRANCH TABLE POSITION
END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ROUTINE STORE TAG(INTEGER NAM,FORM,TYPE,DIM,LEV,AD)
! STORE TAGS I.E. SET NAME & CHECK NOT SET ALREADY
INTEGER M,N
M=LINK(NAM) ;! POINTER TO EXISTING TAGS WORD FOR THIS
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)=LINK(NAM) ;! PUSHDOWN ONTO TAGS LIST FOR THIS NAME
LINK(NAM)=N
N=NEWCELL
TAG(N)=NAM ;! PUSHDOWN NEW CELL ONTO NAME LIST
LINK(N)=NAME(LEVEL) ;! FOR NAMES DECLARED AT THIS LEVEL
NAME(LEVEL)=N
END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ROUTINE DUMP(INTEGER OP,REG,BASE,DISP)
! PRINT OUT CURRENT ADDRESS, OPERATION MNEMONIC & OPERANDS
ROUTINESPEC PMN(INTEGER I)
INTEGER COM
SPACES(10)
COM=' '
PMN(OP) ;! OPERATOR MNEMONIC
COM=','
PMN(REG) ;! REGISTER MNEMONIC
IF DISP>=65536 THEN START
PRINT SYMBOL(',')
SPACES(7)
PRINT NAME(DISP-65536)
FINISH ELSE START
IF BASE=M'BT' OR BASE=M'CT' OR BASE=M'PRG' THEN START
PRINT SYMBOL(',')
SPACES(7)
FINISH
PMN(BASE) ;! BASE MNEMONIC
WRITE(DISP,1) ;! DISPLACEMENT
FINISH
NEWLINE
CA=CA+1 ;! INCREMENT CURRENT ADDRESS COUNT
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
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'PRG' THEN C
PRINT SYMBOL('+') ELSE START
PRINT SYMBOL(COM)
SPACES(J) ;! TO ALLIGN FIELDS CORRECTLY
FINISH
END
END
END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ROUTINE FAULT(INTEGER A,B,C,D)
! MONITOR FAULT - A 'PRINT STRING' ROUTINE
ROUTINESPEC OUT(INTEGER I)
OUT(A)
OUT(B)
OUT(C)
OUT(D)
NEWLINE
FAULTS=FAULTS+1 ;! INCREMENT FAULT COUNT
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
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
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 DOWN
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=TAG(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
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ENDOFPROGRAM