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.
This commit is contained in:
Jan Nieuwenhuizen 2018-04-29 17:48:38 +02:00
parent c20ef52f6f
commit dc24a7f76f
No known key found for this signature in database
GPG Key ID: F3C1A0D9C1D65273
9 changed files with 152 additions and 154 deletions

View File

@ -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 "#<macro " port)
(display (core:cdr x) port)
(display ">" port))
((port? x)
(display "#<port " port)
(display (core:cdr x) port)
(display (core:car x) port)
(display ">" port))
((variable? x)
(display "#<variable " port)
(display (car (core:car x)) port)
(write (list->string (car (core:car x))) port)
(display ">" port))
((number? x)
(display (number->string x) port))

View File

@ -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) "."

View File

@ -72,9 +72,9 @@
(define <cell:keyword> 4)
(define <cell:number> 6)
(define <cell:pair> 7)
(define <cell:string> 9)
(define <cell:symbol> 10)
(define <cell:vector> 14)
(define <cell:string> 10)
(define <cell:symbol> 11)
(define <cell:vector> 15)
(define (core:type x)
(cond ((guile:keyword? x) <cell:keyword>)

View File

@ -77,8 +77,8 @@
(define (pair? x)
(eq? (core:type x) <cell:pair>))
(define (pair? x)
(eq? (core:type x) <cell:pair>))
(define (port? x)
(eq? (core:type x) <cell:port>))
(define (special? x)
(eq? (core:type x) <cell:special>))

View File

@ -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)
{

View File

@ -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 ("#<port ", fd);
fputs (itoa (PORT (x)), fd);
fputs (" " ,fd);
}
if (TYPE (x) == TKEYWORD)
fputs ("#:", fd);
if (write_p && TYPE (x) == TSTRING)
if ((write_p && TYPE (x) == TSTRING) || TYPE (x) == TPORT)
fputc ('"', fd);
SCM t = CAR (x);
while (t && t != cell_nil)
@ -167,8 +174,10 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
}
t = CDR (t);
}
if (write_p && TYPE (x) == TSTRING)
if ((write_p && TYPE (x) == TSTRING) || TYPE (x) == TPORT)
fputc ('"', fd);
if (TYPE (x) == TPORT)
fputs (">", fd);
break;
}
case TVECTOR:

View File

@ -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, "<cell:keyword>",0};
struct scm scm_type_macro = {TSYMBOL, "<cell:macro>",0};
struct scm scm_type_number = {TSYMBOL, "<cell:number>",0};
struct scm scm_type_pair = {TSYMBOL, "<cell:pair>",0};
struct scm scm_type_port = {TSYMBOL, "<cell:port>",0};
struct scm scm_type_ref = {TSYMBOL, "<cell:ref>",0};
struct scm scm_type_special = {TSYMBOL, "<cell:special>",0};
struct scm scm_type_string = {TSYMBOL, "<cell:string>",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);

View File

@ -23,17 +23,43 @@
#include <stdlib.h>
#include <unistd.h>
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

View File

@ -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);
}