remove booting into mes (would need VM), boot.mes; rewrite test.mes.

This commit is contained in:
Jan Nieuwenhuizen 2016-07-18 22:43:16 +02:00
parent 8706d7e938
commit 3a28828bdf
7 changed files with 195 additions and 351 deletions

1
.gitignore vendored
View File

@ -2,7 +2,6 @@
*.go
*.o
*~
/boot.mes
/mes
/mes.h
/environment.i

View File

@ -4,9 +4,8 @@ CFLAGS=-std=c99 -O3 -finline-functions
default: all
all: mes boot.mes
all: mes
#mes.o: mes.c mes.h
mes: mes.c mes.h
mes.h: mes.c GNUmakefile
@ -36,12 +35,6 @@ check: all
./mes.test ./mes
cat scm.mes test.mes | ./mes
boot.mes: mes.mes loop2.mes scm.mes test.mes
cat $^ > $@
boot: all
./mes < boot.mes
run: all
cat scm.mes test.mes | ./mes

7
c1.mes
View File

@ -6,10 +6,9 @@
(define b 1)
(define (y) b)
(set! b 0)
(display b)
(let ((b 2))
(y))
)
(list b
(let ((b 2))
(y))))
(display (x))
(newline)

90
mes.c
View File

@ -277,7 +277,7 @@ assq (scm *x, scm *a)
}
scm *
apply_env_ (scm *fn, scm *x, scm *a)
apply_env (scm *fn, scm *x, scm *a)
{
#if DEBUG
printf ("apply_env fn=");
@ -316,9 +316,9 @@ apply_env_ (scm *fn, scm *x, scm *a)
display (x);
puts ("");
#endif
//return apply_env_ (eval_ (fn, a), x, a);
scm *e = eval_ (fn, a);
return apply_env_ (e, x, a);
//return apply_env (eval (fn, a), x, a);
scm *e = eval (fn, a);
return apply_env (e, x, a);
//return &scm_unspecified;
}
#if MACROS
@ -333,13 +333,13 @@ apply_env_ (scm *fn, scm *x, scm *a)
puts ("");
#endif
//scm *r = apply_env (cdr (macro), cdr (fn), a);
scm *r = apply_env (eval_ (cdr (macro), a), cdr (fn), a);
scm *r = apply_env (eval (cdr (macro), a), cdr (fn), a);
#if DEBUG
printf ("APPLY MACRO GOT: ==> ");
display (r);
puts ("");
#endif
scm *e = eval_ (r, a);
scm *e = eval (r, a);
return apply_env (e, x, a);
}
#endif // MACROS
@ -347,7 +347,7 @@ apply_env_ (scm *fn, scm *x, scm *a)
}
scm *
eval_ (scm *e, scm *a)
eval (scm *e, scm *a)
{
#if DEBUG
printf ("eval e=");
@ -413,7 +413,7 @@ eval_ (scm *e, scm *a)
display (cdr (e));
puts ("");
#endif
return eval (apply_env_ (cdr (macro), cdr (e), a), a);
return eval (apply_env (cdr (macro), cdr (e), a), a);
}
#endif // MACROS
return apply_env (car (e), evlis (cdr (e), a), a);
@ -465,6 +465,9 @@ closure_body (scm *body, scm *a)
scm *p = pairlis (cdadr (e), cdadr (e), cons (cons (caar (e), caar (e)), a));
return cons (cons (car (e), cons (cadr (e), closure_body (cddr (e), p))), cdr (body));
}
if (eq_p (car (e), &scm_symbol_set_x) == &scm_t)
return cons (e, closure_body (cdr (body), a));
// skip closure-body-ing macros
if (eq_p (car (e), &scm_symbol_define_macro) == &scm_t)
return cons (e, closure_body (cdr (body), a));
return cons (cons (car (e), cons (cadr (e), closure_body (cddr (e), a))), cdr (body));
@ -787,10 +790,10 @@ values (scm *x/*...*/)
scm *
call_with_values_env (scm *producer, scm *consumer, scm *a)
{
scm *v = apply_env_ (producer, &scm_nil, a);
scm *v = apply_env (producer, &scm_nil, a);
if (v->type == VALUES)
v = v->cdr;
return apply_env_ (consumer, v, a);
return apply_env (consumer, v, a);
}
scm *
@ -882,6 +885,20 @@ list_to_vector (scm *x)
return v;
}
scm*
integer_to_char (scm *x)
{
assert (x->type == NUMBER);
return make_char (x->value);
}
scm*
char_to_integer (scm *x)
{
assert (x->type == CHAR);
return make_number (x->value);
}
scm*
number_to_string (scm *x)
{
@ -891,6 +908,13 @@ number_to_string (scm *x)
return make_string (buf);
}
scm*
builtin_exit (scm *x)
{
assert (x->type == NUMBER);
exit (x->value);
}
scm*
string_to_symbol (scm *x)
{
@ -1271,13 +1295,19 @@ eval_quasiquote (scm *e, scm *a)
}
puts ("");
#endif
// bool have_unquote = assq (&scm_unquote, a) != &scm_f;
// #if DEBUG
// printf ("eval_quasiquote[%d] ==> ", have_unquote);
// display (e);
// puts ("");
// #endif
if (e == &scm_nil) return e;
else if (atom_p (e) == &scm_t) return e;
else if (eq_p (car (e), &scm_symbol_unquote) == &scm_t)
return eval (cadr (e), a);
else if (e->type == PAIR && e->car->type == PAIR
&& eq_p (caar (e), &scm_symbol_unquote_splicing) == &scm_t)
return append2 (eval_ (cadar (e), a), eval_quasiquote (cdr (e), a));
return append2 (eval (cadar (e), a), eval_quasiquote (cdr (e), a));
return cons (eval_quasiquote (car (e), a), eval_quasiquote (cdr (e), a));
}
#endif
@ -1427,44 +1457,6 @@ read_file (scm *e, scm *a)
return cons (e, read_file (readenv (a), a));
}
scm *
apply_env (scm *fn, scm *x, scm *a)
{
#if DEBUG
printf ("\nc:apply_env fn=");
display (fn);
printf (" x=");
display (x);
puts ("");
#endif
if (fn == &scm_apply_env_)
return eval_ (x, a);
return apply_env_ (fn, x, a);
}
bool evalling_p = false;
scm *
eval (scm *e, scm *a)
{
#if DEBUG
printf ("\nc:eval e=");
display (e);
puts ("");
#endif
scm *eval__ = assq (&scm_symbol_eval, a);
assert (eval__ != &scm_f);
eval__ = cdr (eval__);
if (builtin_p (eval__) == &scm_t
|| evalling_p)
return eval_ (e, a);
evalling_p = true;
scm *r = apply_env (eval__, cons (e, cons (a, &scm_nil)), a);
evalling_p = false;
return r;
}
int
main (int argc, char *argv[])
{

View File

@ -36,7 +36,7 @@
(define (vector . rest) (list->vector rest))
(define (apply f args)
(c:eval (cons f args) (current-module)))
(eval (cons f args) (current-module)))
(define (defined? x)
(assq x (current-module)))
@ -171,3 +171,9 @@
;; (let ((val (number->string counter)))
;; (set! counter (+ counter 1))
;; (string->symbol (string-append "g" val))))))
(define *gensym* 0)
(define (gensym)
(set! *gensym* (+ *gensym* 1))
(string->symbol (string-append "g" (number->string *gensym*))))

