From 1cd72fc8e01ab8893215cca34337e9351e5d263a Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Sat, 5 Jun 2010 22:32:14 -0500 Subject: [PATCH] Add support for reading vectors and strings. Fix choice of continuation when function ends in (call/cc). Change empty kw-args from '() to #%nil in (simplify-apply). Improve error message when no match is found for a primitive form. --- libcompiler/simplifier.scm | 12 +++- libcompiler/writer.scm | 42 +++++++----- src/reader.rls | 128 +++++++++++++++---------------------- 3 files changed, 85 insertions(+), 97 deletions(-) diff --git a/libcompiler/simplifier.scm b/libcompiler/simplifier.scm index 0733af9..e0d3953 100644 --- a/libcompiler/simplifier.scm +++ b/libcompiler/simplifier.scm @@ -145,6 +145,7 @@ (list (simplify-value-list `(value-list ,subform))))) '() subforms))] + [`(#%values) '#%nil] [`(#%values . ,simple-vals) ; (#%value-list (#%values ...)) => (list ...) (let ([tmp (gensym)]) @@ -416,8 +417,8 @@ [`(#%apply . ,sv) `((#%tail-call ,@sv ,ctx ,k))] [`(#%call/cc ,x) - `((#%set! ,argv (#%cons #%k #%nil)) - (#%tail-call ,x ,argv #%nil #%nil ,ctx #%k))] + `((#%set! ,argv (#%cons ,k #%nil)) + (#%tail-call ,x ,argv #%nil #%nil ,ctx ,k))] [`(#%values . ,simple-vals) `((#%set! ,argv #%nil) ,@(map (lambda (sv) `(#%set! ,argv (#%cons ,sv ,argv))) @@ -573,6 +574,11 @@ ,@(map (lambda (x) `(#%set! ,argv (#%cons ,x ,argv))) (reverse plain-args)) ,(simplify-form `(set! ,kw-vals (list ,@(map cdr sorted-kws)))) - (#%apply ,fn-var ,argv ',(map car sorted-kws) ,kw-vals)))) + (#%apply ,fn-var + ,argv + ,(if (null? sorted-kws) + '#%nil + `',(map car sorted-kws)) + ,kw-vals)))) ; vim:set sw=2 expandtab: diff --git a/libcompiler/writer.scm b/libcompiler/writer.scm index 4e14988..f76381c 100644 --- a/libcompiler/writer.scm +++ b/libcompiler/writer.scm @@ -201,29 +201,37 @@ [(machine-variable? value) (list #x00 out #x01 (variable->code value))] [(eq? (length (cdr value)) 1) - (list #x00 out (second (assoc (first value) unary-value-primitives)) - (variable->code (second value)))] + (let ([item (assoc (first value) unary-value-primitives)]) + (unless item (error "Invalid unary value primitive:" value)) + (list #x00 out (second item) (variable->code (second value))))] [(eq? (length (cdr value)) 2) - (list* (second (assoc (first value) binary-value-primitives)) - out (map variable->code (cdr value)))] + (let ([item (assoc (first value) binary-value-primitives)]) + (unless item (error "Invalid binary value primitive:" value)) + (list* (second item) out (map variable->code (cdr value))))] [else (unless (and (eq? (first value) '#%if) (eq? (length (cdr value)) 3)) - (error "Unsupported ternary form:" form)) + (error "Invalid ternary primitive:" form)) (list* out (map variable->code (cdr value)))])) (case (length (cdr form)) - [(1) (list (second (assoc (first form) unary-statement-primitives)) - (variable->code (second form)) - #x00 - #x00)] - [(2) (list (second (assoc (first form) binary-statement-primitives)) - (variable->code (second form)) - (variable->code (third form)) - #x00)] - [(3) (list (second (assoc (first form) ternary-statement-primitives)) - (variable->code (second form)) - (variable->code (third form)) - (variable->code (fourth form)))] + [(1) (let ([item (assoc (first form) unary-statement-primitives)]) + (unless item (error "Invalid unary statement primitive:" form)) + (list (second item) + (variable->code (second form)) + #x00 + #x00))] + [(2) (let ([item (assoc (first form) binary-statement-primitives)]) + (unless item (error "Invalid binary statement primitive:" form)) + (list (second item) + (variable->code (second form)) + (variable->code (third form)) + #x00))] + [(3) (let ([item (assoc (first form) ternary-statement-primitives)]) + (unless item (error "Invalid ternary statement primitive:" form)) + (list (second item) + (variable->code (second form)) + (variable->code (third form)) + (variable->code (fourth form))))] [else (error "Unsupported form:" form)]))) ; vim:set sw=2 expandtab: diff --git a/src/reader.rls b/src/reader.rls index 0e871af..8025b03 100644 --- a/src/reader.rls +++ b/src/reader.rls @@ -54,11 +54,13 @@ (define (read-one-value) (skip-whitespace) - (when eof? (unexpected-eof)) (cond + [eof? (unexpected-eof)] [(eq? current-char #\#) + (next-char) (read-special)] [(eq? current-char #\() + (next-char) (read-list)] [(or (eq? current-char #\-) (eq? current-char #\+) @@ -72,10 +74,8 @@ (unexpected-char)])) (define (read-special) - (next-char) - (when eof? (unexpected-eof)) - (cond + [eof? (unexpected-eof)] [(eq? current-char #\!) (unless (and (eq? line 1) (eq? column 2)) (unexpected-char)) (define (skip-until-newline) @@ -93,16 +93,20 @@ (when (symbol-char? current-char) (unexpected-char)) #t] [(eq? current-char #\&) + (next-char) (read-box)] [(eq? current-char #\() + (next-char) (read-vector)] [(memq? current-char '(#\S #\s)) (next-char) (unless (eq? current-char #\() (unexpected-char)) + (next-char) (read-struct)] [(memq? current-char '(#\W #\w)) (next-char) (unless (eq? current-char #\&) (unexpected-char)) + (next-char) (read-weak-box)] [(memq? current-char '(#\X #\x)) (next-char) @@ -122,8 +126,7 @@ (define (read-rest) (skip-whitespace) (cond - [eof? - (unexpected-eof)] + [eof? (unexpected-eof)] [(eq? current-char #\.) (next-char) (let ([lstcdr (read-one-value)]) @@ -137,10 +140,14 @@ [else (cons (read-one-value) (read-rest))])) - (next-char) - (if (eq? current-char #\)) - '() - (cons (read-one-value) (read-rest)))) + (skip-whitespace) + (cond + [eof? (unexpected-eof)] + [(eq? current-char #\)) + (next-char) + '()] + [else + (cons (read-one-value) (read-rest))])) (define (read-fixnum [radix #f]) (let/cc return @@ -172,17 +179,20 @@ (set! radix 10))) ; Need at least one digit within this radix + (when eof? (unexpected-eof)) (unless (and (alphanumeric-char? current-char) (fix< (digit->integer current-char) radix)) (unexpected-char)) (define (iter accum) - (let ([val (digit->integer current-char)]) - (if (and val (fix< val radix)) - (begin - (next-char) - (iter (fix+ (fix* accum radix) val))) - accum))) + (if eof? + accum + (let ([val (digit->integer current-char)]) + (if (and val (fix< val radix)) + (begin + (next-char) + (iter (fix+ (fix* accum radix) val))) + accum)))) (let ([pos-val (iter 0)]) (if neg? (fix- pos-val) pos-val)))) @@ -191,16 +201,14 @@ (read-fixnum)) (define (read-box) - (next-char) (make-box (read-one-value))) (define (read-weak-box) - (next-char) (let ([val (read-one-value)]) (set! weak-list (cons val weak-list)) (make-weak-box val))) - (define (read-string) + (define (read-string [end-quote current-char]) (define (read-chars [accum '()] [len 0]) (define (read-one-char) (define (skip-ws skip-nl?) @@ -213,7 +221,7 @@ (skip-ws skip-nl?))))) (when eof? (unexpected-eof)) (cond - [(eq? current-char #\") + [(eq? current-char end-quote) (next-char) #f] [(eq? current-char #\\) @@ -296,9 +304,29 @@ (iter (fix- len 1) revchars) str)))) - (define (read-vector) undefined) - (define (read-struct) undefined) - (define (read-symbol) undefined) + (define (read-vector) + (let* ([items (read-list)] + [len (list-length items)] + [vec (make-vector len #f)]) + (define (iter n rst) + (when (pair? rst) + (vector-set! vec n (car rst)) + (iter (fix+ n 1) (cdr rst)))) + (iter 0 items) + vec)) + + (define (read-struct) + (let* ([items (read-list)] + [struct (make-struct (car items))]) + (define (iter n rst) + (when (pair? rst) + (struct-set! struct n (car rst)) + (iter (fix+ n 1) (cdr rst)))) + (iter 0 (cdr items)) + struct)) + + (define (read-symbol) + undefined) (define (skip-whitespace) (unless eof? @@ -505,59 +533,5 @@ ; release_assert(!issymbol(state->ch)); ; return make_float(flt); ; } -; -; static value_t read_vector(reader_state_t *state) -; { -; gc_root_t list_root; -; size_t length = 0; -; value_t value; -; value_t item; -; -; register_gc_root(&list_root, read_list(state)); -; -; for (value_t item = list_root.value; !is_nil(item); item = CDR(item)) -; ++length; -; -; value = make_vector(length, UNDEFINED); -; -; item = list_root.value; -; for (size_t i = 0; i < length; ++i) -; { -; _get_vector(value)->elements[i] = _CAR(item); -; /* No write barrier needed here. */ -; item = _CDR(item); -; } -; -; unregister_gc_root(&list_root); -; -; return value; -; } -; -; static value_t read_struct(reader_state_t *state) -; { -; gc_root_t list_root; -; size_t slots = 0; -; value_t value; -; value_t item; -; -; register_gc_root(&list_root, read_list(state)); -; -; for (item = CDR(list_root.value); !is_nil(item); item = CDR(item)) -; ++slots; -; -; value = make_struct(_CAR(list_root.value), slots); -; -; item = _CDR(list_root.value); -; for (size_t i = 0; i < slots; ++i) -; { -; _get_struct(value)->slots[i] = _CAR(item); -; /* No write barrier needed here. */ -; item = _CDR(item); -; } -; -; unregister_gc_root(&list_root); -; -; return value; -; } ; vim:set syntax=scheme sw=2 expandtab: