source: project/chicken/trunk/utils.scm @ 15414

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

handle errors when deleting files and optional loading for compile-file

File size: 5.0 KB
Line 
1;;;; utils.scm - Utilities for scripting and file stuff
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29  (unit utils)
30  (uses extras srfi-13 posix files)
31  (usual-integrations)
32  (fixnum)
33  (hide chop-pds)
34  (disable-interrupts) )
35
36(cond-expand
37 [paranoia]
38 [else
39  (declare
40    (always-bound
41      ##sys#windows-platform)
42    (bound-to-procedure
43      ##sys#check-port port? read-string for-each-line read-line with-input-from-file
44      command-line-arguments
45      string-append
46      system)
47    (no-procedure-checks-for-usual-bindings)
48    (no-bound-checks))] )
49
50(include "unsafe-declarations.scm")
51
52(register-feature! 'utils)
53
54
55;;; Like `system', but allows format-string and bombs on nonzero return code:
56
57(define system*
58  (let ([sprintf sprintf]
59        [system system] )
60    (lambda (fstr . args)
61      (let* ([str (apply sprintf fstr args)]
62             [n (system str)] )
63        (unless (zero? n)
64          (##sys#error "shell invocation failed with non-zero return status" str n) ) ) ) ) )
65
66
67;;; Handy I/O procedures:
68
69(define for-each-line
70  (let ([read-line read-line])
71    (lambda (proc . port)
72      (let ([port (if (pair? port) (car port) ##sys#standard-input)])
73        (##sys#check-port port 'for-each-line)
74        (let loop ()
75          (let ([ln (read-line port)])
76            (unless (eof-object? ln)
77              (proc ln)
78              (loop) ) ) ) ) ) ) )
79
80
81;; This one is from William Annis:
82
83(define (for-each-argv-line thunk)
84  (define (file-iterator file thunk)
85    (if (string=? file "-")
86        (for-each-line thunk)
87        (with-input-from-file file (cut for-each-line thunk) ) ) )
88  (let ((args (command-line-arguments)))
89    (if (null? args)
90        ;; If no arguments, take from stdin,
91        (for-each-line thunk)
92        ;; otherwise, hit each file named in argv.
93        (for-each (lambda (arg) (file-iterator arg thunk)) args))))
94
95
96;;; Read file as string from given filename or port:
97
98(define (read-all . file)
99  (let ([file (optional file ##sys#standard-input)])
100    (if (port? file)
101        (read-string #f file)
102        (with-input-from-file file (cut read-string #f)) ) ) )
103
104
105;;; Quote string for shell
106
107(define (qs str #!optional (platform (build-platform)))
108  (case platform
109    ((mingw32 msvc)
110     (string-append "\"" str "\""))
111    (else
112     (if (zero? (string-length str))
113         "''"
114         (string-concatenate
115          (map (lambda (c)
116                 (if (or (char-whitespace? c)
117                         (memq c '(#\# #\" #\' #\` # #\~ #\& #\% #\$ #\! #\* #\; #\< #\> #\\
118                                   #\( #\) #\[ #\] #\{ #\})))
119                     (string #\\ c)
120                     (string c)))
121               (string->list str)))))))
122
123
124;;; Compile and load file
125
126(define compile-file-options (make-parameter '("-S" "-O2" "-d2")))
127
128(define compile-file
129  (let ((csc (foreign-value "C_CSC_PROGRAM" c-string))
130        (path (foreign-value "C_INSTALL_BIN_HOME" c-string)) 
131        (load-file load))
132    (lambda (filename #!key (options '()) output-file (load #t))
133      (let ((cscpath (or (file-exists? (make-pathname path csc)) "csc"))
134            (tmpfile (and (not output-file) (create-temporary-file "so")))
135            (crapshell (cond-expand ((or mingw32 msvc) #t) (else #f))))
136        (print "; compiling " filename " ...")
137        (system* 
138         "~a~a -s ~a ~a -o ~a~a" 
139         (if crapshell "\"" "")
140         (qs cscpath)
141         (string-intersperse (append (compile-file-options) options) " ")
142         (qs filename)
143         (qs (or output-file tmpfile))
144         (if crapshell "\"" ""))
145        (unless output-file 
146          (on-exit
147           (lambda ()
148             (handle-exceptions ex #f (delete-file* tmpfile)))))
149        (when load
150          (let ((f (or output-file tmpfile)))
151            (handle-exceptions ex
152                (begin
153                  (delete-file* f)
154                  (abort ex))
155              (load-file f)
156              f)))))))
Note: See TracBrowser for help on using the repository browser.