;*=====================================================================*/
;*    serrano/prgm/project/bigloo/runtime/Ieee/output.scm              */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Sun Jul  5 11:13:01 1992                          */
;*    Last change :  Tue Sep 30 10:25:23 2003 (serrano)                */
;*    -------------------------------------------------------------    */
;*    6.10.3 Output (page 31, r4)                                      */
;*    -------------------------------------------------------------    */
;*    This module is able to display object even if it is not          */
;*    properly initailzed. This is very important because with this    */
;*    means, error during the initialization time will be correctly    */
;*    prompted. In particular, we must be very carefull not to launch  */
;*    unexpected errors.                                               */
;*    -------------------------------------------------------------    */
;*    Source documentation:                                            */
;*       @path ../../manuals/body.texi@                                */
;*       @node Input And Output@                                       */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    Le module                                                        */
;*---------------------------------------------------------------------*/
(module __r4_output_6_10_3

   (import  __error
	    __bexit
	    __r4_ports_6_10_1
	    __bigloo)
   
   (use     __type
	    __tvector
	    __structure
	    __bexit
	    __object
	    __ucs2
	    __unicode
	    __date
	     
	    __r4_numbers_6_5_fixnum
	    __r4_numbers_6_5_flonum
	    __r4_numbers_6_5
	    __r4_characters_6_6
	    __r4_strings_6_7
	    __r4_vectors_6_8
	    __r4_equivalence_6_2
	    __r4_booleans_6_1
	    __r4_symbols_6_4
	    __r4_pairs_and_lists_6_3
	    __r4_control_features_6_9

	    __evenv)
     
   (extern  (macro output-string-port::bool (::obj)
		   "OUTPUT_STRING_PORTP")
	    (macro c-write-char::output-port (::uchar ::output-port)
		   "WRITE_CHAR")
	    (c-write_char::obj (::bchar ::output-port)
			       "write_char")
	    (display-char::obj (::bchar ::output-port)
			       "display_char")
	    (c-write_ucs2::obj (::bucs2 ::output-port)
			       "write_ucs2")
	    (display-ucs2::obj (::bucs2 ::output-port)
			       "display_ucs2")
	    (write-object::obj (::obj ::output-port)
			       "write_object")
	    (write-string::obj (::bstring ::bool ::output-port)
			       "write_string")
	    (display-string::obj (::bstring ::output-port)
				 "display_string")
	    (write-symbol::obj (::symbol ::output-port)
			       "write_symbol")
	    (display-symbol::obj (::symbol ::output-port)
				 "display_symbol")
	    (display-fixnum::obj (::blong ::output-port)
				 "display_fixnum")
	    (display-flonum::obj (::real ::output-port)
				 "display_flonum")
	    (ill-char-rep::obj (::uchar)
			       "ill_char_rep")
	    (write-utf8string::obj (::bstring ::output-port)
				   "write_utf8string")
	    (display-ucs2string::obj (::ucs2string ::output-port)
				     "display_ucs2string"))
    
   (java    (class foreign
	       (method static output-string-port::bool (::obj)
		       "OUTPUT_STRING_PORTP")
	       (method static c-write-char::uchar (::uchar ::output-port)
		       "WRITE_CHAR")
	       (method static c-write_char::obj (::bchar ::output-port)
		       "write_char")
	       (method static display-char::obj (::bchar ::output-port)
		       "display_char")
	       (method static c-write_ucs2::obj (::bucs2 ::output-port)
		       "write_ucs2")
	       (method static display-ucs2::obj (::bucs2 ::output-port)
		       "display_ucs2")
	       (method static write-object::obj (::obj ::output-port)
		       "write_object")
	       (method static write-string::obj (::bstring ::bool ::output-port)
		       "write_string")
	       (method static display-string::obj (::bstring ::output-port)
		       "display_string")
	       (method static write-symbol::obj (::symbol ::output-port)
		       "write_symbol")
	       (method static display-symbol::obj (::symbol ::output-port)
		       "display_symbol")
	       (method static display-fixnum::obj (::bint ::output-port)
		       "display_fixnum")
	       (method static display-flonum::obj (::real ::output-port)
		       "display_flonum")
	       (method static ill-char-rep::obj (::uchar)
		       "ill_char_rep")
	       (method static write-utf8string::obj (::bstring ::output-port)
		       "write_utf8string")
	       (method static display-ucs2string::obj (::ucs2string ::output-port)
		       "display_ucs2string")))
    
   (export  (set-write-length! ::long)
	    (get-write-length::long)
	    (newline . port)
	    (inline newline-1 ::output-port)
	    (write obj . port)
	    (write-2 obj ::output-port)
	    (display obj . port)
	    (display-2 obj ::output-port)  
	    (write-char ::uchar . port)
	    (inline write-char-2 ::uchar ::output-port)
	    (illegal-char-rep ::uchar) 
	    (display* . obj)
	    (write* . obj)
	    (print . obj)
	    (fprint ::output-port . obj)
	    (format ::bstring . obj)
	    (printf ::bstring . obj)
	    (fprintf ::output-port ::bstring . obj)
	    (set-printer! ::procedure)
	    (current-printer::procedure)
	    (native-printer::procedure))

   (pragma  (output-string-port nesting args-safe)
	    (c-write-char nesting)))
   
