308 lines
7.3 KiB
C
308 lines
7.3 KiB
C
/* -*-comment-start: "//";comment-end:""-*-
|
|
* GNU Mes --- Maxwell Equations of Software
|
|
* Copyright © 2016,2017,2018,2019,2023 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
*
|
|
* This file is part of GNU Mes.
|
|
*
|
|
* GNU Mes is free software; you can redistribute it and/or modify it
|
|
* under the terms of the GNU General Public License as published by
|
|
* the Free Software Foundation; either version 3 of the License, or (at
|
|
* your option) any later version.
|
|
*
|
|
* GNU Mes is distributed in the hope that it will be useful, but
|
|
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
* GNU General Public License for more details.
|
|
*
|
|
* You should have received a copy of the GNU General Public License
|
|
* along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
*/
|
|
|
|
#include "mes/lib.h"
|
|
#include "mes/mes.h"
|
|
|
|
#include <stdlib.h>
|
|
|
|
int g_depth;
|
|
|
|
void
|
|
fdwrite_char (char v, int fd)
|
|
{
|
|
if (v == '\0')
|
|
fdputs ("\\nul", fd);
|
|
else if (v == '\a')
|
|
fdputs ("\\alarm", fd);
|
|
else if (v == '\b')
|
|
fdputs ("\\backspace", fd);
|
|
else if (v == '\t')
|
|
fdputs ("\\tab", fd);
|
|
else if (v == '\n')
|
|
fdputs ("\\newline", fd);
|
|
else if (v == '\v')
|
|
fdputs ("\\vtab", fd);
|
|
else if (v == '\f')
|
|
fdputs ("\\page", fd);
|
|
/* Nyacc bug
|
|
else if (v == '\r') fdputs ("return", fd);
|
|
*/
|
|
else if (v == 13)
|
|
fdputs ("\\return", fd);
|
|
else if (v == ' ')
|
|
fdputs ("\\space", fd);
|
|
else
|
|
{
|
|
if (v >= 32 && v <= 127)
|
|
fdputc ('\\', fd);
|
|
fdputc (v, fd);
|
|
}
|
|
}
|
|
|
|
void
|
|
fdwrite_string_char (char v, int fd)
|
|
{
|
|
if (v == '\0')
|
|
fdputs ("\\0", fd);
|
|
else if (v == '\a')
|
|
fdputs ("\\a", fd);
|
|
else if (v == '\b')
|
|
fdputs ("\\b", fd);
|
|
else if (v == '\t')
|
|
fdputs ("\\t", fd);
|
|
else if (v == '\v')
|
|
fdputs ("\\v", fd);
|
|
else if (v == '\n')
|
|
fdputs ("\\n", fd);
|
|
else if (v == '\f')
|
|
fdputs ("\\f", fd);
|
|
/* Nyacc bug
|
|
else if (v == '\r') fdputs ("\\r", fd);
|
|
else if (v == '\e') fdputs ("\\e", fd);
|
|
*/
|
|
else if (v == 13)
|
|
fdputs ("\\r", fd);
|
|
else if (v == 27)
|
|
fdputs ("\\e", fd);
|
|
else if (v == '\\')
|
|
fdputs ("\\\\", fd);
|
|
else if (v == '"')
|
|
fdputs ("\\\"", fd);
|
|
else
|
|
fdputc (v, fd);
|
|
}
|
|
|
|
void
|
|
fdwrite_string (char *s, int length, int fd)
|
|
{
|
|
int i;
|
|
for (i = 0; i < length; i = i + 1)
|
|
fdwrite_string_char (s[i], fd);
|
|
}
|
|
|
|
struct scm *display_helper (struct scm *x, int cont, char *sep, int fd, int write_p);
|
|
|
|
struct scm *
|
|
display_helper (struct scm *x, int cont, char *sep, int fd, int write_p)
|
|
{
|
|
fdputs (sep, fd);
|
|
if (g_depth == 0)
|
|
return cell_unspecified;
|
|
g_depth = g_depth - 1;
|
|
|
|
int t = x->type;
|
|
if (t == TCHAR)
|
|
{
|
|
if (write_p == 0)
|
|
fdputc (x->value, fd);
|
|
else
|
|
{
|
|
fdputs ("#", fd);
|
|
fdwrite_char (x->value, fd);
|
|
}
|
|
}
|
|
else if (t == TCLOSURE)
|
|
{
|
|
fdputs ("#<closure ", fd);
|
|
struct scm *circ = x->cdr->car;
|
|
struct scm *name = circ->cdr->car;
|
|
struct scm *args = x->cdr->cdr->car;
|
|
display_helper (name->car, 0, "", fd, 0);
|
|
fdputc (' ', fd);
|
|
display_helper (args, 0, "", fd, 0);
|
|
fdputs (">", fd);
|
|
}
|
|
else if (t == TMACRO)
|
|
{
|
|
fdputs ("#<macro ", fd);
|
|
display_helper (x->cdr, cont, "", fd, 0);
|
|
fdputs (">", fd);
|
|
}
|
|
else if (t == TVARIABLE)
|
|
{
|
|
fdputs ("#<variable ", fd);
|
|
display_helper (x->variable->car, cont, "", fd, 0);
|
|
fdputs (">", fd);
|
|
}
|
|
else if (t == TNUMBER)
|
|
{
|
|
fdputs (ltoa (x->value), fd);
|
|
}
|
|
else if (t == TPAIR)
|
|
{
|
|
if (cont == 0)
|
|
fdputs ("(", fd);
|
|
if (x->car == cell_circular && x->cdr->car != cell_closure)
|
|
{
|
|
fdputs ("(*circ* . ", fd);
|
|
int i = 0;
|
|
x = x->cdr;
|
|
while (x != cell_nil && i < 10)
|
|
{
|
|
i = i + 1;
|
|
fdisplay_ (x->car->car, fd, write_p);
|
|
fdputs (" ", fd);
|
|
x = x->cdr;
|
|
}
|
|
fdputs (" ...)", fd);
|
|
}
|
|
else
|
|
{
|
|
if (x != 0 && x != cell_nil)
|
|
fdisplay_ (x->car, fd, write_p);
|
|
if (x->cdr != 0 && x->cdr->type == TPAIR)
|
|
display_helper (x->cdr, 1, " ", fd, write_p);
|
|
else if (x->cdr != 0 && x->cdr != cell_nil)
|
|
{
|
|
if (x->cdr->type != TPAIR)
|
|
fdputs (" . ", fd);
|
|
fdisplay_ (x->cdr, fd, write_p);
|
|
}
|
|
}
|
|
if (cont == 0)
|
|
fdputs (")", fd);
|
|
}
|
|
else if (t == TPORT)
|
|
{
|
|
fdputs ("#<port ", fd);
|
|
fdputs (ltoa (x->port), fd);
|
|
fdputs (" ", fd);
|
|
x = x->string;
|
|
fdputc ('"', fd);
|
|
fdwrite_string (cell_bytes (x->string), x->length, fd);
|
|
fdputc ('"', fd);
|
|
fdputs (">", fd);
|
|
}
|
|
else if (t == TKEYWORD)
|
|
{
|
|
fdputs ("#:", fd);
|
|
fdwrite_string (cell_bytes (x->string), x->length, fd);
|
|
}
|
|
else if (t == TSTRING)
|
|
{
|
|
if (write_p == 1)
|
|
{
|
|
fdputc ('"', fd);
|
|
fdwrite_string (cell_bytes (x->string), x->length, fd);
|
|
fdputc ('"', fd);
|
|
}
|
|
else
|
|
fdputs (cell_bytes (x->string), fd);
|
|
}
|
|
else if (t == TSPECIAL || t == TSYMBOL)
|
|
fdwrite_string (cell_bytes (x->string), x->length, fd);
|
|
else if (t == TREF)
|
|
fdisplay_ (x->ref, fd, write_p);
|
|
else if (t == TSTRUCT)
|
|
{
|
|
struct scm *printer = struct_ref_ (x, STRUCT_PRINTER);
|
|
if (printer->type == TREF)
|
|
printer = printer->ref;
|
|
if (printer->type == TCLOSURE || builtin_p (printer) == cell_t)
|
|
apply (printer, cons (x, cell_nil), R0);
|
|
else
|
|
{
|
|
fdputs ("#<", fd);
|
|
fdisplay_ (x->structure, fd, write_p);
|
|
struct scm *t = x->car;
|
|
long size = x->length;
|
|
long i;
|
|
for (i = 2; i < size; i = i + 1)
|
|
{
|
|
fdputc (' ', fd);
|
|
fdisplay_ (cell_ref (x->structure, i), fd, write_p);
|
|
}
|
|
fdputc ('>', fd);
|
|
}
|
|
}
|
|
else if (t == TVECTOR)
|
|
{
|
|
fdputs ("#(", fd);
|
|
struct scm *t = x->car;
|
|
long i;
|
|
for (i = 0; i < x->length; i = i + 1)
|
|
{
|
|
if (i != 0)
|
|
fdputc (' ', fd);
|
|
fdisplay_ (cell_ref (x->vector, i), fd, write_p);
|
|
}
|
|
fdputc (')', fd);
|
|
}
|
|
else
|
|
{
|
|
fdputs ("<", fd);
|
|
fdputs (ltoa (t), fd);
|
|
fdputs (":", fd);
|
|
fdputs (ltoa (cast_voidp_to_long (x)), fd);
|
|
fdputs (">", fd);
|
|
}
|
|
return cell_unspecified;
|
|
}
|
|
|
|
struct scm *
|
|
display_ (struct scm *x)
|
|
{
|
|
g_depth = 5;
|
|
return display_helper (x, 0, "", __stdout, 0);
|
|
}
|
|
|
|
struct scm *
|
|
display_error_ (struct scm *x)
|
|
{
|
|
g_depth = 5;
|
|
return display_helper (x, 0, "", __stderr, 0);
|
|
}
|
|
|
|
struct scm *
|
|
display_port_ (struct scm *x, struct scm *p)
|
|
{
|
|
assert_msg (p->type == TNUMBER, "p->type == TNUMBER");
|
|
return fdisplay_ (x, p->value, 0);
|
|
}
|
|
|
|
struct scm *
|
|
write_ (struct scm *x)
|
|
{
|
|
g_depth = 5;
|
|
return display_helper (x, 0, "", __stdout, 1);
|
|
}
|
|
|
|
struct scm *
|
|
write_error_ (struct scm *x)
|
|
{
|
|
g_depth = 5;
|
|
return display_helper (x, 0, "", __stderr, 1);
|
|
}
|
|
|
|
struct scm *
|
|
write_port_ (struct scm *x, struct scm *p)
|
|
{
|
|
assert_msg (p->type == TNUMBER, "p->type == TNUMBER");
|
|
return fdisplay_ (x, p->value, 1);
|
|
}
|
|
|
|
struct scm *
|
|
fdisplay_ (struct scm *x, int fd, int write_p) /*:((internal)) */
|
|
{
|
|
g_depth = 5;
|
|
return display_helper (x, 0, "", fd, write_p);
|
|
}
|