From 562a9a52d599d9a05f871404050968a5fd282640 Mon Sep 17 00:00:00 2001 From: elioat Date: Wed, 23 Aug 2023 07:52:19 -0400 Subject: * --- .../~bh/61a-pages/Lib/concurrent.scm | 245 +++++++++++++++++++++ 1 file changed, 245 insertions(+) create mode 100644 js/games/nluqo.github.io/~bh/61a-pages/Lib/concurrent.scm (limited to 'js/games/nluqo.github.io/~bh/61a-pages/Lib/concurrent.scm') 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") -- cgit 1.4.1-2-gfad0