// Micro Input Routines
// last edited March 12, 1981  10:36 AM
// Copyright Xerox Corporation 1979, 1981

	get "micdecl.d"
	get "streams.d"
	get "altofilesys.d"

external	// O.S.
[	OpenFile
	Gets; Puts; Closes
	GetCompleteFa; JumpToFa
	FilePos; SetFilePos
	DoubleAdd
	MoveBlock; SetBlock; Zero
	Noop
]

// Input stack structure
structure IR:
[	chain word
	lbsym word
	lblct word
	lincnt word
	cfa @CFA
	name word 0
]
manifest lIR = size IR/16

manifest
  [	minpt = #41	// lowest printing character
	maxpt = #176	// highest printing character
	ecEndOfFile = 1302
	eofchar = -2	// dummy character for eof
	trailerchar = #32	// Bravo trailer character
	bssize = 30	// Bracket/paren stack size
   ]

// Static Storage
// Input stack
static [
	@instk = 0	// input stack for INSERT
	@stcct = 0	// backup char. count for current statement
]

let initin() be
// Initialize input variables
  [	instk = 0
	lbsym = 0
	lblct = 0
	lincnt = 1
	stbuf = alloctemp(stbl+1)+1
	stbend = stbuf+stbl
	stbuf!-1 = endc
   ]

and inpush(filenm, fp; numargs na) = valof
// Push down the input stack and open the indicated file
//	Return false if bad file.
  [	let filename = vec filenamelength
	copyfile(filename, filenm)
	if na ls 2 then
	[ fp = 0; filext(filename, filenm, "MC") ]	// called from INSERT
	if instk ne 0 then
	  [	GetCompleteFa(inchan, lv instk>>IR.cfa)
		Closes(inchan)
	   ]
	inchan = OpenFile(filename, ksTypeReadOnly, charItem, verLatest, fp, inerr)
	if inchan eq 0 then
	[ if instk ne 0 then injump(instk)
	  resultis false
	]
	// Push an entry on the stack
	let nw = (length(filename)+2) rshift 1
	let rp = alloc(lIR+nw)
	rp>>IR.chain = instk
	MoveBlock(lv rp>>IR.name, filename, nw)
	rp>>IR.lbsym = lbsym
	rp>>IR.lblct = lblct
	rp>>IR.lincnt = lincnt
	instk = rp
	lbsym = 0
	lblct = 0
	lincnt = 1
	llstr("** FILE ")
	lstr(filename)
	lcrlf()
	resultis true
   ]

and inpop() = valof
// Pop input stack.  Return true if stack empty.
  [	let rp = instk
	if rp ne 0 then
	[ Closes(inchan)
	  instk = rp>>IR.chain
	]
	if instk eq 0 then	// nothing stacked
	[ if rp ne 0 then dalloc(rp)
	  resultis true
	]
	injump(instk)
	lbsym = rp>>IR.lbsym
	lblct = rp>>IR.lblct
	lincnt = rp>>IR.lincnt
	llstr("** RETURN TO ")
	lstr(lv instk>>IR.name)
	lcrlf()
	dalloc(rp)
	resultis false
   ]

and injump(rp) be
// Reopen an input file and jump to a place in it
[	inchan = OpenFile(0, ksTypeReadOnly, charItem, 0, lv rp>>IR.cfa.fp, inerr)
	if inchan eq 0 then error("CAN'T REOPEN FILE") 
	JumpToFa(inchan, lv rp>>IR.cfa.fa)
]

and inerr(st, ec) = valof
test ec eq ecEndOfFile
ifso	resultis eofchar
ifnot	error("ERROR READING INPUT FILE")

