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)))))
'()
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:

42
libcompiler/writer.scm
View File

@ -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:

128
src/reader.rls
View File

@ -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: