// MICRO Builtins
// last edited July 7, 1980  9:21 AM
// Copyright Xerox Corporation 1979, 1980

get "micdecl.d"

external
[		// MICBIX
	xinsert; xfield; xdefmac; xmemory; xlst; xbuiltin; xcchar; xbittable; xfindbit
	mement
	entarg; looktype; checkbtx; valsize
		// defined here for MICBIX
	minbi; maxbi
		// O.S.
	MoveBlock; Zero
	Usc
]


static
[	minbi = 1
	maxbi = 44
]


// Structure for BIAC table of indices, maxs and mins.
structure bdt:
	  [	setup bit 8	// Setup inst index
		minna bit 4	// Minimum number of args
		maxna bit 4	// Maximum number of args
	   ]

// Literals for building structure BIAC table
manifest [
// Minna values
min0=0; min1=16; min2=32; min3=48; min4=64; min5=80; min6=96; min7=112
// Maxna values
max0=0; max1=1; max2=2; max3=3; max4=4; max5=5; max6=6; max7=7; nomax = 15
// Setup values
s = #400	// setup field position
ev1 = 1*s	// eval 1st arg
ev2 = 2*s	// eval 2nd arg
ev12 = 3*s	// eval 1st and 2nd args
ev23 = 4*s	// eval 2nd and 3rd args
look1 = 5*s	// lookup 1st arg
mem1 = 6*s	// lookup 1st arg as memory
bt1ev2 = 7*s	// lookup 1st arg as bittable, eval 2nd arg
ev3 = 8*s	// eval 3rd arg
fld1 = 9*s	// lookup 1st arg as field name
exp1 = 10*s	// expand 1st arg
// Empty entry
empty = min0+nomax
   ]


