Changeset 5487 in project


Ignore:
Timestamp:
08/17/07 21:40:05 (12 years ago)
Author:
Kon Lovett
Message:

Added tool-error, simplified define-option macro, simplified define-tool macro. Rmvd set! of globals in macros.

Location:
tool
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • tool/tool-support.scm

    r5476 r5487  
    44(use args-doc srfi-37 srfi-13 srfi-1)
    55
    6 (declare
    7   (export tool:parse-option tool:*commands* tool:*options*
    8           tool-usage tool-name tool-help tool-usage tool-exit
     6(declare
     7  (no-procedure-checks-for-usual-bindings)
     8  (fixnum)
     9  (export tool:new-option tool:new-command tool:parse-option
     10          tool:*commands* tool:*options*
     11          tool-usage tool-name tool-help tool-usage tool-exit tool-error
    912          tool-main) )
     13
     14;;;
    1015
    1116(define tool:*options*
    1217  (list (list (option
    13                '(#\h "help") #f #f 
    14                (lambda (o n a args) 
     18               '(#\h "help") #f #f
     19               (lambda (o n a args)
    1520                 (tool-usage 0 (and *current-command* (car *current-command*)))))
    1621              "show this message")) )
    1722
    18 (define tool:*help-options*
    19   tool:*options*)
     23(define tool:*help-options* tool:*options*)
    2024
    2125(define tool:*commands* '())
     
    2327(define *program-name* (car (argv)))
    2428(define *help* #f)
    25 (define *current-command* #f)
     29
     30;;;
    2631
    2732(define (tool:parse-option o doc proc)
    28   (cond ((option? o) 
     33  (cond ((option? o)
    2934         (list
    3035          (option (flatten (option-names o))
     
    3944        ((list? o) (list (option o "ARGUMENT" #f proc) doc))
    4045        (else (error "invalid option value" o)) ) )
     46
     47(define (tool:new-option o doc proc)
     48  (set! tool:*options* (cons (tool:parse-option o doc proc) tool:*options*)) )
     49
     50(define (tool:new-command . lst)
     51  (set! tool:*commands* (cons lst tool:*commands*) ) )
    4152
    4253(define (tool:doc-opt opt doc #!optional arg-string)
     
    8798                                        3))))))
    8899
     100;;;
     101
    89102(define (tool-usage status #!optional (cmd *current-command*))
    90103  (let ((doc-string *help*)
     
    98111  (tool-exit status))
    99112
     113(define (tool-error msg #!optional (status 1) (cmd *current-command*))
     114  (print "Error: " msg)
     115  (tool-usage status cmd) )
     116
    100117(define tool-exit exit)
    101118
     
    105122   (lambda (return)
    106123     (fluid-let ((tool-exit (lambda (#!optional (status 0)) (return status))))
    107        (cond ((null? args) 
     124       (cond ((null? args)
    108125              (if exec (exec '()) (proc)) )
    109              ((filter 
    110                (lambda (c) (string-prefix? (car args) (car c))) 
    111                tool:*commands*) 
     126             ((filter
     127               (lambda (c) (string-prefix? (car args) (car c)))
     128               tool:*commands*)
    112129              pair?
    113130              =>
     
    115132                 ((cmd)
    116133                  (fluid-let ((*current-command* cmd))
    117                     (let ((vals (args-fold 
     134                    (let ((vals (args-fold
    118135                                 (cdr args)
    119136                                 (map car (caddr cmd))
     
    127144              (let ((str (car args)))
    128145                (cond ((or (null? tool:*commands*)
    129                            (and (not (zero? (string-length str))) 
     146                           (and (not (zero? (string-length str)))
    130147                                (char=? #\- (string-ref str 0)) ) )
    131148                       (let ((vals (args-fold
     
    138155                             (exec (reverse vals))
    139156                             (tool-usage 1))))
    140                       (else (tool-usage 1) ) ) 
     157                      (else (tool-usage 1) ) )
    141158                0) ) ) ) ) ) )
    142159
    143160(define (tool-name #!optional name)
    144161  (if name
    145       (set! *program-name* name) 
     162      (set! *program-name* name)
    146163      *program-name*) )
    147164
    148165(define (tool-help #!optional str)
    149166  (if str
    150       (set! *help* str) 
     167      (set! *help* str)
    151168      *help*) )
  • tool/tool.scm

    r5416 r5487  
    33
    44(define-macro (define-option opt doc . args)
    5   (let-optionals args ((proc (string->symbol (->string opt))))
    6     (let ((ovar (gensym))
    7           (pvar (gensym))
    8           (v1 (gensym))
    9           (v2 (gensym))
    10           (v3 (gensym)) )
    11       `(let ((,ovar ,opt)
    12              (,pvar ,(if (symbol? proc)
    13                          `',proc
    14                          proc) ) )
    15          (set! tool:*options*
    16            (cons
    17             (tool:parse-option
    18              ,ovar
    19              ,doc
    20              ,(if (symbol? proc)
    21                   `(begin
    22                      (set! ,proc #f)
    23                      (lambda (,v1 ,(gensym) ,v2 ,v3)
    24                        (set! ,proc ,v2)
    25                        ,v3) )
    26                   proc) )
    27             tool:*options*) ) ) ) ) )
     5  (let-optionals args ((proc (cond ((list? opt) #f)
     6                                   (else (string->symbol (->string opt))))))
     7    (let ((v1 (gensym))
     8          (v2 (gensym))
     9          (v3 (gensym)) )
     10      `(tool:new-option
     11         ,opt
     12         ,doc
     13         ,(if (symbol? proc)
     14              `(begin
     15                 (set! ,proc #f)
     16                 (lambda (,v1 ,(gensym) ,v2 ,v3)
     17                   (set! ,proc ,v2)
     18                   ,v3) )
     19              proc) ) ) ) )
    2820
    2921(define-macro (define-flag opt doc . args)
    3022  (let-optionals args ((var (string->symbol (->string opt))))
    3123    (let ((v1 (gensym))
    32           (v2 (gensym)) )
     24          (v2 (gensym)) )
    3325      `(begin
    34         (set! ,var #f)
    35         (define-option
    36            (option ,opt #f #f #f)
    37            ,doc
    38            (lambda (,v1 ,(gensym) ,(gensym) ,v2) (set! ,var #t) ,v2)) ) ) ) )
     26        (set! ,var #f)
     27        (define-option
     28           (option ,opt #f #f #f)
     29           ,doc
     30           (lambda (,v1 ,(gensym) ,(gensym) ,v2) (set! ,var #t) ,v2)) ) ) ) )
    3931
    4032(define-macro (define-command name doc . body)
    4133  (let ((name (->string name)))
    4234    `(fluid-let ((tool:*options* tool:*options*))
    43        (let ((run (begin (lambda _ (error "unimplemented command" ',name)) ,@body)))
    44          (set! tool:*commands*
    45            (cons (list ',name ,doc tool:*options* run)
    46                  tool:*commands*) ) ) ) ) )
     35       (tool:new-command ',name ,doc tool:*options*
     36                         (begin (lambda _ (error "unimplemented command" ',name)) ,@body)) ) ) )
    4737
    4838(define-macro (define-tool head help . body)
    49   (let ((name (car head))
    50         (input (cadr head))
    51         (args-cnt-var (if (null? (cddr head)) 'arguments-count (caddr head)))
    52         (args-var (gensym)))
    53     `(begin
    54        (tool-name ,(symbol->string name))
    55        (tool-help ,help)
    56        (tool-main
    57          (command-line-arguments)
    58          (lambda (,args-var)
    59            (let ((,args-cnt-var (length ,args-var)))
    60              (for-each (lambda (,input) ,@body)
    61                        (if (null? ,args-var)
    62                            (list (current-input-port))
    63                            ,args-var) ) ) ) ) ) ) )
     39  (let-optionals head ((name (string->symbol (tool-name)))
     40                       (input 'argument)
     41                       (args-cnt-var 'argument-count)
     42                       (args-idx-var 'argument-index))
     43    (let ((args-var (gensym)))
     44      `(begin
     45         (tool-name ,(symbol->string name))
     46         (tool-help ,help)
     47         (tool-main
     48           (command-line-arguments)
     49           (lambda (,args-var)
     50             (let ((,args-cnt-var (length ,args-var))
     51                   (,args-idx-var 0))
     52               (for-each (lambda (,input) ,@body (set! ,args-idx-var (+ ,args-idx-var 1)))
     53                         (if (null? ,args-var)
     54                             (list (current-input-port))
     55                             ,args-var) ) ) ) ) ) ) ) )
Note: See TracChangeset for help on using the changeset viewer.