% (Last edit date : Sat Feb  7 15:00:10 1987)%

dmlfun(`ml_open_in`,":string -> num",1,[Call(1,`ml-open-in`)]);;
dmlfun(`ml_open_out`,":string -> num",1,[Call(1,`openo`)]);;
dmlfun(`ml_open_add`,":string -> num",1,[Call(1,`opena`)]);;
dmlfun(`ml_close`,":num -> obj",1,[Call(1,`close`)]);;
dmlfun(`ml_input`,":num # num -> string",2,[Call(2,`ml-input`)]);;
dmlfun(`ml_input_line`,":num -> string",1,[Call(1,`ml-input-line`)]);;
dmlfun(`ml_lookahead`,":num -> string",1,[Call(1,`ml-lookahead`)]);;
dmlfun(`ml_output`,":num # string -> void",2,[Call(2,`ml-output`)]);;
dmlfun(`ml_read`,":num # num -> string",2,[Call(2,`ml-read`)]);;
dmlfun(`ml_read_line`,":num -> string",1,[Call(1,`ml-read-line`)]);;


dmlfun(`ml_userbuf_input`,":num # num # string -> num",3,[Call(3,`ml-userbuf-input`)]);;
%to be placed in dml.ml%


exception io_failure of string;;


type stream_ident =  terminal | pipe of num | file of string;;

type stream_state = open | closed;;

type interactive = interactive of bool;;

type io_channel = io_channel of num | no_channel;;

type io_buffer = file_buffer of string		% the buffer %
    			      # num ref		% first free place %

               | pipe_buffer of string list ref % the buffer %
	       		      # num ref		% first char available
			      			  in the first string %
			      # num ref		% first free place 
			      			  in last string %
			      # num		% length of all strings %

               | no_buffer;;

type outstream = outstream of stream_ident
                            # stream_state ref
			    # io_buffer
			    # io_channel
               | broadcast_stream of outstream list;;

type instream = instream of stream_ident 
                          # stream_state ref 
	                  # interactive 
			  # io_buffer
			  # io_channel;;

let open_outfiles_list =
    ref ([] : (  string   		% file name %
               # io_buffer 		% associated buffer %
	       # io_channel		% number of LISP channel %
               # num ref 		% how many streams write to this file%
               # outstream list ref 	% list of these streams %
	      ) list);;

let open_infiles_list =
    ref ([] : (  string 		% file name %
               # io_channel 		% number of LISP channel %
               # num ref 		% how many streams read this file %
               # instream list ref	% list of these streams %
              ) list);;

let std_out = outstream (terminal, ref open, no_buffer, io_channel (-1));;

let std_in = instream (terminal,
		       ref open,
		       interactive true,
		       no_buffer,
		       io_channel (-1));;


let rem_assoc indic l = let p (s,_) = not (s = indic) in l := filter p !l;;
% Should it be in prelude ? %

let pbuf_str_ln, set_pipe_buffer_string_length =
    let length = ref 256 in
        (fun () -> !length),
	(fun n -> length := n);;
% length of the strings in the list used as buffer by a pipe %

let (open_in, inter_open_in) =
 let in_open str inter_flag =
    ((instream (file str,
               ref open,
	       interactive inter_flag,
	       no_buffer,		% buffers are in the Le_Lisp world %
	       open_instream str)
         handle system with
	      (`openi`,n) ->
                 if (num_of_obj n) = -2
                    then raise io_failure with `no channel available` 
		    else raise io_failure
	                             with `cannot open ` ^ str ^
				     ` error num : ` ^ (string_of_obj n)
           |  (s,x) -> raise io_failure
                         with `system error : ` ^ s ^ ` ` ^ (string_of_obj x))
    where open_instream = fun
        ``  -> raise io_failure with `missing filename`
      |  s  -> ((let (chan, x, _) = assoc s !open_infiles_list in
                   incr x ; chan)
               handle failure with
	       `find` -> let chan = io_channel (ml_open_in s) in
                             open_infiles_list := (s, chan, ref 1, ref[])
	       				          :: !open_infiles_list
                         ; chan
                | st  -> raise failure with st))
% IN_OPEN :
  Creates an instream from a file the name of which is the <str> parameter.
  The <inter_flag> parameter depends on which function called this one.
  It actually opens a channel from the file only if no one was already open.
  One should handle failure with `assoc`, but the function assoc fails with
  `find` !?!?
