/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */

/*
    print.d -- Print.
*/
/*
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
    Copyright (c) 1990, Giuseppe Attardi.
    Copyright (c) 2001, Juan Jose Garcia Ripoll.

    ECL is free software; you can redistribute it and/or
    modify it under the terms of the GNU Library General Public
    License as published by the Free Software Foundation; either
    version 2 of the License, or (at your option) any later version.

    See file '../Copyright' for full details.
*/
#include <stdio.h>
#include <ecl/ecl.h>
#include <ecl/internal.h>

cl_object
_ecl_stream_or_default_output(cl_object stream)
{
        if (Null(stream))
                return ecl_symbol_value(@'*standard-output*');
        else if (stream == ECL_T)
                return ecl_symbol_value(@'*terminal-io*');
        return stream;
}

int
ecl_print_base(void)
{
        cl_object object = ecl_symbol_value(@'*print-base*');
        cl_fixnum base;
        unlikely_if (!ECL_FIXNUMP(object) || (base = ecl_fixnum(object)) < 2 || base > 36) {
                ECL_SETQ(ecl_process_env(), @'*print-base*', ecl_make_fixnum(10));
                FEerror("The value of *PRINT-BASE*~%  ~S~%"
                        "is not of the expected type (INTEGER 2 36)", 1, object);
        }
        return base;
}

cl_fixnum
ecl_print_level(void)
{
        cl_object object = ecl_symbol_value(@'*print-level*');
        cl_fixnum level;
        if (object == ECL_NIL) {
                level = MOST_POSITIVE_FIXNUM;
        } else if (ECL_FIXNUMP(object)) {
                level = ecl_fixnum(object);
                if (level < 0) {
                ERROR:  ECL_SETQ(ecl_process_env(), @'*print-level*', ECL_NIL);
                        FEerror("The value of *PRINT-LEVEL*~%  ~S~%"
                                "is not of the expected type (OR NULL (INTEGER 0 *))",
                                1, object);
                }
        } else if (ecl_unlikely(!ECL_BIGNUMP(object))) {
                goto ERROR;
        } else {
                level = MOST_POSITIVE_FIXNUM;
        }
        return level;
}

cl_fixnum
ecl_print_length(void)
{
        cl_object object = ecl_symbol_value(@'*print-length*');
        cl_fixnum length;
        if (object == ECL_NIL) {
                length = MOST_POSITIVE_FIXNUM;
        } else if (ECL_FIXNUMP(object)) {
                length = ecl_fixnum(object);
                unlikely_if (length < 0) {
                ERROR:  ECL_SETQ(ecl_process_env(), @'*print-length*', ECL_NIL);
                        FEerror("The value of *PRINT-LENGTH*~%  ~S~%"
                                "is not of the expected type (OR NULL (INTEGER 0 *))",
                                1, object);
                }
        } else if (ecl_unlikely(!ECL_BIGNUMP(object))) {
                goto ERROR;
        } else {
                length = MOST_POSITIVE_FIXNUM;
        }
        return length;
}

bool
ecl_print_radix(void)
{
        return ecl_symbol_value(@'*print-radix*') != ECL_NIL;
}

cl_object
ecl_print_case(void)
{
        cl_object output = ecl_symbol_value(@'*print-case*');
        unlikely_if (output != @':upcase' &&
                     output != @':downcase' &&
                     output != @':capitalize')
        {
                ECL_SETQ(ecl_process_env(), @'*print-case*', @':downcase');
                FEerror("The value of *PRINT-CASE*~%  ~S~%"
                        "is not of the expected type "
                        "(MEMBER :UPCASE :DOWNCASE :CAPITALIZE)", 1, output);
        }
        return output;
}

bool
ecl_print_gensym(void)
{
        return ecl_symbol_value(@'*print-gensym*') != ECL_NIL;
}

bool
ecl_print_array(void)
{
        return ecl_symbol_value(@'*print-array*') != ECL_NIL;
}

bool
ecl_print_readably(void)
{
        return ecl_symbol_value(@'*print-readably*') != ECL_NIL;
}

bool
ecl_print_escape(void)
{
        return ecl_symbol_value(@'*print-escape*') != ECL_NIL;
}

bool
ecl_print_circle(void)
{
        return ecl_symbol_value(@'*print-circle*') != ECL_NIL;
}

