(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)

(FILECREATED "17-May-90 15:48:43" |{DSK}<usr>local>lde>lispcore>sources>STACKFNS.;2|
 6154   

      |changes| |to:|  (VARS STACKFNSCOMS)

      |previous| |date:| "30-Nov-86 17:10:26" |{DSK}<usr>local>lde>lispcore>sources>STACKFNS.;1|)


; Copyright (c) 1986, 1990 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT STACKFNSCOMS)

(RPAQQ STACKFNSCOMS
 ((FNS STKARGS MAPDL SEARCHPDL VARIABLES REALFRAMEP \\REALFRAMEP REALSTKNTH)
                         (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
                                (ADDVARS (NLAMA)
                                       (NLAML)
                                       (LAMA STKARGS)))))
(DEFINEQ

(STKARGS

  (CL:LAMBDA (POS)                                           (* |;;| 

                                                          " return the first NARGS  arguments at POS")

         (FOR
 I FROM
 1 TO
 (STKNARGS POS) COLLECT
 (STKARG I POS))))

(MAPDL

  (LAMBDA (MAPDLFN MAPDLPOS)
                                 (* |wt:| " 9-SEP-78 20:55")

    (PROG NIL
          (SETQ MAPDLPOS (COND
                            ((NULL MAPDLPOS)
                             (STKPOS 'MAPDL))
                            (SPAGHETTIFLG (STKNTH 0 MAPDLPOS))
                            (T MAPDLPOS)))
      LP  (COND
             ((NULL (SETQ MAPDLPOS (STKNTH -1 MAPDLPOS MAPDLPOS)))
              (RETURN NIL)))
          (APPLY* MAPDLFN (STKNAME MAPDLPOS)
                 MAPDLPOS)
          (GO LP))))

(SEARCHPDL

  (LAMBDA (SRCHFN SRCHPOS)                                   (* |Does| |not| |release| |or| |reuse| 

                                                             SRCHPOS)

    (PROG (SRCHX)
          (SETQ SRCHPOS (COND
                           ((NULL SRCHPOS)
                            (STKPOS 'SEARCHPDL))
                           (SPAGHETTIFLG (STKNTH 0 SRCHPOS))
                           (T SRCHPOS)))
      LP  (COND
             ((NULL (SETQ SRCHPOS (STKNTH -1 SRCHPOS SRCHPOS)))
              (RETURN NIL))
             ((APPLY* SRCHFN (SETQ SRCHX (STKNAME SRCHPOS))
                     SRCHPOS)
              (RETURN (CONS SRCHX SRCHPOS))))
          (GO LP))))

(VARIABLES

  (LAMBDA (POS)
    (PROG (N L)
          (SETQ N (STKNARGS POS))
      LP  (COND
             ((ZEROP N)
              (RETURN L)))
          (SETQ L (CONS (STKARGNAME N POS)
                        L))
          (SETQ N (SUB1 N))
          (GO LP))))

(REALFRAMEP

  (LAMBDA (POS INTERPFLG)
                                    (* |lmm| " 7-Nov-86 01:50")

          
          (* |;;| "Value is T if frame should be visible for backtrace, and error retry")

          
          (* |;;| "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)))

(\\REALFRAMEP

  (LAMBDA (FRAME INTERPFLG)
                                  (* |lmm| " 7-Nov-86 01:53")

    (LET ((NAME (|fetch|
 (FNHEADER FRAMENAME) |of|
 (|fetch|
 (FX FNHEADER) |of|
 FRAME)))
          BFLINK)
          
          (* |;;| "note that the selection is on the fnheader's name rather than the nametable name. \\REALFRAMEP is thus not affected by SETSTKNAME")


         (AND (CL:SYMBOLP NAME)
              (SELECTQ NAME
                  (*ENV*                                     (* \; "*ENV* is used by ENVEVAL etc.")

                         NIL)
                  (\\INTERPRETER T)
                  (ERRORSET (NEQ (\\STKARG 2 FRAME)
                                 'INTERNAL))
                  ((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))))))))))

(REALSTKNTH

  (LAMBDA (N POS INTERPFLG OLDPOS)
                           (* |amd| "11-Nov-86 12:03")

          
          (* |;;| "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))))
)
(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 STKARGS)
)
(PRETTYCOMPRINT STACKFNSCOMS)

(RPAQQ STACKFNSCOMS
 ((FNS STKARGS MAPDL SEARCHPDL VARIABLES REALFRAMEP \\REALFRAMEP REALSTKNTH)
                         (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS
                                                                                        (NLAMA)
                                                                                        (NLAML)
                                                                                        (LAMA)))))
(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 )
)
(PUTPROPS STACKFNS COPYRIGHT ("Venue & Xerox Corporation" 1986 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (762 5270 (STKARGS 772 . 1048) (MAPDL 1050 . 1604) (SEARCHPDL 1606 . 2306) (VARIABLES 
2308 . 2575) (REALFRAMEP 2577 . 3024) (\\REALFRAMEP 3026 . 4364) (REALSTKNTH 4366 . 5268)))))
STOP