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