// MICBIX -- second part of builtins for Micro
// last edited August 17, 1978  4:02 PM
// Copyright Xerox Corporation 1979

get "micdecl.d"

external	// defined here for MICBI
[	xinsert; xfield; xdefmac; xmemory; xlst; xbuiltin; xcchar; xbittable; xfindbit
	mement
	entarg; looktype; checkbtx; valsize
]

external
[		// O.S.
	Usc; Zero
		// MICBI
	minbi; maxbi
]


// Literals
manifest [
	maxnm = 15		// max memory #
	maxwidth = 256	// max memory width
	maxsm = #77777	// max memory size
]


// Individual builtins

let xinsert(ap,l) be
// "Insert" builtin
  [	let filename = vec(40)
	bcplpak(filename,ap,l)
	if inpush(filename) eq false then
		errx("COULD NOT OPEN FILE @B FOR 'INSERT'",false,ap,l)
   ]

and xfield(ap,l,first,last) be
// Field builtin
  [	if (first ls 0) % (last ls first) % (last gr maxwidth)
	  then
	  [	errx("BAD PARAMETERS FOR 'FIELD'")
		first = 0
		last = 0
	   ]
	let ep = entarg(ap,l,fldtype)
	ep!fsbits = (first lshift 8) + last-first+1
   ]

and xdefmac(ap, l, dp, ok) be
[	let ep = lookup(ap,l)
	test ep eq 0
	 ifso ep = putin(dp)
	ifnot test ep!stype le maxtype
	 ifso
	  if ep!stype ne nultype then ep = redeferr(ep, mactype)
	ifnot
	 unless ok do errx("MACRO @S REDEFINED",false,ep)
	if ep ne 0 then ep!mcsp = dp
]

and doaddr(ap,l,mem,loc) be
// "Address" builtin
  [	let ep = lookup(ap,l)
	adef((ep eq 0? putin(nultype), ep),mem,loc)
   ]

and mement(ap,l) = valof
// Enter symbol for "memory"
  [	expand(lv ap)
	let ep = lookup(ap,l)
	if ep eq 0 then ep = putin(nultype)
	resultis ep
   ]

and xmemory(ap,l,mw,ms,epsrc,epsink) be
// Memory builtin
  [	let ep = lookup(ap,l)
	test ep ne 0
	 ifso redeferr(ep, memtype)
	ifnot test (mw ls 0) % (mw gr maxwidth) % (ms ls 0) % (ms gr maxsm)
	 ifso errx("ILLEGAL WIDTH OR SIZE FOR 'MEMORY'",true)
	ifnot	test memno eq maxnm
	 ifso	errx("TOO MANY MEMORIES",true)
	ifnot
	  [	memno = memno + 1
		ep = putin(memtype)
		ep!mswidth = mw
		ep!mssize = ms
		ep!msno = memno
		ep!mssource = epsrc-fstop
		ep!mssink = epsink-fstop
		let nw = (mw+15) rshift 4
		let ep1 = alloc(nw)
		ep!msdflt = ep1-fstop
		Zero(ep1, nw)
		ep!mslist = LFbinary
		ep!msltag = 0
		ep!mspost = 0
		ep!mstagmac = 0
		ep1 = alloc(mw)
		ep!mslfields = ep1-fstop
		setlfbi(ep, 0, 0)	// initialize listing fields
		wmemdef(ep)
	   ]
   ]

and dofld(ep,ap,l,set) be
// "assign" and "preassign" builtin
  [	let typ, val = nil, nil
	process(ap,l,fldmode, lv typ, lv val)
	test typ eq undtype ifso
	  [	test set
		ifnot	errx("FORWARD REFERENCE NOT LEGAL IN 'PREASSIGN'")
		ifso	auref(ep,val)
	   ]
	ifnot test (typ eq inttype) ifso
		stfield(ep,val,set)
	ifnot test (typ eq adrtype) ifso
		stfield(ep,val!asval,set)
	ifnot errx("ARG IN FIELD STORE NOT INTEGER OR ADDRESS")
   ]

