;;; ----------------------------------------------------------------------
;;; Copyright 2010-2011 National University of Ireland.
;;; ----------------------------------------------------------------------
;;; This file is part of DysVunctional Language.
;;; 
;;; DysVunctional Language is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Affero General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;;  License, or (at your option) any later version.
;;; 
;;; DysVunctional Language is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;; 
;;; You should have received a copy of the GNU Affero General Public License
;;; along with DysVunctional Language.  If not, see <http://www.gnu.org/licenses/>.
;;; ----------------------------------------------------------------------

(declare (usual-integrations))
;;;; Analysis data structure

(define-structure (binding safe-accessors)
  part1
  part2
  value)

(define (eval-binding? binding)
  (env? (binding-part2 binding)))

(define (apply-binding? binding)
  (not (eval-binding? binding)))

(define (binding-exp binding)
  (if (eval-binding? binding)
      (binding-part1 binding)
      (error "Trying to take the exp of an apply binding" binding)))

(define (binding-env binding)
  (if (eval-binding? binding)
      (binding-part2 binding)
      (error "Trying to take the env of an apply binding" binding)))

(define (binding-proc binding)
  (if (apply-binding? binding)
      (binding-part1 binding)
      (error "Trying to take the proc of an eval binding" binding)))

(define (binding-arg binding)
  (if (apply-binding? binding)
      (binding-part2 binding)
      (error "Trying to take the arg of an eval binding" binding)))

(define-structure (analysis safe-accessors)
  bindings)

(define (analysis-search key1 key2 analysis win lose)
  (let loop ((bindings (analysis-bindings analysis)))
    (if (null? bindings)
        (lose)
        (if (and (abstract-equal? key1 (binding-part1 (car bindings)))
                 (abstract-equal? key2 (binding-part2 (car bindings))))
            (win (car bindings))
            (loop (cdr bindings))))))

;;; ANALYSIS-GET is \bar E_1 from [1].
(define (analysis-get key1 key2 analysis)
  (analysis-search key1 key2 analysis binding-value (lambda () abstract-none)))

;;; EXPAND-ANALYSIS is \bar E_1' from [1].
;;; It registers interest in the evaluation of EXP in ENV by producing
;;; a binding to be added to the new incarnation of ANALYSIS, should
;;; the current incarnation lack any binding already covering that
;;; question.
(define (analysis-expand key1 key2 analysis)
  (analysis-search key1 key2 analysis
   (lambda (binding)
     '())
   (lambda ()
     (if (or (abstract-none? key1)
             (abstract-none? key2))
         '()
         (list (make-binding key1 key2 abstract-none))))))

(define (same-analysis-binding? binding1 binding2)
  (and (abstract-equal? (binding-part1 binding1) (binding-part1 binding2))
       (abstract-equal? (binding-part2 binding1) (binding-part2 binding2))
       (abstract-equal? (binding-value binding1) (binding-value binding2))))

(define (same-analysis? ana1 ana2)
  (lset= same-analysis-binding? (analysis-bindings ana1)
         (analysis-bindings ana2)))

(define (step-changed-analysis? ana1 ana2)
  ;; The definition of this is
  ;; (not (same-analysis? ana1 ana2))
  ;; but since ANA2 is made from ANA1 by STEP-ANALYSIS we know that it
  ;; will contain bindings for all the same exp-env pairs (with
  ;; possibly improved values), in the same order, plus maybe a few
  ;; more bindings generated by EXPAND-ANALYSIS.  Therefore, this does
  ;; the right thing (and is faster).
  (let ((bindings1 (analysis-bindings ana1))
        (bindings2 (analysis-bindings ana2)))
    (or (not (= (length bindings1) (length bindings2)))
        (not (every same-analysis-binding? bindings1 bindings2)))))

(define (binding-escapes? binding)
  ;; TODO Add support for allowing things to escape to VL
  #f)
