;
; canon.scm - canonicalization of Scheme procedure S-expressions
; Total Procedures in Scheme, May 2006, Chris Pressey
; For license information, see the file LICENSE in this directory.
;

(define forbidden-syntax '(
    set!
    letrec
    do
    delay
    let-syntax
    letrec-syntax
    syntax-rules
    define
    define-syntax
  ))

;
; Create the environment that the body of a let* statement would
; be evaluated with.
;
(define-total make-let*-env
  (lambda (names env)
    (if (acyclic? names)
      (cond
        ((null? names)
          env)
        (else
          (let* ((first   (car names))
                 (rest    (cdr names))
                 (new-env (extend-env env first 'defined)))
            (make-let*-env rest new-env)))))))
  
(definerec-total (

;
; Canonicalize the given S-expression representing a Scheme procedre.
; That is, return a new S-exp which is equivalent to the given S-exp,
; but "de-sugared" so that it is simpler and so we can more easily
; work with it during program analysis.
;
; Aborts with an error, as a side-effect, if there is invalid syntax
; in the procedure, that is, syntax which does not appear in the
; subset of Scheme which we can successfully canonicalize.
;
(canonicalize
  (lambda (expr-rep env)
    (if (acyclic? expr-rep)
      (cond
        ((null? expr-rep)  ; for totality-checker's benefit
          expr-rep)
        ((pair? expr-rep)
          (cond
	    ;
	    ; If it is defined in the environment, it might be a
	    ; local variable which we are calling, in which case
	    ; we must override the default meaning of the symbol.
	    ; (This code is a copy of the is-call? code below.)
	    ;
	    ((and (symbol? (car expr-rep)) (get-env env (car expr-rep)))
              (let* ((func-ref-rep (canonicalize (car expr-rep) env))
                     (args-rep     (cdr expr-rep))
                     (pair         (canonicalize-func-args args-rep env '() '()))
                     (new-bindings (car pair))
                     (new-args     (cdr pair))
                     (new-call-rep (cons func-ref-rep new-args)))
                (cond
                  ((null? expr-rep)
                    expr-rep)
                  ((null? new-bindings)
                    expr-rep)
                  (else
                    (list 'let new-bindings new-call-rep)))))	      
            ;
            ; 'if' with no else-branch is given an explicit undefined else branch.
            ;
            ((is-if? expr-rep)
              (let* ((test-expr (cadr expr-rep))     ; get-test-expr
                     (then-expr (caddr expr-rep)))   ; get-then-expr
                (if (> (length expr-rep) 3)
                    (let* ((else-expr (cadddr expr-rep))) ; get-else-expr
                      (list 'if (canonicalize test-expr env)
                                (canonicalize then-expr env)
                                (canonicalize else-expr env)))
                    (list 'if (canonicalize test-expr env)
                              (canonicalize then-expr env)
                              ''undefined))))
            ((is-cond? expr-rep)
              (canonicalize-cond-branches (cdr expr-rep) env)) ; get-cond-branches
	    ;
	    ; XXX TODO: disallow named let
	    ;
            ((is-let? expr-rep)
              (let* ((bindings     (cadr expr-rep))  ; get-let-bindings
                     (body-rep     (cddr expr-rep))  ; get-let-body
		     (names        (bindings->names bindings))
                     (new-bindings (canonicalize-bindings bindings env '()))
                     (new-env      (extend-env-many env (names->env names 'defined (make-empty-env))))
                     (new-body     (canonicalize-begin body-rep new-env)))
                (list 'let new-bindings new-body)))
            ((is-let*? expr-rep)
              (let* ((bindings   (cadr expr-rep))   ; get-let-bindings
                     (body       (cddr expr-rep))  ; get-let-body
                     (names      (bindings->names bindings))
                     (inner-env  (make-let*-env names env))
                     (canon-body (canonicalize-begin body inner-env)))
                (canonicalize-let* bindings canon-body env)))
            ;
            ; Canonicalizing a lambda expression doesn't make any significant
            ; structural changes by itself, but it does modify the environment.
            ;
            ((is-lambda? expr-rep)
              (let* ((args         (cadr expr-rep))           ; get-lambda-args
                     (body-rep     (cddr expr-rep))           ; get-lambda-body
                     (new-bindings (names->env args 'defined (make-empty-env)))
                     (new-env      (extend-env-many env new-bindings))
                     (new-body     (canonicalize-begin body-rep new-env)))
                (list 'lambda args new-body)))
            ((is-begin? expr-rep)
              (canonicalize-begin (cdr expr-rep) env)) ; get-begin-list
            ;
            ; Evaluation of parameters inside a function call are brought outside the
            ; function call, i.e. (foo (bar baz)) -> (let ((x (bar baz))) (func x))
            ; This only brings out nontrivial (non-symbol, int etc) parameters.
            ;
            ((is-call? expr-rep)
              (let* ((func-ref-rep (canonicalize (car expr-rep) env))
                     (args-rep     (cdr expr-rep))
                     (pair         (canonicalize-func-args args-rep env '() '()))
                     (new-bindings (car pair))
                     (new-args     (cdr pair))
                     (new-call-rep (cons func-ref-rep new-args)))
                (cond
                  ((null? expr-rep)
                    expr-rep)
                  ((null? new-bindings)
                    expr-rep)
                  (else
                    (list 'let new-bindings new-call-rep)))))
            ((memv (car expr-rep) forbidden-syntax)
              #f)
            (else
              expr-rep)))
        (else
          expr-rep)))))

;
; 'cond' is transformed into a series of nested 'if's.
;
(canonicalize-cond-branches
  (lambda (branch-reps env)
    (if (acyclic? branch-reps)
      (cond
        ((null? branch-reps)
          ''undefined)
        (else
          (let* ((first-branch     (car branch-reps))
                 (rest-of-branches (cdr branch-reps))
                 (first-test       (car first-branch))
                 (first-result     (cdr first-branch))
                 (canon-result     (canonicalize-begin first-result env)))
            (cond
              ((eq? first-test 'else)
                canon-result)
              (else
                (list 'if
                      (canonicalize first-test env)
                      canon-result
                      (canonicalize-cond-branches rest-of-branches env))))))))))

(canonicalize-bindings
  (lambda (bindings env acc)
    (if (acyclic? bindings)
      (cond
        ((null? bindings)
          (reverse acc))
        (else
          (let* ((binding     (car bindings))
                 (rest        (cdr bindings))
                 (name        (car binding))
                 (value       (cadr binding))
                 (new-value   (canonicalize value env))
                 (new-binding (list name new-value)))
            (canonicalize-bindings rest env (cons new-binding acc))))))))

;
; 'let*' is transformed into a series of nested 'let's.
; Note that body-rep is given to us pre-canonicalized.
;
(canonicalize-let*
  (lambda (bindings body-rep env)
    (if (acyclic? bindings)
      (cond
        ((null? bindings)
          body-rep)
        (else
          (let* ((binding   (car bindings))
                 (rest      (cdr bindings))
                 (name      (car binding))
                 (value     (cadr binding))
                 (canon-val (canonicalize value env))
                 (new-env   (extend-env env name '())))
            (list 'let
                  (list (list name canon-val))
                  (canonicalize-let* rest body-rep env))))))))

;
; The list of expressions contained inside a 'begin' expression
; is transformed into a series of nested, two-statement 'begin's.
;
(canonicalize-begin
  (lambda (exprs env)
    (if (acyclic? exprs)
      (cond
        ((null? exprs)
          ''undefined)
        ((null? (cdr exprs))
          (canonicalize (car exprs) env))
        (else
          (let* ((first (canonicalize (car exprs) env))
                 (rest  (canonicalize-begin (cdr exprs) env)))
            (list 'begin first rest)))))))

(canonicalize-func-args
  (lambda (args env acc-let acc-args)
    (if (acyclic? args)
      (cond
        ((null? args)
          (cons (reverse acc-let) (reverse acc-args)))
        ((list? (car args))
          (let* ((canonicalized-arg (canonicalize (car args) env))
                 (new-name          (get-fresh-name env))
                 (new-env           (extend-env env new-name '()))
                 (new-acc-let       (cons (list new-name canonicalized-arg) acc-let))
                 (new-acc-args      (cons new-name acc-args)))
            (canonicalize-func-args (cdr args) new-env new-acc-let new-acc-args)))
        (else
          (canonicalize-func-args (cdr args) env acc-let (cons (car args) acc-args)))))))

))

;
; Given a list of S-expressions representing Scheme expressions, return
; a corresponding list of canonicalized expressions.
;
(define-total canonicalize-all
  (lambda (expr-reps env acc)
    (if (acyclic? expr-reps)
      (cond
        ((null? expr-reps)
          (reverse acc))
        (else
          (let* ((expr-rep       (car expr-reps))
                 (rest           (cdr expr-reps))
                 (canon-expr-rep (canonicalize expr-rep env))
                 (new-acc        (cons canon-expr-rep acc)))
            (canonicalize-all rest env new-acc)))))))