%
 in
     let in_open1 flag str =
       let i_str = in_open str flag in
           (let (_, _, li_str) = assoc str !open_infiles_list in
                li_str := i_str :: !li_str;
                i_str)
%
 Creates an instream from a file (using in_open), and adds it to the list
 of streams associated to the file. Having called in_open ensures that the
 file is in open_infiles_list.
%
     in
          (in_open1 false, in_open1 true)
 ;;

let close_infile (io_channel chan, _, ref li_str) =
    let close_instream (instream (_, status, _)) = status := closed in
        do_list close_instream li_str;
	ml_close chan;;
% Marks ALL instream associated with a file as closed and deletes the channel
  from this file. The parameter is what is associated with the file name in 
  open_infiles_list.
%

let (open_out, open_append) =
  let out_open add_flag str =
    	let open_err n =
                 if (num_of_obj n) = -2
                    then raise io_failure with `no channel available` 
	            else raise io_failure with `cannot open ` ^
	                     str ^ ` error num : ` ^ (string_of_obj n)
    in
    ((outstream (file str, ref open, open_outstream add_flag str)
% open_outstream will return a buffer and a channel %
	      handle system with
	      (`openo`,n) -> open_err n
    	    | (`opena`,n) -> open_err n
            |  (s,x) -> raise io_failure with `system error : `
		                                ^ s ^ ` ` ^ (string_of_obj x))
              
     where open_outstream flag =

      let ml_open_first_out str =
         ((close_infile (assoc str !open_infiles_list)
              handle failure with `find` -> obj_nil);
          rem_assoc str open_infiles_list;
          ml_open_out str) in
          % When opening the first outstream to a file, one has to delete
            this file before writing. One closes all the instreams which were
            associated with it (if any) and remove it of open_infiles_list. %

     fun  % open_outstream %
        ``  -> raise io_failure with `missing filename`
      |  s  -> ((let (buf, chan, x, _) = assoc s !open_outfiles_list in
		     % takes existing value if any %
                   incr x ; (buf, chan))
               handle failure with
	       `find` -> % no already open stream to this file %
	                 let open_fun = if flag then ml_open_add 
	                                        else ml_open_first_out  in
                             let buf, chan = file_buffer (make_string 256 ` `,
                                                          ref 1),
					     io_channel (open_fun s) in
                           open_outfiles_list := (s, buf, chan, ref 1, ref [])
	       					 :: !open_outfiles_list
                                ; (buf, chan)
                | st  -> raise failure with st))
                  % end of out_open and open_outstream %
  in
     let out_open1 flag str =
       let o_str = out_open flag str in
           (let (_, _, _, lo_str) = assoc str !open_outfiles_list in
                lo_str := o_str :: !lo_str;
                o_str)
      in
          (out_open1 false, out_open1 true)
;;

let new_pipe = let new_pipe_num = ref 0 in fun () ->
    let n = incr new_pipe_num and str_ln = pbuf_str_ln () in
      let pbuf = pipe_buffer (ref [make_string str_ln ` `],
                              ref 1,
                              ref 1,
			      str_ln) in
         instream (pipe n, ref open, interactive false, pbuf, no_channel),
         outstream (pipe n, ref open, pbuf, no_channel);;
% Creates a new buffer for a pipe, using the function pbuf_str_ln to get the
  length of the strings the buffer will use. Associates a pair of streams (one
  instream and one outstream) with this buffer.
%

let broadcast = let rec bdc = fun
    [] -> []
  | ((broadcast_stream l) :: ll) -> l @ bdc ll
  | (o_str :: ll) -> o_str :: bdc ll
in broadcast_stream o bdc;;
% constructs flat broadcast_stream, even if broadcast_streams are given in the
  list. This is necessary for the function output to work properly
%

let output =

 let out_simp = fun   % only defined on simple streams (not broadcast) %

  (outstream (_, ref closed, _, _)) -> raise io_failure with `closed`
              % failure in  "let write = output out_stream;;" %

