From dc24a7f76f4b3df3cadedfcc347e343a17d4f06a Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 29 Apr 2018 17:48:38 +0200 Subject: [PATCH] core: Add string ports. * src/mes.c (type_t): Add TPORT. (scm_type_port): New symbol. (PORT): New macro. (MAKE_STRING_PORT): New macro. (eval_apply): Handle string ports in primitive-load. (mes_symbols): Add scm_type_port. * src/posix.c (peekchar): Handle string ports. (readchar): New function. Replace all getchar callers. (unreadchar): Likewise. * module/mes/type-0 (port?): New function. * module/mes/guile.mes (with-input-from-file): Rewrite. (open-input-string): Remove. * module/mes/guile.scm (guile): Update cell types. * src/gc.c (gc_loop): Support TPORT. * src/lib.c (display_helper): Support TPORT. * module/mes/display.mes (display): Support TPORT. --- module/mes/display.mes | 8 ++- module/mes/guile.mes | 73 ++------------------------ module/mes/guile.scm | 6 +-- module/mes/type-0.mes | 4 +- src/gc.c | 2 + src/lib.c | 13 ++++- src/mes.c | 14 +++-- src/posix.c | 72 ++++++++++++++++++++------ src/reader.c | 114 ++++++++++++++++++++--------------------- 9 files changed, 152 insertions(+), 154 deletions(-) diff --git a/module/mes/display.mes b/module/mes/display.mes index 9c1e099f..110a9470 100644 --- a/module/mes/display.mes +++ b/module/mes/display.mes @@ -23,7 +23,6 @@ ;;; Code: (mes-use-module (mes scm)) -;;(mes-use-module (mes srfi srfi-1)) (define (srfi-1:member x lst eq) (if (null? lst) #f @@ -113,9 +112,14 @@ (display "#" port)) + ((port? x) + (display "#" port)) ((variable? x) (display "#string (car (core:car x))) port) (display ">" port)) ((number? x) (display (number->string x) port)) diff --git a/module/mes/guile.mes b/module/mes/guile.mes index 8009f96d..c13e8930 100644 --- a/module/mes/guile.mes +++ b/module/mes/guile.mes @@ -22,8 +22,6 @@ ;;; Code: -(define-macro (define-module module . rest) #t) -(define-macro (use-modules . rest) #t) (define-macro (cond-expand-provide . rest) #t) (define-macro (include-from-path file) @@ -65,28 +63,9 @@ (define (port-line p) 0) (define (with-input-from-string string thunk) - (define save-peek-char peek-char) - (define save-read-char read-char) - (define save-unread-char unread-char) - (if (and=> (getenv "MES_DEBUG") (compose (cut > <> 3) string->number)) - (core:display-error (string-append "with-input-from-string: `" string "'\n"))) - (let ((tell 0) - (end (string-length string))) - (set! peek-char - (lambda () - (if (= tell end) (integer->char -1) - (string-ref string tell)))) - (set! read-char - (lambda () (if (= tell end) (integer->char -1) - (begin - (set! tell (1+ tell)) - (string-ref string (- tell 1)))))) - (set! unread-char - (lambda (c) (set! tell (1- tell)) c))) - (let ((r (thunk))) - (set! peek-char save-peek-char) - (set! read-char save-read-char) - (set! unread-char save-unread-char) + (let ((prev (set-current-input-port (open-input-string string))) + (r (thunk))) + (set-current-input-port prev) r)) (define (with-input-from-file file thunk) @@ -128,52 +107,6 @@ (core:display-error "\n") port)) -(define open-input-string - (let ((save-set-current-input-port #f) - (string-port #f)) - (lambda (string) - (if (and=> (getenv "MES_DEBUG") (compose (cut > <> 3) string->number)) - (core:display-error (string-append "open-input-string: `" string "'\n"))) - (set! save-set-current-input-port set-current-input-port) - (set! string-port (cons '*string-port* (gensym))) - (set! set-current-input-port - (let ((save-peek-char peek-char) - (save-read-char read-char) - (save-unread-char unread-char) - (tell 0) - (end (string-length string))) - (lambda (port) - (when (and=> (getenv "MES_DEBUG") (compose (cut > <> 5) string->number)) - (core:display-error (string-append "open-input-string: `" string "' save-set-current-input-port port=")) - (core:display-error port) - (core:display-error "\n")) - (if (not (equal? port string-port)) (save-set-current-input-port port) - (begin - (set! tell 0) - (set! peek-char - (lambda () (if (= tell end) (integer->char -1) - (string-ref string tell)))) - (set! read-char - (lambda () (if (= tell end) (integer->char -1) - (begin - (set! tell (1+ tell)) - (string-ref string (- tell 1)))))) - (set! unread-char - (lambda (c) (set! tell (1- tell)) c)) - (set! set-current-input-port - (lambda (port) - (when (and=> (getenv "MES_DEBUG") (compose (cut > <> 4) string->number)) - (core:display-error (string-append "open-input-string: `" string "' set-current-input-port port=")) - (core:display-error port) - (core:display-error "\n")) - (save-set-current-input-port port) - (set! peek-char save-peek-char) - (set! read-char save-read-char) - (set! unread-char save-unread-char) - (set! set-current-input-port save-set-current-input-port) - string-port))))))) - string-port))) - (define (dirname file-name) (let ((lst (filter (negate string-null?) (string-split file-name #\/)))) (if (<= (length lst) 1) "." diff --git a/module/mes/guile.scm b/module/mes/guile.scm index b519dc52..68b4e142 100644 --- a/module/mes/guile.scm +++ b/module/mes/guile.scm @@ -72,9 +72,9 @@ (define 4) (define 6) (define 7) - (define 9) - (define 10) - (define 14) + (define 10) + (define 11) + (define 15) (define (core:type x) (cond ((guile:keyword? x) ) diff --git a/module/mes/type-0.mes b/module/mes/type-0.mes index 18d7dbde..493b5ecc 100644 --- a/module/mes/type-0.mes +++ b/module/mes/type-0.mes @@ -77,8 +77,8 @@ (define (pair? x) (eq? (core:type x) )) -(define (pair? x) - (eq? (core:type x) )) +(define (port? x) + (eq? (core:type x) )) (define (special? x) (eq? (core:type x) )) diff --git a/src/gc.c b/src/gc.c index 680a30d5..cd7079bf 100644 --- a/src/gc.c +++ b/src/gc.c @@ -108,6 +108,7 @@ gc_loop (SCM scan) ///((internal)) || NTYPE (scan) == TKEYWORD || NTYPE (scan) == TMACRO || NTYPE (scan) == TPAIR + || NTYPE (scan) == TPORT || NTYPE (scan) == TREF || scan == 1 // null || NTYPE (scan) == TSPECIAL @@ -197,6 +198,7 @@ gc_ () ///((internal)) gc_copy (i); g_symbols = gc_copy (g_symbols); g_macros = gc_copy (g_macros); + g_ports = gc_copy (g_ports); SCM new = gc_copy (g_stack); if (g_debug > 3) { diff --git a/src/lib.c b/src/lib.c index 18045908..1dbbbf53 100644 --- a/src/lib.c +++ b/src/lib.c @@ -131,13 +131,20 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p) break; } case TKEYWORD: + case TPORT: case TSPECIAL: case TSTRING: case TSYMBOL: { + if (TYPE (x) == TPORT) + { + fputs ("#", fd); break; } case TVECTOR: diff --git a/src/mes.c b/src/mes.c index c0aae433..6f3c4a51 100644 --- a/src/mes.c +++ b/src/mes.c @@ -53,10 +53,11 @@ SCM r2 = 0; // continuation SCM r3 = 0; // macro -SCM g_macros = 1; // cell_nil +SCM g_macros = 1; +SCM g_ports = 1; -enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART}; +enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART}; #if !_POSIX_SOURCE struct scm { @@ -99,12 +100,12 @@ struct scm { union { int value; int function; + int port; SCM cdr; SCM closure; SCM continuation; SCM macro; SCM vector; - int hits; }; }; #endif @@ -224,6 +225,7 @@ struct scm scm_type_keyword = {TSYMBOL, "",0}; struct scm scm_type_macro = {TSYMBOL, "",0}; struct scm scm_type_number = {TSYMBOL, "",0}; struct scm scm_type_pair = {TSYMBOL, "",0}; +struct scm scm_type_port = {TSYMBOL, "",0}; struct scm scm_type_ref = {TSYMBOL, "",0}; struct scm scm_type_special = {TSYMBOL, "",0}; struct scm scm_type_string = {TSYMBOL, "",0}; @@ -285,6 +287,7 @@ int g_function = 0; #define FUNCTION(x) g_functions[g_cells[x].cdr] #define FUNCTION0(x) g_functions[g_cells[x].cdr].function #define MACRO(x) g_cells[x].cdr +#define PORT(x) g_cells[x].cdr #define VALUE(x) g_cells[x].cdr #define VECTOR(x) g_cells[x].cdr @@ -303,6 +306,7 @@ int g_function = 0; #define CLOSURE(x) g_cells[x].closure #define MACRO(x) g_cells[x].macro +#define PORT(x) g_cells[x].port #define REF(x) g_cells[x].ref #define VALUE(x) g_cells[x].value #define VECTOR(x) g_cells[x].vector @@ -321,6 +325,7 @@ int g_function = 0; #define MAKE_REF(n) make_cell__ (TREF, n, 0) #define MAKE_STRING(x) make_cell__ (TSTRING, x, 0) #define MAKE_KEYWORD(x) make_cell__ (TKEYWORD, x, 0) +#define MAKE_STRING_PORT(x) make_cell__ (TPORT, x, -length__ (g_ports) - 2) #define MAKE_MACRO(name, x) make_cell__ (TMACRO, STRING (name), x) #define CAAR(x) CAR (CAR (x)) @@ -1436,6 +1441,8 @@ eval_apply () ; else if (TYPE (r1) == TSTRING) input = set_current_input_port (open_input_file (r1)); + else if (TYPE (r1) == TPORT) + input = set_current_input_port (r1); else assert (0); @@ -1977,6 +1984,7 @@ g_cells[cell_test].car = cstring_to_list (scm_test.name); a = acons (cell_type_macro, MAKE_NUMBER (TMACRO), a); a = acons (cell_type_number, MAKE_NUMBER (TNUMBER), a); a = acons (cell_type_pair, MAKE_NUMBER (TPAIR), a); + a = acons (cell_type_port, MAKE_NUMBER (TPORT), a); a = acons (cell_type_ref, MAKE_NUMBER (TREF), a); a = acons (cell_type_special, MAKE_NUMBER (TSPECIAL), a); a = acons (cell_type_string, MAKE_NUMBER (TSTRING), a); diff --git a/src/posix.c b/src/posix.c index 5986020b..2d483c9a 100644 --- a/src/posix.c +++ b/src/posix.c @@ -23,17 +23,43 @@ #include #include -int -ungetchar (int c) -{ - return ungetc (c, g_stdin); -} +int readchar (); +int unreadchar (); int peekchar () { - int c = getchar (); - ungetchar (c); + if (g_stdin >= 0) + { + int c = readchar (); + unreadchar (c); + return c; + } + SCM port = current_input_port (); + return VALUE (CAR (STRING (port))); +} + +int +readchar () +{ + if (g_stdin >= 0) + return getchar (); + SCM port = current_input_port (); + SCM string = STRING (port); + if (string == cell_nil) + return -1; + int c = VALUE (CAR (string)); + STRING (port) = CDR (string); + return c; +} + +int +unreadchar (int c) +{ + if (g_stdin >= 0) + return ungetc (c, g_stdin); + SCM port = current_input_port (); + STRING (port) = cons (MAKE_CHAR (c), STRING (port)); return c; } @@ -46,13 +72,13 @@ peek_byte () SCM read_byte () { - return MAKE_NUMBER (getchar ()); + return MAKE_NUMBER (readchar ()); } SCM unread_byte (SCM i) { - ungetchar (VALUE (i)); + unreadchar (VALUE (i)); return i; } @@ -65,13 +91,13 @@ peek_char () SCM read_char () { - return MAKE_CHAR (getchar ()); + return MAKE_CHAR (readchar ()); } SCM unread_char (SCM i) { - ungetchar (VALUE (i)); + unreadchar (VALUE (i)); return i; } @@ -155,7 +181,12 @@ access_p (SCM file_name, SCM mode) SCM current_input_port () { - return MAKE_NUMBER (g_stdin); + if (g_stdin >= 0) + return MAKE_NUMBER (g_stdin); + SCM x = g_ports; + while (x && PORT (CAR (x)) != g_stdin) + x = CDR (x); + return CAR (x); } SCM @@ -164,12 +195,23 @@ open_input_file (SCM file_name) return MAKE_NUMBER (open (string_to_cstring (file_name), O_RDONLY)); } +SCM +open_input_string (SCM string) +{ + SCM port = MAKE_STRING_PORT (STRING (string)); + g_ports = cons (port, g_ports); + return port; +} + SCM set_current_input_port (SCM port) { - int prev = g_stdin; - g_stdin = VALUE (port) ? VALUE (port) : STDIN; - return MAKE_NUMBER (prev); + SCM prev = current_input_port (); + if (TYPE (port) == TNUMBER) + g_stdin = VALUE (port) ? VALUE (port) : STDIN; + else if (TYPE (port) == TPORT) + g_stdin = PORT (port); + return prev; } SCM diff --git a/src/reader.c b/src/reader.c index d012f6a5..098f6370 100644 --- a/src/reader.c +++ b/src/reader.c @@ -44,7 +44,7 @@ reader_read_line_comment (int c) { if (c == '\n') return c; - return reader_read_line_comment (getchar ()); + return reader_read_line_comment (readchar ()); } SCM reader_read_block_comment (int s, int c); @@ -71,22 +71,22 @@ reader_read_identifier_or_number (int c) int n = 0; int negative_p = 0; if (c == '+' && isdigit (peekchar ())) - c = getchar (); + c = readchar (); else if (c == '-' && isdigit (peekchar ())) { negative_p = 1; - c = getchar (); + c = readchar (); } while (isdigit (c)) { buf[i++] = c; n *= 10; n += c - '0'; - c = getchar (); + c = readchar (); } if (reader_end_of_word_p (c)) { - ungetchar (c); + unreadchar (c); if (negative_p) n = 0 - n; return MAKE_NUMBER (n); @@ -94,9 +94,9 @@ reader_read_identifier_or_number (int c) while (!reader_end_of_word_p (c)) { buf[i++] = c; - c = getchar (); + c = readchar (); } - ungetchar (c); + unreadchar (c); buf[i] = 0; return lookup_symbol_ (cstring_to_list (buf)); } @@ -115,28 +115,28 @@ reader_read_sexp_ (int c, SCM a) case '\t': case '\n': case '\f': - return reader_read_sexp_ (getchar (), a); + return reader_read_sexp_ (readchar (), a); case '(': - return reader_read_list (getchar (), a); + return reader_read_list (readchar (), a); case ')': return cell_nil; case '#': - return reader_read_hash (getchar (), a); + return reader_read_hash (readchar (), a); case '`': return cons (cell_symbol_quasiquote, - cons (reader_read_sexp_ (getchar (), a), cell_nil)); + cons (reader_read_sexp_ (readchar (), a), cell_nil)); case ',': if (peekchar () == '@') { - getchar (); + readchar (); return cons (cell_symbol_unquote_splicing, - cons (reader_read_sexp_ (getchar (), a), cell_nil)); + cons (reader_read_sexp_ (readchar (), a), cell_nil)); } return cons (cell_symbol_unquote, - cons (reader_read_sexp_ (getchar (), a), cell_nil)); + cons (reader_read_sexp_ (readchar (), a), cell_nil)); case '\'': return cons (cell_symbol_quote, - cons (reader_read_sexp_ (getchar (), a), cell_nil)); + cons (reader_read_sexp_ (readchar (), a), cell_nil)); case '"': return reader_read_string (); case '.': @@ -151,14 +151,14 @@ int reader_eat_whitespace (int c) { while (isspace (c)) - c = getchar (); + c = readchar (); if (c == ';') return reader_eat_whitespace (reader_read_line_comment (c)); if (c == '#' && (peekchar () == '!' || peekchar () == '|')) { - c=getchar (); - reader_read_block_comment (c, getchar ()); - return reader_eat_whitespace (getchar ()); + c=readchar (); + reader_read_block_comment (c, readchar ()); + return reader_eat_whitespace (readchar ()); } return c; } @@ -174,21 +174,21 @@ reader_read_list (int c, SCM a) //return cell_nil; SCM s = reader_read_sexp_ (c, a); if (s == cell_dot) - return CAR (reader_read_list (getchar (), a)); - return cons (s, reader_read_list (getchar (), a)); + return CAR (reader_read_list (readchar (), a)); + return cons (s, reader_read_list (readchar (), a)); } SCM read_env (SCM a) { - return reader_read_sexp_ (getchar (), a); + return reader_read_sexp_ (readchar (), a); } SCM reader_read_block_comment (int s, int c) { - if (c == s && peekchar () == '#') return getchar (); - return reader_read_block_comment (s, getchar ()); + if (c == s && peekchar () == '#') return readchar (); + return reader_read_block_comment (s, readchar ()); } SCM @@ -197,11 +197,11 @@ reader_read_hash (int c, SCM a) switch (c) { case '!': - reader_read_block_comment (c, getchar ()); - return reader_read_sexp_ (getchar (), a); + reader_read_block_comment (c, readchar ()); + return reader_read_sexp_ (readchar (), a); case '|': - reader_read_block_comment (c, getchar ()); - return reader_read_sexp_ (getchar (), a); + reader_read_block_comment (c, readchar ()); + return reader_read_sexp_ (readchar (), a); case 'f': return cell_f; case 't': @@ -209,21 +209,21 @@ reader_read_hash (int c, SCM a) case ',': if (peekchar () == '@') { - getchar (); + readchar (); return cons (cell_symbol_unsyntax_splicing, - cons (reader_read_sexp_ (getchar (), a), + cons (reader_read_sexp_ (readchar (), a), cell_nil)); } return cons (cell_symbol_unsyntax, - cons (reader_read_sexp_ (getchar (), a), cell_nil)); + cons (reader_read_sexp_ (readchar (), a), cell_nil)); case '\'': return cons (cell_symbol_syntax, - cons (reader_read_sexp_ (getchar (), a), cell_nil)); + cons (reader_read_sexp_ (readchar (), a), cell_nil)); case '`': return cons (cell_symbol_quasisyntax, - cons (reader_read_sexp_ (getchar (), a), cell_nil)); + cons (reader_read_sexp_ (readchar (), a), cell_nil)); case ':': - return MAKE_KEYWORD (CAR (reader_read_sexp_ (getchar (), a))); + return MAKE_KEYWORD (CAR (reader_read_sexp_ (readchar (), a))); case 'o': return reader_read_octal (); case 'x': @@ -231,12 +231,12 @@ reader_read_hash (int c, SCM a) case '\\': return reader_read_character (); case '(': - return list_to_vector (reader_read_list (getchar (), a)); + return list_to_vector (reader_read_list (readchar (), a)); case ';': - reader_read_sexp_ (getchar (), a); - return reader_read_sexp_ (getchar (), a); + reader_read_sexp_ (readchar (), a); + return reader_read_sexp_ (readchar (), a); } - return reader_read_sexp_ (getchar (), a); + return reader_read_sexp_ (readchar (), a); } SCM @@ -248,7 +248,7 @@ reader_read_sexp (SCM c, SCM s, SCM a) SCM reader_read_character () { - int c = getchar (); + int c = readchar (); if (c >= '0' && c <= '7' && peekchar () >= '0' && peekchar () <= '7') { @@ -256,7 +256,7 @@ reader_read_character () while (peekchar () >= '0' && peekchar () <= '7') { c <<= 3; - c += getchar () - '0'; + c += readchar () - '0'; } } else if (((c >= 'a' && c <= 'z') @@ -270,7 +270,7 @@ reader_read_character () while ((peekchar () >= 'a' && peekchar () <= 'z') || peekchar () == '*') { - *p++ = getchar (); + *p++ = readchar (); } *p = 0; if (!strcmp (buf, "*eof*")) c = EOF; @@ -325,12 +325,12 @@ reader_read_octal () int n = 0; int c = peekchar (); int s = 1; - if (c == '-') {s = -1;getchar (); c = peekchar ();} + if (c == '-') {s = -1;readchar (); c = peekchar ();} while (c >= '0' && c <= '7') { n <<= 3; n+= c - '0'; - getchar (); + readchar (); c = peekchar (); } return MAKE_NUMBER (s*n); @@ -342,7 +342,7 @@ reader_read_hex () int n = 0; int c = peekchar (); int s = 1; - if (c == '-') {s = -1;getchar (); c = peekchar ();} + if (c == '-') {s = -1;readchar (); c = peekchar ();} while ((c >= '0' && c <= '9') || (c >= 'A' && c <= 'F') || (c >= 'a' && c <= 'f')) @@ -351,7 +351,7 @@ reader_read_hex () if (c >= 'a') n += c - 'a' + 10; else if (c >= 'A') n += c - 'A' + 10; else n+= c - '0'; - getchar (); + readchar (); c = peekchar (); } return MAKE_NUMBER (s*n); @@ -363,7 +363,7 @@ reader_read_string () char buf[1024]; SCM lst = cell_nil; int i = 0; - int c = getchar (); + int c = readchar (); while (1) { if (c == '"' || i > 1022) @@ -378,52 +378,52 @@ reader_read_string () { int p = peekchar (); if (p == '\\' || p == '"') - buf[i++] = getchar (); + buf[i++] = readchar (); else if (p == '0') { - getchar (); + readchar (); buf[i++] = '\0'; } else if (p == 'a') { - getchar (); + readchar (); buf[i++] = '\a'; } else if (p == 'b') { - getchar (); + readchar (); buf[i++] = '\b'; } else if (p == 't') { - getchar (); + readchar (); buf[i++] = '\t'; } else if (p == 'n') { - getchar (); + readchar (); buf[i++] = '\n'; } else if (p == 'v') { - getchar (); + readchar (); buf[i++] = '\v'; } else if (p == 'f') { - getchar (); + readchar (); buf[i++] = '\f'; } else if (p == 'r') { - getchar (); + readchar (); //Nyacc bug //buf[i++] = '\r'; buf[i++] = 13; } else if (p == 'e') { - getchar (); + readchar (); //buf[i++] = '\e'; buf[i++] = 27; } @@ -434,7 +434,7 @@ reader_read_string () #endif else buf[i++] = c; - c = getchar (); + c = readchar (); } return MAKE_STRING (lst); }