home *** CD-ROM | disk | FTP | other *** search
/ vis-ftp.cs.umass.edu / vis-ftp.cs.umass.edu.tar / vis-ftp.cs.umass.edu / pub / Software / ASCENDER / ascendMar8.tar / UMass / ISR / isr2fileio.lisp < prev    next >
Lisp/Scheme  |  1995-04-11  |  85KB  |  2,354 lines
  1. ;; ; -*- Mode:Common-Lisp; Package:isr2; Base:10 -*-
  2. ;;;------------------------------------------------------------------------
  3. ;;; ISR2FileIo.LISP - Functions for saving and loading frames
  4. ;;; Created: Thu May 26 15:19:13 1988
  5. ;;; Author: Robert Heller
  6. ;;;------------------------------------------------------------------------
  7. ;;; Copyright (c) University of Massachusetts 1988
  8. ;;;------------------------------------------------------------------------
  9. ;;; modified 05/01/89 17:18:15 by Bob Collins
  10. ;;;     added code for selecting files by menu, or interactively
  11. ;;;     entering a new filename.  The heart of this code is 
  12. ;;;     menu-choose-source-file.  Function ask-user-for-source-files-to-load 
  13. ;;;     modified to call the choosing code when sub-frame-action is :ask-user.
  14. ;;;     Also, read-frame modified to call choosing code on parent frame when
  15. ;;;     frame-ask-user is non-nil. Global variable *global-directory-search-list*
  16. ;;;     is a list of directories to look through to find file choices to
  17. ;;;     display in the menu.  Changes read-in-decendants to push the directory 
  18. ;;;     of the parent filename onto the directory search list temporarily, if 
  19. ;;;     sub-frame-action is :ask-user.
  20.  
  21. (in-package "ISR2")
  22.  
  23. (export '(store restore write-frame read-frame describe-file))
  24.  
  25. (defmacro with-open-isr2-frame-file ((stream-var fname direction) &body body)
  26.   "Helper macro..."
  27.   `(with-open-file (,stream-var ,fname :direction ,direction
  28.             :element-type '(unsigned-byte 8)
  29.             :if-exists :new-version
  30.             )
  31.      ,@body))
  32.  
  33. (defmacro with-open-isr2-read-frame-file ((stream-var fname frame-path) &body body)
  34.   "Helper macro..."
  35.   `(let ((file-name (if (probe-file ,fname)
  36.             ,fname
  37.             (menu-choose-source-file 
  38.               ,fname (format nil "Choose source file for frame path ~s" ,frame-path)))))
  39.      (with-open-file (,stream-var file-name :direction :input
  40.               :element-type '(unsigned-byte 8)
  41.               )
  42.        ,@body)))
  43.  
  44.  
  45. ;; magic header hacking code
  46.  
  47. (defvar *file-version-number* 1 "File Version number")
  48.  
  49. (defconstant magic-8-byte-header-v0 "ISR2V000"
  50. "This 8-byte sequence is written at the beginning of the file to indicate
  51. that it is an ISR2 (V000) frame file.")
  52.  
  53. (defconstant magic-8-byte-header-v1 "ISR2V001"
  54. "This 8-byte sequence is written at the beginning of the file to indicate
  55. that it is an ISR2 (V001) frame file.")
  56.  
  57. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun write-isr2-header (file)
  58.    (dotimes (i 8)
  59.       (write-byte (char-code (aref magic-8-byte-header-v1 i)) file)))
  60.  
  61. (defun read-and-check-isr2-header (file &aux (header-string (make-string 8)))
  62.    (dotimes (i 8)
  63.       (setf (aref header-string i) (code-char (read-byte file))))
  64.    (cond ((string= header-string magic-8-byte-header-v0)
  65.       (warn "~2&+++ Warning: file ~s is an old format file!~&"
  66.         (truename file))
  67.       0)
  68.      ((string= header-string magic-8-byte-header-v1) 1)
  69.      (t nil)))
  70.  
  71.  
  72. (DEFVAR *WORD* 0 "for byte depositing") 
  73.  
  74. (DEFVAR *TEMP* 0 "for macros, to avoid annoying let gensym stuff") 
  75.  
  76.  
  77. (defvar *null-extents* nil)
  78. (eval-when (compile load eval)
  79.   (setf *null-extents* (make-extents 0 0 0 0 0))) ;written out in place of undefined extents
  80.  
  81. ;; byte fields in multi-byte objects -- NOTE Byte Sex - Low byte first.  This works
  82. ;; for the VAX and the LISP Machine.  Will also work on Intel-based cpus (i.e.
  83. ;; 80386-based SUN's and Sequents).  Beware 68K systems (SUN workstations with
  84. ;; 68020's, Apple MAC's, Atari ST's, etc.)!
  85.  
  86. (defconstant byte0 (byte 8 0))
  87. (defconstant byte1 (byte 8 8))
  88. (defconstant byte2 (byte 8 16))
  89. (defconstant byte3 (byte 8 24))
  90.  
  91. ;;;;======================== LOW LEVEL INPUT =======================================
  92.  
  93. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun read-ubyte8 (stream)
  94.   "Read in an unsigned 8-bit byte"
  95.   (read-byte stream))
  96.  
  97. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun read-ubyte16 (stream)
  98.   "Read in an unsigned 16-bit byte"
  99.   (dpb (read-byte stream) byte0
  100.        (dpb (read-byte stream) byte1 0)))
  101.  
  102. (defconstant max-short-int #x08000)
  103. (defconstant max-ushort-int #x10000)
  104.  
  105. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun read-sbyte16 (stream)
  106.   "Read in a signed 16-bit byte (short int)"
  107.   (let ((temp (read-ubyte16 stream)))
  108.        (if (> temp max-short-int) (- temp max-ushort-int) temp)))
  109.  
  110. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun read-ubyte32 (stream)
  111.   "Read in an unsigned 32-bit byte"
  112.   (dpb (read-byte stream) byte0
  113.        (dpb (read-byte stream) byte1
  114.         (dpb (read-byte stream) byte2
  115.          (dpb (read-byte stream) byte3 0)))))
  116.  
  117. (defconstant max-long-int #x080000000)
  118. (defconstant max-ulong-int #x100000000)
  119. (defconstant MAXINT32 #x0FFFFFFFF)
  120.  
  121. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun read-sbyte32 (stream)
  122.   "Read in a signed 32-bit byte (long int)"
  123.   (let ((temp (read-ubyte32 stream)))
  124.        (if (> temp max-long-int) (- temp max-ulong-int) temp)))
  125.  
  126.  
  127. #+:allegro
  128. (ff:def-c-type fl-union :union (float :single-float) (ub32 :unsigned-long))
  129. #+:lispworks
  130. (foreign::define-foreign-function (float-from-ub32 "convert_float_long" :source)
  131.          ((l :alien)) :result-type :single-float :language :c)
  132. #+:lispworks
  133. (foreign::define-foreign-function (ub32-from-float "convert_long_float" :source)
  134.          ((l :single-float :reference-pass)) :result-type :uinteger :language :c)
  135. #+:lispworks
  136. (eval-when (load eval compile)
  137.        (foreign::define-foreign-type ulong-array (:array :unsigned-long 1) :language :c))
  138. #+:lispworks
  139. (defvar ulong-temp (make-ulong-array))
  140. #+:allegro 
  141. (defvar fl-union-holder (make-fl-union))
  142. #+:allegro
  143. (defun read-float32 (stream)
  144.   (setf (fl-union-ub32 fl-union-holder) (read-ubyte32 stream))
  145.   (fl-union-float fl-union-holder)
  146.   )
  147. #+:lispworks
  148. (defun read-float32 (stream)
  149.    (setf (ulong-array[] ulong-temp 0) (read-ubyte32 stream))
  150.    (float-from-ub32 ulong-temp))
  151.  
  152. #-(or :allegro :lispworks)
  153. (defvar fl-union-ub32 (make-array 1 :element-type '(unsigned-byte 32)))
  154. #-(or :allegro :lispworks)
  155. (defvar fl-union-fl32 (make-array 1 :element-type 'single-float 
  156.                   :displaced-to fl-union-ub32))
  157.  
  158. #-(or :allegro :lispworks)
  159. (defun read-float32 (stream)
  160.   (setf (aref fl-union-ub32 0) (read-ubyte32 stream))
  161.   (aref fl-union-fl32 0))
  162.  
  163. (defun read-isr2-string (file &aux string ch length)
  164.   "Read in a counted string.  The string's length is in a unsigned 16-bit
  165. byte, followed by the ASCII chars of the string followed by a NUL byte
  166. at the end (the NUL byte is counted by the string length byte).  True ASCII
  167. is used, with ASCII HT's for tabs and ASCII LF's for newline marks.  The
  168. rest of the text should be the normal printable ASCII characters (' ' to '~')."
  169.   (setf length (1- (read-ubyte16 file))
  170.     string (make-string length))
  171.   (dotimes (i length)
  172.      (setf ch (read-byte file))
  173.      ;; force character to be a "standard" ASCII character
  174.      ;; (newline using C convention, preserving TABs, trashing all other
  175.      ;; "funny" characters to spaces)
  176.      (cond ((= ch 10) (setf ch #\NEWLINE)) ;; convert LF to #\NEWLINE
  177.        ((= ch 9) (setf ch #\TAB))      ;; convert ASCII HT to #\TAB
  178.        ((< ch 32) (setf ch #\SPACE))   ;; convert all other out-of-range chars
  179.        ((> ch 126) (setf ch #\SPACE))  ;; to #\SPACE
  180.        (t (setf ch (code-char ch))))   ;; normal characters (ASCII ' ' to '~').
  181.      (setf (aref string i) ch))
  182.   ;; gobble null byte at the end (C convention)
  183.   (read-byte file)
  184.   string)
  185.  
  186. (defun read-isr2-string-n (file len &aux string ch length)
  187.   "Read in a counted string.  The string's length is len (already read in).
  188. This function reads in the ASCII chars of the string and the NUL byte
  189. at the end (the NUL byte is counted by the string length byte).  True ASCII
  190. is used, with ASCII HT's for tabs and ASCII LF's for newline marks.  The
  191. rest of the text should be the normal printable ASCII characters (' ' to '~')."
  192.   (setf length (1- len)
  193.     string (make-string length))
  194.   (dotimes (i length)
  195.      (setf ch (read-byte file))
  196.      ;; force character to be a "standard" ASCII character
  197.      ;; (newline using C convention, preserving TABs, trashing all other
  198.      ;; "funny" characters to spaces)
  199.      (cond ((= ch 10) (setf ch #\NEWLINE)) ;; convert LF to #\NEWLINE
  200.        ((= ch 9) (setf ch #\TAB))      ;; convert ASCII HT to #\TAB
  201.        ((< ch 32) (setf ch #\SPACE))   ;; convert all other out-of-range chars
  202.        ((> ch 126) (setf ch #\SPACE))  ;; to #\SPACE
  203.        (t (setf ch (code-char ch))))   ;; normal characters (ASCII ' ' to '~').
  204.      (setf (aref string i) ch))
  205.   ;; gobble null byte at the end (C convention)
  206.   (read-byte file)
  207.   string)
  208.  
  209. ;;;;======================= INTERMEDIATE LEVEL INPUT ==============================
  210.  
  211. (defun read-isr2-sexpr-pkg (file &optional (*package* *package*) &aux sexp)
  212.   (setf sexp (read-from-string (read-isr2-string file)))
  213.   (cond ((and (= *file-version-number* 0)
  214.           (eq sexp *old-ptr-undefined*))
  215.      *ptr-undefined*)
  216.     ((and (= *file-version-number* 0)
  217.           (eq sexp *old-ptr-undefinable*))
  218.      *ptr-undefinable*)
  219.     (t sexp))
  220.   )
  221.  
  222. (defun read-isr2-sexpr-pkg-n (file len &optional (*package* *package*) &aux sexp)
  223.   (setf sexp (read-from-string (read-isr2-string-n file len)))
  224.   (cond ((and (= *file-version-number* 0)
  225.           (eq sexp *old-ptr-undefined*))
  226.      *ptr-undefined*)
  227.     ((and (= *file-version-number* 0)
  228.           (eq sexp *old-ptr-undefinable*))
  229.      *ptr-undefinable*)
  230.     (t sexp))
  231.   )
  232.  
  233. (defvar *old-frame-path* nil "Holds frame path as read and parsed from file")
  234. (defvar *new-frame-path* nil "Holds new frame path as specified in read-frame call")
  235.  
  236. (defun adjust-handle (raw-handle &aux in-frame-parsed-path)
  237.   (if (member raw-handle `(,*ptr-undefined* ,*ptr-undefinable*))
  238.       raw-handle
  239.       (progn
  240.     (setf in-frame-parsed-path
  241.           (adjust-path (parse-token-name raw-handle)))
  242.     (multiple-value-bind (handle more-path)
  243.       (make-handle-from-parsed-path in-frame-parsed-path)
  244.       (if more-path
  245.           (cons handle more-path)
  246.           handle))))
  247.  
  248.   )
  249.                                   
  250.  
  251. (defun adjust-path (in-parsed-path)
  252.   (do ((p1 in-parsed-path (rest p1))
  253.        (p2 *old-frame-path* (rest p2)))
  254.       ((null p2) (append *new-frame-path* p1))
  255.       (unless (and (not (null p1))
  256.            (equalp (first p1) (first p2)))
  257.     (return in-parsed-path)))
  258.   )
  259.         
  260. (defun create-empty-frames-if-needed (handle-spec)
  261.   (do ()
  262.       ((or (eq handle-spec *ptr-undefined*)
  263.        (eq handle-spec *ptr-undefinable*)
  264.        (handle-p handle-spec)
  265.        (or (and (integerp (second handle-spec)) (null (rest (rest handle-spec))))
  266.            (eq (second handle-spec) :?)
  267.            (and (stringp (second handle-spec))
  268.             (string= (subseq (second handle-spec) 0 2) "F_")))
  269.        ) 
  270.        handle-spec)
  271.       (cond ((null (rest handle-spec)) (setf handle-spec (first handle-spec)))
  272.         (t (setf handle-spec (cons (create-stub-frame (list (first handle-spec)
  273.                              (second handle-spec)))
  274.                        (rest (rest handle-spec))))))
  275.       )
  276.   )
  277.  
  278. (defun create-stub-frame (path &aux new-frame-handle new-frame)
  279.   (setf new-frame-handle (create path))
  280.   (when (and (handle-p new-frame-handle) (eq (handle-type new-frame-handle) :frame))
  281.     (setf new-frame (handle-frame new-frame-handle)
  282.       (frame-is-loaded-p new-frame) nil))
  283.   new-frame-handle)
  284.  
  285. (defun read-isr2-tss (file &optional skip &aux frame-path frame-handle flag evv)
  286.   (setf frame-path (read-isr2-string file)
  287.     frame-handle (create-empty-frames-if-needed
  288.                (adjust-handle frame-path)))
  289.   (unless (or skip (and frame-handle
  290.             (handle-p frame-handle)
  291.             (eq (handle-type frame-handle) :frame)))
  292.       (error "I/O Error: Illegal TSS stored in file ~S - frame path was: ~S"
  293.          (namestring (truename file)) frame-path))
  294.   (setf frame-handle (copy-handle frame-handle))
  295.   (setf flag (= (read-ubyte16 file) 0))
  296.   (if flag
  297.       (setf evv (read-isr2-token-list file))
  298.       (setf evv (read-isr2-2vv  file skip)))
  299.   (setf (handle-type frame-handle) :token-subset
  300.     (handle-token-existence-array frame-handle) evv)
  301.   (if skip (make-null-tss! frame-handle) frame-handle)
  302.   )
  303.  
  304. (defvar *sort-fixup-list* nil "List of sort objects to be fixed up")
  305.  
  306. (defun read-isr2-tsort (file &optional skip &aux frame-path frame-handle flag 
  307.                  sort-order fname evv)
  308.   (setf frame-path (read-isr2-string file)
  309.     frame-handle (adjust-handle frame-path))
  310.   (unless (or skip (and frame-handle
  311.             (handle-p frame-handle)
  312.             (eq (handle-type frame-handle) :frame)))
  313.     (error "I/O Error: Illegal Sort stored in file ~S - frame path was: ~S"
  314.        (namestring (truename file)) frame-path))
  315.   (unless (handle-p frame-handle) (setf frame-handle (make-handle)))
  316.   (setf fname (read-isr2-string file))
  317.   (setf flag (= (read-ubyte16 file) 0))
  318.   (if flag
  319.       (setf sort-order :ascending)
  320.       (setf sort-order :descending))
  321.   (setf evv (read-isr2-token-list file))
  322.   (setf (handle-type frame-handle) :token-sort
  323.     (handle-token-existence-array frame-handle) evv
  324.     (handle-sort-order frame-handle) sort-order
  325.     (handle-feature frame-handle) fname)
  326.   (push frame-handle *sort-fixup-list*)
  327.   frame-handle
  328.   )
  329.  
  330. (defun fixup-sorts ()
  331.   (map nil #'(lambda (sort)
  332.              (setf (handle-fdescr sort)
  333.                (first (member (handle-feature sort)
  334.                       (frame-token-set-feature-vector
  335.                         (handle-frame sort))
  336.                       :test #'equalp
  337.                       :key #'fdescr-featurename))))
  338.        *sort-fixup-list*))
  339.  
  340. (defun read-isr2-token-list (file &aux len result)
  341.   (setf len (read-ubyte16 file)
  342.     result (make-list len))
  343.   (do ((p result (rest p)))
  344.       ((null p))
  345.       (setf (first p) (read-ubyte32 file)))
  346.   result)
  347.  
  348. (defun read-isr2-2vv (file &optional skip &aux type-code result block-count 
  349.                low val ovec ivec ov)
  350.   (setf type-code (read-ubyte16 file))
  351.   (setf result (make-2index-vector-vector type-code))
  352.   (setf block-count (read-ubyte16 file))
  353.   (setf ovec (2index-vector-vector-data result))
  354.   (dotimes (k block-count)
  355.      (setf low (read-ubyte32 file))
  356.      (add-2index-vector result (setf ov (truncate 
  357.                       low
  358.                       *default-2index-vector-size*)))
  359.      (setf ivec (2index-vector-data-vector (aref ovec ov)))
  360.      (cond ((= type-code *boolean*)
  361.         (read-bits-into-bvec file ivec *default-2index-vector-size*))
  362.        (t (dotimes (iv *default-2index-vector-size*)
  363.          (setf val (case type-code
  364.                  (#.*int* (read-sbyte32 file))
  365.                  (#.*real* (read-float32 file))
  366.                  (#.*handle* (read-isr2-handle file skip))
  367.                  (#.*extents* (read-isr2-extents file))
  368.                  (#.*bitplane* (read-isr2-bitplane file))
  369.                  (#.*array* (read-isr2-array file))
  370.                  (#.*string* (read-isr2-sexpr-pkg 
  371.                            file
  372.                            (find-package (if (= *file-version-number* 0) 'user 'isr2))))
  373.                  (#.*pointer* (read-isr2-sexpr-pkg 
  374.                         file
  375.                         (find-package (if (= *file-version-number* 0) 'user 'isr2))))))
  376.          (setf (aref ivec iv) val))))
  377.      )
  378.   (if skip (progn (free-2vv result) nil) result))
  379.  
  380. #-(or :allegro :lispworks)
  381. (defun read-bits-into-bvec (file vec size &aux byte-vec)
  382.   (setf byte-vec (make-array (ceiling size 8) :element-type '(unsigned-byte 8)
  383.                  :displaced-to vec))
  384.   (dotimes (ib (ceiling size 8))
  385.      (setf (aref byte-vec ib) (read-ubyte8 file)))
  386.   vec)
  387.  
  388. #+(or :allegro :lispworks)
  389. (defmacro getbit (thebyte ibit)
  390.   `(ldb (byte 1 ,ibit) ,thebyte))
  391. #+(or :allegro :lispworks)
  392. (defmacro setbit (thebyte ibit newbit)
  393.   `(setf ,thebyte (dpb ,newbit (byte 1 ,ibit) ,thebyte)))
  394.  
  395. #+(or :allegro :lispworks)
  396. (defun read-bits-into-bvec (file vec size &aux flat-bits)
  397.   (setf flat-bits (make-array size :element-type 'bit :displaced-to vec))
  398.   (dotimes (ib (ceiling size 8))
  399.        (let ((abyte (read-ubyte8 file)))
  400.         (dotimes (ibit 8)
  401.              (setf (aref flat-bits (+ (* ib 8) ibit)) (getbit abyte ibit))
  402.              ))
  403.        )
  404.   vec)
  405.  
  406. (defconstant tss-header-tag-as-16-bit-ubyte
  407.          (dpb (char-code #\#) byte0
  408.           (dpb (char-code #\T) byte1 0)))
  409.  
  410. (defconstant sort-header-tag-as-16-bit-ubyte
  411.          (dpb (char-code #\#) byte0
  412.           (dpb (char-code #\S) byte1 0)))
  413.  
  414. (defun read-isr2-handle (file &optional skip)
  415.   (let ((start-tag (read-ubyte16 file)))
  416.        (cond ((= start-tag tss-header-tag-as-16-bit-ubyte)
  417.           (read-isr2-tss file skip))
  418.          ((= start-tag sort-header-tag-as-16-bit-ubyte)
  419.           (read-isr2-tsort file skip))
  420.          (t (create-empty-frames-if-needed
  421.           (adjust-handle
  422.             (read-isr2-sexpr-pkg-n
  423.               file start-tag (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  424.         )
  425.          )
  426.        )
  427.   )
  428.  
  429. (defun read-isr2-extents (file)
  430.   (let ((pixcount (read-ubyte32 file)))        ; pixel-count
  431.        (if (= pixcount 0)
  432.        *ptr-undefined*
  433.        (if (= pixcount MAXINT32)
  434.            *ptr-undefinable*
  435.            (make-extents pixcount    
  436.                  (read-sbyte16 file)    ; minx (mincol)
  437.                  (read-sbyte16 file)    ; miny (minrow)
  438.                  (read-sbyte16 file)    ; maxx (maxcol)
  439.                  (read-sbyte16 file))))    ; maxy (maxrow)
  440.        )
  441.   )
  442.  
  443. (defun read-isr2-bitplane (file)
  444.   (let ((numbytes (read-ubyte32 file)))        ; total byte count
  445.        (if (= numbytes 0)
  446.        *ptr-undefined*
  447.        (if (= numbytes MAXINT32)
  448.            *ptr-undefinable*
  449.            (let* ((bit-width (read-ubyte16 file))    ; total number of bit columns
  450.               (bit-height (read-ubyte16 file))   ; total number of bit rows
  451.               (byte-width (ceiling bit-width 8)) ; total number of byte columns
  452.               )
  453.              ;; check for consistent data
  454.              (unless (= (* byte-width bit-height) numbytes)
  455.                (error "Number of bytes in bitplane is ~D, it should be ~D" numbytes
  456.                   (* byte-width bit-height)))
  457.              ;; read in bitplane, padding to longword boundary if needed
  458.              ; compute next highest multiple of 32 bits
  459.              
  460.              (let ((new-byte-width (* 4 (ceiling byte-width 4)))
  461.                #+:EXPLORER (default-cons-area *bitplane-area*))
  462.               #+:EXPLORER (declare (special default-cons-area))
  463.               #-(or :allegro :lispworks)
  464.               (let ((bitplane (make-array (list bit-height new-byte-width)
  465.                               :element-type '(unsigned-byte 8))))
  466.                    ;read in bitplane, a byte at a time
  467.                    (dotimes (y bit-height)
  468.                     (dotimes (x byte-width)
  469.                          (setf (aref bitplane y x)
  470.                                (read-ubyte8 file))))
  471.                    (make-array (list bit-height (* 8 new-byte-width))
  472.                        :element-type 'bit
  473.                        :displaced-to bitplane))
  474.               #+(or :allegro :lispworks)
  475.               (let ((bitplane (make-array (list bit-height 
  476.                                 (* new-byte-width 8)
  477.                               :element-type 'bit))))
  478.                    ;read in bitplane, a byte at a time
  479.                    (dotimes (y bit-height)
  480.                     (dotimes (x byte-width)
  481.                          (let ((abyte (read-ubyte8 file)))
  482.                               (dotimes (ibit 8)
  483.                                    (setf (aref bitplane
  484.                                        y (+ (* 8 x)
  485.                                         ibit))
  486.                                      (getbit abyte ibit))))
  487.                          ))
  488.                    bitplane)
  489.               ))
  490.            )
  491.        )
  492.        )
  493.   )
  494.  
  495. (defun read-isr2-array (file)
  496.   (let ((numdims (read-ubyte16 file)))
  497.        (if (= numdims #x0FFFF)
  498.        *ptr-undefined*
  499.        (if (= numdims #x0FFFE)
  500.            *ptr-undefinable*
  501.            (let ((dimlist (make-list numdims))
  502.              array flat-array)
  503.             (do ((p dimlist (rest p)))
  504.             ((null p))
  505.             (setf (first p) (read-ubyte32 file)))
  506.             (case (read-ubyte16 file)
  507.               (#.*boolean*
  508.                 (setf array (make-array dimlist :element-type 'bit))
  509.                 (read-bits-into-bvec file array (length array)))
  510.               (#.*real*
  511.                 (setf array (make-array dimlist :element-type 'single-float))
  512.                 (setf flat-array (make-array (length array)
  513.                              :element-type 'single-float
  514.                              :displaced-to array))
  515.                 (dotimes (i (length flat-array))
  516.                      (setf (aref flat-array i) (read-float32 file)))
  517.                 )
  518.               (#.*int*
  519.                 (setf array (make-array dimlist :element-type 'fixnum))
  520.                 (setf flat-array (make-array (length array)
  521.                              :element-type 'fixnum
  522.                              :displaced-to array))
  523.                 (dotimes (i (length flat-array))
  524.                      (setf (aref flat-array i) (read-sbyte32 file)))
  525.                 )
  526.               (#.*pointer*
  527.                 (setf array (make-array dimlist :element-type 't))
  528.                 (setf flat-array (make-array (length array)
  529.                              :element-type 't
  530.                              :displaced-to array))
  531.                 (dotimes (i (length flat-array))
  532.                      (setf (aref flat-array i) (read-isr2-sexpr-pkg 
  533.                                  file
  534.                                  (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  535.                 )
  536.               )
  537.             array))
  538.        )
  539.        )
  540.   )
  541.         
  542.         
  543.  
  544. ;;;;========================= LOW LEVEL OUTPUT ====================================
  545.  
  546. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun write-byte8 (stream value)
  547.   "write a signed or unsigned 8 bit value to the stream."
  548.   (write-byte value stream))
  549.  
  550. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun write-byte16 (stream value)
  551.   "write a signed or unsigned 16 bit value to the stream."
  552.      (write-byte (ldb byte0 value) stream)
  553.      (write-byte (ldb byte1 value) stream)
  554.      value)
  555.  
  556. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun write-byte32 (stream val)
  557.   "write a signed or unsigned 32 bit value to the stream."
  558.      (write-byte (ldb byte0 val) stream)
  559.      (write-byte (ldb byte1 val) stream)
  560.      (write-byte (ldb byte2 val) stream)
  561.      (write-byte (ldb byte3 val) stream)
  562.      val)
  563.  
  564. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun write-int32 (stream val)
  565.   "write 25-bit signed integer as a 32-bit signed integer"
  566.      (write-byte (ldb byte0 val) stream)
  567.      (write-byte (ldb byte1 val) stream)
  568.      (write-byte (ldb byte2 val) stream)
  569.      (if (evenp (ldb byte3 val))
  570.      (write-byte 0 stream)    ;positive
  571.      (write-byte 255 stream)) ;negative
  572.      val)
  573.  
  574. #+:lispworks 
  575. (defun write-float32 (stream flonum)
  576.   (write-byte32 stream (ub32-from-float flonum)))
  577. #+:allegro
  578. (defun write-float32 (stream flonum)
  579.   (setf (fl-union-float fl-union-holder) flonum)
  580.   (write-byte32 stream (fl-union-ub32 fl-union-holder))
  581.   flonum)
  582.  
  583. #-(or :allegro :lispworks)
  584. (defun write-float32 (stream flonum)
  585.   (setf (aref fl-union-fl32 0) flonum)
  586.   (write-byte32 stream (aref fl-union-ub32 0))
  587.   flonum)
  588.  
  589.  
  590. (defun write-isr2-string (file string &aux ch)
  591.   "Write a string to an ISR2 data file.  The string is written as a standard
  592. ASCII string, using C conventions:  #\NEWLINE becomes ASCII LF ('\n'), #\TAB
  593. becomes ASCII HT.  Any other characters outside of the normal printable ASCII
  594. set become spaces.  A NUL byte is written after the last character.  The string
  595. is preceded by its length (plus the NUL byte) as a unsigned 16-bit byte."
  596.   (write-byte16 file (1+ (length string)))
  597.   (dotimes (i (length string))
  598.      (setf ch (aref string i))
  599.      ;; force character to be a string char
  600.      (unless (typep ch 'string-char)
  601.        (setf ch (make-char ch)))
  602.      ;; force character to be a "standard" ASCII character
  603.      ;; (newline using C convention, preserving TABs, trashing all other
  604.      ;; "funny" characters to spaces)
  605.      (cond ((eql ch #\NEWLINE) (setf ch 10))    ;; convert #\NEWLINE to LF
  606.        ((eql ch #\TAB) (setf ch 9))        ;; convert #\TAB to ASCII HT
  607.        ((char< ch #\space) (setf ch 32))    ;; convert all other "strange"
  608.        ((char> ch #\~) (setf ch 32))    ;; chars to #\SPACE
  609.        (t (setf ch (char-code ch))))    ;; Normal character
  610.      (write-byte ch file))
  611.   ;; append a null byte to the end (C convention)
  612.   (write-byte 0 file)
  613.   string)
  614.  
  615. (defun write-isr2-sexpr-pkg (file sexpr &optional (*package* *package*))
  616.   (write-isr2-string 
  617.     file
  618.     (write-to-string sexpr :escape t :radix nil :base 10 :circle nil
  619.              :pretty nil :level nil :length nil :case :upcase
  620.              :gensym t :array t)))
  621.  
  622. (defun write-isr2-tss (file tss &aux frame-path evv)
  623.   (setf frame-path (frame-path (handle-frame tss))
  624.     evv (handle-token-existence-array tss))
  625.   (write-byte16 file tss-header-tag-as-16-bit-ubyte)
  626.   (write-isr2-string file frame-path)
  627.   (if (typep evv '2index-vector-vector)
  628.       (progn
  629.     (write-byte16 file #x0ffff)
  630.     (write-isr2-2vv file evv))
  631.       (progn
  632.     (write-byte16 file 0)
  633.     (write-isr2-token-list file evv))
  634.       )
  635.   tss)
  636.  
  637. (defun write-isr2-tsort (file sort &aux frame-path evv)
  638.   (setf frame-path (frame-path (handle-frame sort))
  639.     evv (handle-token-existence-array sort))
  640.   (write-byte16 file sort-header-tag-as-16-bit-ubyte)
  641.   (write-isr2-string file frame-path)
  642.   (write-isr2-string file (handle-feature sort))
  643.   (write-byte16 file (if (eq (handle-sort-order sort) :ascending) 0 #xffff))
  644.   (write-isr2-token-list file evv)
  645.   sort)
  646.  
  647. (defun write-isr2-token-list (file list)
  648.   (write-byte16 file (length list))
  649.   (dolist (tok list)
  650.      (write-byte32 file tok))
  651.   list)
  652.  
  653. (defun write-isr2-2vv (file 2vv &aux type-code)
  654.   (setf type-code (case (2index-vector-vector-resource-type 2vv)
  655.             (2index-bin-vector *boolean*)
  656.             (2index-int-vector *int*)
  657.             (2index-real-vector *real*)
  658.             (2index-ptr-vector *pointer*)
  659.             (2index-ary-vector *array*)
  660.             (2index-bp-vector *bitplane*)
  661.             (2index-extents-vector *extents*)
  662.             (2index-handle-vector *handle*)
  663.             (2index-string-vector *string*)
  664.             ))
  665.   (write-byte16 file type-code)
  666.   (write-byte16 file (count-used-blocks 2vv))
  667.   (let* ((outer-vec (2index-vector-vector-data 2vv))
  668.      (max-ov (fill-pointer outer-vec))
  669.      ivec-block ivec)
  670.     (dotimes (ov max-ov)
  671.        (when (setf ivec-block (aref outer-vec ov))
  672.          (write-byte32 file (2index-vector-start-index ivec-block))
  673.          (setf ivec (2index-vector-data-vector ivec-block))
  674.          (cond ((= type-code *boolean*)
  675.             (write-bits-from-bvec file ivec *default-2index-vector-size*))
  676.            (t (dotimes (iv *default-2index-vector-size*)
  677.               (case type-code
  678.                  (#.*int* (write-int32 file (aref ivec iv)))
  679.                  (#.*real* (write-float32 file (aref ivec iv)))
  680.                  (#.*handle* (write-isr2-handle file (aref ivec iv)))
  681.                  (#.*extents* (write-isr2-extents file (aref ivec iv)))
  682.                  (#.*bitplane* (write-isr2-bitplane file (aref ivec iv)))
  683.                  (#.*array* (write-isr2-array file (aref ivec iv)))
  684.                  (#.*string* (write-isr2-string file (aref ivec iv)))
  685.                  (#.*pointer* (write-isr2-sexpr-pkg 
  686.                         file
  687.                         (aref ivec iv)
  688.                         (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  689.               ))
  690.            )
  691.          )
  692.        )
  693.     )
  694.   2vv)
  695.  
  696. (defun write-partial-2vv (file exist-vect-2vv 2vv &aux type-code)
  697.   (setf type-code (case (2index-vector-vector-resource-type 2vv)
  698.             (2index-bin-vector *boolean*)
  699.             (2index-int-vector *int*)
  700.             (2index-real-vector *real*)
  701.             (2index-ptr-vector *pointer*)
  702.             (2index-ary-vector *array*)
  703.             (2index-bp-vector *bitplane*)
  704.             (2index-extents-vector *extents*)
  705.             (2index-handle-vector *handle*)
  706.             (2index-string-vector *string*)
  707.             ))
  708.   (write-byte16 file type-code)
  709.   (write-byte16 file (count-used-blocks-exist 2vv exist-vect-2vv))
  710.   (let* ((outer-data-vec (2index-vector-vector-data 2vv))
  711.      (outer-exist-vec (2index-vector-vector-data exist-vect-2vv))
  712.      (max-ov (min (fill-pointer outer-data-vec)
  713.               (fill-pointer outer-exist-vec)))
  714.      ivec-data-block ivec-data ivec-exist-block ivec-exist)
  715.     (dotimes (ov max-ov)
  716.       (setf ivec-data-block (aref outer-data-vec ov))
  717.       (setf ivec-exist-block (aref outer-exist-vec ov))
  718.       (when (and ivec-data-block ivec-exist-block)
  719.          (write-byte32 file (2index-vector-start-index ivec-data-block))
  720.          (setf ivec-data (2index-vector-data-vector ivec-data-block))
  721.          (setf ivec-exist (2index-vector-data-vector ivec-exist-block))
  722.          (cond ((= type-code *boolean*)
  723.             (write-bits-from-bvec-logand
  724.               file ivec-exist
  725.               ivec-data *default-2index-vector-size*))
  726.            (t (dotimes (iv *default-2index-vector-size*)
  727.              (case type-code
  728.                    (#.*int* (write-int32 
  729.                       file
  730.                       (if (= (aref ivec-exist iv) 1)
  731.                           (aref ivec-data iv)
  732.                           *int-undefined*)))
  733.                    (#.*real* (write-float32 
  734.                        file
  735.                        (if (= (aref ivec-exist iv) 1)
  736.                            (aref ivec-data iv)
  737.                            *real-undefined*)))
  738.                    (#.*handle* (write-isr2-handle 
  739.                          file
  740.                          (if (= (aref ivec-exist iv) 1)
  741.                          (aref ivec-data iv)
  742.                          *ptr-undefined*)))
  743.                    (#.*extents* (write-isr2-extents 
  744.                           file
  745.                           (if (= (aref ivec-exist iv) 1)
  746.                           (aref ivec-data iv)
  747.                           *ptr-undefined*)))
  748.                    (#.*bitplane* (write-isr2-bitplane
  749.                            file
  750.                            (if (= (aref ivec-exist iv) 1)
  751.                            (aref ivec-data iv)
  752.                            *ptr-undefined*)))
  753.                    (#.*array* (write-isr2-array 
  754.                         file
  755.                         (if (= (aref ivec-exist iv) 1)
  756.                         (aref ivec-data iv)
  757.                         *ptr-undefined*)))
  758.                    (#.*string* (write-isr2-sexpr-pkg
  759.                          file
  760.                          (if (= (aref ivec-exist iv) 1)
  761.                          (aref ivec-data iv)
  762.                          *ptr-undefined*)
  763.                          (find-package (if (= *file-version-number* 0) 'user 'isr2))))
  764.                    (#.*pointer* (write-isr2-sexpr-pkg 
  765.                           file
  766.                           (if (= (aref ivec-exist iv) 1)
  767.                           (aref ivec-data iv)
  768.                           *ptr-undefined*)
  769.                           (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  770.              ))
  771.            )
  772.          )
  773.        )
  774.     )
  775.   2vv)
  776.                    
  777.  
  778. (defun count-used-blocks (2vv)
  779.   (let* ((outer-vec (2index-vector-vector-data 2vv))
  780.      (max-ov (fill-pointer outer-vec))
  781.      (blocks 0))
  782.     (dotimes (ov max-ov)
  783.        (when (aref outer-vec ov)
  784.          (incf blocks)))
  785.     blocks)
  786.   )
  787.  
  788. (defun count-used-blocks-exist (2vv e2vv)
  789.   (let* ((outer-vec (2index-vector-vector-data 2vv))
  790.      (outer-evec (2index-vector-vector-data e2vv))
  791.      (max-ov (min (fill-pointer outer-vec) (fill-pointer outer-evec)))
  792.      (blocks 0))
  793.     (dotimes (ov max-ov)
  794.        (when (and (aref outer-vec ov) (aref outer-evec ov))
  795.          (incf blocks)))
  796.     blocks)
  797.   )
  798.  
  799. (defun make-handle-path-into-string (path-list &aux (result ""))
  800.   (dolist (elt path-list)
  801.     (if (or (char= (aref elt 0) #\<) 
  802.         (= (length result) 0)
  803.         (char= (aref result (1- (length result))) #\>))
  804.     (setf result (concatenate 'string result elt))
  805.     (setf result (concatenate 'string result "$" elt)))
  806.     )
  807.   result)
  808.  
  809. (defun write-isr2-handle (file handle)
  810.   ;  For reasons's I don't understand, handles get corrupted and stored in single element
  811.   ;  lists, this hack helps.   Ross 10/28/91
  812.   (if (typep handle 'cons) (setf handle (handle handle)))
  813.   (cond ((and (handle-p handle)
  814.           (eq (handle-type handle) :token-subset))
  815.      (write-isr2-tss file handle))
  816.     ((and (handle-p handle)
  817.           (eq (handle-type handle) :token-sort))
  818.      (write-isr2-tsort file handle))
  819.     (t (write-isr2-sexpr-pkg file (if (member handle
  820.                           `(,*ptr-undefined* ,*ptr-undefinable*))
  821.                       handle
  822.                       (make-handle-path-into-string
  823.                         (handle-canonical-path handle)))
  824.                  (find-package (if (= *file-version-number* 0) 'user 'isr2))))
  825.     )
  826.   handle)
  827.  
  828. (defun write-isr2-extents (file extents)
  829.   (if (eq extents *ptr-undefined*)
  830.       (write-byte32 file 0)
  831.       (if (eq extents *ptr-undefinable*)
  832.       (write-byte32 file MAXINT32)
  833.       (if (zerop (extents-pixel-count extents))
  834.           (write-byte32 file 0)
  835.           (progn
  836.         (write-byte32 file (extents-pixel-count extents))
  837.         (write-byte16 file (extents-minx extents))
  838.         (write-byte16 file (extents-miny extents))
  839.         (write-byte16 file (extents-maxx extents))
  840.         (write-byte16 file (extents-maxy extents))))))
  841.   extents)
  842.  
  843. (defun write-isr2-bitplane (file bitplane)
  844.   (if (eq bitplane *ptr-undefined*)
  845.       (write-byte32 file 0)
  846.       (if (eq bitplane *ptr-undefinable*)
  847.       (write-byte32 file MAXINT32)
  848.       (let* ((bit-height (array-dimension bitplane 0))
  849.          (bit-width  (array-dimension bitplane 1))
  850.          (byte-width (ceiling bit-width 8))
  851.          (numbytes   (* bit-height byte-width))
  852.          )
  853.         (if (zerop numbytes) 
  854.             (write-byte32 file 0)
  855.             (progn
  856.               (write-byte32 file numbytes)
  857.               (write-byte16 file bit-width)
  858.               (write-byte16 file bit-height)
  859.               (write-bits-from-bvec file bitplane (* numbytes 8)))))))
  860.   bitplane)
  861.  
  862. #-(or :allegro :lispworks)
  863. (defun write-bits-from-bvec (file vec size &aux byte-vec)
  864.   (setf byte-vec (make-array (ceiling size 8) :element-type '(unsigned-byte 8)
  865.                  :displaced-to vec))
  866.   (dotimes (ib (ceiling size 8))
  867.        (write-byte8 file (aref byte-vec ib)))
  868.   vec)
  869. #+(or :allegro :lispworks)
  870. (defun write-bits-from-bvec (file vec size &aux flat-bits)
  871.   (setf flat-bits (make-array size :element-type 'bit :displaced-to vec))
  872.   (dotimes (ib (ceiling size 8))
  873.        (let ((abyte 0))
  874.         (dotimes (ibit 8)
  875.              (setbit abyte ibit (aref flat-bits (+ (* ib 8) ibit)))
  876.              )
  877.         (write-byte8 file abyte))
  878.        )
  879.   vec)
  880.  
  881. #-(or :allegro :lispworks)
  882. (defun write-bits-from-bvec-logand (file mask-vec vec size 
  883.                     &aux mask-byte-vec byte-vec)
  884.   (setf mask-byte-vec (make-array (ceiling size 8) :element-type '(unsigned-byte 8)
  885.                   :displaced-to mask-vec))
  886.   (setf byte-vec (make-array (ceiling size 8) :element-type '(unsigned-byte 8)
  887.                  :displaced-to vec))
  888.   (dotimes (ib (ceiling size 8))
  889.        (write-byte8 file (logand (aref mask-byte-vec ib)
  890.                       (aref byte-vec ib))))
  891.   vec)
  892. #+(or :allegro :lispworks)
  893. (defun write-bits-from-bvec-logand (file mask-vec vec size 
  894.                     &aux mask-flat-bits flat-bits)
  895.   (setf mask-flat-bits (make-array size :element-type 'bit
  896.                   :displaced-to mask-vec))
  897.   (setf flat-bits (make-array size :element-type 'bit
  898.                  :displaced-to vec))
  899.   (dotimes (ib (ceiling size 8))
  900.        (let ((abyte 0))
  901.         (dotimes (ibit 8)
  902.              (unless (zerop (aref mask-flat-bits (+ (* ib 8) ibit)))
  903.                (setbit abyte ibit (aref flat-bits (+ (* ib 8) ibit)))
  904.                ))
  905.         (write-byte8 file abyte)))
  906.   vec)
  907.  
  908. (defun write-isr2-array (file array)
  909.   (if (eq array *ptr-undefined*)
  910.       (write-byte16 file #xFFFF)
  911.       (if (eq array *ptr-undefinable*)
  912.       (write-byte16 file #xFFFE)
  913.       (let* ((dimlist (array-dimensions array))
  914.          (numdims (length dimlist))
  915.          flat-array array-elt-count)
  916.         (write-byte16 file numdims)
  917.         (dolist (d dimlist)
  918.             (write-byte32 file d))
  919.         (setf flat-array (make-array (length array) 
  920.                          :element-type (array-element-type array)
  921.                          :displaced-to array)
  922.               array-elt-count (array-dimension flat-array 0))
  923.         (case (array-element-type flat-array)
  924.               (bit (write-byte16 file *boolean*)
  925.                (write-bits-from-bvec file array (length array)))
  926.               (single-float
  927.             (write-byte16 file *real*)
  928.             (dotimes (i array-elt-count)
  929.                  (write-float32 file (aref flat-array i))))
  930.               (fixnum
  931.             (write-byte16 file *int*)
  932.             (dotimes (i array-elt-count)
  933.                  (write-int32 file (aref flat-array i))))
  934.               (t (write-byte16 file *pointer*)
  935.              (dotimes (i array-elt-count)
  936.                   (write-isr2-sexpr-pkg 
  937.                     file 
  938.                     (aref flat-array i)
  939.                     (find-package (if (= *file-version-number* 0)
  940.                               'user 'isr2)))))
  941.               )
  942.         )
  943.       ))
  944.   array)
  945.  
  946. (defun isect-2vv (real-2vv-bit tss)
  947.   (let ((new-2vv (make-2index-vector-vector 0)))
  948.        (cond ((null tss) nil)
  949.          ((and (handle-p tss) (eq (handle-type tss) :token-subset))
  950.           (logand-isect-into real-2vv-bit 
  951.                 (handle-token-existence-array tss)
  952.                 new-2vv))
  953.          (t (error "Not a legal token subset: ~S" tss)))
  954.        new-2vv)
  955.   )
  956.  
  957. (defun logand-isect-into (real-2vv-bit tss-ea new-2vv)
  958.   (if (typep tss-ea '2index-vector-vector)
  959.       (let* ((real-outer-vector (2index-vector-vector-data real-2vv-bit))
  960.          (new-outer-vector (2index-vector-vector-data new-2vv))
  961.          (tss-outer-vector (2index-vector-vector-data tss-ea))
  962.          (real-fill-pointer (fill-pointer real-outer-vector))
  963.          (tss-fill-pointer (fill-pointer tss-outer-vector))
  964.          real-inner-vector real-iv
  965.          new-inner-vector new-iv
  966.          tss-inner-vector tss-iv
  967.          )
  968.         (dotimes (ov (min tss-fill-pointer real-fill-pointer))
  969.              (vector-push-extend nil new-outer-vector)
  970.              (when (and (setf tss-inner-vector (aref tss-outer-vector ov))
  971.                 (setf real-inner-vector (aref real-outer-vector ov)))
  972.                (setf new-inner-vector
  973.                  (allocate-resource
  974.                    '2index-bin-vector
  975.                    (* ov *default-2index-vector-size*))
  976.                  (aref new-outer-vector ov) new-inner-vector
  977.                  tss-iv (2index-vector-data-vector tss-inner-vector)
  978.                  real-iv (2index-vector-data-vector real-inner-vector)
  979.                  new-iv (2index-vector-data-vector new-inner-vector))
  980.                (dotimes (iv *default-2index-vector-size*)
  981.               (setf (aref new-iv iv)
  982.                 (logand (aref real-iv iv)
  983.                     (aref tss-iv iv))))
  984.                )
  985.              )
  986.         )
  987.       (map nil #'(lambda (index)
  988.              (when (= (vvref real-2vv-bit index) 1)
  989.                (setf (vvref new-2vv index) 1)))
  990.        tss-ea)
  991.       )
  992.   new-2vv)
  993.  
  994. (defun isect-2vv-fval (real-2vv tss)
  995.   (let ((new-2vv (make-2index-vector-vector 
  996.            (case (2index-vector-vector-resource-type real-2vv)
  997.              (2index-bin-vector *boolean*)
  998.              (2index-int-vector *int*)
  999.              (2index-real-vector *real*)
  1000.              (2index-ptr-vector *pointer*)
  1001.              (2index-ary-vector *array*)
  1002.              (2index-bp-vector *bitplane*)
  1003.              (2index-extents-vector *extents*)
  1004.              (2index-handle-vector *handle*)
  1005.              (2index-string-vector *string*)
  1006.              ))))
  1007.        (cond ((null tss) nil)
  1008.          ((and (handle-p tss) (eq (handle-type tss) :token-subset))
  1009.           (if-bit-isect-into real-2vv 
  1010.                 (handle-token-existence-array tss)
  1011.                 new-2vv))
  1012.          (t (error "Not a legal token subset: ~S" tss)))
  1013.        new-2vv)
  1014.   )
  1015.  
  1016. (defun if-bit-isect-into (real-2vv tss-ea new-2vv)
  1017.   (if (typep tss-ea '2index-vector-vector)
  1018.       (let* ((real-outer-vector (2index-vector-vector-data real-2vv))
  1019.          (new-outer-vector (2index-vector-vector-data new-2vv))
  1020.          (tss-outer-vector (2index-vector-vector-data tss-ea))
  1021.          (real-fill-pointer (fill-pointer real-outer-vector))
  1022.          (tss-fill-pointer (fill-pointer tss-outer-vector))
  1023.          real-inner-vector real-iv
  1024.          new-inner-vector new-iv
  1025.          tss-inner-vector tss-iv
  1026.          )
  1027.         (dotimes (ov (min tss-fill-pointer real-fill-pointer))
  1028.              (vector-push-extend nil new-outer-vector)
  1029.              (when (and (setf tss-inner-vector (aref tss-outer-vector ov))
  1030.                 (setf real-inner-vector (aref real-outer-vector ov)))
  1031.                (setf new-inner-vector
  1032.                  (allocate-resource
  1033.                    '2index-bin-vector
  1034.                    (* ov *default-2index-vector-size*))
  1035.                  (aref new-outer-vector ov) new-inner-vector
  1036.                  tss-iv (2index-vector-data-vector tss-inner-vector)
  1037.                  real-iv (2index-vector-data-vector real-inner-vector)
  1038.                  new-iv (2index-vector-data-vector new-inner-vector))
  1039.                (dotimes (iv *default-2index-vector-size*)
  1040.               (when (= (aref tss-iv iv) 1)
  1041.                 (setf (aref new-iv iv)
  1042.                   (aref real-iv iv)
  1043.                   )))
  1044.                )
  1045.              )
  1046.         )
  1047.       (map nil #'(lambda (index)
  1048.              (setf (vvref new-2vv index) 
  1049.                    (vvref real-2vv index)))
  1050.        tss-ea)
  1051.       )
  1052.   new-2vv)
  1053.  
  1054.  
  1055. (defun free-2vv (evv)
  1056.   (when (typep evv '2index-vector-vector)
  1057.     (with-lock ((2index-vector-vector-lock evv))
  1058.        (let* ((outer-vect (2index-vector-vector-data evv))
  1059.           (ov-size (fill-pointer outer-vect))
  1060.           ivect)
  1061.          (dotimes (ov ov-size)
  1062.               (setf ivect (aref outer-vect ov))
  1063.               (when ivect
  1064.             (deallocate-resource
  1065.               (type-of ivect) ivect)
  1066.             (setf (aref outer-vect ov) nil)
  1067.             ))
  1068.          )
  1069.        )
  1070.     )
  1071.   nil)
  1072.  
  1073.  
  1074. (defun select-frame-features (flist falist)
  1075.   (do ((feature flist (rest feature))
  1076.        (result nil)
  1077.        temp fdescr)
  1078.       ((null feature) (nreverse result))
  1079.       (setf temp (parse-token-name (first feature)))
  1080.       (cond ((and (null (rest temp))
  1081.           (setf fdescr (assoc (first temp)
  1082.                       falist
  1083.                       :test #'equalp)))
  1084.          (push (rest fdescr) result))
  1085.         ((null (rest temp))
  1086.          (warn "~&Undefined frame feature \"~A\" NOT written to file"
  1087.            (first temp)))
  1088.         (t t))
  1089.       )
  1090.   )
  1091.  
  1092. (defun select-token-features (flist fvector)
  1093.   (do ((feature flist (rest feature))
  1094.        (result nil)
  1095.        temp fdescr)
  1096.       ((null feature) (nreverse result))
  1097.       (setf temp (parse-token-name (first feature)))
  1098.       (cond ((and (rest temp)
  1099.           (eq (first temp) :?)
  1100.           (setf fdescr (member (second temp)
  1101.                        fvector
  1102.                        :test #'equalp
  1103.                        :key #'fdescr-featurename)))
  1104.          (push (first fdescr) result))
  1105.         ((and (rest temp) (eq (first temp) :?))
  1106.          (warn "~&Undefined token feature \"<?>~A\" NOT written to file"
  1107.            (second temp)))
  1108.         (t t))
  1109.       )
  1110.   )
  1111.       
  1112.  
  1113. (defun merge-bit-vectors (in-2vv-bit out-2vv-bit)
  1114.   (do-active-tokens (tindex in-2vv-bit)
  1115.      (setf (vvref out-2vv-bit tindex) 1)))
  1116.  
  1117.  
  1118. (defun make-stub-frame (parsed-path docstring sources &aux handle more-path)
  1119.   (multiple-value-setq (handle more-path)
  1120.     (make-handle-from-parsed-path parsed-path))
  1121.   (unless (and handle
  1122.            (handle-p handle)
  1123.            (check-terminal-path handle more-path)
  1124.            (eq (handle-type handle) :frame))
  1125.     (error "Bogus sub-frame path ~S: " parsed-path))
  1126.   (when (and more-path (null (rest more-path)) (stringp (first more-path))
  1127.          (not (string= (subseq (first more-path) 0 2) "F_")))
  1128.     (let* ((new-frame-name (first more-path))
  1129.        (new-frame (make-frame new-frame-name
  1130.                   :parent (copy-handle handle)
  1131.                   :documentation docstring))
  1132.        (new-frame-handle (make-handle :type :frame :frame new-frame))
  1133.        (fdescr (make-fdescr :type *handle*
  1134.                 :featurename new-frame-name
  1135.                 :docstring docstring
  1136.                 :value new-frame-handle
  1137.                 :if-needed (list 'isr2::default-if-needed-function)
  1138.                 :if-getting nil
  1139.                 :if-setting nil))
  1140.        )
  1141.       (setf (frame-feature-alist (handle-frame handle))
  1142.         (acons new-frame-name fdescr
  1143.                (frame-feature-alist (handle-frame handle)))
  1144.         (frame-is-loaded-p new-frame) nil
  1145.         (frame-source-file-list new-frame) sources)
  1146.       new-frame-handle)
  1147.     )
  1148.   )
  1149.  
  1150. (defvar *stub-frame-reference-action* :ask-user
  1151.     "Action to take if a stub frame is referenced")
  1152.  
  1153. (defun check-load-stub-frame (frame-handle)
  1154.   (unless (member *stub-frame-reference-action*
  1155.           '(:ask-user :ask-user-always :error :load))
  1156.     (warn "The variable ISR2::*STUB-FRAME-REFERENCE-ACTION* has been munged.~
  1157.          ~%Reseting to :ASK-USER")
  1158.     (setf *stub-frame-reference-action* :ask-user))
  1159.   (case *stub-frame-reference-action*
  1160.     (:load (read-sub-frame frame-handle nil (frame-documentation
  1161.                           (handle-frame frame-handle))
  1162.                    (frame-source-file-list
  1163.                  (handle-frame frame-handle))
  1164.                    :sub-frame-action :load))
  1165.     (:ask-user-always
  1166.       (cond
  1167.         ((yes-or-no-p "Reference to frame ~S, which is not loaded - load?"
  1168.               frame-handle)
  1169.          (read-sub-frame frame-handle nil (frame-documentation
  1170.                           (handle-frame frame-handle))
  1171.                    (frame-source-file-list
  1172.                  (handle-frame frame-handle))
  1173.                    :sub-frame-action :ask-user-always))
  1174.         (t (error "Reference to frame ~S, which is not loaded"
  1175.               frame-handle))))
  1176.     (:ask-user
  1177.       (cond
  1178.         ((yes-or-no-p "Reference to frame ~S, which is not loaded - load?"
  1179.               frame-handle)
  1180.          (read-sub-frame frame-handle nil (frame-documentation
  1181.                           (handle-frame frame-handle))
  1182.                    (frame-source-file-list
  1183.                  (handle-frame frame-handle))
  1184.                    :sub-frame-action :ask-user))
  1185.         (t (error "Reference to frame ~S, which is not loaded"
  1186.               frame-handle))))
  1187.     (:error (error "Reference to frame ~S, which is not loaded"
  1188.               frame-handle)))
  1189.   )
  1190.  
  1191.  
  1192. (defvar *global-filename-variable* nil "needed by w:choose-variable-values")
  1193. (defvar *global-directory-search-list* nil "list of directories to search through")
  1194.  
  1195. (defun check-file (ignore1 ignore2 ignore3 filename)
  1196.   (declare (ignore ignore1 ignore2 ignore3))
  1197.   (unless (probe-file filename)
  1198.     (format nil "file ~a not found" filename)))
  1199.  
  1200. (defun search-for-file-choices (filename-list &aux pathnames)
  1201.   (dolist (directory (append filename-list *global-directory-search-list*))
  1202.     (dolist (filename filename-list)
  1203.       (let* ((filepathname (pathname filename))
  1204.          (filestring (format nil "~a.~a" (pathname-name filepathname) (pathname-type filepathname))))
  1205.     (let ((path (merge-pathnames filestring directory nil)))
  1206.       (dolist (file (reverse (directory-safe path)))  ;;so they come in reverse version order
  1207.         (pushnew file pathnames :test #'equalp))))))
  1208.   (reverse pathnames))
  1209.  
  1210. ;;;  This is Ross's addition, attempting to avoid error of searching directories that no longer exist.
  1211. (defun directory-safe (pathname)
  1212.   "
  1213.    Unlike the default verions provided by TI, this directory command checks with 
  1214. probe and does not attempt to open non-existent files/directories.
  1215.    "
  1216.   (if (probe-file pathname)
  1217.       (directory pathname)
  1218.       nil)
  1219.   )
  1220.  
  1221.  
  1222. (defun get-file-date-string (pathname)
  1223.   (let ((file-date (file-write-date pathname)))
  1224.     (if file-date
  1225.     (multiple-value-bind (second minute hour date month year day-of-week)
  1226.         (decode-universal-time file-date)
  1227.       (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~] ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d,~d ~2,'0d:~2,'0d:~2,'0d"
  1228.           day-of-week (1- month) date year hour minute second))
  1229.     "")))
  1230.  
  1231. (defun format-file-choice-list (filename-list sub-frame-action)
  1232.   (mapcar #'(lambda (path)
  1233.           (list (format nil "~a (~a)" path
  1234.                 (get-file-date-string path))
  1235.             :value
  1236.             path))
  1237.       (search-for-file-choices filename-list)))
  1238.  
  1239. #+:EXPLORER
  1240. ;;WE MAY AT SOME POINT WANT TO MAKE FILENAME-DEFAULT GET ITS VALUE FROM A GLOBAL VARIABLE
  1241. (defun enter-file-name (&optional (filename-default nil))
  1242.   (setf *global-filename-variable* filename-default)
  1243.   (w:choose-variable-values
  1244.     `((*global-filename-variable* "Pathname"
  1245.      :documentation "right button to edit, left button to enter from scratch"
  1246.      :constraint check-file
  1247.          :pathname ,filename-default))
  1248.     :extra-width 40  ;leave space so name can get bigger
  1249.     :label "Enter New Pathname")
  1250.   *global-filename-variable*)
  1251.  
  1252.  
  1253. #+:EXPLORER
  1254. (defun menu-choose-source-file (source-file-list menu-label &OPTIONAL (sub-frame-action :ask-user))
  1255.   (unless (listp source-file-list) (setf source-file-list (list source-file-list)))
  1256.   (let ((choice-list (format-file-choice-list source-file-list sub-frame-action)))
  1257.     (if (null choice-list)
  1258.     (enter-file-name (car source-file-list))  ;ENTER FILENAME FROM SCRATCH IF NO PREDEFINED CHOICES
  1259.     (do ((choice nil))
  1260.         (choice (if (eq choice :newpath) (enter-file-name (car source-file-list)) choice))
  1261.       (setf choice
  1262.         (w::menu-choose    ;CHOOSE FILENAME FROM MENU
  1263.           (cons '("<<Enter new pathname>>" . :newpath) choice-list)
  1264.           :label menu-label))))))
  1265.  
  1266.  
  1267. #-:EXPLORER
  1268. (defun menu-choose-source-file (source-file-list menu-label  &OPTIONAL (sub-frame-action :ask-user))
  1269.   (unless (listp source-file-list) (setf source-file-list (list source-file-list)))
  1270.   (let ((choice-list (format-file-choice-list source-file-list  sub-frame-action)))
  1271.     (if (null choice-list)
  1272.     (enter-file-name (car source-file-list))  ;ENTER FILENAME FROM SCRATCH IF NO PREDEFINED CHOICES
  1273.     (do ((choice nil))
  1274.         (choice (if (eq choice :newpath) (enter-file-name (car source-file-list)) choice))
  1275.       (setf choice
  1276.         (tty33-menu-choose    ;CHOOSE FILENAME FROM MENU
  1277.           (cons '("<<Enter new pathname>>" . :newpath) choice-list)
  1278.           :label menu-label))))))
  1279.  
  1280. #-:EXPLORER
  1281. ;;WE MAY AT SOME POINT WANT TO MAKE FILENAME-DEFAULT GET ITS VALUE FROM A GLOBAL VARIABLE
  1282. (defun enter-file-name (&optional (filename-default
  1283.                    *default-pathname-defaults*))
  1284.   (setf filename-default (pathname filename-default))
  1285.   (do ((filename nil)) (filename filename)
  1286.       (format *query-io* "~&Enter filename [~A]: " filename-default)
  1287.       (setf filename (namestring (merge-pathnames (read-line *query-io*) 
  1288.                           filename-default)))
  1289.       (unless (probe-file filename)
  1290.           (format *query-io* "~&File not accessable: ~A" filename)
  1291.           (setf filename-default (pathname filename) filename nil))
  1292.       )
  1293.   )
  1294.  
  1295. #-:EXPLORER
  1296. (defun tty33-menu-choose (choices &key (label "Select from"))
  1297.    (do ((ichoice nil)(answer ""))
  1298.        (ichoice (let ((choice (elt choices ichoice)))
  1299.                  (or (getf (rest choice) :value)
  1300.                      (rest choice))))
  1301.     (format *query-io* "~&~A:" label)
  1302.     (dotimes (i (length choices))
  1303.        (format *query-io* "~&~2T~d) ~A" i (first (elt choices i))))
  1304.         (format *query-io* "~&Enter a number between 0 and ~D: "
  1305.         (1- (length choices)))
  1306.     (setf ichoice (parse-integer (setf answer (read-line *query-io*))
  1307.                      :junk-allowed t
  1308.                      :radix #x0a))
  1309.     (unless (and ichoice (>= ichoice 0) (< ichoice (length choices)))
  1310.        (format *query-io* "~&*** Bad input ~S, try again" answer)
  1311.        (setf ichoice nil))
  1312.     )
  1313.     )
  1314.  
  1315.  
  1316. (defun ask-user-for-source-files-to-load (new-path old-path docstring source-list &OPTIONAL (sub-frame-action :ask-user))
  1317.   (list (menu-choose-source-file source-list
  1318.        (format nil "Select source file for frame path ~S (old path ~S)~%~A"
  1319.            new-path old-path docstring)
  1320.        sub-frame-action)))
  1321.  
  1322. (defun read-sub-frame (parsed-path old-path docstring sources &key sub-frame-action parent-path &aux
  1323.                new-path)
  1324.   
  1325.   (setf new-path parsed-path)
  1326.   (do ()
  1327.       ((and (handle-p new-path) (handle-p parsed-path))
  1328.        t)
  1329.       (multiple-value-bind (h m) (make-handle-from-parsed-path 
  1330.                    parsed-path)
  1331.     (cond ((null m) 
  1332.            (cond ((not (eq (handle-type h) :frame))
  1333.               (setf new-path (create parsed-path))
  1334.               (multiple-value-setq (h m) (make-handle-from-parsed-path 
  1335.                            parsed-path)
  1336.                        )
  1337.               )
  1338.              (t (setf new-path h)))
  1339.            )
  1340.           (t (setf new-path (create parsed-path))
  1341.          (multiple-value-setq (h m) (make-handle-from-parsed-path 
  1342.                           parsed-path)
  1343.                       ))
  1344.           )
  1345.     (setf parsed-path (cond ((and (handle-p h) (eq (handle-type h) :token-feature))
  1346.                  parsed-path)
  1347.                 ((null m) h)
  1348.                 (t (cons h m)))))
  1349.       )
  1350.   #|
  1351.   (setf sources (find-sources-from-public-data-base (or old-path new-path)
  1352.                             docstring 
  1353.                             (if (member sub-frame-action '(:ask-user :ask-user-always)))))
  1354.   |#
  1355.   (when (member sub-frame-action '(:ask-user :ask-user-always))
  1356.     (setf sources (ask-user-for-source-files-to-load new-path old-path 
  1357.                              docstring sources sub-frame-action))
  1358.     )
  1359.   ;  Bob, Bruce and Ross Drastically simplified this now that read-frame
  1360.   ;  Will prompt user for valid file!
  1361.   (dolist (file sources)
  1362.     (when parent-path
  1363.       (setf file (make-pathname :name (pathname-name file) :type (pathname-type file)
  1364.                 :defaults parent-path)))
  1365.     (read-frame new-path file :all :all :merge-p t
  1366.         :sub-frame-action sub-frame-action
  1367.     ;    (if interact-p :ask-user :load) ;; ADDED THIS LINE 7/31/90 JRB
  1368.         :merge-overlap-action :new))
  1369.   )
  1370.       
  1371. (defun write-frame (frame-path filename features tss &optional
  1372.             frame-source-file-replace)
  1373.   "WRITE-FRAME frame-path filename features tss &OPTIONAL frame-source-file-replace -
  1374. Writes out the frame specified by frame-path out to the file named by
  1375. filename.  If features is :ALL, all token features are written, otherwise
  1376. only the token features specified in the list features are written.  If tss
  1377. is :ALL, all tokens are written, otherwise only the tokens in tss are written.
  1378. If frame-source-file-replace is non-NIL, the frame's source file is replaced
  1379. with the filename specified (illegal if either features or tss is not :ALL),
  1380. otherwise the filename is *added* to the list of previous source file names."
  1381.   (let ((frame (%internal-handle frame-path :error-p nil :terminal-p t))
  1382.     sourcefiles
  1383.     frame-pointer)
  1384.        (unless (and frame
  1385.             (handle-p frame)
  1386.             (eq (handle-type frame) :frame))
  1387.      (error "Not a frame: ~S!" frame-path))
  1388.        (setf frame-pointer (handle-frame frame))
  1389.        (when frame-source-file-replace
  1390.      (unless (and (eq features :all) (eq tss :all))
  1391.        (error "Cannot replace source file when only saving a partial frame: ~S"
  1392.           frame-path)))
  1393.        (with-open-isr2-frame-file (frame-stream filename :output)
  1394.      (setf sourcefiles (cons (namestring 
  1395.                    (truename frame-stream))
  1396.                  (if frame-source-file-replace
  1397.                      nil
  1398.                      (frame-source-file-list 
  1399.                        frame-pointer))))
  1400.      (setf (frame-source-file-list frame-pointer) sourcefiles)
  1401.      (write-isr2-header frame-stream)
  1402.      (write-isr2-string frame-stream (frame-name frame-pointer))
  1403.      (write-isr2-string frame-stream (frame-documentation frame-pointer))
  1404.      (write-byte16      frame-stream (length sourcefiles))
  1405.      (map nil #'(lambda (s) (write-isr2-string frame-stream s))
  1406.           sourcefiles)
  1407.      (write-isr2-string frame-stream (frame-path frame-pointer))
  1408.      (let ((decendants (sort-by-tree-depth (find-all-decendants frame))))
  1409.           (write-byte16 frame-stream (length decendants))
  1410.           (map nil #'(lambda (fh) 
  1411.                  (write-isr2-string 
  1412.                    frame-stream
  1413.                    (frame-path (handle-frame fh)))
  1414.                  (write-isr2-string
  1415.                    frame-stream
  1416.                    (frame-documentation
  1417.                      (handle-frame fh)))
  1418.                  (write-isr2-sexpr-pkg
  1419.                    frame-stream
  1420.                    (frame-source-file-list
  1421.                      (handle-frame fh))
  1422.                    (find-package (if (= *file-version-number* 0) 'user 'isr2))))
  1423.            decendants)
  1424.           )
  1425.      (let ((exist-intersect (if (eq tss :all)
  1426.                     (frame-token-set-existence-vector
  1427.                          frame-pointer)
  1428.                     (isect-2vv (frame-token-set-existence-vector
  1429.                          frame-pointer)
  1430.                            tss)))
  1431.            (globalp-intersect (if (eq tss :all)
  1432.                       (frame-token-set-globalp-vector
  1433.                     frame-pointer)
  1434.                       (isect-2vv (frame-token-set-globalp-vector
  1435.                            frame-pointer)
  1436.                          tss)))
  1437.            )
  1438.           (write-isr2-2vv frame-stream exist-intersect)
  1439.           (write-isr2-2vv frame-stream globalp-intersect)
  1440.  
  1441.           (let ((frame-feature-list
  1442.               (if (eq features :all)
  1443.               (mapcar #'rest (frame-feature-alist frame-pointer))
  1444.               (select-frame-features
  1445.                 features
  1446.                 (frame-feature-alist frame-pointer)))))
  1447.            (write-byte16 frame-stream (length frame-feature-list))
  1448.            (dolist (fdescr frame-feature-list)
  1449.                (write-isr2-string frame-stream
  1450.                           (fdescr-featurename fdescr))
  1451.                (write-isr2-string frame-stream
  1452.                           (fdescr-docstring fdescr))
  1453.                (write-byte16 frame-stream
  1454.                       (fdescr-type fdescr))
  1455.                (write-byte16 frame-stream
  1456.                       (length (fdescr-if-needed fdescr)))
  1457.                (dolist (fn (fdescr-if-needed fdescr))
  1458.                    (write-isr2-sexpr-pkg
  1459.                      frame-stream
  1460.                      fn 
  1461.                      (find-package (if (= *file-version-number* 0) 'user 'isr2))))
  1462.                (write-byte16 frame-stream
  1463.                       (length (fdescr-if-setting fdescr)))
  1464.                (dolist (fn (fdescr-if-setting fdescr))
  1465.                    (write-isr2-sexpr-pkg
  1466.                      frame-stream
  1467.                      fn 
  1468.                      (find-package (if (= *file-version-number* 0) 'user 'isr2))))
  1469.                (write-byte16 frame-stream
  1470.                       (length (fdescr-if-getting fdescr)))
  1471.                (dolist (fn (fdescr-if-getting fdescr))
  1472.                    (write-isr2-sexpr-pkg
  1473.                      frame-stream
  1474.                      fn 
  1475.                      (find-package (if (= *file-version-number* 0) 'user 'isr2))))
  1476.                (case (fdescr-type fdescr)
  1477.                  ((#.*boolean* #.*int*)
  1478.                   (write-int32 frame-stream (fdescr-value fdescr)))
  1479.                  (#.*real*
  1480.                    (write-float32 frame-stream (fdescr-value fdescr)))
  1481.                  (#.*handle*
  1482.                    (write-isr2-handle frame-stream
  1483.                               (fdescr-value fdescr)))
  1484.                  (#.*extents*
  1485.                    (write-isr2-extents frame-stream 
  1486.                                (fdescr-value fdescr)))
  1487.                  (#.*bitplane*
  1488.                    (write-isr2-bitplane frame-stream
  1489.                             (fdescr-value fdescr)))
  1490.                  (#.*array*
  1491.                    (write-isr2-array frame-stream
  1492.                              (fdescr-value fdescr)))
  1493.                  (#.*string*
  1494.                    (write-isr2-sexpr-pkg
  1495.                      frame-stream
  1496.                      (fdescr-value fdescr)
  1497.                      (find-package (if (= *file-version-number* 0) 'user 'isr2))))
  1498.                  (#.*pointer*
  1499.                    (write-isr2-sexpr-pkg
  1500.                      frame-stream
  1501.                      (fdescr-value fdescr)
  1502.                      (find-package (if (= *file-version-number* 0) 'user 'isr2))))
  1503.                  )
  1504.                )
  1505.            )
  1506.           (let ((token-feature-list
  1507.               (if (eq features :all)
  1508.               (frame-token-set-feature-vector frame-pointer)
  1509.               (select-token-features
  1510.                 features
  1511.                 (frame-token-set-feature-vector frame-pointer))
  1512.               ))
  1513.             )
  1514.            (write-byte16 frame-stream (length token-feature-list))
  1515.            (dolist (fdescr token-feature-list)
  1516.                (write-isr2-string frame-stream
  1517.                           (fdescr-featurename fdescr))
  1518.                (write-isr2-string frame-stream
  1519.                           (fdescr-docstring fdescr))
  1520.                (write-byte16 frame-stream
  1521.                       (fdescr-type fdescr))
  1522.                (write-byte16 frame-stream
  1523.                       (length (fdescr-if-needed fdescr)))
  1524.                (dolist (fn (fdescr-if-needed fdescr))
  1525.                    (write-isr2-sexpr-pkg
  1526.                      frame-stream
  1527.                      fn 
  1528.                      (find-package (if (= *file-version-number* 0) 'user 'isr2))))
  1529.                (write-byte16 frame-stream
  1530.                       (length (fdescr-if-setting fdescr)))
  1531.                (dolist (fn (fdescr-if-setting fdescr))
  1532.                    (write-isr2-sexpr-pkg
  1533.                      frame-stream
  1534.                      fn 
  1535.                      (find-package (if (= *file-version-number* 0) 'user 'isr2))))
  1536.                (write-byte16 frame-stream
  1537.                       (length (fdescr-if-getting fdescr)))
  1538.                (dolist (fn (fdescr-if-getting fdescr))
  1539.                    (write-isr2-sexpr-pkg
  1540.                      frame-stream
  1541.                      fn 
  1542.                      (find-package (if (= *file-version-number* 0) 'user 'isr2))))
  1543.                (write-partial-2vv frame-stream
  1544.                           exist-intersect
  1545.                           (fdescr-value fdescr))
  1546.                )
  1547.            )
  1548.           (unless (eq tss :all) (free-2vv exist-intersect))
  1549.           (unless (eq tss :all) (free-2vv globalp-intersect))
  1550.           )
  1551.      (namestring (truename frame-stream))
  1552.      )
  1553.        )     
  1554.   )
  1555.  
  1556. (defun read-in-decendants (frame-stream sub-frame-action &OPTIONAL (parent-path nil))
  1557.   (when (eq sub-frame-action :ask-user)
  1558.     (push frame-stream *global-directory-search-list*))
  1559.   (let (decendant-path decendant-doc decendant-sources dec-parsed-path
  1560.                dec-handle dec-more-path)
  1561.     (prog1 
  1562.       (dotimes (i (read-ubyte16 frame-stream))
  1563.     (setf decendant-path (read-isr2-string frame-stream)
  1564.           decendant-doc  (read-isr2-string frame-stream)
  1565.           decendant-sources  (read-isr2-sexpr-pkg 
  1566.                    frame-stream
  1567.                    (find-package (if (= *file-version-number* 0) 'user 'isr2)))
  1568.           dec-parsed-path (adjust-path (parse-token-name decendant-path)))
  1569.     (multiple-value-setq (dec-handle dec-more-path)
  1570.       (make-handle-from-parsed-path dec-parsed-path))
  1571.     (unless (and (handle-p dec-handle) 
  1572.              (null dec-more-path)
  1573.              (eq (handle-type dec-handle) :frame)
  1574.              (frame-is-loaded-p (handle-frame dec-handle))
  1575.              )
  1576.       (case sub-frame-action
  1577.         (:stub (make-stub-frame (cons dec-handle dec-more-path)
  1578.                     decendant-doc decendant-sources))
  1579.         (:error (error "Unloaded sub frame: ~S" 
  1580.                (cons dec-handle dec-more-path)))
  1581.         (:load  (read-sub-frame (cons dec-handle dec-more-path)
  1582.                     decendant-path
  1583.                     decendant-doc
  1584.                     decendant-sources
  1585.                     :sub-frame-action sub-frame-action)
  1586.             )
  1587.         (:inherit-path (read-sub-frame (cons dec-handle dec-more-path)
  1588.                             decendant-path
  1589.                             decendant-doc
  1590.                             decendant-sources
  1591.                             :sub-frame-action sub-frame-action
  1592.                             :parent-path parent-path))
  1593.         (:ask-user-always (read-sub-frame (cons dec-handle dec-more-path)
  1594.                             decendant-path
  1595.                             decendant-doc
  1596.                             decendant-sources
  1597.                             :sub-frame-action sub-frame-action))
  1598.         (:ask-user (read-sub-frame (cons dec-handle dec-more-path)
  1599.                        decendant-path
  1600.                        decendant-doc
  1601.                        decendant-sources
  1602.                        :sub-frame-action sub-frame-action)))))
  1603.       (when (member sub-frame-action '(:ask-user :ask-user-always))
  1604.     (pop *global-directory-search-list*)))))
  1605.  
  1606.  
  1607. (defun read-in-token-features (frame-stream frame-pointer
  1608.                    exist-bit-vector merge-overlap-action
  1609.                    new-frame-p features tss)
  1610.   (let (fname fdoc ftype f-if-needed f-if-getting f-if-setting
  1611.     fvalue)
  1612.        #|(declare (special fname fdoc ftype f-if-needed f-if-getting f-if-setting
  1613.              fvalue))|#
  1614.        (dotimes (i (read-ubyte16 frame-stream))
  1615.       #|(declare (special i))|#
  1616.       (setf fname (read-isr2-string frame-stream)
  1617.         fdoc  (read-isr2-string frame-stream)
  1618.         ftype (read-ubyte16 frame-stream)
  1619.         f-if-needed (make-list (read-ubyte16 frame-stream)))
  1620.       (do ((p f-if-needed (rest p)))
  1621.           ((null p))
  1622.           (setf (first p)
  1623.             (read-isr2-sexpr-pkg
  1624.               frame-stream
  1625.               (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  1626.       (setf f-if-setting (make-list (read-ubyte16 frame-stream)))
  1627.       (do ((p f-if-setting (rest p)))
  1628.           ((null p))
  1629.           (setf (first p)
  1630.             (read-isr2-sexpr-pkg
  1631.               frame-stream
  1632.               (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  1633.       (setf f-if-getting (make-list (read-ubyte16 frame-stream)))
  1634.       (do ((p f-if-getting (rest p)))
  1635.           ((null p))
  1636.           (setf (first p)
  1637.             (read-isr2-sexpr-pkg
  1638.               frame-stream
  1639.               (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  1640.       (let ((temp-fvalue (read-isr2-2vv frame-stream)))
  1641.            #|(declare (special temp-fvalue))|#
  1642.            (if (eq tss :all) 
  1643.            (setf fvalue temp-fvalue)
  1644.            (progn
  1645.              (setf fvalue (isect-2vv-fval temp-fvalue tss))
  1646.              (free-2vv temp-fvalue))))
  1647.       (if (or (eq features :all)
  1648.           (member fname features
  1649.               :test #'equalp
  1650.               :key #'(lambda (fn &aux (pfn (parse-token-name fn)))
  1651.                      (if (eq (first pfn) :?)
  1652.                          (second pfn)
  1653.                          nil))))
  1654.           (if new-frame-p
  1655.           (pushnew  (make-fdescr
  1656.                 :featurename fname
  1657.                 :docstring   fdoc
  1658.                 :type        ftype
  1659.                 :if-needed   f-if-needed
  1660.                 :if-getting  f-if-getting
  1661.                 :if-setting  f-if-setting
  1662.                 :value       fvalue)
  1663.                 (frame-token-set-feature-vector frame-pointer)
  1664.                 :test #'equalp)
  1665.           (let ((old-fdescr (member fname
  1666.                         (frame-token-set-feature-vector
  1667.                           frame-pointer)
  1668.                         :test #'equalp
  1669.                         :key #'fdescr-featurename)))
  1670.                (if (null old-fdescr)
  1671.                (setf (frame-token-set-feature-vector frame-pointer)
  1672.                  (cons (make-fdescr
  1673.                      :featurename fname
  1674.                      :docstring   fdoc
  1675.                      :type        ftype
  1676.                      :if-needed   f-if-needed
  1677.                      :if-getting  f-if-getting
  1678.                      :if-setting  f-if-setting
  1679.                      :value       fvalue)
  1680.                        (frame-token-set-feature-vector frame-pointer)))
  1681.                (progn
  1682.                  (setf old-fdescr (first old-fdescr))
  1683.                  (unless (= ftype (fdescr-type old-fdescr))
  1684.                    (error
  1685.                  "Token feature type mismatch, feature=~A old=~A, new=~A"
  1686.                  fname
  1687.                  (elt *type-names*
  1688.                       (fdescr-type old-fdescr))
  1689.                  (elt *type-names* ftype)))
  1690.                  (let (old-tok-f-value new-tok-f-value)
  1691.                   (do-active-tokens (tindex exist-bit-vector)
  1692.                      (setf old-tok-f-value (vvref (fdescr-value
  1693.                                     old-fdescr)
  1694.                                   tindex)
  1695.                        new-tok-f-value (vvref fvalue
  1696.                                   tindex))
  1697.                      (if (or (equalp old-tok-f-value
  1698.                          (cond ((= ftype *int*) 
  1699.                             *int-undefined*)
  1700.                                ((= ftype *real*)
  1701.                             *real-undefined*)
  1702.                                (t *ptr-undefined*)))
  1703.                          (and (= ftype *handle*)
  1704.                           (handle-p new-tok-f-value)
  1705.                           (handle-p old-tok-f-value)
  1706.                           (equalp new-tok-f-value
  1707.                               old-tok-f-value)))
  1708.                      (setf (vvref
  1709.                          (fdescr-value old-fdescr)
  1710.                          tindex) 
  1711.                            new-tok-f-value)
  1712.                      (unless (equalp new-tok-f-value
  1713.                              (cond ((= ftype *int*)
  1714.                                 *int-undefined*)
  1715.                                    ((= ftype *real*) 
  1716.                                 *real-undefined*)
  1717.                                    (t *ptr-undefined*
  1718.                                   )))
  1719.                        (case merge-overlap-action
  1720.                          (:error
  1721.                            (error "Merge overlap - token feature ~A, for token ~D"
  1722.                               fname tindex))
  1723.                          (:old t)
  1724.                          (:new (setf (vvref
  1725.                                    (fdescr-value
  1726.                                  old-fdescr) 
  1727.                                    tindex)
  1728.                                  new-tok-f-value))
  1729.                          (:warn-new
  1730.                            (warn "~&Replacing value of token feature ~A; token ~D, old value was ~S, new value is ~S"
  1731.                              fname tindex
  1732.                              old-tok-f-value
  1733.                              new-tok-f-value)
  1734.                            (setf (vvref
  1735.                                (fdescr-value
  1736.                                  old-fdescr) 
  1737.                                tindex)
  1738.                              new-tok-f-value)
  1739.                            )
  1740.                          (:ask-user
  1741.                            (when
  1742.                              (yes-or-no-p
  1743.                                "Replace value of token feature ~A; token ~D, old value was ~S, new value is ~S?"
  1744.                                fname tindex
  1745.                                old-tok-f-value
  1746.                                new-tok-f-value)
  1747.                             (setf (vvref
  1748.                                 (fdescr-value
  1749.                                   old-fdescr) 
  1750.                                 tindex)
  1751.                               new-tok-f-value)
  1752.                             ))
  1753.                          )
  1754.                        )
  1755.                      )
  1756.                      )
  1757.                   )
  1758.                  (free-2vv fvalue)
  1759.                  )
  1760.                )
  1761.                )
  1762.           )
  1763.           (free-2vv fvalue)
  1764.           )
  1765.       )
  1766.        )
  1767.   )
  1768.  
  1769.  
  1770. (defun read-in-frame-features (frame-stream frame-pointer merge-overlap-action
  1771.                    new-frame-p features)
  1772.   (let (fname fdoc ftype f-if-needed f-if-getting f-if-setting
  1773.           fvalue)
  1774.        (dotimes (i (read-ubyte16 frame-stream))
  1775.         (setf fname (read-isr2-string frame-stream)
  1776.               fdoc  (read-isr2-string frame-stream)
  1777.               ftype (read-ubyte16 frame-stream)
  1778.               f-if-needed (make-list (read-ubyte16 frame-stream)))
  1779.         (do ((p f-if-needed (rest p)))
  1780.             ((null p))
  1781.             (setf (first p)
  1782.               (read-isr2-sexpr-pkg
  1783.                 frame-stream
  1784.                 (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  1785.         (setf f-if-setting (make-list (read-ubyte16 frame-stream)))
  1786.         (do ((p f-if-setting (rest p)))
  1787.             ((null p))
  1788.             (setf (first p)
  1789.               (read-isr2-sexpr-pkg
  1790.                 frame-stream
  1791.                 (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  1792.         (setf f-if-getting (make-list (read-ubyte16 frame-stream)))
  1793.         (do ((p f-if-getting (rest p)))
  1794.             ((null p))
  1795.             (setf (first p)
  1796.               (read-isr2-sexpr-pkg
  1797.                 frame-stream
  1798.                 (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  1799.         (setf fvalue
  1800.               (case ftype
  1801.                 ((#.*boolean* #.*int*)
  1802.                  (read-sbyte32 frame-stream))
  1803.                 (#.*real*
  1804.                   (read-float32 frame-stream))
  1805.                 (#.*handle*
  1806.                   (read-isr2-handle frame-stream))
  1807.                 (#.*extents*
  1808.                   (read-isr2-extents frame-stream))
  1809.                 (#.*bitplane*
  1810.                   (read-isr2-bitplane frame-stream))
  1811.                 (#.*array*
  1812.                   (read-isr2-array frame-stream))
  1813.                 ((#.*string* #.*pointer*)
  1814.                  (read-isr2-sexpr-pkg 
  1815.                    frame-stream
  1816.                    (find-package (if (= *file-version-number* 0) 'user 'isr2))))))
  1817.         (when (or (eq features :all)
  1818.               (member fname features
  1819.                   :test #'equalp
  1820.                   :key #'(lambda (fn)
  1821.                          (first (parse-token-name fn)))))
  1822.           (if new-frame-p
  1823.               (pushnew (cons fname
  1824.                      (make-fdescr
  1825.                        :featurename fname
  1826.                        :docstring   fdoc
  1827.                        :type        ftype
  1828.                        :if-needed   f-if-needed
  1829.                        :if-getting  f-if-getting
  1830.                        :if-setting  f-if-setting
  1831.                        :value       fvalue))
  1832.                    (frame-feature-alist frame-pointer)
  1833.                    :test #'equalp)
  1834.               (let ((old-fdescr (assoc fname
  1835.                            (frame-feature-alist
  1836.                          frame-pointer)
  1837.                            :test #'equalp)))
  1838.                (if (null old-fdescr)
  1839.                    (setf (frame-feature-alist frame-pointer)
  1840.                      (acons fname
  1841.                         (make-fdescr
  1842.                           :featurename fname
  1843.                           :docstring   fdoc
  1844.                           :type        ftype
  1845.                           :if-needed   f-if-needed
  1846.                           :if-getting  f-if-getting
  1847.                           :if-setting  f-if-setting
  1848.                           :value       fvalue)
  1849.                         (frame-feature-alist frame-pointer)))
  1850.                    (progn
  1851.                  (setf old-fdescr (rest old-fdescr))
  1852.                  (unless (= ftype (fdescr-type old-fdescr))
  1853.                    (error
  1854.                      "Frame feature type mismatch, feature=~A old=~A, new=~A"
  1855.                      fname
  1856.                      (elt *type-names*
  1857.                       (fdescr-type old-fdescr))
  1858.                      (elt *type-names* ftype)))
  1859.                  (if (or (equalp (fdescr-value old-fdescr)
  1860.                          (cond ((= ftype *int*) *int-undefined*)
  1861.                                ((= ftype *real*) *real-undefined*)
  1862.                                (t *ptr-undefined*)))
  1863.                      (and (= ftype *handle*)
  1864.                           (handle-p fvalue)
  1865.                           (handle-p (fdescr-value old-fdescr))
  1866.                           (equalp fvalue (fdescr-value old-fdescr))))
  1867.                      (setf (fdescr-value old-fdescr) fvalue)
  1868.                      (unless (equalp fvalue
  1869.                              (cond ((= ftype *int*) *int-undefined*)
  1870.                                ((= ftype *real*) *real-undefined*)
  1871.                                (t *ptr-undefined*)))
  1872.                        (case merge-overlap-action
  1873.                          (:error
  1874.                            (error "Merge overlap - frame feature ~A"
  1875.                               fname))
  1876.                          (:old t)
  1877.                          (:new (setf (fdescr-value old-fdescr) 
  1878.                              fvalue))
  1879.                          (:warn-new
  1880.                            (warn "~&Replacing value of frame feature ~A, old value was ~S, new value is ~S"
  1881.                              fname (fdescr-value old-fdescr)
  1882.                              fvalue)
  1883.                            (setf (fdescr-value old-fdescr) 
  1884.                              fvalue)
  1885.                            )
  1886.                          (:ask-user
  1887.                            (when
  1888.                          (yes-or-no-p
  1889.                            "Replace value of frame feature ~A, old value was ~S, new value is ~S?"
  1890.                            fname (fdescr-value old-fdescr)
  1891.                            fvalue)
  1892.                          (setf (fdescr-value old-fdescr) 
  1893.                                fvalue)))
  1894.                          )
  1895.                        )
  1896.                      )
  1897.                  )
  1898.                    )
  1899.                )
  1900.               )
  1901.           )
  1902.         )
  1903.        )
  1904.   )
  1905.  
  1906. (defun read-frame (frame-path filename features tss &key
  1907.            merge-p (sub-frame-action :ask-user)
  1908.            (frame-ask-user nil)
  1909.            (merge-overlap-action :error)
  1910.            &aux *sort-fixup-list* (*file-version-number* 1))
  1911. "READ-FRAME frame-path filename features tss &KEY merge-p (sub-frame-action :ask-user)
  1912.        (merge-overlap-action :error) -
  1913.  Read in a frame from file filename into the frame structure at frame-path.  If
  1914.  merge-p is non-NIL, merge the new data with an existing frame, otherwise signal
  1915.  an error if frame-path already exists.
  1916.  
  1917.     Sub-frame-action specifies what to do
  1918.  about sub-frames referenced by the frame being loaded.  Values can be
  1919.     :ASK-USER - ask the user what to do for each sub-frame,
  1920.     :ASK-USER-ALWAYS - ask the user, but ignores descendant file paths,
  1921.     :LOAD - load the sub-frame if posible, 
  1922.     :INHERIT-PATH - load using the device and directory of the root frame.
  1923.     :STUB - make a stub-frame, or 
  1924.     :ERROR - raise an error if an unresolved
  1925.  sub-frame is referenced.  
  1926.  
  1927.     Merge-overlap-action specifies what to do if merge-p
  1928.  is non-NIL and there is data-overlap.  Posible values are :ERROR - raise an
  1929.  error, :ASK-USER - ask the user for each instance, :OLD - use existing data,
  1930.  :NEW - use new data, or :WARN-NEW - use new data and issue a warning message
  1931.  (with WARN).  Features and TSS control which features and/or tokens to load.
  1932.  :ALL means all, NIL means none.  Features should be :ALL, NIL, or a list a feature 
  1933.  names, with a posible <?> in front,  TSS should be :ALL, NIL, or a TSS.
  1934.   "
  1935.   (unless (member sub-frame-action '(:stub :error :load :inherit-path :ask-user :ask-user-always))
  1936.     (error "Bad keyword value for :sub-frame-action - ~S" sub-frame-action))
  1937.   (when merge-p 
  1938.     (unless (member merge-overlap-action
  1939.             '(:error :ask-user :old :new :warn-new))
  1940.       (error "Bad keyword value for :merge-overlap-action - ~S" 
  1941.          merge-overlap-action)))
  1942.   (let ((*new-frame-path* (parse-token-name frame-path))
  1943.     new-handle new-more-path
  1944.     frame-pointer *old-frame-path*
  1945.     sourcefiles frame-name frame-documentation file-frame-path
  1946.     (new-frame-p nil)
  1947.     )
  1948.        (unwind-protect
  1949.      (progn
  1950.        (multiple-value-setq (new-handle new-more-path)
  1951.          (make-handle-from-parsed-path *new-frame-path*))
  1952.            (when frame-ask-user
  1953.              (setf filename (menu-choose-source-file filename
  1954.         (format nil "Choose source file for frame path ~s" frame-path))))
  1955.        (with-open-isr2-read-frame-file (frame-stream filename frame-path)
  1956.           (unless (setf *file-version-number*
  1957.                 (read-and-check-isr2-header frame-stream))
  1958.         (error "Not a frame file: ~S" filename))
  1959.           (setf frame-name (read-isr2-string frame-stream)
  1960.             frame-documentation (read-isr2-string frame-stream)
  1961.             sourcefiles (make-list (read-ubyte16 frame-stream)))
  1962.           (do ((p sourcefiles (rest p)))
  1963.           ((null p))
  1964.           (setf (first p) (read-isr2-string frame-stream)))
  1965.           (setf file-frame-path (read-isr2-string frame-stream)
  1966.             *old-frame-path* (parse-token-name file-frame-path))
  1967.           (when (null new-handle)
  1968.         (setf *new-frame-path* *old-frame-path*)
  1969.         (multiple-value-setq (new-handle new-more-path)
  1970.           (make-handle-from-parsed-path *new-frame-path*)))
  1971.           (cond ((null new-handle)
  1972.              (error "Bogus frame file:  bad frame path - ~S" file-frame-path))
  1973.             ((and (null new-more-path) 
  1974.               (not (member (handle-type new-handle)
  1975.                        '(:frame-feature :token-feature))))
  1976.              (unless merge-p
  1977.                (error "Frame already exists: ~S!" frame-path)))
  1978.             ((not (check-terminal-path new-handle new-more-path))
  1979.              (error "Bad path: ~S!" frame-path))
  1980.             (t (setf new-handle (create frame-path)
  1981.                  new-frame-p t)))
  1982.           (unless (eq (handle-type new-handle) :frame)
  1983.         (error "Bad path (not a frame!): ~S" frame-path))
  1984.           (setf frame-pointer (handle-frame new-handle))
  1985.           (cond
  1986.         (new-frame-p
  1987.           (setf (frame-documentation frame-pointer) frame-documentation
  1988.             (frame-source-file-list frame-pointer) sourcefiles))
  1989.         (t (setf (frame-source-file-list frame-pointer)
  1990.              (nunion sourcefiles (frame-source-file-list frame-pointer)
  1991.                  :test #'equalp))))
  1992.           (read-in-decendants frame-stream sub-frame-action 
  1993.                   (if (eq sub-frame-action :inherit-path) filename nil))
  1994.           (let ((exist-bit-vector (read-isr2-2vv frame-stream))
  1995.             (globalp-bit-vector (read-isr2-2vv frame-stream)))
  1996.            (if new-frame-p
  1997.                (setf (frame-token-set-existence-vector frame-pointer)
  1998.                  (if (eq tss :all) 
  1999.                  exist-bit-vector
  2000.                  (isect-2vv exist-bit-vector tss))
  2001.                  (frame-token-set-globalp-vector frame-pointer)
  2002.                  (if (eq tss :all)
  2003.                  globalp-bit-vector
  2004.                  (isect-2vv globalp-bit-vector tss))
  2005.                  )
  2006.                (progn
  2007.              (merge-bit-vectors
  2008.                exist-bit-vector
  2009.                (frame-token-set-existence-vector frame-pointer))
  2010.              (merge-bit-vectors
  2011.                globalp-bit-vector
  2012.                (frame-token-set-globalp-vector frame-pointer))
  2013.              )
  2014.                )
  2015.            (read-in-frame-features frame-stream frame-pointer 
  2016.                        merge-overlap-action new-frame-p
  2017.                        features)
  2018.            (read-in-token-features frame-stream frame-pointer 
  2019.                        exist-bit-vector merge-overlap-action
  2020.                        new-frame-p features tss)
  2021.            (unless (eq exist-bit-vector 
  2022.                    (frame-token-set-existence-vector
  2023.                  frame-pointer))
  2024.              (free-2vv exist-bit-vector)
  2025.              (free-2vv globalp-bit-vector))
  2026.            (fixup-sorts)
  2027.            )
  2028.           (setf new-frame-p nil)
  2029.           (setf (frame-is-loaded-p frame-pointer) t)
  2030.           (namestring (truename frame-stream))
  2031.           )
  2032.        )
  2033.      (when (and new-frame-p (handle-p new-handle))
  2034.        (destroy new-handle))
  2035.      )
  2036.        )
  2037.   )
  2038.  
  2039.  
  2040. (defun save (path filename &key (features t) &aux path-handle frame-path tss)
  2041.   "SAVE path filename &KEY (features t) - save a frame path to a file."
  2042.   (setf path-handle (%internal-handle path :terminal-p t :error-p nil))
  2043.   (when (null path-handle)
  2044.     (error "~S is not a known path!" path))
  2045.   (unless (and (handle-p path-handle)
  2046.            (member (handle-type path-handle) '(:frame :token-subset 
  2047.                               :token-sort)))
  2048.     (error "~S [~S] is not a savable path!" path path-handle))
  2049.   (when (eq (handle-type path-handle) :token-sort)
  2050.     (setf path-handle (make-tss path-handle)))
  2051.   (setf frame-path (frame path-handle)
  2052.     tss        (if (eq (handle-type path-handle) :frame)
  2053.                :all
  2054.                path-handle))
  2055.   (prog1
  2056.     (write-frame frame-path filename (if (listp features) features :all)
  2057.          tss)
  2058.     (unless (eq tss path) (make-null-tss! tss)))
  2059.   )
  2060.  
  2061. (defun get-frame-name-from-file (filename &aux frame-name)
  2062.   (with-open-isr2-frame-file (frame-stream filename :input)
  2063.      (unless (read-and-check-isr2-header frame-stream)
  2064.        (error "Not a frame file: ~S" filename))
  2065.      (setf frame-name (read-isr2-string frame-stream)))
  2066.   frame-name)
  2067.  
  2068. (defun load-frame (path filename &KEY (features t) (override :error) &aux
  2069.            path-handle)
  2070.   "LOAD-FRAME path filename &KEY (features t) (override :error) - load a frame
  2071. *under* path."
  2072.   (declare (ignore override))
  2073.   (setf path-handle (%internal-handle path :terminal-p t :error-p nil))
  2074.   (when (null path-handle)
  2075.     (error "~S is not a known path!" path))
  2076.   (cond ((not (handle-p path-handle))
  2077.      (read-frame path-handle filename (if (listp features) features :all) :all
  2078.              ))
  2079.     ((eq (handle-type path-handle) :frame)
  2080.      (read-frame
  2081.        (list path-handle (get-frame-name-from-file filename))
  2082.        filename
  2083.        (if (listp features) features :all) :all))
  2084.     ((eq (handle-type path-handle) :frame-feature)
  2085.      (read-frame
  2086.        (list (frame path-handle) (handle-feature path-handle))
  2087.        filename
  2088.        (if (listp features) features :all) :all))
  2089.     (t (error "The path ~S [~S] is not legal in this context!"
  2090.           path path-handle))
  2091.     )
  2092.   )
  2093.  
  2094. (defun load-data (path filename &key (features t) (override :error) &aux
  2095.            path-handle frame tss)
  2096.   "LOAD-DATA path filename &KEY (features t) (override :error) - load a frame
  2097. *at* path."
  2098.   (setf path-handle (%internal-handle path :terminal-p t :error-p nil))
  2099.   (when (null path-handle)
  2100.     (error "~S is not a known path!" path))
  2101.   (cond ((handle-p path-handle)
  2102.      (case (handle-type path-handle)
  2103.            (:frame (setf tss :all
  2104.                  frame path-handle))
  2105.            (:token-subset (setf tss path-handle
  2106.                     frame (frame path-handle)))
  2107.            (:token-sort (setf tss (make-tss path-handle)
  2108.                   frame (frame path-handle)))
  2109.            (t (error "The path ~S [~S] is not legal in this context!"
  2110.              path path-handle))))
  2111.     (t (setf frame path-handle
  2112.          tss :all)))
  2113.   (read-frame frame filename (if (listp features) features :all) tss
  2114.           :merge-p (handle-p frame)
  2115.           :merge-override-action override)
  2116.   )
  2117.  
  2118.  
  2119. (defun describe-decendants (stream frame-stream verbose)
  2120.   (let (decendant-path decendant-doc decendant-sources num-decendants)
  2121.        (setf num-decendants (read-ubyte16 frame-stream))
  2122.        (when verbose
  2123.      (format stream "~&Frame decendant~p:" num-decendants))
  2124.        (dotimes (i num-decendants)
  2125.         (setf decendant-path (read-isr2-string frame-stream)
  2126.               decendant-doc  (read-isr2-string frame-stream)
  2127.               decendant-sources  (read-isr2-sexpr-pkg 
  2128.                        frame-stream
  2129.                        (find-package (if (= *file-version-number* 0) 'user 'isr2))))
  2130.         (when verbose
  2131.           (format 
  2132.             stream
  2133.             "~&  ~3d. Path: ~A~&       Doc: ~A~&       Sources: ~S"
  2134.             (1+ i) decendant-path decendant-doc decendant-sources))
  2135.         )
  2136.        )
  2137.   )
  2138.  
  2139. (defun describe-frame-features (stream frame-stream verbose)
  2140.   (let (fname fdoc ftype f-if-needed f-if-getting f-if-setting
  2141.     fvalue
  2142.     (fcount (read-ubyte16 frame-stream))
  2143.     )
  2144.        (when stream (format stream "~&Frame feature~p: " fcount))
  2145.        (dotimes (i fcount)
  2146.         (setf fname (read-isr2-string frame-stream)
  2147.               fdoc  (read-isr2-string frame-stream)
  2148.               ftype (read-ubyte16 frame-stream)
  2149.               f-if-needed (make-list (read-ubyte16 frame-stream)))
  2150.         (do ((p f-if-needed (rest p)))
  2151.             ((null p))
  2152.             (setf (first p)
  2153.               (read-isr2-sexpr-pkg
  2154.                 frame-stream
  2155.                 (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  2156.         (setf f-if-setting (make-list (read-ubyte16 frame-stream)))
  2157.         (do ((p f-if-setting (rest p)))
  2158.             ((null p))
  2159.             (setf (first p)
  2160.               (read-isr2-sexpr-pkg
  2161.                 frame-stream
  2162.                 (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  2163.         (setf f-if-getting (make-list (read-ubyte16 frame-stream)))
  2164.         (do ((p f-if-getting (rest p)))
  2165.             ((null p))
  2166.             (setf (first p)
  2167.               (read-isr2-sexpr-pkg
  2168.                 frame-stream
  2169.                 (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  2170.         (setf fvalue
  2171.               (case ftype
  2172.                 ((#.*boolean* #.*int*)
  2173.                  (read-sbyte32 frame-stream))
  2174.                 (#.*real*
  2175.                   (read-float32 frame-stream))
  2176.                 (#.*handle*
  2177.                   (read-isr2-handle frame-stream t))
  2178.                 (#.*extents*
  2179.                   (read-isr2-extents frame-stream))
  2180.                 (#.*bitplane*
  2181.                   (read-isr2-bitplane frame-stream))
  2182.                 (#.*array*
  2183.                   (read-isr2-array frame-stream))
  2184.                 ((#.*string* #.*pointer*)
  2185.                  (read-isr2-sexpr-pkg 
  2186.                    frame-stream
  2187.                    (find-package (if (= *file-version-number* 0) 'user 'isr2))))))
  2188.         (when stream
  2189.           (format
  2190.             stream
  2191.             "~&   ~3d. Name: ~A~&        Doc: ~A~&        Type: ~A"
  2192.             (1+ i) fname fdoc (elt *type-names* ftype))
  2193.           (when verbose
  2194.             (format
  2195.               stream
  2196.               "~&        If-Needed: ~S~&        If-Getting: ~S~&        If-Setting: ~S"
  2197.               f-if-needed f-if-getting f-if-setting)))
  2198.         )
  2199.        )
  2200.   )
  2201.  
  2202. (defun describe-token-features (stream frame-stream verbose)
  2203.   (let (fname fdoc ftype f-if-needed f-if-getting f-if-setting
  2204.     (fcount (read-ubyte16 frame-stream))
  2205.     )
  2206.        (format stream "~&Token feature~p: " fcount)
  2207.        (dotimes (i fcount)
  2208.       (setf fname (read-isr2-string frame-stream)
  2209.         fdoc  (read-isr2-string frame-stream)
  2210.         ftype (read-ubyte16 frame-stream)
  2211.         f-if-needed (make-list (read-ubyte16 frame-stream)))
  2212.       (do ((p f-if-needed (rest p)))
  2213.           ((null p))
  2214.           (setf (first p)
  2215.             (read-isr2-sexpr-pkg
  2216.               frame-stream
  2217.               (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  2218.       (setf f-if-setting (make-list (read-ubyte16 frame-stream)))
  2219.       (do ((p f-if-setting (rest p)))
  2220.           ((null p))
  2221.           (setf (first p)
  2222.             (read-isr2-sexpr-pkg
  2223.               frame-stream
  2224.               (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  2225.       (setf f-if-getting (make-list (read-ubyte16 frame-stream)))
  2226.       (do ((p f-if-getting (rest p)))
  2227.           ((null p))
  2228.           (setf (first p)
  2229.             (read-isr2-sexpr-pkg
  2230.               frame-stream
  2231.               (find-package (if (= *file-version-number* 0) 'user 'isr2)))))
  2232.      (free-2vv (read-isr2-2vv frame-stream t))
  2233.      (format
  2234.        stream
  2235.        "~&   ~3d. Name: ~A~&        Doc: ~A~&        Type: ~A"
  2236.        (1+ i) fname fdoc (elt *type-names* ftype))
  2237.      (when verbose
  2238.        (format
  2239.          stream
  2240.          "~&        If-Needed: ~S~&        If-Getting: ~S~&        If-Setting: ~S"
  2241.          f-if-needed f-if-getting f-if-setting))
  2242.      )
  2243.        )
  2244.   )
  2245.  
  2246.  
  2247. (defun describe-file (filename &key (stream *standard-output*) (features nil)
  2248.                    (verbose nil) &aux *file-version-number*)
  2249.   "DESCRIBE-FILE filename &KEY  (stream *standard-output*) (features nil)
  2250.                 (verbose nil) -
  2251. Describes the contents of the frame file specified.  Output is sent to stream.
  2252. Features specifies which features to give info on and verbose specifies how
  2253. verbose the output should be.  Features can be NIL (no feature info), :FRAME
  2254. (give frame feature info), :TOKEN (give token feature info), or :ALL (both kinds
  2255. features)."
  2256.   (unless (member features '(nil :frame :token :all))
  2257.     (error "Bad keyword value for :features - ~S" features))
  2258.   (setf filename (truename filename))
  2259.   (format stream "~2&Description of file ~A" (namestring filename))
  2260.   (with-open-isr2-frame-file (frame-stream filename :input)
  2261.      (unless (setf *file-version-number*
  2262.            (read-and-check-isr2-header frame-stream))
  2263.        (error "Not a frame file: ~S" filename))
  2264.      (format stream "~&Frame name: ~A" (read-isr2-string frame-stream))
  2265.      (if verbose
  2266.        (read-isr2-string frame-stream)
  2267.        (format stream "~&Feame documentation: ~A" (read-isr2-string frame-stream)))
  2268.      (let ((sourcefiles (make-list (read-ubyte16 frame-stream))))
  2269.       (do ((p sourcefiles (rest p)))
  2270.           ((null p))
  2271.           (setf (first p) (read-isr2-string frame-stream)))
  2272.       (when verbose
  2273.         (format stream "~&Source file~p: ~{~&  ~A~}"
  2274.             (length sourcefiles)
  2275.             sourcefiles))
  2276.       )
  2277.      (if verbose
  2278.      (format stream "~&Frame path: ~A" (read-isr2-string frame-stream))
  2279.      (read-isr2-string frame-stream))
  2280.      (describe-decendants stream frame-stream verbose)
  2281.      (let ((exist-bit-vector (read-isr2-2vv frame-stream))
  2282.        (globalp-bit-vector (read-isr2-2vv frame-stream)))
  2283.       (format stream "~&Token count: ~D/~D"
  2284.           (active-token-count-2vv exist-bit-vector)
  2285.           (total-token-count-2vv  exist-bit-vector))
  2286.       (when verbose
  2287.         (format stream ", global token count: ~D/~D"
  2288.             (active-token-count-2vv globalp-bit-vector)
  2289.             (total-token-count-2vv  globalp-bit-vector))
  2290.         )
  2291.       (free-2vv exist-bit-vector)
  2292.       (free-2vv globalp-bit-vector))
  2293.      (when features
  2294.        (describe-frame-features (if (member features '(:frame :all))
  2295.                     stream
  2296.                     nil)
  2297.                 frame-stream verbose)
  2298.        (when (member features '(:all :token))
  2299.      (describe-token-features stream frame-stream verbose)))
  2300.      (namestring (truename frame-stream))
  2301.      )
  2302.   )
  2303.  
  2304. (defun store (frame-path filename &aux (handle (handle frame-path :error-p nil)))
  2305.   "STORE frame-path filename - saves a complete frame in the specified file."
  2306.   (unless handle
  2307.     (error "Not a defined path: ~S" frame-path))
  2308.   (write-frame (frame handle) filename :all :all t))
  2309.  
  2310.  
  2311.  
  2312. (defun restore (frame-path filename &aux path-handle)
  2313.   "RESTORE frame-path filename - loads a complete frame from the specified
  2314. file."
  2315.   (setf path-handle (handle frame-path :error-p nil))
  2316.   (when (and path-handle (eq (handle-type path-handle) :frame))
  2317.     (error "Frame already exists: ~S" frame-path))
  2318.   ;;  Ross's change, this will never prompt unless root file is not found!
  2319.   (read-frame frame-path filename :all :all 
  2320.           :merge-p nil 
  2321.           :sub-frame-action :load
  2322.           :merge-overlap-action :error)
  2323.   )
  2324.  
  2325. (defun restore-with-prompts (frame-path filename &aux path-handle)
  2326.   "RESTORE frame-path filename - loads a complete frame from the specified
  2327. file."
  2328.   (setf path-handle (handle frame-path :error-p nil))
  2329.   (when (and path-handle (eq (handle-type path-handle) :frame))
  2330.     (error "Frame already exists: ~S" frame-path))
  2331.   ;;  Ross's change, this will never prompt unless root file is not found!
  2332.   (read-frame frame-path filename :all :all 
  2333.           :merge-p nil 
  2334.           :frame-ask-user t
  2335.           :merge-overlap-action :error)
  2336.   )
  2337.  
  2338. (defun restore-inherit-path (frame-path filename &aux path-handle)
  2339.   "RESTORE frame-path filename - loads a complete frame from the specified
  2340. file.  
  2341.  
  2342.    Always assume when loading subframes that the device and directory from
  2343. which to load is the same as that specified with the file name passed in.
  2344.   "
  2345.   (setf path-handle (handle frame-path :error-p nil))
  2346.   (when (and path-handle (eq (handle-type path-handle) :frame))
  2347.     (error "Frame already exists: ~S" frame-path))
  2348.   (read-frame frame-path filename :all :all 
  2349.           :merge-p nil 
  2350.           :sub-frame-action :inherit-path
  2351.           :frame-ask-user nil
  2352.           :merge-overlap-action :error)
  2353.   )
  2354.