// Stack manipulation routines
// Allegro change August 2, 1981  11:15 PM by Beau Sheil
// Last change July 19, 1981  7:23 PM by Beau Sheil
// Last change July 17, 1981  2:02 PM by Beau Sheil
// Last change June 2, 1981  3:56 PM by Beau Sheil
// Post Tone change April 5, 1981  4:42 PM by Beau Sheil

	get "LispBcpl.decl"
	get "Stats.decl"

external [		// declared herein
	NXTUSEDSTKBLOCK; CONTEXTSWITCH	// SUBRS
	StackOverflow			// Punt Subr
	GetFXP				// Get current frame extension
	@BiCall				// Caller of Lisp fns
	GetStkBlkType
			// declared elsewhere
	@SGetBase; @SPutBase; IGetBase; IPutBase; @APutBase32
	MkSmallPos; SmallUnbox
	WriteStatsX; RAIDCode; Usc; CallFn; CallSwat
			// statics
	@InterruptEnable; @lvNIL; @lvKT
 	]

manifest
   [ StkBlkType = 0		// Offsets in stack blocks
     FxNxt = 4
     FreeBlkLen = 1
     GrdBlkLen = 1
   ]

// NXTUSEDSTKBLOCK is a SUBR => the low 16 bits of the stack address of
// the next block that is not a free block. The intent is to skip
// over the currently executing frame. Hence, we also return a free block
// if we have left at least 200 (random constant) words of free space.

let NXTUSEDSTKBLOCK(lvMyF) = valof
   [
   RAIDCode ("Call to NXTUSEDSTKBLOCK")
   let px = SmallUnbox(lvMyF)
   let free = 0
   px = SGetBase(px+FxNxt)		// next block
   [ if GetStkBlkType(px) ne FreeStackBlock % Usc(free, 200) gr 0 then break
     let ps = SGetBase(px+FreeBlkLen)
     if Usc(ps, WordsPerPage) gr 0 then	// split overly large free block
        [ let s=WordsPerPage-2		// ensure the new guard block will fit
          SPutBase(px+FreeBlkLen, s)
          px = px + s
          SetStkBlkType(px, GuardBlock)
          SPutBase(px+GrdBlkLen, ps-s)
          break
        ]
     free = free + ps
     px = px + ps
   ] repeat
   resultis MkSmallPos(px)
   ]

and CONTEXTSWITCH(lvI) = valof		// switches context I and current FXP
   [ let I = SmallUnbox(lvI)
     let newCFXP = IGetBase(IFPCurrentFXP+I)
     IPutBase(IFPCurrentFXP+I, IGetBase(IFPCurrentFXP))
     IPutBase(IFPCurrentFXP, newCFXP)
     if I eq IFPKbdFXP

        then APutBase32 (InterruptEnable, lvKT)	// turn interrupts back on
     resultis lvI
   ]

// StackOverflow ensures at least N free words after current FXP, either by
// collapsing free blocks and adding new stack pages, or by moving it
// to another part of the stack. If the frame is copied, it will have
// its quick return bit turned OFF.

and StackOverflow(lvN) = RAIDCode("Stack ovflw punt")

and GetFXP() = IGetBase(IFPCurrentFXP)

and SetFXP(v) = IPutBase(IFPCurrentFXP, v)

and BiCall(f) be		// sets up stack for Bcpl to call Lisp fn f
  [ 
				// no longer works
    let sp = GetFXP()
    SPutBase(sp, SGetBase(sp)%#002000)	// set C bit in FXP
    let nx=SGetBase(sp+FxNxt)
    let nxsize=SGetBase(nx+FreeBlkLen)	// assumes nx is free; else garbage
    if GetStkBlkType(nx) ne FreeStackBlock then CallSwat("No CallFn space")
lp: switchon Usc(nxsize, 4) into
       [ case  1: [ SetStkBlkType(nx+4, FreeStackBlock)	// split free block
                    SPutBase(nx+4+FreeBlkLen, nxsize-4)
                    endcase ]
         case  0:   endcase		// exactly enough space
         case -1: [ let nxnx = nx+nxsize
                    if GetStkBlkType(nxnx) ne FreeStackBlock
                       then CallSwat("No CallFn space")
                    nxsize = nxsize + SGetBase(nxnx+FreeBlkLen)
                    goto lp ]
       ]
    SPutBase(sp+FxNxt, nx+4)
    SPutBase(nx, ATOMspace)		// push fn name atom
    SPutBase(nx+1, f)
    SPutBase(nx+2, SMALLPOSspace)	// push nargs (always 0)
    SPutBase(nx+3, 0)
    let fname = vec 2; if (fname&1) ne 0 then fname=fname+1    // 2 word align
    fname!0 = ATOMspace; fname!1 = f
    CallFn(0, fname)
  ]

and GetStkBlkType(s) = SGetBase(s+StkBlkType)&StackMask

and SetStkBlkType(s, v) = SPutBase(s+StkBlkType, v)