diff --git a/GNUmakefile b/GNUmakefile index c68ad086..df4bd28d 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -29,7 +29,6 @@ all: mes module/mes/read-0.mo mes.o: GNUmakefile mes.o: mes.c mes.o: mes.c mes.h mes.i mes.environment.i mes.symbols.i -mes.o: display.c display.h display.i display.environment.i mes.o: lib.c lib.h lib.i lib.environment.i mes.o: math.c math.h math.i math.environment.i mes.o: posix.c posix.h posix.i posix.environment.i diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm index 53c21f14..97499e39 100755 --- a/build-aux/mes-snarf.scm +++ b/build-aux/mes-snarf.scm @@ -106,6 +106,7 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e (define (function->environment f i) (string-append (format #f "scm_~a.string = cstring_to_list (scm_~a.name);\n" (.name f) (.name f)) + (format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (.name f) (.name f)) (format #f "a = acons (make_symbol (scm_~a.string), ~a, a);\n" (.name f) (function-cell-name f)) ;;(format #f "a = add_environment (a, ~S, ~a);\n" (function-scm-name f) (function-cell-name f)) )) diff --git a/display.c b/display.c deleted file mode 100644 index 4b21c54f..00000000 --- a/display.c +++ /dev/null @@ -1,166 +0,0 @@ -/* -*-comment-start: "//";comment-end:""-*- - * Mes --- Maxwell Equations of Software - * Copyright © 2016 Jan Nieuwenhuizen - * - * 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 . - */ - -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 CLOSURE: - { - fprintf (f, "#"); - return cell_unspecified; - } - 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_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 && TYPE (cdr (x)) != PAIR) { - fprintf (f, "'"); - x = cdr (x); - if (TYPE (x) != FUNCTION) - x = car (x); - return display_helper (f, x, cont, "", true); - } - if (!cont) fprintf (f, "("); - if (x && x!= cell_nil) display_ (f, car (x)); - if (cdr (x) && TYPE (cdr (x)) == PAIR) - display_helper (f, cdr (x), true, " ", false); - else if (cdr (x) && 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, "#= 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; -} diff --git a/lib.c b/lib.c index 57bafd9e..06a6f8e2 100644 --- a/lib.c +++ b/lib.c @@ -55,3 +55,30 @@ exit_ (SCM x) ///((name . "exit")) assert (TYPE (x) == NUMBER); exit (VALUE (x)); } + +char const* +string_to_cstring (SCM s) +{ + static char buf[1024]; + char *p = buf; + s = STRING (s); + while (s != cell_nil) + { + *p++ = VALUE (car (s)); + s = cdr (s); + } + *p = 0; + return buf; +} + +SCM +assert_defined (SCM x, SCM e) +{ + if (e == cell_undefined) + { + fprintf (stderr, "eval: unbound variable:"); + stderr_ (x); + assert (!"unbound variable"); + } + return e; +} diff --git a/mes.c b/mes.c index dd811549..dd73f2d4 100644 --- a/mes.c +++ b/mes.c @@ -111,6 +111,7 @@ scm scm_symbol_call_with_values = {SYMBOL, "call-with-values"}; scm scm_symbol_current_module = {SYMBOL, "current-module"}; scm scm_symbol_primitive_load = {SYMBOL, "primitive-load"}; scm scm_symbol_read_input_file = {SYMBOL, "read-input-file"}; +scm scm_symbol_display = {SYMBOL, "display"}; scm scm_symbol_car = {SYMBOL, "car"}; scm scm_symbol_cdr = {SYMBOL, "cdr"}; @@ -118,17 +119,6 @@ scm scm_symbol_null_p = {SYMBOL, "null?"}; scm scm_symbol_eq_p = {SYMBOL, "eq?"}; scm scm_symbol_cons = {SYMBOL, "cons"}; -scm char_eof = {CHAR, .name="*eof*", .value=-1}; -scm char_nul = {CHAR, .name="nul", .value=0}; -scm char_alarm = {CHAR, .name="alarm", .value=8}; -scm char_backspace = {CHAR, .name="backspace", .value=8}; -scm char_tab = {CHAR, .name="tab", .value=9}; -scm char_newline = {CHAR, .name="newline", .value=10}; -scm char_vtab = {CHAR, .name="vtab", .value=11}; -scm char_page = {CHAR, .name="page", .value=12}; -scm char_return = {CHAR, .name="return", .value=13}; -scm char_space = {CHAR, .name="space", .value=32}; - scm g_free = {NUMBER, .value=0}; scm *g_cells; scm *g_news = 0; @@ -151,7 +141,6 @@ SCM r1 = 0; // param 1 SCM r2 = 0; // param 2 SCM r3 = 0; // param 3 -#include "display.h" #include "lib.h" #include "math.h" #include "mes.h" @@ -187,7 +176,6 @@ SCM r3 = 0; // param 3 #define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0); #define MAKE_STRING(x) make_cell (tmp_num_ (STRING), x, 0); -SCM display_ (FILE* f, SCM x); SCM vm_call (function0_t f, SCM p1, SCM p2, SCM a); SCM @@ -344,19 +332,6 @@ assq_ref_cache (SCM x, SCM a) return cdr (x); } -SCM -assert_defined (SCM x, SCM e) -{ - if (e == cell_undefined) - { - fprintf (stderr, "eval: unbound variable:"); - display_ (stderr, x); - fprintf (stderr, "\n"); - assert (!"unbound variable"); - } - return e; -} - enum eval_apply_t {EVLIS, APPLY, EVAL, MACRO_EXPAND, BEGIN, IF, CALL_WITH_VALUES}; enum eval_apply_t g_target; @@ -452,9 +427,9 @@ eval_apply () if (type) { fprintf (stderr, "cannot apply: %s: ", type); - display_ (stderr, e); + stderr_ (e); fprintf (stderr, " ["); - display_ (stderr, r1); + stderr_ (r1); fprintf (stderr, "]\n"); assert (!"cannot apply"); } @@ -747,6 +722,13 @@ make_vector (SCM n) return x; } +SCM +arity_ (SCM x) +{ + assert (TYPE (x) == FUNCTION); + return MAKE_NUMBER (FUNCTION (x).arity); +} + SCM values (SCM x) ///((arity . n)) { @@ -924,6 +906,7 @@ gc_loop (SCM scan) while (scan < g_free.value) { if (NTYPE (scan) == CLOSURE + || NTYPE (scan) == FUNCTION || NTYPE (scan) == KEYWORD || NTYPE (scan) == MACRO || NTYPE (scan) == PAIR @@ -1057,13 +1040,11 @@ mes_builtins (SCM a) { #include "mes.i" -#include "display.i" #include "lib.i" #include "math.i" #include "posix.i" #include "reader.i" -#include "display.environment.i" #include "lib.environment.i" #include "math.environment.i" #include "mes.environment.i" @@ -1179,7 +1160,6 @@ dump () return 0; } -#include "display.c" #include "lib.c" #include "math.c" #include "posix.c" @@ -1197,7 +1177,7 @@ main (int argc, char *argv[]) SCM program = (argc > 1 && !strcmp (argv[1], "--load")) ? bload_env (r0) : load_env (r0); if (argc > 1 && !strcmp (argv[1], "--dump")) return dump (); - display_ (stderr, begin_env (program, r0)); + stderr_ (begin_env (program, r0)); fputs ("", stderr); gc (stack); if (g_debug) fprintf (stderr, "\nstats: [%d]\n", g_free.value); diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes index 21d127d6..2ac99432 100644 --- a/module/mes/base-0.mes +++ b/module/mes/base-0.mes @@ -108,6 +108,9 @@ 'o)) (define-macro (load file) (list 'begin + (list core:stderr "read ") + (list core:stderr file) + (list core:stderr "\n") (list 'push! '*input-ports* (list current-input-port)) (list 'set-current-input-port (list open-input-file file)) (list 'primitive-load) @@ -150,12 +153,13 @@ (list 'begin (list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*)) - ;; (list display "loading file=" (list current-error-port)) - ;; (list display (module->file module) (list current-error-port)) - ;; (list newline (list current-error-port)) + ;; (list core:stderr "read ") + ;; (list core:stderr file) + ;; (list core:stderr "\n") (list 'load (list string-append '*mes-prefix* (module->file module))))))) (mes-use-module (srfi srfi-0)) (mes-use-module (mes base)) (mes-use-module (mes quasiquote)) (mes-use-module (mes scm)) +(mes-use-module (mes display)) diff --git a/module/mes/display.mes b/module/mes/display.mes new file mode 100644 index 00000000..0daf1feb --- /dev/null +++ b/module/mes/display.mes @@ -0,0 +1,113 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; 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 . + +;;; Commentary: + +;;; Code: + +(mes-use-module (mes scm)) + +(define (newline . rest) + (apply display (cons "\n" rest))) + +(define (display x . rest) + (let* ((port (if (null? rest) (current-output-port) (car rest))) + (write? (and (pair? rest) (pair? (cdr rest))))) + + (define-macro (cut f slot port) + `(lambda (slot) (,f slot ,port))) + + (define (d x cont? sep) + (for-each (cut write-char <> port) (string->list sep)) + (cond + ((char? x) + (write-char #\# port) + (write-char #\\ port) + (let ((name (and=> (assq x '((#\*eof* . *eof*) + (#\nul . nul) + (#\alarm . alarm) + (#\backspace . backspace) + (#\tab . tab) + (#\newline . newline) + (#\vtab . vtab) + (#\page . page) + (#\return . return) + (#\space . space))) + cdr))) + (if name (display name) + (write-char x port)))) + ((closure? x) + (display "<#procedure #f " port) + (display (cadr (core:cdr x)) port) + (display ">" port)) + ((macro? x) + (display "<#macro " port) + (display (core:cdr x) port) + (display ">" port)) + ((number? x) (display (number->string x) port)) + ((pair? x) + (if (not cont?) (write-char #\( port)) + (cond ((eq? (car x) '*circular*) + (display "(*circ* . #-1#)" port)) + ((eq? (car x) '*closure*) + (display "(*closure* . #-1#)" port)) + (#t + (display (car x) port write?) + (if (pair? (cdr x)) (d (cdr x) #t " ") + (if (and (cdr x) (not (null? (cdr x)))) + (begin + (display " . " port) + (display (cdr x) port write?)))) + (if (not cont?) (write-char #\) port))))) + ((or (keyword? x) (special? x) (string? x) (symbol? x)) + (if (and (string? x) write?) (write-char #\" port)) + (if (keyword? x) (display "#:" port)) + (for-each (cut write-char <> port) (string->list x)) + (if (and (string? x) write?) (write-char #\" port))) + ((vector? x) + (display "#(" port) + (for-each (lambda (i) + (let ((x (vector-ref x i))) + (if (vector? x) + (begin + (display (if (= i 0) "" " ") port) + (display "#(...)" port)) + (d x #f (if (= i 0) "" " "))))) + (iota (vector-length x))) + (display ")" port)) + ((function? x) + (display "<#procedure " port) + (display (core:car x) port) + (display " " port) + (display + (case (core:arity x) + ((-1) "(. x)") + ((0) "()") + ((1) "(x)") + ((2) "(x y)") + ((3) "(x y z)")) + port) + (display ">" port)) + ((broken-heart? x) + (display "<3" port)) + (#t + (display "TODO type=") (display (cell:type-name x)) (newline))) + *unspecified*) + (d x #f ""))) diff --git a/module/mes/read-0.mes b/module/mes/read-0.mes index 25c6ef99..535b34ae 100644 --- a/module/mes/read-0.mes +++ b/module/mes/read-0.mes @@ -108,6 +108,9 @@ (define 3) (define 9) + (define (newline) (core:stderr (integer->char 10))) + (define (display x . reset) #f) + (define (list->symbol lst) (make-symbol lst)) (define (symbol->list s) @@ -219,7 +222,7 @@ (egap . 12) (nruter . 13) (ecaps . 32)))) => cdr) - (#t (display (quote char-not-supported:)) (display n) (newline) (exit 1)))) + (#t (core:stderr (quote char-not-supported:)) (core:stderr n) (newline) (exit 1)))) (if (not (and (> p 96) (< p 123))) (integer->char (lookup-char (list->symbol (cons (integer->char c) n)))) (read-name (read-byte) (peek-byte) (cons (integer->char c) n)))) @@ -258,7 +261,7 @@ (read-byte) (read-string (read-byte) (peek-byte) (append-char s 10))) ((eq? c 34) s) - ((eq? c -1) (display (quote EOF-in-string)) (newline) (exit 1)) + ((eq? c -1) (core:stderr (quote EOF-in-string)) (newline) (exit 1)) (#t (read-string (read-byte) (peek-byte) (append-char s c))))) (list->string (read-string (read-byte) (peek-byte) (list)))) diff --git a/posix.c b/posix.c index e0d66311..0695a97e 100644 --- a/posix.c +++ b/posix.c @@ -20,19 +20,17 @@ #include -char const* -string_to_cstring (SCM s) +SCM +stderr_ (SCM x) { - static char buf[1024]; - char *p = buf; - s = STRING (s); - while (s != cell_nil) - { - *p++ = VALUE (car (s)); - s = cdr (s); - } - *p = 0; - return buf; + SCM display; + if ((display = assq_ref_cache (cell_symbol_display, r0)) != cell_undefined) + apply_env (assq_ref_cache (cell_symbol_display, r0), cons (x, cons (MAKE_NUMBER (2), cell_nil)), r0); + else if (TYPE (x) == SPECIAL || TYPE (x) == STRING || TYPE (x) == SYMBOL) + fprintf (stderr, string_to_cstring (x)); + else + fprintf (stderr, "display: undefined\n"); + return cell_unspecified; } SCM