(FILECREATED "28-Aug-86 12:34:47" {ERIS}<LISPCORE>SOURCES>LLINTERP.;35
 124462 

      changes to:  (FNS FUNCTION)
                   (VARS LLINTERPCOMS)

      previous date: "27-Aug-86 22:37:56" {ERIS}<LISPCORE>SOURCES>LLINTERP.;34)


(* Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved. The 
following program was created in 1981  but has not been published within the meaning of the copyright 
law, is furnished under license, and may not be used, copied and/or disclosed except in accordance 
with the terms of said license.)

(PRETTYCOMPRINT LLINTERPCOMS)

(RPAQQ LLINTERPCOMS
 
       ((E (* Don't fontify these common functions)
           (SETQ FNSLST
                 (LDIFFERENCE FNSLST
                        (QUOTE (EVALV PROG SET SETQ RETURN GO QUOTE AND OR PROGN COND PROG1 FUNCTION 
                                      EVAL APPLY)))))
        (COMS (* For calling interpreted functions)
              (FNS \INTERPRETER \INTERPRETER1 \SETUP-COMPILED-CLOSURE-CALL \STKNAME))
        (COMS (* recursive interpreter)
              (FNS EVAL \EVAL \EVALFORM \EVALFORMASLAMBDA \EVALOTHER APPLY APPLY* \CHECKAPPLY* 
                   \CKAPPLYARGS DEFEVAL)
              (DECLARE: DONTCOPY (MACROS .APPLY.))
              (VARS (\DEFEVALFNS NIL)
                    (\EVALHOOK))
              (SPECVARS *EVALHOOK*)
              (ADDVARS (LAMBDASPLST LAMBDA NLAMBDA CL:LAMBDA OPENLAMBDA))
              (GLOBALVARS \DEFEVALFNS \EVALHOOK LAMBDASPLST CLISPARRAY)
              (DECLARE: DONTEVAL@LOAD DOCOPY (VARS (CLISPARRAY)))
              (GLOBALVARS CLISPARRAY)
              (COMS (* Free variable manipulation)
                    (FNS EVALV \EVALV1 \EVALVAR BOUNDP SET \SETVAR SETQ SETN \STKSCAN \SETFVARSLOT))
              (COMS (* PROG and friends)
                    (FNS PROG \PROG0 \EVPROG1 RETURN GO EVALA \EVALA ERRORSET))
              (FNS QUOTE AND OR PROGN COND \EVPROGN PROG1)
              (COMS (* Evaluating in different stack environment)
                    (FNS ENVEVAL ENVAPPLY FUNCTION \FUNCT1 \MAKEFUNARGFRAME STKEVAL STKAPPLY RETEVAL 
                         RETAPPLY))
              (COMS (* Blip and other stack funniness)
                    (FNS BLIPVAL SETBLIPVAL BLIPSCAN)
                    (FNS DUMMYFRAMEP REALFRAMEP REALSTKNTH \REALFRAMEP)
                    (INITVARS (OPENFNS (QUOTE (APPLY* SETQ AND OR COND SELECTQ PROG PROGN PROG1 ARG 
                                                     SETARG ERSETQ NLSETQ RESETFORM RESETLST 
                                                     RESETVARS RPTQ SAVESETQ SETN UNDONLSETQ XNLSETQ)
                                              )))
                    (VARS \BLIPNAMES)
                    (GLOBALVARS BRKINFOLST)
                    (GLOBALVARS \BLIPNAMES OPENFNS)))
        (COMS (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA READVA 
                   READATOM READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY NOSUCHATOM)
              (FNS BACKTRACE \BACKTRACE \SCANFORNTENTRY \PRINTSTK \PRINTFRAME \PRINTBF)
              (DECLARE: EVAL@COMPILE DONTCOPY (COMS * RAIDCOMS)))
        (COMS (FNS CCODEP EXPRP SUBRP FNTYP ARGTYPE NARGS ARGLIST \CCODEARGLIST \CCODEIVARSCAN)
              (COMS (* Translation machinery for new LAMBDA words)
                    (PROP VARTYPE LAMBDATRANFNS)
                    (ALISTS (LAMBDATRANFNS)))
              (DECLARE: DONTCOPY (MACROS \CCODENARGS \CCODEFNTYP \CCODEARGTYPE)))
        (COMS (* proclaim and friends - needs to come first because DEFVARs put it out)
              (FUNCTIONS PROCLAIM)
              (* used by the codewalker, too)
              (* AND BY PACKAGE CODE (\, WHICH)
                 IS IN THE INIT (\, WHICH)
                 IS WHY THIS IS HERE RATHER THAN IN CMLEVEL.)
              (MACROS VARIABLE-GLOBALLY-SPECIAL-P VARIABLE-GLOBAL-P))
        (FUNCTIONS SPECIAL-FORM-P)
        (PROP FILETYPE LLINTERP)
        (DECLARE: EVAL@COMPILE DONTCOPY (ADDVARS (LAMS FAULTEVAL FAULTAPPLY)))
        (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA PROG1 COND PROGN OR AND QUOTE GO PROG SETN SETQ)
                      (NLAML FUNCTION RETURN)
                      (LAMA APPLY* \INTERPRETER)))
        (LOCALVARS . T)
        (SPECVARS *TAIL* *FN* *FORM* *ARGVAL* *ARGVAL1* *ARGVAL2*)))



(* For calling interpreted functions)


