From 3864d434fcb39a1f39cea2fb25f4f81a46ef6d8e Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 25 Jul 2016 14:39:56 +0200 Subject: [PATCH] split-up test suite, implement quasiquote in scheme. --- GNUmakefile | 33 ++++++-- TODO | 3 + base.mes | 79 ++++++++++++++++++ base0.mes | 22 +++++ let.mes | 100 +++++++++++++++++++++++ lib/srfi/srfi-0.scm | 5 +- lib/test.mes | 71 ++++++++++++++++ mes.c | 49 +++-------- quasiquote.mes | 85 +++++++++++++++++++ scm.mes | 114 ++++---------------------- test/base.test | 39 +++++++++ test/closure.test | 46 +++++++++++ test/foo.test | 6 ++ test/let.test | 52 ++++++++++++ test/quasiquote.test | 38 +++++++++ test.mes => test/scm.test | 167 ++++++-------------------------------- 16 files changed, 618 insertions(+), 291 deletions(-) create mode 100644 base.mes create mode 100644 base0.mes create mode 100644 let.mes create mode 100644 lib/test.mes create mode 100644 quasiquote.mes create mode 100644 test/base.test create mode 100644 test/closure.test create mode 100644 test/foo.test create mode 100644 test/let.test create mode 100644 test/quasiquote.test rename test.mes => test/scm.test (62%) diff --git a/GNUmakefile b/GNUmakefile index e7e1ca67..52eae275 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -31,21 +31,36 @@ mes.h: mes.c GNUmakefile done; echo '#endif'; echo '#endif' 1>&2) > $@ 2>environment.i check: all guile-check - ./mes.test - ./mes.test ./mes - cat scm.mes lib/srfi/srfi-0.scm test.mes | ./mes +# ./mes.test +# ./mes.test ./mes + cat base0.mes base.mes lib/test.mes test/base.test | ./mes + cat base0.mes base.mes lib/test.mes test/closure.test | ./mes + cat base0.mes base.mes quasiquote.mes lib/test.mes test/quasiquote.test | ./mes + cat base0.mes base.mes quasiquote.mes let.mes lib/test.mes test/let.test | ./mes + cat base0.mes base.mes quasiquote.mes let.mes lib/srfi/srfi-0.scm scm.mes lib/test.mes test/scm.test | ./mes guile-check: - guile -s test.mes + guile -s <(cat base.mes lib/test.mes test/base.test) + guile -s <(cat base.mes lib/test.mes test/closure.test) + guile -s <(cat base.mes lib/test.mes test/quasiquote.test) + guile -s <(cat quasiquote.mes lib/test.mes test/quasiquote.test) +# guile -s <(cat base.mes let.mes test/foo.test) +# exit 1 + guile -s <(cat lib/test.mes test/base.test) + guile -s <(cat lib/test.mes test/quasiquote.test) + guile -s <(cat lib/test.mes test/let.test) + guile -s <(cat quasiquote.mes lib/test.mes test/base.test) + guile -s <(cat quasiquote.mes lib/test.mes test/quasiquote.test) + guile -s <(cat lib/test.mes test/scm.test) run: all cat scm.mes test.mes | ./mes psyntax: all - cat scm.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes + cat base0.mes base.mes quasiquote.mes let.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes syntax: all - cat scm.mes syntax.mes syntax-test.mes | ./mes + cat base0.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes syntax-test.mes | ./mes syntax.test: syntax.mes syntax-test.mes cat $^ > $@ @@ -63,7 +78,7 @@ guile-syntax-case: syntax-case.test guile -s $^ macro: all - cat scm.mes macro.mes | ./mes + cat base0.mes base.mes quasiquote.mes let.mes scm.mes macro.mes | ./mes peg: all cat scm.mes syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes | ./mes @@ -84,7 +99,7 @@ record: all paren: all - echo -e 'EOF\n___P((()))' | cat scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm paren.scm - | ./mes + echo -e 'EOF\n___P((()))' | cat base0.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm paren.scm - | ./mes paren.test: lib/lalr.scm paren.scm cat $^ > $@ @@ -93,7 +108,7 @@ guile-paren: paren.test echo '___P((()))' | guile -s $^ mescc: all - echo ' EOF ' | cat scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm c-lexer.scm mescc.scm - main.c | ./mes + echo ' EOF ' | cat base0.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm c-lexer.scm mescc.scm - main.c | ./mes mescc.test: lib/lalr.scm c-lexer.scm mescc.scm cat $^ > $@ diff --git a/TODO b/TODO index 0be14df0..ddf83804 100644 --- a/TODO +++ b/TODO @@ -4,6 +4,9 @@ Using define-macro-based version. ** psyntax.pp Find out how to hook-up sc-expand in eval/apply. +** make core smaller +*** replase mes.c:quasiquote by qq.mes +*** cleanup environment/closures ** bugs See bugs/ ** run PEG diff --git a/base.mes b/base.mes new file mode 100644 index 00000000..15640333 --- /dev/null +++ b/base.mes @@ -0,0 +1,79 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; base.mes: This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(define (not x) + (cond (x #f) + (#t #t))) + +(define guile? (not (pair? (current-module)))) + +(define-macro (or2 x y) + `(cond (,x ,x) (#t ,y))) + +(define-macro (and2 x y) + `(cond (,x ,y) (#t #f))) + +(define-macro (and . x) + (cond ((null? x) #t) + ((null? (cdr x)) (car x)) + (#t (list 'cond (list (car x) (cons 'and (cdr x))) + '(#t #f))))) + +(define-macro (or . x) + (cond + ((null? x) #f) + ((null? (cdr x)) (car x)) + (#t (list 'cond (list (car x)) + (list #t (cons 'or (cdr x))))))) + +(define (cons* x . rest) + (define (loop rest) + (cond ((null? (cdr rest)) (car rest)) + (#t (cons (car rest) (loop (cdr rest)))))) + (loop (cons x rest))) + +(define (equal? a b) ;; FIXME: only 2 arg + (cond ((and (null? a) (null? b)) #t) + ((and (pair? a) (pair? b)) + (and (equal? (car a) (car b)) + (equal? (cdr a) (cdr b)))) + ((and (string? a) (string? b)) + (eq? (string->symbol a) (string->symbol b))) + ((and (vector? a) (vector? b)) + (equal? (vector->list a) (vector->list b))) + (#t (eq? a b)))) + +(define (memq x lst) + (cond ((null? lst) #f) + ((eq? x (car lst)) lst) + (#t (memq x (cdr lst))))) + +(define (map f l . r) + (cond ((null? l) '()) + ((null? r) (cons (f (car l)) (map f (cdr l)))) + ((null? (cdr r)) + (cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))))) + +(define-macro (simple-let bindings . rest) + (cons (cons 'lambda (cons (map car bindings) rest)) + (map cadr bindings))) + +(define-macro (let bindings . rest) + (cons* 'simple-let bindings rest)) diff --git a/base0.mes b/base0.mes new file mode 100644 index 00000000..45f7877b --- /dev/null +++ b/base0.mes @@ -0,0 +1,22 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; base0.mes: This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(define-macro (defined? x) + `(assq ,x (cddr (current-module)))) diff --git a/let.mes b/let.mes new file mode 100644 index 00000000..c42062de --- /dev/null +++ b/let.mes @@ -0,0 +1,100 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; test.mes: This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(define-macro (simple-let bindings . rest) + `(,`(lambda ,(map car bindings) ,@rest) + ,@(map cadr bindings))) + +(define-macro (named-let label bindings . rest) + `(simple-let ((,label *unspecified*)) + (set! ,label (lambda ,(map car bindings) ,@rest)) + (,label ,@(map cadr bindings)))) + +(define-macro (combined-let bindings-or-label . rest) + (display + `(,`(cond + (,(symbol? bindings-or-label) + (lambda () ,(cons* 'named-let bindings-or-label `(car ,rest) `(cdr ,rest)))) + (#t + (lambda () ,(cons* 'simple-let bindings-or-label rest)) + )))) + (newline) + `(,`(cond + (,(symbol? bindings-or-label) + (lambda () ,(cons* 'named-let bindings-or-label `(car ,rest) `(cdr ,rest)))) + (#t + (lambda () ,(cons* 'simple-let bindings-or-label rest)) + )))) + + + + +(define (split-params bindings params) + (cond ((null? bindings) params) + (#t (split-params (cdr bindings) + (append params (cons (caar bindings) '())))))) + +(define (split-values bindings values) + (cond ((null? bindings) values) + (#t (split-values (cdr bindings) + (append values (cdar bindings) '()))))) + +(define-macro (xsimple-let bindings rest) + `((lambda ,(split-params bindings '()) ,@rest) + ,@(split-values bindings '()))) + +(define-macro (xnamed-let label bindings rest) + `((lambda (,label) + (set! ,label (lambda ,(split-params bindings '()) ,@rest)) + (,label ,@(split-values bindings '()))) + *unspecified*)) + +(define-macro (let bindings-or-label . rest) + `(cond (,(symbol? bindings-or-label) + (xnamed-let ,bindings-or-label ,(car rest) ,(cdr rest))) + (#t (xsimple-let ,bindings-or-label ,rest)))) + +(define (expand-let* bindings body) + (cond ((null? bindings) + `((lambda () ,@body))) + (#t `((lambda (,(caar bindings)) + ,(expand-let* (cdr bindings) body)) + ,@(cdar bindings))))) + +(define-macro (let* bindings . body) + (expand-let* bindings body)) + +(define (unspecified-bindings bindings params) + (cond ((null? bindings) params) + (#t (unspecified-bindings + (cdr bindings) + (append params (cons (cons (caar bindings) '(*unspecified*)) '())))))) + +(define (letrec-setters bindings setters) + (cond ((null? bindings) setters) + (#t (letrec-setters (cdr bindings) + (append setters + (cons (cons 'set! (car bindings)) '())))))) + +(define-macro (letrec bindings . body) + `(let ,(unspecified-bindings bindings '()) + ,@(letrec-setters bindings '()) + ,@body)) + diff --git a/lib/srfi/srfi-0.scm b/lib/srfi/srfi-0.scm index 8d279a0f..9ef41184 100644 --- a/lib/srfi/srfi-0.scm +++ b/lib/srfi/srfi-0.scm @@ -1,7 +1,10 @@ (define mes '(0 1)) +(define-macro (defined? x) + `(assq ,x (cddr (current-module)))) + (define (cond-expand-expander clauses) - (let loop ((clauses clauses)) + (named-let loop ((clauses clauses)) (if (defined? (caar clauses)) (eval (cons 'begin (cdar clauses)) (current-module)) (loop (cdr clauses))))) diff --git a/lib/test.mes b/lib/test.mes new file mode 100644 index 00000000..e39cf2db --- /dev/null +++ b/lib/test.mes @@ -0,0 +1,71 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; test.mes: This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(define guile? (not (pair? (current-module)))) + +(define result + (let ((pass 0) + (fail 0)) + (lambda (. t) + (cond ((or (null? t) (eq? (car t) result)) (list pass fail)) + ((eq? (car t) 'report) + (newline) + (display "passed: ") (display pass) (newline) + (display "failed: ") (display fail) (newline) + (display "total: ") (display (+ pass fail)) (newline) + (exit fail)) + ((car t) (display ": pass") (newline) (set! pass (+ pass 1))) + (#t (display ": fail") (newline) (set! fail (+ fail 1))))))) + +(define (seq? a b) + (or (eq? a b) + (begin + (display ": fail") + (newline) + (display "expected: ") + (display b) (newline) + (display "actual: ") + (display a) + (newline) + #f))) + +(define (sequal? a b) + (or (equal? a b) + (begin + (display ": fail") + (newline) + (display "expected: ") + (display b) (newline) + (display "actual: ") + (display a) + (newline) + #f))) + +(define-macro (pass-if name t) + (list + 'begin + (list display "test: ") (list display name) + (list result t))) + +(define-macro (pass-if-not name f) + (list + 'begin + (list display "test: ") (list display name) + (list result (list not f)))) diff --git a/mes.c b/mes.c index 5d635510..2cf75178 100644 --- a/mes.c +++ b/mes.c @@ -315,13 +315,6 @@ assq (scm *x, scm *a) scm * apply_env (scm *fn, scm *x, scm *a) { -#if DEBUG - printf ("\napply_env fn="); - display (fn); - printf (" x="); - display (x); - puts (""); -#endif scm *macro; if (atom_p (fn) != &scm_f) { @@ -362,16 +355,10 @@ apply (scm *f, scm *x) scm * eval (scm *e, scm *a) { -#if DEBUG - printf ("\neval e="); - display (e); - puts (""); -#endif scm *macro; if (e->type == SYMBOL) { scm *y = assq (e, a); if (y == &scm_f) { - //return e; fprintf (stderr, "eval: unbound variable: %s\n", e->name); assert (!"unbound variable"); } @@ -381,8 +368,6 @@ eval (scm *e, scm *a) return e; else if (atom_p (car (e)) == &scm_t) { - if ((macro = lookup_macro (car (e), a)) != &scm_f) - return eval (apply_env (macro, cdr (e), a), a); if (car (e) == &symbol_quote) return cadr (e); if (car (e) == &symbol_begin) @@ -399,10 +384,6 @@ eval (scm *e, scm *a) return make_closure (cadr (e), cddr (e), assq (&symbol_closure, a)); if (car (e) == &symbol_closure) return e; - if (car (e) == &symbol_unquote) - return eval (cadr (e), a); - if (car (e) == &symbol_quasiquote) - return eval_quasiquote (cadr (e), add_unquoters (a)); if (car (e) == &symbol_cond) return evcon (cdr (e), a); if (eq_p (car (e), &symbol_define) == &scm_t) @@ -411,9 +392,12 @@ eval (scm *e, scm *a) return define (e, a); if (car (e) == &symbol_set_x) return set_env_x (cadr (e), eval (caddr (e), a), a); - if ((macro = assq (&symbol_sc_expand, a)) != &scm_f) - if (cdr (macro) != &scm_f) - return eval (apply_env (cdr (macro), e, a), a); + if ((macro = lookup_macro (car (e), a)) != &scm_f) + return eval (apply_env (macro, cdr (e), a), a); + if (car (e) == &symbol_unquote) + return eval (cadr (e), a); + if (car (e) == &symbol_quasiquote) + return eval_quasiquote (cadr (e), add_unquoters (a)); } return apply_env (car (e), evlis (cdr (e), a), a); } @@ -774,15 +758,14 @@ lookup (char *x, scm *a) if (!strcmp (x, symbol_quasiquote.name)) return &symbol_quasiquote; if (!strcmp (x, symbol_quote.name)) return &symbol_quote; - if (!strcmp (x, symbol_set_x.name)) return &symbol_set_x; + if (!strcmp (x, symbol_unquote.name)) return &symbol_unquote; if (!strcmp (x, symbol_unquote_splicing.name)) return &symbol_unquote_splicing; - + if (!strcmp (x, symbol_quasisyntax.name)) return &symbol_quasisyntax; if (!strcmp (x, symbol_syntax.name)) return &symbol_syntax; + if (!strcmp (x, symbol_set_x.name)) return &symbol_set_x; - if (!strcmp (x, symbol_unsyntax.name)) return &symbol_unsyntax; - if (!strcmp (x, symbol_unsyntax_splicing.name)) return &symbol_unsyntax_splicing; if (*x == '\'') return &symbol_quote; if (*x == '`') return &symbol_quasiquote; @@ -937,18 +920,6 @@ display_helper (scm *x, bool cont, char *sep, bool quote) printf ("'"); return display_helper (car (cdr (x)), cont, "", true); } - if (car (x) == &scm_quasiquote) { - printf ("`"); - return display_helper (car (cdr (x)), cont, "", true); - } - if (car (x) == &scm_unquote) { - printf (","); - return display_helper (car (cdr (x)), cont, "", true); - } - if (car (x) == &scm_unquote_splicing) { - printf (",@"); - return display_helper (car (cdr (x)), cont, "", true); - } if (!cont) printf ("("); display (car (x)); if (cdr (x)->type == PAIR) @@ -1350,7 +1321,7 @@ define (scm *x, scm *a) set_cdr_x (cl, aa); return entry; } - + scm * lookup_macro (scm *x, scm *a) { diff --git a/quasiquote.mes b/quasiquote.mes new file mode 100644 index 00000000..57d24224 --- /dev/null +++ b/quasiquote.mes @@ -0,0 +1,85 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; quasiquote.mes: This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(define-macro (quasiquote x) + (define (check x) + (cond ((pair? (cdr x)) (cond ((null? (cddr x))) + (#t (error (car x) "invalid form ~s" x)))))) + (define (loop x) + ;;(display "LOOP") (newline) + (cond + ((not (pair? x)) (cons 'quote (cons x '()))) + ((eq? (car x) 'quasiquote) (check x) (loop (loop (cadr x)))) + ((eq? (car x) 'unquote) (check x) (cadr x)) + ((eq? (car x) 'unquote-splicing) + (error 'unquote-splicing "invalid context for ~s" x)) + (;;(and (pair? (car x)) (eq? (caar x) 'unquote-splicing)) + (cond ((pair? (car x)) (eq? (caar x) 'unquote-splicing)) + (#t #f)) + (check (car x)) + ;; (let ((d (loop (cdr x)))) + ;; (cond ((equal? d '(quote ())) (cadar x)) + ;; ;;(#t `(append ,(cadar x) ,d)) + ;; (#t (list 'append (cadar x) d)) + ;; )) + ((lambda (d) + (list 'append (cadar x) d)) + (loop (cdr x)))) + (#t + ;; (let ((a (loop (car x))) + ;; (d (loop (cdr x)))) + ;; (cond ((pair? d) + ;; (cond ((eq? (car d) 'quote) + ;; (cond ((and (pair? a) (eq? (car a) 'quote)) + ;; `'(,(cadr a) . ,(cadr d))) + ;; (#t (cond ((null? (cadr d)) + ;; `(list ,a)) + ;; (#t `(cons* ,a ,d)))))) + ;; (#t (cond ((memq (car d) '(list cons*)) + ;; `(,(car d) ,a ,@(cdr d))) + ;; (#t `(cons* ,a ,d)))))) + ;; (#t `(cons* ,a ,d)))) + + ((lambda (a d) + ;;(display "LAMBDA AD") (newline) + (cond ((pair? d) + (cond ((eq? (car d) 'quote) + (cond (;;(and (pair? a) (eq? (car a) 'quote)) + (cond ((pair? a) (eq? (car a) 'quote)) + (#t #f)) + (list 'quote (cons (cadr a) (cadr d)))) + (#t (cond ((null? (cadr d)) + (list 'list a)) + (#t (list 'cons* a d)))))) + (#t (cond ((memq (car d) '(list cons*)) + ;;`(,(car d) ,a ,@(cdr d)) + (cons (car d) (cons a (cdr d))) + ) + ;;(#t `(cons* ,a ,d)) + (#t (list 'cons* a d)) + )))) + ;;(#t `(cons* ,a ,d)) + (#t (list 'cons* a d)) + )) + (loop (car x)) + (loop (cdr x))) + + ))) + (loop x)) diff --git a/scm.mes b/scm.mes index bfcf1b08..3e22291d 100755 --- a/scm.mes +++ b/scm.mes @@ -18,56 +18,13 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -;; The Maxwell Equations of Software -- John McCarthy page 13 -;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf +(define (list . rest) rest) (define-macro (if expr then . else) `(cond (,expr ,then) (#t (cond (,(pair? else) ((lambda () ,@else))))))) -(define-macro (when expr . body) - `(if ,expr - ((lambda () ,@body)))) - -(define (list . rest) rest) - -(define (split-params bindings params) - (cond ((null? bindings) params) - (#t (split-params (cdr bindings) - (append params (cons (caar bindings) '())))))) - -(define (split-values bindings values) - (cond ((null? bindings) values) - (#t (split-values (cdr bindings) - (append values (cdar bindings) '()))))) - -(define-macro (simple-let bindings rest) - `((lambda ,(split-params bindings '()) ,@rest) - ,@(split-values bindings '()))) - -(define-macro (let-loop label bindings . rest) - `(let ((,label *unspecified*)) - (let ((,label (lambda ,(split-params bindings '()) ,@rest))) - (,label ,@(split-values bindings '()))))) - -(define-macro (let-loop label bindings rest) - `((lambda (,label) - (set! ,label (lambda ,(split-params bindings '()) ,@rest)) - (,label ,@(split-values bindings '()))) - *unspecified*)) - -(define-macro (let bindings-or-label . rest) - `(cond (,(symbol? bindings-or-label) - (let-loop ,bindings-or-label ,(car rest) ,(cdr rest))) - (#t (simple-let ,bindings-or-label ,rest)))) - -(define-macro (do init test . body) - `(let loop ((,(caar init) ,(cadar init))) - (when (not ,@test) - ,@body - (loop ,@(cddar init))))) - (define-macro (case val . args) (if (null? args) #f @@ -80,36 +37,25 @@ `(member ,val ',pred)) (begin ,@body) (case ,val ,@(cdr args))) - `(begin ,@body))))) ; else clause + `(begin ,@body))))) -(define-macro (or2 x y) - `(cond (,x ,x) (#t ,y))) +(define-macro (when expr . body) + `(if ,expr + ((lambda () ,@body)))) -(define-macro (and2 x y) - `(cond (,x ,y) (#t #f))) +(define-macro (do init test . body) + `(let loop ((,(caar init) ,(cadar init))) + (when (not ,@test) + ,@body + (loop ,@(cddar init))))) -(define-macro (or . x) - (cond - ((null? x) #f) - ((null? (cdr x)) (car x)) - (#t `(cond (,(car x)) - (#t (or ,@(cdr x))))))) +(define (procedure? p) + (cond ((builtin? p) #t) + ((and (pair? p) (eq? (car p) 'lambda))) + ((and (pair? p) (eq? (car p) '*closure*))) + (#t #f))) -(define-macro (and . x) - (cond ((null? x) #t) - ((null? (cdr x)) (car x)) - (#t `(cond (,(car x) (and ,@(cdr x))) - (#t #f))))) - -(define (expand-let* bindings body) - (cond ((null? bindings) - `((lambda () ,@body))) - (#t `((lambda (,(caar bindings)) - ,(expand-let* (cdr bindings) body)) - ,@(cdar bindings))))) - -(define-macro (let* bindings . body) - (expand-let* bindings body)) +(define integer? number?) (define (equal? a b) ;; FIXME: only 2 arg (cond ((and (null? a) (null? b)) #t) @@ -129,17 +75,6 @@ (if (= 0 n) '() (cons fill (loop (- n 1)))))))) -(define-macro (defined? x) - `(assq ,x (cddr (current-module)))) - -(define (procedure? p) - (cond ((builtin? p) #t) - ((and (pair? p) (eq? (car p) 'lambda))) - ((and (pair? p) (eq? (car p) '*closure*))) - (#t #f))) - -(define integer? number?) - (define (assq-set! alist key val) (let ((entry (assq key alist))) (cond (entry (set-cdr! entry val) @@ -226,23 +161,6 @@ (or (null? x) (and (pair? x) (list? (cdr x))))) -(define (unspecified-bindings bindings params) - (cond ((null? bindings) params) - (#t (unspecified-bindings - (cdr bindings) - (append params (cons (cons (caar bindings) '(*unspecified*)) '())))))) - -(define (letrec-setters bindings setters) - (cond ((null? bindings) setters) - (#t (letrec-setters (cdr bindings) - (append setters - (cons (cons 'set! (car bindings)) '())))))) - -(define-macro (letrec bindings . body) - `(let ,(unspecified-bindings bindings '()) - ,@(letrec-setters bindings '()) - ,@body)) - (define gensym (let ((counter 0)) (lambda (. rest) diff --git a/test/base.test b/test/base.test new file mode 100644 index 00000000..c6dabfda --- /dev/null +++ b/test/base.test @@ -0,0 +1,39 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; base.test: This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(pass-if "first dummy" #t) +(pass-if-not "second dummy" #f) + + +(pass-if "begin" (seq? (begin 'a 'b (+ 1 2)) 3)) + +(begin (define *top-begin-a* '*top-begin-a*)) +(pass-if "top begin " (seq? *top-begin-a* '*top-begin-a*)) + +(pass-if "and" (seq? (and 1) 1)) +(pass-if "and 2" (seq? (and 1 (= 0 1) #f) #f)) +(pass-if "or" (seq? (or) #f)) +(pass-if "or 2" (seq? (or 1) 1)) +(pass-if "or 3" (seq? (or #f (= 0 1) 3) 3)) +(pass-if "let" (seq? (let () 0) 0)) +(pass-if "let 2" (seq? (let ((x 0)) x) 0)) +(pass-if "let 3" (seq? (let ((p 5) (q 6)) (+ p q)) 11)) + +(result 'report) diff --git a/test/closure.test b/test/closure.test new file mode 100644 index 00000000..66411b67 --- /dev/null +++ b/test/closure.test @@ -0,0 +1,46 @@ +(define b 0) +(define x (lambda () b)) +(define (x) b) +(pass-if "closure" (seq? (x) 0)) +(define (c b) + (x)) +(pass-if "closure 2" (seq? (c 1) 0)) + +(define (x) + (define b 1) + (define (y) b) + (set! b 0) + (list b + (let ((b 2)) + (y)))) + +(pass-if "closure 3" (sequal? (x) '(0 0))) + +(pass-if "closure 4 " + (seq? (let () + (let ((count (let ((counter 0)) + (lambda () + counter)))) + (count))) + 0)) + +(pass-if "closure 5 " + (seq? + (let () + (define name? 2) + (define (foo) + (define name? 0) + (lambda () name?)) + ((foo))) + 0)) + +(pass-if "closure 6 " + (seq? + (let () + (define foo + (lambda () + (define name? symbol?) + (lambda () + (name? 'boo)))) + ((foo))) + #t)) diff --git a/test/foo.test b/test/foo.test new file mode 100644 index 00000000..d947876c --- /dev/null +++ b/test/foo.test @@ -0,0 +1,6 @@ +(display (let () 0)) +(newline) +(display (let ((x 0)) x)) +(newline) +(display (let loop ((x 0)) 0)) +(newline) diff --git a/test/let.test b/test/let.test new file mode 100644 index 00000000..ba0edb31 --- /dev/null +++ b/test/let.test @@ -0,0 +1,52 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; let.test: This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(pass-if "first dummy" #t) +(pass-if-not "second dummy" #f) + +(let () (define *top-let-a* '*top-let-a*) #f) +(pass-if "top let " (seq? (and (defined? '*top-let-a*) *top-let-a*) #f)) + +(pass-if "let loop" + (sequal? + (let loop ((lst '(3 2 1))) + (cond ((null? lst) '()) + (#t (cons (car lst) (loop (cdr lst)))))) + '(3 2 1))) + +(pass-if "let* comments" + (seq? (let* ((aa 2) + (bb (+ aa 3)) + #! boo !# + ;;(bb 4) + ) + bb) + 5)) + +(pass-if "letrec" + (seq? + (letrec ((factorial (lambda (n) + (cond ((= n 1) 1) + (#t (* n (factorial (- n 1)))))))) + (factorial 4)) + 24)) + +(result 'report) + diff --git a/test/quasiquote.test b/test/quasiquote.test new file mode 100644 index 00000000..39912ac5 --- /dev/null +++ b/test/quasiquote.test @@ -0,0 +1,38 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; quasiquote.test: This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +(pass-if "first dummy" #t) +(pass-if-not "second dummy" #f) + +(pass-if "quasiquote" `#t) +(pass-if-not "quasiquote 2" `#f) +(pass-if "quasiquote 3" (seq? `1 1)) +(pass-if "quasiquote 4" (sequal? '`0 '(quasiquote 0))) +(pass-if "unquote" (let ((x 0)) (sequal? `,x 0))) +(pass-if "unquote 1" (let ((b 1)) (sequal? `(a ,b c) '(a 1 c)))) +(pass-if "unquote 2" (sequal? `,(list 1 2 3 4) '(1 2 3 4))) +(pass-if "unquote 3" (sequal? `(1 2 '(,(+ 1 2))) '(1 2 '(3)))) + +(pass-if "unquote-splicing" (let ((b 1) (c '(2 3))) (sequal? `(a ,b ,@c) '(a 1 2 3)))) +(pass-if "unquote-splicing 2" (sequal? `('boo ,@'(bah baz) 1 2) '((quote boo) bah baz 1 2))) +(pass-if "unquote-splicing 3" (sequal? `(1 ,@(list 2 3) 4) '(1 2 3 4))) +(pass-if "unquote-splicing 4" (sequal? (let ((s-r '(2 3))) `(1 ,@s-r 4)) '(1 2 3 4))) + +(result 'report) diff --git a/test.mes b/test/scm.test similarity index 62% rename from test.mes rename to test/scm.test index 02ff08f8..b44374b8 100644 --- a/test.mes +++ b/test/scm.test @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; test.mes: This file is part of Mes. +;;; scm.test: This file is part of Mes. ;;; ;;; Mes is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by @@ -18,79 +18,20 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -;; The Maxwell Equations of Software -- John McCarthy page 13 -;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf - -(define result - (let ((pass 0) - (fail 0)) - (lambda (. t) - (cond ((null? t) (list pass fail)) - ((car t) (display ": pass") (newline) (set! pass (+ pass 1))) - (#t (display ": fail") (newline) (set! fail (+ fail 1))))))) - - -(define guile? (defined? 'gc)) (when guile? (module-define! (current-module) 'builtin? (lambda (. x) #t)) - (use-modules (srfi srfi-1))) - -(define (seq? a b) - (or (eq? a b) - (begin - (display ": fail") - (newline) - (display "expected: ") - (display b) (newline) - (display "actual: ") - (display a) - (newline) - #f))) - -(define (sequal? a b) - (or (equal? a b) - (begin - (display ": fail") - (newline) - (display "expected: ") - (display b) (newline) - (display "actual: ") - (display a) - (newline) - #f))) - - -(define-macro (pass-if name t) - `(let () - (display "test: ") (display ,name) - (result ,t))) - -(define-macro (pass-if-not name f) - `(let () - (display "test: ") (display ,name) - (result (not ,f)))) + (use-modules (srfi srfi-1)) + ) (pass-if "first dummy" #t) (pass-if-not "second dummy" #f) -(pass-if "and" (seq? (and 1) 1)) -(pass-if "and 2" (seq? (and 1 (= 0 1) #f) #f)) -(pass-if "or" (seq? (or) #f)) -(pass-if "or 2" (seq? (or 1) 1)) -(pass-if "or 3" (seq? (or #f (= 0 1) 3) 3)) -(pass-if "let" (seq? (let ((p 5) (q 6)) (+ p q)) 11)) -(pass-if "let loop" (sequal? (let loop ((lst '(3 2 1))) - (if (null? lst) '() - (cons (car lst) - (loop (cdr lst))))) '(3 2 1))) -(pass-if "quasiquote" (let ((cc 'bb)) (sequal? `(aa bb ,cc) '(aa bb bb)))) -(pass-if "let* comments" (seq? (let* ((aa 2) - (bb (+ aa 3)) - #! boo !# - ;;(bb 4) - ) - bb) - 5)) +(pass-if "if" (seq? (if #t 'true) 'true)) +(pass-if "if 2" (seq? (if (seq? 0 '0) 'true 'false) 'true)) +(pass-if "if 3" (seq? (if (= 1 2) 'true 'false) 'false)) + +(pass-if "when" (seq? (when #t 'true) 'true)) +(pass-if "when 2" (seq? (when #f 'true) *unspecified*)) (pass-if "map" (sequal? (map identity '(1 2 3 4)) '(1 2 3 4))) (pass-if "map 2 " (sequal? (map (lambda (i a) (cons i a)) '(1 2 3 4) '(a b c d)) @@ -99,6 +40,17 @@ (define xxxa 0) (pass-if "set! " (seq? (begin (set! xxxa 1) xxxa) 1)) (pass-if "set! 2" (seq? (let ((a 0)) (set! a 1) a) 1)) + + +(pass-if "list-ref" (seq? (list-ref '(0 1 2) 1) 1)) + +(pass-if "do" (sequal? (let ((acc '())) (do ((i 0 (+ i 1))) ((>= i 3)) (set! acc (cons i acc))) acc) '(2 1 0))) + + + + + + (pass-if "+" (seq? (+ 1 2 3) 6)) (pass-if "*" (seq? (* 3 3 3) 27)) (pass-if "/" (seq? (/ 9 3) 3)) @@ -109,15 +61,7 @@ (pass-if "=" (seq? 3 '3)) (pass-if "= 2" (not (= 3 '4))) -(pass-if "if" (seq? (if #t 'true) 'true)) -(pass-if "if 2" (seq? (if (seq? 0 '0) 'true 'false) 'true)) -(pass-if "if 3" (seq? (if (= 1 2) 'true 'false) 'false)) -(pass-if "letrec" (seq? (letrec ((factorial (lambda (n) - (if (= n 1) 1 - (* n (factorial (- n 1))))))) - (factorial 4)) - 24)) -(pass-if "begin" (seq? (begin 'a 'b (+ 1 2)) 3)) + (pass-if "string-append" (sequal? (string-append "a" "b" "c") "abc")) (pass-if "substring" (sequal? (substring "hello world" 6) "world")) (pass-if "substring 2" (sequal? (substring "hello world" 4 7) "o w")) @@ -139,9 +83,8 @@ (pass-if "make-vector" (sequal? (make-vector 3) #(*unspecified* *unspecified* *unspecified*)))) (pass-if "make-vector 2" (sequal? (make-vector 3 0) #(0 0 0))) (pass-if "vector-ref" (seq? (vector-ref #(0 1) 1) 1)) -(when (not guile?) ;; hmm guile segfaults - (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 "equal?" (sequal? #(1) #(1))) (pass-if "equal?" (not (equal? #() #(1)))) (pass-if "memq" (sequal? (memq 'a '(a b c)) '(a b c))) @@ -181,60 +124,6 @@ (pass-if "gensym" (seq? (gensym) 'g0)) (pass-if "gensym" (seq? (gensym) 'g1)) (pass-if "gensym" (seq? (gensym) 'g2))) -(pass-if "unquote" (sequal? `,(list 1 2 3 4) '(1 2 3 4))) -(pass-if "splice" (sequal? `('boo ,@'(bah baz) 1 2) '((quote boo) bah baz 1 2))) -(pass-if "splice" (sequal? `(1 ,@(list 2 3) 4) '(1 2 3 4))) -(pass-if "splice" (sequal? (let ((s-r '(2 3))) `(1 ,@s-r 4)) '(1 2 3 4))) -(pass-if "unquote" (sequal? `(1 2 '(,(+ 1 2))) '(1 2 '(3)))) -(pass-if "when" (seq? (when #t 'true) 'true)) -(pass-if "when 2" (seq? (when #f 'true) *unspecified*)) - -(define b 0) -(define x (lambda () b)) -(define (x) b) -(pass-if "closure" (seq? (x) 0)) -(define (c b) - (x)) -(pass-if "closure 2" (seq? (c 1) 0)) - -(define (x) - (define b 1) - (define (y) b) - (set! b 0) - (list b - (let ((b 2)) - (y)))) - -(pass-if "closure 3" (sequal? (x) '(0 0))) - -(pass-if "closure 4 " - (seq? (let () - (let ((count (let ((counter 0)) - (lambda () - counter)))) - (count))) - 0)) - -(pass-if "closure 5 " - (seq? - (let () - (define name? 2) - (define (foo) - (define name? 0) - (lambda () name?)) - ((foo))) - 0)) - -(pass-if "closure 6 " - (seq? - (let () - (define foo - (lambda () - (define name? symbol?) - (lambda () - (name? 'boo)))) - ((foo))) - #t)) (pass-if "last-pair " (sequal? (last-pair '(1 2 3 4)) '(4))) (pass-if "last-pair 2" (seq? (last-pair '()) '())) @@ -249,12 +138,6 @@ (pass-if "cond-expand" (sequal? (cond-expand (foobar #f) (mes (display ": pass: *YAY*") 'mes) (guile (display ": pass: *GUILE*") 'mes)) 'mes)) -(begin (define *top-begin-a* '*top-begin-a*)) -(pass-if "top begin " (seq? (and (defined? '*top-begin-a*) *top-begin-a*) '*top-begin-a*)) - -(let () (define *top-let-a* '*top-let-a*) #f) -(pass-if "top let " (seq? (and (defined? '*top-let-a*) *top-let-a*) #f)) - (pass-if "apply identity" (seq? (apply identity '(0)) 0)) (pass-if "apply identity 2" (sequal? (apply identity '((0 1))) '(0 1))) (pass-if "apply append" (sequal? (apply append '((1 2) (3 4))) '(1 2 3 4))) @@ -293,10 +176,6 @@ (pass-if "min 1" (seq? (min 0 1) 0)) (pass-if "min 2" (seq? (min 1 0 2) 0)) -(pass-if "list-ref" (seq? (list-ref '(0 1 2) 1) 1)) - -(pass-if "do" (sequal? (let ((acc '())) (do ((i 0 (+ i 1))) ((>= i 3)) (set! acc (cons i acc))) acc) '(2 1 0))) - (pass-if "char-alphabetic?" (seq? (char-alphabetic? #\a) #t)) (pass-if "char-alphabetic? 2" (seq? (char-alphabetic? #\[) #f))