Changeset 26014 in project


Ignore:
Timestamp:
03/01/12 09:34:44 (9 years ago)
Author:
felix winkelmann
Message:

and I thought this would be easy...

Location:
release/4/system/branches/rewrite
Files:
1 deleted
5 edited

Legend:

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

    r26010 r26014  
    33
    44(require-library setup-api)
     5
     6;; this terrible hack is needed to get access to "compile-file-options"
     7;; which is not correctly exported from the "utils" module in chickens prior to
     8;; version 4.7.6
     9
     10(require 'utils)
     11(define ##fnord#compile-file-options compile-file-options)
    512
    613(module system ((define-system make-component)
  • release/4/system/branches/rewrite/system.scm

    r26012 r26014  
    1515    ((_ sname component ...)
    1616     (define sname
    17        (make <system>
    18          'name 'sname
    19          'components (list (make-component component) ...))))))
     17       (let ((sys (make <system> 'name 'sname)))
     18         (set! (system-components sys)
     19           (list (make-component component sys) ...))
     20         sys)))))
    2021
    2122(define (dribble target msg . args)
     
    3637
    3738(define (compile1 . args)
    38   (parameterize (#;(compile-file-options '()))   ;XXX
     39  (parameterize ((##fnord#compile-file-options '()))   ; see system-module.scm
    3940    (apply compile-file args)))
    4041
     
    4849
    4950(define-class <scheme-load-target> (<target>)
    50   ((load-time accessor: load-time initform: 0)
     51  ((options accessor: options initform: '())
     52   (load-time accessor: load-time initform: 0)
    5153   (force accessor: force-update initform: #f) ) )
    5254
    5355(define-class <scheme-compile-target> (<scheme-load-target>)
    54   ((options accessor: options initform: '())))
     56  () )
    5557
    5658(define-class <scheme-build-target> (<scheme-compile-target>)
     
    7274(define-class <component> ()
    7375  ((name accessor: component-name)
     76   (secondary reader: secondary-component? initform: #f)
    7477   (depends accessor: component-dependencies)))
    7578
    7679(define-class <file-component> (<component>)
    77   ((path accessor: file-component-path)
    78    (byproducts accessor: file-byproducts initform: '())))
     80  ((path accessor: file-component-path)))
    7981
    8082(define-method (print-object (f <component>) port)
     
    9395        #f)))
    9496
    95 (define (make-file-as-not-reloadable path)
     97(define (mark-file-as-not-reloadable path)
    9698  (hash-table-set!
    9799   loaded-files-that-can-not-be-reloaded 
     
    106108   (load-time accessor: load-time initform: #f)
    107109   (output-path accessor: scheme-file-output-path initform: #f)
     110   (compiled accessor: scheme-file-compiled? initform: #f)
    108111   (modules accessor: scheme-file-modules initform: '())
    109112   (temporary-output-path accessor: scheme-file-temporary-output-path initform: #f)
     
    117120        ((string? x)
    118121         (or (and sys (find-component x sys))
    119              (make <scheme-file> 'name x)))
     122             (make <scheme-file> 'name x 'secondary #t)))
    120123        ((subclass? (class-of x) <component>) x)
    121124        (else (error 'make-component "invalid component" x))))
     
    127130(define ((file-maker class #!optional ext) name #!key (depends '()) path options
    128131         output-path modules includes)
    129   (define (optarg name x)
     132  (define (optarg name x #!optional (proc identity))
    130133    (if x
    131         (list name x)
     134        (list name (proc x))
    132135        '()))
    133136  (apply
     
    138141   (append
    139142    (optarg 'output-path output-path)
    140     (optarg 'options options)
    141     (optarg 'includes includes)
    142     (optarg 'modules modules))))
     143    (optarg 'options options listify)
     144    (optarg 'includes includes listify)
     145    (optarg 'modules modules listify))))
    143146
    144147(define file (file-maker <file-component>)) 
     
    169172(define-method (component-changed? (c <component>) (t <target>)) #f)
    170173
    171 ;;XXX refactor
     174(define seen '())
     175
     176(define-method (component-changed? around: (c <component>) (t <target>))
     177  (when (memq c seen)
     178    (error "component has circular dependencies" c))
     179  (fluid-let ((seen (cons c seen)))
     180    (call-next-method)))
     181
     182(define (check-dependencies c t mtime)
     183  (let ((sys (target-system t)))
     184    (cond ((any (lambda (d)
     185                  (component-changed? (make-component d sys) t))
     186                (component-dependencies c)) =>
     187                (lambda (reason)
     188                  (augment-change-reason reason ", which is a dependency")))
     189          ((any (lambda (f)
     190                  (let* ((fc (make-component f sys))
     191                         (fpath (file-component-path fc)))
     192                    (and (file-exists? fpath)
     193                         (> (file-modification-time fpath) mtime)
     194                         (changed "included file `~a' changed" fpath))))
     195                (scheme-file-includes c)))
     196          (else #f))))
     197
    172198(define-method (component-changed? (c <scheme-file>) (t <scheme-load-target>))
    173199  (let ((in (file-component-path c))
    174         (lt (load-time c))
    175         (sys (target-system t)))
    176     (cond ((not lt)
     200        (lt (load-time c)))
     201    (cond ((secondary-component? c) #f)   
     202          ((not lt)
    177203           (changed "file has not been loaded yet"))
    178204          ((> (file-modification-time in) lt)
    179205           (changed "source file is newer than loaded file"))
    180           ((any (lambda (d)
    181                   (component-changed? (make-component d sys) t))
    182                 (component-dependencies c)) =>
    183            (lambda (reason)
    184              (augment-change-reason reason ", which is a dependency")))
    185           ((any (lambda (f)
    186                   (and (file-exists? f)
    187                        (> (file-modification-time f) lt)
    188                        (changed "included file `~a' changed" f)))
    189                 (listify (scheme-file-includes c))))
    190           (else #f))))
     206          (else (check-dependencies c t lt)))))
    191207
    192208(define-method (component-changed? (c <scheme-file>) (t <scheme-compile-target>))
    193209  (let* ((in (file-component-path c))
    194          (out (or (scheme-file-output-path c)
    195                   (make-pathname #f in "so")))
    196          (sys (target-system t))
    197          (mtime (and (file-exists? out) (file-modification-time out))))
    198     (cond ((not mtime)
    199            (changed "compiled file does not exist"))
    200           ((> (file-modification-time in) mtime)
     210         (itime (file-modification-time in))
     211         (out (scheme-file-output-path c))
     212         (mtime (and out (file-exists? out) (file-modification-time out)))
     213         (lt (load-time c)))
     214    (cond ((secondary-component? c) #f)
     215          ((not mtime)
     216           (cond ((not lt)
     217                  (changed "file has not been compiled and loaded yet"))
     218                 ((> itime lt)
     219                  (changed "source file has been changed since it has been loaded"))
     220                 (else (check-dependencies c t (max lt itime)))))
     221          ((> itime mtime)
    201222           (changed "source file is newer than compiled file"))
    202           ((any (lambda (d)
    203                   (component-changed? (make-component d sys) t))
    204                 (component-dependencies c)) =>
    205            (lambda (reason)
    206              (augment-change-reason reason ", which is a dependency")))
    207           ((any (lambda (f)
    208                   (and (file-exists? f)
    209                        (> (file-modification-time f) mtime)
    210                        (changed "included file `~a' changed" f)))
    211                 (listify (scheme-file-includes c))))
    212           (else #f))))
     223          (else (check-dependencies c t mtime)))))
    213224
    214225(define-method (component-changed? (c <scheme-file>) (t <scheme-build-target>))
     
    223234(define-method (update-component! (c <component>) (t <target>)) (void))
    224235
    225 ;;XXX loading built systems is currently not possible
    226 (define-method (update-component! (c <scheme-file>) (t <scheme-load-target>))
    227   (let* ((out (scheme-file-output-path c))
    228          (path (or out (file-component-path c))))
    229     (load path)
    230     (let ((tm (current-seconds)))
    231       (set! (load-time c) tm))))
    232 
    233 (define-method (update-component! (c <scheme-file>) (t <scheme-compile-target>))
     236(define (compile-and-load-scheme-file-as-temporary c t)
    234237  (let ((cf (compile1
    235238             (file-component-path c)
    236              options: (append (listify (options c)) (listify (options t)))
     239             options: (append (options c) (options t))
    237240             verbose: (verbose t))))
    238241    (unless cf (error "recompilation failed" c))
     242    (set! (scheme-file-compiled? c) #t)
     243    (set! (load-time c) (current-seconds))
    239244    (set! (scheme-file-temporary-output-path c) cf)
    240     (load cf)
    241     (let ((tm (current-seconds)))
     245    cf))
     246
     247(define-method (update-component! (c <scheme-file>) (t <scheme-load-target>))
     248  (let* ((tmp (scheme-file-temporary-output-path c))
     249         (out (or tmp (scheme-file-output-path c)))
     250         (path (file-component-path c)))
     251    (cond ((not (scheme-file-compiled? c))
     252           (load path))
     253          ((and out (not (file-can-be-reloaded? out)))
     254           (dribble t "recompiling component `~a' because it can not be reloaded"
     255                    (component-name c))
     256           (compile-and-load-scheme-file-as-temporary c t))
     257          ((not tmp)
     258           (mark-file-as-not-reloadable out)
     259           (load out)))
     260    (let ((tm (current-seconds)))       ; does it again for case #2 above, but, well...
    242261      (set! (load-time c) tm))))
     262
     263(define-method (update-component! (c <compiled-scheme-file>) (t <scheme-load-target>))
     264  (compile-and-load-scheme-file-as-temporary c t))
     265
     266(define-method (update-component! (c <scheme-file>) (t <scheme-compile-target>))
     267  (compile-and-load-scheme-file-as-temporary c t))
    243268
    244269(define-method (update-component! (c <scheme-file>) (t <scheme-build-target>))
    245270  (let* ((path (file-component-path c))
    246271         (out (or (scheme-file-output-path c)
    247                   (make-pathname #f path "so")))
    248          (opts0 (append (listify (options c)) (listify (options t))))
     272                  (pathname-replace-extension path "so")))
     273         (opts0 (append (options c) (options t)))
    249274         (mods (scheme-file-modules c))
    250275         (opts (if (not (null? mods))
     
    259284              verbose: (verbose t))))
    260285    (set! (scheme-file-temporary-output-path c) #f)
     286    (set! (scheme-file-compiled? c) #t)
     287    (set! (load-time c) (current-seconds))
    261288    (unless cf (error "compilation failed" c))
    262289    (for-each
     
    270297                  verbose (verbose t))
    271298           (error "compilation of import library failed" m c))))
    272      (listify mods))))
     299     mods)))
    273300
    274301(define-generic (clean-component component target))
     
    294321         (delete* il t)
    295322         (delete* ilc t)))
    296      (listify (scheme-file-modules c)))))
     323     (scheme-file-modules c))))
    297324
    298325
     
    306333
    307334(define-method (process-system (s <system>) (t <scheme-load-target>))
    308   (for-each (cut process-component <> t) (system-components s))
    309   (unless (target-dry-run? t)
    310     (set! (load-time t) (current-seconds))))
     335  (let ((f #f))
     336    (for-each
     337     (lambda (c)
     338       (when (process-component c t)
     339         (set! f #t)))
     340     (system-components s))
     341    (unless (target-dry-run? t)
     342      (set! (load-time t) (current-seconds)))
     343    f))
    311344
    312345(define-method (process-component (c <component>) (t <target>))
     
    322355             (update-component! c t))
    323356           reason))
     357        ((force-update t)
     358         (dribble
     359          t "updating component `~a' because processing was forced"
     360          (component-name c))
     361         (unless (target-dry-run? t)
     362           (update-component! c t))
     363         #t)
    324364        (else #f)))
    325365
  • release/4/system/branches/rewrite/system.setup

    r26011 r26014  
    33
    44(load "system-module.scm")
    5 (load "trace-module.scm")
    65(import system)
    76
     
    1110               output-path: "system.so"
    1211               modules: 'system
    13                options: "-O3 -d1 -JS"))
     12               options: "-O3 -d2 -JS"))
    1413
    1514(build-system system-extension)
  • release/4/system/branches/rewrite/tests/run.scm

    r26012 r26014  
    3838(print "build ...")
    3939(print (build-system xyz))              ; build
     40
     41(print "sleeping 2 seconds ...")
     42(sleep 2)
     43
     44(print "touching y.scm")
     45(touch "y.scm")
     46
     47(print "loading ...")
     48(print (load-system xyz))               ; load + force recompile
  • release/4/system/branches/rewrite/tests/xyz.system.scm

    r26012 r26014  
    33
    44(define-system xyz
    5   (file "z")
    6   (scheme-file "y" includes: '("z"))
     5  (file "z.scm")
     6  (scheme-file "y" includes: '("z.scm"))
    77  (compiled-scheme-file "x" depends: '("y") modules: "x"))
Note: See TracChangeset for help on using the changeset viewer.