[Indigo]<AltoSource>IF.BCPL!1

// If //
// Copyright Xerox Corporation 1979

// Modified July 9, 1982 8:47 AM by Swinehart -- add /c switch, unload /w switch
// Last modified December 4, 1979 10:13 AM by Deutsch
// Last modified October 12, 1979 9:25 AM by Newell
// Last modified October 8, 1979 7:21 PM by Taft
// Martin Newell. December 1978.

// If implements conditional execution of groups of commands
// to the Alto Executive.
//
// SYNTAX
//
// If <condition> [then <commands>] [else <commands>]
//
// where [] denotes an optional clause, and
// <condition> is one of:
// filename (yields true if file exists)
// filename/l=N (yields true if length of file = N)
// filename/l<N (yields true if length of file < N)
// filename/l>N (yields true if length of file > N)
// filename/s"string" (yields true if file contains string)
// filename/r=otherfilename/r (yields true if read date of
// file = read date of otherfile)
// {similarly with < or >}
// {similarly with either or both ’r’ changed to ’w’ meaning
// write date, or ’c’ meaning the creation date}
// and N is a decimal constant
// <commands> is any string of Alto executive commands
// separated by ’;’.
// Note necessity to escape semicolon past the Executive
// command line reader.
// It is possible to nest Ifs by enclosing <commands> in braces
// (’{’ and ’}’): the braces will be removed, but occurrences of
// " then " or " else " within the braces will not terminate the
// <commands> with respect to the outer If.
//
// SEMANTICS
// In the case that <condition> yields true the <commands>
// in the then clause (if present) are passed to the
// Executive for execution, otherwise the <commands> in the
// else clause (if present) are passed.
//
// EXAMPLE I:
//
// Compiler prog.mesa
// If prog.errlog then bravo/m prog else mesa prog
//
// This is a modification of the m quit macro in bravo for
// mesa.
//
// EXAMPLE II:
// The equivalent in the bcpl world is:
//
// bcpl/f prog.bcpl
// If prog.bt/s+ERROR+ then bravo/b prog else bldr prog
//
// EXAMPLE III:
//
// If prog.mesa/w>prog.bcd/w then Compiler prog.mesa
//

// To load:
// Bldr 100/w If KPMTemplatea KPMTemplateb
// (change the 100 to a larger number if Bldr complains about
// insufficient space for statics)

get "streams.d"
get "altofilesys.d"
get "disks.d"// No other way to get file read/write dates!

external [ BFSActOnPages; CharWidth; Closes; Endofs; EraseBits
FalsePredicate; FileLength; FilePos; FindFdEntry
Gets; MoveBlock; OpenFile; OpenFileFromFp
ParseFileName; Puts; ReadBlock; Resets
SysErr; Timer; TruncateDiskStream; Usc
Wns; Wos; WriteBlock; Wss; Zero
dsp; fpComCm; fpRemCm; fpSysDir; keys; sysZone; sysDisk
]

external [ MakeKPMTemplate; MatchKPMTemplate ]

static [ doch //Last char read from .do file
Scom //input stream from com.cm
comch //Last char read from com.cm (Scom)
DotInFileName //set in ReadFileName
depth//Depth of nesting in braces, see AccountGets
]

