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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
;; -*-theme-d-*-
;; Copyright (C) 2016-2020 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.
;; Expected results: translation and running OK
(define-proper-program (tests test770)
(import (standard-library core)
(standard-library object-string-conversion)
(standard-library list-utilities)
(standard-library console-io)
(standard-library text-file-io))
(define-virtual-gen-proc initialize)
(define-syntax create2
(syntax-rules ()
((create2 clas arg ...)
(force-pure-expr
(let ((tmp (create clas)))
(initialize tmp arg ...)
tmp)))))
(define-param-logical-type :hash-proc (%key)
(:procedure (%key <integer>) <integer> pure))
(define-param-logical-type :assoc-proc (%key %value)
(:procedure (%key (:alist %key %value)) (:maybe (:pair %key %value))
pure))
(define-param-class :hash-table
(parameters %key %value)
(fields
(v (:maybe (:mutable-vector (:alist %key %value))) public module null)
(proc-hash (:maybe (:hash-proc %key)) public module null)
(proc-assoc (:maybe (:assoc-proc %key %value)) public module null)))
(define-param-virtual-method initialize (%key %value)
(((ht (:hash-table %key %value))
(i-size <integer>)
(proc-hash (:hash-proc %key))
(proc-assoc (:assoc-proc %key %value)))
<none>
nonpure)
(console-display-string "initialize (:hash-table ...)\n")
(field-set! ht 'v (make-mutable-vector (:alist %key %value) i-size null))
(field-set! ht 'proc-hash proc-hash)
(field-set! ht 'proc-assoc proc-assoc))
(define-param-class :logged-hash-table
(parameters %key %value)
(superclass (:hash-table %key %value))
(fields
(op-log (:maybe <output-port>) public module null)))
(define my-hash
(:hash-proc <symbol>)
(unchecked-prim-proc hashv (<symbol> <integer>) <integer> pure))
(define-simple-proc my-assoc (((s-key <symbol>)
(al (:alist <symbol> <string>)))
(:maybe (:pair <symbol> <string>))
pure)
(assoc-objects s-key al null))
(define-param-virtual-method initialize (%key %value)
(((ht (:logged-hash-table %key %value))
(i-size <integer>)
(proc-hash (:hash-proc %key))
(proc-assoc (:assoc-proc %key %value))
(op-log <output-port>))
<none>
nonpure)
(console-display-string "initialize (:logged-hash-table ...)\n")
((generic-proc-dispatch-without-result
initialize
((:hash-table %key %value)
<integer>
(:hash-proc %key)
(:assoc-proc %key %value))
())
ht i-size proc-hash proc-assoc)
(field-set! ht 'op-log op-log))
(define-main-proc (() <none> nonpure)
(let ((ht (create2 (:logged-hash-table <symbol> <string>)
100 my-hash my-assoc (current-output-port))))
(display-line (cast <output-port> (field-ref ht 'op-log))
(mutable-vector-ref
(cast (:mutable-vector (:alist <symbol> <string>))
(field-ref ht 'v))
1)))))
|
