(*#C0,T-*) PROGRAM ICL9LPLIBNUC ; CONST (**** CONSTANT DEFINITIONS FOR INTERFACE TO EDINBURGH ROUTINES :- ****) (**** ----------------------------------------------------------- ****) (* GENERAL :- *) EDRSPOK = 0 ; (* JOB SPACE VARIABLE HANDLING :- *) EDJSVMDINT = 1 ; EDJSVMDSTR = 2 ; (* FILE HANDLING :- *) EDNFORD = 1 ; EDNFOWR = 2 ; EDNFORWND = 4 ; EDNFOENDF = 16 ; EDNFOCLS = 32 ; EDNFOPASF = 10 ; EDNFOPASRCF = 11 ; (**** GENERAL CONSTANT DEFINITIONS :- ****) (**** ------------------------------- ****) PASSUBSYSVERSION = '20.10' ; NILAD = 0 ; (* -IMPLEMENTATION OF POINTERS *) (* 2900 H/W DEPENDENT DEFS. :- *) BINWD = 4 ; MXBINWD = 3 ; WDINKB = ?I 100 ; (* DESCRIPTOR FORMATS :- *) MXINTINBND = ?I FFFFFF ; NILDESC = ?D FFFFFFFFFFFFFFFF; DETPBVC = ?I 18000000 ; (* -BYTE VECTOR, SCALED, BOUND-CHECKED *) DETPWDVC = ?I 28000000 ; (* -WORD VECTOR, SCALED, BOUND-CHECKED *) DETPLWDVC = ?I 30000000; BINSGMT = ?I 40000 ; MXBINSGMT = ?I 3FFFF ; WDINSGMT = ?I 10000 ; MXWDINSGMT = ?I FFFF ; (* CHAR. & BYTE STRING CONVENTIONS :- *) ALFALENB = 32 ; ALFA8LENB = 8 ; MXSTRLENB = 4096 ; IMPSTRLENB = 32 ; (* -THIS IS A PASCAL (RATHER THAN AN EDINBURGH) CONVENTION. *) GLOBALAREAMINLENWD = 8 ; (**** CONSTANT DEFINITIONS FOR CHARACTER CODE CONVERSION :- ****) (**** ----------------------------------------------------- ****) (* CHARACTER CODE IDENTIFIERS :- *) CCEBC = 0 ; (* -EBCDIC *) CCISO = 1 ; (* -ISO *) CCICL = 2 ; (* -ICL 1900 *) CCPASSUBSYS = CCEBC ; CCSYSINTNL = CCISO ; CCSYSEXTNL = CCEBC ; (* TRANSLATION TABLES :- *) CCTTIDENTITY = ?X '000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F'& '202122232425262728292A2B2C2D2E2F303132333435363738393A3B3C3D3E3F'& '404142434445464748494A4B4C4D4E4F505152535455565758595A5B5C5D5E5F'& '606162636465666768696A6B6C6D6E6F707172737475767778797A7B7C7D7E7F'& '808182838485868788898A8B8C8D8E8F909192939495969798999A9B9C9D9E9F'& 'A0A1A2A3A4A5A6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF'& 'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF'& 'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEFF0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF' ; CCTTEBCISO = ?X '000102039C09867F978D8E0B0C0D0E0F101112139D8508871819928F1C1D1E1F'& '80818283840A171B88898A8B8C050607909116939495960498999A9B14159E1A'& '20A0A1A2A3A4A5A6A7A85B2E3C282B2126A9AAABACADAEAFB0B15D242A293B5E'& '2D2FB2B3B4B5B6B7B8B97C2C255F3E3FBABBBCBDBEBFC0C1C2603A2340273D22'& 'C3616263646566676869C4C5C6C7C8C9CA6A6B6C6D6E6F707172CBCCCDCECFD0'& 'D17E737475767778797AD2D3D4D5D6D7D8D9DADBDCDDDEDFE0E1E2E3E4E5E6E7'& '7B414243444546474849E8E9EAEBECED7D4A4B4C4D4E4F505152EEEFF0F1F2F3'& '5C9F535455565758595AF4F5F6F7F8F930313233343536373839FAFBFCFDFEFF' ; CCTTEBCICL = ?X '4040404040404040404040404040404040404040404040404040404040404040'& '4040404040404040404040404040404040404040404040404040404040404040'& '104040404040404040403B1E0C181B11164040404040404040403D3C1A190B3E'& '1D1F4040404040404040401C153F0E0F404040404040404040400A1420170D12'& '4040404040404040404040404040404040404040404040404040404040404040'& '4040404040404040404040404040404040404040404040404040404040404040'& '40212223242526272829404040404040402A2B2C2D2E2F303132404040404040'& '1340333435363738393A40404040404000010203040506070809404040404040' ; CCTTISOEBC = ?X '00010203372D2E2F1605250B0C0D0E0F101112133C3D322618193F271C1D1E1F'& '404F7F7B5B6C507D4D5D5C4E6B604B61F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F'& '7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6D7D8D9E2E3E4E5E6E7E8E94AE05A5F6D'& '79818283848586878889919293949596979899A2A3A4A5A6A7A8A9C06AD0A107'& '202122232415061728292A2B2C090A1B30311A333435360838393A3B04143EE1'& '4142434445464748495152535455565758596263646566676869707172737475'& '767778808A8B8C8D8E8F909A9B9C9D9E9FA0AAABACADAEAFB0B1B2B3B4B5B6B7'& 'B8B9BABBBCBDBEBFCACBCCCDCECFDADBDCDDDEDFEAEBECEDEEEFFAFBFCFDFEFF' ; CCTTISOICL = ?X '4040404040404040404040404040404040404040404040404040404040404040'& '101112143C15161718191A1B1C1D1E1F000102030405060708090A0B0C0D0E0F'& '202122232425262728292A2B2C2D2E2F303132333435363738393A3B133D3E3F'& '4040404040404040404040404040404040404040404040404040404040404040'& '4040404040404040404040404040404040404040404040404040404040404040'& '4040404040404040404040404040404040404040404040404040404040404040'& '4040404040404040404040404040404040404040404040404040404040404040'& '4040404040404040404040404040404040404040404040404040404040404040' ; CCTTICLEBC = ?X 'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F404F7FE07B6C507D4D5D5C4E6B604B61'& '7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6D7D8D9E2E3E4E5E6E7E8E94A5B5A5F6D'& '0000000000000000000000000000000000000000000000000000000000000000'& '0000000000000000000000000000000000000000000000000000000000000000'& '0000000000000000000000000000000000000000000000000000000000000000'& '0000000000000000000000000000000000000000000000000000000000000000'& '0000000000000000000000000000000000000000000000000000000000000000'& '0000000000000000000000000000000000000000000000000000000000000000' ; CCTTICLISO = ?X '303132333435363738393A3B3C3D3E3F2021225C2325262728292A2B2C2D2E2F'& '404142434445464748494A4B4C4D4E4F505152535455565758595A5B245D5E5F'& '0000000000000000000000000000000000000000000000000000000000000000'& '0000000000000000000000000000000000000000000000000000000000000000'& '0000000000000000000000000000000000000000000000000000000000000000'& '0000000000000000000000000000000000000000000000000000000000000000'& '0000000000000000000000000000000000000000000000000000000000000000'& '0000000000000000000000000000000000000000000000000000000000000000' ; CCTTEBCGRAPHICS = ?X '4040404040404040404040404040404040404040404040404040404040404040'& '4040404040404040404040404040404040404040404040404040404040404040'& '404040404040404040404A4B4C4D4E4F504040404040404040405A5B5C5D5E5F'& '606140404040404040406A6B6C6D6E6F404040404040404040797A7B7C7D7E7F'& '4081828384858687888940404040404040919293949596979899404040404040'& '40A1A2A3A4A5A6A7A8A940404040404040404040404040404040404040404040'& 'C0C1C2C3C4C5C6C7C8C9404040404040D0D1D2D3D4D5D6D7D8D9404040404040'& 'E040E2E3E4E5E6E7E8E9404040404040F0F1F2F3F4F5F6F7F8F9404040404040' ; UCCONST = ' 0+-.Ee,*' ; (**** CONSTANT DEFINITIONS FOR POSTMORTEM PACKAGE INTERFACE :- ****) (**** -------------------------------------------------------- ****) MAPRECSIZE = 1 ; (* IN BYTES *) (**** CONSTANT DEFINITIONS FOR ERROR HANDLING, DIAGNOSTICS :- ****) (**** ------------------------------------------------------- ****) (* OMF T16 ENTRY ('MODCHAINENTRY') CONSTANTS :- *) EHMCENAMELENOFFSET = 31; EHMCENAMEOFFSET = 32; EHMCEDTTMOFFSET = 12; EHMCEDATELEN = 10; EHMCETIMELEN = 8; (* OMF T17 ENTRY ('AREA ENTRY') CONSTANTS :- *) EHAENAMELENOFFSET = 19; EHAENAMEOFFSET = 20; (* MESSAGE TEXT BASE NUMBERS *) EHDOCNMESSBASE = 1000; (* DOCUMENTATION MESSAGES (I.E. ERRORLINE,ROUTE,ETC *) EHCTDOCNMESSBASE = 1060; EHRNGERRMESSBASE = 1100; EHCASEERRMESSBASE = 1200; EHHEAPERRMESSBASE = 1300; EHFILEERRMESSBASE = 1400; EHPASSYSERR = 1500; EHIMPERROR = 10000; (* OPEH VALUES *) EHDIAGROUTEONLY = 1; (* DIAGNOSTIC PARAMETER *) EHDIAGFULLREPORT = 4; (* " " *) PASCALLANGUAGECODE = 'P'; (* CDIAG PARAMETER VALUES *) EHCTMINOP = 0; EHCTHEXDUMP = 1; EHCTHLDUMP = 2; EHCTMACVALUES = 10; EHCTMINOPMAC = 10; EHCTHEXDUMPMAC = 11; EHCTHLDUMPMAC = 12; (* GENERAL VALUES *) EHCOMPFAILRESPONSE = 5; (* CONTINGENCIES *) EHSTACKCONTINGENCY = 8; EHCONTINGENCYUPPERBOUND = 100; CONTINGENCYDATALENWD = 17 ; (**** CONSTANT DEFINITIONS FOR MATHS. FUNCTIONS :- ****) (**** -------------------------------------------- ****) (* ICL MATHS. LIB. ERROR HANDLING DEFINITIONS :- *) MFEINFOBLKMXIX = 5 ; MFEIBPROCNOIX = 1 ; MFEIBERRNOIX = 2 ; (**** CONSTANT DEFINITIONS FOR HEAP MANAGEMENT :- ****) (**** ------------------------------------------- ****) HEAPMINSZWD = ?I 100 ; (* -I.E.: 1 KB MINIMUM *) HEAPMINSZB = 1024; HEAPMXSZWD = WDINSGMT ; HEAPMXSZB = MXBINSGMT; HEAPMINFREEBLOCKSIZEWD = 2 ; (**** CONSTANT DEFINITIONS FOR FILE HANDLING :- ****) (**** ----------------------------------------- ****) (* EDINBURGH CHANNEL NO. CONVENTIONS :- *) EDCHNMX = 99 ; EDSTDIPCHN = 98 ; EDSTDOPCHN = 99 ; (* PASCAL SUBSYSTEM CONVENTIONS :- *) FNULLCHN = 0 ; (* TEXT BUFFER HANDLING :- *) TXBFMXDATALENB = 160 ; TXBFMXIX = 159 ; TXIPBFMXDATALENB = TXBFMXDATALENB ; TXOPBFLENB = TXBFMXDATALENB ; TXOPBFDATALENB = TXOPBFLENB ; (* CTMLOG 'MESSAGETYPE' VALUES *) LOGCTSUMMARYTYPE = 14 ; LOGCTDIAGTYPE = 15 ; (* EBCDIC CHARACTERS FOR USE CLOSE TO SYSTEM INTERFACE *) FORMFEEDFE = 12 ; (* X'0C' = FORM FEED FORMAT EFFECTOR *) SPACECHAR = 64 ; (* X'40' = SPACE CHARACTER *) (**** CONSTANT DEFINITIONS FOR PASCAL TEXTFILE I/O :- ****) (**** ----------------------------------------------- ****) (* ( -I.E. SUPPORT FOR "READ", "WRITE" ) *) (* -SEE ALSO DEFINITIONS FOR TEXT BUFFERS UNDER "FILE HANDLING" *) BOOLVALSTRLENB = 5 ; MAXINTDIV10 = 214748364 ; MAXINTMOD10 = 7 ; TYPE (**** GENERAL TYPE DEFINITIONS :- ****) (**** --------------------------- ****) WORD = INTEGER ; LONGINT = RECORD UH, LH : INTEGER END; ADDRESS = WORD ; RESPONSE = WORD ; POSINT = 0..MAXINT ; BYTEPT = @BYTE; WORDPT = @WORD ; TEXTPT = @TEXT ; (* 2900 H/W DEPENDANT DEFS. :- *) BINWDRNG = 0..MXBINWD ; BNDRNG = 0..MXINTINBND ; SGMTRNGB = 0..MXBINSGMT ; SGMTRNGWD = 0..MXWDINSGMT ; (* CHAR. & BYTE STRING DEFS. :- *) ALFARNGB = 1..ALFALENB ; ALFA8RNGB = 1..ALFA8LENB ; ALFA = PACKED ARRAY [ALFARNGB] OF CHAR ; ALFA8 = PACKED ARRAY [ALFA8RNGB] OF CHAR ; BALFA = PACKED ARRAY [ALFARNGB] OF BYTE ; BALFA8 = PACKED ARRAY [ALFA8RNGB] OF BYTE ; BALFAPT = @BALFA ; MXSZSTRRNGB = 1..MXSTRLENB ; MXSZBYTESTR = PACKED ARRAY [MXSZSTRRNGB] OF BYTE ; MXSZBYTESTRPT = @MXSZBYTESTR ; STRDESC = DESC ; (* -BY CONVENTION IN THIS LIBRARY, A "STRDESC" IS A BOUNDED BYTE-VECTOR *) (* DESCRIPTOR FOR A STRING OF BYTES OR CHARS.. *) (* DESCRIPTOR DEFS:- *) PROCDESC = DESC; (* PROCEDURE *) WVDESC = DESC; (* WORD VECTOR *) LWVDESC = DESC; (* LONG WORD VECTOR *) (* EDINBURGH "IMPSTRING" DEFS. :- *) IMPSTRRNGB = 0..IMPSTRLENB ; (* -"IMP" FORMAT STRINGS HAVE THE STRING'S LENGTH IN THE FIRST BYTE. *) IMPSTR = PACKED ARRAY [IMPSTRRNGB] OF BYTE ; (* OPERATING SYSTEM DEFS. :- *) INTJSV = RECORD UH, LH : INTEGER END ; (* -INT JSV'S ARE 64 BITS *) VSUMD = (VSDENSE, VSLOCALISED, VSSPARSE, VSSERIAL) ; (* -MODE OF USE FOR VIRTUAL STORE AREA *) (* RUNTIME-COMPILETIME OPTIONS *) BOOLOPTIONTYPE = (RANGECHECKSOPT, COMPILEROPT, DIAGLINEMAPOPT, DIAGNAMETABLEOPT, KEYEDENTRYOPT, FORWARDTRACEOPT); SETOFBOOLOPTIONTYPE = SET OF BOOLOPTIONTYPE; (* DEFINITION OF LAYOUT OF RESERVED PART AT START OF USER PROGRAM'S *) (* GLOBAL DATA AREA :- *) GLOBALAREAPT = @GLOBALAREA ; GLOBALAREA = RECORD JUNKA : ARRAY [0..3] OF WORD ; BASELNBTPANDBND : WORD ; BASELNBAD : ADDRESS ; JLKLINKREF : ADDRESS ; SPARE : WORD END ; (* DEFINITION OF LAYOUT OF FIXED PART OF OBJECT PROGRAM PLT *) PLTLAYOUT = RECORD STANDARD : ARRAY [0..7] OF WORD; GLOBAREADESCS : ARRAY [8..25] OF WORD; OBJECTAREADESC, TOKENAREADESC, MAPAREADESC : STRDESC; VALIDRTOPTIONS : SETOFBOOLOPTIONTYPE END; PLTLAYOUTPT = @PLTLAYOUT; (* DEFINITION OF LAYOUT OF FIXED PART OF STACK FRAME *) STACKFRAMELAYOUT = RECORD LNB : ADDRESS; PSR : WORD; PC : ADDRESS; PLTDESCTOP : WORD; PLTDESCAD : ADDRESS END; STACKFRAMELAYOUTPT = @STACKFRAMELAYOUT; (* TYPE DEFINITIONS FOR CHARACTER CODE CONVERSION :- *) (* ------------------------------------------------- *) CC = CCEBC..CCICL ; (* -EBCDIC, ISO, ICL 1900 *) CCTT = PACKED ARRAY [BYTE] OF BYTE ; CCTTPT = @CCTT ; CCTTPTTB = ARRAY [CC, CC] OF CCTTPT ; UC = (UCSPACE, UCZERO, UCPLUS, UCMINUS, UCPOINT, UCLETTERE, UCSMALLLETTERE, UCCOMMA, UCSTAR) ; UCRPKVC = PACKED ARRAY [UC] OF BYTE ; UCRPKVCPT = @UCRPKVC ; UCRUPVC = ARRAY [UC] OF BYTE ; UCRUPVCPT = @UCRUPVC ; UCRUPVCPTVC = ARRAY [CC] OF UCRUPVCPT ; UCRUPVCVCTYPE = ARRAY [CC] OF UCRUPVC ; (**** TYPE DEFINITIONS FOR POSTMORTEM PACKAGE INTERFACE :- ****) (**** ---------------------------------------------------- ****) OBJECTRECPT = BYTEPT; TOKENRECPT = BYTEPT; MAPRECPT = BYTEPT; (**** TYPE DEFINITIONS FOR ERROR HANDLING, DIAGNOSTICS :- ****) (**** --------------------------------------------------- ****) KINDOFBLOCK = (PROGBLK,PROCBLK,FUNCBLK,UNKNOWNBLK); JLKDIAGDATAREC = RECORD ADATTOPOFSTACKFRAME, ADOFGLOBALAREA : ADDRESS END; EHDOCNMESSTYPE = (INTERRUPTERRORMESS, ERRORMESS, LIBRARYERRORMESS, GROUPMESS, DESCRIPTIONMESS, LOCATIONMESS, LINEMESS, DISPMESS, INMESS, PROCEDUREMESS, FUNCTIONMESS, OFMESS, PROGRAMMESS, COMPILEDONMESS, ATMESS, PASCALMESS, MODULEMESS, MAINPROGBLKMESS, CODEAREAMESS, PASSUPSWERRMESS); EHCTDOCNMESSTYPE = (FAILUREHEADMESS, CONTINGENCYMESS, SUBTYPEMESS, IMPERRMESS, PASCALERRMESS, MODMESS, IINMESS, OFFSETMESS, ACTIVEPROCSMESS); CONTINGENCYMESSAGELAYOUT = RECORD CONTSUBTYPE, CONTTYPE : WORD END; REGISTERSLAYOUT = RECORD LNB, PSR, PC, SSR, SF, IT, IC, CTB, XNB, B, DRO, DR1, ACCO, ACC1, ACC2, ACC3, PPC : WORD END; CDIAGTYPE = EHCTMINOP..EHCTHLDUMPMAC; (* FOR DUMPS :- *) EHAREATYPE = (EHAREGISTERS, EHASTACKFRAME, EHAUSRPRGGLOBAL, EHAHEAP, EHALIBNUCGLOBAL) ; (* FOR ERRORS DURING INITIALISATION :- *) EHINITERRTP = (EHIGLBLLEN, EHIHEAPOFLO,EHIFTPFAIL) ; (**** TYPE DEFINITIONS FOR MATHS. FUNCTIONS :- ****) (**** ---------------------------------------- ****) (* FOR MATHS LIB. PARAMETER ERRORS :- *) MFEINFOBLKRNG = 0..MFEINFOBLKMXIX ; MFEINFOBLK = PACKED ARRAY [MFEINFOBLKRNG] OF BYTE ; MFEINFOBLKPT = @MFEINFOBLK ; (**** TYPE DEFINITIONS FOR HEAP MANAGEMENT :- ****) (**** --------------------------------------- ****) HEAPERRORTYPE = (HENSIZEINVALID, HENNOROOM, HEDADINVALID, HEDSIZECHECK, HEDSIZEINVALID, HEDADINFREE) ; (**** TYPE DEFINITIONS FOR FILE-HANDLING :- ****) (**** ------------------------------------- ****) (* FOR DIAGNOSTICS AND ERROR HANDLING :- *) FWARNTYPE = (FWTXIPBFOFLO) ; FERRORTYPE = (FESYSOPEN, FERWNDSTD, FERCBFSYSMXLEN, FERCIPBFLEN, FERCOPFFULL, FEIPACS, FEIPEOF, FEOPACS, FETXOPCHWIDTH, FETXOPSTRWIDTH, FETXOPINTWIDTH, FETXIPINTEOF, FETXIPINTFIRSTDIG, FETXIPINTOFLO, FETXIPRLINVALIDCH, FETXIPRLOFLO, FETXOPFFULL) ; TXFCLASS = (ORDINARYTXF, RTSTDIP , RTSTDOP , CTLIST, CTJRNL, CTDIAG, RTJRNL, RTDIAG) ; STDSYSOPF = CTLIST..RTDIAG ; FACSMD = (FNOTOPEN, FACSIP, FACSOP) ; FIOMD = FACSIP..FACSOP ; EDCHNRNG = 0..EDCHNMX ; (* -0 IS A DUMMY, "NULL" CHANNEL *) FUNITRNG = EDCHNRNG ; TXBFRNG = 0..TXBFMXIX ; TXBFCOUNT = 0..TXBFMXDATALENB; TXBF = PACKED ARRAY [TXBFRNG] OF BYTE ; RCBFRNG = POSINT ; (* EDINBURGH "FILE DESCRIPTOR" FORMAT :- *) EDFD = RECORD JUNKA : WORD ; EDCHN : EDCHNRNG ; JUNKB : ARRAY [2..5] OF WORD ; EDBFAD : ADDRESS ; EDRCLENB : RCBFRNG ; JUNKC : WORD ; EDMXRCLENB : RCBFRNG ; JUNKD : ARRAY [10..31] OF WORD END ; EDFDPT = @EDFD ; FVPT = @FVAR ; FCBPT = @FCBLOCK ; FVAR = RECORD TXCHRCAD : WORD ; (* -USE DIFFERS FOR TEXT & NON-TEXT *) CHAD : ADDRESS ; FEOLN, FEOF : BOOLEAN ; DUM1 : WORD ; FCBLK : FCBPT ; DUM2 : WORD ; LASTCHAD : ADDRESS END ; FCBLOCK = RECORD NEXTFCBP : FCBPT ; FVLK : FVPT ; FUNITNO : FUNITRNG ; FACS : FACSMD ; BFCOUNT : POSINT ; NAMEPRG : ALFA ; CASE TX : BOOLEAN OF FALSE : ( RCBFAD : ADDRESS ; RCLENRQB : RCBFRNG ; EDRCFFDLK : EDFDPT) ; TRUE : ( FESLOT : WORD ; FTXBF : TXBF ; EOLANDOFLOSLOT : WORD ; TXBFAD : ADDRESS ; THROWPAGE : BOOLEAN ; FCCINTERNAL : CC ; FCCTTP : CCTTPT ; FUCRUPVCP : UCRUPVCPT ; CASE TXFKIND : TXFCLASS OF ORDINARYTXF, RTSTDIP, RTSTDOP : (EDTXFFDLK : EDFDPT) ; CTLIST, CTJRNL, CTDIAG, RTJRNL, RTDIAG : () ) END ; (**** TYPE DEFINITIONS FOR PASCAL TEXTFILE I/O :- ****) (**** ------------------------------------------- ****) (* ( -I.E. SUPPORT FOR "READ", "WRITE" ) *) (* -SEE ALSO DEFINITIONS OF "TXBFRNG", "TXBF" UNDER "FILE HANDLING" *) (* FOR REAL "READ" ERRORS :- *) RRERRORTYPE = (RREINVALIDCH, RREOFLO) ; (* FOR SHORT STRING O/P :- *) WORDSTRRNGB = 1..BINWD ; WORDSTR = PACKED ARRAY [WORDSTRRNGB] OF BYTE ; (* FOR BOOLEAN O/P :- *) BOOLVALSTRRNG = 1..BOOLVALSTRLENB ; BOOLVALSTR = PACKED ARRAY [BOOLVALSTRRNG] OF CHAR ; VAR (**** GLOBAL VARIABLES FOR GENERAL USE :- ****) (**** ----------------------------------- ****) ATCOMPILETIME : BOOLEAN ; (* GLOBAL VARIABLES FOR CHARACTER CODE CONVERSION :- *) (* ------------------------------------------------- *) CCUSRPRG : CC ; CCTTPTB : CCTTPTTB ; PASSBSYSGRAPHICSTTP : CCTTPT; IDCCTTP : CCTTPT ; UCRUPVCPVC : UCRUPVCPTVC ; UCRUPVCVC : UCRUPVCVCTYPE ; (**** GLOBAL VARIABLES FOR COMPILER LISTING FILE :- ****) (**** --------------------------------------------- ****) CTLISTFV : FVAR; CTLISTFP : TEXTPT; (**** GLOBAL VARIABLES FOR JOURNAL ACCESS :- ****) (**** -------------------------------------- ****) JRNLFV : FVAR ; JRNLFP : TEXTPT ; (**** GLOBAL VARIABLES FOR POSTMORTEM PACKAGE INTERFACE :- ****) (**** ---------------------------------------------------- ****) OBJECTSTARTADDR, TOKENSTARTADDR, MAPSTARTADDR, OBJECTCURRADDR, TOKENCURRADDR, MAPCURRADDR, OBJECTENDADDR, TOKENENDADDR, MAPENDADDR : ADDRESS ; (**** GLOBAL VARIABLES FOR ERROR HANDLING, DIAGNOSTICS :- ****) (**** --------------------------------------------------- ****) DIAGFV : FVAR ; DIAGFP : TEXTPT ; USRPRGGLBLP : GLOBALAREAPT ; (* FOR DUMPS :- *) HEXDIGITS : PACKED ARRAY[0..15] OF CHAR; CONTINGENCYDATAAD, CURRSTACKFRAMEAD, USRPRGSTACKBASEAD, USRPRGGLOBALBASEAD, LIBNUCGLOBALBASEAD : ADDRESS ; USRPRGGLOBALLENB, LIBNUCGLOBALLENB : SGMTRNGB ; CURRSTACKFRAMELENW : SGMTRNGWD; DIAGLINEMAP, DIAGNAMETABLE : BOOLEAN; EHCONTINGENCYMESSAGE : CONTINGENCYMESSAGELAYOUT; EHREGISTERS : REGISTERSLAYOUT; CDIAG : CDIAGTYPE; CTDIAGMESSTYPE : INTEGER; COMPILERSTACKBASEAD : ADDRESS; TEMPJLKDIAGDATA : JLKDIAGDATAREC ; (* SEE ALSO "LIBNUCLASTDATAITEM" AT END OF GLOBAL VAR DECLARATIONS *) (**** GLOBAL VARIABLES FOR TIME ROUTINES :- ****) (**** ------------------------------------- ****) STARTPROCTIME : LONGINT; (**** GLOBAL VARIALBLES FOR HEAP MANAGEMENT :- ****) (**** ---------------------------------------- ****) HEAPBASEAD, LASTADINHEAP, MAXUSEDHEAPAD, BASEFREEHEAPAD, MAXFREEHEAPAD : ADDRESS ; (**** GLOBAL VARIABLES FOR FILE HANDLING :- ****) (**** ------------------------------------- ****) FCBCHAINP : FCBPT ; HNOPLINEFAIL : BOOLEAN ; CUREDCHN : EDCHNRNG ; (**** THE FOLLOWING SHOULD ALWAYS BE THE LAST (GLOBAL) "VAR" ****) (**** DECLARATION AS IT IS USED TO DETERMINE THE SIZE OF ****) (**** LIBNUC'S GLOBAL DATA AREA FOR ERROR HANDLING. ****) LIBNUCLASTDATAITEM : WORD ; (**** SFL GENERAL SUPPORT ROUTINES :- ****) (**** ------------------------------- ****) PROCEDURE ICL9LPMASKUFLOW ; EXTERN ; PROCEDURE ICL9LPLONGISB (LI1,LI2 : LONGINT; VAR LI2ISBLI1 : LONGINT) ; EXTERN ; PROCEDURE ICL9LPLONGIDIV (LI1,LI2 : LONGINT; VAR LI2IDVLI1 : LONGINT); EXTERN; (**** SFL CTM INTERFACE ROUTINES :- ****) (**** ----------------------------- ****) PROCEDURE ICL9LPCTMDUMP (SUBTYP, TYP, FRAMESDATA : INTEGER; AREASDR : LWVDESC; OPTIONS : INTEGER) ; EXTERN ; PROCEDURE ICL9LPCTMLOG (MESSAGEDESC : STRDESC); EXTERN ; PROCEDURE ICL9LPCTMPROCTIME (VAR PROCTIME : LONGINT); EXTERN ; PROCEDURE ICL9LPCTMRMLD (CODEADDRESS : ADDRESS; VAR MODNAME : ALFA; VAR IIN : POSINT; VAR OFFSET : SGMTRNGB ); EXTERN ; (**** SFL CTSUPPORT ROUTINES :- ****) (**** ------------------------- ****) PROCEDURE ICL9LPCTNOMINATEERRPROC (CONTINGENCYMESSAD, REGISTERSAD : ADDRESS) ; EXTERN ; (**** SFL RT SUPPORT ROUTINES :- ****) (**** -------------------------- ****) FUNCTION ICL9LPRTTIDYPROCDESC : PROCDESC ; EXTERN ; FUNCTION ICL9LPRTGETICL9HERRADDR : ADDRESS ; EXTERN ; (**** PASCAL CT SUPPORT ROUTINES :- ****) (**** ------------------------------ ****) PROCEDURE ICL9LPCTGETVSAREA (AREANAMEDR : STRDESC; SIZEB : SGMTRNGB; MODEOFUSE : VSUMD; VAR AREAAD : ADDRESS ) ; EXTERN ; PROCEDURE ICL9LPCTDATEANDTIME (VAR DATE, TIME : ALFA8) ; EXTERN ; PROCEDURE ICL9LPCTABORT (COMPILERFAIL : BOOLEAN) ; EXTERN ; (**** EDINBURGH INTERFACE ROUTINE SPECS. :- ****) (**** ------------------------------------- ****) (* GENERAL :- *) PROCEDURE ICL9CEZTIDY ; EXTERN ; PROCEDURE ICL9CEZINIT(LANG, LNBVAL : WORD ; DIAGPROC : PROCDESC; PADDING1, PADDING2 : WORD) ; EXTERN ; PROCEDURE ICL9CEZSTOP ; EXTERN ; (* JOB SPACE VARIABLE ACCESS :- *) FUNCTION ICL9CEZREADJSVAR ( VAR JSVNAME : IMPSTR ; JSVKIND : INTEGER ; RESULTAD : ADDRESS) : RESPONSE ; EXTERN ; FUNCTION ICL9CEZWRITEJSVAR ( VAR JSVNAME : IMPSTR ; JSVKIND : INTEGER ; USEVALUEAD : ADDRESS) : RESPONSE ; EXTERN ; (* VIRTUAL STORE MANAGEMENT :- *) PROCEDURE ICL9CEZOUTFILE ( VAR AREANM : IMPSTR ; SIZEB, MAXSIZEB : POSINT ; USE : VSUMD ; VAR AREAAD : ADDRESS ; VAR RSP : RESPONSE) ; EXTERN ; (* FILE HANDLING :- *) FUNCTION ICL9CEZNEWFILEOP (CHAN : EDCHNRNG ; ACTION : WORD ; FTYPE : WORD ; VAR EDFDLINK : EDFDPT) : RESPONSE ; EXTERN ; FUNCTION ICL9CEZINREC : RESPONSE ; EXTERN ; FUNCTION ICL9CEZOUTREC (LENGTHB : RCBFRNG) : RESPONSE ; EXTERN ; (* DATE AND TIME :- *) FUNCTION ICL9CEZDATEANDTIME (VAR DATE, TIME : IMPSTR) : RESPONSE ; EXTERN ; FUNCTION ICL9CEZREADCPUTIME : WORD ; EXTERN ; (**** RUN-TIME MESAGE TEXT PROCEDURE SPEC :- ****) (**** -------------------------------------- ****) FUNCTION ICL9LPEHMTM (MESSNO : INTEGER) : STRDESC; EXTERN ; (**** POST-MORTEM PACKAGE PROCEDURE SPECS.:- ****) (**** -------------------------------------- ****) PROCEDURE ICL9LPPMINITTABS (MAPREQD, OBJTABREQD : BOOLEAN; USERCC : CC; FROMUSERCCTRANTABP : CCTTPT; VAR RESULT : RESPONSE) ; EXTERN ; PROCEDURE ICL9LPPMLINENO (CODEOFFSETB : SGMTRNGB; VAR SOURCELINE : POSINT) ; EXTERN ; PROCEDURE ICL9LPPMBLOCKID ( CODEOFFSETB : SGMTRNGB; VAR BLOCKKIND : KINDOFBLOCK; VAR BLOCKNAME : ALFA ); EXTERN ; PROCEDURE ICL9LPPMDMPSPACE (CODEOFFSETB : SGMTRNGB; FRAMEBASEAD, GLOBALBASEAD, HEAPBASEAD, HEAPLASTUSEDAD : ADDRESS; FRAMESIZEWD : SGMTRNGWD; VAR DIAGFILE : TEXT; ARRAYSIZE : INTEGER ); EXTERN ; (**** COMPILER ENVIRONMENT PROCEDURE SPECS :- ****) (**** --------------------------------------- ****) FUNCTION ICL9HNLOG (MESSAGE : STRDESC ; DESTINATION : INTEGER ) : RESPONSE ; EXTERN ; FUNCTION ICL9HNOUTPUTLINE (BUFFER : STRDESC) : RESPONSE ; EXTERN ; FUNCTION ICL9HNNEWLINE (LINES : INTEGER) : RESPONSE ; EXTERN ; FUNCTION ICL9HNNEWPAGE : RESPONSE ; EXTERN ; PROCEDURE ICL9HNDUMP (CONTSUBTYPE, CONTTYPE : WORD; AREAS : DESC); EXTERN ; (**** OPEH PROCEDURE SPECS.:- ****) (**** ----------------------- ****) PROCEDURE ICL9HEDIAGOUT (VAR POSITION : INTEGER; TEXT : STRDESC ); EXTERN ; PROCEDURE ICL9HEFATALCOMPERR (LANGUAGECODE : CHAR; ERRORNUMBER : POSINT ); EXTERN ; PROCEDURE ICL9HERESET ; EXTERN ; PROCEDURE ICL9HEPROLOG (STEERINGPARAM : INTEGER); EXTERN ; FUNCTION ICL9HEFILETIDYPROC (TIDYPROCDESC : PROCDESC) : RESPONSE; EXTERN ; PROCEDURE ICL9HETIDYUP; EXTERN ; (**** ICL MATHS. LIB. ROUTINE SPECS. :- ****) (**** --------------------------------- ****) FUNCTION ICL9CM2SIN (VAR VAL : REAL) : REAL ; ALIEN ; FUNCTION ICL9CM2COS (VAR VAL : REAL) : REAL ; ALIEN ; FUNCTION ICL9CM2ATAN (VAR VAL : REAL) : REAL ; ALIEN ; FUNCTION ICL9CM2LOG (VAR VAL : REAL) : REAL ; ALIEN ; FUNCTION ICL9CM2EXP (VAR VAL : REAL) : REAL ; ALIEN ; FUNCTION ICL9CM2SQRT (VAR VAL : REAL) : REAL ; ALIEN ; (**** SPECS. FOR EXTERNAL REAL I/O ROUTINES :- ****) (**** ---------------------------------------- ****) PROCEDURE ICL9LPRIOREAD (VAR RESULT : REAL ; VAR USEFULREPS : UCRUPVC ; VAR FV : FVAR) ; EXTERN ; PROCEDURE ICL9LPRIOWRFIX (VAL : REAL ; FIELDWIDTH, DECDIGCNT : POSINT ; VAR USEFULREPS : UCRUPVC ; VAR FV : FVAR) ; EXTERN ; PROCEDURE ICL9LPRIOWRFLOAT (VAL : REAL ; FIELDWIDTH : POSINT ; VAR USEFULREPS : UCRUPVC ; VAR FV : FVAR) ; EXTERN ; (**** SPECS. OF ROUTINES TO WHICH THERE ARE FORWARD REFERENCES :- ****) (**** ----------------------------------------------------------- ****) (*#E-*) (* FROM HEAP SECTION FOR USE BY JRNL SECTION (JRNLFINISHMSG) :- *) FUNCTION MAXHEAPBYTESUSED : SGMTRNGB ; FORWARD ; (* FROM HEAP SECTION FOR USE BY EHDIAG SECTION (EHDUMPAREA) :- *) PROCEDURE GIVEHEAPBASEANDSIZE (VAR BASEAD : ADDRESS ; VAR SIZEB : SGMTRNGB) ; FORWARD ; (*#E+*) (* WITHIN FILE SECTION (FSTART) *) PROCEDURE ICL9LPWRITELINE (VAR FV : FVAR) ; FORWARD ; (* FROM FILE SECTION FOR USE BY JRNL SECTION (JRNLFILEINIT) AND BY *) (* EHDIAG SECTION (INITDIAGFILE) :- *) PROCEDURE ICL9LPFILEDECL (VAR FV : FVAR ; NAME : ALFA ; TEXTF, PERMF : BOOLEAN ; TXKIND : TXFCLASS ; UNITNO : FUNITRNG ; RCLENWD : POSINT) ; FORWARD ; (* FROM TXIO SECTION FOR USE BY GENUT SECTION (WRITESTR) :- *) PROCEDURE ICL9LPWRITEBSTR (STRD : STRDESC ; VAR FV : FVAR) ; FORWARD ; (**** G E N E R A L & U T I L I T Y R O U T I N E S ****) (**** --------------------------------------------------- ****) (*#E-*) (*#T-*) PROCEDURE PLITTR (STRDSC, TTDSC : DESC) ; CONST PINS16LDSTRDSC = ?I 7885 ; (* -I.E. :- *) (* ORDER = 78 FOR : LD *) (* K = 1 FOR : 16-BIT INSTRUCTION, FORM IS (LNB+N) *) (* N = 5 FOR : STRDSC OFFSET *) PINS16LSDTTDSC = ?I 6487 ; (* -I.E. :- *) (* ORDER = 64 FOR : LSD *) (* K = 1 FOR : 16-BIT INSTRUCTION, FORM IS (LNB+N) *) (* N = 7 OFR : TTDSC OFFSET *) SINS16TTR = ?I A700 ; (* -I.E. ;- *) (* ORDER = A6 FOR : TTR *) (* H = 1 FOR : BYTE COUNT FROM DR BOUND FIELD *) (* Q = 0 FOR : 16-BIT INSTRUCTION *) (* N = 0 FOR : UNUSED *) BEGIN (* N.B. :- THE CODE OF THIS PROCEDURE MUST BE COMPILED WITH *) (* TRACING SWITCHED "OFF", I.E. WITHOUT ANY EXTRA *) (* CODE BEING GENERATED TO SAVE THE SOURCE LINE *) (* NUMBER. *) CODE16 (PINS16LDSTRDSC) ; CODE16 (PINS16LSDTTDSC) ; CODE16 (SINS16TTR) ; END (* PLITTR *) ; FUNCTION PLIUSB (W1, (* FROM *) W2 : WORD ) : WORD ; CONST PINS16LSSW2 = ?I 6286 ; (* -I.E. :- *) (* ORDER = 62 FOR : LSS *) (* K = 1 FOR : 16-BIT INSTRUCTION, FORM IS (LNB+N) *) (* N = 6 FOR : W2 OFFSET *) PINS16USBW1 = ?I C285 ; (* -I.E. :- *) (* ORDER = C2 FOR : USB *) (* K = 1 FOR : 16-BIT INSTRUCTION, FORM IS (LNB+N) *) (* N = 5 FOR : W1 OFFSET *) PINS16STPLIUSB = ?I 4887 ; (* -I.E. :- *) (* ORDER = 48 FOR : ST *) (* K = 1 FOR : 16-BIT INSTRUCTION, FORM IS (LNB+N) *) (* N = 7 FOR : PLIUSB FUNCTION RESULT OFFSET. *) BEGIN (* N.B. :- THE CODE OF THIS PROCEDURE MUST BE COMPILED WITH *) (* TRACING SWITCHED "OFF", I.E. WITHOUT ANY EXTRA *) (* CODE BEING GENERATED TO SAVE THE SOURCE LINE *) (* NUMBER. *) CODE16 (PINS16LSSW2) ; CODE16 (PINS16USBW1) ; CODE16 (PINS16STPLIUSB) ; END (* PLIUSB *) ; PROCEDURE PLIMV (SCED, DESTD : DESC) ; CONST PINS16LSDSCED = ?I 6485 ; (* -I.E. :- *) (* ORDER = 64 FOR LSS, *) (* K = 1 FOR 16-BIT INSTRUCTION, OF FORM (LNB+N), *) (* N = 5 FOR SCED OFFSET. *) PINS16LDDESTD = ?I 7887 ; (* -I.E. :- *) (* ORDER = 78 FOR LD, *) (* K = 1 FOR 16-BIT INSTRUCTION, OF FORM (LNB+N), *) (* N = 7 FOR DESTD OFFSET. *) SINS16MV = ?I B300 ; (* -I.E. :- *) (* ORDER = B2 FOR MV, *) (* H = 1 MEANS STRING LENGTH FROM DR-REG BOUND FIELD, *) (* Q = 0 FOR 16-BIT INSTRUCTION, *) (* N (UNUSED) = 0. *) BEGIN CODE16 (PINS16LSDSCED) ; CODE16 (PINS16LDDESTD) ; CODE16 (SINS16MV) ; END (* PLIMV *) ; PROCEDURE PLIMVL (SCE : BYTE ; DESTD : DESC) ; CONST PINS16LBSCE = ?I 7A85 ; (* -I.E. :- *) (* ORDER = 7A FOR LB, *) (* K = 1 FOR 16-BIT INSTRUCTION, OF FORM (LNB+N), *) (* N = 5 FOR SCE OFFSET. *) PINS16LDDESTD = ?I 7886 ; (* -I.E. :- *) (* ORDER = 78 FOR LD, *) (* K = 1 FOR 16-BIT INSTRUCTION, OF FORM (LNB+N), *) (* N = 6 FOR DESTD OFFSET. *) SINS16MVL = ?I B100 ; (* -I.E. :- *) (* ORDER = B0 FOR MVL, *) (* H = 1 MEANS BYTE COUNT FROM DR-REG BOUND FIELD, *) (* Q = 0 FOR 16-BIT INSTRUCTION, *) (* N (UNUSED) = 0. *) BEGIN CODE16 (PINS16LBSCE) ; CODE16 (PINS16LDDESTD) ; CODE16 (SINS16MVL) ; END (* PLIMVL *) ; FUNCTION CURLOCALNAMEBASEAD : ADDRESS ; CONST PINS16LSSDYNLINK = ?I 6280 ; (* -I.E.: ORDER=62 FOR LSS, K=1 FOR 16-BIT INSTRUCTION WITH FORM *) (* (LNB+N), N=0 FOR DYNAMIC STACK-FRAME LINK OFFSET. *) PINS16STHOLDLINK = ?I 4886 ; (* -I.E.: ORDER=48 FOR ST, K=1 FOR 16-BIT INSTRUCTION WITH FORM *) (* (LNB+N), N=6 FOR "HOLDLINK" OFFSET (-SEE VAR DECLARATION *) (* BELOW) . *) VAR HOLDLINK : WORD ; BEGIN CODE16 (PINS16LSSDYNLINK) ; CODE16 (PINS16STHOLDLINK) ; CURLOCALNAMEBASEAD := ANDX (HOLDLINK, ?I FFFFFFFC) ; END (* CURLOCALNAMEBASEAD *) ; FUNCTION CURTOPOFSTACKAD : ADDRESS ; VAR CURLNBVAL : ADDRESS ; BEGIN CURLNBVAL := CURLOCALNAMEBASEAD ; CURTOPOFSTACKAD := CURLNBVAL - BINWD * ORD (ODD (WORDAT(CURLNBVAL))) ; END (* CURTOPOFSTACKAD *) ; FUNCTION CURPLTBASEAD : ADDRESS ; CONST PINS16STCTCURPLTBASEAD = ?I 3685 ; (* I.E.: ORDER=36 FOR STCT, K=1 FOR 16-BIT INSTRUCTION WITH FORM *) (* (LNB+N), N=5 FOR "CURPLTBASEAD" OFFSET. *) BEGIN CODE16 (PINS16STCTCURPLTBASEAD) ; END (* CURPLTBASEAD *) ; FUNCTION CURGLOBALBASEAD : ADDRESS ; CONST PINS16STXNCURGLOBALBASEAD = ?I 4C85 ; (* -I.E.: ORDER=4C FOR STXN, K=1 FOR 16-BIT INSTRUCTION WITH FORM *) (* (LNB+N), N=5 FOR "CURGLOBALBASEAD" OFFSET. *) BEGIN CODE16 (PINS16STXNCURGLOBALBASEAD) ; END (* CURGLOBALBASEAD *) ; PROCEDURE WRITESIGHEXWORD (VAR F : TEXT ; W : WORD) ; VAR WAD : ADDRESS; I : 0..3; B : BYTE; LEFTDIG, RIGHTDIG : BYTE; SIG : BOOLEAN; BEGIN SIG := FALSE; WAD := ADDRESSOF(W); FOR I := 0 TO 3 DO BEGIN B := BYTEAT(WAD+I); LEFTDIG := B DIV 16; RIGHTDIG := B MOD 16; SIG := SIG OR (LEFTDIG <> 0); IF SIG THEN WRITE(F,HEXDIGITS[LEFTDIG]); SIG := SIG OR (RIGHTDIG <> 0); IF SIG OR (I=3) THEN WRITE(F,HEXDIGITS[RIGHTDIG]); END; END (* WRITESIGHEXWORD *); PROCEDURE WRITESIGALFA (VAR F : TEXT; A : ALFA); VAR LEN : 0..ALFALENB; IX : 1..ALFALENB; ENDFOUND : BOOLEAN; BEGIN LEN := 0; REPEAT ENDFOUND := (LEN = ALFALENB); IF NOT ENDFOUND THEN BEGIN IX := LEN + 1; ENDFOUND := (A[IX] = ' '); IF NOT ENDFOUND THEN LEN := IX; END; UNTIL ENDFOUND; WRITE(F,A:LEN); END (* WRITESIGALFA *); PROCEDURE WRITESTR (VAR TXF : TEXT ; STRD : STRDESC) ; VAR FVP : FVPT ; BEGIN FVP := TYPECONV (FVPT, ADDRESSOF (TXF)) ; ICL9LPWRITEBSTR (STRD, FVP@) ; END (* WRITESTR *) ; FUNCTION MODSTRDESC (D : STRDESC; MODIFIER : INTEGER) : STRDESC; VAR BND:BNDRNG; AD:ADDRESS; TYP:WORD; DMODDED:STRDESC; BEGIN DESPLIT(D,TYP,BND,AD); BND:=BND-MODIFIER; AD:=AD+MODIFIER; DEVARSETUP(DMODDED,TYP,BND,AD); MODSTRDESC:=DMODDED END (* MODSTRDESC *); PROCEDURE MAKEIMPSTR (SCED : STRDESC ; VAR DEST : IMPSTR) ; VAR SCEP : BALFAPT ; BNDSCE : BNDRNG ; I : IMPSTRRNGB ; BEGIN BNDSCE := DEBOUND (SCED) ; IF BNDSCE > IMPSTRLENB THEN BNDSCE := IMPSTRLENB ; SCEP := TYPECONV (BALFAPT, DEADDR (SCED)) ; FOR I := 1 TO BNDSCE DO DEST [I] := CCTTPTB [CCPASSUBSYS, CCSYSINTNL]@ [SCEP@ [I]] ; DEST [0] := BNDSCE ; END (* MAKEIMPSTR *) ; PROCEDURE READINTJSV (NAMED : STRDESC ; VAR VALUE : INTJSV ; VAR RSP : RESPONSE) ; VAR IMPNM : IMPSTR ; BEGIN MAKEIMPSTR (NAMED, IMPNM) ; RSP := ICL9CEZREADJSVAR (IMPNM, EDJSVMDINT, ADDRESSOF (VALUE)) ; END (* READINTJSV *) ; FUNCTION TIDYINTJSV (VALUE : INTJSV ; EDRSP : INTEGER) : INTEGER ; BEGIN WITH VALUE DO IF (EDRSP <> EDRSPOK) OR (UH > 0) OR (UH < -1) OR ((UH = 0) AND (LH < 0)) OR ((UH = -1) AND (LH > 0)) THEN TIDYINTJSV := 0 ELSE TIDYINTJSV := LH ; END (* TIDYINTJSV *) ; FUNCTION INTJSVVALUE (NAMED : STRDESC) : INTEGER ; VAR FULLVALUE : INTJSV ; EDRSP : RESPONSE ; BEGIN READINTJSV (NAMED, FULLVALUE, EDRSP) ; INTJSVVALUE := TIDYINTJSV (FULLVALUE, EDRSP) ; END (* INTJSVVALUE *) ; PROCEDURE RTGETVSAREA (NAMED : STRDESC ; SIZEB : POSINT ; MODEOFUSE : VSUMD; VAR AREAAD : ADDRESS) ; VAR IMPAREANM : IMPSTR ; OFRSP : RESPONSE ; BEGIN MAKEIMPSTR (NAMED, IMPAREANM) ; ICL9CEZOUTFILE (IMPAREANM, SIZEB, SIZEB, MODEOFUSE, AREAAD, OFRSP) ; END (* GETVSAREA *) ; (**** C H A R A C T E R C O D E C O N V E R S I O N ****) (**** ------------------------------------------------- ****) (*#E-*) PROCEDURE CCTRANSLATE (AD : ADDRESS ; LENB : POSINT ; TTP : CCTTPT) ; VAR STRD : DESC ; BEGIN DEVARSETUP (STRD, DETPBVC, LENB, AD) ; PLITTR (STRD, DEREFWITHBND (TTP@)) ; END (* DOCCTRANSLATE *) ; (*#E+*) PROCEDURE ICL9LPCHARCODEIS (NEWCC : CC) ; BEGIN CCUSRPRG := NEWCC ; END (* ICL9LPCHARCODEIS *) ; PROCEDURE ICL9LPGETCHARTAB (VAR TARGETCC : CC ; VAR CCTTPVAR : CCTTPT) ; BEGIN CCTTPVAR := CCTTPTB [CCUSRPRG, TARGETCC] ; END (* ICL9LPGETCHARTAB *) ; (*#E-*) PROCEDURE INITCHARCODECONVERSION ; VAR UCRPKVCP : UCRPKVCPT ; CC1, CC2 : CC ; UC1 : UC ; BEGIN CCUSRPRG := CCEBC ; PASSBSYSGRAPHICSTTP:=TYPECONV(CCTTPT,ADDRESSOF(CCTTEBCGRAPHICS)); IDCCTTP := TYPECONV (CCTTPT, ADDRESSOF (CCTTIDENTITY)) ; FOR CC1 := CCEBC TO CCICL DO FOR CC2 := CCEBC TO CCICL DO CCTTPTB [CC1, CC2] := IDCCTTP ; CCTTPTB [CCEBC, CCISO] := TYPECONV (CCTTPT, ADDRESSOF (CCTTEBCISO)) ; CCTTPTB [CCEBC, CCICL] := TYPECONV (CCTTPT, ADDRESSOF (CCTTEBCICL)) ; CCTTPTB [CCISO, CCEBC] := TYPECONV (CCTTPT, ADDRESSOF (CCTTISOEBC)) ; CCTTPTB [CCISO, CCICL] := TYPECONV (CCTTPT, ADDRESSOF (CCTTISOICL)) ; CCTTPTB [CCICL, CCEBC] := TYPECONV (CCTTPT, ADDRESSOF (CCTTICLEBC)) ; CCTTPTB [CCICL, CCISO] := TYPECONV (CCTTPT, ADDRESSOF (CCTTICLISO)) ; UCRPKVCP := TYPECONV (UCRPKVCPT, ADDRESSOF (UCCONST)) ; FOR CC1 := CCEBC TO CCICL DO BEGIN FOR UC1 := UCSPACE TO UCSTAR DO UCRUPVCVC [CC1] [UC1] := CCTTPTB [CCPASSUBSYS, CC1]@ [UCRPKVCP@ [UC1]] ; UCRUPVCPVC [CC1] := TYPECONV (UCRUPVCPT, ADDRESSOF (UCRUPVCVC [CC1])) ; END ; END (* INITCHARCODECONVERSION *) ; (**** C O M P I L E R L I S T I N G F I L E ****) (**** ----------------------------------------- ****) (*#E-*) PROCEDURE INITCTLISTFILE ; CONST CTLISTNAME = '**COMPILATION-LISTING** '; BEGIN ICL9LPFILEDECL(CTLISTFV,CTLISTNAME,TRUE,TRUE, CTLIST,FNULLCHN,TXOPBFLENB); CTLISTFP := TYPECONV(TEXTPT,ADDRESSOF(CTLISTFV)); REWRITE(CTLISTFP@); END (* INITCTLISTFILE *); (**** J O U R N A L A C C E S S ****) (**** --------------------------- ****) (*#E-*) PROCEDURE JRNLDIRECTMSGLN (MSGD : STRDESC) ; BEGIN ICL9LPCTMLOG(MSGD); END (* JRNLDIRECTMSGLN *) ; PROCEDURE JRNLFILEINIT ; CONST JRNLNAME = '**JOURNAL-FILE** '; VAR TXKIND : TXFCLASS; BEGIN IF ATCOMPILETIME THEN TXKIND := CTJRNL ELSE TXKIND := RTJRNL; ICL9LPFILEDECL (JRNLFV, JRNLNAME, TRUE, TRUE, TXKIND, FNULLCHN, TXOPBFLENB) ; JRNLFP := TYPECONV (TEXTPT, ADDRESSOF (JRNLFV)) ; REWRITE (JRNLFP@) ; END (* JRNLFILEINIT *) ; PROCEDURE JRNLFINISHMSG ; BEGIN WRITELN(JRNLFP@,'HEAP BYTES USED : ',MAXHEAPBYTESUSED:1); WRITELN(JRNLFP@,'OCP TIME (MILLISECS.) : ',CLOCK:1); END (* JRNLFINISHMSG *); PROCEDURE INITJOURNAL ; BEGIN JRNLFILEINIT ; END (* INITJOURNAL *) ; (**** P O S T M O R T E M P A C K A G E I N T E R F A C E ****) (**** ------------------------------------------------------- ****) (*#E-*) PROCEDURE PMINITDIAGTABLES (STACKFRAMEPT : STACKFRAMELAYOUTPT); VAR PLTPT : PLTLAYOUTPT; DR : STRDESC; RC : RESPONSE ; PROCEDURE SETVBLES (AREADR:STRDESC; VAR STARTAD,CURRAD,ENDAD:ADDRESS); BEGIN STARTAD := DEADDR(AREADR); IF STARTAD = NILAD THEN ENDAD := NILAD ELSE ENDAD := STARTAD + DEBOUND(AREADR); CURRAD := NILAD; END (* SETVBLES *) ; BEGIN PLTPT := TYPECONV(PLTLAYOUTPT,STACKFRAMEPT@.PLTDESCAD); WITH PLTPT@ DO BEGIN DIAGLINEMAP := DIAGLINEMAPOPT IN VALIDRTOPTIONS; DIAGNAMETABLE := DIAGNAMETABLEOPT IN VALIDRTOPTIONS; END; DR := PLTPT@.OBJECTAREADESC; (* OBJECT AREA *) SETVBLES(DR,OBJECTSTARTADDR,OBJECTCURRADDR,OBJECTENDADDR); DR := PLTPT@.TOKENAREADESC; (* TOKEN AREA *) SETVBLES(DR,TOKENSTARTADDR,TOKENCURRADDR,TOKENENDADDR); DR := PLTPT@.MAPAREADESC; (* MAP AREA *) SETVBLES(DR,MAPSTARTADDR,MAPCURRADDR,MAPENDADDR); ICL9LPPMINITTABS(DIAGLINEMAP,DIAGNAMETABLE,CCUSRPRG, CCTTPTB[CCUSRPRG,CCPASSUBSYS],RC) ; IF RC <> 0 THEN BEGIN DIAGLINEMAP := FALSE; DIAGNAMETABLE := FALSE; END; END (* PMINITDIAGTABLES *); (*#E+*) PROCEDURE ICL9LPRESETPMOBJ; BEGIN OBJECTCURRADDR := NILAD; END (* ICL9LPRESETPMOBJ *); PROCEDURE ICL9LPRESETPMTOK; BEGIN TOKENCURRADDR := NILAD; END (* ICL9LPRESETPMTOK *); PROCEDURE ICL9LPRESETPMMAP; BEGIN MAPCURRADDR := NILAD; END (* ICL9LPRESETPMMAP *); FUNCTION ICL9LPNEXTPMOBJ : ADDRESS ; VAR RECSIZE : POSINT ; BEGIN IF OBJECTCURRADDR = NILAD THEN OBJECTCURRADDR := OBJECTSTARTADDR ELSE BEGIN RECSIZE := WORDAT(OBJECTCURRADDR); IF RECSIZE = 0 THEN OBJECTCURRADDR := NILAD ELSE BEGIN OBJECTCURRADDR := OBJECTCURRADDR + RECSIZE; IF OBJECTCURRADDR >= OBJECTENDADDR THEN OBJECTCURRADDR := NILAD; END; END; ICL9LPNEXTPMOBJ := OBJECTCURRADDR; END (* ICL9LPNEXTPMOBJ *); FUNCTION ICL9LPNEXTPMTOK : ADDRESS ; VAR RECSIZE : POSINT ; BEGIN IF TOKENCURRADDR = NILAD THEN TOKENCURRADDR := TOKENSTARTADDR ELSE BEGIN RECSIZE := WORDAT(TOKENCURRADDR); IF RECSIZE = 0 THEN TOKENCURRADDR := NILAD ELSE BEGIN TOKENCURRADDR := TOKENCURRADDR + RECSIZE; IF TOKENCURRADDR >= TOKENENDADDR THEN TOKENCURRADDR := NILAD; END; END; ICL9LPNEXTPMTOK := TOKENCURRADDR; END (* ICL9LPNEXTPMTOK *); FUNCTION ICL9LPNEXTPMMAP : ADDRESS ; BEGIN IF MAPCURRADDR = NILAD THEN MAPCURRADDR := MAPSTARTADDR ELSE BEGIN MAPCURRADDR := MAPCURRADDR + MAPRECSIZE; IF MAPCURRADDR >= MAPENDADDR THEN MAPCURRADDR := NILAD; END; ICL9LPNEXTPMMAP := MAPCURRADDR; END (* ICL9LPNEXTPMMAP *); FUNCTION ICL9LPPRELINKPM : SGMTRNGB; VAR PCVALUE : ADDRESS; MODULENAME : ALFA; IIN : POSINT; CODEOFFSET : SGMTRNGB; BEGIN PCVALUE := WORDAT (TEMPJLKDIAGDATA.ADATTOPOFSTACKFRAME); ICL9LPCTMRMLD (PCVALUE, MODULENAME, IIN, CODEOFFSET); ICL9LPPRELINKPM := CODEOFFSET; END (* ICL9LPPRELINKPM *); FUNCTION ICL9LPPOSTLINKPM : SGMTRNGB; CONST JLKLINKOFFSETB = 24; (* C.F. "GLOBALAREA" DEFINITION *) VAR PCVALUE : ADDRESS; MODULENAME : ALFA; IIN : POSINT; CODEOFFSET : SGMTRNGB; BEGIN PCVALUE := WORDAT (WORDAT(TEMPJLKDIAGDATA.ADOFGLOBALAREA+JLKLINKOFFSETB) - BINWD); ICL9LPCTMRMLD (PCVALUE, MODULENAME, IIN, CODEOFFSET); ICL9LPPOSTLINKPM := CODEOFFSET; END (* ICL9LPPOSTLINKPM *); (**** E R R O R H A N D L I N G , D I A G N O S T I C S ****) (**** ---------------------------------------------------- ****) (*#E-*) PROCEDURE EHINITERRSTOP (ERRID : EHINITERRTP) ; VAR MSGD : STRDESC ; BEGIN MSGD := DEREFWITHBND ( 'PASCAL : ERROR DURING INITIALISATION :') ; JRNLDIRECTMSGLN (MSGD) ; CASE ERRID OF EHIGLBLLEN : MSGD := DEREFWITHBND ( ' - PROGRAM''S GLOBAL DATA AREA IS TOO SMALL') ; EHIHEAPOFLO : MSGD := DEREFWITHBND ( ' - HEAP SIZE TOO LOW FOR STANDARD FILE INFO ETC. .') ; EHIFTPFAIL : MSGD := DEREFWITHBND ( ' - ICL9HEFILETIDYPROC FAILURE') ; END (* CASE .... *) ; JRNLDIRECTMSGLN (MSGD) ; ICL9CEZSTOP ; END (* EHINITERRSTOP *) ; PROCEDURE INITDIAGFILE ; CONST DIAGNAME = '**DIAGNOSTICS-FILE** '; VAR TXKIND : TXFCLASS; BEGIN IF ATCOMPILETIME THEN TXKIND := CTDIAG ELSE TXKIND := RTDIAG ; ICL9LPFILEDECL (DIAGFV, DIAGNAME, TRUE, TRUE, TXKIND, FNULLCHN, TXOPBFLENB) ; DIAGFP := TYPECONV (TEXTPT, ADDRESSOF (DIAGFV)) ; REWRITE (DIAGFP@) ; END (* INITDIAGFILE *) ; PROCEDURE EHWRITEDUMPEDAREA (AREAADDR : ADDRESS; AREALENB : SGMTRNGB; AREAID : EHAREATYPE ); CONST MAXLINELEN = 32; (* THESE TWO DEFINE NUMBER OF *) MAXCHARINDEXINLINE = 31; (* BYTES PER LINE OF OUTPUT *) TYPE LINETYPE = PACKED ARRAY [0..MAXCHARINDEXINLINE] OF CHAR; ARRAYOF4BTYPE = PACKED ARRAY [0..3] OF CHAR; VAR CURRENTLINE : LINETYPE; CURRENTCHAR : CHAR; LINEADDR : ADDRESS; WORDGAPMARK : 0..3; LINEDR : STRDESC; LASTLINEINDEX, CURRENTLINEINDEX, CURRENTLINELEN, CURRENTCHARINDEX, LEFTOVERS : POSINT; LINEADDRARRAY : ARRAYOF4BTYPE ; BEGIN LASTLINEINDEX := AREALENB DIV MAXLINELEN; LEFTOVERS := AREALENB - (LASTLINEINDEX * MAXLINELEN); IF LEFTOVERS = 0 THEN LASTLINEINDEX := LASTLINEINDEX - 1; FOR CURRENTLINEINDEX := 0 TO LASTLINEINDEX DO BEGIN LINEADDR := AREAADDR + (CURRENTLINEINDEX * MAXLINELEN); LINEADDRARRAY := TYPECONV(ARRAYOF4BTYPE,LINEADDR); IF AREAID <> EHAREGISTERS THEN FOR CURRENTCHARINDEX := 0 TO 3 DO BEGIN CURRENTCHAR := LINEADDRARRAY[CURRENTCHARINDEX]; WRITE(DIAGFP@,HEXDIGITS[USHX(-4,ORD(CURRENTCHAR))], HEXDIGITS[ANDX(15,ORD(CURRENTCHAR))] ); END; WRITE(DIAGFP@,' '); IF (CURRENTLINEINDEX = LASTLINEINDEX) AND (LEFTOVERS <> 0) THEN CURRENTLINELEN := LEFTOVERS ELSE CURRENTLINELEN := MAXLINELEN; FOR CURRENTCHARINDEX := 0 TO MAXCHARINDEXINLINE DO BEGIN WORDGAPMARK := ANDX(CURRENTCHARINDEX,3); (* EVERY 4 BYTES *) IF WORDGAPMARK = 0 THEN WRITE(DIAGFP@,' '); IF CURRENTCHARINDEX < CURRENTLINELEN THEN BEGIN CURRENTCHAR := TYPECONV(CHAR,BYTEAT(LINEADDR + CURRENTCHARINDEX)); CURRENTLINE[CURRENTCHARINDEX] := CURRENTCHAR; WRITE(DIAGFP@,HEXDIGITS[USHX(-4,ORD(CURRENTCHAR))], HEXDIGITS[ANDX(15,ORD(CURRENTCHAR))] ); END ELSE WRITE(DIAGFP@,' '); END; IF AREAID <> EHAREGISTERS THEN BEGIN WRITE(DIAGFP@,' '); IF CCUSRPRG <> CCPASSUBSYS THEN CCTRANSLATE(ADDRESSOF(CURRENTLINE),CURRENTLINELEN, CCTTPTB[CCUSRPRG,CCPASSUBSYS]); CCTRANSLATE(ADDRESSOF(CURRENTLINE),CURRENTLINELEN, PASSBSYSGRAPHICSTTP); LINEDR := DEREFFOR(CURRENTLINE); DESETBOUND(LINEDR,CURRENTLINELEN); WRITESTR(DIAGFP@,LINEDR); END; WRITELN(DIAGFP@); END; END (* EHWRITEDUMPEDAREA *); PROCEDURE EHDUMPAREA (AREAID : EHAREATYPE) ; VAR TITLED : STRDESC ; AD : ADDRESS ; LENB : SGMTRNGB ; BEGIN CASE AREAID OF EHAREGISTERS : BEGIN TITLED := DEREFWITHBND ('REGISTERS') ; AD := CONTINGENCYDATAAD ; LENB := CONTINGENCYDATALENWD * BINWD ; END ; EHASTACKFRAME : BEGIN TITLED := DEREFWITHBND ('STACK FRAME') ; AD := CURRSTACKFRAMEAD ; LENB := CURRSTACKFRAMELENW * 4 ; END ; EHAUSRPRGGLOBAL : BEGIN TITLED := DEREFWITHBND ('PROGRAM''S GLOBAL DATA') ; AD := USRPRGGLOBALBASEAD ; LENB := USRPRGGLOBALLENB ; END ; EHAHEAP : BEGIN TITLED := DEREFWITHBND ('HEAP') ; GIVEHEAPBASEANDSIZE (AD, LENB) ; END ; EHALIBNUCGLOBAL : BEGIN TITLED := DEREFWITHBND ('PASCAL SUPPORT SOFTWARE''S DATA') ; AD := LIBNUCGLOBALBASEAD ; LENB := LIBNUCGLOBALLENB ; END ; END (* CASE AREAID OF .... *) ; WRITESTR (DIAGFP@, TITLED) ; WRITELN(DIAGFP@); EHWRITEDUMPEDAREA (AD, LENB,AREAID) ; END (* EHDUMPAREA *) ; PROCEDURE INITRTERRORHANDLING (USRPRGGLOBALAREAP : GLOBALAREAPT ; USRPRGGLOBALLENWD : SGMTRNGWD ; USRPRGBASELNBVAL : ADDRESS) ; VAR TIDYPROCDESC : PROCDESC ; REPLY : RESPONSE ; BEGIN USRPRGGLBLP := USRPRGGLOBALAREAP ; USRPRGGLOBALBASEAD := ADDRESSOF (USRPRGGLOBALAREAP@) ; USRPRGGLOBALLENB := USRPRGGLOBALLENWD * BINWD ; USRPRGSTACKBASEAD := USRPRGBASELNBVAL ; LIBNUCGLOBALBASEAD := CURGLOBALBASEAD ; LIBNUCGLOBALLENB := ADDRESSOF (LIBNUCLASTDATAITEM) + BINWD - LIBNUCGLOBALBASEAD ; INITDIAGFILE ; ICL9HEPROLOG(0); TIDYPROCDESC := ICL9LPRTTIDYPROCDESC ; REPLY := ICL9HEFILETIDYPROC(TIDYPROCDESC); IF REPLY > 0 THEN EHINITERRSTOP(EHIFTPFAIL); END (* INITERRORHANDLING *) ; PROCEDURE INITCTERRORHANDLING (COMPBASELNBVAL : ADDRESS; CDIAGVAL : CDIAGTYPE) ; BEGIN CDIAG := CDIAGVAL; COMPILERSTACKBASEAD := COMPBASELNBVAL; INITDIAGFILE; ICL9LPCTNOMINATEERRPROC(ADDRESSOF(EHCONTINGENCYMESSAGE), ADDRESSOF(EHREGISTERS)) ; END (* INITCTERRORHANDLING *); PROCEDURE EHWRITETEXT (MESSDR : STRDESC); BEGIN WRITESTR(DIAGFP@,MESSDR); END (* EHWRITETEXT *); PROCEDURE EHWRITEDOCNMESS(EHDOCNMESS : EHDOCNMESSTYPE); BEGIN EHWRITETEXT(ICL9LPEHMTM(ORD(EHDOCNMESS) + EHDOCNMESSBASE)); WRITE(DIAGFP@,' '); END (* EHWRITEDOCNMESS *) ; PROCEDURE EHWRITEMODNAME (MODCHAINENTRY : STRDESC); VAR NAMELEN:BNDRNG; STRD:STRDESC; BEGIN EHWRITEDOCNMESS(MODULEMESS); NAMELEN:=ORD(BYTEAT(DEADDR(MODCHAINENTRY)+EHMCENAMELENOFFSET)); STRD:=MODSTRDESC(MODCHAINENTRY,EHMCENAMEOFFSET); DESETBOUND(STRD,NAMELEN); EHWRITETEXT(STRD); (* WRITE MODULE NAME *) END (* EHWRITEMODNAME *); PROCEDURE EHWRITEMODDATETIME (MODCHAINENTRY : STRDESC); VAR STRD : STRDESC; BEGIN EHWRITEMODNAME(MODCHAINENTRY); (* WRITE MODULE NAME *) WRITE(DIAGFP@,' '); EHWRITEDOCNMESS(COMPILEDONMESS); STRD:=MODSTRDESC(MODCHAINENTRY,EHMCEDTTMOFFSET); DESETBOUND(STRD,EHMCEDATELEN); EHWRITETEXT(STRD); (* WRITE DATE *) WRITE(DIAGFP@,' '); EHWRITEDOCNMESS(ATMESS); STRD:=MODSTRDESC(STRD,EHMCEDATELEN); DESETBOUND(STRD,EHMCETIMELEN); EHWRITETEXT(STRD); (* WRITE TIME *) END (* EHWRITEMODDATETIME *) ; PROCEDURE EHNEXTSTACKFRAME (VAR STACKFRAMEAD : ADDRESS; VAR STACKFRAMELENW : SGMTRNGWD; VAR CODEADDRESS : ADDRESS); VAR NEXTFRAMEAD : ADDRESS; FRAMEPT: STACKFRAMELAYOUTPT; BEGIN FRAMEPT := TYPECONV(STACKFRAMELAYOUTPT,STACKFRAMEAD); NEXTFRAMEAD := ANDX(FRAMEPT@.LNB,?I FFFFFFFC); CODEADDRESS := FRAMEPT@.PC; STACKFRAMELENW := (STACKFRAMEAD-NEXTFRAMEAD) DIV 4; IF NEXTFRAMEAD <> FRAMEPT@.LNB THEN STACKFRAMELENW := STACKFRAMELENW - 1; STACKFRAMEAD := NEXTFRAMEAD; END (* EHNEXTSTACKFRAME *); PROCEDURE EHWRITECTDOCNMESS (EHCTDOCNMESS : EHCTDOCNMESSTYPE); BEGIN WRITESTR(DIAGFP@,ICL9LPEHMTM(ORD(EHCTDOCNMESS)+EHCTDOCNMESSBASE)); WRITE(DIAGFP@,' '); END (* EHWRITECTDOCNMESS *); PROCEDURE EHWRITEMODIINOFFSET (CODEADDRESS : ADDRESS); VAR MODULENAME : ALFA; IIN : POSINT; OFFSET : SGMTRNGB; BEGIN ICL9LPCTMRMLD(CODEADDRESS,MODULENAME,IIN,OFFSET); EHWRITECTDOCNMESS(MODMESS); WRITESIGALFA(DIAGFP@,MODULENAME); WRITE(DIAGFP@,' '); EHWRITECTDOCNMESS(IINMESS); WRITE(DIAGFP@,IIN:1,' '); EHWRITECTDOCNMESS(OFFSETMESS); WRITE(DIAGFP@,'X'); WRITESIGHEXWORD(DIAGFP@,OFFSET); WRITELN(DIAGFP@); END (* EHWRITEMODIINOFFSET *); PROCEDURE EHGETVMDUMP (CONTTYPE, CONTSUBTYPE : POSINT); VAR HEAPDR : STRDESC; AREASDR : LWVDESC; AREAAD : ADDRESS; AREALEN : SGMTRNGB; BEGIN GIVEHEAPBASEANDSIZE(AREAAD,AREALEN); DEVARSETUP(HEAPDR,DETPBVC,AREALEN,AREAAD); DEVARSETUP(AREASDR,DETPLWDVC,1,ADDRESSOF(HEAPDR)); ICL9LPCTMDUMP(CONTSUBTYPE,CONTTYPE,16,AREASDR,0); END (* EHGETVMDUMP *); PROCEDURE EHCTREPORT (ERRORNO , SUBTYPE : POSINT; LNB , PC : ADDRESS; NAMESPACELENW : SGMTRNGWD); VAR LOCALCDIAG : CDIAGTYPE; STACKDESCENT : BOOLEAN; STACKFRAMEAD : ADDRESS; CODEADDRESS : ADDRESS; STACKFRAMELENW : SGMTRNGWD; BEGIN STACKFRAMEAD := LNB; CODEADDRESS := PC; CTDIAGMESSTYPE := LOGCTSUMMARYTYPE; EHWRITECTDOCNMESS(FAILUREHEADMESS); WRITELN(DIAGFP@);WRITELN(DIAGFP@); IF CDIAG >= EHCTMACVALUES THEN BEGIN CTDIAGMESSTYPE := LOGCTSUMMARYTYPE; LOCALCDIAG := CDIAG - EHCTMACVALUES; END ELSE BEGIN CTDIAGMESSTYPE := LOGCTDIAGTYPE; LOCALCDIAG := CDIAG; END; IF ERRORNO < EHCONTINGENCYUPPERBOUND THEN BEGIN EHWRITECTDOCNMESS(CONTINGENCYMESS); WRITE(DIAGFP@,ERRORNO:1,' '); EHWRITECTDOCNMESS(SUBTYPEMESS); WRITE(DIAGFP@,ANDX(SUBTYPE,?I 07FFFFFF):1); WRITELN(DIAGFP@); WRITELN(DIAGFP@); CONTINGENCYDATAAD := ADDRESSOF(EHREGISTERS); EHDUMPAREA(EHAREGISTERS); END ELSE IF ERRORNO = EHIMPERROR THEN EHWRITECTDOCNMESS(IMPERRMESS) ELSE BEGIN EHWRITECTDOCNMESS(PASCALERRMESS); WRITESTR(DIAGFP@,ICL9LPEHMTM(ERRORNO)); END; WRITELN(DIAGFP@); WRITELN(DIAGFP@); IF (LOCALCDIAG = EHCTHEXDUMP) OR (ERRORNO = EHSTACKCONTINGENCY) THEN EHGETVMDUMP(ERRORNO,SUBTYPE) ELSE BEGIN EHWRITECTDOCNMESS(ACTIVEPROCSMESS); WRITELN(DIAGFP@); STACKDESCENT := TRUE; WHILE STACKDESCENT DO BEGIN IF LOCALCDIAG = EHCTMINOP THEN EHWRITEMODIINOFFSET(CODEADDRESS); STACKDESCENT := (STACKFRAMEAD <> COMPILERSTACKBASEAD); EHNEXTSTACKFRAME(STACKFRAMEAD,STACKFRAMELENW,CODEADDRESS); END; END; END (* EHCTREPORT *); PROCEDURE EHFLAGERROR (ERRNO : POSINT); VAR STACKFRAMEAD : ADDRESS; STACKFRAMELENW : SGMTRNGWD; CODEADDRESS : ADDRESS; BEGIN IF ATCOMPILETIME THEN BEGIN ICL9LPMASKUFLOW; STACKFRAMEAD := CURLOCALNAMEBASEAD; EHNEXTSTACKFRAME(STACKFRAMEAD,STACKFRAMELENW,CODEADDRESS); EHNEXTSTACKFRAME(STACKFRAMEAD,STACKFRAMELENW,CODEADDRESS); EHCTREPORT(ERRNO,0,STACKFRAMEAD,CODEADDRESS,STACKFRAMELENW); ICL9LPCTABORT(TRUE); END ELSE ICL9HEFATALCOMPERR(PASCALLANGUAGECODE,ERRNO); END (* EHFLAGERROR *); PROCEDURE EHWRITELINENO (OFFSET : SGMTRNGB) ; VAR LINENO : POSINT ; BEGIN LINENO := 0; IF DIAGLINEMAP THEN ICL9LPPMLINENO(OFFSET,LINENO); IF LINENO = 0 THEN BEGIN EHWRITEDOCNMESS(DISPMESS); WRITE(DIAGFP@,'X'); WRITESIGHEXWORD(DIAGFP@,OFFSET); END ELSE BEGIN EHWRITEDOCNMESS(LINEMESS); WRITE(DIAGFP@,LINENO:1); END; END (* EHWRITELINENO *) ; PROCEDURE EHWRITEBLOCKID (OFFSET : SGMTRNGB); VAR BLKKIND : KINDOFBLOCK; BLKNAME : ALFA; BLKKINDMESS : EHDOCNMESSTYPE; BEGIN BLKKIND := UNKNOWNBLK; IF DIAGLINEMAP OR DIAGNAMETABLE THEN ICL9LPPMBLOCKID(OFFSET,BLKKIND,BLKNAME); CASE BLKKIND OF PROGBLK : BLKKINDMESS := MAINPROGBLKMESS; PROCBLK : BLKKINDMESS := PROCEDUREMESS; FUNCBLK : BLKKINDMESS := FUNCTIONMESS; UNKNOWNBLK : BLKKINDMESS := CODEAREAMESS; END; EHWRITEDOCNMESS(BLKKINDMESS); IF BLKKIND IN [PROCBLK,FUNCBLK] THEN BEGIN WRITESIGALFA(DIAGFP@,BLKNAME); WRITE(DIAGFP@,' '); END; END (* EHWRITEBLOCKID *); PROCEDURE EHDUMPNAMESPACE (DISPLACEMENT : SGMTRNGB; ARRAYSIZE : INTEGER); VAR HEAPAD: ADDRESS; HEAPSIZEB: SGMTRNGB; BEGIN GIVEHEAPBASEANDSIZE(HEAPAD,HEAPSIZEB); IF DIAGNAMETABLE THEN ICL9LPPMDMPSPACE (DISPLACEMENT,CURRSTACKFRAMEAD,USRPRGGLOBALBASEAD, HEAPAD,(HEAPAD+(HEAPSIZEB-1)), CURRSTACKFRAMELENW,DIAGFP@,ARRAYSIZE) ELSE IF CURRSTACKFRAMEAD = USRPRGSTACKBASEAD THEN EHDUMPAREA(EHAUSRPRGGLOBAL) ELSE EHDUMPAREA(EHASTACKFRAME); END (* EHDUMPNAMESPACE *); PROCEDURE SETJLKDIAGDATA (STACKFRAMEDESC : WVDESC); CONST PLTOFFSETINFRAME = 16; (* C.F. "STACKFRAMELAYOUT" DEFINITION *) GLOBALOFFSETINPLT = 36; (* C.F. "PLTLAYOUT" DEFINITION *) BEGIN WITH TEMPJLKDIAGDATA DO BEGIN ADATTOPOFSTACKFRAME:=DEADDR(STACKFRAMEDESC)+ (DEBOUND(STACKFRAMEDESC)-1)*BINWD; ADOFGLOBALAREA:=WORDAT( WORDAT(DEADDR(STACKFRAMEDESC)+PLTOFFSETINFRAME) + GLOBALOFFSETINPLT ); END; END (* SETJLKDIAGDATA *) ; (*#E+*) FUNCTION ICL9LPCTINTERRUPTERROR : RESPONSE; BEGIN ICL9LPMASKUFLOW; EHCTREPORT(EHCONTINGENCYMESSAGE.CONTTYPE, EHCONTINGENCYMESSAGE.CONTSUBTYPE, EHREGISTERS.LNB, EHREGISTERS.PC, (EHREGISTERS.SF - EHREGISTERS.LNB) DIV 4); ICL9LPCTINTERRUPTERROR := EHCOMPFAILRESPONSE; END (* ICL9LPCTINTERRUPTERROR *); FUNCTION ICL9HERRMESSP (VAR ERRNO : INTEGER; VAR EMESS : STRDESC) : RESPONSE; BEGIN IF ERRNO >= 0 THEN EMESS:=ICL9LPEHMTM(ERRNO) ELSE EMESS:=NILDESC; ICL9HERRMESSP:=0 END (* ICL9HERRMESSP *); FUNCTION ICL9LPPMPROCL (ERRNO, PROCNO, GROUPNO : INTEGER; EMESS, LANG1 : STRDESC; DISPLACEMENT : SGMTRNGB; DIAGREC : PROCDESC; MODCHAINENTRY, AREAENTRY : STRDESC; STACKFRAME : WVDESC ) : RESPONSE; BEGIN ICL9LPMASKUFLOW; SETJLKDIAGDATA(STACKFRAME); WRITELN(DIAGFP@);WRITELN(DIAGFP@); IF ERRNO < 0 THEN (* INTERRUPT ERROR *) BEGIN EHWRITEDOCNMESS(INTERRUPTERRORMESS); WRITELN(DIAGFP@,ERRNO:1); END ELSE IF GROUPNO = 0 THEN (* ERROR *) BEGIN IF ERRNO = EHIMPERROR THEN EHWRITEDOCNMESS(PASSUPSWERRMESS) ELSE BEGIN EHWRITETEXT(MODSTRDESC(LANG1,1)); EHWRITEDOCNMESS(ERRORMESS); END; WRITELN(DIAGFP@,ERRNO:1); END ELSE (* LIBRARY ERROR *) BEGIN EHWRITEDOCNMESS(LIBRARYERRORMESS); WRITE(DIAGFP@,(((256*GROUPNO)+PROCNO)*256+ERRNO):1,' ('); EHWRITETEXT(MODSTRDESC(LANG1,1)); EHWRITEDOCNMESS(GROUPMESS); WRITELN(DIAGFP@,GROUPNO:1,')'); END; EHWRITEDOCNMESS(DESCRIPTIONMESS); EHWRITETEXT(EMESS); WRITELN(DIAGFP@); PMINITDIAGTABLES(TYPECONV(STACKFRAMELAYOUTPT, ANDX(DEADDR(STACKFRAME),?I FFFFFFFC))); EHWRITEDOCNMESS(LOCATIONMESS); EHWRITELINENO(DISPLACEMENT); WRITELN(DIAGFP@); EHWRITEDOCNMESS(INMESS); EHWRITEBLOCKID(DISPLACEMENT); WRITELN(DIAGFP@); EHWRITEDOCNMESS(OFMESS); EHWRITEMODDATETIME(MODCHAINENTRY); WRITELN(DIAGFP@); IF (ERRNO < 0) AND NOT (DIAGNAMETABLE OR DIAGLINEMAP) THEN BEGIN CONTINGENCYDATAAD := ICL9LPRTGETICL9HERRADDR; EHDUMPAREA(EHAREGISTERS); END; WRITELN(DIAGFP@); ICL9LPPMPROCL := 0; END (* ICL9LPPMPROCL *) ; FUNCTION ICL9LPPMPROCR (DIAGNOSTICS, ARRAYSIZE : INTEGER; DISPLACEMENT : SGMTRNGB; STACKFRAME : WVDESC; DIAGREC : PROCDESC; MODCHAINENTRY, AREAENTRY : STRDESC; AREASOFMODULE : LWVDESC ):RESPONSE; VAR STACKFRAMEPT : STACKFRAMELAYOUTPT; BEGIN ICL9LPMASKUFLOW; SETJLKDIAGDATA(STACKFRAME); STACKFRAMEPT := TYPECONV(STACKFRAMELAYOUTPT, ANDX(DEADDR(STACKFRAME),?I FFFFFFFC)); PMINITDIAGTABLES(STACKFRAMEPT); EHWRITEDOCNMESS(PASCALMESS); EHWRITEBLOCKID(DISPLACEMENT); WRITE(DIAGFP@,'('); EHWRITEMODNAME(MODCHAINENTRY); WRITE(DIAGFP@,') '); EHWRITEDOCNMESS(ATMESS); EHWRITELINENO(DISPLACEMENT); WRITELN(DIAGFP@); IF DIAGNOSTICS > EHDIAGROUTEONLY THEN BEGIN WRITELN(DIAGFP@); CURRSTACKFRAMEAD := TYPECONV(ADDRESS,STACKFRAMEPT); CURRSTACKFRAMELENW := DEBOUND(STACKFRAME); EHDUMPNAMESPACE(DISPLACEMENT,ARRAYSIZE); IF DIAGNOSTICS >= EHDIAGFULLREPORT THEN IF CURRSTACKFRAMEAD = USRPRGSTACKBASEAD THEN BEGIN WRITELN(DIAGFP@); EHDUMPAREA(EHAHEAP); END; WRITELN(DIAGFP@); WRITELN(DIAGFP@); END; ICL9LPPMPROCR := 0; END (* ICL9LPPMPROCR *); (* SOFTWARE-DETECTED ERROR NOTIFICATION PROCEDURES :- *) PROCEDURE ICL9LPSYSERR; BEGIN EHFLAGERROR(EHPASSYSERR); END (* ICL9LPPASSYSERR *); PROCEDURE ICL9LPRANGEERROR (VALUEINERROR : INTEGER); BEGIN EHFLAGERROR(EHRNGERRMESSBASE); END (* ICL9LPRANGEERROR *); PROCEDURE ICL9LPCASEERROR ; BEGIN EHFLAGERROR(EHCASEERRMESSBASE); END (* ICL9LPCASEERROR *); (**** T I M E I N F O . ****) (**** ------------------- ****) (*#E-*) FUNCTION OCPTIME : INTEGER; VAR CURRENTPROCTIME, MICROSECUSED, MILLISECUSED : LONGINT; LONGINT1000 : LONGINT; BEGIN ICL9LPCTMPROCTIME(CURRENTPROCTIME); ICL9LPLONGISB(STARTPROCTIME,CURRENTPROCTIME,MICROSECUSED); LONGINT1000.UH := 0; LONGINT1000.LH := 1000; ICL9LPLONGIDIV(LONGINT1000,MICROSECUSED,MILLISECUSED); OCPTIME := MILLISECUSED.LH; END (* OCPTIME *); PROCEDURE RTDATEANDTIME (VAR DATE, TIME : ALFA8); VAR DTIS, TMIS : IMPSTR; I : ALFA8RNGB; EDRSP : RESPONSE; BEGIN DTIS[0] := IMPSTRLENB; TMIS[0] := IMPSTRLENB; EDRSP := ICL9CEZDATEANDTIME(DTIS,TMIS); FOR I := 1 TO ALFA8LENB DO BEGIN DATE[I] := CHR(CCTTPTB[CCSYSINTNL,CCUSRPRG]@ [DTIS[I+2]]); (* NO "19" *) TIME[I] := CHR(CCTTPTB[CCSYSINTNL,CCUSRPRG]@ [TMIS[I]]); END; END (* RTDATEANDTIME *); (*#E+*) FUNCTION ICL9LPCLOCK : WORD ; BEGIN ICL9LPCLOCK := OCPTIME; END (* ICL9LPCLOCK *) ; PROCEDURE ICL9LPDATETIME (VAR DATE, TIME : ALFA8); BEGIN IF ATCOMPILETIME THEN ICL9LPCTDATEANDTIME(DATE,TIME) ELSE RTDATEANDTIME(DATE,TIME); END (* ICL9LPDATETIME *); (*#E-*) PROCEDURE INITTIME ; BEGIN ICL9LPCTMPROCTIME(STARTPROCTIME); END (* INITTIME *) ; (**** M A T H S . F U N C T I O N S ****) (**** ------------------------------- ****) (*#E+*) FUNCTION ICL9LPSIN (VAL : REAL) : REAL ; BEGIN ICL9LPSIN := ICL9CM2SIN (VAL) ; END (* ICL9LPSIN *) ; FUNCTION ICL9LPCOS (VAL : REAL) : REAL ; BEGIN ICL9LPCOS := ICL9CM2COS (VAL) ; END (* ICL9LPCOS *) ; FUNCTION ICL9LPARCTAN (VAL : REAL) : REAL ; BEGIN ICL9LPARCTAN := ICL9CM2ATAN (VAL) ; END (* ICL9LPARCTAN *) ; FUNCTION ICL9LPLN (VAL : REAL) : REAL ; BEGIN ICL9LPLN := ICL9CM2LOG (VAL) ; END (* ICL9LPLN *) ; FUNCTION ICL9LPEXP (VAL : REAL) : REAL ; BEGIN ICL9LPEXP := ICL9CM2EXP (VAL) ; END (* ICL9LPEXP *) ; FUNCTION ICL9LPSQRT (VAL : REAL) : REAL ; BEGIN ICL9LPSQRT := ICL9CM2SQRT (VAL) ; END (* ICL9LPSQRT *) ; (**** H E A P M A N A G E M E N T ****) (**** ----------------------------- ****) (*#E-*) PROCEDURE HEAPERROR (ERRORID : HEAPERRORTYPE) ; BEGIN EHFLAGERROR(ORD(ERRORID) + EHHEAPERRMESSBASE); END (* HEAPERROR *) ; (*#E+*) FUNCTION ICL9LPNEW (SIZEREQUESTEDWD : INTEGER) : ADDRESS ; VAR LASTAD, AD, NEXTAD, NEWNEXTAD : ADDRESS ; ALLOCATESIZEWD, THISSIZEWD : INTEGER ; BLOCKFOUND : BOOLEAN ; BEGIN IF SIZEREQUESTEDWD = 0 THEN (* ANY ADDRESS SHOULD DO, PROVIDING "ICL9LPDISPOSE" KNOWS ABOUT IT *) ICL9LPNEW := HEAPBASEAD ELSE BEGIN IF SIZEREQUESTEDWD < 0 THEN HEAPERROR (HENSIZEINVALID) ELSE IF ODD(SIZEREQUESTEDWD) THEN ALLOCATESIZEWD := SIZEREQUESTEDWD + 1 ELSE ALLOCATESIZEWD := SIZEREQUESTEDWD + 2 ; AD := BASEFREEHEAPAD ; NEXTAD := WORDAT (AD) ; BLOCKFOUND := FALSE ; REPEAT (* -SCAN FREE BLOCK CHAIN *) LASTAD := AD ; AD := NEXTAD ; NEXTAD := WORDAT (AD) ; IF WORDAT (AD-BINWD) >= ALLOCATESIZEWD THEN (* BLOCK OF ADEQUATE SIZE FOUND *) BEGIN THISSIZEWD := WORDAT (AD-BINWD) ; IF (THISSIZEWD > ALLOCATESIZEWD) OR (AD = MAXFREEHEAPAD) THEN (* EXTRA UNWANTED SPACE FORMS NEW FREE BLOCK *) BEGIN NEWNEXTAD := AD + ALLOCATESIZEWD*BINWD ; STOREWORDAT (NEXTAD, NEWNEXTAD) ; STOREWORDAT (THISSIZEWD-ALLOCATESIZEWD, NEWNEXTAD-BINWD) ; IF AD = MAXFREEHEAPAD THEN BEGIN MAXFREEHEAPAD := NEWNEXTAD ; IF MAXFREEHEAPAD > MAXUSEDHEAPAD THEN MAXUSEDHEAPAD := MAXFREEHEAPAD ; END ; END ELSE NEWNEXTAD := NEXTAD ; STOREWORDAT (NEWNEXTAD, LASTAD) ; STOREWORDAT (-ALLOCATESIZEWD, AD-BINWD) ; (* FLAG END OF SCANNING LOOP :- *) NEXTAD := NILAD ; BLOCKFOUND := TRUE ; END ; UNTIL NEXTAD = NILAD ; IF BLOCKFOUND THEN ICL9LPNEW := AD ELSE HEAPERROR (HENNOROOM) ; END ; END (* ICL9LPNEW *) ; PROCEDURE ICL9LPDISPOSE (DISPOSEAD : ADDRESS ; DISPOSESIZEWD : INTEGER) ; VAR ADJUSTABOVEDISPOSE, ADLASTFREEBELOW, ADFIRSTFREEABOVE, ADJUSTABOVELASTFREEBELOW, ADNEWSIZEWORD : ADDRESS ; ACTUALDISPOSESIZEWD, RETURNSIZEWD, SIZEATANDBELOWWD : INTEGER ; BEGIN IF (DISPOSEAD = HEAPBASEAD) AND (DISPOSESIZEWD = 0) THEN (* SPECIAL CASE : DOMAIN TYPE SIZE = 0 (SEE "ICL9LPNEW") *) (* NULL *) ELSE BEGIN IF (DISPOSEAD = NILAD) OR (DISPOSEAD <= BASEFREEHEAPAD) OR (DISPOSEAD > LASTADINHEAP) THEN HEAPERROR (HEDADINVALID) ELSE RETURNSIZEWD := - WORDAT (DISPOSEAD-BINWD) ; IF ODD(DISPOSESIZEWD) THEN ACTUALDISPOSESIZEWD := DISPOSESIZEWD + 1 ELSE ACTUALDISPOSESIZEWD := DISPOSESIZEWD + 2 ; IF RETURNSIZEWD <> ACTUALDISPOSESIZEWD THEN HEAPERROR (HEDSIZECHECK) ELSE IF (RETURNSIZEWD < HEAPMINFREEBLOCKSIZEWD) OR (RETURNSIZEWD > (LASTADINHEAP-DISPOSEAD+BINWD) DIV BINWD) THEN HEAPERROR (HEDSIZEINVALID) ELSE ADJUSTABOVEDISPOSE := DISPOSEAD + RETURNSIZEWD*BINWD ; (* SCAN FREE BLOCK CHAIN FOR LAST FREE BLOCK BELOW AND *) (* FIRST FREE BLOCK ABOVE THE BLOCK BEING DISPOSED OF :- *) ADLASTFREEBELOW := BASEFREEHEAPAD ; ADFIRSTFREEABOVE := WORDAT (ADLASTFREEBELOW) ; WHILE ADFIRSTFREEABOVE < ADJUSTABOVEDISPOSE DO BEGIN ADLASTFREEBELOW := ADFIRSTFREEABOVE ; ADFIRSTFREEABOVE := WORDAT (ADLASTFREEBELOW) ; END ; ADJUSTABOVELASTFREEBELOW := ADLASTFREEBELOW + WORDAT (ADLASTFREEBELOW-BINWD)*BINWD ; IF ADJUSTABOVELASTFREEBELOW > DISPOSEAD THEN HEAPERROR (HEDADINFREE) ; (* MERGE BLOCK BEING DISPOSED OF BACK INTO FREE BLOCK *) (* CHAIN, COALESCING WHERE POSSIBLE WITH ANY FREE BLOCK *) (* JUST ABOVE OR JUST BELOW IT :- *) IF ADJUSTABOVELASTFREEBELOW = DISPOSEAD THEN (* FREE BLOCK JUST BELOW *) BEGIN ADNEWSIZEWORD := ADLASTFREEBELOW-BINWD ; SIZEATANDBELOWWD := WORDAT (ADNEWSIZEWORD) + RETURNSIZEWD ; IF ADJUSTABOVEDISPOSE = ADFIRSTFREEABOVE THEN (* FREE JUST BELOW, FREE JUST ABOVE *) BEGIN STOREWORDAT (WORDAT (ADFIRSTFREEABOVE), ADLASTFREEBELOW) ; STOREWORDAT (SIZEATANDBELOWWD + WORDAT (ADFIRSTFREEABOVE-BINWD), ADNEWSIZEWORD) ; IF ADFIRSTFREEABOVE = MAXFREEHEAPAD THEN MAXFREEHEAPAD := ADLASTFREEBELOW ; END ELSE (* FREE JUST BELOW, USED JUST ABOVE *) STOREWORDAT (SIZEATANDBELOWWD, ADNEWSIZEWORD) END ELSE (* USED BLOCK (OR SPECIAL BASE FREE BLOCK) JUST BELOW *) BEGIN ADNEWSIZEWORD := DISPOSEAD-BINWD ; IF ADJUSTABOVEDISPOSE = ADFIRSTFREEABOVE THEN (* USED/SPECIAL BASE BELOW, FREE ABOVE *) BEGIN STOREWORDAT (WORDAT (ADFIRSTFREEABOVE), DISPOSEAD) ; STOREWORDAT (RETURNSIZEWD + WORDAT (ADFIRSTFREEABOVE-BINWD), ADNEWSIZEWORD) ; IF ADFIRSTFREEABOVE = MAXFREEHEAPAD THEN MAXFREEHEAPAD := DISPOSEAD ; END ELSE (* USED/SPECIAL BASE BELOW, USED ABOVE *) BEGIN STOREWORDAT (ADFIRSTFREEABOVE, DISPOSEAD) ; STOREWORDAT (RETURNSIZEWD, DISPOSEAD-BINWD) ; END ; STOREWORDAT (DISPOSEAD, ADLASTFREEBELOW) ; END (* MERGE & COALESCE *) ; END ; END (* ICL9LPDISPOSE *) ; (*#E-*) FUNCTION MAXHEAPBYTESUSED ; (* - RESULT SPEC. IS :- : SGMTRNGB *) BEGIN MAXHEAPBYTESUSED := MAXUSEDHEAPAD - HEAPBASEAD + BINWD ; END (* MAXHEAPBYTESUSED *) ; PROCEDURE GIVEHEAPBASEANDSIZE ; (* - PARAM. LIST SPEC. IS :- (VAR BASEAD : ADDRESS ; SIZEB : SGMTRNGB) *) BEGIN BASEAD := HEAPBASEAD ; SIZEB := MAXFREEHEAPAD - HEAPBASEAD + BINWD ; END (* GIVEHEAPBASEANDSIZE *) ; PROCEDURE CTALLOCHEAP (VAR HEAPAD : ADDRESS; VAR HEAPLENB : SGMTRNGB); CONST CTHEAPAREANAME = 'ICL9LPHEAPCT'; CTHEAPSIZEB = HEAPMXSZB; BEGIN ICL9LPCTGETVSAREA(DEREFWITHBND(CTHEAPAREANAME),CTHEAPSIZEB,VSDENSE, HEAPAD); HEAPLENB := CTHEAPSIZEB; END (* CTALLOCHEAP *); PROCEDURE RTALLOCHEAP (VAR HEAPAD : ADDRESS; VAR HEAPLENB : SGMTRNGB); CONST RTSIZEJSVNM = 'ICL9LPRHEAP'; RTHEAPAREANAME = 'ICL9LPHEAPRT'; VAR SIZEB : SGMTRNGB; BEGIN SIZEB := INTJSVVALUE(DEREFWITHBND(RTSIZEJSVNM)) * 1024; IF SIZEB < HEAPMINSZB THEN SIZEB := HEAPMINSZB ELSE IF SIZEB > HEAPMXSZB THEN SIZEB := HEAPMXSZB; RTGETVSAREA(DEREFWITHBND(RTHEAPAREANAME),SIZEB,VSDENSE,HEAPAD); HEAPLENB := SIZEB; END (* RTALLOCHEAP *); PROCEDURE ALLOCHEAP (VAR HEAPAD : ADDRESS; VAR HEAPLENB : SGMTRNGB); BEGIN IF ATCOMPILETIME THEN CTALLOCHEAP(HEAPAD,HEAPLENB) ELSE RTALLOCHEAP(HEAPAD,HEAPLENB); END (* ALLOCHEAP *); PROCEDURE INITHEAPMANAGEMENT ; VAR SIZEB : SGMTRNGB; BEGIN ALLOCHEAP(HEAPBASEAD,SIZEB); (* SET UP SIZE AND CHAIN-POINTER WORDS FOR FIRST FREE *) (* BLOCK (UNCHANGING) AND FOR LAST FREE BLOCK (INITIAL *) (* STATE). IN ORDER TO ENSURE THAT THERE ARE ALWAYS A *) (* FIRST BLOCK & A LAST BLOCK IN THE CHAIN, THE SIZE *) (* VALUES FOR THESE BLOCKS ARE TREATED SPECIALLY :- *) (* (1) FIRST FREE BLOCK :- *) (* SIZE = 0, SO THAT "ICL9LPNEW" CAN NEVER ALLOCATE ANY *) (* SPACE FROM THIS BLOCK, AND SO THAT "ICL9LPDISPOSE" WILL *) (* NEVER TRY TO COALESCE IT WITH A RETURNED BLOCK *) (* LYING IMMEDIATELY ABOVE IT . *) (* (2) LAST FREE BLOCK :- *) (* SIZE = 2 WORDS (I.E. HEAPMINFREEBLOCKSIZEWD WORDS) *) (* LESS THAN IS ACTUALLY AVAILABLE, SO THAT WHENEVER *) (* "ICL9LPNEW" TRIES TO ALLOCATE SPACE FROM THE LAST *) (* FREE BLOCK, THERE IS ALWAYS ROOM BEYOND THE NEWLY *) (* ALLOCATED SPACE FOR (AT LEAST) A MINIMAL FREE *) (* BLOCK, WHICH BECOMES THE NEW LAST FREE BLOCK . *) BASEFREEHEAPAD := ANDX (HEAPBASEAD + 2*BINWD, -2*BINWD) ; (* -I.E. THE 1ST 2-WORD-ALIGNED ADDRESS WITH AT LEAST ONE *) (* WORD BELOW IT *) LASTADINHEAP := BASEFREEHEAPAD + (SIZEB - BINWD); MAXFREEHEAPAD := BASEFREEHEAPAD + HEAPMINFREEBLOCKSIZEWD*BINWD ; MAXUSEDHEAPAD := MAXFREEHEAPAD ; STOREWORDAT (MAXFREEHEAPAD, BASEFREEHEAPAD) ; STOREWORDAT (0, BASEFREEHEAPAD-BINWD) ; STOREWORDAT (NILAD, MAXFREEHEAPAD) ; STOREWORDAT ((ANDX(LASTADINHEAP,-2*BINWD) - MAXFREEHEAPAD) DIV BINWD, MAXFREEHEAPAD-BINWD) ; END (* INITHEAPMANAGEMENT *) ; (**** F I L E H A N D L I N G ****) (**** ------------------------- ****) (*#E-*) (* (FILE HANDLING) DIAGNOSTICS :- *) PROCEDURE FWARN (VAR FV : FVAR ; WARNID : FWARNTYPE) ; VAR WARNMSGD : STRDESC ; BEGIN END (* FWARN *) ; PROCEDURE FERROR (VAR FV : FVAR ; ERRID : FERRORTYPE) ; BEGIN EHFLAGERROR(ORD(ERRID)+EHFILEERRMESSBASE); END (* FERROR *) ; (* (FILE HANDLING) LOW-LEVEL SYSTEM INTERFACE :- *) PROCEDURE EDFOPEN (CHN : EDCHNRNG ; ACS : FIOMD ; ISTEXT : BOOLEAN ; VAR EDFDP : EDFDPT ; VAR RSP : RESPONSE) ; VAR NFOTYPE , NFOACT : WORD ; BEGIN IF ACS = FACSIP THEN NFOACT := EDNFORD ELSE NFOACT := EDNFOWR ; CUREDCHN := FNULLCHN ; IF ISTEXT THEN NFOTYPE := EDNFOPASF ELSE NFOTYPE := EDNFOPASRCF ; RSP := ICL9CEZNEWFILEOP (CHN, NFOACT, NFOTYPE, EDFDP) ; END (* EDFOPEN *) ; PROCEDURE EDFSELECT (CHN : EDCHNRNG ; ACS : FIOMD) ; VAR NFOACT : WORD ; NFOFDP : EDFDPT ; NFORSP : RESPONSE ; BEGIN IF ACS = FACSIP THEN NFOACT := EDNFORD ELSE NFOACT := EDNFOWR ; NFORSP := ICL9CEZNEWFILEOP (CHN, NFOACT, EDNFOPASF, NFOFDP) ; CUREDCHN := CHN ; END (* EDFSELECT *) ; PROCEDURE EDFREWIND (CHN : EDCHNRNG ; OLDACS : FIOMD) ; VAR NFOFDP : EDFDPT ; NFORSP : RESPONSE ; BEGIN CUREDCHN := FNULLCHN ; IF OLDACS = FACSOP THEN NFORSP := ICL9CEZNEWFILEOP (CHN, EDNFOENDF, EDNFOPASF, NFOFDP) ; NFORSP := ICL9CEZNEWFILEOP (CHN, EDNFORWND, EDNFOPASF, NFOFDP) ; END (* EDFREWIND *) ; PROCEDURE EDFCLOSE (CHN : EDCHNRNG) ; VAR NFOFDP : EDFDPT ; NFORSP : RESPONSE ; BEGIN NFORSP := ICL9CEZNEWFILEOP (CHN, EDNFOCLS, EDNFOPASF, NFOFDP) ; CUREDCHN := FNULLCHN ; END (* EDFCLOSE *) ; PROCEDURE EDBFIN (EDFDP : EDFDPT ; VAR BFAD : ADDRESS ; VAR BFLENB : RCBFRNG ; VAR ATEOF : BOOLEAN) ; VAR CHN : EDCHNRNG ; RSP : RESPONSE ; BEGIN CHN := EDFDP@.EDCHN ; IF CHN <> CUREDCHN THEN EDFSELECT (CHN, FACSIP) ; RSP := ICL9CEZINREC ; ATEOF := (RSP <> 0) ; IF ATEOF THEN BEGIN BFAD := NILAD ; BFLENB := 0 ; END ELSE BEGIN BFAD := EDFDP@.EDBFAD ; BFLENB := EDFDP@.EDRCLENB ; END ; END (* EDBFIN *) ; PROCEDURE EDBFOUT (EDFDP : EDFDPT ; BFLENB : RCBFRNG ; VAR FILEFULL : BOOLEAN) ; VAR CHN : EDCHNRNG ; RSP : RESPONSE ; BEGIN CHN := EDFDP@.EDCHN ; IF CHN <> CUREDCHN THEN EDFSELECT (CHN, FACSOP) ; RSP := ICL9CEZOUTREC (BFLENB) ; FILEFULL := (RSP <> 0) ; END (* EDBFOUT *) ; (* (FILE HANDLING) LOCAL SUPPORT :- *) PROCEDURE TXLNOPSTART (VAR FV : FVAR) ; BEGIN WITH FV.FCBLK@ DO BEGIN THROWPAGE := FALSE ; FV.CHAD := TXBFAD ; BFCOUNT := BFCOUNT + 1 ; END ; END (* TXLNOPSTART *) ; PROCEDURE RCBFOPSTART (VAR FV : FVAR) ; BEGIN WITH FV.FCBLK@ DO BEGIN RCBFAD := EDRCFFDLK@.EDBFAD ; FV.TXCHRCAD := RCBFAD ; BFCOUNT := BFCOUNT + 1 ; END ; END (* RCBFOPSTART *) ; PROCEDURE FVSTART (VAR FV : FVAR) ; BEGIN WITH FV DO BEGIN TXCHRCAD := 0 ; CHAD := NILAD ; FEOLN := TRUE ; FEOF := TRUE ; DUM1 := 0 ; DUM2 := 0 ; LASTCHAD := NILAD ; END ; END (* FVSTART *) ; PROCEDURE FCBSTART (VAR FCB : FCBLOCK) ; BEGIN WITH FCB DO BEGIN FACS := FNOTOPEN ; BFCOUNT := 0 ; IF TX THEN BEGIN TXBFAD := ADDRESSOF (FTXBF) ; THROWPAGE := FALSE ; FCCTTP := NIL ; IF TXFKIND IN [ORDINARYTXF, RTSTDIP, RTSTDOP] THEN EDTXFFDLK := NIL ; END ELSE BEGIN RCBFAD := NILAD ; EDRCFFDLK := NIL ; END ; END ; END (* FCBSTART *) ; PROCEDURE FSTART (VAR FV : FVAR ; ACS : FIOMD) ; VAR OPENRSP : RESPONSE ; BEGIN WITH FV.FCBLK@ DO IF FACS <> FNOTOPEN THEN IF TX THEN IF TXFKIND = ORDINARYTXF THEN BEGIN IF (FACS = FACSOP) AND ((FV.CHAD > TXBFAD) OR THROWPAGE) THEN ICL9LPWRITELINE (FV) ; EDFREWIND(EDTXFFDLK@.EDCHN,FACS) END ELSE FERROR(FV, FERWNDSTD) ELSE EDFREWIND(EDRCFFDLK@.EDCHN,FACS) ; FCBSTART (FV.FCBLK@) ; FVSTART (FV) ; WITH FV.FCBLK@ DO BEGIN IF TX THEN BEGIN IF TXFKIND IN [ORDINARYTXF, RTSTDIP, RTSTDOP] THEN BEGIN EDFOPEN(FUNITNO,ACS,TRUE,EDTXFFDLK,OPENRSP) ; IF OPENRSP <> EDRSPOK THEN IF TXFKIND = RTSTDIP THEN EDFOPEN(EDSTDIPCHN,ACS,TRUE,EDTXFFDLK,OPENRSP) ELSE IF TXFKIND = RTSTDOP THEN EDFOPEN(EDSTDOPCHN,ACS,TRUE,EDTXFFDLK,OPENRSP) ELSE FERROR(FV,FESYSOPEN) ; END ; IF ACS = FACSIP THEN FCCTTP := CCTTPTB [CCSYSEXTNL,FCCINTERNAL] ELSE FCCTTP := CCTTPTB [FCCINTERNAL,CCSYSEXTNL] ; END ELSE BEGIN EDFOPEN(FUNITNO,ACS,FALSE,EDRCFFDLK,OPENRSP) ; IF OPENRSP <> EDRSPOK THEN FERROR(FV,FESYSOPEN) ; IF EDRCFFDLK@.EDMXRCLENB < RCLENRQB THEN FERROR(FV,FERCBFSYSMXLEN) ; END ; FACS := ACS ; IF ACS = FACSIP THEN FV.FEOF := FALSE ELSE IF TX THEN FV.LASTCHAD := TXBFAD + TXOPBFDATALENB ; END (* WITH FV.FCBLK@ DO .... *) ; END (* FSTART *) ; PROCEDURE EDTXLNIN (EDFDP : EDFDPT ; CCTTP : CCTTPT ; LNBFAD : ADDRESS ; VAR LNBFLENB : TXBFCOUNT ; VAR LNBFOFLO, ATEOF : BOOLEAN) ; VAR EDBFAD : ADDRESS ; EDBFLENB : RCBFRNG ; EDBFBO : BYTE ; SCEDR, DESTDR : STRDESC ; BEGIN EDBFIN (EDFDP,EDBFAD,EDBFLENB,ATEOF) ; IF NOT ATEOF THEN BEGIN EDBFBO := BYTEAT(EDBFAD); IF EDBFBO = FORMFEEDFE THEN BEGIN EDBFAD := EDBFAD + 1 ; EDBFLENB := EDBFLENB - 1 ; END ; LNBFOFLO := (EDBFLENB > TXIPBFMXDATALENB) ; IF LNBFOFLO THEN EDBFLENB := TXIPBFMXDATALENB ; DEVARSETUP(SCEDR,DETPBVC,EDBFLENB,EDBFAD) ; DEVARSETUP(DESTDR,DETPBVC,EDBFLENB,LNBFAD) ; PLIMV(SCEDR,DESTDR) ; LNBFLENB := EDBFLENB ; IF CCTTP <> IDCCTTP THEN CCTRANSLATE(LNBFAD,EDBFLENB,CCTTP) ; END ELSE BEGIN LNBFOFLO := FALSE; LNBFLENB := EDBFLENB; END ; END (* EDTXLNIN *) ; PROCEDURE EDTXLNOUT (EDFDP : EDFDPT ; CCTTP : CCTTPT ; LNBFAD : ADDRESS ; LNBFLENB : TXBFCOUNT ; THROWPAGE : BOOLEAN ; VAR FILEFULL : BOOLEAN ) ; VAR EDBFLENB : RCBFRNG ; LENB : RCBFRNG; SCEDR , DESTDR : STRDESC ; BEGIN EDBFLENB := 0 ; IF THROWPAGE THEN BEGIN STOREBYTEAT(FORMFEEDFE,EDFDP@.EDBFAD) ; EDBFLENB := EDBFLENB + 1 ; END ; IF LNBFLENB + EDBFLENB > EDFDP@.EDMXRCLENB THEN LENB := EDFDP@.EDMXRCLENB - EDBFLENB ELSE LENB := LNBFLENB ; IF CCTTP <> IDCCTTP THEN CCTRANSLATE(LNBFAD,LENB,CCTTP) ; DEVARSETUP(SCEDR,DETPBVC,LENB,LNBFAD) ; DEVARSETUP(DESTDR,DETPBVC,LENB,EDFDP@.EDBFAD+EDBFLENB) ; PLIMV(SCEDR,DESTDR) ; EDBFLENB := EDBFLENB + LENB ; EDBFOUT(EDFDP,EDBFLENB,FILEFULL) ; END (* EDTXLNOUT *) ; PROCEDURE STDSYSTXLNOUT (KIND : STDSYSOPF ; CCTTP : CCTTPT ; LNBFAD : ADDRESS ; LNBFLENB : TXBFCOUNT ; THROWPAGE : BOOLEAN ; VAR FILEFULL : BOOLEAN) ; VAR TEXTDR : STRDESC ; W : WORD ; BEGIN IF (CCTTP <> IDCCTTP) THEN CCTRANSLATE(LNBFAD,LNBFLENB,CCTTP) ; FILEFULL := FALSE ; DEVARSETUP(TEXTDR,DETPBVC,LNBFLENB,LNBFAD); CASE KIND OF RTJRNL : ICL9LPCTMLOG(TEXTDR); CTJRNL : W := ICL9HNLOG(TEXTDR,LOGCTSUMMARYTYPE); CTDIAG : W := ICL9HNLOG(TEXTDR,CTDIAGMESSTYPE); RTDIAG : BEGIN W := -1; ICL9HEDIAGOUT(W,TEXTDR); END; CTLIST : BEGIN IF THROWPAGE THEN W := ICL9HNNEWPAGE; DEVARSETUP(TEXTDR,DETPBVC,LNBFLENB+2,LNBFAD-2); W := ICL9HNOUTPUTLINE(TEXTDR); IF W > 0 THEN W := ICL9HNOUTPUTLINE(TEXTDR); END; END (* CASE *) ; END (* STDSYSTXLNOUT *) ; (*#E+*) (* (FILE HANDLING) MAIN SUPPORT :- *) PROCEDURE ICL9LPREADLINE (VAR FV : FVAR) ; VAR DATACHCNT : TXBFCOUNT ; BFOFLO : BOOLEAN ; BEGIN WITH FV.FCBLK@ DO IF FACS <> FACSIP THEN FERROR (FV, FEIPACS) ELSE IF FV.FEOF THEN FERROR (FV, FEIPEOF) ELSE BEGIN BFCOUNT := BFCOUNT + 1 ; EDTXLNIN(EDTXFFDLK,FCCTTP,TXBFAD,DATACHCNT,BFOFLO,FV.FEOF) ; IF BFOFLO THEN FWARN(FV,FWTXIPBFOFLO) ; STOREBYTEAT(FUCRUPVCP@[UCSPACE],TXBFAD+DATACHCNT) ; WITH FV DO BEGIN FEOLN := (DATACHCNT = 0) ; TXCHRCAD := FTXBF [0] ; CHAD := TXBFAD ; LASTCHAD := TXBFAD + DATACHCNT ; END (* WITH FV DO .... *) ; END (* ELSE .... , WITH FV.FCBLK@ DO .... *) ; END (* ICL9LPREADLINE *) ; PROCEDURE ICL9LPWRITELINE (*VAR FV : FVAR*) ; VAR BFLENB : RCBFRNG; OLDBUFOFLO : BOOLEAN ; FILEFULL : BOOLEAN ; BEGIN WITH FV.FCBLK@ DO IF FACS <> FACSOP THEN FERROR (FV, FEOPACS) ELSE BEGIN OLDBUFOFLO := FV.CHAD>FV.LASTCHAD ; IF OLDBUFOFLO THEN FV.CHAD := FV.CHAD-1 ; BFLENB := FV.CHAD - TXBFAD; IF BFLENB = 0 THEN BEGIN STOREBYTEAT(FUCRUPVCP@[UCSPACE],TXBFAD); BFLENB := 1; END; IF TXFKIND IN [ORDINARYTXF, RTSTDOP] THEN EDTXLNOUT(EDTXFFDLK,FCCTTP,TXBFAD,BFLENB, THROWPAGE,FILEFULL) ELSE STDSYSTXLNOUT(TXFKIND,FCCTTP,TXBFAD,BFLENB, THROWPAGE,FILEFULL) ; IF FILEFULL THEN FERROR(FV,FETXOPFFULL) ; TXLNOPSTART (FV) ; IF OLDBUFOFLO THEN BEGIN FTXBF [0] := FV.TXCHRCAD ; FV.CHAD := FV.CHAD+1 ; END ; END (* ELSE .... , WITH FV.FCBLK@ DO .... *) ; END (* ICL9LPWRITELINE *) ; PROCEDURE ICL9LPGETRECORD (VAR FV : FVAR) ; VAR IPLENB : RCBFRNG ; BEGIN WITH FV.FCBLK@ DO IF FACS <> FACSIP THEN FERROR (FV, FEIPACS) ELSE IF FV.FEOF THEN FERROR (FV, FEIPEOF) ELSE BEGIN BFCOUNT := BFCOUNT + 1 ; EDBFIN(EDRCFFDLK,RCBFAD,IPLENB,FV.FEOF) ; IF (NOT FV.FEOF) AND (IPLENB <> RCLENRQB) THEN FERROR(FV,FERCIPBFLEN) ; FV.TXCHRCAD := RCBFAD ; END (* ELSE .... , WITH FV.FCBLK@ DO .... *) ; END (* ICL9LPGETRECORD *) ; PROCEDURE ICL9LPPUTRECORD (VAR FV : FVAR) ; VAR FILEFULL : BOOLEAN ; BEGIN WITH FV.FCBLK@ DO IF FACS <> FACSOP THEN FERROR (FV, FEOPACS) ELSE BEGIN EDBFOUT(EDRCFFDLK,RCLENRQB,FILEFULL) ; IF FILEFULL THEN FERROR (FV, FERCOPFFULL) ; RCBFOPSTART (FV) ; END (* ELSE .... , WITH FV.FCBLK@ DO .... *) ; END (* ICL9LPPUTRECORD *) ; PROCEDURE ICL9LPRESET (VAR FV : FVAR) ; BEGIN FSTART (FV, FACSIP) ; IF FV.FCBLK@.TX THEN ICL9LPREADLINE (FV) ELSE ICL9LPGETRECORD (FV) ; END (* ICL9LPRESET *) ; PROCEDURE ICL9LPREWRITE (VAR FV : FVAR) ; BEGIN FSTART (FV, FACSOP) ; IF FV.FCBLK@.TX THEN TXLNOPSTART (FV) ELSE RCBFOPSTART (FV) ; END (* ICL9LPREWRITE *) ; PROCEDURE ICL9LPFILEDECL ; (* - PARAM. LIST SPEC IS :- (VAR FV : FVAR ; NAME : ALFA ; TEXTF, PERMF : BOOLEAN ; TXKIND : TXFCLASS ; UNITNO : FUNITRNG ; RCLENWD : POSINT) *) VAR FCBP : FCBPT ; BEGIN IF TEXTF THEN NEW (FCBP, TRUE) ELSE NEW (FCBP, FALSE) ; WITH FCBP@, FV DO BEGIN NEXTFCBP := FCBCHAINP ; FCBCHAINP := FCBP ; FVLK := TYPECONV (FVPT, ADDRESSOF (FV)) ; FCBLK := FCBP ; FUNITNO := UNITNO ; TX := TEXTF ; NAMEPRG := NAME ; IF TEXTF THEN BEGIN TXFKIND := TXKIND ; IF TXKIND IN [ORDINARYTXF, RTSTDIP, RTSTDOP] THEN FCCINTERNAL := CCUSRPRG ELSE FCCINTERNAL := CCPASSUBSYS ; FUCRUPVCP := UCRUPVCPVC [FCCINTERNAL] ; END ELSE IF RCLENWD > MAXINT DIV BINWD THEN FERROR(FV,FERCBFSYSMXLEN) ELSE RCLENRQB := RCLENWD * BINWD ; END (* WITH FCBP@, FV .... *) ; FCBSTART (FCBP@) ; FVSTART (FV) ; IF TXKIND IN [RTSTDIP, RTSTDOP] THEN IF TXKIND = RTSTDIP THEN ICL9LPRESET (FV) ELSE ICL9LPREWRITE (FV) ; END (* ICL9LPFILEDECL *) ; (*#E-*) (* (FILE HANDLING) INIT, CLOSE :- *) PROCEDURE INITFILEHANDLING ; BEGIN FCBCHAINP := NIL ; HNOPLINEFAIL := FALSE ; CUREDCHN := FNULLCHN ; END (* INITFILEHANDLING *) ; PROCEDURE CLOSEDOWNFILEHANDLING ; VAR THISFCBP, MYNEXTFCBP : FCBPT ; BEGIN MYNEXTFCBP := FCBCHAINP ; WHILE MYNEXTFCBP <> NIL DO BEGIN THISFCBP := MYNEXTFCBP ; WITH THISFCBP@ DO BEGIN IF TX AND (FACS = FACSOP) THEN IF (FVLK@.CHAD <> TXBFAD) OR THROWPAGE THEN ICL9LPWRITELINE (FVLK@) ; MYNEXTFCBP := NEXTFCBP ; END (* WITH THISFCBP@ DO .... *) ; END (* WHILE MYNEXTFCBP <> NIL DO .... *) ; FCBCHAINP := NIL ; END (* CLOSEDOWNFILEHANDLING *) ; (**** T E X T - F I L E I / O ****) (**** ------------------------- ****) (*#E+*) PROCEDURE ICL9LPREADRERR (RREID : RRERRORTYPE ; VAR FV : FVAR) ; VAR FEID : FERRORTYPE ; BEGIN CASE RREID OF RREINVALIDCH : FEID := FETXIPRLINVALIDCH ; RREOFLO : FEID := FETXIPRLOFLO END ; FERROR (FV, FEID) ; END (* ICL9LPREADRERR *) ; (*#E-*) PROCEDURE TXOPREPEATEDCH (VAR FV : FVAR ; CH : BYTE ; RPTCNT : POSINT) ; VAR BFFREECNT : TXBFRNG ; BFFILLD : DESC ; BEGIN BFFREECNT := FV.LASTCHAD - FV.CHAD ; IF RPTCNT > BFFREECNT THEN BEGIN DEVARSETUP (BFFILLD, DETPBVC, BFFREECNT, FV.CHAD) ; PLIMVL (CH, BFFILLD) ; FV.CHAD := FV.LASTCHAD ; ICL9LPWRITELINE (FV) ; RPTCNT := RPTCNT - BFFREECNT ; IF RPTCNT > TXOPBFDATALENB THEN BEGIN DEVARSETUP (BFFILLD, DETPBVC, TXOPBFDATALENB - BFFREECNT, FV.CHAD) ; PLIMVL (CH, BFFILLD) ; REPEAT FV.CHAD := FV.LASTCHAD ; ICL9LPREADLINE (FV) ; RPTCNT := RPTCNT - TXOPBFDATALENB ; UNTIL RPTCNT <= TXOPBFDATALENB ; END ; END ; DEVARSETUP (BFFILLD, DETPBVC, RPTCNT, FV.CHAD) ; PLIMVL (CH, BFFILLD) ; FV.CHAD := FV.CHAD + RPTCNT ; END (* TXOPREPEATEDCH *) ; (*#E+*) FUNCTION ICL9LPREADINT (VAR FV : FVAR) : INTEGER ; TYPE ADJRNG = -1..0 ; DIGRNG = 0..9 ; VAR BFSTARTAD : ADDRESS ; INTVAL : INTEGER ; INTADJ : ADJRNG ; INTNEGATIVE : BOOLEAN ; DIGIT : DIGRNG ; CH, SPACECH, PLUSCH, MINUSCH, DIG0CH, DIG9CH : BYTE ; IX, ENDIX : TXBFRNG ; PROCEDURE ERROR (ERRORID: FERRORTYPE); BEGIN IF NOT FV.FEOF THEN FV.CHAD:=BFSTARTAD+IX; FERROR (FV,ERRORID); END (* ERROR *); BEGIN IF FV.FEOF THEN ERROR (FETXIPINTEOF) ; WITH FV DO BEGIN WITH FCBLK@ DO BEGIN SPACECH := FUCRUPVCP@ [UCSPACE] ; PLUSCH := FUCRUPVCP@ [UCPLUS] ; MINUSCH := FUCRUPVCP@ [UCMINUS] ; DIG0CH := FUCRUPVCP@ [UCZERO] ; BFSTARTAD := ADDRESSOF (FTXBF) ; END ; IX := CHAD -BFSTARTAD ; ENDIX := LASTCHAD - BFSTARTAD ; END ; DIG9CH := DIG0CH + 9 ; WITH FV.FCBLK@ DO WHILE FTXBF [IX] = SPACECH DO IF IX = ENDIX THEN BEGIN ICL9LPREADLINE (FV) ; IF FV.FEOF THEN ERROR (FETXIPINTEOF) ; IX := 0 ; ENDIX := FV.LASTCHAD - FV.CHAD ; END ELSE IX := IX + 1 ; INTNEGATIVE := FALSE ; CH := FV.FCBLK@.FTXBF [IX] ; IF (CH = PLUSCH) OR (CH = MINUSCH) THEN BEGIN INTNEGATIVE := (CH = MINUSCH) ; IX := IX + 1 ; CH := FV.FCBLK@.FTXBF [IX] ; END ; IF (CH < DIG0CH) OR (CH > DIG9CH) THEN ERROR (FETXIPINTFIRSTDIG) ; INTVAL := 0 ; INTADJ := 0 ; WITH FV.FCBLK@ DO REPEAT DIGIT := CH - DIG0CH ; IF INTVAL >= MAXINTDIV10 THEN IF INTNEGATIVE AND (INTVAL = MAXINTDIV10) AND (DIGIT = MAXINTMOD10+1) THEN BEGIN INTADJ := -1 ; DIGIT := MAXINTMOD10 END ELSE IF (INTVAL > MAXINTDIV10) OR (DIGIT > MAXINTMOD10) THEN ERROR (FETXIPINTOFLO) ; INTVAL := INTVAL * 10 + DIGIT ; IX := IX + 1 ; CH := FTXBF [IX] ; UNTIL (CH < DIG0CH) OR (CH > DIG9CH) ; FV.TXCHRCAD := CH ; FV.CHAD := BFSTARTAD + IX ; IF IX = ENDIX THEN FV.FEOLN := TRUE ; IF INTNEGATIVE THEN INTVAL := -INTVAL ; ICL9LPREADINT := INTVAL + INTADJ ; END (* ICL9LPREADINT *) ; FUNCTION ICL9LPREADREAL (VAR FV : FVAR) : REAL ; VAR RESULT : REAL ; BEGIN ICL9LPRIOREAD (RESULT, FV.FCBLK@.FUCRUPVCP@, FV) ; ICL9LPREADREAL := RESULT ; END (* ICL9LPREADREAL *) ; PROCEDURE ICL9LPPAGE (VAR FV : FVAR) ; BEGIN WITH FV.FCBLK@ DO IF FACS <> FACSOP THEN FERROR (FV, FEOPACS) ELSE BEGIN IF (FV.CHAD > TXBFAD) OR THROWPAGE THEN ICL9LPWRITELINE (FV) ; THROWPAGE := TRUE ; END ; END (* ICL9LPPAGE *) ; PROCEDURE ICL9LPWRITECHAR (CH : BYTE ; FIELDWIDTH : INTEGER ; VAR FV : FVAR) ; VAR TXFILEP : TEXTPT ; BEGIN IF FIELDWIDTH > 1 THEN TXOPREPEATEDCH (FV, FV.FCBLK@.FUCRUPVCP@ [UCSPACE], FIELDWIDTH - 1) ELSE IF FIELDWIDTH <= 0 THEN FERROR (FV, FETXOPCHWIDTH) ; FV.TXCHRCAD := CH ; TXFILEP := TYPECONV (TEXTPT, ADDRESSOF (FV)) ; PUT (TXFILEP@) ; END (* ICL9LPWRITECHAR *) ; PROCEDURE ICL9LPWRITEBSTR ; (* - PARAM. LIST SPEC. IS :- (STRD : STRDESC ; VAR FV : FVAR) *) VAR STRCHCNT : POSINT ; BFFREECNT : TXBFRNG ; BFD : DESC ; BEGIN STRCHCNT := DEBOUND (STRD) ; BFFREECNT := FV.LASTCHAD - FV.CHAD ; IF STRCHCNT > BFFREECNT THEN BEGIN DEVARSETUP (BFD, DETPBVC, BFFREECNT, FV.CHAD) ; DESETBOUND (STRD, BFFREECNT) ; PLIMV (STRD, BFD) ; FV.CHAD := FV.LASTCHAD ; ICL9LPWRITELINE (FV) ; STRCHCNT := STRCHCNT - BFFREECNT ; DENEWADDR (STRD, DEADDR (STRD) + BFFREECNT) ; IF STRCHCNT > TXOPBFDATALENB THEN BEGIN DESETBOUND (STRD,TXOPBFDATALENB) ; DEVARSETUP (BFD, DETPBVC, TXOPBFDATALENB, FV.CHAD) ; REPEAT PLIMV (STRD, BFD) ; FV.CHAD := FV.LASTCHAD ; ICL9LPWRITELINE (FV) ; DENEWADDR (STRD, DEADDR (STRD) + TXOPBFDATALENB) ; STRCHCNT := STRCHCNT - TXOPBFDATALENB ; UNTIL STRCHCNT <= TXOPBFDATALENB ; END ; DESETBOUND (STRD, STRCHCNT) ; END ; DEVARSETUP (BFD, DETPBVC, STRCHCNT, FV.CHAD) ; PLIMV (STRD, BFD) ; FV.CHAD := FV.CHAD + STRCHCNT ; END (* ICL9LPWRITEBSTR *) ; PROCEDURE ICL9LPWRITESTR (STRD : STRDESC ; FIELDWIDTH : INTEGER ; VAR FV : FVAR) ; VAR SPACECNT, STRLENB : POSINT ; BEGIN IF FIELDWIDTH <= 0 THEN FERROR (FV, FETXOPSTRWIDTH) ; STRLENB := DEBOUND (STRD) ; IF STRLENB > FIELDWIDTH THEN BEGIN STRLENB := FIELDWIDTH ; DESETBOUND (STRD, FIELDWIDTH) ; END ; SPACECNT := FIELDWIDTH - STRLENB ; IF SPACECNT > 0 THEN TXOPREPEATEDCH (FV, FV.FCBLK@.FUCRUPVCP@ [UCSPACE], SPACECNT) ; ICL9LPWRITEBSTR (STRD, FV) ; END (* ICL9LPWRITESTR *) ; PROCEDURE ICL9LPWRITEWDSTR (STR : WORDSTR ; STRLENB : WORDSTRRNGB ; VAR FV : FVAR) ; VAR STRD : DESC ; BEGIN STRD := DEREFFOR (STR) ; DESETBOUND (STRD, STRLENB) ; ICL9LPWRITEBSTR (STRD, FV) ; END (* ICL9LPWRITEWDSTR *) ; PROCEDURE ICL9LPWRITEINT (INTVAL, FIELDWIDTH : INTEGER ; VAR FV : FVAR) ; CONST STRBFMXIX = 20 ; TYPE STRBFRNG = 1..STRBFMXIX ; STRBFTYPE = PACKED ARRAY [STRBFRNG] OF BYTE ; ADJRNG = 0..1 ; VAR STRBF : STRBFTYPE ; STRD : STRDESC ; IX, STRCHCNT : STRBFRNG ; INTVALNEGATIVE : BOOLEAN ; ADJLASTDIG : ADJRNG ; SPACECH, MINUSCH, DIG0CH : BYTE ; BEGIN IF FIELDWIDTH <= 0 THEN FERROR (FV, FETXOPINTWIDTH) ; WITH FV.FCBLK@ DO BEGIN SPACECH := FUCRUPVCP@ [UCSPACE] ; MINUSCH := FUCRUPVCP@ [UCMINUS] ; DIG0CH := FUCRUPVCP@ [UCZERO] ; END ; ADJLASTDIG := 0 ; INTVALNEGATIVE := (INTVAL < 0) ; IF INTVALNEGATIVE THEN BEGIN IF 1 + INTVAL = -MAXINT THEN BEGIN INTVAL := INTVAL + 1 ; ADJLASTDIG := 1 ; END ; INTVAL := -INTVAL ; END ; IX := STRBFMXIX ; REPEAT STRBF [IX] := (INTVAL MOD 10) + DIG0CH ; IX := IX - 1 ; INTVAL := INTVAL DIV 10 ; UNTIL INTVAL = 0 ; STRBF [STRBFMXIX] := STRBF [STRBFMXIX] + ADJLASTDIG ; IF INTVALNEGATIVE THEN STRBF [IX] := MINUSCH ELSE STRBF [IX] := SPACECH ; STRCHCNT := (STRBFMXIX + 1) - IX ; IF STRCHCNT > FIELDWIDTH THEN IF NOT INTVALNEGATIVE THEN BEGIN STRCHCNT := STRCHCNT - 1 ; IX := IX + 1 ; END ; DEVARSETUP (STRD, DETPBVC, STRCHCNT, ADDRESSOF (STRBF [IX])) ; IF FIELDWIDTH > STRCHCNT THEN ICL9LPWRITESTR (STRD, FIELDWIDTH, FV) ELSE ICL9LPWRITEBSTR (STRD, FV) ; END (* ICL9LPWRITEINT *) ; PROCEDURE ICL9LPWRITEREAL (REALVAL : REAL ; FIELDWIDTH, DECDIGCNT : INTEGER ; VAR FV : FVAR) ; BEGIN IF DECDIGCNT < 0 THEN ICL9LPRIOWRFLOAT (REALVAL, FIELDWIDTH, FV.FCBLK@.FUCRUPVCP@, FV) ELSE ICL9LPRIOWRFIX (REALVAL, FIELDWIDTH, DECDIGCNT, FV.FCBLK@.FUCRUPVCP@, FV) ; END (* ICL9LPWRITEREAL *) ; PROCEDURE ICL9LPWRITEBOOL (VALUE : BOOLEAN ; FIELDWIDTH : INTEGER ; VAR FV : FVAR) ; CONST FALSESTR = 'FALSE' ; TRUESTR = 'TRUE ' ; VAR STR : BOOLVALSTR ; BEGIN IF VALUE THEN STR := TRUESTR ELSE STR := FALSESTR ; CCTRANSLATE (ADDRESSOF (STR), BOOLVALSTRLENB, CCTTPTB [CCPASSUBSYS, FV.FCBLK@.FCCINTERNAL]) ; ICL9LPWRITESTR (DEREFWITHBND (STR), FIELDWIDTH, FV) ; END (* ICL9LPWRITEBOOL *) ; (**** I N I T I A L I S A T I O N , C L O S E D O W N ****) (**** ------------------------------------------------- ****) (*#E-*) PROCEDURE INITGLOBALAREA (GLOBALAREAP : GLOBALAREAPT; BASELNBVAL : ADDRESS ) ; BEGIN WITH GLOBALAREAP@ DO BEGIN BASELNBTPANDBND := DETPWDVC + MXINTINBND; BASELNBAD := BASELNBVAL; END; END (* INITGLOBALAREA *); PROCEDURE BASICINIT ; VAR MAINPRGLNBVAL : ADDRESS ; LIBNUCGLOBALP : GLOBALAREAPT ; I : 0..15; BEGIN INITTIME ; FOR I := 0 TO 9 DO HEXDIGITS[I] := CHR(ORD('0') + I); FOR I := 10 TO 15 DO HEXDIGITS[I] := CHR(ORD('A') + (I-10)); INITCHARCODECONVERSION ; (* INITIALISE LIBNUC'S GLOBAL DATA AREA :- *) LIBNUCGLOBALP := TYPECONV (GLOBALAREAPT, CURGLOBALBASEAD) ; INITGLOBALAREA(LIBNUCGLOBALP,NILAD); INITHEAPMANAGEMENT ; INITFILEHANDLING ; INITJOURNAL ; END (* BASICINIT *) ; PROCEDURE RTINIT (GLOBALP : GLOBALAREAPT; GLOBALLENWD : SGMTRNGWD; MAINPRGLNBVAL : ADDRESS ); CONST PASCALFLAGFOREDIN=7; BEGIN ATCOMPILETIME := FALSE; IF GLOBALLENWD < GLOBALAREAMINLENWD THEN EHINITERRSTOP(EHIGLBLLEN); ICL9CEZINIT(PASCALFLAGFOREDIN,MAINPRGLNBVAL,NILDESC,0,0); BASICINIT; INITRTERRORHANDLING(GLOBALP,GLOBALLENWD,MAINPRGLNBVAL); END (* RTINIT *); (*#E+*) (*#T-*) PROCEDURE ICL9LPINITRUN (GLOBALAREALENWD : SGMTRNGWD ; GLOBALAREAP : GLOBALAREAPT ; CALLFROMCOMPILER : BOOLEAN) ; CONST PINS16EXITRETAININGPROGMASK = ?I 382C ; (* -I.E.: ORDER=38 FOR EXIT, K=0 FOR 16-BIT INSTRUCTION WITH LITERAL *) (* OPERAND, N=HEX 2C -BIT 25 SET 0 TO AVOID RESETTING PROGRAM *) (* MASK FROM THE LINK DESCRIPTOR. *) VAR MAINPRGLNBVAL : ADDRESS ; BEGIN (* ICL9LPINITRUN *) MAINPRGLNBVAL := ANDX (WORDAT (CURLOCALNAMEBASEAD), ?I FFFFFFFC) ; IF CALLFROMCOMPILER THEN INITGLOBALAREA(GLOBALAREAP,MAINPRGLNBVAL) ELSE RTINIT(GLOBALAREAP,GLOBALAREALENWD,MAINPRGLNBVAL); (* MASK FLOATING POINT UNDERFLOW FOR THE BENEFIT OF THE REAL I/O *) (* ROUTINES AND MAKE A SPECIAL EXIT :- *) ICL9LPMASKUFLOW; CODE16 (PINS16EXITRETAININGPROGMASK) ; END (* ICL9LPINITRUN *) ; PROCEDURE ICL9LPINITCTSUPPORT (VAR LISTFILEP, DIAGFILEP, JRNLFILEP : TEXTPT; VAR ETOITTP, ITOETTP : CCTTPT; CDIAG : CDIAGTYPE ); VAR COMPLNBVAL : ADDRESS; BEGIN ATCOMPILETIME := TRUE; BASICINIT; COMPLNBVAL := ANDX(WORDAT(CURLOCALNAMEBASEAD),?I FFFFFFFC) ; INITCTERRORHANDLING(COMPLNBVAL,CDIAG); INITCTLISTFILE; LISTFILEP := CTLISTFP; DIAGFILEP := DIAGFP; JRNLFILEP := JRNLFP; ETOITTP := CCTTPTB[CCEBC,CCISO]; ITOETTP := CCTTPTB[CCISO,CCEBC]; END (* ICL9LPINITCTSUPPORT *); (*#E-*) PROCEDURE RTFINISH ; BEGIN ICL9HETIDYUP; ICL9CEZSTOP ; END (* RTFINISH *) ; (*#E+*) PROCEDURE ICL9LPFINISHRUN ; BEGIN IF NOT ATCOMPILETIME THEN RTFINISH; END (* ICL9LPFINISHRUN *); PROCEDURE ICL9LPRTTIDY ; BEGIN JRNLFINISHMSG; CLOSEDOWNFILEHANDLING; ICL9CEZTIDY; END (* ICL9LPRTTIDY *); (*#E-*) PROCEDURE HALT ; BEGIN IF ATCOMPILETIME THEN ICL9LPCTABORT(FALSE) ELSE RTFINISH ; END (* HALT *); (*#E+*) PROCEDURE ICL9LPHALT (MSGD : STRDESC) ; VAR I, MSGLENB : MXSZSTRRNGB ; MSGP : MXSZBYTESTRPT ; CONVJRNLTTP : CCTTPT ; BEGIN MSGLENB := DEBOUND (MSGD) ; MSGP := TYPECONV (MXSZBYTESTRPT, DEADDR (MSGD)) ; CONVJRNLTTP := CCTTPTB [CCUSRPRG, CCSYSEXTNL] ; FOR I := 1 TO MSGLENB DO WRITE (JRNLFP@, CHR (CONVJRNLTTP@ [MSGP@ [I]])) ; WRITELN (JRNLFP@) ; HALT ; END (* ICL9LPHALT *) ; BEGIN END.