blob: b005b58c1c5bddbe23e605931151814e1da4d374 (
about) (
plain)
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
|
;;; ----------------------------------------------------------------
;;; Eq
;;; ----------------------------------------------------------------
(define (Eq-fns algdata)
(list
(cond ((algdata-enum? algdata)
(**define '== '(|x| |y|)
(**== (**con-number (**var '|x|) algdata)
(**con-number (**var '|y|) algdata))))
(else
(**multi-define '== algdata
;; For nullary constructors
(function **true)
;; For unary constructors
(lambda (v1 v2)
(**== (funcall v1) (funcall v2)))
;; For n-ary constructors
(lambda (v1 v2 bool)
(**and (**== (funcall v1) (funcall v2)) bool))
;; The else clause in case the constructors do
;; not match.
(if (algdata-tuple? algdata)
'#f
(function **false)))))))
;;; ----------------------------------------------------------------
;;; Ord
;;; ----------------------------------------------------------------
(define (Ord-fns algdata)
(list (ord-fn1 algdata '< (function **<))
(ord-fn1 algdata '<= (function **<=))))
(define (Ord-fn1 algdata fn prim)
(cond ((algdata-enum? algdata)
(**define fn '(|x| |y|)
(funcall prim (**con-number (**var '|x|) algdata)
(**con-number (**var '|y|) algdata))))
((algdata-tuple? algdata)
(**multi-define fn algdata
(function **false)
(lambda (x y) (funcall prim (funcall x) (funcall y)))
(function combine-eq-<)
'#f))
(else
(**define fn '(|x| |y|)
(**let
(list
(**multi-define '|inner| algdata
(if (eq? fn '<) (function **false)
(function **true))
(lambda (x y)
(funcall prim (funcall x) (funcall y)))
(function combine-eq-<)
'#f)
(**define '|cx| '() (**con-number (**var '|x|) algdata))
(**define '|cy| '() (**con-number (**var '|y|) algdata)))
(**or (**< (**var '|cx|) (**var '|cy|))
(**and (**== (**var `|cx|) (**var '|cy|))
(**app (**var '|inner|)
(**var '|x|)
(**var '|y|)))))))))
(define (combine-eq-< v1 v2 rest)
(**or (**< (funcall v1) (funcall v2))
(**and (**== (funcall v1) (funcall v2))
rest)))
|