| (outstream (pipe number, status, buff, _)) ->

   let rec ml_pipe_out (pipe_buffer (l, _, i_free, buf_str_ln) as buffer) s =
             % writes in the buffer %
    if !i_free = 0 then raise io_failure with `pipe broken` else (
    replace_string (last !l) s !i_free ;
    (let free = (length_string s) + !i_free in
        if free <= buf_str_ln then i_free := free
        else (l := !l @ [(make_string buf_str_ln ` `)];
              if free = (buf_str_ln + 1) then i_free := 1
              else (let string_end = (sub_string s
				                 (buf_str_ln + 2 - !i_free)
				                 (free - buf_str_ln - 1)) in
                        i_free := 1;
			ml_pipe_out buffer string_end))))
        % end of ml_pipe_out %

  in (fun    % value of out_simp with pipe argument %
          str -> case status of
      (ref closed) -> raise io_failure with `closed`
                  % stream closed after defining the writing function %
      | _ -> (ml_pipe_out buff str ; ()))

| (outstream (file name, status, buff, chan)) ->

  let rec ml_file_out ((file_buffer (str, i_free), io_channel chan) as buf_ch)
                      ostring =
                % buffer handling %
    replace_string str ostring !i_free;
    (let new_free = !i_free + length_string ostring in
        if new_free <= 256
           then i_free := new_free
	   else (let rest_begin = 258 - !i_free in
		     ml_output (chan, str);
		     i_free := 1;
		     ml_file_out buf_ch
		                 (sub_string ostring
				             rest_begin
					     (new_free - 257))))

in (fun   % value of out_simp with file parameter %
	str -> (ml_file_out (buff, chan) str ; ()
            handle system with (s,x) -> raise io_failure with 
                              `unable to output to ` ^ name ^
			      ` error : ` ^ s ^ ` ` ^ (string_of_obj x)
                  || failure with `find` -> raise io_failure with `closed`
                                  | s -> failwith s))
| (outstream (terminal, _, _, io_channel chan)) ->
        fun str -> ml_output (chan, str)

in fun
  (broadcast_stream lo_str) ->  (let lfl = map out_simp lo_str in
     fun str -> do_list (fun f -> f str) lfl)
| o_s -> out_simp o_s;;
% let gain efficiency when defining outputing function bounded with a stream.
%

let output_line o_stream ostring = output o_stream ostring;
                                   output o_stream (ascii 10);;
% Writes <ostring> followed by an end-of-line mark. %

let rec flush = fun
    (broadcast_stream l) -> do_list flush l
 |  (outstream (file _, ref open, file_buffer (str, i_free), io_channel chan))
      -> ml_output (chan, (sub_string str 1 (!i_free - 1)));
         i_free := 1;
	 ()
 |  _ -> ();;


let rec ml_pipe_in (pipe_buffer (l, i_deb, i_free, buf_str_ln) as b) n =
 (if length !l = 1
   then (let nchar = (let p_len = !i_free - !i_deb in
                       if p_len < n then p_len else n) in
          (let str = sub_string (hd !l) !i_deb nchar in
            (replace_string (hd !l)
                            (sub_string (hd !l)
                                        (!i_deb + nchar)
				        (buf_str_ln + 1 - (!i_deb + nchar)))
                            1 ;
             i_deb := 1 ;
	     i_free := !i_free - (!i_deb + nchar) + 1;
	     str)))
   else
     (if n < (buf_str_ln + 1 - !i_deb)
         then (let str = sub_string (hd !l) !i_deb n in
                  (i_deb := !i_deb + n ; str))
         else (let (fst_str :: rest) = !l in
               (let fst_str = sub_string fst_str
                                         !i_deb
					 (buf_str_ln + 1 - !i_deb) in
                  (i_deb := 1 ;
                   l := rest ;
		   fst_str ^ ml_pipe_in b (n - (length_string fst_str)))))));;
% Takes n characters in a pipe_buffer. If, after reading, the buffer uses only
  one string all remaining characters are at the beginning of the string. If
  more than one string remain, the first available character is in the first
  string and the last character in the last string.
%

let input = fun
    (instream (_, ref closed, _, _, _))
    	-> raise io_failure with `closed stream`
  | (instream (terminal, _, _, _, io_channel chan))
    	-> (fun n -> ml_input (chan, n)
		handle system with _ -> raise io_failure
			with `unable to input from terminal`)
  | (instream (pipe _, status, _, buffer, _))
    	-> (fun n -> if !status = closed then raise io_failure with `closed`
		     else ml_pipe_in buffer n)
  | (instream (file name, status, _, _, io_channel chan))
    	-> (fun n -> if !status = closed then raise io_failure with `closed`
		     else ml_input (chan, n)
		handle system with _ -> raise io_failure
			with `unable to input from file : ` ^ name)