;*---------------------------------------------------------------------*/
;*    *max-length-write* ...                                           */
;*    -------------------------------------------------------------    */
;*    This variable contains the number of recursive calls that are    */
;*    accepted during a write.                                         */
;*---------------------------------------------------------------------*/
(define *max-length-write* -1)

;*---------------------------------------------------------------------*/
;*    *displayed*                                                      */
;*---------------------------------------------------------------------*/
(define *displayed* 0)

;*---------------------------------------------------------------------*/
;*    set-write-length ...                                             */
;*---------------------------------------------------------------------*/
(define (set-write-length! length)
   (set! *max-length-write* length))

;*---------------------------------------------------------------------*/
;*    get-write-length ...                                             */
;*---------------------------------------------------------------------*/
(define (get-write-length)
   (if (not (fixnum? *max-length-write*))
       -1
       *max-length-write*))

;*---------------------------------------------------------------------*/
;*    newline ...                                                      */
;*---------------------------------------------------------------------*/
(define (newline . port)
   (let ((port (match-case port
		  (()
		   (current-output-port))
		  ((?-)
		   (car port))
		  (else
		   (error "newline"
			  "wrong number of optional arguments"
			  port)))))
      (newline-1 port)))

;*---------------------------------------------------------------------*/
;*    newline-1 ...                                                    */
;*---------------------------------------------------------------------*/
(define-inline (newline-1 port::output-port)
   (c-write-char #\Newline port))

;*---------------------------------------------------------------------*/
;*    display ...                                                      */
;*---------------------------------------------------------------------*/
(define (display obj . port)
   (let ((port (match-case port
		  (()
		   (current-output-port))
		  ((?-)
		   (car port))
		  (else
		   (error "display"
			  "wrong number of optional arguments"
			  port)))))
      (display-2 obj port)))

;*---------------------------------------------------------------------*/
;*    display-2 ...                                                    */
;*---------------------------------------------------------------------*/
(define (display-2 obj port::output-port)
   (set! *displayed* 0)
   (if (or (eq? *current-printer* native-display)
	   (not (procedure? *current-printer*)))
       (write/display obj port #t)
       (try (*current-printer* obj port)
	    (lambda (esc proc mes obj)
	       (set-printer! (native-printer))
	       (error proc mes obj)))))
   
;*---------------------------------------------------------------------*/
;*    native-display ...                                               */
;*---------------------------------------------------------------------*/
(define (native-display obj . port)
   (set! *displayed* 0)
   (write/display obj
		  (if (or (not (pair? port)) (not (output-port? (car port))))
		      (current-output-port)
		      (car port))
		  #t))

;*---------------------------------------------------------------------*/
;*    write ...                                                        */
;*---------------------------------------------------------------------*/
(define (write obj . port)
   (let ((port (match-case port
		  (()
		   (current-output-port))
		  ((?-)
		   (car port))
		  (else
		   (error "write"
			  "wrong number of optional arguments"
			  port)))))
      (write-2 obj port)))

;*---------------------------------------------------------------------*/
;*    write-2 ...                                                      */
;*---------------------------------------------------------------------*/
(define (write-2 obj port::output-port)
   (set! *displayed* 0)
   (write/display obj port #f))

;*---------------------------------------------------------------------*/
;*    write-char ...                                                   */
;*---------------------------------------------------------------------*/
(define (write-char char . port)
   (let ((port (match-case port
		  (()
		   (current-output-port))
		  ((?-)
		   (car port))
		  (else
		   (error "write"
			  "wrong number of optional arguments"
			  port)))))
      (write-char-2 char port)))

;*---------------------------------------------------------------------*/
;*    write-char-2 ...                                                 */
;*---------------------------------------------------------------------*/
(define-inline (write-char-2 char::uchar port::output-port)
   (c-write-char char port))

;*---------------------------------------------------------------------*/
;*    illegal-char-rep ...                                             */
;*---------------------------------------------------------------------*/
(define (illegal-char-rep char)
   (if (or (char-alphabetic? char) (char-numeric? char))
       char
       (case char
	  ((#\Newline)
	   "#\Newline")
	  ((#\Return)
	   "#\Return")
	  ((#\Space)
	   "#\Space")
	  ((#\Tab)
	   "#\Tab")
	  (else
	   (let ((i (char->integer char)))
	      (if (<fx i (char->integer #\!))
		  (ill-char-rep char)
		  char))))))

;*---------------------------------------------------------------------*/
;*    write/display ...                                                */
;*    -------------------------------------------------------------    */
;*    As we can't be sure that this module is initialized before       */
;*    used (for example when an error occurs during module             */
;*    intialization process), we can't use symbol to set               */
;*    flag. So if flag is equal to #t it means that                    */
;*    `write-display' is used to display and if flags is equal         */
;*    to #f it writes.                                                 */
;*---------------------------------------------------------------------*/
(define (write/display obj port flag)
   (set! *displayed* (+fx 1 *displayed*))
   (cond
      ((and (fixnum? *max-length-write*)
	    (>fx *max-length-write* 0)
	    (>=fx *displayed* *max-length-write*)) 
       (display-string "..." port))
      ((fixnum? obj)
       (display-fixnum obj port))
      ((symbol? obj) 
       (if flag
	   (display-symbol obj port)
	   (write-symbol obj port)))
      ((string? obj) 
       (if flag
	   (display-string obj port)
	   (write-string (string-for-read obj)
			 *bigloo-strict-r5rs-strings*
			 port)))
      ((pair? obj)
       (write/display-pair obj port flag))
      ((class? obj)
       (write/display-class obj port flag))
      ((vector? obj)
       (write/display-vector obj port flag))
      ((char? obj)
       (if flag 
	   (display-char obj port)
	   (c-write_char obj port)))
      ((ucs2? obj)
       (if flag 
	   (display-ucs2 obj port)
	   (c-write_ucs2 obj port)))
      ((flonum? obj)
       (display-flonum obj port))
      ((cell? obj)
       (write/display-cell obj port flag))
      ((struct? obj)
       (write/display-structure obj port flag))
      ((tvector? obj)
       (write/display-tvector obj port flag))
      ((object? obj)
       (write/display-object obj port flag))
      ((ucs2-string? obj)
       (if flag
	   (display-ucs2string obj port) 
	   (write-utf8string (string-for-read (ucs2-string->utf8-string obj))
			     port)))
      ((opaque? obj)
       (display-string "#<opaque>" port))
      ((date? obj)
       (if flag
	   (display-string (date->string obj) port)
	   (begin
 	      (display-string "#<date:" port)
	      (display-string (date->string obj) port)
	      (display-string ">" port))))
      (else
       (write-object obj port)))
   #unspecified)

;*---------------------------------------------------------------------*/
;*    write/display-class ...                                          */
;*---------------------------------------------------------------------*/
(define (write/display-class obj port flag)
   (display-string "#<class:" port)
   (display-symbol (class-name obj) port)
   (display-string ">" port))
   
;*---------------------------------------------------------------------*/
;*    write/display-cell ...                                           */
;*---------------------------------------------------------------------*/
(define (write/display-cell obj port flag)
   (display-string "#<cell:" port)
   (write/display (cell-ref obj) port flag)
   (display-string ">" port))

;*---------------------------------------------------------------------*/
;*    write/display-structure ...                                      */
;*---------------------------------------------------------------------*/
(define (write/display-structure obj port flag)
   (c-write-char #\# port)
   (c-write-char #\{ port)
   (write-object (struct-key obj) port)
   (if (=fx 0 (struct-length obj))
       (c-write-char #\} port)
       (let ((len (-fx (struct-length obj) 1)))
	  (c-write-char #\space port)
	  (let loop ((i 0))
	     (cond
		((and (fixnum? *max-length-write*)
		      (>fx *max-length-write* 0)
		      (>fx *displayed* *max-length-write*))
		 (write-object "... }" port))
		((=fx i len)
		 (write/display (struct-ref obj i) port flag)
		 (c-write-char #\} port))
		(else
		 (write/display (struct-ref obj i) port flag)
		 (c-write-char #\space port)
		 (loop (+fx 1 i))))))))

;*---------------------------------------------------------------------*/
;*    write/display-vector ...                                         */
;*---------------------------------------------------------------------*/
(define (write/display-vector obj port flag)
   (c-write-char #\# port)
   (let ((tag (vector-tag obj)))
      (if (>fx tag 0)
	  (begin
	     (if (>=fx tag 100)
		 (write-object tag port)
		 (begin
		    (c-write-char #\0 port)
		    (if (>=fx tag 10)
			(write-object tag port)
			(begin
			   (c-write-char #\0 port)
			   (write-object tag port))))))))
   (c-write-char #\( port)
   (if (=fx 0 (vector-length obj))
       (c-write-char #\) port)
       (let ((len (-fx (vector-length obj) 1)))
	  (let loop ((i 0))
	     (cond
		((and (fixnum? *max-length-write*)
		      (>fx *max-length-write* 0)
		      (>=fx *displayed* *max-length-write*))
		 (write-object "... )" port))
		((=fx i len)
		 (write/display (vector-ref obj i) port flag)
		 (c-write-char #\) port))
		(else
		 (write/display (vector-ref obj i) port flag)
		 (c-write-char #\space port)
		 (loop (+fx 1 i))))))))
 
;*---------------------------------------------------------------------*/
;*    write/display-tvector ...                                        */
;*---------------------------------------------------------------------*/
(define (write/display-tvector tvec port flag)
   (let ((tvector-ref (tvector-ref tvec))
	 (id          (tvector-id tvec)))
      (c-write-char #\# port)
      (write-object id port)
      (c-write-char #\( port)
      (if (not tvector-ref)
	  (begin
	     (write-object "...)" port)
	     tvec)
	  (begin
	     (if (=fx 0 (tvector-length tvec))
		 (c-write-char #\) port)
		 (let ((len (-fx (tvector-length tvec) 1)))
		    (let loop ((i 0))
		       (cond
			  ((and (fixnum? *max-length-write*)
				(>fx *max-length-write* 0)
				(>=fx *displayed* *max-length-write*))
			   (write-object "... )" port))
			  ((=fx i len)
			   (write/display (tvector-ref tvec i)
					  port
					  flag)
			   (c-write-char #\) port))
			  (else
			   (write/display (tvector-ref tvec i)
					  port
					  flag)
			   (c-write-char #\space port)
			   (loop (+fx 1 i)))))))))))

;*---------------------------------------------------------------------*/
;*    write/display-object ...                                         */
;*---------------------------------------------------------------------*/
(define (write/display-object obj port flag)
   (if flag
       (object-display obj port)
       (object-write obj port)))

;*---------------------------------------------------------------------*/
;*    write/display-pair ...                                           */
;*---------------------------------------------------------------------*/
(define (write/display-pair obj port flag)
   (c-write-char #\( port)
   (let loop ((l obj))
      (cond
	 ((null? (cdr l))
	  (write/display (car l) port flag)
	  (c-write-char #\) port))
	 ((and (fixnum? *max-length-write*)
	       (>fx *max-length-write* 0)
	       (>=fx *displayed* *max-length-write*))
	  (write-object " . ... )" port))
	 ((not (pair? (cdr l)))
	  (write/display (car l) port flag)
	  (c-write-char #\space port)
	  (c-write-char #\. port)
	  (c-write-char #\space port)
	  (write/display (cdr l) port flag)
	  (c-write-char #\) port))
	 (else
	  (write/display (car l) port flag)
	  (c-write-char #\space port)
	  (loop (cdr l))))))
 
;*---------------------------------------------------------------------*/
;*    print ...                                                        */
;*---------------------------------------------------------------------*/
(define (print . obj)
   (set! *displayed* 0)
   (let ((port (current-output-port)))
      (let loop ((l   obj)
		 (res '()))
	 (if (null? l)
	     (begin
		(c-write-char #\Newline port)
		res)
	     (let ((v (car l)))
		(write/display v port #t)
		(loop (cdr l) v))))))

;*---------------------------------------------------------------------*/
;*    display* ...                                                     */
;*---------------------------------------------------------------------*/
(define (display* . obj)
   (set! *displayed* 0)
   (let ((port (current-output-port)))
      (let loop ((l obj))
	 (if (null? l)
	     #unspecified
	     (let ((v (car l)))
		(display (car l) port)
		(loop (cdr l)))))))

;*---------------------------------------------------------------------*/
;*    write* ...                                                       */
;*---------------------------------------------------------------------*/
(define (write* . obj)
   (set! *displayed* 0)
   (let ((port (current-output-port)))
      (let loop ((l obj))
	 (if (null? l)
	     #unspecified
	     (let ((v (car l)))
		(write/display (car l) port #f)
		(loop (cdr l)))))))

;*---------------------------------------------------------------------*/
;*    fprint ...                                                       */
;*---------------------------------------------------------------------*/
(define (fprint port . obj)
   (set! *displayed* 0)
   (let loop ((l    obj)
	      (res '()))
      (if (null? l)
	  (begin
	     (c-write-char #\Newline port)
	     res)
	  (let ((v (car l)))
	     (write/display (car l) port #t)
	     (loop (cdr l) v)))))

;*---------------------------------------------------------------------*/
;*    xprintf ...                                                      */
;*---------------------------------------------------------------------*/
(define (xprintf procname p::output-port fmt::bstring objs::pair-nil)
   (let ((len (string-length fmt)))
      (let loop ((i 0)
		 (os objs))
	 (define (next os fmt)
	    (if (null? os)
		(error procname "Insufficient number of arguments" fmt)
		(car os)))
	 (define (print-radix radix num)
	    (if (not (number? num))
		(error procname "Illegal number" num)
		(display (number->string num radix) p)))
	 (if (<fx i len)
	     (let ((c (string-ref fmt i)))
		(if (char=? c #\~)
		    (if (=fx i (-fx len 1))
			(error procname
			       "Tag not allowd here"
			       (substring fmt i len))
			(let ((f (string-ref fmt (+fx i 1))))
			   (case f
			      ((#\a #\A)
			       (display (next os f) p)
			       (loop (+fx i 2) (cdr os)))
			      ((#\s #\S)
			       (write (next os f) p)
			       (loop (+fx i 2) (cdr os)))
			      ((#\v #\V)
			       (display (next os f) p)
			       (newline p)
			       (loop (+fx i 2) (cdr os)))
			      ((#\c #\C)
			       (let ((o (next os f)))
				  (if (not (char? o))
				      (error procname "Illegal char" o)
				      (begin
					 (write-char o p)
					 (loop (+fx i 2) (cdr os))))))
			      ((#\x #\X)
			       (print-radix 16 (next os f))
			       (loop (+fx i 2) (cdr os)))
			      ((#\o #\O)
			       (print-radix 8 (next os f))
			       (loop (+fx i 2) (cdr os)))
			      ((#\b #\B)
			       (print-radix 2 (next os f))
			       (loop (+fx i 2) (cdr os)))
			      ((#\% #\n)
			       (newline p)
			       (loop (+fx i 2) os))
			      ((#\r)
			       (write-char #\return p)
			       (loop (+fx i 2) os))
			      ((#\~)
			       (write-char #\~ p)
			       (loop (+fx i 2) os))
			      (else
			       (error procname "Illegal tag" f)))))
		    (begin
		       (write-char c p)
		       (loop (+fx i 1) os))))))))
			 
;*---------------------------------------------------------------------*/
;*    format ...                                                       */
;*---------------------------------------------------------------------*/
(define (format fmt . obj)
   (let ((p (open-output-string)))
      (xprintf 'format p fmt obj)
      (close-output-port p)))

;*---------------------------------------------------------------------*/
;*    printf ...                                                       */
;*---------------------------------------------------------------------*/
(define (printf fmt . obj)
   (xprintf 'printf (current-output-port) fmt obj))

;*---------------------------------------------------------------------*/
;*    fprintf ...                                                      */
;*---------------------------------------------------------------------*/
(define (fprintf port fmt . obj)
   (xprintf 'fprintf port fmt obj))

;*---------------------------------------------------------------------*/
;*    *current-printer* ...                                            */
;*    -------------------------------------------------------------    */
;*    On est oblige de faire l'affectation de `*current-printer*'      */
;*    en deux fois car sinon, a cause des optims, on n'aura pas        */
;*    eq? entre `native-printer' et `*current-printer*' !              */
;*---------------------------------------------------------------------*/
(define *current-printer* #unspecified)
(set! *current-printer* native-display)

;*---------------------------------------------------------------------*/
;*    set-printer! ...                                                 */
;*---------------------------------------------------------------------*/
(define (set-printer! f)
   (set! *current-printer* f))

;*---------------------------------------------------------------------*/
;*    current-printer ...                                              */
;*---------------------------------------------------------------------*/
(define (current-printer)
   *current-printer*)

;*---------------------------------------------------------------------*/
;*    native-printer ...                                               */
;*---------------------------------------------------------------------*/
(define (native-printer)
   native-display)


