(* COPYRIGHT (C) 1978, REGENTS OF THE *) (* UNIVERSITY OF CALIFORNIA, SAN DIEGO *) PROCEDURE SEARCHSECTION(*FCP: CTP; VAR FCP1: CTP*); BEGIN IF FCP <> NIL THEN IF TREESEARCH(FCP,FCP1,ID) = 0 THEN (*NADA*) ELSE FCP1 := NIL ELSE FCP1 := NIL END (*SEARCHSECTION*) ; PROCEDURE SEARCHID(*FIDCLS: SETOFIDS; VAR FCP: CTP*); LABEL 1; VAR LCP: CTP; BEGIN FOR DISX := TOP DOWNTO 0 DO BEGIN LCP := DISPLAY[DISX].FNAME; IF LCP <> NIL THEN IF TREESEARCH(LCP,LCP,ID) = 0 THEN IF LCP^.KLASS IN FIDCLS THEN GOTO 1 ELSE IF PRTERR THEN ERROR(103) ELSE LCP := NIL ELSE LCP := NIL END; IF PRTERR THEN BEGIN ERROR(104); IF TYPES IN FIDCLS THEN LCP := UTYPPTR ELSE IF ACTUALVARS IN FIDCLS THEN LCP := UVARPTR ELSE IF FIELD IN FIDCLS THEN LCP := UFLDPTR ELSE IF KONST IN FIDCLS THEN LCP := UCSTPTR ELSE IF PROC IN FIDCLS THEN LCP := UPRCPTR ELSE LCP := UFCTPTR END; 1: FCP := LCP END (*SEARCHID*) ; PROCEDURE GETBOUNDS(*FSP: STP; VAR FMIN,FMAX: INTEGER*); BEGIN WITH FSP^ DO IF FORM = SUBRANGE THEN BEGIN FMIN := MIN.IVAL; FMAX := MAX.IVAL END ELSE BEGIN FMIN := 0; IF FSP = CHARPTR THEN FMAX := 255 ELSE IF FSP^.FCONST <> NIL THEN FMAX := FSP^.FCONST^.VALUES.IVAL ELSE FMAX := 0 END END (*GETBOUNDS*) ; PROCEDURE SKIP(*FSYS: SETOFSYS*); BEGIN WHILE NOT(SY IN FSYS) DO INSYMBOL END (*SKIP*) ; FUNCTION PAOFCHAR(*FSP: STP): BOOLEAN*); BEGIN PAOFCHAR := FALSE; IF FSP <> NIL THEN IF FSP^.FORM = ARRAYS THEN PAOFCHAR := FSP^.AISPACKD AND (FSP^.AELTYPE = CHARPTR) END (*PAOFCHAR*) ; FUNCTION STRGTYPE(*FSP: STP) : BOOLEAN*); BEGIN STRGTYPE := FALSE; IF PAOFCHAR(FSP) THEN STRGTYPE := FSP^.AISSTRNG END (*STRGTYPE*) ; FUNCTION DECSIZE(*I: INTEGER): INTEGER*); BEGIN DECSIZE := (TRUNC(I*3.321) + 1 + BITSPERWD) DIV BITSPERWD END (*DECSIZE*) ; PROCEDURE CONSTANT(*FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU*); VAR LSP: STP; LCP: CTP; SIGN: (NONE,POS,NEG); LVP: CSP; BEGIN LSP := NIL; FVALU.IVAL := 0; IF NOT(SY IN CONSTBEGSYS) THEN BEGIN ERROR(50); SKIP(FSYS+CONSTBEGSYS) END; IF SY IN CONSTBEGSYS THEN BEGIN IF SY = STRINGCONSTSY THEN BEGIN IF LGTH = 1 THEN LSP := CHARPTR ELSE BEGIN NEW(LSP,ARRAYS,TRUE,TRUE); LSP^ := STRGPTR^; LSP^.MAXLENG := LGTH; LSP^.INXTYPE := NIL; NEW(LVP); LVP^ := VAL.VALP^; VAL.VALP := LVP END; FVALU := VAL; INSYMBOL END ELSE BEGIN SIGN := NONE; IF (SY = ADDOP) AND (OP IN [PLUS,MINUS]) THEN BEGIN IF OP = PLUS THEN SIGN := POS ELSE SIGN := NEG; INSYMBOL END; IF SY = IDENT THEN BEGIN SEARCHID([KONST],LCP); WITH LCP^ DO BEGIN LSP := IDTYPE; FVALU := VALUES END; IF SIGN <> NONE THEN IF LSP = INTPTR THEN BEGIN IF SIGN = NEG THEN FVALU.IVAL := -FVALU.IVAL END ELSE IF LSP = REALPTR THEN BEGIN IF SIGN = NEG THEN BEGIN NEW(LVP,REEL); LVP^.CCLASS := REEL; LVP^.RVAL := -FVALU.VALP^.RVAL; FVALU.VALP := LVP; END END ELSE IF COMPTYPES(LSP,LONGINTPTR) THEN BEGIN IF SIGN = NEG THEN BEGIN NEW(LVP,LONG); LVP^.CCLASS := LONG; LVP^.LONGVAL[1] := - FVALU.VALP^.LONGVAL[1]; FVALU.VALP := LVP END END ELSE ERROR(105); INSYMBOL; END ELSE IF SY = INTCONST THEN BEGIN IF SIGN = NEG THEN VAL.IVAL := -VAL.IVAL; LSP := INTPTR; FVALU := VAL; INSYMBOL END ELSE IF SY = REALCONST THEN BEGIN IF SIGN = NEG THEN VAL.VALP^.RVAL := -VAL.VALP^.RVAL; LSP := REALPTR; FVALU := VAL; INSYMBOL END ELSE IF SY = LONGCONST THEN BEGIN IF SIGN = NEG THEN BEGIN VAL.VALP^.LONGVAL[1] := - VAL.VALP^.LONGVAL[1]; NEW(LSP,LONGINT); LSP^.SIZE := DECSIZE(LGTH); LSP^.FORM := LONGINT; FVALU := VAL; INSYMBOL END END ELSE BEGIN ERROR(106); SKIP(FSYS) END END; IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END END; FSP := LSP END (*CONSTANT*) ; FUNCTION COMPTYPES(*FSP1,FSP2: STP) : BOOLEAN*); VAR NXT1,NXT2: CTP; COMP: BOOLEAN; LTESTP1,LTESTP2 : TESTP; BEGIN IF FSP1 = FSP2 THEN COMPTYPES := TRUE ELSE IF (FSP1 = NIL) OR (FSP2 = NIL) THEN COMPTYPES := TRUE ELSE IF FSP1^.FORM = FSP2^.FORM THEN CASE FSP1^.FORM OF SCALAR: COMPTYPES := FALSE; SUBRANGE: COMPTYPES := COMPTYPES(FSP1^.RANGETYPE, FSP2^.RANGETYPE); POINTER: BEGIN COMP := FALSE; LTESTP1 := GLOBTESTP; LTESTP2 := GLOBTESTP; WHILE LTESTP1 <> NIL DO WITH LTESTP1^ DO BEGIN IF (ELT1 = FSP1^.ELTYPE) AND (ELT2 = FSP2^.ELTYPE) THEN COMP := TRUE; LTESTP1 := LASTTESTP END; IF NOT COMP THEN BEGIN NEW(LTESTP1); WITH LTESTP1^ DO BEGIN ELT1 := FSP1^.ELTYPE; ELT2 := FSP2^.ELTYPE; LASTTESTP := GLOBTESTP END; GLOBTESTP := LTESTP1; COMP := COMPTYPES(FSP1^.ELTYPE,FSP2^.ELTYPE) END; COMPTYPES := COMP; GLOBTESTP := LTESTP2 END; LONGINT: COMPTYPES := TRUE; POWER: COMPTYPES := COMPTYPES(FSP1^.ELSET,FSP2^.ELSET); ARRAYS: BEGIN COMP := COMPTYPES(FSP1^.AELTYPE,FSP2^.AELTYPE) AND (FSP1^.AISPACKD = FSP2^.AISPACKD); IF COMP AND FSP1^.AISPACKD THEN COMP := (FSP1^.ELSPERWD = FSP2^.ELSPERWD) AND (FSP1^.ELWIDTH = FSP2^.ELWIDTH) AND (FSP1^.AISSTRNG = FSP2^.AISSTRNG); IF COMP AND NOT STRGTYPE(FSP1) THEN COMP := (FSP1^.SIZE = FSP2^.SIZE); COMPTYPES := COMP; END; RECORDS: BEGIN NXT1 := FSP1^.FSTFLD; NXT2 := FSP2^.FSTFLD; COMP := TRUE; WHILE (NXT1 <> NIL) AND (NXT2 <> NIL) AND COMP DO BEGIN COMP:=COMPTYPES(NXT1^.IDTYPE,NXT2^.IDTYPE); NXT1 := NXT1^.NEXT; NXT2 := NXT2^.NEXT END; COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL) AND (FSP1^.RECVAR = NIL) AND (FSP2^.RECVAR = NIL) END; FILES: COMPTYPES := COMPTYPES(FSP1^.FILTYPE,FSP2^.FILTYPE) END (*CASE*) ELSE (*FSP1^.FORM <> FSP2^.FORM*) IF FSP1^.FORM = SUBRANGE THEN COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2) ELSE IF FSP2^.FORM = SUBRANGE THEN COMPTYPES := COMPTYPES(FSP1,FSP2^.RANGETYPE) ELSE COMPTYPES := FALSE END (*COMPTYPES*) ; PROCEDURE GENBYTE(*FBYTE: INTEGER*); BEGIN CODEP^[IC] := CHR(FBYTE); IC := IC+1 END (*GENBYTE*) ; PROCEDURE GENWORD(*FWORD: INTEGER*); BEGIN IF ODD(IC) THEN IC := IC + 1; MOVELEFT(FWORD,CODEP^[IC],2); IC := IC + 2 END (*GENWORD*) ; PROCEDURE WRITETEXT; BEGIN MOVELEFT(SYMBUFP^[SYMCURSOR],CODEP^[0],1024); IF USERINFO.ERRNUM = 0 THEN IF BLOCKWRITE(USERINFO.WORKCODE^,CODEP^[0],2,CURBLK) <> 2 THEN ERROR(402); CURBLK := CURBLK + 2 END (*WRITETEXT*) ; PROCEDURE WRITECODE(*FORCEBUF: BOOLEAN*); VAR CODEINX,LIC,I: INTEGER; BEGIN CODEINX := 0; LIC := IC; REPEAT I := 512-CURBYTE; IF I > LIC THEN I := LIC; MOVELEFT(CODEP^[CODEINX],DISKBUF[CURBYTE],I); CODEINX := CODEINX+I; CURBYTE := CURBYTE+I; IF (CURBYTE = 512) OR FORCEBUF THEN BEGIN IF USERINFO.ERRNUM = 0 THEN IF BLOCKWRITE(USERINFO.WORKCODE^,DISKBUF,1,CURBLK) <> 1 THEN ERROR(402); CURBLK := CURBLK+1; CURBYTE := 0 END; LIC := LIC-I UNTIL LIC = 0; END (*WRITECODE*) ; PROCEDURE FINISHSEG; VAR I: INTEGER; BEGIN IC := 0; FOR I := NEXTPROC-1 DOWNTO 1 DO IF PROCTABLE[I] = 0 THEN GENWORD(0) ELSE GENWORD(SEGINX+IC-PROCTABLE[I]); GENBYTE(SEG); GENBYTE(NEXTPROC-1); SEGTABLE[SEG].CODELENG := SEGINX+IC; WRITECODE(TRUE); SEGINX := 0; CODEINSEG := FALSE END (*FINISHSEG*) ;