;;
% Takes n characters in an instream (or all characters available if less than
  n). Files and terminal are handled in LISP file F-streams.l.
  Closed stream failure is handled when creating a specialised input function,
  and when inputing from the stream.
%

exception ml_eof of num;;

let buf_input = fun
    (instream (_, ref closed, _, _, _))
    	-> raise io_failure with `closed stream`
  | (instream (terminal, _, _, _, io_channel chan))
    	-> (fun s n -> 
		 if n > (length_string s) then failwith `too many chars`
                 else (let nb_c = ml_userbuf_input (chan, n, s) in
		         if n <> nb_c then raise ml_eof with nb_c else ())
		handle system with _ -> raise io_failure
			with `unable to input from terminal`)
  | (instream (pipe _, status, _, buffer, _))
    	-> raise io_failure with `not available`
  | (instream (file name, status, _, _, io_channel chan))
    	-> (fun s n -> 
		 if n > (length_string s) then failwith `too many chars`
                 else (let nb_c = ml_userbuf_input (chan, n, s) in
		         if n <> nb_c then raise ml_eof with nb_c else ())
		handle system with _ -> raise io_failure
			with `unable to input from file : ` ^ name)
;;

let input_line = 
  let rec ml_pipe_input_line 
    	  (pipe_buffer (ref (s1 :: l_s), ref i_deb, _,str_ln) as b) =
      let pos = scan_string s1 (ascii 10) i_deb in
          if pos = 0
             then ml_pipe_in b (str_ln - i_deb + 1)
                  ^ (if l_s = [] then `` else ml_pipe_input_line b)
             else ml_pipe_in b (pos - i_deb + 1)
% Takes characters in a pipe until reaching an end-of-line mark (this mark is
  returned at the end of the string). If no such mark is available, it returns
  all the characters in the pipe, without the end-of-line mark. %

in fun
    (instream (_, ref closed, _, _, _))
        ->  raise io_failure with `closed stream`
  | (instream (terminal, _, _, _, io_channel chan))
        -> (ml_input_line chan
		handle system with _ -> raise io_failure
			with `unable to input from terminal`)
  | (instream (pipe _, status, _, buffer, _))
    	-> if !status = closed then raise io_failure with `closed`
		     else ml_pipe_input_line buffer
  | (instream (file name, status, _, _, io_channel chan))
    	-> (if !status = closed then raise io_failure with `closed`
		     else ml_input_line chan
		handle system with _ -> raise io_failure
			with `unable to input from file : ` ^ name)
;;
% Takes characters in an instream until reaching an end-of-line mark (this
  mark is returned at the end of the string). If no such mark is available,
  it returns all the characters in the stream, without an end-of-line mark.
  Instreams from files or terminal are handled in LISP file F-streams.l.
%

let lookahead =
 let ml_pipe_lookahead 
     (pipe_buffer (ref (s1 :: l_s), ref i_deb, ref i_free, _)) =
        if (l_s = []) & (i_deb = i_free) then ``
        else sub_string s1 i_deb 1
 in fun
    (instream (_, ref closed, _, _, _))
        ->  raise io_failure with `closed stream`
  | (instream (terminal, _, _, _, io_channel chan))
        -> (ml_lookahead chan
		handle system with _ -> raise io_failure
			with `unable to lookahead from terminal`)
  | (instream (pipe _, status, _, buffer, _))
    	-> if !status = closed then raise io_failure with `closed`
	   else ml_pipe_lookahead buffer
  | (instream (file name, status, _, _, io_channel chan))
        -> if !status = closed then raise io_failure with `closed`
	   else ml_lookahead chan
		handle system with _ -> raise io_failure
			with `unable to lookahead from file : ` ^ name
;;
% Returns first char in an instream if any is available %

let end_of_stream i_str = ((lookahead i_str) = ``);;

let read = fun
    (instream (_, _, interactive false, _, _))
    	->  raise io_failure with `not interactive stream`
  | (instream (_, ref closed, _, _, _))
    	->  raise io_failure with `closed stream`
  | (instream (_, _, _, _, io_channel chan))  % always a chan since pipes are 
    						never interactive %
        -> (fun n ->
    if n < 0 then raise io_failure with `negative number of char`
    if n = 0 then ``
    else ml_read (chan,n)
  handle system with (s,x) -> raise io_failure with `unable to read` ^
				  ` error : ` ^ s ^ ` ` ^ (string_of_obj x));;
