source: project/release/4/autocompile/trunk/chicken-scheme.scm @ 23944

Last change on this file since 23944 was 23944, checked in by felix winkelmann, 10 years ago

autocompile 0.9: fixed netbsd-specific issue, thanks to sjamaan

File size: 3.7 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 (run fail fstr . args)
73  (let ((cmd (apply sprintf fstr args)))
74    (when *debug* (print "  " cmd))
75    (let ((r (system cmd)))
76      (cond ((zero? r))
77            (else
78             (when fail (fail))
79             (fprintf 
80              (current-error-port) 
81              "command failed with non-zero exit status ~a:~%~%  ~a~%" r cmd)
82             (exit 1))))) )
83
84(define (compile-and-run prg args)
85  (unless (directory-exists? *cache*)
86    (when *debug* 
87      (print "creating " *cache*) )
88    (create-directory *cache*) )
89  (let* ((hash (md5sum prg))
90         (cached (normalize-pathname (make-pathname *cache* hash *exe*))))
91    (when (or (not (file-exists? cached))
92              (> (file-modification-time prg)
93                 (file-modification-time cached) ) )
94      (let* ((qcached (qs cached))
95            (qprg (qs prg))
96            (errfile (normalize-pathname (create-temporary-file "tmp")))
97            (qerrfile (qs errfile)))
98        (when *chicken-scheme-hook*
99          (run #f "~a start ~a ~a" *chicken-scheme-hook* qprg qerrfile) )
100        (run (lambda ()
101               (if *chicken-scheme-hook*
102                   (run #f "~a fail ~a ~a" *chicken-scheme-hook* qprg qerrfile)
103                   (display (read-all errfile)) ) )
104             "~a ~a ~a -o ~a ~a"
105             *csc* *options* qprg qcached
106             (if *debug* "" (string-append "> " qerrfile)))
107        (when *chicken-scheme-hook*
108          (run #f "~a end ~a ~a" *chicken-scheme-hook* qprg qerrfile) )
109        (delete-file errfile) ) )
110    (process-execute cached args) ) )
111
112(define (main args)
113  (match args
114    (()
115     (process-execute *csi*) )
116    (((or "-h" "-help" "--help") . _)
117     (usage 0) )
118    (("-purge")
119     (purge) )
120    (("-cache")
121     (print *cache*))
122    (("-list")
123     (for-each print (directory *cache*)))
124    ((filename args ...)
125     (compile-and-run filename args) )
126    (_ (usage 1))))
127
128(main (command-line-arguments))
129
130)
Note: See TracBrowser for help on using the repository browser.