;;; $Id: eval3fr.scm,v 1.1 2000/03/10 17:30:58 queinnec Exp $
;;; <Christian.Queinnec@lip6.fr>

;;; Le langage interprété comprend:
;;;  programme  := expression
;;;  expression := constante
;;;             |  variable
;;;             |  (COND clause...)
;;;             |  (QUOTE donnée)
;;;             |  (IF expression expression [ expression ])
;;;             |  (BEGIN expression...)
;;;             |  (LET (liaison...) definition... expression...)
;;;             |  (expression expression...)
;;;      clause := (expression expression...)
;;;             |  (ELSE expression...)
;;;   constante := nombre | chaîne | booléen
;;;      donnée := constante | symbole | liste
;;;       liste := ( donnée... )
;;;     liaison := (variable expression)
;;;  définition := (DEFINE (variable variable...) definition... expression...)

;;; Les types sont décrits avec la syntaxe suivante:
;;;    t* signifie séquence de t
;;;    void signifie que le résultat est inimportant
;;;    t1 * t2 est le produit cartésien de t1 et t2
;;;    les fonctions ont pour types t1 * t2 ... -> t
;;;    alpha, beta etc. sont des types quelconques
;;; Parmi les types prédéfinis, l'on trouve Expression, Valeur, 
;;; nat, int, float, bool.

;;; Ce fichier ne contient qu'une unique définition.
;;; La fonction deug-eval prend une expression et retourne sa valeur.
;;; Expression -> Valeur

