// Copyright Xerox Corporation 1979
get "streams.d"

// Outgoing procedures
external [ SetupReadParam; ReadParam; EvalParam;
	ReadString; AddItem; Swat ]

// Outgoing statics
external [
	ReadParamStream
	]
static [
	ReadParamStream
	]


// Incoming procedures
external [ Ws; Wss; Gets; Puts; dsp; keys; MoveBlock; OpenFile;
	Endofs; CallSwat; DefaultArgs ]

external [
	fpComCm		//FP for file "Com.Cm"
	]

static [ stringVec; swVec ]

structure STRING[
	length byte
	char ↑1,255 byte
	]

structure [ oddblank bit 15; odd bit ]
structure [ left byte; right byte ]

let SetupReadParam(aStringVec, aSwVec, aS, tempSwVec; numargs na) be [
	let comName=vec 256
	DefaultArgs(lv na)
	ReadParamStream=(aS ne 0 ? aS, 
	   OpenFile("Com.Cm", ksTypeReadOnly, charItem, 0, fpComCm))
	stringVec=aStringVec; swVec=aSwVec
	ReadParam(0, 0, (stringVec ne 0 ? stringVec, comName),
	  tempSwVec)
	]


and ReadParam(type, prompt, resultVec, aSwVec, returnOnNull;
  numargs na)=valof [
	DefaultArgs(lv na)

	let name=vec 256; let sw=vec 128; let c=nil
	name!0=0; sw!0=0

	let skipBlanks=true
	while true do [
		c=GetComChar(skipBlanks)
		skipBlanks=false
		if c eq $/ % c eq $*S % c eq $*N then break
		AddItem(name, c)
		]

	if c eq $/ then while true do [
		c=GetComChar(false); if c eq $/ then loop
		if c eq $*S % c eq $*N then break
		if c eq $! then [ CallSwat("Debug break. "); loop ]
		AddItem(sw, c)
		]

	if resultVec eq 0 & stringVec ne 0 then resultVec=stringVec
	if resultVec ne 0 then MoveBlock(resultVec, name, name!0+1)
	if aSwVec eq 0 & swVec ne 0 then aSwVec=swVec
	if aSwVec ne 0 then MoveBlock(aSwVec, sw, sw!0+1)

	if prompt eq -1 then [ returnOnNull=true; prompt=0 ]

	if returnOnNull & name!0 eq 0 resultis -1

	resultis EvalParam(name, type, prompt, resultVec)
	]


and EvalParam(name, type, prompt, resultVec; numargs na)=valof [

// two-character types
manifest [ ic=$I * #400 + $C; iw=$I * #400 + $W;
	oc=$O * #400 + $C; ow=$O * #400 + $W;
	ef=$E *#400 +$F
	]

structure SS[ length byte; c1 byte; c2 byte; blank byte ]

	let packedName=vec 128
	let v=nil; let ft=nil; let radix=8

	DefaultArgs(lv na, 2)
	if na ls 4 then resultVec=name

	if type gr 256 then [
		test type>>SS.length eq 1
			ifso type=type>>SS.c1
			ifnot type=type>>SS.c1 * #400 + type>>SS.c2
		]
	if prompt eq 0 then prompt="Try again: "
	if name!0 eq 0 then goto GetNewName

Retry:	PackString(packedName, name)
	switchon type into [
	  case ic:
	  case $I: ft=0
LOpenFile:	v=0
		if name!0 then v=OpenFile(packedName, 
		  (table [ ksTypeReadOnly;
			ksTypeReadOnly;
			ksTypeWriteOnly;
			ksTypeWriteOnly;
			ksTypeReadWrite;
			ksTypeReadWrite ] )!ft,
		  ((ft eq 0%ft eq 2)? charItem,wordItem))
		if v ne 0 then [
		  if resultVec ne 0 then goto RetPackedName
		  endcase
		  ]
		Ws("*NCouldn't open "); Ws(packedName)
		goto GetNewName
	  case iw: ft=1; goto LOpenFile
	  case oc:
	  case $O: ft=2; goto LOpenFile
	  case ow: ft=3; goto LOpenFile
	  case $F: ft=4; goto LOpenFile
	  case ef: ft=5; goto LOpenFile
	  case $B: radix=8
GetNumber:	[gn let e=name!0; let b=1
		switchon name!e into [
		  case $d:
		  case $D: radix=10; e=e-1; endcase
		  case $o:
		  case $O:
		  case $b:
		  case $B: radix=8; e=e-1; endcase
		  default: endcase
			]
		if name!b eq $# then [ radix=8; b=b+1 ]
		v=0
		for i=b to e do [
			let d=name!i-$0
			if d ls 0 % d ge radix then [
				Ws("*N"); Ws(packedName)
				Ws(" isn't a proper ")
				Ws((radix eq 8 ? "octal", "decimal"))
				Ws(" number")
				goto GetNewName
				]
			v=v*radix+d
			]
		]gn
		endcase
	  case $D: radix=10; goto GetNumber
	  case $P: v=resultVec
RetPackedName:	test resultVec ne 0
		  ifso MoveBlock(resultVec, packedName, (name!0 rshift 1)+1)
		  ifnot
NoResultVec:	    CallSwat("No place to put the packed string")
		endcase
	  case 0: v=resultVec
		test resultVec ne 0
		  ifso MoveBlock(resultVec, name, name!0+1)
		  ifnot goto NoResultVec
		endcase
	  default: CallSwat("Undefined type")
		]
	resultis v

GetNewName: Ws("*N"); Ws(prompt)
	ReadString(name, "/*S*N", keys, true, prompt)
	Puts(dsp, $*N); goto Retry
	]


and ReadString(result, breaks, inStream, editFlag, prompt;
	numargs na)=valof [

	DefaultArgs(lv na, 1, "*N", keys, false, "")
	if inStream eq keys & (editFlag eq false
	  % editFlag eq true) then editFlag=dsp

// avoid using stsize or stdec
	let lb=breaks>>STRING.length
	let bv=vec 256
	for i=1 to lb do [
		let j=i rshift 1
		bv!i=(i<<odd ?  breaks!j<<right, breaks!j<<left)
		]
	[ result!0=0
	while true do [
		let c=Gets(inStream)
		for i=1 to lb do if bv!i eq c then resultis c
		if editFlag then switchon c into [
Del:		  case #177: Wss(editFlag, "XXX*N")
			Wss(editFlag, prompt); break
		  case $H-#100: case $A-#100:
			if result!0 eq 0 then goto Del
			Puts(editFlag, $\)
			Puts(editFlag, result!(result!0))
			result!0=result!0-1; loop
			]
		AddItem(result, c)
		if editFlag then Puts(editFlag, c)
		]
	loop
	] repeat
	]



and GetComChar(skipBlanks)=valof [
	while true do [
		let c=Endofs(ReadParamStream) ? $*N,
		 Gets(ReadParamStream)
		if c eq $*S & skipBlanks then loop
		resultis c
		]
	]


and AddItem(vector, value) be [
	vector!0=vector!0+1
	vector!(vector!0)=value
	]


and PackString(dest, source) be [
	dest>>STRING.length=source!0
l6:	for i=1 to source!0 do [
		let j=i rshift 1
l7:		test i<<odd ifso dest!j<<right=source!i
		  ifnot [ dest!j=0; dest!j<<left=source!i]
		]
	]