andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: Split-out display.c. 

* src/lib.c (display_helper, display_, display_error_, display_port_,
write_, write_error_, write_port_, fdisplay_): Move to ..
* src/display.c: New file.
* build-aux/configure-lib.sh (mes_SOURCES): Add it.
* simple.make: Likewise.
This commit is contained in:
Jan (janneke) Nieuwenhuizen 2020-05-17 20:42:48 +02:00
parent efd9f75ce2
commit c8bfa1478d
No known key found for this signature in database
GPG Key ID: F3C1A0D9C1D65273
7 changed files with 308 additions and 288 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
build-aux/configure-lib.sh
View File

@ -431,6 +431,7 @@ fi
mes_SOURCES="
src/builtins.c
src/display.c
src/eval-apply.c
src/gc.c
src/hash.c

1
build-aux/snarf.sh
View File

@ -25,6 +25,7 @@ srcdest=${srcdest-./}
. ${srcdest}build-aux/trace.sh
trace "SNARF$snarf builtins.c" ${srcdest}build-aux/mes-snarf.scm src/builtins.c
trace "SNARF$snarf display.c" ${srcdest}build-aux/mes-snarf.scm src/display.c
trace "SNARF$snarf eval-apply.c" ${srcdest}build-aux/mes-snarf.scm src/eval-apply.c
trace "SNARF$snarf gc.c" ${srcdest}build-aux/mes-snarf.scm src/gc.c
trace "SNARF$snarf hash.c" ${srcdest}build-aux/mes-snarf.scm src/hash.c

13
include/mes/builtins.h
View File

@ -27,6 +27,13 @@ SCM builtin_name (SCM builtin);
SCM builtin_arity (SCM builtin);
SCM builtin_p (SCM x);
SCM builtin_printer (SCM builtin);
/* src/display.c */
SCM display_ (SCM x);
SCM display_error_ (SCM x);
SCM display_port_ (SCM x, SCM p);
SCM write_ (SCM x);
SCM write_error_ (SCM x);
SCM write_port_ (SCM x, SCM p);
/* src/eval-apply.c */
SCM pairlis (SCM x, SCM y, SCM a);
SCM set_car_x (SCM x, SCM e);
@ -49,12 +56,6 @@ SCM hash_set_x (SCM table, SCM key, SCM value);
SCM hash_table_printer (SCM table);
SCM make_hash_table (SCM x);
/* src/lib.c */
SCM display_ (SCM x);
SCM display_error_ (SCM x);
SCM display_port_ (SCM x, SCM p);
SCM write_ (SCM x);
SCM write_error_ (SCM x);
SCM write_port_ (SCM x, SCM p);
SCM exit_ (SCM x);
SCM frame_printer (SCM frame);
SCM make_stack (SCM stack);

1
simple.make
View File

@ -48,6 +48,7 @@ CFLAGS:= \
MES_SOURCES = \
src/builtins.c \
src/display.c \
src/eval-apply.c \
src/gc.c \
src/hash.c \

28
src/builtins.c
View File

