  -*- Mode : LISP ; Package : SYSTEM - INTERNALS ;  : CL ;  -*-

  this code has been modified for the new one - q - forward instead of
  external - value - cell - pointer in fefs . it will only run in systems > = 121
;;;

(DEFUN FORWARD-VARIABLE-TO-A-MEMORY (SYMBOL LOCATION)
  ;; usually an a-mem location like this is fixed at cold load time.
  ;; so this function is used only when experimenting with new microcodes
  ;; in an old system.
  (LET ((A-MEM-LOC (COND ((FIXP LOCATION)
                          LOCATION)
                         ('ELSE
                          (LAM:ASSURE-LAM-SYMBOLS-LOADED)
                          (- (OR (lam:lam-lookup-name (INTERN (STRING LOCATION) "LAM"))
                                 (FERROR NIL "SYMBOL NOT FOUND: ~S" LOCATION))
                             LAM:RAAMO)))))
    (%P-STORE-TAG-AND-POINTER (+ A-MEM-LOC SYS:A-MEMORY-VIRTUAL-ADDRESS)
                              (%DATA-TYPE (SYMEVAL SYMBOL))
                              (SYMEVAL SYMBOL))
    (%P-STORE-TAG-AND-POINTER (VALUE-CELL-LOCATION SYMBOL)
                              DTP-ONE-Q-FORWARD
                              (+ A-MEM-LOC SYS:A-MEMORY-VIRTUAL-ADDRESS)))
  SYMBOL)


(DEFUN ALLOCATE-INDEX (TYPE)
  (COND ((GETHASH TYPE *INDEX-ALLOCATION-TABLE*)
         (FERROR NIL "ALREADY HAVE INDEX FOR ~S" TYPE))
        ('ELSE
         (GET-INDEX TYPE))))

;; WE KEEP THE INDEX CELL-ARRAYS AS SIMPLE UNFORWARDED ARRAYS FOR EFFICIENCY.