and readstat() = valof
// Read a statement, return false on eof
  [	let fchar = nil	// define first for assembly code
	static [ @rswitch = 0; @rsloop; @bstk; @bstop ]	// See initreadstat below
	stbot = stbuf
	sttop = stbuf
	stlct, stcct = lincnt, 0
	let bsptr = bstk
	let lastsym = stbot
	  [	goto rsloop
//rsloop:	fchar = Gets(inchan)
//		stcct = stcct+1
//		goto rswitch!fchar

let initreadstat(ucf) be
// Initialize readstat character dispatch
  [	if rswitch eq 0 then
	  [	rswitch = alloctemp(#400-eofchar)-eofchar	// eofchar is negative
		rsloop = table[
		  0	// LDA 0 inchan
		  #6407	// JSR @Gets
		    1	//   1
		  #41004	// STA 0 fchar,2
		  0	// ISZ stcct
		  0	// LDA 3 rswitch
		  #117000	// ADD 0 3
		  #3400	// JMP @0,3
		  0	// Gets:
		 ]
		rsloop!0 = #20000+lv inchan
		rsloop!4 = #10000+lv stcct
		rsloop!5 = #34000+lv rswitch
		rsloop!8 = Gets
		SetBlock(rswitch, rschar, #400)
		SetBlock(rswitch, rsskip, minpt)
		SetBlock(rswitch+(maxpt+1), rsskip, #400-(maxpt+1))
		rswitch!eofchar = rseof
		rswitch!trailerchar = rstrailer
		rswitch!$*N = rsnl
		rswitch!$% = rspercent
		rswitch!$( = rslpar
		rswitch!$) = rsrpar
		rswitch!$** = rsstar
		rswitch!$: = rsdelim
		rswitch!$; = rssemi
		rswitch!$[ = rslbr
		rswitch!$] = rsrbr
		rswitch!$, = rsdelim
		rswitch!$# = rsnosym
		rswitch!$← = rsnosym
		bstk = alloctemp(bssize+1)
		@bstk = eofchar
		bstop = bstk+bssize
	   ]
	SetBlock(rswitch+$a, (ucf? rsraise, rschar), $z-$a+1)
   ]

rstrailer:		// Bravo trailer character
		flush($*N, $*S)
rsnl:			// *N
		lincnt = lincnt+1
		if sttop eq stbot then stlct, stcct = lincnt, 0
		goto rsloop
rseof:			// End of file
		if sttop ne stbot then
		[ errx("File ends with incomplete statement")
		  sttop = stbot
		]
		if inpop() then resultis false	// end of top-level file
		stlct, stcct = lincnt, 0
		goto rsloop
rspercent:		// %
		flush($%, -1)
		if sttop eq stbot then stlct, stcct = lincnt, 0
		goto rsloop
rsstar:			// *
		fchar = Gets(inchan)
		test fchar eq eofchar
		 ifso
		  [	ceoferr()
		   ]
		 ifnot
		test fchar ne cmtchar
		 ifso
		  [	flush($*N, fchar)
		   ]
		 ifnot
		// Look for sequence *cmtchar
		  [	flush($**, fchar)
			fchar = Gets(inchan)
			if fchar eq eofchar then
			  [	ceoferr()
				break
			   ]
			if fchar eq cmtchar then
			  [	flush($*N, -1)
				break
			   ]
		   ] repeat
		if sttop eq stbot then stlct, stcct = lincnt, 0
		goto rsloop
rslpar:			// (
rslbr:			// [
		if bsptr eq bstop then
		  [	bserr("Too much nesting of () and []")
			break
		   ]
		bsptr = bsptr+1
		@bsptr = fchar
		goto rsdelim
rsrpar:			// )
		if @bsptr ne $( then
		  [	bserr("Unmatched )")
			break
		   ]
		bsptr = bsptr-1
		goto rsdelim
rsrbr:			// ]
		if @bsptr ne $[ then
		  [	bserr("Unmatched ]")
			break
		   ]
		bsptr = bsptr-1
		goto rsdelim
rsdelim:		// Symbol delimiter
	[	let nc = sttop-lastsym
		test (nc ge 2) & (@lastsym ge $A)
		ifso
		[ let ep = lookup(lastsym, nc)
		  if ep ne 0 then
		  [ @lastsym, lastsym!1 = ep-fstop, symc
		    sttop = lastsym+2
		  ]
		]
		ifnot
		if (@lastsym le $7) & (nc ne 0) & (@lastsym ge (nc eq 1? $0, $1)) & (nc le 6) then
		[ let val = @lastsym-$0
		  for p = lastsym+1 to sttop-1 do
		  [ if (@p gr $7) % (@p ls $0) goto rnon
		    if (val & 160000b) ne 0 goto rnon	// would overflow
		    val = val lshift 3 + @p-$0
		  ]
		  @lastsym, lastsym!1 = val, numc
		  sttop = lastsym+2
	rnon:
		]
		lastsym = sttop+1
		goto rschar
	]
rsnosym:		// Suppress symbol lookup
		lastsym = stbend
		goto rschar
rsraise:		// Raise lower-case letter
		fchar = fchar+($A-$a)
rschar:			// Normal character
		test sttop gr stbend
		ifso
		  [	errx("INPUT STATEMENT TOO LONG")
			break
		   ]
		ifnot
		  [	@sttop = fchar
			sttop = sttop+1
		   ]
rsskip:			// Non-printing character
		goto rsloop
rssemi:			// ;
		if @bsptr ne eofchar then
			bserr("Unmatched ( or [")
		break
	 ] repeat
	tlbot = stbend
	tltop = stbend
	resultis true
   ]

and flush(marker, fchar) = valof
// Flush input stream until marker is detected.
// Increment stcct for each character skipped.
  [	if fchar ls minpt then
	  [	if fchar eq trailerchar then
		 [ flush($*N, $*S)
		   fchar = $*N
		 ]
		if fchar eq $*N then lincnt = lincnt+1
		if fchar eq eofchar then
		  [	ceoferr()
			break
		   ]
	   ]
	if fchar eq marker break
	fchar = Gets(inchan)
	stcct = stcct+1
   ] repeat

and ceoferr() be
	errx("END OF FILE INSIDE COMMENT")

and bserr(str) be
[	errx(str)
	flush($;, -1)
	sttop = stbot
]

and printstat(outs) be
// Print the last statement read, by backing up inchan by stcct characters
// Remove Bravo trailers
[	let pos = vec 1
	FilePos(inchan, pos)
	let lastchar = -1
	if stcct ne 0 then
	[ let n0, n1 = -1, -stcct
	  DoubleAdd(pos, lv n0)
	  SetFilePos(inchan, pos)
	  let puts = Puts
	  for i = 1 to stcct do
	  [ lastchar = Gets(inchan)
	    switchon lastchar into
	    [ case trailerchar: puts = Noop; endcase
	      case $*N: puts = Puts; endcase
	    ]
	    puts(outs, lastchar)
	  ]
	]
	if lastchar ne $*N then Puts(outs, $*N)
]