Changeset 26008 in project


Ignore:
Timestamp:
02/29/12 10:13:28 (9 years ago)
Author:
felix winkelmann
Message:

getting slightly better

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/system/branches/rewrite/system.scm

    r26006 r26008  
    1919         'components (list (make-component component) ...))))))
    2020
    21 (define (dribble target . args)
     21(define (dribble target msg . args)
    2222  (when (verbose target)
    23     (apply print "; " (system-name (target-system target)) ": " args)))
     23    (printf "; ~a: ~?~%" (system-name (target-system target)) msg args)))
    2424
    2525(define-class <system> ()
     
    3939   (verbose accessor: verbose initform: #t)))
    4040
     41(define-class <scheme-load-target> (<target>)
     42  ((load-time accessor: load-time initform: 0)
     43   (force accessor: force-update initform: #f) ) )
     44
     45(define-class <scheme-compile-target> (<scheme-load-target>)
     46  ((options accessor: options initform: '())))
     47
     48(define-class <scheme-build-target> (<scheme-compile-target>)
     49  () )
     50
    4151
    4252;;; components
     53
     54(define loaded-files-that-can-not-be-reloaded
     55  (make-hash-table string=?))
    4356
    4457(define-class <component> ()
     
    5265  (fprintf port "#<component ~s>" (component-name f)))
    5366
     67(define (file-can-be-reloaded? path)
     68  (not (hash-table-ref/default loaded-files-that-can-not-be-reloaded #f)))
     69
     70(define (make-file-as-not-reloadable path)
     71  (hash-table-set! loaded-files-that-can-not-be-reloaded path #t))
     72
    5473
    5574;;; specific (Scheme) components
     
    5776(define-class <scheme-file> (<file-componment>)
    5877  ((modules accessor: scheme-file-modules)
    59    (load-time accessor: scheme-file-load-time initform: #f)
    60    (compiled-output-path accessor: scheme-file-compiled-output-path)
    61    (options accessor: scheme-file-options initform: '())))
     78   (load-time accessor: load-time initform: #f)
     79   (output-path accessor: scheme-file-output-path)
     80   (temporary-output-path accessor: scheme-file-temporary-output-path)
     81   (options accessor: options initform: '())))
    6282
    6383(define-class <compiled-scheme-file> (<scheme-file>)
     
    102122(define-record changed reason)
    103123
    104 (define (changed? reason . argfs)
     124(define (changed reason . args)
    105125  (and reason
    106126       (make-changed
     
    108128            (apply sprintf reason args)))))
    109129
     130(define (augment-change-reason reason msg . args)
     131  (make-changed (sprintf "~a~?" msg args)))
     132
    110133(define-generic (component-changed? component target))
    111 (define-generic (component-needs-recompile? component target))
    112134
    113135(define-method (component-changed? (c <component>) (t <target>)) #f)
    114136
    115 (define-method (component-needs-recompile? (c <component>) (t <target>)) #f)
    116 
    117 (define-method (component-needs-recompile? (c <scheme-file>) (t <target>)) #f)
    118   ;;XXX
    119   )
    120 
    121 (define-method (component-needs-recompile? (c <compiled-scheme-file>) (t <target>))
    122   ;;XXX
    123   )
    124 
    125 (define-method (component-changed? (c <scheme-file>) (t <target>))
    126   ;;XXX determine whether we need to compile/load and use "component-needs-recompile?"
     137(define-method (component-changed? (c <scheme-file>) (t <scheme-load-target>))
    127138  (let ((in (file-component-path c))
    128         (out (schene-file-compiled-output-path c)))
     139        (lt (load-time c)))
     140    (cond ((not lt)
     141           (changed "file has not been loaded yet"))
     142          ((> (file-modification-time in) lt)
     143           (changed "source file is newer than loaded file"))
     144          ((any (cut component-changed? <> t) (component-dependencies c)) =>
     145           (lambda (reason)
     146             (augment-change-reason reason ", which is a dependency")))
     147          (else #f))))
     148
     149(define-method (component-changed? (c <scheme-file>) (t <scheme-compile-target>))
     150  (let ((in (file-component-path c))
     151        (out (scheme-file-output-path c)))
    129152    (cond ((not (file-exists? out))
    130153           (changed "compiled file does not exist"))
     
    132155              (file-modification-time out))
    133156           (changed "source file is newer than compiled file"))
     157          ((any (cut component-changed? <> t) (component-dependencies c)) =>
     158           (lambda (reason)
     159             (augment-change-reason reason ", which is a dependency")))
    134160          (else #f))))
    135161
    136 (define-method (component-changed? (c <compiled-scheme-file>) (t <target>))
    137   (component-needs-recompile? c t))
     162(define-method (component-changed? (c <scheme-file>) (t <scheme-build-target>))
     163  (or (call-next-method)
     164      (and (not (file-can-be-reloaded? (scheme-file-output-path c)))
     165           (changed "currently loaded file can not be reloaded"))))
    138166
    139167(define-generic (update-component! component target))
     
    141169(define-method (update-component! (c <component>) (t <target>)) (void))
    142170
    143 (define-method (update-component! (c <scheme-file>) (t <target>))
    144   ;;XXX determine whether to compile or load
     171;;XXX if a system has been built, then it should be possible to load
     172;;    the build binaries instead of recompiling it; this may happen
     173;;    only once, since after the first load the so's can not be reloaded.
     174
     175(define-method (update-component! (c <scheme-file>) (t <scheme-load-target>))
     176  (load (file-component-path c))
     177  (let ((tm (current-seconds)))
     178    (set! (load-time c) tm)))
     179
     180(define-method (update-component! (c <scheme-file>) (t <scheme-compile-target>))
    145181  (let ((cf (compile-file
    146182             (file-component-path c)
    147              options: (scheme-file-options c)
     183             options: (append (options c) (options t))
    148184             verbose: (verbose t))))
    149     (unless cf (error "recompilation failed" sf))))
    150 
    151 
    152 ;;XXX to be continued ...
     185    (unless cf (error "recompilation failed" sf))
     186    (set! (scheme-file-temporary-output-path c) cf)
     187    (load cf)
     188    (let ((tm (current-seconds)))
     189      (set! (load-time c) tm))))
     190
     191(define-method (update-component! (c <scheme-file>) (t <scheme-build-target>))
     192  (let* ((out (scheme-file-output-path c))
     193         (cf (compile-file
     194              (file-component-path c)
     195              output-file: out
     196              options: (append (options c) (options t))
     197              verbose: (verbose t))))
     198    (unless cf (error "compilation failed" sf))))
     199
     200
     201;;; processing of systems and components with respect to a given target
     202
     203(define-generic (process-system system target))
     204(define-generic (process-component component target))
     205
     206(define-method (process-system (s <system>) (t <target>))
     207  (for-each (cut process-component <> t) (system-components s)))
     208
     209(define-method (process-component (c <component>) (t <target>))
     210  (cond ((component-changed? c t) =>
     211         (lambda (reason)
     212           (dribble target "updating component `~a' because ~a"
     213                    (if (changed? reason)
     214                        (changed-reason reason)
     215                        "it changed"))
     216           (update-component! c t)
     217           reason))
     218        (else #f)))
     219
     220
     221;;; main entry points
     222
     223(define (load-system sys #!key quiet force)
     224  (let ((tgt (make <scheme-load-target>
     225               'system sys
     226               'verbose (not quiet)
     227               'force force)))
     228    (process-system sys tgt)))
     229
     230(define (compile-system sys #!key quiet force)
     231  (let ((tgt (make <scheme-compile-target>
     232               'system sys
     233               'verbose (not quiet)
     234               'force force)))
     235    (process-system sys tgt)))
     236
     237(define (build-system sys #!key quiet force)
     238  (let ((tgt (make <scheme-build-target>
     239               'system sys
     240               'verbose (not quiet)
     241               'force force)))
     242    (process-system sys tgt)))
    153243
    154244
Note: See TracChangeset for help on using the changeset viewer.