!*
!*
!***********************************************************************
!***********************************************************************
!*                                                                     *
!*    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)
!*
%CONSTINTEGER PERQ2= 0;
%CONSTINTEGER PERQ3= 1;
%CONSTINTEGER AMDAHL= 2;
%CONSTINTEGER GOULD= 3;
%CONSTINTEGER HOST= AMDAHL
!*
%constINTEGER REPORT=1
!*
!************************************************************************
!*      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 BLOCKSIZE= 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 FREE(%INTEGER BLOCKPTR)
!*
!*
%EXTERNALROUTINESPEC STOP %ALIAS "S#STOP"
%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)
%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)
!*
%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 NEW1(%INTEGER PTR,BYTES)
%ROUTINESPEC NEW2(%INTEGER PTR,LEVELS,BYTES)
%ROUTINESPEC DISPOSE1(%INTEGER PTR,BYTES)
%ROUTINESPEC DISPOSE2(%INTEGER PTR,LEVELS,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   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                   *
!***********************************************************************
!*
!*
%OWNINTEGER HCHECKS,FCHECKS,UCHECKS,MSTATS
!*
!*
!***********************************************************************
!*              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= 0    { denote 'undefined' file mode     }
%CONSTINTEGER DEFINED= 1    { denote 'defined' file mode       }
%CONSTINTEGER READING= 2    { denote 'inspection' file mode    }
%CONSTINTEGER WRITING= 3    { denote 'generation' file mode    }
%CONSTINTEGER APPENDING= 4    { denote 'appending' file mode     }
!*
%CONSTINTEGER READMODE= 0    { PNX read mode                    }
%CONSTINTEGER WRITEMODE= 1    { PNX write mode                   }
%CONSTINTEGER RWMODE= 2    { PNX read-write mode              }
%CONSTINTEGER WRITEACCESS= 2    { PNX write access                 }
%CONSTINTEGER READACCESS= 4    { PNX read access                  }
%CONSTINTEGER RWACCESS= 8_664{ PNX read-write access            }
!*
%RECORDFORMAT CTLBLOCK(%INTEGER BUFFERPTR,FLAGS, %BYTEINTEGER DESCRIPTOR,MODE,TYPE,SPARE,
   %INTEGER STARTBUFFER,ENDBUFFER,PACKPTR, %SHORTINTEGER ELEMSIZE,BUFFERSIZE, %INTEGER NAMEPTR)
!*
%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
%INCLUDE "SUBARC:SSOWNF2"
%EXTERNALRECORD (SSOWNF) %SPEC SSOWN
%EXTERNALINTEGERFNSPEC FINDCHAN %ALIAS "S#FINDCHAN"(%STRING (255) CHAN, %INTEGERNAME POS)
%EXTERNALINTEGERFN ISATTY %ALIAS "S#ISATTY"(%INTEGER CHAN)
%INTEGER FLAG,POS
%RECORD (FCHANF) %NAME CUR
%RECORD (FDF) %NAME F
%STRING (255) SCHAN
      SCHAN=ITOS(CHAN)
      FLAG=FINDCHAN(SCHAN,POS)
      %IF FLAG=0 {Found} %START
         CUR==RECORD(SSOWN_CHAN(POS))
         F==RECORD(CUR_AFD)
         PRINTSTRING("F_accessroute =".ITOS(F_ACCESSROUTE))
         NEWLINE
         %IF F_ACCESSROUTE=9 %THENRESULT=1 {interactive terminal}
         %RESULT=0
      %FINISHELSERESULT=0 {not a TTY}
%END

%EXTERNALROUTINE A %ALIAS "C#ISA"
%EXTERNALROUTINESPEC EMAS3INTEGER(%STRINGNAME S, %INTEGERNAME I)
%INTEGER J
      EMAS3INTEGER("Chan",J)
      WRITE(ISATTY(J),1); NEWLINE
%END
%INTEGERFN BEXTEND(%INTEGER BYTE)
      %IF BYTE&128#0 %THEN BYTE=BYTE!x'ffffff00'
      %RESULT=BYTE
%END
%ROUTINE ISOERROR(%INTEGER CODE)
!***********************************************************************
!* Report an ISO Standard run-time error.                              *
!***********************************************************************
      NEWLINE
      PRINTSTRING("ISO Error"); WRITE(CODE,4); NEWLINE
      %MONITOR
      EXIT
%END;                                   ! ISOError
!*
%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
!*
%ROUTINE SYSTEMERROR(%INTEGER CODE)
!***********************************************************************
!* Report a system-dependent run-time error.                           *
!***********************************************************************
      {  1 : invalid size for new }
      {  2 : invalid size for dispose }
      {  3 : inconsistent call to dispose }
      {  4 : unable to acquire more memory }
      {  5 : unable to release memory - heap corrupt }
      {  6 : invalid FCB ptr }
      {  7 : unable to open file for reading }
      {  8 : unable to open file for writing }
      {  9 : unable to create new file }
      { 10 : too many file bindings }
      { 11 : attempt to read from 'stdout'  }
      { 12 : attempt to read from 'stderr' }
      { 13 : attempt to write to 'stdin' }
      { 14 : file read fails }
      { 15 : file write fails }
      { 16 : invalid 'width' on write }
      { 17 : integer overflow on read }
      { 18 : size error in 'pack' }
      { 19 : size error in 'unpack' }
      { 20 : unable to allocate file buffer }
      NEWLINE
      PRINTSTRING("System Error"); WRITE(CODE,4); NEWLINE
      %MONITOR
      EXIT
%END;                                   ! SystemError
!*
%ROUTINE FATALERROR(%INTEGER CODE)
!***********************************************************************
!* Report a fatal system-error.                                        *
!***********************************************************************
      NEWLINE
      PRINTSTRING("Fatal Error"); WRITE(CODE,4); NEWLINE
      %MONITOR
      EXIT
%END;                                   ! FatalError
!*
%EXTERNALROUTINE STARTPROGRAM %ALIAS "p_init"(%INTEGER CONTROL)
!***********************************************************************
!* Start program. Control provides control flags as follows            *
!***********************************************************************
      INITHEAP
%END;                                   ! StartProgram
!*
%EXTERNALROUTINE ENDPROGRAM %ALIAS "p_end"
!***********************************************************************
!* Normal program termination. Return to calling environment.          *
!***********************************************************************
      NEWLINES(2)
      PRINTSTRING("Program stopped.")
      NEWLINE
      EXIT
%END;                                   ! EndProgram
!*
%EXTERNALROUTINE TRAPPROGRAM %ALIAS "p_trap"(%INTEGER ERROR)
!***********************************************************************
!* Trap program runtime error. Error gives the appropriate error code. *
!***********************************************************************
%END;                                   ! TrapProgram
!*
%EXTERNALROUTINE PAUSEPROGRAM %ALIAS "p_mon"
!***********************************************************************
!* 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 (31) %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
%INTEGER I
      %IF REPORT#0 %THENSTART
         PRINTSTRING("p_preset "); PHEX(FCBPTR); WRITE(COUNT,4); NEWLINE
      %FINISH
      %IF FCBPTR=0 %THEN SYSTEMERROR(6)
      PRESET(FCBPTR,COUNT*FCBSIZE)
      %FOR I=1,1,COUNT %CYCLE
         FCB==RECORD(FCBPTR)
         FCB_MODE=UNDEFINED
         FCB_FLAGS=0
         FCBPTR=FCBPTR+(FCBSIZE//BYTESTOUNITS)
      %REPEAT
%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
      FCB_FLAGS=FCB_FLAGS!PERMFLAG
%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 in bytes.                              *
!*                                                                     *
!* 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)
         WRITE(BYTES,4); SPACE; PHEX(FLAGPTR); SPACE;
         %IF NAMEPTR#NIL %THEN PRINTSTRING(STRING(NAMEPTR))
         NEWLINE
      %FINISH
      %IF FCBPTR=0 %THEN SYSTEMERROR(6)
      FCB==RECORD(FCBPTR)
      MODE=FCB_MODE; DESCRIPTOR=BEXTEND(FCB_DESCRIPTOR); FLAGS=FCB_FLAGS
      %IF MODE#UNDEFINED %THENSTART
         %IF MODE>DEFINED %AND FLAGS&PERMFLAG#0 %AND DESCRIPTOR>STDERR %THENSTART
            %IF FLAGPTR#NIL %THEN INTEGER(FLAGPTR)=FALSE %ANDRETURN
            EPCERROR(10)
         %FINISH
         CLOSEF(FCB)
      %FINISHELSESTART
         %IF NAMEPTR=NIL %THEN ISOERROR(13)
      %FINISH
      DESCRIPTOR=OPENF(FCB,TYPE,BYTES,NAMEPTR,READING)
      %IF DESCRIPTOR<0 %THENSTART
         %IF FLAGPTR#NIL %THEN INTEGER(FLAGPTR)=FALSE %ANDRETURN
         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 in bytes.                              *
!*                                                                     *
!* 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)
         WRITE(BYTES,4); SPACE; PHEX(FLAGPTR); SPACE
         %IF NAMEPTR#NIL %THEN PRINTSTRING(STRING(NAMEPTR))
         NEWLINE
      %FINISH
      %IF FCBPTR=0 %THEN SYSTEMERROR(6)
      FCB==RECORD(FCBPTR)
      MODE=FCB_MODE; DESCRIPTOR=BEXTEND(FCB_DESCRIPTOR); FLAGS=FCB_FLAGS
      %IF MODE#UNDEFINED %THENSTART
         %IF MODE>DEFINED %AND FLAGS&PERMFLAG#0 %AND DESCRIPTOR>STDERR %THENSTART
            %IF FLAGPTR#NIL %THEN INTEGER(FLAGPTR)=FALSE %ANDRETURN
            EPCERROR(10)
         %FINISH
         CLOSEF(FCB)
      %FINISH
      DESCRIPTOR=OPENF(FCB,TYPE,BYTES,NAMEPTR,WRITING)
      %IF DESCRIPTOR<0 %THENSTART
         %IF FLAGPTR#NIL %THEN INTEGER(FLAGPTR)=FALSE %ANDRETURN
         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 in bytes.                              *
