artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

split-up test suite, implement quasiquote in scheme.

Browse source
This commit is contained in:
Jan Nieuwenhuizen 2016-07-25 14:39:56 +02:00
parent 384a88dd53
commit 3864d434fc
16 changed files with 618 additions and 291 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

33
GNUmakefile
View file

@ -31,21 +31,36 @@ mes.h: mes.c GNUmakefile
done; echo '#endif'; echo '#endif' 1>&2) > $@ 2>environment.i done; echo '#endif'; echo '#endif' 1>&2) > $@ 2>environment.i
check: all guile-check check: all guile-check
./mes.test # ./mes.test
./mes.test ./mes # ./mes.test ./mes
cat scm.mes lib/srfi/srfi-0.scm test.mes | ./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-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 run: all
cat scm.mes test.mes | ./mes cat scm.mes test.mes | ./mes
psyntax: all 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 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 syntax.test: syntax.mes syntax-test.mes
cat $^ > $@ cat $^ > $@
@ -63,7 +78,7 @@ guile-syntax-case: syntax-case.test
guile -s $^ guile -s $^
macro: all macro: all
cat scm.mes macro.mes | ./mes cat base0.mes base.mes quasiquote.mes let.mes scm.mes macro.mes | ./mes
peg: all 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 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 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 paren.test: lib/lalr.scm paren.scm
cat $^ > $@ cat $^ > $@
@ -93,7 +108,7 @@ guile-paren: paren.test
echo '___P((()))' | guile -s $^ echo '___P((()))' | guile -s $^
mescc: all 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 mescc.test: lib/lalr.scm c-lexer.scm mescc.scm
cat $^ > $@ cat $^ > $@

3
TODO
View file

@ -4,6 +4,9 @@
Using define-macro-based version. Using define-macro-based version.
** psyntax.pp ** psyntax.pp
Find out how to hook-up sc-expand in eval/apply. 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 ** bugs
See bugs/ See bugs/
** run PEG ** run PEG

79
base.mes Normal file
View file

@ -0,0 +1,79 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
(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))

22
base0.mes Normal file
View file

@ -0,0 +1,22 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
(define-macro (defined? x)
`(assq ,x (cddr (current-module))))

100
let.mes Normal file
View file

@ -0,0 +1,100 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
(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))

5
lib/srfi/srfi-0.scm
View file

@ -1,7 +1,10 @@
(define mes '(0 1)) (define mes '(0 1))
(define-macro (defined? x)
`(assq ,x (cddr (current-module))))
(define (cond-expand-expander clauses) (define (cond-expand-expander clauses)
(let loop ((clauses clauses)) (named-let loop ((clauses clauses))
(if (defined? (caar clauses)) (if (defined? (caar clauses))
(eval (cons 'begin (cdar clauses)) (current-module)) (eval (cons 'begin (cdar clauses)) (current-module))
(loop (cdr clauses))))) (loop (cdr clauses)))))

71
lib/test.mes Normal file
View file

@ -0,0 +1,71 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
(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))))

45
mes.c
View file

