;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                              TEXTIOL                             ;;;
;;;								     ;;;
;;; ALEX C. MENG                                     Sept-11-83      ;;;
;;;                                                                  ;;;
;;;                                                                  ;;;
;;; 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                 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Hacked 15 August 1985 Richard Mark Soley for Lambda port

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(eval-when (compile load eval) (ct_load 'charmac)) ;CT char set extensions.

(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 'stdenv)) ;Franz/LM stdenv pkg.

(eval-when (compile load eval) (ct_load 'textio));Text_io functions

(eval-when (compile load eval) (ct_load 'diana));diana macs functions
    
(eval-when (compile load eval) (ct_load 'bifmacs))    ; get def for
                                                      ; with_ada_par 
(eval-when (compile load eval) (ct_load 'operators)) ; referencing
                                                      ; assigned_stringp
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))
(declare (ct_includef 'intrpdcl))			; get the specials

(declare (special *default_input_file_type*
		  *default_output_file_type*
		  ))

(declare (*fexpr is_standard_procedure is_standard_function))

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


;;;
;;; search the file list to see if the te given file name identity a file 
;;; already in processing
(defun find_ada_file (fname file_list)
  (do ((ll file_list (cdr ll))
       (f nil))
      ((or f (null ll)) f)
    (cond ((ct_string_equal fname
			    (ct_send (car ll) 'name))
	   (setq f (car ll)))
	  )
    ))

;;;
;;; close all the open files whenever the backend start
;;;
(defun close_ada_files (file_list)
  (cond ((and file_list (car file_list))
	 (aip_for (x in file_list)
	   (do (cond ((equal (ct_send x 'status) 'open)
		      (ct_send x 'close))
		     )
	       )
	   ))
	 ))

;;;
;;; initialize the IO variabales -- callable at back end and flush
;;; the input buffer of the debugger window
;;;
(defun ada_io_init ()
  (close_ada_files **text_file_list**)
  (close_ada_files **sequen_file_list**)
  (close_ada_files **direct_file_list**)
  ;;(delete_textio_temp_file)
  ;;(delete_seqio_temp_file)
  ;;(delete_dirio_temp_file)
  (setq **text_file_list** (list nil nil)
	**text_file_num** 3
	**standard_input** 1
	**default_input** 1
	**standard_output** 2
	**default_output** 2
	**sequen_file_list** nil
	**sequen_file_num** 1
	**direct_file_list** nil
	**direct_file_num** 1
	*textio_temp_file_list* nil
	*seqio_temp_file_list* nil
	*dirio_temp_file_list* nil
	*default_input_file_type* nil
	*default_output_file_type* nil
	)
  (ct_if *userin*
	 (ct_send *userin* ':clear-input))
  )

;;;
;;; given the dt_enum_type return a list of enumeration literals (atom)
;;;
(defun list-of-values (item)
  (let ((as-list (diana_get (extract_basetype
			      (ct_send  item  'sm_defn))
			    'as_list)))
    (mapcar '(lambda (x) (implode
			   (left-blank-out
			     (second (diana_get x 'lx_symrep)))))
	      as-list)))
;;;
;;; given the bared symbol(lower case) and a dn_enum_type node 
;;; return the dt_enum_type node which the string is the enumeration literal
;;;
(defun search-enum (str itemo)
  (let ((as-list (diana_get (extract_basetype
			      (ct_send  itemo 'sm_defn))
			    'as_list)))
    (do ((ls as-list (cdr ls)) (stop nil) (ans nil))
	((or (null ls) stop) ans)
          (cond ((equal str (implode
			      (left-blank-out
				(second (diana_get (car ls) 'lx_symrep)))))
		 (setq ans (car ls) stop t))))))

(defun search-enum-charl (charl itemo)
  (let ((as-list (diana_get (extract_basetype
			      (ct_send  itemo 'sm_defn))
			    'as_list)))
    (do ((ls as-list (cdr ls)) (stop nil) (ans nil))
	((or (null ls) stop) ans)
          (cond ((equal charl (left-blank-out
				(second (diana_get (car ls) 'lx_symrep))))
		 (setq ans (car ls) stop t))))))
;;;
;;;Given the dn_enum_node and return it's coresponding enumeration literal(atom)
;;;
(defun get-literal (item)
  (implode (left-blank-out (second (diana_get item 'lx_symrep)))))


;;;
;;; Given the string and the activation record
;;; Return the dt_enum_type node which the string is it's enumeration literal in
;;;        string form
(defun get-enum (str ar)
  (prog ((aslist (diana_get
		  (extract_basetype
		    (diana_get
		      (diana_get
			(ct_send ar 'node)
			'sm_spec)
		      'as_name_void))
		  'as_list)))
    (return (mapcan '(lambda (x)
	       (cond ((equal str (#+lispm string #+franz get_pname
				  (implode (second
					     (diana_get x 'lx_symrep)))))
		      (return x))
		     (t nil)))
	      aslist))
    ))

;;;
;;; Given the char list and the activation record. Return the dn_enum_type
;;;  node which the char list is it's enumeration literal 
(defun get-enum-charl (charl ar)
  (let ((aslist (diana_get
		  (extract_basetype
		    (diana_get
		      (diana_get
			(ct_send ar 'node)
			'sm_spec)
		      'as_name_void))
		  'as_list)))
    (mapcan '(lambda (x)
	       (cond ((equal charl (second (diana_get x 'lx_symrep))) x)
		     (t nil)))
	      aslist)))


;;;
;;; replace_nth -- used with small list only
;;;
(defun replace_nth (n nuval l)
  (cond ((null l) nil)
	(t (do ((sl l (cdr sl))
		(fl nil )
		(count 1 (add1 count)))
	       ((equal count n) (nconc (nreverse fl)
				    (nconc (list nuval)
					   (cdr sl))))
	       (setq fl (cons (car sl) fl))))))

;;;
;;; used with n > 1 -- destructly
;;;
(defun replace_nth2 (n nuval l)
  (do ((fl l (cdr fl))
       (pl l fl)
       (count 1 (add1 count)))
      ((equal count n) (let ((x (list nuval)))
			 (rplacd pl x)
			 (rplacd x (cdr fl))
			 l))
    ))

;;;
;;; left-pad-off
;;;
(defun left-pad-off (sym)
  (implode (left-blank-out (exploden sym))))

(defun left-blank-out (elist)
  (cond ((not (equal #/  (car elist))) elist)
	(t (do ((l elist (cdr l)))
	       ((not (eq #/  (car l))) l)))))

;;;
;;; delete_textio_temp_file -- A function to delete the temporary files
;;;                            for the textio  created by CREATE
;;;                            procedure call with file NAME input take default,
;;;                            i.e. null string.

(defun delete_textio_temp_file()
  (progn (ct_if *textio_temp_file_list*
		(aip_for (x in *textio_temp_file_list*)
			 (do (ct_send x 'file-delete))))
	 (aip_for (x in **text_file_list**)
		  (when (and (instancep x)
			     (eq (get_status x) 'open)))
		  (do (ct_send x 'close)))))
;;;
;;; int_value -- given the <dt_array_type> a string of numeric literal
;;;              return the right integer.

(defun int_value (arrobj)
  (str_fsm *integer_table* (ct_send arrobj 'printvalue)))

;;;
;;; enum_value -- given the <dt_array_type> a string of chars  and the list
;;;               of enum literals, return the right diana node for the 
;;;               enum literal

(defun enum_value (arrobj enumlist)
  (let ((str (implode (ct_send arrobj 'printvalue))))
    (mapcan '(lambda (x)
	       (cond ((equal str (#+lispm string #+franz get_pname
				  (implode (second
					     (diana_get x 'lx_symrep))))) x)
		     (t nil)))
	    enumlist)))

;;;
;;; resolve a string into a list of chars and put into a array object
;;;
(defun fill_str_into_array (arrayobj str)
  (let* ((arrayname (get-iv dt_array_type arrayobj 'array_storage))
	 (arraydim #+lispm (sub1 (array-length arrayname))
		   #+franz (sub1 (getlength arrayname)))
	 (index_list (car (ct_send arrayobj 'index_list)))
	 (start_index (sub1 (first index_list)))
	 (end_index (sub1 (second index_list)))
	 )
    (do ((index start_index (add1 index))
	 (intlist (exploden str) (cdr intlist)))
        ((or (greaterp index end_index)
	     (null intlist))
	 arrayobj)
      (ct_send #+lispm (aref arrayname index)
	       #+franz (arraycall t arrayname index)
	       'set_val  nil (convert_integer_to_char (car intlist))))))
;;;
;;; fill a char list into a array
;;;
(defun fill_chlist_into_array (arrayobj chlist)
  (let* ((arrayname (ct_send arrayobj 'array_storage))
	 (arraydim #+lispm (sub1 (array-length arrayname))
		   #+franz (sub1 (getlength arrayname))))
    (do ((index 0 (add1 index))
	 (intlist chlist (cdr intlist)))
        ((Greaterp index arraydim) arrayobj)
      (ct_send #+lispm (aref arrayname index)
	       #+franz (arraycall t arrayname index)
	       'set_val  nil (convert_integer_to_char (car intlist))))))

;;; check for unbound file parameter
(defun file_exist_check (filerec)
  (let* ((fields (ada_record_value%record filerec))
         (filepos (ct_send (cdr (first fields)) 'current_value)))
    (ct_if (eq filepos 0)
	   (ada_raise '|status_error| "Referencing an non-existing file")
	   filepos)
    ))


; get the filepos
(defun get_filepos (filerec)
  (let* ((fields (ada_record_value%record filerec))
         (filepos (ct_send (cdr (first fields)) 'current_value)))
    filepos
    ))

(DEFUN ct-FLONUM-TO-STRING (X &optional SMALL MAX-DIGITS FRACTION-DIGITS)
  (DECLARE (RETURN-LIST BUFER INTEGER-DIGITS))
  SMALL						;Not be used on 3600
  (LET ((EXPONENT (si:FLONUM-EXPONENT X #-LMI SMALL))
	(MANTISSA (si:FLONUM-MANTISSA X #-LMI SMALL))
	(BAS 10.)
	K M R Q U S DECIMAL-PLACE
	;; BUFER is needed when MAX-DIGITS is supplied because the rounding
	;; can generate a carry that has to propagate back through the digits.
	(BUFER (MAKE-ARRAY 100 ':TYPE 'ART-STRING ':LEADER-LIST '(0))))
    (OR MAX-DIGITS (SETQ MAX-DIGITS 1000.))	;Cause no effect.
    ;; Get integer part
    (SETQ R (ASH MANTISSA EXPONENT))
    (SETQ Q R)
    (SETQ M (ASH 1 (1- EXPONENT)))	;Actually 0 in most normal cases.
    ;; Instead of using a pdl, precompute S and K.
    ;; S gets the highest power of BAS <= R, and K is its logarithm.
    (SETQ S 1 K 0 U BAS)
    (DO () ((> U R))
      (SETQ S U U (* U BAS) K (1+ K)))
    (DO () (NIL)
      (SETQ U (// R S) R (\ R S))
      (COND ((OR (< R M) (> R (- S M)))
	     (ARRAY-PUSH BUFER (+ #/0 (IF (<= (* 2 R) S)
					  U
					  (1+ U))))
	     (DECF MAX-DIGITS)
	     ;; This is the LEFTFILL routine in the paper.
	     (DO I 1 (1+ I) (>= I K)
	       (ARRAY-PUSH BUFER #/0)
	       (DECF MAX-DIGITS))
	     (RETURN NIL)))
      (ARRAY-PUSH BUFER (+ #/0 U))
      (DECF MAX-DIGITS)
      (DECF K)
      (IF (MINUSP K) (RETURN NIL))
      (SETQ S (// S 10.)))
    (SETQ DECIMAL-PLACE (ARRAY-ACTIVE-LENGTH BUFER))
    (ARRAY-PUSH BUFER (si:PTTBL-DECIMAL-POINT READTABLE))
    (IF FRACTION-DIGITS (SETQ MAX-DIGITS FRACTION-DIGITS))
    (IF (MINUSP EXPONENT)
	;; There is a fraction part.
	(let ((Z (- EXPONENT)))
	  ;; R/S is the fraction, M/S is the error tolerance
          ;; The multiplication by 2 causes initial M to be 1/2 LSB
	  (SETQ R (* #-3600 (IF (<= Z 23.) (LDB Z MANTISSA) ;If fraction bits fit in a fixnum
				(LOGAND MANTISSA (1- (ASH 1 Z))))
		     #+3600 (LOGAND MANTISSA (1- (ASH 1 Z)))
                     2)
		S (ASH 2 Z)
		M 1)
	  (DO () (NIL)
	    (SETQ R (* R BAS))
	    (SETQ U (// R S) R (\ R S) M (* M BAS))
	    (AND (OR (< R M) (> R (- S M)) (< MAX-DIGITS 2))
		 (RETURN NIL))
	    (ARRAY-PUSH BUFER (+ U #/0))
	    (DECF MAX-DIGITS))
	  (ARRAY-PUSH BUFER (SETQ Z (+ (IF (<= (* 2 R) S) U (1+ U)) #/0)))
	  (COND ((> Z #/9)		;Oops, propagate carry backward (MAX-DIGITS case)
		 (DO I (- (ARRAY-LEADER BUFER 0) 2) (1- I) (MINUSP I)
		   (ASET #/0 BUFER (1+ I))
		  SKIP-DECIMAL
		   (SETQ Z (AREF BUFER I))
		   (COND ((= Z (si:PTTBL-DECIMAL-POINT READTABLE))
			  (SETQ I (1- I))
			  (GO SKIP-DECIMAL))
			 (( Z #/9)
			  (ASET (1+ Z) BUFER I)
			  (RETURN NIL))
			 ((ZEROP I)
			  ;;Double oops, the carry has added a new digit
			  (LET ((LEN (- (ARRAY-LEADER BUFER 0) 2)))
			    (AND (= (AREF BUFER LEN) (si:PTTBL-DECIMAL-POINT READTABLE))
				 ;;Must have some fraction part
				 (ARRAY-PUSH BUFER #/0))
			    (DO I LEN (1- I) ( I 0)
				(ASET (AREF BUFER I) BUFER (1+ I)))
			    (INCF DECIMAL-PLACE))
			  (ASET #/0 BUFER 1)
			  (ASET #/1 BUFER 0)
			  (RETURN NIL))))
		 ;Now truncate trailing zeros, except for one after the decimal point
		 (LOOP FOR I FROM (1- (ARRAY-ACTIVE-LENGTH BUFER))
			     DOWNTO (+ DECIMAL-PLACE 2)
		       WHILE (= (AREF BUFER I) #/0)
		       DO (STORE-ARRAY-LEADER I BUFER 0)))))
	;; There is no fraction part at all.
	(ARRAY-PUSH BUFER #/0))
    ;; Now add trailing zeros if requested
    (IF FRACTION-DIGITS
	(LOOP REPEAT (- (+ DECIMAL-PLACE FRACTION-DIGITS 1) (ARRAY-ACTIVE-LENGTH BUFER))
	      DO (ARRAY-PUSH BUFER #/0)))
    (VALUES BUFER DECIMAL-PLACE)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internally Call-able Functions/Macros -- 

;;;
;;; Comment on the file management implementation
;;;
;;; The FILE_TYPE for the TEXT_IO is A RECORD which HAS A FIELD: FILE_POS  to be 
;;; used as the INDEX to a list of file objects. 
;;; The list is **text_file_list**.
;;;
;;; There are two special index : **standard_input** and
;;;  **standard_output** to be used to reference the the standard input
;;;  and output file, while **default_input** and **default_output** to be used
;;;  to reference the default input or output files.

;;; A list of temporary text io files, deleted at the end of the execution


(defun initialize_text_io ()
  (with_package text_io  
;;;
;;; File management
;;;
 (is_standard_procedure create ada_create_file_f ( (in_out file file_type)
         				           (in mode file_mode)
   					           (in name string)
						   (in form string )))

 (is_standard_procedure open ada_open_file_f  ((in_out file file_type)
     				              (in mode file_mode)
					      (in name string )
					      (in form string )))
 
 (is_standard_procedure close ada_close_file_f ((in_out file file_type)))

 (is_standard_procedure delete ada_delete_file_f ((in_out file  file_type)))

 (is_standard_procedure reset ada_reset_file_f ((in_out file file_type)
						(in mode file_mode)))
 
 (is_standard_procedure reset ada_reset_file_d ((in_out file  file_type)))

 (is_standard_function mode ada_file_mode_f ((in file  file_type)) file_mode)

 (is_standard_function name ada_file_name_f ((in file  file_type)) string)

 (is_standard_function form ada_file_form_f ((in file  file_type)) string)

 (is_standard_function is_open ada_file_is_open_f ((in file  file_type))  boolean)

 (is_standard_procedure set_input ada_set_default_input_f ((in file  file_type)))

 (is_standard_procedure set_output ada_set_default_output_f ((in file file_type )))

 ;;(is_standard_function standard_input ada_standard_input_f ()  file_type)

 ;;(is_standard_function standard_output ada_standard_output_f ()  file_type)

 (is_standard_function current_input ada_current_input_f ()  file_type)

 (is_standard_function current_output ada_current_output_f ()  file_type)

;;
;; Io for integer type
;;
 (with_package integer_io
   (is_standard_procedure get ada_get_integer_d ((out item num)
					        (in width field)))

  (is_standard_procedure get ada_get_integer_f ((in file file_type)
						(out item num)
						(in width field)))
  
  (is_standard_procedure put ada_put_integer_d ((in item num)
						(in width field)
         					(in base number_base)))

  (is_standard_procedure put ada_put_integer_f ((in file file_type)
						(in item num)
						(in width field)
						(in base number_base)))

  (is_standard_procedure get ada_get_integer_from_string_d ((in from string)
							    (out item num)
							    (out last positive )))

  (is_standard_procedure put ada_put_integer_to_string_d ((out to string)
							   (in item num)
 							   (in base number_base)))
  )

;;
;; specification of Line and Page Length
;;
  (is_standard_procedure set_line_length ada_set_line_length_d ((in to count)))

  (is_standard_procedure set_line_length ada_set_line_length_f ((in file file_type)
								(in to count)))
  
  (is_standard_procedure set_page_length ada_set_page_length_d ((in to count)))

  (is_standard_procedure set_page_length ada_set_page_length_f ((in file file_type)
								(in to count)))
  
  (is_standard_function line_length ada_line_length_d ()count)

  (is_standard_function line_length ada_line_length_f ((in file file_type))count)

  (is_standard_function page_length ada_page_length_d ()count)
  
  (is_standard_function page_length ada_page_length_f ((in file file_type))count)

  
;;
;; operation on columns, line, and pages
;;
  (is_standard_procedure new_line ada_new_line_d ((in spacing positive_count)))

  (is_standard_procedure new_line ada_new_line_f ((in file file_type)
						   (in spacing positive_count)))
  
  (is_standard_procedure skip_line ada_skip_line_d ((in spacing positive_count)))

  (is_standard_procedure skip_line ada_skip_line_f ((in file file_type)
						     (in spacing positive_count)))
  
  (is_standard_function end_of_line ada_end_of_line_d ()boolean)

  (is_standard_function end_of_line ada_end_of_line_f ((in file file_type))boolean)
  
  (is_standard_procedure new_page ada_new_page_d nil )

  (is_standard_procedure new_page ada_new_page_f ((in file file_type)))
  
  (is_standard_procedure skip_page ada_skip_page_d nil )

  (is_standard_procedure skip_page ada_skip_page_f ((in file file_type)))
  
  (is_standard_function end_of_page ada_end_of_page_d ()boolean)

  (is_standard_function end_of_page ada_end_of_page_f ((in file file_type))boolean)
  
  (is_standard_function end_of_file ada_end_of_file_d ()boolean)

  (is_standard_function end_of_file ada_end_of_file_f ((in file file_type))boolean)

  (is_standard_procedure set_col ada_set_col_d ((in to positive_count)))
  
  (is_standard_procedure set_col ada_set_col_f ((in file file_type)
						(in to positive_count)))
  
  (is_standard_procedure set_line ada_set_line_d ((in to positive_count)))

  (is_standard_procedure set_line ada_set_line_f ((in file file_type)
						  (in to positive_count)))
  
  (is_standard_function col ada_col_d ()positive_count)

  (is_standard_function col ada_col_f ((in file file_type))positive_count)
  
  (is_standard_function line ada_line_d ()positive_count)

  (is_standard_function line ada_line_f ((in file file_type))positive_count)
  
  (is_standard_function page ada_page_d ()positive_count)

  (is_standard_function page ada_page_f ((in file file_type))positive_count)



;;
;; IO for characters and strings
;;

  (is_standard_procedure get ada_get_character_d ((out item character)))

  (is_standard_procedure get ada_get_character_f ((in file file_type)
						   (out item character)))
 
  (is_standard_procedure put ada_put_character_d ((in item character)))

  (is_standard_procedure put ada_put_character_f ((in file  file_type)
						   (in item character))) 
  
  (is_standard_procedure get ada_get_string_d ((out item string)))

  (is_standard_procedure get ada_get_string_f ((in file file_type)
						(out item string)))

  (is_standard_procedure put ada_put_string_d ((in item string)))

  (is_standard_procedure put ada_put_string_f ((in file file_type)
						(in item string)))

  (is_standard_procedure get_line ada_get_line_d ((out item string)
						  (out last natural)))
  
  (is_standard_procedure get_line ada_get_line_f ((in file file_type)
						   (out item string)
						   (out last natural)))

  (is_standard_procedure put_line ada_put_line_d ((in item string)))

  (is_standard_procedure put_line ada_put_line_f ((in file file_type)
						   (in item string)))

;;;
;;; IO for Real type (Float)
;;;
  (with_package float_io
		
   (is_standard_procedure get ada_get_real_d ((out item numf)
							   (in width field)))

   (is_standard_procedure get ada_get_real_f ((in file file_type)
					      (out item numf)
					      (in width field)))

   (is_standard_procedure put ada_put_real_d ((in item numf)
					      (in fore field)
					      (in aft field)
					      (in exp field)))

   (is_standard_procedure put ada_put_real_f ((in file file_type)
					      (in item numf)
					      (in fore field)
					      (in aft field)
					      (in exp field)))

   (is_standard_procedure get ada_get_real_from_string_d ((in from string)
							  (out item numf)
							  (out last positive )))

   (is_standard_procedure put ada_put_real_to_string_d ((out to string) 								(in item numf)
							(in aft field)
							(in exp field)))
  )

;;;
;;; IO for Real type (Fixed_point)
;;;
  (with_package fixed_io

  (is_standard_procedure get ada_get_fixed_real_d ((out item numfi)
					      (in width field)))

  (is_standard_procedure get ada_get_fixed_real_f ((in file file_type)
					      (out item numfi)
					      (in width field)))

  (is_standard_procedure put ada_put_fixed_real_d ((in item numfi)
					      (in fore field)
					      (in aft field)
					      (in exp field)))

  (is_standard_procedure put ada_put_fixed_real_f ((in file file_type)
					      (in item numfi)
					      (in fore field)
					      (in aft field)
					      (in exp field)))

  (is_standard_procedure get ada_get_fixed_real_from_string_d ((in from string)
							  (out item numfi)
							  (out last positive )))

  (is_standard_procedure put ada_put_fixed_real_to_string_d ((out to string)
						       (in item numfi)
							(in aft field)
							(in exp field)))
  )
;;;
;;; IO for enumeration type
;;;

  (with_package enumeration_io
		
   (is_standard_procedure get ada_get_enum_d ((out item enum)))

   (is_standard_procedure get ada_get_enum_f ((in file file_type)
					      (out item enum)))

    (is_standard_procedure put ada_put_enum_d ((in item enum)
					      (in width field)
					      (in set type_set)))

    (is_standard_procedure put ada_put_enum_f ((in file file_type)
					      (in item enum)
					      (in width field)
					      (in set type_set)))

    (is_standard_procedure get ada_get_enum_from_string_d ((in from string)
							  (out item enum) 
							  (out last positive)))

    (is_standard_procedure put ada_put_enum_to_string_d ((out to string)
						       (in item enum)
						       (in set type_set)))
 )
  ))
;;;
;;; Io for files
;;;
(defun ada_create_file_f (ar)
  (with_ada_parameters ((file file) (mode mode) (name name) (form form)) 
   (let* ((fmode (#+lispm string #+franz get_pname
		  (implode (second (diana_get mode 'lx_symrep)))))
	  (fmode (cond ((equal "in_file" fmode) 'input)
		       ((equal "out_file" fmode) 'output)))
	  (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)))
	  (newfile (first (ada_create_file ffile fmode fname fform))))
     (setq **text_file_list** (nconc **text_file_list** (list newfile))
			       file (list **text_file_num**)
			       **text_file_num** (add1 **text_file_num**)))))

				     

(defun ada_open_file_f (ar)
  (with_ada_parameters ((file file) (mode mode) (name name) (form form))
   (let* ((fmode (#+lispm string #+franz get_pname
		  (implode (second (diana_get mode 'lx_symrep)))))
	   (fmode (cond ((equal "in_file" fmode) 'input)
			((equal "out_file" fmode) 'output)))
	   (fname (string-downcase (#+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 (cond ((eq (get_filepos file) 0)
			 (ct_if (not (ct_probef fname))
			  (ada_raise '|name_error|
				     "Non-existing file cannot be open")
			  (find_ada_file fname
					 **text_file_list**)))
			(t (ct_nth (file_exist_check file) **text_file_list**))))
	   (newfile (first (ada_open_file ffile fmode fname fform))))
     (setq **text_file_list** (nconc **text_file_list** (list newfile))
	   file (list **text_file_num**)
	   **text_file_num** (add1 **text_file_num**)))))




(defun ada_close_file_f (ar)
    (with_ada_parameters ((file file))
     (let ((fileo (ct_nth (file_exist_check file) **text_file_list**)))
       (ct_if (eq (ct_typep fileo) 'ada_output_stream)
	      (ct_send fileo 'flush_line_buf))
	(ada_close_file fileo))))

(defun ada_delete_file_f (ar)
    (with_ada_parameters ((file file))
     (ada_delete_file  (ct_nth (file_exist_check file) **text_file_list**))))

(defun ada_reset_file_f (ar)
    (with_ada_parameters ((file file) (mode mode))
     (let ((fileo (ct_nth (file_exist_check file) **text_file_list**)))
       (ct_if (eq (ct_typep fileo) 'ada_output_stream)
	      (ct_send fileo 'flush_line_buf))
       (ada_reset_file (get_filepos file)
		       fileo
		       (cond ((eq '|in_file| (get-literal mode))
			      'input)
			     (t 'output))))))

(defun ada_reset_file_d (ar)
    (with_ada_parameters ((file file))
     (let ((fileo (ct_nth (file_exist_check file) **text_file_list**)))
       (ct_if (eq (ct_typep fileo) 'ada_output_stream)
	      (ct_send fileo 'flush_line_buf))
	  (ada_reset_file (get_filepos file) fileo  nil))))
	  

(defun ada_file_mode_f (ar)
    (with_ada_parameters ((file file))
	(let*((str (#+lispm string #+franz get_pname
		    (ada_file_mode (ct_nth (file_exist_check file)
					   **text_file_list**))))
	      (str (cond ((equal "input" str) "in_file")
			 (t "out_file"))))
	  (get-enum str *activation*))))

(defun ada_file_name_f (ar)
    (with_ada_parameters ((file file))
     (cons 'lex_string
	 (list (exploden (ada_file_name (ct_nth (file_exist_check file)
						**text_file_list**)))))))
			     
(defun ada_file_form_f (ar)
    (with_ada_parameters ((file file))
     (cons 'lex_string
	 (list (exploden (ada_file_form (ct_nth (file_exist_check file)
						**text_file_list**)))))))

(defun ada_file_is_open_f (ar)
    (with_ada_parameters ((file file))
     (ct_if (eq (get_filepos file) 0)
	    (get-enum "false" *activation*)
	    (let* ((str (ada_file_is_open (ct_nth (file_exist_check file)
						  **text_file_list**)))
		   (str (cond (str "true")
			      (t "false"))))
	      (get-enum str *activation*)))
     ))

(defun ada_set_default_input_f (ar)
  (with_ada_parameters ((file file))
   (ada_set_default_input (ct_nth (file_exist_check file)
				  **text_file_list**))
   (setq **default_input** (get_filepos file)
	 *default_input_file_type* file)
   ))

(defun ada_set_default_output_f (ar)
  (with_ada_parameters ((file file))
   (ada_set_default_output (ct_nth (file_exist_check file)
				   **text_file_list**))
   (setq **default_output** (GET_FILEPOS file)
	 *default_output_file_type* file)
   ))

(defun ada_current_input_f (ar) *default_input_file_type*)

(defun ada_current_output_f (ar) *default_output_file_type*)

(defun ada_standard_input_f (ar) 1)

(defun ada_standard_output_f (ar) 2)


;;;
;;; operations on columns, lines, and pages.
;;;			  
(defun ada_set_line_length_d (ar)
    (with_ada_parameters ((to to))
     (ct_if (or (equal to '*unassigned*))
	    (ada_raise '|status_error|
		       "the variable TO is unassigned"))
     (ada_set_line_length to
			  (ct_nth **default_output** **text_file_list** ))))

(defun ada_set_line_length_f (ar)
    (with_ada_parameters ((file file) (to to))
     (ct_if (or (equal to '*unassigned*))
	    (ada_raise '|program_error|
		       "the variable TO is unassigned"))
     (ada_set_line_length to
			  (ct_nth (file_exist_check file)
				  **text_file_list** ))))

(defun ada_set_page_length_d (ar)
    (with_ada_parameters ((to to))
     (ct_if (or (equal to '*unassigned*))
	    (ada_raise '|program_error|
		       "the variable TO is unassigned"))
     (ada_set_page_length to
			  (ct_nth **default_output** **text_file_list** ))))

(defun ada_set_page_length_f (ar)
    (with_ada_parameters ((file file) (to to))
     (ct_if (or (equal to '*unassigned*))
	    (ada_raise '|program_error|
		       "the variable TO is unassigned"))
     (ada_set_page_length to
			  (ct_nth (file_exist_check file)
				  **text_file_list** ))))

(defun ada_line_length_d (ar)
    (ada_line_length (ct_nth **default_output** **text_file_list** )))

(defun ada_line_length_f (ar)
  (with_ada_parameters ((file file))
    (ada_line_length (ct_nth (file_exist_check file)
			     **text_file_list** ))))

(defun ada_page_length_d (ar)
    (ada_page_length (ct_nth **default_output** **text_file_list** )))

(defun ada_page_length_f (ar)
    (with_ada_parameters ((file file))
    (ada_page_length (ct_nth (file_exist_check file)
			     **text_file_list** ))))

(defun ada_new_line_d (ar)
    (with_ada_parameters ((spacing spacing))
     (ada_new_line (ct_nth **default_output** **text_file_list** )
		   spacing)))

(defun ada_new_line_f (ar)
    (with_ada_parameters ((file file) (spacing spacing))
     (ada_new_line (ct_nth (file_exist_check file)
			   **text_file_list** )
		   spacing)))

(defun ada_skip_line_d (ar)
    (with_ada_parameters ((spacing spacing))
     (ada_skip_line spacing
		    (ct_nth **default_input** **text_file_list** ))))

(defun ada_skip_line_f (ar)
    (with_ada_parameters ((file file) (spacing spacing))
     (ada_skip_line spacing
		    (ct_nth (file_exist_check file)
			    **text_file_list** ))))

(defun ada_end_of_line_d (ar)
      (get-enum 
           (cond ((ada_end_of_line 
                    (ct_nth **default_input** **text_file_list** )) "true")
		    (t "false"))
	      *activation*))

(defun ada_end_of_line_f (ar)
  (with_ada_parameters ((file file))
    (get-enum (cond ((ada_end_of_line (ct_nth (file_exist_check file)
			     **text_file_list** )) "true")
		    (t "false"))
	      *activation*)))

(defun ada_new_page_d (ar)
    (ada_new_page (ct_nth **default_output** **text_file_list** )))


(defun ada_new_page_f (ar)
  (with_ada_parameters ((file file))
    (ada_new_page (ct_nth (file_exist_check file)
			  **text_file_list** ))))


(defun ada_skip_page_d (ar)
    (ada_skip_page (ct_nth **default_input** **text_file_list** )))

(defun ada_skip_page_f (ar)
  (with_ada_parameters ((file file))
    (ada_skip_page (ct_nth (file_exist_check file)
			   **text_file_list** ))))


(defun ada_end_of_page_d (ar)
    (ada_end_of_page (ct_nth **default_input** **text_file_list** )))


(defun ada_end_of_page_f (ar)
  (with_ada_parameters ((file file))
    (ada_end_of_page (ct_nth (file_exist_check file)
			     **text_file_list** ))))

(defun ada_end_of_file_d (ar)
  (let* ((str (ada_end_of_file (ct_nth **default_input** **text_file_list** )))
	 (str (cond (str "true")
		    (t "false"))))
	  (get-enum str *activation*)))

(defun ada_end_of_file_f (ar)
    (with_ada_parameters ((file file))
	(let* ((str (ada_end_of_file (ct_nth (file_exist_check file)
					     **text_file_list** )))
	       (str (cond (str "true")
		     (t "false"))))
	  (get-enum str *activation*))))


(defun ada_set_col_d (ar)
    (with_ada_parameters ((to to))
     (ct_if (or (equal to '*unassigned*) (eq to 0))
	    (ada_raise '|program_error|
		       "the variable TO is unassigned"))
     (let ((base 10.) (ibase 10.))
       (ada_set_col to (ct_nth **default_output** **text_file_list** )))))

(defun ada_set_col_f (ar)
    (with_ada_parameters ((file file) (to to))
     (ct_if (or (equal to '*unassigned*) (eq to 0))
	    (ada_raise '|program_error|
		       "the variable TO is unassigned"))
     (ada_set_col to (ct_nth (file_exist_check file)
			     **text_file_list** ))))
              

(defun ada_set_line_d (ar)
    (with_ada_parameters ((to to))
     (ct_if (or (equal to '*unassigned*) (eq to 0))
	    (ada_raise '|program_error|
		       "the variable TO is unassigned"))
     (ada_set_line to
		   (ct_nth **default_output** **text_file_list** ))))


(defun ada_set_line_f (ar)
    (with_ada_parameters ((file file) (to to))
     (ct_if (or (equal to '*unassigned*) (eq to 0))
	    (ada_raise '|program_error|
		       "the variable TO is unassigned"))
     (ada_set_line to (ct_nth (file_exist_check file)
			      **text_file_list** ))))

(defun ada_col_d (ar)
    (ada_col (ct_nth **default_output** **text_file_list** )))


(defun ada_col_f (ar)
  (with_ada_parameters ((file file))
    (ada_col (ct_nth (file_exist_check file) **text_file_list** ))))

(defun ada_line_d (ar)
    (ada_line (ct_nth **default_output** **text_file_list** ))) 

(defun ada_line_f (ar)
  (with_ada_parameters ((file file))
    (ada_line (ct_nth (file_exist_check file) **text_file_list** ))))

(defun ada_page_d (ar)
    (ada_page (ct_nth **default_output** **text_file_list** ))) 

(defun ada_page_f (ar)
  (with_ada_parameters ((file file))
    (ada_page (ct_nth (file_exist_check file) **text_file_list** ))))

;;;
;;; IO for integer
;;;

(defun ada_get_integer_d (ar)
  (with_ada_parameters ((item item) (width width))
   (setq item (first (ada_get_integer
		       width
		       (ct_nth **default_input** **text_file_list** ))))))

(defun ada_get_integer_f (ar)
  (with_ada_parameters ((file file) (item item) (width width))
   (setq item (first (ada_get_integer
		       width
		       (ct_nth (file_exist_check file)
			       **text_file_list** ))))))

(defun ada_put_integer_d (ar)
  (with_ada_parameters ((item item) (width width) (ebase base))
   (ct_if (or (equal item '*unassigned*))
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   (ada_put_integer item
		    (ct_nth **default_output** **text_file_list** )
		    width
		    ebase)))

(defun ada_put_integer_f (ar)
  (with_ada_parameters ((file file) (item item) (width width) (ebase base))
   (ct_if (or (equal item '*unassigned*))
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   (ada_put_integer item
		    (ct_nth (file_exist_check file) **text_file_list** )
		    width
		    ebase)))

(defun ada_get_integer_from_string_d (ar)
  (with_ada_parameters ((from from) (item item) (last last))
   (ct_if (or (equal from '*unassigned*))
	    (ada_raise '|program_error|
		       "the variable FROM is unassigned"))
   (ct_if (or (equal item '*unassigned*))
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   (let* ((str (#+lispm string #+franz get_pname
		(implode (second
			   (convert_strrep_to_lexstr from)))))
	  (lastpos (caar (get-iv dt_array_type from 'index_list)))
	  (ans (ada_get_integer_from_string str lastpos))) 
     (setq last (third ans))            
     (setq item (first ans)))))
			  
(defun ada_put_integer_to_string_d (ar)
  (with_ada_parameters ((to to) (item item) (ebase base))
   (ct_if (or (equal to '*unassigned*))
	    (ada_raise '|program_error|
		       "the variable TO is unassigned"))
   (ct_if (or (equal item '*unassigned*))
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   (let* ((ans (ada_put_integer_to_string
		 item
		 (length (second
			   (convert_strrep_to_lexstr to )))
		 ebase)))
     (setq to (fill_str_into_array to (second ans))))))
;;;
;;; string and char manipulation
;;;
(defun ada_get_character_d (ar)
  (with_ada_parameters ((item item))
   (setq item (convert_integer_to_char
	       (car (ada_get_character
		      (ct_nth **default_input** **text_file_list** )))))))

(defun ada_get_character_f (ar)
  (with_ada_parameters ((item item) (file file))
   (setq item (convert_integer_to_char
		(car (ada_get_character  (ct_nth (file_exist_check file)
						 **text_file_list**)))))))

(defun ada_put_character_d (ar)
  (with_ada_parameters ((item item))
   (ct_if (or (equal item '*unassigned*))
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))

   #|(ct_if (eq item ''*unassigned*)
	  (ct_format *errout*
		     "~%Warning: An unassigned character in PUT ~%"))|#

   (ada_put_character (car (second (convert_chrrep_to_lexchar item)))
		      (ct_nth **default_output** **text_file_list** ))))

(defun ada_put_character_f (ar)
  (with_ada_parameters ((item item) (file file))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   (ct_if (eq item ''*unassigned*)
	  (ct_format *errout*
		     "~%Warning: An unassigned character in PUT ~%"))
   (ada_put_character (car (second (convert_chrrep_to_lexchar item)))
		      (ct_nth (file_exist_check file) **text_file_list**))))

(defun ada_get_string_d (ar)
  (with_ada_parameters ((item item))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   (setq item
    (fill_str_into_array
      item
      (car (ada_get_string
	     (length (second
		       (convert_strrep_to_lexstr item )))
	     (ct_nth **default_input** **text_file_list** )))))))

(defun ada_get_string_f (ar)
  (with_ada_parameters ((item item) (file file))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   (setq item
    (fill_str_into_array
      item
      (car (ada_get_string
	     (length (second
		       (convert_strrep_to_lexstr item )))
	     (ct_nth (file_exist_check file) **text_file_list**)))))))

(defun ada_put_string_d (ar)
  (with_ada_parameters ((item item))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
  #| (ct_if (not (assigned_stringp item))
	  (ct_format *errout*
		     "~%Warning: An unassigned string in PUT ~%"))|#
   (ada_put_string  (second
		      (convert_strrep_to_lexstr item))
		    (ct_nth **default_output** **text_file_list** ))))

(defun ada_put_string_f (ar)
  (with_ada_parameters ((item item) (file file))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   
  #| (ct_if (not (assigned_stringp item))
	  (ct_format *errout*
		     "~%Warning: An unassigned string in PUT ~%"))|#
   (ada_put_string (second
		     (convert_strrep_to_lexstr item))
		   (ct_nth (file_exist_check file) **text_file_list**))))

(defun ada_get_line_d (ar)
  (with_ada_parameters ((item item) (last last))
   (let ((anslist
	   (ada_get_line #+lispm (array-length (get-iv dt_array_type
							item 'array_storage))
			  #+franz (arraydims (get-iv dt_array_type
						     item 'array_storage))
			 (ct_nth **default_input** **text_file_list** )
			 (caar (get-iv dt_array_type item 'index_list)))))
     (setq last (third anslist))
     (setq item  (fill_chlist_into_array item (car anslist))))))

(defun ada_get_line_f (ar)
  (with_ada_parameters ((file file) (item item) (last last))
   (let ((anslist
	   (ada_get_line #+lispm (array-length (get-iv dt_array_type
							item 'array_storage))
			  #+franz (arraydims (get-iv dt_array_type
						     item 'array_storage))
			 (ct_nth (file_exist_check file) **text_file_list** )
			 (caar (get-iv dt_array_type item 'index_list)))))
     (setq last (third anslist))
     (setq item  (fill_chlist_into_array item (car anslist))))))


(defun ada_put_line_d (ar)
  (with_ada_parameters ((item item))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
  #| (ct_if (not (assigned_stringp item))
	  (ct_format *errout*
		     "~%Warning: An unassigned string in PUT_LINE ~%"))|#
   (ada_put_line (second (convert_strrep_to_lexstr item))
		 (ct_nth **default_output** **text_file_list** ))))

(defun ada_put_line_f (ar)
  (with_ada_parameters ((item item) (file file))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
  #| (ct_format *errout*
		     "~%Warning: An unassigned string in PUT_LINE ~%")|#
   (ada_put_line (second (convert_strrep_to_lexstr item))
		 (ct_nth (file_exist_check file) **text_file_list**))))   

;;;
;;; IO for reals -- floating point
;;;
(defun ada_get_real_d (ar)
  (with_ada_parameters ((item item) (width width))
   (setq item (first (ada_get_real  
		       item
		       width
		       (ct_nth **default_input** **text_file_list** ))))
   ))

(defun ada_get_real_f (ar)
  (with_ada_parameters ((file file) (item item) (width width))
   (setq item (first (ada_get_real 
		       item
		       width
		       (ct_nth (file_exist_check file) **text_file_list** )))))
     )
   
(defun ada_put_real_d (ar)
  (with_ada_parameters ((item item) (fore fore) (aft aft) (exp exp))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   (ada_put_real item
		 (ct_nth **default_output** **text_file_list** )
		 fore
		 aft
		 exp)))


(defun ada_put_real_f (ar)
  (with_ada_parameters ((file file) (item item) (fore fore) (aft aft) (exp exp))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   (ada_put_real item
		 (ct_nth (file_exist_check file) **text_file_list**)
		 fore
		 aft
		 exp)))

(defun ada_get_real_from_string_d (ar)
  (with_ada_parameters ((from from) (item item) (last last))
   (ct_if (equal from '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable FROM is unassigned"))
   (let*((str (#+lispm string #+franz get_pname
	       (implode (second (convert_strrep_to_lexstr from)))))
	 (lastpos (caar (get-iv dt_array_type from 'index_list)))
	 (anslist (ada_get_real_from_string str lastpos)))
     (setq last (third anslist))
     (setq item (first anslist)))))

(defun ada_put_real_to_string_d (ar)
  (with_ada_parameters ((to to) (item item) (aft aft) (exp exp))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   (let* ((ans (ada_put_real_to_string
		 item
		 (length (second
			  (convert_strrep_to_lexstr to )))
		 aft
		 exp )))

     (setq to (fill_str_into_array to (second ans))))))

      ;;suplly the default aft exp later

;;;
;;; IO for real -- fixed point 

(defun ada_get_fixed_real_d (ar)
  (with_ada_parameters ((item item) (width width))
   (let* ((itemo (ada_parameter item))
	  (nufval (ct_send itemo 'real_to_fpv_conversion 
		   (first (ada_get_real	 
			    item
			    width
			    (ct_nth **default_input** **text_file_list** ))))))
     (setq *io_get_fixed* t)
     (%= item nufval))))

(defun ada_get_fixed_real_f (ar)
  (with_ada_parameters ((file file) (item item) (width width))
   (let* ((itemo (ada_parameter item))
	  (nufval (ct_send itemo 'real_to_fpv_conversion 
		    (first (ada_get_real  
			     item
			     width
			     (ct_nth (file_exist_check file)
				     **text_file_list** ))))))
     (setq *io_get_fixed* t)
     (%= item nufval))
   ))

(defun ada_put_fixed_real_d (ar)
  (with_ada_parameters ((item item) (fore fore) (aft aft) (exp exp))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   #|
   (ada_put_real (fpv_to_real_conversion item)
		 (ct_nth **default_output** **text_file_list** )
		 fore
		 aft
		 exp)
   |#
   (let* ((val (fpv_to_real_conversion item))
	  (str (cond ((> val 0.0)
		      (exploden (ct-flonum-to-string
				  val
				  nil
				  (+ aft fore)
				  aft)))
		     (t (cons #/- (exploden (ct-flonum-to-string
					      (abs val)
					      nil
					      (+ aft fore)
					      aft))))))
	  )
   (ada_put_string str
		   (ct_nth **default_output** **text_file_list** ))
					
   )))


(defun ada_put_fixed_real_f (ar)
  (with_ada_parameters ((file file) (item item) (fore fore) (aft aft) (exp exp))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   #|
   (ada_put_real (fpv_to_real_conversion item)
		 (ct_nth (file_exist_check file) **text_file_list** )
		 fore
		 aft
		 exp)
   |#
   (let* ((val (fpv_to_real_conversion item))
	  (str (cond ((> val 0.0)
		      (exploden (ct-flonum-to-string
				  val
				  nil
				  (+ aft fore)
				  aft)))
		     (t (cons #/- (exploden (ct-flonum-to-string
					      (abs val)
					      nil
					      (+ aft fore)
					      aft))))))
	  )
   (ada_put_string str
		   (ct_nth (file_exist_check file) **text_file_list** ))
					
   )))

(defun ADA_GET_FIxed_real_from_string_d (ar)
  (with_ada_parameters ((from from) (item item) (last last))
   (ct_if (equal from '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable FROM is unassigned"))
   (let* ((str (#+lispm STRING #+franz get_pname
	       (implode (second (convert_strrep_to_lexstr from)))))
	 (anslist (ada_get_real_from_string str last))
	 (itemo (ada_parameter item)))
     (setq last (third anslist))
     (setq item (ct_send itemo 'real_to_fpv_conversion (first anslist))))))

(defun ada_put_fixed_real_to_string_d (ar)
  (with_ada_parameters ((to to) (item item) (aft aft) (exp exp))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   (let* ((ans (cond ((eq exp 0)
		      (ct-flonum-to-string (fpv_to_real_conversion item)
					   nil
					   (+ aft exp 1)
					   (add1 aft)))
		     (t (second (ada_put_real_to_string
				  (fpv_to_real_conversion item)
				  (length (second
					    (convert_strrep_to_lexstr to )))
				  aft
				  exp)))
		     )))
     (setq to (fill_str_into_array to ans))
     )))

;;;
;;; IO for enumeration type
;;;
(defun ada_get_enum_d (ar)
  (with_ada_parameters ((item item))
   (let* ((itemo (ada_parameter item))
	 (enumlist (list-of-values itemo)))
     (setq item (search-enum (first
			       (ada_get_enum
				 enumlist
				 item
				 (ct_nth **default_input** **text_file_list** )))
			     itemo)))))

(defun ada_get_enum_f (ar)
  (with_ada_parameters ((file file) (item item))
   (let ((itemo (ada_parameter item)))
   (setq item (search-enum (first
			     (ada_get_enum
			       (list-of-values itemo)
			       item
			       (ct_nth (file_exist_check file)
				       **text_file_list** )))
	       itemo)))))
  
(defun ada_put_enum_d (ar)
  (with_ada_parameters ((item item) (width width) (set set))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   (ada_put_enum width
		 (second (diana_get item 'lx_symrep))
		 (ct_nth **default_output** **text_file_list** )
		 width
		 (equal (get-literal set) '|lower_case|))
   ))

(defun ada_put_enum_f (ar)
  (with_ada_parameters ((file file) (item item) (width width) (set set))
   (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   (ada_put_enum width
		 (second (diana_get item 'lx_symrep))
		 (ct_nth (file_exist_check file) **text_file_list** )
		 width
		 (equal (get-literal set) '|lower_case|))
		 ))

(defun ada_get_enum_from_string_d (ar)
  (with_ada_parameters ((from from) (item item) (last last))
   (ct_if (equal from '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable FROM is unassigned"))
   (let*((str (#+lispm string #+franz get_pname
	       (implode (second (convert_strrep_to_lexstr from)))))
	 (itemo (ada_parameter item))
	 (lastpos (caar (get-iv dt_array_type from 'index_list)))
	 (anslist (ada_get_enum_from_string (list-of-values itemo)
					     str
					     lastpos)))
     (setq item (search-enum (first anslist) itemo))
     (setq last (second anslist)))))

(defun ada_put_enum_to_string_d (ar)
  (with_ada_parameters ((to to) (item item) (set set))
    (ct_if (equal item '*unassigned*)
	    (ada_raise '|program_error|
		       "the variable ITEM is unassigned"))
   (let* ((str (#+lispm string #+franz get_pname
		(implode (second (diana_get item 'lx_symrep)))))
	  (arrayname (get-iv dt_array_type to 'array_storage))
	  (tolen #+lispm (array-length arrayname)
		   #+franz (getlength arrayname)))
     (setq to (fill_str_into_array to
				   (second (ada_put_enum_to_string
					     tolen str set))
			     )))))