mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-17 14:51:20 -08:00
408 lines
10 KiB
C
408 lines
10 KiB
C
/* -*- mode: c; c-basic-offset: 8 -*- */
|
|
/*
|
|
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;
|
|
}
|