Introduce reference type, use vectors of SCM.

* mes.c (type): Add REF.
  (scm_t): Add ref, change vector to *scm_t.  Update users.
  (alloc): New function.
  (cons, make_char, make_macro, make_number, make_string,
  internal_make_symbol, make_vector): Use it.
  (make_ref): New function.
  (vector_entry): New function.
  (make_vector, list_to_vector, vector_set_x): Use it.
  (vector_ref): Dereference REF entry.
  (display_helper): Handle REF.
* lib.c (vector_to_list): Handle REF.
* type.c (ref_p): New function.
* tests/vector.test (vector list): New test.

Bugfix vector-ref.

* mes.c (vector-ref): Make copies of simple values.  Fixes lalr.
* tests/vector.test (vector-set! 3): New test.

diff --git a/lib.c b/lib.c
index 4d7a617645dd42279652207ada2624ca9fd23447..f1cb8e948d52a0e8ff7730cb17d973919e7887ff 100644 (file)
--- a/lib.c
+++ b/lib.c
@@ -60,8 +60,11 @@ scm *
 vector_to_list (scm *v)
 {
   scm *x = &scm_nil;
-  for (int i = 0; i < v->length; i++)
-    x = append2 (x, cons (v->vector[i], &scm_nil));
+  for (int i = 0; i < v->length; i++) {
+    scm *e = &v->vector[i];
+    if (e->type == REF) e = e->ref;
+    x = append2 (x, cons (e, &scm_nil));
+  }
   return x;
 }
 

diff --git a/mes.c b/mes.c
index 6a02694ce5e7893fd814b067207ba6d4071baa6b..974e5a6d80b2a395847b25cd49eeac237c9e9501 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -31,7 +31,7 @@
 #define DEBUG 0
 #define QUASIQUOTE 1
 
