// ScanStrings.bcpl

// ScanInit(b,file) (b= vec SCANIlen).  Sets up a scan
//	control block, using specified file to read from.
// ScanClose() Closes current file.
// ScanSet(b) (b = vec SCANIlen) use this file for scanner.
//	b is set up with ScanInit
//	Returns old pointer, if any, so you may restore.
// Scan() => token identifier (numbers defined in scan.defs)
// ScanFor(token) scans to be sure next thing is "token"
// ScanUntil(token) scans until token detected
//		(if token=RPAREN, must be at this "level")
// ScanBack(token) arranges to have next token be token
// ScanGiveID() returns pointer to string last scanned as ID.
// ScanCh()  returns a single character from the file.

// ReadNumber(STR) parses a number in STR format
//		result in FPAC 1; integer part is result of fcn
//		will handle numbers up to 2^16-1 (unsigned)
// PrintNumber(STR,num [,radix])
// PrintFloat(str,lvnum)	Prints floating point number.


// StrEq(a,b) => true if two strings equal
// StrCop(f,t) copy STR f to STR t
// Type(STR)  type string on terminal
// TypeIn(STR)  get a string from the terminal, terminated by CR
// TypeForm(xxxxx)
//	Types a formatted message. For each entry in the call,
//	If it is not in the range 0-#177, type it as a string ptr.
//	Otherwise if it is:
//	0 -- type carriage-return line feed
//	1 -- use the next entry as a string pointer to accept typein
//	2 -- print the next entry as a floating point number
//	3 -- Double precision (fixed,fraction)
//	4 -- Double integer
//	8,10 -- print the next entry as a number in corresonding
//		radix
//	default -- print it as a single character.

// ReadCom(str,sw) =res
//		Reads command file and returns true if more
//		there.  STR will contain string; sw if present
//		is a list of switches (sw!0= # of sw's)
// ReadComInit() starts it off


get "scanstrings.d"
get "streams.d"

// outgoing procedures
external
	[
	Scan
	ScanFor
	ScanUntil
	ScanInit
	ScanClose
	ScanSet
	ScanBack
	ScanGiveID
	ScanCh

	ReadNumber
	PrintNumber
	PrintFloat

	StrEq
	StrCop
	Type
	TypeIn
	TypeForm

	ReadComInit
	ReadCom
	]

// outgoing statics
external
	[
	outstream		//If non-zero, use for typing.
	ScanSavedLetter
	]
static
	[
	outstream
	ScanSavedLetter
	]

// incoming procedures
external
	[
	Scream			//This is for reporting errors

//OS
	Gets
	Puts
	Endofs
	OpenFile
	Closes
	Wss
	Zero

//FLOAT
	FLD;FST;FTR;FLDI;FNEG;FAD;FSB;FML;FDV;FCM;FSN
	FLDV;FSTV;FLDDP;FSTDP;DPAD;DPSB

//SDialog
//	DlgInit
//	DlgStr

	]

// incoming statics
external
	[
	fpComCm
	keys
	dsp
	]

// internal statics
static
	[
	coms
	sc
	]

// File-wide structure and manifest declarations.

structure STR: [
	length byte
	char^1,255 byte
]

manifest strlen=10		//number of words

manifest [ DEL=#177
				CONTROLA=1
				BACKSPACE=$H-$A+1
			 ]
// Procedures

let

//Scanner routines.

ScanInit(b,s) be [
	Zero(b, SCANIlen)
	let str=OpenFile(s, ksTypeReadOnly, 1)
	if str eq 0 then Scream("File not found")
	b>>SCANI.stream=str
]

and

ScanClose() be Closes(sc>>SCANI.stream)

and

Scan() = valof [
	let ins=sc>>SCANI.stream
	let lastch=sc>>SCANI.lastch
	let ch=sc>>SCANI.backtoken
	if ch ne 0 then
		[
		sc>>SCANI.backtoken=0
		resultis ch
		]
	test lastch eq 0 then ch=Gets(ins) or ch=lastch
	let idname=lv sc>>SCANI.idname
	sc>>SCANI.lastch=0
[	if Endofs(ins) then resultis EOF
	let c=getcharclass(ch)
	switchon c into
	[
	case 0:	//separator...
		endcase
	case 1: // left parenthesis.
		if Endofs(ins) then resultis LPAREN
		ch=Gets(ins)
		if getcharclass(ch) eq 2 then resultis SNIL
		sc>>SCANI.lastch=ch
		resultis LPAREN
	case 2: resultis RPAREN
	case 3: [ // "
		let cn=0
		[ if Endofs(ins) then break
		  ch=Gets(ins)
		  if getcharclass(ch) eq 3 then break
		  cn=cn+1
		  idname>>STR.char^cn=ch
		] repeat
		idname>>STR.length=cn
		resultis STRING
		]
	case 4: resultis SLASH
	case 5:
	case 6: [ //Scan into an identifier.
		let firstclass=c
		let cn=0
		[
		  ScanSavedLetter=ch
		  if $a le ch & ch le $z then ch=ch-$a+$A
		  cn=cn+1
		  idname>>STR.char^cn=ch
		  if Endofs(ins) then break
		  ch=Gets(ins)
		  let c=getcharclass(ch)
		  if c ls 5 then break //out of bounds.
		] repeat
		idname>>STR.length=cn
		sc>>SCANI.lastch=ch
		let failflg=true		//try number, but may not be one
		if firstclass eq 5 then ReadNumber(idname,1,lv failflg);
		resultis (failflg? ID,NUMBER)
		]
	case 7:	resultis EQUAL
	]
	ch=Gets(ins)
] repeat
]

