vis-ftp.cs.umass.edu/vis-ftp.cs.umass.edu.tar/vis-ftp.cs.umass.edu/pub/Software/ASCENDER/ascendMar8.tar/UMass/ISR/isr2basics.lisp

Lisp/Scheme | 1995-04-11 | 97KB | 2,644 lines

;;; -*- Mode:Common-Lisp; Package:isr2; Base:10 -*-
;;;------------------------------------------------------------------------
;;; ISR2BASICS.LISP - Basic ISR2 functions
;;; Created: Monday the eleventh of April, 1988; 10:01:26 am
;;; Author: Robert Heller
;;;------------------------------------------------------------------------
;;; Copyright (c) University of Massachusetts 1988
;;;------------------------------------------------------------------------

(in-package "ISR2")

(export '(*set-value-flag* system-status clear-system frame parent handle path?
      token-index-of define-feature features create create-new-token destroy
      copy-definition move rename describe-isr-object datatypep datatype-of
      value add-feature-function))

(defvar *set-value-flag*)
(setf (documentation '*set-value-flag* 'variable)
"Flag used to disable/enable storage of feature values")

;; basic system global valiables

(#+:EXPLORER cdefvar #-:EXPLORER defvar *isr-frame-root*
      (make-frame "ROOT" :Documentation "ISR Root Frame")
     "Root frame in the database")

(defvar *undefinable-numeric-feature-return-value* -1
  "Value to be returned when a feature value in undefinable")

;;;;

(defun system-status (&optional (stream *standard-output*) &aux (*past-frames* nil))
  "SYSTEM-STATUS &OPTIONAL (stream *standard-output*) -
This function prints out the system status."
  (declare (special *past-frames*))
  (status-of-frame *isr-frame-root* stream 0))

(defmacro do-all-tokens ((index-var existence-vector) &body body)
  "This macro indexes through all token indexes (based on the size of the
existence vector)."
  (let ((outer-index (gensym))
    (existence-v (gensym))
    (inner-index (gensym))
    (vv-data     (gensym))
    )
    `(let* ((,existence-v ,existence-vector)
        (,index-var 0)
        (,vv-data (2index-vector-vector-data ,existence-v))
        )
       (dotimes (,outer-index (fill-pointer ,vv-data))
     (dotimes (,inner-index *default-2index-vector-size*)
       (progn ,@body)
       (incf ,index-var))))
    )
  )


(defmacro do-active-tokens ((index-var existence-vector) &body body)
  "This macro applys BODY to every defined token in existence-vector."
  (let ((outer-index (gensym))
    (temp-vector (gensym))
    (temp-inner-2index-vec (gensym))
    (existence-v (gensym))
    (inner-index (gensym))
    (vv-data     (gensym))
    )
    `(let* ((,existence-v ,existence-vector)
        (,index-var 0)
        (,temp-inner-2index-vec nil)
        (,temp-vector nil)
        (,vv-data (2index-vector-vector-data ,existence-v))
       )
       (dotimes (,outer-index (fill-pointer ,vv-data))
     (setf ,temp-inner-2index-vec (aref ,vv-data ,outer-index))
     (if ,temp-inner-2index-vec
         (progn
           (setf ,temp-vector (2index-vector-data-vector
                    ,temp-inner-2index-vec))
           (dotimes (,inner-index *default-2index-vector-size*)
            (when (= (aref ,temp-vector ,inner-index) 1)
              ,@body)
            (incf ,index-var)))
         (incf ,index-var *default-2index-vector-size*)))
       )
    )
  )


(#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun active-token-count (frame)
  "This function returns the number of active tokens."
  (let ((count 0))
    (do-active-tokens (tokindex (frame-token-set-existence-vector frame))
      (incf count))
    count))


(#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun total-token-count (frame)
  "This function retuns the total count of tokens."
  (* (fill-pointer (2index-vector-vector-data
             (frame-token-set-existence-vector frame)))
     *default-2index-vector-size*)
  )


(defun status-of-frame (frame stream level
            &aux (fill (make-string (* level 4) :initial-element #\space))
            )
  "This function prints out the status of a frame.  In the process it calls itself
recursively on any sub-frames it finds in either the frame features or the token
features."
  (declare (special *past-frames*))
  (when (and frame (not (member frame *past-frames*)))
    (push frame *past-frames*)
    (format stream "~&~AFrame at level ~D:~%" fill level)
    (format stream "~&~A  Name: ~A~%" fill (frame-name frame))
    (format stream "~&~A  Documentation: ~A~%" fill (frame-documentation frame))
    (format stream "~&~A  Source File(s): ~S~%" fill (frame-source-file-list frame))
    (format stream "~&~A  Tokens: ~D/~D~%" fill (active-token-count frame)
        (total-token-count frame))
    (map nil #'(lambda (feature-value-pair &aux fdescr fvalue)
         (setf fdescr (rest feature-value-pair)
               fvalue (fdescr-value fdescr))
         (format stream "~&~A  ~A (Type: ~A): ~S~%" fill
             (first feature-value-pair)
             (elt *type-names* (fdescr-type fdescr))
             (if (equalp fvalue
                     (case (fdescr-type fdescr)
                       (#.*int* *int-undefined*)
                       (#.*real* *real-undefined*)
                       (t *ptr-undefined*)))
                 '**UNCALCULATED**
                 fvalue))
         (when (and
             (= (fdescr-type fdescr)
                *handle*)
             (handle-p fvalue)
             (eq (handle-type fvalue) :frame))
           (status-of-frame (handle-frame fvalue) stream
                    (1+ level))
           (pushnew (handle-frame fvalue) *past-frames*)))
     (frame-feature-alist frame))
    (format stream "~&~A  ~D Token features~%" fill
        (length (frame-token-set-feature-vector
              frame)))
    (do-active-tokens (tokenindex (frame-token-set-existence-vector frame))
      (map nil
       #'(lambda (fdescr &aux (fvalue-vec (fdescr-value fdescr)))
           (when (= (fdescr-type fdescr)
            *handle*)
         (let ((token-value-handle (vvref fvalue-vec
                          tokenindex)))
           (when (and (handle-p token-value-handle)
                  (eq (handle-type token-value-handle) :frame))
             (format stream
                 "~&~A  Token ~d, Feature ~A (Type: Handle) ~S~%"
                 fill tokenindex (fdescr-featurename fdescr)
                 token-value-handle)
             (status-of-frame (handle-frame token-value-handle) stream
                      (1+ level)
                      )
             (pushnew (handle-frame token-value-handle) *past-frames*)))))
       (frame-token-set-feature-vector frame))
      )
    )
  )

(defun clear-system (&aux *past-frames*)
  "CLEAR-SYSTEM - This function flushes all known data in the system."
  (declare (special *past-frames*))
  (clear-frame *isr-frame-root*)
  (setf (frame-feature-alist *isr-frame-root*) nil)
  (setf (fill-pointer (2index-vector-vector-data
            (frame-token-set-existence-vector *isr-frame-root*)))
    0)
  (setf (frame-token-set-feature-vector *isr-frame-root*) nil)
  t)

(defun clear-frame (frame)
  "This function flushes a frame.  It also flushes any frames hanging below
this frame."
  (declare (special *past-frames*))
  (when (and frame (not (member frame *past-frames*)))
    (push frame *past-frames*)
    (map nil #'(lambda (feature-value-pair &aux fdescr fvalue)
         (setf fdescr (rest feature-value-pair)
               fvalue (fdescr-value fdescr))
         (when (and
             (= (fdescr-type fdescr)
                *handle*)
             (handle-p fvalue)
             (eq (handle-type fvalue) :frame))
           (clear-frame (handle-frame fvalue))
           (pushnew (handle-frame fvalue) *past-frames*)))
     (frame-feature-alist frame))
    (map nil
     #'(lambda (fdescr &aux (fvalue-vec (fdescr-value fdescr)))
         (do-active-tokens (tokenindex (frame-token-set-existence-vector frame))
           (let ((token-value-handle (vvref fvalue-vec
                        tokenindex)))
         (when (and (handle-p token-value-handle)
                (eq (handle-type token-value-handle) :frame))
           (clear-frame (handle-frame token-value-handle))
           (pushnew (handle-frame token-value-handle) *past-frames*))
         ))
         (with-lock ((2index-vector-vector-lock fvalue-vec))
           (let ((dv (2index-vector-vector-data fvalue-vec))
             temp)
         (dotimes (i (fill-pointer dv))
           (setf temp (aref dv i))
           (when temp
             (deallocate-resource (type-of temp) temp)))))
         )
     (frame-token-set-feature-vector frame))
    (let ((evv (frame-token-set-existence-vector frame)))
      (with-lock ((2index-vector-vector-lock evv))
    (let ((ev (2index-vector-vector-data evv))
          temp)
      (dotimes (i (fill-pointer ev))
        (setf temp (aref ev i))
        (when temp
          (deallocate-resource (type-of temp) temp))))))
    )
  )

(defun frame (handle)
  "FRAME handle - Return a frame handle of a handle."
  (unless (handle-p handle)
    (error "~S is not a handle!" handle))
  (if (eq (handle-type handle) :frame)
      handle
      (make-handle :type :frame :frame (handle-frame handle)))
  )

(defun %internal-handle (path &key (error-p t) (terminal-p nil) &aux parsed-path
           handle more-path)
  "%INTERNAL-HANDLE path &KEY (error-p t) (terminal-p nil) -
Return either a handle object of a list whose car is a handle object.  Try for
the maximum depth posible.  If error-p is non-NIL, raise an error if there is
a problem, else return NIL.  If terminal-p is non-NIL, check for a terminal
path."
  (setf parsed-path (parse-token-name path))
  (multiple-value-setq (handle more-path)
    (make-handle-from-parsed-path parsed-path))
  (if (null handle)
      (if error-p
      (error "~S is not a legitimate path!" path)
      nil)
      (if terminal-p
      (if (check-terminal-path handle more-path)
          (if more-path
          (cons handle more-path)
          handle)
          (if error-p
          (error "~S is not a terminal path!" path)
          nil))
      (if more-path
          (cons handle more-path)
          handle)
      )
      )
  )

(defun handle (path &key (error-p t) &aux handle)
  "HANDLE path &KEY (error-p t) -
Returns the handle for path.  If this is not posible, then either an error is signaled
(error-p non-NIL) or NIL is returned (error-p NIL). If the argument is already a handle,
then the handle returned is EQ to it."
  (when (handle-p path) (return-from handle path))
  (setf handle (%internal-handle path :terminal-p t :error-p nil))
  (if (handle-p handle)
      handle
      (if error-p
      (error "Cannot make ~S into a handle!" path)
      nil))
  )

(#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun path? (path)
  "PATH? path - returns T if path is a valid path to an existing object, NIL
otherwise."
  (not (null (handle path :error-p nil))))

(defun parent (path &aux parsed-path handle more-path)
  "PARENT path - Return the parent of a path."
  (setf parsed-path (parse-token-name path))
  (multiple-value-setq (handle more-path)
    (make-handle-from-parsed-path parsed-path))
  (if (and handle
       (check-terminal-path handle more-path)
       (not (eq (handle-frame handle) *isr-frame-root*)))
      (frame-parent (handle-frame handle))
      (error "~S is not a legitimate path!" path))
  )

(defun check-terminal-path (handle more-path)
  "Helper function: checks to be sure handle/more-path is a terminal
path.  That is there is not additional levels in more-path below the
path HANDLE represents."
  (cond ((null handle) nil)
    ((eq (handle-type handle) :frame)
     (cond ((null more-path) t)
           ((integerp (first more-path))
        (or (null (rest more-path))
            (and (stringp (second more-path))
             (or (null (rest (rest more-path)))
                 (and (stringp (third more-path))
                  (equalp (subseq (third more-path)
                          0 2)
                      "F_")
                  (null (rest (rest (rest more-path)))))))))
           ((stringp  (first more-path))
        (or (null (rest more-path))
            (and (stringp (second more-path))
             (equalp (subseq (second more-path)
                     0 2)
                 "F_")
             (null (rest (rest more-path))))))
           ((eq (first more-path) :?)
        (or (null (rest more-path))
            (and (stringp (second more-path))
             (or (null (rest (rest more-path)))
                 (and (stringp (third more-path))
                  (equalp (subseq (third more-path)
                          0 2)
                      "F_")
                  (null (rest (rest (rest more-path)))))))))
           (t nil)))
    ((or (eq (handle-type handle) :frame-feature)
         (eq (handle-type handle) :token-feature))
     (or (null more-path)
         (and (stringp (first more-path))
          (equalp (subseq (first more-path)
                  0 2)
              "F_")
          (null (rest more-path)))))
    ((eq (handle-type handle) :token)
     (or (null more-path)
         (and (stringp (first more-path))
          (not (equalp (subseq (first more-path)
                       0 2)
                   "F_"))
          (null (rest more-path)))))
    (t (null more-path))
    )
  )


