annotate keiko/util.tcl @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
rev   line source
0
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
1 #
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
2 # util.tcl
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
3 #
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
4 # This file is part of the Oxford Oberon-2 compiler
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
5 # Copyright (c) 2006--2016 J. M. Spivey
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
6 # All rights reserved
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
7 #
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
8 # Redistribution and use in source and binary forms, with or without
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
9 # modification, are permitted provided that the following conditions are met:
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
10 #
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
11 # 1. Redistributions of source code must retain the above copyright notice,
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
12 # this list of conditions and the following disclaimer.
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
13 # 2. Redistributions in binary form must reproduce the above copyright notice,
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
14 # this list of conditions and the following disclaimer in the documentation
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
15 # and/or other materials provided with the distribution.
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
16 # 3. The name of the author may not be used to endorse or promote products
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
17 # derived from this software without specific prior written permission.
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
18 #
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
19 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
20 # IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
21 # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
22 # IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
23 # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
24 # PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
25 # OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
26 # WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
27 # OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
28 # ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
29 #
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
30
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
31 # max -- maximum of any number of args
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
32 proc max {x args} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
33 set max $x
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
34 foreach y $args {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
35 if {$y > $max} {set max $y}
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
36 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
37 return $max
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
38 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
39
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
40 # count -- number of occurrences of a char in a string
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
41 proc count {ch s} {return [regsub -all $ch $s "" dummy]}
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
42
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
43 # lmember -- test for list membership
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
44 proc lmember {x xs} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
45 return [expr {[lsearch -exact $xs $x] >= 0}]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
46 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
47
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
48 # ladd -- add values to a set
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
49 proc ladd {sv args} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
50 upvar $sv s
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
51
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
52 foreach x $args {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
53 if {! [lmember $x $s]} {lappend s $x}
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
54 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
55 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
56
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
57 # lsplit -- split a list into components
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
58 proc lsplit {xs args} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
59 set n [llength $args]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
60
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
61 if {[llength $xs] != $n} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
62 error "expected $n fields, got [llength $xs]"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
63 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
64
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
65 for {set i 0} {$i < $n} {incr i} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
66 uplevel [list set [lindex $args $i] [lindex $xs $i]]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
67 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
68 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
69
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
70 # with -- bind names to record fields in body
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
71 proc with {record fields body} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
72 uplevel [concat [list lsplit $record] $fields]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
73 uplevel $body
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
74 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
75
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
76 # filter -- filter a list by a predicate
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
77 proc filter {p xs} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
78 set ys {}
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
79 foreach x $xs {if {[uplevel $p $x]} {lappend ys $x}}
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
80 return $ys
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
81 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
82
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
83 # exists -- test is a list has any member that satisfies a predicate
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
84 proc exists {p xs} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
85 foreach x $xs {if {[uplevel $p $x]} {return 1}}
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
86 return 0
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
87 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
88
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
89 # map -- apply a function to all elements of a list
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
90 proc map {f xs} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
91 set ys {}
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
92 foreach x $xs {lappend ys [uplevel [concat $f [list $x]]]}
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
93 return $ys
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
94 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
95
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
96 # flatmap -- apply a function to all elements of a list, concatenate results
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
97 proc flatmap {f xs} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
98 set ys {}
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
99 foreach x $xs {set ys [concat $ys [uplevel $f $x]]}
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
100 return $ys
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
101 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
102
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
103 # remdups -- remove adjecent duplicates from a list
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
104 proc remdups {xs} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
105 if {$xs == ""} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
106 return {}
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
107 } else {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
108 set y [lindex $xs 0]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
109 set ys [list $y]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
110 foreach x $xs {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
111 if {$x != $y} {lappend ys $x}
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
112 set y $x
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
113 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
114 return $ys
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
115 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
116 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
117
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
118 # nth_char -- return n'th character of string
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
119 proc nth_char {n string} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
120 return [string index $string $n]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
121 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
122
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
123 # nth_char_is -- test if n'th character of string is a given char
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
124 proc nth_char_is {n ch string} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
125 return [expr {[string index $string $n] == $ch}]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
126 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
127
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
128 # trycatch -- handle exceptions by evaluating alternative script
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
129 proc trycatch {s1 s2} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
130 if {[catch {uplevel $s1}]} {uplevel $s2}
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
131 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
132
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
133 set charcode() 0
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
134 for {set i 1} {$i < 128} {incr i} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
135 set ch [format "%c" $i]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
136 set charcode($ch) $i
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
137 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
138
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
139 # trim -- trim leading and trailing spaces
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
140 proc trim {s} { regexp {^ *(.*[^ ]) *$} $s dummy s; return $s }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
141
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
142 # csym -- make C symbol
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
143 proc csym {k s} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
144 if {$k == ""} {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
145 return [regsub "\\." $s ""]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
146 } else {
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
147 return ${k}_[regsub "\\." $s ""]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
148 }
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
149 }