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

(FILECREATED "16-Dec-2020 09:23:58" 
|{DSK}<home>larry>ilisp>medley>internal>test>Maiko>ARs>STACKHAX.;1|
 4329   

      |previous| |date:| "15-Nov-88 17:16:48" {ERIS}<TEST>MAIKO>STACKHAX.\;4)


; Copyright (c) 1988, 2020 by I.  All rights reserved.

(PRETTYCOMPRINT STACKHAXCOMS)

(RPAQQ STACKHAXCOMS
 ((FNS CHECKSTACKSPACE)))
(DEFINEQ

(CHECKSTACKSPACE

  (LAMBDA (START)
                                     (* \; "Edited 16-Dec-2020 09:22 by larry")

                                                             (* \; "Edited 15-Nov-88 16:55 by jds")

    (PROG ((SCANPTR (OR START (|fetch|
 |StackBase| |of|
 |\\InterfacePage|)))
           (EASP (|fetch|
 |EndOfStack| |of|
 |\\InterfacePage|))
           (*PRINT-LEVEL* 2)
           (*PRINT-LENGTH* 2))
      SCAN
          (SELECTC (|fetch|
 (STK FLAGS) |of|
 SCANPTR)
              (\\STK.FSB (CL:FORMAT T "~6o Free Block~%" SCANPTR)
                         (COND
                            ((ZEROP (|fetch|
 (FSB SIZE) |of|
 SCANPTR))
                             (HELP "FSB size 0 at " SCANPTR)))
                         (|add|
 SCANPTR (|fetch|
 (FSB SIZE) |of|
 SCANPTR)))
              (\\STK.GUARD (CL:FORMAT T "~6o Guard Block~%" SCANPTR)
                           (COND
                              ((EQ SCANPTR EASP)
                               (RETURN T)))

                           (* |;;| "Guard block not at end of stack, treat as a free block:")


                           (COND
                              ((ZEROP (|fetch|
 (FSB SIZE) |of|
 SCANPTR))
                               (HELP "Guard block size 0 at " SCANPTR)))
                           (|add|
 SCANPTR (|fetch|
 (FSB SIZE) |of|
 SCANPTR))
                                                             (* \; "reached end")

                           )
              (\\STK.FX                                      (* \; "frame extension")

                        (CL:FORMAT T "~6o Frame Extn (use ~D) for ~S~%" SCANPTR (FETCH

                                                                                 (FX USECNT)
                                                                                   OF
 SCANPTR)
                               (|fetch|
 (FNHEADER FRAMENAME) |of|
 (|fetch|
 (FX FNHEADER)
                                                                             |of|
 SCANPTR)))
                        (OR (|fetch|
 (FX CHECKED) |of|
 SCANPTR)
                            (HELP (CL:FORMAT T "       FX not CHECKED at ~O.~%" SCANPTR)))
                        (COND
                           ((EQUAL (|fetch|
 (FX NEXTBLOCK) |of|
 SCANPTR)
                                   SCANPTR)
                            (HELP (CL:FORMAT T "       FX's NEXTBLOCK points to itself at ~O.~%" 
                                         SCANPTR))))
                        (SETQ SCANPTR (|fetch|
 (FX NEXTBLOCK) |of|
 SCANPTR)))
              (LET ((ORIG SCANPTR))                          (* \; "must be a basic frame")

                   (|until|
 (|type?|
 BF SCANPTR)
                      |do|
 (OR (EQ (|fetch|
 (STK FLAGS) |of|
 SCANPTR)
                                       \\STK.NOTFLAG)
                                   (HELP (CL:FORMAT T 
                                                "       Non-zero flags in a non-BF word at ~O.~%" 
                                                SCANPTR)))
                            (|add|
 SCANPTR WORDSPERCELL))
                   (CL:FORMAT T "~6o Basic Frame~%" SCANPTR)
                   (OR (COND
                          ((|fetch|
 (BF RESIDUAL) |of|
 SCANPTR)
                           (EQ SCANPTR ORIG))
                          (T (AND (|fetch|
 (BF CHECKED) |of|
 SCANPTR)
                                  (EQ ORIG (|fetch|
 (BF IVAR) |of|
 SCANPTR)))))
                       (CL:FORMAT T "       Bad basic frame at ~O.~%" SCANPTR))
                   (|add|
 SCANPTR WORDSPERCELL)))
      NEXT
          (OR (ILEQ SCANPTR EASP)
              (HELP "SCANPTR got beyond EASP"))
          (GO SCAN))))
)
(PUTPROPS STACKHAX COPYRIGHT ("I" 1988 2020))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (402 4260 (CHECKSTACKSPACE 412 . 4258)))))
STOP