#lang racket ;;; lazy-miss.rkt - Les sources de la section 17.4.3 ;;; Livre PCPS : "Premiers Cours de Programmation avec Scheme" ;;; Langage determine par le source ;;; Un evaluateur d'un langage arithmetique avec environnement modele sur Scheme. ;;; Sans les continuations mais avec possibilite de CPS puisqu'avec fermetures. ;;; (%eval expr env) avec evaluation paresseuse ;;; GESTION DES ENVIRONNEMENTS ;;; Un environnement sera une liste de dictionnaires. ;;; Un dictionnaire sera une liste de couples (symbole . valeur). ;;; Le dictionnaire global se nomme %global-dict et l'environnement global se nomme %global-env. ;;; %global-env est donc a l'origine une liste dont le seul element est %global-dict. (define %global-env '()) ; un environnement est une liste de dictionnaires (define %global-dict '?) ; un dictionnaire est une table de hash (define (%new-dictionnary Lvar Lval) ; resultat : une nouvelle table de hash-code mutable (let ((H (make-hash))) (do ((Lvar Lvar (cdr Lvar)) (Lval Lval (cdr Lval))) ((null? Lvar) H) (hash-set! H (car Lvar) (car Lval))))) (define (%extend-env Lvar Lval env) (cons (%new-dictionnary Lvar Lval) env)) (define (%dict var env) ; le premier dictionnaire de env contenant var (cond ((null? env) #f) ((hash-has-key? (car env) var) (car env)) (else (%dict var (cdr env))))) (define (%lookup var env) ; valeur de var dans env ou erreur (let ((dict (%dict var env))) (if dict (hash-ref dict var) (error "Variable MISS inconnue : " var)))) (define (%extend-dict! var val dict) ; ajout de var/val au dictionnaire dict (hash-set! dict var val)) (define (%dump-env title env) ; pour le debug ;-) (printf "### ~a == ~a~n" title env)) (define (%init-global-env) ; la primitive binaire $+ aura pour valeur dans la hash-table $global-dict ; (prim 2 #) (let ((Lprims `(($+ prim 2 ,+) ($- prim 2 ,-) ($* prim 2 ,*) ($/ prim 2 ,/) ($= prim 2 ,=) ($< prim 2 ,<) ($<= prim 2 ,<=) ($> prim 2 ,>) ($>= prim 2 ,>=) ($null? prim 1 ,null?) ($display prim 1 ,display) ;($printf2 prim 2 ,(lambda (str obj) (printf str obj))) ($zero? prim 1 ,zero?)))) (set! %global-env (%extend-env (map car Lprims) (map cdr Lprims) %global-env)) ; qui est vide au depart ! (set! %global-dict (car %global-env)))) ; et qui a maintenant un seul dictionnaire ! (define (%primitive? proc) (and (pair? proc) (equal? (car proc) 'prim))) ;;; ================== LA FONCTION EVAL STATIQUE ================= (define (%eval expr env) (cond ((%constant? expr) expr) ((symbol? expr) (%lookup expr env)) ((%special? expr) (%eval-special expr env)) (else (%apply (%force (car expr) env) (cdr expr) env)))) ; paresse ! (define (%constant? expr) (or (number? expr) (boolean? expr) (string? expr) (null? expr))) (define %special? (let ((L '($if $lambda $let $letrec $begin $define $quote))) ; pour ne pas la recalculer ! (lambda (expr) (member (car expr) L)))) (define (%eval-special expr env) (case (car expr) (($if) (%eval-if expr env)) (($lambda) (%eval-lambda expr env)) (($let) (%eval-let expr env)) (($letrec) (%eval-letrec expr env)) (($begin) (%eval-begin expr env)) (($define) (%eval-define expr env)) (else (error "Forme speciale inconnue" (car expr))))) (define (%evlis Lexpr env) (if (null? Lexpr) Lexpr (cons (%eval (car Lexpr) env) (%evlis (cdr Lexpr) env)))) ;;; ================== L'ABSTRACTION FONCTIONNELLE LAMBDA ============================= ;;; Forme speciale : l'abstraction fonctionnelle [une terminologie de lambda-calcul pour ;;; designer les lambda-expressions. La valeur d'une lambda-expression est une fermeture, ;;; en anglais "closure". Elle est ici representee par une liste: ;;; (closure Lparams corps env) ;;; ou env pointe vers l'environnement lexical de la fermeture [environnement de compilation], ;;; On force un $begin dans une suite d'instructions, donc on le rend optionnel ;;; pour le programmeur. (define (%eval-lambda expr env) ; expr == ($lambda (x ...) e1 e2 ...) (let ((Lparams (cadr expr)) (body (cddr expr))) (list 'closure Lparams (cons '$begin body) env))) (define (%closure? proc) (and (pair? proc) (equal? (car proc) 'closure))) ;;; ================== L'APPLICATEUR FONCTIONNEL APPLY ============================== (define (%force expr env) (let ((val (%eval expr env))) (if (%delayed? val) (%force (cadr val) (caddr val)) val))) (define (%delay expr env) (list 'delayed expr env)) (define (%delayed? obj) (and (pair? obj) (equal? (car obj) 'delayed))) (define (%apply proc Largs env) (cond ; si proc est une primitive hard, elle est traitee en interne sans environnement: ((%primitive? proc) (%apply-internal proc (map (lambda (e) (%force e env)) Largs))) ; strict ! ; si proc est une fermeture (closure Lparams body env): ((%closure? proc) (%apply-closure proc (map (lambda (e) (%delay e env)) Largs) env)) ; lazy ! (else (error "Bug : valeur impossible a appliquer" proc)))) (define (%apply-closure proc Lvals env) (let ((Lparams (cadr proc)) (body (caddr proc)) (envcomp (cadddr proc))) (%eval body (%extend-env Lparams Lvals envcomp)))) (define (%apply-internal proc Largs) ; proc == (*prim* 2 #) par ex. (let ((arity (cadr proc)) (internal-code (caddr proc))) (case arity ((1) (internal-code (car Largs))) ; on evite apply pour le purisme... ((2) (internal-code (car Largs) (cadr Largs))) (else (error "Nombre d'arguments incorrect" proc))))) ;;; ================== LA CONDITIONNELLE IF =================================== ;;; Forme speciale : la conditionnelle (if p q r) avec else optionnel ! ;(define (%eval-if expr env) ; expr == ($if p q [r]) ; (if (%force (cadr expr) env) ; (%eval (caddr expr) env) ; (if (not (null? (cdddr expr))) ; (%eval (cadddr expr) env) ; #f))) (define (%eval-if expr env) ; expr == ($if p q [r]) (match expr ((list '$if p q r) (if (%force p env) (%eval q env) (%eval r env))) ((list '$if p q) (if (%force p env) (%eval q env) #f)))) ;;; ================== LES VARIABLES LOCALES =================================== ;;; Forme speciale : les variables locales sont traitees en interne via la forme ;;; let en l'absence d'une etape de macro-expansion qui la ramenerait a une simple ;;; application de lambda-expression... (define (%eval-let expr env) ; expr == ($let ((var val) ...) e1 e2 ...) (let ((Lvars (map car (cadr expr))) (Lvals (map cadr (cadr expr))) (body (cddr expr))) (%eval (cons '$begin body) (%extend-env Lvars (%evlis Lvals env) env)))) ;;; ================== LA MUTUALITE RECURSIVE ============================================ ;;; Forme speciale letrec : les fonctions locales mutuellement recursives sont ;;; traitees en interne via la forme letrec bien qu'on pourrait definir en Scheme un ;;; "operateur de point fixe" comme en lambda-calcul [voir l'operateur Y dans la ;;; litterature concernee, par ex. Chazarain page 607]... ;;; ($letrec ((fac ($lambda (n) ($if ($= n 0) 1 ($* n (fac ($- n 1))))))) (fac 5)) (define (%eval-letrec expr env) ; expr == ($letrec ((f e) ...) e1 e2 ...) (let ((Lvars (map car (cadr expr))) (Lfunc (map cadr (cadr expr))) (body (cddr expr))) (let ((new-env (%extend-env Lvars (map (lambda (f) '?) Lfunc) env))) (let ((Lvals (map (lambda (arg) (%eval arg new-env)) Lfunc))) (for-each (lambda (var proc) (%extend-dict! var proc (car new-env))) Lvars Lvals) (%eval (cons '$begin body) new-env))))) ;;; ======================= LE SEQUENCEMENT ============================================ (define (%eval-begin expr env) ; expr == ($begin e1 e2 ...) (define (iter Lexpr) (let ((val (%eval (car Lexpr) env))) (if (null? (cdr Lexpr)) val (iter (cdr Lexpr))))) (if (null? (cdr expr)) (error "($begin) interdit !") (iter (cdr expr)))) ;;; L'affectation a disparu. Sa signification dans un univers de valeurs retardees ;;; n'est pas assez claire. Haskell par exemple est purement fonctionnel... ;;; ================== LA DEFINITION AU TOPLEVEL ================================= ;;; Forme speciale : la definition n'est admise qu'au toplevel. Elle introduit une ;;; nouvelle variable dans l'environnement GLOBAL. Si cette variable existe deja ;;; il s'agit simplement d'une affectation. Les define internes ne sont pas autorises, ;;; utilisez letrec ! ;;; ($define x ($begin ($define y 3) ($+ y 1))) est admis au toplevel ;;; ($define x ($begin ($define x 3) ($+ x 1))) est admis au toplevel ;;; ($let ((x 1)) ($define y ($+ x 3)) ($+ x y)) n'est pas admis ! (define (%eval-define expr env) ; expr == ($define var e) (let ((var (cadr expr)) (e (caddr expr))) (if (not (eq? env %global-env)) ; notez l'utilisation de eq? pour comparer des pointeurs ! (error "$define uniquement dans l'environnement global" expr) (%extend-dict! var (%eval e env) %global-dict)))) ;;; ================== EXTENSION "SOFT" DE L'ENVIRONNEMENT GLOBAL =============== ;;; Ajout de fonctions primitives "soft" [ecrites en Scheme] dans $global-dict. (define (%install-software) (define (install-def! expr) (%eval expr %global-env)) (install-def! `($define $pi ,(acos -1))) ; melange de Miss et de Scheme ! (install-def! `($define sub1 ($lambda (x) ($- x 1)))) (install-def! `($define $null ,null)) (install-def! '($define $cons ($lambda (a b) ($lambda (p) ($if p a b))))) (install-def! '($define $car ($lambda (c) (c #t)))) (install-def! '($define $cdr ($lambda (c) (c #f)))) (install-def! '($define $take ($lambda (n L) ($if ($= n 0) $null ($cons ($car L) ($take ($- n 1) ($cdr L))))))) (install-def! '($define $map ($lambda (f L) ($cons (f ($car L)) ($map f ($cdr L)))))) (install-def! '($define $map2 ($lambda (f L1 L2) ($cons (f ($car L1) ($car L2)) ($map2 f ($cdr L1) ($cdr L2)))))) (install-def! '($define $print-list ($lambda (L) ($letrec ((aux ($lambda (L) ($if ($null? L) ($display " >\n") ($begin ($display ($car L)) ($display " ") (aux ($cdr L))))))) ($display "< ") (aux L))))) (install-def! '($define FIBS ($cons 0 ($cons 1 ($map2 $+ FIBS ($cdr FIBS))))))) ;;; ================== LE TOPLEVEL =============================================== ;;; Le toplevel est une boucle [presque] infinie, alias REP [Read-Eval-Print] loop. (define (%lazy-miss) (printf "Miss Is (almost) a Susbset of lazy Scheme !\n") (%init-global-env) (%install-software) ;(%dump-env "$GLOBAL-ENV" %global-env) (%rep-loop)) (define (%rep-loop) (with-handlers ([exn:fail? (lambda (e) (printf "Miss error : ~a\n" (exn-message e)) (%rep-loop))]) (let ((expr (%read))) (if (equal? expr 'quit) 'bye (begin (%print (%force expr %global-env)) (%rep-loop)))))) (define (%read) (printf "[lazy]? ") (read)) (define (%print val) ; idem, sauf qu'on doit cette fois largement le modifier en Scheme (cond ((%closure? val) (printf "--> #\n")) ((%delayed? val) (printf "--> #\n")) (else (printf "--> ~a\n" val)))) ; en le guidant par le type des objets a afficher ! ;;; 5-4-3-2-1 Ignition ! (%lazy-miss) ; Exemple : ; ($print-list ($take FIBS 15)) ; ($define L ($cons 1 L)) ; ($print-list ($take L 10)) ; ($define f ($lambda (x y) x)) ; (f 1 (/ 1 0))