!*                                                                     *
!* 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)
         WRITE(BYTES,4); SPACE; PHEX(FLAGPTR); SPACE
         %IF NAMEPTR#NIL %THEN PRINTSTRING(STRING(NAMEPTR))
         NEWLINE
      %FINISH
      %IF FCBPTR=0 %THEN SYSTEMERROR(6)
      FCB==RECORD(FCBPTR)
      MODE=FCB_MODE; DESCRIPTOR=BEXTEND(FCB_DESCRIPTOR); FLAGS=FCB_FLAGS
      %IF MODE#UNDEFINED %THENSTART
         %IF MODE>DEFINED %AND FLAGS&PERMFLAG#0 %AND DESCRIPTOR>STDERR %THENSTART
            %IF FLAGPTR#NIL %THEN INTEGER(FLAGPTR)=FALSE %ANDRETURN
            EPCERROR(10)
         %FINISH
         CLOSEF(FCB)
      %FINISH
      DESCRIPTOR=OPENF(FCB,TYPE,BYTES,NAMEPTR,APPENDING)
      %IF DESCRIPTOR<0 %THENSTART
         %IF FLAGPTR#NIL %THEN INTEGER(FLAGPTR)=FALSE %ANDRETURN
         SYSTEMERROR(9)
      %FINISHELSESTART
         %IF FLAGPTR#NIL %THEN INTEGER(FLAGPTR)=TRUE
      %FINISH
      FCB_FLAGS=FCB_FLAGS!LAZYFLAG!EOFFLAG
      %IF DESCRIPTOR=STDOUT %AND FCB_FLAGS&TERMFLAG#0 %THEN STDOUTPTR=FCBPTR
      %IF DESCRIPTOR=STDERR %AND FCB_FLAGS&TERMFLAG#0 %THEN STDERRPTR=FCBPTR
