// FancyTemplate.bcpl -- Formatted printing procedure w/
//special extra added bells, whistles, and so on.
//E. Taft -- September 1976
//glorified, expanded, and slowed down by
//E. McCreight -- January 24, 1978 3:11 PM
external
[
// procedures defined herein
PutTemplate; PutTemplateWithHelp; PutTempStrmWithHelp
PutNum; TemplateGetArg
// procedures defined elsewhere
Puts; Wss; Gets; Endofs
ReturnFrom; MyFrame
FalsePredicate; SysErr
]
manifest
[
// error codes
ecTooFewArgsForTemplate = 2300
ecMalFormedTemplate = 2301
]
structure String: [ length byte; char↑1,255 byte ]
structure AS:// argument structure, correlates with latter args & early
// local variables of InterpretTemplate
[
resultStream word
args word
nArgs word
templStream word
argIndex word
char word// last escape character
radix word// numeric field (in range [2...16])
width word// minimum field width
justifyLeft word// true if left-justified, false otherwise
signed word// true if signed or packed, false if unsigned or unpacked
double word// true if double precision, false otherwise
fill word// fill character to replace leading spaces
]
structure PTS:// PutTemplate stream
[
source word// either a stream or a string
sourceIndex word// index of next string character
sourceIsStream word// true if stream, false if string
Gets word
exitFrame word// frame from which to exit when
// template runs out
unused word 3
Endofs word
]
// --------------------------------------------------------------
let PutTemplate(stream, template, args, nil, nil, nil, nil, nil, nil, nil,
nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil;
numargs na) be
// --------------------------------------------------------------
[
InterpretTemplate(FalsePredicate, template, false, stream, lv args, na-2)
]
// --------------------------------------------------------------
and PutTemplateWithHelp(Oracle, stream, template, args, nil, nil, nil, nil, nil, nil, nil,
nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil;
numargs na) be
// --------------------------------------------------------------
[
InterpretTemplate(Oracle, template, false, stream, lv args, na-3)
]
// --------------------------------------------------------------
and PutTempStrmWithHelp(Oracle, stream, tempstrm, args, nil, nil, nil, nil, nil, nil, nil,
nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil;
numargs na) be
// --------------------------------------------------------------
[
InterpretTemplate(Oracle, tempstrm, true, stream, lv args, na-3)
]
// --------------------------------------------------------------
and InterpretTemplate(Oracle, source, isStream, resultStream, args, nArgs) be
// --------------------------------------------------------------
[
let ptstream = vec size PTS/16
ptstream>>PTS.Gets = PTGets
ptstream>>PTS.Endofs = PTEndofs
ptstream>>PTS.source = source
ptstream>>PTS.sourceIndex = 1
ptstream>>PTS.sourceIsStream = isStream
ptstream>>PTS.exitFrame = MyFrame()
let argIndex, char, radix, width, justifyLeft, signed, double, fill =
0, nil, nil, nil, nil, nil, nil, nil
let as = lv resultStream
[// repeat
char = Gets(ptstream)
test char eq $$
ifnot Puts(resultStream, char)
ifso
[ // start of escape sequence
char = Gets(ptstream)
if char eq $$ then [ Puts(resultStream, $$); loop ]
width = 0; signed = true; double = false; fill = $*s
justifyLeft = false
[ // repeat until command character
switchon char into
[ // modifier characters
case $0 to $9:
width = 10*width+char-$0
endcase
case $U: case $u: // unsigned
signed = false
endcase
case $E: case $e: // "extended" (double precision)
double = true
endcase
case $F: case $f: // new fill character
fill = Gets(ptstream)
endcase
case $L: case $l: // justify left
justifyLeft = true
endcase
// command characters
case $S: case $s: // string
[
let s = TemplateGetArg(as)
width = width-(signed?
s>>String.length, s!0)
unless justifyLeft do
for i=1 to width do
Puts(resultStream, fill)
test signed // U means unpacked
ifso Wss(resultStream, s)
ifnot for i=1 to s!0 do
Puts(resultStream, s!i)
if justifyLeft do
for i=1 to width do
Puts(resultStream, fill)
]
break
case $C: case $c: // single character
Puts(resultStream, TemplateGetArg(as))
break
case $D: case $d: // decimal number
radix = 10
PutNum(as)
break
case $B: case $b: // binary number
radix = 2
PutNum(as)
break
case $O: case $o: // octal number
radix = 8
PutNum(as)
break
case $X: case $x: // hexadecimal number
radix = 16
PutNum(as)
break
case $P: case $p: // procedure call
[
let P = TemplateGetArg(as)
P(resultStream, TemplateGetArg(as))
]
break
default:
unless Oracle(as) do
SysErr(as, ecMalFormedTemplate)
break
]
char = Gets(ptstream)
] repeat
]
] repeat
]
// --------------------------------------------------------------
and PutNum(as) be
// --------------------------------------------------------------
[
let num0 = nil; manifest n0 = 5 // frame offset 5.
let num1 = nil; manifest n1 = n0+1
let negative = nil
let width = as>>AS.width
let arg = TemplateGetArg(as)
test as>>AS.double
ifso
[
// double-precision number
num0 = arg!0
num1 = arg!1
negative = as>>AS.signed & num0 ls 0
]
ifnot
[
// single-precision number
num1 = arg
negative = as>>AS.signed & num1 ls 0
num0 = negative // extends sign: -1 if negative, 0 if non-negative
]
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
] )()
]
let i=0
[
v!i = (table [ $0; $1; $2; $3; $4; $5; $6; $7; $8; $9;
$a; $b; $c; $d; $e; $f ])!
((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; ac1 ← num0 (high part)
#102460// mkzero 0 0; high dividend ← 0
#61021// div
#77400// Swat; if divide fails
#45400+n0// sta 1 n0 3; num0 ← quotient (high)
#25400+n1// lda 1 n1 3; ac1 ← num1 (low part)
#61021// div
#77400// Swat
#45400+n1// sta 1 n1 3; num1 ← quotient (low)
#171000// mov 3 2; recover frame
#35001// lda 3 1 2
#1401// jmp 1 3
] )(as>>AS.radix))
i = i+1
] repeatuntil num0 eq 0 & num1 eq 0
width = width-i-(negative? 1, 0)
let justifyLeft = as>>AS.justifyLeft
let resultStream = as>>AS.resultStream
let fill = as>>AS.fill
unless justifyLeft do for j=1 to width do Puts(resultStream, fill)
if negative then Puts(resultStream, $-)
while i gr 0 do [ i=i-1; Puts(resultStream, v!i) ]
if justifyLeft then for j=1 to width do Puts(resultStream, fill)
]
// --------------------------------------------------------------
and TemplateGetArg(as) = valof
// --------------------------------------------------------------
[
let argIndex = as>>AS.argIndex
let nArgs = as>>AS.nArgs
if argIndex ge nArgs then SysErr(nArgs, ecTooFewArgsForTemplate)
as>>AS.argIndex = argIndex+1
resultis (as>>AS.args)!argIndex
]
// --------------------------------------------------------------
and PTGets(ptstream) = valof
// --------------------------------------------------------------
[
let source = ptstream>>PTS.source
let sourceIndex = ptstream>>PTS.sourceIndex
let isStream = ptstream>>PTS.sourceIsStream
if isStream? Endofs(source),
(sourceIndex gr source>>String.length) then
ReturnFrom(ptstream>>PTS.exitFrame, 0)
resultis isStream? Gets(source),
valof
[
ptstream>>PTS.sourceIndex = sourceIndex+1
resultis source>>String.char↑sourceIndex
]
]
// --------------------------------------------------------------
and PTEndofs(ptstream) = ptstream>>PTS.sourceIsStream?
Endofs(ptstream>>PTS.source),
(ptstream>>PTS.sourceIndex gr
(ptstream>>PTS.source)>>String.length)
// --------------------------------------------------------------