View File

@ -156,6 +156,7 @@
(display "make-transformer") (newline)
`(lambda (,%input ,%rename ,%compare)
(let ((,%tail (cdr ,%input)))
(display "TEEL:") (display ,%tail) (newline)
(cond ,@(map process-rule rules)
(#t ;;else
(syntax-error
@ -169,6 +170,24 @@
(null? (cddr rule)))
(let ((pattern (cdar rule))
(template (cadr rule)))
(let ((xx `,(process-pattern pattern
%tail
(lambda (x) x)))
(tt `,%tail)
(yy (process-match %tail pattern)))
(display "METS>>>") (newline)
(display yy)
(newline)
(display "TEEL>>>") (newline)
(display tt)
(newline)
(display "<<<METS") (newline)
(display "PETTERN>>>") (newline)
(display xx)
(newline)
(display "<<<PETTERN") (newline)
)
`((and ,@(process-match %tail pattern))
(let* ,(process-pattern pattern
%tail

412
test.mes
View File

@ -21,251 +21,93 @@
;; The Maxwell Equations of Software -- John McCarthy page 13
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
(display 123)
;; haha, broken. lat0r
(define pass 0)
(define fail 0)
(define result #f)
(let ((pass 0)
(fail 0))
(set! result
(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)))))))
4
(newline)
(define-macro (pass-if name t)
`(let ()
(display "test: ") (display ,name)
(result ,t)))
(cons (display 'one-) (display 'two))
(newline)
(define-macro (pass-if-not name f)
`(let ()
(display "test: ") (display ,name)
(result (not ,f))))
(display 'hello-display-symbol)
(newline)
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)
(display '(0 1 2))
(newline)
(pass-if "and" (eq? (and 1) 1))
(pass-if "and 2" (eq? (and 1 (= 0 1) #f) #f))
(pass-if "or" (eq? (or) #f))
(pass-if "or 2" (eq? (or 1) 1))
(pass-if "or 3" (eq? (or #f (= 0 1) 3) 3))
(pass-if "let" (eq? (let ((p 5) (q 6)) (+ p q)) 11))
(pass-if "let loop" (equal? (let loop ((lst '(3 2 1)))
(if (null? lst) '()
(cons (car lst)
(loop (cdr lst))))) '(3 2 1)))
(pass-if "quasiquote" (let ((cc 'bb)) (equal? `(aa bb ,cc) '(aa bb bb))))
(pass-if "let* comments" (eq? (let* ((aa 2)
(bb (+ aa 3))
#! boo !#
;;(bb 4)
)
bb)
5))
(display (- 12 3))
(newline)
(display (+ 3 4))
(newline)
(display "(and): ")
(display (and))
(newline)
(display "(and 1): ")
(display (and 1))
(newline)
(display "(and 1 (= 0 1)): ")
(display (and 1 (= 0 1)))
(newline)
(display "(or): ")
(display (or))
(newline)
(display "(or 1): ")
(display (or 1))
(newline)
(display "(or #f (= 0 1) 3): ")
(display (or #f (= 0 1) 3))
(newline)
(display (or (= 0 1) #f (and (display "YEAH") (newline) 'woet)))
(newline)
(let ((p 5)
(q 6))
(display 'let-p:3-q:4)
(newline)
(display 'p:)
(display p)
(newline)
(display 'q:)
(display q)
(newline))
(display
(let ((p 5)
(q 6))
(display 'hallo)
(display p)
(display 'daar)
(display q)
(display 'dan)))
(newline)
(display 'let-dun)
(newline)
(let loop ((lst '(3 2 1)))
(display "loop")
(newline)
(if (null? lst) (begin (display "dun") 'dun)
(begin
(display "looping: ")
(display (car lst))
(newline)
(loop (cdr lst)))))
(newline)
(define c 'b)
`(aa bb ,c)
(display `(pp qq ,c))
(newline)
(display
(let* ((aa 2)
(bb (+ aa 3))
#! boo !#
;;(bb 4)
)
(display 'allo:)
bb))
(newline)
(display 'let*-dun)
(newline)
(map display '(1 2 3 4))
(newline)
(map (lambda (x) (display x) (newline)) '(5 6 7 8))
(newline)
(map (lambda (i a) (display i) (display ':) (display a) (newline)) '(1 2 3 4) '(a b c d))
(newline)
(define a 0)
(display 'a=0:)
(display a)
(newline)
(display "set!")
(display (set! a 1))
(set! a 1)
(display 'a=1:)
(display a)
(newline)
(display
((lambda (x)
(display 'x:)
(display x)
(newline)
(display 'setting-x=2)
(newline)
(set! x 2)
(display 'x:)
(display x)
(newline))
1))
(display (+ 11 12))
(newline)
(display (* 3 3))
(newline)
(display (/ 9 3))
(newline)
(display (= 3 '3))
(newline)
(display (if #t 'true))
(newline)
(display (if (eq? 0 '0) 'true 'false))
(newline)
(display (if (= 1 2) 'true 'false))
(newline)
(display 'factorial4=)
(display
(letrec ((factorial (lambda (n)
;; (display 'factorial:)
;; (display n)
;; (newline)
(if (= n 1) 1
(* n (factorial (- n 1)))))))
(factorial 4)))
(newline)
(define a 2)
(begin
(display 'a+3=)
(display (+ a 3)))
(newline)
" a b c"
(display "string me")
(newline)
(display (string-append "a" "b" "c"))
(newline)
(display (string-length (string-append "a" "b" "c")))
(newline)
#\m
(display #\m)
(newline)
(display #\101)
(newline)
(display #\newline)
(newline)
(display #\space)
(newline)
(display (string #\a #\space #\s #\t #\r #\i #\n #\g #\newline))
(newline)
(display "length of nil: ")
(display (length '()))
(newline)
(display "length of '(a b c): ")
(display (length '(a b c)))
(newline)
#(a b c)
(display #(0 1 2))
(newline)
(define v #("a" "b" "c"))
(display "vector?: ")
(display (vector? v))
(newline)
(display "length of ")
(display v)
(display ": ")
(display (vector-length v))
(newline)
(display "as list: ")
(define lv (vector->list v))
(display lv)
(newline)
(display "again as vector: ")
(display (list->vector lv))
(newline)
(display "(vector 0 1 2): ")
(display (vector 0 1 2))
(newline)
(display "v[1]: ")
(display (vector-ref v 1))
(newline)
(display "v[1]=q: ")
(vector-set! v 1 'q)
(display v)
(newline)
(display "memq a: ")
(display (memq 'a '(a b c)))
(newline)
(display "memq b: ")
(display (memq 'b '(a b c)))
(newline)
(display "memq c: ")
(display (memq 'c '(a b c)))
(newline)
(display "memq d: ")
(display (memq 'd '(a b c)))
(newline)
(display "member a: ")
(display (member '(a) '((a) b c)))
(newline)
(display "plus: ")
(display (+ 1 1 1 1))
(newline)
(pass-if "map" (equal? (map identity '(1 2 3 4)) '(1 2 3 4)))
(pass-if "map 2 " (equal? (map (lambda (i a) (cons i a)) '(1 2 3 4) '(a b c d))
'((1 . a) (2 . b) (3 . c) (4 . d))))
(define xxxa 0)
(pass-if "set! " (eq? (begin (set! xxxa 1) xxxa) 1))
(pass-if "set! 2" (eq? (let ((a 0)) (set! a 1) a) 1))
(pass-if "+" (eq? (+ 1 2 3) 6))
(pass-if "*" (eq? (* 3 3 3) 27))
(pass-if "/" (eq? (/ 9 3) 3))
(pass-if "=" (= 3 '3))
(pass-if "= 2" (not (= 3 '4)))
(pass-if "if" (eq? (if #t 'true) 'true))
(pass-if "if 2" (eq? (if (eq? 0 '0) 'true 'false) 'true))
(pass-if "if 3" (eq? (if (= 1 2) 'true 'false) 'false))
(pass-if "letrec" (= (letrec ((factorial (lambda (n)
(if (= n 1) 1
(* n (factorial (- n 1)))))))
(factorial 4))
24))
(pass-if "begin" (eq? (begin 'a 'b (+ 1 2)) 3))
(pass-if "string-append" (equal? (string-append "a" "b" "c") "abc"))
(pass-if "eq?" (not (eq? (string-append "a" "b" "c") "abc")))
(pass-if "string-length" (= (string-length (string-append "a" "b" "c")) 3))
(pass-if "char" (= (char->integer #\A) 65))
(pass-if "char 2" (= (char->integer #\101) (char->integer #\A)))
(pass-if "char 3" (eq? (integer->char 10) #\newline))
(pass-if "char 4" (eq? (integer->char 32) #\space))
(pass-if "string " (equal? (string #\a #\space #\s #\t #\r #\i #\n #\g) "a string"))
(pass-if "length" (eq? (length '()) 0))
(pass-if "length 2" (= (length '(a b c)) 3))
(pass-if "vector?" (vector? #(1 2 c)))
(pass-if "vector-length" (= (vector-length #(1)) 1))
(pass-if "list->vector" (equal? (list->vector '(a b c)) #(a b c)))
(pass-if "vector" (equal? #(vector 0 1 2) #(vector 0 1 2)))
(pass-if "vector-ref" (eq? (vector-ref #(0 1) 1) 1))
;;(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) #()))
(pass-if "equal?" (equal? #(1) #(1)))
(pass-if "equal?" (not (equal? #() #(1))))
(pass-if "memq" (equal? (memq 'a '(a b c)) '(a b c)))
(pass-if "memq" (equal? (memq 'b '(a b c)) '(b c)))
(pass-if "memq" (eq? (memq 'd '(a b c)) #f))
(pass-if "member" (equal? (member '(a) '((a) b c)) '((a) b c)))
;; works, but debugging is foo
;; (cond ((defined? 'loop2)
@ -286,53 +128,47 @@
;; (display ((lambda (x) x) (values 1 2 3)))
;; (newline)))
(display "(procedure? builtin?: ")
(display (procedure? builtin?))
(define (guile?) (defined? 'gc))
(if (guile?)
(module-define! (current-module) 'builtin? (lambda (. x) #t)))
(pass-if "builtin?" (builtin? eval))
;;(pass-if "builtin?" (builtin? cond))
(pass-if "procedure?" (procedure? builtin?))
(pass-if "procedure?" (procedure? procedure?))
(when (not (guile?))
(pass-if "gensym" (eq? (gensym) 'g0))
(pass-if "gensym" (eq? (gensym) 'g1))
(pass-if "gensym" (eq? (gensym) 'g2)))
(pass-if "unquote" (equal? `,(list 1 2 3 4) '(1 2 3 4)))
(pass-if "splice" (equal? `('boo ,@'(bah baz) 1 2) '((quote boo) bah baz 1 2)))
(pass-if "splice" (equal? `(1 ,@(list 2 3) 4) '(1 2 3 4)))
(pass-if "splice" (equal? (let ((s-r '(2 3))) `(1 ,@s-r 4)) '(1 2 3 4)))
(pass-if "unquote" (equal? `(1 2 '(,(+ 1 2))) '(1 2 '(3))))
(pass-if "when" (eq? (when #t 'true) 'true))
(pass-if "when 2" (eq? (when #f 'true) *unspecified*))
(define b 0)
(define x (lambda () b))
(define (x) b)
(pass-if "closure" (= (x) 0))
(define (c b)
(x))
(pass-if "closure 2" (= (c 1) 0))
(define (x)
(define b 1)
(define (y) b)
(set! b 0)
(list b
(let ((b 2))
(y))))
(pass-if "closure 3" (equal? (x) '(0 0)))
(newline)
(display "passed: ") (display (car (result))) (newline)
(display "failed: ") (display (cadr (result))) (newline)
(display "total: ") (display (apply + (result))) (newline)
(display "(procedure? procedure?): ")
(display (procedure? procedure?))
(newline)
(define *gensym* 0)
(define (gensym)
(set! *gensym* (+ *gensym* 1))
(string->symbol (string-append "g" (number->string *gensym*))))
(display (gensym))
(newline)
(display (gensym))
(newline)
(display (gensym))
(newline)
(display "unquote:")
(display `,(list 1 2 3 4))
(newline)
(display `('boo ,@'(bah baz) 1 2))
(newline)
(display "splice:")
(display `(1 ,@(list 2 3) 4))
(newline)
(define s-r '(2 3))
(display "splice:")
(display `(1 ,@s-r 4))
(newline)
(display "`(1 2 '(,(+ 1 2))): ")
(display `(1 2 '(,(+ 1 2))))
(newline)
(display "when:")
(when #t
(display "true")
(newline))
(when #f
(display "must not see")
(newline))
'()
(exit (cadr (result)))