(defun make-handle-from-parsed-path (parsed-path)
  "This function returns two values: the \"rightmost\" handle and the remaining
path in parsed-path."
  (cond ((null parsed-path) (values nil nil))
    ((handle-p (first parsed-path))
     (make-handle-from-parsed-path1
       (copy-handle (first parsed-path))
       (rest parsed-path)))
    ((stringp (first parsed-path))
     (if (string= (first parsed-path) "ROOT")
         (make-handle-from-parsed-path1
           (make-handle :type :frame
                :frame *isr-frame-root*)
           (rest parsed-path))
         (make-handle-from-parsed-path1
           (make-handle :type :frame
                :frame *isr-frame-root*)
           parsed-path)))
    ((or (integerp (first parsed-path)) (eq (first parsed-path) :?))
     (make-handle-from-parsed-path1
       (make-handle :type :frame
            :frame *isr-frame-root*)
       parsed-path))
    (t (values nil nil))))

(defun make-handle-from-parsed-path1 (handle-above more-parsed-path)
  "Helper function for make-handle-from-parsed-path: handles the recursive
descent needed to traverse the path."
  (DEBUGGING "~&*** Entering ISR2::MAKE-HANDLE-FROM-PARSED-PATH1: ~S ~S"
        handle-above more-parsed-path)
  (DEBUG-DESCRIBE handle-above)
  (cond ((null more-parsed-path)
     (if (and (or (eq (handle-type handle-above) :frame-feature)
              (and (eq (handle-type handle-above) :token-feature)
               (integerp (handle-token handle-above))))
          (fdescr-p (handle-fdescr handle-above)))
         (let* ((fdescr (handle-fdescr handle-above))
            (fdescr-value (if (eq (handle-type handle-above) :frame-feature)
                      (fdescr-value fdescr)
                      (vvref (fdescr-value fdescr)
                         (handle-token handle-above))))
            )
           (if (and
            (= (fdescr-type fdescr) *handle*)
            (handle-p fdescr-value)
            (eq (handle-type fdescr-value) :frame)
            (string= (fdescr-featurename fdescr)
                 (frame-name (handle-frame fdescr-value)))
            (eq (handle-frame handle-above)
                (handle-frame
                  (frame-parent
                (handle-frame fdescr-value))))
               )
              (values (copy-handle fdescr-value) nil)
              (values handle-above nil))
          )
         (values handle-above nil)))
    ((integerp (first more-parsed-path))
     (cond ((and (eq (handle-type handle-above) :frame)
             (= (vvref (frame-token-set-existence-vector
                 (handle-frame handle-above))
                   (first more-parsed-path)) 1))
        (setf (handle-type handle-above) :token
              (handle-token handle-above) (first more-parsed-path)
              )
        (make-handle-from-parsed-path1 handle-above (rest more-parsed-path)))
           ((and (member (handle-type handle-above) '(:token-subset :token-sort))
             (tss-index-memq (first more-parsed-path)
                     (handle-token-existence-array handle-above))
             (= (vvref (frame-token-set-existence-vector
                 (handle-frame handle-above))
                   (first more-parsed-path))
            1))
        (setf (handle-type handle-above) :token
              (handle-token handle-above) (first more-parsed-path)
              )
        (make-handle-from-parsed-path1 handle-above (rest more-parsed-path)))
           ((eq (handle-type handle-above) :frame-feature)
         (let ((fdescr (handle-fdescr handle-above)))
              (if (and (fdescr-p fdescr)
                   (= (fdescr-type fdescr) *handle*)
                   (handle-p (fdescr-value fdescr))
                   (eq (handle-type (fdescr-value fdescr)) :frame)
                   #|
                   (string= (fdescr-featurename fdescr)
                    (frame-name (handle-frame
                              (fdescr-value fdescr))))
                   (eq (handle-frame handle-above)
                   (handle-frame
                     (frame-parent
                       (handle-frame
                     (fdescr-value fdescr)))))
                   |#
                   )
              (make-handle-from-parsed-path1
                (copy-handle-into handle-above (fdescr-value fdescr))
                more-parsed-path)
              (values handle-above more-parsed-path))
              ))
           ((eq (handle-type handle-above) :token-feature)
         (let ((fdescr (handle-fdescr handle-above)))
              (if (and (fdescr-p fdescr)
                   (= (fdescr-type fdescr) *handle*)
                   (integerp (handle-token handle-above)))
              (let ((tokval (vvref (fdescr-value fdescr)
                           (handle-token handle-above))))
                   (if (and (handle-p tokval)
                    (eq (handle-type tokval) :frame)
                    #|
                    (string= (fdescr-featurename fdescr)
                         (frame-name (handle-frame
                                   tokval)))
                    (eq (handle-frame handle-above)
                        (handle-frame
                          (frame-parent
                        (handle-frame
                          tokval))))
                    |#
                    )
                   (make-handle-from-parsed-path1
                     (copy-handle-into handle-above tokval)
                     more-parsed-path)
                   (values handle-above more-parsed-path)))
              (values handle-above more-parsed-path))
              ))
           (t (values handle-above more-parsed-path)))
     )
    ((and (member (handle-type handle-above) '(:frame :token-subset :token-sort))
          (eq (first more-parsed-path) :?))
     (setf (handle-type handle-above) :token
           (handle-token handle-above) (first more-parsed-path)
           )
     (make-handle-from-parsed-path1 handle-above (rest more-parsed-path)))
    ((and (eq (handle-type handle-above) :frame-feature)
          (eq (first more-parsed-path) :?))
     (let ((fdescr (handle-fdescr handle-above)))
          (if (and (fdescr-p fdescr)
               (= (fdescr-type fdescr) *handle*)
               (handle-p (fdescr-value fdescr))
               (eq (handle-type (fdescr-value fdescr)) :frame)
               #|
               (string= (fdescr-featurename fdescr)
                (frame-name (handle-frame (fdescr-value fdescr))))
               (eq (handle-frame handle-above)
               (handle-frame
                 (frame-parent
                   (handle-frame
                 (fdescr-value fdescr)))))
               |#
               )
          (make-handle-from-parsed-path1
            (copy-handle-into handle-above (fdescr-value fdescr))
            more-parsed-path)
          (values handle-above more-parsed-path))
          ))
    ((and (eq (handle-type handle-above) :token-feature)
          (integerp (handle-token handle-above))
          (eq (first more-parsed-path) :?))
     (let ((fdescr (handle-fdescr handle-above)))
          (if (and (fdescr-p fdescr)
               (= (fdescr-type fdescr) *handle*)
               )
          (let ((tokval (vvref (fdescr-value fdescr)
                       (handle-token handle-above))))
               (if (and (handle-p tokval)
                (eq (handle-type tokval) :frame)
                #|
                (string= (fdescr-featurename fdescr)
                     (frame-name (handle-frame tokval)))
                (eq (handle-frame handle-above)
                    (handle-frame
                      (frame-parent
                    (handle-frame
                      tokval))))
                |#
                )
               (make-handle-from-parsed-path1
                 (copy-handle-into handle-above tokval)
                 more-parsed-path)
               (values handle-above more-parsed-path)))
          (values handle-above more-parsed-path))
          ))
    ((stringp (first more-parsed-path))
     (case (handle-type handle-above)
           (:frame
         (let ((fdescr-pair (assoc (first more-parsed-path)
                       (frame-feature-alist
                         (handle-frame handle-above))
                       :test #'equalp)))
              (if fdescr-pair
              (progn
                (setf (handle-type handle-above) :frame-feature
                  (handle-feature handle-above) (first more-parsed-path)
                  (handle-fdescr handle-above) (rest fdescr-pair))
                (make-handle-from-parsed-path1
                  handle-above
                  (rest more-parsed-path)))
              (values handle-above more-parsed-path))
              )
         )
           (:token
         (let ((fdescr (first (member (first more-parsed-path)
                          (frame-token-set-feature-vector
                        (handle-frame handle-above))
                          :test #'string=
                          :key  #'fdescr-featurename))))
              (if fdescr
              (progn
                (setf (handle-type handle-above) :token-feature
                  (handle-fdescr handle-above) fdescr
                  (handle-feature handle-above) (first more-parsed-path))
                (make-handle-from-parsed-path1
                  handle-above
                  (rest more-parsed-path)))
              (values handle-above more-parsed-path))
              )
         )
           (:frame-feature
         (let ((fdescr (handle-fdescr handle-above)))
              (if (and (fdescr-p fdescr)
                   (= (fdescr-type fdescr) *handle*)
                   (handle-p (fdescr-value fdescr))
                   (eq (handle-type (fdescr-value fdescr)) :frame)
                   #|
                   (string= (fdescr-featurename fdescr)
                    (frame-name (handle-frame
                              (fdescr-value fdescr))))
                   (eq (handle-frame handle-above)
                   (handle-frame
                     (frame-parent
                       (handle-frame
                     (fdescr-value fdescr)))))
                   |#
                   (not (string= (subseq (first more-parsed-path) 0 2)
                         "F_"))
                   )
              (make-handle-from-parsed-path1
                (copy-handle-into handle-above (fdescr-value fdescr))
                more-parsed-path)
              (values handle-above more-parsed-path))
              ))
           (:token-feature
         (if (eq (handle-token handle-above) ':?)
             (values handle-above more-parsed-path)
             (let ((fdescr (handle-fdescr handle-above)))
              (if (and (fdescr-p fdescr)
                   (= (fdescr-type fdescr) *handle*))
                  (let ((tokval (vvref (fdescr-value fdescr)
                           (handle-token
                             handle-above))))
                   (if (and (handle-p tokval)
                        (eq (handle-type tokval) :frame)
                        #|
                        (string= (fdescr-featurename fdescr)
                             (frame-name (handle-frame
                                   tokval)))
                        (eq (handle-frame handle-above)
                        (handle-frame
                          (frame-parent (handle-frame
                                  tokval))))
                        |#
                        (not (string= (subseq (first more-parsed-path)
                                  0 2)
                              "F_"))
                        )
                       (make-handle-from-parsed-path1
                     (copy-handle-into handle-above tokval)
                     more-parsed-path)
                       (values handle-above more-parsed-path)))
                  (values handle-above more-parsed-path))
              )
             )
         )
           (t (values handle-above more-parsed-path))))
    (t (values handle-above more-parsed-path))
    )
  )

(defun copy-handle-into (output input)
  (setf (handle-type output) (handle-type input)
    (handle-frame output) (handle-frame input)
    (handle-token output) (handle-token input)
    (handle-feature output) (handle-feature input)
    (handle-fdescr output) (handle-fdescr input)
    (handle-token-existence-array output) (handle-token-existence-array input)
    (handle-last-picked output) (handle-last-picked input)
    (handle-sort-order output) (handle-sort-order input)
    )
  output)

(defun symfunctp (thing)
  (or (and (consp thing)
       (eq (first thing) 'lambda))
      (and (symbolp thing)
       (fboundp thing)))
  )

(defun define-feature (path documentation datatype-key &key if-needed
               if-getting if-setting &aux parsed-path handle
               more-path datatype)
  "DEFINE-FEATURE path documentation datatype &key if-needed if-getting if-setting
This function defines a new frame or token feature as defined by path."
  (setf datatype (dt-from-keyword datatype-key))
  (unless (and (integerp datatype)
           (>= datatype FIRST-DT)
           (<= datatype LAST-DT))
    (error "Illegal data type code: ~S" datatype-key))
  (setf parsed-path (parse-token-name path))
  (multiple-value-setq (handle more-path)
    (make-handle-from-parsed-path parsed-path))
  (unless (and handle
           (check-terminal-path handle more-path))
    (error "~S is not a legitimate path!" path))
  (when (null if-needed)
    (setf if-needed (list 'default-if-needed-function)))
  (unless (every #'symfunctp if-needed)
    (error "Not a list of functions ~S" if-needed))
  (unless (every #'symfunctp if-getting)
    (error "Not a list of functions ~S" if-getting))
  (unless (every #'symfunctp if-setting)
    (error "Not a list of functions ~S" if-setting))
  (cond ((null more-path)
     (if (member (handle-type handle) '(:frame-feature :token-feature))
         (error "~S has already been defined!" path)
         (error "~S is not a legitimate path!" path)))
    ((and (eq (handle-type handle) :token)
          (eq (handle-token handle) ':?))
     (when (> (length more-path) 1)
       (error "~S is not a legitimate path!" path))
     (define-token-set-feature handle (first more-path)
                   documentation datatype
                   if-needed if-getting if-setting))
    ((member (handle-type handle) '(:token :token-subset :token-sort))
     (error "Cannot define a feature for path ~S" path))
    ((eq (first more-path) ':?)
     (when (> (length more-path) 2)
       (error "~S is not a legitimate path!" path))
     (define-token-set-feature handle (second more-path)
                   documentation datatype
                   if-needed if-getting if-setting))
    ((stringp (first more-path))
     (when (rest more-path)
       (error "~S is not a legitimate path!" path))
     (define-frame-feature handle (first more-path)
                   documentation datatype
                   if-needed if-getting if-setting))
    (t (error "~S is not a legitimate path!" path))
    )
  )

(defun define-token-set-feature (handle name doc dt if-needed if-getting
                 if-setting)
  "Helper function: defines a new token-set-feature."
  (when (string= (subseq name 0 2) "F_")
    (error "Reserved path-name element: ~S" name))
  (let ((fdescr (make-fdescr
          :type dt
          :featurename name
          :docstring doc
          :value (make-2index-vector-vector dt)
          :if-needed if-needed
          :if-setting if-setting
          :if-getting if-getting))
    (frame (handle-frame handle))
    )
       (push fdescr
         (frame-token-set-feature-vector frame))
       (make-handle :type :token-feature
            :frame frame
            :feature name
            :token :?
            :fdescr fdescr)
       ))

(defun define-frame-feature (handle name doc dt if-needed if-getting
                 if-setting)
  "Helper function: defines a new frame-feature."
  (when (string= (subseq name 0 2) "F_")
    (error "Reserved path-name element: ~S" name))
  (when (member name '("NAME" "DOCUMENTATION" "SOURCE-FILES") :test #'equalp)
    (error "Reserved frame feature name: ~S" name))
  (let ((fdescr (make-fdescr
          :type dt
          :featurename name
          :docstring doc
          :value  (ecase dt
                 ((#.*pointer* #.*bitplane* #.*extents*
                   #.*array* #.*string* #.*handle*)
                  *ptr-undefined*)
                 (#.*int* *int-undefined*)
                 (#.*real* *real-undefined*)
                 (#.*BOOLEAN* 0)
                 )
          :if-needed if-needed
          :if-setting if-setting
          :if-getting if-getting))
    (frame (handle-frame handle))
    )
       (setf (frame-feature-alist frame)
         (acons name fdescr (frame-feature-alist frame)))
       (setf (handle-type handle) :frame-feature
         (handle-fdescr handle) fdescr
         (handle-feature handle) name)
       handle))

(defun add-feature-function (path which-slot which-end new-function &aux
                 parsed-path handle more-path)
  "ADD-FEATURE-FUNCTION path which-slot which-end new-function -
This function adds a new feature function.  WHICH-SLOT is one of the keywords
:IF-NEEDED, :IF-GETTING, or :IF-SETTING. WHICH-END is either :BEFORE or :AFTER
and specifies whether the new function is to be run before the existing
feature functions or after the existing feature functions.  NEW-FUNCTION is a
function object."
  (setf parsed-path (parse-token-name path))
  (multiple-value-setq (handle more-path)
    (make-handle-from-parsed-path parsed-path))
  (unless (and handle
           (check-terminal-path handle more-path)
           (eq (handle-type handle) :frame))
    (error "~S is not a legitimate path!" path))
  (unless (member which-slot '(:if-needed :if-getting :if-setting))
    (error "Illegal slot name: ~S" which-slot))
  (unless (member which-end '(:before :after))
    (error "Illegal end: ~S" which-end))
  (unless (symfunctp new-function)
    (error "Not a function: ~S" new-function))
  (cond ((null more-path)
     (if (member (handle-type handle) '(:feature :token-feature))
         (if (eq (handle-type handle) :feature)
         (add-frame-feature-function (handle-frame handle)
                         (handle-feature handle)
                         which-slot which-end
                         new-function)
         (add-token-set-feature-function (handle-frame handle)
                         (handle-feature handle)
                         which-slot which-end
                         new-function))
         (error "~S is not a legitimate path!" path)))
    ((and (eq (first more-path) ':?)
          (rest more-path)
          (stringp (second more-path))
          (null (rest (rest more-path))))
     (add-token-set-feature-function (handle-frame handle)
                     (second more-path)
                     which-slot which-end
                     new-function))
    (t (error "~S is not a legitimate path!" path))
    )
  )

(defun add-token-set-feature-function (frame feature slot end function)
  "Helper function to add a new token-set feature function"
  (when (string= (subseq feature 0 2) "F_")
    (error "Reserved path-name element: ~S" feature))
  (let ((fdescr (first (member feature (frame-token-set-feature-vector
                     frame)
                   :test #'equalp
                   :key #'fdescr-featurename))))
       (unless fdescr
     (error "Token set feature ~A not defined in frame ~S"
        feature frame))
       (if (eq end :before)
       (case slot
         (:if-needed (push function (fdescr-if-needed fdescr)))
         (:if-getting (push function (fdescr-if-getting fdescr)))
         (:if-setting (push function (fdescr-if-setting fdescr))))
       (case slot
         (:if-needed
           (setf (fdescr-if-needed fdescr)
             (nconc (fdescr-if-needed fdescr)
                (list function))))
         (:if-getting
           (setf (fdescr-if-getting fdescr)
             (nconc (fdescr-if-getting fdescr)
                (list function))))
         (:if-setting
           (setf (fdescr-if-setting fdescr)
             (nconc (fdescr-if-setting fdescr)
                (list function))))
         )
       )
       )
  t)

(defun add-frame-feature-function (frame feature slot end function)
  "Helper function to add a new frame feature function"
  (when (string= (subseq feature 0 2) "F_")
    (error "Reserved path-name element: ~S" feature))
  (when (member feature '("NAME" "DOCUMENTATION" "SOURCE-FILES") :test #'equalp)
    (error "Cannot set feature functions on hard-wired frame-feature ~A"
       feature))
  (let ((fdescr (cdr (assoc feature (frame-feature-alist
                     frame)
                   :test #'equalp))))
       (unless fdescr
     (error "Frame feature ~A not defined in frame ~S"
        feature frame))
       (if (eq end :before)
       (case slot
         (:if-needed (push function (fdescr-if-needed fdescr)))
         (:if-getting (push function (fdescr-if-getting fdescr)))
         (:if-setting (push function (fdescr-if-setting fdescr))))
       (case slot
         (:if-needed
           (setf (fdescr-if-needed fdescr)
             (nconc (fdescr-if-needed fdescr)
                (list function))))
         (:if-getting
           (setf (fdescr-if-getting fdescr)
             (nconc (fdescr-if-getting fdescr)
                (list function))))
         (:if-setting
           (setf (fdescr-if-setting fdescr)
             (nconc (fdescr-if-setting fdescr)
                (list function))))
         )
       )
       )
  t)

(defun default-if-needed-function (slot-name frame-handle token-handle)
  "Default IF-NEEDED function.  Raises an error if called."
  (error "Uncalculated value found for slot ~A, of frame ~S, token ~S"
     slot-name frame-handle token-handle))

(defun create (path &key frame-features token-features token-init-list
            &aux parsed-path handle more-path)
  "CREATE path &key frame-features token-features token-init-list -
Create a new token or frame (tail of path says which).  If a frame, then
frame-features and token-features define its feature lists (they are lists of
arguments for DEFINE-FEATURE), else if a token token-init-list is a list of two
element lists (featurename value) to be used as token value initializers."
  (setf parsed-path (parse-token-name path))
  (multiple-value-setq (handle more-path)
    (make-handle-from-parsed-path parsed-path))
  (unless (and handle
           (check-terminal-path handle more-path)
           (member (handle-type handle) '(:frame :token-subset :token
                          :token-feature :frame-feature)))
    (error "~S is not a legitimate path!" path))
  #|
  (when (or (null more-path) (and (stringp (first more-path))
                  (string= (subseq (first more-path) 0 2)
                       "F_")))
    (error "~S has already been created!" path))
  |#
  (cond ((integerp (first more-path))
     ;; create a token
     (with-lock ((2index-vector-vector-lock
              (frame-token-set-existence-vector
            (handle-frame handle))))
            (create-token (handle-frame handle) (first more-path) token-init-list
              (eq (handle-type handle) :frame))))
    ((eq (handle-type handle) :token-subset)
     (error "Token subsets don't have features or frames: ~S"
        path))
    ((member (handle-type handle) '(:token :token-feature))
     (when (eq (handle-type handle) :token)
       (when (null more-path)
         (error "~S has already been created!" path))
       (let ((tokindex (handle-token handle)))
        (setf (handle-token handle) :?
              handle (define-feature (list handle (first more-path)) "" :handle)
              more-path (rest more-path)
              (handle-token handle) tokindex)
        ))
     (create-frame handle frame-features token-features))
    (t (when (eq (handle-type handle) :frame)
         (when (null more-path)
           (error "~S has already been created!" path))
         (setf handle (define-feature (list handle (first more-path)) "" :handle)
           more-path (rest more-path)))
       (create-frame handle frame-features token-features)))
  )

(defun create-new-token (path &key token-init-list
            &aux parsed-path handle more-path)
  "CREATE-NEW-TOKEN path &key token-init-list -
Create a new token.  The token index is generated. Token-init-list is a
list of two element lists (featurename value) to be used as token value
initializers."
  (setf parsed-path (parse-token-name path))
  (multiple-value-setq (handle more-path)
    (make-handle-from-parsed-path parsed-path))
  (unless (and handle
           (null more-path)
           (member (handle-type handle) '(:frame :token-subset)))
    (error "~S is not a legitimate path!" path))
  (with-lock ((2index-vector-vector-lock
        (frame-token-set-existence-vector (handle-frame handle))))
    (let* ((new-index (find-free-token-index (handle-frame handle)))
       (new-token (create-token (handle-frame handle) new-index token-init-list
                    (eq (handle-type handle) :frame)))
       )
     (when (eq (handle-type handle) :token-subset)
       (tss-index-add new-index handle))
     new-token)))

(defun token-index-of (token-handle &aux index)
  "Returns the token index in token-handle."
  (unless (and (handle-p token-handle)
           (member (handle-type token-handle) '(:token :token-feature)))
    (error "Bad argument to ~S: not a token or token-feature handle - ~S!"
       'token-index-of token-handle))
  (setf index (handle-token token-handle))
  (unless (integerp index)
    (error "Bad argument to ~S: ambigous token or token-feature handle - ~S!"
       'token-index-of token-handle))
  index)

(defun find-free-token-index (frame)
  "Helper function - find first free token index in frame."
  (let ((evv (frame-token-set-existence-vector frame)))
      (do ((index 0 (1+ index)))
          ((= (vvref evv index) 0) index)
          ))
  )

(defsetf value %setf-value "Setf form for VALUE")

(defun create-token (frame token-index token-init-list &optional (permp nil)
               &aux new-handle)
  "Helper function: create a new token and maybe initializes some of its feature
values."
  (setf (vvref (frame-token-set-existence-vector
         frame)
           token-index) 1)
  (when permp
    (setf (vvref (frame-token-set-globalp-vector
           frame)
         token-index) 1))
  (setf new-handle (make-handle :type :token
                :frame frame
                :token token-index))
  (map nil #'(lambda (feature-value-pair)
             (setf (value (list new-handle (first feature-value-pair)))
               (second feature-value-pair)))
       token-init-list)
  new-handle)

(defun create-frame (fdescr-handle frame-features token-features)
  "Helper function: create a new frame and define some features for it."
  (unless (and (= (fdescr-type (handle-fdescr fdescr-handle)) *handle*)
           (eq (if (eq (handle-type fdescr-handle) :frame-feature)
               (fdescr-value (handle-fdescr fdescr-handle))
               (vvref (fdescr-value (handle-fdescr fdescr-handle))
                  (handle-token fdescr-handle)))
           *ptr-undefined*))
    (error "Attempt to create a frame in a non-handle feature or in a bound feature: ~S"
       fdescr-handle))
  (let* ((new-frame-name (handle-feature fdescr-handle))
     (new-frame
      (make-frame new-frame-name
              :parent (if (eq (handle-type fdescr-handle) :token-feature)
                  (make-handle :type :token
                           :frame (handle-frame fdescr-handle)
                           :token (handle-token fdescr-handle))
                  (make-handle :type :frame
                           :frame (handle-frame fdescr-handle)))))
     (new-frame-handle (make-handle :type :frame :frame new-frame))
     (new-any-token-index-handle
       (make-handle :type :token
            :frame new-frame
            :token :?))
     (success? nil)
     )
    (setf (value fdescr-handle) new-frame-handle)
    (unwind-protect
      (progn
        (map nil #'(lambda (frame-feature-def)
                   (apply #'define-feature
                      (list new-frame-handle
                        (first frame-feature-def))
                      (rest frame-feature-def)))
         frame-features)
        (map nil #'(lambda (token-feature-def)
                   (apply #'define-feature
                      (list new-any-token-index-handle
                        (first token-feature-def))
                      (rest token-feature-def)))
         token-features)
        (setf success? t))
      (unless success?
        (destroy new-frame-handle)))
    (if success?
        new-frame-handle
        nil))
  )

(defvar *value-frame-handle* (make-handle :type :frame)
    "scratch handle for use inside isr2:value")

(defvar *value-token-handle* (make-handle :type :token)
    "scratch handle for use inside isr2:value")

(defun value (path &key (if-undefined :error) &aux parsed-path handle more-path)
  "VALUE path &KEY (if-undefined :error) - returns the value at the end of path."
  (declare (special path))
  (when (and (listp path)
         (handle-p (first path))
         (eq (handle-type (first path)) :token-feature)
         (eq (handle-token (first path)) :?)
         (integerp (second path))
         (null (rest (rest path))))
    (let ((new-path (copy-handle (first path))))
     (setf (handle-token new-path) (second path)
           path new-path)))
  (setf parsed-path (parse-token-name path))
  (multiple-value-setq (handle more-path)
    (make-handle-from-parsed-path parsed-path))
  (unless (and handle
           (check-terminal-path handle more-path))
    (error "~S is not a legitimate path!" path))
  (DEBUGGING "~&*** Entering ISR2::VALUE ~S~&    Parsed: ~S, ~S" path
         handle more-path)
  (unless (frame-is-loaded-p (handle-frame handle))
    (check-load-stub-frame handle))
  (case (handle-type handle)
    (:frame (if (null more-path)
            handle
            (cond ((integerp (first more-path))
               (error "Token does not exist: ~S!" (list
                                   handle
                                   (first more-path))))
              ((string= (first more-path) "DOCUMENTATION")
               (cond ((null (rest more-path))
                  (frame-documentation (handle-frame handle)))
                 ((= (length more-path) 2)
                  (if (string= (second more-path)
                           "F_DATATYPE")
                      :string
                      (error "~S is not a legitimate path !" path)))
                 (t (error "~S is not a legitimate path !" path))))
              ((string= (first more-path) "SOURCE-FILES")
               (cond ((null (rest more-path))
                  (frame-source-file-list (handle-frame handle)))
                 ((= (length more-path) 2)
                  (if (string= (second more-path)
                           "F_DATATYPE")
                      :pointer
                      (error "~S is not a legitimate path !" path)))
                 (t (error "~S is not a legitimate path !" path))))
              ((string= (first more-path) "NAME")
               (cond ((null (rest more-path))
                  (frame-name (handle-frame handle)))
                 ((= (length more-path) 2)
                  (if (string= (second more-path)
                           "F_DATATYPE")
                      :string
                      (error "~S is not a legitimate path !" path)))
                 (t (error "~S is not a legitimate path !" path))))
              (t (error "~S is not a legitimate path !" path)))))
    (:frame-feature
      (frame-feature-value handle more-path if-undefined))
    (:token-feature
      (token-feature-value handle more-path if-undefined))
    (t (error "~S is not a legitimate path !" path)))
  )


(defun frame-feature-value (handle more-path if-undefined)
  "Helper function: fetch the value of a frame feature."
  (declare (special path))
  (if (null more-path)
      (let* ((fdescr (handle-fdescr handle))
         (orig-value (fdescr-value fdescr))
         (if-needed (fdescr-if-needed fdescr))
         (if-setting (fdescr-if-setting fdescr))
         (if-getting (fdescr-if-getting fdescr))
         (frame-handle (progn
                 (setf (handle-type *value-frame-handle*) :frame
                   (handle-frame *value-frame-handle*)
                   (handle-frame handle))
                 *value-frame-handle*))
         (*set-value-flag* t)
         )
       (declare (special *set-value-flag*))
       (when (equalp orig-value (case (fdescr-type fdescr)
                      ((#.*int* #.*boolean*) *int-undefinable*)
                      (#.*real* *real-undefinable*)
                      (t *ptr-undefinable*)))
         (setf orig-value :undefined))
       (when (equalp orig-value (case (fdescr-type fdescr)
                      ((#.*int* #.*boolean*) *int-undefined*)
                      (#.*real* *real-undefined*)
                      (t *ptr-undefined*)))
         (setf orig-value :uncalculated))
       (when (eq orig-value :uncalculated)
         (dolist (if-needed-fun if-needed)
             (setf orig-value
               (funcall if-needed-fun
                    (fdescr-featurename fdescr)
                    frame-handle
                    nil))
             (unless (eq orig-value :uncalculated) (return t)))
         (dolist (if-setting-fun if-setting)
             (setf orig-value
               (funcall if-setting-fun
                    :uncalculated
                    orig-value
                    (fdescr-featurename fdescr)
                    frame-handle nil)))
         (when (eq orig-value :uncalculated)
           (setf orig-value
             (case (fdescr-type fdescr)
               (#.*int* *int-undefined*)
               (#.*real* *real-undefined*)
               (t *ptr-undefined*))))
         (when (eq orig-value :undefined)
           (setf orig-value
             (case (fdescr-type fdescr)
               (#.*int* *int-undefinable*)
               (#.*real* *real-undefinable*)
               (t *ptr-undefinable*))))
         (when *set-value-flag*
           (case (fdescr-type fdescr)
         (#.*int* (unless (typep orig-value 'integer)
                (error "~S must be an integer!" orig-value)))
         (#.*real* (unless (typep orig-value 'single-float)
                 (error "~S must be a single float!" orig-value)))
         (#.*string* (unless (or (eq orig-value *ptr-undefined*)
                     (eq orig-value *ptr-undefinable*)
                     (typep orig-value 'string))
                   (error "~S must be a string!" orig-value)))
         (#.*array* (unless (or (eq orig-value *ptr-undefined*)
                    (eq orig-value *ptr-undefinable*)
                    (typep orig-value 'array))
                  (error "~S must be an array!" orig-value)))
         (#.*handle* (unless (or (eq orig-value *ptr-undefined*)
                     (eq orig-value *ptr-undefinable*)
                     (typep orig-value 'handle))
                   (error "~S must be a handle!" orig-value)))
         (#.*BOOLEAN* (unless (or (eq orig-value *ptr-undefined*)
                      (eq orig-value *ptr-undefinable*)
                      (typep orig-value 'bit))
                (error "~S must be a bit!" orig-value)))
         (#.*bitplane* (unless (or (eq orig-value *ptr-undefined*)
                       (eq orig-value *ptr-undefinable*)
                       (typep orig-value '(array bit (* *))))
                 (error "~S must be a bitplane!" orig-value)))
         (#.*extents* (unless (or (eq orig-value *ptr-undefined*)
                      (eq orig-value *ptr-undefinable*)
                      (typep orig-value 'extents))
                (error "~S must be an extents struct!" orig-value)))
         (#.*pointer*)
         )
           (setf (fdescr-value fdescr) orig-value)
           )
         (when (equalp orig-value (case (fdescr-type fdescr)
                        ((#.*int* #.*boolean*) *int-undefinable*)
                        (#.*real* *real-undefinable*)
                        (t *ptr-undefinable*)))
           (setf orig-value :undefined))
         (when (equalp orig-value (case (fdescr-type fdescr)
                        ((#.*int* #.*boolean*) *int-undefined*)
                        (#.*real* *real-undefined*)
                        (t *ptr-undefined*)))
           (setf orig-value :uncalculated))
         )
       (dolist (if-getting-fun if-getting)
           (setf orig-value
             (funcall if-getting-fun
                  orig-value
                  (fdescr-featurename fdescr)
                  frame-handle nil)))
       (if (eq orig-value :undefined)
           (if (eq if-undefined :error)
           (error "The value of ~S is undefined!" handle)
           if-undefined)
           orig-value))
      (let ((field-name (first more-path))
        (fdescr (handle-fdescr handle)))
       (unless (null (rest more-path))
         (error "~S is not a legitimate path !" path))
       (cond ((string= field-name "F_DATATYPE")
          (keyword-from-dt (fdescr-type fdescr)))
         ((string= field-name "F_DOCUMENTATION")
          (fdescr-docstring fdescr))
         ((string= field-name "F_IF-NEEDED")
          (fdescr-if-needed fdescr))
         ((string= field-name "F_IF-GETTING")
          (fdescr-if-getting fdescr))
         ((string= field-name "F_IF-SETTING")
          (fdescr-if-setting fdescr))
         (t (error "~S is not a legitimate path !" path)))
       )
      )
  )

(defun token-feature-value (handle more-path if-undefined &aux token-index)
  "Helper function: fetch the value of a token feature."
  (declare (special path))
  (setf token-index (handle-token handle))
  (if (null more-path)
      (progn
    (unless (integerp token-index)
      (error "~S is not a legitimate path !" path))
    (unless (= (vvref (frame-token-set-existence-vector (handle-frame handle))
              token-index)
           1)
      (error "~S is not a legitimate path !" path))
    (let* ((fdescr (handle-fdescr handle))
           (orig-value (vvref (fdescr-value fdescr) token-index))
           (if-needed (fdescr-if-needed fdescr))
           (if-getting (fdescr-if-getting fdescr))
           (if-setting (fdescr-if-setting fdescr))
           (frame-handle (progn
                 (setf (handle-type *value-frame-handle*) :frame
                   (handle-frame *value-frame-handle*)
                   (handle-frame handle))
                 *value-frame-handle*))
           (*set-value-flag* t)
           (token-handle (progn
                 (setf (handle-type *value-token-handle*) :token
                   (handle-frame *value-token-handle*)
                   (handle-frame handle)
                   (handle-token *value-token-handle*)
                   (handle-token handle))
                 *value-token-handle*))
           )
          (declare (special *set-value-flag*))
          (when (equalp orig-value (case (fdescr-type fdescr)
                         ((#.*int* #.*boolean*) *int-undefinable*)
                         (#.*real* *real-undefinable*)
                         (t *ptr-undefinable*)))
        (setf orig-value :undefined))
          (when (equalp orig-value (case (fdescr-type fdescr)
                         ((#.*int* #.*boolean*) *int-undefined*)
                         (#.*real* *real-undefined*)
                         (t *ptr-undefined*)))
        (setf orig-value :uncalculated))
          (when (eq orig-value :uncalculated)
        (dolist (if-needed-fun if-needed)
            (setf orig-value
                  (funcall if-needed-fun
                       (fdescr-featurename fdescr)
                       frame-handle token-handle
                       ))
            (unless (eq orig-value :uncalculated) (return t)))
        (dolist (if-setting-fun if-setting)
            (setf orig-value
                  (funcall if-setting-fun
                       :uncalculated
                       orig-value
                       (fdescr-featurename fdescr)
                       frame-handle token-handle)))
        (when (eq orig-value :uncalculated)
          (setf orig-value
            (case (fdescr-type fdescr)
                  (#.*int* *int-undefined*)
                  (#.*real* *real-undefined*)
                  (t *ptr-undefined*))))
        (when (eq orig-value :undefined)
          (setf orig-value
            (case (fdescr-type fdescr)
                  (#.*int* *int-undefinable*)
                  (#.*real* *real-undefinable*)
                  (t *ptr-undefinable*))))
        (when *set-value-flag*
          (case (fdescr-type fdescr)
            (#.*int* (unless (typep orig-value 'integer)
                   (error "~S must be an integer!" orig-value)))
            (#.*real* (unless (typep orig-value 'single-float)
                    (error "~S must be a single float!" orig-value)))
            (#.*string* (unless (or (eq orig-value *ptr-undefined*)
                        (eq orig-value *ptr-undefinable*)
                        (typep orig-value 'string))
                      (error "~S must be a string!" orig-value)))
            (#.*array* (unless (or (eq orig-value *ptr-undefined*)
                           (eq orig-value *ptr-undefinable*)
                           (typep orig-value 'array))
                     (error "~S must be an array!" orig-value)))
            (#.*handle* (unless (or (eq orig-value *ptr-undefined*)
                        (eq orig-value *ptr-undefinable*)
                        (typep orig-value 'handle))
                      (error "~S must be a handle!" orig-value)))
            (#.*BOOLEAN* (unless (typep orig-value 'bit)
                       (error "~S must be a bit!" orig-value)))
            (#.*bitplane* (unless (or (eq orig-value *ptr-undefined*)
                          (eq orig-value *ptr-undefinable*)
                          (typep orig-value '(array bit (* *))))
                    (error "~S must be a bitplane!" orig-value)))
            (#.*extents* (unless (or (eq orig-value *ptr-undefined*)
                         (eq orig-value *ptr-undefinable*)
                         (typep orig-value 'extents))
                       (error "~S must be an extents struct!" orig-value)))
            (#.*pointer*)
            )
          (setf (vvref (fdescr-value fdescr) token-index)
            orig-value))
        (when (equalp orig-value (case (fdescr-type fdescr)
                           ((#.*int* #.*boolean*) *int-undefinable*)
                           (#.*real* *real-undefinable*)
                           (t *ptr-undefinable*)))
          (setf orig-value :undefined))
        (when (equalp orig-value (case (fdescr-type fdescr)
                           ((#.*int* #.*boolean*) *int-undefined*)
                           (#.*real* *real-undefined*)
                           (t *ptr-undefined*)))
          (setf orig-value :uncalculated))
        )
          (dolist (if-getting-fun if-getting)
              (setf orig-value
                (funcall if-getting-fun
                     orig-value
                     (fdescr-featurename fdescr)
                     frame-handle token-handle)))
          (if (eq orig-value :undefined)
          (if (eq if-undefined :error)
              (error "The value of ~S is undefined!" handle)
              if-undefined)
          orig-value)))
      (let ((field-name (first more-path))
        (fdescr (handle-fdescr handle)))
       (unless (null (rest more-path))
         (error "~S is not a legitimate path !" path))
       (cond ((string= field-name "F_DATATYPE")
          (keyword-from-dt (fdescr-type fdescr)))
         ((string= field-name "F_DOCUMENTATION")
          (fdescr-docstring fdescr))
         ((string= field-name "F_IF-NEEDED")
          (copy-list (fdescr-if-needed fdescr)))
         ((string= field-name "F_IF-GETTING")
          (copy-list (fdescr-if-getting fdescr)))
         ((string= field-name "F_IF-SETTING")
          (copy-list (fdescr-if-setting fdescr)))
         (t (error "~S is not a legitimate path !" path)))
       )
      )
  )


(defun %setf-value (path newvalue &aux parsed-path handle more-path)
  "Setf function for VALUE."
  (declare (special path))
  (when (and (listp path)
         (handle-p (first path))
         (eq (handle-type (first path)) :token-feature)
         (eq (handle-token (first path)) :?)
         (integerp (second path))
         (null (rest (rest path))))
    (let ((new-path (copy-handle (first path))))
     (setf (handle-token new-path) (second path)
           path new-path)))
  (setf parsed-path (parse-token-name path))
  (multiple-value-setq (handle more-path)
    (make-handle-from-parsed-path parsed-path))
  (unless (and handle
           (check-terminal-path handle more-path))
    (error "~S is not a legitimate path!" path))
  (DEBUGGING "~&*** Entering ISR2::%SETF-VALUE ~S ~S~&    Parsed: ~S, ~S" path
         newvalue handle more-path)
  (unless (frame-is-loaded-p (handle-frame handle))
    (check-load-stub-frame handle))
  (case (handle-type handle)
    (:frame (if (null more-path)
            (error "~S is not a legitimate path !" path)
            (cond ((integerp (first more-path))
               (error "Token does not exist: ~S!" (list
                                   handle
                                   (first more-path))))
              ((string= (first more-path) "DOCUMENTATION")
               (cond ((null (rest more-path))
                  (setf
                    (frame-documentation (handle-frame handle))
                    (string newvalue)))
                 (t (error "~S is not a legitimate path !" path))))
              ;; Note:  this may be removed at a future time.
              ((string= (first more-path) "SOURCE-FILES")
               (cond ((null (rest more-path))
                  (setf
                    (frame-source-file-list (handle-frame handle))
                    (copy-list newvalue)))
                 (t (error "~S is not a legitimate path !" path))))
              (t (error "~S is not a legitimate path !" path)))))
    (:frame-feature
      (%setf-frame-feature-value handle more-path newvalue))
    (:token-feature
      (%setf-token-feature-value handle more-path newvalue))
    (t (error "~S is not a legitimate path !" path)))
  )


(defun %setf-frame-feature-value (handle more-path newvalue)
  "Function to set a frame feature value."
  (declare (special path))
  (if (null more-path)
      (let* ((fdescr (handle-fdescr handle))
         (orig-value (fdescr-value fdescr))
         (if-setting (fdescr-if-setting fdescr))
         (frame-handle (progn
                 (setf (handle-type *value-frame-handle*) :frame
                   (handle-frame *value-frame-handle*)
                   (handle-frame handle))
                 *value-frame-handle*))
         (*set-value-flag* t)
         )
        (declare (special *set-value-flag*))
        (when (equalp orig-value (case (fdescr-type fdescr)
                       ((#.*int* #.*boolean*) *int-undefinable*)
                       (#.*real* *real-undefinable*)
                       (t *ptr-undefinable*)))
          (setf orig-value :undefined))
        (when (equalp orig-value (case (fdescr-type fdescr)
                       ((#.*int* #.*boolean*) *int-undefined*)
                       (#.*real* *real-undefined*)
                       (t *ptr-undefined*)))
          (setf orig-value :uncalculated))
        (dolist (if-setting-fun if-setting)
             (setf newvalue
               (funcall if-setting-fun
                    orig-value newvalue
                    (fdescr-featurename fdescr)
                    frame-handle nil)))
       (when *set-value-flag*
          (when (eq newvalue :uncalculated)
        (setf newvalue
              (case (fdescr-type fdescr)
                (#.*int* *int-undefined*)
                (#.*real* *real-undefined*)
                (t *ptr-undefined*))))
          (when (eq newvalue :undefined)
        (setf newvalue
              (case (fdescr-type fdescr)
                (#.*int* *int-undefinable*)
                (#.*real* *real-undefinable*)
                (t *ptr-undefinable*))))
           (case (fdescr-type fdescr)
         (#.*int* (unless (typep newvalue 'integer)
                (error "~S must be an integer!" newvalue)))
         (#.*real* (unless (typep newvalue 'single-float)
                 (error "~S must be a single float!" newvalue)))
         (#.*string* (unless (or (eq newvalue *ptr-undefined*)
                     (eq newvalue *ptr-undefinable*)
                     (typep newvalue 'string))
                   (error "~S must be a string!" newvalue)))
         (#.*array* (unless (or (eq newvalue *ptr-undefined*)
                    (eq newvalue *ptr-undefinable*)
                    (typep newvalue 'array))
                  (error "~S must be an array!" newvalue)))
         (#.*handle* (unless (or (eq newvalue *ptr-undefined*)
                     (eq newvalue *ptr-undefinable*)
                     (typep newvalue 'handle))
                   (error "~S must be a handle!" newvalue)))
         (#.*BOOLEAN* (unless (or (eq newvalue *ptr-undefined*)
                      (eq newvalue *ptr-undefinable*)
                      (typep newvalue 'bit))
                (error "~S must be a bit!" newvalue)))
         (#.*bitplane* (unless (or (eq newvalue *ptr-undefined*)
                       (eq newvalue *ptr-undefinable*)
                       (typep newvalue '(array bit (* *))))
                 (error "~S must be a bitplane!" newvalue)))
         (#.*extents* (unless (or (eq newvalue *ptr-undefined*)
                      (eq newvalue *ptr-undefinable*)
                      (typep newvalue 'extents))
                (error "~S must be an extents struct!" newvalue)))
         (#.*pointer*)
         )
         (setf (fdescr-value fdescr) newvalue)))
      (let ((field-name (first more-path))
        (fdescr (handle-fdescr handle)))
       (unless (null (rest more-path))
         (error "~S is not a legitimate path !" path))
       (cond ((string= field-name "F_DOCUMENTATION")
          (setf (fdescr-docstring fdescr) (string newvalue)))
         ((string= field-name "F_IF-NEEDED")
          (unless (and (listp newvalue)
                   (every #'symfunctp newvalue))
            (error "~S is not a list of functions !" newvalue))
          (setf (fdescr-if-needed fdescr) newvalue))
         ((string= field-name "F_IF-GETTING")
          (unless (and (listp newvalue)
                   (every #'symfunctp newvalue))
            (error "~S is not a list of functions !" newvalue))
          (setf (fdescr-if-getting fdescr) newvalue))
         ((string= field-name "F_IF-SETTING")
          (unless (and (listp newvalue)
                   (every #'symfunctp newvalue))
            (error "~S is not a list of functions !" newvalue))
          (setf (fdescr-if-setting fdescr) newvalue))
         (t (error "~S is not a legitimate path !" path)))
       )
      )
  )

(defun %setf-token-feature-value (handle more-path newvalue &aux token-index)
  "Function to set a token feature value."
  (declare (special path))
  (setf token-index (handle-token handle))
  (if (null more-path)
      (progn
    (unless (integerp token-index)
      (error "~S is not a legitimate path !" path))
    (unless (= (vvref (frame-token-set-existence-vector (handle-frame handle))
              token-index)
           1)
      (error "~S is not a legitimate path !" path))
    (let* ((fdescr (handle-fdescr handle))
           (orig-value (vvref (fdescr-value fdescr) token-index))
           (if-setting (fdescr-if-setting fdescr))
           (frame-handle (progn
                 (setf (handle-type *value-frame-handle*) :frame
                   (handle-frame *value-frame-handle*)
                   (handle-frame handle))
                 *value-frame-handle*))
           (*set-value-flag* t)
           (token-handle (progn
                 (setf (handle-type *value-token-handle*) :token
                   (handle-frame *value-token-handle*)
                   (handle-frame handle)
                   (handle-token *value-token-handle*)
                   (handle-token handle))
                 *value-token-handle*))
           )
          (declare (special *set-value-flag*))
          (when (equalp orig-value (case (fdescr-type fdescr)
                         ((#.*int* #.*boolean*) *int-undefinable*)
                         (#.*real* *real-undefinable*)
                         (t *ptr-undefinable*)))
        (setf orig-value :undefined))
          (when (equalp orig-value (case (fdescr-type fdescr)
                         ((#.*int* #.*boolean*) *int-undefined*)
                         (#.*real* *real-undefined*)
                         (t *ptr-undefined*)))
        (setf orig-value :uncalculated))
          (dolist (if-setting-fun if-setting)
              (DEBUGGING "~&***In %setf-token-feature-value: about to call setting function")
              (DEBUG-DESCRIBE if-setting-fun)
              (setf newvalue
                (funcall if-setting-fun
                     orig-value newvalue
                     (fdescr-featurename fdescr)
                     frame-handle token-handle))
              (DEBUGGING "~%---Old value: ~S, New Value: ~S" orig-value newvalue)
              )
          (when *set-value-flag*
        (when (eq newvalue :uncalculated)
          (setf newvalue
            (case (fdescr-type fdescr)
                  (#.*int* *int-undefined*)
                  (#.*real* *real-undefined*)
                  (t *ptr-undefined*))))
        (when (eq newvalue :undefined)
          (setf newvalue
            (case (fdescr-type fdescr)
                  (#.*int* *int-undefinable*)
                  (#.*real* *real-undefinable*)
                  (t *ptr-undefinable*))))
           (case (fdescr-type fdescr)
             (#.*int* (unless (typep newvalue 'integer)
                (error "~S must be an integer!" newvalue)))
             (#.*real* (unless (typep newvalue 'single-float)
                 (error "~S must be a single float!" newvalue)))
             (#.*string* (unless (or (eq newvalue *ptr-undefined*)
                         (eq newvalue *ptr-undefinable*)
                         (typep newvalue 'string))
                   (error "~S must be a string!" newvalue)))
             (#.*array* (unless (or (eq newvalue *ptr-undefined*)
                        (eq newvalue *ptr-undefinable*)
                        (typep newvalue 'array))
                  (error "~S must be an array!" newvalue)))
             (#.*handle* (unless (or (eq newvalue *ptr-undefined*)
                         (eq newvalue *ptr-undefinable*)
                         (typep newvalue 'handle))
                   (error "~S must be a handle!" newvalue)))
             (#.*BOOLEAN* (unless (typep newvalue 'bit)
                    (error "~S must be a bit!" newvalue)))
             (#.*bitplane* (unless (or (eq newvalue *ptr-undefined*)
                           (eq newvalue *ptr-undefinable*)
                           (typep newvalue '(array bit (* *))))
                     (error "~S must be a bitplane!" newvalue)))
             (#.*extents* (unless (or (eq newvalue *ptr-undefined*)
                          (eq newvalue *ptr-undefinable*)
                          (typep newvalue 'extents))
                    (error "~S must be an extents struct!" newvalue)))
             (#.*pointer*)
             )
           (setf (vvref (fdescr-value fdescr) token-index)
             newvalue))
       (cond ((eq newvalue *ptr-undefined*) :uncalculated)
         ((eq newvalue *ptr-undefinable*) :undefined)
         (t newvalue))))
      (let ((field-name (first more-path))
        (fdescr (handle-fdescr handle)))
       (unless (null (rest more-path))
         (error "~S is not a legitimate path !" path))
       (cond ((string= field-name "F_DOCUMENTATION")
          (setf (fdescr-docstring fdescr) (string newvalue)))
         ((string= field-name "F_IF-NEEDED")
          (unless (and (listp newvalue)
                   (list-length newvalue)
                   (every #'symfunctp newvalue))
            (error "~S is not a list of functions !" newvalue))
          (setf (fdescr-if-needed fdescr) (copy-list newvalue)))
         ((string= field-name "F_IF-GETTING")
          (unless (and (listp newvalue)
                   (list-length newvalue)
                   (every #'symfunctp newvalue))
            (error "~S is not a list of functions !" newvalue))
          (setf (fdescr-if-getting fdescr) (copy-list newvalue)))
         ((string= field-name "F_IF-SETTING")
          (unless (and (listp newvalue)
                   (list-length newvalue)
                   (every #'symfunctp newvalue))
            (error "~S is not a list of functions !" newvalue))
          (setf (fdescr-if-setting fdescr) (copy-list newvalue)))
         (t (error "~S is not a legitimate path !" path)))
       )
      )
  )

(defun destroy (path &aux parsed-path handle more-path)
  "DESTROY path -
Destroys (deletes) an existing token or frame (tail of path says which).  If a frame, then
everything below it in the tree is destroyed."
  (setf parsed-path (parse-token-name path))
  (multiple-value-setq (handle more-path)
    (make-handle-from-parsed-path parsed-path))
  (unless (and handle
           (check-terminal-path handle more-path))
    (error "~S is not a legitimate path!" path))
  (unless (null more-path)
    (error "~S does not exist!" path))
  (ecase (handle-type handle)
     (:frame (destroy-frame handle (parent handle)))
     (:token (destroy-token handle))
     (:frame-feature (destroy-frame-feature handle))
     (:token-feature (destroy-token-feature handle))
     )
  )

(defun destroy-frame (frame frame-parent)
  "Helper function - destroy a frame."
  (when (null frame-parent)
    (clear-system)
    (return-from destroy-frame frame))
  (destroy-frame1 frame)
  (let ((fdescr-handle (copy-handle frame-parent)))
       (setf (handle-type fdescr-handle) (if (eq (handle-type frame-parent) :token)
                         :token-feature
                         :frame-feature)
         (handle-feature fdescr-handle) (frame-name (handle-frame frame))
         (handle-fdescr fdescr-handle)
         (cond ((eq (handle-type frame-parent) :token)
            (first (member (frame-name (handle-frame frame))
                   (frame-token-set-feature-vector
                     (handle-frame frame-parent))
                   :test #'equalp
                   :key #'fdescr-featurename)))
           (t (cdr (assoc (frame-name (handle-frame frame))
                  (frame-feature-alist
                    (handle-frame frame-parent))
                  :test #'equalp))))
         )
       (if (eq (handle-type frame-parent) :token)
       (setf (vvref (fdescr-value (handle-fdescr fdescr-handle))
            (handle-token frame-parent))
         *ptr-undefined*)
       (setf (fdescr-value (handle-fdescr fdescr-handle))
         *ptr-undefined*))
       fdescr-handle)
  )

(defun destroy-frame1 (frame)
  "Helper function - destroy a frame's contents."
  (map nil #'(lambda (feature-value-pair &aux fdescr fvalue)
             (setf fdescr (rest feature-value-pair)
               fvalue (fdescr-value fdescr))
             (when (and
                 (= (fdescr-type fdescr)
                *handle*)
                 (handle-p fvalue)
                 (eq (handle-type fvalue) :frame)
                 (equalp (parent fvalue) frame)
                 )
               (destroy-frame1 fvalue)))
       (frame-feature-alist (handle-frame frame)))
  (map nil
       #'(lambda (fdescr &aux (fvalue-vec (fdescr-value fdescr)))
        (do-active-tokens (tokenindex (frame-token-set-existence-vector
                        (handle-frame frame)))
        (let ((token-value-handle (vvref fvalue-vec
                         tokenindex)))
             (when (and (handle-p token-value-handle)
                (eq (handle-type token-value-handle) :frame)
                (equalp (parent token-value-handle) frame))
               (destroy-frame1 token-value-handle))
             ))
        (with-lock ((2index-vector-vector-lock fvalue-vec))
           (let ((dv (2index-vector-vector-data fvalue-vec))
             temp)
            (dotimes (i (fill-pointer dv))
                 (setf temp (aref dv i))
                 (when temp
                   (deallocate-resource (type-of temp) temp)))))
        )
       (frame-token-set-feature-vector (handle-frame frame)))
  (let ((evv (frame-token-set-existence-vector (handle-frame frame))))
       (with-lock ((2index-vector-vector-lock evv))
      (let ((ev (2index-vector-vector-data evv))
        temp)
           (dotimes (i (fill-pointer ev))
            (setf temp (aref ev i))
            (when temp
              (deallocate-resource (type-of temp) temp))))))
  frame)

(defun destroy-token (token)
  "Helper function - destroy a token."
  (unless (integerp (handle-token token))
    (error "Ambiguous token index not allowed in DESTROY: ~S" token))
  (let ((token-index (handle-token token))
    (frame       (handle-frame token))
    )
       (setf (vvref (frame-token-set-existence-vector frame) token-index) 0)
       (setf (vvref (frame-token-set-globalp-vector frame) token-index) 0)
       (check-and-destroy-empty-block (frame-token-set-existence-vector frame)
                      token-index
                      )
       (check-and-destroy-empty-block (frame-token-set-globalp-vector frame)
                      token-index
                      )
       (map nil
        #'(lambda (fdescr &aux (fvalue-vec (fdescr-value fdescr)))
              (setf (vvref fvalue-vec token-index)
                (2index-vector-vector-undefined-value fvalue-vec))
              (check-and-destroy-empty-block fvalue-vec token-index)
              )
        (frame-token-set-feature-vector frame))
       (list (make-handle :type :frame
              :frame frame)
         token-index)
       )
  )

(defun check-and-destroy-empty-block (vvec index)
  "Helper function - check for an empty/unused vector block in vvec.  An
\"empty/unused\" block is defined as one having all its elements set to the
undefined (uncalculated) value.  The block checked is the one that INDEX
falls in.  If the block is empty, it is released via deallocate-resource."
  (with-lock ((2index-vector-vector-lock vvec))
    (let* ((ov (truncate index *default-2index-vector-size*))
           (outer-vec (2index-vector-vector-data vvec))
           (undefined (2index-vector-vector-undefined-value vvec))
           (ov-size (fill-pointer outer-vec))
           (inner-vec (if (< ov ov-size) (aref outer-vec ov)))
           )
          (when (and inner-vec
             (every
               #'(lambda (elt) (equalp elt undefined))
               (2index-vector-data-vector inner-vec)))
        (deallocate-resource (type-of inner-vec) inner-vec)
        (setf (aref outer-vec ov) nil)
        (when (= ov (1- ov-size))
          (do ()
              ((or (zerop (fill-pointer outer-vec))
               (not (null (aref outer-vec
                        (1- (fill-pointer outer-vec)))))))
              (decf (fill-pointer outer-vec)))))
          )
    )
  )

(defun destroy-frame-feature (handle &aux (frame (handle-frame handle))
                     (feature-name (handle-feature handle)))
  "Helper function - destroy a frame feature."
  (setf (frame-feature-alist frame)
    (delete feature-name
        (frame-feature-alist frame)
        :test #'string=
        :key #'car))
  (list (make-handle :type :frame :frame frame)
    feature-name)
  )

(defun destroy-token-feature (handle &aux (frame (handle-frame handle))
                     (feature-name (handle-feature handle))
                     (fvalue-vec (fdescr-value
                           (handle-fdescr handle))))
  "Helper function - destroy a token feature."
  (setf (frame-token-set-feature-vector frame)
    (delete feature-name
        (frame-token-set-feature-vector frame)
        :test #'string=
        :key #'fdescr-featurename))
  (with-lock ((2index-vector-vector-lock fvalue-vec))
       (let ((dv (2index-vector-vector-data fvalue-vec))
         temp)
        (dotimes (i (fill-pointer dv))
             (setf temp (aref dv i))
             (when temp
               (deallocate-resource (type-of temp) temp)))))
  (list (make-handle :type :token :frame frame
             :token (handle-token handle))
    feature-name)
  )

(defun copy-definition (source-path destination-path &optional (clobber-p nil)
            &aux source-parsed-path source-handle source-more-path
                 dest-parsed-path dest-handle dest-more-path)
  "COPY-DEFINITION source-path destination-path &OPTIONAL (clobber-p NIL) -
Copies the definitions in source-path to destination-path.  If clobber-p is
non-NIL the destination-path will be destroyed first if it already exists."
  (setf source-parsed-path (parse-token-name source-path))
  (multiple-value-setq (source-handle source-more-path)
    (make-handle-from-parsed-path source-parsed-path))
  (unless (and source-handle
           (check-terminal-path source-handle source-more-path))
    (error "~S is not a legitimate path!" source-path))
  (unless (null source-more-path)
    (error "~S does not exist!" source-path))
  (setf dest-parsed-path (parse-token-name destination-path))
  (multiple-value-setq (dest-handle dest-more-path)
    (make-handle-from-parsed-path dest-parsed-path))
  (unless (and dest-handle
           (check-terminal-path dest-handle dest-more-path))
    (error "~S is not a legitimate path!" destination-path))
  (cond ((and (eq (handle-type source-handle) :frame)
          (member (handle-type dest-handle) '(:frame :token :frame-feature
                          :token-feature)))
     (when (member (handle-type dest-handle) '(:token :token-feature))
       (unless (integerp (handle-token dest-handle))
         (error "Cannot copy a frame definition to an ambigous token: ~S to ~S" source-path
            destination-path)))
     (when (and (eq (handle-type dest-handle) :token)
            (null dest-more-path))
       (error "Cannot copy a frame definition to a token: ~S to ~S" source-path
          destination-path))
     (when (and (eq (handle-type dest-handle) :frame)
            (null dest-more-path))
       (if clobber-p
           (progn (setf dest-parsed-path (destroy dest-handle))
              (multiple-value-setq (dest-handle dest-more-path)
            (make-handle-from-parsed-path dest-parsed-path)))
           (error "Frame already exists: ~S !" destination-path)))
     (setf dest-handle
           (create (cons dest-handle dest-more-path)
               :frame-features (mapcar
                     #'(lambda (ffpair
                             &aux (ffdescr (rest ffpair)))
                           `(,(first ffpair)
                              ,(fdescr-docstring ffdescr)
                              ,(keyword-from-dt
                             (fdescr-type ffdescr))))
                     (frame-feature-alist
                       (handle-frame source-handle)))
               :token-features (mapcar
                     #'(lambda (fdescr)
                           `(,(fdescr-featurename fdescr)
                              ,(fdescr-docstring fdescr)
                              ,(keyword-from-dt
                             (fdescr-type fdescr))
                              :if-needed
                              ,(fdescr-if-needed fdescr)
                              :if-getting
                              ,(fdescr-if-getting fdescr)
                              :if-setting
                              ,(fdescr-if-setting fdescr)))
                     (frame-token-set-feature-vector
                       (handle-frame
                         source-handle)))
               ))
     (setf (frame-documentation
         (handle-frame dest-handle))
           (frame-documentation
         (handle-frame source-handle)))
     dest-handle)
    ((and (eq (handle-type source-handle) :token)
          (eq (handle-type dest-handle)   :frame)
          (null dest-more-path))
     (let ((dummy-handle (make-handle :type :token
                      :frame (handle-frame dest-handle)
                      :token :?)))
          (map nil
           #'(lambda (fdescr)
                 (define-feature (list dummy-handle
                           (fdescr-featurename fdescr))
                         (fdescr-docstring fdescr)
                         (keyword-from-dt (fdescr-type fdescr))
                         :if-needed
                         (fdescr-if-needed fdescr)
                         :if-getting
                         (fdescr-if-getting fdescr)
                         :if-setting
                         (fdescr-if-setting fdescr)))
           (frame-token-set-feature-vector
             (handle-frame source-handle)))
          )
     dest-handle)
    (t (error "~S is not a valid object for COPY-DEFINITION" source-path))
    )
  )


(defun move (source-path destination-path &optional (clobber-p nil)
         &aux source-parsed-path source-handle source-more-path
          dest-parsed-path dest-handle dest-more-path)
  "MOVE source-path destination-path &OPTIONAL (clobber-p nil) -
Moves the source frame or tokensequence to the destination path.  The source must
specify either a frame or a tokensequence(?) and the destination a frame.  If the
destination already exists and clobber-p is non-nil, it will be destroyed (or
cleared), before the move."
  (setf source-parsed-path (parse-token-name source-path))
  (multiple-value-setq (source-handle source-more-path)
    (make-handle-from-parsed-path source-parsed-path))
  (unless (and source-handle
           (check-terminal-path source-handle source-more-path))
    (error "~S is not a legitimate path!" source-path))
  (unless (null source-more-path)
    (error "~S does not exist!" source-path))
  (setf dest-parsed-path (parse-token-name destination-path))
  (multiple-value-setq (dest-handle dest-more-path)
    (make-handle-from-parsed-path dest-parsed-path))
  (unless (and dest-handle
           (check-terminal-path dest-handle dest-more-path))
    (error "~S is not a legitimate path!" destination-path))
  (cond ((and (eq (handle-type source-handle) :frame)
          (member (handle-type dest-handle) '(:frame :token :frame-feature
                          :token-feature)))
     (when (member (handle-type dest-handle) '(:token :token-feature))
       (unless (integerp (handle-token dest-handle))
         (error "Cannot move a frame to an ambigous token: ~S to ~S" source-path
            destination-path)))
     (when (and (eq (handle-type dest-handle) :token)
            (null dest-more-path))
       (error "Cannot move a frame to a token: ~S to ~S" source-path
          destination-path))
     (when (and (eq (handle-type dest-handle) :frame)
            (null dest-more-path))
       (if clobber-p
           (progn (setf dest-parsed-path (destroy dest-handle))
              (multiple-value-setq (dest-handle dest-more-path)
            (make-handle-from-parsed-path dest-parsed-path)))
           (error "Frame already exists: ~S !" destination-path)))
     (setf dest-handle
           (create (cons dest-handle dest-more-path)
               :frame-features (mapcar
                     #'(lambda (ffpair
                             &aux (ffdescr (rest ffpair)))
                           `(,(first ffpair)
                              ,(fdescr-docstring ffdescr)
                              ,(keyword-from-dt
                              (fdescr-type ffdescr))
                              ))
                     (frame-feature-alist
                       (handle-frame source-handle)))
               :token-features (mapcar
                     #'(lambda (fdescr)
                           `(,(fdescr-featurename fdescr)
                              ,(fdescr-docstring fdescr)
                              ,(keyword-from-dt
                             (fdescr-type fdescr))
                              :if-needed
                              ,(fdescr-if-needed fdescr)
                              :if-getting
                              ,(fdescr-if-getting fdescr)
                              :if-setting
                              ,(fdescr-if-setting fdescr)))
                     (frame-token-set-feature-vector
                       (handle-frame
                         source-handle)))
               ))
     (setf (frame-documentation
         (handle-frame dest-handle))
           (frame-documentation
         (handle-frame source-handle))
           (frame-source-file-list
         (handle-frame dest-handle))
           (frame-source-file-list
         (handle-frame source-handle))
           )
     (map nil
          #'(lambda (ffpair &aux (ffdescr (rest ffpair)) value)
           (setf value (fdescr-value ffdescr))
           (cond ((equalp value (case (fdescr-type ffdescr)
                          ((#.*int* #.*boolean*) *int-undefined*)
                          (#.*real* *real-undefined*)
                          (t *ptr-undefined*)))
              (setf value :uncalculated))
             ((equalp value (case (fdescr-type ffdescr)
                          ((#.*int* #.*boolean*) *int-undefinable*)
                          (#.*real* *real-undefinable*)
                          (t *ptr-undefinable*)))
              (setf value :undefined))
             )
           (unless (eq value :uncalculated)
             (setf (value (list dest-handle (first ffpair))) value)))
          (frame-feature-alist
        (handle-frame source-handle)))
     (do-active-tokens (token-index (frame-token-set-existence-vector
                      (handle-frame source-handle)))
         (create (list dest-handle token-index)
             :token-init-list
             (mapcan
               #'(lambda (fdescr &aux value)
                (setf value (vvref (fdescr-value fdescr) token-index))
                (cond ((equalp value (case (fdescr-type fdescr)
                               ((#.*int* #.*boolean*)
                            *int-undefined*)
                               (#.*real* *real-undefined*)
                               (t *ptr-undefined*)))
                   (setf value :uncalculated))
                  ((equalp value (case (fdescr-type fdescr)
                               ((#.*int* #.*boolean*)
                            *int-undefinable*)
                               (#.*real* *real-undefinable*)
                               (t *ptr-undefinable*)))
                   (setf value :undefined))
                  )
                (unless (eq value :uncalculated)
                  (list
                (list (fdescr-featurename fdescr)
                      value))))
               (frame-token-set-feature-vector (handle-frame
                             source-handle)))))
     (destroy source-handle)
     dest-handle)
    ((and (eq (handle-type source-handle) :token)
          (eq (handle-type dest-handle) :frame))
     (if (null dest-more-path)
         (progn
           (when (not (zerop (active-token-count (handle-frame dest-handle))))
         (if clobber-p
             (do-active-tokens (token-index (frame-token-set-existence-vector
                              (handle-frame dest-handle)))
                       (destroy (list dest-handle token-index)))
             (error "Frame token set not empty: ~S !" destination-path))
         )
           (copy-definition source-handle dest-handle))
         (setf dest-handle
           (create (cons dest-handle dest-more-path)
               :token-features (mapcar
                     #'(lambda (fdescr)
                           `(,(fdescr-featurename fdescr)
                              ,(fdescr-docstring fdescr)
                              ,(keyword-from-dt
                             (fdescr-type fdescr))
                              :if-needed
                              ,(fdescr-if-needed fdescr)
                              :if-getting
                              ,(fdescr-if-getting fdescr)
                              :if-setting
                              ,(fdescr-if-setting fdescr)))
                     (frame-token-set-feature-vector
                       (handle-frame
                         source-handle)))
               )
           (frame-documentation
         (handle-frame dest-handle))
           (frame-documentation
         (handle-frame source-handle))
           (frame-source-file-list
         (handle-frame dest-handle))
           (frame-source-file-list
         (handle-frame source-handle))
           )
         )
     (let ((dummy-handle (copy-handle source-handle)))
          (do-active-tokens (token-index (frame-token-set-existence-vector
                           (handle-frame source-handle)))
         (create (list dest-handle token-index)
             :token-init-list
             (mapcan
               #'(lambda (fdescr &aux value)
                (setf value (vvref (fdescr-value fdescr) token-index))
                (cond ((equalp value (case (fdescr-type fdescr)
                               ((#.*int* #.*boolean*)
                            *int-undefined*)
                               (#.*real* *real-undefined*)
                               (t *ptr-undefined*)))
                   (setf value :uncalculated))
                  ((equalp value (case (fdescr-type fdescr)
                               ((#.*int* #.*boolean*)
                            *int-undefinable*)
                               (#.*real* *real-undefinable*)
                               (t *ptr-undefinable*)))
                   (setf value :undefined))
                  )
                (unless (eq value :uncalculated)
                  (list
                (list (fdescr-featurename fdescr)
                      value))))
               (frame-token-set-feature-vector (handle-frame
                             source-handle))))
         (setf (handle-token dummy-handle) token-index)
         (destroy dummy-handle)))
     dest-handle)
    (t (error "~S is not a valid object for MOVE" source-path))
    )
  )

(defun rename (source-path newname &aux source-parsed-path source-handle
           source-more-path parent-frame)
  "RENAME source-path newname -
Rename the last element in source path to newname"
  (setf source-parsed-path (parse-token-name source-path))
  (multiple-value-setq (source-handle source-more-path)
    (make-handle-from-parsed-path source-parsed-path))
  (unless (and source-handle
           (check-terminal-path source-handle source-more-path))
    (error "~S is not a legitimate path!" source-path))
  (unless (null source-more-path)
    (error "~S does not exist!" source-path))
  (when (find #\$ (string newname))
    (error "Newname is the name of a frame, not a path. Therefore ~S should not have a dollar sign" newname))
  (setf parent-frame (parent source-handle))
  (unless (or (stringp newname) (symbolp newname))
    (error "Argument must be a string or a symbol: ~S !" newname))
  (setf newname (string-upcase newname))
  (ecase (handle-type source-handle)
     ((:token :token-subset :token-sort)
      (error "Tokens, TSS, and Sorts cannot be renamed: ~S !" source-path))
     (:frame (rename-frame parent-frame source-handle newname))
     (:token-feature (rename-token-feature source-handle newname))
     (:frame-feature (rename-frame-feature source-handle newname))
     )
  )

(defun rename-frame (parent-handle frame-handle newname)
  (if (eq (handle-type parent-handle) :token)
      (let* ((parent-frame (handle-frame parent-handle))
         (frame (handle-frame frame-handle))
         (parent-token-features (frame-token-set-feature-vector parent-frame))
         (parent-newname-feature (first (member newname parent-token-features
                            :test #'equalp
                            :key #'fdescr-featurename)))
         (parent-oldname-feature (first (member (frame-name frame)
                            parent-token-features
                            :test #'equalp
                            :key #'fdescr-featurename)))
         (oldname (frame-name frame))
         )
        (when parent-newname-feature
          (error "Cannot rename frame - frame already exists: ~S"
             (list parent-handle newname)))
        (setf (fdescr-featurename parent-oldname-feature) newname)
        (setf (frame-name frame) newname)
        (setf (first (last (frame-path-list frame))) newname)
        (fixup-child-frame-path-lists frame (1- (length (frame-path-list frame)))
                      oldname newname)
        frame-handle)
      (let* ((parent-frame (handle-frame parent-handle))
         (frame (handle-frame frame-handle))
         (parent-frame-features (frame-feature-alist parent-frame))
         (parent-newname-feature (assoc newname parent-frame-features
                        :test #'equalp))
         (parent-oldname-feature (assoc (frame-name frame) parent-frame-features
                        :test #'equalp))
         (oldname (frame-name frame))
         )
        (when parent-newname-feature
          (error "Cannot rename frame - frame already exists: ~S"
             (list parent-handle newname)))
        (setf (first parent-oldname-feature) newname)
        (setf (fdescr-featurename (rest parent-oldname-feature)) newname)
        (setf (frame-name frame) newname)
        (setf (first (last (frame-path-list frame))) newname)
        (fixup-child-frame-path-lists frame (1- (length (frame-path-list frame)))
                      oldname newname)
        frame-handle)
      )
  )

(defun fixup-child-frame-path-lists (frame depth oldname newname)

  (map nil #'(lambda (ffeat &aux (ffdescr (rest ffeat)) sub-frame-handle
                sub-frame pathlist pathp)
        (when (and (= (fdescr-type ffdescr) *handle*)
               (handle-p (setf sub-frame-handle (fdescr-value ffdescr)))
               (eq (handle-type sub-frame-handle) :frame)
               (progn (setf sub-frame (handle-frame sub-frame-handle))
                  (eq (handle-frame (frame-parent sub-frame))
                      frame)))
          (setf pathlist (frame-path-list sub-frame)
            pathp    (nthcdr depth pathlist))
          (when (equalp (first pathp) oldname)
            (setf (first pathp) newname)
            (fixup-child-frame-path-lists sub-frame depth oldname newname)
            )))
       (frame-feature-alist frame))
  (map nil #'(lambda (tfdescr &aux (vvec (fdescr-value tfdescr))
                  sub-frame-handle sub-frame pathlist pathp)
        (when (= (fdescr-type tfdescr) *handle*)
          (do-active-tokens (tindex (frame-token-set-existence-vector frame))
             (when (and (handle-p (setf sub-frame-handle
                           (vvref vvec tindex)))
                (eq (handle-type sub-frame-handle) :frame)
                (progn (setf sub-frame (handle-frame sub-frame-handle))
                       (and (eq (handle-frame (frame-parent sub-frame))
                        frame)
                        (eq (handle-token (frame-parent sub-frame))
                        tindex))))
               (setf pathlist (frame-path-list sub-frame)
                 pathp    (nthcdr depth pathlist))
               (when (equalp (first pathp) oldname)
             (setf (first pathp) newname)
             (fixup-child-frame-path-lists sub-frame depth
                               oldname newname)
             )))
          ))
       (frame-token-set-feature-vector frame))
  t)

(defun rename-frame-feature (frame-feature-handle newname)
  (let* ((frame (handle-frame frame-feature-handle))
     (frame-features (frame-feature-alist frame))
     (newname-feature (assoc newname frame-features
                 :test #'equalp))
     (oldname-feature (assoc (handle-feature frame-feature-handle)
                 frame-features
                 :test #'equalp))
     )
    (when newname-feature
      (error "Cannot rename feature - feature already exists: ~S"
         (make-handle :type :frame-feature
                  :frame frame
                  :feature newname
                  :fdescr (rest newname-feature))))
    (setf (first oldname-feature) newname)
    (setf (fdescr-featurename (rest oldname-feature)) newname)
    (setf frame-feature-handle (copy-handle frame-feature-handle))
    (setf (handle-feature frame-feature-handle) newname)
    frame-feature-handle)
  )

(defun rename-token-feature (token-feature-handle newname)
  (let* ((frame (handle-frame token-feature-handle))
     (token-features (frame-token-set-feature-vector frame))
     (newname-feature (member newname token-features
                 :test #'equalp
                 :key #'fdescr-featurename))
     (oldname-feature (member (handle-feature token-feature-handle)
                  token-features
                 :test #'equalp
                 :key #'fdescr-featurename))
     )
    (when newname-feature
      (error "Cannot rename feature - feature already  exists: ~S"
         (make-handle :type :token-feature
                  :frame frame
                  :feature newname
                  :fdescr (first newname-feature))))
    (setf (fdescr-featurename (first oldname-feature)) newname)
    (setf token-feature-handle (copy-handle token-feature-handle))
    (setf (handle-feature token-feature-handle) newname)
    token-feature-handle)
  )

(defun describe-isr-object (path &key (stream *standard-output*)
                (verbose t) &aux parsed-path handle
                more-parsed-path)
  "DESCRIBE-isr-object path &KEY (stream *standard-output*) (verbose t) -
Describe ISR object at the end of path. If stream is NIL, then no printing is
done.  Verbose controls how verbose the output is.  If non-NIL, the features in
a frame are listed, the values of a token's feature values are listed, and the value
of a frame feature handle is printed.  If verbose is NIL, this information is NOT
printed."
  (setf parsed-path (parse-token-name path))
  (multiple-value-setq (handle more-parsed-path)
    (make-handle-from-parsed-path parsed-path))
  (unless (and handle
           (null more-parsed-path))
    (error "~S is not a legitimate path!" path))
  (when stream
    (let ((frame (handle-frame handle)))
     (case (handle-type handle)
           (:frame
         (format stream "~2&It is an ISR Frame object ~S~%" handle)
         (format stream "~&Name: ~A~%" (frame-name frame))
         (format stream "~&Documentation: ~A~%" (frame-documentation frame))
         (format stream "~&Source files: ~S~%" (frame-source-file-list frame))
         (format stream "~&Tokens: ~D/~D~%" (active-token-count frame)
             (total-token-count frame))
         (format stream "~&~D Frame features, ~D Token features~%"
             (length (frame-feature-alist frame))
             (length (frame-token-set-feature-vector frame)))
         (when verbose
           (when (frame-feature-alist frame)
             (format stream
         "~&Frame features: ~{~<~%                ~1,80:; ~{~A : ~A~}~>~^,~}.~%"
                 (mapcar #'(lambda (ffpair)
                           (list (first ffpair)
                             (elt *type-names*
                              (fdescr-type (rest ffpair)))))
                     (frame-feature-alist frame))))
           (when (frame-token-set-feature-vector frame)
             (format stream
         "~&Token features: ~{~<~%                ~1,80:; ~{~A : ~A~}~>~^,~}.~%"
                 (mapcar #'(lambda (fdescr)
                           (list (fdescr-featurename fdescr)
                             (elt *type-names*
                              (fdescr-type fdescr))))
                     (frame-token-set-feature-vector frame))))
           )
         )
           (:token
         (format stream "~2&It is an ISR token object ~S~%" handle)
         (when verbose
           (map nil
            #'(lambda (fdescr)
                 (format
                   stream
                   "~&  ~A = ~S~%"
                   (fdescr-featurename fdescr)
                   (if (equalp
                     (vvref (fdescr-value fdescr)
                        (handle-token handle))
                     (case (fdescr-type fdescr)
                       (#.*int* *int-undefined*)
                       (#.*real* *real-undefined*)
                       (t *ptr-undefined*)))
                   '**UNCALCULATED**
                   (if (equalp (vvref (fdescr-value fdescr)
                              (handle-token handle))
                           (case (fdescr-type fdescr)
                             (#.*int* *int-undefinable*)
                             (#.*real* *real-undefinable*)
                             (t *ptr-undefinable*))
                           )
                       '**UNDEFINED**
                       (vvref (fdescr-value fdescr)
                          (handle-token handle))))))
            (frame-token-set-feature-vector frame))
           )
         )
           ((:frame-feature :token-feature)
        (let ((fdescr (handle-fdescr handle)))
             (format stream "~2&It is an ISR ~A feature object ~S~%"
                 (if (eq (handle-type handle) :frame-feature)
                 "Frame"
                 "Token")
                 handle)
             (format stream "~&Documentation: ~A~%"
                 (fdescr-docstring fdescr))
             (format stream "~&Data type: ~A~%"
                 (elt *type-names*
                  (fdescr-type fdescr)))
             (when (and verbose (eq (handle-type handle)
                        :frame-feature))
               (format stream "~&Value: ~S~%"
                   (if (equalp (fdescr-value fdescr)
                       (case (fdescr-type fdescr)
                         (#.*int* *int-undefined*)
                         (#.*real* *real-undefined*)
                         (t *ptr-undefined*)))
                   '**UNCALCULATED**
                   (if (equalp (fdescr-value fdescr)
                           (case (fdescr-type fdescr)
                             (#.*int* *int-undefinable*)
                             (#.*real* *real-undefinable*)
                             (t *ptr-undefinable*))
                           )
                       '**UNDEFINED**
                       (fdescr-value fdescr)))))
             ))
           (:token-subset
         (format stream "~2&It is an ISR TokenSubSequence object ~S~%" handle)
         (let ((2vv (handle-token-existence-array handle)))
              (format stream "~&It contains ~D tokens~%"
                  (if (typep 2vv '2index-vector-vector)
                  (active-token-count-2vv 2vv)
                  (length 2vv)))
              ))
           (:token-sort
         (format stream "~2&It is an ISR TokenSort object ~S~%" handle)
         (format stream "~&Sort Key is ~A~%" (handle-feature handle))
         (format stream "~&Sort order is :~A~%" (handle-sort-order handle))
         (format stream "~&It contains ~D tokens~%"
             (length (handle-token-existence-array handle)))
         )
           (t (warn "Cannot describe ~S !" handle))
           )
     )
    )
  handle)

(defun datatype-of (path)
  "DATATYPE-OF path - return the data type code for path."
  (cond ((or (stringp path) (symbolp path) (handle-p path))
     (value (list path 'f_datatype)))
    (t (value (append path (list 'f_datatype)))))
  )

(defun datatypep (path type)
  "DATATYPEP path type - Returns T if feature at path is of type type."
  (eq (datatype-of path) type))

(defun frame-features (frame-path)
  "FRAME-FEATURES-OF-FRAME frame-path - returns a list of feature names for the
frame features in frame-path."
  (let ((frame-handle (%internal-handle frame-path :error-p t :terminal-p t)))
       (unless (and (handle-p frame-handle)
            (eq (handle-type frame-handle) :frame))
     (error "~S is not a frame!" frame-path))
       (append '("DOCUMENTATION" "SOURCE-FILES" "NAME")
           (mapcar #'first
               (frame-feature-alist (handle-frame frame-handle)))))
  )

(defun token-features (frame-path)
  "TOKEN-FEATURES-OF-FRAME frame-path - Returns a list of token set feature
names in frame frame-path."
  (let ((frame-handle (%internal-handle frame-path :error-p t :terminal-p t)))
       (unless (and (handle-p frame-handle)
            (eq (handle-type frame-handle) :frame))
     (error "~S is not a frame!" frame-path))
       (mapcar
     #'fdescr-featurename
     (frame-token-set-feature-vector (handle-frame frame-handle))))
  )

(defun features (path)
  "FEATURES path - Returns a list of frame features iff path is a frame,
TSS, or Sort, or a list of token features iff path is token."
  (let ((handle (%internal-handle path :error-p t :terminal-p t)))
       (case (handle-type handle)
         ((:frame :token-subset :token-sort)
          (frame-features (frame handle)))
         (:token (token-features (frame handle)))
         (t (error "Cannot return a feature list for ~S" path))
         )
       )
  )

(defun ancester-p (frame-handle posible-ancester-frame-handle)
  "Internal function - tests to see if its second argument is an ancester
of its first argument.  *No error checks!*"
  (do ((a-parent (frame-parent (handle-frame frame-handle))
         (frame-parent (handle-frame a-parent))))
      ((or (null a-parent)
       (eq (handle-frame a-parent)
           (handle-frame posible-ancester-frame-handle)))
       (not (null a-parent)))
      )
  )

(defun find-all-decendants (frame-handle)
  "Internal function - finds all of the decendants of its argument."
  (let ((offspring (find-all-decendants1 (handle-frame frame-handle)
                     '()
                     )))
       (setf offspring (delete (handle-frame frame-handle)
                   offspring))
       (do* ((result (cons nil offspring))
         (p result)
         handle)
        ((null (rest p)) (rest result))
        (setf handle (make-handle :type :frame
                      :frame (second p)))
        (cond ((ancester-p handle frame-handle)
           (setf (second p) handle
             p (rest p)))
          (t (setf (rest p) (rest (rest p)))))
        )
       )
  )

(defun find-all-decendants1 (frame offspring)
  "Helper function for find-all-decendants - this is the recursive plunge
function - traverses the frame tree, looking for new elements to add to the
offspring list."
  (unless (member frame offspring)
    (map nil
     #'(lambda (ffpair)
           (when (and (handle-p (fdescr-value (rest ffpair)))
                  (not (eq frame (handle-frame
                           (fdescr-value (rest ffpair))))))
             (setf offspring
               (add-frame (handle-frame (fdescr-value (rest ffpair)))
                      offspring))
             (setf offspring
               (nunion offspring
                   (find-all-decendants1
                     (handle-frame (fdescr-value (rest ffpair)))
                     offspring)))))
     (frame-feature-alist frame))
    (do-active-tokens (tokenindex (frame-token-set-existence-vector frame))
    (map nil
         #'(lambda (fdescr &aux (fvalue-vec (fdescr-value fdescr)))
               (when (= (fdescr-type fdescr) *handle*)
             (let ((token-value-handle (vvref fvalue-vec tokenindex)))
                  (when (and (handle-p token-value-handle)
                     (not (eq (handle-frame token-value-handle)
                          frame)))
                (setf offspring (add-frame (handle-frame
                                 token-value-handle)
                               offspring))
                (setf offspring (nunion offspring
                            (find-all-decendants1
                              (handle-frame
                                token-value-handle)
                              offspring)))
                )
                  )
             )
               )
         (frame-token-set-feature-vector frame))
    )
    )
  offspring)

(defun add-frame (frame list)
  "helper function - does a condition push."
  (unless (member frame list)
    (push frame list))
  list)

(defun sort-by-tree-depth (frame-handle-list)
  "helper function that sorts a frame handle list by depth (as measured
by length of path."
  (sort frame-handle-list
    #'(lambda (handle-1 handle-2)
          (< (length (frame-path-list (handle-frame handle-1)))
             (length (frame-path-list (handle-frame handle-2)))
             )
          )
    )
  )



(export '(handle= make-copy-of-handle))

(defun handle= (h1 h2)
  "HANDLE= h1 h2
Compare two handle objects and return t if they are the \"same\".  \"Sameness\" differs
from what EQUALP would return, since the storage form and pick state are \"don't cares\"
as far as equality is concerned."
  (cond ((not (handle-p h1)) (error "Not a handle: ~S" h1))
    ((not (handle-p h2)) (error "Not a handle: ~S" h2))
    (t (or (eq h1 h2)
           (and (eq (handle-type h1) (handle-type h2))
            (eq (handle-frame h1) (handle-frame h2))
            (case (handle-type h1)
              (:frame t)
              (:token (eq (handle-token h1) (handle-token h2)))
              (:frame-feature (string= (handle-feature h1)
                           (handle-feature h2)))
              (:token-feature (and (eq (handle-token h1)
                           (handle-token h2))
                           (string= (handle-feature h1)
                            (handle-feature h2))))
              (:token-subset (tss= (handle-token-existence-array h1)
                           (handle-token-existence-array h2)))
              (:token-sort (and (string= (handle-feature h1)
                             (handle-feature h2))
                        (eq (handle-sort-order h1)
                        (handle-sort-order h2))
                        (equalp (handle-token-existence-array h1)
                            (handle-token-existence-array h2))))
              (t nil)
              )
            )
           )
       )
    )
  )

(defun tss= (t1 t2)
  (cond ((and (listp t1) (listp t2))
     (equalp t1 t2))
    ((and (typep t1 '2index-vector-vector)
          (typep 21 '2index-vector-vector)
          )
     (equalp t1 t2))
    ((typep t1 '2index-vector-vector)
     (do-active-tokens (tkindex t1)
         (unless (member tkindex t2)
           (return nil)))
     t)
    (t (do-active-tokens (tkindex t2)
         (unless (member tkindex t1)
           (return nil)))
       t)
    )
  )


(defun make-copy-of-handle (handle)
  "MAKE-COPY-OF-HANDLE handle
Does a \"deep\" copy of a handle."
  (cond ((not (handle-p handle))
     (error "Not a handle: ~S" handle))
    ((eq (handle-type handle) :token-subset)
     (make-tss handle))
    ((eq (handle-type handle) :token-sort)
     (copy-token-sort handle))
    (t (copy-handle handle))
    )
  )

(defun copy-token-sort (old-sort &aux new-sort)
  (setf new-sort (copy-handle old-sort)
    (handle-last-picked new-sort) nil
    (handle-token-existence-array new-sort)
    (copy-list (handle-token-existence-array old-sort)))
  new-sort)