From d209a1812101264a2186700e35dff1860b41598b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 25 Oct 2016 00:21:28 +0200 Subject: [PATCH] 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. --- lib.c | 7 +++-- mes.c | 63 ++++++++++++++++++++++++++++++----------- module/mes/record-0.mes | 6 ++++ tests/vector.test | 15 ++++++++-- type.c | 6 ++++ 5 files changed, 76 insertions(+), 21 deletions(-) diff --git a/lib.c b/lib.c index 4d7a6176..f1cb8e94 100644 --- 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 6a02694c..974e5a6d 100644 --- 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; ivalue; i++) p->vector[i] = &scm_unspecified; + p->vector = alloc (n->value); + for (int i=0; ivalue; 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, "#", 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 4fab5708..ff6ce99c 100644 --- 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 c122223d..6280ea0f 100755 --- 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 ddf4e019..ca7119c8 100644 --- 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) {