;; Copyright (C) 2008-2013 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.


;; *** Expressions ***


(import (rnrs exceptions)
	(srfi srfi-1)
	(th-scheme-utilities stdutils)
	(th-scheme-utilities hrecord))


(define gl-i-sgt-counter 0)


;; An expression is allowed to never return and still have
;; never-returns? = #f.
;; Consequently we do not have to detect all cases
;; in which an expression never returns.
(define-hrecord-type <dynamic-expression> (<expression>)
  always-returns?
  never-returns?)

(define-hrecord-type <empty-expression> (<expression>))

(define-hrecord-type <variable-definition> (<expression>)
  variable type-decl value-expr declared? prevent-stripping?
  include?)

(define-hrecord-type <variable-reference> (<expression>)
  variable)

;; Field "include?" is not used for forward declarations.
(define-hrecord-type <forward-declaration> (<expression>)
  variable declared-type redecl? include?)

(define-hrecord-type <prim-proc-ref> (<expression>))

(define-hrecord-type <checked-prim-proc> (<expression>))

(define-hrecord-type <prim-class-def> (<variable-definition>)
  name target-name goops? superclass inh? imm? ebv? checked?
  member-target-name
  equal-target-name
  equal-objects-target-name
  equal-contents-target-name
  zero-address)

(define-hrecord-type <class-definition> (<variable-definition>))

(define-hrecord-type <signature-definition> (<variable-definition>)
  lst-members)

(define-hrecord-type <param-signature-definition> (<variable-definition>)
  r-type-vars lst-members)

(define-hrecord-type <param-class-definition> (<variable-definition>)
  type-variables)

(define-hrecord-type <param-logical-type-def> (<variable-definition>)
  type-variables)

(define-hrecord-type <expr-param-proc-instance> (<expression>)
  param-proc params)

(define-hrecord-type <expr-param-proc-dispatch> (<expression>)
  param-proc params argument-types)

(define-hrecord-type <param-proc-expr> (<expression>)
  type-variables body s-kind s-name l-module)

(define-hrecord-type <set-expression> (<dynamic-expression>)
  variable value-expr)

(define-hrecord-type <generic-procedure-definition> (<variable-definition>))

(define-hrecord-type <generic-proc-dispatch> (<expression>)
  generic-proc arg-types with-result?
  appl-pure? appl-always-returns? appl-never-returns?
  regular?)

;; params is null for simple and generic procedures
(define-hrecord-type <proc-appl> (<dynamic-expression>)
  proc arglist params static-arg-types runtime-arglist-typecheck?
  l-default-params)

(define-hrecord-type <cast-expression> (<dynamic-expression>)
  value-expr default-expr)

(define-hrecord-type <static-cast-expression> (<dynamic-expression>)
  ent-value)

(define-hrecord-type <match-type-expression> (<dynamic-expression>)
  strong? expr-to-match lst-proper-clauses expr-else optimized?)

(define-hrecord-type <if-form> (<dynamic-expression>)
  condition then-expr else-expr boolean-cond?)

(define-hrecord-type <until-form> (<dynamic-expression>)
  condition result body)

;; begin
(define-hrecord-type <compound-expression> (<dynamic-expression>)
  subexprs)

;; let, let* ja letrec
;; variables: (uniform-list (pair <variable> <expression>))
;; jälkimmäinen osa alustuslauseke
(define-hrecord-type <let-expression> (<dynamic-expression>)
  readonly-bindings? recursive? order?
  variables body)

(define-hrecord-type <procedure-expression> (<expression>)
  arg-names arg-descs arg-variables result-type
  body s-kind s-name l-module
  pure-proc? force-pure-proc?
  appl-always-returns?
  appl-never-returns?
  static-method?)


(define-hrecord-type <method-definition> (<expression>)
  gen-proc procexpr static-method? declared? old-address include?)


(define-hrecord-type <method-declaration> (<expression>)
  gen-proc method static-method? include?)


(define-hrecord-type <field-ref-expr> (<dynamic-expression>)
  const-field-name? object field-name)


(define-hrecord-type <field-set-expr> (<dynamic-expression>)
  const-field-name? object field-name field-value)


(define-hrecord-type <expr-constructor> (<expression>)
  clas)


(define-hrecord-type <zero-setting-expr> (<expression>)
  var-class zero-proc param?)


(define-hrecord-type <zero-expr> (<expression>)
  clas)


(define-hrecord-type <force-pure-expr> (<dynamic-expression>)
  repr-component)


(define-hrecord-type <prevent-stripping-expr> (<expression>)
  target-address)


(define-hrecord-type <expr-define-syntax> (<expression>)
  address-syntax x-handler)


(define-hrecord-type <assertion-expr> (<dynamic-expression>)
  condition condition-source-expr strong?)


(define-hrecord-type <debug-output-expr> (<dynamic-expression>)
  x-message)


(define (make-var-ref-to-var var)
  (assert (hrecord-is-instance? var <variable>))
  (make-hrecord <variable-reference>
		(hfield-ref var 'type)
		(hfield-ref var 'type-dispatched?)
		(hfield-ref var 'exact-type?)
		(hfield-ref var 'address)
		#t
		(not-null? (hfield-ref var 'value))
		#f
		(hfield-ref var 'value)
		var))


(define is-empty-expr? (get-hrecord-type-predicate <empty-expression>))


;; Nondynamic entities return always.
(define (entity-always-returns? ent)
  (assert (hrecord-is-instance? ent <entity>))
  (if (hrecord-is-instance? ent <dynamic-expression>)
      (hfield-ref ent 'always-returns?)
      #t))


;; Nondynamic entities return always.
(define (entity-never-returns? ent)
  (assert (hrecord-is-instance? ent <entity>))
  (if (hrecord-is-instance? ent <dynamic-expression>)
      (hfield-ref ent 'never-returns?)
      #f))
		