@ -117,26 +117,21 @@ mes_builtins (SCM a) /*:((internal)) */
a = init_builtin (builtin_type, "builtin-arity", 1, &builtin_arity, a);
a = init_builtin (builtin_type, "builtin?", 1, &builtin_p, a);
a = init_builtin (builtin_type, "builtin-printer", 1, &builtin_printer, a);
/* src/display.c */
a = init_builtin (builtin_type, "core:display", 1, &display_, a);
a = init_builtin (builtin_type, "core:display-error", 1, &display_error_, a);
a = init_builtin (builtin_type, "core:display-port", 2, &display_port_, a);
a = init_builtin (builtin_type, "core:write", 1, &write_, a);
a = init_builtin (builtin_type, "core:write-error", 1, &write_error_, a);
a = init_builtin (builtin_type, "core:write-port", 2, &write_port_, a);
/* src/eval-apply.c */
a = init_builtin (builtin_type, "assert-defined", 2, &assert_defined, a);
a = init_builtin (builtin_type, "check-formals", 3, &check_formals, a);
a = init_builtin (builtin_type, "check-apply", 2, &check_apply, a);
a = init_builtin (builtin_type, "pairlis", 3, &pairlis, a);
a = init_builtin (builtin_type, "set-car!", 2, &set_car_x, a);
a = init_builtin (builtin_type, "set-cdr!", 2, &set_cdr_x, a);
a = init_builtin (builtin_type, "set-env!", 3, &set_env_x, a);
a = init_builtin (builtin_type, "call-lambda", 4, &call_lambda, a);
a = init_builtin (builtin_type, "core:make-closure", 3, &make_closure_, a);
a = init_builtin (builtin_type, "core:make-variable", 1, &make_variable_, a);
a = init_builtin (builtin_type, "macro-get-handle", 1, &macro_get_handle, a);
a = init_builtin (builtin_type, "get-macro", 1, &get_macro, a);
a = init_builtin (builtin_type, "macro-set!", 2, &macro_set_x, a);
a = init_builtin (builtin_type, "push-cc", 4, &push_cc, a);
a = init_builtin (builtin_type, "add-formals", 2, &add_formals, a);
a = init_builtin (builtin_type, "expand-variable", 2, &expand_variable, a);
a = init_builtin (builtin_type, "apply-builtin", 2, &apply_builtin, a);
a = init_builtin (builtin_type, "eval-apply", 0, &eval_apply, a);
a = init_builtin (builtin_type, "apply", 3, &apply, a);
/* src/gc.c */
a = init_builtin (builtin_type, "gc-check", 0, &gc_check, a);
a = init_builtin (builtin_type, "gc", 0, &gc, a);
@ -151,12 +146,6 @@ mes_builtins (SCM a) /*:((internal)) */
a = init_builtin (builtin_type, "hash-table-printer", 1, &hash_table_printer, a);
a = init_builtin (builtin_type, "make-hash-table", 1, &make_hash_table, a);
/* src/lib.c */
a = init_builtin (builtin_type, "core:display", 1, &display_, a);
a = init_builtin (builtin_type, "core:display-error", 1, &display_error_, a);
a = init_builtin (builtin_type, "core:display-port", 2, &display_port_, a);
a = init_builtin (builtin_type, "core:write", 1, &write_, a);
a = init_builtin (builtin_type, "core:write-error", 1, &write_error_, a);
a = init_builtin (builtin_type, "core:write-port", 2, &write_port_, a);
a = init_builtin (builtin_type, "exit", 1, &exit_, a);
a = init_builtin (builtin_type, "frame-printer", 1, &frame_printer, a);
a = init_builtin (builtin_type, "make-stack", -1, &make_stack, a);
@ -202,6 +191,7 @@ mes_builtins (SCM a) /*:((internal)) */
a = init_builtin (builtin_type, "assq", 2, &assq, a);
a = init_builtin (builtin_type, "assoc", 2, &assoc, a);
/* src/module.c */
a = init_builtin (builtin_type, "make-module-type", 0, &make_module_type, a);
a = init_builtin (builtin_type, "module-printer", 1, &module_printer, a);
a = init_builtin (builtin_type, "module-variable", 2, &module_variable, a);
a = init_builtin (builtin_type, "module-ref", 2, &module_ref, a);
@ -233,7 +223,9 @@ mes_builtins (SCM a) /*:((internal)) */
a = init_builtin (builtin_type, "execl", 2, &execl_, a);
a = init_builtin (builtin_type, "core:waitpid", 2, &waitpid_, a);
a = init_builtin (builtin_type, "current-time", 0, &current_time, a);
a = init_builtin (builtin_type, "gettimeofday", 0, &gettimeofday_, a);
a = init_builtin (builtin_type, "get-internal-run-time", 0, &get_internal_run_time, a);
a = init_builtin (builtin_type, "getcwd", 0, &getcwd_, a);
a = init_builtin (builtin_type, "dup", 1, &dup_, a);
a = init_builtin (builtin_type, "dup2", 2, &dup2_, a);
a = init_builtin (builtin_type, "delete-file", 1, &delete_file, a);

