Trailing-Edge
-
PDP-10 Archives
-
decuslib10-06
-
43,50417/pascal.pas
There are no other files named pascal.pas in the archive.
00010 (*$T-,S1300,R16*)
00020 (********************************************************************************
00030 *
00040 * DECSYSTEM-10 PASCAL COMPILER
00050 * ****************************
00060 *
00070 * (C) COPYRIGHT H.-H. NAGEL
00080 * INSTITUT FUER INFORMATIK
00090 * DER UNIVERSITAET HAMBURG
00100 * SCHLUETERSTRASSE 70
00110 * 2000 HAMBURG-13
00120 * GERMANY
00130 * 1976
00140 *
00150 * MAR-73 SYNTAX ANALYSIS INCLUDING ERROR HANDLING,
00160 * CHECKS BASED ON DECLARATIONS AND ADDRESS-
00170 * AND CODE-GENERATION FOR A HYPOTHETICAL
00180 * STACK COMPUTER BY URS AMMAN
00190 *
00200 * FACHGRUPPE COMPUTER-WISSENSCHAFTEN
00210 * EIDG. TECHNISCHE HOCHSCHULE
00220 * CH-8006 ZUERICH
00230 *
00240 * DEC-73 CODE-GENERATION FOR DECSYSTEM-10
00250 * BY C.O. GROSSE-LINDEMANN, F.W. LORENZ,
00260 * H.H. NAGEL AND P.J. STIRL /1/
00270 *
00280 * JUL-74 IMPLEMENTATION OF NEW FEATURES BY STUDENTS
00290 * DURING A PRACTICAL PROGRAMMING COURSE /2/
00300 *
00310 * DEC-74 MODIFICATIONS TO GENERATE RELOCATABLE
00320 * LINK-10 OBJECT-CODE BY E. KISICKI
00330 *
00340 * DEC-74 DEBUG SYSTEM /5/
00350 * BY P. PUTFARKEN
00360 *
00370 * APR-76 POST-MORTEM DUMP FACILITY /6/
00380 * BY B. NEBEL AND B. PRETSCHNER
00390 *
00400 * AUG-76 IMPROVEMENTS AND ADAPTATION TO STANDARD-PASCAL
00410 * AND CDC 6000-3.4. PASCAL AS PRESENTED IN
00420 * "PASCAL - USER MANUAL AND REPORT" /3,4,7/
00430 * BY E.KISICKI
00440 *
00450 * NOV-76 FORMAL PROCEDURE/FUNCTION PARAMETERS
00460 * AND CORRECTION OF ERRORS
00470 * BY H. LINDE
00480 *
00490 * INSTITUT FUER INFORMATIK
00500 * SCHLUETERSTRASSE 70
00510 * D-2000 HAMBURG 13
00520 *
00530 * /1/ F.W. LORENZ, P.J. STIRL
00540 * UEBERTRAGUNG EINES PASCAL-COMPILERS AUF DAS DECSYSTEM-10
00550 * DIPLOMARBEIT, IFI, HH, 74
00560 *
00570 * C.O. GROSSE-LINDEMANN, H.H. NAGEL
00580 * POSTLUDE TO A PASCAL-COMPILER BOOTSTRAP
00590 * BERICHT NR. 11, IFI, HH, 74
00600 *
00610 * C.O. GROSSE-LINDEMANN
00620 * WEITERFUEHRENDE ARBEITEN AM PASCAL-COMPILER ZUR
00630 * STEIGERUNG DER BENUTZERFREUNDLICHKEIT
00640 * DIPLOMARBEIT, IFI, HH, 75
00650 *
00660 * /2/ ERWEITERUNG VON SPRACHDEFINITION, COMPILER UND LAUFZEIT-
00670 * UNTERSTUETZUNG BEI PASCAL/ ERGEBNISSE EINES PRAKTIKUMS
00680 * IM INFORMATIK GRUNDSTUDIUM
00690 * STUD. BEITRAEGE BEARBEITET VON H.H. NAGEL
00700 * MITTEILUNGEN NR. 16, IFI, HH, 75
00710 *
00720 * /3/ H.H. NAGEL
00730 * PASCAL FOR DECSYSTEM-10/ EXPERIENCES AND FURTHER PLANS
00740 * MITTEILUNGEN NR. 21, IFI, HH, NOV-75
00750 *
00760 * /4/ KATHLEEN JENSEN, NIKLAUS WIRTH
00770 * PASCAL USER MANUAL AND REPORT
00780 * LECTURE NOTES IN COMPUTER SCIENCE VOL 18
00790 * SPRINGER-VERLAG BERLIN-HEIDELBERG-NEW YORK
00800 *
00810 * /5/ P. PUTFARKEN
00820 * TESTHILFEN FUER PASCAL PROGRAMME
00830 * DIPLOMARBEIT, IFI, HH, 76
00840 *
00850 * /6/ B. NEBEL, B. PRETSCHNER
00860 * ERWEITERUNG DES DECSYSTEM-10 PASCAL COMPILERS UM
00870 * EINE MOEGLICHKEIT ZUR ERZEUGUNG EINES POST-MORTEM DUMP
00880 * MITTEILUNGEN NR. 34 , IFI, HH, JUN-76
00890 *
00900 * /7/ E. KISICKI, H.H. NAGEL
00910 * PASCAL FOR THE DECSYSTEM-10
00920 * MITTEILUNGEN NR. , IFI, HH, NOV-76
00930 *
00940 ********************************************************************************)
00950
00960
00970
00980
00990 (********************************************************************************
01000 *
01010 * HINTS TO INTERPRET ABBREVIATIONS
01020 *
01030 * BRACK : BRACKET "[ ]" IX : INDEX
01040 * C : CURRENT L : LOCAL
01050 * C : COUNTER L : LEFT
01060 * CST : CONSTANT PARENT : "( )"
01070 * CTP : IDENTIFIER POINTER P/PTR : POINTER
01080 * EL : ELEMENT P/PROC : PROCEDURE
01090 * F : FORMAL R : RIGHT
01100 * F : FIRST S : STRING
01110 * F : FILE SY : SYMBOL
01120 * F/FUNC : FUNCTION V : VARIABLE
01130 * G : GLOBAL V : VALUE
01140 * ID : IDENTIFIER BP : BYTEPOINTER
01150 * REL : RELATIVE REL : RELOCATION
01160 *
01170 ********************************************************************************)
01180
01190
01200
01210
01220 (********************************************************************************
01230 *
01240 * FILES NECESSARY TO IMPLEMENT THE PASCAL COMPILER
01250 *
01260 * SOURCE-CODE
01270 *
01280 * PASCAL.PAS : PASCAL
01290 *
01300 * LIBPAS.PAS : CCL (OPTION, GETOPTION, GETFILENAME, GETPARAMETER)
01310 * DDT (DEBUG)
01320 * STATUS (GETSTATUS)
01330 * READ (READIRANGE, READCRANGE, READRRANGE, READSCALAR,
01340 * READISET, READCSET, READDSET)
01350 * WRITE (WRTSCALAR, WRTISET, WRTDSET,WRTCSET)
01360 * UNDEFINED (UNDEFINED)
01370 *
01380 * LIBMAC.MAC : MACRO RUNTIME SUPPORT
01390 *
01400 * CROSS.PAS : CROSS REFERENCE WITHOUT CODE-GENERATION
01410 *
01420 *
01430 * OBJECT-CODE
01440 *
01450 * PASLIB.REL : SEARCH LIBRARY CONTAINING LIBPAS.REL
01460 * AND LIBMAC.REL
01470 *
01480 *
01490 * EXECUTABLE-CODE
01500 *
01510 * PASCAL.LOW : PASCAL LOW-SEGMENT
01520 * PASCAL.SHR : PASCAL SHARED HIGH-SEGMENT
01530 * CROSS.LOW : CROSS LOW-SEGMENT
01540 * CROSS.SHR : CROSS SHARED HIGH-SEGMENT
01550 *
01560 *
01570 * INFORMATION AND MAINTENANCE
01580 *
01590 * PASCAL.DOC : A GUIDE FOR THE DECSYSTEM-10 PASCAL DIALECT
01600 *
01610 *******************************************************************************)
01620
01630
01640
01650
01660 (*******************************************************************************
01670 *
01680 * HOW TO GENERATE A NEW PASCAL COMPILER
01690 *
01700 * 1) CHANGES TO THE RUNTIME-SUPPORT
01710 *
01720 * LET LIBPAS.PAS AND LIBMAC.MAC BE YOUR MODIFIED RUNTIME SUPPORT
01730 *
01740 * .COMPILE LIBMAC.MAC/LIST
01750 * ...
01760 * .COMPILE LIBPAS.PAS(EXTERN/NOCHECK)/LIST
01770 * PASCAL: LIBPAS [CCL: OPTION, ... ]
01780 * ...
01790 * PASCAL: LIBPAS [DEBUG: DEBUG]
01800 * ...
01810 * EXIT
01820 * .RENAME PASLIB.OLD=PASLIB.REL
01830 * .R FUDGE2
01840 * *PASLIB=LIBPAS,LIBMAC/A$
01850 * *PASLIB=PASLIB/X$
01860 * *^C
01870 *
01880 *
01890 * 2) CHANGES TO THE COMPILER
01900 *
01910 * LET PASCAL.PAS BE YOUR NEW COMPILER SOURCE
01920 * (DO NOT FORGET TO CHANGE THE "HEADER" AND CHECK FOR THE CORRECT
01930 * FILE DESCRIPTIONS FOR PASLIB AND CROSS IN INITPROCEDURE
01940 * "SEARCH LIBRARIES")
01950 *
01960 * .EXECUTE P1=PASCAL(NOCHECK/CODESIZE:1300/RUNCORE:16)
01970 * PASCAL: P1 [PASCAL]
01980 * 0 ERROR(S) DETECTED
01990 * ...
02000 * LINK: LOADING
02010 * [...P1 EXECUTION]
02020 * OBJECT= P2.REL/CODESIZE:1300/RUNCORE:16/NOCHECK/EXECUTE/CREF
02030 * LIST= <CR>
02040 * SOURCE= PASCAL.PAS
02050 * PASCAL: P2 [PASCAL]
02060 * 0 ERROR(S) DETECTED
02070 * ...
02080 * CROSS: P2
02090 * NO ERROR IN BLOCKSTRUCTURE
02100 * LINK: LOADING
02110 * [...P2 EXECUTION]
02120 * OBJECT= P3.REL/CODESIZE:1300/RUNCORE:16/NOCHECK
02130 * LIST= <CR>
02140 * SOURCE= PASCAL.PAS
02150 * PASCAL: P3 [PASCAL]
02160 * 0 ERROR(S) DETECTED
02170 * ...
02180 * EXIT
02190 * .R FILCOM
02200 * *TTY:=P2.REL,P3.REL
02210 * NO DIFFERENCES ENCOUNTERED
02220 * *^C
02230 * .DELETE P1.*,P3.*
02240 * .RENAME PASCAL.*=P2.*
02250 * .RENAME PASCAL.OLD=PASCAL.PAS
02260 * .RENAME PASCAL.PAS=PASCAL.NEW
02270 * .PRINT PASCAL.CRL
02280 * .LOAD PASCAL/MAP
02290 * .SSAVE PASCAL
02300 *
02310 *
02320 * 3) CHANGES TO CROSS
02330 *
02340 * .LOAD CROSS(NOCHECK)/LIST/COMPILE
02350 * ...
02360 * EXIT
02370 * .SSAVE CROSS
02380 *
02390 ********************************************************************************)
02400
02410
02420 (*******************************************************************************
02430 *
02440 * KNOWN BUGS AND RESTRICTIONS
02450 *
02460 * 1) IF THE DEVICE-PARAMETER FOR RESET/REWRITE IS NOT
02470 * DEFAULTED, NEW BUFFERS ARE ALLOCATED WITHOUT REGARD
02480 * TO THE FACT THAT THE NEW DEVICE COULD BE THE SAME AS THE
02490 * THE OLD DEVICE.
02500 *
02510 * 2) COMPARISON OF VARIABLES OF TYPE PACKED RECORD OR
02520 * PACKED ARRAY MAY CAUSE TROUBLE IF THESE VARIABLES APPEAR
02530 * IN A VARIANT PART OR WERE ASSIGNED FROM A VARIANT PART
02540 *
02550 * 3) TOO LARGE ARRAY DIMENSIONS (F.E. MININT..MAXINT) CAUSE
02560 * ARITHMETIC OVERFLOW INSTEAD OF AN APPROPRIATE ERROR
02570 * MESSAGE
02580 *
02590 * 4) ARRAYS OF FILE AND RECORDS WITH FILES AS COMPONENTS
02600 * ARE NOT IMPLEMENTED
02610 *
02620 * 5) SEGMENTED FILES ARE NOT IMPLEMENTED
02630 *
02640 * 6) CALL OF EXTERNAL COBOL OR ALGOL PROCEDURES IS
02650 * NOT IMPLEMENTED
02660 *
02670 *
02680 ********************************************************************************)
02690
02700
02710
02720
02730 PROGRAM PASCAL;
02740
02750 LABEL
02760 0;
02770
02780 CONST
02790
02800 (* NIL = 377777B; *)
02810 (* ALFALENGTH = 10; *)
02820 (* MININT = 400000000000B; *)
02830 (* MAXINT = 377777777777B; *)
02840 (* MAXREAL = 1.7014118432E+38; *)
02850 (* SMALLREAL= 1.4693680107E-39; *)
02860
02870 HEADER = 'PASCAL VERSION FROM 30-DEC-76';
02880
02890 (*COMPILER PARAMETERS:*)
02900 (**********************)
02910
02920 DISPLIMIT = 20; (* MAXIMUM DECLARATION-SCOPE NESTING *)
02930 MAX_FILE = 12; (* MAXIMUM NUMBER OF USER-DECLARED FILES *)
02940 MAX_CHANNEL = 15; (* HIGHEST DATA-CHANNEL ASSIGNED TO A FILE *)
02950 MAXLEVEL = 10; (* MAXIMUM PROC/FUNC LEVEL *)
02960 STRGLGTH = 120; (* MAXIMUM LENGTH FOR STRING-CONSTANT *)
02970 SIZEOFFILEBLOCK = 21; (* SIZE OF FILE CONTROL-BLOCK *)
02980 CIXMAX = 1000; (* STANDARD SIZE OF CODE-ARRAY *)
02990 MAXERR = 4; (* MAXIMUM OF ERRORS IN 1 SOURCE-LINE *)
03000 LABMAX = 9999; (* MAXIMUM VALUE OF A PROGRAM LABEL *)
03010 BITMAX = 36; (* NR. OF BITS OF 1 DECSYSTEM-10 MACHINE-WORD *)
03020 HWCSTMAX = 377777B; (* MAXIMUM POS. INTEGER IN HALFWORD *)
03030 ENTRYMAX = 20; (* MAXIMUM ENTRIES INTO EXTERN PROGRAM *)
03040 EXTPFMAX = 20; (* MAXIMUM OF EXTERN STANDARD PROC/FUNC *)
03050 STDMAX = 36; (* NR. OF STANDARD NAMES *)
03060 RSWMAX = 42; (* NR. OF RESERVED WORDS *)
03070 RSWMAXP1 = 43; (* RESERVED WORDS PLUS 1 *)
03080 STDCHCNTMAX = 132; (* MAXIMUM OF CHARS IN SOURCE-LINE *)
03090 BASEMAX = 71; (* MAXIMUM VALUE OF A SET ELEMENT *)
03100 OFFSET = 40B; (* USED FOR SETS OF CHARACTERS *)
03110 BUFFER_SIZE = 200B; (* DECSYSTEM-10 DISK-BUFFER SIZE *)
03120 TAGFMAX = 5; (* MAX. NR. OF VARIANTS ALLOWED IN CALL OF "NEW" *)
03130 JUMP_MAX = 50; (* MAX. NR. OF LABEL DECLARATIONS *)
03140
03150 REG0 = 0; (* WORKREGISTER *)
03160 REG1 = 1; (* WORKREGISTER (USED FOR ARRAY-BYTEPOINTERS) *)
03170 REGIN = 1; (* TO INITIALIZE REGC *)
03180 STDPARREGCMAX = 6; (* HIGHEST REGISTER USED FOR PARAMETERS *)
03190 WITHIN = 12; (* FIRST REGISTER FOR WITH-STACK *)
03200 NEWREG = 13; (* LAST PLACE OF NEW-STACK *)
03210 BASIS = 14; (* ADDR OF CURRENT ACTIVATION-REC, STATIC AND DYNAMIC LINK *)
03220 TOPP = 15; (* FIRST FREE WORD IN DATA-STACK *)
03230
03240 JBREL = 44B; (* LOCATION OF (0,HIGHEST LEGAL LOW-SEG ADDRESS) *)
03250 JBSA = 120B; (* LOCATION OF (1ST UNUSED LOW-SEG ADDRESS,START-ADDRESS OF PROGRAM) *)
03260 JBFF = 121B; (* LOCATION OF (0,POINTER BEHIND LAST FILE-BUFFER) *)
03270 JBAPR = 125B; (* LOCATION OF (0,PC AFTER PROGRAM ERROR) *)
03280 JBDDT = 74B; (* LOCATION OF (LAST PASDDT-ADDR, PASDDT-ADDR + 2) *)
03290
03300 TTY_SIXBIT = 646471B; (* SIXBIT REPR. FOR 'TTY ' *)
03310 DSK_SIXBIT = 446353B; (* SIXBIT REPR. FOR 'DSK ' *)
03320 ASCII_MODE = 0; (* (SYSTEM-) FLAGS FOR ASCII-MODE *)
03330 BINARY_MODE = 14B; (* (SYSTEM-) FLAGS FOR BINARY-MODE *)
03340 TEXT_FILE = 0; (* (PASCAL-) FLAGS FOR "PACKED FILE OF (SUBRANGE OF) CHAR" = "TEXT" *)
03350 DATA_FILE = 1; (* (PASCAL-) FLAGS FOR OTHER FILES *)
03360
03370 DEBUG_SAVE = 0B; (* ADDR OF DEBUG-SYSTEM STACK *)
03380 DEBUG_STOP = 1B; (* PUSHJ INTO DEBUG ON "STOP" *)
03390 DEBUG_PAGEHEAD = 2B; (* START OF "STOP"-CHAIN *)
03400 DEBUG_STACKBOTTOM = 3B; (* 1ST WORD OF PROGRAM-STACK *)
03410 DEBUG_INITIALIZATION = 6B; (* PUSHJ INTO DEBUG-INITIALIZATION *)
03420 DEBUG_PROGRAMNAME = 7B; (* ADDR OF ADDR OF PROGRAMNAME *)
03430
03440 SYSTEM_LOW_START = 140B; (* LOC 0B..137B CONTAIN SYSTEM-INFO. *)
03450 SYSTEM_HIGH_START = 400010B; (* LOC 400000B..400007B CONTAIN SYSTEM-INFO. *)
03460
03470 LOW_START = 10B; (* LOC 0B..7B RESERVED FOR DEBUG-PROGR. *)
03480 HIGH_START = 400000B; (* START OF EXECUTABLE CODE *)
03490 MAXADDR = 777777B; (* HIGHEST LEGAL ADDRESS *)
03500
03510 ITEM_1 = 1; (* LINK ITEM 1: CODE *)
03520 ITEM_2 = 2; (* LINK ITEM 2: SYMBOLS *)
03530 ITEM_3 = 3; (* LINK ITEM 3: HIGHSEG *)
03540 ITEM_4 = 4; (* LINK ITEM 4: ENTRIES *)
03550 ITEM_5 = 5; (* LINK ITEM 5: LOW-/ HIGHSEGMENT BREAK *)
03560 ITEM_6 = 6; (* LINK ITEM 6: PROGRAM NAME *)
03570 ITEM_7 = 7; (* LINK ITEM 7: START ADDRESS *)
03580 ITEM_10 = 10B; (* LINK ITEM 10: INTERNAL REQUESTS *)
03590 ITEM_17 = 17B; (* LINK ITEM 17: LINK LIBRARIES *)
03600
03610 ENTRY_SYMBOL = 0; (* ENTRY SYMBOL FLAG *)
03620 GLOBAL_SYMBOL = 1; (* GLOBAL SYMBOL FLAG *)
03630 LOCAL_SYMBOL = 2; (* LOCAL SYMBOL FLAG *)
03640 SIXBIT_SYMBOL = 6; (* SIXBIT SYMBOL FLAG *)
03650 EXTERN_SYMBOL = 14B; (* EXTERN SYMBOL FLAG *)
03660
03670
03680 TYPE
03690
03700 (* INTEGER = MININT..MAXINT *)
03710 (* REAL = -MAXREAL..MAXREAL *)
03720 (* CHAR = ' '..'_' *)
03730 (* ASCII = NUL..DEL *)
03740 (* BOOLEAN = (FALSE,TRUE) *)
03750 (* TEXT = PACKED FILE OF CHAR *)
03760 (* ALFA = PACKED ARRAY[1..ALFALENGTH] OF CHAR *)
03770
03780 (*DESCRIBING:*)
03790 (*************)
03800
03810
03820 (*BASIC SYMBOLS*)
03830 (***************)
03840
03850 SYMBOL = (IDENT,INTCONST,REALCONST,STRINGCONST,NOTSY,MULOP,ADDOP,RELOP,
03860 LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON,PERIOD,ARROW,
03870 COLON,BECOMES,LABELSY,CONSTSY,TYPESY,VARSY,FUNCTIONSY,
03880 PROCEDURESY,PACKEDSY,SETSY,ARRAYSY,RECORDSY,FILESY,FORWARDSY,
03890 BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY,LOOPSY,
03900 GOTOSY,EXITSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY,
03910 EXTERNSY,PASCALSY,FORTRANSY,PROGRAMSY,
03920 THENSY,OTHERSY,INITPROCSY,SEGMENTSY,OTHERSSY);
03930
03940 OPERATOR = (NOOP,MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,
03950 LTOP,LEOP,GEOP,GTOP,NEOP,EQOP,INOP);
03960
03970 SETOFSYS = SET OF SYMBOL;
03980
03990 (*BASIC RANGE DEFINITIONS*)
04000 (*************************)
04010
04020 LEVRANGE = 0..MAXLEVEL;
04030 KEYRANGE = 0..77B;
04040 FILEFORMRANGE = 0..77B;
04050 FILEMODERANGE = 0..77B;
04060 ADDRRANGE = 0..MAXADDR;
04070 INSTRANGE = 0..677B;
04080 RADIXRANGE = 0..37777777777B;
04090 FLAGRANGE = 0..17B;
04100 BITRANGE = 0..BITMAX;
04110 ACRANGE = 0..15;
04120 IBRANGE = 0..1;
04130 CODERANGE = 0..HWCSTMAX;
04140 BITS5 = 0..37B;
04150 BITS6 = 0..77B;
04160 BITS7 = 0..177B;
04170 BITS12 = 0..7777B;
04180 BITS18 = 0..777777B;
04190 SETRANGE = 0..BASEMAX;
04200 JUMP_RANGE = 1..JUMP_MAX;
04210
04220 (*CONSTANTS*)
04230 (***********)
04240
04250 BPOINTER = PACKED RECORD
04260 SBITS,PBITS: BITRANGE;
04270 IBIT,DUMMYBIT: IBRANGE;
04280 IREG: ACRANGE;
04290 RELADDR: ADDRRANGE
04300 END;
04310
04320 CSTCLASS = (INT,REEL,PSET,STRD,STRG,BPTR);
04330
04340 CSP = ^ CONSTNT;
04350 CONSTNT = RECORD
04360 SELFCSP: CSP; NOCODE: BOOLEAN;
04370 CASE CCLASS: CSTCLASS OF
04380 INT : (INTVAL: INTEGER;
04390 INTVAL1:INTEGER (*TO ACCESS SECOND WORD OF PVAL*) );
04400 REEL: (RVAL: REAL);
04410 PSET: (PVAL: SET OF SETRANGE);
04420 STRD,
04430 STRG: (SLGTH: 0..STRGLGTH;
04440 SVAL: PACKED ARRAY [1..STRGLGTH] OF CHAR);
04450 BPTR: (BYTE: BPOINTER)
04460 END;
04470
04480 VALU = RECORD
04490 CASE INTEGER OF
04500 1: (IVAL: INTEGER);
04510 2: (VALP: CSP);
04520 3: (BYTE: BPOINTER)
04530 END;
04540
04550 (*DATA STRUCTURES*)
04560 (*****************)
04570
04580 STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES,TAGFWITHID,TAGFWITHOUTID,VARIANT);
04590 DECLKIND = (STANDARD,DECLARED);
04600
04610 STP = ^STRUCTURE;
04620 CTP = ^IDENTIFIER;
04630 STRUCTURE = PACKED RECORD
04640 SELFSTP: STP; SIZE: ADDRRANGE;
04650 NOCODE: BOOLEAN; BITSIZE: BITRANGE;
04660 CASE FORM: STRUCTFORM OF
04670 SCALAR: (CASE SCALKIND: DECLKIND OF
04680 DECLARED: (DB0: BITS6; FCONST: CTP;
04690 VECTORADDR, VECTORCHAIN: ADDRRANGE;
04700 DIMENSION: INTEGER; NEXTSCALAR: STP;
04710 REQUEST: BOOLEAN; TLEV: LEVRANGE));
04720 SUBRANGE: (DB1: BITS7; RANGETYPE: STP; VMIN, VMAX: VALU);
04730 POINTER: (DB2: BITS7; ELTYPE: STP);
04740 POWER: (DB3: BITS7; ELSET: STP);
04750 ARRAYS: (ARRAYPF: BOOLEAN; DB4: BITS6; ARRAYBPADDR: ADDRRANGE;
04760 AELTYPE, INXTYPE: STP);
04770 RECORDS: (RECORDPF: BOOLEAN; DB5: BITS6;
04780 FSTFLD: CTP; RECVAR: STP);
04790 FILES: (DB6: BITS6; FILEPF: BOOLEAN; FILTYPE: STP;
04800 FILE_FORM: FILEFORMRANGE; FILE_MODE: FILEMODERANGE);
04810 TAGFWITHID,
04820 TAGFWITHOUTID: (DB7: BITS7; FSTVAR: STP;
04830 CASE BOOLEAN OF
04840 TRUE : (TAGFIELDP: CTP);
04850 FALSE: (TAGFIELDTYPE: STP));
04860 VARIANT: (DB9: BITS7; NXTVAR, SUBVAR: STP; FIRSTFIELD: CTP; VARVAL: VALU)
04870 END;
04880
04890 BTP = ^BYTEPOINT;
04900 BYTEPOINT = PACKED RECORD
04910 LAST: BTP;
04920 ARRAYSP: STP;
04930 BITSIZE: BITRANGE
04940 END;
04950
04960 GTP = ^GLOBPTR;
04970 GLOBPTR = RECORD
04980 NEXTGLOBPTR: GTP ;
04990 FIRSTGLOB,
05000 LASTGLOB : ADDRRANGE ;
05010 FCIX : CODERANGE
05020 END ;
05030
05040 FTP = ^FILBLCK;
05050 FILBLCK = PACKED RECORD
05060 NEXTFTP : FTP ;
05070 FILEIDENT : CTP
05080 END ;
05090
05100 PTP = ^PROGRAMPARAMETER;
05110 PROGRAMPARAMETER = PACKED RECORD
05120 NEXTPTP: PTP;
05130 FILEIDPTR: CTP;
05140 FILEID: ALFA;
05150 INPUTFILE: BOOLEAN
05160 END;
05170
05180 (*NAMES*)
05190 (*******)
05200
05210 SCALARFORM = (INTEGERFORM,CHARFORM,REALFORM,BOOLFORM,DECLAREDFORM);
05220 IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC,LABELS);
05230 SETOFIDS = SET OF IDCLASS;
05240 IDKIND = (ACTUAL,FORMAL);
05250 PACKKIND = (NOTPACK,PACKK,HWORDR,HWORDL);
05260
05270 IDENTIFIER = PACKED RECORD
05280 NAME: ALFA;
05290 LLINK, RLINK: CTP;
05300 IDTYPE: STP; NEXT: CTP;
05310 SELFCTP: CTP; NOCODE: BOOLEAN;
05320 CASE KLASS: IDCLASS OF
05330 KONST: (VALUES: VALU);
05340 VARS: (VKIND: IDKIND;
05350 VLEV: LEVRANGE;
05360 CHANNEL: ACRANGE;
05370 VDUMMY1: BITS5;
05380 VDUMMY2: BITS18;
05390 VADDR: ADDRRANGE);
05400 FIELD: (CASE PACKF: PACKKIND OF
05410 NOTPACK,
05420 HWORDL,
05430 HWORDR: (HDUMMY: BITS12; FLDADDR: ADDRRANGE);
05440 PACKK: (PDUMMY: BITS12; FLDBYTE: BPOINTER));
05450 PROC,
05460 FUNC: (CASE PFDECKIND: DECLKIND OF
05470 STANDARD: (KEY: KEYRANGE);
05480 DECLARED: (PFLEV: LEVRANGE;
05490 PARLISTSIZE,PFADDR: ADDRRANGE;
05500 HIGHEST_REGISTER: ACRANGE;
05510 CASE PFKIND: IDKIND OF
05520 ACTUAL: (FORWDECL: BOOLEAN;
05530 EXTERNDECL: BOOLEAN;
05540 ACTIVATED: BOOLEAN;
05550 PFCHAIN:CTP;
05560 LANGUAGE: SYMBOL;
05570 TESTFWDPTR: CTP;
05580 EXTERNALNAME: ALFA;
05590 LINKCHAIN: PACKED ARRAY[LEVRANGE] OF ADDRRANGE);
05600 FORMAL: (FPARAM:CTP)));
05610 LABELS:(SCOPE: LEVRANGE;
05620 JUMP_INDEX: 0..JUMP_MAX;
05630 EXIT_JUMP: BOOLEAN;
05640 GOTO_CHAIN: ADDRRANGE;
05650 LABEL_ADDRESS: ADDRRANGE)
05660 END;
05670
05680
05690 DISPRANGE = 0..DISPLIMIT;
05700
05710 WHERE = (BLCK (* ID IS VARIABLE ID*)
05720 ,CREC (* ID IS FIELD ID OF RECORD WITH CONSTANT ADDRESS*)
05730 ,VREC (* ID IS FIELD ID OF RECORD WITH VARIABLE ADDRESS*)
05740 );
05750
05760 (*RELOCATION*)
05770 (************)
05780
05790 CODEREFS = (NOREF,CONSTREF,EXTERNREF,FORWARDREF,GOTOREF,POINTREF,NOINSTR,SAVEREF,DEBUGREF);
05800
05810 RELBYTE = (NO,RIGHT,LEFT,BOTH);
05820
05830 RELWORD = PACKED ARRAY[0..17] OF RELBYTE;
05840
05850 SUPPORTS = ( STACKOVERFLOW, ERRORINASSIGNMENT, INDEXERROR, OVERFLOW, INPUTERROR,
05860 ERRORINSET, NOCOREAVAILABLE,
05870 ALLOCATE, FREE,
05880 EXITPROGRAM, RUNPROGRAM, READPGMPARAMETER,
05890 RESETFILE, REWRITEFILE, OPENTTY, FORTRANRESET, FORTRANEXIT, CLOSEFILE,
05900 GETCHARACTER, GETFILE, GETLINE, PUTFILE, PUTLINE, PUTPAGE, PUTBUFFER,
05910 INITIALIZEDEBUG, ENTERDEBUG, LOADDEBUG,
05920 CONVERTINTEGERTOREAL,
05930 ASCIITIME, ASCIIDATE,
05940 READREAL, READINTEGER, READCHARACTER, READSTRING, READPACKEDSTRING,
05950 WRITECHARACTER, WRITEDEFCHARACTER,
05960 WRITESTRING, WRITEDEFSTRING,
05970 WRITEPACKEDSTRING, WRITEDEFPACKEDSTRING,
05980 WRITEBOOLEAN, WRITEDEFBOOLEAN,
05990 WRITEREAL, WRITEDEF1REAL, WRITEDEF2REAL,
06000 WRITEINTEGER, WRITEDEFINTEGER,
06010 WRITEHEXADECIMAL, WRITEDEFHEXADECIMAL,
06020 WRITEOCTAL, WRITEDEFOCTAL,
06030 READIRANGE, READCRANGE, READRRANGE,
06040 READSCALAR,
06050 READISET, READCSET, READDSET,
06060 WRTSCALAR,
06070 WRTISET, WRTCSET, WRTDSET);
06080
06090 (*EXPRESSIONS*)
06100 (*************)
06110
06120 ATTRKIND = (CST,VARBL,EXPR);
06130
06140 ATTR = RECORD
06150 TYPTR: STP;
06160 CASE KIND: ATTRKIND OF
06170 CST: (CVAL: VALU);
06180 VARBL: (PACKFG: PACKKIND;
06190 INDEXR: ACRANGE;
06200 INDBIT: IBRANGE;
06210 VLEVEL: LEVRANGE;
06220 BPADDR,DPLMT: ADDRRANGE;
06230 VRELBYTE: RELBYTE;
06240 SUBKIND: STP;
06250 VCLASS: IDCLASS;
06260 VBYTE: BPOINTER);
06270 EXPR: (REG:ACRANGE)
06280 END;
06290
06300 TESTP = ^ TESTPOINTER;
06310 TESTPOINTER = PACKED RECORD
06320 ELT1,ELT2: STP;
06330 LASTTESTP: TESTP
06340 END;
06350
06360
06370 (*OTHER TYPES:*)
06380 (**************)
06390
06400 WRITE_FORM = (WRITE_ENTRY,WRITE_NAME,WRITE_HISEG,WRITE_GLOBALS,WRITE_CODE,WRITE_INTERNALS,WRITE_LIBRARY,
06410 WRITE_DEBUG,WRITE_FILEBLOCKS,WRITE_SYMBOLS,WRITE_START,WRITE_END);
06420
06430 NAMEKIND = (STDCONST,STDFILE,STDPROC,STDFUNC,DECLPROC,DECLFUNC);
06440
06450 BTPKIND = (UNUSED,REQUESTED,CALCULATED,USED);
06460
06470 ETP = ^ ERRORWITHTEXT;
06480 ERRORWITHTEXT = PACKED RECORD
06490 NUMBER: INTEGER;
06500 NEXT: ETP;
06510 STRING: ALFA
06520 END;
06530
06540 KSP = ^ KONSTREC;
06550 KONSTREC = PACKED RECORD
06560 ADDR, KADDR: ADDRRANGE;
06570 CONSTPTR: CSP;
06580 NEXTKONST: KSP;
06590 DOUBLE_CHAIN: BOOLEAN
06600 END;
06610
06620 PDP10INSTR = PACKED RECORD
06630 INSTR : INSTRANGE ;
06640 AC : ACRANGE;
06650 INDBIT : IBRANGE;
06660 INXREG : ACRANGE;
06670 ADDRESS : ADDRRANGE
06680 END ;
06690
06700 CHANGE_FORM=(INTCST,PDP10CODE,REALCST,STRCST,SIXBITCST,HALFWD,PDP10BP,RADIX) ;
06710
06720 CHARWORD = PACKED ARRAY[1..5] OF CHAR;
06730
06740 HALFS = PACKED RECORD
06750 LEFTHALF: ADDRRANGE;
06760 RIGHTHALF: ADDRRANGE
06770 END;
06780
06790 CODEPOINTER = ^CODEARRAY;
06800 CODEARRAY = RECORD
06810 CASE CHANGE_FORM OF
06820 PDP10CODE: (INSTRUCTION: ARRAY[CODERANGE] OF PDP10INSTR);
06830 INTCST: (WORD: ARRAY[CODERANGE] OF INTEGER);
06840 HALFWD: (HALFWORD: ARRAY[CODERANGE] OF HALFS)
06850 END;
06860
06870 RELPOINTER = ^RELARRAY;
06880 RELARRAY = PACKED ARRAY[CODERANGE] OF RELBYTE;
06890
06900 REFPOINTER = ^REFARRAY;
06910 REFARRAY = PACKED ARRAY[CODERANGE] OF CODEREFS;
06920
06930 BUFFERPOINTER = ^COMMANDBUFFER;
06940 COMMANDBUFFER = PACKED ARRAY[0..BUFFER_SIZE] OF ASCII;
06950
06960 PAGEELEM = PACKED RECORD
06970 WORD1: PDP10INSTR;
06980 LHALF: ADDRRANGE; RHALF: ADDRRANGE
06990 END;
07000
07010
07020 DEBENTRY = RECORD
07030 LASTPAGEELEM: PAGEELEM;
07040 GLOBALIDTREE: ADDRRANGE;
07050 STANDARDIDTREE: ADDRRANGE;
07060 INTPOINT: STP;
07070 REALPOINT: STP;
07080 BOOLPOINT: STP;
07090 CHARPOINT: STP
07100 END;
07110
07120 NLK = ^NEWLINKS;
07130
07140 NEWLINKS = PACKED RECORD
07150 REFTYPE : STP;
07160 REFADR : ADDRRANGE;
07170 NEXT : NLK;
07180 END;
07190
07200 (*------------------------------------------------------------------------------*)
07210
07220
07230 VAR
07240 (*VALUES RETURNED BY SOURCE PROGRAM SCANNER INSYMBOL:*)
07250 (*****************************************************)
07260
07270 SY: SYMBOL; (*LAST SYMBOL*)
07280 OP: OPERATOR; (*CLASSIFICATION OF LAST SYMBOL*)
07290 VAL: VALU; (*VALUE OF LAST CONSTANT*)
07300 LGTH: INTEGER; (*LENGTH OF LAST STRING CONSTANT*)
07310 ID: ALFA; (*LAST IDENTIFIER (POSSIBLY TRUNCATED)
07320 OR LAST INTEGER CONST (FOR LABEL PROCESSING)*)
07330 CH: CHAR; (*LAST CHARACTER*)
07340
07350
07360 (*COUNTERS:*)
07370 (***********)
07380
07390 I: INTEGER;
07400 ENTRIES: INTEGER;
07410 SUPPORT_INDEX: SUPPORTS;
07420 LANGUAGE_INDEX: SYMBOL;
07430 CHCNTMAX: 0..STDCHCNTMAX;
07440 CHCNT: 0..STDCHCNTMAX; (*CHARACTER COUNTER*)
07450 CODEEND, (*FIRST LOCATION NOT USED FOR INSTRUCTIONS*)
07460 LCMAIN,
07470 LC,IC: ADDRRANGE; (*DATA LOCATION AND INSTRUCTION COUNTER*)
07480 PROGRAM_COUNT: INTEGER;
07490
07500 (*SWITCHES:*)
07510 (***********)
07520
07530 DP, (*DECLARATION PART*)
07540 RESET_POSSIBLE, (*TO IGNORE SWITCHES WHICH MUST NOT BE RESET*)
07550 SEARCH_ERROR, (*TO ALLOW FORWARD REFERENCES IN POINTER TYPE
07560 DECLARATION BY SUPPRESSING ERROR MESSAGE*)
07570 EXTERNAL, (*IF TRUE, ALL LEVEL-1 PROC/FUNC MAY BE
07580 DECLARED AS "EXTERN" BY OTHER PROGRAMS*)
07590 TTYREAD, (*TO INHIBIT TTYOPEN ('*'-PROMPTING) IF NO TTY-INPUT REQUESTED*)
07600 DEBUG, (*ENABLE DEBUGGING*)
07610 DEBUG_SWITCH, (*TO GENERATE DEBUG INFORMATION*)
07620 LIST_CODE, (*LIST MACRO CODE*)
07630 LPTFILE, (*TO INHIBIT GENERATION OF LIST-FILE*)
07640 INITGLOBALS, (*INITIALIZE GLOBAL VARIABLES*)
07650 LOADNOPTR, (*IF TRUE, NO POINTERVARIABLE SHALL BE LOADED*)
07660 FORTRAN_ENVIROMENT,
07670 LOAD_AND_GO,
07680 CROSS_REFERENCE,
07690 FIRST_SYMBOL,
07700 RUNTIME_CHECK: BOOLEAN; (*IF TRUE, PERFORM RUNTIME-TESTS*)
07710
07720
07730 (*POINTERS:*)
07740 (***********)
07750
07760 SEXTERNPFPTR,
07770 LOCALPFPTR, EXTERNPFPTR: CTP; (*PTRS TO LOCAL/EXTERNAL PROC/FUNC-CHAIN*)
07780 PARMPTR: PTP; (*PTR TO PROGRAMPARM.-CHAIN*)
07790 STDFILEPTR: ARRAY[1..4] OF CTP; (*PTRS TO STD-FILES*)
07800 ALFAPTR,PACKC9PTR,
07810 PACKC5PTR,ASCIIPTR,
07820 PACKC6PTR,PACKC8PTR,
07830 INTPTR,REALPTR,CHARPTR,
07840 BOOLPTR,NILPTR,TEXTPTR: STP; (*POINTERS TO ENTRIES OF STANDARD IDS*)
07850 SDECLSCALPTR,
07860 DECLSCALPTR: STP; (*PTR TO CHAIN OF DECLARED SCALARS*)
07870 UTYPPTR,UCSTPTR,UVARPTR,
07880 UFLDPTR,UPRCPTR,UFCTPTR, (*POINTERS TO ENTRIES FOR UNDECLARED IDS*)
07890 FORWARD_POINTER_TYPE: CTP; (*HEAD OF CHAIN OF FORW DECL TYPE IDS*)
07900 ERRMPTR, ERRMPTR1: ETP; (*TO CHAIN ERRORS WITH TEXT*)
07910 LAST_LABEL: CTP; (*TOP OF LABEL CHAIN*)
07920 SLASTBTP,
07930 LASTBTP: BTP; (*HEAD OF BYTEPOINTERTABLE*)
07940 SFILEPTR,
07950 FILEPTR: FTP;
07960 FIRSTKONST: KSP;
07970 ANYFILEPTR: STP; (*TO ALLOW FILES OF "ANY" TYPE AS
07980 VAR PARAMETERS IN STAND. PROC/FUNC*)
07990 FGLOBPTR,CGLOBPTR : GTP ; (*POINTER TO FIRST AND CURRENT GLOBAL INITIALISATION RECORD*)
08000 GLOBTESTP : TESTP ; (*POINTER TO LAST PAIR OF POINTERTYPES*)
08010 GLOBNEWLINK : NLK ; (*POINTER TO NEW-LINKS*)
08020
08030 (*BOOKKEEPING OF DECLARATION LEVELS:*)
08040 (************************************)
08050
08060 LEVEL: LEVRANGE; (*CURRENT STATIC LEVEL*)
08070 DISX, (*LEVEL OF LAST ID SEARCHED BY SEARCHID*)
08080 TOP: DISPRANGE; (*TOP OF DISPLAY*)
08090
08100 DISPLAY: ARRAY[DISPRANGE] OF
08110 PACKED RECORD
08120 FNAME: CTP;
08130 CASE OCCUR: WHERE OF
08140 CREC: (CLEV: LEVRANGE;
08150 CINDR: ACRANGE;
08160 CINDB: IBRANGE;
08170 CRELBYTE: RELBYTE;
08180 CDSPL,
08190 CLC : ADDRRANGE)
08200 END;
08210
08220
08230 (*ERROR MESSAGES:*)
08240 (*****************)
08250
08260 ERROR_FLAG: BOOLEAN; (*TRUE IF SYNTACTIC ERRORS DETECTED*)
08270 ERROR_IN_HEADING: BOOLEAN;
08280 ERRINX: 0..MAXERR ; (*NR OF ERRORS IN CURRENT SOURCE LINE*)
08290 ERRORCOUNT: INTEGER; (*TOTAL NR OF ERRORS DETECTED IN PROGRAM*)
08300 ERROR_EXIT: BOOLEAN; (*TO ENABLE EXIT DURING COMPILATION*)
08310 OVERRUN: BOOLEAN;
08320 ERRLIST:
08330 ARRAY [1..MAXERR] OF
08340 PACKED RECORD
08350 ARW: 1..MAXERR;
08360 POS: 1..STDCHCNTMAX;
08370 NMR: 1..600;
08380 TIC: CHAR
08390 END;
08400
08410 ERRMESS15 : ARRAY [1..24] OF PACKED ARRAY [1..15] OF CHAR;
08420 ERRMESS20 : ARRAY [1..15] OF PACKED ARRAY [1..20] OF CHAR;
08430 ERRMESS25 : ARRAY [1..18] OF PACKED ARRAY [1..25] OF CHAR;
08440 ERRMESS30 : ARRAY [1..20] OF PACKED ARRAY [1..30] OF CHAR;
08450 ERRMESS35 : ARRAY [1..17] OF PACKED ARRAY [1..35] OF CHAR;
08460 ERRMESS40 : ARRAY [1..11] OF PACKED ARRAY [1..40] OF CHAR;
08470 ERRMESS45 : ARRAY [1..18] OF PACKED ARRAY [1..45] OF CHAR;
08480 ERRMESS50 : ARRAY [1..10] OF PACKED ARRAY [1..50] OF CHAR;
08490 ERRMESS55 : ARRAY [1.. 6] OF PACKED ARRAY [1..55] OF CHAR;
08500 ERRORINLINE,
08510 FOLLOWERROR : BOOLEAN;
08520 ERRLINE,
08530 BUFFER: ARRAY [1..STDCHCNTMAX] OF CHAR;
08540 PAGECNT,
08550 LINECNT: INTEGER;
08560 LINENR: PACKED ARRAY [1..5] OF CHAR;
08570
08580
08590 (*EXPRESSION COMPILATION:*)
08600 (*************************)
08610
08620 GATTR: ATTR; (*DESCRIBES THE EXPR CURRENTLY COMPILED*)
08630 AOS: (B0,B1,B2,B3,AOSINSTR,SOSINSTR); (*TESTS CONDITION FOR AOS/SOS-INSTRUCTION*)
08640 LEFTSIDE: ATTR; (*LEFT SIDE OF ASSIGNMENT*)
08650
08660 (*COMPILATION OF PACKED STRUCTURES:*)
08670 (***********************************)
08680
08690 ARRAYBPS: ARRAY[1:18] OF
08700 RECORD
08710 ABYTE: BPOINTER; BYTEMAX: BITRANGE;
08720 ADDRESS: ADDRRANGE;
08730 STATE: BTPKIND
08740 END;
08750
08760
08770
08780 (*DEBUG-SYSTEM:*)
08790 (***************)
08800
08810 LASTSTOP: ADDRRANGE; (*LAST BREAKPOINT*)
08820 LASTLINE, (*LINENUMBER FOR BREAKPOINTS*)
08830 LINEDIFF, (*DIFFERENCE BETWEEN ^ AND LINECNT*)
08840 LASTPAGE:INTEGER; (*LAST PAGE THAT CONTAINS A STOP*)
08850 PAGEHEADADR, (*OVERGIVE TO DEBUG.PAS*)
08860 LASTPAGER: ADDRRANGE; (*POINTS AT LAST PAGERECORD*)
08870 PAGER: PAGEELEM; (*ACTUAL PAGERECORD*)
08880 DEBENTRY_SIZE: INTEGER; (*DEBENTRY LENGTH *)
08890 DEBUGENTRY: DEBENTRY;
08900 IDRECSIZE: ARRAY[IDCLASS] OF INTEGER;
08910 STRECSIZE: ARRAY[STRUCTFORM] OF INTEGER;
08920
08930
08940
08950 (*STRUCTURED CONSTANTS:*)
08960 (***********************)
08970
08980 LETTERSORDIGITS,LETTERS,DIGITS,LETTERSDIGITSORLEFTARROW,HEXADIGITS: SET OF CHAR;
08990 CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS,
09000 LANGUAGESYS,STATBEGSYS,TYPEDELS: SETOFSYS;
09010 RW: ARRAY [1..RSWMAX] OF ALFA;
09020 FRW: ARRAY [1..11(*ALFALENGTH+1*)] OF 1..RSWMAXP1;
09030 RSY: ARRAY [1..RSWMAX] OF SYMBOL;
09040 SSY: ARRAY [' '..'_'] OF SYMBOL;
09050 ROP: ARRAY [1..RSWMAX] OF OPERATOR;
09060 SOP: ARRAY [' '..'_'] OF OPERATOR;
09070 NA: ARRAY[NAMEKIND] OF ARRAY[1..STDMAX] OF ALFA;
09080 NAMAX: ARRAY[NAMEKIND] OF INTEGER;
09090 EXTNA: ARRAY[DECLPROC..DECLFUNC] OF ARRAY[1..EXTPFMAX] OF ALFA;
09100 EXTLANGUAGE: ARRAY[DECLPROC..DECLFUNC] OF ARRAY[1..EXTPFMAX] OF SYMBOL;
09110 MNEMONICS : ARRAY[1..45] OF PACKED ARRAY[1..60] OF CHAR ;
09120 SHOWIBIT : ARRAY[IBRANGE] OF CHAR;
09130 SHOWRELO : ARRAY[BOOLEAN] OF CHAR;
09140 SHOWREF : ARRAY[CODEREFS] OF CHAR;
09150 WRITE_SUPPORT, READ_SUPPORT: ARRAY[SCALARFORM,SCALAR..POWER] OF SUPPORTS;
09160
09170 (*LABEL PROCESSING:*)
09180 (*******************)
09190
09200 JUMPER: 0..JUMP_MAX;
09210 JUMP_TABLE: PACKED ARRAY[JUMP_RANGE] OF ADDRRANGE;
09220 JUMP_ADDRESS: ADDRRANGE;
09230
09240 (*OTHER VARIABLES:*)
09250 (********************)
09260
09270 RELOCATION_BLOCK: PACKED RECORD
09280 CASE INTEGER OF
09290 1: (COMPONENT: ARRAY[1..20] OF INTEGER);
09300 2: (ITEM: ADDRRANGE; COUNT: ADDRRANGE;
09310 RELOCATOR: RELWORD;
09320 CODE: ARRAY[0..17] OF INTEGER)
09330 END;
09340
09350 RUNTIME_SUPPORT: RECORD
09360 NAME: ARRAY[SUPPORTS] OF ALFA;
09370 LINK: PACKED ARRAY[SUPPORTS] OF ADDRRANGE
09380 END;
09390
09400 CODE_ARRAY: CODEPOINTER;
09410
09420 CODE_REFERENCE: REFPOINTER;
09430
09440 COMMAND_BUFFER: BUFFERPOINTER;
09450
09460 CODE_RELOCATION: RELPOINTER;
09470
09480 CHANGE : PACKED RECORD
09490 CASE CHANGE_FORM OF
09500 INTCST :(WKONST: INTEGER);
09510 PDP10CODE:(WINSTR: PDP10INSTR);
09520 REALCST :(WREAL: REAL);
09530 STRCST :(WSTRING: CHARWORD);
09540 SIXBITCST:(WSIXBIT: PACKED ARRAY[1..6] OF 0..77B);
09550 HALFWD :(WLEFTHALF: ADDRRANGE ; WRIGHTHALF : ADDRRANGE);
09560 PDP10BP :(WBYTE: BPOINTER);
09570 RADIX :(FLAG: FLAGRANGE; SYMBOL: RADIXRANGE)
09580 END;
09590
09600
09610 REGC, (*TOP OF REGISTERSTACK*)
09620 REGCMAX: ACRANGE; (*MAXIMUM OF REGISTERS FOR EXPRESSION STACK*)
09630 CIX, (*CODE-ARRAY INDEX*)
09640 STACKSIZE1, STACKSIZE2, (*TO INSERT LCMAX IN PROCEDURE/FUNCTION ENTRY CODE*)
09650 PFSTART: INTEGER; (*START OF NORMAL ENTRYCODE OF EACH FUNC. OR PROC.*)
09660 LCMAX: ADDRRANGE; LCP: CTP;
09670 TEMPCORE, SOURCE, LIST, TTYIN : TEXT;
09680 OBJECT: FILE OF INTEGER;
09690 WITHIX: INTEGER; (*TOP OF WITH-REG STACK*)
09700 HIGHEST_CODE, (*HIGH SEG. BREAK*)
09710 MAIN_START, (*START OF BODY OF MAIN*)
09720 IDTREE, (*POINTER TO THE IDENTIFIER-TREE*)
09730 NAME_ADDRESS, (*ADDR OF PROGRAM-NAME(ALFA-STRING)*)
09740 START_ADDRESS: ADDRRANGE; (*STARTADDRESS*)
09750 LPARMPTR, BACKWPARMPTR: PTP;
09760 DAY, TIMEOFDAY, PROGRAMNAME: ALFA;
09770 ENTRY: ARRAY[0..ENTRYMAX] OF ALFA;
09780 LIST_FILE, SOURCE_FILE, OBJECT_FILE: PACKED ARRAY[1..9] OF CHAR;
09790 RTIME: ARRAY[0..3] OF INTEGER;
09800 CORE: ARRAY[1..2] OF INTEGER;
09810 START_CHANNEL, CODE_SIZE, RUNCORE, PARREGCMAX: INTEGER;
09820 ENTRY_DONE: BOOLEAN;
09830
09840 CROSS_DEVICE: PACKED ARRAY[1..6] OF CHAR;
09850 CROSS_PPN, CROSS_CORE: INTEGER;
09860
09870 LIBRARY_INDEX: INTEGER;
09880 LIBRARY_ORDER: PACKED ARRAY[1..4] OF SYMBOL;
09890 LIBRARY: ARRAY[PASCALSY..FORTRANSY] OF RECORD
09900 CHAINED, CALLED: BOOLEAN;
09910 NAME: ALFA;
09920 PROJNR: ADDRRANGE;
09930 PROGNR: ADDRRANGE;
09940 DEVICE: ALFA
09950 END;
09960
09970 (*------------------------------------------------------------------------------*)
09980
09990 INITPROCEDURE (* MNEMONICS *) ;
10000 BEGIN
10010
10020 MNEMONICS[ 1] := '***001***002***003***004***005***006***007***010***011***012' ;
10030 MNEMONICS[ 2] := '***013***014***015***016***017***020***021***022***023***024' ;
10040 MNEMONICS[ 3] := '***025***026***027***030***031***032***033***034***035***036' ;
10050 MNEMONICS[ 4] := '***037CALL INIT ***042***043***044***045***046CALLI OPEN ' ;
10060 MNEMONICS[ 5] := 'TTCALL***052***053***054RENAMEIN OUT SETSTSSTATO STATUS' ;
10070 MNEMONICS[ 6] := 'STATZ INBUF OUTBUFINPUT OUTPUTCLOSE RELEASMTAPE UGETF USETI ' ;
10080 MNEMONICS[ 7] := 'USETO LOOKUPENTER UJEN ***101***102***103***104***105***106' ;
10090 MNEMONICS[ 8] := '***107***110***111***112***113***114***115***116***117***120' ;
10100 MNEMONICS[ 9] := '***121***122***123***124***125***126***127UFA DFN FSC ' ;
10110 MNEMONICS[10] := 'IBP ILDB LDB IDPB DPB FAD FADL FADM FADB FADR ' ;
10120 MNEMONICS[11] := 'FADRI FADRM FADRB FSB FSBL FSBM FSBB FSBR FSBRI FSBRM ' ;
10130 MNEMONICS[12] := 'FSBRB FMP FMPL FMPM FMPB FMPR FMPRI FMPRM FMPRB FDV ' ;
10140 MNEMONICS[13] := 'FDVL FDVM FDVB FDVR FDVRI FDVRM FDVRB MOVE MOVEI MOVEM ' ;
10150 MNEMONICS[14] := 'MOVES MOVS MOVSI MOVSM MOVSS MOVN MOVNI MOVNM MOVNS MOVM ' ;
10160 MNEMONICS[15] := 'MOVMI MOVMM MOVMS IMUL IMULI IMULM IMULB MUL MULI MULM ' ;
10170 MNEMONICS[16] := 'MULB IDIV IDIVI IDIVM IDIVB DIV DIVI DIVM DIVB ASH ' ;
10180 MNEMONICS[17] := 'ROT LSH JFFO ASHC ROTC LSHC ***247EXCH BLT AOBJP ' ;
10190 MNEMONICS[18] := 'AOBJN JRST JFCL XCT ***257PUSHJ PUSH POP POPJ JSR ' ;
10200 MNEMONICS[19] := 'JSP JSA JRA ADD ADDI ADDM ADDB SUB SUBI SUBM ' ;
10210 MNEMONICS[20] := 'SUBB CAI CAIL CAIE CAILE CAIA CAIGE CAIN CAIG CAM ' ;
10220 MNEMONICS[21] := 'CAML CAME CAMLE CAMA CAMGE CAMN CAMG JUMP JUMPL JUMPE ' ;
10230 MNEMONICS[22] := 'JUMPLEJUMPA JUMPGEJUMPN JUMPG SKIP SKIPL SKIPE SKIPLESKIPA ' ;
10240 MNEMONICS[23] := 'SKIPGESKIPN SKIPG AOJ AOJL AOJE AOJLE AOJA AOJGE AOJN ' ;
10250 MNEMONICS[24] := 'AOJG AOS AOSL AOSE AOSLE AOSA AOSGE AOSN AOSG SOJ ' ;
10260 MNEMONICS[25] := 'SOJL SOJE SOJLE SOJA SOJGE SOJN SOJG SOS SOSL SOSE ' ;
10270 MNEMONICS[26] := 'SOSLE SOSA SOSGE SOSN SOSG SETZ SETZI SETZM SETZB AND ' ;
10280 MNEMONICS[27] := 'ANDI ANDM ANDB ANDCA ANDCAIANDCAMANDCABSETM SETMI SETMM ' ;
10290 MNEMONICS[28] := 'SETMB ANDCM ANDCMIANDCMMANDCMBSETA SETAI SETAM SETAB XOR ' ;
10300 MNEMONICS[29] := 'XORI XORM XORB IOR IORI IORM IORB ANDCB ANDCBIANDCBM' ;
10310 MNEMONICS[30] := 'ANDCBBEQV EQVI EQVM EQVB SETCA SETCAISETCAMSETCABORCA ' ;
10320 MNEMONICS[31] := 'ORCAI ORCAM ORCAB SETCM SETCMISETCMMSETCMBORCM ORCMI ORCMM ' ;
10330 MNEMONICS[32] := 'ORCMB ORCB ORCBI ORCBM ORCBB SETO SETOI SETOM SETOB HLL ' ;
10340 MNEMONICS[33] := 'HLLI HLLM HLLS HRL HRLI HRLM HRLS HLLZ HLLZI HLLZM ' ;
10350 MNEMONICS[34] := 'HLLZS HRLZ HRLZI HRLZM HRLZS HLLO HLLOI HLLOM HLLOS HRLO ' ;
10360 MNEMONICS[35] := 'HRLOI HRLOM HRLOS HLLE HLLEI HLLEM HLLES HRLE HRLEI HRLEM ' ;
10370 MNEMONICS[36] := 'HRLES HRR HRRI HRRM HRRS HLR HLRI HLRM HLRS HRRZ ' ;
10380 MNEMONICS[37] := 'HRRZI HRRZM HRRZS HLRZ HLRZI HLRZM HLRZS HRRO HRROI HRROM ' ;
10390 MNEMONICS[38] := 'HRROS HLRO HLROI HLROM HLROS HRRE HRREI HRREM HRRES HLRE ' ;
10400 MNEMONICS[39] := 'HLREI HLREM HLRES TRN TLN TRNE TLNE TRNA TLNA TRNN ' ;
10410 MNEMONICS[40] := 'TLNN TDN TSN TDNE TSNE TDNA TSNA TDNN TSNN TRZ ' ;
10420 MNEMONICS[41] := 'TLZ TRZE TLZE TRZA TLZA TRZN TLZN TDZ TSZ TDZE ' ;
10430 MNEMONICS[42] := 'TSZE TDZA TSZA TDZN TSZN TRC TLC TRCE TLZE TRCA ' ;
10440 MNEMONICS[43] := 'TLCA TRCN TLCN TDC TSC TDCE TSCE TDCA TSCA TDCN ' ;
10450 MNEMONICS[44] := 'TSCN TRO TLO TROE TLOE TROA TLOA TRON TLON TDO ' ;
10460 MNEMONICS[45] := 'TSO TDOE TSOE TDOA TSOA TDON TSON ***700 ' ;
10470
10480 SHOWIBIT[0] := ' '; SHOWIBIT[1] := '@';
10490
10500 SHOWRELO[FALSE] := ' '; SHOWRELO[TRUE] := '''';
10510
10520 SHOWREF[NOREF] := ' '; SHOWREF[CONSTREF] := 'C';
10530 SHOWREF[EXTERNREF] := 'E'; SHOWREF[NOINSTR] := ' ';
10540 SHOWREF[FORWARDREF] := 'F'; SHOWREF[GOTOREF] := 'G';
10550 SHOWREF[POINTREF] := 'P'; SHOWREF[SAVEREF] := 'S';
10560 SHOWREF[DEBUGREF] := 'D';
10570
10580 END (* MNEMONICS *) ;
10590
10600 INITPROCEDURE (*SEARCH LIBRARIES*) ;
10610 BEGIN
10620
10630 (* INSERT (???) DEVICE, PROJNR, PROGNR AND CORE FOR PASLIB AND CROSS *)
10640
10650 LIBRARY[PASCALSY].CHAINED := FALSE;
10660 LIBRARY[FORTRANSY].CHAINED := FALSE;
10670 LIBRARY[PASCALSY].CALLED := FALSE;
10680 LIBRARY[FORTRANSY].CALLED := FALSE;
10690 LIBRARY[PASCALSY].NAME := 'PASLIB ';
10700 LIBRARY[FORTRANSY].NAME := 'FORLIB ';
10710 LIBRARY[PASCALSY].DEVICE := 'NEW ';
10720 LIBRARY[FORTRANSY].DEVICE := 'SYS ';
10730 LIBRARY[PASCALSY].PROJNR := 0;
10740 LIBRARY[FORTRANSY].PROJNR := 0;
10750 LIBRARY[PASCALSY].PROGNR := 0;
10760 LIBRARY[FORTRANSY].PROGNR := 0;
10770
10780 CROSS_DEVICE := 'NEW ';
10790 CROSS_PPN := 0;
10800 CROSS_CORE := 50; (* ??? *)
10810
10820 END (*SEARCH LIBRARIES*) ;
10830
10840 INITPROCEDURE (*STANDARD NAMES*) ;
10850 BEGIN
10860
10870 NA[STDFILE, 1] := 'INPUT '; NA[STDFILE, 2] := 'OUTPUT '; NA[STDFILE, 3] := 'TTY ';
10880 NA[STDFILE, 4] := 'TTYOUTPUT ';
10890
10900 NA[STDPROC, 1] := 'GET '; NA[STDPROC, 2] := 'GETLN '; NA[STDPROC, 3] := 'PUT ';
10910 NA[STDPROC, 4] := 'PUTLN '; NA[STDPROC, 5] := 'RESET '; NA[STDPROC, 6] := 'REWRITE ';
10920 NA[STDPROC, 7] := 'READ '; NA[STDPROC, 8] := 'READLN '; NA[STDPROC, 9] := 'BREAK ';
10930 NA[STDPROC,10] := 'WRITE '; NA[STDPROC,11] := 'WRITELN '; NA[STDPROC,12] := 'PACK ';
10940 NA[STDPROC,13] := 'UNPACK '; NA[STDPROC,14] := 'NEW '; NA[STDPROC,15] := '$$$1 ';
10950 NA[STDPROC,16] := '$$$2 '; NA[STDPROC,17] := 'GETLINENR '; NA[STDPROC,18] := '$$$3 ';
10960 NA[STDPROC,19] := 'PAGE '; NA[STDPROC,20] := 'PROTECTION'; NA[STDPROC,21] := 'CALL ';
10970 NA[STDPROC,22] := 'DATE '; NA[STDPROC,23] := 'TIME '; NA[STDPROC,24] := 'DISPOSE ';
10980 NA[STDPROC,25] := 'HALT '; NA[STDPROC,26] := 'GETSEG '; NA[STDPROC,27] := 'PUTSEG ';
10990 NA[STDPROC,28] := 'MESSAGE '; NA[STDPROC,29] := 'LINELIMIT ';
11000
11010 NA[STDFUNC, 1] := 'REALTIME '; NA[STDFUNC, 2] := 'ABS '; NA[STDFUNC, 3] := 'SQR ';
11020 NA[STDFUNC, 4] := '$$$4 '; NA[STDFUNC, 5] := 'ODD '; NA[STDFUNC, 6] := 'ORD ';
11030 NA[STDFUNC, 7] := 'CHR '; NA[STDFUNC, 8] := 'PRED '; NA[STDFUNC, 9] := 'SUCC ';
11040 NA[STDFUNC,10] := 'EOF '; NA[STDFUNC,11] := 'EOLN '; NA[STDFUNC,12] := 'CLOCK ';
11050 NA[STDFUNC,13] := 'CARD '; NA[STDFUNC,14] := '$$$5 '; NA[STDFUNC,15] := 'LOWERBOUND';
11060 NA[STDFUNC,16] := 'UPPERBOUND'; NA[STDFUNC,17] := 'EOS '; NA[STDFUNC,18] := '$$$6 ';
11070 NA[STDFUNC,19] := 'MIN '; NA[STDFUNC,20] := 'MAX '; NA[STDFUNC,21] := 'FIRST ';
11080 NA[STDFUNC,22] := 'LAST ';
11090
11100 NA[DECLFUNC, 1] := 'COS '; NA[DECLFUNC, 2] := 'EXP '; NA[DECLFUNC, 3] := 'SQRT ';
11110 NA[DECLFUNC, 4] := 'LN '; NA[DECLFUNC, 5] := 'ARCTAN '; NA[DECLFUNC, 6] := 'LOG ';
11120 NA[DECLFUNC, 7] := 'SIND '; NA[DECLFUNC, 8] := 'COSD '; NA[DECLFUNC, 9] := 'SINH ';
11130 NA[DECLFUNC,10] := 'COSH '; NA[DECLFUNC,11] := 'TANH '; NA[DECLFUNC,12] := 'ARCSIN ';
11140 NA[DECLFUNC,13] := 'ARCCOS '; NA[DECLFUNC,14] := 'RANDOM '; NA[DECLFUNC,15] := 'SIN ';
11150 NA[DECLFUNC,16] := 'ROUND '; NA[DECLFUNC,17] := 'EXPO '; NA[DECLFUNC,18] := 'OPTION ';
11160 NA[DECLFUNC,19] := '$$$7 '; NA[DECLFUNC,20] := 'TRUNC ';
11170
11180 NA[STDCONST, 1] := 'FALSE '; NA[STDCONST, 2] := 'TRUE '; NA[STDCONST, 3] := 'NUL ';
11190 NA[STDCONST, 4] := 'SOH '; NA[STDCONST, 5] := 'STX '; NA[STDCONST, 6] := 'ETX ';
11200 NA[STDCONST, 7] := 'EOT '; NA[STDCONST, 8] := 'ENQ '; NA[STDCONST, 9] := 'ACK ';
11210 NA[STDCONST,10] := 'BEL '; NA[STDCONST,11] := 'BS '; NA[STDCONST,12] := 'HT ';
11220 NA[STDCONST,13] := 'LF '; NA[STDCONST,14] := 'VT '; NA[STDCONST,15] := 'FF ';
11230 NA[STDCONST,16] := 'CR '; NA[STDCONST,17] := 'SO '; NA[STDCONST,18] := 'SI ';
11240 NA[STDCONST,19] := 'DLE '; NA[STDCONST,20] := 'DC1 '; NA[STDCONST,21] := 'DC2 ';
11250 NA[STDCONST,22] := 'DC3 '; NA[STDCONST,23] := 'DC4 '; NA[STDCONST,24] := 'NAK ';
11260 NA[STDCONST,25] := 'SYN '; NA[STDCONST,26] := 'ETB '; NA[STDCONST,27] := 'CAN ';
11270 NA[STDCONST,28] := 'EM '; NA[STDCONST,29] := 'SUB '; NA[STDCONST,30] := 'ESC ';
11280 NA[STDCONST,31] := 'FS '; NA[STDCONST,32] := 'GS '; NA[STDCONST,33] := 'RS ';
11290 NA[STDCONST,34] := 'US '; NA[STDCONST,35] := 'SP '; NA[STDCONST,36] := 'DEL ';
11300
11310 NA[DECLPROC, 1] := 'GETFILENAM'; NA[DECLPROC, 2] := 'GETOPTION '; NA[DECLPROC, 3] := 'GETSTATUS ';
11320
11330 NAMAX[STDFILE] := 4; NAMAX[STDPROC] := 29; NAMAX[STDFUNC] := 22;
11340 NAMAX[DECLFUNC] := 20; NAMAX[DECLPROC] := 3; NAMAX[STDCONST] := 36;
11350
11360 END (*STANDARD NAMES*) ;
11370
11380 INITPROCEDURE (*EXTERNAL PROCEDURE/FUNCTION NAMES*);
11390 BEGIN
11400
11410 EXTNA[DECLFUNC, 1] := 'COS '; EXTLANGUAGE[DECLFUNC, 1] := FORTRANSY;
11420 EXTNA[DECLFUNC, 2] := 'EXP '; EXTLANGUAGE[DECLFUNC, 2] := FORTRANSY;
11430 EXTNA[DECLFUNC, 3] := 'SQRT '; EXTLANGUAGE[DECLFUNC, 3] := FORTRANSY;
11440 EXTNA[DECLFUNC, 4] := 'ALOG '; EXTLANGUAGE[DECLFUNC, 4] := FORTRANSY;
11450 EXTNA[DECLFUNC, 5] := 'ATAN '; EXTLANGUAGE[DECLFUNC, 5] := FORTRANSY;
11460 EXTNA[DECLFUNC, 6] := 'ALOG10 '; EXTLANGUAGE[DECLFUNC, 6] := FORTRANSY;
11470 EXTNA[DECLFUNC, 7] := 'SIND '; EXTLANGUAGE[DECLFUNC, 7] := FORTRANSY;
11480 EXTNA[DECLFUNC, 8] := 'COSD '; EXTLANGUAGE[DECLFUNC, 8] := FORTRANSY;
11490 EXTNA[DECLFUNC, 9] := 'SINH '; EXTLANGUAGE[DECLFUNC, 9] := FORTRANSY;
11500 EXTNA[DECLFUNC,10] := 'COSH '; EXTLANGUAGE[DECLFUNC,10] := FORTRANSY;
11510 EXTNA[DECLFUNC,11] := 'TANH '; EXTLANGUAGE[DECLFUNC,11] := FORTRANSY;
11520 EXTNA[DECLFUNC,12] := 'ASIN '; EXTLANGUAGE[DECLFUNC,12] := FORTRANSY;
11530 EXTNA[DECLFUNC,13] := 'ACOS '; EXTLANGUAGE[DECLFUNC,13] := FORTRANSY;
11540 EXTNA[DECLFUNC,14] := 'RAN '; EXTLANGUAGE[DECLFUNC,14] := FORTRANSY;
11550 EXTNA[DECLFUNC,15] := 'SIN '; EXTLANGUAGE[DECLFUNC,15] := FORTRANSY;
11560 EXTNA[DECLFUNC,16] := 'ROUND '; EXTLANGUAGE[DECLFUNC,16] := PASCALSY;
11570 EXTNA[DECLFUNC,17] := 'EXPO '; EXTLANGUAGE[DECLFUNC,17] := PASCALSY;
11580 EXTNA[DECLFUNC,18] := 'OPTION '; EXTLANGUAGE[DECLFUNC,18] := PASCALSY;
11590 EXTNA[DECLFUNC,19] := 'UNDEFI '; EXTLANGUAGE[DECLFUNC,19] := PASCALSY;
11600 EXTNA[DECLFUNC,20] := 'TRUNC '; EXTLANGUAGE[DECLFUNC,20] := PASCALSY;
11610
11620 EXTNA[DECLPROC, 1] := 'GETFIL '; EXTLANGUAGE[DECLPROC, 1] := PASCALSY;
11630 EXTNA[DECLPROC, 2] := 'GETOPT '; EXTLANGUAGE[DECLPROC, 2] := PASCALSY;
11640 EXTNA[DECLPROC, 3] := 'GETSTA '; EXTLANGUAGE[DECLPROC, 3] := PASCALSY;
11650
11660 END (*EXTERNAL PROCUDURE/FUNCTION NAMES*);
11670
11680 INITPROCEDURE (*RUNTIME-, DEBUG-SUPPORT NAMES*) ;
11690 BEGIN
11700
11710 RUNTIME_SUPPORT.NAME[STACKOVERFLOW] := 'CORERR ';
11720 RUNTIME_SUPPORT.NAME[OVERFLOW] := 'OVERF. ';
11730 RUNTIME_SUPPORT.NAME[ALLOCATE] := 'NEW ';
11740 RUNTIME_SUPPORT.NAME[EXITPROGRAM] := 'END ';
11750 RUNTIME_SUPPORT.NAME[GETLINE] := 'GETLN ';
11760 RUNTIME_SUPPORT.NAME[GETFILE] := 'GET ';
11770 RUNTIME_SUPPORT.NAME[PUTLINE] := 'PUTLN ';
11780 RUNTIME_SUPPORT.NAME[PUTFILE] := 'PUT ';
11790 RUNTIME_SUPPORT.NAME[RESETFILE] := 'RESETF ';
11800 RUNTIME_SUPPORT.NAME[REWRITEFILE] := 'REWRIT ';
11810 RUNTIME_SUPPORT.NAME[WRITEOCTAL] := 'WRTOCT ';
11820 RUNTIME_SUPPORT.NAME[WRITEHEXADECIMAL] := 'WRTHEX ';
11830 RUNTIME_SUPPORT.NAME[WRITEINTEGER] := 'WRTINT ';
11840 RUNTIME_SUPPORT.NAME[LOADDEBUG] := 'DEBUG ';
11850 RUNTIME_SUPPORT.NAME[WRITECHARACTER] := 'WRITEC ';
11860 RUNTIME_SUPPORT.NAME[WRITEREAL] := 'WRTREA ';
11870 RUNTIME_SUPPORT.NAME[WRITEBOOLEAN] := 'WRTBOL ';
11880 RUNTIME_SUPPORT.NAME[WRITESTRING] := 'WRTUST ';
11890 RUNTIME_SUPPORT.NAME[WRITEPACKEDSTRING] := 'WRTPST ';
11900 RUNTIME_SUPPORT.NAME[READINTEGER] := 'READI ';
11910 RUNTIME_SUPPORT.NAME[READCHARACTER] := 'READC ';
11920 RUNTIME_SUPPORT.NAME[READREAL] := 'READR ';
11930 RUNTIME_SUPPORT.NAME[CONVERTINTEGERTOREAL] := 'INTREA ';
11940 RUNTIME_SUPPORT.NAME[PUTBUFFER] := 'PUTBUF ';
11950 RUNTIME_SUPPORT.NAME[OPENTTY] := 'TTYOPN ';
11960 RUNTIME_SUPPORT.NAME[INITIALIZEDEBUG] := 'INDEB. ';
11970 RUNTIME_SUPPORT.NAME[ENTERDEBUG] := 'EXDEB. ';
11980 RUNTIME_SUPPORT.NAME[GETCHARACTER] := 'GETCH ';
11990 RUNTIME_SUPPORT.NAME[PUTPAGE] := 'PUTPG ';
12000 RUNTIME_SUPPORT.NAME[INDEXERROR] := 'INXERR ';
12010 RUNTIME_SUPPORT.NAME[ERRORINASSIGNMENT] := 'SRERR ';
12020 RUNTIME_SUPPORT.NAME[RUNPROGRAM] := 'RUNPGM ';
12030 RUNTIME_SUPPORT.NAME[READPGMPARAMETER] := 'GETPAR ';
12040 RUNTIME_SUPPORT.NAME[READSTRING] := 'READS ';
12050 RUNTIME_SUPPORT.NAME[READPACKEDSTRING] := 'READPS ';
12060 RUNTIME_SUPPORT.NAME[ASCIIDATE] := 'DATE. ';
12070 RUNTIME_SUPPORT.NAME[ASCIITIME] := 'TIME. ';
12080 RUNTIME_SUPPORT.NAME[FREE] := 'FREE ';
12090 RUNTIME_SUPPORT.NAME[READIRANGE] := 'READIR ';
12100 RUNTIME_SUPPORT.NAME[READCRANGE] := 'READCR ';
12110 RUNTIME_SUPPORT.NAME[READRRANGE] := 'READRR ';
12120 RUNTIME_SUPPORT.NAME[READISET] := 'READIS ';
12130 RUNTIME_SUPPORT.NAME[READCSET] := 'READCS ';
12140 RUNTIME_SUPPORT.NAME[READDSET] := 'READDS ';
12150 RUNTIME_SUPPORT.NAME[READSCALAR] := 'READSC ';
12160 RUNTIME_SUPPORT.NAME[WRTISET] := 'WRTISE ';
12170 RUNTIME_SUPPORT.NAME[WRTCSET] := 'WRTCSE ';
12180 RUNTIME_SUPPORT.NAME[WRTDSET] := 'WRTDSE ';
12190 RUNTIME_SUPPORT.NAME[WRTSCALAR] := 'WRTSCA ';
12200 RUNTIME_SUPPORT.NAME[WRITEDEFINTEGER] := 'WRTIN1 ';
12210 RUNTIME_SUPPORT.NAME[WRITEDEFOCTAL] := 'WRTOC1 ';
12220 RUNTIME_SUPPORT.NAME[WRITEDEFHEXADECIMAL] := 'WRTHX1 ';
12230 RUNTIME_SUPPORT.NAME[WRITEDEFBOOLEAN] := 'WRTBO1 ';
12240 RUNTIME_SUPPORT.NAME[WRITEDEF1REAL] := 'WRTRE1 ';
12250 RUNTIME_SUPPORT.NAME[WRITEDEFCHARACTER] := 'WRITC1 ';
12260 RUNTIME_SUPPORT.NAME[WRITEDEFSTRING] := 'WRTUS1 ';
12270 RUNTIME_SUPPORT.NAME[WRITEDEFPACKEDSTRING] := 'WRTPS1 ';
12280 RUNTIME_SUPPORT.NAME[WRITEDEF2REAL] := 'WRTRE2 ';
12290 RUNTIME_SUPPORT.NAME[FORTRANRESET] := 'RESET. ';
12300 RUNTIME_SUPPORT.NAME[FORTRANEXIT] := 'EXIT. ';
12310 RUNTIME_SUPPORT.NAME[CLOSEFILE] := 'CLSFIL ';
12320 RUNTIME_SUPPORT.NAME[INPUTERROR] := 'IPTERR ';
12330 RUNTIME_SUPPORT.NAME[ERRORINSET] := 'SETERR ';
12340 RUNTIME_SUPPORT.NAME[NOCOREAVAILABLE] := 'NOCORE ';
12350
12360 READ_SUPPORT[INTEGERFORM,SUBRANGE] := READIRANGE;
12370 READ_SUPPORT[INTEGERFORM,POWER] := READISET;
12380 READ_SUPPORT[INTEGERFORM,SCALAR] := READINTEGER;
12390
12400 READ_SUPPORT[REALFORM,SUBRANGE] := READRRANGE;
12410 READ_SUPPORT[REALFORM,SCALAR] := READREAL;
12420
12430 READ_SUPPORT[CHARFORM,SUBRANGE] := READCRANGE;
12440 READ_SUPPORT[CHARFORM,POWER] := READCSET;
12450 READ_SUPPORT[CHARFORM,SCALAR] := READCHARACTER;
12460
12470 READ_SUPPORT[DECLAREDFORM,SUBRANGE] := READSCALAR;
12480 READ_SUPPORT[DECLAREDFORM,POWER] := READDSET;
12490 READ_SUPPORT[DECLAREDFORM,SCALAR] := READSCALAR;
12500
12510 WRITE_SUPPORT[INTEGERFORM,POWER] := WRTISET;
12520 WRITE_SUPPORT[CHARFORM,POWER] := WRTCSET;
12530 WRITE_SUPPORT[DECLAREDFORM,POWER] := WRTDSET;
12540 WRITE_SUPPORT[DECLAREDFORM,SUBRANGE] := WRTSCALAR;
12550 WRITE_SUPPORT[DECLAREDFORM,SCALAR] := WRTSCALAR;
12560
12570 END (*RUNTIME-, DEBUG-SUPPORT NAMES*) ;
12580
12590 INITPROCEDURE (*INITSCALARS*) ;
12600 BEGIN
12610 PROGRAMNAME := ' ';
12620 SOURCE_FILE := ' '; OBJECT_FILE := ' ';
12630
12640 FORWARD_POINTER_TYPE := NIL; LASTBTP := NIL; FGLOBPTR := NIL ; FILEPTR := NIL ;
12650 LOCALPFPTR := NIL; EXTERNPFPTR := NIL; GLOBTESTP := NIL; LAST_LABEL := NIL;
12660 ERRMPTR := NIL; PARMPTR := NIL; DECLSCALPTR := NIL; BACKWPARMPTR := NIL;
12670 SDECLSCALPTR := NIL; SEXTERNPFPTR := NIL; SFILEPTR := NIL;
12680 SLASTBTP := NIL; GLOBNEWLINK := NIL;
12690
12700 LIST_CODE := FALSE; LOADNOPTR := TRUE; INITGLOBALS := FALSE ; RUNTIME_CHECK := TRUE;
12710 FOLLOWERROR := FALSE; ERRORINLINE := FALSE; RESET_POSSIBLE := TRUE; FIRST_SYMBOL := TRUE;
12720 DP := TRUE; SEARCH_ERROR := TRUE; ERROR_FLAG := FALSE ; EXTERNAL := FALSE; OVERRUN := FALSE;
12730 ENTRY_DONE := FALSE; DEBUG := FALSE; DEBUG_SWITCH := FALSE; LPTFILE := FALSE;
12740 ERROR_EXIT := FALSE; TTYREAD := FALSE; LOAD_AND_GO := FALSE; CROSS_REFERENCE := FALSE;
12750 FORTRAN_ENVIROMENT := FALSE;
12760
12770 IC := HIGH_START; (*START OF HIGHSEGMENT*)
12780 LC := LOW_START; (*START OF LOWSEGMENT AVAILABLE TO PROGRAM*)
12790 CHCNT := 0; LINECNT := 10; PAGECNT := 1; LASTLINE := -1; LASTPAGE := 0;
12800 AOS := B0; LIBRARY_INDEX := 0; ERRINX := 0; ERRORCOUNT := 0; ENTRIES := 0;
12810 DEBUGENTRY.STANDARDIDTREE := 0; DEBUGENTRY.GLOBALIDTREE := 0; START_CHANNEL := 0;
12820 PARREGCMAX := STDPARREGCMAX; CHCNTMAX := STDCHCNTMAX;
12830 CODE_SIZE := CIXMAX; RUNCORE := 0; JUMPER := 0; JUMP_ADDRESS := 0; PROGRAM_COUNT := 0
12840
12850 END (*INITSCALARS*) ;
12860
12870 INITPROCEDURE (*INITSETS*) ;
12880 BEGIN
12890
12900 DIGITS := ['0'..'9'];
12910 LETTERS := ['A'..'Z'];
12920 HEXADIGITS := ['0'..'9','A'..'F'];
12930 LETTERSORDIGITS := [ '0'..'9','A'..'Z'];
12940 LETTERSDIGITSORLEFTARROW := ['0'..'9','A'..'Z','_'];
12950 LANGUAGESYS := [FORTRANSY,PASCALSY];
12960 CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT];
12970 SIMPTYPEBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT] ;
12980 TYPEBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,ARROW,
12990 PACKEDSY,ARRAYSY,RECORDSY,SETSY,FILESY] ;
13000 TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY];
13010 BLOCKBEGSYS := [LABELSY,CONSTSY,TYPESY,VARSY,INITPROCSY,PROCEDURESY,FUNCTIONSY,BEGINSY];
13020 SELECTSYS := [ARROW,PERIOD,LBRACK];
13030 FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY];
13040 STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,LOOPSY,FORSY,WITHSY,CASESY]
13050
13060 END (*INITSETS*) ;
13070
13080 INITPROCEDURE (*RESERVED WORDS*) ;
13090 BEGIN
13100
13110 RW[ 1] := 'IF '; RW[ 2] := 'DO '; RW[ 3] := 'OF ';
13120 RW[ 4] := 'TO '; RW[ 5] := 'IN '; RW[ 6] := 'OR ';
13130 RW[ 7] := 'END '; RW[ 8] := 'FOR '; RW[ 9] := 'VAR ';
13140 RW[10] := 'DIV '; RW[11] := 'MOD '; RW[12] := 'SET ';
13150 RW[13] := 'AND '; RW[14] := 'NOT '; RW[15] := 'THEN ';
13160 RW[16] := 'ELSE '; RW[17] := 'WITH '; RW[18] := 'GOTO ';
13170 RW[19] := 'LOOP '; RW[20] := 'CASE '; RW[21] := 'TYPE ';
13180 RW[22] := 'FILE '; RW[23] := 'EXIT '; RW[24] := 'BEGIN ';
13190 RW[25] := 'UNTIL '; RW[26] := 'WHILE '; RW[27] := 'ARRAY ';
13200 RW[28] := 'CONST '; RW[29] := 'LABEL '; RW[30] := 'EXTERN ';
13210 RW[31] := 'RECORD '; RW[32] := 'DOWNTO '; RW[33] := 'PACKED ';
13220 RW[34] := 'OTHERS '; RW[35] := 'REPEAT '; RW[36] := 'FORTRAN ';
13230 RW[37] := 'FORWARD '; RW[38] := 'PROGRAM '; RW[39] := 'FUNCTION ';
13240 RW[40] := 'PROCEDURE '; RW[41] := 'SEGMENTED '; RW[42] := 'INITPROCED';
13250
13260 FRW[1] := 1; FRW[2] := 1; FRW[3] := 7; FRW[4] := 15; FRW[5] := 24;
13270 FRW[6] := 30; FRW[7] := 36; FRW[8] := 39; FRW[9] := 40; FRW[10] := 42;
13280 FRW[11] := 43
13290
13300 END (*RESERVED WORDS*) ;
13310
13320 INITPROCEDURE (*SYMBOLS*) ;
13330 BEGIN
13340
13350 RSY[1]:=IFSY; RSY[2]:=DOSY; RSY[3]:=OFSY;
13360 RSY[4]:=TOSY; RSY[8]:=FORSY; RSY[12]:=SETSY;
13370 RSY[5]:=RELOP; RSY[6]:=ADDOP; RSY[7]:=ENDSY;
13380 RSY[9]:=VARSY; RSY[10]:=MULOP; RSY[11]:=MULOP;
13390 RSY[13]:=MULOP; RSY[14]:=NOTSY; RSY[15]:=THENSY;
13400 RSY[16]:=ELSESY; RSY[17]:=WITHSY; RSY[18]:=GOTOSY;
13410 RSY[19]:=LOOPSY; RSY[20]:=CASESY; RSY[21]:=TYPESY;
13420 RSY[22]:=FILESY; RSY[23]:=EXITSY; RSY[24]:=BEGINSY;
13430 RSY[25]:=UNTILSY; RSY[26]:=WHILESY; RSY[27]:=ARRAYSY;
13440 RSY[28]:=CONSTSY; RSY[29]:=LABELSY; RSY[30]:=EXTERNSY;
13450 RSY[31]:=RECORDSY; RSY[32]:=DOWNTOSY; RSY[33]:=PACKEDSY;
13460 RSY[34]:=OTHERSSY; RSY[35]:=REPEATSY; RSY[36]:=FORTRANSY;
13470 RSY[37]:=FORWARDSY; RSY[38]:=PROGRAMSY; RSY[39]:=FUNCTIONSY;
13480 RSY[40]:=PROCEDURESY; RSY[41]:=SEGMENTSY; RSY[42]:=INITPROCSY;
13490
13500 SSY['A'] := OTHERSY; SSY['B'] := OTHERSY; SSY['C'] := OTHERSY;
13510 SSY['D'] := OTHERSY; SSY['E'] := OTHERSY; SSY['F'] := OTHERSY;
13520 SSY['G'] := OTHERSY; SSY['H'] := OTHERSY; SSY['I'] := OTHERSY;
13530 SSY['J'] := OTHERSY; SSY['K'] := OTHERSY; SSY['L'] := OTHERSY;
13540 SSY['M'] := OTHERSY; SSY['N'] := OTHERSY; SSY['O'] := OTHERSY;
13550 SSY['P'] := OTHERSY; SSY['Q'] := OTHERSY; SSY['R'] := OTHERSY;
13560 SSY['S'] := OTHERSY; SSY['T'] := OTHERSY; SSY['U'] := OTHERSY;
13570 SSY['V'] := OTHERSY; SSY['W'] := OTHERSY; SSY['X'] := OTHERSY;
13580 SSY['Y'] := OTHERSY; SSY['Z'] := OTHERSY; SSY['0'] := OTHERSY;
13590 SSY['1'] := OTHERSY; SSY['2'] := OTHERSY; SSY['3'] := OTHERSY;
13600 SSY['4'] := OTHERSY; SSY['5'] := OTHERSY; SSY['6'] := OTHERSY;
13610 SSY['7'] := OTHERSY; SSY['8'] := OTHERSY; SSY['9'] := OTHERSY;
13620 SSY['+'] := ADDOP; SSY['-'] := ADDOP; SSY['*'] := MULOP;
13630 SSY['/'] := MULOP; SSY['('] := LPARENT; SSY[')'] := RPARENT;
13640 SSY['$'] := OTHERSY; SSY['='] := RELOP; SSY[' '] := OTHERSY;
13650 SSY[','] := COMMA; SSY['.'] := PERIOD; SSY[''''] := OTHERSY;
13660 SSY['['] := LBRACK; SSY[']'] := RBRACK; SSY[':'] := COLON;
13670 SSY['#'] := OTHERSY; SSY['%'] := OTHERSY; SSY['!'] := OTHERSY;
13680 SSY['&'] := OTHERSY; SSY['^'] := ARROW; SSY['\'] := OTHERSY;
13690 SSY['<'] := RELOP; SSY['>'] := RELOP; SSY['@'] := OTHERSY;
13700 SSY['"'] := OTHERSY; SSY['?'] := OTHERSY; SSY[';'] := SEMICOLON;
13710 SSY['_'] := OTHERSY;
13720
13730 END (*SYMBOLS*) ;
13740
13750 INITPROCEDURE (*OPERATORS*) ;
13760 BEGIN
13770
13780 ROP[ 1] := NOOP; ROP[ 2] := NOOP; ROP[ 3] := NOOP; ROP[ 4] := NOOP;
13790 ROP[ 5] := INOP; ROP[ 6] := OROP; ROP[ 7] := NOOP; ROP[ 8] := NOOP;
13800 ROP[ 9] := NOOP; ROP[10] := IDIV; ROP[11] := IMOD; ROP[12] := NOOP;
13810 ROP[13] :=ANDOP; ROP[14] := NOOP; ROP[15] := NOOP; ROP[16] := NOOP;
13820 ROP[17] := NOOP; ROP[18] := NOOP; ROP[19] := NOOP; ROP[20] := NOOP;
13830 ROP[21] := NOOP; ROP[22] := NOOP; ROP[23] := NOOP; ROP[24] := NOOP;
13840 ROP[25] := NOOP; ROP[26] := NOOP; ROP[27] := NOOP; ROP[28] := NOOP;
13850 ROP[29] := NOOP; ROP[30] := NOOP; ROP[31] := NOOP; ROP[32] := NOOP;
13860 ROP[33] := NOOP; ROP[34] := NOOP; ROP[35] := NOOP; ROP[36] := NOOP;
13870 ROP[37] := NOOP; ROP[38] := NOOP; ROP[39] := NOOP; ROP[40] := NOOP;
13880 ROP[41] := NOOP; ROP[42] := NOOP;
13890
13900 SOP['+'] := PLUS; SOP['-'] := MINUS; SOP['*'] := MUL; SOP['/'] := RDIV;
13910 SOP['='] := EQOP; SOP['#'] := NOOP; SOP['!'] := NOOP; SOP['&'] := NOOP;
13920 SOP['<'] := LTOP; SOP['>'] := GTOP; SOP['@'] := NOOP; SOP['"'] := NOOP;
13930 SOP[' '] := NOOP; SOP['$'] := NOOP; SOP['%'] := NOOP; SOP['('] := NOOP;
13940 SOP[')'] := NOOP; SOP[','] := NOOP; SOP['.'] := NOOP; SOP['0'] := NOOP;
13950 SOP['1'] := NOOP; SOP['2'] := NOOP; SOP['3'] := NOOP; SOP['4'] := NOOP;
13960 SOP['5'] := NOOP; SOP['6'] := NOOP; SOP['7'] := NOOP; SOP['8'] := NOOP;
13970 SOP['9'] := NOOP; SOP[':'] := NOOP; SOP[';'] := NOOP; SOP['?'] := NOOP;
13980 SOP['A'] := NOOP; SOP['B'] := NOOP; SOP['C'] := NOOP; SOP['D'] := NOOP;
13990 SOP['E'] := NOOP; SOP['F'] := NOOP; SOP['G'] := NOOP; SOP['H'] := NOOP;
14000 SOP['I'] := NOOP; SOP['J'] := NOOP; SOP['K'] := NOOP; SOP['L'] := NOOP;
14010 SOP['M'] := NOOP; SOP['N'] := NOOP; SOP['O'] := NOOP; SOP['P'] := NOOP;
14020 SOP['Q'] := NOOP; SOP['R'] := NOOP; SOP['S'] := NOOP; SOP['T'] := NOOP;
14030 SOP['U'] := NOOP; SOP['V'] := NOOP; SOP['W'] := NOOP; SOP['X'] := NOOP;
14040 SOP['Y'] := NOOP; SOP['Z'] := NOOP; SOP['['] := NOOP; SOP['\'] := NOOP;
14050 SOP[']'] := NOOP; SOP['^'] := NOOP; SOP['_'] := NOOP; SOP[''''] := NOOP
14060
14070 END (*OPERATORS*) ;
14080
14090 INITPROCEDURE (*RECORD SIZES*);
14100 BEGIN
14110
14120 DEBENTRY_SIZE := 8;
14130
14140 IDRECSIZE[TYPES] := 5;
14150 IDRECSIZE[KONST] := 6;
14160 IDRECSIZE[VARS] := 6;
14170 IDRECSIZE[FIELD] := 6;
14180 IDRECSIZE[PROC] := 5;
14190 IDRECSIZE[FUNC] := 5;
14200 IDRECSIZE[LABELS] := 5;
14210 STRECSIZE[SCALAR] := 2;
14220 STRECSIZE[SUBRANGE] := 4;
14230 STRECSIZE[POINTER] := 2;
14240 STRECSIZE[POWER] := 2;
14250 STRECSIZE[ARRAYS] := 3;
14260 STRECSIZE[RECORDS] := 3;
14270 STRECSIZE[FILES] := 2;
14280 STRECSIZE[TAGFWITHID] := 3;
14290 STRECSIZE[TAGFWITHOUTID] := 2;
14300 STRECSIZE[VARIANT] := 4
14310
14320 END (*RECORD SIZES*);
14330
14340
14350 INITPROCEDURE (*ERROR MESSAGES*) ;
14360 BEGIN
14370
14380 ERRMESS15[ 1] := '":" EXPECTED ';
14390 ERRMESS15[ 2] := '")" EXPECTED ';
14400 ERRMESS15[ 3] := '"(" EXPECTED ';
14410 ERRMESS15[ 4] := '"[" EXPECTED ';
14420 ERRMESS15[ 5] := '"]" EXPECTED ';
14430 ERRMESS15[ 6] := '";" EXPECTED ';
14440 ERRMESS15[ 7] := '"=" EXPECTED ';
14450 ERRMESS15[ 8] := '"," EXPECTED ';
14460 ERRMESS15[ 9] := '":=" EXPECTED ';
14470 ERRMESS15[10] := '"OF" EXPECTED ';
14480 ERRMESS15[11] := '"DO" EXPECTED ';
14490 ERRMESS15[12] := '"IF" EXPECTED ';
14500 ERRMESS15[13] := '"END" EXPECTED ';
14510 ERRMESS15[14] := '"THEN" EXPECTED';
14520 ERRMESS15[15] := '"EXIT" EXPECTED';
14530 ERRMESS15[16] := 'ILLEGAL SYMBOL ';
14540 ERRMESS15[17] := 'NO SIGN ALLOWED';
14550 ERRMESS15[18] := 'NUMBER EXPECTED';
14560 ERRMESS15[19] := 'NOT IMPLEMENTED';
14570 ERRMESS15[20] := 'ERROR IN TYPE ';
14580 ERRMESS15[21] := 'COMPILER ERROR ';
14590 ERRMESS15[22] := 'DEVICE EXPECTED';
14600 ERRMESS15[23] := 'ERROR IN FACTOR';
14610 ERRMESS15[24] := 'TOO MANY DIGITS';
14620
14630 ERRMESS20[ 1] := '"BEGIN" EXPECTED ';
14640 ERRMESS20[ 2] := '"UNTIL" EXPECTED ';
14650 ERRMESS20[ 3] := 'ERROR IN OPTIONS ';
14660 ERRMESS20[ 4] := 'CONSTANT TOO LARGE ';
14670 ERRMESS20[ 5] := 'DIGIT MUST FOLLOW ';
14680 ERRMESS20[ 6] := 'EXPONENT TOO LARGE ';
14690 ERRMESS20[ 7] := 'CONSTANT EXPECTED ';
14700 ERRMESS20[ 8] := 'SIMPLE TYPE EXPECTED';
14710 ERRMESS20[ 9] := 'IDENTIFIER EXPECTED ';
14720 ERRMESS20[10] := 'REALTYPE NOT ALLOWED';
14730 ERRMESS20[11] := 'MULTIDEFINED LABEL ';
14740 ERRMESS20[12] := 'FILENAME EXPECTED ';
14750 ERRMESS20[13] := 'SET TYPE EXPECTED ';
14760 ERRMESS20[14] := 'UNDEFINED LABEL ';
14770 ERRMESS20[15] := 'UNDECLARED LABEL ';
14780
14790 ERRMESS25[ 1] := '"TO"/"DOWNTO" EXPECTED ';
14800 ERRMESS25[ 2] := '8 OR 9 IN OCTAL NUMBER ';
14810 ERRMESS25[ 3] := 'IDENTIFIER NOT DECLARED ';
14820 ERRMESS25[ 4] := 'FILE NOT ALLOWED HERE ';
14830 ERRMESS25[ 5] := 'INTEGER CONSTANT EXPECTED';
14840 ERRMESS25[ 6] := 'ERROR IN PARAMETERLIST ';
14850 ERRMESS25[ 7] := 'ALREADY FORWARD DECLARED ';
14860 ERRMESS25[ 8] := 'THIS FORMAT FOR REAL ONLY';
14870 ERRMESS25[ 9] := 'VARIANTTYPE MUST BE ARRAY';
14880 ERRMESS25[10] := 'TYPE CONFLICT OF OPERANDS';
14890 ERRMESS25[11] := 'MULTIDEFINED CASE LABEL ';
14900 ERRMESS25[12] := 'FOR INTEGER ONLY "O"/"H" ';
14910 ERRMESS25[13] := 'ARRAY INDEX OUT OF BOUNDS';
14920 ERRMESS25[14] := 'MISSING FILE DECLARATION ';
14930 ERRMESS25[15] := 'LABEL CONSTANT TOO GREAT ';
14940 ERRMESS25[16] := 'LABEL ALREADY DECLARED ';
14950 ERRMESS25[17] := 'END OF PROGRAM NOT FOUND ';
14960 ERRMESS25[18] := 'MORE THAN 72 SET ELEMENTS';
14970
14980 ERRMESS30[ 1] := 'STRING CONSTANT IS TOO LONG ';
14990 ERRMESS30[ 2] := 'IDENTIFIER ALREADY DECLARED ';
15000 ERRMESS30[ 3] := 'SUBRANGE BOUNDS MUST BE SCALAR';
15010 ERRMESS30[ 4] := 'INCOMPATIBLE SUBRANGE TYPES ';
15020 ERRMESS30[ 5] := 'INCOMPATIBLE WITH TAGFIELDTYPE';
15030 ERRMESS30[ 6] := 'INDEX TYPE MAY NOT BE INTEGER ';
15040 ERRMESS30[ 7] := 'TYPE OF VARIABLE IS NOT ARRAY ';
15050 ERRMESS30[ 8] := 'TYPE OF VARIABLE IS NOT RECORD';
15060 ERRMESS30[ 9] := 'NO SUCH FIELD IN THIS RECORD ';
15070 ERRMESS30[10] := 'EXPRESSION TOO COMPLICATED ';
15080 ERRMESS30[11] := 'ILLEGAL TYPE OF OPERAND(S) ';
15090 ERRMESS30[12] := 'TESTS ON EQUALITY ALLOWED ONLY';
15100 ERRMESS30[13] := 'STRICT INCLUSION NOT ALLOWED ';
15110 ERRMESS30[14] := 'FILE COMPARISON NOT ALLOWED ';
15120 ERRMESS30[15] := 'ILLEGAL TYPE OF EXPRESSION ';
15130 ERRMESS30[16] := 'VALUE OF CASE LABEL TOO LARGE ';
15140 ERRMESS30[17] := 'TOO MANY NESTED WITHSTATEMENTS';
15150 ERRMESS30[18] := 'INVALID OR NO PROGRAM HEADING ';
15160 ERRMESS30[19] := 'TOO MANY LABEL DECLARATIONS ';
15170 ERRMESS30[20] := 'INCOMPATIBLE FORMALPARAMETER ';
15180
15190 ERRMESS35[ 1] := 'STRING CONSTANT CONTAINS "<CR><LF>"';
15200 ERRMESS35[ 2] := 'LABEL NOT DECLARED ON THIS LEVEL ';
15210 ERRMESS35[ 3] := 'CALL NOT ALLOWED IN EXTERN PROGRAMS';
15220 ERRMESS35[ 4] := 'MORE THAN 12 FILES DECLARED BY USER';
15230 ERRMESS35[ 5] := 'FILE AS VALUE PARAMETER NOT ALLOWED';
15240 ERRMESS35[ 6] := 'TOO MUCH CODE: USE OPTION CODESIZE ';
15250 ERRMESS35[ 7] := 'NO PACKED STRUCTURE ALLOWED HERE ';
15260 ERRMESS35[ 8] := 'VARIANT MUST BELONG TO TAGFIELDTYPE';
15270 ERRMESS35[ 9] := 'TYPE OF OPERAND(S) MUST BE BOOLEAN ';
15280 ERRMESS35[10] := 'SET ELEMENT TYPES NOT COMPATIBLE ';
15290 ERRMESS35[11] := 'ASSIGNMENT TO FILES NOT ALLOWED ';
15300 ERRMESS35[12] := 'TOO MANY LABELS IN THIS PROCEDURE ';
15310 ERRMESS35[13] := 'INITPROCEDURE NOT ALLOWED HERE ';
15320 ERRMESS35[14] := 'CONTROL VARIABLE MAY NOT BE FORMAL ';
15330 ERRMESS35[15] := 'ILLEGAL TYPE OF FOR-CONTROLVARIABLE';
15340 ERRMESS35[16] := 'ONLY PACKED FILE OF CHAR ALLOWED ';
15350 ERRMESS35[17] := 'CONSTANT NOT IN BOUNDS OF SUBRANGE ';
15360
15370 ERRMESS40[ 1] := 'IDENTIFIER IS NOT OF APPROPRIATE CLASS ';
15380 ERRMESS40[ 2] := 'TAGFIELD TYPE MUST BE SCALAR OR SUBRANGE';
15390 ERRMESS40[ 3] := 'INDEX TYPE MUST BE SCALAR OR SUBRANGE ';
15400 ERRMESS40[ 4] := 'TOO MANY NESTED SCOPES OF IDENTIFIERS ';
15410 ERRMESS40[ 5] := 'POINTER FORWARD REFERENCE UNSATISFIED ';
15420 ERRMESS40[ 6] := 'PREVIOUS DECLARATION WAS NOT FORWARD ';
15430 ERRMESS40[ 7] := 'TYPE OF VARIABLE MUST BE FILE OR POINTER';
15440 ERRMESS40[ 8] := 'MISSING CORRESPONDING VARIANTDECLARATION';
15450 ERRMESS40[ 9] := 'MORE THAN 6 VARIANTS IN CALL OF "NEW" ';
15460 ERRMESS40[10] := 'MORE THAN FOUR ERRORS IN THIS SOURCELINE';
15470 ERRMESS40[11] := 'NO INITIALISATION ON RECORDS OR FILES ';
15480
15490 ERRMESS45[ 1] := 'LOW BOUND MAY NOT BE GREATER THAN HIGH BOUND ';
15500 ERRMESS45[ 2] := 'IDENTIFIER OR "CASE" EXPECTED IN FIELDLIST ';
15510 ERRMESS45[ 3] := 'TOO MANY NESTED PROCEDURES AND/OR FUNCTIONS ';
15520 ERRMESS45[ 4] := 'FILE DECLARATION IN PROCEDURES NOT ALLOWED ';
15530 ERRMESS45[ 5] := 'MISSING RESULT TYPE IN FUNCTION DECLARATION ';
15540 ERRMESS45[ 6] := 'ASSIGNMENT TO FORMAL FUNCTION IS NOT ALLOWED ';
15550 ERRMESS45[ 7] := 'INDEX TYPE IS NOT COMPATIBLE WITH DECLARATION';
15560 ERRMESS45[ 8] := 'ERROR IN TYPE OF STANDARD PROCEDURE PARAMETER';
15570 ERRMESS45[ 9] := 'ERROR IN TYPE OF STANDARD FUNCTION PARAMETER ';
15580 ERRMESS45[10] := 'REAL AND STRING TAGFIELDS NOT IMPLEMENTED ';
15590 ERRMESS45[11] := 'SET ELEMENT TYPE MUST BE SCALAR OR SUBRANGE ';
15600 ERRMESS45[12] := 'ONLY ASSIGNMENTS ALLOWED IN INITPROCEDURES ';
15610 ERRMESS45[13] := 'NO CONSTANT OR EXPRESSION FOR VAR ARGUMENT ';
15620 ERRMESS45[14] := 'EXTERN DECLARATION NOT ALLOWED IN PROCEDURES ';
15630 ERRMESS45[15] := 'BODY OF FORWARD DECLARED PROCEDURE MISSING ';
15640 ERRMESS45[16] := 'DOUBLE FILE SPECIFICATION IN PROGRAM HEADING ';
15650 ERRMESS45[17] := 'TOO MUCH CODE FOR DEBUG: TRY MORE "CODESIZE" ';
15660 ERRMESS45[18] := 'NO FORMAL-PROC/FUNC IN FORTRAN-SUBROUTINE ';
15670
15680 ERRMESS50[ 1] := 'TOO MANY FORWARD REFERENCES OF PROCEDURE ENTRIES ';
15690 ERRMESS50[ 2] := 'ASSIGNMENT TO STANDARD FUNCTION IS NOT ALLOWED ';
15700 ERRMESS50[ 3] := 'PARAMETER TYPE DOES NOT AGREE WITH DECLARATION ';
15710 ERRMESS50[ 4] := 'INITIALISATION ONLY BY ASSIGNMENT OF CONSTANTS ';
15720 ERRMESS50[ 5] := 'LABEL TYPE INCOMPATIBLE WITH SELECTING EXPRESSION ';
15730 ERRMESS50[ 6] := 'STATEMENT MUST END WITH ";","END","ELSE"OR"UNTIL" ';
15740 ERRMESS50[ 7] := 'NOT ALLOWED IN INITPROCEDURES (PACKED STRUCTURE?) ';
15750 ERRMESS50[ 8] := 'GOTO INTO MAIN PROGRAM NOT ALLOWED IF "EXTERN" ';
15760 ERRMESS50[ 9] := 'ASSIGNMENT TO FUNCTION NOT ALLOWED ON THIS LEVEL ';
15770 ERRMESS50[10] := 'NO STD- OR FORTRAN-PROC/FUNC AS ACTUAL-PROC/FUNC ';
15780
15790 ERRMESS55[ 1] := 'FUNCTION RESULT TYPE MUST BE SCALAR,SUBRANGE OR POINTER';
15800 ERRMESS55[ 2] := 'REPETITION OF RESULT TYPE NOT ALLOWED IF FORW. DECL. ';
15810 ERRMESS55[ 3] := 'REPETITION OF PARAMETER LIST NOT ALLOWED IF FORW. DECL.';
15820 ERRMESS55[ 4] := 'NUMBER OF PARAMETERS DOES NOT AGREE WITH DECLARATION ';
15830 ERRMESS55[ 5] := 'RESULT TYPE OF PARAMETER-FUNC DOES NOT AGREE WITH DECL.';
15840 ERRMESS55[ 6] := 'SELECTED EXPRESSION MUST HAVE TYPE OF CONTROL VARIABLE '
15850
15860 END (*ERROR MESSAGES*) ;
15870
15880 (*----------------------------------------------------------------------------*)
15890
15900 PROCEDURE INIT_COMPILE;
15910 BEGIN
15920
15930 PROGRAM_COUNT := PROGRAM_COUNT + 1;
15940
15950 PROGRAMNAME := ' ';
15960
15970 FORWARD_POINTER_TYPE := NIL; LASTBTP := NIL;
15980 FGLOBPTR := NIL; FILEPTR := SFILEPTR;
15990 LOCALPFPTR := NIL; DECLSCALPTR := SDECLSCALPTR;
16000 GLOBTESTP := NIL; LAST_LABEL := NIL;
16010 ERRMPTR := NIL; PARMPTR := NIL;
16020 BACKWPARMPTR := NIL; EXTERNPFPTR := SEXTERNPFPTR;
16030 LASTBTP := SLASTBTP;
16040
16050 LOADNOPTR := TRUE; INITGLOBALS := FALSE;
16060 FOLLOWERROR := FALSE; ERRORINLINE := FALSE;
16070 DP := TRUE; SEARCH_ERROR := TRUE;
16080 ERROR_FLAG := FALSE; OVERRUN := FALSE;
16090 ERROR_EXIT := FALSE; TTYREAD := FALSE;
16100 ENTRY_DONE := FALSE; FIRST_SYMBOL := TRUE;
16110 RESET_POSSIBLE := TRUE;
16120
16130 IC := HIGH_START; LC := LOW_START;
16140 LIBRARY_INDEX := 0; ERRINX := 0;
16150 ERRORCOUNT := 0; ENTRIES := 0;
16160 DEBUGENTRY.STANDARDIDTREE := 0; DEBUGENTRY.GLOBALIDTREE := 0;
16170 JUMPER := 0; JUMP_ADDRESS := 0;
16180 AOS := B0;
16190
16200 FOR I := 1 TO 18 DO ARRAYBPS[I].STATE := UNUSED;
16210 ARRAYBPS[7].STATE := REQUESTED;
16220
16230 RTIME[0] := CLOCK;
16240 FOR I := 1 TO STDCHCNTMAX DO ERRLINE[I] := ' ';
16250 FOR SUPPORT_INDEX := FIRST(SUPPORT_INDEX) TO LAST(SUPPORT_INDEX) DO
16260 RUNTIME_SUPPORT.LINK[SUPPORT_INDEX] := 0;
16270
16280 RELOCATION_BLOCK.COUNT := 0;
16290
16300 TOP := 1; LEVEL := 1;
16310 WITH DISPLAY[1] DO
16320 BEGIN
16330 FNAME := NIL; OCCUR := BLCK
16340 END;
16350 WHILE EXTERNPFPTR <> NIL DO
16360 WITH EXTERNPFPTR^ DO
16370 BEGIN
16380 LINKCHAIN[0] := 0; EXTERNPFPTR := PFCHAIN
16390 END;
16400 EXTERNPFPTR := SEXTERNPFPTR;
16410 WHILE DECLSCALPTR <> NIL DO
16420 WITH DECLSCALPTR^ DO
16430 BEGIN
16440 VECTORADDR := 0; VECTORCHAIN := 0;
16450 REQUEST := FALSE; DECLSCALPTR := NEXTSCALAR
16460 END;
16470 DECLSCALPTR := SDECLSCALPTR;
16480 WHILE LASTBTP <> NIL DO
16490 WITH LASTBTP^ DO
16500 BEGIN
16510 ARRAYSP^.ARRAYBPADDR := 0; LASTBTP := LAST
16520 END;
16530 LASTBTP := SLASTBTP
16540
16550 END (* INIT_COMPILE *);
16560
16570 PROCEDURE ERROR(FERRNR: INTEGER);
16580 VAR
16590 LPOS,LARW : INTEGER;
16600 BEGIN
16610 ERRORCOUNT := ERRORCOUNT + 1;
16620 IF NOT FOLLOWERROR
16630 THEN
16640 BEGIN
16650 ERROR_FLAG := TRUE ;
16660 IF ERRINX >= MAXERR
16670 THEN
16680 BEGIN
16690 ERRLIST[MAXERR].NMR := 410; ERRINX := MAXERR
16700 END
16710 ELSE
16720 BEGIN
16730 ERRINX := ERRINX + 1;
16740 WITH ERRLIST[ERRINX] DO
16750 BEGIN
16760 NMR := FERRNR; TIC := '^'
16770 END
16780 END;
16790 FOLLOWERROR := TRUE; ERRORINLINE := TRUE;
16800 IF (FERRNR <> 214) AND (FERRNR <> 356) AND (FERRNR <> 405) AND
16810 (FERRNR <> 465) AND (FERRNR <> 467) AND (FERRNR <> 264) AND
16820 (FERRNR <> 267)
16830 THEN
16840 IF EOLN(SOURCE)
16850 THEN ERRLINE [CHCNT] := '^'
16860 ELSE ERRLINE [CHCNT-1] := '^'
16870 ELSE ERRLIST[ERRINX].TIC := ' ';
16880 IF ERRINX > 1
16890 THEN WITH ERRLIST [ ERRINX-1] DO
16900 BEGIN
16910 LPOS := POS; LARW := ARW
16920 END;
16930 WITH ERRLIST [ERRINX] DO
16940 BEGIN
16950 POS := CHCNT;
16960 IF ERRINX = 1
16970 THEN ARW := 1
16980 ELSE
16990 IF LPOS = CHCNT
17000 THEN ARW := LARW
17010 ELSE ARW := LARW + 1
17020 END
17030 END
17040 END (*ERROR*) ;
17050
17060 PROCEDURE ENTERID(FCP: CTP);
17070 (*ENTER ID POINTED TO BY FCP INTO THE NAME-TABLE,
17080 WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS
17090 AN UNBALANCED BINARY TREE*)
17100 VAR
17110 NEW_NAME: ALFA; LCP, LCP1: CTP; LLEFT: BOOLEAN;
17120 BEGIN
17130 LCP := DISPLAY[TOP].FNAME;
17140 IF LCP = NIL
17150 THEN DISPLAY[TOP].FNAME := FCP
17160 ELSE
17170 BEGIN
17180 NEW_NAME := FCP^.NAME;
17190 REPEAT
17200 LCP1 := LCP;
17210 IF LCP^.NAME <= NEW_NAME
17220 THEN
17230 BEGIN
17240 IF LCP^.NAME = NEW_NAME
17250 THEN (*NAME CONFLICT*)
17260 IF NEW_NAME[1] IN DIGITS
17270 THEN ERROR(266) (*MULTI-DECLARED LABEL*)
17280 ELSE ERROR(302) (*MULTI-DECLARED IDENTIFIER*) ;
17290 LCP := LCP^.RLINK; LLEFT := FALSE
17300 END
17310 ELSE
17320 BEGIN
17330 LCP := LCP^.LLINK; LLEFT := TRUE
17340 END
17350 UNTIL LCP = NIL;
17360 IF LLEFT
17370 THEN LCP1^.LLINK := FCP
17380 ELSE LCP1^.RLINK := FCP
17390 END;
17400 WITH FCP^ DO
17410 BEGIN
17420 LLINK := NIL; RLINK := NIL; SELFCTP := NIL
17430 END
17440 END (*ENTERID*) ;
17450
17460 PROCEDURE GET_DIRECTIVES;
17470
17480 (****************************************************************************************
17490 *
17500 * DECSYSTEM-10 CONCISE COMMAND LANGUAGE INTERFACE
17510 *
17520 * DEFINITIONS:
17530 *
17540 * <FILE SPECIFICATION> ::= <EMPTY> OR <FILENAME> OR
17550 * <DEVICE>:<FILENAME>.<EXTENSION>[<PROJECT>,<PROGRAMMER>]<<PROTECTION>>
17560 * (<SWITCH>/.../<SWITCH>)
17570 * /<SWITCH>.../<SWITCH>
17580 *
17590 * <PROGRAMNAME>, <DEVICE>, <FILENAME>, <EXTENSION> ::= <IDENTIFIER>
17600 * <PROJECT>, <PROGRAMMER>, <PROTECTION> ::= <UNSIGNED OCTAL NUMBER>
17610 * <SWITCH> ::= <IDENTIFIER> OR <IDENTIFIER>:<VALUE>
17620 * <VALUE> ::= <UNSIGNED DECIMAL NUMBER>
17630 *
17640 ****************************************************************************************)
17650
17660 TYPE
17670 ANYFILE = FILE OF INTEGER;
17680 PACK9 = PACKED ARRAY[1..9] OF CHAR;
17690 PACK6 = PACKED ARRAY[1..6] OF CHAR;
17700 PACK5 = PACKED ARRAY[1..5] OF CHAR;
17710 QUELLE_FORM = (TEMPFILE,COMMANDFILE,TELETYPEOUTPUT,TELETYPEINPUT,TELETYPE);
17720 DELIMITER = (BLANK,LPARENT,RPARENT,COMMA,POINT,SLASH,LESS,EQUAL,GREATER,RBRACK,LBRACK,COLON,EXCLAMATION,UNKNOWN);
17730 SWP = ^SWITCH_DESCRIPTOR;
17740 SWITCH_DESCRIPTOR = PACKED RECORD
17750 NAME: ALFA;
17760 LEFT, RIGHT: SWP;
17770 VALUE: INTEGER
17780 END;
17790
17800 VAR
17810 SOURCE_PROTECTION , SOURCE_UFD ,
17820 LIST_PROTECTION , LIST_UFD,
17830 OBJECT_PROTECTION , OBJECT_UFD : INTEGER ;
17840 SOURCE_DEVICE , LIST_DEVICE , OBJECT_DEVICE : PACK6 ;
17850 TMP_FILENAME, COM_FILENAME : PACK9;
17860 QUELLE: QUELLE_FORM;
17870 END_OF_FILENAME, DEFAULTED, ERROR : BOOLEAN;
17880 LASTCH: CHAR;
17890 CURRENT_SWITCH, NEW_SWITCH, SWITCH_TREE: SWP;
17900 DELIMITER1: ARRAY[' '..'/'] OF DELIMITER;
17910 DELIMITER2: ARRAY[':'..'>'] OF DELIMITER;
17920 DELIMITER3: ARRAY['['..']'] OF DELIMITER;
17930
17940 PROCEDURE STARTVALUES ;
17950 BEGIN
17960 QUELLE := TEMPFILE; ERROR := FALSE; DEFAULTED := TRUE; LASTCH := ' ';
17970 SWITCH_TREE := NIL; CURRENT_SWITCH := NIL;
17980 DELIMITER1[' '] := BLANK; DELIMITER1['!'] := EXCLAMATION;
17990 DELIMITER1['('] := LPARENT; DELIMITER1[')'] := RPARENT;
18000 DELIMITER1[','] := COMMA; DELIMITER1['.'] := POINT;
18010 DELIMITER1['/'] := SLASH;
18020 DELIMITER2[':'] := COLON; DELIMITER2['<'] := LESS;
18030 DELIMITER2['='] := EQUAL; DELIMITER2['>'] := GREATER;
18040 DELIMITER3['['] := LBRACK; DELIMITER3[']'] := RBRACK;
18050 END;
18060
18070 PROCEDURE ENTER(FNAME: ALFA; FVALUE: INTEGER);
18080
18090 PROCEDURE ENTER_SWITCH(FTREE: SWP);
18100 BEGIN
18110 WITH FTREE^ DO
18120 IF NEW_SWITCH^.NAME <> NAME
18130 THEN
18140 IF NEW_SWITCH^.NAME < NAME
18150 THEN
18160 IF LEFT = NIL
18170 THEN LEFT := NEW_SWITCH
18180 ELSE ENTER_SWITCH(LEFT)
18190 ELSE
18200 IF RIGHT = NIL
18210 THEN RIGHT := NEW_SWITCH
18220 ELSE ENTER_SWITCH(RIGHT)
18230 END (* ENTER_SWITCH *);
18240
18250 BEGIN (* ENTER *)
18260 NEW(NEW_SWITCH);
18270 WITH NEW_SWITCH^ DO
18280 BEGIN
18290 NAME := FNAME; VALUE := FVALUE;
18300 LEFT := NIL ; RIGHT := NIL
18310 END;
18320 IF SWITCH_TREE = NIL
18330 THEN SWITCH_TREE := NEW_SWITCH
18340 ELSE ENTER_SWITCH(SWITCH_TREE)
18350 END (* ENTER *);
18360
18370 (**********************************************************************
18380 *
18390 * FUNCTION OPTION
18400 *
18410 * - TEST IF <SWITCH> "SWITCHNAME" HAS BEEN
18420 * SPECIFIED IN THE DECSYSTEM-10 COMMAND-STRING
18430 * INTERPRETED BY PREVIOUS GETPARAMETER-/GETFILENAME-CALLS.
18440 *
18450 **********************************************************************)
18460
18470 FUNCTION OPTION(SWITCHNAME: ALFA): BOOLEAN;
18480
18490 FUNCTION FIND_SWITCH( FTREE: SWP): BOOLEAN;
18500 BEGIN
18510 IF FTREE <> NIL
18520 THEN
18530 WITH FTREE^ DO
18540 IF SWITCHNAME = NAME
18550 THEN
18560 BEGIN
18570 FIND_SWITCH := TRUE; CURRENT_SWITCH := FTREE
18580 END
18590 ELSE
18600 IF SWITCHNAME < NAME
18610 THEN
18620 FIND_SWITCH := FIND_SWITCH(LEFT)
18630 ELSE
18640 FIND_SWITCH := FIND_SWITCH(RIGHT)
18650 ELSE FIND_SWITCH := FALSE
18660 END (* FIND_SWITCH *);
18670
18680 BEGIN (*OPTION*)
18690 IF SWITCH_TREE = NIL
18700 THEN
18710 OPTION := FALSE
18720 ELSE
18730 OPTION := FIND_SWITCH(SWITCH_TREE)
18740 END (*OPTION*);
18750
18760 (**********************************************************************
18770 *
18780 * PROCEDURE GETOPTION
18790 *
18800 * - ASSIGN <VALUE> OF "SWITCHNAME" TO "SWITCHVALUE".
18810 *
18820 **********************************************************************)
18830
18840 PROCEDURE GETOPTION(SWITCHNAME: ALFA; VAR SWITCHVALUE: INTEGER);
18850 BEGIN
18860 IF OPTION(SWITCHNAME)
18870 THEN
18880 WITH CURRENT_SWITCH^ DO
18890 SWITCHVALUE := VALUE
18900 ELSE
18910 SWITCHVALUE := 0
18920 END (* GETOPTION *);
18930
18940 FUNCTION PICTURE(FCH: CHAR): DELIMITER;
18950 BEGIN
18960 IF FCH IN [' ','!','(',')',',','.','/',':','<','=','>','[',']']
18970 THEN
18980 IF FCH <= '/'
18990 THEN PICTURE := DELIMITER1[FCH]
19000 ELSE
19010 IF FCH <= '>'
19020 THEN PICTURE := DELIMITER2[FCH]
19030 ELSE PICTURE := DELIMITER3[FCH]
19040 ELSE PICTURE := UNKNOWN;
19050 END (* PICTURE *);
19060
19070 (**********************************************************************
19080 *
19090 * PROCEDURE GETFILENAME
19100 *
19110 * - READ DECSYSTEM-10 <FILE SPECIFICATION> FROM
19120 * "SOURCEFILE".
19130 *
19140 **********************************************************************)
19150
19160 PROCEDURE GETFILENAME(VAR SOURCEFILE: TEXT;
19170 VAR FILENAME: PACK9;
19180 VAR PROTECTION,UFD: INTEGER;
19190 VAR DEVICE: PACK6;
19200 FILEVARIABLE: ALFA);
19210 VAR
19220 BUFFER: ALFA;
19230 I, J, K, IMAX, OCVAL, SOURCE_PROT, SOURCE_PPN: INTEGER;
19240 SOURCE_FIL: PACKED ARRAY[1..9] OF CHAR;
19250 SOURCE_DEV: PACKED ARRAY[1..6] OF CHAR;
19260 CH,STATUS: CHAR;
19270 NEW_STATUS: BOOLEAN;
19280
19290 PROCEDURE RE_INITIALIZE;
19300 BEGIN
19310 I := 0; BUFFER := ' '; OCVAL := 0;
19320 NEW_STATUS := FALSE;
19330 END (* RE_INITIALIZE *);
19340
19350 PROCEDURE INITIALIZE;
19360 BEGIN
19370 FILENAME := ' '; DEVICE := 'DSK '; STATUS := ' '; IMAX := 6;
19380 CH := ' '; UFD := 0; PROTECTION := 0; ERROR := FALSE; END_OF_FILENAME := FALSE;
19390 RE_INITIALIZE; DEFAULTED := TRUE
19400 END (* INITIALIZE *);
19410
19420 PROCEDURE READCHAR;
19430 BEGIN
19440 I := I + 1;
19450 IF I > IMAX
19460 THEN ERROR := TRUE
19470 ELSE BUFFER[I] := CH
19480 END (*READCHAR*) ;
19490
19500 PROCEDURE READOCTAL;
19510 BEGIN
19520 IF CH IN ['0'..'7']
19530 THEN
19540 BEGIN
19550 OCVAL := OCVAL * 10B + ORD(CH) - ORD('0')
19560 END
19570 ELSE ERROR := TRUE
19580 END (*READOCTAL*) ;
19590
19600 PROCEDURE READDECIMAL;
19610 BEGIN
19620 IF CH IN ['0'..'9']
19630 THEN
19640 BEGIN
19650 OCVAL := OCVAL * 10 + ORD(CH) - ORD('0')
19660 END
19670 ELSE ERROR := TRUE
19680 END (*READDECIMAL*) ;
19690
19700 PROCEDURE SETSTATUS;
19710 BEGIN
19720 IF CH <> ' '
19730 THEN
19740 BEGIN
19750 CASE PICTURE(CH) OF
19760 COLON :
19770 ERROR := STATUS <> ' ';
19780 POINT :
19790 ERROR := NOT (STATUS IN [' ',':']);
19800 LBRACK :
19810 ERROR := NOT (STATUS IN [' ',':','.']);
19820 LESS :
19830 ERROR := NOT (STATUS IN [' ',':','.',']']);
19840 COMMA :
19850 ERROR := STATUS <> '[';
19860 RBRACK :
19870 ERROR := STATUS <> ',';
19880 GREATER :
19890 ERROR := STATUS <> '<';
19900 SLASH :
19910 ERROR := NOT (STATUS IN [' ',':','.',']','>',')']);
19920 LPARENT :
19930 ERROR := NOT (STATUS IN [' ',':','.',']','>']);
19940 RPARENT :
19950 ERROR := STATUS <> '(';
19960 OTHERS :
19970 ERROR := TRUE
19980 END;
19990 IF NOT ERROR
20000 THEN
20010 BEGIN
20020 NEW_STATUS := TRUE; STATUS := CH
20030 END
20040 END
20050 END (*SETSTATUS*) ;
20060
20070 PROCEDURE READSWITCH;
20080 VAR
20090 READ_VALUE, END_OF_SWITCH: BOOLEAN;
20100 BEGIN
20110 IF NOT EOLN(SOURCEFILE)
20120 THEN
20130 BEGIN
20140 REPEAT
20150 IMAX := ALFALENGTH;
20160 RE_INITIALIZE;
20170 READ_VALUE := FALSE;
20180 END_OF_SWITCH := FALSE;
20190 LOOP
20200 IF EOLN(SOURCEFILE)
20210 THEN
20220 BEGIN
20230 END_OF_SWITCH := TRUE; CH := ' '
20240 END
20250 ELSE READ(SOURCEFILE,CH);
20260 LASTCH := CH
20270 EXIT IF NOT (CH IN ['0'..'9',':','A'..'Z',' ']) OR END_OF_SWITCH;
20280 IF CH <> ' '
20290 THEN
20300 IF READ_VALUE
20310 THEN READDECIMAL
20320 ELSE
20330 IF CH = ':'
20340 THEN READ_VALUE := TRUE
20350 ELSE READCHAR
20360 END;
20370 IF I > 0
20380 THEN ENTER(BUFFER,OCVAL)
20390 UNTIL NOT (CH IN ['/','!',',']) OR ((CH = ',') AND (STATUS <> '(')) OR END_OF_SWITCH;
20400 IF CH IN [',','=']
20410 THEN
20420 BEGIN
20430 END_OF_FILENAME := TRUE; CH := ' '
20440 END;
20450 SETSTATUS
20460 END
20470 END (* READSWITCH *);
20480
20490
20500 PROCEDURE OPERAND;
20510
20520 PROCEDURE NEXTCH;
20530 BEGIN
20540 IF EOLN(SOURCEFILE)
20550 THEN
20560 BEGIN
20570 END_OF_FILENAME := TRUE; CH := ' '
20580 END
20590 ELSE READ(SOURCEFILE,CH);
20600 LASTCH := CH;
20610 IF END_OF_FILENAME OR ((CH=',') AND (STATUS<>'[')) OR (CH='=')
20620 THEN
20630 BEGIN
20640 END_OF_FILENAME := TRUE;
20650 CASE PICTURE(STATUS) OF
20660 BLANK:
20670 CH := '.';
20680 COLON:
20690 CH := '.';
20700 POINT:
20710 CH := '[';
20720 RPARENT,
20730 SLASH,
20740 GREATER,
20750 RBRACK:
20760 BEGIN
20770 CH := ' '; STATUS := ' '
20780 END;
20790 OTHERS:
20800 BEGIN
20810 ERROR := TRUE; CH := ' '
20820 END
20830 END
20840 END
20850 END (*NEXTCH*) ;
20860
20870 BEGIN
20880 (*OPERAND*)
20890 REPEAT
20900 NEXTCH;
20910 IF CH IN ['A'..'Z','0'..'9']
20920 THEN
20930 IF STATUS IN ['[',',','<']
20940 THEN READOCTAL
20950 ELSE READCHAR
20960 ELSE SETSTATUS
20970 UNTIL NEW_STATUS OR ERROR OR END_OF_FILENAME
20980 END (*OPERAND*) ;
20990
21000 PROCEDURE ASSIGNFILENAMEOREXTENSION;
21010 BEGIN
21020 IF I > 0
21030 THEN
21040 IF (FILENAME[1] = ' ') OR ((FILENAME[7] = ' ') AND (IMAX = 3))
21050 THEN
21060 BEGIN
21070 IF IMAX = 3
21080 THEN K := 6
21090 ELSE K := 0;
21100 FOR J := 1 TO IMAX DO FILENAME[K+J] := BUFFER[J];
21110 END
21120 END;
21130
21140 BEGIN
21150 (*GETFILENAME*)
21160 INITIALIZE;
21170 IF NOT EOF(SOURCEFILE)
21180 THEN
21190 IF NOT EOLN(SOURCEFILE)
21200 THEN
21210 REPEAT
21220 OPERAND;
21230 IF NOT ERROR
21240 THEN
21250 BEGIN
21260 CASE PICTURE(STATUS) OF
21270 COLON:
21280 IF I > 0
21290 THEN
21300 BEGIN
21310 DEVICE := ' ' ;
21320 FOR J := 1 TO I DO DEVICE[J] := BUFFER[J];
21330 END ;
21340 POINT:
21350 BEGIN
21360 ASSIGNFILENAMEOREXTENSION; IMAX := 3
21370 END;
21380 LESS,
21390 LBRACK:
21400 ASSIGNFILENAMEOREXTENSION;
21410 LPARENT,
21420 SLASH:
21430 BEGIN
21440 ASSIGNFILENAMEOREXTENSION; READSWITCH
21450 END;
21460 COMMA :
21470 UFD := OCVAL * 1000000B;
21480 RBRACK :
21490 UFD := UFD + OCVAL;
21500 GREATER :
21510 PROTECTION := OCVAL
21520 END;
21530 RE_INITIALIZE; DEFAULTED := FALSE
21540 END
21550 UNTIL ERROR OR END_OF_FILENAME;
21560 DEFAULTED := FILENAME[1] = ' ';
21570 IF NOT DEFAULTED
21580 THEN
21590 IF NOT ERROR AND EOLN(SOURCEFILE) AND (PRED(QUELLE) <= COMMANDFILE) AND NOT EOF(SOURCEFILE)
21600 THEN
21610 BEGIN
21620 READLN(SOURCEFILE); STATUS := ' '; CH := ' '; READSWITCH
21630 END;
21640 END (*GETFILENAME*);
21650
21660 (**********************************************************************
21670 *
21680 * PROCEDURE GETPARAMETER
21690 *
21700 * - READ A DECSYSTEM-10 <FILE SPECIFICATION> FROM EITHER
21710 *
21720 * * A TEMPCORE-FILE NAMED <1ST 3 CHARS. OF PROGRAMNAME>.TMP,
21730 * CREATED BY DECSYSTEM-10 COMPIL-CLASS COMMANDS OR USER, OR
21740 *
21750 * * A COMMAND-FILE NAMED <1ST 6 CHARS. OF PROGRAMNAME>.CMD,
21760 * CREATED BY USER, OR
21770 *
21780 * * TTY
21790 *
21800 * ALL FILES HAVE TO BE "TEXT"-FILES.
21810 *
21820 * TEMPCORE-FILES CAN BE ACCESSED AND CREATED AUTOMATICALLY
21830 * BY PASCAL PROGRAMS IF THE FILENAME IS SPECIFIED AS
21840 * 'XXX TMP' AND DEVICE IS 'DSK ', WHERE XXX ARE
21850 * THE 1ST 3 CHARACTERS OF THE <PROGRAMNAME>. IF THE TEMPCORE-FILE
21860 * CANNOT BE FOUND/CREATED THE DISK-FILE 'NNNXXXTMP' IS
21870 * SEARCHED/CREATED, WHERE NNN IS THE JOB-NUMBER.
21880 *
21890 * THE INPUT FORMAT IS FOR
21900 *
21910 * * TEMPCORE- AND COMMAND-FILES:
21920 *
21930 * <FILE SPECIFICATION>,...,<FILE SPECIFICATION><CR><LF>
21940 * <SWITCH>!...<SWITCH>!<CR><LF>
21950 *
21960 * THE SECOND LINE (USED BY COMPIL-CLASS COMMANDS) IS OPTIONAL
21970 *
21980 * * TTY:
21990 *
22000 * <FILE SPECIFICATION><CR><LF>
22010 *
22020 ***********************************************************************)
22030
22040
22050 PROCEDURE INITIALIZE;
22060 BEGIN
22070 IF QUELLE <> TELETYPE
22080 THEN
22090 BEGIN
22100 CASE QUELLE OF
22110 TEMPFILE:
22120 BEGIN
22130 COM_FILENAME := 'PASCALCMD';
22140 TMP_FILENAME := 'PAS TMP';
22150 RESET(TTYIN,TMP_FILENAME,0,0,'DSK ')
22160 END;
22170 COMMANDFILE:
22180 RESET(TTYIN,COM_FILENAME);
22190 TELETYPEOUTPUT:
22200 REWRITE(TTY,'TTYOUTPUT');
22210 TELETYPEINPUT:
22220 RESET(TTYIN,'TTY ',0,0,'TTY ')
22230 END;
22240 QUELLE := SUCC(QUELLE);
22250 IF EOF(TTYIN) AND NOT (QUELLE IN [TELETYPEINPUT,TELETYPE])
22260 THEN INITIALIZE;
22270 END
22280 END (* INITIALIZE *);
22290
22300 PROCEDURE GETPARAMETER(VAR FILENAME: PACK9;
22310 VAR PROTECTION,UFD: INTEGER;
22320 VAR DEVICE: PACK6;
22330 FILEIDENT: ALFA);
22340
22350 VAR
22360 I : 1..3 ;
22370 FILE_EXTENSION : PACKED ARRAY [ 1..3 ] OF CHAR ;
22380
22390 BEGIN (*GETPARAMETER*)
22400 LOOP
22410 IF QUELLE IN [TELETYPE,TELETYPEINPUT]
22420 THEN
22430 BEGIN
22440 WRITE(TTY,FILEIDENT,'= ');BREAK(TTY);
22450 IF QUELLE = TELETYPEINPUT
22460 THEN INITIALIZE
22470 ELSE READLN(TTYIN)
22480 END;
22490 GETFILENAME(TTYIN,FILENAME,PROTECTION,UFD,DEVICE,FILEIDENT);
22500 IF DEVICE = 'LPT '
22510 THEN ENTER('LPT ',0) ;
22520 IF (PRED(QUELLE) <= COMMANDFILE) AND (FILENAME[7] = ' ') AND NOT DEFAULTED
22530 THEN
22540 BEGIN
22550 IF FILEIDENT = 'SOURCE '
22560 THEN FILE_EXTENSION := 'PAS'
22570 ELSE
22580 IF FILEIDENT = 'LIST '
22590 THEN FILE_EXTENSION := 'LST'
22600 ELSE FILE_EXTENSION := 'REL' ;
22610 FOR I := 1 TO 3 DO FILENAME[6+I] := FILE_EXTENSION[I] ;
22620 END ;
22630 EXIT IF NOT ( ERROR OR (FILEIDENT = 'SOURCE ') AND (DEVICE = 'LPT ') ) ;
22640 IF QUELLE <> TELETYPE
22650 THEN
22660 BEGIN
22670 QUELLE := TELETYPEOUTPUT; INITIALIZE
22680 END;
22690 WRITELN(TTY,'%? SYNTAX ERROR: REENTER') ; BREAK(TTY) ;
22700 END (* LOOP *) ;
22710 END (*GETPARAMETER*) ;
22720
22730 BEGIN (*GET_DIRECTIVES*)
22740 STARTVALUES ; INITIALIZE ;
22750 GETPARAMETER(OBJECT_FILE,OBJECT_PROTECTION,OBJECT_UFD,OBJECT_DEVICE,'OBJECT ');
22760 GETPARAMETER(LIST_FILE,LIST_PROTECTION,LIST_UFD,LIST_DEVICE,'LIST ');
22770 GETPARAMETER(SOURCE_FILE,SOURCE_PROTECTION,SOURCE_UFD,SOURCE_DEVICE,'SOURCE ');
22780 LOOP
22790 IF SOURCE_FILE = ' '
22800 THEN RESET(SOURCE,'SOURCE ',0,0,'DSK ')
22810 ELSE RESET(SOURCE,SOURCE_FILE,SOURCE_PROTECTION,SOURCE_UFD,SOURCE_DEVICE) ;
22820 EXIT IF NOT EOF(SOURCE) ;
22830 WRITE(TTY,'%? NO ACCESS TO ') ;
22840 IF SOURCE_FILE = ' '
22850 THEN WRITE(TTY,'SOURCE')
22860 ELSE WRITE(TTY,SOURCE_FILE:6,'.',SOURCE_FILE[7],SOURCE_FILE[8],SOURCE_FILE[9]);
22870 WRITELN(TTY,' OR NOT FOUND: REENTER') ; BREAK(TTY) ;
22880 GETPARAMETER(SOURCE_FILE,SOURCE_PROTECTION,SOURCE_UFD,SOURCE_DEVICE,'SOURCE ') ;
22890 END (* LOOP FOR SOURCE_FILE *) ;
22900
22910 REWRITE(OBJECT,OBJECT_FILE,OBJECT_PROTECTION,OBJECT_UFD,OBJECT_DEVICE) ;
22920
22930 CROSS_REFERENCE := OPTION('CREF ') OR OPTION('C ') ;
22940
22950 LIST_CODE := OPTION('CODE ');
22960
22970 LPTFILE := NOT OPTION('NOLIST ') AND ( OPTION('LPT ') OR
22980 OPTION('LIST ') OR
22990 (LIST_FILE <> ' ') OR
23000 LIST_CODE ) ;
23010
23020 IF LPTFILE
23030 THEN REWRITE(LIST,LIST_FILE,LIST_PROTECTION,LIST_UFD,LIST_DEVICE) ;
23040
23050 DEBUG := OPTION('DEBUG ');
23060 DEBUG_SWITCH := DEBUG;
23070
23080 RUNTIME_CHECK := NOT OPTION('NOCHECK ');
23090
23100 FORTRAN_ENVIROMENT := OPTION('FORTIO ');
23110
23120 EXTERNAL := OPTION('EXTERN ');
23130
23140 LOAD_AND_GO := (OPTION('EXECUTE ') OR OPTION('LINK ')) AND NOT EXTERNAL;;
23150
23160 IF OPTION('CARD ')
23170 THEN CHCNTMAX := 72;
23180
23190 IF OPTION('FILE ')
23200 THEN
23210 BEGIN
23220 GETOPTION('FILE ',I);
23230 IF I IN [1..MAX_FILE]
23240 THEN START_CHANNEL := I + NAMAX[STDFILE] - 2
23250 END;
23260
23270 IF OPTION('CODESIZE ')
23280 THEN GETOPTION('CODESIZE ',CODE_SIZE);
23290
23300 IF OPTION('REGISTER ')
23310 THEN
23320 BEGIN
23330 GETOPTION('REGISTER ',I);
23340 IF I IN [REGIN..WITHIN]
23350 THEN PARREGCMAX := I
23360 END;
23370
23380 IF OPTION('RUNCORE ')
23390 THEN GETOPTION('RUNCORE ',RUNCORE);
23400
23410 RESET(TEMPCORE,'LNK TMP');
23420 IF NOT EOF(TEMPCORE)
23430 THEN
23440 BEGIN
23450 NEW(COMMAND_BUFFER:BUFFER_SIZE);
23460 COMMAND_BUFFER^[0] := ' '; I := 1;
23470 WHILE NOT EOF(TEMPCORE) AND (I < BUFFER_SIZE) DO
23480 BEGIN
23490 IF EOLN(TEMPCORE)
23500 THEN
23510 BEGIN
23520 READLN(TEMPCORE);
23530 COMMAND_BUFFER^[I] := CR;
23540 COMMAND_BUFFER^[I+1] := LF; I := I + 2
23550 END
23560 ELSE
23570 BEGIN
23580 READ(TEMPCORE,CH);
23590 COMMAND_BUFFER^[I] := CH;
23600 IF (COMMAND_BUFFER^[I-1] = '/') AND (CH = 'D')
23610 THEN
23620 BEGIN
23630 DEBUG := TRUE; DEBUG_SWITCH := TRUE; I := I - 1
23640 END
23650 ELSE I := I + 1
23660 END
23670 END;
23680 REWRITE(TEMPCORE,'LNK TMP');
23690 WRITE(TEMPCORE,COMMAND_BUFFER^:I);
23700 DISPOSE(COMMAND_BUFFER:BUFFER_SIZE)
23710 END
23720 ELSE
23730 BEGIN
23740 IF LOAD_AND_GO
23750 THEN
23760 BEGIN
23770 REWRITE(TEMPCORE,'LNK TMP');
23780 WRITE(TEMPCORE,'DSK:',OBJECT_FILE:6,' /G ');
23790 IF OPTION('EXECUTE ')
23800 THEN WRITE(TEMPCORE,'/E')
23810 END
23820 END;
23830 END (*GET_DIRECTIVES*) ;
23840
23850
23860
23870 PROCEDURE COMPILE;
23880
23890 LABEL
23900 111;
23910
23920 VAR
23930 ESCAPE: BOOLEAN;
23940
23950 PROCEDURE NEWPAGER;
23960 BEGIN
23970 WITH PAGER, WORD1 DO
23980 BEGIN
23990 AC := PAGECNT DIV 16;
24000 INXREG := PAGECNT MOD 16; ADDRESS := LASTPAGER;
24010 LHALF := LASTLINE; RHALF := LASTSTOP;
24020 LASTLINE := -1
24030 END
24040 END;
24050
24060 PROCEDURE WRITEBUFFER;
24070 BEGIN
24080 IF LIST_CODE
24090 THEN
24100 BEGIN
24110 WRITELN(LIST,BUFFER:CHCNT); FOR CHCNT := 1 TO 17 DO BUFFER[CHCNT] := ' '; CHCNT := 17
24120 END
24130 END;
24140
24150 PROCEDURE GETNEXTLINE;
24160 BEGIN
24170 LOOP
24180 GETLINENR(SOURCE,LINENR)
24190 EXIT IF (LINENR <> ' ') OR EOF(SOURCE);
24200 IF DEBUG AND (LASTLINE > -1)
24210 THEN NEWPAGER;
24220 PAGECNT := PAGECNT + 1;
24230 IF LPTFILE
24240 THEN
24250 BEGIN
24260 PAGE(LIST); WRITELN(LIST,'PAGE ',PAGECNT:3); WRITELN(LIST)
24270 END;
24280 READLN(SOURCE) (*TO OVERREAD SECOND <LF> IN PAGE MARK*)
24290 END;
24300 IF LIST_CODE
24310 THEN
24320 BEGIN
24330 IF DP
24340 THEN WRITE(LIST,LC:6:O,SHOWRELO[(LC >= LOW_START) AND (LEVEL <= 1)])
24350 ELSE WRITE(LIST,IC:6:O,'''');
24360 WRITE(LIST,' ':2)
24370 END;
24380 IF LPTFILE
24390 THEN
24400 BEGIN
24410 IF LINENR='-----'
24420 THEN WRITE(LIST,LINECNT:5)
24430 ELSE WRITE(LIST,LINENR) ;
24440 WRITE(LIST,' ':3)
24450 END
24460 END (*GETNEXTLINE*);
24470
24480 PROCEDURE ENDOFLINE;
24490 VAR
24500 I,K: INTEGER;
24510 BEGIN
24520 IF CHCNT > CHCNTMAX
24530 THEN CHCNT := CHCNTMAX;
24540 IF LPTFILE
24550 THEN WRITELN(LIST,BUFFER:CHCNT);
24560 IF ERRORINLINE
24570 THEN (*OUTPUT ERROR MESSAGES*)
24580 BEGIN
24590 IF ERROR_IN_HEADING
24600 THEN WRITELN(TTY);
24610 ERROR_IN_HEADING := FALSE;
24620 IF LIST_CODE
24630 THEN K := 11
24640 ELSE K := 2;
24650 IF LPTFILE
24660 THEN WRITE(LIST,' ':K,'***** '); LIST_CODE := FALSE;
24670 IF LINENR = '-----'
24680 THEN WRITE(TTY,LINECNT:5)
24690 ELSE WRITE(TTY,LINENR);
24700 WRITELN(TTY,' ':3,BUFFER:CHCNT); WRITE(TTY,'P*',PAGECNT:3,'** ');
24710 IF LPTFILE
24720 THEN WRITELN(LIST,ERRLINE : CHCNT); WRITELN(TTY,ERRLINE : CHCNT);
24730 FOR K := 1 TO ERRINX DO
24740 WITH ERRLIST[K] DO
24750 BEGIN
24760 IF LPTFILE
24770 THEN WRITE(LIST,' ':15,ARW:1,'.',TIC,': '); WRITE(TTY,ARW:1,'.',TIC,': ');
24780 IF ERRMPTR <> NIL
24790 THEN
24800 BEGIN
24810 ERRMPTR1 := ERRMPTR;
24820 REPEAT
24830 WITH ERRMPTR1^ DO
24840 IF NMR = NUMBER
24850 THEN
24860 BEGIN
24870 IF LPTFILE
24880 THEN WRITE(LIST,STRING:10,' - ');WRITE(TTY,STRING:10,' - ');
24890 NUMBER := 0; ERRMPTR1 := NIL
24900 END
24910 ELSE ERRMPTR1 := NEXT
24920 UNTIL ERRMPTR1 = NIL
24930 END;
24940 I := NMR MOD 50;
24950 CASE NMR DIV 50 OF
24960 3:
24970 BEGIN
24980 IF LPTFILE
24990 THEN WRITE(LIST,ERRMESS15[I]); WRITE(TTY,ERRMESS15[I])
25000 END;
25010 4:
25020 BEGIN
25030 IF LPTFILE
25040 THEN WRITE(LIST,ERRMESS20[I]); WRITE(TTY,ERRMESS20[I])
25050 END;
25060 5:
25070 BEGIN
25080 IF LPTFILE
25090 THEN WRITE(LIST,ERRMESS25[I]); WRITE(TTY,ERRMESS25[I])
25100 END;
25110 6:
25120 BEGIN
25130 IF LPTFILE
25140 THEN WRITE(LIST,ERRMESS30[I]); WRITE(TTY,ERRMESS30[I])
25150 END;
25160 7:
25170 BEGIN
25180 IF LPTFILE
25190 THEN WRITE(LIST,ERRMESS35[I]); WRITE(TTY,ERRMESS35[I])
25200 END;
25210 8:
25220 BEGIN
25230 IF LPTFILE
25240 THEN WRITE(LIST,ERRMESS40[I]); WRITE(TTY,ERRMESS40[I])
25250 END;
25260 9:
25270 BEGIN
25280 IF LPTFILE
25290 THEN WRITE(LIST,ERRMESS45[I]); WRITE(TTY,ERRMESS45[I])
25300 END;
25310 10:
25320 BEGIN
25330 IF LPTFILE
25340 THEN WRITE(LIST,ERRMESS50[I]); WRITE(TTY,ERRMESS50[I])
25350 END;
25360 11:
25370 BEGIN
25380 IF LPTFILE
25390 THEN WRITE(LIST,ERRMESS55[I]); WRITE(TTY,ERRMESS55[I])
25400 END
25410 END;
25420 IF LPTFILE
25430 THEN WRITELN(LIST); WRITELN(TTY)
25440 END;
25450 BREAK(TTY); ERRINX := 0; ERRORINLINE := FALSE;
25460 FOR I := 1 TO CHCNT DO ERRLINE [I] := ' ';
25470 ERRMPTR := NIL
25480 END;
25490 READLN(SOURCE);
25500 LINECNT := LINECNT + 10; CHCNT := 0;
25510
25520 IF ERROR_EXIT
25530 THEN
25540 IF FIRST_SYMBOL
25550 THEN GOTO 0
25560 ELSE GOTO 111
25570 ELSE
25580 BEGIN
25590 IF NOT EOF(SOURCE)
25600 THEN GETNEXTLINE
25610 ELSE
25620 BEGIN
25630 IF NOT FIRST_SYMBOL
25640 THEN ERROR(267);
25650 ERROR_EXIT := TRUE;
25660 ENDOFLINE
25670 END
25680 END
25690
25700 END (*ENDOFLINE*) ;
25710
25720 PROCEDURE ERROR_WITH_TEXT ( FERRNR: INTEGER; FTEXT: ALFA ) ;
25730 BEGIN
25740 ERROR(FERRNR); NEW(ERRMPTR1);
25750 WITH ERRMPTR1^ DO
25760 BEGIN
25770 NUMBER := FERRNR; STRING := FTEXT;
25780 NEXT := ERRMPTR
25790 END;
25800 ERRMPTR := ERRMPTR1
25810 END (*ERROR WITH TEXT*) ;
25820
25830 PROCEDURE INSYMBOL;
25840
25850 (*READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS
25860 DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LGTH*)
25870
25880 LABEL
25890 222;
25900
25910 CONST
25920 MAXDIGITS = 12;
25930 MAX8 = 37777777777B;
25940 TEST8 = 40000000000B;
25950 MAX10 = 3435973836; (* MAXINT = 2 ** 35 - 1 = 34.359.738.367 *)
25960 MAX16 = 17777777777B;
25970 TEST16 = 20000000000B;
25980 MAXEXP2 = 127; (* MAXREAL = 777.777.777B * 2 ** 100 *)
25990 LOG_OF_2 = 0.30102999806;
26000
26010 VAR
26020 I, K, SCALE, EXPONENT, IVAL: INTEGER;
26030 RVAL, R, FAC: REAL;
26040 STRINGTOOLONG, SIGN: BOOLEAN;
26050 DIGIT: ARRAY [1..MAXDIGITS] OF 0..9;
26060 STRING: ARRAY [1..STRGLGTH] OF CHAR;
26070 LVP: CSP;
26080
26090 PROCEDURE NEXTCH;
26100 BEGIN
26110 IF EOLN(SOURCE)
26120 THEN CH := ' '
26130 ELSE
26140 BEGIN
26150 CH := SOURCE^; GET(SOURCE);
26160 CHCNT := CHCNT + 1;
26170 IF CHCNT <= CHCNTMAX
26180 THEN BUFFER[CHCNT] := CH
26190 ELSE
26200 IF CHCNTMAX = 72
26210 THEN NEXTCH
26220 END
26230 END;
26240
26250 PROCEDURE SKIPCOMMENT;
26260 VAR
26270 COMMENTEND: BOOLEAN;
26280
26290 PROCEDURE OPTIONS;
26300 VAR
26310 LCH : CHAR;
26320 LSWITCH : BOOLEAN;
26330 LVALUE : INTEGER;
26340 BEGIN
26350 REPEAT
26360 LVALUE := 0; LSWITCH := FALSE;
26370 NEXTCH; LCH := CH;
26380 IF NOT (CH IN ['\','*'])
26390 THEN NEXTCH;
26400 IF CH IN (['+','-'] + DIGITS)
26410 THEN
26420 BEGIN
26430 IF CH IN ['+','-']
26440 THEN
26450 BEGIN
26460 LSWITCH := CH = '+'; NEXTCH
26470 END
26480 ELSE
26490 REPEAT
26500 LVALUE := LVALUE * 10 + (ORD(CH)-ORD('0'));
26510 NEXTCH
26520 UNTIL NOT (CH IN DIGITS);
26530 IF NOT RESET_POSSIBLE AND (LCH IN ['S','R','X','F','I','U','E'])
26540 THEN ERROR(203)
26550 ELSE
26560 CASE LCH OF
26570 'L':
26580 LIST_CODE := LSWITCH AND LPTFILE;
26590 'U':
26600 CHCNTMAX := 72;
26610 'T':
26620 RUNTIME_CHECK := LSWITCH;
26630 'E':
26640 IF PROGRAM_COUNT > 1
26650 THEN ERROR(203)
26660 ELSE EXTERNAL := LSWITCH;
26670 'D','P':
26680 IF RESET_POSSIBLE
26690 THEN
26700 BEGIN
26710 DEBUG := LSWITCH;
26720 DEBUG_SWITCH := LSWITCH
26730 END
26740 ELSE
26750 IF DEBUG
26760 THEN DEBUG_SWITCH := LSWITCH
26770 ELSE ERROR(203);
26780 'F':
26790 IF LVALUE IN [1..MAX_FILE]
26800 THEN START_CHANNEL := LVALUE + NAMAX[STDFILE] - 2
26810 ELSE ERROR(203);
26820 'R':
26830 RUNCORE := LVALUE;
26840 'X':
26850 IF LVALUE IN [REGIN..WITHIN]
26860 THEN PARREGCMAX := LVALUE
26870 ELSE ERROR(203);
26880 'S':
26890 CODE_SIZE := LVALUE;
26900 'I':
26910 FORTRAN_ENVIROMENT := LSWITCH;
26920 OTHERS:
26930 IF LCH = 'B'
26940 THEN ERROR(169)
26950 ELSE ERROR(203)
26960 END
26970 END
26980 ELSE ERROR(203);
26990 IF EOLN(SOURCE)
27000 THEN ENDOFLINE
27010 UNTIL CH <> ','
27020 END (*OPTIONS*) ;
27030
27040 BEGIN (*SKIPCOMMENT*)
27050 COMMENTEND := FALSE; NEXTCH;
27060 IF CH = '$'
27070 THEN OPTIONS;
27080 LOOP
27090 WHILE CH = '*' DO
27100 BEGIN
27110 NEXTCH;
27120 COMMENTEND := CH = ')'
27130 END
27140 EXIT IF (CH='\') OR COMMENTEND;
27150 IF EOLN(SOURCE)
27160 THEN ENDOFLINE;
27170 NEXTCH
27180 END (*LOOP*);
27190 NEXTCH
27200 END (*SKIPCOMMENT*);
27210
27220 BEGIN
27230 (*INSYMBOL*)
27240 WHILE CH = ' ' DO
27250 BEGIN
27260 IF EOLN(SOURCE)
27270 THEN ENDOFLINE;
27280 NEXTCH
27290 END;
27300 CASE CH OF
27310 '%':
27320 BEGIN
27330 SKIPCOMMENT; INSYMBOL
27340 END;
27350 '(':
27360 BEGIN
27370 NEXTCH;
27380 IF CH = '*'
27390 THEN
27400 BEGIN
27410 SKIPCOMMENT; INSYMBOL
27420 END
27430 ELSE
27440 BEGIN
27450 SY := LPARENT; OP := NOOP
27460 END
27470 END;
27480 'A','B','C','D','E','F','G','H','I','J','K','L','M',
27490 'N','O','P','Q','R','S','T','U','V','W','X','Y',
27500 'Z':
27510 BEGIN
27520 K := 0 ; ID := ' ';
27530 REPEAT
27540 IF K < ALFALENGTH
27550 THEN
27560 BEGIN
27570 K := K + 1; ID[K] := CH
27580 END ;
27590 NEXTCH
27600 UNTIL NOT (CH IN LETTERSDIGITSORLEFTARROW);
27610 FOR I := FRW[K] TO FRW[K+1] - 1 DO
27620 IF RW[I] = ID
27630 THEN
27640 BEGIN
27650 SY := RSY[I];
27660 OP := ROP[I];
27670 IF (SY = INITPROCSY) AND NOT DP
27680 THEN ERROR(363);
27690 GOTO 222
27700 END;
27710 SY := IDENT; OP := NOOP;
27720 222:
27730 END;
27740 '0','1','2','3','4','5','6','7','8',
27750 '9':
27760 BEGIN
27770 SY := INTCONST; OP := NOOP;
27780 ID := ' ';
27790 I := 0;
27800 REPEAT
27810 I := I + 1;
27820
27830 (* THE DIGITS OF AN "INTCONST" ARE STORED AS "IDENT" TOO. THIS ALLOWES
27840 TO ENTER "LABELS" LIKE ALL OTHER IDENTIFIERS INTO THE BINARY-
27850 (IDENTIFIER-)TREE VIA "ENTERID" AND LOCATE THEM VIA
27860 "SEARCHID". SO "LABELS" ARE "KNOWN" AS CONSTANTS, TYPES OR
27870 VARIABLES IN THE BLOCK THEY HAVE BEEN DECLARED IN.
27880 IT IS ALSO POSSIBLE TO "EXIT" FROM A BLOCK, JUMPING TO A LABEL
27890 WHICH IS DECLARED ON A LOWER LEVEL *)
27900
27910 IF I <= ALFALENGTH
27920 THEN ID[I] := CH;
27930
27940 IF I <= MAXDIGITS
27950 THEN DIGIT[I] := ORD(CH) - ORD('0')
27960 ELSE ERROR(174) ;
27970 NEXTCH
27980 UNTIL NOT (CH IN DIGITS);
27990
28000 IVAL := 0;
28010
28020 IF CH = 'B'
28030 THEN
28040 BEGIN
28050 FOR K := 1 TO I DO
28060 IF IVAL <= MAX8
28070 THEN
28080 BEGIN
28090 IF DIGIT[K] IN [8,9]
28100 THEN ERROR(252);
28110 IVAL := 8*IVAL + DIGIT[K]
28120 END
28130 ELSE
28140 IF (IVAL = TEST8) AND (DIGIT[12] = 0)
28150 THEN IVAL := -MAXINT - 1
28160 ELSE
28170 BEGIN
28180 ERROR(204); IVAL := 0
28190 END;
28200 VAL.IVAL := IVAL;
28210 NEXTCH
28220 END
28230 ELSE
28240 BEGIN
28250 FOR K := 1 TO I DO
28260 IF IVAL <= MAX10
28270 THEN
28280 IF (IVAL = MAX10) AND (DIGIT[K] > 7)
28290 THEN
28300 BEGIN
28310 ERROR(204); IVAL := 0
28320 END
28330 ELSE IVAL := 10*IVAL + DIGIT[K]
28340 ELSE
28350 BEGIN
28360 ERROR(204); IVAL := 0
28370 END;
28380
28390 SCALE := 0;
28400
28410 IF CH = '.'
28420 THEN
28430 BEGIN
28440 NEXTCH;
28450 IF CH = '.'
28460 THEN CH := ':'
28470 ELSE
28480 BEGIN
28490 RVAL := IVAL; SY := REALCONST;
28500 IF NOT (CH IN DIGITS)
28510 THEN ERROR(205)
28520 ELSE
28530 REPEAT
28540 RVAL := 10.0*RVAL + (ORD(CH) - ORD('0'));
28550 SCALE := SCALE - 1; NEXTCH
28560 UNTIL NOT (CH IN DIGITS)
28570 END
28580 END;
28590
28600 IF CH = 'E'
28610 THEN
28620 BEGIN
28630 IF SCALE = 0
28640 THEN
28650 BEGIN
28660 RVAL := IVAL; SY := REALCONST
28670 END;
28680 NEXTCH;
28690 SIGN := CH='-';
28700 IF (CH='+') OR SIGN
28710 THEN NEXTCH;
28720 EXPONENT := 0;
28730 IF NOT (CH IN DIGITS)
28740 THEN ERROR(205)
28750 ELSE
28760 REPEAT
28770 EXPONENT := 10 * EXPONENT + ORD(CH) - ORD('0');
28780 NEXTCH
28790 UNTIL NOT (CH IN DIGITS);
28800
28810 IF SIGN
28820 THEN SCALE := SCALE - EXPONENT
28830 ELSE SCALE := SCALE + EXPONENT;
28840
28850 IF ABS(ROUND(SCALE/LOG_OF_2 + EXPO(RVAL))) >= MAXEXP2
28860 THEN
28870 BEGIN
28880 ERROR(206); SCALE := 0
28890 END
28900 END;
28910
28920 IF SCALE <> 0
28930 THEN
28940 BEGIN
28950 IF SCALE < 0
28960 THEN
28970 BEGIN
28980 SCALE := ABS(SCALE); FAC := 0.1
28990 END
29000 ELSE FAC := 10.0;
29010 R := 1.0;
29020
29030 LOOP
29040
29050 IF ODD(SCALE)
29060 THEN R := R * FAC;
29070 SCALE := SCALE DIV 2
29080 EXIT IF SCALE = 0;
29090 FAC := SQR(FAC)
29100 END;
29110
29120 RVAL := RVAL * R (* RVAL := RVAL * 10 ** SCALE *)
29130 END;
29140
29150 IF SY = INTCONST
29160 THEN VAL.IVAL := IVAL
29170 ELSE
29180 BEGIN
29190 NEW(LVP,REEL);
29200 LVP^.RVAL := RVAL; VAL.VALP := LVP
29210 END
29220 END
29230 END;
29240 '"':
29250 BEGIN
29260 SY := INTCONST; OP := NOOP; IVAL := 0;
29270 NEXTCH;
29280 WHILE (CH IN HEXADIGITS) AND (IVAL >= 0) DO
29290 BEGIN
29300 IF IVAL <= MAX16
29310 THEN
29320 IF CH IN DIGITS
29330 THEN IVAL := 16*IVAL + (ORD(CH) - ORD('0'))
29340 ELSE IVAL := 16*IVAL + (ORD(CH) - 67B)
29350 ELSE
29360 IF (IVAL = TEST16) AND (CH = '0')
29370 THEN IVAL := -MAXINT - 1
29380 ELSE
29390 BEGIN
29400 ERROR(174); IVAL := 0
29410 END;
29420 NEXTCH
29430 END;
29440 WHILE CH IN HEXADIGITS DO NEXTCH;
29450 VAL.IVAL := IVAL
29460 END;
29470 '''':
29480 BEGIN
29490 LGTH := 0; SY := STRINGCONST; OP := NOOP; STRINGTOOLONG := FALSE;
29500 REPEAT
29510 REPEAT
29520 NEXTCH;
29530 IF LGTH <= STRGLGTH
29540 THEN
29550 BEGIN
29560 LGTH := LGTH + 1;
29570 IF LGTH <= STRGLGTH
29580 THEN STRING[LGTH] := CH
29590 END
29600 ELSE STRINGTOOLONG := TRUE
29610 UNTIL EOLN(SOURCE) OR (CH = '''');
29620 IF STRINGTOOLONG
29630 THEN ERROR(301);
29640 IF CH <> ''''
29650 THEN ERROR(351)
29660 ELSE NEXTCH
29670 UNTIL CH <> '''';
29680 LGTH := LGTH - 1;
29690 IF LGTH = 1
29700 THEN VAL.IVAL := ORD(STRING[1])
29710 ELSE
29720 BEGIN
29730 NEW(LVP,STRG:LGTH);
29740 WITH LVP^ DO
29750 BEGIN
29760 SLGTH := LGTH;
29770 PACK(STRING,1,SVAL,1,LGTH)
29780 END;
29790 VAL.VALP := LVP
29800 END
29810 END;
29820 ':':
29830 BEGIN
29840 OP := NOOP; NEXTCH;
29850 IF CH = '='
29860 THEN
29870 BEGIN
29880 SY := BECOMES; NEXTCH
29890 END
29900 ELSE SY := COLON
29910 END;
29920 '.':
29930 BEGIN
29940 OP := NOOP; NEXTCH;
29950 IF CH = '.'
29960 THEN
29970 BEGIN
29980 SY := COLON; NEXTCH
29990 END
30000 ELSE SY := PERIOD
30010 END;
30020 '<','>':
30030 BEGIN
30040 SY := RELOP; OP := SOP[CH]; NEXTCH;
30050 IF (OP=LTOP) AND (CH='>')
30060 THEN
30070 BEGIN
30080 OP := NEOP; NEXTCH
30090 END
30100 ELSE
30110 IF CH = '='
30120 THEN
30130 BEGIN
30140 IF OP = LTOP
30150 THEN OP := LEOP
30160 ELSE OP := GEOP;
30170 NEXTCH
30180 END
30190 END;
30200 OTHERS:
30210 BEGIN
30220 SY := SSY[CH]; OP := SOP[CH];
30230 NEXTCH
30240 END
30250 END (*CASE*);
30260 FIRST_SYMBOL := FALSE
30270 END (*INSYMBOL*) ;
30280
30290 PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP);
30300
30310 (*TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S
30320 --> PROCEDURE PROCEDUREDECLARATION
30330 --> PROCEDURE SELECTOR*)
30340
30350 LABEL
30360 333;
30370
30380 BEGIN
30390 WHILE FCP <> NIL DO
30400 WITH FCP^ DO
30410 BEGIN
30420 IF NAME = ID
30430 THEN GOTO 333;
30440 IF NAME < ID
30450 THEN FCP := RLINK
30460 ELSE FCP := LLINK
30470 END;
30480 333:
30490 FCP1 := FCP
30500 END (*SEARCHSECTION*) ;
30510
30520 PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP);
30530
30540 LABEL
30550 444;
30560
30570 VAR
30580 LCP: CTP;
30590 BEGIN
30600 FOR DISX := TOP DOWNTO 0 DO
30610 BEGIN
30620 LCP := DISPLAY[DISX].FNAME;
30630 WHILE LCP <> NIL DO
30640 WITH LCP^ DO
30650 IF NAME = ID
30660 THEN
30670 IF KLASS IN FIDCLS
30680 THEN GOTO 444
30690 ELSE
30700 BEGIN
30710 IF SEARCH_ERROR
30720 THEN ERROR(401);
30730 LCP := RLINK
30740 END
30750 ELSE
30760 IF NAME < ID
30770 THEN LCP := RLINK
30780 ELSE LCP := LLINK
30790 END;
30800
30810 (*SEARCH NOT SUCCSESSFUL; SUPPRESS ERROR MESSAGE IN CASE
30820 OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION
30830 --> PROCEDURE SIMPLETYPE*)
30840
30850 IF SEARCH_ERROR
30860 THEN
30870 BEGIN
30880 IF ID[1] IN DIGITS
30890 THEN ERROR(215) (*UNDECLARED LABEL*)
30900 ELSE ERROR(253) (*UNDECLARED IDENTIFIER*);
30910
30920 (*TO AVOID RETURNING NIL, REFERENCE AN ENTRY
30930 FOR AN UNDECLARED ID OF APPROPRIATE CLASS
30940 --> PROCEDURE ENTERUNDECL*)
30950
30960 IF TYPES IN FIDCLS
30970 THEN LCP := UTYPPTR
30980 ELSE
30990 IF VARS IN FIDCLS
31000 THEN LCP := UVARPTR
31010 ELSE
31020 IF FIELD IN FIDCLS
31030 THEN LCP := UFLDPTR
31040 ELSE
31050 IF KONST IN FIDCLS
31060 THEN LCP := UCSTPTR
31070 ELSE
31080 IF PROC IN FIDCLS
31090 THEN LCP := UPRCPTR
31100 ELSE LCP := UFCTPTR
31110 END;
31120 444:
31130 FCP := LCP
31140 END (*SEARCHID*) ;
31150
31160
31170 PROCEDURE SKIPIFERR(FSYINSYS:SETOFSYS; FERRNR:INTEGER; FSKIPSYS: SETOFSYS);
31180 VAR
31190 I,OLDCHCNT,OLDLINECNT : INTEGER;
31200 BEGIN
31210 IF NOT (SY IN FSYINSYS)
31220 THEN
31230 BEGIN
31240 ERROR(FERRNR);
31250 OLDLINECNT := LINECNT; OLDCHCNT := CHCNT;
31260 WHILE NOT (SY IN FSKIPSYS + FSYINSYS) DO
31270 BEGIN
31280 (*SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND*)
31290 IF OLDLINECNT <> LINECNT
31300 THEN OLDCHCNT := 1;
31310 FOR I := OLDCHCNT TO CHCNT-1 DO
31320 IF I <= CHCNTMAX
31330 THEN ERRLINE [I] := '*';
31340 OLDCHCNT := CHCNT; OLDLINECNT := LINECNT; ERRORINLINE := TRUE;
31350 INSYMBOL
31360 END
31370 END;
31380 FOLLOWERROR := FALSE
31390 END;
31400
31410 PROCEDURE IFERRSKIP(FERRNR: INTEGER; FSYS: SETOFSYS);
31420 BEGIN
31430 SKIPIFERR(FSYS,FERRNR,FSYS)
31440 END;
31450
31460 PROCEDURE ERRANDSKIP(FERRNR: INTEGER; FSYS: SETOFSYS);
31470 BEGIN
31480 SKIPIFERR([ ],FERRNR,FSYS)
31490 END;
31500
31510 PROCEDURE BLOCK(FPROCP: CTP; FSYS,LEAVEBLOCKSYS: SETOFSYS);
31520
31530 TYPE
31540 MARKER = ^INTEGER;
31550
31560 VAR
31570 LSY: SYMBOL; CURRENT_JUMP: 0..JUMP_MAX;
31580 TESTPACKED: BOOLEAN;
31590 LCPAR: ADDRRANGE;
31600 HEAPMARK, GLOBMARK: MARKER;
31610 FORWARD_PROCEDURES : CTP;
31620
31630 PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU);
31640 VAR
31650 LSP, LSP1: STP;
31660 LCP: CTP;
31670 SIGN: (NONE,POS,NEG);
31680 BEGIN
31690 LSP := NIL; FVALU.IVAL := 0;
31700 SKIPIFERR(CONSTBEGSYS,207,FSYS);
31710 IF SY IN CONSTBEGSYS
31720 THEN
31730 BEGIN
31740 IF SY = STRINGCONST
31750 THEN
31760 BEGIN
31770 IF LGTH = 1
31780 THEN LSP := ASCIIPTR
31790 ELSE
31800 IF LGTH = ALFALENGTH
31810 THEN LSP := ALFAPTR
31820 ELSE
31830 BEGIN
31840 NEW(LSP,ARRAYS); NEW(LSP1,SUBRANGE);
31850 WITH LSP^ DO
31860 BEGIN
31870 SELFSTP := NIL; AELTYPE := ASCIIPTR; INXTYPE := LSP1;
31880 SIZE := (LGTH+4) DIV 5; ARRAYPF := TRUE;
31890 BITSIZE := BITMAX
31900 END;
31910 WITH LSP1^ DO
31920 BEGIN
31930 SELFSTP := NIL; SIZE := 1; BITSIZE := BITMAX;
31940 VMIN.IVAL := 1; VMAX.IVAL := LGTH; RANGETYPE := INTPTR
31950 END
31960 END;
31970 FVALU := VAL; INSYMBOL
31980 END
31990 ELSE
32000 BEGIN
32010 SIGN := NONE;
32020 IF (SY = ADDOP) AND (OP IN [PLUS,MINUS])
32030 THEN
32040 BEGIN
32050 IF OP = PLUS
32060 THEN SIGN := POS
32070 ELSE SIGN := NEG;
32080 INSYMBOL
32090 END;
32100 IF SY = IDENT
32110 THEN
32120 BEGIN
32130 SEARCHID([KONST],LCP);
32140 WITH LCP^ DO
32150 BEGIN
32160 LSP := IDTYPE; FVALU := VALUES
32170 END;
32180 IF SIGN <> NONE
32190 THEN
32200 IF LSP = INTPTR
32210 THEN
32220 BEGIN
32230 IF SIGN = NEG
32240 THEN FVALU.IVAL := -FVALU.IVAL
32250 END
32260 ELSE
32270 IF LSP = REALPTR
32280 THEN
32290 BEGIN
32300 IF SIGN = NEG
32310 THEN
32320 FVALU.VALP^.RVAL := -FVALU.VALP^.RVAL
32330 END
32340 ELSE ERROR(167);
32350 INSYMBOL
32360 END
32370 ELSE
32380 IF SY = INTCONST
32390 THEN
32400 BEGIN
32410 IF SIGN = NEG
32420 THEN VAL.IVAL := -VAL.IVAL;
32430 LSP := INTPTR; FVALU := VAL; INSYMBOL
32440 END
32450 ELSE
32460 IF SY = REALCONST
32470 THEN
32480 BEGIN
32490 IF SIGN = NEG
32500 THEN VAL.VALP^.RVAL := -VAL.VALP^.RVAL;
32510 LSP := REALPTR; FVALU := VAL; INSYMBOL
32520 END
32530 ELSE ERRANDSKIP(168,FSYS)
32540 END;
32550 IFERRSKIP(166,FSYS)
32560 END;
32570 FSP := LSP
32580 END (*CONSTANT*) ;
32590
32600 PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN, FMAX: INTEGER); FORWARD;
32610
32620 FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN;
32630 (*DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE*)
32640 VAR
32650 NXT1,NXT2: CTP; COMP: BOOLEAN; LMIN,LMAX,I: INTEGER;
32660 LTESTP1,LTESTP2: TESTP;
32670 BEGIN
32680 IF FSP1 = FSP2
32690 THEN COMPTYPES := TRUE
32700 ELSE
32710 IF (FSP1 <> NIL) AND (FSP2 <> NIL)
32720 THEN
32730 IF FSP1^.FORM = FSP2^.FORM
32740 THEN
32750 CASE FSP1^.FORM OF
32760 SCALAR:
32770 COMPTYPES := FALSE;
32780
32790 (* IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
32800 NOT RECOGNIZED TO BE COMPATIBLE*)
32810
32820 SUBRANGE:
32830 COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2^.RANGETYPE);
32840 POINTER:
32850 BEGIN
32860 COMP := FALSE; LTESTP1 := GLOBTESTP; LTESTP2 := GLOBTESTP;
32870 WHILE LTESTP1 <> NIL DO
32880 WITH LTESTP1^ DO
32890 BEGIN
32900 IF (ELT1 = FSP1^.ELTYPE) AND (ELT2 = FSP2^.ELTYPE)
32910 THEN COMP := TRUE;
32920 LTESTP1 := LASTTESTP
32930 END;
32940 IF NOT COMP
32950 THEN
32960 BEGIN
32970 NEW(LTESTP1);
32980 WITH LTESTP1^ DO
32990 BEGIN
33000 ELT1 := FSP1^.ELTYPE;
33010 ELT2 := FSP2^.ELTYPE;
33020 LASTTESTP := GLOBTESTP
33030 END;
33040 GLOBTESTP := LTESTP1; COMP := COMPTYPES(FSP1^.ELTYPE,FSP2^.ELTYPE)
33050 END;
33060 COMPTYPES := COMP; GLOBTESTP := LTESTP2
33070 END;
33080 POWER:
33090 COMPTYPES := COMPTYPES(FSP1^.ELSET,FSP2^.ELSET);
33100 ARRAYS:
33110 BEGIN
33120 GETBOUNDS(FSP1^.INXTYPE,LMIN,LMAX);
33130 I := LMAX-LMIN;
33140 GETBOUNDS(FSP2^.INXTYPE,LMIN,LMAX);
33150 COMPTYPES := COMPTYPES(FSP1^.AELTYPE,FSP2^.AELTYPE)
33160 AND (FSP1^.ARRAYPF = FSP2^.ARRAYPF) AND ( I = LMAX - LMIN ) ;
33170 END;
33180 RECORDS:
33190 BEGIN
33200 NXT1 := FSP1^.FSTFLD; NXT2 := FSP2^.FSTFLD; COMP := TRUE;
33210 WHILE (NXT1 <> NIL) AND (NXT2 <> NIL) DO
33220 BEGIN
33230 COMP := COMPTYPES(NXT1^.IDTYPE,NXT2^.IDTYPE) AND COMP;
33240 NXT1 := NXT1^.NEXT; NXT2 := NXT2^.NEXT
33250 END;
33260 COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL)
33270 AND (FSP1^.RECVAR = NIL) AND (FSP2^.RECVAR = NIL)
33280 END;
33290
33300 (*IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
33310 IF NO VARIANTS OCCUR*)
33320
33330 FILES:
33340 COMPTYPES := COMPTYPES(FSP1^.FILTYPE,FSP2^.FILTYPE)
33350 END (*CASE*)
33360 ELSE (*FSP1^.FORM <> FSP2^.FORM*)
33370 IF FSP1^.FORM = SUBRANGE
33380 THEN COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2)
33390 ELSE
33400 IF FSP2^.FORM = SUBRANGE
33410 THEN COMPTYPES := COMPTYPES(FSP1,FSP2^.RANGETYPE)
33420 ELSE COMPTYPES := FALSE
33430 ELSE COMPTYPES := TRUE
33440 END (*COMPTYPES*) ;
33450
33460 PROCEDURE GETBOUNDS;
33470
33480 (*GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE*)
33490
33500 BEGIN
33510 FMIN := 0; FMAX := 0;
33520 IF FSP <> NIL
33530 THEN
33540 IF FSP = INTPTR
33550 THEN
33560 BEGIN (* TYPE INTEGER = MININT..MAXINT *)
33570 FMIN := -MAXINT - 1;
33580 FMAX := MAXINT
33590 END
33600 ELSE
33610 IF (FSP^.FORM <= SUBRANGE) AND NOT COMPTYPES(REALPTR,FSP)
33620 THEN
33630 WITH FSP^ DO
33640 IF FORM = SUBRANGE
33650 THEN
33660 BEGIN
33670 FMIN := VMIN.IVAL;
33680 FMAX := VMAX.IVAL
33690 END
33700 ELSE
33710 IF FSP = ASCIIPTR
33720 THEN
33730 BEGIN (* TYPE ASCII = NUL..DEL *)
33740 FMIN := ORD(NUL);
33750 FMAX := ORD(DEL)
33760 END
33770 ELSE
33780 IF FCONST <> NIL
33790 THEN FMAX := FCONST^.VALUES.IVAL
33800 ELSE FMAX := 0
33810 END (*GETBOUNDS*) ;
33820
33830 FUNCTION STRING(FSP: STP) : BOOLEAN;
33840 BEGIN
33850 STRING := FALSE;
33860 IF FSP <> NIL
33870 THEN
33880 IF FSP^.FORM = ARRAYS
33890 THEN STRING := COMPTYPES(FSP^.AELTYPE,ASCIIPTR)
33900 END (*STRING*) ;
33910
33920 PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE;
33930 VAR FBITSIZE: BITRANGE);
33940 VAR
33950 LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP;
33960 LSIZE,DISPL: ADDRRANGE; I,LMIN,LMAX: INTEGER;
33970 PACKFLAG: BOOLEAN; LBITSIZE: BITRANGE;
33980 LBTP: BTP; BITCOUNT:INTEGER; BYTES: BITRANGE;
33990
34000 FUNCTION LOG2(FVAL: INTEGER): BITRANGE;
34010 VAR
34020 E: BITRANGE; H: INTEGER;
34030 BEGIN
34040 E := 0; H := 1;
34050 REPEAT
34060 E := E + 1; H := H * 2
34070 UNTIL FVAL <= H;
34080 LOG2 := E
34090 END (*LOG2*);
34100
34110 PROCEDURE SIMPLETYPE(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE;
34120 VAR FBITSIZE: BITRANGE);
34130 VAR
34140 LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE;
34150 LCNT: INTEGER; LVALU: VALU; LBITSIZE: BITRANGE;
34160 BEGIN
34170 FSIZE := 1;
34180 SKIPIFERR(SIMPTYPEBEGSYS,208,FSYS);
34190 IF SY IN SIMPTYPEBEGSYS
34200 THEN
34210 BEGIN (* DECLARED SCALARS *)
34220 IF SY = LPARENT
34230 THEN
34240 BEGIN
34250 TTOP := TOP;
34260 WHILE DISPLAY[TOP].OCCUR <> BLCK DO TOP := TOP - 1;
34270 NEW(LSP,SCALAR,DECLARED);
34280 LCP1 := NIL; LCNT := 0;
34290 REPEAT
34300 INSYMBOL;
34310 IF SY = IDENT
34320 THEN
34330 BEGIN
34340 NEW(LCP,KONST);
34350 WITH LCP^ DO
34360 BEGIN
34370 NAME := ID; IDTYPE := LSP; NEXT := LCP1;
34380 VALUES.IVAL := LCNT
34390 END;
34400 ENTERID(LCP);
34410 LCNT := LCNT + 1;
34420 LCP1 := LCP; INSYMBOL
34430 END
34440 ELSE ERROR(209);
34450 IFERRSKIP(166,FSYS + [COMMA,RPARENT])
34460 UNTIL SY <> COMMA;
34470 TOP := TTOP;
34480 WITH LSP^ DO
34490 BEGIN
34500 SELFSTP := NIL; FCONST := LCP1; SIZE := 1; BITSIZE := LOG2(LCNT);
34510
34520 (*ADDITIONAL INFORMATION NEEDED TO STORE IDENTS OF DECLARED
34530 SCALARS USED BY READ AND WRITE*)
34540
34550 VECTORCHAIN := 0; DIMENSION := LCNT - 1; REQUEST := FALSE;
34560 NEXTSCALAR := DECLSCALPTR; DECLSCALPTR := LSP;
34570 VECTORADDR := 0; TLEV := LEVEL
34580 END;
34590 IF SY = RPARENT
34600 THEN INSYMBOL
34610 ELSE ERROR(152)
34620 END (* SY = LPARENT *)
34630 ELSE
34640 BEGIN (* DEFINED CONSTANTS *)
34650 IF SY = IDENT
34660 THEN
34670 BEGIN
34680 SEARCHID([TYPES,KONST],LCP);
34690 INSYMBOL;
34700 IF LCP^.KLASS = KONST
34710 THEN
34720 BEGIN
34730 NEW(LSP,SUBRANGE);
34740 WITH LSP^, LCP^ DO
34750 BEGIN
34760 SELFSTP := NIL; RANGETYPE := IDTYPE;
34770 IF STRING(RANGETYPE)
34780 THEN
34790 BEGIN
34800 ERROR(303); RANGETYPE := NIL
34810 END;
34820 VMIN := VALUES; SIZE := 1
34830 END;
34840 IF SY = COLON
34850 THEN INSYMBOL
34860 ELSE ERROR(151);
34870 CONSTANT(FSYS,LSP1,LVALU);
34880 WITH LSP^ DO
34890 BEGIN
34900 VMAX := LVALU;
34910 IF (VMIN.IVAL < 0) OR (RANGETYPE = REALPTR)
34920 THEN BITSIZE := BITMAX
34930 ELSE
34940 IF VMAX.IVAL = MAXINT
34950 THEN BITSIZE := BITMAX
34960 ELSE BITSIZE := LOG2(VMAX.IVAL + 1);
34970 IF NOT COMPTYPES(RANGETYPE,LSP1)
34980 THEN ERROR(304)
34990 END
35000 END
35010 ELSE
35020 BEGIN
35030 LSP := LCP^.IDTYPE;
35040 IF LSP <> NIL
35050 THEN FSIZE := LSP^.SIZE
35060 END
35070 END (*SY = IDENT*)
35080 ELSE (* SELF-DEFINING CONSTANTS *)
35090 BEGIN
35100 NEW(LSP,SUBRANGE);
35110 CONSTANT(FSYS + [COLON],LSP1,LVALU);
35120 IF STRING(LSP1)
35130 THEN
35140 BEGIN
35150 ERROR(303); LSP1 := NIL
35160 END;
35170 WITH LSP^ DO
35180 BEGIN
35190 RANGETYPE := LSP1; VMIN := LVALU; SIZE := 1
35200 END;
35210 IF SY = COLON
35220 THEN INSYMBOL
35230 ELSE ERROR(151);
35240 CONSTANT(FSYS,LSP1,LVALU);
35250 WITH LSP^ DO
35260 BEGIN
35270 SELFSTP := NIL; VMAX := LVALU;
35280 IF (VMIN.IVAL < 0) OR (RANGETYPE = REALPTR)
35290 THEN BITSIZE := BITMAX
35300 ELSE
35310 IF VMAX.IVAL = MAXINT
35320 THEN BITSIZE := BITMAX
35330 ELSE BITSIZE := LOG2(VMAX.IVAL + 1);
35340 IF NOT COMPTYPES(RANGETYPE,LSP1)
35350 THEN ERROR(304)
35360 END
35370 END;
35380 IF LSP <> NIL
35390 THEN WITH LSP^ DO
35400 IF FORM = SUBRANGE
35410 THEN
35420 IF RANGETYPE <> NIL
35430 THEN
35440 IF RANGETYPE = REALPTR
35450 THEN
35460 BEGIN
35470 IF VMIN.VALP^.RVAL > VMAX.VALP^.RVAL
35480 THEN ERROR(451)
35490 END
35500 ELSE
35510 IF VMIN.IVAL > VMAX.IVAL
35520 THEN ERROR(451)
35530 END;
35540 FSP := LSP;
35550 IF LSP<>NIL
35560 THEN FBITSIZE := LSP^.BITSIZE
35570 ELSE FBITSIZE := 0;
35580 IFERRSKIP(166,FSYS)
35590 END
35600 ELSE
35610 BEGIN
35620 FSP := NIL; FBITSIZE := 0
35630 END
35640 END (*SIMPLETYPE*) ;
35650
35660 PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP; VAR FFIRSTFIELD: CTP);
35670
35680 LABEL
35690 555,5551;
35700
35710 VAR
35720 LCP,LCP1,NXT,NXT1: CTP; LSP,LSP1,LSP2,LSP3,LSP4,TAGSP: STP;
35730 MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU;
35740 LBITSIZE: BITRANGE;
35750 LBTP: BTP; MINBITCOUNT:INTEGER;
35760 LID : ALFA ;
35770
35780 PROCEDURE RECSECTION( VAR FCP: CTP; FSP: STP );
35790 BEGIN
35800 IF NOT PACKFLAG OR (LSIZE > 1) OR (LBITSIZE = 36)
35810 THEN
35820 BEGIN
35830 IF BITCOUNT > 0
35840 THEN
35850 BEGIN
35860 DISPL := DISPL + 1; BITCOUNT := 0
35870 END;
35880 WITH FCP^ DO
35890 BEGIN
35900 IDTYPE := FSP; FLDADDR := DISPL;
35910 PACKF := NOTPACK; FCP := NEXT;
35920 DISPL := DISPL + LSIZE
35930 END
35940 END
35950 ELSE (*PACKED RECORDS*)
35960
35970 BEGIN
35980 BITCOUNT := BITCOUNT + LBITSIZE;
35990 IF BITCOUNT>BITMAX
36000 THEN
36010 BEGIN
36020 DISPL := DISPL + 1;
36030 BITCOUNT := LBITSIZE
36040 END;
36050 IF (LBITSIZE = 18) AND (BITCOUNT IN [18,36])
36060 THEN
36070 BEGIN
36080 WITH FCP^ DO
36090 BEGIN
36100 IDTYPE := FSP;
36110 FLDADDR := DISPL;
36120 IF BITCOUNT = 18
36130 THEN PACKF := HWORDL
36140 ELSE PACKF := HWORDR;
36150 FCP := NEXT
36160 END
36170 END
36180 ELSE
36190 WITH FCP^, FLDBYTE DO
36200 BEGIN
36210 SBITS := LBITSIZE;
36220 PBITS := BITMAX - BITCOUNT;
36230 RELADDR := DISPL;
36240 DUMMYBIT := 0;
36250 IBIT := 0;
36260 IDTYPE := FSP;
36270 PACKF := PACKK;
36280 FCP := NEXT
36290 END
36300 END
36310 END (* RECSECTION *) ;
36320
36330 BEGIN
36340 NXT1 := NIL; LSP := NIL;
36350 SKIPIFERR([IDENT,CASESY],452,FSYS);
36360 WHILE SY = IDENT DO
36370 BEGIN
36380 NXT := NXT1;
36390 LOOP
36400 IF SY = IDENT
36410 THEN
36420 BEGIN
36430 NEW(LCP,FIELD);
36440 WITH LCP^ DO
36450 BEGIN
36460 NAME := ID; IDTYPE := NIL; NEXT := NXT
36470 END;
36480 NXT := LCP;
36490 ENTERID(LCP);
36500 INSYMBOL
36510 END
36520 ELSE ERROR(209);
36530 SKIPIFERR([COMMA,COLON],166,FSYS + [SEMICOLON,CASESY])
36540 EXIT IF SY <> COMMA ;
36550 INSYMBOL
36560 END;
36570 IF SY = COLON
36580 THEN INSYMBOL
36590 ELSE ERROR(151);
36600 TYP(FSYS + [CASESY,SEMICOLON],LSP,LSIZE,LBITSIZE);
36610 IF LSP <> NIL
36620 THEN
36630 IF LSP^.FORM = FILES
36640 THEN ERROR(254);
36650
36660 (* RESERVE SPACE FOR ONE RECORD SECTION *)
36670
36680 WHILE NXT <> NXT1 DO
36690 RECSECTION(NXT,LSP);
36700
36710 NXT1 := LCP;
36720 IF SY = SEMICOLON
36730 THEN
36740 BEGIN
36750 INSYMBOL;
36760 SKIPIFERR([IDENT,ENDSY,CASESY],452,FSYS)
36770 END
36780 ELSE SKIPIFERR([ENDSY,RPARENT],156,FSYS)
36790 END (*WHILE*);
36800 NXT := NIL;
36810 WHILE NXT1 <> NIL DO
36820 WITH NXT1^ DO
36830 BEGIN
36840 LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP
36850 END;
36860 FFIRSTFIELD := NXT;
36870 IF SY = CASESY
36880 THEN
36890 BEGIN
36900 LCP:=NIL; (*POSSIBILITY OF NO TAGFIELD IDENTIFIER*)
36910 INSYMBOL;
36920 IF SY = IDENT
36930 THEN
36940 BEGIN
36950 LID := ID ;
36960 INSYMBOL ;
36970 IF (SY<>COLON) AND (SY<>OFSY)
36980 THEN
36990 BEGIN
37000 ERROR(151) ;
37010 ERRANDSKIP(160,FSYS + [LPARENT])
37020 END
37030 ELSE
37040 BEGIN
37050 IF SY = COLON
37060 THEN
37070 BEGIN
37080 NEW(LSP,TAGFWITHID);
37090 NEW(LCP,FIELD) ;
37100 WITH LCP^ DO
37110 BEGIN
37120 NAME := LID ; IDTYPE := NIL ; NEXT := NIL
37130 END ;
37140 ENTERID(LCP) ;
37150 INSYMBOL ;
37160 IF SY <> IDENT
37170 THEN
37180 BEGIN
37190 ERRANDSKIP(209,FSYS + [LPARENT]) ; GOTO 555
37200 END
37210 ELSE
37220 BEGIN
37230 LID := ID ;
37240 INSYMBOL ;
37250 IF SY <> OFSY
37260 THEN
37270 BEGIN
37280 ERRANDSKIP(160,FSYS + [LPARENT]) ; GOTO 555
37290 END
37300 END
37310 END
37320 ELSE NEW(LSP,TAGFWITHOUTID) ;
37330 WITH LSP^ DO
37340 BEGIN
37350 SIZE:= 0 ; SELFSTP := NIL ;
37360 FSTVAR := NIL;
37370 IF FORM=TAGFWITHID
37380 THEN TAGFIELDP:=NIL
37390 ELSE TAGFIELDTYPE := NIL
37400 END;
37410 FRECVAR := LSP;
37420 ID := LID ;
37430 SEARCHID([TYPES],LCP1) ;
37440 TAGSP := LCP1^.IDTYPE;
37450 IF TAGSP <> NIL
37460 THEN
37470 IF (TAGSP^.FORM <= SUBRANGE) OR STRING(TAGSP)
37480 THEN
37490 BEGIN
37500 IF COMPTYPES(REALPTR,TAGSP)
37510 THEN ERROR(210)
37520 ELSE
37530 IF STRING(TAGSP)
37540 THEN ERROR(169);
37550 WITH LSP^ DO
37560 BEGIN
37570 BITSIZE := TAGSP^.BITSIZE;
37580 IF FORM = TAGFWITHID
37590 THEN TAGFIELDP := LCP
37600 ELSE TAGFIELDTYPE := TAGSP
37610 END;
37620 IF LCP <> NIL
37630 THEN
37640 BEGIN
37650 LBITSIZE :=TAGSP^.BITSIZE;
37660 LSIZE := TAGSP^.SIZE;
37670 RECSECTION(LCP,TAGSP); (*RESERVES SPACE FOR THE TAGFIELD *)
37680 IF BITCOUNT > 0
37690 THEN LSP^.SIZE := DISPL + 1
37700 ELSE LSP^.SIZE := DISPL
37710 END
37720 END
37730 ELSE ERROR(402);
37740 INSYMBOL
37750 END
37760 END
37770 ELSE ERRANDSKIP(209,FSYS + [LPARENT]) ;
37780 555:
37790 LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL; MINBITCOUNT:=BITCOUNT;
37800 LOOP
37810 LSP2 := NIL;
37820 LOOP
37830 CONSTANT(FSYS + [COMMA,COLON,LPARENT],LSP3,LVALU);
37840 IF NOT COMPTYPES(TAGSP,LSP3)
37850 THEN ERROR(305);
37860 NEW(LSP3,VARIANT);
37870 WITH LSP3^ DO
37880 BEGIN
37890 NXTVAR := LSP1; SUBVAR := LSP2; VARVAL := LVALU;
37900 BITSIZE := LSP^.BITSIZE; SELFSTP := NIL
37910 END;
37920 LSP1 := LSP3; LSP2 := LSP3
37930 EXIT IF SY <> COMMA;
37940 INSYMBOL
37950 END;
37960 IF SY = COLON
37970 THEN INSYMBOL
37980 ELSE ERROR(151);
37990 IF SY = LPARENT
38000 THEN INSYMBOL
38010 ELSE ERROR(153);
38020 FIELDLIST(FSYS + [RPARENT,SEMICOLON],LSP2,LCP);
38030 IF BITCOUNT > 0
38040 THEN
38050 BEGIN
38060 DISPL := DISPL + 1 ; BITCOUNT := 0
38070 END ;
38080 IF DISPL > MAXSIZE
38090 THEN MAXSIZE := DISPL;
38100 WHILE LSP3 <> NIL DO
38110 BEGIN
38120 LSP4 := LSP3^.SUBVAR; LSP3^.SUBVAR := LSP2; LSP3^.FIRSTFIELD := LCP;
38130 LSP3^.SIZE := DISPL ;
38140 LSP3 := LSP4
38150 END;
38160 IF SY = RPARENT
38170 THEN
38180 BEGIN
38190 INSYMBOL;
38200 IFERRSKIP(166,FSYS + [SEMICOLON])
38210 END
38220 ELSE ERROR(152)
38230 EXIT IF SY <> SEMICOLON;
38240 INSYMBOL;
38250 IF SY = ENDSY
38260 THEN GOTO 5551;
38270 DISPL := MINSIZE;
38280 BITCOUNT:=MINBITCOUNT
38290 END;
38300 5551:
38310 DISPL := MAXSIZE;
38320 LSP^.FSTVAR := LSP1
38330 END (*IF SY = CASESY*)
38340 ELSE
38350 IF LSP <> NIL
38360 THEN
38370 IF LSP^.FORM = ARRAYS
38380 THEN FRECVAR := LSP
38390 ELSE FRECVAR := NIL
38400 END (*FIELDLIST*) ;
38410
38420 BEGIN
38430 (*TYP*)
38440 SKIPIFERR(TYPEBEGSYS,170,FSYS);
38450 IF SY IN TYPEBEGSYS
38460 THEN
38470 BEGIN
38480 IF SY IN SIMPTYPEBEGSYS
38490 THEN SIMPLETYPE(FSYS,FSP,FSIZE,FBITSIZE)
38500 ELSE
38510 IF SY = ARROW
38520 THEN
38530 BEGIN
38540 NEW(LSP,POINTER); FSP := LSP;
38550 LBITSIZE := 18;
38560 WITH LSP^ DO
38570 BEGIN
38580 SELFSTP := NIL; ELTYPE := NIL; SIZE := 1; BITSIZE := LBITSIZE
38590 END;
38600 INSYMBOL;
38610 IF SY = IDENT
38620 THEN
38630 BEGIN
38640 SEARCH_ERROR := FALSE;
38650 SEARCHID([TYPES],LCP);
38660 SEARCH_ERROR := TRUE;
38670 IF LCP = NIL
38680 THEN (*FORWARD REFERENCED TYPE ID*)
38690 BEGIN
38700 NEW(LCP,TYPES);
38710 WITH LCP^ DO
38720 BEGIN
38730 NAME := ID; IDTYPE := LSP;
38740 NEXT := FORWARD_POINTER_TYPE
38750 END;
38760 FORWARD_POINTER_TYPE := LCP
38770 END
38780 ELSE
38790 BEGIN
38800 IF LCP^.IDTYPE <> NIL
38810 THEN
38820 IF LCP^.IDTYPE^.FORM = FILES
38830 THEN ERROR(254)
38840 ELSE LSP^.ELTYPE := LCP^.IDTYPE
38850 END;
38860 INSYMBOL;
38870 FBITSIZE:=18
38880 END
38890 ELSE ERROR(209)
38900 END
38910 ELSE
38920 BEGIN
38930 IF SY = SEGMENTSY
38940 THEN
38950 BEGIN
38960 INSYMBOL;
38970 SKIPIFERR(TYPEDELS + [PACKEDSY],170,FSYS)
38980 END;
38990 IF SY = PACKEDSY
39000 THEN
39010 BEGIN
39020 INSYMBOL;
39030 SKIPIFERR(TYPEDELS,170,FSYS);
39040 PACKFLAG := TRUE
39050 END
39060 ELSE PACKFLAG := FALSE;
39070 CASE SY OF
39080 ARRAYSY:
39090 BEGIN
39100 INSYMBOL;
39110 IF SY = LBRACK
39120 THEN INSYMBOL
39130 ELSE ERROR(154);
39140 LSP1 := NIL;
39150 LOOP
39160 NEW(LSP,ARRAYS);
39170 WITH LSP^ DO
39180 BEGIN
39190 AELTYPE := LSP1; INXTYPE := NIL; SELFSTP := NIL;
39200 ARRAYPF := PACKFLAG; SIZE := 1
39210 END;
39220 LSP1 := LSP;
39230 SIMPLETYPE(FSYS + [COMMA,RBRACK,OFSY],LSP2,LSIZE,LBITSIZE);
39240
39250 IF LSP2 <> NIL
39260 THEN
39270 IF LSP2^.FORM <= SUBRANGE
39280 THEN
39290 BEGIN
39300 IF LSP2 = REALPTR
39310 THEN
39320 BEGIN
39330 ERROR(210); LSP2 := NIL
39340 END
39350 ELSE
39360 IF LSP2 = INTPTR
39370 THEN
39380 BEGIN
39390 ERROR(306); LSP2 := NIL
39400 END;
39410 LSP^.INXTYPE := LSP2
39420 END
39430 ELSE
39440 BEGIN
39450 ERROR(403); LSP2 := NIL
39460 END
39470 EXIT IF SY <> COMMA;
39480 INSYMBOL
39490 END;
39500 IF SY = RBRACK
39510 THEN INSYMBOL
39520 ELSE ERROR(155);
39530 IF SY = OFSY
39540 THEN INSYMBOL
39550 ELSE ERROR(160);
39560 TYP(FSYS,LSP,LSIZE,LBITSIZE);
39570 IF LSP <> NIL
39580 THEN
39590 IF LSP^.FORM = FILES
39600 THEN ERROR(169) ;
39610 REPEAT
39620 WITH LSP1^ DO
39630 BEGIN
39640 LSP2 := AELTYPE; AELTYPE := LSP;
39650 IF INXTYPE <> NIL
39660 THEN
39670 BEGIN
39680 GETBOUNDS(INXTYPE,LMIN,LMAX);
39690 I := LMAX - LMIN + 1;
39700 IF ARRAYPF AND (LBITSIZE<=18)
39710 THEN
39720 BEGIN
39730 BYTES := BITMAX DIV LBITSIZE;
39740 WITH ARRAYBPS[LBITSIZE] DO
39750 IF STATE = USED
39760 THEN ARRAYBPADDR := ADDRESS
39770 ELSE
39780 BEGIN
39790 NEW(LBTP);
39800 WITH LBTP^ DO
39810 BEGIN
39820 LAST := LASTBTP; BITSIZE := LBITSIZE;
39830 BYTEMAX := BYTES + 1 (*ONE MORE BYTEPOINTER USED FOR INCREMENT-OPERATIONS*) ;
39840 ARRAYSP := LSP1
39850 END;
39860 LASTBTP := LBTP;
39870 IF STATE = UNUSED
39880 THEN
39890 BEGIN
39900 STATE := REQUESTED;
39910 WITH ABYTE DO
39920 BEGIN
39930 SBITS := LBITSIZE;
39940 PBITS := BITMAX; DUMMYBIT := 0;
39950 IBIT := 0; IREG := REG1; RELADDR := 0
39960 END
39970 END
39980 END;
39990 LSIZE := (I+BYTES-1) DIV (BYTES)
40000 END
00010 ELSE
00020 BEGIN
00030 LSIZE := LSIZE * I;
00040 ARRAYPF := FALSE
00050 END;
00060 LBITSIZE := BITMAX;
00070 BITSIZE := LBITSIZE;
00080 SIZE := LSIZE
00090 END
00100 END;
00110 LSP := LSP1; LSP1 := LSP2
00120 UNTIL LSP1 = NIL
00130 END;
00140 RECORDSY:
00150 BEGIN
00160 INSYMBOL;
00170 OLDTOP := TOP;
00180 IF TOP < DISPLIMIT
00190 THEN
00200 BEGIN
00210 TOP := TOP + 1; DISPLAY[TOP].FNAME := NIL ;
00220 DISPLAY[TOP].OCCUR := CREC ;
00230 END
00240 ELSE ERROR(404);
00250 DISPL := 0; BITCOUNT := 0;
00260 FIELDLIST(FSYS-[SEMICOLON] + [ENDSY],LSP1,LCP);
00270 LBITSIZE := BITMAX;
00280 NEW(LSP,RECORDS);
00290 WITH LSP^ DO
00300 BEGIN
00310 SELFSTP := NIL;
00320 FSTFLD := (*LCP;*) DISPLAY[TOP].FNAME;
00330 RECVAR := LSP1;
00340 IF BITCOUNT > 0
00350 THEN SIZE := DISPL + 1
00360 ELSE SIZE := DISPL;
00370 BITSIZE := LBITSIZE; RECORDPF := PACKFLAG
00380 END;
00390 TOP := OLDTOP;
00400 IF SY = ENDSY
00410 THEN INSYMBOL
00420 ELSE ERROR(163)
00430 END;
00440 SETSY:
00450 BEGIN
00460 INSYMBOL;
00470 IF SY = OFSY
00480 THEN INSYMBOL
00490 ELSE ERROR(160);
00500 SIMPLETYPE(FSYS,LSP1,LSIZE,LBITSIZE);
00510 IF LSP1 <> NIL
00520 THEN
00530 WITH LSP1^ DO
00540 CASE FORM OF
00550 SCALAR:
00560 IF SCALKIND = STANDARD
00570 THEN ERROR(268)
00580 ELSE
00590 IF FCONST^.VALUES.IVAL > BASEMAX
00600 THEN ERROR(268);
00610 SUBRANGE:
00620 IF COMPTYPES(RANGETYPE,ASCIIPTR)
00630 THEN
00640 BEGIN
00650 IF ((VMAX.IVAL-OFFSET) > BASEMAX) OR ((VMIN.IVAL-OFFSET) < 0)
00660 THEN ERROR(268)
00670 END
00680 ELSE
00690 BEGIN
00700 IF (RANGETYPE = REALPTR) OR
00710 ((VMAX.IVAL > BASEMAX) OR (VMIN.IVAL < 0))
00720 THEN ERROR(268)
00730 END;
00740 OTHERS:
00750 BEGIN
00760 ERROR(461); LSP1 := NIL
00770 END
00780 END;
00790 LBITSIZE := BITMAX;
00800 NEW(LSP,POWER);
00810 WITH LSP^ DO
00820 BEGIN
00830 SELFSTP := NIL; ELSET := LSP1; SIZE:=2; BITSIZE := LBITSIZE
00840 END
00850 END;
00860 FILESY:
00870 BEGIN
00880 INSYMBOL;
00890 IF SY = OFSY
00900 THEN INSYMBOL
00910 ELSE ERROR(160);
00920 TYP(FSYS,LSP1,LSIZE,LBITSIZE);
00930 NEW(LSP,FILES);
00940 LBITSIZE := BITMAX;
00950 WITH LSP^ DO
00960 BEGIN
00970 SELFSTP := NIL;
00980 FILTYPE := LSP1; SIZE := LSIZE+SIZEOFFILEBLOCK;
00990 FILEPF := PACKFLAG; BITSIZE := LBITSIZE ;
01000
01010 (* REFER TO PROCEDURE "CODE_FOR_FILEBLOCKS"
01020 IN "WRITE_MACHINE_CODE" *)
01030
01040 FILE_MODE := BINARY_MODE;
01050 FILE_FORM := DATA_FILE;
01060 IF COMPTYPES(FILTYPE,ASCIIPTR) AND FILEPF
01070 THEN
01080 BEGIN
01090 FILE_MODE := ASCII_MODE;
01100 IF FILTYPE <> NIL
01110 THEN
01120 WITH FILTYPE^ DO
01130 IF (FORM = SUBRANGE) AND
01140 ((VMIN.IVAL >= ORD(' ')) AND
01150 (VMAX.IVAL <= ORD('_')))
01160 THEN LSP^.FILE_FORM := TEXT_FILE
01170 END;
01180 IF FILEPF AND (FILE_MODE = BINARY_MODE)
01190 THEN FILEPF := FALSE
01200 END;
01210
01220 IF LSP1 <> NIL
01230 THEN
01240 IF LSP1^.FORM = FILES
01250 THEN
01260 BEGIN
01270 ERROR(254); LSP^.FILTYPE := NIL
01280 END
01290 END
01300 END (*CASE*);
01310 FSP := LSP; FBITSIZE := LBITSIZE
01320 END;
01330 IFERRSKIP(166,FSYS)
01340 END
01350 ELSE FSP := NIL;
01360 IF FSP = NIL
01370 THEN
01380 BEGIN
01390 FSIZE := 1;FBITSIZE := 0
01400 END
01410 ELSE FSIZE := FSP^.SIZE
01420 END (*TYP*) ;
01430
01440 PROCEDURE LABELDECLARATION;
01450 VAR
01460 LCP: CTP;
01470 BEGIN
01480 IF JUMPER < JUMP_MAX
01490 THEN JUMPER := JUMPER + 1
01500 ELSE ERROR(319);
01510 CURRENT_JUMP := JUMPER;
01520 JUMP_TABLE[JUMPER] := 0;
01530 LOOP
01540 IF SY = INTCONST
01550 THEN
01560 BEGIN
01570 NEW(LCP,LABELS);
01580 WITH LCP^ DO
01590 BEGIN
01600 SCOPE := LEVEL; NAME := ID; IDTYPE := NIL; NEXT := LAST_LABEL;
01610 GOTO_CHAIN := 0; LABEL_ADDRESS := 0; LAST_LABEL := LCP;
01620 JUMP_INDEX := JUMPER; EXIT_JUMP := FALSE;
01630 IF VAL.IVAL > LABMAX
01640 THEN ERROR(265)
01650 END;
01660 ENTERID(LCP);
01670 INSYMBOL
01680 END
01690 ELSE ERROR(255);
01700 IFERRSKIP(166,FSYS + [COMMA,SEMICOLON])
01710 EXIT IF SY <> COMMA;
01720 INSYMBOL
01730 END;
01740 IF SY = SEMICOLON
01750 THEN INSYMBOL
01760 ELSE ERROR(156)
01770 END (*LABELDECLARATION*) ;
01780
01790 PROCEDURE CONSTANTDECLARATION;
01800 VAR
01810 LCP: CTP; LSP: STP; LVALU: VALU;
01820 BEGIN
01830 SKIPIFERR([IDENT],209,FSYS);
01840 WHILE SY = IDENT DO
01850 BEGIN
01860 NEW(LCP,KONST);
01870 WITH LCP^ DO
01880 BEGIN
01890 NAME := ID; IDTYPE := NIL; NEXT := NIL
01900 END;
01910 INSYMBOL;
01920 IF (SY = RELOP) AND (OP = EQOP)
01930 THEN INSYMBOL
01940 ELSE ERROR(157);
01950 CONSTANT(FSYS + [SEMICOLON],LSP,LVALU);
01960 ENTERID(LCP);
01970 LCP^.IDTYPE := LSP; LCP^.VALUES := LVALU;
01980 IF SY = SEMICOLON
01990 THEN
02000 BEGIN
02010 INSYMBOL;
02020 IFERRSKIP(166,FSYS + [IDENT])
02030 END
02040 ELSE ERROR(156)
02050 END
02060 END (*CONSTANTDECLARATION*) ;
02070
02080 PROCEDURE TYPEDECLARATION;
02090 VAR
02100 LCP,LCP1,LCP2: CTP; LSP: STP; LSIZE: ADDRRANGE;
02110 LBITSIZE: BITRANGE;
02120 BEGIN
02130 SKIPIFERR([IDENT],209,FSYS);
02140 WHILE SY = IDENT DO
02150 BEGIN
02160 NEW(LCP,TYPES);
02170 WITH LCP^ DO
02180 BEGIN
02190 NAME := ID; NEXT := NIL
02200 END;
02210 INSYMBOL;
02220 IF (SY = RELOP) AND (OP = EQOP)
02230 THEN INSYMBOL
02240 ELSE ERROR(157);
02250 TYP(FSYS + [SEMICOLON],LSP,LSIZE,LBITSIZE);
02260 ENTERID(LCP);
02270 WITH LCP^ DO
02280 BEGIN
02290 IDTYPE := LSP;
02300
02310 (* LOOK FOR UNSATISFIED POINTER FORWARD REFERENCES;
02320 THERE MAY BE MORE THAN ONE FOR ONE TYPE-DECLARATION *)
02330
02340 LCP1 := FORWARD_POINTER_TYPE;
02350 WHILE LCP1 <> NIL DO
02360 BEGIN
02370 IF LCP1^.NAME = NAME
02380 THEN
02390 BEGIN
02400 IF IDTYPE^.FORM = FILES
02410 THEN
02420 BEGIN
02430 ERROR(254);
02440 LCP1^.IDTYPE^.ELTYPE := NIL
02450 END
02460 ELSE LCP1^.IDTYPE^.ELTYPE := IDTYPE;
02470 IF LCP1 <> FORWARD_POINTER_TYPE
02480 THEN LCP2^.NEXT := LCP1^.NEXT
02490 ELSE FORWARD_POINTER_TYPE := LCP1^.NEXT
02500 END
02510 ELSE LCP2 := LCP1;
02520 LCP1 := LCP1^.NEXT
02530 END
02540 END;
02550 IF SY = SEMICOLON
02560 THEN
02570 BEGIN
02580 INSYMBOL;
02590 IFERRSKIP(166,FSYS + [IDENT])
02600 END
02610 ELSE ERROR(156)
02620 END;
02630 WHILE FORWARD_POINTER_TYPE <> NIL DO
02640 BEGIN
02650 ERROR_WITH_TEXT(405,FORWARD_POINTER_TYPE^.NAME);
02660 FORWARD_POINTER_TYPE := FORWARD_POINTER_TYPE^.NEXT
02670 END
02680 END (*TYPEDECLARATION*) ;
02690
02700 PROCEDURE VARIABLEDECLARATION;
02710 VAR
02720 LCP,NXT: CTP; LSP: STP; LSIZE: ADDRRANGE;
02730 LBITSIZE: BITRANGE; LPARMPTR: PTP; FOUND: BOOLEAN;
02740 LFILEPTR: FTP;
02750 BEGIN
02760 NXT := NIL;
02770 REPEAT
02780 LOOP
02790 IF SY = IDENT
02800 THEN
02810 BEGIN
02820 NEW(LCP,VARS);
02830 WITH LCP^ DO
02840 BEGIN
02850 NAME := ID; NEXT := NXT;
02860 IDTYPE := NIL; VKIND := ACTUAL; VLEV := LEVEL
02870 END;
02880 ENTERID(LCP);
02890 NXT := LCP;
02900 INSYMBOL
02910 END
02920 ELSE ERROR(209);
02930 SKIPIFERR(FSYS + [COMMA,COLON] + TYPEDELS,166,[SEMICOLON])
02940 EXIT IF SY <> COMMA;
02950 INSYMBOL
02960 END;
02970 IF SY = COLON
02980 THEN INSYMBOL
02990 ELSE ERROR(151);
03000 TYP(FSYS + [SEMICOLON] + TYPEDELS,LSP,LSIZE,LBITSIZE);
03010 IF NOT TESTPACKED AND (LSP <> NIL)
03020 THEN
03030 BEGIN
03040 IF LSP^.FORM = ARRAYS
03050 THEN TESTPACKED := LSP^.ARRAYPF;
03060 IF LSP^.FORM = RECORDS
03070 THEN TESTPACKED := LSP^.RECORDPF
03080 END;
03090 WHILE NXT <> NIL DO
03100 WITH NXT^ DO
03110 BEGIN
03120 IDTYPE := LSP; VADDR := LC;
03130 LC := LC + LSIZE ;
03140 IF LSP <> NIL
03150 THEN
03160 IF LSP^.FORM = FILES
03170 THEN
03180 IF LEVEL > 1
03190 THEN ERROR(454)
03200 ELSE
03210 BEGIN
03220 IF START_CHANNEL = 0
03230 THEN CHANNEL := FILEPTR^.FILEIDENT^.CHANNEL
03240 ELSE
03250 BEGIN
03260 CHANNEL := START_CHANNEL;
03270 START_CHANNEL := 0
03280 END;
03290 IF CHANNEL < MAX_CHANNEL
03300 THEN CHANNEL := CHANNEL + 1
03310 ELSE ERROR(354);
03320 NEW(LFILEPTR);
03330 WITH LFILEPTR^ DO
03340 BEGIN
03350 NEXTFTP := FILEPTR ;
03360 FILEIDENT := NXT
03370 END ;
03380 FILEPTR := LFILEPTR;
03390 LPARMPTR := PARMPTR; FOUND := FALSE;
03400 WHILE LPARMPTR <> NIL DO
03410 WITH LPARMPTR^ DO
03420 BEGIN
03430 IF FILEID = NAME
03440 THEN
03450 IF FOUND
03460 THEN ERROR(466)
03470 ELSE
03480 BEGIN
03490 FILEIDPTR := NXT; FOUND := TRUE
03500 END;
03510 LPARMPTR := NEXTPTP
03520 END
03530 END (*ELSE*) ;
03540 NXT := NEXT
03550 END;
03560 IF SY = SEMICOLON
03570 THEN
03580 BEGIN
03590 INSYMBOL;
03600 IFERRSKIP(166,FSYS + [IDENT])
03610 END
03620 ELSE ERROR(156)
03630 UNTIL NOT (SY IN TYPEDELS + [IDENT]);
03640 WHILE FORWARD_POINTER_TYPE <> NIL DO
03650 BEGIN
03660 ERROR_WITH_TEXT(405,FORWARD_POINTER_TYPE^.NAME);
03670 FORWARD_POINTER_TYPE := FORWARD_POINTER_TYPE^.NEXT
03680 END
03690 END (*VARIABLEDECLARATION*) ;
03700
03710 PROCEDURE PROCEDUREDECLARATION(PROCFLAG: BOOLEAN);
03720 VAR
03730 OLDLEV: 0..MAXLEVEL; LCP,LCP1: CTP; LSP: STP;
03740 FORW: BOOLEAN; OLDTOP: DISPRANGE; LNXT: CTP;
03750 LLC,LCM: ADDRRANGE;
03760
03770 PROCEDURE PARAMETERLIST(FSYS:SETOFSYS; VAR FIP : CTP);
03780
03790 VAR
03800 LIP,LIP1,LIP2,LIP3,LIP4 : CTP; LSP : STP;
03810 LKIND : IDKIND; LPARS:ADDRRANGE; FUNCDECL : BOOLEAN;
03820
03830 PROCEDURE FFPARLIST ( FSYS : SETOFSYS; VAR FIP : CTP; VAR FPARLC : ADDRRANGE);
03840
03850 VAR
03860 LIP,LIP1,LIP2,LIP3 : CTP; LSP : STP;
03870 LKIND : IDKIND; LPARS : ADDRRANGE; FUNCDECL : BOOLEAN;
03880
03890 BEGIN (*FFPARLIST*)
03900 FIP:=NIL;
03910 SKIPIFERR(FSYS+[LPARENT],256,[]);
03920 IF SY=LPARENT
03930 THEN
03940 BEGIN
03950 INSYMBOL;
03960 SKIPIFERR([IDENT,VARSY,PROCEDURESY,FUNCTIONSY],256,FSYS+[RPARENT]);
03970 IF SY IN [IDENT ,VARSY,PROCEDURESY,FUNCTIONSY]
03980 THEN
03990 LOOP
04000 IF SY IN [PROCEDURESY, FUNCTIONSY]
04010 THEN
04020 BEGIN
04030 FUNCDECL:= SY=FUNCTIONSY;
04040 INSYMBOL;
04050 IF FUNCDECL
04060 THEN NEW(LIP,FUNC,DECLARED,FORMAL)
04070 ELSE
04080 NEW(LIP,PROC,DECLARED,FORMAL);
04090 WITH LIP^ DO
04100 BEGIN
04110 IDTYPE:=NIL; NEXT:=NIL; PFLEV:=LEVEL;
04120 PFADDR:=FPARLC; FPARLC:=FPARLC+1;
04130 LPARS:=1+ORD(FUNCDECL);
04140 IF FUNCDECL
04150 THEN FFPARLIST(FSYS+[RPARENT,COLON,SEMICOLON],LIP3,LPARS)
04160 ELSE
04170 FFPARLIST(FSYS+[RPARENT,SEMICOLON],LIP3,LPARS);
04180 FPARAM:=LIP3; PARLISTSIZE:=LPARS;
04190 END;
04200 IF FUNCDECL
04210 THEN
04220 IF SY=COLON
04230 THEN
04240 BEGIN
04250 INSYMBOL;
04260 IF SY<>IDENT
04270 THEN ERROR(209)
04280 ELSE
04290 BEGIN
04300 SEARCHID([TYPES],LIP2);
04310 LSP:=LIP2^.IDTYPE;
04320 IF LSP<> NIL
04330 THEN
04340 IF NOT(LSP^.FORM IN [SCALAR,SUBRANGE,POINTER])
04350 THEN
04360 BEGIN
04370 ERROR(551);
04380 LSP:=NIL
04390 END;
04400 LIP^.IDTYPE:=LSP
04410 END
04420 END
04430 ELSE ERROR(151)
04440 END (*SY IN [FUNCTIONSY,PROCEDURESY]*)
04450 ELSE
04460 BEGIN
04470 IF SY=VARSY
04480 THEN
04490 BEGIN
04500 INSYMBOL;
04510 LKIND:=FORMAL;
04520 IF SY=COLON
04530 THEN INSYMBOL
04540 ELSE ERROR(151)
04550 END
04560 ELSE LKIND:=ACTUAL;
04570 IF SY=IDENT
04580 THEN
04590 BEGIN
04600 SEARCHID([TYPES],LIP2);
04610 INSYMBOL;
04620 LSP:=LIP2^.IDTYPE;
04630 IF LSP<>NIL
04640 THEN
04650 IF LKIND=ACTUAL
04660 THEN
04670 IF LSP^.FORM=FILES
04680 THEN
04690 BEGIN
04700 ERROR(355); LSP:=NIL
04710 END;
04720 NEW(LIP,VARS);
04730 WITH LIP^ DO
04740 BEGIN
04750 IDTYPE:=LSP; NEXT:=NIL; VKIND:=LKIND; VLEV:=LEVEL;
04760 VADDR:=FPARLC;
04770 IF LKIND=FORMAL
04780 THEN FPARLC:=FPARLC+1
04790 ELSE
04800 IF LSP<>NIL
04810 THEN FPARLC:=FPARLC+LSP^.SIZE;
04820 END
04830 END
04840 ELSE
04850 BEGIN
04860 ERROR(209); LIP:=NIL
04870 END
04880 END;
04890 IF LIP<>NIL
04900 THEN
04910 BEGIN
04920 IF FIP=NIL
04930 THEN FIP:=LIP
04940 ELSE LIP1^.NEXT:=LIP;
04950 LIP1:=LIP
04960 END;
04970 SKIPIFERR([SEMICOLON,IDENT,VARSY,PROCEDURESY,FUNCTIONSY,RPARENT],256,FSYS);
04980 EXIT IF NOT(SY IN [SEMICOLON,IDENT,VARSY,PROCEDURESY,FUNCTIONSY]);
04990 IF SY=SEMICOLON
05000 THEN INSYMBOL
05010 ELSE ERROR(156)
05020 END (*LOOP*);
05030 IF SY=RPARENT
05040 THEN INSYMBOL
05050 ELSE ERROR(152);
05060 SKIPIFERR(FSYS,166,[])
05070 END
05080 END (*FFPARLIST*);
05090
05100 BEGIN (*PARAMETERLIST*)
05110 FIP:=NIL; LIP1:=NIL;
05120 SKIPIFERR(FSYS+[LPARENT],256,[]);
05130 IF SY=LPARENT
05140 THEN
05150 BEGIN
05160 IF FORW
05170 THEN ERROR(553);
05180 INSYMBOL;
05190 SKIPIFERR([PROCEDURESY,FUNCTIONSY,VARSY,IDENT],256,FSYS+[RPARENT]);
05200 IF SY IN [PROCEDURESY,FUNCTIONSY,VARSY,IDENT]
05210 THEN
05220 LOOP
05230 LIP2:=NIL;
05240 IF SY IN [PROCEDURESY,FUNCTIONSY]
05250 THEN
05260 BEGIN
05270 FUNCDECL:= SY=FUNCTIONSY;
05280 INSYMBOL;
05290 LOOP
05300 IF SY=IDENT
05310 THEN
05320 BEGIN
05330 IF FUNCDECL
05340 THEN
05350 NEW(LIP,FUNC,DECLARED,FORMAL)
05360 ELSE
05370 NEW(LIP,PROC,DECLARED,FORMAL);
05380 WITH LIP^ DO
05390 BEGIN
05400 NAME:=ID; NEXT:=NIL; PFLEV:=LEVEL;IDTYPE:=NIL;
05410 PFADDR:=LC; LC:=LC+1; HIGHEST_REGISTER:=PARREGCMAX
05420 END;
05430 ENTERID(LIP);
05440 INSYMBOL;
05450 IF FIP=NIL
05460 THEN FIP:=LIP
05470 ELSE LIP1^.NEXT:=LIP;
05480 LIP1:=LIP;
05490 IF LIP2=NIL
05500 THEN LIP2:=LIP;
05510 END
05520 ELSE ERRANDSKIP(209,FSYS+[LPARENT,COLON,COMMA,IDENT,SEMICOLON,RPARENT]);
05530 EXIT IF NOT (SY IN [COMMA,IDENT]);
05540 IF SY=COMMA
05550 THEN INSYMBOL
05560 ELSE ERROR(158)
05570 END (*LOOP*);
05580 IF FUNCDECL
05590 THEN
05600 BEGIN
05610 LPARS:=2;
05620 FFPARLIST(FSYS+[COLON,SEMICOLON,RPARENT],LIP3,LPARS);
05630 LSP:=NIL;
05640 IF SY=COLON
05650 THEN
05660 BEGIN
05670 INSYMBOL;
05680 IF SY=IDENT
05690 THEN
05700 BEGIN
05710 SEARCHID([TYPES],LIP4);
05720 LSP:=LIP4^.IDTYPE;
05730 IF LSP<>NIL
05740 THEN
05750 IF NOT(LSP^.FORM IN [SCALAR,SUBRANGE,POINTER])
05760 THEN
05770 BEGIN
05780 ERROR(551); LSP:=NIL
05790 END;
05800 INSYMBOL
05810 END
05820 ELSE ERRANDSKIP(209,FSYS+[COLON,COMMA,IDENT])
05830 END
05840 ELSE ERROR(151);
05850 WHILE LIP2<>NIL DO WITH LIP2^ DO
05860 BEGIN
05870 IDTYPE:=LSP;
05880 FPARAM:=LIP3; PARLISTSIZE:=LPARS;
05890 LIP2:=NEXT
05900 END
05910 END
05920 ELSE
05930 BEGIN
05940 LPARS:=1;
05950 FFPARLIST(FSYS+[SEMICOLON,RPARENT],LIP3,LPARS);
05960 WHILE LIP2<>NIL DO WITH LIP2^ DO
05970 BEGIN
05980 FPARAM:=LIP3;
05990 PARLISTSIZE:=LPARS;
06000 LIP2:=NEXT
06010 END
06020 END
06030 END (*SY IN [PROCEDURESY,FUNCTIONSY]*)
06040 ELSE
06050 BEGIN
06060 IF SY=VARSY
06070 THEN
06080 BEGIN
06090 LKIND:=FORMAL; INSYMBOL
06100 END
06110 ELSE LKIND:=ACTUAL;
06120 LOOP
06130 IF SY=IDENT
06140 THEN
06150 BEGIN
06160 NEW(LIP,VARS);
06170 WITH LIP^ DO
06180 BEGIN
06190 NAME:=ID; NEXT:=NIL; VKIND:=LKIND; VLEV:=LEVEL;
06200 END;
06210 ENTERID(LIP);
06220 INSYMBOL;
06230 IF FIP=NIL
06240 THEN FIP:=LIP
06250 ELSE LIP1^.NEXT:=LIP;
06260 LIP1:=LIP;
06270 IF LIP2=NIL
06280 THEN LIP2:=LIP
06290 END
06300 ELSE ERRANDSKIP(209,FSYS+[COLON,COMMA,IDENT]);
06310 EXIT IF NOT(SY IN [COMMA,IDENT]);
06320 IF SY=COMMA
06330 THEN INSYMBOL
06340 ELSE ERROR(158)
06350 END (*LOOP*);
06360 IF SY=COLON
06370 THEN
06380 BEGIN
06390 INSYMBOL;
06400 IF SY=IDENT
06410 THEN
06420 BEGIN
06430 SEARCHID([TYPES],LIP3);
06440 INSYMBOL;
06450 LSP:=LIP3^.IDTYPE;
06460 IF LSP<>NIL
06470 THEN
06480 IF (LKIND=ACTUAL) AND(LSP^.FORM=FILES)
06490 THEN
06500 BEGIN
06510 ERROR(355); LSP:=NIL
06520 END
06530 END
06540 ELSE
06550 ERROR(209)
06560 END
06570 ELSE ERROR(151);
06580 WHILE LIP2<>NIL DO WITH LIP2^ DO
06590 BEGIN
06600 VADDR:=LC;
06610 IF LSP<>NIL
06620 THEN
06630 IF VKIND=FORMAL
06640 THEN LC:=LC+1
06650 ELSE LC:=LC+LSP^.SIZE;
06660 IDTYPE:=LSP;
06670 LIP2:=NEXT
06680 END;
06690 END (*SY<>FUNCTIONSY*);
06700 SKIPIFERR([RPARENT,SEMICOLON],256,[PROCEDURESY,FUNCTIONSY,IDENT,VARSY]+FSYS)
06710 EXIT IF NOT(SY IN [SEMICOLON,PROCEDURESY,FUNCTIONSY,VARSY,IDENT]);
06720 IF SY=SEMICOLON
06730 THEN INSYMBOL
06740 ELSE ERROR(156)
06750 END (*LOOP*);
06760 IF SY=RPARENT
06770 THEN INSYMBOL
06780 ELSE ERROR(152);
06790 SKIPIFERR(FSYS,166,[])
06800 END (*SY=LPARENT*)
06810 END (*PARAMETERLIST*);
06820
06830
06840 BEGIN
06850 (*PROCEDUREDECLARATION*)
06860 FSYS:=FSYS-[INITPROCSY];
06870 LLC := LC;
06880 IF PROCFLAG
06890 THEN LC := 1
06900 ELSE LC := 2;
06910 IF SY = IDENT
06920 THEN
06930 BEGIN
06940 SEARCHSECTION(DISPLAY[TOP].FNAME,LCP); (*DECIDE WHETHER FORW.*)
06950 IF LCP <> NIL
06960 THEN
06970 WITH LCP^ DO
06980 BEGIN
06990 IF KLASS = PROC
07000 THEN
07010 IF PFKIND=ACTUAL
07020 THEN FORW:=FORWDECL AND PROCFLAG
07030 ELSE FORW:=FALSE
07040 ELSE
07050 IF KLASS = FUNC
07060 THEN
07070 IF PFKIND=ACTUAL
07080 THEN FORW:=FORWDECL AND NOT PROCFLAG
07090 ELSE FORW:=FALSE
07100 ELSE FORW := FALSE;
07110 IF NOT FORW
07120 THEN ERROR(406)
07130 END
07140 ELSE FORW := FALSE;
07150 IF NOT FORW
07160 THEN
07170 BEGIN
07180 IF PROCFLAG
07190 THEN NEW(LCP,PROC,DECLARED,ACTUAL)
07200 ELSE NEW(LCP,FUNC,DECLARED,ACTUAL);
07210 WITH LCP^ DO
07220 BEGIN
07230 NAME := ID; IDTYPE := NIL; TESTFWDPTR := NIL; HIGHEST_REGISTER := PARREGCMAX;
07240 FORWDECL := FALSE; EXTERNDECL := FALSE; LANGUAGE := PASCALSY; PARLISTSIZE:=0;
07250 PFLEV := LEVEL; PFADDR := 0; FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0
07260 END;
07270 ENTERID(LCP)
07280 END
07290 ELSE LC:=LCP^.PARLISTSIZE;
07300 INSYMBOL
07310 END
07320 ELSE
07330 BEGIN
07340 ERROR(209);
07350 IF PROCFLAG
07360 THEN LCP := UPRCPTR
07370 ELSE LCP := UFCTPTR
07380 END;
07390 OLDLEV := LEVEL; OLDTOP := TOP;
07400 IF LEVEL < MAXLEVEL
07410 THEN LEVEL := LEVEL + 1
07420 ELSE ERROR(453);
07430 IF TOP < DISPLIMIT
07440 THEN
07450 BEGIN
07460 TOP := TOP + 1;
07470 WITH DISPLAY[TOP] DO
07480 BEGIN
07490 FNAME := NIL; OCCUR := BLCK;
07500 IF DEBUG
07510 THEN
07520 BEGIN
07530 NEW(LCP1); LCP1^ := UPRCPTR^;
07540 LCP1^.NEXT := LCP;
07550 ENTERID(LCP1);
07560 IF FORW AND (LCP^.NEXT <> NIL)
07570 THEN
07580 BEGIN
07590 LCP1^.LLINK := LCP^.NEXT; LCP1^.RLINK := LCP^.NEXT;
07600 LCP^.NEXT^.SELFCTP := NIL
07610 END
07620 END
07630 ELSE
07640 IF FORW
07650 THEN FNAME := LCP^.NEXT
07660 END (*WITH DISPLAY[TOP]*)
07670 END
07680 ELSE ERROR(404);
07690 IF PROCFLAG
07700 THEN
07710 BEGIN
07720 PARAMETERLIST([SEMICOLON],LCP1);
07730 IF NOT FORW
07740 THEN WITH LCP^ DO
07750 BEGIN
07760 NEXT:=LCP1; PARLISTSIZE:=LC
07770 END
07780 END
07790 ELSE
07800 BEGIN
07810 PARAMETERLIST([SEMICOLON,COLON],LCP1);
07820 IF NOT FORW
07830 THEN WITH LCP^ DO
07840 BEGIN
07850 NEXT := LCP1; PARLISTSIZE:=LC
07860 END;
07870 IF SY = COLON
07880 THEN
07890 BEGIN
07900 INSYMBOL;
07910 IF SY = IDENT
07920 THEN
07930 BEGIN
07940 IF FORW
07950 THEN ERROR(552);
07960 SEARCHID([TYPES],LCP1);
07970 LSP := LCP1^.IDTYPE;
07980 LCP^.IDTYPE := LSP;
07990 IF LSP <> NIL
08000 THEN
08010 IF NOT (LSP^.FORM IN [SCALAR,SUBRANGE,POINTER])
08020 THEN
08030 BEGIN
08040 ERROR(551); LCP^.IDTYPE := NIL
08050 END;
08060 INSYMBOL
08070 END
08080 ELSE ERRANDSKIP(209,FSYS + [SEMICOLON])
08090 END
08100 ELSE
08110 IF NOT FORW
08120 THEN ERROR(455)
08130 END;
08140 IF SY = SEMICOLON
08150 THEN INSYMBOL
08160 ELSE ERROR(156);
08170 IF SY = FORWARDSY
08180 THEN
08190 BEGIN
08200 IF FORW
08210 THEN ERROR(257)
08220 ELSE
08230 WITH LCP^ DO
08240 BEGIN
08250 TESTFWDPTR := FORWARD_PROCEDURES; FORWARD_PROCEDURES := LCP; FORWDECL := TRUE;
08260 IF NEXT <> NIL
08270 THEN NEXT^.SELFCTP := UVARPTR
08280 END;
08290 INSYMBOL;
08300 IF SY = SEMICOLON
08310 THEN INSYMBOL
08320 ELSE ERROR(156);
08330 IFERRSKIP(166,FSYS)
08340 END (* SY = FORWARDSY *)
08350 ELSE
08360 WITH LCP^ DO
08370 BEGIN
08380 IF SY IN (LANGUAGESYS + [EXTERNSY])
08390 THEN
08400 BEGIN
08410 IF FORW
08420 THEN ERROR(257)
08430 ELSE EXTERNDECL := TRUE;
08440 TTYREAD := TRUE;
08450 IF LEVEL <> 2
08460 THEN ERROR(464);
08470 IF SY IN LANGUAGESYS
08480 THEN LANGUAGE := SY;
08490 INSYMBOL;
08500 IF (LIBRARY_INDEX = 0) OR (NOT LIBRARY[LANGUAGE].CHAINED)
08510 THEN
08520 BEGIN
08530 LIBRARY_INDEX:= LIBRARY_INDEX+1;
08540 LIBRARY_ORDER[LIBRARY_INDEX]:= LANGUAGE;
08550 LIBRARY[LANGUAGE].CHAINED:= TRUE
08560 END;
08570 PFLEV := 1; PFCHAIN := EXTERNPFPTR; EXTERNPFPTR := LCP;
08580 IF SY = SEMICOLON
08590 THEN INSYMBOL
08600 ELSE ERROR(156);
08610 IFERRSKIP(166,FSYS)
08620 END (* SY = EXTERNSY *)
08630 ELSE
08640 BEGIN
08650 PFCHAIN := LOCALPFPTR;
08660 LOCALPFPTR := LCP;
08670 FORWDECL := FALSE;
08680
08690 ACTIVATED := TRUE;
08700 BLOCK(LCP,FSYS,[BEGINSY,FUNCTIONSY,PROCEDURESY,PERIOD,SEMICOLON]);
08710 ACTIVATED := FALSE;
08720
08730 IF SY = SEMICOLON
08740 THEN
08750 BEGIN
08760 INSYMBOL;
08770 SKIPIFERR([BEGINSY,PROCEDURESY,FUNCTIONSY],166,FSYS)
08780 END
08790 ELSE ERROR(156)
08800 END (* SY <> EXTERNSY *)
08810 END (* SY <> FORWARDSY *) ;
08820 LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC
08830 END (*PROCEDUREDECLARATION*) ;
08840
08850 PROCEDURE BODY(FSYS: SETOFSYS);
08860 CONST
08870
08880 FILEOF = 1B; FILEOL = 2B; FILOPN = 3B; FILSTA = 11B; FILDEV = 12B;
08890 FILBHP = 13B; FILNAM = 14B; FILBFH = 20B; FILLNR = 23B; FILCMP = 25B;
08900 VAR
08910 LAST_FILE: CTP;
08920 REG2_SAVED: BOOLEAN;
08930 REG2_LOCATION: ADDRRANGE;
08940
08950 PROCEDURE GENERATE_WORD(FRELBYTE: RELBYTE; FLEFTH: ADDRRANGE; FRIGHTH: ADDRRANGE);
08960 BEGIN
08970 (*GENERATE_WORD*)
08980 CIX := CIX + 1;
08990 IF CIX > CODE_SIZE
09000 THEN
09010 BEGIN
09020 IF NOT OVERRUN
09030 THEN
09040 BEGIN
09050 OVERRUN := TRUE;
09060 IF FPROCP = NIL
09070 THEN ERROR_WITH_TEXT(356,'MAIN ')
09080 ELSE ERROR_WITH_TEXT(356,FPROCP^.NAME)
09090 END;
09100 CIX := 0
09110 END;
09120 WITH CODE_ARRAY^.HALFWORD[CIX] DO
09130 BEGIN
09140 LEFTHALF := FLEFTH;
09150 RIGHTHALF := FRIGHTH
09160 END;
09170 CODE_REFERENCE^[CIX] := NOINSTR; CODE_RELOCATION^[CIX] := FRELBYTE;
09180 IC := IC + 1
09190 END (*GENERATE_WORD*) ;
09200
09210 PROCEDURE INSERT_ADDRESS(FRELBYTE: RELBYTE; FCIX:CODERANGE; FIC:ADDRRANGE);
09220 BEGIN
09230 CODE_ARRAY^.INSTRUCTION[FCIX].ADDRESS := FIC;
09240 CODE_RELOCATION^[FCIX] := FRELBYTE
09250 END;
09260
09270 PROCEDURE INCREMENT_REGC;
09280 BEGIN
09290 REGC := REGC + 1 ;
09300 IF REGC > REGCMAX
09310 THEN
09320 BEGIN
09330 ERROR(310) ; REGC := REGIN
09340 END
09350 END ;
09360
09370 PROCEDURE DEPOSIT_CONSTANT(KONSTTYP:CSTCLASS; FATTR:ATTR);
09380 VAR
09390 II:INTEGER;
09400 LKSP,LLKSP: KSP;
09410 LCSP: CSP;
09420 LREF: CODEREFS;
09430
09440 NEWCONSTANT,EXISTANT:BOOLEAN;
09450 LCIX: CODERANGE;
09460 BEGIN
09470 NEWCONSTANT:=TRUE; LKSP := FIRSTKONST;
09480 WHILE (LKSP <> NIL) AND NEWCONSTANT DO
09490 WITH LKSP^,CONSTPTR^ DO
09500 BEGIN
09510 IF CCLASS = KONSTTYP
09520 THEN
09530 CASE KONSTTYP OF
09540 REEL:
09550 NEWCONSTANT := RVAL <> FATTR.CVAL.VALP^.RVAL;
09560 INT:
09570 NEWCONSTANT := INTVAL <> FATTR.CVAL.IVAL;
09580 PSET:
09590 NEWCONSTANT := PVAL <> FATTR.CVAL.VALP^.PVAL;
09600 BPTR:
09610 NEWCONSTANT := BYTE <> FATTR.CVAL.BYTE;
09620 STRD,
09630 STRG:
09640 IF FATTR.CVAL.VALP^.SLGTH = SLGTH
09650 THEN
09660 BEGIN
09670 EXISTANT := TRUE;
09680 II := 1;
09690 REPEAT
09700 IF FATTR.CVAL.VALP^.SVAL[II] <> SVAL[II]
09710 THEN EXISTANT := FALSE;
09720 II:=II+1
09730 UNTIL (II>SLGTH) OR NOT EXISTANT;
09740 IF EXISTANT
09750 THEN NEWCONSTANT := FALSE
09760 END
09770 END (*CASE*);
09780 LLKSP := LKSP; LKSP := NEXTKONST
09790 END (*WHILE*);
09800
09810 IF KONSTTYP = BPTR
09820 THEN LREF := POINTREF
09830 ELSE LREF := CONSTREF;
09840
09850 IF NOT NEWCONSTANT
09860 THEN
09870 WITH LLKSP^ DO
09880 BEGIN
09890 INSERT_ADDRESS(RIGHT,CIX,ADDR); CODE_REFERENCE^[CIX]:= LREF;
09900 IF KONSTTYP IN [PSET,STRD]
09910 THEN
09920 BEGIN
09930 INSERT_ADDRESS(RIGHT,CIX-1,ADDR-1); CODE_REFERENCE^[CIX-1]:= LREF
09940 END;
09950 ADDR:= IC-1
09960 END
09970 ELSE
09980 BEGIN
09990 IF KONSTTYP = INT
10000 THEN
10010 BEGIN
10020 NEW(LCSP,INT); LCSP^.INTVAL := FATTR.CVAL.IVAL
10030 END
10040 ELSE
10050 IF KONSTTYP = BPTR
10060 THEN
10070 BEGIN
10080 NEW(LCSP,BPTR); LCSP^.BYTE := FATTR.CVAL.BYTE
10090 END
10100 ELSE LCSP := FATTR.CVAL.VALP;
10110 CODE_REFERENCE^[CIX] := LREF;
10120 IF KONSTTYP IN [PSET,STRD]
10130 THEN CODE_REFERENCE^[CIX-1] := LREF;
10140 NEW(LKSP);
10150 WITH LKSP^ DO
10160 BEGIN
10170 ADDR := IC-1; DOUBLE_CHAIN := KONSTTYP IN [PSET,STRD];
10180 CONSTPTR := LCSP; NEXTKONST := NIL
10190 END;
10200 IF FIRSTKONST = NIL
10210 THEN FIRSTKONST := LKSP
10220 ELSE LLKSP^.NEXTKONST := LKSP
10230 END
10240 END (*DEPOSIT_CONSTANT*);
10250
10260 PROCEDURE MACRO(FRELBYTE : RELBYTE;
10270 FINSTR : INSTRANGE;
10280 FAC : ACRANGE;
10290 FINDBIT : IBRANGE;
10300 FINXREG : ACRANGE;
10310 FADDRESS : ADDRRANGE);
10320 BEGIN
10330 IF NOT INITGLOBALS
10340 THEN
10350 BEGIN
10360 CIX := CIX + 1;
10370 IF CIX > CODE_SIZE
10380 THEN
10390 BEGIN
10400 IF NOT OVERRUN
10410 THEN
10420 BEGIN
10430 OVERRUN := TRUE;
10440 IF FPROCP = NIL
10450 THEN ERROR_WITH_TEXT(356,'MAIN ')
10460 ELSE ERROR_WITH_TEXT(356, FPROCP^.NAME)
10470 END;
10480 CIX := 0
10490 END;
10500 WITH CODE_ARRAY^.INSTRUCTION[CIX] DO
10510 BEGIN
10520 INSTR :=FINSTR;
10530 AC :=FAC;
10540 INDBIT :=FINDBIT;
10550 INXREG :=FINXREG;
10560 ADDRESS :=FADDRESS;
10570 CODE_REFERENCE^[CIX]:= NOREF; CODE_RELOCATION^[CIX] := FRELBYTE
10580 END;
10590 IC := IC + 1
10600 END
10610 ELSE ERROR(507)
10620 END (*MACRO*);
10630
10640 PROCEDURE MACRO5(FRELBYTE: RELBYTE; FINSTR : INSTRANGE; FAC,FINXREG : ACRANGE; FADDRESS : ADDRRANGE);
10650 BEGIN
10660 MACRO(FRELBYTE,FINSTR,FAC,0,FINXREG,FADDRESS)
10670 END;
10680
10690 PROCEDURE MACRO4(FINSTR: INSTRANGE;FAC, FINXREG: ACRANGE;FADDRESS: ADDRRANGE);
10700 BEGIN
10710 MACRO(NO,FINSTR,FAC,0,FINXREG,FADDRESS)
10720 END;
10730
10740 PROCEDURE MACRO3(FINSTR : INSTRANGE; FAC:ACRANGE; FADDRESS: ADDRRANGE);
10750 BEGIN
10760 MACRO(NO,FINSTR,FAC,0,0,FADDRESS)
10770 END;
10780
10790 PROCEDURE MACRO4R(FINSTR : INSTRANGE; FAC,FINXREG : ACRANGE; FADDRESS : ADDRRANGE);
10800 BEGIN
10810 MACRO(RIGHT,FINSTR,FAC,0,FINXREG,FADDRESS)
10820 END;
10830
10840 PROCEDURE MACRO3R(FINSTR : INSTRANGE; FAC:ACRANGE; FADDRESS: ADDRRANGE);
10850
10860 BEGIN
10870 MACRO(RIGHT,FINSTR,FAC,0,0,FADDRESS)
10880 END;
10890
10900 PROCEDURE MACRO2(FINSTR: INSTRANGE; FAC: ACRANGE);
10910 BEGIN
10920 MACRO(NO,FINSTR,FAC,0,0,0)
10930 END;
10940
10950 PROCEDURE PUT_PAGENUMBER;
10960 VAR
10970 LRELBYTE: RELBYTE;
10980 BEGIN
10990 LRELBYTE := RIGHT;
11000 WITH PAGER DO
11010 BEGIN
11020 LASTPAGER := IC;
11030 WITH WORD1 DO
11040 BEGIN
11050 IF (ADDRESS = 0) OR (ADDRESS = 377777B)
11060 THEN LRELBYTE := NO;
11070 MACRO5(LRELBYTE,304B(*CAIA*),AC,INXREG,ADDRESS)
11080 END;
11090 IF (RHALF = 0) OR (RHALF = 377777B)
11100 THEN GENERATE_WORD(NO,LHALF,RHALF)
11110 ELSE GENERATE_WORD(RIGHT,LHALF,RHALF);
11120 LASTPAGE := PAGECNT
11130 END
11140 END;
11150
11160 PROCEDURE PUT_LINENUMBER;
11170 VAR
11180 LRELBYTE: RELBYTE;
11190 BEGIN
11200 LRELBYTE := RIGHT;
11210 IF PAGECNT <> LASTPAGE
11220 THEN PUT_PAGENUMBER;
11230 IF LINECNT <> LASTLINE
11240 THEN (*BREAKPOINT*)
11250 BEGIN
11260 IF LINENR <> '-----'
11270 THEN
11280 BEGIN
11290 LINECNT := 0;
11300 FOR I := 1 TO 5 DO LINECNT := 10*LINECNT + ORD(LINENR[I]) - ORD('0')
11310 END;
11320 LINEDIFF := LINECNT - LASTLINE;
11330 IF (LASTSTOP = 0) OR (LASTSTOP = 377777B)
11340 THEN LRELBYTE := NO;
11350 IF LINEDIFF > 255
11360 THEN
11370 BEGIN
11380 MACRO5(LRELBYTE,334B(*SKIPA*),0,0,LASTSTOP);
11390 LASTSTOP := IC-1;
11400 MACRO3(320B(*JUMP*),0,LASTLINE)
11410 END
11420 ELSE
11430 BEGIN
11440 MACRO5(LRELBYTE,320B(*JUMP*),LINEDIFF MOD 16,LINEDIFF DIV 16,LASTSTOP); (*NOOP*)
11450 LASTSTOP := IC - 1
11460 END;
11470 LASTLINE := LINECNT
11480 END
11490 END;
11500
11510 PROCEDURE SUPPORT(FSUPPORT: SUPPORTS);
11520 BEGIN
11530 IF FSUPPORT = FORTRANRESET
11540 THEN MACRO3R(265B(*JSP*),BASIS,RUNTIME_SUPPORT.LINK[FORTRANRESET])
11550 ELSE
11560 IF FSUPPORT = EXITPROGRAM
11570 THEN MACRO3R(254B(*JRST*),0,RUNTIME_SUPPORT.LINK[EXITPROGRAM])
11580 ELSE MACRO3R(260B(*PUSHJ*),TOPP,RUNTIME_SUPPORT.LINK[FSUPPORT]);
11590 CODE_REFERENCE^[CIX]:= EXTERNREF;
11600 RUNTIME_SUPPORT.LINK[FSUPPORT]:= IC-1
11610 END;
11620
11630 PROCEDURE CLOSE_FILES;
11640 VAR
11650 LFILEPTR: FTP;
11660 BEGIN
11670 LFILEPTR := FILEPTR;
11680 WHILE LFILEPTR <> NIL DO
11690 WITH LFILEPTR^, FILEIDENT^ DO
11700 BEGIN
11710 MACRO3R(551B(*HRRZI*),REGIN+1,VADDR);
11720 SUPPORT(CLOSEFILE);
11730 LFILEPTR := NEXTFTP
11740 END
11750 END;
11760
11770 PROCEDURE ENTERBODY;
11780 VAR
11790 I: INTEGER; LCP : CTP;
11800 LBTP: BTP;
11810 BEGIN
11820 LBTP := LASTBTP;
11830 WHILE LBTP <> NIL DO
11840 BEGIN
11850 WITH LBTP^, ARRAYBPS[BITSIZE] DO
11860 IF STATE = REQUESTED
11870 THEN
11880 BEGIN
11890 ARRAYSP^.ARRAYBPADDR := IC;
11900 ADDRESS := IC; STATE := CALCULATED;
11910 IC := IC + BYTEMAX
11920 END
11930 ELSE ARRAYSP^.ARRAYBPADDR := ADDRESS;
11940 LBTP := LBTP^.LAST
11950 END;
11960 IF FPROCP <> NIL
11970 THEN
11980 BEGIN
11990 GENERATE_WORD(NO,0,377777B); IDTREE := CIX; (*IF DEBUG, INSERT TREE POINTER HERE*)
12000 WITH FPROCP^ DO
12010 IF PFLEV > 1
12020 THEN FOR I := MAXLEVEL DOWNTO PFLEV+1 DO
12030 MACRO4(540B(*HRR*),BASIS,BASIS,-1);
12040 PFSTART := IC;
12050 IF FPROCP^.PFLEV = 1
12060 THEN MACRO4(512B(*HLLZM*),BASIS,TOPP,-1)
12070 ELSE MACRO4(202B(*MOVEM*),BASIS,TOPP,-1);
12080 MACRO3(507B(*HRLS*),BASIS,TOPP);
12090 MACRO4(307B(*CAIG*),NEWREG,TOPP,0); STACKSIZE1 := CIX;
12100 SUPPORT(STACKOVERFLOW);
12110 MACRO4(541B(*HRRI*),TOPP,TOPP,0); STACKSIZE2 := CIX;
12120 IF TESTPACKED
12130 THEN
12140 IF LC-LCPAR <= 4
12150 THEN FOR I := LCPAR TO LC-1 DO MACRO4(402B(*SETZM*),0,BASIS,I)
12160 ELSE
12170 BEGIN
12180 MACRO4(551B(*HRRZI*),REG1,BASIS,LCPAR);
12190 MACRO3(505B(*HRLI*),REG1,LCPAR-LC);
12200 MACRO4(402B(*SETZM*),0,REG1,0);
12210 MACRO3R(253B(*AOBJN*),REG1,IC-1)
12220 END;
12230 REGC := REGIN+1;
12240 LCP := FPROCP^.NEXT;
12250 WHILE LCP <> NIL DO
12260 WITH LCP^ DO
12270 BEGIN
12280 IF KLASS <> VARS
12290 THEN
12300 BEGIN
12310 IF REGC <= FPROCP^.HIGHEST_REGISTER
12320 THEN
12330 BEGIN
12340 MACRO4(202B(*MOVEM*),REGC,BASIS,PFADDR);
12350 INCREMENT_REGC
12360 END
12370 END
12380 ELSE
12390 IF IDTYPE <> NIL
12400 THEN
12410 IF (VKIND=FORMAL) OR (IDTYPE^.SIZE=1)
12420 THEN (*COPY PARAMETERS FROM REGISTERS INTO LOCAL CELLS*)
12430 BEGIN
12440 IF REGC <= FPROCP^.HIGHEST_REGISTER
12450 THEN
12460 BEGIN
12470 MACRO4(202B(*MOVEM*),REGC,BASIS,VADDR); REGC := REGC + 1
12480 END
12490 END
12500 ELSE
12510 IF IDTYPE^.SIZE=2
12520 THEN
12530 BEGIN
12540 IF REGC <= FPROCP^.HIGHEST_REGISTER
12550 THEN
12560 BEGIN
12570 MACRO4(202B(*MOVEM*),REGC,BASIS,VADDR);
12580 IF REGC<FPROCP^.HIGHEST_REGISTER
12590 THEN MACRO4(202B(*MOVEM*),REGC+1,BASIS,VADDR+1)
12600 END;
12610 REGC:=REGC+2
12620 END
12630 ELSE
12640 BEGIN
12650 IF REGC <= FPROCP^.HIGHEST_REGISTER
12660 THEN (*COPY MULTIPLE VALUES INTO LOCAL CELLS*)
12670 BEGIN
12680 MACRO3(514B(*HRLZ*),REG1,REGC); REGC := REGC + 1
12690 END
12700 ELSE MACRO4(514B(*HRLZ*),REG1,BASIS,VADDR);
12710 MACRO4(541B(*HRRI*),REG1,BASIS,VADDR);
12720 MACRO4(251B(*BLT*),REG1,BASIS,VADDR+IDTYPE^.SIZE-1)
12730 END;
12740 LCP := LCP^.NEXT
12750 END
12760 END
12770 ELSE MAIN_START := IC;
12780
12790 IF (CURRENT_JUMP <> 0) AND (NOT EXTERNAL OR (LEVEL > 1))
12800 THEN
12810 BEGIN
12820 JUMP_TABLE[CURRENT_JUMP] := IC;
12830 MACRO2(202B(*MOVEM*),BASIS); CODE_REFERENCE^[CIX] := SAVEREF;
12840 MACRO2(202B(*MOVEM*),TOPP); CODE_REFERENCE^[CIX] := SAVEREF
12850 END
12860
12870 END (*ENTERBODY*);
12880
12890 PROCEDURE LEAVEBODY;
12900 VAR
12910 LCP: CTP; I: INTEGER;
12920 LKSP: KSP ; LPARMPTR: PTP;
12930 LDECLSCALPTR: STP;
12940 ICCHANGE: PACKED RECORD
12950 CASE BOOLEAN OF
12960 FALSE:(ICVAL: ADDRRANGE);
12970 TRUE :(ICCSP: CSP)
12980 END;
12990
13000 PROCEDURE ALFACONSTANT( FSTRING: ALFA);
13010 VAR
13020 LCSP: CSP;
13030 BEGIN
13040 NEW(LCSP,STRG);
13050 WITH LCSP^ DO
13060 BEGIN
13070 SLGTH := 10; FOR I := 1 TO 10 DO SVAL[I] := FSTRING[I]
13080 END;
13090 WITH GATTR DO
13100 BEGIN
13110 TYPTR := ALFAPTR;
13120 KIND := CST; CVAL.VALP := LCSP
13130 END
13140 END;
13150
13160 BEGIN
13170 (*LEAVEBODY*)
13180 IF DEBUG
13190 THEN PUT_LINENUMBER;
13200
13210 IF FPROCP <> NIL
13220 THEN
13230 BEGIN
13240 MACRO4(541B(*HRRI*),TOPP,BASIS,0);
13250 MACRO4(547B(*HLRS*),BASIS,TOPP,-1);
13260 MACRO3(263B(*POPJ*),TOPP,0)
13270 END
13280 ELSE
13290 BEGIN
13300 IF NOT EXTERNAL
13310 THEN
13320 BEGIN
13330 CLOSE_FILES;
13340 IF LIBRARY[FORTRANSY].CALLED AND FORTRAN_ENVIROMENT
13350 THEN
13360 BEGIN
13370 MACRO3R(551B(*HRRZI*),REGIN + 1,STDFILEPTR[4]^.VADDR);
13380 SUPPORT(PUTBUFFER);
13390 MACRO3(551B(*HRRZI*),BASIS,IC+3);
13400 SUPPORT(FORTRANEXIT);
13410 GENERATE_WORD(NO,0,0);
13420 GENERATE_WORD(NO,0,0)
13430 END
13440 ELSE SUPPORT(EXITPROGRAM);
13450 START_ADDRESS := IC;
13460 MACRO3(255B(*JFCL*),0,RUNCORE*1024);
13470 MACRO3(554B(*HLRZ*),BASIS,JBSA);
13480 MACRO4(505B(*HRLI*),BASIS,BASIS,0);
13490 MACRO4(541B(*HRRI*),TOPP,BASIS,0);
13500 STACKSIZE1 := CIX; STACKSIZE2 := CIX;
13510 MACRO3R(550B(*HRRZ*),REG1,START_ADDRESS);
13520 MACRO3(317B(*CAMG*),REG1,JBREL);
13530 MACRO3R(254B(*JRST*),0,IC+3);
13540 MACRO3(047B,REG1,11B(*CORE-UUO*));
13550 SUPPORT(NOCOREAVAILABLE);
13560 MACRO3(200B(*MOVE*),NEWREG,JBREL);
13570 MACRO4(307B(*CAIG*),NEWREG,TOPP,40B);
13580 SUPPORT(STACKOVERFLOW);
13590 MACRO3(506B(*HRLM*),NEWREG,JBSA);
13600 MACRO3(275B(*SUBI*),NEWREG,1);
13610 MACRO3(505B(*HRLI*),TOPP,400000B);
13620 MACRO3(047B,REG0,0(*RESET-UUO*));
13630 IF LIBRARY[FORTRANSY].CALLED AND FORTRAN_ENVIROMENT
13640 THEN
13650 BEGIN
13660 MACRO4(202B(*MOVEM*),NEWREG,NEWREG,0);
13670 MACRO4(202B(*MOVEM*),BASIS,NEWREG,-1);
13680 MACRO4(202B(*MOVEM*),TOPP,NEWREG,-2);
13690 SUPPORT(FORTRANRESET);
13700 GENERATE_WORD(NO,0,0);
13710 MACRO3(554B(*HLRZ*),REG1,JBSA);
13720 MACRO4(200B(*MOVE*),NEWREG,REG1,-1);
13730 MACRO4(200B(*MOVE*),BASIS,REG1,-2);
13740 MACRO4(200B(*MOVE*),TOPP,REG1,-3)
13750 END;
13760 IF NOT DEBUG AND RUNTIME_CHECK
13770 THEN
13780 BEGIN
13790 MACRO3(551B(*HRRZI*),REG1,110B); (*ENABLE OVERFLOW*)
13800 MACRO3(047B,REG1,16B(*APRENB-UUO*))
13810 END
13820 END;
13830
13840 REGC := REGIN + 1; LPARMPTR := PARMPTR;
13850
13860 IF EXTERNAL OR (PARMPTR = NIL)
13870 THEN
13880 BEGIN
13890 ALFACONSTANT(PROGRAMNAME);
13900 NAME_ADDRESS := IC;
13910 MACRO2(551B(*HRRZI*),REGC+2); DEPOSIT_CONSTANT(STRG,GATTR)
13920 END;
13930
13940 IF NOT EXTERNAL
13950 THEN
13960 BEGIN
13970
13980 IF PARMPTR <> NIL
13990 THEN
14000 NAME_ADDRESS := IC;
14010
14020 WHILE LPARMPTR <> NIL DO
14030 WITH LPARMPTR^ DO
14040 BEGIN
14050 IF FILEIDPTR <> NIL
14060 THEN
14070 WITH FILEIDPTR^ DO
14080 BEGIN
14090 ALFACONSTANT(PROGRAMNAME);
14100 MACRO2(551B(*HRRZI*),REGC+2); DEPOSIT_CONSTANT(STRG,GATTR);
14110 MACRO3R(551B(*HRRZI*),REGC,VADDR);
14120 ALFACONSTANT(NAME);
14130 MACRO2(551B(*HRRZI*),REGC+1); DEPOSIT_CONSTANT(STRG,GATTR);
14140 IF NOT INPUTFILE
14150 THEN
14160 MACRO2(400B(*SETZ*),REGC+3)
14170 ELSE
14180 MACRO3(551B(*HRRZI*),REGC+3,1);
14190 SUPPORT(READPGMPARAMETER)
14200 END
14210 ELSE
14220 ERROR_WITH_TEXT(264,FILEID);
14230 LPARMPTR := NEXTPTP
14240 END;
14250
14260 FOR I := 1 TO 4 DO MACRO2(400B(*SETZ*),REGC+I);
14270
14280 IF PARMPTR = NIL
14290 THEN
14300 BEGIN
14310 MACRO3R(551B(*HRRZI*),REGC,STDFILEPTR[1]^.VADDR);
14320 SUPPORT(RESETFILE);
14330 MACRO3R(551B(*HRRZI*),REGC,STDFILEPTR[2]^.VADDR);
14340 SUPPORT(REWRITEFILE);
14350 END;
14360
14370 MACRO3R(551B(*HRRZI*),REGC,STDFILEPTR[4]^.VADDR);
14380 MACRO4(336B(*SKIPN*),0,REGC,FILBHP);
14390 SUPPORT(REWRITEFILE);
14400 IF TTYREAD
14410 THEN
14420 BEGIN
14430 SUPPORT(OPENTTY);
14440 ALFACONSTANT('TTY ');
14450 MACRO2(551B(*HRRZI*),REGC+1); DEPOSIT_CONSTANT(STRG,GATTR);
14460 MACRO3R(551B(*HRRZI*),REGC,STDFILEPTR[3]^.VADDR);
14470 MACRO4(200B(*MOVE*),REGC+5,REGC,FILDEV);
14480 MACRO3(302B(*CAIE*),REGC+5,TTY_SIXBIT);
14490 MACRO3(550B(*HRRZ*),REGC+4,REGC+1);
14500 SUPPORT(RESETFILE)
14510 END;
14520
14530 MACRO3(552B(*HRRZM*),BASIS,DEBUG_STACKBOTTOM + SYSTEM_LOW_START);
14540 MACRO3(332B(*SKIPE*),REG0,DEBUG_INITIALIZATION + SYSTEM_LOW_START);
14550 MACRO3(256B(*XCT*),REG0,DEBUG_INITIALIZATION + SYSTEM_LOW_START);
14560 MACRO3R(254B(*JRST*),REG0,MAIN_START);
14570 IF DEBUG
14580 THEN SUPPORT(LOADDEBUG)
14590 END
14600 END;
14610
14620 CODEEND := IC;
14630 LKSP:= FIRSTKONST;
14640 WHILE LKSP <> NIL DO
14650 WITH LKSP^,CONSTPTR^ DO
14660 BEGIN
14670 KADDR:= IC;
14680 WITH ICCHANGE DO
14690 BEGIN
14700 ICVAL := IC; SELFCSP :=ICCSP
14710 END;
14720 NOCODE := FALSE;
14730 CASE CCLASS OF
14740 INT,
14750 BPTR,
14760 REEL:
14770 IC := IC + 1 ;
14780 PSET:
14790 IC := IC + 2 ;
14800 STRD,
14810 STRG:
14820 IC := IC + (SLGTH+4) DIV 5
14830 END (*CASE*);
14840 LKSP := NEXTKONST
14850 END (*WITH , WHILE*);
14860
14870 LDECLSCALPTR := DECLSCALPTR;
14880 WHILE LDECLSCALPTR <> NIL DO
14890 WITH LDECLSCALPTR^ DO
14900 IF (LEVEL = TLEV) OR ((LEVEL = 1) AND (TLEV = 0))
14910 THEN
14920 BEGIN
14930 IF REQUEST
14940 THEN
14950 BEGIN
14960 IC := IC+2*DIMENSION; VECTORADDR := IC; IC := IC + 2
14970 END;
14980 LDECLSCALPTR := NEXTSCALAR
14990 END
15000 ELSE LDECLSCALPTR := NIL;
15010
15020 IF DEBUG_SWITCH
15030 THEN
15040 BEGIN
15050 LCP := DISPLAY[TOP].FNAME;
15060 IF (LEVEL > 1) AND ( LCP <> NIL )
15070 THEN
15080 BEGIN
15090 IF LCP^.SELFCTP = NIL
15100 THEN I:= IC
15110 ELSE I := ORD(LCP^.SELFCTP);
15120 INSERT_ADDRESS(RIGHT,IDTREE,I)
15130 END
15140 END;
15150
15160 IF LEVEL = 1
15170 THEN HIGHEST_CODE := IC
15180 END(*LEAVEBODY*);
15190
15200 PROCEDURE FETCH_BASIS(VAR FATTR: ATTR);
15210 VAR
15220 P,Q: INTEGER;
15230 BEGIN
15240 WITH FATTR DO
15250 IF VLEVEL>1
15260 THEN
15270 BEGIN
15280 P := LEVEL - VLEVEL;
15290 IF P=0
15300 THEN
15310 IF INDEXR=0
15320 THEN INDEXR := BASIS
15330 ELSE MACRO3(270B(*ADD*),INDEXR,BASIS)
15340 ELSE
15350 BEGIN
15360 MACRO4(550B(*HRRZ*),REG1,BASIS,-1);
15370 FOR Q := P DOWNTO 2 DO
15380 MACRO4(550B(*HRRZ*),REG1,REG1,-1);
15390 IF INDEXR=0
15400 THEN INDEXR := REG1
15410 ELSE MACRO4(271B(*ADDI*),INDEXR,REG1,0)
15420 END;
15430
15440 (*DA IN WITH-STATEMENT DIE MOEGLICHKEIT BESTEHT,
15450 DASS FETCH_BASIS 2-MAL AKTIVIERT WIRD*)
15460
15470 VLEVEL := 1
15480
15490 END
15500 END;
15510 (*FETCH_BASIS*)
15520
15530 PROCEDURE GET_PARAMETER_ADDRESS;
15540 BEGIN
15550 FETCH_BASIS(GATTR);
15560 WITH GATTR DO
15570 BEGIN
15580 INCREMENT_REGC;
15590 MACRO5(VRELBYTE,200B(*MOVE*),REGC,INDEXR,DPLMT);
15600 INDEXR := REGC; VRELBYTE:= NO;
15610 INDBIT := 0; VLEVEL := 1; DPLMT := 0
15620 END
15630 END;
15640
15650 PROCEDURE GENERATE_CODE(FINSTR: INSTRANGE; FAC: ACRANGE; VAR FATTR: ATTR);
15660 VAR
15670 LINSTR: INSTRANGE;
15680 LREGC: ACRANGE;
15690 LATTR: ATTR;
15700 LRELBYTE: RELBYTE;
15710 LABS: INTEGER;
15720 BEGIN
15730 LRELBYTE := RIGHT;
15740 WITH FATTR DO
15750 IF TYPTR<>NIL
15760 THEN
15770 BEGIN
15780 CASE KIND OF
15790 CST:
15800 IF TYPTR=REALPTR
15810 THEN
15820 BEGIN
15830 MACRO3(FINSTR,FAC,0); DEPOSIT_CONSTANT(REEL,FATTR)
15840 END
15850 ELSE
15860 IF TYPTR^.FORM=SCALAR
15870 THEN
15880 WITH CVAL DO
15890 BEGIN
15900 IF IVAL = -MAXINT - 1
15910 THEN LABS := MAXINT
15920 ELSE LABS := ABS(IVAL);
15930 IF ((IVAL >= 0) AND (IVAL <= MAXADDR))
15940 OR
15950 ((LABS <= HWCSTMAX+1) AND (FINSTR = 200B(*MOVE*)))
15960 THEN
15970 BEGIN
15980 IF FINSTR=200B(*MOVE*)
15990 THEN
16000 IF IVAL < 0
16010 THEN FINSTR := 561B(*HRROI*)
16020 ELSE FINSTR := 551B(*HRRZI*)
16030 ELSE
16040 IF (FINSTR>=311B) AND (FINSTR <= 317B)
16050 THEN FINSTR := FINSTR - 10B (*E.G. CAML --> CAIL*)
16060 ELSE FINSTR := FINSTR+1;
16070 MACRO3(FINSTR,FAC,IVAL)
16080 END
16090 ELSE
16100 BEGIN
16110 MACRO3(FINSTR,FAC,0); DEPOSIT_CONSTANT(INT,FATTR)
16120 END
16130 END
16140 ELSE
16150 IF TYPTR=NILPTR
16160 THEN
16170 BEGIN
16180 IF FINSTR=200B(*MOVE*)
16190 THEN FINSTR := 551B(*HRRZI*)
16200 ELSE
16210 IF (FINSTR>=311B) AND (FINSTR<=317B)
16220 THEN FINSTR := FINSTR-10B
16230 ELSE FINSTR := FINSTR+1;
16240 MACRO3(FINSTR,FAC,377777B)
16250 END
16260 ELSE
16270 IF TYPTR^.FORM=POWER
16280 THEN
16290 BEGIN
16300 MACRO3(FINSTR,FAC,0); MACRO3(FINSTR,FAC-1,0); DEPOSIT_CONSTANT(PSET,FATTR)
16310 END
16320 ELSE
16330 IF TYPTR^.FORM=ARRAYS
16340 THEN
16350 IF TYPTR^.SIZE = 1
16360 THEN
16370 BEGIN
16380 MACRO3(FINSTR,FAC,0); DEPOSIT_CONSTANT(STRG,FATTR)
16390 END
16400 ELSE
16410 IF TYPTR^.SIZE = 2
16420 THEN
16430 BEGIN
16440 FATTR.CVAL.VALP^.CCLASS := STRD;
16450 MACRO3(FINSTR,FAC,0); MACRO3(FINSTR,FAC-1,0); DEPOSIT_CONSTANT(STRD,FATTR)
16460 END;
16470 VARBL:
16480 BEGIN
16490 FETCH_BASIS(FATTR); LREGC := FAC;
16500 IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND ((PACKFG<>NOTPACK) OR (FINSTR=200B(*MOVE*)))
16510 THEN
16520 IF (TYPTR^.SIZE = 2) AND LOADNOPTR
16530 THEN LREGC := INDEXR+1
16540 ELSE LREGC := INDEXR
16550 ELSE
16560 IF (PACKFG<>NOTPACK) AND (FINSTR<>200B(*MOVE*))
16570 THEN
16580 BEGIN
16590 INCREMENT_REGC; LREGC := REGC
16600 END;
16610 CASE PACKFG OF
16620 NOTPACK:
16630 BEGIN
16640 IF (TYPTR^.SIZE = 2) AND LOADNOPTR
16650 THEN
16660 BEGIN
16670 MACRO5(VRELBYTE,FINSTR,LREGC,INDEXR,DPLMT+1);
16680 MACRO5(VRELBYTE,FINSTR,LREGC-1,INDEXR,DPLMT)
16690 END
16700 ELSE MACRO(VRELBYTE,FINSTR,LREGC,INDBIT,INDEXR,DPLMT)
16710 END;
16720 PACKK:
16730 BEGIN
16740 IF VCLASS = FIELD
16750 THEN
16760 BEGIN
16770 WITH LATTR, CVAL, BYTE DO
16780 BEGIN
16790 KIND := CST;
16800 CVAL.BYTE := FATTR.VBYTE;
16810 IBIT := ORD(FATTR.VRELBYTE);
16820 IREG := FATTR.INDEXR;
16830 RELADDR := RELADDR + FATTR.DPLMT
16840 END;
16850 MACRO2(135B(*LDB*),LREGC); DEPOSIT_CONSTANT(BPTR,LATTR)
16860 END
16870 ELSE
16880 BEGIN
16890 MACRO5(VRELBYTE,551B(*HRRZI*),REG1,INDEXR,DPLMT);
16900 IF (BPADDR>REGIN) AND (BPADDR<=REGCMAX)
16910 THEN
16920 IF (INDEXR<=REGIN) OR (BPADDR<INDEXR)
16930 THEN LREGC := BPADDR
16940 ELSE LREGC := INDEXR;
16950 IF BPADDR < HIGH_START
16960 THEN LRELBYTE := NO;
16970 MACRO5(LRELBYTE,135B(*LDB*),LREGC,0,BPADDR)
16980 END
16990 END;
17000 HWORDL:
17010 MACRO5(VRELBYTE,554B(*HLRZ*),LREGC,INDEXR,DPLMT);
17020 HWORDR:
17030 MACRO5(VRELBYTE,550B(*HRRZ*),LREGC,INDEXR,DPLMT)
17040 END (*CASE*);
17050 IF (FINSTR<>200B(*MOVE*)) AND (PACKFG<>NOTPACK)
17060 THEN MACRO3(FINSTR,FAC,LREGC)
17070 ELSE FAC := LREGC
17080 END;
17090 EXPR:
17100 IF FINSTR <> 200B(*MOVE*)
17110 THEN
17120 BEGIN
17130 MACRO3(FINSTR,FAC,REG);
17140 IF TYPTR^.SIZE = 2
17150 THEN MACRO3(FINSTR,FAC-1,REG-1)
17160 END
17170 END (*CASE*);
17180 KIND := EXPR; REG := FAC
17190 END
17200 END (*GENERATE_CODE*);
17210
17220 PROCEDURE LOAD(VAR FATTR: ATTR);
17230 VAR
17240 LINSTR: INSTRANGE;
17250 BEGIN
17260 WITH FATTR DO
17270 IF TYPTR<>NIL
17280 THEN
17290 IF KIND<>EXPR
17300 THEN
17310 BEGIN
17320 INCREMENT_REGC ; LINSTR := 200B(*MOVE*);
17330 IF (TYPTR^.SIZE = 2) AND LOADNOPTR
17340 THEN INCREMENT_REGC ;
17350 GENERATE_CODE(LINSTR,REGC,FATTR); REGC := REG
17360 END
17370 END (*LOAD*) ;
17380
17390 PROCEDURE STORE(FAC: ACRANGE; VAR FATTR: ATTR);
17400 VAR
17410 LATTR: ATTR; LATTRC: ATTR; LRELBYTE: RELBYTE;
17420 BEGIN
17430 LATTR := FATTR; LRELBYTE := RIGHT;
17440 WITH LATTR DO
17450 IF TYPTR <> NIL
17460 THEN
17470 BEGIN
17480 FETCH_BASIS(LATTR);
17490 CASE PACKFG OF
17500 NOTPACK:
17510 BEGIN
17520 IF TYPTR^.SIZE = 2
17530 THEN
17540 BEGIN
17550 MACRO5(VRELBYTE,202B(*MOVEM*),FAC,INDEXR,DPLMT+1); FAC := FAC-1
17560 END;
17570 MACRO(VRELBYTE,202B(*MOVEM*),FAC,INDBIT,INDEXR,DPLMT)
17580 END;
17590 PACKK:
17600 IF VCLASS = FIELD
17610 THEN
17620 BEGIN
17630 WITH LATTRC, CVAL, BYTE DO
17640 BEGIN
17650 KIND := CST;
17660 CVAL.BYTE := LATTR.VBYTE;
17670 IBIT := ORD(LATTR.VRELBYTE);
17680 IREG := LATTR.INDEXR;
17690 RELADDR := RELADDR + LATTR.DPLMT
17700 END;
17710 MACRO2(137B(*DPB*),FAC); DEPOSIT_CONSTANT(BPTR,LATTRC)
17720 END
17730 ELSE
17740 BEGIN
17750 MACRO5(VRELBYTE,551B(*HRRZI*),REG1,INDEXR,DPLMT);
17760 IF BPADDR < HIGH_START
17770 THEN LRELBYTE := NO;
17780 MACRO5(LRELBYTE,137B(*DPB*),FAC,0,BPADDR)
17790 END;
17800 HWORDL:
17810 MACRO5(VRELBYTE,506B(*HRLM*),FAC,INDEXR,DPLMT);
17820 HWORDR:
17830 MACRO5(VRELBYTE,542B(*HRRM*),FAC,INDEXR,DPLMT)
17840 END (*CASE*)
17850 END (*WITH*)
17860 END (*STORE*) ;
17870
17880 PROCEDURE LOAD_ADDRESS;
17890 BEGIN
17900 INCREMENT_REGC ;
17910 BEGIN
17920 WITH GATTR DO
17930 IF TYPTR <> NIL
17940 THEN
17950 BEGIN
17960 CASE KIND OF
17970 CST:
17980 IF STRING(TYPTR)
17990 THEN
18000 BEGIN
18010 MACRO3(551B(*HRRZI*),REGC,0);
18020 DEPOSIT_CONSTANT(STRG,GATTR)
18030 END
18040 ELSE ERROR(171);
18050 VARBL:
18060 BEGIN
18070 IF (INDEXR>REGIN) AND (INDEXR <= REGCMAX)
18080 THEN REGC := INDEXR;
18090 FETCH_BASIS(GATTR);
18100 CASE PACKFG OF
18110 NOTPACK:
18120 MACRO(VRELBYTE,551B(*HRRZI*),REGC,INDBIT,INDEXR,DPLMT);
18130 PACKK,HWORDL,HWORDR:
18140 ERROR(357)
18150 END;
18160 IF TYPTR^.FORM = FILES
18170 THEN
18180 IF LAST_FILE <> NIL
18190 THEN
18200 WITH LAST_FILE^ DO
18210 IF (VLEV = 0) AND EXTERNAL
18220 THEN
18230 BEGIN
18240 VADDR := IC-1; CODE_REFERENCE^[CIX] := EXTERNREF
18250 END
18260 END;
18270 EXPR:
18280 ERROR(171)
18290 END;
18300 KIND := VARBL; DPLMT := 0; INDEXR:=REGC; INDBIT:=0; VRELBYTE := NO; VCLASS := VARS
18310 END
18320 END
18330 END (*LOAD_ADDRESS*) ;
18340
18350 PROCEDURE WRITE_MACHINE_CODE(WRITE_FLAG:WRITE_FORM);
18360 TYPE
18370 BIGALFA = PACKED ARRAY[1..20] OF CHAR ;
18380 VAR
18390 LLIST_CODE, PUT_CODE_ARRAY: BOOLEAN;
18400 LIC, LICMOD4: ADDRRANGE;
18410 SPACE_C, SPACE_W: INTEGER;
18420
18430 PROCEDURE NEW_LINE;
18440 BEGIN
18450 LICMOD4 := LIC MOD 4;
18460 IF (LICMOD4 = 0) AND LIST_CODE AND (LIC > 0)
18470 THEN
18480 BEGIN
18490 WRITELN(LIST);
18500 WITH RELOCATION_BLOCK DO
18510 BEGIN
18520 IF ITEM = ITEM_1
18530 THEN WRITE(LIST, LIC:6:O, SHOWRELO[RELOCATOR[0] = RIGHT])
18540 ELSE WRITE(LIST,' ':7)
18550 END
18560 END
18570 END (*NEW_LINE*) ;
18580
18590 PROCEDURE PUT_RELOCATABLE_CODE;
18600 VAR
18610 I: INTEGER;
18620 BEGIN
18630 WITH RELOCATION_BLOCK DO
18640 BEGIN
18650 IF ((COUNT > 1) OR (ITEM <> ITEM_1)) AND (COUNT > 0)
18660 THEN
18670 BEGIN
18680 FOR I:= COUNT+1 TO 18 DO RELOCATOR[I-1] := NO;
18690 FOR I:= 1 TO COUNT+2 DO
18700 BEGIN
18710 OBJECT^:= COMPONENT[I];
18720 PUT(OBJECT)
18730 END
18740 END;
18750 COUNT := 0
18760 END
18770 END;
18780
18790 PROCEDURE WRITE_BLOCK_START(FRELBYTE: RELBYTE; FLIC: ADDRRANGE; FITEM: ADDRRANGE);
18800 VAR
18810 CHANGE: PACKED RECORD
18820 CASE BOOLEAN OF
18830 TRUE: (WKONST: INTEGER);
18840 FALSE:(WLEFTHALF: ADDRRANGE; WRIGHTHALF: ADDRRANGE)
18850 END;
18860 BEGIN
18870 WITH RELOCATION_BLOCK , CHANGE DO
18880 BEGIN
18890 IF COUNT <> 0
18900 THEN PUT_RELOCATABLE_CODE;
18910 ITEM := FITEM;
18920 LIC := FLIC;
18930 IF ITEM = ITEM_1
18940 THEN
18950 BEGIN
18960 WLEFTHALF:= 0;
18970 WRIGHTHALF:= LIC;
18980 CODE[0]:= WKONST;
18990 RELOCATOR[0] := FRELBYTE;
19000 COUNT:= 1
19010 END
19020 END
19030 END;
19040
19050 PROCEDURE WRITE_WORD(FRELBYTE: RELBYTE; FWORD: INTEGER);
19060 VAR
19070 CHANGE: PACKED RECORD
19080 CASE BOOLEAN OF
19090 TRUE: (WKONST: INTEGER);
19100 FALSE:(WLEFTHALF: ADDRRANGE; WRIGHTHALF: ADDRRANGE)
19110 END;
19120 BEGIN
19130 WITH CHANGE DO
19140 BEGIN
19150 WKONST := FWORD;
19160 WITH RELOCATION_BLOCK DO
19170 BEGIN
19180 IF COUNT = 0
19190 THEN WRITE_BLOCK_START(RELOCATOR[0],LIC,ITEM);
19200 CODE[COUNT]:= FWORD;
19210
19220 IF NOT PUT_CODE_ARRAY
19230 THEN
19240 BEGIN
19250 IF FRELBYTE IN [LEFT,BOTH]
19260 THEN
19270 IF (WLEFTHALF = 0) OR (WLEFTHALF = 377777B)
19280 THEN
19290 IF FRELBYTE = BOTH
19300 THEN FRELBYTE := RIGHT
19310 ELSE FRELBYTE := NO;
19320 IF FRELBYTE IN [RIGHT,BOTH]
19330 THEN
19340 IF (WRIGHTHALF = 0) OR (WRIGHTHALF = 377777B)
19350 THEN
19360 IF FRELBYTE = BOTH
19370 THEN FRELBYTE := LEFT
19380 ELSE FRELBYTE := NO
19390 END;
19400
19410 RELOCATOR[COUNT]:= FRELBYTE;
19420 COUNT := COUNT+1;
19430 IF COUNT = 18
19440 THEN PUT_RELOCATABLE_CODE
19450 END;
19460
19470 IF LLIST_CODE
19480 THEN
19490 BEGIN
19500 NEW_LINE;
19510 IF LIC > 0
19520 THEN
19530 IF LICMOD4 = 0
19540 THEN WRITE(LIST,' ':13)
19550 ELSE WRITE(LIST,' ':11,' ':SPACE_W);
19560 IF WRITE_FLAG > WRITE_FILEBLOCKS
19570 THEN WRITE(LIST,' ':7)
19580 ELSE WRITE(LIST,WLEFTHALF:6:O, SHOWRELO[ FRELBYTE IN [LEFT,BOTH] ] );
19590 WRITE(LIST,WRIGHTHALF:6:O, SHOWRELO[ FRELBYTE IN [RIGHT,BOTH] ], ' ':3)
19600 END;
19610 LIC := LIC + 1;
19620 SPACE_W := 2
19630 END
19640 END;
19650
19660 FUNCTION RADIX50( FNAME: ALFA): RADIXRANGE;
19670 VAR
19680 I: INTEGER; C: CHAR; OCTALCODE, RADIXVALUE: RADIXRANGE;
19690 BEGIN
19700 RADIXVALUE:= 0;
19710 I:=1; C := FNAME[1];
19720 WHILE (C <> ' ') AND (I <= 6) DO
19730 BEGIN
19740 IF C IN DIGITS
19750 THEN OCTALCODE:= ORD(C)-ORD('0')+1
19760 ELSE
19770 IF C IN LETTERS
19780 THEN OCTALCODE:= ORD(C)-ORD('A')+11
19790 ELSE
19800 IF C = '.'
19810 THEN OCTALCODE:= 37
19820 ELSE
19830 IF C = '$'
19840 THEN OCTALCODE:= 38
19850 ELSE
19860 IF C = '%'
19870 THEN OCTALCODE:= 39;
19880 RADIXVALUE:= RADIXVALUE*50B+OCTALCODE; I:=I+1; C := FNAME[I]
19890 END;
19900 RADIX50:= RADIXVALUE
19910 END;
19920
19930 PROCEDURE WRITE_PAIR( FRELBYTE: RELBYTE; FADDR1, FADDR2: ADDRRANGE);
19940 BEGIN
19950 WITH CHANGE DO
19960 BEGIN
19970 WLEFTHALF:= FADDR1;
19980 WRIGHTHALF:= FADDR2;
19990 WRITE_WORD(FRELBYTE,WKONST)
20000 END
20010 END;
20020
20030 PROCEDURE WRITE_IDENTIFIER( FFLAG: FLAGRANGE; FSYMBOL: ALFA);
20040 BEGIN
20050 LLIST_CODE := FALSE;
20060 WITH CHANGE DO
20070 BEGIN
20080 IF LIST_CODE AND (WRITE_FLAG > WRITE_HISEG)
20090 THEN
20100 BEGIN
20110 IF LIC > 0
20120 THEN
20130 BEGIN
20140 IF LIC MOD 4 = 0
20150 THEN
20160 BEGIN
20170 WRITELN(LIST); WRITE(LIST,' ':7)
20180 END;
20190 WRITE(LIST,' ':13)
20200 END;
20210 WRITE(LIST,FSYMBOL:6,' ':11)
20220 END;
20230 IF FFLAG <> SIXBIT_SYMBOL
20240 THEN
20250 BEGIN
20260 FLAG:= FFLAG; SYMBOL:= RADIX50(FSYMBOL)
20270 END;
20280 WRITE_WORD(NO,WKONST); LLIST_CODE := LIST_CODE
20290 END
20300 END;
20310
20320 PROCEDURE WRITE_FIRST_LINE ;
20330 BEGIN
20340 IF LIST_CODE
20350 THEN
20360 BEGIN
20370 WRITELN(LIST);
20380 LICMOD4 := LIC MOD 4;
20390 IF LICMOD4 > 0
20400 THEN
20410 WRITE(LIST,(LIC-LICMOD4):6:O,SHOWRELO[RELOCATION_BLOCK.RELOCATOR[0] = RIGHT],' ':LICMOD4*30)
20420 END
20430 END ;
20440
20450 PROCEDURE WRITE_HEADER(FTEXT: BIGALFA);
20460 BEGIN
20470 IF LIST_CODE
20480 THEN
20490 BEGIN
20500 WRITELN(LIST); WRITELN(LIST); WRITE(LIST,FTEXT:16,':',' ':3); LIC := 0
20510 END
20520 END;
20530
20540 PROCEDURE WRITE_CONSTANT(FCST: CSTCLASS);
20550 VAR
20560 I, J: INTEGER; LRELBYTE: RELBYTE;
20570 BEGIN
20580 WITH CHANGE DO
20590 BEGIN
20600 IF (FCST = BPTR) AND (WBYTE.IBIT <> 0)
20610 THEN
20620 BEGIN
20630 WBYTE.IBIT := 0; LRELBYTE := RIGHT
20640 END
20650 ELSE LRELBYTE := NO;
20660 IF LIST_CODE
20670 THEN
20680 BEGIN
20690 NEW_LINE;
20700 IF LICMOD4 = 0
20710 THEN WRITE(LIST,' ':8)
20720 ELSE WRITE(LIST,' ':6,' ':SPACE_C);
20730 CASE FCST OF
20740 INT:
20750 WRITE(LIST,'[',' ':10,WKONST,']');
20760 REEL:
20770 WRITE(LIST,'[',' ':5,WREAL,']');
20780 STRD,
20790 STRG:
20800 BEGIN
20810 WRITE(LIST,'[',' ':15,''''); J := 0;
20820 FOR I := 1 TO 5 DO
20830 IF NOT (WSTRING[I] IN [' '..'_'])
20840 THEN J := J + 1
20850 ELSE WRITE(LIST,WSTRING[I]);
20860 WRITE(LIST,'''',' ':J,']')
20870 END;
20880 PSET:
20890 WRITE(LIST,'[',' ':10,WKONST:12:O,']');
20900 BPTR:
20910 WITH WBYTE DO
20920 WRITE(LIST, 'POINT ', SBITS:2, ', ',
20930 RELADDR:5:O, SHOWRELO[(LRELBYTE = RIGHT)], '(',
20940 IREG:2:O, '),', 35-PBITS:2)
20950 END
20960 END;
20970 WRITE_WORD(LRELBYTE,WKONST);
20980 SPACE_C := 0
20990 END
21000 END;
21010
21020 PROCEDURE CODE_FOR_FILEBLOCKS;
21030 VAR
21040 STOPPTR, LFILEPTR: FTP;
21050 I: INTEGER;
21060 FILBLOCKADR: ADDRRANGE;
21070
21080 (* IMPLEMENTATION OF FILES IN DECSYSTEM-10 PASCAL
21090
21100 FILE TYPE PACKED UNPACKED
21110 ------------------------------------------------
21120 (SUBRANGE OF) ASCII-MODE, BINARY-MODE,
21130 CHAR FORMATTED I/O, STANDARD I/O,
21140 "UPPER CASE", "FULL BOARD"
21150 LINENUMBERS &
21160 PAGEMARKS
21170
21180 (SUBRANGE OF) ASCII-MODE, AS ABOVE
21190 ASCII STANDARD I/O,
21200 "FULL BOARD"
21210
21220 OTHER TREATED AS ABOVE
21230 AS UNPACKED
21240 *)
21250
21260 BEGIN
21270 (*CODE_FOR_FILEBLOCKS*)
21280 LFILEPTR:= FILEPTR;
21290 IF NOT EXTERNAL
21300 THEN STOPPTR := NIL
21310 ELSE STOPPTR := SFILEPTR;
21320 WHILE LFILEPTR <> STOPPTR DO
21330 WITH LFILEPTR^, FILEIDENT^, CHANGE DO
21340 IF IDTYPE=NIL
21350 THEN
21360 BEGIN
21370 ERROR(171); LFILEPTR:=STOPPTR
21380 END
21390 ELSE
21400 BEGIN
21410 FILBLOCKADR := VADDR ;
21420 WRITE_BLOCK_START(RIGHT,FILBLOCKADR,ITEM_1); WRITE_FIRST_LINE;
21430 WLEFTHALF := IDTYPE^.FILE_FORM;
21440 WRIGHTHALF := FILBLOCKADR + FILCMP;
21450 WRITE_WORD(RIGHT,WKONST) ;
21460 WRITE_WORD(NO,0) ; WRITE_WORD(NO,0) ; (*RESERVE LOCATIONS FOR FILEOF AND FILEOL*)
21470 WKONST := 0;
21480 WINSTR.INSTR := 50B (*OPEN*) ; WINSTR.AC := CHANNEL ;
21490 WINSTR.ADDRESS := FILBLOCKADR + FILSTA ;
21500 WRITE_WORD(RIGHT,WKONST) (*FILOPN*) ;
21510 WINSTR.INSTR := 76B (*LOOKUP*) ; WINSTR.ADDRESS := FILBLOCKADR + FILNAM ; WRITE_WORD(RIGHT,WKONST) ;
21520 WINSTR.INSTR := 77B (*ENTER*) ; WRITE_WORD(RIGHT,WKONST) ;
21530 WINSTR.ADDRESS := 0 ;
21540 WINSTR.INSTR := 56B (* IN*) ; WRITE_WORD(NO,WKONST) ;
21550 WINSTR.INSTR := 57B (*OUT*) ; WRITE_WORD(NO,WKONST) ;
21560 WINSTR.INSTR := 70B (*CLOSE*) ; WRITE_WORD(NO,WKONST) ;
21570 WRITE_WORD(NO, IDTYPE^.FILE_MODE);
21580 IF (NAME = 'TTYOUTPUT ') OR (NAME = 'TTY ')
21590 THEN WLEFTHALF := TTY_SIXBIT
21600 ELSE WLEFTHALF := DSK_SIXBIT;
21610 WRIGHTHALF := 0;
21620 WRITE_WORD(NO,WKONST);
21630 WRITE_WORD(NO,0) ; (*BUFFERHEADER ADDRESS INSERTED DURING RESET OR REWRITE*)
21640 FOR I := 1 TO 6 DO WSIXBIT[I] := ORD( NAME[I] ) - 40B ; WRITE_WORD(NO,WKONST) ;
21650 WKONST := 0 ;
21660 FOR I := 1 TO 3 DO WSIXBIT[I] := ORD( NAME[I+6] ) - 40B ; WRITE_WORD(NO,WKONST) ;
21670 FOR I := 1 TO 6 DO WRITE_WORD(NO, 0 ) (*ZERO IN FILPROT, FILPPN, FILBFH, FILBTP, FILBTC,FILLNR*) ;
21680 WLEFTHALF := - IDTYPE^.FILTYPE^.SIZE ; WRIGHTHALF := FILBLOCKADR + FILCMP ;
21690 WRITE_WORD(RIGHT,WKONST) (*FILCNT*) ;
21700 FOR I := 1 TO IDTYPE^.FILTYPE^.SIZE DO WRITE_WORD(NO, 0 ) (*CLEAR COMPONENT LOCATIONS *) ;
21710 LFILEPTR := NEXTFTP
21720 END
21730 END (*CODE_FOR_FILEBLOCKS*);
21740
21750 PROCEDURE CODE_FOR_INSTRUCTIONS;
21760 VAR
21770 I, J, NN: INTEGER;
21780 LBYTE: BPOINTER; LDECLSCALPTR: STP; LFCONST: CTP;
21790 LRELBYTE: RELBYTE; LFIRSTKONST: KSP; LREFERENCE: CODEREFS;
21800 STRING: ARRAY[1..6] OF CHAR;
21810
21820 BEGIN
21830 (*CODE_FOR_INSTRUCTIONS*)
21840 LLIST_CODE:= FALSE;
21850 IF LIST_CODE
21860 THEN WRITEBUFFER;
21870 IF LASTBTP <> NIL
21880 THEN
21890 BEGIN
21900 WRITE_BLOCK_START(RIGHT,LASTBTP^.ARRAYSP^.ARRAYBPADDR,ITEM_1); WRITE_FIRST_LINE;
21910 WHILE LASTBTP <> NIL DO
21920 BEGIN
21930 WITH LASTBTP^, ARRAYBPS[BITSIZE] DO
21940 BEGIN
21950 LBYTE := ABYTE;
21960 IF STATE = CALCULATED
21970 THEN
21980 BEGIN
21990 NN := BYTEMAX; STATE:= USED
22000 END
22010 ELSE NN:=0
22020 END;
22030 FOR I:=1 TO NN DO
22040 BEGIN
22050 WITH CHANGE DO
22060 BEGIN
22070 WBYTE := LBYTE; WRITE_CONSTANT(BPTR)
22080 END;
22090 WITH LBYTE DO PBITS := PBITS - SBITS
22100 END (*FOR*);
22110 LASTBTP := LASTBTP^.LAST
22120 END (* WHILE*)
22130 END (*LASTBTP<>NIL*) ;
22140
22150 PUT_CODE_ARRAY := TRUE;
22160 WRITE_BLOCK_START(RIGHT,CODEEND-CIX-1,ITEM_1); WRITE_FIRST_LINE;
22170 IF LIST_CODE AND (LICMOD4 <> 0)
22180 THEN WRITE(LIST,' ':2);
22190 FOR I := 0 TO CIX DO
22200 WITH CODE_ARRAY^, INSTRUCTION[I] DO
22210 BEGIN
22220 LRELBYTE := CODE_RELOCATION^[I];
22230 LREFERENCE := CODE_REFERENCE^[I];
22240 IF (LREFERENCE IN [EXTERNREF,CONSTREF,FORWARDREF,GOTOREF,POINTREF,SAVEREF,DEBUGREF]) AND (ADDRESS = 0)
22250 THEN LRELBYTE := NO;
22260 IF LIST_CODE
22270 THEN
22280 BEGIN
22290 NEW_LINE;
22300 IF LICMOD4 = 0
22310 THEN WRITE(LIST,' ':8)
22320 ELSE WRITE(LIST,' ':6);
22330 CASE LREFERENCE OF
22340 NOINSTR:
22350 WITH HALFWORD[I] DO
22360 WRITE(LIST,' ':5,LEFTHALF :6:O, SHOWRELO[LRELBYTE IN [LEFT,BOTH]],
22370 RIGHTHALF:6:O, SHOWRELO[LRELBYTE IN [RIGHT,BOTH]],' ':5);
22380 OTHERS:
22390 BEGIN
22400 UNPACK(MNEMONICS[(INSTR+9) DIV 10],STRING,1,((INSTR+9) MOD 10)*6+1,6);
22410 WRITE(LIST,STRING:6, ' ',AC:2:O,', ', SHOWIBIT[INDBIT],
22420 ADDRESS:6:O, SHOWRELO[LRELBYTE IN [RIGHT,BOTH]]);
22430 IF INXREG > 0
22440 THEN WRITE(LIST,'(',INXREG:2:O,')',SHOWREF[LREFERENCE])
22450 ELSE WRITE(LIST,' ':4,SHOWREF[LREFERENCE])
22460 END
22470 END (*CASE*)
22480 END;
22490 WRITE_WORD(LRELBYTE,WORD[I])
22500 END (*FOR *) ;
22510 PUT_CODE_ARRAY := FALSE;
22520
22530 IF (FIRSTKONST <> NIL) OR (DECLSCALPTR <> NIL)
22540 THEN
22550 BEGIN
22560 LFIRSTKONST := FIRSTKONST;
22570 WRITE_BLOCK_START(RIGHT,LIC,ITEM_1); WRITE_FIRST_LINE;
22580 IF LIST_CODE AND (LICMOD4 <> 0)
22590 THEN WRITE(LIST,' ':2);
22600 WHILE LFIRSTKONST <> NIL DO
22610 BEGIN
22620 WITH LFIRSTKONST^.CONSTPTR^, CHANGE DO
22630 BEGIN
22640 CASE CCLASS OF
22650 INT,
22660 REEL:
22670 WKONST := INTVAL;
22680 PSET:
22690 BEGIN
22700 WKONST := INTVAL; WRITE_CONSTANT(CCLASS);
22710 WKONST := INTVAL1
22720 END;
22730 BPTR:
22740 WBYTE := BYTE;
22750 STRD,
22760 STRG:
22770 BEGIN
22780 J :=0; WKONST := 0;
22790 FOR I := 1 TO SLGTH DO
22800 BEGIN
22810 J := J+1;
22820 WSTRING[J] := SVAL[I];
22830 IF J=5
22840 THEN
22850 BEGIN
22860 J := 0;
22870 WRITE_CONSTANT(CCLASS);
22880 WKONST := 0
22890 END
22900 END
22910 END
22920 END;
22930 IF NOT (CCLASS IN [STRD,STRG]) OR (J <> 0)
22940 THEN WRITE_CONSTANT(CCLASS)
22950 END;
22960 LFIRSTKONST := LFIRSTKONST^.NEXTKONST
22970 END (*WHILE*) ;
22980
22990 LDECLSCALPTR := DECLSCALPTR;
23000 WHILE LDECLSCALPTR <> NIL DO
23010 WITH LDECLSCALPTR^ DO
23020 IF (LEVEL = TLEV) OR ((LEVEL = 1) AND (TLEV = 0))
23030 THEN
23040 BEGIN
23050 IF REQUEST
23060 THEN
23070 BEGIN
23080 LFCONST := FCONST;
23090 WHILE LFCONST <> NIL DO
23100 WITH LFCONST^ DO
23110 BEGIN
23120 FOR J := 0 TO 1 DO
23130 WITH CHANGE DO
23140 BEGIN
23150 WKONST := 0;
23160 FOR I := 1 TO 5 DO
23170 WSTRING[I] := NAME[I+J*5];
23180 WRITE_CONSTANT(STRD)
23190 END;
23200 LFCONST := NEXT
23210 END
23220 END;
23230 LDECLSCALPTR := NEXTSCALAR
23240 END
23250 ELSE LDECLSCALPTR := NIL
23260 END;
23270
23280 IF LEVEL = 1
23290 THEN
23300 BEGIN
23310 JUMP_ADDRESS := LCMAIN;
23320 LCMAIN := LCMAIN + 2 * JUMPER
23330 END;
23340
23350 IF NOT DEBUG AND (LEVEL = 1)
23360 THEN
23370 BEGIN
23380 LLIST_CODE := LIST_CODE;
23390 IF LIST_CODE
23400 THEN
23410 BEGIN
23420 WRITELN(LIST); WRITE(LIST,DEBUG_SAVE:6:O,'''',' ':13)
23430 END;
23440 WRITE_BLOCK_START(RIGHT,DEBUG_SAVE,ITEM_1);
23450 FOR I := DEBUG_SAVE TO DEBUG_PROGRAMNAME DO
23460 WRITE_WORD(NO,0)
23470 END
23480 END (*CODE_FOR_INSTRUCTIONS*);
23490
23500 PROCEDURE CODE_FOR_GLOBALS;
23510 VAR
23520 I, J: INTEGER;
23530 BEGIN
23540 (*CODE_FOR_GLOBALS*)
23550 IF LIST_CODE AND (FGLOBPTR <> NIL)
23560 THEN WRITEBUFFER;
23570 WHILE FGLOBPTR <> NIL DO
23580 WITH FGLOBPTR^ DO
23590 BEGIN
23600 J := FCIX ;
23610 WRITE_BLOCK_START(RIGHT,FIRSTGLOB,ITEM_1); WRITE_FIRST_LINE;
23620 FOR I := FIRSTGLOB TO LASTGLOB DO
23630 BEGIN
23640 CHANGE.WINSTR := CODE_ARRAY^.INSTRUCTION[J] ; J := J + 1 ;
23650 WRITE_WORD(NO,CHANGE.WKONST)
23660 END ;
23670 FGLOBPTR := NEXTGLOBPTR
23680 END
23690 END (*CODE_FOR_GLOBALS*);
23700
23710 PROCEDURE CODE_FOR_DEBUG;
23720 CONST
23730 MAXSIZE (*OF CONSTANT-, STRUCTURE-, AND IDENTIFIER-RECORD*) = 24 (*WORDS*) ;
23740 TYPE
23750 RECORDFORM = (UNSPECIFIC, CONST_REC, STRUCT_REC,
23760 IDENT_REC, DEBUG_REC);
23770 VAR
23780 LNLK : NLK;
23790 LCP: CTP;
23800 LSIZE: 1..MAXSIZE; RUN1: BOOLEAN;
23810 RELARRAY, RELEMPTY: ARRAY[1..MAXSIZE] OF RELBYTE;
23820 ICCHANGE: PACKED RECORD
23830 CASE INTEGER OF
23840 1:(ICVAL: ADDRRANGE);
23850 2:(ICCSP: CSP);
23860 3:(ICCTP: CTP);
23870 4:(ICSTP: STP)
23880 END;
23890 RECORDCHANGE: PACKED RECORD
23900 CASE RECORDFORM OF
23910 UNSPECIFIC: (WORD:ARRAY[1..MAXSIZE] OF INTEGER);
23920 CONST_REC: (STRING1: PACKED ARRAY[1..STRGLGTH] OF CHAR);
23930 STRUCT_REC: (STRUCTREC: STRUCTURE);
23940 IDENT_REC: (IDENTREC: IDENTIFIER);
23950 DEBUG_REC: (DEBUGREC: DEBENTRY)
23960 END;
23970
23980
23990 PROCEDURE WRITE_RECORD(RECORD_FORM: RECORDFORM);
24000 VAR
24010 I, J: INTEGER;
24020 BEGIN
24030 LLIST_CODE := FALSE;
24040 SPACE_C := 2;
24050 CASE RECORD_FORM OF
24060 IDENT_REC :
24070 J := 2;
24080 CONST_REC :
24090 J := LSIZE;
24100 OTHERS :
24110 J := 0;
24120 END;
24130 IF J <> 0
24140 THEN
24150 BEGIN
24160 FOR I := 1 TO J DO
24170 BEGIN
24180 CHANGE.WKONST := RECORDCHANGE.WORD[I];
24190 WRITE_CONSTANT(STRG)
24200 END;
24210 SPACE_W := 0
24220 END;
24230 LLIST_CODE := LIST_CODE;
24240 FOR I := J + 1 TO LSIZE DO WRITE_WORD(RELARRAY[I], RECORDCHANGE.WORD[I] )
24250 END;
24260
24270 PROCEDURE COPYCSP(FCSP:CSP);
24280 BEGIN
24290 IF FCSP <> NIL
24300 THEN
24310 WITH FCSP^ DO
24320 BEGIN
24330 IF CCLASS IN [STRG,STRD]
24340 THEN LSIZE := (SLGTH + 4) DIV 5
24350 ELSE ERROR(171);
24360 IF RUN1
24370 THEN
24380 BEGIN
24390 IF SELFCSP = NIL
24400 THEN WITH ICCHANGE DO
24410 BEGIN
24420 ICVAL := IC; SELFCSP := ICCSP;
24430 NOCODE := TRUE;
24440 IC := IC + LSIZE
24450 END
24460 END
24470 ELSE
24480 IF NOCODE
24490 THEN
24500 BEGIN
24510 RECORDCHANGE.STRING1 := FCSP^.SVAL;
24520 RELARRAY := RELEMPTY;
24530 WRITE_RECORD(CONST_REC); NOCODE := FALSE
24540 END
24550 END (*WITH FCSP^*)
24560 END (*COPYCSP*);
24570
24580 PROCEDURE COPYSTP(FSP:STP); FORWARD;
24590
24600 PROCEDURE COPYCTP(FCP:CTP);
24610 BEGIN
24620 IF FCP <> NIL
24630 THEN
24640 WITH FCP^ DO
24650 IF RUN1 AND (SELFCTP=NIL) OR NOT RUN1 AND NOCODE
24660 THEN
24670 BEGIN
24680 LSIZE := IDRECSIZE[KLASS];
24690 IF RUN1
24700 THEN
24710 WITH ICCHANGE DO
24720 BEGIN
24730 ICVAL := IC;
24740 SELFCTP := ICCTP; NOCODE := TRUE;
24750 IC := IC + LSIZE
24760 END (* RUN1 *)
24770 ELSE
24780 WITH RECORDCHANGE DO
24790 BEGIN
24800 RELARRAY := RELEMPTY;
24810 IDENTREC := FCP^;
24820 WITH IDENTREC DO
24830 BEGIN
24840 IF LLINK<>NIL
24850 THEN LLINK:=LLINK^.SELFCTP;
24860 IF RLINK<>NIL
24870 THEN RLINK:=RLINK^.SELFCTP;
24880 RELARRAY[3] := BOTH;
24890 IF NEXT <>NIL
24900 THEN NEXT := NEXT^.SELFCTP;
24910 RELARRAY[4] := BOTH;
24920 IF IDTYPE <> NIL
24930 THEN
24940 BEGIN
24950 CASE KLASS OF
24960 KONST:
24970 IF IDTYPE^.FORM > POINTER
24980 THEN
24990 BEGIN
25000 VALUES.VALP := VALUES.VALP^.SELFCSP;
25010 RELARRAY[6] := RIGHT
25020 END
25030 ELSE
25040 IF IDTYPE = REALPTR
25050 THEN
25060 BEGIN
25070 CHANGE.WREAL := VALUES.VALP^.RVAL;
25080 VALUES.IVAL := CHANGE.WKONST
25090 END;
25100 VARS:
25110 BEGIN
25120 IF VLEV < 2
25130 THEN RELARRAY[6] := RIGHT;
25140 WITH FCP^ DO
25150 IF (IDTYPE^.FORM = FILES) AND (VLEV = 0) AND EXTERNAL
25160 THEN VADDR := ORD(SELFCTP) + 5
25170 END
25180 END (*CASE*);
25190 IDTYPE := IDTYPE^.SELFSTP
25200 END
25210 END;
25220 WRITE_RECORD(IDENT_REC); NOCODE := FALSE
25230 END (* RUN2 *);
25240 COPYCTP(LLINK);
25250 COPYCTP(RLINK);
25260 COPYSTP(IDTYPE);
25270 COPYCTP(NEXT);
25280 IF (KLASS = KONST) AND (IDTYPE <> NIL)
25290 THEN
25300 IF IDTYPE^.FORM > POINTER
25310 THEN COPYCSP(VALUES.VALP)
25320 END (*WITH FCP^*)
25330 END (*COPYCTP*);
25340
25350 PROCEDURE COPYSTP;
25360 BEGIN
25370 IF FSP <> NIL
25380 THEN
25390 WITH FSP^ DO
25400 BEGIN
25410 IF RUN1 AND (SELFSTP = NIL) OR NOT RUN1 AND NOCODE
25420 THEN
25430 BEGIN
25440 LSIZE := STRECSIZE[FORM];
25450 IF RUN1
25460 THEN
25470 WITH ICCHANGE DO
25480 BEGIN
25490 NOCODE:=TRUE;
25500 ICVAL := IC; SELFSTP := ICSTP;
25510 IC := IC + LSIZE
25520 END (* RUN1 *)
25530 ELSE
25540 WITH RECORDCHANGE DO
25550 BEGIN
25560 RELARRAY := RELEMPTY; RELARRAY[2] := RIGHT;
25570 STRUCTREC := FSP^;
25580 WITH STRUCTREC DO
25590 CASE FORM OF
25600 SCALAR:
25610 IF SCALKIND = DECLARED
25620 THEN
25630 IF FCONST<>NIL
25640 THEN FCONST:=FCONST^.SELFCTP;
25650 SUBRANGE:
25660 RANGETYPE:=RANGETYPE^.SELFSTP;
25670 POINTER:
25680 IF ELTYPE <> NIL
25690 THEN ELTYPE := ELTYPE^.SELFSTP;
25700 POWER:
25710 ELSET := ELSET^.SELFSTP;
25720 ARRAYS:
25730 BEGIN
25740 AELTYPE := AELTYPE^.SELFSTP;
25750 INXTYPE := INXTYPE^.SELFSTP; RELARRAY[3] := BOTH
25760 END;
25770 RECORDS:
25780 BEGIN
25790 IF FSTFLD <> NIL
25800 THEN FSTFLD := FSTFLD^.SELFCTP;
25810 IF RECVAR <> NIL
25820 THEN
25830 BEGIN
25840 RECVAR := RECVAR^.SELFSTP; RELARRAY[3] := LEFT
25850 END
25860 END;
25870 FILES:
25880 FILTYPE := FILTYPE^.SELFSTP;
25890 TAGFWITHID,
25900 TAGFWITHOUTID:
25910 BEGIN
25920 FSTVAR := FSTVAR^.SELFSTP;
25930 IF FORM = TAGFWITHID
25940 THEN TAGFIELDP := TAGFIELDP^.SELFCTP;
25950 RELARRAY[3] := LEFT
25960 END;
25970 VARIANT:
25980 BEGIN
25990 IF SUBVAR <> NIL
26000 THEN SUBVAR := SUBVAR^.SELFSTP;
26010 IF FIRSTFIELD <> NIL
26020 THEN FIRSTFIELD := FIRSTFIELD^.SELFCTP;
26030 RELARRAY[3] := BOTH;
26040 IF NXTVAR <> NIL
26050 THEN NXTVAR := NXTVAR^.SELFSTP
26060 END
26070 END (*CASE*);
26080 WRITE_RECORD(STRUCT_REC); NOCODE := FALSE
26090 END (*RUN 2*);
26100 CASE FORM OF
26110 SCALAR:
26120 IF SCALKIND = DECLARED
26130 THEN COPYCTP(FCONST);
26140 SUBRANGE:
26150 COPYSTP(RANGETYPE);
26160 POINTER:
26170 COPYSTP(ELTYPE);
26180 POWER:
26190 COPYSTP(ELSET);
26200 ARRAYS:
26210 BEGIN
26220 COPYSTP(AELTYPE);
26230 COPYSTP(INXTYPE)
26240 END;
26250 RECORDS:
26260 BEGIN
26270 COPYCTP(FSTFLD);
26280 COPYSTP(RECVAR)
26290 END;
26300 FILES:
26310 COPYSTP(FILTYPE);
26320 TAGFWITHID,
26330 TAGFWITHOUTID:
26340 BEGIN
26350 COPYSTP(FSTVAR);
26360 IF FORM = TAGFWITHID
26370 THEN COPYCTP(TAGFIELDP)
26380 END;
26390 VARIANT:
26400 BEGIN
26410 COPYSTP(NXTVAR);
26420 COPYSTP(SUBVAR);
26430 COPYCTP(FIRSTFIELD)
26440 END
26450 END (*CASE*)
26460 END ;
26470 END (* WITH FSP^ *)
26480 END (*COPYSTP*);
26490
26500 BEGIN (*CODE_FOR_DEBUG*)
26510 FOR I := 1 TO MAXSIZE DO RELEMPTY[I] := NO;
26520
26530 IF DEBUG_SWITCH
26540 THEN
26550 BEGIN
26560 WRITE_FIRST_LINE; LCP := DISPLAY[TOP].FNAME;
26570 IF LEVEL = 1
26580 THEN
26590 BEGIN
26600 DEBUGENTRY.GLOBALIDTREE := IC;
26610 IF LCP<>NIL
26620 THEN
26630 IF LCP^.SELFCTP <> NIL
26640 THEN DEBUGENTRY.GLOBALIDTREE := ORD(LCP^.SELFCTP)
26650 END;
26660 FOR RUN1 := TRUE DOWNTO FALSE DO COPYCTP(LCP);
26670 LNLK := GLOBNEWLINK;
26680 WHILE LNLK <> NIL DO
26690 WITH LNLK^ DO
26700 BEGIN
26710 IF REFTYPE^.SELFSTP = NIL
26720 THEN FOR RUN1 := TRUE DOWNTO FALSE DO COPYSTP(REFTYPE);
26730 LNLK := NEXT
26740 END;
26750
26760 IF LEVEL = 1
26770 THEN
26780 BEGIN
26790 DEBUGENTRY.STANDARDIDTREE := IC;
26800 FOR RUN1 := TRUE DOWNTO FALSE DO COPYCTP(DISPLAY[0].FNAME)
26810 END;
26820 END (*DEBUG_SWITCH*);
26830
26840 IF LEVEL = 1
26850 THEN
26860 BEGIN
26870 WITH DEBUGENTRY DO
26880 BEGIN
26890 NEWPAGER; LASTPAGEELEM := PAGER;
26900 INTPOINT := INTPTR^. SELFSTP;
26910 REALPOINT := REALPTR^.SELFSTP;
26920 BOOLPOINT := BOOLPTR^.SELFSTP;
26930 CHARPOINT := ASCIIPTR^.SELFSTP
26940 END;
26950 PAGEHEADADR := IC;
26960 FOR I:=1 TO DEBENTRY_SIZE DO RELARRAY[I] := RIGHT;
26970 RECORDCHANGE.DEBUGREC := DEBUGENTRY;
26980 IC := IC + DEBENTRY_SIZE;
26990 LSIZE := DEBENTRY_SIZE;
27000 WRITE_RECORD(DEBUG_REC);
27010 HIGHEST_CODE := IC;
27020 IF LIST_CODE
27030 THEN
27040 BEGIN
27050 WRITELN(LIST); WRITE(LIST,DEBUG_SAVE:6:O,'''',' ':13)
27060 END;
27070 WRITE_BLOCK_START(RIGHT,DEBUG_SAVE,ITEM_1);
27080 WRITE_WORD(NO,0);
27090 WRITE_PAIR(NO,260740B,0);
27100 WRITE_PAIR(RIGHT,0,PAGEHEADADR);
27110 FOR I := 1 TO 3 DO WRITE_WORD(NO,0);
27120 WRITE_PAIR(NO,260740B,0);
27130 WRITE_PAIR(RIGHT,0,NAME_ADDRESS)
27140 END (*LEVEL=1*)
27150 END (*DEBUG*);
27160
27170 PROCEDURE CODE_FOR_CONTROL;
27180 VAR
27190 I,J: INTEGER; INLEVEL: BOOLEAN;
27200 CHECKER: CTP;
27210
27220
27230 BEGIN
27240 (*CODE_FOR_CONTROL*)
27250 CASE WRITE_FLAG OF
27260
27270 WRITE_INTERNALS:
27280 BEGIN
27290 WRITE_HEADER('LINK-CHAIN(S) ');
27300 WRITE_BLOCK_START(NO,0,ITEM_10);
27310
27320 WHILE GLOBNEWLINK <> NIL DO
27330 WITH GLOBNEWLINK^ DO
27340 BEGIN
27350 WRITE_PAIR( BOTH , REFADR , ORD( REFTYPE^.SELFSTP ));
27360 GLOBNEWLINK := NEXT
27370 END;
27380
27390 INLEVEL := TRUE;
27400 CHECKER := LOCALPFPTR;
27410 WHILE (CHECKER <> NIL) AND INLEVEL DO
27420 WITH CHECKER^ DO
27430 IF PFLEV = LEVEL
27440 THEN
27450 BEGIN
27460 IF PFADDR <> 0
27470 THEN FOR I := 0 TO MAXLEVEL DO
27480 IF LINKCHAIN[I] <> 0
27490 THEN WRITE_PAIR(BOTH,LINKCHAIN[I],PFADDR-I);
27500 CHECKER:= PFCHAIN
27510 END
27520 ELSE INLEVEL := FALSE;
27530 IF LEVEL > 1
27540 THEN LOCALPFPTR := CHECKER;
27550
27560 WHILE FIRSTKONST <> NIL DO
27570 WITH FIRSTKONST^, CONSTPTR^ DO
27580 BEGIN
27590 WRITE_PAIR(BOTH,ADDR,KADDR);
27600 IF (CCLASS IN [PSET,STRD]) AND DOUBLE_CHAIN
27610 THEN WRITE_PAIR(BOTH,ADDR-1,KADDR+1);
27620 FIRSTKONST:= NEXTKONST
27630 END;
27640
27650 INLEVEL := TRUE;
27660 WHILE (DECLSCALPTR <> NIL) AND INLEVEL DO
27670 WITH DECLSCALPTR^ DO
27680 IF (LEVEL = TLEV) OR ((LEVEL = 1) AND (TLEV = 0))
27690 THEN
27700 BEGIN
27710 IF REQUEST
27720 THEN WRITE_PAIR(BOTH,VECTORCHAIN,VECTORADDR);
27730 DECLSCALPTR := NEXTSCALAR
27740 END
27750 ELSE INLEVEL := FALSE;
27760
27770 INLEVEL := TRUE;
27780 WHILE (LAST_LABEL <> NIL) AND INLEVEL DO
27790 WITH LAST_LABEL^ DO
27800 IF SCOPE = LEVEL
27810 THEN
27820 BEGIN
27830 IF GOTO_CHAIN <> 0
27840 THEN
27850 IF LABEL_ADDRESS = 0
27860 THEN ERROR_WITH_TEXT(214,NAME)
27870 ELSE WRITE_PAIR(BOTH,GOTO_CHAIN,LABEL_ADDRESS);
27880 LAST_LABEL := NEXT
27890 END
27900 ELSE INLEVEL := FALSE;
27910
27920 IF LEVEL = 1
27930 THEN
27940 BEGIN
27950 J := 0;
27960 FOR I := 1 TO JUMPER DO
27970 BEGIN
27980 IF JUMP_TABLE[I] <> 0
27990 THEN
28000 BEGIN
28010 WRITE_PAIR(BOTH,JUMP_TABLE[I],JUMP_ADDRESS + J);
28020 WRITE_PAIR(BOTH,JUMP_TABLE[I] + 1, JUMP_ADDRESS + J + 1);
28030 J := J + 2
28040 END
28050 END
28060 END
28070 END;
28080
28090 WRITE_END:
28100 BEGIN
28110 WRITE_HEADER('HIGHSEG-BREAK ');
28120 WRITE_BLOCK_START(NO,0,ITEM_5);
28130 WRITE_PAIR(RIGHT,0,HIGHEST_CODE);
28140 WRITE_HEADER('LOWSEG-BREAK ');
28150 LIC := 0;
28160 WRITE_PAIR(RIGHT,0,LCMAIN); PUT_RELOCATABLE_CODE
28170 END;
28180
28190 WRITE_START:
28200 IF NOT EXTERNAL
28210 THEN
28220 BEGIN
28230 WRITE_HEADER('START-ADDRESS ');
28240 WRITE_BLOCK_START(NO,0,ITEM_7);
28250 WRITE_PAIR(RIGHT,0,START_ADDRESS)
28260 END;
28270
28280 WRITE_ENTRY:
28290 IF EXTERNAL
28300 THEN
28310 BEGIN
28320 WRITE_BLOCK_START(NO,0,ITEM_4);
28330 FOR I := 2 TO ENTRIES DO
28340 WRITE_IDENTIFIER(ENTRY_SYMBOL,ENTRY[I])
28350 END;
28360
28370 WRITE_NAME:
28380 BEGIN
28390 WRITE_BLOCK_START(NO,0,ITEM_6);
28400 WRITE_IDENTIFIER(ENTRY_SYMBOL,PROGRAMNAME)
28410 END;
28420
28430 WRITE_HISEG:
28440 BEGIN
28450 LLIST_CODE := FALSE;
28460 WRITE_BLOCK_START(NO,0,ITEM_3);
28470 WRITE_PAIR(NO,400000B,400000B)
28480 END
28490 END (*CASE*)
28500 END (*CODE_FOR_CONTROL*) ;
28510
28520 PROCEDURE CODE_FOR_SYMBOLS;
28530 VAR
28540 SAVE_LIST_CODE: BOOLEAN;
28550 SWITCHFLAG: FLAGRANGE; CHECKER: CTP;
28560 BEGIN
28570 (*CODE_FOR_SYMBOLS*)
28580 WRITE_HEADER('ENTRY-POINT(S) ');
28590 WRITE_BLOCK_START(NO,0,ITEM_2);
28600 IF NOT EXTERNAL
28610 THEN
28620 BEGIN
28630 WRITE_IDENTIFIER(LOCAL_SYMBOL,PROGRAMNAME);
28640 WRITE_PAIR(RIGHT,0,START_ADDRESS)
28650 END
28660 ELSE
28670 BEGIN
28680 CHECKER := LOCALPFPTR;
28690 WHILE CHECKER <> NIL DO
28700 WITH CHECKER^ DO
28710 BEGIN
28720 IF PFADDR <> 0
28730 THEN
28740 BEGIN
28750 WRITE_IDENTIFIER(LOCAL_SYMBOL,NAME);
28760 WRITE_PAIR(RIGHT,0,PFADDR)
28770 END;
28780 CHECKER:= PFCHAIN
28790 END;
28800 SAVE_LIST_CODE := LIST_CODE; LIST_CODE := FALSE;
28810 CHECKER := LOCALPFPTR;
28820 WHILE CHECKER <> NIL DO
28830 WITH CHECKER^ DO
28840 BEGIN
28850 IF PFADDR <> 0
28860 THEN
28870 BEGIN
28880 WRITE_IDENTIFIER(GLOBAL_SYMBOL,NAME);
28890 WRITE_PAIR(RIGHT,0,PFADDR)
28900 END;
28910 CHECKER := PFCHAIN
28920 END;
28930 LIST_CODE := SAVE_LIST_CODE
28940 END;
28950
28960 IF NOT EXTERNAL
28970 THEN
28980 BEGIN
28990 SWITCHFLAG:= GLOBAL_SYMBOL; WRITE_HEADER('ENTRY-SYMBOL(S) ')
29000 END
29010 ELSE
29020 BEGIN
29030 SWITCHFLAG:= EXTERN_SYMBOL; WRITE_HEADER('EXTERN-SYMBOL(S) ')
29040 END;
29050 FILEPTR := SFILEPTR;
29060 WHILE FILEPTR <> NIL DO
29070 WITH FILEPTR^, FILEIDENT^ DO
29080 BEGIN
29090 IF VADDR <> 0
29100 THEN
29110 BEGIN
29120 WRITE_IDENTIFIER(SWITCHFLAG,NAME);
29130 WRITE_PAIR(RIGHT,0,VADDR)
29140 END;
29150 FILEPTR:= NEXTFTP
29160 END;
29170
29180 IF NOT EXTERNAL
29190 THEN WRITE_HEADER('EXTERN-SYMBOL(S) ');
29200 CHECKER:= EXTERNPFPTR;
29210 WHILE CHECKER <> NIL DO
29220 WITH CHECKER^ DO
29230 BEGIN
29240 IF LINKCHAIN[0] <> 0
29250 THEN
29260 BEGIN
29270 IF PFLEV = 0
29280 THEN WRITE_IDENTIFIER(EXTERN_SYMBOL,EXTERNALNAME)
29290 ELSE WRITE_IDENTIFIER(EXTERN_SYMBOL,NAME);
29300 WRITE_PAIR(RIGHT,0,LINKCHAIN[0])
29310 END;
29320 CHECKER:= PFCHAIN
29330 END;
29340
29350 FOR SUPPORT_INDEX := FIRST(SUPPORT_INDEX) TO LAST(SUPPORT_INDEX) DO
29360 IF RUNTIME_SUPPORT.LINK[SUPPORT_INDEX] <> 0
29370 THEN
29380 BEGIN
29390 WRITE_IDENTIFIER(EXTERN_SYMBOL,RUNTIME_SUPPORT.NAME[SUPPORT_INDEX]);
29400 WRITE_PAIR(RIGHT,0,RUNTIME_SUPPORT.LINK[SUPPORT_INDEX])
29410 END;
29420
29430 IF DEBUG
29440 THEN
29450 BEGIN
29460 WRITE_IDENTIFIER(EXTERN_SYMBOL,RUNTIME_SUPPORT.NAME[ENTERDEBUG]);
29470 WRITE_PAIR(RIGHT,0,DEBUG_STOP);
29480 WRITE_IDENTIFIER(EXTERN_SYMBOL,RUNTIME_SUPPORT.NAME[INITIALIZEDEBUG]);
29490 WRITE_PAIR(RIGHT,0,DEBUG_INITIALIZATION)
29500 END;
29510
29520 IF NOT (DEBUG OR EXTERNAL)
29530 THEN
29540 BEGIN
29550 WRITE_IDENTIFIER(EXTERN_SYMBOL,RUNTIME_SUPPORT.NAME[OVERFLOW]);
29560 WRITE_PAIR(NO,0,JBAPR)
29570 END
29580 END (*CODE_FOR_SYMBOLS*) ;
29590
29600 PROCEDURE CODE_FOR_LIBRARIES;
29610 VAR
29620 I, J, L: INTEGER;
29630 BEGIN
29640 (*CODE_FOR_LIBRARIES*)
29650 WRITE_HEADER('LINK-LIBRARIE(S) ');
29660 WRITE_BLOCK_START(NO,0,ITEM_17);
29670 FOR L := 1 TO 2 DO
29680 BEGIN
29690 FOR I := 1 TO LIBRARY_INDEX DO
29700 WITH LIBRARY[LIBRARY_ORDER[I]] DO
29710 IF CALLED
29720 THEN WITH CHANGE DO
29730 BEGIN
29740 FOR J := 1 TO 6 DO WSIXBIT[J] := ORD(NAME[J]) - 40B;
29750 WRITE_IDENTIFIER(SIXBIT_SYMBOL,NAME);
29760 WRITE_PAIR(NO,PROJNR,PROGNR);
29770 FOR J := 1 TO 6 DO WSIXBIT[J] := ORD(DEVICE[J]) - 40B;
29780 WRITE_IDENTIFIER(SIXBIT_SYMBOL,DEVICE); LIC := LIC + 1
29790 END;
29800 I := 1;
29810 FOR LANGUAGE_INDEX := FORTRANSY DOWNTO PASCALSY DO
29820 WITH LIBRARY[LANGUAGE_INDEX] DO
29830 BEGIN
29840 CALLED := (NOT CHAINED AND CALLED) OR ((LANGUAGE_INDEX = PASCALSY) AND NOT CALLED);
29850 LIBRARY_ORDER[I] := LANGUAGE_INDEX; I := I + 1
29860 END;
29870 LIBRARY_INDEX := 2
29880 END
29890 END (*CODE_FOR_LIBRARIES*);
29900
29910 BEGIN
29920 (*WRITE_MACHINE_CODE*)
29930 PUT_CODE_ARRAY := FALSE;
29940 SPACE_W := 2; SPACE_C := 0;
29950 IF ERROR_FLAG
29960 THEN
29970 BEGIN
29980 LASTBTP := NIL;
29990 DECLSCALPTR := NIL
30000 END
30010 ELSE
30020 BEGIN
30030 LLIST_CODE := LIST_CODE;
30040 CASE WRITE_FLAG OF
30050 WRITE_FILEBLOCKS:
30060 CODE_FOR_FILEBLOCKS;
30070 WRITE_GLOBALS :
30080 CODE_FOR_GLOBALS;
30090 WRITE_CODE :
30100 CODE_FOR_INSTRUCTIONS;
30110 WRITE_DEBUG :
30120 CODE_FOR_DEBUG;
30130 WRITE_SYMBOLS :
30140 CODE_FOR_SYMBOLS;
30150 WRITE_INTERNALS,
30160 WRITE_ENTRY,
30170 WRITE_END,
30180 WRITE_START,
30190 WRITE_HISEG,
30200 WRITE_NAME :
30210 CODE_FOR_CONTROL;
30220 WRITE_LIBRARY :
30230 CODE_FOR_LIBRARIES
30240 END (*CASE*);
30250 IF LIST_CODE AND (WRITE_FLAG > WRITE_HISEG)
30260 THEN WRITELN(LIST)
30270 END (*IF ERROR_FLAG*)
30280 END (*WRITE_MACHINE_CODE*);
30290
30300 PROCEDURE STATEMENT(FSYS,STATENDS: SETOFSYS);
30310 TYPE
30320 VALUEKIND = (ONREGC,ONFIXEDREGC,TRUEJMP,FALSEJMP);
30330 VAR
30340 LCP: CTP; J: INTEGER;
30350
30360 PROCEDURE EXPRESSION(FSYS: SETOFSYS; FVALUE:VALUEKIND); FORWARD;
30370
30380 PROCEDURE MAKEREAL(VAR FATTR: ATTR);
30390 BEGIN
30400 IF FATTR.TYPTR=INTPTR
30410 THEN
30420 BEGIN
30430 LOAD(FATTR);
30440 MACRO3(551B(*HRRZI*),REG1,FATTR.REG);
30450 SUPPORT(CONVERTINTEGERTOREAL);
30460 FATTR.TYPTR := REALPTR
30470 END;
30480 IF GATTR.TYPTR=INTPTR
30490 THEN MAKEREAL(GATTR)
30500 END;
30510
30520 PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP);
30530 VAR
30540 LATTR: ATTR; LCP: CTP; LSP: STP;
30550 LMIN,LMAX,INDEXVALUE,INDEXOFFSET: INTEGER;
30560 OLDIC: ACRANGE;
30570 BYTES: BITRANGE;
30580
30590 PROCEDURE SUBLOWBOUND;
30600 BEGIN
30610 IF LMIN > 0
30620 THEN MACRO3(275B(*SUBI*),REGC,LMIN)
30630 ELSE
30640 IF LMIN < 0
30650 THEN MACRO3(271B(*ADDI*),REGC,-LMIN);
30660 IF RUNTIME_CHECK
30670 THEN
30680 BEGIN
30690 MACRO3(301B(*CAIL*),REGC,0);
30700 MACRO3(303B(*CAILE*),REGC,LMAX-LMIN);
30710 SUPPORT(INDEXERROR)
30720 END
30730 END;
30740
30750 BEGIN
30760 WITH FCP^, GATTR DO
30770 BEGIN
30780 TYPTR := IDTYPE; KIND := VARBL; PACKFG := NOTPACK; VCLASS := KLASS;
30790 CASE KLASS OF
30800 VARS:
30810 BEGIN
30820 VLEVEL := VLEV; DPLMT := VADDR; INDEXR := 0;
30830 IF VLEV > 1
30840 THEN VRELBYTE:= NO
30850 ELSE VRELBYTE:= RIGHT;
30860 IF IDTYPE^.FORM = FILES
30870 THEN LAST_FILE:= FCP
30880 ELSE LAST_FILE:= NIL;
30890 INDBIT := ORD(VKIND)
30900 END;
30910 FIELD:
30920 WITH DISPLAY[DISX] DO
30930 IF OCCUR = CREC
30940 THEN
30950 BEGIN
30960 VLEVEL := CLEV; PACKFG := PACKF; VRELBYTE := CRELBYTE;
30970 IF PACKFG = PACKK
30980 THEN
30990 BEGIN
31000 VBYTE := FLDBYTE;
31010 DPLMT := CDSPL
31020 END
31030 ELSE DPLMT := CDSPL+FLDADDR;
31040 INDEXR := CINDR; INDBIT:=CINDB
31050 END
31060 ELSE ERROR(171);
31070 FUNC:
31080 IF PFDECKIND = STANDARD
31090 THEN ERROR(502)
31100 ELSE
31110 IF PFLEV = 0
31120 THEN ERROR(502) (*EXTERNAL FUNCTION*)
31130 ELSE
31140 IF PFKIND = FORMAL (*FORMAL FUNCTION*)
31150 THEN ERROR(456)
31160 ELSE
31170 BEGIN
31180 VLEVEL := PFLEV+1;
31190 VRELBYTE := NO;
31200 IF NOT ACTIVATED
31210 THEN ERROR(509);
31220 DPLMT := 1; (* THE RELATIVE ADDRESS OF THE FUNCTION'S RESULT *)
31230 INDEXR :=0;
31240 INDBIT :=0
31250 END
31260 END (*CASE*)
31270 END (*WITH*);
31280 IFERRSKIP(166,SELECTSYS + FSYS);
31290 WHILE SY IN SELECTSYS DO
31300 BEGIN
31310 (*[*)
31320 IF SY = LBRACK
31330 THEN
31340 BEGIN
31350 IF GATTR.INDBIT = 1
31360 THEN GET_PARAMETER_ADDRESS;
31370 OLDIC := GATTR.INDEXR;
31380 INDEXOFFSET := 0 ;
31390 LOOP
31400 LATTR := GATTR; INDEXVALUE := 0 ;
31410 WITH LATTR DO
31420 IF TYPTR <> NIL
31430 THEN
31440 BEGIN
31450 IF TYPTR^.FORM <> ARRAYS
31460 THEN
31470 BEGIN
31480 ERROR(307); TYPTR := NIL
31490 END;
31500 LSP := TYPTR
31510 END;
31520 INSYMBOL;
31530 EXPRESSION(FSYS + [COMMA,RBRACK],ONREGC);
31540 IF GATTR.KIND<>CST
31550 THEN LOAD(GATTR)
31560 ELSE INDEXVALUE := GATTR.CVAL.IVAL ;
31570 IF GATTR.TYPTR <> NIL
31580 THEN
31590 IF GATTR.TYPTR^.FORM <> SCALAR
31600 THEN ERROR(403);
31610 IF LATTR.TYPTR <> NIL
31620 THEN WITH LATTR,TYPTR^ DO
31630 BEGIN
31640 IF COMPTYPES(INXTYPE,GATTR.TYPTR)
31650 THEN
31660 BEGIN
31670 IF INXTYPE <> NIL
31680 THEN
31690 BEGIN
31700 GETBOUNDS(INXTYPE,LMIN,LMAX);
31710 IF GATTR.KIND = CST
31720 THEN
31730 IF (INDEXVALUE < LMIN) OR (INDEXVALUE > LMAX)
31740 THEN ERROR(263)
31750 END
31760 END
31770 ELSE ERROR(457);
31780 TYPTR := AELTYPE
31790 END
31800 EXIT IF SY <> COMMA;
31810 WITH LATTR DO
31820 IF TYPTR<>NIL
31830 THEN
31840 IF GATTR.KIND = CST
31850 THEN DPLMT := DPLMT + ( INDEXVALUE - LMIN ) * TYPTR^.SIZE
31860 ELSE
31870 BEGIN
31880 SUBLOWBOUND;
31890 IF TYPTR^.SIZE > 1
31900 THEN MACRO3(221B(*IMULI*),REGC,TYPTR^.SIZE);
31910 IF OLDIC = 0
31920 THEN OLDIC := REGC
31930 ELSE
31940 IF OLDIC > REGCMAX
31950 THEN
31960 BEGIN
31970 MACRO3(270B(*ADD*),REGC,OLDIC);
31980 OLDIC := REGC
31990 END
32000 ELSE
32010 BEGIN
32020 MACRO3(270B(*ADD*),OLDIC,REGC) ;
32030 REGC := REGC - 1
32040 END;
32050 INDEXR := OLDIC
32060 END ;
32070 GATTR := LATTR
32080 END (*LOOP*);
32090 WITH LATTR DO
32100 IF TYPTR <> NIL
32110 THEN
32120 BEGIN
32130 IF GATTR.KIND = CST
32140 THEN INDEXOFFSET := ( INDEXVALUE - LMIN ) * TYPTR^.SIZE
32150 ELSE
32160 BEGIN
32170 IF (TYPTR^.SIZE > 1) OR RUNTIME_CHECK
32180 THEN SUBLOWBOUND
32190 ELSE INDEXOFFSET := -LMIN;
32200 IF TYPTR^.SIZE > 1
32210 THEN MACRO3(221B(*IMULI*),REGC,TYPTR^.SIZE);
32220 INDEXR := REGC
32230 END ;
32240 IF LSP^.ARRAYPF
32250 THEN
32260 BEGIN
32270 BYTES := BITMAX DIV LSP^.AELTYPE^.BITSIZE;
32280 IF GATTR.KIND = CST
32290 THEN
32300 BEGIN
32310 BPADDR := INDEXOFFSET MOD BYTES + LSP^.ARRAYBPADDR + 1;
32320 INDEXR := OLDIC;
32330 INDEXOFFSET := INDEXOFFSET DIV BYTES
32340 END
32350 ELSE
32360 BEGIN
32370 INCREMENT_REGC;
32380 IF INDEXR=OLDIC
32390 THEN
32400 BEGIN
32410 INCREMENT_REGC; INDEXR := 0
32420 END;
32430 MACRO4(571B(*HRREI*),REGC,INDEXR,INDEXOFFSET);
32440 INCREMENT_REGC;
32450 REGC := REGC-1; INDEXOFFSET := 0;
32460 MACRO3(231B(*IDIVI*),REGC,BYTES);
32470 MACRO4R(200B(*MOVE*),REGC-1,REGC+1,LSP^.ARRAYBPADDR+1);
32480 BPADDR := REGC-1; INDEXR := REGC
32490 END;
32500 PACKFG := PACKK
32510 END (*ARRAYPACKFLAG*);
32520 DPLMT := DPLMT + INDEXOFFSET ;
32530 KIND := VARBL; VCLASS := VARS;
32540 IF ( OLDIC <> INDEXR ) AND ( OLDIC <> 0 )
32550 THEN
32560 BEGIN
32570 IF OLDIC > REGCMAX
32580 THEN MACRO3(270B(*ADD*),INDEXR,OLDIC)
32590 ELSE
32600 BEGIN
32610 MACRO3(270B(*ADD*),OLDIC,INDEXR);
32620 REGC := REGC - 1;
32630 INDEXR := OLDIC
32640 END
32650 END
32660 END (*WITH.. IF TYPTR <> NIL*) ;
32670 GATTR := LATTR ;
32680 IF SY = RBRACK
32690 THEN INSYMBOL
32700 ELSE ERROR(155)
32710 END (*IF SY = LBRACK*)
32720 ELSE
32730 (*.*)
32740 IF SY = PERIOD
32750 THEN
32760 BEGIN
32770 WITH GATTR DO
32780 BEGIN
32790 IF TYPTR <> NIL
32800 THEN
32810 IF TYPTR^.FORM <> RECORDS
32820 THEN
32830 BEGIN
32840 ERROR(308); TYPTR := NIL
32850 END;
32860 IF INDBIT=1
32870 THEN GET_PARAMETER_ADDRESS;
32880 INSYMBOL;
32890 IF SY = IDENT
32900 THEN
32910 BEGIN
32920 IF TYPTR <> NIL
32930 THEN
32940 BEGIN
32950 SEARCHSECTION(TYPTR^.FSTFLD,LCP);
32960 IF LCP = NIL
32970 THEN
32980 BEGIN
32990 ERROR(309); TYPTR := NIL
33000 END
33010 ELSE WITH LCP^ DO
33020 BEGIN
33030 TYPTR := IDTYPE; PACKFG := PACKF;
33040 IF PACKFG = PACKK
33050 THEN
33060 BEGIN
33070 VCLASS := FIELD; VBYTE := FLDBYTE
33080 END
33090 ELSE DPLMT := DPLMT + FLDADDR
33100 END
33110 END;
33120 INSYMBOL
33130 END (*SY = IDENT*)
33140 ELSE ERROR(209)
33150 END (*WITH GATTR*)
33160 END (*IF SY = PERIOD*)
33170 ELSE
33180 (*^*)
33190 BEGIN
33200 IF GATTR.TYPTR <> NIL
33210 THEN WITH GATTR,TYPTR^ DO
33220 IF FORM IN [POINTER,FILES]
33230 THEN
33240 BEGIN
33250 IF FORM = POINTER
33260 THEN TYPTR := ELTYPE
33270 ELSE TYPTR := FILTYPE;
33280 IF TYPTR <> NIL
33290 THEN
33300 BEGIN
33310 LOADNOPTR := FALSE;
33320 LOAD(GATTR); LOADNOPTR := TRUE;
33330 WITH FCP^ DO
33340 IF (IDTYPE^.FORM = FILES) AND (VLEV = 0) AND EXTERNAL
33350 THEN
33360 BEGIN
33370 VADDR:= IC-1; CODE_REFERENCE^[CIX] := EXTERNREF
33380 END;
33390 INDEXR := REG; DPLMT := 0; INDBIT:=0; PACKFG := NOTPACK; KIND := VARBL;
33400 VRELBYTE:= NO; VCLASS := VARS
33410 END
33420 END
33430 ELSE ERROR(407);
33440 INSYMBOL
33450 END;
33460 IFERRSKIP(166,FSYS + SELECTSYS)
33470 END (*WHILE*);
33480 WITH GATTR DO
33490 IF TYPTR<>NIL
33500 THEN
33510 IF TYPTR^.SIZE = 2
33520 THEN
33530 BEGIN
33540 IF INDBIT = 1
33550 THEN GET_PARAMETER_ADDRESS;
33560 IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX)
33570 THEN INCREMENT_REGC
33580 END
33590 END (*SELECTOR*) ;
33600
33610 PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP);
33620
33630 LABEL
33640 666;
33650
33660 VAR
33670 LKEY: INTEGER;
33680 LCLASS: IDCLASS;
33690 LSUPPORT: SUPPORTS;
33700 TTY_MESSAGE, NOLOAD, LFOLLOWERROR, NO_RIGHT_PARENT, BUFFER_VARIABLE : BOOLEAN;
33710
33720 PROCEDURE GETFILENAME(DEFAULT_NAME:ALFA; FOLLOWSYS: SETOFSYS);
33730 VAR
33740 LCP : CTP ; LVLEV: LEVRANGE; DEFAULT,DEFAULT_TTY : BOOLEAN ;
33750 LSY: SYMBOL; LID: ALFA;
33760 BEGIN
33770
33780 DEFAULT := TRUE ; DEFAULT_TTY := FALSE; NO_RIGHT_PARENT := TRUE;
33790 BUFFER_VARIABLE := FALSE;
33800
33810 IF SY = LPARENT
33820 THEN
33830 BEGIN
33840 NO_RIGHT_PARENT := FALSE;
33850 INSYMBOL ;
33860 IF SY = IDENT
33870 THEN
33880 BEGIN
33890 SEARCHID([KONST,VARS,FIELD,PROC,FUNC],LCP);
33900 IF LCP <> NIL
33910 THEN
33920 WITH LCP^,IDTYPE^ DO
33930 IF IDTYPE <> NIL
33940 THEN
33950 BEGIN
33960 IF FORM = FILES
33970 THEN
33980 BEGIN
33990 IF ARROW IN FOLLOWSYS
34000 THEN INSYMBOL;
34010 IF SY <> ARROW
34020 THEN
34030 BEGIN
34040 DEFAULT := FALSE;
34050 IF
34060 (((LKEY IN [2,4,7,8,10,11,17,19,28]) AND (LCLASS = PROC)) OR
34070 ((LKEY = 11) AND (LCLASS = FUNC))) AND
34080 (FILE_FORM <> TEXT_FILE)
34090 THEN ERROR(366)
34100 END
34110 ELSE BUFFER_VARIABLE := TRUE
34120 END;
34130 IF KLASS = VARS
34140 THEN LVLEV := VLEV
34150 ELSE LVLEV := 1
34160 END;
34170 IF (LVLEV = 0) AND
34180 (ID = 'TTY ') AND
34190 ((DEFAULT_NAME = 'OUTPUT ') OR (DEFAULT_NAME = 'TTYOUTPUT ')) AND
34200 NOT BUFFER_VARIABLE
34210 THEN
34220 BEGIN
34230 DEFAULT := TRUE; DEFAULT_TTY := TRUE;
34240 DEFAULT_NAME := 'TTYOUTPUT '
34250 END
34260 END (*SY = IDENT*)
34270 END (*SY = LPARENT*);
34280
34290 IF NO_RIGHT_PARENT
34300 AND (SY IN (FACBEGSYS + [ADDOP])) AND NOT ( (LCLASS=FUNC) AND (LKEY IN [10,11]) )
34310 THEN ERROR(156);
34320
34330 TTYREAD := (NOT DEFAULT AND (ID = 'TTY ')) OR
34340 (DEFAULT AND (DEFAULT_NAME = 'TTY ')) OR TTYREAD;
34350
34360 IF DEFAULT
34370 THEN
34380 BEGIN
34390 LID := ID; ID := DEFAULT_NAME;
34400 SEARCHID([VARS],LCP);
34410 IF LCP^.IDTYPE^.FORM <> FILES
34420 THEN SEARCHSECTION(DISPLAY[0].FNAME,LCP);
34430 ID := LID
34440 END ;
34450
34460 LSY := SY; SY := COMMA; LFOLLOWERROR := FOLLOWERROR;
34470 SELECTOR(FSYS + [COMMA,RPARENT],LCP) ;
34480 SY := LSY; FOLLOWERROR := LFOLLOWERROR;
34490
34500 IF NOLOAD
34510 THEN
34520 WITH GATTR DO
34530 BEGIN
34540 IF (INDBIT <> 0) OR ((LCP^.VLEV = 0) AND EXTERNAL)
34550 THEN LOAD_ADDRESS;
34560 CASE LKEY OF
34570 10:
34580 DPLMT := DPLMT + FILEOF; (*EOF*)
34590 11:
34600 DPLMT := DPLMT + FILEOL; (*EOLN*)
34610 17:
34620 DPLMT := DPLMT + FILLNR (*GETLINENR*)
34630 END
34640 END
34650 ELSE LOAD_ADDRESS;
34660
34670 IF BUFFER_VARIABLE
34680 THEN
34690 BEGIN
34700 SEARCHID([VARS],LCP);
34710 SELECTOR(FSYS + (FOLLOWSYS-[ARROW]),LCP)
34720 END;
34730
34740 IF NOT DEFAULT OR DEFAULT_TTY
34750 THEN
34760 BEGIN
34770 IF NOT (ARROW IN FOLLOWSYS)
34780 THEN INSYMBOL;
34790 IF NOT (SY IN FOLLOWSYS-[ARROW])
34800 THEN
34810 ERROR(458)
34820 ELSE
34830 IF SY = COMMA
34840 THEN INSYMBOL
34850 END
34860 END (*GETFILENAME*) ;
34870
34880 PROCEDURE VARIABLE(FSYS: SETOFSYS);
34890 VAR
34900 LCP: CTP;
34910 BEGIN
34920 IF SY = IDENT
34930 THEN
34940 BEGIN
34950 SEARCHID([VARS,FIELD],LCP); INSYMBOL
34960 END
34970 ELSE
34980 BEGIN
34990 ERROR(209); LCP := UVARPTR
35000 END;
35010 SELECTOR(FSYS,LCP)
35020 END (*VARIABLE*) ;
35030
35040 PROCEDURE GETPUTRESETREWRITE;
35050 VAR
35060 DEFAULT : ARRAY [1..4] OF BOOLEAN;
35070 I : INTEGER;
35080 LATTR: ATTR;
35090
35100 PROCEDURE GETSTRINGADDRESS(LENGTH: INTEGER) ;
35110 VAR
35120 LATTR: ATTR;
35130
35140 BEGIN
35150 IF SY <> RPARENT
35160 THEN
35170 BEGIN
35180 EXPRESSION(FSYS + [COMMA],ONFIXEDREGC);
35190 WITH GATTR DO
35200 IF STRING(TYPTR)
35210 THEN
35220 WITH TYPTR^ DO
35230 IF ARRAYPF AND (SIZE=2) AND (INXTYPE^.VMAX.IVAL-INXTYPE^.VMIN.IVAL+1 = LENGTH)
35240 THEN
35250 BEGIN
35260 DEFAULT[I] := FALSE; LOAD_ADDRESS
35270 END
35280 ELSE ERROR(458)
35290 ELSE ERROR(458)
35300 END
35310 END (*GETSTRINGADDRESS*);
35320
35330 BEGIN
35340 CASE LKEY OF
35350 1,2 :
35360 GETFILENAME('INPUT ',[RPARENT]);
35370 3,4 :
35380 GETFILENAME('OUTPUT ',[RPARENT]);
35390 5 :
35400 GETFILENAME('INPUT ',[COMMA,RPARENT]);
35410 6 :
35420 GETFILENAME('OUTPUT ',[COMMA,RPARENT])
35430 END;
35440
35450 IF LKEY IN [5,6]
35460 THEN
35470 BEGIN
35480 FOR I := 1 TO 4 DO DEFAULT[I] := TRUE;
35490 I := 1;
35500 GETSTRINGADDRESS(9) (* OF FILENAME *) ;
35510 WHILE (I<3) AND NOT DEFAULT[1] AND (SY=COMMA) DO
35520 BEGIN
35530 I := I + 1;
35540 INSYMBOL; EXPRESSION(FSYS + [COMMA],ONFIXEDREGC);
35550 IF GATTR.TYPTR <> NIL
35560 THEN
35570 IF COMPTYPES(GATTR.TYPTR,INTPTR)
35580 THEN
35590 BEGIN
35600 LOAD(GATTR); DEFAULT[I] := FALSE
35610 END
35620 ELSE ERROR(458)
35630 END;
35640 IF NOT DEFAULT[3]
35650 THEN
35660 BEGIN
35670 I := I+1;
35680 IF SY = COMMA
35690 THEN INSYMBOL;
35700 GETSTRINGADDRESS(6) (* OF DEVICE NAME *)
35710 END;
35720 FOR I := 1 TO 4 DO
35730 IF DEFAULT[I]
35740 THEN
35750 BEGIN
35760 INCREMENT_REGC;
35770 MACRO2(400B(*SETZ*),REGC)
35780 END
35790 END;
35800
35810 CASE LKEY OF
35820 1:
35830 BEGIN
35840 LSUPPORT := GETFILE;
35850 IF GATTR.TYPTR <> NIL
35860 THEN
35870 IF GATTR.TYPTR^.FILE_FORM = TEXT_FILE
35880 THEN LSUPPORT := GETCHARACTER
35890 END;
35900 2:
35910 IF COMPTYPES(GATTR.TYPTR,TEXTPTR)
35920 THEN LSUPPORT := GETLINE
35930 ELSE ERROR(366) ;
35940 3:
35950 LSUPPORT := PUTFILE ;
35960 4:
35970 IF COMPTYPES(GATTR.TYPTR,TEXTPTR)
35980 THEN LSUPPORT := PUTLINE
35990 ELSE ERROR(366) ;
36000 5:
36010 LSUPPORT := RESETFILE ;
36020 6:
36030 LSUPPORT := REWRITEFILE
36040 END ;
36050 SUPPORT(LSUPPORT);
36060
36070 IF (LKEY = 1) AND (GATTR.TYPTR <> NIL) AND RUNTIME_CHECK
36080 THEN
36090 IF GATTR.TYPTR^.FILTYPE <> NIL
36100 THEN
36110 WITH GATTR.TYPTR^.FILTYPE^ DO
36120 IF (FORM = SUBRANGE) AND (GATTR.TYPTR^.FILE_FORM <> TEXT_FILE)
36130 THEN
36140 BEGIN
36150 INCREMENT_REGC; MACRO4(200B(*MOVE*),REGC,REGC-1,FILCMP);
36160 LATTR.KIND := CST; LATTR.TYPTR := RANGETYPE;
36170 LATTR.CVAL := VMAX; GENERATE_CODE(317B(*CAMG*),REGC,LATTR);
36180 LATTR.CVAL := VMIN; GENERATE_CODE(315B(*CAMGE*),REGC,LATTR);
36190 SUPPORT(INPUTERROR)
36200 END;
36210
36220 END (*GETPUTRESETREWRITE*);
36230
36240 PROCEDURE CALL_SUPPORT;
36250 BEGIN
36260 IF (LSUPPORT IN [READIRANGE..WRTDSET]) AND ((SY = COMMA) OR (LKEY IN [8,11]))
36270 THEN
36280 BEGIN
36290 IF NOT REG2_SAVED
36300 THEN
36310 BEGIN
36320 REG2_SAVED := TRUE;
36330 REG2_LOCATION := LC;
36340 LC := LC + 1;
36350 IF LC > LCMAX
36360 THEN LCMAX := LC
36370 END;
36380 MACRO4(202B(*MOVEM*),REGC,BASIS,REG2_LOCATION);
36390 SUPPORT(LSUPPORT);
36400 MACRO4(200B(*MOVE*),REGC,BASIS,REG2_LOCATION)
36410 END
36420 ELSE SUPPORT(LSUPPORT)
36430 END;
36440
36450 PROCEDURE READREADLN;
36460 VAR
36470 BOUNDCLASS: CSTCLASS;
36480 LATTR: ATTR;
36490 BASEFORM: STRUCTFORM;
36500 BEGIN
36510 GETFILENAME('INPUT ',[ARROW,RPARENT,COMMA]);
36520 IF (LKEY = 7) OR ((LKEY = 8) AND (SY = IDENT)) OR BUFFER_VARIABLE
36530 THEN
36540 LOOP
36550 IF NOT BUFFER_VARIABLE
36560 THEN
36570 BEGIN
36580 VARIABLE(FSYS + [COMMA]);
36590 LOAD_ADDRESS
36600 END;
36610 LSUPPORT := READINTEGER;
36620 BUFFER_VARIABLE := FALSE;
36630 WITH GATTR DO
36640 IF TYPTR <> NIL
36650 THEN
36660 IF TYPTR^.FORM IN [SCALAR,SUBRANGE,POWER]
36670 THEN
36680 BEGIN
36690 IF TYPTR = CHARPTR
36700 THEN TYPTR := ASCIIPTR;
36710 BASEFORM := TYPTR^.FORM;
36720 IF TYPTR^.FORM = POWER
36730 THEN
36740 BEGIN
36750 TYPTR := TYPTR^.ELSET;
36760 IF COMPTYPES(TYPTR,ASCIIPTR)
36770 THEN
36780 BEGIN
36790 MACRO3(551B(*HRRZI*),REGC+1,OFFSET);
36800 MACRO3(551B(*HRRZI*),REGC+2,BASEMAX + OFFSET)
36810 END
36820 END;
36830 IF TYPTR <> NIL
36840 THEN
36850 IF TYPTR^.FORM = SUBRANGE
36860 THEN
36870 BEGIN
36880 IF COMPTYPES(REALPTR,TYPTR^.RANGETYPE)
36890 THEN BOUNDCLASS := REEL
36900 ELSE BOUNDCLASS := INT;
36910 LATTR.KIND := CST;
36920 LATTR.CVAL := TYPTR^.VMIN; MACRO2(200B(*MOVE*),REGC+1); DEPOSIT_CONSTANT(BOUNDCLASS,LATTR);
36930 LATTR.CVAL := TYPTR^.VMAX; MACRO2(200B(*MOVE*),REGC+2); DEPOSIT_CONSTANT(BOUNDCLASS,LATTR);
36940 TYPTR := TYPTR^.RANGETYPE
36950 END
36960 ELSE
36970 IF TYPTR^.SCALKIND = DECLARED
36980 THEN
36990 BEGIN
37000 MACRO3(551B(*HRRZI*),REGC+2,TYPTR^.DIMENSION); MACRO2(400B(*SETZ*),REGC+1)
37010 END;
37020 IF TYPTR <> NIL
37030 THEN
37040 IF TYPTR^.SCALKIND = DECLARED
37050 THEN
37060 WITH TYPTR^ DO
37070 BEGIN
37080 REQUEST := TRUE; MACRO3R(551B(*HRRZI*),REGC+3,VECTORCHAIN);
37090 CODE_REFERENCE^[CIX] := CONSTREF; VECTORCHAIN := IC-1;
37100 LSUPPORT := READ_SUPPORT[DECLAREDFORM,BASEFORM]
37110 END
37120 ELSE
37130 BEGIN
37140 IF TYPTR = INTPTR
37150 THEN LSUPPORT := READ_SUPPORT[INTEGERFORM,BASEFORM]
37160 ELSE
37170 IF COMPTYPES(TYPTR,ASCIIPTR)
37180 THEN LSUPPORT := READ_SUPPORT[CHARFORM,BASEFORM]
37190 ELSE
37200 IF TYPTR = REALPTR
37210 THEN LSUPPORT := READ_SUPPORT[REALFORM,BASEFORM]
37220 ELSE ERROR(458)
37230 END
37240 END
37250 ELSE
37260 IF STRING(TYPTR)
37270 THEN
37280 BEGIN
37290 IF TYPTR^.ARRAYPF
37300 THEN LSUPPORT := READPACKEDSTRING
37310 ELSE LSUPPORT := READSTRING;
37320 WITH TYPTR^.INXTYPE^ DO MACRO3(551B(*HRRZI*),REGC+1,VMAX.IVAL-VMIN.IVAL+1)
37330 END
37340 ELSE ERROR(169);
37350 REGC := REGIN + 1;
37360 CALL_SUPPORT
37370 EXIT IF SY <> COMMA;
37380 INSYMBOL
37390 END;
37400 IF LKEY = 8
37410 THEN SUPPORT(GETLINE)
37420 END (*READREADLN*) ;
37430
37440 PROCEDURE BREAK;
37450 BEGIN
37460 GETFILENAME('TTYOUTPUT ',[RPARENT]);
37470 SUPPORT(PUTBUFFER)
37480 END ;
37490
37500 PROCEDURE WRITEWRITELN;
37510 VAR
37520 LLSP, LSP: STP;
37530 DEFAULT, REALFORMAT, DECLARED_OR_SET: BOOLEAN;
37540 LSIZE, LMIN, LMAX: INTEGER;
37550 BEGIN
37560 IF NOT TTY_MESSAGE
37570 THEN GETFILENAME('OUTPUT ',[RPARENT,COMMA,ARROW,COLON]);
37580 IF (LKEY = 10) OR ((LKEY = 11) AND (SY IN FACBEGSYS + [ADDOP])) OR BUFFER_VARIABLE
37590 THEN
37600 LOOP
37610
37620 IF NOT BUFFER_VARIABLE
37630 THEN EXPRESSION(FSYS + [COMMA,COLON],ONFIXEDREGC);
37640 LSP := GATTR.TYPTR;
37650 LSUPPORT := WRITEINTEGER;
37660
37670 IF LSP <> NIL
37680 THEN
37690 WITH LSP^ DO
37700 IF FORM <= POWER
37710 THEN
37720 BEGIN
37730 LOAD(GATTR);
37740 DECLARED_OR_SET := (FORM = POWER) OR ((FORM = SCALAR) AND (SCALKIND = DECLARED) AND NOT (LSP = BOOLPTR))
37750 END
37760 ELSE
37770 BEGIN
37780 IF NOT BUFFER_VARIABLE
37790 THEN LOAD_ADDRESS;
37800 DECLARED_OR_SET := FALSE
37810 END;
37820
37830 BUFFER_VARIABLE := FALSE;
37840
37850 IF SY = COLON
37860 THEN
37870 BEGIN
37880 INSYMBOL;
37890 EXPRESSION(FSYS + [COMMA,COLON],ONFIXEDREGC);
37900 IF GATTR.TYPTR <> NIL
37910 THEN
37920 BEGIN
37930 IF GATTR.TYPTR <> INTPTR
37940 THEN ERROR(458);
37950 IF GATTR.KIND <> EXPR
37960 THEN
37970 BEGIN
37980 GENERATE_CODE( 200B (*MOVE*) , REGIN+3 , GATTR ) ;
37990 REGC := GATTR.REG ;
38000 END ;
38010 END ;
38020 DEFAULT := FALSE
38030 END
38040 ELSE
38050 BEGIN
38060 DEFAULT := TRUE;
38070 INCREMENT_REGC (*RESERVE REGISTER FOR DEFAULT VALUE*)
38080 END ;
38090
38100 IF SY = COLON
38110 THEN
38120 BEGIN
38130 INSYMBOL;
38140 IF COMPTYPES(LSP,INTPTR)
38150 THEN
38160 BEGIN
38170 IF (SY = IDENT) AND ((ID='O ') OR (ID='H '))
38180 THEN
38190 IF ID = 'O '
38200 THEN LSUPPORT := WRITEOCTAL
38210 ELSE LSUPPORT := WRITEHEXADECIMAL
38220 ELSE ERROR(262);
38230 INSYMBOL
38240 END
38250 ELSE
38260 BEGIN
38270 EXPRESSION(FSYS + [COMMA],ONFIXEDREGC);
38280 IF GATTR.TYPTR <> NIL
38290 THEN
38300 IF GATTR.TYPTR <> INTPTR
38310 THEN ERROR(458);
38320 IF LSP <> REALPTR
38330 THEN ERROR(258);
38340 LOAD(GATTR);
38350 REALFORMAT := FALSE
38360 END
38370 END
38380 ELSE REALFORMAT := TRUE;
38390
38400 IF LSP <> INTPTR
38410 THEN
38420 BEGIN
38430 IF COMPTYPES(LSP,ASCIIPTR)
38440 THEN LSUPPORT := WRITECHARACTER
38450 ELSE
38460 IF LSP = REALPTR
38470 THEN
38480 IF REALFORMAT
38490 THEN LSUPPORT := WRITEDEF1REAL
38500 ELSE LSUPPORT := WRITEREAL
38510 ELSE
38520 IF LSP = BOOLPTR
38530 THEN LSUPPORT := WRITEBOOLEAN
38540 ELSE
38550 WITH LSP^ DO
38560 IF STRING(LSP)
38570 THEN
38580 BEGIN
38590 IF INXTYPE <> NIL
38600 THEN
38610 BEGIN
38620 GETBOUNDS(INXTYPE,LMIN,LMAX);
38630 LSIZE := LMAX-LMIN+1
38640 END
38650 ELSE LSIZE := 0;
38660 MACRO3(551B(*HRRZI*),REGIN+4,LSIZE);
38670 IF ARRAYPF
38680 THEN LSUPPORT := WRITEPACKEDSTRING
38690 ELSE LSUPPORT := WRITESTRING
38700 END
38710 ELSE
38720 IF (LSP <> NIL) AND DECLARED_OR_SET
38730 THEN
38740 BEGIN
38750 IF FORM = POWER
38760 THEN
38770 BEGIN
38780 IF ELSET <> NIL
38790 THEN
38800 IF ELSET^.FORM = SUBRANGE
38810 THEN LLSP := ELSET^.RANGETYPE
38820 ELSE LLSP := ELSET
38830 END
38840 ELSE LLSP := LSP;
38850 IF LLSP <> NIL
38860 THEN
38870 IF LLSP^.SCALKIND = DECLARED
38880 THEN
38890 WITH LLSP^ DO
38900 BEGIN
38910 IF DEFAULT
38920 THEN MACRO3(515B(*HRLZI*),REGC,DIMENSION)
38930 ELSE MACRO3(505B(*HRLI*),REGC,DIMENSION);
38940 MACRO3R(551B(*HRRZI*),REGC+1,VECTORCHAIN);
38950 VECTORCHAIN := IC-1; REQUEST := TRUE;
38960 CODE_REFERENCE^[CIX] := CONSTREF; LSUPPORT := WRITE_SUPPORT[DECLAREDFORM,LSP^.FORM]
38970 END
38980 ELSE
38990 BEGIN
39000 IF DEFAULT
39010 THEN MACRO2(400B(*SETZ*),REGC);
39020 IF LLSP = INTPTR
39030 THEN LSUPPORT := WRITE_SUPPORT[INTEGERFORM,FORM]
39040 ELSE
39050 IF COMPTYPES(LLSP,ASCIIPTR)
39060 THEN LSUPPORT := WRITE_SUPPORT[CHARFORM,FORM]
39070 ELSE ERROR(458)
39080 END
39090 END
39100 ELSE ERROR(458)
39110 END;
39120
39130 IF DEFAULT AND NOT DECLARED_OR_SET
39140 THEN LSUPPORT := SUCC( LSUPPORT );
39150 REGC :=REGIN + 1;
39160 CALL_SUPPORT
39170 EXIT IF SY <> COMMA;
39180 INSYMBOL
39190 END (* LOOP *);
39200
39210 IF LKEY = 11
39220 THEN SUPPORT(PUTLINE)
39230 END (*WRITE*) ;
39240
39250 PROCEDURE MESSAGE;
39260
39270 (* MESSAGE(<ARGUMENT LIST>)
39280
39290 IS EQUIVALENT TO
39300
39310 WRITELN(TTY);
39320 WRITELN(TTY,<ARGUMENT LIST>);
39330 BREAK(TTY); *)
39340
39350 BEGIN
39360 INCREMENT_REGC;
39370 MACRO3R(551B(*HRRZI*),REGC,STDFILEPTR[4]^.VADDR);
39380 IF EXTERNAL
39390 THEN STDFILEPTR[4]^.VADDR := IC - 1;
39400 SUPPORT(PUTLINE);
39410 LKEY := 10; TTY_MESSAGE := TRUE;
39420 WRITEWRITELN;
39430 TTY_MESSAGE := FALSE;
39440 SUPPORT(PUTLINE); SUPPORT(PUTBUFFER)
39450 END;
39460
39470 PROCEDURE PACKUNPACK;
39480
39490 (******************************************************************************
39500 *
39510 * PACK(A,I,Z<,J<,L>>) EXECUTES: FOR K := 0 TO L1-1 DO Z[J1+K] := A[I+K]
39520 *
39530 * UNPACK(Z,A,I<,J<,L>>) EXECUTES: FOR K := 0 TO L1-1 DO A[I+K] := Z[J1+K]
39540 *
39550 * A IS AN ARRAY OF A SCALAR-TYPE,
39560 * Z IS A PACKED ARRAY OF THIS TYPE (SO THE BITSIZE MUST BE <= 18),
39570 * I IS THE ABSOLUTE START-INDEX IN A,
39580 * J IS THE ABSOLUTE START-INDEX IN Z,
39590 * L IS THE NUMBER OF ELEMENTS TO BE PACKED/UNPACKED,
39600 * J1 IS J (DEFAULT: LOWERBOUND(Z)),
39610 * L1 IS L (DEFAULT: MIN(UPPERBOUND(Z)-J1,UPPERBOUND(A)-I)+1),
39620 * K IS NOT DENOTED ELSEWHERE IN THE PROGRAM.
39630 *
39640 ******************************************************************************)
39650
39660 VAR
39670 A,I,Z,J,L: ATTR; LREGC: ACRANGE;
39680 LENGTH, ASTART, ZSTART, AMAX, AMIN, ZMAX, ZMIN, PACKFACTOR: INTEGER;
39690 DEFAULT_LENGTH: BOOLEAN;
39700
39710 PROCEDURE ADJUST( VAR FATTR: ATTR; FBOUND: INTEGER);
39720 BEGIN
39730 LOAD(FATTR);
39740 IF FBOUND < 0
39750 THEN MACRO3(271B(*ADDI*),FATTR.REG,-FBOUND)
39760 ELSE
39770 IF FBOUND > 0
39780 THEN MACRO3(275B(*SUBI*),FATTR.REG,FBOUND);
39790 IF RUNTIME_CHECK
39800 THEN
39810 BEGIN
39820 MACRO2(305B(*CAIGE*),FATTR.REG);
39830 SUPPORT(INDEXERROR)
39840 END
39850 END;
39860
39870 PROCEDURE GETOFFSET( VAR FATTR: ATTR; FSYS: SETOFSYS; COMPTYPTR: STP);
39880 BEGIN
39890 EXPRESSION(FSYS,ONREGC); FATTR := GATTR;
39900 IF NOT ERROR_FLAG
39910 THEN
39920 WITH FATTR DO
39930 IF TYPTR <> NIL
39940 THEN
39950 IF NOT COMPTYPES(TYPTR,COMPTYPTR)
39960 THEN ERROR(458);
39970 IF (SY=COMMA) AND (COMMA IN FSYS)
39980 THEN INSYMBOL
39990 ELSE
40000 IF (SY <> RPARENT) OR NOT (RPARENT IN FSYS)
00010 THEN ERROR(458)
00020 END;
00030
00040 PROCEDURE GETVAR( VAR FATTR: ATTR; FSYS: SETOFSYS; COMPTYPTR: STP);
00050 BEGIN
00060 VARIABLE(FSYS); LOAD_ADDRESS; FATTR := GATTR;
00070 IF NOT ERROR_FLAG
00080 THEN
00090 WITH FATTR DO
00100 IF TYPTR <> NIL
00110 THEN
00120 WITH TYPTR^ DO
00130 IF FORM = ARRAYS
00140 THEN
00150 BEGIN
00160 IF COMPTYPTR = NIL
00170 THEN
00180 IF LKEY = 12
00190 THEN
00200 BEGIN
00210 IF ARRAYPF
00220 THEN ERROR(458)
00230 END
00240 ELSE
00250 BEGIN
00260 IF NOT ARRAYPF
00270 THEN ERROR(458)
00280 END
00290 ELSE
00300 IF NOT ((ARRAYPF <> COMPTYPTR^.ARRAYPF) AND
00310 COMPTYPES(AELTYPE,COMPTYPTR^.AELTYPE) AND
00320 COMPTYPES(INXTYPE,COMPTYPTR^.INXTYPE))
00330 THEN ERROR(458);
00340 KIND := EXPR;
00350 IF ARRAYPF
00360 THEN
00370 BEGIN
00380 REG := REG1; REGC := REGC-1;
00390 CODE_ARRAY^.INSTRUCTION[CIX].AC := REG1
00400 END
00410 ELSE REG := INDEXR
00420 END
00430 ELSE ERROR(458);
00440 IF (SY = COMMA) AND (COMMA IN FSYS)
00450 THEN INSYMBOL
00460 ELSE
00470 IF (SY <> RPARENT) OR NOT (RPARENT IN FSYS)
00480 THEN ERROR(458)
00490 END;
00500
00510 BEGIN (* PACKUNPACK *)
00520 LREGC := REGC; DEFAULT_LENGTH := TRUE;
00530 IF LKEY = 12
00540 THEN
00550 BEGIN
00560 GETVAR(A,[COMMA],NIL);
00570 IF A.TYPTR <> NIL
00580 THEN GETOFFSET(I,[COMMA],A.TYPTR^.INXTYPE)
00590 ELSE GETOFFSET(I,[COMMA],NIL);
00600 GETVAR(Z,[COMMA,RPARENT],A.TYPTR)
00610 END
00620 ELSE
00630 BEGIN
00640 GETVAR(Z,[COMMA],NIL);
00650 GETVAR(A,[COMMA],Z.TYPTR);
00660 IF A.TYPTR <> NIL
00670 THEN GETOFFSET(I,[COMMA,RPARENT],A.TYPTR^.INXTYPE)
00680 ELSE GETOFFSET(I,[COMMA,RPARENT],NIL)
00690 END;
00700
00710 IF NOT ERROR_FLAG
00720 THEN
00730 BEGIN
00740 GETBOUNDS(A.TYPTR^.INXTYPE,AMIN,AMAX); AMAX := AMAX-AMIN;
00750 GETBOUNDS(Z.TYPTR^.INXTYPE,ZMIN,ZMAX); ZMAX := ZMAX-ZMIN;
00760 END;
00770
00780 WITH J DO
00790 BEGIN
00800 KIND := CST; CVAL.IVAL := ZMIN
00810 END;
00820
00830
00840 WITH L DO
00850 BEGIN
00860 KIND := CST; CVAL.IVAL := 0
00870 END;
00880
00890 IF SY <> RPARENT
00900 THEN
00910 BEGIN
00920 IF Z.TYPTR <> NIL
00930 THEN GETOFFSET(J,[COMMA,RPARENT],Z.TYPTR^.INXTYPE)
00940 ELSE GETOFFSET(J,[COMMA,RPARENT],NIL);
00950 IF SY <> RPARENT
00960 THEN
00970 BEGIN
00980 DEFAULT_LENGTH := FALSE;
00990 GETOFFSET(L,[RPARENT],INTPTR)
01000 END
01010 END;
01020
01030 IF NOT ERROR_FLAG
01040 THEN
01050 BEGIN
01060 ASTART := 0; PACKFACTOR := BITMAX DIV Z.TYPTR^.AELTYPE^.BITSIZE;
01070 IF (I.KIND = CST) AND (J.KIND = CST) AND (L.KIND = CST)
01080 THEN
01090 BEGIN
01100 ASTART := I.CVAL.IVAL - AMIN;
01110 ZSTART := J.CVAL.IVAL - ZMIN;
01120 IF (ASTART >= 0) AND (ZSTART >= 0)
01130 THEN
01140 BEGIN
01150 LENGTH := MIN(ZMAX-ZSTART, AMAX-ASTART) + 1;
01160 IF LENGTH >= 0
01170 THEN
01180 BEGIN
01190 IF NOT DEFAULT_LENGTH
01200 THEN
01210 IF (L.CVAL.IVAL >= 0) AND (L.CVAL.IVAL <= LENGTH)
01220 THEN LENGTH := L.CVAL.IVAL
01230 ELSE ERROR(263);
01240 MACRO3(505B(*HRLI*),A.REG,-LENGTH);
01250 IF (ZSTART DIV PACKFACTOR) <> 0
01260 THEN
01270 MACRO3(271B(*ADDI*),Z.REG,ZSTART DIV PACKFACTOR);
01280 MACRO3R(200B(*MOVE*),REGC+1,Z.TYPTR^.ARRAYBPADDR+(ZSTART MOD PACKFACTOR))
01290 END
01300 ELSE ERROR(263)
01310 END
01320 ELSE ERROR(263)
01330 END
01340 ELSE (* KIND <> CST *)
01350 BEGIN
01360 ADJUST(I,AMIN);
01370 MACRO3(270B(*ADD*),A.REG,I.REG);
01380 ADJUST(J,ZMIN);
01390 IF RUNTIME_CHECK OR DEFAULT_LENGTH
01400 THEN
01410 BEGIN
01420 MACRO3(275B(*SUBI*),I.REG,AMAX);
01430 MACRO3(200B(*MOVE*),REGC+1,J.REG);
01440 MACRO3(275B(*SUBI*),REGC+1,ZMAX);
01450 MACRO3(315B(*CAMGE*),I.REG,REGC+1);
01460 MACRO3(200B(*MOVE*),I.REG,REGC+1);
01470 IF RUNTIME_CHECK
01480 THEN
01490 BEGIN
01500 MACRO2(303B(*CAILE*),I.REG);
01510 SUPPORT(INDEXERROR)
01520 END;
01530 IF DEFAULT_LENGTH
01540 THEN MACRO4(505B(*HRLI*),A.REG,I.REG,-1)
01550 END;
01560
01570 IF NOT DEFAULT_LENGTH
01580 THEN
01590 IF RUNTIME_CHECK OR (L.KIND <> CST)
01600 THEN
01610 BEGIN
01620 GENERATE_CODE(210B(*MOVN*),REGC+1,L);
01630 IF RUNTIME_CHECK
01640 THEN
01650 BEGIN
01660 MACRO2(307B(*CAIG*),L.REG);
01670 MACRO3(315B(*CAMGE*),L.REG,I.REG);
01680 SUPPORT(INDEXERROR)
01690 END;
01700 MACRO3(504B(*HRL*),A.REG,L.REG)
01710 END
01720 ELSE MACRO3(505B(*HRLI*),A.REG,-L.CVAL.IVAL);
01730 MACRO3(231B(*IDIVI*),J.REG,PACKFACTOR);
01740 MACRO3(270B(*ADD*),Z.REG,J.REG);
01750 MACRO4R(200B(*MOVE*),REGC+1,J.REG+1,Z.TYPTR^.ARRAYBPADDR)
01760 END;
01770
01780 IF LKEY = 12
01790 THEN
01800 BEGIN
01810 MACRO4(200B(*MOVE*),REG0,A.REG,ASTART);
01820 MACRO3(136B(*IDPB*),REG0,REGC+1)
01830 END
01840 ELSE
01850 BEGIN
01860 MACRO3(134B(*ILDB*),REG0,REGC+1);
01870 MACRO4(202B(*MOVEM*),REG0,A.REG,ASTART)
01880 END;
01890
01900 MACRO3R(253B(*AOBJN*),A.REG,IC-2)
01910
01920 END (* IF NOT ERROR_FLAG *)
01930
01940 END (* PACKUNPACK *);
01950
01960 PROCEDURE NEWDISPOSE;
01970
01980 (* "NEW" ALLOCATES STORAGE FOR A DYNAMIC VARIABLE
01990 (F.E. A RECORD VARIANT) IN THE HEAP.
02000 "DISPOSE" DE-ALLOCATES THE STORAGE OCCUPIED BY
02010 SUCH A VARIABLE AND IN THIS IMPLEMENTATION IT
02020 DE-ALLOCATES THE STORAGE OF ALL VARIABLES ALLOCATED
02030 LATER THAN THE SPECIFIED ONE TOO.
02040 THIS IS DUE TO THE STACK-LIKE HEAP MANAGEMENT
02050 WITH ONLY "NEWREG" POINTING TO THE LAST ALLOCATED
02060 WORD OF CORE*)
02070
02080
02090 LABEL
02100 777;
02110
02120 VAR
02130 LSP,LSP1: STP; VARTS,LMIN,LMAX: INTEGER;
02140 LNLK : NLK;
02150 LENGTHREG: ACRANGE;
02160 LSIZE,LSZ: ADDRRANGE; LVAL: VALU;
02170 LATTRC, LATTR: ATTR; I,TAGFC: INTEGER;
02180 TAGFSAV: ARRAY[0..TAGFMAX] OF RECORD
02190 TAGFVAL: INTEGER;
02200 TAGTYPE: TAGFWITHID..TAGFWITHOUTID;
02210 CASE TPACKKIND: PACKKIND OF
02220 NOTPACK,
02230 HWORDL,
02240 HWORDR: (TAGFADDR: ADDRRANGE);
02250 PACKK: (TAGFBYTE: BPOINTER)
02260 END;
02270 BEGIN
02280 INCREMENT_REGC; VARIABLE(FSYS + [COMMA,COLON]);
02290
02300 IF LKEY = 24 (*DISPOSE*)
02310 THEN
02320 BEGIN
02330 GENERATE_CODE(200B(*MOVE*),REG0,GATTR);
02340 LENGTHREG := REG1
02350 END
02360 ELSE LENGTHREG := REGIN + 1;
02370
02380 LSP := NIL; VARTS := 0; LSIZE := 0; TAGFC := -1;
02390 LATTR := GATTR;
02400 IF GATTR.TYPTR <> NIL
02410 THEN WITH GATTR.TYPTR^ DO
02420 IF FORM = POINTER
02430 THEN
02440 BEGIN
02450 IF ELTYPE <> NIL
02460 THEN
02470 BEGIN
02480 LSIZE := ELTYPE^.SIZE;
02490 IF ELTYPE^.FORM = RECORDS
02500 THEN LSP := ELTYPE^.RECVAR
02510 ELSE
02520 IF ELTYPE^.FORM = ARRAYS
02530 THEN LSP := ELTYPE
02540 END
02550 END
02560 ELSE ERROR(458);
02570
02580 WHILE SY = COMMA DO
02590 BEGIN
02600 INSYMBOL; CONSTANT(FSYS + [COMMA,COLON],LSP1,LVAL);
02610 VARTS := VARTS + 1;
02620 IF LSP <> NIL
02630 THEN
02640 IF NOT (STRING(LSP) OR (LSP1 = REALPTR))
02650 THEN
02660 BEGIN
02670 TAGFC := TAGFC + 1;
02680 IF TAGFC <= TAGFMAX
02690 THEN
02700 IF LSP^.FORM = TAGFWITHID
02710 THEN
02720 BEGIN
02730 IF LSP^.TAGFIELDP <> NIL
02740 THEN
02750 IF COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP1)
02760 THEN
02770 WITH TAGFSAV[TAGFC], LSP^.TAGFIELDP^ DO
02780 BEGIN
02790 TAGFVAL := LVAL.IVAL;
02800 TAGTYPE := TAGFWITHID; TPACKKIND := PACKF;
02810 IF TPACKKIND = PACKK
02820 THEN TAGFBYTE := FLDBYTE
02830 ELSE TAGFADDR := FLDADDR
02840 END
02850 ELSE ERROR(458)
02860 END
02870 ELSE
02880 IF LSP^.FORM = TAGFWITHOUTID
02890 THEN
02900 IF COMPTYPES(LSP^.TAGFIELDTYPE,LSP1)
02910 THEN TAGFSAV[TAGFC].TAGTYPE := TAGFWITHOUTID
02920 ELSE ERROR(458)
02930 ELSE ERROR(358)
02940 ELSE
02950 BEGIN
02960 ERROR(409); TAGFC := TAGFMAX
02970 END;
02980 LSP1 := LSP^.FSTVAR;
02990 WHILE LSP1 <> NIL DO
03000 WITH LSP1^ DO
03010 IF VARVAL.IVAL = LVAL.IVAL
03020 THEN
03030 BEGIN
03040 LSIZE := SIZE; LSP := SUBVAR; GOTO 777
03050 END
03060 ELSE LSP1 := NXTVAR;
03070 LSIZE := LSP^.SIZE; LSP := NIL;
03080 777:
03090 END
03100 ELSE ERROR(460)
03110 ELSE ERROR(408)
03120 END (*WHILE*) ;
03130
03140 IF SY = COLON
03150 THEN
03160 BEGIN
03170 INSYMBOL;
03180 EXPRESSION(FSYS,ONREGC);
03190 IF LSP = NIL
03200 THEN ERROR(408)
03210 ELSE
03220 IF LSP^.FORM <> ARRAYS
03230 THEN ERROR(259)
03240 ELSE
03250 BEGIN
03260 IF NOT COMPTYPES(GATTR.TYPTR,LSP^.INXTYPE)
03270 THEN ERROR(458);
03280 LSZ := 1; LMIN := 1;
03290 IF LSP^.INXTYPE <> NIL
03300 THEN GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX);
03310 IF LSP^.AELTYPE <> NIL
03320 THEN LSZ := LSP^.AELTYPE^.SIZE;
03330 LOAD(GATTR);
03340 IF LSZ <> 1
03350 THEN MACRO3(221B(*IMULI*),REGC,LSZ);
03360 IF LSP^.ARRAYPF
03370 THEN
03380 BEGIN
03390 MACRO3(271B(*ADDI*),REGC,LSP^.AELTYPE^.BITSIZE-1);
03400 INCREMENT_REGC; REGC := REGC - 1;
03410 (*FOR TESTING BECAUSE IDIV WORKS ON AC+1 TOO*)
03420 MACRO3(231B(*IDIVI*),REGC,BITMAX DIV LSP^.AELTYPE^.BITSIZE);
03430 LSZ := LSIZE - LSP^.SIZE + 1
03440 END
03450 ELSE LSZ := LSIZE - LSP^.SIZE - LSZ*(LMIN - 1);
03460 MACRO4(551B(*HRRZI*),LENGTHREG,REGC,LSZ)
03470 END
03480 END
03490 ELSE MACRO3(551B(*HRRZI*),LENGTHREG,LSIZE);
03500
03510 IF LKEY = 14
03520 THEN
03530 BEGIN
03540 IF DEBUG_SWITCH
03550 THEN
03560 BEGIN
03570 MACRO3(540B(* HRR *),REG0,NEWREG);
03580 IF LATTR.TYPTR <> NIL
03590 THEN
03600 IF LATTR.TYPTR^.ELTYPE <> NIL
03610 THEN
03620 BEGIN
03630 MACRO3R(505B(* HRLI *), REG0,0);
03640 CODE_REFERENCE^[CIX] := DEBUGREF;
03650 NEW(LNLK);
03660 WITH LNLK^ DO
03670 BEGIN
03680 REFADR := IC - 1;
03690 REFTYPE := LATTR.TYPTR^.ELTYPE;
03700 NEXT := GLOBNEWLINK;
03710 GLOBNEWLINK := LNLK;
03720 END;
03730 END
03740 END;
03750 SUPPORT(ALLOCATE);
03760 IF DEBUG_SWITCH
03770 THEN
03780 BEGIN
03790 MACRO3(360B(*SOJ*),NEWREG,0);
03800 MACRO4(202B(*MOVEM*),REG0,NEWREG,0)
03810 END;
03820
03830 REGC := REGIN+1;
03840 FOR I := 0 TO TAGFC DO
03850 WITH TAGFSAV[I] DO
03860 BEGIN
03870 IF TAGTYPE = TAGFWITHID
03880 THEN
03890 BEGIN
03900 MACRO3(551B(*HRRZI*),REG0,TAGFVAL);
03910 CASE TPACKKIND OF
03920 NOTPACK:
03930 MACRO4(202B(*MOVEM*),REG0,REGC,TAGFADDR);
03940 HWORDR:
03950 MACRO4(542B(*HRRM*),REG0,REGC,TAGFADDR);
03960 HWORDL:
03970 MACRO4(506B(*HRLM*),REG0,REGC,TAGFADDR);
03980 PACKK :
03990 BEGIN
04000 WITH LATTRC, CVAL, BYTE DO
04010 BEGIN
04020 KIND := CST;
04030 CVAL.BYTE := TAGFBYTE;
04040 IREG := REGC
04050 END;
04060 MACRO2(137B(*DPB*),REG0); DEPOSIT_CONSTANT(BPTR,LATTRC)
04070 END
04080 END(*CASE*)
04090 END
04100 END;
04110 STORE(REGC,LATTR)
04120 END
04130 ELSE SUPPORT(FREE)
04140 END (*NEWDISPOSE*) ;
04150
04160 PROCEDURE FIRSTLAST;
04170
04180 (* RETURN LOWER- OR UPPERBOUND OF "STANDARD SCALARS",
04190 "DECLARED SCALARS" AND THEIR "SUBRANGES"*)
04200
04210 VAR
04220 LMIN, LMAX: INTEGER;
04230
04240 BEGIN
04250 VARIABLE(FSYS + [RPARENT]);
04260 IF GATTR.TYPTR <> NIL
04270 THEN
04280 WITH GATTR DO
04290 IF NOT COMPTYPES(REALPTR,TYPTR)
04300 THEN
04310 BEGIN
04320 GETBOUNDS(TYPTR,LMIN,LMAX);
04330 KIND := CST;
04340 IF LKEY = 21
04350 THEN CVAL.IVAL := LMIN
04360 ELSE CVAL.IVAL := LMAX;
04370 IF TYPTR^.FORM = SUBRANGE
04380 THEN TYPTR := TYPTR^.RANGETYPE
04390 END
04400 ELSE ERROR(459)
04410 END;
04420
04430 PROCEDURE LOWERUPPERBOUND;
04440
04450 (* RETURN LOWER- OR UPPERBOUND OF
04460 ARRAY INDEX TYPE*)
04470
04480 VAR
04490 LMIN, LMAX: INTEGER;
04500
04510 BEGIN
04520 VARIABLE(FSYS + [RPARENT]);
04530 IF GATTR.TYPTR <> NIL
04540 THEN
04550 WITH GATTR DO
04560 IF (TYPTR^.FORM = ARRAYS) AND (TYPTR^.INXTYPE <> NIL)
04570 THEN
04580 BEGIN
04590 GETBOUNDS(TYPTR^.INXTYPE,LMIN,LMAX);
04600 KIND := CST;
04610 IF LKEY = 15
04620 THEN CVAL.IVAL := LMIN
04630 ELSE CVAL.IVAL := LMAX;
04640 IF TYPTR^.INXTYPE^.FORM = SUBRANGE
04650 THEN TYPTR := TYPTR^.INXTYPE^.RANGETYPE
04660 ELSE TYPTR := TYPTR^.INXTYPE
04670 END
04680 ELSE ERROR(459)
04690 END;
04700
04710 PROCEDURE MINMAX;
04720
04730 (* THIS PROCEDURE GENERATES CODE FOR THE MIN/MAX FUNCTION.
04740 THE MAXIMUM NUMBER OF SCALAR-TYPE EXPRESSIONS -EXCEPT REAL-
04750 IS 72 *)
04760
04770 CONST
04780 TOPP_OFFSET = 2;
04790 MAX_EXPR = 72;
04800 VAR
04810 I, J: INTEGER;
04820 LREGC: ACRANGE;
04830 INSERT_SIZE: CODERANGE;
04840 LINSTR: INSTRANGE;
04850 FIRST_EXPRESSION, CONVERSION: BOOLEAN;
04860 SELECTOR: SCALARFORM;
04870 ARGUMENT: PACKED ARRAY[1..MAX_EXPR] OF SCALARFORM;
04880
04890 BEGIN
04900 FIRST_EXPRESSION := TRUE;
04910 CONVERSION := FALSE;
04920 I := 1;
04930 LREGC := REGC;
04940 MACRO4(307B(*CAIG*),NEWREG,TOPP,0); INSERT_SIZE := CIX;
04950 SUPPORT(STACKOVERFLOW);
04960 LOOP
04970 EXPRESSION(FSYS + [COMMA,RPARENT], ONFIXEDREGC);
04980 IF GATTR.TYPTR <> NIL
04990 THEN
05000 IF GATTR.TYPTR^.FORM <> SCALAR
05010 THEN ERROR(458)
05020 ELSE
05030 WITH GATTR DO
05040 BEGIN
05050 LOAD(GATTR);
05060 IF TYPTR = INTPTR
05070 THEN ARGUMENT[I] := INTEGERFORM
05080 ELSE
05090 IF TYPTR = REALPTR
05100 THEN ARGUMENT[I] := REALFORM
05110 ELSE
05120 IF COMPTYPES(TYPTR,ASCIIPTR)
05130 THEN ARGUMENT[I] := CHARFORM
05140 ELSE
05150 IF (TYPTR^.SCALKIND = DECLARED) AND (TYPTR <> BOOLPTR)
05160 THEN ARGUMENT[I] := DECLAREDFORM
05170 ELSE ERROR(458);
05180 MACRO4(202B(*MOVEM*),REG,TOPP,TOPP_OFFSET + I);
05190 IF FIRST_EXPRESSION
05200 THEN
05210 BEGIN
05220 FIRST_EXPRESSION := FALSE; SELECTOR := ARGUMENT[I]
05230 END
05240 ELSE
05250 IF SELECTOR <> ARGUMENT[I]
05260 THEN
05270 IF [SELECTOR,ARGUMENT[I]] <= [INTEGERFORM,REALFORM]
05280 THEN
05290 BEGIN
05300 CONVERSION := TRUE; SELECTOR := REALFORM
05310 END
05320 ELSE ERROR(458)
05330 END
05340 EXIT IF SY <> COMMA;
05350 I := I + 1;
05360 IF I > MAX_EXPR
05370 THEN
05380 BEGIN
05390 ERROR(458); I := 1
05400 END;
05410 INSYMBOL;
05420 REGC := LREGC
05430 END;
05440 IF (I > 1) AND NOT ERROR_FLAG
05450 THEN
05460 BEGIN
05470 INSERT_ADDRESS(NO, INSERT_SIZE, TOPP_OFFSET + I);
05480 IF CONVERSION
05490 THEN
05500 FOR J := 1 TO I DO
05510 IF ARGUMENT[J] = INTEGERFORM
05520 THEN
05530 BEGIN
05540 MACRO4(551B(*HRRZI*),REG1,TOPP,TOPP_OFFSET + J);
05550 SUPPORT(CONVERTINTEGERTOREAL)
05560 END;
05570 INCREMENT_REGC;
05580 MACRO4(541B(*HRRI*),REGC,TOPP,TOPP_OFFSET + 2);
05590 MACRO3(505B(*HRLI*),REGC,-(I - 1));
05600 MACRO4(200B(*MOVE*),GATTR.REG,TOPP,TOPP_OFFSET + 1);
05610 IF LKEY = 20
05620 THEN LINSTR := 315B(*CAMGE*)
05630 ELSE LINSTR := 313B(*CAMLE*);
05640 MACRO4(LINSTR,GATTR.REG,REGC,0);
05650 MACRO4(200B(*MOVE*),GATTR.REG,REGC,0);
05660 MACRO3(253B(*AOBJN*),REGC,IC - 2);
05670 IF CONVERSION
05680 THEN GATTR.TYPTR := REALPTR
05690 END
05700 END;
05710
05720 PROCEDURE GETLINENR;
05730 BEGIN
05740 GETFILENAME('INPUT ',[COMMA]);
05750 LOAD(GATTR);
05760 VARIABLE(FSYS);
05770 IF COMPTYPES(GATTR.TYPTR,PACKC5PTR)
05780 THEN STORE(REGC,GATTR)
05790 ELSE ERROR(458)
05800 END;
05810
05820 PROCEDURE PAGE;
05830 BEGIN
05840 GETFILENAME('OUTPUT ',[RPARENT]);
05850 SUPPORT(PUTPAGE)
05860 END;
05870
05880 PROCEDURE DATE; (* ASSIGN DATE IN STANDARD DD-MMM-YY FORMAT TO ALFA PARAMETER *)
05890 BEGIN
05900 VARIABLE(FSYS);
05910 IF COMPTYPES(ALFAPTR,GATTR.TYPTR)
05920 THEN LOAD_ADDRESS
05930 ELSE ERROR(458);
05940 SUPPORT(ASCIIDATE)
05950 END;
05960
05970 PROCEDURE TIME; (* ASSIGN TIME IN STANDARD HH:MM:SS FORMAT TO ALFA PARAMETER *)
05980 BEGIN
05990 VARIABLE(FSYS);
06000 IF COMPTYPES(ALFAPTR,GATTR.TYPTR)
06010 THEN LOAD_ADDRESS
06020 ELSE ERROR(458);
06030 SUPPORT(ASCIITIME)
06040 END;
06050
06060 PROCEDURE CLOCK; (* RETURN THE ELAPSED CPU-TIME IN MILLISECONDS *)
06070 BEGIN
06080 WITH GATTR DO
06090 BEGIN
06100 INCREMENT_REGC; TYPTR := INTPTR; REG := REGC; KIND := EXPR;
06110 MACRO3(047B,REGC,30B(*PJOB-UUO*));
06120 MACRO3(047B,REGC,27B(*RUNTIM-UUO*))
06130 END
06140 END;
06150
06160 PROCEDURE CARD; (* RETURN THE CARDINAL NUMBER OF A SET *)
06170 VAR
06180 LOOP_AROUND: ADDRRANGE;
06190
06200 BEGIN
06210 WITH GATTR DO
06220 BEGIN
06230 IF TYPTR <> NIL
06240 THEN
06250 IF TYPTR^.FORM <> POWER
06260 THEN ERROR(459)
06270 ELSE
06280 BEGIN
06290 INCREMENT_REGC; INCREMENT_REGC;
06300 MACRO3(551B(*HRRZI*),REGC,72);
06310 MACRO2(400B(*SETZ*),REGC-1);
06320 LOOP_AROUND := IC;
06330 MACRO2(305B(*CAIGE*),GATTR.REG - 1);
06340 MACRO2(340B(*AOJ*),REGC-1);
06350 MACRO3(246B(*LSHC*),GATTR.REG - 1,1);
06360 MACRO3R(367B(*SOJG*),REGC,LOOP_AROUND);
06370 REGC := REGC - 1;
06380 KIND := EXPR; REG := REGC; TYPTR := INTPTR
06390 END
06400 END
06410 END;
06420
06430 PROCEDURE ABS;
06440 BEGIN
06450 WITH GATTR DO
06460 IF (TYPTR = INTPTR) OR (TYPTR = REALPTR)
06470 THEN
06480 IF KIND=EXPR
06490 THEN MACRO3(214B(*MOVM*),REG,REG)
06500 ELSE
06510 BEGIN
06520 INCREMENT_REGC;
06530 GENERATE_CODE(214B(*MOVM*),REGC,GATTR)
06540 END
06550 ELSE
06560 BEGIN
06570 ERROR(459); TYPTR:= INTPTR
06580 END
06590 END (*ABS*) ;
06600
06610 PROCEDURE REALTIME;
06620
06630 (* RETURN THE DAY-TIME
06640 IN MILLISECONDS *)
06650
06660 BEGIN
06670 WITH GATTR DO
06680 BEGIN
06690 INCREMENT_REGC; TYPTR := INTPTR; REG := REGC; KIND := EXPR;
06700 MACRO3(047B,REGC,23B(*MSTIME-UUO*))
06710 END
06720 END;
06730
06740 PROCEDURE SQR;
06750 BEGIN
06760 WITH GATTR DO
06770 IF TYPTR = INTPTR
06780 THEN MACRO3(220B(*IMUL*),REG,REG)
06790 ELSE
06800 IF TYPTR = REALPTR
06810 THEN MACRO3(164B(*FMPR*),REG,REG)
06820 ELSE
06830 BEGIN
06840 ERROR(459); TYPTR := INTPTR
06850 END
06860 END (*SQR*) ;
06870
06880 PROCEDURE ODD;
06890 BEGIN
06900 WITH GATTR DO
06910 BEGIN
06920 IF TYPTR <> INTPTR
06930 THEN ERROR(459);
06940 MACRO3(405B(*ANDI*),REG,1);
06950 TYPTR := BOOLPTR
06960 END
06970 END (*ODD*) ;
06980
06990 PROCEDURE ORD;
07000 BEGIN
07010 IF GATTR.TYPTR <> NIL
07020 THEN
07030 IF GATTR.TYPTR^.FORM >= POWER
07040 THEN ERROR(459);
07050 GATTR.TYPTR := INTPTR
07060 END (*ORD*) ;
07070
07080 PROCEDURE CHR;
07090 BEGIN
07100 IF GATTR.TYPTR <> INTPTR
07110 THEN ERROR(459);
07120 GATTR.TYPTR := CHARPTR
07130 END (*CHR*) ;
07140
07150 PROCEDURE PREDSUCC;
07160 VAR
07170 LSP:STP;
07180 PMIN,PMAX: INTEGER;
07190 BEGIN
07200 IF GATTR.TYPTR <> NIL
07210 THEN
07220 IF (GATTR.TYPTR^.FORM>SUBRANGE) OR (GATTR.TYPTR=REALPTR)
07230 THEN ERROR(459)
07240 ELSE
07250 BEGIN
07260 LSP := GATTR.TYPTR;
07270 IF (LSP^.FORM = SUBRANGE)
07280 THEN LSP := LSP^.RANGETYPE;
07290 IF RUNTIME_CHECK AND (LSP <> INTPTR)
07300 THEN
07310 BEGIN
07320 IF LKEY=8
07330 THEN MACRO3R(365B(*SOJGE*),REGC,IC+2)
07340 ELSE
07350 BEGIN
07360 MACRO2(340B(*AOJ*),REGC);
07370 GETBOUNDS(LSP,PMIN,PMAX);
07380 MACRO3(303B(*CAILE*),REGC,PMAX)
07390 END;
07400 SUPPORT(ERRORINASSIGNMENT)
07410 END (* RUNTIME_CHECK *)
07420 ELSE
07430 IF LKEY = 8
07440 THEN MACRO2(360B(*SOJ*),REGC)
07450 ELSE MACRO2(340B(*AOJ*),REGC)
07460 END
07470 END (*PREDSUCC*) ;
07480
07490 PROCEDURE EOFEOLN;
07500 BEGIN
07510 GETFILENAME('INPUT ',[RPARENT]);
07520 WITH GATTR DO
07530 BEGIN
07540 IF LKEY=10
07550 THEN
07560 BEGIN
07570 INCREMENT_REGC; GENERATE_CODE(332B(*SKIPE*),REGC,GATTR);
07580 MACRO3(551B(*HRRZI*),REGC,1)
07590 END;
07600 TYPTR := BOOLPTR
07610 END
07620 END (*EOFEOLN*) ;
07630
07640 PROCEDURE PROTECTION;
07650
07660 (* THIS PROCEDURE IS USED BY "PASDDT" TO TEST
07670 IF A PROGRAM'S HIGH-SEGMENT IS SHARED
07680 (WRITE-PROTECTED). PROGRAMS WHICH ARE
07690 TO BE "DEBUGGED" MUST NOT BE SHARABLE.
07700 FOR DETAILS SEE DECSYSTEM-10 "MONITOR-CALLS"
07710 MANUAL, 3.2.4 *)
07720
07730 BEGIN
07740 EXPRESSION(FSYS, ONREGC);
07750 IF GATTR.TYPTR = BOOLPTR
07760 THEN
07770 BEGIN
07780 LOAD(GATTR);
07790 MACRO3(047B,GATTR.REG,36B(*SETUWP-UUO*));
07800 MACRO3(254B(*HALT*),4,0)
07810 END
07820 ELSE ERROR(458)
07830 END;
07840
07850 PROCEDURE CALL;
07860
07870 (* THE STANDARD PROCEDURE
07880 CALL(<FILENAME>[,<DEVICE>[,<PROJECT-PROGRAMMER>[,<CORE-ASSIGNMENT]]])
07890 ALLOWS TO EXIT FROM ONE PROGRAM AND EXECUTE ANOTHER *)
07900
07910 VAR
07920 I:INTEGER;
07930 DEFAULT:ARRAY[2..4] OF BOOLEAN;
07940
07950 PROCEDURE GETSTRINGADDRESS(FLENGTH: INTEGER);
07960 BEGIN
07970 EXPRESSION(FSYS + [COMMA],ONFIXEDREGC);
07980 WITH GATTR DO
07990 IF STRING(TYPTR)
08000 THEN
08010 WITH TYPTR^ DO
08020 IF ARRAYPF AND (SIZE = 2) AND ((INXTYPE^.VMAX.IVAL-INXTYPE^.VMIN.IVAL+1) = FLENGTH)
08030 THEN LOAD_ADDRESS
08040 ELSE ERROR(458)
08050 ELSE ERROR(458)
08060 END;
08070
08080 BEGIN (* CALL *)
08090 IF NOT EXTERNAL
08100 THEN
08110 BEGIN
08120 CLOSE_FILES;
08130 GETSTRINGADDRESS(9);
08140 FOR I := 2 TO 4 DO DEFAULT[I] := TRUE;
08150 IF SY = COMMA
08160 THEN
08170 BEGIN
08180 INSYMBOL; GETSTRINGADDRESS(6); DEFAULT[2] := FALSE;
08190 IF SY = COMMA
08200 THEN
08210 BEGIN
08220 INSYMBOL; EXPRESSION(FSYS + [COMMA],ONFIXEDREGC);
08230 IF GATTR.TYPTR = INTPTR
08240 THEN
08250 BEGIN
08260 DEFAULT[3] := FALSE; LOAD(GATTR)
08270 END
08280 ELSE ERROR(458);
08290 IF SY = COMMA
08300 THEN
08310 BEGIN
08320 INSYMBOL; EXPRESSION(FSYS,ONFIXEDREGC);
08330 IF GATTR.TYPTR = INTPTR
08340 THEN
08350 BEGIN
08360 DEFAULT[4] := FALSE; LOAD(GATTR)
08370 END
08380 ELSE ERROR(458)
08390 END
08400 END
08410 END;
08420
08430 FOR I := 2 TO 4 DO
08440 IF DEFAULT[I]
08450 THEN
08460 BEGIN
08470 INCREMENT_REGC; MACRO2(400B(*SETZ*),REGC)
08480 END;
08490
08500 SUPPORT(RUNPROGRAM)
08510
08520 END
08530 ELSE ERROR(353)
08540 END (* CALL *);
08550
08560 PROCEDURE HALT;
08570
08580 (* THIS PROCEDURE CALLS "PASDDT"
08590 IF IT IS LOADED, OTHERWISE IT
08600 EXECUTES A "HALT" INSTRUCTION *)
08610
08620 BEGIN
08630 MACRO3(332B(*SKIPE*),REG1,JBDDT);
08640 MACRO4(265B(*JSP*),REG0,REG1,-2);
08650 MACRO2(254B(*HALT*),4)
08660 END;
08670
08680
08690
08700 PROCEDURE CALL_NON_STANDARD;
08710 VAR
08720 NXT,LNXT,LCP,LCP1: CTP;
08730 LSP: STP;
08740 LKIND: IDKIND; PASCALCALL:BOOLEAN;
08750 SAVE_COUNT,P,I,NUMBER_OF_PARAMETERS: INTEGER;
08760 TOPP_OFFSET,OFFSET,START_OF_PARAMETERLIST,ACTUAL_PARAMETER,FIRST_PARAMETER,LLC: ADDRRANGE;
08770 LREGC: ACRANGE;
08780
08790 FUNCTION COMPPARAM(FCP1,FCP2 : CTP):BOOLEAN;
08800
08810 VAR
08820 OK:BOOLEAN;
08830
08840 BEGIN (*COMPPARAM*)
08850 OK:=TRUE;
08860 WHILE OK AND (FCP1<>NIL) AND (FCP2<>NIL) DO WITH FCP1^ DO
08870 BEGIN
08880 IF COMPTYPES(IDTYPE,FCP2^.IDTYPE)
08890 THEN
08900 IF KLASS=FCP2^.KLASS
08910 THEN
08920 IF KLASS=VARS
08930 THEN
08940 BEGIN
08950 IF VKIND<>FCP2^.VKIND
08960 THEN
08970 BEGIN
08980 ERROR(370); OK:=FALSE
08990 END
09000 END
09010 ELSE OK:=COMPPARAM(FPARAM,FCP2^.FPARAM)
09020 ELSE
09030 BEGIN
09040 ERROR(370); OK:=FALSE
09050 END
09060 ELSE
09070 BEGIN
09080 ERROR(370); OK:=FALSE
09090 END;
09100 FCP1:=NEXT; FCP2:=FCP2^.NEXT
09110 END;
09120 IF FCP1<>FCP2
09130 THEN
09140 BEGIN
09150 ERROR(554); COMPPARAM:=FALSE
09160 END
09170 ELSE COMPPARAM:=OK
09180 END(*COMPPARAM*);
09190
09200 BEGIN
09210 NUMBER_OF_PARAMETERS:= 0; TOPP_OFFSET := 0; START_OF_PARAMETERLIST := 0; ACTUAL_PARAMETER := 0;
09220 WITH FCP^ DO
09230 BEGIN
09240 LKIND := PFKIND;
09250 IF LKIND=ACTUAL
09260 THEN
09270 BEGIN
09280 NXT:=NEXT;
09290 IF EXTERNDECL
09300 THEN LIBRARY[LANGUAGE].CALLED:=TRUE;
09310 PASCALCALL:=LANGUAGE=PASCALSY
09320 END
09330 ELSE
09340 BEGIN
09350 NXT:=FPARAM;
09360 PASCALCALL:=TRUE
09370 END;
09380 LNXT:=NXT;
09390 IF KLASS = FUNC
09400 THEN FIRST_PARAMETER := 2
09410 ELSE FIRST_PARAMETER := 1;
09420 SAVE_COUNT := REGC - REGIN;
09430 IF SAVE_COUNT > 0
09440 THEN
09450 BEGIN
09460 LLC := LC ;
09470 LC := LC + SAVE_COUNT ;
09480 IF LC > LCMAX
09490 THEN LCMAX := LC ;
09500 IF SAVE_COUNT > 3
09510 THEN
09520 BEGIN
09530 MACRO3(515B(*HRLZI*),REG1,2);
09540 MACRO4(541B(*HRRI*),REG1,BASIS,LLC);
09550 MACRO4(251B(*BLT*),REG1,BASIS,LLC+SAVE_COUNT-1)
09560 END
09570 ELSE FOR I := 1 TO SAVE_COUNT DO MACRO4(202B(*MOVEM*),REGIN+I,BASIS,LLC+I-1)
09580 END;
09590 LREGC:= REGC;
09600 IF LKIND=ACTUAL
09610 THEN
09620 IF LANGUAGE <> PASCALSY
09630 THEN REGC:= HIGHEST_REGISTER
09640 ELSE REGC:= REGIN
09650 ELSE REGC:=REGIN
09660 END;
09670
09680 IF SY = LPARENT
09690 THEN
09700 BEGIN
09710 REPEAT
09720 INSYMBOL;
09730 IF NXT=NIL
09740 THEN ERROR(554)
09750 ELSE
09760 IF NXT^.KLASS IN [PROC,FUNC]
09770 THEN
09780 IF SY<>IDENT
09790 THEN ERROR(209)
09800 ELSE
09810 BEGIN
09820 SEARCHID([PROC,FUNC],LCP);
09830 INSYMBOL;
09840 WITH LCP^ DO
09850 IF PFDECKIND=STANDARD
09860 THEN ERROR(510)
09870 ELSE
09880 BEGIN
09890 IF PFKIND=ACTUAL
09900 THEN LCP1:=NEXT
09910 ELSE LCP1:=FPARAM;
09920 IF COMPPARAM(NXT^.FPARAM,LCP1)
09930 THEN
09940 IF NXT^.KLASS<>KLASS
09950 THEN ERROR(503)
09960 ELSE
09970 IF NOT COMPTYPES(IDTYPE,NXT^.IDTYPE)
09980 THEN ERROR(555)
09990 ELSE
10000 BEGIN
10010 INCREMENT_REGC;
10020 P:=LEVEL-PFLEV;
10030 IF PFKIND=ACTUAL
10040 THEN
10050 IF LANGUAGE<>PASCALSY
10060 THEN ERROR(510)
10070 ELSE
10080 BEGIN
10090 IF P=0
10100 THEN MACRO3(514B(*HRLZ*),REGC,BASIS)
10110 ELSE
10120 IF P=1
10130 THEN MACRO4(514B(*HRLZ*),REGC,BASIS,-1)
10140 ELSE
10150 IF P>1
10160 THEN
10170 BEGIN
10180 MACRO4(550B(*HRRZ*),REGC,BASIS,-1);
10190 FOR I:=3 TO P DO MACRO4(550B(*HRRZ*),REGC,REGC,-1);
10200 MACRO4(514B(*HRLZ*),REGC,REGC,-1)
10210 END;
10220 IF PFADDR=0
10230 THEN
10240 BEGIN
10250 MACRO3(541B(*HRRI*),REGC,LINKCHAIN[P]);
10260 LINKCHAIN[P]:=IC-1;
10270 IF EXTERNDECL
10280 THEN CODE_REFERENCE^[CIX]:=EXTERNREF
10290 ELSE
10300 CODE_REFERENCE^[CIX]:=FORWARDREF
10310 END
10320 ELSE MACRO3R(541B(*HRRI*),REGC,PFADDR)
10330 END
10340 ELSE
10350 BEGIN
10360 IF P=0
10370 THEN MACRO4(200B(*MOVE*),REGC,BASIS,PFADDR)
10380 ELSE
10390 BEGIN
10400 MACRO4(200B(*MOVE*),REGC,BASIS,-1);
10410 FOR I:=2 TO P DO MACRO4(200B(*MOVE*),REGC,REGC,-1);
10420 MACRO4(200B(*MOVE*),REGC,REGC,PFADDR)
10430 END
10440 END
10450 END
10460 END
10470 END
10480 ELSE (* NXT^.KLASS = VARS *)
10490 BEGIN
10500 EXPRESSION(FSYS + [COMMA,RPARENT],ONFIXEDREGC);
10510 IF GATTR.TYPTR <> NIL
10520 THEN
10530 IF NXT <> NIL
10540 THEN
10550 BEGIN
10560 LSP := NXT^.IDTYPE;
10570 IF LSP <> NIL
10580 THEN
10590 IF NXT^.VKIND = ACTUAL
10600 THEN
10610 IF LSP^.SIZE <= 2
10620 THEN
10630 BEGIN
10640 LOAD(GATTR);
10650 IF COMPTYPES(REALPTR,LSP)
10660 THEN MAKEREAL(GATTR)
10670 END
10680 ELSE
10690 BEGIN
10700 IF LSP^.FORM = FILES
10710 THEN
10720 IF LAST_FILE <> NIL
10730 THEN
10740 IF LAST_FILE^.NAME = 'TTY '
10750 THEN TTYREAD := TRUE;
10760 LOAD_ADDRESS;
10770 IF FCP^.LANGUAGE <> PASCALSY
10780 THEN CODE_ARRAY^.INSTRUCTION[CIX].INSTR := 515B(*HRLZI*)
10790 END
10800 ELSE
10810 WITH GATTR DO
10820 IF KIND = VARBL
10830 THEN LOAD_ADDRESS
10840 ELSE ERROR(463);
10850 IF NOT COMPTYPES(LSP,GATTR.TYPTR)
10860 THEN ERROR(503)
10870 END
10880 END;
10890 IF REGC > FCP^.HIGHEST_REGISTER
10900 THEN
10910 BEGIN
10920 IF TOPP_OFFSET = 0
10930 THEN
10940 BEGIN
10950 IF FCP^.PFKIND=FORMAL
10960 THEN TOPP_OFFSET:=FCP^.PARLISTSIZE+1
10970 ELSE
10980 IF FCP^.LANGUAGE = PASCALSY
10990 THEN TOPP_OFFSET:=FCP^.PARLISTSIZE+1
11000 ELSE
11010 BEGIN
11020 TOPP_OFFSET := 1 + FIRST_PARAMETER;
11030 REPEAT
11040 WITH LNXT^ DO
11050 BEGIN
11060 NUMBER_OF_PARAMETERS := NUMBER_OF_PARAMETERS +1;
11070 TOPP_OFFSET := TOPP_OFFSET + 1;
11080 IF VKIND = ACTUAL
11090 THEN
11100 IF IDTYPE<>NIL
11110 THEN
11120 TOPP_OFFSET := TOPP_OFFSET + IDTYPE^.SIZE;
11130 LNXT := NEXT
11140 END;
11150 UNTIL LNXT = NIL;
11160 START_OF_PARAMETERLIST := 1 + FIRST_PARAMETER;
11170 ACTUAL_PARAMETER := START_OF_PARAMETERLIST + NUMBER_OF_PARAMETERS
11180 END;
11190 MACRO3(271B(*ADDI*),TOPP,TOPP_OFFSET)
11200 END ;
11210 WITH NXT^ DO
11220 BEGIN
11230 IF PASCALCALL
11240 THEN
11250 BEGIN
11260 IF KLASS<>VARS
11270 THEN MACRO4(202B(*MOVEM*),REGC,TOPP,PFADDR+1-TOPP_OFFSET)
11280 ELSE
11290 IF (IDTYPE^.SIZE <> 2) OR (VKIND = FORMAL)
11300 THEN MACRO4(202B(*MOVEM*),REGC,TOPP,VADDR+1-TOPP_OFFSET)
11310 ELSE
11320 BEGIN
11330 MACRO4(202B(*MOVEM*),REGC,TOPP,VADDR+2-TOPP_OFFSET);
11340 IF REGC>FCP^.HIGHEST_REGISTER+1
11350 THEN
11360 MACRO4(202B(*MOVEM*),REGC-1,TOPP,VADDR+1-TOPP_OFFSET)
11370 END
11380 END
11390 ELSE
11400 BEGIN
11410 IF KLASS<>VARS
11420 THEN ERROR(468)
11430 ELSE
11440 IF VKIND = ACTUAL
11450 THEN
11460 IF IDTYPE<>NIL
11470 THEN
11480 BEGIN
11490 IF IDTYPE^.SIZE <= 2
11500 THEN
11510 BEGIN
11520 IF IDTYPE^.SIZE = 2
11530 THEN
11540 BEGIN
11550 MACRO4(202B(*MOVEM*),REGC,TOPP,ACTUAL_PARAMETER+1-TOPP_OFFSET);
11560 REGC := REGC - 1
11570 END;
11580 MACRO4(202B(*MOVEM*),REGC,TOPP,ACTUAL_PARAMETER-TOPP_OFFSET);
11590 MACRO4(541B(*HRRI*),REGC,TOPP,ACTUAL_PARAMETER-TOPP_OFFSET)
11600 END
11610 ELSE
11620 BEGIN
11630 MACRO4(541B(*HRRI*),REGC,TOPP,ACTUAL_PARAMETER-TOPP_OFFSET);
11640 MACRO4(251B(*BLT*),REGC,TOPP,ACTUAL_PARAMETER+IDTYPE^.SIZE-1-TOPP_OFFSET)
11650 END;
11660 ACTUAL_PARAMETER := ACTUAL_PARAMETER + IDTYPE^.SIZE
11670 END;
11680 MACRO4(552B(*HRRZM*),REGC,TOPP,START_OF_PARAMETERLIST-TOPP_OFFSET);
11690 START_OF_PARAMETERLIST := START_OF_PARAMETERLIST + 1
11700 END;
11710 REGC := FCP^.HIGHEST_REGISTER
11720 END
11730 END; (*REGC>FCP^.HIGHEST_REGISTER*)
11740 IF NXT <> NIL
11750 THEN NXT := NXT^.NEXT;
11760 SKIPIFERR([COMMA,RPARENT],256,FSYS)
11770 UNTIL SY <> COMMA;
11780 IF SY = RPARENT
11790 THEN INSYMBOL
11800 ELSE ERROR(152)
11810 END (*IF LPARENT*);
11820
11830
11840 IF NXT<>NIL
11850 THEN ERROR(554);
11860 FOR I := 0 TO WITHIX DO
11870 WITH DISPLAY[TOP-I] DO
11880 IF (CINDR<>0) AND (CINDR<>BASIS)
11890 THEN MACRO4(202B(*MOVEM*),CINDR,BASIS,CLC);
11900 WITH FCP^ DO
11910 BEGIN
11920 IF LKIND=FORMAL
11930 THEN
11940 BEGIN
11950 IF TOPP_OFFSET<>0
11960 THEN MACRO3(275B(*SUBI*),TOPP,TOPP_OFFSET)
11970 END
11980 ELSE
11990 IF (LANGUAGE = PASCALSY) AND (TOPP_OFFSET <> 0)
12000 THEN MACRO3(275B(*SUBI*),TOPP,TOPP_OFFSET)
12010 ELSE
12020 IF (LANGUAGE <> PASCALSY) AND (TOPP_OFFSET = 0)
12030 THEN
12040 BEGIN
12050 TOPP_OFFSET:= FIRST_PARAMETER+2;
12060 MACRO3(271B(*ADDI*),TOPP,TOPP_OFFSET)
12070 END;
12080 IF PFLEV > 1
12090 THEN P := LEVEL - PFLEV
12100 ELSE P:= 0;
12110 IF LKIND = ACTUAL
12120 THEN
12130 BEGIN
12140 IF LANGUAGE <> PASCALSY
12150 THEN
12160 BEGIN
12170 MACRO3(515B(*HRLZI*),REG0,-NUMBER_OF_PARAMETERS);
12180 MACRO4(202B(*MOVEM*),REG0,TOPP,FIRST_PARAMETER-TOPP_OFFSET);
12190 MACRO4(202B(*MOVEM*),BASIS,TOPP,-TOPP_OFFSET);
12200 MACRO4(551B(*HRRZI*),BASIS,TOPP,FIRST_PARAMETER-TOPP_OFFSET+1);
12210 IF NUMBER_OF_PARAMETERS = 0
12220 THEN MACRO4(402B(*SETZM*),0,TOPP,FIRST_PARAMETER-TOPP_OFFSET+1)
12230 END;
12240 IF PFADDR = 0
12250 THEN
12260 BEGIN
12270 MACRO3R(260B(*PUSHJ*),TOPP,LINKCHAIN[P]); LINKCHAIN[P]:= IC-1;
12280 IF EXTERNDECL
12290 THEN CODE_REFERENCE^[CIX] := EXTERNREF
12300 ELSE CODE_REFERENCE^[CIX] := FORWARDREF
12310 END
12320 ELSE MACRO3R(260B(*PUSHJ*),TOPP,PFADDR-P);
12330 IF LANGUAGE <> PASCALSY
12340 THEN
12350 BEGIN
12360 MACRO3(275B(*SUBI*),TOPP,TOPP_OFFSET);
12370 IF KLASS = FUNC
12380 THEN
12390 BEGIN
12400 MACRO4(202B(*MOVEM*),REG0,TOPP,2);
12410 IF IDTYPE^.SIZE = 2
12420 THEN MACRO4(202B(*MOVEM*),REG1,TOPP,3)
12430 END;
12440 MACRO4(200B(*MOVE*),BASIS,TOPP,0)
12450 END;
12460 END
12470 ELSE (*LKIND=FORMAL*)
12480 BEGIN
12490 IF P=0
12500 THEN
12510 BEGIN
12520 MACRO4(550B(*HRRZ*),REG1,BASIS,PFADDR);
12530 MACRO4(544B(*HLR*),BASIS,BASIS,PFADDR)
12540 END
12550 ELSE
12560 BEGIN
12570 MACRO4(550B(*HRRZ*),REG1,BASIS,-1);
12580 FOR I:=2 TO P DO MACRO4(550B(*HRRZ*),REG1,REG1,-1);
12590 MACRO4(544B(*HLR*),BASIS,REG1,PFADDR);
12600 MACRO4(550B(*HRRZ*),REG1,REG1,PFADDR)
12610 END;
12620 MACRO4(260B(*PUSHJ*),TOPP,REG1,0)
12630 END
12640 END;
12650 FOR I := 0 TO WITHIX DO
12660 WITH DISPLAY[TOP-I] DO
12670 IF (CINDR<>0) AND (CINDR<>BASIS)
12680 THEN MACRO4(200B(*MOVE*),CINDR,BASIS,CLC) ;
12690 IF SAVE_COUNT > 0
12700 THEN
12710 BEGIN
12720 IF SAVE_COUNT > 3
12730 THEN
12740 BEGIN
12750 MACRO4(515B(*HRLZI*),REG1,BASIS,LLC);
12760 MACRO3(541B(*HRRI*),REG1,2);
12770 MACRO3(251B(*BLT*),REG1,SAVE_COUNT+1)
12780 END
12790 ELSE FOR I := 1 TO SAVE_COUNT DO MACRO4(200B(*MOVE*),REGIN+I,BASIS,LLC+I-1) ;
12800 LC := LLC
12810 END ;
12820 GATTR.TYPTR := FCP^.IDTYPE; REGC := LREGC
12830 END (*CALL_NON_STANDARD*) ;
12840
12850
12860 BEGIN
12870 (*CALL*)
12880 NOLOAD := FALSE;
12890 TTY_MESSAGE := FALSE;
12900 BUFFER_VARIABLE := FALSE;
12910 IF FCP^.PFDECKIND = STANDARD
12920 THEN
12930 BEGIN
12940 LKEY := FCP^.KEY; LCLASS := FCP^.KLASS;
12950 IF FCP^.KLASS = PROC
12960 THEN
12970 BEGIN
12980 IF NOT (LKEY IN [1..11,17,19,25..27,29])
12990 THEN
13000 IF SY = LPARENT
13010 THEN INSYMBOL
13020 ELSE ERROR(153);
13030 FSYS := FSYS + [RPARENT];
13040 IF (LKEY IN [5..8,10,11,26..29]) AND (REGCMAX <= 8) (*<--- REG2..8 USED BY RUNTIME-SUPPORT*)
13050 THEN ERROR(317);
13060 CASE LKEY OF
13070 1,2,3,4,
13080 5,6:
13090 GETPUTRESETREWRITE;
13100 7,
13110 8:
13120 BEGIN
13130 READREADLN;
13140 IF NO_RIGHT_PARENT
13150 THEN GOTO 666
13160 END;
13170 9:
13180 BEGIN
13190 BREAK ;
13200 IF NO_RIGHT_PARENT
13210 THEN GOTO 666
13220 END ;
13230 10,
13240 11:
13250 BEGIN
13260 WRITEWRITELN;
13270 IF NO_RIGHT_PARENT
13280 THEN GOTO 666
13290 END;
13300 12,
13310 13:
13320 PACKUNPACK;
13330 24,
13340 14:
13350 NEWDISPOSE;
13360 17:
13370 BEGIN
13380 NOLOAD := TRUE;
13390 GETLINENR
13400 END;
13410 19:
13420 BEGIN
13430 PAGE;
13440 IF NO_RIGHT_PARENT
13450 THEN GOTO 666
13460 END;
13470 20:
13480 PROTECTION;
13490 21:
13500 CALL;
13510 22:
13520 DATE;
13530 23:
13540 TIME;
13550 25:
13560 BEGIN
13570 HALT;
13580 GOTO 666
13590 END;
13600 28:
13610 MESSAGE;
13620 OTHERS:
13630 ERRANDSKIP(169,FSYS)
13640 END
13650 END
13660 ELSE
13670 BEGIN
13680 IF LKEY IN [2..9,13..16,19..22]
13690 THEN
13700 BEGIN
13710 IF SY = LPARENT
13720 THEN INSYMBOL
13730 ELSE ERROR(153);
13740 IF LKEY IN [2..9,13,14,18]
13750 THEN
13760 EXPRESSION(FSYS + [RPARENT,COMMA],ONREGC);
13770 IF LKEY IN [3..5,8,9,13,14,18]
13780 THEN LOAD(GATTR)
13790 END;
13800 CASE LKEY OF
13810 1:
13820 REALTIME;
13830 2:
13840 ABS;
13850 3:
13860 SQR;
13870 5:
13880 ODD;
13890 6:
13900 ORD;
13910
13920 7:
13930 CHR;
13940 8,9:
13950 PREDSUCC;
13960 10,11:
13970 BEGIN
13980 NOLOAD := TRUE;
13990 EOFEOLN;
14000 IF NO_RIGHT_PARENT
14010 THEN GOTO 666
14020 END;
14030 12:
14040 CLOCK;
14050 13:
14060 CARD;
14070 15,16:
14080 LOWERUPPERBOUND;
14090 19,20:
14100 MINMAX;
14110 21,22:
14120 FIRSTLAST;
14130 OTHERS:
14140 ERRANDSKIP(169,FSYS + [RPARENT])
14150 END;
14160 IF LKEY IN [1,12]
14170 THEN GOTO 666
14180 END;
14190 IF SY = RPARENT
14200 THEN INSYMBOL
14210 ELSE ERROR(152);
14220 666:
14230 END (*STANDARD PROCEDURES AND FUNCTIONS*)
14240 ELSE CALL_NON_STANDARD
14250 END (*CALL*) ;
14260
14270 PROCEDURE EXPRESSION;
14280 VAR
14290 JUMP_OFFSET: 2..4;
14300 DEFAULT_OFFSET: 4..5;
14310 LATTR: ATTR;
14320 LOP: OPERATOR;
14330 LSIZE: ADDRRANGE;
14340 DEFAULT,JUMP: BOOLEAN;
14350 BOOLREGC,TESTREGC,LREGC1,LREGC2:ACRANGE;
14360 LINSTR,LINSTR1: INSTRANGE;
14370 SETINCLUSION : BOOLEAN;
14380 JMPADRIFALLEQUAL : INTEGER;
14390
14400 PROCEDURE CHANGEBOOL(VAR FINSTR: INSTRANGE);
14410 BEGIN
14420 IF (FINSTR>=311B) AND (FINSTR<=313B)
14430 THEN FINSTR := FINSTR+4 (*CAML,CAME,CAMLE --> CAMGE,CAMN,CAMG*)
14440 ELSE
14450 IF (FINSTR>=315B) AND (FINSTR<=317B)
14460 THEN FINSTR := FINSTR-4 (*SAME IN THE OTHER WAY*)
14470 END;
14480
14490 PROCEDURE SEARCHCODE(FINSTR:INSTRANGE; FATTR: ATTR);
14500 PROCEDURE CHANGEOPERANDS(VAR FINSTR:INSTRANGE);
14510 BEGIN
14520 IF FINSTR=311B(*CAML*)
14530 THEN FINSTR := 317B(*CAMG*)
14540 ELSE
14550 IF FINSTR = 313B(*CAMLE*)
14560 THEN FINSTR := 315B(*CAMGE*)
14570 ELSE
14580 IF FINSTR=315B(*CAMGE*)
14590 THEN FINSTR := 313B(*CAMLE*)
14600 ELSE
14610 IF FINSTR = 317B(*CAMG*)
14620 THEN FINSTR := 311B(*CAML*)
14630 ELSE
14640 IF FINSTR = 420B(*ANDCM*)
14650 THEN FINSTR := 410B(*ANDCA*)
14660 ELSE
14670 IF FINSTR = 410B(*ANDCA*)
14680 THEN FINSTR := 420B(*ANDCM*)
14690 END;
14700
14710 BEGIN
14720 WITH GATTR DO
14730 IF FATTR.KIND = EXPR
14740 THEN
14750 BEGIN
14760 GENERATE_CODE(FINSTR,FATTR.REG,GATTR); REG := FATTR.REG
14770 END
14780 ELSE
14790 IF KIND = EXPR
14800 THEN
14810 BEGIN
14820 CHANGEOPERANDS(FINSTR); GENERATE_CODE(FINSTR,REG,FATTR)
14830 END
14840 ELSE
14850 IF (KIND=VARBL) AND ((PACKFG<>NOTPACK)
14860 OR (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND
14870 ((FATTR.INDEXR<=REGIN) OR (FATTR.INDEXR>REGCMAX)))
14880 THEN
14890 BEGIN
14900 LOAD(GATTR); CHANGEOPERANDS(FINSTR); GENERATE_CODE(FINSTR,REG,FATTR)
14910 END
14920 ELSE
14930 BEGIN
14940 LOAD(FATTR); GENERATE_CODE(FINSTR,FATTR.REG,GATTR); REG := FATTR.REG
14950 END
14960 END;
14970
14980 PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS);
14990 VAR
15000 LATTR: ATTR; LOP: OPERATOR; SIGNED : BOOLEAN;
15010
15020 PROCEDURE TERM(FSYS: SETOFSYS);
15030 VAR
15040 LATTR: ATTR; LOP: OPERATOR;
15050
15060 PROCEDURE FACTOR(FSYS: SETOFSYS);
15070 VAR
15080 LCP: CTP; LVP: CSP; VARPART: BOOLEAN;
15090 CSTPART: SET OF SETRANGE; LSP: STP;
15100 RANGEPART: BOOLEAN; LRMIN: SETRANGE;
15110 LOFFSET: 0..OFFSET ;
15120
15130 BEGIN
15140 IF NOT (SY IN FACBEGSYS)
15150 THEN
15160 BEGIN
15170 ERRANDSKIP(173,FSYS + FACBEGSYS);
15180 GATTR.TYPTR := NIL
15190 END;
15200 IF SY IN FACBEGSYS
15210 THEN
15220 BEGIN
15230 CASE SY OF
15240 IDENT:
15250 BEGIN
15260 SEARCHID([KONST,VARS,FIELD,FUNC],LCP);
15270 INSYMBOL;
15280 CASE LCP^.KLASS OF
15290 FUNC:
15300 BEGIN
15310 CALL(FSYS,LCP);
15320 IF LCP^.PFDECKIND=DECLARED
15330 THEN
15340 BEGIN
15350 WITH LCP^,GATTR DO
15360 BEGIN
15370 TYPTR :=IDTYPE; KIND :=VARBL; PACKFG :=NOTPACK;
15380 VRELBYTE := NO;
15390 VLEVEL :=1; DPLMT :=2;
15400 INDEXR := TOPP; INDBIT :=0;
15410 IF TYPTR <> NIL
15420 THEN
15430 IF TYPTR^.SIZE = 1
15440 THEN LOAD(GATTR)
15450 END
15460 END
15470 END;
15480 KONST:
15490 WITH GATTR, LCP^ DO
15500 BEGIN
15510 TYPTR := IDTYPE; KIND := CST;
15520 CVAL := VALUES
15530 END;
15540 OTHERS:
15550 SELECTOR(FSYS,LCP)
15560 END (*CASE KLASS*);
15570 IF GATTR.TYPTR <> NIL
15580 THEN WITH GATTR, TYPTR^ DO
15590 IF FORM = SUBRANGE (*ELIMINATE SUBRANGE TYPES*)
15600 THEN TYPTR := RANGETYPE (*TO SIMPLIFY LATER TESTS*)
15610 END;
15620 INTCONST:
15630 BEGIN
15640 WITH GATTR DO
15650 BEGIN
15660 TYPTR := INTPTR; KIND := CST;
15670 CVAL := VAL
15680 END;
15690 INSYMBOL
15700 END;
15710 REALCONST:
15720 BEGIN
15730 WITH GATTR DO
15740 BEGIN
15750 TYPTR := REALPTR; KIND := CST;
15760 CVAL := VAL
15770 END;
15780 INSYMBOL
15790 END;
15800 STRINGCONST:
15810 BEGIN
15820 WITH GATTR DO
15830 BEGIN
15840 CONSTANT(FSYS,TYPTR,CVAL) ; KIND := CST
15850 END
15860 END;
15870 LPARENT:
15880 BEGIN
15890 INSYMBOL; EXPRESSION(FSYS + [RPARENT],ONREGC);
15900 IF SY = RPARENT
15910 THEN INSYMBOL
15920 ELSE ERROR(152)
15930 END;
15940 NOTSY:
15950 BEGIN
15960 INSYMBOL; FACTOR(FSYS);
15970 IF GATTR.TYPTR = BOOLPTR
15980 THEN
15990 BEGIN
16000 LOAD(GATTR); MACRO3(411B(*ANDCAI*),REGC,1)
16010 END
16020 ELSE
16030 BEGIN
16040 ERROR(359); GATTR.TYPTR := NIL
16050 END
16060 END;
16070 LBRACK:
16080 BEGIN
16090 INSYMBOL; CSTPART := [ ]; VARPART := FALSE;
16100 RANGEPART:=FALSE;
16110 NEW(LSP,POWER);
16120 WITH LSP^ DO
16130 BEGIN
16140 ELSET:=NIL; SIZE:= 2
16150 END;
16160 IF SY = RBRACK
16170 THEN
16180 BEGIN
16190 WITH GATTR DO
16200 BEGIN
16210 TYPTR:=LSP; KIND:=CST;
16220 NEW(LVP,PSET); LVP^.PVAL := CSTPART; CVAL.VALP := LVP
16230 END;
16240 INSYMBOL
16250 END
16260 ELSE
16270 BEGIN
16280 LOOP
16290 INCREMENT_REGC; INCREMENT_REGC;
16300 EXPRESSION(FSYS + [COMMA,RBRACK,COLON],ONREGC);
16310 IF GATTR.TYPTR <> NIL
16320 THEN
16330 IF GATTR.TYPTR^.FORM <> SCALAR
16340 THEN
16350 BEGIN
16360 ERROR(461); GATTR.TYPTR := NIL
16370 END
16380 ELSE
16390 IF COMPTYPES(LSP^.ELSET,GATTR.TYPTR)
16400 THEN
16410 WITH GATTR DO
16420 BEGIN
16430 IF KIND = CST
16440 THEN
16450 BEGIN
16460 IF COMPTYPES(TYPTR,ASCIIPTR)
16470 THEN CVAL.IVAL := CVAL.IVAL-OFFSET;
16480 IF (CVAL.IVAL < 0) OR (CVAL.IVAL > BASEMAX)
16490 THEN ERROR(268)
16500 ELSE CSTPART := CSTPART + [CVAL.IVAL];
16510 REGC := REGC - 2;
16520 IF SY=COLON
16530 THEN
16540 BEGIN
16550 RANGEPART:=TRUE;
16560 LRMIN:=CVAL.IVAL
16570 END
16580 ELSE
16590 IF RANGEPART
16600 THEN
16610 BEGIN
16620 LRMIN:=LRMIN+1;
16630 WHILE (LRMIN<CVAL.IVAL) DO
16640 BEGIN
16650 CSTPART:=CSTPART + [LRMIN];
16660 LRMIN:=LRMIN+1
16670 END;
16680 RANGEPART:=FALSE
16690 END
16700 END
16710 ELSE
16720 BEGIN
16730 IF (SY=COLON) OR RANGEPART
16740 THEN
16750 BEGIN
16760 ERROR(207);RANGEPART := NOT RANGEPART
16770 END;
16780 LOAD(GATTR);
16790 REGC := REGC -1;
16800 MACRO3(515B(*HRLZI*),REGC-1,400000B);
16810 MACRO2(400B(*SETZ*),REGC);
16820 IF RUNTIME_CHECK
16830 THEN
16840 BEGIN
16850 IF COMPTYPES(TYPTR,ASCIIPTR)
16860 THEN LOFFSET := OFFSET
16870 ELSE LOFFSET := 0 ;
16880 MACRO3(301B(*CAIL*),REGC+1,LOFFSET);
16890 MACRO3(303B(*CAILE*),REGC+1,BASEMAX+LOFFSET);
16900 SUPPORT(ERRORINSET)
16910 END;
16920 MACRO3(210B(*MOVN*),REGC+1,REGC+1);
16930 IF COMPTYPES(TYPTR,ASCIIPTR)
16940 THEN MACRO4(246B(*LSHC*),REGC-1,REGC+1,OFFSET)
16950 ELSE MACRO4(246B(*LSHC*),REGC-1,REGC+1,0);
16960 IF VARPART
16970 THEN
16980 BEGIN
16990 MACRO3(434B(*IOR*),REGC-3,REGC-1);
17000 MACRO3(434B(*IOR*),REGC-2,REGC);
17010 REGC := REGC - 2
17020 END
17030 ELSE VARPART := TRUE;
17040 KIND := EXPR; REG := REGC
17050 END;
17060 LSP^.ELSET := TYPTR;
17070 TYPTR :=LSP
17080 END
17090 ELSE ERROR(360)
17100 EXIT IF NOT(SY IN [COMMA,COLON]);
17110 INSYMBOL
17120 END;
17130 IF SY = RBRACK
17140 THEN INSYMBOL
17150 ELSE ERROR(155);
17160 IF VARPART
17170 THEN
17180 BEGIN
17190 IF CSTPART <> [ ]
17200 THEN
17210 BEGIN
17220 NEW(LVP,PSET); LVP^.PVAL := CSTPART;
17230 GATTR.KIND := CST; GATTR.CVAL.VALP := LVP;
17240 GENERATE_CODE(434B(*IOR*),REGC,GATTR)
17250 END
17260 END
17270 ELSE
17280 BEGIN
17290 NEW(LVP,PSET); LVP^.PVAL := CSTPART; GATTR.CVAL.VALP := LVP
17300 END
17310 END
17320 END
17330 END (*CASE*) ;
17340 IFERRSKIP(166,FSYS)
17350 END (*IF SY IN FACBEGSYS*)
17360 END (*FACTOR*) ;
17370
17380 BEGIN
17390 (*TERM*)
17400 FACTOR(FSYS + [MULOP]);
17410 WHILE SY = MULOP DO
17420 BEGIN
17430 IF OP IN [RDIV,IDIV,IMOD]
17440 THEN LOAD(GATTR); (*BECAUSE OPERANDS ARE NOT
17450 ALLOWED TO BE CHOSEN*)
17460 LATTR := GATTR; LOP := OP;
17470 INSYMBOL; FACTOR(FSYS + [MULOP]);
17480 IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL)
17490 THEN
17500 CASE LOP OF
17510 MUL:
17520 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
17530 AND (GATTR.TYPTR^.FORM = POWER)
17540 THEN SEARCHCODE(404B(*AND*),LATTR)
17550 ELSE
17560 IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
17570 THEN SEARCHCODE(220B(*IMUL*),LATTR)
17580 ELSE
17590 BEGIN
17600 MAKEREAL(LATTR);
17610 IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
17620 THEN SEARCHCODE(164B(*FMPR*),LATTR)
17630 ELSE
17640 BEGIN
17650 ERROR(311); GATTR.TYPTR := NIL
17660 END
17670 END;
17680 RDIV:
17690 BEGIN
17700 MAKEREAL(LATTR);
17710
17720 IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
17730 THEN SEARCHCODE(174B(*FDVR*),LATTR)
17740 ELSE
17750 BEGIN
17760 ERROR(311); GATTR.TYPTR := NIL
17770 END
17780 END;
17790 IDIV:
17800
17810 IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
17820 THEN SEARCHCODE(230B(*IDIV*),LATTR)
17830 ELSE
17840 BEGIN
17850 ERROR(311); GATTR.TYPTR := NIL
17860 END;
17870 IMOD:
17880
17890 IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
17900 THEN
17910 BEGIN
17920 SEARCHCODE(230B(*IDIV*),LATTR);GATTR.REG := GATTR.REG+1
17930 END
17940 ELSE
17950 BEGIN
17960 ERROR(311); GATTR.TYPTR := NIL
17970 END;
17980 ANDOP:
17990 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
18000 AND (GATTR.TYPTR = BOOLPTR)
18010 THEN SEARCHCODE(404B(*AND*),LATTR)
18020 ELSE
18030 BEGIN
18040 ERROR(311); GATTR.TYPTR := NIL
18050 END
18060 END (*CASE*)
18070 ELSE GATTR.TYPTR := NIL;
18080 REGC:=GATTR.REG
18090 END (*WHILE*)
18100 END (*TERM*) ;
18110
18120 BEGIN
18130 (*SIMPLEEXPRESSION*)
18140 SIGNED := FALSE;
18150 IF (SY = ADDOP) AND (OP IN [PLUS,MINUS])
18160 THEN
18170 BEGIN
18180 SIGNED := OP = MINUS; INSYMBOL
18190 END;
18200 TERM(FSYS + [ADDOP]);
18210 IF SIGNED
18220 THEN WITH GATTR DO
18230 IF TYPTR <> NIL
18240 THEN
18250 IF (TYPTR = INTPTR) OR (TYPTR = REALPTR)
18260 THEN
18270 CASE KIND OF
18280 CST:
18290 IF TYPTR = INTPTR
18300 THEN CVAL.IVAL := - CVAL.IVAL
18310 ELSE
18320 BEGIN
18330 INCREMENT_REGC;
18340 GENERATE_CODE(210B(*MOVN*),REGC,GATTR)
18350 END;
18360 VARBL:
18370 BEGIN
18380 INCREMENT_REGC;
18390 GENERATE_CODE(210B(*MOVN*),REGC,GATTR)
18400 END;
18410 EXPR:
18420 MACRO3(210B(*MOVN*),REG,REG)
18430 END (*CASE*)
18440 ELSE
18450 BEGIN
18460 ERROR(311) ; GATTR.TYPTR := NIL
18470 END ;
18480 WHILE SY = ADDOP DO
18490 BEGIN
18500 IF AOS = B2
18510 THEN
18520 IF (LEFTSIDE.PACKFG=NOTPACK) AND COMPTYPES(LEFTSIDE.TYPTR,INTPTR)
18530 THEN
18540 BEGIN
18550 LEFTSIDE.TYPTR:=INTPTR; LEFTSIDE.BPADDR:=GATTR.BPADDR;
18560 IF LEFTSIDE=GATTR
18570 THEN AOS := B3
18580 ELSE AOS:=B0
18590 END
18600 ELSE AOS := B0
18610 ELSE AOS := B0;
18620 IF OP=MINUS
18630 THEN LOAD(GATTR); (*BECAUSE OPD MAY NOT BE CHOSEN*)
18640 LATTR := GATTR; LOP := OP;
18650 INSYMBOL; TERM(FSYS + [ADDOP]);
18660 IF AOS=B3
18670 THEN
18680 IF GATTR.KIND<>CST
18690 THEN AOS:=B0;
18700 IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL)
18710 THEN
18720 CASE LOP OF
18730 PLUS:
18740 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
18750 AND (GATTR.TYPTR^.FORM = POWER)
18760 THEN SEARCHCODE(434B(*IOR*),LATTR)
18770 ELSE
18780 IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
18790 THEN
18800 BEGIN
18810 IF AOS=B3
18820 THEN
18830 IF GATTR.CVAL.IVAL=1
18840 THEN AOS := AOSINSTR;
18850 SEARCHCODE(270B(*ADD*),LATTR)
18860 END
18870 ELSE
18880 BEGIN
18890 MAKEREAL(LATTR);
18900 IF (LATTR.TYPTR=REALPTR) AND (GATTR.TYPTR=REALPTR)
18910 THEN SEARCHCODE(144B(*FADR*),LATTR)
18920 ELSE
18930 BEGIN
18940 ERROR(311); GATTR.TYPTR := NIL
18950 END
18960 END;
18970 MINUS:
18980 IF (LATTR.TYPTR=INTPTR) AND (GATTR.TYPTR=INTPTR)
18990 THEN
19000 BEGIN
19010 IF AOS=B3
19020 THEN
19030 IF GATTR.CVAL.IVAL=1
19040 THEN AOS := SOSINSTR;
19050 SEARCHCODE(274B(*SUB*),LATTR)
19060 END
19070 ELSE
19080 BEGIN
19090 MAKEREAL(LATTR);
19100 IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
19110 THEN SEARCHCODE(154B(*FSBR*),LATTR)
19120 ELSE
19130 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
19140 AND (LATTR.TYPTR^.FORM = POWER)
19150 THEN SEARCHCODE(420B(*ANDCM*),LATTR)
19160 ELSE
19170 BEGIN
19180 ERROR(311); GATTR.TYPTR := NIL
19190 END
19200 END;
19210 OROP:
19220 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
19230 AND (GATTR.TYPTR = BOOLPTR)
19240 THEN SEARCHCODE(434B(*IOR*),LATTR)
19250 ELSE
19260 BEGIN
19270 ERROR(311); GATTR.TYPTR := NIL
19280 END
19290 END (*CASE*)
19300 ELSE GATTR.TYPTR := NIL;
19310 REGC:=GATTR.REG;
19320 IF AOS <= B3
19330 THEN AOS := B0
19340 END (*WHILE*);
19350 IF AOS <= B3
19360 THEN AOS := B0
19370 END (*SIMPLEEXPRESSION*) ;
19380
19390 BEGIN
19400 (*EXPRESSION*)
19410 TESTREGC := REGC+1;
19420 IF AOS=B1
19430 THEN AOS:=B2
19440 ELSE AOS:=B0;
19450 SIMPLEEXPRESSION(FSYS + [RELOP]);
19460 IF SY = RELOP
19470 THEN
19480 BEGIN
19490 JUMP := FALSE;
19500 IF FVALUE IN [ONREGC,ONFIXEDREGC]
19510 THEN
19520 BEGIN
19530 INCREMENT_REGC; MACRO3(551B(*HRRZI*),REGC,1); BOOLREGC := REGC
19540 END;
19550 IF GATTR.TYPTR <> NIL
19560 THEN
19570 IF GATTR.TYPTR^.SIZE > 2
19580 THEN LOAD_ADDRESS;
19590 LREGC1 := REGC;
19600 LATTR := GATTR;
19610 LOP := OP;
19620 IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC < BOOLREGC)
19630 THEN REGC := BOOLREGC;
19640 INSYMBOL; SIMPLEEXPRESSION(FSYS);
19650 IF GATTR.TYPTR <> NIL
19660 THEN
19670 IF GATTR.TYPTR^.SIZE > 2
19680 THEN LOAD_ADDRESS; LREGC2 := REGC;
19690 IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL)
19700 THEN
19710 BEGIN
19720 IF LOP = INOP
19730 THEN
19740 IF GATTR.TYPTR^.FORM = POWER
19750 THEN
19760 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR^.ELSET)
19770 THEN
19780 BEGIN
19790 LOAD(LATTR);
19800 IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC < BOOLREGC)
19810 THEN REGC := BOOLREGC;
19820 LOAD(GATTR); REGC := GATTR.REG - 1;
19830 IF COMPTYPES(LATTR.TYPTR,ASCIIPTR)
19840 THEN MACRO4(246B(*LSHC*),REGC,LATTR.REG,-OFFSET)
19850 ELSE MACRO4(246B(*LSHC*),REGC,LATTR.REG,0);
19860 IF FVALUE = TRUEJMP
19870 THEN LINSTR := 305B(*CAIGE*)
19880 ELSE LINSTR := 301B(*CAIL*);
19890 MACRO2(LINSTR,REGC)
19900 END
19910 ELSE
19920 BEGIN
19930 ERROR(260); GATTR.TYPTR := NIL
19940 END
19950 ELSE
19960 BEGIN
19970 ERROR(213); GATTR.TYPTR := NIL
19980 END
19990 ELSE
20000 BEGIN
20010 IF LATTR.TYPTR <> GATTR.TYPTR
20020 THEN MAKEREAL(LATTR);
20030 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
20040 THEN
20050 BEGIN
20060 LSIZE := LATTR.TYPTR^.SIZE;
20070 CASE LATTR.TYPTR^.FORM OF
20080 POWER:
20090 IF LOP IN [LTOP,GTOP]
20100 THEN ERROR(313);
20110 ARRAYS:
20120 IF NOT STRING(LATTR.TYPTR)
20130 AND (LOP IN [LTOP,LEOP,GTOP,GEOP])
20140 THEN ERROR(312);
20150 POINTER,
20160 RECORDS:
20170 IF LOP IN [LTOP,LEOP,GTOP,GEOP]
20180 THEN ERROR(312);
20190 FILES:
20200 ERROR(314)
20210 END;
20220 WITH LATTR.TYPTR^ DO
20230 BEGIN
20240 IF SIZE <= 2
20250 THEN
20260 BEGIN
20270 DEFAULT := TRUE;
20280 SETINCLUSION := FALSE;
20290 JUMP_OFFSET := 3;
20300 DEFAULT_OFFSET := 4;
20310 CASE LOP OF
20320 LTOP:
20330 BEGIN
20340 LINSTR := 311B(*CAML*); LINSTR1 := 313B
20350 END;
20360 LEOP:
20370 IF FORM = POWER
20380 THEN
20390 BEGIN
20400 SEARCHCODE(420B(*ANDCM*),LATTR);
20410 SETINCLUSION := TRUE
20420 END
20430 ELSE
20440 BEGIN
20450 LINSTR := 313B(*CAMLE*); LINSTR1 := 313B
20460 END;
20470 GTOP:
20480 BEGIN
20490 LINSTR := 317B(*CAMG*); LINSTR1 := 315B
20500 END;
20510 GEOP:
20520 IF FORM = POWER
20530 THEN
20540 BEGIN
20550 SEARCHCODE(410B(*ANDCA*),LATTR);
20560 SETINCLUSION := TRUE
20570 END
20580 ELSE
20590 BEGIN
20600 LINSTR := 315B(*CAMGE*); LINSTR1 := 315B
20610 END;
20620 NEOP:
20630 BEGIN
20640 LINSTR := 316B(*CAMN*);DEFAULT := FALSE
20650 END;
20660 EQOP:
20670 BEGIN
20680 LINSTR := 312B(*CAME*); DEFAULT := FALSE
20690 END
20700 END;
20710 IF FVALUE IN [TRUEJMP,FALSEJMP]
20720 THEN
20730 BEGIN
20740 IF (FORM = SCALAR) AND (GATTR.KIND = CST)
20750 THEN
20760 IF LATTR.TYPTR = REALPTR
20770 THEN JUMP := GATTR.CVAL.VALP^.RVAL = 0.0
20780 ELSE
20790 IF GATTR.CVAL.IVAL = 0
20800 THEN JUMP := TRUE;
20810 IF (FVALUE = TRUEJMP) <> JUMP
20820 THEN CHANGEBOOL(LINSTR);
20830 IF JUMP
20840 THEN LINSTR := LINSTR + 10B (*E.G CAML --> JUMPL *)
20850 END;
20860 IF SIZE = 1
20870 THEN
20880 IF JUMP
20890 THEN
20900 BEGIN
20910 LOAD(LATTR); MACRO3(LINSTR,LATTR.REG,0)
20920 END
20930 ELSE SEARCHCODE(LINSTR,LATTR)
20940 ELSE
20950 IF SETINCLUSION
20960 THEN
20970 BEGIN
20980 MACRO3(336B(*SKIPN*),0,GATTR.REG);
20990 MACRO3(332B(*SKIPE*),0,GATTR.REG-1);
21000 IF FVALUE = TRUEJMP
21010 THEN MACRO3R(254B(*JRST*),0,IC+2)
21020 END
21030 ELSE
21040 BEGIN
21050 LOAD(LATTR);
21060 IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC<BOOLREGC)
21070 THEN REGC := BOOLREGC;
21080 LOAD(GATTR);
21090 CASE FVALUE OF
21100 ONREGC,
21110 ONFIXEDREGC,
21120 FALSEJMP:
21130 IF LOP = EQOP
21140 THEN JUMP_OFFSET := 2;
21150 TRUEJMP:
21160 IF LOP <> EQOP
21170 THEN
21180 BEGIN
21190 JUMP_OFFSET := 2; DEFAULT_OFFSET := 5
21200 END
21210 END;
21220 IF DEFAULT
21230 THEN
21240 BEGIN
21250 MACRO3(LINSTR1,LATTR.REG-1,GATTR.REG-1);
21260 MACRO3R(254B(*JRST*),0,IC + DEFAULT_OFFSET)
21270 END;
21280 MACRO3(312B(*CAME*),LATTR.REG-1,GATTR.REG-1);
21290 MACRO3R(254B(*JRST*),0,IC+JUMP_OFFSET);
21300 MACRO3(LINSTR,LATTR.REG,GATTR.REG)
21310 END
21320 END
21330 ELSE
21340 BEGIN
21350 MACRO3(551B(*HRRZI*),REG0,LSIZE);
21360 INCREMENT_REGC ;
21370 MACRO4(200B(*MOVE*),REGC,LREGC1,0);
21380 MACRO4(312B(*CAME*),REGC,LREGC2,0);
21390 MACRO3R(254B(*JRST*),0,IC+5);
21400 MACRO2(340B(*AOJ*),LREGC1);
21410 MACRO2(340B(*AOJ*),LREGC2);
21420 MACRO3R(367B(*SOJG*),REG0,IC-5);
21430 JMPADRIFALLEQUAL := 0;
21440 CASE LOP OF
21450 LTOP,GTOP:
21460 IF FVALUE=TRUEJMP
21470 THEN JMPADRIFALLEQUAL := 3
21480 ELSE JMPADRIFALLEQUAL := 2;
21490 LEOP,GEOP:
21500 IF FVALUE=TRUEJMP
21510 THEN JMPADRIFALLEQUAL := 2
21520 ELSE JMPADRIFALLEQUAL := 3;
21530 EQOP :
21540 IF FVALUE<>TRUEJMP
21550 THEN JMPADRIFALLEQUAL := 2;
21560 NEOP :
21570 IF FVALUE=TRUEJMP
21580 THEN JMPADRIFALLEQUAL := 2
21590 END;
21600 IF JMPADRIFALLEQUAL <> 0
21610 THEN MACRO4R(254B(*JRST*),0,0,IC+JMPADRIFALLEQUAL);
21620 CASE LOP OF
21630 LTOP,LEOP:
21640 LINSTR := 311B(*CAML*);
21650 GTOP,GEOP:
21660 LINSTR := 317B(*CAMG*)
21670 END;
21680 IF FVALUE=TRUEJMP
21690 THEN CHANGEBOOL(LINSTR);
21700 IF LOP IN [LTOP,LEOP,GTOP,GEOP]
21710 THEN MACRO4(LINSTR,REGC,LREGC2,0);
21720 REGC:=REGC-2
21730 END
21740 END
21750 END
21760 ELSE ERROR(260)
21770 END;
21780 IF FVALUE IN [ONREGC,ONFIXEDREGC]
21790 THEN
21800 BEGIN
21810 MACRO3(400B(*SETZ*),BOOLREGC,0); REGC := BOOLREGC
21820 END
21830 ELSE
21840 IF NOT JUMP
21850 THEN MACRO3(254B(*JRST*),0,0)
21860 END;
21870 GATTR.TYPTR := BOOLPTR; GATTR.KIND := EXPR; GATTR.REG := REGC
21880 END (*SY = RELOP*)
21890 ELSE
21900 IF FVALUE IN [TRUEJMP,FALSEJMP]
21910 THEN
21920 BEGIN
21930 LOAD(GATTR);
21940 IF GATTR.TYPTR<>BOOLPTR
21950 THEN ERROR (359);
21960 IF FVALUE = TRUEJMP
21970 THEN LINSTR := 326B(*JUMPN*)
21980 ELSE LINSTR := 322B(*JUMPE*);
21990 MACRO3(LINSTR,GATTR.REG,0)
22000 END
22010 ELSE
22020 IF GATTR.KIND=EXPR
22030 THEN REGC := GATTR.REG;
22040 IF FVALUE = ONFIXEDREGC
22050 THEN WITH GATTR DO
22060 IF (TYPTR <> NIL) AND (KIND=EXPR)
22070 THEN WITH TYPTR^ DO
22080 BEGIN
22090 IF SIZE = 2
22100 THEN TESTREGC := TESTREGC + 1;
22110 IF TESTREGC <> REGC
22120 THEN
22130 BEGIN
22140 IF SIZE = 2
22150 THEN MACRO3(200B(*MOVE*),TESTREGC-1,REGC-1);
22160 MACRO3(200B(*MOVE*),TESTREGC,REGC); REGC := TESTREGC;REG := REGC
22170 END
22180 END
22190 END (*EXPRESSION*) ;
22200
22210 PROCEDURE ASSIGNMENT(FCP: CTP);
22220 VAR
22230 SLATTR: ATTR;
22240 CMIN, CMAX: VALU;
22250 LEFTSIDE_REAL: BOOLEAN;
22260 LINSTR: INSTRANGE;
22270 OLDIX: CODERANGE;
22280 OLDIC: ADDRRANGE;
22290
22300 PROCEDURE STOREGLOBALS ;
22310 TYPE
22320 CHANGEFORM = (PTRW,INTW,REELW,PSETW,STRGW,INSTW) ;
22330 VAR
22340 CHANGE : RECORD
22350 CASE KW : CHANGEFORM OF
22360 PTRW: (WPTR :GTP (*TO ALLOW NIL*)) ;
22370 INTW: (WINT : INTEGER ; WINT1 : INTEGER (*TO PICK UP SECOND WORD OF SET*)) ;
22380 REELW: (WREEL: REAL) ;
22390 PSETW: (WSET : SET OF SETRANGE) ;
22400 STRGW: (WSTRG: CHARWORD) ;
22410 INSTW: (WINST: PDP10INSTR)
22420 END ;
22430 I: 1..STRGLGTH; J: 0..5;
22440
22450 PROCEDURE STOREWORD ;
22460 BEGIN
22470 CIX := CIX + 1 ;
22480 IF CIX > CODE_SIZE
22490 THEN
22500 BEGIN
22510 CIX := 0;
22520 IF NOT OVERRUN
22530 THEN
22540 BEGIN
22550 OVERRUN := TRUE;
22560 ERROR_WITH_TEXT(356,'INITPROCD.')
22570 END
22580 END ;
22590 WITH CGLOBPTR^ DO
22600 BEGIN
22610 CODE_ARRAY^.INSTRUCTION[CIX] := CHANGE.WINST ;
22620 LASTGLOB := LASTGLOB + 1
22630 END
22640 END (*STOREWORD*) ;
22650
22660 PROCEDURE GETNEWGLOBPTR ;
22670 VAR
22680 LGLOBPTR : GTP ;
22690 BEGIN
22700 NEW(LGLOBPTR) ;
22710 WITH LGLOBPTR^ DO
22720 BEGIN
22730 NEXTGLOBPTR := NIL ;
22740 FIRSTGLOB := 0
22750 END ;
22760 IF CGLOBPTR <> NIL
22770 THEN CGLOBPTR^.NEXTGLOBPTR := LGLOBPTR ;
22780 CGLOBPTR := LGLOBPTR
22790 END (*GETNEWGLOBPTR*);
22800
22810 BEGIN
22820 (*STOREGLOBALS*)
22830 IF FGLOBPTR = NIL
22840 THEN
22850 BEGIN
22860 GETNEWGLOBPTR ;
22870 FGLOBPTR := CGLOBPTR
22880 END
22890 ELSE
22900 IF LEFTSIDE.DPLMT <> CGLOBPTR^.LASTGLOB + 1
22910 THEN GETNEWGLOBPTR ;
22920 WITH CHANGE,CGLOBPTR^,GATTR,CVAL DO
22930 BEGIN
22940 IF FIRSTGLOB = 0
22950 THEN
22960 BEGIN
22970 IF LEFTSIDE.PACKFG<>NOTPACK
22980 THEN
22990 IF ERRLIST[ERRINX].ARW<>507
23000 THEN ERROR(507);
23010 FIRSTGLOB := LEFTSIDE.DPLMT ;
23020 LASTGLOB := FIRSTGLOB - 1 ;
23030 FCIX := CIX + 1
23040 END ;
23050 CASE TYPTR^.FORM OF
23060 SCALAR,
23070 SUBRANGE:
23080 BEGIN
23090 IF LEFTSIDE_REAL
23100 THEN
23110 IF TYPTR=INTPTR
23120 THEN WREEL := IVAL
23130 ELSE WREEL := VALP^.RVAL
23140 ELSE WINT := IVAL ;
23150 STOREWORD
23160 END ;
23170 POINTER :
23180 BEGIN
23190 WPTR := NIL ; STOREWORD
23200 END ;
23210 POWER :
23220 BEGIN
23230 WSET := VALP^.PVAL ; STOREWORD ;
23240 WINT := WINT1 (*GET SECOND WORD OF SET*) ;
23250 STOREWORD
23260 END ;
23270 ARRAYS :
23280 WITH VALP^,CHANGE DO
23290 BEGIN
23300 J := 0; WINT := 0;
23310 FOR I := 1 TO SLGTH DO
23320 BEGIN
23330 J := J + 1;
23340 WSTRG[J] := SVAL[I];
23350 IF J=5
23360 THEN
23370 BEGIN
23380 J := 0;
23390 STOREWORD; WINT := 0
23400 END
23410 END;
23420 IF J<>0
23430 THEN STOREWORD
23440 END;
23450 OTHERS :
23460 ERROR(411)
23470 END (*CASE*)
23480 END (* WITH *)
23490 END (* STOREGLOBALS *) ;
23500
23510 BEGIN
23520 (*ASSIGNMENT*)
23530 SELECTOR(FSYS + [BECOMES],FCP);
23540 IF SY = BECOMES
23550 THEN
23560 BEGIN
23570 LEFTSIDE := GATTR;
23580 LEFTSIDE_REAL := COMPTYPES(LEFTSIDE.TYPTR,REALPTR);
23590 IF NOT RUNTIME_CHECK
23600 THEN
23610 BEGIN
23620 AOS := B1; OLDIX:=CIX; OLDIC:=IC
23630 END;
23640 INSYMBOL;
23650 EXPRESSION(FSYS,ONREGC);
23660 IF (LEFTSIDE.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL)
23670 THEN
23680 IF COMPTYPES(LEFTSIDE.TYPTR,GATTR.TYPTR) OR
23690 LEFTSIDE_REAL AND (GATTR.TYPTR=INTPTR)
23700 THEN
23710 IF INITGLOBALS
23720 THEN
23730 IF GATTR.KIND = CST
23740 THEN STOREGLOBALS
23750 ELSE ERROR(504)
23760 ELSE
23770 IF (GATTR.KIND=CST) AND (GATTR.CVAL.IVAL=0) AND
23780 (LEFTSIDE.PACKFG<>PACKK)
23790 THEN WITH LEFTSIDE DO
23800 BEGIN
23810 FETCH_BASIS(LEFTSIDE);
23820 WITH TYPTR^ DO
23830 IF FORM = SUBRANGE
23840 THEN
23850 IF LEFTSIDE_REAL
23860 THEN
23870 BEGIN
23880 IF (VMIN.VALP^.RVAL > 0) OR (VMAX.VALP^.RVAL < 0)
23890 THEN ERROR(367)
23900 END
23910 ELSE
23920 IF (VMIN.IVAL > 0) OR (VMAX.IVAL < 0)
23930 THEN ERROR(367) ;
23940 CASE PACKFG OF
23950 NOTPACK:
23960 LINSTR := 402B(*SETZM*);
23970 HWORDL:
23980 LINSTR := 553B(*HRRZS*);
23990 HWORDR:
24000 LINSTR := 513B(*HLLZS*)
24010 END (*CASE*);
24020 MACRO(VRELBYTE,LINSTR,0,INDBIT,INDEXR,DPLMT)
24030 END
24040 ELSE
24050 IF AOS >= AOSINSTR
24060 THEN
24070 BEGIN
24080 IC := OLDIC; CIX := OLDIX;
24090 IF AOS=AOSINSTR
24100 THEN GENERATE_CODE(350B(*AOS*),0,LEFTSIDE)
24110 ELSE GENERATE_CODE(370B(*SOS*),0,LEFTSIDE)
24120 END
24130 ELSE
24140 CASE LEFTSIDE.TYPTR^.FORM OF
24150 SCALAR,
24160 POINTER,
24170 POWER:
24180 BEGIN
24190 LOAD(GATTR);
24200 IF (GATTR.TYPTR=INTPTR) AND LEFTSIDE_REAL
24210 THEN MAKEREAL(GATTR);
24220 STORE(GATTR.REG,LEFTSIDE)
24230 END;
24240 SUBRANGE:
24250 BEGIN
24260 CMIN := LEFTSIDE.TYPTR^.VMIN;
24270 CMAX := LEFTSIDE.TYPTR^.VMAX;
24280 IF LEFTSIDE_REAL
24290 THEN
24300 IF GATTR.TYPTR=INTPTR
24310 THEN MAKEREAL(GATTR);
24320 IF GATTR.KIND = CST
24330 THEN WITH GATTR DO
24340 BEGIN
24350 IF LEFTSIDE_REAL
24360 THEN
24370 BEGIN
24380 IF (CVAL.VALP^.RVAL < CMIN.VALP^.RVAL)
24390 OR (CVAL.VALP^.RVAL > CMAX.VALP^.RVAL)
24400 THEN ERROR(367)
24410 END (*LEFTSIDE_REAL*)
24420 ELSE
24430 IF (CVAL.IVAL < CMIN.IVAL) OR (CVAL.IVAL > CMAX.IVAL)
24440 THEN ERROR (367);
24450 LOAD(GATTR)
24460 END (*=CST*)
24470 ELSE
24480 IF RUNTIME_CHECK AND ((GATTR.KIND<>VARBL) OR (GATTR.SUBKIND <> LEFTSIDE.TYPTR))
24490 THEN
24500 BEGIN
24510 LOAD(GATTR);
24520 WITH SLATTR DO
24530 BEGIN
24540 TYPTR:= GATTR.TYPTR;
24550 KIND := CST;
24560 CVAL := CMAX
24570 END;
24580 GENERATE_CODE(317B(*CAMG*),REGC,SLATTR);
24590 SLATTR.KIND:=CST;
24600 SLATTR.CVAL:=CMIN;
24610 GENERATE_CODE(315B(*CAMGE*),REGC,SLATTR);
24620 SUPPORT(ERRORINASSIGNMENT)
24630 END (*RUNTIMECHECK*)
24640 ELSE LOAD(GATTR);
24650 STORE(GATTR.REG,LEFTSIDE)
24660 END;
24670
24680 ARRAYS,
24690 RECORDS:
24700 IF GATTR.TYPTR^.SIZE = 1
24710 THEN
24720 BEGIN
24730 LOAD(GATTR) ; STORE(GATTR.REG,LEFTSIDE)
24740 END
24750 ELSE WITH LEFTSIDE DO
24760 BEGIN
24770 LOAD_ADDRESS ;
24780 CODE_ARRAY^.INSTRUCTION[CIX].INSTR := 515B(*HRLZI*) ;
24790 FETCH_BASIS(LEFTSIDE);
24800 MACRO(VRELBYTE,541B(*HRRI*),REGC,INDBIT,INDEXR,DPLMT);
24810 IF INDBIT=0
24820 THEN MACRO5(VRELBYTE,251B(*BLT *),REGC,INDEXR,DPLMT+TYPTR^.SIZE-1)
24830 ELSE
24840 BEGIN
24850 INCREMENT_REGC ;
24860 MACRO3(200B(*MOVE*),REGC,REGC-1);
24870 MACRO4(251B(*BLT *),REGC,REGC-1,TYPTR^.SIZE-1)
24880 END
24890 END;
24900 FILES:
24910 ERROR(361)
24920 END (*CASE*)
24930 ELSE ERROR(260);
24940 AOS := B0
24950 END (*SY = BECOMES*)
24960 ELSE ERROR(159)
24970 END (*ASSIGNMENT*) ;
24980
24990 PROCEDURE GOTOSTATEMENT;
25000 VAR
25010 LCP: CTP; LSCOPE: LEVRANGE;
25020 BEGIN
25030 IF SY = INTCONST
25040 THEN
25050 BEGIN
25060 SEARCHID([LABELS],LCP);
25070 IF LCP <> NIL
25080 THEN
25090 WITH LCP^ DO
25100 BEGIN
25110 LSCOPE := LEVEL - SCOPE;
25120 MACRO3R(254B(*JRST*),0,GOTO_CHAIN);
25130 GOTO_CHAIN := IC-1; CODE_REFERENCE^[CIX] := GOTOREF;
25140 IF LSCOPE > 0
25150 THEN
25160 IF (SCOPE = 1) AND EXTERNAL
25170 THEN ERROR(508)
25180 ELSE EXIT_JUMP := TRUE
25190 END;
25200 INSYMBOL
25210 END
25220 ELSE ERROR(255)
25230 END (*GOTOSTATEMENT*) ;
25240
25250 PROCEDURE COMPOUNDSTATEMENT;
25260 BEGIN
25270 LOOP
25280 REPEAT
25290 STATEMENT(FSYS,STATENDS)
25300 UNTIL NOT (SY IN STATBEGSYS)
25310 EXIT IF SY <> SEMICOLON;
25320 INSYMBOL
25330 END;
25340 IF SY = ENDSY
25350 THEN INSYMBOL
25360 ELSE ERROR(163)
25370 END (*COMPOUNDSTATEMENET*) ;
25380
25390 PROCEDURE IFSTATEMENT;
25400 VAR
25410 LCIX1,LCIX2: CODERANGE;
25420 BEGIN
25430 EXPRESSION(FSYS + [THENSY],FALSEJMP);
25440 LCIX1 := CIX;
25450 IF SY = THENSY
25460 THEN INSYMBOL
25470 ELSE ERROR(164);
25480 STATEMENT(FSYS + [ELSESY],STATENDS + [ELSESY]);
25490 IF SY = ELSESY
25500 THEN
25510 BEGIN
25520 MACRO3(254B(*JRST*),0,0); LCIX2 := CIX;
25530 INSERT_ADDRESS(RIGHT,LCIX1,IC);
25540 INSYMBOL; STATEMENT(FSYS,STATENDS);
25550 INSERT_ADDRESS(RIGHT,LCIX2,IC)
25560 END
25570 ELSE INSERT_ADDRESS(RIGHT,LCIX1,IC)
25580 END (*IFSTATEMENT*) ;
25590
25600 PROCEDURE CASESTATEMENT;
25610
25620 LABEL
25630 888,999;
25640
25650 TYPE
25660 CIP = ^CASEINFO;
25670 CASEINFO = PACKED
25680 RECORD
25690 NEXT: CIP;
25700 CSSTART: ADDRRANGE;
25710 CSEND: CODERANGE;
25720 CSLAB: INTEGER
25730 END;
25740 VAR
25750 LSP, LSP1: STP;
25760 FSTPTR, LPT1, LPT2, LPT3, OTHERSPTR: CIP;
25770 LVAL: VALU;
25780 LIC, LADDR, JUMPADDR, LMIN, LMAX: ADDRRANGE;
25790 LCIX: CODERANGE;
25800
25810 PROCEDURE INSERTBOUND(FCIX: CODERANGE; FIC: ADDRRANGE; BOUND: INTEGER);
25820 VAR
25830 LCIX1:CODERANGE;
25840 LIC1: ADDRRANGE;
25850 LATTR:ATTR;
25860 BEGIN
25870 IF BOUND >= 0
25880 THEN INSERT_ADDRESS(NO,FCIX,BOUND)
25890 ELSE
25900 BEGIN
25910 LCIX1:=CIX; LIC1 := IC;
25920 CIX:=FCIX; IC := FIC;
25930 WITH LATTR DO
25940 BEGIN
25950 KIND:=CST;
25960 CVAL.IVAL:=BOUND;
25970 TYPTR:=NIL
25980 END;
25990 DEPOSIT_CONSTANT(INT,LATTR);
26000 CIX:=LCIX1; IC:= LIC1;
26010 WITH CODE_ARRAY^.INSTRUCTION[FCIX] DO
26020 INSTR:=INSTR+10B (*CAILE-->CAMLE, CAIL-->CAML*)
26030 END
26040 END (*INSERTBOUND*);
26050 BEGIN
26060 OTHERSPTR:=NIL;
26070 EXPRESSION(FSYS + [OFSY,COMMA,COLON],ONREGC);
26080 LOAD(GATTR);
26090 MACRO2(301B(*CAIL*),REGC); (*<<<---- LMIN IS INSERTED HERE*)
26100 MACRO2(303B(*CAILE*),REGC); (*<<<---- LMAX IS INSERTED HERE*)
26110 MACRO2(254B(*JRST*),0); (*<<<---- START OF "OTHERS" IS INSERTED HERE*)
26120 MACRO(NO,254B(*JRST*),0,1,REGC,0);(*<<<---- START OF JUMP TABLE IS INSERTED HERE*)
26130 LCIX := CIX; LIC := IC;
26140 LSP := GATTR.TYPTR;
26150 IF LSP <> NIL
26160 THEN
26170 IF (LSP^.FORM <> SCALAR) OR (LSP = REALPTR)
26180 THEN
26190 BEGIN
26200 ERROR(315); LSP := NIL
26210 END;
26220 IF SY = OFSY
26230 THEN INSYMBOL
26240 ELSE ERROR(160);
26250 FSTPTR := NIL; LPT3 := NIL;
26260 LOOP
26270 LOOP
26280 CONSTANT(FSYS + [COMMA,COLON],LSP1,LVAL);
26290 IF LSP <> NIL
26300 THEN
26310 IF COMPTYPES(LSP,LSP1)
26320 THEN
26330 BEGIN
26340 LPT1 := FSTPTR; LPT2 := NIL;
26350 IF ABS(LVAL.IVAL) > HWCSTMAX
26360 THEN ERROR(316);
26370 WHILE LPT1 <> NIL DO
26380 WITH LPT1^ DO
26390 BEGIN
26400 IF CSLAB <= LVAL.IVAL
26410 THEN
26420 BEGIN
26430 IF CSLAB = LVAL.IVAL
26440 THEN ERROR(261);
26450 GOTO 888
26460 END;
26470 LPT2 := LPT1; LPT1 := NEXT
26480 END;
26490 888:
26500 NEW(LPT3);
26510 WITH LPT3^ DO
26520 BEGIN
26530 NEXT := LPT1; CSLAB := LVAL.IVAL;
26540 CSSTART := IC; CSEND := 0
26550 END;
26560 IF LPT2 = NIL
26570 THEN FSTPTR := LPT3
26580 ELSE LPT2^.NEXT := LPT3
26590 END
26600 ELSE ERROR(505)
26610 EXIT IF SY <> COMMA;
26620 INSYMBOL
26630 END;
26640 IF SY = COLON
26650 THEN INSYMBOL
26660 ELSE ERROR(151);
26670 REPEAT
26680 STATEMENT(FSYS,STATENDS)
26690 UNTIL NOT (SY IN STATBEGSYS);
26700 IF LPT3 <> NIL
26710 THEN
26720 BEGIN
26730 MACRO2(254B(*JRST*),0); LPT3^.CSEND := CIX
26740 END
26750 EXIT IF SY <> SEMICOLON;
26760 INSYMBOL;
26770 IF SY=OTHERSSY
26780 THEN
26790 BEGIN
26800 INSYMBOL;
26810 IF SY=COLON
26820 THEN INSYMBOL
26830 ELSE ERROR(151);
26840 NEW(OTHERSPTR);
26850 WITH OTHERSPTR^ DO
26860 BEGIN
26870 CSSTART:=IC;
26880 REPEAT
26890 STATEMENT(FSYS,STATENDS)
26900 UNTIL NOT(SY IN STATBEGSYS);
26910 MACRO2(254B(*JRST*),0);
26920 CSEND:=CIX;
26930 IF SY = SEMICOLON
26940 THEN INSYMBOL;
26950 GOTO 999
26960 END
26970 END
26980 ELSE
26990 IF SY = ENDSY
27000 THEN GOTO 999
27010 END;
27020 999:
27030 IF FSTPTR <> NIL
27040 THEN
27050 BEGIN
27060 LMAX := FSTPTR^.CSLAB;
27070 (*REVERSE POINTERS*)
27080 LPT1 := FSTPTR; FSTPTR := NIL;
27090 REPEAT
27100 LPT2 := LPT1^.NEXT; LPT1^.NEXT := FSTPTR;
27110 FSTPTR := LPT1; LPT1 := LPT2
27120 UNTIL LPT1 = NIL;
27130 LMIN := FSTPTR^.CSLAB;
27140 INSERTBOUND(LCIX-2,LIC-2,LMAX);
27150 INSERTBOUND(LCIX-3,LIC-3,LMIN);
27160 INSERT_ADDRESS(RIGHT,LCIX,IC-LMIN);
27170 IF (LMAX - LMIN) < (CODE_SIZE - CIX)
27180 THEN
27190 BEGIN
27200 LADDR := IC + LMAX - LMIN + 1;
27210 IF OTHERSPTR = NIL
27220 THEN JUMPADDR := LADDR
27230 ELSE
27240 BEGIN
27250 INSERT_ADDRESS(RIGHT,OTHERSPTR^.CSEND,LADDR);
27260 JUMPADDR:=OTHERSPTR^.CSSTART
27270 END;
27280 INSERT_ADDRESS(RIGHT,LCIX-1,JUMPADDR);
27290 REPEAT
27300 WITH FSTPTR^ DO
27310 BEGIN
27320 WHILE CSLAB > LMIN DO
27330 BEGIN
27340 GENERATE_WORD(RIGHT,0,JUMPADDR); LMIN := LMIN + 1
27350 END;
27360 GENERATE_WORD(RIGHT,0,CSSTART);
27370 IF CSEND <> 0
27380 THEN INSERT_ADDRESS(RIGHT,CSEND,LADDR);
27390 FSTPTR := NEXT; LMIN := LMIN + 1
27400 END
27410 UNTIL FSTPTR = NIL
27420 END
27430 ELSE
27440 BEGIN
27450 IF NOT OVERRUN
27460 THEN
27470 BEGIN
27480 OVERRUN := TRUE;
27490 IF FPROCP = NIL
27500 THEN ERROR_WITH_TEXT(356,'MAIN ')
27510 ELSE ERROR_WITH_TEXT(356,FPROCP^.NAME)
27520 END;
27530 CIX := 0
27540 END
27550 END;
27560 IF SY = ENDSY
27570 THEN INSYMBOL
27580 ELSE ERROR(163)
27590 END (*CASESTATEMENT*) ;
27600
27610 PROCEDURE REPEATSTATEMENT;
27620 VAR
27630 LADDR: ADDRRANGE;
27640 BEGIN
27650 LADDR := IC;
27660 LOOP
27670 REPEAT
27680 STATEMENT(FSYS + [UNTILSY],STATENDS + [UNTILSY])
27690 UNTIL NOT (SY IN STATBEGSYS)
27700 EXIT IF SY <> SEMICOLON;
27710 INSYMBOL
27720 END;
27730 IF SY = UNTILSY
27740 THEN
27750 BEGIN
27760 INSYMBOL; EXPRESSION(FSYS,FALSEJMP); INSERT_ADDRESS(RIGHT,CIX,LADDR)
27770 END
27780 ELSE ERROR(202)
27790 END (*REPEATSTATEMENT*) ;
27800
27810 PROCEDURE WHILESTATEMENT;
27820 VAR
27830 LADDR: ADDRRANGE;
27840 LCIX: CODERANGE;
27850 BEGIN
27860 LADDR := IC;
27870 EXPRESSION(FSYS + [DOSY],FALSEJMP);
27880 LCIX := CIX;
27890 IF SY = DOSY
27900 THEN INSYMBOL
27910 ELSE ERROR(161);
27920 STATEMENT(FSYS,STATENDS);
27930 MACRO3R(254B(*JRST*),0,LADDR);
27940 INSERT_ADDRESS(RIGHT,LCIX,IC)
27950 END (*WHILESTATEMENT*) ;
27960
27970 PROCEDURE FORSTATEMENT;
27980 VAR
27990 LATTR: ATTR;
28000 LSP: STP;
28010 LSY: SYMBOL;
28020 LCIX: CODERANGE;
28030 LADDR,LDPLMT: ADDRRANGE;
28040 LINSTR: INSTRANGE;
28050 LREGC,LINDREG: ACRANGE;
28060 LINDBIT: IBRANGE;
28070 LRELBYTE: RELBYTE;
28080 ADDTOLC: ADDRRANGE;
28090 BEGIN
28100 IF SY = IDENT
28110 THEN
28120 BEGIN
28130 SEARCHID([VARS],LCP);
28140 WITH LCP^, LATTR DO
28150 BEGIN
28160 TYPTR := IDTYPE; KIND := VARBL;
28170 IF VKIND = ACTUAL
28180 THEN
28190 BEGIN
28200 VLEVEL := VLEV;
28210 IF VLEV > 1
28220 THEN VRELBYTE := NO
28230 ELSE VRELBYTE := RIGHT;
28240 DPLMT := VADDR; INDEXR :=0; PACKFG := NOTPACK;
28250 INDBIT:=0
28260 END
28270 ELSE
28280 BEGIN
28290 ERROR(364); TYPTR := NIL
28300 END
28310 END;
28320 IF LATTR.TYPTR <> NIL
28330 THEN
28340 IF COMPTYPES(REALPTR,LATTR.TYPTR) OR (LATTR.TYPTR^.FORM > SUBRANGE)
28350 THEN
28360 BEGIN
28370 ERROR(365); LATTR.TYPTR := NIL
28380 END;
28390 INSYMBOL
28400 END
28410 ELSE
28420 BEGIN
28430 ERRANDSKIP(209,FSYS + [BECOMES,TOSY,DOWNTOSY,DOSY]);
28440 LATTR.TYPTR := NIL
28450 END;
28460 IF SY = BECOMES
28470 THEN
28480 BEGIN
28490 INSYMBOL; EXPRESSION(FSYS + [TOSY,DOWNTOSY,DOSY],ONREGC);
28500 IF GATTR.TYPTR <> NIL
28510 THEN
28520 IF GATTR.TYPTR^.FORM <> SCALAR
28530 THEN ERROR(315)
28540 ELSE
28550 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
28560 THEN LOAD(GATTR)
28570 ELSE ERROR(556);
28580 LREGC := GATTR.REG
28590 END
28600 ELSE ERRANDSKIP(159,FSYS + [TOSY,DOWNTOSY,DOSY]);
28610 IF SY IN [TOSY,DOWNTOSY]
28620 THEN
28630 BEGIN
28640 LSY := SY; INSYMBOL; EXPRESSION(FSYS + [DOSY],ONREGC);
28650 IF GATTR.TYPTR <> NIL
28660 THEN
28670 IF GATTR.TYPTR^.FORM <> SCALAR
28680 THEN ERROR(315)
28690 ELSE
28700 IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
28710 THEN
28720 BEGIN
28730 ADDTOLC := 0 ;
28740 WITH GATTR DO
28750 IF ((KIND = VARBL) AND
28760 (((VLEVEL > 1) AND (VLEVEL < LEVEL)) OR
28770 (PACKFG <> NOTPACK) OR
28780 ((INDEXR > 0) AND (INDEXR <= REGCMAX)))) OR
28790 (KIND = EXPR)
28800 THEN
28810 BEGIN
28820 LOAD(GATTR); MACRO4(202B(*MOVEM*),REGC,BASIS,LC); ADDTOLC := 1;
28830 KIND := VARBL ; INDBIT := 0 ; INDEXR := BASIS ; VLEVEL := 1;
28840 DPLMT := LC ; PACKFG := NOTPACK ; VRELBYTE := NO
28850 END ;
28860 FETCH_BASIS(LATTR);
28870 WITH LATTR DO
28880 BEGIN
28890 IF (INDEXR>0) AND (INDEXR<=REGCMAX)
28900 THEN
28910 BEGIN
28920 MACRO(NO,551B(*HRRZI*),INDEXR,INDBIT,INDEXR,DPLMT);
28930 LINDBIT := 1; LDPLMT := LC+ADDTOLC; LINDREG := BASIS ;
28940 MACRO4(202B(*MOVEM*),INDEXR,BASIS,LDPLMT);
28950 ADDTOLC := ADDTOLC + 1
28960 END
28970 ELSE
28980 BEGIN
28990 LINDBIT := INDBIT; LINDREG := INDEXR; LDPLMT := DPLMT
29000 END;
29010 LRELBYTE:= VRELBYTE
29020 END;
29030 MACRO(LRELBYTE,202B(*MOVEM*),LREGC,LINDBIT,LINDREG,LDPLMT);
29040 IF LSY = TOSY
29050 THEN LINSTR := 313B(*CAMLE*)
29060 ELSE LINSTR := 315B(*CAMGE*);
29070 LADDR := IC;
29080 GENERATE_CODE(LINSTR,LREGC,GATTR)
29090 END
29100 ELSE ERROR(556)
29110 END
29120 ELSE ERRANDSKIP(251,FSYS + [DOSY]);
29130 MACRO3(254B(*JRST*),0,0); LCIX :=CIX;
29140 IF SY = DOSY
29150 THEN INSYMBOL
29160 ELSE ERROR(161);
29170 LC := LC + ADDTOLC;
29180 IF LC > LCMAX
29190 THEN LCMAX:=LC;
29200 STATEMENT(FSYS,STATENDS);
29210 LC := LC - ADDTOLC;
29220 IF LSY = TOSY
29230 THEN LINSTR := 350B(*AOS*)
29240 ELSE LINSTR := 370B(*SOS*);
29250 MACRO(LRELBYTE,LINSTR,LREGC,LINDBIT,LINDREG,LDPLMT);
29260 MACRO3R(254B(*JRST*),0,LADDR); INSERT_ADDRESS(RIGHT,LCIX,IC)
29270 END (*FORSTATEMENT*) ;
29280
29290 PROCEDURE LOOPSTATEMENT;
29300 VAR
29310 LADDR: ADDRRANGE;
29320 LCIX: CODERANGE;
29330 BEGIN
29340 LADDR := IC;
29350 LOOP
29360 REPEAT
29370 STATEMENT(FSYS + [EXITSY],STATENDS + [EXITSY])
29380 UNTIL NOT (SY IN STATBEGSYS)
29390 EXIT IF SY <> SEMICOLON;
29400 INSYMBOL
29410 END;
29420 IF SY = EXITSY
29430 THEN
29440 BEGIN
29450 INSYMBOL;
29460 IF SY = IFSY
29470 THEN
29480 BEGIN
29490 INSYMBOL; EXPRESSION(FSYS + [SEMICOLON,ENDSY],TRUEJMP)
29500 END
29510 ELSE ERRANDSKIP(162,FSYS + [SEMICOLON,ENDSY]);
29520 LCIX := CIX;
29530 LOOP
29540 REPEAT
29550 STATEMENT(FSYS,STATENDS)
29560 UNTIL NOT (SY IN STATBEGSYS)
29570 EXIT IF SY <> SEMICOLON;
29580 INSYMBOL
29590 END;
29600 MACRO3R(254B(*JRST*),0,LADDR); INSERT_ADDRESS(RIGHT,LCIX,IC)
29610 END
29620 ELSE ERROR(165);
29630 IF SY = ENDSY
29640 THEN INSYMBOL
29650 ELSE ERROR(163)
29660 END (*LOOPSTATEMENT*) ;
29670
29680 PROCEDURE WITHSTATEMENT;
29690 VAR
29700 LCP: CTP; OLDLC: ADDRRANGE; LCNT1: DISPRANGE; OLDREGC: ACRANGE;
29710 BEGIN
29720 LCNT1 := 0; OLDREGC := REGCMAX; OLDLC := LC;
29730 LOOP
29740 IF SY = IDENT
29750 THEN
29760 BEGIN
29770 SEARCHID([VARS,FIELD],LCP); INSYMBOL
29780 END
29790 ELSE
29800 BEGIN
29810 ERROR(209); LCP := UVARPTR
29820 END;
29830 SELECTOR(FSYS + [COMMA,DOSY],LCP);
29840 IF GATTR.TYPTR <> NIL
29850 THEN
29860 IF GATTR.TYPTR^.FORM = RECORDS
29870 THEN
29880 IF TOP < DISPLIMIT
29890 THEN
29900 BEGIN
29910 TOP := TOP + 1; LCNT1 := LCNT1 + 1; WITHIX := WITHIX + 1;
29920 WITH DISPLAY[TOP], GATTR DO
29930 BEGIN
29940 FNAME := TYPTR^.FSTFLD;
29950 OCCUR := CREC;
29960 IF INDBIT = 1
29970 THEN GET_PARAMETER_ADDRESS;
29980 FETCH_BASIS(GATTR);
29990 IF (INDEXR<>0) AND (INDEXR <> BASIS)
30000 THEN
30010 BEGIN
30020 MACRO3(550B(*HRRZ*),REGCMAX,INDEXR);
30030 INDEXR := REGCMAX;
30040 REGCMAX := REGCMAX-1;
30050 IF REGCMAX<REGC
30060 THEN
30070 BEGIN
30080 ERROR(317);
30090 REGC := REGCMAX
30100 END
30110 END;
30120 CLEV := VLEVEL; CRELBYTE := VRELBYTE;
30130 CINDR := INDEXR; CINDB:=INDBIT;
30140 CDSPL := DPLMT;
30150 CLC := LC;
30160 IF (CINDR<>0) AND (CINDR<>BASIS)
30170 THEN
30180 BEGIN
30190 LC := LC + 1;
30200 IF LC>LCMAX
30210 THEN LCMAX := LC
30220 END
30230 END
30240 END
30250 ELSE ERROR(404)
30260 ELSE ERROR(308)
30270 EXIT IF SY <> COMMA;
30280 INSYMBOL
30290 END;
30300 IF SY = DOSY
30310 THEN INSYMBOL
30320 ELSE ERROR(161);
30330 STATEMENT(FSYS,STATENDS);
30340 REGCMAX:=OLDREGC;
30350 TOP := TOP - LCNT1; LC := OLDLC; WITHIX := WITHIX - LCNT1
30360 END (*WITHSTATEMENT*) ;
30370
30380 BEGIN
30390 (*STATEMENT*)
30400 IF SY = INTCONST
30410 THEN (*LABEL*)
30420 BEGIN
30430 SEARCHID([LABELS],LCP);
30440 IF LCP <> NIL
30450 THEN
30460 WITH LCP^ DO
30470 BEGIN
30480 IF LABEL_ADDRESS = 0
30490 THEN
30500 BEGIN
30510 IF EXIT_JUMP
30520 THEN MACRO3R(324B(*JUMPA*),REG0,IC+3);
30530 LABEL_ADDRESS := IC;
30540 IF EXIT_JUMP
30550 THEN
30560 BEGIN
30570 MACRO3R(200B(*MOVE*),BASIS,JUMP_TABLE[JUMP_INDEX]); CODE_REFERENCE^[CIX] := SAVEREF;
30580 MACRO3R(200B(*MOVE*),TOPP,JUMP_TABLE[JUMP_INDEX] + 1); CODE_REFERENCE^[CIX] := SAVEREF;
30590 JUMP_TABLE[JUMP_INDEX] := LABEL_ADDRESS
30600 END
30610 END
30620 ELSE ERROR(211);
30630 IF SCOPE <> LEVEL
30640 THEN ERROR(352)
30650 END;
30660 INSYMBOL;
30670 IF SY = COLON
30680 THEN INSYMBOL
30690 ELSE ERROR(151)
30700 END;
30710
30720 IF NOT (SY IN FSYS + [IDENT])
30730 THEN ERRANDSKIP(166,FSYS);
30740 IF SY IN STATBEGSYS + [IDENT]
30750 THEN
30760 IF INITGLOBALS
30770 THEN
30780 IF SY <> IDENT
30790 THEN ERROR(462)
30800 ELSE
30810 BEGIN
30820 SEARCHID([VARS,FIELD,FUNC,PROC],LCP); INSYMBOL;
30830 IF LCP^.KLASS = PROC
30840 THEN ERROR(462)
30850 ELSE ASSIGNMENT(LCP)
30860 END
30870 ELSE (*...NOT INITGLOBALS*)
30880 BEGIN
30890 IF DEBUG_SWITCH
30900 THEN PUT_LINENUMBER;
30910 REGC := REGIN;
30920 CASE SY OF
30930 IDENT:
30940 BEGIN
30950 SEARCHID([VARS,FIELD,FUNC,PROC],LCP); INSYMBOL;
30960 WITH LCP^ DO
30970 IF (KLASS = VARS) AND (VLEV = 0) AND (SY = ARROW) AND
30980 (IDTYPE^.FORM = FILES) AND (NAME = 'TTY ')
30990 THEN
31000 BEGIN
31010 ID := 'TTYOUTPUT '; SEARCHID([VARS],LCP)
31020 END;
31030 IF LCP^.KLASS = PROC
31040 THEN CALL(FSYS,LCP)
31050 ELSE ASSIGNMENT(LCP)
31060 END;
31070 BEGINSY:
31080 BEGIN
31090 INSYMBOL; COMPOUNDSTATEMENT
31100 END;
31110 GOTOSY:
31120 BEGIN
31130 INSYMBOL; GOTOSTATEMENT
31140 END;
31150 IFSY:
31160 BEGIN
31170 INSYMBOL; IFSTATEMENT
31180 END;
31190 CASESY:
31200 BEGIN
31210 INSYMBOL; CASESTATEMENT
31220 END;
31230 WHILESY:
31240 BEGIN
31250 INSYMBOL; WHILESTATEMENT
31260 END;
31270 REPEATSY:
31280 BEGIN
31290 INSYMBOL; REPEATSTATEMENT
31300 END;
31310 LOOPSY:
31320 BEGIN
31330 INSYMBOL; LOOPSTATEMENT
31340 END;
31350 FORSY:
31360 BEGIN
31370 INSYMBOL; FORSTATEMENT
31380 END;
31390 WITHSY:
31400 BEGIN
31410 INSYMBOL; WITHSTATEMENT
31420 END
31430 END (*CASE*) ;
31440
31450 (* RE-INITIALIZE REGISTER COUNTER TO AVOID OVERFLOW DURING SUBSEQUENT
31460 EXPRESSION EVALUATIONS IN REPEATSTATEMENT OR LOOPSTATEMENT *)
31470
31480 REGC := REGIN
31490
31500 END (*..NOT INITGLOBALS*);
31510 SKIPIFERR(STATENDS,506,FSYS)
31520 END (*STATEMENT*) ;
31530
31540 BEGIN
31550 (*BODY*)
31560 REGCMAX:=WITHIN; WITHIX := -1; FIRSTKONST := NIL;
31570 REG2_SAVED := FALSE;
31580 IF NOT ENTRY_DONE
31590 THEN
31600 BEGIN
31610 ENTRY_DONE:= TRUE;
31620 WRITE_MACHINE_CODE(WRITE_ENTRY);
31630 WRITE_MACHINE_CODE(WRITE_NAME);
31640 WRITE_MACHINE_CODE(WRITE_HISEG)
31650 END;
31660
31670 CIX := -1 ;
31680
31690 IF INITGLOBALS
31700 THEN
31710 BEGIN
31720 CGLOBPTR := NIL ;
31730 LOOP
31740 IF SY <> ENDSY
31750 THEN STATEMENT([SEMICOLON,ENDSY],[SEMICOLON,ENDSY])
31760 EXIT IF SY <> SEMICOLON ;
31770 INSYMBOL
31780 END ;
31790 IF SY = ENDSY
31800 THEN INSYMBOL
31810 ELSE ERROR(163) ;
31820 WRITE_MACHINE_CODE(WRITE_GLOBALS)
31830 END
31840 ELSE
31850 BEGIN
31860 ENTERBODY;
31870 IF FPROCP <> NIL
31880 THEN FPROCP^.PFADDR:= PFSTART
31890 ELSE LC:= 1;
31900 LCMAX:=LC;
31910 LOOP
31920 REPEAT
31930 STATEMENT(FSYS + [SEMICOLON,ENDSY],[SEMICOLON,ENDSY])
31940 UNTIL NOT (SY IN STATBEGSYS)
31950 EXIT IF SY <> SEMICOLON;
31960 INSYMBOL
31970 END;
31980 IF SY = ENDSY
31990 THEN INSYMBOL
32000 ELSE ERROR(163);
32010 LEAVEBODY;
32020 INSERT_ADDRESS(NO,STACKSIZE1,LCMAX);
32030 INSERT_ADDRESS(NO,STACKSIZE2,LCMAX);
32040 WRITE_MACHINE_CODE(WRITE_CODE);
32050 IF DEBUG
32060 THEN WRITE_MACHINE_CODE(WRITE_DEBUG);
32070 WRITE_MACHINE_CODE(WRITE_INTERNALS);
32080 IF LEVEL = 1
32090 THEN
32100 BEGIN
32110 WRITE_MACHINE_CODE(WRITE_FILEBLOCKS);
32120 WRITE_MACHINE_CODE(WRITE_SYMBOLS);
32130 WRITE_MACHINE_CODE(WRITE_LIBRARY);
32140 WRITE_MACHINE_CODE(WRITE_START);
32150 WRITE_MACHINE_CODE(WRITE_END)
32160 END
32170 END
32180 END (*BODY*) ;
32190
32200 BEGIN
32210 (*BLOCK*)
32220 NEW(HEAPMARK);
32230 DP := TRUE; TESTPACKED := FALSE; FORWARD_PROCEDURES := NIL; CURRENT_JUMP := 0;
32240 REPEAT
32250 WHILE SY IN BLOCKBEGSYS - [BEGINSY] DO
32260 BEGIN
32270 IF SY = LABELSY
32280 THEN
32290 BEGIN
32300 INSYMBOL; LABELDECLARATION
32310 END;
32320 IF SY = CONSTSY
32330 THEN
32340 BEGIN
32350 INSYMBOL; CONSTANTDECLARATION
32360 END;
32370 IF SY = TYPESY
32380 THEN
32390 BEGIN
32400 INSYMBOL; TYPEDECLARATION
32410 END;
32420 LCPAR := LC;
32430 IF SY = VARSY
32440 THEN
32450 BEGIN
32460 INSYMBOL; VARIABLEDECLARATION
32470 END;
32480 IF (LEVEL > 1) AND (SY = INITPROCSY)
32490 THEN ERRANDSKIP(363,BLOCKBEGSYS - [INITPROCSY]);
32500 IF LEVEL = 1
32510 THEN
32520 BEGIN
32530 WHILE SY = INITPROCSY DO
32540 BEGIN
32550 INSYMBOL ;
32560 IF SY <> SEMICOLON
32570 THEN ERRANDSKIP(156,[BEGINSY])
32580 ELSE INSYMBOL ;
32590 IF SY = BEGINSY
32600 THEN
32610 BEGIN
32620 NEW(GLOBMARK); INITGLOBALS := TRUE ;
32630 INSYMBOL ; BODY(FSYS + [SEMICOLON,ENDSY]) ;
32640 IF SY = SEMICOLON
32650 THEN INSYMBOL
32660 ELSE ERROR(166) ;
32670 INITGLOBALS := FALSE; DISPOSE(GLOBMARK)
32680 END
32690 ELSE ERROR(201)
32700 END ;
32710 LCMAIN := LC; TESTPACKED := FALSE
32720 END;
32730 WHILE SY IN [PROCEDURESY,FUNCTIONSY] DO
32740 BEGIN
32750 LSY := SY; INSYMBOL; PROCEDUREDECLARATION(LSY=PROCEDURESY)
32760 END;
32770 WHILE FORWARD_PROCEDURES <> NIL DO
32780 WITH FORWARD_PROCEDURES^ DO
32790 BEGIN
32800 IF FORWDECL
32810 THEN ERROR_WITH_TEXT(465,NAME);
32820 FORWARD_PROCEDURES := TESTFWDPTR
32830 END;
32840 SKIPIFERR([BEGINSY],201,FSYS)
32850 END;
32860 DP := FALSE;
32870 IF SY = BEGINSY
32880 THEN INSYMBOL
32890 ELSE ERROR (201);
32900 BODY(FSYS + [CASESY]);
32910 SKIPIFERR(LEAVEBLOCKSYS,166,FSYS)
32920 UNTIL SY IN LEAVEBLOCKSYS;
32930 DISPOSE(HEAPMARK)
32940 END (*BLOCK*) ;
32950
32960 BEGIN (* COMPILE *)
32970
32980 WRITELN(TTY); WRITE(TTY, HEADER:6, ': ',OBJECT_FILE:6); BREAK(TTY);
32990 ERROR_IN_HEADING := TRUE;
33000 GETNEXTLINE; CH := ' '; INSYMBOL; RESET_POSSIBLE := FALSE;
33010
33020 NEW( CODE_ARRAY, PDP10CODE: CODE_SIZE );
33030 NEW( CODE_REFERENCE: CODE_SIZE );
33040 NEW( CODE_RELOCATION: CODE_SIZE );
33050
33060 (*******************************************************************************************
33070 *
33080 * <PROGRAM LIBRARY> ::= [<OPTION SEQUENCE>] [<PROGRAM>]*
33090 * <PROGRAM> ::= <PROGRAM HEADING><BLOCK>.
33100 * <PROGRAM HEADING> ::= PROGRAM <PROGRAMNAME>
33110 * [,<ENTRY>]*
33120 * [(<FILE IDENTIFIER>[,<FILE IDENTIFIER>]* )];
33130
33140 * <OPTION SEQUENCE> ::= ( *$ <OPTION>[,<OPTION>]* <ANY COMMENT> * )
33150 * <OPTION> ::= <LETTER><SIGN>
33160 * <LETTER> ::= [D, E, L, P, T, U]
33170 * <SIGN> ::= [+, -]
33180 *
33190 * <PROGRAMNAME> ::= <IDENTIFIER>
33200 * <FILE IDENTIFIER> ::= <IDENTIFIER>
33210 * <ENTRY> ::= <IDENTIFIER>
33220 *
33230 ************************************ COMPILER OPTIONS ************************************
33240 *
33250 * DEC-10 PASCAL FUNCTION DEFAULT
33260 *
33270 * [NO]LIST(+) - GENERATE LIST FILE OFF
33280 * [NO]CODE L+/L- LIST OBJECT CODE OFF
33290 * [NO]CHECK T+/T- PERFORM RUNTIME CHECKS ON
33300 * [NO]DEBUG D+/D-, P+/P-($) GENERATE DEBUG INFORMATION
33310 * INCLUDING POST-MORTEM DUMP OFF
33320 * [NO]COMPILE(+) - COMPILE THE FILE ON
33330 * [NO]EXTERN E+/E-(@) ALL LEVEL-1 PROCEDURES
33340 * AND FUNCTIONS MAY BE DE-
33350 * CLARED AS "EXTERN" BY OTHER
33360 * PROGRAMS. THESE ENTRIES MUST
33370 * BE DEFINED IN THE PROGRAM
33380 * HEADING ADDITIONALLY OFF
33390 * [NO]CARD U+/U-(@) ONLY 72 CHARS OF THE SOURCE
33400 * LINE ARE ACCEPTED (CARD FORMAT) OFF
33410 * FORTIO I+/I- ENABLE FORTRAN-I/O IN EXTERNAL
33420 * FORTRAN PROGRAMS OFF
33430 * CODESIZE:N SN MAXIMUM NUMBER OF
33440 * CODE WORDS FOR A BODY CIXMAX
33450 * RUNCORE:N RN SIZE OF LOW-SEGMENT LOW-BREAK
33460 * FILE:N FN THIS OPTION IS
33470 * NECESSARY IF FILES ARE
33480 * DECLARED IN EXTERNAL PROGRAMS.
33490 * N IS THE NUMBER OF FILES
33500 * ALREADY DECLARED IN THE MAIN
33510 * (AND/OR OTHER EXTERNAL)
33520 * PROGRAM(S) PLUS 1 0
33530 * [NO]CREF(+) - GENERATE CROSS REFERENCE LIST OFF
33540 * [NO]LINK - CALL LINK-10 AFTER COMPILATION OFF
33550 * [NO]EXECUTE - LOAD AND RUN COMPILED PROGRAM OFF
33560 * REGISTER:N XN HIGHEST REGISTER USED
33570 * TO PASS PARAMETERS STDPARREGCMAX
33580 *
33590 * SWITCHES MARKED WITH A (+) ARE ALSO PART OF THE DECSYSTEM-10 CONCISE COMMAND
33600 * LANGUAGE. THE OTHERS MUST BE ENCLOSED IN "()" IF SPECIFIED
33610 * IN A COMPILE-, LOAD-, EXECUTE- OR DEBUG-COMMAND-STRING,
33620 * E.G.: COMPILE PASRL1=PASCAL.PAS(DEBUG/EXTERN)/LIST/COMPILE
33630 *
33640 * SWITCHES MARKED WITH ($) OR (@) MUST BE SPECIFIED FOR THE FIRST TIME BEFORE THE
33650 * <PROGRAM HEADING>. THOSE WITH (@) CANNOT BE RE-DEFINED AGAIN INSIDE A <PROGRAM>,
33660 * THOSE WITH ($) MIGHT BE RE-DEFINED INSIDE A <PROGRAM> OR
33670 * <PROGRAM LIBRARY>. ALL OTHER SWITCHES CAN BE DEFINED AND
33680 * RE-DEFINED ANYWHERE INSIDE A PROGRAM.
33690 *
33700 *******************************************************************************************)
33710
33720
33730 IF EXTERNAL
33740 THEN
33750 BEGIN
33760 LC := LOW_START; LCMAIN := LC;
33770 WHILE SFILEPTR <> NIL DO
33780 WITH SFILEPTR^, FILEIDENT^ DO
33790 BEGIN
33800 VADDR := 0; SFILEPTR := NEXTFTP
33810 END;
33820 SFILEPTR := FILEPTR
33830 END;
33840
33850 IF SY = PROGRAMSY
33860 THEN
33870 BEGIN
33880 INSYMBOL;
33890 IF SY = IDENT
33900 THEN
33910 BEGIN
33920 PROGRAMNAME := ID; ESCAPE := FALSE;
33930 WHILE (ENTRIES < ENTRYMAX) AND (SY = IDENT) AND NOT ESCAPE DO
33940 BEGIN
33950 ENTRIES := ENTRIES + 1;
33960 ENTRY[ ENTRIES ] := ID;
33970 INSYMBOL;
33980 IF SY = COMMA
33990 THEN
34000 BEGIN
34010 INSYMBOL;
34020 IF SY <> IDENT
34030 THEN
34040 BEGIN
34050 ESCAPE := TRUE; ERROR(209)
34060 END
34070 END
34080 ELSE
34090 IF NOT (SY IN [SEMICOLON,LPARENT])
34100 THEN
34110 BEGIN
34120 ESCAPE := TRUE; ERROR(156)
34130 END
34140 END;
34150 IF SY = LPARENT
34160 THEN
34170 BEGIN
34180 REPEAT
34190 INSYMBOL;
34200 IF SY = IDENT
34210 THEN
34220 BEGIN
34230 NEW(LPARMPTR);
34240 IF PARMPTR = NIL
34250 THEN PARMPTR := LPARMPTR;
34260 WITH LPARMPTR^ DO
34270 BEGIN
34280 FILEID := ID; FILEIDPTR := NIL;
34290 FOR I := 1 TO 2 DO
34300 IF FILEID = NA[STDFILE,I]
34310 THEN FILEIDPTR := STDFILEPTR[I];
34320 NEXTPTP := NIL;
34330 IF BACKWPARMPTR <> NIL
34340 THEN BACKWPARMPTR^.NEXTPTP := LPARMPTR;
34350 BACKWPARMPTR := LPARMPTR; INSYMBOL;
34360 IF (SY IN [MULOP,ADDOP]) AND (OP IN [MUL,PLUS])
34370 THEN
34380 BEGIN
34390 IF OP = PLUS
34400 THEN ERROR(169);
34410 INPUTFILE := TRUE; INSYMBOL
34420 END
34430 END
34440 END
34450 ELSE (*SY <> IDENT*)
34460 ERROR(209)
34470 UNTIL SY <> COMMA;
34480 IF SY <> RPARENT
34490 THEN ERRANDSKIP(152,BLOCKBEGSYS)
34500 ELSE
34510 BEGIN
34520 INSYMBOL;
34530 SKIPIFERR([SEMICOLON],156,BLOCKBEGSYS)
34540 END
34550 END
34560 ELSE (*SY <> LPARENT*)
34570 SKIPIFERR([SEMICOLON],156,BLOCKBEGSYS)
34580 END
34590 ELSE (*SY <> IDENT*)
34600 ERRANDSKIP(209,BLOCKBEGSYS)
34610 END
34620 ELSE (*SY <> PROGRAMSY*)
34630 ERRANDSKIP(318,BLOCKBEGSYS);
34640
34650 IF SY = SEMICOLON
34660 THEN INSYMBOL;
34670
34680 IF NOT ERROR_FLAG
34690 THEN
34700 BEGIN
34710 WRITE(TTY, ' [', PROGRAMNAME);
34720 IF (ENTRIES > 1) AND EXTERNAL
34730 THEN
34740 BEGIN
34750 WRITE(TTY,': '); I := 2;
34760 LOOP
34770 WRITE(TTY,ENTRY[I])
34780 EXIT IF I >= ENTRIES;
34790 I := I + 1;
34800 WRITE(TTY,', ')
34810 END
34820 END;
34830 WRITELN(TTY, ']');
34840 BREAK(TTY)
34850 END;
34860
34870 BLOCK(NIL,BLOCKBEGSYS + STATBEGSYS-[CASESY],[PERIOD,COLON]);
34880
34890 ERROR_EXIT := TRUE; ENDOFLINE;
34900
34910 111:
34920
34930 IF LPTFILE
34940 THEN
34950 BEGIN
34960 WRITELN(LIST);
34970 WRITELN(LIST,ERRORCOUNT:4,' ERROR(S) DETECTED');
34980 WRITELN(LIST)
34990 END;
35000 WRITELN(TTY);
35010 WRITELN(TTY,ERRORCOUNT:4,' ERROR(S) DETECTED');
35020 WRITELN(TTY);
35030
35040 IF NOT ERROR_FLAG
35050 THEN
35060 BEGIN
35070 CORE[1] := HIGHEST_CODE-HIGH_START; CORE[2] := CORE[1] MOD 1024;
35080 CORE[1] := CORE[1] DIV 1024;
35090 IF LPTFILE
35100 THEN WRITELN(LIST,'HIGHSEG: ',CORE[1]:3,'K + ',CORE[2]:4,' WORD(S)');
35110 WRITELN(TTY,'HIGHSEG: ',CORE[1]:3,'K + ',CORE[2]:4,' WORD(S)');
35120 CORE[1] := LCMAIN DIV 1024; CORE[2] := LCMAIN MOD 1024;
35130 IF LPTFILE
35140 THEN
35150 BEGIN
35160 WRITELN(LIST,'LOWSEG : ',CORE[1]:3,'K + ',CORE[2]:4,' WORD(S)'); WRITELN(LIST)
35170 END;
35180 WRITELN(TTY,'LOWSEG : ',CORE[1]:3,'K + ',CORE[2]:4,' WORD(S)'); WRITELN(TTY);
35190 END;
35200
35210 RTIME[0] := CLOCK-RTIME[0];
35220 RTIME[1] := RTIME[0] DIV 60000;
35230 RTIME[2] := (RTIME[0] MOD 60000) DIV 1000;
35240 RTIME[3] := (RTIME[0] MOD 60000) MOD 1000;
35250 IF LPTFILE
35260 THEN WRITELN(LIST,'RUNTIME: ',RTIME[1]:3,':',RTIME[2]:2,'.',RTIME[3]:3) ;
35270 WRITELN(TTY,'RUNTIME: ',RTIME[1]:3,':',RTIME[2]:2,'.',RTIME[3]:3,BEL);
35280 BREAK(TTY);
35290
35300 DISPOSE( CODE_ARRAY, PDP10CODE: CODE_SIZE )
35310
35320 END (* COMPILE *);
35330
35340 PROCEDURE ENTERSTDTYPES;
35350
35360 PROCEDURE ENTERSTDSTRING(VAR STRINGPTR: STP; LOWBND, HIGHBND: INTEGER);
35370 VAR
35380 LBTP: BTP; LSP: STP;
35390
35400 BEGIN
35410 NEW(LSP,SUBRANGE);
35420 WITH LSP^ DO
35430 BEGIN
35440 RANGETYPE := INTPTR; VMIN.IVAL := LOWBND; VMAX.IVAL := HIGHBND;
35450 SELFSTP := NIL; SIZE := 1; BITSIZE := BITMAX
35460 END;
35470 NEW(STRINGPTR,ARRAYS);
35480 WITH STRINGPTR^ DO
35490 BEGIN
35500 ARRAYPF := TRUE; ARRAYBPADDR := 0; SELFSTP := NIL;
35510 AELTYPE := ASCIIPTR; INXTYPE := LSP; SIZE := (HIGHBND-LOWBND+5) DIV 5;
35520 BITSIZE := BITMAX
35530 END;
35540 NEW(LBTP);
35550 WITH LBTP^ DO
35560 BEGIN
35570 LAST := LASTBTP; ARRAYSP := STRINGPTR;
35580 BITSIZE := 7; LASTBTP := LBTP
35590 END;
35600 WITH ARRAYBPS[7], ABYTE DO
35610 BEGIN
35620 SBITS := 7; PBITS := BITMAX; DUMMYBIT := 0;
35630 IBIT := 0; IREG := REG1; RELADDR := 0;
35640 BYTEMAX := 6; STATE := REQUESTED
35650 END
35660 END;
35670
35680 BEGIN
35690
35700 (*STANDARD TYPES*)
35710 (****************)
35720
35730 NEW(INTPTR,SCALAR,STANDARD); (*INTEGER*)
35740 WITH INTPTR^ DO
35750 BEGIN
35760 SIZE := 1;BITSIZE := BITMAX; SELFSTP := NIL
35770 END;
35780 NEW(REALPTR,SCALAR,STANDARD); (*REAL*)
35790 WITH REALPTR^ DO
35800 BEGIN
35810 SIZE := 1;BITSIZE := BITMAX; SELFSTP := NIL
35820 END;
35830 NEW(ASCIIPTR,SCALAR,STANDARD); (*ASCII*)
35840 WITH ASCIIPTR^ DO
35850 BEGIN
35860 SIZE := 1;BITSIZE := 7; SELFSTP := NIL
35870 END;
35880 NEW(BOOLPTR,SCALAR,DECLARED); (*BOOLEAN*)
35890 WITH BOOLPTR^ DO
35900 BEGIN
35910 SIZE := 1;BITSIZE := 1; SELFSTP := NIL
35920 END;
35930 NEW(NILPTR,POINTER); (*NIL*)
35940 WITH NILPTR^ DO
35950 BEGIN
35960 ELTYPE := NIL; SIZE := 1; BITSIZE := 18; SELFSTP := NIL
35970 END;
35980 NEW(ANYFILEPTR,FILES); (*"ANY FILE"*)
35990 WITH ANYFILEPTR^ DO
36000 BEGIN
36010 FILTYPE := NIL; SIZE := 0; BITSIZE := 0; SELFSTP := NIL
36020 END;
36030 NEW(CHARPTR,SUBRANGE); (*CHAR*)
36040 WITH CHARPTR^ DO
36050 BEGIN
36060 SIZE := 1; BITSIZE := 7; SELFSTP := NIL;
36070 RANGETYPE := ASCIIPTR; VMIN.IVAL := ORD(' ');
36080 VMAX.IVAL := ORD('_')
36090 END;
36100 NEW(TEXTPTR,FILES); (*TEXT*)
36110 WITH TEXTPTR^ DO
36120 BEGIN
36130 FILTYPE := CHARPTR; SIZE := 1+SIZEOFFILEBLOCK; BITSIZE := BITMAX;
36140 FILE_MODE := ASCII_MODE; FILEPF := TRUE; SELFSTP := NIL;
36150 FILE_FORM := TEXT_FILE;
36160 END;
36170
36180 ENTERSTDSTRING(ALFAPTR,1,ALFALENGTH);
36190 ENTERSTDSTRING(PACKC9PTR,1,9);
36200 ENTERSTDSTRING(PACKC8PTR,1,8);
36210 ENTERSTDSTRING(PACKC6PTR,1,6);
36220 ENTERSTDSTRING(PACKC5PTR,1,5);
36230
36240 SLASTBTP := LASTBTP
36250
36260 END (*ENTERSTDTYPES*) ;
36270
36280 PROCEDURE ENTERSTDNAMES;
36290 VAR
36300 CP: CTP;
36310 I,J: INTEGER;
36320 LFILEPTR: FTP;
36330 LCSP: CSP;
36340
36350 PROCEDURE ENTERSTDPROCFUNC(FINDEX: INTEGER; FIDCLASS: IDCLASS; FIDTYPE: STP; FNEXT: CTP);
36360 VAR
36370 I: INTEGER; LCP: CTP; NAMEIX: NAMEKIND;
36380 BEGIN
36390 IF FIDCLASS = FUNC
36400 THEN
36410 BEGIN
36420 NAMEIX := DECLFUNC; NEW(LCP,FUNC,DECLARED,ACTUAL)
36430 END
36440 ELSE
36450 BEGIN
36460 NAMEIX := DECLPROC; NEW(LCP,PROC,DECLARED,ACTUAL)
36470 END;
36480 WITH LCP^ DO
36490 BEGIN
36500 IDTYPE := FIDTYPE; NEXT := FNEXT; FORWDECL := FALSE; HIGHEST_REGISTER := STDPARREGCMAX;
36510 PFLEV := 0; PFADDR := 0; PFCHAIN := EXTERNPFPTR; EXTERNPFPTR := LCP; EXTERNDECL := TRUE;
36520 FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0; LANGUAGE := EXTLANGUAGE[NAMEIX,FINDEX];
36530 EXTERNALNAME := EXTNA[NAMEIX,FINDEX]; NAME := NA[NAMEIX,FINDEX];
36540 END;
36550 ENTERID(LCP)
36560 END;
36570
36580 PROCEDURE ENTERSTDPARAMETER(FIDTYPE: STP; FIDKIND: IDKIND; FNEXT: CTP; FADDR: INTEGER);
36590 BEGIN
36600 NEW(CP,VARS);
36610 WITH CP^ DO
36620 BEGIN
36630 NAME := ' '; IDTYPE := FIDTYPE;
36640 VKIND := FIDKIND; NEXT := FNEXT; VLEV := 1; VADDR := FADDR
36650 END
36660 END;
36670
36680 PROCEDURE ENTERSTDID(FIDCLASS: IDCLASS; FNAME: ALFA; FIDTYPE: STP; FNEXT: CTP; FIVAL: INTEGER);
36690 BEGIN
36700 NEW(CP);
36710 WITH CP^ DO
36720 BEGIN
36730 KLASS := FIDCLASS; NAME := FNAME; IDTYPE := FIDTYPE; NEXT := FNEXT;
36740 IF FIDCLASS = KONST
36750 THEN VALUES.IVAL := FIVAL
36760 END;
36770 ENTERID(CP)
36780 END;
36790
36800 BEGIN
36810
36820 (*STANDARDNAMES:*)
36830 (****************)
36840
36850 ENTERSTDID(TYPES,'INTEGER ',INTPTR,NIL,0);
36860 ENTERSTDID(TYPES,'REAL ',REALPTR,NIL,0);
36870 ENTERSTDID(TYPES,'CHAR ',CHARPTR,NIL,0);
36880 ENTERSTDID(TYPES,'ASCII ',ASCIIPTR,NIL,0);
36890 ENTERSTDID(TYPES,'BOOLEAN ',BOOLPTR,NIL,0);
36900 ENTERSTDID(TYPES,'TEXT ',TEXTPTR,NIL,0);
36910 ENTERSTDID(TYPES,'ALFA ',ALFAPTR,NIL,0);
36920 ENTERSTDID(KONST,'NIL ',NILPTR,NIL,377777B);
36930 ENTERSTDID(KONST,'ALFALENGTH',INTPTR,NIL,10);
36940 ENTERSTDID(KONST,'MAXINT ',INTPTR,NIL,377777777777B);
36950 ENTERSTDID(KONST,'MININT ',INTPTR,NIL,-MAXINT - 1);
36960
36970 NEW(LCSP,REEL); LCSP^.INTVAL := 377777777777B;
36980 ENTERSTDID(KONST,'MAXREAL ',REALPTR,NIL,ORD(LCSP));
36990 NEW(LCSP,REEL); LCSP^.INTVAL := 400000000B;
37000 ENTERSTDID(KONST,'SMALLREAL ',REALPTR,NIL,ORD(LCSP));
37010
37020 CP := NIL;
37030 FOR I := 1 TO 2 DO
37040 ENTERSTDID(KONST,NA[STDCONST,I],BOOLPTR,CP,I-1);
37050 WITH BOOLPTR^ DO
37060 BEGIN
37070 FCONST := CP; VECTORADDR := 0; VECTORCHAIN := 0;
37080 TLEV := 0; REQUEST := FALSE; NEXTSCALAR := NIL;
37090 DIMENSION := 1
37100 END;
37110 DECLSCALPTR := BOOLPTR;
37120
37130 CP := NIL;
37140 FOR I := 3 TO 35 DO
37150 ENTERSTDID(KONST,NA[STDCONST,I],ASCIIPTR,CP,I-3);
37160 ENTERSTDID(KONST,NA[STDCONST,36],ASCIIPTR,CP,177B);
37170
37180 (*INPUT,OUTPUT,TTY,TTYOUTPUT*)
37190
37200 FOR I := 1 TO NAMAX[STDFILE] DO
37210 BEGIN
37220 NEW(CP,VARS);
37230 STDFILEPTR[I] := CP;
37240 WITH CP^ DO
37250 BEGIN
37260 NAME := NA[STDFILE,I]; IDTYPE := TEXTPTR; CHANNEL := I-1;
37270 VKIND := ACTUAL; NEXT := NIL; VLEV := 0;
37280 VADDR:= LC;
37290 LC:=LC+IDTYPE^.SIZE;
37300 NEW(LFILEPTR) ;
37310 WITH LFILEPTR^ DO
37320 BEGIN
37330 NEXTFTP := FILEPTR ;
37340 FILEIDENT := CP
37350 END ;
37360 FILEPTR := LFILEPTR
37370 END;
37380 ENTERID(CP)
37390 END;
37400
37410 (* GET,GETLN,PUT,PUTLN,RESET,REWRITE,READ,READLN,
37420 WRITE,WRITELN,PACK,UNPACK,NEW,GETLINR,
37430 PAGE,PROTECTION,RUN,DATE,TIME,DISPOSE,
37440 HALT,GETSEG,PUTSEG,MESSAGE,LINELIMIT*)
37450
37460 FOR I := 1 TO NAMAX[STDPROC] DO
37470 BEGIN
37480 NEW(CP,PROC,STANDARD);
37490 WITH CP^ DO
37500 BEGIN
37510 NAME := NA[STDPROC,I]; IDTYPE := NIL;
37520 NEXT := NIL; KEY := I
37530 END;
37540 ENTERID(CP)
37550 END;
37560
37570 (* CLOCK,ABS,SQR,ODD,ORD,CHR,PRED,SUCC,EOF,EOLN,REALTIME,CARD,EXPO,
37580 LOWERBOUND,UPPERBOUND,MIN,MAX,FIRST,LAST,EOS*)
37590
37600 FOR I := 1 TO NAMAX[STDFUNC] DO
37610 BEGIN
37620 NEW(CP,FUNC,STANDARD);
37630 WITH CP^ DO
37640 BEGIN
37650 NAME := NA[STDFUNC,I]; IDTYPE := NIL;
37660 NEXT := NIL; KEY := I
37670 END;
37680 ENTERID(CP)
37690 END;
37700
37710
37720 (* COS,EXP,SQRT,ALOG,ATAN,ALOG10,
37730 SIND,COSD,SINH,COSH,TANH,ASIN,ACOS,RAN,SIN*)
37740
37750 ENTERSTDPARAMETER(REALPTR,ACTUAL,NIL,2);
37760 FOR I := 1 TO 15 DO ENTERSTDPROCFUNC(I,FUNC,REALPTR,CP);
37770
37780 (* ROUND, EXPO *)
37790
37800 ENTERSTDPROCFUNC(16,FUNC,INTPTR,CP);
37810 ENTERSTDPROCFUNC(17,FUNC,INTPTR,CP);
37820
37830 (* OPTION *)
37840
37850 ENTERSTDPARAMETER(ALFAPTR,ACTUAL,NIL,2);
37860 ENTERSTDPROCFUNC(18,FUNC,BOOLPTR,CP);
37870
37880 (* TRUNC *)
37890
37900 ENTERSTDPARAMETER(REALPTR,ACTUAL,NIL,2);
37910 ENTERSTDPROCFUNC(20,FUNC,INTPTR,CP);
37920
37930 (* GETFILENAME *)
37940
37950 ENTERSTDPARAMETER(ALFAPTR,ACTUAL,NIL,6);
37960 ENTERSTDPARAMETER(PACKC6PTR,FORMAL,CP,5);
37970 ENTERSTDPARAMETER(INTPTR,FORMAL,CP,4);
37980 ENTERSTDPARAMETER(INTPTR,FORMAL,CP,3);
37990 ENTERSTDPARAMETER(PACKC9PTR,FORMAL,CP,2);
38000 ENTERSTDPARAMETER(ANYFILEPTR,FORMAL,CP,1);
38010 ENTERSTDPROCFUNC(1,PROC,NIL,CP);
38020
38030 (* GETOPTION *)
38040
38050 ENTERSTDPARAMETER(INTPTR,FORMAL,NIL,4);
38060 ENTERSTDPARAMETER(ALFAPTR,ACTUAL,CP,2);
38070 ENTERSTDPROCFUNC(2,PROC,NIL,CP);
38080
38090 (* GETSTATUS *)
38100
38110 ENTERSTDPARAMETER(PACKC6PTR,FORMAL,NIL,5);
38120 ENTERSTDPARAMETER(INTPTR,FORMAL,CP,4);
38130 ENTERSTDPARAMETER(INTPTR,FORMAL,CP,3);
38140 ENTERSTDPARAMETER(PACKC9PTR,FORMAL,CP,2);
38150 ENTERSTDPARAMETER(ANYFILEPTR,FORMAL,CP,1);
38160 ENTERSTDPROCFUNC(3,PROC,NIL,CP);
38170
38180 SEXTERNPFPTR := EXTERNPFPTR;
38190 SFILEPTR := FILEPTR;
38200 SDECLSCALPTR := DECLSCALPTR;
38210
38220 LCMAIN := LC
38230
38240 END (*ENTERSTDNAMES*) ;
38250
38260 PROCEDURE ENTERUNDECL;
38270 VAR
38280 I: INTEGER;
38290 BEGIN
38300 NEW(UTYPPTR,TYPES);
38310 WITH UTYPPTR^ DO
38320 BEGIN
38330 NAME := ' '; IDTYPE := NIL; NEXT := NIL
38340 END;
38350 NEW(UCSTPTR,KONST);
38360 WITH UCSTPTR^ DO
38370 BEGIN
38380 NAME := ' '; IDTYPE := NIL; NEXT := NIL;
38390 VALUES.IVAL := 0
38400 END;
38410 NEW(UVARPTR,VARS);
38420 WITH UVARPTR^ DO
38430 BEGIN
38440 NAME := ' '; IDTYPE := NIL; VKIND := ACTUAL;
38450 NEXT := NIL; VLEV := 0; VADDR := 0
38460 END;
38470 NEW(UFLDPTR,FIELD);
38480 WITH UFLDPTR^ DO
38490 BEGIN
38500 NAME := ' '; IDTYPE := NIL; NEXT := NIL; FLDADDR := 0;
38510 PACKF := NOTPACK
38520 END;
38530 NEW(UPRCPTR,PROC,DECLARED,ACTUAL);
38540 WITH UPRCPTR^ DO
38550 BEGIN
38560 NAME := ' '; IDTYPE := NIL; FORWDECL := FALSE;
38570 FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0;
38580 NEXT := NIL; EXTERNDECL := FALSE; PFLEV := 0; PFADDR := 0
38590 END;
38600 NEW(UFCTPTR,FUNC,DECLARED,ACTUAL);
38610 WITH UFCTPTR^ DO
38620 BEGIN
38630 NAME := ' '; IDTYPE := NIL; NEXT := NIL;
38640 FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0;
38650 FORWDECL := FALSE; EXTERNDECL := FALSE; PFLEV := 0; PFADDR := 0
38660 END
38670 END (*ENTERUNDECL*) ;
38680
38690 BEGIN (*PASCAL*)
38700 DATE(DAY); TIME(TIMEOFDAY);
38710 INIT_COMPILE;
38720
38730 (*ENTER STANDARD NAMES AND STANDARD TYPES:*)
38740 (******************************************)
38750
38760 LEVEL := 0; TOP := 0;
38770 WITH DISPLAY[0] DO
38780 BEGIN
38790 FNAME := NIL; OCCUR := BLCK
38800 END;
38810 ENTERSTDTYPES; ENTERSTDNAMES; ENTERUNDECL;
38820
38830 TOP := 1; LEVEL := 1;
38840 WITH DISPLAY[1] DO
38850 BEGIN
38860 FNAME := NIL; OCCUR := BLCK
38870 END;
38880
38890 GET_DIRECTIVES;
38900
38910 IF NOT OPTION('NOCOMPILE ')
38920 THEN
38930 BEGIN
38940 IF LPTFILE
38950 THEN
38960 BEGIN
38970 WRITELN(LIST,'PASCAL COMPILATION LIST PRODUCED BY ',HEADER,' ON ',DAY,' AT ',TIMEOFDAY); WRITELN(LIST)
38980 END;
38990
39000 LOOP
39010 COMPILE
39020 EXIT IF NOT EXTERNAL OR EOF(SOURCE);
39030 INIT_COMPILE
39040
39050 END
39060
39070 END (* IF NOT OPTION('NOCOMPILE ') *);
39080
39090 0:
39100 IF NOT ERROR_FLAG
39110 THEN
39120 BEGIN
39130 IF CROSS_REFERENCE
39140 THEN
39150 BEGIN
39160 IF LPTFILE
39170 THEN RESET(LIST) ; (* CLOSE LIST_FILE *)
39180 REWRITE(TEMPCORE,'CRO TMP');
39190 WRITE(TEMPCORE,SOURCE_FILE:6, '.' ,
39200 SOURCE_FILE[7],SOURCE_FILE[8],SOURCE_FILE[9], ',' ,
39210 OBJECT_FILE:6,'.NEW,',OBJECT_FILE:6,'.CRL');
39220 IF LOAD_AND_GO
39230 THEN WRITE(TEMPCORE,'/LINK');
39240 CALL('CROSS ',CROSS_DEVICE,CROSS_PPN,CROSS_CORE)
39250 END;
39260 IF LOAD_AND_GO
39270 THEN
39280 BEGIN
39290 WRITELN(TTY); BREAK(TTY);
39300 CALL('LINK ')
39310 END
39320 END
39330 ELSE
39340 BEGIN
39350 REWRITE(OBJECT);
39360 RESET(TEMPCORE,'LNK TMP')
39370 END
39380
39390 END (*PASCAL*).