;;;; system.scm - simple system-definition facility (import scheme chicken) (use coops shell) (use srfi-1 utils posix extras files) (import csi) (define verbose-action (make-parameter #f)) (define-syntax define-system (syntax-rules () ((_ sname component ...) (define sname (make 'name 'sname 'components (list (make-component component) ...)))))) (define (dribble . args) (when (verbose-action) (apply print "; " (system-name (current-system)) ": " args))) (define-class () ((name reader: system-name) (components accessor: system-components initform: '()))) (define current-system (make-parameter #f)) (define-method (print-object (sys ) port) (fprintf port "#" (system-name sys))) (define-class () ((name accessor: component-name))) (define-class () ((path initform: #f) (explanation accessor: file-action-explanation initform: #f) (includes accessor: file-includes initform: '()) (depends accessor: file-dependencies initform: '()))) (define-method (print-object (f ) port) (fprintf port "#" (component-name f))) (define-class () ((compiled-file accessor: file-compiled-file initform: #f) (compile-options accessor: file-compile-options initform: '()) (last-load-time accessor: file-last-load-time initform: #f) )) (define-class () ()) (define (make-component x #!optional sys) (cond ((symbol? x) (make-component (symbol->string x))) ((string? x) (or (and sys (find-component x sys)) (make 'name x))) ((subclass? (class-of x) ) x) (else (error 'make-component "invalid component" x)))) (define-method (find-component (name #t) (sys )) (find (lambda (comp) (string=? name (component-name comp))) (system-components sys))) (define ((file-maker class) name #!key (depends '()) (includes '()) (path name) options) (define (listify x) (if (list? x) x (list x))) (apply make class 'name name 'depends (listify depends) 'includes (listify includes) (if options (list 'compile-options (listify options)) '()))) (define file (file-maker )) (define scheme-file (file-maker )) (define compiled-scheme-file (file-maker )) (define-method (file-path (s #t)) s) (define-method (file-path (f )) (or (slot-value f 'path) (let* ((name (component-name f)) (fn (or (file-exists? (make-pathname #f name "scm")) (file-exists? name) (error 'file-path "file not found" name)))) (set! (slot-value f 'path) fn) fn))) (define-method ((setter file-path) (f ) path) (set! (slot-value f 'path) path)) (define (walk sys test action) (let walk ((comps (system-components sys))) (let ((changed #f)) (for-each (lambda (comp) (let ((deps (canonicalize-files (file-dependencies comp) sys)) (incs (canonicalize-files (file-includes comp) sys))) (set! (file-dependencies comp) deps) (set! (file-includes comp) incs) (let ((flag (walk deps))) (cond (flag (set! (file-action-explanation comp) (sprintf "dependency of ~s changed" (component-name comp)))) ((any test deps) (set! flag #t)) ((test comp) (set! flag #t))) (when flag (set! changed #t) (action comp))))) comps) changed))) (define (canonicalize-files files sys) (if (any (lambda (x) (or (string? x) (symbol? x))) files) (map (cut make-component <> sys) files) files)) (define (file-newer? f1 f2) (> (file-modification-time (file-path f1)) (file-modification-time (file-path f2)))) (define (load-system sys #!key quiet force) (parameterize ((verbose-action (not quiet)) (current-system sys) (##sys#current-module #f)) (when force (clean-system sys)) (or (walk sys file-needs-reload? reload-file) (begin (dribble "nothing to do.") #f)))) (define (compile-system sys #!key quiet force) (parameterize ((verbose-action (not quiet)) (current-system sys)) (when force (clean-system sys)) (or (walk sys file-needs-recompile? recompile-file) (begin (dribble "nothing to do.") #f)))) (define (clean-system sys) (for-each clean-file (system-components sys))) (define (build-system sys #!key quiet force) (parameterize ((verbose-action (not quiet)) (current-system sys)) (when force (clean-system sys)) (or (walk sys file-needs-rebuild? rebuild-file) (begin (dribble "nothing to do.") #f)))) (define-method (clean-file (f )) (void)) (define-method (clean-file (f )) (set! (file-last-load-time f) #f) (set! (file-compiled-file f) #f) (delete-file* (pathname-replace-extension (file-path f) "so"))) ; for build-system (define-method (build-file (f )) (void)) (define-method (build-file (f )) (when (file-needs-rebuild? f) (rebuild-file f))) (define-method (file-needs-reload? (f )) #f) (define-method (file-needs-reload? (sf )) (let ((llt (file-last-load-time sf))) (cond ((not llt) (set! (file-action-explanation sf) (sprintf "file ~s needs to be reloaded because it hasn't been loaded yet" (component-name sf))) #t) ((> (file-modification-time (file-path sf)) llt) (set! (file-action-explanation sf) (sprintf "file ~s needs to be reloaded because it has changed" (component-name sf))) #t) ((any (cut include-file-newer? <> llt) (file-includes sf)) (set! (file-action-explanation sf) (sprintf "file ~s needs to be reloaded because included file has changed" (component-name sf))) #t) (else (set! (file-action-explanation sf) #f) #f)))) (define-method (file-needs-recompile? (sf )) (let ((fcf (file-compiled-file sf))) (cond ((not fcf) (set! (file-action-explanation sf) (sprintf "file ~s needs to be recompiled because it hasn't been compiled yet" (component-name sf))) #t) ((file-newer? sf fcf) (set! (file-action-explanation sf) (sprintf "file ~s needs to be recompiled because it has changed" (component-name sf))) #t) ((any (cute include-file-newer? <> (file-modification-time fcf)) (file-includes sf)) (set! (file-action-explanation sf) (sprintf "file ~s needs to be recompiled because included file has changed" (component-name sf))) #t) (else (set! (file-action-explanation sf) #f) #f)))) (define-method (file-needs-rebuild? (f )) #f) (define-method (file-needs-rebuild? (sf )) (let* ((path (file-path sf)) (cf (pathname-replace-extension path "so")) (cfx (file-exists? cf)) (lmt (and cfx (file-modification-time cf)))) (cond ((not cfx) (set! (file-action-explanation sf) (sprintf "file ~s needs to be rebuilt because no compiled version exists" (component-name sf))) #t) ((> (file-modification-time path) lmt) (set! (file-action-explanation sf) (sprintf "file ~s needs to be rebuilt because it has been modified" (component-name sf))) #t) ((any (cut include-file-newer? <> lmt) (file-includes sf)) (set! (file-action-explanation sf) (sprintf "file ~s needs to be rebuilt because included file has changed" (component-name sf))) #t) (else (set! (file-action-explanation sf) #f) #f)))) (define (include-file-newer? f time) (> (file-modification-time (file-path f)) time)) (define (show-action-explanation f) (and-let* ((exp (file-action-explanation f))) (dribble exp))) (define-method (reload-file (f )) (void)) (define-method (reload-file (sf )) (show-action-explanation sf) (parameterize ((load-verbose (verbose-action))) (load (file-path sf))) (set! (file-last-load-time sf) (current-seconds))) (define-method (reload-file (csf )) (recompile-file csf)) (define-method (recompile-file (f )) (void)) (define-method (recompile-file (sf )) (show-action-explanation sf) (let ((cf (compile-file (file-path sf) options: (file-compile-options sf) verbose: (verbose-action)))) (unless cf (error "recompilation failed" sf)) (set! (file-last-load-time sf) (current-seconds)) (set! (file-compiled-file sf) cf))) (define-method (rebuild-file (f )) (void)) (define-method (rebuild-file (sf )) (show-action-explanation sf) (let* ((path (file-path sf)) (out (pathname-replace-extension path "so"))) (parameterize ((shell-verbose (verbose-action))) (run (csc ,@(file-compile-options sf) -J -s ,path -o ,out))))) ;;; csi toplevel commands (when (feature? #:csi) (let () (define (check) (unless (current-system) (print* "Enter expression that evaluates to a system: ") (current-system (eval (read)))) (current-system)) (toplevel-command 'ls (lambda () (load-system (check))) ",ls load selected system") (toplevel-command 'cs (lambda () (load-system (check))) ",cs compile selected system") (toplevel-command 'sys (lambda () (current-system (eval (read)))) ",sys SYSTEM select system")))