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

Support => in cond.

Browse source 
* module/mes/base-0.mes (cond): Support =>.
* module/mes/rea-0.mes (cond): Update.
* NEWS: Update.
This commit is contained in:
Jan Nieuwenhuizen 2016-12-16 20:18:38 +01:00
parent 46a617f16e
commit bbeb4708e5
5 changed files with 38 additions and 31 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
NEWS
View file

@ -18,6 +18,7 @@ The C-reader needs only support reading of words and lists
block-comments are all handled by the Scheme reader later.
** Language
*** Keywords are supported.
*** Cond now supports =>.
* Changes in 0.3 since 0.2
** Core
*** Number-based rather than pointer-based cells.

1
mes.c
View file

@ -84,6 +84,7 @@ scm scm_nil = {SPECIAL, "()"};
scm scm_f = {SPECIAL, "#f"};
scm scm_t = {SPECIAL, "#t"};
scm scm_dot = {SPECIAL, "."};
scm scm_arrow = {SPECIAL, "=>"};
scm scm_undefined = {SPECIAL, "*undefined*"};
scm scm_unspecified = {SPECIAL, "*unspecified*"};
scm scm_closure = {SPECIAL, "*closure*"};

26
module/mes/base-0.mes
View file

@ -60,18 +60,20 @@
(apply f (apply cons* (cons h t)))))
(define-macro (cond . clauses)
(list 'if (null? clauses) *unspecified*
(if (null? (cdr clauses))
(list 'if (car (car clauses))
(list (cons 'lambda (cons '() (cons (car (car clauses)) (cdr (car clauses))))))
*unspecified*)
(if (eq? (car (cadr clauses)) 'else)
(list 'if (car (car clauses))
(list (cons 'lambda (cons '() (car clauses))))
(list (cons 'lambda (cons '() (cons *unspecified* (cdr (cadr clauses)))))))
(list 'if (car (car clauses))
(list (cons 'lambda (cons '() (car clauses))))
(cons 'cond (cdr clauses)))))))
(list 'if (pair? clauses)
(list (cons
'lambda
(cons
'(test)
(list (list 'if 'test
(if (pair? (cdar clauses))
(if (eq? (cadar clauses) '=>)
(append2 (cddar clauses) '(test))
(list (cons 'lambda (cons '() (car clauses)))))
(list (cons 'lambda (cons '() (car clauses)))))
(if (pair? (cdr clauses))
(cons 'cond (cdr clauses)))))))
(car (car clauses)))))
(define else #t)

31
module/mes/read-0.mes
View file

@ -54,19 +54,16 @@
(helper (read)))
(define-macro (cond . clauses)
(list (quote if) (null? clauses) *unspecified*
(if (null? (cdr clauses))
(list (quote if) (car (car clauses))
(list (cons (quote lambda) (cons (list) (cons (car (car clauses)) (cdr (car clauses))))))
*unspecified*)
(if (eq? (car (cadr clauses)) (quote else))
(list (quote if) (car (car clauses))
(list (cons (quote lambda) (cons (list) (car clauses))))
(list (cons (quote lambda) (cons (list) (cons *unspecified* (cdr (cadr clauses)))))))
(list (quote if) (car (car clauses))
(list (cons (quote lambda) (cons (list) (car clauses))))
(cons (quote cond) (cdr clauses)))))))
(list 'if (pair? clauses)
(list 'if (car (car clauses))
(if (pair? (cdar clauses))
(if (eq? (cadar clauses) '=>)
(append2 (cddar clauses) (list (caar clauses)))
(list (cons 'lambda (cons '() (car clauses)))))
(list (cons 'lambda (cons '() (car clauses)))))
(if (pair? (cdr clauses))
(cons 'cond (cdr clauses))))))
(define (eat-whitespace)
(cond
((eq? (peek-byte) 9) (read-byte) (eat-whitespace))
@ -130,7 +127,7 @@
(read-byte)
(cons (lookup (symbol->list (quote unsyntax-splicing)) a)
(cons (read-word (read-byte) w a) (list))))
(else
(#t
(cons (lookup (symbol->list (quote unsyntax)) a)
(cons (read-word (read-byte) w a) (list))))))
((eq? (peek-byte) 39) (read-byte)
@ -139,7 +136,7 @@
((eq? (peek-byte) 96) (read-byte)
(cons (lookup (cons (integer->char 35) (cons (integer->char 96) (list))) a)
(cons (read-word (read-byte) w a) (list))))
(else (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
(#t (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
((eq? c 39) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
(cons (read-word (read-byte) w a) (list)))
(begin (unread-byte c) (lookup w a))))
@ -153,11 +150,11 @@
(cons
(lookup (symbol->list (quote unquote-splicing)) a)
(cons (read-word (read-byte) w a) (list)))))
(else (cons (lookup-char c a) (cons (read-word (read-byte) w a)
(#t (cons (lookup-char c a) (cons (read-word (read-byte) w a)
(list))))))
((eq? c 96) (cons (lookup-char c a) (cons (read-word (read-byte) w a) (list))))
((eq? c 59) (read-line-comment c) (read-word 10 w a))
(else (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
(#t (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
((lambda (p)
;;(display (quote scheme-program=)) (display p) (newline)

10
tests/base.test
View file

@ -52,8 +52,14 @@ exit $?
(pass-if "cond" (seq? (cond (#t)) #t))
(pass-if "cond 2" (seq? (cond (#f)) *unspecified*))
(pass-if "cond 3" (seq? (cond (#t 0)) 0))
(pass-if "cond 3" (seq? (cond (#f 1) (#t 0)) 0)))
)
(pass-if "cond 3" (seq? (cond (#f 1) (#t 0)) 0))
(pass-if-equal "cond => "
0 (let ((lst '(0 1 2)))
(define (next)
(let ((r (car lst)))
(set! lst (cdr lst))
r))
(cond ((next) => identity))))))
(pass-if "and" (seq? (and 1) 1))
(pass-if "and 2" (seq? (and 1 (= 0 1) #f) #f))