(define (deug-eval e)

  ;; Utilitaires généraux 
  ;;---------------------
  ;; Nécessaire pour l'auto-amorçage (on pourrait également les placer
  ;; dans l'environnement initial).

  ;; Signaler une erreur et abandonner l'évaluation.
  (define (wrong who what which) 
    (error "DEUG-ERROR:" who what which) )
  ;; Retourner le second terme d'une liste (d'au moins deux termes).
  ;; alpha* -> alpha
  (define (cadr e) 
    (car (cdr e)) )
  ;; Retourner une liste privée de ses deux premiers termes.
  ;; alpha* -> alpha*
  (define (cddr e) 
    (cdr (cdr e)) )
  ;; Retourner le troisième terme d'une liste.
  ;; alpha* -> alpha
  (define (caddr e)
     (car (cdr (cdr e))))
  ;; Retourner une liste privée de ses trois premiers termes.
  ;; alpha* -> alpha*
  (define (cdddr e) 
    (cdr (cdr (cdr e))))
  ;; Retourner le quatrième terme d'une liste.
  ;; alpha* -> alpha
  (define (cadddr e)
     (car (cdr (cdr (cdr e)))))
  ;; Retourner la longueur d'une liste.
  ;; alpha* -> num
  (define (length es)
    (if (pair? es)
        (+ 1 (length (cdr es)))
        0 ) )
  ;; Retourner la liste des valeurs de f appliquée aux termes d'une liste.
  ;; (alpha -> beta) * alpha* -> beta*
  (define (map f l)
    (if (pair? l)
        (cons (f (car l)) (map f (cdr l)))
        '() ) )
  ;; Tester si une variable apparaît dans une liste de variables.
  ;; Variable * Variable* -> bool
  (define (member id ids)
    (if (pair? ids)
        (if (equal? id (car ids))
            #t
            (member id (cdr ids)) )
        #f ) )
  ;; Retourner le rang d'une variable dans une liste de variables où
  ;; elle apparaît. La première variable a pour rang zéro.
  ;; Variable * Variable* -> num
  (define (rank id ids)
    (if (pair? ids)
        (if (equal? id (car ids))
            0
            (+ 1 (rank id (cdr ids))) )
        (wrong 'rank "variable manquante" id) ) )

  ;; Expansion:
  ;;-----------
  ;; Transformation des conditionnelles (cond ..) en alternatives simples. 
  ;; Cela serait plus simple et plus compact avec la notation backquote.

  ;; Clause* -> Expression
  (define (expand-cond expressions)
    (if (pair? expressions)
        (let ((clause (car expressions)))
          ;; clause : Clause
          (if (equal? (clause-condition clause) 'else)
              (cons 'begin (clause-body clause))
              (cons 'if
                    (cons (car clause)
                          (cons (cons 'begin (clause-body clause))
                                (let ((seq (expand-cond (cdr expressions))))
                                  (if (pair? seq)
                                      (list seq)
                                      seq ) ) ) ) ) ) )
        '() ) )

  ;; Syntaxe:
  ;;--------
  ;; Ces fonctions permettent de manipuler les différentes expressions 
  ;; syntaxiques dont Scheme est formé. Pour chacune de ces différentes 
  ;; formes syntaxiques, on trouve le reconnaisseur et les sélecteurs.

  ;; Expression -> bool
  (define (variable? e)
    (symbol? e) )
  ;; Expression -> bool
  (define (quotation? e)
    (cond ((number? e)  #t)
          ((string? e)  #t)
          ((char? e)    #t)
          ((boolean? e) #t)
          ((pair? e)    (equal? (car e) 'quote))
          (else         #f) ) )
  ;; Expression -> Valeur
  (define (quotation-data e)
    (if (pair? e) 
        (cadr e)
        e ) )
  ;; Expression -> bool
  (define (conditional? e)
    (if (pair? e) (equal? (car e) 'cond) #f) )
  ;; Expression -> Clause*
  (define (conditional-clauses e)
    (cdr e) )
  ;; Clause -> Expression
  (define (clause-condition e)
    (car e) )
  ;; Clause -> Expression*
  (define (clause-body e)
    (cdr e) )
  ;; Expression -> bool
  (define (alternative? e)
    (if (pair? e) (equal? (car e) 'if) #f) )
  ;; Alternative -> Expression
  (define (alternative-condition e)
    (cadr e) )
  ;; Alternative -> Expression
  (define (alternative-consequent e)
    (caddr e) )
  ;; Alternative -> Expression
  (define (alternative-alternant e)
    (if (pair? (cdddr e)) 
        (cadddr e)
        #f ) )
  ;; Expression -> bool
  (define (sequence? e)
    (if (pair? e) (equal? (car e) 'begin) #f) )
  ;; Sequence -> Expression*
  (define (sequence-forms e)
    (cdr e) )
  ;; Expression -> bool
  (define (local-block? e)
    (if (pair? e) (equal? (car e) 'let) #f) )
  ;; LocalBlock -> Liaison*
  (define (local-block-bindings e)
    (cadr e) )
  ;; LocalBlock -> Expression*
  (define (local-block-body e)
    (cddr e) )
  ;; Liaison -> Variable
  (define (binding-name binding)
    (car binding) )
  ;; Liaison -> Expression
  (define (binding-form binding)
    (cadr binding) )
  ;; Expression -> bool
  (define (application? e)
    (pair? e) )
  ;; Application -> Expression
  (define (application-operator e)
    (car e) )
  ;; Application -> Expression*
  (define (application-operands e)
    (cdr e) )
  ;; Expression -> bool
  (define (define-form? e)
    (if (pair? e) (equal? (car e) 'define) #f) )
  ;; DefinitionFonctionnelle -> Variable
  (define (definition-name d)
    (car (cadr d)) )
  ;; DefinitionFonctionnelle -> Variable*
  (define (definition-variables d)
    (cdr (cadr d)) )
  ;; DefinitionFonctionnelle -> Expression*
  (define (definition-body d)
    (cddr d) )
  
  ;; Environnements:
  ;;---------------
  ;; Les environnements sont représentés par la structure de données:
  ;; <env> = (vecteur <env> (variable...) valeur... )
  ;; Après la barrière d'abstraction se trouvent les fonctions les plus
  ;; intéressantes: lookup et extend.

  (let ((empty-environment #f))
    ;; empty-environment : Environnement

    ;; Environnement -> bool
    (define (empty-environment? r)
      (equal? r empty-environment) )
    ;; Environnement -> Environnement
    (define (environment-next r)
      (vector-ref r 0) )
    ;; Environnement -> Variable*
    (define (environment-variables r)
      (vector-ref r 1) )
    ;; Environnement * num -> Valeur
    (define (environment-get-value r i)
      (vector-ref r (+ 2 i)) )
    ;; Environnement * num * Valeur -> void
    (define (environment-put-value! r i v)
      (vector-set! r (+ 2 i) v) )
    ;; Créer un nouvel environnement étendant un ancien environnement et
    ;; suffisamment grand pour y loger des variables.
    ;; Environnement * Variable* -> Environnement
    (define (make-environment next variables)
      (let ((r (make-vector (+ 2 (length variables)))))
        (vector-set! r 0 next)
        (vector-set! r 1 variables)
        r ) )

    ;; Chercher la valeur d'une variable dans un environnement.
    ;; Variable * Environnement -> Valeur
    (define (lookup id r)
      (if (empty-environment? r)
          (wrong 'lookup "variable inconnue" id) 
          (let ((variables (environment-variables r)))
            (if (member id variables)
                (environment-get-value r (rank id variables))
                (lookup id (environment-next r)) ) ) ) )

    ;; Étendre un Environnement avec un bloc d'activation liant 
    ;; des variables à leurs valeurs.
    ;; Environnement * Variable* * Valeur* -> Environnement
    (define (extend r ids values)
      (if (= (length ids) (length values))
          (let ((frame (make-environment r ids)))
            ;; remplir frame avec les valeurs successives:
            ;; num * Valeur* -> void
            (define (fill! i values)
              (if (pair? values)
                  (begin
                    (environment-put-value! frame i (car values))
                    (fill! (+ i 1) (cdr values)) ) ) )
            (fill! 0 values)
            frame )
          (wrong 'extend "arité incorrecte" (list ids values)) ) )

    ;; Étendre un Environnement avec un bloc d'activation pour
    ;; définitions récursives [C'est la seule partie vraiment complexe].
    ;; Environnement * DefinitionFonctionnelle* -> Environnement
    (define (enrich r definitions)
      (let ((names (map definition-name definitions)))
        (let ((frame (make-environment r names)))
          ;; Remplir frame avec les définitions évaluées en récursion mutuelle:
          ;; num * DefinitionFonctionnelle* -> void
          (define (fill! i definitions)
            (if (pair? definitions)
                (begin
                  (environment-put-value! 
                   frame 
                   i
                   (create-function (definition-variables (car definitions))
                                    (definition-body (car definitions))
                                    frame ) )
                  (fill! (+ i 1) (cdr definitions)) ) ) )
          (fill! 0 definitions)
          frame ) ) )

    ;; L'évaluateur:
    ;;--------------
    ;; Tout d'abord, les évaluateurs spécialisés par nature syntaxique.

    ;; Variable * Environnement -> Valeur
    (define (evaluate-variable id r)
      (lookup id r) )
    ;; Valeur * Environnement -> Valeur
    (define (evaluate-quote data r)
      data )
    ;; Clause* * Environnement -> Valeur
    (define (evaluate-cond clauses r)
      (evaluate (expand-cond clauses) r) )
    ;; Expression * Expression * Expression * Environnement -> Valeur
    (define (evaluate-if condition then-part else-part r)
      (if (evaluate condition r)
          (evaluate then-part r)
          (evaluate else-part r) ) )
    ;; Expression* * Environnement -> Valeur
    (define (evaluate-begin expressions r)
      (eprogn expressions r) )
    ;; Liaison* * Expression* * Environnement -> Valeur
    (define (evaluate-let bindings body r)
      (ebody body 
             (extend r 
                     (map binding-name bindings)
                     (evlis (map binding-form bindings) r) ) ) )
    ;; Expression * Expression* * Environnement -> Valeur
    (define (evaluate-call function arguments r)
      (let ((f (evaluate function r)))
        (if (invokable? f)
            (invoke f (evlis arguments r))
            (wrong 'evaluate-call "pas une fonction" f) ) ) )

    ;; Discriminer l'expression pour savoir quel évaluateur spécialisé invoquer:
    ;; Expression * Environnement -> Valeur
    (define (evaluate e r)
      (cond 
       ((variable? e)  (evaluate-variable e r))
       ((quotation? e) (evaluate-quote (quotation-data e) r))
       ((conditional? e) 
        (evaluate-cond (conditional-clauses e) r) )
       ((alternative? e) 
        (evaluate-if (alternative-condition e)
                     (alternative-consequent e)
                     (alternative-alternant e)
                     r ) )
       ((sequence? e)    (evaluate-begin (sequence-forms e) r))
       ((local-block? e) (evaluate-let (local-block-bindings e)
                                       (local-block-body e)
                                       r ))
       ((application? e) (evaluate-call (application-operator e)
                                        (application-operands e)
                                        r ))
       (else (wrong 'evaluate "pas un programme" e)) ) )

    ;; Évaluer tour à tour les expressions et retourner la valeur de la 
    ;; dernière d'entre elles.
    ;; Expression* * Environnement -> Valeur
    (define (eprogn expressions r)
      (if (pair? expressions)
          (if (pair? (cdr expressions))
              (begin (evaluate (car expressions) r)
                     (eprogn (cdr expressions) r) )
              (evaluate (car expressions) r) )
          ;; pas d'alternant ici (pour rester non spécifié)
          ) )
    
    ;; Retourner la liste des valeurs des expressions.
    ;; Expression* * Environnement -> Valeur*
    (define (evlis expressions r)
      (if (pair? expressions)
          (cons (evaluate (car expressions) r)
                (evlis (cdr expressions) r) )
          '() ) )

    ;; Séparer les définitions des expressions, puis évaluer ces
    ;; expressions dans l'environnement étendu avec les définitions
    ;; des fonctions locales mutuellement récursives.
    ;; Expression* * Environnement -> Valeur
    (define (ebody expressions r)
      ;; DefinitionFonctionnelle* * Expression* -> Valeur
      (define (sort-definitions definitions expressions)
        (if (define-form? (car expressions))
            (sort-definitions (cons (car expressions) definitions) 
                              (cdr expressions) )
            (eprogn expressions (enrich r definitions)) ) )
      (sort-definitions '() expressions) )

    ;; Objets invoquables
    ;;-------------------
    ;; Il y a deux types de fonctions, les fonctions prédéfinies
    ;; (reconnues par primitive?) et les fonctions du programme en
    ;; cours d'évaluation (reconnues par function?).

    ;; Valeur -> Bool
    (define (invokable? thing)
      (if (primitive? thing)
          #t 
          (function? thing) ) )

    ;; Valeur * Valeur* -> Valeur
    (define (invoke f values)
      ((if (primitive? f) invoke-primitive invoke-function)
       f values ) )

    ;; Fonctions 
    ;;----------

    ;; Variable* * Expression* * Environnement -> Valeur
    (define (create-function ids expressions r)
      (define (process values)
        (ebody expressions (extend r ids values)) )
      process )

    ;; Fonction * Valeur* -> Valeur
    (define (invoke-function f values)
      (f values) )

    ;; Reconnaître les fonctions créées par le programme.
    ;; Valeur -> Bool
    (define (function? f)
      (procedure? f) )

    ;; Environnement global prédéfini
    ;;-------------------------------
    ;; Pour varier, les primitives sont représentées par des listes.
    ;; Description -> Primitive
    (define (create-primitive primitive-description)
      (cons '*primitive* primitive-description) )

    ;; Primitive * Valeur* -> Valeur
    (define (invoke-primitive primitive values)
      (let ((primitive-description (cdr primitive))
            (n (length values)) )
        (let ((id      (primitive-description-name primitive-description))
              (f       (primitive-description-behavior primitive-description))
              (compare (primitive-description-comparator primitive-description))
              (arity   (primitive-description-arity primitive-description)) )
          (if (compare n arity)
              ;; Comme (apply f values) mais limité à 4 arguments:
              (cond
               ((= n 0) (f))
               ((= n 1) (f (car values)))
               ((= n 2) (f (car values) (cadr values)))
               ((= n 3) (f (car values) (cadr values) (caddr values)))
               ((= n 4) (f (car values) (cadr values) 
                           (caddr values) (cadddr values) ))
               ((= n 5) (f (car values) (cadr values) 
                           (caddr values) (cadddr values)
                           (car (cdddr values)) ))
               (else    (wrong 'primitive "arité non traitée" id)) )
              (wrong id "arité incorrecte" values) ) ) ) )

    ;; Reconnaît les fonctions prédéfinies 
    ;; Valeur -> Bool
    (define (primitive? thing)
      (if (pair? thing) (equal? (car thing) '*primitive*) #f) )
    
    ;; Variable * (Valeur ... -> Valeur)
    ;;     * (num * num -> bool) * num  -> Description
    (define (describe-primitive id f comparator arity)
      (list id f comparator arity) )
    ;; Description -> Variable
    (define (primitive-description-name p)
      (car p) )
    ;; Description -> (Valeur ... -> Valeur)
    (define (primitive-description-behavior p)
      (cadr p) )
    ;; Description -> (num * num -> bool)
    (define (primitive-description-comparator p)
      (caddr p) )
    ;; Description -> num
    (define (primitive-description-arity p)
      (cadddr p) )

    ;; Environnement initial:
    ;;-----------------------
    ;; Ce petit utilitaire prend les descriptions des primitives et 
    ;; construit l'environnement global prédéfini avec.
    ;; Environnement * Description* -> Environnement
    (define (augment r primitive-descriptions)
      (extend r
              (map primitive-description-name primitive-descriptions)
              (map create-primitive primitive-descriptions) ) )

    (let ((primitives         ; primitives : Description*
           (cons (describe-primitive 'car           car           =  1)
           (cons (describe-primitive 'cdr           cdr           =  1)
           (cons (describe-primitive 'cons          cons          =  2)
           (cons (describe-primitive 'list          list          >= 0)
           (cons (describe-primitive 'vector-length vector-length =  1)
           (cons (describe-primitive 'vector-ref    vector-ref    =  2)
           (cons (describe-primitive 'vector-set!   vector-set!   =  3)
           (cons (describe-primitive 'make-vector   make-vector   =  1) ; ou 2 
           (cons (describe-primitive 'pair?         pair?         =  1)
           (cons (describe-primitive 'symbol?       symbol?       =  1)
           (cons (describe-primitive 'number?       number?       =  1)
           (cons (describe-primitive 'string?       string?       =  1)
           (cons (describe-primitive 'boolean?      boolean?      =  1)
           (cons (describe-primitive 'vector?       vector?       =  1)
           (cons (describe-primitive 'char?         char?         =  1)
           (cons (describe-primitive 'procedure?    invokable?    =  1)
           (cons (describe-primitive 'equal?        equal?        =  2)
           (cons (describe-primitive '+             +             >= 0)
           (cons (describe-primitive '*             *             >= 0)
           (cons (describe-primitive '-             -             =  2)
           (cons (describe-primitive '=             =             =  2)
           (cons (describe-primitive '<             <             =  2)
           (cons (describe-primitive '>             >             =  2)
           (cons (describe-primitive '<=            <=            =  2)
           (cons (describe-primitive '>=            >=            =  2)
           (cons (describe-primitive 'remainder     remainder     =  2)
           (cons (describe-primitive 'display       display       =  1) ; ou 2
           (cons (describe-primitive 'newline       newline       =  0) ; ou 1
           (cons (describe-primitive 'read          read          =  0)
           (cons (describe-primitive 'wrong         wrong         =  3)
                 '())))))))))))))))))))))))))))))) ))
      
      ;; Tout est enfin prêt à être évalué:
      (let ((initial-environment (augment empty-environment primitives)))
        ;; initial-environnement : Environnement
        (evaluate e initial-environment) ) ) ) )

; Mise en oeuvre sous DrScheme version 100:
; ouvrir fichier eval3fr.scm puis évaluer (deug-eval '(+ 2 3))
; Pour auto-interpréter l'évaluateur, il suffit d'écrire (en supposant
; que <DEUGEVAL> est la Sexpression définissant deug-eval:
; (deug-eval '(let () <DEUGEVAL> (deug-eval '(+ 2 3))))

; NOTA: pour faire tourner ce code sous d'autres systèmes Scheme, la
; définition de wrong est probablement à revoir suivant l'existence
; et/ou l'arité de la fonction error (qui n'est pas définie par le r4rs).

;;; end of eval3fr.scm