manifest [ Buffsize=5000; pLeftBrace=${; pRightBrace=$};
pHerald=$#; pEscape=$"; bs=#10 ]

let Main() be
[main
let Srem=0
and Scratch=0
and ch=0
and Buffer=vec Buffsize
and Nread=0

Scom=OpenFile("com.cm",ksTypeReadOnly,charItem,0,fpComCm)
Srem=OpenFile("rem.cm",ksTypeReadWrite,charItem,0,fpRemCm)
Nread=ReadBlock(Srem,Buffer,Buffsize)
test Endofs(Srem)
then
[ Resets(Srem)
Transcribe(Scom,Srem)
if (FilePos(Srem)&1) eq 1 do Puts(Srem,$*n) //word boundary for:
WriteBlock(Srem,Buffer,Nread)
TruncateDiskStream(Srem)
]
or
[ Scratch=OpenFile("if.scratch",ksTypeReadWrite,charItem)
WriteBlock(Scratch,Buffer,Nread)
Copystream(Srem,Scratch,Buffer,Buffsize)
Resets(Srem); Resets(Scratch)
Transcribe(Scom,Srem)
Copystream(Scratch,Srem,Buffer,Buffsize)
Closes(Scratch)
]
Closes(Scom); Closes(Srem)
]main

and Transcribe(Scom,Srem) = valof
[T
let name=vec maxLengthFnInWords
and sw=$*s
comch=Gets(Scom) repeatuntil
Endofs(Scom) % (comch eq $*n) %
((comch ne $*s) & (comch ne $*t)) //find command
until Endofs(Scom) % WhiteSpace(comch)
do comch=Gets(Scom) //skip over command
if ReadFileName(Scom,name) do
[ test valof
[ if comch eq $/ do sw=Gets(Scom) //read switch
switchon sw into
[ case $l: //length
case $L:
[ let S=OpenFile(name,ksTypeReadOnly, charItem)
and length = (S? FileLength(S), 0)
resultis selecton Gets(Scom) into //the operator
[ case $=: length eq Readn(Scom)
case $<: Usc(length, Readn(Scom)) ls 0
case $>: Usc(length, Readn(Scom)) gr 0
default: length ne 0
]
]
case $r: //read date
case $R:
case $w: //write date
case $W:
case $c:// create date
case $C:
[ let time1, time2 = vec lTIME, vec lTIME
and chrel = nil
GetFileDate(name, sw, time1)
chrel = Gets(Scom)//relation character
ReadFileName(Scom, name)
if comch eq $/ then sw = Gets(Scom)
GetFileDate(name, sw, time2)
resultis selecton chrel into
[ case $=: LongUsc(time1, time2) eq 0
case $<: LongUsc(time1, time2) ls 0
case $>: LongUsc(time1, time2) gr 0
default: false
]
]
case $s: //contains string
case $S:
[ let S=OpenFile(name,ksTypeReadOnly, wordItem)
and str=vec 256
and term=Gets(Scom)
and ch=Gets(Scom)
and len=0
// read string to be matched
[ until ch eq term do
[ if len ge 126 do Abort("String too long")
len=len+1; str!len=ch
ch=Gets(Scom)
]
test Gets(Scom) eq term //used as escape?
then
[ if len ge 126 do Abort("String too long")
len=len+1; str!len=term
ch=Gets(Scom)
]
or break
] repeat
str!0=len
resultis S ? MatchInStream(str,S), false
]
default:
resultis LookupFileName(name, 0)
]
]
then
[ if ScanFor(Scom,"then") do
CopyUntil(Scom,Srem,"else")
]
or
[ if ScanFor(Scom,"else") do
CopyUntil(Scom,Srem,"then")
]
]
]T

and ScanFor(s,str) = valof
//scan, discarding, up to and including str plus delimeter
//Ignore occurrences within braces
[C
let unstrU=vec 256
and unstrL=vec 256
and found=0
and ch=0
and len=UnPackUL(str,unstrU,unstrL)
depth=0
// scan for str
[ while depth ne 0 do
[ if Endofs(s) resultis false
AccountGets(s)
]
found=true
for i=1 to len do
[ if Endofs(s) resultis false
ch = AccountGets(s)
if (ch ne unstrU!i) & (ch ne unstrL!i) do
[ found=false; break ]
]
if found do
[ unless Endofs(s) do
[ if WhiteSpace(AccountGets(s)) resultis true ]
]
until ch eq $*s do
[ if Endofs(s) resultis false
ch = AccountGets(s)
]
] repeat
]C

and CopyUntil(s,s2,str) be
//Copy from s to s2 up to and discarding str plus delimiter
//Ignore occurrences within braces
[C
let unstrU=vec 256
and unstrL=vec 256
and strbuf=vec 256
and index=0 //used as found flag
and ch=0
and len=UnPackUL(str,unstrU,unstrL)
depth=0
//scan for str
[ while depth ne 0 do
[ if Endofs(s) return
ch = AccountPuts(s2,Gets(s))
]
index=-1
for i=1 to len do
[ if Endofs(s) return
ch = Gets(s); strbuf!i = ch
if (ch ne unstrU!i) & (ch ne unstrL!i) do
[ index=i; break ]
]
//if string matched, check delimiter
if index eq -1 do
[ unless Endofs(s) do
[ ch=Gets(s)
unless WhiteSpace(ch) do index=len
]
]
test index eq -1
then //found
[ Puts(s2,$*n)
return
]
or //output matched chars followed by unmatched one
[ for i=1 to index-1 do Puts(s2,strbuf!i)//not braces
AccountPuts(s2,ch)
]
// scan for next delimiter
until WhiteSpace(ch) do
[ if Endofs(s) return
ch = Gets(s)
AccountPuts(s2,ch)
]
] repeat
]C

and UnPackUL(str,strU,strL) = valof //Unpack into upper and lower case versions. Returns length
[UP
let ch=0
and len=str>>STRING.length
// unpack str into Upper and Lower case versions
strU!0,strL!0 = len,len
for i=1 to len do
[ ch = str>>STRING.char↑i & #337 //i.e. Upper case if letter
test ($A le ch) & (ch le $Z)
then [ strU!i = ch; strL!i = ch + #40; ]
or
[ strU!i = str>>STRING.char↑i
strL!i = strU!i
]
]
resultis len
]UP

and AccountGets(s) = valof
//Get character from s and adjust depth
[AG
let ch = Gets(s)
test ch eq pLeftBrace
then depth = depth+1
or if ch eq pRightBrace
then depth = depth-1
resultis ch
]AG

and AccountPuts(s,ch) = valof
//Put ch on s if not an outermost brace, and adjust depth
[AC
test ch eq pLeftBrace then
[ if depth ne 0 then Puts(s,ch)
depth = depth+1
]
or test ch eq pRightBrace then
[ depth = depth-1
if depth ne 0 then Puts(s,ch)
]
or Puts(s,ch)
resultis ch
]AC

and MatchInStream(str,S) = valof
//search for unpacked string str in stream S
//str must contain no more than 126 chars
//S must be a word stream
[MIS
let buffer=vec 128
and pstr=vec 64
and tmplt=0
and nread=0
and len=str!0

//pack str with prefix and postfix * for wildcard
for i=1 to len do pstr>>STRING.char↑(i+1) = str!i
pstr>>STRING.char↑1 = $**
pstr>>STRING.char↑(len+2) = $**
pstr>>STRING.length = len+2

tmplt = MakeKPMTemplate(pstr)
buffer!0=#177400 //string length 255, first char 0
Zero(buffer+1,63)
nread = ReadBlock(S,buffer+1,63)
[ Zero(buffer+64,63)
nread=ReadBlock(S,buffer+64,63)
if MatchKPMTemplate(buffer,tmplt) eq 0 do resultis true
MoveBlock(buffer+1,buffer+64,63)
] repeatuntil nread ne 63
resultis false
]MIS

and Abort(str) be
[C
Wss(dsp,str);Puts(dsp,$*n)
// Should really ask for effective result of the if command to be typed in here and insert it into rem.cm
finish
]C

and Copystream(s1,s2,Buf,Bufsiz) be
[C
until Endofs(s1) do
[ let Nread=ReadBlock(s1,Buf,Bufsiz)
WriteBlock(s2,Buf,Nread)
]
]C

and ReadString(Si,So,String,StringChar,EscapeChar) = valof
[Rt let ch=0
and escape=false
String>>STRING.length=0
until MyEndofs(Si) do //find first valid char
[ ch=PromptGets(Si,So,escape?EscapeChar,$|)
if StringChar(ch) do break
]
if MyEndofs(Si) do resultis ch //didn’t find a string
[mainloop
switchon ch into
[ default: test escape % ch ne EscapeChar
then [ if So do Puts(So,ch)
unless StringChar(ch)%escape do break
String>>STRING.length=String>>STRING.length+1
String>>STRING.char↑(String>>STRING.length)=ch
escape=false
]
or escape=true
endcase
case bs: test escape then escape=false
or [ if String>>STRING.length ne 0 do
[ if So do EraseBits(So,-CharWidth(So,String>>STRING.char↑(String>>STRING.length)))
String>>STRING.length=String>>STRING.length - 1
]
]
endcase
case $:̆ escape=false
let width=0
while String>>STRING.length gr 0 do
[ width=width+CharWidth(So,String>>STRING.char↑(String>>STRING.length))
String>>STRING.length=String>>STRING.length - 1
if String>>STRING.length eq 0 %
String>>STRING.char↑(String>>STRING.length) eq $*S %
String>>STRING.char↑(String>>STRING.length) eq $*T do break
]
EraseBits(So,-width)
endcase
]
if MyEndofs(Si) do break
ch=PromptGets(Si,So,escape?EscapeChar,$|)
]mainloop repeat
resultis ch
]Rt

and ReadFileName(S,name) = valof
[RFN
let ch=0
ch=ReadString(S, S eq keys?dsp,0, name, Filechar, 0)
DotInFileName=false
for i= 1 to name>>STRING.length do
if name>>STRING.char↑i eq $. do DotInFileName=true
if S eq Scom do comch=ch
resultis name>>STRING.length > 0
]RFN
and Filechar(ch) = ((ch ge $A) & (ch le $Z)) %
((ch ge $a) & (ch le $z)) %
((ch ge $0) & (ch le $9)) %
(ch eq $+) %
(ch eq $-) %
(ch eq $.) %
(ch eq $!) %
(ch eq $$)

and Readn(S) = valof //assumes first char of number next
[readn
let N=0
doch=echoGets(S)
while doch ge $0 & doch le $9 do
[ N=N*10 + (doch-$0)
doch=echoGets(S)
]
resultis N
]readn

and PromptGets(Si,So,prompt) = valof
[PG let Tv=vec 2
and on=false
if Si eq keys & Endofs(Si) do
[ [ let T=Timer(Tv)+600
on=not on
test on
then Puts(So,prompt)
or EraseBits(So,-CharWidth(So,prompt))
while Timer(Tv) ls T do
unless Endofs(Si) do break
] repeatwhile Endofs(Si)
if on do EraseBits(So,-CharWidth(So,prompt))
]
resultis Gets(Si)
]PG

and echoGets(S) = valof
[e let ch=Gets(S)
if S eq keys do Puts(dsp,ch)
resultis ch
]e

and MyEndofs(S) = Endofs(S) & (S ne keys)

and WhiteSpace(ch) = (ch eq $*s) % (ch eq $*t) % (ch eq $*n)

and LongUsc(ln1, ln2) =
//Double-precision unsigned compare, for dates and file lengths
(ln1!0 ne ln2!0? Usc(ln1!0, ln2!0), Usc(ln1!1, ln2!1))

and GetFileDate(name, ch, time) be
//Get read or write date (ch=$r or $w) from file to vector time
[GFD
let dv = vec lDV
unless LookupFileName(name, dv) do
[ Zero(time, lTIME)
return
]
let ld = vec 256
//The following is really unfortunate, should be an OS call
let fp = lv dv>>DV.fp
let DAs = vec 2
DAs!0, DAs!1 = fp>>FP.leaderVirtualDa, fillInDA
BFSActOnPages(sysDisk, lv ld, DAs, fp, 0, 0, DCreadD)
switchon ch into
[ case $r:// read date
case $R:
MoveBlock(time, lv ld>>LD.read, lTIME)
endcase
case $w: // read date
case $W:
MoveBlock(time, lv ld>>LD.written, lTIME)
endcase
case $c:
case $C:// create
MoveBlock(time, lv ld>>LD.created, lTIME)
endcase
default: Abort("Switch error")
]
]GFD