Changeset 25971 in project


Ignore:
Timestamp:
02/25/12 12:48:41 (8 years ago)
Author:
felix winkelmann
Message:

started rewrite

Location:
release/4/system/branches
Files:
1 added
3 edited
1 copied

Legend:

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

    r20536 r25971  
    66(module system ((define-system make-component)
    77                <system>
     8                <target>
    89                system-name
    910                system-components
    1011                current-system
     12                target-system
    1113                <component>
    1214                component-name
    13                 <file>
    14                 file-dependencies
    15                 file-includes
     15                component-dependencies
     16                <file-component>
     17                file-component-path
    1618                <scheme-file>
    17                 <compiled-scheme-file>
     19                scheme-file-modules
     20                compiled-scheme-file-options
     21                compiled-scheme-file-output-path
    1822                find-component
    1923                file
    2024                scheme-file
     25                scheme-module
    2126                compiled-scheme-file
    22                 file-path
     27                compiled-scheme-module
    2328                load-system
    2429                compile-system
    2530                clean-system
    2631                build-system
    27                 file-needs-reload?
    28                 file-needs-recompile?
    29                 file-needs-rebuild?
    30                 clean-file
    31                 build-file
    32                 reload-file
    33                 rebuild-file
    34                 recompile-file)
     32                process-system
     33                process-component
     34                create-target
     35                component-changed?
     36                update-component!)
    3537
    3638"system.scm")
  • release/4/system/branches/rewrite/system.scm

    r23662 r25971  
    99
    1010
    11 (define verbose-action (make-parameter #f))
     11;;; systems
    1212
    1313(define-syntax define-system
     
    1919         'components (list (make-component component) ...))))))
    2020
    21 (define (dribble . args)
    22   (when (verbose-action)
    23     (apply print "; " (system-name (current-system)) ": " args)))
     21(define (dribble target . args)
     22  (when (verbose-actions target)
     23    (apply print "; " (system-name (target-system target)) ": " args)))
    2424
    2525(define-class <system> ()
     
    3232  (fprintf port "#<system ~a>" (system-name sys)))
    3333
     34
     35;;; targets
     36
     37(define-class <target> ()
     38  ((system reader: target-system)))
     39
     40
     41;;; components
     42
    3443(define-class <component> ()
    35   ((name accessor: component-name)))
     44  ((name accessor: component-name)
     45   (depends accessor: component-dependencies)))
    3646
    37 (define-class <file> (<component>)
    38   ((path initform: #f)
    39    (explanation accessor: file-action-explanation initform: #f)
    40    (includes accessor: file-includes initform: '())
    41    (depends accessor: file-dependencies initform: '())))
     47(define-class <file-component> (<component>)
     48  ((path accessor: file-component-path)))
    4249
    4350(define-method (print-object (f <component>) port)
    4451  (fprintf port "#<component ~s>" (component-name f)))
    4552
    46 (define-class <scheme-file> (<file>)
    47   ((compiled-file accessor: file-compiled-file initform: #f)
    48    (compile-options accessor: file-compile-options initform: '())
    49    (last-load-time accessor: file-last-load-time initform: #f) ))
     53
     54;;; specific (Scheme) components
     55
     56(define-class <scheme-file> (<file-componment>)
     57  ((modules accessor: scheme-file-modules)))
    5058
    5159(define-class <compiled-scheme-file> (<scheme-file>)
    52   ())
     60  ((output-path accessor: compiled-scheme-file-output-path)
     61   (options accessor: compiled-scheme-file-options initform: '())))
    5362
     63(define-generic (compiled-scheme-file-path (f <scheme-file>) (t <target>)))
     64 
    5465(define (make-component x #!optional sys)
    5566  (cond ((symbol? x) (make-component (symbol->string x)))
     
    5768         (or (and sys (find-component x sys))
    5869             (make <scheme-file> 'name x)))
    59         ((subclass? (class-of x) <file>) x)
     70        ((subclass? (class-of x) <component>) x)
    6071        (else (error 'make-component "invalid component" x))))
    6172
    6273(define-method (find-component (name #t) (sys <system>))
    63   (find (lambda (comp) (string=? name (component-name comp)))
     74  (find (lambda (comp) (equal? name (component-name comp)))
    6475        (system-components sys)))
    6576
    66 (define ((file-maker class) name #!key (depends '()) (includes '()) path options)
     77(define ((file-maker class #!optional ext) name #!key (depends '()) path options
     78         output-path modules)
    6779  (define (listify x)
    68     (if (list? x)
    69         x
    70         (list x)))
     80    (if (list? x) x (list x)))
     81  (define (optarg name x)
     82    (if x
     83        (list name x)
     84        '()))
    7185  (apply
    7286   make class
    7387   'name name
    7488   'depends (listify depends)
    75    'includes (listify includes)
    76    'path path
    77    (if options (list 'compile-options (listify options)) '())))
     89   'path (or path (make-pathname #f (->string name) ext))
     90   (append
     91    (if output-path (list 'output-path output-path) '())
     92    (if options (list 'options (listify options)) '())
     93    (if modules (list 'modules (listify options)) '()))))
    7894
    7995(define file (file-maker <file>)) 
    80 (define scheme-file (file-maker <scheme-file>))
    81 (define compiled-scheme-file (file-maker <compiled-scheme-file>))
     96(define scheme-file (file-maker <scheme-file> "scm"))
     97(define scheme-module (file-maker <scheme-file> "scm"))
     98(define compiled-scheme-file (file-maker <compiled-scheme-file> "scm"))
     99(define compiled-scheme-module (file-maker <compiled-scheme-file> "scm"))
    82100
    83 (define-method (file-path (s #t)) s)
    84101
    85 (define-method (file-path (f <file>))
    86   (or (slot-value f 'path)
    87       (let* ((name (component-name f))
    88              (fn (or (file-exists? (make-pathname #f name "scm"))
    89                      (file-exists? name)
    90                      (error 'file-path "file not found" name))))
    91         (set! (slot-value f 'path) fn)
    92         fn)))
    93 
    94 (define-method ((setter file-path) (f <file>) path)
    95   (set! (slot-value f 'path) path))
    96 
    97 (define (walk sys test action)
    98   (let walk ((comps (system-components sys)))
    99     (let ((changed #f))
    100       (for-each
    101        (lambda (comp)
    102          (let ((deps (canonicalize-files (file-dependencies comp) sys))
    103                (incs (canonicalize-files (file-includes comp) sys)))
    104            (set! (file-dependencies comp) deps)
    105            (set! (file-includes comp) incs)
    106            (let ((flag (walk deps)))
    107              (cond (flag
    108                     (set! (file-action-explanation comp)
    109                       (sprintf "dependency of ~s changed" (component-name comp))))
    110                    ((any test deps) (set! flag #t))
    111                    ((test comp) (set! flag #t)))
    112              (when flag
    113                (set! changed #t)
    114                (action comp)))))
    115        comps)
    116       changed)))
    117 
    118 (define (canonicalize-files files sys)
    119   (if (any (lambda (x) (or (string? x) (symbol? x))) files)
    120       (map (cut make-component <> sys) files)
    121       files))
    122 
    123 (define (file-newer? f1 f2)
    124   (> (file-modification-time (file-path f1))
    125      (file-modification-time (file-path f2))))
    126 
    127 (define (load-system sys #!key quiet force)
    128   (parameterize ((verbose-action (not quiet))
    129                  (current-system sys)
    130                  (##sys#current-module #f))
    131     (when force (clean-system sys))
    132     (or (walk sys file-needs-reload? reload-file)
    133         (begin
    134           (dribble "nothing to do.")
    135           #f))))
    136 
    137 (define (compile-system sys #!key quiet force)
    138   (parameterize ((verbose-action (not quiet))
    139                  (current-system sys))
    140     (when force (clean-system sys))
    141     (or (walk sys file-needs-recompile? recompile-file)
    142         (begin
    143           (dribble "nothing to do.")
    144           #f))))
    145 
    146 (define (clean-system sys)
    147   (for-each clean-file (system-components sys)))
    148 
    149 (define (build-system sys #!key quiet force)
    150   (parameterize ((verbose-action (not quiet))
    151                  (current-system sys))
    152     (when force (clean-system sys))
    153     (or (walk sys file-needs-rebuild? rebuild-file)
    154         (begin
    155           (dribble "nothing to do.")
    156           #f))))
    157 
    158 (define-method (clean-file (f <file>)) (void))
    159 
    160 (define-method (clean-file (f <scheme-file>))
    161   (set! (file-last-load-time f) #f)
    162   (set! (file-compiled-file f) #f)
    163   (delete-file* (pathname-replace-extension (file-path f) "so"))) ; for build-system
    164 
    165 (define-method (build-file (f <file>)) (void))
    166 
    167 (define-method (build-file (f <scheme-file>))
    168   (when (file-needs-rebuild? f)
    169     (rebuild-file f)))
    170 
    171 (define-method (file-needs-reload? (f <file>)) #f)
    172 
    173 (define-method (file-needs-reload? (sf <scheme-file>))
    174   (let ((llt (file-last-load-time sf)))
    175     (cond ((not llt)
    176            (set! (file-action-explanation sf)
    177              (sprintf
    178                  "file ~s needs to be reloaded because it hasn't been loaded yet"
    179                (component-name sf)))
    180            #t)
    181           ((> (file-modification-time (file-path sf)) llt)
    182            (set! (file-action-explanation sf)
    183              (sprintf "file ~s needs to be reloaded because it has changed"
    184                (component-name sf)))
    185            #t)
    186           ((any (cut include-file-newer? <> llt) (file-includes sf))
    187            (set! (file-action-explanation sf)
    188              (sprintf "file ~s needs to be reloaded because included file has changed"
    189                (component-name sf)))
    190            #t)
    191           (else
    192            (set! (file-action-explanation sf) #f)
    193            #f))))
    194 
    195 (define-method (file-needs-recompile? (sf <scheme-file>))
    196   (let ((fcf (file-compiled-file sf)))
    197     (cond ((not fcf)
    198            (set! (file-action-explanation sf)
    199              (sprintf "file ~s needs to be recompiled because it hasn't been compiled yet"
    200                (component-name sf)))
    201            #t)
    202           ((file-newer? sf fcf)
    203            (set! (file-action-explanation sf)
    204              (sprintf "file ~s needs to be recompiled because it has changed"
    205                (component-name sf)))
    206            #t)
    207           ((any (cute include-file-newer? <> (file-modification-time fcf))
    208                 (file-includes sf))
    209            (set! (file-action-explanation sf)
    210              (sprintf "file ~s needs to be recompiled because included file has changed"
    211                (component-name sf)))
    212            #t)
    213           (else
    214            (set! (file-action-explanation sf) #f)
    215            #f))))
    216 
    217 (define-method (file-needs-rebuild? (f <file>)) #f)
    218 
    219 (define-method (file-needs-rebuild? (sf <scheme-file>))
    220   (let* ((path (file-path sf))
    221          (cf (pathname-replace-extension path "so"))
    222          (cfx (file-exists? cf))
    223          (lmt (and cfx (file-modification-time cf))))
    224     (cond ((not cfx)
    225            (set! (file-action-explanation sf)
    226              (sprintf "file ~s needs to be rebuilt because no compiled version exists"
    227                (component-name sf)))
    228            #t)
    229           ((> (file-modification-time path) lmt)
    230            (set! (file-action-explanation sf)
    231              (sprintf "file ~s needs to be rebuilt because it has been modified"
    232                (component-name sf)))
    233            #t)
    234           ((any (cut include-file-newer? <> lmt) (file-includes sf))
    235            (set! (file-action-explanation sf)
    236              (sprintf "file ~s needs to be rebuilt because included file has changed"
    237                (component-name sf)))
    238            #t)
    239           (else
    240            (set! (file-action-explanation sf) #f)
    241            #f))))
    242 
    243 (define (include-file-newer? f time)
    244   (> (file-modification-time (file-path f)) time))
    245        
    246 (define (show-action-explanation f)
    247   (and-let* ((exp (file-action-explanation f)))
    248     (dribble exp)))
    249 
    250 (define-method (reload-file (f <file>)) (void))
    251 
    252 (define-method (reload-file (sf <scheme-file>))
    253   (show-action-explanation sf)
    254   (parameterize ((load-verbose (verbose-action)))
    255     (load (file-path sf)))
    256   (set! (file-last-load-time sf) (current-seconds)))
    257 
    258 (define-method (reload-file (csf <compiled-scheme-file>))
    259   (recompile-file csf))
    260 
    261 (define-method (recompile-file (f <file>)) (void))
    262 
    263 (define-method (recompile-file (sf <scheme-file>))
    264   (show-action-explanation sf)
    265   (let ((cf (compile-file
    266              (file-path sf)
    267              options: (file-compile-options sf)
    268              verbose: (verbose-action))))
    269     (unless cf (error "recompilation failed" sf))
    270     (set! (file-last-load-time sf) (current-seconds))
    271     (set! (file-compiled-file sf) cf)))
    272 
    273 (define-method (rebuild-file (f <file>)) (void))
    274 
    275 (define-method (rebuild-file (sf <scheme-file>))
    276   (show-action-explanation sf)
    277   (let* ((path (file-path sf))
    278          (out (pathname-replace-extension path "so")))
    279     (parameterize ((shell-verbose (verbose-action)))
    280       (run (csc ,@(file-compile-options sf) -J -s ,path -o ,out)))))
     102;;XXX to be continued ...
    281103
    282104
  • release/4/system/branches/rewrite/system.setup

    r23662 r25971  
    11;;;; system.setup -*- Scheme -*-
    22
    3 (compile -s -O3 -d1 system-module.scm -JS -o system.so)
    4 (compile -s -O3 -d0 system.import.scm)
     3
     4(load "system-module.scm")
     5(import system)
     6
     7(define-system system-extension
     8  (scheme-module "system-module"
     9                 depends: "system.scm"
     10                 output-path: "system.so"
     11                 modules: 'system
     12                 options: "-O3 -d1 -JS"))
     13
     14(build-system system-extension)
    515
    616(install-extension
Note: See TracChangeset for help on using the changeset viewer.