diff --git a/build-aux/configure-lib.sh b/build-aux/configure-lib.sh index eeefd664..558f593c 100644 --- a/build-aux/configure-lib.sh +++ b/build-aux/configure-lib.sh @@ -431,6 +431,7 @@ fi mes_SOURCES=" src/builtins.c +src/display.c src/eval-apply.c src/gc.c src/hash.c diff --git a/build-aux/snarf.sh b/build-aux/snarf.sh index 292f545e..7517f13d 100755 --- a/build-aux/snarf.sh +++ b/build-aux/snarf.sh @@ -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 diff --git a/include/mes/builtins.h b/include/mes/builtins.h index 6e173328..0f0faff8 100644 --- a/include/mes/builtins.h +++ b/include/mes/builtins.h @@ -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); diff --git a/simple.make b/simple.make index bc4f40ce..24149fac 100644 --- a/simple.make +++ b/simple.make @@ -48,6 +48,7 @@ CFLAGS:= \ MES_SOURCES = \ src/builtins.c \ + src/display.c \ src/eval-apply.c \ src/gc.c \ src/hash.c \ diff --git a/src/builtins.c b/src/builtins.c index 03df4e99..f441e27d 100644 --- a/src/builtins.c +++ b/src/builtins.c @@ -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, ¯o_get_handle, a); - a = init_builtin (builtin_type, "get-macro", 1, &get_macro, a); - a = init_builtin (builtin_type, "macro-set!", 2, ¯o_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, ¤t_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); diff --git a/src/display.c b/src/display.c new file mode 100644 index 00000000..2b9ac7f7 --- /dev/null +++ b/src/display.c @@ -0,0 +1,288 @@ +/* -*-comment-start: "//";comment-end:""-*- + * GNU Mes --- Maxwell Equations of Software + * Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen + * + * 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 . + */ + +#include "mes/lib.h" +#include "mes/mes.h" + +#include + +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 ("#", fd); + } + else if (t == TMACRO) + { + fdputs ("#", fd); + } + else if (t == TVARIABLE) + { + 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 ("#", 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); +} diff --git a/src/lib.c b/src/lib.c index 694b6d98..b9fa9561 100644 --- a/src/lib.c +++ b/src/lib.c @@ -24,270 +24,6 @@ #include -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 ("#", fd); - } - else if (t == TMACRO) - { - fdputs ("#", fd); - } - else if (t == TVARIABLE) - { - 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 ("#", 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")) */ {