Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

added -x option for cond-expand-feature definition

  • Loading branch information...
commit d382bd615df996c6deddf4579eb8cfb87b393536 1 parent 193e60a
Álvaro Castro-Castilla authored February 11, 2012
2  src/blackhole.scm
@@ -52,6 +52,8 @@
52 52
         (lib ,@lib-module-resolver)
53 53
         (pkg ,@package-module-resolver)))
54 54
 
  55
+;; Add cond-expand feature by default
  56
+(set! ##cond-expand-features (cons 'black-hole ##cond-expand-features))
55 57
 
56 58
 ;; ---------- Add the hooks =) ----------
57 59
 
63  src/cli.scm
@@ -9,10 +9,15 @@
9 9
     (display "\n") err)
10 10
   (exit 1))
11 11
 
  12
+;;;-----------------------------------------------------------------------------
  13
+;;; Command-line parsing
  14
+;;;-----------------------------------------------------------------------------
  15
+
12 16
 (define short-opts
13 17
   '((#\b 1 "bunch") ;; 1 means that bunch takes an argument ...
14 18
     (#\c 0 "compile") ;; ... compile doesn't (hence 0)
15 19
     (#\C 0 "to-c")
  20
+    (#\x 1 "cond-expand-features")
16 21
     (#\D 0 "ignore-dependencies")
17 22
     (#\e 1 "eval")
18 23
     (#\f 0 "force")
@@ -146,6 +151,10 @@
146 151
        die/error
147 152
        (cons "Expected exactly one argument:" args))))
148 153
 
  154
+;;;-----------------------------------------------------------------------------
  155
+;;; Utils
  156
+;;;-----------------------------------------------------------------------------
  157
+
149 158
 (define (display-pkgs pkgs port)
150 159
   (for-each
151 160
       (lambda (pkg)
@@ -154,12 +163,29 @@
154 163
         (newline port))
155 164
     pkgs))
156 165
 
  166
+(define (define-cond-expand-features-from-cli val)
  167
+  (set! ##cond-expand-features
  168
+                (append (map
  169
+                         string->symbol
  170
+                         (filter
  171
+                          (lambda (s) (not (equal? s "")))
  172
+                          (string-split
  173
+                           #\:
  174
+                           (symbol->string (with-input-from-string val read)))))
  175
+                        ##cond-expand-features)))
  176
+
  177
+;;;-----------------------------------------------------------------------------
  178
+;;; Commands
  179
+;;;-----------------------------------------------------------------------------
  180
+
  181
+;;; exe
  182
+
157 183
 (define (exe-cmd cmd opts args)
158 184
   (define to-c #f)
159 185
   (define output-fn #f)
160 186
   (define quiet #f)
161 187
   (define verbose #f)
162  
-  
  188
+    
163 189
   (handle-opts!
164 190
    opts
165 191
    `(("to-c"
@@ -167,6 +193,9 @@
167 193
           (begin
168 194
             (set! *compile-to-c* #t)
169 195
             (set! to-c (not (equal? val "no"))))))
  196
+     ("cond-expand-features"
  197
+      ,@(lambda (val)
  198
+          (define-cond-expand-features-from-cli val)))
170 199
      ("output"
171 200
       ,@(lambda (val)
172 201
           (set! output-fn val)))
@@ -191,6 +220,8 @@
191 220
              (current-output-port))
192 221
    verbose?: verbose))
193 222
 
  223
+;;; compile
  224
+
194 225
 (define (compile-cmd cmd opts args)
195 226
   (define to-c #f)
196 227
   (define recursive #f)
@@ -207,6 +238,9 @@
207 238
           (begin
208 239
             (set! *compile-to-c* #t)
209 240
             (set! to-c (not (equal? val "no"))))))
  241
+     ("cond-expand-features"
  242
+      ,@(lambda (val)
  243
+          (define-cond-expand-features-from-cli val)))
210 244
      ("recursive"
211 245
       ,@(lambda (val)
212 246
           (set! recursive (not (equal? val "no")))))
@@ -257,6 +291,8 @@
257 291
                           force?: force
258 292
                           verbose?: verbose))))
259 293
 
  294
+;;; clean
  295
+
260 296
 (define (clean-cmd cmd opts args)
261 297
   (define recursive #f)
262 298
   (define quiet #f)
@@ -298,6 +334,8 @@
298 334
           (newline port))
299 335
       mods-and-deps)))
300 336
 
  337
+;;; install
  338
+
301 339
 (define (install-cmd cmd opts args)
302 340
   (define version #t)
303 341
   (define compile #t)
@@ -365,6 +403,8 @@
365 403
                      verbose?: verbose))
366 404
           pkgs-to-be-installed))))
367 405
 
  406
+;;; uninstall
  407
+
368 408
 (define (uninstall-cmd cmd opts args)
369 409
   (define version #t)
370 410
   (define quiet #f)
@@ -478,6 +518,8 @@
478 518
                     (display ".\n" port)))
479 519
             to-be-uninstalled)))))
480 520
 
  521
+;;; list
  522
+
481 523
 (define (list-cmd cmd opts args)
482 524
   (define quiet #f)
483 525
 
@@ -498,6 +540,8 @@
498 540
         (println (package-name&version pkg)))
499 541
     (installed-packages)))
500 542
 
  543
+;;; search
  544
+
501 545
 (define (search-cmd cmd opts args)
502 546
   (ensure-no-args! args)
503 547
   (handle-opts! opts '())
@@ -513,6 +557,8 @@
513 557
                  ")"))
514 558
     (remote-packages)))
515 559
 
  560
+;;; deps
  561
+
516 562
 (define (deps-cmd cmd opts args)
517 563
   (define quiet #f)
518 564
   (define recursive #f)
@@ -545,6 +591,8 @@
545 591
             deps)))
546 592
     args))
547 593
 
  594
+;;; exported-names
  595
+
548 596
 (define (exported-names-cmd cmd opts args)
549 597
   (define quiet #f)
550 598
   
@@ -569,6 +617,8 @@
569 617
            (module-reference-from-file arg))))
570 618
     args))
571 619
 
  620
+;;; help
  621
+
572 622
 (define (help-cmd cmd opts args)
573 623
   (define help-topics
574 624
     `(("modules" ,@help-modules)
@@ -608,6 +658,8 @@
608 658
    (else
609 659
     (die/error "Invalid arguments passed to help:" args))))
610 660
 
  661
+;;; repl
  662
+
611 663
 (define (repl-cmd cmd opts args)
612 664
   (define quiet #f)
613 665
   (define help #f)
@@ -620,6 +672,9 @@
620 672
       ,@(lambda (val)
621 673
           (println "Black Hole for Gambit Scheme, version [not yet determined]")
622 674
           (exit 0)))
  675
+     ("cond-expand-features"
  676
+      ,@(lambda (val)
  677
+          (define-cond-expand-features-from-cli val)))
623 678
      ("eval"
624 679
       ,@(lambda (val)
625 680
           (eval
@@ -639,11 +694,17 @@
639 694
         (println "Gambit Scheme w/ Black Hole"))
640 695
     (##repl-debug #f #t))))
641 696
 
  697
+;;; Handle unknown command
  698
+
642 699
 (define (unknown-cmd cmd opts args-sans-opts)
643 700
   (die/error "Unknown command:"
644 701
              cmd
645 702
              "To get a list of options, type 'bh help'"))
646 703
 
  704
+;;;-----------------------------------------------------------------------------
  705
+;;; Main for command-line
  706
+;;;-----------------------------------------------------------------------------
  707
+
647 708
 (define (cli arguments)
648 709
   (let ((commands
649 710
          `(("exe" ,@exe-cmd)
2  src/core-forms.scm
@@ -387,7 +387,7 @@
387 387
         (lambda clauses
388 388
           (cond-expand-build source
389 389
                              clauses
390  
-                             (cons 'black-hole ##cond-expand-features))))
  390
+                             ##cond-expand-features)))
391 391
        env)))
392 392
 
393 393
    (case
61  src/packages.scm
... ...
@@ -1,64 +1,3 @@
1  
-;;; Utilities
2  
-
3  
-(define (find-one? pred? lst)
4  
-    (let loop ((lst lst))
5  
-      (cond
6  
-       ((null? lst)
7  
-        #f)
8  
-
9  
-       ((pair? lst)
10  
-        (if (pred? (car lst))
11  
-            #t
12  
-            (loop (cdr lst))))
13  
-
14  
-       (else
15  
-        (error "Improper list" lst)))))
16  
-
17  
-(define (string-for-each fn str)
18  
-  (let ((len (string-length str)))
19  
-    (let loop ((i 0))
20  
-      (cond
21  
-       ((= i len) #!void)
22  
-       (else
23  
-        (fn (string-ref str i))
24  
-        (loop (+ i 1)))))))
25  
-
26  
-(define (reverse-list->string list)
27  
-  (let* ((len (length list))
28  
-         (str (make-string len)))
29  
-    (let loop ((i (- len 1))
30  
-               (list list))
31  
-      (cond
32  
-       ((pair? list)
33  
-        (string-set! str i (car list))
34  
-        (loop (- i 1) (cdr list)))))
35  
-    str))
36  
-
37  
-(define (string-split chr str #!optional (sparse #f))
38  
-  (let* ((curr-str '())
39  
-         (result '())
40  
-         (new-str (lambda ()
41  
-                    (push! result (reverse-list->string curr-str))
42  
-                    (set! curr-str '())))
43  
-         (add-char (lambda (chr)
44  
-                     (push! curr-str chr))))
45  
-    (string-for-each (lambda (c)
46  
-                       (cond
47  
-                        ((eq? c chr)
48  
-                         (if (or (not sparse)
49  
-                                 (not (null? curr-str)))
50  
-                             (new-str)))
51  
-                        (else
52  
-                         (add-char c))))
53  
-                     str)
54  
-    (new-str)
55  
-    (reverse result)))
56  
-
57  
-(define (join between args)
58  
-  (cond ((null? args) '())
59  
-        ((null? (cdr args)) (list (car args)))
60  
-        (else `(,(car args) ,between ,@(join between (cdr args))))))
61  
-
62 1
 (define (with-input-from-url url thunk)
63 2
   (with-input-from-process
64 3
    (list path: "curl"
103  src/util.scm
@@ -11,10 +11,91 @@
11 11
      (pp r)
12 12
      r))
13 13
 
  14
+(define-macro (push! list obj)
  15
+  `(set! ,list (cons ,obj ,list)))
  16
+
  17
+(define-macro (pop! list)
  18
+  ;; We don't need to worry about double-evaluating list, because it
  19
+  ;; has to be a simple identifier anyways or the set! won't work.
  20
+  (let ((tmp (gensym 'tmp)))
  21
+    `(let* ((,tmp (car ,list)))
  22
+       (set! ,list (cdr ,list))
  23
+       ,tmp)))
  24
+
  25
+(define (reverse! lst)
  26
+  (let loop ((lst lst) (accum '()))
  27
+    (cond
  28
+     ((pair? lst)
  29
+      (let ((rest (cdr lst)))
  30
+        (set-cdr! lst accum)
  31
+        (loop rest lst)))
  32
+
  33
+     (else
  34
+      accum))))
  35
+
14 36
 (##define-syntax get-path
15 37
   (lambda (a)
16 38
     (vector-ref a 2)))
17 39
 
  40
+(define (find-one? pred? lst)
  41
+    (let loop ((lst lst))
  42
+      (cond
  43
+       ((null? lst)
  44
+        #f)
  45
+
  46
+       ((pair? lst)
  47
+        (if (pred? (car lst))
  48
+            #t
  49
+            (loop (cdr lst))))
  50
+
  51
+       (else
  52
+        (error "Improper list" lst)))))
  53
+
  54
+(define (string-for-each fn str)
  55
+  (let ((len (string-length str)))
  56
+    (let loop ((i 0))
  57
+      (cond
  58
+       ((= i len) #!void)
  59
+       (else
  60
+        (fn (string-ref str i))
  61
+        (loop (+ i 1)))))))
  62
+
  63
+(define (reverse-list->string list)
  64
+  (let* ((len (length list))
  65
+         (str (make-string len)))
  66
+    (let loop ((i (- len 1))
  67
+               (list list))
  68
+      (cond
  69
+       ((pair? list)
  70
+        (string-set! str i (car list))
  71
+        (loop (- i 1) (cdr list)))))
  72
+    str))
  73
+
  74
+(define (string-split chr str #!optional (sparse #f))
  75
+  (let* ((curr-str '())
  76
+         (result '())
  77
+         (new-str (lambda ()
  78
+                    (push! result (reverse-list->string curr-str))
  79
+                    (set! curr-str '())))
  80
+         (add-char (lambda (chr)
  81
+                     (push! curr-str chr))))
  82
+    (string-for-each (lambda (c)
  83
+                       (cond
  84
+                        ((eq? c chr)
  85
+                         (if (or (not sparse)
  86
+                                 (not (null? curr-str)))
  87
+                             (new-str)))
  88
+                        (else
  89
+                         (add-char c))))
  90
+                     str)
  91
+    (new-str)
  92
+    (reverse result)))
  93
+
  94
+(define (join between args)
  95
+  (cond ((null? args) '())
  96
+        ((null? (cdr args)) (list (car args)))
  97
+        (else `(,(car args) ,between ,@(join between (cdr args))))))
  98
+
18 99
 (define (string-contains haystack chr)
19 100
   (call/cc
20 101
    (lambda (ret)
@@ -54,28 +135,6 @@
54 135
                  (string-length haystack))
55 136
       haystack))
56 137
 
57  
-(define-macro (push! list obj)
58  
-  `(set! ,list (cons ,obj ,list)))
59  
-
60  
-(define-macro (pop! list)
61  
-  ;; We don't need to worry about double-evaluating list, because it
62  
-  ;; has to be a simple identifier anyways or the set! won't work.
63  
-  (let ((tmp (gensym 'tmp)))
64  
-    `(let* ((,tmp (car ,list)))
65  
-       (set! ,list (cdr ,list))
66  
-       ,tmp)))
67  
-
68  
-(define (reverse! lst)
69  
-  (let loop ((lst lst) (accum '()))
70  
-    (cond
71  
-     ((pair? lst)
72  
-      (let ((rest (cdr lst)))
73  
-        (set-cdr! lst accum)
74  
-        (loop rest lst)))
75  
-
76  
-     (else
77  
-      accum))))
78  
-
79 138
 (define (file-last-changed-seconds fn)
80 139
   (time->seconds
81 140
    (file-info-last-change-time

0 notes on commit d382bd6

Please sign in to comment.
Something went wrong with that request. Please try again.