add vectors.

GNUmakefile

@@ -1,6 +1,6 @@
 .PHONY: all check default 
 CFLAGS=-std=c99 -O3 -finline-functions
-#CFLAGS=-g
+#CFLAGS=-std=c99 -g
 
 default: all
 
@@ -15,7 +15,7 @@ mes.h: mes.c GNUmakefile
 		while read f; do\
 			fun=$$(echo $$f | sed -e 's,^scm [*],,' -e 's,{.*,,');\
 			name=$$(echo $$fun | sed -e 's,^scm [\*],,' | grep -o '^[^ ]*');\
-			scm_name=$$(echo $$name | sed -e 's,_p$$,?,' -e 's,_x$$,!,' -e 's,^builtin_,,' -re 's,(.*)_$$,c:\1,' | sed \
+			scm_name=$$(echo $$name | sed -e 's,_to_,->,' -e 's,_p$$,?,' -e 's,_x$$,!,' -e 's,^builtin_,,' -re 's,(.*)_$$,c:\1,' | sed \
 				-e 's,^divide$$,/,'\
 				-e 's,^is?$$,=,'\
 				-e 's,^less?$$,<,'\

TODO

@@ -10,27 +10,27 @@ quote
 set!
 ** implement minimal needed rsr3/rsr4: 
 v "string"
-#(v e c t o r)
+v #(v e c t o r)
 #\CHAR
 assq
 call-with-values
 v char?
 v length
 v list
-list->vector
-make-vector
+v list->vector
+v make-vector
 memv
 v string
 v string-append
 v string?
 v symbol?
 values
-vector
-vector->list
-vector-length
-vector-ref
-vector-set!
-vector? 
+v vector
+v vector->list
+v vector-length
+v vector-ref
+v vector-set!
+v vector? 
 ... possibly also: any, each, unquote-splicing, ...
 ** implement extras: (gensym)
 ** hook-up sc-expand, see guile-1.0?: scheme:eval-transformer

mes.c

@@ -42,7 +42,7 @@
 #define QUOTE_SUGAR 1
 #endif
 
-enum type {STRING, SYMBOL, CHAR, NUMBER, PAIR,
+enum type {CHAR, NUMBER, PAIR, STRING, SYMBOL, VECTOR,
            FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn};
 struct scm_t;
 typedef struct scm_t* (*function0_t) (void);
@@ -56,6 +56,7 @@ typedef struct scm_t {
   union {
     char *name;
     struct scm_t* car;
+    int length;
   };
   union {
     int value;
@@ -65,6 +66,7 @@ typedef struct scm_t {
     function3_t function3;
     functionn_t functionn;    
     struct scm_t* cdr;
+    struct scm_t** vector;
   };
 } scm;
 
@@ -150,6 +152,8 @@ eq_p (scm *x, scm *y)
               && y->type != CHAR
               && x->type != NUMBER
               && y->type != NUMBER
+              && x->type != VECTOR
+              && y->type != VECTOR
               && atom_p (y) == &scm_t
               && !strcmp (x->name, y->name)))
     ? &scm_t : &scm_f;
@@ -308,6 +312,8 @@ eval_ (scm *e, scm *a)
     return e;
   else if (e->type == STRING)
     return e;
+  else if (e->type == VECTOR)
+    return e;
   else if (atom_p (e) == &scm_t) {
     scm *y = assoc (e, a);
     if (y == &scm_f) {
@@ -445,6 +451,12 @@ symbol_p (scm *x)
   return x->type == SYMBOL ? &scm_t : &scm_f;
 }
 
+scm *
+vector_p (scm *x)
+{
+  return x->type == VECTOR ? &scm_t : &scm_f;
+}
+
 scm *
 display (scm *x)
 {
@@ -523,6 +535,16 @@ make_symbol (char const *s)
   return p;
 }
 
+scm *
+make_vector (int n)
+{
+  scm *p = malloc (sizeof (scm));
+  p->type = VECTOR;
+  p->length = n;
+  p->vector = malloc (n * sizeof (scm*));
+  return p;
+}
+
 scm *
 string (scm *x/*...*/)
 {
@@ -572,6 +594,44 @@ length (scm *x)
   return make_number (n);
 }
 
+#if 0
+scm *
+builtin_list (scm *x/*...*/) // int
+{
+  return x;
+}
+
+scm *
+vector (scm *x/*...*/) // int
+{
+  return list_to_vector (x);
+}
+#endif
+
+scm *
+vector_length (scm *x)
+{
+  assert (x->type == VECTOR);
+  return make_number (x->length);
+}
+
+scm *
+vector_ref (scm *x, scm *i)
+{
+  assert (x->type == VECTOR);
+  assert (i->value < x->length);
+  return x->vector[i->value];
+}
+
+scm *
+vector_set_x (scm *x, scm *i, scm *e)
+{
+  assert (x->type == VECTOR);
+  assert (i->value < x->length);
+  x->vector[i->value] = e;
+  return &scm_unspecified;
+}
+
 scm *
 lookup (char *x, scm *a)
 {
@@ -620,6 +680,29 @@ list2str (scm *l)
   return buf;
 }
 
+scm*
+list_to_vector (scm *x)
+{
+  int n = length (x)->value;
+  scm *v = make_vector (n);
+  scm **p = v->vector;
+  while (x != &scm_nil)
+    {
+      *p++ = car (x);
+      x = cdr (x);
+    }
+  return v;
+}
+
+scm*
+vector_to_list (scm *v)
+{
+  scm *x = &scm_nil;
+  for (int i = 0; i < v->length; i++)
+    x = append (x, cons (v->vector[i], &scm_nil));
+  return x;
+}
+
 scm *
 builtin_lookup (scm *l, scm *a)
 {
@@ -678,6 +761,12 @@ display_helper (scm *x, bool cont, char *sep, bool quote)
     }
     if (!cont) printf (")");
   }
+  else if (x->type == VECTOR) {
+    printf ("#(");
+    for (int i = 0; i < x->length; i++)
+      display_helper (x->vector[i], true, i ? " " : "", false);
+    printf (")");
+  }
   else if (atom_p (x) == &scm_t) printf ("%s", x->name);
 
   return &scm_unspecified;
@@ -743,7 +832,7 @@ readword (int c, char* w, scm *a)
   if (c == ' ') return readword ('\n', w, a);
   if (c == '"' && !w) return readstring ();
   if (c == '"') {ungetchar (c); return lookup (w, a);}
-  if (c == '(' && !w) return readlis (a);
+  if (c == '(' && !w) return readlist (a);
   if (c == '(') {ungetchar (c); return lookup (w, a);}
   if (c == ')' && !w) {ungetchar (c); return &scm_nil;}
   if (c == ')') {ungetchar (c); return lookup (w, a);}
@@ -758,6 +847,8 @@ readword (int c, char* w, scm *a)
                                            &scm_nil));}
   if (c == ';') {readcomment (c); return readword ('\n', w, a);}
   if (c == '#' && peekchar () == '\\') {getchar (); return readchar ();}
