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
64
65
66
67
68
69
|
;; -*-theme-d-*-
;; Copyright (C) 2019, 2021 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 test758)
(import (standard-library core)
(standard-library list-utilities)
(standard-library basic-math)
(standard-library hash-table)
(standard-library console-io))
(define <my-tuple> (:tuple <symbol> <string>))
(define-simple-method my-hash
(((tup <my-tuple>) (i-size <integer>)) <integer> pure)
(remainder (+ (object-hash (car tup) i-size)
(string-hash (car (cdr tup)) i-size))
i-size))
(define-simple-method my-eq?
(((tup1 <my-tuple>) (tup2 <my-tuple>))
<boolean>
pure)
(and
(equal? (tuple-ref tup1 0) (tuple-ref tup2 0))
(equal? (tuple-ref tup1 1) (tuple-ref tup2 1))))
(define-simple-method my-assoc
(((tup-key <my-tuple>) (al (:alist <my-tuple> <integer>)))
(:alt-maybe (:pair <my-tuple> <integer>))
pure)
(assoc-general tup-key al #f my-eq?))
(define-simple-method my-alist-delete
(((tup-key <my-tuple>) (al (:alist <my-tuple> <integer>)))
(:alist <my-tuple> <integer>)
pure)
(general-alist-delete tup-key al my-eq?))
(define-main-proc (() <none> nonpure)
(let ((ht1 (make-object-hash-table 0))
(ht2 (make-string-hash-table 0))
(ht3 (make-hash-table
(static-cast (:hash-proc <my-tuple>) my-hash)
(static-cast (:assoc-proc <my-tuple> <integer>) my-assoc)
(static-cast (:alist-delete-proc <my-tuple> <integer>)
my-alist-delete))))
(hash-set! ht1 'apple 100)
(hash-set! ht1 'orange 50)
(hash-set! ht1 'banana 200)
(hash-set! ht2 "apple" 100)
(hash-set! ht2 "orange" 50)
(hash-set! ht2 "banana" 200)
(hash-set! ht3 (list 'apple "Finland") 100)
(hash-set! ht3 (list 'orange "Italy") 20)
(hash-set! ht3 (list 'cherry "Germany") 50)
(console-display-line (hash-exists? ht1 'apple))
(console-display-line (hash-exists? ht1 'cherry))
(console-display-line (hash-ref ht1 'banana null))
(console-display-line (hash-ref ht1 'cherry null))
(console-display-line (hash-ref ht2 "orange" null))
(console-display-line (hash-ref ht2 "strawberry" null))
(console-display-line (hash-ref ht3 (list 'cherry "Germany") #f))
(console-display-line (hash-ref ht3 (list 'strawberry "Italy") #f)))))
|
