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



;; *** Translation procedures for both the compiler and the linker ***


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


;; Representation of fields in Theme-D source code.
(define i-field-name 0)
(define i-field-type 1)
(define i-field-read-access 2)
(define i-field-write-access 3)
(define i-source-field-init-value 4)


;; Make a union from expression types
;; rejecting those expressions which never return.
(define (get-union-type-from-expressions binder exprs)
  (let* ((proper-exprs (filter
			(lambda (expr) (not (entity-never-returns? expr)))
			exprs))
	 (types (map get-entity-type proper-exprs)))
    (get-union-of-types0 binder types)))


(define (translate-actual-arglist-type arglist)
  (let* ((arg-types (map
		     (lambda (arg) (get-entity-type arg))
		     arglist)))
    (if (not-null? arg-types)
      (apply make-tuple-type arg-types)
      ;; Formerly we had tt-none here.
      tc-nil)))


(define (get-arglist-type-from-list arg-types)
  (if (not-null? arg-types)
      (apply make-tuple-type arg-types)
      ;; Formerly we had tt-none here.
      tc-nil))


(define (check-arglist-types? binder tt-actual tt-declared)
  (assert (is-binder? binder))
  (let ((decl-none? (entity-is-none1? binder tt-declared)))
    (cond
     (decl-none?
      (entity-is-none1? binder tt-actual))
     ;; The following case should not occur
     ;; since the type of an empty argument list is <nil>.
     ((entity-is-none1? binder tt-actual)
      ;; Formerly we had:
      ;;    (is-t-subtype? binder tc-nil tt-declared))
      decl-none?)
     (else 
      (is-t-subtype? binder tt-actual tt-declared)))))


(define (contains-duplicate-field-names? p-superclass p-new-fields)
  (assert (is-target-object? p-superclass))
  (assert (list? p-new-fields))
  (let* ((existing-fields (tno-field-ref p-superclass 'l-all-fields))
	 (get-name (lambda (field) (tno-field-ref field 's-name)))
	 (existing-field-names (map get-name existing-fields))
	 (new-field-names (map get-name p-new-fields)))
    (or-map? (lambda (field-name)
	       (if (memv field-name existing-field-names) #t #f))
	     new-field-names)))


(set! contains-duplicate-field-names-fwd?
      contains-duplicate-field-names?)


(define (translate-quoted-expression expr)
  (let* ((type (get-primitive-type expr))
	 (to (make-primitive-object type expr)))
    to))


(define (make-new-gen-proc address exported?)
  (let* ((to-clas (make-gen-proc-class-object '()))
	 (name (hfield-ref address 'source-name))
	 (str-name (symbol->string name))
	 (to (make-gen-proc-object to-clas str-name '() address))
	 (var (make-normal-variable
	       address
	       to-clas
	       #t
	       #f
	       #f
	       to
	       exported?)))
    var))


(define (get-method-declaration-repr genproc method-obj static?)
  (assert (is-t-gen-proc? genproc))
  (assert (is-target-object? method-obj))
  (make-hrecord
   <method-declaration>
   tt-none #t #t '()
   #f #f #f '()
   genproc
   method-obj
   static?
   #f))


(define (get-method-definition-repr genproc procexpr static? declared?
				    old-address)
  (assert (is-target-object? genproc))
  (assert (is-entity? procexpr))
  (assert (boolean? declared?))
  (assert (or (null? old-address) (is-address? old-address)))
  (make-hrecord
   <method-definition>
   tt-none
   #t
   #t
   '()
   #f
   #f
   #f
   '()
   genproc
   procexpr
   static?
   declared?
   old-address
   #f))


(define (make-debug-output-expr x-message)
  (make-hrecord <debug-output-expr>
		tt-none #t #t '()
		#f #f #f '()
		#f #f
		x-message))
