!*
!*
!***********************************************************************
!***********************************************************************
!* *
!* 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 Spare0,MODE,TYPE,SPARE,
%INTEGER STARTBUFFER,ENDBUFFER,Descriptor, %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
%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 *
!* *
!* *
!***********************************************************************
%integer flag
CONTROL=(FLAGS>>4)&255
RCHECKS=FLAGS&(1<<8)
UCHECKS=FLAGS&(1<<9)
HCHECKS=FLAGS&(1<<10)
FCHECKS=FLAGS&(1<<11)
%IF HEAPFILENAME#"" %START
HCONAD=0
DISCONNECT(HEAPFILENAME,FLAG)
HEAPFILENAME=""
%FINISH
INITHEAP
! Report = Comreg(26)&8
%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=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<LB %OR 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 PLACES<NUMWIDTH %CYCLE
PLACES=PLACES+1;
DIGITS(PLACES)='0'
%REPEAT
%IF WIDTH>PLACES %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(FCB_DESCRIPTOR)=TRUE %THEN FLUSHBUFFER(FCB)
! %IF FCB_FLAGS&TERMFLAG#0 %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(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(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<<BITOFFSET)
BITMASK=BITMASK<<FIELDWIDTH
BITOFFSET=BITOFFSET+FIELDWIDTH
%IF BITOFFSET>=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<<LOWBIT %ELSE INTEGER(WORDADDR)=WORD
WORDADDR=WORDADDR + 4
LOW=(LOW+32)&(~31)
%REPEATUNTIL LOW>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 %ELSERESULT=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<<D)!(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<DEFAULTBLOCKSIZE %THEN BYTEAMOUNT=DEFAULTBLOCKSIZE
BYTEPTR=MALLOC(BYTEAMOUNT)
%IF BYTEPTR<0 %THEN SYSTEMERROR(4)
BLOCKPTR=BYTEPTR//BYTESTOUNITS
ENDOFBLOCK=BLOCKPTR+(BYTEAMOUNT//BYTESTOUNITS)
INTEGER(BLOCKPTR)=NIL
INTEGER(BLOCKPTR+STARTOFFSET)=BLOCKPTR+BLOCKHEADER
INTEGER(BLOCKPTR+ENDOFFSET)=ENDOFBLOCK
INTEGER(BLOCKPTR+FREEOFFSET)=NIL
HEAPTOP=ENDOFBLOCK
%END; ! ClaimBlock
!*
%ROUTINE EXTENDHEAP(%INTEGER BYTEAMOUNT)
!***********************************************************************
!* Extend the heap by chaining a new memory block into the BlockList. *
!* The extension will guarentee there is room for ByteAmount bytes. *
!***********************************************************************
%INTEGER BLOCKPTR
%IF TRACE#0 %THENSTART
PRINTSTRING("*******Heap extended********"); NEWLINE
%FINISH
CLAIMBLOCK(BYTEAMOUNT,BLOCKPTR)
INTEGER(BLOCKPTR)=BLOCKLIST
BLOCKLIST=BLOCKPTR
%END; ! ExtendHeap
!*
%ROUTINE ACQUIRE(%INTEGERNAME HPTR, %INTEGER AMOUNT)
!***********************************************************************
!* Acquire Amount bytes of heap-space and return the start-address in *
!* Hptr. Extend the heap if there is insufficient space in the current *
!* block. *
!***********************************************************************
%INTEGER CURRPTR,PREVPTR,NEXTPTR,CURRSIZE
%INTEGER SURPLUSPTR,SURPLUS,BLOCKPTR,BLOCKSTART
AMOUNT=AMOUNT//BYTESTOUNITS
BLOCKPTR=BLOCKLIST
%WHILE BLOCKPTR#NIL %CYCLE
CURRPTR=BLOCKPTR+FREEOFFSET
%CYCLE
PREVPTR=CURRPTR
CURRPTR=INTEGER(CURRPTR)
%IF CURRPTR=NIL %THENEXIT
CURRSIZE=INTEGER(CURRPTR+SIZEOFFSET)
%IF CURRSIZE>=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-AMOUNT<BLOCKSTART %THENSTART
SURPLUS=HEAPTOP-BLOCKSTART
%IF SURPLUS>MINHEAPBLOCK %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<INTEGER(BLOCKPTR+ENDOFFSET) %THENEXITELSE %C
BLOCKPTR=INTEGER(BLOCKPTR)
%REPEAT
%IF BLOCKPTR=NIL %THEN SYSTEMERROR(5)
%IF BLOCKPTR=BLOCKLIST %AND HPTR<HEAPTOP %THEN SYSTEMERROR(5)
STARTGARBAGE=HPTR
ENDGARBAGE=HPTR+AMOUNT
CURRPTR=BLOCKPTR+FREEOFFSET
%CYCLE
PREVPTR=CURRPTR
CURRPTR=INTEGER(CURRPTR)
%REPEATUNTIL CURRPTR=NIL %OR CURRPTR<=ENDGARBAGE
%IF CURRPTR=STARTGARBAGE %THEN SYSTEMERROR(2)
%WHILE CURRPTR#NIL %CYCLE
ENDCURRENT=CURRPTR+INTEGER(CURRPTR+SIZEOFFSET)
%IF CURRPTR=ENDGARBAGE %OR ENDCURRENT=STARTGARBAGE %THENSTART
%IF CURRPTR=ENDGARBAGE %THEN ENDGARBAGE=ENDCURRENT %ELSE STARTGARBAGE=CURRPTR
CURRPTR=INTEGER(CURRPTR)
%FINISHELSEEXIT
%REPEAT
AMOUNT=ENDGARBAGE-STARTGARBAGE
%IF STARTGARBAGE#HEAPTOP %THENSTART
INTEGER(STARTGARBAGE+SIZEOFFSET)=AMOUNT
INTEGER(STARTGARBAGE)=CURRPTR
INTEGER(PREVPTR)=STARTGARBAGE
%IF TRACE#0 %THENSTART
PRINTSTRING("Chained free block at "); WRITE(STARTGARBAGE,4)
PRINTSTRING(" HeapTop = "); WRITE(HEAPTOP,4)
NEWLINE
%FINISH
%FINISHELSESTART
HEAPTOP=HEAPTOP+AMOUNT
INTEGER(PREVPTR)=NIL
%IF TRACE#0 %THENSTART
PRINTSTRING("Retracted heap to "); WRITE(HEAPTOP,4)
PRINTSTRING(" HeapTop = "); WRITE(HEAPTOP,4)
NEWLINE
%FINISH
%FINISH
%END; ! Release
!*
!*
!***********************************************************************
!***********************************************************************
!* The following procedures provide low-level support for file-creation*
!* and block i/o. *
!***********************************************************************
!***********************************************************************
!*
!*
%INTEGERFN NEWTEMPNAME
!***********************************************************************
!* Return a pointer to the name of a temporary work-file. *
!***********************************************************************
%INTEGER STRPTR
%IF REPORT#0 %THENSTART
PRINTSTRING("NewTempName "); NEWLINE
%FINISH
acquire(strptr,16)
STRING(STRPTR)="t#ptmp".NEXTTEMP
%RESULT=STRPTR
%END; ! NewTempName
!*
%INTEGERFN NEWFILENAME(%INTEGER NAMEPTR,LENGTH)
!***********************************************************************
!* Construct file name as an IMP string and strip out trailing blanks *
!* and control characters. *
!***********************************************************************
%INTEGER NEWLENGTH,BYTES,FROM,TO,STRPTR,ADDR
BYTES=((LENGTH+3)>>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
%IF REPORT#0 %THENSTART
PRINTSTRING(DATA)
NEWLINE
%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 CAPACITY<MINCAPACITY %THEN BUFFERSIZE=MINCAPACITY*BYTES %ELSE %C
BUFFERSIZE=(CAPACITY+1)*BYTES
%IF BUFFERSIZE>MAXHEAPBLOCK %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
%on %event 9 %Start
i=25; ->eof
%finish
%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=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)
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
eof: 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=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(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