%$W-,X+\ %$R-\ %********************************************************* * * * * * 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 * * * * MODIFIED: BY GERRY PELLETIER * * TRANSPORT CANADA * * TRANSPORT CANADA BUILDING * * PLACE DE VILLE * * OTTAWA, ONTARIO, CANADA * * * *********************************************************\ CONST CVERSION = ' 5.312 '; DISPLIMIT = 20; MAXADDR = 32767; MAXSTRGUB = 77; %MAXIMUM STRINGLENGTH = 78\ STARTADDR = 00000B; CIXMAX = 32767; CODEMAX = 32767; ALFALENG = 10; OPTIONCONSTR = '$' ; SRCNESTMAX = 3 % MAX 3 LEVELS OF SROURCE CODE NESTING \; 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.\ 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 = 25 ; GBLDFMAX = 30 ; PSECTDEFFLAGS = 2450B ; GLOBALDEFFLAGS = 2150B ; GLOBALREFFLAGS = 2100B ; RELOCFCN = 6 ; % GLOBAL ADDITIVE DISPLACED 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, 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 = ^ CONSTANT; CONSTANT = RECORD SELFCSP: INTEGER; NOCODE: INTEGER; CASE 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: (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, 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, 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; LINNR: INTEGER 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 \ 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 ; %COUNTERS:\ %*********\ RTR: RUNTIMEROUTS; %RUNTIMEROUTINECOUNTER\ 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\ 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; VERSION, 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: 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: 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[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[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[NEG] := 'NEG'; MN[HALT] := 'HLT'; MN[TRAP] := 'TRP'; MN[EMT] := 'EMT'; MN[RTI] := 'RTI' END %INSTRMNEMONICS\ (*$Z-*) END; % INITTABLES \ PROCEDURE INITTB; (*$Y+ SEPERATE MODULE *) BEGIN % 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( 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] := 7; STRECSIZE[TAGFWITHID] := 6; STRECSIZE[TAGFWITHOUTID] := 7; PAGEEJECT := FALSE; POINTERCNT := 0; CIX := -1 ; GLOBALINDEX := 0 ; DCIX := -1; PSECT := '.MAIN. '; OBJIDENT := ' '; CXPOPENED := 100000B<0 %TRUE FOR PDP 11\ ; FIRSTMODULE := TRUE; DP := TRUE; PRTERR := TRUE; ERRINX := 0; KK := ALFALENG; CH := ' '; LC := -2; CHCNT := 0; LINENO := 1; PAGENO := 0; LINECNT := 1; VERSION := CVERSION 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; % INITTB \ 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; 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] := NEQM; ARRT[NEOP,TRUE ,TRUE] := NEQM2; ARRT[EQOP,FALSE,FALSE] := EQUM; ARRT[EQOP,FALSE,TRUE] := EQUM2; ARRT[EQOP,TRUE ,FALSE] := EQUM; ARRT[EQOP,TRUE ,TRUE] := EQUM2; 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: 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+ SPLIT MODULES *) PROCEDURE NEWPAGE; BEGIN PAGENO := PAGENO + 1; PAGE(OUTPUT); WRITELN( 'PASCAL PDP-11 VERSION ',VERSION,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; PROCEDURE COPYSTP ( SP: STP ); EXTERN; PROCEDURE COPYCTP ( CP: CTP ); 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- SAME MODULE *) 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 LOOP READLN; EXIT IF NOT EOF(INPUT); IF SRCLEVEL > 0 THEN WITH SRCNEST[SRCLEVEL] DO BEGIN UNSAVEFDB ( INPUT,FDB ); FILENAME := FNAME; SRCLEVEL := SRCLEVEL - 1; LINENO := LINNR; NEWPAGE END ELSE BEGIN WRITELN('***** EOF *****'); ERRMES ( 4 % AND EXIT \ ); END END; LINENO := LINENO + 1; IF LIST THEN WRITE( LINENO:5,' '); END ELSE IF LIST THEN BEGIN WRITE(' ':20); CHCNT := CHCNT + 12; END; END %ENDOFLINE\ ; PROCEDURE ERROR(FERRNR: INTEGER); (*$Y- SAME MODULE *) 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; %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; (*$Y- SAME MODULE AS ERROR *) 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 %FORM FEED\ 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 (* ELSE *) END; PROCEDURE OPTIONS; (*$Y+ NEW MODULE *) VAR LCH: CHAR; B: BOOLEAN; 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; 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 := B; 'H': BEGIN SELECTOR := 0; NEXTCH; ONSWITCH['H'] := TRUE; WHILE CH IN DIGITS DO BEGIN SELECTOR := SELECTOR*10 + ORD(CH) - ORD('0'); NEXTCH; 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; SAVEFDB ( FDB, INPUT, FILENAME ); IF FDB[-19] = 0 THEN BEGIN FILENAME := FNAME; SRCLEVEL := SRCLEVEL - 1; END ELSE BEGIN PAGEEJECT := TRUE; LINENO := 0; END END END; 'Y': PSECTGEN := B ; 'Z': IF B AND NOT CONDCOMP THEN BEGIN OLDLIST := LIST; LIST := FALSE; REPEAT WHILE CH <> OPTIONCONSTR 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 IF SCALE < 0 THEN BEGIN SCALE := -SCALE; SIGN := TRUE END ELSE SIGN := FALSE; FAC := 10E0 ; R := 1E0 ; % OVERFLOW OR UNDERFLOW CAN OCCUR HERE \ 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 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 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- SAME MODULE *) %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); (*$Y- SAME MODULE *) 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); (*$Y-*) %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 := 0; FMAX := 377B 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+ SPLIT MODULES *) 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\ ; (*$Y- DONT SPLIT MODULES *) 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 COMPTYPES := FSP1^.FORM <> BOUNDLESS 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 := SUCC(POINTERCNT); COMPTYPES := COMPTYPES(FSP1^.ELTYPE,FSP2^.ELTYPE); POINTERCNT := PRED(POINTERCNT); 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\ ; (*$Y- DONT SPLIT THESE MODULES *) PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP); 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; 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 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); IF DISPL > MAXSIZE THEN MAXSIZE := DISPL; WHILE LSP3 <> NIL DO BEGIN LSP4 := LSP3^.SUBVAR; LSP3^.SUBVAR := LSP2; LSP3^.SIZE := DISPL; 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 PACKFLAG := SY = PACKEDSY ; IF PACKFLAG THEN BEGIN INSYMBOL; IF NOT (SY IN TYPEDELS) THEN BEGIN ERROR(10); SKIP(FSYS OR TYPEDELS) END END; %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 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 (AELTYPE = CHARPTR) OR ((AELTYPE^.FORM = SUBRANGE) AND (AELTYPE^.RANGETYPE = CHARPTR)) THEN % PACK CHARACTERS ONE PER BYTE \ 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); 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 := 0; IF (LMIN < 0) OR (LMAX = 0) OR (LMAX >= 64) THEN ERROR(604); IF LMAX <= 15 THEN SIZE := 2 ELSE SIZE := 8 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); WRITELN; REPEAT WRITELN(' TYPE-ID ',FWPTR^.NAME); FWPTR := FWPTR^.NEXT UNTIL FWPTR = NIL; IF NOT EOLN(INPUT) THEN WRITE(' ':CHCNT + 8) END END %TYPEDECLARATION\ ; PROCEDURE VARDECLARATION (*$Y+*) ; VAR LCP,NXT: CTP; LSP: STP; LSIZE: ADDRRANGE; 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 LSIZE := LSP^.FILTYPE^.SIZE; VADDR := VADDR - LSIZE; % ALLOCATE SPACE FOR RECORD BUFFER \ LC := LC-FILESIZECORR-LSIZE; IF LSP^.FILTYPE = CHARPTR THEN LC := LC - TEXTBUFFSIZE 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); 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); (*$Y+*) BEGIN IF NOT ERRFOUND THEN BEGIN ERRFOUND := TRUE; ERROR(ERRORNO) END; SKIP(STOPSYS) END; % PSERROR\ (*$Y- SAME MODULE *) BEGIN % PARAMETERSPECIFICATION \ 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 %PARAMTRLIST\ 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 % SY IS NOT FUNCTION OR PROCEDURE \ 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 % SY IS NOT STRING \ 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 INSYMBOL 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 = 'ALTX ' THEN DECLPLACE := EXTERNALTX ELSE 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 \ ; (*$Y- DONT SPLIT THESE MODULES *) 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 := ' '; 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 DOT = 7 THEN FCP^.EXTNAME := NIL ELSE BEGIN NEW(FCP^.EXTNAME); FCP^.EXTNAME^ := SLOW; END; END % FINDEXTNAME \; (*$Y+*) (* SPLIT MODULES AGAIN *) BEGIN %PROCEDUREDECLARATION\ PARLC := 0; LLC := LC; IF ONSWITCH['D'] THEN LC := -4 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\ ; PROCEDURE BODY(FSYS: SETOFSYS); VAR I: INTEGER; CIX1: CODERANGE ; LCMAX,LLC1,ADDR: ADDRRANGE; LCP: CTP; LLP: LBP; INTRPT: BOOLEAN; PROCEDURE WRITOBJ ( VAR REC: OBJECTRECORD ) ; BEGIN IF NOT OFFSWITCH['K'] THEN WRITOFILE( REC, PDP11OBJ (*$Z+*) , OUTPUTHGH (*$Z-*) ) ELSE REC.LEN := 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 PUTGR50 ( R50N1,R50N2,FLAGS,FVAL: INTEGER ) ; BEGIN WITH GSD DO BEGIN IF LEN > 17 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 > 17 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 = 21 THEN BEGIN WRITOBJ ( CODE ) ; IF RLD.LEN > 1 THEN WRITOBJ ( RLD ) ; END ; WITH CODE DO BEGIN IF LEN = 1 THEN BEGIN 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(OPCODE: INSTRRANGE; MODE, REGISTER: INTEGER); VAR BYTE: PACKED ARRAY[0..3] OF CHAR; BEGIN INCCIX; WITH CODE DO BEGIN VALUE [ LEN ] := INSTRVAL[OPCODE] + MODE + REGISTER ; (*$Z+*) IF PRCODE THEN BEGIN IF OPCODE < CLR THEN BYTE := 'B ' ELSE BYTE := ' '; WRITE(CEX,2*CIX:6:O,' ',VALUE[LEN]:6:O,MN[OPCODE]:10,BYTE); WRITEREG(MODE,REGISTER); WRITELN(CEX) END (*$Z-*) END END; %GEN1\ PROCEDURE GEN2(OPCODE: INSTRRANGE; SRCMODE, SRCREG, DSTMODE, DSTREG: INTEGER); VAR BYTE: PACKED ARRAY[0..3] OF CHAR; BEGIN INCCIX; WITH CODE DO BEGIN VALUE [ LEN ] := INSTRVAL[OPCODE] + 64 * (SRCMODE + SRCREG) + DSTMODE + DSTREG ; (*$Z+*) IF PRCODE THEN BEGIN IF OPCODE < CLR THEN BYTE :='B ' ELSE BYTE:=' '; WRITE(CEX,2*CIX:6:O,' ',VALUE[LEN]:6:O,MN[OPCODE]:10,BYTE); WRITEREG(SRCMODE,SRCREG); WRITE(CEX,','); WRITEREG(DSTMODE,DSTREG); WRITELN(CEX) END (*$Z-*) 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,REG,PC,INDEX,GP); 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 - 3; 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 ADDTOP (I:INTEGER); (* GENERATE CODE TO ADD A CONSTANT TO TOP OF STACK *) BEGIN IF I <> 0 THEN BEGIN GEN2 (ADD,AUTINC,PC,REGDEF,SP); GENCONST (I) END END; 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 ) ; 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 > 19 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); BEGIN LOAD; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> BOOLPTR THEN ERROR(144); GEN1(TST,AUTINC,SP); IF (LADDR <> 0) AND (CIX - LADDR <= 126) THEN GENBR(BEQ,LADDR - CIX - 2) %BACKWARD JUMP WITH OFFSET <= 128\ ELSE BEGIN GENBR(BNE, 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: ADDTOP (IDPLMT); PACKD: END; EXPR: ERROR(616) END; KIND := VARBL; IF ACCESS <> PACKD THEN BEGIN ACCESS := INDRCT; IDPLMT := 0 END END END; %LOADADDRESS\ (*$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\ (*$Y- DONT SPLIT THESE MODULES *) PROCEDURE EXPRESSION(FSYS: SETOFSYS); FORWARD; PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP); 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\ IF TYPTR = CHARPTR THEN 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 { SUBSTRING OF A CHAR ARRAY } THEN BEGIN IF AELTYPE <> CHARPTR THEN ERROR(615); LSP1 := INXTYPE; IF LSP1 <> NIL THEN GETBOUNDS(INXTYPE,LMIN,LMAX); END ELSE { SUBSTRING OF A STRINGPARM } BEGIN LSP1 := INTPTR; 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); { COMPUTE SUBSTR LENGTH } GEN2(SUB,REGDEF,SP,REG,R); GEN1(INC,REG,R); IF FORM = ARRAYS THEN { SUBSTR OF ARRAY } BEGIN GEN2(ADD,AUTINC,SP,REGDEF,SP); { ALTER ADDRESS } GEN2(MOV,REG,R,AUTDEC,SP) { LOAD LENGTH } END ELSE { SUBSTR OF STRINGPARM } BEGIN GEN2(ADD,AUTINC,SP,INDEX,SP); { ALTER ADDRESS } GENCONST(2); GEN2(MOV,REG,R,REGDEF,SP) { ALTER LENGTH } END; 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; %COMPARES SET SIZES AND \ %CHECKS IF CONVERSIONS ARE NECESSARY\ VAR %AND CALLS THE CONVERSION ROUTINES\ L1,L2: INTEGER; RTR: RUNTIMEROUTS; 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 % L1 <> L2 \ BEGIN IF L1 > L2 THEN IF GATTR.KIND = VARBL THEN BEGIN L1 := 2; RTR := REDSN END ELSE RTR := EXPST ELSE % L1 < L2 \ IF FATTR.KIND = VARBL THEN RTR := REDST ELSE BEGIN L1 := 8; RTR := EXPSN END; GENSUBRCALL(RTR); END; GATTR.TYPTR^.SIZE := L1 ; 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 (LKEY IN [1,5,7,8,11,12,13]) AND (FILECP = TTYOUTPTR) THEN FILECP := TTYINPTR; END ELSE (* FILECP = NIL *) 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) ; CASE LKEY OF 11: LDISPL := EOFSTATUS; 12: LDISPL := EOLNSTATUS; 13: LDISPL := IORESULT END; IF FILECP <> NIL THEN BEGIN SELECTOR ([SY],FILECP); LOADADDRESS; (* IF THIS FILE IS A FORMAL PARAMETER THEN THE ACTUAL FILE, AS SUPPLIED BY THE CALLER, CAN BE TTY. SO, WE HAVE TO DO A RUNTIME CONVERSION TO TTYIN FOR INPUT TYPE FUNCTIONS. *) IF (FILECP^.VKIND = FORMAL) AND (LKEY IN [1,5,7,8,11,12,13]) THEN GENSUBRCALL (TTPAR); (* GET ACTUAL VALUE OF EOF, EOLN AND IORESULT *) IF LKEY >= 11 THEN BEGIN GEN2( MOV,AUTINC,SP,REG,AD ); GEN2( MOV,INDEX,AD,AUTDEC,SP ); GENCONST( LDISPL ) END; IF SY = COMMA THEN INSYMBOL 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 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 IF GATTR.TYPTR^.FORM <> STRINGPARM THEN ERROR(116); END ELSE (* ARGUMENT IS ABSENT *) 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 (* GET, PUT *) 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]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM = STRINGPARM THEN GENSUBRCALL(RDSTR) ELSE (* VARIABLE IS NOT STRINGPARM *) BEGIN LOADADDRESS; IF COMPTYPES( FILECP^.IDTYPE^.FILTYPE, GATTR.TYPTR) AND NOT COMPTYPES( GATTR.TYPTR,CHARPTR) THEN BEGIN IF GATTR.TYPTR^.FORM = ARRAYS THEN ADDTOP (GATTR.TYPTR^.ADDRCORR); GENSUBRCALL ( RDREC ) END ELSE IF STRING ( GATTR.TYPTR ) THEN BEGIN ADDTOP (GATTR.TYPTR^.ADDRCORR); GETBOUNDS (GATTR.TYPTR^.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) END; (* NOT STRINGPARM *) 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 THEN LOAD ELSE IF LSP^.FORM <> STRINGPARM THEN IF GATTR.KIND = EXPR THEN %MULTIPLE FUNCTIONRESULT ON STACK IS ACTUAL PARAMETER\ BEGIN GEN2(MOV,REG,SP,AUTDEC,SP); STACKD := TRUE END ELSE BEGIN LOADADDRESS; IF LSP^.FORM = ARRAYS THEN ADDTOP (LSP^.ADDRCORR) 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); IF STACKD THEN BEGIN GEN2(ADD,AUTINC,PC,REG,SP); GENCONST(LSP^.SIZE) %REMOVE FUNCTIONRESULT FROM STACK\ END 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; 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); 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\ ; { ASSIGN CURRENT HEAP BASE ADDRESS TO POINTER VARIABLE } 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); { EXPAND HEAP } 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 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 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; 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; (*$Y- DONT SPLIT THESE MODULES *) 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 % CALLNONSTANDARD \ 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 % NXT^.KLASS NOT IN [PROC,FUNC] \ 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(399); 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); ADDTOP (LMIN); GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(LMAX-LMIN+1); END END ELSE % GATTR.KIND = EXPR \ IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> STRINGPARM THEN ERROR(617) END ELSE % LSP^.FORM <> STRINGPARM \ IF GATTR.KIND = VARBL THEN 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+*) ; (* FOR LKEY DEFINITIONS, SEE ENTERSTANDARD *) 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+*) (* SPLIT MODULES *) 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); (*$Y- SAME MODULE *) 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 IF (KADDR = 0) OR (DISX <> TOP) THEN BEGIN LOADSTRINGCONSTANT; IF DISX = TOP THEN KADDR := 2 * CIX - 4 - IDTYPE^.SIZE END ELSE BEGIN GEN2(MOV,REG,PC,AUTDEC,SP); GEN2(SUB,AUTINC,PC,REGDEF,SP); GENCONST(2 * CIX - KADDR); %HYPOTHETICAL ADDRESS OF STRINGCONSTANT ON THE STACK\ END; IF SY = LBRACK THEN BEGIN SELECTOR(FSYS,NIL); LOAD END END END ELSE (* VARS OR FIELD *) SELECTOR(FSYS,LCP); (* REDUCE SUBRANGE TYPES TO THEIR CORRESPONDING RANGE TYPES. NOTE THAT THIS IS ALSO DONE TO FUNCTION RESULTS. *) IF GATTR.TYPTR <> NIL THEN WITH GATTR, TYPTR^ DO 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 BEGIN ERROR(604); RANGEPART := FALSE END ELSE IF SY = COLON THEN BEGIN RANGEPART := TRUE; LRMIN := I END ELSE IF RANGEPART THEN BEGIN WHILE LRMIN <= I DO BEGIN CSTPART := CSTPART OR [LRMIN]; LRMIN := SUCC(LRMIN) END; RANGEPART := FALSE END ELSE (* NUMBER IS LEGAL AND NOT PART OF A SUBRANGE *) CSTPART := CSTPART OR [I] 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 %*\ MUL: 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; %/\ 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; %AND\ ANDOP: IF (LATTR.TYPTR = BOOLPTR) AND (GATTR.TYPTR = BOOLPTR) 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 BEGIN ERROR(134); GATTR.TYPTR := NIL END END %CASE\ ELSE GATTR.TYPTR := NIL END %WHILE\ END %TERM\ ; BEGIN %SMPLEEXPRESSION\ 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]); IF (GATTR.KIND = CST) AND (LOP IN [PLUS,MINUS]) AND (GATTR.TYPTR=INTPTR) AND (LATTR.TYPTR=INTPTR) THEN { USE IMMEDIATE INSTRUCTION } BEGIN IF GATTR.CVAL.IVAL = 1 THEN { CAN USE INC/DEC } IF LOP = PLUS THEN GEN1(INC,REGDEF,SP) ELSE GEN1(DEC,REGDEF,SP) ELSE { CONSTANT IS NOT 1 } BEGIN { USE IMMEDIATE ADD/SUB } IF LOP = PLUS THEN GEN2(ADD,AUTINC,PC,REGDEF,SP) ELSE GEN2(SUB,AUTINC,PC,REGDEF,SP); GENCONST (GATTR.CVAL.IVAL) END; GATTR.KIND := EXPR END ELSE { USE NORMAL STACK INSTRUCTIONS } BEGIN LOAD { VALUE OF SECOND OPERAND } ; IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN CASE LOP OF %+\ PLUS: 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; %-\ 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; %OR\ OROP: IF (LATTR.TYPTR = BOOLPTR) AND (GATTR.TYPTR = BOOLPTR) 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 BEGIN ERROR(134); GATTR.TYPTR := NIL; END END %CASE\ ELSE { EITHER GATTR.TYPTR OR LATTR.TYPTR IS NIL } GATTR.TYPTR := NIL END { ELSE } 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 ADDTOP (GATTR.TYPTR^.ADDRCORR) 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 ADDTOP (GATTR.TYPTR^.ADDRCORR) 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 (* RECALL THAT SUBRANGE TYPES HAVE BEEN REDUCED TO SCALARS. SEE PROCEDURE FACTOR (CASE OF IDENT). *) 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) THEN BEGIN C := TRUE % CHAR IN SET MUST BE REL SPACE \ ; SMIN := 0; SMAX := SMAX - 40B; END ELSE C := FALSE; B := ((SMAX = 0) OR (SMAX > 15)); %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 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 ADDTOP (GATTR.TYPTR^.ADDRCORR) 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 ADDTOP (GATTR.TYPTR^.ADDRCORR) 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)) 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; 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 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 END; 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); GENUJP(LADDR); 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+*) ; BEGIN EPMAIN := (CIX + 1); LLC1 := 0 ; GENSUBRCALL( INITA ) ; 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; IF ONSWITCH['D'] THEN BEGIN GEN2(MOV,AUTINC,PC,INDEX,GP); GENCONST(0); PUTRLD('$DDTDF ',RELOCFCN,2*CODE.LEN-2,2*DCIX+2); GENCONST(-6); COPYCTP( DISPLAY[0].FNAME ); GEN2( MOV,AUTINC,PC,INDEX,GP); GENCONST(0); PUTRLD('$DDTDF ',RELOCFCN,2*CODE.LEN-2,2*INTPTR^.SELFSTP); GENCONST(-8); GEN2 ( MOV,AUTINC,PC,INDEX,GP ); GENCONST(0); PUTRLD('$DDTDF ',RELOCFCN,2*CODE.LEN-2,2*REALPTR^.SELFSTP); GENCONST(-10); GEN2 ( MOV,AUTINC,PC,INDEX,GP ); GENCONST(0); PUTRLD('$DDTDF ',RELOCFCN,2*CODE.LEN-2,2*CHARPTR^.SELFSTP); GENCONST(-12); 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; BEGIN IF PSECTGEN OR FIRSTMODULE THEN NEWMODULE; { FOR THE MAIN PROGRAM, GENERATE OBJECT CODE TO CAUSE } { THE SETTING UP OF THE FCS FILE STORAGE REGION BY THE } { TASK BUILDER. THIS CODE IS EQUIVALENT TO: } { } { .PSECT $$FSR1 GBL,OVR,D } { .GLOBAL .FSRCB ; TO BRING IN FCSFSR } { F.BFHD == 20 ; TO ENABLE ACTFIL OPTION } IF FPROCP = NIL THEN { MAIN PROGRAM } BEGIN PUTGSD ('$$FSR1 ', 2754B {PSECT NAME}, 0); PUTGSD ('.FSRCB ', 2100B {SYMBOL REF}, 0); PUTGSD ('F.BFHD ', 2110B {SYMBOL DEF}, 20B); WRITOBJ (GSD) END; 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-*) IF FPROCP <> NIL THEN WITH FPROCP^ DO BEGIN PFADDR := 2 * (CIX + 1); LLC1 := PARLISTSIZE; GLOBALDEF ( PSECT, PFADDR ) ; END %WITH FPROCP\ ELSE STARTOFMAIN; 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 GEN2 ( MOV,AUTINC,PC,INDEX,MP ); GENCONST(0); IF DISPLAY[TOP].FNAME <> NIL THEN PUTRLD('$DDTDF ',RELOCFCN,2*CODE.LEN-2,2*DCIX+2); GENCONST(-4); COPYCTP( DISPLAY[TOP].FNAME ) END; IF HEAPCHECK THEN BEGIN LINENODEF; GENSUBRCALL(OVFLCHK); END; IF ONSWITCH['D'] AND (FPROCP = NIL) THEN GENSUBRCALL ( DDTINIT ); LCMAX := LC; END % ENTERBODY \; PROCEDURE LEAVEBODY; BEGIN IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13); 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); WRITELN; WRITELN(' LABEL ',LABVAL) 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; GENSUBRCALL ( EXITP ); END ELSE BEGIN 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 PUTGSD ( PSECT, 1400B (* TRANSFER ADDRESS *), 2*EPMAIN ) ; PSECT := '$HEAP '; IF PSECTGEN THEN NEWMODULE; DATASIZE := DATASIZE + 200; PUTGSD('999999 ',PSECTDEFFLAGS, DATASIZE ); PUTGSD('$$HEAP ',GLOBALDEFFLAGS,0); 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 *) BEGIN % BODY \ ENTERBODY; LOOP REPEAT STATEMENT(FSYS OR [SEMICOLON,ENDSY]) UNTIL NOT (SY IN STATBEGSYS); EXIT IF SY <> SEMICOLON; INSYMBOL; END; LEAVEBODY; END % BODY \ ; (*$Y+*) (* NEW MODULE *) BEGIN %BLOCK\ HEAPMARK(HEAPM); TESTPACKED := FALSE; 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)) 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 IF SY = BEGINSY THEN INSYMBOL ELSE ERROR(17); REPEAT BODY(FSYS OR [CASESY]); 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+*) ; TYPE STANDARDFILES = ( TTY, TTYIN, INPUT, OUTPUT ); VAR CP: CTP; GLOBALSIZE: ADDRRANGE ; HEAD: BOOLEAN ; FILES: ARRAY[STANDARDFILES] OF ALFA ; THISFILE: STANDARDFILES ; GIVENFILES: SET OF STANDARDFILES ; BEGIN INSYMBOL ; % GET FIRST SYMBOL \ (* SENSE SWITCHES THAT MUST BE AT START OF PROGRAM *) MAIN := MAIN AND NOT OFFSWITCH['M'] OR ONSWITCH['M']; IF DEBUG THEN ONSWITCH['D'] := TRUE ELSE OFFSWITCH['D'] := TRUE; IF FREQUENCE THEN ONSWITCH['Q'] := TRUE ELSE OFFSWITCH['Q'] := TRUE; GLOBALSIZE := DAPADDR + 2*MAXFILES + 6 ; % SPACE FOR LUNTAB ETC. \ FILES[TTY] := 'TTY ' ; FILES[TTYIN] := 'TTYIN ' ; FILES[INPUT] := 'INPUT ' ; FILES[OUTPUT] := 'OUTPUT ' ; INPUTPTR := NIL ; OUTPUTPTR := NIL ; TTYINPTR := NIL ; TTYOUTPTR := NIL ; GIVENFILES := [] ; IF MAIN THEN BEGIN IF (SY=IDENT) AND (ID='PROGRAM ') THEN BEGIN HEAD := TRUE ; INSYMBOL ; IF SY = IDENT THEN BEGIN PSECT := ID ; INSYMBOL END ELSE ERROR (2) END ELSE % MAIN PROGRAM WITH NO PROGRAM STATEMENT \ BEGIN HEAD := FALSE ; ERROR (920); GIVENFILES := [INPUT,OUTPUT] %DEFAULT FILES\ END ; IF HEAD AND (SY=LPARENT) THEN BEGIN INSYMBOL ; LOOP IF ID = FILES[TTY] THEN GIVENFILES := GIVENFILES OR [TTY,TTYIN] ELSE IF ID = FILES[INPUT] THEN GIVENFILES := GIVENFILES OR [INPUT] ELSE IF ID = FILES[OUTPUT] THEN GIVENFILES := GIVENFILES OR [OUTPUT] ELSE ERROR (23) ; INSYMBOL ; EXIT IF SY <> COMMA ; INSYMBOL END %LOOP\ ; IF SY <> RPARENT THEN ERROR(4) ELSE INSYMBOL END %IF LPARENT\ ; IF HEAD THEN IF (SY = SEMICOLON) THEN INSYMBOL ELSE ERROR(14) ; IF HEAD THEN ID := ' ' END %IF MAIN\ ELSE % NOT MAIN \ (* DECLARE FILES ACCESSIBLE TO SEPARATLY COMPILED PROCEDURE *) GIVENFILES := [TTY,TTYIN] ; FOR THISFILE := TTY TO OUTPUT DO % TTY AND TTYIN MUST BE FIRST \ IF THISFILE IN GIVENFILES THEN BEGIN NEW ( CP, VARS ) ; WITH CP^ DO BEGIN NAME := FILES[THISFILE] ; IDTYPE := TEXTPTR ; VKIND := ACTUAL ; NEXT := NIL ; SELFCTP := 0 ; GLOBALSIZE := GLOBALSIZE + FILESIZECORR + TEXTBUFFSIZE + 4 ; IF THISFILE IN [TTY,TTYIN] THEN GLOBALSIZE := GLOBALSIZE - FDBSIZE ; VADDR := GLOBALSIZE - 2 END %WITH\ ; ENTERID (CP) ; CASE THISFILE OF TTY: TTYOUTPTR := CP ; TTYIN: TTYINPTR := CP ; INPUT: INPUTPTR := CP ; OUTPUT: OUTPUTPTR := CP END END %IF THISFILE..\ ; DATASIZE := GLOBALSIZE ; IF FREQUENCE AND (OUTPUTPTR = NIL) THEN ERROR(930); 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']; PRCODE := PRCODE AND NOT OFFSWITCH['C'] OR ONSWITCH['C']; LIST := LIST AND NOT OFFSWITCH['L'] OR ONSWITCH['L']; WARNINGS := WARNINGS AND NOT OFFSWITCH['W'] OR ONSWITCH['W']; PSECTGEN := PSECTGEN AND NOT OFFSWITCH['Y'] OR ONSWITCH['Y']; CONDCOMP := CONDCOMP AND NOT OFFSWITCH['X'] OR ONSWITCH['X']; HEAPCHECK := HEAPCHECK AND NOT OFFSWITCH['T'] OR ONSWITCH['T']; FREQUENCE := FREQUENCE AND NOT OFFSWITCH['Q'] OR ONSWITCH['Q']; 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['S'] := NOT ONSWITCH['S']; OFFSWITCH['Q'] := NOT ONSWITCH['Q']; LASTLINE.LLADDR := 0; LASTLINE.LLPSECT := PSECT; IF FREQUENCE THEN ONSWITCH['Q'] := TRUE; IF DEBUG THEN LC := -202 %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 %TYPE UNDERLIEING:\ % 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] := ALFALENG; 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\ ; 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; END %ENTERUNDECL\ ; PROCEDURE OPENFILES (*$Y+*) ; BEGIN READFILEIDENTIFIER( DEFLEVEL, PAGEWIDTH, LINEWIDTH, ONSWITCH, OFFSWITCH, MCRLINE, MCRLEN, FILENAME, PDP11OBJ, (*$Z+*) OUTPUTHGH, (*$Z-*) INPUT, OUTPUT (*$Z+*) , CEX (*$Z-*) ) ; END % OPENFILES \ ; PROCEDURE WRITESTAT; (*$Y-*) BEGIN IF ERRDETECTED THEN WRITE('**** ') ELSE WRITE('NO '); WRITELN('ERROR 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; (*$Y+*) (* NEW MODULE *) BEGIN (* MAIN PROGRAM *) INITTABLES; INITTB; INIT2; %ENTER STANDARD NAMES AND STANDARD TYPES:\ %****************************************\ RTIME := RUNTIME; LEVEL := 0; TOP := 0; WITH DISPLAY[0] DO BEGIN FNAME := NIL; OCCUR := BLCK END; %OPEN COMPILER FILES\ %*******************\ OPENFILES; LIST := LIST AND NOT OFFSWITCH['L'] OR ONSWITCH['L']; %WRITE HEADER\ %************\ WTTHEAD( VERSION, DATESTR, TIMESTR ); IF LIST THEN BEGIN NEWPAGE; WRITELN; IF ONSWITCH['C'] OR PRCODE THEN BEGIN WRITELN('INSTRUCTIONCOUNT'); WRITELN('-LOCATIONCOUNT'); WRITE('-000002 '); LINECNT := 3; END; WRITE ( LINENO:5, ' ':3 ); END; %COMPILE:\ %********\ PROGRAMHEADING ; ENTERSTANDARD ; WITH DISPLAY[1] DO BEGIN FNAME := NIL; OCCUR := BLCK END; TOP := 1; LEVEL := 1; CIXX := CIX; BLOCK(BLOCKBEGSYS OR STATBEGSYS - [CASESY],PERIOD,NIL); SRCLEVEL := -1; ENDOFLINE; WRITELN; RTIME := RUNTIME - RTIME; IF LIST THEN WRITESTAT; WTTSTAT( ERRDETECTED, 2*CIXX+2, DATASIZE, -LC, RTIME ); END (*$Y+*) (* HEAP IN SEPARATE MODULE *) .