//
// File search pattern compiler
// last edited September 18, 1980  5:31 PM
//
// Copyright Xerox Corporation 1979, 1980

	get "findpkgdefs.d"
	get "findintdefs.d"

external	// entry point
[	FindCompile	// (pat, chartab[, wildchar, fuzz, outs, storeproc, rregs, lvTables, zone]) -> error/0
]


external
[		// O.S.
	Allocate
	DefaultArgs; Dvec
	MoveBlock; MyFrame
	Puts
	ReturnFrom
	SetBlock
	sysZone
	Usc
	Wss
	Zero
		// rwreg
	WriteInsReg
	WriteReg
		// Template
	PutTemplate
		// FindCompMu
	fRamImage
		// FindNext
	findJumpRam
	findWriteReg
]


structure BS:	// Bcpl string
[	length byte
	char^1,255 byte
]

structure MIF:	// Microinstruction field value
[	w0 word	// add this to word 0
	w1 word	// add this to word 1
	oproc word	// output procedure (or 0=Wss)
	name word 0	// name starts here
]


manifest [
	ramsize = 2000b
	consize = 400b
	charsetsize = 200b
	regsize = 100b
	maxpatsize = regsize
	fixedram = 40b	// space occupied by common microcode
	START = 20b	// entry to Nova emulator
	workarea = 10b	// 2-instruction work area for RWREG
]


static [	// other statics
	FCoutStream	// trace stream for symbolic output, or 0
	FCstoreProc	// if true, store instructions in RAM
	topframe	// return frame in case of error
	allocbits	// bit table for allocating RAM
	reglist	// list of R registers
	constloc	// constant locations
	constval	// constant values
]


let error(s) be ReturnFrom(topframe, s)

let toolong() be error("Pattern too long")

let FindCompile(pat, chartab, wildchar, fuzz, outs, storeproc, rregs, lvTables, zone; numargs na) = valof
[	let dummy = nil	// default for lvTables
	let sproc = storeproc	// To avoid defaulting explicitly supplied value of false
	DefaultArgs(lv na, -2, -1, 0, 0, true, table[ 1; 0; 77777b; 177776b ], lv dummy, sysZone)
	if na ge 6 then storeproc = sproc
	FCoutStream, FCstoreProc = outs, storeproc
	@lvTables = 0

// Validate and unpack pattern
	for c = 0 to charsetsize-1 do
	 if (chartab!c ge 0) & (chartab!(chartab!c) ne classOther) then
	   error("Invalid chartab")
	let patlen = pat>>BS.length
	if patlen eq 0 then error("Null pattern not allowed")
	let nphase = patlen+(patlen&1)	// always even
	let xpat = patlen+1
	Dvec(FindCompile, lv xpat)
	xpat!0 = patlen
	SetBlock(xpat+1, -1, patlen)
	let count = vec charsetsize
	Zero(count, charsetsize)
	let xchar = charsetsize-1
	for i = 1 to patlen do	// allocate B dispatch
	 [ let c = pat>>BS.char^i
	   if c eq wildchar then
	    [ fuzz = fuzz+1
	      loop
	    ]
	   if chartab!c ge 0 then c = chartab!c
	   if chartab!c eq classExit then xchar = c
	   xpat!i = c
	   count!c = count!c+1
	 ]
	if fuzz ge patlen then error("Too fuzzy")

// Set up values for FindNext
	fNegK = -patlen+1+fuzz
	fNphase = nphase
	fExitChar = (xchar lshift 8) + xchar

// First try compiling to microcode, then to assembly code
	let err = FindCompileRam(pat, chartab, nphase, xpat, count, rregs)
	if err eq 0 resultis 0
	resultis FindCompileSoft(pat, chartab, nphase, xpat, count, lvTables, zone)
]

//
// The version of the compiler that produces microcode
//


