1473 lines
59 KiB
OpenEdge ABL
1473 lines
59 KiB
OpenEdge ABL
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*)
|