/*=====================================================================*/
/*    serrano/prgm/project/bigloo/runtime/Clib/cwriter.c               */
/*    -------------------------------------------------------------    */
/*    Author      :  Manuel Serrano                                    */
/*    Creation    :  Tue Dec 17 09:44:20 1991                          */
/*    Last change :  Fri Nov 14 21:30:15 2003 (serrano)                */
/*    -------------------------------------------------------------    */
/*    Object (that have to be non recursives) printing.                */
/*=====================================================================*/
#include <stdio.h>
#include <string.h>
#include <ctype.h>
#include <bigloo.h>

/*---------------------------------------------------------------------*/
/*    Les recuperations externes                                       */
/*---------------------------------------------------------------------*/
extern obj_t c_constant_string_to_string( char *c_string );
extern obj_t write_object( obj_t, obj_t );
extern obj_t write_ucs2( obj_t, obj_t );
extern obj_t display_ucs2string( obj_t, obj_t );
extern obj_t real_to_string( double );
extern obj_t strport_grow( obj_t );
extern bool_t symbol_case_sensitivep( obj_t );
extern obj_t create_string_for_read( obj_t, int );
extern obj_t llong_to_string( BGL_LONGLONG_T x, long radix );

/*---------------------------------------------------------------------*/
/*    Les noms des caracateres                                         */
/*---------------------------------------------------------------------*/
static char *char_name[] = {
   "","","","","","","","",
   "",  "tab", "newline", "", "", "return", "", "",
   "", "","","","","","","",
   "", "", "","","", "", "", "",
   "space", "!", "\"","#","$","%","&","'",
   "(", ")", "*", "+", ",", "-", ".", "/",
   "0", "1", "2", "3", "4", "5", "6", "7",
   "8", "9", ":", ";", "<", "=", ">", "?",
   "@", "A", "B", "C", "D", "E", "F", "G",
   "H", "I", "J", "K", "L", "M", "N", "O",
   "P", "Q", "R", "S", "T", "U", "V", "W",
   "X", "Y", "Z", "[", "\\", "]", "^", "_",
   "`", "a", "b", "c", "d", "e", "f", "g",
   "h", "i", "j", "k", "l", "m", "n", "o",
   "p", "q", "r", "s", "t", "u", "v", "w",
   "x", "y", "z", "{", "|", "}", "~", ""
};


