// March 31, 1978 11:19 AM *** RESIDENT ***
// Utility routines
// Compile with FLOAT/M to get sTypeFloat
// Compile with SQRT/M to get SquareRoot
get "streams.d"
get "altoFileSys.d"
// outgoing procedures:
external [
confirm
getLine
typeForm
sTypeForm
SquareRoot
openRead
openWrite
abortMessage
FPerror
FatalError
capitalize
equal
]
// incoming procedures:
external [
Wss // SYSTEM
Wos
Wns
Gets
Puts
OpenFile
Closes
Zero
getBlock // free storage routines
putBlock
giveUp
FLD; FLDI; FST; FTR // FLOAT
FML; FDV; FAD; FSB
FSN; FCM; FNEG; FLDV
]
// incoming statics:
external [
keys // SYSTEM
dsp
]
// local definitions:
manifest [
getFloat= not newname FLOAT
getSqrt= not newname SQRT
]
//****************************************************************
// input/output procedures
//****************************************************************
let openRead(message, itemType, fileNameAd, fileFp; numargs n) = valof [openread
switchon n into [
case 1: itemType=wordItem
case 2: fileNameAd=0
case 3: fileFp=0
default: endcase
]
if fileFp ne 0 then Zero(fileFp, lFP)
[ typeForm(0, message)
let fileName=getLine()
unless fileName then resultis abortMessage()
let file=OpenFile(fileName, ksTypeReadOnly, itemType, 0, fileFp)
if file then [
test fileNameAd ne 0
ifso @fileNameAd=fileName
ifnot putBlock(fileName)
resultis file
]
typeForm(0, "No such file!*N")
putBlock(fileName)
] repeat
]openread
and openWrite(message, itemType, fileNameAd, fileFp; numargs n) = valof [openwrite
let file, fileName=nil, nil
switchon n into [
case 1: itemType=wordItem
case 2: fileNameAd=0
case 3: fileFp=0
default: endcase
]
[ typeForm(0, message)
fileName=getLine()
unless fileName then resultis abortMessage()
if fileFp ne 0 then Zero(fileFp, lFP)
file=OpenFile(fileName, ksTypeWriteOnly, itemType, verLatest, fileFp)
test file
ifso test confirm("Overwrite ? ")
ifso break
ifnot [ Closes(file); putBlock(fileName) ]
ifnot [
if fileFp ne 0 then Zero(fileFp, lFP)
file=OpenFile(fileName, ksTypeWriteOnly, itemType, verNew, fileFp)
break
]
] repeat
test fileNameAd ne 0
ifso @fileNameAd=fileName
ifnot putBlock(fileName)
resultis file
]openwrite
and abortMessage() = valof [
typeForm(0, "Abort*N")
resultis 0
]
and FatalError(message, error; numargs n) be [
typeForm(0, "SORRY: UNRECOVERABLE ERROR. Type any character to finish.",
0, "*NPlease contact your local software expert.*N", 0, message)
if n eq 2 then typeForm(10, error)
Gets(keys)
finish
]
and FPerror(error) = FatalError("Floating point error ", error)
and capitalize(char) = ((char ge $a) & (char le $z)) ? (char - #40), char
and equal(string1, string2) = valof [
let count=string1>>STRING.length
if count ne string2>>STRING.length then resultis false
for i=1 to count do
if capitalize(string1>>STRING.char↑i) ne
capitalize(string2>>STRING.char↑i) resultis false
resultis true
]
and confirm(message; numargs n) = valof [confirm
if n & message then typeForm(0, message, 0, " [ Yes No ] ")
[ switchon Gets(keys) into [
case $N:
case $n:
typeForm(0, "No*N")
resultis false
case $Y:
case $y:
case $*N:
typeForm(0, "Yes*N")
resultis true
] repeat
]confirm
//****************************************************************
// square root (optional)
//****************************************************************
and SquareRoot(a) be [
// a is FP pointer
compileif getSqrt then [
// FP accumulators
manifest [ r=0; t=1; q=2 ]
let rSave=vec 2; let tSave=vec 2; let qSave=vec 2
FST(r, rSave); FST(t, tSave); FST(q, qSave)
let two= table [ #40500; 0 ]
let prec= table [ #43516; #20000 ]
FLD(r, a)
if FSN(r) eq 0 return
if FSN(r) eq -1 then [ FNEG(r); FST(r, a) ]
FLDI(r, 1); FLD(q, prec)
while FCM(q, prec) ne 1 do [
// t←(r+a/r)/2
FLD(t, a); FDV(t, r); FAD(t, r); FDV(t, two)
// q←|r/(r-t)|
if FCM(r, t) eq 0 break
FLD(q, r); FSB(r, t); FDV(q, r)
if FSN(q) eq -1 then FNEG(q)
// r←t
FLD(r, t)
]
// result in a
FST(r, a)
FLD(r, rSave); FLD(t, tSave); FLD(q, qSave)
return
]
FatalError("Procedure SquareRoot not there!")
]
//***************************************************************
// keyboard input (with DISPLAY output)
//***************************************************************
and getLine(stream; numargs n) = valof [getLine
//string input terminated by carriage-return or escape
//returns string or 0
if n eq 0 then stream=dsp
manifest [ s=20 ]
let bsize, ncmax=s, s/2
let b=getBlock(bsize)
unless b resultis giveUp("[getLine]")
b!0=0
let nc, lc=0, 0
[loop
let c=Gets(keys)
switchon c into [
case #33:
case $*N:
// escape or carriage return => return string or 0
test nc
ifso [
Puts(stream, $*N)
b>>STRING.length=nc
resultis b
]
ifnot [
putBlock(b)
resultis 0
]
case #10:
// back space => delete last character
if nc ne 0 then [
Puts(stream, $\)
Puts(stream, b>>STRING.char↑nc)
nc=nc-1
endcase
]
case #177:
// delete => delete line
Wss(stream, " XXX ")
nc=0
endcase
default:
Puts(stream, c)
// pack new character into string
nc=nc+1
if nc eq ncmax then [
bsize=bsize+s
ncmax=ncmax+s/2
let d=b
b=getBlock(bsize)
unless b resultis giveUp("[getLine]", d)
for i=0 to bsize-s-1 do b!i=d!i
putBlock(d)
]
b>>STRING.char↑nc=c
]
]loop repeat
]getLine
//***************************************************************
// general stream output
//***************************************************************
and typeForm(f1, d1, f2, d2, f3, d3, f4, d4, nil, nil, nil, nil, nil, nil, nil,
nil; numargs n) be [
let p=lv f1
for i=0 to n-2 by 2 do sTypeF(dsp, p!i, p!(i+1))
]
and sTypeForm(s, f1, d1, f2, d2, f3, d3, f4, d4, nil, nil, nil, nil, nil, nil; numargs n) be [
let p=lv f1
for i=0 to n-3 by 2 do sTypeF(s, p!i, p!(i+1))
]
and sTypeF(stream, f, data) be [TypeF
switchon f into [
// floating point
case -2: sTypeFloat(stream, data); endcase
// unsigned octal
case -1: Wos(stream, data); endcase
//string
case 0: Wss(stream, data); endcase
//character
case 1: Puts(stream, data); endcase
//integer (f is radix)
default: Wns(stream, data, 0, f)
]
]TypeF
and sTypeFloat(stream, lvnum) be [sTypeFloat
compileif getFloat then [
FLD(1, lvnum)
let p=FSN(1)
if p eq 0 then [ Puts(stream, $0); return ]
if p eq -1 then [ FNEG(1); Puts(stream, $-) ]
FLDV(2, table [ 0; 1; #100000; 4 ]); //fuz1 = 1+2e-9
FML(2, 1) ; //n←fuz1*Number
FLDI(3, 1); FLDI(4, 10)
FLD(5, 2) //number
let p=0
while FCM(5, 4) eq 1 do [ FDV(5, 4); p=p+1 ]
while FCM(5, 3) eq -1 do [ FML(5, 4); p=p-1 ]
// ac5 has a number between 1 and 10, and p has power
FLD(6, table [ #031325; #163073 ]) //fuz2 = 5e-9
FML(6, 2) //s←fuz2 * n
let q=p
test p gr 7 % p ls -3 then p=0 or q=0
test p ls 0
ifso [
Puts(stream, $0); Puts(stream, $.)
for i=p to -2 do Puts(stream, $0)
for i=1 to -p do FDV(6, 4) //s=s e p
]
ifnot for i=1 to p do FML(6, 4)
// now print (s suppresses trailing zeroes)
for i=1 to 9 do [
let ipart=FTR(5)
Puts(stream, $0+ipart)
p=p-1
FLDI(7, ipart); FSB(5, 7); FML(5, 4)
if p ls 0 then [
if p eq -1 then Puts(stream, $.)
FML(6, 4); //s←s*10
if FCM(5, 6) eq -1 then break
]
]
if q then [ Puts(stream, $E); Wns(stream, q) ]
return
]
Wss(stream, " ### ")
]sTypeFloat