// File OLIBNSRC
 
// Version: E1.10
 
// BCPL part of standard BCPL library for ICL 2900 under EMAS
//  - version without diagnostic routines
 
// Copyright R.D. Eager   University of Kent   MCMLXXIX
 
 
// History:
//  E1.0   - Initial EMAS version
//  E1.1   - Addition of terminal buffer clearing code for class 65
//           (breakin) contingencies.
//         - WRITEOCT, WRITEHEX, WRITES, WRITEO, WRITEH, WRITEN,
//           NEWLINE, NEWPAGE, READN, PACKSTRING and UNPACKSTRING
//           commented out; machine code versions within run-time
//           system are used.
//         - Addition of code to scan to end of the OBEY file, after
//           breakin during an OBEY.
//  E1.2   - Modification to message printed out after a contingency.
//  E1.3   - Removal of CONSOLE routine (now in run-time system).
//         - Correction to code for scanning to end of OBEY file
//           after breakin.
//  E1.4   - Improvement to code for scanning to end of OBEY file; now
//           uses ENDOBEY routine in run-time system.
//  E1.5   - WRITEF altered to accept lower case equivalents for format characters.
//  E1.6   - Modified to accept single-character INT: messages in lower case.
//  E1.7   - Addition of '%$' to WRITEF.
//  E1.8   - Debugging output now uses a 'secret' copy of WRCH; this allows
//           users to plug WRCH with a private version, yet still get
//           diagnostic output even if that private version does not work.
//  E1.9   - Improved version of 'readnumber'; will read 'minint' correctly.
//  E1.10  - Addition of 'getvec' and 'freevec'.


// Standard library routines
 
GET "LIBHDR"
 
LET writed(n, d) BE
$( LET t = VEC 10
   AND i, k = 0, n
 
   IF (n NE 0) & ((n << 1) = 0) THEN
   $( writes("-2147483648")
      RETURN
   $)
   IF n < 0 THEN d, k := d - 1, -n
   $( t!i := k REM 10
      k := k / 10
      i := i + 1
   $) REPEATUNTIL k = 0
   FOR j = i + 1 TO d DO wrch('*S')
   IF n < 0 DO wrch('-')
   FOR j = i - 1 TO 0 BY -1 DO wrch(t!j + '0')
$)
 
LET readnumber(radix) = VALOF
$( LET sum, neg_, sign = 0, FALSE, +1
 
   $( terminator := rdch()
      SWITCHON terminator INTO
      $( CASE '-' : neg_ := TRUE
         CASE '+' : terminator := rdch()
         DEFAULT  : BREAK
         CASE '*S':
         CASE '*T':
         CASE '*C':
         CASE '*N':
         CASE '*P':
      $)
   $) REPEAT
 
   $( LET c = '0' LE terminator LE '9' -> terminator - '0',
              'a' LE terminator LE 'z' -> terminator - 'a' + 10,
              'A' LE terminator LE 'Z' -> terminator - 'A' + 10,
                                          100
      IF c GE radix RESULTIS sum
      sum := sum*radix + c*sign
      IF neg_ & sum NE 0 THEN
      $( sum := -sum
         sign := -1
         neg_ := FALSE
      $)
      terminator := rdch()
   $) REPEAT
$)
 
AND writef(format, a, b, c, d, e, f, g, h, i, j, k) BE
$( LET t = @a
 
   FOR p = 1 TO format%0 DO
   $( LET k = format%p
 
      TEST k = '%' THEN
      $( LET q, n = !t, 0
         AND type = format%(p + 1)
         AND f = ?
 
         p := p + 1
         SWITCHON type INTO
         $( DEFAULT  :  wrch(type); ENDCASE
 
            CASE 's' :
            CASE 'S' :  f := writes;   GOTO l
            CASE 'c' :
            CASE 'C' :  f := wrch;     GOTO l
            CASE 'o' :
            CASE 'O' :  f := writeoct; GOTO m
            CASE 'x' :
            CASE 'X' :  f := writehex; GOTO m
            CASE 'i' :
            CASE 'I' :  f := writed;   GOTO m
            CASE 'n' :
            CASE 'N' :  f := writed;   GOTO l
                   m :  p := p + 1
                        n := format%p
                        IF 'a' LE n LE 'z' THEN n := n - 'a' + 'A'
                        n := '0' LE n LE '9' -> n - '0', n - 'A' + 10
                   l :  f(q, n)
            CASE '$' :  t := t + 1
         $)
      $)
      OR wrch(k)
   $)
$)
 
