8 Continuations (suite)
Où l'on approche du dénouement. Bonne continuation!
Calculette
On définit le petit langage formé des expressions suivantes:
e := (+ e e) |
(- e e) |
(* e e) |
nombre |
(STO e) |
(RCL) |
(PRINT e)
Sa sémantique est celle d'une calculette avec imprimante et dotée
d'une unique mémoire. La mémoire est initialement vide et ne peut
être lue avant d'être écrite. Voici un exemple d'emploi
de cette calculette.
? (CALCULETTE1 '(* (STO 3) (PRINT (+ (RCL) 5))))===> 8
= 24
Exercice 71 : Écrire une fonction d'évaluation exécutant de telles
expressions. Analyser les continuations en jeu et leur signature.
Solution de l'exercice 71 : On pourrait bien sûr faire de la mémoire une variable locale
lue par RCL et affectée par STO. Nous emploierons toutefois des
continuations.
;;;
(define (calculette1 e)
(define (execute e s k)
(cond
((number? e) (k e s))
((pair? e)
(case (car e)
((+) (execute (cadr e) s
(lambda (r1 s1)
(execute (caddr e) s1
(lambda (r2 s2)
(k (+ r1 r2) s2) ) ) ) ))
((-) (execute (cadr e) s
(lambda (r1 s1)
(execute (caddr e) s1
(lambda (r2 s2)
(k (- r1 r2) s2) ) ) ) ))
((*) (execute (cadr e) s
(lambda (r1 s1)
(execute (caddr e) s1
(lambda (r2 s2)
(k (* r1 r2) s2) ) ) ) ))
((STO) (execute (cadr e) s
(lambda (r ss)
(k r r) ) ))
((RCL) (if s (k s s) (error 'calculette "Memoire non initialisee")))
((PRINT) (execute (cadr e) s
(lambda (r ss)
(display "===> ")(display r)(newline)
(k r ss) ) )) ) ) ) )
(execute e #f (lambda (r s) r)) )
Exercice 72 : On ajoute à la grammaire précédente l'expression (EITHER
e e) qui permet de continuer les calculs en cours soit avec la
valeur du premier argument, soit avec la valeur du second argument. La
mémoire n'est pas partagée bien qu'initialement la même et peut
évoluer au gré de chacun de ces deux calculs. Par exemple,
? (CALCULETTE2
'(PRINT (* (STO (EITHER 3 5)) (EITHER (RCL) 11))))===> 9
===> 33
===> 25
===> 55
= 55
Solution de l'exercice 72 :
(define (calculette2 e)
(define (execute e s k)
(cond
((number? e) (k e s))
((pair? e)
(case (car e)
((+) (execute (cadr e) s
(lambda (r1 s1)
(execute (caddr e) s1
(lambda (r2 s2)
(k (+ r1 r2) s2) ) ) ) ))
((-) (execute (cadr e) s
(lambda (r1 s1)
(execute (caddr e) s1
(lambda (r2 s2)
(k (- r1 r2) s2) ) ) ) ))
((*) (execute (cadr e) s
(lambda (r1 s1)
(execute (caddr e) s1
(lambda (r2 s2)
(k (* r1 r2) s2) ) ) ) ))
((STO) (execute (cadr e) s
(lambda (r ss)
(k r r) ) ))
((RCL) (if s (k s s) (error 'calculette "Memoire non initialisee")))
((EITHER) (execute (cadr e) s k)
(execute (caddr e) s k) )
((PRINT) (execute (cadr e) s
(lambda (r ss)
(display "===> ")(display r)(newline)
(k r ss) ) )) ) ) ) )
(execute e #f (lambda (r s) r)) )
Exercice 73 : On aimerait maintenant que les calculs ``parallèles'' introduits par
either soient menés de façon entrelacée. C'est ce
qu'illustre la trace suivante où l'on a tracé les expressions
calculées et leur résultat.
? (CALCULETTE3
'(PRINT (* (STO (EITHER 3 5)) (EITHER (RCL) 11))))<<< (PRINT (* (STO (EITHER 3 5)) (EITHER (RCL) 11)))
<<< (* (STO (EITHER 3 5)) (EITHER (RCL) 11))
<<< (STO (EITHER 3 5))
<<< (EITHER 3 5)
<<< 3
<<< 5
>>> 3[memory= #f]
>>> 5[memory= #f]
>>> 3[memory= 3]
>>> 5[memory= 5]
<<< (EITHER (RCL) 11)
<<< (EITHER (RCL) 11)
<<< (RCL)
<<< 11
<<< (RCL)
<<< 11
>>> 3[memory= 3]
>>> 11[memory= 3]
>>> 5[memory= 5]
>>> 11[memory= 5]
>>> 9[memory= 3]
===> 9
>>> 33[memory= 3]
===> 33
>>> 25[memory= 5]
===> 25
>>> 55[memory= 5]
===> 55
>>> 9[memory= 3]
= 9
Solution de l'exercice 73 :
(define (calculette3 e)
;;
(define (display-state fn args)
(cond ((eq? fn execute)
(display "<<< ")
(display (car args))
(newline) )
(else (display ">>> ")
(display (car args))
(display "[memory= ")
(display (cadr args))
(display "]")
(newline) ) ) )
;;
(define threads '())
(define (schedule! fn . args)
(set! threads (append threads (list (cons fn args))))
(if (pair? threads)
(let* ((thread (car threads))
(fn (car thread))
(args (cdr thread)) )
(set! threads (cdr threads))
(display-state fn args)
(apply fn args) )
;;
'done ) )
(define (add-to-scheduler! fn . args)
(set! threads (append threads (list (cons fn args)))) )
;;
(define (execute e s k)
(cond
((number? e) (schedule! k e s))
((pair? e)
(case (car e)
((+) (schedule! execute (cadr e) s
(lambda (r1 s1)
(schedule! execute (caddr e) s1
(lambda (r2 s2)
(schedule! k (+ r1 r2) s2) ) ) ) ))
((-) (schedule! execute (cadr e) s
(lambda (r1 s1)
(schedule! execute (caddr e) s1
(lambda (r2 s2)
(schedule! k (- r1 r2) s2) ) ) ) ))
((*) (schedule! execute (cadr e) s
(lambda (r1 s1)
(schedule! execute (caddr e) s1
(lambda (r2 s2)
(schedule! k (* r1 r2) s2) ) ) ) ))
((STO) (schedule! execute (cadr e) s
(lambda (r ss)
(schedule! k r r) ) ))
((RCL) (if s (schedule! k s s)
(error 'calculette "Memoire non initialisee") ))
((EITHER) (add-to-scheduler! execute (cadr e) s k)
(schedule! execute (caddr e) s k) )
((PRINT) (schedule! execute (cadr e) s
(lambda (r ss)
(display "===> ")(display r)(newline)
(schedule! k r ss) ) )) ) ) ) )
(schedule! execute e #f (lambda (r s) r)) )
Entrelacement non préemptif
Exercice 74 : Définir la fonction (either expression...) en Scheme
même. Cette fonction crée autant de tâches qu'elle a d'arguments,
en retournant tour à tour tous ses arguments à sa continuation. On
programmera aussi la forme (suicide) qui fait disparaître la
tâche courante. Le calcul entier usant des formes either ou
suicide sera supposé enveloppé par la macro with-parallelism qui retournera la liste des résultats produits. C'est
ce que montrent les exemples suivants:
? (WITH-PARALLELISM (+ 1 (SUICIDE)))
= ()
? (WITH-PARALLELISM
(LET ()
(DEFINE (IOTA START STOP)
(IF (< START STOP)
(CONS START (IOTA (+ START 1) STOP))
'()))
(DEFINE (//IOTA START STOP)
(APPLY EITHER (IOTA START STOP)))
(LIST (//IOTA 0 9))))
= ((8) (7) (6) (5) (4) (3) (2) (1) (0))
Solution de l'exercice 74 :
(define-macro (with-parallelism . body)
(let ((add-to-scheduler! (gensym))
(call-scheduler (gensym))
(threads (gensym))
(results (gensym))
(result (gensym))
(return (gensym)) )
`(call/cc
(lambda (,return)
(letrec ((either (lambda args
(call/cc (lambda (k)
(for-each (lambda (arg)
(,add-to-scheduler! k arg) )
args )
(,call-scheduler) )) ))
;;
(suicide (lambda ()
(,call-scheduler) ))
(,results '())
(,threads '())
(,call-scheduler (lambda ()
(if (pair? ,threads)
(let ((thread (car ,threads)))
(set! ,threads (cdr ,threads))
(apply (car thread) (cdr thread)) )
(,return ,results) ) ))
(,add-to-scheduler!
(lambda (f . args)
(set! ,threads (append ,threads
(list (cons f args)) )) )) )
;;
(,add-to-scheduler!
(lambda ()
(let ((,result (begin . ,body)))
(set! ,results (cons ,result ,results))
(,call-scheduler) )
(suicide) ) )
(,call-scheduler) ) ) ) ) )
Exercice 75 : Plutôt que either soit une fonction, on préfererait la
remplacer par une macro parallel. On introduira aussi une
fonction (yield) qui permet de suspendre la tâche en cours et
de redonner la main à l'ordonnanceur. Ceci permet d'introduire plus
d'asynchronisme entre tâches comme le montre l'exemple suivant:
? (WITH-PARALLELISM2
(LET ()
(DEFINE (WALK TREE)
(IF (PAIR? TREE)
(PARALLEL (WALK (CAR TREE)) (WALK (CDR TREE)))
(BEGIN (YIELD) (LIST TREE))))
(PARALLEL
(WALK '(A (B . C) ((D E) . F) . G))
(WALK '(((1 . 2) 3 (4 5) . 6) 7 8)))))
= ((()) (5) (()) (E) (4) (D) (6) (F) (()) (8) (3) (2) (1) (G) (C) (B) (7) (A))
Noter que si parallel avait été remplacé par either,
le parcours des arbres n'aurait pas été parallélisé. Voici
d'ailleurs une version révisée de //iota:
? (WITH-PARALLELISM2
(LET ()
(DEFINE (//IOTA START STOP)
(IF (< START STOP)
(PARALLEL START (//IOTA (+ START 1) STOP))
(SUICIDE)))
(LIST (//IOTA 0 9))))
= ((8) (7) (6) (5) (4) (3) (2) (1) (0))
Solution de l'exercice 75 :
(define-macro (with-parallelism2 . body)
(let ((add-to-scheduler! (gensym))
(call-scheduler (gensym))
(threads (gensym))
(results (gensym))
(result (gensym))
(return (gensym)) )
`(call/cc
(lambda (,return)
(letrec ((do-parallel
(lambda tasks
(call/cc
(lambda (k)
(map (lambda (task)
(,add-to-scheduler! task k) )
tasks )
(,call-scheduler) ) ) ) )
(suicide (lambda ()
(,call-scheduler) ))
(yield (lambda ()
(call/cc (lambda (k)
(,add-to-scheduler! k 'continue)
(,call-scheduler) )) ))
(,results '())
(,threads '())
(,call-scheduler (lambda ()
(if (pair? ,threads)
(let ((thread (car ,threads)))
(set! ,threads (cdr ,threads))
(apply (car thread) (cdr thread)) )
(,return ,results) ) ))
(,add-to-scheduler!
(lambda (f . args)
(set! ,threads (append ,threads
(list (cons f args)) )) )) )
(,add-to-scheduler!
(lambda ()
(let ((,result (begin . ,body)))
(set! ,results (cons ,result ,results))
(,call-scheduler) ) ) )
(,call-scheduler) ) ) ) ) )
Coroutines
Exercice 76 : Définir un système de coroutines. La forme (coroutine x
form...) crée une coroutine dont le point de contrôle
est supposé se trouver avant la première forme de son corps. La
fonction coroutine-resume ne peut être employée que depuis
le corps de la coroutine; elle prend une coroutine et une valeur, lie
cette dernière à la variable x, puis évalue le corps de la
coroutine à partir de son point de contrôle. La fonction coroutine-return ne peut, elle aussi, être employée que dans le
corps de la coroutine; elle prend un argument et le retourne comme
valeur à l'invoqueur de la coroutine. Lorsque les fonctions coroutine-resume ou coroutine-return sont invoquées, elles
mettent à jour le point de contrôle de la coroutine. Lorsqu'une
coroutine a invoqué coroutine-return, elle est considérée
comme épuisée et se comporte comme l'identité. Comme il faut
pouvoir lancer une coroutine en dehors de son corps, on crééra la
fonction coroutine-start pour ce faire. Voici un exemple
d'emploi:
? (LETREC ((C1 (COROUTINE
X
(DISPLAY X)
(DISPLAY (COROUTINE-RESUME C2 2))
(COROUTINE-RETURN 4)))
(C2 (COROUTINE
Y
(DISPLAY Y)
(DISPLAY (COROUTINE-RESUME C1 3))
(DISPLAY (COROUTINE-RESUME C1 5))
6)))
(COROUTINE-START C1 1))123
= 4
Solution de l'exercice 76 :
(define (coroutine-start c v)
(c v) )
(define-macro (coroutine variable . body)
(let ((value (gensym))
(return (gensym))
(behavior (gensym))
(self (gensym)) )
`(letrec ((,variable 'wait)
(,self (lambda (,value)
(set! ,variable ,value)
(coroutine-return (begin . ,body)) ))
(coroutine-resume
(lambda (c v)
(call/cc (lambda (k)
(set! ,self k)
(set! ,variable (c v))
(,self ,variable) ) )) )
(coroutine-return
(lambda (v)
(set! ,self (lambda (x) x))
v ) ) )
(lambda (x) (,self x)) ) ) )
Exercice 77 : À l'aide du système de coroutines précédent, écrire un
comparateur de frondaisons d'arbre. Ce prédicat retournera Vrai si
deux arbres ont les mêmes feuilles dans le même ordre. On ne
tiendra pas compte des listes vides. Ainsi:
? (SAME-FRINGE '(A B C) '((A . B) . C))(COMPARE A A)(COMPARE B B)(COMPARE C C)(COMPARE () (SENTINEL))
= #F
Solution de l'exercice 77 :
(define (same-fringe tree1 tree2)
(define (visit tree fn)
(define (walk tree)
(if (pair? tree)
(begin (walk (car tree))
(walk (cdr tree)) )
(if tree (fn tree)) ) )
(walk tree) )
(call/cc
(lambda (exit)
(letrec ((sentinel (list 'sentinel))
(c1 (coroutine void
(visit tree1 (lambda (leaf)
(coroutine-resume cmp leaf) ))
(coroutine-resume cmp sentinel) ))
(c2 (coroutine void
(visit tree2 (lambda (leaf)
(coroutine-resume cmp leaf) ))
(coroutine-resume cmp sentinel) ))
(cmp (coroutine leaf
(let find ((leaf1 (coroutine-resume c1 sentinel))
(leaf2 (coroutine-resume c2 sentinel)) )
(display (list 'compare leaf1 leaf2))
(if (eq? leaf1 leaf2)
(if (eq? leaf1 sentinel)
(exit #t)
(find (coroutine-resume c1 sentinel)
(coroutine-resume c2 sentinel) ) )
(exit #f) ) ) )) )
(coroutine-start cmp 'go) ) ) ) )
Entrelacement préemptif
Voici un interprète Scheme écrit avec des continuations. Tout
d'abord l'évaluateur et ses formes spéciales.
(define (evaluate e r k)
(if (atom? e)
(cond ((symbol? e) (k (lookup e r)))
(else (k e)) )
(let ((special (assq (car e) *specials*)))
(if (pair? special)
((cdr special) e r k)
(evaluate-application (car e) (cdr e) r k) ) ) ) )
(define *specials* '())
(define-macro (define-special call . body)
(let ((e (gensym)))
`(begin
(set! *specials*
(cons (cons ',(caar call)
(lambda (,e . ,(cdr call))
(apply (lambda ,(cdar call)
. ,body )
(cdr ,e) ) ) )
*specials* ) )
',(caar call) ) ) )
(define-special ((quote expression) r k)
(k expression) )
(define-special ((if condition consequent . alternant) r k)
(evaluate condition
r
(lambda (bool)
(if bool
(evaluate consequent r k)
(if (pair? alternant)
(evaluate (car alternant) r k)
(k nothing-particular) ) ) ) ) )
(define-special ((begin . forms) r k)
(evaluate-begin forms r k) )
(define-special ((set! variable form) r k)
(evaluate form
r
(lambda (v)
(k (update! variable r v)) ) ) )
(define-special ((lambda variables . body) r k)
(k (make-function variables body r)) )
(define (evaluate-application function arguments r k)
(evaluate function
r
(lambda (f)
(evaluate-arguments arguments
r
(lambda (v*)
(f k v*) ) ) ) ) )
Les itérateurs classiques:
(define (evaluate-begin forms r k)
(if (pair? forms)
(evaluate (car forms)
r
(if (pair? (cdr forms))
(lambda (v)
(evaluate-begin (cdr forms) r k) )
k ) )
(k nothing-particular) ) )
(define (evaluate-arguments arguments r k)
(if (pair? arguments)
(evaluate (car arguments)
r
(lambda (v)
(evaluate-arguments (cdr arguments)
r
(lambda (v*)
(k (cons v v*)) ) ) ) )
(k '()) ) )
La représentation des fonctions:
;;;
(define (make-function variables body r)
(lambda (k arguments)
(evaluate-begin body (extend r variables arguments) k) ) )
La représentation des environnements:
;;;
(define (lookup variable r)
(let ((binding (assq variable r)))
(if (pair? binding)
(cdr binding)
(wrong "No such binding" variable r) ) ) )
(define (update! variable r value)
(let ((binding (assq variable r)))
(if (pair? binding)
(let ((old (cdr binding)))
(set-cdr! binding value)
(if (eq? old uninitialized) value old) )
(wrong "No such binding" variable r value) ) ) )
(define (extend r variables values)
(cond
((pair? variables)
(if (pair? values)
(cons (cons (car variables) (car values))
(extend r (cdr variables) (cdr values)) )
(wrong "Missing argument" variables values) ) )
((null? variables)
(if (pair? values)
(wrong "Too much argument" values)
r ) )
((symbol? variables)
(cons (cons variables values) r) )
(else (wrong "Incorrect variable" variables)) ) )
;;;
(define r.init '())
Les définisseurs des variables globales de l'environnement initial:
(define-macro (definitial name . value)
`(begin (set! r.init
(cons (cons ',name
,(if (pair? value) (car value)
`uninitialized ) )
r.init ) )
',name ) )
(define-macro (defprimitive name primitive arity)
`(definitial ,name
(lambda (k args)
(if (= (length args) ,arity)
(k (apply ,primitive args))
(wrong "Incorrect arity for" ',name args) ) ) ) )
(define-macro (defnaryprimitive name primitive arity)
`(definitial ,name
(lambda (k args)
(if (>= (length args) ,arity)
(k (apply ,primitive args))
(wrong "Incorrect arity for" ',name args) ) ) ) )
Quelques définitions:
(defprimitive cons cons 2)
(defprimitive cdr cdr 1)
(defnaryprimitive + + 1)
(defnaryprimitive list
(lambda values values)
0 )
Enfin, comment lancer cet interprète:
(define (kScheme)
(evaluate (read) r.init display)
(kScheme) )
Exercice 78 : Définir la fonction apply dans cet interprète.
Solution de l'exercice 78 :
(definitial apply
(lambda (k values)
(define (listify arguments)
(if (pair? (cdr arguments))
(cons (car arguments) (listify (cdr arguments)))
(car arguments) ) )
(if (>= (length values) 2)
((car values) k (listify (cdr values)))
(wrong "Incorrect arity" 'apply) ) ) )
Exercice 79 : Définir la fonction call/cc dans cet interprète.
Solution de l'exercice 79 :
(definitial call/cc
(lambda (k args)
(if (= (length args) 1)
(let ((f (car args))
(kf (lambda (kk v*)
(if (= (length v*) 1)
(k (car v*))
(wrong "Incorrect arity for a continuation") ) )) )
(f k (list kf)) )
(wrong "Incorrect arity for" 'call/cc) ) ) )
Exercice 80 : Modifier l'évaluateur précédent de façon à identifier les
pas atomiques de calculs et à entrelacer ceux-ci afin de simuler un
pseudo-parallélisme.
Solution de l'exercice 80 : On définit d'abord un petit ordonnanceur:
;;;
(define (start-scheduler thunk)
(add-to-scheduler! thunk)
(call/cc (lambda (return)
(set! *return* return)
(call-scheduler!) )) )
(define *return* (lambda (x) x))
(define (add-to-scheduler! f . args)
(set! *threads* (append *threads* (list (cons f args)))) )
(define (call-scheduler!)
(if (pair? *threads*)
(let ((thread (car *threads*)))
(set! *threads* (cdr *threads*))
(apply (car thread) (cdr thread)) )
(*return* "No more threads to run") ) )
(define *threads* '())
Et on s'arrange pour que les appels à evaluate passent par
l'ordonnanceur.
;;;
(define (evaluate e r k)
(if (atom? e)
(cond ((symbol? e) (add-to-scheduler! k (lookup e r)))
(else (add-to-scheduler! k e)) )
(let ((special (assq (car e) *specials*)))
(if (pair? special)
(add-to-scheduler! (cdr special) e r k)
(add-to-scheduler! evaluate-application (car e) (cdr e) r k) ) ) )
(call-scheduler!) )
Exercice 81 : Ajouter à l'interprète précédent la forme parallel et la
fonction suicide. Voici un exemple d'emploi (noter le letrec
fait à la main puisque l'interprète n'a pas encore de macros):
? (KSCHEME1
'((LAMBDA (WALK)
(SET! WALK
(LAMBDA (TREE)
(IF (PAIR? TREE)
(PARALLEL (WALK (CAR TREE)) (WALK (CDR TREE)))
(IF (NULL? TREE) (SUICIDE) TREE))))
(PARALLEL
(WALK '(A (B . C) ((D E) . F) . G))
(WALK '(((1 . 2) 3 (4 5) . 6) 7 8))))
'WALK))kScheme= A
kScheme= 7
kScheme= B
kScheme= C
kScheme= G
kScheme= 1
kScheme= 2
kScheme= 3
kScheme= 8
kScheme= F
kScheme= 6
kScheme= D
kScheme= 4
kScheme= E
kScheme= 5
= "No more threads to run"
Solution de l'exercice 81 :
(defprimitive suicide
(lambda ()
(call-scheduler!) )
0 )
(define-special ((parallel . forms) r k)
(for-each (lambda (form)
(add-to-scheduler! evaluate form r k) )
forms )
(call-scheduler!) )
Exercice 82 : Ajouter à l'interprète précédent la forme future et la
fonction touch. Voici un exemple:
? (KSCHEME1
'((LAMBDA (FIB)
(SET! FIB
(LAMBDA (N)
(IF (< N 2)
N
((LAMBDA (FIBN-1 FIBN-2)
(+ (TOUCH FIBN-2) (TOUCH FIBN-1)))
(FUTURE (FIB (- N 1)))
(FUTURE (FIB (- N 2)))))))
(FIB 10))
'FIB))kScheme= 55
= "No more threads to run"
Solution de l'exercice 82 :
(define-special ((future form) r k)
(let ((box (list '*future* 'wait '())))
;;
(set-car! (cdr box) box)
(add-to-scheduler! evaluate
form
r
(lambda (v)
(set-car! (cdr box) v)
(for-each (lambda (task)
(add-to-scheduler! task v) )
(caddr box) )
(call-scheduler!) ) )
(add-to-scheduler! k box)
(call-scheduler!) ) )
(definitial touch
(lambda (k args)
(if (= 1 (length args))
(let ((box (car args)))
(if (and (pair? box) (eq? '*future* (car box)))
(begin
(if (eq? box (cadr box))
(set-car! (cddr box) (cons k (caddr box)))
(add-to-scheduler! k (cadr box)) )
(call-scheduler!) )
(wrong "Not a future" box) ) )
(wrong "Incorrect arity for" 'touch) ) ) )
Exercice 83 : Ajouter des canaux de communication à l'interprète. On introduira
les fonctions suivantes:
channel-create pour les créer, channel-send pour envoyer une valeur sur un canal et channel-receive pour lire une valeur dans un canal. Si une telle
valeur n'est pas présente, la tâche invocatrice est mise en
attente. Ces canaux sont assimilables à des tampons non bornés.
Solution de l'exercice 83 :
;;;
(defprimitive channel-create
(lambda ()
(vector '*channel* '() '()) )
0 )
(defprimitive channel-send
(lambda (c v)
(if (Channel? c)
(if (pair? (Channel-pending c))
(let ((k (car (Channel-pending c))))
(set-Channel-pending! c (cdr (Channel-pending c)))
(add-to-scheduler! k v) )
(begin
(set-Channel-values! c (append (Channel-values c) (list v)))
nothing-particular ) )
(wrong "Not a channel" c) ) )
2 )
(definitial channel-receive
(lambda (k args)
(if (= 1 (length args))
(let ((c (car args)))
(if (Channel? c)
(begin
(if (pair? (Channel-values c))
(let ((v (car (Channel-values c))))
(set-Channel-values! c (cdr (Channel-values c)))
(add-to-scheduler! k v) )
(set-Channel-pending!
c (append (Channel-pending c) (list k)) ) )
(call-scheduler!) )
(wrong "Not a channel" c) ) )
(wrong "Incorrect arity for" 'channel-receive) ) ) )
Exercice 84 : Ajouter à l'interprète la nouvelle forme qlambda qui assure
que son corps est évalué en exclusion mutuelle: aucune autre
invocation parallèle à la même fonction n'est possible.
Solution de l'exercice 84 : Cette forme pose un problème du fait des retours multiples dûs aux
continuations employées plusieurs fois.
(define-special ((qlambda variables . body) r k)
(k (make-qlambda-function variables body r)) )
(define (make-qlambda-function variables body r)
(let ((active? #f)
(queue '()) )
(lambda (k arguments)
(if active?
(set! queue (append queue (list (cons k arguments))))
(let enter ((k k) (arguments arguments))
(set! active? #t)
(add-to-scheduler! evaluate-begin
body
(extend r variables arguments)
(let ((exited? #f))
(lambda (v)
(if (not exited?)
(if (pair? queue)
(let ((k+args (car queue)))
(set! queue (cdr queue))
(add-to-scheduler!
enter (car k+args)
(cdr k+args) ) )
(set! active? #f) ) )
(set! exited? #t)
(k v) ) ) ) ) )
(call-scheduler!) ) ) )