Artifact
e2f1c247b7153ac6aa5b636328a930d359144408:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 37 2d 32 30 31 30 2c 20 4d 61 74 74 68 65 77 20 7-2010, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 0a 3b 3b 20 54 Welland..;;.;; T
0030: 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 72 74 his file is part
0040: 20 6f 66 20 6d 74 61 72 67 73 2e 0a 3b 3b 20 0a of mtargs..;; .
0050: 3b 3b 20 20 20 20 20 6d 74 61 72 67 73 20 69 73 ;; mtargs is
0060: 20 66 72 65 65 20 73 6f 66 74 77 61 72 65 3a 20 free software:
0070: 79 6f 75 20 63 61 6e 20 72 65 64 69 73 74 72 69 you can redistri
0080: 62 75 74 65 20 69 74 20 61 6e 64 2f 6f 72 20 6d bute it and/or m
0090: 6f 64 69 66 79 0a 3b 3b 20 20 20 20 20 69 74 20 odify.;; it
00a0: 75 6e 64 65 72 20 74 68 65 20 74 65 72 6d 73 20 under the terms
00b0: 6f 66 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 of the GNU Gener
00c0: 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 al Public Licens
00d0: 65 20 61 73 20 70 75 62 6c 69 73 68 65 64 20 62 e as published b
00e0: 79 0a 3b 3b 20 20 20 20 20 74 68 65 20 46 72 65 y.;; the Fre
00f0: 65 20 53 6f 66 74 77 61 72 65 20 46 6f 75 6e 64 e Software Found
0100: 61 74 69 6f 6e 2c 20 65 69 74 68 65 72 20 76 65 ation, either ve
0110: 72 73 69 6f 6e 20 33 20 6f 66 20 74 68 65 20 4c rsion 3 of the L
0120: 69 63 65 6e 73 65 2c 20 6f 72 0a 3b 3b 20 20 20 icense, or.;;
0130: 20 20 28 61 74 20 79 6f 75 72 20 6f 70 74 69 6f (at your optio
0140: 6e 29 20 61 6e 79 20 6c 61 74 65 72 20 76 65 72 n) any later ver
0150: 73 69 6f 6e 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 sion..;; .;;
0160: 20 6d 74 61 72 67 73 20 69 73 20 64 69 73 74 72 mtargs is distr
0170: 69 62 75 74 65 64 20 69 6e 20 74 68 65 20 68 6f ibuted in the ho
0180: 70 65 20 74 68 61 74 20 69 74 20 77 69 6c 6c 20 pe that it will
0190: 62 65 20 75 73 65 66 75 6c 2c 0a 3b 3b 20 20 20 be useful,.;;
01a0: 20 20 62 75 74 20 57 49 54 48 4f 55 54 20 41 4e but WITHOUT AN
01b0: 59 20 57 41 52 52 41 4e 54 59 3b 20 77 69 74 68 Y WARRANTY; with
01c0: 6f 75 74 20 65 76 65 6e 20 74 68 65 20 69 6d 70 out even the imp
01d0: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
01e0: 0a 3b 3b 20 20 20 20 20 4d 45 52 43 48 41 4e 54 .;; MERCHANT
01f0: 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e 45 ABILITY or FITNE
0200: 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 55 SS FOR A PARTICU
0210: 4c 41 52 20 50 55 52 50 4f 53 45 2e 20 20 53 65 LAR PURPOSE. Se
0220: 65 20 74 68 65 0a 3b 3b 20 20 20 20 20 47 4e 55 e the.;; GNU
0230: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
0240: 4c 69 63 65 6e 73 65 20 66 6f 72 20 6d 6f 72 65 License for more
0250: 20 64 65 74 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b details..;; .;;
0260: 20 20 20 20 20 59 6f 75 20 73 68 6f 75 6c 64 20 You should
0270: 68 61 76 65 20 72 65 63 65 69 76 65 64 20 61 20 have received a
0280: 63 6f 70 79 20 6f 66 20 74 68 65 20 47 4e 55 20 copy of the GNU
0290: 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 4c General Public L
02a0: 69 63 65 6e 73 65 0a 3b 3b 20 20 20 20 20 61 6c icense.;; al
02b0: 6f 6e 67 20 77 69 74 68 20 6d 74 61 72 67 73 2e ong with mtargs.
02c0: 20 20 49 66 20 6e 6f 74 2c 20 73 65 65 20 3c 68 If not, see <h
02d0: 74 74 70 3a 2f 2f 77 77 77 2e 67 6e 75 2e 6f 72 ttp://www.gnu.or
02e0: 67 2f 6c 69 63 65 6e 73 65 73 2f 3e 2e 0a 0a 0a g/licenses/>....
02f0: 28 6d 6f 64 75 6c 65 20 6d 74 61 72 67 73 0a 20 (module mtargs.
0300: 20 20 20 28 0a 20 20 20 20 20 61 72 67 2d 68 61 (. arg-ha
0310: 73 68 0a 20 20 20 20 20 67 65 74 2d 61 72 67 0a sh. get-arg.
0320: 20 20 20 20 20 67 65 74 2d 61 72 67 2d 66 72 6f get-arg-fro
0330: 6d 0a 20 20 20 20 20 75 73 61 67 65 0a 20 20 20 m. usage.
0340: 20 20 67 65 74 2d 61 72 67 73 0a 20 20 20 20 20 get-args.
0350: 70 72 69 6e 74 2d 61 72 67 73 0a 20 20 20 20 20 print-args.
0360: 61 6e 79 2d 64 65 66 69 6e 65 64 3f 0a 20 20 20 any-defined?.
0370: 20 20 68 65 6c 70 0a 20 20 20 20 20 29 0a 0a 28 help. )..(
0380: 69 6d 70 6f 72 74 20 73 63 68 65 6d 65 20 63 68 import scheme ch
0390: 69 63 6b 65 6e 20 64 61 74 61 2d 73 74 72 75 63 icken data-struc
03a0: 74 75 72 65 73 20 65 78 74 72 61 73 20 70 6f 73 tures extras pos
03b0: 69 78 20 70 6f 72 74 73 20 66 69 6c 65 73 29 0a ix ports files).
03c0: 28 75 73 65 20 73 72 66 69 2d 36 39 20 73 72 66 (use srfi-69 srf
03d0: 69 2d 31 29 0a 0a 28 64 65 66 69 6e 65 20 61 72 i-1)..(define ar
03e0: 67 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 73 g-hash (make-has
03f0: 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 69 6e h-table)).(defin
0400: 65 20 68 65 6c 70 20 22 22 29 0a 0a 28 64 65 66 e help "")..(def
0410: 69 6e 65 20 28 67 65 74 2d 61 72 67 20 61 72 67 ine (get-arg arg
0420: 20 2e 20 64 65 66 61 75 6c 74 29 0a 20 20 28 69 . default). (i
0430: 66 20 28 6e 75 6c 6c 3f 20 64 65 66 61 75 6c 74 f (null? default
0440: 29 0a 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 ). (hash-ta
0450: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
0460: 61 72 67 2d 68 61 73 68 20 61 72 67 20 23 66 29 arg-hash arg #f)
0470: 0a 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 . (hash-tab
0480: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 61 le-ref/default a
0490: 72 67 2d 68 61 73 68 20 61 72 67 20 28 63 61 72 rg-hash arg (car
04a0: 20 64 65 66 61 75 6c 74 29 29 29 29 0a 0a 28 64 default))))..(d
04b0: 65 66 69 6e 65 20 28 61 6e 79 2d 64 65 66 69 6e efine (any-defin
04c0: 65 64 3f 20 2e 20 61 72 67 73 29 0a 20 20 28 6e ed? . args). (n
04d0: 6f 74 20 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 ot (null? (filte
04e0: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 20 78 29 r (lambda (x) x)
04f0: 0a 09 09 20 20 20 20 20 20 28 6d 61 70 20 67 65 ... (map ge
0500: 74 2d 61 72 67 20 61 72 67 73 29 29 29 29 29 0a t-arg args))))).
0510: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 61 6e 79 20 .;; (define any
0520: 61 6e 79 2d 64 65 66 69 6e 65 64 3f 29 0a 0a 28 any-defined?)..(
0530: 64 65 66 69 6e 65 20 28 67 65 74 2d 61 72 67 2d define (get-arg-
0540: 66 72 6f 6d 20 68 74 20 61 72 67 20 2e 20 64 65 from ht arg . de
0550: 66 61 75 6c 74 29 0a 20 20 28 69 66 20 28 6e 75 fault). (if (nu
0560: 6c 6c 3f 20 64 65 66 61 75 6c 74 29 0a 20 20 20 ll? default).
0570: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
0580: 65 66 2f 64 65 66 61 75 6c 74 20 68 74 20 61 72 ef/default ht ar
0590: 67 20 23 66 29 0a 20 20 20 20 20 20 28 68 61 73 g #f). (has
05a0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
05b0: 75 6c 74 20 68 74 20 61 72 67 20 28 63 61 72 20 ult ht arg (car
05c0: 64 65 66 61 75 6c 74 29 29 29 29 0a 0a 28 64 65 default))))..(de
05d0: 66 69 6e 65 20 28 75 73 61 67 65 20 2e 20 61 72 fine (usage . ar
05e0: 67 73 29 0a 20 20 28 69 66 20 28 3e 20 28 6c 65 gs). (if (> (le
05f0: 6e 67 74 68 20 61 72 67 73 29 20 30 29 0a 20 20 ngth args) 0).
0600: 20 20 20 20 28 61 70 70 6c 79 20 70 72 69 6e 74 (apply print
0610: 20 22 45 52 52 4f 52 3a 20 22 20 61 72 67 73 29 "ERROR: " args)
0620: 29 0a 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f ). (if (string?
0630: 20 68 65 6c 70 29 0a 20 20 20 20 20 20 28 70 72 help). (pr
0640: 69 6e 74 20 68 65 6c 70 29 0a 20 20 20 20 20 20 int help).
0650: 28 70 72 69 6e 74 20 22 55 73 61 67 65 3a 20 22 (print "Usage: "
0660: 20 28 63 61 72 20 28 61 72 67 76 29 29 20 22 20 (car (argv)) "
0670: 2e 2e 2e 20 22 29 29 0a 20 20 28 65 78 69 74 20 ... ")). (exit
0680: 30 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 0))..(define (ge
0690: 74 2d 61 72 67 73 20 61 72 67 73 20 70 61 72 61 t-args args para
06a0: 6d 73 20 73 77 69 74 63 68 65 73 20 61 72 67 2d ms switches arg-
06b0: 68 61 73 68 20 6e 75 6d 2d 6e 65 65 64 65 64 29 hash num-needed)
06c0: 0a 20 20 28 6c 65 74 2a 20 28 28 6e 75 6d 74 61 . (let* ((numta
06d0: 72 67 73 20 28 6c 65 6e 67 74 68 20 61 72 67 73 rgs (length args
06e0: 29 29 0a 09 20 28 61 64 6a 2d 6e 75 6d 2d 6e 65 )).. (adj-num-ne
06f0: 65 64 65 64 20 28 69 66 20 6e 75 6d 2d 6e 65 65 eded (if num-nee
0700: 64 65 64 20 28 2b 20 6e 75 6d 2d 6e 65 65 64 65 ded (+ num-neede
0710: 64 20 32 29 20 23 66 29 29 29 0a 20 20 20 20 28 d 2) #f))). (
0720: 69 66 20 28 3c 20 6e 75 6d 74 61 72 67 73 20 28 if (< numtargs (
0730: 69 66 20 61 64 6a 2d 6e 75 6d 2d 6e 65 65 64 65 if adj-num-neede
0740: 64 20 61 64 6a 2d 6e 75 6d 2d 6e 65 65 64 65 64 d adj-num-needed
0750: 20 32 29 29 0a 09 28 69 66 20 28 3e 3d 20 6e 75 2))..(if (>= nu
0760: 6d 2d 6e 65 65 64 65 64 20 31 29 0a 09 20 20 20 m-needed 1)..
0770: 20 28 75 73 61 67 65 20 22 4e 6f 20 61 72 67 75 (usage "No argu
0780: 6d 65 6e 74 73 20 70 72 6f 76 69 64 65 64 22 29 ments provided")
0790: 0a 09 20 20 20 20 27 28 29 29 0a 09 28 6c 65 74 .. '())..(let
07a0: 20 6c 6f 6f 70 20 28 28 61 72 67 20 28 63 61 64 loop ((arg (cad
07b0: 72 20 61 72 67 73 29 29 0a 09 09 20 20 20 28 74 r args))... (t
07c0: 61 69 6c 20 28 63 64 64 72 20 61 72 67 73 29 29 ail (cddr args))
07d0: 0a 09 09 20 20 20 28 72 65 6d 74 61 72 67 73 20 ... (remtargs
07e0: 27 28 29 29 29 0a 09 20 20 28 63 6f 6e 64 20 0a '())).. (cond .
07f0: 09 20 20 20 28 28 6d 65 6d 62 65 72 20 61 72 67 . ((member arg
0800: 20 70 61 72 61 6d 73 29 20 3b 3b 20 61 72 67 73 params) ;; args
0810: 20 77 69 74 68 20 70 61 72 61 6d 73 0a 09 20 20 with params..
0820: 20 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 (if (< (length
0830: 20 74 61 69 6c 29 20 31 29 0a 09 09 28 75 73 61 tail) 1)...(usa
0840: 67 65 20 22 70 61 72 61 6d 20 67 69 76 65 6e 20 ge "param given
0850: 77 69 74 68 6f 75 74 20 61 72 67 75 6d 65 6e 74 without argument
0860: 20 22 20 61 72 67 29 0a 09 09 28 6c 65 74 20 28 " arg)...(let (
0870: 28 76 61 6c 20 20 20 20 20 28 63 61 72 20 74 61 (val (car ta
0880: 69 6c 29 29 0a 09 09 20 20 20 20 20 20 28 6e 65 il))... (ne
0890: 77 74 61 69 6c 20 28 63 64 72 20 74 61 69 6c 29 wtail (cdr tail)
08a0: 29 29 0a 09 09 20 20 28 68 61 73 68 2d 74 61 62 ))... (hash-tab
08b0: 6c 65 2d 73 65 74 21 20 61 72 67 2d 68 61 73 68 le-set! arg-hash
08c0: 20 61 72 67 20 76 61 6c 29 0a 09 09 20 20 28 69 arg val)... (i
08d0: 66 20 28 6e 75 6c 6c 3f 20 6e 65 77 74 61 69 6c f (null? newtail
08e0: 29 20 72 65 6d 74 61 72 67 73 0a 09 09 20 20 20 ) remtargs...
08f0: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 (loop (car ne
0900: 77 74 61 69 6c 29 28 63 64 72 20 6e 65 77 74 61 wtail)(cdr newta
0910: 69 6c 29 20 72 65 6d 74 61 72 67 73 29 29 29 29 il) remtargs))))
0920: 29 0a 09 20 20 20 28 28 6d 65 6d 62 65 72 20 61 ).. ((member a
0930: 72 67 20 73 77 69 74 63 68 65 73 29 20 20 20 20 rg switches)
0940: 20 20 20 20 20 3b 3b 20 61 72 67 73 20 77 69 74 ;; args wit
0950: 68 20 6e 6f 20 70 61 72 61 6d 73 20 28 69 2e 65 h no params (i.e
0960: 2e 20 73 77 69 74 63 68 65 73 29 0a 09 20 20 20 . switches)..
0970: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
0980: 21 20 61 72 67 2d 68 61 73 68 20 61 72 67 20 23 ! arg-hash arg #
0990: 74 29 0a 09 20 20 20 20 28 69 66 20 28 6e 75 6c t).. (if (nul
09a0: 6c 3f 20 74 61 69 6c 29 20 72 65 6d 74 61 72 67 l? tail) remtarg
09b0: 73 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 s...(loop (car t
09c0: 61 69 6c 29 28 63 64 72 20 74 61 69 6c 29 20 72 ail)(cdr tail) r
09d0: 65 6d 74 61 72 67 73 29 29 29 0a 09 20 20 20 28 emtargs))).. (
09e0: 65 6c 73 65 0a 09 20 20 20 20 28 69 66 20 28 6e else.. (if (n
09f0: 75 6c 6c 3f 20 74 61 69 6c 29 28 61 70 70 65 6e ull? tail)(appen
0a00: 64 20 72 65 6d 74 61 72 67 73 20 28 6c 69 73 74 d remtargs (list
0a10: 20 61 72 67 29 29 20 3b 3b 20 72 65 74 75 72 6e arg)) ;; return
0a20: 20 74 68 65 20 6e 6f 6e 2d 75 73 65 64 20 61 72 the non-used ar
0a30: 67 73 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 gs...(loop (car
0a40: 74 61 69 6c 29 28 63 64 72 20 74 61 69 6c 29 28 tail)(cdr tail)(
0a50: 61 70 70 65 6e 64 20 72 65 6d 74 61 72 67 73 20 append remtargs
0a60: 28 6c 69 73 74 20 61 72 67 29 29 29 29 29 29 29 (list arg)))))))
0a70: 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 69 6e ). ))..(defin
0a80: 65 20 28 70 72 69 6e 74 2d 61 72 67 73 20 72 65 e (print-args re
0a90: 6d 74 61 72 67 73 20 61 72 67 2d 68 61 73 68 29 mtargs arg-hash)
0aa0: 0a 20 20 28 70 72 69 6e 74 20 22 41 52 47 53 3a . (print "ARGS:
0ab0: 20 22 20 72 65 6d 74 61 72 67 73 29 0a 20 20 28 " remtargs). (
0ac0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
0ad0: 20 28 61 72 67 29 0a 09 20 20 20 20 20 20 28 70 (arg).. (p
0ae0: 72 69 6e 74 20 22 20 20 20 22 20 61 72 67 20 22 rint " " arg "
0af0: 20 20 20 22 20 28 68 61 73 68 2d 74 61 62 6c 65 " (hash-table
0b00: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 61 72 67 -ref/default arg
0b10: 2d 68 61 73 68 20 61 72 67 20 23 66 29 29 29 0a -hash arg #f))).
0b20: 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
0b30: 2d 6b 65 79 73 20 61 72 67 2d 68 61 73 68 29 29 -keys arg-hash))
0b40: 29 0a 0a 0a 29 0a )...).