;;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
;;;
;;; Copyright (c) 2009 by the authors.
;;;
;;; See LICENCE for details.

(in-package :hu.dwim.excosy)

;;;;;;
;;; AST

(def class* ast ()
  ((reader-function :type symbol)
   (printer-function :type symbol)
   (interpreter-function :type symbol)
   (memory-location-allocator-function :type symbol)))

;;;;;;
;;; Abstraction

;; TODO: rather call it object? or something-that-has-memory-location? or whatever?
(def class* abstraction/ast (ast)
  ((printer-function 'print-abstraction)
   (interpreter-function 'interpret-abstraction)
   (memory-location-allocator-function 'allocate-abstraction-memory-location)
   (counter 0 :allocation :class)))

(def function read-abstraction (machine ast input)
  (make-instance 'abstraction/ast))

(def function print-abstraction (machine ast output)
  (format output "(abstraction)"))

(def function interpret-abstraction (machine ast)
  (bind ((memory-location (ensure-memory-location machine ast))
         (register (llvm/generate-new-register-name :abstraction))
         (bit-size (word-bit-size-of (configuration-of machine))))
    (llvm/alloca machine (llvm/register machine register) (llvm/type machine :signed-integer bit-size) 1)
    (llvm/store machine (llvm/type machine :signed-integer bit-size) memory-location (llvm/type machine :signed-integer bit-size) (llvm/register machine register))
    (llvm/register machine register)))

(def function allocate-abstraction-memory-location (machine ast)
  (declare (ignore machine))
  (logior (ash (incf (counter-of ast)) 2) #b11))

;;;;;;
;;; Application

(def class* application/ast (ast)
  ((applied-abstraction :type abstraction/ast)))

(def function read-application (machine ast input)
  ;; TODO:
  (make-instance 'application))

(def function print-application (machine ast output)
  (format output "(~A)" (applied-abstraction-of ast)))

(def function interpret-application (machine ast)
  ast)

;;;;;;
;;; Argument

(def class* argument/ast (ast)
  ((name :type string)))

(def function read-argument (machine ast input)
  ;; TODO:
  (make-instance 'argument :name nil))

(def function print-argument (machine ast output)
  (format output "(~A)" (applied-abstraction-of ast)))

(def function interpret-argument (machine ast)
  (error ""))

;;;;;;
;;; Single argument abstraction

(def class* single-argument-abstraction/ast (abstraction/ast)
  ((argument :type ast)
   (body :type ast)))

;;;;;;
;;; Single argument application

(def class* single-argument-application/ast (application/ast)
  ((argument :type ast)))

;;;;;;
;;; Multi argument abstraction

(def class* multi-argument-abstraction/ast (abstraction/ast)
  ((arguments :type ast)
   (body :type ast)))

;;;;;;
;;; Multi argument application

(def class* multi-argument-application/ast (application/ast)
  ((arguments :type ast)))

;;;;;;
;;; If

(def class* if/ast (ast)
  ((reader-function 'read-if)
   (printer-function 'print-if)
   (interpreter-function 'interpret-if)
   (condition :type ast)
   (then-branch :type ast)
   (else-branch :type ast)))

(def function read-if (machine ast output)
  (not-yet-implemented))

(def function print-if (machine ast output)
  (not-yet-implemented))

(def function interpret-if (machine ast)
  (bind ((true-memory-location (ensure-memory-location machine (find-well-known-abstraction (configuration-of machine) :true)))
         (false-memory-location (ensure-memory-location machine (find-well-known-abstraction (configuration-of machine) :false)))
         (conditional-register (llvm/generate-new-register-name :conditional))
         (then-register (llvm/generate-new-register-name :then-branch))
         (else-register (llvm/generate-new-register-name :else-branch))
         (result-register (llvm/generate-new-register-name :result))
         (bit-size (word-bit-size-of (configuration-of machine))))
    (llvm/block
      (llvm/label machine :if-entry)
      (llvm/load machine (llvm/register machine conditional-register) (llvm/type machine :signed-integer bit-size) (interpret-ast machine (condition-of ast)))
      (llvm/switch machine (llvm/register machine conditional-register) (llvm/label-reference machine :if-exit)
                   true-memory-location (llvm/label-reference machine :then-branch) false-memory-location  (llvm/label-reference machine :else-branch))
      (llvm/label machine :then-branch)
      (llvm/load machine (llvm/register machine then-register) (llvm/type machine :signed-integer bit-size) (interpret-ast machine (then-branch-of ast)))
      (llvm/unconditional-br machine (llvm/label-reference machine :if-exit))
      (llvm/label machine :else-branch)
      (llvm/load machine (llvm/register machine else-register) (llvm/type machine :signed-integer bit-size) (interpret-ast machine (else-branch-of ast)))
      (llvm/unconditional-br machine (llvm/label-reference machine :if-exit))
      (llvm/label machine :if-exit)
      (llvm/phi machine (llvm/register machine result-register) (llvm/type machine :signed-integer bit-size)
                (llvm/register machine then-register) (llvm/label-reference machine :then-branch)
                (llvm/register machine else-register) (llvm/label-reference machine :else-branch)
                (llvm/register machine conditional-register) (llvm/label-reference machine :if-entry))
      (llvm/register machine result-register))))

;;;;;;
;;; with-labels/ast

(def class* with-labels/ast (ast)
  ((reader-function 'read-with-labels)
   (printer-function 'print-with-labels)
   (interpreter-function 'interpret-with-labels)
   (labelled-asts :type list)))

(def function read-with-labels (machine ast input)
  (not-yet-implemented))

(def function print-with-labels (machine ast output)
  (not-yet-implemented))

(def function interpret-with-labels (machine ast)
  (bind ((labelled-asts (labelled-asts-of ast))
         (first-name (name-of (first labelled-asts))))
    (llvm/unconditional-br machine (llvm/label-reference machine first-name))
    (llvm/label machine first-name)
    (dolist (labelled-ast (rest labelled-asts))
      (push-label machine labelled-ast)
      (llvm/label machine (name-of labelled-ast)))
    (dolist (labelled-ast labelled-asts)
      (interpret-ast machine labelled-ast))
    ;; TODO: use :nothing instead
    (ensure-memory-location machine (find-well-known-abstraction (configuration-of machine) :false))))

(def function push-label (machine ast)
  (push ast (labels-of (environment-of machine))))

;;;;;;
;;; label

(def class* label/ast (ast)
  ((reader-function 'read-label)
   (printer-function 'print-label)
   (interpreter-function 'interpret-label)
   (name :type symbol)
   (body :type ast)))

(def function read-label (machine ast input)
  (not-yet-implemented))

(def function print-label (machine ast output)
  (not-yet-implemented))

(def function interpret-label (machine ast)
  (interpret-ast machine (body-of ast)))

;;;;;;
;;; goto-label/ast

(def class* goto-label/ast (ast)
  ((reader-function 'read-goto-label)
   (printer-function 'print-goto-label)
   (interpreter-function 'interpret-goto-label)
   (name :name symbol)))

(def function read-goto-label (machine ast input)
  (not-yet-implemented))

(def function print-goto-label (machine ast output)
  (not-yet-implemented))

(def function interpret-goto-label (machine ast)
  (llvm/unconditional-br machine (llvm/label-reference machine (name-of ast))))

;;;;;;
;;; let/ast

(def class* let/ast (ast)
  ((reader-function 'read-let)
   (printer-function 'print-let)
   (interpreter-function 'interpret-let)))

(def function read-let (machine ast input)
  (not-yet-implemented))

(def function print-let (machine ast output)
  (not-yet-implemented))

(def function interpret-let (machine ast)
  (not-yet-implemented))

;;;;;;
;;; set/ast

(def class* set/ast (ast)
  ((reader-function 'read-set)
   (printer-function 'print-set)
   (interpreter-function 'interpret-set)))

(def function read-set (machine ast input)
  (not-yet-implemented))

(def function print-set (machine ast output)
  (not-yet-implemented))

(def function interpret-set (machine ast)
  (not-yet-implemented))

;;;;;;
;;; sequentially/ast

(def class* sequentially/ast (ast)
  ((reader-function 'read-sequentially)
   (printer-function 'print-sequentially)
   (interpreter-function 'interpret-sequentially)
   (body :type list)))

(def function read-sequentially (machine ast input)
  (not-yet-implemented))

(def function print-sequentially (machine ast output)
  (not-yet-implemented))

(def function interpret-sequentially (machine ast)
  (dolist (child-ast (body-of ast))
    (interpret-ast machine child-ast)))

;;;;;;
;;; primitive-application/ast

(def class* primitive-application/ast (multi-argument-application/ast)
  ((reader-function 'read-primitive-application)
   (printer-function 'print-primitive-application)
   (interpreter-function 'interpret-primitive-application)
   (memory-location-allocator-function 'allocate-primitive-application-memory-location)))

(def function read-primitive-application (machine ast input)
  (not-yet-implemented))

(def function print-primitive-application (machine ast output)
  (not-yet-implemented))