-
Notifications
You must be signed in to change notification settings - Fork 1
/
util.scm
142 lines (127 loc) · 4.82 KB
/
util.scm
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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
;; ---------------------------------------------------------------------- ;;
;; FICHIER : util.scm ;;
;; DATE DE CREATION : Mon May 29 09:58:52 1995 ;;
;; DERNIERE MODIFICATION : Mon May 29 10:01:34 1995 ;;
;; ---------------------------------------------------------------------- ;;
;; Copyright (c) 1995 Dominique Boucher ;;
;; ---------------------------------------------------------------------- ;;
;; Miscellaneous functions and variables ... ;;
;; ---------------------------------------------------------------------- ;;
;; ---------------------------------------------------------------------- ;;
;; A few constants ... ;;
;; ---------------------------------------------------------------------- ;;
(define $all-keys-node (make-all-keys))
(define $the-empty-list (make-instance #f #f))
(define $the-true-value (make-instance #f #t))
(define $the-false-value (make-instance #f #f))
(define $non-initialized '(uninitialized))
(define $unbound '(unbound))
(define vertical-bar (string->symbol "|"))
;; ---------------------------------------------------------------------- ;;
;; Used in parser.scm ... ;;
;; ---------------------------------------------------------------------- ;;
(define (insert-in-condition-clause! x c)
(cond-clause-matches-set! c (cons x (cond-clause-matches c))))
;; ---------------------------------------------------------------------- ;;
;; Sorted insertion function ;;
;; ---------------------------------------------------------------------- ;;
(define (sinsert elem lst)
(let loop ((l1 lst))
(if (null? l1)
(cons elem l1)
(let ((x (car l1)))
(cond ((< elem x)
(cons elem l1))
((> elem x)
(cons x (loop (cdr l1))))
(else
l1))))))
;; ---------------------------------------------------------------------- ;;
;; The operator precedence list ... ;;
;; ---------------------------------------------------------------------- ;;
(define $precedence-list
(list
(cons '^ 2)
(cons '* 3) (cons '/ 3)
(cons '+ 4) (cons '- 4)
(cons '= 5) (cons '== 5) (cons '~= 5) (cons '< 5) (cons '> 5)
(cons '<= 5) (cons '>= 5)
(cons '& 6) (cons vertical-bar 6)
(cons ':= 7)))
(define (op->precedence op)
(cdr (assq op $precedence-list)))
(define (binop-series->expr lst)
(define (make-node v1 op v2)
(let ((name (binary-op-name op)))
(cond
((eq? name ':=)
(make-assignment v1 v2))
((eq? name '&)
(make-and-expr v1 v2))
((eq? name vertical-bar)
(make-or-expr v1 v2))
(else
(make-funcall (make-ast-symbol name) (list v1 v2))))))
(define (make-exprn val-stack op-stack pr-stack lst)
(if (null? op-stack)
(if (null? lst)
(car val-stack)
(let* ((op (car lst))
(pr (op->precedence (binary-op-name op)))
(val (cadr lst)))
(make-exprn (cons val val-stack)
(cons op op-stack)
(cons pr pr-stack)
(cddr lst))))
(if (null? lst)
(let ((node (make-node (cadr val-stack) (car op-stack) (car val-stack))))
(make-exprn (cons node (cddr val-stack))
(cdr op-stack)
(cdr op-stack)
lst))
(let* ((r-op (car lst))
(l-op (car op-stack))
(r-pr (op->precedence (binary-op-name r-op)))
(l-pr (car pr-stack))
(r-val (cadr lst))
(rest (cddr lst)))
(cond
((< r-pr l-pr)
(make-exprn (cons r-val val-stack)
(cons r-op op-stack)
(cons r-pr pr-stack)
rest))
((> r-pr l-pr)
(let* ((l-val1 (cadr val-stack))
(l-val2 (car val-stack))
(node (make-node l-val1 l-op l-val2))
(val-rest (cddr val-stack)))
(make-exprn (cons node val-rest)
(cdr op-stack)
(cdr pr-stack)
lst)))
(else ; r-pr = l-pr
(if (eq? (binary-op-name r-op) ':=)
(make-exprn (cons r-val val-stack)
(cons r-op op-stack)
(cons r-pr pr-stack)
rest)
(let* ((l-val1 (cadr val-stack))
(l-val2 (car val-stack))
(node (make-node l-val1 l-op l-val2))
(val-rest (cddr val-stack)))
(make-exprn (cons node val-rest)
(cdr op-stack)
(cdr pr-stack)
lst)))))))))
(make-exprn (list (car lst)) '() '() (cdr lst)))
;; ---------------------------------------------------------------------- ;;
;; The filter function ... ;;
;; ---------------------------------------------------------------------- ;;
(define (filter pred l)
(if (null? l)
'()
(let ((elt (car l)))
(if (pred elt)
(cons elt (filter pred (cdr l)))
(filter pred (cdr l))))))