#lang racket

;;; parser3.rkt - Sections 15.4 du chapitre 15 (Analyseurs Syntaxiques)
;;; Livre PCPS : "Premiers Cours de Programmation avec Scheme"
;;; Langage determine par le source

;;; Traducteur de Nano-C vers Scheme

(require parser-tools/lex)
(require parser-tools/yacc)

;;; le lexeur

(define-lex-abbrevs
  (blanc (union #\newline #\return #\tab #\space))
  (letter (union (char-range "a" "z") (char-range "A" "Z")))
  (digit (char-range "0" "9"))
  (int (repetition 1 +inf.0 digit))
  (float (concatenation int "." int))
  (boolean (union "true" "false"))
  (var (concatenation letter (repetition 0 +inf.0 (union letter digit)))))

(define-tokens value-tokens (NUM VAR))
(define-empty-tokens op-tokens (LPAR RPAR LBRA RBRA + - * / ^ =  > ==
                                     WHILE PRINT FINI SEMICOLON COLON NEG IF THEN ELSE LOWER_THAN_ELSE))

(define get-lexeme
  (lexer
   [(eof) 'FINI]
   ; on invoque recursivement le lexer pour sauter les espaces. La variable input-port est liee dans lexer
   [(repetition 1 +inf.0 blanc) (get-lexeme input-port)]
   [(union "=" "+" "-" "*" "/" "^" ">" "==" "print" "if" "then" "else" "while") (string->symbol (string-upcase lexeme))]
   ["," 'COLON]
   ["(" 'LPAR]
   [")" 'RPAR]
   ["{" 'LBRA]
   ["}" 'RBRA]
   [";" 'SEMICOLON]
   [var (token-VAR (string->symbol lexeme))]                      ; une variable
   [(union int float) (token-NUM (string->number lexeme))]))      ; un entier ou un flottant est un nombre

(define prgm-nanoC
  "n = 2^3; res = 1; 
while (n > 0) {
  res = res*n;
  n = n-1;
}
test = res+1 == 150;
if (test) print(1);
else if (100 > res) print(2);
else print(res);")

(printf "Voici un programme en Nano-C :\n-----------------\n~a\n------------------\n" prgm-nanoC)

(define (test-lexer)
  (let ((p-in (open-input-string prgm-nanoC)))
    (do ((x (get-lexeme p-in) (get-lexeme p-in)))
      ((equal? x 'FINI) (void))
      (printf "Lecture de ~a\n" x))))

(printf "Test du lexeur sur ce programme :\n\n")
(test-lexer)

(define lexeur (let ((p-in (open-input-string prgm-nanoC)))
                 (lambda ()
                   (get-lexeme p-in))))

;;; le parseur

(define parse
  (parser
   
   (start prog)
   (end FINI)
   (tokens value-tokens op-tokens)
   (error (lambda (a b c) (printf "Parsing error : ~a\n" (list a b c))))
   
   (precs (nonassoc LOWER_THAN_ELSE)
          (nonassoc ELSE)
          (nonassoc > = ==)
          (left - +)
          (left * /)
          (left NEG)       ; operateur virtuel n'existant que pour sa priorite ! Left car --x = -(-x)
          (right ^))       ; right car a^b^c = a^b(^c)       
   
   (grammar                ; 0 conflit !
    
    (prog  [(instrs) `(begin ,@$1)])
    
    (instrs [(instr) `(,$1)]
            [(instrs instr) `(,@$1 ,$2)])
    
    (instr [(IF LPAR expr RPAR instr ELSE instr) `(if ,$3 ,$5 ,$7)]
           [(IF LPAR expr RPAR instr) (prec LOWER_THAN_ELSE) `(when ,$3 ,$5)]
           [(WHILE LPAR expr RPAR instr) `(while ,$3 ,$5)] 
           [(VAR = expr SEMICOLON) `(set! ,$1 ,$3)]
           [(LBRA instrs RBRA) `(begin ,@$2)]
           [(PRINT expr SEMICOLON) `(printf "~a\n" ,$2)])
    
    (exprs [() '()]
           [(exprs expr) `(,@$1 ,$2)])
    
    (expr [(NUM) $1]
          [(VAR) $1]
          [(expr + expr) `(+ ,$1 ,$3)]
          [(expr - expr) `(- ,$1 ,$3)]
          [(expr * expr) `(* ,$1 ,$3)]
          [(expr / expr) `(/ ,$1 ,$3)]
          [(expr ^ expr) `(expt ,$1 ,$3)]
          [(- expr) (prec NEG) `(- ,$2)]     ; priorite du moins unaire plus elevee que celle du moins binaire !
          [(expr > expr) `(> ,$1 ,$3)]
          [(expr == expr) `(= ,$1 ,$3)]
          [(LPAR expr RPAR) $2]
          [(IF expr THEN expr ELSE expr) `(if ,$2 ,$4 ,$6)]
          [(IF expr THEN expr) (prec LOWER_THAN_ELSE) `(if ,$2 ,$4 (void))]))))

(define (reunion L1 L2)      ; append sans repetitions
  (cond ((null? L1) L2)
        ((member (car L1) L2) (reunion (cdr L1) L2))
        (else (cons (car L1) (reunion (cdr L1) L2)))))

(define (variables code)
  (cond ((null? code) '())
        ((pair? code) (reunion (variables (car code)) (variables (cdr code))))
        ((member code '(begin set! while if printf + - * / > = == expt)) '())
        ((symbol? code) (list code))
        (else '())))

(define prgm-scheme  (parse lexeur))      ; la traduction en Scheme

(printf "\nLes variables du texte source sont : ~a\n" (variables prgm-scheme))

(set! prgm-scheme 
      `(let ,(map (lambda (var) (list var 0)) (variables prgm-scheme))
        ,@(cdr prgm-scheme)))

(printf "\nEt la traduction en Scheme du programme Nano-C est :\n\n")
prgm-scheme

;;; Execution du programme Scheme obtenu

(define ns (make-base-namespace))
(eval '(require "while-for.rkt") ns)    ; la macro while dans un module exterieur
(printf "\nExecution du programme Scheme obtenu : ")
(eval prgm-scheme ns)