and

ScanFor(token) be [
	let c=Scan()
	if c ne token then Scream("Format")
]

and

ScanUntil(token) be [
	let level=0
	[
	let c=Scan()
	if c eq token then
		[
		if token ne RPAREN % level eq 0 then return
		]
 	if c eq LPAREN then level=level+1
	if c eq RPAREN then level=level-1
	] repeat
]

and

ScanBack(token) be [
	sc>>SCANI.backtoken=token
]

and

ScanSet(b) = valof [
	let c=sc
	sc=b
	resultis c
]

and

ScanGiveID() = lv sc>>SCANI.idname

and

ScanCh() = valof
[
	let ch=sc>>SCANI.lastch
	sc>>SCANI.lastch=0
	if ch then resultis ch
	let ins=sc>>SCANI.stream
	if Endofs(ins) then resultis EOF
	ch=Gets(ins)
	resultis ch
]

and

getcharclass(ch) = valof [
	switchon ch into
	[
	case $*s: case $*l: case $*n: case #11: 
		resultis 0
	case $(:
		resultis 1
	case $):
		resultis 2
	case $":
		resultis 3
	case $/:
		resultis 4
	case $-: case $.: case $0: case $1: case $2: case $3:
	case $4: case $5: case $6: case $7: case $8: case $9:
		resultis 5
	case $=:
		resultis 7
	default:
		resultis 6
	]
]

and

//Number reading and printing....

ReadNumber (str,x,fail;numargs n) = valof [
// Read a number from str and return it in FPAC 1
// uses FPAC's 2,3,4
// Set @fail if it turns out not to be a number.
	if n eq 1 then x=1
	let a=nil
	if n ls 3 then fail=lv a
	@fail=false
	let octn=0
	let sign=false
	FLDI(1,0); FLDI(4,10); FLDI(2,1)
	let pseen=false
	for i=x to str>>STR.length do 
		[
		let ch=str>>STR.char^i
		test ch eq $. then pseen=true or
		test ch eq $- then sign=not sign or
		test $0 le ch & ch le $9 then
			[
			FLDI(3,ch-$0)
			test pseen
				ifso [ FDV(2,4); FML(3,2) ]
				ifnot FML(1,4)
			FAD(1,3)
			octn=(octn lshift 3)+ch-$0
			]
			or
		test ch eq $E then
			[ //exponent...
			let flg=nil
			let s=vec 2; FST(1,s);
			ReadNumber(str,i+1,lv flg)
			if flg then [ @fail=true; break ]
			let exp=FTR(1)
			FLD(1,s)
			FLDI(4,10)
			while exp gr 0 do [ FML(1,4); exp=exp-1 ]
			while exp ls 0 do [ FDV(1,4); exp=exp+1 ]
			break
			] or
		test ch eq $Q then FLDI(1,octn) or
			[
			@fail=true
			break		//Don't try to parse any more
			]
		]
	if @fail ne 0 & n ls 3 then Scream("ReadNumber: format")
	if sign then FNEG(1)
	resultis(FTR(1))
]

and

PrintNumber(str,n,radix,pos; numargs a) be [
	if a ls 4 then str>>STR.length=0
	if a ls 3 then radix=10
	if n ls 0 then
		[
		n=-n
		pb(str,$-)
		]
	printnumber2(str,n,radix)
]

and

printnumber2(str,n,radix) be [
	let f=n/radix
	if f ne 0 then printnumber2(str,f,radix)
	pb(str,$0+(n rem radix))
]

and