/*---------------------------------------------------------------------*/
/*    char                                                             */
/*    strputc ...                                                      */
/*---------------------------------------------------------------------*/
BGL_RUNTIME_DEF
char
strputc( char c, obj_t p )
{
   long offset;
   
   if( END_OF_STRING_PORTP( p ) )
      strport_grow( p );

   offset = OUTPUT_STRING_PORT( p ).offset;

   OUTPUT_STRING_PORT( p ).buffer[ offset ] = c;
   OUTPUT_STRING_PORT( p ).offset = offset + 1;

   return c;
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    lstrputs ...                                                     */
/*---------------------------------------------------------------------*/
obj_t
lstrputs( char *s, obj_t p, long len )
{
   long offset;
   
   offset = OUTPUT_STRING_PORT( p ).offset;

   while((OUTPUT_STRING_PORT( p ).offset+len) > OUTPUT_STRING_PORT( p ).size)
      strport_grow( p );

   memcpy( &(OUTPUT_STRING_PORT(p).buffer[offset] ), s, len);

   OUTPUT_STRING_PORT( p ).offset = offset + len;

   return p;
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    strputs ...                                                      */
/*---------------------------------------------------------------------*/
obj_t
strputs( char *s, obj_t p )
{
   return lstrputs( s, p, (int)strlen( s ) );
}
   
/*---------------------------------------------------------------------*/
/*    We catch the `escape_char_found' variable from Clib/cstring.c    */
/*---------------------------------------------------------------------*/
extern int escape_char_found;

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    display_string ...                                               */
/*---------------------------------------------------------------------*/
BGL_RUNTIME_DEF
obj_t
display_string( obj_t o, obj_t port )
{
   if( OUTPUT_STRING_PORTP( port ) )
      lstrputs( (char *)BSTRING_TO_STRING( o ),
	        port,
	        STRING_LENGTH( o ) );
   else
   {
      FILE *fout = OUTPUT_PORT( port ).file;
      long  len  = STRING_LENGTH( o );
      char *aux  = &STRING_REF( o, 0 );
      
      fwrite( aux, 1, len, fout );
   }
   
   return o;
}

/*---------------------------------------------------------------------*/
/*    write_string ...                                                 */
/*---------------------------------------------------------------------*/
obj_t
write_string( obj_t string, bool_t r5rs_string, obj_t port )
{
   char *aux = (char *)BSTRING_TO_STRING( string );
   long len  = STRING_LENGTH( string );
   
   if( OUTPUT_STRING_PORTP( port ) )
   {
      if( r5rs_string && escape_char_found )
         strputc( '#', port );

      strputc( '"', port );
      lstrputs( aux, port,len );
      strputc( '"', port );
   }
   else
   {
      FILE *fout = OUTPUT_PORT( port ).file;

      if( r5rs_string && escape_char_found )
         fputc( '#', fout );
   
      fputc( '"', fout );
      fwrite( aux, 1, len, fout );
      fputc( '"', fout );
      return string;
   }

   return string;
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    display_symbol ...                                               */
/*---------------------------------------------------------------------*/
BGL_RUNTIME_DEF
obj_t
display_symbol( obj_t o, obj_t port )
{
   if( OUTPUT_STRING_PORTP( port ) )
      strputs( (char *)BSTRING_TO_STRING( SYMBOL( o ).string ), port );
   else
   {
      FILE *fout = OUTPUT_PORT( port ).file;
                        
      fputs( (char *)BSTRING_TO_STRING( SYMBOL( o ).string ), fout );
   }
                     
   return o;
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    write_symbol ...                                                 */
/*---------------------------------------------------------------------*/
obj_t
write_symbol( obj_t o, obj_t port )
{
   if( !symbol_case_sensitivep( o ) )
      return display_symbol( o, port );
   else
   {
      obj_t str = create_string_for_read( SYMBOL( o ).string, 1 );

      if( OUTPUT_STRING_PORTP( port ) )
      {
	 strputs( "|", port );
	 strputs( (char *)BSTRING_TO_STRING( str ), port );
	 strputs( "|", port );
      }
      else
      {
	 FILE *fout = OUTPUT_PORT( port ).file;

	 fputs( "|", fout );
	 fputs( (char *)BSTRING_TO_STRING( str ), fout );
	 fputs( "|", fout );
      }
                     
      return o;
      
   }
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    display_fixnum ...                                               */
/*---------------------------------------------------------------------*/
BGL_RUNTIME_DEF
obj_t
display_fixnum( obj_t o, obj_t port )
{
   if( OUTPUT_STRING_PORTP( port ) )
   {
      char new[ 100 ];
      
      sprintf( new, "%ld", CINT( o ) );
      strputs( new, port );
   }
   else
   {
      FILE *fout = OUTPUT_PORT( port ).file;
      
      fprintf( fout, "%ld", CINT( o ) );
   }
   
   return o;
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    display_flonum ...                                               */
/*    -------------------------------------------------------------    */
/*    Many thanks to Raj Manandhar <raj@droid.msfc.nasa.gov> for       */
/*    providing this code.                                             */
/*---------------------------------------------------------------------*/
obj_t
display_flonum( obj_t o, obj_t port )
{
   char *new = BSTRING_TO_STRING( real_to_string( REAL( o ).real ) );

   if( OUTPUT_STRING_PORTP( port ) )
      strputs( new, port );
   else
   {
      FILE *fout = OUTPUT_PORT( port ).file;

      fputs( new, fout );
   }
   return o;
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    display_char ...                                                 */
/*---------------------------------------------------------------------*/
BGL_RUNTIME_DEF
obj_t
display_char( obj_t o, obj_t port )
{
   if( OUTPUT_STRING_PORTP( port ) )
      strputc( CCHAR( o ), port );
   else
   {
      FILE *fout = OUTPUT_PORT( port ).file;
         
      fputc( CCHAR( o ), fout );
   }
      
   return o;
}

/*---------------------------------------------------------------------*/
/*    write_char ...                                                   */
/*---------------------------------------------------------------------*/
obj_t
write_char( obj_t c, obj_t port )
{
   int  cc = CCHAR( c );
   
   if( OUTPUT_STRING_PORTP( port ) )
   {
      if( (cc > 0) && (cc < 128) && (char_name[ cc ][ 0 ]) )
      {
      
         lstrputs( "#\\", port, 2 );
         strputs( char_name[ cc ], port );
      }
      else
      {
         char aux[ 10 ];
         
         sprintf( aux, "#a%03d", (unsigned char)(cc) );
         strputs( aux, port );
      }
   }
   else
   {
      FILE *f = OUTPUT_PORT( port ).file;
   
      if( (cc > 0) && (cc < 128) && (char_name[ cc ][ 0 ]) )
         fprintf( f, "#\\%s", char_name[ CCHAR( c ) ] );
      else
         fprintf( f, "#a%03d", (unsigned char)(cc) );
   }
   return c;
}

/*---------------------------------------------------------------------*/
/*    ill_char_rep ...                                                 */
/*---------------------------------------------------------------------*/
obj_t
ill_char_rep( unsigned char c )
{
   char aux[ 10 ];

   sprintf( aux, "#a%03d", c );

   return c_constant_string_to_string( aux );
}

/*---------------------------------------------------------------------*/
/*    obj_t                                                            */
/*    write_object ...                                                 */
/*---------------------------------------------------------------------*/
obj_t
write_object( obj_t o, obj_t port ) 
{
   if( INTEGERP( o ) )
      return display_fixnum( o, port );
   
   if( CHARP( o ) )
      return display_char( o, port );

   if( UCS2P( o ) )
      return write_ucs2( o, port );

#if defined( TAG_STRING )
   if( STRINGP( o ) )
      return display_string( o, port );
#endif  
      
#if defined( TAG_REAL )
   if( REALP( o ) )
      return display_flonum( o, port );   
#endif

   switch( (long)o )
   {
    case (long)BNIL :
            if( OUTPUT_STRING_PORTP( port ) )
	       lstrputs( "()", port, 2 );
            else
            {
               FILE *fout = OUTPUT_PORT( port ).file;
               
               fputs( "()", fout );
            }

            return o;

    case (long)BUNSPEC :
            if( OUTPUT_STRING_PORTP( port ) )
	       lstrputs( "#unspecified", port, 12 );
            else
            {
               FILE *fout = OUTPUT_PORT( port ).file;
               
	       fputs( "#unspecified", fout );
            }
         
            return o;
    
    case (long)BFALSE :
            if( OUTPUT_STRING_PORTP( port ) )
	       lstrputs( "#f", port, 2 );
            else
            {
               FILE *fout = OUTPUT_PORT( port ).file;

               fputs( "#f", fout );
            }

            return o;
    
    case (long)BTRUE :
            if( OUTPUT_STRING_PORTP( port ) )
	       lstrputs( "#t", port, 2 );
            else
            {
               FILE *fout = OUTPUT_PORT( port ).file;

               fputs( "#t", fout );
            }

            return o;

    case (long)BEOF :
            if( OUTPUT_STRING_PORTP( port ) )
	       lstrputs( "#eof-object", port, 11 );
            else
            {
               FILE *fout = OUTPUT_PORT( port ).file;
               
	       fputs( "#eof-object", fout );
            }
         
            return o;

      case (long)BOPTIONAL :
            if( OUTPUT_STRING_PORTP( port ) )
	       lstrputs( "#!optional", port, 10 );
            else
            {
               FILE *fout = OUTPUT_PORT( port ).file; 
               
	       fputs( "#!optional", fout );
            }
         
            return o;

      case (long)BREST :
            if( OUTPUT_STRING_PORTP( port ) )
	       lstrputs( "#!rest", port, 6 );
            else
            {
               FILE *fout = OUTPUT_PORT( port ).file;
               
	       fputs( "#!rest", fout );
            }
         
            return o;

      case (long)BKEY :
            if( OUTPUT_STRING_PORTP( port ) )
	       lstrputs( "#!key", port, 5 );
            else
            {
               FILE *fout = OUTPUT_PORT( port ).file;
               
	       fputs( "#!key", fout );
            }
         
            return o;

	 
    default :
            if( CNSTP( o ) )
            {
               if( OUTPUT_STRING_PORTP( port ) )
               {
                  char aux[ 7 ];
               
                  sprintf( aux, "#<%04x>", (int)CCNST( o ) );
                  lstrputs( aux, port, 7 );
               
               }
               else
               {
                  FILE *fout = OUTPUT_PORT( port ).file;
               
                  fprintf( fout, "#<%04x>", (int)CCNST( o ) );
               }
               
               return o;
            }
                
            if( !POINTERP( o ) )
            {
               if( OUTPUT_STRING_PORTP( port ) )
               {
                  char aux[ 16 ];
               
                  sprintf( aux, "#<???:%08lx>", (unsigned long)o );
                  strputs( aux, port );
               }
               else
               {
                  FILE *fout = OUTPUT_PORT( port ).file;
                  
                  fprintf( fout, "#<???:%08lx>", (unsigned long)o );
               }
               
               return o;
            }
	    else 
	    switch( TYPE( o ) )
	    {
#if( !defined( TAG_STRING ) )
               case STRING_TYPE :
	             return display_string( o, port );
#endif

	       case UCS2_STRING_TYPE:
		     return display_ucs2string( o, port );
		     
	       case SYMBOL_TYPE :
		     return display_symbol( o, port );
		     
	       case KEYWORD_TYPE :
                     if( OUTPUT_STRING_PORTP( port ) )
		        strputs( (char *)BSTRING_TO_STRING( KEYWORD( o ).string ),
				 port );
                     else
                     {
                        FILE *fout = OUTPUT_PORT( port ).file;

			fputs( (char *)BSTRING_TO_STRING( KEYWORD( o ).string ),
			       fout );
                     }
                     
		     return o;

#if( !defined( TAG_REAL ) )
	       case REAL_TYPE :
	             return display_flonum( o, port );
#endif
                        
	       case PROCEDURE_TYPE :
                     if( OUTPUT_STRING_PORTP( port ) )
                     {
                        char new[ 100 ];
                  
                        sprintf( new, "#<procedure:%lx.%ld>",
				 VA_PROCEDUREP( o ) ?
				 (unsigned long)PROCEDURE_VA_ENTRY( o ) :
				 (unsigned long)PROCEDURE_ENTRY( o ),
                                 (long)PROCEDURE( o ).arity );
                        strputs( new, port );
                     }
                     else
                     {
                        FILE *fout = OUTPUT_PORT( port ).file;
                        
                        fprintf( fout, "#<procedure:%lx.%ld>",
				 VA_PROCEDUREP( o ) ?
				 (unsigned long)PROCEDURE_VA_ENTRY( o ) :
				 (unsigned long)PROCEDURE_ENTRY( o ),
				 (long)PROCEDURE( o ).arity );
                     }
                     
                     return o;
        
	       case OUTPUT_PORT_TYPE :
                     if( OUTPUT_STRING_PORTP( port ) )
                     {
                        char new[ 100 ];
                        
			sprintf( new, "#<output_port:%s>",
				 OUTPUT_PORT( o ).name ); 
                        strputs( new, port );
                     }
                     else
                     {
                        FILE *fout = OUTPUT_PORT( port ).file;
                     
                        fprintf( fout, "#<output_port:%s>",
                                 OUTPUT_PORT( o ).name );
                     }
                        
                     return o;
                  
	       case OUTPUT_STRING_PORT_TYPE :
                     if( OUTPUT_STRING_PORTP( port ) )
		        lstrputs( "#<output_string_port>", port, 21 );
                     else
                     {
                        FILE *fout = OUTPUT_PORT( port ).file;
                        
                        fputs( "#<output_string_port>", fout );
                     }
                        
                     return o;
                  
	       case INPUT_PORT_TYPE : 
                     if( OUTPUT_STRING_PORTP( port ) )
                     {
                        char new[ 500 ];
                        
			sprintf( new, "#<input_port:%s.%ld>",
				 INPUT_PORT( o ).name,
				 (long)INPUT_PORT( o ).bufsiz );
                        strputs( new, port );
                     } 
                     else
                     {
                        FILE *fout = OUTPUT_PORT( port ).file;
                        
                        fprintf( fout, "#<input_port:%s.%ld>",
                                 INPUT_PORT( o ).name,
                                 (long)INPUT_PORT( o ).bufsiz );

                     }
                     
		     return o;
      
	       case BINARY_PORT_TYPE : 
                     if( OUTPUT_STRING_PORTP( port ) )
                     {
                        char new[ 500 ];
                        
			sprintf( new, "#<binary_%s_port:%s>",
                                 BINARY_PORT_INP( o ) ? "input" : "output",
				 BINARY_PORT( o ).name );
                        strputs( new, port );
                     } 
                     else
                     {
                        FILE *fout = OUTPUT_PORT( port ).file;
                        
                        fprintf( fout, "#<binary_%s_port:%s>",
                                 BINARY_PORT_INP( o ) ? "input" : "output",
                                 BINARY_PORT( o ).name );
                     }
                                
		     return o;

	       case ELONG_TYPE:
		     if( OUTPUT_STRING_PORTP( port ) )
		     {
			char new[ 100 ];
			
			sprintf( new, "#e%ld", BELONG_TO_LONG( o ) );
			strputs( new, port );
		     }
		     else
		     {
			FILE *fout = OUTPUT_PORT( port ).file;
			
			fprintf( fout, "#e%ld", BELONG_TO_LONG( o ) );
		     }
		     
		     return o;

	       case LLONG_TYPE:
	             {
			char *s = BSTRING_TO_STRING( llong_to_string( BLLONG_TO_LLONG( o ), 10 ) );
			if( OUTPUT_STRING_PORTP( port ) )
			{
			   lstrputs( "#l", port, 2 );
			   strputs( s, port );
			}
			else
			{
			   FILE *fout = OUTPUT_PORT( port ).file;
			   
			   fprintf( fout, "#l%s", s );
			}
		     
			return o;
		     }
                  
	       case FOREIGN_TYPE :
	          if( OUTPUT_STRING_PORTP( port ) )
		  {
		     char new[ 500 ];
		     
		     lstrputs( "#<foreign:", port, 10 );
		     write_object( FOREIGN_ID( o ), port );

		     sprintf( new, ":%lx>", (long)FOREIGN_TO_COBJ( o ) );
		     strputs( new, port );
	 	  }
		  else
		  {
		     FILE *fout = OUTPUT_PORT( port ).file;

		     fputs( "#<foreign:", fout );
		     write_object( FOREIGN_ID( o ), port );
		     fprintf( fout, ":%lx>", (long)FOREIGN_TO_COBJ( o ) );
		  }
		  return o;

	       case PROCESS_TYPE:
	          if( OUTPUT_STRING_PORTP( port ) )
		  {
		     char new[ 500 ];

		     sprintf( new, "#<process:%d>", PROCESS_PID( o ) );
		     strputs( new, port );
	 	  }
		  else
		  {
		     FILE *fout = OUTPUT_PORT( port ).file;

		     fprintf( fout, "#<process:%d>", PROCESS_PID( o ) );
		  }
		  return o;

	       case SOCKET_TYPE:
	          if( OUTPUT_STRING_PORTP( port ) )
		  {
		     char new[ 500 ];

		     sprintf( new,
			      "#<socket:%s.%d>",
			      STRINGP( SOCKET( o ).hostname ) ?
			      BSTRING_TO_STRING( SOCKET( o ).hostname ) :
			      "localhost",
			      SOCKET( o ).portnum );
		     strputs( new, port );
	 	  }
		  else
		  {
		     FILE *fout = OUTPUT_PORT( port ).file;

		     fprintf( fout,
			      "#<socket:%s.%d>",
			      STRINGP( SOCKET( o ).hostname ) ?
			      BSTRING_TO_STRING( SOCKET( o ).hostname ) :
			      "localhost",
			      SOCKET( o ).portnum );
		  }
		  return o;

	       case CUSTOM_TYPE:
	          if( OUTPUT_STRING_PORTP( port ) )
		  {
		     char new[ 50 ];
		     strputs( CUSTOM_TO_STRING( o )( o, new, 50 ), port );
	 	  }
		  else
		  {
		     FILE *fout = OUTPUT_PORT( port ).file;
		     CUSTOM_OUTPUT( o )( o, fout );
		  }
		  return o;

	       case OPAQUE_TYPE:
                  if( OUTPUT_STRING_PORTP( port ) )
                  {
                     char aux[ 20 ];
                  
                     sprintf( aux,
			      "#<opaque:%ld:%08lx>",
			      TYPE( o ),
			      (unsigned long)o );
                     strputs( aux, port );
                  }                            
                  else
                  {
                     FILE *fout = OUTPUT_PORT( port ).file;

                     fprintf( fout,
			      "#<opaque:%ld:%08lx>",
			      TYPE( o ),
			      (unsigned long)o );
                  }
		  return o;

	       default :
                  if( OUTPUT_STRING_PORTP( port ) )
                  {
                     char aux[ 20 ];
                  
                     sprintf( aux,
			      "#<???:%ld:%08lx>",
			      TYPE( o ),
			      (unsigned long)o );
                     strputs( aux, port );
                  }                            
                  else
                  {
                     FILE *fout = OUTPUT_PORT( port ).file;

                     fprintf( fout,
			      "#<???:%ld:%08lx>",
			      TYPE( o ),
			      (unsigned long)o );
                  }
                        
		  return o;
            }
   }
}