@ -315,13 +315,6 @@ assq (scm *x, scm *a)
scm * scm *
apply_env (scm *fn, scm *x, scm *a) apply_env (scm *fn, scm *x, scm *a)
{ {
#if DEBUG
printf ("\napply_env fn=");
display (fn);
printf (" x=");
display (x);
puts ("");
#endif
scm *macro; scm *macro;
if (atom_p (fn) != &scm_f) if (atom_p (fn) != &scm_f)
{ {
@ -362,16 +355,10 @@ apply (scm *f, scm *x)
scm * scm *
eval (scm *e, scm *a) eval (scm *e, scm *a)
{ {
#if DEBUG
printf ("\neval e=");
display (e);
puts ("");
#endif
scm *macro; scm *macro;
if (e->type == SYMBOL) { if (e->type == SYMBOL) {
scm *y = assq (e, a); scm *y = assq (e, a);
if (y == &scm_f) { if (y == &scm_f) {
//return e;
fprintf (stderr, "eval: unbound variable: %s\n", e->name); fprintf (stderr, "eval: unbound variable: %s\n", e->name);
assert (!"unbound variable"); assert (!"unbound variable");
} }
@ -381,8 +368,6 @@ eval (scm *e, scm *a)
return e; return e;
else if (atom_p (car (e)) == &scm_t) 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) if (car (e) == &symbol_quote)
return cadr (e); return cadr (e);
if (car (e) == &symbol_begin) 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)); return make_closure (cadr (e), cddr (e), assq (&symbol_closure, a));
if (car (e) == &symbol_closure) if (car (e) == &symbol_closure)
return e; 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) if (car (e) == &symbol_cond)
return evcon (cdr (e), a); return evcon (cdr (e), a);
if (eq_p (car (e), &symbol_define) == &scm_t) if (eq_p (car (e), &symbol_define) == &scm_t)
@ -411,9 +392,12 @@ eval (scm *e, scm *a)
return define (e, a); return define (e, a);
if (car (e) == &symbol_set_x) if (car (e) == &symbol_set_x)
return set_env_x (cadr (e), eval (caddr (e), a), a); return set_env_x (cadr (e), eval (caddr (e), a), a);
if ((macro = assq (&symbol_sc_expand, a)) != &scm_f) if ((macro = lookup_macro (car (e), a)) != &scm_f)
if (cdr (macro) != &scm_f) return eval (apply_env (macro, cdr (e), a), a);
return eval (apply_env (cdr (macro), 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); 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_quasiquote.name)) return &symbol_quasiquote;
if (!strcmp (x, symbol_quote.name)) return &symbol_quote; 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.name)) return &symbol_unquote;
if (!strcmp (x, symbol_unquote_splicing.name)) return &symbol_unquote_splicing; if (!strcmp (x, symbol_unquote_splicing.name)) return &symbol_unquote_splicing;
if (!strcmp (x, symbol_quasisyntax.name)) return &symbol_quasisyntax; if (!strcmp (x, symbol_quasisyntax.name)) return &symbol_quasisyntax;
if (!strcmp (x, symbol_syntax.name)) return &symbol_syntax; if (!strcmp (x, symbol_syntax.name)) return &symbol_syntax;
if (!strcmp (x, symbol_set_x.name)) return &symbol_set_x; 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_quote;
if (*x == '`') return &symbol_quasiquote; if (*x == '`') return &symbol_quasiquote;
@ -937,18 +920,6 @@ display_helper (scm *x, bool cont, char *sep, bool quote)
printf ("'"); printf ("'");
return display_helper (car (cdr (x)), cont, "", true); 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 ("("); if (!cont) printf ("(");
display (car (x)); display (car (x));
if (cdr (x)->type == PAIR) if (cdr (x)->type == PAIR)

85
quasiquote.mes Normal file
View file

@ -0,0 +1,85 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
(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))

114
scm.mes
View file