PrintFloat(s,lvnum) be [
	let v=vec 4*5
	for i=1 to 4 do FSTV(i,v+4*i)
	@s=0
	FLD(1,lvnum)
	let p=FSN(1)
	test p eq 0 then pb(s,$0) or [		//Really work
	if p eq -1 then [ FNEG(1); pb(s,$-) ]

	FLDV(2,table [ 0; 1; #100000; 4 ]); 	//Fuzz1= 1+2E-9
	FML(1,2)	//n_fuzz1*number
	FLDI(3,1);FLDI(2,10)
	FLD(4,1)	//number
	p=0
	while FCM(4,2) eq 1 do [ FDV(4,2); p=p+1 ]
	while FCM(4,3) eq -1 do [ FML(4,2); p=p-1 ]

// 4 has  number between 1 and 10, and p has power

	FLD(3,table [ #031325; #163073 ])	//Fuzz2 = 5E-9
	FML(3,1)	//s_fuzz2 * n
	let q=p
	test p gr 7 % p ls -3 then p=0 or q=0
	test p ls 0 then [ pb(s,$0); pb(s,$.)
		for i=p to -2 do pb(s,$0)
		for i=1 to -p do FDV(3,2)	//s=s E P
	] or [	for i=1 to p do FML(3,2) ]

//now print (s suppresses trailing zeroes)

	for i=1 to 9 do [
		let ipart=FTR(4)
		pb(s,$0+ipart)
		p=p-1
		FLDI(1,ipart); FSB(4,1); FML(4,2)
		if p ls 0 then [
			if p eq -1 then pb(s,$.)
			FML(3,2)
			if FCM(4,3) eq -1 then break //fuzz
		]
	]
	if q ne 0 then
		[
		pb(s,$E);
		PrintNumber(s,q,10,nil)
		]
	] //Really work
	for i=1 to 4 do FLDV(i,v+4*i)
]

and

pb(s,b) be [
	let l=s>>STR.length+1
	s>>STR.char^l=b
	s>>STR.length=l
]

and

//Type in and out routines.

TypeForm(m,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil,nil; numargs n) be [
	let lvm=lv m
	let i=0; let str=vec 20
	while i ls n do
		[
		let x=lvm!i
		let i1=i+1
		if (x&#177600) eq 0 then switchon x into
			[
			case 8:
			case 10: i=i1
				PrintNumber(str,lvm!i,x)
				x=str
				endcase
			case 0: x="*N*L"
				endcase
			case 1:	i=i1
				TypeIn(lvm!i)
				x=""
				endcase
			case 2: i=i1
				PrintFloat(str,lvm!i)
				x=str
				endcase
			case 3: case 4: [
				i=i1
				let v=vec 4
				FSTV(1,v)
				FLDDP(1,lvm!i)
				if x eq 4 then
				   [
				   let s=vec 4
				   FSTV(1,s); s!1=s!1+16; FLDV(1,s)
				   ]
				PrintFloat(str,1)
				FLDV(1, v)
				x=str
				endcase ]
			default: str!0=x+#400
				x=str
				endcase
			]
		Type(x)
		i=i+1
		]
]

and

Type(str) be [
	Wss(((outstream eq 0)? dsp, outstream), str)
]

and

TypeIn(str) be [
//	DlgInit()
//	DlgStr("", str)
let count=0
let ch = Gets(keys)

until ch eq $*N do
 [	switchon ch into
	 [	case BACKSPACE: case CONTROLA:
		[	if count eq 0 then endcase
			Puts(dsp,$/);Puts(dsp,str>>STR.char^count)
			count = count - 1
			endcase
		]
		case DEL: Type("XXX");count=0;endcase
		default: count = count + 1
			str>>STR.char^count = ch
			Puts(dsp,ch)
			endcase
	 ] //end of switchon
	ch=Gets(keys)
 ] //end of wait for *n
str>>STR.length=count
Puts(dsp,$*n)
]

and
//String stuff

StrEq(a,b) = valof [
	if a>>STR.length ne b>>STR.length then resultis false
	for i=1 to a>>STR.length do
	 	[ let c1=a>>STR.char^i
		  let c2=b>>STR.char^i
		  if (c1 ge $a)&(c1 le $z) then c1=c1+$A-$a
		  if (c2 ge $a)&(c2 le $z) then c2=c2+$A-$a
 		  unless c1 eq c2 then resultis false
		]
	resultis true
]

and

StrCop(f,t) be [
	for i=1 to f>>STR.length do t>>STR.char^i=f>>STR.char^i
	t>>STR.length=f>>STR.length
]

and

//Command line reader and processor.  Uses the main routine SCAN above.

ReadComInit() be [
	coms=table [ 0;0;0;0;0;0;0;0;0;0;0;0;0;0 ]
	compileif SCANIlen gr 14 then [ foo=nil ]

	Zero(coms, SCANIlen)
	coms>>SCANI.stream=OpenFile("Com.Cm", ksTypeReadOnly, 1, 0, fpComCm)
]

and

ReadCom(str,sw; numargs n) = valof [
	if n eq 2 then sw!0=0
	let old=ScanSet(coms)
	let ans=valof
		[
		let c=Scan()
		if c eq EOF then [ ScanBack(EOF); resultis 0 ]
		if c eq ID % c eq NUMBER then
			[
			StrCop(lv coms>>SCANI.idname,str)
			while coms>>SCANI.lastch eq $/ do 
				[ //switches
				Scan()	//To pick up /
				Scan()
				if n eq 2 then
				   [
				   let s=(lv coms>>SCANI.idname)
				   for i=1 to s>>STR.length do
					[
					sw!0=sw!0+1
					sw!(sw!0)=s>>STR.char^i
					]
				   ]

				]
			resultis c
			]
		Scream("Invalid command line")
		]
	ScanSet(old)
	resultis ans
]