source: project/release/4/autocompile/tags/1.0/chicken-scheme.scm @ 27149

Last change on this file since 27149 was 27149, checked in by felix winkelmann, 9 years ago

autocompile 1.0: allow specification of options in comment header

File size: 4.1 KB
Line 
1;;;; chicken-scheme.scm
2
3
4(module chicken-scheme ()
5
6(import scheme chicken matchable foreign)
7(use files posix ports extras utils regex)
8
9
10(define-foreign-variable +csc-program+ c-string "C_CSC_PROGRAM")
11(define-foreign-variable +csi-program+ c-string "C_CSI_PROGRAM")
12(define-foreign-variable +binpath+ c-string "C_INSTALL_BIN_HOME")
13
14(define *debug*
15  (get-environment-variable "CHICKEN_SCHEME_DEBUG") )
16
17(define *chicken-scheme-hook* 
18  (and (not *debug*)
19       (get-environment-variable "CHICKEN_SCHEME_HOOK") ))
20
21(define *cache* 
22  (make-pathname 
23   (or (get-environment-variable "HOME") "/")
24   ".chicken-scheme.cache") )
25
26(define *options* 
27  (or (get-environment-variable "CHICKEN_SCHEME_OPTIONS")
28      (if *debug* "-v -v" "-O2")) )
29
30(define *csc* (make-pathname +binpath+ +csc-program+))
31(define *csi* (make-pathname +binpath+ +csi-program+))
32
33(define *exe* 
34  (and (eq? 'windows (software-type))
35       (not (eq? 'cygwin (build-platform)))
36      "exe"))
37
38(define +md5sum-regex+
39  (regexp '(: bos (? #\\) (* space) (submatch (+ xdigit)) (* space))))
40
41(define *md5sum-program*
42  (cond-expand
43    (netbsd "md5 -n")
44    ((or freebsd openbsd dragonfly) "md5 -r")
45    (else "md5sum")))
46
47(define (usage code)
48  (print "usage: chicken-scheme [-help] [-purge] [-list] [-cache] [FILENAME ARGUMENT ...]")
49  (exit code) )
50
51(define (purge)
52  (when *debug*
53    (print "purging " *cache* " ..."))
54  (when (directory-exists? *cache*)
55    (for-each
56     (lambda (f) (delete-file* (make-pathname *cache* f))) 
57     (directory *cache*))) )
58
59(define (md5sum filename)
60  (let ((qsource (qs (normalize-pathname filename))))
61    (case (software-version)
62      ((macosx) 
63       (with-input-from-pipe (sprintf "md5 -q ~a" qsource) read-line) )
64      (else
65       (with-input-from-pipe 
66        (sprintf "~a ~a" *md5sum-program* qsource)
67        (lambda () 
68          (let ((input (read-line)))
69            (cond ((string-search +md5sum-regex+ input) => cadr)
70                  (else (error "cannot compute md5sum" input))))))))))
71
72(define scan-head
73  (let ((rx (regexp " *;[ ;]*AUTOCOMPILE *: *(.*)")))
74    (lambda (fname proc)
75      (with-input-from-file fname
76        (lambda ()
77          (read-line)                   ; she-bang line
78          (let loop ()
79            (let ((ln (read-line)))
80              (cond ((eof-object? ln))
81                    ((string-match rx ln) =>
82                     (lambda (m)
83                       (proc (cadr m))
84                       (loop)))))))))))
85
86(define (run fail fstr . args)
87  (let ((cmd (apply sprintf fstr args)))
88    (when *debug* (print "  " cmd))
89    (let ((r (system cmd)))
90      (cond ((zero? r))
91            (else
92             (when fail (fail))
93             (fprintf 
94              (current-error-port) 
95              "command failed with non-zero exit status ~a:~%~%  ~a~%" r cmd)
96             (exit 1))))) )
97
98(define (compile-and-run prg args)
99  (unless (directory-exists? *cache*)
100    (when *debug* 
101      (print "creating " *cache*) )
102    (create-directory *cache*) )
103  (let* ((hash (md5sum prg))
104         (cached (normalize-pathname (make-pathname *cache* hash *exe*))))
105    (when (or (not (file-exists? cached))
106              (> (file-modification-time prg)
107                 (file-modification-time cached) ) )
108      (let* ((qcached (qs cached))
109             (qprg (qs prg))
110             (errfile (normalize-pathname (create-temporary-file "tmp")))
111             (qerrfile (qs errfile)))
112        (scan-head 
113         prg 
114         (lambda (opts)
115           (set! *options* (string-append *options* " " opts))))
116        (when *chicken-scheme-hook*
117          (run #f "~a start ~a ~a" *chicken-scheme-hook* qprg qerrfile) )
118        (run (lambda ()
119               (if *chicken-scheme-hook*
120                   (run #f "~a fail ~a ~a" *chicken-scheme-hook* qprg qerrfile)
121                   (display (read-all errfile)) ) )
122             "~a ~a ~a -o ~a ~a"
123             *csc* *options* qprg qcached
124             (if *debug* "" (string-append "> " qerrfile)))
125        (when *chicken-scheme-hook*
126          (run #f "~a end ~a ~a" *chicken-scheme-hook* qprg qerrfile) )
127        (delete-file errfile) ) )
128    (process-execute cached args) ) )
129
130(define (main args)
131  (match args
132    (()
133     (process-execute *csi*) )
134    (((or "-h" "-help" "--help") . _)
135     (usage 0) )
136    (("-purge")
137     (purge) )
138    (("-cache")
139     (print *cache*))
140    (("-list")
141     (for-each print (directory *cache*)))
142    ((filename args ...)
143     (compile-and-run filename args) )
144    (_ (usage 1))))
145
146(main (command-line-arguments))
147
148)
Note: See TracBrowser for help on using the repository browser.