Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-07 13:16:36 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Allowing begin/end hooks for run-application.

Browse source
This commit is contained in:
Alex Shinn 2014-01-13 19:36:05 +09:00
parent 0d097c8c3a
commit e22c0a40ba
1 changed files with 26 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
lib/chibi/app.scm
View file

@ -112,7 +112,7 @@
(lp (cdr val+args) (lp (cdr val+args)
(conf-set opts (caar val+args) (cdar val+args)))))))) (conf-set opts (caar val+args) (cdar val+args))))))))
(define (parse-app prefix spec opt-spec args config . o) (define (parse-app prefix spec opt-spec args config init end . o)
(define (next-prefix prefix name) (define (next-prefix prefix name)
(append (if (null? prefix) '(command) prefix) (list name))) (append (if (null? prefix) '(command) prefix) (list name)))
(define (prev-prefix prefix) (define (prev-prefix prefix)
@ -137,24 +137,29 @@
(cfg+args (parse-options prefix new-opt-spec args new-fail)) (cfg+args (parse-options prefix new-opt-spec args new-fail))
(config (conf-append (car cfg+args) config)) (config (conf-append (car cfg+args) config))
(args (cdr cfg+args))) (args (cdr cfg+args)))
(parse-app prefix (cdr spec) new-opt-spec args config new-fail))) (parse-app prefix (cdr spec) new-opt-spec args config init end new-fail)))
((or) ((or)
(any (lambda (x) (parse-app prefix x opt-spec args config)) (cdar spec))) (any (lambda (x) (parse-app prefix x opt-spec args config init end))
(cdar spec)))
((begin)
(parse-app prefix (cdr spec) opt-spec args config (cadr (car spec)) end fail))
((end)
(parse-app prefix (cdr spec) opt-spec args config init (cadr (car spec)) fail))
(else (else
(if (procedure? (caar spec)) (if (procedure? (caar spec))
(list (caar spec) config args) ; TODO: verify, apply defaults (vector (caar spec) config args init end) ; TODO: verify
(parse-app prefix (car spec) opt-spec args config fail))))) (parse-app prefix (car spec) opt-spec args config init end fail)))))
((symbol? (car spec)) ((symbol? (car spec))
(and (pair? args) (and (pair? args)
(eq? (car spec) (string->symbol (car args))) (eq? (car spec) (string->symbol (car args)))
(let ((prefix (next-prefix prefix (car spec)))) (let ((prefix (next-prefix prefix (car spec))))
(parse-app prefix (cdr spec) opt-spec (cdr args) config fail)))) (parse-app prefix (cdr spec) opt-spec (cdr args) config init end fail))))
((procedure? (car spec)) ((procedure? (car spec))
(list (car spec) config args)) (vector (car spec) config args init end))
(else (else
(if (not (string? (car spec))) (if (not (string? (car spec)))
(error "unknown application spec" (car spec))) (error "unknown application spec" (car spec)))
(parse-app prefix (cdr spec) opt-spec args config fail))))) (parse-app prefix (cdr spec) opt-spec args config init end fail)))))
(define (print-command-help command out) (define (print-command-help command out)
(cond (cond
@ -241,7 +246,16 @@
(define (run-application spec . o) (define (run-application spec . o)
(let ((args (if (pair? o) (car o) (command-line)))) (let ((args (if (pair? o) (car o) (command-line))))
(let ((ls (parse-app '() (cdr spec) '() (cdr args) #f))) (cond
(if ls ((parse-app '() (cdr spec) '() (cdr args) #f #f #f)
(apply (car ls) (cadr ls) spec (car (cddr ls))) => (lambda (v)
(let ((proc (vector-ref v 0))
(cfg (vector-ref v 1))
(args (vector-ref v 2))
(init (vector-ref v 3))
(end (vector-ref v 4)))
(if init (init cfg))
(apply proc cfg spec args)
(if end (end cfg)))))
(else
(error "Unknown command: " args))))) (error "Unknown command: " args)))))