and xlst(ap,l,val) be
// "list" builtin
test l eq 0 
ifso	ltoflag = val eq 0
ifnot
  [	let mem = looktype(ap,l,memtype)
	mem!mslist = val
   ]

and xbuiltin(ap,l,no) be
// "builtin" builtin
test (no ls minbi) % (no gr maxbi)
ifso	errx("ILLEGAL BUILTIN NUMBER FOR @B",false,ap,l)
ifnot
  [	let ep = lookup(ap, l)
	if (ep ne 0) & (ep!stype eq bitype) & (ep!bsno eq no) then return	// OK to redefine a builtin identically
	ep = entarg(ap,l,bitype)
	if ep ne 0 then ep!bsno = no
   ]

and xcchar(ap,l) be
// "commentchar" builtin
  [	cmtchar = (l gr 0? ap!0, -1)
   ]

and xbittable(ep, n) be
// "bittable" builtin
  [	let nw = n rshift 4 + 1
	let bp = alloc(nw)
	Zero(bp, nw)
	ep!bttab = bp-fstop
	ep!btsize = n
   ]

and xfindbit(ep, lvStart, num, delta, hop, count) = valof
// "findbit" builtin -- changes start, returns true if found
  [	while count ne 0 do
	[ let i, n = @lvStart, num
	  while n ne 0 do
	  [ if Usc(i, ep!btsize) ge 0 resultis false	// ran off end of memory
	    if getbits(ep!bttab+fstop, i, 1) ne 0 goto outer
	    i, n = i+delta, n-1
	  ]
	  resultis true
	outer:
	  @lvStart, count = @lvStart+hop, count-1
	]
	resultis false	// exhausted count
   ]


// Utilities for builtins

and entarg(ap, l, typ) = valof
// Put the argument in the symbol table with type typ.
// Error if already defined.
[	let ep = lookup(ap, l)
	test ep eq 0
	 ifso ep = putin(typ)
	ifnot test (ep!stype eq nultype) & (typesizes!(realtype(typ)) le typesizes!nultype)
	 ifso ep!stype = typ
	ifnot ep = redeferr(ep, typ)
	resultis ep
]

and looktype(ap,l,typ) = valof
// look up argument, must be of given type.
  [	let ep = lookup(ap,l)
	if (ep eq 0) % (typ eq adrtype? ep!stype ge 0, typ eq mactype? ep!stype le maxtype, ep!stype ne typ) then
	  [	errx("@B is not a @L name", false, ap, l, typenames!(realtype(typ)))
		ep = 0
	   ]
	resultis ep
   ]

and checkbtx(index, ep) = valof
// check index in bittable
[	test Usc(index, ep!btsize) ls 0
	 ifso resultis true
	 ifnot
	  [	errx("INDEX @V TOO BIG FOR BITTABLE @S",false,index,ep)
		resultis false
	   ]
]

and adef(ep, mem, val) = valof
// Define address tag.
  [	let typ = ep!stype
	test (typ ne undtype) & (typ ne nultype) & (typ ne mem-fstop)
	 ifso
	  ep = redeferr(ep, adrtype)
	 ifnot
	[ if ep-fstop ge ofbot then newdef(ep, true)
	  ep!stype = mem-fstop
	  ep!asval = val
	  mem!msltag = ep-fstop
	]
	resultis ep
   ]

and valsize(ep) = typesizes!(realtype(ep!stype))

and realtype(typ) =
	(typ ls 0? adrtype, typ gr maxtype? mactype, typ)

and redeferr(ep, typ) = valof
// Indicate a redefinition error, return 0
[	errx("Attempt to redefine @L @S as @L", false,
	  typenames!(realtype(ep!stype)), ep,
	  typenames!(realtype(typ)) )
	resultis 0
]