source: project/release/4/inline/tags/1.9/inline.scm @ 28760

Last change on this file since 28760 was 28760, checked in by felix winkelmann, 7 years ago

inline 1.9: use simple-sha1, as md5 introduces too many dependencies

File size: 3.9 KB
Line 
1;;;; inline.scm
2;
3; Copyright (c) 2003-2013, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25
26
27(module inline (inline inline-compile inline-eval inline-cache)
28
29(import scheme chicken foreign)
30(use bind simple-sha1 files extras utils posix data-structures)
31
32(define-syntax inline
33  (syntax-rules ()
34    ((_ text more ...)
35     (cond-expand
36       (compiling (bind* ,text))
37       (else (inline-compile text more ...)) ) )))
38
39(define (inline-eval x . o)
40  (inline-compile x (if (pair? o) (car o) "") #t))
41
42(define +default-inline-cache-name+
43  (or (get-environment-variable "CHICKEN_INLINE_CACHE")
44      (make-pathname (get-environment-variable "HOME") ".chicken-inline")))
45
46(define windows-shell (foreign-value "C_WINDOWS_SHELL" bool))
47(define inline-cache (make-parameter +default-inline-cache-name+))
48
49(define catalog '())    ; ((#(HASH OPTIONS TEXT) . PROC) ...)
50
51(define (inline-compile text . more)
52  (let* ([opts (if (pair? more) (car more) "")]
53         [scheme? (and (pair? more) (pair? (cdr more)) (cadr more))]
54         [hc (string->sha1sum (if scheme? (->string text) text))]
55         [tmp-sym (and scheme? (string->symbol (string-append "inline#" hc)))]
56         [fname (make-pathname (inline-cache) (->string hc) "scm")]
57         [p (vector hc opts text)]
58         [a (member p catalog)] )
59    (define (doload fname)
60      (load (pathname-replace-extension fname ##sys#load-dynamic-extension)) )
61    (unless a
62      (let ([tmp (create-temporary-file "scm")]
63            (cmd (sprintf "csc ~A -s -O2 -d1 ~A -R bind" fname opts)))
64        (with-output-to-file tmp
65          (lambda ()
66            (printf "; ~A~%" cmd)
67            (if scheme?
68                (pp `(define (,tmp-sym) ,text))
69                (pp `(bind* ,text)))) )
70        (ensure-cache)
71        (if (and (file-exists? fname) (files-equal? tmp fname))
72            (begin
73              (delete-file* tmp)
74              (doload fname)
75              (update-inline-catalog p) )
76            (begin
77              (system*
78               "~a ~A ~A"
79               (if windows-shell "move" "mv")
80               (qs tmp) (qs fname))
81              (system* cmd)
82              (doload fname)
83              (update-inline-catalog p) ) ) ) )
84    (if scheme?
85        ((eval tmp-sym))
86        (void)) ) )
87
88(define (update-inline-catalog key)
89  (unless (member key catalog)
90    (set! catalog (cons key catalog)) ) )
91
92(define (files-equal? a b)
93  (and (= (file-size a) (file-size b))
94       (if windows-shell
95           (string=? (read-all a) (read-all b))
96           (zero? (system (sprintf "cmp -s ~A ~A" (qs a) (qs b)))) )))
97
98(define (ensure-cache)
99  (unless (file-exists? (inline-cache))
100    (create-directory (inline-cache) #t) ) )
101
102)
Note: See TracBrowser for help on using the repository browser.