#lang racket ;;; exo_16_14_10.rkt : solution de l'exercice page 375 ;;; Examen L3-Info, Nice, 2006 ;;; Livre "Premiers Cours de Programmation avec Scheme" (Ellipses Ed, 2010) ;;; ::= NUM | IDENT | BOOL | | ;;; ::= (if0 ) | (function (IDENT ...) ) | (with ((IDENT ::= ( ...) ;;; Un langage purement fonctionnel en liaison statique avec un syntaxe tres reduite. ;;; Les seules primitives arithmetiques sont + et -, avec un (ifO p q r). ;;; Un environnement est une simple A-liste geree en pile. Pas de tables de hash-code. (define $global-env `((+ (*prim* ,+)) (- (*prim* ,-)))) ; l'evaluateur en liaison statique (define (main-static) (define ($eval expr env) (cond ((or (number? expr) (boolean? expr)) expr) ((symbol? expr) (let ((try (assoc expr env))) (if try (cadr try) (error "Unbound identifier" expr)))) ((equal? 'function (car expr)) (list '*closure* (cadr expr) (caddr expr) env)) ; fermetures ! ((equal? 'if0 (car expr)) (if (= 0 ($eval (cadr expr) env)) ($eval (caddr expr) env) ($eval (cadddr expr) env))) ((equal? 'with (car expr)) ($eval `((function ,(map car (cadr expr)) ,(caddr expr)) ,@(map cadr (cadr expr))) env)) ; macro-expansion ! (else ($apply ($eval (car expr) env) (map (lambda (x) ($eval x env)) (cdr expr)))))) (define ($apply proc Largs) (if (and (pair? proc) (equal? (car proc) '*prim*)) ((cadr proc) (car Largs) (cadr Largs)) ($eval (caddr proc) (append (map list (cadr proc) Largs) (cadddr proc))))) (define (toplevel) (printf "? ") (let ((expr (read))) (when (not (equal? expr 'quit)) (printf "= ~a~n" ($eval expr $global-env)) (toplevel)))) (let ((L '((with ((x 1) (y 2)) (+ x y)) (with ((x 1) (y 2)) (if0 x #t #f)) (with ((x 1) (y 2)) (+ 1 (if0 x (+ y 1) (- y 1)))) (with ((x 1) (y 2)) +) (with ((x 1) (y 2)) (function () (+ x 1))) (with ((x 1) (y 2)) (function (f) (f x))) (with ((a 1)) (with ((f (function (x) (+ x a)))) (with ((a 1000)) (f a)))) (with ((x 1) (y 2)) ((function (x) (if0 x 0 (+ x 1))) (+ y 1))) (with ((x 1) (y 2)) (+ (with ((x (+ y 1))) (+ x 1)) x))))) (for-each (lambda (x) (printf "? ~a~n= ~a~n" x ($eval x $global-env))) L) ; tests automatiques en prelude (toplevel))) (printf "LIAISON STATIQUE :\n") (main-static) ; l'evaluateur en liaison dynamique (define (main-dynamic) (define ($eval expr env) (cond ((or (number? expr) (boolean? expr)) expr) ((symbol? expr) (let ((try (assoc expr env))) (if try (cadr try) (error "Unbound identifier" expr)))) ((equal? 'function (car expr)) (list '*function* (cadr expr) (caddr expr))) ; plus de env ! ((equal? 'if0 (car expr)) (if (= 0 ($eval (cadr expr) env)) ($eval (caddr expr) env) ($eval (cadddr expr) env))) ((equal? 'with (car expr)) ($eval `((function ,(map car (cadr expr)) ,(caddr expr)) ,@(map cadr (cadr expr))) env)) ; macro-expansion ! (else ($apply ($eval (car expr) env) (map (lambda (x) ($eval x env)) (cdr expr)) env)))) (define ($apply proc Largs env) ; env dynamique !! (if (and (pair? proc) (equal? (car proc) '*prim*)) ((cadr proc) (car Largs) (cadr Largs)) ($eval (caddr proc) (append (map list (cadr proc) Largs) env)))) ; on etend env et non l'env. de compilation ! (define (toplevel) (printf "? ") (let ((expr (read))) (when (not (equal? expr 'quit)) (printf "= ~a~n" ($eval expr $global-env)) (toplevel)))) (let ((L '((with ((x 1) (y 2)) (+ x y)) (with ((x 1) (y 2)) (if0 x #t #f)) (with ((x 1) (y 2)) (+ 1 (if0 x (+ y 1) (- y 1)))) (with ((x 1) (y 2)) +) (with ((x 1) (y 2)) (function () (+ x 1))) (with ((x 1) (y 2)) (function (f) (f x))) (with ((a 1)) (with ((f (function (x) (+ x a)))) (with ((a 1000)) (f a)))) (with ((x 1) (y 2)) ((function (x) (if0 x 0 (+ x 1))) (+ y 1))) (with ((x 1) (y 2)) (+ (with ((x (+ y 1))) (+ x 1)) x))))) (for-each (lambda (x) (printf "? ~a~n= ~a~n" x ($eval x $global-env))) L) ; tests automatiques en prelude (toplevel))) (printf "LIAISON DYNAMIQUE :\n") (main-dynamic)