288
src/display.c Normal file
View File

@ -0,0 +1,288 @@
/* -*-comment-start: "//";comment-end:""-*-
* GNU Mes --- Maxwell Equations of Software
* Copyright © 2016,2017,2018,2019 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;
SCM
display_helper (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 = TYPE (x);
if (t == TCHAR)
{
if (write_p == 0)
fdputc (VALUE (x), fd);
else
{
fdputs ("#", fd);
long v = VALUE (x);
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 (VALUE (x), fd);
}
}
}
else if (t == TCLOSURE)
{
fdputs ("#<closure ", fd);
SCM circ = CADR (x);
SCM name = CADR (circ);
SCM args = CAR (CDDR (x));
display_helper (CAR (name), 0, "", fd, 0);
fdputc (' ', fd);
display_helper (args, 0, "", fd, 0);
fdputs (">", fd);
}
else if (t == TMACRO)
{
fdputs ("#<macro ", fd);
display_helper (CDR (x), cont, "", fd, 0);
fdputs (">", fd);
}
else if (t == TVARIABLE)
{
fdputs ("#<variable ", fd);
display_helper (CAR (VARIABLE (x)), cont, "", fd, 0);
fdputs (">", fd);
}
else if (t == TNUMBER)
{
fdputs (itoa (VALUE (x)), fd);
}
else if (t == TPAIR)
{
if (cont == 0)
fdputs ("(", fd);
if (CAR (x) == cell_circular && CADR (x) != cell_closure)
{
fdputs ("(*circ* . ", fd);
int i = 0;
x = CDR (x);
while (x != cell_nil && i < 10)
{
i = i + 1;
fdisplay_ (CAAR (x), fd, write_p);
fdputs (" ", fd);
x = CDR (x);
}
fdputs (" ...)", fd);
}
else
{
if (x && x != cell_nil)
fdisplay_ (CAR (x), fd, write_p);
if (CDR (x) && TYPE (CDR (x)) == TPAIR)
display_helper (CDR (x), 1, " ", fd, write_p);
else if (CDR (x) && CDR (x) != cell_nil)
{
if (TYPE (CDR (x)) != TPAIR)
fdputs (" . ", fd);
fdisplay_ (CDR (x), fd, write_p);
}
}
if (cont == 0)
fdputs (")", fd);
}
else if (t == TKEYWORD || t == TPORT || t == TSPECIAL || t == TSTRING || t == TSYMBOL)
{
if (t == TPORT)
{
fdputs ("#<port ", fd);
fdputs (itoa (PORT (x)), fd);
fdputs (" ", fd);
x = STRING (x);
}
if (t == TKEYWORD)
fdputs ("#:", fd);
if ((write_p && t == TSTRING) || t == TPORT)
fdputc ('"', fd);
char const *s = CSTRING (x);
size_t length = LENGTH (x);
size_t i;
for (i = 0; i < length; i = i + 1)
{
long v = -1;
if (write_p != 0)
v = s[i];
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);
#if 1 //__MESC__
//Nyacc bug
else if (v == 13)
fdputs ("\\r", fd);
else if (v == 27)
fdputs ("\\e", fd);
#else
//else if (v == '\r') fdputs ("\\r", fd);
//Nyacc crash
//else if (v == '\e') fdputs ("\\e", fd);
#endif
else if (v == '\\')
fdputs ("\\\\", fd);
else if (v == '"')
fdputs ("\\\"", fd);
else
fdputc (s[i], fd);
}
if ((write_p && t == TSTRING) || t == TPORT)
fdputc ('"', fd);
if (t == TPORT)
fdputs (">", fd);
}
else if (t == TREF)
fdisplay_ (REF (x), fd, write_p);
else if (t == TSTRUCT)
{
//SCM printer = STRUCT (x) + 1;
SCM printer = struct_ref_ (x, STRUCT_PRINTER);
if (TYPE (printer) == TREF)
printer = REF (printer);
if (TYPE (printer) == TCLOSURE || builtin_p (printer) == cell_t)
apply (printer, cons (x, cell_nil), r0);
else
{
fdputs ("#<", fd);
fdisplay_ (STRUCT (x), fd, write_p);
SCM t = CAR (x);
long size = LENGTH (x);
long i;
for (i = 2; i < size; i = i + 1)
{
fdputc (' ', fd);
fdisplay_ (STRUCT (x) + i, fd, write_p);
}
fdputc ('>', fd);
}
}
else if (t == TVECTOR)
{
fdputs ("#(", fd);
SCM t = CAR (x);
long i;
for (i = 0; i < LENGTH (x); i = i + 1)
{
if (i != 0)
fdputc (' ', fd);
fdisplay_ (VECTOR (x) + i, fd, write_p);
}
fdputc (')', fd);
}
else
{
fdputs ("<", fd);
fdputs (itoa (t), fd);
fdputs (":", fd);
fdputs (itoa (x), fd);
fdputs (">", fd);
}
return 0;
}
SCM
display_ (SCM x)
{
g_depth = 5;
return display_helper (x, 0, "", __stdout, 0);
}
SCM
display_error_ (SCM x)
{
g_depth = 5;
return display_helper (x, 0, "", __stderr, 0);
}
SCM
display_port_ (SCM x, SCM p)
{
assert_msg (TYPE (p) == TNUMBER, "TYPE (p) == TNUMBER");
return fdisplay_ (x, VALUE (p), 0);
}
SCM
write_ (SCM x)
{
g_depth = 5;
return display_helper (x, 0, "", __stdout, 1);
}
SCM
write_error_ (SCM x)
{
g_depth = 5;
return display_helper (x, 0, "", __stderr, 1);
}
SCM
write_port_ (SCM x, SCM p)
{
assert_msg (TYPE (p) == TNUMBER, "TYPE (p) == TNUMBER");
return fdisplay_ (x, VALUE (p), 1);
}
SCM
fdisplay_ (SCM x, int fd, int write_p) /*:((internal)) */
{
g_depth = 5;
return display_helper (x, 0, "", fd, write_p);
}

