From 919b835bfc258e146e38dbdead25edcec731e856 Mon Sep 17 00:00:00 2001 From: Justin Meiners Date: Fri, 17 Dec 2021 20:34:31 -0700 Subject: [PATCH 1/3] cleanup macro --- lisp.h | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/lisp.h b/lisp.h index d53d307..1cafbb5 100644 --- a/lisp.h +++ b/lisp.h @@ -4808,20 +4808,21 @@ static const char* lib_code_lang0 = "\ (if (null? l) '() \ (begin (proc (car l)) (for-each1 proc (cdr l ))))) \ \ +(define (_make-lambda args body) \ + (list 'LAMBDA args (if (null? (cdr body)) (car body) (cons 'BEGIN body)))) \ +\ (define (_let->combination var bindings body) \ (for-each1 (lambda (entry) \ (if (not (pair? entry)) (syntax-error \"bad let binding\" entry)) \ (if (not (symbol? (first entry))) (syntax-error \"let entry missing symbol\" entry))) bindings) \ - (define body-func (list 'LAMBDA \ - (map1 (lambda (entry) (car entry)) bindings '()) \ - (if (null? (cdr body)) (car body) (cons 'BEGIN body)))) \ + (define body-func (_make-lambda (map1 (lambda (entry) (car entry)) bindings '()) body)) \ (define initial-args (map1 (lambda (entry) (car (cdr entry))) bindings '())) \ (if (null? var) \ (cons body-func initial-args) \ - (list (list 'LAMBDA '() (list 'DEFINE var body-func) (cons var initial-args))))) \ + (list (_make-lambda '() (list (list 'DEFINE var body-func) (cons var initial-args)))))) \ \ (define-macro let (lambda args \ -(if (pair? (first args)) \ + (if (pair? (first args)) \ (_let->combination '() (car args) (cdr args)) \ (_let->combination (first args) (second args) (cdr (cdr args)))))) \ \ @@ -4831,8 +4832,7 @@ static const char* lib_code_lang0 = "\ (define-macro let* (lambda (def-list . body) (_let*-helper def-list body))) \ \ (define (_cond-helper clauses) \ - (if (null? clauses) \ - '() \ + (if (null? clauses) '() \ (if (eq? (car (car clauses)) 'ELSE) \ (cons 'BEGIN (cdr (car clauses))) \ (list 'IF \ From 1e581f5027381d57cc257ed981f6475d3e5a7cae Mon Sep 17 00:00:00 2001 From: Justin Meiners Date: Sat, 18 Dec 2021 14:04:28 -0700 Subject: [PATCH 2/3] improved language compatibility and testing --- lisp.h | 119 +++++++++----- repl.c | 10 +- tests/code/bugs.scm | 8 +- tests/code/dp.scm | 2 +- tests/code/gc.scm | 2 +- tests/code/include/prolog.scm | 283 ++++++++++++++++++++++++++++++++++ tests/code/lists.scm | 35 +++-- tests/code/mit.scm | 44 +++++- tests/code/norvig.scm | 12 +- tests/code/numbers.scm | 47 +++--- tests/code/prolog.scm | 5 + tests/code/streams.scm | 14 +- tests/code/strings.scm | 31 ++-- tests/code/vectors.scm | 26 ++-- 14 files changed, 506 insertions(+), 132 deletions(-) create mode 100644 tests/code/include/prolog.scm create mode 100644 tests/code/prolog.scm diff --git a/lisp.h b/lisp.h index 1cafbb5..aecdec4 100644 --- a/lisp.h +++ b/lisp.h @@ -892,7 +892,7 @@ Lisp lisp_alist_ref(Lisp l, Lisp key) } l = lisp_cdr(l); } - return lisp_make_null(); + return lisp_false(); } static int _vector_len(const Vector* v) { return v->block.d.vector.length; } @@ -1007,7 +1007,7 @@ Lisp lisp_avector_ref(Lisp v, Lisp key) Lisp pair = lisp_vector_ref(v, i); if (lisp_is_pair(pair) && lisp_eq(lisp_car(pair), key)) return pair; } - return lisp_make_null(); + return lisp_false(); } static uint64_t hash_uint64(uint64_t x) @@ -3374,8 +3374,18 @@ static Lisp sch_read(Lisp args, LispError* e, LispContext ctx) static Lisp sch_error(Lisp args, LispError* e, LispContext ctx) { - Lisp l = lisp_car(args); - fputs(lisp_string(l), ctx.p->out_port); + if (lisp_is_pair(args)) + { + Lisp l = lisp_car(args); + fputs(lisp_string(l), ctx.p->err_port); + args = lisp_cdr(args); + } + while (lisp_is_pair(args)) + { + fputs(" ", ctx.p->err_port); + lisp_printf(ctx.p->err_port, lisp_car(args)); + args = lisp_cdr(args); + } *e = LISP_ERROR_RUNTIME; return lisp_make_null(); @@ -3567,6 +3577,7 @@ static Lisp sch_divide(Lisp args, LispError* e, LispContext ctx) case LISP_REAL: return lisp_make_real(lisp_number_to_real(x) / lisp_real(y)); case LISP_INT: + // TODO: divide by zero check? return lisp_make_int(lisp_int(x) / lisp_int(y)); default: *e = LISP_ERROR_TYPE; @@ -3653,6 +3664,7 @@ static Lisp sch_symbol_less(Lisp args, LispError* e, LispContext ctx) static Lisp sch_string_to_symbol(Lisp args, LispError* e, LispContext ctx) { + ARITY_CHECK(1, 1); Lisp val = lisp_car(args); if (lisp_type(val) != LISP_STRING) { @@ -4797,13 +4809,15 @@ static const char* lib_code_lang0 = "\ (if (pred (car l)) #t \ (some? pred (cdr l))))) \ \ -(define (map1 proc l result) \ +(define (_map1-helper proc l result) \ (if (null? l) \ (reverse! result) \ - (map1 proc \ + (_map1-helper proc \ (cdr l) \ (cons (proc (car l)) result)))) \ \ +(define (map1 proc l) (_map1-helper proc l '())) \ +\ (define (for-each1 proc l) \ (if (null? l) '() \ (begin (proc (car l)) (for-each1 proc (cdr l ))))) \ @@ -4811,12 +4825,15 @@ static const char* lib_code_lang0 = "\ (define (_make-lambda args body) \ (list 'LAMBDA args (if (null? (cdr body)) (car body) (cons 'BEGIN body)))) \ \ +(define (_check-binding-list bindings) \ + (for-each1 (lambda (entry) \ + (if (not (pair? entry)) (syntax-error \"bad let binding\" entry)) \ + (if (not (symbol? (first entry))) (syntax-error \"let entry missing symbol\" entry))) bindings)) \ +\ (define (_let->combination var bindings body) \ - (for-each1 (lambda (entry) \ - (if (not (pair? entry)) (syntax-error \"bad let binding\" entry)) \ - (if (not (symbol? (first entry))) (syntax-error \"let entry missing symbol\" entry))) bindings) \ - (define body-func (_make-lambda (map1 (lambda (entry) (car entry)) bindings '()) body)) \ - (define initial-args (map1 (lambda (entry) (car (cdr entry))) bindings '())) \ + (_check-binding-list bindings) \ + (define body-func (_make-lambda (map1 (lambda (entry) (first entry)) bindings) body)) \ + (define initial-args (map1 (lambda (entry) (second entry)) bindings)) \ (if (null? var) \ (cons body-func initial-args) \ (list (_make-lambda '() (list (list 'DEFINE var body-func) (cons var initial-args)))))) \ @@ -4826,10 +4843,20 @@ static const char* lib_code_lang0 = "\ (_let->combination '() (car args) (cdr args)) \ (_let->combination (first args) (second args) (cdr (cdr args)))))) \ \ -(define (_let*-helper def-list body) \ - (if (null? def-list) (if (null? (cdr body)) (car body) (cons 'BEGIN body)) \ - (list 'LET (list (car def-list)) (_let*-helper (cdr def-list) body)))) \ -(define-macro let* (lambda (def-list . body) (_let*-helper def-list body))) \ +(define (_let*-helper bindings body) \ + (if (null? bindings) (if (null? (cdr body)) (car body) (cons 'BEGIN body)) \ + (list 'LET (list (car bindings)) (_let*-helper (cdr bindings) body)))) \ +\ +(define-macro let* (lambda (bindings . body) \ + (_check-binding-list bindings) \ + (_let*-helper bindings body))) \ +\ +(define-macro letrec (lambda (bindings . body) \ + (_check-binding-list bindings) \ + (cons (_make-lambda (map1 (lambda (entry) (first entry)) bindings) \ + (append (map1 (lambda (entry) (list 'SET! (first entry) (second entry))) \ + bindings) body)) \ + (map1 (lambda (entry) '()) bindings)))) \ \ (define (_cond-helper clauses) \ (if (null? clauses) '() \ @@ -4847,27 +4874,36 @@ static const char* lib_code_lang0 = "\ (syntax-error \"(cond (pred expression...)...)\")) \ ) clauses) \ (_cond-helper clauses)))) \ -\ +"; + +static const char* lib_code_lang1 = " \ (define (_and-helper preds) \ - (if (null? preds) #t \ - (cons 'IF \ - (cons (car preds) \ - (cons (_and-helper (cdr preds)) (cons #f '())) )))) \ + (cond ((null? preds) #t) \ + ((null? (cdr preds)) (car preds)) \ + (else \ + `(IF ,(car preds) ,(_and-helper (cdr preds)) #f)))) \ +(define-macro and (lambda preds (_and-helper preds))) \ \ -(define-macro and \ - (lambda preds (_and-helper preds))) \ +(define (_or-helper preds var) \ + (cond ((null? preds) #f) \ + ((null? (cdr preds)) (car preds)) \ + (else \ + `(BEGIN (SET! ,var ,(car preds)) \ + (IF ,var ,var ,(_or-helper (cdr preds) var)))))) \ \ -(define (_or-helper preds) \ - (if (null? preds) #f \ - (cons 'IF \ - (cons (car preds) \ - (cons #t (cons (_or-helper (cdr preds)) '()) ))))) \ +(define-macro or (lambda preds \ + (let ((var (gensym))) \ + `(LET ((,var '())) ,(_or-helper preds var))))) \ +\ +(define-macro case (lambda (key . clauses) \ + (let ((expr (gensym))) \ + `(let ((,expr ,key)) \ + ,(cons 'COND (map1 (lambda (entry) \ + (cons (if (pair? (car entry)) \ + `(memv ,expr (quote ,(car entry))) \ + (car entry)) \ + (cdr entry))) clauses)))))) \ \ -(define-macro or \ - (lambda preds (_or-helper preds))) \ -"; - -static const char* lib_code_lang1 = " \ (define-macro push \ (lambda (v l) \ `(begin (set! ,l (cons ,v ,l)) ,l))) \ @@ -4906,7 +4942,7 @@ static const char* lib_code_lang1 = " \ (cons 'DEFINE (cons (list (string->symbol (string-append \"C\" text \"R\")) 'pair) \ (_expand-mnemonic-body (string->list text))))) \ \ -(define-macro _mnemonic-accessors (lambda args (cons 'BEGIN (map1 _expand-mnemonic args '())))) \ +(define-macro _mnemonic-accessors (lambda args (cons 'BEGIN (map1 _expand-mnemonic args)))) \ "; static const char* lib_code_lists = " \ @@ -4926,8 +4962,8 @@ static const char* lib_code_lists = " \ (define (helper lists result) \ (if (some? null? lists) \ (reverse! result) \ - (helper (map1 cdr lists '()) \ - (cons (apply proc (map1 car lists '())) result)))) \ + (helper (map1 cdr lists) \ + (cons (apply proc (map1 car lists)) result)))) \ (helper rest '())) \ \ (define (for-each proc . rest) \ @@ -4935,12 +4971,12 @@ static const char* lib_code_lists = " \ (if (some? null? lists) \ '() \ (begin \ - (apply proc (map1 car lists '())) \ - (helper (map1 cdr lists '()))))) \ + (apply proc (map1 car lists)) \ + (helper (map1 cdr lists))))) \ (helper rest)) \ \ (define (_assoc key list eq?) \ - (if (null? list) '() \ + (if (null? list) #f \ (let ((pair (car list))) \ (if (and (pair? pair) (eq? key (car pair))) \ pair \ @@ -5061,7 +5097,7 @@ static const char* lib_code_sequence = " \ (define (vector-binary-search v key< unwrap-key key) \ (define (helper low high mid) \ (if (<= (- high low) 1) \ - (if (key< (unwrap-key (vector-ref v low)) key) '() (vector-ref v low)) \ + (if (key< (unwrap-key (vector-ref v low)) key) #f (vector-ref v low)) \ (begin \ (set! mid (+ low (quotient (- high low) 2))) \ (if (key< key (unwrap-key (vector-ref v mid))) \ @@ -5096,14 +5132,13 @@ static const char* lib_code_sequence = " \ \ (define (sort list cmp) (vector->list (sort! (list->vector list) cmp))) \ \ -(define-macro assert \ - (lambda (body) \ +(define-macro assert (lambda (body) \ `(if ,body '() \ (begin \ (display (quote ,body)) \ (error \" assert failed\"))))) \ \ -(define-macro => \ +(define-macro ==> \ (lambda (test expected) \ `(assert (equal? ,test (quote ,expected))) )) \ "; diff --git a/repl.c b/repl.c index 3881973..034be53 100644 --- a/repl.c +++ b/repl.c @@ -45,6 +45,14 @@ int main(int argc, const char* argv[]) ctx ); + // Load as a macro is called "include" and can be used to load files containing macros. + lisp_table_set( + lisp_macro_table(ctx), + lisp_make_symbol("INCLUDE", ctx), + lisp_make_func(sch_load), + ctx + ); + clock_t start_time, end_time; if (file_path) @@ -59,7 +67,7 @@ int main(int argc, const char* argv[]) if (!file) { - fprintf(stderr, "failed to open: %s", argv[1]); + fprintf(stderr, "failed to open: %s", file_path); return 2; } diff --git a/tests/code/bugs.scm b/tests/code/bugs.scm index 641240c..df26117 100644 --- a/tests/code/bugs.scm +++ b/tests/code/bugs.scm @@ -43,14 +43,14 @@ (define (scope-test var) (let ((var "dog")) - (=> var "dog")) - (=> var "cat")) + (==> var "dog")) + (==> var "cat")) (scope-test "cat") (define (scope-test-named var) (let block-name ((var "dog")) - (=> var "dog")) - (=> var "cat")) + (==> var "dog")) + (==> var "cat")) (scope-test-named "cat") diff --git a/tests/code/dp.scm b/tests/code/dp.scm index 4ca5837..cb0dcfd 100644 --- a/tests/code/dp.scm +++ b/tests/code/dp.scm @@ -56,4 +56,4 @@ (define (edit-distance a b) (edit-distance-list (string->list a) (string->list b) char=?)) -(=> (edit-distance "kitten" "sitting") 3) +(==> (edit-distance "kitten" "sitting") 3) diff --git a/tests/code/gc.scm b/tests/code/gc.scm index 86ef5fa..3811a18 100644 --- a/tests/code/gc.scm +++ b/tests/code/gc.scm @@ -30,7 +30,7 @@ (basic-loop) -(=> (call/cc (lambda (throw) (define x '(1 2 3)) (gc-flip) (throw x))) (1 2 3)) +(==> (call/cc (lambda (throw) (define x '(1 2 3)) (gc-flip) (throw x))) (1 2 3)) (print-gc-statistics) diff --git a/tests/code/include/prolog.scm b/tests/code/include/prolog.scm new file mode 100644 index 0000000..0156a53 --- /dev/null +++ b/tests/code/include/prolog.scm @@ -0,0 +1,283 @@ +; Scheme 9 from Empty Space, Function Library +; By Nils M Holm, 1998-2009 +; Placed in the Public Domain +; +; (prolog list1 list2) ==> list +; (new-database!) ==> unspecific +; (fact! list) ==> unspecific +; (predicate! list1 list2 ...) ==> unspecific +; (query list) ==> list +; +; (load-from-library "prolog.scm") +; +; This is a tiny PROLOG interpreter that is based on an even +; tinier PROLOG interpreter written in MACLISP by Ken Kahn. +; +; The PROLOG procedures takes a query LIST1 and a database +; LIST2 as arguments, attempts to prove LIST1 in LIST2, and +; returns the result(s). + +; NEW-DATABASE! sets up a fresh PROLOG database (thereby +; deleting any existing one). +; +; FACT! adds a new fact to the database. +; +; PREDICATE! adds a predicate with the head LIST1 and the +; clauses LIST2 ... to the database. +; +; QUERY attempts to prove LIST1. It returns a list of results. +; An empty list indicates that LIST1 could not be proven. +; +; See "prolog-test.scm" for an example program. +; +; The following macros add some syntactic sugar for interactive +; use; they allows you to write, for instance, (! (man socrates)) +; instead of (fact! '(man socrates)). +; +; (! fact) ==> unspecific +; (:- list1 list2 ...) ==> unspecific +; (? query) ==> unspecific +; +; The following special predicates are implemented in the +; interpreter: (== A B) returns a new environment if A can be +; unified with B, else NO. (Dif A B) returns NO if A can be +; unified with B, else YES (use only at the end of a clause!) +; +; Example: (begin (! (man socrates)) +; (:- (mortal ?x) +; (man ?x)) +; (query '(mortal ?who))) ==> (((who . socrates))) + +(define *prolog-database* '()) + +(define (prolog q db) + + (define empty-env '((()))) + + (define top-scope "") + + (define true '(())) + + (define false '()) + + (define (unique a) + (letrec + ((unique2 + (lambda (a r) + (cond ((null? a) + (reverse! r)) + ((member (car a) r) + (unique2 (cdr a) r)) + (else + (unique2 (cdr a) + (cons (car a) r))))))) + (unique2 a '()))) + + (define (variable? x) + (and (symbol? x) + (char=? #\? (string-ref (symbol->string x) 0)))) + + (define (internal? x) + (and (symbol? x) + (char=? #\: (string-ref (symbol->string x) 0)))) + + (define (anonymous? x) + (eq? '_ x)) + + (define (extend n v env) + (cons (cons n v) env)) + + (define (new-scope env id) + (cond ((variable? env) + (string->symbol + (string-append (symbol->string env) id))) + ((pair? env) + (cons (new-scope (car env) id) + (new-scope (cdr env) id))) + (else + env))) + + (define (new-env-id x) + (string-append ";" x)) + + (define (value-of x env) + (if (variable? x) + (let ((v (assq x env))) + (if v + (value-of (cdr v) env) + x)) + x)) + + (define (unify x y env) + (let ((x (value-of x env)) + (y (value-of y env))) + (cond ((variable? x) (extend x y env)) + ((variable? y) (extend y x env)) + ((or (anonymous? x) + (anonymous? y)) + env) + ((and (pair? x) + (pair? y)) + (let ((new (unify (car x) (car y) env))) + (and new (unify (cdr x) (cdr y) new)))) + ((eq? x y) env) + (else #f)))) + + (define (check-args g n) + (if (not (= n (length g))) + (error "wrong number of arguments" g))) + + (define (goal-unify rules goals env id result) + (check-args (car goals) 3) + (let* ((this-goal (car goals)) + (new-env (unify (cadr this-goal) (caddr this-goal) env))) + (if new-env + (let ((r (prove (cdr goals) + new-env + (new-env-id id)))) + (try-rules (cdr rules) goals env id (append result r))) + (try-rules (cdr rules) goals env id result)))) + + (define (goal-dif rules goals env id result) + (check-args (car goals) 3) + (let* ((this-goal (car goals)) + (new-env (unify (cadr this-goal) (caddr this-goal) env))) + (if (not new-env) + (let ((r (prove (cdr goals) + env + (new-env-id id)))) + (try-rules (cdr rules) goals env id (append result r))) + false))) + + (define (goal* rules goals env id result) + (let* ((this-rule (new-scope (car rules) id)) + (new-env (unify (car goals) (car this-rule) env))) + (if new-env + (let ((r (prove (append (cdr this-rule) (cdr goals)) + new-env + (new-env-id id)))) + (try-rules (cdr rules) goals env id (append result r))) + (try-rules (cdr rules) goals env id result)))) + + (define (try-rules rules goals env id result) + (if (null? rules) + result + (case (caar goals) + ((==) (goal-unify rules goals env id result)) + ((dif) (goal-dif rules goals env id result)) + (else (goal* rules goals env id result))))) + + (define (list-env env) + (letrec + ((this-id caar) + (scope-id caddr) + (top-level? + (lambda (x) + (not (memv #\; (string->list (symbol->string x)))))) + (var-name + (lambda (x) + (let* ((s (symbol->string x)) + (k (string-length s))) + (let loop ((i 0)) + (if (or (>= i k) + (char=? #\; (string-ref s i))) + (string->symbol (substring s 1 i)) + (loop (+ 1 i))))))) + (list-env2 + (lambda (e r) + (cond ((null? (cdr e)) + (list r)) + ((top-level? (this-id e)) + (list-env2 (cdr e) + (extend (var-name (this-id e)) + (value-of (this-id e) env) + r))) + (else + (list-env2 (cdr e) r)))))) + + (list-env2 env '()))) + + ; version without memoization + (define (prove goals env id) + (if (null? goals) + (list-env env) + (try-rules db goals env id '()))) + + ;(define proven (make-hash-table)) + + ;(define (prove goals env id) + ; (if (null? goals) + ; (list-env env) + ; (let* ((k (append goals env)) + ; (v (hash-table-ref proven k #f))) + ; (if v + ; (car v) + ; (let ((v (try-rules db goals env id '()))) + ; (hash-table-set! proven k v) + ; v))))) + + (define (any? p a) + (cond ((null? a) #f) + ((p (car a)) #t) + (else (any? p (cdr a))))) + + (define (cleanup env) + (apply append + (map (lambda (frame) + (if (or (any? (lambda (x) (variable? (cdr x))) frame) + (any? (lambda (x) (internal? (cdr x))) frame)) + '() + (list frame))) + env))) + + (cleanup (unique (prove (new-scope q top-scope) + empty-env + (new-env-id top-scope))))) + +(define (new-database!) + (set! *prolog-database* '())) + +(define (update! x) + (set! *prolog-database* + (cons x *prolog-database*))) + +(define (fact! x) + (let ((update! update!)) + (update! (list x)))) + +(define (predicate! head . clause*) + (let ((update! update!)) + (update! (cons head clause*)))) + +(define (query . q) + (prolog q (reverse *prolog-database*))) + +(define (print-frames env) + (cond ((equal? '(()) env) + (display "yes") + (newline)) + ((equal? '() env) + (display "no") + (newline)) + (else + (for-each (lambda (frame) + (for-each (lambda (b) + (display (car b)) + (display " = ") + (display (cdr b)) + (display "; ")) + frame) + (newline)) + env)))) + +(define-macro ! (lambda (fact) `(fact! (quote ,fact)))) +(define-macro :- (lambda args + (cons 'PREDICATE! (map1 (lambda (entry) `(quote ,entry)) args)))) +(define-macro ? (lambda args + (list 'PRINT-FRAMES + (cons 'QUERY (map1 (lambda (entry) `(quote ,entry)) args))))) + + + + + diff --git a/tests/code/lists.scm b/tests/code/lists.scm index d4ac082..8092050 100644 --- a/tests/code/lists.scm +++ b/tests/code/lists.scm @@ -1,17 +1,17 @@ (assert '()) -(=> (cons 'a (cons 'b (cons 'c '()))) (a b c)) -(=> (car (cons 1 2)) 1) -(=> (cdr (cons 1 2)) 2) -(=> (car (list 1 2)) 1) -(=> (cdr (list 1 2)) (2)) +(==> (cons 'a (cons 'b (cons 'c '()))) (a b c)) +(==> (car (cons 1 2)) 1) +(==> (cdr (cons 1 2)) 2) +(==> (car (list 1 2)) 1) +(==> (cdr (list 1 2)) (2)) (define test-pair (cons 1 2)) (set-car! test-pair 3) (set-cdr! test-pair 4) -(=> test-pair (3 . 4)) +(==> test-pair (3 . 4)) -(=> (reverse '(a b c)) (c b a)) +(==> (reverse '(a b c)) (c b a)) ; https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_8.html (assert (pair? '(a . b))) @@ -28,26 +28,29 @@ (assert (eq? (list-ref '(a b c d) 2) 'c)) -(=> (append '(a) '(b c d)) (a b c d)) -(=> (sort '(1 4 2 6 3) <) (1 2 3 4 6)) -(=> (make-list 4 1) (1 1 1 1)) +(==> (append '(a) '(b c d)) (a b c d)) +(==> (sort '(1 4 2 6 3) <) (1 2 3 4 6)) +(==> (make-list 4 1) (1 1 1 1)) -(=> (memq 'a '(a b c)) (a b c)) -(=> (memq 'b '(a b c)) (b c)) -(=> (memq 'a '(b c d)) #f) +(==> (memq 'a '(a b c)) (a b c)) +(==> (memq 'b '(a b c)) (b c)) +(==> (memq 'a '(b c d)) #f) +(==> (member (list 'a) '(b (a) c)) ((a) c)) +(==> (member 'a '(b (a) c)) #f) + (assert (= (apply + (list 3 4 5 6)) 18)) -(=> (append-reverse! '("y" "x" "w") '("z")) ("w" "x" "y" "z")) +(==> (append-reverse! '("y" "x" "w") '("z")) ("w" "x" "y" "z")) ; 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 (not (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))) +(assert (not (assq 'bad-key list-map))) diff --git a/tests/code/mit.scm b/tests/code/mit.scm index f866716..c865070 100644 --- a/tests/code/mit.scm +++ b/tests/code/mit.scm @@ -5,15 +5,19 @@ (assert (and (= 2 2) (> 2 1))) (assert (and)) +(==> (and 3 2) 2) +(==> (and 1 2 'c '(f g)) (f g)) +(==> (or #f #\a #f) #\a) +(==> (or (memq 'b '(a b c)) (/ 3 0)) (b c)) (define (bit-type x) (cond ((= x 0) 'OFF) ((= x 1) 'ON) (else 'UNKNOWN))) -(=> (bit-type 0) OFF) -(=> (bit-type 1) ON) -(=> (bit-type 25) UNKNOWN) +(==> (bit-type 0) OFF) +(==> (bit-type 1) ON) +(==> (bit-type 25) UNKNOWN) ; https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_13.html @@ -30,18 +34,46 @@ (let ((x "hello") (y "world")) -(=> (string-append x y) "helloworld")) +(==> (string-append x y) "helloworld")) (let* ((x 2) (y (+ x 1))) - (=> (+ x y) 5)) + (==> (+ x y) 5)) (do ((i 0 (+ i 1))) ((>= i 10)) (assert (>= i 0)) (display i)) -(=> (eval '(+ 2 2) (user-initial-environment)) 4) +(==> (eval '(+ 2 2) (user-initial-environment)) 4) +(assert (case (+ 2 3) + ((2) #f) + ((1 5) #t))) + +(assert (case 7 + ((2) #f) + ((1 5) #f) + (else #t))) + + +(assert (case 2 + ((2) #t) + ((1 5) #f) + (else #f))) + + +(assert (letrec ((even? + (lambda (n) + (if (zero? n) + #t + (odd? (- n 1))))) + (odd? + (lambda (n) + (if (zero? n) + #f + (even? (- n 1)))))) + (even? 88))) + diff --git a/tests/code/norvig.scm b/tests/code/norvig.scm index 3d37f31..00f4a33 100644 --- a/tests/code/norvig.scm +++ b/tests/code/norvig.scm @@ -59,13 +59,13 @@ (display (square-root 200.0)) (newline) -(=> (call/cc (lambda (throw) (+ 5 (* 10 (throw 1))))) 1) -(=> (call/cc (lambda (throw) (+ 5 (* 10 1)))) 15) +(==> (call/cc (lambda (throw) (+ 5 (* 10 (throw 1))))) 1) +(==> (call/cc (lambda (throw) (+ 5 (* 10 1)))) 15) -(=> (call/cc (lambda (throw) (+ 5 (* 10 (call/cc (lambda (escape) (* 100 (escape 3)))))))) 35) -(=> (call/cc (lambda (throw) (+ 5 (* 10 (call/cc (lambda (escape) (* 100 (throw 3)))))))) 3) -(=> (call/cc (lambda (throw) (+ 5 (* 10 (call/cc (lambda (escape) (* 100 1))))))) 1005) +(==> (call/cc (lambda (throw) (+ 5 (* 10 (call/cc (lambda (escape) (* 100 (escape 3)))))))) 35) +(==> (call/cc (lambda (throw) (+ 5 (* 10 (call/cc (lambda (escape) (* 100 (throw 3)))))))) 3) +(==> (call/cc (lambda (throw) (+ 5 (* 10 (call/cc (lambda (escape) (* 100 1))))))) 1005) -(=> (let ((a 1) (b 2)) (+ a b)) 3) +(==> (let ((a 1) (b 2)) (+ a b)) 3) diff --git a/tests/code/numbers.scm b/tests/code/numbers.scm index aa27e3b..f9bee99 100644 --- a/tests/code/numbers.scm +++ b/tests/code/numbers.scm @@ -1,27 +1,29 @@ -(=> (+ 2 2) 4) -(=> (+ (* 2 100) (* 1 10)) 210) +(==> (+ 2 2) 4) +(==> (+ (* 2 100) (* 1 10)) 210) -(=> (if (> 6 5) (+ 1 1) (+ 2 2)) 2) -(=> (if (< 6 5) (+ 1 1) (+ 2 2)) 4) +(==> (if (> 6 5) (+ 1 1) (+ 2 2)) 2) +(==> (if (< 6 5) (+ 1 1) (+ 2 2)) 4) -(=> (gcd 32 -36) 4) -(=> (gcd 4 3) 1) -(=> (gcd) 0) +(==> (gcd 32 -36) 4) +(==> (gcd 4 3) 1) +(==> (gcd) 0) -(=> (lcm 32 -36) 288) + +(==> (lcm 32 -36) 288) (assert (exact? (lcm 32 -36))) (assert (inexact? (lcm 32.0 -36))) -(=> (lcm) 1) +(==> (lcm) 1) + +(==> (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)) -(=> (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)) -(=> (- 1) -1) -(=> (- 436) -436) -(=> (- -7) 7) +(==> (- 1) -1) +(==> (- 436) -436) +(==> (- -7) 7) (assert (integer? 3)) (assert (real? 3)) @@ -40,6 +42,7 @@ (assert (= (modulo -13 4) 3)) (assert (= (remainder -13 4) -1)) + (assert (= (remainder 13 -4) 1)) (assert (even? 2)) @@ -61,16 +64,16 @@ (assert (inexact? (- 1.3 2))) (assert (exact? (expt 3 3))) -(=> (expt 3 3) 27) +(==> (expt 3 3) 27) (assert (inexact? (expt 3 2.5))) -(=> (magnitude 13) 13) -(=> (magnitude -13) 13) +(==> (magnitude 13) 13) +(==> (magnitude -13) 13) -(=> (floor 0.87) 0) -(=> (ceiling 0.87) 1) -(=> (round 0.87) 1) +(==> (floor 0.87) 0) +(==> (ceiling 0.87) 1) +(==> (round 0.87) 1) (assert (< (- (abs (atan 0)) (/ 3.141592 4)) 0.001)) diff --git a/tests/code/prolog.scm b/tests/code/prolog.scm new file mode 100644 index 0000000..2a25576 --- /dev/null +++ b/tests/code/prolog.scm @@ -0,0 +1,5 @@ +(include "include/prolog.scm") + +(! (man socrates)) +(:- (mortal ?x) (man ?x)) +(? (mortal ?who)) diff --git a/tests/code/streams.scm b/tests/code/streams.scm index 73e8723..84ea85f 100644 --- a/tests/code/streams.scm +++ b/tests/code/streams.scm @@ -1,6 +1,6 @@ -(=> (force (delay (+ 1 2))) 3) +(==> (force (delay (+ 1 2))) 3) -(=> (let ((p (delay (+ 1 2)))) +(==> (let ((p (delay (+ 1 2)))) (list (force p) (force p))) (3 3)) (assert (promise? (delay (+ 1 2)))) @@ -17,13 +17,13 @@ (define x 5) -(=> count 0) +(==> count 0) (assert (promise? p)) -(=> (force p) 15) +(==> (force p) 15) (assert (promise? p)) -(=> count 1) -(=> (force p) 15) -(=> count 1) +(==> count 1) +(==> (force p) 15) +(==> count 1) (define (integers-starting-from n) diff --git a/tests/code/strings.scm b/tests/code/strings.scm index 6b38192..f22959e 100644 --- a/tests/code/strings.scm +++ b/tests/code/strings.scm @@ -1,19 +1,19 @@ ; https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_7.html ; TODO: add characters to reader -(=> (make-string 10 #\x) "xxxxxxxxxx") +(==> (make-string 10 #\x) "xxxxxxxxxx") (assert (string? "Hi")) (assert (not (string? 'Hi))) -(=> (string-length "") 0) -(=> (string-length "The length") 10) +(==> (string-length "") 0) +(==> (string-length "The length") 10) (assert (string=? "PIE" "PIE")) (assert (not (string=? "PIE" "pie"))) -(=> (list->string (string->list "hello 123")) "hello 123") -(=> (string->list (list->string '(#\A #\B #\3))) (#\A #\B #\3)) +(==> (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 @@ -25,21 +25,24 @@ (assert (string=? "FLYING-FISH" (symbol->string 'flying-fish))) ; specials -(=> (string-length "\\") 1) -(=> (string-length "\t") 1) -(=> (string-length "\n") 1) -(=> (string-length "\f") 1) -(=> (string-length "\"") 1) +(==> (string-length "\\") 1) +(==> (string-length "\t") 1) +(==> (string-length "\n") 1) +(==> (string-length "\f") 1) +(==> (string-length "\"") 1) (display "Hello\nworld!") -(=> (string->number (number->string 279)) 279) -(=> (number->string (string->number "279")) "279") +(==> (string->number (number->string 279)) 279) +(==> (number->string (string->number "279")) "279") -(=> (string->number (number->string 0.5)) 0.5) +(==> (string->number (number->string 0.5)) 0.5) (assert (symbol (- (char->integer #\c) (char->integer #\a)) 2) +(==> (- (char->integer #\c) (char->integer #\a)) 2) + +(==> (string-ref "abc" 0) #\a) +(==> (string-ref "abc" 2) #\c) diff --git a/tests/code/vectors.scm b/tests/code/vectors.scm index 9a31f2d..6f63e35 100644 --- a/tests/code/vectors.scm +++ b/tests/code/vectors.scm @@ -5,7 +5,7 @@ (define (vec-sorted? v op) ; "if x and y are any two adjacent elements in the result, - ; where x precedes y, it is the case that (procedure y x) => #f" + ; where x precedes y, it is the case that (procedure y x) ==> #f" ; https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_8.html#SEC72 (or (< (vector-length v) 2) @@ -21,6 +21,7 @@ (assert (not (vec-sorted? #(1 2 3 4 4 3) <))) (assert (not (vec-sorted? #(1 2 3 2 4 5) <))) + ; Now test the sort function (assert (vec-sorted? (sort! #(1) <) <)) (assert (vec-sorted? (sort! #(2 1) <) <)) @@ -38,36 +39,37 @@ ; Converting between lists and vectors ;https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/Construction-of-Vectors.html -(=> (vector 'a 'b 'c) #(A B C)) -(=> (list->vector '(dididit dah)) #(dididit dah)) +(==> (vector 'a 'b 'c) #(A B C)) +(==> (list->vector '(dididit dah)) #(dididit dah)) + ; Binary serach (assert (= (vector-binary-search #(1 2 3 4 5) < (lambda (x) x) 3) 3)) -(assert (null? (vector-binary-search #(1 2 2 4 5) < (lambda (x) x) 3))) +(assert (not (vector-binary-search #(1 2 2 4 5) < (lambda (x) x) 3))) (define v (vector 1 1 2)) (vector-fill! v 3) -(=> v #(3 3 3)) +(==> v #(3 3 3)) -(=> (make-initialized-vector 5 (lambda (x) (* x x))) #(0 1 4 9 16)) +(==> (make-initialized-vector 5 (lambda (x) (* x x))) #(0 1 4 9 16)) -(=> (vector-head #(1 2 3) 2) #(1 2)) +(==> (vector-head #(1 2 3) 2) #(1 2)) ; Issues parsing large vector (define big-v #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200)) -(=> (vector-length big-v) 200) +(==> (vector-length big-v) 200) ; Subvector -(=> (subvector #(1 2 3 4) 1 4) #(2 3 4)) -(=> (subvector #(1 2 3 4) 0 2) #(1 2)) -(=> (subvector #(A 1 A 1 A 1 A 1) 1 3) #(1 A)) +(==> (subvector #(1 2 3 4) 1 4) #(2 3 4)) +(==> (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))) +(assert (not (vector-assq 'bad-key avector))) From e152c37b895fa2ba85fddb5b61f7a5a472457f4e Mon Sep 17 00:00:00 2001 From: Justin Meiners Date: Sat, 18 Dec 2021 14:19:10 -0700 Subject: [PATCH 3/3] readme --- README.md | 60 ++++++++++++++++++++++++++++++------------------------- 1 file changed, 33 insertions(+), 27 deletions(-) diff --git a/README.md b/README.md index b24eee4..5f6e1e5 100644 --- a/README.md +++ b/README.md @@ -1,25 +1,26 @@ lisp-interpreter =============== +> Any sufficiently complicated C or Fortran program contains an ad hoc, informally-specified, bug-ridden, slow implementation of half of Common Lisp. -- Philip Greenspun + An embeddable lisp/scheme interpreter written in C. -Includes a small subset of the MIT Scheme library. -I created this while reading [SICP](https://github.com/justinmeiners/sicp-excercises) to improve my knowledge of lisp and to make an implementation that allows me to easily add scripting to my own programs. +It includes a subset of R5RS with some extensions from MIT Scheme. + +I created this while reading [SICP](https://github.com/justinmeiners/sicp-excercises) to improve my knowledge of lisp +and to make an implementation that allows me to easily add scripting to my own programs. ### Philosophy -- **Simple**: Language implementations often are quite complicated and have too many fancy features. +- **Simple**: Languages can become very complicated and have too many fancy features. This project doesn't aim to be an optimal, fully featured, or compliant Scheme implementation. It is just a robust foundation for scripting. - If you need a more complete implementation try [s7](https://ccrma.stanford.edu/software/snd/snd/s7.html) - or [chicken](https://www.call-cc.org) + If you need more try [s7](https://ccrma.stanford.edu/software/snd/snd/s7.html) or [chicken](https://www.call-cc.org) -- **Unintrusive**: Just copy in the header file. - Turn on and off major features with build macros. - It should be portable between major platforms. +- **Unintrusive**: Just copy in the header file. Turn on and off major features with build macros. It should be portable between major platforms. - **Unsurprising**: You should be able to read the source code and understand how it works. - The header API should work how you expect. + The C API should work how you expect. - **First class data**: Lisp s-expressions are undervalued as an alternative to JSON or XML. Preprocessor flags can remove most scheme features if you just want to read s-expressions @@ -28,25 +29,23 @@ I created this while reading [SICP](https://github.com/justinmeiners/sicp-excerc ### Features - C99 no dependencies. Single header. -- Core scheme language: if, let, do, lambda, cons, car, eval, symbols, etc. -- Data structures: lists, vectors, hash tables, integers, real numbers, characters, strings, and integers. -- Standard library: subset of [MIT Scheme](https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_toc.html) - with Common Lisp features (like `push`) mixed in. +- Core lisp language `if`, `let`, `do`, `lambda`, `cons`, `eval`, etc. +- Subset of scheme R5RS library: lists, vectors, hash tables, integers, real numbers, characters, strings, and integers. +- Common lisp goodies: unhygenic macros (`define-macro`), `push`, `dotimes`. +- Easy to integrate C functions. - Exact [garbage collection](#garbage-collection) with explicit invocation. -- Common lisp style unhygenic macros: `define-macro`. -- Easy integration of C functions. - REPL command line tool. - Efficient parsing and manipulation of large data files. ### Non-Features -- compiler -- full numeric tower: complex and rational numbers. -- full call/cc (simple stack jump supported) -- full port IO -- unix system library +- Compiler +- Full numeric tower: complex and rational numbers. +- Full call/cc. This only supports simple stack jumps. +- syntax rules. +- extensive IO or UNIX system libraries. -## Examples +### Examples ### Interactive programming with Read, eval, print loop. ```bash @@ -146,7 +145,7 @@ lisp_env_define(env, lisp_make_symbol("INTEGER-RANGE", ctx), func, ctx); In Lisp ```scheme -(INTEGER-RANGE 5 15) +(integer-range 5 15) ; => #(5 6 7 8 9 10 11 12 13 14) ``` Constants can also be stored in the environment in a similar fashion. @@ -155,14 +154,14 @@ Constants can also be stored in the environment in a similar fashion. Lisp pi = lisp_make_real(3.141592); lisp_env_define(env, lisp_make_symbol("PI", ctx), pi, ctx); ``` -## Macros +### Macros Common Lisp style (`defmacro`) is available with the name `define-macro`. (define-macro nil! (lambda (x) `(set! ,x '())) -## Garbage Collection +### Garbage Collection Garbage is only collected if it is explicitly told to. You can invoke the garbage collector in C: @@ -174,15 +173,22 @@ OR in lisp code: (gc-flip) Note that whenever a collect is issued -ANY `Lisp` value which is not accessible +ANY `Lisp` value in `C`which is not accessible through the global environment may become invalid. Be careful what variables you hold onto in C. -Don't call `eval` in a custom defined C function unless -you know what you are doing. +Don't call `eval` in a custom defined C function unless you know what you are doing. See [internals](INTERNALS.md) for more details. +## Documentation + +For the language refer to [MIT Scheme](https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_toc.html) +with the understanding that not everything is missing. +If we do implement a feature that MIT scheme has, we will try to follow their specificaiton. + +For the C API refer to the header and sample programs (`repl.c`, `printer.c`). + ## Project License Copyright (c) 2020 Justin Meiners