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. block-comments are all handled by the Scheme reader later.
** Language ** Language
*** Keywords are supported. *** Keywords are supported.
*** Cond now supports =>.
* Changes in 0.3 since 0.2 * Changes in 0.3 since 0.2
** Core ** Core
*** Number-based rather than pointer-based cells. *** 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_f = {SPECIAL, "#f"};
scm scm_t = {SPECIAL, "#t"}; scm scm_t = {SPECIAL, "#t"};
scm scm_dot = {SPECIAL, "."}; scm scm_dot = {SPECIAL, "."};
scm scm_arrow = {SPECIAL, "=>"};
scm scm_undefined = {SPECIAL, "*undefined*"}; scm scm_undefined = {SPECIAL, "*undefined*"};
scm scm_unspecified = {SPECIAL, "*unspecified*"}; scm scm_unspecified = {SPECIAL, "*unspecified*"};
scm scm_closure = {SPECIAL, "*closure*"}; scm scm_closure = {SPECIAL, "*closure*"};

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

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

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

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