nybble
/
rosella
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Jesse D. McDonald 2010-06-05 22:32:14 -05:00
parent 61b6a76205
commit 1cd72fc8e0
3 changed files with 85 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
libcompiler/simplifier.scm
View File

@ -145,6 +145,7 @@
(list (simplify-value-list `(value-list ,subform))))) (list (simplify-value-list `(value-list ,subform)))))
'() '()
subforms))] subforms))]
[`(#%values) '#%nil]
[`(#%values . ,simple-vals) [`(#%values . ,simple-vals)
; (#%value-list (#%values ...)) => (list ...) ; (#%value-list (#%values ...)) => (list ...)
(let ([tmp (gensym)]) (let ([tmp (gensym)])
@ -416,8 +417,8 @@
[`(#%apply . ,sv) [`(#%apply . ,sv)
`((#%tail-call ,@sv ,ctx ,k))] `((#%tail-call ,@sv ,ctx ,k))]
[`(#%call/cc ,x) [`(#%call/cc ,x)
`((#%set! ,argv (#%cons #%k #%nil)) `((#%set! ,argv (#%cons ,k #%nil))
(#%tail-call ,x ,argv #%nil #%nil ,ctx #%k))] (#%tail-call ,x ,argv #%nil #%nil ,ctx ,k))]
[`(#%values . ,simple-vals) [`(#%values . ,simple-vals)
`((#%set! ,argv #%nil) `((#%set! ,argv #%nil)
,@(map (lambda (sv) `(#%set! ,argv (#%cons ,sv ,argv))) ,@(map (lambda (sv) `(#%set! ,argv (#%cons ,sv ,argv)))
@ -573,6 +574,11 @@
,@(map (lambda (x) `(#%set! ,argv (#%cons ,x ,argv))) ,@(map (lambda (x) `(#%set! ,argv (#%cons ,x ,argv)))
(reverse plain-args)) (reverse plain-args))
,(simplify-form `(set! ,kw-vals (list ,@(map cdr sorted-kws)))) ,(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: ; vim:set sw=2 expandtab:

42
libcompiler/writer.scm
View File

@ -201,29 +201,37 @@
[(machine-variable? value) [(machine-variable? value)
(list #x00 out #x01 (variable->code value))] (list #x00 out #x01 (variable->code value))]
[(eq? (length (cdr value)) 1) [(eq? (length (cdr value)) 1)
(list #x00 out (second (assoc (first value) unary-value-primitives)) (let ([item (assoc (first value) unary-value-primitives)])
(variable->code (second value)))] (unless item (error "Invalid unary value primitive:" value))
(list #x00 out (second item) (variable->code (second value))))]
[(eq? (length (cdr value)) 2) [(eq? (length (cdr value)) 2)
(list* (second (assoc (first value) binary-value-primitives)) (let ([item (assoc (first value) binary-value-primitives)])
out (map variable->code (cdr value)))] (unless item (error "Invalid binary value primitive:" value))
(list* (second item) out (map variable->code (cdr value))))]
[else [else
(unless (and (eq? (first value) '#%if) (unless (and (eq? (first value) '#%if)
(eq? (length (cdr value)) 3)) (eq? (length (cdr value)) 3))
(error "Unsupported ternary form:" form)) (error "Invalid ternary primitive:" form))
(list* out (map variable->code (cdr value)))])) (list* out (map variable->code (cdr value)))]))
(case (length (cdr form)) (case (length (cdr form))
[(1) (list (second (assoc (first form) unary-statement-primitives)) [(1) (let ([item (assoc (first form) unary-statement-primitives)])
(variable->code (second form)) (unless item (error "Invalid unary statement primitive:" form))
#x00 (list (second item)
#x00)] (variable->code (second form))
[(2) (list (second (assoc (first form) binary-statement-primitives)) #x00
(variable->code (second form)) #x00))]
(variable->code (third form)) [(2) (let ([item (assoc (first form) binary-statement-primitives)])
#x00)] (unless item (error "Invalid binary statement primitive:" form))
[(3) (list (second (assoc (first form) ternary-statement-primitives)) (list (second item)
(variable->code (second form)) (variable->code (second form))
(variable->code (third form)) (variable->code (third form))
(variable->code (fourth 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)]))) [else (error "Unsupported form:" form)])))
; vim:set sw=2 expandtab: ; vim:set sw=2 expandtab:

128
src/reader.rls
View File

@ -54,11 +54,13 @@
(define (read-one-value) (define (read-one-value)
(skip-whitespace) (skip-whitespace)
(when eof? (unexpected-eof))
(cond (cond
[eof? (unexpected-eof)]
[(eq? current-char #\#) [(eq? current-char #\#)
(next-char)
(read-special)] (read-special)]
[(eq? current-char #\() [(eq? current-char #\()
(next-char)
(read-list)] (read-list)]
[(or (eq? current-char #\-) [(or (eq? current-char #\-)
(eq? current-char #\+) (eq? current-char #\+)
@ -72,10 +74,8 @@
(unexpected-char)])) (unexpected-char)]))
(define (read-special) (define (read-special)
(next-char)
(when eof? (unexpected-eof))
(cond (cond
[eof? (unexpected-eof)]
[(eq? current-char #\!) [(eq? current-char #\!)
(unless (and (eq? line 1) (eq? column 2)) (unexpected-char)) (unless (and (eq? line 1) (eq? column 2)) (unexpected-char))
(define (skip-until-newline) (define (skip-until-newline)
@ -93,16 +93,20 @@
(when (symbol-char? current-char) (unexpected-char)) (when (symbol-char? current-char) (unexpected-char))
#t] #t]
[(eq? current-char #\&) [(eq? current-char #\&)
(next-char)
(read-box)] (read-box)]
[(eq? current-char #\() [(eq? current-char #\()
(next-char)
(read-vector)] (read-vector)]
[(memq? current-char '(#\S #\s)) [(memq? current-char '(#\S #\s))
(next-char) (next-char)
(unless (eq? current-char #\() (unexpected-char)) (unless (eq? current-char #\() (unexpected-char))
(next-char)
(read-struct)] (read-struct)]
[(memq? current-char '(#\W #\w)) [(memq? current-char '(#\W #\w))
(next-char) (next-char)
(unless (eq? current-char #\&) (unexpected-char)) (unless (eq? current-char #\&) (unexpected-char))
(next-char)
(read-weak-box)] (read-weak-box)]
[(memq? current-char '(#\X #\x)) [(memq? current-char '(#\X #\x))
(next-char) (next-char)
@ -122,8 +126,7 @@
(define (read-rest) (define (read-rest)
(skip-whitespace) (skip-whitespace)
(cond (cond
[eof? [eof? (unexpected-eof)]
(unexpected-eof)]
[(eq? current-char #\.) [(eq? current-char #\.)
(next-char) (next-char)
(let ([lstcdr (read-one-value)]) (let ([lstcdr (read-one-value)])
@ -137,10 +140,14 @@
[else [else
(cons (read-one-value) (read-rest))])) (cons (read-one-value) (read-rest))]))
(next-char) (skip-whitespace)
(if (eq? current-char #\)) (cond
'() [eof? (unexpected-eof)]
(cons (read-one-value) (read-rest)))) [(eq? current-char #\))
(next-char)
'()]
[else
(cons (read-one-value) (read-rest))]))
(define (read-fixnum [radix #f]) (define (read-fixnum [radix #f])
(let/cc return (let/cc return
@ -172,17 +179,20 @@
(set! radix 10))) (set! radix 10)))
; Need at least one digit within this radix ; Need at least one digit within this radix
(when eof? (unexpected-eof))
(unless (and (alphanumeric-char? current-char) (unless (and (alphanumeric-char? current-char)
(fix< (digit->integer current-char) radix)) (fix< (digit->integer current-char) radix))
(unexpected-char)) (unexpected-char))
(define (iter accum) (define (iter accum)
(let ([val (digit->integer current-char)]) (if eof?
(if (and val (fix< val radix)) accum
(begin (let ([val (digit->integer current-char)])
(next-char) (if (and val (fix< val radix))
(iter (fix+ (fix* accum radix) val))) (begin
accum))) (next-char)
(iter (fix+ (fix* accum radix) val)))
accum))))
(let ([pos-val (iter 0)]) (let ([pos-val (iter 0)])
(if neg? (fix- pos-val) pos-val)))) (if neg? (fix- pos-val) pos-val))))
@ -191,16 +201,14 @@
(read-fixnum)) (read-fixnum))
(define (read-box) (define (read-box)
(next-char)
(make-box (read-one-value))) (make-box (read-one-value)))
(define (read-weak-box) (define (read-weak-box)
(next-char)
(let ([val (read-one-value)]) (let ([val (read-one-value)])
(set! weak-list (cons val weak-list)) (set! weak-list (cons val weak-list))
(make-weak-box val))) (make-weak-box val)))
(define (read-string) (define (read-string [end-quote current-char])
(define (read-chars [accum '()] [len 0]) (define (read-chars [accum '()] [len 0])
(define (read-one-char) (define (read-one-char)
(define (skip-ws skip-nl?) (define (skip-ws skip-nl?)
@ -213,7 +221,7 @@
(skip-ws skip-nl?))))) (skip-ws skip-nl?)))))
(when eof? (unexpected-eof)) (when eof? (unexpected-eof))
(cond (cond
[(eq? current-char #\") [(eq? current-char end-quote)
(next-char) (next-char)
#f] #f]
[(eq? current-char #\\) [(eq? current-char #\\)
@ -296,9 +304,29 @@
(iter (fix- len 1) revchars) (iter (fix- len 1) revchars)
str)))) str))))
(define (read-vector) undefined) (define (read-vector)
(define (read-struct) undefined) (let* ([items (read-list)]
(define (read-symbol) undefined) [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) (define (skip-whitespace)
(unless eof? (unless eof?
@ -505,59 +533,5 @@
; release_assert(!issymbol(state->ch)); ; release_assert(!issymbol(state->ch));
; return make_float(flt); ; 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: ; vim:set syntax=scheme sw=2 expandtab: