source: project/release/4/system/branches/rewrite/system.scm @ 26010

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

bugfixes, added trace helper

File size: 9.7 KB
Line 
1;;;; system.scm - simple system-definition facility
2
3
4(import scheme chicken)
5
6(use coops shell)
7(use srfi-1 utils posix extras files data-structures srfi-69)
8(import csi)
9
10;;; systems
11
12(define-syntax define-system
13  (syntax-rules ()
14    ((_ sname component ...)
15     (define sname
16       (make <system>
17         'name 'sname
18         'components (list (make-component component) ...))))))
19
20(define (dribble target msg . args)
21  (when (verbose target)
22    (printf "; ~a: ~?~%" (system-name (target-system target)) msg args)))
23
24(define-class <system> ()
25  ((name reader: system-name)
26   (components accessor: system-components initform: '())))
27
28(define current-system (make-parameter #f))
29
30(define-method (print-object (sys <system>) port)
31  (fprintf port "#<system ~a>" (system-name sys)))
32
33(define (listify x)
34  (if (list? x) x (list x)))
35
36
37;;; targets
38
39(define-class <target> ()
40  ((system reader: target-system)
41   (verbose accessor: verbose initform: #t)))
42
43(define-class <scheme-load-target> (<target>)
44  ((load-time accessor: load-time initform: 0)
45   (force accessor: force-update initform: #f) ) )
46
47(define-class <scheme-compile-target> (<scheme-load-target>)
48  ((options accessor: options initform: '())))
49
50(define-class <scheme-build-target> (<scheme-compile-target>)
51  () )
52
53(define-class <clean-target> (<target>)
54  () )
55
56(define-generic (create-target target))
57
58(define-method (create-target (t <target>)) #f)
59
60
61;;; components
62
63(define loaded-files-that-can-not-be-reloaded
64  (make-hash-table string=?))
65
66(define-class <component> ()
67  ((name accessor: component-name)
68   (depends accessor: component-dependencies)))
69
70(define-class <file-component> (<component>)
71  ((path accessor: file-component-path)
72   (byproducts accessor: file-byproducts initform: '())))
73
74(define-method (print-object (f <component>) port)
75  (fprintf port "#<component ~s>" (component-name f)))
76
77(define (canonical-pathname path)
78  (let ((path (normalize-pathname path)))
79    (if (absolute-pathname? path)
80        path
81        (make-pathname (current-directory) path))))
82
83(define (file-can-be-reloaded? path)
84  (not (hash-table-ref/default
85        loaded-files-that-can-not-be-reloaded 
86        (canonical-pathname path)
87        #f)))
88
89(define (make-file-as-not-reloadable path)
90  (hash-table-set! 
91   loaded-files-that-can-not-be-reloaded 
92   (canonical-pathname path)
93   #t))
94
95
96;;; specific (Scheme) components
97
98(define-class <scheme-file> (<file-component>)
99  ((modules accessor: scheme-file-modules)
100   (load-time accessor: load-time initform: #f)
101   (output-path accessor: scheme-file-output-path)
102   (modules accessor: scheme-file-modules initform: '())
103   (temporary-output-path accessor: scheme-file-temporary-output-path)
104   (options accessor: options initform: '())))
105
106(define-class <compiled-scheme-file> (<scheme-file>)
107  ())
108
109(define (make-component x #!optional sys)
110  (cond ((symbol? x) (make-component (symbol->string x)))
111        ((string? x) 
112         (or (and sys (find-component x sys))
113             (make <scheme-file> 'name x)))
114        ((subclass? (class-of x) <component>) x)
115        (else (error 'make-component "invalid component" x))))
116
117(define-method (find-component (name #t) (sys <system>))
118  (find (lambda (comp) (equal? name (component-name comp)))
119        (system-components sys)))
120
121(define ((file-maker class #!optional ext) name #!key (depends '()) path options 
122         output-path modules)
123  (define (optarg name x)
124    (if x
125        (list name x)
126        '()))
127  (apply
128   make class
129   'name name
130   'depends (listify depends)
131   'path (or path (make-pathname #f (->string name) ext))
132   (append
133    (optarg 'output-path output-path)
134    (optarg 'options options)
135    (optarg 'modules modules))))
136
137(define file (file-maker <file-component>)) 
138(define scheme-file (file-maker <scheme-file> "scm"))
139(define compiled-scheme-file (file-maker <compiled-scheme-file> "scm"))
140
141(define-record changed reason)
142
143(define (changed reason . args)
144  (and reason
145       (make-changed 
146        (if (string? reason)
147            (apply sprintf reason args)))))
148
149(define (augment-change-reason reason msg . args)
150  (make-changed
151   (sprintf "~a~?"
152     (if (changed? reason)
153         (changed-reason reason)
154         "")
155     msg args)))
156
157(define-generic (component-changed? component target))
158
159(define-method (component-changed? (c <component>) (t <target>)) #f)
160
161(define-method (component-changed? (c <scheme-file>) (t <scheme-load-target>))
162  (let ((in (file-component-path c))
163        (lt (load-time c)))
164    (cond ((not lt) 
165           (changed "file has not been loaded yet"))
166          ((> (file-modification-time in) lt)
167           (changed "source file is newer than loaded file"))
168          ((any (cut component-changed? <> t) (component-dependencies c)) =>
169           (lambda (reason)
170             (augment-change-reason reason ", which is a dependency")))
171          (else #f))))
172
173(define-method (component-changed? (c <scheme-file>) (t <scheme-compile-target>))
174  (let ((in (file-component-path c))
175        (out (scheme-file-output-path c)))
176    (cond ((not (file-exists? out))
177           (changed "compiled file does not exist"))
178          ((> (file-modification-time in)
179              (file-modification-time out))
180           (changed "source file is newer than compiled file"))
181          ((any (cut component-changed? <> t) (component-dependencies c)) =>
182           (lambda (reason)
183             (augment-change-reason reason ", which is a dependency")))
184          (else #f))))
185
186(define-method (component-changed? (c <scheme-file>) (t <scheme-build-target>))
187  (or (call-next-method)
188      (and (not (file-can-be-reloaded? (scheme-file-output-path c)))
189           (changed "currently loaded file can not be reloaded"))))
190
191(define-generic (update-component! component target))
192
193(define-method (update-component! (c <component>) (t <target>)) (void))
194
195(define-method (update-component! (c <scheme-file>) (t <scheme-load-target>))
196  (load (file-component-path c))
197  (let ((tm (current-seconds)))
198    (set! (load-time c) tm)))
199
200(define-method (update-component! (c <scheme-file>) (t <scheme-compile-target>))
201  (let ((cf (compile-file 
202             (file-component-path c) 
203             options: (append (options c) (options t))
204             verbose: (verbose t))))
205    (unless cf (error "recompilation failed" c))
206    (set! (scheme-file-temporary-output-path c) cf)
207    (load cf)
208    (let ((tm (current-seconds)))
209      (set! (load-time c) tm))))
210
211(define-method (update-component! (c <scheme-file>) (t <scheme-build-target>))
212  (let ((out (scheme-file-output-path c)))
213    (when (and (load-time c)
214               (not (file-can-be-reloaded? out)))
215      (let* ((opts0 (append (options c) (options t)))
216             (mods (scheme-file-modules c))
217             (opts (if (pair? mods)
218                       (cons "-J" opts0)
219                       opts0))
220             (path (file-component-path c))
221             (dir (pathname-directory out))
222             (cf (compile-file
223                  path
224                  output-file: out
225                  load: #f
226                  options: opts
227                  verbose: (verbose t))))
228        (set! (scheme-file-temporary-output-path c) cf)
229        (unless cf (error "compilation failed" c))
230        (for-each
231         (lambda (m)
232           (let ((m (->string m)))
233             (unless (compile-file
234                      (make-pathname dir m "import.scm")
235                      output-file: (make-pathname dir m "import.so")
236                      options: opts0
237                      load: #f
238                      verbose (verbose t))
239               (error "compilation of import library `~a' failed" m c))))
240         mods)))))
241
242(define-generic (clean-component component target))
243
244(define-method (clean-component (c <component>) (t <target>)) #f)
245
246(define (delete* fn)
247  (when (file-exists? n)
248    (dribble t "deleting ~a" dn)
249    (delete-file* dn)))
250
251(define-method (clean-component (c <scheme-file>) (t <target>)) 
252  (when (load-time c)
253    (let* ((path (scheme-file-output-path c))
254           (dir (pathname-directory path)))
255      (delete* path)))
256  (for-each
257   (lambda (m)
258     (let ((il (make-pathname dir (->string m) "import.scm"))
259           (ilc (make-pathname dir (->string m) "import.so")))
260       (delete* il)
261       (delete* ilc)))
262   (scheme-file-modules c)))
263
264
265;;; processing of systems and components with respect to a given target
266
267(define-generic (process-system system target))
268(define-generic (process-component component target))
269
270(define-method (process-system (s <system>) (t <target>))
271  (for-each (cut process-component <> t) (system-components s)))
272
273(define-method (process-system (s <system>) (t <scheme-load-target>))
274  (for-each (cut process-component <> t) (system-components s))
275  (set! (load-time t) (current-seconds)))
276
277(define-method (process-component (c <component>) (t <target>))
278  (cond ((component-changed? c t) =>
279         (lambda (reason)
280           (dribble 
281            t "updating component `~a' because ~a" 
282            (component-name c)
283            (if (changed? reason)
284                (changed-reason reason)
285                "it changed"))
286           (update-component! c t)
287           reason))
288        (else #f)))
289
290(define-method (process-component (c <component>) (t <clean-target>))
291  (clean-component c t))
292
293
294;;; main entry points
295
296(define (load-system sys #!key quiet force)
297  (let ((tgt (make <scheme-load-target>
298               'system sys
299               'verbose (not quiet)
300               'force force)))
301    (process-system sys tgt)))
302
303(define (compile-system sys #!key quiet force)
304  (let ((tgt (make <scheme-compile-target>
305               'system sys
306               'verbose (not quiet)
307               'force force)))
308    (process-system sys tgt)))
309
310(define (build-system sys #!key quiet force)
311  (let ((tgt (make <scheme-build-target>
312               'system sys
313               'verbose (not quiet)
314               'force force)))
315    (process-system sys tgt)))
316
317(define (clean-system sys)
318  (let ((tgt (make <clean-target> 'system sys)))
319    (process-system sys tgt)))
320
321
322;;; csi toplevel commands
323
324(when (feature? #:csi)
325  (let ()
326    (define (check)
327      (unless (current-system)
328        (print* "Enter expression that evaluates to a system: ")
329        (current-system (eval (read))))
330      (current-system))
331    (toplevel-command
332     'ls
333     (lambda () (load-system (check)))
334     ",ls               load selected system")
335    (toplevel-command
336     'cs
337     (lambda () (load-system (check)))
338     ",cs               compile selected system")
339    (toplevel-command
340     'sys
341     (lambda () (current-system (eval (read))))
342     ",sys SYSTEM       select system")))
Note: See TracBrowser for help on using the repository browser.