#lang racket ;;; chap16-exos.rkt - Les sources incompletes du chapitre 16 (Interprétation d'un sous-ensemble de Scheme) ;;; Livre PCPS : "Premiers Cours de Programmation avec Scheme" ;;; Langage determine par le source ;;; Completez ce fichier en resolvant les exercices 16.14.2 --> 16.14.7 ;;; Les solutions sont dans le fichier chap16-sol.rkt ;;; 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) en liaison statique ;;; ********** Implementation avec listes non mutables, et tables de hash-code *********** ;;; GESTION DES ENVIRONNEMENTS ;;; Un environnement sera une liste de dictionnaires. ;;; Un dictionnaire sera une table de hash-code {variable/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) '.....) ((hash-has-key? (car env) var) '.....) ; exo 16.14.2 (else '.....))) (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 ,>=) ($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 (%eval (car expr) env) (%evlis (cdr expr) env))))) ; liaison statique ! (define (%constant? expr) (or (number? expr) (boolean? expr))) (define %special? (let ((L '($if $lambda $let $letrec $set! $begin $define))) (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 (cdr expr) env)) (($set!) (%eval-set! expr env)) (($define) (%eval-define expr env)) (else (error "Forme speciale inconnue" (mcar 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 (%apply proc Lvals) (cond ((%primitive? proc) ; si proc est une primitive hard, elle est traitee en interne sans environnement (%apply-internal proc Lvals)) ((%closure? proc) ; si proc est une fermeture (closure Lparams body env) (%apply-closure proc Lvals)) (else (error '%apply "Bug : fonction impossible a appliquer : ~a" proc)))) (define (%apply-internal proc Lvals) (let ((arity (cadr proc)) (internal-code (caddr proc))) (case arity ((1) (internal-code (car Lvals))) ; on évite apply... ((2) (internal-code (car Lvals) (cadr Lvals))) (else (error '%apply-internal "Nombre d'arguments incorrect : ~a" proc))))) (define (%apply-closure proc Lvals) (let ((Lparams (cadr proc)) ; la liste des paramètres (body (caddr proc)) ; l'expression formant le corps (envcomp (cadddr proc))) ; l'environnement de compilation (%eval body (%extend-env Lparams Lvals envcomp)))) ;;; ================== LA CONDITIONNELLE IF =================================== ;;; Forme speciale : la conditionnelle (if p q r) avec else optionnel ! ;(define (%eval-if expr env) ; version classique ; (if (%eval (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 (%eval p env) (%eval q env) (%eval r env))) ((list '$if p q) (if (%eval 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... Exo 16.14.3 (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 '.....))) ;;; ================== 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))) ; Exo 16.14.4 (Lfunc (map cadr (cadr expr))) (body (cddr expr))) (let ((new-env (%extend-env '.....))) '.....))) ;;; ======================= LE SEQUENCEMENT ============================================ (define (%eval-begin Lexpr env) ; Lexpr == (e1 e2 ...) Exo 16.14.5 '.....) ;;; ========================= L'AFFECTATION ============================================ (define (%eval-set! expr env) ; expr == ($set! var e) Exo 16.14.6 (let ((var (cadr expr)) (e (caddr expr))) (if (not (symbol? var)) (error '.....) '.....))) ;;; ================== 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 '%eval-define "$define uniquement dans l'environnement global : ~a" 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) ; la bibliotheque initiale Exo 16.14.7 (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)))) '..... ) ;;; ================== LE TOPLEVEL =============================================== ;;; Le toplevel est une boucle [presque] infinie, alias REP [Read-Eval-Print] loop. (define (%miss) (printf "Miss Is (almost) a Subset of 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))]) (%print (%eval (%read) %global-env)) (%rep-loop))) ; Rajoutez une commande quit au toplevel pour quitter, pas une fonction (quit) ! ; Je tape simplement le mot quit et l'interprete quitte. Ce mot quit n'est reconnu que sous la boucle toplevel. (define (%read) ; un prompt special pour MISS (printf "? ") (read)) (define (%print val) ; largement modifiable suivant le type de valeur a afficher (when (not (void? val)) (printf "--> ~a\n" val))) ;;; 5-4-3-2-1 Ignition ! (require mzlib/trace) ;(trace %apply) ;(trace %eval) ;(trace %lookup) (%miss)