source: project/chicken/branches/prerelease/scripts/tools.scm @ 13859

Last change on this file since 13859 was 13859, checked in by felix winkelmann, 11 years ago

merged trunk rev. 13858 (not including srandom change)

File size: 13.3 KB
Line 
1;;;; tools.scm
2
3
4(use (srfi 1) posix utils files)
5
6
7(define *verbose* (##sys#fudge 13))
8(define *dependencies* (make-hash-table string=?))
9(define *variables* (make-hash-table string=?))
10(define *actions* (make-hash-table string=?))
11(define *pseudo-targets* '())
12(define *sleep-delay* 2)
13
14(define *windows-shell*
15  (memq (build-platform) '(mingw32 msvc)))
16
17
18;;; Verbosity and output
19
20(define *tty* 
21  (and (##sys#tty-port? (current-output-port)) 
22       (not (equal? (getenv "EMACS") "t"))
23       (not (equal? (getenv "TERM") "dumb"))))
24
25(define *tty-width*
26  (or (and *tty* 
27           (with-input-from-pipe "stty size 2>/dev/null"
28             (lambda () (read) (read))))
29      72))
30
31(define *info-message-escape* (if *tty* "\x1b[0m\x1b[2m" ""))
32(define *target-message-escape* (if *tty* "\x1b[0m\x1b[32m" ""))
33(define *error-message-escape* (if *tty* "\x1b[0m\x1b[31m" ""))
34(define *command-message-escape* (if *tty* "\x1b[0m\x1b[33m" ""))
35(define *reset-escape* (if *tty* "\x1b[0m" ""))
36
37(define (format-message msg #!optional (nl #t))
38  (if (or *verbose* (not *tty*))
39      ((if nl print print*) msg)
40      (for-each
41       (lambda (ln)
42         (printf "\r\x1b[K~a~!"
43                 (if (>= (string-length ln) (sub1 *tty-width*))
44                     (string-append
45                      (substring ln 0 (- *tty-width* 5))
46                      "...")
47                     ln) ) )
48       (string-split msg "\n")) ) )
49
50(define (message fstr . args)
51  (when *verbose*
52    (format-message (sprintf "~a* ~?~a " *info-message-escape* fstr args *reset-escape*)) ) )
53
54(define (message* fstr . args)
55  (when *verbose*
56    (format-message (sprintf "~a* ~?~a " *info-message-escape* fstr args *reset-escape*) #f) ) )
57
58(define (target-message fstr . args)
59  (format-message (sprintf "~a~?~a " *target-message-escape* fstr args *reset-escape*)))
60
61(define (command-message fstr . args)
62  (when *verbose*
63    (format-message (sprintf "~a  ~?~a " *command-message-escape* fstr args *reset-escape*))) )
64
65(define (error-message fstr . args)
66  (sprintf "~%~a~?~a~%" *error-message-escape* fstr args *reset-escape*))
67
68(define (quit fstr . args)
69  (display (apply error-message fstr args) (current-error-port))
70  (reset) )
71
72(define (cleanup-output)
73  (when (and (not *verbose*) *tty*)
74    (printf "\r\x1b[0m\x1b[K~!") ) )
75
76
77;;; make-code stolen from PLT
78
79(define (find-matching-line str spec)
80  (let ([match? (lambda (s) (string=? s str))])
81    (let loop ([lines spec])
82      (cond
83       [(null? lines) #f]
84       [else (let* ([line (car lines)]
85                    [names (if (string? (car line))
86                               (list (car line))
87                               (car line))])
88               (if (ormap match? names)
89                   line
90                   (loop (cdr lines))))]))))
91
92(define (form-error s p) (quit "~a: ~s" s p))
93(define (line-error s p n) (quit "~a: ~s in line ~a" s p))
94
95(define (check-spec spec)
96  (and (or (list? spec) (form-error "specification is not a list" spec))
97       (or (pair? spec) (form-error "specification is an empty list" spec))
98       (andmap
99        (lambda (line)
100          (and (or (and (list? line) (<= 2 (length line) 3))
101                   (form-error "list is not a list with 2 or 3 parts" line))
102               (or (or (string? (car line))
103                       (and (list? (car line))
104                            (andmap string? (car line))))
105                   (form-error "line does not start with a string or list of strings" line))
106               (let ([name (car line)])
107                 (or (list? (cadr line))
108                     (line-error "second part of line is not a list" (cadr line) name)
109                     (andmap (lambda (dep)
110                               (or (string? dep)
111                                   (form-error "dependency item is not a string" dep)))
112                             (cadr line)))
113                 (or (null? (cddr line))
114                     (procedure? (caddr line))
115                     (line-error "command part of line is not a thunk" (caddr line) name)))))
116        spec)))
117
118(define (check-argv argv)
119  (or (string? argv)
120      (and (vector? argv)
121           (andmap string? (vector->list argv)))
122      (error "argument is not a string or string vector" argv)))
123
124(define (make/proc/helper spec argv)
125  (check-spec spec)
126  (check-argv argv)
127  (letrec ([made '()]
128           [exn? (condition-predicate 'exn)]
129           [exn-message (condition-property-accessor 'exn 'message)]
130           [make-file
131            (lambda (s indent)
132              (let ([line (find-matching-line s spec)]
133                    [date (and (not (member s *pseudo-targets*))
134                               (file-exists? s)
135                               (file-modification-time s))])
136                (if line
137                    (let ([deps (cadr line)])
138                      (for-each (let ([new-indent (string-append " " indent)])
139                                  (lambda (d) (make-file d new-indent)))
140                                deps)
141                      (let ([reason
142                             (or (not date)
143                                 (ormap (lambda (dep)
144                                          (unless (file-exists? dep)
145                                            (quit "dependancy ~a was not made~%" dep))
146                                          (and (> (file-modification-time dep) date)
147                                               dep))
148                                        deps))])
149                        (when reason
150                          (let ([l (cddr line)])
151                            (unless (null? l)
152                              (set! made (cons s made))
153                              ((car l)))))))
154                    (when (not date) 
155                      (quit "don't know how to make ~a" s)))))])
156    (cond
157     [(string? argv) (make-file argv "")]
158     [(equal? argv '#()) (make-file (caar spec) "")]
159     [else (for-each (lambda (f) (make-file f "")) (vector->list argv))]) ) )
160
161(define make/proc
162  (case-lambda
163   [(spec) (make/proc/helper spec '#())]
164   [(spec argv) (make/proc/helper spec argv)]))
165
166
167;;; Run subcommands
168
169(define (execute exps)
170  (for-each
171   (lambda (exp)
172     (let ((cmd (string-intersperse (map ->string (flatten exps)))))
173       (command-message "~A" cmd)
174       (let ((s (system cmd)))
175         (unless (zero? s)
176           (quit (sprintf "invocation of command failed with non-zero exit-status ~a: ~a~%" s cmd) s) ) ) ) )
177   exps) )
178
179(define-syntax run
180  (syntax-rules ()
181    ((_ exp ...)
182     (execute (list `exp ...)))))
183
184
185;;; String and path helper functions
186
187(define (prefix dir . files)
188  (if (null? files)
189      (pathname-directory dir)
190      (let ((files2 (map (cut make-pathname dir <>) (normalize files))))
191        (if (or (pair? (cdr files)) (pair? (car files)))
192            files2
193            (car files2) ) ) ) )
194
195(define (suffix suf . files)
196  (if (null? files)
197      (pathname-extension suf)
198      (let ((files2 (map (cut pathname-replace-extension <> suf) (normalize files))))
199        (if (or (pair? (cdr files)) (pair? (car files)))
200            files2
201            (car files2) ) ) ) )
202
203(define (normalize fs)
204  (delete-duplicates
205   (map ->string
206        (if (pair? fs)
207            (flatten fs)
208            (list fs) ) )
209   equal?) )
210
211(define path make-pathname)
212
213
214;;; "Stateful" build interface
215
216(define (build-clear)
217  (set! *dependencies* (make-hash-table string=?)) 
218  (set! *actions* (make-hash-table string=?)) 
219  (set! *variables* (make-hash-table string=?)) )
220
221(define (depends target . deps)
222  (let ((deps (normalize deps)))
223    (hash-table-update!
224     *dependencies* target
225     (lambda (old) (lset-union string=? old deps))
226     (lambda () deps) ) ) )
227
228(define actions
229  (let ((doaction 
230          (lambda (name target proc)
231            (hash-table-update! *dependencies* target identity (constantly '()))
232            (hash-table-set! 
233             *actions* target 
234             (lambda ()
235               (target-message "~a\t~a" name target)
236               (proc) ) ) ) ) )
237    (case-lambda
238     ((target proc) (doaction "build " target proc))
239     ((name target proc) (doaction name target proc)) ) ) )
240
241(define (notfile . targets)
242  (set! *pseudo-targets* (lset-union string=? *pseudo-targets* targets)))
243
244(define (clean-on-error t thunk)
245  (handle-exceptions ex
246      (begin
247        (when (file-exists? t)
248          (message "deleting ~a" t)
249          (delete-file t) )
250        (abort ex) )
251    (thunk) ) )
252
253(define (build #!optional
254               (targets "all")
255               #!key
256               continuous
257               (verbose *verbose*) )
258  (fluid-let ((*verbose* verbose))
259    (let* ((deps (hash-table->alist *dependencies*))
260           (wdeps (delete-duplicates (append-map cdr deps) string=?))
261           (targets (list->vector (normalize targets)) ) 
262          (ftable (and continuous (make-hash-table string=?))))
263      (when continuous
264        (for-each
265         (lambda (dep)
266           (when (file-exists? dep) 
267             (hash-table-set! ftable dep (file-modification-time dep))))
268         wdeps))
269      (let loop ()
270        (make/proc
271         (map (lambda (dep)
272                (let ((target (car dep))
273                      (deps (cdr dep)))
274                 (list target deps
275                       (eval
276                        `(lambda ()
277                           (clean-on-error
278                            ',target
279                            (lambda ()
280                              ((hash-table-ref/default *actions* ',target noop)))))))))
281              deps)
282         targets)
283        (when continuous
284          (watch-dependencies wdeps ftable)
285          (loop)))
286      (cleanup-output))))
287
288(define (build-dump #!optional (port (current-output-port)))
289  (with-output-to-port port
290    (lambda ()
291      (message "dependencies:")
292      (for-each show-dependencies (hash-table-keys *dependencies*))
293      (when (positive? (hash-table-size *variables*))
294        (message "variables:")
295        (hash-table-walk
296         *variables*
297         (lambda (v x)
298           (message "  ~s:" v)
299           (for-each
300            (lambda (p)
301              (message "    ~a\t-> ~s~%" (car p) (cadr p))) 
302            x))) ) ) ) )
303
304(define (show-dependencies target)
305  (let ((i ""))
306    (let loop ((t target))
307      (message "~a~a ~a" i t (if (member t *pseudo-targets*) "(p)" ""))
308      (fluid-let ((i (string-append i " ")))
309        (for-each loop (hash-table-ref/default *dependencies* t '())) ) ) ) )
310
311
312;;; Command line processing
313
314(define (build* . args)
315  (let ((continuous #f)
316        (targets '()) 
317        (debug #f) )
318    (let-values (((procs arglists) (partition procedure? args)))
319      (let loop ((args (if (null? arglists) 
320                           (command-line-arguments) 
321                           (concatenate arglists))) )
322        (cond ((null? args) 
323               (when debug (build-dump))
324               (for-each (lambda (p) (p)) procs)
325               (build 
326                (if (null? targets) "all" (reverse targets))
327                verbose: *verbose*
328                continuous: continuous) )
329              (else
330               (let ((x (car args)))
331                 (cond ((and (> (string-length x) 0) (char=? #\- (string-ref x 0)))
332                        (cond ((string=? "-v" x) 
333                               (set! *verbose* #t) )
334                              ((member x '("-h" "-help" "--help"))
335                               (usage 0) )
336                              ((string=? "-c" x)
337                               (set! continuous #t) )
338                              ((string=? "-d" x)
339                               (set! debug #t) )
340                              (else (usage 1)) )
341                        (loop (cdr args)) )
342                       ((string-match "([-_A-Za-z0-9]+)=(.*)" x) =>
343                        (lambda (m)
344                          (let* ((sym (string->symbol (cadr m))))
345                            (if (##sys#symbol-has-toplevel-binding? sym)
346                                (let ((val (##sys#slot sym 0)))
347                                  (if (or (boolean? val) (string? val) (symbol? val) (eq? (void) val))
348                                      (##sys#setslot sym 0 (caddr m)) 
349                                      (quit "variable `~a' already has a suspicious value" sym) ) )
350                                (##sys#setslot sym 0 (caddr m)) )
351                            (loop (cdr args)) ) ) )
352                       (else
353                        (set! targets (cons x targets))
354                        (loop (cdr args))))))))) ) )
355
356(define (usage code)
357  (print "usage: " (car (argv)) " [ -v | -c | -d | TARGET | VARIABLE=VALUE ] ...")
358  (exit code) )
359
360
361;;; Check dependencies for changes
362
363(define (watch-dependencies deps tab)
364  (let loop ((f #f))
365    (sleep *sleep-delay*)
366    (cond ((any (lambda (dep)
367                  (and-let* (((file-exists? dep))
368                             (ft (file-modification-time dep))
369                             ((> ft (hash-table-ref/default tab dep 0))))
370                    (hash-table-set! tab dep ft)
371                    (message "~a changed" dep)
372                    #t) )
373                deps))
374          (f (loop #t))
375          (else
376           (message "waiting for changes ...")
377           (loop #t)))))
378
379
380;;; Other useful procedures
381
382(define -e file-exists?)
383(define -d (conjoin file-exists? directory?))
384(define -x (conjoin file-exists? file-execute-access?))
385
386(define cwd current-directory)
387(define (cd #!optional d) (if d (current-directory d) (getenv "HOME")))
388
389(define (with-cwd dir thunk)
390  (if (or (not dir) (equal? "." dir))
391      (thunk)
392      (let ((old #f))
393        (dynamic-wind
394            (lambda () (set! old (current-directory)))
395            (lambda ()
396              (command-message "cd ~a" dir)
397              (change-directory dir)
398              (thunk) )
399            (lambda ()
400              (change-directory old)
401              (command-message "cd ~a" old) ) ) ) ) )
402
403(define (try-run code #!optional (msg "trying to compile and run some C code") (flags "") (cc "cc"))
404  (let ((tmp (create-temporary-file "c")))
405    (with-output-to-file tmp (lambda () (display code)))
406    (message* "~a ..." msg)
407    (let ((r (zero? (system (sprintf "~a ~a ~a 2>/dev/null && ./a.out" cc tmp flags)))))
408      (delete-file* tmp)
409      (message (if r "ok" "failed"))
410      r) ) )
411
412(define (true? x)
413  (and x (not (member x '("no" "false" "off" "0" "")))))
414
415(define (simple-args #!optional (args (command-line-arguments)) (error error))
416  (define (assign var val)
417    (##sys#setslot 
418     (string->symbol (string-append "*" var "*"))
419     0
420     (if (string? val) 
421         (or (string->number val) val)
422         val)))
423  (let loop ((args args) (vals '()))
424    (cond ((null? args) (reverse vals))
425          ((string-match "(-{1,2})([-_A-Za-z0-9]+)(=)?\\s*(.+)?" (car args)) 
426           =>
427           (lambda (m)
428             (let*-values (((next) (cdr args))
429                           ((var val)
430                            (cond ((equal? "=" (fourth m))
431                                   (let ((opt (third m))
432                                         (val (fifth m)))
433                                     (cond (val (values opt val))
434                                           (else
435                                            (when (null? next)
436                                              (error "missing argument for option" (car args)) )
437                                            (let ((x (car next)))
438                                              (set! next (cdr next))
439                                              (values opt x))))) )
440                                  ((string? (second m)) (values (third m) #t))
441                                  (else (values #f #f)) ) ) )
442               (cond (var 
443                      (assign var val)
444                      (loop next vals) )
445                     (else (loop next (cons (car args) vals)))))))
446          (else (loop (cdr args) (cons (car args) vals))))))
447
448(define (yes-or-no? str . default)
449  (let ((def (optional default #f)))
450    (let loop ()
451      (printf "~%~A (yes/no) " str)
452      (when def (printf "[~A] " def))
453      (flush-output)
454      (let ((ln (read-line)))
455        (cond ((eof-object? ln) (set! ln "abort"))
456              ((and def (string=? "" ln)) (set! ln def)) )
457        (cond ((string-ci=? "yes" ln) #t)
458              ((string-ci=? "no" ln) #f)
459              (else
460               (printf "~%Please enter \"yes\" or \"no\".~%")
461               (loop) ) ) ) ) ) )
Note: See TracBrowser for help on using the repository browser.