%END;                                   ! AppendFile
!*
%EXTERNALROUTINE CLOSEFILE %ALIAS "p_closef"(%INTEGER FCBPTR)
!***********************************************************************
!* Close a file if opened.                                             *
!***********************************************************************
%RECORD (CTLBLOCK) %NAME FCB
%INTEGER MODE,DESCRIPTOR,FLAG
      %IF REPORT#0 %THENSTART
         PRINTSTRING("p_closef "); PHEX(FCBPTR); NEWLINE
      %FINISH
      %IF FCBPTR=0 %THEN SYSTEMERROR(6)
      FCB==RECORD(FCBPTR)
      MODE=FCB_MODE; DESCRIPTOR=BEXTEND(FCB_DESCRIPTOR)
      %IF MODE#UNDEFINED %THENSTART
         CLOSEF(FCB)
         destroy(string(fcb_nameptr),flag) %UNLESS FCB_FLAGS&PERMFLAG#0
         PRESET(FCBPTR,FCBSIZE)
         FCB_MODE=UNDEFINED
         FCB_FLAGS=0
      %FINISH
      %IF FCBPTR=STDOUTPTR %THEN STDOUTPTR=NIL
      %IF FCBPTR=STDERRPTR %THEN STDERRPTR=NIL
%END;                                   ! CloseFile
!*
!*
!***********************************************************************
!***********************************************************************
!* 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=1
         ACTUALGET(FCB)
      %FINISHELSE NEGATIVE=0
      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=1 %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,DIGITPTR,CHPTR,CTLPTR,CH,I