264
src/lib.c
View File

@ -24,270 +24,6 @@
#include <stdlib.h>
int g_depth;
SCM
display_helper (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 = TYPE (x);
if (t == TCHAR)
{
if (write_p == 0)
fdputc (VALUE (x), fd);
else
{
fdputs ("#", fd);
long v = VALUE (x);
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 (VALUE (x), fd);
}
}
}
else if (t == TCLOSURE)
{
fdputs ("#<closure ", fd);
SCM circ = CADR (x);
SCM name = CADR (circ);
SCM args = CAR (CDDR (x));
display_helper (CAR (name), 0, "", fd, 0);
fdputc (' ', fd);
display_helper (args, 0, "", fd, 0);
fdputs (">", fd);
}
else if (t == TMACRO)
{
fdputs ("#<macro ", fd);
display_helper (CDR (x), cont, "", fd, 0);
fdputs (">", fd);
}
else if (t == TVARIABLE)
{
fdputs ("#<variable ", fd);
display_helper (CAR (VARIABLE (x)), cont, "", fd, 0);
fdputs (">", fd);
}
else if (t == TNUMBER)
{
fdputs (itoa (VALUE (x)), fd);
}
else if (t == TPAIR)
{
if (cont == 0)
fdputs ("(", fd);
if (CAR (x) == cell_circular && CADR (x) != cell_closure)
{
fdputs ("(*circ* . ", fd);
int i = 0;
x = CDR (x);
while (x != cell_nil && i < 10)
{
i = i + 1;
fdisplay_ (CAAR (x), fd, write_p);
fdputs (" ", fd);
x = CDR (x);
}
fdputs (" ...)", fd);
}
else
{
if (x && x != cell_nil)
fdisplay_ (CAR (x), fd, write_p);
if (CDR (x) && TYPE (CDR (x)) == TPAIR)
display_helper (CDR (x), 1, " ", fd, write_p);
else if (CDR (x) && CDR (x) != cell_nil)
{
if (TYPE (CDR (x)) != TPAIR)
fdputs (" . ", fd);
fdisplay_ (CDR (x), fd, write_p);
}
}
if (cont == 0)
fdputs (")", fd);
}
else if (t == TKEYWORD || t == TPORT || t == TSPECIAL || t == TSTRING || t == TSYMBOL)
{
if (t == TPORT)
{
fdputs ("#<port ", fd);
fdputs (itoa (PORT (x)), fd);
fdputs (" ", fd);
x = STRING (x);
}
if (t == TKEYWORD)
fdputs ("#:", fd);
if ((write_p && t == TSTRING) || t == TPORT)
fdputc ('"', fd);
char const *s = CSTRING (x);
size_t length = LENGTH (x);
size_t i;
for (i = 0; i < length; i = i + 1)
{
long v = -1;
if (write_p != 0)
v = s[i];
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);
#if 1 //__MESC__
//Nyacc bug
else if (v == 13)
fdputs ("\\r", fd);
else if (v == 27)
fdputs ("\\e", fd);
#else
//else if (v == '\r') fdputs ("\\r", fd);
//Nyacc crash
//else if (v == '\e') fdputs ("\\e", fd);
#endif
else if (v == '\\')
fdputs ("\\\\", fd);
else if (v == '"')
fdputs ("\\\"", fd);
else
fdputc (s[i], fd);
}
if ((write_p && t == TSTRING) || t == TPORT)
fdputc ('"', fd);
if (t == TPORT)
fdputs (">", fd);
}
else if (t == TREF)
fdisplay_ (REF (x), fd, write_p);
else if (t == TSTRUCT)
{
//SCM printer = STRUCT (x) + 1;
SCM printer = struct_ref_ (x, STRUCT_PRINTER);
if (TYPE (printer) == TREF)
printer = REF (printer);
if (TYPE (printer) == TCLOSURE || builtin_p (printer) == cell_t)
apply (printer, cons (x, cell_nil), r0);
else
{
fdputs ("#<", fd);
fdisplay_ (STRUCT (x), fd, write_p);
SCM t = CAR (x);
long size = LENGTH (x);
long i;
for (i = 2; i < size; i = i + 1)
{
fdputc (' ', fd);
fdisplay_ (STRUCT (x) + i, fd, write_p);
}
fdputc ('>', fd);
}
}
else if (t == TVECTOR)
{
fdputs ("#(", fd);
SCM t = CAR (x);
long i;
for (i = 0; i < LENGTH (x); i = i + 1)
{
if (i != 0)
fdputc (' ', fd);
fdisplay_ (VECTOR (x) + i, fd, write_p);
}
fdputc (')', fd);
}
else
{
fdputs ("<", fd);
fdputs (itoa (t), fd);
fdputs (":", fd);
fdputs (itoa (x), fd);
fdputs (">", fd);
}
return 0;
}
SCM
display_ (SCM x)
{
g_depth = 5;
return display_helper (x, 0, "", __stdout, 0);
}
SCM
display_error_ (SCM x)
{
g_depth = 5;
return display_helper (x, 0, "", __stderr, 0);
}
SCM
display_port_ (SCM x, SCM p)
{
assert_msg (TYPE (p) == TNUMBER, "TYPE (p) == TNUMBER");
return fdisplay_ (x, VALUE (p), 0);
}
SCM
write_ (SCM x)
{
g_depth = 5;
return display_helper (x, 0, "", __stdout, 1);
}
SCM
write_error_ (SCM x)
{
g_depth = 5;
return display_helper (x, 0, "", __stderr, 1);
}
SCM
write_port_ (SCM x, SCM p)
{
assert_msg (TYPE (p) == TNUMBER, "TYPE (p) == TNUMBER");
return fdisplay_ (x, VALUE (p), 1);
}
SCM
fdisplay_ (SCM x, int fd, int write_p) /*:((internal)) */
{
g_depth = 5;
return display_helper (x, 0, "", fd, write_p);
}
SCM
exit_ (SCM x) /*:((name . "exit")) */
{