@(defun write (x
               &key ((:stream strm) ECL_NIL)
                    (array ecl_symbol_value(@'*print-array*'))
                    (base ecl_symbol_value(@'*print-base*'))
                    ((:case cas) ecl_symbol_value(@'*print-case*'))
                    (circle ecl_symbol_value(@'*print-circle*'))
                    (escape ecl_symbol_value(@'*print-escape*'))
                    (gensym ecl_symbol_value(@'*print-gensym*'))
                    (length ecl_symbol_value(@'*print-length*'))
                    (level ecl_symbol_value(@'*print-level*'))
                    (lines ecl_symbol_value(@'*print-lines*'))
                    (miser_width ecl_symbol_value(@'*print-miser-width*'))
                    (pprint_dispatch ecl_symbol_value(@'*print-pprint-dispatch*'))
                    (pretty ecl_symbol_value(@'*print-pretty*'))
                    (radix ecl_symbol_value(@'*print-radix*'))
                    (readably ecl_symbol_value(@'*print-readably*'))
                    (right_margin ecl_symbol_value(@'*print-right-margin*')))
@{
        ecl_bds_bind(the_env, @'*print-array*', array);
        ecl_bds_bind(the_env, @'*print-base*', base);
        ecl_bds_bind(the_env, @'*print-case*', cas);
        ecl_bds_bind(the_env, @'*print-circle*', circle);
        ecl_bds_bind(the_env, @'*print-escape*', escape);
        ecl_bds_bind(the_env, @'*print-gensym*', gensym);
        ecl_bds_bind(the_env, @'*print-level*', level);
        ecl_bds_bind(the_env, @'*print-length*', length);
        ecl_bds_bind(the_env, @'*print-lines*', lines);
        ecl_bds_bind(the_env, @'*print-miser-width*', miser_width);
        ecl_bds_bind(the_env, @'*print-pprint-dispatch*', pprint_dispatch);
        ecl_bds_bind(the_env, @'*print-pretty*', pretty);
        ecl_bds_bind(the_env, @'*print-radix*', radix);
        ecl_bds_bind(the_env, @'*print-readably*', readably);
        ecl_bds_bind(the_env, @'*print-right-margin*', right_margin);

        strm = _ecl_stream_or_default_output(strm);
        si_write_object(x, strm);
        ecl_force_output(strm);

        ecl_bds_unwind_n(the_env, 15);
        @(return x)
@)

@(defun prin1 (obj &optional strm)
@
        ecl_prin1(obj, strm);
        @(return obj)
@)

@(defun print (obj &optional strm)
@
        ecl_print(obj, strm);
        @(return obj)
@)

@(defun pprint (obj &optional strm)
@
        strm = _ecl_stream_or_default_output(strm);
        ecl_bds_bind(the_env, @'*print-escape*', ECL_T);
        ecl_bds_bind(the_env, @'*print-pretty*', ECL_T);
        ecl_write_char('\n', strm);
        si_write_object(obj, strm);
        ecl_force_output(strm);
        ecl_bds_unwind_n(the_env, 2);
        @(return)
@)

@(defun princ (obj &optional strm)
@
        ecl_princ(obj, strm);
        @(return obj)
@)

@(defun write-char (c &optional strm)
@
        /* INV: ecl_char_code() checks the type of `c' */
        strm = _ecl_stream_or_default_output(strm);
        c = ECL_CODE_CHAR(ecl_write_char(ecl_char_code(c), strm));
        @(return c)
@)

@(defun write-string (strng &o strm &k (start ecl_make_fixnum(0)) end)
@
        unlikely_if (!ECL_STRINGP(strng))
                FEwrong_type_nth_arg(@[write-string], 1, strng, @[string]);
        strm = _ecl_stream_or_default_output(strm);
#ifdef ECL_CLOS_STREAMS
        if (!ECL_ANSI_STREAM_P(strm))
                _ecl_funcall5(@'gray::stream-write-string', strm, strng, start, end);
        else
#endif
                si_do_write_sequence(strng, strm, start, end);
        @(return strng)
@)

@(defun write-line (strng &o strm &k (start ecl_make_fixnum(0)) end)
@
        unlikely_if (!ECL_STRINGP(strng))
                FEwrong_type_nth_arg(@[write-line], 1, strng, @[string]);
        strm = _ecl_stream_or_default_output(strm);
#ifdef ECL_CLOS_STREAMS
        if (!ECL_ANSI_STREAM_P(strm))
                _ecl_funcall5(@'gray::stream-write-string', strm, strng,
                              start, end);
        else
#endif
                si_do_write_sequence(strng, strm, start, end);
        ecl_terpri(strm);
        @(return strng)
@)

@(defun terpri (&optional strm)
@
        ecl_terpri(strm);
        @(return ECL_NIL)
@)

@(defun fresh-line (&optional strm)
@
        strm = _ecl_stream_or_default_output(strm);
#ifdef ECL_CLOS_STREAMS
        if (!ECL_ANSI_STREAM_P(strm)) {
                return _ecl_funcall2(@'gray::stream-fresh-line', strm);
        }
#endif
        if (ecl_file_column(strm) == 0)
                @(return ECL_NIL)
        ecl_write_char('\n', strm);
        ecl_force_output(strm);
        @(return ECL_T)
@)

@(defun finish-output (&o strm)
@
        strm = _ecl_stream_or_default_output(strm);
#ifdef ECL_CLOS_STREAMS
        if (!ECL_ANSI_STREAM_P(strm)) {
                return _ecl_funcall2(@'gray::stream-finish-output', strm);
        }
#endif
        ecl_force_output(strm);
        @(return ECL_NIL)
@)

@(defun force-output (&o strm)
@
        strm = _ecl_stream_or_default_output(strm);
        ecl_force_output(strm);
        @(return ECL_NIL)
@)

@(defun clear-output (&o strm)
@
        strm = _ecl_stream_or_default_output(strm);
        ecl_clear_output(strm);
        @(return ECL_NIL)
@)

cl_object
cl_write_byte(cl_object integer, cl_object binary_output_stream)
{
        ecl_write_byte(integer, binary_output_stream);
        @(return integer)
}

@(defun write-sequence (sequence stream &key (start ecl_make_fixnum(0)) end)
@
#ifdef ECL_CLOS_STREAMS
        if (!ECL_ANSI_STREAM_P(stream)) {
                return _ecl_funcall5(@'gray::stream-write-sequence',
                                     stream, sequence, start, end);
        } else
#endif
                return si_do_write_sequence(sequence, stream, start, end);
@)

cl_object
ecl_princ(cl_object obj, cl_object strm)
{
        const cl_env_ptr the_env = ecl_process_env();
        strm = _ecl_stream_or_default_output(strm);
        ecl_bds_bind(the_env, @'*print-escape*', ECL_NIL);
        ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL);
        si_write_object(obj, strm);
        ecl_bds_unwind_n(the_env, 2);
        return obj;
}

