PageRenderTime 83ms CodeModel.GetById 40ms app.highlight 14ms RepoModel.GetById 27ms app.codeStats 0ms

/utils.ss

http://github.com/yinwang0/ydiff
Scheme | 214 lines | 140 code | 51 blank | 23 comment | 0 complexity | 43e28fc3ef6d703814df93ec56fcbba4 MD5 | raw file
  1;; ydiff - a language-aware tool for comparing programs
  2;; Copyright (C) 2011 Yin Wang (yinwang0@gmail.com)
  3
  4
  5;; This program is free software: you can redistribute it and/or modify
  6;; it under the terms of the GNU General Public License as published by
  7;; the Free Software Foundation, either version 3 of the License, or
  8;; (at your option) any later version.
  9
 10;; This program is distributed in the hope that it will be useful,
 11;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 12;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 13;; GNU General Public License for more details.
 14
 15;; You should have received a copy of the GNU General Public License
 16;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 17
 18
 19
 20
 21;-------------------------------------------------------------
 22;                        utilities
 23;-------------------------------------------------------------
 24
 25(define-syntax letv
 26  (syntax-rules ()
 27    [(_ () body ...)
 28     (begin body ...)]
 29    [(_ ([(e1 e2* ...) e3] bd* ...) body ...)
 30     (let-values ([(e1 e2* ...) e3])
 31       (letv (bd* ...) body ...))]
 32    [(_ ([e1 e2] bd* ...) body ...)
 33     (let ([e1 e2])
 34       (letv (bd* ...) body ...))]))
 35
 36
 37(define-syntax first-val
 38  (syntax-rules ()
 39    [(_ e)
 40     (letv ([(x y) e]) x)]))
 41
 42
 43(define-syntax second-val
 44  (syntax-rules ()
 45    [(_ e)
 46     (letv ([(x y) e]) y)]))
 47
 48
 49(define *debug* #f)
 50(define-syntax peek
 51  (syntax-rules ()
 52    [(_ name args ...)
 53     (if *debug*
 54         (begin
 55           (printf "~s: ~s = ~s~n" name 'args args)
 56           ...)
 57         (void))]))
 58
 59
 60;; utility for error reporting
 61(define fatal
 62  (lambda (who . args)
 63    (printf "~s: " who)
 64    (for-each display args)
 65    (display "\n")
 66    (error who "")))
 67
 68
 69; foldl of Racket has a bug!
 70; (foldl (lambda (x y) x) 0 '(1 2 3 4))
 71; => 4
 72; Don't use it!
 73(define foldl2
 74  (lambda (f x ls)
 75    (cond
 76     [(null? ls) x]
 77     [else
 78       (foldl2 f (f x (car ls)) (cdr ls))])))
 79
 80
 81; (foldl2 + 0 '(1 2 3 4 ))
 82
 83
 84
 85(define orf
 86  (lambda (a b)
 87    (or a b)))
 88
 89
 90
 91
 92(define char->string
 93  (lambda (c)
 94    (list->string (list c))))
 95
 96
 97(define read-file
 98  (lambda (filename)
 99    (let ([port (open-input-file filename #:mode 'text)])
100      (let loop ([line (read-line port)]
101                 [all ""])
102        (cond
103         [(eof-object? line) all]
104         [else
105          (loop (read-line port)
106                (string-append all line "\n"))])))))
107
108
109
110(define new-progress
111  (lambda (size)
112    (let ([counter 0])
113      (lambda (x)
114        (cond
115         [(string? x)
116          (display x)
117          (display "\n")
118          (flush-output)]
119         [(= 0 (remainder counter size))
120          (set! counter (+ x counter))
121          (display ".")
122          (flush-output)]
123         [else
124          (set! counter (+ x counter))])))))
125
126
127;;----------------- multi dimensional eq hash --------------------
128
129(define hash-put!
130  (lambda (hash key1 key2 v)
131    (cond
132     [(hash-has-key? hash key2)
133      (let ([inner (hash-ref hash key2)])
134        (hash-set! inner key1 v))]
135     [else
136      (let ([inner (make-hasheq)])
137        (hash-set! inner key1 v)
138        (hash-set! hash key2 inner))])))
139
140(define hash-get
141  (lambda (hash key1 key2)
142    (cond
143     [(hash-has-key? hash key2)
144      (let ([inner (hash-ref hash key2)])
145        (cond
146         [(hash-has-key? inner key1)
147          (hash-ref inner key1)]
148         [else #f]))]
149     [else #f])))
150
151
152(define hash-put2!
153  (lambda (hash key1 key2 v)
154    (cond
155     [(hash-has-key? hash key2)
156      (let ([inner (hash-ref hash key2)])
157        (hash-set! inner key1 v))]
158     [else
159      (let ([inner (make-hash)])
160        (hash-set! inner key1 v)
161        (hash-set! hash key2 inner))])))
162
163(define hash-get2
164  (lambda (hash key1 key2)
165    (cond
166     [(hash-has-key? hash key2)
167      (let ([inner (hash-ref hash key2)])
168        (cond
169         [(hash-has-key? inner key1)
170          (hash-ref inner key1)]
171         [else #f]))]
172     [else #f])))
173
174
175(define predand
176  (lambda preds
177    (lambda (x)
178      (cond
179       [(null? preds) #t]
180       [((car preds) x) 
181        ((apply predand (cdr preds)) x)]
182       [else #f]))))
183
184
185(define predor
186  (lambda preds
187    (lambda (x)
188      (cond
189       [(null? preds) #f]
190       [((car preds) x) #t]
191       [else
192        ((apply predor (cdr preds)) x)]))))
193
194
195(define set-
196  (lambda (s1 s2)
197    (cond
198     [(null? s1) '()]
199     [(memq (car s1) s2)
200      (set- (cdr s1) s2)]
201     [else
202      (cons (car s1) (set- (cdr s1) s2))])))
203
204
205
206(define string-join
207  (lambda (ls sep)
208    (cond
209     [(null? ls) ""]
210     [else 
211      (string-append (car ls) sep (string-join (cdr ls) sep))])))
212
213; (string-join (list "a" "b" "c") ",")
214