mes/display.c

166 lines
5.1 KiB
C
Raw Normal View History

/* -*-comment-start: "//";comment-end:""-*-
* Mes --- Maxwell Equations of Software
* Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
*
* This file is part of Mes.
*
* 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.
*
* 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 Mes. If not, see <http://www.gnu.org/licenses/>.
*/
SCM display_helper (FILE*, SCM , bool, char const*, bool);
SCM
display (SCM x) ///((arity . n))
{
SCM e = car (x);
SCM p = cdr (x);
int fd = 1;
if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = HITS (car (p));
FILE *f = fd == 1 ? stdout : stderr;
return display_helper (f, e, false, "", false);
}
SCM
newline (SCM p) ///((arity . n))
{
int fd = 1;
if (TYPE (p) == PAIR && TYPE (car (p)) == NUMBER) fd = VALUE (car (p));
FILE *f = fd == 1 ? stdout : stderr;
fputs ("\n", f);
return cell_unspecified;
}
SCM
display_ (FILE* f, SCM x)
{
return display_helper (f, x, false, "", false);
}
SCM
display_helper (FILE* f, SCM x, bool cont, char const *sep, bool quote)
{
SCM r;
fprintf (f, "%s", sep);
switch (TYPE (x))
{
case CHAR:
{
char const *name = 0;
if (VALUE (x) == char_nul.value) name = char_nul.name;
else if (VALUE (x) == char_alarm.value) name = char_alarm.name;
else if (VALUE (x) == char_backspace.value) name = char_backspace.name;
else if (VALUE (x) == char_tab.value) name = char_tab.name;
else if (VALUE (x) == char_newline.value) name = char_newline.name;
else if (VALUE (x) == char_vtab.value) name = char_vtab.name;
else if (VALUE (x) == char_page.value) name = char_page.name;
else if (VALUE (x) == char_return.value) name = char_return.name;
else if (VALUE (x) == char_space.value) name = char_space.name;
if (name) fprintf (f, "#\\%s", name);
else fprintf (f, "#\\%c", VALUE (x));
break;
}
case MACRO:
fprintf (f, "(*macro* ");
display_helper (f, g_cells[x].macro, cont, sep, quote);
fprintf (f, ")");
break;
case NUMBER: fprintf (f, "%d", VALUE (x)); break;
case PAIR:
{
if (car (x) == cell_closure) {
fprintf (f, "#<procedure #f ");
display_ (f, (caddr (x)));
fprintf (f, ">");
return cell_unspecified;
}
if (car (x) == cell_circular) {
fprintf (f, "(*circ* . #-1#)");
return cell_unspecified;
}
if (car (x) == cell_closure) {
fprintf (f, "(*closure* . #-1#)");
return cell_unspecified;
}
if (car (x) == cell_symbol_quote) {
fprintf (f, "'");
x = cdr (x);
if (TYPE (x) != FUNCTION)
x = car (x);
return display_helper (f, x, cont, "", true);
}
if (!cont) fprintf (f, "(");
display_ (f, car (x));
if (cdr (x) && TYPE (cdr (x)) == PAIR)
display_helper (f, cdr (x), true, " ", false);
else if (cdr (x) != cell_nil) {
fprintf (f, " . ");
display_ (f, cdr (x));
}
if (!cont) fprintf (f, ")");
break;
}
case VECTOR:
{
fprintf (f, "#(");
for (int i = 0; i < LENGTH (x); i++) {
if (TYPE (VECTOR (x)+i) == VECTOR
|| (TYPE (VECTOR (x)+i) == REF
&& TYPE (REF (VECTOR (x)+i)) == VECTOR))
fprintf (f, "%s#(...)", i ? " " : "");
else
display_helper (f,VECTOR (x)+i, false, i ? " " : "", false);
}
fprintf (f, ")");
break;
}
case REF: display_helper (f, g_cells[x].ref, cont, "", true); break;
case FUNCTION:
{
fprintf (f, "#<procedure ");
SCM p = STRING (x);
if (p < 0 || p >= g_free.value || TYPE (p) != PAIR)
fprintf (f, "%s", NAME (x));
else
display_ (f, STRING (x));
fprintf (f, " ");
switch (FUNCTION (x).arity)
{
case -1: fprintf (f, "(. x)"); break;
case 0: fprintf (f, "()"); break;
case 1: fprintf (f, "(x)"); break;
case 2: fprintf (f, "(x y)"); break;
case 3: fprintf (f, "(x y z)"); break;
}
fprintf (f, ">");
break;
}
case BROKEN_HEART: fprintf (f, "<3"); break;
case KEYWORD:
fprintf (f, "#:");
default:
if (STRING (x))
{
SCM p = STRING (x);
assert (p);
while (p != cell_nil) {
assert (TYPE (car (p)) == CHAR);
fputc (VALUE (car (p)), f);
p = cdr (p);
}
}
else if (TYPE (x) != PAIR && NAME (x)) fprintf (f, "%s", NAME (x));
}
return cell_unspecified;
}