%$E-,F-,G-\ %$W-,X+\ %$R-,T-\ %********************************************************* * * * * * STEP-WISE DEVELOPMENT OF A PASCAL COMPILER * * ****************************************** * * * * * * STEP 5: SYNTAX ANALYSIS INCLUDING ERROR * * HANDLING; CHECKS BASED ON DECLARATIONS * * * * AUTHOR: URS AMMANN * * FACHGRUPPE COMPUTERWISSENSCHAFTEN * * EIDG. TECHNISCHE HOCHSCHULE * * CH-8006 ZUERICH * * * * ADAPTED TO GENERATE CODE FOR A * * PDP 11 BY: * * W. DE VRIES * * UNDER GUIDANCE OF DRS C. BRON * * VAKGROEP INFORMATICA * * TECHNISCHE HOGESCHOOL TWENTE ENSCHEDE * * APRIL '75 * * * * CHANGED TO RUN UNDER RSX-11M BY: * * SEVED TORSTENDAHL * * TELEFONAKTIEBOLAGET LM ERICSSON * * S-126 25 STOCKHOLM * * * *********************************************************\ CONST DISPLIMIT = 20; MAXADDR = 32767; MAXSTRGUB = 77; %MAXIMUM STRINGLENGTH = 78\ STARTADDR = 00000B; CIXMAX = 32767; CODEMAX = 32767; ALFALENG = 10; OPTIONCONSTR = '$' ; SRCNESTMAX = 3 % MAX 3 LEVELS OF SOURCE CODE NESTING (INCLUDES)\; MAXFILES = 5 ; TEXTBUFFSIZE = 132 % BYTES \ ; FILESIZECORR = 104 % BYTES \ ; FDBSIZE = 96 % BYTES \ ; % RECORD \ % FDB: FILE DESCR BLOCK \ EOLNSTATUS = -8; % EOLN: BOOLEAN \ EOFSTATUS = -6; % EOF: BOOLEAN \ IORESULT = -4 % IORESULT:INTEGER \ ; % FILTYP: SET OF [RANDOM,UPDATE,APPEND,TEMPORARY,INSERT,SHARED,SPOOL] \ %ADDRESSES OF 'PREDECLARED' VARIABLES \ %WHICH BY THEIR ADDRESS HAVE THE STATUS OF \ %PARAMETERS TO THE MAIN PROGRAM.\ DAPDDT = 12; MARKDDT = 10; DAPADDR = 8; MARKADDR = 6; LINEADDR = 2; %NAMES OF THE PDP11-INSTRUCTIONS THAT MAY \ %APPEAR IN THE INLINE CODE \ %NAMES OF THE PDP11 REGISTERS \ AR = 0; R = 1; AD = 2; GP = 3; MP = 4; SP = 5; HP = 6; PC = 7; %NAMES REPRESENTING THE PDP11 ADDRESSING- \ % MODES \ REG = 0; REGDEF = 8; AUTINC = 16; AUTDEC = 32; AUTINCDEF = 24; AUTDECDEF = 40; INDEX = 48; INDEXDEF = 56; OBJECTRECSIZE = 46 ; GBLDFMAX = 30 ; PSECTDEFFLAGS = 2440B ; GLOBALDEFFLAGS = 2050B ; GLOBALREFFLAGS = 2000B ; RELOCFCN = 6 ; % GLOBAL ADDITIVE DISPLACED RELOCATION\ ABSADDR = 5; % GLOBAL ADDITIVE RELOCATION \ TYPE %DESCRIBING:\ %***********\ %BASIC SYMBOLS\ %*************\ INSTRRANGE = (CLRB,MOVB,CMPB,CLR,DEC,INC,NEG,TST,COM,ASL,ASR,HALT, JMP,JSR,SOB,XOR,MULT,DIVV,TRAP,EMT,MOV,ADD,SUB,CMP,BVS,BVC, BIS,BIT,BIC,BR,BEQ,BNE,BGE,BGT,BLE,BLT,BPL,BMI,RTI,RTS) ; SYMBOL = (IDENT,INTCONST,REALCONST,STRINGCONST,NOTSY,MULOP,ADDOP,RELOP, LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON,PERIOD,ARROW, COLON,BECOMES,LABELSY,CONSTSY,TYPESY,VARSY,LOCALSY,FUNCTIONSY, PROCEDURESY,SETSY,PACKEDSY,ARRAYSY,RECORDSY,FILESY,FORWARDSY, BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY,LOOPSY, GOTOSY,EXITSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY, THENSY,OTHERSY,DEFAULTSY,EXTERNALSY); OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,GEOP,GTOP, NEOP,EQOP,INOP,NOOP); SETOFSYS = SET OF SYMBOL; BOOLARR = PACKED ARRAY ['A'..'Z'] OF BOOLEAN; %CONSTANTS\ %*********\ CSTCLASS = (REEL,PSET,STRG); CSP = ^ CONSTNT; CONSTNT = RECORD SELFCSP: INTEGER; NOCODE: BOOLEAN; CASE CCLASS: CSTCLASS OF %CCLASS NEVER SET NORE TESTED\ REEL: (HEAD,TAIL: INTEGER; RVAL: REAL); PSET: (PVAL: SET OF 0..63); STRG: (SLGTH: 0..MAXSTRGUB; SVAL: ARRAY [0..MAXSTRGUB] OF CHAR) END; VALU = RECORD CASE BOOLEAN OF %INTVAL NEVER SET NORE TESTED\ TRUE: (IVAL: INTEGER); FALSE: (VALP: CSP) END; %DATA STRUCTURES\ %***************\ LEVRANGE = 0..MAXADDR; ADDRRANGE = -MAXADDR..MAXADDR; STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES, BOUNDLESS,TAGFWITHID,TAGFWITHOUTID,VARIANT,STRINGPARM); DECLKIND = (STANDARD,DECLARED); STP = ^ STRUCTURE; CTP = ^ IDENTIFIER; INTP = ^ INTEGER; STRUCTURE = PACKED RECORD SELFSTP: INTEGER; NOCODE: BOOLEAN; SIZE: ADDRRANGE; CASE FORM: STRUCTFORM OF SCALAR: (CASE SCALKIND: DECLKIND OF DECLARED: (FCONST: CTP)); SUBRANGE: (RANGETYPE: STP; MIN,MAX: VALU); POINTER: (ELTYPE: STP); POWER: (ELSET: STP); ARRAYS: (AELTYPE,INXTYPE: STP; ADDRCORR: INTEGER; PACKOPT: BOOLEAN); RECORDS: (FSTFLD: CTP; RECVAR: STP; PACKSTRUCT: BOOLEAN); FILES: (FILTYPE: STP); BOUNDLESS:(SUBSTRUCT,INDEXTYPE: STP; UNSPECLEVEL: INTEGER); TAGFWITHID, TAGFWITHOUTID:(FSTVAR: STP; CASE BOOLEAN OF TRUE: (TAGFIELDP: CTP); FALSE: (TAGFIELDTYPE: STP)); VARIANT: (FIRSTFIELD: CTP; NXTVAR,SUBVAR: STP; VARVAL: VALU) END; %NAMES\ %*****\ IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC); SETOFIDS = SET OF IDCLASS; IDKIND = (ACTUAL,FORMAL); ALFA = PACKED ARRAY [1..ALFALENG] OF CHAR; FORWARDOREXT = (INTERNAL,FORWDECL,FORWFOUND,EXTRNL, EXTERNALTX,EXTERNFORTRAN) ; CODERANGE = 0 .. CODEMAX ; ALFAP = ^ ALFA ; IDENTIFIER = PACKED RECORD SELFCTP: INTEGER; NOCODE: BOOLEAN; NAME: ALFA; LLINK, RLINK: CTP; IDTYPE: STP; NEXT: CTP; CASE KLASS: IDCLASS OF KONST: (VALUES: VALU; KADDR: CODERANGE); VARS: (VKIND: IDKIND; VLEV: LEVRANGE; VADDR: ADDRRANGE); FIELD: (FLDADDR: ADDRRANGE); PROC, FUNC: (CASE PFDECKIND: DECLKIND OF STANDARD: (KEY: 1..25); DECLARED: (PFLEV: LEVRANGE; PFADDR, PARLISTSIZE: ADDRRANGE; CASE PFKIND: IDKIND OF ACTUAL: (DECLPLACE: FORWARDOREXT; EXTNAME: ALFAP); FORMAL: (PARMLIST: CTP))) END; DISPRANGE = 0..DISPLIMIT; WHERE = (BLCK,CREC,VREC); %NAMES OF THE RUNTIMEROUTINES \ RUNTIMEROUTS = (ERRN, EQUR,NEQR,LESR,LEQR,GRTR,GEQR,ADR,SBR, EQUB,EQUB2,NEQB,NEQB2, SQRR,MPR,DVR,FLO,FLT,TRC,RND,EXITP, GRTM,GRTM2,LESM,LESM2,GEQM,GEQM2,LEQM,LEQM2, EQUM,EQUM2,EQUS4,NEQM,NEQM2,NEQS4, EQU,NEQ,GRT,GEQ,LES,LEQ, DVI,MODI,SQI,MPI, MOVM,MOVM2, WRCHA,INN,SGSIN,INITS,UNI4,INT4,DIF4, EXPST,EXPSN,REDST,REDSN, IXB,STPB,LPB,CLRAREA,CLRSTK, RDC,RDI,RDR,RDREC,WRREC,RDSTR, WRC,WRS,WRI,WRR, MARKP,RELEASEP,OVFLCHK,SUBRCHK, LEQS1,LEQS4,GEQS1,GEQS4, TRACK,FREQV,DDTINIT, GETCH,GETLINE,INITA,WRIOCT,RESETF,REWRITEF, PUTCH,PUTLINE,INITN,EXITN, BRK,FORMFD,RUNTM,TIME1,DATE1,WRB,WRBFX, GETR,PUTR,DUMP,WRFIX,FORTR,TTPAR,MOVTS, MOVFS,MOVMR,TWPOW,SPLTRL,RSIN,RCOS, RARCTAN,REXP,RLOG,RSQRT,SUBSTRCHECK, STRINGINDEX,DUMRTR); %EXPRESSIONS\ %***********\ ATTRKIND = (CST,VARBL,EXPR); VACCESS = (DRCT, INDRCT, PACKD); ATTR = RECORD TYPTR: STP; CASE KIND: ATTRKIND OF CST: (CVAL: VALU); VARBL: (CASE ACCESS: VACCESS OF DRCT: (VLEVEL: LEVRANGE; DPLMT: ADDRRANGE); INDRCT: (IDPLMT: ADDRRANGE)) END; %LABELS\ %******\ REFLINKP = ^ REFLINK ; REFLINK = RECORD NEXTREF: REFLINKP; REFADDR: ADDRRANGE END; LBP = ^ LABL; LABL = RECORD NEXTLAB: LBP; LABVAL: INTEGER; DECLARED: BOOLEAN; CASE DEFINED: BOOLEAN OF TRUE: (LABADDR: ADDRRANGE); FALSE: (LABCHAIN: REFLINKP) END; % CODE GENERATION \ %*****************\ TEXT = FILE OF CHAR; INTFILE = FILE OF INTEGER; GBLDFRANGE = 0 .. GBLDFMAX ; OBJECTRECORD = RECORD LEN: 1..OBJECTRECSIZE ; VALUE: ARRAY [1..OBJECTRECSIZE] OF INTEGER END; TEXTFDB = ARRAY [-19..0] OF INTEGER; LINEBUFF = PACKED ARRAY [1..80] OF CHAR; STR20 = PACKED ARRAY [0..20] OF CHAR; SRCDESCR = RECORD FDB: TEXTFDB; FNAME: STR20; OLDLIST: BOOLEAN; LINNR: INTEGER END; EXTFILEP = ^ EXTFILET; EXTFILET = RECORD DECL: BOOLEAN; NEXT: EXTFILEP; NAME: ALFA END; %------------------------------------------------------------------------------\ VAR %RETURNED BY SOURCE PROGRAM SCANNER INSYMBOL: *********\ SY: SYMBOL; %LAST SYMBOL\ OP: OPERATOR; %CLASSIFICATION OF LAST SYMBOL\ VAL: VALU; %VALUE OF LAST CONSTANT\ LGTH: INTEGER; %LENGTH OF LAST STRING CONSTANT\ ID:ALFA; %LAST IDENTIFIER (POSSIBLY TRUNCATED)\ KK: 1..ALFALENG; %NR OF CHARS IN LAST IDENTIFIER\ CH: CHAR; %LAST CHARACTER\ % OBJECT CODE GENERATION \ %************************\ GSD,CODE,RLD: OBJECTRECORD ; % EGSD,EM \ PROGNAME, PSECT,OBJIDENT: ALFA ; % CURRENT PSECTION NAME \ GLOBALENTRY: ARRAY [GBLDFRANGE] OF RECORD R50P1,R50P2,EPADDR:INTEGER END; GLOBALINDEX: GBLDFRANGE ; % POINTER IN GLOBALENTRY\ NOTCALLED: PACKED ARRAY [ RUNTIMEROUTS] OF BOOLEAN ; EXTFILE: EXTFILEP; %COUNTERS:\ %*********\ RTR: RUNTIMEROUTS; %RUNTIMEROUTINECOUNTER\ VERSION: INTEGER; %VERSION NUMBER * 100, E.G. 500 == 5.00\ NFILES: INTEGER; %NUMBER OF FILES DECLARED\ %RESET ALSO BY OPTION N+\ CIXX: INTEGER; DATASIZE, I, RTIME: INTEGER; %RUNTIME COUNT/CONTRL VAR\ CHCNT: INTEGER; %CHARACTER COUNTER\ CIX: INTEGER; %COMPILER-INSTRUCTIONCOUNTER\ LC: INTEGER; %DATA LOCATION\ PDPWORD, CHECKSUM: INTEGER; OLDLINENO,LINEWIDTH,POINTERCNT, LINENO,PAGENO,LINECNT,PAGEWIDTH: INTEGER; EPMAIN: CODERANGE; %STARTADDRESS OF MAIN PROGRAM\ SELECTOR, %RUNTIME ERROR BEHAVIOUR SELECTION\ DEFLEVEL: INTEGER; % DEFAULT DECLARATION LEVEL \ %SWITCHES:\ %*********\ INTPROC, %INTERRUPT PROCEDURES\ ERRDETECTED, %DETECTION OF ERRORS\ DP, %DECLARATION PART\ PRTERR, %TO ALLOW FORWARD REFERENCES IN POINTER TYPE DECLARATION BY SUPPRESSING ERROR MESSAGE\ PAGEEJECT, %PREMATURE PAGE EJECT\ LIST,PRCODE, MAIN, %MAIN PROGRAM OR PROCEDUREONLY\ TRACE, % TUNTIME TRACE OF EXECUTED STATEMENTS\ DEBUG, % DEBUG SELECTOR \ FREQUENCE, % MEASUREMENT OF STATEMENT EXECUTION FREQUENCIES\ CONDCOMP, % CONDITIONAL COMPILATION \ WARNINGS, % WARNING MESSAGES \ HEAPCHECK, %RUNTIME CHECK OF HEAP VS STACK\ CXPOPENED, %BOOKKEEPING OF CEX STATUS\ DOLLARNAME, %EXTNAMES TO BEGIN WITH DOLLAR SIGN\ RUNTMCHECK, %OUTPUT OPTIONS FOR -- SOURCE PROGRAM LISTING -- PRINTING SYMBOLIC CODE -- RUNTIME CHECKING --> PROCEDURE OPTION\ PSECTGEN, % -- PSECTION GENERATION\ FIRSTMODULE, % TO GENERATE MODULE ID \ EXTSET, FPPUNIT, % OPTIONS FOR CODEGENERATION: --EXTENDED PDP11 INSTRUCTIONSET --FLOATING POINT PROCESSOR\ FLTSET : BOOLEAN; % FLOATING POINT INSTRUCTION SET \ ONSWITCH,OFFSWITCH: BOOLARR; %POINTERS:\ %*********\ INTPTR,REALPTR,CHARPTR,IOSPECPTR, BOOLPTR,NILPTR,TEXTPTR: STP; %POINTERS TO ENTRIES OF STANDARD IDS\ INPUTPTR,OUTPUTPTR, TTYINPTR,TTYOUTPTR, %POINTERS TO STANDARD FILES\ UTYPPTR,UCSTPTR,UVARPTR, UFLDPTR,UPRCPTR,UFCTPTR, %POINTERS TO ENTRIES FOR UNDECLARED IDS\ FWPTR: CTP; %HEAD OF CHAIN OF FORW DECL TYPE IDS\ FSTLABP: LBP; %HEAD OF LABEL CHAIN\ %BOOKKEEPING OF DECLARATION LEVELS:\ %**********************************\ LEVEL: LEVRANGE; %CURRENT STATIC LEVEL\ DISX, %LEVEL OF LAST ID SEARCHED BY SEARCHID\ TOP: DISPRANGE; %TOP OF DISPLAY\ DISPLAY: %WHERE: MEANS:\ ARRAY [DISPRANGE] OF PACKED RECORD %=BLCK: ID IS VARIABLE ID\ FNAME: CTP; %=CREC: ID IS FIELD ID IN RECORD WITH\ CASE OCCUR: WHERE OF % CONSTANT ADDRESS\ CREC: (CLEV: LEVRANGE; %=VREC: ID IS FIELD ID IN RECORD WITH\ CDSPL: ADDRRANGE);% VARIABLE ADDRESS\ VREC: (VDSPL: ADDRRANGE) END; % --> PROCEDURE WITHSTATEMENT\ %ERROR MESSAGES:\ %***************\ ERRINX: 0..10; %NR OF ERRORS IN CURRENT SOURCE LINE\ ERRLIST: ARRAY [1..10] OF PACKED RECORD POS: INTEGER; NMR: 1..999 END; %EXPRESSION COMPILATION:\ %***********************\ GATTR: ATTR; %DESCRIBES THE EXPR CURRENTLY COMPILED\ %STRUCTURED CONSTANTS:\ %*********************\ LETTERS,DIGITS: SET OF CHAR; CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS, STATBEGSYS,TYPEDELS: SETOFSYS; RW: ARRAY [1..38%NR. OF RES. WORDS\] OF ALFA; FRW: ARRAY [1..11%ALFALENG+1\] OF 1..39%NR. OF RES. WORDS + 1\; RSY: ARRAY [1..38%NR. OF RES. WORDS\] OF SYMBOL; SSY: ARRAY [' '..'_'] OF SYMBOL; ROP: ARRAY [1..38%NR. OF RES. WORDS\] OF OPERATOR; SOP: ARRAY [' '..'_'] OF OPERATOR; INSTRVAL: ARRAY[INSTRRANGE] OF INTEGER ; RNA: ARRAY[RUNTIMEROUTS] OF PACKED ARRAY[0..4] OF CHAR; %RUNTIME NAMES\ (*$Z+*) REGNAMES: ARRAY [0..7] OF PACKED ARRAY[0..1] OF CHAR; MN: ARRAY[INSTRRANGE] OF PACKED ARRAY[0..2] OF CHAR; %DISSEMBLER\ (*$Z-*) ARRT : ARRAY [LTOP..EQOP,BOOLEAN,BOOLEAN] OF RUNTIMEROUTS; SCALRT : ARRAY [LTOP..EQOP,BOOLEAN] OF RUNTIMEROUTS; HEADER,TIMESTR,DATESTR: ALFA; PDP11OBJ: TEXT ; %OBJECT CODE FILE FOR PDP-11 COMPILER\ (*$Z+*) OUTPUTHGH: FILE OF INTEGER; %CODE FILE IN BIN. FORMAT\ CEX: FILE OF CHAR ; %CODE EXPANSION LIST FILE \ (*$Z-*) FILENAME: STR20; %NAME OF INPUT FILE\ MCRLINE: LINEBUFF; MCRLEN,MCRINX: INTEGER; SRCLEVEL: -1..SRCNESTMAX; SRCNEST: ARRAY [1..SRCNESTMAX] OF SRCDESCR; % DEBUG \ %*******\ LASTLINE: RECORD LLADDR: ADDRRANGE; LLPSECT: ALFA END; DCIX: INTEGER % POINTER IN PSECT $DDTDF \; IDRECSIZE: ARRAY [ IDCLASS ] OF INTEGER; STRECSIZE: ARRAY [ STRUCTFORM ] OF INTEGER; %------------------------------------------------------------------------------\ PROCEDURE SWITCHINIT( VAR I1,I2,I3,I4: INTEGER; VAR B1,B2,B3,B4,B5, B6,B7,B8,B9,B10,B11,B12,B13,B14: BOOLEAN ); EXTERN; PROCEDURE INITTABLES ; BEGIN % INITPROCEDURE \ %RUNTIMEROUTINEMNEMONICS\ BEGIN RNA[ERRN] := 'ERRN '; RNA[EQUR] := 'EQUR '; RNA[NEQR] := 'NEQR '; RNA[LESR] := 'LESR '; RNA[LEQR] := 'LEQR '; RNA[GRTR] := 'GRTR '; RNA[GEQR] := 'GEQR '; RNA[ADR] := 'ADDR '; RNA[SBR] := 'SUBR '; RNA[SQRR] := 'SQRR '; RNA[MPR] := 'MULR '; RNA[DVR] := 'DIVR '; RNA[FLO] := 'FLO '; RNA[FLT] := 'FLT '; RNA[TRC] := 'TRC '; RNA[RND] := 'RND '; RNA[EXITP] := 'EXITP'; RNA[GRTM] := 'GRTM '; RNA[GRTM2] := 'GRTM2'; RNA[LESM] := 'LESM '; RNA[LESM2] := 'LESM2'; RNA[GEQM] := 'GEQM '; RNA[GEQM2] := 'GEQM2'; RNA[LEQM] := 'LEQM '; RNA[LEQM2] := 'LEQM2'; RNA[EQUM] := 'EQUM '; RNA[EQUM2] := 'EQUM2'; RNA[EQUS4] := 'EQUS4'; RNA[NEQM] := 'NEQM '; RNA[NEQM2] := 'NEQM2'; RNA[NEQS4] := 'NEQS4'; RNA[EQUB] := 'EQUB '; RNA[EQUB2] := 'EQUB2'; RNA[NEQB] := 'NEQB '; RNA[NEQB2] := 'NEQB2'; RNA[EQU] := 'EQU '; RNA[NEQ] := 'NEQ '; RNA[GRT] := 'GRT '; RNA[GEQ] := 'GEQ '; RNA[LES] := 'LES '; RNA[LEQ] := 'LEQ '; RNA[DVI] := 'DIVI '; RNA[MODI] := 'MODI '; RNA[SQI] := 'SQI '; RNA[MPI] := 'MULI '; RNA[MOVM] := 'MOVM '; RNA[MOVM2] := 'MOVM2'; RNA[WRCHA] := 'WRCHA'; RNA[INN] := 'INN '; RNA[SGSIN] := 'SGSIN'; RNA[INITS] := 'INITS'; RNA[UNI4] := 'UNI4 '; RNA[INT4] := 'INT4 '; RNA[DIF4] := 'DIF4 '; RNA[EXPST] := 'EXPST'; RNA[EXPSN] := 'EXPSN'; RNA[REDST] := 'REDST'; RNA[REDSN] := 'REDSN'; RNA[IXB] := 'IXB '; RNA[STPB] := 'STPB '; RNA[LPB] := 'LPB '; RNA[CLRAREA] := 'CLRAR'; RNA[CLRSTK] := 'CLRST'; RNA[RDC] := 'RDC '; RNA[RDI] := 'RDI '; RNA[RDR] := 'RDR '; RNA[RDREC] := 'RDREC'; RNA[WRREC] := 'WRREC'; RNA[RDSTR] := 'RDSTR'; RNA[WRC] := 'WRC '; RNA[WRS] := 'WRS '; RNA[WRI] := 'WRI '; RNA[WRR] := 'WRR '; RNA[MARKP] := 'MARKP'; RNA[RELEASEP] := 'RELEA'; RNA[OVFLCHK] := 'OVFLC'; RNA[SUBRCHK] := 'SUBRC'; RNA[LEQS1] := 'LEQS1'; RNA[LEQS4] := 'LEQS4'; RNA[GEQS1] := 'GEQS1'; RNA[GEQS4] := 'GEQS4'; RNA[TRACK] := 'P.TRC'; RNA[FREQV] := 'P.FRQ'; RNA[DDTINIT] := 'P.DDT'; RNA[GETCH] := 'GET '; RNA[GETLINE] := 'GETLN'; RNA[INITA] := 'INITA'; RNA[WRIOCT] := 'WROCT'; RNA[RESETF] := 'RESET'; RNA[REWRITEF] := 'REWRI'; RNA[PUTCH] := 'PUT '; RNA[PUTLINE] := 'PUTLN'; RNA[INITN] := 'INITN'; RNA[EXITN] := 'EXITN'; RNA[BRK] := 'BRK '; RNA[FORMFD] := 'PAGE '; RNA[RUNTM] := 'RUNTM'; RNA[TIME1] := 'TIME '; RNA[DATE1] := 'DATE '; RNA[WRB] := 'WRB '; RNA[WRBFX] := 'WRBFX'; RNA[GETR] := 'GETRM'; RNA[PUTR] := 'PUTRM'; RNA[DUMP] := 'DUMP '; RNA[WRFIX] := 'WRFIX'; RNA[FORTR] := 'FORTR'; RNA[TTPAR] := 'TTPAR'; RNA[MOVTS] := 'MOVTS'; RNA[MOVFS] := 'MOVFS'; RNA[MOVMR] := 'MOVMR'; RNA[TWPOW] := 'TWPOW'; RNA[SPLTRL] := 'SPTRL'; RNA[RSIN] := 'RSIN '; RNA[RCOS] := 'RCOS '; RNA[RARCTAN] := 'ARCTN'; RNA[REXP] := 'REXP '; RNA[RLOG] := 'RLOG '; RNA[RSQRT] := 'RSQRT'; RNA[SUBSTRCHECK] := 'STRCH'; RNA[STRINGINDEX] := 'STIND'; END; %RTRMNEMONICS\ (*$Z+*) % INITPROCEDURE \ %INSTRMNEMONICS\ BEGIN REGNAMES[0] := 'AR'; REGNAMES[1] := 'R '; REGNAMES[2] := 'AD'; REGNAMES[3] := 'GP'; REGNAMES[4] := 'MP'; REGNAMES[5] := 'SP'; REGNAMES[6] := 'HP'; REGNAMES[7] := 'PC'; MN[CLRB] := 'CLR'; MN[MOVB] := 'MOV'; MN[CMPB] := 'CMP'; MN[CLR] := 'CLR'; MN[DEC] := 'DEC'; MN[INC] := 'INC'; MN[TST] := 'TST'; MN[COM] := 'COM'; MN[ASL] := 'ASL'; MN[ASR] := 'ASR'; MN[JMP] := 'JMP'; MN[JSR] := 'JSR'; MN[SOB] := 'SOB'; MN[MULT] :='MUL'; MN[DIVV] := 'DIV'; MN[XOR] := 'XOR'; MN[BR] := 'BR '; MN[BEQ] := 'BEQ'; MN[BNE] := 'BNE'; MN[BGE] := 'BGE'; MN[BGT] := 'BGT'; MN[BLE] := 'BLE'; MN[BLT] := 'BLT'; MN[BPL] := 'BPL'; MN[BMI] := 'BMI'; MN[MOV] := 'MOV'; MN[ADD] := 'ADD'; MN[SUB] := 'SUB'; MN[CMP] := 'CMP'; MN[BIS] := 'BIS'; MN[BIT] := 'BIT'; MN[BIC] := 'BIC'; MN[RTS] := 'RTS'; MN[BVS] := 'BVS'; MN[BVC] := 'BVC'; MN[NEG] := 'NEG'; MN[HALT] := 'HLT'; MN[TRAP] := 'TRP'; MN[EMT] := 'EMT'; MN[RTI] := 'RTI'; END %INSTRMNEMONICS\ ; (*$Z-*) % INITPROCEDURE \ %INITSCALARS\ BEGIN FWPTR := NIL ; FSTLABP := NIL ; ERRDETECTED := FALSE; SRCLEVEL := 0; FOR CH:='A' TO 'Z' DO BEGIN ONSWITCH[CH]:=FALSE; OFFSWITCH[CH]:=FALSE END; SWITCHINIT( VERSION,DEFLEVEL,PAGEWIDTH,LINEWIDTH,EXTSET,FLTSET,FPPUNIT, LIST,PRCODE,CONDCOMP,WARNINGS,RUNTMCHECK,HEAPCHECK,MAIN, PSECTGEN,TRACE,DEBUG,FREQUENCE); IDRECSIZE[TYPES] := 12; IDRECSIZE[KONST] := 14; IDRECSIZE[VARS] := 15; IDRECSIZE[FIELD] := 13; IDRECSIZE[PROC] := 19; IDRECSIZE[FUNC] := 19; STRECSIZE[SCALAR] := 6; STRECSIZE[SUBRANGE] := 7; STRECSIZE[POINTER] := 5; STRECSIZE[POWER] := 5; STRECSIZE[ARRAYS] := 8; STRECSIZE[RECORDS] := 7; STRECSIZE[FILES] := 5; STRECSIZE[BOUNDLESS] := 7; STRECSIZE[VARIANT] := 8; STRECSIZE[STRINGPARM] := 4; STRECSIZE[TAGFWITHID] := 6; STRECSIZE[TAGFWITHOUTID] := 6; PAGEEJECT := TRUE; POINTERCNT := 0; CIX := -1 ; GLOBALINDEX := 0 ; DCIX := 0; PSECT := '.MAIN. '; OBJIDENT := ' '; CXPOPENED := 100000B<0 %TRUE FOR PDP 11\ ; FIRSTMODULE := TRUE; DP := TRUE; PRTERR := TRUE; ERRINX := 0; DOLLARNAME := FALSE; KK := ALFALENG; CH := ' '; LC := -2; CHCNT := LINEWIDTH + 1; LINENO := 0; PAGENO := 0; LINECNT := 0; HEADER := ' 5.00 '; IF VERSION > 999 THEN HEADER[1] := CHR( VERSION DIV 1000 + 48 ); HEADER[2] := CHR( (VERSION DIV 100) MOD 10 + 48 ); HEADER[4] := CHR( (VERSION DIV 10) MOD 10 + 48 ); HEADER[5] := CHR( VERSION MOD 10 + 48 ); END %INITSCALARS\ ; % INITPROCEDURE \ %INITSETS\ BEGIN DIGITS := ['0','1','2','3','4','5','6','7','8','9']; LETTERS := ['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']; CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT]; SIMPTYPEBEGSYS := [ LPARENT , ADDOP , INTCONST , REALCONST , STRINGCONST , IDENT ] ; TYPEBEGSYS := [ARROW,PACKEDSY,ARRAYSY,RECORDSY,SETSY,FILESY,LPARENT,ADDOP, INTCONST,REALCONST,STRINGCONST,IDENT]; TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY]; BLOCKBEGSYS := [LABELSY,CONSTSY,TYPESY,VARSY,PROCEDURESY,FUNCTIONSY, BEGINSY]; SELECTSYS := [ARROW,PERIOD,LBRACK]; FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY]; STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,LOOPSY,FORSY,WITHSY, CASESY,LOCALSY]; END %INITSETS\ ; % INITPROCEDURE \ %RESWORDS\ BEGIN RW[ 1] := 'IF '; RW[ 2] := 'DO '; RW[ 3] := 'OF '; RW[ 4] := 'TO '; RW[ 5] := 'IN '; RW[ 6] := 'OR '; RW[ 7] := 'END '; RW[ 8] := 'FOR '; RW[ 9] := 'VAR '; RW[10] := 'DIV '; RW[11] := 'MOD '; RW[12] := 'SET '; RW[13] := 'AND '; RW[14] := 'NOT '; RW[15] := 'THEN '; RW[16] := 'ELSE '; RW[17] := 'WITH '; RW[18] := 'GOTO '; RW[19] := 'LOOP '; RW[20] := 'CASE '; RW[21] := 'TYPE '; RW[22] := 'FILE '; RW[23] := 'EXIT '; RW[24] := 'BEGIN '; RW[25] := 'UNTIL '; RW[26] := 'WHILE '; RW[27] := 'ARRAY '; RW[28] := 'LABEL '; RW[29] := 'CONST '; RW[30] := 'OTHERS '; RW[31] := 'REPEAT '; RW[32] := 'RECORD '; RW[33] := 'DOWNTO '; RW[34] := 'PACKED '; RW[35] := 'EXTERN '; RW[36] := 'FORWARD '; RW[37] := 'FUNCTION '; RW[38] := 'PROCEDURE '; FRW[1] := 1; FRW[2] := 1; FRW[3] := 7; FRW[4] := 15; FRW[5] := 24; FRW[6] := 30; FRW[7] := 36; FRW[8] := 37; FRW[9] := 38; FRW[10] := 39; FRW[11] := 39; END %RESWORDS\; % INITPROCEDURE \ %SYMBOLS \ BEGIN RSY[1] := IFSY; RSY[2] := DOSY; RSY[3] := OFSY; RSY[4] := TOSY; RSY[5] := RELOP; RSY[6] := ADDOP; RSY[7] := ENDSY; RSY[8] := FORSY; RSY[9] := VARSY; RSY[10] := MULOP; RSY[11] := MULOP; RSY[12] := SETSY; RSY[13] := MULOP; RSY[14] := NOTSY; RSY[15] := THENSY; RSY[16] := ELSESY; RSY[17] := WITHSY; RSY[18] := GOTOSY; RSY[19] := LOOPSY; RSY[20] := CASESY; RSY[21] := TYPESY; RSY[22] := FILESY; RSY[23] := EXITSY; RSY[24] := BEGINSY; RSY[25] := UNTILSY; RSY[26] := WHILESY; RSY[27] := ARRAYSY; RSY[28] := LABELSY; RSY[29] := CONSTSY; RSY[30] := DEFAULTSY; RSY[31] := REPEATSY; RSY[32] := RECORDSY; RSY[33] := DOWNTOSY; RSY[34] := PACKEDSY; RSY[35] := EXTERNALSY; RSY[36] := FORWARDSY; RSY[37] := FUNCTIONSY; RSY[38] := PROCEDURESY; SSY['A'] := OTHERSY; SSY['B'] := OTHERSY; SSY['C'] := OTHERSY; SSY['D'] := OTHERSY; SSY['E'] := OTHERSY; SSY['F'] := OTHERSY; SSY['G'] := OTHERSY; SSY['H'] := OTHERSY; SSY['I'] := OTHERSY; SSY['J'] := OTHERSY; SSY['K'] := OTHERSY; SSY['L'] := OTHERSY; SSY['M'] := OTHERSY; SSY['N'] := OTHERSY; SSY['O'] := OTHERSY; SSY['P'] := OTHERSY; SSY['Q'] := OTHERSY; SSY['R'] := OTHERSY; SSY['S'] := OTHERSY; SSY['T'] := OTHERSY; SSY['U'] := OTHERSY; SSY['V'] := OTHERSY; SSY['W'] := OTHERSY; SSY['X'] := OTHERSY; SSY['Y'] := OTHERSY; SSY['Z'] := OTHERSY; SSY['0'] := OTHERSY; SSY['1'] := OTHERSY; SSY['2'] := OTHERSY; SSY['3'] := OTHERSY; SSY['4'] := OTHERSY; SSY['5'] := OTHERSY; SSY['6'] := OTHERSY; SSY['7'] := OTHERSY; SSY['8'] := OTHERSY; SSY['9'] := OTHERSY; SSY['_'] := OTHERSY; SSY['+'] := ADDOP; SSY['-'] := ADDOP; SSY['*'] := MULOP; SSY['/'] := MULOP; SSY['('] := LPARENT; SSY[')'] := RPARENT; SSY['$'] := OTHERSY; SSY['='] := RELOP; SSY[' '] := OTHERSY; SSY[','] := COMMA; SSY['.'] := PERIOD; SSY[''''] := OTHERSY; SSY['['] := LBRACK;SSY[']'] := RBRACK ; SSY[':'] := COLON; SSY['#'] := RELOP; SSY['%'] := OTHERSY; SSY['!'] := ADDOP; SSY['&'] := MULOP; SSY['^'] := ARROW ; SSY['\'] := OTHERSY; SSY['<'] := RELOP; SSY['>'] := RELOP ; SSY['@'] := RELOP; SSY['"'] := RELOP; SSY['?'] := NOTSY ; SSY[';'] := SEMICOLON; END %SYMBOLS\; END % INITTABLES ( TOO LONG IF INIT2 INCLUDED ) \ ; PROCEDURE INIT2 (*$Y+*) ; BEGIN % INITPROCEDURE \ % OPERATORS\ BEGIN ROP[ 1] := NOOP; ROP[ 2] := NOOP; ROP[ 3] := NOOP; ROP[ 4] := NOOP; ROP[ 5] := INOP; ROP[ 6] := OROP; ROP[ 7] := NOOP; ROP[ 8] := NOOP; ROP[ 9] := NOOP; ROP[10] := IDIV; ROP[11] := IMOD; ROP[12] := NOOP; ROP[13] :=ANDOP; ROP[14] := NOOP; ROP[15] := NOOP; ROP[16] := NOOP; ROP[17] := NOOP; ROP[18] := NOOP; ROP[19] := NOOP; ROP[20] := NOOP; ROP[21] := NOOP; ROP[22] := NOOP; ROP[23] := NOOP; ROP[24] := NOOP; ROP[25] := NOOP; ROP[26] := NOOP; ROP[27] := NOOP; ROP[28] := NOOP; ROP[29] := NOOP; ROP[30] := NOOP; ROP[31] := NOOP; ROP[32] := NOOP; ROP[33] := NOOP; ROP[34] := NOOP; ROP[35] := NOOP; ROP[36] := NOOP; ROP[37] := NOOP; ROP[38] := NOOP; SOP['+'] := PLUS; SOP['-'] := MINUS; SOP['*'] := MUL; SOP['/'] := RDIV; SOP['='] := EQOP; SOP['#'] := NEOP; SOP['!'] := OROP; SOP['&'] := ANDOP; SOP['<'] := LTOP; SOP['>'] := GTOP; SOP['@'] := LEOP; SOP['"'] := GEOP; SOP[' '] := NOOP; SOP['$'] := NOOP; SOP['%'] := NOOP; SOP['('] := NOOP; SOP[')'] := NOOP; SOP[','] := NOOP; SOP['.'] := NOOP; SOP['0'] := NOOP; SOP['1'] := NOOP; SOP['2'] := NOOP; SOP['3'] := NOOP; SOP['4'] := NOOP; SOP['5'] := NOOP; SOP['6'] := NOOP; SOP['7'] := NOOP; SOP['8'] := NOOP; SOP['9'] := NOOP; SOP[':'] := NOOP; SOP[';'] := NOOP; SOP['?'] := NOOP; SOP['E'] := NOOP; SOP['F'] := NOOP; SOP['G'] := NOOP; SOP['H'] := NOOP; SOP['A'] := NOOP; SOP['B'] := NOOP; SOP['C'] := NOOP; SOP['D'] := NOOP; SOP['I'] := NOOP; SOP['J'] := NOOP; SOP['K'] := NOOP; SOP['L'] := NOOP; SOP['M'] := NOOP; SOP['N'] := NOOP; SOP['O'] := NOOP; SOP['P'] := NOOP; SOP['Q'] := NOOP; SOP['R'] := NOOP; SOP['S'] := NOOP; SOP['T'] := NOOP; SOP['U'] := NOOP; SOP['V'] := NOOP; SOP['W'] := NOOP; SOP['X'] := NOOP; SOP['Y'] := NOOP; SOP['Z'] := NOOP; SOP['['] := NOOP; SOP['\'] := NOOP; SOP[']'] := NOOP; SOP['^'] := NOOP; SOP['_'] := NOOP; SOP[''''] := NOOP; %END OPERATORS\ END; % INITPROCEDURE \ %INSTRUCTIONVALUES\ BEGIN INSTRVAL[MOVB]:=110000B; INSTRVAL[CLRB]:=105000B; INSTRVAL[CMPB]:=120000B; INSTRVAL[CLR]:=005000B; INSTRVAL[DEC]:=005300B; INSTRVAL[INC]:=005200B; INSTRVAL[NEG]:=005400B; INSTRVAL[TST]:=005700B; INSTRVAL[COM]:=005100B; INSTRVAL[ASL]:=006300B; INSTRVAL[ASR]:=006200B; INSTRVAL[JMP]:=000100B; INSTRVAL[JSR]:=004000B; INSTRVAL[SOB]:=077000B; INSTRVAL[XOR]:=074000B; INSTRVAL[MULT]:=070000B; INSTRVAL[TRAP]:=104400B; INSTRVAL[EMT]:=104000B; INSTRVAL[BR]:= 000400B; INSTRVAL[BEQ]:=001400B; INSTRVAL[BNE]:=001000B; INSTRVAL[BGE]:=002000B; INSTRVAL[BGT]:=003000B; INSTRVAL[BLE]:=003400B; INSTRVAL[BLT]:=002400B; INSTRVAL[BPL]:=100000B; INSTRVAL[BMI]:=100400B; INSTRVAL[MOV]:=010000B; INSTRVAL[ADD]:=060000B; INSTRVAL[SUB]:=160000B; INSTRVAL[CMP]:=020000B; INSTRVAL[BIS]:=050000B; INSTRVAL[BIT]:=030000B; INSTRVAL[BIC]:=040000B; INSTRVAL[RTS]:=000200B; INSTRVAL[RTI]:=000002B; INSTRVAL[BVC]:=102000B; INSTRVAL[BVS]:=102400B; END % INSTUCTIONVALUES \ ; TIMESTR := ' '; DATESTR := '18-OCT-76 '; FOR RTR := ERRN TO DUMRTR DO NOTCALLED[RTR] := TRUE; % INITPROCEDURE \ %ARRAYS FOR EXPRESSION: CALLS OF RUNTIMEROUTINES\ BEGIN SCALRT[LEOP,FALSE] := LEQ; SCALRT[LEOP,TRUE] := LEQR; SCALRT[GEOP,FALSE] := GEQ; SCALRT[GEOP,TRUE] := GEQR; SCALRT[GTOP,FALSE] := GRT; SCALRT[GTOP,TRUE] := GRTR; SCALRT[LTOP,FALSE] := LES; SCALRT[LTOP,TRUE] := LESR; SCALRT[EQOP,FALSE] := EQU; SCALRT[EQOP,TRUE] := EQUR; SCALRT[NEOP,FALSE] := NEQ; SCALRT[NEOP,TRUE] := NEQR; ARRT[LTOP,FALSE,FALSE] := ERRN ; ARRT[LTOP,FALSE,TRUE] := ERRN ; ARRT[LTOP,TRUE ,FALSE] := LESM ; ARRT[LTOP,TRUE ,TRUE] := LESM2; ARRT[LEOP,FALSE,FALSE] := ERRN ; ARRT[LEOP,FALSE,TRUE] := ERRN ; ARRT[LEOP,TRUE ,FALSE] := LEQM ; ARRT[LEOP,TRUE ,TRUE] := LEQM2; ARRT[GEOP,FALSE,FALSE] := ERRN ; ARRT[GEOP,FALSE,TRUE] := ERRN ; ARRT[GEOP,TRUE ,FALSE] := GEQM ; ARRT[GEOP,TRUE ,TRUE] := GEQM2; ARRT[GTOP,FALSE,FALSE] := ERRN ; ARRT[GTOP,FALSE,TRUE] := ERRN ; ARRT[GTOP,TRUE,FALSE] := GRTM ; ARRT[GTOP,TRUE ,TRUE] := GRTM2; ARRT[NEOP,FALSE,FALSE] := NEQM; ARRT[NEOP,FALSE,TRUE] := NEQM2; ARRT[NEOP,TRUE ,FALSE] := NEQB; ARRT[NEOP,TRUE ,TRUE] := NEQB2; ARRT[EQOP,FALSE,FALSE] := EQUM; ARRT[EQOP,FALSE,TRUE] := EQUM2; ARRT[EQOP,TRUE ,FALSE] := EQUB; ARRT[EQOP,TRUE ,TRUE] := EQUB2; END; % INITPROCEDURE \ % OBJECTRECORDS \ BEGIN GSD.VALUE[1] := 1 ; GSD.LEN := 1 ; RLD.VALUE[1] := 4 ; RLD.LEN := 1 ; CODE.VALUE[1] := 3 ; CODE.LEN := 1 ; END % OBJECTRECORDS \ ; END % INIT2 \ ; PROCEDURE WRITOFILE ( VAR REC: OBJECTRECORD ; VAR PDPOBJ: TEXT (*$Z+*) ; VAR OUTPUTHGH: INTFILE (*$Z-*) ); EXTERN; PROCEDURE READFILEIDENTIFIER( VAR FDL,FPW,PLW: INTEGER; VAR SWL,SWC: BOOLARR; VAR CML: LINEBUFF; VAR CMLLEN, CMLIX: INTEGER; VAR FILENAME: STR20 ; VAR PDPOBJ:TEXT ; (*$Z+*) VAR OUTPUTHGH: INTFILE; (*$Z-*) VAR INPUT: TEXT; VAR OUTPUT: TEXT (*$Z+*) ; VAR CODE: TEXT (*$Z-*) ); EXTERN; (*$Y+*) (* NEW MODULE *) PROCEDURE NEWPAGE; BEGIN PAGENO := PAGENO + 1; PAGE(OUTPUT); WRITELN( 'PASCAL PDP-11 VERSION ',HEADER,DATESTR:12,' ':6,TIMESTR:8,' ':10,' PAGE ',PAGENO:3); WRITELN( FILENAME, ' ':4, OBJIDENT, ' ':4, PSECT ); WRITELN; PAGEEJECT := FALSE; LINECNT := 0; END % NEWPAGE \ ; PROCEDURE WTTERR( N: INTEGER ); EXTERN; PROCEDURE WTTINT( N: INTEGER ); EXTERN; PROCEDURE WTTEOL; EXTERN; PROCEDURE WTTSTAT( E: BOOLEAN; P,D,DD,T: INTEGER ); EXTERN; PROCEDURE WTTHEAD( VAR HDR,DAY,TIM: ALFA ); EXTERN; FUNCTION NEXTINPUT ( VAR F: TEXT; VAR CML: LINEBUFF; VAR CMLLEN, CMLIX: INTEGER; VAR FILENAME: STR20 ) : BOOLEAN; EXTERN; PROCEDURE SAVEFDB ( VAR FDB: TEXTFDB; VAR F: TEXT; VAR FN : STR20 ); EXTERN; PROCEDURE UNSAVEFDB ( VAR F: TEXT; VAR FDB: TEXTFDB ); EXTERN; PROCEDURE ERRMES ( N: INTEGER ); EXTERN; PROCEDURE HEAPMARK( VAR M: INTP ); EXTERN; PROCEDURE HEAPRELEASE( M: INTP ); EXTERN; PROCEDURE ENDOFLINE (*$Y+*); VAR LASTPOS,FREEPOS,CURRPOS,CURRNMR,F,K: INTEGER; BEGIN IF ERRINX > 0 THEN %OUTPUT ERROR MESSAGES\ BEGIN WTTERR( LINENO ); FOR K := 1 TO ERRINX DO BEGIN WTTINT(ERRLIST[K].NMR); IF ERRLIST[K].NMR<900 THEN ERRDETECTED := TRUE END; WTTEOL; IF LIST THEN BEGIN WRITELN; WRITE('***** '); IF PRCODE THEN WRITE(' ':9); LASTPOS := 0; FREEPOS := 1; FOR K := 1 TO ERRINX DO BEGIN WITH ERRLIST[K] DO BEGIN CURRPOS := POS; CURRNMR := NMR END; IF CURRPOS = LASTPOS THEN WRITE(',') ELSE BEGIN WHILE FREEPOS < CURRPOS DO BEGIN WRITE(' '); FREEPOS := FREEPOS + 1 END; WRITE('^'); LASTPOS := CURRPOS END; IF CURRNMR < 10 THEN F := 1 ELSE IF CURRNMR < 100 THEN F := 2 ELSE F := 3; WRITE(CURRNMR:F); FREEPOS := FREEPOS + F + 1 ; END; WRITELN; LINECNT := LINECNT + 2; END % IF LIST \ ; ERRINX := 0; END; IF LIST THEN BEGIN WRITELN; IF (LINECNT > PAGEWIDTH) OR PAGEEJECT THEN NEWPAGE; LINECNT := LINECNT + 1; IF PRCODE THEN IF DP THEN WRITE('-',-LC:6:O,' ') ELSE WRITE(2 * CIX + 2:6:O,' '); END; CHCNT := 0; IF SRCLEVEL >= 0 THEN IF EOLN(INPUT) THEN BEGIN READLN; WHILE EOF(INPUT) DO BEGIN IF SRCLEVEL > 0 THEN WITH SRCNEST[SRCLEVEL] DO BEGIN UNSAVEFDB ( INPUT,FDB ); FILENAME := FNAME; SRCLEVEL := SRCLEVEL - 1; LINENO := LINNR; IF LIST THEN NEWPAGE; IF OLDLIST AND NOT LIST THEN WRITELN; LIST := OLDLIST; READLN; END ELSE IF NOT NEXTINPUT ( INPUT, MCRLINE, MCRLEN, MCRINX, FILENAME ) THEN BEGIN WRITELN('***** EOF *****'); ERRMES ( 4 % AND EXIT \ ); END END; LINENO := LINENO + 1; IF LIST THEN WRITE( LINENO:5,' '); END ELSE IF LINENO = 0 THEN BEGIN LINENO := 1; IF LIST THEN WRITE(' 1 '); END ELSE IF LIST THEN BEGIN WRITE(' ':20); CHCNT := CHCNT + 12; END; END %ENDOFLINE\ ; PROCEDURE ERROR(FERRNR: INTEGER) (*$Y+*) ; BEGIN IF WARNINGS OR (FERRNR < 900) THEN BEGIN IF ERRINX >= 9 THEN BEGIN ERRLIST[10].NMR := 255; ERRINX := 10 END ELSE BEGIN ERRINX := ERRINX + 1; ERRLIST[ERRINX].NMR := FERRNR END; ERRLIST[ERRINX].POS := CHCNT END % WARNINGS \ END %ERROR\ ; PROCEDURE INSYMBOL (*$Y+*); %READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LGTH\ LABEL 1,2; CONST DIGMAX = 9; VAR I,J,K,SCALE,EXP,IVAL: INTEGER; MANT,RVAL,R,FAC: REAL; CASECONV,STAR,SIGN,OLDLIST: BOOLEAN; DIGIT: ARRAY [1..DIGMAX] OF 0..9; STRING: ARRAY [0..MAXSTRGUB] OF CHAR; LVP: CSP; BINEXP, SGN: INTEGER; PROCEDURE NEXTCH; VAR ORDCH: 0..255; BEGIN IF EOLN(INPUT) THEN CH :=' ' ELSE BEGIN READ(CH); ORDCH := ORD(CH) ; IF ORDCH > 127 THEN BEGIN ORDCH := ORDCH - 128; CH := CHR(ORDCH) END; IF ORDCH < 32 THEN CH := ' '; IF LIST THEN BEGIN IF ORDCH = 12 %FF\ THEN PAGEEJECT := TRUE; IF ORDCH = 9 %TAB\ THEN BEGIN ORDCH := 7-CHCNT MOD 8; WRITE(' ':ORDCH); CHCNT := CHCNT + ORDCH; END; WRITE(CH); CHCNT := CHCNT+1 END; IF (ORDCH > 95) AND CASECONV THEN BEGIN IF ORDCH = 173B (* LEFT BRACE *) THEN CH := '%' ELSE IF ORDCH = 175B (* RIGHT BRACE *) THEN CH := '\' ELSE CH := CHR( ORDCH - 32 ); END; END END; (*$Y+*) (* NEW MODULE *) PROCEDURE OPTIONS; VAR LCH: CHAR; B: BOOLEAN; VALUE: INTEGER; BEGIN REPEAT NEXTCH; LCH := CH; NEXTCH; IF NOT (CH IN ['+','-']) THEN ERROR(902) ELSE BEGIN IF LCH IN ['A'..'Z'] THEN B := (CH = '+') AND NOT OFFSWITCH[LCH] OR ONSWITCH[LCH] ELSE B := FALSE; CASE LCH OF 'C': BEGIN PRCODE := B; (*$Z+*) IF PRCODE THEN IF CXPOPENED THEN BEGIN WRITELN(CEX); WRITELN(CEX,';************'); WRITELN(CEX) END ELSE BEGIN CXPOPENED := TRUE; REWRITE(CEX,FILENAME) END (*$Z-*) END; 'E','F', 'G','M': IF B THEN ONSWITCH[LCH]:=TRUE ELSE OFFSWITCH[LCH]:=TRUE; 'P': PAGEEJECT := B; 'T': HEAPCHECK := B; 'L': LIST := B; 'V': BEGIN I := 1; NEXTCH; OBJIDENT := ' '; WHILE (CH IN LETTERS OR DIGITS) AND (I < 7) DO BEGIN OBJIDENT[I] := CH; I := I + 1; NEXTCH END END; 'W': WARNINGS := B; 'S': TRACE := B; 'Q': FREQUENCE := B; 'D': DEBUG := CH = '+'; 'B': DOLLARNAME := B; 'N','H': BEGIN VALUE := 0; NEXTCH; WHILE CH IN DIGITS DO BEGIN VALUE := VALUE*10 + ORD(CH) - ORD('0'); NEXTCH; END; IF LCH = 'N' THEN NFILES := VALUE ELSE BEGIN SELECTOR := VALUE; ONSWITCH['H'] := TRUE; END; END; 'X': CONDCOMP := B; 'I': IF SRCLEVEL = SRCNESTMAX THEN ERROR ( 940 ) ELSE BEGIN SRCLEVEL := SRCLEVEL + 1; WITH SRCNEST[SRCLEVEL] DO BEGIN FNAME := FILENAME; LINNR := LINENO; OLDLIST := LIST; SAVEFDB ( FDB, INPUT, FILENAME ); IF EOF(INPUT) THEN BEGIN UNSAVEFDB ( INPUT, FDB ); FILENAME := FNAME; SRCLEVEL := SRCLEVEL - 1; ERROR(941); END ELSE BEGIN WHILE (CH <> '*') AND (CH <> '\') DO NEXTCH; LIST := LIST AND B; IF OLDLIST AND NOT LIST THEN WRITE(')'); IF B THEN BEGIN PAGEEJECT := TRUE; IF OFFSWITCH['D'] THEN LINENO :=0; END END END END; 'Y': PSECTGEN := B ; 'Z': IF B AND NOT CONDCOMP THEN BEGIN OLDLIST := LIST; LIST := FALSE; REPEAT WHILE CH <> '$' DO IF EOLN(INPUT) THEN ENDOFLINE ELSE NEXTCH; NEXTCH; IF CH = 'Z' THEN BEGIN NEXTCH; CONDCOMP := CH = '-' END; UNTIL CONDCOMP; CONDCOMP := FALSE; LIST := OLDLIST END; 'R': RUNTMCHECK := B END; END; IF EOLN(INPUT) THEN ENDOFLINE; IF NOT ( CH IN ['\','*'] ) THEN NEXTCH; UNTIL CH <> ',' END %OPTIONS\ ; (*$Y+*) (* NEW MODULE *) BEGIN %INSYMBOL\ CASECONV := TRUE ; 1: IF CHCNT > LINEWIDTH THEN ENDOFLINE; LOOP WHILE CH = ' ' DO BEGIN IF EOLN(INPUT) OR (CHCNT > LINEWIDTH) THEN ENDOFLINE; NEXTCH END EXIT IF CH <> '%'; NEXTCH; IF CH = OPTIONCONSTR THEN OPTIONS; LOOP IF EOLN(INPUT) OR (CHCNT > LINEWIDTH) THEN ENDOFLINE; EXIT IF CH = '\'; NEXTCH END; NEXTCH END; 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 K := 0; REPEAT IF K < ALFALENG THEN BEGIN K := K + 1; ID[K] := CH END ; NEXTCH UNTIL NOT (CH IN LETTERS OR DIGITS); IF K >= KK THEN KK := K ELSE REPEAT ID[KK] := ' '; KK := KK - 1 UNTIL KK = K; FOR I := FRW[K] TO FRW[K+1] - 1 DO IF RW[I] = ID THEN BEGIN SY := RSY[I]; OP := ROP[I]; GOTO 2 END; SY := IDENT; OP := NOOP; 2: END; '0','1','2','3', '4','5','6', '7','8','9': BEGIN SY := INTCONST; OP := NOOP; I := 0; REPEAT I := I + 1; IF I <= DIGMAX THEN DIGIT[I] := ORD(CH) - ORD('0'); NEXTCH UNTIL NOT (CH IN DIGITS); IF I > DIGMAX THEN BEGIN ERROR(203); I:= DIGMAX END; IVAL := 0; RVAL := 0; IF CH = 'B' THEN BEGIN IF (I>6) OR ((I=6) AND (DIGIT[1]>1)) THEN BEGIN ERROR(203); IVAL := 0 END ELSE FOR K := 1 TO I DO BEGIN IF DIGIT[K] > 7 THEN ERROR(204); IVAL := 8*IVAL + DIGIT[K]; END; VAL.IVAL := IVAL; NEXTCH END ELSE BEGIN SCALE := 0; IF CH = '.' THEN BEGIN NEXTCH; IF CH = '.' THEN CH := ':' ELSE IF CH = ')' THEN CH := ']' ELSE BEGIN FOR K := 1 TO I DO RVAL := RVAL*10E0+DIGIT[K]; SY := REALCONST; IF NOT (CH IN DIGITS) THEN ERROR(201) ELSE REPEAT RVAL := 10E0*RVAL + (ORD(CH) - ORD('0')); SCALE := SCALE - 1; NEXTCH UNTIL NOT (CH IN DIGITS) END END; IF CH = 'E' THEN BEGIN IF SCALE = 0 THEN BEGIN FOR K := 1 TO I DO RVAL := RVAL * 10E0 + DIGIT[K]; SY := REALCONST END; SIGN := FALSE; NEXTCH; IF CH = '+' THEN NEXTCH ELSE IF CH = '-' THEN BEGIN SIGN := TRUE; NEXTCH END; EXP := 0; IF NOT (CH IN DIGITS) THEN ERROR(201) ELSE REPEAT EXP := 10*EXP + (ORD(CH) - ORD('0')); NEXTCH UNTIL NOT (CH IN DIGITS); IF SIGN THEN SCALE := SCALE - EXP ELSE SCALE := SCALE + EXP END; IF SCALE <> 0 THEN BEGIN R := 1E0; %NOTE POSSIBLE OVERFLOW OR UNDERFLOW\ IF SCALE < 0 THEN BEGIN SIGN := TRUE; SCALE := -SCALE END ELSE SIGN := FALSE; FAC := 10E0; REPEAT IF ODD(SCALE) THEN R := R*FAC; FAC := SQR(FAC); SCALE := SCALE DIV 2 UNTIL SCALE = 0; %NOW R = 10^SCALE\ IF SIGN THEN RVAL := RVAL/R ELSE RVAL := RVAL*R END; IF SY = INTCONST THEN BEGIN IF I > 4 THEN J := 4 ELSE J := I; FOR K := 1 TO J DO IVAL := 10 * IVAL + DIGIT[K]; IF (I<5) OR (((I=5) AND (IVAL<3276)) OR ((I=5) AND (IVAL=3276) AND (DIGIT[5]<8))) THEN BEGIN IF I = 5 THEN IVAL := 10*IVAL + DIGIT[5]; VAL.IVAL := IVAL END ELSE BEGIN ERROR(203); IVAL := 0 END END ELSE BEGIN NEW(LVP,REEL); VAL.VALP := LVP; LVP^.RVAL := RVAL; BINEXP := 0; IF RVAL < 0E0 THEN BEGIN SGN := 100000B; RVAL := -RVAL END ELSE SGN := 0; IF RVAL = 0E0 THEN MANT := 0E0 ELSE BEGIN WHILE RVAL < 8388608E0 DO BEGIN RVAL := RVAL * 2E0; BINEXP := BINEXP - 1 END; WHILE RVAL > 16777216E0 DO BEGIN RVAL := RVAL/2E0; BINEXP := BINEXP + 1 END; BINEXP := BINEXP + 24; MANT := RVAL; END; IF (BINEXP < -128) OR (BINEXP > 127) THEN BEGIN ERROR(205); MANT := 0E0 END; WITH LVP^ DO BEGIN SELFCSP := 0; IF MANT = 0E0 THEN BEGIN HEAD := 0; TAIL := 0 END ELSE BEGIN TAIL := TRUNC(MANT-TRUNC(MANT/32768E0)*32768E0); HEAD := TRUNC((MANT-8388608E0)/65536E0) + 128 * (BINEXP + 128) + SGN ; IF ODD(TRUNC(MANT/32768E0)) THEN TAIL := TAIL + 100000B END; END END END END; '''': BEGIN CASECONV := FALSE ; LGTH := 0; SY := STRINGCONST; OP := NOOP; REPEAT REPEAT NEXTCH; STRING[LGTH] := CH; LGTH := LGTH + 1 UNTIL EOLN(INPUT) OR (CH = ''''); IF EOLN(INPUT) AND (CH <> '''') THEN ERROR(202) ELSE NEXTCH UNTIL CH <> ''''; LGTH := LGTH - 1; %NOW LGTH = NR OF CHARS IN STRING\ IF LGTH = 1 THEN VAL.IVAL := ORD(STRING[0]) ELSE BEGIN NEW(LVP,STRG:LGTH-1); WITH LVP^ DO BEGIN SELFCSP := 0; SLGTH := LGTH-1; FOR I := 0 TO SLGTH DO SVAL[I] := STRING[I] END; VAL.VALP := LVP END END; ':': BEGIN OP := NOOP; NEXTCH; IF CH = '=' THEN BEGIN SY := BECOMES; NEXTCH END ELSE SY := COLON END; '.': BEGIN OP := NOOP; NEXTCH; IF CH = '.' THEN BEGIN SY := COLON; NEXTCH END ELSE IF CH = ')' THEN BEGIN SY:=RBRACK; NEXTCH END ELSE SY := PERIOD END; '(': BEGIN NEXTCH; IF CH = '*' THEN BEGIN NEXTCH; IF CH = OPTIONCONSTR THEN OPTIONS; LOOP IF EOLN(INPUT) OR (CHCNT > LINEWIDTH) THEN ENDOFLINE; STAR := CH = '*'; WHILE CH = '*' DO NEXTCH EXIT IF STAR AND ( CH = ')' ) ; NEXTCH END; NEXTCH; GOTO 1; END ELSE BEGIN IF CH = '.' THEN BEGIN SY:= LBRACK; OP := NOOP; NEXTCH END ELSE BEGIN SY := LPARENT; OP := NOOP END END; END; '?','*','/','&','+','-','\', '@','"','#','=','!', ')','[',']',',',';','^','_','$': BEGIN SY := SSY[CH]; OP := SOP[CH]; NEXTCH END; '<','>': BEGIN SY := SSY[CH]; OP := SOP[CH]; NEXTCH; IF CH = '=' THEN BEGIN IF OP = LTOP THEN OP := LEOP ELSE OP := GEOP; NEXTCH END ELSE IF ( CH = '>' ) AND ( OP = LTOP ) THEN BEGIN OP := NEOP ; NEXTCH END END END %CASE\ END %INSYMBOL\ ; PROCEDURE ENTERID(FCP: CTP) (*$Y+*); %ENTER ID POINTED AT BY FCP INTO THE NAME-TABLE, WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS AN UNBALANCED BINARY TREE\ VAR NAM: ALFA; LCP, LCP1: CTP; LLEFT: BOOLEAN; BEGIN NAM := FCP^.NAME; FCP^.SELFCTP := 0; LCP := DISPLAY[TOP].FNAME; IF LCP = NIL THEN DISPLAY[TOP].FNAME := FCP ELSE BEGIN REPEAT LCP1 := LCP; IF LCP^.NAME = NAM THEN %NAME CONFLICT, FOLLOW RIGHT LINK\ BEGIN ERROR(101); LCP := LCP^.RLINK; LLEFT := FALSE END ELSE IF LCP^.NAME < NAM THEN BEGIN LCP := LCP^.RLINK; LLEFT := FALSE END ELSE BEGIN LCP := LCP^.LLINK; LLEFT := TRUE END UNTIL LCP = NIL; IF LLEFT THEN LCP1^.LLINK := FCP ELSE LCP1^.RLINK := FCP END; FCP^.LLINK := NIL; FCP^.RLINK := NIL END %ENTERID\ ; PROCEDURE SRCHSECTION(FCP: CTP; VAR FCP1: CTP) (*$Y+*); %TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S --> PROCEDURE PROCEDUREDECLARATION --> PROCEDURE SELECTOR\ LABEL 1; BEGIN WHILE FCP <> NIL DO IF FCP^.NAME = ID THEN GOTO 1 ELSE IF FCP^.NAME < ID THEN FCP := FCP^.RLINK ELSE FCP := FCP^.LLINK; 1: FCP1 := FCP 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; WHILE LCP <> NIL DO IF LCP^.NAME = ID THEN IF LCP^.KLASS IN FIDCLS THEN GOTO 1 ELSE BEGIN IF PRTERR THEN ERROR(103); LCP := LCP^.RLINK END ELSE IF LCP^.NAME < ID THEN LCP := LCP^.RLINK ELSE LCP := LCP^.LLINK END; %SEARCH NOT SUCCSESSFUL; SUPPRESS ERROR MESSAGE IN CASE OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION --> PROCEDURE SIMPLETYPE\ IF PRTERR THEN BEGIN ERROR(104); %TO AVOID RETURNING NIL, REFERENCE AN ENTRY FOR AN UNDECLARED ID OF APPROPRIATE CLASS --> PROCEDURE ENTERUNDECL\ IF TYPES IN FIDCLS THEN LCP := UTYPPTR ELSE IF VARS 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); %GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE\ %ASSUME (FSP <> NIL) AND (FSP^.FORM <= SUBRANGE) AND (FSP <> INTPTR) AND NOT COMPTYPES(REALPTR,FSP)\ BEGIN WITH FSP^ DO IF FORM = SUBRANGE THEN BEGIN FMIN := MIN.IVAL; FMAX := MAX.IVAL END ELSE BEGIN FMIN := 0; IF FSP = CHARPTR THEN BEGIN FMIN := 40B; FMAX := 140B END ELSE IF FSP = INTPTR THEN FMAX := 0 ELSE IF FSP^.FCONST <> NIL THEN FMAX := FSP^.FCONST^.VALUES.IVAL ELSE FMAX := 0 END END %GETBOUNDS\ ; (*$Y+*) (* NEW MODULE *) PROCEDURE BLOCK(FSYS: SETOFSYS; FSY: SYMBOL; FPROCP: CTP); VAR LSY: SYMBOL; FLABP: LBP; TESTPACKED: BOOLEAN; %TEST FOR PACKED STRUCTURES\ HEAPM: INTP; OLDCIX: INTEGER ; OLDPSECT: ALFA ; OLDGLOBALINDEX: GBLDFRANGE ; PROCEDURE SKIP(FSYS: SETOFSYS); %SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND\ BEGIN WHILE NOT (SY IN FSYS) DO INSYMBOL END %SKIP\ ; PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU); VAR LSP,LSP1: STP; LCP: CTP; SIGN: (NONE,POS,NEG); STEST: REAL; BEGIN LSP := NIL; FVALU.IVAL := 0; IF NOT (SY IN CONSTBEGSYS) THEN BEGIN ERROR(50); SKIP(FSYS OR CONSTBEGSYS) END; IF SY IN CONSTBEGSYS THEN BEGIN IF SY = STRINGCONSTSY THEN BEGIN IF LGTH = 1 THEN LSP := CHARPTR ELSE BEGIN NEW(LSP,ARRAYS); NEW(LSP1,SUBRANGE); WITH LSP^ DO BEGIN AELTYPE := CHARPTR; INXTYPE := LSP1; PACKOPT := FALSE; ADDRCORR := 0; SIZE := 2 * ((LGTH + 1) DIV 2); END ; WITH LSP1^ DO BEGIN SIZE := 2; RANGETYPE := INTPTR; MIN.IVAL := 0; MAX.IVAL := LGTH-1; END 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 WITH FVALU.VALP^ DO BEGIN RVAL := -RVAL; STEST := HEAD; IF (STEST>=32768.0 %CROSS COMPILOR\) OR (STEST<0 %PDP-11 COMPILOR\) THEN HEAD := HEAD - 100000B ELSE HEAD := HEAD + 100000B 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 WITH VAL.VALP^ DO BEGIN RVAL := -RVAL; HEAD := HEAD + 100000B END; LSP := REALPTR; FVALU := VAL; INSYMBOL 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; %DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE\ VAR NXT1,NXT2: CTP; COMP: BOOLEAN; LMIN, LMAX, I: INTEGER; BEGIN IF FSP1 = FSP2 THEN IF FSP1^.FORM = BOUNDLESS THEN COMPTYPES := FALSE ELSE COMPTYPES := TRUE ELSE IF (FSP1 <> NIL) AND (FSP2 <> NIL) THEN IF FSP1^.FORM = FSP2^.FORM THEN CASE FSP1^.FORM OF SCALAR: COMPTYPES := FALSE; % IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE NOT RECOGNIZED TO BE COMPATIBLE\ SUBRANGE: COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2^.RANGETYPE); POINTER: IF POINTERCNT = 10 THEN COMPTYPES := FALSE ELSE BEGIN POINTERCNT := POINTERCNT + 1; COMPTYPES := COMPTYPES(FSP1^.ELTYPE,FSP2^.ELTYPE); POINTERCNT := POINTERCNT - 1; END; POWER: COMPTYPES := COMPTYPES(FSP1^.ELSET,FSP2^.ELSET); ARRAYS: BEGIN COMP := COMPTYPES(FSP1^.AELTYPE,FSP2^.AELTYPE) AND (FSP1^.SIZE = FSP2^.SIZE); IF FSP1^.PACKOPT OR FSP2^.PACKOPT THEN BEGIN GETBOUNDS(FSP1^.INXTYPE,LMIN,LMAX); I := LMAX - LMIN; GETBOUNDS(FSP2^.INXTYPE,LMIN,LMAX); COMP := COMP AND (I = LMAX - LMIN) END %COMPATIBILITY OF PACKED STRUCTURES\ ; COMPTYPES := COMP END; %ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST BE COMPATIBLE. -- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST BE THE SAME\ RECORDS: BEGIN NXT1 := FSP1^.FSTFLD; NXT2 := FSP2^.FSTFLD; COMP := TRUE; WHILE (NXT1 <> NIL) AND (NXT2 <> NIL) DO BEGIN COMP := COMP AND 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; %IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE IFF NO VARIANTS OCCUR\ FILES: COMPTYPES := COMPTYPES(FSP1^.FILTYPE,FSP2^.FILTYPE); BOUNDLESS: COMPTYPES := FALSE; STRINGPARM: COMPTYPES := TRUE 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 BEGIN COMPTYPES := FALSE; IF FSP1^.FORM = STRINGPARM THEN BEGIN IF FSP2^.FORM = ARRAYS THEN COMPTYPES := FSP2^.AELTYPE = CHARPTR END ELSE IF FSP2^.FORM = STRINGPARM THEN IF FSP1^.FORM = ARRAYS THEN COMPTYPES := FSP1^.AELTYPE = CHARPTR END ELSE COMPTYPES := TRUE END %COMPTYPES\ ; FUNCTION STRING(FSP: STP) : BOOLEAN; BEGIN STRING := FALSE; IF FSP <> NIL THEN IF FSP^.FORM = ARRAYS THEN IF COMPTYPES(FSP^.AELTYPE,CHARPTR) THEN STRING := TRUE END %STRING\ ; PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE) (*$Y+*) ; VAR LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP; LSIZE,DISPL: ADDRRANGE; LMIN,LMAX: INTEGER; PSIZE, CORRECTION: INTEGER; PACKFLAG: BOOLEAN; PROCEDURE SIMPLETYPE(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE); VAR LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE; LCNT: INTEGER; LVALU: VALU; BEGIN FSIZE := 2; IF NOT (SY IN SIMPTYPEBEGSYS) THEN BEGIN ERROR(1); SKIP(FSYS OR SIMPTYPEBEGSYS) END; IF SY IN SIMPTYPEBEGSYS THEN BEGIN IF SY = LPARENT THEN BEGIN TTOP := TOP; %DECL. CONSTS LOCAL TO INNERMOST BLOCK\ WHILE DISPLAY[TOP].OCCUR <> BLCK DO TOP := TOP - 1; NEW(LSP,SCALAR,DECLARED); LSP^.SIZE := 2; LSP^.SELFSTP := 0; LCP1 := NIL; LCNT := 0; REPEAT INSYMBOL; IF SY = IDENT THEN BEGIN NEW(LCP,KONST); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := LSP; NEXT := LCP1; VALUES.IVAL := LCNT; END; ENTERID(LCP); LCNT := LCNT + 1; LCP1 := LCP; INSYMBOL END ELSE ERROR(2); IF NOT (SY IN FSYS OR [COMMA,RPARENT]) THEN BEGIN ERROR(6); SKIP(FSYS OR [COMMA,RPARENT]) END UNTIL SY <> COMMA; LSP^.FCONST := LCP1; TOP := TTOP; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END ELSE BEGIN IF SY = IDENT THEN BEGIN SEARCHID([TYPES,KONST],LCP); INSYMBOL; IF LCP^.KLASS = KONST THEN BEGIN NEW(LSP,SUBRANGE); WITH LSP^, LCP^ DO BEGIN RANGETYPE := IDTYPE; SELFSTP := 0; IF STRING(RANGETYPE) THEN BEGIN ERROR(148); RANGETYPE := NIL END; IF RANGETYPE <> NIL THEN SIZE := RANGETYPE^.SIZE; MIN := VALUES END; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); CONSTANT(FSYS,LSP1,LVALU); LSP^.MAX := LVALU; IF LSP^.RANGETYPE <> LSP1 THEN ERROR(107) END ELSE LSP := LCP^.IDTYPE END %SY = IDENT\ ELSE BEGIN NEW(LSP,SUBRANGE); CONSTANT(FSYS OR [COLON],LSP1,LVALU); IF STRING(LSP1) THEN BEGIN ERROR(148); LSP1 := NIL END; WITH LSP^ DO BEGIN RANGETYPE := LSP1; MIN := LVALU; IF RANGETYPE <> NIL THEN SIZE := RANGETYPE^.SIZE END; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); CONSTANT(FSYS,LSP1,LVALU); LSP^.MAX := LVALU; LSP^.SELFSTP := 0; IF LSP^.RANGETYPE <> LSP1 THEN ERROR(107) END; IF LSP <> NIL THEN WITH LSP^ DO IF FORM = SUBRANGE THEN IF RANGETYPE <> NIL THEN IF RANGETYPE = REALPTR THEN BEGIN IF MIN.VALP^.RVAL > MAX.VALP^.RVAL THEN ERROR(102) END ELSE IF MIN.IVAL > MAX.IVAL THEN ERROR(102) END; FSP := LSP; IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END END ELSE FSP := NIL; IF FSP = NIL THEN FSIZE := 2 ELSE FSIZE := FSP^.SIZE END %SIMPLETYPE\ ; PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP; VAR FFSTFLD: CTP); LABEL 1; VAR LCP,LCP1,NXT,NXT1: CTP; LSP,LSP1,LSP2,LSP3,LSP4: STP; MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU; LID: ALFA; BEGIN NXT1 := NIL; LSP := NIL; IF NOT (SY IN [IDENT,CASESY]) THEN BEGIN ERROR(19); SKIP(FSYS OR [IDENT,CASESY]) END; WHILE SY = IDENT DO BEGIN NXT := NXT1; LOOP IF SY = IDENT THEN BEGIN NEW(LCP,FIELD); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := NIL; NEXT := NXT END; NXT := LCP; ENTERID(LCP); INSYMBOL END ELSE ERROR(2); IF NOT (SY IN [COMMA,COLON]) THEN BEGIN ERROR(6); SKIP(FSYS OR [COMMA,COLON,SEMICOLON,CASESY]) END; EXIT IF SY <> COMMA; INSYMBOL END; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); TYP(FSYS OR [CASESY,SEMICOLON],LSP,LSIZE); WHILE NXT <> NXT1 DO WITH NXT^ DO BEGIN IDTYPE := LSP; FLDADDR := DISPL; IF LSP <> NIL THEN IF LSP^.FORM = ARRAYS THEN BEGIN FLDADDR := FLDADDR - LSP^.ADDRCORR; IF NOT PACKFLAG THEN %PACKFLAG INDICATES PACKED ARR\ BEGIN LSP1 := LSP; WHILE LSP1^.AELTYPE^.FORM = ARRAYS DO LSP1 := LSP1^.AELTYPE; PACKFLAG := LSP^.PACKOPT END END; NXT := NEXT; DISPL := DISPL + LSIZE END; NXT1 := LCP; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN [IDENT,CASESY]) THEN BEGIN ERROR(19); SKIP(FSYS OR [IDENT,CASESY]) END END END %WHILE\; NXT := NIL; WHILE NXT1 <> NIL DO WITH NXT1^ DO BEGIN LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP END; FFSTFLD := NXT; IF SY = CASESY THEN BEGIN LCP := NIL ; %POSSIBLY NO TAGFIELDIDENTIFIER\ INSYMBOL; IF SY = IDENT THEN BEGIN LID := ID; INSYMBOL; IF (SY <> COLON) AND (SY <> OFSY) THEN BEGIN ERROR(169); SKIP(FSYS OR [LPARENT]) END ELSE BEGIN IF SY = COLON THEN BEGIN NEW(LSP,TAGFWITHID); NEW(LCP,FIELD); WITH LCP^ DO BEGIN NAME := LID; IDTYPE := NIL; NEXT := NIL; FLDADDR := DISPL END; ENTERID(LCP); INSYMBOL; IF SY <> IDENT THEN BEGIN ERROR(2); SKIP(FSYS OR [LPARENT]); GOTO 1 END ELSE BEGIN LID := ID; INSYMBOL; IF SY <> OFSY THEN BEGIN ERROR(8); SKIP(FSYS OR [LPARENT]); GOTO 1 END; END END ELSE NEW(LSP,TAGFWITHOUTID); WITH LSP^ DO BEGIN SIZE := 0; FSTVAR := NIL; SELFSTP := 0; IF FORM = TAGFWITHID THEN TAGFIELDP := NIL ELSE TAGFIELDTYPE := NIL; END; FRECVAR := LSP; ID := LID; KK := ALFALENG; %RESTAURATION\ SEARCHID([TYPES],LCP1); LSP1 := LCP1^.IDTYPE; IF LSP1 <> NIL THEN IF (LSP1^.FORM <= SUBRANGE) OR STRING(LSP1) THEN BEGIN IF COMPTYPES(REALPTR,LSP1) THEN ERROR(109) ELSE IF STRING(LSP1) THEN ERROR(399); WITH LSP^ DO BEGIN IF FORM = TAGFWITHID THEN BEGIN DISPL := DISPL + LSP1^.SIZE; TAGFIELDP := LCP; IF LCP <> NIL THEN LCP^.IDTYPE := LSP1; END ELSE TAGFIELDTYPE := LSP1 END; END ELSE ERROR(110); INSYMBOL; END END ELSE BEGIN ERROR(2); SKIP(FSYS OR [LPARENT]) END; 1: LSP^.SIZE := DISPL; LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL; LOOP LSP2 := NIL; LOOP CONSTANT(FSYS OR [COMMA,COLON,LPARENT],LSP3,LVALU); IF LSP <> NIL THEN IF LSP^.FORM = TAGFWITHID THEN BEGIN IF LSP^.TAGFIELDP <> NIL THEN IF NOT COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP3) THEN ERROR(111) END ELSE IF NOT COMPTYPES(LSP^.TAGFIELDTYPE,LSP3) THEN ERROR(111); NEW(LSP3,VARIANT); WITH LSP3^ DO BEGIN NXTVAR := LSP1; SUBVAR := LSP2; VARVAL := LVALU; SELFSTP := 0 END; LSP1 := LSP3; LSP2 := LSP3; EXIT IF SY <> COMMA; INSYMBOL END; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9); FIELDLIST(FSYS OR [RPARENT,SEMICOLON],LSP2,LCP); IF DISPL > MAXSIZE THEN MAXSIZE := DISPL; WHILE LSP3 <> NIL DO BEGIN LSP4 := LSP3^.SUBVAR; LSP3^.SUBVAR := LSP2; LSP3^.SIZE := DISPL; LSP3^.FIRSTFIELD := LCP; LSP3 := LSP4 END; IF SY = RPARENT THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS OR [SEMICOLON]) THEN BEGIN ERROR(6); SKIP(FSYS OR [SEMICOLON]) END END ELSE ERROR(4); EXIT IF SY <> SEMICOLON; DISPL := MINSIZE; INSYMBOL END; DISPL := MAXSIZE; LSP^.FSTVAR := LSP1; END ELSE IF LSP <> NIL THEN IF LSP^.FORM = ARRAYS THEN FRECVAR := LSP ELSE FRECVAR := NIL END %FIELDLIST\ ; BEGIN %TYP\ IF NOT (SY IN TYPEBEGSYS) THEN BEGIN ERROR(10); SKIP(FSYS OR TYPEBEGSYS) END; IF SY IN TYPEBEGSYS THEN BEGIN CORRECTION := 0; IF SY IN SIMPTYPEBEGSYS THEN SIMPLETYPE(FSYS,FSP,FSIZE) ELSE %^\ IF SY = ARROW THEN BEGIN NEW(LSP,POINTER); FSP := LSP; WITH LSP^ DO BEGIN ELTYPE := NIL; SIZE := 2; SELFSTP := 0 END; INSYMBOL; IF SY = IDENT THEN BEGIN PRTERR := FALSE; %NO ERROR IF SEARCH NOT SUCCESSFUL\ SEARCHID([TYPES],LCP); PRTERR := TRUE; IF LCP = NIL THEN %FORWARD REFERENCED TYPE ID\ BEGIN NEW(LCP,TYPES); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := LSP; NEXT := FWPTR END; FWPTR := LCP END ELSE BEGIN IF LCP^.IDTYPE <> NIL THEN IF LCP^.IDTYPE^.FORM = FILES THEN ERROR(108) ELSE LSP^.ELTYPE := LCP^.IDTYPE END; INSYMBOL; END ELSE ERROR(2); END ELSE BEGIN IF SY = PACKEDSY THEN BEGIN INSYMBOL; PACKFLAG := TRUE; IF NOT (SY IN TYPEDELS) THEN BEGIN ERROR(10); SKIP(FSYS OR TYPEDELS) END END ELSE PACKFLAG := FALSE; %ARRAY\ IF SY = ARRAYSY THEN BEGIN INSYMBOL; IF SY = LBRACK THEN INSYMBOL ELSE ERROR(11); LSP1 := NIL; LOOP NEW(LSP,ARRAYS); WITH LSP^ DO BEGIN AELTYPE := LSP1; INXTYPE := NIL; SELFSTP := 0; SIZE := 2; PACKOPT := FALSE END; LSP1 := LSP; SIMPLETYPE(FSYS OR [COMMA,RBRACK,OFSY],LSP2,LSIZE); IF LSP2 <> NIL THEN IF LSP2^.FORM <= SUBRANGE THEN BEGIN IF LSP2 = REALPTR THEN BEGIN ERROR(109); LSP2 := NIL END ELSE IF LSP2 = INTPTR THEN BEGIN ERROR(149); LSP2 := NIL END; LSP^.INXTYPE := LSP2 END ELSE BEGIN ERROR(113); LSP2 := NIL END; EXIT IF SY <> COMMA; INSYMBOL END; IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12); IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); TYP(FSYS,LSP,LSIZE); IF LSP <> NIL THEN %FOR CALCULATION OF HYPOTH.ADDR\ IF LSP^.FORM = ARRAYS THEN CORRECTION := LSP^.ADDRCORR; REPEAT WITH LSP1^ DO BEGIN IF FORM = FILES THEN ERROR(108); (*V5-39*) LSP2 := AELTYPE; AELTYPE := LSP; IF PACKFLAG AND (LSP = BOOLPTR) THEN PACKOPT := TRUE; IF INXTYPE <> NIL THEN BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX); IF PACKOPT THEN BEGIN IF AELTYPE = BOOLPTR THEN LSIZE := 2 * ((LMAX - LMIN + 16) DIV 16) END ELSE BEGIN IF COMPTYPES ( AELTYPE , CHARPTR ) THEN %ACTUAL CHARSIZE = 1\ BEGIN CORRECTION := CORRECTION + LMIN; LSIZE := 2 * ((LMAX - LMIN + 2) DIV 2); END ELSE BEGIN CORRECTION := CORRECTION + LMIN * LSIZE; LSIZE := LSIZE * (LMAX - LMIN + 1) END END; ADDRCORR := CORRECTION; SIZE := LSIZE END END; LSP := LSP1; LSP1 := LSP2 UNTIL LSP1 = NIL END ELSE %RECORD\ IF SY = RECORDSY THEN BEGIN INSYMBOL; OLDTOP := TOP; IF TOP < DISPLIMIT THEN BEGIN TOP := TOP + 1; DISPLAY[TOP].FNAME := NIL; DISPLAY[TOP].OCCUR := CREC END ELSE ERROR(250); DISPL := 0; FIELDLIST(FSYS-[SEMICOLON] OR [ENDSY],LSP1,LCP); NEW(LSP,RECORDS); WITH LSP^ DO BEGIN FSTFLD := DISPLAY[TOP].FNAME; SELFSTP := 0; RECVAR := LSP1; SIZE := DISPL; PACKSTRUCT := PACKFLAG END; TOP := OLDTOP; IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13) END ELSE %SET\ IF SY = SETSY THEN BEGIN INSYMBOL; IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); SIMPLETYPE(FSYS,LSP1,LSIZE); IF LSP1 <> NIL THEN IF LSP1^.FORM > SUBRANGE THEN BEGIN ERROR(115); LSP1 := NIL END ELSE IF LSP1 = REALPTR THEN ERROR(114); NEW(LSP,POWER); WITH LSP^ DO BEGIN ELSET := LSP1; SELFSTP := 0; IF LSP1 = CHARPTR THEN BEGIN LMIN := 0; LMAX := 63 END ELSE IF LSP1 <> NIL THEN BEGIN GETBOUNDS(LSP1,LMIN,LMAX); IF (LSP1^.FORM = SUBRANGE) AND (LSP1^.RANGETYPE = CHARPTR) THEN BEGIN LMIN := 0; LMAX := LMAX - 40B END END ELSE LMAX := -1; IF LMIN < 0 THEN ERROR(604); IF LMAX <= 15 THEN SIZE := 2 ELSE IF LMAX < 64 THEN SIZE := 8 ELSE ERROR(604) END END ELSE %FILE\ IF SY = FILESY THEN BEGIN INSYMBOL; IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); TYP(FSYS,LSP1,LSIZE); NEW(LSP,FILES); WITH LSP^ DO BEGIN FILTYPE := LSP1; SIZE := 2; SELFSTP := 0; END; IF LSP1 <> NIL THEN IF LSP1^.FORM = FILES THEN BEGIN ERROR(108); LSP^.FILTYPE := NIL END; END; FSP := LSP END; IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END END ELSE FSP := NIL; IF FSP = NIL THEN FSIZE := 2 ELSE FSIZE := FSP^.SIZE END %TYP\ ; PROCEDURE LABELDECLARATION (*$Y+*) ; LABEL 1; VAR LLP: LBP; BEGIN LOOP IF SY = INTCONST THEN BEGIN LLP := FSTLABP; WHILE LLP <> FLABP DO IF LLP^.LABVAL = VAL.IVAL THEN BEGIN ERROR(166); GOTO 1 END ELSE LLP := LLP^.NEXTLAB; NEW(LLP); WITH LLP^ DO BEGIN LABVAL := VAL.IVAL; DEFINED := FALSE; LABCHAIN := NIL; NEXTLAB := FSTLABP; DECLARED := TRUE END; FSTLABP := LLP; 1: INSYMBOL END ELSE ERROR(15); IF NOT (SY IN FSYS OR [COMMA,SEMICOLON]) THEN BEGIN ERROR(6); SKIP(FSYS OR [COMMA,SEMICOLON]) END; EXIT IF SY <> COMMA; INSYMBOL END; IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14) END %LABELDECLARATION\ ; PROCEDURE CONSTDECLARATION (*$Y+*) ; VAR LCP: CTP; LSP: STP; LVALU: VALU; BEGIN IF SY <> IDENT THEN BEGIN ERROR(2); SKIP(FSYS OR [IDENT]) END; WHILE SY = IDENT DO BEGIN NEW(LCP,KONST); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := NIL; NEXT := NIL; KADDR := 0 END; INSYMBOL; IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16); CONSTANT(FSYS OR [SEMICOLON],LSP,LVALU); ENTERID(LCP); LCP^.IDTYPE := LSP; LCP^.VALUES := LVALU; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS OR [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS OR [IDENT]) END END ELSE ERROR(14) END END %CONSTANTDECLARATION\ ; PROCEDURE TYPEDECLARATION (*$Y+*) ; VAR LCP,LCP1,LCP2: CTP; LSP: STP; LSIZE: ADDRRANGE; BEGIN IF SY <> IDENT THEN BEGIN ERROR(2); SKIP(FSYS OR [IDENT]) END; WHILE SY = IDENT DO BEGIN NEW(LCP,TYPES); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := NIL END; INSYMBOL; IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16); TYP(FSYS OR [SEMICOLON],LSP,LSIZE); ENTERID(LCP); LCP^.IDTYPE := LSP; %HAS ANY FORWARD REFERENCE BEEN SATISFIED:\ LCP1 := FWPTR; WHILE LCP1 <> NIL DO BEGIN IF LCP1^.NAME = LCP^.NAME THEN BEGIN LCP1^.IDTYPE^.ELTYPE := LCP^.IDTYPE; IF LCP1 <> FWPTR THEN LCP2^.NEXT := LCP1^.NEXT ELSE FWPTR := LCP1^.NEXT; END; LCP2 := LCP1; LCP1 := LCP1^.NEXT END; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS OR [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS OR [IDENT]) END END ELSE ERROR(14) END; IF FWPTR <> NIL THEN BEGIN ERROR(117); IF LIST THEN BEGIN WRITELN; REPEAT WRITELN(' TYPE-ID ',FWPTR^.NAME); FWPTR := FWPTR^.NEXT UNTIL FWPTR = NIL; IF NOT EOLN(INPUT) THEN WRITE(' ':CHCNT + 8) END END END %TYPEDECLARATION\ ; PROCEDURE VARDECLARATION (*$Y+*) ; VAR LCP,NXT: CTP; LSP: STP; LSIZE: ADDRRANGE; FILEP: EXTFILEP; BEGIN NXT := NIL; REPEAT LOOP IF SY = IDENT THEN BEGIN NEW(LCP,VARS); WITH LCP^ DO BEGIN NAME := ID; NEXT := NXT; IDTYPE := NIL; VKIND := ACTUAL; VLEV := LEVEL END; ENTERID(LCP); NXT := LCP; INSYMBOL; END ELSE ERROR(2); IF NOT (SY IN FSYS OR [COMMA,COLON] OR TYPEDELS) THEN BEGIN ERROR(6); SKIP(FSYS OR [COMMA,COLON,SEMICOLON] OR TYPEDELS) END; EXIT IF SY <> COMMA; INSYMBOL END; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); TYP(FSYS OR [SEMICOLON] OR TYPEDELS,LSP,LSIZE); WHILE NXT <> NIL DO WITH NXT^ DO BEGIN IDTYPE := LSP; LC := LC - LSIZE; VADDR := LC; IF LSP <> NIL THEN BEGIN IF LSP^.FORM = ARRAYS THEN VADDR := VADDR - LSP^.ADDRCORR; IF LSP^.FORM = FILES THEN BEGIN NFILES := NFILES + 1; LSIZE := LSP^.FILTYPE^.SIZE; VADDR := VADDR - LSIZE; % ALLOCATE SPACE FOR RECORD BUFFER \ LC := LC-FILESIZECORR-LSIZE; IF LEVEL > 1 THEN ERROR(108); IF COMPTYPES ( LSP^.FILTYPE, CHARPTR ) THEN LC := LC - TEXTBUFFSIZE IF TRUE THEN FILEP := EXTFILE;(***** HPA ERROR *****) WHILE FILEP <> NIL DO BEGIN IF FILEP^.NAME = NXT^.NAME THEN FILEP^.DECL:=TRUE; FILEP:=FILEP^.NEXT;  END; END; END; NXT := NEXT END; IF LSP <> NIL THEN IF LSP^.FORM = ARRAYS THEN BEGIN IF NOT TESTPACKED THEN BEGIN WHILE LSP^.AELTYPE^.FORM = ARRAYS DO LSP := LSP^.AELTYPE; TESTPACKED := LSP^.PACKOPT %BASE LEVEL OF ARRAY PACKED?\ END END ELSE IF LSP^.FORM = RECORDS THEN %CHECK IF A RECORD CONTAINS PACKED ARRAYSTRUCTURES\ TESTPACKED := TESTPACKED OR LSP^.PACKSTRUCT; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS OR [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS OR [IDENT]) END END ELSE ERROR(14) UNTIL (SY <> IDENT) AND NOT (SY IN TYPEDELS); IF FWPTR <> NIL THEN BEGIN ERROR(117); WRITELN; REPEAT WRITELN(' TYPE-ID ',FWPTR^.NAME); FWPTR := FWPTR^.NEXT UNTIL FWPTR = NIL; IF NOT EOLN(INPUT) THEN WRITE(' ':CHCNT + 8) END END %VARIABLEDECLARATION\ ; PROCEDURE PROCEDUREDECLARATION(FSY: SYMBOL); VAR OLDLEV: LEVRANGE; LSY: SYMBOL; LCP,LCP1: CTP; LSP: STP; INTRPT: BOOLEAN; FORW: BOOLEAN; OLDTOP: DISPRANGE; LLC,LCM, PARLC,PARSIZE: ADDRRANGE; PROCEDURE PARAMTRLIST(FSY: SETOFSYS; VAR FPAR: CTP) (*$Y+*) ; VAR LCP,LCP1,LCP2,LCP3: CTP; LSP: STP; LKIND: IDKIND; LCP4: CTP; LSP1,LSP2: STP; DIM: INTEGER; PROCEDURE PARAMETERSPECIFICATION(FSY: SETOFSYS; VAR FPAR: CTP); VAR LCP,LCP1,LCP2: CTP; LSP: STP; LKIND: IDKIND; OK, ERRFOUND: BOOLEAN; %DIGESTS THE ADDED SYNTACTIC UNIT: \ PROCEDURE PSERROR(ERRORNO: INTEGER; STOPSYS: SETOFSYS); BEGIN IF NOT ERRFOUND THEN BEGIN ERRFOUND := TRUE; ERROR(ERRORNO) END; SKIP(STOPSYS) END; % PSERROR\ BEGIN LCP1 := NIL; ERRFOUND := FALSE; WHILE SY IN [LPARENT,SEMICOLON] DO BEGIN INSYMBOL; OK := FALSE; IF SY = PROCEDURESY THEN BEGIN NEW(LCP,PROC,DECLARED,FORMAL); WITH LCP^ DO BEGIN IDTYPE := NIL; NEXT := LCP1; PARMLIST := NIL END; LCP1 := LCP ; INSYMBOL; IF SY = LPARENT THEN BEGIN PARAMETERSPECIFICATION(FSY,LCP2); LCP1^.PARMLIST := LCP2 END ; OK := TRUE END ELSE IF SY = FUNCTIONSY THEN BEGIN NEW(LCP,FUNC,DECLARED,FORMAL); WITH LCP^ DO BEGIN NEXT := LCP1; PARMLIST := NIL; IDTYPE := NIL END; LCP1 := LCP; INSYMBOL; IF SY = LPARENT THEN BEGIN PARAMETERSPECIFICATION(FSY, LCP2); LCP1^.PARMLIST := LCP2 END ; IF SY = COLON THEN BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN SEARCHID([TYPES],LCP); LSP := LCP^.IDTYPE; INSYMBOL; IF LSP <> NIL THEN IF LSP^.FORM >= FILES THEN BEGIN ERROR(120); LSP := NIL END; LCP1^.IDTYPE := LSP; OK := TRUE END END END %IF FUNCTIONSY\ ELSE BEGIN IF SY = VARSY THEN BEGIN INSYMBOL; LKIND := FORMAL; IF SY <> COLON THEN ERROR(607) ELSE INSYMBOL END ELSE LKIND := ACTUAL; IF SY = IDENT THEN BEGIN SEARCHID([TYPES],LCP); LSP := LCP^.IDTYPE; IF LSP <> NIL THEN IF (LKIND = ACTUAL) AND (LSP^.FORM = FILES) THEN ERROR(121); NEW(LCP,VARS); WITH LCP^ DO BEGIN VKIND := LKIND; IDTYPE := LSP; NEXT := LCP1 END; LCP1 := LCP; INSYMBOL; OK := TRUE END END; IF NOT (SY IN [RPARENT,SEMICOLON]) OR NOT OK THEN BEGIN PSERROR(608,[LPARENT,RPARENT,SEMICOLON] OR FSY); WHILE SY = LPARENT DO BEGIN PARAMETERSPECIFICATION(FSY,LCP2); SKIP([LPARENT,RPARENT,SEMICOLON] OR FSY) END END END; %WHILE SY\ IF SY = RPARENT THEN INSYMBOL; IF ERRFOUND THEN FPAR := NIL ELSE BEGIN LCP := NIL; WHILE LCP1 <> NIL DO WITH LCP1^ DO BEGIN LCP2 := NEXT; NEXT := LCP; LCP := LCP1; LCP1 := LCP2; END; FPAR := LCP END END; %PARAMETERSPECIFICATION\ BEGIN LCP1 := NIL; PARLC := 2; %ADDRESS OF LAST PARAMETER IN THE LIST\ IF NOT (SY IN FSY OR [LPARENT]) THEN BEGIN ERROR(7); SKIP(FSYS OR FSY OR [LPARENT]) END; IF SY = LPARENT THEN BEGIN IF FORW THEN ERROR(119); INSYMBOL; IF NOT (SY IN [IDENT,VARSY,PROCEDURESY,FUNCTIONSY]) THEN BEGIN ERROR(7); SKIP(FSYS OR [IDENT,RPARENT]) END; WHILE SY IN [IDENT,VARSY,PROCEDURESY,FUNCTIONSY] DO BEGIN IF SY = PROCEDURESY THEN BEGIN LCP4 := LCP1; %FOR PARAMETERSPECIFICATION\ REPEAT INSYMBOL; IF SY = IDENT THEN BEGIN NEW(LCP,PROC,DECLARED,FORMAL); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := NIL; NEXT := LCP1; PFLEV := LEVEL; PARMLIST := NIL; %ADDRESSING OF PARAMETERS CAN ONLY BE DONE AFTER THEIR TOTAL LENGTH HAS BECOME KNOWN\ END; ENTERID(LCP); LCP1 := LCP; INSYMBOL END ELSE ERROR(2); IF NOT (SY IN FSYS OR [LPARENT,COMMA,SEMICOLON,RPARENT]) THEN BEGIN ERROR(7); SKIP(FSYS OR [COMMA,LPARENT, SEMICOLON,RPARENT]) END UNTIL SY <> COMMA; IF SY = LPARENT THEN PARAMETERSPECIFICATION(FSYS OR [SEMICOLON,RPARENT],LCP) ELSE LCP := NIL; LCP2 := LCP1 ; %COPY POINTER TO PROCEDURE-ID LIST\ WHILE LCP2 <> LCP4 DO %CHAIN SPECIF.LIST TO PROCEDURE-ID\ BEGIN LCP2^.PARMLIST := LCP; LCP2 := LCP2^.NEXT END; END ELSE BEGIN IF SY = FUNCTIONSY THEN BEGIN LCP2 := NIL; REPEAT INSYMBOL; IF SY = IDENT THEN BEGIN NEW(LCP,FUNC,DECLARED,FORMAL); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := NIL; NEXT := LCP2; PFLEV := LEVEL; PARMLIST := NIL; END; ENTERID(LCP); LCP2 := LCP; INSYMBOL; END; IF NOT (SY IN [COMMA,COLON,LPARENT]) THEN BEGIN ERROR(7); SKIP(FSYS OR [COMMA,SEMICOLON, RPARENT]) END; UNTIL SY <> COMMA; IF SY = LPARENT THEN PARAMETERSPECIFICATION(FSYS OR [SEMICOLON,COLON,RPARENT] ,LCP4) ELSE LCP4 := NIL; IF SY = COLON THEN BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN SEARCHID([TYPES],LCP); LSP := LCP^.IDTYPE; IF LSP <> NIL THEN IF LSP^.FORM >= FILES THEN BEGIN ERROR(120); LSP := NIL END; LCP3 := LCP2; WHILE LCP2 <> NIL DO BEGIN LCP2^.IDTYPE := LSP; LCP := LCP2; LCP2^.PARMLIST := LCP4; LCP2 := LCP2^.NEXT END; LCP^.NEXT := LCP1; LCP1 := LCP3; INSYMBOL END ELSE ERROR(2); IF NOT (SY IN FSYS OR [SEMICOLON,RPARENT]) THEN BEGIN ERROR(7); SKIP(FSYS OR [SEMICOLON,RPARENT]) END END ELSE ERROR(5) END ELSE BEGIN IF (SY = IDENT) AND (ID = 'STRING ') THEN BEGIN PARSIZE := 4; NEW(LSP,STRINGPARM); LSP^.SIZE := PARSIZE; REPEAT %READ NEXT IDENTIFIER\ INSYMBOL; IF SY = IDENT THEN BEGIN NEW(LCP,VARS); WITH LCP^ DO BEGIN NAME := ID; NEXT := LCP1; IDTYPE := LSP; VKIND := FORMAL; VLEV := LEVEL; VADDR := PARSIZE; %TEMPORARILY CONTAINS SIZE\ END; ENTERID(LCP); LCP1 := LCP; INSYMBOL; END ELSE ERROR(2); IF NOT (SY IN [COMMA,SEMICOLON,RPARENT]) THEN BEGIN ERROR(7); SKIP(FSYS OR [COMMA,SEMICOLON,RPARENT]) END; UNTIL SY <> COMMA; END ELSE BEGIN IF SY = VARSY THEN BEGIN LKIND := FORMAL; INSYMBOL END ELSE LKIND := ACTUAL; LCP2 := NIL; LOOP IF SY = IDENT THEN BEGIN NEW(LCP,VARS); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := LSP; VKIND := LKIND; NEXT := LCP2; VLEV := LEVEL; END; ENTERID(LCP); LCP2 := LCP; INSYMBOL; END; IF NOT (SY IN [COMMA,COLON] OR FSYS) THEN BEGIN ERROR(7); SKIP(FSYS OR [COMMA,SEMICOLON, RPARENT]) END; EXIT IF SY <> COMMA; INSYMBOL END; IF SY = COLON THEN BEGIN INSYMBOL; IF NOT (SY IN [IDENT,ARRAYSY]) THEN ERROR(601) ELSE BEGIN IF SY = ARRAYSY THEN BEGIN IF LKIND <> FORMAL THEN ERROR(602); INSYMBOL; LSP1 := NIL; IF SY = LBRACK THEN INSYMBOL ELSE ERROR(11); LOOP NEW(LSP, BOUNDLESS); LSP^.SUBSTRUCT := LSP1; LSP1 := LSP; TYP(FSYS OR [COMMA,RBRACK,OFSY],LSP2,DIM); IF LSP2 <> NIL THEN IF LSP2^.FORM = SCALAR THEN BEGIN IF LSP2 = REALPTR THEN BEGIN ERROR(109); LSP2 := NIL END END ELSE BEGIN ERROR(600); LSP2 := NIL END; LSP^.INDEXTYPE := LSP2; EXIT IF SY <> COMMA; INSYMBOL END; IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12); IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); IF SY = IDENT THEN BEGIN SEARCHID([TYPES], LCP); LSP2 := LCP^.IDTYPE END ELSE ERROR(2); LSP := LSP2; DIM := 1; REPEAT WITH LSP1^ DO BEGIN LSP2 := SUBSTRUCT; SUBSTRUCT := LSP; UNSPECLEVEL := DIM; SIZE := 0 END; DIM := DIM + 1; LSP := LSP1; LSP1 := LSP2; UNTIL LSP1 = NIL; PARSIZE := 2 * (DIM - 1) END ELSE IF SY = IDENT THEN BEGIN SEARCHID([TYPES],LCP); LSP := LCP^.IDTYPE; IF (LSP <> NIL) AND (LKIND = ACTUAL) THEN BEGIN IF LSP^.FORM = FILES THEN ERROR(121); PARSIZE := LSP^.SIZE END ELSE PARSIZE := 2; END; LCP3 := LCP2; WHILE LCP2 <> NIL DO BEGIN LCP2^.IDTYPE := LSP; LCP := LCP2; LCP2^.VADDR := PARSIZE; %VADDR TEMPORARILY CONTAINS THE SIZE OF THE PARAMETER IN THE PARAMETERLIST \ LCP2 := LCP2^.NEXT END; LCP^.NEXT := LCP1; LCP1 := LCP3; INSYMBOL; END; IF NOT (SY IN FSYS OR [SEMICOLON,RPARENT]) THEN BEGIN ERROR(7); SKIP(FSYS OR [SEMICOLON,RPARENT]) END END ELSE ERROR(5); END; END; END; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS OR [IDENT,VARSY,PROCEDURESY,FUNCTIONSY]) THEN BEGIN ERROR(7); SKIP(FSYS OR [IDENT,RPARENT]) END END END %WHILE\ ; IF SY = RPARENT THEN BEGIN INSYMBOL; IF NOT (SY IN FSY OR FSYS) THEN BEGIN ERROR(6); SKIP(FSY OR FSYS) END END ELSE ERROR(4); LCP3 := NIL; %REVERSE POINTERS AND ASSIGN ADDRESSES TO THE PARAMETERS\ WHILE LCP1 <> NIL DO WITH LCP1^ DO BEGIN IF (KLASS = PROC) OR (KLASS = FUNC) THEN BEGIN PFADDR := PARLC; PARLC := PARLC + 4 END ELSE BEGIN PARSIZE := VADDR; %KLASS = VARS\ VADDR := PARLC; PARLC := PARLC + PARSIZE; IF (VKIND = ACTUAL) AND ( IDTYPE^.FORM = ARRAYS) THEN VADDR := VADDR - IDTYPE^.ADDRCORR END; LCP2 := NEXT; NEXT := LCP3 ; LCP3 := LCP1; LCP1 := LCP2 END; FPAR := LCP3 END ELSE FPAR := NIL END % PARAMETERLIST \ ; PROCEDURE EXTERNALDECL(FCP:CTP) (*$Y+*) ; VAR LCP: CTP; BEGIN FCP^.DECLPLACE := EXTRNL; IF SY = LPARENT THEN WITH FCP^ DO BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN IF ID = 'FORTRAN ' THEN DECLPLACE := EXTERNFORTRAN ELSE ERROR(399) ; INSYMBOL; IF SY = COMMA THEN INSYMBOL ELSE IF SY <> RPARENT THEN ERROR(20); END % IF IDENT \ ; IF SY = STRINGCONST THEN BEGIN NEW(EXTNAME); WITH VAL.VALP^ DO FOR I := 0 TO ALFALENG-1 DO IF I > SLGTH THEN EXTNAME^[I+1] := ' ' ELSE EXTNAME^[I+1] := SVAL[I]; INSYMBOL END % IF STRING \ ; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4); END % IF LPARENT \ ; IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); IF NOT ( SY IN FSYS ) THEN BEGIN ERROR(6); SKIP(FSYS) END; LCP := FCP^.NEXT; IF FCP^.DECLPLACE = EXTERNFORTRAN THEN WHILE LCP <> NIL DO BEGIN IF LCP^.VKIND <> FORMAL THEN ERROR(182); LCP^.VKIND := FORMAL; LCP := LCP^.NEXT; FCP^.PFLEV := 0; END; END % EXTERNALDECL \ ; PROCEDURE FINDEXTNAME( FCP: CTP ); LABEL 1,99; VAR DOT,I: INTEGER; LCP: CTP; CH: CHAR; SLOW: ALFA; FUNCTION COMPSTR(S1,S2: ALFA): BOOLEAN; VAR I: INTEGER; B: BOOLEAN; BEGIN B:=TRUE; FOR I:=1 TO 6 DO B := B AND ( S1[I]=S2[I] ); COMPSTR := B; END % COMPSTR \ ; FUNCTION COMP(FCP:CTP):BOOLEAN; LABEL 9,99; BEGIN IF FCP = NIL THEN COMP := FALSE ELSE IF NOT (FCP^.KLASS IN [PROC,FUNC]) THEN GOTO 9 ELSE IF COMPSTR(FCP^.NAME,SLOW) THEN COMP := TRUE ELSE IF FCP^.PFDECKIND<>DECLARED THEN GOTO 9 ELSE IF FCP^.PFKIND<>ACTUAL THEN GOTO 9 ELSE IF FCP^.EXTNAME=NIL THEN GOTO 9 ELSE IF COMPSTR(FCP^.EXTNAME^,SLOW) THEN COMP := TRUE ELSE GOTO 9; GOTO 99; 9: IF COMP(FCP^.LLINK) THEN COMP := TRUE ELSE COMP := COMP(FCP^.RLINK); 99: END % COMP \; BEGIN % FINDEXTNAME \ SLOW := FCP^.NAME; DOT := 7; CH := ' '; IF DOLLARNAME THEN BEGIN SLOW[6] := '$'; FOR I:=1 TO 5 DO IF SLOW[I]=' ' THEN SLOW[I]:='$'; END; IF COMPSTR(PROGNAME,SLOW) THEN BEGIN DOT:=6; CH:=SLOW[6]; SLOW[6]:='.' END; 1: FOR I := TOP DOWNTO 1 DO BEGIN IF COMP(DISPLAY[I].FNAME) THEN BEGIN IF DOT = 1 THEN BEGIN ERROR(931); GOTO 99 END ELSE BEGIN SLOW[DOT] := CH; DOT := DOT-1; CH := SLOW[DOT]; SLOW[DOT] := '.'; GOTO 1; END END % IF COMP \ END %FOR \; 99: IF DOLLARNAME OR (DOT < 7) THEN BEGIN NEW(FCP^.EXTNAME); FCP^.EXTNAME^ := SLOW; END ELSE FCP^.EXTNAME := NIL; END % FINDEXTNAME \; (*$Y+*) (* NEW MODULE *) BEGIN %PROCEDUREDECLARATION\ PARLC := 0; LLC := LC; IF ONSWITCH['D'] THEN LC := -6 ELSE LC := -2; IF SY = IDENT THEN BEGIN SRCHSECTION(DISPLAY[TOP].FNAME,LCP); %DECIDE WHETHER FORW.\ IF LCP <> NIL THEN BEGIN IF LCP^.KLASS = PROC THEN FORW := (LCP^.DECLPLACE=FORWDECL) AND (FSY = PROCEDURESY) AND (LCP^.PFKIND = ACTUAL) ELSE IF LCP^.KLASS = FUNC THEN FORW := (LCP^.DECLPLACE=FORWDECL) AND (FSY = FUNCTIONSY) AND (LCP^.PFKIND = ACTUAL) ELSE FORW := FALSE; IF NOT FORW THEN ERROR(160) END ELSE FORW := FALSE; IF NOT FORW THEN BEGIN IF FSY = PROCEDURESY THEN NEW(LCP,PROC,DECLARED,ACTUAL) ELSE NEW(LCP,FUNC,DECLARED,ACTUAL); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := NIL; NEXT := NIL; FINDEXTNAME(LCP); PFLEV := LEVEL; PFADDR := 0; DECLPLACE := INTERNAL; END; ENTERID(LCP) END; INSYMBOL END ELSE BEGIN ERROR(2); IF FSY = PROCEDURESY THEN LCP := UPRCPTR ELSE LCP := UFCTPTR; END; OLDLEV := LEVEL; OLDTOP := TOP; LEVEL := LEVEL + 1; IF TOP < DISPLIMIT THEN BEGIN TOP := TOP + 1; WITH DISPLAY[TOP] DO BEGIN IF FORW THEN FNAME := LCP^.NEXT ELSE FNAME := NIL; OCCUR := BLCK END END ELSE ERROR(250); IF FSY = PROCEDURESY THEN BEGIN PARAMTRLIST([SEMICOLON],LCP1); IF NOT FORW THEN LCP^.NEXT := LCP1 END ELSE BEGIN PARAMTRLIST([SEMICOLON,COLON],LCP1); IF NOT FORW THEN LCP^.NEXT := LCP1; IF SY = COLON THEN BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN IF FORW THEN ERROR(122); SEARCHID([TYPES],LCP1); LSP := LCP1^.IDTYPE; LCP^.IDTYPE := LSP; IF LSP <> NIL THEN IF LSP^.FORM >= FILES THEN BEGIN ERROR(120); LCP^.IDTYPE := NIL END; INSYMBOL END ELSE BEGIN ERROR(2); SKIP(FSYS OR [SEMICOLON]) END END ELSE IF NOT FORW THEN ERROR(123) END; IF NOT FORW THEN LCP^.PARLISTSIZE := PARLC; IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); IF SY = FORWARDSY THEN BEGIN IF FORW THEN ERROR(161) ELSE LCP^.DECLPLACE := FORWDECL ; INSYMBOL; IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END END ELSE IF SY = EXTERNALSY THEN BEGIN INSYMBOL; EXTERNALDECL(LCP) END ELSE BEGIN WITH LCP^ DO IF DECLPLACE = FORWDECL THEN DECLPLACE := FORWFOUND ; REPEAT BLOCK(FSYS,SEMICOLON,LCP); IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN [BEGINSY,PROCEDURESY,FUNCTIONSY]) THEN BEGIN ERROR(6); SKIP(FSYS) END END ELSE IF MAIN OR (LEVEL > 2) THEN ERROR(14) UNTIL SY IN [BEGINSY,PROCEDURESY,FUNCTIONSY,PERIOD]; END; LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC; END %PROCEDUREDECLARATION\ ; (*$Y+*) (* NEW MODULE *) PROCEDURE BODY(FSYS: SETOFSYS); VAR I: INTEGER; CIX1: CODERANGE ; LCMAX,LLC1,ADDR: ADDRRANGE; LCP: CTP; LLP: LBP; INTRPT: BOOLEAN; (* MNC - ADDED THE FOLLOWING VARIABLE TO KEEP TRACK OF CONTEXT FOR OPTIMIZING. ALL OPTIMIZING CODE REFERS TO IT, SO I HAVE NOT MARKED SUCH CODE. SEARCH FOR EVERY OCCURRENCE OF "PREV[" TO FIND THE OPTIMIZING CODE. ALSO NOTE ADDITION OF PROCEDURE DELPREVINSTR: *) PREV: ARRAY [-1 .. 0] OF (* MNC - CONTEXT FOR CODE OPTIMIZATION *) RECORD (* PREV[-1] IS CONTEXT PREVIOUS TO PREV[0] *) LOCINSTR: -1 .. OBJECTRECSIZE; OPCODE: INSTRRANGE; SRCMODE, SRCREG, DSTMODE, DSTREG: INTEGER; SUBRNAME: RUNTIMEROUTS END; PROCEDURE WRITOBJ ( VAR REC: OBJECTRECORD ) ; BEGIN IF NOT OFFSWITCH['K'] THEN WRITOFILE( REC, PDP11OBJ (*$Z+*) , OUTPUTHGH (*$Z-*) ) ELSE REC.LEN := 1; PREV[0].LOCINSTR := -1; PREV[-1].LOCINSTR := -1; END; (*$Y-*) (* NO MODULE SPLITTING FOR A WHILE *) FUNCTION RAD50 ( FSTR: ALFA ; FINDEX: INTEGER ): INTEGER ; VAR I,J: INTEGER ; FUNCTION RAD50C ( CH: CHAR ): INTEGER ; BEGIN IF CH IN LETTERS THEN RAD50C := ORD(CH) - 64 ELSE IF CH IN DIGITS THEN RAD50C := ORD(CH) - 18 ELSE IF CH = ' ' THEN RAD50C := 0 ELSE IF CH = '$' THEN RAD50C := 27 ELSE IF CH = '.' THEN RAD50C := 28 ELSE RAD50C := 29 END ; BEGIN % RAD50 \ J := 0 ; FOR I := FINDEX TO FINDEX + 2 DO J := 40 * J + RAD50C ( FSTR[I] ) ; RAD50 := J END ; PROCEDURE DELPREVINSTR(RELOCCMDSIZE: INTEGER); BEGIN WITH CODE, PREV[0] DO BEGIN CIX := CIX - (LEN + 1 - LOCINSTR); LEN := LOCINSTR - 1; LOCINSTR := PREV[-1].LOCINSTR; PREV[-1].LOCINSTR := -1; OPCODE := PREV[-1].OPCODE; SRCMODE := PREV[-1].SRCMODE; SRCREG := PREV[-1].SRCREG; DSTMODE := PREV[-1].DSTMODE; DSTREG := PREV[-1].DSTREG; RLD.LEN := RLD.LEN - RELOCCMDSIZE; END; END; PROCEDURE PUTGR50 ( R50N1,R50N2,FLAGS,FVAL: INTEGER ) ; BEGIN WITH GSD DO BEGIN (* MNC - I CHANGED INTEGER CONSTANTS TO EXPRESSIONS INVOLVING OBJECTRECSIZE, WHEREVER APPROPRIATE, WHEN I DOUBLED THE LENGTH OF OBJECT RECORDS (SEE MNC COMMENT AT DECL OF OBJECTRECSIZE). SEARCH FOR EVERY FOLLOWING OCCURRENCE OF OBJECTRECSIZE: *) IF LEN > OBJECTRECSIZE-5 THEN WRITOBJ ( GSD ) ; VALUE[LEN+1] := R50N1 ; VALUE[LEN+2] := R50N2 ; VALUE[LEN+3] := FLAGS ; VALUE[LEN+4] := FVAL ; LEN := LEN + 4 ; END END ; PROCEDURE PUTGSD ( FNAM: ALFA ; FLAGS,FVAL: INTEGER ) ; BEGIN PUTGR50 ( RAD50(FNAM,1) , RAD50(FNAM,4), FLAGS, FVAL ) END; PROCEDURE PUTRLD ( FNAM: ALFA ; FTYP,FDISPL,FVAL: INTEGER ) ; BEGIN WITH RLD DO BEGIN VALUE[LEN+1] := FTYP + 256 * FDISPL ; IF FTYP <> 8 THEN BEGIN VALUE [ LEN+2 ] := RAD50 ( FNAM, 1 ) ; VALUE [ LEN + 3 ] := RAD50 ( FNAM, 4 ) ; LEN := LEN + 2 END; VALUE [ LEN + 2 ] := FVAL ; LEN := LEN + 2 ; IF LEN > OBJECTRECSIZE - 5 THEN BEGIN WRITOBJ(CODE) ; WRITOBJ(RLD) END ; END ; (*$Z+*) IF PRCODE AND (FTYP = RELOCFCN) THEN WRITELN( CEX, ';', FNAM:60 ); (*$Z-*) END ; PROCEDURE GLOBALDEF ( FNAM: ALFA ; FADDR: CODERANGE ) ; BEGIN IF GLOBALINDEX = GBLDFMAX THEN ERROR ( 999 ) ELSE BEGIN GLOBALINDEX := GLOBALINDEX + 1 ; WITH GLOBALENTRY [ GLOBALINDEX ] DO BEGIN EPADDR := FADDR ; R50P1 := RAD50 ( FNAM, 1 ) ; R50P2 := RAD50 ( FNAM, 4 ) ; END END END ; PROCEDURE PSECTDEF ( FNAM: ALFA ; FSIZE: CODERANGE ) ; VAR I: INTEGER ; BEGIN PUTGSD ( FNAM, PSECTDEFFLAGS, FSIZE ) ; FOR I := OLDGLOBALINDEX + 1 TO GLOBALINDEX DO WITH GLOBALENTRY [ I ] DO PUTGR50 ( R50P1, R50P2, GLOBALDEFFLAGS, EPADDR ) ; END ; PROCEDURE INCCIX; BEGIN CIX := CIX + 1; IF CODE.LEN = OBJECTRECSIZE-1 THEN BEGIN WRITOBJ ( CODE ) ; IF RLD.LEN > 1 THEN WRITOBJ ( RLD ) ; END ; WITH CODE DO BEGIN IF LEN = 1 THEN BEGIN PREV[0].OPCODE := TRAP ; (* NOT USABLE FOR OPTIMIZATION *) LEN := 2 ; VALUE [ 2 ] := 2 * CIX END ; LEN := LEN + 1 END END; (*$Z+*) PROCEDURE WRITEREG(MODE,REG: INTEGER ); BEGIN IF ODD(MODE DIV 8) THEN WRITE(CEX,'@'); CASE MODE DIV 16 OF 0: WRITE(CEX,REGNAMES[REG]); 1: IF REG = PC THEN WRITE(CEX,'<>C') ELSE WRITE(CEX,'(',REGNAMES[REG],')+'); 2: WRITE(CEX,'-(',REGNAMES[REG],')'); 3: WRITE(CEX,'X(',REGNAMES[REG],')') END END %WRITEREG \ ; (*$Z-*) PROCEDURE GEN1(NEWOPCODE: INSTRRANGE; NEWMODE, NEWREG: INTEGER); VAR BYTE: PACKED ARRAY[0..3] OF CHAR; BEGIN INCCIX; WITH CODE DO BEGIN VALUE [ LEN ] := INSTRVAL[NEWOPCODE] + NEWMODE + NEWREG ; (* MNC: *) PREV[-1] := PREV[0]; WITH PREV[0] DO BEGIN LOCINSTR := LEN; OPCODE := NEWOPCODE; DSTMODE := NEWMODE; DSTREG := NEWREG; END; (*$Z+*) IF PRCODE THEN BEGIN IF NEWOPCODE < CLR THEN BYTE := 'B ' ELSE BYTE := ' '; WRITE(CEX,2*CIX:6:O,' ',VALUE[LEN]:6:O,MN[NEWOPCODE]:10,BYTE); WRITEREG(NEWMODE,NEWREG); WRITELN(CEX) END (*$Z-*) END END; %GEN1\ PROCEDURE GEN2(NEWOPCODE: INSTRRANGE; NEWSRCMODE, NEWSRCREG, NEWDSTMODE, NEWDSTREG: INTEGER); VAR BYTE: PACKED ARRAY[0..3] OF CHAR; MODIFIEDPREVINSTR: BOOLEAN; BEGIN WITH CODE DO BEGIN MODIFIEDPREVINSTR := FALSE; IF (PREV[0].LOCINSTR >= LEN - 1) THEN IF (NEWSRCMODE = AUTINC) AND (NEWSRCREG = SP) THEN IF (INSTRVAL[NEWOPCODE] >= 0) THEN (* NOT A BYTE INSTRUCTION *) WITH PREV[0] DO IF (INSTRVAL[OPCODE] + DSTMODE + DSTREG = INSTRVAL[MOV] + AUTDEC + SP) THEN BEGIN VALUE[LOCINSTR] := VALUE[LOCINSTR] - 10045B + INSTRVAL[NEWOPCODE] + NEWDSTMODE + NEWDSTREG; OPCODE := NEWOPCODE; DSTMODE := NEWDSTMODE; DSTREG := NEWDSTREG; MODIFIEDPREVINSTR := TRUE; END; IF NOT MODIFIEDPREVINSTR THEN BEGIN INCCIX; VALUE [ LEN ] := INSTRVAL[NEWOPCODE] + 64 * (NEWSRCMODE + NEWSRCREG) + NEWDSTMODE + NEWDSTREG; (* MNC - OPTIMIZATION: *) PREV[-1] := PREV[0]; WITH PREV[0] DO BEGIN LOCINSTR := LEN; OPCODE := NEWOPCODE; SRCMODE := NEWSRCMODE; SRCREG := NEWSRCREG; DSTMODE := NEWDSTMODE; DSTREG := NEWDSTREG; END; (*$Z+*) IF PRCODE THEN BEGIN IF NEWOPCODE < CLR THEN BYTE :='B ' ELSE BYTE:=' '; WRITE(CEX,2*CIX:6:O,' ',VALUE[LEN]:6:O,MN[NEWOPCODE]:10,BYTE); WRITEREG(NEWSRCMODE,NEWSRCREG); WRITE(CEX,','); WRITEREG(NEWDSTMODE,NEWDSTREG); WRITELN(CEX) END (*$Z-*) END END END; %GEN2\ PROCEDURE GENBR(BRCODE: INSTRRANGE; OFFS: INTEGER); VAR OFFSET: INTEGER; BEGIN INCCIX; IF OFFS < 0 THEN OFFSET := OFFS + 256 ELSE OFFSET := OFFS; WITH CODE DO BEGIN VALUE [ LEN ] := INSTRVAL[BRCODE] + OFFSET ; (*$Z+*) IF PRCODE THEN WRITELN(CEX,2*CIX:6:O,' ',VALUE[LEN]:6:O, MN[BRCODE]:10,OFFS:8,' ; ',2*(CIX+1+OFFS):6:O) (*$Z-*) END END; %GENBR\ PROCEDURE GENCONST(CNST: INTEGER); BEGIN INCCIX; WITH CODE DO VALUE [LEN] := CNST ; (*$Z+*) IF PRCODE THEN WRITELN(CEX,2*CIX:6:O,' ',CNST:6:O,' ',CNST:12) (*$Z-*) END %GENCONST\ ; PROCEDURE GENSUBRCALL (SUBRNAME:RUNTIMEROUTS ); FORWARD; PROCEDURE LINENODEF; BEGIN IF LINENO <> OLDLINENO THEN BEGIN OLDLINENO := LINENO; IF TRACE THEN GENSUBRCALL ( TRACK ); GEN2(MOV,AUTINC,PC,INDEX,GP); GENCONST(LINENO); GENCONST(LINEADDR); IF FREQUENCE OR DEBUG THEN WITH LASTLINE DO BEGIN GEN1 ( TST,AUTINC,PC ); GENCONST ( 0 ); IF LLADDR <> 0 THEN PUTRLD ( LLPSECT,15B%PSECT ADD.REL.\,2*CODE.LEN-2,2*LLADDR); LLPSECT := PSECT; LLADDR := CIX - 4; END; IF FREQUENCE THEN BEGIN GEN1( INC,AUTINC,PC ); GENCONST ( 0 ) END; END END % LINENODEF \; PROCEDURE MOVETOSP( N: INTEGER ); VAR I: INTEGER; BEGIN IF N > 4 THEN BEGIN GENSUBRCALL(MOVTS); GENCONST( N ); END ELSE FOR I:=1 TO N DO GEN2( MOV,AUTDEC,AD,AUTDEC,SP ); END % MOVE TO SP \; PROCEDURE MOVEFROMSP( N: INTEGER ); VAR I: INTEGER; BEGIN IF N > 4 THEN BEGIN GENSUBRCALL( MOVFS ); GENCONST( N ); END ELSE FOR I:=1 TO N DO GEN2( MOV,AUTINC,SP,AUTINC,AD ); END % MOVE FROM SP \; PROCEDURE LOD (P: LEVRANGE; Q,SIZE: ADDRRANGE); %FOR ADDRESSING VARI-\ VAR I, REGISTER: INTEGER; %ABLES ON INTERMEDIATE\ BEGIN %LEVELS\ IF SIZE = 2 THEN BEGIN IF P = 0 THEN REGISTER := MP ELSE BEGIN REGISTER := AD; GEN2(MOV,REGDEF,MP,REG,AD); FOR I := 2 TO P DO GEN2(MOV,REGDEF,AD,REG,AD) END; IF COMPTYPES( GATTR.TYPTR, CHARPTR ) THEN BEGIN GEN1(CLR, AUTDEC,SP); GEN2(MOVB,INDEX,REGISTER,REGDEF,SP) END ELSE GEN2(MOV,INDEX,REGISTER,AUTDEC,SP); GENCONST(Q) END %SIZE = 2\ ELSE BEGIN IF P = 0 THEN GEN2(MOV,REG,MP,REG,AD) ELSE BEGIN GEN2(MOV,REGDEF,MP,REG,AD); FOR I := 2 TO P DO GEN2(MOV,REGDEF,AD,REG,AD) END; GEN2(ADD,AUTINC,PC,REG,AD); GENCONST(Q + SIZE); %Q AND SIZE IN BYTES\ MOVETOSP( SIZE DIV 2 ); END END; %LOD \ PROCEDURE LDO (Q, VSIZE: ADDRRANGE); %FOR LOADING GLOBALLY DECLARED\ VAR I: INTEGER; %VARIABLES\ BEGIN IF VSIZE = 2 THEN IF COMPTYPES( GATTR.TYPTR , CHARPTR ) THEN BEGIN GEN1(CLR,AUTDEC,SP); GEN2(MOVB,INDEX,GP,REGDEF,SP); GENCONST(Q); END ELSE BEGIN GEN2(MOV,INDEX,GP,AUTDEC,SP); GENCONST(Q) END ELSE BEGIN GEN2(MOV,REG,GP,REG,AD); GEN2(ADD,AUTINC,PC,REG,AD); GENCONST(Q + VSIZE); MOVETOSP( VSIZE DIV 2 ); END END; %LDO \ PROCEDURE GENSUBRCALL; %GENERATES RTRCALLS\ VAR ID: ALFA ; I: INTEGER ; BEGIN ID[1] := '$' ; FOR I := 0 TO 4 DO ID[I+2] := RNA[SUBRNAME][I] ; FOR I := 7 TO ALFALENG DO ID[I] := ' ' ; GEN2( JSR, REG, MP, INDEX, PC ) ; GENCONST ( 0 ) ; PUTRLD ( ID, RELOCFCN, 2*CODE.LEN-2, 0 ) ; PREV[-1].SUBRNAME := PREV[0].SUBRNAME; PREV[0].SUBRNAME := SUBRNAME; IF NOTCALLED [SUBRNAME] THEN BEGIN NOTCALLED [SUBRNAME] := FALSE ; PUTGSD ( ID, GLOBALREFFLAGS, 0 ) END ; END; %GENSUBRCALL\ PROCEDURE GENUJP(LADDR: CODERANGE); BEGIN IF (LADDR <> 0) AND (CIX - LADDR <= 126) THEN GENBR(BR,LADDR - CIX - 2) ELSE BEGIN GEN1(JMP,INDEX,PC); IF LADDR<>0 THEN GENCONST(2 * (LADDR-CIX-2)) ELSE GENCONST(0) END; END; %GENUJP\ PROCEDURE INSERT(ADDRS: CODERANGE; OFFST: ADDRRANGE); BEGIN IF CODE.LEN > 1 THEN WRITOBJ( CODE ) ; WITH RLD DO BEGIN IF LEN > OBJECTRECSIZE-3 THEN WRITOBJ ( RLD ) ; VALUE [ LEN+1 ] := 8 ; % REDEFINE CURRENT LOCATION POINTER \ VALUE [ LEN+2 ] := 2 * ADDRS ; % NEW LOCATION \ LEN := LEN + 2 ; WRITOBJ ( RLD ) END ; WITH CODE DO BEGIN VALUE [ 2 ] := 2*ADDRS ; VALUE [ 3 ] := OFFST ; LEN := 3 ; WRITOBJ ( CODE ) ; END ; WITH RLD DO BEGIN VALUE [ 2 ] := 8 ; VALUE [ 3 ] := 2 * CIX + 2 ; LEN := 3 ; WRITOBJ ( RLD ) ; END ; (*$Z+*) IF PRCODE THEN BEGIN WRITELN(CEX,';'); WRITELN(CEX,2*ADDRS:6:O,' ',OFFST:6:O); WRITELN(CEX,';'); END (*$Z-*) END ; PROCEDURE LOAD; VAR I: INTEGER; BEGIN WITH GATTR DO IF TYPTR <> NIL THEN BEGIN CASE KIND OF CST: IF TYPTR^.FORM = SCALAR THEN IF TYPTR = REALPTR THEN BEGIN %HERE A REAL VALUE IS REPRESENTED BY TWO PDP-11 INTEGERS\ GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(CVAL.VALP^.TAIL); GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(CVAL.VALP^.HEAD); END ELSE IF CVAL.IVAL = 0 THEN GEN1(CLR,AUTDEC,SP) ELSE BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(CVAL.IVAL) END %FORM = SCALAR\ ELSE IF TYPTR = NILPTR THEN GEN1(CLR,AUTDEC,SP) ELSE ERROR(400); VARBL: CASE ACCESS OF DRCT: IF VLEVEL <= 1 THEN LDO(DPLMT,TYPTR^.SIZE) ELSE LOD(LEVEL - VLEVEL,DPLMT,TYPTR^.SIZE); INDRCT: IF TYPTR^.SIZE = 2 THEN IF COMPTYPES ( TYPTR , CHARPTR ) THEN BEGIN GEN2(MOV,AUTINC,SP,REG,AD); GEN1(CLR,AUTDEC,SP); IF IDPLMT = 0 THEN GEN2(MOVB,REGDEF,AD,REGDEF,SP) ELSE BEGIN GEN2(MOVB,INDEX,AD,REGDEF,SP); GENCONST(IDPLMT) END END ELSE IF IDPLMT = 0 THEN GEN2(MOV,AUTINCDEF,SP,AUTDEC,SP) ELSE BEGIN GEN2(MOV,AUTINC,SP,REG,AD); GEN2(MOV,INDEX,AD,AUTDEC,SP); GENCONST(IDPLMT) END ELSE BEGIN GEN2(MOV,AUTINC,SP,REG,AD); GEN2(ADD,AUTINC,PC,REG,AD); GENCONST(IDPLMT + TYPTR^.SIZE); MOVETOSP( TYPTR^.SIZE DIV 2 ); END; PACKD: IF TYPTR = BOOLPTR THEN GENSUBRCALL(LPB) ELSE ERROR(400) END; EXPR: END; KIND := EXPR END END %LOAD\ ; PROCEDURE GENFJP(LADDR: CODERANGE); VAR TSTNEEDED: BOOLEAN; BRTYPE, OPPBRTYPE: INSTRRANGE; BEGIN (* MNC - NOTE EXTENSIVE CHANGES TO THIS PROCEDURE, TO OPTIMIZE OUT MOST TST INSTRUCTIONS. SAVINGS IN COMPILER = 2400. WORDS. *) LOAD; IF GATTR.TYPTR # NIL THEN IF GATTR.TYPTR # BOOLPTR THEN ERROR(144); BRTYPE := BEQ; OPPBRTYPE := BNE; TSTNEEDED := TRUE; WITH CODE DO IF (PREV[0].LOCINSTR >= LEN - 1) THEN BEGIN TSTNEEDED := FALSE; WITH PREV[0] DO IF (INSTRVAL[OPCODE] + DSTMODE + DSTREG) = 10045B THEN BEGIN VALUE[LOCINSTR] := INSTRVAL[TST] + SRCMODE + SRCREG; OPCODE := TST; DSTMODE := SRCMODE; DSTREG := SRCREG; END ELSE IF (DSTMODE + DSTREG) = (REGDEF + SP) THEN BEGIN VALUE[LOCINSTR] := VALUE[LOCINSTR] - REGDEF + AUTINC; DSTMODE := AUTINC; END ELSE IF (VALUE[LOCINSTR] = INSTRVAL[JSR] + 100B * MP + INDEX + PC) AND (SUBRNAME >= EQU) AND (SUBRNAME <= LEQ) AND (RLD.LEN >= 5) THEN BEGIN DELPREVINSTR(4); (* ELIM THE CALL TO INT COMPARE ROUTINE *) GEN2(CMP, AUTINC, SP, AUTINC, SP); CASE SUBRNAME OF (* NOTE: SINCE OUR CMP INSTR COMPARES RIGHT, LEFT INSTEAD OF LEFT, RIGHT, WE HAVE TO USE THE MIRROR-IMAGE COND BR. ALSO, SINCE WE WANT TO BR ON FALSE, WE USE NEGATION OF MIRROR-IMAGE CONDITIONAL BRANCH. *) NEQ: BEGIN BRTYPE := BEQ; OPPBRTYPE := BNE; END; EQU: BEGIN BRTYPE := BNE; OPPBRTYPE := BEQ; END; LES: BEGIN BRTYPE := BLE; OPPBRTYPE := BGT; END; LEQ: BEGIN BRTYPE := BLT; OPPBRTYPE := BGE; END; GEQ: BEGIN BRTYPE := BGT; OPPBRTYPE := BLE; END; GRT: BEGIN BRTYPE := BGE; OPPBRTYPE := BLT; END END; END ELSE TSTNEEDED := TRUE; END; IF TSTNEEDED THEN GEN1(TST,AUTINC,SP); IF (LADDR # 0) AND (CIX - LADDR <= 126) THEN GENBR(BRTYPE,LADDR - CIX - 2) %BACKWARD JUMP WITH OFFSET <= 128\ ELSE BEGIN GENBR(OPPBRTYPE, 2); GEN1(JMP,INDEX,PC); IF LADDR # 0 THEN GENCONST(2 * (LADDR - CIX - 2)) ELSE GENCONST(0) END END; %GENFJP\ (*$Y+*) (* MODULE SPLITTING *) PROCEDURE STORE(VAR FATTR: ATTR); VAR I,P,REGISTER: INTEGER; BEGIN WITH FATTR DO IF TYPTR <> NIL THEN CASE ACCESS OF DRCT: IF VLEVEL <= 1 THEN %STORE AT GLOBAL LEVEL\ BEGIN IF TYPTR^.SIZE = 2 THEN BEGIN IF COMPTYPES ( TYPTR , CHARPTR ) THEN BEGIN GEN2(MOV,AUTINC,SP,REG,R); GEN2(MOVB,REG,R,INDEX,GP) END ELSE GEN2(MOV,AUTINC,SP,INDEX,GP); GENCONST(DPLMT) END ELSE BEGIN GEN2(MOV,REG,GP,REG,AD); GEN2(ADD,AUTINC,PC,REG,AD); GENCONST(DPLMT); MOVEFROMSP( TYPTR^.SIZE DIV 2 ); END END ELSE BEGIN P := LEVEL - VLEVEL; IF TYPTR^.SIZE = 2 THEN BEGIN IF P = 0 THEN REGISTER := MP ELSE BEGIN REGISTER := AD; GEN2(MOV,REGDEF,MP,REG,AD); FOR I := 2 TO P DO GEN2(MOV,REGDEF,AD,REG,AD) END; IF COMPTYPES ( TYPTR , CHARPTR ) THEN BEGIN GEN2(MOV,AUTINC,SP,REG,R); GEN2(MOVB,REG,R,INDEX,REGISTER) END ELSE GEN2(MOV,AUTINC,SP,INDEX,REGISTER); GENCONST(DPLMT) END ELSE BEGIN IF P = 0 THEN GEN2(MOV,REG,MP,REG,AD) ELSE BEGIN GEN2(MOV,REGDEF,MP,REG,AD); FOR I := 2 TO P DO GEN2(MOV,REGDEF,AD,REG,AD) END; GEN2(ADD,AUTINC,PC,REG,AD); GENCONST(DPLMT); MOVEFROMSP( TYPTR^.SIZE DIV 2 ); END END; INDRCT: IF IDPLMT <> 0 THEN ERROR(400) ELSE BEGIN IF TYPTR^.SIZE = 2 THEN IF COMPTYPES ( TYPTR , CHARPTR ) THEN BEGIN GEN2(MOV,AUTINC,SP,REG,R); GEN2(MOVB,REG,R,AUTINCDEF,SP) END ELSE GEN2(MOV,AUTINC,SP,AUTINCDEF,SP) ELSE BEGIN GEN2(MOV,INDEX,SP,REG,AD); GENCONST(TYPTR^.SIZE); MOVEFROMSP( TYPTR^.SIZE DIV 2 ); GEN1(TST,AUTINC,SP) END END; PACKD: IF TYPTR = BOOLPTR THEN GENSUBRCALL(STPB) ELSE ERROR(400) END END %STORE\ ; (*$Y+*) (* MODULE SPLITTING *) PROCEDURE LOADADDRESS; VAR I,J: INTEGER; BEGIN WITH GATTR DO IF TYPTR <> NIL THEN BEGIN CASE KIND OF CST: IF NOT STRING(TYPTR) THEN ERROR(400); VARBL: CASE ACCESS OF DRCT: BEGIN IF VLEVEL <= 1 THEN GEN2(MOV,REG,GP,AUTDEC,SP) ELSE BEGIN I := LEVEL - VLEVEL; IF I = 0 THEN GEN2(MOV,REG,MP,AUTDEC,SP) ELSE IF I = 1 THEN GEN2(MOV,REGDEF,MP,AUTDEC,SP) ELSE BEGIN GEN2(MOV,REGDEF,MP,REG,AD); FOR J := 3 TO I DO GEN2(MOV,REGDEF,AD,REG,AD); GEN2(MOV,REGDEF,AD,AUTDEC,SP) END END; GEN2(ADD,AUTINC,PC,REGDEF,SP); GENCONST(DPLMT) END; INDRCT: IF IDPLMT <> 0 THEN BEGIN GEN2(ADD,AUTINC,PC,REGDEF,SP); GENCONST(IDPLMT) END; PACKD: END; EXPR: ERROR(616) END; KIND := VARBL; IF ACCESS <> PACKD THEN BEGIN ACCESS := INDRCT; IDPLMT := 0 END END END; %LOADADDRESS\ PROCEDURE COPYTREE(FCP: CTP; VAR NAMECP: CTP) (*$Y+*); (* USED, IF D+ OPTION, TO COPY IDENTIFIER-,STRUCTURE- AND CONSTANT TABLES TO $DDTDF SECTION. NOTE THAT THE FIRST TWO FIELDS (SELFXXX, NOCODE) ARE NOT COPIED. INPUT: FCP POINTS AT ROOT OF IDTREE TO BE COPIED. NAMECP POINTS AT ID RECORD OF PROCEDURE TO WHICH IDTREE IS LOCAL . OUTPUT: NAMECP POINTS AT FIRST RECORD OF COPIED TREE *) CONST MAXRECSIZE = 44; (* OF CONSTANT-,STRUCTURE- AND IDENTIFIER RECORD *) TYPE RECORDFORM = (NONE,CONSTNTREC,STRUCTUREREC,IDENTIFREC); RECSIRANGE = 1..MAXRECSIZE; VAR LCP : CTP; LCIX: INTEGER; RECSIZE : RECSIRANGE; PASS1: BOOLEAN; RELOC : PACKED ARRAY[RECSIRANGE] OF BOOLEAN; RECORDTRANS: RECORD CASE RECORDFORM OF NONE : (REC: ARRAY[RECSIRANGE] OF INTEGER); CONSTNTREC: (CONSTREC: CONSTNT); STRUCTUREREC: (STRUCTREC: STRUCTURE); IDENTIFREC: (IDENTREC: IDENTIFIER) END; PTRTRANS: RECORD (* TRANSFORMS AN ADDRESS INTO A POINTER *) CASE VARIANTE: INTEGER OF 1: (PTRIX : ADDRRANGE); 2: (IXCSP : CSP); 3: (IXCTP : CTP); 4: (IXSTP : STP) END; PROCEDURE WRITERECORD; VAR I: RECSIRANGE; BEGIN WITH RECORDTRANS DO FOR I:=3 TO RECSIZE DO BEGIN GENCONST(REC[I]); IF RELOC[I] THEN PUTRLD('$DDTDF ',ABSADDR,2*CODE.LEN-2,2*REC[I]); END END (* WRITERECORD *); FUNCTION CONSTRECSIZE(FCSP: CSP) : INTEGER; (* RETURNS THE ACTUAL SIZE OF CONSTANT RECORD FCSP^ *) BEGIN WITH FCSP^ DO CASE CCLASS OF REEL: CONSTRECSIZE:=7; PSET: CONSTRECSIZE:=7; STRG: CONSTRECSIZE:=5+(SLGTH DIV 2) END END (* CONSTRECSIZE *); PROCEDURE COPYCSP(FCSP: CSP); (* COPY COSTANT RECORD *) VAR I : RECSIRANGE; BEGIN IF FCSP<>NIL THEN WITH FCSP^ DO IF PASS1 THEN BEGIN IF SELFCSP=0 THEN BEGIN SELFCSP:=DCIX; NOCODE:=TRUE; DCIX:=DCIX+CONSTRECSIZE(FCSP) - 2 END END ELSE IF NOCODE THEN BEGIN RECORDTRANS.CONSTREC:=FCSP^; RECSIZE:= CONSTRECSIZE(FCSP); FOR I:=3 TO RECSIZE DO RELOC[I]:=FALSE; WRITERECORD; NOCODE:=FALSE END END (* COPYCSP *); PROCEDURE COPYSTP(FSP: STP); FORWARD; PROCEDURE COPYCTP(FCP: CTP); (* COPY IDENTIFIER RECORD *) VAR I : RECSIRANGE; BEGIN IF FCP<>NIL THEN WITH FCP^ DO IF (PASS1 AND (SELFCTP=0)) OR (NOT PASS1 AND NOCODE) THEN BEGIN IF PASS1 THEN BEGIN SELFCTP:=DCIX; NOCODE:=TRUE; DCIX:=DCIX+IDRECSIZE[KLASS] - 2 END ELSE (* PASS 2 *) WITH RECORDTRANS DO BEGIN RECSIZE:=IDRECSIZE[KLASS]; FOR I:=3 TO RECSIZE DO RELOC[I]:=FALSE; IDENTREC:=FCP^; WITH IDENTREC DO BEGIN IF LLINK<>NIL THEN BEGIN PTRTRANS.PTRIX:=LLINK^.SELFCTP; LLINK:=PTRTRANS.IXCTP; RELOC[9]:=TRUE END; IF RLINK<>NIL THEN BEGIN PTRTRANS.PTRIX:=RLINK^.SELFCTP; RLINK:=PTRTRANS.IXCTP; RELOC[8]:=TRUE; END; IF NEXT<>NIL THEN BEGIN PTRTRANS.PTRIX:=NEXT^.SELFCTP; NEXT:=PTRTRANS.IXCTP; RELOC[11]:=TRUE END; IF IDTYPE<>NIL THEN BEGIN IF KLASS=KONST THEN IF (IDTYPE^.FORM>POINTER) OR (IDTYPE=REALPTR) THEN BEGIN PTRTRANS.PTRIX:=VALUES.VALP^.SELFCSP; VALUES.VALP:=PTRTRANS.IXCSP; RELOC[13]:=TRUE END; IF (KLASS=PROC) OR (KLASS=FUNC) THEN IF PFDECKIND=DECLARED THEN IF PFKIND=FORMAL THEN IF PARMLIST<>NIL THEN BEGIN PTRTRANS.PTRIX:=PARMLIST^.SELFCTP; PARMLIST:=PTRTRANS.IXCTP; RELOC[18]:=TRUE END; PTRTRANS.PTRIX:=IDTYPE^.SELFSTP; IDTYPE:=PTRTRANS.IXSTP; RELOC[10]:=TRUE END END (* WITH IDENTREC *); WRITERECORD; NOCODE:=FALSE END (* WITH RECORDTRANS *); COPYCTP(LLINK); COPYCTP(RLINK); COPYSTP(IDTYPE); COPYCTP(NEXT); IF (KLASS=KONST) AND (IDTYPE<>NIL) THEN IF (IDTYPE^.FORM>POINTER) OR (IDTYPE=REALPTR) THEN COPYCSP(VALUES.VALP); IF (KLASS=PROC) OR (KLASS=FUNC) THEN IF PFDECKIND=DECLARED THEN IF PFKIND=FORMAL THEN COPYCTP(PARMLIST); END END (* COPYCTP *); PROCEDURE COPYSTP; (* COPY STRUCTURE RECORD *) VAR I : RECSIRANGE; BEGIN IF FSP<>NIL THEN WITH FSP^ DO IF (PASS1 AND (SELFSTP=0)) OR (NOT PASS1 AND NOCODE) THEN BEGIN IF PASS1 THEN BEGIN SELFSTP:=DCIX; NOCODE:=TRUE; DCIX:=DCIX+STRECSIZE[FORM] - 2 END ELSE (* PASS 2 *) WITH RECORDTRANS DO BEGIN RECSIZE:=STRECSIZE[FORM]; FOR I:=3 TO RECSIZE DO RELOC[I]:=FALSE; STRUCTREC:=FSP^; WITH STRUCTREC,PTRTRANS DO CASE FORM OF SCALAR : IF SCALKIND=DECLARED THEN IF FCONST<>NIL THEN BEGIN PTRIX:=FCONST^.SELFCTP; FCONST:=IXCTP; RELOC[6]:=TRUE END; SUBRANGE: BEGIN PTRIX:=RANGETYPE^.SELFSTP; RANGETYPE:=IXSTP; RELOC[5]:=TRUE END; POINTER : IF ELTYPE<>NIL THEN BEGIN PTRIX:=ELTYPE^.SELFSTP; ELTYPE:=IXSTP; RELOC[5]:=TRUE END; POWER : BEGIN PTRIX:=ELSET^.SELFSTP; ELSET:=IXSTP; RELOC[5]:=TRUE END; ARRAYS : BEGIN PTRIX:=AELTYPE^.SELFSTP; AELTYPE:=IXSTP; RELOC[6]:=TRUE; PTRIX:=INXTYPE^.SELFSTP; INXTYPE:=IXSTP; RELOC[5]:=TRUE END; RECORDS : BEGIN IF FSTFLD<>NIL THEN BEGIN PTRIX:=FSTFLD^.SELFCTP; FSTFLD:=IXCTP; RELOC[5]:=TRUE END; IF RECVAR<>NIL THEN BEGIN PTRIX:=RECVAR^.SELFSTP; RECVAR:=IXSTP; RELOC[6]:=TRUE END; END; FILES : BEGIN PTRIX:=FILTYPE^.SELFSTP; FILTYPE:=IXSTP; RELOC[5]:=TRUE END; BOUNDLESS: BEGIN IF SUBSTRUCT<>NIL THEN BEGIN PTRIX:=SUBSTRUCT^.SELFSTP; SUBSTRUCT:=IXSTP; RELOC[6]:=TRUE END; IF INDEXTYPE<>NIL THEN BEGIN PTRIX:=INDEXTYPE^.SELFSTP; INDEXTYPE:=IXSTP; RELOC[5]:=TRUE END; END; TAGFWITHID, TAGFWITHOUTID : BEGIN PTRIX:=FSTVAR^.SELFSTP; FSTVAR:=IXSTP; RELOC[5]:=TRUE; IF FORM=TAGFWITHID THEN BEGIN PTRIX:=TAGFIELDP^.SELFCTP; TAGFIELDP:=IXCTP; RELOC[6]:=TRUE END ELSE BEGIN PTRIX:=TAGFIELDTYPE^.SELFSTP; TAGFIELDTYPE:=IXSTP; RELOC[6]:=TRUE; END END; VARIANT : BEGIN IF FIRSTFIELD<>NIL THEN BEGIN PTRIX:=FIRSTFIELD^.SELFCTP; FIRSTFIELD:=IXCTP; RELOC[5]:=TRUE; END; IF NXTVAR<>NIL THEN BEGIN PTRIX:=NXTVAR^.SELFSTP; NXTVAR:=IXSTP; RELOC[7]:=TRUE; END; IF SUBVAR<>NIL THEN BEGIN PTRIX:=SUBVAR^.SELFSTP; SUBVAR:=IXSTP; RELOC[6]:=TRUE END END END (* CASE FORM *); WRITERECORD; NOCODE:=FALSE END (* WITH RECORDTRANS *); CASE FORM OF SCALAR : IF SCALKIND=DECLARED THEN COPYCTP(FCONST); SUBRANGE : COPYSTP(RANGETYPE); POINTER : COPYSTP(ELTYPE); POWER : COPYSTP(ELSET); ARRAYS : BEGIN COPYSTP(AELTYPE); COPYSTP(INXTYPE) END; RECORDS : BEGIN COPYCTP(FSTFLD); COPYSTP(RECVAR) END; FILES : COPYSTP(FILTYPE); BOUNDLESS: BEGIN COPYSTP(SUBSTRUCT); COPYSTP(INDEXTYPE) END; TAGFWITHID, TAGFWITHOUTID: BEGIN COPYSTP(FSTVAR); IF FORM=TAGFWITHID THEN COPYCTP(TAGFIELDP) ELSE COPYSTP(TAGFIELDTYPE) END; VARIANT : BEGIN COPYCTP(FIRSTFIELD); COPYSTP(NXTVAR); COPYSTP(SUBVAR) END END (* CASE FORM *) END END (* COPYSTP *); (*$Y+*) (* NEW MODULE *) BEGIN (* BODY OF COPYTREE *) IF NAMECP<>NIL THEN BEGIN (* INSERT DUMMY ID RECORD WITH NAME=NAMECP^.NAME IN FRONT OF TREE *) IF NAMECP^.KLASS=FUNC THEN NEW(LCP,FUNC,DECLARED,ACTUAL) ELSE NEW(LCP,PROC,DECLARED,ACTUAL); WITH LCP^ DO BEGIN SELFCTP:=0; NOCODE:=TRUE; NAME:=NAMECP^.NAME; LLINK:=FCP; (* POINTS AT ROOT OF REAL TREE *) RLINK:=NIL; IDTYPE:=NIL; NEXT:=NIL; PFLEV:=0; PFADDR:=0; PARLISTSIZE:=0; DECLPLACE:=INTERNAL; EXTNAME:=NIL END; FCP:=LCP END; NAMECP:=FCP; LCIX:=CIX; CIX:=DCIX; DCIX:=DCIX+1; PUTRLD('$DDTDF ',7,0,2*CIX+2); IF CODE.LEN > 1 THEN WRITOBJ(CODE); IF RLD.LEN > 1 THEN WRITOBJ(RLD); FOR PASS1:=TRUE DOWNTO FALSE DO COPYCTP(FCP); DCIX:=CIX; CIX:=LCIX; PUTRLD(PSECT,7,0,2*CIX+2) IF CODE.LEN >1 THEN WRITOBJ(CODE); IF RLD.LEN > 1 THEN WRITOBJ(RLD); END (* COPYTREE *); (*$Y+*) (* NEW MODULE *) PROCEDURE STATEMENT(FSYS: SETOFSYS); LABEL 1; VAR LCP: CTP; LLP: LBP; PROCEDURE MULTIPLY; BEGIN IF EXTSET THEN BEGIN GEN2(MOV,AUTINC,SP,REG,R); GEN2(MULT,REG,R,AUTINC,SP); GEN2(MOV,REG,R,AUTDEC,SP); END ELSE GENSUBRCALL(MPI); END; %MULTIPLY\ PROCEDURE EXPRESSION(FSYS: SETOFSYS); FORWARD; (* MNC - THE FOLLOWING IS A DUMMY PROCEDURE (IT IS JUST: SELECTOR:: JMP DOSELECTOR .END ), IN ORDER TO ALLOW HEAVIER OVERLAYING (SEE HUGPASBLD.ODL): *) PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP); EXTERN; PROCEDURE DOSELECTOR(FSYS: SETOFSYS; FCP: CTP); (*$Y+*) VAR LATTR: ATTR; LCP: CTP; LMIN,LMAX: INTEGER; P,SUBSTRSIZE: INTEGER; LSP1: STP; BEGIN IF FCP <> NIL THEN %FCP = NIL INDICATES EITHER A STRINGCONSTANT OR A FUNCTIONRESULT OF\ %MULTIPLE TYPE FROM WHICH AN ELEMENT MUST BE SELECTED\ WITH FCP^, GATTR DO BEGIN TYPTR := IDTYPE; KIND := VARBL; CASE KLASS OF VARS: IF VKIND = ACTUAL THEN BEGIN ACCESS := DRCT; VLEVEL := VLEV; DPLMT := VADDR END ELSE BEGIN P:= VADDR; IF TYPTR <> NIL THEN IF TYPTR^.FORM = STRINGPARM THEN LOD(LEVEL - VLEV,P,4) ELSE BEGIN IF TYPTR^.FORM = BOUNDLESS THEN P := P + 2 * (TYPTR^.UNSPECLEVEL - 1); %HYP.ADDR. OF BOUNDLESS ARRAYS ON LOCATION P\ TYPTR := INTPTR; %ADDRESS MUST BE LOADED INSTEAD OF CHARACTERVALUE\ LOD(LEVEL - VLEV, P, 2); TYPTR := IDTYPE; END; ACCESS := INDRCT; IDPLMT := 0 END; FIELD: WITH DISPLAY[DISX] DO IF OCCUR = CREC THEN BEGIN ACCESS := DRCT; VLEVEL := CLEV; DPLMT := CDSPL + FLDADDR END ELSE BEGIN TYPTR := INTPTR; % <> CHARPTR FOR LOD AND LDO \ IF LEVEL = 1 THEN LDO(VDSPL,2) ELSE LOD(0,VDSPL,2); TYPTR := IDTYPE; ACCESS := INDRCT; IDPLMT := FLDADDR END; FUNC: IF PFDECKIND = STANDARD THEN ERROR(150) ELSE IF PFLEV = 0 THEN ERROR(150) %EXTERNAL FCT\ ELSE IF PFKIND = FORMAL THEN ERROR(151) ELSE BEGIN ACCESS := DRCT; VLEVEL := PFLEV + 1; DPLMT := PARLISTSIZE; %ADDRESS OF FUNCTIONRESULT\ IF IDTYPE^.FORM=ARRAYS THEN DPLMT := DPLMT - IDTYPE^.ADDRCORR END END %CASE\ END %WITH\; IF NOT (SY IN SELECTSYS OR FSYS) THEN BEGIN ERROR(59); SKIP(SELECTSYS OR FSYS) END; WHILE SY IN SELECTSYS DO BEGIN %[\ IF SY = LBRACK THEN BEGIN REPEAT WITH GATTR DO IF TYPTR <> NIL THEN IF NOT (TYPTR^.FORM IN [ARRAYS,STRINGPARM,BOUNDLESS]) THEN BEGIN ERROR(138); GATTR.TYPTR := NIL END; LATTR := GATTR; LOADADDRESS; INSYMBOL; EXPRESSION(FSYS OR [COMMA,COLON,RBRACK]); LOAD; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> SCALAR THEN ERROR(113); IF LATTR.TYPTR <> NIL THEN WITH LATTR.TYPTR^ DO BEGIN SUBSTRSIZE := -1; WITH GATTR DO BEGIN KIND := VARBL;ACCESS:= INDRCT; IDPLMT :=0 END; IF SY = COLON THEN BEGIN IF FORM = BOUNDLESS THEN ERROR(615) ELSE IF FORM = ARRAYS THEN BEGIN IF AELTYPE <> CHARPTR THEN ERROR(615); LSP1 := INXTYPE; IF LSP1 <> NIL THEN GETBOUNDS(INXTYPE,LMIN,LMAX); END ELSE BEGIN LSP1 := INTPTR; %INDEXTYPE OF STRINGPARAMETER\ LMIN := 0; END; IF NOT COMPTYPES(LSP1,GATTR.TYPTR) THEN ERROR(613); LSP1 := GATTR.TYPTR; INSYMBOL; EXPRESSION(FSYS OR [RBRACK]); LOAD; IF NOT COMPTYPES(LSP1,GATTR.TYPTR) THEN ERROR(614); IF RUNTMCHECK THEN BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(LMIN); IF FORM = ARRAYS THEN BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(LMAX); END ELSE BEGIN GEN2(MOV,INDEX,SP,AUTDEC,SP); GENCONST(6); END; GENSUBRCALL(SUBSTRCHECK); END; GEN2(MOV,AUTINC,SP,REG,R); GEN2(SUB,REGDEF,SP,REG,R); GEN1(INC,REG,R); GEN2(ADD,AUTINC,SP,REGDEF,SP); GEN2(MOV,REG,R,AUTDEC,SP); GATTR.KIND := EXPR; IF LATTR.TYPTR^.FORM = STRINGPARM THEN GATTR.TYPTR := LATTR.TYPTR ELSE NEW(GATTR.TYPTR,STRINGPARM); END ELSE IF FORM = BOUNDLESS THEN BEGIN IF NOT COMPTYPES(INDEXTYPE,GATTR.TYPTR) THEN ERROR(139); IF UNSPECLEVEL > 1 THEN %LOAD THE REQUIRED SIZE COMPONENT OF THE BOUNDLESS ARRAY-\ %PARAMETER FROM ITS PLACE IN THE PARAMETERLIST\ BEGIN IF FCP <> NIL THEN BEGIN IF (LEVEL - FCP^.VLEV) = 0 THEN P := MP ELSE BEGIN P := AD; GEN2(MOV,REGDEF,MP,REG,AD); FOR P := 2 TO LEVEL - FCP^.VLEV DO GEN2(MOV,REGDEF,AD,REG,AD); END; GEN2(MOV,INDEX,P,AUTDEC,SP); GENCONST(FCP^.VADDR + 2 * (UNSPECLEVEL - 2)) END; MULTIPLY; GEN2(ADD,AUTINC,SP,REGDEF,SP); END ELSE IF SUBSTRUCT <> NIL THEN SUBSTRSIZE := SUBSTRUCT^.SIZE; %IF UNSPECLEVEL = 1 THEN SIZE = SIZE OF SUBSTRUCTURE\ GATTR.TYPTR := SUBSTRUCT END ELSE %FORM = ARRAYS\ IF FORM = ARRAYS THEN BEGIN IF INXTYPE <> NIL THEN GETBOUNDS(INXTYPE,LMIN,LMAX); IF RUNTMCHECK THEN BEGIN GENSUBRCALL(SUBRCHK); GENCONST(LMIN); GENCONST(LMAX); END; IF PACKOPT THEN BEGIN GATTR.ACCESS := PACKD; IF INXTYPE <> NIL THEN BEGIN IF LMIN <> 0 THEN BEGIN GEN2(SUB, AUTINC,PC,REGDEF,SP); GENCONST(LMIN) END END ELSE ERROR(606) END ELSE IF AELTYPE <> NIL THEN SUBSTRSIZE := AELTYPE^.SIZE; IF NOT COMPTYPES(INXTYPE,GATTR.TYPTR) THEN ERROR(139); GATTR.TYPTR := AELTYPE END ELSE %FORM = STRINGPARM\ BEGIN IF RUNTMCHECK THEN GENSUBRCALL(STRINGINDEX); SUBSTRSIZE := 1; IF NOT COMPTYPES(GATTR.TYPTR,INTPTR) THEN ERROR(139); GATTR.TYPTR := CHARPTR; GEN2(MOV,AUTINC,SP,REGDEF,SP); END; IF SUBSTRSIZE <> -1 THEN BEGIN IF GATTR.TYPTR <> NIL THEN BEGIN IF (SUBSTRSIZE <> 6) AND (SUBSTRSIZE <= 8) THEN BEGIN IF NOT COMPTYPES ( GATTR.TYPTR , CHARPTR ) THEN WHILE SUBSTRSIZE > 1 DO BEGIN SUBSTRSIZE := SUBSTRSIZE DIV 2; GEN1(ASL,REGDEF,SP) END; END ELSE BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(SUBSTRSIZE); MULTIPLY; END; GEN2(ADD,AUTINC,SP,REGDEF,SP); END END END UNTIL SY <> COMMA; IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12) END %IF SY = LBRACK\ ELSE %.\ IF SY = PERIOD THEN BEGIN WITH GATTR DO BEGIN IF TYPTR <> NIL THEN IF TYPTR^.FORM <> RECORDS THEN BEGIN ERROR(140); TYPTR := NIL END; INSYMBOL; IF SY = IDENT THEN BEGIN IF TYPTR <> NIL THEN BEGIN SRCHSECTION(TYPTR^.FSTFLD,LCP); IF LCP = NIL THEN BEGIN ERROR(152); TYPTR := NIL END ELSE WITH LCP^ DO BEGIN TYPTR := IDTYPE; CASE ACCESS OF DRCT: DPLMT := DPLMT + FLDADDR; INDRCT: IDPLMT := IDPLMT + FLDADDR; PACKD: ERROR(400) END END END; INSYMBOL END %SY = IDENT\ ELSE ERROR(2) END %WITH GATTR\ END %IF SY = PERIOD\ ELSE %^\ BEGIN IF GATTR.TYPTR <> NIL THEN WITH GATTR,TYPTR^ DO IF FORM IN [POINTER,FILES] THEN BEGIN LOAD; IF FORM = POINTER THEN TYPTR := ELTYPE ELSE TYPTR := FILTYPE ; IF TYPTR^.FORM = ARRAYS THEN IF TYPTR^.ADDRCORR <> 0 THEN BEGIN GEN2(SUB,AUTINC,PC,REGDEF,SP); GENCONST(ELTYPE^.ADDRCORR) END; KIND := VARBL; ACCESS := INDRCT; IDPLMT := 0 END ELSE ERROR(141); INSYMBOL END; IF NOT (SY IN FSYS OR SELECTSYS) THEN BEGIN ERROR(6); SKIP(FSYS OR SELECTSYS) END END; % WHILE\ IF GATTR.TYPTR^.FORM = BOUNDLESS THEN IF GATTR.TYPTR^.UNSPECLEVEL > 1 THEN LOD(LEVEL - FCP^.VLEV, FCP^.VADDR, 2 * (GATTR.TYPTR^.UNSPECLEVEL - 1)) END %SELECTOR\ ; FUNCTION LARGESET(FATTR: ATTR): BOOLEAN (*$Y+*); %CHECKS IF CONVERSIONS ARE NECESSARY\ VAR L1,L2: INTEGER; %AND CALLS THE CONVERSION ROUTINES\ RTR: RUNTIMEROUTS; LSP: STP; BEGIN IF NOT COMPTYPES(GATTR.TYPTR,FATTR.TYPTR) THEN BEGIN ERROR(606); GATTR.TYPTR := NIL END ELSE BEGIN L1 := FATTR.TYPTR^.SIZE; L2 := GATTR.TYPTR^.SIZE; IF L1 = L2 THEN BEGIN IF (FATTR.KIND = VARBL) AND (GATTR.KIND = VARBL) AND (FATTR.TYPTR^.ELTYPE <> GATTR.TYPTR^.ELTYPE) THEN BEGIN ERROR(605); GATTR.TYPTR := NIL END END ELSE BEGIN IF L1 > L2 THEN IF GATTR.KIND = VARBL THEN BEGIN L1 := 2; RTR := REDSN END ELSE RTR := EXPST ELSE IF FATTR.KIND = VARBL THEN RTR := REDST ELSE BEGIN L1 := 8; RTR := EXPSN END; GENSUBRCALL(RTR); END; IF L1 <> GATTR.TYPTR^.SIZE THEN BEGIN NEW(LSP); LSP^ := GATTR.TYPTR^; LSP^.SIZE := L1; GATTR.TYPTR := LSP; END; LARGESET := L1 = 8; END END; %LARGESET\ (*$Y+*) (* NEW MODULE *) PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP); VAR LKEY: 1..25; FILECP: CTP; PROCEDURE VARIABLE(FSYS: SETOFSYS); VAR LCP: CTP; BEGIN IF SY = IDENT THEN BEGIN SEARCHID([VARS,FIELD],LCP); INSYMBOL END ELSE BEGIN ERROR(2); LCP := UVARPTR END; SELECTOR(FSYS,LCP) END %VARIABLE\ ; (*$Y+*) (* NEW MODULE *) PROCEDURE GETFILEID; VAR LDISPL: INTEGER; BEGIN FILECP := NIL; IF SY = IDENT THEN BEGIN PRTERR := FALSE; SEARCHID( [VARS], FILECP ); PRTERR := TRUE; IF FILECP^.IDTYPE = NIL THEN FILECP := NIL ELSE IF FILECP^.IDTYPE^.FORM <> FILES THEN FILECP := NIL; END; IF FILECP <> NIL THEN BEGIN INSYMBOL; IF SY = COMMA THEN INSYMBOL; IF (LKEY IN [1,5,7,8,11,12,13]) AND (FILECP = TTYOUTPTR) THEN FILECP := TTYINPTR; END ELSE BEGIN IF ( LKEY IN [7,8,11,12,13]) AND ( INPUTPTR <> NIL ) THEN FILECP := INPUTPTR ELSE IF ( LKEY IN [2,9,10]) AND ( OUTPUTPTR <> NIL ) THEN FILECP := OUTPUTPTR ELSE IF ( LKEY IN [4,9,10]) AND ( TTYOUTPTR <> NIL ) THEN FILECP := TTYOUTPTR ELSE IF ( LKEY IN [7,8,11,12,13] ) AND (TTYINPTR <> NIL ) THEN FILECP := TTYINPTR ELSE ERROR(180) ; END; CASE LKEY OF 11: LDISPL := EOFSTATUS; 12: LDISPL := EOLNSTATUS; 13: LDISPL := IORESULT END; IF FILECP <> NIL THEN WITH FILECP^ DO IF VKIND = FORMAL THEN BEGIN GATTR.TYPTR := INTPTR (* <> CHARPTR FOR LOD *); LOD( LEVEL-VLEV, VADDR, 2 ); IF LKEY IN [7,8,11,12,13] THEN GENSUBRCALL( TTPAR ); IF LKEY >= 11 THEN BEGIN GEN2( MOV,AUTINC,SP,REG,AD ); GEN2( MOV,INDEX,AD,AUTDEC,SP ); GENCONST( LDISPL ) END END ELSE IF LKEY >= 11 THEN BEGIN GEN2( MOV,INDEX,GP,AUTDEC,SP ); GENCONST( VADDR + LDISPL ) END ELSE BEGIN GEN2( MOV, REG, GP, AUTDEC, SP ); GEN2( ADD, AUTINC, PC, REGDEF, SP ); GENCONST( VADDR ) END END % GETFILEID \ ; (*$Y+*) (* NEW MODULE *) PROCEDURE GETPUTRESETREWRITE; VAR SUBRNAME: RUNTIMEROUTS; I,J,SMIN,SMAX: INTEGER; BEGIN GETFILEID; IF LKEY > 4 % RESET, REWRITE \ THEN BEGIN %RESET, REWRITE \ IF FILECP^.IDTYPE <> NIL THEN WITH FILECP^.IDTYPE^ DO IF FORM = FILES THEN BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); IF COMPTYPES ( FILTYPE, CHARPTR ) THEN GENCONST(-1) ELSE GENCONST(FILTYPE^.SIZE); END; FOR I := 1 TO 3 DO BEGIN IF NOT ( SY IN [COMMA,RPARENT] ) THEN BEGIN EXPRESSION(FSYS OR [COMMA,RPARENT]); IF GATTR.TYPTR <> NIL THEN IF STRING(GATTR.TYPTR) THEN BEGIN GETBOUNDS(GATTR.TYPTR^.INXTYPE,SMIN,SMAX); IF GATTR.KIND = VARBL THEN IF GATTR.ACCESS = DRCT THEN GATTR.DPLMT := GATTR.DPLMT + SMIN ELSE GATTR.IDPLMT := GATTR.IDPLMT + SMIN; LOADADDRESS ; GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(SMAX-SMIN+1) END ELSE ERROR(116); END ELSE IF (I = 1) AND (FILECP <> NIL) THEN WITH FILECP^ DO BEGIN GENBR(BR,(ALFALENG+1)DIV 2); J := 1 ; WHILE J < ALFALENG DO BEGIN GENCONST(ORD(NAME[J])+256* ORD(NAME[J+1])); J := J+2 ; END; IF ODD(ALFALENG) THEN GENCONST(ORD(NAME[J])); GEN2(MOV,REG,PC,AUTDEC,SP); GEN2(SUB,AUTINC,PC,REGDEF,SP); GENCONST( 2 * ( ALFALENG DIV 2 ) + 2 ); GEN2(MOV,AUTINC,PC,AUTDEC,SP) ; GENCONST(ALFALENG) END ELSE BEGIN GEN1(CLR,AUTDEC,SP); GEN1(CLR,AUTDEC,SP) END ; IF SY = COMMA THEN INSYMBOL; END % FOR \ ; IF SY = RPARENT THEN GEN1(CLR,AUTDEC,SP) ELSE BEGIN EXPRESSION(FSYS OR [COMMA,RPARENT]); IF GATTR.TYPTR = NIL THEN ERROR(116) ELSE WITH GATTR.TYPTR^ DO IF (FORM = POWER) AND (SIZE = 2) THEN LOAD ELSE ERROR(116); END; END % LKEY > 4 \ ELSE IF SY <> RPARENT THEN BEGIN EXPRESSION(FSYS OR [RPARENT]); IF COMPTYPES(INTPTR,GATTR.TYPTR) THEN LOAD ELSE ERROR(116); LKEY := LKEY + 1; END; CASE LKEY OF 1: SUBRNAME := GETCH; 2: SUBRNAME := GETR; 3: SUBRNAME := PUTCH; 4: SUBRNAME := PUTR; 5: SUBRNAME := RESETF; 6: SUBRNAME := REWRITEF END; GENSUBRCALL(SUBRNAME) END %GETPUTRESETREWRITE\ ; PROCEDURE READREADLN (*$Y+*) ; VAR SMIN,SMAX: INTEGER; BEGIN GETFILEID; IF ((LKEY = 7) OR ((LKEY = 8) AND (SY <>RPARENT) AND (SY IN (FACBEGSYS - [LBRACK]) OR [ADDOP]))) AND (FILECP <> NIL) THEN LOOP VARIABLE(FSYS OR [COMMA,RPARENT]); LOADADDRESS; IF GATTR.TYPTR <> NIL THEN IF COMPTYPES( FILECP^.IDTYPE^.FILTYPE, GATTR.TYPTR) AND NOT COMPTYPES( GATTR.TYPTR,CHARPTR) THEN GENSUBRCALL( RDREC ) ELSE IF STRING ( GATTR.TYPTR ) THEN WITH GATTR.TYPTR^ DO BEGIN IF ADDRCORR <> 0 THEN BEGIN GEN2(ADD,AUTINC,PC,REGDEF,SP); GENCONST(ADDRCORR); END; GETBOUNDS(INXTYPE,SMIN,SMAX); GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(SMAX-SMIN+1); GENSUBRCALL(RDSTR); END ELSE IF GATTR.TYPTR^.FORM <= SUBRANGE THEN IF COMPTYPES(INTPTR,GATTR.TYPTR) THEN GENSUBRCALL(RDI) ELSE IF COMPTYPES(REALPTR,GATTR.TYPTR) THEN GENSUBRCALL(RDR) ELSE IF COMPTYPES(CHARPTR,GATTR.TYPTR) THEN GENSUBRCALL(RDC) ELSE ERROR(399) ELSE ERROR(116); EXIT IF SY <> COMMA; INSYMBOL END; IF FILECP <> NIL THEN IF (LKEY = 8) AND COMPTYPES(FILECP^.IDTYPE^.FILTYPE,CHARPTR) THEN GENSUBRCALL(GETLINE) ELSE GEN1(TST,AUTINC,SP) % REMOVE FILE ID \ ; END %READ\ ; PROCEDURE WRITEWRITELN (*$Y+*) ; VAR LSP: STP; DEFAULT, STACKD: BOOLEAN; SMIN,SMAX: INTEGER; BEGIN GETFILEID; IF ((LKEY = 9) OR ((LKEY = 10) AND ((SY <> RPARENT) AND (SY IN (FACBEGSYS - [LBRACK]) OR [ADDOP])))) AND (FILECP <> NIL) THEN LOOP EXPRESSION(FSYS OR [COMMA,COLON,RPARENT]); LSP := GATTR.TYPTR; STACKD := FALSE; IF LSP <> NIL THEN IF (LSP^.FORM <= POWER) AND COMPTYPES ( FILECP^.IDTYPE^.FILTYPE, CHARPTR ) THEN LOAD ELSE IF LSP^.FORM <> STRINGPARM THEN IF GATTR.KIND = EXPR THEN %MULTIPLE FUNCTIONRESULT ON STACK IS ACTUAL PARAMETER\ BEGIN GEN2(MOV,INDEX,SP,AUTDEC,SP); GENCONST(GATTR.TYPTR^.SIZE); GEN1(TST,AUTDEC,SP); GEN2(MOV,REG,SP,REGDEF,SP); STACKD := TRUE; GEN2(ADD,AUTINC,PC,REGDEF,SP); GENCONST(4); END ELSE BEGIN LOADADDRESS; IF LSP^.FORM = ARRAYS THEN IF LSP^.ADDRCORR <> 0 THEN BEGIN GEN2(ADD,AUTINC,PC,REGDEF,SP); GENCONST(LSP^.ADDRCORR) END END; IF NOT COMPTYPES(CHARPTR,GATTR.TYPTR) AND COMPTYPES(FILECP^.IDTYPE^.FILTYPE,GATTR.TYPTR) THEN GENSUBRCALL ( WRREC ) ELSE BEGIN IF SY = COLON THEN BEGIN INSYMBOL; EXPRESSION(FSYS OR [COMMA,COLON,RPARENT]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(116); LOAD; DEFAULT := FALSE END ELSE DEFAULT := TRUE; IF SY = COLON THEN BEGIN INSYMBOL; IF (SY = IDENT) AND (ID = 'O ') THEN BEGIN INSYMBOL; IF LSP <> INTPTR THEN ERROR(206) ELSE GENSUBRCALL(WRIOCT) END ELSE BEGIN EXPRESSION(FSYS OR [COMMA,RPARENT]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(116); IF LSP <> REALPTR THEN ERROR(124); LOAD; GENSUBRCALL(WRFIX); END END ELSE IF LSP = INTPTR THEN BEGIN IF DEFAULT THEN BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP) ; GENCONST( 8 ) END ; GENSUBRCALL(WRI) END ELSE IF LSP = REALPTR THEN BEGIN IF DEFAULT THEN BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(15) END; GENSUBRCALL(WRR) END ELSE IF LSP = CHARPTR THEN BEGIN IF DEFAULT THEN GENSUBRCALL(WRC) ELSE GENSUBRCALL(WRCHA); END ELSE IF LSP = BOOLPTR THEN BEGIN IF DEFAULT THEN GENSUBRCALL(WRB) ELSE GENSUBRCALL(WRBFX); END ELSE IF LSP <> NIL THEN BEGIN IF LSP^.FORM = SCALAR THEN ERROR(399) ELSE IF STRING(LSP) THEN BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GETBOUNDS(LSP^.INXTYPE,SMIN,SMAX); GENCONST(SMAX - SMIN + 1); IF DEFAULT THEN GEN2(MOV,REGDEF,SP,AUTDEC,SP); GENSUBRCALL(WRS); END ELSE IF LSP^.FORM = STRINGPARM THEN BEGIN IF DEFAULT THEN GEN2(MOV,REGDEF,SP,AUTDEC,SP) ELSE BEGIN GEN2(MOV,AUTINC,SP,REG,R); GEN2(MOV,REGDEF,SP,AUTDEC,SP); GEN2(MOV,REG,R,INDEX,SP); GENCONST(2); END; GENSUBRCALL(WRS) END ELSE ERROR(116); END; END; IF STACKD THEN BEGIN GEN2(ADD,AUTINC,PC,REG,SP); GENCONST(LSP^.SIZE+2); END; EXIT IF SY <> COMMA; INSYMBOL END; IF FILECP <> NIL THEN IF (LKEY = 10) AND COMPTYPES(FILECP^.IDTYPE^.FILTYPE,CHARPTR) THEN GENSUBRCALL(PUTLINE) ELSE GEN1(TST,AUTINC,SP) % REMOVE FILE ID \ ; END %WRITE\ ; PROCEDURE PACK (*$Y+*) ; VAR LSP,LSP1: STP; BEGIN ERROR(399); (*$Z+*) VARIABLE(FSYS OR [COMMA,RPARENT]); LSP := NIL; LSP1 := NIL; IF GATTR.TYPTR <> NIL THEN WITH GATTR.TYPTR^ DO IF FORM = ARRAYS THEN BEGIN LSP := INXTYPE; LSP1 := AELTYPE END ELSE ERROR(116); IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); EXPRESSION(FSYS OR [COMMA,RPARENT]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> SCALAR THEN ERROR(116) ELSE IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN ERROR(116); IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); VARIABLE(FSYS OR [RPARENT]); IF GATTR.TYPTR <> NIL THEN WITH GATTR.TYPTR^ DO IF FORM = ARRAYS THEN BEGIN IF NOT COMPTYPES(AELTYPE,LSP1) OR NOT COMPTYPES(INXTYPE,LSP) THEN ERROR(116) END ELSE ERROR(116) (*$Z-*) END %PACK\ ; PROCEDURE UNPACK (*$Y+*) ; VAR LSP,LSP1: STP; BEGIN ERROR(399); (*$Z+*) VARIABLE(FSYS OR [COMMA,RPARENT]); LSP := NIL; LSP1 := NIL; IF GATTR.TYPTR <> NIL THEN WITH GATTR.TYPTR^ DO IF FORM = ARRAYS THEN BEGIN LSP := INXTYPE; LSP1 := AELTYPE END ELSE ERROR(116); IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); VARIABLE(FSYS OR [COMMA,RPARENT]); IF GATTR.TYPTR <> NIL THEN WITH GATTR.TYPTR^ DO IF FORM = ARRAYS THEN BEGIN IF NOT COMPTYPES(AELTYPE,LSP1) OR NOT COMPTYPES(INXTYPE,LSP) THEN ERROR(116) END ELSE ERROR(116); IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); EXPRESSION(FSYS OR [RPARENT]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> SCALAR THEN ERROR(116) ELSE IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN ERROR(116); (*$Z-*) END %UNPACK\ ; PROCEDURE NEW1 (*$Y+*) ; LABEL 1; VAR LSP,LSP1: STP; LMIN,LMAX,I: INTEGER; LSIZE,LSZ: ADDRRANGE; LVAL: VALU; B: BOOLEAN; BEGIN VARIABLE(FSYS OR [COMMA,RPARENT,COLON]); LOADADDRESS; LSP := NIL;LSIZE := 0; IF GATTR.TYPTR <> NIL THEN WITH GATTR.TYPTR^ DO IF FORM = POINTER THEN BEGIN IF ELTYPE <> NIL THEN BEGIN LSIZE := ELTYPE^.SIZE; IF ELTYPE^.FORM = RECORDS THEN BEGIN LSP := ELTYPE^.RECVAR; B := ELTYPE^.PACKSTRUCT END ELSE IF ELTYPE^.FORM = ARRAYS THEN BEGIN LSP := ELTYPE; B := LSP^.PACKOPT END; IF B THEN BEGIN GENSUBRCALL(CLRAREA); GENCONST(ELTYPE^.SIZE DIV 2) END END END ELSE ERROR(116); GEN2(MOV,INDEX,GP,REG,AD); GENCONST(DAPADDR); IF DEBUG THEN BEGIN GEN2(MOV,INDEX,GP,AUTINC,AD); GENCONST(DAPDDT); GEN2(MOV,AUTINC,PC,AUTINC,AD); GENCONST(0); PUTRLD('$DDTDF ',ABSADDR,2*CODE.LEN-2,2*GATTR.TYPTR^.ELTYPE^.SELFSTP); GEN2(MOV,INDEX,GP,INDEX,GP); GENCONST(DAPADDR); GENCONST(DAPDDT); GEN2(MOV,REG,AD,INDEX,GP); GENCONST(DAPADDR); END; WHILE SY = COMMA DO BEGIN INSYMBOL; CONSTANT(FSYS OR [COMMA,COLON,RPARENT],LSP1,LVAL); %CHECK TO INSERT HERE: IS CONSTANT IN TAGFIELDTYPE RANGE\ IF LSP = NIL THEN ERROR(158) ELSE IF STRING(LSP1) OR (LSP1 = REALPTR) THEN ERROR(159) ELSE BEGIN IF LSP^.FORM = TAGFWITHID THEN BEGIN IF LSP^.TAGFIELDP <> NIL THEN IF COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP1) THEN BEGIN GEN2(MOV,AUTINC,PC,INDEX,AD); GENCONST(LVAL.IVAL); GENCONST(LSP^.TAGFIELDP^.FLDADDR); END ELSE BEGIN ERROR(116); GOTO 1 END END ELSE IF LSP^.FORM = TAGFWITHOUTID THEN BEGIN IF NOT COMPTYPES(LSP^.TAGFIELDTYPE,LSP1) THEN BEGIN ERROR(116); GOTO 1 END END ELSE BEGIN ERROR(170); GOTO 1 END; LSP1 := LSP^.FSTVAR; WHILE LSP1 <> NIL DO WITH LSP1^ DO IF VARVAL.IVAL = LVAL.IVAL THEN BEGIN LSIZE := SIZE; LSP := SUBVAR; GOTO 1 END ELSE LSP1 := NXTVAR; LSIZE := LSP^.SIZE; LSP := NIL; END; 1: END %WHILE\ ; GEN2(MOV,REG,AD,AUTINCDEF,SP); IF SY = COLON THEN BEGIN INSYMBOL; EXPRESSION(FSYS OR [RPARENT]); IF LSP = NIL THEN ERROR(163) ELSE IF LSP^.FORM <> ARRAYS THEN ERROR(164) ELSE BEGIN IF NOT COMPTYPES(GATTR.TYPTR,LSP^.INXTYPE) THEN ERROR(116); LSZ := 2; LMIN := 1; IF LSP^.INXTYPE <> NIL THEN GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX); IF LSP^.AELTYPE <> NIL THEN IF LSP^.AELTYPE = CHARPTR THEN LSZ := 1 ELSE LSZ := LSP^.AELTYPE^.SIZE; LOAD; IF LSP^.PACKOPT THEN BEGIN GEN2(SUB,AUTINC,PC,REGDEF,SP); GENCONST(LMIN - 1); LSZ := 1; FOR I := 1 TO 3 DO GEN1(ASR,REGDEF,SP) % ... DIV 8 \ ; GEN1(INC,REGDEF,SP); LMIN := 1 %ALWAYS ADDS ONE BYTE\ END; GEN2(MOV,AUTINC,SP,REG,R); IF LSZ <> 1 THEN IF LSZ = 2 THEN GEN1(ASL,REG,R) ELSE IF EXTSET THEN BEGIN GEN2(MULT,REG,R,AUTINC,PC); GENCONST(LSZ) END ELSE BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(LSZ); GENSUBRCALL(MPI); GEN2(MOV,AUTINC,SP,REG,R) END; LSZ := LSIZE - LSP^.SIZE - LSZ * (LMIN - 1); IF LSZ > 0 THEN BEGIN GEN2(ADD,AUTINC,PC,REG,R); GENCONST(LSZ); END; IF (LSP^.AELTYPE = CHARPTR) OR LSP^.PACKOPT THEN BEGIN GEN2(MOV,REG,R,REG,AR); GEN2(BIC,AUTINC,PC,REG,AR); GENCONST(-2); GENBR(BEQ,1); GEN1(INC,REG,R); %TEST FOR ODD STRINGLENGTH; IN THIS CASE AN EXTRA\ %BYTE MUST BE ADDED TO MAINTAIN WORD BOUNDARY\ END; GEN2(ADD,REG,R,INDEX,GP); GENCONST(DAPADDR) END END ELSE BEGIN GEN2(ADD,AUTINC,PC,INDEX,GP); GENCONST(LSIZE); GENCONST(DAPADDR) END; IF HEAPCHECK THEN GENSUBRCALL(OVFLCHK); END %NEW\ ; PROCEDURE ABS (*$Y+*) ; BEGIN IF GATTR.TYPTR = INTPTR THEN BEGIN GEN1(TST,REGDEF,SP); GENBR(BPL,1); GEN1(NEG,REGDEF,SP) END ELSE IF GATTR.TYPTR = REALPTR THEN BEGIN GEN2(BIC,AUTINC,PC,REGDEF,SP); GENCONST(100000B) END ELSE BEGIN ERROR(125); GATTR.TYPTR := INTPTR END END %ABS\ ; PROCEDURE SQR (*$Y+*) ; BEGIN IF GATTR.TYPTR = INTPTR THEN BEGIN IF EXTSET THEN BEGIN GEN2(MOV,REGDEF,SP,REG,R); GEN2(MULT,REG,R,AUTINC,SP); GEN2(MOV,REG,R,AUTDEC,SP) END ELSE GENSUBRCALL(SQI) END ELSE IF GATTR.TYPTR = REALPTR THEN GENSUBRCALL(SQRR) ELSE BEGIN ERROR(125); GATTR.TYPTR := INTPTR END END %SQR\ ; PROCEDURE TRUNC (*$Y+*) ; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> REALPTR THEN ERROR(125); GENSUBRCALL(TRC); GATTR.TYPTR := INTPTR END %TRUNC\ ; PROCEDURE ARITHMETICFUNCTIONS (*$Y+*) ; VAR RTR: RUNTIMEROUTS; BEGIN IF GATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLT); GATTR.TYPTR := REALPTR END; IF GATTR.TYPTR <> REALPTR THEN ERROR(125) ELSE BEGIN CASE LKEY OF 16: RTR := RSIN; 17: RTR := RCOS; 18: RTR := RARCTAN; 19: RTR := REXP; 20: RTR := RLOG; 21: RTR := RSQRT END; GENSUBRCALL(RTR); END; END; %ARITHMETICFUNCTIONS\ PROCEDURE ROUND (*$Y+*) ; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> REALPTR THEN ERROR(125); GENSUBRCALL(RND); GATTR.TYPTR := INTPTR END; %ROUND\ PROCEDURE ODD (*$Y+*) ; BEGIN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); GEN2(BIC,AUTINC,PC,REGDEF,SP); GENCONST(-2); GATTR.TYPTR := BOOLPTR END %ODD\ ; PROCEDURE ORD (*$Y+*) ; BEGIN IF GATTR.TYPTR <> NIL THEN IF (GATTR.TYPTR^.FORM > POWER) OR (GATTR.TYPTR^.SIZE <> 2) THEN ERROR(125); GATTR.TYPTR := INTPTR END %ORD\ ; PROCEDURE CHR (*$Y+*) ; BEGIN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); GATTR.TYPTR := CHARPTR END %CHR\ ; PROCEDURE PREDSUCC (*$Y+*) ; BEGIN IF LKEY = 7 THEN GEN1(DEC,REGDEF,SP) ELSE GEN1(INC,REGDEF,SP); %NO BOUNDCHECKING IS DONE\ IF GATTR.TYPTR <> NIL THEN IF (GATTR.TYPTR^.FORM <> SCALAR) OR (GATTR.TYPTR = REALPTR) THEN ERROR(125); END %PREDSUCC\ ; PROCEDURE EOFEOLNIORES (*$Y+*) ; VAR LDISPL: INTEGER; BEGIN LKEY := LKEY + 2; GETFILEID; IF LKEY = 13 (* 11+2 *) THEN GATTR.TYPTR := INTPTR ELSE GATTR.TYPTR := BOOLPTR ; END %EOF\ ; PROCEDURE BREAKLN (*$Y+*) ; BEGIN GETFILEID; GENSUBRCALL( BRK ) END; PROCEDURE FORMFEED (*$Y+*) ; BEGIN GETFILEID; GENSUBRCALL( FORMFD ) END; PROCEDURE DATETIME (*$Y+*) ; BEGIN VARIABLE( FSYS OR [RPARENT]); LOADADDRESS; IF GATTR.TYPTR <> NIL THEN IF LKEY = 18 THEN GENSUBRCALL( TIME1 ) ELSE GENSUBRCALL( DATE1 ); END; PROCEDURE HALT (*$Y+*) ; BEGIN IF DEBUG THEN GENCONST(4 %IOT\) ELSE GENSUBRCALL( DUMP ) END ; PROCEDURE RUNTIME1 (*$Y+*) ; BEGIN GENSUBRCALL( RUNTM ); GATTR.TYPTR := INTPTR END; PROCEDURE MARKRELEASE (*$Y+*) ; BEGIN ERROR(903); SKIP(FSYS OR [RPARENT]); IF LKEY = 12 THEN GENSUBRCALL(MARKP) ELSE GENSUBRCALL(RELEASEP) END; PROCEDURE SPLITREAL (*$Y+*) ; BEGIN IF GATTR.TYPTR <> REALPTR THEN ERROR(125); IF SY =COMMA THEN INSYMBOL ELSE ERROR(20); VARIABLE(FSYS OR [RPARENT]); LOADADDRESS; IF GATTR.TYPTR <> INTPTR THEN ERROR(125); GENSUBRCALL(SPLTRL); GATTR.TYPTR := REALPTR; END; %SPLITREAL\ PROCEDURE SSIZE (*$Y+*) ; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> STRINGPARM THEN ERROR(626) ELSE GEN2(MOV,AUTINC,SP,REGDEF,SP); GATTR.TYPTR := INTPTR; END; PROCEDURE TWOPOW (*$Y+*) ; BEGIN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); GENSUBRCALL(TWPOW); GATTR.TYPTR := REALPTR; END; %TWOPOW\ PROCEDURE CALLNS1 (*$Y+*) ; BEGIN IF SY IN [LBRACK,PERIOD] THEN %ELEMENTSELECTION FROM MULTIPLE\ BEGIN %FUNCTIONRESULT\ IF GATTR.TYPTR <> NIL THEN WITH GATTR.TYPTR^ DO BEGIN I := SIZE; GEN2(MOV,REG,SP,AUTDEC,SP); %MULTIPLE ADDRESS ON STACK\ IF FORM = ARRAYS THEN IF ADDRCORR <> 0 THEN BEGIN GEN2(SUB,AUTINC,PC,REGDEF,SP); GENCONST(ADDRCORR) END END; WITH GATTR DO BEGIN KIND := VARBL ; ACCESS := INDRCT; IDPLMT := 0 END; SELECTOR(FSYS, NIL); % \ %POSSIBILITIES AFTER SELECTOR: KIND = VARBL, ACCESS = INDRCT,OR ACCESS = PACKD. AN ADDRESS (POSSIBLY 2-TUPLE)HAS BEEN PRODUCED ON TOP OF THE STACK; THE CONTENTS OF THIS ADDRESS (POSSIBLY A MULTIPLE VALUE) MUST BE LOADED ONTO THE STACK AFTER THE FUNCTIONRESULT HAS BEEN REMOVED\ IF GATTR.TYPTR <> NIL THEN WITH GATTR DO IF KIND = EXPR THEN ERROR(609) ELSE IF ACCESS = INDRCT THEN %FIELD OF RECORD OR ARRAY-EL\ BEGIN GEN2(MOV,AUTINC,SP,REG,AR); GEN2(MOV,REG,SP,REG,AD); GEN2(ADD,AUTINC,PC,REG,AD); GENCONST(I); IF TYPTR^.SIZE = 2 THEN IF TYPTR = CHARPTR THEN BEGIN IF IDPLMT = 0 THEN GEN2(MOVB,REGDEF,AR,REG,AR) ELSE BEGIN GEN2(MOVB,INDEX,AR,REG,AR); GENCONST(IDPLMT) END; GEN1(CLR,AUTDEC,AD); GEN2(MOVB,REG,AR,REGDEF,AD); END ELSE IF IDPLMT = 0 THEN GEN2(MOV,REGDEF,AR,AUTDEC,AD) ELSE %MAY BE DONE MORE EFFICIENT\ BEGIN GEN2(MOV,INDEX,AR,AUTDEC,AD); GENCONST(IDPLMT) END ELSE BEGIN GEN2(ADD,AUTINC,PC,REG,AR); GENCONST(IDPLMT + TYPTR^.SIZE); GENSUBRCALL(MOVMR); GENCONST(TYPTR^.SIZE DIV 2) END; GEN2(MOV,REG,AD,REG,SP); END ELSE BEGIN %ACCESSS = PACKD\ IF TYPTR = BOOLPTR THEN BEGIN GENSUBRCALL(LPB); GEN2(MOV,REGDEF,SP,INDEX,SP); GENCONST(I); GEN2(ADD,AUTINC,PC,REG,SP); GENCONST(I) END ELSE ERROR(400); END; GATTR.KIND := EXPR END; END % CALLNS1 \ ; PROCEDURE CALLNONSTANDARD (*$Y+*) ; VAR NXT,LCP: CTP; LSP,LSP2: STP; LKIND: IDKIND; LSP1: STP; LCP1,LCP2: CTP; LMIN,LMAX,I,P: INTEGER; LATTR: ATTR; B: BOOLEAN; RELNAME: ALFA; PROCEDURE BASE(PLEVEL: LEVRANGE); VAR I,MODE,REGISTER: INTEGER; BEGIN REGISTER := MP; (* MNC - ADDED FOLLOWING TEST FOR WHETHER WE ARE CALLING GLOBAL (OUTERMOST LEVEL) PROCEDURE. IF SO WE CAN PASS ITS STATIC LINK WITH ONE INSTR, INSTEAD OF MANY, BECAUSE GP POINTS TO FRAME OF GLOBAL VARS: *) IF FCP^.PFLEV <= 1 THEN GEN2(MOV,REG,GP,AUTDEC,SP) ELSE BEGIN IF PLEVEL = 0 THEN MODE := REG ELSE MODE := REGDEF; IF PLEVEL > 1 THEN BEGIN GEN2(MOV,REGDEF,MP,REG,AD); FOR I := 3 TO PLEVEL DO GEN2(MOV,REGDEF,AD,REG,AD); REGISTER := AD END; GEN2(MOV,MODE,REGISTER,AUTDEC,SP) END; END; FUNCTION COMPSPECIFICATION(LCP1, LCP2: CTP): BOOLEAN; VAR ERR: BOOLEAN; BEGIN ERR := FALSE; WHILE (LCP1 <> NIL) AND (LCP2 <> NIL) AND NOT ERR DO BEGIN IF COMPTYPES(LCP1^.IDTYPE, LCP2^.IDTYPE) AND (LCP1^.KLASS = LCP2^.KLASS) THEN BEGIN IF LCP1^.KLASS = VARS THEN BEGIN IF LCP1^.VKIND <> LCP2^.VKIND THEN ERR := TRUE END ELSE ERR := NOT COMPSPECIFICATION(LCP1^.PARMLIST,LCP2^.PARMLIST); END ELSE ERR := TRUE; LCP1 := LCP1^.NEXT; LCP2 := LCP2^.NEXT; END; IF LCP1 <> LCP2 THEN ERR := TRUE; COMPSPECIFICATION := NOT ERR; END; %COMPSPECIFICATION\ BEGIN WITH FCP^ DO BEGIN LKIND := PFKIND; IF LKIND = ACTUAL THEN NXT := NEXT ELSE NXT := PARMLIST; %NXT POINTS TO PARAM.LIST\ IF KLASS = FUNC THEN %RESERVE PLACE FOR RESULT\ BEGIN IF IDTYPE^.SIZE = 2 THEN GEN1(CLR,AUTDEC,SP) ELSE IF IDTYPE^.SIZE = 4 THEN GEN2(CMP,AUTDEC,SP,AUTDEC,SP) ELSE BEGIN GEN2(SUB,AUTINC,PC,REG,SP); GENCONST(IDTYPE^.SIZE) END END END; IF SY = LPARENT THEN BEGIN REPEAT INSYMBOL; IF NXT = NIL THEN BEGIN ERROR(126); SKIP(FSYS OR [RPARENT]) END ELSE BEGIN IF NXT^.KLASS IN [PROC,FUNC] THEN %PROCEDURE PARAM'S\ BEGIN IF SY <> IDENT THEN BEGIN ERROR(2); SKIP(FSYS OR [COMMA,RPARENT]) END ELSE %PROCEDURE PARAM\ IF NXT^.KLASS = PROC THEN SEARCHID([PROC],LCP) ELSE %FUNCTION PARAM\ BEGIN SEARCHID([FUNC],LCP); IF NOT COMPTYPES(LCP^.IDTYPE, NXT^.IDTYPE) THEN ERROR(128) END; INSYMBOL; IF NOT (SY IN FSYS OR [COMMA,RPARENT]) THEN BEGIN ERROR(6); SKIP(FSYS OR [COMMA,RPARENT]) END; IF LCP <> NIL THEN WITH LCP^ DO BEGIN P := LEVEL - PFLEV; IF PFDECKIND = STANDARD THEN ERROR(603); LCP1 := NXT^.PARMLIST; IF PFKIND = ACTUAL THEN %ACTUAL PARAM IS AN\ BEGIN BASE(P); %ACTUAL P/F\ LCP2 := LCP^.NEXT; GEN2(MOV,REG,PC,AUTDEC,SP); GEN2(ADD,AUTINC,PC,REGDEF,SP); IF DECLPLACE > EXTRNL THEN ERROR(609); GENCONST( 0 %ADDRCHAIN\ ); IF EXTNAME = NIL THEN RELNAME := NAME ELSE RELNAME := EXTNAME^ ; PUTRLD( RELNAME, RELOCFCN, 2*CODE.LEN-2, 4); PUTGSD(RELNAME, GLOBALREFFLAGS, 0 ) ; END %NOW ABSOLUTE CODEADDRESS OF P/F LOADED\ ELSE BEGIN LCP2 := LCP^.PARMLIST; %ACTUAL PROCEDURE PARAM\ IF PFLEV <= 1 THEN LDO(PFADDR, 4) %IS FORMAL PROCEDURE\ ELSE LOD(P, PFADDR, 4) END; IF NOT COMPSPECIFICATION(LCP1,LCP2) THEN ERROR(612); END END ELSE BEGIN LSP := NXT^.IDTYPE; IF LSP <> NIL THEN BEGIN IF NXT^.VKIND = FORMAL THEN BEGIN IF LSP^.FORM = STRINGPARM THEN IF SY = IDENT THEN BEGIN PRTERR := FALSE; SEARCHID([FUNC],LCP1); PRTERR := TRUE; IF LCP1 <> NIL THEN ERROR(609); END; EXPRESSION(FSYS OR [COMMA,RPARENT]); IF LSP^.FORM = STRINGPARM THEN BEGIN IF GATTR.KIND <> EXPR THEN BEGIN LOADADDRESS; IF GATTR.TYPTR <> NIL THEN WITH GATTR.TYPTR^ DO IF FORM = ARRAYS THEN BEGIN IF INXTYPE <> NIL THEN GETBOUNDS(INXTYPE,LMIN,LMAX); GEN2(ADD,AUTINC,PC,REGDEF,SP); GENCONST(LMIN); %HYP.ADDR --> ACT ADDR\ GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(LMAX-LMIN+1); END END ELSE IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> STRINGPARM THEN ERROR(617) END ELSE IF GATTR.KIND = VARBL THEN IF (GATTR.ACCESS=PACKD) AND (GATTR.TYPTR=BOOLPTR) THEN ERROR(142) ELSE LOADADDRESS ELSE ERROR(154); LSP2 := GATTR.TYPTR; LSP1 := LSP; WHILE LSP1^.FORM = BOUNDLESS DO BEGIN IF LSP2 <> NIL THEN IF LSP2^.FORM = ARRAYS THEN BEGIN LSP2 := LSP2^.AELTYPE; IF LSP1^.UNSPECLEVEL > 1 THEN BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(LSP2^.SIZE); END END ELSE IF LSP2^.FORM = BOUNDLESS THEN BEGIN IF ((LSP2^.UNSPECLEVEL = 1) AND (LSP1^.UNSPECLEVEL > 1)) THEN BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(LSP2^.SUBSTRUCT^.SIZE); END; LSP2 := LSP2^.SUBSTRUCT; END; LSP1 := LSP1^.SUBSTRUCT; END; IF NOT COMPTYPES(LSP1,LSP2) THEN ERROR(142) END ELSE WITH LSP^ DO BEGIN IF (FORM = ARRAYS) OR (FORM = RECORDS) THEN BEGIN EXPRESSION(FSYS OR [COMMA,RPARENT]); IF GATTR.KIND <> EXPR THEN % GATTR.TYPTR = EXPR MEANS THAT THE ACTUAL PARAMETER WAS A FUNCTION, THE RESULT OF WHICH HAS BEEN LEFT BEHIND ON THE STACK\ BEGIN LOADADDRESS; GEN2(MOV,AUTINC,SP,REG,AR); IF FORM = ARRAYS THEN I := GATTR.TYPTR^.ADDRCORR ELSE I := 0; IF SIZE <= 10 THEN BEGIN GEN2(ADD,AUTINC,PC,REG,AR); GENCONST(SIZE + I); FOR I := 1 TO SIZE DIV 2 DO GEN2(MOV,AUTDEC,AR,AUTDEC,SP); END ELSE BEGIN GEN2(SUB,AUTINC,PC,REG,SP); GENCONST(SIZE); GEN2(MOV,REG,SP,REG,AD); %NOW ADDRESS OF DESTINATION IN AD\ IF I <> 0 THEN BEGIN GEN2(ADD,AUTINC,PC,REG,AR); GENCONST(ADDRCORR) END; GENSUBRCALL(MOVM2); GENCONST(SIZE DIV 2); END END; IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN ERROR(142) END %FORM=ARRAYS,ETC\ ELSE BEGIN EXPRESSION(FSYS OR [COMMA,RPARENT]) ;LOAD ; IF FORM = POWER THEN BEGIN LATTR.TYPTR := LSP; LATTR.KIND := VARBL ; B := LARGESET(LATTR) END ELSE IF COMPTYPES(REALPTR,LSP) AND (GATTR.TYPTR = INTPTR) THEN BEGIN GENSUBRCALL(FLT); GATTR.TYPTR := REALPTR END; IF RUNTMCHECK THEN IF (FORM <= SUBRANGE) AND (LSP <> REALPTR) AND (LSP <> INTPTR) THEN BEGIN GENSUBRCALL(SUBRCHK); GETBOUNDS(LSP,LMIN,LMAX); GENCONST(LMIN); GENCONST(LMAX); END; IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN ERROR(142) END END %WITH LSP..\ END %LSP <> NIL\ END % NXT^.KLASS\ END; %NXT = NIL\ IF NXT <> NIL THEN NXT := NXT^.NEXT; UNTIL SY <> COMMA; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END; %IF SY=LPARENT\ IF NXT <> NIL THEN ERROR(126); WITH FCP^ DO IF LKIND = ACTUAL THEN %CALL THE ACTUAL PROCEDURE\ BEGIN IF EXTNAME = NIL THEN RELNAME := NAME ELSE RELNAME := EXTNAME^ ; IF DECLPLACE < EXTERNFORTRAN THEN BEGIN BASE(LEVEL - PFLEV); %LOADS THE STATIC LINK\ GEN2(JSR,REG,PC,INDEX,PC); GENCONST( 0 ) ; PUTRLD ( RELNAME, RELOCFCN, 2*CODE.LEN-2, 0 ) ; PUTGSD ( RELNAME, GLOBALREFFLAGS, 0 ) ; END ELSE BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(PARLISTSIZE DIV 2); GENSUBRCALL( FORTR ); GENCONST( 0 ); PUTRLD ( RELNAME, RELOCFCN, 2*CODE.LEN-2, 0 ); PUTGSD ( RELNAME, GLOBALREFFLAGS, 0 ); IF KLASS = FUNC THEN BEGIN GEN2(MOV,REG,AR,REGDEF,SP); IF IDTYPE^.SIZE = 4 THEN BEGIN GEN2(MOV,REG,R,INDEX,SP); GENCONST( 2 ); END END END; END ELSE %CALL OF FORMAL PROCEDURE\ BEGIN LOD(LEVEL - PFLEV,PFADDR,4); %LOAD THE PROCEDURE PARAMETER\ GEN2(JSR,REG,PC,AUTINCDEF,SP) END; % WITH FCP\ GATTR.TYPTR := FCP^.IDTYPE; END %CALLNONSTANDARD\ ; PROCEDURE CALLSTANDARD( FCP: CTP ) (*$Y+*) ; BEGIN %CALLSTANDARD\ LKEY := FCP^.KEY; IF (FCP^.KLASS = PROC) AND (LKEY = 14) THEN HALT ELSE IF (FCP^.KLASS = FUNC) AND (LKEY = 13) THEN RUNTIME1 ELSE IF (FCP^.KLASS = PROC) AND ((LKEY IN [2,4,8,10,12,13]) AND (SY <> LPARENT)) THEN CASE LKEY OF 2: FORMFEED; 4: BREAKLN; 8: READREADLN; 10: WRITEWRITELN; 12: GENSUBRCALL(MARKP); 13: GENSUBRCALL(RELEASEP) END ELSE IF (FCP^.KLASS = FUNC) AND ((LKEY IN [9,10,11]) AND (SY <> LPARENT)) THEN EOFEOLNIORES ELSE BEGIN IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9); IF FCP^.KLASS = PROC THEN CASE LKEY OF 2: FORMFEED; 4: BREAKLN; 1,3, 5,6: GETPUTRESETREWRITE; 7,8: READREADLN; 9,10: WRITEWRITELN; 11 : NEW1; 12,13:MARKRELEASE; 15 : PACK; 16 : UNPACK; 17,18 : DATETIME END ELSE IF LKEY IN [9,10,11] THEN EOFEOLNIORES ELSE BEGIN EXPRESSION(FSYS OR [COMMA,RPARENT]); IF LKEY <> 22 THEN LOAD; CASE LKEY OF 1: ABS; 2: SQR; 3: TRUNC; 4: ODD; 5: ORD; 6: CHR; 7,8: PREDSUCC; 12: ROUND; 14: SPLITREAL; 15: TWOPOW; 16,17,18, 19,20,21: ARITHMETICFUNCTIONS; 22: SSIZE END END; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END END %CALLSTANDARD\ ; (*$Y+*) (* NEW MODULE *) BEGIN % CALL \ IF FCP^.PFDECKIND = STANDARD THEN CALLSTANDARD( FCP ) ELSE BEGIN CALLNONSTANDARD; IF SY IN [LBRACK,PERIOD] THEN CALLNS1 END END % CALL \ ; (*$Y+*) (* NEW MODULE *) PROCEDURE EXPRESSION; VAR LATTR: ATTR; LOP: OPERATOR; LSIZE: ADDRRANGE; B,C,STACKD: BOOLEAN; SUBRNAME: RUNTIMEROUTS; SMIN,SMAX: INTEGER; MULTSSIZE: INTEGER; PROCEDURE SMPLEEXPRESSION(FSYS: SETOFSYS); VAR LATTR: ATTR; LOP: OPERATOR; SIGNED: BOOLEAN; PROCEDURE TERM(FSYS: SETOFSYS); VAR LATTR: ATTR; LOP: OPERATOR; PROCEDURE LOADSTRINGCONSTANT; VAR I: INTEGER; BEGIN WITH GATTR DO IF TYPTR <> NIL THEN WITH CVAL.VALP^ DO BEGIN GENBR(BR,(SLGTH + 2) DIV 2); I := 0; WHILE I < SLGTH DO BEGIN GENCONST(ORD(SVAL[I]) + 256 * ORD(SVAL[I + 1])); I := I + 2 END; IF ODD(SLGTH+1) THEN GENCONST(ORD(SVAL[I])); GEN2(MOV,REG,PC,AUTDEC,SP); GEN2(SUB,AUTINC,PC,REGDEF,SP); GENCONST(TYPTR^.SIZE + 2) %HYP. STRINGADDRESS ON STACK\ END END; %LOADSTRINGCONSTANT\ PROCEDURE FACTOR(FSYS: SETOFSYS); VAR LCP: CTP; LVP: CSP; VARPART: BOOLEAN; CSTPART: SET OF 0..63; LSP,LSP1: STP; J,I,INTSET,K: INTEGER; FOURWORDSET: BOOLEAN; SCOUNT,LRMIN: INTEGER; RANGEPART: BOOLEAN; BEGIN IF NOT (SY IN FACBEGSYS) THEN BEGIN ERROR(58); SKIP(FSYS OR FACBEGSYS); GATTR.TYPTR := NIL END; WHILE SY IN FACBEGSYS DO BEGIN CASE SY OF %ID\ IDENT: BEGIN SEARCHID([KONST,VARS,FIELD,FUNC],LCP); INSYMBOL; IF LCP^.KLASS = FUNC THEN BEGIN CALL(FSYS,LCP); GATTR.KIND := EXPR END ELSE IF LCP^.KLASS = KONST THEN WITH GATTR, LCP^ DO BEGIN TYPTR := IDTYPE; KIND := CST; CVAL := VALUES; IF STRING(TYPTR) THEN BEGIN LOADSTRINGCONSTANT; IF SY = LBRACK THEN BEGIN SELECTOR(FSYS,NIL); LOAD END END ; END ELSE SELECTOR(FSYS,LCP); IF GATTR.TYPTR <> NIL THEN %ELIM. SUBR. TYPES TO\ WITH GATTR, TYPTR^ DO %SIMPLIFY LATER TESTS\ IF FORM = SUBRANGE THEN TYPTR := RANGETYPE END; %CST\ INTCONST: BEGIN WITH GATTR DO BEGIN TYPTR := INTPTR; KIND := CST; CVAL := VAL END; INSYMBOL END; REALCONST: BEGIN WITH GATTR DO BEGIN TYPTR := REALPTR; KIND := CST; CVAL := VAL END; INSYMBOL END; STRINGCONST: BEGIN WITH GATTR DO BEGIN KIND := CST; IF LGTH = 1 THEN BEGIN TYPTR := CHARPTR; CVAL := VAL; INSYMBOL END ELSE BEGIN NEW(LSP,ARRAYS); NEW(LSP1,SUBRANGE); WITH LSP^ DO BEGIN AELTYPE := CHARPTR; INXTYPE := LSP1; PACKOPT := FALSE; ADDRCORR := 0; SIZE := 2 * ((LGTH + 1) DIV 2); END; WITH LSP1^ DO BEGIN SIZE := 2; RANGETYPE := INTPTR; MIN.IVAL := 0; MAX.IVAL := LGTH-1 END; TYPTR := LSP; CVAL := VAL; LOADSTRINGCONSTANT; INSYMBOL; IF SY = LBRACK THEN BEGIN SELECTOR(FSYS,NIL); LOAD END END; END; END; %(\ LPARENT: BEGIN INSYMBOL; EXPRESSION(FSYS OR [RPARENT]); IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END; %NOT\ NOTSY: BEGIN INSYMBOL; FACTOR(FSYS); LOAD; GEN1(COM,REGDEF,SP); GEN2(BIC,AUTINC,PC,REGDEF,SP); GENCONST(-2); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> BOOLPTR THEN BEGIN ERROR(135); GATTR.TYPTR := NIL END; END; %[\ LBRACK: BEGIN INSYMBOL; CSTPART := [ ]; VARPART := FALSE; FOURWORDSET := FALSE; RANGEPART := FALSE; NEW(LSP,POWER); WITH LSP^ DO BEGIN ELSET := NIL; SIZE := 2 END; IF SY = RBRACK THEN BEGIN WITH GATTR DO BEGIN TYPTR := LSP; KIND := CST END; INSYMBOL END ELSE BEGIN LOOP EXPRESSION(FSYS OR [COMMA,COLON,RBRACK]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> SCALAR THEN BEGIN ERROR(136); GATTR.TYPTR := NIL END ELSE IF COMPTYPES(LSP^.ELSET,GATTR.TYPTR) THEN BEGIN IF GATTR.KIND = CST THEN BEGIN I := GATTR.CVAL.IVAL; IF GATTR.TYPTR = CHARPTR THEN I := I - 40B; IF I > 15 THEN FOURWORDSET := TRUE; IF (I > 63) OR (I < 0) THEN ERROR(604) ELSE CSTPART := CSTPART OR [I]; IF SY = COLON THEN BEGIN RANGEPART := TRUE; LRMIN := I END ELSE IF RANGEPART THEN BEGIN LRMIN := LRMIN + 1; WHILE LRMIN < I DO BEGIN CSTPART := CSTPART OR [LRMIN]; LRMIN := LRMIN + 1; END; RANGEPART := FALSE END END ELSE BEGIN LOAD; IF (SY = COLON) OR RANGEPART THEN BEGIN ERROR(21); RANGEPART := NOT RANGEPART END; IF GATTR.TYPTR = CHARPTR THEN BEGIN GEN2(SUB,AUTINC,PC,REGDEF,SP); GENCONST(40B); END; IF NOT VARPART THEN BEGIN VARPART := TRUE; GETBOUNDS(GATTR.TYPTR,SMIN,SMAX) ; IF (SMAX <> 0) AND (SMAX <= 15) AND NOT FOURWORDSET THEN BEGIN GEN2(MOV,REGDEF,SP,REG,AR); GEN1(CLR,REGDEF,SP); GEN2(MOV,REG,AR,AUTDEC,SP) END ELSE BEGIN GENSUBRCALL(INITS); FOURWORDSET := TRUE END; END; GENSUBRCALL(SGSIN) END; LSP^.ELSET := GATTR.TYPTR; GATTR.TYPTR := LSP END ELSE ERROR(137); EXIT IF NOT (SY IN [COMMA,COLON]); INSYMBOL END; IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12) END; GATTR.KIND := EXPR; IF FOURWORDSET THEN LSP^.SIZE := 8; IF NOT (VARPART AND (CSTPART = [])) THEN BEGIN IF FOURWORDSET THEN SCOUNT := 63 ELSE SCOUNT := 15; FOR K := LSP^.SIZE DIV 2 DOWNTO 1 DO BEGIN J := 40000B; INTSET := 0; IF SCOUNT IN CSTPART THEN INTSET := INTSET + 100000B; SCOUNT := SCOUNT - 1; FOR I := 0 TO 14 DO BEGIN IF SCOUNT IN CSTPART THEN INTSET := INTSET + J; J := J DIV 2; SCOUNT := SCOUNT - 1 END; IF INTSET = 0 THEN GEN1(CLR,AUTDEC,SP) ELSE BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(INTSET) END; END; IF VARPART THEN IF FOURWORDSET THEN GENSUBRCALL(UNI4) ELSE GEN2(BIS, AUTINC,SP,REGDEF,SP); END END END %CASE\ ; IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS OR FACBEGSYS) END END %WHILE\ END %FACTOR\ ; BEGIN %TERM\ FACTOR(FSYS OR [MULOP]); WHILE SY = MULOP DO BEGIN LOAD; LATTR := GATTR; LOP := OP; INSYMBOL; FACTOR(FSYS OR [MULOP]); LOAD; IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN CASE LOP OF %*,AND\ MUL,ANDOP: BEGIN IF (LATTR.TYPTR = BOOLPTR) AND (GATTR.TYPTR = BOOLPTR) AND (LOP = ANDOP) THEN BEGIN GEN1(COM,REGDEF,SP); GEN2(BIC,AUTINC,SP,REGDEF,SP) END ELSE IF (LATTR.TYPTR^.FORM = POWER) THEN IF LARGESET(LATTR) THEN GENSUBRCALL(INT4) ELSE BEGIN GEN1(COM,REGDEF,SP); %INT1\ GEN2(BIC,AUTINC,SP,REGDEF,SP) END ELSE IF LOP = MUL THEN IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN MULTIPLY ELSE BEGIN IF LATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLO); LATTR.TYPTR := REALPTR END ELSE IF GATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLT); GATTR.TYPTR := REALPTR END; IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR) THEN GENSUBRCALL(MPR) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END; %/\ RDIV: BEGIN IF GATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLT); GATTR.TYPTR := REALPTR END; IF LATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLO); LATTR.TYPTR := REALPTR END; IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR) THEN GENSUBRCALL(DVR) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END; %DIV\ IDIV: IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN GENSUBRCALL(DVI) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END; %MOD\ IMOD: IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN GENSUBRCALL(MODI) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END %CASE\ ELSE GATTR.TYPTR := NIL END %WHILE\ END %TERM\ ; BEGIN %SIMPLEEXPRESSION\ SIGNED := FALSE; IF (SY = ADDOP) AND (OP IN [PLUS,MINUS]) THEN BEGIN SIGNED := OP = MINUS; INSYMBOL END; TERM(FSYS OR [ADDOP]); IF SIGNED THEN BEGIN LOAD; IF GATTR.TYPTR = INTPTR THEN GEN1(NEG,REGDEF,SP) ELSE IF GATTR.TYPTR = REALPTR THEN BEGIN GEN1(TST,REGDEF,SP); GENBR(BEQ,2); %TO PREVENT -0\ GEN2(ADD,AUTINC,PC,REGDEF,SP); GENCONST(100000B); END ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END; WHILE SY = ADDOP DO BEGIN LOAD; LATTR := GATTR; LOP := OP; INSYMBOL; TERM(FSYS OR [ADDOP]); LOAD; IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN CASE LOP OF %+,OR\ PLUS,OROP: BEGIN IF (LATTR.TYPTR = BOOLPTR) AND (GATTR.TYPTR = BOOLPTR) AND (LOP = OROP) THEN GEN2(BIS,AUTINC,SP,REGDEF,SP) ELSE IF LATTR.TYPTR^.FORM = POWER THEN IF LARGESET(LATTR) THEN GENSUBRCALL(UNI4) ELSE GEN2(BIS,AUTINC,SP,REGDEF,SP) ELSE IF LOP = PLUS THEN IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN GEN2(ADD,AUTINC,SP,REGDEF,SP) ELSE BEGIN IF LATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLO); LATTR.TYPTR := REALPTR END ELSE IF GATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLT); GATTR.TYPTR := REALPTR END; IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR) THEN GENSUBRCALL(ADR) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END; %-\ MINUS: IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN GEN2(SUB,AUTINC,SP,REGDEF,SP) ELSE BEGIN IF LATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLO); LATTR.TYPTR := REALPTR END ELSE IF GATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLT); GATTR.TYPTR := REALPTR END; IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR) THEN GENSUBRCALL(SBR) ELSE IF LATTR.TYPTR^.FORM = POWER THEN IF LARGESET(LATTR) THEN GENSUBRCALL(DIF4) ELSE GEN2(BIC,AUTINC,SP,REGDEF,SP) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END END %CASE\ ELSE GATTR.TYPTR := NIL END %WHILE\ END %SIMPLEEXPRESSION\ ; (*$Y+*) (* NEW MODULE *) BEGIN %EXPRESSION\ MULTSSIZE := 0; SMPLEEXPRESSION(FSYS OR [RELOP]); IF SY = RELOP THEN BEGIN STACKD := FALSE; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <= POWER THEN LOAD ELSE IF GATTR.KIND = EXPR THEN STACKD := TRUE ELSE BEGIN LOADADDRESS; IF GATTR.TYPTR^.FORM = ARRAYS THEN %HYP --> ACT\ IF GATTR.TYPTR^.ADDRCORR <> 0 THEN BEGIN GEN2(ADD,AUTINC,PC,REGDEF,SP); GENCONST(GATTR.TYPTR^.ADDRCORR) END END; LATTR := GATTR; LOP := OP; INSYMBOL; SMPLEEXPRESSION(FSYS); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <= POWER THEN LOAD ELSE IF STACKD THEN %MULTIPLE LEFTM ON STACK\ BEGIN IF GATTR.KIND = EXPR THEN BEGIN GEN2(MOV,REG,SP,REG,AR); %LOAD RIGHT MEMBER ADDR\ MULTSSIZE := GATTR.TYPTR^.SIZE; END ELSE BEGIN LOADADDRESS; GEN2(MOV,AUTINC,SP,REG,AR); %LOAD RIGHT MEMBER ADDRESS\ IF GATTR.TYPTR^.FORM = ARRAYS THEN IF GATTR.TYPTR^.ADDRCORR <> 0 THEN BEGIN GEN2(ADD,AUTINC,PC,REG,AR); GENCONST(GATTR.TYPTR^.ADDRCORR) END END; GEN2(MOV,REG,SP,REG,AD); %LOAD DESTINATIONADDRESS\ IF MULTSSIZE <> 0 THEN BEGIN GEN2(ADD,AUTINC,PC,REG,AD); GENCONST(MULTSSIZE) END; MULTSSIZE := MULTSSIZE + LATTR.TYPTR^.SIZE END ELSE IF GATTR.KIND = EXPR THEN BEGIN STACKD := TRUE; GEN2(MOV,REG,SP,REG,AR); MULTSSIZE := GATTR.TYPTR^.SIZE; GEN2(MOV,INDEX,SP,REG,AD); GENCONST(MULTSSIZE); MULTSSIZE := MULTSSIZE + 2; END ELSE BEGIN LOADADDRESS; STACKD := FALSE; IF GATTR.TYPTR^.FORM = ARRAYS THEN IF GATTR.TYPTR^.ADDRCORR <> 0 THEN BEGIN GEN2(ADD,AUTINC,PC,REGDEF,SP); GENCONST(GATTR.TYPTR^.ADDRCORR) END END; IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN IF LOP = INOP THEN IF (GATTR.TYPTR^.FORM = POWER ) AND (LATTR.TYPTR^.FORM=SCALAR) THEN IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR^.ELSET) THEN BEGIN GETBOUNDS(LATTR.TYPTR,SMIN,SMAX); %BOUNS OF SCAL.\ IF (LATTR.TYPTR = CHARPTR) OR ((LATTR.TYPTR^.FORM = SUBRANGE) AND (LATTR.TYPTR^.RANGETYPE = CHARPTR)) THEN BEGIN C := TRUE % CHAR IN SET MUST BE REL SPACE \ ; SMIN := 0; SMAX := SMAX - 40B; END ELSE C := FALSE; IF (SMAX = 0) OR (SMAX > 15) THEN B := TRUE ELSE B := FALSE; %B=TRUE MEANS THAT A LARGE SET MUST BE USED\ LSIZE := GATTR.TYPTR^.SIZE; IF (GATTR.KIND<>VARBL) AND B AND (LSIZE = 2) THEN BEGIN GENSUBRCALL(EXPST); LSIZE := 8 END ELSE B := LSIZE = 8; IF C THEN BEGIN GEN2( SUB, AUTINC, PC, INDEX, SP ); GENCONST( 40B % SPACE \ ); GENCONST( LSIZE ) END; GENSUBRCALL(INN); IF B THEN GENCONST(8) ELSE GENCONST(2); END ELSE BEGIN ERROR(129); GATTR.TYPTR := NIL END ELSE BEGIN ERROR(130); GATTR.TYPTR := NIL END ELSE BEGIN IF LATTR.TYPTR <> GATTR.TYPTR THEN IF LATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLO); LATTR.TYPTR := REALPTR END ELSE IF GATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLT); GATTR.TYPTR := REALPTR END; IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN BEGIN LSIZE := LATTR.TYPTR^.SIZE; CASE LATTR.TYPTR^.FORM OF SCALAR : BEGIN B := LATTR.TYPTR = REALPTR; SUBRNAME := SCALRT[LOP,B] END; POINTER: IF LOP = EQOP THEN SUBRNAME := EQU ELSE IF LOP = NEOP THEN SUBRNAME := NEQ ELSE SUBRNAME := ERRN; POWER : BEGIN B := LARGESET(LATTR); CASE LOP OF LTOP,GTOP: SUBRNAME := ERRN; LEOP: IF B THEN SUBRNAME := LEQS4 ELSE SUBRNAME := LEQS1; GEOP: IF B THEN SUBRNAME := GEQS4 ELSE SUBRNAME := GEQS1; NEOP: IF B THEN SUBRNAME := NEQS4 ELSE SUBRNAME := NEQ; EQOP: IF B THEN SUBRNAME := EQUS4 ELSE SUBRNAME := EQU END; END; ARRAYS, RECORDS: BEGIN SUBRNAME := ARRT[LOP,STRING(LATTR.TYPTR),STACKD]; IF SUBRNAME IN [EQUM,EQUM2,NEQM,NEQM2] THEN LSIZE := LSIZE DIV 2; END; FILES : BEGIN ERROR(133); SUBRNAME := ERRN END END; IF SUBRNAME = ERRN THEN ERROR(131) ELSE IF LATTR.TYPTR^.FORM IN [ARRAYS,RECORDS] THEN IF SUBRNAME IN [EQUM2,NEQM2,LEQM2,LESM2,GEQM2,GRTM2] THEN BEGIN GEN2(MOV,AUTINC,PC,REG,R); GENCONST(LSIZE); GENSUBRCALL(SUBRNAME); END ELSE BEGIN GENSUBRCALL(SUBRNAME); GENCONST(LSIZE) END ELSE GENSUBRCALL(SUBRNAME) END ELSE ERROR(129) END; GATTR.TYPTR := BOOLPTR; GATTR.KIND := EXPR; IF MULTSSIZE <> 0 THEN BEGIN GEN2(MOV,REGDEF,SP,INDEX,SP); GENCONST(MULTSSIZE); GEN2(ADD,AUTINC,PC,REG,SP); GENCONST(MULTSSIZE); END END %SY = RELOP\ END %EXPRESSION\ ; PROCEDURE ASSIGNMENT(FCP: CTP) (*$Y+*) ; VAR LATTR: ATTR; SMIN,SMAX: INTEGER; LSP1: STP; STACKD: BOOLEAN; AL, I: INTEGER; BEGIN SELECTOR(FSYS OR [BECOMES],FCP); IF FCP^.KLASS = FUNC THEN IF (FCP^.PFLEV > LEVEL) OR (FCP^.PFLEV=LEVEL) AND (FPROCP<>FCP) THEN BEGIN ERROR ( 184 ); GATTR.TYPTR := NIL; END; IF SY = BECOMES THEN BEGIN IF GATTR.TYPTR <> NIL THEN IF (GATTR.ACCESS <> DRCT) OR (GATTR.TYPTR^.FORM > POWER) THEN BEGIN LOADADDRESS; IF GATTR.TYPTR^.FORM = ARRAYS THEN IF GATTR.TYPTR^.ADDRCORR <> 0 THEN BEGIN GEN2(ADD,AUTINC,PC,REGDEF,SP); GENCONST(GATTR.TYPTR^.ADDRCORR) %HYPOTHETICAL ADDRESS BECOMES ACTUAL ADDRESS\ END END; LATTR := GATTR; INSYMBOL; EXPRESSION(FSYS); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <= POWER THEN LOAD ELSE IF GATTR.KIND = EXPR THEN BEGIN STACKD := TRUE; GEN2(MOV,REG,SP,REG,AR); GEN2(ADD,AUTINC,PC,REG,SP); GENCONST(GATTR.TYPTR^.SIZE); GEN2(MOV,AUTINC,SP,REG,AD) END %WHEN THE MULTIPLE IS A FUNCTIONRESULT ON THE STACK\ ELSE BEGIN LOADADDRESS; STACKD := FALSE; IF GATTR.TYPTR^.FORM = ARRAYS THEN IF GATTR.TYPTR^.ADDRCORR <> 0 THEN BEGIN GEN2(ADD,AUTINC,PC,REGDEF,SP); GENCONST(GATTR.TYPTR^.ADDRCORR) END END; IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN BEGIN IF COMPTYPES(REALPTR,LATTR.TYPTR) AND (GATTR.TYPTR = INTPTR) THEN BEGIN GENSUBRCALL(FLT); GATTR.TYPTR := REALPTR END; IF LATTR.TYPTR^.FORM = POWER THEN STACKD := LARGESET(LATTR); %SETCONVERSIONS ONLY\ IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN CASE LATTR.TYPTR^.FORM OF SCALAR, SUBRANGE: BEGIN IF RUNTMCHECK AND (LATTR.TYPTR<>INTPTR) AND (LATTR.TYPTR <> REALPTR) AND (LATTR.TYPTR <> BOOLPTR) (*V5-34*) THEN BEGIN GETBOUNDS(LATTR.TYPTR,SMIN,SMAX); GENSUBRCALL(SUBRCHK); GENCONST(SMIN); GENCONST(SMAX); END; STORE(LATTR); END; POINTER, POWER : STORE(LATTR); ARRAYS, RECORDS: BEGIN AL := GATTR.TYPTR^.SIZE DIV 2; IF STACKD THEN IF AL <= 3 THEN FOR I:= 1 TO AL DO GEN2(MOV,AUTINC,AR,AUTINC,AD) ELSE BEGIN GENSUBRCALL(MOVM2); GENCONST(AL); END ELSE BEGIN GENSUBRCALL(MOVM); GENCONST(AL) END END; FILES: ERROR(146) END ELSE ERROR(129) END END %SY = BECOMES\ ELSE ERROR(51) END %ASSIGNMENT\ ; PROCEDURE GOTOSTATEMENT (*$Y+*) ; LABEL 1; VAR LLP: LBP; LRP: REFLINKP ; BEGIN IF SY = INTCONST THEN BEGIN LLP := FSTLABP; WHILE LLP <> FLABP DO WITH LLP^ DO IF LABVAL = VAL.IVAL THEN BEGIN IF DEFINED THEN GENUJP(LABADDR) ELSE BEGIN GENUJP( 0 ); NEW ( LRP ) ; LRP^.NEXTREF := LABCHAIN ; LABCHAIN := LRP ; LRP^.REFADDR := CIX ; END; GOTO 1 END ELSE LLP := NEXTLAB; (* UNDECLARED AND UNDEFINED *) GENUJP( 0 ); NEW(LRP); NEW(LLP); WITH LLP^ DO BEGIN LABVAL := VAL.IVAL; DEFINED := FALSE; LABCHAIN := LRP; NEXTLAB := FSTLABP; DECLARED := FALSE; END; FSTLABP := LLP; WITH LRP^ DO BEGIN NEXTREF := NIL; REFADDR := CIX END; 1: INSYMBOL END ELSE ERROR(15) END %GOTOSTATEMENT\ ; PROCEDURE COMPOUNDSTATEMENT (*$Y+*) ; BEGIN LOOP REPEAT STATEMENT(FSYS OR [SEMICOLON,ENDSY]) UNTIL NOT (SY IN STATBEGSYS); EXIT IF SY <> SEMICOLON; INSYMBOL END; IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13) END %COMPOUNDSTATEMENET\ ; PROCEDURE IFSTATEMENT (*$Y+*) ; VAR LCIX1,LCIX2: CODERANGE; BEGIN EXPRESSION(FSYS OR [THENSY]); GENFJP(0); LCIX1 := CIX; IF SY = THENSY THEN INSYMBOL ELSE ERROR(52); STATEMENT(FSYS OR [ELSESY]); IF SY = ELSESY THEN BEGIN GENUJP(0); LCIX2 := CIX; INSERT(LCIX1, 2 * (CIX - LCIX1)); INSYMBOL; STATEMENT(FSYS); INSERT(LCIX2, 2 * (CIX - LCIX2)); END ELSE INSERT(LCIX1,2 * (CIX - LCIX1)); END %IFSTATEMENT\ ; PROCEDURE CASESTATEMENT (*$Y+*) ; LABEL 1,2; TYPE CIP = ^CASEINFO; CASEINFO = PACKED RECORD NEXT: CIP; CSSTART: CODERANGE; CSEND: CODERANGE; CSLAB: INTEGER END; VAR LSP,LSP1: STP; FSTPTR,LPT1,LPT2,LPT3: CIP; LVAL: VALU; LADDR,OTHERADDR,OTHEREND: ADDRRANGE; LCIX: CODERANGE; LMIN,LMAX: INTEGER; OTHERCASE: BOOLEAN; HEAPM: INTP; BEGIN EXPRESSION(FSYS OR [OFSY,COMMA,COLON]); HEAPMARK(HEAPM); LOAD; %LOAD LABELVALUE\ GEN2(MOV,AUTINC,SP,REG,R); GEN2(CMP,REG,R,AUTINC,PC); GENCONST(0); GENBR(BLT,3); GEN2(CMP,REG,R,AUTINC,PC); GENCONST(0); GENBR(BLE,2); GEN1(JMP,INDEX,PC); GENCONST(0); GEN1(ASL,REG,R); GEN2(ADD,REG,PC,REG,R); LCIX := CIX; GEN2(ADD,INDEX,R,REG,R); GENCONST(0); GEN1(JMP,REGDEF,R); LSP := GATTR.TYPTR; IF LSP <> NIL THEN IF (LSP^.FORM <> SCALAR) OR (LSP = REALPTR) THEN BEGIN ERROR(144); LSP := NIL END; IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); FSTPTR := NIL; LPT3 := NIL; OTHERADDR := 0; LOOP OTHERCASE := SY = DEFAULTSY; IF OTHERCASE THEN BEGIN IF OTHERADDR <> 0 THEN ERROR(156); OTHERADDR := CIX + 1; INSYMBOL END ELSE LOOP CONSTANT(FSYS OR [COMMA,COLON],LSP1,LVAL); IF LSP <> NIL THEN IF COMPTYPES(LSP,LSP1) THEN BEGIN LPT1 := FSTPTR; LPT2 := NIL; WHILE LPT1 <> NIL DO WITH LPT1^ DO BEGIN IF CSLAB <= LVAL.IVAL THEN BEGIN IF CSLAB = LVAL.IVAL THEN ERROR(156); GOTO 1 END; LPT2 := LPT1; LPT1 := NEXT END; 1: NEW(LPT3); WITH LPT3^ DO BEGIN NEXT := LPT1; CSLAB := LVAL.IVAL; CSSTART := CIX + 1; CSEND := 0; %CSSTART IS CODEADDRESS\ END; IF LPT2 = NIL THEN FSTPTR := LPT3 ELSE LPT2^.NEXT := LPT3 END ELSE ERROR(147); EXIT IF SY <> COMMA; INSYMBOL; END; IF (OTHERADDR<>0) AND NOT OTHERCASE THEN ERROR(186); IF SY = COLON THEN INSYMBOL ELSE ERROR(5); REPEAT STATEMENT(FSYS OR [SEMICOLON]) UNTIL NOT (SY IN STATBEGSYS); GENUJP(0); IF OTHERCASE THEN OTHEREND := CIX ELSE IF LPT3<>NIL THEN LPT3^.CSEND := CIX; EXIT IF SY <> SEMICOLON; INSYMBOL; IF SY=ENDSY THEN GOTO 2; END; 2: IF FSTPTR <> NIL THEN BEGIN LMAX := FSTPTR^.CSLAB; %REVERSE POINTERS\ LPT1 := FSTPTR; FSTPTR := NIL; REPEAT LPT2 := LPT1^.NEXT; LPT1^.NEXT := FSTPTR; FSTPTR := LPT1; LPT1 := LPT2 UNTIL LPT1 = NIL; LMIN := FSTPTR^.CSLAB; INSERT(LCIX + 2, 2 * (CIX - LCIX - LMIN)); INSERT(LCIX - 8, LMIN); INSERT(LCIX - 5, LMAX); IF LMAX - LMIN < CIXMAX THEN BEGIN LADDR := CIX + 2 + LMAX - LMIN; IF OTHERADDR = 0 THEN OTHERADDR := LADDR ELSE INSERT( OTHEREND, 2*(LADDR-OTHEREND-1)); INSERT(LCIX - 2,2 * (OTHERADDR - LCIX + 1)); REPEAT WITH FSTPTR^ DO BEGIN WHILE CSLAB > LMIN DO BEGIN GENCONST(2 * (OTHERADDR - LCIX - 1 - LMIN)); LMIN := LMIN + 1 END; GENCONST(2 * (CSSTART - LCIX - CSLAB - 1)); IF CSEND <> 0 THEN INSERT(CSEND, 2 * (LADDR-CSEND-1)); FSTPTR := NEXT; LMIN := LMIN + 1 END UNTIL FSTPTR = NIL END ELSE ERROR(157) END; IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13); HEAPRELEASE(HEAPM) END %CASESTATEMENT\ ; PROCEDURE REPEATSTATEMENT (*$Y+*) ; VAR LADDR: ADDRRANGE; BEGIN LADDR := CIX + 1; LOOP REPEAT STATEMENT(FSYS OR [SEMICOLON,UNTILSY]) UNTIL NOT (SY IN STATBEGSYS); EXIT IF SY <> SEMICOLON; INSYMBOL END; IF SY = UNTILSY THEN BEGIN INSYMBOL; EXPRESSION(FSYS); GENFJP(LADDR) END ELSE ERROR(53) END %REPEATSTATEMENT\ ; PROCEDURE WHILESTATEMENT (*$Y+*) ; VAR LADDR: ADDRRANGE; LCIX: CODERANGE; BEGIN LADDR := CIX + 1; EXPRESSION(FSYS OR [DOSY]); GENFJP(0); LCIX := CIX; IF SY = DOSY THEN INSYMBOL ELSE ERROR(54); STATEMENT(FSYS); GENUJP(LADDR); INSERT(LCIX, 2 * (CIX - LCIX)) END %WHILESTATEMENT\ ; PROCEDURE FORSTATEMENT (*$Y+*) ; VAR LATTR: ATTR; LSP: STP; LADDR: ADDRRANGE; LSY: SYMBOL; LCIX: CODERANGE; REGR, I: INTEGER; INSTR: INSTRRANGE; BEGIN IF SY = IDENT THEN BEGIN SEARCHID([VARS],LCP); WITH LCP^, LATTR DO BEGIN TYPTR := IDTYPE; KIND := VARBL; IF VKIND = ACTUAL THEN BEGIN ACCESS := DRCT; VLEVEL := VLEV; DPLMT := VADDR END ELSE BEGIN ERROR(155); TYPTR := NIL END END; IF LATTR.TYPTR <> NIL THEN IF (LATTR.TYPTR^.FORM > SUBRANGE) OR COMPTYPES(REALPTR,LATTR.TYPTR) THEN BEGIN ERROR(143); LATTR.TYPTR := NIL END; INSYMBOL END ELSE BEGIN ERROR(2); SKIP(FSYS OR [BECOMES,TOSY,DOWNTOSY,DOSY]) END; IF SY = BECOMES THEN BEGIN INSYMBOL; EXPRESSION(FSYS OR [TOSY,DOWNTOSY,DOSY]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> SCALAR THEN ERROR(144) ELSE IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN BEGIN LOAD; STORE(LATTR) END ELSE ERROR(145) END ELSE BEGIN ERROR(51); SKIP(FSYS OR [TOSY,DOWNTOSY,DOSY]) END; IF SY IN [TOSY,DOWNTOSY] THEN BEGIN LSY := SY; INSYMBOL; EXPRESSION(FSYS OR [DOSY]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> SCALAR THEN ERROR(144) ELSE IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN BEGIN LOAD; LC := LC - 2; GEN2(MOV,AUTINC,SP,INDEX,MP); GENCONST(LC); LADDR := CIX + 1; %CODE-ADDR FOR JUMP\ IF LATTR.VLEVEL = LEVEL THEN REGR := MP ELSE IF LATTR.VLEVEL <= 1 THEN REGR := GP ELSE BEGIN GEN2(MOV,REGDEF,MP,REG,AD); FOR I := 2 TO LEVEL - LATTR.VLEVEL DO GEN2(MOV,REGDEF,AD,REG,AD); REGR := AD END; IF LATTR.TYPTR = CHARPTR THEN INSTR := CMPB ELSE INSTR := CMP; GEN2(INSTR,INDEX,REGR,INDEX,MP); GENCONST(LATTR.DPLMT); GENCONST(LC); IF LSY = TOSY THEN INSTR := BLE ELSE INSTR := BGE; GENBR(INSTR, 2); IF LC < LCMAX THEN LCMAX := LC END ELSE ERROR(145) END ELSE BEGIN ERROR(55); SKIP(FSYS OR [DOSY]) END; GEN1(JMP,INDEX,PC); GENCONST(0); LCIX := CIX; IF SY = DOSY THEN INSYMBOL ELSE ERROR(54); STATEMENT(FSYS); IF LSY = TOSY THEN INSTR := INC ELSE INSTR := DEC; IF REGR = AD THEN BEGIN GEN2(MOV,REGDEF,MP,REG,AD); FOR I := 2 TO LEVEL - LATTR.VLEVEL DO GEN2(MOV,REGDEF,AD,REG,AD) END; GEN1(INSTR,INDEX,REGR); GENCONST(LATTR.DPLMT); IF CIX-LADDR <= 126 THEN GENBR ( BVC, LADDR-CIX-2 ) ELSE BEGIN GENBR ( BVS, 2 ); GENUJP ( LADDR ); END; INSERT(LCIX, 2 * (CIX - LCIX)); LC := LC + 2 END %FORSTATEMENT\ ; PROCEDURE LOOPSTATEMENT (*$Y+*) ; VAR LADDR: ADDRRANGE; LCIX: CODERANGE; BEGIN LADDR := CIX + 1; LOOP REPEAT STATEMENT(FSYS OR [SEMICOLON,EXITSY]) UNTIL NOT (SY IN STATBEGSYS); EXIT IF SY <> SEMICOLON; INSYMBOL END; IF SY = EXITSY THEN BEGIN INSYMBOL; IF SY = IFSY THEN BEGIN INSYMBOL; EXPRESSION(FSYS OR [SEMICOLON,ENDSY]); LOAD END ELSE BEGIN ERROR(56); SKIP(FSYS OR [SEMICOLON,ENDSY]) END; GEN1(TST,AUTINC,SP); GENBR(BEQ,2); GEN1(JMP,INDEX,PC); GENCONST(0); LCIX := CIX; LOOP REPEAT STATEMENT(FSYS OR [SEMICOLON,ENDSY]) UNTIL NOT (SY IN STATBEGSYS); EXIT IF SY <> SEMICOLON; INSYMBOL END; GENUJP(LADDR); INSERT(LCIX,2 * (CIX - LCIX)) END ELSE ERROR(57); IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13) END %LOOPSTATEMENT\ ; PROCEDURE WITHSTATEMENT (*$Y+*) ; VAR LCP: CTP; LCNT1: DISPRANGE; LCNT2: ADDRRANGE; BEGIN LCNT1 := 0; LCNT2 := 0; LOOP IF SY = IDENT THEN BEGIN SEARCHID([VARS,FIELD],LCP); INSYMBOL END ELSE BEGIN ERROR(2); LCP := UVARPTR END; SELECTOR(FSYS OR [COMMA,DOSY],LCP); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM = RECORDS THEN IF TOP < DISPLIMIT THEN BEGIN TOP := TOP + 1; LCNT1 := LCNT1 + 1; DISPLAY[TOP].FNAME := GATTR.TYPTR^.FSTFLD; IF GATTR.ACCESS = DRCT THEN WITH DISPLAY[TOP] DO BEGIN OCCUR := CREC; CLEV := GATTR.VLEVEL; CDSPL := GATTR.DPLMT END ELSE BEGIN LOADADDRESS; LC := LC - 2; LCNT2 := LCNT2 - 2; WITH DISPLAY[TOP] DO BEGIN OCCUR := VREC; VDSPL := LC END; IF LC < LCMAX THEN LCMAX := LC; GEN2(MOV,AUTINC,SP,INDEX,MP); GENCONST(LC) END END ELSE ERROR(250) ELSE ERROR(140); EXIT IF SY <> COMMA; INSYMBOL END; IF SY = DOSY THEN INSYMBOL ELSE ERROR(54); STATEMENT(FSYS); TOP := TOP - LCNT1; LC := LC - LCNT2; END %WITHSTATEMENT\ ; (*$Y+*) (* NEW MODULE *) BEGIN %STATEMENT\ IF RUNTMCHECK THEN LINENODEF; IF SY = INTCONST THEN %LABEL\ BEGIN LLP := FSTLABP; WHILE LLP <> FLABP DO WITH LLP^ DO IF LABVAL = VAL.IVAL THEN BEGIN IF NOT DECLARED THEN ERROR(900); IF DEFINED THEN ERROR(165); WHILE LABCHAIN <> NIL DO WITH LABCHAIN^ DO BEGIN INSERT ( REFADDR, 2*( CIX - REFADDR )) ; LABCHAIN := NEXTREF END ; LABADDR := CIX + 1 ; DEFINED := TRUE ; GOTO 1 END ELSE LLP := NEXTLAB; ERROR(900); NEW(LLP); WITH LLP^ DO BEGIN DECLARED := FALSE; LABVAL := VAL.IVAL; DEFINED := TRUE; LABCHAIN := NIL; NEXTLAB := FSTLABP; LABADDR := CIX + 1; END; FSTLABP := LLP; 1: INSYMBOL; IF SY = COLON THEN INSYMBOL ELSE ERROR(5) END; IF NOT (SY IN FSYS OR [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS) END; IF SY IN STATBEGSYS OR [IDENT] THEN BEGIN CASE SY OF IDENT: BEGIN SEARCHID([VARS,FIELD,FUNC,PROC],LCP); INSYMBOL; IF LCP^.KLASS = PROC THEN CALL(FSYS,LCP) ELSE ASSIGNMENT(LCP) END; BEGINSY: BEGIN INSYMBOL; COMPOUNDSTATEMENT END; GOTOSY: BEGIN INSYMBOL; GOTOSTATEMENT END; IFSY: BEGIN INSYMBOL; IFSTATEMENT END; CASESY: BEGIN INSYMBOL; CASESTATEMENT END; WHILESY: BEGIN INSYMBOL; WHILESTATEMENT END; REPEATSY: BEGIN INSYMBOL; REPEATSTATEMENT END; LOOPSY: BEGIN INSYMBOL; LOOPSTATEMENT END; FORSY: BEGIN INSYMBOL; FORSTATEMENT END; WITHSY: BEGIN INSYMBOL; WITHSTATEMENT END END; IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END END END %STATEMENT\ ; PROCEDURE STARTOFMAIN (*$Y+*) ; VAR LCIX: INTEGER; BEGIN EPMAIN := (CIX + 1); LLC1 := 0 ; IF NFILES = 0 THEN GENSUBRCALL ( INITN ) ELSE GENSUBRCALL( INITA ) ; GENCONST(0); PUTRLD('$$HEAP ',ABSADDR,2*CODE.LEN-2,0); PUTGSD('$$HEAP ',GLOBALREFFLAGS,0); IF OUTPUTPTR <> NIL THEN ADDR := OUTPUTPTR^.VADDR ELSE ADDR :=0 ; GENCONST( ADDR % OUTPUT \ ) ; IF INPUTPTR <> NIL THEN ADDR := INPUTPTR^.VADDR ELSE ADDR := 0 ; GENCONST ( ADDR % INPUT \ ) ; IF TTYOUTPTR <> NIL THEN ADDR := TTYOUTPTR^.VADDR ELSE ADDR := 0 ; GENCONST ( ADDR % TTYOUT \ ) ; IF TTYINPTR <> NIL THEN ADDR := TTYINPTR^.VADDR ELSE ADDR := 0 ; GENCONST ( ADDR % TTYIN \ ) ; TESTPACKED := TRUE; IF ONSWITCH['H'] THEN BEGIN GEN2(MOV,AUTINC,PC,INDEX,GP); GENCONST(SELECTOR); GENCONST(4%SELECTOR WORD\); END; END; PROCEDURE NEWMODULE (*$Y-*) (* CONTIGUOUS MODULE *); BEGIN IF FIRSTMODULE THEN FIRSTMODULE := FALSE ELSE BEGIN IF GSD.LEN > 1 THEN WRITOBJ( GSD ); GSD.VALUE[1] := 2 % EGSD \ ; WRITOBJ( GSD ); GSD.VALUE[1] := 6 % EM \ ; WRITOBJ( GSD ); GSD.VALUE[1] := 1 % GSD \ ; (*$Z+*) (* NEW MODULE *) IF PRCODE THEN BEGIN WRITELN(CEX,'.END':30); PAGE(CEX); END; (*$Z-*) END; PUTGSD ( PSECT, 0 % MODULE NAME \, 0 ); PUTGSD ( OBJIDENT, 3000B % MODULE IDENT \, 0 ); WRITOBJ( GSD ); FOR RTR := ERRN TO DUMRTR DO NOTCALLED[RTR] := TRUE; (*$Z+*) IF PRCODE THEN WRITELN( CEX, ' .TITLE ',PSECT); (*$Z-*) END % NEWMODULE \ ; PROCEDURE ENTERBODY; VAR LCIX: INTEGER; LCP: CTP; BEGIN (* MNC - INITIALIZE INFO ABOUT PREV INSTRS: *) FOR I:= -1 TO 0 DO WITH PREV[I] DO BEGIN LOCINSTR := -1; OPCODE := HALT; SUBRNAME := DUMRTR; END; IF PSECTGEN OR FIRSTMODULE THEN NEWMODULE; PUTRLD ( PSECT, 7, 0, 2*CIX+2 ) ; WRITOBJ ( RLD ) ; (*$Z+*) IF PRCODE THEN BEGIN WRITELN(CEX); WRITELN(CEX); WRITELN(CEX); WRITELN(CEX,'.PSECT':30,PSECT:15) END; (*$Z-*) LCP := FPROCP; IF FPROCP <> NIL THEN WITH FPROCP^ DO BEGIN PFADDR := 2 * (CIX + 1); LLC1 := PARLISTSIZE; GLOBALDEF ( PSECT, PFADDR ) ; END %WITH FPROCP\ ELSE BEGIN STARTOFMAIN; NEW(LCP,PROC,STANDARD); WITH LCP^ DO BEGIN SELFCTP := 0; IDTYPE := NIL; NAME := PSECT; LLINK := NIL; RLINK := NIL; NEXT := NIL; END; END; GEN2(MOV,REG,SP,REG,AD); GEN2(MOV, REG,MP,AUTDEC,SP); GEN2(MOV, REG,AD,REG,MP); %ENTER BODY INSTRUCTIONS\ IF TESTPACKED THEN GENSUBRCALL(CLRSTK) ELSE GEN2(SUB,AUTINC,PC,REG,SP); GENCONST(0); CIX1 := CIX; IF ONSWITCH['D'] THEN BEGIN IF DEBUG THEN BEGIN COPYTREE ( DISPLAY[TOP].FNAME, LCP ); GEN2 ( MOV,AUTINC,PC,INDEX,MP ); GENCONST(0); PUTRLD('$DDTDF ',ABSADDR,2*CODE.LEN-2, 2*LCP^.SELFCTP); GENCONST(-4); END; GEN2(MOV,INDEX,GP,INDEX,MP); GENCONST(2); GENCONST(-6); (* LINE NUMBER *) IF FPROCP = NIL THEN BEGIN LCP := NIL; COPYTREE( DISPLAY[0].FNAME, LCP ); GEN2(MOV,AUTINC,PC,INDEX,GP); GENCONST(0); PUTRLD('$DDTDF ',ABSADDR,2*CODE.LEN-2, 2*LCP^.SELFCTP); GENCONST(-6); GEN2( MOV,AUTINC,PC,INDEX,GP); GENCONST(0); PUTRLD('$DDTDF ',ABSADDR,2*CODE.LEN-2,2*INTPTR^.SELFSTP); GENCONST(-8); GEN2 ( MOV,AUTINC,PC,INDEX,GP ); GENCONST(0); PUTRLD('$DDTDF ',ABSADDR,2*CODE.LEN-2,2*REALPTR^.SELFSTP); GENCONST(-10); GEN2 ( MOV,AUTINC,PC,INDEX,GP ); GENCONST(0); PUTRLD('$DDTDF ',ABSADDR,2*CODE.LEN-2,2*BOOLPTR^.SELFSTP); GENCONST(-12); GEN2 ( MOV,AUTINC,PC,INDEX,GP ); GENCONST(0); PUTRLD('$DDTDF ',ABSADDR,2*CODE.LEN-2,2*CHARPTR^.SELFSTP); GENCONST(-14); GEN2( MOV,INDEX,PC,INDEX,GP); GENCONST(0); PUTRLD('$DDTDF ',RELOCFCN,2*CODE.LEN-2,0); GENCONST(-16); GENSUBRCALL ( DDTINIT ); END; END; IF HEAPCHECK THEN BEGIN LINENODEF; GENSUBRCALL(OVFLCHK); END; LCMAX := LC; END % ENTERBODY \; PROCEDURE LEAVEBODY; VAR LCIX: INTEGER; BEGIN LLP := FSTLABP; %TEST FOR UNDEFINED LABELS\ WHILE LLP <> FLABP DO WITH LLP^ DO BEGIN IF NOT DEFINED THEN BEGIN IF LABCHAIN = NIL THEN ERROR(901) ELSE ERROR(168); IF LIST THEN BEGIN WRITELN; WRITELN(' LABEL ',LABVAL) END; END; LLP := NEXTLAB END; IF FPROCP = NIL THEN BEGIN IF ONSWITCH['Q'] THEN BEGIN GENSUBRCALL ( FREQV ); GENCONST(ORD(FILENAME[8])+256*ORD(FILENAME[9])); GENCONST(ORD(FILENAME[6])+256*ORD(FILENAME[7])); GENCONST(ORD(FILENAME[4])+256*ORD(FILENAME[5])); GENCONST(ORD(FILENAME[2])+256*ORD(FILENAME[3])); GENCONST(ORD(FILENAME[0])+256*ORD(FILENAME[1])); GENCONST(0); PUTRLD ( LASTLINE.LLPSECT,15B % PSECT ADD.REL. \, 2*CODE.LEN-2,2*LASTLINE.LLADDR); END; IF ONSWITCH['D'] THEN BEGIN PUTRLD('$DDTDF ',7,0,0); IF CODE.LEN>1 THEN WRITOBJ(CODE); IF RLD.LEN>1 THEN WRITOBJ( RLD); LCIX := CIX; CIX := -1; GENCONST(0); CIX := LCIX; PUTRLD(LASTLINE.LLPSECT,15B, %PSECT ADD RELOC\ 2*CODE.LEN-2,2*LASTLINE.LLADDR); PUTRLD(PSECT,7,0,2*CIX+2); WRITOBJ(CODE); WRITOBJ(RLD); PUTGSD ( '$DDTDF ', 2750B (*GBL,D*), 2*DCIX+2); PUTGSD ( '$DDTDF ',GLOBALDEFFLAGS,0); DATASIZE := DATASIZE + 2000; END; IF NFILES = 0 THEN GENSUBRCALL ( EXITN ) ELSE GENSUBRCALL ( EXITP ); END ELSE BEGIN IF ONSWITCH['D'] THEN BEGIN GEN2(MOV,INDEX,MP,INDEX,GP); GENCONST(-6); GENCONST(2); (* LINE NUMBER *) END; GEN2(MOV,AUTDEC,MP,REG,MP); GEN2(ADD,AUTINC,PC,REG,SP); GENCONST(LLC1 - LCMAX); %RETURN FROM BODY INSTRUCTIONS\ GEN1(RTS,REG,PC); END; I := -LCMAX - 2; DATASIZE := DATASIZE + I; IF TESTPACKED THEN INSERT(CIX1,I DIV 2) %NUMBER OF WORDS\ ELSE INSERT(CIX1,I); FSTLABP := FLABP ; IF CODE.LEN > 1 THEN WRITOBJ ( CODE ) ; IF RLD.LEN > 1 THEN WRITOBJ ( RLD ) ; PSECTDEF ( PSECT, 2*CIX+2 ) ; CIXX := CIXX + CIX + 1 ; IF ( FPROCP = NIL ) OR ( SY = PERIOD ) THEN BEGIN IF FPROCP = NIL THEN BEGIN WHILE EXTFILE <> NIL DO BEGIN IF NOT EXTFILE^.DECL THEN BEGIN ERROR(931); IF LIST THEN WRITELN('FILE ',EXTFILE^.NAME,' NOT USED') END; EXTFILE:=EXTFILE^.NEXT END; IF ONSWITCH['D'] THEN PUTGSD ( 'PAS$IN ',GLOBALDEFFLAGS,2*EPMAIN) ELSE PUTGSD ( PSECT, 1400B (* TRANSFER ADDRESS *), 2*EPMAIN ) ; PUTGSD('$$FSR1 ', 2754B (*GBL,D,OVR*), NFILES*528 ); IF OFFSWITCH['D'] THEN BEGIN PSECT := '$HEAP '; NEWMODULE; DATASIZE := DATASIZE + 200; PUTGSD('999999 ',PSECTDEFFLAGS, DATASIZE ); PUTGSD('$$HEAP ',GLOBALDEFFLAGS,0); END; END; WRITOBJ ( GSD ) ; GSD.VALUE [ 1 ] := 2 % EGSD \ ; WRITOBJ ( GSD ) ; GSD.VALUE [ 1 ] := 6 % EM \ ; WRITOBJ ( GSD ) ; END ELSE IF GSD.LEN > 1 THEN WRITOBJ ( GSD ) ; CIX := OLDCIX ; PSECT := OLDPSECT ; GLOBALINDEX := OLDGLOBALINDEX ; END % LEAVE BODY \; (*$Y+*) (* MODULE SPLITTING AGAIN *) (* MNC - SEE PREV TWO NEW PROCEDURES FOR MISSING CODE. ALLOWS HEAVIER OVER- LAYING. ALSO NOTE THAT LOOP STATEMENT AROUND THE CALL TO PROCEDURE STATEMENT HAS BEEN REMOVED. PROCEDURE STATEMENT IS NOW BEING ASKED TO CALL COMPOUNDSTATEMENT WHICH WILL PROCESS THE BEGIN,END PAIR WHICH SURROUND THE PROCEDURE BODY. HAVING BODY CALL STATEMENT ONLY ONCE SPEEDS UP HUGPAS AND BIGPAS GREATLY BY REDUCING OVERLAY SWPNG. NOTE ALSO REQUIRED CHANGE TO PROCEDURE BLOCK: *) BEGIN % BODY \ ENTERBODY; STATEMENT(FSYS OR [SEMICOLON,ENDSY]); LEAVEBODY; END % BODY \ ; (*$Y+*) (* NEW MODULE *) BEGIN %BLOCK\ HEAPMARK(HEAPM); TESTPACKED := ONSWITCH['D']; FLABP := FSTLABP; DP := TRUE; IF NOT MAIN AND (LEVEL = 1) THEN FSYS := FSYS OR [PERIOD]; OLDPSECT := PSECT; IF FPROCP <> NIL THEN IF FPROCP^.EXTNAME <> NIL THEN PSECT := FPROCP^.EXTNAME^ ELSE PSECT := FPROCP^.NAME; OLDCIX := CIX ; CIX := -1 ; OLDGLOBALINDEX := GLOBALINDEX ; REPEAT IF NOT (SY IN BLOCKBEGSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END; IF SY = LABELSY THEN BEGIN INSYMBOL; LABELDECLARATION END; IF SY = CONSTSY THEN BEGIN INSYMBOL; CONSTDECLARATION END; IF SY = TYPESY THEN BEGIN INSYMBOL; TYPEDECLARATION END; IF SY = VARSY THEN BEGIN INSYMBOL; VARDECLARATION END; WHILE SY IN [PROCEDURESY,FUNCTIONSY] DO BEGIN LSY := SY; INSYMBOL; PROCEDUREDECLARATION(LSY) END; IF (SY <> BEGINSY) AND (MAIN OR (LEVEL > 1)) OR ((SY <> PERIOD) AND NOT MAIN AND (LEVEL = 1)) THEN BEGIN ERROR(18); SKIP(FSYS) END UNTIL (SY IN STATBEGSYS) OR ((SY = PERIOD) AND NOT MAIN AND (LEVEL = 1)); DP := FALSE; IF MAIN OR ( LEVEL > 1 ) THEN BEGIN (* MNC - NOTE CHANGE IN FOLLOWING LINE TO ALLOW PROCEDURE COMPOUNDSTMT TO PROCESS THE BEGIN,END OF A PROCEDURE BODY. SEE PREVIOUS MNC COMMENT AT BODY OF PROCEDURE BODY: *) IF SY <> BEGINSY THEN ERROR(17); REPEAT BODY(FSYS OR [CASESY, FSY]); IF ( SY <> FSY ) AND ( SY <> PERIOD ) THEN BEGIN ERROR(6); SKIP(FSYS OR [FSY]) END UNTIL (SY = FSY) OR (SY IN BLOCKBEGSYS) OR (SY = PERIOD); END % IF MAIN OR LEVEL > 1 \ ELSE IF SY <> PERIOD THEN ERROR(183); HEAPRELEASE(HEAPM); %DELETE LOCAL ENTRIES IN THE RUNTIME ''HEAP''\ END %BLOCK\ ; PROCEDURE PROGRAMHEADING (*$Y+*) ; VAR CP: CTP; GLOBALSIZE: ADDRRANGE; FILEINX: 0..4; HEAD,READY,READING,PARMLIST: BOOLEAN; FILES: ARRAY [1..4] OF ALFA; OLDID: ALFA; FILEP: EXTFILEP; BEGIN INSYMBOL; GLOBALSIZE := DAPADDR + 2*MAXFILES + 6 % SPACE FOR LUNTAB AND TTY IOSB \ ; MAIN := MAIN AND NOT OFFSWITCH['M'] OR ONSWITCH['M']; DEBUG := DEBUG AND NOT OFFSWITCH['D'] OR ONSWITCH['D']; WARNINGS := WARNINGS AND NOT OFFSWITCH['W'] OR ONSWITCH['W']; CONDCOMP := CONDCOMP AND NOT OFFSWITCH['X'] OR ONSWITCH['X']; FREQUENCE := FREQUENCE AND NOT OFFSWITCH['Q'] OR ONSWITCH['Q']; EXTFILE := NIL; IF DEBUG THEN ONSWITCH['D'] := TRUE ELSE OFFSWITCH['D'] := TRUE; IF FREQUENCE THEN ONSWITCH['Q'] := TRUE ELSE OFFSWITCH['Q'] := TRUE; IF MAIN THEN BEGIN FILES[1] := 'INPUT '; FILES[2] := 'OUTPUT '; FILES[3] := 'TTY '; HEAD := FALSE; OLDID := ID; INPUTPTR := NIL; OUTPUTPTR := NIL; TTYINPTR := NIL; TTYOUTPTR := NIL; IF (SY = IDENT) AND (ID = 'PROGRAM ') THEN HEAD := TRUE; IF HEAD THEN INSYMBOL ELSE ERROR(920); IF HEAD AND (SY = IDENT) THEN BEGIN PSECT := ID; PROGNAME := ID; INSYMBOL END ELSE IF HEAD THEN ERROR(2); PARMLIST := SY = LPARENT; IF NOT HEAD OR PARMLIST OR FREQUENCE OR ONSWITCH['D'] THEN BEGIN READING := PARMLIST; IF READING THEN INSYMBOL ELSE ID := FILES[2]; % ONLY INPUT AND OUTPUT ARE DEFAULT IF NO PROGRAMHEADING \ LOOP IF ID = 'INPUT ' THEN FILEINX := 1 ELSE IF ID = 'OUTPUT ' THEN FILEINX := 2 ELSE IF ID = 'TTY ' THEN FILEINX := 4 ELSE FILEINX := 0; IF FILEINX = 0 THEN BEGIN NEW(FILEP); FILEP^.DECL:=FALSE; FILEP^.NAME:=ID; FILEP^.NEXT:=EXTFILE; EXTFILE := FILEP; END ELSE REPEAT NEW(CP,VARS); WITH CP^ DO BEGIN NAME := ID; IDTYPE := TEXTPTR; SELFCTP := 0; VKIND := ACTUAL; NEXT := NIL; GLOBALSIZE := GLOBALSIZE + FILESIZECORR + TEXTBUFFSIZE + 4; IF FILEINX > 2 THEN GLOBALSIZE := GLOBALSIZE - FDBSIZE ELSE NFILES := NFILES + 1; VADDR := GLOBALSIZE - 2; ENTERID(CP); CASE FILEINX OF 1: INPUTPTR := CP; 2: OUTPUTPTR := CP; 3: TTYINPTR := CP; 4: TTYOUTPTR := CP END; FILEINX := FILEINX - 1; ID := 'TTYIN '; END % WITH CP^ \ ; UNTIL FILEINX < 3; KK := 10; (* ID IS CHANGED *) IF READING THEN INSYMBOL; READY := (HEAD AND (SY <> COMMA)) OR (NOT HEAD AND (FILEINX = 0)); IF READY AND ONSWITCH['D'] THEN IF TTYINPTR = NIL THEN BEGIN READY := FALSE; READING := FALSE; FILEINX := 3; END ELSE IF OUTPUTPTR = NIL THEN BEGIN READY := FALSE; READING := FALSE; FILEINX := 2; END; IF READY AND FREQUENCE AND (OUTPUTPTR=NIL) THEN BEGIN READY := FALSE; READING := FALSE; FILEINX := 2; END; EXIT IF READY; IF READING THEN INSYMBOL ELSE ID := FILES[FILEINX]; END %LOOP\ ; IF NOT HEAD THEN ID := OLDID ELSE ID := ' '; IF PARMLIST THEN IF SY <> RPARENT THEN ERROR(4) ELSE INSYMBOL; END % IF LPARENT\ ; IF HEAD THEN IF SY <> SEMICOLON THEN ERROR(14) ELSE INSYMBOL; END % IF MAIN \ ; DATASIZE := GLOBALSIZE ; EXTSET := EXTSET AND NOT OFFSWITCH['E'] OR ONSWITCH['E']; FLTSET := FLTSET AND NOT OFFSWITCH['G'] OR ONSWITCH['G']; FPPUNIT:=FPPUNIT AND NOT OFFSWITCH['F'] OR ONSWITCH['F']; LIST := LIST AND NOT OFFSWITCH['L'] OR ONSWITCH['L']; PSECTGEN := PSECTGEN AND NOT OFFSWITCH['Y'] OR ONSWITCH['Y']; HEAPCHECK := HEAPCHECK AND NOT OFFSWITCH['T'] OR ONSWITCH['T']; RUNTMCHECK := RUNTMCHECK AND NOT OFFSWITCH['R'] OR ONSWITCH['R']; EXTSET := EXTSET OR FLTSET OR FPPUNIT ; TRACE := TRACE AND NOT OFFSWITCH['S'] OR ONSWITCH['S']; IF FREQUENCE OR TRACE OR DEBUG THEN BEGIN HEAPCHECK := TRUE; ONSWITCH['T'] := TRUE END; IF DEBUG THEN BEGIN PSECTGEN := FALSE; OFFSWITCH['Y'] := TRUE; ONSWITCH['Y'] := FALSE; END; OFFSWITCH['D'] := NOT ONSWITCH['D']; OFFSWITCH['Q'] := NOT ONSWITCH['Q']; LASTLINE.LLADDR := 0; LASTLINE.LLPSECT := PSECT; IF FREQUENCE THEN ONSWITCH['Q'] := TRUE; IF DEBUG THEN LC := -502 %WORKING SPACE FOR DEBUGGER\; END % PROGRAMHEADING \ ; PROCEDURE ENTERSTANDARD (*$Y+*) ; VAR CP,CP1: CTP; I: INTEGER; LVP: CSP; SP: STP; NA: ARRAY [1..58] OF ALFA; VAL: ARRAY [0..8] OF INTEGER; BEGIN % ENTER STANDARD TYPES \ %**********************\ % INITPROCEDURE \ %STANDARDNAMES\ BEGIN NA[ 1] := 'FALSE '; NA[ 2] := 'TRUE '; NA[ 3] := 'INPUT '; NA[ 4] := 'OUTPUT '; NA[ 5] := 'GET '; NA[ 6] := 'PAGE '; NA[ 7] := 'PUT '; NA[ 8] := 'BREAK '; NA[ 9] := 'RESET '; NA[10] := 'REWRITE '; NA[11] := 'READ '; NA[12] := 'READLN '; NA[13] := 'WRITE '; NA[14] := 'WRITELN '; NA[15] := 'NEW '; NA[16] := 'MARK '; NA[17] := 'RELEASE '; NA[18] := 'HALT '; NA[19] := 'PACK '; NA[20] := 'UNPACK '; NA[21] := 'DATE '; NA[22] := 'TIME '; NA[23] := 'ABS '; NA[24] := 'SQR '; NA[25] := 'TRUNC '; NA[26] := 'ODD '; NA[27] := 'ORD '; NA[28] := 'CHR '; NA[29] := 'PRED '; NA[30] := 'SUCC '; NA[31] := 'EOF '; NA[32] := 'EOLN '; NA[33] := 'IORESULT '; NA[34] := 'ROUND '; NA[35] := 'RUNTIME '; NA[36] := 'SPLITREAL '; NA[37] := 'TWOPOW '; NA[38] := 'SIN '; NA[39] := 'COS '; NA[40] := 'ARCTAN '; NA[41] := 'EXP '; NA[42] := 'LN '; NA[43] := 'SQRT '; NA[44] := 'SIZE '; NA[45] := 'ALFALENG '; NA[46] := 'MAXINT '; NA[47] := 'MININT '; NA[48] := 'MAXREAL '; NA[49] := 'SMALLREAL '; NA[50] := 'MINREAL '; NA[51] := 'RANDOM '; NA[52] := 'UPDATE '; NA[53] := 'APPEND '; NA[54] := 'TEMPORARY '; NA[55] := 'INSERT '; NA[56] := 'SHARED '; NA[57] := 'SPOOL '; NA[58] := 'BLOCK '; VAL[0] := 10; VAL[1] := 32767; VAL[2] := 100000B; VAL[3] := 077777B; VAL[4] := 032400B; VAL[5] := 000001B; VAL[6] := 177777B; VAL[7] := 000000B; VAL[8] := 000000B; END %STANDARDNAMES\ ; %TYPE UNDERLIEING:\ NEW(INTPTR,SCALAR,STANDARD); %INTEGER\ INTPTR^.SIZE := 2; INTPTR^.SELFSTP := 0; NEW(REALPTR,SCALAR,STANDARD); %REAL\ REALPTR^.SIZE := 4; REALPTR^.SELFSTP := 0; NEW(CHARPTR,SCALAR,STANDARD); %CHAR\ CHARPTR^.SIZE := 2; CHARPTR^.SELFSTP := 0; NEW(BOOLPTR,SCALAR,DECLARED); %BOOLEAN\ BOOLPTR^.SIZE := 2; BOOLPTR^.SELFSTP := 0; NEW(NILPTR,POINTER); %NIL\ WITH NILPTR^ DO BEGIN ELTYPE := NIL; SIZE := 2; SELFSTP := 0; END; BEGIN NEW(TEXTPTR,FILES); %TEXT\ WITH TEXTPTR^ DO BEGIN FILTYPE := CHARPTR; SIZE := 2; SELFSTP := 0 END; END; % ENTER STANDARD NAMES \ %**********************\ NEW(CP,TYPES); %INTEGER\ WITH CP^ DO BEGIN NAME := 'INTEGER '; IDTYPE := INTPTR END; ENTERID(CP); NEW(CP,TYPES); %REAL\ WITH CP^ DO BEGIN NAME := 'REAL '; IDTYPE := REALPTR END; ENTERID(CP); NEW(CP,TYPES); %CHAR\ WITH CP^ DO BEGIN NAME := 'CHAR '; IDTYPE := CHARPTR END; ENTERID(CP); NEW(CP,TYPES); %BOOLEAN\ WITH CP^ DO BEGIN NAME := 'BOOLEAN '; IDTYPE := BOOLPTR END; ENTERID(CP); NEW(CP,KONST); %NIL\ WITH CP^ DO BEGIN NAME := 'NIL '; IDTYPE := NILPTR; NEXT := NIL; VALUES.IVAL := 0 END; ENTERID(CP); IF DEFLEVEL >= 2 THEN BEGIN NEW(CP,TYPES); WITH CP^ DO BEGIN NAME := 'TEXT '; IDTYPE := TEXTPTR; END; ENTERID(CP); FOR I := 0 TO 5 DO BEGIN NEW(CP,KONST); %ALFALENG\ WITH CP^ DO BEGIN NAME := NA[I+45]; NEXT := NIL; IF I < 3 THEN BEGIN IDTYPE := INTPTR; VALUES.IVAL := VAL[I] END ELSE BEGIN IDTYPE := REALPTR; (*$Z+*) NEW(CP1,KONST); (*SOLVE PROBLEM WITH NEW(LVP)*) (*$Z-*) NEW(LVP,REEL); LVP^.HEAD := VAL[I]; LVP^.TAIL := VAL[I+3]; VALUES.VALP := LVP; END; END; ENTERID(CP); END; END; IF DEFLEVEL >= 3 THEN BEGIN NEW(IOSPECPTR,SCALAR,DECLARED); IOSPECPTR^.SIZE := 2; NEW(CP,TYPES); WITH CP^ DO BEGIN NAME := 'IOSPEC '; IDTYPE := IOSPECPTR; END; ENTERID ( CP ); CP1 := NIL; FOR I := 0 TO 7 DO BEGIN NEW( CP,KONST ); WITH CP^ DO BEGIN NAME := NA[I+51]; IDTYPE := IOSPECPTR; NEXT := CP1; VALUES.IVAL := I; END; ENTERID( CP ); CP1 := CP; END; IOSPECPTR^.FCONST := CP; END % IF DEFLEVEL >= 3 \ ; IF DEFLEVEL >= 2 THEN BEGIN NEW( SP,SUBRANGE ); WITH SP^ DO BEGIN SIZE := 2; SELFSTP := 0; RANGETYPE := CHARPTR; MIN.IVAL := 0; MAX.IVAL := 127; END; NEW( CP,TYPES ); WITH CP^ DO BEGIN NAME := 'ASCII '; IDTYPE := SP; SELFCTP := 0; END; NEW( SP,SUBRANGE ); SP^ := CP^.IDTYPE^; SP^.MAX.IVAL := 255; NEW( CP1,TYPES ); WITH CP1^ DO BEGIN NAME := 'BYTE '; IDTYPE := SP; SELFCTP := 0; END; ENTERID( CP ); ENTERID( CP1 ); END % IF DEFLEVEL >= 2 \; CP1 := NIL; FOR I := 1 TO 2 DO BEGIN NEW(CP,KONST); %FALSE,TRUE\ WITH CP^ DO BEGIN NAME := NA[I]; IDTYPE := BOOLPTR; NEXT := CP1; VALUES.IVAL := I - 1 END; ENTERID(CP); CP1 := CP END; BOOLPTR^.FCONST := CP; FOR I := 5 TO 22 DO IF (I<18) OR (DEFLEVEL>=1) THEN BEGIN NEW(CP,PROC,STANDARD); %GET,GETLN,PUT,PUTLN,RESET\ WITH CP^ DO %REWRITE,READ,READLN,WRITE,WRITELN,\ BEGIN NAME := NA[I]; IDTYPE := NIL; %NEW,MARK,RELEASE\ NEXT := NIL; KEY := I - 4; %SETCONTENTS\ END; %MARK,RELEASE\ ENTERID(CP) END; FOR I := 23 TO 44 DO IF (I<36) OR (DEFLEVEL>=1) THEN BEGIN NEW(CP,FUNC,STANDARD); WITH CP^ DO BEGIN NAME := NA[I]; IDTYPE := NIL; NEXT := NIL; KEY := I - 22; END; ENTERID(CP); END; NEW(CP,VARS); %PARAMETER OF PREDECLARED FUNCTIONS\ WITH CP^ DO BEGIN NAME := ' '; IDTYPE := REALPTR; VKIND := ACTUAL; NEXT := NIL; VLEV := 1; VADDR := 0 END; % ENTER UNDECLARED \ %******************\ NEW(UTYPPTR,TYPES); WITH UTYPPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL END; NEW(UCSTPTR,KONST); WITH UCSTPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; NEXT := NIL; VALUES.IVAL := 0 END; NEW(UVARPTR,VARS); WITH UVARPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; VKIND := ACTUAL; NEXT := NIL; VLEV := 0; VADDR := 0 END; NEW(UFLDPTR,FIELD); WITH UFLDPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; NEXT := NIL; FLDADDR := 0 END; NEW(UPRCPTR,PROC,DECLARED,ACTUAL); WITH UPRCPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; DECLPLACE := INTERNAL; NEXT := NIL; EXTNAME := NIL; PFLEV := 0; PFADDR :=0; END; NEW(UFCTPTR,FUNC,DECLARED,ACTUAL); WITH UFCTPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; NEXT := NIL; DECLPLACE := INTERNAL; EXTNAME := NIL; PFLEV := 0; PFADDR := 0; END (* ADJUST INPUT ETC BECAUSE PRORAMHEADING IS CALLED BEFORE ENTERST *) IF INPUTPTR <> NIL THEN INPUTPTR^.IDTYPE := TEXTPTR; IF OUTPUTPTR <> NIL THEN OUTPUTPTR^.IDTYPE := TEXTPTR; IF TTYINPTR <> NIL THEN TTYINPTR^.IDTYPE := TEXTPTR; IF TTYOUTPTR <> NIL THEN TTYOUTPTR^.IDTYPE := TEXTPTR; WITH DISPLAY[1] DO BEGIN FNAME := NIL; OCCUR := BLCK END; TOP := 1; LEVEL := 1; CIXX := CIX; END %ENTERUNDECL\ ; PROCEDURE OPENFILES (*$Y+*) ; BEGIN %ENTER STANDARD NAMES AND STANDARD TYPES:\ %****************************************\ RTIME := RUNTIME; LEVEL := 0; TOP := 0; WITH DISPLAY[0] DO BEGIN FNAME := NIL; OCCUR := BLCK END; READFILEIDENTIFIER ( DEFLEVEL, PAGEWIDTH, LINEWIDTH, ONSWITCH, OFFSWITCH, MCRLINE, MCRLEN, MCRINX, FILENAME, PDP11OBJ, (*$Z+*) OUTPUTHGH, (*$Z-*) INPUT, OUTPUT (*$Z+*) , CEX (*$Z-*) ); WTTHEAD( HEADER, DATESTR, TIMESTR ); LIST := LIST AND NOT OFFSWITCH['L'] OR ONSWITCH['L']; PRCODE := PRCODE AND NOT OFFSWITCH['C'] OR ONSWITCH['C']; END % OPENFILES \ ; PROCEDURE WRITESTAT; BEGIN IF ERRDETECTED THEN WRITE('**** E') ELSE WRITE('NO E'); WRITELN('RROR DETECTED'); WRITELN('TOTAL PROGRAM SIZE ', 2*CIXX+2:7:O); WRITELN('OUTERMOST DATA SIZE ', -LC:7:O ); WRITELN('RESERVED STACK & HEAP ', DATASIZE:7:O); WRITELN; WRITELN ( MCRLINE : MCRLEN ); END; PROCEDURE FINISH; BEGIN SRCLEVEL := -1; ENDOFLINE; IF LIST THEN WRITELN; RTIME := RUNTIME - RTIME; IF LIST THEN WRITESTAT; WTTSTAT( ERRDETECTED, 2*CIXX+2, DATASIZE, -LC, RTIME ); END; (* FINISH *) (*$Y+*) (* NEW MODULE *) BEGIN INITTABLES; INIT2; %OPEN COMPILER FILES\ %*******************\ OPENFILES; %COMPILE:\ %********\ PROGRAMHEADING ; ENTERSTANDARD ; BLOCK(BLOCKBEGSYS OR STATBEGSYS - [CASESY],PERIOD,NIL); FINISH; END (*$Y+*) (* HEAP IN SEPARATE MODULE *) .