and FindCompileRam(pat, chartab, nphase, xpat, count, rregs) = valof
[	topframe = MyFrame()

// Miscellaneous subroutines


// Initialize microinstruction field values
	manifest q = 400b
	let aluPLUS1 = table[ 5*200b; 0; 0; 2*q+$+; $1*q ]
	let aluMINUS1 = table[ 6*200b; 0; 0; 2*q+$-; $1*q ]
	let bsLOADR = table[ 1*20b; 0; 0; 2*q+$_; $L*q ]
	let f1TASK = table[ 2*1b; 0; -2; 4*q+$T; $A*q+$S; $K*q ]
	let f1const = table[ 7*1b; -7*10000b; -1 ]
	let f2BUSEQ0 = table[ 0; 1*10000b; -2; 5*q+$B; $U*q+$S; $=*q+$0 ]
	let f2BUS = table[ 0; 4*10000b; -2; 3*q+$B; $U*q+$S ]
	let f2IDISP = table[ 0; 15b*10000b; -2; 5*q+$I; $D*q+$I; $S*q+$P ]
	let LOADL = table[ 0; -1*2000b; -2; 2*q+$L; $_*q ]
	let rAC0 = table[ 3 lshift 11; 0; 0; 3*q+$A; $C*q+$0 ]
	let rPhase = table[ Rphase lshift 11; 0; 0; 5*q+$p; $h*q+$a; $s*q+$e ]
	let rNegK1 = table[ RnegK1 lshift 11; 0; 0; 4*q+$-; $K*q+$+; $1*q ]

// Initialize RAM
	let RamImage = fRamImage(workarea, (FCstoreProc eq true? fixedram, -1), error)	// Get code from FindCompMu


// Routine to produce microinstructions

let comment(s) be
if FCoutStream ne 0 then PutTemplate(FCoutStream, "; ******************** $S*N", s)

let ctrsel(n) = valof
[	static [ ctrw0; ctrw1 = 0; ctrproc; ctrnum ]
	let wctrn(st, p) be PutTemplate(st, "s$O", @p)
	let reg = reglist!n
	ctrw0 = reg lshift 11 + (reg ge 40b? 3*20b, 0*20b)
	ctrproc, ctrnum = wctrn, n
	resultis lv ctrw0
]

let consel(n) = valof
[	static [ conw0; conw1 = 7*10000b; conproc; connum ]
	let wconn(st, p) be PutTemplate(st, "=$O", constval!(@p))
	let loc = constloc!n
	conw0 = (loc&370b) lshift 8 + (loc&7) lshift 4
	conproc, connum = wconn, n
	resultis lv conw0
]

let instr(loc, nil, nil, nil, nil, nil, nil, nil, nil, nil; numargs na) = valof
[	let w0, w1 = 10b, 102000b	// no-op
	for j = 1 to na-2 do
	 [ let f = (lv loc)!j
	   w0 = w0 + f>>MIF.w0
	   w1 = w1 + f>>MIF.w1
	 ]
	let next = (lv loc)!(na-1)
	w1 = w1+next
	if FCoutStream ne 0 then
	 [ PutTemplate(FCoutStream, "$4O: $6UO $6UO | $4O:   ", loc, w0, w1, loc)
	   for j = 1 to na-2 do
	    [ let f = (lv loc)!j
	      let proc = f>>MIF.oproc
	      if proc eq -1 loop
	      test proc eq -2
	      ifso
	      [ if j gr 1 then Wss(FCoutStream, ", ")
	        Wss(FCoutStream, lv f>>MIF.name)
	      ]
	      ifnot
	        (proc eq 0? Wss, proc)(FCoutStream, lv f>>MIF.name)
	    ]
	   PutTemplate(FCoutStream, (na eq 2? ":$O;*N", ", :$O;*N"), next)
	 ]
	if FCstoreProc ne 0 then (FCstoreProc eq true? WriteInsReg, FCstoreProc)(loc, lv w0)
	resultis next
]


// Bit table routines

let getbit(tab, i) =
	tab!(i rshift 4) & (100000b rshift (i&17b))

let setbit(tab, i) be	// invert bit
[	let p = tab + i rshift 4
	@p = @p xor (100000b rshift (i&17b))
]

let allocins() = valof
[	let j = ramsize/16-1
	while allocbits!j eq 0 do
	 [ if j eq 0 then error("RAM full")
	   j = j-1
	 ]
	let i = j*16+15
	while getbit(allocbits, i) eq 0 do i = i-1
	setbit(allocbits, i)
	resultis i
]

let prealloc(loc, delta, n, trying; numargs na) = valof
[	if na ls 4 then trying = false
	for m = 0 to n-1 do
	 [ let lc = loc+m*delta
	   if getbit(allocbits, lc) eq 0 resultis -1
	   unless trying do setbit(allocbits, lc)
	 ]
	resultis loc
]

let findalloc(loc, delta, n, inc) = valof
[	let lc, lim = loc, ramsize-delta*n
	while lc le lim do
	 [ if prealloc(lc, delta, n, true) ne -1 then
	    [ prealloc(lc, delta, n)
	      resultis lc
	    ]
	   lc = lc+inc
	 ]
	error("Can't preallocate")
]


// Main routines

let nextmask(n) = valof
[	let m = 1
	while m le n do m = m lshift 1
	resultis m-1
]

// Unpack R register list
	let regv = vec regsize
	let patmax = 0
	for i = 0 to regsize-1 do
	 if getbit(rregs, i) ne 0 then
	 [ regv!patmax = i
	   patmax = patmax+1
	 ]
	reglist = regv
	patmax = patmax & -2

// Unpack pattern
	comment("Pattern is:")
	comment(pat)
	if nphase gr patmax then toolong()
	let npmask = nextmask((nphase-1)*2)+1
	let patlen = xpat!0

// Scan constant memory
	manifest [ nxcon = 3 ]
	manifest [ nconst = maxpatsize+nxcon ]
	let cloc, cval = vec nconst, vec nconst
	cloc, cval = cloc+nxcon, cval+nxcon
	for j = -nxcon to nphase-1 do
	 [ let val = selecton j into
	    [ case -3: 1777b	// for resetting phase
	      case -2: 6000b	// ditto
	      case -1: -1	// for signalling match
	      default: j
	    ]
	   for i = 0 to consize-1 do
	    if RamImage!i eq val then
	    [ cloc!j, cval!j = i, val; goto found ]
	   error("Inadequate constant memory")
found:
	 ]
	constloc, constval = cloc, cval

// Allocate dispatches
	let albits = vec (ramsize/16)
	allocbits = albits
	SetBlock(allocbits, -1, ramsize/16)
	let abase = ramsize-charsetsize
	prealloc(abase, 1, charsetsize)	// allocate A dispatch
	let loc = (npmask ls fixedram? fixedram, npmask)
	prealloc(0, 1, loc)	// skip bottom loc.s
	let endloc = vec (maxpatsize)
	let idloc = count
	for c = 0 to charsetsize-1 do	// allocate B dispatch
	 test idloc!c ne 0	// occurs in pattern
	 ifso
	  [ loc = findalloc(loc, 1, nphase, npmask)
	    idloc!c = loc
	  ]
	 ifnot idloc!c = -1
	let clrbase = findalloc(0, 1, nphase, npmask)
	let clrnext = allocins()
	comment("Last test")
	let next = 2
	for ctr = 0 to nphase-1 do
	 [ endloc!ctr = allocins()
	   next = findalloc(next, 1, 2, 2)
	   instr(endloc!ctr, ctrsel(ctr), bsLOADR, next)
	   instr(next, rPhase, f2BUS, clrnext)
	   instr(next+1, LOADL, consel(ctr), Match)
	 ]

// Compile test sequences
[	let tlocs = vec maxpatsize
	for c = 0 to charsetsize-1 do
	 if idloc!c ne -1 then
	 [ let cs = "Code for ' '"
	   cs>>BS.char^11 = c
	   comment(cs)
	   let nl = -1
	   for i = 1 to patlen do
	    if xpat!i eq c then
	    [ nl = nl+1; tlocs!nl = i ]
	   for h = 0 to nphase-1 do
	    [ if nl ne 0 then comment("New phase")
	      let loc = idloc!c+h
	      for j = 0 to nl do
	       [ let ctr = (h-tlocs!j+1+nphase) rem nphase
	         let n1 = (j eq nl? endloc!ctr, allocins())
	         instr(loc, LOADL, ctrsel(ctr), aluPLUS1, f2BUSEQ0, n1)	// *** should have TASK
	         if j ne nl then
	          [ next = findalloc(next, 1, 2, 2)
	            instr(n1, ctrsel(ctr), bsLOADR, next)
	            instr(next+1, LOADL, consel(ctr), Match)
	            loc = next
	          ]
	       ]
	    ]
	 ]
]

// Store C (counter-clearing) code
[	comment("Clearing counters")
	instr(clrnext, LOADL, rNegK1, f2IDISP, clrbase)
	for h = 0 to nphase-1 do
	 [ let loc, fetch = clrbase+h, ((h&1) eq 0? FetchOdd, FetchEven)
	   let nh = (h+1) rem nphase
	   test nh eq 0
	   ifso	// also reset phase
	    [ next = findalloc(next, 1, 2, 2)
	      instr(loc, ctrsel(nh), bsLOADR, next)
	      let n1 = allocins()
	      instr(next, LOADL, consel(-3), f1const, f2IDISP, n1)
	      instr(next+1, LOADL, consel(-2), f1const, aluMINUS1, f2IDISP, n1)
	      instr(n1, rPhase, bsLOADR, fetch)
	    ]
	   ifnot
	    [ instr(loc, ctrsel(nh), bsLOADR, fetch)
	    ]
	 ]
]

// Compile reset sequence
[	comment ("Reset all counters")
	let n1 = allocins()
	instr(Reset, LOADL, rNegK1, n1)
	for i = 0 to nphase-1 do
	 [ let n2 = allocins()
	   instr(n1, ctrsel(i), bsLOADR, n2)
	   n1 = n2
	 ]
	let n2 = allocins()
	instr(n1, LOADL, rAC0, f1TASK, n2)
	instr(n2, rPhase, bsLOADR, START)
]

// Fill in character (A) dispatch
	let xchar = charsetsize-1
[	comment("A dispatch")
	let outt = FCoutStream
	for c = 0 to charsetsize-1 do
	 if (chartab!c eq classOther) & (idloc!c ne -1) then
	[ let l1 = allocins()
	  instr(l1, idloc!c)
	  idloc!c = l1
	]
	for c = 0 to charsetsize-1 do
	 [ FCoutStream = outt
	   let c1 = chartab!c
	   switchon c1 into
	   [ case classSkip:
	      instr(abase+c, Skip)
	      endcase
	     case classRecord:
	      instr(abase+c, LOADL, rPhase, Record)
	      endcase
	     case classExit:
	      instr(abase+c, LOADL, consel(-1), Match)
	      endcase
	     case classOther:
	      c1 = c	// falls through
	     default:
	      switchon idloc!c1 into
	      [ case -1:
	         FCoutStream = 0
	         instr(abase+c, rPhase, f2BUS, clrnext)
	         endcase
	        default:
	         instr(abase+c, rPhase, f2BUS, idloc!c1)	// *** should have TASK
	      ]
	   ]
	 ]
	FCoutStream = outt
]

// Set up values for FindNext
	findJumpRam = 0	// FindInit sets it up
	findWriteReg = WriteReg

	resultis 0
]

