#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);
union {
char const *name;
struct scm_t* car;
+ struct scm_t* ref;
int length;
};
union {
functionn_t functionn;
struct scm_t* cdr;
struct scm_t* macro;
- struct scm_t** vector;
+ struct scm_t* vector;
};
} scm;
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;
scm *
make_char (int x)
{
- scm *p = (scm*)malloc (sizeof (scm));
+ scm *p = alloc (1);
p->type = CHAR;
p->value = x;
return p;
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;
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;
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;
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;
}
{
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 *
{
assert (x->type == VECTOR);
assert (i->value < x->length);
- x->vector[i->value] = e;
+ x->vector[i->value] = *vector_entry (e);
return &scm_unspecified;
}
{
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;
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);
(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)