1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
;; -*-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-main-proc (() <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"))))
|