/*
AND writeoct(n, p) BE
$( IF p > 1 THEN writeoct(n >> 3, p - 1)
   wrch((n & #7) + '0')
$)
 
AND writehex(n, p) BE
$( LET m = n &#17
   IF p > 1 THEN writehex(n >> 4, p - 1)
   wrch(m + (m < 10 -> '0', 'A' - 10))
$)
 
AND writes(s) BE FOR i = 1 to s%0 DO wrch(s%i)
 
AND writeo(n) BE writeoct(n, 11)
 
AND writeh(n) BE writehex(n, 8)
 
AND writen(n) BE writed(n, 0)
 
AND newline() BE wrch('*N')
 
AND newpage() BE wrch('*P')
 
AND readn() = readnumber(10)
 
AND packstring(v, s) = VALOF
$( LET last.word = !v/bytesperword
 
   s!last.word := 0
   FOR i = 0 to !v DO s%i := v!i
   RESULTIS last.word
$)
 
AND unpackstring(s, v) BE
   FOR i = 0 TO s%0 DO v!i := s%i
*/
 
// Debugging and store allocation routines
 
MANIFEST $(
sv.size            = 80              // Size of system vector
sv.base            = -sv.size        // Global offset of base of system vector
$)

GLOBAL $(   // Items in system vector
svwrch             : sv.base+21      // Secret copy of 'wrch'
svgvsupport        : sv.base+68      // Entry to 'getvec' support code
$)

MANIFEST $(
quantum      = 32*1024   // In words
sizebits     = #xfffffffe
freebit      = 1
$)

STATIC $( blklist = ?; user.wrch = ? $)

LET contingency(class, subclass, dumpseg) BE
$( EXTERNAL $( uinfi $)

   LET dummy = ?
   AND mes = "Program failure"
   AND obey = uinfi(2) = 3
 
   TEST wrch = svwrch THEN user.wrch := 0
   OR
   $( user.wrch := wrch
      wrch := svwrch                    // Ensure we get diagnostic output
   $)

   discard.id()   // Re-allow interrupts

   selectoutput(journal)

   IF class = 65 THEN    // Breakin contingency
   $( console(7, @dummy, @dummy)   // Kill output
 
      IF subclass = 'C' \/ subclass = 'c' THEN
         console(8, @dummy, @dummy)   // Kill input

      IF obey THEN endobey()   // Scan to end of OBEY file
 
      writes("Breakin - exit*N")
      stop(-1)
   $)
 
   IF class = 64 THEN   // Run out of time
      mes := "CPU time exceeded"

   writef("*N*N%S", mes)

   UNLESS class = 64 DO
      writef("*NContingency class %N, subclass X%X8, PC = X%X8", class, subclass, dumpseg!2)

   newline()

   stop(-1)
$)
 
AND backtrace() BE RETURN
 
AND postmortem(lnb, sf, psr, pc) BE RETURN    // LNB and SF are word addresses
 
AND mapglobals(first, last) BE RETURN
 
AND mapstatics() BE RETURN
 
AND mapstore() BE RETURN
 
AND abort(n) BE
$( writef("*NBCPL Abort - User code = %N*N", n)
   IF n NE 0 THEN stop(n)
$)
 
AND getvec(n) = VALOF   // Called once only - then redirected to getblk
$( LET p = svgvsupport(0)   // Create workfile

   IF p < 0 RESULTIS 0
   p := (p >> 2) + 1   // Convert to BCPL address - ignore first word to preserve even size
   blklist, p!0, p!(quantum - 2) := p, (quantum - 2) \/ freebit, 0
   getvec := getblk   // The real space allocation routine
   RESULTIS getvec(n)
$)

AND getblk(n) = VALOF   // The real 'getvec'
$( LET p, q = 0, blklist

   n := n + 2   // Allow for secret word and zeroth word

   n := (n + 1) & sizebits   // Round to multiple of 2

   $( p := q

      // Chain through used blocks, looking for an unused one

      WHILE (!p & freebit) = 0 DO
      $( TEST !p = 0 THEN   // No space left - try to get more
         $( LET x = svgvsupport(1)   // Extend file

            IF x < 0 RESULTIS 0
            !p := quantum \/ freebit
            p!quantum := 0
            RESULTIS getvec(n - 2)
         $)
         OR
            p := p + !p
      $)

      q := p   // Chain to the end of this free area
      UNTIL (!q & freebit) = 0 DO
         q := q + (!q & NOT freebit)
   $) REPEATUNTIL q - p GE n   // Exit if large enough block found

   // Split block unless it is an exact fit

   UNLESS p + n = q DO
      p!n := (q - p - n) \/ freebit

   !p := n

   RESULTIS p + 1   // Return pointer, avoiding secret word
$)

AND freevec(p) BE
$( p := p - 1   // Point to true start of block

   !p := !p \/ freebit
$)

// End of file OLIBNSRC