// 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)]
]