multiple scheme implementation support update

Author: seckcoder

src/eval/eval.scm

@@ -41,6 +41,7 @@
         ((or? exp) (seck-eval (or->if exp) env))
         ((let? exp) (seck-eval (let->combination exp) env))
         ((letstar? exp) (seck-eval (let*->nested-let exp) env))
+        ((letrec? exp) (seck-eval (letrec->let exp) env))
         ((for? exp) (seck-eval (for->let exp) env))
         ((application? exp)
          ; evaluated when call procedure
@@ -239,7 +240,7 @@
 (define (make-procedure params body-seq env)
   (list 'procedure
         params
-        (scan-out-defines body-seq)
+        (scan-out-defines body-seq #f)
         env))
 
 (define (procedure-parameters proc)
@@ -261,11 +262,12 @@
           (eval-sequence (rest-exps exps) env))
         ))
 ; proc-body is a sequence of expressions to be evaluated
-(define (scan-out-defines proc-body)
+(define (scan-out-defines proc-body do-scan-out)
   (let ((definitions (filter definition? proc-body))
         (non-definitions (filter (compose not definition?)
                                  proc-body)))
-    (if (not (null? definitions))
+    (if (and do-scan-out
+             (not (null? definitions)))
       (list (make-let (map (lambda (exp)
                              (list (definition-var exp)
                                    ;; Here, we use '', since
@@ -488,6 +490,20 @@
                  (let-vals exp)  ; todo
                  ))
 
+
+(define (letrec? exp)
+  (tagged-list? exp 'letrec))
+(define (letrec->let exp)
+  (make-let 
+    (map (lambda (var)
+           (list var ''*assigned*))
+         (let-vars exp))
+    (append (map (lambda (var value)
+                   (list 'set! var value))
+                 (let-vars exp)
+                 (let-vals exp))
+            (let-body exp))))
+
 ; @(for)
 
 (define (for? exp)
@@ -613,10 +629,32 @@
              global-env)
   'pass)
 
-(define proc (make-procedure '(c)
-                             '((define b (+ a x))
-                               (define a 5)
-                               (+ a b c))
-                             global-env))
-(define (test-scan-out-definitons)
-  (scan-out-defines (procedure-body proc)))
+
+(define letrec-exp '(letrec ((even?
+                               (lambda (n)
+                                 (if (= n 0)
+                                   true
+                                   (odd? (- n 1)))))
+                             (odd?
+                               (lambda (n)
+                                 (if (= n 0)
+                                   false
+                                   (even? (- n 1))))))
+                      (even? x)))
+
+(define (test-letrec)
+  (seck-eval '(define (f x)
+                (letrec ((even?
+                           (lambda (n)
+                             (if (= n 0)
+                               true
+                               (odd? (- n 1)))))
+                         (odd?
+                           (lambda (n)
+                             (if (= n 0)
+                               false
+                               (even? (- n 1))))))
+                  (even? x)))
+             global-env)
+  (seck-eval '(f 3) global-env)
+  )

src/lib/r6rs/chez.scm

@@ -0,0 +1,106 @@
+(library
+  (chez)
+  (export sleepfor
+          parallel-execute
+          make-semaphore
+          semaphore-acquire
+          semaphore-release
+          rand
+          random-in-range
+          random-init
+          random-update
+          )
+  (import (chezscheme))
+
+  ; @(utils)
+  ; sleep for s seconds
+  (define (sleepfor s)
+    (sleep (make-time 'time-duration 0 s)))
+
+  ; @(concurrency)
+  (define (parallel-execute . args)
+    (for-each fork-thread args))
+
+  (define (make-serializer)
+    (let ((mutex (make-mutex)))
+      (lambda (p)
+        (define (serialized-p . args)
+          (mutex 'acquire)
+          (let ((val (apply p args)))
+            (mutex 'release)
+            val))
+        serialized-p)))
+  (define (make-semaphore n)
+    (let ((mutex (make-mutex)))
+      (define (acquire . args)
+        (let ((block? (if (null? args)
+                        #t
+                        (car args))))
+          ; Note n's if test should be protected by mutex.
+          (mutex-acquire mutex)
+          (if (> n 0)
+            (begin (set! n (- n 1))
+                   (mutex-release mutex)
+                   #t)
+            (begin (mutex-release mutex)
+                   (if block?
+                     (acquire)
+                     #f)))
+          ))
+      (define (release)
+        (mutex-acquire mutex)
+        (set! n (+ n 1))
+        (mutex-release mutex))
+
+      (define (self msg)
+        (cond ((eq? msg 'acquire) acquire)
+              ((eq? msg 'release) release)
+              (else
+                (error 'semaphore-self "UNKNOWN MESSAGE" msg))))
+      self))
+
+  (define (semaphore-acquire sem . args)
+    (apply (sem 'acquire) args))
+
+  (define (semaphore-release sem)
+    (sem 'release))
+
+  ; a not practical implementation of test-and-set!
+  (define (test-and-set! cell)
+    (if (car cell)
+      #t
+      (begin (set-car! cell #t)
+             #f)))
+
+  (define (clear! cell)
+    (set-car! cell #f))
+
+  (define (mutex-test-and-set-impl)
+    (define (make-mutex)
+      (let ((cell (list #f)))
+        (define (self msg)
+          (cond ((eq? msg 'acquire)
+                 (if (test-and-set! cell)
+                   (self 'acquire)
+                   #t))
+                ((eq? msg 'release)
+                 (clear! cell))))
+        self)))
+
+  ; [low high)
+  (define (random-in-range low high)
+    (let ((range (- high low)))
+      (+ low (random range))))
+  (define random-init (time-second (current-time)))
+  (define (random-update x)
+    (let ((a 40)
+          (b 2641)
+          (m 729))
+      (modulo (+ (* a x) b) m)))
+
+  (define rand
+    (let ((x random-init))
+      (lambda ()
+        (set! x (rand-update x))
+        x)))
+  )

src/lib/r6rs/concurrency.scm

@@ -1,78 +0,0 @@
-(library
-  (concurrency)
-  (export parallel-execute
-          make-semaphore
-          semaphore-acquire
-          semaphore-release)
-
-  (import (chezscheme))
-
-  (define (parallel-execute . args)
-    (for-each fork-thread args))
-
-  (define (make-serializer)
-    (let ((mutex (make-mutex)))
-      (lambda (p)
-        (define (serialized-p . args)
-          (mutex 'acquire)
-          (let ((val (apply p args)))
-            (mutex 'release)
-            val))
-        serialized-p)))
-  (define (make-semaphore n)
-    (let ((mutex (make-mutex)))
-      (define (acquire . args)
-        (let ((block? (if (null? args)
-                        #t
-                        (car args))))
-          ; Note n's if test should be protected by mutex.
-          (mutex-acquire mutex)
-          (if (> n 0)
-            (begin (set! n (- n 1))
-                   (mutex-release mutex)
-                   #t)
-            (begin (mutex-release mutex)
-                   (if block?
-                     (acquire)
-                     #f)))
-          ))
-      (define (release)
-        (mutex-acquire mutex)
-        (set! n (+ n 1))
-        (mutex-release mutex))
-
-      (define (self msg)
-        (cond ((eq? msg 'acquire) acquire)
-              ((eq? msg 'release) release)
-              (else
-                (error 'semaphore-self "UNKNOWN MESSAGE" msg))))
-      self))
-
-  (define (semaphore-acquire sem . args)
-    (apply (sem 'acquire) args))
-
-  (define (semaphore-release sem)
-    (sem 'release))
-
-  ; a not practical implementation of test-and-set!
-  (define (test-and-set! cell)
-    (if (car cell)
-      #t
-      (begin (set-car! cell #t)
-             #f)))
-
-  (define (clear! cell)
-    (set-car! cell #f))
-
-  (define (mutex-test-and-set-impl)
-    (define (make-mutex)
-      (let ((cell (list #f)))
-        (define (self msg)
-          (cond ((eq? msg 'acquire)
-                 (if (test-and-set! cell)
-                   (self 'acquire)
-                   #t))
-                ((eq? msg 'release)
-                 (clear! cell))))
-        self)))
-  )

src/lib/r6rs/rand.scm

@@ -1,19 +1 @@
-(library
-  (rand)
-  (import (chezscheme))
-  (export rand
-          random-init
-          random-update)
-  (define random-init (time-second (current-time)))
-  (define (random-update x)
-    (let ((a 40)
-          (b 2641)
-          (m 729))
-      (modulo (+ (* a x) b) m)))
 
-  (define rand
-    (let ((x random-init))
-      (lambda ()
-        (set! x (rand-update x))
-        x)))
-  )

src/lib/r6rs/utils.scm

@@ -7,14 +7,15 @@
           set-caddr!
           inlist?
           range
-          random-in-range
-          sleepfor
           divides?
           divisible? 
           println
           average
           pythagorean-triple?)
-  (import (chezscheme))
+
+  (import (rnrs)
+          (rnrs r5rs)
+          (rnrs mutable-pairs))
   (define (set-cadr! lst v)
     (set-car! (cdr lst) v))
 
@@ -40,14 +41,6 @@
           ((> a b) (cons a (range (- a 1) b)))
           ((< a b) (cons a (range a (- b 1))))))
 
-  ; [low high)
-  (define (random-in-range low high)
-    (let ((range (- high low)))
-      (+ low (random range))))
-
-  ; sleep for s seconds
-  (define (sleepfor s)
-    (sleep (make-time 'time-duration 0 s)))
   (define (divides? a b)
     (= (remainder b a) 0))