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