From 49f1c4e5f3dfb67c93408cda7236845d45495f79 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 24 Dec 2016 22:16:53 +0100 Subject: [PATCH] Refactor reader. * module/mes/read-0.mes (read-hash): New function. (read-word): Use it. (eat-whitespace): Rewrite. (display): Minimal implementation through core. * lib.c (stderr_): Support printing of strings while booting. --- mes.c | 1 + module/mes/read-0.mes | 130 ++++++++++++++++++++---------------------- posix.c | 6 +- 3 files changed, 68 insertions(+), 69 deletions(-) diff --git a/mes.c b/mes.c index 4f8596a8..d61a8b59 100644 --- a/mes.c +++ b/mes.c @@ -101,6 +101,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_write = {SYMBOL, "write"}; scm scm_symbol_display = {SYMBOL, "display"}; scm scm_symbol_car = {SYMBOL, "car"}; diff --git a/module/mes/read-0.mes b/module/mes/read-0.mes index 012a01bb..de08eb87 100644 --- a/module/mes/read-0.mes +++ b/module/mes/read-0.mes @@ -108,8 +108,8 @@ (define 3) (define 9) - (define (newline) (core:stderr (integer->char 10))) - (define (display x . reset) #f) + (define (newline . rest) (core:stderr (list->string (list (integer->char 10))))) + (define (display x . rest) (core:stderr x)) (define (list->symbol lst) (make-symbol lst)) @@ -148,31 +148,29 @@ (if (pair? (cdr clauses)) (cons (quote cond) (cdr clauses)))))) - (define (eat-whitespace) - ((lambda (c) - (cond - ((eq? c 32) (read-byte) (eat-whitespace)) - ((eq? c 10) (read-byte) (eat-whitespace)) - ((eq? c 9) (read-byte) (eat-whitespace)) - ((eq? c 12) (read-byte) (eat-whitespace)) - ((eq? c 13) (read-byte) (eat-whitespace)) - ((eq? c 59) (begin (read-line-comment (read-byte)) - (eat-whitespace))) - ((eq? c 35) (begin (read-byte) - (cond ((eq? (peek-byte) 33) - (read-byte) - (read-block-comment 33 (read-byte)) - (eat-whitespace)) - ((eq? (peek-byte) 59) - (read-byte) - (read-word (read-byte) (list) (list)) - (eat-whitespace)) - ((eq? (peek-byte) 124) - (read-byte) - (read-block-comment 124 (read-byte)) - (eat-whitespace)) - (#t (unread-byte 35))))))) - (peek-byte))) + (define (eat-whitespace c) + (cond + ((eq? c 32) (eat-whitespace (read-byte))) + ((eq? c 10) (eat-whitespace (read-byte))) + ((eq? c 9) (eat-whitespace (read-byte))) + ((eq? c 12) (eat-whitespace (read-byte))) + ((eq? c 13) (eat-whitespace (read-byte))) + ((eq? c 59) (begin (read-line-comment c) + (eat-whitespace (read-byte)))) + ((eq? c 35) (cond ((eq? (peek-byte) 33) + (read-byte) + (read-block-comment 33 (read-byte)) + (eat-whitespace (read-byte))) + ((eq? (peek-byte) 59) + (read-byte) + (read-word (read-byte) (list) (list)) + (eat-whitespace (read-byte))) + ((eq? (peek-byte) 124) + (read-byte) + (read-block-comment 124 (read-byte)) + (eat-whitespace (read-byte))) + (#t (unread-byte 35)))) + (#t (unread-byte c)))) (define (read-block-comment s c) (if (eq? c s) (if (eq? (peek-byte) 35) (read-byte) @@ -184,7 +182,7 @@ (read-line-comment (read-byte)))) (define (read-list a) - (eat-whitespace) + (eat-whitespace (read-byte)) (if (eq? (peek-byte) 41) (begin (read-byte) (list)) ((lambda (w) (if (eq? w *dot*) (car (read-list a)) @@ -272,51 +270,47 @@ (define (lookup w a) (core:lookup (map1 integer->char w) a)) + (define (read-hash c w a) + (cond + ((eq? c 33) (begin (read-block-comment 33 (read-byte)) + (read-word (read-byte) w a))) + ((eq? c 124) (begin (read-block-comment 124 (read-byte)) + (read-word (read-byte) w a))) + ((eq? c 40) (list->vector (read-list a))) + ((eq? c 92) (read-character)) + ((eq? c 120) (read-hex)) + ((eq? c 44) (cond ((eq? (peek-byte) 64) + (read-byte) + (cons (quote unsyntax-splicing) + (cons (read-word (read-byte) w a) w))) + (#t (cons (quote unsyntax) + (cons (read-word (read-byte) w a) w))))) + ((eq? c 39) (cons (quote syntax) (cons (read-word (read-byte) w a) w))) + ((eq? c 58) (symbol->keyword (read-word (read-byte) w a))) + ((eq? c 59) (begin (read-word (read-byte) w a) + (read-word (read-byte) w a))) + ((eq? c 96) (cons (quote quasisyntax) + (cons (read-word (read-byte) w a) w))) + (#t (read-word c (append2 w (cons 35 w)) a)))) + (define (read-word c w a) (cond - ((eq? c 32) (if (null? w) (read-word (read-byte) (list) a) (lookup w a))) - ((eq? c 10) (read-word 32 w a)) - ((eq? c 9) (read-word 32 w a)) - ((eq? c 12) (read-word 32 w a)) - ((eq? c 34) (if (null? w) (read-string) - (begin (unread-byte c) (lookup w a)))) - ((eq? c 35) (cond - ((eq? (peek-byte) 33) (begin (read-byte) - (read-block-comment 33 (read-byte)) - (read-word (read-byte) w a))) - ((eq? (peek-byte) 124) (begin (read-byte) - (read-block-comment 124 (read-byte)) - (read-word (read-byte) w a))) - ((eq? (peek-byte) 40) (read-byte) (list->vector (read-list a))) - ((eq? (peek-byte) 92) (read-byte) (read-character)) - ((eq? (peek-byte) 120) (read-byte) (read-hex)) - ((eq? (peek-byte) 44) - (read-byte) - (cond ((eq? (peek-byte) 64) - (read-byte) - (cons (quote unsyntax-splicing) - (cons (read-word (read-byte) w a) (list)))) - (#t - (cons (quote unsyntax) - (cons (read-word (read-byte) w a) (list)))))) - ((eq? (peek-byte) 39) (read-byte) - (cons (quote syntax) (cons (read-word (read-byte) w a) (list)))) - ((eq? (peek-byte) 58) (read-byte) - (symbol->keyword (read-word (read-byte) (list) a))) - ((eq? (peek-byte) 59) (read-byte) - (read-word (read-byte) w a) - (read-word (read-byte) w a)) - ((eq? (peek-byte) 96) (read-byte) - (cons (quote quasisyntax) - (cons (read-word (read-byte) w a) (list)))) - (#t (read-word (read-byte) (append2 w (cons c (list))) a)))) - ((eq? c 39) (if (null? w) (cons (quote quote) - (cons (read-word (read-byte) w a) (list))) - (begin (unread-byte c) (lookup w a)))) + ((or (and (> c 96) (< c 123)) + (eq? c 45) + (eq? c 63) + (and (> c 47) (< c 58))) (read-word (read-byte) (append2 w (cons c (list))) a)) ((eq? c 40) (if (null? w) (read-list a) (begin (unread-byte c) (lookup w a)))) ((eq? c 41) (if (null? w) (quote *FOOBAR*) (begin (unread-byte c) (lookup w a)))) + ((eq? c 34) (if (null? w) (read-string) + (begin (unread-byte c) (lookup w a)))) + ((eq? c 32) (if (null? w) (read-word (read-byte) (list) a) (lookup w a))) + ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a) (lookup w a))) + ((eq? c 35) (read-hash (read-byte) w a)) + ((eq? c 39) (if (null? w) (cons (quote quote) + (cons (read-word (read-byte) w a) (list))) + (begin (unread-byte c) (lookup w a)))) ((eq? c 44) (cond ((eq? (peek-byte) 64) (begin (read-byte) @@ -327,6 +321,8 @@ (cons (read-word (read-byte) w a) (list)))))) ((eq? c 96) (cons (quote quasiquote) (cons (read-word (read-byte) w a) (list)))) ((eq? c 59) (read-line-comment c) (read-word 10 w a)) + ((eq? c 9) (read-word 32 w a)) + ((eq? c 12) (read-word 32 w a)) ((eq? c -1) (list)) (#t (read-word (read-byte) (append2 w (cons c (list))) a)))) diff --git a/posix.c b/posix.c index 5a95ec7e..19197dd6 100644 --- a/posix.c +++ b/posix.c @@ -82,8 +82,10 @@ write_byte (SCM x) ///((arity . n)) SCM stderr_ (SCM x) { - SCM display; - if ((display = assq_ref_cache (cell_symbol_display, r0)) != cell_undefined) + SCM write; + if (TYPE (x) == STRING) + fprintf (stderr, string_to_cstring (x)); + else if ((write = assq_ref_cache (cell_symbol_write, 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));