d0p1/ack
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity
ack/lang/a68s/aem/a68s1lx.p

1474 lines
59 KiB
OpenEdge ABL
Raw Permalink Normal View History

Initial revision
1988-10-04 10:56:50 +00:00
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 ERRPTR<ERRLXPTR THEN
15880 BEGIN
15890 FOR I := ERRPTR+1 TO ERRLXPTR-1 DO ERRBUF[I] := ERRCHAR;
15900 ERRPTR := ERRLXPTR;
15910 ERRBUF[ERRLXPTR] := '1'
15920 END
15930 ELSE
15940 ERRBUF[ERRLXPTR] :=
15950 CHR((ORD(ERRBUF[ERRLXPTR])-ORD('0')+1) MOD 10 + ORD('0'));
15960 ERRNONBLANK := TRUE;
15970 IF ONLINE THEN
15980 BEGIN
15990 (*+53() IF N<=ESE THEN ERRMSG(OUTPUT) ELSE ERRMSG2(OUTPUT); ()+53*)
16000 (*-53() ERRMSG(OUTPUT); ()-53*)
16010 IF PRGLIST IN PRAGFLGS THEN
16020 BEGIN
16030 IF LSTCNT>4+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 SYMCNT<TAXLEN THEN
19210 BEGIN
19220 LXCOUNT := (SYMCNT+CHARPERWORD-1) DIV CHARPERWORD;
19230 FOR I := (SYMCNT-1) MOD CHARPERWORD TO CHARPERWORD-2 DO
19240 BEGIN SYMCNT := SYMCNT+1; STRNG[SYMCNT] := C END
19250 END
19260 ELSE BEGIN LXCOUNT := TAXLENWD; LXERR(ELX+9) END
19270 END
19280 END;
19290 (*START OF LX*)
19300 BEGIN
19310 WITH CURRENTLEX DO
19320 BEGIN
19330 REPEAT
19340 1: ERRLXPTR := SRCPTR;
19350 LEXLINE := LSTLINE;
19360 CASE INDEX OF
19370 (*SKIPSPACES*)
19380 CONTROL, EOL, SPACE:
19390 BEGIN NEXTCH(SKIPSPACES); GOTO 1 END;
19400 (*ERRORCHAR*)
19410 ERRCH: (*ERRORCHAR*)
19420 BEGIN
19430 LXERR(ELX+8);
19440 NEXTCH(SKIPNONE);
19450 LEX := LEXERROR;
19460 GOTO 99
19470 END;
19480 (*GETPRIMDEN*)
19490 DIGIT, POINT: (*GETPRIMDEN*)
19500 BEGIN
19510 LXDENRPREAL := 0.0; EXPONENT := 0; SIGN := +1; SCALE := 0;
19514 (*+02() SYMCNT := ((SZADDR+SZREAL) DIV SZINT) * CHARPERWORD; ()+02*)
19520 STATE := INTPT;
19530 WHILE TRUE DO
19540 BEGIN
19550 6: (*LABEL TO REPEAT CASE WITH DIFFERENT STATE*)
19560 CASE STATE OF
19570 INTPT: (*SCAN DIGITS*)
19580 (*+43() IF INDEX=POINT THEN STATE := PT
19590 ELSE IF (CHA='R')(*-50() AND ((PRGPOINT IN PRAGFLGS) OR (LOWC IN TYP))()-50*) THEN
19600 STATE := R
19610 ELSE IF (CHA='E')(*-50() AND ((PRGPOINT IN PRAGFLGS) OR (LOWC IN TYP))()-50*) THEN
19620 BEGIN STATE := PM;
19630 IF LXDENRP<=MAXINT THEN
19640 LXDENRPREAL := (*-04() LXDENRP ()-04*)(*+04() FLOAT(LXDENRP) ()+04*)
19650 ELSE BEGIN OUTERR(ELX+10, ERRORR, NIL); LXDENRPREAL := 0.0 END
19660 END
19670 ELSE IF DIG IN TYP THEN
19680 IF LXDENRP<MAX10 THEN
19690 LXDENRP := LXDENRP*10+(ORD(CHA)-ORD('0'))
19700 ELSE BEGIN OUTERR(ELX+10, ERRORR, NIL); LXDENRP := 0 END
19710 (*+61() (*WORRY ABOUT LONG CONVERSIONS*) ()+61*)
19720 ELSE
19730 BEGIN (*+61() IF LONGSCNT=1 THEN LXDENMD := MDLINT ELSE ()+61*) LXDENMD := MDINT;
19740 GOTO 7 END;
19750 ()+43*)
19760 (*-43() IF INDEX=POINT THEN STATE := PT
19770 ELSE IF (CHA='R')(*-50() AND ((PRGPOINT IN PRAGFLGS) OR (LOWC IN TYP))()-50*) THEN
19780 STATE:=R
19790 ELSE IF (CHA='E')(*-50() AND ((PRGPOINT IN PRAGFLGS) OR (LOWC IN TYP))()-50*) THEN
19800 STATE:=PM
19810 ELSE IF DIG IN TYP THEN
19820 LXDENRPREAL := LXDENRPREAL*10+(ORD(CHA)-ORD('0'))
19830 ELSE IF LXDENRPREAL<=MAXINT
19840 THEN BEGIN (*+61() IF LONGSCNT=1 THEN LXDENMD := MDLINT ELSE ()+61*) LXDENMD:=MDINT;
19850 LXDENRP:=TRUNC(LXDENRPREAL);GOTO 7 END
19860 ELSE BEGIN OUTERR(ELX+10,ERRORR,NIL);
19870 (*+61() (*WORRY ABOUT LONG CONVERSIONS*) ()+61*)
19880 LXDENMD := MDINT;
19890 LXDENRP:=0 END;
19900 ()-43*)
19910 PT: (*FIXED-POINT-NUMERAL MUST FOLLOW IN
19920 FRACTIONAL-PART*)
19930 BEGIN STATE := FRACPT;
19940 (*-02() (*+43() IF LXDENRP<=MAXINT THEN
19950 LXDENRPREAL := LXDENRP
19960 ELSE BEGIN OUTERR(ELX+10, ERRORR, NIL); LXDENRPREAL := 0.0 END;
19970 (*+61() (*WORRY ABOUT LONG CONVERSIONS*) ()+61*)
19980 ()+43*) ()-02*)
19990 GOTO 6
20000 END;
20010 FRACPT: (*SCAN DIGITS OF FRACTIONAL-PART*)
20020 IF (CHA='E') AND ((PRGPOINT IN PRAGFLGS) OR (LOWC IN TYP))
20030 THEN STATE:=PM
20040 ELSE IF DIG IN TYP THEN
20050 (*-02() BEGIN LXDENRPREAL := LXDENRPREAL*10+(ORD(CHA)-ORD('0')); SCALE := SCALE-1 END ()-02*)
20060 ELSE BEGIN STATE := EXP; GOTO 6 END;
20070 PM: (*CHECK FOR PLUSMINUS IN EXPONENT-PART*)
20080 IF INDEX=PLSMIN THEN
20090 BEGIN IF CHA='-' THEN SIGN := -1; STATE := E END
20100 ELSE IF DIG IN TYP THEN
20110 BEGIN STATE := EXP; GOTO 6 END
20120 ELSE BEGIN LXERR(ELX+6); LEX := LEXERROR; GOTO 99 END;
20130 E: (*FIXED-POINT-NUMERAL MUST FOLLOW PLUSMINUS*)
20140 IF DIG IN TYP THEN
20150 BEGIN STATE := EXP; GOTO 6 END
20160 ELSE BEGIN LXERR(ELX+6); LEX := LEXERROR; GOTO 99 END;
20170 EXP: (*SCAN FIXED-POINT-NUMERAL IN EXPONENT-PART*)
20180 IF DIG IN TYP THEN
20190 (*-02() EXPONENT := EXPONENT*10+(ORD(CHA)-ORD('0'))*SIGN ()-02*)
20200 ELSE
20202 BEGIN
20210 (*-02() SCALE := SCALE+EXPONENT;
20220 RR := 1.0; NS := SCALE<0; SCALE := ABS(SCALE); FAC := 10.0;
20230 WHILE SCALE<>0 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 DIGT<EXPONENT THEN
20530 BEGIN SCALE := EXPONENT;
20540 WHILE SCALE<>1 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 DIGT<EXPONENT THEN
20690 BEGIN SCALE := EXPONENT;
20700 WHILE SCALE<>1 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 SYMCNT<TAXLEN THEN
21100 BEGIN SYMCNT := SYMCNT+1; STRNG[SYMCNT] := CHA END
21110 ELSE (*NO ACTION*)
21120 END
21130 ELSE
21140 BEGIN
21150 NEXTCH(SKIPNONE);
21160 IF INDEX=QUOTE THEN
21170 IF SYMCNT<TAXLEN THEN
21180 BEGIN SYMCNT := SYMCNT+1; STRNG[SYMCNT] := CHA END
21190 ELSE (*NO ACTION*)
21200 ELSE
21210 BEGIN
21220 SRCSTCH := ' ';
21230 IF INDEX<=SKIPSPACES THEN NEXTCH(SKIPSPACES);
21240 IF INDEX<>QUOTE 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 SYMCNT<TAXLEN THEN
22170 BEGIN SYMCNT := SYMCNT+1; STRNG[SYMCNT] := CHA END;
22180 NEXTCH(LEVEL)
22190 UNTIL TYP*TTYPE=[];
22200 (*+11()
22210 IF SYMCNT<11 THEN
22220 BEGIN
22230 LXCOUNT := 1;
22240 WHILE SYMCNT<10 DO
22250 BEGIN SYMCNT := SYMCNT+1; STRNG[SYMCNT] := ' ' END;
22260 LEX := HT[(FUDGE1+FUDGE2) MOD HTSIZE];
22270 WHILE LEX<>NIL 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*)
Reference in a new issue Copy permalink