12330 (*+81() 12340 (**) 12350 (*+04() 12360 FUNCTION FLOAT(N: A68INT): REAL; 12370 BEGIN FLOAT := SHRINK(N) (*THIS IS SLOPPY*) END; 12380 ()+04*) 12390 (*+25() (*+31() (*$P+ +) ()+31+) ()+25*) 12400 (**) 12410 (**) 12420 (*LISTING*) 12430 (*********) 12440 (**) 12450 (*+05() 12460 PROCEDURE OPENLOADFILE(VAR F: LOADFILE; PARAM: INTEGER; WRITING: BOOLEAN); 12470 VAR S: ARGSTRING; 12480 PROCEDURE NAMEFILE(S: ARGSTRING; SU, SL: INTEGER; VAR F: ANYFILE); EXTERN; 12490 FUNCTION GETARG(VAR S: ARGSTRING; SU, SL: INTEGER; I: INTEGER): BOOLEAN; EXTERN; 12500 BEGIN 12510 IF GETARG(S, 50 ,1, PARAM) THEN 12520 NAMEFILE(S, 50, 1, F); 12530 IF WRITING THEN REWRITE(F) ELSE RESET(F); 12540 END; 12550 PROCEDURE OPENTEXT(VAR F: TEXT; PARAM: INTEGER; WRITING: BOOLEAN); 12560 VAR S: ARGSTRING; 12570 PROCEDURE NAMEFILE(S: ARGSTRING; SU, SL: INTEGER; VAR F: ANYFILE); EXTERN; 12580 FUNCTION GETARG(VAR S: ARGSTRING; SU, SL: INTEGER; I: INTEGER): BOOLEAN; EXTERN; 12590 BEGIN 12600 IF GETARG(S, 50, 1, PARAM) THEN 12610 NAMEFILE(S, 50, 1, F); 12620 IF WRITING THEN REWRITE(F) ELSE RESET(F); 12630 END; 12632 FUNCTION TIME: INTEGER; EXTERN; 12634 PROCEDURE CTIME(VAR RESULT: TIMSTRING; SU, SL: INTEGER; CLOCK: INTEGER); EXTERN; 12640 ()+05*) 12650 (**) 12660 (**) 12670 PROCEDURE CHECKPAGE; 12680 (*STARTS NEW PAGE IF LISTING IN PROGRESS AND OLD PAGE 12690 EXHAUSTED*) 12700 BEGIN 12710 IF LSTCNT>LINESPERPAGE THEN 12720 BEGIN 12730 LSTCNT := 0; 12740 IF PRGLIST IN PRAGFLGS THEN 12750 BEGIN 12760 LSTPAGE := LSTPAGE+1; 12770 IF ONLINE THEN 12780 BEGIN 12782 (*-01() IF LSTPAGE<>1 THEN PAGE(LSTFILE); ()-01*) 12790 WRITELN(LSTFILE, (*+01()'1',()+01*) 12800 'ALGOL68S COMPILER ',VERSIONNUM, 12810 (*-04() (*-02() (*-05()DAT, ' ',()-05*) TIM, ()-02*) ()-04*) ' PAGE ', LSTPAGE:3); 12820 WRITELN(LSTFILE (*+01(),' '()+01*)); 12830 END 12840 (*-02() (*-04() (*-05() 12850 ELSE (*BATCH*) 12860 BEGIN 12862 (*-01() IF LSTPAGE<>1 THEN PAGE(LSTFILE); ()-01*) 12870 WRITELN(OUTPUT, (*+01()'1',()+01*) 12880 'ALGOL68S COMPILER ',VERSIONNUM, 12890 DAT, ' ', TIM, ' PAGE ', LSTPAGE:3); 12900 WRITELN(OUTPUT, ' '); 12910 END 12920 ()-05*) ()-04*) ()-02*) 12930 END 12940 END; 12950 END; 12960 (**) 12970 (**) 12980 PROCEDURE INITIO; 12990 (*+01() VAR AW66: PW66; ()+01*) 13000 (*+05() TYPE STRING = PACKED ARRAY [1..12] OF CHAR; 13010 VAR S: STRING; 13020 ()+05*) 13030 BEGIN 13040 ERRDEV := FALSE; 13050 (*+23() NUMPARAMS:=0; (* TO COUNT NO OF P-OP PARAMETERS OUTPUT TO LSTFILE *) ()+23*) 13060 LSTLINE := -1; (*FOR FIRST TIME OF OUTSRC*) 13070 LSTCNT := 100; (*TO FORCE NEWPAGE*) 13080 LSTPAGE := 0; 13090 (*-03() (*-04() (*-05() 13100 RESET(SOURCDECS); 13110 REWRITE(LSTFILE); 13120 ()-05*) ()-04*) ()-03*) 13130 (*+03() 13140 WRITE('SOURCE-FILE: '); 13150 OPEN(SOURCDECS,'','SYMB',SEQRD); 13160 WRITE('LIST-FILE: '); 13170 OPEN(LSTFILE,'','DATA',SEQWR); 13180 OPEN(OUTPUT,'TERMINAL','SYMB',SEQWR); 13190 ()+03*) 13200 (*+04() 13210 RESET(SOURCDECS, 'SOURCDECS'); 13220 REWRITE(OUTPUT, 'CONSOLE'); 13230 REWRITE(LSTFILE, 'LSTFILE'); 13240 ()+04*) 13250 (*+05() 13260 OPENTEXT(SOURCDECS, 1, FALSE); 13270 OPENTEXT(LSTFILE, 3, TRUE); 13280 ()+05*) 13290 SRCBUF[0] := ' '; (*IT WILL NEVER BE WRITTEN TO AGAIN*) 13300 (*+01() 13310 LINELIMIT(OUTPUT, 100000); 13320 AW66 := ASPTR(66B); 13330 ONLINE := AW66^.JOPR=3; 13340 ()+01*) 13350 (*+02() ONLINE := TRUE; ()+02*) 13360 (*+03() ONLINE := FILENR(LSTFILE)<>1; ()+03*) 13370 (*+04() ONLINE := TRUE; ()+04*) 13380 (*+05() ONLINE := TRUE; ()+05*) 13390 (*+01() DATE(DAT); TIME(TIM); ()+01*) 13392 (*+03() DATE(DAT); TIME(TIM); ()+03*) 13394 (*+05() CTIME(TIM, 26, 1, TIME); TIM[25] := CHR(0); ()+05*) 13400 END; 13410 (**) 13420 (**) 13430 PROCEDURE OUTLST(LINE: INTEGER; VAR BUF: BUFFER; PTR: INTEGER); 13440 (*FUNCTION: SEND A SINGLE RECORD TO THE LISTING DEVICE (AND 13450 POSSIBLY THE ERROR DEVICE AS WELL). THE PRAGMAT NOLIST MAY BE 13460 USED TO SUPPRESS THE PRINTING OF THE LISTING. IN THIS CASE, 13470 NO ACTION IS TAKEN UNLESS THE LINE IS BEING SENT TO THE ERROR 13480 DEVICE. ERROR LINES ARE ALWAYS TRANSMITTED. 13490 INPUTS: 13500 LINE - THE LINE NUMBER; -VE IF NO NUMBER TO BE PRINTED 13510 BUF - BUFFER CONTAINING THE LINE TO BE PRINTED; USUALLY 13520 SRCBUF OR ERRBUF 13530 PTR - NUMBER OF CHARACTERS IN BUF; USUALLY SRCPTR OR ERRPTR 13540 GLOBALS: 13550 PRAGFLGS 13560 LSTCNT- THE NUMBER OF LINES ALREADY PRINTED ON THE CURRENT 13570 PAGE 13580 ERRDEV- TRUE IFF RECORD IS TO BE SENT TO ERROR DEVICE 13590 SRCSTAT-THE VALUE OF SRCSTCH AT THE BEGINNING OF THE LINE 13600 *) 13610 VAR I: INTEGER; 13620 BEGIN 13630 IF ONLINE THEN 13640 BEGIN 13650 IF PRGLIST IN PRAGFLGS THEN 13660 BEGIN 13662 (*+01() WRITE(LSTFILE, ' '); ()+01*) 13670 IF LINE>=0 THEN 13680 WRITE(LSTFILE, SRCSTAT, ' ', LINE:5, ' ') 13690 ELSE WRITE(LSTFILE, ' '); 13700 FOR I := 0 TO PTR DO 13710 WRITE(LSTFILE, BUF[I]); 13720 WRITELN(LSTFILE); 13730 LSTCNT := LSTCNT+1; 13740 END; 13750 IF ERRDEV THEN 13760 BEGIN 13770 IF LINE>=0 THEN 13780 WRITE(OUTPUT, SRCSTAT, ' ', LINE:5, ' ') 13790 ELSE WRITE(OUTPUT, ' '); 13800 FOR I := 0 TO PTR DO 13810 WRITE(OUTPUT, BUF[I]); 13820 WRITELN(OUTPUT); 13830 END 13840 END 13850 (*-02() (*-04() (*-05() 13860 ELSE (*BATCH*) 13870 IF ERRDEV OR (PRGLIST IN PRAGFLGS) THEN 13880 BEGIN 13882 (*+01() WRITE(LSTFILE, ' '); ()+01*) 13890 IF LINE >=0 THEN 13900 WRITE(OUTPUT, SRCSTAT, ' ', LINE:5, ' ') 13910 ELSE WRITE(OUTPUT, ' '); 13920 FOR I := 1 TO PTR DO 13930 WRITE(OUTPUT, BUF[I]); 13940 WRITELN(OUTPUT); 13950 LSTCNT := LSTCNT+1 13960 END; 13970 ()-05*) ()-04*) ()-02*) 13980 END; 13990 (**) 14000 (**) 14010 (*ERROR HANDLING*) 14020 (****************) 14030 (**) 14040 PROCEDURE OUTERR(N: INTEGER; LEV: ERRLEV; LEX: PLEX); 14050 (*FUNCTION: OUTPUT ERROR MESSAGE AND WRITE CHARACTER TO 14060 APPROPRIATE POSITION IN ERRBUF. 14070 INPUTS: 14080 N - IDENTIFIES MESSAGE TO BE PRINTED 14090 LEV - INDICATES WARNING OR ERROR 14100 GLOBALS: 14110 ERRLXPTR - POINTS TO ERRBUF POSITION JUST BEFORE START OF 14120 OFFENDING LEXEME 14130 ERRDEV, ERRNONBLANK, ERRBUF, ERRS, LSTCNT, PRAGFLGS 14140 *) 14150 VAR I: INTEGER; 14160 PROCEDURE PRINTLEX(VAR F: TEXT); 14170 VAR I: INTEGER; 14180 BEGIN WITH LEX^ DO 14190 BEGIN 14200 WRITE(F, ' - '); 14210 CASE LXTOKEN OF 14220 TKTAG: (*NOTHING*); 14230 TKBOLD: WRITE(F, '.'); 14240 TKSYMBOL: WRITE(F, ''''); 14250 END; 14260 FOR I := 1 TO LXCOUNT*CHARPERWORD DO 14270 IF STRNG[I]<>' ' THEN WRITE(F, STRNG[I]); 14280 IF LXTOKEN=TKSYMBOL THEN WRITE(F, ''''); 14290 END 14300 END; 14310 (**) 14320 PROCEDURE ERRMSG(VAR F: TEXT); 14330 BEGIN 14340 WRITE(F, ' '); 14350 CASE LEV OF 14360 ERRORR: WRITE(F, 'ERROR '); 14370 WARNING: WRITE(F, 'WARNING ') 14380 END; 14390 (*+55() WRITE(F,N:3); ()+55*) 14400 (*-55() 14410 CASE N OF 14420 (*ELX*) 14430 3: WRITE(F, 'MISSING CLOSE QUOTE IN STRING-DENOTATION'); 14440 4: WRITE(F, 'MISSING CLOSE-PRAGMENT-SYMBOL'); 14450 5: WRITE(F, 'ILLEGAL SYMBOL'); 14460 6: WRITE(F, 'ILL-FORMED DENOTATION'); 14470 7: WRITE(F, 'STRAY STROP MARK'); 14480 8: WRITE(F, 'ILLEGAL CHARACTER'); 14490 9: WRITE(F, 'IDENTIFIER OR STRING-DENOTATION TOO ', 14500 'LONG, COMPLAIN TO CHL'); 14510 10: WRITE(F, 'DENOTATION OUT OF RANGE'); 14520 (*ESY*) 14530 11: WRITE(F, 'MISSING UNIT (OR EXTRA ;)'); 14540 12: WRITE(F, 'DECLARER NOT FOUND WHERE EXPECTED'); 14550 13: WRITE(F, 'ILLEGAL FORM OF TRIMMER OR MISPLACED COLON'); 14560 14: WRITE(F, '.DO NOT FOUND WHERE EXPECTED'); 14570 15: WRITE(F, 'FIELD NOT SPECIFIED PROPERLY'); 14575 16: WRITE(F, 'MISMATCH AFTER ''['''); 14580 17: WRITE(F, 'MISMATCH AFTER ''('''); 14590 18: WRITE(F, 'END OF PROGRAM TEXT'); 14600 19: WRITE(F, 'MISSING LABEL-DECLARATION FOLLOWING .EXIT'); 14610 20: WRITE(F, 'MISSING = IN IDENTITY-DECLARATION'); 14620 21: WRITE(F, 'INCORRECT VARIABLE-DECLARATION'); 14630 22: WRITE(F, 'INCORRECT MODE-DECLARATION'); 14640 23: WRITE(F, '.GOTO NOT FOLLOWED BY LABEL'); 14650 24: WRITE(F, '.STRUCT NOT FOLLOWED BY ''('''); 14660 25: WRITE(F, 'MISPLACED PROCEDURE-PLAN'); 14670 26: WRITE(F, 'MISSING DECLARER OR DENOTATION AFTER .LONG OR .SHORT'); 14680 27: WRITE(F, 'ILLEGAL BOUNDS IN FORMAL-DECLARER'); 14690 28: WRITE(F, 'FORMAL-PARAMETER NOT SPECIFIED PROPERLY'); 14700 29: WRITE(F, 'PARAMETER MODE NOT SPECIFIED PROPERLY'); 14710 30: WRITE(F, 'ACTUAL-BOUNDS NOT TERMINATED BY '','' OR '']'''); 14720 31: WRITE(F, 'ADDITIONAL TEXT FOLLOWS A COMPLETE PROGRAM'); 14730 32: WRITE(F, 'ILLEGAL ACTUAL-PARAMETER-LIST'); 14740 33: WRITE(F, 'MISSING COLON IN ROUTINE-TEXT'); 14750 34: WRITE(F, 'MISSING ;'); 14760 35: WRITE(F, 'MISPLACED COMMA OR MISSING COMMA'); 14770 36: WRITE(F, 'MISMATCH IN LOOP-CLAUSE'); 14780 37: WRITE(F, 'MISMATCH AFTER .BEGIN'); 14790 38: WRITE(F, 'MISMATCH IN CASE-CLAUSE'); 14800 39: WRITE(F, 'MISMATCH IN IF-CLAUSE'); 14810 40: WRITE(F, 'MISSING SEMICOLON AFTER DECLARATION'); 14820 41: WRITE(F, 'MISPLACED ACTUAL-DECLARER'); 14830 42: WRITE(F, 'LOOKS LIKE AN ILLEGAL DECLARATION'); 14840 43: WRITE(F, 'ILLEGAL UNIT IN THIS CONTEXT'); 14850 44: WRITE(F, 'ILLEGAL CONTEXT FOR DISPLAY IN ALGOL 68S'); 14860 45: WRITE(F, 'MODE IS ILLEGAL IN ALGOL 68S'); 14870 46: WRITE(F, 'MISSING IDENTIFIER AFTER .FOR'); 14880 47: WRITE(F, 'ILL-FORMED DISPLAY OR DATA-LIST'); 14890 48: WRITE(F, 'MISSING = IN OPERATION-DECLARATION'); 14900 49: WRITE(F, 'MISSING BOUNDS IN ACTUAL-DECLARER'); 14910 50: WRITE(F, 'INCORRECT PRIORITY-DECLARATION'); 14920 51: WRITE(F, 'MISSING = OR := IN ROUTINE-DECLARATION'); 14930 52: WRITE(F, 'ILLEGAL CASE-CLAUSE'); 14940 53: WRITE(F, 'PRIORITY MUST BE A DIGIT'); 14950 ()-55*) 14960 (*+53() 14970 END; 14980 IF LEX<>NIL THEN PRINTLEX(F); 14990 WRITELN(F); 15000 END; 15010 PROCEDURE ERRMSG2(VAR F: TEXT); 15020 BEGIN 15030 WRITE(F, ' '); 15040 CASE LEV OF 15050 ERRORR: WRITE(F, 'ERROR '); 15060 WARNING: WRITE(F, 'WARNING '); 15070 END; 15080 (*+55() WRITE(F,N:3); ()+55*) 15090 (*-55() CASE N OF ()-55*) 15100 ()+53*) 15110 (*ESE*) 15120 (*-55() 15130 61: WRITE(F, 'DUPLICATED FIELD-SELECTOR IN .STRUCT DECLARER'); 15140 62: WRITE(F, 'LABEL-DECLARATION IN ENQUIRY-CLAUSE'); 15150 63: WRITE(F, 'ILL-FORMED MODE IN MODE-DECLARATION'); 15160 64: WRITE(F, 'LABEL PRECEDES A DECLARATION IN CURRENT RANGE'); 15170 65: WRITE(F, 'LOCAL-GENERATOR MAY NOT PRECEDE FIRST DECLARATION OF RANGE IN ALGOL 68S'); 15180 66: WRITE(F, 'TOO MANY .SHORTS'); 15190 67: WRITE(F, 'LABEL ALREADY USED AS IDENTIFIER'); 15200 68: WRITE(F, 'IDENTIFIER ALREADY USED IN THIS REACH'); 15210 69: WRITE(F, 'IDENTIFIER ALREADY DECLARED'); 15220 70: WRITE(F, 'VALUE DISCARDED WITHOUT BEING USED'); 15230 71: WRITE(F, 'MODE-INDICATION ALREADY DECLARED'); 15240 72: WRITE(F, 'MODE-INDICATION ALREADY USED IN THIS REACH'); 15250 73: WRITE(F, 'LABEL ALREADY DECLARED'); 15260 74: WRITE(F, 'SCOPE VIOLATION'); 15270 75: WRITE(F, 'IDENTIFIER ALREADY USED AS LABEL'); 15280 76: WRITE(F, 'IDENTIFIER NOT DECLARED'); 15290 78: WRITE(F, 'DISPLAYS MUST BE IN STRONG NON-VOID POSITIONS'); 15300 79: WRITE(F, 'TOO MANY .LONGS'); 15310 80: WRITE(F, 'LEFT SIDE OF ASSIGNMENT IS NOT A VARIABLE'); 15320 81: WRITE(F, '.NIL OCCURS IN NON-REF CONTEXT'); 15330 82: WRITE(F, 'MONADIC-OPERATOR USED AS DYADIC-OPERATOR'); 15340 83: WRITE(F, 'UNSUITABLE OPERAND FOR MONADIC-OPERATOR'); 15350 84: WRITE(F, 'UNSUITABLE OPERANDS FOR DYADIC-OPERATOR'); 15360 85: WRITE(F, 'THE OBJECT CALLED IS NOT A .PROC'); 15370 86: WRITE(F, 'BALANCE CANNOT BE MADE IN A SOFT POSITION'); 15380 87: WRITE(F, 'BALANCE CANNOT BE MADE IN A WEAK POSITION'); 15390 88: WRITE(F, 'BALANCE CANNOT BE MADE IN A MEEK POSITION'); 15400 89: WRITE(F, 'BALANCE CANNOT BE MADE IN A FIRM POSITION'); 15410 90: WRITE(F, 'TOO MANY ACTUAL-PARAMETERS IN CALL'); 15420 91: WRITE(F, 'ILLEGAL MODE FOR TRANSPUT'); 15430 92: WRITE(F, 'STRING-SLICE MAY NOT CONTAIN .AT IN ALGOL 68S'); 15440 93: WRITE(F, 'ILLEGAL MODE FOR THIS POSITION'); 15450 94: WRITE(F, 'ENQUIRY IN IF-CLAUSE MUST BE .BOOL'); 15460 95: WRITE(F, 'ENQUIRY IN CASE-CLAUSE MUST BE .INT'); 15470 96: WRITE(F, 'ENQUIRY IN WHILE-PART OF LOOP-CLAUSE MUST BE .BOOL'); 15480 97: WRITE(F, 'ENQUIRY IN BRIEF CHOICE-CLAUSE MUST BE .BOOL OR .INT'); 15490 98: WRITE(F, '.GOTO UNDEFINED LABEL'); 15500 99: WRITE(F, 'UNIT AFTER .TO, .BY OR .FROM MUST BE .INT'); 15510 100: WRITE(F, 'JUMP MAY NOT OCCUR IN .PROC MODE CONTEXT IN ALGOL 68S'); 15520 101: WRITE(F, 'PRIORITY MUST BE FROM 1 TO 9'); 15530 102: WRITE(F, 'PRIORITY ALREADY GIVEN FOR THIS OPERATOR'); 15540 103: WRITE(F, 'THE OBJECT AFTER .OF IS NOT A .STRUCT'); 15550 104: WRITE(F, 'FIELD-SELECTOR NOT RECOGNIZED IN THIS .STRUCT'); 15560 105: WRITE(F, 'ROWED NAME USED IN IDENTITY-RELATION'); 15570 106: WRITE(F, 'MODE-INDICATION NOT DECLARED'); 15580 107: WRITE(F, 'THE OBJECT SLICED IS NOT AN ARRAY'); 15590 108: WRITE(F, 'TOO MANY TRIMSCRIPTS IN SLICE'); 15600 109: WRITE(F, 'TOO FEW TRIMSCRIPTS IN SLICE'); 15610 110: WRITE(F, 'UNIT AFTER .AT MUST BE .INT'); 15620 111: WRITE(F, 'UNIT IN SUBSCRIPT MUST BE .INT'); 15630 112: WRITE(F, 'UNIT IN LOWER-BOUND MUST BE .INT'); 15640 113: WRITE(F, 'UNIT IN UPPER-BOUND MUST BE .INT'); 15650 114: WRITE(F, 'TOO FEW/MANY PARAMETERS FOR OPERATOR'); 15660 115: WRITE(F, 'PRIORITY-DECLARATION MUST PRECEDE OPERATOR-DECLARATION IN ALGOL 68S'); 15670 116: WRITE(F, 'A MEEKLY-RELATED OPERATOR ALREADY EXISTS'); 15680 117: WRITE(F, 'OPERAND OF IDENTITY-RELATION IS NOT A NAME'); 15690 118: WRITE(F, 'TOO FEW UNITS IN STRUCTURE-DISPLAY'); 15700 119: WRITE(F, 'TOO MANY UNITS IN STRUCTURE-DISPLAY'); 15710 120: WRITE(F, 'DISPLAY DOES NOT HAVE REQUIRED MODE'); 15720 121: WRITE(F, 'A JUMP TO THIS LABEL BYPASSES A DECLARATION'); 15730 122: WRITE(F, 'TOO MANY INTERMEDIATE VALUES (POSSIBLE RUNTIME ERROR)'); 15740 123: WRITE(F, 'IDENTIFIER USED BEFORE DECLARATION COMPLETE'); 15750 132: WRITE(F, 'TOO FEW ACTUAL-PARAMETERS IN CALL'); 15760 133: WRITE(F, '.LOC OMITTED IN VARIABLE-DECLARATION'); 15770 END; 15780 ()-55*) 15790 IF LEX<>NIL THEN PRINTLEX(F); 15800 WRITELN(F); 15810 END; 15820 (*START OF OUTERR*) 15830 BEGIN 15840 IF (LEV=ERRORR) OR (PRGWARN IN PRAGFLGS) THEN 15850 BEGIN 15860 ERRDEV := TRUE; 15870 IF ERRPTR4+LINESPERPAGE THEN CHECKPAGE; 16040 (*+01() WRITE(LSTFILE, ' '); ()+01*) 16050 (*+53() IF N<=ESE THEN ERRMSG(LSTFILE) ELSE ERRMSG2(LSTFILE); ()+53*) 16060 (*-53() ERRMSG(LSTFILE); ()-53*) 16070 LSTCNT := LSTCNT+1; 16080 END; 16090 END 16100 (*-02() (*-04() (*-05() 16110 ELSE (*BATCH*) 16120 BEGIN 16130 IF LSTCNT>4+LINESPERPAGE THEN CHECKPAGE; 16140 (*+01()WRITE(OUTPUT, ' '); ()+01*) 16150 (*+53() IF N<=ESE THEN ERRMSG(OUTPUT) ELSE ERRMSG2(OUTPUT); ()+53*) 16160 (*-53() ERRMSG(OUTPUT); ()-53*) 16170 LSTCNT := LSTCNT+1; 16180 END 16190 ()-05*) ()-04*) ()-02*) 16200 ; IF LEV=ERRORR THEN 16210 ERRS := ERRS+1 16220 ELSE WARNS := WARNS+1 16230 END 16240 END; 16250 (**) 16260 (**) 16270 PROCEDURE SEMERR(N: INTEGER); 16280 (*FUNCTION: PRINT ERROR MESSAGE PRODUCED BY SEMANTIC ROUTINES. 16290 A FUTURE VERSION OF THIS PROCEDURE MIGHT INCREMENT A SPECIAL COUNTER 16300 (AS DISTINCT FROM ERRS) FOR SEMANTIC ERRORS. 16310 *) 16320 BEGIN OUTERR(N, ERRORR, NIL); SEMERRS := SEMERRS+1 END; 16330 (**) 16340 (**) 16350 PROCEDURE SEMERRP(N: INTEGER; LEX: PLEX); 16360 (*FUNCTION: PRINTS ERROR MESSAGE FOLLOWED BY THE OFFENDING LEXEME*) 16370 BEGIN OUTERR(N, ERRORR, LEX); SEMERRS := SEMERRS+1 END; 16380 (**) 16390 (**) 16400 PROCEDURE MODERR(M: MODE; N: INTEGER); 16410 (*FUNCTION: PRINTS ERROR MESSAGE UNLESS M=MDERROR*) 16420 BEGIN 16430 IF (M<>MDERROR) AND (M<>PRCERROR) THEN 16440 BEGIN OUTERR(N, ERRORR, NIL); SEMERRS := SEMERRS+1 END 16450 END; 16460 (**) 16470 ()+81*) 16480 (*+82() 16490 (**) 16500 (*LEXICAL ANALYSIS*) 16510 (******************) 16520 (**) 16530 PROCEDURE OUTSRC; 16540 (*FUNCTION: OUTPUT A LINE OF SOURCE ON THE LISTING DEVICE. 16550 IF AN ERROR OCCURRED IN THE LINE OR THE LINE WAS IGNORED DUE 16560 TO A PREVIOUS ERROR, THEN A LINE OF ERROR INDICATION IS ALSO 16570 OUTPUT.IF AN ERROR OCCURRED IN THE LINE, THEN ERRORDEV WILL 16580 BE TRUE AND THUS ALL OUTPUT WILL GO TO THE ERROR DEVICE ALSO. 16590 GLOBALS: 16600 SRCBUF, SRCPTR - SOURCE BUFFER 16610 ERRBUF, ERRPTR - BUFFER CONTAINING ERROR INDICATIONS 16620 ERRNONBLANK - FALSE IF NO ERROR INDICATIONS 16630 ERRLXPTR 16640 PRAGFLGS 16650 INDEX - INDEX TYPE OF CURRENT CHARACTER 16660 LSTLINE - LINE NUMBER 16670 SRCSTAT, SRCSTCH 16680 *) 16690 VAR I: INTEGER; 16700 BEGIN 16710 IF LSTCNT>4+LINESPERPAGE THEN CHECKPAGE; (*MAINLY FOR FIRST TIME*) 16720 OUTLST(LSTLINE, SRCBUF, SRCPTR); 16730 IF ERRNONBLANK THEN 16740 BEGIN 16750 FOR I := ERRPTR+1 TO SRCPTR DO ERRBUF[I] := ERRCHAR; 16760 OUTLST(-1, ERRBUF, SRCPTR); 16770 IF ERRCHAR=' ' THEN 16780 ERRNONBLANK := FALSE; 16790 ERRDEV := FALSE 16800 END; 16810 IF INDEX=EOL THEN 16820 IF EOF(SOURCDECS) THEN INDEX := EOFF 16830 ELSE IF (LINENUMBERS IN PRAGFLGS) THEN 16840 BEGIN READ(SOURCDECS, LSTLINE); IF SOURCDECS^=' ' THEN GET(SOURCDECS); END 16850 ELSE LSTLINE := LSTLINE+1; 16860 SRCPTR := 0; ERRPTR := -1; ERRLXPTR := 0; 16870 IF LSTCNT>LINESPERPAGE THEN CHECKPAGE; 16880 SRCSTAT := SRCSTCH 16890 END; 16900 (**) 16910 (**) 16920 PROCEDURE NEXTCH(LEVEL: INDEXTYPE); 16930 (*FUNCTION: GET THE NEXT ACCEPTABLE CHARACTER FROM THE SOURCE 16940 INPUT. LEVEL IS USED TO INDICATE WHICH CHARACTERS ARE 16950 ACCEPTABLE. 16960 INPUTS 16970 LEVEL - THE LOWEST INDEX TYPE WHICH IS ACCEPTABLE 16980 OUTPUTS (GLOBAL) 16990 CHA - THE CURRENT INPUT CHARACTER 17000 TYPE - THE TYPE TYPE OF CHA 17010 INDEX - THE INDEX TYPE OF CHA 17020 *) 17030 LABEL 99; 17040 BEGIN 17050 REPEAT 17060 IF (INDEX=EOL) OR (SRCPTR>=CBUFSIZE) THEN 17070 OUTSRC; 17080 IF INDEX=EOFF THEN GOTO 99 17090 ELSE CHA := SOURCDECS^; 17100 SRCPTR := SRCPTR+1; SRCBUF[SRCPTR] := CHA; 17110 CHAC:=UPC; 17120 (*-50() 17130 IF (ORD(CHA)>96) AND (ORD(CHA)<127) THEN 17140 BEGIN 17150 CHA:=CHR(ORD(CHA)-32); 17160 CHAC:=LOWC 17170 END; 17180 ()-50*) 17190 (*+02() (*-25() IF EOF(SOURCDECS) THEN BEGIN INDEX := EOFF; GOTO 99 END ELSE ()-25*) ()+02*) 17192 (*-50() IF (ORD(CHA)<32) OR (ORD(CHA)>=127) THEN 17194 BEGIN INDEX := ERRCH; TYP := [] END 17196 ELSE ()-50*) 17200 CASE CHA OF 17210 ' ': 17220 BEGIN 17230 TYP := []; 17240 IF EOF(SOURCDECS) THEN BEGIN INDEX:=EOFF; GOTO 99 END 17250 ELSE IF EOLN(SOURCDECS) THEN INDEX:=EOL 17260 ELSE INDEX := SPACE 17270 END; 17280 (*-51() 17290 '$', '&', '''', '?', '\', '_': 17300 ()-51*) 17310 (*+51() 17320 '$', '_', '"', '\', '?', '^': 17330 ()+51*) 17340 (*+50() BEGIN INDEX := ERRCH; TYP := [] END; ()+50*) 17342 (*-50() BEGIN IF CHAC=UPC THEN INDEX := ERRCH ELSE INDEX := PUNCT; TYP := [] END; ()-50*) 17350 '0', '1', '2', '3', '4', '5', '6', '7', '8', '9': 17360 BEGIN 17370 INDEX := DIGIT; 17380 TYP := [HEX, DIG] 17390 END; 17400 '.': 17410 BEGIN 17420 GET(SOURCDECS); 17430 IF SOURCDECS^ IN ['0'..'9'] THEN INDEX := POINT 17440 ELSE INDEX := STROP; 17450 TYP := []; 17460 GOTO 99 17470 END; 17480 (*-51() 17490 '"': BEGIN INDEX := QUOTE; TYP := [] END; 17500 ':', '!', '%', '(', ')', '*', '/', ',', ';', '<', '>', 17510 '^', '=', '@', '[', ']': 17520 ()-51*) 17530 (*+51() 17540 '!': BEGIN INDEX := QUOTE; TYP := [] END; 17550 ':', '&', '%', '(', ')', '*', '/', ',', ';', '<', '>', 17560 '''', '=', '@', '[', ']': 17570 ()+51*) 17580 (*+50() BEGIN INDEX := PUNCT; TYP :=[] END; ()+50*) 17582 (*-50() BEGIN IF CHAC=UPC THEN INDEX := PUNCT ELSE INDEX := ERRCH; TYP := [] END; ()-50*) 17590 '+', '-': 17600 BEGIN INDEX := PLSMIN; TYP := [] END; 17610 'A', 'B', 'C', 'D', 'E', 'F': 17620 BEGIN 17630 INDEX := LETTER; 17640 TYP := [HEX, CHAC] 17650 END; 17660 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 17670 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z': 17680 BEGIN 17690 INDEX := LETTER; 17700 TYP := [CHAC] 17710 END; 17720 '#': 17730 BEGIN INDEX := PRAG; TYP := [] END; 17740 END; 17750 GET(SOURCDECS); 17760 99: 17770 UNTIL INDEX>LEVEL 17780 END; 17790 (**) 17800 (**) 17810 PROCEDURE LXERR(N: INTEGER); 17820 (*FUNCTION: PRINT ERROR MESSAGE UNLESS CURRENTLY PROCESSING 17830 INSIDE A PRAGMENT. 17840 INPUT: 17850 N - IDENTIFIES MESSAGE TO BE PRINTED 17860 GLOBALS: 17870 INPRAGMENT 17880 *) 17890 BEGIN 17900 IF NOT INPRAGMENT THEN 17910 OUTERR(N, ERRORR, NIL) 17920 END; 17930 (**) 17940 (**) 17950 PROCEDURE INITLX; 17960 (*FUNCTION: PERFORM PER-COMPILATION INITIALIZATION REQUIRED BY 17970 THE LEXICAL ANALYZER. 17980 *) 17990 (*VAR I: 0..HTSIZE; *) 18000 BEGIN 18010 (*WORDS := 0;*) 18020 (*+50() 18030 (*-52() PRAGFLGS := [PRGPOINT, PRGWARN, PRGMACH, PRGLIST, PRGGO]; ()-52*) 18040 (*+52() PRAGFLGS := [PRGPOINT, PRGWARN, PRGMACH, PRGLIST]; ()+52*) 18050 ()+50*) 18060 (*-50() PRAGFLGS := [PRGUPPER, PRGWARN, PRGMACH, PRGLIST, PRGGO]; ()-50*) 18070 INDEX := CONTROL; 18080 INPRAGMENT := FALSE; 18090 LONGSCNT := 0; 18100 ERRLXPTR := 0; ERRPTR := -1; 18110 ERRCHAR := ' '; ERRNONBLANK := FALSE; 18120 SRCPTR := 0; 18130 (*KRONOS HAS A CONVENTION FOR LINE NUMBERING OF FILES. 18140 THE FIRST CHARACTER OF THE FILE WILL NOW BE READ, AND IF 18150 IT IS A DIGIT, IT WILL BE ASSUMED THAT THE SOURCE TEXT 18160 IS NUMBERED ACCORDING TO THIS CONVENTION.*) 18170 LSTLINE := 1; 18180 IF NOT EOF(SOURCDECS) THEN 18190 BEGIN 18200 WHILE EOLN(SOURCDECS) DO GET(SOURCDECS); 18210 IF SOURCDECS^ IN ['0'..'9'] THEN 18220 BEGIN 18230 READ(SOURCDECS,LSTLINE); 18240 IF SOURCDECS^=' ' THEN GET(SOURCDECS); 18250 PRAGFLGS := PRAGFLGS+[LINENUMBERS]; 18260 END 18270 END; 18280 LEXLINE := LSTLINE; 18290 SRCSTAT := ' '; 18340 END; 18350 (**) 18360 (**) 18370 (*+04() 18380 FUNCTION LABS(X: A68INT): A68INT; 18390 BEGIN IF X>0 THEN LABS := X ELSE LABS := -X END; 18400 ()+04*) 18410 ()+82*) 18420 (*+81() 18430 FUNCTION HASHIN: PLEX; 18440 (*FUNCTION: SEARCH HASH TABLE FOR LEXEME SITTING IN CURRENTLEX. 18450 IF LEXEME IS ALREADY IN TABLE, THEN RETURN POINTER TO THIS OLD 18460 LEXEME. IF IT IS NOT IN THE TABLE AND NOENTER IS FALSE AND WE 18470 ARE NOT INSIDE A PRAGMENT, THEN ENTER THE LEXEME IN THE TABLE 18480 AND RETURN A POINTER TO THE NEW LEXEME. IF LEXEME IS NOT 18490 FOUND AND A NEW ENTRY IS NOT MADE, THEN RETURN NIL. 18500 *) 18510 LABEL 8, 9; 18520 VAR TOTAL: A68INT; HASHVAL, HASHSTART: INTEGER; I: 1..TAXLENWD; THIS: PLEX; 18530 BEGIN 18540 WITH CURRENTLEX DO 18550 BEGIN 18560 TOTAL := 0; 18570 HASHSTART := 1+ORD(LXTOKEN=TKDENOT); 18580 FOR I := HASHSTART TO LXCOUNT DO 18590 (*+11() TOTAL := TOTAL+FUDGE[2*I-1]+FUDGE[2*I]; 18592 HASHVAL := ABS(TOTAL MOD HTSIZE); (*HASH VALUE*) ()+11*) 18600 (*-11() 18601 (*-05() TOTAL := (TOTAL+INTEGERS[I]) MOD HTSIZE; ()-05*) 18602 (*+05() TOTAL := TOTAL+INTEGERS[I]; ()+05*) 18604 (*-04()(*-05() HASHVAL := TOTAL; (*HASH VALUE*) ()-05*)()-04*) 18610 (*+05() HASHVAL := ABS(TOTAL MOD HTSIZE); (*HASH VALUE*) ()+05*) 18620 (*+04() HASHVAL := SHRINK(LABS(TOTAL)); ()+04*) 18624 ()-11*) 18630 THIS := HT[HASHVAL]; 18640 WHILE THIS<>NIL DO 18650 BEGIN 18660 IF LXCOUNT<>THIS^.LXCOUNT THEN GOTO 8; 18670 FOR I := 1 TO LXCOUNT DO 18680 IF INTEGERS[I]<>THIS^.INTEGERS[I] THEN GOTO 8; 18690 IF LXTOKEN=THIS^.LXTOKEN THEN 18700 IF LXTOKEN<>TKDENOT THEN GOTO 9 18710 ELSE IF LXDENMD=THIS^.LXDENMD THEN GOTO 9 ELSE GOTO 8; 18720 8: THIS := THIS^.LINK 18730 END; 18740 9: IF (THIS=NIL) AND (NOT INPRAGMENT) THEN 18750 BEGIN 18760 (*NEW LEXEME MUST BE CREATED*) 18770 (*CREATE LEXEME JUST BIG ENOUGH*) 18780 ENEW(THIS, LXCOUNT*SZWORD+LEX1SIZE); 18790 FOR I := 1 TO LXCOUNT + LEX1SIZE DIV SZWORD DO 18800 THIS^.LEXWORDS[I] := LEXWORDS[I]; 18810 THIS^.LINK := HT[HASHVAL]; 18820 HT[HASHVAL] := THIS; 18830 END; 18840 HASHIN := THIS 18850 END (*OF WITH CURRENTLEX*) 18860 END; 18870 (**) 18880 ()+81*) 18890 (*+82() 18900 (**) 18910 FUNCTION LX: PLEX; 18920 (*FUNCTION: SCAN A SYMBOL FROM THE INPUT. 18930 VALUE: PLEX FOR THE SYMBOL. 18940 *) 18950 LABEL 1, 6, 7, 8, 77, 88, 99; 18960 CONST SKIPNONE=CONTROL; SKIPEOL=EOL; SKIPSPACES=SPACE; 18970 SKIPDENS=PLSMIN; SKIPTAGS=LETTER; 18980 (*+11() MAX10=3146314631463146313B; 18990 MAX2=37777777777777777777B; 19000 ()+11*) 19002 (*+12() 19004 MAX10=3277; 19006 MAX2=16383; 19008 ()+12*) 19010 (*+13() MAX10=214748364; 19020 MAX2=1073741824; 19030 ()+13*) 19040 VAR LEX: PLEX; SYMCNT, I: INTEGER; 19050 S: 0..127; 19060 STATE: (PT, INTPT, R, PM, FRACPT, E, EXP, BITS); 19070 (*FOR GETPRIMDEN*) 19080 EXPONENT, SIGN, SCALE, DIGT: INTEGER; 19090 NS: BOOLEAN; 19100 RR, FAC: REAL; 19110 LEVEL: INDEXTYPE; 19120 PROCEDURE FINISHOFF(C: CHAR); 19130 (*FUNCTION: FILLS REST OF STRING WITH SPACES UP TO NEXT FULL 19140 WORD AND SETS LXCOUNT. 19150 *) 19160 VAR I: 0..TAXLEN; 19170 BEGIN 19180 WITH CURRENTLEX DO 19190 BEGIN 19200 IF SYMCNT0 DO 20240 BEGIN IF ODD(SCALE) THEN RR := RR*FAC; 20250 SCALE := SCALE DIV 2; 20252 IF SCALE<>0 THEN FAC := SQR(FAC); 20260 END; (*RR = 10^SCALE*) 20270 IF NS THEN LXDENRPREAL := LXDENRPREAL/RR 20280 ELSE LXDENRPREAL := LXDENRPREAL*RR; 20284 ()-02*) 20290 (*+61() IF LONGSCNT=1 THEN LXDENMD := MDLREAL ELSE ()+61*) LXDENMD := MDREAL; 20300 GOTO 7; 20310 END; 20320 R: (*DIGITS MUST FOLLOW LETTER-R IN 20330 BITS-DENOTATION*) 20340 (*+43() IF (HEX IN TYP)(*-50() AND ((PRGPOINT IN PRAGFLGS) OR NOT(UPC IN TYP)) ()-50*) 20350 (*-04() AND (LXDENRP IN [2,4,8,16]) THEN ()-04*) 20360 (*+04() AND (SHRINK(LXDENRP) IN [2,4,8,16]) THE ()+04*) 20370 BEGIN STATE := BITS; 20380 EXPONENT := (*-04() LXDENRP; ()-04*)(*+04() SHRINK(LXDENRP); ()+04*) 20390 LXDENRP := 0; GOTO 6; 20400 END 20410 ELSE BEGIN LXERR(ELX+6); LEX := LEXERROR; GOTO 99 END; 20420 ()+43*) 20430 (*-43() IF (HEX IN TYP)(*-50() AND ((PRGPOINT IN PRAGFLGS) OR NOT(UPC IN TYP))()-50*) 20440 AND (TRUNC(LXDENRPREAL)-1 IN [1,3,7,15]) THEN 20450 BEGIN STATE := BITS; EXPONENT := TRUNC(LXDENRPREAL); LXDENRPREAL := 0; GOTO 6 END 20460 ELSE BEGIN LXERR(ELX+6); LEX := LEXERROR; GOTO 99 END; 20470 ()-43*) 20480 BITS: (*SCAN DIGITS IN BITS-DENOTATION*) 20490 (*+43() IF (HEX IN TYP)(*-50() AND ((PRGPOINT IN PRAGFLGS) OR NOT(UPC IN TYP))()-50*) THEN 20500 BEGIN IF DIG IN TYP THEN DIGT := ORD(CHA)-ORD('0') 20510 ELSE DIGT := ORD(CHA)-ORD('A')+10; 20520 IF DIGT1 DO 20550 IF LXDENRP<=MAX2 THEN 20560 BEGIN LXDENRP := LXDENRP*2; SCALE := SCALE DIV 2 END 20570 (*RELIES ON THE FACT THAT *2 IS A SHIFT*) 20580 ELSE BEGIN OUTERR(ELX+10, ERRORR, NIL); LXDENRP := 0 END; 20590 LXDENRP := LXDENRP+DIGT 20600 END 20610 ELSE BEGIN LXERR(ELX+6); LEX := LEXERROR; GOTO 99 END 20620 END 20630 ELSE BEGIN LXDENMD := MDBITS; GOTO 7 END 20640 ()+43*) 20650 (*-43() IF (HEX IN TYP) AND ((PRGPOINT IN PRAGFLGS) OR (NOT(UPC IN TYP))) THEN 20660 BEGIN IF DIG IN TYP THEN DIGT := ORD(CHA)-ORD('0') 20670 ELSE DIGT := ORD(CHA)-ORD('A')+10; 20680 IF DIGT1 DO 20710 BEGIN LXDENRPREAL := LXDENRPREAL*2; SCALE := SCALE DIV 2 END; 20720 LXDENRPREAL := LXDENRPREAL+DIGT 20730 END 20740 ELSE BEGIN LXERR(ELX+6); LEX := LEXERROR; GOTO 99 END 20750 END 20760 ELSE BEGIN 20770 IF LXDENRPREAL-MAXINT-1<=MAXINT THEN 20780 IF LXDENRPREAL<=MAXINT THEN 20790 LXDENRP := TRUNC(LXDENRPREAL) 20800 ELSE LXDENRP := TRUNC(LXDENRPREAL-MAXINT-MAXINT-2) 20810 ELSE BEGIN OUTERR(ELX+10, ERRORR, NIL); LXDENRP:=0 END ; 20820 LXDENMD := MDBITS; GOTO 7 END 20830 ()-43*) 20840 END; (*OF CASE STATE*) 20844 (*+02() SYMCNT := SYMCNT+1; STRNG[SYMCNT] := CHA; ()+02*) 20850 NEXTCH(SKIPSPACES) (*SKIPNONE IN RES*) 20860 END (*OF LOOP*); 20870 7: (*EXIT LABEL FOR LOOP*) 20880 (*+61() IF LONGSCNT<0 THEN SEMERR(ESE+6) ELSE IF LONGSCNT>1 THEN SEMERR(ESE+19); ()+61*) 20884 IF LXDENMD=MDREAL THEN 20886 BEGIN 20890 (*-02() LXCOUNT := WORDSPERREAL + SZADDR DIV SZWORD ()-02*) 20892 (*+02() LXDENRP := SYMCNT - ((SZADDR+SZREAL) DIV SZINT)*CHARPERWORD; 20894 FINISHOFF(CHR(0)); 20896 ()+02*) 20900 (*+61() (*WORRY ABOUT LONG MODES*) ()+61*) 20904 END 20910 ELSE LXCOUNT := (SZADDR+SZINT) DIV SZWORD; 20920 LXV := LXVPRDEN; 20930 LXTOKEN := TKDENOT; 20940 GOTO 88 20950 END (*OF GETPRIMDEN*); 20960 (*GETSTRGDEN*) 20970 QUOTE: (*GETSTRGDEN*) 20980 BEGIN 20990 SRCSTCH := 'S'; 21000 SYMCNT := ((SZADDR+SZINT) DIV SZINT)*CHARPERWORD; (*ALLOWS ROOM FOR LXDENMD AND LXDENRP*) 21010 WHILE TRUE DO 21020 BEGIN 21030 NEXTCH(SKIPEOL); 21040 IF INDEX=EOFF THEN 21050 BEGIN LXERR(ELX+3); LEX := LEXERROR; GOTO 99 END 21060 ELSE IF INDEX<>QUOTE THEN 21070 BEGIN 21080 (*-50() IF CHAC=LOWC THEN CHA := CHR(ORD(CHA)+32); ()-50*) 21090 IF SYMCNTQUOTE THEN GOTO 8; 21250 SRCSTCH := 'S' 21260 END 21270 END 21280 END (*OF LOOP*); 21290 8: (*UPON RECOGNITION OF END OF STRING-DENOTATION*) 21300 LXDENRP := SYMCNT-((SZADDR+SZINT)DIV SZINT)*CHARPERWORD; (*LENGTH OF STRING*) 21310 IF SYMCNT=((SZADDR+SZINT) DIV SZINT)*CHARPERWORD+1 THEN 21320 BEGIN LXDENMD := MDCHAR; 21330 LXDENRP := ORD(STRNG[((SZADDR+SZINT) DIV SZINT)*CHARPERWORD+1]); 21340 LXV := LXVPRDEN; LXCOUNT := (SZADDR+SZINT) DIV SZWORD; 21350 END 21360 ELSE 21370 BEGIN LXDENMD := MDSTRNG; FINISHOFF(CHR(0)); LXV := LXVSTRGDEN END; 21380 LXTOKEN := TKDENOT; 21390 GOTO 88 21400 END (*OF GETSTRGDEN*); 21410 (*GETOPR*) 21420 PUNCT, PLSMIN, PRAG: (*GETOPR*) 21430 BEGIN 21440 (*+01() IF CHA=':' THEN S := ORD('$')-ORD('+') ELSE S := ORD(CHA)-ORD('+'); ()+01*) 21450 (*+25() IF CHA=':' THEN S := ORD('$')-ORD('+') ELSE S := ORD(CHA)-ORD('+'); ()+25*) 21460 (*-01() (*-25() S := ORD(CHA)-ORD('!'); (*ASCII VERSION*) 21462 IF CHA='%' THEN S := 23 21465 IF CHA = '%' THEN S:=23 ELSE 21470 IF CHA IN ['[',']','^','\'] THEN S:=S-55; ()-25*) ()-01*) 21480 NEXTCH(SKIPNONE); 21490 WITH OPCHTABLE[S] DO 21500 BEGIN 21510 LEX := OTLEX; 21520 S := OTNEXT 21530 END; 21540 WHILE S<>0 DO 21550 WITH OPCHTABLE[S] DO 21560 IF CHA=OTCHAR THEN 21570 BEGIN 21580 NEXTCH(SKIPNONE); 21590 LEX := OTLEX; 21600 S := OTNEXT 21610 END 21620 ELSE S := OTALT; 21630 IF LEX=LEXERROR THEN 21640 BEGIN 21650 NEXTCH(SKIPNONE); 21660 LXERR(ELX+5); 21670 END; 21680 GOTO 99 21690 END; 21700 (*GETTAX*) 21710 LETTER: (*GETTAX*) 21720 BEGIN 21730 (*IN RES STROPPING, NOENTER IS SET. 21740 IF UPPER/LOWER STROP AND UPPER/LOWER OR IF RES 21750 THEN USE HASHBOLD 21760 ELSE*) 21770 IF PRGPOINT IN PRAGFLGS THEN TTYPE:=[UPC, LOWC, DIG] 21780 ELSE TTYPE:=[CHAC, DIG]; 21790 IF (PRGUPPER IN PRAGFLGS) AND (CHAC=UPC) THEN 21800 BEGIN 21810 LXV:=LXVTAB; 21820 LXTOKEN:=TKBOLD; 21830 LEVEL:=SKIPNONE 21840 END 21850 ELSE 21860 BEGIN 21870 LXV:=LXVTAG; 21880 LXTOKEN:=TKTAG; 21890 LEVEL:=SKIPSPACES 21900 END 21910 END (*OF GETTAX*); 21920 (*GETBOLD*) 21930 STROP: (*GETBOLD*) 21940 BEGIN 21950 NEXTCH(SKIPNONE); 21960 IF INDEX=LETTER THEN 21970 BEGIN 21980 (*HASHBOLD*) 21990 TTYPE:=[CHAC,DIG]; 22000 LXV := LXVTAB; 22010 LXTOKEN := TKBOLD; 22020 LEVEL := SKIPNONE 22030 END 22040 ELSE BEGIN LXERR(ELX+7); LEX := LEXERROR; GOTO 99 END 22050 END (*OF GETBOLD*); 22060 (*ENDOFFILE*) 22070 EOFF: (*ENDOFFILE*) 22080 BEGIN 22090 LEX := LEXSTOP; 22100 GOTO 99 22110 END; 22120 END (*OF CASE INDEX*); 22130 77: (*SCANTAX*) 22140 SYMCNT := 0; 22150 REPEAT 22160 IF SYMCNTNIL DO 22280 BEGIN 22290 IF S10=LEX^.S10 THEN 22300 IF LXTOKEN=LEX^.LXTOKEN THEN GOTO 99; 22310 LEX := LEX^.LINK 22320 END 22330 END 22340 ELSE ()+11*) 22350 FINISHOFF(' '); 22360 88: (*HASHIN*) 22370 LEX := HASHIN; 22380 99: (*LABEL REACHED FROM EXITLX*) 22390 UNTIL (LEX<>LEXERROR) OR INPRAGMENT; 22400 LX := LEX; 22410 END (*OF WITH CURRENTLEX*) 22420 END; 22430 (**) 22440 (**) 22450 PROCEDURE LEXALF(LEX: PLEX; VAR ALF: ALFA); 22460 (*OBTAINS 1ST 10 CHARS OF IDENTIFIER IN LEX*) 22470 VAR I: INTEGER; 22480 BEGIN 22490 IF LEX=NIL THEN ALF := '-UNNAMED- ' 22500 ELSE WITH LEX^ DO 22510 IF LXCOUNT=0 THEN ALF := '-UNNAMED- ' 22520 ELSE 22530 (*-11() IF LXCOUNT*CHARPERWORD<10 THEN 22540 BEGIN ALF := ' '; 22550 FOR I := 1 TO LXCOUNT*CHARPERWORD DO ALF[I] := S10[I]; 22560 END 22570 ELSE 22580 ()-11*) 22590 ALF := S10; 22600 END; 22610 (**) 22620 (**) 22630 (*+01() 22640 PROCEDURE SETPARAM(S: ALFA; COUNT: INTEGER); 22650 (*SETS S AS THE COUNTTH PARAMETER IN THE COMMUNICATION AREA*) 22660 VAR PARAMS: PACKED RECORD CASE SEVERAL OF 22670 1: (INT: INTEGER); 22680 2: (REC: PACKED ARRAY [1..7] OF CHAR; 22690 CODE: 0..777777B); 22700 3,4,5,6,7,8,9,10: () 22710 END; 22720 P: PINTEGER; 22730 I: INTEGER; 22740 BEGIN WITH PARAMS DO 22750 BEGIN 22760 IF COUNT=0 THEN P := ASPTR(64B) 22770 ELSE P := ASPTR(1+COUNT); 22780 FOR I := 1 TO 7 DO 22790 IF S[I]=' ' THEN REC[I] := CHR(0) 22800 ELSE REC[I] := S[I]; 22810 CODE := 1; (*FOR COMMA*) 22820 P^ := INT; 22830 P := ASPTR(64B); 22840 INT := P^; 22850 CODE := COUNT; 22860 P^ := INT 22870 END 22880 END; 22890 (**) 22900 (**) 22910 ()+01*) 22920 FUNCTION PARSIN: PLEX; 22930 (*FUNCTION: SCAN A TOKEN FROM THE INPUT AND RETURN ITS LEXEME. 22940 A TOKEN CONSISTS OF AN OPTIONAL PRAGMENT (PRAGMAT OR COMMENT) 22950 FOLLOWED BY A SYMBOL. 22960 *) 22970 LABEL 9; 22980 CONST SKIPDENS=PLSMIN; 22990 VAR LEX, LEX2: PLEX; 23000 PTR: PLEXQ; 23010 GOCOUNT, I: INTEGER; 23020 BEGIN 23030 (*PARSCLKS := PARSCLKS+1; LXCLOCK := LXCLOCK-CLOCK;*) 23040 IF PLINPQ=NIL THEN 23050 BEGIN 23060 REPEAT 23070 SRCSTCH := ' '; 23080 LEX := LX; 23090 WITH LEX^.LXV DO 23100 BEGIN 23110 IF (LXIO=LXIOCMMENT) OR (LXIO=LXIOPRAGMAT) THEN 23120 BEGIN 23130 IF LXIO=LXIOCMMENT THEN SRCSTCH := 'C' 23140 ELSE SRCSTCH := 'P'; 23150 INPRAGMENT := TRUE; LEX2 := NIL; 23160 REPEAT 23170 IF INDEX=EOFF THEN 23180 BEGIN OUTERR(ELX+4, ERRORR, LEX); GOTO 9 END 23190 ELSE IF INDEX>=LETTER THEN 23200 BEGIN 23210 LEX2 := LX; 23220 IF SRCSTCH='P' THEN 23230 (*DOPRAG*) WITH CURRENTLEX DO 23232 BEGIN 23240 (*-11() FOR I:=LXCOUNT*CHARPERWORD+1 TO 10 DO S10[I]:=' '; ()-11*) 23250 IF S10='WARN ' THEN PRAGFLGS := PRAGFLGS+[PRGWARN] 23260 ELSE IF S10='NOWARN ' THEN PRAGFLGS := PRAGFLGS-[PRGWARN] 23270 ELSE IF S10='POINT ' THEN PRAGFLGS := PRAGFLGS+[PRGPOINT] 23280 -[PRGUPPER] 23290 ELSE IF S10='UPPER ' THEN PRAGFLGS := PRAGFLGS+[PRGUPPER] 23300 -[PRGPOINT] 23310 ELSE IF S10='LIST ' THEN PRAGFLGS := PRAGFLGS+[PRGLIST] 23320 ELSE IF S10='NOLIST ' THEN 23330 BEGIN 23340 PRAGFLGS := PRAGFLGS-[PRGLIST]; 23350 LSTCNT := 100 (*TO FORCE NEW PAGE ON RESTARTING*) 23360 END 23370 ELSE IF (S10='PAGE ') AND (PRGLIST IN PRAGFLGS) THEN 23380 LSTCNT := 55 23390 ELSE IF S10='GO ' THEN 23400 BEGIN 23410 PRAGFLGS := PRAGFLGS+[PRGGO]; GOCOUNT := 0; 23420 (*+01() 23430 REPEAT 23440 SETPARAM(S10, GOCOUNT); GOCOUNT := GOCOUNT+1; 23450 IF INDEX<=SKIPDENS THEN NEXTCH(SKIPDENS); LEX2 := LX 23460 UNTIL LEX2=LEX 23470 ()+01*) 23480 END 23490 ELSE IF S10='NOGO ' THEN PRAGFLGS := PRAGFLGS-[PRGGO] 23500 (* ELSE IF S10='SPACE ' THEN 23510 BEGIN 23520 REPEAT LEX2 := LEX 23530 UNTIL (LXTOKEN=TKDENOT) OR (LEX2=LEX); 23540 IF LXTOKEN=TKDENOT THEN WORDS := LXDENRP 23550 END 23560 *) 23570 END 23580 END 23590 ELSE NEXTCH(SKIPDENS) (*MAYBE DIFFERENT IN RES*) 23600 UNTIL LEX2=LEX; (*MATCHING PRAGMENT-SYMBOL*) 23610 INPRAGMENT := FALSE; 23620 9: (*LABEL REACHED AFTER ELX+4*) 23630 END 23640 END 23650 UNTIL SRCSTCH=' '; 23660 IF LEX^.LXV.LXIO=LXIOLONG THEN 23670 LONGSCNT := LONGSCNT+1 23680 ELSE IF LEX^.LXV.LXIO=LXIOSHORT THEN 23690 LONGSCNT := LONGSCNT-1 23700 ELSE LONGSCNT := 0; 23710 PARSIN := LEX 23720 END 23730 ELSE WITH PLINPQ^ DO 23740 BEGIN 23750 PARSIN := DATA1; 23760 PTR := PLINPQ; PLINPQ := LINK; DISPOSE(PTR) 23770 END; 23780 (*LXCLOCK := LXCLOCK+CLOCK; LXCLOCKS := LXCLOCKS+1*) 23790 END; 23800 (**) 23810 ()+82*) 23820 (*+81() 23830 (**) 23840 (*STACK HANDLING*) 23850 (****************) 23860 (**) 23870 PROCEDURE SUBSAVE; 23880 BEGIN SRSEMP := SRSEMP+1; SRSTK[SRSEMP].SUBP := SRSUBP; SRSUBP := SRSEMP END; 23890 (**) 23900 (**) 23910 PROCEDURE SUBREST; 23920 BEGIN SRSEMP := SRSUBP-1; SRSUBP := SRSTK[SRSEMP+1].SUBP END; 23930 (**) 23940 (**) 23950 FUNCTION SRPOPMD: MODE; 23960 BEGIN SRPOPMD := SRSTK[SRSEMP].MD; SRSEMP := SRSEMP-1 END; 23970 (**) 23980 (**) 23990 PROCEDURE SCPUSH(M: MODE); 24000 VAR SC: PMODECHAIN; 24010 BEGIN NEW(SC); WITH SC^ DO 24020 BEGIN LINK := SCL; SCMODE := M END; 24030 SCL := SC 24040 END; 24050 (**) 24060 (**) 24070 FUNCTION SCPOP: MODE; 24080 VAR SC: PMODECHAIN; 24090 BEGIN SCPOP := SCL^.SCMODE; SC := SCL; SCL := SCL^.LINK; DISPOSE(SC) END; 24100 (**) 24110 (**) 24120 ()+81*) 24130 (*+84() 24140 (*MODE CREATION*) 24150 (***************) 24160 (**) 24170 PROCEDURE FIND(VAR SEARCHLIST: MODE; RECURSIVE: BOOLEAN; LENGTH: CNTR); 24180 (*REPLACES THE FIRST MODE OF SEARCHLIST BY ANY DUPLICATES OF ITSELF*) 24190 VAR PREV, THIS, NEXT: MODE; 24200 FUNCTION COMPARE(M1, M2: MODE; ASSUMPTION: PMODECHAIN; SEARCHDEEP: BOOLEAN): BOOLEAN; 24210 (*IF SEARCHDEEP THEN 24220 RETURNS TRUE IFF M1 AND M2 ARE EQUIVALENT UNDER THE ASSUMPTION THAT 24230 NIL AND ALL MODES IN ASSUMPTION ARE EQUIVALENT TO SEARCHLIST 24240 ELSE 24250 RETURNS TRUE IFF M1=M2 24260 *) 24270 VAR FOUND: BOOLEAN; 24280 I: INTEGER; 24290 APTR: PMODECHAIN; 24300 BEGIN 24310 IF M1=M2 THEN COMPARE := TRUE 24320 ELSE IF SEARCHDEEP THEN 24330 IF M1=NIL THEN 24340 IF RECURSIVE THEN 24350 BEGIN 24360 APTR := ASSUMPTION; FOUND := FALSE; 24370 WHILE (APTR<>NIL) AND NOT FOUND DO WITH APTR^ DO (*SCAN ASSUMPTIONS*) 24380 BEGIN FOUND := SCMODE=M2; APTR := LINK END; 24390 COMPARE := FOUND; 24400 IF NOT FOUND THEN (*MAKE NEW ASSUMPTION*) 24410 BEGIN 24420 NEW(APTR); 24430 APTR^.LINK := ASSUMPTION; APTR^.SCMODE := M2; 24440 COMPARE := COMPARE(SEARCHLIST, M2, APTR, TRUE); 24450 DISPOSE(APTR) 24460 END 24470 END 24480 ELSE COMPARE := FALSE 24490 ELSE IF M2=NIL THEN COMPARE := COMPARE(NIL, M1, ASSUMPTION, SEARCHDEEP) 24500 ELSE WITH M1^ DO IF (MDV.MDCNT=M2^.MDV.MDCNT) AND (MDV.MDID=M2^.MDV.MDID) THEN 24510 BEGIN 24520 IF MDV.MDID IN [MDIDPROC, MDIDPASC, MDIDREF, MDIDROW] THEN 24530 FOUND := COMPARE(MDPRRMD, M2^.MDPRRMD, ASSUMPTION, RECURSIVE) 24540 ELSE FOUND := TRUE; 24550 IF MDV.MDID IN [MDIDPROC, MDIDPASC] THEN 24560 FOR I := 0 TO MDV.MDCNT-1 DO 24570 FOUND := FOUND AND COMPARE(MDPRCPRMS[I], M2^.MDPRCPRMS[I], ASSUMPTION, RECURSIVE) 24580 ELSE IF MDV.MDID=MDIDSTRUCT THEN 24590 FOR I := 0 TO MDV.MDCNT-1 DO WITH MDSTRFLDS[I] DO 24600 FOUND := FOUND 24610 AND (MDSTRFLEX=M2^.MDSTRFLDS[I].MDSTRFLEX) 24620 AND COMPARE(MDSTRFMD, M2^.MDSTRFLDS[I].MDSTRFMD, ASSUMPTION, RECURSIVE); 24630 COMPARE := FOUND 24640 END 24650 ELSE COMPARE := FALSE 24660 ELSE COMPARE := FALSE 24670 END; (*COMPARE*) 24680 BEGIN (*FIND*) 24690 PREV := SEARCHLIST; 24700 THIS := SEARCHLIST^.MDLINK; (*FIRST MODE TO BE TESTED*) 24710 WHILE THIS<>NIL DO WITH THIS^ DO 24720 BEGIN 24730 NEXT := MDLINK; 24740 IF COMPARE(SEARCHLIST, THIS, NIL, TRUE) THEN (*MOVE THIS TO START OF SEARCHLIST*) 24750 BEGIN 24760 PREV^.MDLINK := NEXT; 24770 MDLINK := SEARCHLIST^.MDLINK; 24780 IF PREV=SEARCHLIST THEN PREV := THIS; 24790 EDISPOSE(SEARCHLIST, LENGTH+MODE1SIZE); 24800 SEARCHLIST := THIS; 24810 THIS := NEXT; 24820 END 24830 ELSE 24840 BEGIN PREV := THIS; THIS := NEXT END; 24850 END; 24860 END; 24870 (**) 24880 (**) 24890 FUNCTION FINDREF(M: MODE): MODE; 24900 (*FIND, OR CREATE, A MODE TABLE ENTRY FOR .REF M*) 24910 VAR CURRENTMD: MODE; 24920 BEGIN 24930 ENEW(CURRENTMD, MODE1SIZE); 24940 WITH CURRENTMD^ DO 24950 BEGIN 24960 MDV := MDVREF; MDPRRMD := M; 24970 MDLINK := REFL; REFL := CURRENTMD 24980 END; 24990 FIND(REFL, FALSE, 0); 25000 FINDREF := REFL 25010 END; 25020 (**) 25030 (**) 25040 FUNCTION FINDROW(M: MODE; CNT: CNTR): MODE; 25050 (*FIND, OR CREATE, A MODE TABLE ENTRY FOR ROWS OF M*) 25060 VAR CURRENTMD: MODE; 25070 BEGIN 25080 IF CNT<=0 THEN FINDROW := M 25090 ELSE BEGIN 25100 ENEW(CURRENTMD, MODE1SIZE); 25110 WITH CURRENTMD^ DO 25120 BEGIN 25130 MDV := MDVROW; MDPRRMD := M; MDV.MDCNT := CNT; 25140 IF M<>NIL THEN 25150 BEGIN MDV.MDIO := M^.MDV.MDIO; MDV.MDSCOPE := M^.MDV.MDSCOPE END; 25152 IF M^.MDV.MDID IN [MDIDOUT..MDIDINB] THEN MDV.MDPILE := FALSE; 25160 MDLINK := ROWL; ROWL := CURRENTMD 25170 END; 25180 FIND(ROWL, FALSE, 0); 25190 FINDROW := ROWL 25200 END 25210 END; 25220 (**) 25230 (**) 25240 PROCEDURE FINDPRC(RESMD: MODE; CNT: CNTR; CP: CODEPROC); 25250 (*FIND, OR CREATE, A MODE TABLE ENTRY FOR A .PROC MODE. 25260 RESMD IS THE RESULT MODE. THE PARAMETER MODES, IF ANY, ARE ON THE SUBSTACK 25270 *) 25280 VAR CURRENTMD: MODE; 25290 LENGTH, I: INTEGER; 25300 BEGIN 25310 LENGTH := CNT*SZADDR; 25320 ENEW(CURRENTMD, LENGTH+MODE1SIZE); 25330 WITH CURRENTMD^ DO 25340 BEGIN 25350 CASE CP OF 25360 PROC: BEGIN MDV := MDVPROC; MDLINK := PROCL; PROCL := CURRENTMD END; 25370 PASC: BEGIN MDV := MDVPASC; MDLINK := PASCL; PASCL := CURRENTMD END; 25390 END; 25400 MDPRRMD := RESMD; MDV.MDCNT := CNT; MDV.MDDEPROC := CNT=0; 25410 FOR I := 0 TO CNT-1 DO (*COPY PARAMETERS*) 25420 MDPRCPRMS[I] := SRSTK[SRSUBP+1+I].MD; 25430 SUBREST 25440 END; 25450 SRSEMP := SRSEMP+1; WITH SRSTK[SRSEMP] DO 25460 CASE CP OF 25470 PROC: BEGIN FIND(PROCL, FALSE, LENGTH); MD := PROCL END; 25480 PASC: BEGIN FIND(PASCL, FALSE, LENGTH); MD := PASCL END; 25500 END 25510 END; 25520 (**) 25530 (**) 25540 PROCEDURE FINSTRLEN(M: MODE); 25550 (*FUNCTION: FILLS IN MDLEN, MDSCOPE AND MDIO FIELDS OF MODE, 25560 IF ENOUGH INFORMATION IS AVAILABLE. 25570 *) 25580 LABEL 7; 25590 VAR TOTAL: INTEGER; IO, SCOPE: BOOLEAN; 25600 I: INTEGER; 25610 BEGIN 25620 WITH M^ DO 25630 IF MDV.MDLEN=0 THEN 25640 BEGIN (*LENGTH HAS NOT BEEN CALCULATED BEFORE*) 25650 TOTAL := 0; IO := TRUE; SCOPE := FALSE; 25660 FOR I := MDV.MDCNT-1 DOWNTO 0 DO 25670 WITH MDSTRFLDS[I] DO 25680 IF MDSTRFMD=NIL THEN GOTO 7 25690 ELSE BEGIN 25700 IF MDSTRFMD^.MDV.MDLEN=0 THEN GOTO 7; 25710 IO := IO AND MDSTRFMD^.MDV.MDIO; 25720 SCOPE := SCOPE OR MDSTRFMD^.MDV.MDSCOPE; 25730 TOTAL := TOTAL+MDSTRFMD^.MDV.MDLEN 25740 END; 25750 MDV.MDIO := IO; MDV.MDLEN := TOTAL; MDV.MDSCOPE := SCOPE 25760 END; 25770 7: END; 25780 (**) 25790 (**) 25800 PROCEDURE FINSTRUCT(CNT: CNTR); 25810 (*FIND, OR CREATE, A MODE TABLE ENTRY FOR A .STRUCT MODE. 25820 THE FIELDS ARE ALREADY ON THE SUBSTACK. 25830 *) 25840 VAR CURRENTMD: MODE; 25850 LENGTH, I: INTEGER; 25860 BEGIN 25870 (*+01() LENGTH := SZADDR*CNT; ()+01*) 25880 (*-01() LENGTH := 2*SZADDR*CNT; ()-01*) 25890 ENEW(CURRENTMD, LENGTH+MODE1SIZE); 25900 WITH CURRENTMD^ DO 25910 BEGIN 25920 MDV := MDVSTRUCT; MDSTRSDB := 0; MDV.MDCNT := CNT; 25930 FOR I := 0 TO CNT-1 DO WITH MDSTRFLDS[I] DO 25940 BEGIN MDSTRFMD := SRSTK[SRSUBP+1+2*I].MD; MDSTRFLEX := SRSTK[SRSUBP+2+2*I].LEX END; 25950 SUBREST; 25960 MDLINK := STRUCTL; STRUCTL := CURRENTMD 25970 END; 25980 FIND(STRUCTL, FALSE, LENGTH); 25990 SRSEMP := SRSEMP+1; WITH SRSTK[SRSEMP] DO 26000 BEGIN MD := STRUCTL; FINSTRLEN(MD) END 26010 END; 26020 (**) 26030 (**) 26040 PROCEDURE NEWFIELD(LEX: PLEX); 26050 (*FUNCTION: CALLED FROM SR07A AND SR07B TO PROCESS ANOTHER FIELD-SELECTOR IN A DECLARER*) 26060 VAR ISLEX: BOOLEAN; 26070 SEMP: -1..SRSTKSIZE; 26080 BEGIN 26090 ISLEX := FALSE; 26100 SEMP := SRSUBP+1; 26110 WHILE SEMP<=SRSEMP DO 26120 BEGIN 26130 IF ISLEX THEN 26140 IF SRSTK[SEMP].LEX=LEX THEN SEMERRP(ESE+01, LEX); 26150 ISLEX := NOT ISLEX; 26160 SEMP := SEMP+1 26170 END; 26180 SRSEMP := SRSEMP+1; SRSTK[SRSEMP].LEX := LEX 26190 END; 26200 (**) 26210 (**) 26220 PROCEDURE RECURFIX(VAR BASEM: MODE); 26230 (*BASEM IS THE MODE TO BE DEFINED IN A RECURSIVE MODE-DEFINITION. 26240 IT IS AT THE START OF ITS APPROPRIATE MODE LIST. 26250 IT IS REPLACED AT THE START OF THAT LIST BY ANY OTHER MODE EQUIVALENT 26260 TO ITSELF, AND THEN ALL APPLIED OCCURRENCES OF THE MODE INDICATION WITHIN 26270 IT ARE REPLACED BY THE NEW BASEM. 26280 *) 26290 FUNCTION FIXM(M: MODE): MODE; 26300 VAR I: INTEGER; 26310 BEGIN 26320 IF M=NIL THEN FIXM := BASEM 26330 ELSE WITH M^ DO 26340 BEGIN 26350 IF NOT MDV.MDRECUR THEN 26360 BEGIN 26370 IF MDV.MDID IN [MDIDPROC, MDIDPASC, MDIDREF, MDIDROW] THEN 26380 MDPRRMD := FIXM(MDPRRMD); 26390 IF MDV.MDID IN [MDIDPROC, MDIDPASC] THEN 26400 FOR I := 0 TO MDV.MDCNT-1 DO 26410 MDPRCPRMS[I] := FIXM(MDPRCPRMS[I]) 26420 ELSE IF MDV.MDID=MDIDSTRUCT THEN 26430 BEGIN 26440 FOR I := 0 TO MDV.MDCNT-1 DO WITH MDSTRFLDS[I] DO 26450 MDSTRFMD := FIXM(MDSTRFMD); 26460 FINSTRLEN(M) 26470 END; 26480 MDV.MDRECUR := TRUE 26490 END; 26500 FIXM := M 26510 END 26520 END; (*OF FIXM*) 26530 BEGIN (*RECURFIX*) 26540 WITH BASEM^ DO CASE MDV.MDID OF 26550 MDIDREF: BEGIN FIND(REFL, TRUE, 0); BASEM := REFL END; 26560 MDIDROW: BEGIN FIND(ROWL, TRUE, 0); BASEM := ROWL END; 26570 MDIDPROC: BEGIN FIND(PROCL, TRUE, MDV.MDCNT); BASEM := PROCL END; 26580 (*DON'T BOTHER WITH MDIDPASC FOR NOW*) 26590 MDIDSTRUCT: BEGIN FIND(STRUCTL, TRUE, 26600 (*+11() SZADDR*MDV.MDCNT ()+11*) 26610 (*+12() 2*SZADDR*MDV.MDCNT ()+12*) 26620 (*+13() 2*SZADDR*MDV.MDCNT ()+13*) ); 26630 BASEM := STRUCTL END; 26640 END; 26650 BASEM := FIXM(BASEM) 26660 END; 26670 (**) 26680 ()+84*) 26690 (**) 26700 (*+04() 26710 BEGIN SIN; S1 26720 END. 26730 ()+04*)