;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; 
;;;$Header: /ct/interp/directio.l,v 1.33 84/09/26 13:35:27 alex Exp $
;;; 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;				DIRECTIO                             ;;;
;;;                                                                  ;;;
;;; LISP Code to implement direct input-output for Ada.              ;;;
;;;                                                                  ;;;
;;; John Shelton                                          Early 1983 ;;;
;;; Updated by Mark Miller                          Wed 28 Sept 1983 ;;;
;;;                                                                  ;;;
;;; Data elements are stored as PRIN-able and READ-able S-           ;;;
;;; expresssions in a file.  The first element in a file contains    ;;;
;;; the size (in elements) of the file.  This is always read upon    ;;;
;;; init.                                                            ;;;
;;;                                                                  ;;;
;;; Looking forward in a file requires READing forward across all    ;;;
;;; intermediary text.  This can be rather slow for files with very  ;;;
;;; many objects, or many large objects.  A DIRECTORY at the         ;;;
;;; beginning of the file that gave the bytecount starting position  ;;;
;;; of each object would speed up such things.  Such a directory     ;;;
;;; would itself be expensive to maintain if the file contained many ;;;
;;; small objects.  The directory scheme has been implemented.       ;;;
;;;                                                                  ;;;
;;; To save lots of disk access during normal direct reads, we cache ;;;
;;; a lot of stuff in a QUEUE of 500 elements.  This queue records   ;;;
;;; the last 500 (lineal) elements read from the file so we don't    ;;;
;;; have to read from the beginning of the file to find recent       ;;;
;;; items.  This won't help in extreme cases, but should help in     ;;;
;;; general.                                                         ;;;
;;;                                                                  ;;;
;;; The read cache behaves as a queue, and is implemented as an      ;;;
;;; array with start and end pointers.  (We use an array to avoid    ;;;
;;; unnecessary consing, and to increase the speed of reference.)    ;;;
;;; Unfortunately, this means a fixed overhead to a direct file,     ;;;
;;; but, what-the-hell, there is plenty of address space on the      ;;;
;;; target machines, anyway.                                         ;;;
;;;                                                                  ;;;
;;; This file is part of a proprietary software project.  Source     ;;;
;;; code and documentation describing implementation details are     ;;;
;;; available on a confidential, non-disclosure basis only.  These   ;;;
;;; materials, including this file in particular, are trade secrets  ;;;
;;; of Computer * Thought Corporation.                               ;;;
;;;                                                                  ;;;
;;; (c) Copyright 1982 and 1983,  Computer * Thought Corporation.    ;;;
;;;     All Rights Reserved.                                         ;;;
;;;                                                                  ;;;
;;; Reference materials:                                             ;;;
;;;   Foderaro and Sklower, The FRANZ LISP Manual, September 1981.   ;;;
;;;   Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981.   ;;;
;;;   Charniak et al., 1980.  Artificial Intelligence Programming.   ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;;   AJPO, Feb 1983.  ANSI/MIL-STD-1815A  Ada Reference Manual.     ;;;
;;; The following code assumes familiarity with these materials.     ;;;
;;;                                                                  ;;;
;;;	        ASSUMES CT_LOAD AND SUITABLE FILEMAP                 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(eval-when (compile load eval) (ct_load 'charmac))	;Char set exten.

(eval-when (compile load eval) (ct_load 'aip))	  ;AIP macros pkg. 

(eval-when (compile load eval) (ct_load 'compat)) ;Franz/LM compat pkg.

(eval-when (compile load eval) (ct_load 'cthash)) ;Hash Table.

(eval-when (compile load eval) (ct_load 'iocompat))	;TextIO Compat.

(eval-when (compile load eval) (ct_load 'bifmacs)) 

(eval-when (compile load eval) (ct_load 'stdenv))

(eval-when (compile load eval) (ct_load 'diana)) ; diana structure

(eval-when (compile load eval) (ct_load 'sequenio))

(eval-when (compile load eval)		  ;For string package
	   (ct_load 'ctstrl))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))
(declare (ct_includef 'intrpdcl))

(declare (special *dirio_temp_file_list*
		  **direct_file_list**
		  **direct_file_num**))

(defvar *temp_directory* (ct_load_get 'temp_directory))
			  ;; temporary file directory used in dump_cache
		  
;;; Size of the read_cache, used in a lot of places.
(declare (special *read_cache_size*))
(declare (special *directory_number_width*))
(declare (special *read_position_threshhold*))
(defun direct_init ()
  (let ((base 10.) (ibase 10.))
    (setq *read_cache_size* 500.)
    
;;; The directory is implemented as fixnums stored in the file in fixed
;;; width slots.  (This makes it easy to compute the address of a directory
;;; entry in a file.)  There is always one extra directory entry that is 
;;; ignored.
    
;;; How many bytes a directory entry takes, including spaces.
    
    (setq *directory_number_width* 10.)
    
;;; If we HAVE to read from a file, how many elements away from where we
;;; are do we want to use direct positioning instead of just reading.
;;; Also, this number indicates how far before the desired position we
;;; start reading.  This should be less than *read_cache_size* and seems
;;; that it ought to be about 1/4 of *read_cache_size*.
    
    (setq *read_position_threshhold* 50.)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Macros/Flavors/Methods -- 

              ;;;;;;;;;;;
(ct_defflavor ada_direct_io_file 
              ;;;;;;;;;;;

    (real_stream		;; This may change through course of r/w.
     name			;; Filename of the file we diddle.
     file_size		        ;; Size in records of external file.
     (index 1)		        ;; Next record to be read or written.
     (filepos 1)		;; Where file thinks it really is.
     mode			;; One of in, out, inout.
     status			;; One of open, closed.
     write_cache		;; Where we store writes.
     (read_cache (gensym))	;; The read cache.
     (read_cache_start 0)	;; First element of read q.
     (read_cache_end 0)		;; Last element of read q.
     (read_cache_start_key 0)   ;; Key of first element.
     (read_cache_end_key 0)     ;; Key of last element.
    )
    ()
    :settable-instance-variables
    :gettable-instance-variables)


           ;;;;;;;;;;;;;;;;;;;;;;;
(ct_defmethod (ada_direct_io_file d_init) ()
           ;;;;;;;;;;;;;;;;;;;;;;;

  ;;; Create the hash table.  Also, initialize file_size.  And, create
  ;;; the read_cache array.
  (let ((base 10.) (ibase 10.))
	  (setq write_cache (ct_make_hash_table 464 'dump_cache self))
	  #+franz (*array read_cache t *read_cache_size*)
	  #+(or 3600 cadr) (setq read_cache (make-array *read_cache_size*))
	  (setq file_size (ct_read real_stream))
	  (ct_send self 'init_filepos)

	  ))


       ;;;;;;;;;;;;;;;;;
(defun fixed_width_print (fixnum stream)
  ;;;;;;;;;;;;;;;;;
  
  ;;; This function prints an integer right justified in a
  ;;; fixed field,  with one trailing space.
  ;;; (fixed_width_print 145 terminal-io) will  print " 145 "
  ;;; on the terminal when *directory_number_width* is 6.
  ;;; (The quote signs will not be printed, of course.)
  
  #+lispm
  (let ((base 10.)
	(ibase 10.))
    (ct_format stream "~VD" *directory_number_width* fixnum)
    
					  ;(1- *directory_number_width*)
    #+franz
    ;;; Must resort to kludges since Franz Format is inadequate.
    (princ (pad_right_list (exploden fixnum)
			   *directory_number_width*
			   #/ ) stream)
    ))


#+franz
       ;;;;;;;;;;;;;;
(defun pad_right_list (str n char)
       ;;;;;;;;;;;;;;
  ;;; Internal to fixed_width_print, above.
  ;;; This is a special purpose function which places a string (ahem)
  ;;; in a field of spaces with one space on the right and the rest
  ;;; of the spaces on the left.

  (ct_if (< (length str) n)
	 (maknam (append (firstn (- n 1 (length str)) (circular-list char))
			 str
			 (list char)))
	 (maknam str)))



;;; NB: The write_cache (implemented as a hash-table) stores
;;; all write requests.  This means we don't actually have
;;; to write to disk every time the user writes an element.
;;; When the hash table gets full, the rehash-function
;;; DUMP_CACHE is called.  Instead of increasing the size of
;;; the table, dump_cache writes all the queued elements to
;;; disk in one sweep, and then clears the hash table.

       ;;;;;;;;;;
(defun dump_cache (table)
       ;;;;;;;;;;

  ;;; Puts all the cached write info into the file, by rewriting the file
  ;;; from scratch.  The directory is printed first.

    (let* ((file (ht_owner table))
	   (base 10.) (ibase 10.)
	   (ocount (get-iv ada_direct_io_file file 'file_size))
	   (count (max (ht_max_key table) ocount))
	   (fname (get-iv ada_direct_io_file file 'name))
	   (tempname #|(fs:make-pathname ':name
				       (ct_string_downcase (gensym))
				       ':directory
				       (ct_send (ct_send
						  (ct_send file 'real_stream)
						  'pathname)
						':directory))|#
		     (ct_string_append *temp_directory*
				       (ct_format nil (gensym))))
	   (foo (ct_open_out tempname))
	   (w 0)
	   (prinlength nil)
	   (prinlevel nil)
	   (*nopoint t)
	   newstream)
      (ct_send file 'init_filepos)        ; Ready to read first elt.
      (fixed_width_print count foo)	  ; Print the number of entries.
      (fixed_width_print 0 foo)		  ; First elt is at locn 0.

      ;; Print the entries in the directory for items already in file.
      (loop for i from 1 to ocount
	    for item = (ct_send file 'read_element)
	    for hitem = (ct_gethash i table)
	    for width first (1+ (flatc (ct_if hitem (cdr hitem) item)))
	     then (+ width 1 (flatc (ct_if hitem (cdr hitem) item)))
	    doing (fixed_width_print width foo)
	    finally (setq w width))
      (ct_send file 'init_filepos)        ; Ready to read first elt.
      (ct_if (not w) (setq w 0))	  ; Previous loop can clr w.

      ;; Print entries in directory for items not in file.
      (loop for i from (1+ ocount) to count
	    for hitem = (cdr (ct_gethash i table))
	    for width first (+ 1 (flatc hitem) w)
	     then (+ width 1 (flatc hitem))
	    doing (fixed_width_print width foo))

      ;;  Now, print elts that were in old file, replacing with new if can.
      (loop for i from 1 to ocount
	    for item = (ct_send file 'read_element)
	    for hitem = (ct_gethash i table)
	    doing (prin1_sp (ct_if hitem (cdr hitem) item) foo))

      ;;  Next, print elements that are after any elements in the old
      ;;  file, printing NILs where nothing has been stored.
      (loop for i from (1+ ocount) to count
	    for hitem = (cdr (ct_gethash i table))
	    doing (prin1_sp hitem foo))

      ;;  Now close up the old & new files, and rename.
      (ct_closef foo) 
      (ct_closef (get-iv ada_direct_io_file file 'real_stream))
      (ct_deletef fname)
      ;;(ct_renamef tempname fname)
      (ct_copy_temp_file tempname fname)
      (ct_deletef tempname)
      (set-iv ada_direct_io_file file 'real_stream
				      (ct_open_in fname))
      (ct_send file 'recompute_file_size)
      (ct_clrhash table)))

(defun ct_copy_temp_file (tempname fname)
  (let ((bar (ct_open_out fname)))
    (do ((foo (ct_open_in (ct_string_append tempname ".lisp.1")))
	 (ch nil)
	 (eof nil))
	(eof)
      (ct_if (setq ch (ct_tyi foo nil))
	     (ct_tyo ch bar)
	     (setq eof t))
      )
    (ct_closef bar)
    ))

(defun get_directory (stream)
  (do ((dirl (ct_send (ct_send stream 'pathname) 'directory) (cdr dirl))
       (dir ""))
      ((null dirl) (ct_string_append dir "//"))
    (setq dir (ct_string_append dir "//" (car dirl)))
    ))

#|
;;; file copy
(defun ct_file_copy (from to)
  (do ((eof nil) (ch nil))
      (eof)
    (cond ((setq eof (null (setq ch (ct_tyi from nil)))))
	  (t (ct_tyo ch to)))
    ))
|#


           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(ct_defmethod (ada_direct_io_file recompute_file_size) ()
           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;;; Reads the filesize from the directory.  Assumes the file is just at
  ;;; the beginning.  Then sets file ready to read first element.

  (setq file_size (ct_read real_stream))
  (ct_send self 'init_filepos))


;;; For convenience, all elements are read or written as LISP S-exps, so 
;;; that LISP's READ can get them back easily.



           ;;;;;;;;;;;;;;;;;;;;;;;;;;
(ct_defmethod (ada_direct_io_file find_element) (n)
           ;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;;; Finds the Nth element in a file by doing:
  ;;; 0.  The caller should look in the write cache.  Find_element won't.
  ;;; 1.  Check to see if it should exist.  If not, ERROR.
  ;;; 2.  Check to see if element is after end of existing file, but 
  ;;;     before some element in the write cache.  Return NIL.
  ;;; 3.  Check to see if element is in read cache.  If so, access it
  ;;;     using AREF (quickly) and return it.
  ;;; 4.  Else, decide to read forward in file, accumulating stuff in
  ;;;     the read cache, or reset the file and read cache, and read 
  ;;;     forward to find it.

  (let (a b (base 10.) (ibase 10.))
    (cond
      ;; No possible element: (i.e. past last element)
      ((> n (max (ht_max_key write_cache) file_size))
       (ada_raise '|end_error| "Attempt to read record past end of file."))
      
      ;; Not in real file nor cache, so must be nil.
      ((> n file_size)
       nil)
      
      ;; In the read_cache.
      ((<= read_cache_start_key n (1- read_cache_end_key))
       #+franz (apply read_cache (list (remainder
				 (- (+ *read_cache_size* read_cache_end)
				    (- read_cache_end_key n))
				 *read_cache_size*)))
       #+(or 3600 cadr) (aref read_cache (remainder
				 (- (+ *read_cache_size* read_cache_end)
				    (- read_cache_end_key n))
				 *read_cache_size*))
       )
      
      ;; If we get here, it is not in the read cache.  We will have to
      ;; read stuff from the file, and adjust the read cache as we go
      ;; along.  
      (t ;; If read too far, go to beginning of file. After this, the
         ;; filepos must be before the desired element.
         (ct_if (> filepos n) (ct_send self 'reset))	

	 ;; If we would have to read too many elements to get to the
	 ;; right one, use direct positioning to get there quicker.
	 ;; This puts us at most *read_position_threshhold* elements
	 ;; away from the correct element.  We don't zap right to it
	 ;; because we want to put some nearby elements in the
	 ;; read_cache, assuming it is faster to find stuff in the cache
	 ;; than to position a file.
	 (ct_if (> n (+ filepos *read_position_threshhold*))
	     (ct_send self 'element_position (- n *read_position_threshhold*)))
	 
	 ;; If we are not just about to read the element just after the
	 ;; last one in the queue, we reset the queue.  This makes sure
	 ;; queue contains only a linear, adjacent collection of elements.  
	 (ct_if (not (= filepos read_cache_end_key))
		(ct_send self 'clear_read_cache))
	 (ct_if (zerop read_cache_start_key)	;If read cache is empty,
	     (setq read_cache_start_key filepos	;start it correctly.
		   read_cache_end_key   filepos))
	 (setq b (- n filepos -1))
	 (ct_dotimes b
	    (setq a (ct_send self 'read_element))
	    (ct_if (= (remainder (1+ read_cache_end) *read_cache_size*)
		   read_cache_start)
		;; If r_c full, roll both end and start one.
		(setq read_cache_start (remainder (1+ read_cache_start)
						  *read_cache_size*)
		      read_cache_start_key (1+ read_cache_start_key)
		      read_cache_end (remainder (1+ read_cache_end)
						*read_cache_size*)
		      read_cache_end_key (1+ read_cache_end_key))
		;; If the cache is not full, roll only end.
		(setq read_cache_end (remainder (1+ read_cache_end)
						*read_cache_size*)
		      read_cache_end_key (1+ read_cache_end_key)))
	    ;; Finally, store in the array.
	    #+franz (eval `(store (,read_cache ,(remainder (+ *read_cache_size*
					      (1- read_cache_end))
					   *read_cache_size*))
                          ',a))
	    #+(or 3600 cadr) (aset a
				   read_cache
				   (remainder (+ *read_cache_size*
					      (1- read_cache_end))
					   *read_cache_size*))
	    )
	 a))))


           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(ct_defmethod (ada_direct_io_file clear_read_cache) ()
           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;;; Clears the read cache.  Simple enough.

  (setq read_cache_start_key 0
	read_cache_start     0
	read_cache_end_key   0
	read_cache_end       0))


           ;;;;;;;;;;;;;;;;;;;
(ct_defmethod (ada_direct_io_file reset) ()
           ;;;;;;;;;;;;;;;;;;;

  ;;; Positions file to read first element, and clears the read cache.

  (ct_send self 'init_filepos)
  (ct_send self 'clear_read_cache))


           ;;;;;;;;;;;;;;;;;;;;;;;;;;
(ct_defmethod (ada_direct_io_file read_element) ()
           ;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;;; Reads an actual element from a file.  Updates filepos.

  (setq filepos (1+ filepos))
  (ct_read real_stream))


       ;;;;;;;;;;;
(defun open_direct (name mode)
       ;;;;;;;;;;;

  ;;; Open_direct opens a file up for direct_io.

  (ct_make_instance 'ada_direct_io_file
		 'name name
		 'real_stream (ct_open_in name)
		 'mode mode
		 'status 'open))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; "Directory" manipulation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; It has been decided to "bite the bullet" and write a directory of
;;; elements to disk to make accessing quicker.  (I do not know whether
;;; this will really make accessing quicker.)  A directory is a
;;; sequence of numbers, all of uniform width (printed in decimal)
;;; written at the beginning of a file.  Each number represents the
;;; BYTE COUNT of the element within the file, with the first element
;;; being at position 0, even though it is after the directory.  The
;;; true position is calculated by adding to the directory entry an
;;; OFFSET which is easily calculated as the product of the number of
;;; entries in the file and the directory_number_width, which tells how
;;; many digits are in each number.

;;; As an example, the initial directory number width is 9, which
;;; allows 8 digits and a terminating space.

;;; The first (zero) entry in the directory is actually a count of how
;;; many elements are in the file.  This is also, of course, the number
;;; of entries in the directory.

;;; A method element_position will move the pointer in the file so that
;;; the next element to be read will be element N.  This is
;;; accomplished by calculating the position in the file of the
;;; directory entry for element N, reading the directory entry, and
;;; then positioning the file pointer.  The file position is also
;;; updated.  (NB:  File pointer is a value manipulated by the file
;;; system that indicates which byte is about to be read from a file.
;;; File position is a value we maintain that indicates what ELEMENT is
;;; about to be read from the file.)


           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(ct_defmethod (ada_direct_io_file element_position) (n)
           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;;; Positions a file to be ready to read element n.
  
  ;; First, position the file pointer to be ready to read the dir entry.
  (ct_send self 'set_pointer (* n *directory_number_width*))

  ;; Now, position the file pointer correctly, by computing the sum of
  ;; the directory value (which is read) and the offset.
  (let ((num (ct_read real_stream)))
    (ct_send self 'set_pointer
	  (+ num (* *directory_number_width* (+ 2 file_size)))))

  ;; Finally, update filepos to indicate which element is next.
  (setq filepos n))


           ;;;;;;;;;;;;;;;;;;;;;;;;;;
(ct_defmethod (ada_direct_io_file init_filepos) ()
           ;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;;; Sets filepos to 1, and actually positions file pointer there, too.

  (setq filepos 1)
  (ct_send self 'set_pointer (* *directory_number_width* (+ 2 file_size))))


           ;;;;;;;;;;;;;;;;;;;;;;;;;
(ct_defmethod (ada_direct_io_file set_pointer) (pos)
           ;;;;;;;;;;;;;;;;;;;;;;;;;

  ;;; Sets the file pointer (bytes).

  #+lispm
  (set-iv ada_direct_io_file real_stream 'pointer pos)

  #+franz
  (fseek real_stream pos 0)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros/Methods -- 

       ;;;;;;;;;;;;;;;;;;;;
(defun ada_direct_io_create (ar)
       ;;;;;;;;;;;;;;;;;;;;

  ;;; Creates a new file for read, write, or both.  Form is ignored.

  (with_ada_parameters ((file file) (mode mode) (name name) (form form))
   (let* ((fmod  (#+lispm string #+franz get_pname
		 (implode (second (diana_get mode 'lx_symrep)))))
	  (fmode (cond ((equal "in_file" fmod) 'in)
		       ((equal "out_file" fmod) 'out)
		       (t 'inout)))
	  (fname (#+lispm string #+franz get_pname
		 (implode (second (convert_strrep_to_lexstr  name)))))
	  (fform (#+lispm string #+franz get_pname
		  (implode (second (convert_strrep_to_lexstr  form)))))
	  (ffile (ct_if (eq (get_filepos file) 0)
			nil
			(get_filepos file)))
	  (fileo (cond (ffile (ct_nth ffile **direct_file_list**))
		       (t nil)))
	  (tempfile nil))

     (ct_if fileo (ada_raise '|status_error| "File object already exists."))
     (ct_if (null fmode) (setq fmode 'inout))
     (ct_if (not (memq fmode '(in out inout)))
	    (ada_raise '|status_error| "Mode must be in, out, or inout"))
     (ct_if (equal fname "")	    ; Implies file is temporary.
	    (setq fname (ct_string_append
			  "#junk" (#+lispm string #+franz get_pname (gensym)))
		   tempfile t
		  ))

     (let* ((f (errset (ct_open_out fname) nil))  ;Open up file (to create it).
	    (f (ct_if f (car f)
		      (ada_raise '|name_error| "cannot create the file"))))
	      
       (fixed_width_print 0 f)		  ;Indicate 0 records.
       (fixed_width_print 0 f)		  ;Print dummy address.
       (ct_closef f))
     (setq fileo (open_direct fname fmode))
     (setq **direct_file_list** (nconc **direct_file_list**
				       (list fileo))
	   file (list **direct_file_num**)
	   **direct_file_num** (add1 **direct_file_num**))
     (ct_send fileo 'd_init)
     (ct_if tempfile (setq *dirio_temp_file_list*
				 (cons fileo *dirio_temp_file_list*)))
     (list file mode name form))))


       ;;;;;;;;;;;;;;;;;;;;
(defun ada_direct_io_open (ar)
       ;;;;;;;;;;;;;;;;;;;;

  ;;; Opens an existing file for input.
  (with_ada_parameters ((file file) (mode mode) (name name) (form form))
   (let* ((fmode (cond ((equal mode '*unassigned*)
			(ada_raise '|program_error|
				   "unassigned MODE"))
		       (t (#+lispm string #+franz get_pname
			   (implode (second (diana_get mode 'lx_symrep)))))
		       ))
	  (fmode (cond ((equal "in_file" fmode) 'in)
		       ((equal "out_file" fmode) 'out)
		       (t 'inout)))
	  (fform (#+lispm string #+franz get_pname
		  (implode (second (convert_strrep_to_lexstr  form)))))
	  (fname (cond ((equal name '*unassigned*) "")
		       (t (#+lispm string #+franz get_pname
			   (implode (second (convert_strrep_to_lexstr  name)))))
		       ))
	  (ffile (ct_if (eq (get_filepos file) 0)
			nil
			(get_filepos file)))
	  (fileo (cond ((null ffile)
			(ct_if (not (ct_probef fname))
			  (ada_raise '|name_error|
				     "Non-existing file cannot be open")
			  (find_ada_file fname
					 **sequen_file_list**)))
			(t (ct_nth ffile **direct_file_list**))))
	  
	  )
  (ct_if (not (ct_probef fname))
      (ada_raise '|name_error| "File does not exist."))
  (ct_if (null fmode) (setq fmode 'inout))
  (ct_if (not (memq fmode '(in out inout)))
      (ada_raise '|status_error| "Mode must be in, out or inout."))
  (setq fileo (let ((f (errset (open_direct fname fmode) nil)))
		(ct_if f (car f)
		       (ada_raise '|name_error| "cannot open file"))))
  (setq **direct_file_list** (nconc **direct_file_list**
				      (list fileo))
	  file (list **direct_file_num**)
	  **direct_file_num** (add1 **direct_file_num**))
  (ct_send fileo 'd_init)
  (list file mode name form))))


       ;;;;;;;;;;;;;;;;;;;;;
(defun ada_direct_io_close (ar)
  ;;;;;;;;;;;;;;;;;;;;;
  
  ;;; Closes a file, writing the write_cache iff it has changed.  This
  ;;; is determined easily by looking at the max_key.
  
  (with_ada_parameters ((file file))
   (let ((fileo (ct_nth (file_exist_check file) **direct_file_list**)))
     (ct_if (neq (get-iv ada_direct_io_file fileo 'status) 'open)
	    (ada_raise '|status_error| "Cannot close a file already closed."))
     (ct_if (not (zerop (ht_max_key (ct_send fileo 'write_cache))))
	    (dump_cache (ct_send fileo 'write_cache)));Dump contents of cache,
     (set-iv ada_direct_io_file fileo 'status 'closed)   ;;which rewrites the file.
     (ct_closef (ct_send fileo 'real_stream))
     (list file))))


       ;;;;;;;;;;;;;;;;;;;;
(defun ada_direct_io_delete (ar)
       ;;;;;;;;;;;;;;;;;;;;

  ;;; Closes and deletes the file.  Does not bother to write the write
  ;;; cache, since it would be lost anyway.
  (with_ada_parameters ( (file file))
   (let* ((fileo (ct_nth (file_exist_check file) **direct_file_list**)))

     (ct_if (neq (get-iv ada_direct_io_file fileo 'status) 'open)
	    (ada_raise '|status_error| "Cannot delete a file already closed."))
     (set-iv ada_direct_io_file fileo 'status 'closed)
     (ct_closef (get-iv ada_direct_io_file fileo 'real_stream))
     (ct_deletef (get-iv ada_direct_io_file fileo 'name))
     (list file))))


       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ada_direct_io_reset_with_mode (ar)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;;; procedure RESET (FILE : in out FILE_TYPE; 
  ;;;                  MODE : in FILE_MODE);
  ;;; 
  ;;;    Resets the given file so that reading  from  or  writing  to  its
  ;;;    elements  can  be  restarted  from the beginning of the file;  in
  ;;;    particular, for direct access this means that the  current  index
  ;;;    is  set  to 1.  If a MODE parameter is supplied, the current mode
  ;;;    of the given file is set to the given mode.
  ;;;    
  ;;;    The exception STATUS_ERROR is raised if the  file  is  not  open.
  ;;;    The  exception  USE_ERROR  is  raised if the environment does not
  ;;;    support resetting for the external file and, also, if the environ-
  ;;;    ment does not support resetting to the specified mode for the
  ;;;    external file.

  ;;; {Operates by closing and re-opening the file.}

  (with_ada_parameters ((file file) (mode mode))
   (let* ((fmode (#+lispm string
		  #+franz get_pname
		 (implode (second (diana_get mode 'lx_symrep)))))
	  (fmode (cond ((equal "in_file" fmode) 'in)
		       ((equal "out_file" fmode) 'out)
		       (t 'inout)))
	  (fileo (ct_nth (file_exist_check file) **direct_file_list**)))
    (ct_if (neq (get-iv ada_direct_io_file fileo 'status) 'open)
	   (ada_raise '|status_error|
		      "File not open, cannot reset."))
    (ct_if (not (memq fmode '(inout in out)))
	   (ada_raise '|status_error|
		      "Mode must be in_file or out_file when resetting."))
    (ct_if (not (zerop (ht_max_key (ct_send fileo 'write_cache))))
	   (dump_cache (ct_send fileo 'write_cache)))
    (ct_send fileo 'reset)
    (set-iv ada_direct_io_file fileo 'index 1) ; Next read or write at index=1.
    (set-iv ada_direct_io_file fileo 'mode fmode)
    (list file fmode))))

       ;;;;;;;;;;;;;;;;;;;
(defun ada_direct_io_reset (ar)
       ;;;;;;;;;;;;;;;;;;;
  
  ;;; Resets the file, and NO mode change.
  ;;; Mode defaults to previous.  Does not actually write anything to disk.
  ;;; You must close file to get a permanent copy.
  
  (with_ada_parameters ((file file))
   (let* ((fileo (ct_nth (file_exist_check file) **direct_file_list**)))
     (ct_if (not (zerop (ht_max_key (ct_send fileo 'write_cache))))
	    (dump_cache (ct_send fileo 'write_cache)))
     (ct_send fileo 'reset)
     (set-iv ada_direct_io_file fileo 'index 1)	 ; Next read or write at index=1.
     (list file ))))


;;; Returns the file's mode.  FUNCTION

       ;;;;;;;;;;;;;;;;;;
(defun ada_direct_io_mode (ar)
       ;;;;;;;;;;;;;;;;;;
  (with_ada_parameters ((file file))
   (let* ((fileo (ct_nth (file_exist_check file) **direct_file_list**))
	  (fmode (get-iv ada_direct_io_file fileo 'mode))
	  (str (cond ((equal fmode 'in) "in_file")
		     ((equal fmode 'out) "out_file")
		     (t "inout_file"))))
  (ct_if (neq (get-iv ada_direct_io_file fileo 'status) 'open)
      (ada_raise '|status_error| "File must be open."))
  (get-enum str *activation*))))



       ;;;;;;;;;;;;;;;;;;
(defun ada_direct_io_name (ar)  
       ;;;;;;;;;;;;;;;;;;

  ;;; Returns the file's name.   FUNCTION.
  (with_ada_parameters ((file file))
   (let ((fileo (ct_nth (file_exist_check file) **direct_file_list**)))
     (ct_if (neq (get-iv ada_direct_io_file fileo 'status) 'open)
	    (ada_raise '|status_error| "File must be open."))
     (cons 'lex_string (list
			 (exploden (get-iv ada_direct_io_file fileo 'name)))))))


       ;;;;;;;;;;;;;;;
(defun ada_direct_io_form (ar)
       ;;;;;;;;;;;;;;;

  ;;; Returns the file's form.   FUNCTION.  (We don't use forms, so the null
  ;;; string is always returned.
  (with_ada_parameters ((file file))
   (let ((fileo (ct_nth (file_exist_check file) **direct_file_list**)))
     (ct_if (neq (get-iv ada_direct_io_file fileo 'status) 'open)
	 (ada_raise '|status_error| "File must be open."))
  (cons 'lex_string (list nil)))))


       ;;;;;;;;;;;;;;;;;;
(defun ada_direct_io_is_open (ar)
       ;;;;;;;;;;;;;;;;;;

  ;;; Returns T if file is open; nil if not.
  (with_ada_parameters ((file file))
   (let ((fileo (ct_nth (file_exist_check file) **direct_file_list**)))
     (ct_if (eq (get-iv ada_direct_io_file fileo 'status) 'open)
	    (get-enum "true" *activation*)
	    (get-enum "false" *activation*)))))


       ;;;;;;;;;;;;;;;;
(defun ada_direct_io_write (ar)
       ;;;;;;;;;;;;;;;;
  ;;; write a item into the write cache following current index
  ;;; increment the index after writing.
  
  (with_ada_parameters ((file file) (item item))
   (let* ((fileo (ct_nth (file_exist_check file) **direct_file_list**))
	  (to (get-iv ada_direct_io_file fileo 'index))
	  (itemo (ada_parameter item))
	  (base 10.) (ibase 10.)
	  (prinlength nil)
	  (prinlevel nil))
     (ct_if (eq (get-iv ada_direct_io_file fileo 'mode) 'in)
	    (ada_raise '|mode_error| "File must be open for output."))
     (ct_if (eq (get-iv ada_direct_io_file fileo 'status) 'closed)
	    (ada_raise '|status_error| "File must be open to write."))
     (ct_puthash to
		 (get_direct_io_value item itemo)
		 (ct_send fileo 'write_cache))
     (set-iv ada_direct_io_file fileo 'index (add1 to))
     (list item file to))))

       ;;;;;;;;;;;;;;;;
(defun ada_direct_io_write_to (ar)
       ;;;;;;;;;;;;;;;;
  ;;; Sets Nth element of a file.  The index is specified
  ;;; as given input. Increment the index after
  ;;; writing.

  (with_ada_parameters ((file file) (item item) (to to))
   (let ((fileo (ct_nth (file_exist_check file) **direct_file_list**))
	 (itemo (ada_parameter item))
	 (base 10.) (ibase 10.)
	 (prinlength nil)
	 (prinlevel nil))
     (ct_if (equal to '*unassigned*)
	    (ada_raise '|program_error|
		       "unitialized TO parameter"))
     (ct_if (eq (get-iv ada_direct_io_file fileo 'mode) 'in)
	    (ada_raise '|mode_error| "File must be open for output."))
     (ct_if (eq (get-iv ada_direct_io_file fileo 'status) 'closed)
	    (ada_raise '|status_error| "File must be open to write."))
     (ct_puthash to
		 (get_direct_io_value item itemo)
		 (ct_send fileo 'write_cache))
     (set-iv ada_direct_io_file fileo 'index (add1 to))
     (list item file to))))

(defun get_direct_io_value (item itemo)
  (cond ((numberp item) item)
	((is_char item)  (ct_send itemo 'printvalue))
	((is_array item) (ct_send item 'printvalue))
	((is_enumeration item) (ct_send itemo 'printvalue))
	((ada_record_type itemo)
	  (mapcar '(lambda (x) (ct_send (cdr x) 'printvalue))
		      (ada_record_value%record item)))
	(t (print "Unknown Item"))))



(defun ada_direct_io_read (ar)
       ;;;;;;;;;;;;;;;
;;;  Retrieves the Next element from the file, checking first to see if
;;; is in the write_cache.  Increment the index after reading.

  (with_ada_parameters ((file file)(item item))
   (let* ((fileo (ct_nth (file_exist_check file) **direct_file_list**))
 	  (from (get-iv ada_direct_io_file fileo 'index))
	  (direct_value (ct_gethash from (ct_send fileo 'write_cache)))
	  (itemo (ada_parameter item))
	  (base 10.) (ibase 10.)
	  (prinlength nil)
	  (prinlevel nil))
     
     (ct_if (eq (get-iv ada_direct_io_file fileo 'mode) 'out)
	    (ada_raise '|mode_error| "File must be open for input."))
     (ct_if (eq (get-iv ada_direct_io_file fileo 'status) 'closed)
	    (ada_raise '|status_error| "File must be open."))
     (ct_if (not direct_value)
	    (setq direct_value (ct_send fileo 'find_element from))
	    (setq direct_value (cdr direct_value)))
     (cond ((ada_num_p itemo)
	    (setq item direct_value))
	   ((ada_array_type itemo)
	    (direct_read_array direct_value item))
	   ((ada_enumeration_type itemo)
	    (setq item (get_enum_literal direct_value itemo)))
	   ((ada_record_type itemo)
	    (direct_read_record direct_value item))
	   (t (print "Unknown Item")))
     (set-iv ada_direct_io_file fileo 'index (add1 from))
     (list item fileo from))))

       ;;;;;;;;;;;;;;;
(defun ada_direct_io_read_from (ar)
       ;;;;;;;;;;;;;;;
;;;  Retrieves the Nth element from the file, checking first to see if
;;; is in the write_cache.  Increment the index after reading.

  (with_ada_parameters ((file file)(item item)(from from))
   (let* ((fileo (ct_nth (file_exist_check file) **direct_file_list**))
	  (itemo (ada_parameter item))
	  (direct_value (ct_gethash from (ct_send fileo 'write_cache)))
	  (base 10.) (ibase 10.)
	  (prinlength nil)
	  (prinlevel nil))
     (ct_if (equal from '*unassigned*)
	    (ada_raise '|program_error|
		       "unitialized FROM parameter"))
     (ct_if (eq (get-iv ada_direct_io_file fileo 'mode) 'out)
	    (ada_raise '|mode_error| "File must be open for input."))
     (ct_if (eq (get-iv ada_direct_io_file fileo 'status) 'closed)
	    (ada_raise '|status_error| "File must be open."))
     (ct_if (not direct_value)
	    (setq direct_value (ct_send fileo 'find_element from))
	    (setq direct_value (cdr direct_value)))
     (cond ((ada_num_p itemo)
	    (setq item direct_value))
	   ((ada_array_type itemo)
	    (direct_read_array direct_value item))
	   ((ada_enumeration_type itemo)
	    (setq item (get_enum_literal direct_value itemo)))
	   ((ada_record_type itemo)
	    (direct_read_record direct_value item))
	   (t (print "Unknown Item")))
     (set-iv ada_direct_io_file fileo 'index (add1 from))
     (list item fileo from))))


(defun direct_read_array (value  item)
  (let* ((list-of-values value)
	 (arraystorage (get-iv dt_array_type item 'array_storage))
	 (eleobj  #+lispm (aref arraystorage 0)
		  #+franz (arraycall t arraystorage 0)))
    (fill-in-value-for-array
      list-of-values
      item )))

(defun direct_read_record (direct_value item)
  (let* ((recvalue (ada_record_value%record item))
	 (num_of_fields (length recvalue))
	 (nuval direct_value))
    (uci_loop (initial count num_of_fields
		       reclist recvalue
		       nuvalue nuval
		       itemo (cdr (first reclist)))
	      (do (cond ((ada_num_p itemo)
			 (ct_send itemo 'set_val nil (car nuvalue)))
			((ada_enumeration_type itemo)
			 (ct_send itemo 'set_val
				  nil
				  (get_enum_literal
				     (car nuvalue)
				     itemo)))
			((is_array itemo)
			 (fill-in-value-for-array (car nuvalue) itemo))
			((ada_record_type itemo)
			 (fill-in-value-for-record (car nuvalue) itemo))))
	      (until (eq count 0))
	      (next count (sub1 count)
		    reclist (cdr reclist)
		    nuvalue (cdr nuvalue)
		    itemo (cdr (first reclist)))
    )))

       ;;;;;;;;;;;;;
(defun ada_direct_io_set_index (ar)
       ;;;;;;;;;;;;;
  ;;; Sets the index for a given file.  An index can be set to any integer
  ;;; you wish; no checking is done for validity until read happens.  (You 
  ;;; can write wherever you please!)

  (with_ada_parameters ((file file) (to to))
   (let ((fileo (ct_nth (file_exist_check file) **direct_file_list**)))
     (ct_if (equal to '*unassigned*)
	    (ada_raise '|program_error|
		       "unitialized TO parameter"))
     (ct_if (eq (get-iv ada_direct_io_file fileo 'status) 'closed)
	    (ada_raise '|status_error| "File must be open to set index."))
     (set-iv ada_direct_io_file fileo 'index to)
     (list file to))))


       ;;;;;;;;;
(defun ada_direct_io_index (ar)
       ;;;;;;;;;

  ;;; Returns the current index.  This is an Ada function.
  (with_ada_parameters ((file file))
   (let ((fileo (ct_nth (file_exist_check file) **direct_file_list**)))
     (ct_if (eq (get-iv ada_direct_io_file fileo 'status) 'closed)
	    (ada_raise '|status_error| "File must be open."))
     (get-iv ada_direct_io_file fileo 'index))))


       ;;;;;;;;
(defun ada_direct_io_size (ar)
       ;;;;;;;;

  ;;; Returns the number of records (elements) in the file.  This is an
  ;;; Ada FUNCTION.  The file size can be changed by writing, but not by
  ;;; reading.  The number returned includes elements in the write cache.

  (with_ada_parameters ((file file))
   (let ((fileo (ct_nth (file_exist_check file) **direct_file_list**)))
    (max (get-iv ada_direct_io_file fileo 'file_size)
	 (ht_max_key (ct_send fileo 'write_cache))))))


       ;;;;;;;;;;;;;;;
(defun ada_direct_io_end_of_file (ar)
       ;;;;;;;;;;;;;;;

  ;;; Returns T or NIL (which should translate to an Ada boolean).
  ;;; T indicates the index is greater than the size of the file.

  (with_ada_parameters ((file file))
   (let ((fileo (ct_nth (file_exist_check file) **direct_file_list**))
	 (base 10.)
	 (ibase 10.))
    (ct_if (eq (get-iv ada_direct_io_file fileo 'mode) 'out)
	(ada_raise '|mode_error| "Direct out files never reach EOF.")
	(let ((val (> (get-iv ada_direct_io_file fileo 'index)
		      (max (get-iv ada_direct_io_file fileo 'file_size)
			   (ht_max_key (ct_send fileo 'write_cache))))))
	  (ct_if val (get-enum "true" *activation*)
		 (get-enum "false" *activation*)))))))


(ct_defmethod (ada_direct_io_file delete) ()
    (ct_if (neq status 'open)
	    (ada_raise '|status_error| "Cannot delete a file already closed."))
    (setq status 'closed)
    (ct_deletef real_stream))

(ct_defmethod (ada_direct_io_file close) ()
    (ct_if (neq status 'open)
	    (ada_raise '|status_error| "Cannot close a file already closed."))
    (setq status 'closed)
    (ct_closef real_stream))

(defun dir_get_status (fileo)
  (get-iv ada_direct_io_file fileo 'status))

(defun delete_dirio_temp_file ()
  (progn (ct_if *dirio_temp_file_list*
		(aip_for (x in *dirio_temp_file_list*)
			 (when (eq (dir_get_status x) 'open))
			 (do (ct_send x 'delete))))
	 (ct_if **direct_file_list**
		(aip_for (x in **direct_file_list**)
			 (when (eq (dir_get_status x) 'open))
		   (do (ct_send x 'close))))
	 ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;				  eof				     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;