From 4fa676ce68d2361b94c2bd6541b22348e52d1d70 Mon Sep 17 00:00:00 2001 From: Justin Meiners Date: Sat, 11 Dec 2021 16:10:04 -0700 Subject: [PATCH 1/8] load for repl --- repl.c | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/repl.c b/repl.c index d364034..3881973 100644 --- a/repl.c +++ b/repl.c @@ -9,6 +9,14 @@ #define LISP_IMPLEMENTATION #include "lisp.h" +static Lisp sch_load(Lisp args, LispError* e, LispContext ctx) +{ + Lisp path = lisp_car(args); + Lisp result = lisp_read_path(lisp_string(path), e, ctx); + if (*e != LISP_ERROR_NONE) return lisp_make_null(); + return lisp_eval(result, e, ctx); +} + int main(int argc, const char* argv[]) { const char* file_path = NULL; @@ -30,6 +38,12 @@ int main(int argc, const char* argv[]) LispContext ctx = lisp_init(); lisp_load_lib(ctx); + lisp_env_define( + lisp_cdr(lisp_env_global(ctx)), + lisp_make_symbol("LOAD", ctx), + lisp_make_func(sch_load), + ctx + ); clock_t start_time, end_time; From fd6055c6abf414c806e7328a89809a44ee0b5c91 Mon Sep 17 00:00:00 2001 From: Justin Meiners Date: Sat, 11 Dec 2021 16:16:41 -0700 Subject: [PATCH 2/8] fix math function interface --- lisp.h | 38 ++++++++++++++------------------------ 1 file changed, 14 insertions(+), 24 deletions(-) diff --git a/lisp.h b/lisp.h index 5452c30..ee4102f 100644 --- a/lisp.h +++ b/lisp.h @@ -3971,59 +3971,49 @@ static Lisp sch_is_real(Lisp args, LispError* e, LispContext ctx) static Lisp sch_is_boolean(Lisp args, LispError* e, LispContext ctx) { - LispType t = lisp_type(lisp_car(args)); - return lisp_make_bool(t == LISP_BOOL); + return lisp_make_bool(lisp_type(lisp_car(args)) == LISP_BOOL); } static Lisp sch_is_even(Lisp args, LispError* e, LispContext ctx) { - while (!lisp_is_null(args)) - { - if ((lisp_int(lisp_car(args)) & 1) == 1) return lisp_false(); - args = lisp_cdr(args); - } - return lisp_true(); + ARITY_CHECK(1, 1); + return lisp_make_bool( (lisp_int(lisp_car(args)) & 1) == 0); } static Lisp sch_exp(Lisp args, LispError* e, LispContext ctx) { - LispReal x = exp(lisp_real(lisp_car(args))); - return lisp_make_real(x); + ARITY_CHECK(1, 1); + return lisp_make_real( exp(lisp_number_to_real(lisp_car(args))) ); } static Lisp sch_log(Lisp args, LispError* e, LispContext ctx) { ARITY_CHECK(1, 1); - LispReal x = log(lisp_real(lisp_car(args))); - return lisp_make_real(x); + return lisp_make_real( log(lisp_number_to_real(lisp_car(args))) ); } static Lisp sch_sin(Lisp args, LispError* e, LispContext ctx) { ARITY_CHECK(1, 1); - LispReal x = sin(lisp_real(lisp_car(args))); - return lisp_make_real(x); + return lisp_make_real( sin(lisp_number_to_real(lisp_car(args))) ); } static Lisp sch_cos(Lisp args, LispError* e, LispContext ctx) { ARITY_CHECK(1, 1); - LispReal x = cos(lisp_real(lisp_car(args))); - return lisp_make_real(x); + return lisp_make_real( cos(lisp_number_to_real(lisp_car(args))) ); } static Lisp sch_tan(Lisp args, LispError* e, LispContext ctx) { ARITY_CHECK(1, 1); - LispReal x = tan(lisp_real(lisp_car(args))); - return lisp_make_real(x); + return lisp_make_real( tan(lisp_number_to_real(lisp_car(args))) ); } static Lisp sch_sqrt(Lisp args, LispError* e, LispContext ctx) { ARITY_CHECK(1, 1); - LispReal x = sqrt(lisp_real(lisp_car(args))); - return lisp_make_real(x); + return lisp_make_real( sqrt(lisp_number_to_real(lisp_car(args))) ); } static Lisp sch_quotient(Lisp args, LispError* e, LispContext ctx) @@ -4040,7 +4030,6 @@ static Lisp sch_remainder(Lisp args, LispError* e, LispContext ctx) args = lisp_cdr(args); int b = lisp_int(lisp_car(args)); return lisp_make_int(a % b); - } static Lisp sch_modulo(Lisp args, LispError* e, LispContext ctx) @@ -4055,12 +4044,13 @@ static Lisp sch_modulo(Lisp args, LispError* e, LispContext ctx) static Lisp sch_abs(Lisp args, LispError* e, LispContext ctx) { - switch (lisp_type(lisp_car(args))) + Lisp x = lisp_car(args); + switch (lisp_type(x)) { case LISP_INT: - return lisp_make_int(llabs(lisp_int(lisp_car(args)))); + return lisp_make_int(llabs(lisp_int(x))); case LISP_REAL: - return lisp_make_real(fabs(lisp_real(lisp_car(args)))); + return lisp_make_real(fabs(lisp_real(x))); default: *e = LISP_ERROR_TYPE; return lisp_make_null(); From c3ed8471fb76bd158d9c9b5c3ae3f556a4378c40 Mon Sep 17 00:00:00 2001 From: Justin Meiners Date: Sat, 11 Dec 2021 16:24:57 -0700 Subject: [PATCH 3/8] powers --- lisp.h | 33 +++++++++++++++++++++++++++++++++ tests/code/numbers.scm | 5 +++-- 2 files changed, 36 insertions(+), 2 deletions(-) diff --git a/lisp.h b/lisp.h index ee4102f..d673b16 100644 --- a/lisp.h +++ b/lisp.h @@ -3986,6 +3986,38 @@ static Lisp sch_exp(Lisp args, LispError* e, LispContext ctx) return lisp_make_real( exp(lisp_number_to_real(lisp_car(args))) ); } +static int ipow(int base, int exp) +{ + int result = 1; + for (;;) + { + if (exp & 1) + result *= base; + exp >>= 1; + if (!exp) + break; + base *= base; + } + + return result; +} + +static Lisp sch_power(Lisp args, LispError* e, LispContext ctx) +{ + Lisp base = lisp_car(args); + args = lisp_cdr(args); + Lisp power = lisp_car(args); + + if (lisp_type(base) == LISP_INT && lisp_type(power) == LISP_INT) + { + return lisp_make_int( ipow(lisp_int(base), lisp_int(power)) ); + } + else + { + return lisp_make_real( pow(lisp_number_to_real(base), lisp_number_to_real(power)) ); + } +} + static Lisp sch_log(Lisp args, LispError* e, LispContext ctx) { ARITY_CHECK(1, 1); @@ -4543,6 +4575,7 @@ static const LispFuncDef lib_cfunc_defs[] = { { "EVEN?", sch_is_even }, { "REAL?", sch_is_real }, { "EXP", sch_exp }, + { "EXPT", sch_power }, { "LOG", sch_log }, { "SIN", sch_sin }, { "COS", sch_cos }, diff --git a/tests/code/numbers.scm b/tests/code/numbers.scm index 9ee454c..1083157 100644 --- a/tests/code/numbers.scm +++ b/tests/code/numbers.scm @@ -51,7 +51,8 @@ (assert (inexact? (- 1 2.5))) (assert (inexact? (- 1.3 2))) +(assert (exact? (expt 3 3))) +(=> (expt 3 3) 27) - - +(assert (inexact? (expt 3 2.5))) From 27ec651da0a421ea71b77459a7d4d8f81b80cdc9 Mon Sep 17 00:00:00 2001 From: Justin Meiners Date: Sat, 11 Dec 2021 16:36:15 -0700 Subject: [PATCH 4/8] lcm --- lisp.h | 9 +++++++-- tests/code/numbers.scm | 9 +++++++-- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/lisp.h b/lisp.h index d673b16..43cf652 100644 --- a/lisp.h +++ b/lisp.h @@ -4901,8 +4901,13 @@ static const char* lib_code_sequence = " \ (if (= b 0) a (_gcd-helper b (modulo a b)))) \ \ (define (gcd . args) \ - (if (null? args) 0 \ - (_gcd-helper (car args) (car (cdr args))))) \ + (if (null? args) 0 \ + (_gcd-helper (car args) (car (cdr args))))) \ +\ +(define (lcm . args) \ + (if (null? args) 1 \ + (abs (* (/ (car args) (apply gcd args)) \ + (apply * (cdr args)))))) \ \ (define (reverse l) (reverse! (list-copy l))) \ (define (vector-head v end) (subvector v 0 end)) \ diff --git a/tests/code/numbers.scm b/tests/code/numbers.scm index 1083157..4e42ff7 100644 --- a/tests/code/numbers.scm +++ b/tests/code/numbers.scm @@ -6,10 +6,15 @@ (assert (= (gcd 32 -36) 4)) (assert (= (gcd 4 3) 1)) -(assert (= (gcd) 0)) +(=> (gcd) 0) -(assert (= (abs -1) 1)) +(=> (lcm 32 -36) 288) +(assert (exact? (lcm 32 -36))) +(assert (inexact? (lcm 32.0 -36))) + +(=> (lcm) 1) +(assert (= (abs -1) 1)) (=> (map + '(1 1 1) '(2 2 2)) (3 3 3)) (=> (map abs '(-1 -2 3)) (1 2 3)) (=> (vector-map abs #(-1 -2 3)) #(1 2 3)) From 48e8c3d2f144ea3472c5c122f7948fd6ceecf2a8 Mon Sep 17 00:00:00 2001 From: Justin Meiners Date: Sat, 11 Dec 2021 16:55:04 -0700 Subject: [PATCH 5/8] dotimes macro --- lisp.h | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/lisp.h b/lisp.h index 43cf652..df93747 100644 --- a/lisp.h +++ b/lisp.h @@ -4774,6 +4774,11 @@ static const char* lib_code1 = " \ (lambda (v l) \ `(begin (set! ,l (cons ,v ,l)) ,l))) \ \ +(define (nthcdr n list) \ + (cond ((= n 0) list) \ + ((null? list) '()) \ + (t (nthcdr (- n 1) (cdr list))))) \ +\ (define-macro do \ (lambda (vars loop-check . loops) \ (let ((names '()) \ @@ -4795,6 +4800,14 @@ static const char* lib_code1 = " \ ,(cons f inits) \ )) '()) ))) \ \ +(define-macro dotimes \ + (lambda (form body) \ + (apply (lambda (i n . result) \ + `(do ((,i 0 (+ ,i 1))) \ + ((>= ,i ,n) ,(if (null? result) result (car result)) ) \ + ,body) \ + ) form))) \ +\ (define (number? x) (real? x)) \ (define (odd? x) (not (even? x))) \ (define (inexact? x) (not (exact? x))) \ From a535b4426ec4ef8c68e5ae1cc614363db0277938 Mon Sep 17 00:00:00 2001 From: Justin Meiners Date: Sat, 11 Dec 2021 16:58:49 -0700 Subject: [PATCH 6/8] additional string tests --- tests/code/strings.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/code/strings.scm b/tests/code/strings.scm index 6bb2ddb..f1f0e2f 100644 --- a/tests/code/strings.scm +++ b/tests/code/strings.scm @@ -12,7 +12,9 @@ (assert (string=? "PIE" "PIE")) (assert (not (string=? "PIE" "pie"))) -(=> (list->string (string->list "hello")) "hello") +(=> (list->string (string->list "hello 123")) "hello 123") +(=> (string->list (list->string '(#\A #\B #\3))) (#\A #\B #\3)) + ; https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Symbols.html (assert (symbol? 'foo)) From 5dfa5ec1b8e7439672865496b13ee27df0a6ea94 Mon Sep 17 00:00:00 2001 From: Justin Meiners Date: Sat, 11 Dec 2021 17:10:47 -0700 Subject: [PATCH 7/8] string append --- lisp.h | 54 +++++++++++++++++++++++++++++++++--------------------- 1 file changed, 33 insertions(+), 21 deletions(-) diff --git a/lisp.h b/lisp.h index df93747..b672171 100644 --- a/lisp.h +++ b/lisp.h @@ -3750,15 +3750,6 @@ static Lisp sch_make_string(Lisp args, LispError* e, LispContext ctx) return lisp_make_string2(lisp_int(n), c, ctx); } -static Lisp sch_string_equal(Lisp args, LispError* e, LispContext ctx) -{ - Lisp a = lisp_car(args); - args = lisp_cdr(args); - Lisp b = lisp_car(args); - int result = strcmp(lisp_string(a), lisp_string(b)) == 0; - return lisp_make_bool(result); -} - static Lisp sch_string_less(Lisp args, LispError* e, LispContext ctx) { Lisp a = lisp_car(args); @@ -3838,12 +3829,34 @@ static Lisp sch_string_downcase(Lisp args, LispError* e, LispContext ctx) Lisp r = lisp_make_string(lisp_string(s), ctx); char* c = lisp_string(r); - while (*c) + while (*c) { *c = tolower(*c); ++c; } + return r; +} + +static Lisp sch_string_append(Lisp args, LispError* e, LispContext ctx) +{ + int count = 0; + Lisp it = args; + while (lisp_is_pair(it)) { - *c = tolower(*c); - ++c; + Lisp x = lisp_car(it); + count += strlen(lisp_string(x)); + it = lisp_cdr(it); } - return r; + + Lisp result = lisp_make_string2(count + 1, '\0', ctx); + char* c = lisp_string(result); + + it = args; + while (lisp_is_pair(it)) + { + Lisp x = lisp_car(it); + int n = (LispInt)strlen(lisp_string(x)); + memcpy(c, lisp_string(x), n); + c += n; + it = lisp_cdr(it); + } + return result; } static Lisp sch_string_to_list(Lisp args, LispError* e, LispContext ctx) @@ -4529,7 +4542,7 @@ static const LispFuncDef lib_cfunc_defs[] = { // Strings https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_7.html#SEC61 { "STRING?", sch_is_string }, { "MAKE-STRING", sch_make_string }, - { "STRING=?", sch_string_equal }, + { "STRING=?", sch_equal }, { "STRINGLIST", sch_string_to_list }, { "LIST->STRING", sch_list_to_string }, { "STRING->NUMBER", sch_string_to_number }, { "NUMBER->STRING", sch_number_to_string }, - // Characters https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Characters.html#Characters { "CHAR?", sch_is_char }, { "CHAR=?", sch_equals }, @@ -4859,15 +4872,14 @@ static const char* lib_code_sequence = " \ (helper (map1 cdr lists '()))))) \ (helper rest)) \ \ -(define (memq x list) \ +(define (_member x list eq?) \ (cond ((null? list) #f) \ ((eq? (car list) x) list) \ - (else (memq x (cdr list))))) \ + (else (_member x (cdr list))))) \ \ -(define (member x list) \ - (cond ((null? list) #f) \ - ((equal? (car list) x) list) \ - (else (member x (cdr list))))) \ +(define (member x list) (_member x list equal?)) \ +(define (memq x list) (_member x list eq?)) \ +(define (memv x list) (_member x list eqv?)) \ \ (define (make-list k elem) \ (define (helper k l) \ From edcb069eb32ebd0849c74940031419cd97fdd7c3 Mon Sep 17 00:00:00 2001 From: Justin Meiners Date: Sat, 11 Dec 2021 18:01:42 -0700 Subject: [PATCH 8/8] improve assocations --- README.md | 2 +- lisp.h | 215 ++++++++++++----------------------------- tests/code/bugs.scm | 11 +-- tests/code/lists.scm | 12 +++ tests/code/vectors.scm | 8 ++ 5 files changed, 86 insertions(+), 162 deletions(-) diff --git a/README.md b/README.md index 3dacd3d..7b85c1e 100644 --- a/README.md +++ b/README.md @@ -101,7 +101,7 @@ LispContext ctx = lisp_init(); // load lisp structure Lisp data = lisp_read_file(file, ctx); // get value for age -Lisp age = lisp_list_assoc(data, lisp_make_symbol("AGE", ctx), ctx); +Lisp age_entry = lisp_avector_ref(data, lisp_make_symbol("AGE", ctx), ctx); // ... lisp_shutdown(ctx); ``` diff --git a/lisp.h b/lisp.h index b672171..d877861 100644 --- a/lisp.h +++ b/lisp.h @@ -147,6 +147,10 @@ Lisp lisp_collect(Lisp root_to_save, LispContext ctx); void lisp_print_collect_stats(LispContext ctx); const char* lisp_error_string(LispError error); +void lisp_port_set_out(FILE* file, LispContext ctx); +void lisp_port_set_in(FILE* file, LispContext ctx); +void lisp_port_set_err(FILE* file, LispContext ctx); + // ----------------------------------------- // REPL // ----------------------------------------- @@ -164,15 +168,10 @@ Lisp lisp_eval2(Lisp expr, Lisp env, LispError* out_error, LispContext ctx); void lisp_print(Lisp l); void lisp_printf(FILE* file, Lisp l); -// Expands special Lisp forms and checks syntax. -// The default eval will do this for you, but this can prepare statements that are run multiple times. -Lisp lisp_macroexpand(Lisp lisp, LispError* out_error, LispContext ctx); - void lisp_displayf(FILE* file, Lisp l); -void lisp_port_set_out(FILE* file, LispContext ctx); -void lisp_port_set_in(FILE* file, LispContext ctx); -void lisp_port_set_err(FILE* file, LispContext ctx); +// Expands special Lisp forms and checks syntax (called by eval). +Lisp lisp_macroexpand(Lisp lisp, LispError* out_error, LispContext ctx); // ----------------------------------------- // PRIMITIVES @@ -194,7 +193,6 @@ Lisp lisp_cons(Lisp car, Lisp cdr, LispContext ctx); #define lisp_is_pair(p) ((p).type == LISP_PAIR) #define lisp_is_list(p) ((p).type == LISP_PAIR || (p).type == LISP_NULL) - // Numbers Lisp lisp_make_int(LispInt n); LispInt lisp_int(Lisp x); @@ -207,7 +205,6 @@ Lisp lisp_parse_real(const char* string); LispReal lisp_number_to_real(Lisp x); LispInt lisp_number_to_int(Lisp x); - // Bools Lisp lisp_make_bool(int t); int lisp_bool(Lisp x); @@ -249,17 +246,12 @@ Lisp lisp_list_reverse2(Lisp l, Lisp tail); // O(n) Lisp lisp_list_append(Lisp l, Lisp tail, LispContext ctx); // O(n) Lisp lisp_list_advance(Lisp l, int i); // O(n) Lisp lisp_list_ref(Lisp l, int i); // O(n) -int lisp_list_index_of(Lisp l, Lisp x); // O(n) int lisp_list_length(Lisp l); // O(n) -// given a list of pairs ((key1 val1) (key2 val2) ... (keyN valN)) -// returns the pair with the given key or null of none -Lisp lisp_list_assoc(Lisp l, Lisp key); // O(n) - -Lisp lisp_list_assq(Lisp l, Lisp key); // O(n) - -// given a list of pairs returns the value of the pair with the given key. (car (cdr (assoc ..))) -Lisp lisp_list_for_key(Lisp l, Lisp key); // O(n) +// Association lists "alists" +// Given a list of pairs ((key1 val1) (key2 val2) ... (keyN valN)) +// returns the value with tgiven key. +Lisp lisp_alist_ref(Lisp l, Lisp key); // O(n) // Vectors (heterogeneous) Lisp lisp_make_vector(int n, LispContext ctx); @@ -270,16 +262,17 @@ Lisp lisp_vector_ref(Lisp v, int i); void lisp_vector_set(Lisp v, int i, Lisp x); void lisp_vector_swap(Lisp v, int i, int j); void lisp_vector_fill(Lisp v, Lisp x); -Lisp lisp_vector_assq(Lisp v, Lisp key); // O(n) Lisp lisp_vector_grow(Lisp v, int n, LispContext ctx); Lisp lisp_subvector(Lisp old, int start, int end, LispContext ctx); +Lisp lisp_avector_ref(Lisp l, Lisp key); // O(n) + // Hash tables Lisp lisp_make_table(LispContext ctx); void lisp_table_set(Lisp t, Lisp key, Lisp x, LispContext ctx); Lisp lisp_table_get(Lisp t, Lisp key, int* present); int lisp_table_size(Lisp t); -Lisp lisp_table_to_assoc_list(Lisp t, LispContext ctx); +Lisp lisp_table_to_alist(Lisp t, LispContext ctx); // ----------------------------------------- // LANGUAGE @@ -862,45 +855,14 @@ Lisp lisp_list_ref(Lisp l, int n) return lisp_make_null(); } -int lisp_list_index_of(Lisp l, Lisp x) -{ - int i = 0; - while (lisp_is_pair(l)) - { - if (lisp_eq(lisp_car(l), x)) return i; - ++i; - l = lisp_cdr(l); - } - return -1; -} - int lisp_list_length(Lisp l) { - int count = 0; - while (lisp_is_pair(l)) - { - ++count; - l = lisp_cdr(l); - } - return count; + int n = 0; + while (lisp_is_pair(l)) { ++n; l = lisp_cdr(l); } + return n; } -Lisp lisp_list_assoc(Lisp l, Lisp key) -{ - while (lisp_is_pair(l)) - { - Lisp pair = lisp_car(l); - if (lisp_is_pair(pair) && lisp_equal_r(lisp_car(pair), key)) - { - return pair; - } - - l = lisp_cdr(l); - } - return lisp_make_null(); -} - -Lisp lisp_list_assq(Lisp l, Lisp key) +Lisp lisp_alist_ref(Lisp l, Lisp key) { while (lisp_is_pair(l)) { @@ -915,51 +877,6 @@ Lisp lisp_list_assq(Lisp l, Lisp key) return lisp_make_null(); } -Lisp lisp_list_for_key(Lisp l, Lisp key) -{ - Lisp pair = lisp_list_assq(l, key); - Lisp x = lisp_cdr(pair); - if (!lisp_is_pair(x)) return lisp_make_null(); - return lisp_car(x); -} - -// TODO: get rid of this? -Lisp lisp_list_accessor_mnemonic(Lisp p, const char* c) -{ - if (toupper(*c) != 'C') return lisp_make_null(); - - ++c; - int i = 0; - while (toupper(*c) != 'R' && *c) - { - ++i; - ++c; - } - - if (toupper(*c) != 'R') return lisp_make_null(); - --c; - - while (i > 0) - { - if (toupper(*c) == 'D') - { - p = lisp_cdr(p); - } - else if (toupper(*c) == 'A') - { - p = lisp_car(p); - } - else - { - return lisp_make_null(); - } - --c; - --i; - } - - return p; -} - static int _vector_len(const Vector* v) { return v->block.d.vector.length; } // types are stored in an array of bytes at the end of the data. @@ -1031,17 +948,6 @@ void lisp_vector_fill(Lisp v, Lisp x) lisp_vector_set(v, i, x); } -Lisp lisp_vector_assq(Lisp v, Lisp key) -{ - int n = lisp_vector_length(v); - for (int i = 0; i < n; ++i) - { - Lisp pair = lisp_vector_ref(v, i); - if (lisp_eq(lisp_car(pair), key)) return pair; - } - return lisp_make_null(); -} - Lisp lisp_subvector(Lisp old, int start, int end, LispContext ctx) { assert(start <= end); @@ -1078,6 +984,17 @@ Lisp lisp_vector_grow(Lisp v, int n, LispContext ctx) } } +Lisp lisp_avector_ref(Lisp v, Lisp key) +{ + int n = lisp_vector_length(v); + for (int i = 0; i < n; ++i) + { + Lisp pair = lisp_vector_ref(v, i); + if (lisp_is_pair(pair) && lisp_eq(lisp_car(pair), key)) return pair; + } + return lisp_make_null(); +} + static uint64_t hash_uint64(uint64_t x) { x *= 0xff51afd7ed558ccd; @@ -1208,7 +1125,7 @@ Lisp lisp_table_get(Lisp t, Lisp key, int* present) } } -Lisp lisp_table_to_assoc_list(Lisp t, LispContext ctx) +Lisp lisp_table_to_alist(Lisp t, LispContext ctx) { const Table* table = table_get_(t); Lisp result = lisp_make_null(); @@ -3512,21 +3429,13 @@ static Lisp sch_reverse_inplace(Lisp args, LispError* e, LispContext ctx) ARITY_CHECK(1, 1); return lisp_list_reverse(lisp_car(args)); } - -static Lisp sch_assoc(Lisp args, LispError* e, LispContext ctx) -{ - ARITY_CHECK(2, 2); - Lisp key = lisp_car(args); - Lisp l = lisp_car(lisp_cdr(args)); - return lisp_list_assoc(l, key); -} - -static Lisp sch_assq(Lisp args, LispError* e, LispContext ctx) +static Lisp sch_list_advance(Lisp args, LispError* e, LispContext ctx) { ARITY_CHECK(2, 2); - Lisp key = lisp_car(args); - Lisp l = lisp_car(lisp_cdr(args)); - return lisp_list_assq(l, key); + Lisp x = lisp_car(args); + args = lisp_cdr(args); + Lisp count = lisp_car(args); + return lisp_list_advance(x, lisp_int(count)); } static Lisp sch_add(Lisp args, LispError* e, LispContext ctx) @@ -3987,6 +3896,11 @@ static Lisp sch_is_boolean(Lisp args, LispError* e, LispContext ctx) return lisp_make_bool(lisp_type(lisp_car(args)) == LISP_BOOL); } +static Lisp sch_not(Lisp args, LispError* e, LispContext ctx) +{ + return lisp_make_bool(!lisp_is_true(lisp_car(args))); +} + static Lisp sch_is_even(Lisp args, LispError* e, LispContext ctx) { ARITY_CHECK(1, 1); @@ -4242,17 +4156,18 @@ static Lisp sch_vector_swap(Lisp args, LispError* e, LispContext ctx) static Lisp sch_vector_fill(Lisp args, LispError* e, LispContext ctx) { - Lisp v = lisp_list_ref(args, 0); - Lisp x = lisp_list_ref(args, 1); - lisp_vector_fill(v, x); + Lisp v = lisp_car(args); + args = lisp_cdr(args); + lisp_vector_fill(v, lisp_car(args)); return lisp_make_null(); } static Lisp sch_vector_assq(Lisp args, LispError* e, LispContext ctx) { - Lisp key = lisp_car(args); - Lisp v = lisp_car(lisp_cdr(args)); - return lisp_vector_assq(v, key); + Lisp k = lisp_car(args); + args = lisp_cdr(args); + Lisp v = lisp_car(args); + return lisp_avector_ref(v, k); } static Lisp sch_subvector(Lisp args, LispError* e, LispContext ctx) @@ -4365,7 +4280,7 @@ static Lisp sch_table_size(Lisp args, LispError* e, LispContext ctx) static Lisp sch_table_to_alist(Lisp args, LispError* e, LispContext ctx) { Lisp table = lisp_car(args); - return lisp_table_to_assoc_list(table, ctx); + return lisp_table_to_alist(table, ctx); } static Lisp sch_is_promise(Lisp args, LispError* e, LispContext ctx) @@ -4485,7 +4400,6 @@ static Lisp sch_print_gc_stats(Lisp args, LispError* e, LispContext ctx) static const LispFuncDef lib_cfunc_defs[] = { - // NON STANDARD ADDITINONS { "ERROR", sch_error }, { "SYNTAX-ERROR", sch_syntax_error }, @@ -4502,14 +4416,15 @@ static const LispFuncDef lib_cfunc_defs[] = { { "MACROEXPAND", sch_macroexpand }, - // Equivalence Predicates https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Equivalence-Predicates.html { "EQ?", sch_exact_eq }, { "EQV?", sch_equal }, { "EQUAL?", sch_equal_r }, // Booleans https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Booleans.html - + { "BOOLEAN?", sch_is_boolean }, + { "NOT", sch_not }, + // Lists https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_8.html { "CONS", sch_cons }, { "CAR", sch_car }, @@ -4524,6 +4439,7 @@ static const LispFuncDef lib_cfunc_defs[] = { { "APPEND", sch_append }, { "LIST-REF", sch_list_ref }, { "REVERSE!", sch_reverse_inplace }, + { "NTHCDR", sch_list_advance }, // Vectors https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_9.html#SEC82 { "VECTOR", sch_vector }, @@ -4535,6 +4451,7 @@ static const LispFuncDef lib_cfunc_defs[] = { { "VECTOR-SWAP!", sch_vector_swap }, { "VECTOR-REF", sch_vector_ref }, { "VECTOR-FILL!", sch_vector_fill }, + { "VECTOR-ASSQ", sch_vector_assq }, { "SUBVECTOR", sch_subvector }, { "LIST->VECTOR", sch_list_to_vector }, { "VECTOR->LIST", sch_vector_to_list }, @@ -4570,13 +4487,6 @@ static const LispFuncDef lib_cfunc_defs[] = { { "CHAR->INTEGER", sch_to_exact }, // Association Lists https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Association-Lists.html - { "ASSOC", sch_assoc }, - { "ASSQ", sch_assq }, - - // TODO: Non Standard - { "VECTOR-ASSQ", sch_vector_assq }, - { "BOOLEAN?", sch_is_boolean }, - // Numerical operations https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Numerical-operations.html { "=", sch_equals }, { "+", sch_add }, @@ -4615,7 +4525,6 @@ static const LispFuncDef lib_cfunc_defs[] = { { "SYSTEM-GLOBAL-ENVIRONMENT", sch_system_env }, { "USER-INITIAL-ENVIRONMENT", sch_user_env }, // { "THE-ENVIRONMENT", sch_current_env }, - // TODO: purify // Hash Tables https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Basic-Hash-Table-Operations.html#Basic-Hash-Table-Operations { "HASH-TABLE?", sch_is_table }, @@ -4694,8 +4603,6 @@ static const LispFuncDef lib_cfunc_defs[] = { // (if t f)) static const char* lib_code0 = "\ -(define (not x) (if x #f #t)) \ -\ (define (first x) (car x)) \ (define (second x) (car (cdr x))) \ (define (third x) (car (cdr (cdr x)))) \ @@ -4787,11 +4694,6 @@ static const char* lib_code1 = " \ (lambda (v l) \ `(begin (set! ,l (cons ,v ,l)) ,l))) \ \ -(define (nthcdr n list) \ - (cond ((= n 0) list) \ - ((null? list) '()) \ - (t (nthcdr (- n 1) (cdr list))))) \ -\ (define-macro do \ (lambda (vars loop-check . loops) \ (let ((names '()) \ @@ -4872,10 +4774,21 @@ static const char* lib_code_sequence = " \ (helper (map1 cdr lists '()))))) \ (helper rest)) \ \ +(define (_assoc key list eq?) \ + (if (null? list) '() \ + (let ((pair (car list))) \ + (if (and (pair? pair) (eq? key (car pair))) \ + pair \ + (_assoc key (cdr list) eq?))))) \ +\ +(define (assoc key list) (_assoc key list equal?)) \ +(define (assq key list) (_assoc key list eq?)) \ +(define (assv key list) (_assoc key list eqv?)) \ +\ (define (_member x list eq?) \ (cond ((null? list) #f) \ ((eq? (car list) x) list) \ - (else (_member x (cdr list))))) \ + (else (_member x (cdr list) eq?)))) \ \ (define (member x list) (_member x list equal?)) \ (define (memq x list) (_member x list eq?)) \ diff --git a/tests/code/bugs.scm b/tests/code/bugs.scm index 41636b8..94879e8 100644 --- a/tests/code/bugs.scm +++ b/tests/code/bugs.scm @@ -25,16 +25,6 @@ (hello-world) ; vector and list assoc -(define vec-map #((bob . 1) (john . 2) (dan . 3) (alice . 4))) -(define list-map '((bob . 1) (john . 2) (dan . 3) (alice . 4))) - -(assert (= (cdr (vector-assq 'john vec-map)) 2)) -(assert (= (cdr (vector-assq 'alice vec-map)) 4)) -(assert (null? (vector-assq 'bad-key vec-map))) - -(assert (= (cdr (assoc 'john list-map)) 2)) -(assert (= (cdr (assoc 'alice list-map)) 4)) -(assert (null? (assoc 'bad-key list-map))) (assert (= (do ((i 1 (+ i 1)) (n 0 n)) @@ -49,3 +39,4 @@ (assert (equal? (cons 2000 1) (cons 2000 1))) (assert (equal? "apple" "apple")) +(assert (not (eq? 'DEFINE 'DEFINE-MACRO))) diff --git a/tests/code/lists.scm b/tests/code/lists.scm index 504c396..fecb395 100644 --- a/tests/code/lists.scm +++ b/tests/code/lists.scm @@ -37,3 +37,15 @@ (=> (memq 'a '(b c d)) #f) (assert (= (apply + (list 3 4 5 6)) 18)) + +; Association lists +(define list-map '((bob . 1) (john . 2) (dan . 3) (alice . 4))) + +(assert (= (cdr (assoc 'john list-map)) 2)) +(assert (= (cdr (assoc 'alice list-map)) 4)) +(assert (null? (assoc 'bad-key list-map))) + +(assert (= (cdr (assq 'john list-map)) 2)) +(assert (= (cdr (assq 'alice list-map)) 4)) +(assert (null? (assq 'bad-key list-map))) + diff --git a/tests/code/vectors.scm b/tests/code/vectors.scm index 3706379..9a31f2d 100644 --- a/tests/code/vectors.scm +++ b/tests/code/vectors.scm @@ -63,3 +63,11 @@ (=> (subvector #(1 2 3 4) 0 2) #(1 2)) (=> (subvector #(A 1 A 1 A 1 A 1) 1 3) #(1 A)) +; Association +(define avector #((bob . 1) (john . 2) (dan . 3) (alice . 4))) + +(assert (= (cdr (vector-assq 'john avector)) 2)) +(assert (= (cdr (vector-assq 'alice avector)) 4)) +(assert (null? (vector-assq 'bad-key avector))) + +