source: project/release/5/autocompile/tags/1.1.0/chicken-scheme.scm @ 36221

Last change on this file since 36221 was 36221, checked in by felix winkelmann, 20 months ago

autocompile 1.1.0 (thanks, wasamasa!)

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