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


;; *** Common procedures for target compilation ***


(import (th-scheme-utilities stdutils))


(define gl-i-max-ebv-opt 10)


(define gl-l-prim-pred
  (list (cons tc-nil 'null?)
	(cons tc-symbol 'symbol?)
	(cons tc-boolean 'boolean?)
	(cons tc-real 'is-real?)
	(cons tc-integer 'is-integer?)
	(cons tc-string 'string?)
	(cons tc-char 'char?)))


(define gl-al-prim-equal
  (list (cons tc-nil 'eq?)
	(cons tc-boolean 'eq?)
	(cons tc-integer 'eqv?)
	(cons tc-real 'eqv?)
	(cons tc-symbol 'eq?)
	(cons tc-string 'equal?)
	(cons tc-char 'eqv?)))


(define gl-al-prim-equal-contents gl-al-prim-equal)


(define gl-al-prim-equal-objects
  (list (cons tc-nil 'eq?)
	(cons tc-boolean 'eq?)
	(cons tc-integer 'eqv?)
	(cons tc-real 'eqv?)
	(cons tc-symbol 'eq?)
	(cons tc-string 'eqv?)
	(cons tc-char 'eqv?)))


(define gl-al-target-eq-pred
  (list (cons 'equal-values? 'theme-equal?)
	(cons 'equal-objects? 'theme-equal-objects?)
	(cons 'equal-contents? 'theme-equal-contents?)))


(define (get-equiv-pred s-kind cl)
  (let* ((al
	  (case s-kind
	    ((equal-values?) gl-al-prim-equal)
	    ((equal-objects?) gl-al-prim-equal-objects)
	    ((equal-contents?) gl-al-prim-equal-contents)
	   (else (raise 'internal-error))))
	 (p (assq cl al)))
    (if p (cdr p) #f)))


(define (get-ht-raw-procs linker)
  (hfield-ref (hfield-ref linker 'binder-instantiation) 'ht-raw-procs))


(define (get-target-new-name linker module number source-name)
  (cond
   ((and (not (eqv? module #f)) (>= number 0))
    (let ((i-target-number
	   (let* ((x-actual-module-name (get-actual-module-name module))
		  (i-base (hash-ref
			   (hfield-ref linker 'ht-module-indices)
			   x-actual-module-name)))
	     (if (integer? i-base)
		 (+ i-base number)
		 (raise
		  (list 'variable-numbering-error
			source-name
			number
			x-actual-module-name))))))
      (string->symbol
       (if (not-null? source-name)
	   (string-append "_u_"
			  (number->string i-target-number)
			  "_"
			  (symbol->string source-name))
	   (string-append "_u_"
			  (number->string i-target-number))))))
   ((and (eqv? module #f) (>= number 0))
    (if (null? source-name)
	(string->symbol
	 (string-append "_l_" (number->string number)))
	(string->symbol
	 (string-append "_l_" (number->string number)
			"_" (symbol->string source-name)))))
   ((= number address-number-builtin)
    (assert (eq? module 'builtins))
    (assert (symbol? source-name))
    (string->symbol (string-append "_b_" (symbol->string source-name))))
   ((= number address-number-target)
    source-name)
   (else
    (write-error-info module)
    (write-error-info number)
    (write-error-info source-name)
    (raise 'internal-illegal-var-ref))))


(define (get-target-var-name linker address)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address <address>))
  (let* ((ht-lexical-vars (hfield-ref linker 'ht-lexical-vars))
	 (sym-var-name (address-hash-ref ht-lexical-vars address)))
    (if sym-var-name
	sym-var-name
	(let ((module (hfield-ref address 'module))
	      (number (hfield-ref address 'number))
	      (source-name (hfield-ref address 'source-name)))
	  (assert (or (boolean? module) (eqv? module 'builtins)
		      (is-module-name? module)))
	  (assert (integer? number))
	  (assert (or (null? source-name) (symbol? source-name)))
	  (let ((sym-new-name (get-target-new-name linker module number
						   source-name)))
	    (address-hash-set! ht-lexical-vars address sym-new-name)
	    sym-new-name)))))


(set! get-target-var-name-fwd get-target-var-name)


(define (do-compile-value obj)
  (assert (is-target-object? obj))
  (cond
   ((eqv? obj to-nil) '())
   ((is-t-atomic-object? obj) (get-contents obj))
   ((target-type=? (get-entity-type (get-entity-type obj))
		   tpc-pair)
    (cons (do-compile-value (tno-field-ref obj 'first))
	  (do-compile-value (tno-field-ref obj 'second))))
   (else (raise 'invalid-value-expression))))


(define (param-class-inst-contains-tvars? instance)
  (let* ((to (list-ref instance 1))
	 (tvar-values (tno-field-ref to 'l-tvar-values)))
    (and (not-null? tvar-values)
	 (or-map? contains-type-variables? tvar-values))))


(define (get-let-keyword recursive? order?)
  (cond
   ((and recursive? order?) 'letrec*)
   ((and recursive? (not order?)) 'letrec)
   ;; let* is implemented as a macro so we should not have it here.
   ((and (not recursive?) order?)
    (raise 'invalid-let*)
    'let*)
   (else 'let)))


(define (get-initializer-arg-name index)
  (assert (integer? index))
  (string->symbol (string-append "arg" (number->string index))))


(define (get-constructor-field-args fields)
  (let ((len (length fields))
	(args '()))
    (do ((i 1 (+ i 1)) (cur-lst fields (cdr cur-lst)))
	((null? cur-lst) args)
      (let ((cur-field (car cur-lst)))
	(if (not (tno-field-ref cur-field 'has-init-value?))
	    (set! args
		  (append args (list (get-initializer-arg-name i)))))))))


(define (get-field-index field-name type)
  (let* ((all-fields (tno-field-ref type 'l-all-fields))
	 (index
	  (general-search
	   field-name all-fields
	   (lambda (a b) (eqv? a (tno-field-ref b 's-name))))))
    (if (= index -1)
	(raise (list 'nonexistent-field (cons 's-field-name field-name)))
	(+ index 1))))


(define (get-field field-name clas)
  (let* ((all-fields (tno-field-ref clas 'l-all-fields))
	 (field (find
		 (lambda (fld)
		   (eq? field-name (tno-field-ref fld 's-name)))
		 all-fields)))
    (if (eqv? field #f)
	(raise (list 'nonexistent-field (cons 's-field-name field-name)))
	field)))


(define (alloc-tvar-number-range linker nr-of-tvars)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (integer? nr-of-tvars))
  (let ((start (hfield-ref linker 'next-tvar-number)))
    (hfield-set! linker 'next-tvar-number
		 (+ start nr-of-tvars))
    start))


;; We use param-cache-parsing here because the target compilation
;; uses data structures created in implementation pseudocode reading.
;; Data structures created during instantiation are discarded.
(define (get-binder-for-tc linker)
  (hfield-ref linker 'binder-parsing))


(define (linker-entity-is-none? linker ent)
  (entity-is-none1? (get-binder-for-tc linker) ent))


(define (is-simple-arg-list2? arg-descs)
  ;; The following expression is #t for an empty list.
  (not (or-map? (lambda (ent)
		  (or (is-t-rest? ent) (is-t-splice? ent)))
		arg-descs)))


(define (is-simple-arg-list-with-tail? arg-descs)
  (and (not-null? arg-descs)
       (let ((ent-last (last arg-descs)))
	 (or (is-t-rest? ent-last) (is-t-splice? ent-last)))
       ;; The following expression is #t for a single element list.
       (not (or-map? (lambda (ent)
		       (or (is-t-rest? ent) (is-t-splice? ent)))
		     (drop-right arg-descs 1)))))


(define (get-gensyms linker lst-args)
  (map (lambda (arg)
	 (get-target-var-name linker (hfield-ref arg 'address)))
       lst-args))
