;;; -*- Fonts: CPTFONTB -*-
;;; $Header: /ct/interp/textio.l,v 1.28 84/09/10 16:10:45 alex Exp $
;;; $Log: 
;;; 
;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                              TEXTIO                              ;;;
;;; John Shelton                                                     ;;;
;;; Alex C. Meng                                                     ;;;
;;;              						     ;;;   
;;; Thisfile 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                 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



#+franz (declare (macros t))

; This file contains code to implement "top_level" functions that will be
; written to directly interpret ADA functions and procedures for textio.

(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 'ctflav));Compatible flavors.

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

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

(eval-when (compile load eval)		  ;With_ada_parameters macro.
	   (ct_load 'bifmacs))

(eval-when (compile load eval)		  ;For ada_raise.
	   (ct_load 'dsmacs))

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

; ****************************************************************
; Notes about procedures.
; ****************************************************************

; Procedures of N parameters (in ADA) will be simulated in LISP by 
; passing in N arguments, and returning a list of N items corresponding
; to the parameters.  If there are additional arguments that need
; be supplied the function, they will not be returned.  These arguments
; typically are used to simulate a specific, instantiated procedure for
; a particular sub_type.  

;  Some procedures and functions may accept optional arguments.  These
; are not truly optional, but do allow the user of this package to specify
; nil to request a DEFAULT value, rather than explicitly providing a value.




; ****************************************************************
;   Functions
; ****************************************************************


; ada_create_file  creates and opens a file.   It is
; not clear what to do when an existing file is asked to be created in INPUT
; mode.   We detect a file's already being open by the non_nil file slot.  We don't
;;; do anything with the FORM input.
(defun ada_create_file (file mode name form)
    (cond (file                               ; If there is already a file obj,
	      (ada_raise '|status_error| "File object already exists."))
	((eq mode 'input)		  ; If mode is INPUT, then open
	 (let ((fileo (errset (open_for_input name) nil)))
	    (ct_if (null fileo)
		   (ada_raise '|name_error| "cannot create the input file")
		   (setq file (car fileo )))))
	(t
	 (let* ((fname (ct_if (equal name "")
			     (ct_string_append "#junk"
						(#+lispm string #+franz get_pname
						 (gensym)))
			     name))
		(fileo (errset (open_for_output fname) nil)))
	   (ct_if (null fileo)
		  (ada_raise '|name_error| "cannot create the output file")
		  (setq file (car fileo)))

		 (ct_if (equal name "") 
			(setq *textio_temp_file_list*
			      (cons file *textio_temp_file_list*))))))
    
    (list file mode name form))
			    

; ada_open_file  establishes a port for reading or writing.  No file reading
; or writing can occur without a file being open.  Note the subtle
; difference with ada_create_file.  Also note that for output mode, this
; function requires that the file already exists, even though it will just
; write over it anyway. 
(defun ada_open_file (file mode name form)
    (cond ((not (ct_probef name)) ; If file doesn't exist
	   (ada_raise '|name_error| "File does not exist."))
	  ((and file (eq (get_status file) 'open))
           (ada_raise '|status_error| "File is already open.")) ; complain.
	  ((eq mode 'input)
	   (let ((fileo (errset (open_for_input name) nil)))
	     (ct_if (null fileo)
		    (ada_raise '|name_error| "cannot open the input file")
		    (setq file (car fileo)))))
	  (t
	    (let ((fileo (errset (open_for_output name) nil)))
	     (ct_if (null fileo)
		    (ada_raise '|name_error| "cannot open the output file")
		    (setq file (car fileo))))))
	  
   (list file mode name form))
				  
		              

; ada_close_file  closes a file.  STATUS_ERROR is raised if the file is not
; open.  
(defun ada_close_file (file)
  (cond
    ((or (eq file *ada_default_original_input*)
	 (eq file *ada_default_input*)
	 (eq file *ada_default_original_output*)
	 (eq file *ada_default_output*))
     (ada_raise '|status_error| "Attempt to close standard stream."))
    ((and file (eq (get_status file) 'open))
     (ct_send file 'close))				; close the file
    (t (ada_raise '|status_error| "Attempt to close non_open stream")))
  (list file))


; ada_delete_file  closes and deletes an open file.  STATUS_ERROR is raised
; if the file is not open.  
(defun ada_delete_file (file)
  (cond ((or (eq file *ada_default_original_input*)
	     (eq file *ada_default_input*)
	     (eq file *ada_default_original_output*)
	     (eq file *ada_default_output*))
	 (ada_raise '|status_error| "Attempt to close standard stream."))
	((and file (eq (get_status file) 'open))
	 (ct_send file 'delete)
	 (setq file nil))
	(t (ada_raise '|status_error| "Attempt to close non_open stream.")))
  (list file))
	       
	       


; ada_reset_file will reset the file so that reading or writing starts from
; the beginning of the file.  A mode may be specified (IN, OUT) to change
; the current mode, if desired.  This can be accomplished by closing the
; file and then opening it again.  (Use NIL to specify no particular mode.)
(defun ada_reset_file ( filenum file mode)
  (cond
    ((or (eq file *ada_default_original_input*)
	 (eq file *ada_default_input*)
	 (eq file *ada_default_original_output*)
	 (eq file *ada_default_output*))
     (ada_raise '|status_error| "Attempt to close standard stream."))
    ((and file (eq (get_status file) 'open))
     (let ((cur_mode (get_mode file))
	   (cur_name (get_name file)))
       (ada_close_file file)
       (ct_if (not mode) (setq mode cur_mode))
       (setq file (car (ada_open_file
			    file
			    mode
			    cur_name
			    "")))))
    (t (ada_raise '|status_error| "File is not open.")))
  (setq **text_file_list** (replace_nth filenum file  **text_file_list** )))

 
				 


; ada_file_mode (FUNCTION) returns the current mode of the given file.
; status_error is raised if the file is not open. (returns 'input or 'output)
(defun ada_file_mode (file)
  (ct_if (and file (eq (get_status file) 'open))
      (get_mode file)
      (ada_raise '|status_error| "File is not open.")))



; ada_file_name (FUNCTION) returns the name of the open file.  status_error
; is raised if the file is not open.
(defun ada_file_name (file)
  (ct_if (and file (eq (get_status file) 'open))
      (get_name file)
      (ada_raise '|status_error| "File is not open.")))


; ada_file_form (FUNCTION) returns as a string the form of the file.  Right
; now, form is undefined.
(defun ada_file_form (file)
    (ct_if file "" (ada_raise '|status_error| "No file object.")))


; ada_file_is_open (FUNCTION) returns a boolean indicating whether or not
; the file is open.  
(defun ada_file_is_open (file)
    (ct_if file (eq (get_status file) 'open) nil))


; ada_set_default_input  sets the current default input file to FILE.
(defun ada_set_default_input (file)
    (cond
	((not file) (ada_raise '|status_error| "Not a valid file object."))
	((not (eq (get_status file) 'open))
	 (ada_raise '|status_error| "Supplied file is not open."))
	((not (eq (ct_typep file) 'ada_input_stream))
	 (ada_raise '|mode_error| "File sould be a in_file")))
    file)


; ada_set_default_output  sets the current default output file to FILE.
(defun ada_set_default_output (file)
    (cond
	((not file)
	 (ada_raise '|status_error| "Must supply a file."))
	((not (eq (get_status file) 'open))
	 (ada_raise '|status_error| "File must be open."))
        ((not (eq (ct_typep file) 'ada_output_stream))
	 (ada_raise '|mode_error| "File sould be a out_file")))
    file)


; ada_standard_input (FUNCTION) returns the file provided at the beginning of
; program execution as a default input file.
(defun ada_standard_input ()
    *ada_default_original_output*)

; ada_standard_output (FUNCTION)  returns the file provided at the beginning
; of program execution as a default output file.
(defun ada_standard_output ()
    *ada_default_original_output*)


; ada_current_input (FUNCTION)  returns the current default input file.
(defun ada_current_input () *ada_default_input*)


; ada_current_output (FUNCTION)  returns the current default output file.
(defun ada_current_output () *ada_default_output*)



; ****************************************************************
; Dealing with lines and pages.
; ****************************************************************


; ada_set_line_length  sets the maximum line length of an open file.  The
; file parameter is optional, and defaults to the default output file.
;  MODE_ERROR is raised if the mode is not OUT_FILE.  USE_ERROR is raised if
; the line length is not appropriate.  A line length of 0 indicates an
; unbounded line length.
(defun ada_set_line_length (length file)
    (ct_if (not file) (setq file *ada_default_output*))
    (cond
	((not (eq (get_mode file) 'output))
	 (ada_raise '|mode_error| "File must be open for output."))
	((< length 0)
	 (ada_raise '|use_error| "Line length shoule be positive"))
	(t (set-iv ada_output_stream file 'max_column length)))
           ;;;(ct_send file 'set-max_column length)
    (list length file))


; ada_set_page_length is similar to ada_set_line_length.
(defun ada_set_page_length (length file)
    (ct_if (not file) (setq file *ada_default_output*))
    (cond
	((not (eq (get_mode file) 'output))
	 (ada_raise '|mode_error| "File must be open for output."))
	((< length 0)
	 (ada_raise '|constraint_error| "page length shoule be positive"))
	(t (set-iv ada_output_stream file 'max_line length)))
           ;;;(ct_send file 'set-max_line length)
    (list length file))
	    


; ada_line_length (FUNCTION)  returns the maximum line length for the
; specified file, which defaults to the default output file.  Raises
; MODE_ERROR if the mode is not OUT_FILE.
(defun ada_line_length (file)
  (ct_if (not file) (setq file *ada_default_output*))
  (cond ((not (eq (get_mode file) 'output))
	 (ada_raise '|mode_error| "File must be open for output.")))
  (get-iv ada_output_stream file 'max_column))
  ;;;;(ct_send file 'max_column)

; ada_page_length is similar to ada_line_length
(defun ada_page_length (file)
  (ct_if (not file) (setq file *ada_default_output*))
  (cond ((not (eq (get_mode file) 'output))
	 (ada_raise '|mode_error| "File must be open for output.")))
  (get-iv ada_output_stream file 'max_line))
  ;;;;(ct_send file 'max_line)


; ada_new_line  outputs an EOL, possibly N times.  N defaults to 1.  The
; output file defaults to the default output file.  Works on OUT_FILEs only.
(defun ada_new_line (file n)
    (ct_if (not n) (setq n 1))
    (ct_if (not file) (setq file *ada_default_output*))
    (ct_if (not (eq (get_mode file) 'output))
	   (ada_raise '|mode_error| "File must be open for output"))
    (ct_send file 'flush_line_buf)
    (ct_if (greaterp n 0)
	   (ct_dotimes n (ct_send file 'print_char *ada_eol*))
	   (ada_raise '|constraint_error| "Spacing number should be positive"))
    (list file n))


; ada_skip_line  "Reads and discards all characters until a line terminator
; has been read, and then sets the current column number to one.  If the
; line terminator is not immediately followed by a page terminator, the
; current line number is incremented.  Otherwise, if the line terminator is
; immediately followed by a page terminator, then the page terminator is
; skipped, the current page number is incremented by one, and the current
; line number is set to one."  If the spacing N is greater than one, the
; above is done N times.  Works on IN_FILEs only.
(defun ada_skip_line (spacing file)
    (ct_if (not file) (setq file *ada_default_input*))
    (ct_if (not spacing) (setq spacing 1))
    (ct_if (eq (get_mode file) 'input)
	(ct_if (greaterp spacing 0)
	   (ct_send file 'skip_line spacing)
	   (ada_raise '|constraint_error| "Spacing number should be positive"))
	(ada_raise '|mode_error| "File must be open for input."))
    (list spacing file))


; ada_end_of_line (FUNCTION) returns true if a line terminator or a file
; terminator is next.  MODE_ERROR is raised if the mode is not IN_FILE.
; File defaults to the default input file.
(defun ada_end_of_line (file)
    (ct_if (not file) (setq file *ada_default_input*))
    (ct_if (eq (get_mode file) 'input)
	   (ct_send file 'end_of_line_p)
	   (ada_raise '|mode_error| "File must be open for input.")))


; ada_new_page.  If the current line is not terminated, and likewise if the
; current page is terminated, outputs a line terminator.  Then outputs a
; page terminator, which terminates the current page.  Adds one to the
; current page number, and sets the column and line numbers to 1.
; MODE_ERROR is raised if the mode is not OUT_FILE.  File defaults to the
; current default output file.
(defun ada_new_page  (file)
    (ct_if (not file) (setq file *ada_default_output*))
    (ct_if (eq (get_mode file) 'output)
	(progn (ct_send file 'flush_line_buf) 
	       (ct_send file 'print_end_of_page))
	(ada_raise '|mode_error| "File must be open for output."))
    (list file))


; ada_skip_page.   reads and discards all characters and line terminators
; until a page terminator has been read.  Then adds one to the current page
; number, and sets the current column and line numbers to one.  MODE_ERROR
; is raised if the mode is not IN_FILE.  END_ERROR is raised if an attempt
; is made to read the EOF terminator.
(defun ada_skip_page (file)
    (ct_if (not file) (setq file *ada_default_input*))
    (ct_if (eq (get_mode file) 'input)
	(ct_send file 'skip_page 1)
        (ada_raise '|mode_error| "File must be open for input."))
    (list file))


; ada_end_of_page (FUNCTION)  returns TRUE if the combination of a line
; terminator and a page terminator is next, or if a file terminator is next.
; Raises MODE_ERROR if mode is not IN_FILE.
(defun ada_end_of_page (file)
    (ct_if (not file) (setq file *ada_default_input*))
    (ct_if (eq (get_mode file) 'input)
	(ct_send file 'end_of_page_p)
	(ada_raise '|mode_error| "File must be open for input.")))



; ada_end_of_file (FUNCTION)  returns TRUE if a file terminator (EOF) is
; next, or if the combination of a line, page, and file terminator is next.
(defun ada_end_of_file (file)
  (let (ans)
    (ct_if (not file) (setq file *ada_default_input*))
    (ct_if (eq (get_mode file) 'input)
	(setq ans (ct_send file 'end_of_file_p))
	(ada_raise '|mode_error| "File must be open for input."))
#|    
    #+(or 3600 cadr)
    (let* ((real_stream (ct_send file 'real_stream))
	   (terminal_style_io (ct_send file 'terminal_style_io))
	   char)
      (cond (terminal_style_io
	     (cond ((ct_send real_stream ':listen)
		    (setq char (ct_send real_stream ':tyi))
		    (ct_if (member char *keyboard_eof*) ans
			   (ct_send real_stream ':untyi char)))
		   (t nil)))
      ))
|#
    ans))

; ada_set_col
; FOR OUTPUT FILES: If the value specified by TO is greater than the current
; column number, outputs spaces, adding one to the current column number
; after each space, until the current column number equals the specified
; value.  If the value specified by TO is equal to the current column
; number, there is no effect.  If the value specified by TO is less than the
; current column number, has the effect of calling NEW_LINE with a spacing
; of one, then outputs TO-1 spaces, and sets the current column number to
; the specified value.  Raises LAYOUT_ERROR if TO exceeds LINE_LENGTH.  If
; TO is zero, just causes a new_line.
; FOR INPUT FILES:  Performs GET operations for characters (which are
; discarded) until the current column number equals the value specified by
; TO.  If the current column number already equals the specified calue of
; TO, there is no effect.  END_ERROR is raised if an attempt is made to read
; a file terminator.  This definition implies that for input files with no
; line terminator, you could read to the end of the file on a simple error.

(defun ada_set_col (col file)
  (ct_if (not file) (setq file *ada_default_output*))
  (cond ((eq (get_mode file) 'input)
	 (do ()
	     ((= (get-iv ada_input_stream file 'current_column) col))
	   (ct_send file 'get_char)))	  ; it will raise end_error if necessary
					  ; discard
	(t				  ; otherwise, must be output mode
	 (let ((cur_col (get-iv ada_output_stream file 'current_column))
	       (splist nil)
	       (line_length (get-iv ada_output_stream file 'max_column)))
	   (cond ((<= col 0)
		  (ada_raise '|constraint_error|
			     "Non-positive column number in  SET-COL"))
		 ((greaterp line_length 0)
		  (ct_if (greaterp col line_length)
			 (ada_raise '|layout_error|
				    "Col number exceed the line length"))))
	   (cond ((= cur_col col))        ; if equal, do nothing.
		 ((> cur_col col)	  ; if greater,
		  (ct_send file 'print_end_of_line)
		  (ct_dotimes (sub1 col) (setq splist (cons *ada_space* splist)))
		  (ct_send file 'print_char_list splist))
		 (t (ct_dotimes (- col cur_col)
				(setq splist (cons *ada_space* splist)))
		    (ct_send file 'print_char_list splist))))))
  (list col file))


; ada_set_line
; FOR OUTPUT FILES:  If the value specified by TO is greater than the
; current lien number, repeatedly calls NEW_LINE until the current line
; number is equal to the specified value.  If TO is equal to the current
; line number, no effect.  If TO is less than the current line number, calls
; NEW_PAGE, and then NEW_LINE with spacing TO-1.  LAYOUT_ERROR is raised if
; the value specified by TO exceeds the page length maximum.
; FOR INPUT FILES:  calls skip_line until the current line number equals the
; specified value of TO.  If the current line number already equals the
; specified value of TO, there is no effect.  END_ERROR is raised if the
; EOF terminator is read.
(defun ada_set_line (line file)
    (ct_if (not file) (setq file *ada_default_output*))
    (let ((page_length (ct_send file 'max_line)))
      (cond ((lessp line 0)
	     (ada_raise '|constraint_error|
			"Negative line number in SET-LINE"))
	    ((greaterp page_length 0)
	     (ct_if (greaterp line page_length)
		    (ada_raise '|layout_error|
			       "LINE number exceed the page length")))))
    (cond
	((eq (get_mode file) 'input)        ; if INPUT mode,
	    (do ()                          ; do skiplines for a while.
		((= (get-iv ada_input_stream file 'current_line) line))
		(ct_send file 'skip_line)))
	(t			            ; otherwise, must be OUTPUT
	    (let ((cur_line (get-iv ada_output_stream file 'current_line)))
		(cond
		    ((= cur_line line))     ; if equal, do nothing.
		    ((> cur_line line)
			(ct_send file 'print_end_of_page)
			(ct_dotimes (max 0 (1- line))
			    (ct_send file 'print_end_of_line)))
		    (t (ct_dotimes (- line cur_line)
			   (ct_send file 'print_end_of_line)))))))
    (list line file))



; ada_col   (FUNCTION)  returns the current column number.  If this number
; is bigger than *ada_max_integer*, LAYOUT_ERROR is raised.
(defun ada_col (file)
    (ct_send (or file *ada_default_output*) 'find_current_column))


; ada_line  (FUNCTION)  returns the current line number.  If this number is
; bigger than *ada_max_integer*, LAYOUT_ERROR is raised.
(defun ada_line (file)
    (ct_send (or file *ada_default_output*) 'find_current_line))


; ada_page  (FUNCTION)  returns the current page number.  If this number is
; bigger than *ada_max_integer*, LAYOUT_ERROR is raised.
(defun ada_page (file)
    (ct_send (or file *ada_default_output*) 'find_current_page))



; ****************************************************************
; string and character manipulation
; ****************************************************************

; ada_get_character  reads one character from the input file.  Any line
; terminators and page terminators are skipped.  END_ERROR is raised if an
; attempt is made to read the EOF.
(defun ada_get_character (file)
  (prog (char)
    (ct_if (not file) (setq file *ada_default_input*))
    (ct_if (eq (get_mode file) 'input)
	(let* ((stdout (ct_nth **standard_output** **text_file_list**))
	       (goflush (ct_send file 'terminal_style_io)))
	  (ct_if goflush
		 (ct_send  stdout 'flush_line_buf))
	  (setq char (ct_send file 'get_char)))
	(ada_raise '|mode_error| "File must be open for input."))
    (return (list char file))))



; ada_put_character  outputs one character.  WIll not exceed the maximum
; line or page lengths.
(defun ada_put_character (char file)
    (ct_if (not file) (setq file *ada_default_output*))
    (ct_if (eq (get_mode file) 'output)
	(ct_if (> (setq char (map_ascii_to_lispm char)) 0)
	       (ct_send file 'print_char char))
	(ada_raise '|mode_error| "File must be open for output."))
    (list char file))


; ada_get_string  reads a string of N characters, where N is the length of
; the string passed as a parameter.  Reads N characters by doing get_char
; operations, thus ignoring line boundaries.  Attempting to read past the
; end of file will cause an END_ERROR.
(defun ada_get_string (len file)
  (prog (string)
	(ct_if (not file) (setq file *ada_default_input*))
	(ct_if (eq (get_mode file) 'input)
	       (let* ((stdout (ct_nth **standard_output** **text_file_list**))
		      (goflush (get-iv ada_input_stream file 'terminal_style_io)))
		 (ct_if goflush
			(ct_send  stdout 'flush_line_buf))
		 (setq string (ct_send file 'get_string len)))
	       (ada_raise '|mode_error| "File must be open for input."))
	(return (list string file))))


; ADA_PUT_STRing  will put_char the characters of the char list.
(defun ada_put_string (charl file)
     (ct_if (not file) (setq file *ada_default_output*))
    (ct_if (eq (get_mode file) 'output)
	(ada_put_string_aux charl file)
        (ada_raise '|mode_error| "File must be open for output."))
    (CT_IF (EQUAL (GET_STATUS FILE) 'CLOSED)
           (ADA_RAISE '|status_error| 
                      "File is closed"))
    (list charl file))

;;;the aux function for ada_put_string, check if there is a control char embeded
;;;in the char list, break the char list if necessary
(defun ada_put_string_aux (charl file)
  (do ((ll charl (cdr ll))
       (ans nil))
      ((null ll) (ct_send file 'print_char_list (nreverse ans)))
    (ct_if (is_control_char (car ll))
	     (ct_if (null ans)
		    (progn
		      (ct_send file 'flush_line_buf)
		      (ct_send file 'print_char (car ll)))
		    (progn
		      (ct_send file 'print_char_list (nreverse ans))
		      (ct_send file 'flush_line_buf)
		      (setq ans nil)
		      (ct_send file 'print_char (car ll))))
	   (setq ans (cons (car ll) ans)))
    ))

; ****************************************************************
; Line manipulation
; ****************************************************************

; ada_get_line  If at the end of the line, calls SKIP_LINE 1.  Then,
; replaces successive characters of the specified string by successive
; characters read from the specified file, stopping when wither the end of
; the string or the end of the line is met.  The ADA Ref. Man. says that
; characters in the string that are not replaced are left undefined.  This
; procedure will replace those characters with spaces.  The LAST parameter
; is an index value specifying the last character replaced, or 0 if no
; characters are read.  END_ERROR is raised if EOF is read.
(defun ada_get_line (len file last)
  (prog (chlist)
	(ct_if (not file) (setq file *ada_default_input*))
	(cond
	  ((eq (get_mode file) 'input)
	   (let* ((stdout (ct_nth **standard_output** **text_file_list**))
		  (goflush (get-iv ada_input_stream file 'terminal_style_io)))
		 (ct_if goflush
			(ct_send  stdout 'flush_line_buf)))
	   (ct_if (ct_send file 'end_of_line_p)
		  (ct_send file 'skip_line 1))
	   (setq chlist (ct_send file 'get_line len)) 
	   (setq last (1- (+ last (length chlist))))
	   (setq chlist (pad_right_charl chlist len *ada_space*)))
	  (t (ada_raise '|mode_error| "File must be open for input.")))
	(return (list chlist file last))))


; ada_put_line   Calls put_char_list, then new_line.
(defun ada_put_line (charl file)
    (ct_if (not file) (setq file *ada_default_output*))
    (cond
	((eq (get_mode file) 'output)
	    (ct_send file 'flush_line_buf)
	    ;(ct_send file 'print_char_list charl)
	    (ada_put_string_aux charl file)
	    (ct_send file 'flush_line_buf)
	    (ct_send file 'print_end_of_line))	    
	(t (ada_raise '|mode_error| "File must be open for output.")))
    (list charl file))
	
	



; ****************************************************************
; integer input output
; ****************************************************************

; These routines behave differently depending upon the type of integer used.
; ADA expects these to be generic routines, instantiated for each variety.

; To accomplish variations here, the integer routines expect to be supplied
; with a WIDTH parameter for that number type, and a RANGE parameter, which
; specifies the allowed range of values.  Numbers read that are outside of
; these values will raise DATA_ERROR.


; ada_get_integer   Skips leading blanks, line terms, and page terms.  Then
; reads an integer, stopping if a non-meaningful character is read, or if
; (non-zero) width chars are read.  Width defaults to zero on input.
; DATA_ERROR is raised for non-syntactic input, or out-of-range numbers.  
; RANGE must be specified-- it is a list of two numbers.  Width and file are
; both optional.  Width defaults to 0,
; which means that reading stops only when a lexical item has been read.
; file defaults	to the default input.
; delete number arg. -- no way to pass by reference. ++am+

; delete the range argument ++AM++

(defun ada_get_integer (width file)
 (prog (number base ibase)
   (setq base 10. ibase 10.)
   (ct_if (not width) (setq width 0))
   (ct_if (not file) (setq file *ada_default_input*))
   (ct_if (not (eq (get_mode file) 'input))
       (ada_raise '|mode_error| "File must be open for input."))
   (let* ((stdout (ct_nth **standard_output** **text_file_list**))
	  (goflush (get-iv ada_input_stream file 'terminal_style_io)))
     (ct_if goflush
	    (ct_send  stdout 'flush_line_buf)))
   (setq number (ct_send file 'get_integer width))
   (setq *io_get_integer* t)
   (return (list number width file))))



; ada_put_integer  Outputs the value of the supplied integer with NO
; UNDERSCORES, no exponent, and no leading zeros.  If the resulting output
; will have less than WIDTH characters, leading spaces make up the
; difference.  If a base other than 10 is specified, uses based number
; syntax.  File, width, and base may be defaulted.

(defun ada_put_integer ( integer file width ebase)
  (let ((base 10.) (ibase 10.) (*nopoint nil))
    (ct_if (not file) (setq file *ada_default_output*))
    (ct_if (not (eq (get_mode file) 'output))
	   (ada_raise '|mode_error| "File must be open for output."))
    (ct_send file 'put_integer integer width ebase)
    (list integer file width ebase)))


;;;  These functions do not use file objects.

;;; ada_get_integer_from_string will read an integer from a string instead
;;; of from a file.  The caller must provide RANGE and String.  A useful number
;;; is returned in number, and the last character index read from the string is
;;; return in last.
(defun ada_get_integer_from_string (string last)
  (let (ans (base 10.) (ibase 10.))
    (setq ans (string_fsm *integer_table* string))
    (list (car ans) string (+ last (cadr ans)))))

;;    (ct_if (<= (first range) (car ans) (second range))
;;	(list (car ans) string (cadr ans))
;;	(ada_raise '|data_error| "Integer out of range from string."))))


;;; ada_put_integer_to_string will place the integer, right justified, in the
;;; string, unless the string is too short, in which case LAYOUT_ERROR will
;;; be raised.
;;;  This version works by binding base, which fails in franzlisp.
#+lispm
(defun ada_put_integer_to_string (integer len ebase)
  (let (list
	basen
	(width len)
	(base 10.) (ibase 10.) (*nopoint t))
    (cond
      ((= ebase 10.)
       (setq list (exploden integer)))
      (t (setq basen (exploden ebase)
	       list (fix_hex_chars
		      (append (butlast basen)
			      '(35)
			      (let ((base ebase))
				(exploden integer))
			      '(35))))))
    
    (list
      integer
      (implode
	(cond ((< (length list) width)
	       (append (firstn (- width (length list)) (circular-list *ada_space*))
		       list))
	      ((> (length list) width)
	       (ada_raise '|layout_error|  "Integer too big to fit in string."))
	      (t list)))
      ebase)))


#+franz
(defun ada_put_integer_to_string (integer len ebase)
  (let (list (neg nil) (width len) (base 10.) (ibase 10.))
	 (ct_if (< integer 0) (setq integer (- integer)
				 neg t))
	 (setq list (do ((num integer)
			 (rems (ct_if (not (= ebase 10))
				   (list #/#)
				   nil)))
			((< num ebase)
			 (fix_hex_chars (cons (+ #/0 num) rems)))
			(setq rems (cons (+ #/0 (mod num ebase)) rems)
			      num  (*quo num ebase))))
	 (ct_if neg (setq list (cons #/- list)))
	 (ct_if (not (= ebase 10))
	     (setq list (append (exploden ebase) (list #/#) list)))
	 (maknam (ct_if (< (length list) width)
		     (append (firstn (- width (length list))
				     (circular-list *ada_space*)) list)
		     list))))






; ****************************************************************
; input-output for reals
; ****************************************************************


; ada_get_real.  Skips leading blanks, lineterms, and page terms.  Reads a
; real number, stopping if a (non-zero) width has happened, or if a
; non-meaningful character is read.  DATA_ERROR is raised if the sequence
; read is not a real, or if the value returned is not of the right type.
; The number may be based.  Width defaults to 0;  file defaults to the
; default input.
; delete the restriction argument . ++AM++

(defun ada_get_real (number width file)
  (let ((base 10.) (ibase 10.))  
    (ct_if (lessp width 0)
	   (ada_raise '|constraint_error| "Negative width parm"))
    (ct_if (not file) (setq file *ada_default_input*))
    (ct_if (not (eq (get_mode file) 'input))
	   (ada_raise '|mode_error| "File must be open for input."))
    (let* ((stdout (ct_nth **standard_output** **text_file_list**))
	  (goflush (get-iv ada_input_stream file 'terminal_style_io)))
     (ct_if goflush
	    (ct_send  stdout 'flush_line_buf)))
    (setq number (ct_send file 'get_real width))
    (setq *io_get_float* t)
    (list number width file)))


; ada_put_real.  Outputs the value of the ITEM parameter as a decimal
; number, using FORE, AFT, and EXP widths for formatting.  Read ARM, 14.3.8
; for full details.
(defun ada_put_real (number file fore aft exp)
  (let ((base 10.) (ibase 10.))
    (ct_if (not file) (setq file *ada_default_output*))
    (ct_if (not (eq (get_mode file) 'output))
	   (ada_raise '|mode_error| "File must be open for output."))
    (ct_send file 'put_real number fore aft exp)
    (list number file fore aft exp)))


;;;  Gets a real number from a string.
(defun ada_get_real_from_string (string last)
  (let (ans (base 10.) (ibase 10.))
    (setq ans (string_fsm *real_table* string))
    (list (car ans) string (+ last (cadr ans)))))

;;    (ct_if (<= (first restriction) (car ans) (second restriction))
;;	(list (car ans) string (cadr ans))
;;	(ada_raise '|data_error| "Real out of range from string."))))


;;;  Puts a real number in a string, right justified.
(defun ada_put_real_to_string (number len aft exp)
    (let ((fore (ct_if (zerop exp) (- len aft 1)
		     (- len aft exp 2)))
	(string nil)
	(base 10.) (ibase 10.) (*nopoint t))
    (setq string (ct_if (zerop exp)
			(real_charl_sans_exp number fore aft)
			(real_charl number fore aft exp)))
    (ct_if (> (length string) len)
	   (ada_raise '|layout_error| "Real number is too long for string."))
    (list number
	  (apply 'ct_string_append string) ;;(ct_format nil "~A" (implode string))
	  aft
	  exp)))






; ****************************************************************
;  input-output for enumerated types
; ****************************************************************


; ada_get_enum  AFter skipping leading blanks, EOLs, and EOPs, reads an
; identifier according to the syntax of this lexical element.  (Lower and
; upper case are considered identical.)   Raises DATA_ERROR if the sequence
; does not have the required syntax or if the identifier is not of the right
; type.  
(defun ada_get_enum (values item file)
    (ct_if (not file) (setq file *ada_default_input*))
    (ct_if (not (eq (get_mode file) 'input))
	(ada_raise '|mode_error| "File must be open for input."))
    (let* ((stdout (ct_nth **standard_output** **text_file_list**))
	   (goflush (get-iv ada_input_stream file 'terminal_style_io)))
      (ct_if goflush
	     (ct_send  stdout 'flush_line_buf)))
    (setq item (ct_send file 'get_enum values))
    (setq *io_get_enum* t)
    (list item file))


; ada_put_enum.  Outputs the item.  If LC is specified TRUE, the item is
; printed in all lower case.  If a width is specified, then spaces are used
; to fill on the right.
(defun ada_put_enum (default_width item file width lc)
  (ct_if (not file) (setq file *ada_default_output*))
  (ct_if (not (eq (get_mode file) 'output))
	 (ada_raise '|mode_error| "File must be open for output."))
  (ct_if (lessp width 0)
	 (ada_raise '|constraint_error| "Negative width parm"))
  (ct_if (eq 0 width) (setq width default_width))
  (ct_send file 'put_enum item width lc))


(defun ada_get_enum_from_string (values str last)
  (ct_if (equal str "")
	 (ada_raise '|end_error| "Null string been given")
	 (prog (string index len ch ans)
	       (setq string ""
		     index -1
		     len (ct_string_length str))
	    loop1
	       (setq index (1+ index)
		     ch (ct_nth_char str index))
	       (ct_if (= index (1- len))
		      (ada_raise '|data_error| "No item found; all spaces."))
	       (ct_if (eq ch *ada_space*) (go loop1))
	    loop2
	       (setq string (ct_string_append string ch))
	       (setq index (1+ index)
		     ch (ct_nth_char str index))
	       (ct_if (and (memq ch *item_chars*)
			   (< index (1- len)))
		      (go loop2))
	       
	       (ct_if (= index (1- len))
		      (setq string (ct_string_append string ch)))
	       (setq ans (list (implode
				 (exploden (ct_string_downcase string)))
			       (+ last index)))
	       (ct_if (memq (car ans) values) (return ans)
		      (ada_raise '|data_error| "Item not in data range.")))))

(defun ada_put_enum_to_string (tolen str lc)
  (let ((len (ct_string_length str)))
    (ct_if lc (setq str (ct_string_downcase str))
	      (setq str (ct_string_upcase str)))
    (ct_if (> len tolen)
	(ada_raise '|layout_error| "Enumerated item too long for string."))
    (list str
	  (pad_right_str str tolen *ada_space*)
	  lc)))