(DEFINEQ

(\INTERPRETER

  [LAMBDA N
                                                  (* bvm: " 7-Jul-86 17:28")

          
          (* the microcode calls this function instead if it is given an expr or an 

          undefined function to call -

          the name of the function/sexpression which is supposed to be called is given as 

          an extra argument)


    (PROG ((FN (ARG N N))
           (NACTUAL (SUB1 N))
           (NA 0)
           DEF ARGLIST NEXTRA NTSIZE TYPE NNILS ENV)
          (COND
             ((LITATOM FN)
              (CHECK (NOT (fetch
 (LITATOM CCODEP) of
 FN)))
              (SETQ DEF (fetch
 (LITATOM DEFPOINTER) of
 FN)))
             (T (SETQ DEF FN)))
          [COND
             ((TYPEP DEF (QUOTE COMPILED-CLOSURE))
              (RETURN (\MISCAPPLY* (FUNCTION \SETUP-COMPILED-CLOSURE-CALL)
                             DEF)))
             ((TYPEP DEF (QUOTE CLOSURE))
              (SETQ ENV (CLOSURE-ENVIRONMENT DEF))
              (SETQ DEF (CLOSURE-FUNCTION DEF]
          (COND
             ((NLISTP DEF)
              (GO ERR)))
          (RETURN (.CALLAFTERPUSHINGNILS.
                   (SELECTQ (CAR DEF)
                       (CL:LAMBDA (RETURN (\INTERPRETER-LAMBDA N DEF ENV FN)))
                       ([LAMBDA NLAMBDA OPENLAMBDA] 
                            [SETQ ARGLIST (CAR (OR (LISTP (CDR DEF))
                                                   (GO ERR]
                            (SETQ NNILS
                             (IPLUS (SETQ NEXTRA
                                     (COND
                                        ((LISTP ARGLIST)     (* spread function)

                                         (for
 X in
 ARGLIST
                                            do
 (COND
                                                  ((OR (NULL (\DTEST X (QUOTE LITATOM)))
                                                       (EQ X T))
                                                   (LISPERROR "ATTEMPT TO BIND NIL OR T" X))) 
                                                             (* Process one argument)

                                               (SETQ NA (ADD1 NA)))
                                         (COND
                                            ((IGREATERP NA NACTUAL)
                                             (IDIFFERENCE NA NACTUAL))
                                            (T 0)))
                                        ((NULL ARGLIST)      (* spread function)

                                         0)
                                        ((EQ ARGLIST T)
                                         (LISPERROR "ATTEMPT TO BIND NIL OR T" ARGLIST))
                                        (T 
          
          (* Nospread--needs to bind exactly one variable, the arg name.

          LAMBDA* also needs to set that arg to the number of actual args, but that can 

          be done by diddling the slot currently occupied by the fn name.

          Never any "extra" args to worry about)


                                           (\DTEST ARGLIST (QUOTE LITATOM))
                                           (SETQ NA 1)
                                           0)))
                                    (PROG1 (SETQ NTSIZE (CEIL (ADD1 NA)
                                                              WORDSPERQUAD))
          
          (* round number of nametable entries up to next quadword, leaving room for a 

          zero. add in overhead. NA is now in units of "cells" since there two words in a 

          cell.)


                                           )
                                    (FOLDHI (fetch
 (FNHEADER OVERHEADWORDS) of
 T)
                                           WORDSPERCELL)
                                    (SUB1 CELLSPERQUAD))))
                       (FUNARG (GO FUN))
                       (GO ERR))
                   (\INTERPRETER1
 ARGLIST NNILS NTSIZE NACTUAL NEXTRA FN DEF)))
      FUN [RETURN (PROGN (\SMASHLINK NIL (\STACKARGPTR (CADDR DEF)))
                         (SPREADAPPLY (CADR DEF)
                                (for
 I from
 1 to
 (SUB1 N) collect
 (ARG N I]
      ERR (RETURN (FAULTAPPLY FN (for
 I from
 1 to
 NACTUAL collect
 (ARG N I])

(\INTERPRETER1

  [LAMBDA (ARGLIST
 NNILS NTSIZE NACTUAL NPVARARGS FN DEF)
    (* lmm "18-Feb-86 01:31")

    (PROG ((*TAIL* (CDDR DEF))
           (INTERPFRAME (\MYALINK))
           HEADER NT NILSTART)
          (SETQ HEADER (fetch
 (FX FNHEADER) of
 INTERPFRAME)) (* The function header of code for 

                                                             \INTERPRETER)

          
          (* * Build a nametable for INTERPFRAME that identifies the vars in ARGLIST as 

          the NACTUAL IVAR's that were passed to it as arguments plus the NPVARARGS extra 

          NIL's that we implement as PVAR's. We build the nametable out of space that was 

          allocated on the stack by \INTERPRETER pushing many NIL's)


          (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch
 (FX NEXTBLOCK)
                                                                             of
 INTERPFRAME)
                                                                    (UNFOLD NNILS WORDSPERCELL)))
                                              (UNFOLD NPVARARGS WORDSPERCELL))
                                       WORDSPERQUAD)))
          
          (* Address of our synthesized nametable: NNILS cells back from the end of 

          INTERPFRAME, leaving space for additional "PVARs" we are using as extra NIL 

          args, rounded up to quadword)


          (UNINTERRUPTABLY
              [COND
                 ((NOT ARGLIST)                              (* No args, no nametable)

                  )
                 ((LISTP ARGLIST)
                  [for
 ARG in
 ARGLIST as
 ARG# from
 0 as
 NT1 from
 (fetch
 (FNHEADER OVERHEADWORDS)
                                                                    of
 T) as
 NT2
                     from
 (IPLUS (fetch
 (FNHEADER OVERHEADWORDS) of
 T)
                                 NTSIZE)
                     do
 (PUTBASE NT NT1 (\ATOMVALINDEX ARG))
                        (PUTBASE NT NT2 (COND
                                           ((ILESSP ARG# NACTUAL)
                                            (IPLUS IVARCODE ARG#))
                                           (T                (* Say it's the nth PVAR, where n is 

                                                             out of the range of the real PVARs)

                                              (IPLUS PVARCODE (FOLDLO (IDIFFERENCE
                                                                       NILSTART
                                                                       (fetch
 (FX FIRSTPVAR)
                                                                          of
 INTERPFRAME))
                                                                     WORDSPERCELL)
                                                     (IDIFFERENCE ARG# NACTUAL]
                                                             (* Note: area is initialize to NIL's

                                                             (zero)%, so end of nametable already 

                                                             has its zeroes)

                  )
                 (T                                          (* Nospread. Store lone arg in 

                                                             nametable)

                    (PUTBASE NT (fetch
 (FNHEADER OVERHEADWORDS) of
 T)
                           (\ATOMVALINDEX ARGLIST))
                    (PUTBASE NT (IPLUS (fetch
 (FNHEADER OVERHEADWORDS) of
 T)
                                       NTSIZE)
                           (IPLUS IVARCODE (COND
                                              ((EQ (CAR DEF)
                                                   (QUOTE NLAMBDA))
                                                             (* It's the first (and only) arg)

                                               0)
                                              (T             (* Use the n+1'st arg, which currently 

                                                             is our framename (FN))

                                                 (PUTBASEPTR \STACKSPACE
                                                        (IPLUS (fetch
 (BF IVAR)
                                                                  of
 (fetch
 (FX BLINK) of
 INTERPFRAME
                                                                            ))
                                                               (UNFOLD NACTUAL WORDSPERCELL))
                                                        NACTUAL)
                                                             (* set arg's value to be number of 

                                                             real args)

                                                 NACTUAL]
          
          (* * now fix up header of NT)


              (replace
 (FNHEADER #FRAMENAME) of
 NT with
 FN)  (* use #FRAMENAME to denote no 

                                                             reference counting)

              (replace
 (FNHEADER NTSIZE) of
 NT with
 NTSIZE)
              (replace
 (FNHEADER NLOCALS) of
 NT with
 (fetch
 (FNHEADER NLOCALS) of
 HEADER))
                                                             (* Probably doesn't matter, since 

                                                             there are no FVARS in that frame)

                                                             (* Do I need to worry about STK, NA, 

                                                             PV, START, ARGTYPE ? -

                                                             probably not)

              (replace
 (FX NAMETABLE) of
 INTERPFRAME with
 NT))
      EVLP
          (* * Now that we have "bound" the arguments, just evaluate the forms in the 

          LAMBDA/NLAMBDA as progn)

          (COND
             ((CDR *TAIL*)
              (\EVAL
 (CAR *TAIL*))
              (SETQ *TAIL* (CDR *TAIL*))
              (GO EVLP))
             (T (RETURN (\EVAL
 (CAR *TAIL*])

(\SETUP-COMPILED-CLOSURE-CALL

  [LAMBDA (CLOSURE)
                                          (* bvm: "21-Jul-86 11:12")

          
          (* * "Called in the misc context by \INTERPRETER when the function being called is a closure.  Replace the intepreter frame by the frame that would result if we had correctly called the closure in microcode.  This is a normal function call of the code body in the closure with the one additional wrinkle that the CLOSURE object is stored in PVAR1.")


    (LET ((INTERPFRAME (fetch
 (IFPAGE MiscFXP) of
 \InterfacePage))
          (CODE (fetch
 (COMPILED-CLOSURE FNHEADER) of
 CLOSURE))
          NA NACTUALS INTERPBF INTERPIVAR INTERPALINK INTERPCLINK SP NEWFX NPVARS STKEND SLOWP OLDBF 
          ENV)
         (SETQ OLDBF (SETQ INTERPBF (fetch
 (FX BLINK) of
 INTERPFRAME)))
         (SETQ INTERPIVAR (fetch
 (BF IVAR) of
 INTERPBF))
         (SETQ INTERPALINK (fetch
 (FX #ALINK) of
 INTERPFRAME))
                                                             (* Note that this is the "raw" ALINK 

                                                             -- we never look at it, just update it 

                                                             in new FX)

         [COND
            ((SETQ SLOWP (fetch
 (FX SLOWP) of
 INTERPFRAME))  (* Usually false, because \INTERPRETER 

                                                             hasn't had any reason to make itself 

                                                             slow. But it's not uninterruptable, so 

                                                             arbitrary things could happen to it)

             (SETQ INTERPCLINK (fetch
 (FX #CLINK) of
 INTERPFRAME]
         (SETQ STKEND (fetch
 (FX NEXTBLOCK) of
 INTERPFRAME))
         [COND
            ((fetch
 (BF PADDING) of
 INTERPBF)                (* Forget padding. I don't think 

                                                             anyone pads anymore, except maybe Lisp 

                                                             stack mungers)

             (SETQ INTERPBF (IDIFFERENCE INTERPBF WORDSPERCELL]
         (SETQ NACTUALS (FOLDLO (IDIFFERENCE INTERPBF INTERPIVAR)
                               WORDSPERCELL))
         (SETQ NA (fetch
 (FNHEADER NA) of
 CODE))
         [COND
            ((OR SLOWP (ILESSP (IDIFFERENCE STKEND INTERPBF)
                              (fetch
 (FNHEADER STKMIN) of
 CODE)))
                                                             (* No space for frame, or interpreter 

                                                             frame is slow, do slow case.

                                                             This computation is quite 

                                                             conservative, since we aren't counting 

                                                             the args)

             (LET ((NEWSTACK (\FREESTACKBLOCK (IPLUS (fetch
 (FNHEADER STKMIN) of
 CODE)
                                                     (UNFOLD NACTUALS WORDSPERCELL))
                                    INTERPFRAME)))
                  (SETQ STKEND (IPLUS NEWSTACK (fetch
 (FSB SIZE) of
 NEWSTACK)))
                  [while
 (type?
 FSB STKEND) do
 (SETQ STKEND (add
 STKEND (fetch
 (FSB SIZE)
                                                                           of
 STKEND]
                  (\BLT (ADDSTACKBASE NEWSTACK)
                        (ADDSTACKBASE INTERPIVAR)
                        (UNFOLD NACTUALS WORDSPERCELL))
                  (SETQ INTERPBF (IPLUS NEWSTACK (UNFOLD NACTUALS WORDSPERCELL)))
                  [COND
                     ((NEQ (fetch
 (FX USECNT) of
 INTERPFRAME)
                           0)
                      (add
 (fetch
 (FX USECNT) of
 INTERPFRAME)
                           -1))
                     (T [COND
                           ((NEQ (fetch
 (BF USECNT) of
 OLDBF)
                                 0)
                            (add
 (fetch
 (BF USECNT) of
 OLDBF)
                                 -1))
                           (T                                (* Normal slow case, can flush BF)

                              (\MAKEFREEBLOCK INTERPIVAR (IPLUS (IDIFFERENCE OLDBF INTERPIVAR)
                                                                WORDSPERCELL]
                                                             (* Finally, flush FX.

                                                             Has to be separate free block because 

                                                             FX and BF not necessarily contiguous)

                        (LET [(START (COND
                                        ((EQ OLDBF (fetch
 (FX DUMMYBF) of
 INTERPFRAME))
                                                             (* Normal contiguous case)

                                         INTERPFRAME)
                                        (T                   (* Have to blow away the dummy BF in 

                                                             front of the FX)

                                           (fetch
 (FX DUMMYBF) of
 INTERPFRAME]
                             (\MAKEFREEBLOCK START (IDIFFERENCE (fetch
 (FX NEXTBLOCK) of
 INTERPFRAME)
                                                          START]
                  (SETQ INTERPIVAR NEWSTACK)
                  (SETQ SLOWP T]
         [PROGN                                              (* Do argument adjustment.

                                                             In general we should pop excess args, 

                                                             but there's really no need for that)

                (COND
                   ((GREATERP NA NACTUALS)                   (* Push extra NILs for missing args)

                    (FRPTQ (DIFFERENCE NA NACTUALS)
                           (\PUTBASEPTR (STACKADDBASE INTERPBF)
                                  0 NIL)
                           (add
 INTERPBF WORDSPERCELL]
         (PROGN                                              (* Fix up BF trailer cell)

                (\PUTBASE \STACKSPACE INTERPBF 0)            (* Clear BF flags)

                (replace
 (BF IVAR) of
 INTERPBF with
 INTERPIVAR)
                (replace
 (BF FLAGS) of
 INTERPBF with
 \STK.BF)
                (CHECK (fetch
 (BF CHECKED) of
 INTERPBF)))
         (PROGN 
          
          (* Fix up FX header. Some of this work is redundant in the case where NEWFX is 

          the same as the old, but in general we did some arg adjusting or did the slow 

          case)


                (SETQ NEWFX (IPLUS INTERPBF WORDSPERCELL))
                (\PUTBASE \STACKSPACE NEWFX 0)               (* Clear FX flags)

                (replace
 (FX FLAGS) of
 NEWFX with
 \STK.FX)
                (replace
 (FX NOPUSH) of
 NEWFX with
 T)        (* When we return to the user context, 

                                                             don't want any value to appear on 

                                                             stack)

                (COND
                   (SLOWP (replace
 (FX #BLINK) of
 NEWFX with
 INTERPBF)
                          (replace
 (FX #CLINK) of
 NEWFX with
 (OR INTERPCLINK INTERPALINK))
                                                             (* If INTERPCLINK is NIL, the original 

                                                             frame was not SLOW, so ALINK = CLINK 

                                                             and INTERPALINK has its low bit off)

                          (replace
 (FX #ALINK) of
 NEWFX with
 (LOGOR INTERPALINK 1)))
                   (T (replace
 (FX #ALINK) of
 NEWFX with
 INTERPALINK)))
                (replace
 (FX FNHEADER) of
 NEWFX with
 CODE)
                (replace
 (FX PC) of
 NEWFX with
 (fetch
 (FNHEADER STARTPC) of
 CODE)))
         [PROGN                                              (* Initialize PVAR region)

                (SETQ SP (fetch
 (FX FIRSTPVAR) of
 NEWFX))
                (SETQ NPVARS (UNFOLD (ADD1 (fetch
 (FNHEADER PV) of
 CODE))
                                    CELLSPERQUAD))
                (COND
                   ((SETQ ENV (fetch
 (COMPILED-CLOSURE ENVIRONMENT) of
 CLOSURE))
                                                             (* Set first pvar to closure 

                                                             environment)

                    (\PUTBASEPTR \STACKSPACE SP ENV)
                    (add
 SP WORDSPERCELL)
                    (add
 NPVARS -1)))
                (RPTQ NPVARS (PROGN                          (* Fill in rest of Pvar region with 

                                                             "unbound")

                                    (\PUTBASE \STACKSPACE SP 65535)
                                    (add
 SP WORDSPERCELL]
         (PROGN                                              (* Make free block after this frame)

                (replace
 (FX NEXTBLOCK) of
 NEWFX with
 (add
 SP (fetch
 (FX PADDING) of
 NEWFX)))
                                                             (* Need extra junk quad after the pvar 

                                                             region)

                (\MAKEFREEBLOCK SP (IDIFFERENCE STKEND SP))
                (CHECK (fetch
 (FX CHECKED) of
 NEWFX)))
         (replace
 (IFPAGE MiscFXP) of
 \InterfacePage with
 NEWFX])

(\STKNAME

  [LAMBDA (POS)
                                              (* lmm " 2-Jul-86 12:37")

    (LET* ((NAME (fetch
 (FX FRAMENAME) of
 POS)))
          (COND
             [(EQ NAME (QUOTE \INTERPRETER))
              (\GETBASEPTR \STACKSPACE (LET ((BFLINK (fetch
 (FX BLINK) of
 POS)))
                                            (IPLUS (fetch
 (BF IVAR) of
 BFLINK)
                                                   (TIMES (SUB1 (fetch
 (BF NARGS) of
 BFLINK))
                                                          WORDSPERCELL]
             (T NAME])
)



(* recursive interpreter)


(DEFINEQ

(EVAL

  [LAMBDA (U \INTERNAL)
    (DECLARE
 (SPECVARS \INTERNAL))
                           (* lmm "19-AUG-81 23:04")

    (\EVAL
 U])

(\EVAL

  [LAMBDA (FORM)
                                             (* lmm " 3-NOV-81 15:42")

    (COND
       ((LISTP FORM)
        (\EVALFORM
 FORM))
       ((LITATOM FORM)
        (\EVALVAR
 FORM))
       ((NUMBERP FORM)
        FORM)
       (T (\EVALOTHER
 FORM])

(\EVALFORM

  [LAMBDA (*FORM* TEMP)
    (DECLARE
 (SPECVARS *FORM*)
           (ADDTOVAR LAMS FAULTEVAL))
                        (* lmm " 6-Jun-86 12:54")

                                                             (* eval of LISTP)

    (PROG NIL
      RETRY
          [COND
             ((LITATOM (SETQ TEMP (CAR *FORM*)))
              (COND
                 ((fetch
 (LITATOM CCODEP) of
 TEMP)
                  (SELECTQ (fetch
 (LITATOM ARGTYPE) of
 TEMP)
                      (1 (GO NLSPREAD))
                      (3 (GO NLNOSPREAD))
                      (GO EVLAM)))
                 (T                                          (* EXPR OR UDF)

                    (SETQ TEMP (fetch
 (LITATOM DEFPOINTER) of
 TEMP]
                                                             (* TEMP is now definition of EXPR)

          (TYPECASE TEMP (CLOSURE                            (* falls out)
)
                 (CONS (SELECTQ (CAR TEMP)
                           (NLAMBDA (COND
                                       ((OR (LISTP (SETQ TEMP (CADR TEMP)))
                                            (NULL TEMP))
                                        (GO NLSPREAD))
                                       (T (GO NLNOSPREAD))))
                           ((CL:LAMBDA LAMBDA OPENLAMBDA))
                           (GO FAULT)))
                 (T (GO FAULT)))
      EVLAM
                                                             (* THIS FUNCTION'S DEFINITION VERY 

                                                             DEPENDENT ON THE SPECIAL MACRO IN ALAP 

                                                             FOR COMPILING IT. -

                                                             SEE CEVALFORM)

          [RETURN (PROG ((*ARGVAL* 0)
                         (*TAIL* *FORM*)
                         (*FN* (CAR *FORM*)))
                        (DECLARE
 (SPECVARS *ARGVAL* *FN* *TAIL*))
                        (RETURN (.EVALFORM.]
      NLSPREAD
          (RETURN (SPREADAPPLY (CAR *FORM*)
                         (CDR *FORM*)))
      NLNOSPREAD
          (RETURN (SPREADAPPLY* (CAR *FORM*)
                         (CDR *FORM*)))
      FAULT
          (COND
             ([AND CLISPARRAY (LISTP (SETQ TEMP (GETHASH *FORM* CLISPARRAY]
              (SETQ *FORM* TEMP)
              (GO RETRY)))
          (RETURN (FAULTEVAL *FORM*])

(\EVALFORMASLAMBDA

  [LAMBDA (FAULTX)
                                           (* lmm "29-Apr-86 13:06")

    (PROG ((*ARGVAL* 0)
           (*TAIL* FAULTX)
           (*FN* (CAR FAULTX)))
          (DECLARE
 (SPECVARS *ARGVAL* *FN* *TAIL*))
          (RETURN (.EVALFORM.])

(\EVALOTHER

  [LAMBDA (X)
                                                (* lmm "10-MAY-80 17:03")

                                                             (* evaluate some other data type

                                                             (not atom or list))

    (PROG NIL
          (RETURN (SPREADAPPLY* (CDR (OR (FASSOC (TYPENAME X)
                                                \DEFEVALFNS)
                                         (RETURN X)))
                         X])

(APPLY

  [LAMBDA (U V \INTERNAL)
    (DECLARE
 (SPECVARS \INTERNAL))
                           (* lmm "15-Aug-84 17:53")

    (.APPLY. U V])

(APPLY*

  [LAMBDA U
                                                  (* lmm " 5-Jun-86 03:28")

    (PROG [(DEF (AND (IGREATERP U 0)
                     (ARG U 1]
      LP  (COND
             [(LITATOM DEF)
              (COND
                 [(fetch
 (LITATOM CCODEP) of
 DEF)
                  (COND
                     ((EQ (fetch
 (LITATOM ARGTYPE) of
 DEF)
                          3)
                      (GO NOSPR))
                     (T (GO SPR]
                 (T                                          (* EXPR)

                    (SETQ DEF (OR (LISTP (fetch
 (LITATOM DEFPOINTER) of
 DEF))
                                  (GO FAULT]
             ((CCODEP
 DEF)
              (GO SPR))
             ((NLISTP DEF)
              (GO FAULT)))
          (SELECTQ (CAR DEF)
              ([LAMBDA CL:LAMBDA] 
                   NIL)
              (FUNARG (SETQ DEF (CADR DEF))
                      (GO LP))
              (NLAMBDA (COND
                          ((AND (CAR (LISTP (CDR DEF)))
                                (NLISTP (CADR DEF)))
                           (GO NOSPR))))
              (OPENLAMBDA)
              (GO FAULT))
      SPR [RETURN (SELECTQ U
                      (1                                     (* no args)

                         (SPREADAPPLY* (ARG U 1)))
                      (2                                     (* 1 arg)

                         (SPREADAPPLY* (ARG U 1)
                                (ARG U 2)))
                      (3                                     (* 2 args)

                         (SPREADAPPLY* (ARG U 1)
                                (ARG U 2)
                                (ARG U 3)))
                      (4                                     (* 3 args)

                         (SPREADAPPLY* (ARG U 1)
                                (ARG U 2)
                                (ARG U 3)
                                (ARG U 4)))
                      (SPREADAPPLY (ARG U 1)
                             (for
 I from
 2 to
 U collect
 (ARG U I]
      FAULT
          [RETURN (FAULTAPPLY DEF (for
 I from
 2 to
 U collect
 (ARG U I]
      NOSPR
                                                             (* NLAMBDA*)

          (RETURN (SPREADAPPLY* (ARG U 1)
                         (for
 I from
 2 to
 U collect
 (ARG U I])

(\CHECKAPPLY*

  [LAMBDA (FN)
                                               (* bvm: " 7-Jul-86 17:13")

          
          (* * "APPLY* compiles open as: PUSH each arg, PUSH #args, PUSH FN, CHECKAPPLY*, APPLYFN 

CHECKAPPLY* should merely return FN in the case where FN is a LAMBDA or a NLAMBDA spread.  The only case it needs to handle special is NLAMBDA nospread.")


    (PROG ((DEF FN))
          [COND
             [(LITATOM DEF)
              (COND
                 ((NOT (fetch
 (LITATOM CCODEP) of
 DEF))      (* EXPR)

                  (SETQ DEF (fetch
 (LITATOM DEFPOINTER) of
 DEF)))
                 ((EQ (fetch
 (LITATOM ARGTYPE) of
 DEF)
                      3)
                  (GO NOSPR))
                 (T (RETURN FN]
             ((AND NIL (TYPEP DEF (QUOTE COMPILED-CLOSURE))) (* "Give a symbol this definition so APPLYFN can call it.  This is an utter kludge.  It can never work with preemptive scheduling, and even without it is vulnerable to an interrupt between CHECKAPPLY* and APPLYFN")

              (\PUTD (QUOTE *\CHECKAPPLY*\HACK)
                     DEF)
              (RETURN (QUOTE *\CHECKAPPLY*\HACK]
          (COND
             ((AND (LISTP DEF)
                   (EQ (CAR DEF)
                       (QUOTE NLAMBDA))
                   (LISTP (SETQ DEF (CDR DEF)))
                   (CAR DEF)
                   (NLISTP (CAR DEF)))
              (GO NOSPR))
             (T (RETURN FN)))
      NOSPR
          (RETURN (LIST (QUOTE LAMBDA)
                        NIL
                        (LIST (QUOTE QUOTE)
                              (SPREADAPPLY* FN (\CKAPPLYARGS
])

(\CKAPPLYARGS

  [LAMBDA NIL
                                                (* lmm "10-NOV-81 22:26")

    (PROG ((FRAME (fetch
 (FX ALINK) of
 (\MYALINK)))
           ACNT PTR VAL)
          [SETQ ACNT (STACKGETBASEPTR (SETQ PTR (IDIFFERENCE (fetch
 (FX NEXTBLOCK) of
 FRAME)
                                                       WORDSPERCELL]
          (CHECK (SMALLPOSP ACNT))
          [FRPTQ ACNT (push
 VAL (STACKGETBASEPTR (SETQ PTR (IDIFFERENCE PTR WORDSPERCELL]
          (RETURN VAL])

(DEFEVAL

  [LAMBDA (TYPE FN)
                                          (* edited: "13-DEC-78 23:18")

    (PROG ((F (FASSOC TYPE \DEFEVALFNS)))
          [COND
             (F (SETQ \DEFEVALFNS (DREMOVE F \DEFEVALFNS]
          [COND
             (FN (SETQ \DEFEVALFNS (CONS (CONS TYPE FN)
                                         \DEFEVALFNS]
          (RETURN (CDR F])
)
(DECLARE: DONTCOPY 
(DECLARE: EVAL@COMPILE 

(PUTPROPS .APPLY. MACRO ((U V)
                         (* body for APPLY, used by RETAPPLY too)
                         (PROG ((DEF U))
                               LP
                               (COND ((LITATOM DEF)
                                      (COND ((NOT (fetch (LITATOM CCODEP)
                                                         of DEF))
                                             (* EXPR)
                                             (SETQ DEF (fetch (LITATOM DEFPOINTER)
                                                              of DEF)))
                                            ((EQ (fetch (LITATOM ARGTYPE)
                                                        of DEF)
                                                 3)
                                             (GO NLSTAR))
                                            (T (GO NORMAL)))))
                               (COND ((LISTP DEF)
                                      (SELECTQ (CAR DEF)
                                             (NLAMBDA (AND (NLISTP (CADR DEF))
                                                           (CADR DEF)
                                                           (GO NLSTAR)))
                                             (FUNARG (SETQ DEF (CADR DEF))
                                                    (GO LP))
                                             NIL))
                                     ((NULL DEF)
                                      (RETURN (FAULTAPPLY U V))))
                               NORMAL
                               (RETURN (SPREADAPPLY U V))
                               NLSTAR
                               (* NLAMBDA*)
                               (RETURN (SPREADAPPLY* U V)))))
)
)

(RPAQQ \DEFEVALFNS
 NIL)

(RPAQQ \EVALHOOK
 NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(SPECVARS *EVALHOOK*)
)

(ADDTOVAR LAMBDASPLST
 LAMBDA NLAMBDA CL:LAMBDA OPENLAMBDA)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \DEFEVALFNS \EVALHOOK LAMBDASPLST CLISPARRAY)
)
(DECLARE: DONTEVAL@LOAD DOCOPY 

(RPAQQ CLISPARRAY
 NIL)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS CLISPARRAY)
)



(* Free variable manipulation)


(DEFINEQ

(EVALV

  [LAMBDA (VAR POS RELFLG)
                                   (* lmm " 6-Apr-84 16:37")

                                                             (* EVAL of a LITATOM without uba error)

    [COND
       (POS (\SMASHLINK NIL (\STACKARGPTR POS]
    (PROG1 (\EVALV1
 VAR)
           (COND
              (RELFLG (RELSTK POS])

(\EVALV1

  [LAMBDA (VAR)
                                              (* lmm "24-DEC-81 00:08")

    (COND
       ((OR (NULL (\DTEST VAR (QUOTE LITATOM)))
            (EQ VAR T))
        VAR)
       (T (\GETBASEPTR (\STKSCAN
 VAR)
                 0])

(\EVALVAR

  [LAMBDA (VAR)
                                              (* bvm: "18-Jan-85 14:21")

                                                             (* EVAL of a LITATOM)

    (COND
       ((OR (NULL VAR)
            (EQ VAR T))
        VAR)
       (T (PROG ((VP (\STKSCAN
 VAR))
                 VAL)
                (RETURN (COND
                           ((AND (EQ (SETQ VAL (\GETBASEPTR VP 0))
                                     (QUOTE NOBIND))
                                 (EQ (FLOOR (\HILOC VP)
                                            2)
                                     (\HILOC \VALSPACE)))    (* Value is NOBIND and it was found as 

                                                             the top-level value)

                            (FAULTEVAL VAR))
                           (T VAL])

(BOUNDP

  [LAMBDA (VAR)
                                              (* bvm: "18-Jan-85 14:12")

                                                             (* True if VAR is bound or has top 

                                                             level value)

    (AND (LITATOM VAR)
         (OR (NEQ (GETTOPVAL VAR)
                  (QUOTE NOBIND))
             (NEQ (PROGN 
          
          (* \VALSPACE is (potentially) two segments long, but continguous, so mask out 

          the low bit of the binding pointer segment.

          In the 32K litatom world this test would also succeed if the binding pointer 

          were in plist space, but that never happens)


                         (FLOOR (\HILOC (\STKSCAN
 VAR))
                                2))
                  (\HILOC \VALSPACE])

(SET

  [LAMBDA (VAR VALUE)
                                        (* lmm "24-FEB-82 16:11")

    (COND
       ((NULL VAR)
        (AND VALUE (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE)))
       (T (PROG [(VP (\STKSCAN
 (\DTEST VAR (QUOTE LITATOM]
                (COND
                   ((EQ (\HILOC VP)
                        \STACKHI)
                    (\PUTBASEPTR VP 0 VALUE))
                   ((EQ VAR T)
                    (OR (EQ VALUE T)
                        (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE)))
                   (T (\RPLPTR VP 0 VALUE)))
                (RETURN VALUE])

(\SETVAR

  [LAMBDA (VAR VALUE)
                                        (* lmm "24-FEB-82 16:11")

    (COND
       ((NULL VAR)
        (AND VALUE (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE)))
       (T (PROG [(VP (\STKSCAN
 (\DTEST VAR (QUOTE LITATOM]
                (COND
                   ((EQ (\HILOC VP)
                        \STACKHI)
                    (\PUTBASEPTR VP 0 VALUE))
                   ((EQ VAR T)
                    (OR (EQ VALUE T)
                        (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE)))
                   (T (\RPLPTR VP 0 VALUE)))
                (RETURN VALUE])

(SETQ

  [NLAMBDA U
                                                 (* lmm "24-DEC-81 00:19")

                                                             (* (SETQ X Y + 3) MUST TRY TO EVAL +)

    (\SETVAR
 (CAR U)
           (PROG ((*TAIL* (CDR U)))
                 (DECLARE
 (SPECVARS *TAIL*))
                 (RETURN (PROG1 (\EVAL
 (CAR *TAIL*))
                                (PROG NIL
                                  LP  (COND
                                         ((LISTP (SETQ *TAIL* (CDR *TAIL*)))
                                          (\EVAL
 (CAR *TAIL*))
                                          (GO LP])

(SETN

  [NLAMBDA U
                                                 (* lmm "24-DEC-81 00:19")

                                                             (* (SETN X Y + 3) MUST TRY TO EVAL +)

    (\SETVAR
 (CAR U)
           (PROG ((*TAIL* (CDR U)))
                 (DECLARE
 (SPECVARS *TAIL*))
                 (RETURN (PROG1 (\EVAL
 (CAR *TAIL*))
                                (PROG NIL
                                  LP  (COND
                                         ((LISTP (SETN
 *TAIL* (CDR *TAIL*)))
                                          (\EVAL
 (CAR *TAIL*))
                                          (GO LP])

(\STKSCAN

  [LAMBDA (VAR)
                                              (* bvm: "13-Feb-85 22:38")

                                                             (* RETURNS POINTER TO PLACE WHERE VAR 

                                                             IS BOUND)

    (PROG ((FX (fetch
 (FX ALINK) of
 (\MYALINK)))
           (ATOM# (\ATOMVALINDEX VAR))
           NTSIZE A VARINFO PVAROFFSET NT FVAR)
      FRAMELP
          [COND
             ((fetch
 (FX INVALIDP) of
 FX)                    (* Reached top of stack without 

                                                             finding a binding)

              (RETURN (fetch
 (VALINDEX VCELL) of
 ATOM#]
          (SETQ NT (fetch
 (FX NAMETABLE) of
 FX))
          (SETQ NTSIZE (fetch
 (FNHEADER NTSIZE) of
 NT))
          (SETQ NT (\ADDBASE NT (fetch
 (FNHEADER OVERHEADWORDS) of
 T)))
      TABLELP
          [COND
             ((EQ (SETQ A (\GETBASE NT 0))
                  0)                                         (* End of name table)

              (GO ENDTABLE))
             ((EQ A ATOM#)                                   (* Found ATOM#. See if it is really 

                                                             bound here)

              (SELECTC (fetch
 (NAMETABLESLOT VARTYPE) of
 (SETQ VARINFO (\ADDBASE NT NTSIZE)))
                  (\NT.IVAR                                  (* Is bound in BF)

                                                             (* IVAR)

                            [RETURN (STACKADDBASE (IPLUS (UNFOLD (fetch
 (NAMETABLESLOT VAROFFSET)
                                                                    of
 VARINFO)
                                                                WORDSPERCELL)
                                                         (fetch
 (BF IVAR) of
 (fetch
 (FX BLINK)
                                                                                of
 FX])
                  (\NT.PVAR                                  (* Local may or may not be bound yet)

                            (SETQ PVAROFFSET (IPLUS (UNFOLD (fetch
 (NAMETABLESLOT VAROFFSET)
                                                               of
 VARINFO)
                                                           WORDSPERCELL)
                                                    (fetch
 (FX FIRSTPVAR) of
 FX)))
                            [COND
                               ((fetch
 (PVARSLOT BOUND) of
 (STACKADDBASE PVAROFFSET))
                                                             (* PVAR)

                                (RETURN (STACKADDBASE PVAROFFSET])
                  (\NT.FVAR                                  (* If FVAR is looked up, we can use 

                                                             it.)

                            [SETQ FVAR (ADDSTACKBASE (IPLUS (UNFOLD (fetch
 (NAMETABLESLOT VAROFFSET)
                                                                       of
 VARINFO)
                                                                   WORDSPERCELL)
                                                            (fetch
 (FX FIRSTPVAR) of
 FX]
                            (COND
                               ((fetch
 (FVARSLOT LOOKEDUP) of
 FVAR)
                                (SETQ FVAR (fetch
 (FVARSLOT BINDINGPTR) of
 FVAR))
                                (RETURN FVAR))
                               (T (GO ENDTABLE))))
                  (SHOULDNT]
          (SETQ NT (\ADDBASE NT 1))
          (GO TABLELP)
      ENDTABLE
          (SETQ FX (fetch
 (FX ALINK) of
 FX))
          (GO FRAMELP])

(\SETFVARSLOT

  [LAMBDA (VAR NEWBINDING)
                                   (* bvm: "13-Feb-85 22:39")

                                                             (* Sets the freevar binding slot of 

                                                             VAR in caller's frame to point at 

                                                             NEWBINDING)

    (PROG ((FX (\MYALINK))
           (ATOM# (\ATOMVALINDEX VAR))
           NTSIZE A VARINFO NT)
          (SETQ NT (fetch
 (FX NAMETABLE) of
 FX))
          (SETQ NTSIZE (fetch
 (FNHEADER NTSIZE) of
 NT))
          (SETQ NT (\ADDBASE NT (fetch
 (FNHEADER OVERHEADWORDS) of
 T)))
      TABLELP
          (COND
             ((EQ (SETQ A (\GETBASE NT 0))
                  0)                                         (* End of name table)

              (ERROR "Binding slot not found in caller's frame" VAR))
             ((AND (EQ A ATOM#)
                   (EQ (fetch
 (NAMETABLESLOT VARTYPE) of
 (SETQ VARINFO (\ADDBASE NT NTSIZE)))
                       \NT.FVAR))
              (replace
 (FVARSLOT BINDINGPTR) of
 (ADDSTACKBASE (IPLUS (UNFOLD (fetch
 (NAMETABLESLOT
                                                                                     VAROFFSET)
                                                                                of
 VARINFO)
                                                                            WORDSPERCELL)
                                                                     (fetch
 (FX FIRSTPVAR)
                                                                        of
 FX))) with
 NEWBINDING)
              (RETURN NEWBINDING)))
          (SETQ NT (\ADDBASE NT 1))
          (GO TABLELP])
)



(* PROG and friends)


(DEFINEQ

(PROG

  [NLAMBDA U
                                                 (* bvm: "29-AUG-81 22:41")

                                                             (* PROG unpacks the argument list and 

                                                             changes any EVAL type forms by 

                                                             evaluating the form and then smashing 

                                                             the name and value)

          
          (* NOTE --- this mechanism might confuse DWIM someday because the arguments 

          inside the PROG are evaluated at a time when the PROG frame is in a very funny 

          state: the "values" are the variables, and the variables are NIL)


    (PROG ((NVARS 0)
           (VARLST (CAR U))
           NTSIZE NNILS)
          (for
 VAR in
 VARLST do
                              (* Count number of vars to bind, check 

                                                             validity)

                                (COND
                                   ((OR (NULL (\DTEST (COND
                                                         ((LISTP VAR)
                                                          (SETQ VAR (CAR VAR)))
                                                         (T VAR))
                                                     (QUOTE LITATOM)))
                                        (EQ VAR T))
                                    (LISPERROR "ATTEMPT TO BIND NIL OR T" VAR)))
                                (add
 NVARS 1))
          (RETURN (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE (CEIL (ADD1 NVARS)
                                                                                      WORDSPERQUAD))
                                                             (FOLDHI (fetch
 (FNHEADER OVERHEADWORDS)
                                                                        of
 T)
                                                                    WORDSPERCELL)
                                                             (SUB1 CELLSPERQUAD)))
                         (\PROG0
 U U NNILS NVARS NTSIZE VARLST])

(\PROG0

  [LAMBDA (*FIRSTTAIL* *TAIL* NNILS NVARS NTSIZE VARLST)
     (* lmm "13-FEB-83 13:52")

    (DECLARE
 (SPECVARS *TAIL* *FIRSTTAIL*))
    (PROG NIL
          [COND
             (VARLST 
          
          (* * Create a nametable inside progframe where PROG pushed all those nils)


                    (PROG ((PROGFRAME (\MYALINK))
                           HEADER NT NILSTART)
                          (SETQ HEADER (fetch
 (FX FNHEADER) of
 PROGFRAME))
                          (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART
                                                               (IDIFFERENCE (fetch
 (FX NEXTBLOCK)
                                                                               of
 PROGFRAME)
                                                                      (UNFOLD NNILS WORDSPERCELL)))
                                                              (UNFOLD NVARS WORDSPERCELL))
                                                       WORDSPERQUAD)))
                                                             (* NT is address of our synthesized 

                                                             nametable: beginning of NIL's, not 

                                                             counting additional PVARs we are about 

                                                             to bind, rounded up to quadword)

                          [for
 VAR in
 VARLST as
 VALUEOFF from
 NILSTART by
 WORDSPERCELL
                             do
                              (* evaluate initial values first)

                                (COND
                                   ((LISTP VAR)
                                    (PUTBASEPTR \STACKSPACE VALUEOFF (\EVPROG1
 (CDR VAR]
                                                             (* then build NT)

                          (UNINTERRUPTABLY
                              (for
 VAR in
 VARLST as
 VAR#
                                 from
 (FOLDLO (IDIFFERENCE NILSTART (fetch
 (FX FIRSTPVAR)
                                                                       of
 PROGFRAME))
                                             WORDSPERCELL) as
 NT1 from
 (fetch
 (FNHEADER OVERHEADWORDS
                                                                                     ) of
 T)
                                 as
 NT2 from
 (IPLUS (fetch
 (FNHEADER OVERHEADWORDS) of
 T)
                                                    NTSIZE)
                                 do
 [PUTBASE NT NT1 (\ATOMVALINDEX (COND
                                                                      ((LISTP VAR)
                                                                       (CAR VAR))
                                                                      (T VAR]
                                    (PUTBASE NT NT2 (IPLUS PVARCODE VAR#)))
                              (replace
 (FNHEADER #FRAMENAME) of
 NT with
 (QUOTE PROG))
                              (replace
 (FNHEADER NTSIZE) of
 NT with
 NTSIZE)
                                                             (* Do I need to worry about STK, NA, 

                                                             PV, START, ARGTYPE NLOCALS ? -

                                                             no)

                              (replace
 (FX NAMETABLE) of
 PROGFRAME with
 NT))]
      EVLP
          (COND
             ((NULL (SETQ *TAIL* (CDR *TAIL*)))
              (RETURN NIL))
             (T (\EVAL
 (OR (LISTP (CAR *TAIL*))
                           (GO EVLP)))
                (GO EVLP])

(\EVPROG1

  [LAMBDA (*TAIL*)
                                           (* lmm "14-MAY-80 13:00")

    (DECLARE
 (SPECVARS *TAIL*))
    (PROG1 (\EVAL
 (CAR *TAIL*))
           (PROG NIL
             LP  (COND
                    ((LISTP (SETQ *TAIL* (CDR *TAIL*)))
                     (\EVAL
 (CAR *TAIL*))
                     (GO LP])

(RETURN

  [NLAMBDA (FORM)
    (DECLARE
 (LOCALVARS . T))
                                (* lmm " 3-Mar-86 18:31")

    (LET [(MV (MULTIPLE-VALUE-LIST (\EVAL
 FORM]
         (PROG ((FRAME (\MYALINK)))
           LP  (COND
                  ((EQ (fetch
 (FNHEADER FRAMENAME) of
 (fetch
 (FX NAMETABLE) of
 FRAME))
                       (FUNCTION \PROG0))
                   (SETQ FRAME (fetch
 (FX CLINK) of
 FRAME))  (* Its caller, i.e. PROG)

                   (\SMASHLINK NIL FRAME FRAME)              (* Make us return to PROG with this 

                                                             value)

                   (RETURN (VALUES-LIST MV)))
                  ([NOT (fetch
 (FX INVALIDP) of
 (SETQ FRAME (fetch
 (FX CLINK) of
 FRAME]
                   (GO LP))
                  (T (LISPERROR "ILLEGAL RETURN"])

(GO

  [NLAMBDA U
                                                 (* lmm "23-DEC-81 11:28")

    (PROG ((FRAME (\MYALINK))
           (LABEL (CAR U))
           GOTAIL FIRSTARG)
      LP  [COND
             ((EQ (fetch
 (FNHEADER FRAMENAME) of
 (fetch
 (FX NAMETABLE) of
 FRAME))
                  (FUNCTION \PROG0))
              (COND
                 ([SETQ GOTAIL (FMEMB LABEL (CDR (STACKGETBASEPTR (SETQ FIRSTARG
                                                                   (fetch
 (BF IVAR)
                                                                      of
 (fetch
 (FX BLINK)
                                                                            of
 FRAME]
                                                             (* first argument of \PROG0 is the 

                                                             actual tail of the prog, which can 

                                                             contain the labels. Second argument is 

                                                             the "current" *TAIL*)

                  (STACKPUTBASEPTR (IPLUS FIRSTARG WORDSPERCELL)
                         GOTAIL)                             (* Reset *TAIL* in the \PROG0 frame)

                  (\SMASHLINK NIL FRAME FRAME)               (* Fix it so we return to \PROG0 to 

                                                             continue evaluating after label)

                  (RETURN NIL]
          (COND
             ([NOT (fetch
 (FX INVALIDP) of
 (SETQ FRAME (fetch
 (FX CLINK) of
 FRAME]
              (GO LP))
             (T (LISPERROR "UNDEFINED OR ILLEGAL GO" LABEL])

(EVALA

  [LAMBDA (X A)
                                              (* lmm " 4-SEP-81 10:57")

          
          (* * Evaluate X after spreading alist A on stack)


    (PROG ((NVARS 0)
           NTSIZE NNILS TMP)
          (for
 VAR in
 A do
                                   (* Count number of vars to bind, check 

                                                             validity)

                           (COND
                              ((OR [NULL (SETQ TMP (\DTEST (CAR (\DTEST VAR (QUOTE LISTP)))
                                                          (QUOTE LITATOM]
                                   (EQ TMP T))
                               (LISPERROR "ATTEMPT TO BIND NIL OR T" TMP)))
                           (add
 NVARS 1))
          (RETURN (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE (CEIL (ADD1 NVARS)
                                                                                      WORDSPERQUAD))
                                                             (FOLDHI (fetch
 (FNHEADER OVERHEADWORDS)
                                                                        of
 T)
                                                                    WORDSPERCELL)
                                                             (SUB1 CELLSPERQUAD)))
                         (\EVALA
 NNILS NVARS NTSIZE X A])

(\EVALA

  [LAMBDA (NNILS NVARS NTSIZE FORM ALIST)
                    (* lmm "13-FEB-83 13:52")

    (PROG ((CALLER (\MYALINK))
           NILSTART NT HEADER)
          
          (* * Create a nametable inside CALLER where EVALA pushed all those nils)


          (SETQ HEADER (fetch
 (FX FNHEADER) of
 CALLER))      (* The function header of code for 

                                                             EVALA)

          (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch
 (FX NEXTBLOCK)
                                                                             of
 CALLER)
                                                                    (UNFOLD NNILS WORDSPERCELL)))
                                              (UNFOLD NVARS WORDSPERCELL))
                                       WORDSPERQUAD)))       (* Address of our synthesized 

                                                             nametable: beginning of NIL's, not 

                                                             counting additional PVARs we are about 

                                                             to bind, rounded up to quadword)

          (UNINTERRUPTABLY
              (for
 PAIR in
 ALIST as
 VAR# from
 (FOLDLO (IDIFFERENCE NILSTART (fetch
 (FX FIRSTPVAR)
                                                                               of
 CALLER))
                                                     WORDSPERCELL) as
 NT1
                 from
 (fetch
 (FNHEADER OVERHEADWORDS) of
 T) as
 NT2
                 from
 (IPLUS (fetch
 (FNHEADER OVERHEADWORDS) of
 T)
                             NTSIZE) as
 VALUEOFF from
 NILSTART by
 WORDSPERCELL
                 do
 (PUTBASEPTR \STACKSPACE VALUEOFF (CDR PAIR))
                    (PUTBASE NT NT1 (\ATOMVALINDEX (CAR PAIR)))
                    (PUTBASE NT NT2 (IPLUS PVARCODE VAR#)))
          
          (* * now fix up header of NT)


              (replace
 (FNHEADER #FRAMENAME) of
 NT with
 (QUOTE EVALA))
              (replace
 (FNHEADER NTSIZE) of
 NT with
 NTSIZE)  (* Do I need to worry about STK, NA, 

                                                             PV, START, ARGTYPE ? -

                                                             probably not)

              (replace
 (FX NAMETABLE) of
 CALLER with
 NT))
          (RETURN (\EVAL
 FORM])

(ERRORSET

  [LAMBDA (U V W)
                                            (* lmm "18-APR-80 13:40")

    (LIST (\EVAL
 U])
)
(DEFINEQ

(QUOTE

  [NLAMBDA U
    (CAR U])

(AND

  [NLAMBDA U
    (DECLARE
 (SPECVARS *TAIL*))
    (OR (NLISTP U)
        (PROG ((*TAIL* U))
          LP  (RETURN (COND
                         ((NLISTP (CDR *TAIL*))
                          (\EVAL
 (CAR *TAIL*)))
                         ((\EVAL
 (CAR *TAIL*))
                          (SETQ *TAIL* (CDR *TAIL*))
                          (GO LP])

(OR

  [NLAMBDA U
    (DECLARE
 (SPECVARS *TAIL*))
                              (* lmm " 9-May-86 13:45")

    (AND (LISTP U)
         (PROG ((*TAIL* U))
           LP  (RETURN (COND
                          ((NLISTP (CDR *TAIL*))
                           (\EVAL
 (CAR *TAIL*)))
                          (T (OR (\EVAL
 (CAR *TAIL*))
                                 (PROGN (SETQ *TAIL* (CDR *TAIL*))
                                        (GO LP])

(PROGN

  [NLAMBDA U                                                 (* MUST be a NLAMBDA* with internal 

                                                             call to EVAL for dwimsake)

    (DECLARE
 (SPECVARS *TAIL*))
    (AND (LISTP U)
         (PROG ((*TAIL* U))
           LP  (COND
                  [(NLISTP (CDR *TAIL*))
                   (RETURN (\EVAL
 (CAR *TAIL*]
                  (T (\EVAL
 (CAR *TAIL*))
                     (SETQ *TAIL* (CDR *TAIL*))
                     (GO LP])

(COND

  [NLAMBDA U
    (DECLARE
 (SPECVARS *TAIL*))
                              (* lmm "25-APR-80 18:03")

    (PROG ((*TAIL* U)
           VAL)
      LP  (RETURN (COND
                     ((NLISTP *TAIL*)
                      (COND
                         (*TAIL* (LISPERROR "UNUSUAL CDR ARG LIST" *TAIL*))
                         (T NIL)))
                     ((SETQ VAL (\EVAL
 (CAAR *TAIL*)))
                      (COND
                         ((CDAR *TAIL*)
                          (\EVPROGN
 (CDAR *TAIL*)))
                         (T VAL)))
                     (T (SETQ *TAIL* (CDR *TAIL*))
                        (GO LP])

(\EVPROGN

  [LAMBDA (*TAIL*)
                                           (* lmm "18-Feb-86 01:44")

    (DECLARE
 (SPECVARS *TAIL*))
    (PROG NIL
      LP  (COND
             ((CDR *TAIL*)
              (\EVAL
 (CAR *TAIL*))
              (SETQ *TAIL* (CDR *TAIL*))
              (GO LP))
             (T (RETURN (\EVAL
 (CAR *TAIL*])

(PROG1

  [NLAMBDA U
    (DECLARE
 (SPECVARS *TAIL*))
                              (* lmm "14-MAY-80 12:59")

    (AND (LISTP U)
         (PROG ((*TAIL* U))
               (RETURN (PROG1 (\EVAL
 (CAR *TAIL*))
                              (PROG NIL
                                LP  (COND
                                       ((LISTP (SETQ *TAIL* (CDR *TAIL*)))
                                        (\EVAL
 (CAR *TAIL*))
                                        (GO LP])
)



(* Evaluating in different stack environment)


(DEFINEQ

(ENVEVAL

  [LAMBDA (FORM APOS CPOS AFLG CFLG)
                         (* bvm: "18-AUG-81 23:29")

    (\CALLME (QUOTE *ENV*))
    (\SMASHLINK NIL (AND APOS (\STACKARGPTR APOS))
           (AND CPOS (\STACKARGPTR CPOS)))
    (COND
       (AFLG (RELSTK APOS)))
    (COND
       (CFLG (RELSTK CPOS)))
    (\EVAL
 FORM])

(ENVAPPLY

  [LAMBDA (FN ARGS APOS CPOS AFLG CFLG)
                      (* lmm "15-Aug-84 17:53")

    (\CALLME (QUOTE *ENV*))
    (\SMASHLINK NIL (AND APOS (\STACKARGPTR APOS))
           (AND CPOS (\STACKARGPTR CPOS)))
    (COND
       (AFLG (RELSTK APOS)))
    (COND
       (CFLG (RELSTK CPOS)))
    (.APPLY. FN ARGS])

(FUNCTION

  (NLAMBDA (FN ENV)
                                          (* lmm "24-May-86 16:03")

                                                             (* wrong, but -- for now)

    (COND
       (ENV (LIST (QUOTE FUNARG)
                  FN
                  (STKNTH -1 (QUOTE FUNCTION))))
       (T FN))))

(\FUNCT1

  [LAMBDA (NNILS NVARS NTSIZE VARLST)
                        (* lmm "13-FEB-83 13:52")

    (PROG ((FUNCTFRAME (\MYALINK))
           HEADER NT NILSTART)
          (SETQ HEADER (fetch
 (FX FNHEADER) of
 FUNCTFRAME))
          (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch
 (FX NEXTBLOCK)
                                                                             of
 FUNCTFRAME)
                                                                    (UNFOLD NNILS WORDSPERCELL)))
                                              (UNFOLD NVARS WORDSPERCELL))
                                       WORDSPERQUAD)))       (* NT is address of our synthesized 

                                                             nametable: beginning of NIL's, not 

                                                             counting additional PVARs we are about 

                                                             to bind, rounded up to quadword)

          (for
 VAR in
 VARLST as
 VALUEOFF from
 NILSTART by
 WORDSPERCELL
             do
 (\PUTBASEPTR (ADDSTACKBASE VALUEOFF)
                       0
                       (\EVAL
 VAR)))                         (* then build NT)

          (UNINTERRUPTABLY
              (for
 VAR in
 VARLST as
 VAR# from
 (FOLDLO (IDIFFERENCE NILSTART (fetch
 (FX FIRSTPVAR)
                                                                               of
 FUNCTFRAME))
                                                     WORDSPERCELL) as
 NT1
                 from
 (fetch
 (FNHEADER OVERHEADWORDS) of
 T) as
 NT2
                 from
 (IPLUS (fetch
 (FNHEADER OVERHEADWORDS) of
 T)
                             NTSIZE) do
 (\PUTBASE NT NT1 (\ATOMVALINDEX VAR))
                                        (\PUTBASE NT NT2 (IPLUS PVARCODE VAR#)))
              (replace
 (FNHEADER #FRAMENAME) of
 NT with
 (QUOTE *FUNARG*))
              (replace
 (FNHEADER NTSIZE) of
 NT with
 NTSIZE)
              (replace
 (FX NAMETABLE) of
 FUNCTFRAME with
 NT))
          (RETURN (\MAKESTACKP NIL FUNCTFRAME])

(\MAKEFUNARGFRAME

  [LAMBDA (ENV)
                                              (* lmm "26-MAY-82 23:14")

    (\CALLME (QUOTE FUNARG))
    (PROG ((NVARS 0)
           NTSIZE NNILS)
          (for
 VAR in
 ENV do
                                 (* Count number of vars to bind, check 

                                                             validity)

                             (COND
                                ((OR (NULL (\DTEST VAR (QUOTE LITATOM)))
                                     (EQ VAR T))
                                 (LISPERROR "ATTEMPT TO BIND NIL OR T" VAR)))
                             (add
 NVARS 1))
          (SETQ ENV (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE (CEIL (ADD1 NVARS)
                                                                                        WORDSPERQUAD)
                                                                      )
                                                               (FOLDHI (fetch
 (FNHEADER OVERHEADWORDS
                                                                                     ) of
 T)
                                                                      WORDSPERCELL)
                                                               (SUB1 CELLSPERQUAD)))
                           (\FUNCT1
 NNILS NVARS NTSIZE ENV)))(* ENV POINTS TO COPY OF FUNCTION 

                                                             FRAME)

          (\SMASHLINK (fetch
 (STACKP EDFXP) of
 ENV)
                 0 0)
          (RETURN ENV])

(STKEVAL

  [LAMBDA (POS FORM FLG INTERNALFLG)
                         (* lmm "25-APR-80 00:08")

    (\SMASHLINK NIL (\STACKARGPTR POS))
    (AND FLG (RELSTK POS))
    (\EVAL
 FORM])

(STKAPPLY

  [LAMBDA (POS FN ARGS FLG)
                                  (* lmm "15-Aug-84 17:55")

    (\CALLME (QUOTE *ENV*))
    (\SMASHLINK NIL (\STACKARGPTR POS))
    (AND FLG (RELSTK POS))
    (.APPLY. FN ARGS])

(RETEVAL

  [LAMBDA (POS FORM FLG INTERNALFLG)
                         (* lmm "28-Aug-84 12:20")

    (\CALLME (QUOTE *ENV*))
    (PROG ((FX (\STACKARGPTR POS)))
          (\SMASHLINK NIL FX (COND
                                ((fetch
 (FX INVALIDP) of
 (SETQ FX (fetch
 (FX CLINK) of
 FX)))
                                 (LISPERROR "ILLEGAL STACK ARG" POS))
                                (T FX)))
          (AND FLG (RELSTK POS))
          (RETURN (\EVAL
 FORM])

(RETAPPLY

  [LAMBDA (POS FN ARGS FLG)
                                  (* lmm "28-Aug-84 12:20")

    (\CALLME (QUOTE *ENV*))
    (PROG ((FX (\STACKARGPTR POS)))
          (\SMASHLINK NIL FX (COND
                                ((fetch
 (FX INVALIDP) of
 (SETQ FX (fetch
 (FX CLINK) of
 FX)))
                                 (LISPERROR "ILLEGAL STACK ARG" POS))
                                (T FX)))
          (AND FLG (RELSTK POS))
          (RETURN (.APPLY. FN ARGS])
)



(* Blip and other stack funniness)


(DEFINEQ

(BLIPVAL

  [LAMBDA (BLIPTYP IPOS FLG)
                                 (* lmm "13-FEB-83 13:52")

    (PROG ([FRAME (COND
                     ((NULL IPOS)
                      (\MYALINK))
                     (T (\STACKARGPTR IPOS]
           (A (\ATOMVALINDEX BLIPTYP))
           I)
          (SELECTQ BLIPTYP
              ((*TAIL* *FORM* *FN* *ARGVAL*))
              (RETURN (AND (EQ FLG T)
                           0)))
          (RETURN
           (COND
              ((EQ FLG T)                                    (* Count number of blips of type 

                                                             BLIPTYP at FRAME)

               (COND
                  ((NOT (SETQ I (\VAROFFSET FRAME A)))
                   0)
                  ((EQ BLIPTYP (QUOTE *ARGVAL*))             (* the value of *ARGVAL* is the number 

                                                             of *ARGVAL* blips in this frame)

                   (OR (\GETBASEPTR \STACKSPACE I)
                       0))
                  (T 1)))
              (T
               (PROG NIL
                     (OR FLG (SETQ FLG 1))
                 FRAMELP
                     [COND
                        ((SETQ I (\VAROFFSET FRAME A))
                         (SELECTQ BLIPTYP
                             (*ARGVAL* [COND
                                          ((IGREATERP FLG (SETQ I (OR (\GETBASEPTR \STACKSPACE I)
                                                                      0)))
                                                             (* Fewer blips here than FLG)

                                           (SETQ FLG (IDIFFERENCE FLG I)))
                                          (T                 (* Scan the temporary region for the 

                                                             value of the FLG'th *ARGVAL* blip)

                                             (RETURN (PROG ((NXT (fetch
 (FX NEXTBLOCK) of
 FRAME))
                                                            (P (fetch
 (FX FIRSTTEMP) of
 FRAME)))
                                                       LP  (CHECK (ILESSP P NXT))
                                                           [COND
                                                              ((EQ (\GETBASEPTR \STACKSPACE P)
                                                                   (QUOTE *ARGVAL*))
                                                             (* \EVALFORM pushes the atom *ARGVAL*, 

                                                             then each argument. We want the FLG'th 

                                                             arg, counting from the end backwards)

                                                               (add
 P (UNFOLD (ADD1 (IDIFFERENCE
                                                                                     I FLG))
                                                                             WORDSPERCELL))
                                                               (CHECK (ILESSP P NXT))
                                                               (RETURN (\GETBASEPTR \STACKSPACE P]
                                                           (add
 P WORDSPERCELL)
                                                           (GO LP])
                             (COND
                                ((ILESSP (SETQ FLG (SUB1 FLG))
                                        1)
                                 (RETURN (\GETBASEPTR \STACKSPACE I]
                 NEXT
                     (COND
                        ([NOT (fetch
 (FX INVALIDP) of
 (SETQ FRAME (fetch
 (FX CLINK) of
 FRAME]
                         (GO FRAMELP])

(SETBLIPVAL

  [LAMBDA (BLIPTYP IPOS N VAL)
                               (* lmm "13-FEB-83 13:53")

    (PROG ([FRAME (COND
                     ((NULL IPOS)
                      (\MYALINK))
                     (T (\STACKARGPTR IPOS]
           (A (\ATOMVALINDEX BLIPTYP))
           I)
          (SELECTQ BLIPTYP
              ((*TAIL* *FORM* *FN* *ARGVAL*))
              (RETURN))
          (COND
             ((NOT N)
              (SETQ N 1))
             ((ILESSP N 1)
              (\ILLEGAL.ARG N)))
      FRAMELP
          [COND
             ((SETQ I (\VAROFFSET FRAME A))
              (SELECTQ BLIPTYP
                  (*ARGVAL* [COND
                               ((NOT (SETQ I (\GETBASEPTR \STACKSPACE I)))
                                                             (* No argvals)

                                )
                               ((IGREATERP N I)
                                (SETQ N (IDIFFERENCE N I)))
                               (T                            (* Scan the temporary region for the 

                                                             value of the Nth *ARGVAL* blip)

                                  (RETURN (PROG ((NXT (fetch
 (FX NEXTBLOCK) of
 FRAME))
                                                 (P (fetch
 (FX FIRSTTEMP) of
 FRAME)))
                                            LP  (CHECK (ILESSP P NXT))
                                                [COND
                                                   ((EQ (\GETBASEPTR \STACKSPACE P)
                                                        (QUOTE *ARGVAL*))
                                                             (* \EVALFORM pushes the atom *ARGVAL*, 

                                                             then each argument. We want the N'th 

                                                             arg from the end)

                                                    (add
 P (UNFOLD (ADD1 (IDIFFERENCE I N))
                                                                  WORDSPERCELL))
                                                    (CHECK (ILESSP P NXT))
                                                    (RETURN (\PUTBASEPTR \STACKSPACE P VAL]
                                                (add
 P WORDSPERCELL)
                                                (GO LP])
                  (COND
                     ((ILESSP (SETQ N (SUB1 N))
                             1)                              (* All other blip types are just the 

                                                             value of the blip binding)

                      (RETURN (\PUTBASEPTR \STACKSPACE I VAL]
          (COND
             ([NOT (fetch
 (FX INVALIDP) of
 (SETQ FRAME (fetch
 (FX CLINK) of
 FRAME]
              (GO FRAMELP])

(BLIPSCAN

  [LAMBDA (BLIPTYP IPOS)
                                     (* lmm "13-FEB-83 13:52")

    (PROG ([FRAME (COND
                     ((NULL IPOS)
                      (\MYALINK))
                     (T (\STACKARGPTR IPOS]
           OFF A)
          (SETQ A (SELECTQ BLIPTYP
                      ((*FORM* *TAIL* *FN* *ARGVAL*) 
                           (\ATOMVALINDEX BLIPTYP))
                      (RETURN)))
      LP  (COND
             ([AND (SETQ OFF (\VAROFFSET FRAME A))
                   (NOT (AND (EQ BLIPTYP (QUOTE *ARGVAL*))
                             (NULL (GETBASEPTR \STACKSPACE OFF]
              (RETURN (\MAKESTACKP NIL FRAME)))
             ([NOT (fetch
 (FX INVALIDP) of
 (SETQ FRAME (fetch
 (FX CLINK) of
 FRAME]
              (GO LP))
             (T (RETURN])
)
(DEFINEQ

(DUMMYFRAMEP

  [LAMBDA (POS)
                                              (* wt: "20-AUG-80 23:39")

    (NOT (REALFRAMEP
 POS T])

(REALFRAMEP

  [LAMBDA (POS INTERPFLG)
                                    (* lmm "27-MAY-80 22:00")

          
          (* Value is T if user did write a call to the function at POS, and either 

          INTERPFLG is T, or else the functio call would also exist if compiled)


    (\REALFRAMEP
 (\STACKARGPTR POS)
           INTERPFLG])

(REALSTKNTH

  [LAMBDA (N POS INTERPFLG OLDPOS)
                           (* lmm "27-MAY-80 22:00")

                                                             (* skips back N (or -N) real frames on 

                                                             the stack. i.e. frames for which

                                                             (REALFRAMEP POS INTERPFLG) is true)

    (PROG [(FX (\STACKARGPTR POS))
           (K (COND
                 ((ILESSP N 0)
                  (IMINUS N))
                 (T N]
      LP  (COND
             ([EQ 0 (SETQ FX (COND
                                ((IGREATERP 0 N)
                                 (fetch
 (FX CLINK) of
 FX))
                                (T (fetch
 (FX ALINK) of
 FX]
              (RETURN NIL)))
          [COND
             ((\REALFRAMEP
 FX INTERPFLG)
              (COND
                 ((ILEQ (SETQ K (SUB1 K))
                        0)
                  (RETURN (\MAKESTACKP OLDPOS FX]
          (GO LP])

(\REALFRAMEP

  [LAMBDA (FRAME INTERPFLG)
                                  (* lmm " 2-Jul-86 12:59")

    (PROG ((NAME (fetch
 (FNHEADER FRAMENAME) of
 (fetch
 (FX FNHEADER) of
 FRAME)))
           BFLINK)                                           (* NOTE THAT WE SELECT ON THE 

                                                             FNHEADER'S NAME RATHER THAN THE 

                                                             NAMETABLE NAME. THUS, REALFRAMEP IS 

                                                             NOT AFFECTED BY SETSTKNAME)

          (RETURN (SELECTQ NAME
                      (*ENV*                                 (* *ENV* is used by ENVEVAL etc.)

                             NIL)
                      (\INTERPRETER T)
                      ((EVAL APPLY) 
                           (\SMASHLINK NIL FRAME)
                           (SELECTQ \INTERNAL
                               ((INTERNAL SELECTQ) 
                                    NIL)
                               T))
                      (OR (NOT (LITATOM NAME))
                          (COND
                             ((FMEMB NAME OPENFNS)
                              INTERPFLG)
                             (T (OR (NEQ (CHCON1 NAME)
                                         (CHARCODE \))
                                    (EXPRP
 NAME)
                                    (FASSOC NAME BRKINFOLST])
)

(RPAQ? OPENFNS
 
       (QUOTE (APPLY* SETQ AND OR COND SELECTQ PROG PROGN PROG1 ARG SETARG ERSETQ NLSETQ RESETFORM 
                     RESETLST RESETVARS RPTQ SAVESETQ SETN UNDONLSETQ XNLSETQ)))

(RPAQQ \BLIPNAMES
 (*TAIL* *FORM* *FN* *ARGVALS*))
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS BRKINFOLST)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \BLIPNAMES OPENFNS)
)
(DEFINEQ

(RAIDCOMMAND

  [LAMBDA NIL
                                                (* lmm "18-Mar-86 09:52")

    (DECLARE
 (USEDFREE ROOTFRAME ALINKS? RAIDIX FRAME# VPRINTLEVEL))
    (FRESHLINE T)
    (PROG (CMD)
          (SELECTQ (ALLOCAL (SETQ CMD (ASKUSER NIL NIL "@"
                                             [QUOTE ((Q "uit [confirm]" CONFIRMFLG T)
                                                     (% "^N - remote return [confirm]" NOECHOFLG T 
                                                         CONFIRMFLG T RETURN (QUOTE ^N))
                                                     (L "isp stack ")
                                                     (% "Lisp stack " NOECHOFLG T EXPLAINSTRING 
                                                   "^L -- Lisp stack from arbitrary frame or context" 
                                                         RETURN (QUOTE ^L))
                                                     (F "rame ")
                                                     (%
 "Next frame " EXPLAINSTRING 
                                                         "LF - next frame" RETURN (QUOTE LF))
                                                     (^ " Previous frame ")
                                                     (A "tom top-level value of atom: ")
                                                     (D "efinition for atom: ")
                                                     (P "roperty list for atom: ")
                                                     (V " -- show object at Virtual address: ")
                                                     (B "lock of storage starting at address: ")
                                                     (S "how raw stack from address: ")
                                                     (C "ode for function:")
                                                     (% "Basic frame at: " EXPLAINSTRING 
                                                         "^F - print basic frame at octal address" 
                                                         RETURN (QUOTE ^F))
                                                     (% "frame extension at: " EXPLAINSTRING 
                                                        "^X - print frame extension at octal address" 
                                                         RETURN (QUOTE ^X))
                                                     (W "alk stack blocks starting at: ")
                                                     (K "" EXPLAINSTRING 
                                                        "K -- Set linKtype for stack ops")
                                                     (_ " Set word at address: ")
                                                     (% " Set value of atom " EXPLAINSTRING 
                                                         "^V -- Set value of atom" RETURN
                                                         (QUOTE ^V))
                                                     (% "atom number for atom: " EXPLAINSTRING 
                                                         "^O - look up atom" RETURN (QUOTE ^O))
                                                     (Z "Zap Print level to: ")
                                                     (I "nspect InterfacePage [confirm]" CONFIRMFLG T
                                                        )
                                                     (U " -- Show remote screen [confirm]" CONFIRMFLG 
                                                        T)
                                                     ("
" "" RETURN NIL)
                                                     (% " Enter Lisp " EXPLAINSTRING 
                                                         "^Y -- Enter Lisp" RETURN (QUOTE ^Y]
                                             T)))
              (^N (RETURN (QUOTE RETURN)))
              (Q (TERPRI T)
                 (RETURN (QUOTE QUIT)))
              (NIL)
              (A (PRINCOPY
 (GETTOPVAL (READATOM
))))
              (P (PRINCOPY
 (GETPROPLIST (READATOM
))))
              (C (PRINTCODE (READATOM
)
                        T RAIDIX))
              (V (PRINCOPY
 (READVA
)))
              (B (PRINTADDRS
 (READVA
)
                        (READOCT
 " for (number of words): ")))
              (S (PRINTADDRS
 (ADDSTACKBASE (READOCT
))
                        (READOCT
 " for (number of words): ")))
              (D (PRINTADDRS
 (fetch
 (LITATOM DEFINITIONCELL) of
 (READATOM
))
                        2))
              (^O (PRINTNUM .I2 (\ATOMVALINDEX (READATOM
))
                         T))
              (^V (PROG ((ATM (READATOM
)))
                        (printout T " to be ")
                        (SETTOPVAL ATM (READ T T))))
              ((L ^L) 
                   (RAIDSTACKCMD
 CMD))
              (F [RAIDSHOWFRAME
 (SETQ FRAME# (PROG1 (READ T T)
                                                    (READC T])
              (LF (OR FRAME# (SETQ FRAME# 0))
                  (printout T "(" .I1 (add
 FRAME# 1)
                         ")" T)
                  (RAIDSHOWFRAME
 FRAME#))
              (^ (COND
                    ((OR (NULL FRAME#)
                         (ILEQ FRAME# 1))
                     (printout T "No previous frame" T))
                    (T (printout T "(" .I1 (add
 FRAME# -1)
                              ")" T)
                       (RAIDSHOWFRAME
 FRAME#))))
              (^F (\PRINTBF
 (READOCT
)
                         NIL
                         (FUNCTION PRINCOPY)))
              (Z [ALLOCAL (LET [(A (PROG1 (READ T T)
                                          (READC T)))
                                (D (PROG1 (READ T T)
                                          (READC T]
                               (COND
                                  ((AND (FIXP A)
                                        (FIXP D))
                                   (SETQ VPRINTLEVEL (CONS A D)))
                                  (T (PRINTOUT T "Must be two integers, car level then cdr level" T)
                                     (ERROR!])
              (W [SHOWSTACKBLOCKS
 (COND
                                     ((EQ (PEEKC T)
                                          (QUOTE %
))
                                      (READC T)
                                      (fetch
 (IFPAGE StackBase) of
 \InterfacePage))
                                     (T (READOCT
])
              (^X (\PRINTFRAME
 (READOCT
)
                         (QUOTE PRINCOPY)))
              (^Y (TERPRI T)
                  (USEREXEC (QUOTE ::)))
              (K (SETQ ALINKS? (EQ (ASKUSER NIL NIL " Set link type for stack operations to "
                                          (QUOTE ((A "links
")
                                                  (C "links
")))
                                          T)
                                   (QUOTE A))))
              (_ (PROG ((VA (READVA
)))
                       (printout T " Currently ")
                       (PRINTNUM .I7 (GETBASE VA 0)
                              T)
                       (printout T " to be ")
                       (PUTBASE VA 0 (READOCT
))))
              (I [ALLOCAL (COND
                             [(NULL (GETD (QUOTE INSPECT]
                             ((RECLOOK (QUOTE IFPAGE))
                              (INSPECT [COND
                                          ((LISTP VMEMFILE)
                                           (VMAPPAGE (fetch
 (POINTER PAGE#) of
 \InterfacePage)))
                                          (T (PROG [(PAGE (NCREATE (QUOTE VMEMPAGEP]
                                                   (SETVMPTR (VGETTOPVAL (QUOTE \InterfacePage)))
                                                   (\BINS (GETSTREAM VMEMFILE)
                                                          PAGE 0 BYTESPERPAGE)
                                                   (RETURN PAGE]
                                     (QUOTE IFPAGE)))
                             (T (PRIN1 " Can't -- no record for IFPAGE"]
                 (TERPRI T))
              (U (SHOWREMOTESCREEN))
              (HELP))
          (RETURN NIL])

(RAIDSHOWFRAME

  [LAMBDA (N)
                                                (* bvm: "27-Jan-85 15:27")

    (PROG [(FRAME (OR ROOTFRAME (RAIDROOTFRAME
]
          [FRPTQ (SUB1 N)
                 (COND
                    ([fetch
 (FX INVALIDP) of
 (SETQ FRAME (COND
                                                            (ALINKS? (fetch
 (FX ALINK) of
 FRAME))
                                                            (T (fetch
 (FX CLINK) of
 FRAME]
                     (RETURN (printout T N " is beyond the bottom of the stack" T]
          (\BACKTRACE
 FRAME FRAME T NIL T T NIL (FUNCTION PRINCOPY)
                 NIL RAIDIX])

(RAIDSTACKCMD

  [LAMBDA (CMD)
                                              (* bvm: "28-Jan-85 12:16")

    (DECLARE
 (USEDFREE FRAME# ROOTFRAME))
    (PROG (FRAME)
          (SETQ FRAME# 0)
          [COND
             ((EQ CMD (QUOTE L))
              (RAIDROOTFRAME
))
             (T (SETQ ROOTFRAME (SELECTQ (SETQ FRAME (ASKUSER NIL NIL "in context (? for help): "
                                                            (QUOTE ((P "age fault")
                                                                    (G "arbage collection")
                                                                    (K "eyboard handler")
                                                                    (H "ard Return")
                                                                    (S "tack manipulator")
                                                                    (R "eset")
                                                                    (M "iscellaneous")
                                                                    (F "rame at location: ")))
                                                            T))
                                    (P (fetch
 (IFPAGE FAULTFXP) of
 \InterfacePage))
                                    (G (fetch
 (IFPAGE GCFXP) of
 \InterfacePage))
                                    (K (fetch
 (IFPAGE KbdFXP) of
 \InterfacePage))
                                    (H (fetch
 (IFPAGE HardReturnFXP) of
 \InterfacePage))
                                    (S (fetch
 (IFPAGE SubovFXP) of
 \InterfacePage))
                                    (R (fetch
 (IFPAGE ResetFXP) of
 \InterfacePage))
                                    (M (fetch
 (IFPAGE MiscFXP) of
 \InterfacePage))
                                    (COND
                                       ((AND (ILESSP (SETQ FRAME (READOCT
))
                                                    WORDSPERPAGE)
                                             (ILESSP (\GETBASE \InterfacePage FRAME)
                                                    (fetch
 (IFPAGE EndOfStack) of
 \InterfacePage))
                                             (type?
 FX (\GETBASE \InterfacePage FRAME)))
                                        (\GETBASE \InterfacePage FRAME))
                                       ((type?
 FX FRAME)
                                        FRAME)
                                       (T (PRINTNUM .I7 FRAME)
                                          (printout T " not a valid frame." T)
                                          (RETURN]
          (FRESHLINE T)
          (\BACKTRACE
 ROOTFRAME NIL T NIL NIL NIL ALINKS? (FUNCTION PRINCOPY)
                 1 RAIDIX])

(RAIDROOTFRAME

  [LAMBDA NIL
                                                (* bvm: "27-Jan-85 15:26")

    (SETQ ROOTFRAME (PROG1 (COND
                              ((ALLOCAL (LISTP VMEMFILE))
                               (PRIN1 "in TeleRaid Context" T)
                               (fetch
 (IFPAGE TELERAIDFXP) of
 \InterfacePage))
                              (T (fetch
 (IFPAGE CurrentFXP) of
 \InterfacePage)))
                           (TERPRI T])

(PRINTADDRS

  [LAMBDA (BASE CNT)
                                         (* bvm: "13-Feb-85 22:42")

    (PRIN1 "words from ")
    (PRINTVA
 BASE)
    (PRIN1 " to ")
    (PRINTVA
 (\ADDBASE BASE (SUB1 CNT)))
    (TERPRI)
    (SPACES 7)
    (for
 I from
 0 to
 7 do
 (PRINTNUM .I7 I))
    (PROG ((NB (\VAG2 (\HILOC BASE)
                      (FLOOR (\LOLOC BASE)
                             8)))
           (LB (\ADDBASE BASE CNT)))
          (do
 (COND
                 ((EVENP (\LOLOC NB)
                         8)
                  (TAB 0 0)
                  (PRINTNUM .I5 (\LOLOC NB))
                  (PRIN1 ": ")))
              [COND
                 ((PTRGTP BASE NB)
                  (SPACES 7))
                 (T (PRINTNUM .I7 (\GETBASE NB 0]
              (SETQ NB (\ADDBASE NB 1)) repeatwhile
 (PTRGTP LB NB))
          (TAB 0 0])

(PRINTVA

  [LAMBDA (X)
                                                (* bvm: "12-Feb-85 10:41")

    (PRIN1 "{")
    (PRINTNUM .I2 (HILOC X))
    (PRIN1 ",")
    (PRINTNUM .I2 (LOLOC X))
    (PRIN1 "}"])

(READVA

  [LAMBDA NIL
                                                (* lmm "21-AUG-81 12:55")

    (VAG2 (READOCT
)
          (READOCT
])

(READATOM

  [LAMBDA NIL
                                                (* bvm: "18-Jan-85 14:42")

    (PROG1 (READ T T)
           (READC T])

(READOCT

  [LAMBDA (PROMPT)
                                           (* bvm: "28-Jan-85 11:51")

    (DECLARE
 (USEDFREE RAIDIX))
    (COND
       ((AND PROMPT (NOT (READP T)))
        (printout T PROMPT)))
    (bind
 STR while
 (EQUAL (SETQ STR (RSTRING T T))
                           "") do
 (READC T)
       finally

       (RETURN
        (PROG1 (OR (FIXP (SELECTQ RAIDIX
                             (8 (MKATOM (CONCAT STR "Q")))
                             (16 (bind
 (N _ 0)
                                       CHAR while
 (SETQ CHAR (GNC STR))
                                    do
 [SETQ N (IPLUS (ITIMES N 16)
                                                      (COND
                                                         ((FIXP CHAR)
                                                          CHAR)
                                                         ((AND (IGEQ (SETQ CHAR (CHCON1 CHAR))
                                                                     (CHARCODE A))
                                                               (ILEQ CHAR (CHARCODE F)))
                                                          (IPLUS (IDIFFERENCE CHAR (CHARCODE A))
                                                                 10))
                                                         (T (ERROR CHAR (QUOTE ?)
                                                                   T] finally
 (RETURN N)))
                             (SHOULDNT)))
                   (PROGN (PRIN1 "?" T)
                          (ERROR!)))
               (READC T])

(SHOWSTACKBLOCKS

  [LAMBDA (SCANPTR WAITFLG)
                                  (* bvm: "18-AUG-83 12:05")

                                                             (* show stack)

    (PROG ((EASP (fetch
 EndOfStack of
 \InterfacePage)))
      SCAN
          [SELECTC (fetch
 (STK FLAGS) of
 SCANPTR)
              (\STK.FSB (SHOWSTACKBLOCK1
 SCANPTR "free block" (fetch
 (FSB CHECKED) of
 SCANPTR))
                        (add
 SCANPTR (fetch
 (FSB SIZE) of
 SCANPTR)))
              (\STK.GUARD (SHOWSTACKBLOCK1
 SCANPTR "guard block" T)
                          (add
 SCANPTR (fetch
 (FSB SIZE) of
 SCANPTR)))
              (\STK.FX                                       (* frame extension)

                       (SHOWSTACKBLOCK1
 SCANPTR "Frame extn = " (fetch
 (FX CHECKED) of
 SCANPTR))
                       (PRIN2 (\UNCOPY (fetch
 (FX FRAMENAME) of
 SCANPTR)))
                       (SETQ SCANPTR (fetch
 (FX NEXTBLOCK) of
 SCANPTR)))
              (PROG ((ORIG SCANPTR)
                     IVAR)                                   (* must be a basic frame)

                    (while
 (EQ (fetch
 (STK FLAGS) of
 SCANPTR)
                               \STK.NOTFLAG) do
 (add
 SCANPTR WORDSPERCELL))
                    (COND
                       ((NOT (type?
 BF SCANPTR))
                        (SHOWSTACKBLOCK1
 ORIG "Garbage" T))
                       (T (SETQ IVAR (fetch
 (BF IVAR) of
 SCANPTR))
                          [COND
                             ((fetch
 (BF RESIDUAL) of
 SCANPTR)
                              (SHOWSTACKBLOCK1
 SCANPTR "Residual BF" (EQ SCANPTR ORIG))
                              (PRIN1 " with IVar = ")
                              (PRINTNUM .I7 IVAR))
                             (T (SHOWSTACKBLOCK1
 SCANPTR "Basic frame" (AND (EQ ORIG IVAR)
                                                                            (fetch
 (BF CHECKED)
                                                                               of
 SCANPTR]
                          (add
 SCANPTR WORDSPERCELL]
          (TERPRI)
          (COND
             ((IGREATERP SCANPTR EASP)
              (RETURN)))
          (AND WAITFLG (READC T))
          (GO SCAN])

(SHOWSTACKBLOCK1

  [LAMBDA (PTR STR GOODFLG)
                                  (* bvm: " 6-AUG-83 23:59")

    (PRINTNUM .I7 PTR)
    (SPACES 1)
    (OR GOODFLG (PRIN1 "[bad] "))
    (PRIN1 STR])

(PRINCOPY

  [LAMBDA (X)
                                                (* bvm: "24-Jan-86 12:33")

    (PRINT (\UNCOPY X (LOCAL (CAR VPRINTLEVEL))
                  (LOCAL (CDR VPRINTLEVEL)))
           T T])

(NOSUCHATOM

  [LAMBDA (ATM)
                                              (* bvm: "18-Jan-85 17:52")

                                                             (* Called only under TeleRaid when 

                                                             V\MKATOM fails to find atom ATM)

    (printout T "No such atom: " ATM T)
    (ERROR!])
)
(DEFINEQ

(BACKTRACE

  [LAMBDA (IPOS EPOS FLAGS FILE PRINTFN)
                     (* bvm: "13-Feb-85 22:42")

    (RESETFORM (OUTPUT FILE)
           (\BACKTRACE
 (\STACKARGPTR (OR IPOS -1))
                  (\STACKARGPTR (OR EPOS T))
                  [EQ 0 (LOGAND 8 (OR FLAGS (SETQ FLAGS 0]
                  (NEQ 0 (LOGAND FLAGS 1))
                  (NEQ 0 (LOGAND FLAGS 4))
                  (NEQ 0 (LOGAND FLAGS 32))
                  (EQ 0 (LOGAND FLAGS 16))
                  (OR PRINTFN (FUNCTION PRINT))
                  NIL])

(\BACKTRACE

  [LAMBDA (IPOS EPOS NAMES VARS LOCALS JUNK ALINKS PRINTFN CNT RADIX)

                                                             (* lmm " 2-Jul-86 13:00")

    (OR RADIX (SETQ RADIX 8))
    (PROG [NARGS
 NPVARS NAME ARGNAME BLINK (.I7 (NUMFORMATCODE (LIST (QUOTE FIX)
                                                                     7 RADIX]
          (DECLARE
 (SPECVARS .I7))
      POSLP
          (COND
             (CNT (printout NIL .I3 CNT ": ")
                  (add
 CNT 1)))
          (SETQ NAME (\STKNAME
 IPOS))
          (COND
             (JUNK (TERPRI)
                   (TERPRI)
                   (PRIN1 "Basic frame at ")
                   (PRINTNUM .I7 (SETQ BLINK (fetch
 (FX BLINK) of
 IPOS)))
                   (TERPRI)
                   (\PRINTBF
 BLINK (fetch
 (FX NAMETABLE) of
 IPOS)
                          PRINTFN)
                   (PROGN (TERPRI)
                          (PRIN1 "Frame xtn at ")
                          (PRINTNUM .I7 IPOS)
                          (PRIN1 ", frame name= "))
                   (APPLY*
 PRINTFN NAME)
                   (\PRINTFRAME
 IPOS PRINTFN))
             [(OR VARS LOCALS)
              (\PRINTBF
 (fetch
 (FX BLINK) of
 IPOS)
                     (fetch
 (FX NAMETABLE) of
 IPOS)
                     PRINTFN
                     (COND
                        (LOCALS (QUOTE LOCALS))
                        (T T)))
              (COND
                 (NAMES (APPLY*
 PRINTFN NAME)
                        (TERPRI)))
              (\PRINTFRAME
 IPOS PRINTFN (COND
                                           (LOCALS (QUOTE LOCALS))
                                           (T T]
             (NAMES (APPLY*
 PRINTFN NAME)))
          (COND
             ([AND (NEQ EPOS IPOS)
                   (NOT (fetch
 (FX INVALIDP) of
 (SETQ IPOS (COND
                                                              (ALINKS (fetch
 (FX ALINK) of
 IPOS))
                                                              (T (fetch
 (FX CLINK) of
 IPOS]
              (GO POSLP)))
          (RETURN T])

(\SCANFORNTENTRY

  [LAMBDA (NMT NTENTRY)
                                      (* bvm: "13-Feb-85 22:42")

    (bind
 NM for
 NT1 from
 (fetch
 (FNHEADER OVERHEADWORDS) of
 T) as
 NT2
       from
 (IPLUS (fetch
 (FNHEADER OVERHEADWORDS) of
 T)
                   (fetch
 (FNHEADER NTSIZE) of
 NMT)) do
 (COND
                                                           ((EQ (SETQ NM (\GETBASE NMT NT1))
                                                                0)
                                                            (RETURN)))
                                                        (COND
                                                           ((IEQ NTENTRY (\GETBASE NMT NT2))
                                                            (RETURN (\INDEXATOMVAL NM])

(\PRINTSTK

  [LAMBDA (I)
                                                (* lmm "23-MAY-82 22:09")

    (PRINTNUM .I7 I)
    (PRIN1 ": ")
    (PRINTNUM .I7 (GETBASE \STACKSPACE I))
    (PRINTNUM .I7 (GETBASE \STACKSPACE (ADD1 I)))
    (SPACES 1])

(\PRINTFRAME

  [LAMBDA (FRAME PRINTFN VARSONLY)
                           (* bvm: " 5-Mar-85 18:14")

    (PROG ((NMT (fetch
 (FX NAMETABLE) of
 FRAME))
           (I 0)
           (FT (fetch
 (FX FIRSTTEMP) of
 FRAME))
           TMP NLOCALS)
          [COND
             ((NOT VARSONLY)
              (\PRINTSTK
 FRAME)
              (PRIN1 "[")
              (PROGN (PSTKFLD FAST "F, " FAST)
                     (PSTKFLD INCALL "C, " INCALL)
                     (PSTKFLD VALIDNAMETABLE "V, " VALIDNAMETABLE)
                     (PSTKFLD NOPUSH "N, " NOPUSH)
                     (PSTKFLD USECNT "USE=" (NEQ USECNT 0)
                            NIL ", ")
                     (PSTKFLD SLOWP "X, " SLOWP)
                     (PSTKFLD ALINK " alink]" T))
              (TERPRI)
              (PSTK 2 (FNHEADER "[fn header]" T))
              (PSTK 4 (NEXTBLOCK "[next, pc]" T))
              (PSTK 6 (NAMETABLE "[nametable]" T))
              (PSTK 8 (BLINK "[blink, clink]" T]
          (SETQ NLOCALS (fetch
 (FNHEADER NLOCALS) of
 NMT))
          [for
 old
 I from
 (fetch
 (FX FIRSTPVAR) of
 FRAME) by
 WORDSPERCELL
             while
 (ILESSP I FT) as
 J from
 0
             do
 (OR VARSONLY (\PRINTSTK
 I))
                (COND
                   [(ILESSP J NLOCALS)
                    (COND
                       ([OR (SETQ TMP (\SCANFORNTENTRY
 NMT (IPLUS PVARCODE J)))
                            (AND (NEQ VARSONLY T)
                                 (SETQ TMP (QUOTE *local*]
                        (COND
                           ((fetch
 (PVARSLOT BOUND) of
 (ADDSTACKBASE I))
                            (AND VARSONLY (SPACES 3))
                            (PRIN2 TMP)
                            (SPACES 1)
                            (APPLY*
 PRINTFN (\GETBASEPTR (ADDSTACKBASE I)
                                                   0)))
                           ((NOT VARSONLY)
                            (printout NIL TMP " [unbound]" T]
                   ((NOT VARSONLY)
                    (COND
                       ((SETQ TMP (\SCANFORNTENTRY
 NMT (IPLUS FVARCODE J)))
                        (printout NIL "[fvar " .P2 TMP " "
                               (COND
                                  ((fetch
 (FVARSLOT LOOKEDUP) of
 (ADDSTACKBASE I))
                                   (COND
                                      ((EQ [SETQ TMP (\HILOC (fetch
 (FVARSLOT BINDINGPTR)
                                                                of
 (ADDSTACKBASE I]
                                           \STACKHI)
                                       " on stack]")
                                      ((NEQ (FLOOR TMP 2)
                                            (\HILOC \VALSPACE))
                                                             (* See comment in BOUNDP)

                                       " non-stack binding]")
                                      (T " top value]")))
                                  (T " not looked up]"))
                               T))
                       (T (printout NIL "[padding]" T]
          (COND
             ((NOT VARSONLY)
              (SETQ FT (fetch
 (FX NEXTBLOCK) of
 FRAME))
              (for
 old
 I by
 2 while
 (ILESSP I FT) do
         (* 2 = WORDSPERCELL but for doesn't 

                                                             translate correctly with WORDSPERCELL)

                                                     (\PRINTSTK
 I)
                                                     (COND
                                                        ((fetch
 (PVARSLOT BOUND) of
 (ADDSTACKBASE
                                                                                     I))
                                                         (APPLY*
 PRINTFN (\GETBASEPTR (ADDSTACKBASE
                                                                                       I)
                                                                                0)))
                                                        (T (TERPRI])

(\PRINTBF

  [LAMBDA (BL NMT PRINTFN VARSONLY)
                          (* bvm: " 9-DEC-81 16:44")

    [bind
 NM for
 I from
 (fetch
 (BF IVAR) of
 BL) by
 2 as
 J from
 0
       to
 (SUB1 (fetch
 (BF NARGS) of
 BL))
       do
 (OR VARSONLY (\PRINTSTK
 I))
          [COND
             ([OR (SETQ NM (\SCANFORNTENTRY
 [OR NMT (RETURN (OR VARSONLY (TERPRI]
                                  (IPLUS IVARCODE J)))
                  (AND (NEQ VARSONLY T)
                       (SETQ NM (QUOTE *local*]
              (AND VARSONLY (SPACES 3))
              (PRIN2 NM)
              (SPACES 1)
              (APPLY*
 PRINTFN (GETBASEPTR \STACKSPACE I]
       finally
 (OR VARSONLY (while
 (ILESSP I BL) do
 (\PRINTSTK
 I)
                                                    (printout NIL "[padding]" T)
                                                    (add
 I 2]
    (COND
       ((NOT VARSONLY)
        (\PRINTSTK
 BL)
        (COND
           ((fetch
 (BF RESIDUAL) of
 BL)
            (PRIN1 "residual ")))
        (COND
           ((NEQ (fetch
 (BF USECNT) of
 BL)
                 0)
            (printout NIL "usecnt= " (fetch
 (BF USECNT) of
 BL)
                   %,)))
        (TERPRI])
)
(DECLARE: EVAL@COMPILE DONTCOPY 

(RPAQQ RAIDCOMS
 
       ((MACROS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA)
        (ADDVARS (RDCOMS (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA 
                              READVA READOCT READATOM SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY 
                              NOSUCHATOM)
                        (FNS \BACKTRACE \STKNAME \PRINTBF \PRINTFRAME \SCANFORNTENTRY \PRINTSTK))
               (EXPANDMACROFNS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA))
        (ADDVARS (DONTCOMPILEFNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS 
                        PRINTVA READVA READATOM READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY 
                        NOSUCHATOM))))
(DECLARE: EVAL@COMPILE 

(PUTPROPS PSTKFLD MACRO ((FLD STR TEST FMT STR2)
                         (PROG ((FLD (fetch (FX FLD)
                                            of FRAME)))
                               (DECLARE (LOCALVARS FLD))
                               (COND (TEST (PRIN1 (QUOTE STR))
                                           (SELECTQ (CONSTANT (NTHCHAR (QUOTE STR)
                                                                     -1))
                                                  (= (printout NIL %, FLD STR2))
                                                  NIL)
                                           T)))))
(PUTPROPS PRINTSTKFIELDS MACRO (FIELDS (CONS (QUOTE PROGN)
                                             (MAPCAR FIELDS (FUNCTION (LAMBDA (X)
                                                                             (CONS (QUOTE PSTKFLD)
                                                                                   X)))))))
(PUTPROPS PSTK MACRO ((N . FIELDS)
                      (\PRINTSTK (IPLUS FRAME N))
                      (PRINTSTKFIELDS . FIELDS)
                      (TERPRI)))
(PUTPROPS PRINTVA MACRO (LAMBDA (X)
                               (printout NIL "{" (HILOC X)
                                      ","
                                      (LOLOC X)
                                      "}")))
)

(ADDTOVAR RDCOMS
 (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA READVA 
                      READOCT READATOM SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY NOSUCHATOM)
                 (FNS \BACKTRACE \STKNAME \PRINTBF \PRINTFRAME \SCANFORNTENTRY \PRINTSTK))

(ADDTOVAR EXPANDMACROFNS
 PSTKFLD PRINTSTKFIELDS PSTK PRINTVA)

(ADDTOVAR DONTCOMPILEFNS
 RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA 
                               READVA READATOM READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY 
                               NOSUCHATOM)
)
(DEFINEQ

(CCODEP

  [LAMBDA (FN)
                                               (* bvm: " 8-Jul-86 16:25")

    (COND
       [(LITATOM FN)
        (COND
           ((fetch
 (LITATOM CCODEP) of
 FN)
            (NOT (fetch
 (LITATOM PSEUDOCODEP) of
 FN)))
           (T (TYPEP (fetch
 (LITATOM DEFPOINTER) of
 FN)
                     (QUOTE COMPILED-CLOSURE]
       (T (OR (TYPEP FN (QUOTE COMPILED-CLOSURE))
              (AND (ARRAYP FN)
                   (EQ (fetch
 (ARRAYP TYP) of
 FN)
                       \ST.CODE])

(EXPRP

  [LAMBDA (FN)
                                               (* lmm "17-FEB-82 23:50")

    (PROG ((DEF FN))
          [COND
             ((LITATOM DEF)
              [COND
                 ((fetch
 (LITATOM CCODEP) of
 DEF)
                  (RETURN (fetch
 (LITATOM PSEUDOCODEP) of
 DEF]
              (SETQ DEF (fetch
 (LITATOM DEFPOINTER) of
 DEF]
          (RETURN (COND
                     ((LISTP DEF)
                      T])

(SUBRP

  [LAMBDA (FN)
                                               (* lmm "17-AUG-81 21:57")

    NIL])

(FNTYP

  [LAMBDA (FN)
                                               (* bvm: " 7-Jul-86 16:43")

    (PROG ((DEF FN))
          [COND
             ((LITATOM DEF)
              (SETQ DEF (fetch
 (LITATOM DEFINITIONCELL) of
 DEF))
              (COND
                 ((fetch
 (DEFINITIONCELL PSEUDOCODEP) of
 DEF)
                  (SETQ DEF (\PSEUDOCODE.REALDEF DEF)))
                 ((PROG1 (fetch
 (DEFINITIONCELL CCODEP) of
 DEF)
                         (SETQ DEF (fetch
 (DEFINITIONCELL DEFPOINTER) of
 DEF)))
                  (RETURN (\CCODEFNTYP DEF]
          (RETURN (COND
                     ((LISTP DEF)
                      (SELECTQ (CAR DEF)
                          (CL:LAMBDA (QUOTE EXPR*))
                          ([LAMBDA OPENLAMBDA] 
                               (COND
                                  ((AND (NLISTP (SETQ DEF (CADR DEF)))
                                        DEF)
                                   (QUOTE EXPR*))
                                  (T (QUOTE EXPR))))
                          (NLAMBDA (COND
                                      ((AND (NLISTP (SETQ DEF (CADR DEF)))
                                            DEF)
                                       (QUOTE FEXPR*))
                                      (T (QUOTE FEXPR))))
                          (FUNARG (QUOTE EXPR))
                          NIL))
                     ((TYPEP DEF (QUOTE COMPILED-CLOSURE))
                      (\CCODEFNTYP (fetch
 (COMPILED-CLOSURE FNHEADER) of
 DEF])

(ARGTYPE

  [LAMBDA (FN)
                                               (* bvm: "16-Jul-86 22:47")

    (LET ((DEF FN))
         (TYPECASE DEF [SYMBOL (COND
                                  ((PROG1 (fetch
 (LITATOM CCODEP) of
 DEF)
                                          (SETQ DEF (fetch
 (LITATOM DEFPOINTER) of
 DEF)))
                                   (\CCODEARGTYPE DEF))
                                  (DEF (ARGTYPE
 DEF]
                (CONS (SELECTQ (CAR DEF)
                          (CL:LAMBDA 2)
                          ([LAMBDA OPENLAMBDA] 
                               (COND
                                  ((AND (NLISTP (SETQ DEF (CADR DEF)))
                                        DEF)
                                   2)
                                  (T 0)))
                          (NLAMBDA (COND
                                      ((AND (NLISTP (SETQ DEF (CADR DEF)))
                                            DEF)
                                       3)
                                      (T 1)))
                          (FUNARG (ARGTYPE
 (CADR DEF)))
                          (SELECTQ (FNTYP
 DEF)
                              (EXPR 0)
                              (FEXPR 1)
                              (EXPR* 2)
                              (FEXPR* 3)
                              NIL)))
                (CLOSURE 2)
                (COMPILED-CLOSURE (\CCODEARGTYPE (fetch
 (COMPILED-CLOSURE FNHEADER) of
 DEF])

(NARGS

  [LAMBDA (FN)
                                               (* bvm: " 7-Jul-86 17:07")

    (LET ((DEF FN))
         (COND
            ([AND (LITATOM DEF)
                  (PROG1 (fetch
 (LITATOM CCODEP) of
 DEF)
                         (SETQ DEF (fetch
 (LITATOM DEFPOINTER) of
 DEF]
             (\CCODENARGS DEF))
            ((LISTP DEF)
             (SELECTQ (CAR DEF)
                 (CL:LAMBDA 1)
                 ([LAMBDA NLAMBDA OPENLAMBDA] 
                      (COND
                         ((NULL (SETQ DEF (CADR DEF)))
                          0)
                         ((NLISTP DEF)
                          1)
                         (T (in
 DEF sum
 1))))
                 (FUNARG (NARGS
 (CADR DEF)))
                 NIL))
            ((TYPEP DEF (QUOTE COMPILED-CLOSURE))
             (\CCODENARGS (fetch
 (COMPILED-CLOSURE FNHEADER) of
 DEF])

(ARGLIST

  [LAMBDA (FN)
                                               (* bvm: " 7-Jul-86 16:45")

    (PROG ((DEF FN)
           TEMP)
          [COND
             ((LITATOM DEF)
              (COND
                 ((PROG1 (fetch
 (LITATOM CCODEP) of
 DEF)
                         (SETQ DEF (fetch
 (LITATOM DEFPOINTER) of
 DEF)))
                  (RETURN (\CCODEARGLIST
 DEF)))
                 ((NULL DEF)
                  (SETQ DEF (GETPROP FN (QUOTE EXPR]
          [RETURN (COND
                     ((LISTP DEF)
                      (SELECTQ (CAR DEF)
                          (CL:LAMBDA (QUOTE U))
                          ([LAMBDA NLAMBDA OPENLAMBDA] 
                               (CADR DEF))
                          (FUNARG (ARGLIST
 (CADR DEF)))
                          (GO UNDEF)))
                     ((TYPEP DEF (QUOTE COMPILED-CLOSURE))
                      (\CCODEARGLIST
 (fetch
 (COMPILED-CLOSURE FNHEADER) of
 DEF)))
                     (T (GO UNDEF]
      UNDEF
          (COND
             ((AND (SETQ DEF (FNCHECK FN T))
                   (NEQ DEF FN))
              (RETURN (ARGLIST
 DEF)))
             (T (ERROR (QUOTE "Args not available:")
                       FN])

(\CCODEARGLIST

  [LAMBDA (FNHD SMARTP)
                                      (* bvm: "30-Jun-86 15:18")

    (PROG ((N (fetch
 (FNHEADER NA) of
 FNHD))
           IVARS SIZE LOCALSIZE ENDT)
          (COND
             ((ILESSP N 0)                                   (* LAMBDA*)

              (RETURN (QUOTE U)))
             ((EQ N 0)                                       (* No args)

              (RETURN NIL)))
          (SETQ SIZE (fetch
 (FNHEADER NTSIZE) of
 FNHD))
          [COND
             ((EQ [SETQ LOCALSIZE (IDIFFERENCE (FOLDLO (fetch
 (FNHEADER STARTPC) of
 FNHD)
                                                      BYTESPERWORD)
                                         (SETQ ENDT (IPLUS (fetch
 (FNHEADER OVERHEADWORDS)
                                                              of
 T)
                                                           (COND
                                                              ((EQ SIZE 0)
                                                             (* No nametable, but there's a quad of 

                                                             zeros there anyway)

                                                               WORDSPERQUAD)
                                                              (T (UNFOLD SIZE 2]
                  0)                                         (* Nothing extra here)

              )
             [(IGREATERP LOCALSIZE WORDSPERCELL)             (* There is a second nametable between 

                                                             the first and the code.)

              (SETQ IVARS (\CCODEIVARSCAN
 FNHD ENDT (FOLDLO LOCALSIZE 2]
             ([AND (LISTP (SETQ ENDT (\GETBASEPTR FNHD ENDT)))
                   (LISTP (SETQ ENDT (CAR ENDT]              (* It's exactly a pointer to debugging 

                                                             info, car of which is a stylized 

                                                             arglist)

                                                             (* Note that if we got this far, 

                                                             function is an nlambda spread, which 

                                                             means there can't be any &key or &rest)

              (RETURN (COND
                         (SMARTP ENDT)
                         (T (for
 X in
 ENDT unless
 (OR (EQ X (QUOTE &OPTIONAL))
                                                      (EQ X (QUOTE &INTERLISP)))
                               collect
 (COND
                                          ((STRINGP X)       (* Callers of ARGLIST are expecting to 

                                                             get something that would actually 

                                                             function as one)

                                           (MKATOM X))
                                          (T X]
          [COND
             ((NEQ SIZE 0)                                   (* Scan specials name table)

              (SETQ IVARS (\CCODEIVARSCAN
 FNHD (fetch
 (FNHEADER OVERHEADWORDS) of
 T)
                                 SIZE IVARS]
          [SETQ IVARS (for
 I from
 0 to
 (SUB1 N) collect
 (OR (CDR (ASSOC I IVARS))
                                                            (PACK* (QUOTE *ARG*)
                                                                   I]
          (RETURN (SELECTQ (fetch
 (FNHEADER ARGTYPE) of
 FNHD)
                      (3 (CAR IVARS))
                      IVARS])

(\CCODEIVARSCAN

  [LAMBDA (FNHD START SIZE IVARS)
                            (* bvm: "30-Jun-86 14:18")

          
          (* * Search nametable starting at offset START in FNHD for all ivars.

          Return list of dotted pairs (index . name) consed onto front of IVARS.

          NTSIZE is size of nt in words)


    (for
 (NTENTRY _ (\ADDBASE FNHD START)) by
 (\ADDBASE NTENTRY 1) bind
 NM CODE
       while
 (SETQ NM (\INDEXATOMVAL (\GETBASE NTENTRY 0)))
       do
                                                    (* Note that entry = 0 => NM = NIL 

                                                             terminates the loop)

          [COND
             ((EQ (LOGAND VARCODEMASK (SETQ CODE (\GETBASE NTENTRY SIZE)))
                  IVARCODE)
              (push
 IVARS (CONS (IDIFFERENCE CODE IVARCODE)
                                NM] finally
 (RETURN IVARS])
)



(* Translation machinery for new LAMBDA words)



(PUTPROPS LAMBDATRANFNS VARTYPE
 ALIST)

(ADDTOVAR LAMBDATRANFNS
 )
(DECLARE: DONTCOPY 
(DECLARE: EVAL@COMPILE 

(PUTPROPS \CCODENARGS MACRO ((FNH)
                             ((LAMBDA (N)
                                     (COND ((ILESSP N 0)
                                            1)
                                           (T N)))
                              (fetch (FNHEADER NA)
                                     of FNH))))
(PUTPROPS \CCODEFNTYP MACRO ((FNH)
                             (SELECTQ (\CCODEARGTYPE FNH)
                                    (0 (QUOTE CEXPR))
                                    (1 (QUOTE CFEXPR))
                                    (2 (QUOTE CEXPR*))
                                    (QUOTE CFEXPR*))))
(PUTPROPS \CCODEARGTYPE MACRO ((FNH)
                               (fetch (FNHEADER ARGTYPE)
                                      of FNH)))
)
)



(* proclaim and friends - needs to come first because DEFVARs put it out)


(DEFUN PROCLAIM
 (PROCLAMATION) 
          
          (* PROCLAIM is a top-level form used to pass assorted information to the 

          compiler. This interpreter ignores proclamations except for those declaring 

          variables to be SPECIAL. *)

 (COND
    ((LISTP PROCLAMATION)
     (SELECTQ (CAR PROCLAMATION)
         (SPECIAL (for
 X in
 (CDR PROCLAMATION) do
 (SETF (VARIABLE-GLOBALLY-SPECIAL-P X)
                                                        T)))
         (GLOBAL (for
 X in
 (CDR PROCLAMATION) do
 (SETF (VARIABLE-GLOBAL-P X)
                                                       T)))
         NIL))))




(* used by the codewalker, too)





(* AND BY PACKAGE CODE (\, WHICH) IS IN THE INIT (\, WHICH) IS WHY THIS IS HERE RATHER THAN IN 
CMLEVEL.)


(DECLARE: EVAL@COMPILE 

(PUTPROPS VARIABLE-GLOBALLY-SPECIAL-P MACRO ((VARIABLE)
                                             (GET VARIABLE (QUOTE GLOBALLY-SPECIAL))))
(PUTPROPS VARIABLE-GLOBAL-P MACRO ((VARIABLE)
                                   (GET VARIABLE (QUOTE GLOBALVAR))))
)
(DEFUN SPECIAL-FORM-P
 (X) (GET X (QUOTE SPECIAL-FORM)))


(PUTPROPS LLINTERP FILETYPE
 COMPILE-FILE)
(DECLARE: EVAL@COMPILE DONTCOPY 

(ADDTOVAR LAMS
 FAULTEVAL FAULTAPPLY)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 PROG1 COND PROGN OR AND QUOTE GO PROG SETN SETQ)

(ADDTOVAR NLAML
 FUNCTION RETURN)

(ADDTOVAR LAMA
 APPLY* \INTERPRETER)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(SPECVARS *TAIL* *FN* *FORM* *ARGVAL* *ARGVAL1* *ARGVAL2*)
)
(PUTPROPS LLINTERP COPYRIGHT ("Xerox Corporation" T 1981 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (4433 25515 (\INTERPRETER 4443 . 8770) (\INTERPRETER1 8772 . 15024) (
\SETUP-COMPILED-CLOSURE-CALL 15026 . 24912) (\STKNAME 24914 . 25513)) (25550 34388 (EVAL 25560 . 25711
) (\EVAL 25713 . 26001) (\EVALFORM 26003 . 28439) (\EVALFORMASLAMBDA 28441 . 28729) (\EVALOTHER 28731
 . 29244) (APPLY 29246 . 29400) (APPLY* 29402 . 31820) (\CHECKAPPLY* 31822 . 33482) (\CKAPPLYARGS 
33484 . 34004) (DEFEVAL 34006 . 34386)) (36629 47041 (EVALV 36639 . 36988) (\EVALV1 36990 . 37255) (
\EVALVAR 37257 . 38111) (BOUNDP 38113 . 38964) (SET 38966 . 39579) (\SETVAR 39581 . 40198) (SETQ 40200
 . 40855) (SETN 40857 . 41516) (\STKSCAN 41518 . 45258) (\SETFVARSLOT 45260 . 47039)) (47071 60055 (
PROG 47081 . 49309) (\PROG0 49311 . 53052) (\EVPROG1 53054 . 53410) (RETURN 53412 . 54296) (GO 54298
 . 56005) (EVALA 56007 . 57412) (\EVALA 57414 . 59918) (ERRORSET 59920 . 60053)) (60056 62991 (QUOTE 
60066 . 60102) (AND 60104 . 60474) (OR 60476 . 60947) (PROGN 60949 . 61473) (COND 61475 . 62137) (
\EVPROGN 62139 . 62492) (PROG1 62494 . 62989)) (63046 69276 (ENVEVAL 63056 . 63386) (ENVAPPLY 63388 . 
63719) (FUNCTION 63721 . 64050) (\FUNCT1 64052 . 66255) (\MAKEFUNARGFRAME 66257 . 67852) (STKEVAL 
67854 . 68050) (STKAPPLY 68052 . 68278) (RETEVAL 68280 . 68775) (RETAPPLY 68777 . 69274)) (69320 76791
 (BLIPVAL 69330 . 73098) (SETBLIPVAL 73100 . 75965) (BLIPSCAN 75967 . 76789)) (76792 79807 (
DUMMYFRAMEP 76802 . 76946) (REALFRAMEP 76948 . 77307) (REALSTKNTH 77309 . 78345) (\REALFRAMEP 78347 . 
79805)) (80195 98624 (RAIDCOMMAND 80205 . 88520) (RAIDSHOWFRAME 88522 . 89198) (RAIDSTACKCMD 89200 . 
91976) (RAIDROOTFRAME 91978 . 92461) (PRINTADDRS 92463 . 93348) (PRINTVA 93350 . 93565) (READVA 93567
 . 93722) (READATOM 93724 . 93877) (READOCT 93879 . 95491) (SHOWSTACKBLOCKS 95493 . 97828) (
SHOWSTACKBLOCK1 97830 . 98035) (PRINCOPY 98037 . 98256) (NOSUCHATOM 98258 . 98622)) (98625 107921 (
BACKTRACE 98635 . 99178) (\BACKTRACE 99180 . 101351) (\SCANFORNTENTRY 101353 . 102181) (\PRINTSTK 
102183 . 102439) (\PRINTFRAME 102441 . 106631) (\PRINTBF 106633 . 107919)) (110651 121661 (CCODEP 
110661 . 111210) (EXPRP 111212 . 111683) (SUBRP 111685 . 111800) (FNTYP 111802 . 113355) (ARGTYPE 
113357 . 114867) (NARGS 114869 . 115787) (ARGLIST 115789 . 117040) (\CCODEARGLIST 117042 . 120722) (
\CCODEIVARSCAN 120724 . 121659)))))
STOP