%LONGLONGREAL RWORK,SCALE
%LONGREAL VALUE
!*
%ROUTINE COPYCH
      BYTEINTEGER(CHPTR)=CH
      CHPTR=CHPTR+1
      ACTUALGET(FCB)
      CH=BYTEINTEGER(FCB_BUFFERPTR)
%END
!*
%ROUTINE DIGITSEQUENCE
      CH=BYTEINTEGER(FCB_BUFFERPTR)
      %IF '0'<=CH<='9' %THENSTART
         %CYCLE
            COPYCH
         %REPEATUNTIL CH<'0' %OR CH>'9'
      %FINISHELSE ISOERROR(56)
%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=1
         ACTUALGET(FCB)
      %FINISHELSE NEGATIVE=0
      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
            I=READINT(FCB_BUFFERPTR)
            RWORK=RWORK*d'10.0'**I
         %FINISH
      %FINISH
      %IF NEGATIVE=1 %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
%CONSTLONGREAL D0= 0, D1 = 1
%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=1
      %FINISHELSE NEGATIVE=0
      PLACES=0
      %CYCLE
         TENS=VALUE//10
         PLACES=PLACES+1
         DIGITS(PLACES)=VALUE-10*TENS+'0'
         VALUE=TENS
      %REPEATUNTIL VALUE=0
      %IF NEGATIVE=1 %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
         UNITS=VALUE//BASE
         PLACES=PLACES+1
         DIGIT=VALUE-BASE*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,NEGATIVE,CTLPTR,STRINGPTR,I
%STRING (63) S
      %IF REPORT#0 %THENSTART
         PRINTSTRING("p_wrfx "); PHEX(FCBPTR); WRITE(TOTALWIDTH,4);
         WRITE(FRACDIGITS,4); NEWLINE
      %FINISH
      %IF FCBPTR=0 %THEN SYSTEMERROR(6)
      FCB==RECORD(FCBPTR)
      %IF FCHECKS#0 %THEN CHECKWRITE(FCB)
      S=SPRINT(VALUE,TOTALWIDTH-FRACDIGITS-4,FRACDIGITS)
      STRINGPTR=ADDR(S)+1
      ACTWIDTH=LENGTH(S)
      %FOR I=1,1,ACTWIDTH %CYCLE
         PUTCH(FCB,BYTEINTEGER(STRINGPTR))
         STRINGPTR=STRINGPTR+1
      %REPEAT
%END;                                   ! WriteFxRl
!*
%EXTERNALROUTINE WRITEFLRL %ALIAS "p_wrfl"(%INTEGER FCBPTR, %LONGREAL VALUE,
   %INTEGER TOTALWIDTH)
