Artifact
c1d2bd2b3a7845cad2355ccfd49736e97a2db41f:
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 6e 75 6d get-arg-num
0330: 62 65 72 0a 20 20 20 20 20 67 65 74 2d 61 72 67 ber. get-arg
0340: 2d 66 72 6f 6d 0a 20 20 20 20 20 72 65 6d 6f 76 -from. remov
0350: 65 2d 61 72 67 2d 66 72 6f 6d 2d 68 74 0a 20 20 e-arg-from-ht.
0360: 20 20 20 67 65 74 2d 61 72 67 73 0a 20 20 20 20 get-args.
0370: 20 75 73 61 67 65 0a 20 20 20 20 20 70 72 69 6e usage. prin
0380: 74 2d 61 72 67 73 0a 20 20 20 20 20 61 6e 79 2d t-args. any-
0390: 64 65 66 69 6e 65 64 3f 0a 20 20 20 20 20 29 20 defined?. )
03a0: 0a 0a 28 69 6d 70 6f 72 74 20 73 63 68 65 6d 65 ..(import scheme
03b0: 29 20 3b 3b 20 67 69 76 65 73 20 75 73 20 63 6f ) ;; gives us co
03c0: 6e 64 2d 65 78 70 61 6e 64 20 69 6e 20 63 68 69 nd-expand in chi
03d0: 63 6b 65 6e 2d 34 0a 0a 28 63 6f 6e 64 2d 65 78 cken-4..(cond-ex
03e0: 70 61 6e 64 0a 20 28 63 68 69 63 6b 65 6e 2d 35 pand. (chicken-5
03f0: 0a 20 20 28 69 6d 70 6f 72 74 20 73 63 68 65 6d . (import schem
0400: 65 20 28 63 68 69 63 6b 65 6e 20 62 61 73 65 29 e (chicken base)
0410: 20 28 63 68 69 63 6b 65 6e 20 70 6f 72 74 29 20 (chicken port)
0420: 28 63 68 69 63 6b 65 6e 20 66 69 6c 65 29 20 28 (chicken file) (
0430: 63 68 69 63 6b 65 6e 20 70 72 6f 63 65 73 73 2d chicken process-
0440: 63 6f 6e 74 65 78 74 29 29 0a 20 20 28 69 6d 70 context)). (imp
0450: 6f 72 74 20 73 72 66 69 2d 36 39 20 73 72 66 69 ort srfi-69 srfi
0460: 2d 31 29 29 0a 20 28 63 68 69 63 6b 65 6e 2d 34 -1)). (chicken-4
0470: 0a 20 20 28 69 6d 70 6f 72 74 20 63 68 69 63 6b . (import chick
0480: 65 6e 20 70 6f 73 69 78 20 73 72 66 69 2d 36 39 en posix srfi-69
0490: 20 73 72 66 69 2d 31 29 29 0a 20 28 65 6c 73 65 srfi-1)). (else
04a0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 75 73 61 67 ))..(define usag
04b0: 65 20 28 6d 61 6b 65 2d 70 61 72 61 6d 65 74 65 e (make-paramete
04c0: 72 20 70 72 69 6e 74 29 29 0a 28 64 65 66 69 6e r print)).(defin
04d0: 65 20 61 72 67 2d 68 61 73 68 20 28 6d 61 6b 65 e arg-hash (make
04e0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 0a 28 -hash-table))..(
04f0: 64 65 66 69 6e 65 20 28 67 65 74 2d 61 72 67 20 define (get-arg
0500: 61 72 67 20 2e 20 64 65 66 61 75 6c 74 29 0a 20 arg . default).
0510: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 65 66 61 (if (null? defa
0520: 75 6c 74 29 0a 20 20 20 20 20 20 28 68 61 73 68 ult). (hash
0530: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
0540: 6c 74 20 61 72 67 2d 68 61 73 68 20 61 72 67 20 lt arg-hash arg
0550: 23 66 29 0a 20 20 20 20 20 20 28 68 61 73 68 2d #f). (hash-
0560: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
0570: 74 20 61 72 67 2d 68 61 73 68 20 61 72 67 20 28 t arg-hash arg (
0580: 63 61 72 20 64 65 66 61 75 6c 74 29 29 29 29 0a car default)))).
0590: 0a 3b 3b 20 67 65 74 20 61 6e 20 61 72 67 20 61 .;; get an arg a
05a0: 73 20 61 20 6e 75 6d 62 65 72 0a 28 64 65 66 69 s a number.(defi
05b0: 6e 65 20 28 67 65 74 2d 61 72 67 2d 6e 75 6d 62 ne (get-arg-numb
05c0: 65 72 20 61 72 67 20 2e 20 64 65 66 61 75 6c 74 er arg . default
05d0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 76 61 6c 2d ). (let* ((val-
05e0: 73 74 72 20 28 67 65 74 2d 61 72 67 20 61 72 67 str (get-arg arg
05f0: 29 29 0a 09 20 28 76 61 6c 20 20 20 20 20 28 69 )).. (val (i
0600: 66 20 76 61 6c 2d 73 74 72 20 28 73 74 72 69 6e f val-str (strin
0610: 67 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 2d 73 74 g->number val-st
0620: 72 29 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 r) #f))). (if
0630: 20 76 61 6c 0a 09 76 61 6c 0a 09 28 69 66 20 28 val..val..(if (
0640: 6e 75 6c 6c 3f 20 64 65 66 61 75 6c 74 29 0a 09 null? default)..
0650: 20 20 20 20 23 66 0a 09 20 20 20 20 64 65 66 61 #f.. defa
0660: 75 6c 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ult))))..(define
0670: 20 28 61 6e 79 2d 64 65 66 69 6e 65 64 3f 20 2e (any-defined? .
0680: 20 61 72 67 73 29 0a 20 20 28 6e 6f 74 20 28 6e args). (not (n
0690: 75 6c 6c 3f 20 28 66 69 6c 74 65 72 20 28 6c 61 ull? (filter (la
06a0: 6d 62 64 61 20 28 78 29 20 78 29 0a 09 09 20 20 mbda (x) x)...
06b0: 20 20 20 20 28 6d 61 70 20 67 65 74 2d 61 72 67 (map get-arg
06c0: 20 61 72 67 73 29 29 29 29 29 0a 0a 3b 3b 20 28 args)))))..;; (
06d0: 64 65 66 69 6e 65 20 61 6e 79 20 61 6e 79 2d 64 define any any-d
06e0: 65 66 69 6e 65 64 3f 29 0a 0a 28 64 65 66 69 6e efined?)..(defin
06f0: 65 20 28 67 65 74 2d 61 72 67 2d 66 72 6f 6d 20 e (get-arg-from
0700: 68 74 20 61 72 67 20 2e 20 64 65 66 61 75 6c 74 ht arg . default
0710: 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 ). (if (null? d
0720: 65 66 61 75 6c 74 29 0a 20 20 20 20 20 20 28 68 efault). (h
0730: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
0740: 66 61 75 6c 74 20 68 74 20 61 72 67 20 23 66 29 fault ht arg #f)
0750: 0a 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 . (hash-tab
0760: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 le-ref/default h
0770: 74 20 61 72 67 20 28 63 61 72 20 64 65 66 61 75 t arg (car defau
0780: 6c 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 lt))))..(define
0790: 28 72 65 6d 6f 76 65 2d 61 72 67 2d 66 72 6f 6d (remove-arg-from
07a0: 2d 68 74 20 61 72 67 29 0a 20 20 20 20 20 20 28 -ht arg). (
07b0: 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 hash-table-delet
07c0: 65 21 20 61 72 67 2d 68 61 73 68 20 61 72 67 29 e! arg-hash arg)
07d0: 0a 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 .)..(define (get
07e0: 2d 61 72 67 73 20 61 72 67 73 20 70 61 72 61 6d -args args param
07f0: 73 20 73 77 69 74 63 68 65 73 20 61 72 67 2d 68 s switches arg-h
0800: 61 73 68 20 6e 75 6d 2d 6e 65 65 64 65 64 29 0a ash num-needed).
0810: 20 20 28 6c 65 74 2a 20 28 28 6e 75 6d 74 61 72 (let* ((numtar
0820: 67 73 20 28 6c 65 6e 67 74 68 20 61 72 67 73 29 gs (length args)
0830: 29 0a 09 20 28 61 64 6a 2d 6e 75 6d 2d 6e 65 65 ).. (adj-num-nee
0840: 64 65 64 20 28 69 66 20 6e 75 6d 2d 6e 65 65 64 ded (if num-need
0850: 65 64 20 28 2b 20 6e 75 6d 2d 6e 65 65 64 65 64 ed (+ num-needed
0860: 20 32 29 20 23 66 29 29 29 0a 20 20 20 20 28 69 2) #f))). (i
0870: 66 20 28 3c 20 6e 75 6d 74 61 72 67 73 20 28 69 f (< numtargs (i
0880: 66 20 61 64 6a 2d 6e 75 6d 2d 6e 65 65 64 65 64 f adj-num-needed
0890: 20 61 64 6a 2d 6e 75 6d 2d 6e 65 65 64 65 64 20 adj-num-needed
08a0: 32 29 29 0a 09 28 69 66 20 28 3e 3d 20 6e 75 6d 2))..(if (>= num
08b0: 2d 6e 65 65 64 65 64 20 31 29 0a 09 20 20 20 20 -needed 1)..
08c0: 28 75 73 61 67 65 20 22 4e 6f 20 61 72 67 75 6d (usage "No argum
08d0: 65 6e 74 73 20 70 72 6f 76 69 64 65 64 22 29 0a ents provided").
08e0: 09 20 20 20 20 27 28 29 29 0a 09 28 6c 65 74 20 . '())..(let
08f0: 6c 6f 6f 70 20 28 28 61 72 67 20 28 63 61 64 72 loop ((arg (cadr
0900: 20 61 72 67 73 29 29 0a 09 09 20 20 20 28 74 61 args))... (ta
0910: 69 6c 20 28 63 64 64 72 20 61 72 67 73 29 29 0a il (cddr args)).
0920: 09 09 20 20 20 28 72 65 6d 74 61 72 67 73 20 27 .. (remtargs '
0930: 28 29 29 29 0a 09 20 20 28 63 6f 6e 64 20 0a 09 ())).. (cond ..
0940: 20 20 20 28 28 6d 65 6d 62 65 72 20 61 72 67 20 ((member arg
0950: 70 61 72 61 6d 73 29 20 3b 3b 20 61 72 67 73 20 params) ;; args
0960: 77 69 74 68 20 70 61 72 61 6d 73 0a 09 20 20 20 with params..
0970: 20 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 20 (if (< (length
0980: 74 61 69 6c 29 20 31 29 0a 09 09 28 75 73 61 67 tail) 1)...(usag
0990: 65 20 22 70 61 72 61 6d 20 67 69 76 65 6e 20 77 e "param given w
09a0: 69 74 68 6f 75 74 20 61 72 67 75 6d 65 6e 74 20 ithout argument
09b0: 22 20 61 72 67 29 0a 09 09 28 6c 65 74 20 28 28 " arg)...(let ((
09c0: 76 61 6c 20 20 20 20 20 28 63 61 72 20 74 61 69 val (car tai
09d0: 6c 29 29 0a 09 09 20 20 20 20 20 20 28 6e 65 77 l))... (new
09e0: 74 61 69 6c 20 28 63 64 72 20 74 61 69 6c 29 29 tail (cdr tail))
09f0: 29 0a 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c )... (hash-tabl
0a00: 65 2d 73 65 74 21 20 61 72 67 2d 68 61 73 68 20 e-set! arg-hash
0a10: 61 72 67 20 76 61 6c 29 0a 09 09 20 20 28 69 66 arg val)... (if
0a20: 20 28 6e 75 6c 6c 3f 20 6e 65 77 74 61 69 6c 29 (null? newtail)
0a30: 20 72 65 6d 74 61 72 67 73 0a 09 09 20 20 20 20 remtargs...
0a40: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 (loop (car new
0a50: 74 61 69 6c 29 28 63 64 72 20 6e 65 77 74 61 69 tail)(cdr newtai
0a60: 6c 29 20 72 65 6d 74 61 72 67 73 29 29 29 29 29 l) remtargs)))))
0a70: 0a 09 20 20 20 28 28 6d 65 6d 62 65 72 20 61 72 .. ((member ar
0a80: 67 20 73 77 69 74 63 68 65 73 29 20 20 20 20 20 g switches)
0a90: 20 20 20 20 3b 3b 20 61 72 67 73 20 77 69 74 68 ;; args with
0aa0: 20 6e 6f 20 70 61 72 61 6d 73 20 28 69 2e 65 2e no params (i.e.
0ab0: 20 73 77 69 74 63 68 65 73 29 0a 09 20 20 20 20 switches)..
0ac0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
0ad0: 20 61 72 67 2d 68 61 73 68 20 61 72 67 20 23 74 arg-hash arg #t
0ae0: 29 0a 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c ).. (if (null
0af0: 3f 20 74 61 69 6c 29 20 72 65 6d 74 61 72 67 73 ? tail) remtargs
0b00: 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 ...(loop (car ta
0b10: 69 6c 29 28 63 64 72 20 74 61 69 6c 29 20 72 65 il)(cdr tail) re
0b20: 6d 74 61 72 67 73 29 29 29 0a 09 20 20 20 28 65 mtargs))).. (e
0b30: 6c 73 65 0a 09 20 20 20 20 28 69 66 20 28 6e 75 lse.. (if (nu
0b40: 6c 6c 3f 20 74 61 69 6c 29 28 61 70 70 65 6e 64 ll? tail)(append
0b50: 20 72 65 6d 74 61 72 67 73 20 28 6c 69 73 74 20 remtargs (list
0b60: 61 72 67 29 29 20 3b 3b 20 72 65 74 75 72 6e 20 arg)) ;; return
0b70: 74 68 65 20 6e 6f 6e 2d 75 73 65 64 20 61 72 67 the non-used arg
0b80: 73 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 74 s...(loop (car t
0b90: 61 69 6c 29 28 63 64 72 20 74 61 69 6c 29 28 61 ail)(cdr tail)(a
0ba0: 70 70 65 6e 64 20 72 65 6d 74 61 72 67 73 20 28 ppend remtargs (
0bb0: 6c 69 73 74 20 61 72 67 29 29 29 29 29 29 29 29 list arg))))))))
0bc0: 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 69 6e 65 . ))..(define
0bd0: 20 28 70 72 69 6e 74 2d 61 72 67 73 20 61 72 67 (print-args arg
0be0: 2d 68 61 73 68 29 0a 20 20 28 66 6f 72 2d 65 61 -hash). (for-ea
0bf0: 63 68 20 28 6c 61 6d 62 64 61 20 28 61 72 67 29 ch (lambda (arg)
0c00: 0a 09 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 .. (print "
0c10: 20 20 20 22 20 61 72 67 20 22 20 20 20 22 20 28 " arg " " (
0c20: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
0c30: 65 66 61 75 6c 74 20 61 72 67 2d 68 61 73 68 20 efault arg-hash
0c40: 61 72 67 20 23 66 29 29 29 0a 09 20 20 20 20 28 arg #f))).. (
0c50: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
0c60: 61 72 67 2d 68 61 73 68 29 29 29 0a 0a 28 64 65 arg-hash)))..(de
0c70: 66 69 6e 65 20 28 61 6e 79 2d 64 65 66 69 6e 65 fine (any-define
0c80: 64 3f 20 2e 20 61 72 67 73 29 0a 20 20 28 6e 6f d? . args). (no
0c90: 74 20 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 72 t (null? (filter
0ca0: 20 28 6c 61 6d 62 64 61 20 28 78 29 20 78 29 0a (lambda (x) x).
0cb0: 09 09 20 20 20 20 20 20 28 6d 61 70 20 67 65 74 .. (map get
0cc0: 2d 61 72 67 20 61 72 67 73 29 29 29 29 29 0a 0a -arg args)))))..
0cd0: 0a 29 0a .).