source: project/release/5/make/trunk/make.scm @ 33359

Last change on this file since 33359 was 33359, checked in by evhan, 5 years ago

Copy make egg into release/5 with minor updates for chicken-5

File size: 8.5 KB
Line 
1;;;; make.scm - PLT's `make' macro for CHICKEN - felix
2
3#|
4> (make ((target (depend ...) command ...) ...) argv)
5
6expands to
7
8  (make/proc
9    (list (list target (list depend ...) (lambda () command ...)) ...)
10    argv)
11
12> (make/proc spec argv) performs a make according to `spec' and using
13`argv' as command-line arguments selecting one or more targets.
14`argv' can either be a string or a vector of strings.
15
16`spec' is a MAKE-SPEC:
17
18  MAKE-SPEC = (list-of MAKE-LINE)
19  MAKE-LINE = (list TARGET (list-of DEPEND-STRING) COMMAND-THUNK)
20  TARGET = (union string (list-of string)) ; either a string or a list of strings
21  DEPEND-STRING = string
22  COMMAND-THUNK = (-> void)
23
24To make a target, make/proc is first called on each of the target's
25dependencies. If a target is not in the spec and it exists, then the
26target is considered made. If a target is older than any of its
27dependencies, the corresponding COMMAND-THUNK is invoked. The
28COMMAND-THUNK is optional; a MAKE-LINE without a COMMAND-THUNK is
29useful as a target for making a number of other targets (the
30dependencies).
31
32Parameters:
33
34> (make-print-checking [on?]) - If #f, make only prints when it is
35making a target. Otherwise, it prints when it is checking the
36dependancies of a target. Defaultly #t.
37
38> (make-print-dep-no-line [on?]) - If #f, make only prints "checking..."
39lines for dependancies that have a corresponding make line.  Defaultly
40#f.
41
42> (make-print-reasons [on?]) If #t, make prints the reason for each
43dependency that fires. Defaultly #t.
44|#
45
46(module make (make make/proc
47              make-print-checking
48              make-print-dep-no-line
49              make-print-reasons
50              make-nonfile-targets)
51
52(import-for-syntax (srfi 1)) ; For `every` in the `make` macro.
53(import (scheme) (chicken) (chicken format) (chicken posix) (srfi 1))
54
55(define make-print-checking (make-parameter #f))
56(define make-print-dep-no-line (make-parameter #f))
57(define make-print-reasons (make-parameter #f))
58(define make-nonfile-targets (make-parameter '()))
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 (any match? names)
70                   line
71                   (loop (cdr lines)))))))))
72
73(define (make:form-error s p)
74  (error (sprintf "~a: ~s" s p)))
75(define (make:line-error s p n)
76  (error (sprintf "~a: ~s for line: ~a" s p n)))
77
78(define (make:check-spec spec)
79  (and
80   (or (list? spec) (make:form-error "specification is not a list" spec))
81   (or (pair? spec) (make:form-error "specification is an empty list" spec))
82   (every
83    (lambda (line)
84      (and
85       (or (and (list? line) (<= 2 (length line) 3))
86           (make:form-error "list is not a list with 2 or 3 parts" line))
87       (or (or (string? (car line))
88               (and (list? (car line))
89                    (every string? (car line))))
90           (make:form-error "line does not start with a string or list of strings" line))
91       (let ((name (car line)))
92         (or (list? (cadr line))
93             (make:line-error "second part of line is not a list" (cadr line) name)
94             (every (lambda (dep)
95                      (or (string? dep)
96                          (make:form-error "dependency item is not a string" dep)))
97                    (cadr line)))
98         (or (null? (cddr line))
99             (procedure? (caddr line))
100             (make:line-error "command part of line is not a thunk" (caddr line) name)))))
101    spec)))
102
103(define (make:check-argv argv)
104  (or (string? argv)
105      (every 
106       string?
107       (if (vector? argv) (vector->list argv) argv))
108      (error "argument is not a string or string vector" argv)))
109
110(define (make:make/proc/helper spec argv)
111  (make:check-spec spec)
112  (make:check-argv argv)
113  (letrec ((made '())
114           (exn? (condition-predicate 'exn))
115           (exn-message (condition-property-accessor 'exn 'message))
116           (make-file
117            (lambda (s indent)
118              (let ((line (make:find-matching-line s spec))
119                    (date (and (file-exists? s)
120                               (file-modification-time s))))
121
122                (when (and (make-print-checking)
123                           (or line
124                               (make-print-dep-no-line)))
125                  (printf "make: ~achecking ~a~%" indent s))
126
127                (if line
128                    (let ((deps (cadr line)))
129                      (for-each (let ((new-indent (string-append " " indent)))
130                                  (lambda (d) (make-file d new-indent)))
131                                deps)
132                      (let ((reason
133                             (or (not date)
134                                 (find (lambda (dep)
135                                         (and (not (member dep (make-nonfile-targets)))
136                                              (unless (file-exists? dep)
137                                                (error (sprintf "dependency ~a was not made~%" dep)))
138                                              (and (> (file-modification-time dep) date)
139                                                   dep)))
140                                       deps))))
141                        (when reason
142                          (let ((l (cddr line)))
143                            (unless (null? l)
144                              (set! made (cons s made))
145                              (printf
146                               "make: ~amaking ~a~a~%"
147                               (if (make-print-checking) indent "")
148                               s
149                               (if (make-print-reasons)
150                                   (cond
151                                    ((and (not date) (not (member s (make-nonfile-targets))))
152                                     (string-append " because " s " does not exist"))
153                                    ((string? reason)
154                                     (string-append " because " reason " changed"))
155                                    (else
156                                     (string-append (sprintf " just because (reason: ~a date: ~a)" reason date))))
157                                   ""))
158                              (handle-exceptions
159                               exn
160                               (begin
161                                 (printf "make: Failed to make ~a: ~a~%"
162                                         (car line)
163                                         (if (exn? exn)
164                                             (exn-message exn)
165                                             exn))
166                                 (signal exn) )
167                               ((car l))))))))
168                    (unless date
169                      (error (sprintf "don't know how to make ~a" s))))))))
170    (cond
171     ((string? argv) (make-file argv ""))
172     ((or (null? argv) (equal? argv '#())) (make-file (caar spec) ""))
173     (else (for-each (lambda (f) (make-file f ""))
174                     (if (vector? argv) (vector->list argv) argv))))
175    (for-each (lambda (item)
176                (printf "make: made ~a~%" item))
177              (reverse made))))
178
179(define make/proc
180  (case-lambda
181   ((spec) (make:make/proc/helper spec '()))
182   ((spec argv) (make:make/proc/helper spec argv))))
183
184(define-syntax make
185  (er-macro-transformer
186   (lambda (expr rename compare)
187     (let ((make
188            (lambda (spec argv)
189              (let ((form-error (lambda (s . p) (apply error s spec p))))
190                (and (or (list? spec)
191                         (form-error "illegal specification (not a sequence)"))
192                     (or (pair? spec)
193                         (form-error "empty specification"))
194                     (every
195                      (lambda (line)
196                        (and
197                         (or (and (list? line) (>= (length line) 2))
198                             (form-error
199                              "clause does not have at least 2 parts"
200                              line))
201                         (let ((name (car line)))
202                           (or (list? (cadr line))
203                               (form-error
204                                "second part of clause is not a sequence"
205                                (cadr line))))))
206                      spec))
207                `(,(rename 'make/proc)
208                  (list ,@(map (lambda (line)
209                                 `(,(rename 'list) ,(car line)
210                                   (,(rename 'list) ,@(cadr line))
211                                   ,@(let ((l (cddr line)))
212                                       (if (null? l)
213                                           '()
214                                           `((,(rename 'lambda) ()
215                                              ,@l))))))
216                               spec))
217                  ,(if (vector? argv) `',argv (car argv)))))))
218       (cond
219        ((null? (cdr expr))
220         (error "no arguments to make"))
221        ((pair? (cddr expr))
222         (make (cadr expr) (cddr expr)))
223        (else
224         (make (cadr expr) '#()))))))))
Note: See TracBrowser for help on using the repository browser.