!* !* !*********************************************************************** !*********************************************************************** !* * !* P A S C A L R U N T I M E S U P P O R T L I B R A R Y * !* * !*********************************************************************** !*********************************************************************** !* !* !* History !* ------- !* !* Version 1.0 for Perq2 and Perq3. (agh) !* 29/04/86 - Fix field-width bug in WriteWord. !* 03/05/86 - Introduce CheckName to validate file names. !* 05/05/86 - Revised treatment of file names. Remove close error !* check from reset, rewrite and append. Add New3 and !* Dispose3. !* 06/05/86 - In ExtendHeap chain blocks correctly. !* 06/05/86 - In Release, StartGarbage > HeapTop, change > to # to !* to ensure HeapTop is retracted if StartGarbage = HeapTop. !* 06/05/86 - In Acquire, chain surplus block correctly and follow !* follow search-chain accordingly. !* 07/05/86 - Remove size checks on new and dispose. Parameters are !* verified by the compiler instead. !* 07/05/86 - Add fast unchecked versions new0 and dispose0. !* 07/05/86 - Fix bug in CheckWrite to access flags correctly. !* 08/05/86 - Minor improvements to diagnostic reporting. !* 19/05/86 - Preset file control blocks to undefined pattern. !* 19/05/86 - Ensure heap requests > 16k honoured. !* 19/05/86 - Add textdesc and notextdesc. !* 19/05/86 - Merge file-names with error messages. !* 22/05/86 - Add maths function interface. !* 28/05/86 - Replace // by unsigned division in WriteWord. !* %CONSTINTEGER PERQ2= 0; %CONSTINTEGER PERQ3= 1; %CONSTINTEGER AMDAHL= 2; %CONSTINTEGER GOULD= 3; %CONSTINTEGER HOST= AMDAHL %CONSTINTEGER TARGET= AMDAHL !* %CONSTINTEGER REPORT=0 %CONSTINTEGER TRACE= 0 !* !************************************************************************ !* S Y S T E M - D E P E N D E N T D E C L A R A T I O N S * !************************************************************************ !* %CONSTINTEGER MCBYTESPERWORD= 4 { bytes per machine word } !* %IF HOST=PERQ2 %THENSTART !* %CONSTINTEGER BYTESTOUNITS= 2 { scale bytes to architectural units } %CONSTINTEGER UNITSTOBYTES= 2 { scale architectural units to bytes } %CONSTINTEGER WORDSTOUNITS= 1 { scale words to architectural units } %CONSTINTEGER UNITSTOWORDS= 1 { scale architectural units to words } %CONSTINTEGER BLOCKHEADER= 8 { memory-block header size ... (words) } %CONSTINTEGER STARTOFFSET= 2 { memory-block start offset .. (words) } %CONSTINTEGER ENDOFFSET= 4 { memory-block end offset .... (words) } %CONSTINTEGER FREEOFFSET= 6 { memory-block free-list offset(words) } %CONSTINTEGER MINHEAPBLOCK= 4 { minimum heap-block size .... (words) } %CONSTINTEGER SIZEOFFSET= 2 { heap-block size offset .... (words) } %CONSTINTEGER LEVELOFFSET= 2 { variable level offset ...... (words) } %CONSTINTEGER FLAGOFFSET= 2 { file control flags offset .. (words) } !* %FINISHELSESTART !* %CONSTINTEGER BYTESTOUNITS= 1 { scale bytes to architectural units } %CONSTINTEGER UNITSTOBYTES= 1 { scale architectural units to bytes } %CONSTINTEGER WORDSTOUNITS= 2 { scale words to architectural units } %CONSTINTEGER UNITSTOWORDS= 2 { scale architectural units to words } %CONSTINTEGER BLOCKHEADER= 16 { memory-block header size ... (bytes) } %CONSTINTEGER STARTOFFSET= 4 { memory-block start offset .. (bytes) } %CONSTINTEGER ENDOFFSET= 8 { memory-block end offset .... (bytes) } %CONSTINTEGER FREEOFFSET= 12 { memory-block free-list offset(words) } %CONSTINTEGER MINHEAPBLOCK= 8 { minimum heap-block size .... (bytes) } %CONSTINTEGER SIZEOFFSET= 4 { heap-block size offset .... (bytes) } %CONSTINTEGER LEVELOFFSET= 4 { variable level offset ...... (bytes) } %CONSTINTEGER FLAGOFFSET= 4 { file control flags offset .. (words) } !* %FINISH !* %CONSTINTEGER DEFAULTBLOCKSIZE= 16*1024-8 { memory manager block-size } !* !************************************************************************ !* S Y S T E M - D E P E N D E N T I M P O R T S * !************************************************************************ !* %EXTERNALROUTINESPEC DESTROY %ALIAS "S#DESTROY"(%STRING (255) FILE, %INTEGERNAME FLAG) %externalintegerfnspec checkname %alias "S#CHECKNAME"(%stringname name, %integername type,qualifier) !%EXTERNALINTEGERFNSPEC FREE(%INTEGER BLOCKPTR) !* !* %EXTERNALROUTINESPEC STOP %ALIAS "S#STOP" %EXTERNALROUTINESPEC NDIAG %ALIAS "S#NDIAG"(%INTEGER PC,LNB,FAULT,INF) %EXTERNALROUTINESPEC FILL %ALIAS "s#fill"(%INTEGER LENGTH,AT,FILLER) %EXTERNALROUTINESPEC MOVE %ALIAS "s#move"(%INTEGER LEN,FROM,TO) %EXTERNALROUTINESPEC SETRETURNCODE %ALIAS "S#SETRETURNCODE"(%INTEGER VAL) %EXTERNALSTRINGFNSPEC NEXTTEMP %ALIAS "S#NEXTTEMP" %EXTERNALROUTINESPEC OUTFILE %ALIAS "S#OUTFILE"(%STRING (255) FILE, %INTEGER SIZE,HOLE,PROT, %INTEGERNAME CONAD,FLAG) %EXTERNALROUTINESPEC CHANGEFILESIZE %ALIAS "S#CHANGEFILESIZE"(%STRING (255) FILE, %INTEGER NEWSIZE, %INTEGERNAME FLAG) %EXTERNALROUTINESPEC DISCONNECT %ALIAS "S#DISCONNECT"(%STRING (255) FILE, %INTEGERNAME FLAG) %EXTERNALROUTINESPEC PHEX %ALIAS "s#phex"(%INTEGER N) %EXTERNALINTEGERMAPSPEC COMREG %ALIAS "S#COMREGMAP"(%INTEGER N) %EXTERNALROUTINESPEC EMAS3CLAIMCHANNEL(%INTEGERNAME CH) %EXTERNALROUTINESPEC EMAS3(%STRING (255) %NAME COMM,PARAM, %INTEGERNAME FLAG) %EXTERNALROUTINESPEC OPENSQ(%INTEGER CH) %EXTERNALROUTINESPEC WRITESQ(%INTEGER CHAN, %NAME START,FINISH) %EXTERNALROUTINESPEC READLSQ(%INTEGER CH, %NAME START,FINISH, %INTEGERNAME LEN) %EXTERNALROUTINESPEC CLOSESQ(%INTEGER CH) %EXTERNALSTRING (15) %FNSPEC ITOS %ALIAS "S#ITOS"(%INTEGER N) %EXTERNALINTEGERFNSPEC ISATTY %ALIAS "S#ISATTY"(%INTEGER CHAN) %OWNSTRING (31) HEAPFILENAME="" %OWNINTEGER HCONAD=0 !* !*********************************************************************** !* S Y S T E M - I N D E P E N D E N T E X P O R T S * !*********************************************************************** !* %ROUTINESPEC STARTPROGRAM(%INTEGER CONTROL) %ROUTINESPEC ENDPROGRAM %ROUTINESPEC TRAPPROGRAM(%INTEGER ERROR) %ROUTINESPEC PAUSEPROGRAM !* %INTEGERFNSPEC MALLOC(%INTEGER BYTES) %ROUTINESPEC PRESETFILE(%INTEGER FCBPTR,COUNT) %ROUTINESPEC POSTSETFILE(%INTEGER FCBPTR,COUNT) %ROUTINESPEC BINDFILE(%INTEGER FCBPTR) %ROUTINESPEC RESETFILE(%INTEGER FCBPTR,PROPERTY,BYTES,NAMEPTR,FLAGPTR) %ROUTINESPEC REWRITEFILE(%INTEGER FCBPTR,PROPERTY,BYTES,NAMEPTR,FLAGPTR) %ROUTINESPEC APPENDFILE(%INTEGER FCBPTR,PROPERTY,BYTES,NAMEPTR,FLAGPTR) %ROUTINESPEC CLOSEFILE(%INTEGER FCBPTR) %ROUTINESPEC ICLCLOSE(%INTEGER FCBPTR) %INTEGERFNSPEC TEXTDESC(%INTEGER FCBPTR) %INTEGERFNSPEC NONTEXTDESC(%INTEGER FCBPTR) !* %INTEGERFNSPEC LAZYOP(%INTEGER FCBPTR) %ROUTINESPEC GETOP(%INTEGER FCBPTR) %ROUTINESPEC GETOPT(%INTEGER FCBPTR) %ROUTINESPEC PUTOP(%INTEGER FCBPTR) %ROUTINESPEC PUTOPT(%INTEGER FCBPTR) %INTEGERFNSPEC EOFOP(%INTEGER FCBPTR) %INTEGERFNSPEC EOLOP(%INTEGER FCBPTR) !* %INTEGERFNSPEC READINT(%INTEGER FCBPTR) %LONGREALFNSPEC READRL(%INTEGER FCBPTR) %ROUTINESPEC READLN(%INTEGER FCBPTR) !* %ROUTINESPEC WRITEINT(%INTEGER FCBPTR,VALUE,WIDTH) %ROUTINESPEC WRITECH(%INTEGER FCBPTR,VALUE,WIDTH) %ROUTINESPEC WRITEBOOL(%INTEGER FCBPTR,VALUE,WIDTH) %ROUTINESPEC WRITEWORD(%INTEGER FCBPTR,VALUE,BASE,WIDTH) %ROUTINESPEC WRITESTR(%INTEGER FCBPTR,STRINGPTR,LENGTH,WIDTH) %ROUTINESPEC WRITEFXRL(%INTEGER FCBPTR, %LONGREAL VALUE, %INTEGER WIDTH,FRACDIGITS) %ROUTINESPEC WRITEFLRL(%INTEGER FCBPTR, %LONGREAL VALUE, %INTEGER WIDTH) %ROUTINESPEC WRITELN(%INTEGER FCBPTR) %ROUTINESPEC WRITELINES(%INTEGER FCBPTR,COUNT) %ROUTINESPEC WRITEPAGE(%INTEGER FCBPTR) !* %ROUTINESPEC NEW0(%INTEGER PTR,BYTES) %ROUTINESPEC NEW1(%INTEGER PTR,LEVELS,BYTES) %ROUTINESPEC NEW2(%INTEGER PTR,BYTES) %ROUTINESPEC NEW3(%INTEGER PTR,BYTES) %ROUTINESPEC DISPOSE0(%INTEGER PTR,BYTES) %ROUTINESPEC DISPOSE1(%INTEGER PTR,LEVELS,BYTES) %ROUTINESPEC DISPOSE2(%INTEGER PTR,BYTES) %ROUTINESPEC DISPOSE3(%INTEGER PTR,BYTES) !* %ROUTINESPEC PACK(%INTEGER UPPTR,PKPTR,UPSIZE,ELSPERWORD,ELEMENTS) %ROUTINESPEC UNPACK(%INTEGER UPPTR,PKPTR,UPSIZE,ELSPERWORD,ELEMENTS) !* %INTEGERFNSPEC SETUNION(%INTEGER LHS,RHS,RESULT,SIZE) %INTEGERFNSPEC SETINTERSECTION(%INTEGER LHS,RHS,RESULT,SIZE) %INTEGERFNSPEC SETDIFFERENCE(%INTEGER LHS,RHS,RESULT,SIZE) %INTEGERFNSPEC SETEQUAL(%INTEGER LHS,RHS,SIZE) %INTEGERFNSPEC SETUNEQUAL(%INTEGER LHS,RHS,SIZE) %INTEGERFNSPEC SETLESSOREQUAL(%INTEGER LHS,RHS,SIZE) %INTEGERFNSPEC SETMEMBER(%INTEGER VALUE,RHS) %INTEGERFNSPEC SINGLETONSET(%INTEGER VALUE,RESULT,SIZE) %INTEGERFNSPEC RANGESET(%INTEGER LOW,HIGH,RESULT,SIZE) !* %LONGREALFNSPEC PSIN(%LONGREAL VALUE) %LONGREALFNSPEC PCOS(%LONGREAL VALUE) %LONGREALFNSPEC PARCTAN(%LONGREAL VALUE) %LONGREALFNSPEC PSQRT(%LONGREAL VALUE) %LONGREALFNSPEC PEXP(%LONGREAL VALUE) %LONGREALFNSPEC PLOG(%LONGREAL VALUE) !* %INTEGERFNSPEC SHIFT(%INTEGER WORD,AMOUNT) %INTEGERFNSPEC ROTATE(%INTEGER WORD,AMOUNT) %ROUTINESPEC ICLDATE(%INTEGER PTR) %ROUTINESPEC ICLTIME(%INTEGER PTR) !* !* !*********************************************************************** !*********************************************************************** !* S Y S T E M - D E P E N D E N T E R R O R M E S S A G E S * !*********************************************************************** !*********************************************************************** !* !* %CONSTSTRING (164) %ARRAY SYSTEMMESSAGES(431:450)= %C " ", " 432 : In a call to 'dispose' an attempt has been made to discard unallocated storage. ", " 433 : In a call to 'dispose' the amount of heap-space released does not match the amount originally allocated by a call to 'new'. ", " 434 : System limit: in a call to 'new' the system was unable to supply sufficient heap-space. ", " 435 : In a call to 'dispose' internal checks indicate that the heap has been corrupted. ", " 436 : In a call to 'write', 'writeln', 'read', 'readln', 'get', 'put', 'eof' or 'eoln', the file-variable parameter is invalid. ", " 437 : Following a call to 'reset', the file ", " 438 : Following a call to 'rewrite', the file ", " 439 : Following a call to 'append', the file ", " 440 : System limit: the maximum number of files that can be opened for reading and writing is 63. ", " 441 : Following a call to 'reset', an attempt was made to read from the standard file 'stdout'. ", " 442 : Following a call to 'reset', and attempt was made to read from the standard file 'stderr'. ", " 443 : Following a call to 'rewrite' or 'append', and attempt was made to write to the standard file 'stdin'. ", " 444 : An attempt to read from the file ", " 445 : An attempt to write to the file ", " 446 : System limit: in a call to 'write' or 'writeln', the field-width must not exceed 128. ", " 447 : System limit: the abosulte value of an integer read from a text file must not exceed 2147483647. ", " 448 : In a call to 'pack' the size of the unpacked data items is invalid. ", " 449 : In a call to 'unpack' the size of the unpacked data items is invalid. ", " 450 : System limit: the element-size of a data-file must not exceed 4096 bytes. " !* !* !*********************************************************************** !*********************************************************************** !* I S O S T A N D A R D E R R O R M E S S A G E S * !*********************************************************************** !*********************************************************************** !* !* %CONSTSTRING (164) %ARRAY ISOMESSAGES(301:359)= %C " 301 : The index value lies outside the bounds of the array. (D1) ", " 302 : The variant field access is inconsistent with the tag-field value, or will destroy an existing reference to the current variant. (D2) ", " 303 : A nil pointer cannot be used to reference a variable, or as a parameter to 'dispose'. (D3,D23) ", " 304 : A undefined pointer cannot be used to reference a variable or as a parameter to 'dispose'. (D4,D24) ", " 305 : A dynamic variable cannot be destroyed by 'dispose' while a reference to it still exists. (D5) ", " 306 : The position of a file cannot be altered while a reference to the buffer variable still exists. (D6) ", " 307 : The value of an actual parameter lies outside the interval defined by the type of the formal parameter. (D7) ", " 308 : The members of an actual parameter lie outside the interval defined by the base-type of the formal parameter. (D8) ", " 309 : A file variable must be in write-mode immediately prior to any use of 'put', 'write', 'writeln', or 'page'. (D9) ", " 310 : A file variable must be defined immediately prior to any use of 'put', 'write', or 'page'. (D10) ", " 311 : End-of-file must be true immediately prior to any use of 'put', 'write', 'writeln', or 'page'. (D11) ", " 312 : The file buffer variable must be defined immediately prior to any use of 'put'. (D12) ", " 313 : A file variable must be defined immediately prior to any use of 'reset'. (D13) ", " 314 : A file variable must be in read-mode immediately prior to any use of 'get' or 'read'. (D14) ", " 315 : A file variable must be defined immediately prior to any use of 'get' or 'read'. (D15) ", " 316 : End-of-file must not be true immediately prior to any use of 'get' or 'read'. (D16) ", " ", " 318 : For 'write', the value of the expression lies outside the range of values defined by the component type of the file. (D18) ", " 319 : For a variable created by 'new(p,c1,,,cn)', tag-field assignment attempts to select a variant not identified by c1,,,cn. (D19) ", " 320 : For 'dispose(p)', the dynamic variable was originally created by a call 'new(p,c1,,,cn)'. (D20) ", " 321 : For 'dispose(p,k1,,,km)', the dynamic variable was originally created by a call 'new(p,c1,,,cn)' where m<>n. (D21) ", " 322 : For 'dispose(p,k1,,,km)', the variants in the dynamic variable are different from those specified by the case-constants. (D22) ", " ", " ", " 325 : A dynamic variable created by 'new(p,c1,,,cn)', cannot be accessed or referenced as an entire variable 'p^'. (D25) ", " 326 : In 'pack', the index value lies outside the bounds of the unpacked array. (D26) ", " 327 : In 'pack', a component of the unpacked array is accessed but undefined. (D27) ", " 328 : In 'pack', the upper bound of the unpacked array will be exceeded. (D28) ", " 329 : In 'unpack', the index value lies outside the bounds of the unpacked array. (D29) ", " 330 : In 'unpack', a component of the packed array is both undefined and accessed. (D30) ", " 331 : In 'unpack' the upper bound of the unpacked array will be exceeded. (D31) ", " 332 : For integer or real 'x', 'sqr(x)' would exceed the maximum integer or real value. (D32) ", " 333 : For 'ln(x)', 'x' is zero or negative. (D33) ", " 334 : For 'sqrt(x)', 'x' is negative. (D34) ", " 335 : The magnitude of 'x' is too large to allow evaluation of 'trunc(x)' as defined by the Pascal Standard. (D35) ", " 336 : The magnitude of 'x' is too large to allow evaluation of 'round(x)' as defined by the pascal standard. (D36) ", " 337 : For 'chr(x)', 'x' does not identify a character value. (D37) ", " 338 : The value of 'succ(x)' exceeds the range of values defined by the type of 'x'. (D38) ", " 339 : The value of 'pred(x)' precedes the range of values defined by the type of 'x'. (D39) ", " 340 : For 'eof(f)', 'f' is undefined. (D40) ", " 341 : For 'eoln(f)', 'f' is undefined. (D41) ", " 342 : For 'eoln(f)', 'eof(f)' is already true. (D42) ", " 343 : A variable or buffer variable must be assigned a value prior to its use in an expression or in 'put'. (D12,D43) ", " 344 : In 'x/y', 'y' is zero. (D44) ", " 345 : In 'i div j', 'j' is zero. (D45) ", " 346 : In 'i mod j', 'j' is zero or negative. (D46) ", " 347 : The result of integer addition, subtraction, or multiplication lies outside the interval [-maxint..+maxint]. (D47) ", " 348 : The value of the function is undefined. (D48) ", " 349 : An expression value or a value read, lies outside the range of values defined by the variable type. (D17,D18,D49,D55) ", " 350 : The members of a set-value lie outside the range of values defined by the base-type of the set variable. (D50) ", " 351 : In a case-statement, none of the case constants is equal to the value of the case-index. (D51) ", " 352 : In a for-statement, the initial value is less than the minimum permitted value of the control variable. (D52) ", " 353 : In a for-statement, the final value is greater than the maximum permitted value of the control variable. (D53) ", " 354 : The sequence of data characters does not form a signed integer number. (D54) ", " ", " 356 : The sequence of data characters does not form a signed real number. (D56) ", " 357 : The buffer variable is undefined immediately prior to use of 'read'. (D57) ", " 358 : The value of a field-width expression in a write-statement is less than one. (D58) ", " 359 : The bounds of an actual parameter do not lie within the range of the index type of the formal conformant array parameter. (D59) " !* !* !*********************************************************************** !*********************************************************************** !* I C L P A S C A L E R R O R M E S S A G E S * !*********************************************************************** !*********************************************************************** !* !* %CONSTSTRING (164) %ARRAY ICLMESSAGES(370:381)= %C " 370 : The file-variable in a call to 'reset', 'rewrite' or 'append', is already bound to another file. A call to 'close' is required. (D10) ", " 371 : A file variable must be defined immediately prior to any use of 'close'. ", " 372 : A file must be opened immediately prior to any use of 'textdesc' or 'nontextdesc'. ", " ", " ", " ", " ", " 377 : A 'goto' statement attempts to tranfer control to a global label in a program block that is not active. (D17) ", " 378 : The base of write-parameter does not lie in the closed interval [2..16]. (D18) ", " 379 : In 'lines', the value of the expression is less than one. (D19) ", " ", " 381 : In an enumeration transfer, the value of the expression does not belong to the set of values denoited by the type-identifier. (D21) " !* !* !*********************************************************************** !*********************************************************************** !* M A T H S F U N C T I O N E R R O R M E S S A G E S * !*********************************************************************** !*********************************************************************** !* !* %CONSTSTRING (164) %ARRAY MATHSMESSAGES(1:7)= %C " Maths function error: the argument to 'log' is negative or zero. ", " Maths function error: the argument to 'sqrt' is negative. ", " Maths function error: the argument to 'exp' is greater than 709.78. ", " Maths function error: the argument to 'exp' is less than -708.39. ", " Maths function error: the argument to 'sin' is greater than 2.829E+16. ", " Maths function error: the argument to 'asin' is greater than 1.0. ", " Maths function error: the argument to 'cos' is greater than 2.829E+16. " !* !* !*********************************************************************** !*********************************************************************** !* S Y S T E M - D E P E N D E N T D E C L A R A T I O N S * !*********************************************************************** !*********************************************************************** !* !* %CONSTINTEGER NIL= 0 { denotes 'nil' pointer } %CONSTINTEGER FALSE= 0 { denotes Boolean 'false' } %CONSTINTEGER TRUE= 1 { denotes Boolean 'true' } %CONSTINTEGER UNDEFINEDVAR= 16_81818181{ denotes undefined value } !* !* !*********************************************************************** !* declarations for the control-manager * !*********************************************************************** !* !* %CONSTINTEGER UNKNOWN= 0 { denotes unknown language } %CONSTINTEGER PASCAL= 1 { denotes Pascal language } %CONSTINTEGER FORTRAN= 2 { denotes Fortran language } %CONSTINTEGER IMP= 3 { denotes Imp language } !* %IF TARGET=PERQ2 %THENSTART !* %CONSTINTEGER MAXDISPLAY= 46 { max display size .. (words)} !* %FINISHELSESTART !* %CONSTINTEGER MAXDISPLAY= 128 { max display size .. (bytes)} !* %FINISH !* %OWNINTEGER CONTROL,RCHECKS,HCHECKS,FCHECKS,UCHECKS !* !* !*********************************************************************** !* declarations for the memory-manager * !*********************************************************************** !* !* %CONSTINTEGER MAXHEAPBLOCK= 16*1024-64 { BlockSize - Safety Margin } !* %OWNINTEGER BLOCKLIST,HEAPTOP !* %ROUTINESPEC INITHEAP %ROUTINESPEC PRESET(%INTEGER PTR,AMOUNT) %ROUTINESPEC ACQUIRE(%INTEGERNAME PTR, %INTEGER AMOUNT) %ROUTINESPEC RELEASE(%INTEGER PTR,AMOUNT) !* !* !*********************************************************************** !* declarations for the file-manager * !*********************************************************************** !* !* %CONSTINTEGER STDIN= 0 { standard input stream } %CONSTINTEGER STDOUT= 1 { standard output stream } %CONSTINTEGER STDERR= 2 { standard error stream } %CONSTINTEGER FCBSIZE= 32 { size of FCB CtlBlock ... (bytes) } %CONSTINTEGER DISCBUFFER= 1024 { size of disc i/o buffer (bytes) } %CONSTINTEGER TERMBUFFER= 256 { size of term i/o buffer (bytes) } %CONSTINTEGER MINCAPACITY= 4 { minimum number of buffered items } !* these for fcb_flags %CONSTINTEGER LAZYFLAG= 1 { set bit 0 if f^ defined } %CONSTINTEGER EOLFLAG= 2 { set bit 1 if eoln(f) true } %CONSTINTEGER EOFFLAG= 4 { set bit 2 if eof(f) } %CONSTINTEGER PERMFLAG= 8 { set bit 3 if permanent file } %CONSTINTEGER TERMFLAG= 16 { set bit 4 if terminal file } !* these for fcb_type %CONSTINTEGER DATAFILE= 0 { denote data file } %CONSTINTEGER TEXTFILE= 1 { denote text file } %CONSTINTEGER BYTEFILE= 2 { denote byte-packed data file } %CONSTINTEGER BITFILE= 3 { denote bit-packed data file } !* these for fcb_mode %CONSTINTEGER UNDEFINED= X'81' { denote 'undefined' file mode } %CONSTINTEGER DEFINED= 1 { denote 'defined' file mode } %CONSTINTEGER READING= 2 { denote 'inspection' file mode } %CONSTINTEGER WRITING= 3 { denote 'generation' file mode } %CONSTINTEGER APPENDING= 4 { denote 'appending' file mode } !* %CONSTINTEGER READMODE= 0 { PNX read mode } %CONSTINTEGER WRITEMODE= 1 { PNX write mode } %CONSTINTEGER RWMODE= 2 { PNX read-write mode } %CONSTINTEGER WRITEACCESS= 2 { PNX write access } %CONSTINTEGER READACCESS= 4 { PNX read access } %CONSTINTEGER RWACCESS= 8_664{ PNX read-write access } !* %RECORDFORMAT CTLBLOCK(%INTEGER BUFFERPTR,FLAGS, %BYTEINTEGER DESCRIPTOR,MODE,TYPE,SPARE, %INTEGER STARTBUFFER,ENDBUFFER,PACKPTR, %SHORTINTEGER ELEMSIZE,BUFFERSIZE, %INTEGER NAMEPTR) !* %OWNRECORD (CTLBLOCK) %NAME ERROR FCB %OWNINTEGER BINDINGS,STDOUTPTR,STDERRPTR !* !* !*********************************************************************** !* declarations for the i/o manager * !*********************************************************************** !* !* %CONSTINTEGER NL= 10 { ASCII newline } %CONSTINTEGER FF= 12 { ASCII form-feed } %CONSTINTEGER SP= 32 { ASCII space } %CONSTINTEGER EOT= 4 { ASCII end-of-transmission (eof) } %CONSTINTEGER MAXWIDTH= 128 { maximum field-width for write } %CONSTINTEGER MAXINTDIV10= 214748364 { maxint // 10 } %CONSTINTEGER MAXINTMOD10= 7 { rem(maxint, 10) } %CONSTINTEGER EXPDIGITS= 2 { number of exponent digits } !* %CONSTBYTEINTEGERARRAY FALSESTR(1:5)= 'f', 'a', 'l', 's', 'e' %CONSTBYTEINTEGERARRAY TRUESTR(1:4)= 't', 'r', 'u', 'e' !* %INTEGERFNSPEC OPENF(%RECORD (CTLBLOCK) %NAME FCB, %INTEGER TYPE,BYTES,NAMEPTR,MODE) %ROUTINESPEC FILLBUFFER(%RECORD (CTLBLOCK) %NAME FCB) %ROUTINESPEC FLUSHBUFFER(%RECORD (CTLBLOCK) %NAME FCB) %ROUTINESPEC FORCEFLUSH(%INTEGER FCBPTR) %ROUTINESPEC CLOSEF(%RECORD (CTLBLOCK) %NAME FCB) !* %ROUTINESPEC CHECKREAD(%RECORD (CTLBLOCK) %NAME FCB) %ROUTINESPEC CHECKWRITE(%RECORD (CTLBLOCK) %NAME FCB) %ROUTINESPEC ACTUALGET(%RECORD (CTLBLOCK) %NAME FCB) %ROUTINESPEC LAZYGET(%RECORD (CTLBLOCK) %NAME FCB) %INTEGERFNSPEC NEXTCH(%RECORD (CTLBLOCK) %NAME FCB) %ROUTINESPEC PUTCH(%RECORD (CTLBLOCK) %NAME FCB, %INTEGER CH) %ROUTINESPEC PADFIELD(%RECORD (CTLBLOCK) %NAME FCB, %INTEGER SPACES) !* !* !*********************************************************************** !* declarations for set-arithmetic * !*********************************************************************** !* !* %CONSTINTEGERARRAY MASK(0:31)= %C X'00000001', X'00000003', X'00000007', X'0000000F', X'0000001F', X'0000003F', X'0000007F', X'000000FF', X'000001FF', X'000003FF', X'000007FF', X'00000FFF', X'00001FFF', X'00003FFF', X'00007FFF', X'0000FFFF', X'0001FFFF', X'0003FFFF', X'0007FFFF', X'000FFFFF', X'001FFFFF', X'003FFFFF', X'007FFFFF', X'00FFFFFF', X'01FFFFFF', X'03FFFFFF', X'07FFFFFF', X'0FFFFFFF', X'1FFFFFFF', X'3FFFFFFF', X'7FFFFFFF', X'FFFFFFFF' !* !* !*********************************************************************** !*********************************************************************** !* The following routines provide overall control of program entry and * !* exit. * !*********************************************************************** !*********************************************************************** !* !* %ROUTINE EXIT !*********************************************************************** !* This returns to command level. S#STOP does all the work * !* but we use this routine to destroy the heap and possibly other * !* internal tidy operations. Should be proof against recursive * !* running of Pascal programs. * !*********************************************************************** %INTEGER FLAG %IF REPORT#0 %THEN PRINTSTRING("p_exit") %AND NEWLINE %IF HEAPFILENAME#"" %START HCONAD=0 DISCONNECT(HEAPFILENAME,FLAG) HEAPFILENAME="" %FINISH STOP %END %INTEGERFN BEXTEND(%INTEGER BYTE) %IF BYTE&128#0 %THEN BYTE=BYTE!x'ffffff00' %RESULT=BYTE %END %EXTERNALROUTINE MONITOR %ALIAS "p_mon"(%INTEGER RTFRAMES) !*********************************************************************** !* Control production of postmortem diagnostics by calling language- * !* dependent diagnostic routines. RtFrame gives the number of stack- * !* frames to ignore when PostMortem is called internally from r/t IMP * !* routines. * !*********************************************************************** %INTEGER THISFRAME,PC THISFRAME=ADDR(RTFRAMES)-64 ! ! Do not need to discard RT frames manually on EMAS. Once Pascal library ! is part of the System Library NDIAG will do this automatcally Unless ! conreg 25 is nonzero. To diagnose errors in the Pascal LIbrary after ! it is in SYSLIB type "#scom 25,1". ! PC=INTEGER(THISFRAME+60) NDIAG(PC,THISFRAME,0,0) EXIT %END; ! Monitor !* %ROUTINE RUNTIMEERROR !*********************************************************************** !* Announce a runtime error. The runtime system prints an explanatory * !* message only. All other diagnostics are supplied by PMD. * !*********************************************************************** NEWLINES(2) SPACES(25) PRINTSTRING("------ Runtime error ------") NEWLINES(2) %END; ! RuntimeError !* %ROUTINE APPEND(%STRING (128) REMAINDER) !*********************************************************************** !* Append the remainder of an error message after inserting the file * !* name. * !*********************************************************************** %STRING (127) %NAME FILENAME FILENAME==STRING(ERRORFCB_NAMEPTR) PRINTSTRING("'".FILENAME."'") NEWLINE PRINTSTRING(" ".REMAINDER) NEWLINE %END; ! Append !* %ROUTINE ISOERROR(%INTEGER CODE) !*********************************************************************** !* Report an ISO Standard run-time error. * !*********************************************************************** %STRING (255) MESSAGE RUNTIMEERROR CODE=CODE+300 MESSAGE=ISOMESSAGES(CODE) PRINTSTRING(MESSAGE) MONITOR(2) %END; ! ISOError !* %ROUTINE ICLERROR(%INTEGER CODE) !*********************************************************************** !* Report an EPC Pascal run-time error. * !*********************************************************************** %STRING (255) MESSAGE RUNTIMEERROR CODE=CODE+360 MESSAGE=ICLMESSAGES(CODE) PRINTSTRING(MESSAGE) MONITOR(2) %END; ! ICLError !* %ROUTINE SYSTEMERROR(%INTEGER CODE) !*********************************************************************** !* Report a system-dependent run-time error. * !*********************************************************************** %STRING (255) MESSAGE RUNTIMEERROR CODE=CODE+430 MESSAGE=SYSTEMMESSAGES(CODE) PRINTSTRING(MESSAGE) %IF CODE=437 %THEN APPEND("could not be opened for reading.") %IF CODE=438 %OR CODE=439 %THEN APPEND("could not be opened for writing.") %IF CODE=444 %OR CODE=445 %THEN APPEND("has failed.") MONITOR(2) %END; ! SystemError !* %EXTERNALROUTINE MATHSERROR %ALIAS "p_mle"(%INTEGER CODE) !*********************************************************************** !* Report an error from the match function library. * !*********************************************************************** %SWITCH E(1:7) %STRING (255) MESSAGE RUNTIMEERROR ->E(CODE) E(1): MESSAGE=ISOMESSAGES(333) ->PRINT E(2): MESSAGE=ISOMESSAGES(334) ->PRINT E(*): MESSAGE=MATHSMESSAGES(CODE) PRINT: PRINTSTRING(MESSAGE) MONITOR(2) %END; ! MathsError !* %EXTERNALROUTINE INSTRUCTIONERROR %ALIAS "ponill" !*********************************************************************** !* Signal illegal instruction. * !*********************************************************************** NEWLINE PRINTSTRING("** Illegal instruction signalled **") NEWLINES(2) MONITOR(1) %END; ! InstructionError !* %EXTERNALROUTINE RANGEERROR %ALIAS "ponbnd" !*********************************************************************** !* Signal harware bound error from CHK instruction. * !*********************************************************************** NEWLINE PRINTSTRING("** Range error signalled **") NEWLINES(2) MONITOR(1) %END; ! BoundError !* %EXTERNALROUTINE QUITPROGRAM %ALIAS "ponquit" !*********************************************************************** !* Signal quit. * !*********************************************************************** NEWLINE PRINTSTRING("** Quit signalled **") NEWLINES(2) MONITOR(1) %END; ! QuitProgram !* %EXTERNALROUTINE IOERROR %ALIAS "poniot" !*********************************************************************** !* Signal i/o transfer error. * !*********************************************************************** NEWLINE PRINTSTRING("** IOT error signalled **") NEWLINES(2) MONITOR(1) %END; ! IOError !* %EXTERNALROUTINE EMTERROR %ALIAS "ponemt" !*********************************************************************** !* Signal EMT error. * !*********************************************************************** NEWLINE PRINTSTRING("** EMT error signalled **") NEWLINES(2) MONITOR(1) %END; ! EMTError !* %EXTERNALROUTINE FPERROR %ALIAS "ponfpe" !*********************************************************************** !* Signal floating-point error. * !*********************************************************************** NEWLINE PRINTSTRING("** Floating-point error signalled **") NEWLINES(2) MONITOR(1) %END; ! FPError !* %EXTERNALROUTINE ADDRESSERROR %ALIAS "ponsegv" !*********************************************************************** !* Signal address error. * !*********************************************************************** NEWLINE PRINTSTRING("** Address error signalled **") NEWLINES(2) MONITOR(1) %END; ! AddressError !* %ROUTINE EPCERROR(%INTEGER CODE) !*********************************************************************** !* Report an EPC Pascal run-time error. * !*********************************************************************** { 10 : duplicate file-binding } { 18 : base not in range 2..16 } NEWLINE PRINTSTRING("EPC Error"); WRITE(CODE,4); NEWLINE %MONITOR EXIT %END; ! EPCError !* !* %EXTERNALROUTINE STARTPROGRAM %ALIAS "p_init"(%INTEGER FLAGS) !*********************************************************************** !* * !* Start program. Flags provides control flags as follows * !* * !* bit 0 - spare * !* 1 - spare * !* 2 - spare * !* 3 - spare * !* 4..7 - diag level * !* * !* 0 - no diags * !* 1 - supply minimal diags * !* 2 - supply trace-back * !* 3 - supply trace-back and scalar variable-dump * !* 4 - supply trace-back and full variable dump * !* * !* 8 - Enable range checks * !* 9 - Enable unassigned varaible checks * !* 10 - Enable heap checks * !* 11 - Enable file checks * !* * !* * !*********************************************************************** CONTROL=(FLAGS>>4)&255 RCHECKS=FLAGS&(1<<8) UCHECKS=FLAGS&(1<<9) HCHECKS=FLAGS&(1<<10) FCHECKS=FLAGS&(1<<11) INITHEAP %END; ! StartProgram %EXTERNALROUTINE ENDPROGRAM %ALIAS "p_end" !*********************************************************************** !* Normal program termination. Return to calling environment. * !*********************************************************************** NEWLINES(2) PRINTSTRING("Program stopped.") NEWLINE EXIT %END; ! EndProgram !* %EXTERNALROUTINE D1 %ALIAS "p_d1" !*********************************************************************** !* Report ISO error D1. * !*********************************************************************** ISOERROR(1) %END; ! D1 !* %EXTERNALROUTINE D7 %ALIAS "p_d7" !*********************************************************************** !* Report ISO error D7. * !*********************************************************************** ISOERROR(7) %END; ! D7 !* %EXTERNALROUTINE D8 %ALIAS "p_d8" !*********************************************************************** !* Report ISO error D8. * !*********************************************************************** ISOERROR(8) %END; ! D8 !* %EXTERNALROUTINE D17 %ALIAS "p_d17" !*********************************************************************** !* Report ISO error D17. * !*********************************************************************** ISOERROR(17) %END; ! D17 !* %EXTERNALROUTINE D18 %ALIAS "p_d18" !*********************************************************************** !* Report ISO error D18. * !*********************************************************************** ISOERROR(18) %END; ! D18 !* %EXTERNALROUTINE D26 %ALIAS "p_d26" !*********************************************************************** !* Report ISO error D26. * !*********************************************************************** ISOERROR(26) %END; ! D26 !* %EXTERNALROUTINE D28 %ALIAS "p_d28" !*********************************************************************** !* Report ISO error D28. * !*********************************************************************** ISOERROR(28) %END; ! D28 !* %EXTERNALROUTINE D29 %ALIAS "p_29" !*********************************************************************** !* Report ISO error D29. * !*********************************************************************** ISOERROR(29) %END; ! D29 !* %EXTERNALROUTINE D31 %ALIAS "p_31" !*********************************************************************** !* Report ISO error D31. * !*********************************************************************** ISOERROR(31) %END; ! D31 !* %EXTERNALROUTINE D32 %ALIAS "p_32" !*********************************************************************** !* Report ISO error D32. * !*********************************************************************** ISOERROR(32) %END; ! D32 !* %EXTERNALROUTINE D33 %ALIAS "p_33" !*********************************************************************** !* Report ISO error D33. * !*********************************************************************** ISOERROR(33) %END; ! D33 !* %EXTERNALROUTINE D34 %ALIAS "p_34" !*********************************************************************** !* Report ISO error D34. * !*********************************************************************** ISOERROR(34) %END; ! D34 !* %EXTERNALROUTINE D35 %ALIAS "p_35" !*********************************************************************** !* Report ISO error D35. * !*********************************************************************** ISOERROR(35) %END; ! D35 !* %EXTERNALROUTINE D36 %ALIAS "p_36" !*********************************************************************** !* Report ISO error D36. * !*********************************************************************** ISOERROR(36) %END; ! D36 !* %EXTERNALROUTINE D37 %ALIAS "p_37" !*********************************************************************** !* Report ISO error D37. * !*********************************************************************** ISOERROR(37) %END; ! D37 !* %EXTERNALROUTINE D38 %ALIAS "p_38" !*********************************************************************** !* Report ISO error D38. * !*********************************************************************** ISOERROR(38) %END; ! D38 !* %EXTERNALROUTINE D39 %ALIAS "p_39" !*********************************************************************** !* Report ISO error D39. * !*********************************************************************** ISOERROR(39) %END; ! D39 !* %EXTERNALROUTINE D44 %ALIAS "p_44" !*********************************************************************** !* Report ISO error D44. * !*********************************************************************** ISOERROR(44) %END; ! D44 !* %EXTERNALROUTINE D45 %ALIAS "p_45" !*********************************************************************** !* Report ISO error D45. * !*********************************************************************** ISOERROR(45) %END; ! D45 !* %EXTERNALROUTINE D46 %ALIAS "p_46" !*********************************************************************** !* Report ISO error D46. * !*********************************************************************** ISOERROR(46) %END; ! D46 !* %EXTERNALROUTINE D47 %ALIAS "p_47" !*********************************************************************** !* Report ISO error D47. * !*********************************************************************** ISOERROR(47) %END; ! D47 !* %EXTERNALROUTINE D48 %ALIAS "p_48" !*********************************************************************** !* Report ISO error D48. * !*********************************************************************** ISOERROR(48) %END; ! D48 !* %EXTERNALROUTINE D49 %ALIAS "p_49" !*********************************************************************** !* Report ISO error D49. * !*********************************************************************** ISOERROR(49) %END; ! D49 !* %EXTERNALROUTINE D50 %ALIAS "p_50" !*********************************************************************** !* Report ISO error D50. * !*********************************************************************** ISOERROR(50) %END; ! D50 !* %EXTERNALROUTINE D51 %ALIAS "p_51" !*********************************************************************** !* Report ISO error D51. * !*********************************************************************** ISOERROR(51) %END; ! D51 !* %EXTERNALROUTINE D58 %ALIAS "p_58" !*********************************************************************** !* Report ISO error D58. * !*********************************************************************** ISOERROR(58) %END; ! D58 !* %EXTERNALROUTINE D59 %ALIAS "p_59" !*********************************************************************** !* Report ISO error D59. * !*********************************************************************** ISOERROR(59) %END; ! D59 %EXTERNALROUTINE TRAPPROGRAM %ALIAS "p_trap"(%INTEGER ERROR) !*********************************************************************** !* Trap program runtime error. Error gives the appropriate error code. * !*********************************************************************** ERROR=ERROR-300 %IF ERROR<60 %THEN ISOERROR(ERROR) %ELSE ICLERROR(ERROR) %END; ! TrapProgram !* !* !* %EXTERNALROUTINE PAUSEPROGRAM %ALIAS "p_pause" !*********************************************************************** !* Pause program execution and provide 'snapshot' dump. * !*********************************************************************** %END; ! PauseProgram !* !* !*********************************************************************** !*********************************************************************** !* The following procedures provide support for file-variables. * !*********************************************************************** !*********************************************************************** !* !* %ROUTINE PRINTFCB(%INTEGER FCBPTR) !*********************************************************************** !* Dump file FCB. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %STRING (127) %NAME FILENAME %INTEGER I FCB==RECORD(FCBPTR) NEWLINE; PRINTSTRING("FCB for ... ") FILENAME==STRING(FCB_NAMEPTR) PRINTSTRING(FILENAME) NEWLINE %FOR I=0,1,8 %CYCLE PHEX(INTEGER(FCBPTR+I*2*WORDSTOUNITS)) NEWLINE %REPEAT %END; ! PrintFCB !* %EXTERNALROUTINE PRESETFILE %ALIAS "p_presetf"(%INTEGER FCBPTR,COUNT) !*********************************************************************** !* Preset a file control block to 'undefined'. FCBPtr points to an * !* array of one or more control blocks. The number of such blocks is * !* given by Count. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("p_preset "); PHEX(FCBPTR); WRITE(COUNT,4); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) PRESET(FCBPTR,COUNT*FCBSIZE) %END; ! PresetFile !* %EXTERNALROUTINE POSTSETFILE %ALIAS "p_postsetf"(%INTEGER FCBPTR,COUNT) !*********************************************************************** !* Postset a file control block to 'undefined' and close the file if * !* opened. FCBPtr points to an array of one or more control blocks. * !* The number of such blocks is given by Count. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %INTEGER I %IF REPORT#0 %THENSTART PRINTSTRING("p_postset "); PHEX(FCBPTR); WRITE(COUNT,4); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) %FOR I=1,1,COUNT %CYCLE %IF REPORT#0 %THEN PRINTFCB(FCBPTR) CLOSEFILE(FCBPTR) FCBPTR=FCBPTR+(FCBSIZE//BYTESTOUNITS) %REPEAT %END; ! PostsetFile !* %EXTERNALROUTINE BINDFILE %ALIAS "p_bindf"(%INTEGER FCBPTR) !*********************************************************************** !* Bind a file-variable to a permanent file in the file-store. When * !* closed, the file will be retained. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("p_bindf "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) FCB_MODE=DEFINED %END; ! BindFile !* %EXTERNALROUTINE RESETFILE %ALIAS "p_resetf"(%INTEGER FCBPTR,TYPE,BYTES,NAMEPTR,FLAGPTR) !*********************************************************************** !* * !* Open or re-open a file for reading. Parameters are:- * !* * !* FCBPtr - Pointer to file control block. * !* * !* Type - File-type. Values are * !* * !* 0 - data-file * !* 1 - text-file * !* 2 - packed-file * !* 3 - bit-file * !* * !* Bytes - File element size<<8 ! Namelength. * !* * !* NamePtr - Pointer to string containing name of a permanent file. * !* Zero for scratch files. * !* * !* FlagPtr - Pointer to flag-variable or zero. * !* * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %INTEGER MODE,DESCRIPTOR,FLAGS %IF REPORT#0 %THENSTART PRINTSTRING("p_resetf "); PHEX(FCBPTR); WRITE(TYPE,4) PHEX(BYTES); SPACE; PHEX(FLAGPTR); SPACE; ; PHEX(NAMEPTR) NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) MODE=FCB_MODE %IF MODE#UNDEFINED %THENSTART CLOSEF(FCB) %FINISHELSESTART %IF NAMEPTR=NIL %THEN ISOERROR(13) %FINISH DESCRIPTOR=OPENF(FCB,TYPE,BYTES,NAMEPTR,READING) %IF DESCRIPTOR=-1 %THENSTART %IF FLAGPTR#NIL %THEN INTEGER(FLAGPTR)=FALSE %ANDRETURN ERROR FCB==FCB SYSTEMERROR(7) %FINISHELSESTART %IF FLAGPTR#NIL %THEN INTEGER(FLAGPTR)=TRUE %FINISH %IF TYPE#TEXTFILE %THEN FILLBUFFER(FCB) %ELSE FCB_BUFFERPTR=FCB_ENDBUFFER-1 %IF REPORT#0 %THEN PRINTFCB(FCBPTR) %END; ! ResetFile !* %EXTERNALROUTINE REWRITEFILE %ALIAS "p_rewritef"(%INTEGER FCBPTR,TYPE,BYTES,NAMEPTR,FLAGPTR) !*********************************************************************** !* * !* Open or re-open a file for writing. Parameters are:- * !* * !* FCBPtr - Pointer to file control block. * !* * !* Type - File-type. Values are * !* * !* 0 - data-file * !* 1 - text-file * !* 2 - packed-file * !* 3 - bit-file * !* * !* Bytes - File element size <<8 ! Namelength * !* * !* NamePtr - Pointer to string containing name of a permanent file. * !* Zero for scratch files. * !* * !* FlagPtr - Pointer to flag-variable or zero. * !* * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %INTEGER MODE,DESCRIPTOR,FLAGS %IF REPORT#0 %THENSTART PRINTSTRING("p_rewritef "); PHEX(FCBPTR); WRITE(TYPE,4) PHEX(BYTES); SPACE; PHEX(FLAGPTR); SPACE; PHEX(NAMEPTR) NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) MODE=FCB_MODE %IF MODE#UNDEFINED %THENSTART CLOSEF(FCB) %FINISH DESCRIPTOR=OPENF(FCB,TYPE,BYTES,NAMEPTR,WRITING) %IF DESCRIPTOR=-1 %THENSTART %IF FLAGPTR#NIL %THEN INTEGER(FLAGPTR)=FALSE %ANDRETURN ERROR FCB==FCB SYSTEMERROR(8) %FINISHELSESTART %IF FLAGPTR#NIL %THEN INTEGER(FLAGPTR)=TRUE %FINISH FCB_FLAGS=FCB_FLAGS!LAZYFLAG!EOFFLAG ! %IF DESCRIPTOR=STDOUT %AND FCB_FLAGS&TERMFLAG#0 %THEN STDOUTPTR=FCBPTR ! %IF DESCRIPTOR=STDERR %AND FCB_FLAGS&TERMFLAG#0 %THEN STDERRPTR=FCBPTR %IF REPORT#0 %THEN PRINTFCB(FCBPTR) %END; ! RewriteFile !* %EXTERNALROUTINE APPENDFILE %ALIAS "p_appendf"(%INTEGER FCBPTR,TYPE,BYTES,NAMEPTR,FLAGPTR) !*********************************************************************** !* * !* Open or re-open a file for writing but append new data. Parameters * !* are:- * !* * !* FCBPtr - Pointer to file control block. * !* * !* Type - File-type. Values are * !* * !* 0 - data-file * !* 1 - text-file * !* 2 - byte-file * !* 3 - bit-file * !* * !* Bytes - File element size <<8 ! Namelength. * !* * !* NamePtr - Pointer to string containing name of a permanent file. * !* Zero for scratch files. * !* * !* FlagPtr - Pointer to flag-variable or zero. * !* * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %INTEGER MODE,DESCRIPTOR,FLAGS %IF REPORT#0 %THENSTART PRINTSTRING("p_rewritef "); PHEX(FCBPTR); WRITE(TYPE,4) PHEX(BYTES); SPACE; PHEX(FLAGPTR); SPACE; PHEX(NAMEPTR) NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) MODE=FCB_MODE %IF MODE#UNDEFINED %THENSTART CLOSEF(FCB) %FINISH DESCRIPTOR=OPENF(FCB,TYPE,BYTES,NAMEPTR,APPENDING) %IF DESCRIPTOR=-1 %THENSTART %IF FLAGPTR#NIL %THEN INTEGER(FLAGPTR)=FALSE %ANDRETURN ERROR FCB==FCB SYSTEMERROR(9) %FINISHELSESTART %IF FLAGPTR#NIL %THEN INTEGER(FLAGPTR)=TRUE %FINISH FCB_FLAGS=FCB_FLAGS!LAZYFLAG!EOFFLAG ! %IF DESCRIPTOR=STDOUT %AND FCB_FLAGS&TERMFLAG#0 %THEN STDOUTPTR=FCBPTR ! %IF DESCRIPTOR=STDERR %AND FCB_FLAGS&TERMFLAG#0 %THEN STDERRPTR=FCBPTR %END; ! AppendFile !* %EXTERNALROUTINE CLOSEFILE %ALIAS "p_closef"(%INTEGER FCBPTR) !*********************************************************************** !* Close a file if opened. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %INTEGER MODE,DESCRIPTOR,FLAG %IF REPORT#0 %THENSTART PRINTSTRING("p_closef "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) MODE=FCB_MODE; DESCRIPTOR=BEXTEND(FCB_DESCRIPTOR) %IF MODE#UNDEFINED %THENSTART CLOSEF(FCB) DESTROY(STRING(FCB_NAMEPTR),FLAG) %UNLESS FCB_FLAGS&PERMFLAG#0 PRESET(FCBPTR,FCBSIZE) %FINISH %IF FCBPTR=STDOUTPTR %THEN STDOUTPTR=NIL %IF FCBPTR=STDERRPTR %THEN STDERRPTR=NIL %END; ! CloseFile %EXTERNALROUTINE ICLCLOSE %ALIAS "p_close"(%INTEGER FCBPTR) !*********************************************************************** !* Implements explicit ICL close routine. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %INTEGER MODE,DESCRIPTOR,FLAG %IF REPORT#0 %THENSTART PRINTSTRING("p_close "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCB_MODE=UNDEFINED %THEN ICLERROR(11) %ELSE CLOSEFILE(FCBPTR) %END; ! ICLClose !* %EXTERNALINTEGERFN TEXTDESC(%INTEGER FCBPTR) !*********************************************************************** !* Return descriptor for a text file. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCB_MODE=UNDEFINED %THEN ICLERROR(12) %RESULT=FCB_DESCRIPTOR %END; ! TextDesc !* %EXTERNALINTEGERFN NONTEXTDESC(%INTEGER FCBPTR) !*********************************************************************** !* Return a descriptor for a non-text file. * !*********************************************************************** %RESULT=TEXTDESC(FCBPTR) %END; ! NonTextDesc !* !* !*********************************************************************** !*********************************************************************** !* The following procedures provide primitive i/o operations. * !*********************************************************************** !*********************************************************************** !* !* %EXTERNALINTEGERFN LAZYOP %ALIAS "p_lazy"(%INTEGER FCBPTR) !*********************************************************************** !* Perform 'lazy' update of textfile buffer-variable prior to access. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("p_lazy "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCB_FLAGS&LAZYFLAG=0 %THENSTART ACTUALGET(FCB); FCB_FLAGS=FCB_FLAGS!LAZYFLAG %FINISH %RESULT=BYTEINTEGER(FCB_BUFFERPTR) %END; ! LazyOp !* %EXTERNALROUTINE GETOP %ALIAS "p_get"(%INTEGER FCBPTR) !*********************************************************************** !* Perform get operation on a non textfile. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("p_get "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCB_FLAGS&EOFFLAG#0 %THEN ISOERROR(16) %IF FCHECKS#0 %THEN CHECKREAD(FCB) %IF FCB_TYPE=BYTEFILE %THENSTART FCB_BUFFERPTR=FCB_BUFFERPTR+1 %IF FCB_BUFFERPTR=FCB_ENDBUFFER %THEN FILLBUFFER(FCB) %FINISHELSESTART FCB_BUFFERPTR=FCB_BUFFERPTR+FCB_ELEMSIZE %IF FCB_BUFFERPTR=FCB_ENDBUFFER//BYTESTOUNITS %THEN FILLBUFFER(FCB) %FINISH %END; ! GetOp !* %EXTERNALROUTINE GETOPT %ALIAS "p_gett"(%INTEGER FCBPTR) !*********************************************************************** !* Perform get operation on a textfile. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("p_gett "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCB_FLAGS&EOFFLAG#0 %THEN ISOERROR(16) %IF FCHECKS#0 %THEN CHECKREAD(FCB) %IF FCB_FLAGS&LAZYFLAG=0 %THEN ACTUALGET(FCB) %ELSE FCB_FLAGS=FCB_FLAGS!!LAZYFLAG %END; ! GetOpt !* %EXTERNALROUTINE PUTOP %ALIAS "p_put"(%INTEGER FCBPTR) !*********************************************************************** !* Perform put operation on the file. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("p_put "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKWRITE(FCB) %IF FCB_TYPE=BYTEFILE %THENSTART FCB_BUFFERPTR=FCB_BUFFERPTR+1 %IF FCB_BUFFERPTR=FCB_ENDBUFFER %THEN FLUSHBUFFER(FCB) %FINISHELSESTART FCB_BUFFERPTR=FCB_BUFFERPTR+FCB_ELEMSIZE %IF FCB_BUFFERPTR=FCB_ENDBUFFER//BYTESTOUNITS %THEN FLUSHBUFFER(FCB) %FINISH %END; ! PutOp !* %EXTERNALROUTINE PUTOPT %ALIAS "p_putt"(%INTEGER FCBPTR) !*********************************************************************** !* Perform put operation on a textfile. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("p_putt "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKWRITE(FCB) FCB_BUFFERPTR=FCB_BUFFERPTR+1 %IF FCB_BUFFERPTR=FCB_ENDBUFFER %THEN FLUSHBUFFER(FCB) %END; ! PutOpt !* %EXTERNALINTEGERFN EOFOP %ALIAS "p_eof"(%INTEGER FCBPTR) !*********************************************************************** !* Test end-of-file. Return 1 if true, 0 if false. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("p_eof "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCB_MODE=UNDEFINED %THEN ISOERROR(40) %IF FCB_FLAGS&EOFFLAG#0 %THENRESULT=TRUE %ELSERESULT=FALSE %END; ! EofOp !* %EXTERNALINTEGERFN EOFOPT %ALIAS "p_eoft"(%INTEGER FCBPTR) !*********************************************************************** !* Test end-of-file for a textfile. Return 1 if true, 0 if false. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("p_eof "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCB_MODE=UNDEFINED %THEN ISOERROR(40) %IF FCB_FLAGS&LAZYFLAG=0 %THENSTART ACTUALGET(FCB); FCB_FLAGS=FCB_FLAGS!LAZYFLAG %FINISH %IF FCB_FLAGS&EOFFLAG#0 %THENRESULT=TRUE %ELSERESULT=FALSE %END; ! EofOpt !* %EXTERNALINTEGERFN EOLOP %ALIAS "p_eol"(%INTEGER FCBPTR) !*********************************************************************** !* Test end-of-line. Return 1 if true, 0 if false. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("p_eol "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCB_MODE=UNDEFINED %THEN ISOERROR(41) %IF FCB_FLAGS&LAZYFLAG=0 %THENSTART ACTUALGET(FCB); FCB_FLAGS=FCB_FLAGS!LAZYFLAG %FINISH %IF FCB_FLAGS&EOFFLAG#0 %THEN ISOERROR(42) %IF FCB_FLAGS&EOLFLAG#0 %THENRESULT=TRUE %ELSERESULT=FALSE %END; ! EolOp !* !* !*********************************************************************** !*********************************************************************** !* The following procedures provide high-level standard input functions* !* for Pascal. * !*********************************************************************** !*********************************************************************** !* !* %EXTERNALINTEGERFN READINT %ALIAS "p_readi"(%INTEGER FCBPTR) !*********************************************************************** !* Read an integer value from the file denoted by the FCB. Return the * !* value read as the function result. Values which would cause overflow* !* are trapped with error ?? * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %BYTEINTEGERARRAY DIGITS(1:256) %INTEGER NEGATIVE,VALUE,PLACES,CH,D,I %IF REPORT#0 %THENSTART PRINTSTRING("p_readi "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKREAD(FCB) %IF FCB_FLAGS&LAZYFLAG=0 %THENSTART ACTUALGET(FCB); FCB_FLAGS=FCB_FLAGS!LAZYFLAG %FINISH %WHILE BYTEINTEGER(FCB_BUFFERPTR)<=SP %AND FCB_FLAGS&EOFFLAG=0 %CYCLE ACTUALGET(FCB) %REPEAT %IF FCB_FLAGS&EOFFLAG#0 %THEN ISOERROR(54) CH=BYTEINTEGER(FCB_BUFFERPTR) %IF CH='+' %OR CH='-' %THENSTART %IF CH='-' %THEN NEGATIVE=TRUE ACTUALGET(FCB) %FINISHELSE NEGATIVE=FALSE ISOERROR(54) %UNLESS '0'<=BYTEINTEGER(FCB_BUFFERPTR)<='9' ACTUALGET(FCB) %WHILE BYTEINTEGER(FCB_BUFFERPTR)='0' VALUE=0; PLACES=0; CH=BYTEINTEGER(FCB_BUFFERPTR) %IF '1'<=CH<='9' %THENSTART %WHILE '0'<=CH<='9' %CYCLE PLACES=PLACES+1 DIGITS(PLACES)=CH-'0' ACTUALGET(FCB) CH=BYTEINTEGER(FCB_BUFFERPTR) %REPEAT %IF PLACES>10 %THEN SYSTEMERROR(17) %FOR I=1,1,PLACES %CYCLE D=DIGITS(I) %IF I=10 %THENSTART %IF VALUE>MAXINTDIV10 %OR (VALUE=MAXINTDIV10 %AND D>MAXINTMOD10) %THEN %C SYSTEMERROR(17) %FINISH VALUE=VALUE*10+D %REPEAT %FINISH %IF NEGATIVE=TRUE %THEN VALUE=-VALUE %RESULT=VALUE %END; ! ReadInt !* %EXTERNALLONGREALFN READRL %ALIAS "p_readr"(%INTEGER FCBPTR) !*********************************************************************** !* Read a real value from the file denoted by FCB. Real evaluation is * !* performed to maximum accuracy using double-precision arithmetic. It * !* is the Pascal compiler's respnsibility to truncate the result if * !* required. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %INTEGER NEGATIVE,CHPTR,CH,I %LONGLONGREAL RWORK,SCALE %LONGREAL VALUE !* %ROUTINE COPYCH BYTEINTEGER(CHPTR)=CH CHPTR=CHPTR+1 ACTUALGET(FCB) CH=BYTEINTEGER(FCB_BUFFERPTR) %END !* %IF REPORT#0 %THENSTART PRINTSTRING("p_readrl "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKREAD(FCB) %IF FCB_FLAGS&LAZYFLAG=0 %THENSTART ACTUALGET(FCB); FCB_FLAGS=FCB_FLAGS!LAZYFLAG %FINISH %WHILE BYTEINTEGER(FCB_BUFFERPTR)<=SP %AND FCB_FLAGS&EOFFLAG=0 %CYCLE ACTUALGET(FCB) %REPEAT %IF FCB_FLAGS&EOFFLAG#0 %THEN ISOERROR(56) CH=BYTEINTEGER(FCB_BUFFERPTR) %IF CH='+' %OR CH='-' %THENSTART %IF CH='-' %THEN NEGATIVE=TRUE ACTUALGET(FCB) %FINISHELSE NEGATIVE=FALSE ISOERROR(56) %UNLESS '0'<=BYTEINTEGER(FCB_BUFFERPTR)<='9' ACTUALGET(FCB) %WHILE BYTEINTEGER(FCB_BUFFERPTR)='0' RWORK=0.0; CH=BYTEINTEGER(FCB_BUFFERPTR) %IF '1'<=CH<='9' %THENSTART RWORK=CH-'0' %CYCLE ACTUALGET(FCB) CH=BYTEINTEGER(FCB_BUFFERPTR) %EXITUNLESS '0'<=CH<='9' RWORK=10.0*RWORK+(CH-'0') %REPEAT %IF CH='.' %THENSTART SCALE=10.0 %CYCLE ACTUALGET(FCB) CH=BYTEINTEGER(FCB_BUFFERPTR) %EXITUNLESS '0'<=CH<='9' RWORK=RWORK+(CH-'0')/SCALE SCALE=10.0*SCALE %REPEAT %FINISH %IF CH='e' %OR CH='E' %THENSTART ACTUAL GET(FCB) I=READINT(FCBPTR) RWORK=RWORK*d'10.0'**I %FINISH %FINISH %IF NEGATIVE=TRUE %THEN RWORK=-RWORK %RESULT=RWORK %END; ! ReadRl !* %EXTERNALROUTINE READLN %ALIAS "p_rdln"(%INTEGER FCBPTR) !*********************************************************************** !* Perform standard function 'readln'. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("p_readrl "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKREAD(FCB) %IF FCB_FLAGS&LAZYFLAG=0 %THENSTART ACTUALGET(FCB); FCB_FLAGS=FCB_FLAGS!LAZYFLAG %FINISH ACTUALGET(FCB) %WHILE FCB_FLAGS&EOLFLAG=0 %AND FCB_FLAGS&EOFFLAG=0 %IF FCB_FLAGS&EOFFLAG#0 %THEN ISOERROR(16) FCB_FLAGS=FCB_FLAGS!!LAZYFLAG %END; ! ReadLn !* !* !*********************************************************************** !*********************************************************************** !* The following procedures provide high-level standard output * !* functions for Pascal. * !*********************************************************************** !*********************************************************************** !* %CONSTLONGREAL PMAX= 1@16 %CONSTLONGREAL DZ= 0 %STRING (15) %FNSPEC SWRITE(%INTEGER VALUE,PLACES) %STRING (15) %FN SWRITE(%INTEGER VALUE,PLACES) !*********************************************************************** !* SIMPLE MINDED ALL IMP VERSION * !*********************************************************************** %STRING (1) SIGN %STRING (15) RES %INTEGER WORK,PTR %STRING (1) %ARRAY CH(0:15) RES="" SIGN=" " %IF VALUE=X'80000000' %THENSTART RES="_2147483548" RES=" ".RES %FOR PTR=1,1,PLACES-10 %RESULT=RES %FINISH %IF VALUE=X'80000000' %THENRESULT="-2147483648" %IF VALUE<0 %THEN SIGN="-" %AND VALUE=-VALUE PTR=0 %CYCLE WORK=VALUE//10 CH(PTR)=TOSTRING(VALUE-10*WORK+'0') VALUE=WORK PTR=PTR+1 %REPEATUNTIL VALUE=0 RES=RES." " %FOR WORK=PTR,1,PLACES-1 WORK=PTR-1 RES=RES.SIGN RES=RES.CH(PTR) %FOR PTR=WORK,-1,0 %RESULT=RES %END %STRING (63) %FNSPEC SPRINTFL(%LONGREAL X, %INTEGER N) %STRING (63) %FN SPRINT(%LONGREAL X, %INTEGER N,M) !*********************************************************************** !* PRINTS A REAL NUMBER (X) ALLOWING N PLACES BEFORE THE DECIMAL * !* POINT AND M PLACES AFTER.IT REQUIRES (M+N+2) PRINT PLACES * !* UNLESS (M=0) WHEN (N+1) PLACES ARE REQUIRED. * !* * !* A LITTLE CARE IS NEEDED TO AVOID UNNECESSARY LOSS OF ACCURACY * !* AND TO AVOID OVERFLOW WHEN DEALING WITH VERY LARGE NUMBERS * !*********************************************************************** %LONGLONGREAL Y,Z,ROUND,FACTOR %STRING (63) RESULT %INTEGER I,J,L %BYTEINTEGER SIGN RESULT="" M=M&63; ! DEAL WITH STUPID PARAMS %IF N<0 %THEN N=1; N=N&31; ! DEAL WITH STUPID PARAMS X=X+DZ; ! NORMALISE SIGN=' '; ! '+' IMPLIED %IF X<0 %THEN SIGN='-' Y=MOD(X); ! ALL WORK DONE WITH Y ROUND=0.5/10**M; ! ROUNDING FACTOR %IF Y>PMAX %OR N=0 %THENSTART; ! MEANINGLESS FIGURES GENERATED %IF N>M %THEN M=N; ! FOR FIXED POINT PRINTING %RESULT=SPRINT FL(X,M); ! OF ENORMOUS NUMBERS %FINISH I=0; Z=1; Y=Y+ROUND %UNTIL Z>Y %CYCLE; ! COUNT LEADING PLACES I=I+1; Z=10*Z; ! NO DANGER OF OVERFLOW HERE %REPEAT RESULT=RESULT." " %FOR J=1,1,N-I; ! O.K FOR ZERO OR -VE SPACES RESULT=RESULT.TOSTRING(SIGN) J=I-1; Z=10**J FACTOR=1/10 %CYCLE %UNTIL J<0 %CYCLE L=INT PT(Y/Z); ! OBTAIN NEXT DIGIT Y=Y-L*Z; Z=Z*FACTOR; ! AND REDUCE TOTAL RESULT=RESULT.TOSTRING(L+'0') J=J-1 %REPEAT %IF M=0 %THENRESULT=RESULT; ! NO DECIMAL PART TO BE O/P RESULT=RESULT."." J=M-1; Z=10**(J-1); M=0 Y=10*Y*Z %REPEAT %RESULT=RESULT %END; ! OF ROUTINE PRINT %STRING (63) %FN SPRINTFL(%LONGREAL XIN, %INTEGER N) !*********************************************************************** !* PRINTS IN FLOATING POINT FORMAT WITH N PLACES AFTER THE * !* DECIMAL POINT. ALWAYS TAKES N+7 PRINTING POSITIONS. * !* CARE REQUIRED TO AVOID OVERFLOW WITH LARGE X * !*********************************************************************** %LONGLONGREAL SIGN,ROUND,FACTOR,LB,UB,X %STRING (63) RESULT %INTEGER COUNT,INC,ESIGN,J,K X=XIN ROUND=0.5/10**N; ! TO ROUND SCALED NO LB=1-ROUND; UB=10-ROUND SIGN=1 X=X+DZ; ! NORMALISE %IF X=0 %THEN COUNT=-99 %ELSESTART %IF X<0 %THEN X=-X %AND SIGN=-SIGN INC=1; COUNT=0 FACTOR=1/10 %IF X<=1 %THEN FACTOR=10 %AND INC=-1 ! FORCE INTO RANGE 1->10 %WHILE X=UB %CYCLE X=X*FACTOR; COUNT=COUNT+INC %REPEAT %FINISH RESULT=SPRINT(SIGN*X,1,N)."E" ESIGN='+' %IF COUNT<0 %THEN ESIGN='-' %AND COUNT=-COUNT J=COUNT//10 K=COUNT-10*J RESULT=RESULT.TOSTRING(ESIGN).TOSTRING(J+'0').TOSTRING(K+'0') %RESULT=RESULT %END; ! OF ROUTINE PRINTFL !* %EXTERNALROUTINE WRITEINT %ALIAS "p_wri"(%INTEGER FCBPTR,VALUE,WIDTH) !*********************************************************************** !* Write an integer Value within the given field Width on the file FCB * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %INTEGER PLACES,TENS,NEGATIVE,I %INTEGERARRAY DIGITS(1:15) %IF REPORT#0 %THENSTART PRINTSTRING("p_wrc "); PHEX(FCBPTR); WRITE(VALUE,4); WRITE(WIDTH,4); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKWRITE(FCB) %IF WIDTH>MAXWIDTH %THEN SYSTEMERROR(16) %IF VALUE<0 %THENSTART VALUE=-VALUE; NEGATIVE=TRUE %FINISHELSE NEGATIVE=FALSE PLACES=0 %CYCLE TENS=VALUE//10 PLACES=PLACES+1 DIGITS(PLACES)=VALUE-10*TENS+'0' VALUE=TENS %REPEATUNTIL VALUE=0 %IF NEGATIVE=TRUE %THENSTART PLACES=PLACES+1; DIGITS(PLACES)='-' %FINISH %IF WIDTH>PLACES %THEN PADFIELD(FCB,WIDTH-PLACES) PUTCH(FCB,DIGITS(I)) %FOR I=PLACES,-1,1 %END; ! WriteInt !* %EXTERNALROUTINE WRITECH %ALIAS "p_wrc"(%INTEGER FCBPTR,VALUE,WIDTH) !*********************************************************************** !* Write a character Value within the given field Width on the file FCB* !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("p_wrc "); PHEX(FCBPTR); WRITE(VALUE,4); WRITE(WIDTH,4); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKWRITE(FCB) %IF WIDTH>MAXWIDTH %THEN SYSTEMERROR(16) %IF WIDTH>1 %THEN PADFIELD(FCB,WIDTH-1) %IF 0<=VALUE<=255 %THENSTART PUTCH(FCB,VALUE) %RETURN %FINISH ISOERROR(18) %END; ! WriteCh !* %EXTERNALROUTINE WRITEBOOL %ALIAS "p_wrb"(%INTEGER FCBPTR,VALUE,WIDTH) !*********************************************************************** !* Write a Boolean Value within the given field Width on the file FCB * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %INTEGER I %IF REPORT#0 %THENSTART PRINTSTRING("p_wrb "); PHEX(FCBPTR); WRITE(VALUE,4); WRITE(WIDTH,4); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKWRITE(FCB) %IF WIDTH>MAXWIDTH %THEN SYSTEMERROR(16) %IF VALUE=FALSE %THENSTART %IF WIDTH>5 %THEN PADFIELD(FCB,WIDTH-5) %AND WIDTH=5 PUTCH(FCB,FALSESTR(I)) %FOR I=1,1,WIDTH %RETURN %FINISH %IF VALUE=TRUE %THENSTART %IF WIDTH>4 %THEN PADFIELD(FCB,WIDTH-4) %AND WIDTH=4 PUTCH(FCB,TRUESTR(I)) %FOR I=1,1,WIDTH %RETURN %FINISH ISOERROR(18) %END; ! WriteBool !* %EXTERNALROUTINE WRITEWORD %ALIAS "p_wrw"(%INTEGER FCBPTR,VALUE,BASE,WIDTH) !*********************************************************************** !* Write a word Value using the given Base and the given Field width. * !*********************************************************************** %CONSTINTEGERARRAY BASEWIDTH(2:16)= %C 32, 21, 16, 14, 13, 12, 11, 11, 10, 10, 9, 9, 9, 9, 8 %RECORD (CTLBLOCK) %NAME FCB %INTEGER PLACES,NUMWIDTH,UNITS,DIGIT,I %INTEGERARRAY DIGITS(1:32) %IF REPORT#0 %THENSTART PRINTSTRING("p_wrw "); PHEX(FCBPTR); WRITE(VALUE,4); WRITE(BASE,4); WRITE(WIDTH,4) NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKWRITE(FCB) %IF WIDTH>MAXWIDTH %THEN SYSTEMERROR(16) %IF BASE<2 %OR BASE>16 %THEN EPCERROR(18) %IF WIDTH=0 %THEN WIDTH=BASEWIDTH(BASE) NUMWIDTH=BASEWIDTH(BASE); PLACES=0 %CYCLE PLACES=PLACES+1 *sr_0,0; *l_1,value; ! dont sign extend *d_0,base; *st_0,digit; *st_1,units %IF DIGIT>=10 %THEN DIGITS(PLACES)=DIGIT-10+'A' %ELSE DIGITS(PLACES)=DIGIT+'0' VALUE=UNITS %REPEATUNTIL VALUE=0 %WHILE PLACESPLACES %THEN PADFIELD(FCB,WIDTH-PLACES) PUTCH(FCB,DIGITS(I)) %FOR I=PLACES,-1,1 %END; ! WriteWord !* %EXTERNALROUTINE WRITESTR %ALIAS "p_wrst"(%INTEGER FCBPTR,STRINGPTR,LENGTH,WIDTH) !*********************************************************************** !* Write Length characters of the string referenced by StringPtr within* !* the field Width on file FCB. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %INTEGER BYTEADDR,I %IF REPORT#0 %THENSTART PRINTSTRING("p_wstr "); PHEX(FCBPTR); SPACE; PHEX(STRINGPTR); WRITE(LENGTH,4); WRITE(WIDTH,4) NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKWRITE(FCB) %IF WIDTH>MAXWIDTH %THEN SYSTEMERROR(16) BYTEADDR=STRINGPTR*UNITSTOBYTES %IF WIDTH>LENGTH %THEN PADFIELD(FCB,WIDTH-LENGTH) %ELSE LENGTH=WIDTH %FOR I=1,1,LENGTH %CYCLE PUTCH(FCB,BYTEINTEGER(BYTEADDR)) BYTEADDR=BYTEADDR+1 %REPEAT %END; ! WriteStr !* %EXTERNALROUTINE WRITEFXRL %ALIAS "p_wrfx"(%INTEGER FCBPTR, %LONGREAL VALUE, %INTEGER TOTALWIDTH,FRACDIGITS) !*********************************************************************** !* Write the real Value in fixed-point format allowing FracDigits after* !* the decimal point within a total field of Width. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %INTEGER ACTWIDTH,STRINGPTR,I %STRING (63) S %IF REPORT#0 %THENSTART PRINTSTRING("p_wrfx "); PHEX(FCBPTR); WRITE(TOTALWIDTH,4); WRITE(FRACDIGITS,4); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKWRITE(FCB) S=SPRINT(VALUE,TOTALWIDTH-FRACDIGITS-4,FRACDIGITS) STRINGPTR=ADDR(S)+1 ACTWIDTH=LENGTH(S) %FOR I=1,1,ACTWIDTH %CYCLE PUTCH(FCB,BYTEINTEGER(STRINGPTR)) STRINGPTR=STRINGPTR+1 %REPEAT %END; ! WriteFxRl !* %EXTERNALROUTINE WRITEFLRL %ALIAS "p_wrfl"(%INTEGER FCBPTR, %LONGREAL VALUE, %INTEGER TOTALWIDTH) !*********************************************************************** !* Write the real Value in floating-point format with field Width on * !* the FCB. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %INTEGER ACTWIDTH,PRECISION,CTLPTR,STRINGPTR,ENDOFSTRING,CH,I %STRING (63) S %IF REPORT#0 %THENSTART PRINTSTRING("p_wrfl "); PHEX(FCBPTR); WRITE(TOTALWIDTH,4); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKWRITE(FCB) %IF TOTALWIDTH>=EXPDIGITS+5 %THEN ACTWIDTH=TOTALWIDTH %ELSE ACTWIDTH=EXPDIGITS+5 PRECISION=ACTWIDTH-EXPDIGITS-4 S=SPRINTFL(VALUE,PRECISION-1) STRINGPTR=ADDR(S)+1 ACTWIDTH=LENGTH(S) %FOR I=1,1,ACTWIDTH %CYCLE PUTCH(FCB,BYTEINTEGER(STRINGPTR)) STRINGPTR=STRINGPTR+1 %REPEAT %END; ! WriteFlRl !* %EXTERNALROUTINE WRITELN %ALIAS "p_wrln"(%INTEGER FCBPTR) !*********************************************************************** !* Perform the standard operation 'writeln' on the file FCB. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("p_wrln "); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKWRITE(FCB) PUTCH(FCB,NL) %IF ISATTY(BEXTEND(FCB_DESCRIPTOR))=TRUE %THEN FLUSHBUFFER(FCB) %END; ! WriteLn !* %EXTERNALROUTINE WRITELINES %ALIAS "p_lines"(%INTEGER FCBPTR,COUNT) !*********************************************************************** !* Perform the operation 'lines' on the file FCB. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %INTEGER I %IF REPORT#0 %THENSTART PRINTSTRING("p_lines"); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKWRITE(FCB) %IF COUNT>=1 %THENSTART PUTCH(FCB,NL) %FOR I=1,1,COUNT %IF ISATTY(BEXTEND(FCB_DESCRIPTOR))=TRUE %THEN FLUSHBUFFER(FCB) %RETURN %FINISH %END; ! WriteLines !* %EXTERNALROUTINE WRITEPAGE %ALIAS "p_page"(%INTEGER FCBPTR) !*********************************************************************** !* Perform the standard operation 'page' on the FCB. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("p_lines"); PHEX(FCBPTR); NEWLINE %FINISH %IF FCBPTR=0 %THEN SYSTEMERROR(6) FCB==RECORD(FCBPTR) %IF FCHECKS#0 %THEN CHECKWRITE(FCB) PUTCH(FCB,FF) %IF ISATTY(BEXTEND(FCB_DESCRIPTOR))=TRUE %THEN FLUSHBUFFER(FCB) %END; ! WritePage !* !* !*********************************************************************** !*********************************************************************** !* The following procedures provide the standard operations 'new' and * !* 'dispose'. Forms 1 and 2 respectively denote the short and long * !* forms of each function. * !*********************************************************************** !*********************************************************************** !* !* %EXTERNALROUTINE NEW0 %ALIAS "p_new0"(%INTEGER PTR,BYTES) !*********************************************************************** !* Perform the operation new(p) when no checks are requested. Ptr is a * !* pointer to the pointer variable, and Bytes is the size of the * !* required dynamic variable. * !*********************************************************************** %INTEGER HPTR %IF TRACE#0 %THENSTART PRINTSTRING("new0("); WRITE(BYTES,3); PRINTSTRING(")") NEWLINE %FINISH ACQUIRE(HPTR,BYTES) INTEGER(PTR)=HPTR %IF TRACE#0 %THENSTART PRINTSTRING("("); WRITE(PTR,4); PRINTSTRING(") := ") WRITE(HPTR,4); NEWLINE %FINISH %END; ! New0 !* %EXTERNALROUTINE NEW1 %ALIAS "p_new1"(%INTEGER PTR,LEVELS,BYTES) !*********************************************************************** !* Perform the operation new(p{,c1,,cn}). Ptr is a pointer to the * !* pointer variable, Levels is the number of case constants cn, and * !* Bytes is the size of the required dynamic variable. * !*********************************************************************** %INTEGER HPTR,HEAPBYTES %IF TRACE#0 %THENSTART PRINTSTRING("new1("); WRITE(BYTES,3) PRINTSTRING(","); WRITE(LEVELS,2) PRINTSTRING(")") NEWLINE %FINISH HEAPBYTES=BYTES %IF HCHECKS#0 %THEN HEAPBYTES=HEAPBYTES+8 ACQUIRE(HPTR,HEAPBYTES) %IF UCHECKS#0 %THEN PRESET(HPTR,HEAPBYTES) %IF HCHECKS#0 %THENSTART INTEGER(HPTR)=BYTES INTEGER(HPTR+LEVELOFFSET)=LEVELS HPTR=HPTR+4*WORDSTOUNITS %FINISH INTEGER(PTR)=HPTR %IF TRACE#0 %THENSTART PRINTSTRING("("); WRITE(PTR,4); PRINTSTRING(") := ") WRITE(HPTR,4); NEWLINE %FINISH %END; ! New2 !* %EXTERNALROUTINE NEW2 %ALIAS "p_new2"(%INTEGER PTR,BYTES) !*********************************************************************** !* Perform the operation new(p) when no checks are requested. Ptr is a * !* pointer to the pointer variable, and Bytes is the size of the * !* required dynamic variable. In this case, Ptr references a byte * !* pointer. * !*********************************************************************** %INTEGER HPTR %IF TRACE#0 %THENSTART PRINTSTRING("new2("); WRITE(BYTES,3); PRINTSTRING(")") NEWLINE %FINISH ACQUIRE(HPTR,BYTES) INTEGER(PTR)=HPTR*UNITSTOBYTES %IF TRACE#0 %THENSTART PRINTSTRING("("); WRITE(PTR,4); PRINTSTRING(") := ") WRITE(HPTR,4); NEWLINE %FINISH %END; ! New2 !* %EXTERNALROUTINE NEW3 %ALIAS "p_new3"(%INTEGER PTR,BYTES) !*********************************************************************** !* Perform the operation new(p). Ptr is a pointer to the pointer * !* variable, and Bytes is the size of the required dynamic variable. * !* Return a byte pointer in this case. * !*********************************************************************** %INTEGER HPTR,HEAPBYTES %IF TRACE#0 %THENSTART PRINTSTRING("new3("); WRITE(BYTES,3); PRINTSTRING(")") NEWLINE %FINISH HEAPBYTES=BYTES %IF HCHECKS#0 %THEN HEAPBYTES=HEAPBYTES+8 ACQUIRE(HPTR,HEAPBYTES) %IF UCHECKS#0 %THEN PRESET(HPTR,HEAPBYTES) %IF HCHECKS#0 %THENSTART INTEGER(HPTR)=BYTES INTEGER(HPTR+LEVELOFFSET)=0 HPTR=HPTR+4*WORDSTOUNITS %FINISH INTEGER(PTR)=HPTR*UNITSTOBYTES %END; ! New3 !* %EXTERNALROUTINE DISPOSE0 %ALIAS "p_disp0"(%INTEGER PTR,BYTES) !*********************************************************************** !* Perform the operation dispose(p) when no checks are required. Ptr * !* is a pointer to the pointer variable, and Bytes is the size of the * !* associated dynamic variable. * !*********************************************************************** %INTEGER HPTR %IF TRACE#0 %THENSTART PRINTSTRING("dispose0("); WRITE(INTEGER(PTR),4); PRINTSTRING(",") WRITE(BYTES,3); PRINTSTRING(")") NEWLINE %FINISH HPTR=INTEGER(PTR) RELEASE(HPTR,BYTES) %END; ! Dispose0 !* %EXTERNALROUTINE DISPOSE1 %ALIAS "p_disp1"(%INTEGER PTR,LEVELS,BYTES) !*********************************************************************** !* Perform the operation dispose(p[,c1,,cn]). Ptr is a pointer to the * !* pointer variable, Levels is the number of case-constant cn, and * !* Bytes is the size of the associated dysnamic variable to be * !* destroyed. * !*********************************************************************** %INTEGER HPTR,HEAPBYTES %INTEGERNAME NEWLEVEL %IF TRACE#0 %THENSTART PRINTSTRING("dispose1("); WRITE(INTEGER(PTR),4); PRINTSTRING(",") WRITE(BYTES,3); PRINTSTRING(",") WRITE(LEVELS,2); PRINTSTRING(")") NEWLINE %FINISH HEAPBYTES=BYTES HPTR=INTEGER(PTR) %IF HCHECKS#0 %THENSTART %IF HPTR=NIL %THEN ISOERROR(23) HPTR=HPTR-4*WORDSTOUNITS %IF INTEGER(HPTR)#BYTES %THEN SYSTEMERROR(3) NEWLEVEL==INTEGER(HPTR+LEVELOFFSET) %IF LEVELS=0 %THENSTART %IF NEWLEVEL#0 %THEN ISOERROR(20) %FINISHELSESTART %IF NEWLEVEL#0 %AND NEWLEVEL#LEVELS %THEN ISOERROR(21) %FINISH HEAPBYTES=HEAPBYTES+8 %FINISH RELEASE(HPTR,HEAPBYTES) %IF UCHECKS#0 %THEN PRESET(PTR,MCBYTESPERWORD) %END; ! Dispose1 !* %EXTERNALROUTINE DISPOSE2 %ALIAS "p_disp2"(%INTEGER PTR,BYTES) !*********************************************************************** !* Perform the operation dispose(p) when no checks are required. Ptr * !* is a pointer to the pointer variable, and Bytes is the size of the * !* associated dynamic variable. In this case Ptr references a byte * !* pointer. * !*********************************************************************** %INTEGER HPTR %IF TRACE#0 %THENSTART PRINTSTRING("dispose2("); WRITE(INTEGER(PTR),4); PRINTSTRING(",") WRITE(BYTES,3); PRINTSTRING(")") NEWLINE %FINISH HPTR=INTEGER(PTR)//BYTESTOUNITS RELEASE(HPTR,BYTES) %END; ! Dispose2 !* %EXTERNALROUTINE DISPOSE3 %ALIAS "p_disp3"(%INTEGER PTR,BYTES) !*********************************************************************** !* Perform the operation dispose(p). Ptr is a pointer to the pointer * !* variable, and Bytes is the size of the associated dynamic variable * !* to be destroyed. In this case Ptr references a byte-pointer. * !*********************************************************************** %INTEGER HPTR,HEAPBYTES %IF TRACE#0 %THENSTART PRINTSTRING("dispose3("); WRITE(INTEGER(PTR),4); PRINTSTRING(",") WRITE(BYTES,3); PRINTSTRING(")") NEWLINE %FINISH HEAPBYTES=BYTES HPTR=INTEGER(PTR)//BYTESTOUNITS %IF HCHECKS#0 %THENSTART %IF HPTR=NIL %THEN ISOERROR(23) HPTR=HPTR-4*WORDSTOUNITS %IF INTEGER(HPTR)#BYTES %THEN SYSTEMERROR(3) %IF INTEGER(HPTR+LEVELOFFSET)#0 %THEN ISOERROR(20) HEAPBYTES=HEAPBYTES+8 %FINISH RELEASE(HPTR,HEAPBYTES) %IF UCHECKS#0 %THEN PRESET(PTR,MCBYTESPERWORD) %END; ! Dispose3 !* !* !*********************************************************************** !*********************************************************************** !* The following procedures provide the transfer functions 'pack' and * !* 'unpack'. * !*********************************************************************** !*********************************************************************** !* !* %EXTERNALROUTINE PACK %ALIAS "p_pack"(%INTEGER UPPTR,PKPTR,UPSIZE,ELSPERWORD,PKELEMENTS) !*********************************************************************** !* * !* Perform the standard operation 'pack'. Parameters are:- * !* * !* UpPtr - Pointer to the unpacked array. * !* * !* PkPtr - Pointer to the packed array. * !* * !* UpSize - Byte size of an element of the unpacked array. * !* * !* ElsPerWord - Number of elements per machine-word for the packed * !* array. * !* * !* PkElements - Number of elements of the packed array to pack. * !* * !*********************************************************************** %INTEGER BYTES,BITOFFSET,FIELDWIDTH,FIELDMASK,BITMASK %INTEGER PKVALUE,UPVALUE,I %IF REPORT#0 %THENSTART PRINTSTRING("p_pack"); SPACE; PHEX(UPPTR); SPACE; PHEX(PKPTR); SPACE; WRITE(UPSIZE,4); WRITE(ELSPERWORD,4); WRITE(PKELEMENTS,4) %FINISH UPPTR=UPPTR*UNITSTOBYTES %IF ELSPERWORD<2 %THENSTART PKPTR=PKPTR*UNITSTOBYTES BYTES=UPSIZE*PKELEMENTS MOVE(BYTES,UPPTR,PKPTR) %FINISHELSESTART SYSTEMERROR(18) %UNLESS UPSIZE=1 %OR UPSIZE=4 BITOFFSET=0; FIELDWIDTH=32//ELSPERWORD FIELDMASK=MASK(FIELDWIDTH-1); BITMASK=FIELDMASK PKVALUE=INTEGER(PKPTR) %FOR I=1,1,PKELEMENTS %CYCLE %IF UPSIZE=1 %THEN UPVALUE=BYTEINTEGER(UPPTR) %ELSE %C UPVALUE=INTEGER(UPPTR//BYTESTOUNITS) PKVALUE=(PKVALUE&(~BITMASK))!(UPVALUE<=32 %THENSTART INTEGER(PKPTR)=PKVALUE PKPTR=PKPTR+2*WORDSTOUNITS PKVALUE=INTEGER(PKPTR) BITMASK=FIELDMASK BITOFFSET=0 %FINISH UPPTR=UPPTR+UPSIZE %REPEAT INTEGER(PKPTR)=PKVALUE %FINISH %END; ! Pack !* %EXTERNALROUTINE UNPACK %ALIAS "p_unpack"(%INTEGER UPPTR,PKPTR,UPSIZE,ELSPERWORD,PKELEMENTS) !*********************************************************************** !* * !* Perform the standard operation 'unpack'. Parameters are:- * !* * !* UpPtr - Pointer to the unpacked array. * !* * !* PkPtr - Pointer to the packed array. * !* * !* UpSize - Byte size of an element of the unpacked array. * !* * !* ElsPerWord - Number of elements per machine-word for the packed * !* array. * !* * !* PkElements - Number of elements of the packed array to unpack. * !* * !*********************************************************************** %INTEGER BYTES,BITOFFSET,FIELDWIDTH,FIELDMASK %INTEGER PKVALUE,UPVALUE,I %IF REPORT#0 %THENSTART PRINTSTRING("p_pack"); SPACE; PHEX(UPPTR); SPACE; PHEX(PKPTR); SPACE; WRITE(UPSIZE,4); WRITE(ELSPERWORD,4); WRITE(PKELEMENTS,4) %FINISH UPPTR=UPPTR*UNITSTOBYTES %IF ELSPERWORD<2 %THENSTART PKPTR=PKPTR*UNITSTOBYTES BYTES=UPSIZE*PKELEMENTS MOVE(BYTES,PKPTR,UPPTR) %FINISHELSESTART SYSTEMERROR(19) %UNLESS UPSIZE=1 %OR UPSIZE=4 BITOFFSET=0; FIELDWIDTH=32//ELSPERWORD FIELDMASK=MASK(FIELDWIDTH-1) PKVALUE=INTEGER(PKPTR) %FOR I=1,1,PKELEMENTS %CYCLE UPVALUE=(PKVALUE>>BITOFFSET)&FIELDMASK %IF UPSIZE=1 %THEN BYTEINTEGER(UPPTR)=UPVALUE %ELSE %C INTEGER(UPPTR//BYTESTOUNITS)=UPVALUE BITOFFSET=BITOFFSET+FIELDWIDTH %IF BITOFFSET>=32 %THENSTART PKPTR=PKPTR+2*WORDSTOUNITS PKVALUE=INTEGER(PKPTR) BITOFFSET=0 %FINISH UPPTR=UPPTR+UPSIZE %REPEAT %FINISH %END; ! UnPack !* !* !*********************************************************************** !*********************************************************************** !* The following procedures provide set-arithmetic for multi-word sets * !*********************************************************************** !*********************************************************************** !* !* %EXTERNALINTEGERFN SETUNION %ALIAS "p_setu"(%INTEGER LHS,RHS,RESULT,SIZE) !*********************************************************************** !* LHS, RHS, and Result are pointers. Size is Result byte-size. * !*********************************************************************** SIZE=SIZE>>2 %CYCLE SIZE=SIZE-4 INTEGER(RESULT+SIZE)=INTEGER(LHS+SIZE)!INTEGER(RHS+SIZE) %REPEATUNTIL SIZE=0 %RESULT=RESULT %END; ! SetUnion !* %EXTERNALINTEGERFN SETINTERSECTION %ALIAS "p_seti"(%INTEGER LHS,RHS,RESULT,SIZE) !*********************************************************************** !* LHS, RHS, and Result are pointers. Size is Result byte-size. * !*********************************************************************** SIZE=SIZE>>2 %CYCLE SIZE=SIZE-4 INTEGER(RESULT+SIZE)=INTEGER(LHS+SIZE)&INTEGER(RHS+SIZE) %REPEATUNTIL SIZE=0 %RESULT=RESULT %END; ! SetIntersection !* %EXTERNALINTEGERFN SETDIFFERENCE %ALIAS "p_setd"(%INTEGER LHS,RHS,RESULT,SIZE) !*********************************************************************** !* LHS, RHS, and Result are pointers. Size is Result byte-size. * !*********************************************************************** SIZE=SIZE>>2 %CYCLE SIZE=SIZE-4 INTEGER(RESULT+SIZE)=INTEGER(LHS+SIZE)&(~INTEGER(RHS+SIZE)) %REPEATUNTIL SIZE=0 %RESULT=RESULT %END; ! SetDifference !* %EXTERNALINTEGERFN SETEQUAL %ALIAS "p_seteq"(%INTEGER LHS,RHS,SIZE) !*********************************************************************** !* Return 1 if true, 0 otherwise. * !*********************************************************************** SIZE=SIZE>>2 %CYCLE SIZE=SIZE-4 %IF INTEGER(LHS+SIZE)#INTEGER(RHS+SIZE) %THENRESULT=FALSE %REPEATUNTIL SIZE=0 %RESULT=TRUE %END; ! SetEqual !* %EXTERNALINTEGERFN SETUNEQUAL %ALIAS "p_setne"(%INTEGER LHS,RHS,SIZE) !*********************************************************************** !* Return 1 if true, 0 otherwise. * !*********************************************************************** SIZE=SIZE>>2 %CYCLE SIZE=SIZE-4 %IF INTEGER(LHS+SIZE)#INTEGER(RHS+SIZE) %THENRESULT=TRUE %REPEATUNTIL SIZE=0 %RESULT=FALSE %END; ! SetUnEqual !* %EXTERNALINTEGERFN SETLESSOREQUAL %ALIAS "p_setle"(%INTEGER LHS,RHS,SIZE) !*********************************************************************** !* Return 1 if true, 0 otherwise. * !*********************************************************************** %INTEGER RHWORD SIZE=SIZE>>2 %CYCLE SIZE=SIZE-4 RHWORD=INTEGER(RHS+SIZE) %IF INTEGER(LHS+SIZE)!RHWORD#RHWORD %THENRESULT=FALSE %REPEATUNTIL SIZE=0 %RESULT=TRUE %END; ! SetLessOrEqual !* %EXTERNALINTEGERFN SETMEMBER %ALIAS "p_setin"(%INTEGER VALUE,SET) !*********************************************************************** !* Return 1 if Value identifies a member of Set, 0 otherwise. * !*********************************************************************** %INTEGER WORD WORD=INTEGER(SET+(VALUE>>5)<<2) %RESULT=WORD>>(VALUE&31)&1 %END; ! SetMember !* %EXTERNALINTEGERFN SINGLETONSET %ALIAS "p_sets"(%INTEGER VALUE,RESULT,SIZE) !*********************************************************************** !* Construct [Value]. Result is pointer. Size is Result byte-size. * !*********************************************************************** %INTEGER FROM,TO INTEGER(RESULT)=0 %IF SIZE>4 %THENSTART FROM=RESULT FILL(SIZE,FROM,0) %FINISH INTEGER(RESULT+(VALUE>>5)<<2)=1<<(VALUE&31) %RESULT=RESULT %END; ! SingletonSet !* %EXTERNALINTEGERFN RANGESET %ALIAS "p_setr"(%INTEGER LOW,HIGH,RESULT,SIZE) !*********************************************************************** !* Construct [Low..High]. Result is pointer. Size is Result byte-size. * !*********************************************************************** %INTEGER FROM,TO,WORD,WORDADDR,LOWBIT,RANGE INTEGER(RESULT)=0 %IF SIZE>4 %THENSTART FILL(SIZE,RESULT,0) %FINISH %IF LOW>HIGH %THENRESULT=RESULT WORDADDR=RESULT+(LOW>>5)<<2 %CYCLE LOWBIT=LOW&31 RANGE=HIGH-LOW %IF RANGE>31 %THEN WORD=MASK(31) %ELSE WORD=MASK(RANGE) %IF LOWBIT>0 %THEN INTEGER(WORDADDR)=WORD<HIGH %RESULT=RESULT %END; ! RangeSet !* !* !*********************************************************************** !*********************************************************************** !* The following procedures provide the standard maths functions. All * !* functions evaluate their results using double-precision arithmetic. * !*********************************************************************** !*********************************************************************** !* !* %EXTERNALLONGREALFN PSIN %ALIAS "p_sin"(%LONGREAL VALUE) !*********************************************************************** !* Evaluate 'sin'. * !*********************************************************************** %RESULT=SIN(VALUE) %END; ! Sin !* %EXTERNALLONGREALFN PCOS %ALIAS "p_cos"(%LONGREAL VALUE) !*********************************************************************** !* Evaluate 'cos'. * !*********************************************************************** %RESULT=COS(VALUE) %END; ! Cos !* %EXTERNALLONGREALFN PARCTAN %ALIAS "p_arctan"(%LONGREAL VALUE) !*********************************************************************** !* Evaluate 'arctan'. * !*********************************************************************** %RESULT=ARCTAN(VALUE,1.0) %END; ! arctan !* %EXTERNALLONGREALFN PSQRT %ALIAS "p_dsqrt"(%LONGREAL VALUE) !*********************************************************************** !* Evaluate 'sqrt'. * !*********************************************************************** %RESULT=SQRT(VALUE) %END; ! Sqrt !* %EXTERNALLONGREALFN PEXP %ALIAS "p_exp"(%LONGREAL VALUE) !*********************************************************************** !* Evaluate 'exp'. * !*********************************************************************** %RESULT=EXP(VALUE) %END; ! Exp !* %EXTERNALLONGREALFN PLOG %ALIAS "p_log"(%LONGREAL VALUE) !*********************************************************************** !* Evaluate 'log'. * !*********************************************************************** %RESULT=LOG(VALUE) %END; ! Log !* !* !*********************************************************************** !*********************************************************************** !* The following procedures provide additional functions of ICL Pascal * !*********************************************************************** !*********************************************************************** !* !* %EXTERNALINTEGERFN SHIFT %ALIAS "p_shift"(%INTEGER WORD,AMOUNT) !*********************************************************************** !* Perform logical shift of Word by Amount * !*********************************************************************** %INTEGER NEGATIVE %IF REPORT#0 %THENSTART PRINTSTRING("p_shift "); WRITE(WORD,4); WRITE(AMOUNT,4) NEWLINE %FINISH %IF AMOUNT<0 %THENSTART NEGATIVE=TRUE; AMOUNT=-AMOUNT %FINISHELSE NEGATIVE=FALSE %IF AMOUNT>31 %THENRESULT=0 %IF NEGATIVE=FALSE %THENRESULT=WORD<>AMOUNT %END; ! Shift !* %EXTERNALINTEGERFN ROTATE %ALIAS "p_rot"(%INTEGER WORD,AMOUNT) !*********************************************************************** !* Perform left or right rotate of Word by Amount. * !*********************************************************************** %INTEGER NEGATIVE,D %IF REPORT#0 %THENSTART PRINTSTRING("p_rot "); WRITE(WORD,4); WRITE(AMOUNT,4) NEWLINE %FINISH %IF AMOUNT<0 %THENSTART NEGATIVE=TRUE; AMOUNT=-AMOUNT %FINISHELSE NEGATIVE=FALSE D=AMOUNT&31 %IF D=0 %THENRESULT=WORD %IF NEGATIVE=FALSE %THENRESULT=(WORD<>(32-D)) %ELSE %C %RESULT=(WORD>>D)!(WORD<<(32-D)) %END; ! Rotate !* %EXTERNALROUTINE ICLDATE %ALIAS "p_date"(%INTEGER PTR) !*********************************************************************** !* Place the date in the 8-character array referenced by Ptr. * !*********************************************************************** %CONSTSTRING (8) %NAME DATE=x'01f0003b' %INTEGER BYTEPTR BYTEPTR=PTR*UNITSTOBYTES MOVE(8,ADDR(DATE)+1,BYTEPTR) %END; ! Date !* %EXTERNALROUTINE ICLTIME %ALIAS "p_time"(%INTEGER PTR) !*********************************************************************** !* Place the time in the 8-character array referenced by Ptr. * !*********************************************************************** %CONSTSTRING (8) %NAME TIME=x'01f00047' %INTEGER BYTEPTR BYTEPTR=PTR*UNITSTOBYTES MOVE(8,ADDR(TIME)+1,BYTEPTR) %END; ! Time !* !* !*********************************************************************** !*********************************************************************** !* I M P L E M E N T A T I O N - P A R T * !*********************************************************************** !*********************************************************************** !* !* !* !* !*********************************************************************** !*********************************************************************** !* The following procedures provide heap-management and garbage * !* collection for the run-time system. * !*********************************************************************** !*********************************************************************** !* !* %INTEGERFN MALLOC(%INTEGER BYTES) !*********************************************************************** !* This routine mimics malloc on UNIX to return chunks of store * !* for the heap routines. The EMAS method is to use a tempfile ** !* extended in 32 page chunks and using the standard headed to ** !* keep track of the allocations. At present a one seg hole is * !* specified meaning thge heap will normally not go beyond 1 Mb * !*********************************************************************** %INTEGER FLAG,NEWSIZE,J,I %IF HEAPFILENAME="" %START; ! heapfile not yet created HEAPFILENAME="T#PHP".NEXTTEMP OUTFILE(HEAPFILENAME,32*4096,0,x'20000000',HCONAD,FLAG) %IF FLAG#0 %THEN SETRETURNCODE(FLAG) %ANDRESULT=-1 INTEGER(HCONAD+12)=4; ! type=datafile %FINISH ! %IF INTEGER(HCONAD)+BYTES>INTEGER(HCONAD+8) %START; ! needs extending NEWSIZE=INTEGER(HCONAD+8)+32*4096 CHANGEFILESIZE(HEAPFILENAME,NEWSIZE,FLAG) %IF FLAG#0 %THEN SETRETURNCODE(FLAG) %ANDRESULT=-1 INTEGER(HCONAD+8)=NEWSIZE %FINISH ! J=INTEGER(HCONAD) INTEGER(HCONAD)=INTEGER(HCONAD)+BYTES %RESULT=J+HCONAD %END %ROUTINE PRESET(%INTEGER PTR,AMOUNT) !*********************************************************************** !* Preset Amount bytes of memory beginning at Ptr. * !*********************************************************************** %INTEGER FROM,TO %IF AMOUNT<=0 %THENRETURN FILL(AMOUNT,PTR,X'81') %END; ! Preset !* %ROUTINE INITHEAP !*********************************************************************** !* Initialise heap-manager. * !*********************************************************************** BLOCKLIST=NIL HEAPTOP=NIL %END; ! InitHeap !* %ROUTINE CLAIMBLOCK(%INTEGER BYTEAMOUNT, %INTEGERNAME BLOCKPTR) !*********************************************************************** !* Claim a new memory block from system memory-manager. Return its * !* byte address in BlockPtr. The amount allocated will be the maximum * !* of ByteAmount and DefaultBlockSize (16k bytes). * !*********************************************************************** %INTEGER BYTEPTR,ENDOFBLOCK BYTEAMOUNT=BYTEAMOUNT+BLOCKHEADER*UNITSTOBYTES %IF BYTEAMOUNT=AMOUNT %THENSTART NEXTPTR=INTEGER(CURRPTR) SURPLUS=CURRSIZE-AMOUNT %IF SURPLUS>MINHEAPBLOCK %THENSTART SURPLUSPTR=CURRPTR+AMOUNT INTEGER(PREVPTR)=SURPLUSPTR INTEGER(SURPLUSPTR+SIZEOFFSET)=SURPLUS INTEGER(SURPLUSPTR)=NEXTPTR %FINISHELSESTART INTEGER(PREVPTR)=NEXTPTR %FINISH HPTR=CURRPTR %IF TRACE#0 %THENSTART PRINTSTRING("Re-allocated block at "); WRITE(HPTR,4) PRINTSTRING(" HeapTop = "); WRITE(HEAPTOP,4) NEWLINE %FINISH %RETURN %FINISH %REPEAT BLOCKPTR=INTEGER(BLOCKPTR) %REPEAT %IF BLOCKLIST=NIL %THEN CLAIMBLOCK(AMOUNT*UNITSTOBYTES,BLOCKLIST) BLOCKSTART=INTEGER(BLOCKLIST+STARTOFFSET) %IF HEAPTOP-AMOUNTMINHEAPBLOCK %THENSTART INTEGER(BLOCKSTART)=NIL INTEGER(BLOCKSTART+SIZEOFFSET)=SURPLUS INTEGER(PREVPTR)=BLOCKSTART %FINISH EXTENDHEAP(AMOUNT*UNITSTOBYTES) %FINISH HEAPTOP=HEAPTOP-AMOUNT HPTR=HEAPTOP %IF TRACE#0 %THENSTART PRINTSTRING("Allocated new block at "); WRITE(HEAPTOP,4) PRINTSTRING(" HeapTop = "); WRITE(HEAPTOP,4) NEWLINE %FINISH %END; ! Acquire !* %ROUTINE RELEASE(%INTEGER HPTR,AMOUNT) !*********************************************************************** !* Release Amount bytes of heap-space onto the free-list. Perform * !* simple garbage-collection to coalesce adjacent unused areas. * !*********************************************************************** %INTEGER STARTGARBAGE,ENDGARBAGE,CURRPTR,ENDCURRENT,PREVPTR,BLOCKPTR AMOUNT=AMOUNT//BYTESTOUNITS BLOCKPTR=BLOCKLIST %WHILE BLOCKPTR#NIL %CYCLE %IF INTEGER(BLOCKPTR+STARTOFFSET)<=HPTR>2)<<2 %IF BYTES<8 %THEN BYTES=8 ACQUIRE(STRPTR,BYTES) FROM=NAMEPTR*UNITSTOBYTES TO=STRPTR*UNITSTOBYTES NEWLENGTH=0 %FOR ADDR=FROM,1,FROM+LENGTH-1 %CYCLE %IF BYTEINTEGER(ADDR)<=' ' %THENEXIT NEWLENGTH=NEWLENGTH+1 BYTEINTEGER(TO+NEWLENGTH)=BYTEINTEGER(ADDR) %REPEAT BYTEINTEGER(TO)=NEWLENGTH %RESULT=STRPTR %END; ! NewFileName !* %INTEGERFN STDCHECK(%STRING (127) %NAME FILENAME, %INTEGER MODE) !*********************************************************************** !* Check FileName against "stdin", "stdout" and "stderr" and trap * !* attempts to write to the key-board or read from the screen. Return * !* 0, 1, or 2 if access to standard file permitted. Return -1 if name * !* does not identify a standard file. * !*********************************************************************** %IF MODE=READING %THENSTART %IF FILENAME="stdin" %THEN FILENAME=".IN" %IF FILENAME="stdout" %AND ISATTY(STDOUT)=TRUE %THEN SYSTEMERROR(11) %IF FILENAME="stderr" %AND ISATTY(STDERR)=TRUE %THEN SYSTEMERROR(12) %FINISHELSESTART %IF FILENAME="stdout" %THEN FILENAME=".OUT" %IF FILENAME="stderr" %THEN FILENAME=".OUT" %IF FILENAME="stdin" %AND ISATTY(STDIN)=TRUE %THEN SYSTEMERROR(13) %FINISH %RESULT=-1 %END; ! StdCheck !* %INTEGERFN EOPEN(%STRING (255) FILENAME, %INTEGER MODE,TYPE,BYTES) !*********************************************************************** !* emas open which does a define. For textio the open is done * !* on first access. SQ files are opened here. Some method of * !* picking up a user define is desirable * !*********************************************************************** %STRING (255) DATA %INTEGER CH,FLAG,j EMAS3CLAIMCHANNEL(CH) DATA=ITOS(CH).",".FILENAME %IF TYPE&TEXTFILE=0 %START %IF MODE&APPENDING#0 %THEN DATA=DATA."-MOD" DATA=DATA.",,F".ITOS(BYTES) %FINISH EMAS3("define",DATA,FLAG) %if flag=0 %and type&textfile#0 %Start %if mode=reading %and filename#".IN" %then flag=checkname(filename,1,129) %if mode=writing %and charno(filename,1)#'.' %then flag=checkname(filename,1,128+2{char & writeable}) %finish %IF FLAG#0 %THEN SET RETURN CODE(FLAG) %ANDRESULT=-1 %IF TYPE&TEXTFILE=0 %THEN OPENSQ(CH) %RESULT=CH %END %INTEGERFN ECLOSE(%INTEGER CHAN,TYPE) !*********************************************************************** !* emas close avoids closing current input or poutput streams * !*********************************************************************** %IF TYPE&TEXTFILE#0 %START %IF COMREG(22)=CHAN %THEN SELECT INPUT(0) %IF COMREG(23)=CHAN %THEN SELECT OUTPUT(0) %ELSE CLOSESQ(CHAN) %FINISH %RESULT=0 %END !* %ROUTINE GETBUFFER(%RECORD (CTLBLOCK) %NAME FCB, %INTEGER BYTES) !*********************************************************************** !* Get an i/o transfer buffer for the file. Bytes is the element size. * !*********************************************************************** %INTEGER BUFFERPTR,BUFFERSIZE,CAPACITY,TYPE %IF REPORT#0 %THENSTART PRINTSTRING("GetBuffer "); NEWLINE %FINISH TYPE=FCB_TYPE %IF TYPE=TEXTFILE %THENSTART %IF FCB_FLAGS&TERMFLAG#0 %THEN BUFFERSIZE=TERMBUFFER %ELSE BUFFERSIZE=DISCBUFFER %FINISHELSESTART CAPACITY=DISCBUFFER//BYTES %IF CAPACITYMAXHEAPBLOCK %THEN SYSTEMERROR(20) %FINISH ACQUIRE(BUFFERPTR,BUFFERSIZE) BUFFERPTR=BUFFERPTR*UNITSTOBYTES FCB_STARTBUFFER=BUFFERPTR FCB_ENDBUFFER=BUFFERPTR+BUFFERSIZE FCB_BUFFERSIZE=BUFFERSIZE %IF TYPE=DATAFILE %THENSTART FCB_ELEMSIZE=BYTES//BYTESTOUNITS FCB_BUFFERPTR=FCB_STARTBUFFER//BYTESTOUNITS %FINISHELSEIF TYPE=TEXTFILE %OR TYPE=BYTEFILE %THENSTART FCB_ELEMSIZE=1 FCB_BUFFERPTR=FCB_STARTBUFFER %FINISH %END; ! GetBuffer !* %INTEGERFN OPENF(%RECORD (CTLBLOCK) %NAME FCB, %INTEGER TYPE,BYTES,NAMEPTR,MODE) !*********************************************************************** !* Bind the file denoted by FCB to a physical file in the host file * !* store. If the file is to be permanent, NamePtr references the file * !* name. Mode specifies whether the file is to be opened for reading * !* or writing. If binding is successful set the mode flags in FCB and * !* return the value 0. Otherwise return -1. * !*********************************************************************** %STRING (127) FILENAME %INTEGER DESCRIPTOR,FLAGS,STDFILE %IF REPORT#0 %THENSTART PRINTSTRING("Openf "); NEWLINE %FINISH %IF NAMEPTR=NIL %THENSTART %IF READING<=FCB_MODE<=APPENDING %THEN NAMEPTR=FCB_NAMEPTR %ELSE NAMEPTR=NEWTEMPNAME FLAGS=0 %FINISHELSESTART NAMEPTR=NEWFILENAME(NAMEPTR,BYTES&255) FLAGS=PERMFLAG %FINISH FILENAME=STRING(NAMEPTR) FCB_NAMEPTR=NAMEPTR %IF FILENAME="stdout" %THEN STDOUTPTR=ADDR(FCB) %IF FILENAME="stderr" %THEN STDERRPTR=ADDR(FCB) %IF REPORT#0 %THENSTART PRINTSTRING(FILENAME); NEWLINE %FINISH STDFILE=STDCHECK(FILENAME,MODE) DESCRIPTOR=EOPEN(FILENAME,MODE,TYPE,BYTES>>8) %IF DESCRIPTOR=-1 %THENRESULT=-1 %IF ISATTY(DESCRIPTOR)=TRUE %THEN FLAGS=FLAGS!TERMFLAG !frig %IF filename=".IN" %OR filename=".OUT" %THEN flags=flags!termflag ! above line horrible frig till isatty behaves FCB_DESCRIPTOR<-DESCRIPTOR FCB_NAMEPTR=NAMEPTR FCB_MODE=MODE FCB_FLAGS=FLAGS FCB_TYPE=TYPE GETBUFFER(FCB,BYTES>>8) %RESULT=DESCRIPTOR %END; ! Openf !* %ROUTINE FILLBUFFER(%RECORD (CTLBLOCK) %NAME FCB) !*********************************************************************** !* Fill transfer buffer by a block-read. * !*********************************************************************** %INTEGER AMOUNT,CH,I %IF REPORT#0 %THENSTART PRINTSTRING("fillbuffer "); NEWLINE %FINISH %IF FCB_FLAGS&TERMFLAG#0 %THENSTART %IF STDOUTPTR#NIL %THEN FORCEFLUSH(STDOUTPTR) %IF STDERRPTR#NIL %THEN FORCEFLUSH(STDERRPTR) %FINISH CH=BEXTEND(FCB_DESCRIPTOR) %IF FCB_TYPE&TEXTFILE=0 %START READLSQ(CH,BYTEINTEGER(FCB_STARTBUFFER), BYTEINTEGER(FCB_STARTBUFFER+FCB_BUFFERSIZE-1),AMOUNT) I=0 %ELSE SELECTINPUT(CH) AMOUNT=0 %CYCLE READSYMBOL(I) %IF I=25 %THENEXIT BYTEINTEGER(FCB_STARTBUFFER+AMOUNT)=I AMOUNT=AMOUNT+1 %EXITIF I=10 %REPEAT %IF AMOUNT>FCB_BUFFERSIZE %THEN ERROR FCB==FCB %AND SYSTEM ERROR(14) %FINISH FCB_ENDBUFFER=FCB_STARTBUFFER+AMOUNT %IF AMOUNT=0 %OR I=25 %THEN FCB_FLAGS=FCB_FLAGS!EOFFLAG %IF FCB_TYPE=TEXTFILE %OR FCB_TYPE=BYTEFILE %THEN FCB_BUFFERPTR=FCB_STARTBUFFER %ELSE %C FCB_BUFFERPTR=FCB_STARTBUFFER//BYTESTOUNITS %END; ! FillBuffer !* %ROUTINE FLUSHBUFFER(%RECORD (CTLBLOCK) %NAME FCB) !*********************************************************************** !* Flush transfer buffer by a block-write. * !*********************************************************************** %INTEGER AMOUNT,FLAG,CH,I,OCH %IF REPORT#0 %THENSTART PRINTSTRING("FlushBuffer "); NEWLINE %FINISH %IF FCB_TYPE=TEXTFILE %OR FCB_TYPE=BYTEFILE %THEN %C AMOUNT=FCB_BUFFERPTR-FCB_STARTBUFFER %ELSE %C AMOUNT=FCB_BUFFERPTR*UNITSTOBYTES-FCB_STARTBUFFER %IF AMOUNT>0 %THENSTART CH=BEXTEND(FCB_DESCRIPTOR) %IF FCB_TYPE&TEXTFILE=0 %START %WHILE AMOUNT>FCB_ELEMSIZE %CYCLE WRITESQ(CH,BYTEINTEGER(FCB_STARTBUFFER), BYTEINTEGER(FCB_STARTBUFFER+FCB_ELEMSIZE-1)) AMOUNT=AMOUNT-FCB_ELEMSIZE MOVE(AMOUNT,FCB_STARTBUFFER+FCB_ELEMSIZE,FCB_STARTBUFFER) %REPEAT WRITESQ(CH,BYTEINTEGER(FCB_STARTBUFFER),BYTEINTEGER(FCB_STARTBUFFER+AMOUNT-1)) %ELSE OCH=COMREG(23) SELECT OUTPUT(CH) %FOR I=0,1,AMOUNT-1 %CYCLE PRINTSYMBOL(BYTEINTEGER(FCB_STARTBUFFER+I)) %REPEAT SELECT OUTPUT(OCH) %FINISH %FINISH %IF FCB_TYPE=TEXTFILE %OR FCB_TYPE=BYTEFILE %THEN FCB_BUFFERPTR=FCB_STARTBUFFER %ELSE %C FCB_BUFFERPTR=FCB_STARTBUFFER//BYTESTOUNITS %END; ! FlushBuffer !* %ROUTINE FORCEFLUSH(%INTEGER FCBPTR) !*********************************************************************** !* If a read is requested from the key-board and output is buffered * !* for the screen, force out the line before taking the read. * !*********************************************************************** %RECORD (CTLBLOCK) %NAME FCB %IF REPORT#0 %THENSTART PRINTSTRING("ForceFlush"); NEWLINE %FINISH FCB==RECORD(FCBPTR) %IF FCB_BUFFERPTR>FCB_STARTBUFFER %THENSTART FLUSHBUFFER(FCB) %FINISH %END; ! ForceFlush !* %ROUTINE CLOSEF(%RECORD (CTLBLOCK) %NAME FCB) !*********************************************************************** !* Close the file denoted by FCB. * !*********************************************************************** %INTEGER FLAG,MODE %IF REPORT#0 %THENSTART PRINTSTRING("Closef "); NEWLINE %FINISH MODE=FCB_MODE %IF READING<=MODE<=APPENDING %THENSTART %IF MODE#READING %THENSTART %IF FCB_TYPE=TEXTFILE %THENSTART %IF FCB_BUFFERPTR>FCB_STARTBUFFER %THENSTART %IF BYTEINTEGER(FCB_BUFFERPTR-1)#NL %THEN PUTCH(FCB,NL) %FINISH %FINISH FLUSHBUFFER(FCB) %FINISH RELEASE(FCB_STARTBUFFER//BYTESTOUNITS,FCB_BUFFERSIZE) FLAG=ECLOSE(BEXTEND(FCB_DESCRIPTOR),FCB_TYPE) %UNLESS ISATTY(FCB_DESCRIPTOR)=TRUE %FINISH %END; ! Closef !* !*********************************************************************** !*********************************************************************** !* The following procedures provide character i/o primitives. * !*********************************************************************** !*********************************************************************** !* !* %ROUTINE CHECKREAD(%RECORD (CTLBLOCK) %NAME FCB) !*********************************************************************** !* Perform runtime checks prior to a 'get' or 'read'. * !*********************************************************************** %IF FCB_MODE=UNDEFINED %THEN ISOERROR(15) %IF FCB_MODE#READING %THEN ISOERROR(14) %IF FCB_FLAGS&EOFFLAG#0 %THEN ISOERROR(16) %END; ! CheckRead !* %ROUTINE CHECKWRITE(%RECORD (CTLBLOCK) %NAME FCB) !*********************************************************************** !* Perform runtime checks prior to a 'put' or 'write'. * !*********************************************************************** %IF FCB_MODE=UNDEFINED %THEN ISOERROR(10) %IF FCB_MODE#WRITING %AND FCB_MODE#APPENDING %THEN ISOERROR(9) %IF FCB_FLAGS&EOFFLAG=0 %THEN ISOERROR(11) %END; ! CheckWrite !* %ROUTINE ACTUALGET(%RECORD (CTLBLOCK) %NAME FCB) !*********************************************************************** !* Perform actual 'get' operation on a textfile. * !*********************************************************************** %IF REPORT#0 %THENSTART PRINTSTRING("ActualGet "); NEWLINE %FINISH FCB_BUFFERPTR=FCB_BUFFERPTR+1 %IF FCB_BUFFERPTR=FCB_ENDBUFFER %THEN FILLBUFFER(FCB) %IF FCB_FLAGS&EOFFLAG=0 %THENSTART %IF BYTEINTEGER(FCB_BUFFERPTR)=NL %THENSTART FCB_FLAGS=FCB_FLAGS!EOLFLAG BYTEINTEGER(FCB_BUFFERPTR)=SP %FINISHELSE FCB_FLAGS=FCB_FLAGS&(~EOLFLAG) %FINISHELSE BYTEINTEGER(FCB_BUFFERPTR)=EOT %END; ! ActualGet !* %ROUTINE LAZYGET(%RECORD (CTLBLOCK) %NAME FCB) !*********************************************************************** !* Perform 'lazy'get on a text-file. (Used internally by read routines)* !*********************************************************************** %IF FCB_FLAGS&LAZYFLAG=0 %THEN ACTUALGET(FCB) %ELSE FCB_FLAGS=FCB_FLAGS!!LAZYFLAG %END; ! LazyGet !* %INTEGERFN NEXTCH(%RECORD (CTLBLOCK) %NAME FCB) !*********************************************************************** !* Return the next character of a textfile. (Used internally by read * !* routines.) * !*********************************************************************** %IF FCB_FLAGS&LAZYFLAG=0 %THENSTART ACTUALGET(FCB); FCB_FLAGS=FCB_FLAGS!LAZYFLAG %FINISH %RESULT=BYTEINTEGER(FCB_BUFFERPTR) %END; ! NextCh !* %ROUTINE PUTCH(%RECORD (CTLBLOCK) %NAME FCB, %INTEGER CH) !*********************************************************************** !* Append the next character Ch onto the file. * !*********************************************************************** BYTEINTEGER(FCB_BUFFERPTR)=CH FCB_BUFFERPTR=FCB_BUFFERPTR+1 %IF FCB_BUFFERPTR=FCB_ENDBUFFER %THEN FLUSHBUFFER(FCB) %END; ! PutCh !* %ROUTINE PADFIELD(%RECORD (CTLBLOCK) %NAME FCB, %INTEGER BLANKS) !*********************************************************************** !* Pad an output field with Blanks. * !*********************************************************************** %INTEGER I PUTCH(FCB,SP) %FOR I=1,1,BLANKS %END; ! PadField !* !* %ENDOFFILE