source: project/release/3/cmk/cmk-utils.scm @ 18200

Last change on this file since 18200 was 12851, checked in by iraikov, 11 years ago

Some fixes to mingw build.

File size: 13.4 KB
Line 
1
2;; from srfi-1
3
4;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an)))
5;;; (cons* a1) = a1     (cons* a1 a2 ...) = (cons a1 (cons* a2 ...))
6;;;
7;;; (cons first (unfold not-pair? car cdr rest values))
8
9(define (cons* first . rest)
10  (let recur ((x first) (rest rest))
11    (if (pair? rest)
12        (cons x (recur (car rest) (cdr rest)))
13        x)))
14
15(define (every pred lis1)
16;  (check-arg procedure? pred every)
17      ;; Fast path
18      (or (null-list? lis1)
19          (let lp ((head (car lis1))  (tail (cdr lis1)))
20            (if (null-list? tail)
21                (pred head)     ; Last PRED app is tail call.
22                (and (pred head) (lp (car tail) (cdr tail)))))))
23
24(define (any pred lis1)
25
26      ;; Fast path
27      (and (not (null-list? lis1))
28           (let lp ((head (car lis1)) (tail (cdr lis1)))
29             (if (null-list? tail)
30                 (pred head)            ; Last PRED app is tail call.
31                 (or (pred head) (lp (car tail) (cdr tail)))))))
32
33
34;; This FILTER shares the longest tail of L that has no deleted elements.
35;; If Scheme had multi-continuation calls, they could be made more efficient.
36
37(define (filter pred lis)                       ; Sleazing with EQ? makes this
38;  (check-arg procedure? pred filter)           ; one faster.
39  (let recur ((lis lis))               
40    (if (null-list? lis) lis                    ; Use NOT-PAIR? to handle dotted lists.
41        (let ((head (car lis))
42              (tail (cdr lis)))
43          (if (pred head)
44              (let ((new-tail (recur tail)))    ; Replicate the RECUR call so
45                (if (eq? tail new-tail) lis
46                    (cons head new-tail)))
47              (recur tail))))))                 ; this one can be a tail call.
48
49
50;;; Map F across L, and save up all the non-false results.
51(define (filter-map f lis1)
52  ;; Fast path.
53  (let recur ((lis lis1))
54    (if (null-list? lis) lis
55        (let ((tail (recur (cdr lis))))
56          (cond ((f (car lis)) => (lambda (x) (cons x tail)))
57                (else tail))))))
58
59
60;; end srfi-1
61
62;; from srfi-13
63
64;;; STRING-CONCATENATE & STRING-CONCATENATE/SHARED are passed a list of
65;;; strings, which they concatenate into a result string. STRING-CONCATENATE
66;;; always allocates a fresh string; STRING-CONCATENATE/SHARED may (or may
67;;; not) return a result that shares storage with any of its arguments. In
68;;; particular, if it is applied to a singleton list, it is permitted to
69;;; return the car of that list as its value.
70
71
72;;; Here it is written out. I avoid using REDUCE to add up string lengths
73;;; to avoid non-R5RS dependencies.
74(define (string-concatenate strings)
75  (let* ((total (do ((strings strings (cdr strings))
76                     (i 0 (+ i (string-length (car strings)))))
77                    ((not (pair? strings)) i)))
78         (ans (make-string total)))
79    (let lp ((i 0) (strings strings))
80      (if (pair? strings)
81          (let* ((s (car strings))
82                 (slen (string-length s)))
83            (%string-copy! ans i s 0 slen)
84            (lp (+ i slen) (cdr strings)))))
85    ans))
86         
87;; end srfi-13
88
89(define (s+ . lst)    (string-concatenate (map ->string lst)))
90(define (sw+ lst)     (string-intersperse (filter-map (lambda (x) (and x (->string x))) lst) " "))
91(define nl "\n")
92
93(define ($ x) (if (string? x) (string->symbol x) x))
94
95(define (pcmd$ p x) 
96  (if p (string->symbol (string-append (map ->string (list p "-" x))))
97      (string->symbol (->string x))))
98
99(define (lookup-def k lst . rest)
100  (let-optionals rest ((default #f))
101      (let ((kv (assoc k lst)))
102        (if (not kv) default
103            (match kv ((k v) v) (else (cdr kv)))))))
104
105(define (pv p . rest)
106  (let ((v (p)))
107    (if (procedure? v) (apply v rest) 
108        v)))
109
110
111
112;; Code from unit posix
113
114(define current-directory
115  (let ([make-string make-string])
116    (lambda (#!optional dir)
117      (if dir
118          (change-directory dir)
119          (let* ([buffer (make-string 256)]
120                 [len (##core#inline "C_curdir" buffer)] )
121            (##sys#update-errno)
122            (if len
123                (##sys#substring buffer 0 len)
124                (##sys#signal-hook #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )
125
126
127(define (mode arg) (if (pair? arg) (##sys#slot arg 0) '###text))
128(define (badmode m) (##sys#error "illegal input/output mode specifier" m))
129
130(define (check cmd inp r)
131  (##sys#update-errno)
132  (if (##sys#null-pointer? r)
133      (##sys#signal-hook #:file-error "cannot open pipe" cmd)
134      (let ([port (##sys#make-port inp ##sys#stream-port-class "(pipe)" 'stream)])
135        (##core#inline "C_set_file_ptr" port r)
136        port) ) )
137
138(define (open-input-pipe cmd . m)
139  (##sys#check-string cmd 'open-input-pipe)
140  (let ([m (mode m)])
141    (check
142     cmd #t
143     (case m
144       ((###text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd)))
145       ((###binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd)))
146       (else (badmode m))))))
147
148(define (close-input-pipe port)
149  (lambda (port)
150    (##sys#check-port port 'close-input-pipe)
151    (let ((r (##core#inline "close_pipe" port)))
152      (when (eq? -1 r) (posix-error #:file-error 'close-input/output-pipe "error while closing pipe" port))
153      r) ) )
154
155(define with-input-from-pipe
156    (lambda (cmd thunk . mode)
157      (let ([old ##sys#standard-input]
158            [p (apply open-input-pipe cmd mode)] )
159        (set! ##sys#standard-input p)
160        (##sys#call-with-values thunk
161          (lambda results
162            (close-input-pipe p)
163            (set! ##sys#standard-input old)
164            (apply values results) ) ) ) ) )
165
166
167(define (##sys#stat file loc)
168  (let ([r (cond [(fixnum? file) (##core#inline "C_fstat" file)]
169                 [(string? file)
170                  (let ([path (##sys#make-c-string (##sys#expand-home-path file))])
171                        (##core#inline "C_stat" path) ) ]
172                 [else (##sys#signal-hook #:type-error "bad argument type - not a fixnum or string" file)] ) ] )
173    (when (fx< r 0)
174      (posix-error #:file-error loc "cannot access file" file) ) ) )
175
176(define-foreign-variable _stat_st_ino unsigned-int "C_statbuf.st_ino")
177(define-foreign-variable _stat_st_nlink unsigned-int "C_statbuf.st_nlink")
178(define-foreign-variable _stat_st_size integer64 "C_statbuf.st_size")
179(define-foreign-variable _stat_st_mtime double "C_statbuf.st_mtime")
180(define-foreign-variable _stat_st_atime double "C_statbuf.st_atime")
181(define-foreign-variable _stat_st_ctime double "C_statbuf.st_ctime")
182
183(define (file-size f) (##sys#stat f 'file-size) _stat_st_size)
184(define (file-modification-time f) (##sys#stat f 'file-modification-time) _stat_st_mtime)
185(define (file-access-time f) (##sys#stat f 'file-access-time) _stat_st_atime)
186(define (file-change-time f) (##sys#stat f 'file-change-time) _stat_st_ctime)
187
188
189;; End code from unit posix
190
191;; Code from unit files
192
193(define (chop-pds str pds)
194  (and str
195       (let ((len (##sys#size str))
196             (pdslen (if pds (##sys#size pds) 1)))
197         (if (and (fx>= len 1)
198                  (if pds
199                      (##core#inline "C_substring_compare" str pds (fx- len pdslen) 0 pdslen)
200                      (memq (##core#inline "C_subchar" str (fx- len pdslen))
201                            '(#\/ #\\) ) ) )
202             (##sys#substring str 0 (fx- len pdslen))
203             str) ) ) )
204
205(define make-pathname)
206
207(let ([string-append string-append]
208      [absolute-pathname? absolute-pathname?]
209      [def-pds "/"] )
210
211  (define (conc-dirs dirs pds)
212    (##sys#check-list dirs 'make-pathname)
213    (let loop ([strs dirs])
214      (if (null? strs)
215          ""
216          (let ((s1 (car strs)))
217            (if (zero? (string-length s1))
218                (loop (cdr strs))
219                (string-append
220                 (chop-pds (car strs) pds)
221                 (or pds def-pds)
222                 (loop (cdr strs))) ) ) ) ) )
223
224  (define (canonicalize-dirs dirs pds)
225    (cond [(or (not dirs) (null? dirs)) ""]
226          [(string? dirs) (conc-dirs (list dirs) pds)]
227          [else           (conc-dirs dirs pds)] ) )
228
229  (define (_make-pathname loc dir file ext pds)
230    (let ([ext (or ext "")]
231          [file (or file "")]
232          [pdslen (if pds (##sys#size pds) 1)] )
233      (##sys#check-string dir loc)
234      (##sys#check-string file loc)
235      (##sys#check-string ext loc)
236      (when pds (##sys#check-string pds loc))
237      (string-append
238       dir
239       (if (and (fx>= (##sys#size file) pdslen)
240                (if pds
241                    (##core#inline "C_substring_compare" pds file 0 0 pdslen)
242                    (memq (##core#inline "C_subchar" file 0) '(#\\ #\/))))
243           (##sys#substring file pdslen (##sys#size file))
244           file)
245       (if (and (fx> (##sys#size ext) 0)
246                (not (char=? (##core#inline "C_subchar" ext 0) #\.)) )
247           "."
248           "")
249       ext) ) )
250
251  (set! make-pathname
252    (lambda (dirs file #!optional ext pds)
253      (_make-pathname 'make-pathname (canonicalize-dirs dirs pds) file ext pds)))
254  )
255
256;; end code from unit files
257
258
259;;; Like `system', but allows format-string and bombs on nonzero return code:
260
261(define system*
262  (let ([sprintf sprintf]
263        [system system] )
264    (lambda (fstr . args)
265      (let* ([str (apply sprintf fstr args)]
266             [n (system str)] )
267        (unless (zero? n)
268          (##sys#error "shell invocation failed with non-zero return status" str n) ) ) ) ) )
269
270(define (run:execute explist)
271  (define (smooth lst)
272    (let ((slst (map ->string lst)))
273      (string-intersperse (cons (car slst) (cdr slst)) " ") ) )
274  (for-each
275   (lambda (cmd)
276     (when (run-verbose) (printf "  ~A~%~!" cmd))
277     (system* "~a" cmd) )
278   (map smooth explist) ) )
279
280(define-macro (run . explist)
281  `(run:execute (list ,@(map (lambda (x) (list 'quasiquote x)) explist))) )
282
283
284(define (run:execute* explist)
285  (define (smooth lst)
286    (let ((slst (map ->string lst)))
287      (string-intersperse (cons (car slst) (cdr slst)) " ") ) )
288  (for-each
289   (lambda (cmd)
290     (when (run-verbose) (printf "  ~A~%~!" cmd))
291     (system (sprintf "~a" cmd)) )
292   (map smooth explist) ) )
293
294(define-macro (run* . explist)
295  `(run:execute* (list ,@(map (lambda (x) (list 'quasiquote x)) explist))) )
296
297
298(define (ipipe:execute lam cmd)
299  (define (smooth lst)
300    (let ((slst (map ->string lst)))
301      (string-intersperse (cons (car slst) (cdr slst)) " ")))
302  ((lambda (cmd) 
303     (when (run-verbose) (printf "  ~A~%~!" cmd))
304     (with-input-from-pipe (sprintf "~a" cmd) lam))
305   (smooth cmd)))
306
307(define-macro (ipipe lam . explist)
308  `(ipipe:execute ,lam ,@(map (lambda (x) (list 'quasiquote x)) explist)))
309
310
311
312;;; "make" functionality from chicken-setup
313
314(define (make:find-matching-line str spec)
315  (let ((match? (lambda (s) (string=? s str))))
316    (let loop ((lines spec))
317      (cond
318       ((null? lines) #f)
319       (else (let* ((line (car lines))
320                    (names (if (string? (car line))
321                               (list (car line))
322                               (car line))))
323               (if (any match? names)
324                   line
325                   (loop (cdr lines)))))))))
326
327(define (make:form-error s p) (error (sprintf "~a: ~s" s p)))
328(define (make:line-error s p n) (error (sprintf "~a: ~s for line: ~a" s p n)))
329
330(define (make:check-spec spec)
331  (and (or (list? spec) (make:form-error "specification is not a list" spec))
332       (or (pair? spec) (make:form-error "specification is an empty list" spec))
333       (every
334        (lambda (line)
335          (and (or (and (list? line) (<= 2 (length line) 3))
336                   (make:form-error "list is not a list with 2 or 3 parts" line))
337               (or (or (string? (car line))
338                       (and (list? (car line))
339                            (every string? (car line))))
340                   (make:form-error "line does not start with a string or list of strings" line))
341               (let ((name (car line)))
342                 (or (list? (cadr line))
343                     (make:line-error "second part of line is not a list" (cadr line) name)
344                     (every (lambda (dep)
345                               (or (string? dep)
346                                   (make:form-error "dependency item is not a string" dep)))
347                             (cadr line)))
348                 (or (null? (cddr line))
349                     (procedure? (caddr line))
350                     (make:line-error "command part of line is not a thunk" (caddr line) name)))))
351        spec)))
352
353(define (make:check-argv argv)
354  (or (string? argv)
355      (every string? argv)
356      (error "argument is not a string or string list" argv)))
357
358
359(define (make:make/proc/helper spec argv)
360  (when (vector? argv) (set! argv (vector->list argv)))
361  (make:check-spec spec)
362  (make:check-argv argv)
363  (letrec ((made '())
364           (exn? (condition-predicate 'exn))
365           (exn-message (condition-property-accessor 'exn 'message))
366           (make-file
367            (lambda (s indent)
368              (let* ((line (make:find-matching-line s spec))
369                     (date (and (file-exists? s)
370                                (file-modification-time s))))
371                (when (run-verbose)
372                  (printf "make: ~achecking ~a~%" indent s))
373                (if line
374                    (let ((deps (cadr line)))
375                      (for-each (let ((new-indent (string-append " " indent)))
376                                  (lambda (d) (make-file d new-indent)))
377                                deps)
378                      (let ((reason
379                             (or (not date)
380                                 (any (lambda (dep)
381                                        (unless (file-exists? dep)
382                                          (error (sprintf "dependency ~a was not made~%" dep)))
383                                        (and (> (file-modification-time dep) date)
384                                             dep)) 
385                                        deps))))
386                        (when reason
387                          (let ((l (cddr line)))
388                            (unless (null? l)
389                              (set! made (cons s made))
390                              (when (run-verbose)
391                                (printf "make: ~amaking ~a~a~%"
392                                        indent
393                                        s
394                                        (cond
395                                         ((not date)
396                                          (string-append " because " s " does not exist"))
397                                         ((string? reason)
398                                          (string-append " because " reason " changed"))
399                                         (else
400                                          (string-append (sprintf " just because (reason: ~a date: ~a)" 
401                                                                  reason date)))) ) )
402                              (handle-exceptions exn
403                                  (begin
404                                    (printf "make: Failed to make ~a: ~a~%"
405                                            (car line)
406                                            (if (exn? exn)
407                                                (exn-message exn)
408                                                exn))
409                                    (signal exn) )
410                                ((car l))))))))
411                    (unless date
412                      (error (sprintf "don't know how to make ~a" s))))))))
413    (cond
414     ((string? argv) (make-file argv ""))
415     ((null? argv) (make-file (caar spec) ""))
416     (else (for-each (lambda (f) (make-file f "")) argv)))
417    (when (run-verbose)
418      (for-each (lambda (item)
419                  (printf "make: made ~a~%" item))
420        (reverse made)))) )
421
422(define make/proc
423  (case-lambda
424   ((spec) (make:make/proc/helper spec '()))
425   ((spec argv)
426    (make:make/proc/helper
427     spec
428     (if (vector? argv)
429         (vector->list argv)
430         argv) ) ) ) )
431
432;; end make procedures
Note: See TracBrowser for help on using the repository browser.