854ce044e272e573190664fafdf918bb24e3023e
[mes.git] / guile / guix / make.scm
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of Mes.
7 ;;;
8 ;;; Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; make
24
25 ;;; Code:
26
27 (define-module (guix make)
28   #:use-module (ice-9 curried-definitions)
29   #:use-module (ice-9 format)
30   #:use-module (ice-9 optargs)
31   #:use-module (ice-9 popen)
32   #:use-module (ice-9 pretty-print)
33   #:use-module (ice-9 rdelim)
34   #:use-module (ice-9 receive)
35
36   #:use-module (srfi srfi-1)
37   #:use-module (srfi srfi-26)
38
39   #:use-module (guix records)
40   #:use-module (guix shell-utils)
41
42   #:export (build
43             check
44             clean
45             group
46             install
47             target-prefix?
48             check-target?
49             install-target?
50
51             cpp.mescc
52             compile.mescc
53             ld
54
55             bin.mescc
56             bin.gcc
57             snarf
58
59             libc-mes.E
60             libc-mes+tcc.E
61             mini-libc-mes.E
62             add-target
63             get-target
64
65             conjoin
66             system**
67             target-file-name
68
69             target
70             %targets
71             %status
72
73             %version
74             %prefix
75             %datadir
76             %docdir
77             %moduledir
78             %guiledir
79             %godir))
80
81 (define %status 0)
82 (define %targets '())
83 (define %store-dir ".store")
84 (mkdir-p %store-dir)
85 (define %command-log (open-output-file "script"))
86
87 (define (base-name file-name suffix)
88   (string-drop-right file-name (string-length suffix)))
89
90 (define (conjoin . predicates)
91   (lambda (. arguments)
92     (every (cut apply <> arguments) predicates)))
93
94 (define (system** . command)
95   (format %command-log "~a\n" (string-join command " "))
96   (unless (zero? (apply system* command))
97     (format (current-error-port) "FAILED:~s\n" command)
98     (exit 1)))
99
100 (define (gulp-pipe* . command)
101   (let* ((port (apply open-pipe* (cons OPEN_READ command)))
102          (foo (set-port-encoding! port "ISO-8859-1"))
103          (output (read-string port))
104          (status (close-pipe port)))
105     (format %command-log "~a\n" (string-join command " "))
106     (values output status)))
107
108 (define (assert-gulp-pipe* . command)
109   (receive (output status)
110       (apply gulp-pipe* command)
111     (if (zero? status) (string-trim-right output #\newline)
112         (error (format #f "pipe failed: ~d ~s"
113                        (or (status:exit-val status)
114                            (status:term-sig status)) command)))))
115
116 (define-record-type* <method>
117   method make-method
118   method?
119   (name       method-name)
120   (build      method-build (default (lambda _ #t)))
121   (inputs     method-inputs (default (list))))
122
123 (define-record-type* <target>
124   target make-target
125   target?
126   (file-name  target-file-name (default #f))       ; string
127   (file-names target-file-names (default '()))     ; (string)
128   (hash       target-hash (default #f))            ; string
129   (method     target-method (default method-file)) ; <method>
130   (inputs     target-inputs (default (list)))      ; list
131
132                                                    ; For check targets
133   (baseline   target-baseline (default #f))        ; string: file-name
134   (exit       target-exit (default #f))            ; number
135   (signal     target-signal (default #f)))         ; number
136
137 (define method-file (method (name "FILE")))
138 (define method-check
139   (method (name "CHECK")
140           (build (lambda (o t)
141                    (let* ((inputs (target-inputs t))
142                           (file-name (target-file-name (build (car inputs))))
143                           (run file-name)
144                           (baseline (target-baseline t))
145                           (exit (target-exit t))
146                           (signal (target-signal t))
147                           (log (string-append file-name "-check.log")))
148                      (format (current-error-port) "  CHECK\t~a" (basename file-name))
149                      (receive (output result)
150                          ;; FIXME: quiet MES tests are not fun
151                          (if (string-prefix? "tests/" run) (values #f (system* run "arg1" "arg2" "arg3" "arg4" "arg5"))
152                              (gulp-pipe* run "arg1" "arg2" "arg3" "arg4" "arg5"))
153                        (if (file-exists? log) (delete-file log))
154                        (if (or baseline (and output (not (string-null? output)))) (with-output-to-file log (lambda _ (display output))))
155                        (if baseline (set! result (system* "diff" "-bu" baseline log)))
156                        (let ((status (if (string? result) 0
157                                          (or (status:term-sig result) (status:exit-val result)))))
158                          (if (file-exists? log) (store #:add-file log))
159                          (format (current-error-port) "\t[~a]\n"
160                                  (if (or (and signal (= status signal))
161                                          (and exit (= status exit))) "OK"
162                                          (begin (set! %status 1) "FAIL"))))))))))
163
164 (define %version (or (getenv "VERSION") "git"))
165 (define %prefix (or (getenv "PREFIX") ""))
166 (define %datadir "share/mes")
167 (define %docdir "share/doc/mes")
168 (define %moduledir (string-append %datadir "/module"))
169 (define %guiledir (string-append "share/guile/site/" (effective-version)))
170 (define %godir (string-append "lib/guile/" (effective-version) "/site-ccache"))
171
172 (define* (method-cp #:key substitutes)
173   (method (name "INSTALL")
174           (build (lambda (o t)
175                    (let ((file-name (target-file-name t)))
176                      (mkdir-p (dirname file-name))
177                      (format (current-error-port) "  INSTALL\t~a\n" file-name)
178                      (copy-file ((compose target-file-name car target-inputs) t) file-name)
179                      (if substitutes
180                          (begin
181                            (substitute* file-name
182                              (("module/") (string-append %prefix "/" %moduledir "/"))
183                              (("@DATADIR@") (string-append %prefix "/" %datadir "/"))
184                              (("@DOCDIR@") (string-append %prefix "/" %docdir "/"))
185                              (("@GODIR@") (string-append %prefix "/" %godir "/"))
186                              (("@GUILEDIR@") (string-append %prefix "/" %guiledir "/"))
187                              (("@MODULEDIR@") (string-append %prefix "/" %moduledir "/"))
188                              (("@PREFIX@") (string-append %prefix "/"))
189                              (("@VERSION@") %version)))))))))
190
191 (define (hash-target o)
192   (if (find (negate identity) (target-inputs o))
193       (format (current-error-port) "invalid inputs[~s]: ~s\n" (target-file-name o) (target-inputs o)))
194   (let ((inputs (target-inputs o)))
195     (if (null? inputs) (or (target-hash o) (target-hash (store #:add o)))
196         (let ((input-shas (map hash-target inputs)))
197           (and (every identity input-shas)
198                (let ((method (target-method o)))
199                  (string-hash (format #f "~s" (cons* (target-file-name o)
200                                                      (method-build method)
201                                                      (map target-hash (method-inputs method))
202                                                      input-shas)))))))))
203
204 (define (string-hash o)
205   (number->string (hash o (expt 2 31))))
206
207 (define (file-hash o)
208   (string-hash (with-input-from-file o read-string)))
209
210 (define (store-file-name o)
211   (string-append %store-dir "/" (if (string? o) o
212                                     (target-hash o))))
213
214 (define (link-or-cp existing-file new-file)
215   (catch #t
216     (lambda _ (link existing-file new-file))
217     (lambda _ (copy-file existing-file new-file))))
218
219 (define (assert-link existing-file new-file)
220   (if (not (file-exists? new-file)) (link-or-cp existing-file new-file)))
221
222 (define store
223   (let ((*store* '()))
224     (define (prune? o)
225       (let ((t (cdr o)))
226         (pair? (target-inputs t))))
227     (define ((file-name? file-name) o)
228       (let ((t (cdr o)))
229         (equal? (target-file-name t) (target-file-name file-name))))
230     (lambda* (#:key add add-file delete get key print prune)
231       (cond ((and add key) (let ((value (target (inherit add) (hash key))))
232                              (set! *store* (assoc-set! (filter (negate (file-name? add)) *store*) key value))
233                              (let ((file-name (target-file-name value)))
234                                (if (and file-name (file-exists? file-name))
235                                    (assert-link file-name (store-file-name value))))
236                              value))
237             (add (let ((key (if (null? (target-inputs add)) (file-hash (target-file-name add))
238                                 (hash-target add))))
239                    (if (not key) (error "store: no hash for:" add))
240                    (store #:add add #:key key)))
241             (add-file
242              (or (and=> (find (lambda (t) (equal? (target-file-name t) add-file)) (map cdr *store*))
243                         (compose (cut store #:get <>) target-hash))
244                  (and (file-exists? add-file)
245                       (store #:add (target (file-name add-file))))
246                  (error (format #f "store add-file: no such file: ~s\n" add-file))))
247             ((and get key)
248              (or (assoc-ref *store* key)
249                  (let ((store-file (store-file-name key))
250                        (file-name (target-file-name get)))
251                    (and (file-exists? store-file)
252                         (if (file-exists? file-name) (delete-file file-name))
253                         (link-or-cp store-file file-name)
254                         (store #:add get #:key key)))))
255             (get (assoc-ref *store* get))
256             (delete (and (assoc-ref *store* delete)
257                          (set! *store* (filter (lambda (e) (not (equal? (car e) delete))) *store*))))
258             (print (pretty-print (map (lambda (e) (cons (target-file-name (cdr e)) (car e))) *store*)))
259             ((eq? prune 'file-system)
260              (set! *store* (filter prune? *store*)))
261             (else (error "store: dunno"))))))
262
263 (define (build o)
264   (let ((hash (hash-target o)))
265     (or (and hash (store #:get o #:key hash))
266         (begin
267           ;;(format (current-error-port) "must rebuild hash=~s\n" hash)
268           (for-each build (target-inputs o))
269           (let ((method (target-method o)))
270             ((method-build method) method o))
271           (store #:add o #:key hash)))))
272
273 (define* (check name #:key baseline (exit 0) (signal #f) (dependencies '()))
274   (target (file-name (string-append "check-" name))
275           (method method-check)
276           (inputs (cons (get-target name) dependencies))
277           (baseline baseline)
278           (exit exit)
279           (signal signal)))
280
281 (define* (install name #:key (dir (dirname name)) (installed-name (basename name)) (prefix %prefix) substitutes (dependencies '()))
282   (target (file-name (string-append prefix "/" dir "/" installed-name))
283           (method (method-cp #:substitutes substitutes))
284           (inputs (cons (or (get-target name)
285                             (store #:add-file name)) dependencies))))
286
287 (define* (group name #:key (dependencies '()))
288   (target (file-name name)
289           (inputs (map get-target dependencies))))
290
291 (define (target->input-files o)
292   (let ((inputs (target-inputs o)))
293     (if (null? inputs) '()
294         (append (cons (target-file-name o) (target-file-names o)) (append-map target->input-files inputs)))))
295
296 (define* (clean #:optional targets)
297   (for-each
298    delete-file
299    (filter file-exists? (delete-duplicates (append-map (cut target->input-files <>) (or targets %targets))))))
300
301 (define (tree o)
302   (let ((inputs (target-inputs o)))
303     (if (null? inputs) o
304         (cons o (append (map tree inputs) (map tree (method-inputs (target-method o))))))))
305
306
307 (define (verbose fmt . o)
308   ;;(apply format (cons* (current-error-port) fmt o))
309   #t
310   )
311
312 (define* (PATH-search-path name #:key (default name))
313   (or (search-path (string-split (getenv "PATH") #\:) name)
314       (and (format (current-error-port) "warning: not found: ~a\n" name)
315            default)))
316
317 (define %CC (PATH-search-path "gcc"))
318 (define %CC32 (or (PATH-search-path "i686-unknown-linux-gnu-gcc" #:default #f)
319                   (not (format (current-error-port) "warning: CC32 not found, skipping mlibc-gcc targets\n"))))
320 (define %C-FLAGS
321   '("--std=gnu99"
322     "-O0"
323     "-g"
324     "-D"
325     "POSIX=1"
326     "-I" "src"
327     "-I" "mlibc/include"
328     "--include=mlibc/libc-gcc.c"
329     ))
330 (define %C32-FLAGS
331   '("--std=gnu99"
332     "-O0"
333     "-g"
334     "-I" "src"
335     "-I" "mlibc/include"
336     "--include=mlibc/libc-gcc.c"
337     ))
338
339 (define* (CC.gcc #:key (libc #t) (cc (if libc %CC %CC32)) (c-flags (if libc %C-FLAGS %C32-FLAGS)) (defines '()) (includes '()))
340   (method (name "CC.gcc")
341           (build (lambda (o t)
342                    (let* ((input-files (map target-file-name (target-inputs t)))
343                           (command `(,cc
344                                      "-c"
345                                      ,@(append-map (cut list "-D" <>) defines)
346                                      ,@(append-map (cut list "-I" <>) includes)
347                                      ,@(if libc '() '("-nostdinc" "-fno-builtin"))
348                                      ,@c-flags
349                                      "-o" ,(target-file-name t)
350                                      ,@(filter (cut string-suffix? ".c" <>) input-files))))
351                      (format (current-error-port) "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
352                      (apply system** command))))
353           (inputs (list (store #:add-file "mlibc/libc-gcc.c"))))) ;; FIXME: FLAGS
354
355 (define* (CPP.mescc #:key (cc %MESCC) (defines '()) (includes '()))
356   (method (name "CPP.mescc")
357           (build (lambda (o t)
358                    (let ((input-files (map target-file-name (target-inputs t))))
359                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
360                      (apply system**
361                             `(,cc
362                               "-E"
363                               ,@(append-map (cut list "-D" <>) defines)
364                               ,@(append-map (cut list "-I" <>) includes)
365                               "-o" ,(target-file-name t)
366                               ,@input-files)))))))
367
368 (define %MESCC "guile/mescc.scm")
369 (define* (CC.mescc #:key (cc %MESCC))
370   (method (name "CC.mescc")
371           (build (lambda (o t)
372                    (let ((input-files (map target-file-name (target-inputs t))))
373                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
374                      (apply system**
375                             `("guile/mescc.scm" "-c"
376                               "-o" ,(target-file-name t)
377                               ,@input-files)))))
378           (inputs (list (store #:add-file "guile/language/c99/compiler.go")
379                         (store #:add-file "guile/language/c99/info.go")
380                         (store #:add-file "guile/mes/as.go")
381                         (store #:add-file "guile/mes/as-i386.go")
382                         (store #:add-file "guile/mes/bytevectors.go")
383                         (store #:add-file "guile/mes/M1.go")))))
384
385 (define %M1 (or (PATH-search-path "M1" #:default #f)
386                 (PATH-search-path "M0" #:default #f) ; M1 is in unreleased mescc-tools 0.2
387                 (and (format (current-error-port) "error: no macro assembler found, please install mescc-tools\n")
388                      (exit 1))))
389 (define %M0-FLAGS
390   '("--LittleEndian"))
391 (define %M1-FLAGS
392   '("--LittleEndian"
393     "--Architecture=1"))
394 (if (equal? (basename %M1) "M0")
395     (set! %M1-FLAGS %M0-FLAGS))
396
397 (define* (M1.asm #:key (m1 %M1) (m1-flags %M1-FLAGS))
398   (method (name "M1")
399           (build (lambda (o t)
400                    (let* ((input-files (map target-file-name (target-inputs t)))
401                           (input-files (filter (lambda (f) (string-suffix? "M1" f))
402                                                input-files)))
403                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
404                      (with-output-to-file (target-file-name t)
405                        (lambda _
406                          (display
407                           (apply assert-gulp-pipe*
408                                  `(,m1
409                                    "-f"
410                                    "stage0/x86.M1"
411                                    ,@(append-map (cut list "-f" <>) input-files)
412                                    ,@m1-flags)))
413                          (newline))))))
414           (inputs (list (store #:add-file "stage0/x86.M1")))))
415
416 (define %HEX2-FLAGS
417   '("--LittleEndian"
418     "--Architecture=1"
419     "--BaseAddress=0x1000000"))
420 (define %HEX2 (PATH-search-path "hex2"))
421
422 (define* (LINK.hex2 #:key (hex2 %HEX2) (hex2-flags %HEX2-FLAGS) debug?)
423   (method (name "LINK.hex2")
424           (build (lambda (o t)
425                    (let* ((input-files (map target-file-name (target-inputs t)))
426                           ;; FIXME: snarf inputs
427                           (input-files (filter (lambda (f) (string-suffix? "hex2" f))
428                                                input-files)))
429                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
430                      (with-output-to-file (target-file-name t)
431                        (lambda _
432                          (set-port-encoding! (current-output-port) "ISO-8859-1")
433                          (display
434                           (apply assert-gulp-pipe*
435                                  `(,hex2
436                                    ,@hex2-flags
437                                    "-f"
438                                    ,(if (not debug?) "stage0/elf32-0header.hex2"
439                                         "stage0/elf32-header.hex2")
440                                    ,@(append-map (cut list "-f" <>) input-files)
441                                    "-f"
442                                    ,(if (not debug?) "stage0/elf-0footer.hex2"
443                                         "stage0/elf32-footer-single-main.hex2"))))))
444                      (chmod (target-file-name t) #o755))))
445           (inputs (list (store #:add-file "stage0/elf32-0header.hex2")
446                         (store #:add-file "stage0/elf-0footer.hex2")))))
447
448 (define* (LINK.gcc #:key (cc %CC) (c-flags %C-FLAGS) (libc #t))
449   (method (name "LINK.gcc")
450           (build (lambda (o t)
451                    (let* ((input-files (map target-file-name (target-inputs t)))
452                           (command `(,cc
453                                      ,@c-flags
454                                      ,@(if libc '() '("-nostdlib"))
455                                      "-o"
456                                      ,(target-file-name t)
457                                      ,@input-files)))
458                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
459                      (apply system** command))))))
460
461 (define SNARF "build-aux/mes-snarf.scm")
462 (define (SNARF.mes mes?)
463   (method (name "SNARF.mes")
464           (build (lambda (o t)
465                    (let* ((input-files (map target-file-name (target-inputs t)))
466                           (command `(,SNARF
467                                      ,@(if mes? '("--mes") '())
468                                      ,@input-files)))
469                      (format #t "  ~a\t ~a -> ~a\n" (method-name o) (string-join input-files) (target-file-name t))
470                      (apply system** command))))))
471
472 (define* (cpp.mescc input-file-name #:key (cc %MESCC) (defines '()) (includes '()) (dependencies '()))
473   (let* ((c-target (target (file-name input-file-name)))
474          (base-name (base-name input-file-name ".c"))
475          (suffix ".E")
476          (target-file-name (string-append base-name suffix)))
477     (target (file-name target-file-name)
478             (inputs (cons c-target dependencies))
479             (method (CPP.mescc #:cc cc #:defines defines #:includes includes)))))
480
481 (define mini-libc-mes.E (cpp.mescc "mlibc/mini-libc-mes.c"))
482 (define libc-mes.E (cpp.mescc "mlibc/libc-mes.c"))
483 (define libc-mes+tcc.E (cpp.mescc "mlibc/libc-mes+tcc.c"))
484
485 (define* (compile.gcc input-file-name #:key (libc #t) (cc (if libc %CC %CC32)) (defines '()) (includes '()) (dependencies '()))
486   (let* ((base-name (base-name input-file-name ".c"))
487          (cross (if libc "" "mlibc-"))
488          (suffix (string-append "." cross "o"))
489          (target-file-name (string-append base-name suffix))
490          (c-target (target (file-name input-file-name))))
491     (target (file-name target-file-name)
492             (inputs (cons c-target dependencies))
493             (method (CC.gcc #:cc cc #:libc libc #:defines defines #:includes includes)))))
494
495 (define* (compile.mescc input-file-name #:key (cc %MESCC) (libc libc-mes.E) (defines '()) (includes '()) (dependencies '()))
496   (let* ((base-name (base-name input-file-name ".c"))
497          ;;(foo (format (current-error-port) "COMPILE[~s .c] base=~s\n" input-file-name base-name))
498          (suffix (cond ((not libc) ".0-M1")
499                        ((eq? libc libc-mes.E) ".M1")
500                        ((eq? libc libc-mes+tcc.E) ".tcc-M1")
501                        (else ".mini-M1")))
502          (target-file-name (string-append base-name suffix))
503          (E-target (cpp.mescc input-file-name #:cc cc #:defines defines #:includes includes #:dependencies dependencies)))
504     (target (file-name target-file-name)
505             (inputs `(,@(if libc (list libc) '()) ,E-target))
506             (method (CC.mescc #:cc cc)))))
507
508 (define* (m1-asm input-file-name #:key (cc %MESCC) (m1 %M1) (libc libc-mes.E) (defines '()) (includes '()) (dependencies '()))
509   (let* ((base-name (base-name input-file-name ".c"))
510          ;;(foo (format (current-error-port) "m1-asm[~s .m1] base=~s\n" input-file-name base-name))
511          (suffix (cond ((not libc) ".0-hex2")
512                        ((eq? libc libc-mes.E) ".hex2")
513                        ((eq? libc libc-mes+tcc.E) ".tcc-hex2")
514                        (else ".mini-hex2")))
515          (target-file-name (string-append base-name suffix))
516          (m1-target (compile.mescc input-file-name #:cc cc #:libc libc #:defines defines #:includes includes #:dependencies dependencies))
517          (libc.m1 (cond ((eq? libc libc-mes.E)
518                          (compile.mescc "mlibc/libc-mes.c" #:libc #f #:defines defines #:includes includes))
519                         ((eq? libc mini-libc-mes.E)
520                          (compile.mescc "mlibc/mini-libc-mes.c" #:libc #f #:defines defines #:includes includes))
521                         ((eq? libc libc-mes+tcc.E)
522                          (compile.mescc "mlibc/libc-mes+tcc.c" #:libc #f #:defines defines #:includes includes))
523                         (else #f))))
524     (target (file-name target-file-name)
525             ;;(inputs `(,@(if libc (list libc.m1) '()) ,m1-target))
526             (inputs `(,m1-target))
527             (method (M1.asm #:m1 m1)))))
528
529 (define* (bin.mescc input-file-name #:key (cc %MESCC) (hex2 %HEX2) (m1 %M1) (libc libc-mes.E) (dependencies '()) (defines '()) (includes '()))
530   (let* ((base-name (base-name input-file-name ".c"))
531          ;;(foo (format (current-error-port) "bin[~s .c] base=~s\n" input-file-name base-name))
532          (suffix (cond ((not libc) ".0-guile")
533                        ((eq? libc libc-mes.E) ".guile")
534                        ((eq? libc libc-mes+tcc.E) ".tcc-guile")
535                        (else ".mini-guile")))
536          (target-file-name (string-append base-name suffix))
537          (hex2-target (m1-asm input-file-name #:m1 m1 #:cc cc #:libc libc #:defines defines #:includes includes #:dependencies dependencies)))
538     (target (file-name target-file-name)
539             (inputs (list hex2-target))
540             (method (LINK.hex2 #:hex2 hex2 #:debug? (eq? libc libc-mes.E))))))
541
542 (define* (bin.gcc input-file-name #:key (libc #t) (cc (if libc %CC %CC32)) (dependencies '()) (defines '()) (includes '()))
543   (and cc
544        (let* ((base-name (base-name input-file-name ".c"))
545           (suffix (if libc ".gcc" ".mlibc-gcc"))
546           (target-file-name (string-append base-name suffix))
547           (o-target (compile.gcc input-file-name #:cc cc #:libc libc #:defines defines #:includes includes #:dependencies dependencies)))
548      (target (file-name target-file-name)
549              (inputs (list o-target))
550              (method (LINK.gcc #:cc cc #:libc libc))))))
551
552 (define* (snarf input-file-name #:key (dependencies '()) (mes? #t))
553   (let* ((base-name (base-name input-file-name ".c"))
554          (suffixes '(".h" ".i" ".environment.i" ".symbol-names.i" ".symbols.i"  ".symbols.h"))
555          (suffixes (if mes? (map (cut string-append ".mes" <>) suffixes) suffixes))
556          (target-file-names (map (cut string-append base-name <>) suffixes))
557          (snarf-target (target (file-name input-file-name))))
558     (target (file-name (car target-file-names))
559             (file-names (cdr target-file-names))
560             (inputs (cons snarf-target dependencies))
561             ;;(inputs (list snarf-target))
562             (method (SNARF.mes mes?)))))
563
564 (define ((target-prefix? prefix) o)
565   (string-prefix? prefix (target-file-name o)))
566
567 (define (check-target? o)
568   (and o ((target-prefix? "check-") o)))
569
570 (define (install-target? o)
571   (and o ((target-prefix? (or (getenv "PREFIX") "/")) o)))
572
573 (define (add-target o)
574   (and o (set! %targets (append %targets (list o))))
575   o)
576 (define (get-target o)
577   (if (target? o) o
578       (find (lambda (t) (equal? (target-file-name t) o)) %targets)))