@ -18,56 +18,13 @@
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>. ;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;; The Maxwell Equations of Software -- John McCarthy page 13 (define (list . rest) rest)
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
(define-macro (if expr then . else) (define-macro (if expr then . else)
`(cond `(cond
(,expr ,then) (,expr ,then)
(#t (cond (,(pair? else) ((lambda () ,@else))))))) (#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) (define-macro (case val . args)
(if (null? args) (if (null? args)
#f #f
@ -80,36 +37,25 @@
`(member ,val ',pred)) `(member ,val ',pred))
(begin ,@body) (begin ,@body)
(case ,val ,@(cdr args))) (case ,val ,@(cdr args)))
`(begin ,@body))))) ; else clause `(begin ,@body)))))
(define-macro (or2 x y) (define-macro (when expr . body)
`(cond (,x ,x) (#t ,y))) `(if ,expr
((lambda () ,@body))))
(define-macro (and2 x y) (define-macro (do init test . body)
`(cond (,x ,y) (#t #f))) `(let loop ((,(caar init) ,(cadar init)))
(when (not ,@test)
,@body
(loop ,@(cddar init)))))
(define-macro (or . x) (define (procedure? p)
(cond (cond ((builtin? p) #t)
((null? x) #f) ((and (pair? p) (eq? (car p) 'lambda)))
((null? (cdr x)) (car x)) ((and (pair? p) (eq? (car p) '*closure*)))
(#t `(cond (,(car x)) (#t #f)))
(#t (or ,@(cdr x)))))))
(define-macro (and . x) (define integer? number?)
(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 (equal? a b) ;; FIXME: only 2 arg (define (equal? a b) ;; FIXME: only 2 arg
(cond ((and (null? a) (null? b)) #t) (cond ((and (null? a) (null? b)) #t)
@ -129,17 +75,6 @@
(if (= 0 n) '() (if (= 0 n) '()
(cons fill (loop (- n 1)))))))) (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) (define (assq-set! alist key val)
(let ((entry (assq key alist))) (let ((entry (assq key alist)))
(cond (entry (set-cdr! entry val) (cond (entry (set-cdr! entry val)
@ -226,23 +161,6 @@
(or (null? x) (or (null? x)
(and (pair? x) (list? (cdr 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 (define gensym
(let ((counter 0)) (let ((counter 0))
(lambda (. rest) (lambda (. rest)

39
test/base.test Normal file
View file

@ -0,0 +1,39 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
(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)

46
test/closure.test Normal file
View file

@ -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))

6
test/foo.test Normal file
View file

@ -0,0 +1,6 @@
(display (let () 0))
(newline)
(display (let ((x 0)) x))
(newline)
(display (let loop ((x 0)) 0))
(newline)

52
test/let.test Normal file
View file

@ -0,0 +1,52 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
(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)

38
test/quasiquote.test Normal file
View file

@ -0,0 +1,38 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
(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)

167
test.mes → test/scm.test
View file

@ -3,7 +3,7 @@
;;; Mes --- Maxwell Equations of Software ;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
;;; 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 ;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by ;;; 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 ;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>. ;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;; 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? (when guile?
(module-define! (current-module) 'builtin? (lambda (. x) #t)) (module-define! (current-module) 'builtin? (lambda (. x) #t))
(use-modules (srfi srfi-1))) (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))))
(pass-if "first dummy" #t) (pass-if "first dummy" #t)
(pass-if-not "second dummy" #f) (pass-if-not "second dummy" #f)
(pass-if "and" (seq? (and 1) 1)) (pass-if "if" (seq? (if #t 'true) 'true))
(pass-if "and 2" (seq? (and 1 (= 0 1) #f) #f)) (pass-if "if 2" (seq? (if (seq? 0 '0) 'true 'false) 'true))
(pass-if "or" (seq? (or) #f)) (pass-if "if 3" (seq? (if (= 1 2) 'true 'false) 'false))
(pass-if "or 2" (seq? (or 1) 1))
(pass-if "or 3" (seq? (or #f (= 0 1) 3) 3)) (pass-if "when" (seq? (when #t 'true) 'true))
(pass-if "let" (seq? (let ((p 5) (q 6)) (+ p q)) 11)) (pass-if "when 2" (seq? (when #f 'true) *unspecified*))
(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 "map" (sequal? (map identity '(1 2 3 4)) '(1 2 3 4))) (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)) (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) (define xxxa 0)
(pass-if "set! " (seq? (begin (set! xxxa 1) xxxa) 1)) (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 "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? (+ 1 2 3) 6))
(pass-if "*" (seq? (* 3 3 3) 27)) (pass-if "*" (seq? (* 3 3 3) 27))
(pass-if "/" (seq? (/ 9 3) 3)) (pass-if "/" (seq? (/ 9 3) 3))
@ -109,15 +61,7 @@
(pass-if "=" (seq? 3 '3)) (pass-if "=" (seq? 3 '3))
(pass-if "= 2" (not (= 3 '4))) (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 "string-append" (sequal? (string-append "a" "b" "c") "abc"))
(pass-if "substring" (sequal? (substring "hello world" 6) "world")) (pass-if "substring" (sequal? (substring "hello world" 6) "world"))
(pass-if "substring 2" (sequal? (substring "hello world" 4 7) "o w")) (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" (sequal? (make-vector 3) #(*unspecified* *unspecified* *unspecified*))))
(pass-if "make-vector 2" (sequal? (make-vector 3 0) #(0 0 0))) (pass-if "make-vector 2" (sequal? (make-vector 3 0) #(0 0 0)))
(pass-if "vector-ref" (seq? (vector-ref #(0 1) 1) 1)) (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" (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 2" (not (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #()))))
(pass-if "equal?" (sequal? #(1) #(1))) (pass-if "equal?" (sequal? #(1) #(1)))
(pass-if "equal?" (not (equal? #() #(1)))) (pass-if "equal?" (not (equal? #() #(1))))
(pass-if "memq" (sequal? (memq 'a '(a b c)) '(a b c))) (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) 'g0))
(pass-if "gensym" (seq? (gensym) 'g1)) (pass-if "gensym" (seq? (gensym) 'g1))
(pass-if "gensym" (seq? (gensym) 'g2))) (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 " (sequal? (last-pair '(1 2 3 4)) '(4)))
(pass-if "last-pair 2" (seq? (last-pair '()) '())) (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)) (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" (seq? (apply identity '(0)) 0))
(pass-if "apply identity 2" (sequal? (apply identity '((0 1))) '(0 1))) (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))) (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 1" (seq? (min 0 1) 0))
(pass-if "min 2" (seq? (min 1 0 2) 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?" (seq? (char-alphabetic? #\a) #t))
(pass-if "char-alphabetic? 2" (seq? (char-alphabetic? #\[) #f)) (pass-if "char-alphabetic? 2" (seq? (char-alphabetic? #\[) #f))