!***********************************************************************
!* Write the real Value in floating-point format with field Width on   *
!* the FCB.                                                            *
!***********************************************************************
%RECORD (CTLBLOCK) %NAME FCB
%INTEGER ACTWIDTH,PRECISION,CTLPTR,STRINGPTR,ENDOFSTRING,CH,I
%STRING (63) S
      %IF REPORT#0 %THENSTART
         PRINTSTRING("p_wrfl "); PHEX(FCBPTR); WRITE(TOTALWIDTH,4); NEWLINE
      %FINISH
      %IF FCBPTR=0 %THEN SYSTEMERROR(6)
      FCB==RECORD(FCBPTR)
      %IF FCHECKS#0 %THEN CHECKWRITE(FCB)
      %IF TOTALWIDTH>=EXPDIGITS+5 %THEN ACTWIDTH=TOTALWIDTH %ELSE ACTWIDTH=EXPDIGITS+5
      PRECISION=ACTWIDTH-EXPDIGITS-4
      S=SPRINTFL(VALUE,PRECISION-1)
      STRINGPTR=ADDR(S)+1
      ACTWIDTH=LENGTH(S)
      %FOR I=1,1,ACTWIDTH %CYCLE
         PUTCH(FCB,BYTEINTEGER(STRINGPTR))
         STRINGPTR=STRINGPTR+1
      %REPEAT
%END;                                   ! WriteFlRl
!*
%EXTERNALROUTINE WRITELN %ALIAS "p_wrln"(%INTEGER FCBPTR)
!***********************************************************************
!* Perform the standard operation 'writeln' on the file FCB.           *
!***********************************************************************
%RECORD (CTLBLOCK) %NAME FCB
      %IF REPORT#0 %THENSTART
         PRINTSTRING("p_wrln "); PHEX(FCBPTR); NEWLINE
      %FINISH
      %IF FCBPTR=0 %THEN SYSTEMERROR(6)
      FCB==RECORD(FCBPTR)
      %IF FCHECKS#0 %THEN CHECKWRITE(FCB)
      PUTCH(FCB,NL)
      %IF ISATTY(BEXTEND(FCB_DESCRIPTOR))=TRUE %THEN FLUSHBUFFER(FCB)
%END;                                   ! WriteLn
!*
%EXTERNALROUTINE WRITELINES %ALIAS "p_lines"(%INTEGER FCBPTR,COUNT)
!***********************************************************************
!* Perform the operation 'lines' on the file FCB.                      *
!***********************************************************************
%RECORD (CTLBLOCK) %NAME FCB
%INTEGER I
      %IF REPORT#0 %THENSTART
         PRINTSTRING("p_lines"); PHEX(FCBPTR); NEWLINE
      %FINISH
      %IF FCBPTR=0 %THEN SYSTEMERROR(6)
      FCB==RECORD(FCBPTR)
      %IF FCHECKS#0 %THEN CHECKWRITE(FCB)
      %IF COUNT>=1 %THENSTART
         PUTCH(FCB,NL) %FOR I=1,1,COUNT
         %IF ISATTY(BEXTEND(FCB_DESCRIPTOR))=TRUE %THEN FLUSHBUFFER(FCB)
         %RETURN
      %FINISH
%END;                                   ! WriteLines
!*
%EXTERNALROUTINE WRITEPAGE %ALIAS "p_page"(%INTEGER FCBPTR)
!***********************************************************************
!* Perform the standard operation 'page' on the FCB.                   *
!***********************************************************************
%RECORD (CTLBLOCK) %NAME FCB
      %IF REPORT#0 %THENSTART
         PRINTSTRING("p_lines"); PHEX(FCBPTR); NEWLINE
      %FINISH
      %IF FCBPTR=0 %THEN SYSTEMERROR(6)
      FCB==RECORD(FCBPTR)
      %IF FCHECKS#0 %THEN CHECKWRITE(FCB)
      PUTCH(FCB,FF)
      %IF ISATTY(BEXTEND(FCB_DESCRIPTOR))=TRUE %THEN FLUSHBUFFER(FCB)
