conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fixed bug in guard (now allowing definitions and expressions in <body>)

This commit is contained in:
Abdulaziz Ghuloum 2009-01-02 17:55:01 -05:00
parent e72effdb73
commit 5946459630
3 changed files with 133 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

217
lab/command-line.ss
View File

@ -17,8 +17,9 @@
(make-f id (car x) (cadr x) (cddr x))) (make-f id (car x) (cadr x) (cddr x)))
(define (get type ls) (define (get type ls)
(filter (lambda (x) (eq? (f-type x) type)) ls)) (filter (lambda (x) (eq? (f-type x) type)) ls))
(define (fmt-req x) (define (fmt-req p)
(format " -~a <~a>" (f-char x) (f-id x))) (lambda (x)
(display* (list " -" (f-char x) " <" (f-id x) ">") p)))
(define (fmt-req-no-value x) (define (fmt-req-no-value x)
(format " -~a" (f-char x))) (format " -~a" (f-char x)))
(define (fmt-z c) (define (fmt-z c)
@ -26,26 +27,29 @@
(format " [-~a <~a>]~a" (f-char x) (f-id x) c))) (format " [-~a <~a>]~a" (f-char x) (f-id x) c)))
(define (fmt-<> x) (define (fmt-<> x)
(format " <~a>" x)) (format " <~a>" x))
(define (display* ls p)
(for-each (lambda (x) (display x p)) ls))
(define (synopsis f* args args-rest) (define (synopsis f* args args-rest)
(let ([opt* (get 'optional f*)] (let ([opt* (get 'optional f*)]
[flag* (get 'flag f*)] [flag* (get 'flag f*)]
[req0* (get 'required0 f*)] [req0* (get 'required0 f*)]
[req1* (get 'required1 f*)] [req1* (get 'required1 f*)]
[z0* (get 'zero-plus f*)] [z0* (get 'zero-plus f*)]
[z1* (get 'one-plus f*)]) [z1* (get 'one-plus f*)])
(let-values ([(p e) (open-string-output-port)]) (let-values ([(p e) (open-string-output-port)])
(display (car arguments) p) (display (car arguments) p)
(display (apply string-append (map fmt-req-no-value req0*)) p) (display* (map fmt-req-no-value req0*) p)
(unless (null? flag*) (unless (null? flag*)
(fprintf p " [-~a]" (display " [-" p)
(list->string (map f-char flag*)))) (display* (map f-char flag*) p)
(display (apply string-append (map (fmt-z "") opt*)) p) (display "]" p))
(display (apply string-append (map (fmt-z "*") z0*)) p) (display* (map (fmt-z "") opt*) p)
(display (apply string-append (map (fmt-z "+") z1*)) p) (display* (map (fmt-z "*") z0*) p)
(display (apply string-append (map fmt-req req1*)) p) (display* (map (fmt-z "+") z1*) p)
(display (apply string-append (map fmt-<> args)) p) (for-each (fmt-req p) req1*)
(display* (map fmt-<> args) p)
(when args-rest (when args-rest
(display (string-append (fmt-<> args-rest) " ...") p)) (display* (list (fmt-<> args-rest) " ...") p))
(e)))) (e))))
(define (print-usage-line help fields field-ids args args-rest dash-rest) (define (print-usage-line help fields field-ids args args-rest dash-rest)
(let ([f* (map mkf fields field-ids)]) (let ([f* (map mkf fields field-ids)])
@ -61,11 +65,14 @@
(unless (null? def*) (unless (null? def*)
(for-each (for-each
(lambda (x) (lambda (x)
(printf " -~a defaults to ~a\n" (f-char x) (display*
(f-def x))) (list " -" (f-char x)
" defaults to" (f-def x)
"\n")
(current-output-port)))
def*))) def*)))
(newline)))) (newline))))
(printf "\nUsage:\n") (display "\nUsage:\n")
(for-each (lambda (x) (apply print-usage-line x)) data*) (for-each (lambda (x) (apply print-usage-line x)) data*)
(print-usage-line "Display this help message" (print-usage-line "Display this help message"
'([#\h required0 . #f]) '([#\h required0 . #f])
@ -305,119 +312,140 @@
#'(dispatch-opts expr '(data* ...) (list proc* ...)))]))) #'(dispatch-opts expr '(data* ...) (list proc* ...)))])))
(define-syntax define-command
(syntax-rules ()
[(_ (name arg) . body)
(begin
(define (name arg) . body)
(display "================================================\n")
(pretty-print '(define (name arg) . body))
(newline))]))
(define-syntax test (define-syntax test
(syntax-rules () (syntax-rules ()
[(_ command ls expected) [(_ command
(begin [ls* expected*] ...)
(printf "testing ~s => ~s ... " '(command ls) 'expected) (for-each
(let ([a1 (command 'ls)] (lambda (ls expected)
[a2 'expected]) (printf "~s => " `(command ',ls))
(unless (equal? a1 a2) (let ([a1 (command ls)]
(error #f "failed/got/expected" a1 'expected)) [a2 expected])
(printf "OK\n")))])) (unless (equal? a1 a2)
(error #f "failed/got/expected" a1 expected))
(printf "~s OK\n" expected)))
'(ls* ...)
'(expected* ...))]))
(define (command1 ls) (define-command (command1 ls)
(command-line-interface ls (command-line-interface ls
[(p) "Help0" (list 0 p)] [(p) "Help0" (list 0 p)]
[(p p1) "Help1" (list 1 p p1)] [(p p1) "Help1" (list 1 p p1)]
[(p p1 p2) "Help2" (list 2 p p1 p2)] [(p p1 p2) "Help2" (list 2 p p1 p2)]
[(p p1 p2 p3) "Help3" (list 3 p p1 p2 p3)])) [(p p1 p2 p3) "Help3" (list 3 p p1 p2 p3)]))
(test command1 ("p") (0 "p")) (test command1
(test command1 ("p" "p1") (1 "p" "p1")) [("p") (0 "p")]
(test command1 ("p" "p1" "p2") (2 "p" "p1" "p2")) [("p" "p1") (1 "p" "p1")]
(test command1 ("p" "p1" "p2" "p3") (3 "p" "p1" "p2" "p3")) [("p" "p1" "p2") (2 "p" "p1" "p2")]
(test command1 ("./prog" "p1" "p2" "p3" "p4") #f) [("p" "p1" "p2" "p3") (3 "p" "p1" "p2" "p3")]
[("./prog" "p1" "p2" "p3" "p4") #f])
(define (command2 ls) (define-command (command2 ls)
(command-line-interface ls (command-line-interface ls
[(p p1 p2 p3) "Help3" (list 3 p p1 p2 p3)] [(p p1 p2 p3) "Help3" (list 3 p p1 p2 p3)]
[(p p1 p2 ps ...) "Help2" (list 2 p p1 p2 ps)] [(p p1 p2 ps ...) "Help2" (list 2 p p1 p2 ps)]
[(p p1 ps ...) "Help1" (list 1 p p1 ps)] [(p p1 ps ...) "Help1" (list 1 p p1 ps)]
[(p ps ...) "Help0" (list 0 p ps)])) [(p ps ...) "Help0" (list 0 p ps)]))
(test command2 ("p") (0 "p" ())) (test command2
(test command2 ("p" "a") (1 "p" "a" ())) [("p") (0 "p" ())]
(test command2 ("p" "a" "b") (2 "p" "a" "b" ())) [("p" "a") (1 "p" "a" ())]
(test command2 ("p" "a" "b" "c") (3 "p" "a" "b" "c")) [("p" "a" "b") (2 "p" "a" "b" ())]
(test command2 ("p" "a" "b" "c" "d") (2 "p" "a" "b" ("c" "d"))) [("p" "a" "b" "c") (3 "p" "a" "b" "c")]
(test command2 ("./prog" "-h") #f) [("p" "a" "b" "c" "d") (2 "p" "a" "b" ("c" "d"))]
[("./prog" "-h") #f])
(define (command3 ls) (define-command (command3 ls)
(command-line-interface ls (command-line-interface ls
[(p "-X" xopt "-Y" yopt) (list 'xy p xopt yopt)] [(p "-X" xopt "-Y" yopt) (list 'xy p xopt yopt)]
[(p "-X" xopt) (list 'x p xopt)] [(p "-X" xopt) (list 'x p xopt)]
[(p "-Y" yopt) (list 'y p yopt)])) [(p "-Y" yopt) (list 'y p yopt)]))
(test command3 ("p" "-X" "xopt") (x "p" "xopt")) (test command3
(test command3 ("p" "-Y" "yopt") (y "p" "yopt")) [("p" "-X" "xopt") (x "p" "xopt")]
(test command3 ("p" "-X" "xopt" "-Y" "yopt") (xy "p" "xopt" "yopt")) [("p" "-Y" "yopt") (y "p" "yopt")]
(test command3 ("p" "-Y" "yopt" "-X" "xopt") (xy "p" "xopt" "yopt")) [("p" "-X" "xopt" "-Y" "yopt") (xy "p" "xopt" "yopt")]
(test command3 ("./prog") #f) [("p" "-Y" "yopt" "-X" "xopt") (xy "p" "xopt" "yopt")]
(test command3 ("./prog" "-h") #f) [("./prog") #f]
[("./prog" "-h") #f])
(define (command4 ls) (define-command (command4 ls)
(command-line-interface ls (command-line-interface ls
[(p "-X?" xopt "-Y?" yopt) (list p xopt yopt)] [(p "-X?" xopt "-Y?" yopt) (list p xopt yopt)]
[(p "-X?" xopt rest ...) (list p xopt rest)])) [(p "-X?" xopt rest ...) (list p xopt rest)]))
(test command4 ("p") ("p" #f #f)) (test command4
(test command4 ("p" "-X") ("p" #t #f)) [("p") ("p" #f #f)]
(test command4 ("p" "-Y") ("p" #f #t)) [("p" "-X") ("p" #t #f)]
(test command4 ("p" "-X" "-Y") ("p" #t #t)) [("p" "-Y") ("p" #f #t)]
(test command4 ("p" "-Y" "-X") ("p" #t #t)) [("p" "-X" "-Y") ("p" #t #t)]
(test command4 ("p" "-X" "a") ("p" #t ("a"))) [("p" "-Y" "-X") ("p" #t #t)]
(test command4 ("p" "a") ("p" #f ("a"))) [("p" "-X" "a") ("p" #t ("a"))]
(test command4 ("./prog" "-h") #f) [("p" "a") ("p" #f ("a"))]
[("./prog" "-h") #f])
(define (command5 ls) (define-command (command5 ls)
(command-line-interface ls (command-line-interface ls
[(p "-X=default" xopt) (list p xopt)])) [(p "-X=default" xopt) (list p xopt)]))
(test command5 ("p") ("p" "default")) (test command5
(test command5 ("p" "-X" "hello") ("p" "hello")) [("p") ("p" "default")]
(test command5 ("./prog" "-h") #f) [("p" "-X" "hello") ("p" "hello")]
[("./prog" "-h") #f])
(define (command6 ls) (define-command (command6 ls)
(command-line-interface ls (command-line-interface ls
[(p "-X*" xopts) (list p xopts)] [(p "-X*" xopts) (list p xopts)]
[(p "-X*" xopts "-Y*" yopts) (list p xopts yopts)])) [(p "-X*" xopts "-Y*" yopts) (list p xopts yopts)]))
(test command6 ("p") ("p" ())) (test command6
(test command6 ("p" "-X" "a" "-X" "b") ("p" ("a" "b"))) [("p") ("p" ())]
(test command6 ("p" "-X" "a" "-Y" "b") ("p" ("a") ("b"))) [("p" "-X" "a" "-X" "b") ("p" ("a" "b"))]
(test command6 ("p" "-Y" "b") ("p" () ("b"))) [("p" "-X" "a" "-Y" "b") ("p" ("a") ("b"))]
(test command6 ("p" "-X" "a" "-Y" "b" "-X" "c" "-Y" "d") [("p" "-Y" "b") ("p" () ("b"))]
("p" ("a" "c") ("b" "d"))) [("p" "-X" "a" "-Y" "b" "-X" "c" "-Y" "d") ("p" ("a" "c") ("b" "d"))]
(test command6 ("./prog" "-Q" "12") #f) [("./prog" "-Q" "12") #f]
(test command6 ("./prog" "-h") #f) [("./prog" "-h") #f])
(define (command7 ls) (define-command (command7 ls)
(command-line-interface ls (command-line-interface ls
[(p "-X+" xopts) (list p xopts)] [(p "-X+" xopts) (list p xopts)]
[(p "-X*" xopts "-Y+" yopts) (list p xopts yopts)])) [(p "-X*" xopts "-Y+" yopts) (list p xopts yopts)]))
(test command7 ("p" "-X" "a") ("p" ("a"))) (test command7
(test command7 ("p" "-X" "a" "-X" "b") ("p" ("a" "b"))) [("p" "-X" "a") ("p" ("a"))]
(test command7 ("p" "-X" "a" "-Y" "b") ("p" ("a") ("b"))) [("p" "-X" "a" "-X" "b") ("p" ("a" "b"))]
(test command7 ("p" "-Y" "b") ("p" () ("b"))) [("p" "-X" "a" "-Y" "b") ("p" ("a") ("b"))]
(test command7 ("p" "-X" "a" "-Y" "b" "-X" "c" "-Y" "d") [("p" "-Y" "b") ("p" () ("b"))]
("p" ("a" "c") ("b" "d"))) [("p" "-X" "a" "-Y" "b" "-X" "c" "-Y" "d") ("p" ("a" "c") ("b" "d"))]
(test command7 ("./prog") #f) [("./prog") #f]
(test command7 ("./prog" "-h") #f) [("./prog" "-h") #f])
(define (command8 ls) (define-command (command8 ls)
(command-line-interface ls (command-line-interface ls
[(p "-Q=foobar" q "-R=blabla" r "-X?" xopts "-Y?" yopt "-L*" libs "-f" file file* ...) [(p "-Q=foobar" q "-R=blabla" r "-X?" xopts "-Y?" yopt "-L*" libs
"-f" file file* ...)
"Does something nice" "Does something nice"
#t])) #t]))
(test command8 ("./prog") #f) (test command8
(test command8 ("./prog" "-h") #f) [("./prog") #f]
(test command8 ("./prog" "--help") #f) [("./prog" "-h") #f]
[("./prog" "--help") #f])
(define (ls-command ls)
(define-command (ls-command ls)
(command-line-interface ls (command-line-interface ls
[(ls "-A?" A "-B?" B "-C?" C "-F?" F "-G?" G "-H?" H "-L?" L [(ls "-A?" A "-B?" B "-C?" C "-F?" F "-G?" G "-H?" H "-L?" L
"-P?" P "-R?" R "-S?" S "-T?" T "-W?" W "-Z?" Z "-a?" a "-P?" P "-R?" R "-S?" S "-T?" T "-W?" W "-Z?" Z "-a?" a
@ -427,7 +455,8 @@
files ...) files ...)
#t])) #t]))
(test ls-command ("ls" "-h") #f) (test ls-command
[("ls" "-h") #f])
#!eof #!eof
@ -466,3 +495,19 @@
"Each of <library-files> must contain a library and are" "Each of <library-files> must contain a library and are"
"installed before the <init-files> are loaded" "installed before the <init-files> are loaded"
(list 4 program libdirs library-files init-files args)])) (list 4 program libdirs library-files init-files args)]))
#!eof
=head1 NAME
gimp-request - send a request to GIMP's Script-Fu Server
=head1 SYNOPSIS
Syntax:
$ gimp-request \
[--server=HOST][--port=PORT] \
[SCHEME_FILE] [ARGS]...

2
scheme/last-revision
View File

@ -1 +1 @@
1730 1735

2
scheme/psyntax.expander.ss
View File

@ -1337,7 +1337,7 @@
(with-exception-handler (with-exception-handler
(lambda (,con) (lambda (,con)
,(gen-clauses con outerk clause*)) ,(gen-clauses con outerk clause*))
(lambda () #f ,b ,@b*)))))))))))) (lambda () ,b ,@b*))))))))))))
(define define-enumeration-macro (define define-enumeration-macro
(lambda (stx) (lambda (stx)