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

Last change on this file since 12843 was 12843, checked in by Ivan Raikov, 12 years ago

Added initial version of cmk.

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 link 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                    (if link
172                        (##core#inline "C_lstat" path)
173                        (##core#inline "C_stat" path) ) ) ]
174                 [else (##sys#signal-hook #:type-error "bad argument type - not a fixnum or string" file)] ) ] )
175    (when (fx< r 0)
176      (posix-error #:file-error loc "cannot access file" file) ) ) )
177
178(define-foreign-variable _stat_st_ino unsigned-int "C_statbuf.st_ino")
179(define-foreign-variable _stat_st_nlink unsigned-int "C_statbuf.st_nlink")
180(define-foreign-variable _stat_st_size integer64 "C_statbuf.st_size")
181(define-foreign-variable _stat_st_mtime double "C_statbuf.st_mtime")
182(define-foreign-variable _stat_st_atime double "C_statbuf.st_atime")
183(define-foreign-variable _stat_st_ctime double "C_statbuf.st_ctime")
184
185(define (file-size f) (##sys#stat f #f 'file-size) _stat_st_size)
186(define (file-modification-time f) (##sys#stat f #f 'file-modification-time) _stat_st_mtime)
187(define (file-access-time f) (##sys#stat f #f 'file-access-time) _stat_st_atime)
188(define (file-change-time f) (##sys#stat f #f 'file-change-time) _stat_st_ctime)
189
190
191;; End code from unit posix
192
193;; Code from unit files
194
195(define (chop-pds str pds)
196  (and str
197       (let ((len (##sys#size str))
198             (pdslen (if pds (##sys#size pds) 1)))
199         (if (and (fx>= len 1)
200                  (if pds
201                      (##core#inline "C_substring_compare" str pds (fx- len pdslen) 0 pdslen)
202                      (memq (##core#inline "C_subchar" str (fx- len pdslen))
203                            '(#\/ #\\) ) ) )
204             (##sys#substring str 0 (fx- len pdslen))
205             str) ) ) )
206
207(define make-pathname)
208
209(let ([string-append string-append]
210      [absolute-pathname? absolute-pathname?]
211      [def-pds "/"] )
212
213  (define (conc-dirs dirs pds)
214    (##sys#check-list dirs 'make-pathname)
215    (let loop ([strs dirs])
216      (if (null? strs)
217          ""
218          (let ((s1 (car strs)))
219            (if (zero? (string-length s1))
220                (loop (cdr strs))
221                (string-append
222                 (chop-pds (car strs) pds)
223                 (or pds def-pds)
224                 (loop (cdr strs))) ) ) ) ) )
225
226  (define (canonicalize-dirs dirs pds)
227    (cond [(or (not dirs) (null? dirs)) ""]
228          [(string? dirs) (conc-dirs (list dirs) pds)]
229          [else           (conc-dirs dirs pds)] ) )
230
231  (define (_make-pathname loc dir file ext pds)
232    (let ([ext (or ext "")]
233          [file (or file "")]
234          [pdslen (if pds (##sys#size pds) 1)] )
235      (##sys#check-string dir loc)
236      (##sys#check-string file loc)
237      (##sys#check-string ext loc)
238      (when pds (##sys#check-string pds loc))
239      (string-append
240       dir
241       (if (and (fx>= (##sys#size file) pdslen)
242                (if pds
243                    (##core#inline "C_substring_compare" pds file 0 0 pdslen)
244                    (memq (##core#inline "C_subchar" file 0) '(#\\ #\/))))
245           (##sys#substring file pdslen (##sys#size file))
246           file)
247       (if (and (fx> (##sys#size ext) 0)
248                (not (char=? (##core#inline "C_subchar" ext 0) #\.)) )
249           "."
250           "")
251       ext) ) )
252
253  (set! make-pathname
254    (lambda (dirs file #!optional ext pds)
255      (_make-pathname 'make-pathname (canonicalize-dirs dirs pds) file ext pds)))
256  )
257
258;; end code from unit files
259
260
261;;; Like `system', but allows format-string and bombs on nonzero return code:
262
263(define system*
264  (let ([sprintf sprintf]
265        [system system] )
266    (lambda (fstr . args)
267      (let* ([str (apply sprintf fstr args)]
268             [n (system str)] )
269        (unless (zero? n)
270          (##sys#error "shell invocation failed with non-zero return status" str n) ) ) ) ) )
271
272(define (run:execute explist)
273  (define (smooth lst)
274    (let ((slst (map ->string lst)))
275      (string-intersperse (cons (car slst) (cdr slst)) " ") ) )
276  (for-each
277   (lambda (cmd)
278     (when (run-verbose) (printf "  ~A~%~!" cmd))
279     (system* "~a" cmd) )
280   (map smooth explist) ) )
281
282(define-macro (run . explist)
283  `(run:execute (list ,@(map (lambda (x) (list 'quasiquote x)) explist))) )
284
285
286(define (run:execute* explist)
287  (define (smooth lst)
288    (let ((slst (map ->string lst)))
289      (string-intersperse (cons (car slst) (cdr slst)) " ") ) )
290  (for-each
291   (lambda (cmd)
292     (when (run-verbose) (printf "  ~A~%~!" cmd))
293     (system (sprintf "~a" cmd)) )
294   (map smooth explist) ) )
295
296(define-macro (run* . explist)
297  `(run:execute* (list ,@(map (lambda (x) (list 'quasiquote x)) explist))) )
298
299
300(define (ipipe:execute lam cmd)
301  (define (smooth lst)
302    (let ((slst (map ->string lst)))
303      (string-intersperse (cons (car slst) (cdr slst)) " ")))
304  ((lambda (cmd) 
305     (when (run-verbose) (printf "  ~A~%~!" cmd))
306     (with-input-from-pipe (sprintf "~a" cmd) lam))
307   (smooth cmd)))
308
309(define-macro (ipipe lam . explist)
310  `(ipipe:execute ,lam ,@(map (lambda (x) (list 'quasiquote x)) explist)))
311
312
313
314;;; "make" functionality from chicken-setup
315
316(define (make:find-matching-line str spec)
317  (let ((match? (lambda (s) (string=? s str))))
318    (let loop ((lines spec))
319      (cond
320       ((null? lines) #f)
321       (else (let* ((line (car lines))
322                    (names (if (string? (car line))
323                               (list (car line))
324                               (car line))))
325               (if (any match? names)
326                   line
327                   (loop (cdr lines)))))))))
328
329(define (make:form-error s p) (error (sprintf "~a: ~s" s p)))
330(define (make:line-error s p n) (error (sprintf "~a: ~s for line: ~a" s p n)))
331
332(define (make:check-spec spec)
333  (and (or (list? spec) (make:form-error "specification is not a list" spec))
334       (or (pair? spec) (make:form-error "specification is an empty list" spec))
335       (every
336        (lambda (line)
337          (and (or (and (list? line) (<= 2 (length line) 3))
338                   (make:form-error "list is not a list with 2 or 3 parts" line))
339               (or (or (string? (car line))
340                       (and (list? (car line))
341                            (every string? (car line))))
342                   (make:form-error "line does not start with a string or list of strings" line))
343               (let ((name (car line)))
344                 (or (list? (cadr line))
345                     (make:line-error "second part of line is not a list" (cadr line) name)
346                     (every (lambda (dep)
347                               (or (string? dep)
348                                   (make:form-error "dependency item is not a string" dep)))
349                             (cadr line)))
350                 (or (null? (cddr line))
351                     (procedure? (caddr line))
352                     (make:line-error "command part of line is not a thunk" (caddr line) name)))))
353        spec)))
354
355(define (make:check-argv argv)
356  (or (string? argv)
357      (every string? argv)
358      (error "argument is not a string or string list" argv)))
359
360
361(define (make:make/proc/helper spec argv)
362  (when (vector? argv) (set! argv (vector->list argv)))
363  (make:check-spec spec)
364  (make:check-argv argv)
365  (letrec ((made '())
366           (exn? (condition-predicate 'exn))
367           (exn-message (condition-property-accessor 'exn 'message))
368           (make-file
369            (lambda (s indent)
370              (let* ((line (make:find-matching-line s spec))
371                     (date (and (file-exists? s)
372                                (file-modification-time s))))
373                (when (run-verbose)
374                  (printf "make: ~achecking ~a~%" indent s))
375                (if line
376                    (let ((deps (cadr line)))
377                      (for-each (let ((new-indent (string-append " " indent)))
378                                  (lambda (d) (make-file d new-indent)))
379                                deps)
380                      (let ((reason
381                             (or (not date)
382                                 (any (lambda (dep)
383                                        (unless (file-exists? dep)
384                                          (error (sprintf "dependency ~a was not made~%" dep)))
385                                        (and (> (file-modification-time dep) date)
386                                             dep)) 
387                                        deps))))
388                        (when reason
389                          (let ((l (cddr line)))
390                            (unless (null? l)
391                              (set! made (cons s made))
392                              (when (run-verbose)
393                                (printf "make: ~amaking ~a~a~%"
394                                        indent
395                                        s
396                                        (cond
397                                         ((not date)
398                                          (string-append " because " s " does not exist"))
399                                         ((string? reason)
400                                          (string-append " because " reason " changed"))
401                                         (else
402                                          (string-append (sprintf " just because (reason: ~a date: ~a)" 
403                                                                  reason date)))) ) )
404                              (handle-exceptions exn
405                                  (begin
406                                    (printf "make: Failed to make ~a: ~a~%"
407                                            (car line)
408                                            (if (exn? exn)
409                                                (exn-message exn)
410                                                exn))
411                                    (signal exn) )
412                                ((car l))))))))
413                    (unless date
414                      (error (sprintf "don't know how to make ~a" s))))))))
415    (cond
416     ((string? argv) (make-file argv ""))
417     ((null? argv) (make-file (caar spec) ""))
418     (else (for-each (lambda (f) (make-file f "")) argv)))
419    (when (run-verbose)
420      (for-each (lambda (item)
421                  (printf "make: made ~a~%" item))
422        (reverse made)))) )
423
424(define make/proc
425  (case-lambda
426   ((spec) (make:make/proc/helper spec '()))
427   ((spec argv)
428    (make:make/proc/helper
429     spec
430     (if (vector? argv)
431         (vector->list argv)
432         argv) ) ) ) )
433
434;; end make procedures
Note: See TracBrowser for help on using the repository browser.