let dobi(bep,na,ac) be
// Do builtin
  [	let biac = table [

	min0+max0;		// filler
	min2+max2+ev2;		// builtin
	min2+max2+exp1;	// m (macro)
	min1+max1+exp1;	// n (neutral)
	min5+max5+ev23;	// memory
	min1+max1+look1;	// target
	min2+max2+mem1;	// default
	min3+max3+ev23;	// f (field)

	min2+max2+fld1;	// pf (preassign)
	min2+max2+ev2;		// set
	min0+nomax;		// add
	min1+max1+look1;	// ip (integer part)
	min3+max4+exp1;	// ifse (if string eq)
	min2+max3+fld1;	// ifset (if any bits of field)
	min3+max4+ev12;	// ife (if integers equal)
	min3+max4+ev12;	// ifg (if int 1 > int 2)

	min2+max3+look1;	// ifdef (if sym in symtab and not unbound address)
	min3+max4+look1;	// ifme (if mem part = string)
	min1+max3+exp1;	// er
	min2+max2+ev2;		// set list mode for memory
	min1+max1+exp1;	// insert file
	min1+max1+ev1;		// 1's complement
	min2+max2+ev1;		// repeat text #2 #1 times
	min1+nomax;		// logical or

	min1+nomax;		// logical xor
	min1+nomax;		// logical and
	min1+max1+exp1;	// set comment char
	min2+max2+ev2;		// bittable
	min2+max2+bt1ev2;	// get bit
	min2+max5+bt1ev2;	// set bit(s)
	min2+max6+bt1ev2;	// find bit(s)
	empty;			// ** unused

	min2+max2+ev12;	// lshift
	min2+max2+ev12;	// rshift
	min1+max1+fld1;	// get field value
	min1+nomax;		// select
	min2+max2+mem1;	// set postmacro
	min2+max2+mem1;	// set tag macro
	min2+max2+mem1;	// set listing fields
	min1+max1+exp1;	// set binary output extension

	min1+nomax;		// subtract
	min2+max2+exp1;	// equate
	min1+max1+ev1;		// set ignore mode
	min2+max2+ev12;		// set trace mode
	min2+max2	// while #1 repeat #2
	 ]

	let v1,v2,v3,v4,v5,v6,v7 = nil,nil,nil,nil,nil,nil,nil
	// *** Don't reorder the next line ***
	let ap1,l1, ap2,l2, ap3,l3, ap4,l4, ap5,l5, ap6,l6, ap7,l7 =
		nil,nil, nil,nil, nil,nil, nil,nil, nil,nil, nil,nil, nil,nil
	let no = bep!bsno
	let k = biac!no
	let m = k << bdt.maxna
	if (na gr m) % (na ls k<<bdt.minna) then
	  [	errx("WRONG NUMBER OF ARGS FOR '@S'",false,bep)
		return
	   ]
	let ap = ac
	let lvap1 = lv ap1
	if m ne nomax then
	 [ let p = lvap1
	   for i = 1 to na do
	    [ @p, p!1 = ap+1, @ap-1
	      ap = ap+@ap
	      p = p+2
	    ]
	 ]
	let oldfslim = fslim	// Mark top of temp storage
	switchon k << bdt.setup into
	  [ case ev23/s:
		v2 = evarg(ap2,l2)
	    case ev3/s:
		v3 = evarg(ap3,l3)
		endcase
	    case ev12/s:
		v1 = evarg(ap1,l1)
	    case ev2/s:
		v2 = evarg(ap2,l2)
		endcase
	    case ev1/s:
		v1 = evarg(ap1,l1)
		endcase
	    case look1/s:
		if l1 gr 2 then expand(lvap1)
		v1 = lookup(ap1,l1)
		endcase
	    case mem1/s:
		expand(lvap1)
		v1 = looktype(ap1,l1,memtype)
		endcase
	    case fld1/s:
		if l1 gr 2 then expand(lvap1)
		v1 = looktype(ap1,l1,fldtype)
		endcase
	    case bt1ev2/s:
		expand(lvap1)
		v1 = looktype(ap1, l1, bttype)
		v2 = evarg(ap2, l2)
		endcase
	    case exp1/s:
		expand(lvap1)
		endcase
	   ]
	let t = nil
	let typ, ep = nil, nil
	let ptr, len = nil, nil
	switchon no into
	  [ default:
		errx("UNDEFINED BUILTIN @S", false, bep)
		endcase
	    case 1:	// BUILTIN
		expand(lvap1)
		xbuiltin(ap1,l1,v2)
		endcase
	    case 2:	// M (MACRO)
		t = macdef(ap2, l2)
		xdefmac(ap1, l1, fstop-t, false)
		endcase
	    case 3:	// N (NEUTRAL)
		entarg(ap1,l1,neutype)
		endcase
	    case 4:	// MEMORY
		expand(lvap1)
		xmemory(ap1,l1,v2,v3, mement(ap4,l4), mement(ap5,l5))
		endcase
	    case 5:	// TARGET
		targset(v1)
		endcase
	    case 6:	// DEFAULT
		defaultbi(v1,ap2,l2)
		endcase
	    case 7:	// F (FIELD)
		expand(lvap1)
		xfield(ap1,l1,v2,v3)
		endcase
	    case 8:	// PF (PREASSIGN)
		dofld(v1,ap2,l2,false)
		endcase
	    case 9:	// SET
		if l1 gr 2 then expand(lvap1)
		ep = lookup(ap1,l1)
		if ep eq 0 then ep = putin(inttype)
		typ = ep!stype
		test typ eq inttype 
		 ifso	ep!isval = v2
		 ifnot
		test (typ eq nultype) % (typ eq undtype)
		 ifso
		  [	ep!stype = inttype
			ep!isval = v2
		   ]
		 ifnot
			redeferr(ep, inttype)
		endcase
	    case 10:	// ADD
		v1 = 0
		for k = 1 to na do
		  [	v1 = evarg(ap+1, @ap-1) + v1
			ap = ap+@ap
		   ]
		goto av
	    case 11:	// IP
		if (v1 eq 0) % (v1!stype ge 0) then
		[ process(ap1, l1, valmode, lv typ, lv v1)
		  if typ ne adrtype then
		  [ errx("'IP[@B]' - ARG NOT ADDRESS",false,ap1,l1)
		    endcase
		  ]
		]
		v1 = v1!asval
		goto av
	    case 12:	// IFSE
		expand(lv ap2)
		if l1 ne l2 then goto bf
		for k = 0 to l1-1 do
			if ap1!k ne ap2!k then goto bf
		goto bt
	    case 13:	// IFSET
		t = aused(v1)
		goto bx
	    case 14:	// IFE
		t = v1 eq v2
		goto bx
	    case 15:	// IFG
		t = v1 gr v2
		goto bx
	    case 16:	// IFDEF
		t = (v1 ne 0) & (v1!stype ne nultype) &
			(v1!stype ne undtype)
		goto bx
	    case 17:	// IFME
		expand(lv ap2)
		v2 = looktype(ap2,l2,memtype)
		t = (v1 ne 0) & (v1!stype eq v2-fstop)
		goto bx
	    case 18:	// ER
		v2 = (na ls 2? 0, evarg(ap2,l2))
		t = false
		if na ge 3 then v3 = evarg(ap3,l3)
		switchon v2 into
		[ default: coderr(bep, v2); endcase
		  case 1: t = true	// fatal error
		  case 2: endcase	// ordinary error
		  case 3: warncnt = warncnt+1	// warning
		  case 0: errcnt = errcnt-1	// not a real error
		]
		test na ge 3
		 ifso errx("@B@V", t, ap1, l1, v3)
		 ifnot errx("@B", t, ap1, l1)
		endcase
	    case 19:	// LIST
		expand(lvap1)
		xlst(ap1,l1,v2)
		endcase
	    case 20:	// INSERT
		xinsert(ap1,l1)
		endcase
	    case 21:	// NOT
		v1 = -1-v1
		goto av
	    case 22:	// REPEAT
		for k = 1 to v1 do
			process(ap2,l2,accmode)
		endcase
	    case 23:	// OR
		v1 = false
		for k = 1 to na do
		  [	v1 = evarg(ap+1, @ap-1) % v1
			ap = ap+@ap
		   ]
		goto av
	    case 24:	// XOR
		v1 = false
		for k = 1 to na do
		  [	v1 = evarg(ap+1, @ap-1) xor v1
			ap = ap+@ap
		   ]
		goto av
	    case 25:	// AND
		v1 = true
		for k = 1 to na do
		  [	v1 = evarg(ap+1, @ap-1) & v1
			ap = ap+@ap
		   ]
		goto av
	    case 26:	// COMMENTCHAR
		xcchar(ap1,l1)
		endcase
	    case 27:	// BITTABLE
		expand(lvap1)
		xbittable(entarg(ap1, l1, bttype), v2)
		endcase
	    case 28:	// GETBIT
		if checkbtx(v2, v1) then
		[ v1 = getbits(v1!bttab+fstop, v2, 1); goto av ]
		endcase
	    case 29:	// SETBIT
		v3 = (na ls 3? 1, evarg(ap3,l3))
		v4 = (na ls 4? 1, evarg(ap4,l4))
		v5 = (na ls 5? 1, evarg(ap5,l5)&1)
		while v3 ne 0 do
		[ unless checkbtx(v2, v1) break
		  setbits(v1!bttab+fstop, v2, 1, v5)
		  v2, v3 = v2+v4, v3-1
		]
		endcase
	    case 30:	// FINDBIT
		if xfindbit(v1, lv v2,
		 (na ls 3? 1, evarg(ap3,l3)),
		 (na ls 4? 1, evarg(ap4,l4)),
		 (na ls 5? 1, evarg(ap5,l5)),
		 (na ls 6? -1, evarg(ap6,l6)) ) then
		[ v1 = v2; goto av ]
		endcase
	    case 32:	// LSHIFT
		v1 = v1 lshift v2
		goto av
	    case 33:	// RSHIFT
		v1 = v1 rshift v2
		goto av
	    case 34:	// FVAL
		v1 = gtfield(v1)
		goto av
	    case 35:	// SELECT
		v1 = evarg(ap+1, @ap-1)
		test (v1 ls 0) % (v1 gr na-2)
		ifso	errx("INDEX @V TOO BIG IN 'SELECT'", false, v1)
		ifnot
		  [	for j = 0 to v1 do
				ap = ap+@ap
			ptr, len = ap+1, @ap-1
			goto ba
		   ]
		endcase
	    case 36:	// SETPOST
		v1!mspost = (l2 eq 0? 0, mement(ap2, l2)-fstop)
		endcase
	    case 37:	// SETTAG
		v1!mstagmac = (l2 eq 0? 0, mement(ap2, l2)-fstop)
		endcase
	    case 38:	// SETLISTFIELDS
		setlfbi(v1, ap2, l2)
		endcase
	    case 39:	// SETMBEXT
		if outchan ne fakeoutchan then
			errx("SETMBEXT GIVEN AFTER OUTPUT STARTED")
		t = alloc(l1/2+1)
		bcplpak(t, ap1, l1)
		mbext = t-fstop
		endcase
	    case 40:	// SUB
		v1 = evarg(ap+1, @ap-1)
		for k = 2 to na do
		  [	ap = ap+@ap
			v1 = v1 - evarg(ap+1, @ap-1)
		   ]
		goto av
	    case 41:	// EQUATE
		expand(lv ap2)
		ep = lookup(ap2, l2)
		ap1 = lookup(ap1, l1)
		if ep eq 0 then
		[ errx("@B not defined in EQUATE", false, ap2, l2); endcase ]
		v1 = valsize(ep)
		test ap1 eq 0
		ifso ap1 = putin(ep!stype)
		ifnot if v1 ne valsize(ap1) then
		[ errx("EQUATE[@S,@S] -- different types", false, ap1, ep); endcase ]
		MoveBlock(ap1-v1, ep-v1, v1)
		endcase
	    case 42:	// PROCESSMODE
		switchon v1 into
		[ case 0: ignore = false; endcase
		  case 1: ignore = true; endcase
		  default: coderr(bep, v1)
		]
		endcase
	    case 43:	// TRACEMODE
		t = v2 ne 0
		switchon v1 into
		[ case 0: tracesyms = t; endcase
		  case 1: tracecalls = t; endcase
		  default: coderr(bep, v1)
		]
		endcase
	    case 44:	// WHILE
		while evarg(ap1, l1) ne 0 do
		  process(ap2, l2, accmode)
		endcase

	    bt:
		t = true
	    bx:
		if t then m = m-1
	    bf:
		if na ls m endcase
		t = lvap1+m*2
		ptr, len = t!-2, t!-1
	    ba:	// Append len char.s at ptr
		test sttop+len ge tlbot
		ifso
			errx("Statement too long")
		ifnot
		  [	MoveBlock(sttop, ptr, len)
			sttop = sttop+len
		   ]
		endcase

	    av:	// Append v1 as number
		test sttop+2 ge tlbot
		ifso
			errx("Statement too long")
		ifnot
		[ @sttop, sttop!1 = v1, numc
		  sttop = sttop+2
		]
		endcase

	   ]

	// Deallocate any expansion blocks
	fslim = oldfslim
   ]

and coderr(ep, v) be
	errx("Invalid code @V for @S", false, v, ep)