// Template.bcpl  --  Formatted printing procedure
//			E. Taft  -- September 1976
// Copyright Xerox Corporation 1979


external
   [
   // procedures defined herein
   PutTemplate; PutNum

   // procedures defined elsewhere
   Puts; Wss
   MyFrame; GotoFrame; CoReturn
   SysErr
   ]

manifest
   [
   // error codes
   ecTooFewArgsForTemplate = 2300
   ecMalformedTemplate = 2301
   ]

structure String: [ length byte; char^1,255 byte ]
structure NT:  // number template passed to PutNum
   [
   radix word	// numeric radix (in range [2,10])
   width word	// minimum field width
   signed word	// true for signed, false for unsigned
   double word	// true if double precision, false if single
   fill word	// fill character to replace leading spaces
   ]


// ----------------------------------------------------------------
let PutTemplate(str,template,args,nil,nil,nil,nil,nil,nil,nil,
   nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil; numargs na) be
// ----------------------------------------------------------------
// Copy the template string "template" to the stream "str",
// performing substitutions for escape sequences in the template
// of the form  $ number letter(s)  , where the letter(s) say what
// to do and the number is an optional argument (which may be
// omitted).  Each such escape sequence will result in substitution
// of the next parameter (starting at "args") at that point,
// with conversion performed as follows:
//	$S	the argument is a BCPL string
//	$US	the argument is an unpacked string
//	$C	the argument is a single character

// The following three specifications may be preceded by any
// combination (represented by "#" below) of:
// (1) a decimal number, specifying the minimum field width.
// (2) "U", specifying "unsigned" (default = signed)
// (3) "E", specifying "extended (32-bit rather than 16 bit, and
//     the argument is a pointer to the 32-bit number rather than
//     the number itself).
// (4) "Fx", specifying a filler character "x" to be used in place
//     of space when replacing leading zeroes.

//	$#D	the argument is a signed decimal number
//	$#O	signed octal
//	$#B	signed binary (for whatever that's worth)

//	$$	this is how you include a "$" literally
//	$P	calls the arg as a procedure, passing it the
//		stream and the next arg as arguments.
[
let frame = InterpretTemplate(str,lv args,na-2)  //init coroutine
for i = 1 to template>>String.length do  //feed chars to coroutine
   GotoFrame(frame,template>>String.char^i)
]

// ----------------------------------------------------------------
and InterpretTemplate(str,args,nArgs) be
// ----------------------------------------------------------------
// This procedure does the real work.
// It operates as a coroutine with PutTemplate.  Each CoReturn
// returns the next character from the template.
[
// the following variables must be declared in the order
// declared in the structure NT:
let radix, width, signed, double, fill = nil, nil, nil, nil, nil
let nt = lv radix
let i = 0  // init argument counter
   [
   let char = CoReturn(MyFrame())
   test char eq $$
      ifnot Puts(str,char)  //normal char, not in escape sequence
      ifso  //start of escape sequence
         [
         char = CoReturn()  //get char after "$"
         if char eq $$ then [ Puts(str,char); loop ]
         if i ge nArgs then SysErr(nArgs,ecTooFewArgsForTemplate)
         width = 0; signed = true; double = false; fill = $*s
            [  //repeat loop starts here.
               //Command characters that simply modify subsequent
               //characters finish with "endcase" so as to fall
               //through, get the next char, and loop.  Command
               //characters that actually execute the operation
               //and terminate an escape sequence end in "break".
            switchon char into
               [
               //non-terminating modifier characters
               case $0: case $1: case $2: case $3: case $4:
               case $5: case $6: case $7: case $8: case $9:
                  [ width = 10*width+char-$0; endcase ]
               case $U: case $u:  // "unsigned" or "unpacked"
                  [ signed = false; endcase ]
               case $E: case $e:  // "extended" (double precision)
                  [ double = true; endcase ]
               case $F: case $f:  //fill char replacing leading 0's
                  [ fill = CoReturn(); endcase ]

               //terminating command characters
               case $S: case $s:  //string argument
                  [
                  test signed  // U means unpacked in this context
                     ifso Wss(str,args!i)  // normal string
                     ifnot  // unpacked string
                        [
                        let v = args!i
                        for j = 1 to v!0 do Puts(str,v!j)
                        ]
                  break
                  ]
               case $C: case $c:  //single character argument
                  [ Puts(str,args!i); break ]
               case $D: case $d:  //decimal number
                  [ radix = 10; PutNum(str,args!i,nt); break ]
               case $O: case $o:  //octal number
                  [ radix = 8; PutNum(str,args!i,nt); break ]
               case $B: case $b:  //binary number
                  [ radix = 2; PutNum(str,args!i,nt); break ]
               case $P: case $p:  //arbitrary procedure call
                  [ (args!i)(str,args!(i+1)); i = i+1; break ]
               default:
                  SysErr(char,ecMalformedTemplate)
               ]
            char = CoReturn()
            ] repeat
         i = i+1
         ]
   ] repeat
]

// ----------------------------------------------------------------
and PutNum(str,arg,nt) be
// ----------------------------------------------------------------
[
let num0 = nil; manifest n0 = 7  //frame offset 7.
let num1 = nil; manifest n1 = n0+1
let negative = nil
let width = nt>>NT.width
test nt>>NT.double
   ifso
      [  // double-precision number
      num0 = arg!0
      num1 = arg!1
      negative = nt>>NT.signed & num0 ls 0
      ]
   ifnot
      [  // single-precision number
      num1 = arg
      negative = nt>>NT.signed & num1 ls 0
      num0 = negative  //extend sign (note true = -1, false = 0)
      ]
let v = vec 31  // Max space needed for unpacked digits
if negative then
   [
   (table
      [  //double-precision negate
       #21000+n0	// lda 0 n0 2
       #25000+n1	// lda 1 n1 2
      #124423		// negz 1 1 snc
      #100001		//  com 0 0 skp
      #100400		//  neg 0 0
       #41000+n0	// sta 0 n0 2
       #45000+n1	// sta 1 n1 2
        #1401		// jmp 1 3
      ])()
   width = width-1  // Space for minus sign
   ]
let i = 0
   [
   v!i = (table	// Divide (num0,num1) by radix, put quotient back
      [		//  in (num0,num1), and return remainder.
       #55001		// sta 3 1 2
      #155000		// mov 2 3	// preserve frame pointer
      #111000		// mov 0 2	// ac2 _ radix
       #25400+n0	// lda 1 n0 3	// get num0 (high part)
      #102460		// mkzero 0 0	// high dividend  =  0
       #61021		// div
       #77400		// Swat		// if divide fails
       #45400+n0	// sta 1 n0 3	// store high quotient
       #25400+n1	// lda 1 n1 3	// get num1 (low part)
       #61021		// div
       #77400		// Swat
       #45400+n1	// sta 1 n1 3	// store low quotient
      #171000		// mov 3 2	// recover frame
       #35001		// lda 3 1 2
        #1401		// jmp 1 3
      ])(nt>>NT.radix)
   i = i+1
   ] repeatuntil num0 eq 0 & num1 eq 0
while width gr i do [ Puts(str,nt>>NT.fill); width = width-1]
if negative then Puts(str,$-)
while i ne 0 do [ i = i-1;  Puts(str,$0+v!i)]
]