-enum type {CHAR, MACRO, NUMBER, PAIR, SCM, STRING, SYMBOL, VALUES, VECTOR,
+enum type {CHAR, MACRO, NUMBER, PAIR, SCM, STRING, SYMBOL, REF, VALUES, VECTOR,
            FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn};
 struct scm_t;
 typedef struct scm_t* (*function0_t) (void);
@@ -45,6 +45,7 @@ typedef struct scm_t {
   union {
     char const *name;
     struct scm_t* car;
+    struct scm_t* ref;
     int length;
   };
   union {
@@ -56,7 +57,7 @@ typedef struct scm_t {
     functionn_t functionn;
     struct scm_t* cdr;
     struct scm_t* macro;
-    struct scm_t** vector;
+    struct scm_t* vector;
   };
 } scm;
 
@@ -133,10 +134,16 @@ cdr (scm *x)
   return x->cdr;
 }
 
+scm *
+alloc (int n)
+{
+  return (scm*)malloc (n * sizeof (scm));
+}
+
 scm *
 cons (scm *x, scm *y)
 {
-  scm *p = (scm*)malloc (sizeof (scm));
+  scm *p = alloc (1);
   p->type = PAIR;
   p->car = x;
   p->cdr = y;
@@ -506,7 +513,7 @@ append (scm *x) ///((args . n))
 scm *
 make_char (int x)
 {
-  scm *p = (scm*)malloc (sizeof (scm));
+  scm *p = alloc (1);
   p->type = CHAR;
   p->value = x;
   return p;
@@ -515,7 +522,7 @@ make_char (int x)
 scm *
 make_macro (scm *name, scm *x)
 {
-  scm *p = (scm*)malloc (sizeof (scm));
+  scm *p = alloc (1);
   p->type = MACRO;
   p->macro = x;
   p->name = name->name;
@@ -525,16 +532,25 @@ make_macro (scm *name, scm *x)
 scm *
 make_number (int x)
 {
-  scm *p = (scm*)malloc (sizeof (scm));
+  scm *p = alloc (1);
   p->type = NUMBER;
   p->value = x;
   return p;
 }
 
+scm *
+make_ref (scm *x)
+{
+  scm *p = alloc (1);
+  p->type = REF;
+  p->ref = x;
+  return p;
+}
+
 scm *
 make_string (char const *s)
 {
-  scm *p = (scm*)malloc (sizeof (scm));
+  scm *p = alloc (1);
   p->type = STRING;
   p->name = strdup (s);
   return p;
@@ -554,7 +570,7 @@ internal_lookup_symbol (char const *s)
 scm *
 internal_make_symbol (char const *s)
 {
-  scm *x = (scm*)malloc (sizeof (scm));
+  scm *x = alloc (1);
   x->type = SYMBOL;
   x->name = strdup (s);
   x->value = 0;
@@ -572,11 +588,11 @@ make_symbol (char const *s)
 scm *
 make_vector (scm *n)
 {
-  scm *p = (scm*)malloc (sizeof (scm));
+  scm *p = alloc (1);
   p->type = VECTOR;
   p->length = n->value;
-  p->vector = (scm**)malloc (n->value * sizeof (scm*));
-  for (int i=0; i<n->value; i++) p->vector[i] = &scm_unspecified;
+  p->vector = alloc (n->value);
+  for (int i=0; i<n->value; i++) p->vector[i] = *vector_entry (&scm_unspecified);
   return p;
 }
 
@@ -609,7 +625,17 @@ vector_ref (scm *x, scm *i)
 {
   assert (x->type == VECTOR);
   assert (i->value < x->length);
-  return x->vector[i->value];
+  scm *e = &x->vector[i->value];
+  if (e->type == REF) e = e->ref;
+  if (e->type == CHAR) e = make_char (e->value);
+  if (e->type == NUMBER) e = make_number (e->value);
+  return e;
+}
+
+scm *
+vector_entry (scm *x) {
+  if (x->type == PAIR || x->type == SCM || x->type == STRING || x->type == SYMBOL || x->type == VECTOR) x = make_ref (x);
+  return x;
 }
 
 scm *
@@ -617,7 +643,7 @@ vector_set_x (scm *x, scm *i, scm *e)
 {
   assert (x->type == VECTOR);
   assert (i->value < x->length);
-  x->vector[i->value] = e;
+  x->vector[i->value] = *vector_entry (e);
   return &scm_unspecified;
 }
 
@@ -663,10 +689,10 @@ list_to_vector (scm *x)
 {
   temp_number.value = length (x)->value;
   scm *v = make_vector (&temp_number);
-  scm **p = v->vector;
+  scm *p = v->vector;
   while (x != &scm_nil)
     {
-      *p++ = car (x);
+      *p++ = *vector_entry (car (x));
       x = cdr (x);
     }
   return v;
@@ -737,13 +763,16 @@ display_helper (FILE* f, scm *x, bool cont, char const *sep, bool quote)
   else if (x->type == VECTOR) {
     fprintf (f, "#(", x->length);
     for (int i = 0; i < x->length; i++) {
-      if (x->vector[i]->type == VECTOR)
+      if (x->vector[i].type == VECTOR
+          || (x->vector[i].type == REF
+              && x->vector[i].ref->type == VECTOR))
         fprintf (f, "%s#(...)", i ? " " : "");
       else
-        display_helper (f, x->vector[i], false, i ? " " : "", false);
+        display_helper (f, &x->vector[i], false, i ? " " : "", false);
     }
     fprintf (f, ")");
   }
+  else if (x->type == REF) display_helper (f, x->ref, cont, "", true);
   else if (builtin_p (x) == &scm_t) fprintf (f, "#<procedure %s>", x->name);
   else if (pair_p (x) == &scm_f) fprintf (f, "%s", x->name);
 

diff --git a/module/mes/record-0.mes b/module/mes/record-0.mes
index 4fab57088d560a0dd284f046131721ce3bc2659a..ff6ce99c7f66ece04aa7f8ecb216c7752b4b8a33 100644 (file)
--- a/module/mes/record-0.mes
+++ b/module/mes/record-0.mes
@@ -30,3 +30,9 @@
 (define record? vector?)
 (define (record-type x) (vector-ref x 0))
 (define record-ref vector-ref)
+(define (call-error message . rest)
+  (display "call-error:" (current-error-port))
+  (display message (current-error-port))
+  (display ":" (current-error-port))
+  (display rest (current-error-port))
+  (newline (current-error-port)))

diff --git a/tests/vector.test b/tests/vector.test
index c122223dbe086d9dae1bb6beebb5a68dce52b49b..6280ea0f63b968e75a6fdd23d14f659e0e9a126a 100755 (executable)
--- a/tests/vector.test
+++ b/tests/vector.test
@@ -49,8 +49,19 @@ exit $?
 
 (pass-if "make-vector 2" (sequal? (make-vector 3 1) #(1 1 1)))
 (pass-if "vector-ref" (seq? (vector-ref #(0 1) 1) 1))
-(pass-if "vector-set" (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #(0 q)))
-(pass-if "vector-set 2" (not (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #())))
+(pass-if "vector-set!" (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #(0 q)))
+(pass-if "vector-set! 2" (not (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #())))
+(pass-if "vector-set! 3" (sequal? (let ((v1 #(0))
+                                        (v2 #(1)))
+                                    (vector-set! v2 0 (cons 0 (vector-ref v1 0)))
+                                    (vector-set! v1 0 'mwhuharhararrrg)
+                                    v2)
+                                  #((0 . 0))))
 (pass-if "list->vector" (sequal? (list->vector '(a b c)) #(a b c)))
+(pass-if "vector list" (let* ((v #(0))
+                              (l '(a b c)))
+                         (vector-set! v 0 l)
+                         (set-cdr! l '())
+                         (sequal? (vector->list v) '((a)))))
 
 (result 'report)

diff --git a/type.c b/type.c
index ddf4e019b35b0367aef1c64e9e40abd872507712..ca7119c8a25ec2031f296f70a29713f9cdd5ceb0 100644 (file)
--- a/type.c
+++ b/type.c
@@ -44,6 +44,12 @@ pair_p (scm *x)
   return x->type == PAIR ? &scm_t : &scm_f;
 }
 
+scm *
+ref_p (scm *x)
+{
+  return x->type == REF ? &scm_t : &scm_f;
+}
+
 scm *
 string_p (scm *x)
 {