;; -*-theme-d-*-

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

;; Expected results: translation and running OK


(define-proper-program (tests test385)

  (import (standard-library core)
	  (standard-library string-utilities)
	  (standard-library console-io))

  (define-simple-proc string-search-from-end
      (((str <string>) (str-match <string>)) <integer> pure)
    (let ((i-len (string-length str))
	  (i-match-len (string-length str-match)))
      (if (> i-match-len i-len)
	  (raise 'string-search-from-end:index-out-of-range)
	  (let-mutable ((i-found <integer> -1))
	    (do ((i1 <integer> (- i-len i-match-len) (- i1 1)))
		((or (< i1 0) (>= i-found 0)) i-found)
	      (if
	       (let-mutable ((success2? <boolean> #t))
		 (do ((i2 <integer> 0 (+ i2 1)))
		     ((or (>= i2 i-match-len) (not success2?)) success2?)
		   (if (not (character=? (string-ref str (+ i1 i2))
					 (string-ref str-match i2)))
		       (set! success2? #f))))
	       (set! i-found i1)))))))

  (define-simple-proc compute-creator-name
      (((str-name <string>) (i-new <integer>) (i-pred-len <integer>))
       <string> pure)
    (assert (>= i-new 0))
    (assert (>= i-pred-len 0))
    (string-append
     (substring str-name 0 i-new)
     "-create"
     (substring str-name (+ i-new i-pred-len) (string-length str-name))))

  (define-simple-proc do-compute-creator-name
      (((str-name <string>) (str-pred <string>))
       <string> pure)
    (let ((i-pred-len (string-length str-pred))
	  (i-new (string-search-from-end str-name str-pred)))
      (if (>= i-new 0)
	  (compute-creator-name str-name i-new i-pred-len)
	  "xxx")))

  (define-simple-proc main (() <none> nonpure)
    (console-display-line (string-search-from-end "gtk-entry-new" "-new"))
    (console-display-line (string-search-from-end "gtk-entry-new" "entry"))
    (console-display-line (string-search-from-end "gtk-entry-new" "abc"))
    (console-display-line (string-search-from-end
			   "gtk-button-new-with-labels"
			   "-new"))
    (console-display-line (do-compute-creator-name "gtk-entry-new" "-new"))
    (console-display-line (do-compute-creator-name "abcdef" "-new"))
    (console-display-line (do-compute-creator-name
			   "gtk-button-new-with-labels" "-new"))))
