;;; tp11a.rkt - A completer en TP...
;;; (jpr) Fac. Sciences de Nice, L3-INFORMATIQUE
;;; Ne pas lire "Premiers Cours de Programmation avec Scheme" (Ellipses 2010), chap. 16.

;;; 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.

#lang racket 

(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 (%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 (%dict var env)                     ; le premier dictionnaire de env contenant var
  (error '%dict "Not yet implemented !"))

(define (%extend-env Lvar Lval env)
  (error '%extend-env "Not yet implemented !"))

(define (%extend-dict! var val dict)        ; ajout de var/val au dictionnaire dict
  (error '%extend-dict! "Not yet implemented !"))

(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 #<primitive:+>)
  (let ((Lprims `(($+      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 ((SPECIALS '($if $lambda $let $letrec $set! $begin $define)))
    (lambda (expr) (member (car expr) SPECIALS))))

(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)
  (error '%evlis "Not yet implemented !"))

;;; ================== 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 "Bug : fonction impossible a appliquer" 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 "Nombre d'arguments incorrect" proc)))))

(define (%apply-closure proc Lvals)    ; application d'une fermeture ! Liaison statique...
  (error '%apply-closure "Not yet implemented !"))   

;;; ==================  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)))

  
;;; ================== 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]) où r est optionnel
  (match expr
    ((list '$if p q r) (error '%eval-if "Not yet implemented !"))
    ((list '$if p q) (error '%eval-if "Not yet implemented !"))))

;;; ================== 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 (error '%eval-let "Not fully implemented !"))))

;;; ==================  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. l'article THE WHY OF Y de Gabriel, sur le Web]...
;;; ($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)))
      (error '%eval-letrec "Not fully implemented !"))))

;;; ================== 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)
        (error '%eval-define "Not fully implemented !"))))

;;; =======================  LE SEQUENCEMENT ============================================

(define (%eval-begin Lexpr env)      ; Lexpr == (e1 e2 ...)
  (error '%eval-begin "Not fully implemented !"))

;;; =========================  L'AFFECTATION ============================================

(define (%eval-set! expr env)       ; expr == ($set! var e)
  (let ((var (cadr expr)) (e (caddr expr)))
    (if (not (symbol? var))
        (error "$set! expected a symbol !" expr)
        (error '%eval-set! "Not fully implemented !"))))

;;; ================== EXTENSION "SOFT" DE L'ENVIRONNEMENT GLOBAL ===============
;;; Ajout de fonctions primitives "soft"  [ecrites en Scheme] dans $global-dict. 

(define (%install-software)            ; la bibliotheque initiale
  (define (install-def! expr)
    (error '%install-software "Not fully implemented !"))
  (install-def! `($define $pi ,(acos -1)))   ; melange de MIPS et de Scheme !
  (install-def! `($define $sub1 ($lambda (x) ($- x 1))))
  (install-def! '($define $fac ...))
  ; ........
  )

;;; ================== LE TOPLEVEL ===============================================
;;; Le toplevel est une boucle [presque] infinie, alias REP [Read-Eval-Print] loop.

(define (%mips)
  (printf "MIPS Is (almost) a Pseudo Scheme !\n")
  (printf "Primitives and special forms are prefixed by '$'.\n")
  (%init-global-env)
  (%install-software)
  ;(%dump-env "$GLOBAL-ENV" %global-env)
  (%rep-loop))

(define (%rep-loop)   ; on pourrait rajouter une "commande" .quit au toplevel...
  (with-handlers ([exn:fail? (lambda (e) (printf "MIPS error : ~a\n" (exn-message e)) (%rep-loop))])
    (%print (%eval (%read) %global-env))
    (%rep-loop)))

(define (%read)
  (printf "[MIPS] ? ")
  (read))

(define (%print val)
  (when (not (void? val))
    (printf "--> ~a\n" val)))    ; en le guidant par le type des objets a afficher !

;(require mzlib/trace)
;(trace %apply)
;(trace %eval)
;(trace %lookup)

;;; 5-4-3-2-1 Ignition ! 
(%mips)