//
// An alternative compiler that doesn't use microcode
//


and FindCompileSoft(pat, chartab, nphase, xpat, count, lvTables, zone) = valof
[
external
[		// fpsoftasm
	@flvlvlvCtrs; @fnNctrs; @flvDisp
	fJumpRam; fWriteReg
	fClear; fSkip; fExit; @fCount
]
	topframe = MyFrame()

// Miscellaneous subroutines

let outblk(addr, len) be
[	for i = 0 to len-1 do
	[ if (i rem 6) eq 0 then PutTemplate(FCoutStream, "*N$6UO", addr+i)
	  PutTemplate(FCoutStream, "$8UO", addr!i)
	]
	Puts(FCoutStream, $*N)
]

// Allocate state vector
	let nchars, nlit = 0, 0
	for i = 0 to charsetsize-1 do
	  if count!i ne 0 then nchars, nlit = nchars+1, nlit+count!i
	if nphase gr 376b then toolong()	// >64K of tables needed!
	let state = Allocate(zone,
	  nphase+	// counters
	  charsetsize+	// A dispatch
	  2*nchars+nlit+	// B dispatches
	  nphase+2+	// First level of counter addresses
	  nphase*(nphase+1),	// Second level
	 -1)
	if state eq 0 then toolong()	// Can't allocate tables
	@lvTables = state
	let ctrbase = state
	let adisp = ctrbase+nphase
	  SetBlock(adisp, fClear, charsetsize)
	let bdisp = adisp+charsetsize
	let ppcbase = bdisp+2*nchars+nlit+1
	let pcbase = ppcbase+nphase+1

// Produce B dispatch tables
[	let bptr = bdisp
	for c = 0 to charsetsize-1 do
	 if count!c ne 0 then
	[ adisp!c = bptr
	  @bptr = 6000b+lv fCount	// jsr @
	  bptr = bptr+1
	  for i = 1 to xpat!0 do
	   if xpat!i eq c then
	  [ @bptr = i-1; bptr = bptr+1 ]
	  @bptr = -1
	  bptr = bptr+1
	]
]

// Fill in character (A) dispatch
[	for c = 0 to charsetsize-1 do
	 [ let c1 = chartab!c
	   let d = nil
	   switchon c1 into
	   [ case classSkip:
	      adisp!c = fSkip
	      endcase
	     case classRecord:
	      adisp!c = fExit
	      endcase
	     case classExit:
	      adisp!c = fExit
	      endcase
	     case classOther:
	      endcase	// already done
	     default:
	      if count!c1 eq 0 loop
	      adisp!c = adisp!c1
	   ]
	 ]
]

// Set up pointer tables
[	ppcbase!-1 = -1
	let p = pcbase
	for i = 0 to nphase-1 do
	[ p = p+1
	  ppcbase!i = p
	  for j = 0 to nphase-1 do
	    p!j = ctrbase+((i-j+nphase) rem nphase)
	  p!-1 = p!(nphase-1)
	  p = p+nphase
	]
	ppcbase!nphase = 0
]

// Write listing
if FCoutStream ne 0 then
[	outblk(adisp, charsetsize)
	outblk(bdisp, ppcbase-bdisp)
	outblk(ppcbase-1, nphase+2)
	outblk(pcbase, nphase*(nphase+1))
]

// Set up values for FindNext
	findJumpRam = fJumpRam
	findWriteReg = fWriteReg

// Set up data for assembly code
	flvDisp = adisp
	fnNctrs = -nphase
	flvlvlvCtrs = ppcbase

	resultis 0
]