Trailing-Edge
-
PDP-10 Archives
-
decuslib20-01
-
decus/20-0003/pascmp.pas
There are 4 other files named pascmp.pas in the archive. Click here to see a list.
%$L-,C-,D-,T-,V:001200000214B\
program pascmp;
include 'pasprm.pas'; (* set up tops10 and tops20 *)
%*********************************************************
* *
* *
* STEP-WISE DEVELOPMENT OF A PASCAL COMPILER *
* ****************************************** *
* *
* *
* STEP 5: SYNTAX ANALYSIS INCLUDING ERROR *
* HANDLING; CHECKS BASED ON DECLARA- *
* 15/3/73 TIONS; ADDRESS AND CODE GENERATION *
* FOR A HYPOTHETICAL STACK COMPUTER *
* *
* *
* AUTHOR: URS AMMANN *
* FACHGRUPPE COMPUTERWISSENSCHAFTEN *
* EIDG. TECHNISCHE HOCHSCHULE *
* CH-8006 ZUERICH *
* *
* CODE GENERATION FOR DECSYSTEM 10 BY *
* C.-O. GROSSE-LINDEMANN, F.-W. LORENZ, *
* H.-H. NAGEL, P.J. STIRL *
* *
* MODIFICATIONS TO GENERATE RELOCATABLE OBJECT CODE *
* BY E. KISICKI (DEC 74) *
* *
* DEBUG SYSTEM BY P. PUTFARKEN (DEC 74) *
* *
* INSTITUT FUER INFORMATIK, D-2 HAMBURG 13, *
* SCHLUETERSTRASSE 70 / GERMANY *
* *
* *
*********************************************************\
% HOW TO GENERATE A NEW PASCAL COMPILER
SOURCES:
A) ASCII: PASREL.PAS
RUNTIM.MAC
DEBSUP.MAC
DEBUG .PAS
B) BINARY: PASREL.SHR
PASREL.LOW
PASLIB.REL (CHECK INITPROCEDURE "SEARCH LIBRARIES")
! IF THE NEW COMPILER SHOULD NOT BE MADE AVAILABLE FOR GENERAL USE ON SYS,
! ENTER THE APPROPIATE DIRECTORY SPECIFICATIONS IN INITPROCEDURE "SEARCH LIBRARIES"
STEP ACTION
0 SAVE ALL SOURCE FILES ON DECTAPES!!
1 .COPY PASLBN.REL=PASLIB.REL
2 IF THERE ARE NO CHANGES TO RUNTIM.MAC, DEBSUP.MAC, OR DEBUG.PAS
THEN GOTO STEP 9
3 UPDATE RUNTIM.MAC
4 ASSEMBLE " --> RUNTIM.REL
5 UPDATE DEBSUP.MAC
6 ASSEMBLE " --> DEBSUP.REL
7 UPDATE DEBUG.PAS
.RUN PASREL
*DEBUG.PAS --> DEBUG.REL
8 .R FUDGE2
*PASLBN.REL=PASLBN.REL<RUNSP>,RUNTIM.REL<RUNSP>(R)$
*PASLBN.REL=PASLBN.REL<DEBSP>,DEBSUP.REL<DEBSP>(R)$
*PASLBN.REL=PASLBN.REL<DEBUG>,DEBUG.REL<DEBUG>(R)$
*^C
--> PASLBN.REL
9 UPDATE PASREL.PAS
UPDATE "HEADER" IN PASREL.PAS
IF THERE ARE NEW ENTRIES TO RUNSP OR DEBSP
CHECK
INITPROCEDURE "RUNTIME-, DEBUG-SUPPORTS", "SUPPORTS"
AND
PROCEDURE "SUPPORT"
10 .RUN PASREL
*PASREL.PAS --> PASREL.REL
11 .LOAD PASREL,/SEARCH PASLBN.REL
.SSAVE PASREL 36 --> PASREL.SHR
PASREL.LOW
36 K CORE ONLY IF NO RUNTIMECHECK (C-) AND NO DEBUG OPTION (D-) , OTHERWISE MORE !
12 .RENAME PAS1.PAS=PASREL.PAS
13 .RUN PASREL
*PAS1.PAS --> PAS1.REL
14 .LOAD PAS1,/SEARCH PASLBN.REL
.SSAVE PAS1 36 --> PAS1.SHR
PAS1.LOW
14.1 .RENAME PAS2.PAS=PAS1.PAS
14.2 .RUN PAS1
*PAS2.PAS --> PAS2.REL
14.3 .LOAD PAS2,/SEARCH PASLBN.REL
.SSAVE PAS2 36 --> PAS2.SHR
--> PAS2.LOW
15 .R FILCOM
*TTY:=PAS2.LOW,PAS1.LOW
NO DIFFERENCES ENCOUNTERED
*TTY:=PAS2.SHR,PAS1.SHR
FILE 1) DSK:PAS2.SHR CREATED: XXX
FILE 2) DSK:PAS1.SHR CREATED: XXX
400005 604163 XXXXXX 604163 XXXXXX XXXXXX
%FILES ARE DIFFERENT
16 .DELETE PASREL.*,PAS1.*,PAS2.REL,PASLIB.REL
.PRINT PAS2.LST
.RENAME PASREL.*=PAS2.*
.RENAME PASLIB.REL=PASLBN.REL
*******************************************************************\
%HINTS FOR INTERPRETING ABBREVIATED IDENTIFIERS
BRACK : BRACKET "[ ]" IX : INDEX
C : CURRENT L : LOCAL
C : COUNTER L : LEFT
CST : CONSTANT PARENT : "( )"
CTP : IDENTIFIER POINTER P/PTR : POINTER
EL : ELEMENT P/PROC : PROCEDURE
F : FORMAL R : RIGHT
F : FIRST S : STRING
F : FILE SY : SYMBOL
F/FUNC : FUNCTION V : VARIABLE
G : GLOBAL V : VALUE
ID : IDENTIFIER
REL : RELATIVE REL : RELOCATION\
(*LOCAL CHANGE HISTORY
1 CLEAN UP COMMENT SCANNING AND ALLOW /* */ BRACKETS.
NOTE THAT THIS \ WOULD HAVE TERMINATED THIS COMMENT
PRIOR TO FIX.
2 INCREASE STACKANDHEAP, GET CORE IF NEEDED ON PROGRAM
ENTRY, FIX PARAMETER PASSING BUG, LOAD PASREL FROM
SYS: INSTEAD OF DSK:, GENERATE FLOAT AND FIX INLINE.
(FROM HEDRICK)
NB: RUNTIM has now been modified to pass all characters,
including control characters as well as lower case.
It no longer turns tabs into spaces. Thus it was
necessary to put this file through a program that
expanded tabs into spaces when they were in strings.
Thus FILCOM with the old version should specify /S
or lots of irrelevant differences will be found.
3 MAP LOWER CASE TO UPPER EXCEPT IN STRINGS. (DOESN'T
SOLVE THE PROBLEM ABOUT SETS, THOUGH.) HEDRICK.
4 use SCAN for file spec's, and fix to be called by
COMPIL. Hedrick.
5 add /CREF switch. Hedrick.
6 allow PROGRAM statement. Syntax check but ignore it.
fix bug that caused lower case char. after a string to put compiler in loop
allow <> for #
allow LABEL declaration. Syntax check bug ignore it.
with /CREF/OBJ put only 3 instructions per line (4
overflow a LPT line)
use standard PACK and UNPACK
catch illegal characters
7 add /HEAP switch for size of stack and heap
treat lower case as upper in sets
10 Add STRSET and STRWRITE - equivalent to RESET and
REWRITE, but sets I/O into string
also GETINDEX, CLOSE, ROUND, CALLI
ALSO REDID RESET/REWRITE TO TAKE GOOD FILE NAMES
11 Modify compiler to use new RESET/REWRITE.
12 Make PASCAL programs self-expanding
13 ADD DDT SYMBOL NAMES FOR ROUTINES(BLOCK-STRUCTURED)
use PROGRAM name as module and entry name
allow strset/write on non-TEXT files
add opt. 4th arg to strset/write: limit
14 allow read of string - gets rest of line
add rename,dismiss,update,dumpin/out,useti/o, and xblock arg to
reset and friends
15 a few more arg's to some runtimes
16 detect unexpected EOF
17 DECUS VERSION - CHANGE DDT SYMBOLS TO BE OK FOR DEC DDT
20 CMU patch: do packed struct. correctly. Did not adopt:
(1) replace CAMG, etc., for text (their fix did unnecessary work for
the most common cases, and didn't get all of the obscure ones)
(2) use Knuth's defn of MOD (the one here is so much faster, who care about
negative numbers?)
(3) clean up variants in NEW (they say it is unnecessary)
Also: fix ill mem ref if undef var first after READ
21 allow PROGRAM <name>; (i.e. no file list)
allow null field list in record (for null variant, mainly)
fix MOD. Much cleaner fix than CMUs. Usually adds just one instruction
fix compare of PACKED ARRAY OF CHAR. Get it all (I hope)
keep new from storing tag if no id (CMU's fix)
implement +,*,- as set operators
22 restore MOD to be REM (Cyber does it that way)
fix all my added file things to use GETFN to scan
file name, so we properly handle external files, etc.
fix callnonstandard to pass external files
fix writewriteln so doesn't ill mem ref on undef file
23 change enterbody to always zero locals. Needed to ensure
that certain comparisons work, but a good thing anyway.
if typechecking is on, check for following nil or 0 pointer
24 do not allow comparisons except those in manual.
means we don't have to zero locals on proc entry, ever.
add LOC(<proc>) that returns address of proc or ftn
add S:<integer> and H:<integer> comments, to set starting
addr of stack and heap respectively
change starting code to not disturb %rndev, etc. on restart
25 add /ZERO (and $z) to control whether locals initialized
to zero. Useful mostly to help find uninit.'ed pointers.
26 allow record as extended lookup block
add error message's for ext. lookup block
don't check file pointers as if they were pointers!
use getfn instead of getfilename in break,breakin,
and close, to allow non-ascii files
27 add NEWZ that does what NEW used to (zeros what it gets)
30 fix NEW with : syntax, per Nagel.
31 FIX ILL MEM REF IN READREADLN
ADD ERR MSG FOR ASSIGN TO FTN NAME OUTSIDE BODY
32 add APPEND
33 full implementation of PROGRAM statement
version numbering of output files and program
allow proc and func as parameters
remove LOC (subsumed by above)
add $V directive for version number
34 allow list of entry points in PROGRAM statement
35 fix error recovery in BLOCK, especially for /NOMAIN
36 ALLOW DEBUGGING MULTIPLE FILES
remove T- option
NB: I have not removed the variables for T-, and also
supports exist for indeb. and exdeb., though they
are no longer used in PASCMP.
37 fix bug in static link for level one proc's
40 use RESDEV as external name for DISMISS
by default put request for PASLIB before FORLIB
improve format of /OBJECT listing
fix arg's to predefined functions
fix comparison of unpacked strings
41 make it restartable
change kludge for file OUTPUT
42 allow variable records for GET,PUT,and DUMPx
Currently DUMPx implemented in kludgey way.
43 add 5 locations to file block for new runtimes
add PUTX
add optional arg to useti
allow 12 digit octal number
44 Add SETPOS and CURPOS to compiler
45 Add NEXTBLOCK to compiler and make check for
AC overlap with APPEND,UPDATE
46 Repair CALLI to use 1 for true, and accept all
possible argument formats.
47 Add some more functions
Repair calculations for NEW with packed arrays
50 Generate correct code for 400000,,0
Reinitialize file ctl blocks at start
Don't open INPUT or OUTPUT unless asked
51 Allow mismatch of byte size for SETSTRING
Fix GETLINENR
52 Fixes from CMU:
To CALLNONSTANDARD: when depositing directly into
display, moved 2 ac's for all arg's of size 2,
without checking to see if VAR. Assumed AC was
unchanged by BLT.
To SIMPLEEXPRESSION: optimization sometimes negated
a real constant. If had been declared by CONST,
future ref's were to the negated quantity!
53 Problems with dynamic memory expansion:
Arbitrarily asked for 40b more locations above
end of stack (for runtimes). But some odd
procedure calls use more. Need to figure out
how much memory is used.
CORERR just allocated memory up to (P). Should
be 40(P), or however much is really needed.
So add STKOFFMAX, to keep track of how much
really needed. CORALLOC is addr of the test for
sufficient memory, fixed up.
54 More dynamic memory: Need to accumulate offsets
above top of stack, in case of
x(1,2,3,4,5,f(1,2,3,4,5,6)), etc., though an
actual problem seems a bit unlikely.
55 Add require source file feature
56 Clean up syntax for require file
57 add tops20 version
60 make tops20 strings work more like tops10
61 add jsys pseudo-runtime
add tops20 runtimes and restrict runtimes that work only on one system
add +*@ after file name to control gtfjn in tops20
62 make sure there is never data above the stack pointer
63 convert time, runtime, setuwp for tops20
64 input:/ for tops-20
empty entry in record
non-local goto's
fix procedure param's if not in ac's
65 allow extra semicolon in case
remove references to exit labels
66 speed up non-local goto's
67 fix external proc's as proc param's
70 fix ill mem ref if certain errors in type decl
71 make file name in fcb be 7 bit for tops20
72 make two fixup chains for 2 word constants, to
prevent giving LINK an ill mem ref
73 make new use getfn for file names, to get EXTERN files
74 allow new init. so tops10 version can work with emulator
75 fix non-loc goto's - typo made goto chain bad
76 allow a set in reset/rewrite to specify bits.
allow break char set in read/readln
77 fix jsys and reset set arguments
100 fix ac usage in readreadln from strings
101 fix fltr and fix code generation
102 Add klcpu - put improved packed array code under it
103 Fix pointer to global symbol table in case that level
has already been output by some inner procedure
104 Check stack overflow
Check to be sure structures aren't too big
Range check subranges in for loop and value parameters
105 Use tables instead of -40B to convert from lower case
106 Make subranges of reals illegal
107 Abort creation of .REL file on all errors
110 Allow [x..y] set construct
111 Allow STRING and POINTER parameters to EXTERN proc's
112 Clrbfi when error detected. Bounds check sets [a..b]
113 Make real number reader handle exact things exactly
Don't demand foward type ref's resolved at end of require file
114 Write local fixups even if only non-loc gotos
Make CREF not say .FIELDID. for local gotos
maxint = 377777777777B
115 Make tops10=false, kl=false work (tenex)
116 IDRECSIZE entries for param, labelt type
Make NEXT NIL instead of 0 when not used, for COPYCTP
117 Fix enumerated type in record
120 Make initialization routine use JSP, for T20/Tenex so
don't have ill mem ref if emulator present
121 Initialize CODEARRAY: fix bollixed INITPROC's
122 KA's. This includes fixing COPYSTP so it doesn't
try to follow NIL pointers. Harmless if 377777 is a
legal address, but it isn't for KA's.
123 Do POPF when can't find included file, so close gets done.
124 Limit initprocedures to top level.
Initialize CREF off
125 Do POPF when expected eof inside included file.
126 Detect procedures not beginning with BEGIN
127 INit CREF to FALSE, fix [const..var] set construct
130 Fix KA bug wherein random word in core image is garbage
131 Move cixmax to pasprm.pas so tops20 can use big value
132 Replace KA10 with KACPU for op codes and NOVM for old
memory allocation.
133 Fix JSYS to allow functions within it. Garbaged stack.
134 Allow DELETE in Tops-10, too.
135 Fix LOG2 for big numbers. Prevent ill mem ref's in
PACK and UNPACK with syntax errors.
136 Add header line at top of each page with pg. number
137 Reset line no. to 1 at start of page.
Fix bug in set constructors for CHAR
140 Chnage order of SETMAP to closer to ASCII collating seq.
141 Fix problem where REGC gets messed up by array subscript
calculations when ONFIXEDREGC is in effect.
Detect overflow in number scanning with JFCL.
142 Make real number scanner scan anything legitimate
143 Redo I/O to string in Tops-10 for new runtimes and fix
onfixedregc code for packed arrays
144 Allow :/ in program and :@ in reset for Tops-10
145 Change external name of GET to GET. for Wharton
146 Reinit count in putrelcode to avoid garbage in .REL file
147 Lines start with 2 on new pages.
150 Fix bug in forward type references,
error recovery in fieldlist if garbage case type
symbol table in forward proc's for debugger
151 Fix reversed args in I,J:INTEGER in procedure decl.
152 Add DISPOSE
153 Fix some reg usage problems with DISPOSE
154 More reg usage problems with DISPOSE
155 Source file name in DEBUG block
156 Detect FTNNAME^.field := value. Only bare ftn name
allowed on LHS of assignment.
157 Add $A- to turn off arith check
160 Add compiler switch /ARITHCHECK
161 fix STRINg and POINTER
162 fix REGSIZE
163 fix TIME for Tops-20
164 use Polish fixups in CASE
165 in type decl, make sure ^THING gets local defn of THING,
even if it happens later and there is a higher level defn.
(This requires treating ^THING as forward always.)
166 make assignment to func id from inner func work
initialize frecvar in fieldlist, to prevent ill mem ref
with null record decl.
167 improvements to edit 165
170 more improvements to 165 (this time to error handling)
171 allow read into packed objects
allow read and write of binary files
make sure default file names don't use user-declared INPUT,
and OUTPUT
fix NEW of pointer that is part of packed array
172 option string as third arg of RESET, etc.
evaluate upper bound of FOR statement only once
173 allow files in any context; internal files
174 fix to initprocedures from Hisgen
175 make getfn take a param telling runtime validity check
needed. SETSTRING, etc., do not
176 better unterminated-comment error messages
177 fix AC allocation in GETFILENAME
200 fix addressing problem in loading file pointers
201 make most manipulation of zero size objects be no-op.
Previously one might stomp on the next variable.
202 insufficient initialization before RESET(TTY), etc.
fix POINTER passed by ref
203 fix glitch in edit 202
204 don't validity check the FCB for CLOSE, RCLOSE, and DISMISS
205 fix AC in RENAME
206 allow constants in WRITE statements for FILE OF INTEGER, etc.
207 fix AC in GETFILENAME (again...)
210 Allow 9 digit HEX numbers
211 Fix output of string constants in .REL file
212 Better error message if INPUT or OUTPUT redefined
213 Fix procedure exit code if there is local variable
214 Make debugger see locals of forward declared proc's
*)
CONST
HEADER = 'PASCAL %12(214)';
DISPLIMIT = 20; MAXLEVEL = 8;
STRGLGTH = 120; BITMAX = 36;
(* 43 - longer file block for new runtimes *)
SIZEOFFILEBLOCK=43B ; {plus size of component}
OFFSET=40B; %FUER SETVERARBEITUNG DER ASCIICHARACTER\
CHCNTMAX = 132; %MAXIMUM OF CHARACTERS IN ONE LINE\
LEFT = 2;RIGHT = 1;BOTH = 3;NO = 0;
%KONSTANTEN VON BODY: \
%*********************\
(* move cixmax to param file *)
HWCSTMAX = 377777B; LABMAX = 20;
(* 2 - increase default stack space *)
(* 7 - stackandheap now set by switch *)
(* 137 - fix set constructor for CHAR *)
MAXERR = 4; BASEMAX = 71; CHARMAX = 177B;
%ADDRESSES:
**********\
HAC=0; %HILFSREGISTER\
TAC=1; %HILFSREGISTER AUCH FUER BYTEPOINTER\
REGIN=1; %INITIALISE REGC\
PARREGCMAX=6; %HIGHEST REGISTER USED FOR PARAMETERS\
WITHIN=12; %FIRST REGISTER FOR WITHSTACK\
NEWREG=13; %LAST PLACE OF NEW-STACK\
BASIS=14; %BASIS ADDRESS STACK\
TOPP=15; %FIRST FREE PLACE IN DATASTACK\
PROGRST = 145B; %LOC 140B..144B RESERVED FOR DEBUG-PROGR.\
HIGHSTART=400000B;
MAXADDR=777777B;
TYPE
%DESCRIBING:\
%***********\
%BASIC SYMBOLS\
%*************\
SYMBOL = (IDENT,INTCONST,REALCONST,STRINGCONST,NOTSY,MULOP,ADDOP,RELOP,
LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON,PERIOD,ARROW,
COLON,BECOMES,LABELSY,CONSTSY,TYPESY,VARSY,VALUESY,FUNCTIONSY,
(* 6 - add PROGRAM statement *)
(* 56 - ADD INCLUDE *)
PROCEDURESY,SETSY,PACKEDSY,ARRAYSY,RECORDSY,FILESY,FORWARDSY,PROGRAMSY,INCLUDESY,
BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY,LOOPSY,
GOTOSY,EXITSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY,
EXTERNSY,PASCALSY,FORTRANSY,ALGOLSY,COBOLSY,
THENSY,OTHERSY,INITPROCSY,OTHERSSY);
OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,GEOP,GTOP,
NEOP,EQOP,INOP,NOOP);
SETOFSYS = SET OF SYMBOL;
(* 23 - check for bad pointer *)
(* 24 - ONLY CLEAR NEW WHEN TYPECHECKING *)
(* 104 - new tops10 stackoverflow *)
(* 152 - DISPOSE *)
SUPPORTS = (FIRSTSUPPORT,STACKOVERFLOW,DEBSTACK,BADPOINT,ALLOCATE,CLEARALLOC,DEALLOCATE,
(* 173 - internal files *)
WITHFILEDEALLOCATE,
(* 43 - add PUTX *)
(* 64 - non-loc goto *)
EXITGOTO,EXITPROGRAM,GETLINE,GETFILE,PUTLINE,PUTFILE,PUTXFILE,
(* 57 - Add strset and strwrite external routines *)
RESETFILE,REWRITEFILE,RESETSTRING,REWRITESTRING,GETCHARACTER,PUTPAGE,ERRORINASSIGNMENT,
(* 173 - internal files *)
FILEUNINITIALIZED,INITFILEBLOCK,
WRITEPACKEDSTRING,WRITESTRING,WRITEBOOLEAN,READCHARACTER,READINTEGER,READREAL,
(* 171 - RECORD READ/WRITE *)
(* 206 - extend for constants *)
READRECORD,WRITERECORD,WRITESCALAR,
BREAKOUTPUT,OPENTTY,INITIALIZEDEBUG,ENTERDEBUG,INDEXERROR,WRITEOCTAL,WRITEINTEGER,WRITEREAL,
(* 10 add CLOSE *)
WRITEHEXADECIMAL,WRITECHARACTER,CONVERTINTEGERTOREAL,
(* 14 and lots more *)
(* 33 - PROGRAM statement *)
CONVERTREALTOINTEGER,CLOSEFILE,READSTRING,READPACKEDSTRING,READFILENAME,
NAMEFILE,DISFILE,UPFILE,APFILE,READDUMP,WRITEDUMP,SETIN,SETOUT,BREAKINPUT,
(* 74 - tops20 routines *)
SETPOSF,CURPOSF,NEXTBLOCKF,SPACELEFTF,GETXF,DELFILE,RELFILE,INITMEM,INITFILES,
(* 163 - tops20 TIME function *)
GETDAYTIME,LASTSUPPORT);
%CONSTANTS\
%*********\
CSTCLASS = (INT,REEL,PSET,STRD,STRG);
CSP = ^ CONSTNT;
(* 55 - add require files *)
STRGARR = PACKED ARRAY[1..STRGLGTH] OF CHAR;
CONSTNT = RECORD
SELFCSP: CSP; NOCODE: BOOLEAN;
CASE CCLASS: CSTCLASS OF
INT : (INTVAL: INTEGER; INTVAL1:INTEGER %TO ACCESS SECOND WORD OF PVAL\ );
REEL: (RVAL: REAL);
PSET: (PVAL: SET OF 0..71);
STRD,
STRG: (SLGTH: 0..STRGLGTH;
SVAL: PACKED ARRAY [1..STRGLGTH] OF CHAR)
END;
VALU = RECORD
CASE BOOLEAN OF
TRUE: (IVAL: INTEGER);
FALSE: (VALP: CSP)
END;
%DATA STRUCTURES\
%***************\
LEVRANGE = 0..MAXLEVEL; ADDRRANGE = 0..MAXADDR; INSTRANGE = 0..677B ;
RADIXRANGE = 0..37777777777B; FLAGRANGE = 0..17B;
BITRANGE = 0..BITMAX; ACRANGE = 0..15; IBRANGE = 0..1; CODERANGE = 0..CIXMAX ;
(* 173 - internal files *)
BITS5 = 0..37B; BITS6 = 0..77B; BITS7 = 0..177B;
STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES,TAGFWITHID,TAGFWITHOUTID,VARIANT);
DECLKIND = (STANDARD,DECLARED);
STP = ^ STRUCTURE; CTP = ^ IDENTIFIER; BTP = ^BYTEPOINT;
FTP = ^FILBLCK;
GTP = ^GLOBPTR ;
STRUCTURE = PACKED RECORD
SELFSTP: STP; SIZE: ADDRRANGE;
NOCODE: BOOLEAN; BITSIZE: BITRANGE;
(* 173 - internal files *)
HASFILE: BOOLEAN;
CASE FORM: STRUCTFORM OF
SCALAR: (CASE SCALKIND: DECLKIND OF
DECLARED: (DB0: BITS5; FCONST: CTP));
SUBRANGE: (DB1: BITS6; RANGETYPE: STP; MIN,MAX: VALU);
POINTER: (DB2: BITS6; ELTYPE: STP);
POWER: (DB3: BITS6; ELSET: STP);
ARRAYS: (ARRAYPF: BOOLEAN; DB4: BITS5; ARRAYBPADDR: ADDRRANGE;
AELTYPE,INXTYPE: STP);
RECORDS: (RECORDPF: BOOLEAN; DB5: BITS5;
FSTFLD: CTP; RECVAR: STP);
FILES: (DB6: BITS5; FILEPF: BOOLEAN;FILTYPE: STP);
TAGFWITHID,
TAGFWITHOUTID: (DB7: BITS6; FSTVAR: STP;
CASE BOOLEAN OF
TRUE : (TAGFIELDP: CTP);
FALSE : (TAGFIELDTYPE: STP));
VARIANT: (DB9: BITS6; NXTVAR,SUBVAR: STP; FIRSTFIELD: CTP; VARVAL: VALU; QXLYPRTWRR: BOOLEAN)
END;
BPOINTER = PACKED RECORD
SBITS,PBITS: BITRANGE;
IBIT,DUMMYBIT: IBRANGE;
IREG: ACRANGE;
RELADDR: ADDRRANGE
END;
BPKIND = (RECORDD,ARRAYY);
BYTEPOINT = PACKED RECORD
BYTE: BPOINTER;
LAST :BTP;
CASE BKIND:BPKIND OF
RECORDD: (FIELDCP: CTP);
ARRAYY : (ARRAYSP: STP)
END;
GLOBPTR = RECORD
NEXTGLOBPTR: GTP ;
FIRSTGLOB,
LASTGLOB : ADDRRANGE ;
FCIX : CODERANGE
END ;
FILBLCK = PACKED RECORD
NEXTFTP : FTP ;
FILEIDENT : CTP
END ;
%NAMES\
%*****\
(* 64 - non-loc goto *)
(* 111 - STRING, POINTER *)
(* PARAMS is a special kind of TYPES. It is used only for
predeclared identifiers describing kludgey types that are
valid only in procedure parameter lists. *)
IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC,LABELT,PARAMS);
SETOFIDS = SET OF IDCLASS;
IDKIND = (ACTUAL,FORMAL);
PACKKIND = (NOTPACK,PACKK,HWORDR,HWORDL);
CHARWORD = PACKED ARRAY [1..5] OF CHAR;
%ALFA = PACKED ARRAY [1..ALFALENG] OF CHAR;\
IDENTIFIER = PACKED RECORD
NAME: ALFA;
LLINK, RLINK: CTP;
IDTYPE: STP; NEXT: CTP;
SELFCTP: CTP; NOCODE: BOOLEAN;
CASE KLASS: IDCLASS OF
KONST: (VALUES: VALU);
VARS: (VKIND: IDKIND; VLEV: LEVRANGE;
CHANNEL: ACRANGE; VDUMMY: 0..31; VADDR: ADDRRANGE);
FIELD: (PACKF: PACKKIND; FDUMMY: 0..7777B;
FLDADDR: ADDRRANGE);
%IF PACKF=PACKK THEN FLDADDR CONTAINS THE
ABSOLUTE ADDRESS OF THE CORRESPONDING BYTEPOINTER
-----> ENTERBODY\
PROC,
FUNC: (PFCHAIN: CTP; CASE PFDECKIND: DECLKIND OF
STANDARD: (KEY: 1..44);
DECLARED: (PFLEV: LEVRANGE; PFADDR: ADDRRANGE;
CASE PFKIND: IDKIND OF
ACTUAL: (FORWDECL: BOOLEAN; TESTFWDPTR: CTP;
EXTERNDECL: BOOLEAN; LANGUAGE: SYMBOL;
EXTERNALNAME: ALFA;
LINKCHAIN: PACKED ARRAY[LEVRANGE] OF ADDRRANGE;
(* 62 - clean of stack offsets *)
POFFSET:ADDRRANGE)));
(* 66 - non-local goto's *)
LABELT: (SCOPE:LEVRANGE;NONLOCGOTO:BOOLEAN;
GOTOCHAIN:ADDRRANGE;LABELADDRESS:ADDRRANGE)
END;
DISPRANGE = 0..DISPLIMIT;
WHERE = (BLCK,CREC);
(* 61 - new type to separate tops10 and tops20 ftns *)
machine = (okname,t10name,t20name);
%RELOCATION\
%**********\
RELBYTE = 0..3B %(NO,RIGHT,LEFT,BOTH)\;
RELWORD = PACKED ARRAY[0..17] OF RELBYTE;
%EXPRESSIONS\
%***********\
ATTRKIND = (CST,VARBL,EXPR);
ATTR = RECORD
TYPTR: STP;
CASE KIND: ATTRKIND OF
CST: (CVAL: VALU);
VARBL: (PACKFG: PACKKIND; INDEXR: ACRANGE; INDBIT: IBRANGE;
VLEVEL: LEVRANGE; BPADDR,DPLMT: ADDRRANGE; VRELBYTE: RELBYTE; SUBKIND: STP);
EXPR: (REG:ACRANGE)
END;
TESTP = ^ TESTPOINTER;
TESTPOINTER = PACKED RECORD
ELT1,ELT2: STP;
LASTTESTP: TESTP
END;
(* 65 - remove exit labels *)
%TYPES FROM BODY \
%****************\
(* 13 - ADD WRITEBLOCK FOR DDT SYMBOLS *)
WRITEFORM = (WRITEENTRY,WRITENAME,WRITEHISEG,WRITEGLOBALS,WRITECODE,WRITEINTERNALS,
(* 164 - add Polish fixups *)
WRITEPOLISH,WRITELIBRARY,
(* 173 - remove writefileblock *)
WRITESYMBOLS,WRITEBLK,WRITESTART,WRITEEND);
UPDATEFORM = (C,D);
ETP = ^ ERRORUPDATE;
ERRORUPDATE = PACKED RECORD
NUMBER: INTEGER;
NEXT: ETP;
CASE FORM: UPDATEFORM OF
C: (STRING: ALFA);
D: (INTVAL: INTEGER)
END;
KSP = ^ KONSTREC;
KONSTREC = PACKED RECORD
(* 72 - two fixup chains for 2 word consts *)
ADDR, ADDR1, KADDR: ADDRRANGE;
CONSTPTR: CSP;
NEXTKONST: KSP
END;
(* 164 - Polish fixups for CASE *)
POLPT = ^ POLREC;
{This record indicates a Polish fixup to be done at address WHERE in
the code. The RH of WHERE is to get the BASE (assumed relocatable),
adjusted by OFFSET (a constant). This is needed because the loader
assumes that any address < 400000B is in the lowseg. So to get the
virtual start of the CASE statement branch table we need to use
this to adjust the physical start of the table by the first case
index}
POLREC = PACKED RECORD
WHERE: ADDRRANGE;
BASE: ADDRRANGE;
OFFSET: INTEGER;
NEXTPOL: POLPT
END;
PDP10INSTR = PACKED RECORD
INSTR : INSTRANGE ;
AC : ACRANGE;
INDBIT : IBRANGE;
INXREG : ACRANGE;
ADDRESS : ADDRRANGE
END ;
HALFS = PACKED RECORD
LEFTHALF: ADDRRANGE;
RIGHTHALF: ADDRRANGE
END;
PAGEELEM = PACKED RECORD
WORD1: PDP10INSTR;
LHALF: ADDRRANGE; RHALF: ADDRRANGE
END;
DEBENTRY = RECORD
(* 36 - ALLOW MULTIPLE MODULES *)
NEXTDEB: INTEGER; %WILL BE PTR TO NEXT ENTRY\
LASTPAGEELEM: PAGEELEM;
(* 103 - fix global id tree *)
GLOBALIDTREE: CTP;
STANDARDIDTREE: CTP;
INTPOINT: STP;
REALPOINT: STP;
CHARPOINT: STP;
MODNAME: ALFA;
(* 155 - add source information *)
SOURCE: PACKED ARRAY[1..167]OF CHAR;
END;
(* 4 - add data structure for SCAN to return *)
(* 11 - modify structure and add type for the REL file *)
INTFILE = FILE OF INTEGER;
RPGDATA = RECORD
(* 7 - add /HEAP switch *)
RELNAME:ALFA;
(* 24 - allow user to set first loc of stack and heap *)
STACKVAL:INTEGER;
HEAPVAL:INTEGER;
(* 33 - version no. *)
VERVAL:INTEGER;
(* 25 - add /ZERO *)
(* 160 - add /ARITHCHECK *)
ASW,ZSW,LSW,TSW,MSW,CSW,DSW,CRSW,RPGSW:BOOLEAN
END;
RPGPT = ^ RPGDATA;
(* 33 - PROGRAM statement *)
(* 61 - allow +* in tops20 *)
PROGFILE = PACKED RECORD
FILID:ALFA;
NEXT:^PROGFILE;
(* 64 - INPUT:/ *)
wild,newgen,oldfile,interact,seeeol:Boolean
END;
(* 157 - See if we need INITTTY *)
PROGFILEPT = ^ PROGFILE;
%------------------------------------------------------------------------------\
VAR
%RETURNED BY SOURCE PROGRAM SCANNER INSYMBOL:\
%********************************************\
SY: SYMBOL; %LAST SYMBOL\
OP: OPERATOR; %CLASSIFICATION OF LAST SYMBOL\
VAL: VALU; %VALUE OF LAST CONSTANT\
LGTH: INTEGER; %LENGTH OF LAST STRING CONSTANT\
ID: ALFA; %LAST IDENTIFIER (POSSIBLY TRUNCATED)\
CH: CHAR; %LAST CHARACTER\
%COUNTERS:\
%*********\
RTIME,
I: INTEGER;
SUPPORTIX: SUPPORTS;
LANGUAGEIX: SYMBOL;
CHCNT: 0..132; %CHARACTER COUNTER\
CODEEND, %FIRST LOCATION NOT USED FOR INSTRUCTIONS\
LCMAIN,
(* 5 - some new variables for CREF *)
LC,IC,BEGLC,BEGIC: ADDRRANGE; %DATA LOCATION AND INSTRUCTION COUNTER\
(* 176 - new vars for unterminated comment *)
comment_page, comment_line: integer;
%SWITCHES:\
%*********\
(* 25 - ADD /ZERO *)
ZERO, %ON TO INITIALIZE LOCAL VAR'S\
(* 4 - variable for COMPIL linkage *)
RPGENTRY, %ON IF CALLED CALLED BY COMPIL\
(* 5 - new variables for CREF *)
CREF, %ON IF CREF LISTING BEING MADE\
DP,BEGDP, %DECLARATION PART\
RESETFLAG, %TO IGNORE SWITCHES WHICH MUST NOT BE RESET\
PRTERR, %TO ALLOW FORWARD REFERENCES IN POINTER TYPE
DECLARATION BY SUPPRESSING ERROR MESSAGE\
MAIN, %IF FALSE COMPILER PRODUCES EXTERNAL PROCEDURE OR FUNCTION\
doinitTTY, %TTYOPEN needed\
TTYINUSE, %no longer used ?\
TTYSEEEOL, %TTY:# in program state\
DEBUG, %ENABLE DEBUGGING\
DEBUGSWITCH, %INSERT DEBUGINFORMATION\
LISTCODE, %LIST MACRO CODE\
INITGLOBALS, %INITIALIZE GLOBAL VARIABLES\
LOADNOPTR, %TRUE IF NO POINTERVARIABLE SHALL BE LOADED\
(* 157 - separate control for arith overflow *)
ARITHCHECK, %SWITCH FOR DETECTING ARITH ERRORS\
RUNTMCHECK: BOOLEAN; %SWITCH FOR RUNTIME-TESTS\
(* 24 - ALLOW USER TO SET FIRST LOC OF STACK AND HEAP *)
STACK,HEAP: ADDRRANGE; %FIRST ADDR OF STACK AND HEAP\
(* 12 - stackandheap no longer needed *)
(* 33 - VERSION NO. *)
version:packed record %version no. for output\
case boolean of
true:(word:integer);
false:(who:0..7B;major:0..777B;minor:0..77B;edit:0..777777B)
end;
%POINTERS:\
%*********\
LOCALPFPTR, EXTERNPFPTR: CTP; %PTRS TO LOCAL/EXTERNAL PROC/FUNC-CHAIN\
(* 111 - STRING, POINTER *)
(* 202 - POINTER by ref *)
INTPTR,REALPTR,CHARPTR,ANYFILEPTR,STRINGPTR,POINTERPTR,POINTERREF,
BOOLPTR,NILPTR,TEXTPTR: STP; %POINTERS TO ENTRIES OF STANDARD IDS\
(* 135 - ill mem ref in PACK, UNPACK *)
UARRTYP:STP;
UTYPPTR,UCSTPTR,UVARPTR,
UFLDPTR,UPRCPTR,UFCTPTR, %POINTERS TO ENTRIES FOR UNDECLARED IDS\
(* 64 - non-loc goto *)
ulblptr,
FWPTR: CTP; %HEAD OF CHAIN OF FORW DECL TYPE IDS\
ERRMPTR,ERRMPTR1: ETP; %TO CHAIN ERROR-UPDATES\
(* 65 - remove exit labels *)
LASTBTP: BTP; %HEAD OF BYTEPOINTERTABLE\
SFILEPTR,
FILEPTR: FTP;
FIRSTKONST: KSP;
(* 164 - Polish fixups for CASE *)
FIRSTPOL: POLPT;
ALFAPTR, DATEPTR: STP;
FGLOBPTR,CGLOBPTR : GTP ; %POINTER TO FIRST AND CURRENT GLOBAL INITIALISATION RECORD\
GLOBTESTP : TESTP ; %POINTER TO LAST PAIR OF POINTERTYPES\
(* 4 - Here is the main structure for the SCAN linkage *)
SCANDATA : RPGPT ; %DATA FROM SCAN OF FILE NAMES\
(* 33 - PROGRAM STATEMENT *)
NPROGFILE, %NEW FILE NAME\
LPROGFILE, %LAST FILE NAME IN LIST\
FPROGFILE:PROGFILEPT; %FIRST FILE NAME IN LIST\
(* 64 - non-loc goto *)
lastlabel:ctp;
(* 171 - treat file names as special *)
infile,outfile,ttyfile,ttyoutfile:ctp; {Pointers to ID's for
INPUT, OUTPUT, TTY, TTYOUT}
%BOOKKEEPING OF DECLARATION LEVELS:\
%**********************************\
(* 5 - new variable for CREF *)
LEVEL,BEGLEVEL: LEVRANGE; %CURRENT STATIC LEVEL\
DISX, %LEVEL OF LAST ID SEARCHED BY SEARCHID\
TOP: DISPRANGE; %TOP OF DISPLAY\
DISPLAY: %WHERE: MEANS:\
ARRAY[DISPRANGE] OF
PACKED RECORD
%=BLCK: ID IS VARIABLE ID\
(* 5 - new variable for CREF *)
BLKNAME: ALFA; %NAME OF BLOCK\
FNAME: CTP; %=CREC: ID IS FIELD ID IN RECORD WITH\
CASE OCCUR: WHERE OF % CONSTANT ADDRESS\
CREC: (CLEV: LEVRANGE; %=VREC: ID IS FIELD ID IN RECORD WITH\
CINDR: ACRANGE; % VARIABLE ADDRESS\
CINDB: IBRANGE;
CRELBYTE: RELBYTE;
CDSPL,
CLC : ADDRRANGE)
END;
%ERROR MESSAGES:\
%***************\
ERRORFLAG: BOOLEAN; %TRUE IF SYNTACTIC ERRORS DETECTED\
ERRINX: 0..MAXERR ; %NR OF ERRORS IN CURRENT SOURCE LINE\
ERRLIST:
ARRAY [1..MAXERR] OF
PACKED RECORD
ARW : 1..4;
POS: 1..CHCNTMAX;
NMR: 1..600;
TIC: CHAR
END;
ERRMESS15 : ARRAY [1..24] OF PACKED ARRAY [1..15] OF CHAR;
(* 6 - add error msg for illegal character *)
ERRMESS20 : ARRAY [1..16] OF PACKED ARRAY [1..20] OF CHAR;
(* 104 - error message for too much data for address space *)
ERRMESS25 : ARRAY [1..16] OF PACKED ARRAY [1..25] OF CHAR;
ERRMESS30 : ARRAY [1..17] OF PACKED ARRAY [1..30] OF CHAR;
(* 156 - ftnname^ := *)
ERRMESS35 : ARRAY [1..18] OF PACKED ARRAY [1..35] OF CHAR;
(* 31 - ADD MESSAGE FOR BAD ASSIGN TO FTN. NAME *)
ERRMESS40 : ARRAY [1..13] OF PACKED ARRAY [1..40] OF CHAR;
(* 24 - NEW ERROR MSG FOR LOC *)
ERRMESS45 : ARRAY [1..16] OF PACKED ARRAY [1..45] OF CHAR;
(* 33 - PROGRAM STATEMENT *)
ERRMESS50 : ARRAY [1.. 9] OF PACKED ARRAY [1..50] OF CHAR;
(* 124 - bad initprocedure *)
ERRMESS55 : ARRAY [1.. 7] OF PACKED ARRAY [1..55] OF CHAR;
ERRORINLINE,
FOLLOWERROR : BOOLEAN;
ERRLINE,
BUFFER: ARRAY [1..CHCNTMAX] OF CHAR;
(* 136 - listing format *)
PAGECNT,SUBPAGE,CURLINE,
LINECNT: INTEGER;
LINENR: PACKED ARRAY [1..5] OF CHAR;
%EXPRESSION COMPILATION:\
%***********************\
GATTR: ATTR; %DESCRIBES THE EXPR CURRENTLY COMPILED\
(* 105 - character mapping from lower case *)
charmap,setmap:array[0..177B]of integer; %fast mapping to upper case\
setmapchain:addrrange; %for external reference to runtime version of setmap\
%COUNTERS FOR TESTS:\
%*******************\
%DEBUG-SYSTEM:\
%*************\
LASTSTOP: ADDRRANGE; %LAST BREAKPOINT\
LASTLINE, %LINENUMBER FOR BREAKPOINTS\
LINEDIFF, %DIFFERENCE BETWEEN ^ AND LINECNT\
LASTPAGE:INTEGER; %LAST PAGE THAT CONTAINS A STOP\
PAGEHEADADR, %OVERGIVE TO DEBUG.PAS\
LASTPAGER: ADDRRANGE; %POINTS AT LAST PAGERECORD\
PAGER: PAGEELEM; %ACTUAL PAGERECORD\
DEBUGENTRY: DEBENTRY;
IDRECSIZE: ARRAY[IDCLASS] OF INTEGER;
STRECSIZE: ARRAY[STRUCTFORM] OF INTEGER;
%STRUCTURED CONSTANTS:\
%*********************\
LETTERSORDIGITS,LETTERS,DIGITS,LETTERSDIGITSORLEFTARROW,HEXADIGITS: SET OF CHAR;
CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS,
LANGUAGESYS,STATBEGSYS,TYPEDELS: SETOFSYS;
(* 6 - add PROGRAM statement *)
(* 56 - ADD INCLUDE *)
RW: ARRAY [1..45%NR. OF RES. WORDS\] OF ALFA;
FRW: ARRAY [1..11%ALFALENG+1\] OF 1..46%NR. OF RES. WORDS + 1\;
RSY: ARRAY [1..45%NR. OF RES. WORDS\] OF SYMBOL;
SSY: ARRAY [' '..'_'] OF SYMBOL;
ROP: ARRAY [1..45%NR. OF RES. WORDS\] OF OPERATOR;
SOP: ARRAY [' '..'_'] OF OPERATOR;
(* 10 make room for 12 more proc's, 8 more ftn's *)
NA: ARRAY [1..81] OF ALFA;
(* 61 - new array to declare which are tops10 and tops20 *)
machna: array[1..81] of machine;
othermachine: machine;
EXTNA: ARRAY[39..53] OF ALFA;
EXTLANGUAGE: ARRAY[39..53] OF SYMBOL;
MNEMONICS : ARRAY[1..45] OF PACKED ARRAY[1..60] OF CHAR ;
%VARIABLES FROM BODY\
%*******************\
(* 173 - internal files *)
{Chantab is very strange. It is used as a kludge because we need
two global request chains for each of INPUT, OUTPUT, TTY, and TTYOUTPUT.
So the second one is stored here. From an identifier record, you can
look at CHANNEL to find which of these corresponds to that one.}
CHANTAB:ARRAY[1..4] OF ADDRRANGE;
FILEINBLOCK:ARRAY[LEVRANGE]OF BOOLEAN; {True is there is a local file}
(* 12 - VAR'S FOR GLOBAL REF TO RUNTIMES. FOR DYNAMIC ALLOC *)
LSTNEW,NEWBND: ADDRRANGE; %references to these global variables\
(* 13 - ADD DATA FOR DDT SYMBOLS *)
PFPOINT,PFDISP:ADDRRANGE; %ADDRESS OF FIRST CODE IN PROCEDURE\
RELBLOCK: PACKED RECORD
CASE BOOLEAN OF
TRUE: (COMPONENT: ARRAY[1..20] OF INTEGER);
FALSE: (ITEM: ADDRRANGE; COUNT: ADDRRANGE;
RELOCATOR: RELWORD;
CODE: ARRAY[0..17] OF INTEGER)
END;
RNTS: RECORD
NAME: ARRAY[SUPPORTS] OF ALFA;
LINK: PACKED ARRAY[SUPPORTS] OF ADDRRANGE
END;
CODE: PACKED RECORD
RELOCATION: PACKED ARRAY[CODERANGE] OF RELBYTE;
INFORMATION: PACKED ARRAY[CODERANGE] OF CHAR;
CASE INTEGER OF
1: (INSTRUCTION: PACKED ARRAY[CODERANGE] OF PDP10INSTR);
2: (WORD: PACKED ARRAY[CODERANGE] OF INTEGER);
3: (HALFWORD: PACKED ARRAY[CODERANGE] OF HALFS)
END;
LABELS: ARRAY [1:LABMAX] OF
RECORD
LABSVAL,LABSADDR: INTEGER
END;
GOTOS: ARRAY [1:LABMAX] OF
RECORD
GOTOVAL,GOTOADDR: INTEGER
END;
REGC, %TOP OF REGISTERSTACK\
REGCMAX: ACRANGE; %MAXIMUM OF REGISTERS FOR EXPRESSION STACK\
LIX,JIX,CIX,
INSERTSIZE, %TOO INSERT LCMAX IN ENTRYCODE\
PFSTART: INTEGER; %START OF NORMAL ENTRYCODE OF EACH FUNC. OR PROC.\
IX: INTEGER;
(* 54 - var's needed to keep track of stack space needed *)
STKOFF, STKOFFMAX, CORALLOC: INTEGER; %STACK SPACE NEEDED ABOVE LOCALS\
LCMAX: ADDRRANGE; LCP: CTP;
OUTPUTREL: FILE OF INTEGER; %RELOCATABLE BINARY OUTPUT\
WITHIX, %TOP OF WITH-REG STACK\
HIGHESTCODE, %MAXIMUM OF HIGH SEGMENTS ADDRESS\
MAINSTART, %FIRST CODE OF BODY OF MAIN\
(* 16 - add CCLSW set by entry with offset=1 *)
CCLSW,
(* 66 - nonloc goto's *)
globtopp,globbasis,
STARTADDR: INTEGER; %STARTADDRESSE\
(* 33 - VERSION NO. *)
LOOKBLOCK: ARRAY[0..6] OF INTEGER;
LST,REL: PACKED ARRAY[1..3] OF CHAR ;
(* 34 - entry no longer needed *)
FILENAME: ALFA;
DAY: PACKED ARRAY[1..9] OF CHAR;
(* 125 - moved to global so insymbol can see it *)
REQFILE,ENTRYDONE: BOOLEAN;
(* 171 - read/write of records *)
THISFILE: STP;
GOTARG: BOOLEAN;
LIBIX: INTEGER;
LIBORDER: PACKED ARRAY[1..4] OF SYMBOL;
LIBRARY: ARRAY[PASCALSY..COBOLSY] OF RECORD
INORDER, CALLED: BOOLEAN;
NAME: ALFA;
PROJNR: ADDRRANGE;
PROGNR: ADDRRANGE;
DEVICE: ALFA
END;
%------------------------------------------------------------------------------\
INITPROCEDURE ;
BEGIN
(* 33 - VERSION NO. *)
(* 34 - using filename instead of entry *)
LST:= 'LST' ; REL:= 'REL' ; FILENAME:= ' ' ; LOOKBLOCK[0] := 6;
MNEMONICS[ 1] := '***001***002***003***004***005***006***007***010***011***012' ;
MNEMONICS[ 2] := '***013***014***015***016***017***020***021***022***023***024' ;
MNEMONICS[ 3] := '***025***026***027***030***031***032***033***034***035***036' ;
MNEMONICS[ 4] := '***037CALL INIT ***042***043***044***045***046CALLI OPEN ' ;
MNEMONICS[ 5] := 'TTCALL***052***053***054RENAMEIN OUT SETSTSSTATO STATUS' ;
MNEMONICS[ 6] := 'STATZ INBUF OUTBUFINPUT OUTPUTCLOSE RELEASMTAPE UGETF USETI ' ;
(* 133 - add mnemonics for ADJSP and JSYS *)
MNEMONICS[ 7] := 'USETO LOOKUPENTER UJEN ***101***102***103JSYS ADJSP ***106' ;
MNEMONICS[ 8] := '***107***110***111***112***113***114***115***116***117***120' ;
(* 2 - add mnemonics for KI-10, since we are using some of them *)
MNEMONICS[ 9] := '***121FIX ***123***124***125FIXR FLTR UFA DFN FSC ' ;
MNEMONICS[10] := 'IBP ILDB LDB IDPB DPB FAD FADL FADM FADB FADR ' ;
MNEMONICS[11] := 'FADRI FADRM FADRB FSB FSBL FSBM FSBB FSBR FSBRI FSBRM ' ;
MNEMONICS[12] := 'FSBRB FMP FMPL FMPM FMPB FMPR FMPRI FMPRM FMPRB FDV ' ;
MNEMONICS[13] := 'FDVL FDVM FDVB FDVR FDVRI FDVRM FDVRB MOVE MOVEI MOVEM ' ;
MNEMONICS[14] := 'MOVES MOVS MOVSI MOVSM MOVSS MOVN MOVNI MOVNM MOVNS MOVM ' ;
MNEMONICS[15] := 'MOVMI MOVMM MOVMS IMUL IMULI IMULM IMULB MUL MULI MULM ' ;
MNEMONICS[16] := 'MULB IDIV IDIVI IDIVM IDIVB DIV DIVI DIVM DIVB ASH ' ;
MNEMONICS[17] := 'ROT LSH JFFO ASHC ROTC LSHC ***247EXCH BLT AOBJP ' ;
MNEMONICS[18] := 'AOBJN JRST JFCL XCT ***257PUSHJ PUSH POP POPJ JSR ' ;
MNEMONICS[19] := 'JSP JSA JRA ADD ADDI ADDM ADDB SUB SUBI SUBM ' ;
MNEMONICS[20] := 'SUBB CAI CAIL CAIE CAILE CAIA CAIGE CAIN CAIG CAM ' ;
MNEMONICS[21] := 'CAML CAME CAMLE CAMA CAMGE CAMN CAMG JUMP JUMPL JUMPE ' ;
MNEMONICS[22] := 'JUMPLEJUMPA JUMPGEJUMPN JUMPG SKIP SKIPL SKIPE SKIPLESKIPA ' ;
MNEMONICS[23] := 'SKIPGESKIPN SKIPG AOJ AOJL AOJE AOJLE AOJA AOJGE AOJN ' ;
MNEMONICS[24] := 'AOJG AOS AOSL AOSE AOSLE AOSA AOSGE AOSN AOSG SOJ ' ;
MNEMONICS[25] := 'SOJL SOJE SOJLE SOJA SOJGE SOJN SOJG SOS SOSL SOSE ' ;
MNEMONICS[26] := 'SOSLE SOSA SOSGE SOSN SOSG SETZ SETZI SETZM SETZB AND ' ;
MNEMONICS[27] := 'ANDI ANDM ANDB ANDCA ANDCAIANDCAMANDCABSETM SETMI SETMM ' ;
MNEMONICS[28] := 'SETMB ANDCM ANDCMIANDCMMANDCMBSETA SETAI SETAM SETAB XOR ' ;
MNEMONICS[29] := 'XORI XORM XORB IOR IORI IORM IORB ANDCB ANDCBIANDCBM' ;
MNEMONICS[30] := 'ANDCBBEQV EQVI EQVM EQVB SETCA SETCAISETCAMSETCABORCA ' ;
MNEMONICS[31] := 'ORCAI ORCAM ORCAB SETCM SETCMISETCMMSETCMBORCM ORCMI ORCMM ' ;
MNEMONICS[32] := 'ORCMB ORCB ORCBI ORCBM ORCBB SETO SETOI SETOM SETOB HLL ' ;
MNEMONICS[33] := 'HLLI HLLM HLLS HRL HRLI HRLM HRLS HLLZ HLLZI HLLZM ' ;
MNEMONICS[34] := 'HLLZS HRLZ HRLZI HRLZM HRLZS HLLO HLLOI HLLOM HLLOS HRLO ' ;
MNEMONICS[35] := 'HRLOI HRLOM HRLOS HLLE HLLEI HLLEM HLLES HRLE HRLEI HRLEM ' ;
MNEMONICS[36] := 'HRLES HRR HRRI HRRM HRRS HLR HLRI HLRM HLRS HRRZ ' ;
MNEMONICS[37] := 'HRRZI HRRZM HRRZS HLRZ HLRZI HLRZM HLRZS HRRO HRROI HRROM ' ;
MNEMONICS[38] := 'HRROS HLRO HLROI HLROM HLROS HRRE HRREI HRREM HRRES HLRE ' ;
MNEMONICS[39] := 'HLREI HLREM HLRES TRN TLN TRNE TLNE TRNA TLNA TRNN ' ;
MNEMONICS[40] := 'TLNN TDN TSN TDNE TSNE TDNA TSNA TDNN TSNN TRZ ' ;
MNEMONICS[41] := 'TLZ TRZE TLZE TRZA TLZA TRZN TLZN TDZ TSZ TDZE ' ;
MNEMONICS[42] := 'TSZE TDZA TSZA TDZN TSZN TRC TLC TRCE TLZE TRCA ' ;
MNEMONICS[43] := 'TLCA TRCN TLCN TDC TSC TDCE TSCE TDCA TSCA TDCN ' ;
MNEMONICS[44] := 'TSCN TRO TLO TROE TLOE TROA TLOA TRON TLON TDO ' ;
MNEMONICS[45] := 'TSO TDOE TSOE TDOA TSOA TDON TSON ***700 ' ;
END;
INITPROCEDURE %SEARCH LIBRARIES\ ;
BEGIN
LIBRARY[PASCALSY].INORDER := FALSE;
LIBRARY[FORTRANSY].INORDER := FALSE;
LIBRARY[ALGOLSY].INORDER := FALSE;
LIBRARY[COBOLSY].INORDER := FALSE;
LIBRARY[PASCALSY].CALLED := FALSE;
LIBRARY[FORTRANSY].CALLED := FALSE;
LIBRARY[ALGOLSY].CALLED := FALSE;
LIBRARY[COBOLSY].CALLED := FALSE;
(* 57 - Make library a parameter *)
LIBRARY[PASCALSY].NAME := PASLIB;
LIBRARY[FORTRANSY].NAME := 'FORLIB ';
LIBRARY[ALGOLSY].NAME := 'ALGLIB ';
LIBRARY[COBOLSY].NAME := 'LIBOL ';
(* 2 - library now on SYS: *)
(* 57 *)
LIBRARY[PASCALSY].DEVICE := PASDEV;
LIBRARY[FORTRANSY].DEVICE := 'SYS ';
LIBRARY[ALGOLSY].DEVICE := 'SYS ';
LIBRARY[COBOLSY].DEVICE := 'SYS ';
(* 57 *)
LIBRARY[PASCALSY].PROJNR := PASPROJ;
LIBRARY[FORTRANSY].PROJNR := 0;
LIBRARY[ALGOLSY].PROJNR := 0;
LIBRARY[COBOLSY].PROJNR := 0;
(* 57 *)
LIBRARY[PASCALSY].PROGNR := PASPROG;
LIBRARY[FORTRANSY].PROGNR := 0;
LIBRARY[ALGOLSY].PROGNR := 0;
LIBRARY[COBOLSY].PROGNR := 0;
END %SEARCH LIBRARIES\ ;
INITPROCEDURE %STANDARDNAMES\ ;
BEGIN
NA[ 1] := 'FALSE '; NA[ 2] := 'TRUE '; NA[ 3] := 'INPUT ';
NA[ 4] := 'OUTPUT '; NA[ 5] := 'TTY '; NA[ 6] := 'TTYOUTPUT ';
NA[ 7] := 'GET '; NA[ 8] := 'GETLN '; NA[ 9] := 'PUT ';
NA[10] := 'PUTLN '; NA[11] := 'RESET '; NA[12] := 'REWRITE ';
NA[13] := 'READ '; NA[14] := 'READLN '; NA[15] := 'BREAK ';
NA[16] := 'WRITE '; NA[17] := 'WRITELN '; NA[18] := 'PACK ';
NA[19] := 'UNPACK '; NA[20] := 'NEW '; NA[21] := 'MARK ';
NA[22] := 'RELEASE '; NA[23] := 'GETLINENR '; NA[24] := 'PUT8BITSTO';
NA[25] := 'PAGE '; NA[26] := 'DATE '; NA[27] := 'RUNTIME ';
NA[28] := 'TIME '; NA[29] := 'ABS '; NA[30] := 'SQR ';
NA[31] := 'TRUNC '; NA[32] := 'ODD '; NA[33] := 'ORD ';
NA[34] := 'CHR '; NA[35] := 'PRED '; NA[36] := 'SUCC ';
NA[37] := 'EOF '; NA[38] := 'EOLN '; NA[39] := 'SIN ';
NA[40] := 'COS '; NA[41] := 'EXP '; NA[42] := 'SQRT ';
NA[43] := 'LN '; NA[44] := 'ARCTAN '; NA[45] := 'LOG ';
NA[46] := 'SIND '; NA[47] := 'COSD '; NA[48] := 'SINH ';
NA[49] := 'COSH '; NA[50] := 'TANH '; NA[51] := 'ARCSIN ';
NA[52] := 'ARCCOS '; NA[53] := 'RANDOM ';
(* 10 make room for 12 more proc's, 8 more ftn's *)
NA[54] := 'STRSET '; NA[55] := 'STRWRITE ';
NA[56] := 'GETINDEX '; NA[57] := 'CLOSE ';
NA[58] := 'CALLI '; NA[59] := 'RENAME ';
NA[60] := 'DISMISS '; NA[61] := 'UPDATE ';
NA[62] := 'DUMPIN '; NA[63] := 'DUMPOUT ';
NA[64] := 'USETI '; NA[65] := 'USETO ';
(* 27 - add NEWZ *)
NA[66] := 'BREAKIN '; NA[67] := 'NEWZ ';
NA[68] := 'APPEND '; NA[69] := 'PUTX ';
(* 44 - SETPOS,CURPOS, SKIP *)
NA[70] := 'SETPOS '; NA[71] := 'NEXTBLOCK ';
(* 61 - tops20 system version *)
na[72] := 'GETX '; na[73] := 'DELETE ';
na[74] := 'RCLOSE '; na[75] := 'JSYS ';
(* 152 - add DISPOSE *)
na[76] := 'DISPOSE '; na[77] := 'NEXTFILE ';
na[78] := 'CURPOS '; na[79] := 'SPACELEFT ';
na[80] := 'ROUND '; na[81] := 'RECSIZE ';
machna[24] := t10name; machna[58] := t10name;
machna[62] := t10name; machna[63] := t10name;
machna[64] := t10name; machna[65] := t10name;
(* 134 - remove t20name entry for DELETE *)
machna[71] := t10name;
machna[74] := t20name; machna[75] := t20name;
machna[77] := t20name; machna[79] := t10name;
END %STANDARDNAMES\ ;
INITPROCEDURE %EXTERNAL NAMES\;
BEGIN
EXTNA[39] := 'SIN '; EXTLANGUAGE[39] := FORTRANSY;
EXTNA[40] := 'COS '; EXTLANGUAGE[40] := FORTRANSY;
EXTNA[41] := 'EXP '; EXTLANGUAGE[41] := FORTRANSY;
EXTNA[42] := 'SQRT '; EXTLANGUAGE[42] := FORTRANSY;
EXTNA[43] := 'ALOG '; EXTLANGUAGE[43] := FORTRANSY;
EXTNA[44] := 'ATAN '; EXTLANGUAGE[44] := FORTRANSY;
EXTNA[45] := 'ALOG10 '; EXTLANGUAGE[45] := FORTRANSY;
EXTNA[46] := 'SIND '; EXTLANGUAGE[46] := FORTRANSY;
EXTNA[47] := 'COSD '; EXTLANGUAGE[47] := FORTRANSY;
EXTNA[48] := 'SINH '; EXTLANGUAGE[48] := FORTRANSY;
EXTNA[49] := 'COSH '; EXTLANGUAGE[49] := FORTRANSY;
EXTNA[50] := 'TANH '; EXTLANGUAGE[50] := FORTRANSY;
EXTNA[51] := 'ASIN '; EXTLANGUAGE[51] := FORTRANSY;
EXTNA[52] := 'ACOS '; EXTLANGUAGE[52] := FORTRANSY;
EXTNA[53] := 'RAN '; EXTLANGUAGE[53] := FORTRANSY;
END %EXTERNAL NAMES\;
INITPROCEDURE %RUNTIME-, DEBUG-SUPPORTS\ ;
BEGIN
RNTS.NAME[STACKOVERFLOW] := 'CORERR ';
(* 104 - new tops10 stackoverflow for better checking *)
RNTS.NAME[DEBSTACK] := 'DCORER ';
(* 23 - check for bad pointer *)
RNTS.NAME[BADPOINT] := 'PTRER. ';
RNTS.NAME[ALLOCATE] := 'NEW ';
RNTS.NAME[CLEARALLOC] := 'NEWCL. ';
(* 152 - DISPOSE *)
RNTS.NAME[DEALLOCATE] := 'DISPOS ';
(* 173 - internal file *)
RNTS.NAME[WITHFILEDEALLOCATE] := 'DISPF. ';
(* 64 - non-loc goto *)
rnts.name[exitgoto] := 'GOTOC. ';
RNTS.NAME[EXITPROGRAM] := 'END ';
RNTS.NAME[GETLINE] := 'GETLN ';
RNTS.NAME[GETFILE] := 'GET. ';
RNTS.NAME[PUTLINE] := 'PUTLN ';
RNTS.NAME[PUTFILE] := 'PUT ';
(* 43 - add PUTX *)
RNTS.NAME[PUTXFILE] := 'PUTX ';
RNTS.NAME[RESETFILE] := 'RESETF ';
RNTS.NAME[REWRITEFILE] := 'REWRIT ';
(* 57 - do strset and strwrite at runtime *)
RNTS.NAME[RESETSTRING] := 'STSET. ';
RNTS.NAME[REWRITESTRING] := 'STWR. ';
RNTS.NAME[WRITEOCTAL] := 'WRTOCT ';
RNTS.NAME[WRITEHEXADECIMAL] := 'WRTHEX ';
RNTS.NAME[WRITEINTEGER] := 'WRTINT ';
RNTS.NAME[WRITECHARACTER] := 'WRITEC ';
RNTS.NAME[WRITEREAL] := 'WRTREA ';
RNTS.NAME[WRITEBOOLEAN] := 'WRTBOL ';
RNTS.NAME[WRITESTRING] := 'WRTUST ';
RNTS.NAME[WRITEPACKEDSTRING] := 'WRTPST ';
RNTS.NAME[WRITERECORD] := '.WRREC ';
RNTS.NAME[WRITESCALAR] := '.WRSCA ';
RNTS.NAME[READINTEGER] := '.READI ';
RNTS.NAME[READCHARACTER] := '.READC ';
RNTS.NAME[READREAL] := '.READR ';
RNTS.NAME[READRECORD] := '.READD ';
RNTS.NAME[CONVERTINTEGERTOREAL] := 'INTREA ';
RNTS.NAME[CONVERTREALTOINTEGER] := 'TRUNC ';
RNTS.NAME[BREAKOUTPUT] := 'BREAK ';
RNTS.NAME[OPENTTY] := 'TTYPR. ';
RNTS.NAME[INITIALIZEDEBUG] := 'INDEB. ';
RNTS.NAME[ENTERDEBUG] := 'EXDEB. ';
RNTS.NAME[GETCHARACTER] := 'GETCH ';
RNTS.NAME[PUTPAGE] := 'PUTPG ';
RNTS.NAME[INDEXERROR] := 'INXERR ';
RNTS.NAME[ERRORINASSIGNMENT] := 'SRERR ';
RNTS.NAME[FILEUNINITIALIZED] := 'ILFIL. ';
RNTS.NAME[INITFILEBLOCK] := 'INITB. ';
(* 10 ADD CLOSE *)
RNTS.NAME[CLOSEFILE] := 'CLOFIL ';
(* 14 AND STRING READERS *)
RNTS.NAME[READSTRING] := 'READUS ';
RNTS.NAME[READPACKEDSTRING] := 'READPS ';
RNTS.NAME[READFILENAME] := 'GETFN. ';
RNTS.NAME[NAMEFILE] := 'RENAME ';
(* 40 - change name so won't conflict with FORTRAN *)
RNTS.NAME[DISFILE] := 'RESDEV ';
RNTS.NAME[UPFILE] := 'UPDATE ';
RNTS.NAME[APFILE] := 'APPEND ';
RNTS.NAME[READDUMP] := 'DUMPIN ';
RNTS.NAME[WRITEDUMP] := 'DUMPOU ';
RNTS.NAME[SETIN] := 'USETIN ';
RNTS.NAME[SETOUT] := 'USETOU ';
RNTS.NAME[BREAKINPUT] := 'BREAKI ';
RNTS.NAME[SETPOSF] := 'SETPOS ';
RNTS.NAME[CURPOSF] := 'CURPOS ';
RNTS.NAME[NEXTBLOCKF] := 'NEXTBL ';
rnts.name[spaceleftf] := 'SPCLF. ';
rnts.name[getxf] := 'GETX. ';
(* 74 - Tops20 runtimes *)
rnts.name[delfile] := 'DELF. ';
rnts.name[relfile] := 'RELF. ';
rnts.name[initmem] := 'PASIM. ';
(* 120 - New calling convention, so changed name *)
rnts.name[initfiles] := 'PASIF. ';
rnts.name[getdaytime] := 'DAYTM. ';
END %RUNTIME-, DEBUG-SUPPORTS\ ;
INITPROCEDURE %INITSCALARS\ ;
BEGIN
CHANTAB[1] := 0; CHANTAB[2] := 0; CHANTAB[3] := 0; CHANTAB[4] := 0;
(* 65 - remove exit labels *)
FWPTR := NIL; LASTBTP := NIL; FGLOBPTR := NIL ; FILEPTR := NIL ;
LOCALPFPTR:=NIL; EXTERNPFPTR:= NIL; GLOBTESTP := NIL; ERRMPTR := NIL;
(* 24 - INITIALZE HEAP AND STACK *)
HEAP := 0; STACK := 0;
LISTCODE := FALSE; LOADNOPTR := TRUE; INITGLOBALS := FALSE ; RUNTMCHECK := TRUE;
(* 157 - separate control for arith error *)
ARITHCHECK := TRUE;
TTYINUSE := TRUE; FOLLOWERROR := FALSE; ERRORINLINE := FALSE; RESETFLAG := TRUE;
(* 172 *)
TTYSEEEOL := FALSE;
DP := TRUE; PRTERR := TRUE; ERRORFLAG := FALSE ; MAIN := TRUE;
ENTRYDONE := FALSE; DEBUG := FALSE; DEBUGSWITCH := FALSE;
(* 176 *)
comment_page := 0;
(* 33 - PROGRAM *)
FPROGFILE := NIL; LPROGFILE := NIL;
(* 64 - non-loc goto *)
lastlabel := nil;
IC := HIGHSTART; %START OF HIGHSEGMENT\
LC := PROGRST; %START OF LOWSEGMENT AVAILABLE TO PROGRAM\
(* 136 - listing format *)
CHCNT := 0; LINECNT := 1; PAGECNT := 1; SUBPAGE := 0;
LASTLINE := -1; LASTPAGE := 0;
(* 12 - initialize new variables for dynamic core *)
LIBIX := 0; ERRINX := 0; LSTNEW := 0; NEWBND := 0;
END %INITSCALARS\ ;
INITPROCEDURE %INITSETS\ ;
BEGIN
DIGITS := ['0'..'9'];
LETTERS := ['A'..'Z'];
HEXADIGITS := ['0'..'9','A'..'F'];
LETTERSORDIGITS := [ '0'..'9','A'..'Z'];
LETTERSDIGITSORLEFTARROW := ['0'..'9','A'..'Z','_'];
LANGUAGESYS := [FORTRANSY,ALGOLSY,COBOLSY,PASCALSY];
CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT];
SIMPTYPEBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT] ;
TYPEBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,ARROW,PACKEDSY,ARRAYSY,RECORDSY,SETSY,FILESY] ;
TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY];
(* 56 - add require files *)
BLOCKBEGSYS := [INCLUDESY,LABELSY,CONSTSY,TYPESY,VARSY,INITPROCSY,PROCEDURESY,FUNCTIONSY,BEGINSY];
SELECTSYS := [ARROW,PERIOD,LBRACK];
FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY];
STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,LOOPSY,FORSY,WITHSY,CASESY]
END %INITSETS\ ;
INITPROCEDURE %RESWORDS\ ;
BEGIN
RW[ 1] := 'IF '; RW[ 2] := 'DO '; RW[ 3] := 'OF ';
RW[ 4] := 'TO '; RW[ 5] := 'IN '; RW[ 6] := 'OR ';
RW[ 7] := 'END '; RW[ 8] := 'FOR '; RW[ 9] := 'VAR ';
RW[10] := 'DIV '; RW[11] := 'MOD '; RW[12] := 'SET ';
RW[13] := 'AND '; RW[14] := 'NOT '; RW[15] := 'THEN ';
RW[16] := 'ELSE '; RW[17] := 'WITH '; RW[18] := 'GOTO ';
RW[19] := 'LOOP '; RW[20] := 'CASE '; RW[21] := 'TYPE ';
RW[22] := 'FILE '; RW[23] := 'EXIT '; RW[24] := 'BEGIN ';
RW[25] := 'UNTIL '; RW[26] := 'WHILE '; RW[27] := 'ARRAY ';
RW[28] := 'CONST '; RW[29] := 'LABEL '; RW[30] := 'ALGOL ';
RW[31] := 'COBOL '; RW[32] := 'EXTERN '; RW[33] := 'PASCAL ';
RW[34] := 'RECORD '; RW[35] := 'DOWNTO '; RW[36] := 'PACKED ';
RW[37] := 'OTHERS '; RW[38] := 'REPEAT '; RW[39] := 'FORTRAN ';
(* 6 - add PROGRAM statement *)
(* 56 - ADD INCLUDE *)
RW[40] := 'FORWARD '; RW[41] := 'PROGRAM '; RW[42] := 'INCLUDE ';
RW[43] := 'FUNCTION '; RW[44] := 'PROCEDURE ';
RW[45] := 'INITPROCED';
FRW[1] := 1; FRW[2] := 1; FRW[3] := 7; FRW[4] := 15; FRW[5] := 24;
FRW[6] := 32; FRW[7] := 39; FRW[8] := 43; FRW[9] := 44; FRW[10] := 45;
FRW[11] := 46;
END %RESWORDS\ ;
INITPROCEDURE %SYMBOLS\ ;
BEGIN
RSY[1] := IFSY; RSY[2] := DOSY; RSY[3] := OFSY; RSY[4] := TOSY;
RSY[5] := RELOP; RSY[6] := ADDOP; RSY[7] := ENDSY; RSY[8] := FORSY;
RSY[9] := VARSY; RSY[10] := MULOP; RSY[11] := MULOP; RSY[12] := SETSY;
RSY[13] := MULOP; RSY[14] := NOTSY; RSY[15] := THENSY;
RSY[16] := ELSESY; RSY[17] := WITHSY; RSY[18] := GOTOSY;
RSY[19] := LOOPSY; RSY[20] := CASESY; RSY[21] := TYPESY;
RSY[22] := FILESY; RSY[23] := EXITSY; RSY[24] := BEGINSY;
RSY[25] := UNTILSY; RSY[26] := WHILESY; RSY[27] := ARRAYSY;
RSY[28] := CONSTSY; RSY[29] := LABELSY;
RSY[30] := ALGOLSY; RSY[31] := COBOLSY;
RSY[32] := EXTERNSY; RSY[33] := PASCALSY; RSY[34] := FORTRANSY;
RSY[34] := RECORDSY; RSY[35]:= DOWNTOSY; RSY[36] := PACKEDSY;
RSY[37] := OTHERSSY; RSY[38]:= REPEATSY; RSY[39] := FORTRANSY;
(* 6 - add PROGRAM statement *)
(* 56 - ADD INCLUDE *)
RSY[40] := FORWARDSY; RSY[41] := PROGRAMSY; RSY[42] := INCLUDESY; RSY[43] := FUNCTIONSY;
RSY[44] := PROCEDURESY; RSY[45] := INITPROCSY;
SSY['A'] := OTHERSY; SSY['B'] := OTHERSY; SSY['C'] := OTHERSY;
SSY['D'] := OTHERSY; SSY['E'] := OTHERSY; SSY['F'] := OTHERSY;
SSY['G'] := OTHERSY; SSY['H'] := OTHERSY; SSY['I'] := OTHERSY;
SSY['J'] := OTHERSY; SSY['K'] := OTHERSY; SSY['L'] := OTHERSY;
SSY['M'] := OTHERSY; SSY['N'] := OTHERSY; SSY['O'] := OTHERSY;
SSY['P'] := OTHERSY; SSY['Q'] := OTHERSY; SSY['R'] := OTHERSY;
SSY['S'] := OTHERSY; SSY['T'] := OTHERSY; SSY['U'] := OTHERSY;
SSY['V'] := OTHERSY; SSY['W'] := OTHERSY; SSY['X'] := OTHERSY;
SSY['Y'] := OTHERSY; SSY['Z'] := OTHERSY; SSY['0'] := OTHERSY;
SSY['1'] := OTHERSY; SSY['2'] := OTHERSY; SSY['3'] := OTHERSY;
SSY['4'] := OTHERSY; SSY['5'] := OTHERSY; SSY['6'] := OTHERSY;
SSY['7'] := OTHERSY; SSY['8'] := OTHERSY; SSY['9'] := OTHERSY;
SSY['_'] := OTHERSY;
SSY['+'] := ADDOP; SSY['-'] := ADDOP; SSY['*'] := MULOP;
SSY['/'] := MULOP; SSY['('] := LPARENT; SSY[')'] := RPARENT;
SSY['$'] := OTHERSY; SSY['='] := RELOP; SSY[' '] := OTHERSY;
SSY[','] := COMMA; SSY['.'] := PERIOD; SSY[''''] := OTHERSY;
SSY['['] := LBRACK; SSY[']'] := RBRACK; SSY[':'] := COLON;
SSY['#'] := RELOP; SSY['%'] := OTHERSY; SSY['!'] := ADDOP;
SSY['&'] := MULOP; SSY['^'] := ARROW; SSY['\'] := OTHERSY;
SSY['<'] := RELOP; SSY['>'] := RELOP; SSY['@'] := RELOP;
SSY['"'] := RELOP; SSY['?'] := NOTSY; SSY[';'] := SEMICOLON;
END %SYMBOLS\ ;
INITPROCEDURE %OPERATORS\ ;
BEGIN
ROP[ 1] := NOOP; ROP[ 2] := NOOP; ROP[ 3] := NOOP; ROP[ 4] := NOOP;
ROP[ 5] := INOP; ROP[ 6] := OROP; ROP[ 7] := NOOP; ROP[ 8] := NOOP;
ROP[ 9] := NOOP; ROP[10] := IDIV; ROP[11] := IMOD; ROP[12] := NOOP;
ROP[13] :=ANDOP; ROP[14] := NOOP; ROP[15] := NOOP; ROP[16] := NOOP;
ROP[17] := NOOP; ROP[18] := NOOP; ROP[19] := NOOP; ROP[20] := NOOP;
ROP[21] := NOOP; ROP[22] := NOOP; ROP[23] := NOOP; ROP[24] := NOOP;
ROP[25] := NOOP; ROP[26] := NOOP; ROP[27] := NOOP; ROP[28] := NOOP;
ROP[29] := NOOP; ROP[30] := NOOP; ROP[31] := NOOP; ROP[32] := NOOP;
ROP[33] := NOOP; ROP[34] := NOOP; ROP[35] := NOOP; ROP[36] := NOOP;
ROP[37] := NOOP; ROP[38] := NOOP; ROP[39] := NOOP; ROP[40] := NOOP;
(* 6 - add PROGRAM statement *)
(* 56 - ADD INCLUDE *)
ROP[41] := NOOP; ROP[42] := NOOP; ROP[43] := NOOP; ROP[44] := NOOP; ROP[45] := NOOP;
SOP['+'] := PLUS; SOP['-'] := MINUS; SOP['*'] := MUL; SOP['/'] := RDIV;
SOP['='] := EQOP; SOP['#'] := NEOP; SOP['!'] := OROP; SOP['&'] := ANDOP;
SOP['<'] := LTOP; SOP['>'] := GTOP; SOP['@'] := LEOP; SOP['"'] := GEOP;
SOP[' '] := NOOP; SOP['$'] := NOOP; SOP['%'] := NOOP; SOP['('] := NOOP;
SOP[')'] := NOOP; SOP[','] := NOOP; SOP['.'] := NOOP; SOP['0'] := NOOP;
SOP['1'] := NOOP; SOP['2'] := NOOP; SOP['3'] := NOOP; SOP['4'] := NOOP;
SOP['5'] := NOOP; SOP['6'] := NOOP; SOP['7'] := NOOP; SOP['8'] := NOOP;
SOP['9'] := NOOP; SOP[':'] := NOOP; SOP[';'] := NOOP; SOP['?'] := NOOP;
SOP['A'] := NOOP; SOP['B'] := NOOP; SOP['C'] := NOOP; SOP['D'] := NOOP;
SOP['E'] := NOOP; SOP['F'] := NOOP; SOP['G'] := NOOP; SOP['H'] := NOOP;
SOP['I'] := NOOP; SOP['J'] := NOOP; SOP['K'] := NOOP; SOP['L'] := NOOP;
SOP['M'] := NOOP; SOP['N'] := NOOP; SOP['O'] := NOOP; SOP['P'] := NOOP;
SOP['Q'] := NOOP; SOP['R'] := NOOP; SOP['S'] := NOOP; SOP['T'] := NOOP;
SOP['U'] := NOOP; SOP['V'] := NOOP; SOP['W'] := NOOP; SOP['X'] := NOOP;
SOP['Y'] := NOOP; SOP['Z'] := NOOP; SOP['['] := NOOP; SOP['\'] := NOOP;
SOP[']'] := NOOP; SOP['^'] := NOOP; SOP['_'] := NOOP; SOP[''''] := NOOP;
END %OPERATORS\ ;
INITPROCEDURE %RECORDSIZES\;
BEGIN
IDRECSIZE[TYPES] := 5;
IDRECSIZE[KONST] := 6;
IDRECSIZE[VARS] := 6;
IDRECSIZE[FIELD] := 6;
IDRECSIZE[PROC] := 5;
IDRECSIZE[FUNC] := 8;
(* 116 - define size of the new types for copyctp *)
IDRECSIZE[PARAMS] := 5;
IDRECSIZE[LABELT] := 6;
STRECSIZE[SCALAR] := 2;
STRECSIZE[SUBRANGE]:=4;
STRECSIZE[POINTER]:= 2;
STRECSIZE[POWER] := 2;
STRECSIZE[ARRAYS] := 3;
STRECSIZE[RECORDS]:= 3;
STRECSIZE[FILES] := 2;
STRECSIZE[TAGFWITHID]:=3;
STRECSIZE[TAGFWITHOUTID] := 3;
STRECSIZE[VARIANT] :=4
END;
INITPROCEDURE %ERRORMESSAGES\ ;
BEGIN
ERRMESS15[ 1] := '":" expected ';
ERRMESS15[ 2] := '")" expected ';
ERRMESS15[ 3] := '"(" expected ';
ERRMESS15[ 4] := '"[" expected ';
ERRMESS15[ 5] := '"]" expected ';
ERRMESS15[ 6] := '";" expected ';
ERRMESS15[ 7] := '"=" expected ';
ERRMESS15[ 8] := '"," expected ';
ERRMESS15[ 9] := '":=" expected ';
ERRMESS15[10] := '"OF" expected ';
ERRMESS15[11] := '"DO" expected ';
ERRMESS15[12] := '"IF" expected ';
ERRMESS15[13] := '"END" expected ';
ERRMESS15[14] := '"THEN" expected';
ERRMESS15[15] := '"EXIT" expected';
ERRMESS15[16] := 'Illegal symbol ';
ERRMESS15[17] := 'No sign allowed';
ERRMESS15[18] := 'Number expected';
ERRMESS15[19] := 'Not implemented';
ERRMESS15[20] := 'Error in type ';
(* 35 - new error - no longer need old one, so we replaced*)
ERRMESS15[21] := 'Compiler error ';
ERRMESS15[22] := '"." expected ';
ERRMESS15[23] := 'Error in factor';
ERRMESS15[24] := 'Too many digits';
ERRMESS20[ 1] := '"BEGIN" expected ';
ERRMESS20[ 2] := '"UNTIL" expected ';
ERRMESS20[ 3] := 'Error in options ';
ERRMESS20[ 4] := 'Constant too large ';
ERRMESS20[ 5] := 'Digit must follow ';
ERRMESS20[ 6] := 'Exponent too large ';
ERRMESS20[ 7] := 'Constant expected ';
ERRMESS20[ 8] := 'Simple type expected';
ERRMESS20[ 9] := 'Identifier expected ';
ERRMESS20[10] := 'Realtype not allowed';
ERRMESS20[11] := 'Multidefined label ';
ERRMESS20[12] := 'Filename expected ';
ERRMESS20[13] := 'Set type expected ';
ERRMESS20[14] := 'Undeclared exitlabel';
ERRMESS20[15] := 'Undeclared label ';
(* 6 - add error msg for illegal character *)
ERRMESS20[16] := 'Illegal character ';
ERRMESS25[ 1] := '"TO"/"DOWNTO" expected ';
ERRMESS25[ 2] := '8 OR 9 in octal number ';
ERRMESS25[ 3] := 'Identifier not declared ';
ERRMESS25[ 4] := 'File not allowed here ';
ERRMESS25[ 5] := 'Integer constant expected';
ERRMESS25[ 6] := 'Error in parameterlist ';
ERRMESS25[ 7] := 'Already forward declared ';
ERRMESS25[ 8] := 'This format for real only';
ERRMESS25[ 9] := 'Varianttype must be array';
ERRMESS25[10] := 'Type conflict of operands';
ERRMESS25[11] := 'Multidefined case label ';
ERRMESS25[12] := 'Octal for integer only ';
ERRMESS25[13] := 'Array index out of bounds';
(* 26 - two new error messages for reset/rewrite/update *)
ERRMESS25[14] := 'Must be array or record ';
ERRMESS25[15] := 'Must be at least 5 words ';
(* 104 - error message for too much data for address space *)
ERRMESS25[16] := 'Data won''t fit in memory ';
ERRMESS30[ 1] := 'String constant is too long ';
ERRMESS30[ 2] := 'Identifier already declared ';
ERRMESS30[ 3] := 'Subrange bounds must be scalar';
ERRMESS30[ 4] := 'Incompatible subrange types ';
ERRMESS30[ 5] := 'Incompatible with tagfieldtype';
ERRMESS30[ 6] := 'Index type may not be integer ';
ERRMESS30[ 7] := 'Type of variable is not array ';
ERRMESS30[ 8] := 'Type of variable is not record';
ERRMESS30[ 9] := 'No such field in this record ';
ERRMESS30[10] := 'Expression too complicated ';
ERRMESS30[11] := 'Illegal type of operand(s) ';
ERRMESS30[12] := 'Tests on equality allowed only';
ERRMESS30[13] := 'Strict inclusion not allowed ';
(* 24 - CAN'T COMPARE RECORDS OR ARRAYS NOW *)
ERRMESS30[14] := 'Structure comparison illegal ';
ERRMESS30[15] := 'Illegal type of expression ';
ERRMESS30[16] := 'Value of case label too large ';
ERRMESS30[17] := 'Too many nested withstatements';
ERRMESS35[ 1] := 'String constant contains "<CR><LF>"';
ERRMESS35[ 2] := 'Basetype requires more than 72 bits';
ERRMESS35[ 3] := 'Basetype must be scalar or subrange';
ERRMESS35[ 4] := 'More than 12 files declared by user';
ERRMESS35[ 5] := 'File as value parameter not allowed';
ERRMESS35[ 6] := 'Procedure too long (too much code) ';
ERRMESS35[ 7] := 'No packed structure allowed here ';
ERRMESS35[ 8] := 'Variant must belong to tagfieldtype';
ERRMESS35[ 9] := 'Type of operand(s) must be boolean ';
ERRMESS35[10] := 'Set element types not compatible ';
ERRMESS35[11] := 'Assignment to files not allowed ';
ERRMESS35[12] := 'Too many labels in this procedure ';
ERRMESS35[13] := 'Too many cases in case statement ';
ERRMESS35[14] := 'Control variable may not be formal ';
ERRMESS35[15] := 'Illegal type of for-controlvariable';
ERRMESS35[16] := 'Type of filecomponent must be char ';
ERRMESS35[17] := 'Constant not in bounds of subrange ';
(* 156 ftn^ := *)
ERRMESS35[18] := 'Illegal when assigning to function ';
ERRMESS40[ 1] := 'Identifier is not of appropriate class ';
ERRMESS40[ 2] := 'Tagfield type must be scalar or subrange';
ERRMESS40[ 3] := 'Index type must be scalar or subrange ';
ERRMESS40[ 4] := 'Too many nested scopes of identifiers ';
ERRMESS40[ 5] := 'Pointer forward reference unsatisfied ';
ERRMESS40[ 6] := 'Previous declaration was not forward ';
ERRMESS40[ 7] := 'Type of variable must be file or pointer';
ERRMESS40[ 8] := 'Missing corresponding variantdeclaration';
ERRMESS40[ 9] := 'Too many variants in call of NEW (max 6)';
ERRMESS40[10] := 'More than four errors in this sourceline';
ERRMESS40[11] := 'No initialisation on records or files ';
(* 31 - new message *)
ERRMESS40[12] := 'Assignment to func. must be in its body ';
ERRMESS40[13] := 'Too many parameters (must fit in AC''s) ';
ERRMESS45[ 1] := 'Low bound may not be greater than high bound ';
ERRMESS45[ 2] := 'Identifier or "CASE" expected in fieldlist ';
ERRMESS45[ 3] := 'Too many nested procedures and/or functions ';
ERRMESS45[ 4] := 'File declaration in procedures not allowed ';
ERRMESS45[ 5] := 'Missing result type in function declaration ';
ERRMESS45[ 6] := 'Assignment to formal function is not allowed ';
ERRMESS45[ 7] := 'Index type is not compatible with declaration';
ERRMESS45[ 8] := 'Error in type of standard procedure parameter';
ERRMESS45[ 9] := 'Error in type of standard function parameter ';
ERRMESS45[10] := 'Real and string tagfields not implemented ';
ERRMESS45[11] := 'Set element type must be scalar or subrange ';
ERRMESS45[12] := 'In initprocedure only assignments possible ';
ERRMESS45[13] := 'No constant or expression for VAR argument ';
ERRMESS45[14] := 'EXTERN declaration not allowed in procedures ';
ERRMESS45[15] := 'Body of forward declared procedure missing ';
(* 24 - NEW ERROR MSG FOR LOC *)
ERRMESS45[16] := 'Must be user-declared PASCAL proc. or func. ';
ERRMESS50[ 1] := 'Too many forward references of procedure entries ';
ERRMESS50[ 2] := 'Assignment to standard function is not allowed ';
ERRMESS50[ 3] := 'Parameter type does not agree with declaration ';
ERRMESS50[ 4] := 'Initialisation only by assignment of constants ';
ERRMESS50[ 5] := 'Label type incompatible with selecting expression ';
ERRMESS50[ 6] := 'Statement must end with ";","END","ELSE"or"UNTIL" ';
ERRMESS50[ 7] := 'Not allowed in initprocedures (packed structure?) ';
(* 33 - PROGRAM *)
ERRMESS50[ 8] := 'File mentioned in PROGRAM statement not declared ';
(* 211 - better err msg *)
ERRMESS50[ 9] := 'Variable mentioned in PROGRAM statement not a file';
ERRMESS55[ 1] := 'Function result type must be scalar,subrange or pointer';
ERRMESS55[ 2] := 'Forward decl. func:repetition of resulttype not allowed';
ERRMESS55[ 3] := 'Forward decl.: repetition of parameter list not allowed';
ERRMESS55[ 4] := 'Number of parameters does not agree with declaration ';
ERRMESS55[ 5] := 'Resulttype of parameter func. does not agree with decl.';
ERRMESS55[ 6] := 'Selected expression must have type of control variable ';
(* 124 - detect bad initproc *)
ERRMESS55[ 7] := 'INITPROCEDURE can''t be within a procedure or function ';
END %ERROR MESSAGES\ ;
(* 105 - new mapping from lower case *)
initprocedure %character mapping tables\ ;
begin
charmap[0B] := 0B; charmap[1B] := 1B; charmap[2B] := 2B; charmap[3B] := 3B;
charmap[4B] := 4B; charmap[5B] := 5B; charmap[6B] := 6B; charmap[7B] := 7B;
charmap[10B] := 10B; charmap[11B] := 11B; charmap[12B] := 12B; charmap[13B] := 13B;
charmap[14B] := 14B; charmap[15B] := 15B; charmap[16B] := 16B; charmap[17B] := 17B;
charmap[20B] := 20B; charmap[21B] := 21B; charmap[22B] := 22B; charmap[23B] := 23B;
charmap[24B] := 24B; charmap[25B] := 25B; charmap[26B] := 26B; charmap[27B] := 27B;
charmap[30B] := 30B; charmap[31B] := 31B; charmap[32B] := 32B; charmap[33B] := 33B;
charmap[34B] := 34B; charmap[35B] := 35B; charmap[36B] := 36B; charmap[37B] := 37B;
charmap[40B] := 40B; charmap[41B] := 41B; charmap[42B] := 42B; charmap[43B] := 43B;
charmap[44B] := 44B; charmap[45B] := 45B; charmap[46B] := 46B; charmap[47B] := 47B;
charmap[50B] := 50B; charmap[51B] := 51B; charmap[52B] := 52B; charmap[53B] := 53B;
charmap[54B] := 54B; charmap[55B] := 55B; charmap[56B] := 56B; charmap[57B] := 57B;
charmap[60B] := 60B; charmap[61B] := 61B; charmap[62B] := 62B; charmap[63B] := 63B;
charmap[64B] := 64B; charmap[65B] := 65B; charmap[66B] := 66B; charmap[67B] := 67B;
charmap[70B] := 70B; charmap[71B] := 71B; charmap[72B] := 72B; charmap[73B] := 73B;
charmap[74B] := 74B; charmap[75B] := 75B; charmap[76B] := 76B; charmap[77B] := 77B;
charmap[100B] := 100B; charmap[101B] := 101B; charmap[102B] := 102B; charmap[103B] := 103B;
charmap[104B] := 104B; charmap[105B] := 105B; charmap[106B] := 106B; charmap[107B] := 107B;
charmap[110B] := 110B; charmap[111B] := 111B; charmap[112B] := 112B; charmap[113B] := 113B;
charmap[114B] := 114B; charmap[115B] := 115B; charmap[116B] := 116B; charmap[117B] := 117B;
charmap[120B] := 120B; charmap[121B] := 121B; charmap[122B] := 122B; charmap[123B] := 123B;
charmap[124B] := 124B; charmap[125B] := 125B; charmap[126B] := 126B; charmap[127B] := 127B;
charmap[130B] := 130B; charmap[131B] := 131B; charmap[132B] := 132B; charmap[133B] := 133B;
charmap[134B] := 134B; charmap[135B] := 135B; charmap[136B] := 136B; charmap[137B] := 137B;
charmap[140B] := 140B; charmap[141B] := 101B; charmap[142B] := 102B; charmap[143B] := 103B;
charmap[144B] := 104B; charmap[145B] := 105B; charmap[146B] := 106B; charmap[147B] := 107B;
charmap[150B] := 110B; charmap[151B] := 111B; charmap[152B] := 112B; charmap[153B] := 113B;
charmap[154B] := 114B; charmap[155B] := 115B; charmap[156B] := 116B; charmap[157B] := 117B;
charmap[160B] := 120B; charmap[161B] := 121B; charmap[162B] := 122B; charmap[163B] := 123B;
charmap[164B] := 124B; charmap[165B] := 125B; charmap[166B] := 126B; charmap[167B] := 127B;
charmap[170B] := 130B; charmap[171B] := 131B; charmap[172B] := 132B; charmap[173B] := 173B;
charmap[174B] := 174B; charmap[175B] := 175B; charmap[176B] := 176B; charmap[177B] := 177B;
(* 140 - redid numbers to make it come in the same order as ASCII *)
setmap[0B] := 0B; setmap[1B] := 0B; setmap[2B] := 0B; setmap[3B] := 0B;
setmap[4B] := 0B; setmap[5B] := 0B; setmap[6B] := 0B; setmap[7B] := 0B;
setmap[10B] := 0B; setmap[11B] := 1B; setmap[12B] := 0B; setmap[13B] := 0B;
setmap[14B] := 0B; setmap[15B] := 0B; setmap[16B] := 0B; setmap[17B] := 0B;
setmap[20B] := 0B; setmap[21B] := 0B; setmap[22B] := 0B; setmap[23B] := 0B;
setmap[24B] := 0B; setmap[25B] := 0B; setmap[26B] := 0B; setmap[27B] := 0B;
setmap[30B] := 0B; setmap[31B] := 0B; setmap[32B] := 0B; setmap[33B] := 0B;
setmap[34B] := 0B; setmap[35B] := 0B; setmap[36B] := 0B; setmap[37B] := 0B;
setmap[40B] := 2B; setmap[41B] := 3B; setmap[42B] := 4B; setmap[43B] := 5B;
setmap[44B] := 6B; setmap[45B] := 7B; setmap[46B] := 10B; setmap[47B] := 11B;
setmap[50B] := 12B; setmap[51B] := 13B; setmap[52B] := 14B; setmap[53B] := 15B;
setmap[54B] := 16B; setmap[55B] := 17B; setmap[56B] := 20B; setmap[57B] := 21B;
setmap[60B] := 22B; setmap[61B] := 23B; setmap[62B] := 24B; setmap[63B] := 25B;
setmap[64B] := 26B; setmap[65B] := 27B; setmap[66B] := 30B; setmap[67B] := 31B;
setmap[70B] := 32B; setmap[71B] := 33B; setmap[72B] := 34B; setmap[73B] := 35B;
setmap[74B] := 36B; setmap[75B] := 37B; setmap[76B] := 40B; setmap[77B] := 41B;
setmap[100B] := 42B; setmap[101B] := 43B; setmap[102B] := 44B; setmap[103B] := 45B;
setmap[104B] := 46B; setmap[105B] := 47B; setmap[106B] := 50B; setmap[107B] := 51B;
setmap[110B] := 52B; setmap[111B] := 53B; setmap[112B] := 54B; setmap[113B] := 55B;
setmap[114B] := 56B; setmap[115B] := 57B; setmap[116B] := 60B; setmap[117B] := 61B;
setmap[120B] := 62B; setmap[121B] := 63B; setmap[122B] := 64B; setmap[123B] := 65B;
setmap[124B] := 66B; setmap[125B] := 67B; setmap[126B] := 70B; setmap[127B] := 71B;
setmap[130B] := 72B; setmap[131B] := 73B; setmap[132B] := 74B; setmap[133B] := 75B;
setmap[134B] := 76B; setmap[135B] := 77B; setmap[136B] := 100B; setmap[137B] := 101B;
setmap[140B] := 102B; setmap[141B] := 43B; setmap[142B] := 44B; setmap[143B] := 45B;
setmap[144B] := 46B; setmap[145B] := 47B; setmap[146B] := 50B; setmap[147B] := 51B;
setmap[150B] := 52B; setmap[151B] := 53B; setmap[152B] := 54B; setmap[153B] := 55B;
setmap[154B] := 56B; setmap[155B] := 57B; setmap[156B] := 60B; setmap[157B] := 61B;
setmap[160B] := 62B; setmap[161B] := 63B; setmap[162B] := 64B; setmap[163B] := 65B;
setmap[164B] := 66B; setmap[165B] := 67B; setmap[166B] := 70B; setmap[167B] := 71B;
setmap[170B] := 72B; setmap[171B] := 73B; setmap[172B] := 74B; setmap[173B] := 103B;
setmap[174B] := 104B; setmap[175B] := 105B; setmap[176B] := 106B; setmap[177B] := 107B;
end; %character mapping tables\
%-------------------------------------------------------------------------------\
(* 40 - make it restartable *)
procedure reinit;
begin
CHANTAB[1] := 0; CHANTAB[2] := 0; CHANTAB[3] := 0; CHANTAB[4] := 0;
(* 65 - remove exit labels *)
FWPTR := NIL; LASTBTP := NIL; FGLOBPTR := NIL ; FILEPTR := NIL ;
LOCALPFPTR:=NIL; EXTERNPFPTR:= NIL; GLOBTESTP := NIL; ERRMPTR := NIL;
(* 24 - INITIALZE HEAP AND STACK *)
HEAP := 0; STACK := 0;
(* 124 - initialize CREF *)
(* 125 - and REQFILE *)
CREF := false; reqfile := false;
LISTCODE := FALSE; LOADNOPTR := TRUE; INITGLOBALS := FALSE ; RUNTMCHECK := TRUE;
(* 157 - separate check for arith error *)
ARITHCHECK := TRUE;
TTYINUSE := TRUE; FOLLOWERROR := FALSE; ERRORINLINE := FALSE; RESETFLAG := TRUE;
(* 172 - end of line *)
TTYSEEEOL := FALSE;
DP := TRUE; PRTERR := TRUE; ERRORFLAG := FALSE ; MAIN := TRUE;
ENTRYDONE := FALSE; DEBUG := FALSE; DEBUGSWITCH := FALSE;
(* 176 *)
comment_page := 0;
(* 33 - PROGRAM *)
FPROGFILE := NIL; LPROGFILE := NIL;
IC := HIGHSTART; %START OF HIGHSEGMENT\
LC := PROGRST; %START OF LOWSEGMENT AVAILABLE TO PROGRAM\
(* 136 - listing format *)
CHCNT := 0; LINECNT := 1; PAGECNT := 1; SUBPAGE := 0; CURLINE := 1;
LASTLINE := -1; LASTPAGE := 0;
(* 12 - initialize new variables for dynamic core *)
LIBIX := 0; ERRINX := 0; LSTNEW := 0; NEWBND := 0;
with pager.word1 do
begin instr:=0;ac:=0;indbit:=0;inxreg:=0;address:=0 end;
pager.lhalf := 0; pager.rhalf := 0;
debugentry.lastpageelem := pager;
laststop := 0; lastpager := 0;
(* 103 - changed type for idtree's *)
debugentry.standardidtree := nil;
debugentry.globalidtree := nil;
filename := ' ';
LIBRARY[PASCALSY].INORDER := FALSE;
LIBRARY[FORTRANSY].INORDER := FALSE;
LIBRARY[ALGOLSY].INORDER := FALSE;
LIBRARY[COBOLSY].INORDER := FALSE;
LIBRARY[PASCALSY].CALLED := FALSE;
LIBRARY[FORTRANSY].CALLED := FALSE;
LIBRARY[ALGOLSY].CALLED := FALSE;
LIBRARY[COBOLSY].CALLED := FALSE;
(* 105 - map lower case better *)
setmapchain := 0;
end;
(* 136 - new listing format *)
procedure pagehead;
begin
page;
write(header,' ',day,' ',scandata^.relname);
if reqfile
then write(' ****Included file****');
write(' Page ',pagecnt:0);
if subpage > 0
then write('-',subpage:0);
writeln;
writeln;
curline := 1;
end;
procedure newline;
begin
writeln;
curline := curline+1;
if curline > 53
then begin
subpage := subpage + 1;
pagehead;
end
end;
PROCEDURE NEWPAGER;
BEGIN
WITH PAGER, WORD1 DO
BEGIN
AC := PAGECNT DIV 16;
INXREG := PAGECNT MOD 16; ADDRESS := LASTPAGER;
LHALF := LASTLINE; RHALF := LASTSTOP;
LASTLINE := -1
END
END;
(* 5 - reorganized printing somewhat for CREF *)
(* The FILCOM is a bit misleading here, as global changes have been made *)
PROCEDURE BEGOFLINE;
BEGIN
IF CREF THEN WRITE(CHR(177B),'A');
IF CHCNT > CHCNTMAX THEN CHCNT := CHCNTMAX;
IF LISTCODE
THEN
BEGIN
(* 5 - more of the CREF change *)
IF BEGDP
THEN
BEGIN
WRITE(BEGLC:6:O);
IF (BEGLC < PROGRST) OR (BEGLEVEL > 1)
THEN WRITE(' ')
ELSE WRITE('''')
END
ELSE WRITE(BEGIC:6:O,'''');
WRITE(' ':2)
END;
IF LINENR='-----'
THEN WRITE(LINECNT:5)
ELSE WRITE(LINENR) ;
WRITE(' ':3);
END;
PROCEDURE WRITEBUFFER;
BEGIN
IF LISTCODE
THEN
BEGIN
(* 5 - more CREF *)
IF CREF THEN WRITE(CHR(177B),'B'); BEGOFLINE;
(* 136 - listing format *)
WRITE(BUFFER:CHCNT); FOR CHCNT := 1 TO 17 DO BUFFER[CHCNT] := ' '; CHCNT := 17;
newline;
END
END;
PROCEDURE GETNEXTLINE;
BEGIN
LOOP
GETLINENR(LINENR);
EXIT IF INPUT^ # CHR(14B); %TEST END OF PAGE\
IF DEBUG AND (LASTLINE > -1)
THEN NEWPAGER;
(* 136 - listing format *)
PAGECNT := PAGECNT + 1; SUBPAGE := 0;
pagehead;
(* 137 - reset line to 1 on each page *)
linecnt := 1;
READLN; %TO OVERREAD SECOND CARRIAGE RETURN IN PAGE MARK\
END;
IF CREF
THEN WRITE(CHR(177B),'B');
BEGIC:=IC;BEGLC:=LC;BEGDP:=DP;BEGLEVEL:=LEVEL;
END;
(* 56 - needed for file switch *)
PROCEDURE BEGSTUFF;
BEGIN
IF CREF
THEN WRITE(CHR(177B),'B');
BEGIC:=IC;BEGLC:=LC;BEGDP:=DP;BEGLEVEL:=LEVEL;
CHCNT:=0
END;
(* 16 - DETECT UNEXPECTED EOF *)
(* 41 - make restartable *)
PROCEDURE PASXIT(VAR A,B,C:FILE); EXTERN;
(* 55 - ADD PROC'S FOR REQUIRE FILES *)
PROCEDURE PUSHF(VAR F:FILE;S:STRGARR;L:INTEGER); EXTERN;
PROCEDURE POPF(VAR F:FILE); EXTERN;
(* 107 - moved declaration of analys so can be used several places *)
procedure analys(var f:file); extern;
(* 112 - clrbfi when error detected *)
procedure clribf; extern;
(* 141 - better detection of number overflow *)
function overflow:Boolean; extern;
(* 155 - source file name *)
procedure curname(var f:file;var s:string); extern;
(* 56 - SEPARATE OUT STUFF NEEDED FOR FILE SWITCH *)
PROCEDURE ENDSTUFF;
VAR
I,K: INTEGER;
BEGIN
(* 5 - more CREF *)
BEGOFLINE;
(* 136 - listing format *)
WRITE(BUFFER:CHCNT); NEWLINE;
IF ERRORINLINE
THEN %OUTPUT ERROR MESSAGES\
BEGIN
IF LISTCODE
THEN K := 11
ELSE K := 2;
WRITE(' ':K,'***** '); LISTCODE := FALSE;
IF LINENR = '-----'
THEN WRITE(TTY,LINECNT:5)
ELSE WRITE(TTY,LINENR);
WRITELN(TTY,' ':3,BUFFER:CHCNT); WRITE(TTY,'P*',PAGECNT:3,'** ');
(* 5 - more CREF *)
FOR K:=1 TO CHCNT DO
IF BUFFER[K] = CHR(11B)
THEN ERRLINE[K] := CHR(11B);
(* 136 - LISTING FORMAT *)
WRITE(ERRLINE : CHCNT); WRITELN(TTY,ERRLINE : CHCNT); NEWLINE;
FOR K := 1 TO ERRINX DO
WITH ERRLIST[K] DO
BEGIN
WRITE(' ':15,ARW:1,'.',TIC,': '); WRITE(TTY,ARW:1,'.',TIC,': ');
IF ERRMPTR # NIL
THEN
BEGIN
ERRMPTR1 := ERRMPTR;
WHILE ERRMPTR1 # NIL DO
WITH ERRMPTR1^ DO
BEGIN
IF NMR = NUMBER
THEN
BEGIN
CASE FORM OF
C:
BEGIN
WRITE(STRING:10,' --> ');WRITE(TTY,STRING:10,' --> ')
END;
D:
BEGIN
WRITE(INTVAL:5,' --> ');WRITE(TTY,INTVAL:5,' --> ')
END
END;
NUMBER := 0; ERRMPTR1 := NIL
END
ELSE ERRMPTR1 := NEXT
END
END;
I := NMR MOD 50;
CASE NMR DIV 50 OF
3:
BEGIN
WRITE(ERRMESS15[I]); WRITE(TTY,ERRMESS15[I])
END;
4:
BEGIN
WRITE(ERRMESS20[I]); WRITE(TTY,ERRMESS20[I])
END;
5:
BEGIN
WRITE(ERRMESS25[I]); WRITE(TTY,ERRMESS25[I])
END;
6:
BEGIN
WRITE(ERRMESS30[I]); WRITE(TTY,ERRMESS30[I])
END;
7:
BEGIN
WRITE(ERRMESS35[I]); WRITE(TTY,ERRMESS35[I])
END;
8:
BEGIN
WRITE(ERRMESS40[I]); WRITE(TTY,ERRMESS40[I])
END;
9:
BEGIN
WRITE(ERRMESS45[I]); WRITE(TTY,ERRMESS45[I])
END;
10:
BEGIN
WRITE(ERRMESS50[I]); WRITE(TTY,ERRMESS50[I])
END;
11:
BEGIN
WRITE(ERRMESS55[I]); WRITE(TTY,ERRMESS55[I])
END
END;
(* 136 - LISTING FORMAT *)
newline; WRITELN(TTY)
END;
(* 26 - break not needed for TTY *)
ERRINX := 0; ERRORINLINE := FALSE;
FOR I := 1 TO CHCNT DO ERRLINE [I] := ' ';
ERRMPTR := NIL
END;
(* 56 -SEPARATE OUT STUFF NEEDED FOR FILE SWITCH *)
END;
PROCEDURE ENDOFLINE(OKEOF:BOOLEAN);
BEGIN
ENDSTUFF;
(* 16 - DETECT UNEXPECTED EOF *)
IF EOF(INPUT) AND NOT OKEOF
THEN BEGIN
(* 136 - LISTING FORMAT *)
WRITE('Unexpected end of file'); NEWLINE;
WRITELN(TTY,'? Unexpected end of file');
(* 176 - error for unexpected EOF in a comment *)
if comment_page <> 0 then (* we're in a comment *)
begin
write('Unterminated Comment at ',comment_page:0,
'/',comment_line:0); NEWLINE;
writeln(tty,'? Unterminated Comment at ',comment_page:0,
'/',comment_line:0)
end;
(* 41 - make restartable *)
(* 107 - abort creation of rel file on error *)
rewrite(outputrel);
(* 112 - clrbfi when error *)
clribf;
(* 125 - popf to be sure we get main file closed in reqfile *)
if reqfile
then begin
close(input);
popf(input)
end;
PASXIT(INPUT,OUTPUT,OUTPUTREL)
END;
READLN;
(* 147 - move incr linecnt here so first line of new page is 1 *)
LINECNT := LINECNT + 1;
IF NOT EOF(INPUT)
THEN GETNEXTLINE;
(* 136 - listing format *)
CHCNT := 0
END %ENDOFLINE\ ;
PROCEDURE ERROR(FERRNR: INTEGER);
VAR
LPOS,LARW : INTEGER;
BEGIN
IF NOT FOLLOWERROR
THEN
BEGIN
ERRORFLAG := TRUE ;
IF ERRINX >= MAXERR
THEN
BEGIN
ERRLIST[MAXERR].NMR := 410; ERRINX := MAXERR
END
ELSE
BEGIN
ERRINX := ERRINX + 1;
WITH ERRLIST[ERRINX] DO BEGIN NMR := FERRNR; TIC := '^' END
END;
FOLLOWERROR := TRUE; ERRORINLINE := TRUE;
IF (FERRNR # 215)
AND (FERRNR # 356)
AND (FERRNR # 405)
AND (FERRNR # 464)
THEN
IF EOLN(INPUT)
THEN ERRLINE [CHCNT] := '^'
ELSE ERRLINE [CHCNT-1] := '^'
ELSE ERRLIST[ERRINX].TIC := ' ';
IF ERRINX > 1
THEN
WITH ERRLIST [ ERRINX-1] DO
BEGIN
LPOS := POS; LARW := ARW
END;
WITH ERRLIST [ERRINX] DO
BEGIN
POS := CHCNT;
IF ERRINX = 1
THEN ARW := 1
ELSE
IF LPOS = CHCNT
THEN ARW := LARW
ELSE ARW := LARW + 1
END;
END;
END %ERROR\ ;
PROCEDURE ERRORWITHTEXT ( FERRNR: INTEGER; FTEXT: ALFA ) ;
BEGIN
ERROR(FERRNR); NEWZ(ERRMPTR1,C);
WITH ERRMPTR1^ DO
BEGIN
NUMBER := FERRNR; STRING := FTEXT;
NEXT := ERRMPTR
END;
ERRMPTR := ERRMPTR1
END %ERROR WITH TEXT\ ;
PROCEDURE INSYMBOL;
%READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS
DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LGTH\
(* 114 - prevent recursive comment scanning *)
LABEL 2;
CONST
(* 210 - allow 9 digit hex numbers *)
hexmax = 9;
DIGMAX = 12; MAX8 = 37777777777B;
TEST8 = 40000000000B;
MIN8 = 400000000000B;
(* 142 - better real number scanning *)
MAX10 = 3435973836; {maximum number, sans last digit}
MAX16 = 17777777777B;
MAXEXP = 35;
type
(* 43 - allow 12 digit octal no. *)
numconv=record case Boolean of
true:(oct:packed array[1:digmax]of 0..7);
false:(int:integer)
end;
(* 210 - allow 9 digit hex numbers *)
hexconv=record case Boolean of
true:(hex:packed array[1..hexmax] of 0..15);
false:(int:integer)
end;
VAR
(* 133 - make real numbers be read exactly *)
I,K,ASCALE,SCALE,EXP,IVAL: INTEGER;
RVAL,R,FAC: REAL; STRINGTOOLONG,SIGN: BOOLEAN;
DIGIT: ARRAY [1..DIGMAX] OF 0..9;
STRING: ARRAY [1..STRGLGTH] OF CHAR;
LVP: CSP;
(* 43 - allow 12 digit octal no. *)
nc:numconv;
(* 210 - allow 9 digit hex numbers *)
hc:hexconv;
PROCEDURE NEXTCH;
BEGIN
IF EOLN(INPUT)
THEN CH := ' '
ELSE
BEGIN
%READ(CH);\ CH := INPUT^; GET(INPUT); %THIS CHANGE SAVES 3 INSTRUCTIONS AT RUN-TIME\
CHCNT := CHCNT + 1;
IF CHCNT <= CHCNTMAX
THEN BUFFER[CHCNT] := CH
(* 3 - map lower case to upper. Need separate NEXTCH for strings now,
since we don't do mapping there. *)
END;
(* 105 - improve lower case mapping *)
ch := chr(charmap[ord(ch)]);
END;
PROCEDURE NEXTSTRCH;
BEGIN
IF EOLN(INPUT)
THEN CH := ' '
ELSE
BEGIN
CH := INPUT^; GET(INPUT);
CHCNT := CHCNT + 1;
IF CHCNT <= CHCNTMAX
THEN BUFFER[CHCNT] := CH
END
END;
PROCEDURE OPTIONS;
VAR
LCH : CHAR; LSWITCH : BOOLEAN;
BEGIN
REPEAT
NEXTCH; LCH := CH;
IF NOT (CH IN ['\','*'])
THEN NEXTCH;
IF NOT (CH IN ['+','-'])
(* 24 - S AND H FOR STACK AND HEAP *)
(* 33 - version *)
THEN IF (LCH IN ['H','S','V']) AND (CH = ':')
THEN BEGIN
NEXTCH;
INSYMBOL;
IF SY # INTCONST
THEN ERROR(203)
(* 24 - S AND H FOR STACK AND HEAP *)
ELSE BEGIN
(* 33 - version *)
IF LCH IN ['H','S']
THEN BEGIN
IF (VAL.IVAL MOD 1000B) = 0
THEN VAL.IVAL := VAL.IVAL -1;
VAL.IVAL := (VAL.IVAL DIV 1000B)*1000B + 777B;
END;
IF LCH = 'S'
THEN STACK := VAL.IVAL
(* 33 - version *)
ELSE IF LCH = 'H'
THEN HEAP := VAL.IVAL
ELSE VERSION.WORD := VAL.IVAL
END
END
ELSE ERROR(203)
ELSE
BEGIN
LSWITCH := CH = '+';
(* 157 - use CASE instead of IF nest *)
CASE LCH OF
'L': LISTCODE := LSWITCH;
'T': IF RESETFLAG THEN TTYINUSE := LSWITCH;
'M': IF RESETFLAG THEN MAIN := LSWITCH;
'C': BEGIN RUNTMCHECK := LSWITCH; ARITHCHECK := LSWITCH END;
'A': ARITHCHECK := LSWITCH;
'Z': ZERO := LSWITCH;
'D': BEGIN
DEBUGSWITCH := LSWITCH;
(* 36 - allow us to reset debug at beginning *)
if resetflag
then debug := lswitch
else IF LSWITCH
THEN DEBUG := TRUE
END
END
END;
IF EOLN(INPUT)
(* 16 - EOF *)
THEN ENDOFLINE(FALSE);
IF NOT ((CH IN ['\','*']) OR (LCH = 'H'))
THEN NEXTCH
UNTIL CH # ','
END %OPTIONS\ ;
(* 1 - reorganized a bit here, mainly to improve comment scanning *)
PROCEDURE NEWCH;
BEGIN
(* 16 - EOF *)
IF EOLN(INPUT) THEN ENDOFLINE(FALSE);
NEXTCH
END;
PROCEDURE SCANCOMMENT(STOPCH:CHAR);
BEGIN
(* 176 - error for unexpected EOF in a comment *)
comment_page := pagecnt; { pagecnt had better not be 0 }
comment_line := linecnt;
NEWCH;
IF CH='$' THEN OPTIONS;
(* 105 - curly brackets are now comments *)
if (stopch = '\') or (stopch = '}')
then while ch # stopch do newch
ELSE REPEAT WHILE CH#'*' DO NEWCH; NEXTCH UNTIL CH=STOPCH;
(* 176 - error for unexpected EOF in a comment *)
comment_page := 0;
(* 114 - prevent deep recursion in comment scanning *)
NEWCH;
END;
BEGIN 2:
%INSYMBOL\
WHILE (CH = ' ') OR (ORD(CH) = 11B) DO
BEGIN
IF EOLN(INPUT)
(* 16 - EOF *)
THEN ENDOFLINE(FALSE);
NEXTCH;
END;
(* 1 - code removed here for comments. Handled better elsewhere *)
CASE CH OF
'A','B','C','D','E','F','G','H','I',
'J','K','L','M','N','O','P','Q','R',
'S','T','U','V','W','X','Y','Z':
BEGIN
K := 0 ; ID := ' ';
REPEAT
IF K < ALFALENG
THEN
BEGIN
K := K + 1; ID[K] := CH
END ;
NEXTCH
UNTIL NOT (CH IN LETTERSDIGITSORLEFTARROW);
FOR I := FRW[K] TO FRW[K+1] - 1 DO
IF RW[I] = ID
THEN
BEGIN
SY := RSY[I]; OP := ROP[I]; GOTO 1
END;
SY := IDENT; OP := NOOP;
1:
END;
'0','1','2','3','4','5','6','7','8','9':
BEGIN
(* 141 - better way to check overflow *)
if overflow then; {clear old errors}
SY := INTCONST; OP := NOOP;
(* 64 - non-loc goto *)
id := ' ';
I := 0;
REPEAT
I := I + 1;
if i <= alfaleng
then id[i] := ch;
IF I <= DIGMAX
(* 142 - better real scanning *)
THEN DIGIT[I] := ORD(CH) - ORD('0');
NEXTCH
UNTIL NOT (CH IN DIGITS);
IVAL := 0;
IF CH = 'B'
THEN
BEGIN
(* 43 - allow 12 digit octal no. *)
(* 142 - better real number scanning *)
if i > digmax
then begin
error(174);
i := digmax
end;
nc.int:=0;
FOR K := 1 TO I DO
IF DIGIT[K] IN [8,9]
THEN ERROR(252)
else nc.oct[k+digmax-i]:=digit[k];
val.ival := nc.int;
NEXTCH
END
ELSE
BEGIN
(* 142 - better real number scanning *)
scale := 0;
FOR K := 1 TO I DO
if scale > 0
then scale := scale + 1
else if ival < max10
then ival := 10*ival + digit[k]
else if (ival = max10) and (digit[k] <= 7)
then ival := 10*ival + digit[k]
else scale := scale + 1;
IF CH = '.'
THEN
BEGIN
NEXTCH;
IF CH = '.'
THEN CH := ':'
ELSE
BEGIN
(* 142 - better real scanning *)
SY := REALCONST;
IF NOT (CH IN DIGITS)
THEN ERROR(205)
ELSE
REPEAT
if scale > 0
then scale := scale + 1
else if ival < max10
then ival := 10*ival + (ord(ch)-ord('0'))
else if (ival = max10) and (ch <= '7')
then ival := 10*ival + (ord(ch)-ord('0'))
else scale := scale + 1;
SCALE := SCALE - 1; NEXTCH
UNTIL NOT (CH IN DIGITS);
END
END;
IF CH = 'E'
THEN
BEGIN
(* 142 - better real scan *)
sy := realconst;
NEXTCH;
SIGN := CH='-';
IF (CH='+') OR (CH='-')
THEN NEXTCH;
EXP := 0;
IF NOT (CH IN DIGITS)
THEN ERROR(205)
ELSE
REPEAT
EXP := 10*EXP + (ORD(CH) - ORD('0'));
NEXTCH
UNTIL NOT (CH IN DIGITS);
IF SIGN
THEN SCALE := SCALE - EXP
ELSE SCALE := SCALE + EXP;
END;
(* 142 - better real scan *)
if sy = realconst
then begin
rval := ival;
IF SCALE # 0
THEN
BEGIN
(* 113 - reorganized to handle exact fractions exactly *)
FAC := 10.0;
ASCALE := ABS(SCALE);
(* 141 - prevent overflow for exp > 32 *)
LOOP
IF ODD(ASCALE)
THEN if scale > 0
then rval := rval*FAC
else rval := rval/fac;
ASCALE := ASCALE DIV 2;
EXIT IF ASCALE=0;
FAC := SQR(FAC);
END;
(* 141 - better overflow error handling *)
IF OVERFLOW
THEN BEGIN
ERROR(206);
RVAL := 0.0
END;
END;
(* 142 - better real scanning *)
newz(lvp,reel);
lvp^.rval := rval;
val.valp := lvp
end {real}
else {integer}
if scale = 0
then VAL.IVAL := IVAL
else begin
error(204);
val.ival := 0
end;
END
END;
'"':
BEGIN
SY := INTCONST; OP := NOOP; IVAL := 0; I := 0; hc.int := 0;
NEXTCH;
WHILE CH IN HEXADIGITS DO
BEGIN
i := i + 1;
if i <= hexmax then
IF CH IN DIGITS
THEN digit[i] := 16*IVAL + ORD(CH) - ORD('0')
ELSE digit[i] := 16*IVAL + ORD(CH) - 67B;
NEXTCH
END;
if i > hexmax then
begin
error(174);
i := hexmax
end;
for k := 1 to i do
hc.hex[k+hexmax-i] := digit[k];
VAL.IVAL := hc.int;
END;
'''':
BEGIN
LGTH := 0; SY := STRINGCONST; OP := NOOP;STRINGTOOLONG := FALSE;
REPEAT
REPEAT
(* 3 - different NEXTCH so don't map lower case, etc. *)
NEXTSTRCH;
IF LGTH < STRGLGTH
THEN
BEGIN
LGTH := LGTH + 1; STRING[LGTH] := CH
END
ELSE STRINGTOOLONG := TRUE
UNTIL (EOLN(INPUT)) OR (CH = '''');
IF STRINGTOOLONG
THEN ERROR(301);
IF EOLN(INPUT) AND (CH#'''')
THEN ERROR(351)
(* 3 - different NEXTCH so don't map lower case, etc. *)
(* 6 - don't use nextstrch for char after end of string[caused loop] *)
ELSE NEXTCH %this is embedded ' or char after string\
UNTIL CH # '''';
LGTH := LGTH - 1; %NOW LGTH = NR OF CHARS IN STRING\
IF LGTH = 1
THEN VAL.IVAL := ORD(STRING[1])
ELSE
BEGIN
NEWZ(LVP,STRG:LGTH);
WITH LVP^ DO
BEGIN
SLGTH := LGTH;
FOR I := 1 TO LGTH DO SVAL[I] := STRING[I]
END;
VAL.VALP := LVP
END
END;
':':
BEGIN
OP := NOOP; NEXTCH;
IF CH = '='
THEN
BEGIN
SY := BECOMES; NEXTCH
END
ELSE SY := COLON
END;
'.':
BEGIN
OP := NOOP; NEXTCH;
IF CH = '.'
THEN
BEGIN
SY := COLON; NEXTCH
END
ELSE SY := PERIOD
END;
'?','*','&','+','-','!','\',
(* 1 - / now handled elsewhere *)
'@','#','=',
')','[',']',',',';','^','_','$':
BEGIN
SY := SSY[CH]; OP := SOP[CH];
NEXTCH
END;
'(':
BEGIN
NEXTCH;
(* 1 - improved comment scanning *)
IF CH='*' THEN BEGIN SCANCOMMENT(')'); GOTO 2 END
ELSE BEGIN SY := LPARENT; OP := NOOP END
END;
'{':
BEGIN SCANCOMMENT('}'); GOTO 2 END;
'%':
BEGIN SCANCOMMENT('\'); GOTO 2 END;
'/':
BEGIN
NEXTCH;
IF CH='*' THEN BEGIN SCANCOMMENT('/'); GOTO 2 END
ELSE BEGIN SY := MULOP; OP := RDIV END
END;
'<','>':
BEGIN
SY := SSY[CH]; OP := SOP[CH]; NEXTCH;
IF CH = '='
THEN
BEGIN
IF OP = LTOP
THEN OP := LEOP
ELSE OP := GEOP;
NEXTCH
END
(* 6 - allow <> for not equals *)
ELSE IF (CH = '>') AND (OP = LTOP)
THEN
BEGIN
OP := NEOP;
NEXTCH
END
END;
(* 6 - add error msg in case of illegal character *)
OTHERS:
BEGIN
ERROR(216);
NEWCH;
INSYMBOL
END
END %CASE\
END %INSYMBOL\ ;
PROCEDURE ENTERID(FCP: CTP);
%ENTER ID POINTED AT BY FCP INTO THE NAME-TABLE,
WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS
AN UNBALANCED BINARY TREE\
VAR
NAM: ALFA; LCP, LCP1: CTP; LLEFT: BOOLEAN;
BEGIN
NAM := FCP^.NAME;
(* 5 - CREF *)
IF CREF
THEN WRITE(CHR(1B),CHR(21),NAM,' ',DISPLAY[TOP].BLKNAME,CHR(2B));
LCP := DISPLAY[TOP].FNAME;
IF LCP = NIL
THEN
DISPLAY[TOP].FNAME := FCP
ELSE
BEGIN
REPEAT
LCP1 := LCP;
IF LCP^.NAME <= NAM
THEN
BEGIN
IF LCP^.NAME = NAM
THEN ERROR(302) %NAME CONFLICT\;
LCP := LCP^.RLINK; LLEFT := FALSE
END
ELSE
BEGIN
LCP := LCP^.LLINK; LLEFT := TRUE
END
UNTIL LCP = NIL;
IF LLEFT
THEN LCP1^.LLINK := FCP
ELSE LCP1^.RLINK := FCP
END;
WITH FCP^ DO
BEGIN
LLINK := NIL; RLINK := NIL; SELFCTP := NIL
END
END %ENTERID\ ;
PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP);
%TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S
--> PROCEDURE PROCEDUREDECLARATION
--> PROCEDURE SELECTOR\
BEGIN
WHILE FCP # NIL DO
WITH FCP^ DO
BEGIN
IF NAME = ID
THEN GOTO 1;
IF NAME < ID
THEN FCP := RLINK
ELSE FCP := LLINK
END;
1:
FCP1 := FCP
END %SEARCHSECTION\ ;
PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP);
VAR
LCP: CTP;
BEGIN
FOR DISX := TOP DOWNTO 0 DO
BEGIN
LCP := DISPLAY[DISX].FNAME;
WHILE LCP # NIL DO
WITH LCP^ DO
IF NAME = ID
THEN
IF KLASS IN FIDCLS
THEN GOTO 1
ELSE
BEGIN
IF PRTERR
THEN ERROR(401);
(* 170 - fix error handling for forwards *)
GOTO 2
END
ELSE
IF NAME < ID
THEN
LCP := RLINK
ELSE LCP := LLINK
END;
2: LCP := NIL; {Use NIL if don't find something better below}
(* 5 - save some info for so CREF will know the block name *)
DISX := TOP; %IF FORWARD, WILL BE IN THIS BLOCK\
(* 114 - use only real block names *)
(* 116 - more elegant way to do this *)
WHILE DISPLAY[DISX].OCCUR <> BLCK DO
DISX := DISX - 1;
%SEARCH NOT SUCCSESSFUL; SUPPRESS ERROR MESSAGE IN CASE
OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION
--> PROCEDURE SIMPLETYPE\
IF PRTERR
THEN
BEGIN
ERROR(253);
%TO AVOID RETURNING NIL, REFERENCE AN ENTRY
FOR AN UNDECLARED ID OF APPROPRIATE CLASS
--> PROCEDURE ENTERUNDECL\
IF TYPES IN FIDCLS
THEN LCP := UTYPPTR
ELSE
IF VARS IN FIDCLS
THEN LCP := UVARPTR
ELSE
IF FIELD IN FIDCLS
THEN LCP := UFLDPTR
ELSE
IF KONST IN FIDCLS
THEN LCP := UCSTPTR
ELSE
IF PROC IN FIDCLS
THEN LCP := UPRCPTR
(* 64 - non-loc gotos *)
ELSE IF FUNC IN FIDCLS
THEN LCP := UFCTPTR
ELSE LCP := ULBLPTR;
END;
1:
(* 5 - CREF *)
IF CREF
THEN WRITE(CHR(1B),CHR(21),ID,' ',DISPLAY[DISX].BLKNAME);
FCP := LCP
END %SEARCHID\ ;
PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER);
%GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE\
%ASSUME (FSP # NIL) AND (FSP^.FORM <= SUBRANGE) AND (FSP # INTPTR)
AND NOT COMPTYPES(REALPTR,FSP)\
BEGIN
WITH FSP^ DO
IF FORM = SUBRANGE
THEN
BEGIN
FMIN := MIN.IVAL; FMAX := MAX.IVAL
END
ELSE
BEGIN
FMIN := 0;
IF FSP = CHARPTR
THEN FMAX := 177B
ELSE
IF FCONST # NIL
THEN
FMAX := FCONST^.VALUES.IVAL
ELSE FMAX := 0
END
END %GETBOUNDS\ ;
(* 6 - move error stuff outside BLOCK so PROGSTAT can use it *)
PROCEDURE SKIPIFERR(FSYINSYS:SETOFSYS; FERRNR:INTEGER; FSKIPSYS: SETOFSYS);
VAR
I,OLDCHCNT,OLDLINECNT : INTEGER;
BEGIN
IF NOT (SY IN FSYINSYS)
THEN
BEGIN
ERROR(FERRNR);
OLDLINECNT := LINECNT; OLDCHCNT := CHCNT;
WHILE NOT (SY IN FSKIPSYS OR FSYINSYS) DO
BEGIN
IF OLDLINECNT # LINECNT
THEN OLDCHCNT := 1;
FOR I := OLDCHCNT TO CHCNT-1 DO
IF I <= CHCNTMAX
THEN ERRLINE [I] := '*';
OLDCHCNT := CHCNT; OLDLINECNT := LINECNT; ERRORINLINE := TRUE;
INSYMBOL
END;
%SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND\
END;
FOLLOWERROR := FALSE
END;
PROCEDURE IFERRSKIP(FERRNR: INTEGER; FSYS: SETOFSYS);
BEGIN
SKIPIFERR(FSYS,FERRNR,FSYS)
END;
PROCEDURE ERRANDSKIP(FERRNR: INTEGER; FSYS: SETOFSYS);
BEGIN
SKIPIFERR([ ],FERRNR,FSYS)
END;
(* 6 - add PROGRAM statement *)
PROCEDURE PROGSTAT;
(* 34 - allow list of entry point names *)
VAR STSYM,ENDSYM:SYMBOL;
BEGIN
IF SY=PROGRAMSY
THEN
BEGIN
(* 34 - allow entry point names *)
IF MAIN
THEN BEGIN STSYM:=LPARENT; ENDSYM := RPARENT END
ELSE BEGIN STSYM:=COMMA; ENDSYM := SEMICOLON END;
INSYMBOL;
IF SY # IDENT THEN ERROR(209);
(* 33 NO LONGER NEED ENTRY *)
FILENAME := ID;
INSYMBOL;
(* 34 - DIFFERENT SYNTAX FOR ENTRY POINTS *)
IF SY = STSYM
THEN BEGIN
REPEAT
INSYMBOL;
IF NOT (SY = IDENT)
THEN ERROR(209);
(* 33 - USE FILE NAMES *)
NEWZ(NPROGFILE);
NPROGFILE^.FILID := ID;
NPROGFILE^.NEXT := NIL;
IF FPROGFILE = NIL
THEN BEGIN
FPROGFILE := NPROGFILE;
LPROGFILE := NPROGFILE
END
ELSE BEGIN
LPROGFILE^.NEXT := NPROGFILE;
LPROGFILE := NPROGFILE
END;
INSYMBOL;
(* 61 - allow +* in tops20 *)
(* 144 - allow this stuff in tops10, too *)
if (sy=colon) and main
then begin
insymbol;
while sy in [addop,mulop,relop] do
begin
if (op = mul) and (not tops10)
then nprogfile^.wild := true
else if op = plus
then nprogfile^.newgen := true
else if op = minus
then nprogfile^.oldfile := true
(* 64 - input:/ *)
else if op = rdiv
then nprogfile^.interact := true
(* 172 - new EOLN treatment *)
else if op = neop
then nprogfile^.seeeol := true
else error(158);
insymbol
end;
end;
(* 34 - DIFFERENT SYNTAX FOR ENTRY POINTS *)
IFERRSKIP(158,[ENDSYM,COMMA])
UNTIL SY=ENDSYM;
IF MAIN THEN INSYMBOL
END;
(* 21 - Allow null file list in prog. statement *)
IFERRSKIP(156,[SEMICOLON]);
INSYMBOL
END
END;
PROCEDURE BLOCK(FPROCP: CTP; FSYS,LEAVEBLOCKSYS: SETOFSYS);
VAR
(* 56 - add reqfile for require files *)
(* 125 - reqfile moved *)
(* 65 - remove exit labels *)
LSY: SYMBOL;
(* 136 - listing format *)
ORIGLINENR:PACKED ARRAY[1:5]OF CHAR;
ORIGPAGECNT,ORIGSUBPAGE,ORIGLINECNT:INTEGER;
ORIGPAGE:PAGEELEM; ORIGCH:CHAR;
(* 24 - testpacked no longer needed *)
LCPAR: ADDRRANGE;%SAVES LOCATION FROM WHERE
LOCAL AREAS ARE SET TO ZERO\
HEAPMARK,GLOBMARK: INTEGER;
FORWPTR : CTP; %TEST FOR FORWORD DECLARED PROCEDURES\
PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU);
VAR
LSP,LSP1: STP; LCP: CTP; SIGN: (NONE,POS,NEG);
BEGIN
LSP := NIL; FVALU.IVAL := 0;
SKIPIFERR(CONSTBEGSYS,207,FSYS);
IF SY IN CONSTBEGSYS
THEN
BEGIN
IF SY = STRINGCONST
THEN
BEGIN
IF LGTH = 1
THEN LSP := CHARPTR
ELSE
IF LGTH = ALFALENG
THEN LSP := ALFAPTR
ELSE
BEGIN
NEWZ(LSP,ARRAYS); NEWZ(LSP1,SUBRANGE);
WITH LSP^ DO
BEGIN
AELTYPE := CHARPTR; INXTYPE := LSP1;
SIZE := (LGTH+4) DIV 5; ARRAYPF := TRUE;
(* 211 - make PASDDT able to see this *)
BITSIZE := BITMAX; SELFSTP := NIL
END;
WITH LSP1^ DO
BEGIN
SIZE := 1; BITSIZE := BITMAX;
MIN.IVAL := 1; MAX.IVAL := LGTH; RANGETYPE := NIL
END
END;
FVALU := VAL; INSYMBOL
END
ELSE
BEGIN
SIGN := NONE;
IF (SY = ADDOP) AND (OP IN [PLUS,MINUS])
THEN
BEGIN
IF OP = PLUS
THEN SIGN := POS
ELSE SIGN := NEG;
INSYMBOL
END;
IF SY = IDENT
THEN
BEGIN
SEARCHID([KONST],LCP);
WITH LCP^ DO
BEGIN
LSP := IDTYPE; FVALU := VALUES
END;
IF SIGN # NONE
THEN
IF LSP = INTPTR
THEN
BEGIN
IF SIGN = NEG
THEN FVALU.IVAL := -FVALU.IVAL
END
ELSE
IF LSP = REALPTR
THEN
BEGIN
IF SIGN = NEG
THEN
FVALU.VALP^.RVAL := -FVALU.VALP^.RVAL
END
ELSE ERROR(167);
INSYMBOL;
END
ELSE
IF SY = INTCONST
THEN
BEGIN
IF SIGN = NEG
THEN VAL.IVAL := -VAL.IVAL;
LSP := INTPTR; FVALU := VAL; INSYMBOL
END
ELSE
IF SY = REALCONST
THEN
BEGIN
IF SIGN = NEG
THEN VAL.VALP^.RVAL := -VAL.VALP^.RVAL;
LSP := REALPTR; FVALU := VAL; INSYMBOL
END
ELSE ERRANDSKIP(168,FSYS)
END;
IFERRSKIP(166,FSYS);
END;
FSP := LSP
END %CONSTANT\ ;
FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN;
%DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE\
VAR
NXT1,NXT2: CTP; COMP: BOOLEAN; LMIN,LMAX,I: INTEGER;
LTESTP1,LTESTP2: TESTP;
BEGIN
IF FSP1 = FSP2
THEN COMPTYPES := TRUE
ELSE
IF (FSP1 # NIL) AND (FSP2 # NIL)
THEN
IF FSP1^.FORM = FSP2^.FORM
THEN
CASE FSP1^.FORM OF
SCALAR:
COMPTYPES := FALSE;
% IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
NOT RECOGNIZED TO BE COMPATIBLE\
SUBRANGE:
COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2^.RANGETYPE);
POINTER:
BEGIN
COMP := FALSE; LTESTP1 := GLOBTESTP; LTESTP2 := GLOBTESTP;
WHILE LTESTP1 # NIL DO
WITH LTESTP1^ DO
BEGIN
IF (ELT1 = FSP1^.ELTYPE) AND (ELT2 = FSP2^.ELTYPE)
THEN COMP := TRUE;
LTESTP1 := LASTTESTP
END;
IF NOT COMP
THEN
BEGIN
NEWZ(LTESTP1);
WITH LTESTP1^ DO
BEGIN
ELT1 := FSP1^.ELTYPE;
ELT2 := FSP2^.ELTYPE;
LASTTESTP := GLOBTESTP
END;
GLOBTESTP := LTESTP1; COMP := COMPTYPES(FSP1^.ELTYPE,FSP2^.ELTYPE)
END;
COMPTYPES := COMP; GLOBTESTP := LTESTP2
END;
POWER:
COMPTYPES := COMPTYPES(FSP1^.ELSET,FSP2^.ELSET);
ARRAYS:
BEGIN
GETBOUNDS (FSP1^.INXTYPE,LMIN,LMAX);
I := LMAX-LMIN;
GETBOUNDS (FSP2^.INXTYPE,LMIN,LMAX);
COMPTYPES := COMPTYPES(FSP1^.AELTYPE,FSP2^.AELTYPE)
AND (FSP1^.ARRAYPF = FSP2^.ARRAYPF) AND ( I = LMAX - LMIN ) ;
END;
%ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST
BE COMPATIBLE. MAY GIVE TROUBLE FOR ASSIGNMENT OF STRINGCONSTANTS
-- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST
BE THE SAME\
RECORDS:
BEGIN
NXT1 := FSP1^.FSTFLD; NXT2 := FSP2^.FSTFLD; COMP := TRUE;
WHILE (NXT1 # NIL) AND (NXT2 # NIL) DO
BEGIN
COMP := COMPTYPES(NXT1^.IDTYPE,NXT2^.IDTYPE) AND COMP;
NXT1 := NXT1^.NEXT; NXT2 := NXT2^.NEXT
END;
COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL)
AND (FSP1^.RECVAR = NIL) AND (FSP2^.RECVAR = NIL)
END;
%IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
IFF NO VARIANTS OCCUR\
FILES:
COMPTYPES := COMPTYPES(FSP1^.FILTYPE,FSP2^.FILTYPE)
END %CASE\
ELSE %FSP1^.FORM # FSP2^.FORM\
IF FSP1^.FORM = SUBRANGE
THEN
COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2)
ELSE
IF FSP2^.FORM = SUBRANGE
THEN
COMPTYPES := COMPTYPES(FSP1,FSP2^.RANGETYPE)
ELSE COMPTYPES := FALSE
ELSE COMPTYPES := TRUE
END %COMPTYPES\ ;
FUNCTION STRING(FSP: STP) : BOOLEAN;
BEGIN
STRING := FALSE;
IF FSP # NIL
THEN
IF FSP^.FORM = ARRAYS
THEN
IF COMPTYPES(FSP^.AELTYPE,CHARPTR)
THEN STRING := TRUE
END %STRING\ ;
PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE;
VAR FBITSIZE: BITRANGE);
VAR
(* 173 - internal files *)
FHASFILE,LHASFILE:BOOLEAN;
LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP;
LSIZE,DISPL: ADDRRANGE; I,LMIN,LMAX: INTEGER;
PACKFLAG: BOOLEAN; LBITSIZE: BITRANGE;
LBTP: BTP; BITCOUNT:INTEGER;
(* 104 - check structure sizes *)
function checksize(i:addrrange):addrrange;
begin
if abs(i) <= 377777B
then checksize := i
else begin
error(266);
checksize := 0
end
end;
FUNCTION LOG2(FVAL: INTEGER): BITRANGE;
VAR
E: BITRANGE; H: INTEGER;
BEGIN
E :=0;
H := 1;
(* 135 - numbers > 200 000 000 000B didn't work. *)
{There are two complicating issues here:
1 - 200 000 000 000 is the highest power of 2, so the
loop below goes forever for them
2 - the caller has often added 1, thus making 377 777 777 777
into 400 000 000 000, which is negative!!
In both of these cases we want to return 35}
IF (FVAL-1) >= 200000000000B
THEN E := 35
ELSE REPEAT
E := E + 1; H := H * 2
UNTIL FVAL <= H;
LOG2 := E
END %LOG2\;
PROCEDURE SIMPLETYPE(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE;
VAR FBITSIZE: BITRANGE);
VAR
LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE;
LCNT: INTEGER; LVALU: VALU; LBITSIZE: BITRANGE;
BEGIN
FSIZE := 1;
SKIPIFERR(SIMPTYPEBEGSYS,208,FSYS);
IF SY IN SIMPTYPEBEGSYS
THEN
BEGIN
IF SY = LPARENT
THEN
BEGIN
TTOP := TOP; %DECL. CONSTS LOCAL TO INNERMOST BLOCK\
WHILE DISPLAY[TOP].OCCUR # BLCK DO TOP := TOP - 1;
NEWZ(LSP,SCALAR,DECLARED);
LSP^.SIZE := 1;
LCP1 := NIL; LCNT := 0;
REPEAT
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
NEWZ(LCP,KONST);
WITH LCP^ DO
BEGIN
NAME := ID; IDTYPE := LSP; NEXT := LCP1;
VALUES.IVAL := LCNT;
END;
ENTERID(LCP);
LCNT := LCNT + 1;
LCP1 := LCP; INSYMBOL
END
ELSE ERROR(209);
IFERRSKIP(166,FSYS OR [COMMA,RPARENT])
UNTIL SY # COMMA;
TOP := TTOP;
WITH LSP^ DO
BEGIN
SELFSTP := NIL; FCONST := LCP1; BITSIZE := LOG2(LCNT)
END;
IF SY = RPARENT
THEN INSYMBOL
ELSE ERROR(152)
END
ELSE
BEGIN
IF SY = IDENT
THEN
BEGIN
SEARCHID([TYPES,KONST],LCP);
INSYMBOL;
IF LCP^.KLASS = KONST
THEN
BEGIN
NEWZ(LSP,SUBRANGE);
WITH LSP^, LCP^ DO
BEGIN
SELFSTP := NIL; RANGETYPE := IDTYPE;
IF STRING(RANGETYPE)
THEN
BEGIN
ERROR(303); RANGETYPE := NIL
END;
MIN := VALUES; SIZE := 1
END;
IF SY = COLON
THEN INSYMBOL
ELSE ERROR(151);
CONSTANT(FSYS,LSP1,LVALU);
WITH LSP^ DO
BEGIN
MAX := LVALU;
IF MIN.IVAL<0
THEN BITSIZE := BITMAX
ELSE BITSIZE := LOG2(MAX.IVAL + 1);
IF RANGETYPE # LSP1
THEN ERROR(304)
END;
END
ELSE
BEGIN
LSP := LCP^.IDTYPE;
IF LSP # NIL
THEN FSIZE := LSP^.SIZE;
END
END %SY = IDENT\
ELSE
BEGIN
NEWZ(LSP,SUBRANGE);
CONSTANT(FSYS OR [COLON],LSP1,LVALU);
IF STRING(LSP1)
THEN
BEGIN
ERROR(303); LSP1 := NIL
END;
WITH LSP^ DO
BEGIN
RANGETYPE := LSP1; MIN := LVALU; SIZE := 1
END;
IF SY = COLON
THEN INSYMBOL
ELSE ERROR(151);
CONSTANT(FSYS,LSP1,LVALU);
WITH LSP^ DO
BEGIN
SELFSTP := NIL; MAX := LVALU;
IF MIN.IVAL<0
THEN BITSIZE := BITMAX
ELSE BITSIZE := LOG2(MAX.IVAL + 1);
IF RANGETYPE # LSP1
THEN ERROR(304)
END
END;
IF LSP # NIL
THEN
WITH LSP^ DO
IF FORM = SUBRANGE
THEN
IF RANGETYPE # NIL
THEN
IF RANGETYPE = REALPTR
THEN
(* 106 - make subranges of real illegal *)
error(210)
ELSE
IF MIN.IVAL > MAX.IVAL
THEN ERROR(451)
END;
FSP := LSP;
IF LSP#NIL
THEN FBITSIZE := LSP^.BITSIZE
ELSE FBITSIZE := 0;
IFERRSKIP(166,FSYS)
END
ELSE
BEGIN
FSP := NIL; FBITSIZE := 0
END
END %SIMPLETYPE\ ;
(* 173 - internal files *)
PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP; VAR FFIRSTFIELD: CTP; VAR FHASFILE:BOOLEAN);
VAR
LHASFILE:BOOLEAN;
LCP,LCP1,NXT,NXT1: CTP; LSP,LSP1,LSP2,LSP3,LSP4,TAGSP: STP;
MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU;
LBITSIZE: BITRANGE;
LBTP: BTP; MINBITCOUNT:INTEGER;
LID : ALFA ;
PROCEDURE RECSECTION( VAR FCP: CTP; FSP: STP );
BEGIN
IF NOT PACKFLAG OR (LSIZE > 1) OR (LBITSIZE = 36)
THEN
BEGIN
IF BITCOUNT > 0
THEN
BEGIN
DISPL := DISPL + 1; BITCOUNT := 0
END;
WITH FCP^ DO
BEGIN
IDTYPE := FSP; FLDADDR := DISPL;
PACKF := NOTPACK; FCP := NEXT;
DISPL := DISPL + LSIZE
END
END
ELSE %PACK RECORD-SECTION\
BEGIN
BITCOUNT := BITCOUNT + LBITSIZE;
IF BITCOUNT>BITMAX
THEN
BEGIN
DISPL := DISPL + 1;
BITCOUNT := LBITSIZE
END;
IF (LBITSIZE = 18) AND (BITCOUNT IN [18,36])
THEN
BEGIN
WITH FCP^ DO
BEGIN
IDTYPE := FSP;
FLDADDR := DISPL;
IF BITCOUNT = 18
THEN PACKF := HWORDL
ELSE PACKF := HWORDR;
FCP := NEXT
END
END
ELSE
BEGIN
NEWZ(LBTP,RECORDD);
WITH LBTP^.BYTE DO
BEGIN
SBITS := LBITSIZE;
PBITS := BITMAX - BITCOUNT;
RELADDR := DISPL;
DUMMYBIT := 0;
IBIT := 0;
IREG := TAC
END;
WITH LBTP^ DO
BEGIN
LAST := LASTBTP; FIELDCP := FCP
END;
LASTBTP := LBTP;
WITH FCP^ DO
BEGIN
IDTYPE := FSP;
PACKF := PACKK;
FCP := NEXT
END
END
END
END % RECSECTION \ ;
BEGIN
(* 173 - internal files *)
(* 166 - In case of null record declaration, FRECVAR was getting junk.
I don't understand the logic of this routine, but initializing
it to NIL seems safe enough *)
NXT1 := NIL; LSP := NIL; FRECVAR := NIL; FHASFILE := FALSE;
(* 21 - Allow null fieldlist (added FSYS OR to next statement) *)
(* 65 - allow extra semicolons *)
while sy=semicolon do
insymbol;
SKIPIFERR(FSYS OR [IDENT,CASESY],452,FSYS);
WHILE SY = IDENT DO
BEGIN
NXT := NXT1;
LOOP
IF SY = IDENT
THEN
BEGIN
NEWZ(LCP,FIELD);
WITH LCP^ DO
BEGIN
NAME := ID; IDTYPE := NIL; NEXT := NXT
END;
NXT := LCP;
ENTERID(LCP);
INSYMBOL
END
ELSE ERROR(209);
SKIPIFERR([COMMA,COLON],166,FSYS OR [SEMICOLON,CASESY]);
EXIT IF SY # COMMA;
INSYMBOL
END;
IF SY = COLON
THEN INSYMBOL
ELSE ERROR(151);
TYP(FSYS OR [CASESY,SEMICOLON],LSP,LSIZE,LBITSIZE);
IF LSP # NIL
THEN
(* internal files *)
IF (LSP^.FORM = FILES) OR LSP^.HASFILE
THEN FHASFILE := TRUE;
WHILE NXT # NXT1 DO RECSECTION(NXT,LSP); %RESERVES SPACE FOR ONE RECORDSECTION \
NXT1 := LCP;
(* 64 - allow null entry *)
WHILE SY = SEMICOLON DO
BEGIN
INSYMBOL;
SKIPIFERR(FSYS OR [IDENT,CASESY,SEMICOLON],452,FSYS)
END
END %WHILE\;
NXT := NIL;
WHILE NXT1 # NIL DO
WITH NXT1^ DO
BEGIN
LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP
END;
FFIRSTFIELD := NXT;
IF SY = CASESY
THEN
BEGIN
LCP:=NIL; %POSSIBILITY OF NO TAGFIELDIDENTIFIER\
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
LID := ID ;
INSYMBOL ;
IF (SY#COLON) AND (SY#OFSY)
THEN
BEGIN
ERROR(151) ;
ERRANDSKIP(160,FSYS OR [LPARENT])
END
ELSE
BEGIN
IF SY = COLON
THEN
BEGIN
NEWZ(LSP,TAGFWITHID);
NEWZ(LCP,FIELD) ;
WITH LCP^ DO
BEGIN
NAME := LID ; IDTYPE := NIL ; NEXT := NIL
END ;
ENTERID(LCP) ;
INSYMBOL ;
IF SY # IDENT
THEN
BEGIN
ERRANDSKIP(209,FSYS OR [LPARENT]) ; GOTO 1
END
ELSE
BEGIN
LID := ID ;
INSYMBOL ;
IF SY # OFSY
THEN
BEGIN
ERRANDSKIP(160,FSYS OR [LPARENT]) ; GOTO 1
END
END
END
ELSE NEWZ(LSP,TAGFWITHOUTID) ;
WITH LSP^ DO
BEGIN
SIZE:= 0 ; SELFSTP := NIL ;
FSTVAR := NIL;
IF FORM=TAGFWITHID
THEN TAGFIELDP:=NIL
ELSE TAGFIELDTYPE := NIL
END;
FRECVAR := LSP;
ID := LID ;
SEARCHID([TYPES],LCP1) ;
TAGSP := LCP1^.IDTYPE;
IF TAGSP # NIL
THEN
IF (TAGSP^.FORM <= SUBRANGE) OR STRING(TAGSP)
THEN
BEGIN
IF COMPTYPES(REALPTR,TAGSP)
THEN ERROR(210)
ELSE
IF STRING(TAGSP)
THEN ERROR(169);
WITH LSP^ DO
BEGIN
BITSIZE := TAGSP^.BITSIZE;
IF FORM = TAGFWITHID
THEN TAGFIELDP := LCP
ELSE TAGFIELDTYPE := TAGSP;
END;
IF LCP # NIL
THEN
BEGIN
LBITSIZE :=TAGSP^.BITSIZE;
LSIZE := TAGSP^.SIZE;
RECSECTION(LCP,TAGSP); %RESERVES SPACE FOR THE TAGFIELD \
IF BITCOUNT > 0
(* 104 - check structure sizes *)
THEN LSP^.SIZE:=CHECKSIZE(DISPL + 1)
ELSE LSP^.SIZE:= CHECKSIZE(DISPL);
END
END
ELSE ERROR(402);
INSYMBOL;
END
END
(* 150 - fix ill mem ref trying to follow tagsp if not set *)
ELSE BEGIN TAGSP := NIL; ERRANDSKIP(209,FSYS OR [LPARENT]) END ;
1:
LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL; MINBITCOUNT:=BITCOUNT;
(* 65 - allow extra semicolons *)
while sy=semicolon do
insymbol;
LOOP
LSP2 := NIL;
LOOP
CONSTANT(FSYS OR [COMMA,COLON,LPARENT],LSP3,LVALU);
IF NOT COMPTYPES(TAGSP,LSP3)
THEN ERROR(305);
NEWZ(LSP3,VARIANT);
WITH LSP3^ DO
BEGIN
NXTVAR := LSP1; SUBVAR := LSP2; VARVAL := LVALU;
BITSIZE := LSP^.BITSIZE; SELFSTP := NIL
END;
LSP1 := LSP3; LSP2 := LSP3;
EXIT IF SY # COMMA;
INSYMBOL;
END;
IF SY = COLON
THEN INSYMBOL
ELSE ERROR(151);
IF SY = LPARENT
THEN INSYMBOL
ELSE ERROR(153);
(* 173 - internal files *)
FIELDLIST(FSYS OR [RPARENT,SEMICOLON],LSP2,LCP,LHASFILE);
FHASFILE := FHASFILE OR LHASFILE;
IF DISPL > MAXSIZE
THEN MAXSIZE := DISPL;
WHILE LSP3 # NIL DO
BEGIN
LSP4 := LSP3^.SUBVAR; LSP3^.SUBVAR := LSP2; LSP3^.FIRSTFIELD := LCP;
(* 20 - deleted if bitcount>0 use displ+1 - done in fieldlist *)
(* 104 - check structure sizes *)
LSP3^.SIZE := CHECKSIZE(DISPL) ;
LSP3 := LSP4
END;
IF SY = RPARENT
THEN
BEGIN
INSYMBOL;
IFERRSKIP(166,FSYS OR [SEMICOLON])
END
ELSE ERROR(152);
(* 65 - allow extra semicolons *)
while sy=semicolon
do insymbol;
exit if sy in fsys;
DISPL := MINSIZE;
BITCOUNT:=MINBITCOUNT; %RESTAURATION \
END;
DISPL := MAXSIZE;
LSP^.FSTVAR := LSP1;
END %IF SY = CASESY\
ELSE
IF LSP # NIL
THEN
IF LSP^.FORM = ARRAYS
THEN FRECVAR := LSP
ELSE FRECVAR := NIL;
(* 20 - fix packed records - from CMU *)
IF BITCOUNT > 0 THEN
BEGIN DISPL:=DISPL+1; BITCOUNT := 0 END
END %FIELDLIST\ ;
BEGIN
%TYP\
(* 173 - internal files *)
FHASFILE := FALSE;
SKIPIFERR(TYPEBEGSYS,170,FSYS);
PACKFLAG := FALSE;
IF SY IN TYPEBEGSYS
THEN
BEGIN
IF SY IN SIMPTYPEBEGSYS
THEN SIMPLETYPE(FSYS,FSP,FSIZE,FBITSIZE)
ELSE
%^\
IF SY = ARROW
THEN
BEGIN
NEWZ(LSP,POINTER); FSP := LSP;
LBITSIZE := 18;
WITH LSP^ DO
BEGIN
SELFSTP := NIL; ELTYPE := NIL; SIZE := 1; BITSIZE := LBITSIZE
END;
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
(* 165 - fix scoping problem with pointer ref's *)
{All declarations of the form ^THING must be treated as forward references.
The problem is that we want to use the local declaration of THING if there
is any. So we have to wait til we have seen all type declarations before
we can look up pointer references.}
NEWZ(LCP,TYPES);
WITH LCP^ DO
BEGIN
NAME := ID; IDTYPE := LSP;
NEXT := FWPTR
END;
FWPTR := LCP;
INSYMBOL;
FBITSIZE:=18
END
ELSE ERROR(209);
END
ELSE
BEGIN
IF SY = PACKEDSY
THEN
BEGIN
INSYMBOL;
SKIPIFERR(TYPEDELS,170,FSYS);
PACKFLAG := TRUE
END;
%ARRAY\
IF SY = ARRAYSY
THEN
BEGIN
INSYMBOL;
IF SY = LBRACK
THEN INSYMBOL
ELSE ERROR(154);
LSP1 := NIL;
LOOP
NEWZ(LSP,ARRAYS);
WITH LSP^ DO
BEGIN
AELTYPE := LSP1; INXTYPE := NIL; SELFSTP := NIL;
ARRAYPF := PACKFLAG; SIZE := 1
END;
LSP1 := LSP;
SIMPLETYPE(FSYS OR [COMMA,RBRACK,OFSY],LSP2,LSIZE,LBITSIZE);
IF LSP2 # NIL
THEN
IF LSP2^.FORM <= SUBRANGE
THEN
BEGIN
IF LSP2 = REALPTR
THEN
BEGIN
ERROR(210); LSP2 := NIL
END
ELSE
IF LSP2 = INTPTR
THEN
BEGIN
ERROR(306); LSP2 := NIL
END;
LSP^.INXTYPE := LSP2
END
ELSE
BEGIN
ERROR(403); LSP2 := NIL
END;
EXIT IF SY # COMMA;
INSYMBOL
END;
IF SY = RBRACK
THEN INSYMBOL
ELSE ERROR(155);
IF SY = OFSY
THEN INSYMBOL
ELSE ERROR(160);
TYP(FSYS,LSP,LSIZE,LBITSIZE);
IF LSP # NIL
THEN
(* 173 - internal files *)
IF (LSP^.FORM = FILES) OR (LSP^.HASFILE)
THEN FHASFILE := TRUE;
REPEAT
WITH LSP1^ DO
BEGIN
LSP2 := AELTYPE; AELTYPE := LSP;
IF INXTYPE # NIL
THEN
BEGIN
GETBOUNDS(INXTYPE,LMIN,LMAX);
(* 104 - check structure sizes *)
lmin := checksize(lmin);
lmax := checksize(lmax);
I := LMAX - LMIN + 1;
IF ARRAYPF AND (LBITSIZE<=18)
THEN
BEGIN
NEWZ(LBTP,ARRAYY);
WITH LBTP^,BYTE DO
BEGIN
SBITS := LBITSIZE;
PBITS := BITMAX; DUMMYBIT := 0;
IBIT := 0; IREG := TAC; RELADDR := 0;
LAST := LASTBTP; LASTBTP := LBTP;
ARRAYSP := LSP1;
END;
LSIZE := (I+(BITMAX DIV LBITSIZE)-1) DIV (BITMAX DIV LBITSIZE);
END
ELSE
BEGIN
LSIZE := LSIZE * I;
ARRAYPF := FALSE
END;
LBITSIZE := BITMAX;
BITSIZE := LBITSIZE;
(* 104 - check structure sizes *)
SIZE := CHECKSIZE(LSIZE);
END
END;
LSP := LSP1; LSP1 := LSP2
UNTIL LSP1 = NIL
END
ELSE
%RECORD\
IF SY = RECORDSY
THEN
BEGIN
INSYMBOL;
OLDTOP := TOP;
IF TOP < DISPLIMIT
THEN
BEGIN
(* 5 - save block name for CREF *)
TOP := TOP + 1; DISPLAY[TOP].FNAME := NIL;
DISPLAY[TOP].BLKNAME := '.FIELDID. ';
(* 117 - fix enumerated types in record *)
DISPLAY[TOP].OCCUR := CREC
END
ELSE ERROR(404);
DISPL := 0;
BITCOUNT:=0;
(* 173 - internal files *)
FIELDLIST(FSYS-[SEMICOLON] OR [ENDSY],LSP1,LCP,LHASFILE);
FHASFILE := FHASFILE OR LHASFILE;
LBITSIZE := BITMAX;
NEWZ(LSP,RECORDS);
WITH LSP^ DO
BEGIN
SELFSTP := NIL;
FSTFLD := %LCP;\ DISPLAY[TOP].FNAME;
RECVAR := LSP1;
(* 20 - FIX PACKED RECORDS - FROM CMU - DELETED CODE NOW IN FIELDLIST *)
(* 104 - check structure sizes *)
SIZE := CHECKSIZE(DISPL);
BITSIZE := LBITSIZE; RECORDPF := PACKFLAG;
END;
TOP := OLDTOP;
IF SY = ENDSY
THEN INSYMBOL
ELSE ERROR(163)
END
ELSE
%SET\
IF SY = SETSY
THEN
BEGIN
INSYMBOL;
IF SY = OFSY
THEN INSYMBOL
ELSE ERROR(160);
SIMPLETYPE(FSYS,LSP1,LSIZE,LBITSIZE);
IF LSP1 # NIL
THEN
WITH LSP1^ DO
CASE FORM OF
SCALAR:
IF (LSP1=REALPTR) OR (LSP1=INTPTR)
THEN ERROR(352)
ELSE
IF SCALKIND =DECLARED
THEN
IF FCONST^.VALUES.IVAL > BASEMAX
THEN ERROR(352);
SUBRANGE:
IF ( RANGETYPE = REALPTR )
OR ( ( RANGETYPE # CHARPTR ) AND ((MAX.IVAL > BASEMAX) OR (MIN.IVAL < 0) ) )
THEN ERROR(352);
OTHERS:
BEGIN
ERROR(353); LSP1 := NIL
END
END;
LBITSIZE := BITMAX;
NEWZ(LSP,POWER);
WITH LSP^ DO
BEGIN
SELFSTP := NIL; ELSET := LSP1; SIZE:=2; BITSIZE := LBITSIZE
END;
END
ELSE
%FILE\
IF SY = FILESY
THEN
BEGIN
FHASFILE := TRUE;
INSYMBOL;
IF SY = OFSY
THEN INSYMBOL
ELSE ERROR(160);
TYP(FSYS,LSP1,LSIZE,LBITSIZE);
NEWZ(LSP,FILES);
LBITSIZE := BITMAX;
WITH LSP^ DO
BEGIN
SELFSTP := NIL;
(* 104 - check structure sizes *)
FILTYPE := LSP1;
(* 173 - internal files *)
SIZE := CHECKSIZE(LSIZE) + SIZEOFFILEBLOCK;
FILEPF := PACKFLAG; BITSIZE := LBITSIZE
END;
IF LSP1 # NIL
THEN
IF (LSP1^.FORM = FILES) OR (LSP1^.HASFILE)
THEN
BEGIN
ERROR(254); LSP^.FILTYPE := NIL
END;
(* 70 - fix ill mem ref if type error *)
END
ELSE LSP := NIL;
FSP := LSP; FBITSIZE := LBITSIZE
END;
IFERRSKIP(166,FSYS)
END
ELSE FSP := NIL;
IF FSP = NIL
THEN
BEGIN
FSIZE := 1;FBITSIZE := 0
END
(* 173 - internal files *)
ELSE BEGIN
FSIZE := FSP^.SIZE;
FSP^.HASFILE := FHASFILE
END
END %TYP\ ;
PROCEDURE LABELDECLARATION;
VAR
(* 64 - NON-LOCAL GOTOS *)
lcp:ctp;
BEGIN
(* 6 - remove error message. Allow LABEL declaration but ignore it *)
LOOP
IF SY = INTCONST
THEN
BEGIN
newz(lcp,labelt);
with lcp^ do
begin
scope := level; name := id; idtype := nil;
next := lastlabel; lastlabel := lcp;
gotochain := 0; labeladdress := 0
end;
enterid(lcp);
1:
INSYMBOL
END
ELSE ERROR(255);
IFERRSKIP(166,FSYS OR [COMMA,SEMICOLON]);
EXIT IF SY # COMMA;
INSYMBOL
END;
IF SY = SEMICOLON
THEN INSYMBOL
ELSE ERROR(156)
END %LABELDECLARATION\ ;
PROCEDURE CONSTANTDECLARATION;
VAR
LCP: CTP; LSP: STP; LVALU: VALU;
BEGIN
SKIPIFERR([IDENT],209,FSYS);
WHILE SY = IDENT DO
BEGIN
NEWZ(LCP,KONST);
WITH LCP^ DO
BEGIN
NAME := ID; IDTYPE := NIL; NEXT := NIL
END;
INSYMBOL;
IF (SY = RELOP) AND (OP = EQOP)
THEN INSYMBOL
ELSE ERROR(157);
(* 56 - REQ FILE SYNTAX *)
CONSTANT(FSYS OR [SEMICOLON,PERIOD],LSP,LVALU);
ENTERID(LCP);
LCP^.IDTYPE := LSP; LCP^.VALUES := LVALU;
IF SY = SEMICOLON
THEN
BEGIN
INSYMBOL;
IFERRSKIP(166,FSYS OR [IDENT])
END
(* 56 - REQ FILE SYNTAX *)
ELSE IF NOT ((SY=PERIOD) AND REQFILE)
THEN ERROR(156)
END
END %CONSTANTDECLARATION\ ;
PROCEDURE TYPEDECLARATION;
VAR
LCP,LCP1,LCP2: CTP; LSP: STP; LSIZE: ADDRRANGE;
LBITSIZE: BITRANGE;
BEGIN
SKIPIFERR([IDENT],209,FSYS);
WHILE SY = IDENT DO
BEGIN
NEWZ(LCP,TYPES);
WITH LCP^ DO
BEGIN
(* 116 - be sure NEXT is NIL when unused, for COPYCTP *)
NAME := ID; IDTYPE := NIL; NEXT := NIL;
END;
INSYMBOL;
IF (SY = RELOP) AND (OP = EQOP)
THEN INSYMBOL
ELSE ERROR(157);
(* 56 - REQ FILE SYNTAX *)
TYP(FSYS OR [SEMICOLON,PERIOD],LSP,LSIZE,LBITSIZE);
ENTERID(LCP);
WITH LCP^ DO
BEGIN
IDTYPE := LSP;
(* 165 - fix scoping for pointer ref's *)
END;
IF SY = SEMICOLON
THEN
BEGIN
INSYMBOL;
IFERRSKIP(166,FSYS OR [IDENT]);
END
(* 56 - REQ FILE SYNTAX *)
ELSE IF NOT ((SY=PERIOD) AND REQFILE)
THEN ERROR(156)
END;
(* 113 - don't check for forw. ref's satisfied in req. file *)
END %TYPEDECLARATION\ ;
(* 166 - must resolve forwards separately, in case of TYPE section
in required file but none in main *)
PROCEDURE FWDRESOLVE;
BEGIN
{For each forward request, look up the variable requested. If
you find the request, use it. Note that all declarations of
the form ^THING produce forward requests. This is to force
THING to be looked up after all type declarations have been
processed, so we get the local definition if there is one.}
WHILE FWPTR # NIL DO
BEGIN
(* 165 - fix scoping problem with pointers *)
ID := FWPTR^.NAME;
PRTERR := FALSE; %NO ERROR IF SEARCH NOT SUCCESSFUL\
SEARCHID([TYPES],LCP); PRTERR := TRUE;
IF LCP <> NIL
THEN IF LCP^.IDTYPE # NIL
THEN IF LCP^.IDTYPE^.FORM = FILES
THEN ERROR(254)
ELSE FWPTR^.IDTYPE^.ELTYPE := LCP^.IDTYPE
ELSE
ELSE ERRORWITHTEXT(405,FWPTR^.NAME);
FWPTR := FWPTR^.NEXT
END
END %FWDRESOLVE\ ;
PROCEDURE VARIABLEDECLARATION;
VAR
LCP,NXT: CTP; LSP: STP; LSIZE: ADDRRANGE;
LBITSIZE: BITRANGE; II: INTEGER;
(* 173 - removed lfileptr *)
BEGIN
NXT := NIL;
REPEAT
LOOP
IF SY = IDENT
THEN
BEGIN
NEWZ(LCP,VARS);
WITH LCP^ DO
BEGIN
NAME := ID; NEXT := NXT;
IDTYPE := NIL; VKIND := ACTUAL; VLEV := LEVEL
END;
ENTERID(LCP);
NXT := LCP;
INSYMBOL;
END
ELSE ERROR(209);
SKIPIFERR(FSYS OR [COMMA,COLON] OR TYPEDELS,166,[SEMICOLON]);
EXIT IF SY # COMMA;
INSYMBOL
END;
IF SY = COLON
THEN INSYMBOL
ELSE ERROR(151);
TYP(FSYS OR [SEMICOLON] OR TYPEDELS,LSP,LSIZE,LBITSIZE);
(* 24 - testpacked no longer needed *)
(* 173 - internal files *)
IF LSP <> NIL
THEN IF (LSP^.FORM = FILES) OR LSP^.HASFILE
THEN FILEINBLOCK[LEVEL] := TRUE;
WHILE NXT # NIL DO
WITH NXT^ DO
BEGIN
IDTYPE := LSP; VADDR := LC;
LC := LC + LSIZE ;
(* 173 - internal files - removed file code here *)
NXT := NEXT ;
END;
IF SY = SEMICOLON
THEN
BEGIN
INSYMBOL;
IFERRSKIP(166,FSYS OR [IDENT])
END
ELSE ERROR(156)
UNTIL (SY # IDENT) AND NOT (SY IN TYPEDELS);
(* 167 - code removed from here. It is now part of FWDRESOLVE,
which is called right after this procedure *)
END %VARIABLEDECLARATION\ ;
PROCEDURE PROCEDUREDECLARATION(FSY: SYMBOL);
VAR
OLDLEV: 0..MAXLEVEL; LSY: SYMBOL; LCP,LCP1: CTP; LSP: STP;
FORW: BOOLEAN; OLDTOP: DISPRANGE; LNXT: CTP;
(* 62 - clean up stack offsets *)
LLC,LCM: ADDRRANGE; TOPPOFFSET: ADDRRANGE;
PROCEDURE PARAMETERLIST(FSY: SETOFSYS; VAR FPAR: CTP; VAR TOPPOFFSET: ADDRRANGE);
VAR
LCP,LCP1,LCP2,LCP3: CTP; LSP: STP; LKIND: IDKIND;
(* 62 - clean up stack offset *)
REGC:INTEGER;
BEGIN
LCP1 := NIL; REGC := REGIN+1;
SKIPIFERR(FSY OR [LPARENT],256,FSYS);
IF SY = LPARENT
THEN
BEGIN
IF FORW
THEN ERROR(553);
INSYMBOL;
SKIPIFERR([IDENT,VARSY,PROCEDURESY,FUNCTIONSY],256,FSYS OR [RPARENT]);
WHILE SY IN [IDENT,VARSY,PROCEDURESY,FUNCTIONSY] DO
BEGIN
IF SY = PROCEDURESY
THEN
BEGIN
(* 33 - PROC PARAM.S *)
REPEAT
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
NEWZ(LCP,PROC,DECLARED,FORMAL);
WITH LCP^ DO
BEGIN
NAME := ID; IDTYPE := NIL; NEXT := LCP1;
PFLEV := LEVEL; PFADDR := LC
END;
ENTERID(LCP);
(* 62 - clean up stack offset *)
LCP1 := LCP; LC := LC + 1; REGC := REGC+1;
INSYMBOL
END
ELSE ERROR(209);
IFERRSKIP(256,FSYS OR [COMMA,SEMICOLON,RPARENT])
UNTIL SY # COMMA
END
ELSE
IF SY = FUNCTIONSY
THEN
BEGIN
(* 33 - PROC PARAM.S *)
LCP2 := NIL;
REPEAT
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
NEWZ(LCP,FUNC,DECLARED,FORMAL);
WITH LCP^ DO
BEGIN
NAME := ID; IDTYPE := NIL; NEXT := LCP2;
PFLEV := LEVEL; PFADDR := LC
END;
ENTERID(LCP);
(* 62 - clean up stack offset *)
LCP2 := LCP; LC := LC + 1; REGC := REGC+1;
INSYMBOL;
END;
IF NOT (SY IN [COMMA,COLON] OR FSYS)
THEN
ERRANDSKIP(256,FSYS OR [COMMA,SEMICOLON,RPARENT])
UNTIL SY # COMMA;
IF SY = COLON
THEN
BEGIN
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
SEARCHID([TYPES],LCP);
LSP := LCP^.IDTYPE;
IF LSP # NIL
THEN
IF NOT (LSP^.FORM IN [SCALAR,SUBRANGE,POINTER])
THEN
BEGIN
ERROR(551); LSP := NIL
END;
LCP3 := LCP2;
WHILE LCP2 # NIL DO
BEGIN
LCP2^.IDTYPE := LSP; LCP := LCP2;
LCP2 := LCP2^.NEXT
END;
LCP^.NEXT := LCP1; LCP1 := LCP3;
INSYMBOL
END
ELSE ERROR(209);
IFERRSKIP(256,FSYS OR [SEMICOLON,RPARENT])
END
ELSE ERROR(151)
END
ELSE
BEGIN
IF SY = VARSY
THEN
BEGIN
LKIND := FORMAL; INSYMBOL
END
ELSE LKIND := ACTUAL;
LCP2 := NIL;
LOOP
IF SY = IDENT
THEN
BEGIN
NEWZ(LCP,VARS);
WITH LCP^ DO
BEGIN
NAME := ID; IDTYPE := NIL;
VKIND := LKIND; NEXT := LCP2; VLEV := LEVEL;
END;
ENTERID(LCP);
LCP2 := LCP;
INSYMBOL;
END
ELSE ERROR(256);
IF NOT (SY IN [COMMA,COLON] OR FSYS)
THEN
ERRANDSKIP(256,FSYS OR [COMMA,SEMICOLON,RPARENT])
EXIT IF SY # COMMA;
INSYMBOL
END;
IF SY = COLON
THEN
BEGIN
INSYMBOL;
(* 15 - ALLOW :FILE AS KLUDGEY THING THAT MATCHES ALL FILES *)
IF SY IN [IDENT,FILESY]
THEN
BEGIN
IF SY=IDENT
THEN BEGIN
(* 111 - STRING, POINTER *)
SEARCHID([TYPES,PARAMS],LCP);
(* PARAMS IS A PREDECLARED IDENTIFIER DESCRIBING
A CLASS OF PARAMETERS WITH REDUCED TYPE CHECKING,
E.G. STRING OR POINTER *)
LSP := LCP^.IDTYPE;
END
ELSE LSP:=ANYFILEPTR;
IF LSP # NIL
THEN
IF (LKIND = ACTUAL) AND (LSP^.FORM = FILES)
THEN
ERROR(355);
(* 151 - fix reversed args in case I,J:INTEGER *)
{LCP2 is reversed at the moment. Put it forwards so memory alloc is right}
LCP3 := NIL;
WHILE LCP2 # NIL DO
BEGIN
LCP := LCP2;
LCP2 := LCP2^.NEXT;
LCP^.NEXT := LCP3;
LCP3 := LCP;
END;
WHILE LCP3 # NIL DO
BEGIN
WITH LCP3^ DO
BEGIN
IDTYPE := LSP;
VADDR := LC;
(* 161 - fix POINTER and STRING *)
(* 202 - pointer by ref *)
{POINTER and STRING are passed by a kludgey mechanism. Since it uses 2 AC's
we choose to call this thing call by value, with a size of 2. STRING
works the same for value and ref anyway. POINTER doesn't, so we
use pointerref instead of pointerptr to distinguish. If we call these
things 2-word quantities passed by value, then mostly the right thing
happens automatically. The only other place special code is required
is in CALLNONSTANDARD where by use a special routine in place of LOAD,
to do the actually funny passing.}
if (lsp = stringptr) or (lsp = pointerptr)
then if (lsp = pointerptr) and
(vkind = formal)
{If it is POINTER called by ref, use a special tag, POINTERREF }
then begin
idtype := pointerref;
vkind := actual
end
{In any case, consider it actual so the size = 2 works }
else vkind := actual;
IF VKIND = FORMAL
THEN LC := LC + 1
ELSE
IF IDTYPE # NIL
THEN LC := LC + IDTYPE^.SIZE;
(* 62 - clean up stack offset *)
IF IDTYPE = NIL
THEN REGC := REGC+1
ELSE IF (VKIND = ACTUAL) AND (IDTYPE^.SIZE = 2)
THEN REGC := REGC+2
ELSE REGC := REGC+1
END;
LCP := LCP3;
LCP3 := LCP3^.NEXT;
(* 151 - CONS the new thing on individually instead of APPENDing the whole
string, in order to avoid getting I and J reversed in I,J:INTEGER *)
{Note that we are here reversing the order again. This is because the
whole thing gets reversed below.}
LCP^.NEXT := LCP1;
LCP1 := LCP;
END;
INSYMBOL
END
ELSE ERROR(209);
IFERRSKIP(256,FSYS OR [SEMICOLON,RPARENT])
END
ELSE ERROR(151);
END;
IF SY = SEMICOLON
THEN
BEGIN
INSYMBOL;
SKIPIFERR(FSYS OR [IDENT,VARSY,PROCEDURESY,FUNCTIONSY],256,[RPARENT])
END
END %WHILE\ ;
IF SY = RPARENT
THEN
BEGIN
INSYMBOL;
IFERRSKIP(166,FSY OR FSYS)
END
ELSE ERROR(152);
LCP3 := NIL;
%REVERSE POINTERS\
WHILE LCP1 # NIL DO
WITH LCP1^ DO
BEGIN
LCP2 := NEXT; NEXT := LCP3;
LCP3 := LCP1; LCP1 := LCP2
END;
FPAR := LCP3
END
ELSE FPAR := NIL;
(* 62 - clean up stack offset *)
IF (REGC - 1) > PARREGCMAX
THEN TOPPOFFSET := LC - 1
ELSE TOPPOFFSET := 0;
END %PARAMETERLIST\ ;
BEGIN
%PROCEDUREDECLARATION\
LLC := LC;
IF FSY = PROCEDURESY
THEN LC := 1
ELSE LC := 2;
IF SY = IDENT
THEN
BEGIN
(* 5 - CREF *)
IF CREF
THEN WRITE(CHR(15B),CHR(10),ID);
SEARCHSECTION(DISPLAY[TOP].FNAME,LCP); %DECIDE WHETHER FORW.\
IF LCP # NIL
THEN
WITH LCP^ DO
BEGIN
IF KLASS = PROC
THEN
FORW := FORWDECL AND (FSY = PROCEDURESY) AND (PFKIND = ACTUAL)
ELSE
IF KLASS = FUNC
THEN
FORW := FORWDECL AND (FSY = FUNCTIONSY) AND (PFKIND = ACTUAL)
ELSE FORW := FALSE;
IF NOT FORW
THEN ERROR(406)
END
ELSE FORW := FALSE;
IF NOT FORW
THEN
BEGIN
IF FSY = PROCEDURESY
THEN NEWZ(LCP,PROC,DECLARED,ACTUAL)
ELSE NEWZ(LCP,FUNC,DECLARED,ACTUAL);
WITH LCP^ DO
BEGIN
(* 116 - be sure NEXT is NIL when unused, for COPYCTP *)
NAME := ID; IDTYPE := NIL; TESTFWDPTR := NIL; NEXT := NIL;
FORWDECL := FALSE; EXTERNDECL := FALSE; LANGUAGE := PASCALSY;
PFLEV := LEVEL; PFADDR := 0; FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0
END;
ENTERID(LCP)
END
ELSE
BEGIN
LCP1 := LCP^.NEXT;
WHILE LCP1 # NIL DO
BEGIN
WITH LCP1^ DO
IF KLASS = VARS
THEN
IF IDTYPE # NIL
THEN
BEGIN
LCM := VADDR + IDTYPE^.SIZE;
IF LCM > LC
THEN LC := LCM
END;
LCP1 := LCP1^.NEXT
END
END;
INSYMBOL
END
ELSE
BEGIN
ERROR(209);
IF FSY = PROCEDURESY
THEN LCP := UPRCPTR
ELSE LCP := UFCTPTR
END;
OLDLEV := LEVEL; OLDTOP := TOP;
IF LEVEL < MAXLEVEL
THEN LEVEL := LEVEL + 1
ELSE ERROR(453);
IF TOP < DISPLIMIT
THEN
BEGIN
TOP := TOP + 1;
WITH DISPLAY[TOP] DO
BEGIN
(* 5 - save block name for CREF *)
FNAME := NIL; OCCUR := BLCK; BLKNAME := LCP^.NAME;
IF DEBUG THEN BEGIN
(* 214 - use ULBLPTR because UPRCPTR will not have NEXT treated
properly *)
{This is a dummy entry in the symbol table strictly for the debugger.
The debugger looks at its NEXT field to find the procedure name}
NEWZ(LCP1); LCP1^ := ULBLPTR^;
LCP1^.NEXT := LCP;
ENTERID(LCP1);
IF FORW AND (LCP^.NEXT # NIL)
THEN BEGIN
(* 150 - removed lcp1^.llink := lcp^.next. LCP^.NEXT is a tree containing
the parameters. It needs to be put into the symbol table. Since
all legal symbols > blanks, just put it in Rlink. Previously got
all symbols twice in debugger! *)
LCP1^.RLINK := LCP^.NEXT
END
END
ELSE IF FORW THEN FNAME := LCP^.NEXT
END %WITH DISPLAY[TOP]\
END
ELSE ERROR(404);
IF FSY = PROCEDURESY
THEN
BEGIN
(* 62 - clean up stack offset *)
PARAMETERLIST([SEMICOLON],LCP1,TOPPOFFSET);
IF NOT FORW
THEN WITH LCP^ DO
BEGIN NEXT := LCP1; POFFSET := TOPPOFFSET END
END
ELSE
BEGIN
(* 62 - clean up stack offset *)
PARAMETERLIST([SEMICOLON,COLON],LCP1,TOPPOFFSET);
IF NOT FORW
THEN WITH LCP^ DO
BEGIN NEXT := LCP1; POFFSET := TOPPOFFSET END;
IF SY = COLON
THEN
BEGIN
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
IF FORW
THEN ERROR(552);
SEARCHID([TYPES],LCP1);
LSP := LCP1^.IDTYPE;
LCP^.IDTYPE := LSP;
IF LSP # NIL
THEN
IF NOT (LSP^.FORM IN [SCALAR,SUBRANGE,POINTER])
THEN
BEGIN
ERROR(551); LCP^.IDTYPE := NIL
END;
INSYMBOL
END
ELSE ERRANDSKIP(209,FSYS OR [SEMICOLON])
END
ELSE
IF NOT FORW
THEN ERROR(455)
END;
IF SY = SEMICOLON
THEN INSYMBOL
ELSE ERROR(156);
IF SY = FORWARDSY
THEN
BEGIN
IF FORW
THEN ERROR(257)
ELSE
WITH LCP^ DO
BEGIN
TESTFWDPTR := FORWPTR; FORWPTR := LCP; FORWDECL := TRUE
END;
INSYMBOL;
IF SY = SEMICOLON
THEN INSYMBOL
ELSE ERROR(156);
IFERRSKIP(166,FSYS)
END % SY = FORWARDSY \
ELSE
WITH LCP^ DO
BEGIN
IF SY = EXTERNSY
THEN
BEGIN
IF FORW
THEN ERROR(257)
ELSE EXTERNDECL := TRUE;
INSYMBOL;
IF LEVEL # 2
THEN ERROR(464);
IF SY IN LANGUAGESYS
THEN
BEGIN
LANGUAGE := SY;
INSYMBOL
END;
IF (LIBIX = 0) OR (NOT LIBRARY[LANGUAGE].INORDER)
THEN
BEGIN
LIBIX:= LIBIX+1;
LIBORDER[LIBIX]:= LANGUAGE;
LIBRARY[LANGUAGE].INORDER:= TRUE
END;
PFLEV := 1; PFCHAIN := EXTERNPFPTR; EXTERNPFPTR := LCP;
IF SY = SEMICOLON
(* 56 - ACCEPT SYNTAX OF REQUIRE FILE *)
THEN BEGIN
INSYMBOL;
IFERRSKIP(166,FSYS)
END
ELSE IF NOT((SY=PERIOD) AND REQFILE)
THEN ERROR(166)
END % SY = EXTERNSY \
ELSE
BEGIN
(* 55 - ONLY EXTERN DECL'S ALLOWED IN REQUIRE FILE *)
IF REQFILE
THEN ERROR(169);
PFCHAIN := LOCALPFPTR; LOCALPFPTR := LCP; FORWDECL := FALSE;
BLOCK(LCP,FSYS,[BEGINSY,FUNCTIONSY,PROCEDURESY,PERIOD,SEMICOLON]);
IF SY = SEMICOLON
THEN
BEGIN
INSYMBOL;
SKIPIFERR([BEGINSY,PROCEDURESY,FUNCTIONSY],166,FSYS)
END
ELSE
IF MAIN OR (LEVEL > 2) OR (SY # PERIOD)
THEN ERROR(156)
END % SY # EXTERNSY \
END % SY # FORWARDSY \ ;
LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC;
(* 5 - CREF *)
IF CREF
THEN WRITE(CHR(16B),CHR(10),LCP^.NAME)
END %PROCEDUREDECLARATION\ ;
PROCEDURE BODY(FSYS: SETOFSYS);
CONST
(* 173 - rework for internal files *)
FILEOF = 1B; FILEOL = 2B; FILSTA = 11B; FILTST=40B;
FILBFH =26B; FILLNR = 31B;
(* 43 - new stuff for blocked files *)
(* 50 - new labels for reinit *)
FILCMP =43B; filbll=36b;
(* 61 - tops20 *)
filjfn =4b;
VAR
LASTFILE: CTP;
IDTREE: ADDRRANGE; %POINTER(IN THE USER'S CODE) TO THE IDENTIFIER-TREE\
PROCEDURE FULLWORD(FRELBYTE: RELBYTE; FLEFTH: ADDRRANGE; FRIGHTH: ADDRRANGE);
BEGIN
%FULLWORD\
CIX := CIX + 1;
IF CIX > CIXMAX
THEN
BEGIN
IF FPROCP = NIL THEN ERRORWITHTEXT(356,'MAIN ')
ELSE ERRORWITHTEXT(356, FPROCP^.NAME);
CIX := 0
END;
WITH CODE, HALFWORD[CIX] DO
BEGIN
LEFTHALF := FLEFTH;
RIGHTHALF := FRIGHTH;
INFORMATION[CIX] := 'W'; RELOCATION[CIX] := FRELBYTE
END;
IC := IC + 1
END %FULLWORD\ ;
(* 164 - routine to allow Polish fixup in case ADDR can't be done by compiler *)
procedure insertpolish(place,original:addrrange;adjust:integer);
var pol:polpt;
{This routine requests the loader to fix up the right half of PLACE, by
putting in ORIGINAL (assumed relocatable) + ADJUST (assumed absolute).
A POLREC is created, and the actual request is put in the file by
WRITEMC(WRITEPOLISH).}
begin
if abs(adjust) > 377777B
then error(266)
else begin
new(pol);
with pol^ do
begin
where := place;
base := original;
offset := adjust;
nextpol := firstpol {Link into chain of requests - FIRSTPOL}
end;
firstpol := pol
end;
end;
PROCEDURE INSERTADDR(FRELBYTE: RELBYTE; FCIX:CODERANGE;FIC:ADDRRANGE);
BEGIN
IF NOT ERRORFLAG
THEN
WITH CODE DO
BEGIN
INSTRUCTION[FCIX].ADDRESS := FIC;
RELOCATION[FCIX] := FRELBYTE
END
END;
PROCEDURE INCREMENTREGC;
BEGIN
REGC := REGC + 1 ;
IF REGC > REGCMAX
THEN
BEGIN
ERROR(310) ; REGC := REGIN
END
END ;
PROCEDURE DEPCST(KONSTTYP:CSTCLASS; FATTR:ATTR);
VAR
II:INTEGER; LKSP,LLKSP: KSP; LCSP: CSP;
NEUEKONSTANTE,GLEICH:BOOLEAN; LCIX: CODERANGE;
BEGIN
I:=1;
NEUEKONSTANTE:=TRUE; LKSP := FIRSTKONST;
WHILE (LKSP#NIL) AND NEUEKONSTANTE DO
WITH LKSP^,CONSTPTR^ DO
BEGIN
IF CCLASS = KONSTTYP
THEN
CASE KONSTTYP OF
REEL:
IF RVAL = FATTR.CVAL.VALP^.RVAL
THEN
NEUEKONSTANTE := FALSE;
INT:
IF INTVAL = FATTR.CVAL.IVAL
THEN
NEUEKONSTANTE := FALSE;
PSET:
IF PVAL = FATTR.CVAL.VALP^.PVAL
THEN
NEUEKONSTANTE := FALSE;
STRD,
STRG:
IF FATTR.CVAL.VALP^.SLGTH = SLGTH
THEN
BEGIN
GLEICH := TRUE;
II := 1;
REPEAT
IF FATTR.CVAL.VALP^.SVAL[II] # SVAL[II]
THEN
GLEICH := FALSE;
II:=II+1
UNTIL (II>SLGTH) OR NOT GLEICH;
IF GLEICH
THEN NEUEKONSTANTE := FALSE
END
END %CASE\;
LLKSP := LKSP; LKSP := NEXTKONST
END %WHILE\;
IF NOT NEUEKONSTANTE
THEN
WITH LLKSP^ DO
BEGIN
INSERTADDR(RIGHT,CIX,ADDR); CODE.INFORMATION[CIX]:= 'C';
IF KONSTTYP IN [PSET,STRD]
THEN
BEGIN
INSERTADDR(RIGHT,CIX-1,ADDR1); CODE.INFORMATION[CIX-1]:= 'C'; ADDR1 := IC-2;
END;
ADDR:= IC-1
END
ELSE
BEGIN
IF KONSTTYP = INT
THEN
BEGIN
NEWZ(LCSP,INT); LCSP^.INTVAL := FATTR.CVAL.IVAL
END
ELSE
LCSP := FATTR.CVAL.VALP;
CODE.INFORMATION[CIX] := 'C';
IF KONSTTYP IN [PSET,STRD]
THEN CODE.INFORMATION[CIX-1] := 'C';
NEWZ(LKSP);
WITH LKSP^ DO
BEGIN
ADDR := IC-1;
(* 72 - two fixup chains for 2 word consts *)
if konsttyp in [strd,pset]
then addr1 := ic-2;
CONSTPTR := LCSP; NEXTKONST := NIL
END;
IF FIRSTKONST = NIL
THEN FIRSTKONST := LKSP
ELSE LLKSP^.NEXTKONST := LKSP
END
END %DEPCST\;
PROCEDURE MACRO(FRELBYTE : RELBYTE;
FINSTR : INSTRANGE;
FAC : ACRANGE;
FINDBIT : IBRANGE;
FINXREG : ACRANGE;
FADDRESS : INTEGER);
BEGIN
IF NOT INITGLOBALS
THEN
BEGIN
CIX := CIX + 1;
IF CIX > CIXMAX
THEN
BEGIN
IF FPROCP = NIL
THEN ERRORWITHTEXT(356,'MAIN ')
ELSE ERRORWITHTEXT(356, FPROCP^.NAME);
CIX := 0
END;
WITH CODE, INSTRUCTION[CIX] DO
BEGIN
INSTR :=FINSTR;
AC :=FAC;
INDBIT :=FINDBIT;
INXREG :=FINXREG;
ADDRESS :=FADDRESS;
INFORMATION[CIX]:= ' '; RELOCATION[CIX] := FRELBYTE
END;
IC := IC + 1
END
ELSE ERROR(507)
END %MACRO\;
PROCEDURE MACRO5(FRELBYTE: RELBYTE; FINSTR : INSTRANGE; FAC,FINXREG : ACRANGE; FADDRESS : INTEGER);
BEGIN
MACRO(FRELBYTE,FINSTR,FAC,0,FINXREG,FADDRESS)
END;
PROCEDURE MACRO4(FINSTR: INSTRANGE;FAC, FINXREG: ACRANGE;FADDRESS: INTEGER);
BEGIN
MACRO(NO,FINSTR,FAC,0,FINXREG,FADDRESS)
END;
PROCEDURE MACRO3(FINSTR : INSTRANGE; FAC:ACRANGE; FADDRESS: INTEGER);
BEGIN
MACRO(NO,FINSTR,FAC,0,0,FADDRESS)
END;
PROCEDURE MACRO4R(FINSTR : INSTRANGE; FAC,FINXREG : ACRANGE; FADDRESS : INTEGER);
BEGIN
MACRO(RIGHT,FINSTR,FAC,0,FINXREG,FADDRESS)
END;
PROCEDURE MACRO3R(FINSTR : INSTRANGE; FAC:ACRANGE; FADDRESS: INTEGER);
BEGIN
MACRO(RIGHT,FINSTR,FAC,0,0,FADDRESS)
END;
PROCEDURE PUTPAGER;
BEGIN
WITH PAGER DO
BEGIN
LASTPAGER := IC;
WITH WORD1 DO MACRO4R(304B%CAIA\,AC,INXREG,ADDRESS);
FULLWORD(RIGHT,LHALF,RHALF);
LASTPAGE := PAGECNT
END
END;
PROCEDURE PUTLINER;
BEGIN
IF PAGECNT # LASTPAGE
THEN PUTPAGER;
IF LINECNT # LASTLINE
THEN %BREAKPOINT\
BEGIN
IF LINENR # '-----'
THEN
BEGIN
LINECNT := 0;
FOR I := 1 TO 5 DO LINECNT := 10*LINECNT + ORD(LINENR[I]) - ORD('0')
END;
LINEDIFF := LINECNT - LASTLINE;
IF LINEDIFF > 255
THEN
BEGIN
MACRO3R(334B%SKIPA\,0,LASTSTOP);
LASTSTOP := IC-1;
MACRO3(320B%JUMP\,0,LASTLINE)
END
ELSE
BEGIN
MACRO4R(320B%JUMP\,LINEDIFF MOD 16,LINEDIFF DIV 16, LASTSTOP); %NOOP\
LASTSTOP := IC - 1
END;
LASTLINE := LINECNT
END
END;
PROCEDURE SUPPORT(FSUPPORT: SUPPORTS);
BEGIN
CASE FSUPPORT OF
(* 23 - check for bad pointer *)
BADPOINT,
ERRORINASSIGNMENT,
INDEXERROR : MACRO3R(265B%JSA\,HAC,RNTS.LINK[FSUPPORT]);
(* 12 - NOW STACKOVERFLOW IS NOT AN ERROR - GETS MORE MEMORY *)
(* 74 - add initmem for 10 version under emulator *)
(* 104 - debstack for tops-10 debugging stack check *)
(* 120 - new calling method for INITFILES, for T20/Tenex *)
INITFILES,INITMEM,STACKOVERFLOW,DEBSTACK: MACRO3R(265B%JSP\,TAC,RNTS.LINK[FSUPPORT]);
(* 64 - non-local gotos *)
EXITPROGRAM : MACRO3R(254B%JRST\,0,RNTS.LINK[FSUPPORT]);
OTHERS : MACRO3R(260B%PUSHJ\,TOPP,RNTS.LINK[FSUPPORT])
END;
CODE.INFORMATION[CIX]:= 'E';
RNTS.LINK[FSUPPORT]:= IC-1
END;
PROCEDURE ENTERBODY;
VAR
I: INTEGER; LCP : CTP;
(* 66 - NON-LOC GOTO *)
LBTP: BTP; NONLOC,INLEVEL: BOOLEAN;
BEGIN
LBTP := LASTBTP;
(* 13 - ADD DATA FOR DDT SYMBOLS *)
PFPOINT := IC;
WHILE LBTP # NIL DO
BEGIN
WITH LBTP^ DO
CASE BKIND OF
RECORDD: FIELDCP^.FLDADDR := IC;
ARRAYY : ARRAYSP^.ARRAYBPADDR := IC
END;
LBTP := LBTP^.LAST;
IC := IC + 1
END;
(* 66 - NON-LOC GOTO *)
LCP:=LASTLABEL;
INLEVEL:=TRUE; NONLOC:=FALSE;
WHILE(LCP#NIL) AND INLEVEL DO
WITH LCP^ DO
IF SCOPE=LEVEL
THEN BEGIN
NONLOC := NONLOC OR NONLOCGOTO;
LCP := NEXT
END
ELSE INLEVEL := FALSE;
IF FPROCP # NIL
THEN
BEGIN
FULLWORD(NO,0,377777B); IDTREE := CIX; %IF DEBUG, INSERT TREEPOINTER HERE\
(* 13 - SAVE START ADDRESS FOR DDT SYMBOL *)
PFDISP := IC;
WITH FPROCP^ DO
IF PFLEV > 1
THEN
FOR I := MAXLEVEL DOWNTO PFLEV+1 DO
MACRO4(540B%HRR\,BASIS,BASIS,-1);
PFSTART := IC;
(* 62 - clean up stack offset *)
if fprocp^.poffset # 0
then macro4(262B%pop\,topp,topp,-fprocp^.poffset-1);
(* 37 - fix static link for level one procedures *)
if fprocp^.pflev = 1
then macro4(512b%hllzm\,basis,topp,-fprocp^.poffset-1)
ELSE MACRO4(202B%MOVEM\,BASIS,TOPP,-FPROCP^.POFFSET-1);
if fprocp^.poffset # 0
then begin
macro4(201B%movei\,basis,topp,-fprocp^.poffset);
(* 104 - several changes below to allow detection stack overflow *)
macro3(504B%hrl\,basis,basis);
end
ELSE MACRO3(507B%HRLS\,BASIS,TOPP);
(* 115 - tenex *)
IF KLCPU AND NOT TOPS10
THEN MACRO3(105B%ADJSP\,TOPP,0)
ELSE MACRO4(541B%HRRI\,TOPP,TOPP,0);
INSERTSIZE := CIX;
(* 66 - NONLOC GOTO *)
IF NONLOC
THEN MACRO4(506B%HRLM\,TOPP,BASIS,0);
(* If anyone has done a non-local goto into this block, save the
stack pointer here where the goto can recover it. *)
(* 53 - figure out later how many loc's above stack we need *)
(* 57 - LIMIT CORE ALLOCATION TO TOPS-10 VERSION *)
IF TOPS10 THEN BEGIN
IF RUNTMCHECK
THEN BEGIN
MACRO4(201B%MOVEI\,HAC,TOPP,0); CORALLOC := CIX;
%Will be fixed up - get highest core needed \
MACRO4(301B%CAIL\,HAC,BASIS,0); %check wraparound > 777777\
MACRO4(303B%CAILE\,HAC,NEWREG,0); %see if need more\
SUPPORT(DEBSTACK)
END
ELSE BEGIN %NOT DEBUG\
MACRO4(307B%CAIG\,NEWREG,TOPP,0); CORALLOC := CIX;
%will be fixed up - fails if wrap around 777777\
SUPPORT(STACKOVERFLOW);
END
END;
(* 24 - NOW ZERO ONLY IF RUNTIME CHECKING ON *)
(* 25 - SEPARATE SWITCH /ZERO FOR THIS NOW *)
IF ZERO
THEN BEGIN
IF LCPAR < LC %ANY VARIABLES?\
THEN MACRO4(402B%SETZM\,0,BASIS,LCPAR);
IF LCPAR < (LC-1) %MORE THAN ONE?\
THEN BEGIN
MACRO4(505B%HRLI\,TAC,BASIS,LCPAR);
MACRO4(541B%HRRI\,TAC,BASIS,LCPAR+1);
MACRO4(251B%BLT\,TAC,BASIS,LC-1)
END
END;
REGC := REGIN+1;
LCP := FPROCP^.NEXT;
WHILE LCP # NIL DO
WITH LCP^ DO
BEGIN
(* 33 - proc param.'s*)
IF KLASS # VARS
THEN
BEGIN
IF REGC <= PARREGCMAX
THEN BEGIN
MACRO4(202B%MOVEM\,REGC,BASIS,PFADDR);
REGC := REGC+1
END
END
ELSE
IF IDTYPE # NIL
THEN
IF (VKIND=FORMAL) OR (IDTYPE^.SIZE=1)
THEN %COPY PARAMETERS FROM REGISTERS INTO LOCAL CELLS\
BEGIN
IF REGC <= PARREGCMAX
THEN
BEGIN
MACRO4(202B%MOVEM\,REGC,BASIS,VADDR); REGC := REGC + 1
END
END
ELSE
IF IDTYPE^.SIZE=2
THEN
BEGIN
IF REGC < PARREGCMAX
THEN
BEGIN
MACRO4(202B%MOVEM\,REGC,BASIS,VADDR);
MACRO4(202B%MOVEM\,REGC+1,BASIS,VADDR+1);
REGC:=REGC+2
END
(* 2 - bug fix for parameter passing *)
ELSE REGC:=PARREGCMAX+1
END
(* 201 - zero size things *)
ELSE IF IDTYPE^.SIZE > 0
THEN BEGIN
IF REGC <= PARREGCMAX
THEN %COPY MULTIPLE VALUES INTO LOCAL CELLS\
BEGIN
MACRO3(504B%HRL\,TAC,REGC); REGC := REGC + 1
END
ELSE
MACRO4(504B%HRL\,TAC,BASIS,VADDR);
MACRO4(541B%HRRI\,TAC,BASIS,VADDR);
MACRO4(251B%BLT\,TAC,BASIS,VADDR+IDTYPE^.SIZE-1)
END
(* 201 - zero size things *)
ELSE {zero size}
REGC := REGC + 1;
LCP := LCP^.NEXT;
END
END
ELSE MAINSTART := IC
END %ENTERBODY\;
PROCEDURE LEAVEBODY;
VAR
J,K : ADDRRANGE ;
LFILEPTR: FTP; LKSP: KSP ;
(* 33 - PROGRAM *)
LCP : CTP; OLDID : ALFA;
PROCEDURE ALFACONSTANT(FSTRING:ALFA);
VAR LCSP:CSP;
BEGIN
NEW(LCSP,STRG);
WITH LCSP^ DO
BEGIN
SLGTH := 10; FOR I := 1 TO 10 DO SVAL[I] := FSTRING[I]
END;
WITH GATTR DO
BEGIN
TYPTR := ALFAPTR;
KIND := CST; CVAL.VALP := LCSP
END
END;
BEGIN
IF DEBUG
THEN PUTLINER;
IF FPROCP # NIL
THEN
(* 173 - internal files - close them *)
if fileinblock[level]
then begin
{We have to close any files in this block before we can change TOPP,
or we might be playing with locals above the stack! So this is
coded like a non-local goto - new basis in regc, new topp in regc+1}
regc := regin+1;
(* 213 - forgot to subtract 1 from TOPP to simulate POPJ *)
{simulate HRLS TOPP,BASIS. But have to subtract 1
since there would have been a POPJ TOPP, later.
Because of this, things that would be -1(TOPP) are
now (TOPP)}
macro4(505B%hrli\,regc+1,basis,-1);
macro3(544B%hlr\,regc+1,regc+1);
{simulate HLRS BASIS,-1(TOPP), but note that -1 has
already been done}
macro4(544B%hlr\,regc,regc+1,0);
macro3(504B%hrl\,regc,regc);
{now get return address from where POPJ TOPP, would
get it, i.e. (TOPP). However note that -1 has been
done}
macro4(550B%hrrz\,regc+2,regc+1,1);
support(exitgoto)
end
else
BEGIN
(* 104 - keep LH=RH in topp for tops20 adjsp *)
MACRO3(507B%HRLS\,TOPP,BASIS);
MACRO4(547B%HLRS\,BASIS,TOPP,-1);
MACRO3(263B%POPJ\,TOPP,0);
END
ELSE
BEGIN
IF MAIN
THEN
BEGIN
SUPPORT(EXITPROGRAM);
STARTADDR := IC;
(* 2 - get some core by default if none there *)
(* 12 - REDO INITIALIZATION FOR DYNAMIC EXPANDING CORE *)
(* 16 - change entry code in case execute-only or entry at +1 *)
(* 24 - CHANGE AGAIN TO ALLOW ST. ADDR OF HEAP AND STACK SPECIFIED *)
MACRO3R(254B%JRST\,1,IC+2); %PORTAL - IN CASE EXEC-ONLY\
MACRO3R(254B%JRST\,1,IC+2); %IN CASE OFFSET =1\
MACRO3(634B%TDZA\,1,1); %NORMAL ENTRY - ZERO AND SKIP\
MACRO3(201B%MOVEI\,1,1); %CCL ENTRY - SET TO ONE\
MACRO3R(202B%MOVEM\,1,CCLSW); %STORE CCL VALUE\
MACRO3R(200B%MOVE\,1,CCLSW+4); %SEE IF INIT DONE\
MACRO3R(326B%JUMPN\,1,IC+5); %YES - DON'T RESAVE AC'S\
MACRO3R(202B%MOVEM\,0,CCLSW+1); %RUNNAME\
MACRO3R(202B%MOVEM\,7B,CCLSW+2); %RUNPPN\
MACRO3R(202B%MOVEM\,11B,CCLSW+3); %RUNDEV\
MACRO3R(476B%SETOM\,0,CCLSW+4); %SAY WE HAVE DONE IT\
(* 132 - separate KA10 into NOVM and KACPU *)
IF (HEAP = 0) AND (NOT NOVM)
THEN HEAP := 377777B;
MACRO3(201B%MOVEI\,BASIS,HEAP); %LSTNEW_377777\
MACRO3R(202B%MOVEM\,BASIS,LSTNEW); %WILL GET GLOBAL FIXUP\
LSTNEW := IC-1;
MACRO3(201B%MOVEI\,BASIS,HEAP+1); %NEWBND_400000\
MACRO3R(202B%MOVEM\,BASIS,NEWBND); %GLOBAL FIXUP\
NEWBND := IC-1;
IF STACK#0
THEN MACRO3(201B%MOVEI\,BASIS,STACK)
ELSE MACRO3(550B%HRRZ\,BASIS,115B); %BASIS_.JBHRL\
MACRO3(306B%CAIN\,BASIS,0); %IF NO HISEG\
MACRO3(201B%MOVEI\,BASIS,377777B); %START STACK 400000\
MACRO3(200B%MOVE\,NEWREG,BASIS); %NEWREG=HIGHEST ALLOC\
MACRO3(271B%ADDI\,BASIS,1); %BASIS=NEXT TO USE\
MACRO4(505B%HRLI\,BASIS,BASIS,0);
MACRO4(541B%HRRI\,TOPP,BASIS,0); %GETS FIXED UP\
INSERTSIZE:= CIX;
(* 104 - KEEP LH=RH FOR TOPS20 ADJSP *)
MACRO3(504B%HRL\,TOPP,TOPP);
(* 66 - nonloc goto's *)
macro3r(202B%movem\,basis,globbasis);
macro3r(202B%movem\,topp,globtopp);
(* 17 - LEAVE .JBFF ALONE, SINCE BUFFER HEADERS POINT INTO FREE AREA *)
(* 57 - LIMIT UUO'S AND CORE ALLOC TO TOPS-10 VERSION *)
IF TOPS10 THEN BEGIN
(* 122 - seem not to need to save .jbff any more *)
{ MACRO3(550B%HRRZ\,1,121B); %.JBFF\
MACRO3(506B%HRLM\,1,120B); %TO LH(.JBSA)\
} MACRO3(047B,0,0%RESET-UUO\); %.JBFF=.JBSA\
(* 74 - new init stuff for tops10 under emulator *)
support(initmem);
(* 53 - figure out later how many loc's above stack we need *)
(* 130 - leave in dummy CAI in KA version so there is some place for the CORALLOC fixup to go *)
MACRO4(300B%CAI\,NEWREG,TOPP,0); CORALLOC := CIX; %Will be fixed up later\
(* 122 - already get core in initmem for KA *)
(* 132 - separate KA10 into novm and kacpu *)
if not novm
THEN SUPPORT(STACKOVERFLOW); % GET CORE FOR STACK\
(* 34 - TRAP ARITH EXCEPTIONS WHEN CHECKING *)
IF ARITHCHECK
THEN BEGIN
MACRO3(201B%MOVEI\,1,110B); %TRAP ALL ARITH. EXCEPTIONS\
MACRO3(047B%CALLI\,1,16B); %APRENB - TURN ON APR SYS\
END;
(* 57 - INIT ALL IN RUNTIMES FOR NON-TOPS10 *)
END
ELSE MACRO3(201B%MOVEI\,2,ORD(ARITHCHECK));
(* 50 - reinit file ctl. blocks *)
support(initfiles);
doinitTTY := false;
LFILEPTR := SFILEPTR ;
REGC := REGIN + 1 ;
(* 33 - PROGRAM *)
(* 50 - changed logic to only open INPUT and OUTPUT if in pgm state *)
LPROGFILE := FPROGFILE;
WHILE LPROGFILE # NIL DO
BEGIN
PRTERR := FALSE; OLDID := ID; ID := LPROGFILE^.FILID;
SEARCHID([VARS],LCP);
PRTERR := TRUE; ID := OLDID;
IF LCP = NIL
THEN ERRORWITHTEXT(508,LPROGFILE^.FILID)
ELSE
WITH LCP^ DO
BEGIN
IF IDTYPE#NIL THEN IF IDTYPE^.FORM#FILES
THEN ERRORWITHTEXT(509,LPROGFILE^.FILID);
MACRO3R(201B%MOVEI\,REGC,VADDR);
IF (VLEV = 0) AND (NOT MAIN)
THEN BEGIN
VADDR := IC -1;
CODE.INFORMATION[CIX] := 'E'
END;
ALFACONSTANT(LPROGFILE^.FILID);
MACRO3(551B%HRRZI\,REGC+1,0);DEPCST(STRG,GATTR);
(* 61 - set up flags for gtjfn *)
i := 60023b; %mandatory flags for gtjfn\
if lprogfile^.wild
then i := i + 100B;
if lprogfile^.newgen
then i := i + 400000B;
if lprogfile^.oldfile
then i := i + 100000B;
macro3(505B%hrli\,regc+1,i);
(* 172 - end of line proc *)
if lcp = ttyfile
then ttyseeeol := lprogfile^.seeeol;
if not ((lcp = ttyfile) or (lcp = ttyoutfile))
then SUPPORT(READFILENAME)
END;
(* 171 - handle input and output as special - many changes to lcp = in/outfile *)
if (lcp = infile)
and not lprogfile^.interact
then doinitTTY := true;
if (lcp = infile) or (lcp = outfile)
then begin
macro3(201B%movei\,regc-1,0); {AC1=0 for text file}
macro3(403B%setzb\,regc+1,regc+2);
macro3(403B%setzb\,regc+3,regc+4);
(* 64 - input:/ *)
(* 157 - always open INPUT interactive - do GET below *)
if lcp = infile
then macro3(201B%movei\,regc+3,1);
macro3(403B%setzb\,regc+5,regc+6);
(* 172 - new eoln handling *)
if (lcp = infile) and lprogfile^.seeeol
then if tops10
then macro3(201B%movei\,regc+5,40000B)
else macro3(201B%movei\,regc+6,20B);
if lcp = infile
then support(resetfile)
else support(rewritefile)
end;
LPROGFILE := LPROGFILE^.NEXT
END;
(* 15 - ZERO ALL ARGS TO OPEN *)
TTYINUSE := TTYINUSE OR DEBUG;
WHILE LFILEPTR # NIL DO
WITH LFILEPTR^ , FILEIDENT^ DO
(* 50 - only open TTY here, as INPUT and OUTPUT done above *)
begin
if (fileident = ttyfile) or (fileident = ttyoutfile)
then
BEGIN
MACRO3R(201B%MOVEI\,REGC,VADDR) ;
macro3(201B%movei\,regc-1,0); {0=text file}
(* 202 - fix illegal option *)
macro3(403B%setzb\,regc+1,regc+2);
macro3(403B%setzb\,regc+3,regc+4);
(* 172 - new EOL *)
macro3(403B%setzb\,regc+5,regc+6);
if (fileident = ttyfile) and ttyseeeol
then if tops10
then macro3(201B%movei\,regc+5,40000B)
else macro3(201B%movei\,regc+6,20B);
(* 36 - allow debugging non-main modules *)
IF fileident = ttyfile
THEN
SUPPORT(RESETFILE)
ELSE
SUPPORT(REWRITEFILE) ;
end;
(* 3 - Removed OPENTTY because of RUNTIM changes *)
LFILEPTR := NEXTFTP ;
END ;
if doinitTTY
then support(opentty);
macro3(200b%move\,tac,74b); %get .jbddt\
macro3(602b%trne\,tac,777777b); %if zero RH\
macro3(603b%tlne\,tac,777777b); %or non-0 LH\
macro3r(254b%jrst\,0,mainstart); %isn't PASDDT\
macro4(260b%pushj\,topp,tac,-2); %init pt. is start-2\
MACRO3R(254B%JRST\,0,MAINSTART);
END;
END;
CODEEND := IC;
LKSP:= FIRSTKONST;
WHILE LKSP # NIL DO
WITH LKSP^,CONSTPTR^ DO
BEGIN
KADDR:= IC;
CASE CCLASS OF
INT,
REEL: IC := IC + 1 ;
PSET: IC := IC + 2 ;
STRD,
STRG: IC := IC + (SLGTH+4) DIV 5
END ;
%CASE\
LKSP := NEXTKONST
END %WITH , WHILE\;
IF DEBUGSWITCH
THEN
BEGIN
IF (LEVEL > 1) AND ( DISPLAY[TOP].FNAME # NIL )
THEN INSERTADDR(RIGHT,IDTREE,IC)
END
ELSE
IF LEVEL = 1
THEN HIGHESTCODE := IC
END%LEAVEBODY\;
PROCEDURE FETCHBASIS(VAR FATTR: ATTR);
VAR
P,Q: INTEGER;
BEGIN
WITH FATTR DO
IF VLEVEL>1
THEN
BEGIN
P := LEVEL - VLEVEL;
IF P=0
THEN
IF INDEXR=0
THEN INDEXR := BASIS
ELSE MACRO3(270B%ADD\,INDEXR,BASIS)
ELSE
BEGIN
MACRO4(540B%HRR\,TAC,BASIS,-1);
FOR Q := P DOWNTO 2 DO
MACRO4(540B%HRR\,TAC,TAC,-1);
IF INDEXR=0
THEN INDEXR := TAC
ELSE MACRO3(270B%ADD\,INDEXR,TAC)
END;
VLEVEL:=1 %DA IN WITHSTATEMENT DIE MOEGLICHKEIT BESTEHT,
DASS ES 2-MAL DURCH FETCHBASIS LAEUFT\
END
END;
%FETCHBASIS\
PROCEDURE GETPARADDR;
BEGIN
FETCHBASIS(GATTR);
WITH GATTR DO
BEGIN
INCREMENTREGC;
MACRO5(VRELBYTE,200B%MOVE\,REGC,INDEXR,DPLMT);
INDEXR := REGC; VRELBYTE:= NO;
INDBIT := 0; VLEVEL := 1; DPLMT := 0;
END
END;
{Warning to future modifiers: At the end of EXPRESSION, there is code that
second-guesses the register allocation in this procedure. If you change
the register allocation here, please look at that code.}
PROCEDURE MAKECODE(FINSTR: INSTRANGE; FAC: ACRANGE; VAR FATTR: ATTR);
VAR
LINSTR: INSTRANGE; LREGC: ACRANGE;
BEGIN
WITH FATTR DO
IF TYPTR#NIL
THEN
BEGIN
CASE KIND OF
CST:
IF TYPTR=REALPTR
THEN
BEGIN
MACRO3(FINSTR,FAC,0); DEPCST(REEL,FATTR)
END
ELSE
IF TYPTR^.FORM=SCALAR
THEN
WITH CVAL DO
IF ((IVAL >= 0) AND (IVAL <= MAXADDR))
OR
(* 50 - correct code for 400000,,0 *)
((ABS(IVAL) <= HWCSTMAX+1) AND (IVAL # 400000000000B)
AND
((FINSTR = 200B%MOVE\) OR (IVAL >= 0)))
THEN
BEGIN
IF FINSTR=200B%MOVE\
THEN
IF IVAL < 0
THEN FINSTR := 571B%HRREI\
ELSE FINSTR := 551B%HRRZI\
ELSE
IF (FINSTR>=311B) AND (FINSTR <= 317B)
THEN FINSTR := FINSTR - 10B %E.G. CAML --> CAIL\
ELSE FINSTR := FINSTR+1;
MACRO3(FINSTR,FAC,IVAL);
END
ELSE
BEGIN
MACRO3(FINSTR,FAC,0); DEPCST(INT,FATTR)
END
ELSE
IF TYPTR=NILPTR
THEN
BEGIN
IF FINSTR=200B%MOVE\
THEN FINSTR := 571B%HRREI\
ELSE
IF (FINSTR>=311B) AND (FINSTR<=317B)
THEN FINSTR := FINSTR-10B
ELSE FINSTR := FINSTR+1;
MACRO3(FINSTR,FAC,377777B);
END
ELSE
IF TYPTR^.FORM=POWER
THEN
BEGIN
MACRO3(FINSTR,FAC,0); MACRO3(FINSTR,FAC-1,0); DEPCST(PSET,FATTR);
END
ELSE
IF TYPTR^.FORM=ARRAYS
THEN
IF TYPTR^.SIZE = 1
THEN
BEGIN
MACRO3(FINSTR,FAC,0); DEPCST(STRG,FATTR)
END
ELSE
IF TYPTR^.SIZE = 2
THEN
BEGIN
FATTR.CVAL.VALP^.CCLASS := STRD;
MACRO3(FINSTR,FAC,0); MACRO3(FINSTR,FAC-1,0); DEPCST(STRD,FATTR);
END;
VARBL:
BEGIN
FETCHBASIS(FATTR); LREGC := FAC;
IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND ((PACKFG#NOTPACK) OR (FINSTR=200B%MOVE\))
THEN
IF (TYPTR^.SIZE = 2) AND LOADNOPTR
THEN LREGC := INDEXR+1
ELSE LREGC := INDEXR
ELSE
IF (PACKFG#NOTPACK) AND (FINSTR#200B%MOVE\)
THEN
BEGIN
INCREMENTREGC; LREGC := REGC
END;
CASE PACKFG OF
NOTPACK:
BEGIN
IF (TYPTR^.SIZE = 2) AND LOADNOPTR
THEN
(* 141 - protect against obscure case where INDEXR = LREGC *)
IF LREGC <> INDEXR
THEN BEGIN
MACRO5(VRELBYTE,FINSTR,LREGC,INDEXR,DPLMT+1);
MACRO5(VRELBYTE,FINSTR,LREGC-1,INDEXR,DPLMT)
END
ELSE BEGIN
MACRO5(VRELBYTE,FINSTR,LREGC-1,INDEXR,DPLMT);
MACRO5(VRELBYTE,FINSTR,LREGC,INDEXR,DPLMT+1)
END
ELSE MACRO(VRELBYTE,FINSTR,LREGC,INDBIT,INDEXR,DPLMT);
END;
PACKK:
BEGIN
MACRO5(VRELBYTE,201B%MOVEI\,TAC,INDEXR,DPLMT);
IF (BPADDR>REGIN) AND (BPADDR<=REGCMAX)
THEN
IF (INDEXR<=REGIN) OR (BPADDR<INDEXR)
THEN LREGC := BPADDR
ELSE LREGC := INDEXR;
MACRO3R(135B%LDB\,LREGC,BPADDR);
END;
HWORDL: MACRO5(VRELBYTE,554B%HLRZ\,LREGC,INDEXR,DPLMT);
HWORDR: MACRO5(VRELBYTE,550B%HRRZ\,LREGC,INDEXR,DPLMT)
END %CASE\;
IF (FINSTR#200B%MOVE\) AND (PACKFG#NOTPACK)
THEN
MACRO3(FINSTR,FAC,LREGC)
ELSE FAC := LREGC
END;
EXPR:
IF FINSTR#200B%MOVE\
THEN
IF TYPTR^.SIZE = 2
THEN
BEGIN
MACRO3(FINSTR,FAC,REG); MACRO3(FINSTR,FAC-1,REG-1)
END
ELSE MACRO3(FINSTR,FAC,REG)
END %CASE\;
KIND := EXPR; REG := FAC;
END;
END;
PROCEDURE LOAD(VAR FATTR: ATTR);
BEGIN
WITH FATTR DO
IF TYPTR#NIL
THEN
IF KIND#EXPR
THEN
BEGIN
INCREMENTREGC ;
IF (TYPTR^.SIZE = 2) AND LOADNOPTR
THEN INCREMENTREGC ;
MAKECODE(200B%MOVE\,REGC,FATTR);REGC := REG
END;
END;
%LOAD\
(* 104 - common procedure for improved range check on subranges *)
procedure loadsubrange(var gattr:attr;lsp:stp);
var slattr:attr; srmin,srmax:integer;
begin
GETBOUNDS(LSP,SRMIN,SRMAX);
IF (GATTR.KIND=CST)
THEN
IF (GATTR.CVAL.IVAL >= SRMIN) AND (GATTR.CVAL.IVAL <=SRMAX)
THEN LOAD (GATTR)
ELSE ERROR (367)
ELSE
BEGIN
IF RUNTMCHECK AND (( GATTR.KIND#VARBL) OR (GATTR.SUBKIND # LSP))
THEN
BEGIN
LOAD (GATTR);
WITH SLATTR DO
BEGIN
TYPTR:=INTPTR;
KIND :=CST;
CVAL.IVAL:=SRMAX
END;
MAKECODE(317B%CAMG\,REGC,SLATTR);
SLATTR.KIND:=CST;
SLATTR.CVAL.IVAL:=SRMIN;
MAKECODE(315B%CAMGE\,REGC,SLATTR);
SUPPORT(ERRORINASSIGNMENT)
END
ELSE LOAD (GATTR);
END
end;
PROCEDURE STORE(FAC: ACRANGE; VAR FATTR: ATTR);
VAR
LATTR: ATTR;
BEGIN
LATTR := FATTR;
WITH LATTR DO
IF TYPTR # NIL
THEN
BEGIN
FETCHBASIS(LATTR);
CASE PACKFG OF
NOTPACK:
BEGIN
IF TYPTR^.SIZE = 2
THEN
BEGIN
MACRO5(VRELBYTE,202B%MOVEM\,FAC,INDEXR,DPLMT+1); FAC := FAC-1
END;
MACRO(VRELBYTE,202B%MOVEM\,FAC,INDBIT,INDEXR,DPLMT)
END;
PACKK:
BEGIN
MACRO5(VRELBYTE,201B%MOVEI\,TAC,INDEXR,DPLMT);
MACRO3R(137B%DPB\,FAC,BPADDR);
END;
HWORDL: MACRO5(VRELBYTE,506B%HRLM\,FAC,INDEXR,DPLMT);
HWORDR: MACRO5(VRELBYTE,542B%HRRM\,FAC,INDEXR,DPLMT)
END %CASE\ ;
END %WITH\ ;
END %STORE\ ;
{Warning to future modifiers: At the end of EXPRESSION, there is code that
second-guesses the register allocation in this procedure. If you change
the register allocation here, please look at that code.}
PROCEDURE LOADADDRESS;
BEGIN
INCREMENTREGC ;
BEGIN
WITH GATTR DO
IF TYPTR # NIL
THEN
BEGIN
CASE KIND OF
CST:
IF STRING(TYPTR)
THEN
BEGIN
MACRO3(201B%MOVEI\,REGC,0);
DEPCST(STRG,GATTR)
END
ELSE ERROR(171);
VARBL:
BEGIN
IF (INDEXR>REGIN) AND (INDEXR <= REGCMAX)
THEN REGC := INDEXR;
FETCHBASIS(GATTR);
CASE PACKFG OF
NOTPACK: MACRO(VRELBYTE,201B%MOVEI\,REGC,INDBIT,INDEXR,DPLMT);
PACKK,HWORDL,HWORDR: ERROR(357)
END;
END;
EXPR: ERROR(171)
END;
KIND := VARBL; DPLMT := 0; INDEXR:=REGC; INDBIT:=0; VRELBYTE := NO
END
END
END %LOADADDRESS\ ;
PROCEDURE WRITEMC(WRITEFLAG:WRITEFORM);
CONST
(* 155 *)
MAXSIZE %OF CONSTANT-, STRUCTURE-, AND ID.-RECORD\ = 44 %WORDS\ ;
TYPE
WANDELFORM=(KONSTANTE,PDP10CODE,REALCST,STRCST,SIXBITCST,HALFWD,PDP10BP,RADIX) ;
RECORDFORM=(NONE,CONSTNTREC,STRUCTUREREC,IDENTIFREC,DEBUGREC);
BIGALFA = PACKED ARRAY[1..15] OF CHAR ;
VAR
I,J,L : INTEGER; LLISTCODE: BOOLEAN; CHECKER: CTP;
LIC : ADDRRANGE; LFIRSTKONST: KSP; LRELBYTE: RELBYTE;
STRING: ARRAY[1..6] OF CHAR; LFILEPTR: FTP; SWITCHFLAG: FLAGRANGE;
FILBLOCKADR : ADDRRANGE ; CODEARRAY: BOOLEAN; LICMOD4: ADDRRANGE;
LSIZE: 1..MAXSIZE; RUN1: BOOLEAN; SAVELISTCODE: BOOLEAN;
CSP0: CSP; %INSTEAD OF NIL\
RELARRAY, RELEMPTY: ARRAY[1..MAXSIZE] OF RELBYTE;
WANDLUNG : PACKED RECORD
CASE WANDELFORM OF
KONSTANTE:(WKONST :INTEGER);
PDP10CODE:(WINSTR :PDP10INSTR);
REALCST :(WREAL: REAL);
STRCST :(WSTRING:CHARWORD);
SIXBITCST:(WSIXBIT:PACKED ARRAY[1..6] OF 0..77B);
HALFWD :(WLEFTHALF:ADDRRANGE ; WRIGHTHALF : ADDRRANGE);
PDP10BP :(WBYTE: BPOINTER);
RADIX :(FLAG: FLAGRANGE; SYMBOL: RADIXRANGE)
END;
ICWANDEL: PACKED RECORD
CASE VARIANTE:INTEGER OF
1:(ICVAL: ADDRRANGE);
2:(ICCSP: CSP);
3:(ICCTP: CTP);
4:(ICSTP: STP)
END;
RECORDWANDEL: PACKED RECORD
CASE RECORDFORM OF
NONE: (WORD:ARRAY[1..MAXSIZE] OF INTEGER);
CONSTNTREC:(CONSTREC: CONSTNT);
STRUCTUREREC:(STRUCTREC: STRUCTURE);
IDENTIFREC:(IDENTREC: IDENTIFIER);
DEBUGREC:(DEBUGREC: DEBENTRY)
END;
PROCEDURE NEUEZEILE;
BEGIN
(* 6 - if CREFing, less stuff fits on a line *)
IF CREF
THEN LICMOD4 := LIC MOD 3
ELSE LICMOD4 := LIC MOD 4;
IF (LICMOD4 = 0) AND LISTCODE AND (LIC > 0)
THEN
BEGIN
(* 136 - LISTING FORMAT *)
newline ;
IF RELBLOCK.ITEM = 1
THEN
BEGIN
WRITE(LIC:6:O);
IF LIC >= PROGRST
THEN WRITE('''')
ELSE WRITE(' ')
END
ELSE WRITE(' ':7)
END
END %NEUEZEILE\ ;
PROCEDURE PUTRELCODE;
VAR
I: INTEGER;
BEGIN
WITH RELBLOCK DO
(* 146 - Move count := 0 outside the test, since we must zero count in
the case where COUNT = 1 and ITEM = 1. *)
BEGIN
IF ((COUNT > 1) OR (ITEM # 1)) AND (COUNT > 0)
THEN
BEGIN
FOR I:= COUNT+1 TO 18 DO RELOCATOR[I-1] := NO;
FOR I:= 1 TO COUNT+2 DO
BEGIN
OUTPUTREL^:= COMPONENT[I];
PUT(OUTPUTREL)
END;
END;
(* 146 *)
COUNT := 0;
END;
END;
PROCEDURE SHOWRELOCATION(FSIDE: RELBYTE; FRELBYTE: RELBYTE);
BEGIN
IF (FRELBYTE = FSIDE) OR (FRELBYTE = BOTH)
THEN WRITE('''')
ELSE WRITE(' ')
END;
PROCEDURE WRITEBLOCKST( FITEM: ADDRRANGE);
VAR
WANDLUNG: PACKED RECORD
CASE BOOLEAN OF
TRUE: (WKONST: INTEGER);
FALSE: (WLEFTHALF: ADDRRANGE;WRIGHTHALF: ADDRRANGE)
END;
BEGIN
WITH RELBLOCK , WANDLUNG DO
BEGIN
IF COUNT # 0
THEN PUTRELCODE;
ITEM:= FITEM;
IF ITEM = 1
THEN
BEGIN
WLEFTHALF:= 0;
WRIGHTHALF:= LIC;
CODE[0]:= WKONST;
IF WRIGHTHALF < PROGRST
THEN RELOCATOR[0] := NO
ELSE RELOCATOR[0] := RIGHT;
COUNT:= 1
END
END
END;
PROCEDURE WRITEWORD(FRELBYTE: RELBYTE; FWORD: INTEGER);
VAR
WANDLUNG: PACKED RECORD
CASE BOOLEAN OF
TRUE: (WKONST: INTEGER);
FALSE: (WLEFTHALF: ADDRRANGE; WRIGHTHALF: ADDRRANGE)
END;
BEGIN
WITH WANDLUNG DO
BEGIN
WKONST := FWORD;
WITH RELBLOCK DO
BEGIN
IF COUNT = 0
THEN WRITEBLOCKST(ITEM);
CODE[COUNT]:= FWORD;
IF FRELBYTE IN [LEFT,BOTH]
THEN
IF (WLEFTHALF < PROGRST) OR (WLEFTHALF = 377777B)
THEN FRELBYTE := FRELBYTE - LEFT;
IF FRELBYTE IN [RIGHT,BOTH]
THEN
IF (WRIGHTHALF < PROGRST) OR (WRIGHTHALF = 377777B)
THEN FRELBYTE := FRELBYTE - RIGHT;
RELOCATOR[COUNT]:= FRELBYTE; LRELBYTE := FRELBYTE;
COUNT := COUNT+1;
IF COUNT = 18
THEN PUTRELCODE
END;
IF LLISTCODE
THEN
BEGIN
NEUEZEILE;
IF LIC > 0
THEN WRITE(' ':13);
(* 173 - remove writefileblocks *)
IF WRITEFLAG > WRITELIBRARY
THEN WRITE(' ':7)
ELSE
BEGIN
WRITE(WLEFTHALF:6:O); SHOWRELOCATION(LEFT,FRELBYTE)
END;
WRITE(WRIGHTHALF:6:O); SHOWRELOCATION(RIGHT,FRELBYTE); WRITE(' ':3)
END;
IF NOT CODEARRAY
THEN LIC := LIC + 1
END
END;
FUNCTION RADIX50( FNAME: ALFA): RADIXRANGE;
VAR
I: INTEGER; OCTALCODE, RADIXVALUE: RADIXRANGE;
BEGIN
RADIXVALUE:= 0;
I:=1;
WHILE (FNAME[I] # ' ') AND (I <= 6) DO
BEGIN
IF FNAME[I] IN DIGITS
THEN OCTALCODE:= ORD(FNAME[I])-ORD('0')+1
ELSE
IF FNAME[I] IN LETTERS
THEN OCTALCODE:= ORD(FNAME[I])-ORD('A')+11
ELSE
CASE FNAME[I] OF
'.': OCTALCODE:= 37;
'$': OCTALCODE:= 38;
'%': OCTALCODE:= 39
END;
RADIXVALUE:= RADIXVALUE*50B; RADIXVALUE:= RADIXVALUE+OCTALCODE; I:=I+1
END;
RADIX50:= RADIXVALUE
END;
PROCEDURE WRITEPAIR( FRELBYTE: RELBYTE; FADDR1, FADDR2: ADDRRANGE);
BEGIN
WITH WANDLUNG DO
BEGIN
WLEFTHALF:= FADDR1;
WRIGHTHALF:= FADDR2;
WRITEWORD(FRELBYTE,WKONST)
END
END;
PROCEDURE WRITEIDENTIFIER( FFLAG: FLAGRANGE; FSYMBOL: ALFA);
BEGIN
LLISTCODE := FALSE;
WITH WANDLUNG DO
BEGIN
IF LISTCODE AND (WRITEFLAG > WRITEHISEG)
THEN
BEGIN
(* 40 - if CREFing, less stuff fits on a line *)
IF ((NOT CREF) AND (LIC MOD 4 = 0) OR
CREF AND (LIC MOD 3 = 0)) AND (LIC > 0)
THEN
BEGIN
(* 136 - LISTING FORMAT *)
NEWLINE;
WRITE(' ':7)
END;
IF LIC > 0
THEN WRITE(' ':13); WRITE(FSYMBOL:6,' ':11)
END;
(* 40 - print format *)
if listcode and cref then lic := lic+1;
IF FFLAG # 6B
THEN
BEGIN
FLAG:= FFLAG; SYMBOL:= RADIX50(FSYMBOL)
END;
WRITEWORD(NO,WKONST); LLISTCODE := LISTCODE
END
END;
PROCEDURE WRITEFIRSTLINE ;
BEGIN
IF LISTCODE
THEN
BEGIN
(* 136 - LISTING FORMAT *)
NEWLINE;
(* 6 - if CREFing, less stuff fits on a line *)
IF CREF
THEN LICMOD4 := LIC MOD 3
ELSE LICMOD4 := LIC MOD 4;
IF LICMOD4 > 0
THEN
BEGIN
WRITE(LIC-LICMOD4:6:O);
IF LIC >= PROGRST
THEN WRITE('''')
ELSE WRITE(' ');
WRITE(' ':LICMOD4*30);
IF (WRITEFLAG = WRITECODE) AND CODEARRAY
THEN WRITE(' ':2)
END
END
END ;
PROCEDURE WRITEHEADER(FTEXT: BIGALFA);
BEGIN
LIC := 0;
IF LISTCODE
THEN
BEGIN
(* 136 - LISTING FORMAT *)
NEWLINE;
WRITE(FTEXT:15,':',' ':4)
END
END;
(*173 - remove writefileblocks *)
PROCEDURE MCGLOBALS;
BEGIN
%MCGLOBALS\
IF LISTCODE AND (FGLOBPTR # NIL)
THEN WRITEBUFFER;
WHILE FGLOBPTR # NIL DO
WITH FGLOBPTR^ DO
BEGIN
LIC := FIRSTGLOB ; WRITEFIRSTLINE ;
J := FCIX ;
WRITEBLOCKST(1);
FOR I := FIRSTGLOB TO LASTGLOB DO
BEGIN
WANDLUNG.WINSTR := CODE.INSTRUCTION[J] ; J := J + 1 ;
WRITEWORD(NO,WANDLUNG.WKONST) ;
END ;
FGLOBPTR := NEXTGLOBPTR
END;
END %MCGLOBALS\;
PROCEDURE MCCODE;
PROCEDURE WRITERECORD;
BEGIN
FOR I := 1 TO LSIZE DO WRITEWORD(RELARRAY[I], RECORDWANDEL.WORD[I] )
END;
(* 211 - MAKE CONSTANTS WORK IN THE DEBUGGER *)
FUNCTION CONSTRECSIZE(FCSP: CSP): INTEGER;
BEGIN
WITH FCSP^ DO
CASE CCLASS OF
INT,PSET: CONSTRECSIZE := 5;
REEL : CONSTRECSIZE := 4;
STRD,STRG:CONSTRECSIZE := 4 + (SLGTH+4) DIV 5
END
END;
PROCEDURE COPYCSP(FCSP:CSP);
BEGIN
IF FCSP # NIL
THEN WITH FCSP^ DO
IF RUN1
THEN
BEGIN
IF SELFCSP = CSP0%NIL\
THEN WITH ICWANDEL DO
BEGIN
ICVAL := IC; SELFCSP := ICCSP;
NOCODE := TRUE;
IC := IC + CONSTRECSIZE(FCSP)
END
END
ELSE
IF NOCODE
THEN
BEGIN
RECORDWANDEL.CONSTREC := FCSP^;
LSIZE := CONSTRECSIZE(FCSP);
RELARRAY := RELEMPTY;
WRITERECORD; NOCODE := FALSE
END
END %COPYCSP\;
PROCEDURE COPYSTP(FSP:STP); FORWARD;
PROCEDURE COPYCTP(FCP:CTP);
BEGIN
IF FCP # NIL
THEN WITH FCP^ DO
IF RUN1 AND (SELFCTP=NIL) OR NOT RUN1 AND NOCODE
THEN
BEGIN
IF RUN1
THEN
WITH ICWANDEL DO
BEGIN
ICVAL := IC;
SELFCTP := ICCTP; NOCODE := TRUE;
IC := IC + IDRECSIZE[KLASS]
END %WITH\
ELSE %NOW RUN 2\
WITH RECORDWANDEL DO
BEGIN
RELARRAY := RELEMPTY;
IDENTREC := FCP^;
WITH IDENTREC DO
BEGIN
IF LLINK#NIL
THEN
BEGIN
LLINK:=LLINK^.SELFCTP; RELARRAY[3] := 1
END;
IF RLINK#NIL
THEN
BEGIN
RLINK:=RLINK^.SELFCTP; RELARRAY[3] := RELARRAY[3] + 2
END;
IF NEXT #NIL
THEN
BEGIN
NEXT := NEXT^.SELFCTP; RELARRAY[4] := 1B
END;
IF IDTYPE # NIL
THEN
BEGIN
IF KLASS = KONST
THEN
IF IDTYPE^.FORM > POINTER
THEN
(* 211 - FIX CONSTANT PRINTING *)
BEGIN
VALUES.VALP := VALUES.VALP^.SELFCSP;
RELARRAY[6] := 1B
END
ELSE
IF IDTYPE = REALPTR
THEN
BEGIN
WANDLUNG.WREAL := VALUES.VALP^.RVAL;
VALUES.IVAL := WANDLUNG.WKONST
END;
IF KLASS=VARS
THEN
IF VLEV<2
THEN RELARRAY[6] := 2;
IF KLASS = FIELD
THEN
IF PACKF = PACKK
THEN RELARRAY[6] := 2;
IDTYPE:=IDTYPE^.SELFSTP; RELARRAY[4] := RELARRAY[4] + 2
END
END;
LSIZE := IDRECSIZE[KLASS]; WRITERECORD;
NOCODE := FALSE
END %WITH RECORDWANDEL\;
COPYCTP(LLINK);
COPYCTP(RLINK);
COPYSTP(IDTYPE);
(* 214 - fix debugger problem with foward declared proc's *)
{The following is somewhat of a kludge. We don't want to do COPYCTP
on the NEXT field of a procedure. If we did, the following could
happen:
procedure foo(x:integer); forward;
...
foo(1);
...
procedure foo;
var i,j;
When the final declaration of FOO is supplied, the symbol table is
initialized from symboltable(FOO)^.NEXT, which contains the parameters,
as supplied in the forward decl. Then I and J are added to the symbol
table. The result is that X points to I and J in the symbol table
tree. This is all fine. The problem comes when the identifier
record for FOO is put into the .REL file before the final declaration.
If COPYCTP traces the NEXT field, then the identifier records for all
the parameters are also put out. Since a given identifier is put out
only once, this means that X is put into the .REL file before pointers
to I and J are added to it. The effect is that the debugger can't
see I and J.
It turns out that the debugger never uses the NEXT field of a
procedure entry. Thus it is not crucial to have a correctly mapped
value when the identifier record for the procedure is put out.
If we don't call COPYCTP on NEXT, then the NEXT field put into the
.REL file will be junk, but at least records for the parameters won't
be put out prematurely. They will get put out eventually even without
tracing NEXT, since they will show up in the symbol table for the
procedure when it is finally declared. That should suffice.}
IF NOT (KLASS IN [PROC,FUNC])
THEN COPYCTP(NEXT);
IF (KLASS = KONST) AND (IDTYPE # NIL)
THEN
IF IDTYPE^.FORM > POINTER
THEN COPYCSP(VALUES.VALP)
END %WITH FCP^\
END %COPYCTP\;
PROCEDURE COPYSTP;
BEGIN
IF FSP # NIL
THEN WITH FSP^ DO
IF RUN1 AND (SELFSTP = NIL) OR NOT RUN1 AND NOCODE
THEN
BEGIN
IF RUN1
THEN
WITH ICWANDEL DO
BEGIN
NOCODE:=TRUE;
ICVAL := IC; SELFSTP := ICSTP;
IC := IC + STRECSIZE[FORM]
END
ELSE %NOW RUN 2\
IF NOCODE
THEN WITH RECORDWANDEL DO
BEGIN
RELARRAY := RELEMPTY; RELARRAY[2] := 1;
STRUCTREC := FSP^;
WITH STRUCTREC DO
CASE FORM OF
SCALAR:
IF SCALKIND = DECLARED
THEN
IF FCONST#NIL
THEN FCONST:=FCONST^.SELFCTP;
SUBRANGE:
BEGIN
RANGETYPE:=RANGETYPE^.SELFSTP; RELARRAY[2]:=1
END;
POINTER:
IF ELTYPE # NIL
THEN ELTYPE := ELTYPE^.SELFSTP;
POWER: ELSET := ELSET^.SELFSTP;
ARRAYS:
BEGIN
(* 122 - DON'T FOLLOW NILS ON FUDGED TYPES *)
IF AELTYPE#NIL
THEN AELTYPE := AELTYPE^.SELFSTP;
IF INXTYPE#NIL
THEN INXTYPE := INXTYPE^.SELFSTP;
RELARRAY[3] := 3
END;
RECORDS:
BEGIN
IF FSTFLD # NIL
THEN FSTFLD := FSTFLD^.SELFCTP;
IF RECVAR # NIL
THEN
BEGIN
RECVAR := RECVAR^.SELFSTP; RELARRAY[3] := 2
END
END;
FILES: IF FILTYPE # NIL
THEN FILTYPE := FILTYPE^.SELFSTP;
TAGFWITHID,
TAGFWITHOUTID:
BEGIN
FSTVAR := FSTVAR^.SELFSTP;
IF FORM = TAGFWITHID
THEN TAGFIELDP := TAGFIELDP^.SELFCTP
ELSE TAGFIELDTYPE := TAGFIELDTYPE^.SELFSTP;
RELARRAY[3] := 2
END;
VARIANT:
BEGIN
IF SUBVAR # NIL
THEN SUBVAR := SUBVAR^.SELFSTP;
IF FIRSTFIELD # NIL
THEN
BEGIN
FIRSTFIELD := FIRSTFIELD^.SELFCTP; RELARRAY[3]:=1
END;
IF NXTVAR # NIL
THEN
BEGIN
NXTVAR := NXTVAR^.SELFSTP; RELARRAY[3] :=RELARRAY[3] + 2
END;
END
END %CASE\;
LSIZE := STRECSIZE[FORM]; WRITERECORD;
NOCODE := FALSE
END %RUN 2\;
CASE FORM OF
SCALAR:
IF SCALKIND = DECLARED
THEN COPYCTP(FCONST);
SUBRANGE:COPYSTP(RANGETYPE);
POINTER: COPYSTP(ELTYPE);
POWER: COPYSTP(ELSET);
ARRAYS:
BEGIN
COPYSTP(AELTYPE);
COPYSTP(INXTYPE)
END;
RECORDS:
BEGIN
COPYCTP(FSTFLD);
COPYSTP(RECVAR)
END;
FILES: COPYSTP(FILTYPE);
TAGFWITHID,
TAGFWITHOUTID:
BEGIN
COPYSTP(FSTVAR);
IF FORM = TAGFWITHID
THEN COPYCTP(TAGFIELDP)
ELSE COPYSTP(TAGFIELDTYPE)
END;
VARIANT:
BEGIN
COPYSTP(NXTVAR);
COPYSTP(SUBVAR);
COPYCTP(FIRSTFIELD)
END
END %CASE\
END %WITH\
END %COPYSTP\;
BEGIN
%MCCODE\
CODEARRAY := FALSE; LLISTCODE:= FALSE;
IF LISTCODE
THEN WRITEBUFFER;
IF LASTBTP # NIL
THEN
WITH LASTBTP^ DO
CASE BKIND OF
RECORDD: LIC := FIELDCP^.FLDADDR ;
ARRAYY : LIC := ARRAYSP^.ARRAYBPADDR
END ;
WRITEFIRSTLINE ; WRITEBLOCKST(1);
WHILE LASTBTP # NIL DO
BEGIN
WITH LASTBTP^,BYTE DO
BEGIN
IF LISTCODE
THEN
BEGIN
NEUEZEILE;
IF LICMOD4 = 0
THEN WRITE(' ':7)
ELSE WRITE(' ':5);
WRITE(' POINT ',SBITS:2,',') ;
IF IBIT = 0
THEN WRITE(' ')
ELSE WRITE(' @') ;
WRITE(RELADDR:5:O,'(',IREG:2:O,'),',35-PBITS:2) ;
END;
WITH WANDLUNG DO
BEGIN
WBYTE := BYTE;
WRITEWORD(NO,WKONST)
END;
LASTBTP := LAST
END
END % WHILE\ ;
LIC := CODEEND - CIX - 1 ; CODEARRAY := TRUE;
WRITEBLOCKST(1); WRITEFIRSTLINE;
FOR I := 0 TO CIX DO
WITH CODE, INSTRUCTION[I], HALFWORD[I] DO
BEGIN
LRELBYTE := RELOCATION[I]; WRITEWORD(LRELBYTE,WORD[I]);
IF LISTCODE
THEN
BEGIN
NEUEZEILE;
IF LICMOD4 = 0
THEN WRITE(' ':7)
ELSE WRITE(' ':5);
CASE INFORMATION[I] OF
'W':
BEGIN
WRITE(' ':6,LEFTHALF :6:O); SHOWRELOCATION(LEFT,LRELBYTE);
WRITE(RIGHTHALF:6:O); SHOWRELOCATION(RIGHT,LRELBYTE);
WRITE(' ':5)
END;
%'B': WITH WANDLUNG.WBYTE DO
BEGIN
WANDLUNG.WKONST := WORD[I];
WRITE(' POINT ',SBITS:2,',');
IF IBIT = 0 THEN WRITE(' ') ELSE WRITE(' @');
WRITE(RELADDR:5:O,'(',IREG:2:O,'),',35-PBITS:2)
END;\
OTHERS:
BEGIN
(* 6 - UNPACK CAN'T DO THIS NOW *)
%UNPACK(MNEMONICS[(INSTR+9) DIV 10],((INSTR+9) MOD 10)*6+1,STRING,6);\
FOR J := 1 TO 6 DO
STRING[J] := MNEMONICS[(INSTR+9) DIV 10, ((INSTR+9) MOD 10)*6 + J];
WRITE(' ',STRING:6, ' ',AC:2:O,', ');
IF INDBIT = 0
THEN WRITE(' ')
ELSE WRITE('@');
WRITE(ADDRESS:6:O); SHOWRELOCATION(RIGHT,LRELBYTE);
IF INXREG > 0
THEN WRITE('(',INXREG:2:O,')',INFORMATION[I]:1)
ELSE WRITE(' ':4,INFORMATION[I]:1)
END
END
END;
LIC := LIC + 1
END %FOR \ ;
CODEARRAY := FALSE; LLISTCODE := LISTCODE;
IF FIRSTKONST # NIL
THEN
BEGIN
LFIRSTKONST := FIRSTKONST; WRITEFIRSTLINE; WRITEBLOCKST(1);
WHILE LFIRSTKONST # NIL DO
BEGIN
WITH LFIRSTKONST^.CONSTPTR^ DO
CASE CCLASS OF
INT,
REEL: WRITEWORD(NO,INTVAL) ;
PSET:
BEGIN
% THE SET IS PICKED UP
AND WRITTEN OUT AS TWO OCTAL NUMBERS \
WRITEWORD(NO,INTVAL) ;
WRITEWORD(NO,INTVAL1) ;
END ;
STRD,
STRG: WITH WANDLUNG DO
BEGIN
J :=0; WKONST := 0;
FOR I := 1 TO SLGTH DO
BEGIN
J := J+1;
WSTRING[J] := SVAL[I];
IF J=5
THEN
BEGIN
J := 0;
WRITEWORD(NO,WKONST);
WKONST := 0
END
END;
IF J#0
THEN
WRITEWORD(NO,WKONST)
END
END;
LFIRSTKONST := LFIRSTKONST^.NEXTKONST
END %WHILE\
END;
IF DEBUG
THEN
BEGIN
IF DEBUGSWITCH
THEN
BEGIN
(* 103 - globalidtree moved below *)
WRITEFIRSTLINE;
FOR RUN1 := TRUE DOWNTO FALSE DO COPYCTP(DISPLAY[TOP].FNAME);
IF LEVEL = 1
THEN
BEGIN
(* 103 - new way to set globalidtree and standardidtree *)
FOR RUN1 := TRUE DOWNTO FALSE DO COPYCTP(DISPLAY[0].FNAME);
if display[top].fname = nil
then debugentry.globalidtree := nil
else debugentry.globalidtree := display[top].fname^.selfctp;
debugentry.standardidtree := display[0].fname^.selfctp;
END;
END %DEBUGSWITCH\;
IF LEVEL = 1
THEN
BEGIN
WITH DEBUGENTRY DO
BEGIN
NEWPAGER; LASTPAGEELEM := PAGER;
INTPOINT := INTPTR^. SELFSTP;
REALPOINT := REALPTR^.SELFSTP;
CHARPOINT := CHARPTR^.SELFSTP;
(* 36 - ALLOW MULTIPLE MODULES *)
NEXTDEB := 0; %LINK WILL MAKE THIS PTR TO SIMILAR ENTRY IN NEXT MODULE\
MODNAME := FILENAME;
CURNAME(INPUT,SOURCE);
END;
PAGEHEADADR := IC;
LSIZE := 44; %LENGTH OF DEBUGENTRY-RECORD\
RELARRAY[1] := 0;
FOR I:=2 TO 8 DO RELARRAY[I] := 1;
FOR I:= 9 TO LSIZE DO RELARRAY[I] := 0;
RECORDWANDEL.DEBUGREC := DEBUGENTRY;
IC := IC + LSIZE;
WRITERECORD;
HIGHESTCODE := IC;
(* 40 - fix printing format *)
(* 136 - LISTING FORMAT *)
if listcode then NEWLINE;
WRITEHEADER('LINK IN CHAIN 1');
LLISTCODE := FALSE;
WRITEBLOCKST(12B); %LINK BLOCK\
WRITEPAIR(NO,0,1); %LINK NUMBER 1\
LLISTCODE := LISTCODE;
WRITEPAIR(RIGHT,0,PAGEHEADADR); %NEXTDEB FIELD\
(* NB: LOCATION 141/2 ARE NOW HANDLED BY DEBSUP. 143 GETS .LNKEND FOR THE
LINK SET UP ABOVE *)
END;
(* 5 - CREF *)
END;
(* 136 - LISTING FORMAT *)
IF LISTCODE THEN NEWLINE;
END %MCCODE\;
PROCEDURE MCVARIOUS;
VAR
(* 17 - MAKE SYMBOLS ACCEPTABLE TO DEC DDT *)
INLEVEL: BOOLEAN; PNAME:ALFA;
BEGIN
%MCVARIOUS\
CASE WRITEFLAG OF
(* 13 - ADD WRITEBLOCK FOR DDT SYMBOLS *)
(* 16 - MAKE ACCEPTABLE TO DEC DDT *)
WRITEBLK:
BEGIN
PNAME := DISPLAY[TOP].BLKNAME;
(* 40 - fix print format *)
WRITEHEADER('LOCAL SYMBOLS ');
WRITEBLOCKST(2);
WRITEIDENTIFIER(2B,PNAME);
WRITEPAIR(RIGHT,0,PFSTART);
I:=5;
WHILE PNAME[I]=' ' DO I:=I-1;
IF PFDISP#PFSTART
THEN BEGIN
PNAME[I+1]:='.';
WRITEIDENTIFIER(2B,PNAME);
WRITEPAIR(RIGHT,0,PFDISP)
END;
IF PFPOINT#PFDISP
THEN BEGIN
PNAME[I+1]:='%';
WRITEIDENTIFIER(2B,PNAME);
WRITEPAIR(RIGHT,0,PFPOINT)
END
END;
(* 164 - add Polish fixups *)
WRITEPOLISH:
BEGIN
WRITEHEADER('POLISH FIXUPS ');
WHILE FIRSTPOL <> NIL DO
WITH FIRSTPOL^ DO
BEGIN
{A Polish fixup block looks like this:
type 11
operator,,0 0 means next half word is operand
operand1,,0
operand2,,-1 -1 means put in RH of result addr
place to put result,,0
}
WRITEBLOCKST(11B);
IF OFFSET < 0
THEN WRITEPAIR(NO,4,0) {4 - SUB}
ELSE WRITEPAIR(NO,3,0); {3 - ADD}
WRITEPAIR(LEFT,BASE,0);
WRITEPAIR(NO,ABS(OFFSET),777777B);
WRITEPAIR(LEFT,WHERE,0);
PUTRELCODE;
FIRSTPOL := NEXTPOL; {CDR down list}
END;
if cref and listcode then NEWLINE;
END;
WRITEINTERNALS:
BEGIN
WRITEHEADER('LOCAL REQUESTS '); INLEVEL := TRUE;
WRITEBLOCKST(8); CHECKER := LOCALPFPTR;
WHILE (CHECKER # NIL) AND INLEVEL DO
WITH CHECKER^ DO
IF PFLEV = LEVEL
THEN
BEGIN
IF PFADDR # 0
THEN
FOR I := 0 TO MAXLEVEL DO
IF LINKCHAIN[I] # 0
THEN WRITEPAIR(BOTH,LINKCHAIN[I],PFADDR-I);
CHECKER:= PFCHAIN
END
ELSE INLEVEL := FALSE;
IF LEVEL > 1
THEN LOCALPFPTR := CHECKER;
WHILE FIRSTKONST # NIL DO
WITH FIRSTKONST^, CONSTPTR^ DO
BEGIN
WRITEPAIR(BOTH,ADDR,KADDR);
(* 72 - two fixup chains for 2 word consts *)
IF (CCLASS IN [PSET,STRD]) AND (ADDR1 <> 0)
THEN WRITEPAIR(BOTH,ADDR1,KADDR+1);
FIRSTKONST:= NEXTKONST
END;
(* 64 - non-local gotos *)
inlevel := true;
while (lastlabel # nil) and inlevel do
with lastlabel^ do
if scope = level
then begin
if gotochain # 0
then if labeladdress = 0
then errorwithtext(215,name)
else writepair(both,gotochain,labeladdress);
lastlabel := next
end
else inlevel := false;
(* 40 - print format *)
(* 136 - LISTING FORMAT *)
if cref and listcode then NEWLINE;
END;
WRITEEND:
BEGIN
WRITEHEADER('HIGHSEG-BREAK ');
WRITEBLOCKST(5);
WRITEPAIR(RIGHT,0,HIGHESTCODE);
WRITEHEADER('LOWSEG-BREAK ');
WRITEPAIR(RIGHT,0,LCMAIN); PUTRELCODE
END;
WRITESTART:
IF MAIN
THEN
BEGIN
(* 33 - VERSION NO. *)
WRITEHEADER('VERSION NUMBER ');
LIC := 137B;
(* 40 - fix print format *)
WRITEBLOCKST(1);
if listcode then with version do
write(' ',who:1:o,' ',major:3:o,' ',minor:2:o,' ',edit:6:o);
llistcode := false;
WRITEWORD(NO,VERSION.WORD);
llistcode := listcode;
WRITEHEADER('STARTADDRESS ');
WRITEBLOCKST(7);
WRITEPAIR(RIGHT,0,STARTADDR)
END;
WRITEENTRY:
BEGIN
WRITEBLOCKST(4);
(* 34 - USE LIST OF ENTRIES IN PROGRAM IF APPROPRIATE *)
IF MAIN OR (FPROGFILE = NIL)
THEN WRITEIDENTIFIER(0,FILENAME)
ELSE
BEGIN
NPROGFILE := FPROGFILE;
WHILE NPROGFILE # NIL DO
BEGIN
WRITEIDENTIFIER(0,NPROGFILE^.FILID);
NPROGFILE := NPROGFILE^.NEXT
END
END
END;
WRITENAME:
BEGIN
WRITEBLOCKST(6);
WRITEIDENTIFIER(0,FILENAME)
END;
WRITEHISEG:
BEGIN
LLISTCODE := FALSE;
WRITEBLOCKST(3);
WRITEPAIR(NO,400000B,400000B);
END
END %CASE\
END %MCVARIOUS\ ;
PROCEDURE MCSYMBOLS;
VAR
ENTRYFOUND: BOOLEAN; POLHEADERDONE:Boolean; chan:integer;
BEGIN
%MCSYMBOLS\
WRITEHEADER('ENTRYPOINT(S) ');
WRITEBLOCKST(2);
SAVELISTCODE := LISTCODE;
LISTCODE := FALSE;
FOR SWITCHFLAG := 1B TO 2B DO
BEGIN
IF MAIN
THEN
BEGIN
WRITEIDENTIFIER(SWITCHFLAG,FILENAME);
WRITEPAIR(RIGHT,0,STARTADDR)
END
ELSE
BEGIN
(* 34 - LOOK FOR FTN=FILENAME ONLY IF NOT SPEC. IN PROGRAM STATE. *)
CHECKER := LOCALPFPTR;
IF FPROGFILE=NIL
THEN ENTRYFOUND := FALSE
ELSE ENTRYFOUND := TRUE;
WHILE CHECKER # NIL DO
WITH CHECKER^ DO
BEGIN
IF PFADDR # 0
THEN
BEGIN
IF NOT ENTRYFOUND
(* 34 - USING FILENAME FOR ENTRY NOW *)
THEN ENTRYFOUND := FILENAME = NAME;
WRITEIDENTIFIER(SWITCHFLAG,NAME);
WRITEPAIR(RIGHT,0,PFADDR);
IF PFCHAIN = NIL
THEN
IF NOT ENTRYFOUND
THEN
BEGIN
(* 34 - USING FILENAME FOR ENTRY NOW *)
WRITEIDENTIFIER(SWITCHFLAG,FILENAME);
WRITEPAIR(RIGHT,0,PFADDR)
END
END;
CHECKER:= PFCHAIN
END
END;
LISTCODE := SAVELISTCODE; LIC := 0
END;
IF MAIN
THEN
BEGIN
SWITCHFLAG:= 1B; WRITEHEADER('GLOBAL SYMBOLS ');
(* 16 - ADD CCL SWITCH *)
WRITEIDENTIFIER(SWITCHFLAG,'%CCLSW ');
WRITEPAIR(RIGHT,0,CCLSW);
WRITEIDENTIFIER(SWITCHFLAG,'%RNNAM ');
WRITEPAIR(RIGHT,0,CCLSW+1);
WRITEIDENTIFIER(SWITCHFLAG,'%RNPPN ');
WRITEPAIR(RIGHT,0,CCLSW+2);
WRITEIDENTIFIER(SWITCHFLAG,'%RNDEV ');
WRITEPAIR(RIGHT,0,CCLSW+3);
END
ELSE
BEGIN
SWITCHFLAG:= 14B; WRITEHEADER('GLOBAL REQUESTS')
END;
FILEPTR := SFILEPTR;
WHILE FILEPTR # NIL DO
WITH FILEPTR^, FILEIDENT^ DO
BEGIN
IF VADDR # 0
THEN
BEGIN
WRITEIDENTIFIER(SWITCHFLAG,NAME);
WRITEPAIR(RIGHT,0,VADDR)
END;
FILEPTR:= NEXTFTP
END;
IF MAIN
THEN WRITEHEADER('GLOBAL REQUESTS');
CHECKER:= EXTERNPFPTR;
WHILE CHECKER # NIL DO
WITH CHECKER^ DO
BEGIN
IF LINKCHAIN[0] # 0
THEN
BEGIN
IF PFLEV = 0
THEN WRITEIDENTIFIER(14B,EXTERNALNAME)
ELSE WRITEIDENTIFIER(14B,NAME);
WRITEPAIR(RIGHT,0,LINKCHAIN[0])
END;
CHECKER:= PFCHAIN
END;
(* 12 - ADD EXTERNAL REF TO RUNTIMES FOR DYNAMIC CORE ALLOC *)
IF LSTNEW # 0
THEN BEGIN
WRITEIDENTIFIER(14B,'LSTNEW ');
WRITEPAIR(RIGHT,0,LSTNEW); % GLOBAL FIXUP TO INIT. CODE\
END;
IF NEWBND # 0
THEN BEGIN
WRITEIDENTIFIER(14B,'NEWBND ');
WRITEPAIR(RIGHT,0,NEWBND); % DITTO \
END;
(* 105 - improve lower case mapping in sets *)
if setmapchain # 0
then begin
writeidentifier (14B,'.STCHM ');
writepair (right,0,setmapchain)
end;
FOR SUPPORTIX:= SUCC(FIRSTSUPPORT) TO PRED(LASTSUPPORT) DO
IF RNTS.LINK[SUPPORTIX] # 0
THEN
BEGIN
WRITEIDENTIFIER(14B,RNTS.NAME[SUPPORTIX]);
WRITEPAIR(RIGHT,0,RNTS.LINK[SUPPORTIX])
END;
(* 36 - 141 is now set up elsewhere *)
{In non-main modules, if there are references to TTY^, etc., a
Polish fixup may be needed to resolve them.}
polheaderdone := false;
FILEPTR := SFILEPTR;
IF NOT MAIN THEN WHILE FILEPTR # NIL DO
WITH FILEPTR^, FILEIDENT^ DO
begin
if chantab[channel] <> 0
then begin
if not polheaderdone
then begin
writeheader('SYMBOLIC POLISH');
polheaderdone := true;
end;
{A Polish fixup block looks like this:
type 11
operator,,2 2 means next word is global req - that is operand
operand1
0,,operand2 0 means next half word is operand
-1,,place to put -1 means put in RH of result addr
}
writeblockst(11B);
writepair(no,3,2); {add}
writeidentifier(0,name);
writepair(no,0,filcmp);
writepair(right,777777B,chantab[channel]);
putrelcode;
end;
FILEPTR:= NEXTFTP
END;
if polheaderdone and cref and listcode then NEWLINE;
END %MCSYMBOLS\ ;
PROCEDURE MCLIBRARY;
BEGIN
%MCLIBRARY\
WRITEHEADER('LINK LIBRARIES ');
WRITEBLOCKST(15);
FOR L := 1 TO 2 DO
BEGIN
FOR I := 1 TO LIBIX DO
WITH LIBRARY[LIBORDER[I]] DO
IF CALLED
THEN WITH WANDLUNG DO
BEGIN
FOR J := 1 TO 6 DO WSIXBIT[J] := ORD(NAME[J]) - 40B;
WRITEIDENTIFIER(6B,NAME);
WRITEPAIR(NO,PROJNR,PROGNR);
FOR J := 1 TO 6 DO WSIXBIT[J] := ORD(DEVICE[J]) - 40B;
WRITEIDENTIFIER(6B,DEVICE); LIC := LIC + 1
END;
I := 1;
(* 40 - load PASLIB first *)
for languageix := pascalsy to fortransy do
WITH LIBRARY[LANGUAGEIX] DO
BEGIN
CALLED := (NOT INORDER AND CALLED) OR (LANGUAGEIX = PASCALSY);
LIBORDER[I] := LANGUAGEIX; I := I + 1
END;
LIBIX := 2
END;
END %MCLIBRARY\;
BEGIN
%WRITEMC\
(* 121 - missing initialization - fix bollixed INITPROC's *)
CODEARRAY := FALSE;
IF NOT ERRORFLAG
THEN
BEGIN
(* 5 - CREF *)
IF CREF AND LISTCODE
THEN WRITE(CHR(177B),'F');
FOR I:=1 TO MAXSIZE DO RELEMPTY[I] := 0;
WITH ICWANDEL DO
BEGIN
ICVAL := 0;
CSP0 := ICCSP
END;
LLISTCODE := LISTCODE;
CASE WRITEFLAG OF
WRITEGLOBALS : MCGLOBALS; %LINK-ITEM 01B\
WRITECODE : MCCODE; %LINK-ITEM 01B\
WRITESYMBOLS : MCSYMBOLS; %LINK-ITEM 02B\
WRITEBLK, %LINK-ITEM 02B\
WRITEINTERNALS, %LINK-ITEM 10B\
(* 164 - Polish fixups *)
WRITEPOLISH, %LINK-ITEM 11B\
WRITEENTRY, %LINK-ITEM 04B\
WRITEEND, %LINK-ITEM 05B\
WRITESTART, %LINK-ITEM 07B\
WRITEHISEG, %LINK-ITEM 03B\
WRITENAME : MCVARIOUS; %LINK-ITEM 06B\
WRITELIBRARY : MCLIBRARY %LINK-ITEM 17B\
END %CASE\;
IF LISTCODE AND (WRITEFLAG > WRITEHISEG)
(* 5 - CREF *)
(* 136 - LISTING FORMAT *)
THEN NEWLINE;
IF CREF AND LISTCODE
THEN WRITE(CHR(177B),'B')
END %IF ERRORFLAG\
ELSE
IF WRITEFLAG = WRITECODE
THEN LASTBTP := NIL
END %WRITEMC\;
PROCEDURE STATEMENT(FSYS,STATENDS: SETOFSYS);
TYPE
VALUEKIND = (ONREGC,ONFIXEDREGC,TRUEJMP,FALSEJMP);
VAR
LCP: CTP; IX,J: INTEGER;
PROCEDURE EXPRESSION(FSYS: SETOFSYS; FVALUE:VALUEKIND); FORWARD;
PROCEDURE MAKEREAL(VAR FATTR: ATTR);
BEGIN
IF FATTR.TYPTR=INTPTR
THEN
BEGIN
LOAD(FATTR);
(* 2 - hard code FLOAT using KI-10 op code *)
(* 101 - fix code generation for fltr *)
(* 122 - add back KA-10 code *)
(* 132 - separate KA10 into NOVM and KACPU *)
if kacpu
then begin
macro3(201B%movei\,tac,fattr.reg);
support(convertintegertoreal);
end
ELSE WITH CODE.INSTRUCTION[CIX] DO
IF (INSTR = 200B%MOVE\) AND (AC = FATTR.REG)
THEN INSTR := 127B%FLTR\
ELSE MACRO3(127B%FLTR\,FATTR.REG,FATTR.REG);
FATTR.TYPTR := REALPTR
END;
IF GATTR.TYPTR=INTPTR
THEN MAKEREAL(GATTR)
END;
PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP);
VAR
LATTR: ATTR; LCP: CTP; LSP: STP;
LMIN,LMAX,INDEXVALUE,INDEXOFFSET: INTEGER;
OLDIC: ACRANGE;
PROCEDURE SUBLOWBOUND;
BEGIN
IF LMIN > 0
THEN MACRO3(275B%SUBI\,REGC,LMIN)
ELSE
IF LMIN < 0
THEN MACRO3(271B%ADDI\,REGC,-LMIN);
IF RUNTMCHECK
THEN
BEGIN
MACRO3(301B%CAIL\,REGC,0);
MACRO3(303B%CAILE\,REGC,LMAX-LMIN);
SUPPORT(INDEXERROR)
END
END;
BEGIN
WITH FCP^, GATTR DO
BEGIN
TYPTR := IDTYPE; KIND := VARBL; PACKFG := NOTPACK;
CASE KLASS OF
VARS:
BEGIN
VLEVEL := VLEV; DPLMT := VADDR; INDEXR := 0;
IF VLEV > 1
THEN VRELBYTE:= NO
ELSE VRELBYTE:= RIGHT;
IF IDTYPE^.FORM = FILES
THEN LASTFILE:= FCP
ELSE LASTFILE:= NIL;
IF VKIND=ACTUAL
THEN INDBIT:=0
ELSE INDBIT:=1
END;
FIELD:
WITH DISPLAY[DISX] DO
IF OCCUR = CREC
THEN
BEGIN
VLEVEL := CLEV; PACKFG := PACKF; VRELBYTE:= CRELBYTE;
IF PACKFG = PACKK
THEN
BEGIN
BPADDR := FLDADDR;
DPLMT := CDSPL
END
ELSE DPLMT := CDSPL+FLDADDR;
INDEXR := CINDR; INDBIT:=CINDB
END
ELSE
ERROR(171);
FUNC:
IF PFDECKIND = STANDARD
THEN ERROR(502)
ELSE
IF PFLEV = 0
THEN ERROR(502) %EXTERNAL FCT\
ELSE
IF PFKIND = FORMAL
THEN ERROR(456)
(* 31 - BE SURE WE'RE IN THE BODY OF THE FTN *)
ELSE IF (LEVEL <= PFLEV) OR (DISPLAY[PFLEV+1].BLKNAME # NAME)
THEN ERROR(412)
ELSE
BEGIN
(* 166 - use pflev+1 for vlevel, to allow assignment from inner function *)
VLEVEL := PFLEV + 1; VRELBYTE := NO;
DPLMT := 1; %IMPL. RELAT. ADDR. OF FCT. RESULT\
INDEXR :=0; INDBIT :=0
END
END;
%CASE\
END %WITH\;
IFERRSKIP(166,SELECTSYS OR FSYS);
WHILE SY IN SELECTSYS DO
BEGIN
(* 156 - error for selector on ftn name *)
IF FCP^.KLASS = FUNC
THEN ERROR(368);
%[\
IF SY = LBRACK
THEN
BEGIN
IF GATTR.INDBIT = 1
THEN GETPARADDR;
OLDIC := GATTR.INDEXR;
INDEXOFFSET := 0 ;
LOOP
LATTR := GATTR; INDEXVALUE := 0 ;
WITH LATTR DO
IF TYPTR # NIL
THEN
BEGIN
IF TYPTR^.FORM # ARRAYS
THEN
BEGIN
ERROR(307); TYPTR := NIL
END;
LSP := TYPTR
END;
INSYMBOL;
EXPRESSION(FSYS OR [COMMA,RBRACK],ONREGC);
IF GATTR.KIND#CST
THEN LOAD(GATTR)
ELSE INDEXVALUE := GATTR.CVAL.IVAL ;
IF GATTR.TYPTR # NIL
THEN
IF GATTR.TYPTR^.FORM # SCALAR
THEN ERROR(403);
IF LATTR.TYPTR # NIL
THEN
WITH LATTR,TYPTR^ DO
BEGIN
IF COMPTYPES(INXTYPE,GATTR.TYPTR)
THEN
BEGIN
IF INXTYPE # NIL
THEN
BEGIN
GETBOUNDS(INXTYPE,LMIN,LMAX);
IF GATTR.KIND = CST
THEN
IF (INDEXVALUE < LMIN) OR (INDEXVALUE > LMAX)
THEN ERROR(263)
END
END
ELSE ERROR(457);
TYPTR := AELTYPE ;
END ;
EXIT IF SY # COMMA;
WITH LATTR DO
IF TYPTR#NIL
THEN
IF GATTR.KIND = CST
THEN DPLMT := DPLMT +( INDEXVALUE - LMIN ) * TYPTR^.SIZE
ELSE
BEGIN
SUBLOWBOUND;
IF TYPTR^.SIZE > 1
THEN MACRO3(221B%IMULI\,REGC,TYPTR^.SIZE);
IF OLDIC = 0
THEN OLDIC := REGC
ELSE
IF OLDIC > REGCMAX
THEN
BEGIN
MACRO3(270B%ADD\,REGC,OLDIC);
OLDIC := REGC
END
ELSE
BEGIN
MACRO3(270B%ADD\,OLDIC,REGC) ;
REGC := REGC - 1
END;
INDEXR := OLDIC
END ;
GATTR := LATTR ;
END;
%LOOP\
WITH LATTR DO
IF TYPTR # NIL
THEN
BEGIN
IF GATTR.KIND = CST
THEN INDEXOFFSET := ( INDEXVALUE - LMIN ) * TYPTR^.SIZE
ELSE
BEGIN
IF (TYPTR^.SIZE > 1) OR RUNTMCHECK
THEN SUBLOWBOUND
ELSE INDEXOFFSET := -LMIN;
IF TYPTR^.SIZE > 1
THEN MACRO3(221B%IMULI\,REGC,TYPTR^.SIZE);
INDEXR := REGC ;
END ;
IF LSP^.ARRAYPF
THEN
BEGIN
(* 102 - kl array code *)
if not klcpu
THEN INCREMENTREGC;
IF INDEXR=OLDIC
THEN
BEGIN
INCREMENTREGC; INDEXR := 0
END;
(* 102 - kl adjbp code *)
if not klcpu then begin
MACRO4(571B%HRREI\,REGC,INDEXR,INDEXOFFSET);
INCREMENTREGC; %TEST FOR IDIVI-INSTRUCTION\
REGC := REGC-1; INDEXOFFSET := 0;
MACRO3R(200B%MOVE\,REGC-1,LSP^.ARRAYBPADDR);
MACRO3(231B%IDIVI\,REGC,BITMAX DIV LSP^.AELTYPE^.BITSIZE);
MACRO3(133B%IBP\,0,REGC-1);
MACRO3R(365B%SOJGE\,REGC+1,IC-1);
BPADDR := REGC-1; PACKFG := PACKK; INDEXR := REGC;
(* 102 - kl adjbp code *)
end
else begin (* kl code*)
macro4(571B%hrrei\,regc,indexr,indexoffset+1);
macro3r(133B%adjbp\,regc,lsp^.arraybpaddr);
bpaddr := regc; packfg := packk; indexr := 0;
indexoffset := 0;
end;
END;
DPLMT := DPLMT + INDEXOFFSET ;
KIND := VARBL ;
IF ( OLDIC # INDEXR ) AND ( OLDIC # 0 )
THEN
BEGIN
(* 102 - new packed array code *)
if indexr = 0
then indexr := oldic
ELSE IF OLDIC > REGCMAX
THEN MACRO3(270B%ADD\,INDEXR,OLDIC)
ELSE
BEGIN
MACRO3(270B%ADD\,OLDIC,INDEXR);
REGC := REGC - 1;
INDEXR := OLDIC
END
END
END %WITH.. IF TYPTR # NIL\ ;
GATTR := LATTR ;
IF SY = RBRACK
THEN INSYMBOL
ELSE ERROR(155)
END %IF SY = LBRACK\
ELSE
%.\
IF SY = PERIOD
THEN
BEGIN
WITH GATTR DO
BEGIN
IF TYPTR # NIL
THEN
IF TYPTR^.FORM # RECORDS
THEN
BEGIN
ERROR(308); TYPTR := NIL
END;
IF INDBIT=1
THEN GETPARADDR;
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
IF TYPTR # NIL
THEN
BEGIN
SEARCHSECTION(TYPTR^.FSTFLD,LCP);
(* 5 - CREF *)
IF CREF
THEN WRITE(CHR(1B),CHR(21),ID,' .FIELDID. ');
IF LCP = NIL
THEN
BEGIN
ERROR(309); TYPTR := NIL
END
ELSE
WITH LCP^ DO
BEGIN
TYPTR := IDTYPE;PACKFG := PACKF;
IF PACKFG = PACKK
THEN
BPADDR := FLDADDR
ELSE
DPLMT := DPLMT + FLDADDR;
END
END;
INSYMBOL
END %SY = IDENT\
ELSE ERROR(209)
END %WITH GATTR\
END %IF SY = PERIOD\
ELSE
%^\
BEGIN
IF GATTR.TYPTR # NIL
THEN
WITH GATTR,TYPTR^ DO
(* 173 - changes for internal files, since we can't assume FILPTR is set up *)
IF FORM = FILES
THEN BEGIN
TYPTR := FILTYPE;
{What we are trying to do here is to generate code like
MOVEI 2,INPUT+FILCMP
In the usual case, we just do a loadaddress on the file, after add
filcmp to the displacement. There are two cases where this won't
work:
- when the address is an external reference, since it then
becomes an address in a fixup chain, and can't have FILCMP
added to it at compile time. Thus we have a separate
fixup chain stored in CHANTAB which the loader will add
FILCMP to after fixing up.
- when the thing is indirect, since we have to add the displacemtn
after doing the indirection. The only solution there is
an ADDI, as far as I can see.
Hamburg used to just do a LOAD, which works because at INPUT there
is a pointer to INPUT+FILCMP. I can't do that because if the
FCB isn't initialized that will be garbage, and I need the real
address to do the validity check}
WITH FCP^ DO
IF (VLEV = 0) AND (NOT MAIN)
THEN BEGIN
INCREMENTREGC;
MACRO3R(201B%MOVEI\,REGC,CHANTAB[CHANNEL]);
CHANTAB[CHANNEL] := IC-1;
CODE.INFORMATION[CIX] := 'E';
WITH GATTR DO
BEGIN
KIND := VARBL; DPLMT := 0; INDEXR:=REGC;
INDBIT:=0; VRELBYTE := NO
END
END
(* 200 - fix addressing *)
ELSE IF INDBIT = 0
THEN BEGIN
DPLMT := DPLMT + FILCMP;
LOADADDRESS;
END
ELSE BEGIN
LOADADDRESS;
MACRO3(271B%ADDI\,REGC,FILCMP)
END;
IF RUNTMCHECK
THEN BEGIN
{See if the file is open. A magic value of 314157 is left in FILTST if so }
MACRO4(200B%MOVE\,HAC,REGC,FILTST-FILCMP);
MACRO3(302B%CAIE\,HAC,314157B);
SUPPORT(FILEUNINITIALIZED)
END
END
ELSE IF FORM = POINTER
THEN
BEGIN
TYPTR := ELTYPE;
IF TYPTR # NIL
THEN WITH GATTR DO
BEGIN
LOADNOPTR := FALSE;
LOAD(GATTR); LOADNOPTR := TRUE;
(* 23 - check for bad pointer *)
(* 26 - but not for file *)
IF RUNTMCHECK
THEN BEGIN
MACRO3(302B%CAIE\,REG,0);
MACRO3(306B%CAIN\,REG,377777B);
SUPPORT(BADPOINT)
END;
INDEXR := REG; DPLMT := 0; INDBIT:=0;
PACKFG := NOTPACK; KIND := VARBL;
VRELBYTE:= NO
END
END
ELSE ERROR(407);
INSYMBOL
END;
IFERRSKIP(166,FSYS OR SELECTSYS)
END;
%WHILE\
WITH GATTR DO
IF TYPTR#NIL
THEN
IF TYPTR^.SIZE = 2
THEN
BEGIN
IF INDBIT = 1
THEN GETPARADDR;
IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX)
THEN INCREMENTREGC
END
END %SELECTOR\ ;
PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP);
VAR
(* 10 - ALLOW MORE RUNTIMES *)
LKEY: 1..44;
LFOLLOWERROR, NORIGHTPARENT : BOOLEAN;
(* 33 - allow use with non-TEXT files *)
(* 171 - allow read/write of records *)
(* 173 - completely new getfilename *)
(* 204 - don't check validty of file to be closed *)
PROCEDURE GETFILENAME(DEFAULTFILE:CTP;TEXTPROC:BOOLEAN;
VAR FILETYPE:STP;VAR GOTARG:BOOLEAN;CHECK:BOOLEAN);
VAR
(* 177 - fix AC *)
GOTFILE : BOOLEAN; FILEREGC: ACRANGE;
{When we are finished we will have loaded a file into REGC, and parsed
the next parameter if there is one, using EXPRESSION with REGC incremented}
BEGIN
INCREMENTREGC; {by default we will load into 3}
FILEREGC := REGC; {but file goes into 2, which this still is}
{REGC = 2}
GOTARG := FALSE; NORIGHTPARENT := TRUE; GOTFILE := FALSE;
IF SY = LPARENT
THEN BEGIN
NORIGHTPARENT := FALSE;
INSYMBOL;
EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
{REGC = 3 if expression (file can't be), 2 otherwise}
GOTFILE := FALSE;
{We have an expression, see if it is a legal file. If so, load it into
REGC (note: no incrementregc first) and do a few tests. We have to do
our own loading mostly to avoid the INCREMENTREGC done by LOADADDRESS}
WITH GATTR DO
IF TYPTR <> NIL
THEN WITH TYPTR^ DO
IF FORM = FILES
THEN BEGIN
IF TEXTPROC
THEN IF NOT (COMPTYPES(FILTYPE,CHARPTR))
THEN ERROR(366);
{Yes, it is a legal file. Now load it}
{If TTY that is supposed to be mapped to TTYOUTPUT, handle that}
IF (LASTFILE = TTYFILE) AND (DEFAULTFILE = OUTFILE)
THEN BEGIN
LASTFILE := TTYOUTFILE;
MACRO3R(201B%MOVEI\,REGC,TTYOUTFILE^.VADDR);
END
ELSE BEGIN
FETCHBASIS(GATTR);
MACRO(VRELBYTE,201B%MOVEI\,REGC,INDBIT,INDEXR,DPLMT);
END;
KIND := VARBL; DPLMT := 0; INDEXR:=REGC;
INDBIT:=0; VRELBYTE := NO;
WITH LASTFILE^ DO
IF (VLEV=0) AND (NOT MAIN)
THEN BEGIN VADDR:=IC-1; CODE.INFORMATION[CIX]:='E' END;
GOTFILE := TRUE;
FILETYPE := TYPTR;
{Runtime checks if appropriate}
(* 204 - don't check for CLOSE *)
if runtmcheck and check
then begin
macro4(200B%MOVE\,hac,regc,filtst); {File test word}
macro3(302B%CAIE\,hac,314157B); {True if file is open}
support(fileuninitialized); {Not open}
end;
{Now see if there is an arg}
IF SY <> RPARENT
THEN BEGIN
IF SY = COMMA
THEN INSYMBOL
ELSE ERROR(158);
{Note that this is guaranteed not to change REGC unless it sees an
expression, in which case it advances to 3. We can't have two
advances (i.e. due to the EXPRESSION above and this one), since
this is done only if the one above saw a file, which can't have
advanced REGC}
EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
GOTARG := TRUE
END
END;
{Now we are done processing a file arg}
IF NOT GOTFILE {If expression wasn't a file, use it as arg}
THEN GOTARG := TRUE
END;
{End of IF RPARENT}
{At this point REGC = 2 unless what we saw was an expr (which a file
can't be), in which case REGC = 3 and it is loaded}
IF NOT GOTFILE
THEN WITH DEFAULTFILE^ DO
{If we didn't get a file above, here is the code to do it}
BEGIN
(* 177 - fix AC *)
MACRO3R(201B%MOVEI\,FILEREGC,VADDR);
IF NOT GOTARG
THEN WITH GATTR DO
BEGIN
KIND := VARBL; DPLMT := 0; INDEXR:=REGC;
INDBIT:=0; VRELBYTE := NO;
END;
IF (VLEV=0) AND (NOT MAIN)
THEN BEGIN VADDR:=IC-1; CODE.INFORMATION[CIX]:='E' END;
FILETYPE := IDTYPE;
(* 204 - don't check for CLOSE *)
if runtmcheck and check
then begin
(* 207 - more bad AC's *)
macro4(200B%MOVE\,hac,fileregc,filtst); {File test word}
macro3(302B%CAIE\,hac,314157B); {True if file is open}
support(fileuninitialized); {Not open}
end;
END;
{If we saw an arg, REGC is exactly like it would have been with a
simple INCREMENTREGC; EXPRESSION; which is the whole point.
That is,it is 2 unless an expression was seen, in which case the
expression is loaded into 3. If we didn't see an expression, then
REGC is guaranteed to be 2. Very shady...}
END %GETFILENAME\ ;
PROCEDURE VARIABLE(FSYS: SETOFSYS);
VAR
LCP: CTP;
BEGIN
IF SY = IDENT
THEN
BEGIN
SEARCHID([VARS,FIELD],LCP); INSYMBOL
END
ELSE
BEGIN
ERROR(209); LCP := UVARPTR
END;
SELECTOR(FSYS,LCP)
END %VARIABLE\ ;
(* 22 - add GETFN - common non-defaulting file name scanner *)
(* 73 - add ,COLON since used in NEW *)
(* 175 - internal files *)
PROCEDURE GETFN(TEST:BOOLEAN);
BEGIN
VARIABLE(FSYS OR [RPARENT,COLON,COMMA]);
LOADADDRESS;
IF GATTR.TYPTR#NIL
THEN IF GATTR.TYPTR^.FORM#FILES
THEN ERROR(212)
ELSE WITH LASTFILE^ DO
IF (VLEV=0) AND (NOT MAIN)
THEN BEGIN VADDR:=IC-1; CODE.INFORMATION[CIX]:='E' END;
(* 175 - internal files *)
if test and runtmcheck
then begin
macro4(200B%MOVE\,hac,regc,filtst); {File test word}
macro3(302B%CAIE\,hac,314157B); {Magic value if it is open}
support(fileuninitialized); {Not open}
end;
END;
(* 14 - SEVERAL CHANGES IN THIS PROC TO ADD NEW RUNTIMES AND ADD OPTIONAL XBLOCK ARG *)
PROCEDURE GETPUTRESETREWRITE;
VAR
(* 172 - new options string *)
LMAX,LMIN: INTEGER;
(* 173 - internal files *)
LATTR: ATTR;
ADR : SUPPORTS ;
DEFAULT : ARRAY [1..6] OF BOOLEAN;
I,J : INTEGER;
PROCEDURE GETSTRINGADDRESS ;
VAR LMAX,LMIN: INTEGER;
(* 61 - allow flags for gtjfn in tops20 *)
flagbits: packed record case Boolean of
true: (dum:0..777777B;usetty:Boolean;wildok:Boolean);
false: (dum2:0..777777B; rh:0..777777B)
end;
BEGIN
IF SY=COMMA
THEN
BEGIN
INSYMBOL;
EXPRESSION(FSYS OR [COMMA,RPARENT,COLON],ONFIXEDREGC);
WITH GATTR DO
IF TYPTR#NIL
THEN
WITH TYPTR^ DO
IF(FORM=ARRAYS) AND ARRAYPF
THEN
IF COMPTYPES(AELTYPE,CHARPTR)
THEN
BEGIN
(* 15 - CHANGE DUE TO SLIGHTLY DIFFERENT LOGIC IN MAIN PROC *)
DEFAULT[I] := FALSE;
I:=I+1;DEFAULT[I]:=FALSE;
LOADADDRESS;
GETBOUNDS(INXTYPE,LMIN,LMAX);
LMAX := LMAX-LMIN+1;
INCREMENTREGC;
MACRO3(201B%MOVEI\,REGC,LMAX);
END
ELSE ERROR(212)
ELSE ERROR(212);
(* 61 - implement extra syntax for tops20 *)
(* 144 - allow it for tops10, too *)
if (sy=colon)
then begin
insymbol;
flagbits.rh := 0;
while sy in [relop,addop,mulop] do
begin
if op = leop (* @ *)
then flagbits.usetty := true
else if (op = mul) and (not tops10)
then flagbits.wildok := true
else error(158);
insymbol
end;
macro3(505b%hrli\,regc-1,flagbits.rh);
end;
END;
END ;
BEGIN
VARIABLE( FSYS OR [RPARENT,COMMA] ) ;
LOADADDRESS ;
(* 173 - internal files *)
LATTR := GATTR;
IF GATTR.TYPTR # NIL
THEN
IF GATTR.TYPTR^.FORM # FILES
THEN ERRANDSKIP(458,FSYS OR [RPARENT])
ELSE
BEGIN
WITH LASTFILE^ DO
IF (VLEV = 0) AND (NOT MAIN)
THEN
BEGIN
VADDR:= IC-1; CODE.INFORMATION[CIX] := 'E'
END;
IF (LKEY>=5) AND (LKEY#28)
THEN
BEGIN
FOR I := 1 TO 6 DO DEFAULT[I] := TRUE;
I := 1;
GETSTRINGADDRESS % OF FILENAME \ ;
(* 15 - ADD NEW PARAMETERS AND ALLOW OMITTING BLOCK *)
WHILE NOT DEFAULT[I] AND (SY=COMMA) DO
BEGIN
I := I+1;
INSYMBOL;
(* 172 - ADD OPTION STRING AS 3RD ARG *)
IF I = 3
THEN BEGIN
EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
WITH GATTR DO
IF TYPTR#NIL
THEN WITH TYPTR^ DO
IF(FORM=ARRAYS) AND ARRAYPF
THEN IF COMPTYPES(AELTYPE,CHARPTR)
THEN BEGIN
DEFAULT[I] := FALSE;
LOADADDRESS;
GETBOUNDS(INXTYPE,LMIN,LMAX);
LMAX := LMAX-LMIN+1;
MACRO3(505B%HRLI\,REGC,LMAX);
END
ELSE ERROR(212) {not CHAR array}
ELSE BEGIN {not packed array}
LOAD(GATTR); DEFAULT[I] := FALSE
END
END {I=3}
(* 57 - ONLY TOPS10 HAS XBLOCK ARG *)
ELSE IF (NOT TOPS10) OR (I # 4) OR ((SY=INTCONST)AND(VAL.IVAL=0))
THEN BEGIN
EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
IF GATTR.TYPTR#NIL
THEN
BEGIN
LOAD(GATTR); DEFAULT[I] := FALSE;
(* 77 - allow sets, since they are elegant for specifying bits *)
if gattr.typtr^.form = power
then regc := regc-1;
END
END
ELSE BEGIN
VARIABLE(FSYS OR[COMMA,RPARENT]);
IF GATTR.TYPTR # NIL
(* 26 - allow record as lookup block *)
THEN IF NOT (GATTR.TYPTR^.FORM IN [ARRAYS,RECORDS])
THEN ERROR(264)
ELSE IF GATTR.TYPTR^.SIZE<5
THEN ERROR(265)
ELSE BEGIN LOADADDRESS; DEFAULT[I]:=FALSE END
ELSE ERROR(458)
END;
END;
FOR I := 1 TO 6 DO
IF DEFAULT[I]
THEN
BEGIN
INCREMENTREGC;
IF I=6
THEN MACRO3(474B%SETO\,REGC,0)
ELSE MACRO3(201B%MOVEI\,REGC,0)
END;
END;
(* 173 - internal files *)
if lkey in [5,6,29,36] {openning}
then begin
if lattr.typtr <> nil
then if lattr.typtr^.form = files
then if comptypes(lattr.typtr^.filtype,charptr)
{In AC1, put size of component, or 0 if text file}
then macro3(201B%movei\,tac,0)
else macro3(201B%movei\,tac,
{Normally we would have to type filtype^ for nil, but if it is nil, the
comptypes above will succeed, and this code will never happen.}
lattr.typtr^.filtype^.size)
end
(* 204 - don't validty check for DISMISS *)
(* 205 - fix AC for RENAME *)
else if runtmcheck and (lkey <> 28)
then begin
macro4(200B%MOVE\,hac,regin+1,filtst);{File test word}
macro3(302B%CAIE\,hac,314157B); {Magic value if open}
support(fileuninitialized); {Not open}
end;
CASE LKEY OF
2: ADR:= GETLINE ;
4: ADR:= PUTLINE ;
5: ADR:= RESETFILE ;
6: ADR:= REWRITEFILE;
27:ADR:=NAMEFILE;
28:ADR:=DISFILE;
29:ADR:=UPFILE;
36:ADR:=APFILE
END ;
SUPPORT(ADR) ;
END ;
END;
(* 10 - ADD SETSTRING, TO ALLOW I/O TO STRINGS *)
(* 13 - CODE MODIFIED TO ALLOW 4TH ARG, LIMIT *)
(* 51 - allow any file type, any packed array *)
PROCEDURE SETSTRING;
VAR
LREGC:ACRANGE;
LMIN,LMAX:ADDRRANGE;
ARRAY1,OFFSET,FILEP,LIMIT:ATTR;
NOOFF,NOLIM: BOOLEAN;
BEGIN
LREGC := REGC; NOOFF := FALSE; NOLIM:=FALSE;
(* 175 - if not inited, do it *)
GETFN(FALSE);
{If the file block is not legal yet, call routine to make it so}
macro4(200B%MOVE\,hac,regc,filtst); {File test word}
macro3(302B%CAIE\,hac,314157B); {Magic value if it is open}
support(initfileblock);
FILEP := GATTR;
IF SY = COMMA
THEN INSYMBOL
ELSE ERROR(158);
VARIABLE(FSYS OR [RPARENT,COMMA]);
LOADADDRESS;
WITH GATTR DO
BEGIN
KIND := EXPR; REG := INDEXR;
IF TYPTR # NIL
THEN WITH TYPTR^ DO
IF FORM # ARRAYS
THEN ERROR(458)
ELSE IF FILEP.TYPTR#NIL
THEN IF NOT ARRAYPF
THEN ERROR(458)
END;
ARRAY1 := GATTR;
IF SY = RPARENT
THEN NOOFF := TRUE
ELSE IF SY = COMMA
THEN BEGIN
INSYMBOL;
EXPRESSION(FSYS OR [RPARENT,COMMA],ONREGC);
IF GATTR.TYPTR # NIL
THEN IF GATTR.TYPTR^.FORM # SCALAR
THEN ERROR(458)
ELSE IF NOT COMPTYPES(ARRAY1.TYPTR^.INXTYPE,GATTR.TYPTR)
THEN ERROR(458);
OFFSET := GATTR;
IF OFFSET.KIND = EXPR
THEN INCREMENTREGC
END
ELSE ERROR(158);
IF SY = RPARENT
THEN NOLIM := TRUE
ELSE IF SY = COMMA
THEN BEGIN
INSYMBOL;
EXPRESSION(FSYS OR [RPARENT],ONREGC);
IF GATTR.TYPTR # NIL
THEN IF GATTR.TYPTR^.FORM # SCALAR
THEN ERROR(458)
ELSE IF NOT COMPTYPES(ARRAY1.TYPTR^.INXTYPE,GATTR.TYPTR)
THEN ERROR(458);
LIMIT := GATTR;
IF LIMIT.KIND = EXPR
THEN INCREMENTREGC
END
ELSE ERROR(158);
IF NOT ERRORFLAG
THEN BEGIN
GETBOUNDS(ARRAY1.TYPTR^.INXTYPE,LMIN,LMAX);
LMAX := LMAX - LMIN;
IF NOT NOLIM
THEN BEGIN
IF LIMIT.KIND # EXPR
THEN BEGIN LOAD(LIMIT); INCREMENTREGC END;
WITH LIMIT DO
BEGIN
IF LMIN > 0
THEN MACRO3(275B%SUBI\,REG,LMIN)
ELSE IF LMIN < 0
THEN MACRO3(271B%ADDI\,REG,-LMIN);
IF RUNTMCHECK
THEN BEGIN
MACRO3(307B%CAIG\,REG,LMAX);
MACRO3(305B%CAIGE\,REG,0);
SUPPORT(INDEXERROR)
END;
END;
END;
IF NOT NOOFF
THEN BEGIN
IF OFFSET.KIND # EXPR
THEN BEGIN LOAD(OFFSET); INCREMENTREGC END;
WITH OFFSET DO
BEGIN
IF LMIN > 0
THEN MACRO3(275B%SUBI\,REG,LMIN)
ELSE IF LMIN < 0
THEN MACRO3(271B%ADDI\,REG,-LMIN);
IF RUNTMCHECK
THEN BEGIN
MACRO3(301B%CAIL\,REG,0);
MACRO3(303B%CAILE\,REG,LMAX+1);
SUPPORT(INDEXERROR)
END;
END;
INCREMENTREGC;
IF NOLIM
THEN MACRO4(211B%MOVNI\,REGC,OFFSET.REG,-LMAX-1)
ELSE BEGIN
MACRO4(201B%MOVEI\,REGC,LIMIT.REG,1);
MACRO4(275B%SUBI\,REGC,OFFSET.REG,0);
IF RUNTMCHECK
THEN BEGIN
MACRO3(305B%CAIGE\,REGC,0);
SUPPORT(INDEXERROR)
END
END;
MACRO4(552B%HRRZM\,REGC,FILEP.INDEXR,FILBFH+2);
MACRO3R(200B%MOVE\,REGC,ARRAY1.TYPTR^.ARRAYBPADDR);
MACRO3(621B%TLZ\,REGC,17B);
MACRO3(231B%IDIVI\,OFFSET.REG,BITMAX DIV ARRAY1.TYPTR^.AELTYPE^.BITSIZE);
MACRO3(270B%ADD\,ARRAY1.REG,OFFSET.REG);
MACRO3(540B%HRR\,REGC,ARRAY1.REG);
MACRO3(303B%CAILE\,OFFSET.REG+1,0);
MACRO3(133B%IBP\,0,REGC);
MACRO3R(367B%SOJG\,OFFSET.REG+1,IC-1);
MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+1)
END
ELSE BEGIN
INCREMENTREGC;
IF NOLIM
THEN MACRO3(201B%MOVEI\,REGC,LMAX+1)
ELSE MACRO4(201B%MOVEI\,REGC,LIMIT.REG,1);
MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+2);
MACRO3R(200B%MOVE\,REGC,ARRAY1.TYPTR^.ARRAYBPADDR);
MACRO3(621B%TLZ\,REGC,17B);
MACRO3(540B%HRR\,REGC,ARRAY1.REG);
MACRO4(202B%MOVEM\,REGC,FILEP.INDEXR,FILBFH+1)
END;
IF NOLIM
THEN MACRO3(505B%HRLI\,REGC,LMIN+LMAX+400001B)
ELSE MACRO4(505B%HRLI\,REGC,LIMIT.REG,LMIN+400001B);
(* 60 - DON'T PUT IN LH(0) FOR TOPS-20. "FILBFH" IS FREE *)
(* 143 - Tops10 now like Tops20 *)
IF TOPS10
THEN MACRO4(556B%HLRZM\,REGC,FILEP.INDEXR,FILBLL)
ELSE MACRO4(556B%HLRZM\,REGC,FILEP.INDEXR,FILBFH);
(* 43 - setzm to avoid blocked or dump mode I/O *)
(* 60 - kludge needed only for tops10 *)
(* 143 - tops10 now like tops20 *)
CASE LKEY OF
(* 60 - TOPS20 USES RUNTIME TO INIT *)
(* 143 - so does Tops10 *)
22: SUPPORT(RESETSTRING);
23: SUPPORT(REWRITESTRING)
END;
END;
REGC := LREGC
END;
(* 57 - ADD SET20STRING FOR 20 STRSET,STRWRITE *)
(* 60 - on further thought, use normal one *)
PROCEDURE GETINDEX;
VAR LREGC:ACRANGE;
FILEP:ATTR;
BEGIN
LREGC := REGC;
(* 175 *)
GETFN(TRUE);
FILEP := GATTR;
IF SY = COMMA
THEN INSYMBOL
ELSE ERROR(158);
VARIABLE(FSYS OR [RPARENT]);
LOADADDRESS;
WITH GATTR DO
BEGIN
IF TYPTR # NIL
THEN WITH TYPTR^ DO
IF (FORM # SCALAR) AND (FORM # SUBRANGE)
THEN ERROR(458)
END;
IF NOT ERRORFLAG
THEN BEGIN
INCREMENTREGC;
WITH FILEP DO
BEGIN
(* 60 - TOPS20 HAS MAGIC NO. IN DIFFERENT PLACE *)
(* 143 - tops10 now the same *)
IF TOPS10
THEN MACRO4(200B%MOVE\,REGC,INDEXR,FILBLL)
ELSE MACRO4(200B%MOVE\,REGC,INDEXR,FILBFH);
MACRO3(620B%TRZ\,REGC,400000B);
MACRO4(274B%SUB\,REGC,INDEXR,FILBFH+2);
MACRO4(202B%MOVEM\,REGC,GATTR.INDEXR,0);
END
END;
REGC := LREGC
END;
PROCEDURE READREADLN;
VAR
(* 14 ADD READING OF STRING *)
(* 171 read into packed objects, ALLOW READ OF RECORDS *)
LADDR : SUPPORTS; LMIN,LMAX:INTEGER; LATTR:ATTR;
READREC: BOOLEAN; LREGC: ACRANGE;
{This procedure is complicated by a number of special cases. The first is
the question of whether the file is text or binary. The code for a binary
file is more or less completely different. (Note also that only READLN
is not legal for a binary file.) The second question is whether the
address is passed to the runtimes or whether they return a value. For
binary files we must pass the address of the variable to be filled, since
it can be arbitrarily big. Similarly for strings. For simple values,
the runtimes return the value in AC 3, and we must do a store. This is
to allow for storing into packed objects (what kind of address could be
pass for that?) We do LOADADDRESS for binary files and strings, and
for simple objects we do STORE afterwards.}
BEGIN
(* 33 - ALLOW GETFILENAME WITH NON-TEXT FILES *)
(* 171 - PREDECL FILES ARE GLOBAL, ALSO ALLOW READ OF RECORD *)
IF LKEY = 7 {read?}
THEN GETFILENAME(INFILE,FALSE,THISFILE,GOTARG,TRUE) {might be binary}
ELSE GETFILENAME(INFILE,TRUE,THISFILE,GOTARG,TRUE); {must be text}
IF (LKEY = 7) AND NOT GOTARG
THEN ERROR(554); {READ must have args}
READREC := FALSE; {now see if a binary file}
IF LKEY = 7
THEN IF NOT COMPTYPES(CHARPTR,THISFILE^.FILTYPE)
THEN READREC := TRUE;
LREGC := REGC;
IF GOTARG
THEN
LOOP
(* 14 ADD READING OF STRING *)
(* 171 read into packed objects *)
LATTR := GATTR;
(* 31 - INITIALIZE LADDR IN CASE OF ERROR - PREVENT ILL MEM REF *)
IF READREC
THEN BEGIN {separate code for binary files}
LADDR := READRECORD;
IF GATTR.TYPTR#NIL
THEN IF NOT COMPTYPES(THISFILE^.FILTYPE,GATTR.TYPTR)
THEN ERROR(260);
LOADADDRESS
END
ELSE BEGIN {Here is the code for TEXT files}
LADDR := READCHARACTER;
IF GATTR.TYPTR#NIL
THEN
IF GATTR.TYPTR^.FORM<=SUBRANGE
THEN
IF COMPTYPES(INTPTR,GATTR.TYPTR)
THEN
LADDR := READINTEGER
ELSE
IF COMPTYPES(REALPTR,GATTR.TYPTR)
THEN
LADDR := READREAL
ELSE
IF COMPTYPES(CHARPTR,GATTR.TYPTR)
THEN
LADDR := READCHARACTER
ELSE ERROR(169)
ELSE WITH GATTR.TYPTR^ DO
IF FORM = ARRAYS
THEN IF COMPTYPES(CHARPTR,AELTYPE)
THEN
BEGIN
(* 171 - read into packed objects *)
LOADADDRESS; {of array}
GETBOUNDS(INXTYPE,LMIN,LMAX);
INCREMENTREGC;
MACRO3(201B%MOVEI\,REGC,LMAX-LMIN+1);
IF ARRAYPF
THEN LADDR := READPACKEDSTRING
ELSE LADDR := READSTRING;
IF SY = COLON
THEN BEGIN
INSYMBOL;
(* 76 - allow set of break characters *)
VARIABLE(FSYS OR [COMMA,RPARENT,COLON]);
LOADADDRESS;
IF NOT COMPTYPES(INTPTR,GATTR.TYPTR)
THEN ERROR(458);
END
else begin
incrementregc;
MACRO3(201B%MOVEI\,REGC,0);
end;
if sy = colon
then begin
insymbol;
expression(fsys or [comma,rparent],onfixedregc);
if gattr.typtr#nil
then if (gattr.typtr^.form = power)
then if comptypes(gattr.typtr^.elset, charptr)
then begin
load(gattr);
regc := regc-2;
end
else error(458)
else error(458)
end
else macro3(403B%SETZB\,regc+1,regc+2);
END
ELSE ERROR(458)
ELSE ERROR(458);
END; {of TEXT file case}
(* 171 - read into packed objects *)
REGC := LREGC;
if not (readrec or (laddr in [readstring,readpackedstring]))
then begin
{This is for reading single words, which may go into packed structures.
Note that we have to redo the ac allocation because the read routine
will return a value in AC 3, which quite likely is used as INDEXR or
BPADDR. Since we are pushing the active AC's anyway, we might as well
pop them back into a different place.}
incrementregc; {place that read will return the value}
if (lattr.indexr > regin) and (lattr.indexr <= 10B)
then begin
macro3(261B%PUSH\,topp,lattr.indexr);
incrementregc;
lattr.indexr := regc; {Place to put this value afterwards}
end;
if (lattr.packfg = packk) and (lattr.bpaddr > regin)
and (lattr.bpaddr <= 10B)
then begin
macro3(261B%PUSH\,topp,lattr.bpaddr);
incrementregc;
lattr.bpaddr := regc;
end;
regc := lregc; {restore regc}
support(laddr);
if (lattr.packfg = packk) and (lattr.bpaddr > regin)
and (lattr.bpaddr <= 10B)
then macro3(262B%POP\,topp,lattr.bpaddr);
if (lattr.indexr > regin) and (lattr.indexr <= 10B)
then macro3(262B%POP\,topp,lattr.indexr);
fetchbasis(lattr); {Now do the store}
store(regc+1,lattr)
end
else SUPPORT(LADDR);
EXIT IF SY # COMMA;
INSYMBOL;
VARIABLE(FSYS OR [COMMA,COLON,RPARENT]);
END;
IF LKEY = 8
THEN SUPPORT(GETLINE)
END %READREADLN\ ;
(* 42 - move breakin to close *)
(* 43 - add putx *)
procedure putx;
begin
(* 175 *)
getfn(true);
(* 61 - add delete *)
case lkey of
37: support(putxfile);
41: support(delfile)
end;
end;
PROCEDURE BREAK;
BEGIN
(* 26 - allow non-text files *)
(* 171 - PREDECL FILES ARE SPECIAL *)
GETFILENAME(OUTFILE,FALSE,THISFILE,GOTARG,TRUE);
IF GOTARG THEN ERROR(554);
SUPPORT(BREAKOUTPUT) ;
END ;
(* 10 - ADD CLOSE *)
(* 15 - AND ALLOW OPT. PARAM FOR CLOSE BITS *)
(* 42 - move breakin here, to allow param to suppress get *)
PROCEDURE CLOSE;
BEGIN
(* 26 - allow non-text files *)
(* 61 - rclose for tops20 *)
if (lkey = 25) or (lkey = 42)
(* 171 - PREDECL FILES ARE SPECIAL *)
(* 204 - don't validity check CLOSE and RCLOSE *)
THEN GETFILENAME(OUTFILE,FALSE,THISFILE,GOTARG,FALSE)
else getfilename(INFILE,false,THISFILE,GOTARG,FALSE);
IF GOTARG
THEN LOAD(GATTR)
ELSE BEGIN
INCREMENTREGC;
MACRO3(201B%MOVEI\,REGC,0)
END;
(* 45 - add NEXTBLOCK *)
(* 61 - add RCLOSE *)
case lkey of
25: support(closefile);
34: support(breakinput);
39: support(nextblockf);
42: support(relfile)
end;
END;
(* 14 - ADD DUMP MODE STUFF *)
(* 42 - allow variable size *)
PROCEDURE DUMP;
VAR FILEP:ATTR; s:integer;
BEGIN
(* 175 *)
GETFN(TRUE);
FILEP:=GATTR;
IF SY=COMMA
THEN INSYMBOL
ELSE ERROR(158);
EXPRESSION(FSYS OR[COMMA,RPARENT],ONFIXEDREGC);
LOADADDRESS;
if gattr.typtr#nil
then s:=gattr.typtr^.size;
if sy=comma
then
begin
insymbol;
expression(fsys or [rparent],onfixedregc);
if comptypes(intptr,gattr.typtr)
then load(gattr)
else error(458);
if runtmcheck
then begin
macro3(303b%caile\,regc,s);
support(indexerror)
end
end
else
begin
INCREMENTREGC;
MACRO3(201B%MOVEI\,REGC,GATTR.TYPTR^.SIZE)
end;
IF LKEY=30
THEN SUPPORT(READDUMP)
ELSE SUPPORT(WRITEDUMP)
END;
PROCEDURE USET;
VAR FILEP:ATTR;
BEGIN
(* 175 *)
GETFN(TRUE);
FILEP:=GATTR;
IF SY = COMMA
THEN INSYMBOL
ELSE ERROR(158);
(* 43 - new optional arg for useti *)
EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
LOAD(GATTR);
IF GATTR.TYPTR=NIL
THEN ERROR(458)
ELSE IF GATTR.TYPTR#INTPTR
THEN ERROR(458);
(* 44 - add SETPOS and SKIP *)
IF LKEY # 33
(* 43 - new optional arg for useti *)
then begin
if sy=comma
then begin
insymbol;
expression(fsys or [rparent],onfixedregc);
load(gattr);
end
else begin
incrementregc;
macro3(201b%movei\,regc,0)
end;
case lkey of
32:support(setin);
38:support(setposf)
end
end
ELSE SUPPORT(SETOUT)
END;
PROCEDURE WRITEWRITELN;
VAR
LSP: STP; DEFAULT,REALFORMAT,WRITEOCT: BOOLEAN; LSIZE,LMIN,LMAX: INTEGER; LADDR: SUPPORTS;
(* 171 - write records *)
writerec: Boolean;
BEGIN
(* 171 - PREDECL FILES ARE GLOBAL, ALSO ALLOW READ OF RECORD *)
{First scan file name and see if binary file}
IF LKEY = 10 {WRITE?}
THEN GETFILENAME(OUTFILE,FALSE,THISFILE,GOTARG,TRUE) {Yes, might be binary}
ELSE GETFILENAME(OUTFILE,TRUE,THISFILE,GOTARG,TRUE); {No, WRITELN not legal for binary files}
IF (LKEY = 10) AND NOT GOTARG
THEN ERROR(554);
WRITEREC := FALSE;
IF LKEY = 10 {Now see if it was a binary file}
THEN IF NOT COMPTYPES(CHARPTR,THISFILE^.FILTYPE)
THEN WRITEREC := TRUE;
IF GOTARG
THEN
LOOP
(* 22 - INITIALIZE LADDR IN CASE OF ERRORS. PREVENTS ILL MEM REF *)
(* 206 - moved initialization below *)
LSP := GATTR.TYPTR; LSIZE := LGTH; WRITEOCT := FALSE;
IF LSP # NIL
THEN
(* 206 - make non-text files work for constants *)
{Note that the values of LADDR set here are used only for binary files.
LADDR is reset below for text files. Only in case of error will these
values remain for a text file, and in that case having them prevents
an ill mem ref}
IF LSP^.FORM <= POWER
THEN BEGIN LOAD(GATTR); LADDR := WRITESCALAR END
ELSE
BEGIN
IF (GATTR.KIND = VARBL)
AND
(GATTR.INDEXR = TOPP)
THEN ERROR(458);
LOADADDRESS;
LADDR := WRITERECORD;
END;
(* 206 - make non-text files work for constants *)
IF WRITEREC
THEN BEGIN {For binary files, make sure of type match}
IF GATTR.TYPTR#NIL
THEN IF NOT COMPTYPES(THISFILE^.FILTYPE,GATTR.TYPTR)
THEN ERROR(260);
END {end binary}
ELSE BEGIN
IF SY = COLON
THEN
BEGIN
INSYMBOL; EXPRESSION(FSYS OR [COMMA,COLON,RPARENT],ONFIXEDREGC);
IF GATTR.TYPTR # NIL
THEN
IF GATTR.TYPTR # INTPTR
THEN ERROR(458);
LOAD(GATTR); DEFAULT := FALSE;
END
ELSE
BEGIN
DEFAULT := TRUE; INCREMENTREGC %RESERVE REGISTER FOR DEFAULT VALUE\
END ;
IF LSP = INTPTR
THEN
BEGIN
LADDR := WRITEINTEGER ; LSIZE := 12
END;
IF SY = COLON
THEN
BEGIN
INSYMBOL;
IF (SY = IDENT) AND ((ID='O ') OR (ID='H '))
THEN
BEGIN
IF NOT COMPTYPES(LSP,INTPTR)
THEN ERROR(262);
IF ID = 'O '
THEN LADDR := WRITEOCTAL
ELSE
BEGIN
LADDR := WRITEHEXADECIMAL; LSIZE := 11
END;
INSYMBOL
END
ELSE
BEGIN
EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
IF GATTR.TYPTR # NIL
THEN
IF GATTR.TYPTR # INTPTR
THEN ERROR(458);
IF LSP # REALPTR
THEN ERROR(258);
LOAD(GATTR); REALFORMAT := FALSE
END
END
ELSE REALFORMAT := TRUE;
IF LSP = INTPTR
THEN GOTO 1;
IF LSP = CHARPTR
THEN
BEGIN
LSIZE := 1; LADDR := WRITECHARACTER
END
ELSE
IF LSP = REALPTR
THEN
BEGIN
LSIZE := 16; LADDR := WRITEREAL;
IF REALFORMAT
THEN MACRO3(201B%MOVEI\,REGIN+4,123456B);
END
ELSE
IF LSP = BOOLPTR
THEN
BEGIN
LSIZE := 6; LADDR := WRITEBOOLEAN
END
ELSE
IF LSP # NIL
THEN
BEGIN
IF LSP^.FORM = SCALAR
THEN ERROR(169)
ELSE
IF STRING(LSP)
THEN
BEGIN
IF LSP^.INXTYPE#NIL
THEN
BEGIN
GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX);
LSIZE := LMAX-LMIN+1;
END;
MACRO3(201B%MOVEI\,REGIN+4,LSIZE);
IF LSP^.ARRAYPF
THEN LADDR := WRITEPACKEDSTRING
ELSE LADDR := WRITESTRING ;
END
ELSE ERROR(458)
END;
1:
IF DEFAULT
THEN MACRO3(201B%MOVEI\,REGIN+3,LSIZE);
END; {of IF WRITEREC}
SUPPORT(LADDR);
REGC :=REGIN + 1;
EXIT IF SY # COMMA;
INSYMBOL;
(* 206 - allow constants for records *)
EXPRESSION(FSYS OR [COMMA,COLON,RPARENT],ONFIXEDREGC);
END;
IF LKEY = 11
THEN SUPPORT(PUTLINE) ;
END %WRITE\ ;
(* 6 - PACK and UNPACK have been rewritten to be as described in Jensen and Wirth *)
PROCEDURE PACK;
% PACK(A,I,Z) MEANS:
FOR L := LMIN(Z) TO LMAX(Z) DO Z[L] := A[L-LMIN(Z)+I] \
VAR
ARRAY1,OFFSET1,ARRAY2,OFFSET2: ATTR;
LADDR,START,STOP,LMIN1,LMAX1,LMIN2,LMAX2: ADDRRANGE;
LREGC: ACRANGE;
BEGIN
LREGC := REGC; START := 0;
VARIABLE(FSYS OR [COMMA,RPARENT]);
LOADADDRESS;
WITH GATTR DO
BEGIN
KIND := EXPR; REG := INDEXR;
(* 135 prevent ill mem ref if not a variable *)
IF TYPTR = NIL
THEN TYPTR := UARRTYP
ELSE WITH TYPTR^ DO
IF FORM # ARRAYS
THEN ERROR(458)
ELSE
IF ARRAYPF
THEN ERROR(458)
END;
ARRAY1 := GATTR;
IF SY = COMMA
THEN INSYMBOL
ELSE ERROR(158);
EXPRESSION(FSYS OR [COMMA,RPARENT],ONREGC);
IF GATTR.TYPTR # NIL
THEN
IF GATTR.TYPTR^.FORM # SCALAR
THEN ERROR(458)
ELSE
IF NOT COMPTYPES(ARRAY1.TYPTR^.INXTYPE,GATTR.TYPTR)
THEN ERROR(458);
OFFSET1 := GATTR;
IF SY = COMMA
THEN INSYMBOL
ELSE ERROR(158);
VARIABLE(FSYS OR [RPARENT]);
LOADADDRESS;
WITH GATTR DO
BEGIN
KIND := EXPR; REG := INDEXR;
IF TYPTR # NIL
THEN WITH TYPTR^ DO
IF FORM # ARRAYS
THEN ERROR(458)
ELSE
IF NOT ARRAYPF
OR
NOT (COMPTYPES(AELTYPE,ARRAY1.TYPTR^.AELTYPE)
AND
COMPTYPES(INXTYPE,ARRAY1.TYPTR^.INXTYPE))
THEN ERROR(458)
END;
ARRAY2 := GATTR;
IF NOT ERRORFLAG
THEN
BEGIN
GETBOUNDS(ARRAY1.TYPTR^.INXTYPE,LMIN1,LMAX1); LMAX1 := LMAX1 - LMIN1;
GETBOUNDS(ARRAY2.TYPTR^.INXTYPE,LMIN2,LMAX2); LMAX2 := LMAX2 - LMIN2;
WITH OFFSET2 DO %MAKE OFFSET2 A CONST = LMAX2+1 \
BEGIN
TYPTR := INTPTR;
KIND := CST;
CVAL.IVAL := LMAX2 + 1
END;
IF (OFFSET1.KIND = CST)
THEN
BEGIN
STOP := OFFSET2.CVAL.IVAL;
START := OFFSET1.CVAL.IVAL - LMIN1;
IF (START < 0) OR (START > (LMAX1+1-STOP))
THEN ERROR(263);
MACRO3(505B%HRLI\,ARRAY1.REG,-STOP);
END
ELSE
BEGIN
LOAD(OFFSET2);
WITH OFFSET2 DO
MACRO3(210B%MOVN\,REG,REG);
LOAD(OFFSET1);
WITH OFFSET1 DO
BEGIN
IF LMIN1 > 0
THEN MACRO3(275B%SUBI\,REG,LMIN1)
ELSE
IF LMIN1 < 0
THEN MACRO3(271B%ADDI\,REG,-LMIN1);
IF RUNTMCHECK
THEN
BEGIN
MACRO3(301B%CAIL\,REG,0);
MACRO4(303B%CAILE\,REG,OFFSET2.REG,LMAX1+1);
SUPPORT(INDEXERROR)
END;
MACRO3(270B%ADD\,ARRAY1.REG,REG);
MACRO4(505B%HRLI\,ARRAY1.REG,OFFSET2.REG,0)
END
END;
INCREMENTREGC;
MACRO3(540B%HRR\,TAC,ARRAY2.REG);
MACRO3R(200B%MOVE\,REGC,ARRAY2.TYPTR^.ARRAYBPADDR);
LADDR := IC;
MACRO4(200B%MOVE\,HAC,ARRAY1.REG,START);
MACRO3(136B%IDPB\,HAC,REGC);
MACRO3R(253B%AOBJN\,ARRAY1.REG,LADDR)
END;
REGC := LREGC
END;
PROCEDURE UNPACK;
% UNPACK(Z,A,I) MEANS:
FOR L := LMIN(Z) TO LMAX(Z) DO A[L-LMIN(Z)+I] := Z[L] \
VAR
ARRAY1,OFFSET1,ARRAY2,OFFSET2: ATTR;
LADDR,START,STOP,LMIN1,LMAX1,LMIN2,LMAX2: ADDRRANGE;
LREGC: ACRANGE;
BEGIN
LREGC := REGC; START := 0;
VARIABLE(FSYS OR [COMMA,RPARENT]);
LOADADDRESS;
WITH GATTR DO
BEGIN
KIND := EXPR; REG := INDEXR;
(* 135 - prevent ill mem ref if not a variable *)
IF TYPTR = NIL
THEN TYPTR := UARRTYP
ELSE WITH TYPTR^ DO
IF FORM # ARRAYS
THEN ERROR(458)
ELSE
IF NOT ARRAYPF
THEN ERROR(458)
END;
ARRAY1 := GATTR;
IF SY = COMMA
THEN INSYMBOL
ELSE ERROR(158);
VARIABLE(FSYS OR [COMMA,RPARENT]);
LOADADDRESS;
WITH GATTR DO
BEGIN
KIND := EXPR; REG := INDEXR;
(* 135 - prevent ill mem ref if not a variable *)
IF TYPTR = NIL
THEN TYPTR := UARRTYP
ELSE WITH TYPTR^ DO
IF FORM # ARRAYS
THEN ERROR(458)
ELSE
IF ARRAYPF
OR
NOT (COMPTYPES(AELTYPE,ARRAY1.TYPTR^.AELTYPE)
AND
COMPTYPES(INXTYPE,ARRAY1.TYPTR^.INXTYPE))
THEN ERROR(458)
END;
ARRAY2 := GATTR;
IF SY = COMMA
THEN INSYMBOL
ELSE ERROR(158);
EXPRESSION(FSYS OR [RPARENT],ONREGC);
IF GATTR.TYPTR # NIL
THEN
IF GATTR.TYPTR^.FORM # SCALAR
THEN ERROR(458)
ELSE
IF NOT COMPTYPES(ARRAY2.TYPTR^.INXTYPE,GATTR.TYPTR)
THEN ERROR(458);
OFFSET2 := GATTR;
IF NOT ERRORFLAG
THEN
BEGIN
GETBOUNDS(ARRAY1.TYPTR^.INXTYPE,LMIN1,LMAX1); LMAX1 := LMAX1 - LMIN1;
GETBOUNDS(ARRAY2.TYPTR^.INXTYPE,LMIN2,LMAX2); LMAX2 := LMAX2 - LMIN2;
WITH OFFSET1 DO %MAKE OFFSET1 A CONST = LMAX1+1 \
BEGIN
TYPTR := INTPTR;
KIND := CST;
CVAL.IVAL := LMAX1 + 1
END;
IF (OFFSET2.KIND = CST)
THEN
BEGIN
STOP := OFFSET1.CVAL.IVAL;
START := OFFSET2.CVAL.IVAL - LMIN2;
IF (START < 0) OR (START > (LMAX2+1-STOP))
THEN ERROR(263);
MACRO3(505B%HRLI\,ARRAY2.REG,-STOP);
END
ELSE
BEGIN
LOAD(OFFSET1);
WITH OFFSET1 DO
MACRO3(210B%MOVN\,REG,REG);
LOAD(OFFSET2);
WITH OFFSET2 DO
BEGIN
IF LMIN2 > 0
THEN MACRO3(275B%SUBI\,REG,LMIN2)
ELSE
IF LMIN2 < 0
THEN MACRO3(271B%ADDI\,REG,-LMIN2);
IF RUNTMCHECK
THEN
BEGIN
MACRO3(301B%CAIL\,REG,0);
MACRO4(303B%CAILE\,REG,OFFSET1.REG,LMAX2+1);
SUPPORT(INDEXERROR)
END;
MACRO3(270B%ADD\,ARRAY2.REG,REG);
MACRO4(505B%HRLI\,ARRAY2.REG,OFFSET1.REG,0)
END
END;
INCREMENTREGC;
MACRO3(540B%HRR\,TAC,ARRAY1.REG);
MACRO3R(200B%MOVE\,REGC,ARRAY1.TYPTR^.ARRAYBPADDR);
LADDR := IC;
MACRO3(134B%ILDB\,HAC,REGC);
MACRO4(202B%MOVEM\,HAC,ARRAY2.REG,START);
MACRO3R(253B%AOBJN\,ARRAY2.REG,LADDR)
END;
REGC := LREGC
END;
PROCEDURE NEW;
CONST
TAGFMAX=5;
VAR
(* 42 - move GET and PUT here *)
(* 47 - add GETX and RECSIZE - no other comments in body *)
adr:supports; sizereg:acrange;
LSP,LSP1: STP; VARTS,LMIN,LMAX: INTEGER;
FIRSTLOAD:BOOLEAN;
LSIZE,LSZ: ADDRRANGE; LVAL: VALU;
LATTR: ATTR; I,TAGFC: INTEGER;
TAGFSAV: ARRAY[0..TAGFMAX] OF RECORD
TAGFVAL: INTEGER;
TAGFADDR: ADDRRANGE;
LPACKKIND:PACKKIND;
(* 21 - KEEP FROM STORING TAG VALUE IF NO PLACE TO PUT IT *)
TAGWITHID:BOOLEAN
END;
BEGIN
FOR I:=0 TO TAGFMAX DO TAGFSAV[I].TAGWITHID := FALSE;
(* 42 - move GET and PUT in here *)
(* 73 - restructure to use GETFN for file names, to allow extern files *)
(* 152 - DISPOSE *)
(* 153 - repair AC usage in DISPOSE *)
if lkey = 44 {dispose}
then begin
incrementregc; incrementregc;
sizereg := regc;
variable(fsys or [comma,colon,rparent]);
lattr := gattr; {We have to use a local copy so that
if AC1 is loaded here, that fact is
not saved for the store later.}
fetchbasis(lattr);
with lattr do {modelled after loadaddress}
macro(vrelbyte,200B%MOVE\,sizereg-1,indbit,indexr,dplmt);
end
(* 162 - fix RECSIZE *)
else if lkey in [14,35]
then begin (* all except file names *)
incrementregc; sizereg := regc ;
VARIABLE(FSYS OR [COMMA,COLON,RPARENT]);
end
(* 175 - validate files for get and put stuff, but not for RECSIZE,
which seems OK even if the file isn't open yet *)
else begin getfn(lkey in [1,3,40]); sizereg := regin+2 end;
LSP := NIL; VARTS := 0; LSIZE := 0; TAGFC := -1;
LATTR := GATTR;
IF GATTR.TYPTR # NIL
THEN
WITH GATTR.TYPTR^ DO
(* 42 - move GET and PUT in here *)
(* 152 - dispose *)
(* 162 - fix RECSIZE *)
if (lkey in [14,35,44]) and (form=pointer) or
(lkey in [1,3,15,40]) and (form=files)
THEN
BEGIN %WARNING: This code depends upon fact that ELTYPE and FILTYPE are in the same place\
IF ELTYPE # NIL
THEN
BEGIN
LSIZE := ELTYPE^.SIZE;
IF ELTYPE^.FORM = RECORDS
THEN
BEGIN
LSP := ELTYPE^.RECVAR;
END
ELSE
IF ELTYPE^.FORM = ARRAYS
THEN LSP := ELTYPE
END
END
ELSE ERROR(458);
WHILE SY = COMMA DO
BEGIN
INSYMBOL; CONSTANT(FSYS OR [COMMA,COLON,RPARENT],LSP1,LVAL);
VARTS := VARTS + 1;
%CHECK TO INSERTADDR HERE: IS CONSTANT IN TAGFIELDTYPE RANGE\
IF LSP = NIL
THEN ERROR(408)
ELSE
IF STRING(LSP1) OR (LSP1=REALPTR)
THEN ERROR(460)
ELSE
BEGIN
TAGFC := TAGFC + 1;
IF TAGFC > TAGFMAX
THEN
BEGIN
ERROR(409);TAGFC := TAGFMAX; GOTO 1
END;
IF LSP^.FORM = TAGFWITHID
THEN
BEGIN
IF LSP^.TAGFIELDP # NIL
THEN
IF COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP1)
THEN
WITH TAGFSAV[TAGFC],LSP^.TAGFIELDP^ DO
BEGIN
TAGFVAL := LVAL.IVAL;
TAGFADDR:= FLDADDR;
LPACKKIND:= PACKF;
(* 21 - KEEP FROM STORING TAG VALUE INTO NON-EXISTENT FIELD *)
TAGWITHID:=TRUE
END
ELSE
BEGIN
ERROR(458);GOTO 1
END
END
ELSE
IF LSP^.FORM=TAGFWITHOUTID
THEN
BEGIN
IF NOT COMPTYPES(LSP^.TAGFIELDTYPE,LSP1)
THEN
BEGIN
ERROR(458); GOTO 1
END
END
ELSE
BEGIN
ERROR(358);GOTO 1
END;
LSP1 := LSP^.FSTVAR;
WHILE LSP1 # NIL DO
WITH LSP1^ DO
IF VARVAL.IVAL = LVAL.IVAL
THEN
BEGIN
LSIZE :=SIZE; LSP := SUBVAR; GOTO 1
END
ELSE LSP1:=NXTVAR;
LSIZE := LSP^.SIZE; LSP := NIL
END;
1:
END %WHILE\ ;
IF SY = COLON
THEN
BEGIN
INSYMBOL;
EXPRESSION(FSYS OR [RPARENT],ONREGC);
IF LSP = NIL
THEN ERROR(408)
ELSE
IF LSP^.FORM # ARRAYS
THEN ERROR(259)
ELSE
BEGIN
IF NOT COMPTYPES(GATTR.TYPTR,LSP^.INXTYPE)
THEN
ERROR(458);
LSZ := 1; LMIN := 1;
IF LSP^.INXTYPE # NIL
THEN
GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX);
IF LSP^.AELTYPE # NIL
THEN LSZ := LSP^.AELTYPE^.SIZE;
LOAD(GATTR);
(* 47 - add bounds checking *)
if runtmcheck
then begin
macro3(301B%cail\,regc,lmin);
macro3(303B%caile\,regc,lmax);
support(indexerror)
end;
IF LSZ # 1
THEN
MACRO3(221B%IMULI\,REGC,LSZ);
IF LSP^.ARRAYPF
THEN
BEGIN
(* 30 - added BITMAX DIV, per Nagel's instructions *)
(* 47 - repair calculation, and adjust for LMIN *)
lsz := bitmax div lsp^.aeltype^.bitsize-1-(lmin-1);
if lsz > 0
then macro3(271B%addi\,regc,lsz)
else if lsz < 0
then macro3(275B%subi\,regc,-lsz);
INCREMENTREGC; REGC := REGC - 1;
%FOR TESTING BECAUSE IDIV WORKS ON AC+1 TOO\
MACRO3(231B%IDIVI\,REGC,BITMAX DIV LSP^.AELTYPE^.BITSIZE);
LSZ := LSIZE - LSP^.SIZE;
END
ELSE
LSZ := LSIZE - LSP^.SIZE - LSZ*(LMIN - 1);
(* 42 - change for GET and PUT *)
MACRO4(201B%MOVEI\,SIZEREG,REGC,LSZ);
END
END
ELSE MACRO3(201B%MOVEI\,SIZEREG,LSIZE);
(* 24 - DON'T ZERO CORE UNLESS CHECKING *)
(* 25 - USE /ZERO NOW INSTEAD *)
(* 27 - add NEWZ *)
(* 42 - move get and put in here *)
if lattr.typtr # nil
then begin
case lkey of
1:if comptypes(lattr.typtr^.filtype,charptr)
then adr := getcharacter
else adr := getfile;
3:adr := putfile;
14:if zero
then adr := clearalloc
else adr := allocate;
15:with gattr do
begin typtr:=intptr; reg:=sizereg;kind:=expr;regc:=sizereg end;
35:adr := clearallocate;
40:if comptypes(lattr.typtr^.filtype,charptr)
then error(458)
else adr:=getxf;
(* 173 - internal files *)
44:if lattr.typtr^.eltype <> nil
then if lattr.typtr^.eltype^.hasfile
then adr := withfiledeallocate
else adr := deallocate
else adr := deallocate
end;
{Perhaps this is premature optimization, but NEW and DISPOSE do not save any
ac's. Hence any that are active here have to be saved by the caller. Since
only ac's 1 to 6 are used by the NEW and DISPOSE, we save only things <= 6:
any WITH ac's <= 6 (a fairly rare case)
lattr.indexr, if it is <= 6. This is used in cases such as
new(a^.b^.c)
to save information needed to get to C again after the call.
ac 1 sometimes contains the display pointer for a higher-level block.
However by gerrymandering LATTR, we force this to be recomputed after
the call by FETCHBASIS, so it is not saved.
}
(* 154 - don't clobber With AC's *)
if (lkey in [14,35,44]) and (regcmax < 6)
then for i := 0 to withix do
with display[top-i] do
if (cindr#0) and (cindr <= 6)
then macro4(202B%MOVEM\,cindr,basis,clc);
(* 153 - save AC's *)
(* 154 - don't need to save WITH acs *)
(* 171 - more AC saving *)
if (lkey in [14,35,44])
then begin
if (lattr.indexr > regin) and (lattr.indexr <= 6)
then macro3(261B%PUSH\,topp,lattr.indexr);
if (lattr.packfg = packk) and (lattr.bpaddr > regin)
and (lattr.bpaddr <= 6)
then macro3(261B%PUSH\,topp,lattr.bpaddr);
support(adr);
if (lattr.packfg = packk) and (lattr.bpaddr > regin)
and (lattr.bpaddr <= 6)
then macro3(262B%POP\,topp,lattr.bpaddr);
if (lattr.indexr > regin) and (lattr.indexr <= 6)
then macro3(262B%POP\,topp,lattr.indexr);
end
else if lkey#15
then support(adr);
(* 154 - restore WITH ac's *)
if (lkey in [14,35,44]) and (regcmax < 6)
then for i := 0 to withix do
with display[top-i] do
if (cindr#0) and (cindr <= 6)
then macro4(200B%MOVE\,cindr,basis,clc);
end;
if (lkey=14)or(lkey=35)
then begin
REGC := REGIN+1;
FIRSTLOAD := TRUE;
FOR I := 0 TO TAGFC DO
WITH TAGFSAV[I] DO
(* 21 - KEEP FROM STORING TAG VALUE INTO NON-EXISTENT FIELD *)
IF TAGWITHID THEN
BEGIN
MACRO3(201B%MOVEI\,HAC,TAGFVAL);
CASE LPACKKIND OF
NOTPACK: MACRO4(202B%MOVEM\,HAC,REGC,TAGFADDR);
HWORDR:MACRO4(542B%HRRM\,HAC,REGC,TAGFADDR);
HWORDL:MACRO4(506B%HRLM\,HAC,REGC,TAGFADDR);
PACKK :
BEGIN
IF FIRSTLOAD
THEN
BEGIN
MACRO3(200B%MOVE\,TAC,REGC);
FIRSTLOAD := FALSE
END;
MACRO3R(137B%DPB\,HAC,TAGFADDR)
END
END%CASE\
END;
STORE(REGC,LATTR)
(* 42 - move GET and PUT in here *)
end
(* 152 - DISPOSE *)
(* 153 - make reg usage safer *)
else if lkey=44
then begin
incrementregc;
macro3(201B%MOVEI\,regc,377777B%nil\);
store(regc,lattr)
end
END %NEW\ ;
(* 46 - major reorganization to handle all arg formats *)
PROCEDURE CALLI;
type argform=(bareac,xwd,twowords,oneword);
VAR LSP:STP; LVAL,acval:VALU;
LH,RH,BOOL,RESUL:ATTR;
arg:argform;
BEGIN
arg := xwd; %default format\
CONSTANT(FSYS OR [RPARENT,COMMA],LSP,LVAL);
IF NOT(COMPTYPES(INTPTR,LSP))
THEN ERROR(458);
IF SY = COMMA
THEN INSYMBOL
ELSE ERROR(158);
if sy=comma %,,word\
then begin
insymbol;
arg := oneword;
expression(fsys or [rparent,comma],onregc);
load(gattr);
lh := gattr
end
else if sy=colon %:ac\
then begin
arg := bareac;
insymbol;
constant(fsys or [rparent,comma],lsp,acval);
if not(comptypes(intptr,lsp))
then error(458)
end
else begin %lh,rh or w1:w2\
EXPRESSION(FSYS OR [RPARENT,COMMA,COLON],ONREGC);
LOAD(GATTR);
LH := GATTR;
IF SY = COMMA
THEN INSYMBOL
else if sy=colon
then begin arg:=twowords; insymbol end
else error(158);
EXPRESSION(FSYS OR [RPARENT,COMMA],ONREGC);
IF GATTR.TYPTR # NIL
THEN IF (GATTR.TYPTR^.FORM <= POWER) or (arg=twowords)
THEN LOAD(GATTR)
ELSE BEGIN
LOADADDRESS;
GATTR.KIND:=EXPR;
GATTR.REG:=GATTR.INDEXR
END;
RH := GATTR;
end %of lh,rh and w1:w2\;
IF SY = COMMA
THEN INSYMBOL
ELSE ERROR(158);
VARIABLE(FSYS OR [RPARENT,COMMA]);
IF GATTR.TYPTR = NIL
THEN ERROR(458)
ELSE IF NOT(GATTR.TYPTR^.FORM IN [SUBRANGE,SCALAR])
THEN ERROR(458)
ELSE LOADADDRESS;
RESUL:=GATTR;
IF SY = COMMA
THEN INSYMBOL
ELSE ERROR(158);
VARIABLE(FSYS OR [RPARENT]);
IF NOT COMPTYPES(BOOLPTR,GATTR.TYPTR)
THEN ERROR(158)
ELSE LOADADDRESS;
BOOL := GATTR;
IF NOT ERRORFLAG
THEN BEGIN
case arg of
bareac: regc := acval.ival;
xwd: begin regc := rh.reg; macro3(504B%hrl\,rh.reg,lh.reg) end;
oneword: regc := lh.reg;
twowords: begin
regc := lh.reg;
if (regc+1) # rh.reg
then macro3(200B%move\,regc+1,rh.reg)
end
end %case\;
macro3(201B%movei\,tac,1);
macro4(202B%movem\,tac,bool.indexr,0);
MACRO3(047B%CALLI\,REGC,LVAL.IVAL);
MACRO4(402B%SETZM\,0,BOOL.INDEXR,0);
MACRO4(202B%MOVEM\,REGC,RESUL.INDEXR,0)
END
END;
(* 61 - tops20 system version *)
procedure jsys;
var
lval:valu; lsp:stp; jsysnum,numrets,i:integer;
retsave:attr; saveret,ercal,done1: Boolean;
realregc:acrange;
(* 133 - add variable to allow saving stuff in display *)
savelc:addrrange;
procedure loadarg;
(* Handles input args for jsys:
simple vars - use their values
sets - use LH word only
files - use jfn word
packed arrays - make byte ptr to it
other - make pointer to it
*)
begin
expression (fsys or [rparent,comma,semicolon,colon],onfixedregc);
if gattr.typtr # nil
then if (gattr.typtr^.form < power)
then load(gattr)
else if (gattr.typtr^.form = power)
then begin
(* 77 - can't treat as integer. have to load both words and throw away 2nd *)
load(gattr);
regc := regc-1;
end
else if (gattr.typtr^.form = files)
then begin
loadaddress;
with lastfile^ do
if (vlev = 0) and (not main)
then begin vaddr := ic-1; code.information[cix] := 'E' end;
macro4(200b%move\,regc,regc,filjfn)
end
else if (gattr.typtr^.form = arrays) and gattr.typtr^.arraypf
then begin
loadaddress;
macro3r(500b%hll\,regc,gattr.typtr^.arraybpaddr);
macro3(621b%tlz\,regc,17b)
end
else loadaddress
end;
procedure storearg;
(* stores results of jsys. As above, but error for
anything bigger than a word *)
begin
variable(fsys or [rparent,comma]);
if gattr.typtr # nil
then if (gattr.typtr^.form < power)
then store(realregc,gattr)
else if (gattr.typtr^.form = power)
then begin
gattr.typtr := intptr;
store(realregc,gattr)
end
else if (gattr.typtr^.form = files)
then begin
loadaddress; {addr of file now in REGC}
with lastfile^ do
if (vlev = 0) and (not main)
then begin vaddr:=ic-1; code.information[cix] := 'E' end;
(* 173 - internal files *)
{We have to compile code to see if the file is initialized. If not,
call INITB. to do so. INITB. needs the file in AC 2. Note that
the AC use here is such that REGC is always above 2, so the only
reason for 2 not to be free is that realregc is using it. This is
certainly not the best possible code, but at this point I am going
for the last code in the compiler to implement it.}
macro3(250b%exch\,2,regc);
macro4(200b%move\,0,2,filtst);
macro3(302b%caie\,0,314157B);
support(initfileblock);
if realregc = 2
then macro4(202b%movem\,regc,2,filjfn)
else macro4(202b%movem\,realregc,2,filjfn)
end
else error(458)
end;
begin (* jsys *)
ercal := false; saveret := false; numrets := 0; done1 := false;
constant(fsys or [rparent,comma,semicolon],lsp,lval);
jsysnum := lval.ival;
if not comptypes (intptr, lsp)
then error(458);
if sy = comma
then begin (* return spec *)
insymbol;
constant(fsys or [rparent,comma,semicolon],lsp,lval);
if lval.ival < 0
then ercal := true;
numrets := abs(lval.ival);
if not comptypes (intptr, lsp)
then error(458);
if sy = comma
then begin (* return var *)
insymbol;
variable(fsys or [rparent,semicolon]);
if comptypes (intptr,gattr.typtr)
then begin saveret := true; retsave := gattr end
else error (459)
end
end; (* return spec *)
if sy = semicolon
then begin (* prolog *)
insymbol;
regc := 1;
if sy # semicolon
then loop (* non-empty prolog *)
loadarg;
if sy = colon
then begin
insymbol;
realregc := regc;
loadarg;
macro3(504b%hrl\,realregc,realregc);
macro3(540b%hrr\,realregc,regc);
regc := realregc
end;
if not done1
then begin
(* 133 - save in display instead of PUSH P, *)
{Here we prepared a place on the display to store the value}
savelc := lc;
lc := lc+1;
if lc > lcmax
then lcmax := lc;
macro4(202B%movem\,2,basis,savelc);
done1 := true;
regc := 1
end;
exit if sy # comma;
insymbol
end (* non-empty prolog *)
end; (* prolog *)
(* main call *)
if done1
(* 133 - save in display instead of POP P, *)
then begin
macro4(200B%move\,1,basis,savelc);
lc := savelc
end;
if saveret
then macro3(201b%movei\,0,numrets+1);
macro3(104b%jsys\,0,jsysnum);
if ercal
then begin
macro3r(320b%jump\,16b,ic+numrets);
numrets := numrets -1
end;
for i := 1 to numrets do
if saveret then
macro3(275b%subi\,0,1)
else macro3(255b%jfcl\,0,0);
if sy = semicolon (* if epilog, save reg a over store *)
then begin
(* 133 - use display instead of stack to save *)
{find a place in the display to save ac 2}
savelc := lc;
lc := lc + 1;
if lc > lcmax
then lcmax := lc;
macro4(202B%movem\,2,basis,savelc);
macro3(200b%move\,2,1);
done1 := true
end
else done1 := false;
if saveret
then store(0,retsave);
if sy = semicolon
then begin (* epilog *)
realregc := 1;
repeat
insymbol;
regc := 4; (* so temp ac's start at 5 *)
realregc := realregc + 1;
if realregc > 4
then error(458);
storearg;
if done1
then begin
(* 133 - use display instead of stack to store ac 2 *)
macro4(200B%move\,2,basis,savelc);
lc := savelc;
realregc := 1;
done1 := false
end
until sy # comma
end (* epilog *)
end; (* jsys *)
PROCEDURE MARK;
BEGIN
VARIABLE(FSYS OR [RPARENT]);
IF COMPTYPES(INTPTR,GATTR.TYPTR)
THEN
(* 12 - REWRITE FOR NEW DYNAMIC MEMORY *)
(* 122 - retrofit KA code *)
(* 132 - separate KA10 into NOVM and KACPU *)
if novm
then begin
loadaddress;
macro4(202B%movem\,newreg,gattr.indexr,0)
end
else
BEGIN
LOADADDRESS;
INCREMENTREGC;
MACRO3R(200B%MOVE\,REGC,LSTNEW);
LSTNEW:=IC-1; %GLOBAL FIXUP\
MACRO4(202B%MOVEM\,REGC,GATTR.INDEXR,0)
END
ELSE ERROR(459)
END %MARK\ ;
PROCEDURE RELEASE;
BEGIN
EXPRESSION(FSYS OR [RPARENT],ONREGC);
IF GATTR.TYPTR = INTPTR
THEN
BEGIN
(* 12 - RECODE FOR NEW DYNAMIC MEMORY *)
LOAD(GATTR);
(* 122 - retrofit for KA *)
(* 132 - separate KA10 into NOVM and KACPU *)
if novm
then macro3(200B%move\,newreg,regc)
ELSE BEGIN
MACRO3R(202B%MOVEM\,REGC,LSTNEW);
LSTNEW := IC-1; % GLOBAL FIXUP \
end
END
ELSE ERROR(458)
END %RELEASE\ ;
PROCEDURE GETLINENR;
BEGIN
(* 33 - ALLOW GETFILENAME WITH NON-TEXT *)
(* 171 - PREDECL FILES ARE SPECIAL *)
GETFILENAME(INFILE,TRUE,THISFILE,GOTARG,TRUE);
IF NOT GOTARG
THEN ERROR(554);
IF GATTR.KIND <> VARBL
THEN ERROR(458)
ELSE IF GATTR.TYPTR # NIL
THEN
IF COMPTYPES(CHARPTR,GATTR.TYPTR^.AELTYPE) AND (GATTR.TYPTR^.FORM = ARRAYS)
THEN
BEGIN
MACRO4(200B%MOVE\,REGC,REGC,FILLNR); STORE(REGC,GATTR)
END
ELSE ERROR(458);
END;
PROCEDURE GETINTEGERFILENAME(DEFAULTNAME : ALFA);
VAR
LCP : CTP; LID : ALFA;
BEGIN
LID := ID;
ID := DEFAULTNAME; SEARCHID([VARS],LCP);
SELECTOR(FSYS OR FACBEGSYS OR [COMMA], LCP); LOADADDRESS;
WITH LCP^, IDTYPE^ DO
IF (FORM = FILES) AND (VLEV = 0) AND (NOT MAIN)
THEN
BEGIN
VADDR:= IC-1; CODE.INFORMATION[CIX] := 'E'
END;
ID := LID
END;
PROCEDURE PUT8BITSTOTTY;
BEGIN
EXPRESSION(FSYS OR [RPARENT],ONREGC) ;
LOAD(GATTR);
MACRO3(051B%TTCALL\,15B%IONEOU\,GATTR.REG)
END %PUT8BITSTOTTY\ ;
PROCEDURE PAGE;
BEGIN
(* 33 - ALLOW GETFILENAME WITH NON-TEXT *)
(* 171 - PREDECL FILES ARE SPECIAL *)
GETFILENAME(OUTFILE,TRUE,THISFILE,GOTARG,TRUE);
IF GOTARG
THEN ERROR(554);
SUPPORT(PUTPAGE)
END;
(* 63 - support for tops-20 time and runtime *)
procedure jsysf(jsysnum,hireg:integer);
var i:integer;
begin
if hireg > regc
then hireg := regc;
for i := 2 to hireg do
macro3(261B%push\,topp,i);
if jsysnum = 15B
then macro3(211B%movni\,1,5);
macro3(104B%jsys\,0,jsysnum);
with gattr do
begin
incrementregc; typtr := intptr; reg := regc; kind := expr;
macro3(200B%move\,regc,1)
end;
for i := hireg downto 2 do
macro3(262B%pop\,topp,i)
end;
PROCEDURE RUNTIME;
BEGIN
(* 63 - TOPS20 *)
IF TOPS10
THEN WITH GATTR DO
BEGIN
INCREMENTREGC; TYPTR := INTPTR; REG := REGC; KIND := EXPR;
MACRO3(047B,REGC,30B%PJOB-UUO\);
MACRO3(047B,REGC,27B%RUNTIM-UUO\)
END
ELSE JSYSF(15B%RUNTM\,3)
END;
PROCEDURE ABS;
BEGIN
WITH GATTR DO
IF (TYPTR = INTPTR) OR (TYPTR = REALPTR)
THEN
WITH CODE.INSTRUCTION[CIX] DO
IF INSTR = 200B%MOVE\
THEN INSTR := 214B%MOVM\
ELSE MACRO3(214B%MOVM\,REG,REG)
ELSE
BEGIN
ERROR(459); TYPTR:= INTPTR
END
END %ABS\ ;
PROCEDURE TIME;
BEGIN
(* 63 - TOPS20 *)
WITH GATTR DO
BEGIN
INCREMENTREGC; TYPTR := INTPTR; REG := REGC; KIND := EXPR;
if tops10
then MACRO3(047B,REGC,23B%MSTIME-UUO\)
else begin
support(getdaytime);
macro3(262B%POP\,17B,regc)
end
END
END;
PROCEDURE SQR;
BEGIN
WITH GATTR DO
IF TYPTR = INTPTR
THEN MACRO3(220B%IMUL\,REG,REG)
ELSE
IF TYPTR = REALPTR
THEN MACRO3(164B%FMPR\,REG,REG)
ELSE
BEGIN
ERROR(459); TYPTR := INTPTR
END
END %SQR\ ;
PROCEDURE TRUNC;
VAR INSTRUC:1..777;
BEGIN
IF LKEY = 5
THEN INSTRUC := 122B%FIX\
ELSE INSTRUC := 126B%FIXR\;
IF GATTR.TYPTR # REALPTR
THEN ERROR(459)
ELSE
(* 2 - hard code TRUNC using KI-10 op code *)
(* 10 - ADD ROUND *)
(* 101 - fix bad code generation for fix and fixr *)
(* 122 - put back KA code *)
(* 132 - separate KA10 into NOVM and KACPU *)
if kacpu
then begin
if lkey=5
then macro3(551B%hrrzi\,tac,gattr.reg)
else macro3(561B%hrroi\,tac,gattr.reg);
support(convertrealtointeger);
end
ELSE WITH CODE.INSTRUCTION[CIX] DO
IF (INSTR = 200B%MOVE\) AND (AC = GATTR.REG)
THEN INSTR := INSTRUC
ELSE MACRO3(INSTRUC,GATTR.REG,GATTR.REG);
GATTR.TYPTR := INTPTR
END %TRUNC\ ;
PROCEDURE ODD;
BEGIN
WITH GATTR DO
BEGIN
IF TYPTR # INTPTR
THEN ERROR(459);
MACRO3(405B%ANDI\,REG,1);
TYPTR := BOOLPTR
END
END %ODD\ ;
PROCEDURE ORD;
BEGIN
IF GATTR.TYPTR # NIL
THEN
IF GATTR.TYPTR^.FORM >= POWER
THEN ERROR(459);
GATTR.TYPTR := INTPTR
END %ORD\ ;
PROCEDURE CHR;
BEGIN
IF GATTR.TYPTR # INTPTR
THEN ERROR(459);
GATTR.TYPTR := CHARPTR
END %CHR\ ;
PROCEDURE PREDSUCC;
VAR
LSTRPTR:STP; LATTR: ATTR;
BEGIN
IF GATTR.TYPTR # NIL
THEN
IF (GATTR.TYPTR^.FORM>SUBRANGE) OR (GATTR.TYPTR=REALPTR)
THEN ERROR(459)
ELSE
IF RUNTMCHECK
THEN
BEGIN
LSTRPTR:=GATTR.TYPTR;
IF (LSTRPTR^.FORM=SUBRANGE) AND (LSTRPTR^.RANGETYPE #NIL)
THEN LSTRPTR:=LSTRPTR^.RANGETYPE;
IF LKEY=9
THEN
BEGIN
IF LSTRPTR=INTPTR
THEN
BEGIN
MACRO3R(255B%JFCL\,10B,IC+1);
MACRO3(275B%SUBI\,REGC,1 );
MACRO3R(255B%JFCL\,10B,IC+2);
MACRO3(334B%SKIPA\,0,0 );
SUPPORT(ERRORINASSIGNMENT)
END
ELSE% CHAR OR DECLARED \
BEGIN
MACRO3R(365B%SOJGE\,REGC,IC+2);
SUPPORT(ERRORINASSIGNMENT)
END
END % LKEY = 9 \
ELSE % LKEY = 10 \
BEGIN
IF LSTRPTR=INTPTR
THEN
BEGIN
MACRO3R(255B%JFCL \,10B,IC+1);
MACRO3(271B%ADDI \,REGC,1 );
MACRO3R(255B%JFCL \,10B,IC+2);
MACRO3(334B%SKIPA\,0,0 );
SUPPORT(ERRORINASSIGNMENT)
END
ELSE %CHAR OR DECLARED\
BEGIN
WITH LATTR DO
BEGIN
TYPTR := LSTRPTR; KIND := CST; CVAL.IVAL := 0;
IF LSTRPTR=CHARPTR
THEN CVAL.IVAL := 177B
ELSE
IF LSTRPTR^.FCONST # NIL
THEN CVAL.IVAL:=LSTRPTR^.FCONST^.VALUES.IVAL;
MAKECODE(311B%CAML\,REGC,LATTR);
SUPPORT(ERRORINASSIGNMENT);
MACRO3(271B%ADDI \,REGC,1 );
END
END
END % LKEY = 10 \;
END % RUNTMCHECK \
ELSE
IF LKEY = 9
THEN MACRO3(275B%SUBI\,REGC,1)
ELSE MACRO3(271B%ADDI\,REGC,1)
END %PREDSUCC\ ;
PROCEDURE EOFEOLN;
BEGIN
(* 33 - USE GETFILENAME, SO DEFAULTS TO INPUT *)
(* 171 - PREDECL FILES ARE SPECIAL *)
GETFILENAME(INFILE,FALSE,THISFILE,GOTARG,TRUE);
IF GOTARG
THEN ERROR(554);
WITH GATTR DO
BEGIN
KIND := EXPR; REG := INDEXR;
IF LKEY=11
THEN
BEGIN
MACRO4(332B%SKIPE\,REG,REG,FILEOF) ;
MACRO3(201B%MOVEI\,REG,1) ;
END
ELSE MACRO4(200B%MOVE\,REG,REG,FILEOL);
TYPTR := BOOLPTR
END
END %EOF\ ;
PROCEDURE PROTECTION;
(* FOR DETAILS SEE DEC-SYSTEM-10 MONITOR CALLS MANUAL, 3.2.4 *)
BEGIN
EXPRESSION ( FSYS OR [RPARENT], ONREGC );
IF GATTR.TYPTR = BOOLPTR
(* 63 - TOPS20 *)
THEN IF TOPS10
THEN
BEGIN
LOAD(GATTR);
MACRO3(047B%CALLI\,REGC,36B%SETUWP\);
MACRO3(254B%HALT\,4,0)
END
ELSE
ELSE ERROR(458)
END;
PROCEDURE CALLNONSTANDARD;
VAR
NXT,LNXT,LCP: CTP;
LSP: STP;
(* 33 - PROC PARAM.S*)
PKIND,LKIND: IDKIND; LB: BOOLEAN;
SAVECOUNT,P,I,NOFPAR: INTEGER;
TOPPOFFSET,OFFSET,PARLIST,ACTUALPAR,FIRSTPAR,LLC: ADDRRANGE;
LREGC: ACRANGE;
(* 111 - STRING, POINTER *)
procedure paramfudge;
var lmin,lmax:integer;
(* This is used to handle special parameter types with
reduced type checking, such as STRING, POINTER. They
are always one of STRINGPTR, POINTERPTR, or POINTERREF.
STRINGPTR is for STRING, the other two for POINTER.
POINTERREF is for call by ref *)
begin
with gattr.typtr^ do
if lsp=stringptr
then if (form=arrays) and arraypf
then if comptypes(aeltype,charptr)
then begin (* STRING *)
getbounds (gattr.typtr^.inxtype, lmin, lmax);
loadaddress;
incrementregc;
macro3(201B%movei\,regc,lmax-lmin+1);
end
else error(503)
else error(503)
else if form=pointer {pointerptr or pointerref}
then if eltype <> nil
then begin (* POINTER *)
(* 202 - fix up pointer by ref *)
if lsp = pointerptr
then load(gattr)
else loadaddress;
incrementregc;
macro3(201B%movei\,regc,eltype^.size)
end
else (* bad type decl - already have error *)
else error(503);
gattr.typtr := lsp (* so comptypes later succeeds *)
end;
BEGIN
NOFPAR:= 0; TOPPOFFSET := 0; PARLIST := 0; ACTUALPAR := 0;
WITH FCP^ DO
BEGIN
NXT := NEXT; LKIND := PFKIND;
IF KLASS = FUNC
THEN FIRSTPAR := 2
ELSE FIRSTPAR := 1;
(* 33 - PROC PARAM.S *)
IF LKIND = ACTUAL
THEN IF EXTERNDECL
THEN LIBRARY[LANGUAGE].CALLED:= TRUE;
SAVECOUNT := REGC - REGIN;
IF SAVECOUNT > 0
THEN
BEGIN
LLC := LC ;
LC := LC + SAVECOUNT ;
IF LC > LCMAX
THEN LCMAX := LC ;
IF SAVECOUNT > 3
THEN
BEGIN
MACRO3(505B%HRLI\,TAC,2);
MACRO4(541B%HRRI\,TAC,BASIS,LLC);
MACRO4(251B%BLT\,TAC,BASIS,LLC+SAVECOUNT-1)
END
ELSE FOR I := 1 TO SAVECOUNT DO MACRO4(202B%MOVEM\,REGIN+I,BASIS,LLC+I-1)
END;
LREGC:= REGC;
IF LKIND = FORMAL
THEN REGC := REGIN
ELSE IF LANGUAGE # PASCALSY
THEN REGC:= PARREGCMAX
ELSE REGC:= REGIN
END;
IF SY = LPARENT
THEN
BEGIN
REPEAT
LB := FALSE; %DECIDE WHETHER PROC/FUNC MUST BE PASSED\
IF LKIND = ACTUAL
THEN
BEGIN
IF NXT = NIL
THEN ERROR(554)
ELSE LB := NXT^.KLASS IN [PROC,FUNC]
END
(* 33 - PROC PARAM.S *)
ELSE LB := FALSE;
%FOR FORMAL PROC/FUNC LB IS FALSE AND EXPRESSION
WILL BE CALLED, WHICH WILL ALLWAYS INTERPRET A PROC/FUNC ID
AT ITS BEGINNING AS A CALL RATHER THAN A PARAMETER PASSING.
IN THIS IMPLEMENTATION, PARAMETER PROCEDURES/FUNCTIONS
ARE THEREFORE NOT ALLOWED TO HAVE PROCEDURE/FUNCTION
PARAMETERS\
INSYMBOL;
IF LB
THEN %PASS FUNCTION OR PROCEDURE\
BEGIN
IF SY # IDENT
THEN
ERRANDSKIP(209,FSYS OR [COMMA,RPARENT])
ELSE
BEGIN
IF NXT^.KLASS = PROC
THEN SEARCHID([PROC],LCP)
ELSE
BEGIN
SEARCHID([FUNC],LCP);
IF NOT COMPTYPES(LCP^.IDTYPE,NXT^.IDTYPE)
THEN
ERROR(555)
END;
INSYMBOL;
IFERRSKIP(166,FSYS OR [COMMA,RPARENT])
END;
(* 33 - PROC PARAM.S *)
WITH LCP^ DO
IF (PFDECKIND = STANDARD) OR (PFKIND = ACTUAL) AND (LANGUAGE # PASCALSY)
THEN ERROR (466)
ELSE BEGIN
INCREMENTREGC;
(* 67 - fix proc param's *)
if pflev > 1
then p := level - pflev
else p := 0;
IF PFKIND = ACTUAL
THEN BEGIN
IF P = 0
THEN MACRO3(514B%HRLZ\,REGC,BASIS)
ELSE IF P=1
THEN MACRO4(514B%HRLZ\,REGC,BASIS,-1)
ELSE %P>1\
BEGIN
MACRO4(550B%HRRZ\,REGC,BASIS,-1);
FOR I := 3 TO P DO MACRO4(550B%HRRZ\,REGC,REGC,-1);
MACRO4(514B%HRLZ\,REGC,REGC,-1)
END;
IF PFADDR = 0
THEN BEGIN
(* 67 - fix typo: R in macro3r omitted *)
MACRO3R(541B%HRRI\,REGC,LINKCHAIN[P]);
LINKCHAIN[P] := IC - 1;
IF EXTERNDECL
THEN CODE.INFORMATION[CIX] := 'E'
ELSE CODE.INFORMATION[CIX] := 'F'
END
ELSE MACRO3R(541B%HRRI\,REGC,PFADDR);
END %OF PFKIND = ACTUAL \
ELSE %PFKIND = FORMAL \
IF P = 0
THEN MACRO4(200B%MOVE\,REGC,BASIS,PFADDR)
ELSE
BEGIN
MACRO4(200B%MOVE\,REGC,BASIS,-1);
FOR I := 2 TO P DO MACRO4(200B%MOVE\,REGC,REGC,-1);
MACRO4(200B%MOVE\,REGC,REGC,PFADDR)
END
END;
END %IF LB\
ELSE
BEGIN
EXPRESSION(FSYS OR [COMMA,RPARENT],ONFIXEDREGC);
IF GATTR.TYPTR # NIL
THEN
(* 33 - PROC PARAM.S *)
BEGIN
%NOTE : WE TREAT ALL PARAM'S OF A FORMAL PROC AS ACTUAL\
IF (NXT # NIL) OR (LKIND = FORMAL)
THEN
BEGIN
(*33 - PROC PARAM.S *)
IF LKIND = FORMAL
THEN BEGIN LSP := GATTR.TYPTR; PKIND := ACTUAL END
ELSE BEGIN LSP := NXT^.IDTYPE; PKIND := NXT^.VKIND END;
IF LSP # NIL
THEN
BEGIN
(* 33 - PROC PARAM.S *)
(* 161 - fix STRING,POINTER *)
IF (PKIND = ACTUAL)
THEN
IF LSP^.SIZE <= 2
THEN
BEGIN
(* 104 - more range checking for subrange things *)
(* 202 - pointer by ref *)
if (lsp = stringptr) or
(lsp = pointerptr) or
(lsp = pointerref)
then paramfudge
else if lsp^.form = subrange
then loadsubrange(gattr,lsp)
else load(gattr);
IF COMPTYPES(REALPTR,LSP)
AND (GATTR.TYPTR = INTPTR)
THEN MAKEREAL(GATTR)
END
ELSE
BEGIN
LOADADDRESS;
(* 33 - PROC PARAM.S *)
IF (LKIND = ACTUAL) AND (FCP^.LANGUAGE # PASCALSY)
THEN CODE.INSTRUCTION[CIX].INSTR := 505B%HRLI\
END
ELSE
IF GATTR.KIND = VARBL
THEN LOADADDRESS
ELSE ERROR(463) ;
(* 22 - ALLOW EXTERNAL FILE REFERENCES *)
IF GATTR.TYPTR#NIL
THEN IF GATTR.TYPTR^.FORM=FILES
THEN WITH LASTFILE^ DO
IF (VLEV=0) AND (NOT MAIN)
THEN BEGIN VADDR:=IC-1;CODE.INFORMATION[CIX]:='E' END;
(* 64 - fix proc param's that don't fit in ac's *)
IF NOT COMPTYPES(LSP,GATTR.TYPTR)
THEN ERROR(503)
END
END
END
(* 33 - PROC PARAM.S *)
END;
IF REGC>PARREGCMAX
THEN
(* 33 - PROC PARAM.S *)
(* NOTE: CURRENTLY WE PUNT IF ARG'S DON'T FIT IN AC'S IN FORMAL PROC*)
IF LKIND=FORMAL
THEN ERROR(413)
ELSE BEGIN
IF TOPPOFFSET = 0
THEN
BEGIN
LNXT := FCP^.NEXT ;
IF FCP^.LANGUAGE = PASCALSY
(* 62 - clean up offset *)
then toppoffset := fcp^.poffset + 1
ELSE
BEGIN
TOPPOFFSET := 1 + FIRSTPAR;
REPEAT
WITH LNXT^ DO
BEGIN
NOFPAR := NOFPAR +1;
TOPPOFFSET := TOPPOFFSET + 1;
IF VKIND = ACTUAL
THEN TOPPOFFSET := TOPPOFFSET + IDTYPE^.SIZE;
IF LKIND = ACTUAL
THEN LNXT := NEXT
END;
UNTIL LNXT = NIL;
PARLIST := 1 + FIRSTPAR;
ACTUALPAR := PARLIST + NOFPAR
END;
(* 104 - TOPS20 DETECTION OF STACK OVERFLOW *)
(* 115 - TENEX *)
IF KLCPU AND NOT TOPS10
THEN MACRO3(105B%ADJSP\,TOPP,TOPPOFFSET)
ELSE MACRO3(271B%ADDI\,TOPP,TOPPOFFSET);
(* 54 - keep track of how many loc's above stack are used *)
stkoff := stkoff + toppoffset;
if stkoff > stkoffmax
then stkoffmax := stkoff
END ;
WITH NXT^ DO
BEGIN
IF FCP^.LANGUAGE = PASCALSY
THEN
(* 64 - fix parameter proc's that don't fit in ac's *)
if klass # vars
then macro4(202b%movem\,regc,topp,pfaddr+1-toppoffset)
ELSE BEGIN
(* 52 - if VAR, size is always 1 *)
IF (VKIND=ACTUAL) AND (IDTYPE^.SIZE=2)
THEN
BEGIN
MACRO4(202B%MOVEM\,REGC,TOPP,VADDR+2-TOPPOFFSET);
REGC := REGC - 1
END;
(* 201 - zero size things *)
IF (IDTYPE^.SIZE > 0) OR (VKIND <> ACTUAL)
THEN MACRO4(202B%MOVEM\,REGC,TOPP,VADDR+1-TOPPOFFSET)
END
ELSE
(* 64 - proc param's that don't fit in ac's *)
if klass # vars
then error(466)
ELSE BEGIN
IF VKIND = ACTUAL
THEN
BEGIN
IF IDTYPE^.SIZE <= 2
THEN
BEGIN
IF IDTYPE^.SIZE = 2
THEN
BEGIN
MACRO4(202B%MOVEM\,REGC,TOPP,ACTUALPAR+1-TOPPOFFSET);
REGC := REGC - 1
END;
(* 201 - zero size objects *)
IF IDTYPE^.SIZE > 0
THEN MACRO4(202B%MOVEM\,REGC,TOPP,ACTUALPAR-TOPPOFFSET);
MACRO4(541B%HRRI\,REGC,TOPP,ACTUALPAR-TOPPOFFSET)
END
ELSE
BEGIN
MACRO4(541B%HRRI\,REGC,TOPP,ACTUALPAR-TOPPOFFSET);
MACRO4(251B%BLT\,REGC,TOPP,ACTUALPAR+IDTYPE^.SIZE-1-TOPPOFFSET);
(* 52 - BLT may change REGC, so reset it since used below *)
MACRO4(541B%HRRI\,REGC,TOPP,ACTUALPAR-TOPPOFFSET)
END;
ACTUALPAR := ACTUALPAR + IDTYPE^.SIZE
END;
MACRO4(552B%HRRZM\,REGC,TOPP,PARLIST-TOPPOFFSET);
PARLIST := PARLIST + 1
END;
REGC := PARREGCMAX
END
END;
IF (LKIND = ACTUAL) AND (NXT # NIL)
THEN NXT := NXT^.NEXT
UNTIL SY # COMMA;
IF SY = RPARENT
THEN INSYMBOL
ELSE ERROR(152)
END %IF LPARENT\;
FOR I := 0 TO WITHIX DO
WITH DISPLAY[TOP-I] DO
IF (CINDR#0) AND (CINDR#BASIS)
THEN
MACRO4(202B%MOVEM\,CINDR,BASIS,CLC);
WITH FCP^ DO
BEGIN
(* 33 - PROC. PARAM.S *)
IF LKIND = FORMAL
THEN BEGIN END %TOPOFFSET=0 ALWAYS AT THE MOMENT\
ELSE IF (LANGUAGE = PASCALSY) AND (TOPPOFFSET # 0)
(* 54 - keep track of offsets above top of stack *)
(* 62 - clean up offset *)
THEN STKOFF := STKOFF - TOPPOFFSET
ELSE IF (LANGUAGE # PASCALSY) AND (TOPPOFFSET = 0)
THEN
BEGIN
TOPPOFFSET:= FIRSTPAR+2;
(* 104 - TOPS20 ADJSP *)
(* 115 - TENEX *)
IF KLCPU AND NOT TOPS10
THEN MACRO3(105B%ADJSP\,TOPP,TOPPOFFSET)
ELSE MACRO3(271B%ADDI\,TOPP,TOPPOFFSET);
(* 54 - keep track of how many loc's above stack are used *)
STKOFF := STKOFF + TOPPOFFSET;
IF STKOFF > STKOFFMAX
THEN STKOFFMAX := STKOFF
END;
IF PFLEV > 1
THEN P := LEVEL - PFLEV
ELSE P:= 0;
IF LKIND = ACTUAL
THEN
BEGIN
IF NXT # NIL
THEN ERROR(554);
IF LANGUAGE # PASCALSY
THEN
BEGIN
MACRO3(515B%HRLZI\,HAC,-NOFPAR);
MACRO4(202B%MOVEM\,HAC,TOPP,FIRSTPAR-TOPPOFFSET);
MACRO4(202B%MOVEM\,BASIS,TOPP,-TOPPOFFSET);
MACRO4(201B%MOVEI\,BASIS,TOPP,FIRSTPAR-TOPPOFFSET+1);
IF NOFPAR = 0
THEN MACRO4(402B%SETZM\,0,TOPP,FIRSTPAR-TOPPOFFSET+1)
END;
IF PFADDR = 0
THEN
BEGIN
MACRO3R(260B%PUSHJ\,TOPP,LINKCHAIN[P]); LINKCHAIN[P]:= IC-1;
IF EXTERNDECL
THEN CODE.INFORMATION[CIX] := 'E'
ELSE CODE.INFORMATION[CIX] := 'F'
END
ELSE MACRO3R(260B%PUSHJ\,TOPP,PFADDR-P);
(* 33 - PROC PARAM.S *)
IF LANGUAGE # PASCALSY
THEN
BEGIN
(* 104 - TOPS20 ADJSP *)
IF KLCPU AND NOT TOPS10
THEN MACRO3(105B%ADJSP\,TOPP,-TOPPOFFSET)
ELSE MACRO3(275B%SUBI\,TOPP,TOPPOFFSET);
(* 54 - keep track of how many loc's above stack are used *)
STKOFF := STKOFF - TOPPOFFSET;
IF KLASS = FUNC
THEN
BEGIN
MACRO4(202B%MOVEM\,HAC,TOPP,2);
IF IDTYPE^.SIZE = 2
THEN MACRO4(202B%MOVEM\,TAC,TOPP,3)
END;
MACRO4(200B%MOVE\,BASIS,TOPP,0)
END
(* 33 - PROC PARAM.S *)
END (* OF LKIND = ACTUAL *)
ELSE
BEGIN
IF P = 0
THEN BEGIN
MACRO4(550B%HRRZ\,TAC,BASIS,PFADDR);
MACRO4(544B%HLR\,BASIS,BASIS,PFADDR)
END
ELSE BEGIN
MACRO4(550B%HRRZ\,TAC,BASIS,-1);
FOR I := 2 TO P DO MACRO4(550B%HRRZ\,TAC,TAC,-1);
MACRO4(544B%HLR\,BASIS,TAC,PFADDR);
MACRO4(550B%HRRZ\,TAC,TAC,PFADDR)
END;
MACRO4(260B%PUSHJ\,TOPP,TAC,0)
END
END;
FOR I := 0 TO WITHIX DO
WITH DISPLAY[TOP-I] DO
IF (CINDR#0) AND (CINDR#BASIS)
THEN MACRO4(200B%MOVE\,CINDR,BASIS,CLC) ;
IF SAVECOUNT > 0
THEN
BEGIN
IF SAVECOUNT > 3
THEN
BEGIN
MACRO4(505B%HRLI\,TAC,BASIS,LLC);
MACRO3(541B%HRRI\,TAC,2);
MACRO3(251B%BLT\,TAC,SAVECOUNT+1)
END
ELSE FOR I := 1 TO SAVECOUNT DO MACRO4(200B%MOVE\,REGIN+I,BASIS,LLC+I-1) ;
LC := LLC
END ;
GATTR.TYPTR := FCP^.IDTYPE; REGC := LREGC
END %CALLNONSTANDARD\ ;
BEGIN
%CALL\
IF FCP^.PFDECKIND = STANDARD
THEN
BEGIN
LKEY := FCP^.KEY;
IF FCP^.KLASS = PROC
THEN
BEGIN
(* 26 - allow non-text files *)
(* 61 - rclose *)
IF NOT (LKEY IN [7,8,9,10,11,17,19,25,34,39,42] )
THEN
IF SY = LPARENT
THEN INSYMBOL
ELSE ERROR(153);
(* 45 - APPEND, UPDATE, RENAME, use REG5 and REG6 *)
IF (LKEY IN [5,6,7,8,10,11,27,29,36]) AND (REGCMAX <= 8)
THEN ERROR(317);
%REGISTER USED BY RUNTIME SUPPORT FREE OR NOT \
CASE LKEY OF
(* 42 - move GET and PUT to NEW *)
2,4,
(* 14 - NEW DUMP MODE I/O *)
5,6,27,28,29,36: GETPUTRESETREWRITE;
7,
8:
BEGIN
READREADLN;
IF NORIGHTPARENT
THEN GOTO 9
END;
9:
BEGIN
BREAK;
IF NORIGHTPARENT
THEN GOTO 9
END;
10,
11:
BEGIN
WRITEWRITELN;
IF NORIGHTPARENT
THEN GOTO 9
END;
12: PACK;
13: UNPACK;
(* 27 - add NEWZ *)
(* 42 - move GET and PUT to NEW *)
(* 152 - add DISPOSE *)
1,3,14,35,40,44: NEW;
15: MARK;
16: RELEASE;
17: GETLINENR;
18: PUT8BITSTOTTY;
19:
BEGIN
PAGE;
IF NORIGHTPARENT
THEN GOTO 9
END;
21: PROTECTION;
(* 10 - ADD SETSTRING *)
22,23: SETSTRING;
24: GETINDEX;
(* 26 - allow non-text files *)
(* 42 - move breakin to close *)
(* 61 - rclose *)
25,34,39,42: BEGIN CLOSE;IF NORIGHTPARENT THEN GOTO 9 END;
26:CALLI;
(* 14 - NEW DUMP MODE I/O *)
30,31:DUMP;
32,33,38:USET;
(* 61 - delete *)
37,41:PUTX;
(* 61 - tops20 system version *)
43:JSYS
END
END
ELSE
BEGIN
IF NOT (LKEY IN [1,2,11,12])
THEN
BEGIN
IF SY = LPARENT
THEN INSYMBOL
ELSE ERROR(153);
if lkey#15
then EXPRESSION(FSYS OR [RPARENT],ONREGC);
IF NOT (LKEY IN [7,8,11,12,15])
THEN LOAD(GATTR)
END;
CASE LKEY OF
1: RUNTIME;
2: TIME;
3: ABS;
4: SQR;
5,14: TRUNC;
6: ODD;
7: ORD;
8: CHR;
9,10: PREDSUCC;
11,12: BEGIN EOFEOLN; IF NORIGHTPARENT THEN GOTO 9 END;
15: NEW
END;
IF LKEY < 3
THEN GOTO 9
END;
IF SY = RPARENT
THEN INSYMBOL
ELSE ERROR(152);
9:
END %STANDARD PROCEDURES AND FUNCTIONS\
ELSE CALLNONSTANDARD
END %CALL\ ;
PROCEDURE EXPRESSION;
VAR
LATTR: ATTR; LOP: OPERATOR; LSIZE: ADDRRANGE; LOFFSET: INTEGER; DEFAULT,NEEDSHIFT: BOOLEAN;
BOOLREGC,TESTREGC:ACRANGE; LINSTR,LINSTR1: INSTRANGE; LREGC1,LREGC2: ACRANGE;
SETINCLUSION : BOOLEAN; JMPADRIFALLEQUAL : INTEGER;
PROCEDURE CHANGEBOOL(VAR FINSTR: INSTRANGE);
BEGIN
IF (FINSTR>=311B) AND (FINSTR<=313B)
THEN FINSTR := FINSTR+4 %CAML,CAME,CAMLE --> CAMGE,CAMN,CAMG\
ELSE
IF (FINSTR>=315B) AND (FINSTR<=317B)
THEN FINSTR := FINSTR-4 %SAME IN THE OTHER WAY\;
END;
PROCEDURE SEARCHCODE(FINSTR:INSTRANGE; FATTR: ATTR);
PROCEDURE CHANGEOPERANDS(VAR FINSTR:INSTRANGE);
BEGIN
IF FINSTR=311B%CAML\
THEN FINSTR := 317B%CAMG\
ELSE
IF FINSTR = 313B%CAMLE\
THEN FINSTR := 315B%CAMGE\
ELSE
IF FINSTR=315B%CAMGE\
THEN FINSTR := 313B%CAMLE\
ELSE
IF FINSTR = 317B%CAMG\
THEN FINSTR := 311B%CAML\
ELSE
IF FINSTR = 420B%ANDCM\
THEN FINSTR := 410B%ANDCA\
ELSE
IF FINSTR = 410B%ANDCA\
THEN FINSTR := 420B%ANDCM\;
END;
BEGIN
WITH GATTR DO
IF FATTR.KIND = EXPR
THEN
BEGIN
MAKECODE(FINSTR,FATTR.REG,GATTR); REG := FATTR.REG
END
ELSE
IF KIND = EXPR
THEN
BEGIN
CHANGEOPERANDS(FINSTR); MAKECODE(FINSTR,REG,FATTR)
END
ELSE
IF (KIND=VARBL) AND ((PACKFG#NOTPACK)
OR (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND
((FATTR.INDEXR<=REGIN) OR (FATTR.INDEXR>REGCMAX)))
THEN
BEGIN
LOAD(GATTR); CHANGEOPERANDS(FINSTR); MAKECODE(FINSTR,REG,FATTR)
END
ELSE
BEGIN
LOAD(FATTR); MAKECODE(FINSTR,FATTR.REG,GATTR); REG := FATTR.REG
END;
END;
PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS);
VAR
LATTR: ATTR; LOP: OPERATOR; SIGNED : BOOLEAN;
(* 52 - new var needed to prevent clobbering CONST decl. *)
NEWREALCSP: CSP;
PROCEDURE TERM(FSYS: SETOFSYS);
VAR
LATTR: ATTR; LOP: OPERATOR;
PROCEDURE FACTOR(FSYS: SETOFSYS);
VAR
LCP: CTP; LVP: CSP; VARPART: BOOLEAN;
CSTPART: SET OF 0..71; LSP: STP;
RANGEPART: BOOLEAN;LRMIN: INTEGER;
BEGIN
IF NOT (SY IN FACBEGSYS)
THEN
BEGIN
ERRANDSKIP(173,FSYS OR FACBEGSYS);
GATTR.TYPTR := NIL
END;
IF SY IN FACBEGSYS
THEN
BEGIN
CASE SY OF
%ID\ IDENT:
BEGIN
SEARCHID([KONST,VARS,FIELD,FUNC],LCP);
INSYMBOL;
IF LCP^.KLASS = FUNC
THEN
BEGIN
CALL(FSYS,LCP);
IF LCP^.PFDECKIND=DECLARED
THEN
BEGIN
WITH LCP^,GATTR DO
BEGIN
TYPTR :=IDTYPE; KIND :=VARBL; PACKFG :=NOTPACK;
VRELBYTE := NO;
VLEVEL :=1; DPLMT :=2;
INDEXR := TOPP; INDBIT :=0;
IF TYPTR # NIL
THEN
IF TYPTR^.SIZE = 1
THEN LOAD(GATTR)
END
END
END
ELSE
IF LCP^.KLASS = KONST
THEN
WITH GATTR, LCP^ DO
BEGIN
TYPTR := IDTYPE; KIND := CST;
CVAL := VALUES
END
ELSE
SELECTOR(FSYS,LCP);
IF GATTR.TYPTR # NIL
THEN %ELIM. SUBR. TYPES TO\
WITH GATTR, TYPTR^ DO %SIMPLIFY LATER TESTS\
IF FORM = SUBRANGE
THEN TYPTR := RANGETYPE
END;
%CST\ INTCONST:
BEGIN
WITH GATTR DO
BEGIN
TYPTR := INTPTR; KIND := CST;
CVAL := VAL;
END;
INSYMBOL
END;
REALCONST:
BEGIN
WITH GATTR DO
BEGIN
TYPTR := REALPTR; KIND := CST;
CVAL := VAL
END;
INSYMBOL
END;
STRINGCONST:
BEGIN
WITH GATTR DO
BEGIN
CONSTANT(FSYS,TYPTR,CVAL) ; KIND := CST ;
END;
END;
%(\ LPARENT:
BEGIN
INSYMBOL; EXPRESSION(FSYS OR [RPARENT],ONREGC);
IF SY = RPARENT
THEN INSYMBOL
ELSE ERROR(152)
END;
% NOT \ NOTSY:
BEGIN
INSYMBOL; FACTOR(FSYS);
IF GATTR.TYPTR = BOOLPTR
THEN
BEGIN
LOAD(GATTR); MACRO3(411B%ANDCAI\,REGC,1)
END
ELSE
BEGIN
ERROR(359); GATTR.TYPTR := NIL
END;
END;
%[\ LBRACK:
BEGIN
INSYMBOL; CSTPART := [ ]; VARPART := FALSE;
(* 110 - MOVED RANGEPART INITIALIZATION INSIDE LOOP *)
NEWZ(LSP,POWER);
WITH LSP^ DO
BEGIN
ELSET:=NIL; SIZE:= 2
END;
IF SY = RBRACK
THEN
BEGIN
WITH GATTR DO
BEGIN
TYPTR:=LSP; KIND:=CST;
NEWZ(LVP,PSET); LVP^.PVAL := CSTPART; CVAL.VALP := LVP
END;
INSYMBOL
END
ELSE
BEGIN
(* 110 - THIS ROUTINE LARGELY RECODED *)
(* AC usage in the following is documented at the end. In order to provide
any sanity at all, REGC has to be kept the same whatever the expression
types found. Since an expression will advance REGC in most cases, we
have to be sure it gets advanced in others. This means incrementregc
for constants and LOAD otherwise. We don't LOAD constants because if
the other half of the range is also constant we will just remember it
as constant and not do a load at all. *)
LOOP
(* RANGEPART IS FLAG: 1ST EXPRESSION IS VARIABLE *)
RANGEPART := FALSE;
INCREMENTREGC; INCREMENTREGC; (* FIRST EXPR *)
EXPRESSION(FSYS OR [COMMA,RBRACK,COLON],ONFIXEDREGC);
IF GATTR.TYPTR # NIL
THEN
IF GATTR.TYPTR^.FORM # SCALAR
THEN
BEGIN
ERROR(461); GATTR.TYPTR := NIL
END
ELSE
IF COMPTYPES(LSP^.ELSET,GATTR.TYPTR)
THEN
BEGIN (* LOAD IF VAR, SAVE IN LRMIN IF CONST *)
IF GATTR.KIND = CST
THEN
BEGIN (* FIRST EXPR IS CONST *)
(* 127 - fix reversed AC's *)
INCREMENTREGC;
(* 137 - CHAR needs different test *)
IF (GATTR.CVAL.IVAL<0)
OR (GATTR.CVAL.IVAL>BASEMAX) AND (GATTR.TYPTR<>CHARPTR)
OR (GATTR.CVAL.IVAL>CHARMAX) AND (GATTR.TYPTR=CHARPTR)
THEN BEGIN ERROR(352) ; GATTR.CVAL.IVAL := 0 END;
IF GATTR.TYPTR=CHARPTR
THEN
(* 7 - TREAT LOWER CASE AS UPPER IN SETS *)
(* 105 - improve lower case mapping in sets *)
GATTR.CVAL.IVAL := SETMAP[GATTR.CVAL.IVAL];
LRMIN := GATTR.CVAL.IVAL;
END
ELSE
BEGIN (* FIRST EXPR IS NOT A CONSTANT *)
RANGEPART := TRUE; (* SIGNAL VARIABLE *)
LOAD(GATTR);
(* 112 - range check sets *)
if runtmcheck
then begin
(* 137 - different range check for char *)
if gattr.typtr = charptr
then macro3(307B%caig\,regc,charmax)
else macro3(307B%caig\,regc,basemax);
macro3(305B%caige\,regc,0);
support(errorinassignment)
end;
IF GATTR.TYPTR = CHARPTR
THEN BEGIN
(* 105 - improve lower case mapping in sets *)
macro4r(200B%MOVE\,regc,regc,setmapchain);
code.information[cix] := 'E';
setmapchain := ic-1;
END;
END;
IF SY <> COLON
THEN (* ONLY ONE EXPR *)
IF NOT RANGEPART
THEN (* CONSTANT *)
BEGIN
CSTPART := CSTPART OR [LRMIN];
(* 127 - fixed reversed AC's *)
REGC := REGC - 3;
END
ELSE (* ONE VARIABLE *)
BEGIN
IF GATTR.TYPTR = CHARPTR
THEN CODE.INSTRUCTION[CIX].INSTR := 210B%MOVN\
ELSE MACRO3(210B%MOVN\,REGC,REGC);
REGC := REGC - 1;
MACRO3(515B%HRLZI\,REGC-1,400000B);
MACRO3(400B%SETZ\,REGC,0);
(* 105 - more improvements for lower case mapping *)
MACRO4(246B%LSHC\,REGC-1,REGC+1,0);
IF VARPART
THEN
BEGIN
MACRO3(434B%IOR\,REGC-3,REGC-1);
MACRO3(434B%IOR\,REGC-2,REGC);
REGC := REGC-2;
END
ELSE VARPART := TRUE;
GATTR.KIND := EXPR; GATTR.REG := REGC
END
ELSE (* RANGE *)
BEGIN
INSYMBOL;
EXPRESSION(FSYS OR [COMMA,RBRACK],ONFIXEDREGC);
IF GATTR.TYPTR <> NIL (* 2ND EXPR *)
THEN
IF GATTR.TYPTR^.FORM <> SCALAR
THEN BEGIN
ERROR(461);
GATTR.TYPTR := NIL
END
ELSE
IF COMPTYPES(LSP^.ELSET,GATTR.TYPTR)
THEN
BEGIN
IF GATTR.KIND = CST
THEN BEGIN
(* 137 - different test for CHAR, fix AC mess *)
INCREMENTREGC;
IF (GATTR.CVAL.IVAL < 0)
OR (GATTR.CVAL.IVAL > BASEMAX) AND (GATTR.TYPTR<>CHARPTR)
OR (GATTR.CVAL.IVAL > CHARMAX) AND (GATTR.TYPTR=CHARPTR)
THEN BEGIN ERROR(352); GATTR.CVAL.IVAL := 0 END;
IF GATTR.TYPTR = CHARPTR
THEN GATTR.CVAL.IVAL := SETMAP[GATTR.CVAL.IVAL]
END
(* 137 - more AC confusion *)
ELSE LOAD(GATTR);
IF (GATTR.KIND = CST) AND (NOT RANGEPART)
THEN (* CONSTANT RANGE *)
BEGIN
WHILE(LRMIN <= GATTR.CVAL.IVAL) DO
BEGIN
CSTPART := CSTPART OR [LRMIN];
LRMIN := LRMIN+1
END;
(* 127 - fix reversed AC's *)
(* 137 - once again *)
REGC := REGC - 4
END
ELSE
BEGIN (* VARIABLE LIMITS ON RANGE *)
IF NOT RANGEPART (* FIRST PART IS CONSTANT *)
THEN
BEGIN (* SO NOT IN AC YET *)
(* 127 - fix reversed AC's *)
(* 137 - once again *)
MACRO3(201B%MOVEI\,REGC-1,LRMIN)
END;
if gattr.kind = cst (* same for second *)
then macro3(201B%movei\,regc,gattr.cval.ival);
(* 112 - range check sets *)
(* 137 - different test needed for CHAR *)
if (gattr.kind <> cst) and runtmcheck
then begin
if gattr.typtr = charptr
then macro3(307B%caig\,regc,charmax)
else macro3(307B%caig\,regc,basemax);
macro3(305B%caige\,regc,0);
support(errorinassignment);
end;
IF (GATTR.TYPTR=CHARPTR) AND (GATTR.KIND <> CST)
THEN BEGIN
(* 105 - improve lower case mapping in sets *)
macro4r(200B%MOVE\,regc,regc,setmapchain);
code.information[cix] := 'E';
setmapchain := ic-1;
END;
(* HERE IS WHAT IS IN THE AC'S:
REGC - RH LIMIT
REGC-1 - LH LIMIT
REGC-2 - DOUBLE WORD OF BITS
REGC-3 "
*)
MACRO3(477B%SETOB\,REGC-3,REGC-2);
MACRO4(246B%LSHC\,REGC-3,REGC-1,0);
MACRO3(275B%SUBI\,REGC,71);
MACRO3(210B%MOVN\,REGC,REGC);
MACRO3(270B%ADD\,REGC-1,REGC);
MACRO3(210B%MOVN\,REGC-1,REGC-1);
MACRO4(246B%LSHC\,REGC-3,REGC-1,0);
MACRO4(246B%LSHC\,REGC-3,REGC,0);
REGC := REGC -2;
IF VARPART
THEN
BEGIN
MACRO3(434B%IOR\,REGC-3,REGC-1);
MACRO3(434B%IOR\,REGC-2,REGC);
REGC := REGC-2;
END
ELSE VARPART := TRUE;
GATTR.KIND := EXPR; GATTR.REG := REGC
END
END
END;
LSP^.ELSET := GATTR.TYPTR;
GATTR.TYPTR :=LSP
END
ELSE ERROR(360);
EXIT IF NOT(SY IN [COMMA]);
INSYMBOL
END;
IF SY = RBRACK
THEN INSYMBOL
ELSE ERROR(155);
IF VARPART
THEN
BEGIN
IF CSTPART # [ ]
THEN
BEGIN
(* 34 - BUG FIX FROM HAMBURG - NEEDED FOR PROGSTAT *)
NEW(LVP,PSET);LVP^.PVAL := CSTPART;
GATTR.KIND:=CST; GATTR.CVAL.VALP := LVP;
MAKECODE(434B%IOR\,REGC,GATTR)
END
END
ELSE
BEGIN
NEWZ(LVP,PSET); LVP^.PVAL := CSTPART; GATTR.CVAL.VALP := LVP
END
END;
END
END %CASE\ ;
IFERRSKIP(166,FSYS)
END;
%IF SY IN FACBEGSYS\
END %FACTOR\ ;
BEGIN
%TERM\
FACTOR(FSYS OR [MULOP]);
WHILE SY = MULOP DO
BEGIN
IF OP IN [RDIV,IDIV,IMOD]
THEN LOAD(GATTR); %BECAUSE OPERANDS ARE NOT
ALLOWED TO BE CHOSEN\
LATTR := GATTR; LOP := OP;
INSYMBOL; FACTOR(FSYS OR [MULOP]);
IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
THEN
CASE LOP OF
%*\ MUL:
IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
THEN SEARCHCODE(220B%IMUL\,LATTR)
(* 21 - * with sets is and *)
ELSE IF (LATTR.TYPTR^.FORM=POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
THEN SEARCHCODE(404B%AND\,LATTR)
ELSE
BEGIN
MAKEREAL(LATTR);
IF (LATTR.TYPTR = REALPTR)
AND (GATTR.TYPTR = REALPTR)
THEN SEARCHCODE(164B%FMPR\,LATTR)
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END
END;
%/\ RDIV:
BEGIN
MAKEREAL(LATTR);
IF (LATTR.TYPTR = REALPTR)
AND (GATTR.TYPTR = REALPTR)
THEN SEARCHCODE(174B%FDVR\,LATTR)
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END
END;
%DIV\ IDIV:
IF (LATTR.TYPTR = INTPTR)
AND (GATTR.TYPTR = INTPTR)
THEN SEARCHCODE(230B%IDIV\,LATTR)
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END;
%MOD\ IMOD:
IF (LATTR.TYPTR = INTPTR)
AND (GATTR.TYPTR = INTPTR)
THEN
BEGIN
SEARCHCODE(230B%IDIV\,LATTR);GATTR.REG := GATTR.REG+1
END
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END;
% AND \ ANDOP:
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
AND ( (LATTR.TYPTR^.FORM = POWER) OR (GATTR.TYPTR = BOOLPTR) )
THEN SEARCHCODE(404B%AND\,LATTR)
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END
END %CASE\
ELSE GATTR.TYPTR := NIL;
REGC:=GATTR.REG
END %WHILE\
END %TERM\ ;
BEGIN
%SIMPLEEXPRESSION\
SIGNED := FALSE;
IF (SY = ADDOP) AND (OP IN [PLUS,MINUS])
THEN
BEGIN
SIGNED := OP = MINUS; INSYMBOL
END;
TERM(FSYS OR [ADDOP]);
IF SIGNED
THEN WITH GATTR DO
IF TYPTR # NIL
THEN
IF (TYPTR = INTPTR) OR (TYPTR = REALPTR)
THEN
IF KIND = CST
THEN
IF TYPTR = INTPTR
THEN CVAL.IVAL := - CVAL.IVAL
(* 52 - have to put negated value in new place, since old one might be a CONST declaration used elsewhere *)
ELSE
BEGIN
NEW(NEWREALCSP);
NEWREALCSP^.CCLASS := REEL;
NEWREALCSP^.RVAL := -CVAL.VALP^.RVAL;
CVAL.VALP := NEWREALCSP
END
ELSE
BEGIN
LOAD(GATTR) ;
WITH CODE, INSTRUCTION[CIX] DO
IF INSTR=200B%MOVE\
THEN INSTR := 210B%MOVN\
ELSE MACRO3(210B%MOVN\,GATTR.REG,GATTR.REG)
END
ELSE
BEGIN
ERROR(311) ; GATTR.TYPTR := NIL
END ;
WHILE SY = ADDOP DO
BEGIN
IF OP=MINUS
THEN LOAD(GATTR); %BECAUSE OPD MAY NOT BE CHOSEN\
LATTR := GATTR; LOP := OP;
INSYMBOL; TERM(FSYS OR [ADDOP]);
IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
THEN
CASE LOP OF
%+\ PLUS:
IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
THEN
SEARCHCODE(270B%ADD\,LATTR)
(* 21 - ALLOW + AS SET UNION *)
ELSE IF(LATTR.TYPTR^.FORM=POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
THEN SEARCHCODE(434B%IOR\,LATTR)
ELSE
BEGIN
MAKEREAL(LATTR);
IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
THEN SEARCHCODE(144B%FADR\,LATTR)
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END
END;
%-\ MINUS:
IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
THEN
SEARCHCODE(274B%SUB\,LATTR)
(* 21 - ALLOW - AS SET DIFFERENCE *)
ELSE IF (LATTR.TYPTR^.FORM = POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
THEN SEARCHCODE(420B%ANDCM\,LATTR)
ELSE
BEGIN
MAKEREAL(LATTR);
IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
THEN SEARCHCODE(154B%FSBR\,LATTR)
ELSE
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
AND (LATTR.TYPTR^.FORM = POWER)
THEN SEARCHCODE(420B%ANDCM\,LATTR)
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END
END;
% OR \ OROP:
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
AND ( (GATTR.TYPTR = BOOLPTR) OR (LATTR.TYPTR^.FORM = POWER) )
THEN SEARCHCODE(434B%IOR\,LATTR)
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END
END %CASE\
ELSE GATTR.TYPTR := NIL;
REGC:=GATTR.REG
END %WHILE\
END %SIMPLEEXPRESSION\ ;
BEGIN
%EXPRESSION\
TESTREGC := REGC+1;
SIMPLEEXPRESSION(FSYS OR [RELOP]);
IF SY = RELOP
THEN
BEGIN
IF FVALUE IN [ONREGC,ONFIXEDREGC]
THEN
BEGIN
INCREMENTREGC; MACRO3(201B%MOVEI\,REGC,1); BOOLREGC := REGC
END;
IF GATTR.TYPTR # NIL
THEN
(* 24 - STRING IS ONLY STRUCTURE ALLOWED *)
IF STRING(GATTR.TYPTR)
THEN LOADADDRESS; LREGC1 := REGC;
LATTR := GATTR; LOP := OP;
IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC < BOOLREGC)
THEN REGC := BOOLREGC;
INSYMBOL; SIMPLEEXPRESSION(FSYS);
IF GATTR.TYPTR # NIL
THEN
(* 24 - STRING IS ONLY STRUCTURE ALLOWED *)
IF STRING(GATTR.TYPTR)
THEN LOADADDRESS; LREGC2 := REGC;
IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
THEN
BEGIN
IF LOP = INOP
THEN
IF GATTR.TYPTR^.FORM = POWER
THEN
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR^.ELSET)
THEN
BEGIN
LOAD(LATTR);
IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC < BOOLREGC)
THEN REGC := BOOLREGC;
LOAD(GATTR); REGC := GATTR.REG - 1;
IF LATTR.TYPTR=CHARPTR
THEN
(* 7 - TREAT LOWER CASE AS UPPER IN SETS *)
BEGIN
(* 105 - improve lower case mapping in sets *)
macro4r(200B%move\,lattr.reg,lattr.reg,setmapchain);
code.information[cix] := 'E';
setmapchain := ic-1;
END;
MACRO4(246B%LSHC\,REGC,LATTR.REG,0);
IF FVALUE = TRUEJMP
THEN LINSTR := 305B%CAIGE\
ELSE LINSTR := 301B%CAIL\;
MACRO3(LINSTR,REGC,0);
END
ELSE
BEGIN
ERROR(260); GATTR.TYPTR := NIL
END
ELSE
BEGIN
ERROR(213); GATTR.TYPTR := NIL
END
ELSE
BEGIN
IF LATTR.TYPTR # GATTR.TYPTR
THEN
MAKEREAL(LATTR);
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
THEN
BEGIN
LSIZE := LATTR.TYPTR^.SIZE;
CASE LATTR.TYPTR^.FORM OF
POINTER:
IF LOP IN [LTOP,LEOP,GTOP,GEOP]
THEN ERROR (312);
POWER:
IF LOP IN [LTOP,GTOP]
THEN ERROR(313);
ARRAYS:
IF NOT STRING(LATTR.TYPTR)
(* 24 - STRING IS ONLY STRUCT. ALLOWED *)
THEN ERROR(312);
RECORDS,
FILES:
ERROR(314)
END;
WITH LATTR.TYPTR^ DO
BEGIN
DEFAULT := TRUE; LOFFSET := 3; SETINCLUSION := FALSE;
CASE LOP OF
LTOP:
BEGIN
LINSTR := 311B%CAML\; LINSTR1 := 313B
END;
LEOP:
IF FORM = POWER
THEN
BEGIN
SEARCHCODE(420B%ANDCM\,LATTR);
SETINCLUSION := TRUE
END
ELSE
BEGIN
LINSTR := 313B%CAMLE\; LINSTR1 := 313B
END;
GTOP:
BEGIN
LINSTR := 317B%CAMG\; LINSTR1 := 315B
END;
GEOP:
IF FORM = POWER
THEN
BEGIN
SEARCHCODE(410B%ANDCA\,LATTR);
SETINCLUSION := TRUE
END
ELSE
BEGIN
LINSTR := 315B%CAMGE\; LINSTR1 := 315B
END;
NEOP:
BEGIN
LINSTR := 316B%CAMN\;DEFAULT := FALSE
END;
EQOP:
BEGIN
LINSTR := 312B%CAME\; DEFAULT := FALSE; LOFFSET := 2
END
END;
IF FVALUE = TRUEJMP
THEN CHANGEBOOL(LINSTR);
(* 24 - STRING IS ONLY STRUCTURE *)
IF FORM#ARRAYS THEN BEGIN
IF SIZE = 1
THEN SEARCHCODE(LINSTR,LATTR)
ELSE
IF SETINCLUSION
THEN
BEGIN
MACRO3(336B%SKIPN\,0,GATTR.REG);
MACRO3(332B%SKIPE\,0,GATTR.REG-1);
IF FVALUE = TRUEJMP
THEN
MACRO3R(254B%JRST\,0,IC+2)
END
ELSE
BEGIN
LOAD(LATTR);
IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC<BOOLREGC)
THEN
REGC := BOOLREGC;
LOAD(GATTR);
IF DEFAULT
THEN
BEGIN
MACRO3(LINSTR1,LATTR.REG-1,GATTR.REG-1);
MACRO3R(254B%JRST\,0,IC+4) %FALSE\
END;
MACRO3(312B%CAME\,LATTR.REG-1,GATTR.REG-1);
MACRO3R(254B%JRST\,0,IC+LOFFSET);
MACRO3(LINSTR,LATTR.REG,GATTR.REG)
END
END
ELSE
(* 24 - THIS CODE IS NOW ONLY FOR STRINGS *)
BEGIN (*STRING*)
GETBOUNDS(INXTYPE,LOFFSET,LSIZE);
LSIZE:=LSIZE-LOFFSET+1;
(* 40 - fix this code for unpacked strings, too *)
if arraypf
then begin
LOFFSET:=(LSIZE MOD 5)*700B;
LSIZE:=LSIZE DIV 5;
end
else loffset:=0;
IF (LSIZE=0) AND (LOFFSET=0)
THEN MACRO3(403B%SETZB\,TAC,HAC)
ELSE IF (LSIZE=0)
THEN BEGIN
MACRO3(505B%HRLI\,LREGC1,LOFFSET+440000B);
MACRO3(505B%HRLI\,LREGC2,LOFFSET+440000B);
MACRO3(134B%ILDB\,TAC,LREGC1);
MACRO3(134B%ILDB\,HAC,LREGC2)
END
ELSE
BEGIN
(* 40 - fix for nonpacked arrays *)
if arraypf
then begin
MACRO3(505B%HRLI\,LREGC1,444300B);
MACRO3(505B%HRLI\,LREGC2,444300B);
end
else begin
macro3(505b%hrli\,lregc1,444400b);
macro3(505b%hrli\,lregc2,444400b)
end;
INCREMENTREGC;
IF LSIZE > 1
THEN MACRO3(201B%MOVEI\,REGC,LSIZE);
MACRO3(134B%ILDB\,TAC,LREGC1);
MACRO3(134B%ILDB\,HAC,LREGC2);
IF (LOFFSET=0)
THEN BEGIN
IF LSIZE>1
THEN BEGIN
MACRO3(316B%CAMN\,TAC,HAC);
MACRO3R(367B%SOJG\,REGC,IC-3)
END
END
ELSE %OFFSET NOT 0\ BEGIN
MACRO3(312B%CAME\,TAC,HAC);
IF LSIZE>1
THEN BEGIN
MACRO3R(254B%JRST\,0,IC+6);
MACRO3R(367B%SOJG\,REGC,IC-4)
END
ELSE MACRO3R(254B%JRST\,0,IC+5);
MACRO3(505B%HRLI\,LREGC1,LOFFSET);
MACRO3(505B%HRLI\,LREGC2,LOFFSET);
MACRO3(134B%ILDB\,TAC,LREGC1);
MACRO3(134B%ILDB\,HAC,LREGC2)
END;
REGC:=REGC-1
END;
MACRO3(LINSTR,TAC,HAC);
REGC:=REGC-2
END
END
END
ELSE ERROR(260)
END;
IF FVALUE IN [ONREGC,ONFIXEDREGC]
THEN
BEGIN
MACRO3(400B%SETZ\,BOOLREGC,0); REGC := BOOLREGC
END
ELSE MACRO3(254B%JRST\,0,0);
END;
%(IF LATTR.TYPTR#NIL) AND (GATTR.TYPTR#NIL) THEN \
GATTR.TYPTR := BOOLPTR; GATTR.KIND := EXPR; GATTR.REG := REGC
END %SY = RELOP\
ELSE
IF FVALUE IN [TRUEJMP,FALSEJMP]
THEN
BEGIN
LOAD(GATTR);
IF GATTR.TYPTR#BOOLPTR
THEN ERROR (359);
IF FVALUE = TRUEJMP
THEN LINSTR := 326B%JUMPN\
ELSE LINSTR := 322B%JUMPE\;
MACRO3(LINSTR,GATTR.REG,0)
END
ELSE
IF GATTR.KIND=EXPR
THEN REGC := GATTR.REG;
IF GATTR.TYPTR # NIL
THEN
WITH GATTR,TYPTR^ DO
(* 141 - fix bollixed AC allocation in complex array calculations *)
(* 143 - fixed code below for Tops-10 packed arrays *)
{Warning to modifiers: the following code depends upon the register
allocation in MAKECODE for the case where opcode=MOVE, and in
LOADADDRESS. Please be sure to keep them consistent!}
{Onfixedregc means we are in a context where the result has to go in
a particular AC. So if we had a complex calculation that ended up
with it in a higher AC, we have to move it down. That is for
KIND=EXPR. For KIND=CST or VARBL (the only other cases), we have
to make sure REGC was not changed, as the caller will expect that.
It could be changed by an array with a complex subscript calculation.
Note that we in the case KIND=VARBL we may leave AC's set up with
info needed to access arrays (in the fieldS INDEXR and/or BPADDR).
So in that case this amounts to second-guessing LOAD and MAKECODE
to make sure that whichever place the result will be loaded
(usually INDEXR or BPADDR) is pointing to the fixed AC.}
IF FVALUE = ONFIXEDREGC
THEN
BEGIN
IF KIND=EXPR
THEN BEGIN
IF SIZE = 2
THEN TESTREGC := TESTREGC + 1;
IF TESTREGC # REGC
THEN BEGIN
IF SIZE = 2
THEN MACRO3(200B%MOVE\,TESTREGC-1,REGC-1);
MACRO3(200B%MOVE\,TESTREGC,REGC);
REG := TESTREGC; REGC := TESTREGC;
END
END
ELSE IF KIND=VARBL
THEN BEGIN
IF (PACKFG = PACKK) AND (BPADDR>REGIN) AND (BPADDR<=REGCMAX)
THEN IF (INDEXR <= REGIN) OR (BPADDR<INDEXR)
THEN IF BPADDR<> TESTREGC
THEN BEGIN
MACRO3(200B%MOVE\,TESTREGC,BPADDR);
BPADDR := TESTREGC
END
ELSE
ELSE IF INDEXR<>TESTREGC
THEN BEGIN
MACRO3(200B%MOVE\,TESTREGC,INDEXR);
INDEXR := TESTREGC
END
ELSE
ELSE IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND (INDEXR<>TESTREGC)
THEN BEGIN
MACRO3(200B%MOVE\,TESTREGC,INDEXR);
INDEXR := TESTREGC
END;
REGC := TESTREGC - 1;
END
ELSE REGC := TESTREGC-1
END
END %EXPRESSION\ ;
PROCEDURE ASSIGNMENT(FCP: CTP);
VAR
LATTR,SLATTR: ATTR;
SRMIN,SRMAX: INTEGER;
PROCEDURE STOREGLOBALS ;
TYPE
WANDELFORM = (PTRW,INTW,REELW,PSETW,STRGW,INSTW) ;
VAR
WANDEL : RECORD
CASE KW : WANDELFORM OF
PTRW: (WPTR :GTP %TO ALLOW NIL\) ;
INTW: (WINT : INTEGER ; WINT1 : INTEGER %TO PICK UP SECOND WORD OF SET\) ;
REELW: (WREEL: REAL) ;
PSETW: (WSET : SET OF 0..71) ;
STRGW: (WSTRG: CHARWORD) ;
INSTW: (WINST: PDP10INSTR)
END ;
I,J : INTEGER ;
PROCEDURE STOREWORD ;
BEGIN
CIX := CIX + 1 ;
IF CIX > CIXMAX
THEN
BEGIN
CIX := 0 ; ERRORWITHTEXT(356,'INITPROCD.')
END ;
WITH CGLOBPTR^ DO
BEGIN
CODE.INSTRUCTION[CIX] := WANDEL.WINST ;
LASTGLOB := LASTGLOB + 1 ;
END ;
END ;
PROCEDURE GETNEWGLOBPTR ;
VAR
LGLOBPTR : GTP ;
BEGIN
NEWZ(LGLOBPTR) ;
WITH LGLOBPTR^ DO
BEGIN
NEXTGLOBPTR := NIL ;
FIRSTGLOB := 0 ;
END ;
IF CGLOBPTR # NIL
THEN CGLOBPTR^.NEXTGLOBPTR := LGLOBPTR ;
CGLOBPTR := LGLOBPTR ;
END;
BEGIN
%STOREGLOBALS\
IF FGLOBPTR = NIL
THEN
BEGIN
GETNEWGLOBPTR ;
FGLOBPTR := CGLOBPTR ;
END
ELSE
IF LATTR.DPLMT # CGLOBPTR^.LASTGLOB + 1
THEN GETNEWGLOBPTR ;
WITH WANDEL,CGLOBPTR^,GATTR,CVAL DO
BEGIN
IF FIRSTGLOB = 0
THEN
BEGIN
FIRSTGLOB := LATTR.DPLMT ;
LASTGLOB := FIRSTGLOB - 1 ;
FCIX := CIX + 1 ;
END ;
CASE TYPTR^.FORM OF
SCALAR,
SUBRANGE:
BEGIN
(* 174 30-Sep-80 Andy Hisgen, CMU, Problems with xreal:=xinteger,
and with subranges.
The lines below used to read --
IF TYPTR = REALPTR
THEN
IF LATTR.TYPTR=INTPTR
THEN WREEL := IVAL
ELSE WREEL := VALP^.RVAL
ELSE WINT := IVAL ;
Unfortunately, that was testing to see if the RightHandSide (GATTR) was
a real, and if so doing weird things. For example, that let the
assignment "x:=2", where x is a real, go thru, but without doing
any conversion, thus x contained the bit pattern for the integer 2.
The problem here seems to have been that the roles of LATTR and
GATTR got reversed in the coder's mind. Below, we have reversed
them back.
A second unrelated problem was that subrange checking was not
being done. In the code below, we now handle this.
*)
IF lattr.typtr = realptr
THEN
IF gattr.typtr = intptr
THEN WREEL := IVAL
ELSE WREEL := VALP^.RVAL
ELSE BEGIN (*left isn't real*)
IF lattr.typtr^.form = subrange
THEN
BEGIN (*left is subrange*)
getBounds(lattr.typtr,srmin,srmax);
IF NOT( (srmin <= ival) AND
(ival <= srmax) )
THEN error(367);
END; (*left is subrange*)
WINT := IVAL;
END; (*left isn't real*)
(*30-Sep-80 end of changes for xreal:=integer and for subranges*)
STOREWORD ;
END ;
POINTER:
BEGIN
WPTR := NIL ; STOREWORD
END ;
POWER :
BEGIN
WSET := VALP^.PVAL ; STOREWORD ;
WINT := WINT1 %GET SECOND WORD OF SET\ ;
STOREWORD ;
END ;
ARRAYS : WITH VALP^,WANDEL DO
BEGIN
J := 0; WINT := 0;
FOR I := 1 TO SLGTH DO
BEGIN
J := J + 1;
WSTRG[J] := SVAL[I];
IF J=5
THEN
BEGIN
J := 0;
STOREWORD; WINT := 0
END
END;
IF J#0
THEN STOREWORD
END;
RECORDS,
FILES : ERROR(411)
END %CASE\ ;
END % WITH \ ;
END % STOREGLOBALS \ ;
BEGIN
%ASSIGNMENT\
SELECTOR(FSYS OR [BECOMES],FCP);
IF SY = BECOMES
THEN
BEGIN
LATTR := GATTR;
INSYMBOL;
EXPRESSION(FSYS,ONREGC);
IF (LATTR.TYPTR # NIL) AND (GATTR.TYPTR # NIL)
THEN
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) OR
(REALPTR=LATTR.TYPTR) AND (GATTR.TYPTR=INTPTR)
THEN
IF INITGLOBALS
THEN
IF GATTR.KIND = CST
THEN STOREGLOBALS
ELSE ERROR(504)
ELSE
IF (GATTR.KIND=CST) AND (GATTR.CVAL.IVAL=0)
AND (LATTR.PACKFG=NOTPACK)
THEN
BEGIN
FETCHBASIS(LATTR);
WITH LATTR DO
BEGIN
(* 104 - check subranges *)
if lattr.typtr^.form = subrange
then begin
getbounds(lattr.typtr,srmin,srmax);
if (0 < srmin) or (0 > srmax)
then error(367)
end;
MACRO(VRELBYTE,402B%SETZM\,0,INDBIT,INDEXR,DPLMT)
END
END
ELSE
CASE LATTR.TYPTR^.FORM OF
SCALAR,
POINTER,
POWER:
BEGIN
LOAD(GATTR);
IF COMPTYPES(REALPTR,LATTR.TYPTR) AND (GATTR.TYPTR=INTPTR)
THEN
MAKEREAL(GATTR);
STORE(GATTR.REG,LATTR)
END;
SUBRANGE:
BEGIN
(* 104 - moved code into procedure for use elsewhere *)
loadsubrange(gattr,lattr.typtr);
STORE(GATTR.REG,LATTR)
END;
ARRAYS,
RECORDS:
(* 201 - zero size objects *)
IF GATTR.TYPTR^.SIZE = 0
THEN
ELSE IF GATTR.TYPTR^.SIZE = 1
THEN
BEGIN
LOAD(GATTR) ; STORE(GATTR.REG,LATTR)
END
ELSE WITH LATTR DO
BEGIN
LOADADDRESS ;
CODE.INSTRUCTION[CIX].INSTR := 505B%HRLI\ ;
FETCHBASIS(LATTR);
MACRO(VRELBYTE,541B%HRRI\,REGC,INDBIT,INDEXR,DPLMT) ;
IF INDBIT=0
THEN MACRO5(VRELBYTE,251B%BLT \,REGC,INDEXR,DPLMT+TYPTR^.SIZE-1)
ELSE
BEGIN
INCREMENTREGC ;
MACRO3(200B%MOVE\,REGC,REGC-1);
MACRO4(251B%BLT \,REGC,REGC-1,TYPTR^.SIZE-1)
END;
END;
FILES: ERROR(361)
END
ELSE ERROR(260)
END %SY = BECOMES\
ELSE ERROR(159);
END %ASSIGNMENT\ ;
PROCEDURE GOTOSTATEMENT;
VAR
(* 64 - non-local gotos *)
(* 65 - remove exit labels *)
I,J,JJ:INTEGER; lcp:ctp;
BEGIN
IF SY = INTCONST
THEN
BEGIN
prterr := false;
searchid([labelt],lcp);
prterr := true;
if lcp # nil
then with lcp^ do
(* See if the goto is out of the current block. If so, handle
specially, since we have to restore the basis and topp. Except
for the global level, we recover the basis by tracing the static
links. Then we arranged for topp's RH to be stored in the LH
of word 0 of the display. Global labels are odd because the
static link will be 0. So the global topp and basis are stored
in special variables. *)
(* 173 - As of this edit, we have to call GOTOC. in order to
close files in the blocks exited. In order to prevent problems
if we are interrupted while this is happening, we can't really
change BASIS or TOPP until after the files are closed, else we
might be trying to close a file whose control block is above TOPP.
So we REGC is the new BASIS and REGC+1 is the new TOPP *)
if scope # level
then begin
incrementregc;
if scope = 1
then begin
macro3r(200B%move\,regc,globbasis);
macro3r(200B%move\,regc+1,globtopp)
end
else begin
macro4(504B%hrl\,regc,basis,-1);
macro3(544B%hlr\,regc,regc);
for i := scope to level - 2 do
macro4(507B%hrls\,regc,regc,-1);
macro4(544B%hlr\,regc+1,regc,0);
macro3(504B%hrl\,regc+1,regc+1);
end;
(* 75 - following was macro3 due to typo *)
macro3r(201B%movei\,regc+2,gotochain);
gotochain := ic-1;
code.information[cix] := 'F';
nonlocgoto := true;
support(exitgoto);
goto 2
end;
FOR I:=1 TO LIX DO
BEGIN
WITH LABELS[I] DO
IF LABSVAL = VAL.IVAL
THEN
BEGIN
MACRO3R(254B%JRST\,0,LABSADDR);
GOTO 2
END
END;
MACRO3(254B%JRST\,0,0);
FOR I:=1 TO JIX DO
BEGIN
WITH GOTOS[I] DO
IF GOTOVAL = VAL.IVAL
THEN
BEGIN
J:= CODE.INSTRUCTION[GOTOADDR].ADDRESS;
JJ:= GOTOADDR;
WHILE J#0 DO
BEGIN
JJ:=J;
J:= CODE.INSTRUCTION[J].ADDRESS
END;
INSERTADDR(NO,JJ,CIX);
GOTO 2
END
END;
FOR I:=1 TO JIX DO
BEGIN
WITH GOTOS[I] DO
IF GOTOVAL = -1
THEN
BEGIN
GOTOVAL:=VAL.IVAL;
GOTOADDR:=CIX;
GOTO 2
END
END;
JIX :=JIX+1;
IF JIX > LABMAX
THEN
BEGIN
ERROR(362);
JIX := LABMAX
END;
WITH GOTOS[JIX] DO
BEGIN
GOTOVAL := VAL.IVAL;
GOTOADDR:=CIX
END;
2:
INSYMBOL
END
ELSE ERROR(255)
END %GOTOSTATEMENT\ ;
PROCEDURE COMPOUNDSTATEMENT;
BEGIN
LOOP
REPEAT
STATEMENT(FSYS,STATENDS)
UNTIL NOT (SY IN STATBEGSYS);
EXIT IF SY # SEMICOLON;
INSYMBOL
END;
IF SY = ENDSY
THEN INSYMBOL
ELSE ERROR(163)
END %COMPOUNDSTATEMENET\ ;
PROCEDURE IFSTATEMENT;
VAR
LCIX1,LCIX2: CODERANGE;
BEGIN
EXPRESSION(FSYS OR [THENSY],FALSEJMP);
LCIX1 := CIX;
IF SY = THENSY
THEN INSYMBOL
ELSE ERROR(164);
STATEMENT(FSYS OR [ELSESY],STATENDS OR [ELSESY]);
IF SY = ELSESY
THEN
BEGIN
MACRO3(254B%JRST\,0,0); LCIX2 := CIX;
INSERTADDR(RIGHT,LCIX1,IC);
INSYMBOL; STATEMENT(FSYS,STATENDS);
INSERTADDR(RIGHT,LCIX2,IC)
END
ELSE INSERTADDR(RIGHT,LCIX1,IC)
END %IFSTATEMENT\ ;
PROCEDURE CASESTATEMENT;
TYPE
CIP = ^CASEINFO;
CASEINFO = PACKED
RECORD
NEXT: CIP;
CSSTART: ADDRRANGE;
CSEND: CODERANGE;
CSLAB: INTEGER
END;
VAR
LSP,LSP1: STP; FSTPTR,LPT1,LPT2,LPT3,OTHERSPTR: CIP; LVAL: VALU;
LIC,LADDR,JUMPADDR: ADDRRANGE; LCIX: CODERANGE; LMIN,LMAX: INTEGER;
PROCEDURE INSERTBOUND(FCIX:CODERANGE;FIC: ADDRRANGE;BOUND:INTEGER);
VAR
LCIX1:CODERANGE; LIC1: ADDRRANGE;
LATTR:ATTR;
BEGIN
IF BOUND>=0
THEN INSERTADDR(NO,FCIX,BOUND)
ELSE
BEGIN
LCIX1:=CIX; LIC1 := IC;
CIX:=FCIX; IC := FIC;
WITH LATTR DO
BEGIN
KIND:=CST;
CVAL.IVAL:=BOUND;
TYPTR:=NIL
END;
DEPCST(INT,LATTR);
CIX:=LCIX1; IC:= LIC1;
WITH CODE.INSTRUCTION[FCIX] DO
INSTR:=INSTR+10B %CAILE-->CAMLE, CAIL-->CAML\
END
END;
BEGIN
OTHERSPTR:=NIL;
EXPRESSION(FSYS OR [OFSY,COMMA,COLON],ONREGC);
LOAD(GATTR);
MACRO3(301B%CAIL\,REGC,0);%<<<---------- LMIN IS INSERTED HERE\
MACRO3(303B%CAILE\,REGC,0);%<<<--------- LMAX IS INSERTED HERE\
MACRO3(254B%JRST\,0,0);%<<<------------- START OF "OTHERS" IS INSERTED HERE\
MACRO(NO,254B%JRST\,0,1,REGC,0);%<<<---- START OF JUMP TABLE IS INSERTED HERE\
LCIX := CIX; LIC := IC;
LSP := GATTR.TYPTR;
IF LSP # NIL
THEN
IF (LSP^.FORM # SCALAR) OR (LSP = REALPTR)
THEN
BEGIN
ERROR(315); LSP := NIL
END;
IF SY = OFSY
THEN INSYMBOL
ELSE ERROR(160);
(* 65 - allow extra semicolon *)
while sy=semicolon do
insymbol;
FSTPTR := NIL; LPT3 := NIL;
LOOP
LOOP
CONSTANT(FSYS OR [COMMA,COLON],LSP1,LVAL);
IF LSP # NIL
THEN
IF COMPTYPES(LSP,LSP1)
THEN
BEGIN
LPT1 := FSTPTR; LPT2 := NIL;
IF ABS(LVAL.IVAL) > HWCSTMAX
THEN ERROR(316);
WHILE LPT1 # NIL DO
WITH LPT1^ DO
BEGIN
IF CSLAB <= LVAL.IVAL
THEN
BEGIN
IF CSLAB = LVAL.IVAL
THEN ERROR(261);
GOTO 1
END;
LPT2 := LPT1; LPT1 := NEXT
END;
1:
NEWZ(LPT3);
WITH LPT3^ DO
BEGIN
NEXT := LPT1; CSLAB := LVAL.IVAL;
CSSTART := IC; CSEND := 0
END;
IF LPT2 = NIL
THEN FSTPTR := LPT3
ELSE LPT2^.NEXT := LPT3
END
ELSE ERROR(505);
EXIT IF SY # COMMA;
INSYMBOL
END;
IF SY = COLON
THEN INSYMBOL
ELSE ERROR(151);
REPEAT
STATEMENT(FSYS,STATENDS)
UNTIL NOT (SY IN STATBEGSYS);
IF LPT3 # NIL
THEN
BEGIN
MACRO3(254B%JRST\,0,0); LPT3^.CSEND := CIX
END;
(* 65 - allow extra semicolons *)
while sy = semicolon
do insymbol;
exit if sy in (fsys or statends);
IF SY=OTHERSSY
THEN
BEGIN
INSYMBOL;
IF SY=COLON
THEN INSYMBOL
ELSE ERROR(151);
NEWZ(OTHERSPTR);
WITH OTHERSPTR^ DO
BEGIN
CSSTART:=IC;
REPEAT
STATEMENT(FSYS,STATENDS)
UNTIL NOT(SY IN STATBEGSYS);
MACRO3(254B %JRST\,0,0);
CSEND:=CIX;
(* 65 - allow extra semicolons *)
while sy=semicolon do
insymbol;
GOTO 2
END
END
END;
2:
IF FSTPTR # NIL
THEN
BEGIN
LMAX := FSTPTR^.CSLAB;
%REVERSE POINTERS\
LPT1 := FSTPTR; FSTPTR := NIL;
REPEAT
LPT2 := LPT1^.NEXT; LPT1^.NEXT := FSTPTR;
FSTPTR := LPT1; LPT1 := LPT2
UNTIL LPT1 = NIL;
LMIN := FSTPTR^.CSLAB;
INSERTBOUND(LCIX-2,LIC-2,LMAX);
INSERTBOUND(LCIX-3,LIC-3,LMIN);
(* 164 - Polish fixups to avoid problem with LOADER *)
INSERTPOLISH(LIC-1,IC,-LMIN); {put IC-LMIN at LIC-1}
IF LMAX - LMIN < CIXMAX-CIX
THEN
BEGIN
LADDR := IC + LMAX - LMIN + 1;
IF OTHERSPTR=NIL
THEN JUMPADDR:=LADDR
ELSE
BEGIN
INSERTADDR(RIGHT,OTHERSPTR^.CSEND,LADDR);
JUMPADDR:=OTHERSPTR^.CSSTART
END;
INSERTADDR(RIGHT,LCIX-1,JUMPADDR);
REPEAT
WITH FSTPTR^ DO
BEGIN
WHILE CSLAB > LMIN DO
BEGIN
FULLWORD(RIGHT,0,JUMPADDR); LMIN := LMIN + 1
END;
FULLWORD(RIGHT,0,CSSTART);
IF CSEND # 0
THEN INSERTADDR(RIGHT,CSEND,LADDR);
FSTPTR := NEXT; LMIN := LMIN + 1
END
UNTIL FSTPTR = NIL
END
ELSE ERROR(363)
END;
IF SY = ENDSY
THEN INSYMBOL
ELSE ERROR(163)
END %CASESTATEMENT\ ;
PROCEDURE REPEATSTATEMENT;
VAR
LADDR: ADDRRANGE;
BEGIN
LADDR := IC;
LOOP
REPEAT
STATEMENT(FSYS OR [UNTILSY],STATENDS OR [UNTILSY])
UNTIL NOT (SY IN STATBEGSYS);
EXIT IF SY # SEMICOLON;
INSYMBOL
END;
IF SY = UNTILSY
THEN
BEGIN
INSYMBOL; EXPRESSION(FSYS,FALSEJMP); INSERTADDR(RIGHT,CIX,LADDR);
END
ELSE ERROR(202)
END %REPEATSTATEMENT\ ;
PROCEDURE WHILESTATEMENT;
VAR
LADDR: ADDRRANGE; LCIX: CODERANGE;
BEGIN
LADDR := IC;
EXPRESSION(FSYS OR [DOSY],FALSEJMP);
LCIX := CIX;
IF SY = DOSY
THEN INSYMBOL
ELSE ERROR(161);
STATEMENT(FSYS,STATENDS);
MACRO3R(254B%JRST\,0,LADDR);
INSERTADDR(RIGHT,LCIX,IC)
END %WHILESTATEMENT\ ;
PROCEDURE FORSTATEMENT;
VAR
(* 104 - check subranges *)
LATTR,SATTR: ATTR; LSP: STP; LSY: SYMBOL;
LCIX: CODERANGE; LADDR,LDPLMT: ADDRRANGE; LINSTR: INSTRANGE;
LREGC,LINDREG: ACRANGE; LINDBIT: IBRANGE; LRELBYTE: RELBYTE;
ADDTOLC: INTEGER;
BEGIN
IF SY = IDENT
THEN
BEGIN
SEARCHID([VARS],LCP);
WITH LCP^, LATTR DO
BEGIN
TYPTR := IDTYPE; KIND := VARBL;
IF VKIND = ACTUAL
THEN
BEGIN
VLEVEL := VLEV;
IF VLEV > 1
THEN VRELBYTE := NO
ELSE VRELBYTE := RIGHT;
DPLMT := VADDR; INDEXR :=0; PACKFG := NOTPACK;
INDBIT:=0
END
ELSE
BEGIN
ERROR(364); TYPTR := NIL
END
END;
IF LATTR.TYPTR # NIL
THEN
IF COMPTYPES(REALPTR,LATTR.TYPTR) OR (LATTR.TYPTR^.FORM > SUBRANGE)
THEN
BEGIN
ERROR(365); LATTR.TYPTR := NIL
END;
INSYMBOL
END
ELSE
BEGIN
ERRANDSKIP(209,FSYS OR [BECOMES,TOSY,DOWNTOSY,DOSY]);
LATTR.TYPTR := NIL
END;
IF SY = BECOMES
THEN
BEGIN
INSYMBOL; EXPRESSION(FSYS OR [TOSY,DOWNTOSY,DOSY],ONREGC);
IF GATTR.TYPTR # NIL
THEN
IF GATTR.TYPTR^.FORM # SCALAR
THEN ERROR(315)
ELSE
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
(* 104 - range check subranges *)
then begin
if lattr.typtr # nil
then if lattr.typtr^.form = subrange
then loadsubrange(gattr,lattr.typtr)
else load(gattr)
end
ELSE ERROR(556);
LREGC := GATTR.REG
END
ELSE ERRANDSKIP(159,FSYS OR [TOSY,DOWNTOSY,DOSY]);
IF SY IN [TOSY,DOWNTOSY]
THEN
BEGIN
LSY := SY; INSYMBOL; EXPRESSION(FSYS OR [DOSY],ONREGC);
IF GATTR.TYPTR # NIL
THEN
IF GATTR.TYPTR^.FORM # SCALAR
THEN ERROR(315)
ELSE
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
THEN
BEGIN
ADDTOLC := 0 ;
WITH GATTR DO
{This test checks for forms of upper bound that must be copied into a local
variable. Originally, they tried to use variables in place instead of
copying, to save the MOVE, MOVEM. The problem is that if the user changes
the variable inside the loop, you have the wrong upper bound. We
interpret the language spec as requiring the bound to be evaluated only
once, at the start. The following test, commented out, was the original
test, to see whether the object could be used in place for a CAMGE, or
needed to be copied. Now we copy all variables, as just discussed.}
{IF ( (KIND = VARBL) AND ( (VLEVEL > 1) AND (VLEVEL < LEVEL) OR
(PACKFG # NOTPACK) OR (INDEXR > 0) AND (INDEXR <= REGCMAX) ) ) OR
(KIND = EXPR) }
IF (KIND = VARBL) OR (KIND = EXPR)
THEN
BEGIN
(* 104 - add range checking for subrange types *)
if lattr.typtr # nil
then if lattr.typtr^.form = subrange
then loadsubrange(gattr,lattr.typtr)
else load(gattr);
MACRO4(202B%MOVEM\,REGC,BASIS,LC); ADDTOLC := 1;
KIND := VARBL ; INDBIT := 0 ; INDEXR := BASIS ; VLEVEL := 1;
DPLMT := LC ; PACKFG := NOTPACK ; VRELBYTE := NO
END
else if lattr.typtr # nil
then if (lattr.typtr^.form = subrange) and runtmcheck
then begin
(* must copy, since otherwise at end of loop
makecode will think it is in an AC *)
sattr := gattr;
loadsubrange(sattr,lattr.typtr)
end;
FETCHBASIS(LATTR);
WITH LATTR DO
BEGIN
IF (INDEXR>0) AND (INDEXR<=REGCMAX)
THEN
BEGIN
MACRO(NO,201B%MOVEI\,INDEXR,INDBIT,INDEXR,DPLMT);
LINDBIT := 1; LDPLMT := LC+ADDTOLC; LINDREG := BASIS ;
MACRO4(202B%MOVEM\,INDEXR,BASIS,LDPLMT);
ADDTOLC := ADDTOLC + 1 ;
END
ELSE
BEGIN
LINDBIT := INDBIT; LINDREG := INDEXR; LDPLMT := DPLMT
END;
LRELBYTE:= VRELBYTE
END;
MACRO(LRELBYTE,202B%MOVEM\,LREGC,LINDBIT,LINDREG,LDPLMT);
IF LSY = TOSY
THEN LINSTR := 313B%CAMLE\
ELSE LINSTR := 315B%CAMGE\;
LADDR := IC;
MAKECODE(LINSTR,LREGC,GATTR) ;
END
ELSE ERROR(556)
END
ELSE ERRANDSKIP(251,FSYS OR [DOSY]);
MACRO3(254B%JRST\,0,0); LCIX :=CIX;
IF SY = DOSY
THEN INSYMBOL
ELSE ERROR(161);
LC := LC + ADDTOLC;
IF LC > LCMAX
THEN LCMAX:=LC;
STATEMENT(FSYS,STATENDS);
LC := LC - ADDTOLC;
IF LSY = TOSY
THEN LINSTR := 350B%AOS\
ELSE LINSTR := 370B%SOS\;
MACRO(LRELBYTE,LINSTR,LREGC,LINDBIT,LINDREG,LDPLMT);
MACRO3R(254B%JRST\,0,LADDR); INSERTADDR(RIGHT,LCIX,IC)
END %FORSTATEMENT\ ;
PROCEDURE LOOPSTATEMENT;
VAR
LADDR: ADDRRANGE; LCIX: CODERANGE;
BEGIN
LADDR := IC;
LOOP
REPEAT
STATEMENT(FSYS OR [EXITSY],STATENDS OR [EXITSY])
UNTIL NOT (SY IN STATBEGSYS);
EXIT IF SY # SEMICOLON;
INSYMBOL
END;
IF SY = EXITSY
THEN
BEGIN
INSYMBOL;
IF SY = IFSY
THEN
BEGIN
INSYMBOL; EXPRESSION(FSYS OR [SEMICOLON,ENDSY],TRUEJMP);
END
ELSE ERRANDSKIP(162,FSYS OR [SEMICOLON,ENDSY]);
LCIX := CIX;
LOOP
REPEAT
STATEMENT(FSYS,STATENDS)
UNTIL NOT (SY IN STATBEGSYS);
EXIT IF SY # SEMICOLON;
INSYMBOL
END;
MACRO3R(254B%JRST\,0,LADDR); INSERTADDR(RIGHT,LCIX,IC)
END
ELSE ERROR(165);
IF SY = ENDSY
THEN INSYMBOL
ELSE ERROR(163)
END %LOOPSTATEMENT\ ;
PROCEDURE WITHSTATEMENT;
VAR
LCP: CTP; OLDLC: ADDRRANGE; LCNT1: DISPRANGE; OLDREGC: ACRANGE;
BEGIN
LCNT1 := 0; OLDREGC := REGCMAX; OLDLC := LC;
LOOP
IF SY = IDENT
THEN
BEGIN
SEARCHID([VARS,FIELD],LCP); INSYMBOL
END
ELSE
BEGIN
ERROR(209); LCP := UVARPTR
END;
SELECTOR(FSYS OR [COMMA,DOSY],LCP);
IF GATTR.TYPTR # NIL
THEN
IF GATTR.TYPTR^.FORM = RECORDS
THEN
IF TOP < DISPLIMIT
THEN
BEGIN
TOP := TOP + 1; LCNT1 := LCNT1 + 1; WITHIX := WITHIX + 1;
DISPLAY[TOP].FNAME := GATTR.TYPTR^.FSTFLD;
WITH DISPLAY[TOP],GATTR DO
BEGIN
OCCUR := CREC;
(* 5 - create block name for CREF *)
BLKNAME := '.FIELDID. ';
IF INDBIT = 1
THEN GETPARADDR;
FETCHBASIS(GATTR);
IF (INDEXR#0) AND (INDEXR # BASIS)
THEN
BEGIN
MACRO3(200B%MOVE\,REGCMAX,INDEXR);
INDEXR := REGCMAX;
REGCMAX := REGCMAX-1;
IF REGCMAX<REGC
THEN
BEGIN
ERROR(317);
REGC := REGCMAX
END
END;
CLEV := VLEVEL; CRELBYTE := VRELBYTE;
CINDR := INDEXR; CINDB:=INDBIT;
CDSPL := DPLMT;
CLC := LC;
IF (CINDR#0) AND (CINDR#BASIS)
THEN
BEGIN
LC := LC + 1;
IF LC>LCMAX
THEN LCMAX := LC;
END
END
END
ELSE ERROR(404)
ELSE ERROR(308);
EXIT IF SY # COMMA;
INSYMBOL
END;
IF SY = DOSY
THEN INSYMBOL
ELSE ERROR(161);
STATEMENT(FSYS,STATENDS);
REGCMAX:=OLDREGC;
TOP := TOP - LCNT1; LC := OLDLC; WITHIX := WITHIX - LCNT1;
END %WITHSTATEMENT\ ;
BEGIN
%STATEMENT\
IF SY = INTCONST
THEN %LABEL\
BEGIN
(* 64 - non-loc gotos *)
prterr := false;
searchid([labelt],lcp);
prterr := true;
if lcp # nil
then with lcp^ do
if scope = level
then labeladdress := ic;
FOR IX:=1 TO LIX DO
BEGIN
WITH LABELS[IX] DO
IF LABSVAL = VAL.IVAL
THEN
BEGIN
ERROR(211);
GOTO 1
END
END;
LIX := LIX+1;
IF LIX > LABMAX
THEN
BEGIN
ERROR(362);
LIX:=LABMAX
END;
WITH LABELS[LIX] DO
BEGIN
LABSVAL:=VAL.IVAL;
LABSADDR:=IC
END;
FOR IX:=1 TO JIX DO
BEGIN
WITH GOTOS[IX] DO
IF GOTOVAL = VAL.IVAL
THEN
BEGIN
J:=CODE.INSTRUCTION[GOTOADDR].ADDRESS;
INSERTADDR(RIGHT,GOTOADDR,IC);
WHILE J#0 DO
BEGIN
GOTOADDR:=J;
J:=CODE.INSTRUCTION[GOTOADDR].ADDRESS;
INSERTADDR(RIGHT,GOTOADDR,IC)
END;
GOTOVAL:=-1;
GOTO 1
END
END;
1:
INSYMBOL;
IF SY = COLON
THEN INSYMBOL
ELSE ERROR(151)
END;
IF DEBUG AND NOT INITGLOBALS
THEN PUTLINER;
IF NOT (SY IN FSYS OR [IDENT])
THEN ERRANDSKIP(166,FSYS);
IF SY IN STATBEGSYS OR [IDENT]
THEN
BEGIN
REGC:=REGIN ;
IF INITGLOBALS AND (SY # IDENT)
THEN ERROR(462)
ELSE
CASE SY OF
IDENT:
BEGIN
SEARCHID([VARS,FIELD,FUNC,PROC],LCP); INSYMBOL;
IF LCP^.KLASS = PROC
THEN
IF INITGLOBALS
THEN ERROR(462)
ELSE CALL(FSYS,LCP)
ELSE ASSIGNMENT(LCP)
END;
BEGINSY:
BEGIN
INSYMBOL; COMPOUNDSTATEMENT
END;
GOTOSY:
BEGIN
INSYMBOL; GOTOSTATEMENT
END;
IFSY:
BEGIN
INSYMBOL; IFSTATEMENT
END;
CASESY:
BEGIN
INSYMBOL; CASESTATEMENT
END;
WHILESY:
BEGIN
INSYMBOL; WHILESTATEMENT
END;
REPEATSY:
BEGIN
INSYMBOL; REPEATSTATEMENT
END;
LOOPSY:
BEGIN
INSYMBOL; LOOPSTATEMENT
END;
FORSY:
BEGIN
INSYMBOL; FORSTATEMENT
END;
WITHSY:
BEGIN
INSYMBOL; WITHSTATEMENT
END
END;
SKIPIFERR(STATENDS,506,FSYS)
END;
REGC := REGIN %RE-INITIALIZE REGISTER COUNTER TO AVOID OVERFLOW DURING SUBSEQUENT
EXPRESSION EVALUATIONS IN REPEATSTATEMENT OR LOOPSTATEMENT \ ;
END %STATEMENT\ ;
BEGIN
%BODY\
LIX:=0;JIX:=0;REGCMAX:=WITHIN;WITHIX := -1; FIRSTKONST := NIL;
(* 164 - Polish fixups for CASE *)
FIRSTPOL := NIL;
IF NOT ENTRYDONE
THEN
BEGIN
ENTRYDONE:= TRUE;
WRITEMC(WRITEENTRY);
WRITEMC(WRITENAME);
WRITEMC(WRITEHISEG)
END;
CIX := -1 ;
IF INITGLOBALS
THEN
BEGIN
CGLOBPTR := NIL ;
LOOP
IF SY # ENDSY
THEN STATEMENT([SEMICOLON,ENDSY],[SEMICOLON,ENDSY]) ;
EXIT IF SY # SEMICOLON ;
INSYMBOL
END ;
IF SY = ENDSY
THEN INSYMBOL
ELSE ERROR(163) ;
WRITEMC(WRITEGLOBALS)
END
ELSE
BEGIN
%BODY PROPER\
ENTERBODY;
IF FPROCP # NIL
(* 40 - fix print format *)
THEN FPROCP^.PFADDR:= PFSTART
ELSE LC:= 1;
LCMAX:=LC;
(* 54 - keep track of how many loc's above stack are used *)
STKOFFMAX := 0;
STKOFF := 0;
IF MAIN OR (LEVEL > 1)
THEN
BEGIN
LOOP
REPEAT
STATEMENT(FSYS OR [SEMICOLON,ENDSY],[SEMICOLON,ENDSY])
UNTIL NOT (SY IN STATBEGSYS);
EXIT IF SY # SEMICOLON;
INSYMBOL
END;
IF SY = ENDSY
THEN INSYMBOL
ELSE ERROR(163);
FOR IX:=1 TO JIX DO %TEST ON UNDEFINED LABELS\
BEGIN
WITH GOTOS[IX] DO
IF GOTOVAL # -1
THEN
BEGIN
ERROR(215);
NEWZ(ERRMPTR1,D);
WITH ERRMPTR1^ DO
BEGIN
NUMBER := 215; INTVAL := GOTOVAL; NEXT := ERRMPTR
END;
ERRMPTR := ERRMPTR1;
END
END
% WHILE FSTEXP # FEXP DO %TEST ON UNDEFINED EXIT LABELS\
END;
LEAVEBODY;
IF MAIN OR (LEVEL > 1)
(* 53 - allocate core for loc's above stack *)
then
begin
(* 104 - check for overflow of address space *)
if lcmax > 377777B (* else adjsp will see it negative *)
then error(266);
(* 62 - clean up stack offsets *)
if fprocp # nil
then insertaddr(no,insertsize,lcmax-fprocp^.poffset)
else insertaddr(no,insertsize,lcmax); %below the stack\
(* 57 - coralloc only needed for tops10 *)
if tops10
then insertaddr(no,coralloc,stkoffmax+40B); %above the stack\
end;
WRITEMC(WRITECODE);
(* 40 - fix print format *)
if fprocp # nil
then writemc(writeblk);
(* 64 - Polish fixups for CASE *)
if firstpol # NIL
then writemc(writepolish);
IF FIRSTKONST # NIL
THEN WRITEMC(WRITEINTERNALS)
ELSE
IF LOCALPFPTR # NIL
THEN
IF LOCALPFPTR^.PFLEV = LEVEL
THEN WRITEMC(WRITEINTERNALS)
(* 114 - ALWAYS WRITE INTERNALS IF REF TO NON-LOC GOTO *)
ELSE IF LASTLABEL # NIL
THEN IF LASTLABEL^.SCOPE = LEVEL
THEN WRITEMC(WRITEINTERNALS)
ELSE
ELSE
ELSE IF LASTLABEL # NIL
THEN IF LASTLABEL^.SCOPE = LEVEL
THEN WRITEMC(WRITEINTERNALS);
IF LEVEL = 1
THEN
BEGIN
WRITEMC(WRITESYMBOLS);
WRITEMC(WRITELIBRARY);
WRITEMC(WRITESTART);
WRITEMC(WRITEEND)
END
END % BODY PROPER\
END %BODY\ ;
(* 56 - PROCEDURES FOR FILE SWITCHING *)
PROCEDURE OPENALT;
BEGIN
REQFILE := TRUE;
(* 136 - listing format *)
ORIGPAGECNT := PAGECNT; ORIGSUBPAGE := SUBPAGE; ORIGLINENR := LINENR;
ORIGPAGE := PAGER; ORIGLINECNT := LINECNT; ORIGCH := CH;
ENDSTUFF;
PUSHF(INPUT,VAL.VALP^.SVAL,VAL.VALP^.SLGTH);
(* 107 - error check openning of subfile *)
if eof
then begin (* nb: on the 20, analys does not show the file name in most cases *)
(* 136 - LISTING FORMAT *)
write('Failure to open INCLUDEd file: ',val.valp^.sval:val.valp^.slgth);
NEWLINE;
writeln(tty,'Failure to open INCLUDEd file: ',val.valp^.sval:val.valp^.slgth);
analys(input); writeln(tty);
rewrite(outputrel);
(* 112 - clrbfi when error *)
clribf;
(* 123 - restore input so close gets done by pasxit *)
close(input);
popf(input);
pasxit(input,output,outputrel)
end;
(* 136 - listing format *)
PAGECNT := 1; SUBPAGE := 0; LINECNT := 1; CH := ' ';
READLN; {because pushf does an interactive open}
GETLINENR(LINENR);
pagehead;
WRITE(VAL.VALP^.SVAL:VAL.VALP^.SLGTH);
newline; newline;
BEGSTUFF
END;
PROCEDURE CLOSEALT;
BEGIN
ENDSTUFF;
POPF(INPUT);
(* 136 - listing format *)
PAGECNT := ORIGPAGECNT; SUBPAGE := ORIGSUBPAGE + 1;
pagehead;
write('Main file continued'); newline; newline;
LINENR := ORIGLINENR; CH := ORIGCH;
PAGER := ORIGPAGE; LINECNT := ORIGLINECNT;
BEGSTUFF
END;
PROCEDURE INCLUSION;
BEGIN
IF NOT (SY = STRINGCONST)
THEN BEGIN ERROR(212); REQFILE := FALSE END
ELSE BEGIN
OPENALT;
INSYMBOL
END
END;
BEGIN
%BLOCK\
MARK(HEAPMARK);
(* 24 - testpacked no longer needed *)
(* 55 - ALL 55 PATCHES ARE FOR REQUIRE FILES - INITIALIZE REQFILE *)
(* 65 - remove exit labels *)
(* 125 - reqfile init moved *)
(* 173 - internal files *)
FILEINBLOCK[LEVEL] := FALSE;
DP := TRUE; FORWPTR := NIL;
REPEAT
(* 23 - be sure LCPAR is set even when no VAR part *)
LCPAR := LC;
(* 56 - INCLUDE SYNTAX *)
(* 126 - turn while into repeat for better to force check for BEGIN *)
REPEAT
(* 56 - SCAN REQUIRE FILE SYNTAX *)
IF (SY=INCLUDESY) OR REQFILE
THEN BEGIN
INSYMBOL;
INCLUSION;
END;
(* 55 - LABELS NOT LEGAL IN REQUIRE FILE *)
IF (SY = LABELSY) AND NOT REQFILE
THEN
BEGIN
INSYMBOL; LABELDECLARATION
END;
IF SY = CONSTSY
THEN
BEGIN
INSYMBOL; CONSTANTDECLARATION
END;
IF SY = TYPESY
THEN
BEGIN
INSYMBOL; TYPEDECLARATION
END;
(* 55 - NO VARIABLES OR INITPROC'S IN REQUIRE FILE *)
IF NOT REQFILE THEN BEGIN
LCPAR := LC;
IF SY = VARSY
THEN
BEGIN
INSYMBOL; VARIABLEDECLARATION
END;
(* 167 - resolve fwd type ref's *)
{Note that FWDRESOLVE must be called after the VAR section because
^FOO in the VAR section is treated as a forward reference to FOO.
We can't resolve this until after the end of the var section,
since otherwise we might accept ^FOO where FOO is a type in an
outer block, but a local variable in the current block. This seems
to be illegal}
FWDRESOLVE;
(* 124 - detect initproc's when not at level 1 *)
WHILE SY = INITPROCSY DO
BEGIN
IF LEVEL # 1
THEN ERROR(557);
INSYMBOL ;
IF SY # SEMICOLON
THEN ERRANDSKIP(156,[BEGINSY])
ELSE INSYMBOL ;
IF SY = BEGINSY
THEN
BEGIN
MARK(GLOBMARK) ; INITGLOBALS := TRUE ;
INSYMBOL ; BODY(FSYS OR [SEMICOLON,ENDSY]) ;
IF SY = SEMICOLON
THEN INSYMBOL
ELSE ERROR(166) ;
INITGLOBALS := FALSE ; RELEASE(GLOBMARK) ;
END
ELSE ERROR(201) ;
END ;
IF LEVEL=1
THEN
LCMAIN := LC;
END;
WHILE SY IN [PROCEDURESY,FUNCTIONSY] DO
BEGIN
LSY := SY; INSYMBOL; PROCEDUREDECLARATION(LSY)
END;
WHILE FORWPTR # NIL DO
WITH FORWPTR^ DO
BEGIN
IF FORWDECL
THEN ERRORWITHTEXT(465,NAME);
FORWPTR := TESTFWDPTR
END;
(* 56 - REQ FILE ENDS IN PERIOD *)
IF (MAIN OR (LEVEL > 1)) AND NOT REQFILE
(* 126 - TWEAK ERROR RECOVER AGAIN *)
THEN BEGIN IF SY # BEGINSY THEN ERROR(201) END
(* 35 - fix error recovery, especially for /NOMAIN *)
%This else is top level of /NOMAIN. If anything is here
other than a period we have to turn on /MAIN, since otherwise
BODY will refuse to scan anything.\
ELSE IF SY # PERIOD
THEN BEGIN
ERROR(172);
(* 56 - DON'T SET MAIN TO TRUE IN REQ FILE *)
IF NOT REQFILE
THEN MAIN := TRUE
END;
(* 55 - CLOSE REQFILE *)
IF REQFILE
THEN BEGIN
(* 136 - listing format *)
REQFILE := FALSE;
CLOSEALT;
INSYMBOL;
IF SY = SEMICOLON
THEN INSYMBOL
ELSE IF SY = COMMA
THEN REQFILE := TRUE
ELSE
ERROR(166);
END;
(* 126 - make it an UNTIL to force always check for BEGIN, etc. *)
UNTIL NOT ( (SY IN BLOCKBEGSYS - [BEGINSY]) OR REQFILE);
DP := FALSE;
IF SY = BEGINSY
THEN INSYMBOL;
%ELSE ERROR(201) REDUNDANT HERE - MSG PRINTED ABOVE\
BODY(FSYS OR [CASESY]);
SKIPIFERR(LEAVEBLOCKSYS,166,FSYS)
UNTIL SY IN LEAVEBLOCKSYS;
RELEASE(HEAPMARK);
END %BLOCK\ ;
PROCEDURE ENTERSTDTYPES;
VAR
LBTP: BTP; LSP: STP;
BEGIN
%TYPE UNDERLIEING:\
%*****************\
NEWZ(INTPTR,SCALAR,STANDARD); %INTEGER\
WITH INTPTR^ DO
BEGIN
SIZE := 1;BITSIZE := BITMAX; SELFSTP := NIL
END;
NEWZ(REALPTR,SCALAR,STANDARD); %REAL\
WITH REALPTR^ DO
BEGIN
SIZE := 1;BITSIZE := BITMAX; SELFSTP := NIL
END;
NEWZ(CHARPTR,SCALAR,STANDARD); %CHAR\
WITH CHARPTR^ DO
BEGIN
SIZE := 1;BITSIZE := 7; SELFSTP := NIL
END;
NEWZ(BOOLPTR,SCALAR,DECLARED); %BOOLEAN\
WITH BOOLPTR^ DO
BEGIN
SIZE := 1;BITSIZE := 1; SELFSTP := NIL
END;
NEWZ(NILPTR,POINTER); %NIL\
WITH NILPTR^ DO
BEGIN
ELTYPE := NIL; SIZE := 1; BITSIZE := 18; SELFSTP := NIL
END;
NEWZ(TEXTPTR,FILES); %TEXT\
WITH TEXTPTR^ DO
BEGIN
FILTYPE := CHARPTR; SIZE := SIZEOFFILEBLOCK + 1; BITSIZE := BITMAX;
FILEPF := FALSE; SELFSTP := NIL; HASFILE := TRUE;
END;
(* 15 - ALLOW "FILE" AS TYPE IN PROC DECL - ANY TYPE OF FILE *)
NEWZ(ANYFILEPTR,FILES);
WITH ANYFILEPTR^ DO
BEGIN
FILTYPE := NIL; SIZE := SIZEOFFILEBLOCK + 1; BITSIZE := BITMAX;
FILEPF := FALSE; SELFSTP := NIL; HASFILE := TRUE;
END;
NEWZ(LSP,SUBRANGE);
WITH LSP^ DO
BEGIN
RANGETYPE := INTPTR; MIN.IVAL := 1; MAX.IVAL := 9; SELFSTP := NIL
END;
NEWZ(DATEPTR,ARRAYS);
WITH DATEPTR^ DO
BEGIN
ARRAYPF := TRUE; ARRAYBPADDR := 0;
SELFSTP := NIL; AELTYPE := CHARPTR; INXTYPE := LSP;
SIZE := 2; BITSIZE := 36
END;
NEWZ(LBTP,ARRAYY);
WITH LBTP^, BYTE DO
BEGIN
SBITS := 7; PBITS := BITMAX; DUMMYBIT := 0;
IBIT := 0; IREG := TAC; RELADDR := 0;
LAST := LASTBTP; LASTBTP := LBTP; ARRAYSP := DATEPTR
END;
NEWZ(LSP,SUBRANGE);
WITH LSP^ DO
BEGIN
RANGETYPE := INTPTR; MIN.IVAL := 1; MAX.IVAL := ALFALENG; SELFSTP := NIL
END;
NEWZ(ALFAPTR,ARRAYS);
WITH ALFAPTR^ DO
BEGIN
ARRAYPF := TRUE; ARRAYBPADDR := 0;
SELFSTP := NIL; AELTYPE := CHARPTR; INXTYPE := LSP;
SIZE := 2; BITSIZE := 36
END;
(* 111 - STRING, POINTER *)
NEWZ(STRINGPTR,ARRAYS);
WITH STRINGPTR^ DO
BEGIN
ARRAYPF := TRUE; SELFSTP := NIL; AELTYPE := CHARPTR;
(* 161 - fix string and pointer *)
INXTYPE := NIL; SIZE := 2; BITSIZE := 36
END;
NEWZ(POINTERPTR,POINTER);
WITH POINTERPTR^ DO
BEGIN
(* 161 - fix string and pointer *)
ELTYPE := NIL; SIZE := 2; BITSIZE := 36; SELFSTP := NIL
END;
(* 202 - fix VAR POINTER *)
NEWZ(POINTERREF,POINTER);
(* 203 - had done pointerref^ := pointerptr^ - This copied too much *)
WITH POINTERREF^ DO
BEGIN
(* 161 - fix string and pointer *)
ELTYPE := NIL; SIZE := 2; BITSIZE := 36; SELFSTP := NIL
END;
NEWZ(LBTP,ARRAYY);
WITH LBTP^, BYTE DO
BEGIN
SBITS := 7; PBITS := BITMAX; DUMMYBIT := 0;
IBIT := 0; IREG := TAC; RELADDR := 0;
LAST := LASTBTP; LASTBTP := LBTP; ARRAYSP := ALFAPTR
END;
END %ENTERSTDTYPES\ ;
PROCEDURE ENTERSTDNAMES;
VAR
CP,CP1: CTP; I,J: INTEGER; LFILEPTR :FTP ;
BEGIN
%NAME:\
%*****\
NEWZ(CP,TYPES); %INTEGER\
WITH CP^ DO
BEGIN
(* 116 - here and following: add next := nil for copyctp *)
NAME := 'INTEGER '; IDTYPE := INTPTR; NEXT := NIL;
END;
ENTERID(CP);
NEWZ(CP,TYPES); %REAL\
WITH CP^ DO
BEGIN
NAME := 'REAL ';IDTYPE := REALPTR; NEXT := NIL;
END;
ENTERID(CP);
NEWZ(CP, TYPES); %CHAR\
WITH CP^ DO
BEGIN
NAME := 'CHAR '; IDTYPE := CHARPTR; NEXT := NIL;
END;
ENTERID(CP);
NEWZ(CP,TYPES); %BOOLEAN\
WITH CP^ DO
BEGIN
NAME := 'BOOLEAN '; IDTYPE := BOOLPTR; NEXT := NIL;
END;
ENTERID(CP);
NEWZ(CP,TYPES); %TEXT\
WITH CP^ DO
BEGIN
NAME := 'TEXT '; IDTYPE := TEXTPTR; NEXT := NIL;
END;
ENTERID(CP);
NEWZ(CP,TYPES);
WITH CP^ DO
BEGIN
NAME := 'ALFA '; IDTYPE := ALFAPTR; NEXT := NIL;
END;
ENTERID(CP);
(* 111 - STRING, POINTER *)
NEWZ(CP,PARAMS);
WITH CP^ DO
BEGIN
NAME := 'STRING '; IDTYPE := STRINGPTR; NEXT := NIL;
END;
ENTERID(CP);
NEWZ(CP,PARAMS);
WITH CP^ DO
BEGIN
NAME := 'POINTER '; IDTYPE := POINTERPTR; NEXT := NIL;
END;
ENTERID(CP);
NEWZ(CP,KONST); %NIL\
WITH CP^ DO
BEGIN
NAME := 'NIL '; IDTYPE := NILPTR;
NEXT := NIL; VALUES.IVAL := 377777B;
END;
ENTERID(CP);
NEWZ(CP,KONST); %ALFALENG\
WITH CP^ DO
BEGIN
NAME := 'ALFALENG '; IDTYPE := INTPTR;
NEXT := NIL; VALUES.IVAL := 10;
END;
ENTERID(CP);
(* 112 - maxint *)
newz(cp,konst);
with cp^ do
begin
name := 'MAXINT '; idtype := intptr;
next := nil; values.ival := 377777777777B;
end;
enterid(cp);
CP1 := NIL;
FOR I := 1 TO 2 DO
BEGIN
NEWZ(CP,KONST); %FALSE,TRUE\
WITH CP^ DO
BEGIN
NAME := NA[I]; IDTYPE := BOOLPTR;
NEXT := CP1; VALUES.IVAL := I - 1;
END;
ENTERID(CP); CP1 := CP
END;
BOOLPTR^.FCONST := CP;
FOR I := 3 TO 6 DO
BEGIN
NEWZ(CP,VARS); %INPUT,OUTPUT,TTY,TTYOUTPUT\
(* 171 - treat files as special *)
case i of
3:infile := cp; 4:outfile := cp; 5:ttyfile := cp; 6:ttyoutfile := cp
end;
WITH CP^ DO
BEGIN
(* 173 - no channels any more *)
NAME := NA[I]; IDTYPE := TEXTPTR; CHANNEL := I-2;
VKIND := ACTUAL; NEXT := NIL; VLEV := 0;
VADDR:= LC;
LC := LC + 1 %BUFFERSIZE FOR TYPE CHAR\ + SIZEOFFILEBLOCK;
NEWZ(LFILEPTR) ;
WITH LFILEPTR^ DO
BEGIN
NEXTFTP := FILEPTR ;
FILEIDENT := CP ;
END ;
FILEPTR := LFILEPTR ;
END;
ENTERID(CP)
END;
SFILEPTR := FILEPTR; %REMEMBER TOP OF STANDARD FILES\
(* 16 - ADD DATA AT ENTRY *)
CCLSW := LC; LC := LC+5;
(* 66 - nonloc gotos *)
globtopp := lc; lc:=lc+1; globbasis := lc; lc:=lc+1;
(* 61 - allow us to distinguish tops10 and tops20 specific ftns *)
if tops10
then othermachine := t20name
else othermachine := t10name;
% GET,GETLN,PUT,PUTLN,RESET,REWRITE,READ,READLN,
WRITE,WRITELN,PACK,UNPACK,NEW,MARK,RELEASE,GETLINR,
PUT8BITSTOTTY,PAGE\
FOR I := 7 TO 25 DO
(* 61 - restrict tops10 and tops20 specific *)
if machna[i] # othermachine then
BEGIN
NEWZ(CP,PROC,STANDARD);
WITH CP^ DO
BEGIN
NAME := NA[I]; IDTYPE := NIL;
NEXT := NIL; KEY := I - 6;
END;
ENTERID(CP)
END;
(* 10 - ADD SETSTRING *)
(* 14 - AND OTHERS *)
(* 27 - add NEWZ *)
(* 61 - restrict tops10 and tops20 defn's *)
(* 152 - DISPOSE *)
FOR I := 54 TO 76 DO
if machna[i] # othermachine then
BEGIN
NEWZ(CP,PROC,STANDARD);
WITH CP^ DO
BEGIN
NAME := NA[I]; IDTYPE := NIL;
NEXT := NIL; KEY := I - 32;
END;
ENTERID(CP)
END;
(* 44 - add curpos and its arg *)
(* arg for CURPOS *)
newz(cp1,vars);
with cp1^ do
begin
name:=' ';idtype:=anyfileptr;
vkind:=formal;next:=nil;vlev:=1;vaddr:=2
end;
(* CURPOS *)
(* 47 - more of this kind now *)
(* 61 - tops10 and tops20 specific functions *)
FOR I:=77 TO 79 DO
if machna[i] # othermachine then
begin
newz(cp,func,declared,actual);
with cp^ do
begin
name := na[i]; idtype:=intptr; next:=cp1; forwdecl:=false;
externdecl := true; pflev:=0; pfaddr:=0; pfchain:=externpfptr;
externpfptr:=cp; for j:=0 to maxlevel do linkchain[j]:=0; externalname:=na[i];
language:=pascalsy
end;
enterid(cp);
end;
NEWZ(CP,FUNC,DECLARED,ACTUAL);
WITH CP^ DO
BEGIN
NAME := NA[26]; IDTYPE := DATEPTR; NEXT := NIL; FORWDECL := FALSE;
EXTERNDECL := TRUE; PFLEV := 0; PFADDR := 0; PFCHAIN := EXTERNPFPTR;
EXTERNPFPTR := CP; FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0; EXTERNALNAME := NA[26];
LANGUAGE := FORTRANSY
END;
ENTERID(CP);
% RUNTIME,TIME,ABS,SQR,TRUNC,ODD,ORD,CHR,PRED,SUCC,EOF,EOLN \
FOR I := 27 TO 38 DO
BEGIN
NEWZ(CP,FUNC,STANDARD);
WITH CP^ DO
BEGIN
NAME := NA[I]; IDTYPE := NIL;
NEXT := NIL; KEY := I - 26;
END;
ENTERID(CP)
END;
FOR I := 80 TO 81 DO
BEGIN
NEWZ(CP,FUNC,STANDARD);
WITH CP^ DO
BEGIN
NAME := NA[I]; IDTYPE := NIL;
NEXT := NIL; KEY := I - 66;
END;
ENTERID(CP)
END;
NEWZ(CP,VARS); %PARAMETER OF PREDECLARED FUNCTIONS\
WITH CP^ DO
BEGIN
NAME := ' '; IDTYPE := REALPTR;
VKIND := ACTUAL; NEXT := NIL; VLEV := 1; VADDR := 2
END;
% SIN,COS,EXP,SQRT,ALOG,ATAN,ALOG10,
SIND,COSD,SINH,COSH,TANH,ASIN,ACOS,RAN \
FOR I := 39 TO 53 DO
BEGIN
NEWZ(CP1,FUNC,DECLARED,ACTUAL);
WITH CP1^ DO
BEGIN
NAME := NA[I]; IDTYPE := REALPTR; NEXT := CP;
FORWDECL := FALSE; EXTERNDECL := TRUE; PFLEV := 0; PFADDR := 0;
PFCHAIN:= EXTERNPFPTR; EXTERNPFPTR:= CP1; EXTERNALNAME := EXTNA[I];
FOR J := 0 TO MAXLEVEL DO LINKCHAIN[J] := 0; LANGUAGE := EXTLANGUAGE[I]
END;
ENTERID(CP1)
END;
LCMAIN := LC;
END %ENTERSTDNAMES\ ;
PROCEDURE ENTERUNDECL;
VAR
I: INTEGER;
BEGIN
NEWZ(UTYPPTR,TYPES);
WITH UTYPPTR^ DO
BEGIN
NAME := ' '; IDTYPE := NIL; NEXT := NIL;
END;
NEWZ(UCSTPTR,KONST);
WITH UCSTPTR^ DO
BEGIN
NAME := ' '; IDTYPE := NIL; NEXT := NIL;
VALUES.IVAL := 0
END;
NEWZ(UVARPTR,VARS);
WITH UVARPTR^ DO
BEGIN
NAME := ' '; IDTYPE := NIL; VKIND := ACTUAL;
NEXT := NIL; VLEV := 0; VADDR := 0
END;
(* 135 - UARRPTR is needed as dummy to prevent ill mem ref in PACK/UNPACK *)
NEWZ(UARRTYP,ARRAYS);
WITH UARRTYP^ DO
BEGIN
ARRAYPF := FALSE; SELFSTP := NIL; AELTYPE := NIL;
INXTYPE := NIL; SIZE := 777777B; BITSIZE := 36
END;
NEWZ(UFLDPTR,FIELD);
WITH UFLDPTR^ DO
BEGIN
NAME := ' '; IDTYPE := NIL; NEXT := NIL; FLDADDR := 0;
PACKF := NOTPACK
END;
NEWZ(UPRCPTR,PROC,DECLARED,ACTUAL);
WITH UPRCPTR^ DO
BEGIN
NAME := ' '; IDTYPE := NIL; FORWDECL := FALSE;
FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0;
NEXT := NIL; EXTERNDECL := FALSE; PFLEV := 0; PFADDR := 0
END;
NEWZ(UFCTPTR,FUNC,DECLARED,ACTUAL);
WITH UFCTPTR^ DO
BEGIN
NAME := ' '; IDTYPE := NIL; NEXT := NIL;
FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0;
FORWDECL := FALSE; EXTERNDECL := FALSE; PFLEV := 0; PFADDR := 0
END;
(* 64 - non-loc gotos *)
newz(ulblptr,labelt);
with ulblptr^ do
begin
name := ' '; idtype := nil; next := nil;
scope := 0; gotochain := 0; labeladdress := 0;
end;
END %ENTERUNDECL\ ;
PROCEDURE ENTERDEBNAMES;
VAR
CP:CTP;
BEGIN
NEWZ(CP,PROC,STANDARD);
WITH CP^ DO
BEGIN
NAME := 'PROTECTION';
IDTYPE := NIL; NEXT := NIL; KEY:= 21
END;
ENTERID(CP);
END;
(* 4 - replace file name scanner with call to SCAN *)
(* 11 - new definition of PASPRM *)
FUNCTION PASPRM(VAR I,O:TEXT;VAR R:INTFILE):RPGPT; EXTERN;
(* 104 - improved error detection in tops10 *)
(* 107 - moved declaration of analys earlier *)
BEGIN
%ENTER STANDARD NAMES AND STANDARD TYPES:\
%****************************************\
(* 41 - make restartable *)
reinit;
RTIME := RUNTIME; DAY := DATE;
LEVEL := 0; TOP := 0;
WITH DISPLAY[0] DO
BEGIN
(* 5 - create block name for CREF *)
FNAME := NIL; OCCUR := BLCK; BLKNAME := '.PREDEFIN.';
END;
ENTERSTDTYPES; ENTERSTDNAMES; ENTERUNDECL; ENTERDEBNAMES;
TOP := 1; LEVEL := 1;
WITH DISPLAY[1] DO
BEGIN
(* 5 - create block name for CREF *)
FNAME := NIL; OCCUR := BLCK; BLKNAME := '.GLOBAL. ';
END;
%OPEN COMPILER FILES\
%*******************\
(* 4 - here we open the files that SCAN gave us *)
REWRITE(TTYOUTPUT);
SCANDATA := PASPRM(INPUT,OUTPUT,OUTPUTREL);
WITH SCANDATA ^ DO
BEGIN
(* 33 - VERSION NO *)
VERSION.WORD := VERVAL;
(* I haven't figured out what to do about lookup blocks. Commented out for now *)
(* 104 - fix error detection on tops10 *)
if tops10
then reset(input%,'',true,lookblock,40000B,4000B\) {tag for SOS}
else reset(input,'',0,0,0,20B); {see EOL char's}
%if eof {tag for SOS}
then begin
analys(input);
pasxit(input,output,outputrel);
end;
get(input);\ {tag for SOS}
IF VERSION.WORD = 0 THEN VERSION.WORD := LOOKBLOCK[6];
LOOKBLOCK[6] := VERSION.WORD;
FOR I := 1 TO 5 DO LOOKBLOCK[I] := 0;
REWRITE(OUTPUT%,'',0,LOOKBLOCK\); {tag for SOS}
FOR I := 1 TO 5 DO LOOKBLOCK[I] := 0;
REWRITE(OUTPUTREL%,'',0,LOOKBLOCK\); {tag for SOS}
FILENAME := RELNAME;
(* 34 - DON'T NEED ENTRY NOW *)
IF FILENAME = ' '
THEN FILENAME := '.NONAM '; %A BLANK ENTRY NAME IS BAD NEWS\
LISTCODE := LSW;
TTYINUSE := TSW;
MAIN := MSW;
RUNTMCHECK := CSW;
(* 160 - compiler switch /ARITHCHECK *)
ARITHCHECK := ASW;
DEBUGSWITCH := DSW;
CREF:=CRSW;
DEBUG := DSW;
RPGENTRY := RPGSW;
(* 7 - ADD /HEAP SWITCH *)
(* 12 - /heap no longer needed *)
(* 24 - /HEAP AND /STACK NOW USED FOR START ADDR *)
HEAP := HEAPVAL;
STACK := STACKVAL;
(* 25 - /ZERO *)
ZERO := ZSW
END;
%WRITE HEADER\
%************\
(* 136 - listing format *)
pagehead;
%NEW LINE FOR ERROR MESSAGES OR PROCEDURENAMES\
GETNEXTLINE; %GETS FIRST LINENUMBER IF ANY\
CH := ' '; INSYMBOL; RESETFLAG := FALSE;
IF NOT MAIN
THEN
BEGIN
LC := PROGRST; LCMAIN := LC;
WHILE SFILEPTR # NIL DO
WITH SFILEPTR^, FILEIDENT^ DO
BEGIN
VADDR:= 0; SFILEPTR:= NEXTFTP
END;
SFILEPTR := FILEPTR;
END;
%COMPILE:\
%********\
(* 5 - CREF *)
IF CREF
THEN WRITE(CHR(15B),CHR(10),'.GLOBAL. ');
FOR I := 1 TO CHCNTMAX DO ERRLINE[I] := ' '; RELBLOCK.COUNT:= 0;
FOR SUPPORTIX := FIRSTSUPPORT TO LASTSUPPORT DO RNTS.LINK[SUPPORTIX] := 0;
(* 6 - allow PROGRAM statement *)
PROGSTAT;
(* 13 - PRINT HEADER NOW THAT HAD PROG STATEMENT SCANNED *)
IF RPGENTRY
THEN WRITELN(TTY,'PASCAL:',CHR(11B),FILENAME:6);
(* 41 - Don't print header *)
(* 26 - break not needed for TTY *)
BLOCK(NIL,BLOCKBEGSYS OR STATBEGSYS-[CASESY],[PERIOD]);
(* 104 - detect programs that don't fit in address space *)
if (highestcode > 777777B) or (lcmain > 377777B)
then error(266);
(* 5 - CREF *)
IF CREF
THEN WRITE(CHR(16B),CHR(10),'.GLOBAL. ');
(* 16 - EOF *)
ENDOFLINE(TRUE);
(* 5 - CREF *)
if cref and not eof(input)
then write(chr(177B),'A'); %balances <ro>B from ENDOFLINE\
(* 136 - LISTING FORMAT *)
NEWLINE ; NEWLINE ;
IF NOT ERRORFLAG
THEN
BEGIN
(* 4 - Make us look normal if called by COMPIL *)
WRITE('No ') ; IF NOT RPGENTRY THEN WRITE(TTY,'No ')
END
ELSE WRITE(TTY,'?');
(* 136 - LISTING FORMAT *)
WRITE('error detected') ; NEWLINE;
IF (NOT RPGENTRY) OR ERRORFLAG
THEN
(* 26 - break not needed for TTY *)
WRITELN(TTY,'error detected');
IF ERRORFLAG
(* 112 - clrbfi when error *)
THEN BEGIN
REWRITE(OUTPUTREL);
clribf;
end
ELSE IF NOT RPGENTRY THEN
BEGIN
(* 136 - LISTING FORMAT *)
WRITELN(TTY); NEWLINE;
I := (HIGHESTCODE - 400000B + 1023) DIV 1024;
WRITELN(TTY,'Highseg: ',I:3,'K'); WRITELN('Highseg: ',I:3,'K');
I := (LCMAIN + 1023) DIV 1024;
WRITELN(TTY,'Lowseg : ',I:3,'K'); WRITELN('Lowseg : ',I:3,'K');
END;
(* 4 - Make us look normal if called by COMPIL *)
IF NOT RPGENTRY THEN BEGIN
RTIME := RUNTIME - RTIME;
WRITE(TTY,'Runtime: ',(RTIME DIV 60000):3,':');
RTIME := RTIME MOD 60000;
WRITE(TTY,(RTIME DIV 1000):2,'.');
RTIME := RTIME MOD 1000;
WRITELN(TTY,RTIME:3)
(* 4 - get back to SCAN if appropriate *)
END;
PASXIT(INPUT,OUTPUT,OUTPUTREL)
END.