{********************************************************* * * * * * 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 * * * * Recent revisions by: * * Gerry Pelletier * * PRIOR Data Sciences Ltd. * * Bell Mews Plaza - Nepean * * 39 Highway 7 * * Ottawa, Ontario K2H 8R2 * * 613-820-7235 * * Telex: 053-3356 * * * *********************************************************} {$V+850810 REVISION DATE } {$W- NO WARNINGS } {$X- DONT COMPILE CONDITIONAL CODE } { IF X+ THEN ALL CODE RELATED TO PRODUCTION AND OUTPUT OF SYMBOLIC OBJECT CODE FOR THE CXP FILE WILL BE COMPILED. ALSO THE PARAMETERS OF PACK AND UNPACK CALLS WILL BE VERIFIED. NOTE THAT P11FIL.PAS MUST BE COMPILED WITH THE SAME X SWITCH AS USED HERE. } {$R- NO RUNTIME CHECKS } CONST DISPLIMIT = 20; MAXADDR = 32767; MAXSTRGUB = 77; { MAXIMUM STRINGLENGTH = 78 } STARTADDR = 00000B; CIXMAX = 32767; CODEMAX = 32767; ALFALENG = 10; OPTIONCONSTR = '$' ; SRCNESTMAX = 3 { MAX 3 LEVELS OF SOURCE CODE NESTING (INCLUDES) }; { SIZES AND OFFSETS RELATED THE FILE VARIABLE STRUCTURE. } TEXTBUFFSIZE = 132 { BYTES } ; FILESIZECORR = 104 { BYTES } ; FDBSIZE = 96 { BYTES } ; EOLNSTATUS = -8; { EOLN: BOOLEAN } EOFSTATUS = -6; { EOF: BOOLEAN } IORESULT = -4 { IORESULT:INTEGER } ; { ADDRESSES OF SOME HIDDEN GLOBAL VARIABLES. } { THESE ARE LOCATED THROUGH A POSITIVE OFFSET FROM GP } { AND THEREFORE RESEMBLE PARAMETERS TO THE MAIN PROG. } DAPDDT = 12; MARKDDT = 10; DAPADDR = 8; MARKADDR = 6; LINEADDR = 2; { THE RUNTIME LUN TABLE IS ALSO A HIDDEN GLOBAL VARIABLE. } { IT IS MAXFILES+1 WORDS LONG } MAXFILES = 16 ; HIDDENLEN = 50 ; { LENGTH IN BYTES OF ALL HIDDEN GLOBAL VARIABLES } { INCLUDING THE LUN TABLE. } { 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 ADRESSING MODES } REG = 0; REGDEF = 8; AUTINC = 16; AUTDEC = 32; AUTINCDEF = 24; AUTDECDEF = 40; INDEX = 48; INDEXDEF = 56; OBJECTRECSIZE = 46 ; GBLDFMAX = 30 ; PSECTDEFFLAGS = 2450B ; GLOBALDEFFLAGS = 2150B ; GLOBALREFFLAGS = 2100B ; { OBJECT RECORD ENTRIES: } GADRENTRY = 6 ; { GLOBAL ADDITIVE DISPLACED RELOCATION } GARENTRY = 5; { GLOBAL ADDITIVE RELOCATION } TYPE %DESCRIBING:\ %***********\ %BASIC SYMBOLS\ %*************\ INSTRRANGE = (CLRB,MOVB,CMPB,CLR,DEC,INC,NEG,TST,COM,ASL,ASR,HALT, JMP,JSR,SOB,XOR,MULT,DIVV,TRAP,EMT,MOV,ADD,SUB,CMP,BVS,BVC, BIS,BIT,BIC,BR,BEQ,BNE,BGE,BGT,BLE,BLT,BPL,BMI,BLOS,BHIS, RTI,RTS) ; SYMBOL = (IDENT,INTCONST,REALCONST,STRINGCONST,NOTSY,MULOP,ADDOP,RELOP, LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON,PERIOD,ARROW, COLON,BECOMES,LABELSY,CONSTSY,TYPESY,VARSY,LOCALSY,FUNCTIONSY, PROCEDURESY,SETSY,PACKEDSY,ARRAYSY,RECORDSY,FILESY,FORWARDSY, BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY,LOOPSY, GOTOSY,EXITSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY, THENSY,OTHERSY,DEFAULTSY,EXTERNALSY); OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,GEOP,GTOP, NEOP,EQOP,INOP,NOOP); SETOFSYS = SET OF SYMBOL; BOOLARR = PACKED ARRAY ['A'..'Z'] OF BOOLEAN; %CONSTANTS\ %*********\ CSTCLASS = (REEL,PSET,STRG); CSP = ^ CONSTNT; CONSTNT = RECORD SELFCSP: INTEGER; NOCODE: BOOLEAN; CASE CCLASS: CSTCLASS OF %CCLASS NEVER SET NORE TESTED\ REEL: (HEAD,TAIL: INTEGER; RVAL: REAL); PSET: (PVAL: SET OF 0..63); STRG: (SLGTH: 0..MAXSTRGUB; SVAL: ARRAY [0..MAXSTRGUB] OF CHAR) END; VALU = RECORD CASE BOOLEAN OF %INTVAL NEVER SET NORE TESTED\ TRUE: (IVAL: INTEGER); FALSE: (VALP: CSP) END; %DATA STRUCTURES\ %***************\ LEVRANGE = 0..MAXADDR; ADDRRANGE = -MAXADDR..MAXADDR; STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES, BOUNDLESS,TAGFWITHID,TAGFWITHOUTID,VARIANT,STRINGPARM); DECLKIND = (STANDARD,DECLARED); STP = ^ STRUCTURE; CTP = ^ IDENTIFIER; INTP = ^ INTEGER; STRUCTURE = PACKED RECORD SELFSTP: INTEGER; NOCODE: BOOLEAN; SIZE: ADDRRANGE; CASE FORM: STRUCTFORM OF SCALAR: (CASE SCALKIND: DECLKIND OF DECLARED: (FCONST: CTP)); SUBRANGE: (RANGETYPE: STP; MIN,MAX: VALU); POINTER: (ELTYPE: STP); POWER: (ELSET: STP); ARRAYS: (AELTYPE,INXTYPE: STP; ADDRCORR: INTEGER; PACKOPT: BOOLEAN); RECORDS: (FSTFLD: CTP; RECVAR: STP; PACKSTRUCT: BOOLEAN); FILES: (FILTYPE: STP); BOUNDLESS:(SUBSTRUCT,INDEXTYPE: STP; UNSPECLEVEL: INTEGER); TAGFWITHID, TAGFWITHOUTID:(FSTVAR: STP; CASE BOOLEAN OF TRUE: (TAGFIELDP: CTP); FALSE: (TAGFIELDTYPE: STP)); VARIANT: (FIRSTFIELD: CTP; NXTVAR,SUBVAR: STP; VARVAL: VALU) END; %NAMES\ %*****\ IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC); SETOFIDS = SET OF IDCLASS; IDKIND = (ACTUAL,FORMAL); ALFA = PACKED ARRAY [1..ALFALENG] OF CHAR; FORWARDOREXT = (INTERNAL,FORWDECL,FORWFOUND,EXTRNL, EXTERNALTX,EXTERNFORTRAN) ; CODERANGE = 0 .. CODEMAX ; ALFAP = ^ ALFA ; IDENTIFIER = PACKED RECORD SELFCTP: INTEGER; NOCODE: BOOLEAN; NAME: ALFA; LLINK, RLINK: CTP; IDTYPE: STP; NEXT: CTP; CASE KLASS: IDCLASS OF KONST: (VALUES: VALU; KADDR: CODERANGE); VARS: (VKIND: IDKIND; VLEV: LEVRANGE; VADDR: ADDRRANGE); FIELD: (FLDADDR: ADDRRANGE); PROC, FUNC: (CASE PFDECKIND: DECLKIND OF STANDARD: (KEY: 1..25); DECLARED: (PFLEV: LEVRANGE; PFADDR, PARLISTSIZE: ADDRRANGE; CASE PFKIND: IDKIND OF ACTUAL: (DECLPLACE: FORWARDOREXT; EXTNAME: ALFAP); FORMAL: (PARMLIST: CTP))) END; DISPRANGE = 0..DISPLIMIT; WHERE = (BLCK,CREC,VREC); %NAMES OF THE RUNTIMEROUTINES \ RUNTIMEROUTS = (ERRN, EQUR,NEQR,LESR,LEQR,GRTR,GEQR,ADR,SBR, EQUB,EQUB2,NEQB,NEQB2, SQRR,MPR,DVR,FLO,FLT,TRC,RND,EXITP, GRTM,GRTM2,LESM,LESM2,GEQM,GEQM2,LEQM,LEQM2, EQUM,EQUM2,EQUS4,NEQM,NEQM2,NEQS4, EQU,NEQ,GRT,GEQ,LES,LEQ, DVI,MODI,SQI,MPI, MOVM,MOVM2, WRCHA,INN,SGSIN,INITS,UNI4,INT4,DIF4, EXPST,EXPSN,REDST,REDSN, IXB,STPB,LPB,CLRAREA,CLRSTK, RDC,RDI,RDR,RDREC,WRREC,RDSTR, WRC,WRS,WRI,WRR, MARKP,RELEASEP,OVFLCHK,SUBRCHK, LEQS1,LEQS4,GEQS1,GEQS4, TRACK,FREQV,DDTINIT, GETCH,GETLINE,INITA,WRIOCT,RESETF,REWRITEF, PUTCH,PUTLINE,INITN,EXITN, BRK,FORMFD,RUNTM,TIME1,DATE1,WRB,WRBFX, GETR,PUTR,DUMP,WRFIX,FORTR,TTPAR,MOVTS, MOVFS,MOVMR,TWPOW,SPLTRL,RSIN,RCOS, RARCTAN,REXP,RLOG,RSQRT,SUBSTRCHECK, STRINGINDEX,FPINI,DUMRTR); %EXPRESSIONS\ %***********\ ATTRKIND = (CST,VARBL,EXPR); VACCESS = (DRCT, INDRCT, PACKD); ATTR = RECORD TYPTR: STP; CASE KIND: ATTRKIND OF CST: (CVAL: VALU); VARBL: (CASE ACCESS: VACCESS OF DRCT: (VLEVEL: LEVRANGE; DPLMT: ADDRRANGE); INDRCT: (IDPLMT: ADDRRANGE)) END; %LABELS\ %******\ REFLINKP = ^ REFLINK ; REFLINK = RECORD NEXTREF: REFLINKP; REFADDR: ADDRRANGE END; LBP = ^ LABL; LABL = RECORD NEXTLAB: LBP; LABVAL: INTEGER; DECLARED: BOOLEAN; CASE DEFINED: BOOLEAN OF TRUE: (LABADDR: ADDRRANGE); FALSE: (LABCHAIN: REFLINKP) END; % CODE GENERATION \ %*****************\ TEXT = FILE OF CHAR; INTFILE = FILE OF INTEGER; GBLDFRANGE = 0 .. GBLDFMAX ; OBJECTRECORD = RECORD LEN: 1..OBJECTRECSIZE ; VALUE: ARRAY [1..OBJECTRECSIZE] OF INTEGER END; TEXTFDB = ARRAY [-19..0] OF INTEGER; LINEBUFF = PACKED ARRAY [1..80] OF CHAR; STR20 = PACKED ARRAY [0..20] OF CHAR; SRCDESCR = RECORD FDB: TEXTFDB; FNAME: STR20; OLDLIST: BOOLEAN; LINNR: INTEGER END; 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:\ %*********\ VERSION: INTEGER; %VERSION NUMBER * 100, E.G. 500 == 5.00\ NFILES: INTEGER; { NUM OF FILES DECLARED IN THIS COMPILE } CIXX: INTEGER; DATASIZE, RTIME: INTEGER; { RUNTIME COUNT } 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\ OUTPUTDECLARED, { 'OUTPUT' PRESENT IN PROGRAM STATEMENT } INPUTDECLARED, { 'INPUT' PRESENT IN PROGRAM STATEMENT } TRACE, % RUNTIME TRACE OF EXECUTED STATEMENTS\ DEBUG, % DEBUG SELECTOR \ FREQUENCE, % MEASUREMENT OF STATEMENT EXECUTION FREQUENCIES\ CONDCOMP, % CONDITIONAL COMPILATION \ WARNINGS, % WARNING MESSAGES \ HEAPCHECK, %RUNTIME CHECK OF HEAP VS STACK\ CXPOPENED, %BOOKKEEPING OF CEX STATUS\ DOLLARNAME, %EXTNAMES TO BEGIN WITH DOLLAR SIGN\ RUNTMCHECK, %OUTPUT OPTIONS FOR -- SOURCE PROGRAM LISTING -- PRINTING SYMBOLIC CODE -- RUNTIME CHECKING --> PROCEDURE OPTION\ PSECTGEN, % -- PSECTION GENERATION\ FIRSTMODULE, % TO GENERATE MODULE ID \ EXTSET, FPPUNIT, % OPTIONS FOR CODEGENERATION: --EXTENDED PDP11 INSTRUCTIONSET --FLOATING POINT PROCESSOR\ FLTSET : BOOLEAN; % FLOATING POINT INSTRUCTION SET \ ONSWITCH,OFFSWITCH: BOOLARR; %POINTERS:\ %*********\ INTPTR,REALPTR,CHARPTR,IOSPECPTR, BOOLPTR,NILPTR,TEXTPTR: STP; %POINTERS TO ENTRIES OF STANDARD IDS\ INPUTPTR,OUTPUTPTR, TTYINPTR,TTYOUTPTR, %POINTERS TO STANDARD FILES\ UTYPPTR,UCSTPTR,UVARPTR, UFLDPTR,UPRCPTR,UFCTPTR, %POINTERS TO ENTRIES FOR UNDECLARED IDS\ FWPTR: CTP; %HEAD OF CHAIN OF FORW DECL TYPE IDS\ FSTLABP: LBP; %HEAD OF LABEL CHAIN\ %BOOKKEEPING OF DECLARATION LEVELS:\ %**********************************\ LEVEL: LEVRANGE; {CURRENT STATIC LEVEL} DISX, {LEVEL OF LAST ID SEARCHED BY SEARCHID} TOP: DISPRANGE; {TOP OF DISPLAY} DISPLAY: {WHERE: MEANS:} ARRAY [DISPRANGE] OF PACKED RECORD {=BLCK: ID IS VARIABLE ID} FNAME: CTP; {=CREC: ID IS FIELD ID IN RECORD WITH} CASE OCCUR: WHERE OF { CONSTANT ADDRESS} CREC: (CLEV: LEVRANGE; {=VREC: ID IS FIELD ID IN RECORD WITH} CDSPL: ADDRRANGE);{ VARIABLE ADDRESS} VREC: (VDSPL: ADDRRANGE) END; { --> PROCEDURE WITHSTATEMENT} {ERROR MESSAGES:} {***************} ERRINX: 0..10; {NR OF ERRORS IN CURRENT SOURCE LINE} ERRLIST: ARRAY [1..10] OF PACKED RECORD POS: INTEGER; NMR: 1..999 END; {EXPRESSION COMPILATION:} {***********************} GATTR: ATTR; {DESCRIBES THE EXPR CURRENTLY COMPILED} {STRUCTURED CONSTANTS:} {*********************} LETTERS, DIGITS: SET OF CHAR; CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS, STATBEGSYS,TYPEDELS: SETOFSYS; RW: ARRAY [1..39{NR. OF RES. WORDS}] OF ALFA; FRW: ARRAY [1..11{ALFALENG+1}] OF 1..40{NR. OF RES. WORDS + 1}; RSY: ARRAY [1..39{NR. OF RES. WORDS}] OF SYMBOL; SSY: ARRAY [' '..'_'] OF SYMBOL; ROP: ARRAY [1..39{NR. OF RES. WORDS}] OF OPERATOR; SOP: ARRAY [' '..'_'] OF OPERATOR; INSTRVAL: ARRAY [INSTRRANGE] OF INTEGER; RNA: ARRAY [RUNTIMEROUTS] OF PACKED ARRAY[0..4] OF CHAR; {RUNTIME NAMES} (*$Z+*) REGNAMES: ARRAY [0..7] OF PACKED ARRAY[0..1] OF CHAR; MN: ARRAY [INSTRRANGE] OF PACKED ARRAY[0..2] OF CHAR; {DISSEMBLER} (*$Z-*) ARRT : ARRAY [LTOP..EQOP,BOOLEAN,BOOLEAN] OF RUNTIMEROUTS; SCALRT : ARRAY [LTOP..EQOP,BOOLEAN] OF RUNTIMEROUTS; HEADER,TIMESTR,DATESTR: ALFA; PDP11OBJ: TEXT ; {OBJECT CODE FILE FOR PDP-11 COMPILER} (*$Z+*) OUTPUTHGH: FILE OF INTEGER; {CODE FILE IN BIN. FORMAT} CEX: FILE OF CHAR ; {CODE EXPANSION LIST FILE } (*$Z-*) FILENAME: STR20; {NAME OF INPUT FILE} MCRLINE: LINEBUFF; MCRLEN,MCRINX: INTEGER; SRCLEVEL: -1..SRCNESTMAX; SRCNEST: ARRAY [1..SRCNESTMAX] OF SRCDESCR; { DEBUG } {*******} LASTLINE: RECORD LLADDR: ADDRRANGE; LLPSECT: ALFA END; DCIX: INTEGER { POINTER IN PSECT $DDTDF }; IDRECSIZE: ARRAY [ IDCLASS ] OF INTEGER; STRECSIZE: ARRAY [ STRUCTFORM ] OF INTEGER; PROCEDURE SWITCHINIT( VAR I1,I2,I3,I4: INTEGER; VAR B1,B2,B3,B4,B5, B6,B7,B8,B9,B10,B11,B12,B13,B14: BOOLEAN ); EXTERN; PROCEDURE INIT1 ; BEGIN % INITPROCEDURE \ %RUNTIMEROUTINEMNEMONICS\ BEGIN RNA[ERRN] := 'ERRN '; RNA[EQUR] := 'EQUR '; RNA[NEQR] := 'NEQR '; RNA[LESR] := 'LESR '; RNA[LEQR] := 'LEQR '; RNA[GRTR] := 'GRTR '; RNA[GEQR] := 'GEQR '; RNA[ADR] := 'ADDR '; RNA[SBR] := 'SUBR '; RNA[SQRR] := 'SQRR '; RNA[MPR] := 'MULR '; RNA[DVR] := 'DIVR '; RNA[FLO] := 'FLO '; RNA[FLT] := 'FLT '; RNA[TRC] := 'TRC '; RNA[RND] := 'RND '; RNA[EXITP] := 'EXITP'; RNA[GRTM] := 'GRTM '; RNA[GRTM2] := 'GRTM2'; RNA[LESM] := 'LESM '; RNA[LESM2] := 'LESM2'; RNA[GEQM] := 'GEQM '; RNA[GEQM2] := 'GEQM2'; RNA[LEQM] := 'LEQM '; RNA[LEQM2] := 'LEQM2'; RNA[EQUM] := 'EQUM '; RNA[EQUM2] := 'EQUM2'; RNA[EQUS4] := 'EQUS4'; RNA[NEQM] := 'NEQM '; RNA[NEQM2] := 'NEQM2'; RNA[NEQS4] := 'NEQS4'; RNA[EQUB] := 'EQUB '; RNA[EQUB2] := 'EQUB2'; RNA[NEQB] := 'NEQB '; RNA[NEQB2] := 'NEQB2'; RNA[EQU] := 'EQU '; RNA[NEQ] := 'NEQ '; RNA[GRT] := 'GRT '; RNA[GEQ] := 'GEQ '; RNA[LES] := 'LES '; RNA[LEQ] := 'LEQ '; RNA[DVI] := 'DIVI '; RNA[MODI] := 'MODI '; RNA[SQI] := 'SQI '; RNA[MPI] := 'MULI '; RNA[MOVM] := 'MOVM '; RNA[MOVM2] := 'MOVM2'; RNA[WRCHA] := 'WRCHA'; RNA[INN] := 'INN '; RNA[SGSIN] := 'SGSIN'; RNA[INITS] := 'INITS'; RNA[UNI4] := 'UNI4 '; RNA[INT4] := 'INT4 '; RNA[DIF4] := 'DIF4 '; RNA[EXPST] := 'EXPST'; RNA[EXPSN] := 'EXPSN'; RNA[REDST] := 'REDST'; RNA[REDSN] := 'REDSN'; RNA[IXB] := 'IXB '; RNA[STPB] := 'STPB '; RNA[LPB] := 'LPB '; RNA[CLRAREA] := 'CLRAR'; RNA[CLRSTK] := 'CLRST'; RNA[RDC] := 'RDC '; RNA[RDI] := 'RDI '; RNA[RDR] := 'RDR '; RNA[RDREC] := 'RDREC'; RNA[WRREC] := 'WRREC'; RNA[RDSTR] := 'RDSTR'; RNA[WRC] := 'WRC '; RNA[WRS] := 'WRS '; RNA[WRI] := 'WRI '; RNA[WRR] := 'WRR '; RNA[MARKP] := 'MARKP'; RNA[RELEASEP] := 'RELEA'; RNA[OVFLCHK] := 'OVFLC'; RNA[SUBRCHK] := 'SUBRC'; RNA[LEQS1] := 'LEQS1'; RNA[LEQS4] := 'LEQS4'; RNA[GEQS1] := 'GEQS1'; RNA[GEQS4] := 'GEQS4'; RNA[TRACK] := 'P.TRC'; RNA[FREQV] := 'P.FRQ'; RNA[DDTINIT] := 'P.DDT'; RNA[GETCH] := 'GET '; RNA[GETLINE] := 'GETLN'; RNA[INITA] := 'INITA'; RNA[WRIOCT] := 'WROCT'; RNA[RESETF] := 'RESET'; RNA[REWRITEF] := 'REWRI'; RNA[PUTCH] := 'PUT '; RNA[PUTLINE] := 'PUTLN'; RNA[INITN] := 'INITN'; RNA[EXITN] := 'EXITN'; RNA[BRK] := 'BRK '; RNA[FORMFD] := 'PAGE '; RNA[RUNTM] := 'RUNTM'; RNA[TIME1] := 'TIME '; RNA[DATE1] := 'DATE '; RNA[WRB] := 'WRB '; RNA[WRBFX] := 'WRBFX'; RNA[GETR] := 'GETRM'; RNA[PUTR] := 'PUTRM'; RNA[DUMP] := 'DUMP '; RNA[WRFIX] := 'WRFIX'; RNA[FORTR] := 'FORTR'; RNA[TTPAR] := 'TTPAR'; RNA[MOVTS] := 'MOVTS'; RNA[MOVFS] := 'MOVFS'; RNA[MOVMR] := 'MOVMR'; RNA[TWPOW] := 'TWPOW'; RNA[SPLTRL] := 'SPTRL'; RNA[RSIN] := 'RSIN '; RNA[RCOS] := 'RCOS '; RNA[RARCTAN] := 'ARCTN'; RNA[REXP] := 'REXP '; RNA[RLOG] := 'RLOG '; RNA[RSQRT] := 'RSQRT'; RNA[SUBSTRCHECK] := 'STRCH'; RNA[STRINGINDEX] := 'STIND'; RNA[FPINI] := 'FPINI' 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'; MN[BVS] := 'BVS'; MN[BVC] := 'BVC'; MN[BLOS] := 'LOS'; MN[BHIS] := 'HIS'; END %INSTRMNEMONICS\ ; (*$Z-*) END; (* INIT1 *) PROCEDURE INIT2; (*$Y+*) VAR C: CHAR; BEGIN % INITPROCEDURE \ %INITSCALARS\ BEGIN FWPTR := NIL ; FSTLABP := NIL ; ERRDETECTED := FALSE; SRCLEVEL := 0; FOR C := 'A' TO 'Z' DO BEGIN ONSWITCH[C] := FALSE; OFFSWITCH[C]:= FALSE END; SWITCHINIT( VERSION,DEFLEVEL,PAGEWIDTH,LINEWIDTH,EXTSET,FLTSET,FPPUNIT, LIST,PRCODE,CONDCOMP,WARNINGS,RUNTMCHECK,HEAPCHECK,MAIN, PSECTGEN,TRACE,DEBUG,FREQUENCE); IDRECSIZE[TYPES] := 12; IDRECSIZE[KONST] := 14; IDRECSIZE[VARS] := 15; IDRECSIZE[FIELD] := 13; IDRECSIZE[PROC] := 19; IDRECSIZE[FUNC] := 19; STRECSIZE[SCALAR] := 6; STRECSIZE[SUBRANGE] := 7; STRECSIZE[POINTER] := 5; STRECSIZE[POWER] := 5; STRECSIZE[ARRAYS] := 8; STRECSIZE[RECORDS] := 7; STRECSIZE[FILES] := 5; STRECSIZE[BOUNDLESS] := 7; STRECSIZE[VARIANT] := 8; STRECSIZE[STRINGPARM] := 4; STRECSIZE[TAGFWITHID] := 6; STRECSIZE[TAGFWITHOUTID] := 6; PAGEEJECT := TRUE; POINTERCNT := 0; CIX := -1 ; GLOBALINDEX := 0 ; DCIX := 0; PSECT := '.MAIN. '; OBJIDENT := ' '; CXPOPENED := 100000B<0 %TRUE FOR PDP 11\ ; FIRSTMODULE := TRUE; DP := TRUE; PRTERR := TRUE; ERRINX := 0; DOLLARNAME := FALSE; KK := ALFALENG; CH := ' '; LC := -2; CHCNT := LINEWIDTH + 1; LINENO := 0; PAGENO := 0; LINECNT := 0; HEADER := ' 5.00 '; IF VERSION > 999 THEN HEADER[1] := CHR( VERSION DIV 1000 + 48 ); HEADER[2] := CHR( (VERSION DIV 100) MOD 10 + 48 ); HEADER[4] := CHR( (VERSION DIV 10) MOD 10 + 48 ); HEADER[5] := CHR( VERSION MOD 10 + 48 ); END %INITSCALARS\ ; % INITPROCEDURE \ %INITSETS\ BEGIN DIGITS := ['0','1','2','3','4','5','6','7','8','9']; LETTERS := ['A','B','C','D','E','F','G','H','I','J','K','L','M', 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z']; CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT]; SIMPTYPEBEGSYS := [ LPARENT , ADDOP , INTCONST , REALCONST , STRINGCONST , IDENT ] ; TYPEBEGSYS := [ARROW,PACKEDSY,ARRAYSY,RECORDSY,SETSY,FILESY,LPARENT,ADDOP, INTCONST,REALCONST,STRINGCONST,IDENT]; TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY]; BLOCKBEGSYS := [LABELSY,CONSTSY,TYPESY,VARSY,PROCEDURESY,FUNCTIONSY, BEGINSY]; SELECTSYS := [ARROW,PERIOD,LBRACK]; FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY]; STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,LOOPSY,FORSY,WITHSY, CASESY,LOCALSY]; END %INITSETS\ ; % INITPROCEDURE \ %RESWORDS\ BEGIN RW[ 1] := 'IF '; RW[ 2] := 'DO '; RW[ 3] := 'OF '; RW[ 4] := 'TO '; RW[ 5] := 'IN '; RW[ 6] := 'OR '; RW[ 7] := 'END '; RW[ 8] := 'FOR '; RW[ 9] := 'VAR '; RW[10] := 'DIV '; RW[11] := 'MOD '; RW[12] := 'SET '; RW[13] := 'AND '; RW[14] := 'NOT '; RW[15] := 'THEN '; RW[16] := 'ELSE '; RW[17] := 'WITH '; RW[18] := 'GOTO '; RW[19] := 'LOOP '; RW[20] := 'CASE '; RW[21] := 'TYPE '; RW[22] := 'FILE '; RW[23] := 'EXIT '; RW[24] := 'BEGIN '; RW[25] := 'UNTIL '; RW[26] := 'WHILE '; RW[27] := 'ARRAY '; RW[28] := 'LABEL '; RW[29] := 'CONST '; RW[30] := 'OTHERS '; RW[31] := 'REPEAT '; RW[32] := 'RECORD '; RW[33] := 'DOWNTO '; RW[34] := 'PACKED '; RW[35] := 'EXTERN '; RW[36] := 'FORWARD '; RW[37] := 'FUNCTION '; RW[38] := 'PROCEDURE '; RW[39] := 'OTHERWISE '; 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] := 40; 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; RSY[39] := DEFAULTSY; 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; (* INIT2 *) PROCEDURE INIT3 (*$Y+*) ; VAR RTR: RUNTIMEROUTS; 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; ROP[39] := NOOP; SOP['+'] := PLUS; SOP['-'] := MINUS; SOP['*'] := MUL; SOP['/'] := RDIV; SOP['='] := EQOP; SOP['#'] := NEOP; SOP['!'] := OROP; SOP['&'] := ANDOP; SOP['<'] := LTOP; SOP['>'] := GTOP; SOP['@'] := LEOP; SOP['"'] := GEOP; SOP[' '] := NOOP; SOP['$'] := NOOP; SOP['%'] := NOOP; SOP['('] := NOOP; SOP[')'] := NOOP; SOP[','] := NOOP; SOP['.'] := NOOP; SOP['0'] := NOOP; SOP['1'] := NOOP; SOP['2'] := NOOP; SOP['3'] := NOOP; SOP['4'] := NOOP; SOP['5'] := NOOP; SOP['6'] := NOOP; SOP['7'] := NOOP; SOP['8'] := NOOP; SOP['9'] := NOOP; SOP[':'] := NOOP; SOP[';'] := NOOP; SOP['?'] := NOOP; SOP['E'] := NOOP; SOP['F'] := NOOP; SOP['G'] := NOOP; SOP['H'] := NOOP; SOP['A'] := NOOP; SOP['B'] := NOOP; SOP['C'] := NOOP; SOP['D'] := NOOP; SOP['I'] := NOOP; SOP['J'] := NOOP; SOP['K'] := NOOP; SOP['L'] := NOOP; SOP['M'] := NOOP; SOP['N'] := NOOP; SOP['O'] := NOOP; SOP['P'] := NOOP; SOP['Q'] := NOOP; SOP['R'] := NOOP; SOP['S'] := NOOP; SOP['T'] := NOOP; SOP['U'] := NOOP; SOP['V'] := NOOP; SOP['W'] := NOOP; SOP['X'] := NOOP; SOP['Y'] := NOOP; SOP['Z'] := NOOP; SOP['['] := NOOP; SOP['\'] := NOOP; SOP[']'] := NOOP; SOP['^'] := NOOP; SOP['_'] := NOOP; SOP[''''] := NOOP; %END OPERATORS\ END; % INITPROCEDURE \ %INSTRUCTIONVALUES\ BEGIN INSTRVAL[MOVB]:=110000B; INSTRVAL[CLRB]:=105000B; INSTRVAL[CMPB]:=120000B; INSTRVAL[CLR]:=005000B; INSTRVAL[DEC]:=005300B; INSTRVAL[INC]:=005200B; INSTRVAL[NEG]:=005400B; INSTRVAL[TST]:=005700B; INSTRVAL[COM]:=005100B; INSTRVAL[ASL]:=006300B; INSTRVAL[ASR]:=006200B; INSTRVAL[JMP]:=000100B; INSTRVAL[JSR]:=004000B; INSTRVAL[SOB]:=077000B; INSTRVAL[XOR]:=074000B; INSTRVAL[MULT]:=070000B; INSTRVAL[TRAP]:=104400B; INSTRVAL[EMT]:=104000B; INSTRVAL[BR]:= 000400B; INSTRVAL[BEQ]:=001400B; INSTRVAL[BNE]:=001000B; INSTRVAL[BGE]:=002000B; INSTRVAL[BGT]:=003000B; INSTRVAL[BLE]:=003400B; INSTRVAL[BLT]:=002400B; INSTRVAL[BPL]:=100000B; INSTRVAL[BMI]:=100400B; INSTRVAL[MOV]:=010000B; INSTRVAL[ADD]:=060000B; INSTRVAL[SUB]:=160000B; INSTRVAL[CMP]:=020000B; INSTRVAL[BIS]:=050000B; INSTRVAL[BIT]:=030000B; INSTRVAL[BIC]:=040000B; INSTRVAL[RTS]:=000200B; INSTRVAL[RTI]:=000002B; INSTRVAL[BVC]:=102000B; INSTRVAL[BVS]:=102400B; INSTRVAL[BLOS]:=101400B; INSTRVAL[BHIS]:=103000B; END % INSTUCTIONVALUES \ ; TIMESTR := ' '; DATESTR := '18-OCT-76 '; FOR RTR := ERRN TO DUMRTR DO NOTCALLED[RTR] := TRUE; % INITPROCEDURE \ %ARRAYS FOR EXPRESSION: CALLS OF RUNTIMEROUTINES\ BEGIN SCALRT[LEOP,FALSE] := LEQ; SCALRT[LEOP,TRUE] := LEQR; SCALRT[GEOP,FALSE] := GEQ; SCALRT[GEOP,TRUE] := GEQR; SCALRT[GTOP,FALSE] := GRT; SCALRT[GTOP,TRUE] := GRTR; SCALRT[LTOP,FALSE] := LES; SCALRT[LTOP,TRUE] := LESR; SCALRT[EQOP,FALSE] := EQU; SCALRT[EQOP,TRUE] := EQUR; SCALRT[NEOP,FALSE] := NEQ; SCALRT[NEOP,TRUE] := NEQR; ARRT[LTOP,FALSE,FALSE] := ERRN ; ARRT[LTOP,FALSE,TRUE] := ERRN ; ARRT[LTOP,TRUE ,FALSE] := LESM ; ARRT[LTOP,TRUE ,TRUE] := LESM2; ARRT[LEOP,FALSE,FALSE] := ERRN ; ARRT[LEOP,FALSE,TRUE] := ERRN ; ARRT[LEOP,TRUE ,FALSE] := LEQM ; ARRT[LEOP,TRUE ,TRUE] := LEQM2; ARRT[GEOP,FALSE,FALSE] := ERRN ; ARRT[GEOP,FALSE,TRUE] := ERRN ; ARRT[GEOP,TRUE ,FALSE] := GEQM ; ARRT[GEOP,TRUE ,TRUE] := GEQM2; ARRT[GTOP,FALSE,FALSE] := ERRN ; ARRT[GTOP,FALSE,TRUE] := ERRN ; ARRT[GTOP,TRUE,FALSE] := GRTM ; ARRT[GTOP,TRUE ,TRUE] := GRTM2; ARRT[NEOP,FALSE,FALSE] := NEQM; ARRT[NEOP,FALSE,TRUE] := NEQM2; ARRT[NEOP,TRUE ,FALSE] := NEQB; ARRT[NEOP,TRUE ,TRUE] := NEQB2; ARRT[EQOP,FALSE,FALSE] := EQUM; ARRT[EQOP,FALSE,TRUE] := EQUM2; ARRT[EQOP,TRUE ,FALSE] := EQUB; ARRT[EQOP,TRUE ,TRUE] := EQUB2; END; % INITPROCEDURE \ % OBJECTRECORDS \ BEGIN GSD.VALUE[1] := 1 ; GSD.LEN := 1 ; RLD.VALUE[1] := 4 ; RLD.LEN := 1 ; CODE.VALUE[1] := 3 ; CODE.LEN := 1 ; END % OBJECTRECORDS \ END; (* INIT3 *) PROCEDURE WRITOFILE ( VAR REC: OBJECTRECORD ; VAR PDPOBJ: TEXT (*$Z+*) ; VAR OUTPUTHGH: INTFILE (*$Z-*) ); EXTERN; PROCEDURE READFILEIDENTIFIER( VAR FDL,FPW,PLW: INTEGER; VAR SWL,SWC: BOOLARR; VAR CML: LINEBUFF; VAR CMLLEN, CMLIX : INTEGER; VAR FILENAME: STR20 ; VAR PDPOBJ:TEXT ; (*$Z+*) VAR OUTPUTHGH: INTFILE; (*$Z-*) VAR INPUT: TEXT; VAR OUTPUT: TEXT (*$Z+*) ; VAR CODE: TEXT (*$Z-*) ); EXTERN; (*$Y+*) PROCEDURE NEWPAGE; BEGIN PAGENO := PAGENO + 1; PAGE(OUTPUT); WRITELN( 'PASCAL PDP-11 VERSION ',HEADER,DATESTR:12,' ':6,TIMESTR:8,' ':10,' PAGE ',PAGENO:3); WRITELN( FILENAME, ' ':4, OBJIDENT, ' ':4, PSECT ); WRITELN; PAGEEJECT := FALSE; LINECNT := 0; END % NEWPAGE \ ; PROCEDURE WTTERR( N: INTEGER ); EXTERN; PROCEDURE WTTINT( N: INTEGER ); EXTERN; PROCEDURE WTTEOL; EXTERN; PROCEDURE WTTSTAT( E: BOOLEAN; P,D,DD,T: INTEGER ); EXTERN; PROCEDURE WTTHEAD( VAR HDR,DAY,TIM: ALFA ); EXTERN; FUNCTION NEXTINPUT ( VAR F: TEXT; VAR CML: LINEBUFF; VAR CMLLEN, CMLIX: INTEGER; VAR FILENAME: STR20 ) : BOOLEAN; EXTERN; PROCEDURE SAVEFDB ( VAR FDB: TEXTFDB; VAR F: TEXT; VAR FN : STR20 ); EXTERN; PROCEDURE UNSAVEFDB ( VAR F: TEXT; VAR FDB: TEXTFDB ); EXTERN; PROCEDURE ERRMES ( N: INTEGER ); EXTERN; PROCEDURE HEAPMARK( VAR M: INTP ); EXTERN; PROCEDURE HEAPRELEASE( M: INTP ); EXTERN; PROCEDURE ENDOFLINE (*$Y+*); VAR LASTPOS,FREEPOS,CURRPOS,CURRNMR,F,K: INTEGER; BEGIN IF ERRINX > 0 THEN { OUTPUT ERROR MESSAGES } BEGIN WTTERR( LINENO ); { WRITE ERROR MESSAGE TO TERMINAL } 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; CHCNT := 0; IF SRCLEVEL >= 0 THEN IF EOLN(INPUT) THEN BEGIN READLN; WHILE EOF(INPUT) DO BEGIN IF SRCLEVEL > 0 THEN WITH SRCNEST[SRCLEVEL] DO BEGIN UNSAVEFDB (INPUT, FDB); FILENAME := FNAME; SRCLEVEL := SRCLEVEL - 1; IF OFFSWITCH['D'] THEN LINENO := LINNR; IF LIST THEN PAGEEJECT := TRUE; LIST := OLDLIST; READLN END ELSE { SRCLEVEL = 0 } IF NOT NEXTINPUT (INPUT, MCRLINE, MCRLEN, MCRINX, FILENAME) THEN BEGIN WRITELN ('***** EOF *****'); ERRMES ( 4 { AND EXIT } ); END END; { WHILE EOF } LINENO := LINENO + 1; END { IF EOLN } ELSE { NOT EOLN } IF LINENO = 0 THEN { FIRST LINE } LINENO := 1 ELSE { LINENO <> 0 -- CONTINUATION LINE } IF LIST THEN CHCNT := 12; IF LIST THEN BEGIN WRITELN; IF (LINECNT > PAGEWIDTH) OR PAGEEJECT THEN NEWPAGE; LINECNT := LINECNT + 1; IF PRCODE THEN IF DP THEN { DECLARATION PART } WRITE ('-',-LC:6:O,' ') ELSE WRITE (2 * CIX + 2:6:O,' '); IF CHCNT <> 0 THEN { CONTINUATION LINE } WRITE (' ':20) ELSE WRITE (LINENO:5,' ') END; END { ENDOFLINE } ; PROCEDURE ERROR (FERRNR: INTEGER) (*$Y+*) ; BEGIN IF WARNINGS OR (FERRNR < 900) THEN BEGIN IF ERRINX >= 9 THEN BEGIN ERRLIST[10].NMR := 255; ERRINX := 10 END ELSE BEGIN ERRINX := ERRINX + 1; ERRLIST[ERRINX].NMR := FERRNR END; ERRLIST[ERRINX].POS := CHCNT END END { ERROR } ; PROCEDURE INSYMBOL (*$Y+*); %READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LGTH\ LABEL 1,2; CONST DIGMAX = 9; VAR I,J,K,SCALE,EXP,IVAL: INTEGER; MANT,RVAL,R,FAC: REAL; CASECONV,STAR,SIGN,OLDLIST: BOOLEAN; DIGIT: ARRAY [1..DIGMAX] OF 0..9; STRING: ARRAY [0..MAXSTRGUB] OF CHAR; LVP: CSP; BINEXP, SGN: INTEGER; PROCEDURE NEXTCH; VAR ORDCH: 0..255; BEGIN IF EOLN(INPUT) THEN CH :=' ' ELSE BEGIN READ(CH); ORDCH := ORD(CH) ; IF ORDCH > 127 THEN BEGIN ORDCH := ORDCH - 128; CH := CHR(ORDCH) END; IF ORDCH < 32 THEN CH := ' '; IF LIST THEN BEGIN IF ORDCH = 12 %FF\ THEN PAGEEJECT := TRUE; IF ORDCH = 9 %TAB\ THEN BEGIN ORDCH := 7-CHCNT MOD 8; WRITE(' ':ORDCH); CHCNT := CHCNT + ORDCH; END; WRITE(CH); CHCNT := CHCNT+1 END; IF (ORDCH > 95) AND CASECONV THEN BEGIN IF ORDCH = 173B (* LEFT BRACE *) THEN CH := '%' ELSE IF ORDCH = 175B (* RIGHT BRACE *) THEN CH := '\' ELSE CH := CHR( ORDCH - 32 ); END; END END; (*$Y+*) PROCEDURE OPTIONS; VAR LCH: CHAR; B: BOOLEAN; VALUE: INTEGER; BEGIN REPEAT NEXTCH; LCH := CH; NEXTCH; IF NOT (CH IN ['+','-']) THEN ERROR(902) ELSE BEGIN IF LCH IN ['A'..'Z'] THEN B := (CH = '+') AND NOT OFFSWITCH[LCH] OR ONSWITCH[LCH] ELSE B := FALSE; CASE LCH OF 'C': BEGIN PRCODE := B; (*$Z+*) IF PRCODE THEN IF CXPOPENED THEN BEGIN WRITELN(CEX); WRITELN(CEX,';************'); WRITELN(CEX) END ELSE BEGIN CXPOPENED := TRUE; REWRITE(CEX,FILENAME) END (*$Z-*) END; 'E','F', 'G','M': IF B THEN ONSWITCH[LCH]:=TRUE ELSE OFFSWITCH[LCH]:=TRUE; 'P': PAGEEJECT := B; 'T': HEAPCHECK := B; 'L': LIST := B; 'V': BEGIN I := 1; NEXTCH; OBJIDENT := ' '; WHILE (CH IN LETTERS + DIGITS) AND (I < 7) DO BEGIN OBJIDENT[I] := CH; I := I + 1; NEXTCH END END; 'W': WARNINGS := B; 'S': TRACE := B; 'Q': FREQUENCE := B; 'D': DEBUG := CH = '+'; 'B': DOLLARNAME := B; 'H': BEGIN VALUE := 0; NEXTCH; WHILE CH IN DIGITS DO BEGIN VALUE := VALUE*10 + ORD(CH) - ORD('0'); NEXTCH; END; SELECTOR := VALUE; ONSWITCH['H'] := TRUE END; 'X': CONDCOMP := B; 'I': IF SRCLEVEL = SRCNESTMAX THEN ERROR ( 940 ) ELSE BEGIN SRCLEVEL := SRCLEVEL + 1; WITH SRCNEST[SRCLEVEL] DO BEGIN FNAME := FILENAME; LINNR := LINENO; OLDLIST := LIST; SAVEFDB ( FDB, INPUT, FILENAME ); IF EOF(INPUT) THEN BEGIN UNSAVEFDB ( INPUT, FDB ); FILENAME := FNAME; SRCLEVEL := SRCLEVEL - 1; ERROR(941); END ELSE BEGIN WHILE (CH<>'*') AND (CH<>'\') DO NEXTCH; LIST := LIST AND B; IF LIST THEN BEGIN PAGEEJECT := TRUE; IF OFFSWITCH['D'] THEN LINENO := 0 END END END END; 'Y': PSECTGEN := B ; 'Z': IF B AND NOT CONDCOMP THEN BEGIN OLDLIST := LIST; LIST := FALSE; REPEAT WHILE CH <> '$' DO IF EOLN(INPUT) THEN ENDOFLINE ELSE NEXTCH; NEXTCH; IF CH = 'Z' THEN BEGIN NEXTCH; CONDCOMP := CH = '-' END; UNTIL CONDCOMP; CONDCOMP := FALSE; LIST := OLDLIST END; 'R': RUNTMCHECK := B END; END; IF EOLN(INPUT) THEN ENDOFLINE; IF NOT ( CH IN ['\','*'] ) THEN NEXTCH; UNTIL CH <> ',' END %OPTIONS\ ; (*$Y+*) 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; IF CH = '%' THEN ERROR(950); { POSSIBLE UNCLOSED COMMENT } 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 + DIGITS + ['_']); IF K >= KK THEN KK := K ELSE REPEAT ID[KK] := ' '; KK := KK - 1 UNTIL KK = K; FOR I := FRW[K] TO FRW[K+1] - 1 DO IF RW[I] = ID THEN BEGIN SY := RSY[I]; OP := ROP[I]; GOTO 2 END; SY := IDENT; OP := NOOP; 2: END; '0','1','2','3', '4','5','6', '7','8','9': BEGIN SY := INTCONST; OP := NOOP; I := 0; REPEAT I := I + 1; IF I <= DIGMAX THEN DIGIT[I] := ORD(CH) - ORD('0'); NEXTCH UNTIL NOT (CH IN DIGITS); IF I > DIGMAX THEN BEGIN ERROR(203); I:= DIGMAX END; IVAL := 0; RVAL := 0; IF CH = 'B' THEN BEGIN IF (I>6) OR ((I=6) AND (DIGIT[1]>1)) THEN BEGIN ERROR(203); IVAL := 0 END ELSE FOR K := 1 TO I DO BEGIN IF DIGIT[K] > 7 THEN ERROR(204); IVAL := 8*IVAL + DIGIT[K]; END; VAL.IVAL := IVAL; NEXTCH END ELSE BEGIN SCALE := 0; IF CH = '.' THEN BEGIN NEXTCH; IF CH = '.' THEN CH := ':' ELSE IF CH = ')' THEN CH := ']' ELSE BEGIN FOR K := 1 TO I DO RVAL := RVAL*10E0+DIGIT[K]; SY := REALCONST; IF NOT (CH IN DIGITS) THEN ERROR(201) ELSE REPEAT RVAL := 10E0*RVAL + (ORD(CH) - ORD('0')); SCALE := SCALE - 1; NEXTCH UNTIL NOT (CH IN DIGITS) END END; IF CH = 'E' THEN BEGIN IF SCALE = 0 THEN BEGIN FOR K := 1 TO I DO RVAL := RVAL * 10E0 + DIGIT[K]; SY := REALCONST END; SIGN := FALSE; NEXTCH; IF CH = '+' THEN NEXTCH ELSE IF CH = '-' THEN BEGIN SIGN := TRUE; NEXTCH END; EXP := 0; IF NOT (CH IN DIGITS) THEN ERROR(201) ELSE REPEAT EXP := 10*EXP + (ORD(CH) - ORD('0')); NEXTCH UNTIL NOT (CH IN DIGITS); IF SIGN THEN SCALE := SCALE - EXP ELSE SCALE := SCALE + EXP END; IF SCALE <> 0 THEN BEGIN R := 1E0; %NOTE POSSIBLE OVERFLOW OR UNDERFLOW\ IF SCALE < 0 THEN BEGIN SIGN := TRUE; SCALE := -SCALE END ELSE SIGN := FALSE; FAC := 10E0; REPEAT IF ODD(SCALE) THEN R := R*FAC; FAC := SQR(FAC); SCALE := SCALE DIV 2 UNTIL SCALE = 0; %NOW R = 10^SCALE\ IF SIGN THEN RVAL := RVAL/R ELSE RVAL := RVAL*R END; IF SY = INTCONST THEN BEGIN IF I > 4 THEN J := 4 ELSE J := I; FOR K := 1 TO J DO IVAL := 10 * IVAL + DIGIT[K]; IF (I<5) OR (((I=5) AND (IVAL<3276)) OR ((I=5) AND (IVAL=3276) AND (DIGIT[5]<8))) THEN BEGIN IF I = 5 THEN IVAL := 10*IVAL + DIGIT[5]; VAL.IVAL := IVAL END ELSE BEGIN ERROR(203); IVAL := 0 END END ELSE BEGIN NEW(LVP,REEL); VAL.VALP := LVP; LVP^.RVAL := RVAL; BINEXP := 0; IF RVAL < 0E0 THEN BEGIN SGN := 100000B; RVAL := -RVAL END ELSE SGN := 0; IF RVAL = 0E0 THEN MANT := 0E0 ELSE BEGIN WHILE RVAL < 8388608E0 DO BEGIN RVAL := RVAL * 2E0; BINEXP := BINEXP - 1 END; WHILE RVAL > 16777216E0 DO BEGIN RVAL := RVAL/2E0; BINEXP := BINEXP + 1 END; BINEXP := BINEXP + 24; MANT := RVAL; END; IF (BINEXP < -128) OR (BINEXP > 127) THEN BEGIN ERROR(205); MANT := 0E0 END; WITH LVP^ DO BEGIN SELFCSP := 0; IF MANT = 0E0 THEN BEGIN HEAD := 0; TAIL := 0 END ELSE BEGIN TAIL := TRUNC(MANT-TRUNC(MANT/32768E0)*32768E0); HEAD := TRUNC((MANT-8388608E0)/65536E0) + 128 * (BINEXP + 128) + SGN ; IF ODD(TRUNC(MANT/32768E0)) THEN TAIL := TAIL + 100000B END; END END END END; '''': BEGIN CASECONV := FALSE ; LGTH := 0; SY := STRINGCONST; OP := NOOP; REPEAT REPEAT NEXTCH; STRING[LGTH] := CH; LGTH := LGTH + 1 UNTIL EOLN(INPUT) OR (CH = ''''); IF EOLN(INPUT) AND (CH <> '''') THEN ERROR(202) ELSE NEXTCH UNTIL CH <> ''''; LGTH := LGTH - 1; %NOW LGTH = NR OF CHARS IN STRING\ IF LGTH = 1 THEN VAL.IVAL := ORD(STRING[0]) ELSE BEGIN NEW(LVP,STRG:LGTH-1); WITH LVP^ DO BEGIN SELFCSP := 0; SLGTH := LGTH-1; FOR I := 0 TO SLGTH DO SVAL[I] := STRING[I] END; VAL.VALP := LVP END END; ':': BEGIN OP := NOOP; NEXTCH; IF CH = '=' THEN BEGIN SY := BECOMES; NEXTCH END ELSE SY := COLON END; '.': BEGIN OP := NOOP; NEXTCH; IF CH = '.' THEN BEGIN SY := COLON; NEXTCH END ELSE IF CH = ')' THEN BEGIN SY:=RBRACK; NEXTCH END ELSE SY := PERIOD END; '(': BEGIN NEXTCH; IF CH = '*' THEN BEGIN NEXTCH; IF CH = OPTIONCONSTR THEN OPTIONS; LOOP IF EOLN(INPUT) OR (CHCNT > LINEWIDTH) THEN ENDOFLINE; IF CH = '(' THEN BEGIN NEXTCH; IF CH = '*' THEN ERROR(950) { POSSIBLE UNCLOSED COMMENT } END; STAR := CH = '*'; WHILE CH = '*' DO NEXTCH EXIT IF STAR AND ( CH = ')' ) ; NEXTCH END; NEXTCH; GOTO 1; END ELSE BEGIN IF CH = '.' THEN BEGIN SY:= LBRACK; OP := NOOP; NEXTCH END ELSE BEGIN SY := LPARENT; OP := NOOP END END; END; '?','*','/','&','+','-','\', '@','"','#','=','!', ')','[',']',',',';','^','$': BEGIN SY := SSY[CH]; OP := SOP[CH]; NEXTCH END; '<','>': BEGIN SY := SSY[CH]; OP := SOP[CH]; NEXTCH; IF CH = '=' THEN BEGIN IF OP = LTOP THEN OP := LEOP ELSE OP := GEOP; NEXTCH END ELSE IF ( CH = '>' ) AND ( OP = LTOP ) THEN BEGIN OP := NEOP ; NEXTCH END END END %CASE\ END %INSYMBOL\ ; PROCEDURE ENTERID(FCP: CTP) (*$Y+*); %ENTER ID POINTED AT BY FCP INTO THE NAME-TABLE, WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS AN UNBALANCED BINARY TREE\ VAR NAM: ALFA; LCP, LCP1: CTP; LLEFT: BOOLEAN; BEGIN NAM := FCP^.NAME; FCP^.SELFCTP := 0; LCP := DISPLAY[TOP].FNAME; IF LCP = NIL THEN DISPLAY[TOP].FNAME := FCP ELSE BEGIN REPEAT LCP1 := LCP; IF LCP^.NAME = NAM THEN %NAME CONFLICT, FOLLOW RIGHT LINK\ BEGIN ERROR(101); LCP := LCP^.RLINK; LLEFT := FALSE END ELSE IF LCP^.NAME < NAM THEN BEGIN LCP := LCP^.RLINK; LLEFT := FALSE END ELSE BEGIN LCP := LCP^.LLINK; LLEFT := TRUE END UNTIL LCP = NIL; IF LLEFT THEN LCP1^.LLINK := FCP ELSE LCP1^.RLINK := FCP END; FCP^.LLINK := NIL; FCP^.RLINK := NIL END %ENTERID\ ; PROCEDURE SRCHSECTION(FCP: CTP; VAR FCP1: CTP) (*$Y+*); %TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S --> PROCEDURE PROCEDUREDECLARATION --> PROCEDURE SELECTOR\ LABEL 1; BEGIN WHILE FCP <> NIL DO IF FCP^.NAME = ID THEN GOTO 1 ELSE IF FCP^.NAME < ID THEN FCP := FCP^.RLINK ELSE FCP := FCP^.LLINK; 1: FCP1 := FCP END %SEARCHSECTION\ ; (*$Y-*) PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP); LABEL 1; VAR LCP: CTP; BEGIN DISX := TOP; WHILE DISX >= 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; DISX := DISX - 1; END; { WHILE } %SEARCH NOT SUCCSESSFUL; SUPPRESS ERROR MESSAGE IN CASE OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION --> PROCEDURE SIMPLETYPE\ IF PRTERR THEN BEGIN ERROR(104); %TO AVOID RETURNING NIL, REFERENCE AN ENTRY FOR AN UNDECLARED ID OF APPROPRIATE CLASS --> PROCEDURE ENTERUNDECL\ IF TYPES IN FIDCLS THEN LCP := UTYPPTR ELSE IF VARS IN FIDCLS THEN LCP := UVARPTR ELSE IF FIELD IN FIDCLS THEN LCP := UFLDPTR ELSE IF KONST IN FIDCLS THEN LCP := UCSTPTR ELSE IF PROC IN FIDCLS THEN LCP := UPRCPTR ELSE LCP := UFCTPTR; END; 1: FCP := LCP END %SEARCHID\ ; PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER); %GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE\ %ASSUME (FSP <> NIL) AND (FSP^.FORM <= SUBRANGE) AND (FSP <> INTPTR) AND NOT COMPTYPES(REALPTR,FSP)\ BEGIN WITH FSP^ DO IF FORM = SUBRANGE THEN BEGIN FMIN := MIN.IVAL; FMAX := MAX.IVAL END ELSE BEGIN FMIN := 0; IF FSP = CHARPTR THEN FMAX := 377B 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+*) 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-*) PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU); VAR LSP,LSP1: STP; LCP: CTP; SIGN: (NONE,POS,NEG); STEST: REAL; CS: CSP; BEGIN LSP := NIL; FVALU.IVAL := 0; IF NOT (SY IN CONSTBEGSYS) THEN BEGIN ERROR(50); SKIP(FSYS + CONSTBEGSYS) END; IF SY IN CONSTBEGSYS THEN BEGIN IF SY = STRINGCONSTSY THEN BEGIN IF LGTH = 1 THEN LSP := CHARPTR ELSE BEGIN NEW(LSP,ARRAYS); 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 { not STRINGCONSTSY } BEGIN SIGN := NONE; IF (SY = ADDOP) AND (OP IN [PLUS,MINUS]) THEN BEGIN IF OP = PLUS THEN SIGN := POS ELSE SIGN := NEG; INSYMBOL END; IF SY = IDENT THEN BEGIN SEARCHID([KONST],LCP); WITH LCP^ DO BEGIN LSP := IDTYPE; FVALU := VALUES END; IF SIGN <> NONE THEN IF LSP = INTPTR THEN BEGIN IF SIGN = NEG THEN FVALU.IVAL := -FVALU.IVAL END ELSE IF LSP = REALPTR THEN BEGIN IF SIGN = NEG THEN BEGIN NEW (CS, REEL); WITH FVALU.VALP^ DO BEGIN { Negate the new constant } CS^.SELFCSP := SELFCSP; CS^.RVAL := -RVAL; STEST := HEAD; IF (STEST>=32768.0) {CROSS COMPILOR} OR (STEST<0) THEN {PDP-11 COMPILOR} CS^.HEAD := HEAD - 100000B ELSE CS^.HEAD := HEAD + 100000B; CS^.TAIL := TAIL; END; FVALU.VALP := CS; 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 := POINTERCNT + 1; COMPTYPES := COMPTYPES(FSP1^.ELTYPE,FSP2^.ELTYPE); POINTERCNT := POINTERCNT - 1; END; POWER: COMPTYPES := COMPTYPES(FSP1^.ELSET,FSP2^.ELSET); ARRAYS: BEGIN COMP := COMPTYPES(FSP1^.AELTYPE,FSP2^.AELTYPE) AND (FSP1^.SIZE = FSP2^.SIZE); IF FSP1^.PACKOPT OR FSP2^.PACKOPT THEN BEGIN GETBOUNDS(FSP1^.INXTYPE,LMIN,LMAX); I := LMAX - LMIN; GETBOUNDS(FSP2^.INXTYPE,LMIN,LMAX); COMP := COMP AND (I = LMAX - LMIN) END %COMPATIBILITY OF PACKED STRUCTURES\ ; COMPTYPES := COMP END; %ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST BE COMPATIBLE. -- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST BE THE SAME\ RECORDS: BEGIN NXT1 := FSP1^.FSTFLD; NXT2 := FSP2^.FSTFLD; COMP := TRUE; WHILE (NXT1 <> NIL) AND (NXT2 <> NIL) DO BEGIN COMP := COMP AND COMPTYPES(NXT1^.IDTYPE,NXT2^.IDTYPE); NXT1 := NXT1^.NEXT; NXT2 := NXT2^.NEXT END; COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL) AND (FSP1^.RECVAR = NIL) AND (FSP2^.RECVAR = NIL) END; %IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE IFF NO VARIANTS OCCUR\ FILES: COMPTYPES := COMPTYPES(FSP1^.FILTYPE,FSP2^.FILTYPE); BOUNDLESS: COMPTYPES := FALSE; STRINGPARM: COMPTYPES := TRUE END %CASE\ ELSE %FSP1^.FORM <> FSP2^.FORM\ IF FSP1^.FORM = SUBRANGE THEN COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2) ELSE IF FSP2^.FORM = SUBRANGE THEN COMPTYPES := COMPTYPES(FSP1,FSP2^.RANGETYPE) ELSE BEGIN COMPTYPES := FALSE; IF FSP1^.FORM = STRINGPARM THEN BEGIN IF FSP2^.FORM = ARRAYS THEN COMPTYPES := FSP2^.AELTYPE = CHARPTR END ELSE IF FSP2^.FORM = STRINGPARM THEN IF FSP1^.FORM = ARRAYS THEN COMPTYPES := FSP1^.AELTYPE = CHARPTR END ELSE COMPTYPES := TRUE END %COMPTYPES\ ; FUNCTION STRING(FSP: STP) : BOOLEAN; BEGIN STRING := FALSE; IF FSP <> NIL THEN IF FSP^.FORM = ARRAYS THEN IF COMPTYPES(FSP^.AELTYPE,CHARPTR) THEN STRING := TRUE END %STRING\ ; PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE) (*$Y+*) ; VAR LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP; LSIZE,DISPL: ADDRRANGE; LMIN,LMAX: INTEGER; PSIZE, CORRECTION: INTEGER; PACKFLAG: BOOLEAN; PROCEDURE SIMPLETYPE(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE); VAR LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE; LCNT: INTEGER; LVALU: VALU; BEGIN FSIZE := 2; IF NOT (SY IN SIMPTYPEBEGSYS) THEN BEGIN ERROR(1); SKIP(FSYS + 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 + [COMMA,RPARENT]) THEN BEGIN ERROR(6); SKIP(FSYS + [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 + [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 ERROR(114) 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-*) PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP; VAR FFSTFLD: CTP); LABEL 1; VAR LCP,LCP1,NXT,NXT1: CTP; LSP,LSP1,LSP2,LSP3,LSP4: STP; MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU; LID: ALFA; BEGIN NXT1 := NIL; LSP := NIL; 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 + [COMMA,COLON,SEMICOLON,CASESY]) END; EXIT IF SY <> COMMA; INSYMBOL END; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); TYP(FSYS + [CASESY,SEMICOLON],LSP,LSIZE); WHILE NXT <> NXT1 DO WITH NXT^ DO BEGIN IDTYPE := LSP; FLDADDR := DISPL; IF LSP <> NIL THEN BEGIN 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; IF LSP^.FORM = FILES THEN { FILES IN RECORD } BEGIN LSIZE := LSIZE + LSP^.FILTYPE^.SIZE { SPACE FOR RECORD BUFFER } + FILESIZECORR; FLDADDR := FLDADDR + FILESIZECORR; { ADDRESS PAST FDB } IF LSP^.FILTYPE = CHARPTR THEN { TEXT FILE } BEGIN LSIZE := LSIZE + TEXTBUFFSIZE; FLDADDR := FLDADDR + TEXTBUFFSIZE; END END; END; NXT := NEXT; DISPL := DISPL + LSIZE END; NXT1 := LCP; IF SY = SEMICOLON THEN INSYMBOL END %WHILE\; NXT := NIL; WHILE NXT1 <> NIL DO WITH NXT1^ DO BEGIN LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP END; FFSTFLD := NXT; IF SY = CASESY THEN BEGIN LCP := NIL ; %POSSIBLY NO TAGFIELDIDENTIFIER\ INSYMBOL; IF SY = IDENT THEN BEGIN LID := ID; INSYMBOL; IF (SY <> COLON) AND (SY <> OFSY) THEN BEGIN ERROR(169); SKIP(FSYS + [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 + [LPARENT]); GOTO 1 END ELSE BEGIN LID := ID; INSYMBOL; IF SY <> OFSY THEN BEGIN ERROR(8); SKIP(FSYS + [LPARENT]); GOTO 1 END; END END ELSE NEW(LSP,TAGFWITHOUTID); WITH LSP^ DO BEGIN SIZE := 0; FSTVAR := NIL; SELFSTP := 0; IF FORM = TAGFWITHID THEN TAGFIELDP := NIL ELSE TAGFIELDTYPE := NIL; END; FRECVAR := LSP; ID := LID; KK := ALFALENG; %RESTAURATION\ SEARCHID([TYPES],LCP1); LSP1 := LCP1^.IDTYPE; IF LSP1 <> NIL THEN IF (LSP1^.FORM <= SUBRANGE) OR STRING(LSP1) THEN BEGIN IF COMPTYPES(REALPTR,LSP1) THEN ERROR(109) ELSE IF STRING(LSP1) THEN ERROR(399); WITH LSP^ DO BEGIN IF FORM = TAGFWITHID THEN BEGIN DISPL := DISPL + LSP1^.SIZE; TAGFIELDP := LCP; IF LCP <> NIL THEN LCP^.IDTYPE := LSP1; END ELSE TAGFIELDTYPE := LSP1 END; END ELSE ERROR(110); INSYMBOL; END END ELSE BEGIN ERROR(2); SKIP(FSYS + [LPARENT]) END; 1: LSP^.SIZE := DISPL; LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL; LOOP LSP2 := NIL; LOOP CONSTANT(FSYS + [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 + [RPARENT,SEMICOLON],LSP2,LCP); IF DISPL > MAXSIZE THEN MAXSIZE := DISPL; WHILE LSP3 <> NIL DO BEGIN LSP4 := LSP3^.SUBVAR; LSP3^.SUBVAR := LSP2; LSP3^.SIZE := DISPL; LSP3^.FIRSTFIELD := LCP; LSP3 := LSP4 END; IF SY = RPARENT THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS + [SEMICOLON]) THEN BEGIN ERROR(6); SKIP(FSYS + [SEMICOLON]) END END ELSE ERROR(4); IF SY = SEMICOLON THEN INSYMBOL; EXIT IF NOT (SY IN CONSTBEGSYS); DISPL := MINSIZE END; { LOOP } 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 + 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 + 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 + [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 COMPTYPES ( AELTYPE , CHARPTR ) THEN %ACTUAL CHARSIZE = 1\ BEGIN CORRECTION := CORRECTION + LMIN; LSIZE := 2 * ((LMAX - LMIN + 2) DIV 2); END ELSE BEGIN CORRECTION := CORRECTION + LMIN * LSIZE; LSIZE := LSIZE * (LMAX - LMIN + 1) END END; ADDRCORR := CORRECTION; SIZE := LSIZE END END; LSP := LSP1; LSP1 := LSP2 UNTIL LSP1 = NIL END ELSE %RECORD\ IF SY = RECORDSY THEN BEGIN INSYMBOL; OLDTOP := TOP; IF TOP < DISPLIMIT THEN BEGIN TOP := TOP + 1; DISPLAY[TOP].FNAME := NIL; DISPLAY[TOP].OCCUR := CREC END ELSE ERROR(250); DISPL := 0; FIELDLIST(FSYS-[SEMICOLON]+[ENDSY],LSP1,LCP); NEW(LSP,RECORDS); WITH LSP^ DO BEGIN FSTFLD := DISPLAY[TOP].FNAME; SELFSTP := 0; RECVAR := LSP1; SIZE := DISPL; PACKSTRUCT := PACKFLAG END; TOP := OLDTOP; IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13) END ELSE %SET\ IF SY = SETSY THEN BEGIN INSYMBOL; IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); SIMPLETYPE(FSYS,LSP1,LSIZE); IF LSP1 <> NIL THEN IF LSP1^.FORM > SUBRANGE THEN BEGIN ERROR(115); LSP1 := NIL END ELSE IF LSP1 = REALPTR THEN ERROR(114); NEW(LSP,POWER); WITH LSP^ DO BEGIN ELSET := LSP1; SELFSTP := 0; IF LSP1 = CHARPTR THEN BEGIN LMIN := 0; LMAX := 63 END ELSE IF LSP1 <> NIL THEN BEGIN GETBOUNDS(LSP1,LMIN,LMAX); IF (LSP1^.FORM = SUBRANGE) AND (LSP1^.RANGETYPE = CHARPTR) THEN BEGIN LMIN := 0; LMAX := LMAX - 40B END END ELSE LMAX := -1; IF (LMIN < 0) 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 + [COMMA,SEMICOLON]) THEN BEGIN ERROR(6); SKIP(FSYS + [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 + [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 + [SEMICOLON],LSP,LVALU); ENTERID(LCP); LCP^.IDTYPE := LSP; LCP^.VALUES := LVALU; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS + [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS + [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 + [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 + [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 + [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END END ELSE ERROR(14) END; IF FWPTR <> NIL THEN BEGIN ERROR(117); IF LIST THEN BEGIN WRITELN; REPEAT WRITELN(' TYPE-ID ',FWPTR^.NAME); FWPTR := FWPTR^.NEXT UNTIL FWPTR = NIL; IF NOT EOLN(INPUT) THEN WRITE(' ':CHCNT + 8) END END END %TYPEDECLARATION\ ; PROCEDURE VARDECLARATION (*$Y+*) ; VAR LCP,NXT: CTP; LSP: STP; LSIZE: ADDRRANGE; BEGIN NXT := NIL; REPEAT LOOP IF SY = IDENT THEN BEGIN NEW(LCP,VARS); LCP^.NAME := ID; LCP^.NEXT := NXT; LCP^.IDTYPE := NIL; LCP^.VKIND := ACTUAL; LCP^.VLEV := LEVEL; ENTERID(LCP); NXT := LCP; INSYMBOL; END ELSE ERROR(2); IF NOT (SY IN FSYS + [COMMA,COLON] + TYPEDELS) THEN BEGIN ERROR(6); SKIP(FSYS + [COMMA,COLON,SEMICOLON] + TYPEDELS) END; EXIT IF SY <> COMMA; INSYMBOL END; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); TYP(FSYS+[SEMICOLON]+TYPEDELS,LSP,LSIZE); WHILE NXT <> NIL DO BEGIN NXT^.IDTYPE := LSP; LC := LC - LSIZE; NXT^.VADDR := LC; IF LSP <> NIL THEN BEGIN IF LSP^.FORM = ARRAYS THEN NXT^.VADDR := NXT^.VADDR - LSP^.ADDRCORR; IF LSP^.FORM = FILES THEN BEGIN NFILES := NFILES + 1; LSIZE := LSP^.FILTYPE^.SIZE; NXT^.VADDR := NXT^.VADDR - LSIZE; % ALLOCATE SPACE FOR RECORD BUFFER \ LC := LC-FILESIZECORR-LSIZE; IF COMPTYPES(LSP^.FILTYPE,CHARPTR) THEN LC := LC - TEXTBUFFSIZE END; END; NXT := NXT^.NEXT END; { WHILE } 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 + [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS + [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, PARSIZE: ADDRRANGE; PROCEDURE FINDEXTNAME( FCP: CTP ); LABEL 1,99; VAR DOT,I: INTEGER; LCP: CTP; CH: CHAR; SLOW: ALFA; FUNCTION COMPSTR(S1,S2: ALFA): BOOLEAN; {$Y+} 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; {$Y-} LABEL 9,99; BEGIN IF FCP = NIL THEN COMP := FALSE ELSE IF NOT (FCP^.KLASS IN [PROC,FUNC]) THEN GOTO 9 ELSE IF COMPSTR(FCP^.NAME,SLOW) THEN COMP := TRUE ELSE IF FCP^.PFDECKIND<>DECLARED THEN GOTO 9 ELSE IF FCP^.PFKIND<>ACTUAL THEN GOTO 9 ELSE IF FCP^.EXTNAME=NIL THEN GOTO 9 ELSE IF COMPSTR(FCP^.EXTNAME^,SLOW) THEN COMP := TRUE ELSE GOTO 9; GOTO 99; 9: IF COMP(FCP^.LLINK) THEN COMP := TRUE ELSE COMP := COMP(FCP^.RLINK); 99: END % COMP \; BEGIN % FINDEXTNAME \ SLOW := FCP^.NAME; DOT := 7; CH := ' '; IF DOLLARNAME THEN BEGIN SLOW[6] := '$'; FOR I:=1 TO 5 DO IF SLOW[I]=' ' THEN SLOW[I]:='$'; END; 1: FOR I := TOP DOWNTO 1 DO BEGIN IF COMP(DISPLAY[I].FNAME) THEN BEGIN IF DOT = 1 THEN BEGIN ERROR(931); GOTO 99 END ELSE BEGIN SLOW[DOT] := CH; DOT := DOT-1; CH := SLOW[DOT]; SLOW[DOT] := '.'; GOTO 1; END END % IF COMP \ END %FOR \; 99: IF DOLLARNAME OR (DOT < 7) THEN BEGIN NEW(FCP^.EXTNAME); FCP^.EXTNAME^ := SLOW; END ELSE FCP^.EXTNAME := NIL; END % FINDEXTNAME \; PROCEDURE PFHEADING (FSYS: SETOFSYS; FPF: CTP; { PROC/FUNC IDENTIFIER } VAR FORMALS: CTP); FORWARD; PROCEDURE PARAMTRLIST (FSY: SETOFSYS; VAR FPAR: CTP; VAR PARLC: ADDRRANGE); {$Y+} VAR LCP,LCP1,LCP2,LCP3: CTP; LSP: STP; LKIND: IDKIND; LCP4: CTP; LSP1,LSP2: STP; DIM: INTEGER; BEGIN LCP1 := NIL; PARLC := 2; %ADDRESS OF LAST PARAMETER IN THE LIST\ IF NOT (SY IN FSY + [LPARENT]) THEN BEGIN ERROR(7); SKIP(FSYS + FSY + [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 + [IDENT,RPARENT]) END; WHILE SY IN [IDENT,VARSY,PROCEDURESY,FUNCTIONSY] DO BEGIN IF SY = PROCEDURESY THEN BEGIN { PROCEDURAL PARAMETER SPECIFICATION } INSYMBOL; IF SY <> IDENT THEN ERROR(2) ELSE BEGIN NEW (LCP,PROC,DECLARED,FORMAL); PFHEADING (FSYS+[SEMICOLON], LCP, LCP2); LCP^.PARMLIST := LCP2; { FORMALS OF FORMAL } LCP^.NEXT := LCP1; { LINK PROCEDURE TO FORMAL PARAMETER LIST } LCP1 := LCP END END ELSE BEGIN IF SY = FUNCTIONSY THEN BEGIN { FUNCTIONAL PARAMETER SPECIFICATION } INSYMBOL; IF SY <> IDENT THEN ERROR(2) ELSE BEGIN NEW (LCP,FUNC,DECLARED,FORMAL); PFHEADING (FSYS+[SEMICOLON], LCP, LCP2); LCP^.PARMLIST := LCP2; { FORMALS OF FORMAL } LCP^.NEXT := LCP1; { LINK FUNCTION INTO FORMAL PARAMETER LIST } LCP1 := LCP END END ELSE BEGIN IF (SY = IDENT) AND (ID = 'STRING ') THEN BEGIN { STRING PARAMETER (EXTENSION) } PARSIZE := 4; NEW(LSP,STRINGPARM); LSP^.SIZE := PARSIZE; REPEAT %READ NEXT IDENTIFIER\ INSYMBOL; IF SY = IDENT THEN BEGIN NEW(LCP,VARS); LCP^.NAME := ID; LCP^.NEXT := LCP1; LCP^.IDTYPE := LSP; LCP^.VKIND := FORMAL; LCP^.VLEV := LEVEL; LCP^.VADDR := PARSIZE; { TEMPORARILY CONTAINS SIZE } ENTERID(LCP); LCP1 := LCP; INSYMBOL; END ELSE ERROR(2); IF NOT (SY IN [COMMA,SEMICOLON,RPARENT]) THEN BEGIN ERROR(7); SKIP(FSYS + [COMMA,SEMICOLON,RPARENT]) END; UNTIL SY <> COMMA; END ELSE BEGIN IF SY = VARSY THEN BEGIN LKIND := FORMAL; INSYMBOL END ELSE LKIND := ACTUAL; LCP2 := NIL; LOOP IF SY = IDENT THEN BEGIN NEW(LCP,VARS); LCP^.NAME := ID; LCP^.IDTYPE := NIL; LCP^.VKIND := LKIND; LCP^.VLEV := LEVEL; LCP^.NEXT := LCP2; ENTERID(LCP); LCP2 := LCP; INSYMBOL; END; IF NOT (SY IN [COMMA,COLON] + FSYS) THEN BEGIN ERROR(7); SKIP(FSYS + [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 + [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 LSP2 := LSP1^.SUBSTRUCT; LSP1^.SUBSTRUCT := LSP; LSP1^.UNSPECLEVEL := DIM; LSP1^.SIZE := 0; 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 + [SEMICOLON,RPARENT]) THEN BEGIN ERROR(7); SKIP(FSYS + [SEMICOLON,RPARENT]) END END ELSE ERROR(5); END; END; END; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS + [IDENT,VARSY,PROCEDURESY,FUNCTIONSY]) THEN BEGIN ERROR(7); SKIP(FSYS + [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 BEGIN IF (LCP1^.KLASS = PROC) OR (LCP1^.KLASS = FUNC) THEN BEGIN LCP1^.PFADDR := PARLC; PARLC := PARLC + 4 END ELSE { KLASS = VARS } BEGIN PARSIZE := LCP1^.VADDR; LCP1^.VADDR := PARLC; PARLC := PARLC + PARSIZE; IF (LCP1^.VKIND = ACTUAL) AND (LCP1^.IDTYPE^.FORM = ARRAYS) THEN LCP1^.VADDR := LCP1^.VADDR - LCP1^.IDTYPE^.ADDRCORR END; LCP2 := LCP1^.NEXT; LCP1^.NEXT := LCP3 ; LCP3 := LCP1; LCP1 := LCP2 END; FPAR := LCP3 END ELSE FPAR := NIL END % PARAMTRLIST \ ; PROCEDURE PFHEADING; { FORWARD DECLARED } {$Y+} VAR RESULTTYPE: CTP; LSP: STP; OLDTOP: DISPRANGE; BEGIN FORMALS := NIL; { CURRENT SYMBOL IS PROCEDURE/FUNCTION IDENTIFIER } FPF^.NAME := ID; FPF^.IDTYPE := NIL; FPF^.NEXT := NIL; FPF^.PFLEV := LEVEL; FPF^.PFADDR := 0; FPF^.PARLISTSIZE := 2; IF FPF^.PFKIND = ACTUAL THEN FINDEXTNAME (FPF); ENTERID (FPF); { DEFINING OCCURRENCE } LEVEL := LEVEL + 1; OLDTOP := TOP; IF TOP >= DISPLIMIT THEN ERROR(250) ELSE BEGIN TOP := TOP + 1; WITH DISPLAY[TOP] DO BEGIN FNAME := NIL; OCCUR := BLCK END END; INSYMBOL; IF SY = LPARENT THEN PARAMTRLIST (FSYS+[RPARENT], FORMALS, FPF^.PARLISTSIZE); TOP := OLDTOP; LEVEL := LEVEL - 1; IF FPF^.KLASS = FUNC THEN IF SY <> COLON THEN BEGIN ERROR(2); SKIP (FSYS+[IDENT]) END ELSE { SY = COLON } BEGIN INSYMBOL; IF SY <> IDENT THEN ERROR(2) ELSE BEGIN SEARCHID ([TYPES], RESULTTYPE); LSP := RESULTTYPE^.IDTYPE; IF LSP <> NIL THEN IF LSP^.FORM >= FILES THEN BEGIN ERROR(120); LSP := NIL END; FPF^.IDTYPE := LSP; INSYMBOL END END END; { PFHEADING } PROCEDURE EXTERNALDECL(FCP:CTP) (*$Y+*) ; VAR LCP: CTP; I: INTEGER; BEGIN FCP^.DECLPLACE := EXTRNL; IF SY = LPARENT THEN WITH FCP^ DO BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN IF ID = 'FORTRAN ' THEN DECLPLACE := EXTERNFORTRAN ELSE ERROR(399) ; INSYMBOL; IF SY = COMMA THEN INSYMBOL ELSE IF SY <> RPARENT THEN ERROR(20); END % IF IDENT \ ; IF SY = STRINGCONST THEN BEGIN NEW(EXTNAME); FOR I := 0 TO ALFALENG-1 DO IF I > VAL.VALP^.SLGTH THEN EXTNAME^[I+1] := ' ' ELSE EXTNAME^[I+1] := VAL.VALP^.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+*) (* NEW MODULE *) BEGIN %PROCEDUREDECLARATION\ LLC := LC; IF ONSWITCH['D'] THEN LC := -6 ELSE LC := -2; IF SY = IDENT THEN BEGIN SRCHSECTION(DISPLAY[TOP].FNAME,LCP); %DECIDE WHETHER FORW.\ IF LCP <> NIL THEN BEGIN IF LCP^.KLASS = PROC THEN FORW := (LCP^.DECLPLACE=FORWDECL) AND (FSY = PROCEDURESY) AND (LCP^.PFKIND = ACTUAL) ELSE IF LCP^.KLASS = FUNC THEN FORW := (LCP^.DECLPLACE=FORWDECL) AND (FSY = FUNCTIONSY) AND (LCP^.PFKIND = ACTUAL) ELSE FORW := FALSE; IF NOT FORW THEN ERROR(160) END ELSE FORW := FALSE; IF FORW THEN INSYMBOL ELSE BEGIN IF FSY = PROCEDURESY THEN NEW(LCP,PROC,DECLARED,ACTUAL) ELSE NEW(LCP,FUNC,DECLARED,ACTUAL); PFHEADING (FSYS+[SEMICOLON],LCP,LCP1); LCP^.NEXT := LCP1; { FORMAL PARAMETER LIST } LCP^.DECLPLACE := INTERNAL END END ELSE { SY <> IDENT } 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 IF FORW THEN BEGIN FNAME := LCP^.NEXT; OCCUR := BLCK END { ELSE PFHEADING HAS ALREADY STARTED ID TREE AT THIS LEVEL } END ELSE ERROR(250); 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); (*$Y+*) VAR I: INTEGER; CIX1: CODERANGE ; LCMAX,LLC1,ADDR: ADDRRANGE; LCP: CTP; LLP: LBP; INTRPT: BOOLEAN; (* MNC - ADDED THE FOLLOWING VARIABLE TO KEEP TRACK OF CONTEXT FOR OPTIMIZING. ALL OPTIMIZING CODE REFERS TO IT, SO I HAVE NOT MARKED SUCH CODE. SEARCH FOR EVERY OCCURRENCE OF "PREV[" TO FIND THE OPTIMIZING CODE. ALSO NOTE ADDITION OF PROCEDURE DELPREVINSTR: *) PREV: ARRAY [-1 .. 0] OF (* MNC - CONTEXT FOR CODE OPTIMIZATION *) RECORD (* PREV[-1] IS CONTEXT PREVIOUS TO PREV[0] *) LOCINSTR: -1 .. OBJECTRECSIZE; OPCODE: INSTRRANGE; SRCMODE, SRCREG, DSTMODE, DSTREG: INTEGER; SUBRNAME: RUNTIMEROUTS END; PROCEDURE WRITOBJ ( VAR REC: OBJECTRECORD ) ; (*$Y+*) BEGIN IF NOT OFFSWITCH['K'] THEN WRITOFILE( REC, PDP11OBJ (*$Z+*) , OUTPUTHGH (*$Z-*) ) ELSE REC.LEN := 1; PREV[0].LOCINSTR := -1; PREV[-1].LOCINSTR := -1; END; (*$Y+*) FUNCTION RAD50 ( FSTR: ALFA ; FINDEX: INTEGER ): INTEGER ; VAR I,J: INTEGER ; FUNCTION RAD50C ( CH: CHAR ): INTEGER ; BEGIN IF CH IN LETTERS THEN RAD50C := ORD(CH) - 64 ELSE IF CH IN DIGITS THEN RAD50C := ORD(CH) - 18 ELSE IF CH = ' ' THEN RAD50C := 0 ELSE IF CH = '$' THEN RAD50C := 27 ELSE IF CH = '.' THEN RAD50C := 28 ELSE RAD50C := 29 END ; BEGIN % RAD50 \ J := 0 ; FOR I := FINDEX TO FINDEX + 2 DO J := 40 * J + RAD50C ( FSTR[I] ) ; RAD50 := J END ; PROCEDURE DELPREVINSTR(RELOCCMDSIZE: INTEGER); (*$Y+*) BEGIN WITH CODE, PREV[0] DO BEGIN CIX := CIX - (LEN + 1 - LOCINSTR); LEN := LOCINSTR - 1; LOCINSTR := PREV[-1].LOCINSTR; PREV[-1].LOCINSTR := -1; OPCODE := PREV[-1].OPCODE; SRCMODE := PREV[-1].SRCMODE; SRCREG := PREV[-1].SRCREG; DSTMODE := PREV[-1].DSTMODE; DSTREG := PREV[-1].DSTREG; RLD.LEN := RLD.LEN - RELOCCMDSIZE; END; END; PROCEDURE PUTGR50 ( R50N1,R50N2,FLAGS,FVAL: INTEGER ) ; (*$Y+*) BEGIN WITH GSD DO BEGIN (* MNC - I CHANGED INTEGER CONSTANTS TO EXPRESSIONS INVOLVING OBJECTRECSIZE, WHEREVER APPROPRIATE, WHEN I DOUBLED THE LENGTH OF OBJECT RECORDS (SEE MNC COMMENT AT DECL OF OBJECTRECSIZE). SEARCH FOR EVERY FOLLOWING OCCURRENCE OF OBJECTRECSIZE: *) IF LEN > OBJECTRECSIZE-5 THEN WRITOBJ ( GSD ) ; VALUE[LEN+1] := R50N1 ; VALUE[LEN+2] := R50N2 ; VALUE[LEN+3] := FLAGS ; VALUE[LEN+4] := FVAL ; LEN := LEN + 4 ; END END ; PROCEDURE PUTGSD ( FNAM: ALFA ; FLAGS,FVAL: INTEGER ); (*$Y+*) BEGIN PUTGR50 ( RAD50(FNAM,1) , RAD50(FNAM,4), FLAGS, FVAL ) END; PROCEDURE PUTRLD ( FNAM: ALFA ; FTYP,FDISPL,FVAL: INTEGER ) ; (*$Y+*) BEGIN WITH RLD DO BEGIN VALUE[LEN+1] := FTYP + 256 * FDISPL ; IF FTYP <> 8 THEN BEGIN VALUE [ LEN+2 ] := RAD50 ( FNAM, 1 ) ; VALUE [ LEN + 3 ] := RAD50 ( FNAM, 4 ) ; LEN := LEN + 2 END; VALUE [ LEN + 2 ] := FVAL ; LEN := LEN + 2 ; IF LEN > OBJECTRECSIZE - 5 THEN BEGIN WRITOBJ(CODE) ; WRITOBJ(RLD) END ; END ; (*$Z+*) IF PRCODE AND (FTYP = GADRENTRY) THEN WRITELN( CEX, ';', FNAM:60 ); (*$Z-*) END ; PROCEDURE GLOBALDEF ( FNAM: ALFA ; FADDR: CODERANGE ) ; (*$Y+*) 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 ) ; (*$Y+*) 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; (*$Y+*) BEGIN CIX := CIX + 1; IF CODE.LEN = OBJECTRECSIZE-1 THEN BEGIN WRITOBJ ( CODE ) ; IF RLD.LEN > 1 THEN WRITOBJ ( RLD ) ; END ; WITH CODE DO BEGIN IF LEN = 1 THEN BEGIN PREV[0].OPCODE := TRAP; { NOT USABLE FOR OPTIMIZATION } LEN := 2 ; VALUE [ 2 ] := 2 * CIX END ; LEN := LEN + 1 END END; (*$Z+*) PROCEDURE WRITEREG(MODE,REG: INTEGER ); (*$Y+*) BEGIN IF ODD(MODE DIV 8) THEN WRITE(CEX,'@'); CASE MODE DIV 16 OF 0: WRITE(CEX,REGNAMES[REG]); 1: IF REG = PC THEN WRITE(CEX,'#C') ELSE WRITE(CEX,'(',REGNAMES[REG],')+'); 2: WRITE(CEX,'-(',REGNAMES[REG],')'); 3: WRITE(CEX,'X(',REGNAMES[REG],')') END END %WRITEREG \ ; (*$Z-*) PROCEDURE GEN1(NEWOPCODE: INSTRRANGE; NEWMODE, NEWREG: INTEGER); (*$Y+*) VAR BYTE: PACKED ARRAY[0..3] OF CHAR; BEGIN INCCIX; WITH CODE DO BEGIN VALUE[LEN] := INSTRVAL[NEWOPCODE] + NEWMODE + NEWREG ; (* MNC: *) PREV[-1] := PREV[0]; WITH PREV[0] DO BEGIN LOCINSTR := LEN; OPCODE := NEWOPCODE; DSTMODE := NEWMODE; DSTREG := NEWREG; END; (*$Z+*) IF PRCODE THEN BEGIN IF NEWOPCODE < CLR THEN BYTE := 'B ' ELSE BYTE := ' '; WRITE(CEX,2*CIX:6:O,' ',VALUE[LEN]:6:O, MN[NEWOPCODE]:10, BYTE); WRITEREG(NEWMODE,NEWREG); WRITELN(CEX) END (*$Z-*) END END; %GEN1\ PROCEDURE GEN2(NEWOPCODE: INSTRRANGE; NEWSRCMODE, NEWSRCREG, NEWDSTMODE, NEWDSTREG: INTEGER); (*$Y+*) VAR BYTE: PACKED ARRAY[0..3] OF CHAR; MODIFIEDPREVINSTR: BOOLEAN; BEGIN WITH CODE DO BEGIN MODIFIEDPREVINSTR := FALSE; IF (PREV[0].LOCINSTR >= LEN - 1) THEN IF (NEWSRCMODE = AUTINC) AND (NEWSRCREG = SP) THEN IF (INSTRVAL[NEWOPCODE] >= 0) THEN (* NOT A BYTE INSTRUCTION *) WITH PREV[0] DO IF (INSTRVAL[OPCODE] + DSTMODE + DSTREG = INSTRVAL[MOV] + AUTDEC + SP) THEN BEGIN VALUE[LOCINSTR] := VALUE[LOCINSTR] - 10045B + INSTRVAL[NEWOPCODE] + NEWDSTMODE + NEWDSTREG; OPCODE := NEWOPCODE; DSTMODE := NEWDSTMODE; DSTREG := NEWDSTREG; MODIFIEDPREVINSTR := TRUE; END; IF NOT MODIFIEDPREVINSTR THEN BEGIN INCCIX; VALUE [ LEN ] := INSTRVAL[NEWOPCODE] + 64 * (NEWSRCMODE + NEWSRCREG) + NEWDSTMODE + NEWDSTREG; (* MNC - OPTIMIZATION: *) PREV[-1] := PREV[0]; WITH PREV[0] DO BEGIN LOCINSTR := LEN; OPCODE := NEWOPCODE; SRCMODE := NEWSRCMODE; SRCREG := NEWSRCREG; DSTMODE := NEWDSTMODE; DSTREG := NEWDSTREG; END; (*$Z+*) IF PRCODE THEN BEGIN IF NEWOPCODE < CLR THEN BYTE :='B ' ELSE BYTE:=' '; WRITE (CEX, 2*CIX:6:O, ' ', VALUE[LEN]:6:O, MN[NEWOPCODE]:10, BYTE); WRITEREG (NEWSRCMODE,NEWSRCREG); WRITE (CEX,','); WRITEREG (NEWDSTMODE,NEWDSTREG); WRITELN (CEX) END (*$Z-*) END END END; { GEN2 } PROCEDURE GENBR (BRCODE: INSTRRANGE; OFFS: INTEGER); (*$Y+*) VAR OFFSET: INTEGER; BEGIN INCCIX; IF OFFS < 0 THEN OFFSET := OFFS + 256 ELSE OFFSET := OFFS; CODE.VALUE[CODE.LEN] := INSTRVAL[BRCODE] + OFFSET; (*$Z+*) IF PRCODE THEN WRITELN (CEX, 2*CIX:6:O, ' ', CODE.VALUE[CODE.LEN]:6:O, MN[BRCODE]:10, OFFS:8, ' ; ', 2*(CIX+1+OFFS):6:O) (*$Z-*) END; { GENBR } PROCEDURE GENCONST (CNST: INTEGER); (*$Y+*) BEGIN INCCIX; CODE.VALUE [CODE.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; (*$Y+*) BEGIN IF LINENO <> OLDLINENO THEN BEGIN OLDLINENO := LINENO; IF TRACE THEN GENSUBRCALL ( TRACK ); GEN2(MOV,AUTINC,PC,INDEX,GP); GENCONST(LINENO); GENCONST(LINEADDR); IF FREQUENCE OR DEBUG THEN WITH LASTLINE DO BEGIN GEN1 ( TST,AUTINC,PC ); GENCONST ( 0 ); IF LLADDR <> 0 THEN PUTRLD ( LLPSECT,15B%PSECT ADD.REL.\,2*(CODE.LEN-1),2*LLADDR); LLPSECT := PSECT; LLADDR := CIX - 4; END; IF FREQUENCE THEN BEGIN GEN1( INC,AUTINC,PC ); GENCONST ( 0 ) END; END END % LINENODEF \; PROCEDURE MOVETOSP( N: INTEGER ); (*$Y+*) 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 ); (*$Y+*) 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 ADDTOTOP ( I: INTEGER ); {$Y+} { 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); (*$Y+*) (* FOR ADDRESSING VARIABLES ON INTERMEDIATE LEVELS *) VAR I, REGISTER: INTEGER; BEGIN 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); (*$Y+*) (* FOR LOADING GLOBALLY DECLARED VARIABLES *) VAR I: INTEGER; 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\ (*$Y+*) 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, GADRENTRY, 2*(CODE.LEN-1), 0 ) ; PREV[-1].SUBRNAME := PREV[0].SUBRNAME; PREV[0].SUBRNAME := SUBRNAME; IF NOTCALLED [SUBRNAME] THEN BEGIN NOTCALLED [SUBRNAME] := FALSE ; PUTGSD ( ID, GLOBALREFFLAGS, 0 ) END ; END; %GENSUBRCALL\ PROCEDURE GENUJP(LADDR: CODERANGE); (*$Y+*) 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); (*$Y+*) BEGIN IF CODE.LEN > 1 THEN WRITOBJ( CODE ) ; WITH RLD DO BEGIN IF LEN > OBJECTRECSIZE-3 THEN WRITOBJ ( RLD ) ; VALUE [ LEN+1 ] := 8 ; % REDEFINE CURRENT LOCATION POINTER \ VALUE [ LEN+2 ] := 2 * ADDRS ; % NEW LOCATION \ LEN := LEN + 2 ; WRITOBJ ( RLD ) END ; WITH CODE DO BEGIN VALUE [ 2 ] := 2*ADDRS ; VALUE [ 3 ] := OFFST ; LEN := 3 ; WRITOBJ ( CODE ) ; END ; WITH RLD DO BEGIN VALUE [ 2 ] := 8 ; VALUE [ 3 ] := 2 * CIX + 2 ; LEN := 3 ; WRITOBJ ( RLD ) ; END ; (*$Z+*) IF PRCODE THEN BEGIN WRITELN(CEX,';'); WRITELN(CEX,2*ADDRS:6:O,' ',OFFST:6:O); WRITELN(CEX,';'); END (*$Z-*) END ; PROCEDURE LOAD; (*$Y+*) 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); (*$Y+*) VAR TSTNEEDED: BOOLEAN; BRTYPE, OPPBRTYPE: INSTRRANGE; BEGIN (* MNC - NOTE EXTENSIVE CHANGES TO THIS PROCEDURE, TO OPTIMIZE OUT MOST TST INSTRUCTIONS. SAVINGS IN COMPILER = 2400. WORDS. *) LOAD; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> BOOLPTR THEN ERROR(144); BRTYPE := BEQ; OPPBRTYPE := BNE; TSTNEEDED := TRUE; WITH CODE DO IF (PREV[0].LOCINSTR >= LEN - 1) THEN BEGIN TSTNEEDED := FALSE; WITH PREV[0] DO IF (INSTRVAL[OPCODE] + DSTMODE + DSTREG) = 10045B THEN BEGIN VALUE[LOCINSTR] := INSTRVAL[TST] + SRCMODE + SRCREG; OPCODE := TST; DSTMODE := SRCMODE; DSTREG := SRCREG; END ELSE IF (DSTMODE + DSTREG) = (REGDEF + SP) THEN BEGIN VALUE[LOCINSTR] := VALUE[LOCINSTR] - REGDEF + AUTINC; DSTMODE := AUTINC; END ELSE IF (VALUE[LOCINSTR] = INSTRVAL[JSR] + 100B * MP + INDEX + PC) AND (SUBRNAME >= EQU) AND (SUBRNAME <= LEQ) AND (RLD.LEN >= 5) THEN BEGIN DELPREVINSTR(4); (* ELIM THE CALL TO INT COMPARE ROUTINE *) GEN2(CMP, AUTINC, SP, AUTINC, SP); CASE SUBRNAME OF (* NOTE: SINCE OUR CMP INSTR COMPARES RIGHT, LEFT INSTEAD OF LEFT, RIGHT, WE HAVE TO USE THE MIRROR-IMAGE COND BR. ALSO, SINCE WE WANT TO BR ON FALSE, WE USE NEGATION OF MIRROR-IMAGE CONDITIONAL BRANCH. *) NEQ: BEGIN BRTYPE := BEQ; OPPBRTYPE := BNE; END; EQU: BEGIN BRTYPE := BNE; OPPBRTYPE := BEQ; END; LES: BEGIN BRTYPE := BLE; OPPBRTYPE := BGT; END; LEQ: BEGIN BRTYPE := BLT; OPPBRTYPE := BGE; END; GEQ: BEGIN BRTYPE := BGT; OPPBRTYPE := BLE; END; GRT: BEGIN BRTYPE := BGE; OPPBRTYPE := BLT; END END; END ELSE TSTNEEDED := TRUE; END; IF TSTNEEDED THEN GEN1(TST,AUTINC,SP); IF (LADDR <> 0) AND (CIX - LADDR <= 126) THEN GENBR(BRTYPE,LADDR - CIX - 2) %BACKWARD JUMP WITH OFFSET <= 128\ ELSE BEGIN GENBR(OPPBRTYPE, 2); GEN1(JMP,INDEX,PC); IF LADDR <> 0 THEN GENCONST(2 * (LADDR - CIX - 2)) ELSE GENCONST(0) END END; %GENFJP\ PROCEDURE STORE(VAR FATTR: ATTR); (*$Y+*) 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: ADDTOTOP (IDPLMT); PACKD: END; EXPR: ERROR(616) END; KIND := VARBL; IF ACCESS <> PACKD THEN BEGIN ACCESS := INDRCT; IDPLMT := 0 END END END; %LOADADDRESS\ PROCEDURE COPYTREE(FCP: CTP; VAR NAMECP: CTP) (*$Y+*); (* USED, IF D+ OPTION, TO COPY IDENTIFIER-,STRUCTURE- AND CONSTANT TABLES TO $DDTDF SECTION. NOTE THAT THE FIRST TWO FIELDS (SELFXXX, NOCODE) ARE NOT COPIED. INPUT: FCP POINTS AT ROOT OF IDTREE TO BE COPIED. NAMECP POINTS AT ID RECORD OF PROCEDURE TO WHICH IDTREE IS LOCAL . OUTPUT: NAMECP POINTS AT FIRST RECORD OF COPIED TREE *) CONST MAXRECSIZE = 44; (* OF CONSTANT-,STRUCTURE- AND IDENTIFIER RECORD *) TYPE RECORDFORM = (NONE,CONSTNTREC,STRUCTUREREC,IDENTIFREC); RECSIRANGE = 1..MAXRECSIZE; VAR LCP : CTP; LCIX: INTEGER; RECSIZE : RECSIRANGE; PASS1: BOOLEAN; RELOC : PACKED ARRAY[RECSIRANGE] OF BOOLEAN; RECORDTRANS: RECORD CASE RECORDFORM OF NONE : (REC: ARRAY[RECSIRANGE] OF INTEGER); CONSTNTREC: (CONSTREC: CONSTNT); STRUCTUREREC: (STRUCTREC: STRUCTURE); IDENTIFREC: (IDENTREC: IDENTIFIER) END; PTRTRANS: RECORD (* TRANSFORMS AN ADDRESS INTO A POINTER *) CASE VARIANTE: INTEGER OF 1: (PTRIX : ADDRRANGE); 2: (IXCSP : CSP); 3: (IXCTP : CTP); 4: (IXSTP : STP) END; PROCEDURE WRTRECORD; VAR I: RECSIRANGE; BEGIN WITH RECORDTRANS DO FOR I:=3 TO RECSIZE DO BEGIN GENCONST(REC[I]); IF RELOC[I] THEN PUTRLD('$DDTDF ',GARENTRY,2*CODE.LEN-2,2*REC[I]); END END (* WRTRECORD *); (*$Y-*) FUNCTION CONSTRECSIZE(FCSP: CSP) : INTEGER; (* RETURNS THE ACTUAL SIZE OF CONSTANT RECORD FCSP^ *) BEGIN WITH FCSP^ DO CASE CCLASS OF REEL: CONSTRECSIZE:=7; PSET: CONSTRECSIZE:=7; STRG: CONSTRECSIZE:=5+(SLGTH DIV 2) END END (* CONSTRECSIZE *); PROCEDURE COPYCSP(FCSP: CSP); (* COPY CONSTANT RECORD *) VAR I : RECSIRANGE; BEGIN IF FCSP<>NIL THEN WITH FCSP^ DO IF PASS1 THEN BEGIN IF SELFCSP=0 THEN BEGIN SELFCSP:=DCIX; NOCODE:=TRUE; DCIX:=DCIX+CONSTRECSIZE(FCSP) - 2 END END ELSE IF NOCODE THEN BEGIN RECORDTRANS.CONSTREC:=FCSP^; RECSIZE:= CONSTRECSIZE(FCSP); FOR I:=3 TO RECSIZE DO RELOC[I]:=FALSE; WRTRECORD; NOCODE:=FALSE END END (* COPYCSP *); PROCEDURE COPYSTP(FSP: STP); FORWARD; PROCEDURE COPYCTP(FCP: CTP); (* COPY IDENTIFIER RECORD *) VAR I : RECSIRANGE; BEGIN IF FCP<>NIL THEN WITH FCP^ DO IF (PASS1 AND (SELFCTP=0)) OR (NOT PASS1 AND NOCODE) THEN BEGIN IF PASS1 THEN BEGIN SELFCTP:=DCIX; NOCODE:=TRUE; DCIX:=DCIX+IDRECSIZE[KLASS] - 2 END ELSE (* PASS 2 *) WITH RECORDTRANS DO BEGIN RECSIZE:=IDRECSIZE[KLASS]; FOR I:=3 TO RECSIZE DO RELOC[I]:=FALSE; IDENTREC:=FCP^; WITH IDENTREC DO BEGIN IF LLINK<>NIL THEN BEGIN PTRTRANS.PTRIX:=LLINK^.SELFCTP; LLINK:=PTRTRANS.IXCTP; RELOC[9]:=TRUE END; IF RLINK<>NIL THEN BEGIN PTRTRANS.PTRIX:=RLINK^.SELFCTP; RLINK:=PTRTRANS.IXCTP; RELOC[8]:=TRUE; END; IF NEXT<>NIL THEN BEGIN PTRTRANS.PTRIX:=NEXT^.SELFCTP; NEXT:=PTRTRANS.IXCTP; RELOC[11]:=TRUE END; IF IDTYPE<>NIL THEN BEGIN IF KLASS=KONST THEN IF (IDTYPE^.FORM>POINTER) OR (IDTYPE=REALPTR) THEN BEGIN PTRTRANS.PTRIX:=VALUES.VALP^.SELFCSP; VALUES.VALP:=PTRTRANS.IXCSP; RELOC[13]:=TRUE END; IF (KLASS=PROC) OR (KLASS=FUNC) THEN IF PFDECKIND=DECLARED THEN IF PFKIND=FORMAL THEN IF PARMLIST<>NIL THEN BEGIN PTRTRANS.PTRIX:=PARMLIST^.SELFCTP; PARMLIST:=PTRTRANS.IXCTP; RELOC[18]:=TRUE END; PTRTRANS.PTRIX:=IDTYPE^.SELFSTP; IDTYPE:=PTRTRANS.IXSTP; RELOC[10]:=TRUE END END (* WITH IDENTREC *); WRTRECORD; NOCODE:=FALSE END (* WITH RECORDTRANS *); COPYCTP(LLINK); COPYCTP(RLINK); COPYSTP(IDTYPE); COPYCTP(NEXT); IF (KLASS=KONST) AND (IDTYPE<>NIL) THEN IF (IDTYPE^.FORM>POINTER) OR (IDTYPE=REALPTR) THEN COPYCSP(VALUES.VALP); IF (KLASS=PROC) OR (KLASS=FUNC) THEN IF PFDECKIND=DECLARED THEN IF PFKIND=FORMAL THEN COPYCTP(PARMLIST); END END (* COPYCTP *); PROCEDURE COPYSTP; (* COPY STRUCTURE RECORD *) VAR I : RECSIRANGE; BEGIN IF FSP<>NIL THEN WITH FSP^ DO IF (PASS1 AND (SELFSTP=0)) OR (NOT PASS1 AND NOCODE) THEN BEGIN IF PASS1 THEN BEGIN SELFSTP:=DCIX; NOCODE:=TRUE; DCIX:=DCIX+STRECSIZE[FORM] - 2 END ELSE (* PASS 2 *) WITH RECORDTRANS DO BEGIN RECSIZE:=STRECSIZE[FORM]; FOR I:=3 TO RECSIZE DO RELOC[I]:=FALSE; STRUCTREC:=FSP^; WITH STRUCTREC,PTRTRANS DO CASE FORM OF SCALAR : IF SCALKIND=DECLARED THEN IF FCONST<>NIL THEN BEGIN PTRIX:=FCONST^.SELFCTP; FCONST:=IXCTP; RELOC[6]:=TRUE END; SUBRANGE: BEGIN PTRIX:=RANGETYPE^.SELFSTP; RANGETYPE:=IXSTP; RELOC[5]:=TRUE END; POINTER : IF ELTYPE<>NIL THEN BEGIN PTRIX:=ELTYPE^.SELFSTP; ELTYPE:=IXSTP; RELOC[5]:=TRUE END; POWER : BEGIN PTRIX:=ELSET^.SELFSTP; ELSET:=IXSTP; RELOC[5]:=TRUE END; ARRAYS : BEGIN PTRIX:=AELTYPE^.SELFSTP; AELTYPE:=IXSTP; RELOC[6]:=TRUE; PTRIX:=INXTYPE^.SELFSTP; INXTYPE:=IXSTP; RELOC[5]:=TRUE END; RECORDS : BEGIN IF FSTFLD<>NIL THEN BEGIN PTRIX:=FSTFLD^.SELFCTP; FSTFLD:=IXCTP; RELOC[5]:=TRUE END; IF RECVAR<>NIL THEN BEGIN PTRIX:=RECVAR^.SELFSTP; RECVAR:=IXSTP; RELOC[6]:=TRUE END; END; FILES : BEGIN PTRIX:=FILTYPE^.SELFSTP; FILTYPE:=IXSTP; RELOC[5]:=TRUE END; BOUNDLESS: BEGIN IF SUBSTRUCT<>NIL THEN BEGIN PTRIX:=SUBSTRUCT^.SELFSTP; SUBSTRUCT:=IXSTP; RELOC[6]:=TRUE END; IF INDEXTYPE<>NIL THEN BEGIN PTRIX:=INDEXTYPE^.SELFSTP; INDEXTYPE:=IXSTP; RELOC[5]:=TRUE END; END; TAGFWITHID, TAGFWITHOUTID : BEGIN PTRIX:=FSTVAR^.SELFSTP; FSTVAR:=IXSTP; RELOC[5]:=TRUE; IF FORM=TAGFWITHID THEN BEGIN PTRIX:=TAGFIELDP^.SELFCTP; TAGFIELDP:=IXCTP; RELOC[6]:=TRUE END ELSE BEGIN PTRIX:=TAGFIELDTYPE^.SELFSTP; TAGFIELDTYPE:=IXSTP; RELOC[6]:=TRUE; END END; VARIANT : BEGIN IF FIRSTFIELD<>NIL THEN BEGIN PTRIX:=FIRSTFIELD^.SELFCTP; FIRSTFIELD:=IXCTP; RELOC[5]:=TRUE; END; IF NXTVAR<>NIL THEN BEGIN PTRIX:=NXTVAR^.SELFSTP; NXTVAR:=IXSTP; RELOC[7]:=TRUE; END; IF SUBVAR<>NIL THEN BEGIN PTRIX:=SUBVAR^.SELFSTP; SUBVAR:=IXSTP; RELOC[6]:=TRUE END END END (* CASE FORM *); WRTRECORD; NOCODE:=FALSE END (* WITH RECORDTRANS *); CASE FORM OF SCALAR : IF SCALKIND=DECLARED THEN COPYCTP(FCONST); SUBRANGE : COPYSTP(RANGETYPE); POINTER : COPYSTP(ELTYPE); POWER : COPYSTP(ELSET); ARRAYS : BEGIN COPYSTP(AELTYPE); COPYSTP(INXTYPE) END; RECORDS : BEGIN COPYCTP(FSTFLD); COPYSTP(RECVAR) END; FILES : COPYSTP(FILTYPE); BOUNDLESS: BEGIN COPYSTP(SUBSTRUCT); COPYSTP(INDEXTYPE) END; TAGFWITHID, TAGFWITHOUTID: BEGIN COPYSTP(FSTVAR); IF FORM=TAGFWITHID THEN COPYCTP(TAGFIELDP) ELSE COPYSTP(TAGFIELDTYPE) END; VARIANT : BEGIN COPYCTP(FIRSTFIELD); COPYSTP(NXTVAR); COPYSTP(SUBVAR) END END (* CASE FORM *) END END (* COPYSTP *); (*$Y+*) (* NEW MODULE *) BEGIN (* BODY OF COPYTREE *) IF NAMECP<>NIL THEN BEGIN (* INSERT DUMMY ID RECORD WITH NAME=NAMECP^.NAME IN FRONT OF TREE *) IF NAMECP^.KLASS=FUNC THEN NEW(LCP,FUNC,DECLARED,ACTUAL) ELSE NEW(LCP,PROC,DECLARED,ACTUAL); WITH LCP^ DO BEGIN SELFCTP:=0; NOCODE:=TRUE; NAME:=NAMECP^.NAME; LLINK:=FCP; (* POINTS AT ROOT OF REAL TREE *) RLINK:=NIL; IDTYPE:=NIL; NEXT:=NIL; PFLEV:=0; PFADDR:=0; PARLISTSIZE:=0; DECLPLACE:=INTERNAL; EXTNAME:=NIL END; FCP:=LCP END; NAMECP:=FCP; LCIX:=CIX; CIX:=DCIX; DCIX:=DCIX+1; PUTRLD('$DDTDF ',7,0,2*CIX+2); IF CODE.LEN > 1 THEN WRITOBJ(CODE); IF RLD.LEN > 1 THEN WRITOBJ(RLD); FOR PASS1:=TRUE DOWNTO FALSE DO COPYCTP(FCP); DCIX:=CIX; CIX:=LCIX; PUTRLD(PSECT,7,0,2*CIX+2) IF CODE.LEN >1 THEN WRITOBJ(CODE); IF RLD.LEN > 1 THEN WRITOBJ(RLD); END (* COPYTREE *); (*$Y+*) (* NEW MODULE *) PROCEDURE STATEMENT(FSYS: SETOFSYS); LABEL 1; VAR LCP: CTP; LLP: LBP; PROCEDURE MULTIPLY; BEGIN IF EXTSET THEN BEGIN GEN2(MOV,AUTINC,SP,REG,R); GEN2(MULT,REG,R,AUTINC,SP); GEN2(MOV,REG,R,AUTDEC,SP); END ELSE GENSUBRCALL(MPI); END; %MULTIPLY\ PROCEDURE EXPRESSION(FSYS: SETOFSYS); FORWARD; (* MNC - THE FOLLOWING IS A DUMMY PROCEDURE (IT IS JUST: SELECTOR:: JMP DOSELECTOR .END ), IN ORDER TO ALLOW HEAVIER OVERLAYING (SEE HUGPASBLD.ODL): *) PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP); EXTERN; PROCEDURE DOSELECTOR(FSYS: SETOFSYS; FCP: CTP); (*$Y+*) VAR LATTR: ATTR; LCP: CTP; LMIN,LMAX: INTEGER; P,SUBSTRSIZE: INTEGER; LSP1: STP; BEGIN IF FCP <> NIL THEN %FCP = NIL INDICATES EITHER A STRINGCONSTANT OR A FUNCTIONRESULT OF\ %MULTIPLE TYPE FROM WHICH AN ELEMENT MUST BE SELECTED\ WITH FCP^, GATTR DO BEGIN TYPTR := IDTYPE; KIND := VARBL; CASE KLASS OF VARS: IF VKIND = ACTUAL THEN BEGIN ACCESS := DRCT; VLEVEL := VLEV; DPLMT := VADDR END ELSE BEGIN P:= VADDR; IF TYPTR <> NIL THEN IF TYPTR^.FORM = STRINGPARM THEN LOD(LEVEL - VLEV,P,4) ELSE BEGIN IF TYPTR^.FORM = BOUNDLESS THEN P := P + 2 * (TYPTR^.UNSPECLEVEL - 1); %HYP.ADDR. OF BOUNDLESS ARRAYS ON LOCATION P\ TYPTR := INTPTR; %ADDRESS MUST BE LOADED INSTEAD OF CHARACTERVALUE\ LOD(LEVEL - VLEV, P, 2); TYPTR := IDTYPE; END; ACCESS := INDRCT; IDPLMT := 0 END; FIELD: WITH DISPLAY[DISX] DO IF OCCUR = CREC THEN BEGIN ACCESS := DRCT; VLEVEL := CLEV; DPLMT := CDSPL + FLDADDR END ELSE BEGIN TYPTR := INTPTR; % <> CHARPTR FOR LOD AND LDO \ IF LEVEL = 1 THEN LDO(VDSPL,2) ELSE LOD(0,VDSPL,2); TYPTR := IDTYPE; ACCESS := INDRCT; IDPLMT := FLDADDR END; FUNC: IF PFDECKIND = STANDARD THEN ERROR(150) ELSE IF PFLEV = 0 THEN ERROR(150) %EXTERNAL FCT\ ELSE IF PFKIND = FORMAL THEN ERROR(151) ELSE BEGIN ACCESS := DRCT; VLEVEL := PFLEV + 1; DPLMT := PARLISTSIZE; %ADDRESS OF FUNCTIONRESULT\ IF IDTYPE^.FORM=ARRAYS THEN DPLMT := DPLMT - IDTYPE^.ADDRCORR END END %CASE\ END %WITH\; IF NOT (SY IN SELECTSYS + FSYS) THEN BEGIN ERROR(59); SKIP(SELECTSYS + 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 + [COMMA,COLON,RBRACK]); LOAD; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> SCALAR THEN ERROR(113); IF LATTR.TYPTR <> NIL THEN WITH LATTR.TYPTR^ DO BEGIN SUBSTRSIZE := -1; WITH GATTR DO BEGIN KIND := VARBL;ACCESS:= INDRCT; IDPLMT :=0 END; IF SY = COLON THEN BEGIN IF FORM = BOUNDLESS THEN ERROR(615) ELSE IF FORM = ARRAYS THEN BEGIN IF AELTYPE <> CHARPTR THEN ERROR(615); LSP1 := INXTYPE; IF LSP1 <> NIL THEN GETBOUNDS(INXTYPE,LMIN,LMAX); END ELSE BEGIN LSP1 := INTPTR; %INDEXTYPE OF STRINGPARAMETER\ LMIN := 0; END; IF NOT COMPTYPES(LSP1,GATTR.TYPTR) THEN ERROR(613); LSP1 := GATTR.TYPTR; INSYMBOL; EXPRESSION(FSYS + [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 IN [2,4,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 + SELECTSYS) THEN BEGIN ERROR(6); SKIP(FSYS + 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 (* DOSELECTOR *) ; FUNCTION LARGESET(FATTR: ATTR): BOOLEAN (*$Y+*); %CHECKS IF CONVERSIONS ARE NECESSARY\ VAR L1,L2: INTEGER; %AND CALLS THE CONVERSION ROUTINES\ RTR: RUNTIMEROUTS; LSP: STP; BEGIN IF NOT COMPTYPES(GATTR.TYPTR,FATTR.TYPTR) THEN BEGIN ERROR(606); GATTR.TYPTR := NIL END ELSE BEGIN L1 := FATTR.TYPTR^.SIZE; L2 := GATTR.TYPTR^.SIZE; IF L1 = L2 THEN BEGIN IF (FATTR.KIND = VARBL) AND (GATTR.KIND = VARBL) AND (FATTR.TYPTR^.ELTYPE <> GATTR.TYPTR^.ELTYPE) THEN BEGIN ERROR(605); GATTR.TYPTR := NIL END END ELSE BEGIN IF L1 > L2 THEN IF GATTR.KIND = VARBL THEN BEGIN L1 := 2; RTR := REDSN END ELSE RTR := EXPST ELSE IF FATTR.KIND = VARBL THEN RTR := REDST ELSE BEGIN L1 := 8; RTR := EXPSN END; GENSUBRCALL(RTR); END; IF L1 <> GATTR.TYPTR^.SIZE THEN BEGIN NEW(LSP); LSP^ := GATTR.TYPTR^; LSP^.SIZE := L1; GATTR.TYPTR := LSP; END; LARGESET := L1 = 8; END END; %LARGESET\ (*$Y+*) (* NEW MODULE *) PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP); VAR LKEY: 1..25; FILECP: CTP; PROCEDURE VARIABLE(FSYS: SETOFSYS); VAR LCP: CTP; BEGIN IF SY = IDENT THEN BEGIN SEARCHID([VARS,FIELD],LCP); INSYMBOL END ELSE BEGIN ERROR(2); LCP := UVARPTR END; SELECTOR(FSYS,LCP) END %VARIABLE\ ; (*$Y+*) (* NEW MODULE *) PROCEDURE GETFILEID; VAR LDISPL: INTEGER; BEGIN FILECP := NIL; IF SY = IDENT THEN BEGIN PRTERR := FALSE; SEARCHID( [VARS,FIELD], 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 INPUTDECLARED THEN FILECP := INPUTPTR ELSE IF ( LKEY IN [2,9,10]) AND OUTPUTDECLARED 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+*) PROCEDURE GETPUTRESETREWRITE; VAR SUBRNAME: RUNTIMEROUTS; I, j, SMIN, SMAX: INTEGER; filespecgiven: boolean; procedure pushdefaultfilename ( useoldspec: boolean ); { Push a string on the runtime stack for the default file name. Use the name of the file variable. If useoldspec is true then push a negative string length to indicate to the reset/rewrite support routine to reopen the current file if it is already opened. } var j: integer; begin if 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); if useoldspec then genconst (-alfaleng) else genconst (alfaleng); end end; { pushdefaultfilename } {$Y-} BEGIN { getputresetrewrite } GETFILEID; IF LKEY > 4 { RESET, REWRITE } THEN BEGIN { RESET, REWRITE } IF FILECP^.IDTYPE <> NIL THEN WITH FILECP^.IDTYPE^ DO IF FORM = FILES THEN BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); IF COMPTYPES(FILTYPE,CHARPTR) THEN GENCONST(-1) ELSE GENCONST(FILTYPE^.SIZE); END; filespecgiven := false; { tentatively } FOR I := 1 TO 3 DO { for the three file spec strings } BEGIN IF NOT ( SY IN [COMMA,RPARENT] ) then { string given } begin if not filespecgiven and (i > 1) then { we skipped some } begin { catch up in pushing skipped strings } pushdefaultfilename (false {dont keep old filespec}); if i = 3 then { only device string is given } begin { push empty directory string } gen1 (clr, autdec, sp); gen1 (clr, autdec, sp) end end; filespecgiven := true; EXPRESSION (FSYS + [COMMA,RPARENT]); IF GATTR.TYPTR <> NIL then begin 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 end else { no string argument given for this parameter } begin if filespecgiven then begin { push empty string } gen1 (clr, autdec, sp); gen1 (clr, autdec, sp) end end; IF SY = COMMA THEN INSYMBOL; END % FOR \ ; if not filespecgiven then { no string args were given } begin pushdefaultfilename (true {use old filespec}); for i := 1 to 4 do { push two empty strings } gen1 (clr, autdec, sp); end; IF SY = RPARENT THEN GEN1(CLR,AUTDEC,SP) ELSE BEGIN EXPRESSION(FSYS + [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 + [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\ ; {$Y+} 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 + [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 ADDTOTOP (GATTR.TYPTR^.ADDRCORR); GENSUBRCALL ( RDREC ) END ELSE IF STRING ( GATTR.TYPTR ) THEN BEGIN ADDTOTOP (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]) + [ADDOP])))) AND (FILECP <> NIL) THEN LOOP EXPRESSION(FSYS + [COMMA,COLON,RPARENT]); LSP := GATTR.TYPTR; STACKD := FALSE; IF LSP <> NIL THEN IF (LSP^.FORM <= POWER) AND COMPTYPES ( FILECP^.IDTYPE^.FILTYPE, CHARPTR ) THEN LOAD ELSE IF LSP^.FORM <> STRINGPARM THEN IF GATTR.KIND = EXPR THEN %MULTIPLE FUNCTIONRESULT ON STACK IS ACTUAL PARAMETER\ BEGIN GEN2(MOV,INDEX,SP,AUTDEC,SP); GENCONST(GATTR.TYPTR^.SIZE); GEN1(TST,AUTDEC,SP); GEN2(MOV,REG,SP,REGDEF,SP); STACKD := TRUE; GEN2(ADD,AUTINC,PC,REGDEF,SP); GENCONST(4); END ELSE BEGIN LOADADDRESS; IF LSP^.FORM = ARRAYS THEN ADDTOTOP (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 + [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 + [COMMA,RPARENT]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(116); IF LSP <> REALPTR THEN ERROR(124); LOAD; GENSUBRCALL(WRFIX); END END ELSE IF LSP = INTPTR THEN BEGIN IF DEFAULT THEN BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP) ; GENCONST( 8 ) END ; GENSUBRCALL(WRI) END ELSE IF LSP = REALPTR THEN BEGIN IF DEFAULT THEN BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(15) END; GENSUBRCALL(WRR) END ELSE IF LSP = CHARPTR THEN BEGIN IF DEFAULT THEN GENSUBRCALL(WRC) ELSE GENSUBRCALL(WRCHA); END ELSE IF LSP = BOOLPTR THEN BEGIN IF DEFAULT THEN GENSUBRCALL(WRB) ELSE GENSUBRCALL(WRBFX); END ELSE IF LSP <> NIL THEN BEGIN IF LSP^.FORM = SCALAR THEN ERROR(399) ELSE IF STRING(LSP) THEN BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GETBOUNDS(LSP^.INXTYPE,SMIN,SMAX); GENCONST(SMAX - SMIN + 1); IF DEFAULT THEN GEN2(MOV,REGDEF,SP,AUTDEC,SP); GENSUBRCALL(WRS); END ELSE IF LSP^.FORM = STRINGPARM THEN BEGIN IF DEFAULT THEN GEN2(MOV,REGDEF,SP,AUTDEC,SP) ELSE BEGIN GEN2(MOV,AUTINC,SP,REG,R); GEN2(MOV,REGDEF,SP,AUTDEC,SP); GEN2(MOV,REG,R,INDEX,SP); GENCONST(2); END; GENSUBRCALL(WRS) END ELSE ERROR(116); END; END; IF STACKD THEN BEGIN GEN2(ADD,AUTINC,PC,REG,SP); GENCONST(LSP^.SIZE+2); END; EXIT IF SY <> COMMA; INSYMBOL END; IF FILECP <> NIL THEN IF (LKEY = 10) AND COMPTYPES(FILECP^.IDTYPE^.FILTYPE,CHARPTR) THEN GENSUBRCALL(PUTLINE) ELSE GEN1(TST,AUTINC,SP) % REMOVE FILE ID \ ; END %WRITE\ ; PROCEDURE PACK (*$Y+*) ; VAR LSP,LSP1: STP; BEGIN (*$Z+*) VARIABLE(FSYS + [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 + [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 + [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-*) SKIP ([RPARENT]) END %PACK\ ; PROCEDURE UNPACK (*$Y+*) ; VAR LSP,LSP1: STP; BEGIN (*$Z+*) VARIABLE(FSYS + [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 + [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 + [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-*) SKIP ([RPARENT]) 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 + [COMMA,RPARENT,COLON]); LOADADDRESS; LSP := NIL;LSIZE := 0; IF GATTR.TYPTR <> NIL THEN WITH GATTR.TYPTR^ DO IF FORM = POINTER THEN BEGIN IF ELTYPE <> NIL THEN BEGIN LSIZE := ELTYPE^.SIZE; IF ELTYPE^.FORM = RECORDS THEN BEGIN LSP := ELTYPE^.RECVAR; B := ELTYPE^.PACKSTRUCT END ELSE IF ELTYPE^.FORM = ARRAYS THEN BEGIN LSP := ELTYPE; B := LSP^.PACKOPT END; IF B THEN BEGIN GENSUBRCALL(CLRAREA); GENCONST(ELTYPE^.SIZE DIV 2) END END END ELSE ERROR(116); GEN2(MOV,INDEX,GP,REG,AD); GENCONST(DAPADDR); IF DEBUG THEN BEGIN GEN2(MOV,INDEX,GP,AUTINC,AD); GENCONST(DAPDDT); GEN2(MOV,AUTINC,PC,AUTINC,AD); GENCONST(0); PUTRLD('$DDTDF ',GARENTRY,2*(CODE.LEN-1),2*GATTR.TYPTR^.ELTYPE^.SELFSTP); GEN2(MOV,INDEX,GP,INDEX,GP); GENCONST(DAPADDR); GENCONST(DAPDDT); GEN2(MOV,REG,AD,INDEX,GP); GENCONST(DAPADDR); END; WHILE SY = COMMA DO BEGIN INSYMBOL; CONSTANT(FSYS+[COMMA,COLON,RPARENT],LSP1,LVAL); %CHECK TO INSERT HERE: IS CONSTANT IN TAGFIELDTYPE RANGE\ IF LSP = NIL THEN ERROR(158) ELSE IF STRING(LSP1) OR (LSP1 = REALPTR) THEN ERROR(159) ELSE BEGIN IF LSP^.FORM = TAGFWITHID THEN BEGIN IF LSP^.TAGFIELDP <> NIL THEN IF COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP1) THEN BEGIN GEN2(MOV,AUTINC,PC,INDEX,AD); GENCONST(LVAL.IVAL); GENCONST(LSP^.TAGFIELDP^.FLDADDR); END ELSE BEGIN ERROR(116); GOTO 1 END END ELSE IF LSP^.FORM = TAGFWITHOUTID THEN BEGIN IF NOT COMPTYPES(LSP^.TAGFIELDTYPE,LSP1) THEN BEGIN ERROR(116); GOTO 1 END END ELSE BEGIN ERROR(170); GOTO 1 END; LSP1 := LSP^.FSTVAR; WHILE LSP1 <> NIL DO WITH LSP1^ DO IF VARVAL.IVAL = LVAL.IVAL THEN BEGIN LSIZE := SIZE; LSP := SUBVAR; GOTO 1 END ELSE LSP1 := NXTVAR; LSIZE := LSP^.SIZE; LSP := NIL; END; 1: END %WHILE\ ; GEN2(MOV,REG,AD,AUTINCDEF,SP); IF SY = COLON THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [RPARENT]); IF LSP = NIL THEN ERROR(163) ELSE IF LSP^.FORM <> ARRAYS THEN ERROR(164) ELSE BEGIN IF NOT COMPTYPES(GATTR.TYPTR,LSP^.INXTYPE) THEN ERROR(116); LSZ := 2; LMIN := 1; IF LSP^.INXTYPE <> NIL THEN GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX); IF LSP^.AELTYPE <> NIL THEN IF LSP^.AELTYPE = CHARPTR THEN LSZ := 1 ELSE LSZ := LSP^.AELTYPE^.SIZE; LOAD; IF LSP^.PACKOPT THEN BEGIN GEN2(SUB,AUTINC,PC,REGDEF,SP); GENCONST(LMIN - 1); LSZ := 1; FOR I := 1 TO 3 DO GEN1(ASR,REGDEF,SP) % ... DIV 8 \ ; GEN1(INC,REGDEF,SP); LMIN := 1 %ALWAYS ADDS ONE BYTE\ END; GEN2(MOV,AUTINC,SP,REG,R); IF LSZ <> 1 THEN IF LSZ = 2 THEN GEN1(ASL,REG,R) ELSE IF EXTSET THEN BEGIN GEN2(MULT,REG,R,AUTINC,PC); GENCONST(LSZ) END ELSE BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(LSZ); GENSUBRCALL(MPI); GEN2(MOV,AUTINC,SP,REG,R) END; LSZ := LSIZE - LSP^.SIZE - LSZ * (LMIN - 1); IF LSZ > 0 THEN BEGIN GEN2(ADD,AUTINC,PC,REG,R); GENCONST(LSZ); END; IF (LSP^.AELTYPE = CHARPTR) OR LSP^.PACKOPT THEN BEGIN GEN2(MOV,REG,R,REG,AR); GEN2(BIC,AUTINC,PC,REG,AR); GENCONST(-2); GENBR(BEQ,1); GEN1(INC,REG,R); %TEST FOR ODD STRINGLENGTH; IN THIS CASE AN EXTRA\ %BYTE MUST BE ADDED TO MAINTAIN WORD BOUNDARY\ END; GEN2(ADD,REG,R,INDEX,GP); GENCONST(DAPADDR) END END ELSE BEGIN GEN2(ADD,AUTINC,PC,INDEX,GP); GENCONST(LSIZE); GENCONST(DAPADDR) END; IF HEAPCHECK THEN GENSUBRCALL(OVFLCHK); END %NEW\ ; PROCEDURE ABS (*$Y+*) ; BEGIN IF GATTR.TYPTR = INTPTR THEN BEGIN GEN1(TST,REGDEF,SP); GENBR(BPL,1); GEN1(NEG,REGDEF,SP) END ELSE IF GATTR.TYPTR = REALPTR THEN BEGIN GEN2(BIC,AUTINC,PC,REGDEF,SP); GENCONST(100000B) END ELSE BEGIN ERROR(125); GATTR.TYPTR := INTPTR END END %ABS\ ; PROCEDURE SQR (*$Y+*) ; BEGIN IF GATTR.TYPTR = INTPTR THEN BEGIN IF EXTSET THEN BEGIN GEN2(MOV,REGDEF,SP,REG,R); GEN2(MULT,REG,R,AUTINC,SP); GEN2(MOV,REG,R,AUTDEC,SP) END ELSE GENSUBRCALL(SQI) END ELSE IF GATTR.TYPTR = REALPTR THEN GENSUBRCALL(SQRR) ELSE BEGIN ERROR(125); GATTR.TYPTR := INTPTR END END %SQR\ ; PROCEDURE TRUNC (*$Y+*) ; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> REALPTR THEN ERROR(125); GENSUBRCALL(TRC); GATTR.TYPTR := INTPTR END %TRUNC\ ; PROCEDURE ARITHMETICFUNCTIONS (*$Y+*) ; VAR RTR: RUNTIMEROUTS; BEGIN IF GATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLT); GATTR.TYPTR := REALPTR END; IF GATTR.TYPTR <> REALPTR THEN ERROR(125) ELSE BEGIN CASE LKEY OF 16: RTR := RSIN; 17: RTR := RCOS; 18: RTR := RARCTAN; 19: RTR := REXP; 20: RTR := RLOG; 21: RTR := RSQRT END; GENSUBRCALL(RTR); END; END; %ARITHMETICFUNCTIONS\ PROCEDURE ROUND (*$Y+*) ; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> REALPTR THEN ERROR(125); GENSUBRCALL(RND); GATTR.TYPTR := INTPTR END; %ROUND\ PROCEDURE ODD (*$Y+*) ; BEGIN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); GEN2(BIC,AUTINC,PC,REGDEF,SP); GENCONST(-2); GATTR.TYPTR := BOOLPTR END %ODD\ ; PROCEDURE ORD (*$Y+*) ; BEGIN IF GATTR.TYPTR <> NIL THEN IF (GATTR.TYPTR^.FORM > POWER) OR (GATTR.TYPTR^.SIZE <> 2) THEN ERROR(125); GATTR.TYPTR := INTPTR END %ORD\ ; PROCEDURE CHR (*$Y+*) ; BEGIN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); GATTR.TYPTR := CHARPTR END %CHR\ ; PROCEDURE PREDSUCC (*$Y+*) ; BEGIN IF LKEY = 7 THEN GEN1(DEC,REGDEF,SP) ELSE GEN1(INC,REGDEF,SP); %NO BOUNDCHECKING IS DONE\ IF GATTR.TYPTR <> NIL THEN IF (GATTR.TYPTR^.FORM <> SCALAR) OR (GATTR.TYPTR = REALPTR) THEN ERROR(125); END %PREDSUCC\ ; PROCEDURE EOFEOLNIORES (*$Y+*) ; VAR LDISPL: INTEGER; BEGIN LKEY := LKEY + 2; GETFILEID; IF LKEY = 13 (* 11+2 *) THEN GATTR.TYPTR := INTPTR ELSE GATTR.TYPTR := BOOLPTR ; END %EOF\ ; PROCEDURE BREAKLN (*$Y+*) ; BEGIN GETFILEID; GENSUBRCALL( BRK ) END; PROCEDURE FORMFEED (*$Y+*) ; BEGIN GETFILEID; GENSUBRCALL( FORMFD ) END; PROCEDURE DATETIME (*$Y+*) ; BEGIN VARIABLE( FSYS + [RPARENT]); LOADADDRESS; IF GATTR.TYPTR <> NIL THEN IF LKEY = 18 THEN GENSUBRCALL( TIME1 ) ELSE GENSUBRCALL( DATE1 ); END; PROCEDURE HALT (*$Y+*) ; BEGIN IF DEBUG THEN GENCONST(4 %IOT\) ELSE GENSUBRCALL( DUMP ) END ; PROCEDURE RUNTIME1 (*$Y+*) ; BEGIN GENSUBRCALL( RUNTM ); GATTR.TYPTR := INTPTR END; PROCEDURE MARKRELEASE (*$Y+*) ; BEGIN ERROR(903); SKIP(FSYS + [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 + [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: INTEGER; LATTR: ATTR; B: BOOLEAN; RELNAME: ALFA; PROCEDURE BASE(PLEVEL: LEVRANGE); VAR I,MODE,REGISTER: INTEGER; BEGIN IF PLEVEL <= 1 THEN GEN2(MOV,REG,GP,AUTDEC,SP) ELSE BEGIN PLEVEL := LEVEL - PLEVEL; 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; END; (*$Y-*) FUNCTION COMPSPECIFICATION(LCP1, LCP2: CTP): BOOLEAN; { CHECK CONGRUITY OF TWO FORMAL PARAMETER LISTS } 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 + [RPARENT]) END ELSE BEGIN IF NXT^.KLASS IN [PROC,FUNC] THEN %PROCEDURE PARAM'S\ BEGIN IF SY <> IDENT THEN BEGIN ERROR(2); SKIP(FSYS + [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 + [COMMA,RPARENT]) THEN BEGIN ERROR(6); SKIP(FSYS + [COMMA,RPARENT]) END; IF LCP <> NIL THEN WITH LCP^ DO BEGIN IF PFDECKIND = STANDARD THEN ERROR(603); LCP1 := NXT^.PARMLIST; IF PFKIND = ACTUAL THEN { ACTUAL PARAMETER IS AN ACTUAL PROC/FUNC } BEGIN BASE(PFLEV); { LOAD STATIC LINK } LCP2 := LCP^.NEXT; IF DECLPLACE > EXTRNL THEN ERROR(609); GEN2 (MOV,AUTINC,PC,AUTDEC,SP); { LOAD P/F ADDRESS } GENCONST (0); { ABSOLUTE P/F ADDRESS } IF EXTNAME = NIL THEN RELNAME := NAME ELSE RELNAME := EXTNAME^ ; PUTRLD( RELNAME, GARENTRY, 2*(CODE.LEN-1), 0); PUTGSD(RELNAME, GLOBALREFFLAGS, 0 ) ; END ELSE { ACTUAL PARAMETER IS A FORMAL PROC/FUNC } BEGIN LCP2 := LCP^.PARMLIST; IF PFLEV <= 1 THEN LDO(PFADDR, 4) ELSE LOD(LEVEL-PFLEV, PFADDR, 4) END; IF NOT COMPSPECIFICATION(LCP1,LCP2) THEN ERROR(612); END END ELSE { NXT^.KLASS NOT IN [PROC,FUNC], MUST BE VARS } 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(617); END; EXPRESSION(FSYS + [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); ADDTOTOP (LMIN); GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(LMAX-LMIN+1); END END ELSE IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> STRINGPARM THEN ERROR(617) END ELSE { NOT STRINGPARM -- ORDINARY VAR } IF GATTR.KIND = VARBL THEN IF (GATTR.ACCESS=PACKD) AND (GATTR.TYPTR=BOOLPTR) THEN ERROR(142) ELSE LOADADDRESS ELSE ERROR(154); LSP2 := GATTR.TYPTR; LSP1 := LSP; WHILE LSP1^.FORM = BOUNDLESS DO BEGIN IF LSP2 <> NIL THEN IF LSP2^.FORM = ARRAYS THEN BEGIN LSP2 := LSP2^.AELTYPE; IF LSP1^.UNSPECLEVEL > 1 THEN BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(LSP2^.SIZE); END END ELSE IF LSP2^.FORM = BOUNDLESS THEN BEGIN IF ((LSP2^.UNSPECLEVEL = 1) AND (LSP1^.UNSPECLEVEL > 1)) THEN BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(LSP2^.SUBSTRUCT^.SIZE); END; LSP2 := LSP2^.SUBSTRUCT; END; LSP1 := LSP1^.SUBSTRUCT; END; IF NOT COMPTYPES(LSP1,LSP2) THEN ERROR(142) END ELSE WITH LSP^ DO BEGIN IF (FORM = ARRAYS) OR (FORM = RECORDS) THEN BEGIN EXPRESSION(FSYS + [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} { CAN ALSO MEAN THAT EXPRESSION IS SUBSTRING SPECIFICATION } 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) OR (GATTR.TYPTR^.FORM = STRINGPARM) THEN ERROR(142) END { FORM=ARRAYS,ETC } ELSE { NOT ARRAYS OR RECORDS } BEGIN EXPRESSION(FSYS + [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(PFLEV); %LOADS THE STATIC LINK\ GEN2(JSR,REG,PC,INDEX,PC); GENCONST( 0 ) ; PUTRLD ( RELNAME, GADRENTRY, 2*(CODE.LEN-1), 0 ) ; PUTGSD ( RELNAME, GLOBALREFFLAGS, 0 ) ; END ELSE BEGIN GEN2(MOV,AUTINC,PC,AUTDEC,SP); GENCONST(PARLISTSIZE DIV 2); GENSUBRCALL( FORTR ); GENCONST( 0 ); PUTRLD ( RELNAME, GADRENTRY, 2*(CODE.LEN-1), 0 ); PUTGSD ( RELNAME, GLOBALREFFLAGS, 0 ); IF KLASS = FUNC THEN BEGIN GEN2(MOV,REG,AR,REGDEF,SP); IF IDTYPE^.SIZE = 4 THEN BEGIN GEN2(MOV,REG,R,INDEX,SP); GENCONST( 2 ); END END END; END ELSE %CALL OF FORMAL PROCEDURE\ BEGIN LOD(LEVEL - PFLEV,PFADDR,4); %LOAD THE PROCEDURE PARAMETER\ GEN2(JSR,REG,PC,AUTINCDEF,SP) END; % WITH FCP\ GATTR.TYPTR := FCP^.IDTYPE; END %CALLNONSTANDARD\ ; PROCEDURE CALLSTANDARD( FCP: CTP ) (*$Y+*) ; BEGIN %CALLSTANDARD\ LKEY := FCP^.KEY; IF (FCP^.KLASS = PROC) AND (LKEY = 14) THEN HALT ELSE IF (FCP^.KLASS = FUNC) AND (LKEY = 13) THEN RUNTIME1 ELSE IF (FCP^.KLASS = PROC) AND ((LKEY IN [2,4,8,10,12,13]) AND (SY <> LPARENT)) THEN CASE LKEY OF 2: FORMFEED; 4: BREAKLN; 8: READREADLN; 10: WRITEWRITELN; 12: GENSUBRCALL(MARKP); 13: GENSUBRCALL(RELEASEP) END ELSE IF (FCP^.KLASS = FUNC) AND ((LKEY IN [9,10,11]) AND (SY <> LPARENT)) THEN EOFEOLNIORES ELSE BEGIN IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9); IF FCP^.KLASS = PROC THEN CASE LKEY OF 2: FORMFEED; 4: BREAKLN; 1,3, 5,6: GETPUTRESETREWRITE; 7,8: READREADLN; 9,10: WRITEWRITELN; 11 : NEW1; 12,13:MARKRELEASE; 15 : PACK; 16 : UNPACK; 17,18 : DATETIME END ELSE IF LKEY IN [9,10,11] THEN EOFEOLNIORES ELSE BEGIN EXPRESSION(FSYS + [COMMA,RPARENT]); IF LKEY <> 22 THEN LOAD; CASE LKEY OF 1: ABS; 2: SQR; 3: TRUNC; 4: ODD; 5: ORD; 6: CHR; 7,8: PREDSUCC; 12: ROUND; 14: SPLITREAL; 15: TWOPOW; 16,17,18, 19,20,21: ARITHMETICFUNCTIONS; 22: SSIZE END END; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END END %CALLSTANDARD\ ; (*$Y+*) (* NEW MODULE *) BEGIN % CALL \ IF FCP^.PFDECKIND = STANDARD THEN CALLSTANDARD( FCP ) ELSE BEGIN CALLNONSTANDARD; IF SY IN [LBRACK,PERIOD] THEN CALLNS1 END END % CALL \ ; (*$Y+*) (* NEW MODULE *) PROCEDURE EXPRESSION; VAR LATTR: ATTR; LOP: OPERATOR; LSIZE: ADDRRANGE; B,C,STACKD: BOOLEAN; SUBRNAME: RUNTIMEROUTS; SMIN,SMAX: INTEGER; MULTSSIZE: INTEGER; PROCEDURE SMPLEEXPRESSION(FSYS: SETOFSYS); VAR LATTR: ATTR; LOP: OPERATOR; SIGNED: BOOLEAN; PROCEDURE TERM(FSYS: SETOFSYS); VAR LATTR: ATTR; LOP: OPERATOR; PROCEDURE LOADSTRINGCONSTANT; VAR I: INTEGER; BEGIN WITH GATTR DO IF TYPTR <> NIL THEN WITH CVAL.VALP^ DO BEGIN GENBR(BR,(SLGTH + 2) DIV 2); I := 0; WHILE I < SLGTH DO BEGIN GENCONST(ORD(SVAL[I]) + 256 * ORD(SVAL[I + 1])); I := I + 2 END; IF ODD(SLGTH+1) THEN GENCONST(ORD(SVAL[I])); GEN2(MOV,REG,PC,AUTDEC,SP); GEN2(SUB,AUTINC,PC,REGDEF,SP); GENCONST(TYPTR^.SIZE + 2) %HYP. STRINGADDRESS ON STACK\ END END; %LOADSTRINGCONSTANT\ (*$Y-*) PROCEDURE FACTOR(FSYS: SETOFSYS); VAR LCP: CTP; LVP: CSP; VARPART: BOOLEAN; CSTPART: SET OF 0..63; LSP,LSP1: STP; J,I,INTSET,K: INTEGER; FOURWORDSET: BOOLEAN; SCOUNT,LRMIN: INTEGER; RANGEPART: BOOLEAN; BEGIN IF NOT (SY IN FACBEGSYS) THEN BEGIN ERROR(58); SKIP(FSYS + FACBEGSYS); GATTR.TYPTR := NIL END; WHILE SY IN FACBEGSYS DO BEGIN CASE SY OF %ID\ IDENT: BEGIN SEARCHID([KONST,VARS,FIELD,FUNC],LCP); INSYMBOL; IF LCP^.KLASS = FUNC THEN BEGIN CALL(FSYS,LCP); GATTR.KIND := EXPR END ELSE IF LCP^.KLASS = KONST THEN WITH GATTR, LCP^ DO BEGIN TYPTR := IDTYPE; KIND := CST; CVAL := VALUES; IF STRING(TYPTR) THEN BEGIN LOADSTRINGCONSTANT; IF SY = LBRACK THEN BEGIN SELECTOR(FSYS,NIL); LOAD END END ; END ELSE { VARS, FIELD } SELECTOR(FSYS,LCP); { TO SIMPLIFY LATER TESTS, REDUCE SUBRANGE TYPES TO THEIR UNDERLYING RANGE TYPES. NOTE THAT THIS IS ALSO DONE TO FUNCTION RESULTS. } IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM = SUBRANGE THEN GATTR.TYPTR := GATTR.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 + [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 + [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 + [LRMIN]; LRMIN := SUCC(LRMIN) END; RANGEPART := FALSE END ELSE (* NUMBER IS LEGAL AND NOT PART OF A SUBRANGE *) CSTPART := CSTPART + [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 + FACBEGSYS) END END %WHILE\ END %FACTOR\ ; BEGIN %TERM\ FACTOR(FSYS + [MULOP]); WHILE SY = MULOP DO BEGIN LOAD; LATTR := GATTR; LOP := OP; INSYMBOL; FACTOR(FSYS + [MULOP]); LOAD; IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN CASE LOP OF %*,AND\ MUL,ANDOP: BEGIN IF (LATTR.TYPTR = BOOLPTR) AND (GATTR.TYPTR = BOOLPTR) AND (LOP = ANDOP) THEN BEGIN GEN1(COM,REGDEF,SP); GEN2(BIC,AUTINC,SP,REGDEF,SP) END ELSE IF (LATTR.TYPTR^.FORM = POWER) THEN IF LARGESET(LATTR) THEN GENSUBRCALL(INT4) ELSE BEGIN GEN1(COM,REGDEF,SP); %INT1\ GEN2(BIC,AUTINC,SP,REGDEF,SP) END ELSE IF LOP = MUL THEN IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN MULTIPLY ELSE BEGIN IF LATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLO); LATTR.TYPTR := REALPTR END ELSE IF GATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLT); GATTR.TYPTR := REALPTR END; IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR) THEN GENSUBRCALL(MPR) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END; %/\ RDIV: BEGIN IF GATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLT); GATTR.TYPTR := REALPTR END; IF LATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLO); LATTR.TYPTR := REALPTR END; IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR) THEN GENSUBRCALL(DVR) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END; %DIV\ IDIV: IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN GENSUBRCALL(DVI) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END; %MOD\ IMOD: IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN GENSUBRCALL(MODI) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END %CASE\ ELSE GATTR.TYPTR := NIL END %WHILE\ END %TERM\ ; BEGIN %SMPLEEXPRESSION\ SIGNED := FALSE; IF (SY = ADDOP) AND (OP IN [PLUS,MINUS]) THEN BEGIN SIGNED := OP = MINUS; INSYMBOL END; TERM(FSYS + [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\ ADDTOTOP (100000B); END ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END; WHILE SY = ADDOP DO BEGIN LOAD; LATTR := GATTR; LOP := OP; INSYMBOL; TERM(FSYS + [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 %+,OR\ PLUS,OROP: BEGIN IF (LATTR.TYPTR = BOOLPTR) AND (GATTR.TYPTR = BOOLPTR) AND (LOP = OROP) THEN GEN2(BIS,AUTINC,SP,REGDEF,SP) ELSE IF LATTR.TYPTR^.FORM = POWER THEN IF LARGESET(LATTR) THEN GENSUBRCALL(UNI4) ELSE GEN2(BIS,AUTINC,SP,REGDEF,SP) ELSE IF LOP = PLUS THEN IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN GEN2(ADD,AUTINC,SP,REGDEF,SP) ELSE BEGIN IF LATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLO); LATTR.TYPTR := REALPTR END ELSE IF GATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLT); GATTR.TYPTR := REALPTR END; IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR) THEN GENSUBRCALL(ADR) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END; %-\ MINUS: IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN GEN2(SUB,AUTINC,SP,REGDEF,SP) ELSE BEGIN IF LATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLO); LATTR.TYPTR := REALPTR END ELSE IF GATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLT); GATTR.TYPTR := REALPTR END; IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR) THEN GENSUBRCALL(SBR) ELSE IF LATTR.TYPTR^.FORM = POWER THEN IF LARGESET(LATTR) THEN GENSUBRCALL(DIF4) ELSE GEN2(BIC,AUTINC,SP,REGDEF,SP) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END END %CASE\ ELSE { 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 + [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 ADDTOTOP (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; IF GATTR.TYPTR^.FORM = ARRAYS THEN ADDTOTOP (GATTR.TYPTR^.ADDRCORR); GEN2(MOV,AUTINC,SP,REG,AR) %LOAD RIGHT MEMBER ADDRESS\ 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 ADDTOTOP (GATTR.TYPTR^.ADDRCORR) 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; IF (SMAX = 0) OR (SMAX > 15) THEN B := TRUE ELSE B := FALSE; %B=TRUE MEANS THAT A LARGE SET MUST BE USED\ LSIZE := GATTR.TYPTR^.SIZE; IF (GATTR.KIND<>VARBL) AND B AND (LSIZE = 2) THEN BEGIN GENSUBRCALL(EXPST); LSIZE := 8 END ELSE B := LSIZE = 8; IF C THEN BEGIN GEN2( SUB, AUTINC, PC, INDEX, SP ); GENCONST( 40B % SPACE \ ); GENCONST( LSIZE ) END; GENSUBRCALL(INN); IF B THEN GENCONST(8) ELSE GENCONST(2); END ELSE BEGIN ERROR(129); GATTR.TYPTR := NIL END ELSE BEGIN ERROR(130); GATTR.TYPTR := NIL END ELSE BEGIN IF LATTR.TYPTR <> GATTR.TYPTR THEN IF LATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLO); LATTR.TYPTR := REALPTR END ELSE IF GATTR.TYPTR = INTPTR THEN BEGIN GENSUBRCALL(FLT); GATTR.TYPTR := REALPTR END; IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN BEGIN LSIZE := LATTR.TYPTR^.SIZE; CASE LATTR.TYPTR^.FORM OF SCALAR : BEGIN B := LATTR.TYPTR = REALPTR; SUBRNAME := SCALRT[LOP,B] END; POINTER: IF LOP = EQOP THEN SUBRNAME := EQU ELSE IF LOP = NEOP THEN SUBRNAME := NEQ ELSE SUBRNAME := ERRN; POWER : BEGIN B := LARGESET(LATTR); CASE LOP OF LTOP,GTOP: SUBRNAME := ERRN; LEOP: IF B THEN SUBRNAME := LEQS4 ELSE SUBRNAME := LEQS1; GEOP: IF B THEN SUBRNAME := GEQS4 ELSE SUBRNAME := GEQS1; NEOP: IF B THEN SUBRNAME := NEQS4 ELSE SUBRNAME := NEQ; EQOP: IF B THEN SUBRNAME := EQUS4 ELSE SUBRNAME := EQU END; END; ARRAYS, RECORDS: BEGIN SUBRNAME := ARRT[LOP,STRING(LATTR.TYPTR),STACKD]; IF SUBRNAME IN [EQUM,EQUM2,NEQM,NEQM2] THEN LSIZE := LSIZE DIV 2; END; FILES : BEGIN ERROR(133); SUBRNAME := ERRN END END; IF SUBRNAME = ERRN THEN ERROR(131) ELSE IF LATTR.TYPTR^.FORM IN [ARRAYS,RECORDS] THEN IF SUBRNAME IN [EQUM2,NEQM2,LEQM2,LESM2,GEQM2,GRTM2] THEN BEGIN GEN2(MOV,AUTINC,PC,REG,R); GENCONST(LSIZE); GENSUBRCALL(SUBRNAME); END ELSE BEGIN GENSUBRCALL(SUBRNAME); GENCONST(LSIZE) END ELSE GENSUBRCALL(SUBRNAME) END ELSE ERROR(129) END; GATTR.TYPTR := BOOLPTR; GATTR.KIND := EXPR; IF MULTSSIZE <> 0 THEN BEGIN GEN2(MOV,REGDEF,SP,INDEX,SP); GENCONST(MULTSSIZE); GEN2(ADD,AUTINC,PC,REG,SP); GENCONST(MULTSSIZE); END END %SY = RELOP\ END %EXPRESSION\ ; PROCEDURE ASSIGNMENT(FCP: CTP) (*$Y+*) ; VAR LATTR: ATTR; SMIN,SMAX: INTEGER; LSP1: STP; STACKD: BOOLEAN; AL, I: INTEGER; BEGIN SELECTOR(FSYS + [BECOMES],FCP); IF FCP^.KLASS = FUNC THEN IF (FCP^.PFLEV > LEVEL) OR (FCP^.PFLEV=LEVEL) AND (FPROCP<>FCP) THEN BEGIN ERROR ( 184 ); GATTR.TYPTR := NIL; END; IF SY = BECOMES THEN BEGIN IF GATTR.TYPTR <> NIL THEN IF (GATTR.ACCESS <> DRCT) OR (GATTR.TYPTR^.FORM > POWER) THEN BEGIN LOADADDRESS; IF GATTR.TYPTR^.FORM = ARRAYS THEN ADDTOTOP (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 ADDTOTOP (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) AND (LATTR.TYPTR <> BOOLPTR) (*V5-34*) THEN BEGIN GETBOUNDS(LATTR.TYPTR,SMIN,SMAX); GENSUBRCALL(SUBRCHK); GENCONST(SMIN); GENCONST(SMAX); END; STORE(LATTR); END; POINTER, POWER : STORE(LATTR); ARRAYS, RECORDS: BEGIN AL := GATTR.TYPTR^.SIZE DIV 2; IF STACKD THEN IF AL <= 3 THEN FOR I:= 1 TO AL DO GEN2(MOV,AUTINC,AR,AUTINC,AD) ELSE BEGIN GENSUBRCALL(MOVM2); GENCONST(AL); END ELSE BEGIN GENSUBRCALL(MOVM); GENCONST(AL) END END; FILES: ERROR(146) END ELSE ERROR(129) END END %SY = BECOMES\ ELSE ERROR(51) END %ASSIGNMENT\ ; PROCEDURE GOTOSTATEMENT (*$Y+*) ; LABEL 1; VAR LLP: LBP; LRP: REFLINKP ; BEGIN IF SY = INTCONST THEN BEGIN LLP := FSTLABP; WHILE LLP <> FLABP DO WITH LLP^ DO IF LABVAL = VAL.IVAL THEN BEGIN IF DEFINED THEN GENUJP(LABADDR) ELSE BEGIN GENUJP( 0 ); NEW ( LRP ) ; LRP^.NEXTREF := LABCHAIN ; LABCHAIN := LRP ; LRP^.REFADDR := CIX ; END; GOTO 1 END ELSE LLP := NEXTLAB; (* UNDECLARED AND UNDEFINED *) GENUJP( 0 ); NEW(LRP); NEW(LLP); WITH LLP^ DO BEGIN LABVAL := VAL.IVAL; DEFINED := FALSE; LABCHAIN := LRP; NEXTLAB := FSTLABP; DECLARED := FALSE; END; FSTLABP := LLP; WITH LRP^ DO BEGIN NEXTREF := NIL; REFADDR := CIX END; 1: INSYMBOL END ELSE ERROR(15) END %GOTOSTATEMENT\ ; PROCEDURE COMPOUNDSTATEMENT (*$Y+*) ; BEGIN LOOP REPEAT STATEMENT(FSYS + [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 + [THENSY]); GENFJP(0); LCIX1 := CIX; IF SY = THENSY THEN INSYMBOL ELSE ERROR(52); STATEMENT(FSYS + [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,OWISE: BOOLEAN; HEAPM: INTP; BEGIN EXPRESSION(FSYS + [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; WHILE (SY IN (CONSTBEGSYS+[DEFAULTSY])) DO { FOR ALL CASES } BEGIN OTHERCASE := SY = DEFAULTSY; OWISE := ID = 'OTHERWISE '; IF OTHERCASE THEN BEGIN IF OTHERADDR <> 0 THEN ERROR(156); OTHERADDR := CIX + 1; INSYMBOL END ELSE LOOP { OVER CONSTANT LIST } CONSTANT(FSYS+[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; { LOOP } IF OWISE THEN { 'OTHERWISE' CASE } LOOP REPEAT STATEMENT (FSYS+[SEMICOLON]) UNTIL NOT (SY IN STATBEGSYS); EXIT IF SY <> SEMICOLON; INSYMBOL END { LOOP } ELSE { 'OTHERS' CASE AND NORMAL CASE } BEGIN IF (OTHERADDR<>0) AND NOT OTHERCASE THEN ERROR(186); IF SY = COLON THEN INSYMBOL ELSE ERROR(5); STATEMENT(FSYS + [SEMICOLON]) END; GENUJP(0); IF OTHERCASE THEN OTHEREND := CIX ELSE IF LPT3<>NIL THEN LPT3^.CSEND := CIX; IF SY = SEMICOLON THEN INSYMBOL END; { WHILE } 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 + [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 + [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; LCP: CTP; LADDR: ADDRRANGE; LSY: SYMBOL; LCIX: CODERANGE; REGR, I: INTEGER; INSTR: INSTRRANGE; BEGIN IF SY <> IDENT THEN BEGIN ERROR(2); SKIP(FSYS + [BECOMES,TOSY,DOWNTOSY,DOSY]) END ELSE BEGIN SEARCHID([VARS],LCP); WITH LCP^, LATTR DO BEGIN TYPTR := IDTYPE; KIND := VARBL; IF (VKIND <> ACTUAL) OR (VLEV <> LEVEL) THEN BEGIN ERROR(155); TYPTR := NIL END ELSE BEGIN ACCESS := DRCT; VLEVEL := LEVEL; DPLMT := VADDR 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; IF SY <> BECOMES THEN BEGIN ERROR(51); SKIP(FSYS + [TOSY,DOWNTOSY,DOSY]) END ELSE BEGIN INSYMBOL; EXPRESSION(FSYS+[TOSY,DOWNTOSY,DOSY]); { INITIAL VALUE } IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> SCALAR THEN ERROR(144) ELSE IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN LOAD { LEAVE ON STACK UNTIL FINAL VALUE EVALUATED } ELSE ERROR(145) END; IF NOT (SY IN [TOSY,DOWNTOSY]) THEN BEGIN ERROR(55); SKIP(FSYS + [DOSY]) END ELSE BEGIN LSY := SY; INSYMBOL; EXPRESSION(FSYS + [DOSY]); { FINAL VALUE } IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> SCALAR THEN ERROR(144) ELSE IF NOT COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN ERROR(145) ELSE BEGIN LOAD; LC := LC - 2; GEN2(MOV,AUTINC,SP,INDEX,MP); { SAVE FINAL VALUE IN TEMP VARIABLE } GENCONST(LC); STORE (LATTR); { ASSIGN INITIAL VALUE TO CONTROL VARIABLE } LADDR := CIX + 1; { CODE-ADDR FOR JUMP } IF LATTR.TYPTR = CHARPTR THEN INSTR := CMPB ELSE INSTR := CMP; GEN2 (INSTR, INDEX, MP, INDEX, MP); GENCONST (LATTR.DPLMT); GENCONST (LC); LSP := LATTR.TYPTR; IF LSP^.FORM = SUBRANGE THEN LSP := LSP^.RANGETYPE; IF (LSP^.SCALKIND = DECLARED) OR (LSP = CHARPTR) THEN BEGIN { Do an unsigned compare } IF LSY = TOSY THEN INSTR := BLOS ELSE INSTR := BHIS END ELSE BEGIN { Do a signed compare } IF LSY = TOSY THEN INSTR := BLE ELSE INSTR := BGE END; GENBR (INSTR, 2); IF LC < LCMAX THEN LCMAX := LC END 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; GEN1 (INSTR, INDEX, MP); GENCONST (LATTR.DPLMT); IF CIX-LADDR <= 126 THEN GENBR (BVC, LADDR-CIX-2) ELSE BEGIN GENBR (BVS, 2); GENUJP (LADDR) END; INSERT (LCIX, 2 * (CIX - LCIX)); LC := LC + 2 END; { FORSTATEMENT } PROCEDURE LOOPSTATEMENT (*$Y+*) ; VAR LADDR: ADDRRANGE; LCIX: CODERANGE; BEGIN LADDR := CIX + 1; LOOP REPEAT STATEMENT(FSYS + [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 + [SEMICOLON,ENDSY]); LOAD END ELSE BEGIN ERROR(56); SKIP(FSYS + [SEMICOLON,ENDSY]) END; GEN1(TST,AUTINC,SP); GENBR(BEQ,2); GEN1(JMP,INDEX,PC); GENCONST(0); LCIX := CIX; LOOP REPEAT STATEMENT(FSYS + [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 + [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 + [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS) END; IF SY IN STATBEGSYS + [IDENT] THEN BEGIN CASE SY OF IDENT: BEGIN SEARCHID([VARS,FIELD,FUNC,PROC],LCP); INSYMBOL; IF LCP^.KLASS = PROC THEN CALL(FSYS,LCP) ELSE ASSIGNMENT(LCP) END; BEGINSY: BEGIN INSYMBOL; COMPOUNDSTATEMENT END; GOTOSY: BEGIN INSYMBOL; GOTOSTATEMENT END; IFSY: BEGIN INSYMBOL; IFSTATEMENT END; CASESY: BEGIN INSYMBOL; CASESTATEMENT END; WHILESY: BEGIN INSYMBOL; WHILESTATEMENT END; REPEATSY: BEGIN INSYMBOL; REPEATSTATEMENT END; LOOPSY: BEGIN INSYMBOL; LOOPSTATEMENT END; FORSY: BEGIN INSYMBOL; FORSTATEMENT END; WITHSY: BEGIN INSYMBOL; WITHSTATEMENT END END; IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END END END %STATEMENT\ ; PROCEDURE STARTOFMAIN (*$Y+*) ; VAR LCIX: INTEGER; BEGIN EPMAIN := (CIX + 1); LLC1 := 0 ; { FOR THE MAIN PROGRAM, GENERATE OBJECT CODE TO ENABLE } { THE TASK BUILDER ACTFIL OPTION AND TO DRAW THE FCS } { FILE STORAGE REGION INTO THE SAME SEGEMENT AS THE } { OVERLAY SEGMENT AS THE MAIN PROGRAM WHEN OVERLAYING. } { THIS IS EQUIVALENT TO: F.BFHD == 20 } { .GLOBL .FSRCB } PUTGSD ('F.BFHD ', 2110B {SYMBOL DEF}, 20B); PUTGSD ('.FSRCB ', 2100B {SYMBOL REF}, 0); WRITOBJ (GSD); { PRELOAD A REGISTER WITH START ADDR OF HEAP FOR INIT ROUTINE } GEN2(MOV,AUTINC,PC,REG,R); GENCONST(0); PUTRLD('$$HEAP ',GARENTRY,2*(CODE.LEN-1),0); PUTGSD('$$HEAP ',GLOBALREFFLAGS,0); IF NFILES = 0 THEN { NO FILES HAVE BEEN DECLARED } GENSUBRCALL ( INITN ) { SPECIAL INIT ROUTINE } ELSE BEGIN GENSUBRCALL ( INITA ); { NORMAL INIT ROUTINE } 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 \ ) END; 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 FPPUNIT THEN { INITIALIZE FLOATING POINT PROCESSOR } GENSUBRCALL (FPINI) END; PROCEDURE NEWMODULE (*$Y-*) (* CONTIGUOUS MODULE *); VAR RTR: RUNTIMEROUTS; BEGIN IF FIRSTMODULE THEN FIRSTMODULE := FALSE ELSE BEGIN IF GSD.LEN > 1 THEN WRITOBJ( GSD ); GSD.VALUE[1] := 2 % EGSD \ ; WRITOBJ( GSD ); GSD.VALUE[1] := 6 % EM \ ; WRITOBJ( GSD ); GSD.VALUE[1] := 1 % GSD \ ; (*$Z+*) (* NEW MODULE *) IF PRCODE THEN BEGIN WRITELN(CEX,'.END':30); PAGE(CEX); END; (*$Z-*) END; PUTGSD ( PSECT, 0 % MODULE NAME \, 0 ); PUTGSD ( OBJIDENT, 3000B % MODULE IDENT \, 0 ); WRITOBJ( GSD ); FOR RTR := ERRN TO DUMRTR DO NOTCALLED[RTR] := TRUE; (*$Z+*) IF PRCODE THEN WRITELN( CEX, ' .TITLE ',PSECT); (*$Z-*) END % NEWMODULE \ ; PROCEDURE ENTERBODY; VAR LCIX: INTEGER; LCP: CTP; I: INTEGER; BEGIN (* MNC - INITIALIZE INFO ABOUT PREV INSTRS: *) FOR I := -1 TO 0 DO WITH PREV[I] DO BEGIN LOCINSTR := -1; OPCODE := HALT; SUBRNAME := DUMRTR; END; IF PSECTGEN OR FIRSTMODULE THEN NEWMODULE; PUTRLD ( PSECT, 7, 0, 2*(CIX+1) ) ; WRITOBJ ( RLD ) ; (*$Z+*) IF PRCODE THEN BEGIN WRITELN(CEX); WRITELN(CEX); WRITELN(CEX); WRITELN(CEX,'.PSECT':30,PSECT:15) END; (*$Z-*) LCP := FPROCP; IF FPROCP <> NIL THEN WITH FPROCP^ DO BEGIN PFADDR := 2 * (CIX + 1); LLC1 := PARLISTSIZE; GLOBALDEF ( PSECT, PFADDR ) ; END %WITH FPROCP\ ELSE BEGIN STARTOFMAIN; NEW(LCP,PROC,STANDARD); WITH LCP^ DO BEGIN SELFCTP := 0; IDTYPE := NIL; NAME := PSECT; LLINK := NIL; RLINK := NIL; NEXT := NIL; END; END; GEN2(MOV,REG,SP,REG,AD); GEN2(MOV, REG,MP,AUTDEC,SP); GEN2(MOV, REG,AD,REG,MP); %ENTER BODY INSTRUCTIONS\ IF TESTPACKED THEN GENSUBRCALL(CLRSTK) ELSE GEN2(SUB,AUTINC,PC,REG,SP); GENCONST(0); CIX1 := CIX; IF ONSWITCH['D'] THEN BEGIN IF DEBUG THEN BEGIN COPYTREE ( DISPLAY[TOP].FNAME, LCP ); GEN2 ( MOV,AUTINC,PC,INDEX,MP ); GENCONST(0); PUTRLD ('$DDTDF ', GARENTRY, 2*(CODE.LEN-1), 2*LCP^.SELFCTP); GENCONST (-4) END; GEN2(MOV,INDEX,GP,INDEX,MP); GENCONST(2); GENCONST(-6); (* LINE NUMBER *) IF FPROCP = NIL THEN BEGIN LCP := NIL; COPYTREE( DISPLAY[0].FNAME, LCP ); GEN2(MOV,AUTINC,PC,INDEX,GP); GENCONST(0); PUTRLD('$DDTDF ',GARENTRY,2*(CODE.LEN-1), 2*LCP^.SELFCTP); GENCONST(-6); GEN2( MOV,AUTINC,PC,INDEX,GP); GENCONST(0); PUTRLD('$DDTDF ',GARENTRY,2*(CODE.LEN-1),2*INTPTR^.SELFSTP); GENCONST(-8); GEN2 ( MOV,AUTINC,PC,INDEX,GP ); GENCONST(0); PUTRLD('$DDTDF ',GARENTRY,2*(CODE.LEN-1),2*REALPTR^.SELFSTP); GENCONST(-10); GEN2 ( MOV,AUTINC,PC,INDEX,GP ); GENCONST(0); PUTRLD('$DDTDF ',GARENTRY,2*(CODE.LEN-1),2*BOOLPTR^.SELFSTP); GENCONST(-12); GEN2 ( MOV,AUTINC,PC,INDEX,GP ); GENCONST(0); PUTRLD('$DDTDF ',GARENTRY,2*(CODE.LEN-1),2*CHARPTR^.SELFSTP); GENCONST(-14); GEN2( MOV,INDEX,PC,INDEX,GP); GENCONST(0); PUTRLD('$DDTDF ',GADRENTRY,2*(CODE.LEN-1),0); GENCONST(-16); GENSUBRCALL ( DDTINIT ); END; END; IF HEAPCHECK THEN BEGIN LINENODEF; GENSUBRCALL(OVFLCHK); END; LCMAX := LC; END % ENTERBODY \; PROCEDURE LEAVEBODY; VAR LCIX: INTEGER; BEGIN LLP := FSTLABP; %TEST FOR UNDEFINED LABELS\ WHILE LLP <> FLABP DO WITH LLP^ DO BEGIN IF NOT DEFINED THEN BEGIN IF LABCHAIN = NIL THEN ERROR(901) ELSE ERROR(168); IF LIST THEN BEGIN WRITELN; WRITELN(' LABEL ',LABVAL) END; END; LLP := NEXTLAB END; IF FPROCP = NIL THEN BEGIN IF ONSWITCH['Q'] THEN BEGIN GENSUBRCALL ( FREQV ); GENCONST(ORD(FILENAME[8])+256*ORD(FILENAME[9])); GENCONST(ORD(FILENAME[6])+256*ORD(FILENAME[7])); GENCONST(ORD(FILENAME[4])+256*ORD(FILENAME[5])); GENCONST(ORD(FILENAME[2])+256*ORD(FILENAME[3])); GENCONST(ORD(FILENAME[0])+256*ORD(FILENAME[1])); GENCONST(0); PUTRLD ( LASTLINE.LLPSECT,15B % PSECT ADD.REL. \, 2*(CODE.LEN-1),2*LASTLINE.LLADDR); END; IF ONSWITCH['D'] THEN BEGIN PUTRLD('$DDTDF ',7,0,0); IF CODE.LEN>1 THEN WRITOBJ(CODE); IF RLD.LEN>1 THEN WRITOBJ( RLD); LCIX := CIX; CIX := -1; GENCONST(0); CIX := LCIX; PUTRLD(LASTLINE.LLPSECT,15B, %PSECT ADD RELOC\ 2*(CODE.LEN-1),2*LASTLINE.LLADDR); PUTRLD(PSECT,7,0,2*(CIX+1)); WRITOBJ(CODE); WRITOBJ(RLD); PUTGSD ('$DDTDF ', 2750B { GBL,D }, 2*(DCIX+1)); PUTGSD ('$DDTDF ', GLOBALDEFFLAGS, 0); DATASIZE := DATASIZE + 2000; END; GEN2 (MOV,AUTINC,PC,AUTDEC,SP); GENCONST (1); { EX$SUC SUCCESSFUL EXIT STATUS } IF NFILES = 0 THEN GENSUBRCALL ( EXITN ) ELSE GENSUBRCALL ( EXITP ); END ELSE BEGIN IF ONSWITCH['D'] THEN BEGIN GEN2(MOV,INDEX,MP,INDEX,GP); GENCONST(-6); GENCONST(2); (* LINE NUMBER *) END; GEN2(MOV,AUTDEC,MP,REG,MP); GEN2(ADD,AUTINC,PC,REG,SP); GENCONST(LLC1 - LCMAX); %RETURN FROM BODY INSTRUCTIONS\ GEN1(RTS,REG,PC); END; I := -LCMAX - 2; DATASIZE := DATASIZE + I; IF TESTPACKED THEN INSERT(CIX1,I DIV 2) %NUMBER OF WORDS\ ELSE INSERT(CIX1,I); FSTLABP := FLABP ; IF CODE.LEN > 1 THEN WRITOBJ ( CODE ) ; IF RLD.LEN > 1 THEN WRITOBJ ( RLD ) ; PSECTDEF ( PSECT, 2*(CIX+1) ) ; CIXX := CIXX + CIX + 1 ; IF ( FPROCP = NIL ) OR ( SY = PERIOD ) THEN BEGIN IF FPROCP = NIL THEN { MAIN PROGRAM } BEGIN IF ONSWITCH['D'] THEN PUTGSD ('PAS$IN ', GLOBALDEFFLAGS, 2*EPMAIN) ELSE PUTGSD (PSECT, 1400B { TRANSFER ADDRESS }, 2*EPMAIN) ; DATASIZE := DATASIZE + 200; { ADD EXTRA STACK/HEAP WORKSPACE } { .PSECT $99999 OVR,RO,REL,GBL,D } { .BLKB DATASIZE } PUTGSD ('$99999 ', 2774B, DATASIZE ); END; WRITOBJ ( GSD ) ; GSD.VALUE [ 1 ] := 2 % EGSD \ ; WRITOBJ ( GSD ) ; GSD.VALUE [ 1 ] := 6 % EM \ ; WRITOBJ ( GSD ) ; END ELSE IF GSD.LEN > 1 THEN WRITOBJ ( GSD ) ; CIX := OLDCIX ; PSECT := OLDPSECT ; GLOBALINDEX := OLDGLOBALINDEX ; END % LEAVE BODY \; (*$Y+*) (* MODULE SPLITTING AGAIN *) (* MNC - SEE PREV TWO NEW PROCEDURES FOR MISSING CODE. ALLOWS HEAVIER OVER- LAYING. ALSO NOTE THAT LOOP STATEMENT AROUND THE CALL TO PROCEDURE STATEMENT HAS BEEN REMOVED. PROCEDURE STATEMENT IS NOW BEING ASKED TO CALL COMPOUNDSTATEMENT WHICH WILL PROCESS THE BEGIN,END PAIR WHICH SURROUND THE PROCEDURE BODY. HAVING BODY CALL STATEMENT ONLY ONCE SPEEDS UP HUGPAS AND BIGPAS GREATLY BY REDUCING OVERLAY SWPNG. NOTE ALSO REQUIRED CHANGE TO PROCEDURE BLOCK: *) BEGIN % BODY \ ENTERBODY; STATEMENT(FSYS + [SEMICOLON,ENDSY]); LEAVEBODY; END % BODY \ ; (*$Y+*) BEGIN (* BLOCK *) HEAPMARK(HEAPM); TESTPACKED := ONSWITCH['D']; FLABP := FSTLABP; DP := TRUE; IF NOT MAIN AND (LEVEL = 1) THEN FSYS := FSYS + [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 (* MNC - NOTE CHANGE IN FOLLOWING LINE TO ALLOW PROCEDURE COMPOUNDSTMT TO PROCESS THE BEGIN,END OF A PROCEDURE BODY. SEE PREVIOUS MNC COMMENT AT BODY OF PROCEDURE BODY: *) IF SY <> BEGINSY THEN ERROR(17); REPEAT BODY(FSYS + [CASESY, FSY]); IF ( SY <> FSY ) AND ( SY <> PERIOD ) THEN BEGIN ERROR(6); SKIP(FSYS + [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 } MAIN := MAIN AND NOT OFFSWITCH['M'] OR ONSWITCH['M']; DEBUG := DEBUG AND NOT OFFSWITCH['D'] OR ONSWITCH['D']; FREQUENCE := FREQUENCE AND NOT OFFSWITCH['Q'] OR ONSWITCH['Q']; WARNINGS := WARNINGS AND NOT OFFSWITCH['W'] OR ONSWITCH['W']; CONDCOMP := CONDCOMP AND NOT OFFSWITCH['X'] OR ONSWITCH['X']; { SENSE OPTIONS THAT MUST BE AT START OF PROGRAM } IF DEBUG THEN ONSWITCH['D'] := TRUE ELSE OFFSWITCH['D'] := TRUE; IF FREQUENCE THEN ONSWITCH['Q'] := TRUE ELSE OFFSWITCH['Q'] := TRUE; GLOBALSIZE := HIDDENLEN ; { SPACE FOR HIDDEN GLOBAL VARIABLES } FILES[TTY] := 'TTY ' ; FILES[TTYIN] := 'TTYIN ' ; FILES[INPUT] := 'INPUT ' ; FILES[OUTPUT] := 'OUTPUT ' ; INPUTPTR := NIL ; OUTPUTPTR := NIL ; TTYINPTR := NIL ; TTYOUTPTR := NIL ; GIVENFILES := [] ; INPUTDECLARED := FALSE ; OUTPUTDECLARED := FALSE ; NFILES := 0 ; 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} INPUTDECLARED := TRUE; OUTPUTDECLARED := TRUE END ; IF HEAD AND (SY=LPARENT) THEN BEGIN INSYMBOL ; LOOP IF ID = FILES[TTY] THEN GIVENFILES := GIVENFILES + [TTY,TTYIN] ELSE IF ID = FILES[INPUT] THEN BEGIN GIVENFILES := GIVENFILES + [INPUT]; INPUTDECLARED := TRUE END ELSE IF ID = FILES[OUTPUT] THEN BEGIN GIVENFILES := GIVENFILES + [OUTPUT]; OUTPUTDECLARED := TRUE END ELSE ERROR (921) ; 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] ; { DEFINE THE FILES REQUIRED BY DEBUG AND FREQUENCE } IF ONSWITCH['D'] THEN GIVENFILES := GIVENFILES + [TTY,TTYIN,OUTPUT]; IF FREQUENCE THEN GIVENFILES := GIVENFILES + [OUTPUT]; 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 ELSE NFILES := NFILES + 1 ; { COUNT NON-TTY FILES } 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 ; 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']; PSECTGEN := PSECTGEN AND NOT OFFSWITCH['Y'] OR ONSWITCH['Y']; HEAPCHECK := HEAPCHECK AND NOT OFFSWITCH['T'] OR ONSWITCH['T']; RUNTMCHECK := RUNTMCHECK AND NOT OFFSWITCH['R'] OR ONSWITCH['R']; EXTSET := EXTSET OR FLTSET OR FPPUNIT ; TRACE := TRACE AND NOT OFFSWITCH['S'] OR ONSWITCH['S']; IF FREQUENCE OR TRACE OR DEBUG THEN BEGIN HEAPCHECK := TRUE; ONSWITCH['T'] := TRUE END; IF DEBUG THEN BEGIN PSECTGEN := FALSE; OFFSWITCH['Y'] := TRUE; ONSWITCH['Y'] := FALSE; END; OFFSWITCH['D'] := NOT ONSWITCH['D']; OFFSWITCH['Q'] := NOT ONSWITCH['Q']; LASTLINE.LLADDR := 0; LASTLINE.LLPSECT := PSECT; IF FREQUENCE THEN ONSWITCH['Q'] := TRUE; IF DEBUG THEN LC := -502 {WORKING SPACE FOR DEBUGGER} END { PROGRAMHEADING } ; PROCEDURE ENTERSTANDARD (*$Y+*) ; VAR CP,CP1: CTP; I: INTEGER; LVP: CSP; SP: STP; NA: ARRAY [1..60] OF ALFA; VAL: ARRAY [0..8] OF INTEGER; BEGIN % 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 '; NA[59] := 'NOCR '; NA[60] := 'FDFTN '; VAL[0] := 10; VAL[1] := 32767; VAL[2] := 100000B; VAL[3] := 077777B; VAL[4] := 032400B; VAL[5] := 000001B; VAL[6] := 177777B; VAL[7] := 000000B; VAL[8] := 000000B; END %STANDARDNAMES\ ; { ENTER UNDERLYING TYPES } { ====================== } 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); BEGIN NEW(CP,TYPES); { STANDARD TYPE 'TEXT' } WITH CP^ DO BEGIN NAME := 'TEXT '; IDTYPE := TEXTPTR; END; ENTERID(CP); { PREDEFINED INTEGER AND REAL CONSTANTS } { ===================================== } FOR I := 0 TO 5 DO { ALFALENG TO MINREAL } BEGIN NEW(CP,KONST); 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; { PREDEFINED TYPE 'IOSPEC = (RANDOM,UPDATE,...)' } { =============================================== } 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 9 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 \ ; { PREDEFINED TYPES 'ASCII' AND 'BYTE' } { =================================== } 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 \; { BOOLEAN CONSTANTS: 'FALSE', 'TRUE' } { ================================== } CP1 := NIL; FOR I := 1 TO 2 DO BEGIN NEW(CP,KONST); WITH CP^ DO BEGIN NAME := NA[I]; IDTYPE := BOOLPTR; NEXT := CP1; VALUES.IVAL := I - 1 END; ENTERID(CP); CP1 := CP END; BOOLPTR^.FCONST := CP; { STANDARD PROCEDURES } { =================== } FOR I := 5 TO 22 DO IF (I<18) OR (DEFLEVEL>=1) THEN BEGIN NEW(CP,PROC,STANDARD); WITH CP^ DO BEGIN NAME := NA[I]; IDTYPE := NIL; NEXT := NIL; KEY := I - 4; END; ENTERID(CP) END; { STANDARD FUNCTIONS: 'ABS' TO 'SIZE' } { ==================================== } FOR I := 23 TO 44 DO IF (I<36) OR (DEFLEVEL>=1) THEN BEGIN NEW(CP,FUNC,STANDARD); WITH CP^ DO BEGIN NAME := NA[I]; IDTYPE := NIL; NEXT := NIL; KEY := I - 22; END; ENTERID(CP); END; NEW(CP,VARS); %PARAMETER OF PREDECLARED FUNCTIONS\ WITH CP^ DO BEGIN NAME := ' '; IDTYPE := REALPTR; VKIND := ACTUAL; NEXT := NIL; VLEV := 1; VADDR := 0 END; { ENTER UNDECLARED } { ================ } NEW(UTYPPTR,TYPES); WITH UTYPPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL END; NEW(UCSTPTR,KONST); WITH UCSTPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; NEXT := NIL; VALUES.IVAL := 0 END; NEW(UVARPTR,VARS); WITH UVARPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; VKIND := ACTUAL; NEXT := NIL; VLEV := 0; VADDR := 0 END; NEW(UFLDPTR,FIELD); WITH UFLDPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; NEXT := NIL; FLDADDR := 0 END; NEW(UPRCPTR,PROC,DECLARED,ACTUAL); WITH UPRCPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; DECLPLACE := INTERNAL; NEXT := NIL; EXTNAME := NIL; PFLEV := 0; PFADDR :=0; END; NEW(UFCTPTR,FUNC,DECLARED,ACTUAL); WITH UFCTPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; NEXT := NIL; DECLPLACE := INTERNAL; EXTNAME := NIL; PFLEV := 0; PFADDR := 0; END (* ADJUST INPUT ETC BECAUSE PRORAMHEADING IS CALLED BEFORE ENTERST *) IF INPUTPTR <> NIL THEN INPUTPTR^.IDTYPE := TEXTPTR; IF OUTPUTPTR <> NIL THEN OUTPUTPTR^.IDTYPE := TEXTPTR; IF TTYINPTR <> NIL THEN TTYINPTR^.IDTYPE := TEXTPTR; IF TTYOUTPTR <> NIL THEN TTYOUTPTR^.IDTYPE := TEXTPTR; WITH DISPLAY[1] DO BEGIN FNAME := NIL; OCCUR := BLCK END; TOP := 1; LEVEL := 1; CIXX := CIX; END %ENTERSTANDARD\ ; PROCEDURE OPENFILES (*$Y+*) ; BEGIN RTIME := RUNTIME; LEVEL := 0; TOP := 0; WITH DISPLAY[0] DO BEGIN FNAME := NIL; OCCUR := BLCK END; DATE (DATESTR); TIME (TIMESTR); READFILEIDENTIFIER ( DEFLEVEL, PAGEWIDTH, LINEWIDTH, ONSWITCH, OFFSWITCH, MCRLINE, MCRLEN, MCRINX, FILENAME, PDP11OBJ, (*$Z+*) OUTPUTHGH, (*$Z-*) INPUT, OUTPUT (*$Z+*) , CEX (*$Z-*) ); LIST := LIST AND NOT OFFSWITCH['L'] OR ONSWITCH['L']; PRCODE := PRCODE AND NOT OFFSWITCH['C'] OR ONSWITCH['C']; END % OPENFILES \ ; PROCEDURE WRITESTAT; (*$Y+*) BEGIN RTIME := RUNTIME - RTIME; WRITELN; IF ERRDETECTED THEN WRITE('****') ELSE WRITE('NO'); WRITELN(' ERROR DETECTED'); WRITELN('TOTAL PROGRAM SIZE ', 2*(CIXX+1):7:O); WRITELN('OUTERMOST DATA SIZE ', -LC:7:O ); WRITELN('RESERVED STACK & HEAP ', DATASIZE:7:O); WRITELN('COMPILATION TIME ',RTIME:1,' SECONDS'); WRITELN; WRITELN ( MCRLINE : MCRLEN ); END; (*$Y-*) PROCEDURE FINISH; PROCEDURE EXITST ( I: INTEGER ); EXTERN; BEGIN SRCLEVEL := -1; ENDOFLINE; IF LIST THEN WRITESTAT; IF ERRDETECTED THEN EXITST (2 {EX$ERR}) END; (* FINISH *) (*$Y+*) BEGIN (* MAIN PROGRAM *) INIT1; INIT2; INIT3; %OPEN COMPILER FILES\ %*******************\ OPENFILES; %COMPILE:\ %********\ PROGRAMHEADING ; ENTERSTANDARD ; BLOCK(BLOCKBEGSYS + STATBEGSYS - [CASESY],PERIOD,NIL); FINISH END (*$Y+*) (* HEAP IN SEPARATE MODULE *) .