source: project/release/4/make/make-support.scm @ 14348

Last change on this file since 14348 was 14348, checked in by Alex Shinn, 11 years ago

make for chicken 4

File size: 5.5 KB
Line 
1;;;; make.scm - PLT's `make' macro for CHICKEN - felix
2
3
4#|
5> (make ((target (depend ...) command ...) ...) argv)
6
7expands to
8
9  (make/proc
10    (list (list target (list depend ...) (lambda () command ...)) ...)
11    argv)
12
13> (make/proc spec argv) performs a make according to `spec' and using
14`argv' as command-line arguments selecting one or more targets.
15`argv' can either be a string or a vector of strings.
16
17`spec' is a MAKE-SPEC:
18
19  MAKE-SPEC = (list-of MAKE-LINE)
20  MAKE-LINE = (list TARGET (list-of DEPEND-STRING) COMMAND-THUNK)
21  TARGET = (union string (list-of string)) ; either a string or a list of strings
22  DEPEND-STRING = string
23  COMMAND-THUNK = (-> void)
24
25To make a target, make/proc is first called on each of the target's
26dependencies. If a target is not in the spec and it exists, then the
27target is considered made. If a target is older than any of its
28dependencies, the corresponding COMMAND-THUNK is invoked. The
29COMMAND-THUNK is optional; a MAKE-LINE without a COMMAND-THUNK is
30useful as a target for making a number of other targets (the
31dependencies).
32
33Parameters:
34
35> (make-print-checking [on?]) - If #f, make only prints when it is
36making a target. Otherwise, it prints when it is checking the
37dependancies of a target. Defaultly #t.
38
39> (make-print-dep-no-line [on?]) - If #f, make only prints "checking..."
40lines for dependancies that have a corresponding make line.  Defaultly
41#f.
42
43> (make-print-reasons [on?]) If #t, make prints the reason for each
44dependancy that fires. Defaultly #t.
45|#
46
47
48(declare
49  (hide make:check-spec make:check-argv
50        make:find-matching-line make:form-error
51        make:make/proc/helper) )
52
53(use srfi-1 posix)
54
55
56(define make-print-checking (make-parameter #f))
57(define make-print-dep-no-line (make-parameter #f))
58(define make-print-reasons (make-parameter #f))
59
60(define (make:find-matching-line str spec)
61  (let ([match? (lambda (s) (string=? s str))])
62    (let loop ([lines spec])
63      (cond
64       [(null? lines) #f]
65       [else (let* ([line (car lines)]
66                    [names (if (string? (car line))
67                               (list (car line))
68                               (car line))])
69               (if (ormap match? names)
70                   line
71                   (loop (cdr lines))))]))))
72
73(define (make:form-error s p) (error (sprintf "~a: ~s" s p)))
74(define (make:line-error s p n) (error (sprintf "~a: ~s for line: ~a" s p n)))
75
76(define (make:check-spec spec)
77  (and (or (list? spec) (make:form-error "specification is not a list" spec))
78       (or (pair? spec) (make:form-error "specification is an empty list" spec))
79       (andmap
80        (lambda (line)
81          (and (or (and (list? line) (<= 2 (length line) 3))
82                   (make:form-error "list is not a list with 2 or 3 parts" line))
83               (or (or (string? (car line))
84                       (and (list? (car line))
85                            (andmap string? (car line))))
86                   (make:form-error "line does not start with a string or list of strings" line))
87               (let ([name (car line)])
88                 (or (list? (cadr line))
89                     (make:line-error "second part of line is not a list" (cadr line) name)
90                     (andmap (lambda (dep)
91                               (or (string? dep)
92                                   (make:form-error "dependency item is not a string" dep)))
93                             (cadr line)))
94                 (or (null? (cddr line))
95                     (procedure? (caddr line))
96                     (make:line-error "command part of line is not a thunk" (caddr line) name)))))
97        spec)))
98
99(define (make:check-argv argv)
100  (or (string? argv)
101      (every 
102       string?
103       (if (vector? argv) (vector->list argv) argv))
104      (error "argument is not a string or string vector" argv)))
105
106(define (make:make/proc/helper spec argv)
107  (make:check-spec spec)
108  (make:check-argv argv)
109  (letrec ([made '()]
110           [exn? (condition-predicate 'exn)]
111           [exn-message (condition-property-accessor 'exn 'message)]
112           [make-file
113            (lambda (s indent)
114              (let ([line (make:find-matching-line s spec)]
115                    [date (and (file-exists? s)
116                               (file-modification-time s))])
117
118                (when (and (make-print-checking)
119                           (or line
120                               (make-print-dep-no-line)))
121                  (printf "make: ~achecking ~a~%" indent s))
122
123                (if line
124                    (let ([deps (cadr line)])
125                      (for-each (let ([new-indent (string-append " " indent)])
126                                  (lambda (d) (make-file d new-indent)))
127                                deps)
128                      (let ([reason
129                             (or (not date)
130                                 (ormap (lambda (dep)
131                                          (unless (file-exists? dep)
132                                            (error (sprintf "dependancy ~a was not made~%" dep)))
133                                          (and (> (file-modification-time dep) date)
134                                               dep))
135                                        deps))])
136                        (when reason
137                          (let ([l (cddr line)])
138                            (unless (null? l)
139                              (set! made (cons s made))
140                              (printf "make: ~amaking ~a~a~%"
141                                      (if (make-print-checking) indent "")
142                                      s
143                                      (if (make-print-reasons)
144                                          (cond
145                                           [(not date)
146                                            (string-append " because " s " does not exist")]
147                                           [(string? reason)
148                                            (string-append " because " reason " changed")]
149                                           [else
150                                            (string-append (sprintf " just because (reason: ~a date: ~a)" reason date))])
151                                          ""))
152                              (handle-exceptions exn
153                                  (begin
154                                    (printf "make: Failed to make ~a: ~a~%"
155                                            (car line)
156                                            (if (exn? exn)
157                                                (exn-message exn)
158                                                exn))
159                                    (signal exn) )
160                                ((car l))))))))
161                    (unless date
162                      (error (sprintf "don't know how to make ~a" s))))))])
163    (cond
164     [(string? argv) (make-file argv "")]
165     [(or (null? argv) (equal? argv '#())) (make-file (caar spec) "")]
166     [else (for-each (lambda (f) (make-file f ""))
167                     (if (vector? argv) (vector->list argv) argv))])
168    (for-each (lambda (item)
169                (printf "make: made ~a~%" item))
170              (reverse made))))
171
172(define make/proc
173  (case-lambda
174   [(spec) (make:make/proc/helper spec '())]
175   [(spec argv) (make:make/proc/helper spec argv)]))
Note: See TracBrowser for help on using the repository browser.