cl_object
ecl_prin1(cl_object obj, cl_object strm)
{
        const cl_env_ptr the_env = ecl_process_env();
        strm = _ecl_stream_or_default_output(strm);
        ecl_bds_bind(the_env, @'*print-escape*', ECL_T);
        si_write_object(obj, strm);
        ecl_force_output(strm);
        ecl_bds_unwind1(the_env);
        return obj;
}

cl_object
ecl_print(cl_object obj, cl_object strm)
{
        strm = _ecl_stream_or_default_output(strm);
        ecl_terpri(strm);
        ecl_prin1(obj, strm);
        ecl_princ_char(' ', strm);
        return obj;
}

cl_object
ecl_terpri(cl_object strm)
{
        strm = _ecl_stream_or_default_output(strm);
#ifdef ECL_CLOS_STREAMS
        if (!ECL_ANSI_STREAM_P(strm)) {
                return _ecl_funcall2(@'gray::stream-terpri', strm);
        }
#endif
        ecl_write_char('\n', strm);
        ecl_force_output(strm);
        return(ECL_NIL);
}

void
ecl_write_string(cl_object strng, cl_object strm)
{
        cl_index i;

        strm = _ecl_stream_or_default_output(strm);
        switch(ecl_t_of(strng)) {
#ifdef ECL_UNICODE
        case t_string:
                for (i = 0;  i < strng->string.fillp;  i++)
                        ecl_write_char(strng->string.self[i], strm);
                break;
#endif
        case t_base_string:
                for (i = 0;  i < strng->base_string.fillp;  i++)
                        ecl_write_char(strng->base_string.self[i], strm);
                break;
        default:
                FEwrong_type_nth_arg(@[write-string], 1, strng, @[string]);
        }
                
        ecl_force_output(strm);
}

/*
        THE ULTRA-SPECIAL-DINNER-SERVICE OPTIMIZATION
*/
void
ecl_princ_str(const char *s, cl_object strm)
{
        strm = _ecl_stream_or_default_output(strm);
        writestr_stream(s, strm);
}

int
ecl_princ_char(int c, cl_object strm)
{
        strm = _ecl_stream_or_default_output(strm);
        ecl_write_char(c, strm);
        if (c == '\n') {
                ecl_force_output(strm);
        }
        return c;
}