% Waits until <n> characters are available on an interactive instream.
  Uses no (terminal case) or few (file case) CPU time.
  Returns the <n> characters.
%

let read_line = fun
    (instream (_, _, interactive false, _, _))
    	->  raise io_failure with `not interactive stream`
  | (instream (_, ref closed, _, _, _))
    	->  raise io_failure with `closed stream`
  | (instream (_, _, _, _, io_channel chan))  % always a chan since pipes are 
    						never interactive %
        -> ml_read_line chan
  handle system with (s,x) -> raise io_failure with `unable to read` ^
				  ` error : ` ^ s ^ ` ` ^ (string_of_obj x);;
% Waits until an end-of-line mark is available on an interactive instream.
  Uses no (terminal case) or few (file case) CPU time.
  Returns the line WITHOUT the end-of-line mark.
%

let close_in = fun
    (instream (_, ref closed, _, _, _))
        -> raise io_failure with `stream already closed`
  | (instream (terminal, _, _, _, _))
        -> raise io_failure with `cannot close standard input`
  | (instream (pipe _, status, _, pipe_buffer (l, _, i_fr, _), _)) 
        -> l := [] ; i_fr := 0 ; status := closed ; ()
  | (instream (file name, status, _, _, _))
        ->  (let (io_channel chan, x, _) = assoc name !open_infiles_list in
              (if !x > 1
	        then (decr x ; obj_nil)
		else (rem_assoc name open_infiles_list;
		     ml_close chan));
	     status := closed;() 
    handle system with 
           (`close`,n) -> raise io_failure with `unable to close ` ^ name ^
				           ` error num : ` ^ (string_of_obj n)
       |   (s,x) -> raise io_failure with `system error ` ^ s ^
		                          ` ` ^ (string_of_obj x) );;
% Closes an instream. If it was associated with a file the channel remains
  open if another instream from this file exists. If it was associated with
  a pipe, the pipe is removed from open_pipes_list ; attempting to write
  to this pipe will cause a failure.
%

let all_close_infiles () =
    do_list (close_infile o snd) !open_infiles_list;
     open_infiles_list := [];
     ();;
% Closes all instream from files %

let rec close_out = 
  let broadcast_close_out o_str =
           (close_out o_str handle io_failure with _ -> ())
in fun
    (broadcast_stream lo_str)
        -> do_list broadcast_close_out lo_str ; ()
  | (outstream (_, ref closed, _, _))
        -> raise io_failure with `stream already closed`
  | (outstream (terminal, _, _, _))
        -> raise io_failure with `cannot close standard output`
  | (outstream (pipe _, status, _, _)) 
        -> status := closed ; ()
  | ((outstream (file name, status, _, io_channel chan)) as o_str)
        -> flush o_str ;
	   (let (_, _, x,_) = assoc name !open_outfiles_list in
             (if !x > 1
	        then (decr x ; obj_nil)
		else (rem_assoc name open_outfiles_list;
		     ml_close chan));
	     status := closed;
	     () )
    handle system with 
           (`close`,n) -> raise io_failure with `unable to close ` ^ name ^
				           ` error num : ` ^ (string_of_obj n)
       |   (s,x) -> raise io_failure with `system error ` ^ s ^
	                             ` ` ^  (string_of_obj x);;
% Closes an outstream. If it was associated with a file the channel remains
  open if another outstream to this file exists, in each case the buffer is
  written to the file. If it was associated with a pipe, the pipe is not
  removed from open_pipes_list, so that one can still read this pipe (if any
  still remains in it).
%


let all_close_outfiles () =
  let close_outfile (_, io_channel chan, _,ref lo_str) =
     % Closes all outstreams to a file and deletes the associated channel %
       let close_outstream (outstream (ident, status, _, _) as o_str) =
            % Marks an outstream as closed after writing its buffer to the
              file if needed %
           (case ident of (file _) -> flush o_str | _ -> ());
           status := closed
       in
        do_list close_outstream lo_str;
	ml_close chan
  in
     do_list (close_outfile o snd) !open_outfiles_list;
     open_outfiles_list := [];
     ();;
% Closes all outstreams associated with files %

