;; -*-scheme-*-

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


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


(define empty-list '())

(define source-proper-program-ext ".thp")
(define source-script-ext ".ths")
(define source-interface-ext ".thi")
(define source-body-ext ".thb")
(define pcode-proper-program-ext ".tcp")
(define pcode-script-ext ".tcs")
(define pcode-interface-ext ".tci")
(define pcode-body-ext ".tcb")

(define scheme-file-ext ".scm")
(define tree-il-file-ext ".tree-il")
(define racket-file-ext ".rkt")
(define target-file-ext ".go")

(define gl-i-loc-start 0)

(define gl-sym-default-prim-equal 'eqv?)
(define gl-sym-default-prim-equal-objects 'eqv?)
(define gl-sym-default-prim-equal-contents 'equal?)


(define translate-const-field-ref-fwd '())


(define translate-const-field-set-fwd '())


(define (hrecord-type-inquire lst val)
  (let ((cell (assv val lst)))
    (if cell (cdr cell) #f)))


(define (is-module-name? obj)
  (and
   (list? obj)
   (not-null? obj)
   (and-map? symbol? obj)))


(define (is-user-module-name? obj)
  (or (symbol? obj)
      (and
       (list? obj)
       (not-null? obj)
       (and-map? symbol? obj))))


(define (module-name=? mod1 mod2)
  (assert (is-module-name? mod1))
  (assert (is-module-name? mod2))
  (equal? mod1 mod2))


(define (get-file-name-from-list base-dir lst)
  (assert (string? base-dir))
  (dvar1-set! lst)
  (assert (list? lst))
  (cond
   ((null? lst) base-dir)
   (else (string-append (get-file-name-from-list base-dir (drop-right lst 1))
			"/"
			(symbol->string (car (take-right lst 1)))))))


(define (get-file-name-from-list-and-ext base-dir lst extension)
  (string-append (get-file-name-from-list base-dir lst) extension))


(define (get-actual-module-name mod-name)
  (if (symbol? mod-name) (list mod-name) mod-name))


(define (search-file search-path module-name extension)
  (let ((result #f))
    (do ((cur-lst search-path (cdr cur-lst)))
	((or (null? cur-lst) (not (eqv? result #f))) result)
      (let* ((cur-dir (car cur-lst))
	     (filename
	      (get-file-name-from-list-and-ext cur-dir module-name extension)))
	(if (file-exists? filename)
	    (set! result filename))))))


(define (get-pcode-suffix unit-type)
  (case unit-type
    ((proper-program) pcode-proper-program-ext)
    ((script) pcode-script-ext)
    ((interface) pcode-interface-ext)
    ((body) pcode-body-ext)
    (else (raise 'invalid-unit-type))))


(define (get-source-code-suffix unit-type)
  (case unit-type
    ((proper-program) source-proper-program-ext)
    ((script) source-script-ext)
    ((interface) source-interface-ext)
    ((body) source-body-ext)
    (else (raise 'invalid-unit-type))))


(define (get-filename-extension filename)
  (assert (string? filename))
  (let ((index (string-index-right filename #\.)))
    (if (eqv? index #f)
	""
	(string-take-right filename
			   (- (string-length filename)
			      index)))))


(define (get-variable-value var)
  (hfield-ref var 'value))


;; We don't use big-util because it overlaps with srfi-1.
(define identity (lambda (x) x))


(define (atom? x) (not (pair? x)))


(define (get-filename-without-ext filename)
  (let ((index (string-index-right filename #\.)))
    (if (eqv? index #f)
	filename
	(string-take filename index))))


(define (get-filename-without-path filename)
  (assert (string? filename))
  (let ((index (string-index-right filename #\/)))
    (if (eqv? index #f)
	filename
	(let ((plain-length (- (string-length filename) (+ index 1))))
	  (string-take-right filename plain-length)))))


(define (parse-search-path str default)
  (let ((parsed (split-string str #\:)))
    (map (lambda (item) (if (string-null? item) default item)) parsed)))


(define (get-integer-sequence start count)
  (assert (>= count 0))
  (if (= count 0)
      '()
      (cons start (get-integer-sequence (+ start 1) (- count 1)))))


(define (xor b1 b2)
  (assert (boolean? b1))
  (assert (boolean? b2))
  (not (eq? b1 b2)))


(define (make-list-with-tail elements tl)
  (if (null? elements)
      tl
      (cons (car elements)
	    (make-list-with-tail (cdr elements) tl))))


;; member? returns a boolean value.
(define (member? obj lst)
  (if (member obj lst) #t #f))


;; general-member? returns a boolean value.
(define (general-member? obj lst pred)
  (if (member obj lst pred) #t #f))


(define (distinct-elements? lst eq-pred)
  (if (null? lst)
      #t
      (and
       (not (general-member? (car lst) (cdr lst) eq-pred))
       (distinct-elements? (cdr lst) eq-pred))))


(define-hrecord-type <assoc-list> ()
  contents eq-pred)


(define (make-alo contents eq-pred)
  (make-hrecord <assoc-list> contents eq-pred))


(define (alo-fetch alo obj-key)
  (assoc obj-key (hfield-ref alo 'contents) (hfield-ref alo 'eq-pred)))


;; We don't check if the key already exists.
(define (alo-add-binding-weak! alo obj-key obj-value)
  (hfield-set! alo 'contents
	       (cons (cons obj-key obj-value)
		     (hfield-ref alo 'contents))))
 

(define (alo-delete alo obj-key)
  (hfield-set! alo 'contents
	       (alist-delete obj-key
			     (hfield-ref alo 'contents)
			     (hfield-ref alo 'eq-pred))))


(define is-alo? (get-hrecord-type-predicate <assoc-list>))


(define-hrecord-type <singleton> () element)


(define (singleton-get-element sgt)
  (assert (hrecord-is-instance? sgt <singleton>))
  (hfield-ref sgt 'element))


(define (singleton-set-element! sgt new-element)
  (assert (hrecord-is-instance? sgt <singleton>))
  (hfield-set! sgt 'element new-element))


(define (has-name? ent name)
  (let ((address (hfield-ref ent 'address)))
    (and (not-null? address)
	 (eq? (hfield-ref address 'source-name) name))))


(define (join-strings-with-sep l-str str-sep)
  (if (null? l-str)
      ""
      (let ((str-head (car l-str))
	    (l-tail (cdr l-str)))
	  (if (null? l-tail)
	      str-head
	      (string-append str-head str-sep
			     (join-strings-with-sep l-tail str-sep))))))


(define (symbol-list->string0 lst)
  (cond
   ((null? lst) "")
   ((null? (cdr lst)) (symbol->string (car lst)))
   (else
    (string-append (symbol->string (car lst)) " "
		   (symbol-list->string0 (cdr lst))))))


(define (symbol-list->string lst)
  (string-append "(" (symbol-list->string0 lst) ")"))


(define (equal-pairs? p1 p2)
  (and (eqv? (car p1) (car p2))
       (eqv? (cdr p1) (cdr p2))))


(define (pick5th l)
  (list-ref l 4))
