(FILECREATED "10-Oct-86 22:16:06" {ERIS}<LISPCORE>SOURCES>LLSTK.;20
 92736  

      changes to:  (RECORDS FX BF FSB STK PVARSLOT BINDMARKSLOT)
                   (VARS LLSTKCOMS)

      previous date: "31-Aug-86 16:31:42" {ERIS}<LISPCORE>SOURCES>LLSTK.;19)


(* "
Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT LLSTKCOMS)

(RPAQQ LLSTKCOMS
 
       [(DECLARE: DONTCOPY (EXPORT (RECORDS BF FX FSB STK)
                                  (CONSTANTS \#ALINK.OFFSET)
                                  (GLOBALVARS \PENDINGINTERRUPT \KBDSTACKBASE \MISCSTACKBASE 
                                         \STACKOVERFLOW)
                                  (MACROS \MYALINK ADDSTACKBASE STACKADDBASE STACKGETBASE 
                                         STACKGETBASEPTR STACKPUTBASE STACKPUTBASEPTR \MISCAPPLY*)
                                  (RECORDS STACKP)
                                  (CONSTANTS * STACKTYPES)
                                  (CONSTANTS \StackAreaSize (\InitStackSize (ITIMES \StackAreaSize 12
                                                                                   )))
                                  (CONSTANTS \MAXSAFEUSECOUNT)
                                  (RECORDS NAMETABLESLOT FVARSLOT PVARSLOT STKTEMPSLOT BINDMARKSLOT)
                                  (CONSTANTS \NT.IVAR \NT.PVAR \NT.FVAR))
               (RECORDS STACKCELL))
        (COMS (* ; "FOR LAMBDA* FUNCTIONS")
              (FNS \MYARGCOUNT \ARG0 \SETARG0))
        (COMS (* ; "basic spaghetti for allocating, moving and reclaiming stack frames")
              (FNS \HARDRETURN \DOHARDRETURN \DOGC1 \DOGC \DOHARDRETURN1 \DOSTACKOVERFLOW \MOVEFRAME 
                   \INCUSECOUNT \DECUSECOUNT \MAKESTACKP \SMASHLINK \FREESTACKBLOCK \EXTENDSTACK))
        (COMS (* ; "Some ugly stack-munging ufns")
              (FNS \SLOWRETURN \COPY.N.UFN \POP.N.UFN \STORE.N.UFN \UNWIND.UFN))
        (COMS (* ; "parsing stack for gc")
              (FNS \GCSCANSTACK))
        (COMS (* ; "setting up stack from scratch")
              (FNS CLEARSTK HARDRESET RELSTK RELSTKP)
              (FNS SETUPSTACK \SETUPSTACK1 \MAKEFRAME \RESETSTACK \RESETSTACK0 \SETUPGUARDBLOCK 
                   \MAKEFREEBLOCK \REPEATEDLYEVALQT \DUMMYKEYHANDLER \DUMMYTELERAID \CAUSEINTERRUPT 
                   \CONTEXTAPPLY \INTERRUPTFRAME \INTERRUPTED \CODEFORTFRAME \DOMISCAPPLY 
                   \DOMISCAPPLY1))
        (COMS (* ; "Ufns for RETCALL")
              (FNS \DORETCALL \RETCALL))
        (INITVARS (STACKTESTING T))
        (COMS (* ; "Stack overflow handler")
              (FNS \DOSTACKFULLINTERRUPT STACK.FULL.WARNING \CLEANUP.STACKFULL)
              (INITVARS (\PENDINGINTERRUPT)
                     (\STACKOVERFLOW)
                     (AUTOHARDRESETFLG T))
              (ADDVARS (RESETFORMS (SETQ \STACKOVERFLOW)))
              (GLOBALVARS AUTOHARDRESETFLG))
        (DECLARE: DONTCOPY
               (ADDVARS [INEWCOMS (FNS SETUPSTACK \SETUPSTACK1 \SETUPGUARDBLOCK \MAKEFREEBLOCK)
                               (ALLOCAL (ADDVARS (LOCKEDFNS \RESETSTACK0 \MAKEFRAME \SETUPSTACK1 
                                                        \MAKEFREEBLOCK \FAULTHANDLER \KEYHANDLER 
                                                        \DUMMYKEYHANDLER \DOTELERAID \DUMMYTELERAID 
                                                        \DOHARDRETURN \DOGC \CAUSEINTERRUPT 
                                                        \INTERRUPTFRAME \CODEFORTFRAME 
                                                        \DOSTACKOVERFLOW \UNLOCKPAGES \DOMISCAPPLY)
                                               (LOCKEDVARS \InterfacePage \DEFSPACE \STACKSPACE 
                                                      \KBDSTACKBASE \MISCSTACKBASE]
                      (EXPANDMACROFNS ADDSTACKBASE STACKADDBASE))
               EVAL@COMPILE
               (ADDVARS (DONTCOMPILEFNS SETUPSTACK)))
        (LOCALVARS . T)
        (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                            (NLAML)
                                                                            (LAMA \INTERRUPTFRAME])
(DECLARE: DONTCOPY 
(* FOLLOWING DEFINITIONS EXPORTED)


(DECLARE: EVAL@COMPILE

(ACCESSFNS BF
 ((BFBLOCK (ADDSTACKBASE DATUM)))
               (* ; "basic frame pointer")

              (BLOCKRECORD BFBLOCK ((FLAGS BITS 3)
                                    (NIL BITS 3)
                                    (RESIDUAL FLAG)
          (* ; "true if this is not a full BF")

                                    (PADDING BITS 1)
                                    (USECNT BITS 8)
                                    (IVAR WORD)))
              (TYPE?
 (IEQ (fetch
 (BF FLAGS) of
 DATUM)
                          \STK.BF))
              [ACCESSFNS BF ((NARGS (IDIFFERENCE (FOLDLO (IDIFFERENCE DATUM (fetch
 (BF IVAR)
                                                                               of
 DATUM))
                                                        WORDSPERCELL)
                                           (fetch
 (BF PADDING) of
 DATUM)))
                             [SIZE (IPLUS 2 (IDIFFERENCE DATUM (fetch
 (BF IVAR) of
 DATUM]
                             (CHECKED (AND (type?
 BF DATUM)
                                           (for
 I from
 (fetch
 (BF IVAR) of
 DATUM)
                                              to
 (IDIFFERENCE DATUM 2) by
 2
                                              always
 (IEQ \STK.NOTFLAG (fetch
 (BF FLAGS) of
 I])

(ACCESSFNS FX
 ((FXBLOCK (ADDSTACKBASE DATUM)))
               (* ; "frame extension index")

              (BLOCKRECORD FXBLOCK ((FLAGS BITS 3)
           (* ; "= \STK.FX")

                                    (FAST FLAG)
                                    (NIL FLAG)
                                    (INCALL FLAG)
      (* ; "set when fncall microcode has to punt")

                                    (VALIDNAMETABLE FLAG)

                                                  (* ; 

                                  "if on, NAMETABLE field is filled in.  If off, is same as FNHEADER")

                                    (NOPUSH FLAG)
 (* ; 

                           "when returning to this frame, don't push a value.  Set by interrupt code")

                                    (USECNT BITS 8)
                                    (#ALINK WORD)
            (* ; "low bit is SLOWP")

                                    (FNHEADLO WORD)

                                                  (* ; 

                                                  "pointer in swapped order with HILOC duplicated")

                                    (FNHEADHI1 BYTE)
                                    (FNHEADHI2 BYTE)
                                    (NEXTBLOCK WORD)
                                    (PC WORD)
                                    (NAMETABLO WORD)
                                    (NAMETABHI1 BYTE)
                                    (NAMETABHI2 BYTE)
                                    (#BLINK WORD)
                                    (#CLINK WORD)))
              (BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE)
                                    (NIL BYTE)
                                    (NIL BITS 15)
            (* ; "most of the bits of #ALINK")

                                    (SLOWP FLAG)
  (* ; 

                           "if on, then BLINK and CLINK fields are valid.  If off, they are implicit")

                                    ))
              (TYPE?
 (IEQ (fetch
 (FX FLAGS) of
 DATUM)
                          \STK.FX))
              [ACCESSFNS FX ([FNHEADER (\VAG2 (fetch
 (FX FNHEADHI) of
 DATUM)
                                              (fetch
 (FX FNHEADLO) of
 DATUM))
                                    (PROGN (replace
 (FX FNHEADHI) of
 DATUM with
 (\HILOC NEWVALUE))
                                           (replace
 (FX FNHEADLO) of
 DATUM with
 (\LOLOC NEWVALUE]
                             (FNHEADHI (fetch
 (FX FNHEADHI2) of
 DATUM)
                                    (PROGN (replace
 (FX FNHEADHI1) of
 DATUM with
 NEWVALUE)
                                           (replace
 (FX FNHEADHI2) of
 DATUM with
 NEWVALUE)))
                             [NAMETABLE# (\VAG2 (fetch
 (FX NAMETABHI) of
 DATUM)
                                                (fetch
 (FX NAMETABLO) of
 DATUM))
                                    (PROGN (replace
 (FX NAMETABHI) of
 DATUM with
 (\HILOC NEWVALUE))
                                           (replace
 (FX NAMETABLO) of
 DATUM with
 (\LOLOC NEWVALUE]
                             (NAMETABLE (COND
                                           ((fetch
 (FX VALIDNAMETABLE) of
 DATUM)
                                            (fetch
 (FX NAMETABLE#) of
 DATUM))
                                           (T (fetch
 (FX FNHEADER) of
 DATUM)))
                                    (PROGN (replace
 (FX FAST) of
 DATUM with
 NIL)
                                           (replace
 (FX NAMETABLE#) of
 DATUM with
 NEWVALUE)
                                           (replace
 (FX VALIDNAMETABLE) of
 DATUM with
 T)))
                             (NAMETABHI (fetch
 (FX NAMETABHI2) of
 DATUM)
                                    (PROGN (replace
 (FX NAMETABHI1) of
 DATUM with
 NEWVALUE)
                                           (replace
 (FX NAMETABHI2) of
 DATUM with
 NEWVALUE)))
                             (FRAMENAME (fetch
 (FNHEADER FRAMENAME) of
 (fetch
 (FX NAMETABLE)
                                                                          of
 DATUM)))
                             (INVALIDP (EQ DATUM 0))

                                                  (* ; 

                                     "true when A/CLink points at nobody, i.e. FX is bottom of stack")

                             [FASTP (NOT (fetch
 (FX SLOWP) of
 DATUM))
                                    (PROGN (CHECK (NULL NEWVALUE))
                                           (COND
                                              ((fetch
 (FX FASTP) of
 DATUM)
                                               (replace
 (FX #BLINK) of
 DATUM
                                                  with
 (fetch
 (FX DUMMYBF) of
 DATUM))
                                               (replace
 (FX #CLINK) of
 DATUM
                                                  with
 (fetch
 (FX #ALINK) of
 DATUM))
                                               (replace
 (FX SLOWP) of
 DATUM with
 T]
                             [BLINK (COND
                                       ((fetch
 (FX FASTP) of
 DATUM)
                                        (fetch
 (FX DUMMYBF) of
 DATUM))
                                       (T (fetch
 (FX #BLINK) of
 DATUM)))
                                    (PROGN (replace
 (FX #BLINK) of
 DATUM with
 NEWVALUE)
                                           (COND
                                              ((fetch
 (FX FASTP) of
 DATUM)
                                               (replace
 (FX #CLINK) of
 DATUM
                                                  with
 (fetch
 (FX #ALINK) of
 DATUM))
                                               (replace
 (FX SLOWP) of
 DATUM with
 T]
                             [CLINK (IDIFFERENCE (COND
                                                    ((fetch
 (FX FASTP) of
 DATUM)
                                                     (fetch
 (FX #ALINK) of
 DATUM))
                                                    (T (fetch
 (FX #CLINK) of
 DATUM)))
                                           \#ALINK.OFFSET)
                                    (PROGN (replace
 (FX #CLINK) of
 DATUM with
 (IPLUS NEWVALUE 
                                                                                     \#ALINK.OFFSET))
                                           (COND
                                              ((fetch
 (FX FASTP) of
 DATUM)
                                               (replace
 (FX #BLINK) of
 DATUM
                                                  with
 (fetch
 (FX DUMMYBF) of
 DATUM))
                                               (replace
 (FX SLOWP) of
 DATUM with
 T]
                             [ALINK (IDIFFERENCE (FLOOR (fetch
 (FX #ALINK) of
 DATUM)
                                                        WORDSPERCELL)
                                           \#ALINK.OFFSET)
                                    (PROGN [COND
                                              ((fetch
 (FX FASTP) of
 DATUM)
                                               (replace
 (FX #BLINK) of
 DATUM
                                                  with
 (fetch
 (FX DUMMYBF) of
 DATUM))
                                               (replace
 (FX #CLINK) of
 DATUM
                                                  with
 (fetch
 (FX #ALINK) of
 DATUM]
                                           (replace
 (FX #ALINK) of
 DATUM with
 (IPLUS NEWVALUE 
                                                                                     \#ALINK.OFFSET
                                                                                     (SUB1 
                                                                                         WORDSPERCELL
                                                                                           ]
                             [ACLINK (SHOULDNT)
                                    (PROGN [COND
                                              ((fetch
 (FX FASTP) of
 DATUM)
                                               (replace
 (FX #BLINK) of
 DATUM
                                                  with
 (fetch
 (FX DUMMYBF) of
 DATUM]
                                           (replace
 (FX #CLINK) of
 DATUM with
 (IPLUS NEWVALUE 
                                                                                     \#ALINK.OFFSET))
                                           (replace
 (FX #ALINK) of
 DATUM with
 (IPLUS NEWVALUE 
                                                                                     \#ALINK.OFFSET
                                                                                     (SUB1 
                                                                                         WORDSPERCELL
                                                                                           ]

                                                  (* ; 

                                      "replaces A & C Links at once more efficiently than separately")

                             (DUMMYBF (IDIFFERENCE DATUM WORDSPERCELL))

                                                  (* ;; "This is either an actual BF or %"residual%" BF that provides enough BF to find its IVAR slot.  This means that when a FX is copied, the cell preceding the FX is copied too.")

                             (IVAR (fetch
 (BF IVAR) of
 (fetch
 (FX DUMMYBF) of
 DATUM)))
                             [CHECKED (AND (type?
 FX DATUM)
                                           (OR (IEQ (fetch
 (FX DUMMYBF) of
 DATUM)
                                                    (fetch
 (FX BLINK) of
 DATUM))
                                               (AND (fetch
 (BF RESIDUAL) of
 (fetch
 (FX DUMMYBF)
                                                                               of
 DATUM))
                                                    (IEQ (fetch
 (BF IVAR) of
 (fetch
 (FX DUMMYBF)
                                                                                of
 DATUM))
                                                         (fetch
 (BF IVAR) of
 (fetch
 (FX BLINK)
                                                                                of
 DATUM]
                             (FIRSTPVAR (IPLUS DATUM (fetch
 (FX FXSIZE) of
 T)))

                                                             (* ; "stack offset of PVAR0")

                             (FXSIZE (PROGN 10))
        (* ; "fixed overhead from flags thru clink")

                             (PADDING (PROGN 4))
     (* ; "doublecell of garbage for microcode use")

                             (FIRSTTEMP (IPLUS (fetch
 (FX FIRSTPVAR) of
 DATUM)
                                               (fetch
 (FX NPVARWORDS) of
 DATUM)
                                               (fetch
 (FX PADDING) of
 DATUM)))

                                                  (* ; 

                                                 "note that NPVARWORDS is obtained from the FNHEADER")

                             (SIZE (IDIFFERENCE (fetch
 (FX NEXTBLOCK) of
 DATUM)
                                          DATUM])

(ACCESSFNS FSB
 ((FSBBLOCK (ADDSTACKBASE DATUM))
                (CHECKED (IEQ (fetch
 (FSB FLAGWORD) of
 DATUM)
                              \STK.FSB.WORD)))
               (BLOCKRECORD FSBBLOCK ((FLAGS BITS 3)
                                      (DUMMY BITS 13)
                                      (SIZE WORD)))
               (BLOCKRECORD FSBBLOCK ((FLAGWORD WORD)
                                      (SIZE WORD)))
          (* ; "free stack block")

               (TYPE?
 (IEQ (fetch
 (FSB FLAGS) of
 DATUM)
                           \STK.FSB)))

(ACCESSFNS STK
 ((STKBLOCK (ADDSTACKBASE DATUM)))
             (* ; "unspecified stack block")

               (BLOCKRECORD STKBLOCK ((FLAGS BITS 3)))
               (BLOCKRECORD STKBLOCK ((FLAGWORD WORD))))
)
(DECLARE: EVAL@COMPILE 

(RPAQQ \#ALINK.OFFSET
 10)

(CONSTANTS \#ALINK.OFFSET)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \PENDINGINTERRUPT \KBDSTACKBASE \MISCSTACKBASE \STACKOVERFLOW)
)
(DECLARE: EVAL@COMPILE 

[PUTPROPS \MYALINK DMACRO (NIL ((OPCODES MYALINK]
(PUTPROPS ADDSTACKBASE DMACRO (= . STACKADDBASE))
(PUTPROPS STACKADDBASE DMACRO ((N)
                               (VAG2 \STACKHI N)))
(PUTPROPS STACKGETBASE DMACRO ((N)
                               (\GETBASE (STACKADDBASE N)
                                      0)))
(PUTPROPS STACKGETBASEPTR DMACRO ((N)
                                  (\GETBASEPTR (STACKADDBASE N)
                                         0)))
(PUTPROPS STACKPUTBASE DMACRO ((N V)
                               (\PUTBASE (STACKADDBASE N)
                                      0 V)))
(PUTPROPS STACKPUTBASEPTR DMACRO ((N V)
                                  (\PUTBASEPTR (STACKADDBASE N)
                                         0 V)))
[PUTPROPS \MISCAPPLY* MACRO ((FN ARG1 ARG2)
                             (UNINTERRUPTABLY
                                 (replace
 (IFPAGE MISCSTACKFN) of
 \InterfacePage with
 FN)
                                 (replace
 (IFPAGE MISCSTACKARG1) of
 \InterfacePage with
 ARG1)
                                 (replace
 (IFPAGE MISCSTACKARG2) of
 \InterfacePage with
 ARG2)
                                 (\CONTEXTSWITCH \MiscFXP)
                                 (fetch
 (IFPAGE MISCSTACKRESULT) of
 \InterfacePage))]
)
(DECLARE: EVAL@COMPILE

(BLOCKRECORD STACKP
 ((STACKP0 WORD)
                     (EDFXP WORD))
                    (BLOCKRECORD STACKP ((STACKPOINTER FULLXPOINTER)))
                    (TYPE?
 (STACKP DATUM)))
)

(RPAQQ STACKTYPES
 (\STK.GUARD \STK.FX \STK.BF \STK.NOTFLAG \STK.FSB \STK.FLAGS.SHIFT
                         (\STK.FSB.WORD (LLSH \STK.FSB \STK.FLAGS.SHIFT))
                         (\STK.GUARD.WORD (LLSH \STK.GUARD \STK.FLAGS.SHIFT))
                         (\STK.BF.WORD (LLSH \STK.BF \STK.FLAGS.SHIFT))))
(DECLARE: EVAL@COMPILE 

(RPAQQ \STK.GUARD
 7)

(RPAQQ \STK.FX
 6)

(RPAQQ \STK.BF
 4)

(RPAQQ \STK.NOTFLAG
 0)

(RPAQQ \STK.FSB
 5)

(RPAQQ \STK.FLAGS.SHIFT
 13)

(RPAQ \STK.FSB.WORD
 (LLSH \STK.FSB \STK.FLAGS.SHIFT))

(RPAQ \STK.GUARD.WORD
 (LLSH \STK.GUARD \STK.FLAGS.SHIFT))

(RPAQ \STK.BF.WORD
 (LLSH \STK.BF \STK.FLAGS.SHIFT))

(CONSTANTS \STK.GUARD \STK.FX \STK.BF \STK.NOTFLAG \STK.FSB \STK.FLAGS.SHIFT (\STK.FSB.WORD
                                                                              (LLSH \STK.FSB 
                                                                                    \STK.FLAGS.SHIFT)
                                                                              )
       (\STK.GUARD.WORD (LLSH \STK.GUARD \STK.FLAGS.SHIFT))
       (\STK.BF.WORD (LLSH \STK.BF \STK.FLAGS.SHIFT)))
)
(DECLARE: EVAL@COMPILE 

(RPAQQ \StackAreaSize
 768)

(RPAQ \InitStackSize
 (ITIMES \StackAreaSize 12))

(CONSTANTS \StackAreaSize (\InitStackSize (ITIMES \StackAreaSize 12)))
)
(DECLARE: EVAL@COMPILE 

(RPAQQ \MAXSAFEUSECOUNT
 200)

(CONSTANTS \MAXSAFEUSECOUNT)
)
(DECLARE: EVAL@COMPILE

(BLOCKRECORD NAMETABLESLOT
 ((VARTYPE BYTE)
                            (VAROFFSET BYTE)))

(BLOCKRECORD FVARSLOT
 ((BINDLO WORD)
                       (BINDHI1 BYTE)
                       (BINDHI2 BYTE))
                      [ACCESSFNS FVARSLOT ((LOOKEDUP (EVENP (fetch
 BINDLO of
 DATUM)))
                                           (BINDINGPTR (\VAG2 (fetch
 BINDHI1 of
 DATUM)
                                                              (fetch
 BINDLO of
 DATUM))
                                                  (PROGN (replace
 BINDLO of
 DATUM with
 (\LOLOC 
                                                                                             NEWVALUE
                                                                                              ))
                                                         (replace
 BINDHI1 of
 DATUM
                                                            with
 (replace
 BINDHI2 of
 DATUM
                                                                    with
 (\HILOC NEWVALUE])

(BLOCKRECORD PVARSLOT
 ((PVHI BYTE)
                       (PVVALUE XPOINTER))
                      [ACCESSFNS PVARSLOT ((BOUND (EQ (fetch
 (PVARSLOT PVHI) of
 DATUM)
                                                      0)
                                                  (if
 (NULL NEWVALUE)
                                                      then
 (replace
 (PVARSLOT PVHI) of
 DATUM
                                                              with
 255)
                                                    else
 (ERROR "Illegal replace" NEWVALUE])

(BLOCKRECORD STKTEMPSLOT
 ((STKTMPHI BYTE)
                          (VALUE XPOINTER))
                         [ACCESSFNS STKTEMPSLOT ((BINDINGPTRP (NEQ (fetch
 STKTMPHI of
 DATUM)
                                                                   0])

(BLOCKRECORD BINDMARKSLOT
 ((BINDMARKP FLAG)
                           (NIL BITS 15))
                          (BLOCKRECORD BINDMARKSLOT ((BINDNEGVALUES WORD)
                                                     (BINDLASTPVAR WORD)))
                          [ACCESSFNS BINDMARKSLOT ((BINDNVALUES (PROGN 

                                                  (* ; 

                            "Value stored in high half is one's complement of number of values bound")

                                                                       (LOGXOR (fetch
 BINDNEGVALUES
                                                                                  of
 DATUM)
                                                                              65535])
)
(DECLARE: EVAL@COMPILE 

(RPAQQ \NT.IVAR
 0)

(RPAQQ \NT.PVAR
 128)

(RPAQQ \NT.FVAR
 192)

(CONSTANTS \NT.IVAR \NT.PVAR \NT.FVAR)
)


(* END EXPORTED DEFINITIONS)


(DECLARE: EVAL@COMPILE

(BLOCKRECORD STACKCELL
 ((STACKNONPOINTERBITS BITS 8)
                        (STACKHIBITS BITS 8)
                        (STACKLOBITS WORD))
                       [ACCESSFNS STACKCELL ((VALIDPOINTERP (EQ 0 (fetch
 (STACKCELL 
                                                                                STACKNONPOINTERBITS)
                                                                     of
 DATUM)))
                                             (VALIDPOINTER (\GETBASEPTR DATUM 0])
)
)



(* ; "FOR LAMBDA* FUNCTIONS")


(DEFINEQ

(\MYARGCOUNT

  [LAMBDA NIL
                                                (* lmm " 6-OCT-81 23:15")

          
          (* Put out by the compiler in lambda* functions, returns number of arguments of 

          the caller, to be bound to the lambda* variable.

          Eventually will be an opcode)


    (fetch
 (BF NARGS) of
 (fetch
 (FX BLINK) of
 (\MYALINK])

(\ARG0

  [LAMBDA (N)
                                                (* lmm " 6-OCT-81 23:15")

                                                             (* call to this function put out by 

                                                             compiler when compiling ARG for local 

                                                             argument. Returns Nth argument of 

                                                             parent's frame)

    (PROG [(BFLINK (fetch
 (FX BLINK) of
 (\MYALINK]           (* BFLINK is the basic frame we are 

                                                             looking at)

          (CHECK (type?
 BF BFLINK))
          (RETURN (COND
                     [[AND (IGREATERP N 0)
                           (NOT (IGREATERP N (fetch
 (BF NARGS) of
 BFLINK]
                                                             (* N must be between 1 and the number 

                                                             of arguments)

                      (GETBASEPTR \STACKSPACE (IPLUS (fetch
 (BF IVAR) of
 BFLINK)
                                                     (LLSH (SUB1 N)
                                                           1]
                     (T (LISPERROR "ILLEGAL ARG" N])

(\SETARG0

  [LAMBDA (N VAL)
                                            (* bvm: " 5-Feb-85 16:10")

                                                             (* call to this function put out by 

                                                             compiler when compiling SETARG for 

                                                             local argument. Sets Nth argument of 

                                                             parent's frame)

    (PROG [(BFLINK (fetch
 (FX BLINK) of
 (\MYALINK]           (* BFLINK is the basic frame we are 

                                                             looking at)

          (CHECK (type?
 BF BFLINK))
          (RETURN (COND
                     ([AND (IGREATERP N 0)
                           (NOT (IGREATERP N (fetch
 (BF NARGS) of
 BFLINK]
                                                             (* N must be between 1 and the number 

                                                             of arguments)

                      (\PUTBASEPTR (ADDSTACKBASE (IPLUS (fetch
 (BF IVAR) of
 BFLINK)
                                                        (UNFOLD (SUB1 N)
                                                               WORDSPERCELL)))
                             0 VAL))
                     (T (LISPERROR "ILLEGAL ARG" N])
)



(* ; "basic spaghetti for allocating, moving and reclaiming stack frames")


(DEFINEQ

(\HARDRETURN

  [LAMBDA (VAL)
                                              (* lmm "20-JUL-81 13:45")

                                                             (* Called by the microcode instead of 

                                                             returning to a frame whose use count 

                                                             is greater than one.)

    (\CONTEXTSWITCH \HardReturnFXP)
    VAL])

(\DOHARDRETURN

  [LAMBDA NIL
                                                (* lmm "27-JUL-81 09:07")

    (PROG NIL
      LP  (\DOHARDRETURN1
 (fetch
 (IFPAGE HardReturnFXP) of
 \InterfacePage))
          (\CONTEXTSWITCH \HardReturnFXP)
          (GO LP])

(\DOGC1

  [LAMBDA NIL
                                                (* lmm " 1-SEP-81 00:53")

    (\GCSCANSTACK
)
    (\GCMAPSCAN)                                             (* map thru, releasing entries)

    (\GCMAPUNSCAN)                                           (* map thru, unmarking stack entries)

    ])

(\DOGC

  [LAMBDA NIL
                                                (* lmm " 1-SEP-81 00:52")

    (PROG NIL
      LP  (\DOGC1
)
          (\CONTEXTSWITCH \GCFXP)
          (GO LP])

(\DOHARDRETURN1

  [LAMBDA (HRFRAME)
                                          (* bvm: " 8-Jun-85 22:33")

          
          (* executed in the hard return context. HRFRAME is the context in which 

          \HARDRETURN was invoked. We want to fix \HARDRETURN's caller to do a return to 

          its caller)


    [COND
       ((EQ (fetch
 (FX FNHEADER FRAMENAME) of
 HRFRAME)
            (QUOTE \CONTEXTSWITCH))                          (* We really want to mung \HARDRETURN 

                                                             frame, not \CONTEXTSWITCH.

                                                             Test is needed in case \CONTEXTSWITCH 

                                                             is microcode)

        (SETQ HRFRAME (fetch
 (FX CLINK) of
 HRFRAME]
    (PROG ((RETURNER (fetch
 (FX CLINK) of
 HRFRAME))
           RETURNEE AX NEW SIZE RETBF)
          (CHECK (EQ (fetch
 (FX FNHEADER FRAMENAME) of
 HRFRAME)
                     (QUOTE \HARDRETURN)))
          (SETQ RETURNEE (fetch
 (FX CLINK) of
 RETURNER))
          [CHECK (fetch
 (FX CHECKED) of
 RETURNEE)
                 (fetch
 (FX CHECKED) of
 RETURNER)
                 (NOT (fetch
 (FX FASTP) of
 RETURNER))
                 (OR (NEQ RETURNEE (fetch
 (FX ALINK) of
 RETURNER))
                     (COND
                        ((NEQ (fetch
 (FX USECNT) of
 RETURNEE)
                              0)                             (* use count of RETURNEE gt 1, must 

                                                             copy RETURNEE)

                         T)
                        ((type?
 FSB (SETQ AX (fetch
 (FX NEXTBLOCK) of
 RETURNEE)))
                                                             (* returnee followed by a free block, 

                                                             but that free block is too small)

                         (ILEQ (fetch
 (FSB SIZE) of
 AX)
                               \MinExtraStackWords))
                        (T 
          
          (* used to check ((EQ AX (fetch (BF IVAR) of

          (SETQ AX (fetch (FX BLINK) of RETURNER))))

          (* returnee followed by RETURNER's BF but it doesn't have a non-zero usecount)

          (NEQ (fetch (BF USECNT) of AX) 0)))

                                                             (* must copy in all other cases)

                           T]
          (COND
             ((NEQ RETURNEE (SETQ AX (fetch
 (FX ALINK) of
 RETURNER)))
                                                             (* ALINK and CLINK of returner not the 

                                                             same. Fix.)

                                                             (* Set new ALINK before decrementing 

                                                             count on old value)

              (replace
 (FX ALINK) of
 RETURNER with
 RETURNEE)
              (\DECUSECOUNT
 AX)))
          (COND
             ((COND
                 ((NEQ (fetch
 (FX USECNT) of
 RETURNEE)
                       0)                                    (* use count of RETURNEE gt 1, must 

                                                             copy RETURNEE)

                  T)
                 ((type?
 FSB (SETQ AX (fetch
 (FX NEXTBLOCK) of
 RETURNEE)))
                                                             (* returnee followed by a free block, 

                                                             but that free block is too small)

                                                             (* SHOULD REALLY REQUIRE MICROCODE 

                                                             MERGE THE FREE BLOCKS)

                  (while
 [type?
 FSB (SETQ NEW (IPLUS AX (fetch
 (FSB SIZE) of
 AX]
                     do
 (add
 (fetch
 (FSB SIZE) of
 AX)
                             (fetch
 (FSB SIZE) of
 NEW)))
                  (ILEQ (fetch
 (FSB SIZE) of
 AX)
                        \MinExtraStackWords))
                 ([EQ AX (fetch
 (BF IVAR) of
 (SETQ AX (fetch
 (FX BLINK) of
 RETURNER]
                                                             (* returnee followed by RETURNER's BF 

                                                             but it doesn't have a non-zero 

                                                             usecount)

                  (NEQ (fetch
 (BF USECNT) of
 AX)
                       0))
                 (T                                          (* must copy in all other cases)

                    T))                                      (* Must copy returnee to a new block 

                                                             because there isn't enough room to 

                                                             return a value to it)

              (FLIPCURSORBAR 5)
              (SETQ SIZE (IPLUS (fetch
 (FX SIZE) of
 RETURNEE)
                                WORDSPERCELL))
              (SETQ NEW (\FREESTACKBLOCK
 SIZE RETURNER))     (* Find a free stack block)

              (\BLT (ADDSTACKBASE NEW)
                    (ADDSTACKBASE (IDIFFERENCE RETURNEE WORDSPERCELL))
                    SIZE)                                    (* copy frame and dummy bf pointer too)

              (replace
 (BF RESIDUAL) of
 NEW with
 T)
              (add
 NEW WORDSPERCELL)                         (* now NEW points to the FX)

              (replace
 (FX NEXTBLOCK) of
 NEW with
 (IDIFFERENCE (IPLUS NEW SIZE)
                                                         WORDSPERCELL))
              (replace
 (FX BLINK) of
 NEW with
 (SETQ RETBF (fetch
 (FX BLINK) of
 RETURNEE)))
                                                             (* Point to the real BF, not the 

                                                             residual)

              (replace
 (FX USECNT) of
 NEW with
 0)
              (CHECK (fetch
 (BF CHECKED) of
 RETBF))
              [COND
                 ((AND (fetch
 (FX VALIDNAMETABLE) of
 NEW)
                       (EQ (fetch
 (FX NAMETABHI) of
 NEW)
                           \STACKHI))
                  (CHECK ([LAMBDA (N)
                            (AND (IGREATERP N RETURNEE)
                                 (ILESSP N (fetch
 (FX NEXTBLOCK) of
 RETURNEE]
                          (fetch
 (FX NAMETABLO) of
 RETURNEE)))
                  (add
 (fetch
 (FX NAMETABLO) of
 NEW)
                       (IDIFFERENCE NEW RETURNEE]
              (add
 (fetch
 (BF USECNT) of
 RETBF)
                   1)                                        (* increment use count of basic frame 

                                                             of returnee because we made another FX 

                                                             which points to it)

              (replace
 (FX FASTP) of
 RETURNEE with
 NIL)
              (\INCUSECOUNT
 (SETQ AX (fetch
 (FX CLINK) of
 RETURNEE)))
                                                             (* increment use count of CLINK of 

                                                             returnee because we made a copy of 

                                                             returnee)

              (COND
                 ((NEQ AX (SETQ AX (fetch
 (FX ALINK) of
 RETURNEE)))
                  (\INCUSECOUNT
 AX)))
              (\DECUSECOUNT
 RETURNEE)
              (replace
 (FX ACLINK) of
 RETURNER with
 NEW)
              (CHECK (fetch
 (FX CHECKED) of
 NEW)
                     (fetch
 (FX CHECKED) of
 RETURNER))
              (SETQ RETURNEE NEW)
              (FLIPCURSORBAR 5)))
          (\SMASHLINK
 HRFRAME RETURNEE RETURNEE])

(\DOSTACKOVERFLOW

  [LAMBDA NIL
                                                (* lmm "27-JUL-81 15:52")

    (PROG NIL
      LP  (replace
 (IFPAGE SubovFXP) of
 \InterfacePage with
 (\MOVEFRAME
 (fetch
 (IFPAGE SubovFXP)
                                                                           of
 \InterfacePage)))
          (\CONTEXTSWITCH \SubovFXP)
          (GO LP])

(\MOVEFRAME

  [LAMBDA (OLDFRAME)
                                         (* bvm: " 8-Jun-85 22:29")

    (FLIPCURSORBAR 10)
          
          (* * Called from \DOSTACKOVERFLOW when there isn't enough space to run in 

          OLDFRAME -

          Either we're at the end of stack space, in which case we can just extend the 

          stack a bit, or we need to move OLDFRAME to somewhere else that has more free 

          space after it.)


    (PROG ((SIZE (IPLUS (fetch
 (FX SIZE) of
 OLDFRAME)
                        WORDSPERCELL))
           (NXT (fetch
 (FX NEXTBLOCK) of
 OLDFRAME))
           AX NEW)
          [COND
             ((type?
 FSB NXT)
              (while
 [type?
 FSB (SETQ NEW (IPLUS NXT (fetch
 (FSB SIZE) of
 NXT]
                 do
                                          (* merge free blocks)

                    (add
 (fetch
 (FSB SIZE) of
 NXT)
                         (fetch
 (FSB SIZE) of
 NEW)))
              (COND
                 ((AND (EQ NEW (fetch
 (IFPAGE EndOfStack) of
 \InterfacePage))
                       (\EXTENDSTACK
))
                  (SETQ NEW OLDFRAME)
                  (GO OUT]                                   (* Must copy OLDFRAME to a new block 

                                                             because there isn't enough room to run 

                                                             in it)

          (CHECK (fetch
 (FX CHECKED) of
 OLDFRAME)
                 (EQ (fetch
 (FX USECNT) of
 OLDFRAME)
                     0)
                 (NOT \INTERRUPTABLE))
          (SETQ NEW (\FREESTACKBLOCK
 SIZE OLDFRAME))         (* Find a free stack block)

          (\BLT (ADDSTACKBASE NEW)
                (ADDSTACKBASE (IDIFFERENCE OLDFRAME WORDSPERCELL))
                SIZE)                                        (* copy frame and dummy bf pointer too)

          (replace
 (BF RESIDUAL) of
 NEW with
 T)
          (add
 NEW WORDSPERCELL)                             (* now NEW points to the FX)

          (replace
 (FX NEXTBLOCK) of
 NEW with
 (IDIFFERENCE (IPLUS NEW SIZE)
                                                     WORDSPERCELL))
          (CHECK (fetch
 (BF CHECKED) of
 (fetch
 (FX BLINK) of
 OLDFRAME)))
          (replace
 (FX BLINK) of
 NEW with
 (fetch
 (FX BLINK) of
 OLDFRAME))
                                                             (* Point at true BF, not residual)

          [COND
             ((AND (fetch
 (FX VALIDNAMETABLE) of
 NEW)
                   (EQ (fetch
 (FX NAMETABHI) of
 NEW)
                       \STACKHI))                            (* Frame's nametable is on the stack, 

                                                             so it moved at the same time the frame 

                                                             did)

              [CHECK (LET ((N (fetch
 (FX NAMETABLO) of
 OLDFRAME)))
                          (AND (IGREATERP N OLDFRAME)
                               (ILESSP N (fetch
 (FX NEXTBLOCK) of
 OLDFRAME]
              (add
 (fetch
 (FX NAMETABLO) of
 NEW)
                   (IDIFFERENCE NEW OLDFRAME]
          [COND
             ((fetch
 (BF RESIDUAL) of
 (fetch
 (FX DUMMYBF) of
 OLDFRAME))
              (\MAKEFREEBLOCK
 (IDIFFERENCE OLDFRAME WORDSPERCELL)
                     SIZE))
             (T (\MAKEFREEBLOCK
 OLDFRAME (IDIFFERENCE SIZE WORDSPERCELL]
      OUT (FLIPCURSORBAR 10)                                 (* Restore cursor)

          (RETURN NEW])

(\INCUSECOUNT

  [LAMBDA (FRAME)
                                            (* bvm: "23-Mar-84 18:01")

    [COND
       ((NOT (fetch
 (FX INVALIDP) of
 FRAME))
        (CHECK (NOT \INTERRUPTABLE)
               (fetch
 (FX CHECKED) of
 FRAME))
        (COND
           ((IGREATERP (add
 (fetch
 (FX USECNT) of
 FRAME)
                            1)
                   \MAXSAFEUSECOUNT)
            (\MP.ERROR \MP.USECOUNTOVERFLOW "Stack frame use count maximum exceeded" FRAME)))
        (PROG ((SCANPTR (fetch
 (FX NEXTBLOCK) of
 FRAME)))    (* scan for BF ptr)

              (SELECTC (fetch
 (STK FLAGS) of
 SCANPTR)
                  (\STK.NOTFLAG (until
 (type?
 BF (add
 SCANPTR WORDSPERCELL))))
                  (\STK.BF)
                  (RETURN))
              [CHECK (OR (fetch
 (BF RESIDUAL) of
 SCANPTR)
                         (EQ (fetch
 (BF IVAR) of
 SCANPTR)
                             (fetch
 (FX NEXTBLOCK) of
 FRAME]
              (COND
                 ((type?
 FX (add
 SCANPTR WORDSPERCELL))
                  (CHECK (fetch
 (FX CHECKED) of
 SCANPTR))
                  (replace
 (FX FASTP) of
 SCANPTR with
 NIL]
    FRAME])

(\DECUSECOUNT

  [LAMBDA (FRAME)
                                            (* lmm " 4-SEP-81 09:29")

    (PROG (TEMP ALINK BLINK SIZE CLINK)
          (CHECK (NOT \INTERRUPTABLE))
      TOP (COND
             ((fetch
 (FX INVALIDP) of
 FRAME)                 (* reached top of stack)

              (RETURN)))
          (CHECK (fetch
 (FX CHECKED) of
 FRAME))
          (COND
             ((NEQ (fetch
 (FX USECNT) of
 FRAME)
                   0)                                        (* USECNT (= use count + 1) greater 

                                                             than 1, merely decrement it)

              (add
 (fetch
 (FX USECNT) of
 FRAME)
                   -1)
              (RETURN FRAME)))                               (* ok, now free it)

          (SETQ ALINK (fetch
 (FX ALINK) of
 FRAME))
          (SETQ BLINK (fetch
 (FX BLINK) of
 FRAME))
          (SETQ CLINK (fetch
 (FX CLINK) of
 FRAME))
          (SETQ SIZE (fetch
 (FX SIZE) of
 FRAME))
          (COND
             ((fetch
 (BF RESIDUAL) of
 (fetch
 (FX DUMMYBF) of
 FRAME))
              (\MAKEFREEBLOCK
 (IDIFFERENCE FRAME WORDSPERCELL)
                     (IPLUS SIZE WORDSPERCELL)))
             (T (\MAKEFREEBLOCK
 FRAME SIZE)))
          (CHECK (fetch
 (BF CHECKED) of
 BLINK))
          (COND
             ((EQ (fetch
 (BF USECNT) of
 BLINK)
                  0)                                         (* frame extension count+1=0 -

                                                             release basic frame)

              (\MAKEFREEBLOCK
 (fetch
 (BF IVAR) of
 BLINK)
                     (fetch
 (BF SIZE) of
 BLINK)))
             (T                                              (* merely decrement extension count)

                (add
 (fetch
 (BF USECNT) of
 BLINK)
                     -1)))
          (COND
             ((NEQ ALINK CLINK)
              (\DECUSECOUNT
 ALINK)))
          (SETQ FRAME CLINK)
          (GO TOP])

(\MAKESTACKP

  [LAMBDA (ED FX)
                                            (* bvm: " 5-Jun-85 17:21")

                                                             (* Create a STACKP cell, possibly 

                                                             reusing ED, and pointing to FX)

    (UNINTERRUPTABLY
        (COND
           ((NEQ FX 0)
            (\INCUSECOUNT
 FX)))
        (COND
           [(OR (STACKP ED)
                (TYPENAMEP ED (QUOTE PROCESS)))
            (LET ((OLDFX (fetch
 (STACKP EDFXP) of
 ED)))
                 (COND
                    ((NEQ OLDFX 0)
                     (\DECUSECOUNT
 OLDFX]
           (T (SETQ ED (CREATECELL \STACKP))
              (replace
 (STACKP STACKP0) of
 ED with
 \STACKHI)))
        (replace
 (STACKP EDFXP) of
 ED with
 FX))
    ED])

(\SMASHLINK

  [LAMBDA (CALLER ALINK CLINK)
                               (* bvm: " 5-Feb-85 16:19")

                                                             (* Smashes caller's ALINK and/or CLINK 

                                                             with ALINK and CLINK)

    (OR CALLER (SETQ CALLER (\MYALINK)))
    (UNINTERRUPTABLY
        (PROG ((OLDALINK (fetch
 (FX ALINK) of
 CALLER))
               (OLDCLINK (fetch
 (FX CLINK) of
 CALLER))
               BLINK)
              (COND
                 (ALINK (COND
                           ((NEQ ALINK (OR CLINK OLDCLINK))  (* Don't increment twice if ALINK 

                                                             comes out same as CLINK)

                            (\INCUSECOUNT
 ALINK)))
                        (replace
 (FX ALINK) of
 CALLER with
 ALINK)))
              (COND
                 (CLINK (COND
                           ((OR ALINK (NEQ CLINK OLDALINK))  (* If we're only setting the CLINK, 

                                                             and we're setting it to be the same as 

                                                             the ALINK, don't bump count)

                            (\INCUSECOUNT
 CLINK)))
                        (replace
 (FX CLINK) of
 CALLER with
 CLINK)
                        (\DECUSECOUNT
 OLDCLINK)))            (* must be careful to increment any 

                                                             use counts before decrementing any)

              (COND
                 ((AND (NEQ OLDALINK OLDCLINK)
                       ALINK)
                  (\DECUSECOUNT
 OLDALINK)))
              (COND
                 ((AND (EQ (OR ALINK (SETQ ALINK OLDALINK))
                           (OR CLINK (SETQ CLINK OLDCLINK)))
                       (EQ (fetch
 (FX USECNT) of
 CLINK)
                           0)
                       (EQ (SETQ BLINK (fetch
 (FX BLINK) of
 CALLER))
                           (fetch
 (FX DUMMYBF) of
 CALLER))
                       (EQ (fetch
 (BF IVAR) of
 BLINK)
                           (fetch
 (FX NEXTBLOCK) of
 CLINK))
                       (EQ (fetch
 (BF USECNT) of
 BLINK)
                           0)
                       (NOT (fetch
 (FX NOPUSH) of
 CLINK))
                       (NOT (fetch
 (FX INCALL) of
 CLINK)))
          
          (* We have made CALLER fast again: its alink and clink are same, usecnt of 

          blink and caller are normal, bf is contiguous with CALLER and CALLER's caller)


                  (replace
 (FX SLOWP) of
 CALLER with
 NIL)))
              (RETURN CALLER)))])

(\FREESTACKBLOCK

  [LAMBDA (N START)
                                          (* bvm: " 4-Nov-85 17:23")

                                                             (* Scan stack space searching for a 

                                                             free block of size at least n, 

                                                             starting scan at start

                                                             (or beginning of stackspace if 

                                                             START=NIL))

    (PROG ((WANTEDSIZE (IPLUS N \StackAreaSize \MinExtraStackWords))
           FREEPTR FREESIZE (EASP (fetch
 EndOfStack of
 \InterfacePage))
           SCANPTR)
          [CHECK (OR (NULL START)
                     (IGEQ START (fetch
 StackBase of
 \InterfacePage]
      STARTOVER
          (SETQ SCANPTR (OR START (fetch
 StackBase of
 \InterfacePage)))
      SCAN
          (SELECTC (fetch
 (STK FLAGS) of
 SCANPTR)
              (\STK.FSB (GO FREESCAN))
              (\STK.GUARD (COND
                             ((ILESSP SCANPTR EASP)          (* Guard block not at end of stack, 

                                                             treat as a free block)

                              (GO FREESCAN)))                (* reached end)

                          (COND
                             (START                          (* had a starting place, just wrap 

                                                             around)

                                    (SETQ SCANPTR (fetch
 StackBase of
 \InterfacePage))
                                    (GO SCAN))
                             (T                              (* Scanned the entire stack -

                                                             add a new page)

                                (GO NEWPAGE))))
              (\STK.FX                                       (* frame extension)

                       (CHECK (fetch
 (FX CHECKED) of
 SCANPTR))
                       (SETQ SCANPTR (fetch
 (FX NEXTBLOCK) of
 SCANPTR)))
              (PROG ((ORIG SCANPTR))                         (* must be a basic frame)

                    (until
 (type?
 BF SCANPTR) do
 (CHECK (EQ (fetch
 (STK FLAGS) of
 SCANPTR)
                                                            \STK.NOTFLAG))
                                                 (add
 SCANPTR WORDSPERCELL))
                    [CHECK (COND
                              ((fetch
 (BF RESIDUAL) of
 SCANPTR)
                               (EQ SCANPTR ORIG))
                              (T (AND (fetch
 (BF CHECKED) of
 SCANPTR)
                                      (EQ ORIG (fetch
 (BF IVAR) of
 SCANPTR]
                    (add
 SCANPTR WORDSPERCELL)))
      NEXT
          (COND
             ((NEQ SCANPTR START)
              (CHECK (ILEQ SCANPTR EASP))
              (GO SCAN)))
      NEWPAGE
          [COND
             ((SETQ EASP (\EXTENDSTACK
))
              (GO STARTOVER))
             (T (while
 T do
 (\MP.ERROR \MP.STACKFULL 
                                   "Stack Full -- Type LU to see stack; ↑D to flush to top"]
      FREESCAN
          (SETQ FREEPTR SCANPTR)
          (SETQ FREESIZE (fetch
 (FSB SIZE) of
 SCANPTR))
      FREE
                                                             (* MERGE FREE BLOCKS)

          (SETQ SCANPTR (IPLUS FREEPTR FREESIZE))
          (COND
             ((SELECTC (fetch
 (STK FLAGS) of
 SCANPTR)
                  (\STK.FSB T)
                  (\STK.GUARD (ILESSP SCANPTR EASP))
                  NIL)
              (add
 FREESIZE (fetch
 (FSB SIZE) of
 SCANPTR))
              (GO FREE)))
          (COND
             ((IGEQ FREESIZE WANTEDSIZE)                     (* Found a large enough block -

                                                             Split the block)

              [SETQ WANTEDSIZE (COND
                                  ((EVENP FREEPTR WORDSPERQUAD)
                                                             (* alignment ok)

                                   \MinExtraStackWords)
                                  (T                         (* no, adjust alignment)

                                     (IPLUS WORDSPERCELL \MinExtraStackWords]
              (SETQ SCANPTR (\SETUPGUARDBLOCK
 (IPLUS FREEPTR WANTEDSIZE)
                                   N))
              (\MAKEFREEBLOCK
 FREEPTR WANTEDSIZE)
              (\MAKEFREEBLOCK
 (IPLUS SCANPTR N)
                     (IDIFFERENCE (IDIFFERENCE FREESIZE WANTEDSIZE)
                            N))
              (RETURN SCANPTR))
             (T (\MAKEFREEBLOCK
 FREEPTR FREESIZE)))
          (GO NEXT])

(\EXTENDSTACK

  [LAMBDA NIL
                                                (* bvm: "18-JAN-83 12:12")

    (PROG ((EASP (fetch
 (IFPAGE EndOfStack) of
 \InterfacePage))
           SCANPTR)
          (RETURN (COND
                     ((ILESSP EASP \LastStackAddr)
                      (if
 (AND (IGREATERP EASP \GuardStackAddr)
                               (NOT \STACKOVERFLOW))
                          then
 (replace
 STACKOVERFLOW of
 \INTERRUPTSTATE with
 T)
                               (SETQ \STACKOVERFLOW (SETQ \PENDINGINTERRUPT T)))
                      (OR (\DONEWPAGE (ADDSTACKBASE (SETQ SCANPTR (IPLUS EASP 2)))
                                 T)
                          (\DOLOCKPAGES (ADDSTACKBASE SCANPTR)
                                 1))
          
          (* Create, if necessary, new page and lock it.

          Second clause happens when page already existed.

          \DONEWPAGE instead of \NEWPAGE etc. because we are in a safe context

          (and might even be in the misc context))


                      (\MAKEFREEBLOCK
 SCANPTR (IDIFFERENCE WORDSPERPAGE 2))
                      (\SETUPGUARDBLOCK
 (SETQ SCANPTR (IPLUS EASP WORDSPERPAGE))
                             2)
                      (replace
 EndOfStack of
 \InterfacePage with
 SCANPTR)
                      (\MAKEFREEBLOCK
 EASP 2)
                      SCANPTR])
)



(* ; "Some ugly stack-munging ufns")


(DEFINEQ

(\SLOWRETURN

  [LAMBDA NIL
                                                (* lmm "30-Dec-84 03:31")

                                                             (* cause caller to slow return)

    (replace
 (FX FASTP) of
 (\MYALINK) with
 NIL])

(\COPY.N.UFN

  [LAMBDA (ALPHA)
                                            (* lmm " 2-Jan-85 01:29")

    (\.GETBASE32 \STACKSPACE (IDIFFERENCE (fetch
 (FX NEXTBLOCK) of
 (\MYALINK))
                                    (IPLUS ALPHA WORDSPERCELL])

(\POP.N.UFN

  [LAMBDA (N)
                                                (* lmm "11-Apr-85 22:12")

    (\SLOWRETURN
)
    (LET ((AL (\MYALINK))
          NEXT VAL LEN)
         (SETQ NEXT (fetch
 (FX NEXTBLOCK) of
 AL))
         [SETQ VAL (\GETBASEPTR \STACKSPACE (SETQ NEXT (IDIFFERENCE NEXT (SETQ LEN
                                                                          (UNFOLD (ADD1 N)
                                                                                 WORDSPERCELL]
         (\MAKEFREEBLOCK
 NEXT LEN)
         (replace
 (FX NEXTBLOCK) of
 AL with
 NEXT)
         VAL])

(\STORE.N.UFN

  [LAMBDA (VAL ALPHA)
                                        (* lmm " 2-Jan-85 01:30")

    (\.PUTBASE32 \STACKSPACE (IDIFFERENCE (fetch
 (FX NEXTBLOCK) of
 (\MYALINK))
                                    (IPLUS ALPHA WORDSPERCELL))
           VAL])

(\UNWIND.UFN

  [LAMBDA (N.KEEP)
                                           (* bvm: "21-Jul-86 14:37")

          
          (* * "UFN for UNWIND opcode.  The two bytes are the desired stack depth to unwind to and a flag indicating whether to push TOS when done")


    (LET* ((CALLER (\MYALINK))
           (NEXT (fetch
 (FX NEXTBLOCK) of
 CALLER))
           (SP (IDIFFERENCE NEXT WORDSPERCELL))
           (DESIREDSP (IPLUS (IDIFFERENCE (fetch
 (FX FIRSTPVAR) of
 CALLER)
                                    WORDSPERCELL)
                             (UNFOLD (LRSH N.KEEP 8)
                                    WORDSPERCELL)))
           (PUSHP (NEQ (LOGAND N.KEEP 255)
                       0))
           OLDTOS)
          [COND
             (PUSHP                                          (* Save old top of stack)

                    (SETQ OLDTOS (\GETBASEPTR (STACKADDBASE SP)
                                        0]
          (UNINTERRUPTABLY
              [while
 (GREATERP (add
 SP (IMINUS WORDSPERCELL))
                            DESIREDSP) bind
 (PVAR0BASE ← (STACKADDBASE (fetch
 (FX FIRSTPVAR)
                                                                          of
 CALLER)))
                 when
 (fetch
 BINDMARKP of
 (STACKADDBASE SP))
                 do
                                          (* Unbind stuff. Bind mark says how 

                                                             many pvars were bound, and gives the 

                                                             offset of the last of them)

                    (LET [(LASTPVAR (fetch
 BINDLASTPVAR of
 (STACKADDBASE SP]
                         (to
 (fetch
 BINDNVALUES of
 (STACKADDBASE SP))
                            do
 (\PUTBASE PVAR0BASE LASTPVAR 65535)
                               (SETQ LASTPVAR (IDIFFERENCE LASTPVAR WORDSPERCELL]
              (replace
 (FX NEXTBLOCK) of
 CALLER with
 (add
 DESIREDSP WORDSPERCELL))
              (\MAKEFREEBLOCK
 DESIREDSP (IDIFFERENCE NEXT DESIREDSP))
              (COND
                 ((NOT PUSHP)                                (* Keep return value from being pushed)

                  (replace
 (FX NOPUSH) of
 CALLER with
 T)))   (* Now explicitly slow return to 

                                                             caller, since we have violated the 

                                                             fast return assumptions by blowing 

                                                             away stack between here and there)

              (\SLOWRETURN
)
              OLDTOS)])
)



(* ; "parsing stack for gc")


(DEFINEQ

(\GCSCANSTACK

  [LAMBDA NIL
                                                (* bvm: "11-Jun-84 13:02")

                                                             (* scan stack space calling SCANREF on 

                                                             all pointers)

    (PROG ((SCANPTR (fetch
 StackBase of
 \InterfacePage))
           (EASP (fetch
 EndOfStack of
 \InterfacePage))
           SCANBASE Q)
      LP  (SELECTC (fetch
 (STK FLAGS) of
 SCANPTR)
              (\STK.FX                                       (* frame extension)

                       [PROG (NTEND NEXT)
                             (CHECK (fetch
 (FX CHECKED) of
 SCANPTR))
                             (\STKREF (fetch
 (FX FNHEADER) of
 SCANPTR))
                             [SETQ SCANBASE (ADDSTACKBASE (SETQ Q (fetch
 (FX FIRSTPVAR) of
 SCANPTR]
                             (FRPTQ (fetch
 (FX FNHEADER NLOCALS) of
 SCANPTR)
                                    [COND
                                       ((fetch
 (PVARSLOT BOUND) of
 SCANBASE)
                                        (\STKREF (fetch
 (STACKCELL VALIDPOINTER) of
 SCANBASE]
                                    (SETQ SCANBASE (\ADDBASE SCANBASE WORDSPERCELL)))
                             (SETQ NEXT (SETQ Q (fetch
 (FX NEXTBLOCK) of
 SCANPTR)))
                             [COND
                                ((fetch
 (FX VALIDNAMETABLE) of
 SCANPTR)
                                                             (* Frame has separate nametable.)

                                 (COND
                                    ((EQ (fetch
 (FX NAMETABHI) of
 SCANPTR)
                                         \STACKHI)           (* Nametable is on stack.

                                                             Need to refcnt its framename and skip 

                                                             that section of the stack, since it 

                                                             does not contain pointers)

                                     (CHECK (ILEQ (fetch
 (FX NAMETABLO) of
 SCANPTR)
                                                  Q))
                                     (\STKREF (fetch
 (FNHEADER FRAMENAME) of
 (fetch
 (FX NAMETABLE#)
                                                                                of
 SCANPTR)))
                                     (SETQ Q (fetch
 (FX NAMETABLO) of
 SCANPTR))
                                     (SETQ NTEND (IPLUS Q (fetch
 (FNHEADER OVERHEADWORDS)
                                                             of
 T)
                                                        (UNFOLD (fetch
 (FNHEADER NTSIZE)
                                                                   of
 (ADDSTACKBASE Q))
                                                               2)))
                                                             (* Need to skip the region from Q to 

                                                             NTEND)

                                     )
                                    (T                       (* Nametable elsewhere, just reference 

                                                             it)

                                       (\STKREF (fetch
 (FX NAMETABLE) of
 SCANPTR]
                             (SETQ SCANPTR (fetch
 (FX FIRSTTEMP) of
 SCANPTR))
                         SCANTEMPS
                             (SETQ SCANBASE (ADDSTACKBASE SCANPTR))
                             (while
 (ILESSP SCANPTR Q) do
 [COND
                                                             ((fetch
 (STACKCELL VALIDPOINTERP)
                                                                 of
 SCANBASE)
                                                              (\STKREF (fetch
 (STACKCELL VALIDPOINTER
                                                                                     ) of
 SCANBASE]
                                                          (add
 SCANPTR WORDSPERCELL)
                                                          (SETQ SCANBASE (\ADDBASE SCANBASE 
                                                                                WORDSPERCELL)))
                             (COND
                                (NTEND                       (* Skip over NT, scan after it)

                                       (SETQ SCANPTR NTEND)
                                       (SETQ Q NEXT)
                                       (SETQ NTEND)
                                       (GO SCANTEMPS])
              (\STK.GUARD (AND (EQ SCANPTR EASP)
                               (RETURN))
                          (add
 SCANPTR (fetch
 (FSB SIZE) of
 SCANPTR)))
              (\STK.FSB 
          
          (* to merge free blocks (SETQ Q (IPLUS SCANPTR

          (fetch (FSB SIZE) of SCANPTR))) (CHECK (NEQ SCANPTR Q))

          (while (type? FSB Q) do (add (fetch (FSB SIZE) of SCANPTR)

          (SETQ NV (fetch (FSB SIZE) of Q))) (add Q NV))

          (SETQ SCANPTR Q))


                        (add
 SCANPTR (fetch
 (FSB SIZE) of
 SCANPTR)))
              (PROG ((ORIG SCANPTR))                         (* must be a basic frame)

                    (SETQ SCANBASE (ADDSTACKBASE SCANPTR))
                    (until
 (type?
 BF SCANPTR) do
 (CHECK (EQ (fetch
 (STK FLAGS) of
 SCANPTR)
                                                            \STK.NOTFLAG))
                                                 (\STKREF (fetch
 (STACKCELL VALIDPOINTER)
                                                             of
 SCANBASE))
                                                 (add
 SCANPTR WORDSPERCELL)
                                                 (SETQ SCANBASE (\ADDBASE SCANBASE WORDSPERCELL)))
                    [CHECK (COND
                              ((fetch
 (BF RESIDUAL) of
 SCANPTR)
                               (EQ SCANPTR ORIG))
                              (T (AND (fetch
 (BF CHECKED) of
 SCANPTR)
                                      (EQ ORIG (fetch
 (BF IVAR) of
 SCANPTR]
                    (add
 SCANPTR WORDSPERCELL)))
          (GO LP])
)



(* ; "setting up stack from scratch")


(DEFINEQ

(CLEARSTK

  [LAMBDA (FLG)
                                              (* bvm: " 5-Feb-85 16:29")

    (PROG (LST)
          [\MAPMDS \STACKP
                 (FUNCTION (LAMBDA (PAGE)
                             (PROG ((I 0)
                                    (PTR (create
 POINTER
                                                PAGE# ← PAGE))
                                    FX)
                               LPE [COND
                                      ((AND (EQ (fetch
 (STACKP STACKP0) of
 PTR)
                                                \STACKHI)
                                            (NEQ (SETQ FX (fetch
 (STACKP EDFXP) of
 PTR))
                                                 0))
                                       (SELECTQ FLG
                                           (NIL [COND
                                                   (NIL      (* Disallow this, we can't have this 

                                                             global smashing in the process world)

                                                        (UNINTERRUPTABLY
                                                            (PROGN (replace
 (STACKP EDFXP)
                                                                      of
 PTR with
 0)
                                                                   (\DECUSECOUNT
 FX)))])
                                           (**CLEAR**        (* Called by HARDRESET)

                                                      (replace
 (STACKP EDFXP) of
 PTR with
 0))
                                           (push
 LST PTR]
                                   (COND
                                      ((NEQ (SETQ I (IPLUS I WORDSPERCELL))
                                            \MDSIncrement)
                                       (SETQ PTR (\ADDBASE PTR WORDSPERCELL))
                                       (GO LPE]
          (RETURN LST])

(HARDRESET

  [LAMBDA NIL
                                                (* bvm: "12-JAN-82 12:06")

                                                             (* this is what Raid's ↑D does)

    (\CONTEXTSWITCH \ResetFXP])

(RELSTK

  [LAMBDA (POS)
                                              (* lmm "27-JUL-81 09:42")

    [AND (STACKP POS)
         (PROG ((FX (fetch
 EDFXP of
 POS)))
               (COND
                  ((NEQ FX 0)
                   (UNINTERRUPTABLY
                       (\DECUSECOUNT
 FX)
                       (replace
 EDFXP of
 POS with
 0))]
    POS])

(RELSTKP

  [LAMBDA (X)
                                                (* bvm: " 5-Feb-85 15:41")

    (AND (STACKP X)
         (EQ (fetch
 EDFXP of
 X)
             0])
)
(DEFINEQ

(SETUPSTACK

  [LAMBDA (INITFLG)
                                          (* lmm "22-JUN-83 15:08")

                                                             (* INITFLG is on if coming from 

                                                             MAKEINIT. Kludge because fn 

                                                             definitions are not available during 

                                                             MAKEINIT)

    (CREATEPAGES \STACKSPACE (IQUOTIENT \InitStackSize WordsPerPage)
           NIL T)                                            (* create initial stack pages)

    (\SETUPGUARDBLOCK
 0 WORDSPERCELL)                        (* start stack with mini-guard block)

    (replace
 (IFPAGE CurrentFXP) of
 \InterfacePage with
 (\SETUPSTACK1
 WORDSPERCELL 0 0
                                                               (IDIFFERENCE \StackAreaSize 2)
                                                               0 RESETPC RESETPTR NIL INITFLG))
    (replace
 (IFPAGE ResetFXP) of
 \InterfacePage with
 0)
    (replace
 (IFPAGE FAULTFXP) of
 \InterfacePage with
 0)
    (replace
 (IFPAGE SubovFXP) of
 \InterfacePage with
 0)
    (replace
 (IFPAGE KbdFXP) of
 \InterfacePage with
 0)
    (\SETUPGUARDBLOCK
 (IDIFFERENCE \StackAreaSize 2)
           2)
    (replace
 (IFPAGE StackBase) of
 \InterfacePage with
 (\SETUPGUARDBLOCK
 \StackAreaSize
                                                              (IDIFFERENCE (IDIFFERENCE 
                                                                                  \InitStackSize 
                                                                                  \StackAreaSize)
                                                                     2)))
    (replace
 (IFPAGE EndOfStack) of
 \InterfacePage with
 (\SETUPGUARDBLOCK
 (IDIFFERENCE \InitStackSize 
                                                                                 2)
                                                               2])

(\SETUPSTACK1

  [LAMBDA (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH)

                                                             (* lmm " 5-Feb-86 14:47")

    (COND
       ([OR INITFLG (IGREATERP (IDIFFERENCE STKEND STKP)
                           (IPLUS (PROG1 (fetch
 (FNHEADER STKMIN) of
 DEFPTR)
                                                             (* Space needed to call this fn)

                                         )
                                  (PROG1 WORDSPERQUAD        (* Extra slop)
]
                                                             (* Don't build a frame if there isn't 

                                                             space!)

        (PROG ((SP STKP))
              (if
 ARGSLENGTH
                  then
 (SETQ ARGSLENGTH (MIN ARGSLENGTH NARGS))
                       (\BLT (ADDSTACKBASE SP)
                             ARGS
                             (UNFOLD ARGSLENGTH WORDSPERCELL))
                       (add
 SP (TIMES ARGSLENGTH WORDSPERCELL))
                       (SETQ ARGS))
              (FRPTQ NARGS (PUTBASEPTR \STACKSPACE SP (AND ARGS (pop
 ARGS)))
                                                             (* store args)

                     (add
 SP WORDSPERCELL))
              (AND (PROG1 (COND
                             ((ODDP SP WORDSPERQUAD)
                              (PUTBASEPTR \STACKSPACE SP NIL)(* Clear out the padding word)

                              (add
 SP WORDSPERCELL)
                              T))
                          (replace
 (STK FLAGWORD) of
 SP with
 \STK.BF.WORD))
                   (replace
 (BF PADDING) of
 SP with
 1))
              (replace
 (BF IVAR) of
 SP with
 STKP)
              (SETQ STKP (IPLUS SP WORDSPERCELL))
              (replace
 (FX FLAGS) of
 STKP with
 \STK.FX)
              (replace
 (FX NOPUSH) of
 STKP with
 T)
              (replace
 (FX INCALL) of
 STKP with
 NIL)
              (replace
 (FX FAST) of
 STKP with
 NIL)
              (replace
 (FX VALIDNAMETABLE) of
 STKP with
 NIL)
              (replace
 (FX USECNT) of
 STKP with
 0)
              (replace
 (FX #BLINK) of
 STKP with
 SP)
              (replace
 (FX #ALINK) of
 STKP with
 (IPLUS ALINK \#ALINK.OFFSET 1))
              (replace
 (FX #CLINK) of
 STKP with
 (IPLUS CLINK \#ALINK.OFFSET))
              (replace
 (FX FNHEADER) of
 STKP with
 DEFPTR)
              (replace
 (FX PC) of
 STKP with
 PC)
              (SETQ SP (fetch
 (FX FIRSTPVAR) of
 STKP))
              [COND
                 ((NOT INITFLG)                              (* function definitions not available 

                                                             during MAKEINIT)

                  (RPTQ (UNFOLD (ADD1 (fetch
 (FNHEADER PV) of
 DEFPTR))
                               CELLSPERQUAD)
                        (PROGN                               (* Fill in Pvar region with "unbound")

                               (\PUTBASE \STACKSPACE SP 65535)
                               (add
 SP 2]
              (replace
 (FX NEXTBLOCK) of
 STKP with
 (add
 SP (fetch
 (FX PADDING) of
 STKP)))
                                                             (* Need extra junk quad after the

                                                             (null) pvar region)

              (\MAKEFREEBLOCK
 SP (IDIFFERENCE STKEND SP))
              (RETURN STKP])

(\MAKEFRAME

  [LAMBDA (FN ST END ALINK CLINK ARGS ARGLOCN)
               (* lmm " 5-Feb-86 14:44")

    (CHECK (fetch
 (LITATOM CCODEP) of
 FN))
    (PROG ((DEF (fetch
 (LITATOM DEFPOINTER) of
 FN)))
          (RETURN (\SETUPSTACK1
 ST ALINK CLINK END (COND
                                                      ((fetch
 (FNHEADER LSTARP) of
 DEF)
                                                       0)
                                                      (T (fetch
 (FNHEADER NA) of
 DEF)))
                         (fetch
 (FNHEADER STARTPC) of
 DEF)
                         DEF ARGS NIL ARGLOCN])

(\RESETSTACK

  [LAMBDA NIL
                                                (* lmm "23-MAY-81 05:30")

    (PROG NIL
      LP  (\RESETSTACK0
)
          (\CONTEXTSWITCH \ResetFXP)
          (GO LP])

(\RESETSTACK0

  [LAMBDA NIL
                                                (* bvm: "14-MAR-83 22:11")

    (PROG ((BASE \StackAreaSize))
          (replace
 (IFPAGE FAULTFXP) of
 \InterfacePage with
 (\MAKEFRAME
 (FUNCTION \FAULTHANDLER)
                                                                   BASE
                                                                   (SETQ BASE (IPLUS BASE 
                                                                                     \StackAreaSize))
                                                                   0 0))
          (replace
 (IFPAGE HardReturnFXP) of
 \InterfacePage with
 (\MAKEFRAME
 (FUNCTION \DOHARDRETURN)
                                                                        BASE
                                                                        (SETQ BASE (IPLUS BASE 
                                                                                       \StackAreaSize
                                                                                          ))
                                                                        0 0))
          (replace
 (IFPAGE TELERAIDFXP) of
 \InterfacePage
             with
 (\MAKEFRAME
 (COND
                                 ((fetch
 (LITATOM CCODEP) of
 (FUNCTION \DOTELERAID))
                                  (FUNCTION \DOTELERAID))
                                 (T (FUNCTION \DUMMYTELERAID)))
                         BASE
                         (SETQ BASE (IPLUS BASE \StackAreaSize))
                         0 0))                               (* NOTE: Anything below the key 

                                                             handler is considered super 

                                                             uninterruptable)

          (replace
 (IFPAGE KbdFXP) of
 \InterfacePage with
 (\MAKEFRAME
 (COND
                                                                         ((fetch
 (LITATOM CCODEP)
                                                                             of
 (QUOTE \KEYHANDLER))
                                                                          (FUNCTION \KEYHANDLER))
                                                                         (T (QUOTE \DUMMYKEYHANDLER))
                                                                         )
                                                                 (SETQ \KBDSTACKBASE BASE)
                                                                 (SETQ BASE (IPLUS BASE 
                                                                                   \StackAreaSize))
                                                                 0 0))
          (replace
 (IFPAGE GCFXP) of
 \InterfacePage with
 (\MAKEFRAME
 (FUNCTION \DOGC)
                                                                BASE
                                                                (SETQ BASE (IPLUS BASE \StackAreaSize
                                                                                  ))
                                                                0 0))
          (replace
 (IFPAGE SubovFXP) of
 \InterfacePage with
 (\MAKEFRAME
 (FUNCTION \DOSTACKOVERFLOW)
                                                                   BASE
                                                                   (SETQ BASE (IPLUS BASE 
                                                                                     \StackAreaSize))
                                                                   0 0))
          (replace
 (IFPAGE MiscFXP) of
 \InterfacePage with
 (\MAKEFRAME
 (FUNCTION \DOMISCAPPLY)
                                                                  (SETQ \MISCSTACKBASE BASE)
                                                                  (SETQ BASE (IPLUS BASE 
                                                                                    \StackAreaSize))
                                                                  0 0))
          (replace
 (IFPAGE StackBase) of
 \InterfacePage with
 BASE)
                                                             (* tell BCPL not to mess with previous 

                                                             stack areas)

          (replace
 (IFPAGE ResetFXP) of
 \InterfacePage
             with
 (\MAKEFRAME
 (FUNCTION \CODEFORTFRAME)
                         BASE
                         (PROGN [COND
                                   ((IGREATERP (SETQ BASE (fetch
 (IFPAGE EndOfStack) of
 
                                                                                       \InterfacePage
                                                                 ))
                                           \InitStackSize)   (* Trim stack back, unlocking pages.

                                                             This way you don't permanently lock 

                                                             entire stack segment if you get a 

                                                             stack overflow)

                                    [\UNLOCKPAGES (ADDSTACKBASE \InitStackSize)
                                           (ADD1 (IDIFFERENCE (FOLDLO BASE WORDSPERPAGE)
                                                        (FOLDLO \InitStackSize WORDSPERPAGE]
                                    (replace
 (IFPAGE EndOfStack) of
 \InterfacePage
                                       with
 (SETQ BASE (IDIFFERENCE \InitStackSize 2]
                                BASE)
                         0 0))
          (\SETUPGUARDBLOCK
 BASE 2])

(\SETUPGUARDBLOCK

  [LAMBDA (STKP LEN)
                                         (* lmm "27-JUL-81 09:34")

    (replace
 (FSB FLAGWORD) of
 STKP with
 \STK.GUARD.WORD)
    (replace
 (FSB SIZE) of
 STKP with
 LEN)
    STKP])

(\MAKEFREEBLOCK

  [LAMBDA (STK SIZE)
                                         (* lmm "27-JUL-81 09:33")

    (PROGN                                                   (* must be careful here, because stack 

                                                             is inconsistent in this region)

           (replace
 (FSB SIZE) of
 STK with
 SIZE)
           (replace
 (FSB FLAGWORD) of
 STK with
 \STK.FSB.WORD])

(\REPEATEDLYEVALQT

  [LAMBDA NIL
                                                (* lmm "10-JUN-81 16:41")

    (PROG ((\INTERRUPTABLE T))
      LP  (\RESETSYSTEMSTATE)
          (EVALQT)
          (GO LP])

(\DUMMYKEYHANDLER

  [LAMBDA NIL
                                                (* lmm " 4-APR-82 21:47")

                                                             (* installed instead of KEYHANDLER by 

                                                             RESETSTACK when KEYHANDLER is not 

                                                             CCODEP, e.g. inside MICROTEST where 

                                                             LLKEY is not loaded)

    (PROG NIL                                                (* FOR PRE-WIND VERSION ACTUALLY.

                                                             INCLUDED SO THAT MICROTEST CAN RUN 

                                                             WITHOUT KBD HANDLER)

      LP  (\CONTEXTAPPLY
 \KbdFXP (FUNCTION \CAUSEINTERRUPT)
                 \KbdFXP)
          (\CONTEXTSWITCH \KbdFXP)
          (GO LP])

(\DUMMYTELERAID

  [LAMBDA NIL
                                                (* bvm: "14-MAR-83 22:09")

    (PROG NIL
      LP  (\CONTEXTSWITCH \TeleRaidFXP)
          (GO LP])

(\CAUSEINTERRUPT

  [LAMBDA (CNTXT FN)
                                         (* bvm: " 6-APR-83 15:40")

          
          (* Builds a frame for FN (default is \INTERRUPTFRAME) on top of the fx in the 

          CNTXT slot of interface page, returning T on success)


    (PROG ((FRAME (\GETBASE \InterfacePage CNTXT))
           NXT)
          (COND
             ((ILESSP FRAME (fetch
 (IFPAGE StackBase) of
 \InterfacePage))
          
          (* I can't actually test \INTERRUPTABLE, because that might fault! I assume 

          that any context that lives lower than the keyboard handler is uninterruptable.

          This is mainly so I don't build an \INTERRUPTED frame on top of the fault 

          handler)

                                                             (* You might want to allow a RAID 

                                                             interrupt here, but that could be VERY 

                                                             dangerous if a fault is in progress, 

                                                             so best wait.)

              (RETURN)))
          (SETQ NXT (fetch
 (FX NEXTBLOCK) of
 FRAME))
          (CHECK (fetch
 (FX CHECKED) of
 FRAME)
                 (type?
 FSB NXT))
          (RETURN (COND
                     ((SETQ FRAME (\MAKEFRAME
 (OR FN (FUNCTION \INTERRUPTFRAME))
                                         NXT
                                         (IPLUS NXT (fetch
 (FSB SIZE) of
 NXT))
                                         FRAME FRAME))
                      (\PUTBASE \InterfacePage CNTXT FRAME)
                      T])

(\CONTEXTAPPLY

  [LAMBDA (CNTXT FN ARG)
                                     (* lmm "13-OCT-81 10:01")

    (PROG ((MYALINK (\MYALINK)))
          (\SMASHLINK
 NIL (GETBASE \InterfacePage CNTXT))
          (RETURN (PROG1 (SPREADAPPLY* FN ARG)
                         (\SMASHLINK
 NIL MYALINK])

(\INTERRUPTFRAME

  [LAMBDA NOBIND
                                             (* bvm: " 7-MAY-82 16:55")

    (COND
       (WINDFLG (\INTERRUPTED
))
       (T (INTERRUPTED])

(\INTERRUPTED

  [LAMBDA NIL
                                                (* lmm " 5-DEC-82 20:53")

    (COND
       (\INTERRUPTABLE (INTERRUPTED))
       (T (SETQ \PENDINGINTERRUPT T)                         (* Wrong, we weren't interruptable 

                                                             after all. Tell keyboard to try again 

                                                             later)

          ])

(\CODEFORTFRAME

  [LAMBDA NIL
                                                (* lmm "23-JUL-81 08:54")

    (\CALLME T)
    (CLEARSTK
 (QUOTE **CLEAR**))
    (INITIALEVALQT)
    (PROG NIL
      LP  (\REPEATEDLYEVALQT
)
          (GO LP])

(\DOMISCAPPLY

  [LAMBDA NIL
                                                (* bvm: "30-NOV-82 12:28")

    (\DOMISCAPPLY1
])

(\DOMISCAPPLY1

  [LAMBDA NIL
                                                (* bvm: "30-NOV-82 12:29")

          
          (* * Utility context to perform selected operations in a "safe" area of the 

          stack. Use \MISCAPPLY* macro to "call")

          
          (* * The compiler emits a BIND for the SPREADAPPLY* below, hence we cannot do 

          this at the root of the stack. Sigh)


    (PROG NIL
      LP  (replace
 (IFPAGE MISCSTACKRESULT) of
 \InterfacePage with
 (SPREADAPPLY* (fetch
 (IFPAGE
                                                                                         MISCSTACKFN)
                                                                                    of
 \InterfacePage
                                                                                        )
                                                                          (fetch
 (IFPAGE 
                                                                                        MISCSTACKARG1
                                                                                        )
                                                                             of
 \InterfacePage)
                                                                          (fetch
 (IFPAGE 
                                                                                        MISCSTACKARG2
                                                                                        )
                                                                             of
 \InterfacePage)))
          (\CONTEXTSWITCH \MiscFXP)
          (GO LP])
)



(* ; "Ufns for RETCALL")


(DEFINEQ

(\DORETCALL

  [LAMBDA (NARGS RETURNER)
                                   (* lmm " 5-Feb-86 15:58")

    (LET* [(RCFRAME (fetch
 (IFPAGE MiscFXP) of
 \InterfacePage))
           (RETURNER (fetch
 (FX CLINK)
                            RCFRAME))
           [FN (\VAG2 0 (LET ((PC (fetch
 (FX PC)
                                         RETURNER))
                              (FNHEADER (fetch
 (FX FNHEADER)
                                               RETURNER)))
                             (LOGOR (LSH (\GETBASEBYTE FNHEADER PC)
                                         8)
                                    (\GETBASEBYTE FNHEADER (ADD1 PC]
           (RETURNEE (fetch
 (FX CLINK)
                            RETURNER))
           (ARGLOC (DIFFERENCE (fetch
 (FX NEXTBLOCK)
                                      RETURNER)
                          (UNFOLD NARGS WORDSPERCELL]
          (CHECK (EQ (fetch
 (FX FNHEADER FRAMENAME) of
 RCFRAME)
                     (QUOTE \RETCALL))
                 (AND (LITATOM FN)
                      (CCODEP FN))
                 (fetch
 (FX CHECKED)
                        RCFRAME)
                 (fetch
 (FX CHECKED)
                        RETURNER)
                 (fetch
 (FX CHECKED)
                        RETURNEE))
          (\INCUSECOUNT
 RETURNEE)
          (\DECUSECOUNT
 RCFRAME)
          (replace
 (IFPAGE MiscFXP) of
 \InterfacePage
             with
 (LET ((START (\FREESTACKBLOCK
 1024 RETURNEE)))
                       (OR (\MAKEFRAME
 FN START (PLUS START (fetch
 (FSB SIZE)
                                                                   START))
                                  RETURNEE RETURNEE (ADDSTACKBASE ARGLOC)
                                  NARGS)
                           (RAID "couldn't make a frame"])

(\RETCALL

  [LAMBDA (NARGS)
                                            (* lmm " 5-Feb-86 15:05")

    (\MISCAPPLY* (QUOTE \DORETCALL)
           NARGS])
)

(RPAQ? STACKTESTING
 T)



(* ; "Stack overflow handler")


(DEFINEQ

(\DOSTACKFULLINTERRUPT

  [LAMBDA NIL
                                                (* bvm: " 4-Nov-85 17:34")

    (replace
 STACKOVERFLOW of
 \INTERRUPTSTATE with
 NIL)
    (RESETLST (RESETSAVE NIL (LIST (FUNCTION \CLEANUP.STACKFULL)))
           (STACK.FULL.WARNING
 T])

(STACK.FULL.WARNING

  [LAMBDA (FLG)
                                              (* bvm: " 4-Nov-85 18:11")

    (DECLARE
 (SPECVARS FLG))                                 (* Otherwise compiler optimizes this 

                                                             away)

    (COND
       (FLG                                                  (* True on call from 

                                                             \DOSTACKFULLINTERRUPT and NIL after we 

                                                             get into break. This way user can say 

                                                             OK to resume computation)

            (SETQ FLG NIL)
            (PROG ((HELPFLAG (QUOTE BREAK!)))
                  (LISPERROR "STACK OVERFLOW" NIL T])

(\CLEANUP.STACKFULL

  [LAMBDA NIL
                                                (* bvm: " 5-Nov-85 11:22")

          
          (* * On a RESETSAVE around the stack full break, so that ↑ or ↑D from the break 

          will do a HARDRESET)


    (COND
       ((SELECTQ AUTOHARDRESETFLG
            (NIL NIL)
            ((ERROR RESET) 
                 (EQ RESETSTATE AUTOHARDRESETFLG))
            (SELECTQ RESETSTATE
                ((ERROR RESET) 
                     T)
                NIL))
        (SETQ \STACKOVERFLOW)
        (HARDRESET
])
)

(RPAQ? \PENDINGINTERRUPT
 )

(RPAQ? \STACKOVERFLOW
 )

(RPAQ? AUTOHARDRESETFLG
 T)

(ADDTOVAR RESETFORMS
 (SETQ \STACKOVERFLOW))
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS AUTOHARDRESETFLG)
)
(DECLARE: DONTCOPY 

(ADDTOVAR INEWCOMS
 
          (FNS SETUPSTACK \SETUPSTACK1 \SETUPGUARDBLOCK \MAKEFREEBLOCK)
          (ALLOCAL (ADDVARS (LOCKEDFNS \RESETSTACK0 \MAKEFRAME \SETUPSTACK1 \MAKEFREEBLOCK 
                                   \FAULTHANDLER \KEYHANDLER \DUMMYKEYHANDLER \DOTELERAID 
                                   \DUMMYTELERAID \DOHARDRETURN \DOGC \CAUSEINTERRUPT \INTERRUPTFRAME 
                                   \CODEFORTFRAME \DOSTACKOVERFLOW \UNLOCKPAGES \DOMISCAPPLY)
                          (LOCKEDVARS \InterfacePage \DEFSPACE \STACKSPACE \KBDSTACKBASE 
                                 \MISCSTACKBASE))))

(ADDTOVAR EXPANDMACROFNS
 ADDSTACKBASE STACKADDBASE)
EVAL@COMPILE 

(ADDTOVAR DONTCOMPILEFNS
 SETUPSTACK)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 \INTERRUPTFRAME)
)
(PUTPROPS LLSTK COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (24951 28078 (\MYARGCOUNT 24961 . 25360) (\ARG0 25362 . 26685) (\SETARG0 26687 . 28076))
 (28162 54885 (\HARDRETURN 28172 . 28623) (\DOHARDRETURN 28625 . 28901) (\DOGC1 28903 . 29239) (\DOGC 
29241 . 29436) (\DOHARDRETURN1 29438 . 37525) (\DOSTACKOVERFLOW 37527 . 37930) (\MOVEFRAME 37932 . 
41623) (\INCUSECOUNT 41625 . 42872) (\DECUSECOUNT 42874 . 44962) (\MAKESTACKP 44964 . 45814) (
\SMASHLINK 45816 . 48577) (\FREESTACKBLOCK 48579 . 53444) (\EXTENDSTACK 53446 . 54883)) (54931 59094 (
\SLOWRETURN 54941 . 55210) (\COPY.N.UFN 55212 . 55474) (\POP.N.UFN 55476 . 56101) (\STORE.N.UFN 56103
 . 56383) (\UNWIND.UFN 56385 . 59092)) (59132 65546 (\GCSCANSTACK 59142 . 65544)) (65593 68409 (
CLEARSTK 65603 . 67589) (HARDRESET 67591 . 67830) (RELSTK 67832 . 68220) (RELSTKP 68222 . 68407)) (
68410 87629 (SETUPSTACK 68420 . 70543) (\SETUPSTACK1 70545 . 74173) (\MAKEFRAME 74175 . 74823) (
\RESETSTACK 74825 . 75035) (\RESETSTACK0 75037 . 80829) (\SETUPGUARDBLOCK 80831 . 81082) (
\MAKEFREEBLOCK 81084 . 81536) (\REPEATEDLYEVALQT 81538 . 81754) (\DUMMYKEYHANDLER 81756 . 82694) (
\DUMMYTELERAID 82696 . 82884) (\CAUSEINTERRUPT 82886 . 84597) (\CONTEXTAPPLY 84599 . 84909) (
\INTERRUPTFRAME 84911 . 85098) (\INTERRUPTED 85100 . 85550) (\CODEFORTFRAME 85552 . 85806) (
\DOMISCAPPLY 85808 . 85946) (\DOMISCAPPLY1 85948 . 87627)) (87663 89705 (\DORETCALL 87673 . 89538) (
\RETCALL 89540 . 89703)) (89773 91477 (\DOSTACKFULLINTERRUPT 89783 . 90079) (STACK.FULL.WARNING 90081
 . 90902) (\CLEANUP.STACKFULL 90904 . 91475)))))
STOP