%END;                                   ! WritePage
!*
!*
!***********************************************************************
!***********************************************************************
!* The following procedures provide the standard operations 'new' and  *
!* 'dispose'. Forms 1 and 2 respectively denote the short and long     *
!* forms of each function.                                             *
!***********************************************************************
!***********************************************************************
!*
!*
%EXTERNALROUTINE NEW1 %ALIAS "p_new1"(%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.   *
!***********************************************************************
%INTEGER HPTR,HEAPBYTES
      SYSTEMERROR(1) %UNLESS 0<BYTES<MAXHEAPBLOCK
      HEAPBYTES=((BYTES+3)>>2)<<2
      %IF HEAPBYTES<8 %THEN HEAPBYTES=8
      %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
%END;                                   ! New1
!*
%EXTERNALROUTINE NEW2 %ALIAS "p_new2"(%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
      SYSTEMERROR(1) %UNLESS 0<BYTES<MAXHEAPBLOCK
      HEAPBYTES=((BYTES+3)>>2)<<2
      %IF HEAPBYTES<8 %THEN HEAPBYTES=8
      %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
%END;                                   ! New2
!*
%EXTERNALROUTINE DISPOSE1 %ALIAS "p_disp1"(%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.                                                    *
!***********************************************************************
%INTEGER HPTR,HEAPBYTES
      SYSTEMERROR(2) %UNLESS 0<BYTES<MAXHEAPBLOCK
      HEAPBYTES=((BYTES+3)>>2)<<2
      %IF HEAPBYTES<8 %THEN HEAPBYTES=8
      HPTR=INTEGER(PTR)
      %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;                                   ! Dispose1
!*
%EXTERNALROUTINE DISPOSE2 %ALIAS "p_disp2"(%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
      SYSTEMERROR(2) %UNLESS 0<BYTES<MAXHEAPBLOCK
      HEAPBYTES=((BYTES+3)>>2)<<2
      %IF HEAPBYTES<8 %THEN HEAPBYTES=8
      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 NEWLEVEL#0 %AND NEWLEVEL#LEVELS %THEN ISOERROR(21)
         HEAPBYTES=HEAPBYTES+8
      %FINISH
      RELEASE(HPTR,HEAPBYTES)
      %IF UCHECKS#0 %THEN PRESET(PTR,MCBYTESPERWORD)
%END;                                   ! Dispose2
!*
!*
!***********************************************************************
!***********************************************************************
!* 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>>1
      %CYCLE
         SIZE=SIZE-2
         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>>1
      %CYCLE
         SIZE=SIZE-2
         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>>1
      %CYCLE
         SIZE=SIZE-2
         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>>1
      %CYCLE
         SIZE=SIZE-2
         %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>>1
      %CYCLE
         SIZE=SIZE-2
         %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>>1
      %CYCLE
         SIZE=SIZE-2
         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)<<1)
      %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)<<1)=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)<<1
      %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+2
         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_sqrt"(%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(%INTEGERNAME BLOCKPTR)
