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
|
;; -*-theme-d-*-
;; Copyright (C) 2021 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.
(define-body (standard-library mutable-pair)
(import (standard-library string-utilities))
(define-param-method mcons (%type1 %type2)
(((x1 %type1) (x2 %type2)) (:mpair %type1 %type2)
pure)
(create (:mpair %type1 %type2) x1 x2))
(define-param-method mcar (%type1 %type2)
(((mp (:mpair %type1 %type2))) %type1 pure)
(field-ref mp 'head))
(define-param-method mcdr (%type1 %type2)
(((mp (:mpair %type1 %type2))) %type2 pure)
(field-ref mp 'tail))
(define-param-method m-set-car! (%type1 %type2)
(((mp (:mpair %type1 %type2)) (x %type1))
<none> nonpure)
(field-set! mp 'head x))
(define-param-method m-set-cdr! (%type1 %type2)
(((mp (:mpair %type1 %type2)) (x %type2))
<none> nonpure)
(field-set! mp 'tail x))
(define-param-method m-assoc (%key %value %default)
(((key %key) (mal (:mutable-alist %key %value))
(default %default))
(:union (:mpair %key %value) %default)
pure)
(match-type mal
((<null>) default)
((mal1 (:nonempty-mutable-alist %key %value))
(let ((p (car mal1)))
(if (equal? key (mcar p))
p
(m-assoc key (cdr mal1) default))))))
(define-param-method mpair->string (%type1 %type2)
(((mp (:mpair %type1 %type2))) <string> pure)
(string-append
"[ "
(object->string (mcar mp))
" . "
(object->string (mcdr mp))
" ]"))
(include-virtual-methods object->string mpair->string))
|
