Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

added -x option for cond-expand-feature definition

  • Loading branch information...
commit d382bd615df996c6deddf4579eb8cfb87b393536 1 parent 193e60a
@alvatar authored
View
2  src/blackhole.scm
@@ -52,6 +52,8 @@
(lib ,@lib-module-resolver)
(pkg ,@package-module-resolver)))
+;; Add cond-expand feature by default
+(set! ##cond-expand-features (cons 'black-hole ##cond-expand-features))
;; ---------- Add the hooks =) ----------
View
63 src/cli.scm
@@ -9,10 +9,15 @@
(display "\n") err)
(exit 1))
+;;;-----------------------------------------------------------------------------
+;;; Command-line parsing
+;;;-----------------------------------------------------------------------------
+
(define short-opts
'((#\b 1 "bunch") ;; 1 means that bunch takes an argument ...
(#\c 0 "compile") ;; ... compile doesn't (hence 0)
(#\C 0 "to-c")
+ (#\x 1 "cond-expand-features")
(#\D 0 "ignore-dependencies")
(#\e 1 "eval")
(#\f 0 "force")
@@ -146,6 +151,10 @@
die/error
(cons "Expected exactly one argument:" args))))
+;;;-----------------------------------------------------------------------------
+;;; Utils
+;;;-----------------------------------------------------------------------------
+
(define (display-pkgs pkgs port)
(for-each
(lambda (pkg)
@@ -154,12 +163,29 @@
(newline port))
pkgs))
+(define (define-cond-expand-features-from-cli val)
+ (set! ##cond-expand-features
+ (append (map
+ string->symbol
+ (filter
+ (lambda (s) (not (equal? s "")))
+ (string-split
+ #\:
+ (symbol->string (with-input-from-string val read)))))
+ ##cond-expand-features)))
+
+;;;-----------------------------------------------------------------------------
+;;; Commands
+;;;-----------------------------------------------------------------------------
+
+;;; exe
+
(define (exe-cmd cmd opts args)
(define to-c #f)
(define output-fn #f)
(define quiet #f)
(define verbose #f)
-
+
(handle-opts!
opts
`(("to-c"
@@ -167,6 +193,9 @@
(begin
(set! *compile-to-c* #t)
(set! to-c (not (equal? val "no"))))))
+ ("cond-expand-features"
+ ,@(lambda (val)
+ (define-cond-expand-features-from-cli val)))
("output"
,@(lambda (val)
(set! output-fn val)))
@@ -191,6 +220,8 @@
(current-output-port))
verbose?: verbose))
+;;; compile
+
(define (compile-cmd cmd opts args)
(define to-c #f)
(define recursive #f)
@@ -207,6 +238,9 @@
(begin
(set! *compile-to-c* #t)
(set! to-c (not (equal? val "no"))))))
+ ("cond-expand-features"
+ ,@(lambda (val)
+ (define-cond-expand-features-from-cli val)))
("recursive"
,@(lambda (val)
(set! recursive (not (equal? val "no")))))
@@ -257,6 +291,8 @@
force?: force
verbose?: verbose))))
+;;; clean
+
(define (clean-cmd cmd opts args)
(define recursive #f)
(define quiet #f)
@@ -298,6 +334,8 @@
(newline port))
mods-and-deps)))
+;;; install
+
(define (install-cmd cmd opts args)
(define version #t)
(define compile #t)
@@ -365,6 +403,8 @@
verbose?: verbose))
pkgs-to-be-installed))))
+;;; uninstall
+
(define (uninstall-cmd cmd opts args)
(define version #t)
(define quiet #f)
@@ -478,6 +518,8 @@
(display ".\n" port)))
to-be-uninstalled)))))
+;;; list
+
(define (list-cmd cmd opts args)
(define quiet #f)
@@ -498,6 +540,8 @@
(println (package-name&version pkg)))
(installed-packages)))
+;;; search
+
(define (search-cmd cmd opts args)
(ensure-no-args! args)
(handle-opts! opts '())
@@ -513,6 +557,8 @@
")"))
(remote-packages)))
+;;; deps
+
(define (deps-cmd cmd opts args)
(define quiet #f)
(define recursive #f)
@@ -545,6 +591,8 @@
deps)))
args))
+;;; exported-names
+
(define (exported-names-cmd cmd opts args)
(define quiet #f)
@@ -569,6 +617,8 @@
(module-reference-from-file arg))))
args))
+;;; help
+
(define (help-cmd cmd opts args)
(define help-topics
`(("modules" ,@help-modules)
@@ -608,6 +658,8 @@
(else
(die/error "Invalid arguments passed to help:" args))))
+;;; repl
+
(define (repl-cmd cmd opts args)
(define quiet #f)
(define help #f)
@@ -620,6 +672,9 @@
,@(lambda (val)
(println "Black Hole for Gambit Scheme, version [not yet determined]")
(exit 0)))
+ ("cond-expand-features"
+ ,@(lambda (val)
+ (define-cond-expand-features-from-cli val)))
("eval"
,@(lambda (val)
(eval
@@ -639,11 +694,17 @@
(println "Gambit Scheme w/ Black Hole"))
(##repl-debug #f #t))))
+;;; Handle unknown command
+
(define (unknown-cmd cmd opts args-sans-opts)
(die/error "Unknown command:"
cmd
"To get a list of options, type 'bh help'"))
+;;;-----------------------------------------------------------------------------
+;;; Main for command-line
+;;;-----------------------------------------------------------------------------
+
(define (cli arguments)
(let ((commands
`(("exe" ,@exe-cmd)
View
2  src/core-forms.scm
@@ -387,7 +387,7 @@
(lambda clauses
(cond-expand-build source
clauses
- (cons 'black-hole ##cond-expand-features))))
+ ##cond-expand-features)))
env)))
(case
View
61 src/packages.scm
@@ -1,64 +1,3 @@
-;;; Utilities
-
-(define (find-one? pred? lst)
- (let loop ((lst lst))
- (cond
- ((null? lst)
- #f)
-
- ((pair? lst)
- (if (pred? (car lst))
- #t
- (loop (cdr lst))))
-
- (else
- (error "Improper list" lst)))))
-
-(define (string-for-each fn str)
- (let ((len (string-length str)))
- (let loop ((i 0))
- (cond
- ((= i len) #!void)
- (else
- (fn (string-ref str i))
- (loop (+ i 1)))))))
-
-(define (reverse-list->string list)
- (let* ((len (length list))
- (str (make-string len)))
- (let loop ((i (- len 1))
- (list list))
- (cond
- ((pair? list)
- (string-set! str i (car list))
- (loop (- i 1) (cdr list)))))
- str))
-
-(define (string-split chr str #!optional (sparse #f))
- (let* ((curr-str '())
- (result '())
- (new-str (lambda ()
- (push! result (reverse-list->string curr-str))
- (set! curr-str '())))
- (add-char (lambda (chr)
- (push! curr-str chr))))
- (string-for-each (lambda (c)
- (cond
- ((eq? c chr)
- (if (or (not sparse)
- (not (null? curr-str)))
- (new-str)))
- (else
- (add-char c))))
- str)
- (new-str)
- (reverse result)))
-
-(define (join between args)
- (cond ((null? args) '())
- ((null? (cdr args)) (list (car args)))
- (else `(,(car args) ,between ,@(join between (cdr args))))))
-
(define (with-input-from-url url thunk)
(with-input-from-process
(list path: "curl"
View
103 src/util.scm
@@ -11,10 +11,91 @@
(pp r)
r))
+(define-macro (push! list obj)
+ `(set! ,list (cons ,obj ,list)))
+
+(define-macro (pop! list)
+ ;; We don't need to worry about double-evaluating list, because it
+ ;; has to be a simple identifier anyways or the set! won't work.
+ (let ((tmp (gensym 'tmp)))
+ `(let* ((,tmp (car ,list)))
+ (set! ,list (cdr ,list))
+ ,tmp)))
+
+(define (reverse! lst)
+ (let loop ((lst lst) (accum '()))
+ (cond
+ ((pair? lst)
+ (let ((rest (cdr lst)))
+ (set-cdr! lst accum)
+ (loop rest lst)))
+
+ (else
+ accum))))
+
(##define-syntax get-path
(lambda (a)
(vector-ref a 2)))
+(define (find-one? pred? lst)
+ (let loop ((lst lst))
+ (cond
+ ((null? lst)
+ #f)
+
+ ((pair? lst)
+ (if (pred? (car lst))
+ #t
+ (loop (cdr lst))))
+
+ (else
+ (error "Improper list" lst)))))
+
+(define (string-for-each fn str)
+ (let ((len (string-length str)))
+ (let loop ((i 0))
+ (cond
+ ((= i len) #!void)
+ (else
+ (fn (string-ref str i))
+ (loop (+ i 1)))))))
+
+(define (reverse-list->string list)
+ (let* ((len (length list))
+ (str (make-string len)))
+ (let loop ((i (- len 1))
+ (list list))
+ (cond
+ ((pair? list)
+ (string-set! str i (car list))
+ (loop (- i 1) (cdr list)))))
+ str))
+
+(define (string-split chr str #!optional (sparse #f))
+ (let* ((curr-str '())
+ (result '())
+ (new-str (lambda ()
+ (push! result (reverse-list->string curr-str))
+ (set! curr-str '())))
+ (add-char (lambda (chr)
+ (push! curr-str chr))))
+ (string-for-each (lambda (c)
+ (cond
+ ((eq? c chr)
+ (if (or (not sparse)
+ (not (null? curr-str)))
+ (new-str)))
+ (else
+ (add-char c))))
+ str)
+ (new-str)
+ (reverse result)))
+
+(define (join between args)
+ (cond ((null? args) '())
+ ((null? (cdr args)) (list (car args)))
+ (else `(,(car args) ,between ,@(join between (cdr args))))))
+
(define (string-contains haystack chr)
(call/cc
(lambda (ret)
@@ -54,28 +135,6 @@
(string-length haystack))
haystack))
-(define-macro (push! list obj)
- `(set! ,list (cons ,obj ,list)))
-
-(define-macro (pop! list)
- ;; We don't need to worry about double-evaluating list, because it
- ;; has to be a simple identifier anyways or the set! won't work.
- (let ((tmp (gensym 'tmp)))
- `(let* ((,tmp (car ,list)))
- (set! ,list (cdr ,list))
- ,tmp)))
-
-(define (reverse! lst)
- (let loop ((lst lst) (accum '()))
- (cond
- ((pair? lst)
- (let ((rest (cdr lst)))
- (set-cdr! lst accum)
- (loop rest lst)))
-
- (else
- accum))))
-
(define (file-last-changed-seconds fn)
(time->seconds
(file-info-last-change-time
Please sign in to comment.
Something went wrong with that request. Please try again.