*

1 files changed, 245 insertions, 0 deletions

diff --git a/js/games/nluqo.github.io/~bh/61a-pages/Lib/concurrent.scm b/js/games/nluqo.github.io/~bh/61a-pages/Lib/concurrent.scm
new file mode 100644
index 0000000..b0014fc
--- /dev/null
+++ b/js/games/nluqo.github.io/~bh/61a-pages/Lib/concurrent.scm
@@ -0,0 +1,245 @@
+;; Implementation of parallel-execute using call/cc.
+;;
+;; By Ben Rudiak-Gould, 10/2002.
+;;
+;; Requires STk (for "procedure-body" and first-class environments).
+
+
+(define call/cc call-with-current-continuation)
+
+
+(define (parallel-execute . thunks)
+  (apply run-concurrently-with-env
+         random
+         (map (lambda (thunk)
+                (cons (list (uncode (procedure-body thunk)))
+		      (make-virtual-env (procedure-environment thunk)) ))
+              thunks ))
+  'okay )
+
+
+(define (run-concurrently select . exprs)
+  (apply run-concurrently-with-env
+	 select
+	 (map (lambda (x)
+		(cons x (make-virtual-env (global-environment))) )
+	      exprs )))
+
+
+(define (run-concurrently-with-env select . exprs-with-envs)
+  (let ((threads
+	 (map (lambda (exp-env)
+		(list (call/cc
+		       (lambda (cont)
+			 (let ((scheduler (call/cc cont)))
+			   (scheduler (myeval (car exp-env)
+					      (cdr exp-env)
+					      scheduler )))))))
+	      exprs-with-envs )))
+    (let loop ()
+      (let ((active-threads
+             (filter (lambda (x) (continuation? (car x))) threads) ))
+        (if (null? active-threads)
+            (map car threads)
+            (let ((active (list-ref active-threads
+                                    (select (length active-threads)) )))
+              (set-car! active (call/cc (car active)))
+              (loop) ))))))
+
+
+(define (make-virtual-env real-env)
+  (cons
+   `((quote    **macro** ,macro-quote)
+     (lambda   **macro** ,macro-lambda)
+     (let      **macro** ,macro-let)
+     (set!     **macro** ,macro-set!)
+     (define   **macro** ,macro-define)
+     (if       **macro** ,macro-if)
+     (cond     **macro** ,macro-cond)
+     (and      **macro** ,macro-and)
+     (or       **macro** ,macro-or)
+     (set-car! **prim**  ,prim-set-car!)
+     (set-cdr! **prim**  ,prim-set-cdr!)
+     (begin    **prim**  ,prim-begin)
+     (test-and-set! **prim** ,prim-test-and-set!) )
+   real-env ))
+
+
+(define (env-lookup-raw sym env scheduler)
+  (call/cc scheduler)
+  (let ((virtual (assq sym (car env))))
+    (if virtual
+        (cdr virtual)
+        (eval sym (cdr env)) )))
+
+
+(define (env-lookup sym env scheduler)
+  (let* ((val (env-lookup-raw sym env scheduler))
+         (proc-body (procedure-body val)) )
+    (if (and proc-body (not (eq? (cadr proc-body) '**args**)))
+        (myeval (uncode proc-body)
+                (make-virtual-env (procedure-environment val))
+                scheduler )
+        val )))
+
+
+(define (env-set! sym val env scheduler)
+  (call/cc scheduler)
+  (let ((virtual (assq sym (car env))))
+    (if virtual
+        (set-cdr! virtual val)
+        (eval `(set! ,sym ',val) (cdr env)) )))
+
+
+(define (env-define! sym val env scheduler)
+  (call/cc scheduler)
+  (set-car! env (cons (cons sym val) (car env))) )
+
+
+(define (get-special-form name env scheduler)
+  (if (symbol? name)
+      (let ((val (env-lookup-raw name env scheduler)))
+        (if (and (pair? val) (eq? (car val) '**macro**))
+            val
+            #f ))
+      #f ))
+
+
+(define (myeval expr env scheduler)
+  (cond ((pair? expr)
+         (let ((special (get-special-form (car expr) env scheduler)))
+           (if special
+               ((cadr special) (cdr expr) env scheduler)
+               (let ((evaluated (eval-seq expr env scheduler)))
+                 (myapply (car evaluated) (cdr evaluated) scheduler) ))))
+        ((symbol? expr)
+	 (env-lookup expr env scheduler) )
+        (else (eval expr)) ))
+
+
+(define (eval-seq exprs env scheduler)
+  (if (null? exprs)
+      '()
+      (let ((val (myeval (car exprs) env scheduler)))
+	(cons val (eval-seq (cdr exprs) env scheduler)) )))
+
+
+(define (myapply func args scheduler)
+  (cond ((procedure? func)
+         (apply func args) )
+        ((and (pair? func) (eq? (car func) '**prim**))
+         ((cadr func) args scheduler) )
+        ((and (pair? func) (eq? (car func) '**macro**))
+         ((cadr func) (map (lambda (x) (list 'quote x)) args) scheduler) )
+        (else (error "apply of non-procedure" func args)) ))
+
+
+(define (make-call-environment params args env)
+  (cons (let loop ((params params) (args args))
+          (cond ((pair? params)
+                 (cons (cons (car params) (car args))
+                       (loop (cdr params) (cdr args)) ))
+                ((null? params)
+                 (car env) )
+                (else (cons (cons params args) (car env))) ))
+        (cdr env) ))
+
+
+(define (macro-lambda args env scheduler)
+  (let ((params (car args))
+        (body (cdr args)) )
+    (lambda **args**
+      (let ((new-env (make-call-environment params **args** env)))
+        (last (map (lambda (x) (myeval x new-env scheduler)) body)) ))))
+
+
+(define (macro-let args env scheduler)
+  (let ((vars (map car (car args)))
+        (vals (map cadr (car args)))
+        (body (cdr args)) )
+    (myeval `((lambda ,vars ,@body) ,@vals) env scheduler) ))
+
+
+(define (macro-define args env scheduler)
+  (if (pair? (car args))
+      (macro-define `(,(caar args) (lambda ,(cdar args) ,@(cdr args)))
+		    env scheduler )
+      (let ((val (myeval (cadr args) env scheduler)))
+        (env-define! (car args) val env scheduler) )))
+
+
+(define (macro-set! args env scheduler)
+  (let ((val (myeval (cadr args) env scheduler)))
+    (env-set! (car args) val env scheduler) ))
+
+
+(define (macro-quote args env scheduler)
+  (car args) )
+
+
+(define (macro-if args env scheduler)
+  (if (myeval (car args) env scheduler)
+      (myeval (cadr args) env scheduler)
+      (if (pair? (cddr args))
+	  (myeval (caddr args) env scheduler)
+	  'okay )))
+
+
+(define (macro-cond args env scheduler)
+  (cond ((null? args) 'okay)
+        ((or (eq? (caar args) 'else)
+             (myeval (caar args) env scheduler) )
+         (car (last-pair (eval-seq (cdar args) env scheduler))) )
+        (else (macro-cond (cdr args) env scheduler)) ))
+
+
+(define (macro-and args env scheduler)
+  (if (null? args)
+      #t
+      (let ((val (myeval (car args) env scheduler)))
+        (if (null? (cdr args))
+            val
+            (and val (macro-and (cdr args) env scheduler)) ))))
+
+
+(define (macro-or args env scheduler)
+  (if (null? args)
+      #f
+      (let ((val (myeval (car args) env scheduler)))
+        (if (null? (cdr args))
+            val
+            (or val (macro-or (cdr args) env scheduler)) ))))
+
+
+(define (prim-set-car! args scheduler)
+  (call/cc scheduler)
+  (apply set-car! args) )
+
+
+(define (prim-set-cdr! args scheduler)
+  (call/cc scheduler)
+  (apply set-cdr! args) )
+
+
+(define (prim-begin args scheduler)
+  (car (last-pair args)) )
+
+
+(define (prim-test-and-set! args scheduler)
+  (call/cc scheduler)
+  (test-and-set! (car args)) )
+
+
+(define (test-and-set! x)
+  (let ((oldval (car x)))
+    (set-car! x #t)
+    oldval ))
+
+
+(define (last-pair lst)
+  (if (null? (cdr lst))
+      lst
+      (last-pair (cdr lst)) ))
+
+
+(load "~cs61a/lib/serial.scm")