+  if (c == '#' && !w && peekchar () == '(') {getchar (); return list_to_vector (readlist (a));}
+  if (c == '#' && peekchar () == '(') {ungetchar (c); return lookup (w, a);}
   if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);}
   char buf[256] = {0};
   char ch = c;
@@ -822,15 +913,15 @@ eat_whitespace (int c)
 }
 
 scm *
-readlis (scm *a)
+readlist (scm *a)
 {
   int c = getchar ();
   c = eat_whitespace (c);
   if (c == ')') return &scm_nil;
   scm *w = readword (c, 0, a);
   if (w == &scm_dot)
-    return car (readlis (a));
-  return cons (w, readlis (a));
+    return car (readlist (a));
+  return cons (w, readlist (a));
 }
 
 scm *

mes.mes

@@ -126,6 +126,7 @@
    ((char? e) e)
    ((number? e) e)
    ((string? e) e)
+   ((vector? e) e)
    ((atom? e) (cdr (assoc e a)))
    ((builtin? e) e)
    ((atom? (car e))
@@ -176,7 +177,7 @@
         ((eq? c 32) ;; \space
          (readword 10 w a))
         ((eq? c 40) ;; (
-         (cond ((eq? w '()) (readlis a))
+         (cond ((eq? w '()) (readlist a))
                (#t (ungetchar c) (lookup w a))))
         ((eq? c 41) ;; )
          (cond ((eq? w '()) (ungetchar c) w)
@@ -194,6 +195,7 @@
                 (getchar)
                 (readblock (getchar))
                 (readword 10 w a))
+               ;; TODO: char, vector
                (#t (readword (getchar) (append w (cons c '())) a))))
         (#t (readword (getchar) (append w (cons c '())) a))))
 
@@ -211,15 +213,15 @@
         ((eq? (peekchar) 35) (getchar) (eat-whitespace))
         (#t #t)))
 
-(define (readlis a)
-  ;; (display 'mes-readlis:)
+(define (readlist a)
+  ;; (display 'mes-readlist:)
   ;; (newline)
   (eat-whitespace)
   (cond ((eq? (peekchar) 41) ;; )
          (getchar)
          '())
         ;; TODO *dot*
-        (#t (cons (readword (getchar) '() a) (readlis a)))))
+        (#t (cons (readword (getchar) '() a) (readlist a)))))
 
 (define (readcomment c)
   (cond ((eq? c 10) ;; \n

scm.mes

@@ -22,6 +22,7 @@
 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
 
 (define (list . rest) rest)
+(define (vector . rest) (list->vector rest))
 
 (define (+ x y) (- x (- 0 y)))
 

test.mes

@@ -189,4 +189,37 @@
 (display (length '(a b c)))
 (newline)
 
+#(a b c)
+(display #(0 1 2))
+(newline)
+(define v #("a" "b" "c"))
+(display "vector?: ")
+(display (vector? v))
+(newline)
+(display "length of ")
+(display v)
+(display ": ")
+(display (vector-length v))
+(newline)
+(display "as list: ")
+(define lv (vector->list v))
+(display lv)
+(newline)
+(display "again as vector: ")
+(display (list->vector lv))
+(newline)
+
+(display "(vector 0 1 2): ")
+(display (vector 0 1 2))
+(newline)
+
+(display "v[1]: ")
+(display (vector-ref v 1))
+(newline)
+
+(display "v[1]=q: ")
+(vector-set! v 1 'q)
+(display v)
+(newline)
+
 '()