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

@@ -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))
+                       `((#%set! ,argv (#%cons ,k #%nil))
-                         (#%tail-call ,x ,argv #%nil #%nil ,ctx #%k))]
+                         (#%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:

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))
+           (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)
-           (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
            (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))
+        [(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)]
+                     #x00))]
-        [(2) (list (second (assoc (first form) binary-statement-primitives))
+        [(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)]
+                     #x00))]
-        [(3) (list (second (assoc (first form) ternary-statement-primitives))
+        [(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)))]
+                     (variable->code (fourth form))))]
         [else (error "Unsupported form:" form)])))
 
 ; vim:set sw=2 expandtab:

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?
+            [eof? (unexpected-eof)]
-               (unexpected-eof)]
             [(eq? current-char #\.)
                (next-char)
                (let ([lstcdr (read-one-value)])
@@ -137,10 +140,14 @@
             [else
                (cons (read-one-value) (read-rest))]))
 
+        (skip-whitespace)
+        (cond
+          [eof? (unexpected-eof)]
+          [(eq? current-char #\))
              (next-char)
-        (if (eq? current-char #\))
+             '()]
-            '()
+          [else
-            (cons (read-one-value) (read-rest))))
+             (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)
+            (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)))
+                      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-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)
         (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: