PROGRAM PASCALS(INPUT,OUTPUT,CONTINGENCY); (*$U+,T-,P-*) (*AUTHOR: N.WIRTH, E.T.H. CH-8092 ZURICH, 1.3.76*) (*MODIFIED: L.ZAFFALON, CUI, GENEVE, 31.7.80*) LABEL 99; CONST NKW = 29; (*NO. OF KEY WORDS*) ALNG = 12; (*NO. OF SIGNIFICANT CHARS IN IDENTIFIERS*) LLNG = 81; (*INPUT ,LINE LENGTH*) EMAX = 38; (*MAX EXPONENT OF REAL NUMBERS*) EMIN =-38; (*MIN EXPONENT*) KMAX = 12; (*MAX NO. OF SIGNIFICANT DIGITS*) TMAX = 100; (*SIZE OF TABLE*) BMAX = 20; (*SIZE OF BLOCK-TABLE*) AMAX = 30; (*SIZE OF ARRAY-TABLE*) C2MAX = 20; (*SIZE OF REAL CONSTANT TABLE*) CSMAX = 30; (*MAX NO. OF CASES*) CMAX = 850; (*SIZE OF CODE*) LMAX = 7; (*MAXIMUM LEVEL*) SMAX = 600; (*SIZE OF STRING-TABLE*) ERMAX = 58; (*MAX ERROR NO.*) OMAX = 63; (*HIGHEST ORDER CODE*) XMAX = 32767; (*2**15 - 1*) NMAX = 2147483647; (*2**31-1 *) LINELENG = 132; (*OUTPUT LINE LENGTH*) LINELIMIT = 300; STACKSIZE = 3000; ALFALENG=12; (*ATTENTION ALFALENG ET ALFABLANC SONT LIES ,*) ALFABLANC=' '; (*DANS ALFABLANC IL DOIT Y AVOIR ALFALENG BLANCS* ALFAMAX=84 ; (* MAX DE CARACTERES DANS CHAINES*) TYPE SYMBOL = (INTCON,REALCON,CHARCON,STRING, NOTSY,PLUS,MINUS,TIMES,IDIV,RDIV,IMOD,ANDSY,ORSY, EQL,NEQ,LSS,LEQ,GTR,GEQ, LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON,PERIOD, COLON,BECOMES,CONSTSY,TYPESY,VARSY,FUNCTIONSY, PROCEDURESY,ARRAYSY,RECORDSY,PROGRAMSY,IDENT, BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,PACKEDSY, ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY,STRINGSY,THENSY); PSTATUS =(RUN,FIN,CASCHK,DIVCHK,INXCHK,STKCHK,LINCHK,LNGCHK,REDCHK, IOPR,IGDM,IFOF,IFUF,IDOF,IOERR,SYMBERR,ERRCALL); INDEX = -XMAX .. +XMAX; ALFA = PACKED ARRAY [1..ALNG] OF CHAR; OBJECT = (KONSTANT,VARIABLE,TYPE1,PROZEDURE,FUNKTION); TYPES = (NOTYP,INTS,REALS,BOOLS,CHARS,ARRAYS,RECORDS,PACKEDS,STRINGS,CHARSP); SYMSET = SET OF SYMBOL; TYPSET = SET OF TYPES; ITEM = RECORD TYP: TYPES; REF: INDEX END ; ORDER = PACKED RECORD F: -OMAX..+OMAX; X: -LMAX..+LMAX; Y: -1073741824 ..1073741823 END ; VAR SY: SYMBOL; (*LAST SYMBOL READ BY INSYMBOL*) ID: ALFA; (*IDENTIFIER FROM INSYMBOL*) INUM: INTEGER; (*INTEGER FROM INSYMBOL*) RNUM: REAL; (*REAL NUMBER FROM INSYMBOL*) SLENG: INTEGER; (*STRING LENGTH*) CH: CHAR; (*LAST CHARACTER READ FROM SOURCE PROGRAM*) LINE: ARRAY [1..LLNG] OF CHAR; CC: INTEGER; (*CHARACTER COUNTER*) LC: INTEGER; (*PROGRAM LOCATION COUNTER*) LL: INTEGER; (*LENGTH OF CURRENT LINE*) ERRS: SET OF 0..ERMAX; ERRPOS: INTEGER; PROGNAME: ALFA; IFLAG, OFLAG, SKIPFLAG,PRINTB,PRINTC: BOOLEAN; CONSTBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,FACBEGSYS,STATBEGSYS: SYMSET; KEY: ARRAY [1..NKW] OF ALFA; KSY: ARRAY [1..NKW] OF SYMBOL; SPS: ARRAY [CHAR] OF SYMBOL; (*SPECIAL SYMBOLS*) T,A,B,SX,C1,C2: INTEGER; (*INDICES TO TABLES*) STANTYPS: TYPSET; DISPLAY: ARRAY [0 .. LMAX] OF INTEGER; TAB: ARRAY [0 .. TMAX] OF (*IDENTIFIER TABLE*) PACKED RECORD NAME: ALFA; LINK: INDEX; OBJ: OBJECT; TYP: TYPES; REF: INDEX; NORMAL: BOOLEAN; LEV: 0 .. LMAX; ADR: INTEGER END ; ATAB: ARRAY [1 .. AMAX] OF (*ARRAY-TABLE*) PACKED RECORD INXTYP, ELTYP: TYPES; ELREF, LOW, HIGH, ELSIZE, SIZE: INDEX END ; BTAB: ARRAY [1 .. BMAX] OF (*BLOCK-TABLE*) PACKED RECORD LAST, LASTPAR, PSIZE, VSIZE: INDEX END ; STAB: PACKED ARRAY [0..SMAX] OF CHAR; (*STRING TABLE*) RCONST: ARRAY [1 .. C2MAX] OF REAL; CODE: ARRAY [0 .. CMAX] OF ORDER; PS : PSTATUS; STRTAB:ARRAY[1..AMAX,1..2]OF INTEGER; (*GESTION CHAINES DE CARACTERES*) PROCEDURE ERRORMSG; VAR K: INTEGER; MSG: ARRAY [0..ERMAX] OF ALFA; BEGIN MSG [0] := 'UNDEF ID '; MSG [1] := 'MULTI DEF '; MSG [2] := 'IDENTIFIER '; MSG [3] := 'PROGRAM '; MSG [4] := ') '; MSG [5] := ': '; MSG [6] := 'SYNTAX '; MSG [7] := 'IDENT, VAR '; MSG [8] := 'OF '; MSG [9] := '( '; MSG[10] := 'ID, ARRAY '; MSG[11] := '[ '; MSG[12] := '] '; MSG[13] := '.. '; MSG[14] := '; '; MSG[15] := 'FUNC. TYPE '; MSG[16] := '= '; MSG[17] := 'BOOLEAN '; MSG[18] := 'CONVAR TYP '; MSG[19] := 'TYPE '; MSG[20] := 'PROG.PARAM '; MSG[21] := 'TOO BIG '; MSG[22] := '. '; MSG[23] := 'TYP (CASE) '; MSG[24] := 'CHARACTER '; MSG[25] := 'CONST ID '; MSG[26] := 'INDEX TYPE '; MSG[27] := 'INDEXBOUND '; MSG[28] := 'NO ARRAY '; MSG[29] := 'TYPE ID '; MSG[30] := 'UNDEF TYPE '; MSG[31] := 'NO RECORD '; MSG[32] := 'BOOLE TYPE '; MSG[33] := 'ARITH TYPE '; MSG[34] := 'INTEGER '; MSG[35] := 'TYPES '; MSG[36] := 'PARAM TYPE '; MSG[37] := 'VARIAB ID '; MSG[38] := 'STRING '; MSG[39] := 'NO.OF PARS '; MSG[40] := 'REAL NUMBR '; MSG[41] := 'TYPE '; MSG[42] := 'REAL TYPE '; MSG[43] := 'INTEGER '; MSG[44] := 'VAR, CONST '; MSG[45] := 'VAR, PROC '; MSG[46] := 'TYPES (:=) '; MSG[47] := 'TYP (CASE) '; MSG[48] := 'TYPE '; MSG[49] := 'STORE OVFL '; MSG[50] := 'CONSTANT '; MSG[51] := ':= '; MSG[52] := 'THEN '; MSG[53] := 'UNTIL '; MSG[54] := 'DO '; MSG[55] := 'TO DOWNTO '; MSG[56] := 'BEGIN '; MSG[57] := 'END '; MSG[58] := 'FACTOR '; K := 0; WRITELN; WRITELN(' KEY WORDS'); WHILE ERRS <>[] DO BEGIN WHILE NOT (K IN ERRS) DO K := K+1; WRITELN(K,' ',MSG[K]); ERRS := ERRS - [K] END END (*ERRORMSG*) ; PROCEDURE ENDSKIP; BEGIN (*UNDERLINE SKIPPED PART OF INPUT*) WHILE ERRPOS < CC DO BEGIN WRITE('-'); ERRPOS := ERRPOS + 1 END ; SKIPFLAG := FALSE END (*ENDSKIP*) ; PROCEDURE NEXTCH; (*READ NEXT CHARACTER; PROCESS LINE END*) BEGIN IF CC = LL THEN BEGIN IF EOF(INPUT) THEN BEGIN WRITELN; WRITELN(' PROGRAM INCOMPLETE'); ERRORMSG; GOTO 99 END ; IF ERRPOS <> 0 THEN BEGIN IF SKIPFLAG THEN ENDSKIP; WRITELN; ERRPOS := 0 END ; WRITE(LC:5, ' '); LL := 0; CC := 0; WHILE NOT EOLN(INPUT) DO BEGIN LL := LL+1; READ(CH); WRITE(CH); LINE[LL] := CH END ; WRITELN; LL := LL+1; LINE[LL]:=' '; READLN END ; CC := CC+1; CH := LINE[CC]; END (*NEXTCH*) ; PROCEDURE ERROR(N: INTEGER); BEGIN IF ERRPOS = 0 THEN WRITE(' ****'); IF CC > ERRPOS THEN BEGIN WRITE(' ': CC-ERRPOS, '\', N:2); ERRPOS := CC+3; ERRS := ERRS+ [N] END END (*ERROR*) ; PROCEDURE FATAL(N: INTEGER); VAR MSG: ARRAY [1..7] OF ALFA; BEGIN WRITELN; ERRORMSG; MSG [1] := 'IDENTIFIER '; MSG [2] := 'PROCEDURES '; MSG [3] := 'REALS '; MSG [4] := 'ARRAYS '; MSG [5] := 'LEVELS '; MSG [6] := 'CODE '; MSG [7] := 'STRINGS '; WRITELN(' COMPILER TABLE FOR ', MSG[N], ' IS TOO SMALL'); GOTO 99 (* TERMINATE COMPILATION*) END (*FATAL*) ; (*-----------------------------------------------------------INSYMBOL-*) PROCEDURE INSYMBOL; (*READS NEXT SYMBOL*) LABEL 1,2,3; VAR I,J,K,E: INTEGER; PROCEDURE READSCALE; VAR S, SIGN: INTEGER; BEGIN NEXTCH; SIGN := 1; S := 0; IF CH = '+' THEN NEXTCH ELSE IF CH = '-' THEN BEGIN NEXTCH; SIGN := -1 END ; IF NOT (CH IN ['0'..'9']) THEN ERROR(40) ELSE REPEAT S := 10*S + ORD(CH) - ORD('0'); NEXTCH UNTIL NOT (CH IN ['0'..'9']); E := S*SIGN + E END (*READSCALE*) ; PROCEDURE ADJUSTSCALE; VAR S: INTEGER; D,T: REAL; BEGIN IF K+E > EMAX THEN ERROR(21) ELSE IF K+E < EMIN THEN RNUM := 0 ELSE BEGIN S := ABS(E); T := 1.0; D := 10.0; REPEAT WHILE NOT ODD(S) DO BEGIN S := S DIV 2; D := SQR(D) END ; S := S-1; T := D*T UNTIL S = 0; IF E >= 0 THEN RNUM := RNUM*T ELSE RNUM := RNUM/T END END (*ADJUSTSCALE*) ; BEGIN (*INSYMBOL*) 1: WHILE CH = ' ' DO NEXTCH; CASE CH OF 'A','B','C','D','E','F','G','H','I', 'J','K','L','M','N','O','P','Q','R', 'S','T','U','V','W','X','Y','Z': BEGIN (*IDENTIFIER OR WORDSYMBOL*) K := 0; ID := ' '; REPEAT IF K < ALNG THEN BEGIN K := K+1; ID[K] := CH END ; NEXTCH UNTIL NOT (CH IN ['A'..'Z','0'..'9']); I := 1; J := NKW; (*BINARY SEARCH*) REPEAT K := (I+J) DIV 2; IF ID <= KEY[K] THEN J := K-1; IF ID >= KEY[K] THEN I := K+1 UNTIL I > J; IF I-1 > J THEN SY := KSY[K] ELSE SY := IDENT END; '0','1','2','3','4','5','6','7','8','9': BEGIN (*NUMBER*) K := 0; INUM := 0; SY := INTCON; REPEAT INUM := INUM*10 + ORD(CH) - ORD('0'); K := K+1; NEXTCH UNTIL NOT (CH IN ['0'..'9']); IF (K > KMAX) OR (INUM > NMAX) THEN BEGIN ERROR(21); INUM := 0; K := 0 END ; IF CH = '.' THEN BEGIN NEXTCH; IF CH = '.' THEN CH := ':' ELSE BEGIN SY := REALCON; RNUM := INUM; E := 0; WHILE CH IN ['0'..'9'] DO BEGIN E := E-1; RNUM := 10.0*RNUM + (ORD(CH)-ORD('0')); NEXTCH END ; IF E = 0 THEN ERROR(40); IF CH = 'E' THEN READSCALE; IF E <> 0 THEN ADJUSTSCALE END END ELSE IF CH = 'E' THEN BEGIN SY := REALCON; RNUM := INUM; E := 0; READSCALE; IF E <> 0 THEN ADJUSTSCALE END ; END; ':': BEGIN NEXTCH; IF CH = '=' THEN BEGIN SY := BECOMES; NEXTCH END ELSE SY := COLON END ; '<' : BEGIN NEXTCH; IF CH = '=' THEN BEGIN SY := LEQ; NEXTCH END ELSE IF CH = '>' THEN BEGIN SY := NEQ; NEXTCH END ELSE SY := LSS END ; '>' : BEGIN NEXTCH; IF CH = '=' THEN BEGIN SY := GEQ; NEXTCH END ELSE SY := GTR END ; '.' : BEGIN NEXTCH; IF CH = '.' THEN BEGIN SY := COLON; NEXTCH END ELSE SY := PERIOD END ; '''': BEGIN K := 0; 2: NEXTCH; IF CH = '''' THEN BEGIN NEXTCH; IF CH <> '''' THEN GOTO 3 END ; IF SX+K = SMAX THEN FATAL(7); STAB[SX+K] := CH; K := K+1; IF CC = 1 THEN BEGIN (*END OF LINE*) K := 0; END ELSE GOTO 2; 3: IF K = 1 THEN BEGIN SY := CHARCON; INUM := ORD(STAB[SX]) END ELSE IF K = 0 THEN BEGIN ERROR(38); SY := CHARCON; INUM := 0 END ELSE BEGIN SY := STRING; INUM := SX; SLENG := K; SX := SX+K END END ; '(' : BEGIN NEXTCH; IF CH <> '*' THEN SY := LPARENT ELSE BEGIN (*COMMENT*) NEXTCH; REPEAT WHILE CH <> '*' DO NEXTCH; NEXTCH UNTIL CH = ')'; NEXTCH; GOTO 1 END END ; '+', '-', '*', '/', ')', '=', ',', '[', ']', ';' : BEGIN SY := SPS[CH]; NEXTCH END ; '$', '!', '@', '\', '^', '_', '?', '"', '&' : BEGIN ERROR(24); NEXTCH; GOTO 1 END END END (*INSYMBOL*) ; (*---------------------------------------------------------- ENTER ---*) PROCEDURE ENTER(X0: ALFA; X1: OBJECT; X2: TYPES; X3: INTEGER); BEGIN T := T+1; (*ENTER STANDARD IDENTIFIER*) WITH TAB[T] DO BEGIN NAME := X0; LINK := T-1; OBJ := X1; TYP := X2; REF := 0; NORMAL := TRUE; LEV := 0; ADR := X3 END END (*ENTER*) ; PROCEDURE ENTERARRAY(TP: TYPES; L,H: INTEGER); BEGIN IF L > H THEN ERROR(27); IF (ABS(L)>XMAX) OR (ABS(H)>XMAX) THEN BEGIN ERROR(27); L := 0; H := 0; END ; IF A = AMAX THEN FATAL(4) ELSE BEGIN A := A+1; WITH ATAB[A] DO BEGIN INXTYP := TP; LOW := L; HIGH := H END END END (*ENTERARRAY*) ; PROCEDURE ENTERBLOCK; BEGIN IF B = BMAX THEN FATAL(2) ELSE BEGIN B := B+1; BTAB[B].LAST := 0; BTAB[B].LASTPAR := 0 END END (*ENTERBLOCK*) ; PROCEDURE ENTERREAL(X: REAL); BEGIN IF C2 = C2MAX-1 THEN FATAL(3) ELSE BEGIN RCONST[C2+1] := X; C1 := 1; WHILE RCONST[C1] <> X DO C1 := C1+1; IF C1 > C2 THEN C2 := C1 END END (*ENTERREAL*) ; PROCEDURE EMIT(FCT: INTEGER); BEGIN IF LC = CMAX THEN FATAL(6); CODE[LC].F := FCT; LC := LC+1 END (*EMIT*) ; PROCEDURE EMIT1(FCT,B: INTEGER); BEGIN IF LC = CMAX THEN FATAL(6); WITH CODE[LC] DO BEGIN F := FCT; Y := B END ; LC := LC+1 END (*EMIT1*) ; PROCEDURE EMIT2(FCT,A,B: INTEGER); BEGIN IF LC = CMAX THEN FATAL(6); WITH CODE[LC] DO BEGIN F := FCT; X := A; Y := B END ; LC := LC+1 END (*EMIT2*) ; PROCEDURE PRINTTABLES; VAR I,IPR: INTEGER; O: ORDER; BEGIN PAGE(OUTPUT); WRITELN(' IDENTIFIERS LINK OBJ TYP REF NRM LEV ADR'); IF PRINTC THEN IPR:=1 ELSE IPR:=BTAB[1].LAST+1 ; FOR I :=IPR TO T DO WITH TAB[I] DO WRITELN(I:7,' ',NAME,LINK:5, ORD(OBJ):5, ORD(TYP):5, REF:5, ORD(NORMAL):5, LEV:5, ADR:10); WRITELN; WRITELN(' BLOCKS LAST LPAR PSZE VSZE'); FOR I := 1 TO B DO WITH BTAB[I] DO WRITELN(I:5,' ', LAST:5, LASTPAR:5, PSIZE:5, VSIZE:5); WRITELN; WRITELN(' ARRAYS XTYP ETYP EREF LOW HIGH ELSZ SIZE'); FOR I := 1 TO A DO WITH ATAB[I] DO WRITELN(I:5,' ', ORD(INXTYP):5, ORD(ELTYP):5, ELREF:5, LOW:5, HIGH:5, ELSIZE:5, SIZE:5); WRITELN; WRITELN(' CODE:'); FOR I := 0 TO LC-1 DO BEGIN IF I MOD 5 = 0 THEN BEGIN WRITELN; WRITE(I:5) END ; O := CODE[I]; WRITE(O.F:5); IF (O.F < 31 ) AND (O.F > -1) THEN IF O.F < 4 THEN WRITE(O.X:2, O.Y:7) ELSE WRITE(O.Y:9) ELSE IF O.F<0 THEN CASE O.F OF -1,-2,-3,-4,-8,-9,-10,-11,-13,-14,-17,-18,-23 : WRITE(O.Y:9); (*EMIT1*) -5,-6,-7,-21,-22 : WRITE(' '); (*EMIT*) -12,-15,-16,-19,-20 : WRITE(O.X:2,O.Y:7); (*EMIT2*) END (*CASE*) ELSE WRITE(' '); WRITE(',') END ; WRITELN END (*PRINTTABLES*) ; PROCEDURE PRINTSTRINGS; (*PROCEDURE D.IMPRESSION DE CHAINES DE CARACTERES , OPTION:PMD*) VAR I,J:INTEGER; BEGIN (*PRINTSTRINGS*) WRITELN;WRITELN;WRITELN(' CONST STRING',' ':(ALFAMAX-12),'POSIT',' ':5,' LONG'); FOR I:=BTAB[1].LAST+1 TO T DO WITH TAB[I] DO IF TYP=STRINGS THEN BEGIN WRITELN;WRITE(' '); FOR J:=0 TO (ADR MOD 1000 - 1) DO WRITE(STAB[ADR DIV 1000 +J]); WRITE(' ':ALFAMAX-(ADR MOD 1000)); WRITE(ADR DIV 1000 : 5); WRITE(ADR MOD 1000:10); END; I:=1; WHILE (I<=AMAX) AND (STRTAB[I,1]<>0)DO BEGIN WRITELN;WRITE(' '); FOR J:=0 TO (STRTAB[I,1]-1)DO WRITE(STAB[STRTAB[I,2]+J]); WRITE(' ':ALFAMAX-STRTAB[I,1]); WRITE(STRTAB[I,2]:5); WRITE(STRTAB[I,1]:10); I:=I+1; END; WRITELN; END; (*PRINTSTRINGS*) (*-------------------------------------------------------------BLOCK--*) PROCEDURE BLOCK(FSYS: SYMSET; ISFUN: BOOLEAN; LEVEL: INTEGER); TYPE CONREC = RECORD CASE TP: TYPES OF INTS,CHARS,BOOLS: (I: INTEGER); REALS: (R: REAL) END ; VAR DX: INTEGER; (*DATA ALLOCATION INDEX*) PRT: INTEGER; (*T-INDEX OF THIS PROCEDURE*) PRB: INTEGER; (*B-INDEX OF THIS PROCEDURE*) X: INTEGER; PROCEDURE SKIP(FSYS: SYMSET; N: INTEGER); BEGIN ERROR(N); SKIPFLAG := TRUE; WHILE NOT (SY IN FSYS) DO INSYMBOL; IF SKIPFLAG THEN ENDSKIP END (*SKIP*) ; PROCEDURE TEST(S1,S2: SYMSET; N: INTEGER); BEGIN IF NOT (SY IN S1) THEN SKIP(S1+S2,N) END (*TEST*) ; PROCEDURE TESTSEMICOLON; BEGIN IF SY = SEMICOLON THEN INSYMBOL ELSE BEGIN ERROR(14); IF SY IN [COMMA,COLON] THEN INSYMBOL END ; TEST([IDENT]+BLOCKBEGSYS, FSYS, 6) END (*TESTSEMICOLON*) ; PROCEDURE ENTER(ID: ALFA; K: OBJECT); VAR J,L: INTEGER; BEGIN IF T = TMAX THEN FATAL(1) ELSE BEGIN TAB[0].NAME := ID; J := BTAB[DISPLAY[LEVEL]].LAST; L := J; WHILE TAB[J].NAME <> ID DO J := TAB[J].LINK; IF J <> 0 THEN ERROR(1) ELSE BEGIN T := T+1; WITH TAB[T] DO BEGIN NAME := ID; LINK := L; OBJ := K; TYP := NOTYP; REF := 0; LEV := LEVEL; ADR := 0 END ; BTAB[DISPLAY[LEVEL]].LAST := T END END END (*ENTER*) ; FUNCTION LOC(ID: ALFA): INTEGER; VAR I,J: INTEGER; (*LOCATE ID IN TABLE*) BEGIN I := LEVEL; TAB[0].NAME := ID; (*SENTINEL*) REPEAT J := BTAB[DISPLAY[I]].LAST; WHILE TAB[J].NAME <> ID DO J := TAB[J].LINK; I := I-1; UNTIL (I<0) OR (J<>0); IF J = 0 THEN ERROR(0); LOC := J END (*LOC*) ; PROCEDURE ENTERVARIABLE; BEGIN IF SY = IDENT THEN BEGIN ENTER(ID,VARIABLE); INSYMBOL END ELSE ERROR(2) END (*ENTERVARIABLE*) ; PROCEDURE CONSTANT(FSYS: SYMSET; VAR C: CONREC); VAR X, SIGN: INTEGER; BEGIN C.TP := NOTYP; C.I := 0; TEST(CONSTBEGSYS, FSYS, 50); IF SY IN CONSTBEGSYS THEN BEGIN IF SY=STRING THEN BEGIN C.TP:=STRINGS; C.I:=INUM*1000+SLENG; INSYMBOL; END ELSE IF SY = CHARCON THEN BEGIN C.TP := CHARS; C.I := INUM; INSYMBOL END ELSE BEGIN SIGN := 1; IF SY IN [PLUS,MINUS] THEN BEGIN IF SY = MINUS THEN SIGN := -1; INSYMBOL END ; IF SY = IDENT THEN BEGIN X := LOC(ID); IF X <> 0 THEN IF TAB[X].OBJ <> KONSTANT THEN ERROR(25) ELSE BEGIN C.TP := TAB[X].TYP; IF C.TP = REALS THEN C.R := SIGN*RCONST[TAB[X].ADR] ELSE C.I := SIGN*TAB[X].ADR END ; INSYMBOL END ELSE IF SY = INTCON THEN BEGIN C.TP := INTS; C.I := SIGN*INUM; INSYMBOL END ELSE IF SY = REALCON THEN BEGIN C.TP := REALS; C.R := SIGN*RNUM; INSYMBOL END ELSE SKIP(FSYS,50) END; TEST(FSYS, [], 6) END END (*CONSTANT*) ; PROCEDURE TYP(FSYS: SYMSET; VAR TP: TYPES; VAR RF, SZ: INTEGER); VAR X: INTEGER; ELTP: TYPES; ELRF: INTEGER; ELSZ, OFFSET, T0,T1: INTEGER; PROCEDURE PACKEDTYP(VAR AREF,ARSZ:INTEGER); VAR ELTP:TYPES; LOW,HIGH:CONREC; ELRF,ELSZ:INTEGER; BEGIN CONSTANT([COLON,RBRACK,RPARENT,OFSY]+FSYS,LOW); IF LOW.TP=REALS THEN BEGIN ERROR(27);LOW.TP:=INTS;LOW.I:=0 END; IF SY=COLON THEN INSYMBOL ELSE ERROR(13); CONSTANT([RBRACK,RPARENT,OFSY]+FSYS,HIGH); IF HIGH.TP<>LOW.TP THEN BEGIN ERROR(27);HIGH.I:=LOW.I END; ENTERARRAY(LOW.TP,LOW.I,HIGH.I);AREF:=A; IF SY=RBRACK THEN INSYMBOL ELSE BEGIN ERROR(12); IF SY=RPARENT THEN INSYMBOL END; IF SY=OFSY THEN INSYMBOL ELSE ERROR(8); IF SY=IDENT THEN IF ID='CHAR ' THEN BEGIN INSYMBOL;WITH ATAB[AREF] DO BEGIN ELREF:=0;ELTYP:=CHARSP; ARSZ:=((HIGH-LOW) DIV ALFALENG)+1; ELSIZE:=ARSZ; SIZE:=ARSZ END; END ELSE ERROR(24) ELSE ERROR(24) END (*PACKEDTYP*); PROCEDURE ARRAYTYP(VAR AREF,ARSZ: INTEGER); VAR ELTP: TYPES; LOW, HIGH: CONREC; ELRF, ELSZ: INTEGER; BEGIN CONSTANT([COLON,RBRACK,RPARENT,OFSY]+FSYS, LOW); IF LOW.TP = REALS THEN BEGIN ERROR(27); LOW.TP := INTS; LOW.I := 0 END ; IF SY = COLON THEN INSYMBOL ELSE ERROR(13); CONSTANT([RBRACK,COMMA,RPARENT,OFSY]+FSYS, HIGH); IF HIGH.TP <> LOW.TP THEN BEGIN ERROR(27); HIGH.I := LOW.I END ; ENTERARRAY(LOW.TP, LOW.I, HIGH.I); AREF := A; IF SY = COMMA THEN BEGIN INSYMBOL; ELTP := ARRAYS; ARRAYTYP(ELRF,ELSZ) END ELSE BEGIN IF SY = RBRACK THEN INSYMBOL ELSE BEGIN ERROR(12); IF SY = RPARENT THEN INSYMBOL END ; IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); TYP(FSYS,ELTP,ELRF,ELSZ) END ; WITH ATAB[AREF] DO BEGIN ARSZ := (HIGH-LOW+1)*ELSZ; SIZE := ARSZ; ELTYP := ELTP; ELREF := ELRF; ELSIZE := ELSZ END ; END (*ARRAYTYP*) ; BEGIN (*TYP*) TP := NOTYP; RF := 0; SZ := 0; TEST(TYPEBEGSYS, FSYS, 10); IF SY IN TYPEBEGSYS THEN BEGIN IF SY = IDENT THEN BEGIN X := LOC(ID); IF X <> 0 THEN WITH TAB[X] DO IF OBJ <> TYPE1 THEN ERROR(29) ELSE BEGIN TP := TYP; RF := REF; SZ := ADR; IF TP = NOTYP THEN ERROR(30) END ; INSYMBOL END ELSE IF (SY=PACKEDSY) OR (SY=STRINGSY) THEN BEGIN INSYMBOL ; IF SY=ARRAYSY THEN INSYMBOL; IF SY=LBRACK THEN INSYMBOL ELSE BEGIN ERROR(11) ; IF SY=LPARENT THEN INSYMBOL END; TP:=PACKEDS; PACKEDTYP(RF,SZ) END ELSE IF SY = ARRAYSY THEN BEGIN INSYMBOL; IF SY = LBRACK THEN INSYMBOL ELSE BEGIN ERROR(11); IF SY = LPARENT THEN INSYMBOL END ; TP := ARRAYS; ARRAYTYP(RF,SZ) END ELSE BEGIN (*RECORDS*) INSYMBOL; ENTERBLOCK; TP := RECORDS; RF := B; IF LEVEL = LMAX THEN FATAL(5); LEVEL := LEVEL+1; DISPLAY[LEVEL] := B; OFFSET := 0; WHILE NOT (SY IN FSYS-[SEMICOLON,COMMA,IDENT]+[ENDSY]) DO BEGIN (*FIELD SECTION*) IF SY = IDENT THEN BEGIN T0 := T; ENTERVARIABLE; WHILE SY = COMMA DO BEGIN INSYMBOL; ENTERVARIABLE END ; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); T1 := T; TYP(FSYS+[SEMICOLON,ENDSY,COMMA,IDENT],ELTP,ELRF,ELSZ); WHILE T0 < T1 DO BEGIN T0 := T0+1; WITH TAB[T0] DO BEGIN TYP := ELTP; REF := ELRF; NORMAL := TRUE; ADR := OFFSET; OFFSET := OFFSET + ELSZ END END END ; IF SY <> ENDSY THEN BEGIN IF SY = SEMICOLON THEN INSYMBOL ELSE BEGIN ERROR(14); IF SY = COMMA THEN INSYMBOL END ; TEST([IDENT,ENDSY,SEMICOLON], FSYS, 6) END END ; BTAB[RF].VSIZE := OFFSET; SZ := OFFSET; BTAB[RF].PSIZE := 0; INSYMBOL; LEVEL := LEVEL-1 END ; TEST(FSYS,[], 6) END END (*TYP*) ; PROCEDURE PARAMETERLIST; (*FORMAL PARAMETER LIST*) VAR TP: TYPES; RF, SZ, X, T0: INTEGER; VALPAR: BOOLEAN; BEGIN INSYMBOL; TP := NOTYP; RF := 0; SZ := 0; TEST([IDENT, VARSY], FSYS+[RPARENT], 7); WHILE SY IN [IDENT,VARSY] DO BEGIN IF SY <> VARSY THEN VALPAR := TRUE ELSE BEGIN INSYMBOL; VALPAR := FALSE END ; T0 := T; ENTERVARIABLE; WHILE SY = COMMA DO BEGIN INSYMBOL; ENTERVARIABLE; END ; IF SY = COLON THEN BEGIN INSYMBOL; IF SY <> IDENT THEN ERROR(2) ELSE BEGIN X := LOC(ID); INSYMBOL; IF X <> 0 THEN WITH TAB[X] DO IF OBJ <> TYPE1 THEN ERROR(29) ELSE BEGIN TP := TYP; RF := REF; IF VALPAR THEN SZ := ADR ELSE SZ := 1 END ; END ; TEST([SEMICOLON,RPARENT], [COMMA,IDENT]+FSYS, 14) END ELSE ERROR(5); WHILE T0 < T DO BEGIN T0 := T0+1; WITH TAB[T0] DO BEGIN TYP := TP; REF := RF; NORMAL := VALPAR; ADR := DX; LEV := LEVEL; DX := DX + SZ END END ; IF SY <> RPARENT THEN BEGIN IF SY = SEMICOLON THEN INSYMBOL ELSE BEGIN ERROR(14); IF SY = COMMA THEN INSYMBOL END ; TEST([IDENT,VARSY], [RPARENT]+FSYS, 6) END END (*WHILE*) ; IF SY = RPARENT THEN BEGIN INSYMBOL; TEST([SEMICOLON,COLON], FSYS, 6) END ELSE ERROR(4) END (*PARAMETERLIST*) ; PROCEDURE CONSTANTDECLARATION; VAR C: CONREC; BEGIN INSYMBOL; TEST([IDENT], BLOCKBEGSYS, 2); WHILE SY = IDENT DO BEGIN ENTER(ID,KONSTANT); INSYMBOL; IF SY = EQL THEN INSYMBOL ELSE BEGIN ERROR(16); IF SY = BECOMES THEN INSYMBOL END ; CONSTANT([SEMICOLON,COMMA,IDENT]+FSYS,C); TAB[T].TYP := C.TP; TAB[T].REF := 0; IF C.TP = REALS THEN BEGIN ENTERREAL(C.R); TAB[T].ADR := C1 END ELSE TAB[T].ADR := C.I; TESTSEMICOLON END END (*CONSTANTDECLARATION*) ; PROCEDURE TYPEDECLARATION; VAR TP: TYPES; RF, SZ, T1: INTEGER; BEGIN INSYMBOL; TEST([IDENT], BLOCKBEGSYS, 2); WHILE SY = IDENT DO BEGIN ENTER(ID,TYPE1); T1 := T; INSYMBOL; IF SY = EQL THEN INSYMBOL ELSE BEGIN ERROR(16); IF SY = BECOMES THEN INSYMBOL END ; TYP([SEMICOLON,COMMA,IDENT]+FSYS, TP, RF, SZ); WITH TAB[T1] DO BEGIN TYP := TP; REF := RF; ADR := SZ END ; TESTSEMICOLON END END (*TYPEDECLARATION*) ; PROCEDURE VARIABLEDECLARATION; VAR T0, T1, RF, SZ: INTEGER; TP: TYPES; BEGIN INSYMBOL; TEST([IDENT],BLOCKBEGSYS,2); WHILE SY = IDENT DO BEGIN T0 := T; ENTERVARIABLE; WHILE SY = COMMA DO BEGIN INSYMBOL; ENTERVARIABLE; END ; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); T1 := T; TYP([SEMICOLON,COMMA,IDENT]+FSYS, TP, RF, SZ); WHILE T0 < T1 DO BEGIN T0 := T0+1; WITH TAB[T0] DO BEGIN TYP := TP; REF := RF; LEV := LEVEL; ADR := DX; NORMAL := TRUE; DX := DX + SZ END END ; TESTSEMICOLON END END (*VARIABLEDECLARATION*) ; PROCEDURE PROCDECLARATION; VAR ISFUN: BOOLEAN; BEGIN ISFUN := SY = FUNCTIONSY; INSYMBOL; IF SY <> IDENT THEN BEGIN ERROR(2); ID := ' ' END ; IF ISFUN THEN ENTER(ID,FUNKTION) ELSE ENTER(ID,PROZEDURE); TAB[T].NORMAL := TRUE; INSYMBOL; BLOCK([SEMICOLON]+FSYS, ISFUN, LEVEL+1); IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); EMIT(32+ORD(ISFUN)) (*EXIT*) END (*PROCEDUREDECLARATION*) ; (*---------------------------------------------------------STATEMENT--*) PROCEDURE STATEMENT(FSYS: SYMSET); VAR I: INTEGER; X: ITEM; PROCEDURE EXPRESSION(FSYS: SYMSET; VAR X: ITEM); FORWARD; PROCEDURE SELECTOR(FSYS: SYMSET; VAR V:ITEM); VAR X: ITEM; A,J: INTEGER; BEGIN (*SY IN [LPARENT, LBRACK, PERIOD]*) REPEAT IF SY = PERIOD THEN BEGIN INSYMBOL; (*FIELD SELECTOR*) IF SY <> IDENT THEN ERROR(2) ELSE BEGIN IF V.TYP <> RECORDS THEN ERROR(31) ELSE BEGIN (*SEARCH FIELD IDENTIFIER*) J := BTAB[V.REF] .LAST; TAB[0].NAME := ID; WHILE TAB[J].NAME <> ID DO J := TAB[J].LINK; IF J = 0 THEN ERROR(0); V.TYP := TAB[J].TYP; V.REF := TAB[J].REF; A := TAB[J].ADR; IF A <> 0 THEN EMIT1(9,A) END ; INSYMBOL END END ELSE BEGIN (*ARRAY SELECTOR*) IF SY <> LBRACK THEN ERROR(11); REPEAT INSYMBOL; EXPRESSION(FSYS+[COMMA,RBRACK], X); IF (V.TYP <>ARRAYS) AND (V.TYP<>PACKEDS) THEN ERROR(28) ELSE BEGIN A := V.REF; IF ATAB[A].INXTYP <> X.TYP THEN ERROR(26) ELSE IF ATAB[A].ELTYP=CHARSP THEN EMIT1(-9,A) ELSE IF ATAB[A].ELSIZE = 1 THEN EMIT1(20,A) ELSE EMIT1(21,A); V.TYP := ATAB[A].ELTYP; V.REF := ATAB[A].ELREF END UNTIL SY <> COMMA; IF SY = RBRACK THEN INSYMBOL ELSE BEGIN ERROR(12); IF SY = RPARENT THEN INSYMBOL END END UNTIL NOT (SY IN [LBRACK,LPARENT,PERIOD]); TEST(FSYS, [], 6) END (*SELECTOR*) ; PROCEDURE CALL(FSYS: SYMSET; I: INTEGER); VAR X: ITEM; LASTP, CP, K: INTEGER; BEGIN EMIT1(18,I); (*MARK STACK*) LASTP := BTAB[TAB[I].REF].LASTPAR; CP := I; IF SY = LPARENT THEN BEGIN (*ACTUAL PARAMETER LIST*) REPEAT INSYMBOL; IF CP >= LASTP THEN ERROR(39) ELSE BEGIN CP := CP+1; IF TAB[CP].NORMAL THEN BEGIN (*VALUE PARAMETER*) EXPRESSION(FSYS+[COMMA,COLON,RPARENT], X); IF X.TYP=TAB[CP].TYP THEN BEGIN IF X.REF <> TAB[CP].REF THEN ERROR(36) ELSE IF X.TYP = ARRAYS THEN EMIT1(22,ATAB[X.REF].SIZE) ELSE IF X.TYP = PACKEDS THEN EMIT1(22,ATAB[X.REF].SIZE) ELSE IF X.TYP = RECORDS THEN EMIT1(22,BTAB[X.REF].VSIZE) END ELSE IF (X.TYP=INTS) AND (TAB[CP].TYP=REALS) THEN EMIT1(26,0) ELSE IF X.TYP<>NOTYP THEN ERROR(36); END ELSE BEGIN (*VARIABLE PARAMETER*) IF SY <> IDENT THEN ERROR(2) ELSE BEGIN K := LOC(ID); INSYMBOL; IF K <> 0 THEN BEGIN IF TAB[K].OBJ <> VARIABLE THEN ERROR(37); X.TYP := TAB[K].TYP; X.REF := TAB[K].REF; IF TAB[K].NORMAL THEN EMIT2(0,TAB[K].LEV,TAB[K].ADR) ELSE EMIT2(1,TAB[K].LEV,TAB[K].ADR); IF SY IN [LBRACK,LPARENT,PERIOD] THEN SELECTOR(FSYS+[COMMA,COLON,RPARENT], X); IF (X.TYP<>TAB[CP].TYP) OR (X.REF<>TAB[CP].REF) THEN ERROR(36) END END END END ; TEST([COMMA,RPARENT], FSYS, 6) UNTIL SY <> COMMA; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END ; IF CP < LASTP THEN ERROR(39); (*TOO FEW ACTUAL PARAMETERS*) EMIT1(19, BTAB[TAB[I].REF].PSIZE-1); IF TAB[I].LEV < LEVEL THEN EMIT2(3, TAB[I].LEV, LEVEL) END (*CALL*) ; FUNCTION RESULTTYPE(A,B: TYPES): TYPES; BEGIN IF (A>REALS) OR (B>REALS) THEN BEGIN ERROR(33); RESULTTYPE := NOTYP END ELSE IF (A=NOTYP) OR (B=NOTYP) THEN RESULTTYPE := NOTYP ELSE IF A=INTS THEN IF B=INTS THEN RESULTTYPE := INTS ELSE BEGIN RESULTTYPE := REALS; EMIT1(26,1) END ELSE BEGIN RESULTTYPE := REALS; IF B=INTS THEN EMIT1(26,0) END END (*RESULTTYPE*) ; PROCEDURE EXPRESSION(FSYS: SYMSET; VAR X: ITEM); VAR Y:ITEM; OP:SYMBOL; PROCEDURE SIMPLEEXPRESSION(FSYS:SYMSET; VAR X:ITEM); VAR Y:ITEM; OP:SYMBOL; PROCEDURE TERM(FSYS:SYMSET; VAR X:ITEM); VAR Y:ITEM; OP:SYMBOL; TS:TYPSET; PROCEDURE FACTOR(FSYS:SYMSET; VAR X:ITEM); VAR I,F: INTEGER; PROCEDURE STANDFCT(N: INTEGER); VAR TS: TYPSET; BEGIN (*STANDARD FUNCTION NO. N*) IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9); IF N < 17 THEN BEGIN EXPRESSION(FSYS+[RPARENT],X); CASE N OF (*ABS,SQR*) 0,2: BEGIN TS := [INTS,REALS]; TAB[I].TYP := X.TYP; IF X.TYP = REALS THEN N := N+1 END ; (*ODD,CHR*) 4,5: TS := [INTS]; (*ORD*) 6: TS := [INTS,BOOLS,CHARS]+[CHARSP]; (*SUCC,PRED*) 7,8: BEGIN TS := [INTS,BOOLS,CHARS]+[CHARSP];TAB[I].TYP :=X.TYP END ; (*ROUND,TRUNC*) 9,10,11,12,13,14,15,16: (*SIN,COS,...*) BEGIN TS := [INTS,REALS]; IF X.TYP = INTS THEN EMIT1(26,0) END ; END ; IF X.TYP IN TS THEN EMIT1(8,N) ELSE IF X.TYP <> NOTYP THEN ERROR(48); END ELSE (*EOF,EOLN*) BEGIN (*N IN [17,18]*) IF SY <> IDENT THEN ERROR(2) ELSE IF ID <> 'INPUT ' THEN ERROR(0) ELSE INSYMBOL; EMIT1(8,N); END ; X.TYP := TAB[I].TYP; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END (*STANDFCT*) ; PROCEDURE STANDSPFCT(N:INTEGER); (* NVLLE FCTS PREDEFINIES SPASCAL *) VAR REFTEMP:INTEGER; XLOC:ITEM; BEGIN (*STANDSPFCT*) IF SY=LPARENT THEN INSYMBOL ELSE ERROR(9); EXPRESSION(FSYS+[RPARENT,COMMA],XLOC); REFTEMP:=XLOC.REF; IF (XLOC.TYP<>PACKEDS) THEN ERROR(46); IF SY=COMMA THEN INSYMBOL ELSE ERROR(0); EXPRESSION(FSYS+[RPARENT],XLOC); IF XLOC.TYP<>INTS THEN ERROR(46); IF SY<>RPARENT THEN ERROR(4) ELSE INSYMBOL ; EMIT1(-23,REFTEMP) END; (*STANDSPFCT*) FUNCTION LOCSTR:INTEGER; (*TRAITEMENT DE CHAINES DE CARACTERES DANS LES EXPRESSIONS *) VAR I,J:INTEGER; FOUND:BOOLEAN; BEGIN I:=1;FOUND:=FALSE; WHILE (I<=AMAX) AND (STRTAB[I,1]<>0) AND (NOT FOUND) DO BEGIN IF STRTAB[I,1]=SLENG THEN BEGIN J:=0; REPEAT J:=J+1; UNTIL (STAB[STRTAB[I,2]+J-1]<>STAB[INUM+J-1]) OR (J>SLENG); IF J>SLENG THEN FOUND:=TRUE; END; I:=I+1; END; IF (I>AMAX) AND NOT FOUND THEN BEGIN ERROR(49); LOCSTR:=0; END ELSE BEGIN IF NOT FOUND THEN BEGIN STRTAB[I,1]:=SLENG; STRTAB[I,2]:=INUM; IF I 0 THEN CALL(FSYS, I) ELSE IF ADR<>20 THEN STANDFCT(ADR) ELSE STANDSPFCT(ADR) END END (*CASE,WITH*) END ELSE IF SY IN [CHARCON,INTCON,REALCON] THEN BEGIN X.REF:=0; IF SY=REALCON THEN BEGIN X.TYP:=REALS ;ENTERREAL(RNUM); EMIT1(25,C1) END ELSE BEGIN IF SY=CHARCON THEN BEGIN X.TYP:=CHARS; X.REF:=-1 (*SIGNIFIE POUR CHARCON POUR PROCEDURE ASSIGN *) END ELSE X.TYP:=INTS; EMIT1(24,INUM) END; INSYMBOL END ELSE IF SY=LPARENT THEN BEGIN INSYMBOL; EXPRESSION(FSYS+[RPARENT], X); IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END ELSE IF SY = NOTSY THEN BEGIN INSYMBOL; FACTOR(FSYS,X); IF X.TYP=BOOLS THEN EMIT(35) ELSE IF X.TYP<>NOTYP THEN ERROR(32) END ; TEST(FSYS, FACBEGSYS, 6) END (*WHILE*) END (*FACTOR*) ; BEGIN (*TERM*) FACTOR(FSYS+[TIMES,RDIV,IDIV,IMOD,ANDSY], X); WHILE SY IN [TIMES,RDIV,IDIV,IMOD,ANDSY] DO BEGIN OP := SY; INSYMBOL; FACTOR(FSYS+[TIMES,RDIV,IDIV,IMOD,ANDSY], Y); IF OP = TIMES THEN BEGIN X.TYP := RESULTTYPE(X.TYP, Y.TYP); CASE X.TYP OF NOTYP: ; INTS : EMIT(57); REALS: EMIT(60); END END ELSE IF OP = RDIV THEN BEGIN IF X.TYP = INTS THEN BEGIN EMIT1(26,1); X.TYP := REALS END ; IF Y.TYP = INTS THEN BEGIN EMIT1(26,0); Y.TYP := REALS END ; IF (X.TYP=REALS) AND (Y.TYP=REALS) THEN EMIT(61) ELSE BEGIN IF (X.TYP<>NOTYP) AND (Y.TYP<>NOTYP) THEN ERROR(33); X.TYP := NOTYP END END ELSE IF OP = ANDSY THEN BEGIN IF (X.TYP=BOOLS) AND (Y.TYP=BOOLS) THEN EMIT(56) ELSE BEGIN IF (X.TYP<>NOTYP) AND (Y.TYP<>NOTYP) THEN ERROR(32); X.TYP := NOTYP END END ELSE BEGIN (*OP IN [IDIV,IMOD]*) IF (X.TYP=INTS) AND (Y.TYP=INTS) THEN IF OP=IDIV THEN EMIT(58) ELSE EMIT(59) ELSE BEGIN IF (X.TYP<>NOTYP) AND (Y.TYP<>NOTYP) THEN ERROR(34); X.TYP := NOTYP END END END END (*TERM*) ; BEGIN (*SIMPLEEXPRESSION*) IF SY IN [PLUS,MINUS] THEN BEGIN OP := SY; INSYMBOL; TERM(FSYS+[PLUS,MINUS], X); IF X.TYP > REALS THEN ERROR(33) ELSE IF OP = MINUS THEN EMIT(36) END ELSE TERM(FSYS+[PLUS,MINUS,ORSY], X); WHILE SY IN [PLUS,MINUS,ORSY] DO BEGIN OP := SY; INSYMBOL; TERM(FSYS+[PLUS,MINUS,ORSY], Y); IF OP = ORSY THEN BEGIN IF (X.TYP=BOOLS) AND (Y.TYP=BOOLS) THEN EMIT(51) ELSE BEGIN IF (X.TYP<>NOTYP) AND (Y.TYP<>NOTYP) THEN ERROR(32); X.TYP := NOTYP END END ELSE BEGIN X.TYP := RESULTTYPE(X.TYP, Y.TYP); CASE X.TYP OF NOTYP: ; INTS : IF OP = PLUS THEN EMIT(52) ELSE EMIT(53); REALS: IF OP = PLUS THEN EMIT(54) ELSE EMIT(55) END END END END (*SIMPLEEXPRESSION*) ; BEGIN (*EXPRESSION*) SIMPLEEXPRESSION(FSYS+[EQL,NEQ,LSS,LEQ,GTR,GEQ], X); IF SY IN [EQL,NEQ,LSS,LEQ,GTR,GEQ] THEN BEGIN OP := SY; INSYMBOL; SIMPLEEXPRESSION(FSYS, Y); IF (X.TYP IN [NOTYP,INTS,BOOLS]) AND (X.TYP = Y.TYP) THEN CASE OP OF EQL: EMIT(45); NEQ: EMIT(46); LSS: EMIT(47); LEQ: EMIT(48); GTR: EMIT(49); GEQ: EMIT(50); END ELSE IF (X.TYP IN [CHARS,CHARSP,PACKEDS,STRINGS]) AND (Y.TYP IN [CHARS,CHARSP,PACKEDS,STRINGS]) THEN IF (X.TYP = Y.TYP) THEN CASE X.TYP OF CHARS: EMIT(45+ORD(OP)-ORD(EQL)); CHARSP: EMIT1(-11,ORD(OP)-ORD(EQL)); PACKEDS: EMIT2(-12,ORD(OP)-ORD(EQL), X.REF*1000+Y.REF); STRINGS: (*NON IMPLANTE CAR INUTILE*) END ELSE (*X.TYP<>Y.TYP*) IF (X.TYP=PACKEDS) AND (Y.TYP=STRINGS) THEN EMIT2(-15,ORD(OP)-ORD(EQL),X.REF) ELSE IF (X.TYP=STRINGS) AND (Y.TYP=PACKEDS) THEN EMIT2(-16,ORD(OP)-ORD(EQL),Y.REF) ELSE IF (X.TYP=CHARS) AND (Y.TYP=CHARSP) THEN EMIT1(-14,ORD(OP)-ORD(EQL)) ELSE IF (X.TYP=CHARSP) AND (Y.TYP=CHARS) THEN EMIT1(-13,ORD(OP)-ORD(EQL)) ELSE ERROR(35) ELSE BEGIN IF X.TYP = INTS THEN BEGIN X.TYP := REALS; EMIT1(26,1) END ELSE IF Y.TYP = INTS THEN BEGIN Y.TYP := REALS; EMIT1(26,0) END ; IF (X.TYP=REALS) AND (Y.TYP=REALS) THEN CASE OP OF EQL: EMIT(39); NEQ: EMIT(40); LSS: EMIT(41); LEQ: EMIT(42); GTR: EMIT(43); GEQ: EMIT(44); END ELSE ERROR(35) END ; X.TYP := BOOLS END END (*EXPRESSION*) ; PROCEDURE ASSIGNMENT(LV,AD: INTEGER); VAR X,Y: ITEM; F: INTEGER; (*TAB[I].OBJ IN [VARIABLE,PROZEDURE]*) BEGIN X.TYP := TAB[I].TYP; X.REF := TAB[I].REF; IF TAB[I].NORMAL THEN F := 0 ELSE F := 1; EMIT2(F, LV, AD); IF SY IN [LBRACK,LPARENT,PERIOD] THEN SELECTOR([BECOMES,EQL]+FSYS, X); IF SY = BECOMES THEN INSYMBOL ELSE BEGIN ERROR(51); IF SY = EQL THEN INSYMBOL END ; EXPRESSION(FSYS, Y); IF X.TYP=Y.TYP THEN CASE X.TYP OF NOTYP,INTS,BOOLS,REALS,CHARS:EMIT(38); (*AFFECTATIONS SIMPLES*) STRINGS:ERROR(46); (*PAS D.AFFECTATIONS PERMISES ENTRE CHAINES CTES *) ARRAYS ,RECORDS: (*AFFECTATIONS ENTRE TABLEAUX OU ENREGISTREMENTS*) IF X.REF<>Y.REF THEN ERROR(46) (*CONFLIT DE TYPES*) ELSE IF X.TYP=ARRAYS THEN EMIT1(23,ATAB[X.REF].SIZE) ELSE EMIT1(23,BTAB[X.REF].VSIZE); PACKEDS: EMIT1(-1,X.REF*1000+Y.REF); (*AFFECTATIONS ENTRE STRUCTURES EMPACKETEES *) CHARSP: EMIT(-7); (*AFFECTATIONS ENTRE CARACTERES DE STRUCTURES EMPAQUETEES*) END (*CASE*) ELSE IF (X.TYP=REALS) AND (Y.TYP=INTS) THEN BEGIN EMIT1(26,0);EMIT(38) END ELSE IF ((X.TYP=ARRAYS) AND (Y.TYP=PACKEDS)) OR ((X.TYP=ARRAYS) AND (Y.TYP=STRINGS)) THEN (*DEPAQUETAGE*) IF ATAB[X.REF].ELTYP=CHARS THEN EMIT1(-2,X.REF*1000+Y.REF) ELSE ERROR(46) ELSE IF (X.TYP=PACKEDS) AND (Y.TYP=ARRAYS) THEN (*EMPAQUETAGE*) IF ATAB[Y.REF].ELTYP=CHARS THEN EMIT1(-3,X.REF*1000+Y.REF) ELSE ERROR(46) ELSE IF (X.TYP=PACKEDS) AND (Y.TYP=STRINGS) THEN (*AFFECTATIONS DE CTES DE TYPE CHAINE*) EMIT1(-4,X.REF) ELSE IF (X.TYP=CHARS) AND (Y.TYP=CHARSP) THEN (*EXTRACTION*) EMIT(-5) ELSE IF (X.TYP=CHARSP) AND (Y.TYP=CHARS) THEN (*INSERTION*) EMIT(-6) ELSE IF (X.TYP=PACKEDS) AND (Y.TYP=CHARS) THEN IF Y.REF=-1 THEN EMIT1(-10,X.REF) ELSE ERROR(46) ELSE IF(X.TYP<>NOTYP) AND (Y.TYP<>NOTYP) THEN ERROR(46) END (*ASSIGNMENT*) ; PROCEDURE COMPOUNDSTATEMENT; BEGIN INSYMBOL; STATEMENT([SEMICOLON,ENDSY]+FSYS); WHILE SY IN [SEMICOLON]+STATBEGSYS DO BEGIN IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); STATEMENT([SEMICOLON,ENDSY]+FSYS) END ; IF SY = ENDSY THEN INSYMBOL ELSE ERROR(57) END (*COMPOUNDSTATEMENET*) ; PROCEDURE IFSTATEMENT; VAR X: ITEM; LC1,LC2: INTEGER; BEGIN INSYMBOL; EXPRESSION(FSYS+[THENSY,DOSY], X); IF NOT (X.TYP IN[BOOLS,NOTYP]) THEN ERROR(17); LC1 := LC; EMIT(11); (*JMPC*) IF SY = THENSY THEN INSYMBOL ELSE BEGIN ERROR(52); IF SY = DOSY THEN INSYMBOL END ; STATEMENT(FSYS+[ELSESY]); IF SY = ELSESY THEN BEGIN INSYMBOL; LC2 := LC; EMIT(10); CODE[LC1].Y := LC; STATEMENT(FSYS); CODE[LC2].Y := LC END ELSE CODE[LC1].Y := LC END (*IFSTATEMENT*) ; PROCEDURE CASESTATEMENT; VAR X: ITEM; I,J,K,LC1: INTEGER; CASETAB: ARRAY [1..CSMAX] OF PACKED RECORD VAL, LC: INDEX END ; EXITTAB: ARRAY [1..CSMAX] OF INTEGER; PROCEDURE CASELABEL; VAR LAB: CONREC; K: INTEGER; BEGIN CONSTANT(FSYS+[COMMA,COLON], LAB); IF LAB.TP <> X.TYP THEN ERROR(47) ELSE IF I = CSMAX THEN FATAL(6) ELSE BEGIN I := I+1; K := 0; CASETAB[I].VAL := LAB.I; CASETAB[I].LC := LC; REPEAT K := K+1 UNTIL CASETAB[K].VAL = LAB.I; IF K < I THEN ERROR(1); (*MULTIPLE DEFINITION*) END END (*CASELABEL*) ; PROCEDURE ONECASE; BEGIN IF SY IN CONSTBEGSYS THEN BEGIN CASELABEL; WHILE SY = COMMA DO BEGIN INSYMBOL; CASELABEL END ; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); STATEMENT([SEMICOLON,ENDSY]+FSYS); J := J+1; EXITTAB[J] := LC; EMIT(10) END END (*ONECASE*) ; BEGIN INSYMBOL; I := 0; J := 0; EXPRESSION(FSYS+[OFSY,COMMA,COLON], X); IF NOT (X.TYP IN [INTS,BOOLS,CHARS,NOTYP]) THEN ERROR(23); LC1 := LC; EMIT(12); (*JMPX*) IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); ONECASE; WHILE SY = SEMICOLON DO BEGIN INSYMBOL; ONECASE END ; CODE[LC1].Y := LC; FOR K := 1 TO I DO BEGIN EMIT1(13,CASETAB[K].VAL); EMIT1(13,CASETAB[K].LC) END ; EMIT1(10,0); FOR K := 1 TO J DO CODE[EXITTAB[K]].Y := LC; IF SY = ENDSY THEN INSYMBOL ELSE ERROR(57) END (*CASESTATEMENT*) ; PROCEDURE REPEATSTATEMENT; VAR X: ITEM; LC1: INTEGER; BEGIN LC1 := LC; INSYMBOL; STATEMENT([SEMICOLON,UNTILSY]+FSYS); WHILE SY IN [SEMICOLON]+STATBEGSYS DO BEGIN IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); STATEMENT([SEMICOLON,UNTILSY]+FSYS) END ; IF SY = UNTILSY THEN BEGIN INSYMBOL; EXPRESSION(FSYS, X); IF NOT (X.TYP IN [BOOLS,NOTYP]) THEN ERROR(17); EMIT1(11,LC1) END ELSE ERROR(53) END (*REPEATSTATEMENT*) ; PROCEDURE WHILESTATEMENT; VAR X: ITEM; LC1,LC2: INTEGER; BEGIN INSYMBOL; LC1 := LC; EXPRESSION(FSYS+[DOSY], X); IF NOT (X.TYP IN [BOOLS,NOTYP]) THEN ERROR(17); LC2 := LC; EMIT(11); IF SY = DOSY THEN INSYMBOL ELSE ERROR(54); STATEMENT(FSYS); EMIT1(10,LC1); CODE[LC2].Y := LC END (*WHILESTATEMENT*) ; PROCEDURE FORSTATEMENT; VAR CVT: TYPES; X: ITEM; I,F,LC1,LC2: INTEGER; BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN I := LOC(ID); INSYMBOL; IF I = 0 THEN CVT := INTS ELSE IF TAB[I].OBJ = VARIABLE THEN BEGIN CVT := TAB[I].TYP; IF NOT TAB[I].NORMAL THEN ERROR(37) ELSE EMIT2(0, TAB[I].LEV, TAB[I].ADR); IF NOT (CVT IN [NOTYP,INTS,BOOLS,CHARS]) THEN ERROR(18) END ELSE BEGIN ERROR(37); CVT := INTS END END ELSE SKIP([BECOMES,TOSY,DOWNTOSY,DOSY]+FSYS, 2); IF SY = BECOMES THEN BEGIN INSYMBOL; EXPRESSION([TOSY,DOWNTOSY,DOSY]+FSYS, X); IF X.TYP <> CVT THEN ERROR(19); END ELSE SKIP([TOSY,DOWNTOSY,DOSY]+FSYS, 51); F := 14; IF SY IN [TOSY, DOWNTOSY] THEN BEGIN IF SY = DOWNTOSY THEN F := 16; INSYMBOL; EXPRESSION([DOSY]+FSYS, X); IF X.TYP <> CVT THEN ERROR(19) END ELSE SKIP([DOSY]+FSYS, 55); LC1 := LC; EMIT(F); IF SY = DOSY THEN INSYMBOL ELSE ERROR(54); LC2 := LC; STATEMENT(FSYS); EMIT1(F+1,LC2); CODE[LC1].Y := LC END (*FORSTATEMENT*) ; PROCEDURE STANDPROC(N: INTEGER); VAR I,F: INTEGER; X,Y: ITEM; BEGIN CASE N OF 1,2: BEGIN (*READ*) IF NOT IFLAG THEN BEGIN ERROR(20); IFLAG := TRUE END ; IF SY = LPARENT THEN BEGIN REPEAT INSYMBOL; IF SY <> IDENT THEN ERROR(2) ELSE BEGIN I := LOC(ID); INSYMBOL; IF I <> 0 THEN IF TAB[I].OBJ <> VARIABLE THEN ERROR(37) ELSE BEGIN X.TYP := TAB[I].TYP; X.REF := TAB[I].REF; IF TAB[I].NORMAL THEN F := 0 ELSE F := 1; EMIT2(F, TAB[I].LEV, TAB[I].ADR); IF SY IN [LBRACK,LPARENT,PERIOD] THEN SELECTOR(FSYS+[COMMA,RPARENT], X); IF X.TYP IN [INTS,REALS,CHARS,NOTYP] THEN EMIT1(27, ORD(X.TYP)) ELSE IF X.TYP=PACKEDS THEN EMIT1(-17,X.REF) ELSE IF X.TYP=CHARSP THEN EMIT1(-18,X.REF) ELSE ERROR(41) END END ; TEST([COMMA,RPARENT], FSYS, 6); UNTIL SY <> COMMA; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END ; IF N = 2 THEN EMIT(62) END ; 3,4: BEGIN (*WRITE*) IF SY = LPARENT THEN BEGIN REPEAT INSYMBOL; IF SY = STRING THEN BEGIN EMIT1(24,SLENG); EMIT1(28,INUM); INSYMBOL END ELSE BEGIN EXPRESSION(FSYS+[COMMA,COLON,RPARENT], X); IF NOT (X.TYP IN STANTYPS+[CHARSP,PACKEDS,STRINGS]) THEN ERROR(41); IF SY = COLON THEN BEGIN INSYMBOL; EXPRESSION(FSYS+[COMMA,COLON,RPARENT], Y); IF Y.TYP <> INTS THEN ERROR(43); IF SY = COLON THEN BEGIN IF X.TYP <> REALS THEN ERROR(42); INSYMBOL; EXPRESSION(FSYS+[COMMA,RPARENT], Y); IF Y.TYP <> INTS THEN ERROR(43); EMIT(37) END ELSE IF X.TYP IN [PACKEDS,STRINGS,CHARSP] THEN (*CAS DE CHAINES*) EMIT2(-19,ORD(X.TYP)-ORD(PACKEDS),X.REF) ELSE (*CAS NORMAL*) EMIT1(30,ORD(X.TYP)) END ELSE IF X.TYP IN [PACKEDS,STRINGS,CHARSP] THEN (*CAS DE CHAINES*) EMIT2(-20,ORD(X.TYP)-ORD(PACKEDS),X.REF) ELSE (*CAS NORMAL*) EMIT1(29,ORD(X.TYP)) END UNTIL SY <> COMMA; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END ; IF N = 4 THEN EMIT(63) END ; 5 : EMIT(-21); (*SAUT DE PAGE*) END (*CASE*) END (*STANDPROC*) ; BEGIN (*STATEMENT*) IF SY IN STATBEGSYS+[IDENT] THEN CASE SY OF IDENT: BEGIN I := LOC(ID); INSYMBOL; IF I <> 0 THEN CASE TAB[I].OBJ OF KONSTANT, TYPE1: ERROR(45); VARIABLE: ASSIGNMENT(TAB[I].LEV, TAB[I].ADR); PROZEDURE: IF TAB[I].LEV <> 0 THEN CALL(FSYS, I) ELSE STANDPROC(TAB[I].ADR); FUNKTION: IF TAB[I].REF = DISPLAY[LEVEL] THEN ASSIGNMENT(TAB[I].LEV+1, 0) ELSE ERROR(45) END END ; BEGINSY: COMPOUNDSTATEMENT; IFSY: IFSTATEMENT; CASESY: CASESTATEMENT; WHILESY: WHILESTATEMENT; REPEATSY: REPEATSTATEMENT; FORSY: FORSTATEMENT; END; TEST(FSYS, [], 14) END (*STATEMENT*) ; BEGIN (*BLOCK*) DX := 5; PRT := T; IF LEVEL > LMAX THEN FATAL(5); TEST([LPARENT,COLON,SEMICOLON], FSYS, 14); ENTERBLOCK; DISPLAY[LEVEL] := B; PRB := B; TAB[PRT].TYP := NOTYP; TAB[PRT].REF := PRB; IF (SY = LPARENT) AND (LEVEL > 1) THEN PARAMETERLIST; BTAB[PRB].LASTPAR := T; BTAB[PRB].PSIZE := DX; IF ISFUN THEN IF SY = COLON THEN BEGIN INSYMBOL; (*FUNCTION TYPE*) IF SY = IDENT THEN BEGIN X := LOC(ID); INSYMBOL; IF X <> 0 THEN IF TAB[X].OBJ <> TYPE1 THEN ERROR(29) ELSE IF TAB[X].TYP IN STANTYPS THEN TAB[PRT].TYP := TAB[X].TYP ELSE ERROR(15) END ELSE SKIP([SEMICOLON]+FSYS, 2) END ELSE ERROR(5); IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); REPEAT IF SY = CONSTSY THEN CONSTANTDECLARATION; IF SY = TYPESY THEN TYPEDECLARATION; IF SY = VARSY THEN VARIABLEDECLARATION; BTAB[PRB].VSIZE := DX; WHILE SY IN [PROCEDURESY,FUNCTIONSY] DO PROCDECLARATION; TEST([BEGINSY], BLOCKBEGSYS+STATBEGSYS, 56) UNTIL SY IN STATBEGSYS; TAB[PRT].ADR := LC; INSYMBOL; STATEMENT([SEMICOLON,ENDSY]+FSYS); WHILE SY IN [SEMICOLON]+STATBEGSYS DO BEGIN IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); STATEMENT([SEMICOLON,ENDSY]+FSYS) END ; IF SY = ENDSY THEN INSYMBOL ELSE ERROR(57); TEST(FSYS+[PERIOD], [], 6) END (*BLOCK*) ; (*-------------------------------------------------------CONTINGENCY-*) PROCEDURE CONTINGENCY(VAR PS : PSTATUS); FORWARD; (*-------------------------------------------------------------------*) (*-------------------------------------------------------INTERPRET---*) PROCEDURE INTERPRET; (*GLOBAL CODE, TAB, BTAB*) LABEL 98; (*TRAP LABEL*) VAR IR: ORDER; (*INSTRUCTION BUFFER*) PC: INTEGER; (*PROGRAM COUNTER*) T: INTEGER; (*TOP STACK INDEX*) TOPMAX: INTEGER; (*TOP STACK INDEX MAX ATTEINT*) B: INTEGER; (*BASE INDEX*) LNCNT, OCNT, BLKCNT, CHRCNT: INTEGER; (*COUNTERS*) H1,H2,H3,H4: INTEGER; T1,TX,TY:INTEGER; TEMP:ARRAY[1..ALFAMAX] OF CHAR; TP:PACKED ARRAY[1..ALFALENG] OF CHAR; FLD: ARRAY [1..4] OF INTEGER; (*DEFAULT FIELD WIDTHS*) DISPLAY: ARRAY [1..LMAX] OF INTEGER; S: ARRAY [1..STACKSIZE] OF (*BLOCKMARK: *) RECORD CASE TYPES OF (* S B+0] = FCT RESULT *) INTS: (I: INTEGER); (* S[B+1] = RETURN ADR *) REALS: (R: REAL); (* S[B+2] = STATIC LINK *) BOOLS: (B: BOOLEAN); (* S[B+3] = DYNAMIC LINK*) CHARS: (C: CHAR); (* S[B+4] = TABLE INDEX *) PACKEDS: (P:PACKED ARRAY[1..ALFALENG] OF CHAR) END ; PROCEDURE OPEREL; (*UTILISEE DANS LE CONTEXTE DE COMPARAISON ENTRE CHAINES *) BEGIN (*OPEREL*) IF TX>TY THEN BEGIN T1:=TX-TY;H3:=H2; END ELSE BEGIN T1:=TY-TX; H3:=H1; END; WHILE (T1<>0) AND S[T].B DO BEGIN S[T].B:=S[H3].P = ALFABLANC ; T1:=T1-1; H3:=H3+1; END; END; (*OPEREL*) PROCEDURE H123; (*DETERMINE H1 ,H2 ,H3 *) BEGIN (*H123*) H1:=S[T].I; (*INDICE*) H2:=(H1-1) DIV ALFALENG ; (*NBRE DE MOTS *) H3:=(H1-1) MOD ALFALENG +1 ; (*POSITION*) END ; (*H123*) PROCEDURE H124; (*DETERMINE H1 ,H2 ,H4 *) BEGIN (*H124*) H1:=S[T-2].I; (*INDICE*) H2:=(H1-1) DIV ALFALENG ; (*NBRE DE MOTS *) H4:=(H1-1) MOD ALFALENG +1 ; (*POSITION*) END ; (*H124*) BEGIN (*INTERPRET*) S[1].I := 0; S[2].I := 0; S[3].I := -1; S[4].I := BTAB[1].LAST; B := 0; DISPLAY [1] := 0; T := BTAB[2].VSIZE - 1; TOPMAX:=0; PC := TAB[S[4].I].ADR; PS := RUN; LNCNT := 0; OCNT := 0; CHRCNT := 0; FLD[1] := 10; FLD[2] := 22; FLD[3] := 10; FLD[4] := 1; REPEAT IR := CODE[PC]; PC := PC+1; OCNT := OCNT + 1; IF T>TOPMAX THEN TOPMAX:=T ; CASE IR.F OF 0: BEGIN (*LOAD ADDRESS*) T := T+1; IF T > STACKSIZE THEN PS := STKCHK ELSE S[T].I := DISPLAY[IR.X] + IR.Y END ; 1: BEGIN (*LOAD VALUE*) T := T+1; IF T > STACKSIZE THEN PS := STKCHK ELSE S[T] := S[DISPLAY[IR.X] + IR.Y] END ; 2: BEGIN (*LOAD INDIRECT*) T := T+1; IF T > STACKSIZE THEN PS := STKCHK ELSE S[T] := S[S[DISPLAY[IR.X] + IR.Y].I] END ; 3: BEGIN (*UPDATE DISPLAY*) H1 := IR.Y; H2 := IR.X; H3 := B; REPEAT DISPLAY[1] := H3; H1 := H1-1; H3 := S[H3+2].I UNTIL H1 = H2 END ; 8: CASE IR.Y OF 0: S[T].I := ABS(S[T].I); 1: S[T].R := ABS(S[T].R); 2: S[T].I := SQR(S[T].I); 3: S[T].R := SQR(S[T].R); 4: S[T].B := ODD(S[T].I); 5: BEGIN (* S[T].C := CHR(S[T].I); *) IF (S[T].I < 0) OR (S[T].I > 63) THEN PS := INXCHK END ; 6: (* S[T].I := ORD(S[T].C) *); 7: S[T].C := SUCC(S[T].C); 8: S[T].C := PRED(S[T].C); 9: S[T].I := ROUND(S[T].R); 10: S[T].I := TRUNC(S[T].R); 11: S[T].R := SIN(S[T].R); 12: S[T].R := COS(S[T].R); 13: S[T].R := EXP(S[T].R); 14: S[T].R := LN(S[T].R); 15: S[T].R := SQRT(S[T].R); 16: S[T].R := ARCTAN(S[T].R); 17: BEGIN T := T+1; IF T > STACKSIZE THEN PS := STKCHK ELSE S[T].B := EOF(INPUT) END ; 18: BEGIN T := T+1; IF T > STACKSIZE THEN PS := STKCHK ELSE S[T].B := EOLN(INPUT) END ; END ; 9: S[T].I := S[T].I + IR.Y; (*OFFSET*) 10: PC := IR.Y; (*JUMP*) 11: BEGIN (*CONDITIONAL JUMP*) IF NOT S[T].B THEN PC := IR.Y; T := T-1 END ; 12: BEGIN (*SWITCH*) H1 := S[T].I; T := T-1; H2 := IR.Y; H3 := 0; REPEAT IF CODE[H2].F <> 13 THEN BEGIN H3 := 1; PS := CASCHK END ELSE IF CODE[H2].Y = H1 THEN BEGIN H3 := 1; PC := CODE[H2+1].Y END ELSE H2 := H2 + 2 UNTIL H3 <> 0 END ; 14: BEGIN (*FOR1UP*) H1 := S[T-1].I; IF H1 <= S[T].I THEN S[S[T-2].I].I := H1 ELSE BEGIN T := T-3; PC := IR.Y END END ; 15: BEGIN (*FOR2UP*) H2 := S[T-2].I; H1 := S[H2].I + 1; IF H1 <= S[T].I THEN BEGIN S[H2].I := H1; PC := IR.Y END ELSE T := T-3; END ; 16: BEGIN (*FOR1DOWN*) H1 := S[T-1].I; IF H1 >= S[T].I THEN S[S[T-2].I].I := H1 ELSE BEGIN PC := IR.Y; T := T-3 END END ; 17: BEGIN (*FOR2DOWN*) H2 := S[T-2].I; H1 := S[H2].I - 1; IF H1 >= S[T].I THEN BEGIN S[H2].I := H1; PC := IR.Y END ELSE T := T-3; END ; 18: BEGIN (*MARK STACK*) H1 := BTAB[TAB[IR.Y].REF].VSIZE; IF T+H1 > STACKSIZE THEN PS := STKCHK ELSE BEGIN T := T+5;S[T-1].I := H1-1; S[T].I := IR.Y END END ; 19: BEGIN (*CALL*) H1 := T - IR.Y; (*H1 POINTS TO BASE*) H2 := S[H1+4].I; (*H2 POINTS TO TAB*) H3 := TAB[H2].LEV; DISPLAY[H3+1] := H1; H4 := S[H1+3].I + H1; S[H1+1].I := PC; S[H1+2].I := DISPLAY[H3]; S[H1+3].I := B; FOR H3 := T+1 TO H4 DO S[H3].I := 0; B := H1; T := H4; PC := TAB[H2].ADR END ; 20: BEGIN (*INDEX1*) H1 := IR.Y; (*H1 POINTS TO ATAB*) H2 := ATAB[H1].LOW; H3 := S[T].I; IF H3 < H2 THEN PS := INXCHK ELSE IF H3 > ATAB[H1].HIGH THEN PS := INXCHK ELSE BEGIN T := T-1; S[T].I := S[T].I + (H3-H2) END END ; 21: BEGIN (*INDEX*) H1 := IR.Y; (*H1 POINTS TO ATAB*) H2 := ATAB[H1].LOW; H3 := S[T].I; IF H3 < H2 THEN PS := INXCHK ELSE IF H3 > ATAB[H1].HIGH THEN PS := INXCHK ELSE BEGIN T := T-1; S[T].I := S[T].I + (H3-H2)*ATAB[H1].ELSIZE END END ; 22: BEGIN (*LOAD BLOCK*) H1 := S[T].I; T := T-1; H2 := IR.Y + T; IF H2 > STACKSIZE THEN PS := STKCHK ELSE WHILE T < H2 DO BEGIN T := T+1; S[T] := S[H1]; H1 := H1+1 END END ; 23: BEGIN (*COPY BLOCK*) H1:=S[T-1].I; H2:=S[T].I; H3:=H1+IR.Y; WHILE H1

STACKSIZE THEN PS := STKCHK ELSE S[T].I := IR.Y END ; 25: BEGIN (*LOAD REAL*) T := T+1; IF T>STACKSIZE THEN PS:=STKCHK ELSE S[T].R:=RCONST[IR.Y] ; END ; 26: BEGIN (*FLOAT*) H1 := T - IR.Y; S[H1].R := S[H1].I END ; 27: BEGIN (*READ*) IF EOF(INPUT) THEN PS := REDCHK ELSE CASE IR.Y OF 1: READ(S[S[T].I].I); 2: READ(S[S[T].I].R); 4: READ(S[S[T].I].C); END ; T := T-1 END ; 28: BEGIN (*WRITE STRING*) H1 := S[T].I; H2 := IR.Y; T := T-1; CHRCNT := CHRCNT+H1; IF CHRCNT > LINELENG THEN PS := LNGCHK; REPEAT WRITE(STAB[H2]); H1 := H1-1; H2 := H2+1 UNTIL H1 = 0 END ; 29: BEGIN (*WRITE1*) CHRCNT := CHRCNT + FLD[IR.Y]; IF CHRCNT > LINELENG THEN PS := LNGCHK ELSE CASE IR.Y OF 1: WRITE(S[T].I: FLD[1]); 2: WRITE(S[T].R: FLD[2]); 3: WRITE(S[T].B: FLD[3]); 4: WRITE(CHR(S[T].I MOD 64)); END ; T := T-1 END ; 30: BEGIN (*WRITE2*) CHRCNT := CHRCNT + S[T].I; IF CHRCNT > LINELENG THEN PS := LNGCHK ELSE CASE IR.Y OF 1: WRITE(S[T-1].I: S[T].I); 2: WRITE(S[T-1].R: S[T].I); 3: WRITE(S[T-1].B: S[T].I); 4: WRITE(CHR(S[T-1].I MOD 64): S[T].I); END ; T := T-2 END ; 31: PS := FIN; 32: BEGIN (*EXIT PROCEDURE*) T := B-1; PC := S[B+1].I; B := S[B+3].I END ; 33: BEGIN (*EXIT FUNCTION*) T := B; PC := S[B+1].I; B := S[B+3].I END ; 34: S[T] := S[S[T].I]; 35: S[T].B := NOT S[T].B; 36: S[T].I := - S[T].I; 37: BEGIN CHRCNT := CHRCNT + S[T-1].I; IF CHRCNT > LINELENG THEN PS := LNGCHK ELSE WRITE(S[T-2].R: S[T-1].I: S[T].I); T := T-3 END ; 38: BEGIN (*STORE*) S[S[T-1].I] := S[T]; T := T-2 END ; 39: BEGIN T := T-1; S[T].B := S[T].R = S[T+1].R END ; 40: BEGIN T := T-1; S[T].B := S[T].R <> S[T+1].R END ; 41: BEGIN T := T-1; S[T].B := S[T].R < S[T+1].R END ; 42: BEGIN T := T-1; S[T].B := S[T].R <= S[T+1].R END ; 43: BEGIN T := T-1; S[T].B := S[T].R > S[T+1].R END ; 44: BEGIN T := T-1; S[T].B := S[T].R >= S[T+1].R END ; 45: BEGIN T := T-1; S[T].B := S[T].I = S[T+1].I END ; 46: BEGIN T := T-1; S[T].B := S[T].I <> S[T+1].I END ; 47: BEGIN T := T-1; S[T].B := S[T].I < S[T+1].I END ; 48: BEGIN T := T-1; S[T].B := S[T].I <= S[T+1].I END ; 49: BEGIN T := T-1; S[T].B := S[T].I > S[T+1].I END ; 50: BEGIN T := T-1; S[T].B := S[T].I >= S[T+1].I END ; 51: BEGIN T := T-1; S[T].B := S[T].B OR S[T+1].B END ; 52: BEGIN T := T-1; S[T].I := S[T].I + S[T+1].I END ; 53: BEGIN T := T-1; S[T].I := S[T].I - S[T+1].I END ; 54: BEGIN T := T-1; S[T].R := S[T].R + S[T+1].R; END ; 55: BEGIN T := T-1; S[T].R := S[T].R - S[T+1].R; END ; 56: BEGIN T := T-1; S[T].B := S[T].B AND S[T+1].B END ; 57: BEGIN T := T-1; S[T].I := S[T].I * S[T+1].I END ; 58: BEGIN T := T-1; IF S[T+1].I = 0 THEN PS := DIVCHK ELSE S[T].I := S[T].I DIV S[T+1].I END ; 59: BEGIN T := T-1; IF S[T+1].I = 0 THEN PS := DIVCHK ELSE S[T].I := S[T].I MOD S[T+1].I END ; 60: BEGIN T := T-1; S[T].R := S[T].R * S[T+1].R; END ; 61: BEGIN T := T-1; S[T].R := S[T].R / S[T+1].R; END ; 62: IF EOF(INPUT) THEN PS := REDCHK ELSE READLN; 63: BEGIN WRITELN; LNCNT := LNCNT + 1; CHRCNT := 0; IF LNCNT > LINELIMIT THEN PS := LINCHK END; -1: BEGIN (*AFFECTATIONS ENTRE STRUCTURES EMPAQUETEES*) (* L.ALGORITHME UTILISE EST COUTEUX LORSQUE TY<TY THEN H3:=TY+1 ELSE H3:=TX+1; FOR T1:=H3 TO TX+H4 DO TEMP[T1]:=' '; H3:=H1+((TX-1) DIV ALFALENG); H4:=1; WHILE H1<=H3 DO BEGIN PACK(TEMP,H4,S[H1].P); H4:=H4+ALFALENG; H1:=H1+1; END; T:=T-2 END ;(*-1*) -2: BEGIN (*DEPAQUETAGE*) T1:=IR.Y MOD 1000 ;(*Y.REF*) IF T1<>0 THEN (*VARIABLE CHAINE*) BEGIN TY:=ATAB[T1].HIGH-ATAB[T1].LOW+1; H4:=ATAB[T1].SIZE; T1:=IR.Y DIV 1000 ;TX:=ATAB[T1].HIGH-ATAB[T1].LOW+1; H3:=S[T].I; H1:=S[T-1].I; FOR H2:=1 TO H4 DO UNPACK(S[H3+H2-1].P,TEMP,(H2-1)*ALFALENG+1); IF TX<=TY THEN FOR H2:=1 TO TX DO S[H1+H2-1].C:=TEMP[H2] ELSE BEGIN FOR H2:=1 TO TY DO S[H1+H2-1].C:=TEMP[H2]; FOR H2:=TY+1 TO TX DO S[H1+H2-1].C:=' '; END; END ELSE (*DEPAQUETAGE D.UNE CTE CHAINE*) BEGIN TY:=S[T].I MOD 1000 ;(*LONG DE LA CHAINE*) H4:=S[T].I DIV 1000 ; (*LOCATION DE LA CHAINE DANS STAB*) T1:=IR.Y DIV 1000;(*X.REF*) TX:=ATAB[T1].HIGH-ATAB[T1].LOW+1; H3:=S[T-1].I; IF TY>=TX THEN FOR H2:=1 TO TX DO S[H3+H2-1].C:=STAB[H4+H2-1] ELSE BEGIN FOR H2:=1 TO TY DO S[H3+H2-1].C:=STAB[H4+H2-1]; FOR H2:=TY+1 TO TX DO S[H3+H2-1].C:=' ' END END; T:=T-2; END; (*-2*) -3: BEGIN (*EMPAQUETAGE*) T1:=IR.Y MOD 1000; (*Y.REF*) TY:=ATAB[T1].HIGH-ATAB[T1].LOW+1; (*LONG. TABLEAU*) T1:=IR.Y DIV 1000; (*X.REF*) TX:=ATAB[T1].HIGH-ATAB[T1].LOW+1; (*LONG. CHAINE*) H2:=S[T].I; H3:=S[T-1].I; H1:=1; WHILE (H1<=ALFAMAX) AND (H1<=TY) DO BEGIN TEMP[H1]:=S[H2].C; H2:=H2+1; H1:=H1+1; END; WHILE H1<=ALFAMAX DO BEGIN TEMP[H1]:=' '; H1:=H1+1; END; H1:=1; WHILE TY>0 DO BEGIN PACK(TEMP,H1,TP); S[H3].P:=TP; H3:=H3+1; TY:=TY-ALFALENG; H1:=H1+ALFALENG; END; T:=T-2; END; (*-3*) -4: BEGIN (*AFFECTATION DE CHAINE CTES *) TY:=S[T].I MOD 1000 ; (*LONG CHAINE DANS STAB*) T1:=IR.Y; TX:=ATAB[T1].HIGH-ATAB[T1].LOW+1; H4:=S[T].I DIV 1000; (*LOCATION CHAINE DANS STAB*) H2:=S[T-1].I ;H1:=1; WHILE (H1<=TY) AND (H1<=TX) DO BEGIN H3:=1; WHILE (H3<=ALFALENG) AND (H1<=TX) AND (H1<=TY) DO BEGIN S[H2].P[H3]:=STAB[H4+H1-1]; H1:=H1+1;H3:=H3+1; END; H2:=H2+1; END; IF TX>TY THEN (*CAS D.AJUSTEMENT UNIQUEMENT*) BEGIN WHILE H3 <= ALFALENG DO BEGIN S[H2-1].P[H3]:=' '; H3:=H3+1; END; T1:=ATAB[T1].SIZE; H3:=H2-S[T-1].I; WHILE H3STACKSIZE THEN PS:=STKCHK ELSE S[T].I:=IR.Y END; (*-8*) -9: BEGIN (*PREPARATION EXTRACTION*) (*VERIFICATION D.INDICE UNIQUEMENT*) H1:=IR.Y; (*REF. DANS ATAB*) H3:=S[T].I; (*INDICE*) H2:=ATAB[H1].LOW; (*BORNE INF.*) H4:=ATAB[H1].HIGH; (*BORNE SUP.*) IF (H3H4) THEN PS:=INXCHK ELSE S[T].I:=H3-H2+1; END; (*-9*) -10: BEGIN (*AFFECTATION D.UN CARACTERE A UNE CHAINE*) H1:=ATAB[IR.Y].HIGH -ATAB[IR.Y].LOW+1; H2:=S[T-1].I; H3:=(H1-1) DIV ALFALENG ; TP:=ALFABLANC; TP[1]:=S[T].C; S[H2].P:=TP; WHILE H3<>0 DO BEGIN H2:=H2+1; H3:=H3-1; S[H2].P:=ALFABLANC; END; T:=T-2; END; (*-10*) -11, (*COMPARAISON ENTRE CARACTERES DE CHAINES *) -13, (*COMPARAISON ENTRE CARACTERES DE CHAINE ET CARACTERES*) -14: BEGIN (*COMPARAISON ENTRE CARACTERES ET CARACTERES DE CHAINE*) T:=T-1; CASE IR.Y OF 0 : S[T].B:= S[T].C = S[T+1].C ; 1 : S[T].B:= S[T].C <> S[T+1].C ; 2 : S[T].B:= S[T].C < S[T+1].C ; 3 : S[T].B:= S[T].C <= S[T+1].C ; 4 : S[T].B:= S[T].C > S[T+1].C ; 5 : S[T].B:= S[T].C >= S[T+1].C ; END; (*CASE*) END; (*-11,-13,-14*) -12: BEGIN (*TESTS DE COMPARAISON ENTRE STRUCTURES EMPAQUETEES*) TY:=ATAB[IR.Y MOD 1000].SIZE; (*Y.SIZE*) TX:=ATAB[IR.Y DIV 1000].SIZE; (*X.SIZE*) IF TX<=TY THEN T1:=TX ELSE T1:=TY; H1:=S[T].I; (*ADR Y *) H2:=S[T-1].I; (*ADR X*) T:=T-1; S[T].B:=TRUE; WHILE S[T].B AND (T1<>0) DO BEGIN S[T].B:=S[H2].P=S[H1].P; H2:=H2+1; H1:=H1+1; T1:=T1-1; END; (* CASE IR.X OF 0: EQL ; 1: NEQ ; 2: LSS ; 3: LEQ ; 4: GTR ; 5: GEQ ; END ; *) IF S[T].B THEN BEGIN OPEREL; IF IR.X<>0 THEN IF S[T].B THEN CASE IR.X OF 1,2,4: S[T].B:=FALSE; END (*CASE*) ELSE CASE IR.X OF 1 : S[T].B:=TRUE; 2,3 : IF TXTY THEN S[T].B:=TRUE; END (*CASE*) END (*BEGIN*) ELSE CASE IR.X OF 0 : ; 1 : S[T].B:=TRUE; 2,3 : S[T].B:= S[H2-1].P S[H1-1].P; END (*CASE*) END; (*-12*) -15,-16: BEGIN (*COMPARAISON ENTRE VARIABLES CHAINES ET CONSTANTES CHAINES*) IF IR.F=-15 THEN BEGIN TX:=ATAB[IR.Y].HIGH-ATAB[IR.Y].LOW+1; H2:=ATAB[IR.Y].SIZE; H3:=S[T-1].I; FOR H1:=1 TO H2 DO UNPACK(S[H3+H1-1].P,TEMP,(H1-1)*ALFALENG+1); TY:=S[T].I MOD 1000; (*LONG. CHAINE CTE*) H4:=S[T].I DIV 1000; (*POSITION DS STAB*) T:=T-1; END ELSE (* IR.F=-16*) BEGIN TY:=ATAB[IR.Y].HIGH-ATAB[IR.Y].LOW+1; H2:=ATAB[IR.Y].SIZE; H3:=S[T].I; FOR H1:=1 TO H2 DO UNPACK(S[H3+H1-1].P,TEMP,(H1-1)*ALFALENG+1); T:=T-1; TX:=S[T].I MOD 1000; H4:=S[T].I DIV 1000; END; S[T].B:=TRUE; H1:=1; IF TX<=TY THEN T1:=TX ELSE T1:=TY ; WHILE S[T].B AND (T1<>0) DO BEGIN S[T].B:=TEMP[H1] = STAB[H4+H1-1]; H1:=H1+1; T1:=T1-1; END; IF S[T].B THEN BEGIN IF TX>TY THEN T1:=TX-TY ELSE T1:=TY-TX; WHILE (T1<>0) AND S[T].B DO BEGIN IF ((IR.F=-15) AND (TX>TY)) OR ((IR.F=-16) AND (TX 0 THEN IF S[T].B THEN CASE IR.X OF 1,2,4 : S[T].B:=FALSE ; END (*CASE*) ELSE CASE IR.X OF 1 : S[T].B:=TRUE; 2,3 : IF TXTY THEN S[T].B:=TRUE; END ; (*CASE*) END (*BEGIN*) ELSE CASE IR.X OF 0 : ; 1 : S[T].B:=TRUE; 2,3 : IF IR.F =-15 THEN S[T].B:=TEMP[H1-1] < STAB[H4+H1-2] ELSE S[T].B:=STAB[H4+H1-2] < TEMP[H1-1]; 4,5 : IF IR.F =-15 THEN S[T].B:=TEMP[H1-1] > STAB[H4+H1-2] ELSE S[T].B:=STAB[H4+H1-2] > TEMP[H1-1]; END ; (*CASE*) (*POSSIBILITE D.OPTIMISATION AU DETRIMENT DE LA LISIBILITE *) END; (*-15,-16*) -17: BEGIN (*LECTURE D.UNE CHAINE DE CARACTERES*) IF EOF(INPUT) THEN PS:=REDCHK ELSE BEGIN TX:=ATAB[IR.Y].HIGH-ATAB[IR.Y].LOW+1; (*LONG CHAINE*) T1:=1; WHILE NOT EOLN AND (T1<=TX) DO BEGIN READ(TEMP[T1]); T1:=T1+1; END; H2:=ATAB[IR.Y].SIZE; (*NBRE DE MOTS*) FOR H1:=T1 TO H2*ALFALENG DO TEMP[H1]:=' '; H1:=1; WHILE H2<>0 DO (*COMPACTAGE*) BEGIN PACK(TEMP,(H1-1)*ALFALENG+1,S[S[T].I+H1-1].P); H1:=H1+1; H2:=H2-1; END; END; T:=T-1; END; (*-17*) -18: BEGIN (*LECTURE D.UN CARACTERE DE CHAINE*) IF EOF(INPUT) THEN PS:=REDCHK ELSE BEGIN H123; (*INDICE,NBRE DE MOTS,POSITION*) UNPACK(S[S[T-1].I+H2].P,TEMP,1); IF EOLN THEN TEMP[H3]:=' ' ELSE READ(TEMP[H3]); PACK(TEMP,1,S[S[T-1].I+H2].P); END; T:=T-2; END; (*-18*) -19,-20: BEGIN (*IMPRESSION D.UNE CHAINE DE CARACTERES AVEC OU SANS FORMAT*) CASE IR.X OF 0 : BEGIN (*PACKEDS*) TX:=ATAB[IR.Y].HIGH-ATAB[IR.Y].LOW+1; IF IR.F=-20 THEN H4:=TX ELSE BEGIN H4:=S[T].I; T:=T-1; END; CHRCNT:=CHRCNT+H4; IF CHRCNT>LINELENG THEN PS:=LNGCHK ELSE BEGIN H2:=ATAB[IR.Y].SIZE; FOR H1:=1 TO H2 DO UNPACK(S[S[T].I+H1-1].P,TEMP,(H1-1)*ALFALENG+1); IF H4<=TX THEN (*TRONCATION*) FOR T1:=1 TO H4 DO WRITE(TEMP[T1]) ELSE (*AJUSTEMENT AVEC DES BLANCS*) BEGIN FOR T1:=1 TO (H4-TX) DO WRITE(' '); FOR T1:=1 TO TX DO WRITE(TEMP[T1]); END; END; END; (*PACKEDS*) 1 : BEGIN (*STRINGS*) IF IR.F=-19 THEN T:=T-1; H2:=S[T].I DIV 1000 ; (*POS DS STAB*) TX:=S[T].I MOD 1000 ; (*LONG*) IF IR.F=-20 THEN H4:=TX ELSE H4:=S[T+1].I; CHRCNT:=CHRCNT+H4; IF CHRCNT>LINELENG THEN PS:=LNGCHK ELSE BEGIN IF H4<=TX THEN (*TRONCATION*) FOR T1:=0 TO (H4-TX) DO WRITE(STAB[H2+T1]) ELSE BEGIN (*AJUSTEMENT*) FOR T1:=1 TO (H4-TX) DO WRITE(' '); FOR T1:=0 TO (TX-1) DO WRITE(STAB[H2+T1]); END; END; END; (*STRINGS*) 2 : BEGIN (*CHARSP*) IF IR.F=-20 THEN H4:=1 ELSE BEGIN H4:=S[T].I; T:=T-1; END; CHRCNT:=CHRCNT+H4; IF CHRCNT>LINELENG THEN PS:=LNGCHK ELSE BEGIN IF H4>1 THEN FOR T1:=1 TO (H4-1) DO WRITE(' '); WRITE(S[T].C); END; END; (*CHARSP*) END; (*CASE*) T:=T-1; END; (*-19,-20*) -21 : PAGE; (*SAUT DE PAGE*) -22 : BEGIN (*EXTRACTION,PREPARATION CARACTERE DE CHAINE*) H123; (*INDICE, NBRE DE MOTS ,POSITION*) T:=T-1; UNPACK(S[S[T].I+H2].P,TEMP,1); S[T].C:=TEMP[H3]; END; (*-22*) -23 : BEGIN (* FUNCTION DE HASHCODING *) (* ALGORITHME : FUNCTION HASH(ID:IDENTIFIER,TABLE_LENGTH:INTEGER):INTEGER; VAR KEY,I:INTEGER;C:CHAR; BEGIN KEY:=1;I:=0; REPEAT I:=I+1; C:=ID[I]; IF C<>' ' THEN KEY:=KEY*ORD(C) MOD TABLE_LENGTH+1; UNTIL (C=' ') OR (I=IDLENGTH); HASH:=KEY; END; *) TX:=ATAB[IR.Y].HIGH-ATAB[IR.Y].LOW+1; H1:=ATAB[IR.Y].ELSIZE; T:=T-1; H3:=S[T].I; H4:=1; FOR H2:=1 TO H1 DO BEGIN UNPACK(S[H3].P,TEMP,H4); H3:=H3+1; H4:=H4+ALFALENG; END; H1:=S[T+1].I; (*TABLE-LENGTH*) H2:=1; (*KEY *) H3:=0; (*I *) REPEAT H3:=H3+1; IF TEMP[H3]<>' ' THEN H2:=H2*ORD(TEMP[H3]) MOD H1+1; UNTIL (TEMP[H3]=' ') OR (H3=TX) ; S[T].I:=H2; END; (*-23*) END (*CASE*) ; UNTIL PS <> RUN; 98: IF PS <> FIN THEN BEGIN WRITELN; WRITE(' HALT AT', PC:5, ' BECAUSE OF '); CASE PS OF RUN: WRITELN('ERROR (SEE DAYFILE)'); CASCHK: WRITELN('UNDEFINED CASE'); DIVCHK: WRITELN('DIVISION BY 0'); INXCHK: WRITELN('INVALID INDEX'); STKCHK: WRITELN('STORAGE OVERFLOW'); LINCHK: WRITELN('TOO MUCH OUTPUT'); LNGCHK: WRITELN('LINE TOO LONG'); REDCHK: WRITELN('READING PAST END OF FILE'); IOPR : WRITELN('ILLEGAL OPERATION'); IGDM : WRITELN('GUARD MODE OR UNDEFINED SEQUENCE'); IFOF : WRITELN('FLOATING POINT OVERFLOW'); IFUF : WRITELN('FLOATING POINT UNDERFLOW'); IDOF : WRITELN('DIVIDE FAULT (DIV. BY ZERO OR OVERFLOW)'); IOERR : WRITELN('I/O CALL ERROR'); SYMBERR:WRITELN('SYMBIONT CALL ERROR'); ERRCALL:WRITELN('CALL ON ERR$'); END ; H1 := B; BLKCNT := 10; (*POST MORTEM DUMP*) REPEAT WRITELN; BLKCNT := BLKCNT - 1; IF BLKCNT = 0 THEN H1 := 0; H2 := S[H1+4].I; IF H1<>0 THEN WRITELN(' ', TAB[H2].NAME, ' CALLED AT', S[H1+1].I: 5); H2 := BTAB[TAB[H2].REF].LAST; WHILE H2 <> 0 DO WITH TAB[H2] DO BEGIN IF OBJ = VARIABLE THEN IF TYP IN STANTYPS THEN BEGIN WRITE(' ', NAME, ' = '); IF NORMAL THEN H3 := H1+ADR ELSE H3 := S[H1+ADR].I; CASE TYP OF INTS: WRITELN(S[H3].I); REALS: WRITELN(S[H3].R); BOOLS: WRITELN(ORD(S[H3].B)); CHARS: WRITELN(CHR(S[H3].I MOD 64)); END END ; H2 := LINK END ; H1 := S[H1+3].I UNTIL H1 < 0; END ; WRITELN; WRITELN(OCNT, ' STEPS'); WRITELN; IF PRINTB THEN WRITELN(TOPMAX,' TOPMAX'); END (*INTERPRET*) ; (*------------------------------------------------------------MAIN----*) BEGIN (*MAIN*) WRITELN('-- PASCAL-S --');WRITELN; KEY [1] := 'AND '; KEY [2] := 'ARRAY '; KEY [3] := 'BEGIN '; KEY [4] := 'CASE '; KEY [5] := 'CONST '; KEY [6] := 'DIV '; KEY [8] := 'DOWNTO '; KEY [7] := 'DO '; KEY [9] := 'ELSE '; KEY [10] := 'END '; KEY[11] := 'FOR '; KEY[12] := 'FUNCTION '; KEY[13] := 'IF '; KEY[14] := 'MOD '; KEY[15] := 'NOT '; KEY[16] := 'OF '; KEY[17] := 'OR '; KEY[19] := 'PROCEDURE '; KEY[20] := 'PROGRAM '; KEY[21] := 'RECORD '; KEY[22] := 'REPEAT '; KEY[23] := 'STRING '; KEY[24] := 'THEN '; KEY[25] := 'TO '; KEY[26] := 'TYPE '; KEY[27] := 'UNTIL '; KEY[28] := 'VAR '; KEY[29] := 'WHILE '; KEY[18] := 'PACKED '; KSY [1] := ANDSY; KSY [2] := ARRAYSY; KSY [3] := BEGINSY; KSY [4] := CASESY; KSY [5] := CONSTSY; KSY [6] := IDIV; KSY [8] := DOWNTOSY; KSY [7] := DOSY; KSY [9] := ELSESY; KSY [10] := ENDSY; KSY [11] := FORSY; KSY [12] := FUNCTIONSY; KSY [13] := IFSY; KSY [14] := IMOD; KSY [15] := NOTSY; KSY [16] := OFSY; KSY [17] := ORSY; KSY [19] := PROCEDURESY; KSY [20] := PROGRAMSY; KSY [21] := RECORDSY; KSY[22] := REPEATSY; KSY[23] := STRINGSY; KSY[24]:= THENSY; KSY[25] := TOSY; KSY[26] := TYPESY; KSY[27] := UNTILSY; KSY[28] := VARSY; KSY[29] := WHILESY ; KSY[18] := PACKEDSY ; SPS['+'] := PLUS; SPS['-'] := MINUS; SPS['*'] := TIMES; SPS['/'] := RDIV; SPS['('] := LPARENT; SPS[')'] := RPARENT; SPS['='] := EQL; SPS[','] := COMMA; SPS['['] := LBRACK; SPS[']'] := RBRACK; SPS['"'] := NEQ; SPS['&'] := ANDSY; SPS[';'] := SEMICOLON; CONSTBEGSYS := [PLUS,MINUS,INTCON,REALCON,CHARCON,IDENT,STRING]; TYPEBEGSYS := [IDENT,ARRAYSY,RECORDSY,PACKEDSY,STRINGSY]; BLOCKBEGSYS := [CONSTSY,TYPESY,VARSY,PROCEDURESY,FUNCTIONSY,BEGINSY]; FACBEGSYS := [INTCON,REALCON,CHARCON,IDENT,LPARENT,NOTSY]; STATBEGSYS := [BEGINSY,IFSY,WHILESY,REPEATSY,FORSY,CASESY]; STANTYPS := [NOTYP,INTS,REALS,BOOLS,CHARS]; STRTAB[1,1]:=0; (*INIT. TABLEAU POINT. SUR CHAINES*) LC := 0; LL := 0; CC := 0; CH := ' '; ERRPOS := 0; ERRS := []; T := -1; A := 1; B := 1; SX := 0; C2 := 0; DISPLAY[0] := 1; RESET(INPUT); INSYMBOL; PRINTC:=FALSE; IFLAG := FALSE; PRINTB := FALSE; OFLAG := FALSE; SKIPFLAG := FALSE; IF SY <> PROGRAMSY THEN ERROR(3) ELSE BEGIN INSYMBOL; IF SY <> IDENT THEN ERROR(2) ELSE BEGIN PROGNAME := ID; INSYMBOL; IF SY <> LPARENT THEN ERROR(9) ELSE REPEAT INSYMBOL; IF SY <> IDENT THEN ERROR(2) ELSE BEGIN IF ID = 'INPUT ' THEN IFLAG := TRUE ELSE IF ID='PMD ' THEN PRINTB:= TRUE ELSE IF ID='PMDC ' THEN BEGIN PRINTB:=TRUE; PRINTC:=TRUE; END ELSE IF ID = 'OUTPUT ' THEN OFLAG := TRUE ELSE ERROR(0); INSYMBOL END UNTIL SY <> COMMA; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4); IF NOT OFLAG THEN ERROR(20) END END ; ENTER(' ', VARIABLE, NOTYP, 0); (*SENTINEL*) ENTER('ALFA ',TYPE1,PACKEDS,1); ENTER('ALFALENG ',KONSTANT,INTS,12); ENTER('FALSE ', KONSTANT, BOOLS, 0); ENTER('TRUE ', KONSTANT, BOOLS, 1); ENTER('REAL ', TYPE1, REALS, 1); ENTER('CHAR ', TYPE1, CHARS, 1); ENTER('BOOLEAN ', TYPE1, BOOLS, 1); ENTER('INTEGER ', TYPE1, INTS , 1); ENTER('ABS ', FUNKTION, REALS,0); ENTER('SQR ', FUNKTION, REALS,2); ENTER('ODD ', FUNKTION, BOOLS,4); ENTER('CHR ', FUNKTION, CHARS,5); ENTER('ORD ', FUNKTION, INTS, 6); ENTER('SUCC ', FUNKTION, CHARS,7); ENTER('PRED ', FUNKTION, CHARS,8); ENTER('ROUND ', FUNKTION, INTS, 9); ENTER('TRUNC ', FUNKTION, INTS, 10); ENTER('SIN ', FUNKTION, REALS, 11); ENTER('COS ', FUNKTION, REALS, 12); ENTER('EXP ', FUNKTION, REALS, 13); ENTER('LN ', FUNKTION, REALS, 14); ENTER('SQRT ', FUNKTION, REALS, 15); ENTER('ARCTAN ', FUNKTION, REALS, 16); ENTER('EOF ', FUNKTION, BOOLS, 17); ENTER('EOLN ', FUNKTION, BOOLS, 18); ENTER('HASH ',FUNKTION,INTS,20); ENTER('READ ', PROZEDURE, NOTYP, 1); ENTER('READLN ', PROZEDURE, NOTYP, 2); ENTER('WRITE ', PROZEDURE, NOTYP, 3); ENTER('WRITELN ', PROZEDURE, NOTYP, 4); ENTER('PAGE ',PROZEDURE,NOTYP,5); ENTER(' ', PROZEDURE, NOTYP, 0); WITH BTAB[1] DO BEGIN LAST := T; LASTPAR := 1; PSIZE := 0; VSIZE := 0 END ; (*INITIALISATION DE ATAB[POUR LE TYPE PREDEFINI : ALFA , ALFA=STRING[1..ALFALENG] OF CHAR; *) TAB[1].REF:=A ; TAB[1].LEV:=0 ; ATAB[A].INXTYP:=INTS ; ATAB[A].ELTYP:=CHARSP ; ATAB[A].ELREF:=0 ; ATAB[A].LOW:=1 ; ATAB[A].HIGH:=ALFALENG ; ATAB[A].ELSIZE:=1 ; ATAB[A].SIZE:=1 ; (*FIN INITIALISATION*) BLOCK(BLOCKBEGSYS+STATBEGSYS, FALSE, 1); IF SY <> PERIOD THEN ERROR(22); EMIT(31); (*HALT*) IF BTAB[2].VSIZE > STACKSIZE THEN ERROR(49); IF PROGNAME='TEST0 ' THEN PRINTTABLES ELSE IF PRINTB THEN BEGIN PRINTTABLES; PRINTSTRINGS; END; IF ERRS = [] THEN BEGIN IF IFLAG THEN IF EOF(INPUT) THEN WRITELN(' INPUT DATA MISSING') ; WRITELN(' (EOF)'); WRITELN; CONTINGENCY(PS); INTERPRET END ELSE ERRORMSG; 99: WRITELN END . @@