Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

add do, case syntax

fix broken member-procedure
  • Loading branch information...
commit c36743d066d8fc3a7bf5428a1de5cbb0f1fb2707 1 parent bf63204
@cpylua authored
Showing with 120 additions and 42 deletions.
  1. +73 −42 lib/core.scm
  2. +21 −0 test/case-test.scm
  3. +26 −0 test/do-test.scm
View
115 lib/core.scm
@@ -5,7 +5,73 @@
; 2012-2-16, initial version
;
+; delay evaluation
+(define (make-promise proc)
+ (let ((result-ready? #f)
+ (result #f))
+ (lambda ()
+ (if result-ready?
+ result
+ (let ((x (proc)))
+ (if result-ready?
+ result
+ (begin (set! result-ready? #t)
+ (set! result x)
+ result)))))))
+
+(define-macro delay
+ (lambda (exp)
+ `(make-promise (lambda () ,exp))))
+
+(define (force promise)
+ (promise))
+
+; let*
+(define-macro let*
+ (lambda (bindings . body)
+ (cond
+ ((null? (cdr bindings))
+ `(let ,bindings ,@body))
+ (else
+ `(let ,(list (car bindings)) (let* ,(cdr bindings) ,@body))))))
+; letrec
+(define-macro letrec
+ (lambda (bindings . body)
+ `(let ,(map (lambda (b) (list (car b) ''*undefined*)) bindings)
+ ,@(map (lambda (b) (cons 'set! b)) bindings)
+ ,@body)))
+
+; case
+(define-macro case
+ (lambda (key . clauses)
+ (let ((val (gensym)))
+ `(let ((,val ,key))
+ (cond
+ ,@(map (lambda (c)
+ (cond
+ ((eq? (car c) 'else) c)
+ (else `((memv ,val ',(car c)) ,(cadr c)))))
+ clauses))))))
+
+; do
+(define-macro do
+ (lambda (exps test . cmd)
+ (let ((loop-proc (gensym "proc")))
+ `(begin
+ (define (,loop-proc ,@(map car exps))
+ (cond
+ (,(car test) ,@(cdr test))
+ (else ,@cmd
+ (,loop-proc
+ ,@(map (lambda (e)
+ (cond
+ ((null? (list-tail e 2)) (car e))
+ (else (caddr e))))
+ exps)))))
+ (,loop-proc ,@(map cadr exps))))))
+
+; library helpers
(define *DATA-TOP* "/usr/share/asc/")
(define (load-lib lib)
@@ -370,11 +436,13 @@
(else (find-tail pred (cdr seq)))))
(define (member-procedure pred)
- (lambda (obj seq)
- (cond
- ((null? seq) #f)
- ((pred obj (car seq)) seq)
- (else (maker obj (cdr seq))))))
+ (define loop
+ (lambda (obj seq)
+ (cond
+ ((null? seq) #f)
+ ((pred obj (car seq)) seq)
+ (else (loop obj (cdr seq))))))
+ loop)
(define memq (member-procedure eq?))
@@ -522,40 +590,3 @@
(define (current-continuation)
(call/cc (lambda (cc) (cc cc))))
-; delay evaluation
-(define (make-promise proc)
- (let ((result-ready? #f)
- (result #f))
- (lambda ()
- (if result-ready?
- result
- (let ((x (proc)))
- (if result-ready?
- result
- (begin (set! result-ready? #t)
- (set! result x)
- result)))))))
-
-(define-macro delay
- (lambda (exp)
- `(make-promise (lambda () ,exp))))
-
-(define (force promise)
- (promise))
-
-; let*
-(define-macro let*
- (lambda (bindings . body)
- (cond
- ((null? (cdr bindings))
- `(let ,bindings ,@body))
- (else
- `(let ,(list (car bindings)) (let* ,(cdr bindings) ,@body))))))
-
-; letrec
-(define-macro letrec
- (lambda (bindings . body)
- `(let ,(map (lambda (b) (list (car b) ''*undefined*)) bindings)
- ,@(map (lambda (b) (cons 'set! b)) bindings)
- ,@body)))
-
View
21 test/case-test.scm
@@ -0,0 +1,21 @@
+(display-line
+ (macroexpand-1
+ '(case (* 2 3)
+ ((2 3 5 7) 'prime)
+ ((1 4 6 8 9) 'composite))))
+
+(display-line
+ (case (* 2 3)
+ ((2 3 5 7) 'prime)
+ ((1 4 6 8 9) 'composite)))
+
+(display-line
+ (case (car '(c d))
+ ((a) 'a)
+ ((b) 'b)))
+
+(display-line
+ (case (car '(c d))
+ ((a e i o u) 'vowel)
+ ((w y) 'semivowel)
+ (else 'consonant)))
View
26 test/do-test.scm
@@ -0,0 +1,26 @@
+(display-line
+ (macroexpand-1
+ '(do ((vec (make-vector 5))
+ (i 0 (+ i 1)))
+ ((= i 5) vec)
+ (vector-set! vec i i))))
+
+(display-line
+ (do ((vec (make-vector 5))
+ (i 0 (+ i 1)))
+ ((= i 5) vec)
+ (vector-set! vec i i)))
+
+(display-line
+ (let ((x '(1 3 5 7 9)))
+ (macroexpand-1
+ '(do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum)))))
+
+(display-line
+ (let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum))))
+
Please sign in to comment.
Something went wrong with that request. Please try again.