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