(DEFUN GET-INDEX (TYPE)
  "Type is a cell specification, e.g. (:function foo) for the function cell of foo, (:plist bar)"
  (CHECK-ARG TYPE (AND (CONSP TYPE)
                       (MEMQ (CAR TYPE) '(:FUNCTION :VALUE :PLIST))
                       (SYMBOLP (CADR TYPE)))
             "a legal cell type specification")
  (LET ((INDEX (GETHASH TYPE *INDEX-ALLOCATION-TABLE*)))
    (COND (INDEX)
          ('ELSE
           (WITH-LOCK ((GET 'GET-INDEX 'LOCK))
             (SETQ INDEX *INDEX-UNALLOCATED*)
             (PUTHASH TYPE INDEX *INDEX-ALLOCATION-TABLE*)
             (UNLESS (< INDEX (ARRAY-LENGTH *INDEX-NAME-TABLE*))
               (LET ((OLD *INDEX-NAME-TABLE*)
                     (N (ARRAY-LENGTH *INDEX-NAME-TABLE*)))
                 (SETQ *INDEX-NAME-TABLE* (MAKE-ARRAY (* 2 N)))
                 (COPY-ARRAY-PORTION OLD 0 N
                                     *INDEX-NAME-TABLE* 0 N)))
             (SETF (AREF *INDEX-NAME-TABLE* INDEX) TYPE)
             (DOLIST (A *CELL-ARRAYS*)
               (UNLESS (< INDEX (ARRAY-LENGTH (CELL-PLACE.ARRAY A)))
                 (GROW-CELL-ARRAY A)))
             (SETQ *INDEX-UNALLOCATED* (1+ INDEX))
             INDEX)))))




(DEFUN GROW-CELL-ARRAY (A)
  (LET ((OLD (CELL-PLACE.ARRAY A))
        (N (ARRAY-LENGTH (CELL-PLACE.ARRAY A))))
    (SETF (CELL-PLACE.ARRAY A) (MAKE-ARRAY (* 2 N)))
    ;; THIS IS USED INSTEAD OF COPY-ARRAY-PORTION
    ;; BECAUSE OF THE UNBOUND MARKERS (DTP-NULL'S) IN THE
    ;; ARRAY.
    (%BLT-TYPED (%POINTER-PLUS OLD
                               (ARRAY-DATA-OFFSET OLD))
                (%POINTER-PLUS (CELL-PLACE.ARRAY A)
                               (ARRAY-DATA-OFFSET (CELL-PLACE.ARRAY A)))
                N
                1)
    (WHEN (EQ OLD *INDEXED-CELL-ARRAY*)
      (SETQ *INDEXED-CELL-ARRAY* (CELL-PLACE.ARRAY A)))
    (WHEN (EQ OLD *GLOBAL-INDEXED-CELL-ARRAY*)
      (SETQ *GLOBAL-INDEXED-CELL-ARRAY* (CELL-PLACE.ARRAY A))))
  A)


(DEFUN DE (&OPTIONAL (N *INDEX-UNALLOCATED*))
  (FORMAT T "~&~D ALLOCATED INDEX NUMBERS~%" *INDEX-UNALLOCATED*)
  (DOTIMES (J N)
    (FORMAT T "~D = ~S ~:[un~]bound~%" J
            (AREF *INDEX-NAME-TABLE* J)
            (location-boundp (locf (aref *indexed-cell-array* j))))))

(DEFUN NEW-INDEXED-CELL-ARRAY ()
  "RETURN A COPY OF THE GLOBAL INDEXED CELL ARRAY"
  (LET ((A (COPY-OBJECT *GLOBAL-INDEXED-CELL-ARRAY*)))
    (PUSH (MAKE-CELL-PLACE :ARRAY A) *CELL-ARRAYS*)
    A))

(DEFUN FLUSH-INDEXED-CELL-ARRAY (A)
  (SETQ *CELL-ARRAYS* (DELQ A *CELL-ARRAYS*)))


(DEFUN STORE-INDEXED-FORWARD (POINTER INDEX)
  (%P-STORE-TAG-AND-POINTER POINTER DTP-INDEXED-FORWARD INDEX))

(DEFUN INDEXIFY-SYMBOL-CELLS (SYMBOL)
  (INDEXIFY-SYMBOL-CELLS-1 SYMBOL #'ALLOCATE-INDEX))

(DEFUN RE-INDEXIFY-SYMBOL-CELLS (SYMBOL)
  (INDEXIFY-SYMBOL-CELLS-1 SYMBOL #'GET-INDEX))

(DEFUN INDEXIFY-SYMBOL-CELLS-1 (SYMBOL ALLOCATE-INDEX)
  (LET ((V-I (FUNCALL ALLOCATE-INDEX `(:VALUE ,SYMBOL)))
        (F-I (FUNCALL ALLOCATE-INDEX `(:FUNCTION ,SYMBOL)))
        (P-I (FUNCALL ALLOCATE-INDEX `(:PLIST ,SYMBOL))))
    (LET* ((VP (BOUNDP SYMBOL))
           (V (IF VP (SYMEVAL SYMBOL)))
           (FP (FBOUNDP SYMBOL))
           (F (IF FP (FSYMEVAL SYMBOL)))
           (P (PLIST SYMBOL)))
      (DOLIST (CP *CELL-ARRAYS*)
        (LET ((A (CELL-PLACE.ARRAY CP)))
          (COND (VP
                 (SETF (AREF A V-I) V))
                ('ELSE
                 (LOCATION-MAKUNBOUND (LOCF (AREF A V-I)) SYMBOL)))
          (COND (FP
                 (SETF (AREF A F-I) F))
                ('ELSE
                 (LOCATION-MAKUNBOUND (LOCF (AREF A F-I)) SYMBOL)))
          (SETF (AREF A P-I) (COPY-LIST P)))))
    (STORE-INDEXED-FORWARD (LOCF (SYMBOL-VALUE SYMBOL)) V-I)
    (STORE-INDEXED-FORWARD (LOCF (SYMBOL-FUNCTION SYMBOL)) F-I)
    (STORE-INDEXED-FORWARD (LOCF (SYMBOL-PLIST SYMBOL)) P-I)
    SYMBOL))

(DEFUN PKG-INTERN-AND-INDEXIFY-STORE (HASH SYM PKG)
  (MULTIPLE-VALUE-BIND (SYMBOL ALREADY-INTERNED-FLAG ACTUAL-PACKAGE)
      (PKG-INTERN-STORE HASH SYM PKG)
    (WHEN (EQ (SYMBOL-PACKAGE SYMBOL) PKG)
      (INDEXIFY-SYMBOL-CELLS SYMBOL))
    (VALUES SYMBOL ALREADY-INTERNED-FLAG ACTUAL-PACKAGE)))


(DEFUN SET-PACKAGE-AUTO-INDEXIFY (PKG)
  (CHECK-TYPE PKG PACKAGE)
  (SETF (PKG-NEW-SYMBOL-FUNCTION PKG) 'PKG-INTERN-AND-INDEXIFY-STORE)
  (MAPATOMS #'(LAMBDA (X)
                (WHEN (EQ (SYMBOL-PACKAGE X) PKG)
                  (INDEXIFY-SYMBOL-CELLS X)))
            PKG
            NIL)
  PKG)



(DEFUN ASSOCIATED-INDEXED-CELL-ARRAY (X &OPTIONAL COPIER-FUNCTION)
  (OR (CDR (ASSQ X *ASSOCIATED-INDEXED-CELL-ARRAYS*))
      (LET ((A (NEW-INDEXED-CELL-ARRAY))
            (COPIER (OR COPIER-FUNCTION #'TOP-LEVEL-CELL-VALUE-COPIER)))
        (PUSH (CONS X A) *ASSOCIATED-INDEXED-CELL-ARRAYS*)
        (DOTIMES (J *INDEX-UNALLOCATED*)
          (LET ((LOC (LOCF (AREF A J))))
            (WHEN (LOCATION-BOUNDP LOC)
              (LET ((VALUE (CONTENTS LOC)))
                (SETF (CONTENTS LOC) (FUNCALL COPIER VALUE (AREF *INDEX-NAME-TABLE* J)))))))
        A)))


(DEFUN TOP-LEVEL-CELL-VALUE-COPIER (VALUE NAME)
  standard hacker . for example in  we know we have to copy the
  ;; toplevel of all list structures, and throw in arrays for good keeping.
  ;; anything not top level should have been copied into a pure area previously
  ;; for safe keeping.
  NAME
  SHOULD FIRST CHECK TO SEE IF VALUE IS IN A READ - ONLY AREA . THEN DONT BOTHER TO COPY IT .
  (COND ((CONSP VALUE)
         (COND ((CIRCULARP VALUE)
                VALUE)
               ('ELSE
                (COPYLIST VALUE))))
        ((ARRAYP VALUE)
         (COPY-OBJECT VALUE))
        ('ELSE
  CONSIDER ALL OTHER ATOMS . E.G. PATHNAMES , FEF 'S , SYMBOLS
  AS NOT NEEDING TO BE COPIED .
         VALUE)))

(DEFUN CIRCULARP (X)
  (DO ((L1 X (CDR L1))
       (L2 (CDR X) (CDDR L2)))
      ((ATOM L2)
       ())
    (IF (EQ L1 L2) (RETURN T))))


(defun map-fef-exit-vector-index (fef f)
  (CHECK-TYPE FEF COMPILED-FUNCTION)
  (DO ((I %FEF-HEADER-LENGTH (1+ I))
       (LIM (TRUNCATE (FEF-INITIAL-PC FEF) 2)))
      (( I LIM) NIL)
    (funcall f i)))



(DEFUN DESCRIBE-FEF-EXIT-VECTOR (FEF)
  (map-fef-exit-vector-index
    fef
    #'(lambda (i)
        (let ((dt (%p-ldb-offset %%Q-DATA-TYPE fef i)))
          (format t "~&~A(~D)~%" (nth dt q-data-types)
                  (%p-ldb-offset %%q-pointer fef i))))))


(DEFUN DESCRIBE-FEF-EXIT-VECTOR-2 (FEF)
  (map-fef-exit-vector-index
    fef
    #'(lambda (i)
        (let ((dt (%p-ldb-offset %%Q-DATA-TYPE fef i))
              (n  (%p-ldb-offset %%q-pointer fef i)))
          (format t "~&~A(~D)" (nth dt q-data-types) n)
          (cond ((= dt dtp-one-q-forward)
                 (let* ((loc (%P-CONTENTS-AS-LOCATIVE-OFFSET FEF i))
                        (ptr (%find-structure-header loc))
                        (offset (%POINTER-DIFFERENCE loc PTR)))
                   (cond ((symbolp ptr)
                          (format t " ~A cell of ~S (is ~A)~%"
                                  (nth offset '("??" "value" "function" "plist" "package"))
                                  ptr
                                  (nth (%p-data-type loc) q-data-types)))
                         ('else
                          (terpri)))))
                ((= dt dtp-indexed-forward)
                 (format t "~S~%" (aref *index-name-table* n)))
                ('else
                 (terpri)))))))

(DEFUN RELINK-FEF-EXIT-VECTOR (OBJ)
  (RELINK-FEF-EXIT-VECTOR-INTERNAL (TYPECASE OBJ
                                     (CONS
                                      (CASE (CAR OBJ)
                                        (MACRO (CDR OBJ))
                                        (T (RETURN-FROM RELINK-FEF-EXIT-VECTOR NIL))))
                                     (COMPILED-FUNCTION OBJ)
                                     (T (RETURN-FROM RELINK-FEF-EXIT-VECTOR NIL)))))

(DEFUN RELINK-FEF-EXIT-VECTOR-INTERNAL (FEF)
  "Change all one-q-forwards that point to indexed symbols to dtp-index-forwards"
  (map-fef-exit-vector-index
    fef
    #'(lambda (i)
        (WHEN (= (%P-LDB-OFFSET %%Q-DATA-TYPE FEF I) DTP-ONE-Q-FORWARD)
          (let* ((loc (%P-CONTENTS-AS-LOCATIVE-OFFSET FEF i))
                 (ptr (%find-structure-header loc)))
            (when (and (symbolp ptr)
                       (= dtp-indexed-forward (%p-data-type loc)))
              (let ((%INHIBIT-READ-ONLY T))
                (%p-store-tag-and-pointer (%make-pointer-offset dtp-locative
                                                                fef
                                                                i)
                                          dtp-indexed-forward
                                          (%p-pointer loc)))))))))


(DEFUN UNLINK-FEF-EXIT-VECTOR (FEF)
  (map-fef-exit-vector-index
    fef
    #'(lambda (i)
        (when (= (%p-ldb-offset %%Q-DATA-TYPE fef i) dtp-indexed-forward)
          (let ((name (aref *index-name-table* (%p-ldb-offset %%q-pointer fef i))))
            (let ((%INHIBIT-READ-ONLY T))
              (%p-store-tag-and-pointer (%make-pointer-offset dtp-locative
                                                              fef
                                                              i)
                                        DTP-ONE-Q-FORWARD
                                        (%pointer-plus (cadr name)
                                                       (ecase (car name)
                                                         (:value 1)
                                                         (:function 2))))))))))

(defun relink-fefs-in-package (pkg)
  (mapatoms #'(lambda (sym)
                (when (fboundp sym)
                  (let ((f (fsymeval sym)))
                    (when (typep f 'compiled-function)
                      (relink-fef-exit-vector f)))))
            pkg
            nil))


(defun unlink-fefs-in-package (pkg)
  (mapatoms #'(lambda (sym)
                (when (fboundp sym)
                  (let ((f (fsymeval sym)))
                    (when (typep f 'compiled-function)
                      (unlink-fef-exit-vector f)))))
            pkg
            nil))



(defun sumarize-cell-array-data (&OPTIONAL PRINT-TYPES)
  (LET ((VALUES NIL)
        (FUNCTIONS NIL)
        (PLISTS 0))
    (DOTIMES (J *INDEX-UNALLOCATED*)
      (LET ((LOC (locf (aref *indexed-cell-array* j))))
        (WHEN (LOCATION-BOUNDP LOC)
          (CASE (CAR (AREF *INDEX-NAME-TABLE* J))
            (:PLIST
             (INCF PLISTS (FLOOR (LENGTH (CONTENTS LOC)) 2)))
            (:FUNCTION
             (LET ((TYPE (TYPE-OF (CONTENTS LOC))))
               (WHEN (MEMQ TYPE PRINT-TYPES)
                 (FORMAT T "~&~S = ~S~%"
                         (AREF *INDEX-NAME-TABLE* J)
                         (CONTENTS LOC)))
               (INCF (CDR (OR (ASSQ TYPE FUNCTIONS) (CAR (PUSH (CONS TYPE 0) FUNCTIONS)))))))
            (:VALUE
             (LET ((TYPE (TYPE-OF (CONTENTS LOC))))
               (WHEN (MEMQ TYPE PRINT-TYPES)
                 (FORMAT T "~&~S = ~S~%"
                         (AREF *INDEX-NAME-TABLE* J)
                         (CONTENTS LOC)))
               (INCF (CDR (OR (ASSQ TYPE VALUES)
                              (CAR (PUSH (CONS TYPE 0) VALUES)))))))))))
    (LIST :FUNCTION FUNCTIONS
          :PLIST PLISTS
          :VALUE VALUES)))


(DEFUN DE-SYM (X)
  (FORMAT T "~&~S has:~%" x)
  (dolist (c '((:value 1) (:function 2) (:plist 3)))
    (format t "~9S = ~S ~A(~D)~%"
            (car c)
            (gethash (list (car c) x) *index-allocation-table*)
            (nth (%p-data-type (%pointer-plus x (cadr c))) q-data-types)
            (%p-pointer (%pointer-plus x (cadr c))))))


(defun describe-fefs-in-package (pkg)
  (mapatoms #'(lambda (x)
                (when (and (fboundp x)
                           (typep (fsymeval x) 'compiled-function))
                  (format t "~&  ~A~%" x)
                  (describe-fef-exit-vector-2 (fsymeval x))))
            pkg
            nil))

  used by EH : TRANS - TRAP - DECODE

(defun IDENTIFY-LOCATIVE-TO-INDEX-CELL-ARRAY (locative)
  (DOLIST (A *CELL-ARRAYS*)
    (let* ((ar (CELL-PLACE.ARRAY A))
           (k (- (%pointer-difference locative ar)
                 (array-data-offset ar))))
      (WHEN (AND (NOT (< K 0))
                 (< K *INDEX-UNALLOCATED*))
        (return (car (aref *index-name-table* k)))))))

 Package : SYSTEM - INTERNALS ;  : CL ;  -*-

 usually an a-mem location like this is fixed at cold load time.
 so this function is used only when experimenting with new microcodes
 in an old system.
 WE KEEP THE INDEX CELL-ARRAYS AS SIMPLE UNFORWARDED ARRAYS FOR EFFICIENCY.
 THIS IS USED INSTEAD OF COPY-ARRAY-PORTION
 BECAUSE OF THE UNBOUND MARKERS (DTP-NULL'S) IN THE
 ARRAY.
 toplevel of all list structures, and throw in arrays for good keeping.
 anything not top level should have been copied into a pure area previously
 for safe keeping.

  this code has been modified for the new one - q - forward instead of
  external - value - cell - pointer in fefs . it will only run in systems > = 121

(DEFUN FORWARD-VARIABLE-TO-A-MEMORY (SYMBOL LOCATION)
  (LET ((A-MEM-LOC (COND ((FIXP LOCATION)
                          LOCATION)
                         ('ELSE
                          (LAM:ASSURE-LAM-SYMBOLS-LOADED)
                          (- (OR (lam:lam-lookup-name (INTERN (STRING LOCATION) "LAM"))
                                 (FERROR NIL "SYMBOL NOT FOUND: ~S" LOCATION))
                             LAM:RAAMO)))))
    (%P-STORE-TAG-AND-POINTER (+ A-MEM-LOC SYS:A-MEMORY-VIRTUAL-ADDRESS)
                              (%DATA-TYPE (SYMEVAL SYMBOL))
                              (SYMEVAL SYMBOL))
    (%P-STORE-TAG-AND-POINTER (VALUE-CELL-LOCATION SYMBOL)
                              DTP-ONE-Q-FORWARD
                              (+ A-MEM-LOC SYS:A-MEMORY-VIRTUAL-ADDRESS)))
  SYMBOL)


(DEFUN ALLOCATE-INDEX (TYPE)
  (COND ((GETHASH TYPE *INDEX-ALLOCATION-TABLE*)
         (FERROR NIL "ALREADY HAVE INDEX FOR ~S" TYPE))
        ('ELSE
         (GET-INDEX TYPE))))


(DEFUN GET-INDEX (TYPE)
  "Type is a cell specification, e.g. (:function foo) for the function cell of foo, (:plist bar)"
  (CHECK-ARG TYPE (AND (CONSP TYPE)
                       (MEMQ (CAR TYPE) '(:FUNCTION :VALUE :PLIST))
                       (SYMBOLP (CADR TYPE)))
             "a legal cell type specification")
  (LET ((INDEX (GETHASH TYPE *INDEX-ALLOCATION-TABLE*)))
    (COND (INDEX)
          ('ELSE
           (WITH-LOCK ((GET 'GET-INDEX 'LOCK))
             (SETQ INDEX *INDEX-UNALLOCATED*)
             (PUTHASH TYPE INDEX *INDEX-ALLOCATION-TABLE*)
             (UNLESS (< INDEX (ARRAY-LENGTH *INDEX-NAME-TABLE*))
               (LET ((OLD *INDEX-NAME-TABLE*)
                     (N (ARRAY-LENGTH *INDEX-NAME-TABLE*)))
                 (SETQ *INDEX-NAME-TABLE* (MAKE-ARRAY (* 2 N)))
                 (COPY-ARRAY-PORTION OLD 0 N
                                     *INDEX-NAME-TABLE* 0 N)))
             (SETF (AREF *INDEX-NAME-TABLE* INDEX) TYPE)
             (DOLIST (A *CELL-ARRAYS*)
               (UNLESS (< INDEX (ARRAY-LENGTH (CELL-PLACE.ARRAY A)))
                 (GROW-CELL-ARRAY A)))
             (SETQ *INDEX-UNALLOCATED* (1+ INDEX))
             INDEX)))))




(DEFUN GROW-CELL-ARRAY (A)
  (LET ((OLD (CELL-PLACE.ARRAY A))
        (N (ARRAY-LENGTH (CELL-PLACE.ARRAY A))))
    (SETF (CELL-PLACE.ARRAY A) (MAKE-ARRAY (* 2 N)))
    (%BLT-TYPED (%POINTER-PLUS OLD
                               (ARRAY-DATA-OFFSET OLD))
                (%POINTER-PLUS (CELL-PLACE.ARRAY A)
                               (ARRAY-DATA-OFFSET (CELL-PLACE.ARRAY A)))
                N
                1)
    (WHEN (EQ OLD *INDEXED-CELL-ARRAY*)
      (SETQ *INDEXED-CELL-ARRAY* (CELL-PLACE.ARRAY A)))
    (WHEN (EQ OLD *GLOBAL-INDEXED-CELL-ARRAY*)
      (SETQ *GLOBAL-INDEXED-CELL-ARRAY* (CELL-PLACE.ARRAY A))))
  A)


(DEFUN DE (&OPTIONAL (N *INDEX-UNALLOCATED*))
  (FORMAT T "~&~D ALLOCATED INDEX NUMBERS~%" *INDEX-UNALLOCATED*)
  (DOTIMES (J N)
    (FORMAT T "~D = ~S ~:[un~]bound~%" J
            (AREF *INDEX-NAME-TABLE* J)
            (location-boundp (locf (aref *indexed-cell-array* j))))))

(DEFUN NEW-INDEXED-CELL-ARRAY ()
  "RETURN A COPY OF THE GLOBAL INDEXED CELL ARRAY"
  (LET ((A (COPY-OBJECT *GLOBAL-INDEXED-CELL-ARRAY*)))
    (PUSH (MAKE-CELL-PLACE :ARRAY A) *CELL-ARRAYS*)
    A))

(DEFUN FLUSH-INDEXED-CELL-ARRAY (A)
  (SETQ *CELL-ARRAYS* (DELQ A *CELL-ARRAYS*)))


(DEFUN STORE-INDEXED-FORWARD (POINTER INDEX)
  (%P-STORE-TAG-AND-POINTER POINTER DTP-INDEXED-FORWARD INDEX))

(DEFUN INDEXIFY-SYMBOL-CELLS (SYMBOL)
  (INDEXIFY-SYMBOL-CELLS-1 SYMBOL #'ALLOCATE-INDEX))

(DEFUN RE-INDEXIFY-SYMBOL-CELLS (SYMBOL)
  (INDEXIFY-SYMBOL-CELLS-1 SYMBOL #'GET-INDEX))

(DEFUN INDEXIFY-SYMBOL-CELLS-1 (SYMBOL ALLOCATE-INDEX)
  (LET ((V-I (FUNCALL ALLOCATE-INDEX `(:VALUE ,SYMBOL)))
        (F-I (FUNCALL ALLOCATE-INDEX `(:FUNCTION ,SYMBOL)))
        (P-I (FUNCALL ALLOCATE-INDEX `(:PLIST ,SYMBOL))))
    (LET* ((VP (BOUNDP SYMBOL))
           (V (IF VP (SYMEVAL SYMBOL)))
           (FP (FBOUNDP SYMBOL))
           (F (IF FP (FSYMEVAL SYMBOL)))
           (P (PLIST SYMBOL)))
      (DOLIST (CP *CELL-ARRAYS*)
        (LET ((A (CELL-PLACE.ARRAY CP)))
          (COND (VP
                 (SETF (AREF A V-I) V))
                ('ELSE
                 (LOCATION-MAKUNBOUND (LOCF (AREF A V-I)) SYMBOL)))
          (COND (FP
                 (SETF (AREF A F-I) F))
                ('ELSE
                 (LOCATION-MAKUNBOUND (LOCF (AREF A F-I)) SYMBOL)))
          (SETF (AREF A P-I) (COPY-LIST P)))))
    (STORE-INDEXED-FORWARD (LOCF (SYMBOL-VALUE SYMBOL)) V-I)
    (STORE-INDEXED-FORWARD (LOCF (SYMBOL-FUNCTION SYMBOL)) F-I)
    (STORE-INDEXED-FORWARD (LOCF (SYMBOL-PLIST SYMBOL)) P-I)
    SYMBOL))

(DEFUN PKG-INTERN-AND-INDEXIFY-STORE (HASH SYM PKG)
  (MULTIPLE-VALUE-BIND (SYMBOL ALREADY-INTERNED-FLAG ACTUAL-PACKAGE)
      (PKG-INTERN-STORE HASH SYM PKG)
    (WHEN (EQ (SYMBOL-PACKAGE SYMBOL) PKG)
      (INDEXIFY-SYMBOL-CELLS SYMBOL))
    (VALUES SYMBOL ALREADY-INTERNED-FLAG ACTUAL-PACKAGE)))


(DEFUN SET-PACKAGE-AUTO-INDEXIFY (PKG)
  (CHECK-TYPE PKG PACKAGE)
  (SETF (PKG-NEW-SYMBOL-FUNCTION PKG) 'PKG-INTERN-AND-INDEXIFY-STORE)
  (MAPATOMS #'(LAMBDA (X)
                (WHEN (EQ (SYMBOL-PACKAGE X) PKG)
                  (INDEXIFY-SYMBOL-CELLS X)))
            PKG
            NIL)
  PKG)



(DEFUN ASSOCIATED-INDEXED-CELL-ARRAY (X &OPTIONAL COPIER-FUNCTION)
  (OR (CDR (ASSQ X *ASSOCIATED-INDEXED-CELL-ARRAYS*))
      (LET ((A (NEW-INDEXED-CELL-ARRAY))
            (COPIER (OR COPIER-FUNCTION #'TOP-LEVEL-CELL-VALUE-COPIER)))
        (PUSH (CONS X A) *ASSOCIATED-INDEXED-CELL-ARRAYS*)
        (DOTIMES (J *INDEX-UNALLOCATED*)
          (LET ((LOC (LOCF (AREF A J))))
            (WHEN (LOCATION-BOUNDP LOC)
              (LET ((VALUE (CONTENTS LOC)))
                (SETF (CONTENTS LOC) (FUNCALL COPIER VALUE (AREF *INDEX-NAME-TABLE* J)))))))
        A)))


(DEFUN TOP-LEVEL-CELL-VALUE-COPIER (VALUE NAME)
  standard hacker . for example in  we know we have to copy the
  NAME
  SHOULD FIRST CHECK TO SEE IF VALUE IS IN A READ - ONLY AREA . THEN DONT BOTHER TO COPY IT .
  (COND ((CONSP VALUE)
         (COND ((CIRCULARP VALUE)
                VALUE)
               ('ELSE
                (COPYLIST VALUE))))
        ((ARRAYP VALUE)
         (COPY-OBJECT VALUE))
        ('ELSE
  CONSIDER ALL OTHER ATOMS . E.G. PATHNAMES , FEF 'S , SYMBOLS
  AS NOT NEEDING TO BE COPIED .
         VALUE)))

(DEFUN CIRCULARP (X)
  (DO ((L1 X (CDR L1))
       (L2 (CDR X) (CDDR L2)))
      ((ATOM L2)
       ())
    (IF (EQ L1 L2) (RETURN T))))


(defun map-fef-exit-vector-index (fef f)
  (CHECK-TYPE FEF COMPILED-FUNCTION)
  (DO ((I %FEF-HEADER-LENGTH (1+ I))
       (LIM (TRUNCATE (FEF-INITIAL-PC FEF) 2)))
      (( I LIM) NIL)
    (funcall f i)))



(DEFUN DESCRIBE-FEF-EXIT-VECTOR (FEF)
  (map-fef-exit-vector-index
    fef
    #'(lambda (i)
        (let ((dt (%p-ldb-offset %%Q-DATA-TYPE fef i)))
          (format t "~&~A(~D)~%" (nth dt q-data-types)
                  (%p-ldb-offset %%q-pointer fef i))))))


(DEFUN DESCRIBE-FEF-EXIT-VECTOR-2 (FEF)
  (map-fef-exit-vector-index
    fef
    #'(lambda (i)
        (let ((dt (%p-ldb-offset %%Q-DATA-TYPE fef i))
              (n  (%p-ldb-offset %%q-pointer fef i)))
          (format t "~&~A(~D)" (nth dt q-data-types) n)
          (cond ((= dt dtp-one-q-forward)
                 (let* ((loc (%P-CONTENTS-AS-LOCATIVE-OFFSET FEF i))
                        (ptr (%find-structure-header loc))
                        (offset (%POINTER-DIFFERENCE loc PTR)))
                   (cond ((symbolp ptr)
                          (format t " ~A cell of ~S (is ~A)~%"
                                  (nth offset '("??" "value" "function" "plist" "package"))
                                  ptr
                                  (nth (%p-data-type loc) q-data-types)))
                         ('else
                          (terpri)))))
                ((= dt dtp-indexed-forward)
                 (format t "~S~%" (aref *index-name-table* n)))
                ('else
                 (terpri)))))))

(DEFUN RELINK-FEF-EXIT-VECTOR (OBJ)
  (RELINK-FEF-EXIT-VECTOR-INTERNAL (TYPECASE OBJ
                                     (CONS
                                      (CASE (CAR OBJ)
                                        (MACRO (CDR OBJ))
                                        (T (RETURN-FROM RELINK-FEF-EXIT-VECTOR NIL))))
                                     (COMPILED-FUNCTION OBJ)
                                     (T (RETURN-FROM RELINK-FEF-EXIT-VECTOR NIL)))))

(DEFUN RELINK-FEF-EXIT-VECTOR-INTERNAL (FEF)
  "Change all one-q-forwards that point to indexed symbols to dtp-index-forwards"
  (map-fef-exit-vector-index
    fef
    #'(lambda (i)
        (WHEN (= (%P-LDB-OFFSET %%Q-DATA-TYPE FEF I) DTP-ONE-Q-FORWARD)
          (let* ((loc (%P-CONTENTS-AS-LOCATIVE-OFFSET FEF i))
                 (ptr (%find-structure-header loc)))
            (when (and (symbolp ptr)
                       (= dtp-indexed-forward (%p-data-type loc)))
              (let ((%INHIBIT-READ-ONLY T))
                (%p-store-tag-and-pointer (%make-pointer-offset dtp-locative
                                                                fef
                                                                i)
                                          dtp-indexed-forward
                                          (%p-pointer loc)))))))))


(DEFUN UNLINK-FEF-EXIT-VECTOR (FEF)
  (map-fef-exit-vector-index
    fef
    #'(lambda (i)
        (when (= (%p-ldb-offset %%Q-DATA-TYPE fef i) dtp-indexed-forward)
          (let ((name (aref *index-name-table* (%p-ldb-offset %%q-pointer fef i))))
            (let ((%INHIBIT-READ-ONLY T))
              (%p-store-tag-and-pointer (%make-pointer-offset dtp-locative
                                                              fef
                                                              i)
                                        DTP-ONE-Q-FORWARD
                                        (%pointer-plus (cadr name)
                                                       (ecase (car name)
                                                         (:value 1)
                                                         (:function 2))))))))))

(defun relink-fefs-in-package (pkg)
  (mapatoms #'(lambda (sym)
                (when (fboundp sym)
                  (let ((f (fsymeval sym)))
                    (when (typep f 'compiled-function)
                      (relink-fef-exit-vector f)))))
            pkg
            nil))


(defun unlink-fefs-in-package (pkg)
  (mapatoms #'(lambda (sym)
                (when (fboundp sym)
                  (let ((f (fsymeval sym)))
                    (when (typep f 'compiled-function)
                      (unlink-fef-exit-vector f)))))
            pkg
            nil))



(defun sumarize-cell-array-data (&OPTIONAL PRINT-TYPES)
  (LET ((VALUES NIL)
        (FUNCTIONS NIL)
        (PLISTS 0))
    (DOTIMES (J *INDEX-UNALLOCATED*)
      (LET ((LOC (locf (aref *indexed-cell-array* j))))
        (WHEN (LOCATION-BOUNDP LOC)
          (CASE (CAR (AREF *INDEX-NAME-TABLE* J))
            (:PLIST
             (INCF PLISTS (FLOOR (LENGTH (CONTENTS LOC)) 2)))
            (:FUNCTION
             (LET ((TYPE (TYPE-OF (CONTENTS LOC))))
               (WHEN (MEMQ TYPE PRINT-TYPES)
                 (FORMAT T "~&~S = ~S~%"
                         (AREF *INDEX-NAME-TABLE* J)
                         (CONTENTS LOC)))
               (INCF (CDR (OR (ASSQ TYPE FUNCTIONS) (CAR (PUSH (CONS TYPE 0) FUNCTIONS)))))))
            (:VALUE
             (LET ((TYPE (TYPE-OF (CONTENTS LOC))))
               (WHEN (MEMQ TYPE PRINT-TYPES)
                 (FORMAT T "~&~S = ~S~%"
                         (AREF *INDEX-NAME-TABLE* J)
                         (CONTENTS LOC)))
               (INCF (CDR (OR (ASSQ TYPE VALUES)
                              (CAR (PUSH (CONS TYPE 0) VALUES)))))))))))
    (LIST :FUNCTION FUNCTIONS
          :PLIST PLISTS
          :VALUE VALUES)))


(DEFUN DE-SYM (X)
  (FORMAT T "~&~S has:~%" x)
  (dolist (c '((:value 1) (:function 2) (:plist 3)))
    (format t "~9S = ~S ~A(~D)~%"
            (car c)
            (gethash (list (car c) x) *index-allocation-table*)
            (nth (%p-data-type (%pointer-plus x (cadr c))) q-data-types)
            (%p-pointer (%pointer-plus x (cadr c))))))


(defun describe-fefs-in-package (pkg)
  (mapatoms #'(lambda (x)
                (when (and (fboundp x)
                           (typep (fsymeval x) 'compiled-function))
                  (format t "~&  ~A~%" x)
                  (describe-fef-exit-vector-2 (fsymeval x))))
            pkg
            nil))

  used by EH : TRANS - TRAP - DECODE

(defun IDENTIFY-LOCATIVE-TO-INDEX-CELL-ARRAY (locative)
  (DOLIST (A *CELL-ARRAYS*)
    (let* ((ar (CELL-PLACE.ARRAY A))
           (k (- (%pointer-difference locative ar)
                 (array-data-offset ar))))
      (WHEN (AND (NOT (< K 0))
                 (< K *INDEX-UNALLOCATED*))
        (return (car (aref *index-name-table* k)))))))