!***********************************************************************
!* Claim a new memory block from system memory-manager. Return its     *
!* byte address in BlockPtr. The block-size is given by the            *
!* configurable constant MBlockSize.                                   *
!***********************************************************************
%INTEGER BYTEPTR,ENDOFBLOCK
      BYTEPTR=MALLOC(BLOCKSIZE)
      %IF BYTEPTR<0 %THEN SYSTEMERROR(4)
      BLOCKPTR=BYTEPTR//BYTESTOUNITS
      ENDOFBLOCK=BLOCKPTR+(BLOCKSIZE//BYTESTOUNITS)
      INTEGER(BLOCKPTR)=NIL
      INTEGER(BLOCKPTR+STARTOFFSET)=BLOCKPTR+BLOCKHEADER
      INTEGER(BLOCKPTR+ENDOFFSET)=ENDOFBLOCK
      INTEGER(BLOCKPTR+FREEOFFSET)=NIL
      HEAPTOP=ENDOFBLOCK
%END;                                   ! ClaimBlock
!*
%ROUTINE EXTENDHEAP
!***********************************************************************
!* Extend the heap by chaining a new memory block into the BlockList.  *
!***********************************************************************
%INTEGER BLOCKPTR
      CLAIMBLOCK(BLOCKPTR)
      %IF BLOCKLIST=NIL %THEN INTEGER(BLOCKLIST)=BLOCKPTR
      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
               %RETURN
            %FINISH
         %REPEAT
         BLOCKPTR=INTEGER(BLOCKLIST)
      %REPEAT
      %IF BLOCKLIST=NIL %THEN CLAIMBLOCK(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)=HEAPTOP
         %FINISH
         EXTENDHEAP
      %FINISH
      HEAPTOP=HEAPTOP-AMOUNT
      HPTR=HEAPTOP
%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
      %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
      %FINISHELSESTART
         HEAPTOP=HEAPTOP+AMOUNT
         INTEGER(PREVPTR)=NIL
      %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
      STRING(ADDR(STRPTR))="t#ptmp".NEXTTEMP
      %RESULT=STRPTR
%END;                                   ! NewTempName
!*
%INTEGERFN STDCHECK(%STRING (31) %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
      EMAS3CLAIMCHANNEL(CH)
      DATA=ITOS(CH).",".FILENAME
      %IF TYPE&TEXTFILE=0 %START
         %IF MODE&APPENDING#0 %THEN DATA=DATA."-MOD"
         DATA=DATA.",,F".ITOS(BYTES)
      %FINISH
      EMAS3("define",DATA,FLAG)
      %IF FLAG#0 %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 (31) %NAME 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
      %FINISHELSE FLAGS=PERMFLAG
      FILENAME==STRING(NAMEPTR)
      STDFILE=STDCHECK(FILENAME,MODE)
      DESCRIPTOR=EOPEN(FILENAME,MODE,TYPE,BYTES)
      %IF DESCRIPTOR=-1 %THENRESULT=-1
      %IF ISATTY(DESCRIPTOR)=TRUE %THEN FLAGS=FLAGS!TERMFLAG
      FCB_DESCRIPTOR<-DESCRIPTOR
      FCB_NAMEPTR=NAMEPTR
      FCB_MODE=MODE
      FCB_FLAGS=FLAGS
      FCB_TYPE=TYPE
      GETBUFFER(FCB,BYTES)
      %RESULT=DESCRIPTOR
%END;                                   ! Openf
!*
%ROUTINE FILLBUFFER(%RECORD (CTLBLOCK) %NAME FCB)
!***********************************************************************
!* Fill transfer buffer by a block-read.                               *
!***********************************************************************
%INTEGER AMOUNT,CH,I
      %IF REPORT#0 %THENSTART
         PRINTSTRING("fillbuffer "); NEWLINE
      %FINISH
      %IF FCB_FLAGS&TERMFLAG#0 %THENSTART
         %IF STDOUTPTR#NIL %THEN FORCEFLUSH(STDOUTPTR)
         %IF STDERRPTR#NIL %THEN FORCEFLUSH(STDERRPTR)
      %FINISH
      CH=BEXTEND(FCB_DESCRIPTOR)
      %IF FCB_TYPE&TEXTFILE=0 %START
         READLSQ(CH,BYTEINTEGER(FCB_STARTBUFFER),
            BYTEINTEGER(FCB_STARTBUFFER+FCB_BUFFERSIZE-1),AMOUNT)
         I=0
      %ELSE
         SELECTINPUT(CH)
         AMOUNT=0
         %CYCLE
            READSYMBOL(I)
            %IF I=25 %THENEXIT
            BYTEINTEGER(FCB_STARTBUFFER+AMOUNT)=I
            AMOUNT=AMOUNT+1
            %EXITIF I=10
         %REPEAT
         %IF AMOUNT>FCB_BUFFERSIZE %THEN SYSTEM ERROR(14)
      %FINISH
      FCB_ENDBUFFER=FCB_STARTBUFFER+AMOUNT
      %IF AMOUNT=0 %OR I=25 %THEN FCB_FLAGS=FCB_FLAGS!EOFFLAG
      %IF FCB_TYPE=TEXTFILE %OR FCB_TYPE=BYTEFILE %THEN FCB_BUFFERPTR=FCB_STARTBUFFER %ELSE %C
         FCB_BUFFERPTR=FCB_STARTBUFFER//BYTESTOUNITS
%END;                                   ! FillBuffer
!*
%ROUTINE FLUSHBUFFER(%RECORD (CTLBLOCK) %NAME FCB)
!***********************************************************************
!* Flush transfer buffer by a block-write.                             *
!***********************************************************************
%INTEGER AMOUNT,FLAG,CH,I,och
      %IF REPORT#0 %THENSTART
         PRINTSTRING("FlushBuffer "); NEWLINE
      %FINISH
      %IF FCB_TYPE=TEXTFILE %OR FCB_TYPE=BYTEFILE %THEN %C
         AMOUNT=FCB_BUFFERPTR-FCB_STARTBUFFER %ELSE %C
         AMOUNT=FCB_BUFFERPTR*UNITSTOBYTES-FCB_STARTBUFFER
      %IF AMOUNT>0 %THENSTART
         CH=BEXTEND(FCB_DESCRIPTOR)
         %IF FCB_TYPE&TEXTFILE=0 %START
            %WHILE AMOUNT>FCB_ELEMSIZE %CYCLE
               WRITESQ(CH,BYTEINTEGER(FCB_STARTBUFFER),
                  BYTEINTEGER(FCB_STARTBUFFER+FCB_ELEMSIZE-1))
               AMOUNT=AMOUNT-FCB_ELEMSIZE
               MOVE(AMOUNT,FCB_STARTBUFFER+FCB_ELEMSIZE,FCB_STARTBUFFER)
            %REPEAT
            WRITESQ(CH,BYTEINTEGER(FCB_STARTBUFFER),BYTEINTEGER(FCB_STARTBUFFER+AMOUNT-1))
         %ELSE
              och=comreg(23)
            SELECT OUTPUT(CH)
            %FOR I=0,1,AMOUNT-1 %CYCLE
               PRINTSYMBOL(BYTEINTEGER(FCB_STARTBUFFER+I))
            %REPEAT
           select output(och)
         %FINISH
      %FINISH
      %IF FCB_TYPE=TEXTFILE %OR FCB_TYPE=BYTEFILE %THEN FCB_BUFFERPTR=FCB_STARTBUFFER %ELSE %C
         FCB_BUFFERPTR=FCB_STARTBUFFER//BYTESTOUNITS
%END;                                   ! FlushBuffer
!*
%ROUTINE FORCEFLUSH(%INTEGER FCBPTR)
!***********************************************************************
!* If a read is requested from the key-board and output is buffered    *
!* for the screen, force out the line before taking the read.          *
!***********************************************************************
%RECORD (CTLBLOCK) %NAME FCB
      %IF REPORT#0 %THENSTART
         PRINTSTRING("ForceFlush"); NEWLINE
      %FINISH
      FCB==RECORD(FCBPTR)
      %IF FCB_BUFFERPTR>FCB_STARTBUFFER %THENSTART
         FLUSHBUFFER(FCB)
      %FINISH
%END;                                   ! ForceFlush
!*
%ROUTINE CLOSEF(%RECORD (CTLBLOCK) %NAME FCB)
!***********************************************************************
!* Close the file denoted by FCB.                                      *
!***********************************************************************
%INTEGER FLAG,MODE
      %IF REPORT#0 %THENSTART
         PRINTSTRING("Closef "); NEWLINE
      %FINISH
      MODE=FCB_MODE
      %IF READING<=MODE<=APPENDING %THENSTART
         %IF MODE=WRITING %AND FCB_TYPE=TEXTFILE %THENSTART
            %IF FCB_BUFFERPTR>FCB_STARTBUFFER %THENSTART
               %IF BYTEINTEGER(FCB_BUFFERPTR-1)#NL %THEN PUTCH(FCB,NL)
            %FINISH
         %FINISH
         %IF MODE#READING %THEN FLUSHBUFFER(FCB)
         RELEASE(FCB_STARTBUFFER//BYTESTOUNITS,FCB_BUFFERSIZE)
         FLAG=ECLOSE(BEXTEND(FCB_DESCRIPTOR),FCB_TYPE) %UNLESS %C
            ISATTY(BEXTEND(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 %THEN ISOERROR(9)
      %IF FCB_MODE&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