source: project/build/main.scm @ 2815

Last change on this file since 2815 was 2815, checked in by felix winkelmann, 14 years ago

rgraph fix by mario

File size: 3.9 KB
Line 
1;;;; main.scm
2
3
4(use srfi-37 regex-case utils modules miscmacros regex posix)
5
6#+(not csi)
7(declare (uses scan))
8
9(define-constant +version+ "0.5 - (c)2006 Felix L. Winkelmann")
10(define-constant +buildfile+ "Buildfile")
11(define-constant +initfile+ ".build")
12
13(include "syntax.scm")
14(include "build.scm")
15(include "base.scm")
16
17(set-signal-handler! 
18 signal/int
19 (lambda _
20   (quit "*** interrupted ***") ) )
21
22(define *buildfile* +buildfile+)
23(define *interactive* #f)
24
25(module ()
26
27(define (usage)
28  (print #<#EOF
29usage: build [OPTION | VAR=VAL | TARGET ...]
30
31  -h   --help               show this message and exit
32  -v   --version            show version and exit
33  -d   --debug              enable debug mode (give multiple times for more output)
34  -f   --file FILENAME      use other file than `#*buildfile*'
35  -n   --dry-run            don't execute any commands
36  -p   --plain              don't use colored output
37  -o   --output FILENAME    write updating actions to file
38EOF
39;#|
40  ) )
41
42(define (debugging o n a ts)
43  (if *verbose* 
44      (set! *VERBOSE* #t)
45      (set! *verbose* #t) )
46  ts)
47
48(define (plain o n a ts)
49  (set! *info-message-escape* "")
50  (set! *target-message-escape* "")
51  (set! *error-message-escape* "")
52  (set! *command-message-escape* "")
53  (set! *reset-escape* "") 
54  (set! *tty* #f)
55  ts)
56
57(define *options*
58  (list (option '(#\h "help") #f #f (lambda _ (usage) (exit)))
59        (option '(#\v "version") #f #f (lambda _ (print "build " +version+) (exit)))
60        (option '(#\d "debug") #f #f debugging)
61        (option '(#\i "interactive") #f #f (lambda (o n a ts) (set! *interactive* #t) ts))
62        (option '(#\p "plain") #f #f plain)
63        (option '(#\n "dry-run") #f #f (lambda (o n a ts) (set! *dry-run* #t) ts))
64        (option '(#\o "output") #t #f (lambda (o n a ts) (set! build:*output-file* (open-output-file a)) ts))
65        (option '(#\f "file") #t #f (lambda (o n a ts) (set! *buildfile* a) ts)) ) )
66
67(define (unrecognized . _)
68  (usage)
69  (exit 1) )
70
71(define (argument x ts)
72  (regex-case x
73    ("([A-Za-z0-9_]+)=(.+)" (_ name val)
74     (##sys#setslot (string->symbol name) 0 val) 
75     ts)
76    ("([A-Za-z0-9_]+)=\"(.+)\"" (_ name val)
77     (##sys#setslot (string->symbol name) 0 val) 
78     ts)
79    (else (cons x ts)) ) )
80
81(define (loadfile f)
82  (when *VERBOSE* (message "loading ~a ..." f))
83  (load f (if *VERBOSE* (each pp eval) eval)) )
84
85(define (load-environment)
86  (when *VERBOSE* (message "Environment:"))
87  (for-each
88   (match-lambda
89     ((var . val)
90      (unless (string=? "_" var)
91        (let ((s (string->symbol var)))
92          (when *VERBOSE* (message "  ~a\t=\t~s" s val))
93          (##sys#setslot s 0 val) ) ) ) )
94   (current-environment)))
95
96(define status-code (condition-property-accessor 'quit 'status))
97(define has-status? (condition-predicate 'quit))
98
99(define (main args)
100  (let ((targets (args-fold args *options* unrecognized argument '())))
101    (load-environment)
102    (let ((status 0))
103      (handle-exceptions ex
104          (begin
105            (print* *error-message-escape*)
106            (print-error-message ex) 
107            (print* *reset-escape*)
108            (set! status (if (has-status? ex) (status-code ex) 1)) )
109        (when (file-exists? +initfile+) (loadfile +initfile+))
110        (and-let* ((f (file-exists? (make-pathname (getenv "HOME") +initfile+))))
111          (loadfile f) )
112        (when *VERBOSE* (message "targets: ~a" targets))
113        (let process ((dirs '(".")))
114          (for-each
115           (lambda (dir)
116             (with-cwd 
117              dir
118              (lambda ()
119                (fluid-let ((build:*context-prefix* (in-context dir))
120                            (build:*subdirs* '()) )
121                  (cond ((file-exists? *buildfile*) (loadfile *buildfile*))
122                        ((not *interactive*) (quit "no `Buildfile' found in `~a'" (current-directory))) )
123                  (process build:*subdirs*) ) ) ) )
124           dirs) )
125        (check-dependencies)
126        (when *VERBOSE* (build-dump))
127        (cond (*interactive* (repl))
128              (else (for-each build (if (null? targets) '("all") (reverse targets))))) )
129      (when build:*output-file* (close-output-port build:*output-file*))
130      (exit status) ) ) )
131
132(main (command-line-arguments))
133
134)
Note: See TracBrowser for help on using the repository browser.