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*)
