diff --git a/GNUmakefile b/GNUmakefile index 6757703a..44e434c9 100644 --- a/GNUmakefile +++ b/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?$$,<,'\ diff --git a/TODO b/TODO index 7a323edf..6adbe13b 100644 --- a/TODO +++ b/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 diff --git a/mes.c b/mes.c index 7a255080..feb59c35 100644 --- a/mes.c +++ b/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 * diff --git a/mes.mes b/mes.mes index 9650bf7e..b9edfd8f 100644 --- a/mes.mes +++ b/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 diff --git a/scm.mes b/scm.mes index cff5fba6..5bea0222 100755 --- a/scm.mes +++ b/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))) diff --git a/test.mes b/test.mes index f1215dc8..a40780db 100644 --- a/test.mes +++ b/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) + '()