Artifact
49f133f318959c43a91f6e3ef3d69607a8e25d0d:
- File
srfi/s37/args-fold.sls
— part of check-in
[723d9456e8]
at
2018-12-09 15:41:45
on branch trunk
— fixed bug for in args-fold.sls thanks to anonymous
(user:
aldo
size: 1384)
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 28 63 29 ;; Copyright (c)
0010: 20 32 30 30 39 20 44 65 72 69 63 6b 20 45 64 64 2009 Derick Edd
0020: 69 6e 67 74 6f 6e 2e 20 20 41 6c 6c 20 72 69 67 ington. All rig
0030: 68 74 73 20 72 65 73 65 72 76 65 64 2e 0a 3b 3b hts reserved..;;
0040: 20 4c 69 63 65 6e 73 65 64 20 75 6e 64 65 72 20 Licensed under
0050: 61 6e 20 4d 49 54 2d 73 74 79 6c 65 20 6c 69 63 an MIT-style lic
0060: 65 6e 73 65 2e 20 20 4d 79 20 6c 69 63 65 6e 73 ense. My licens
0070: 65 20 69 73 20 69 6e 20 74 68 65 20 66 69 6c 65 e is in the file
0080: 0a 3b 3b 20 6e 61 6d 65 64 20 4c 49 43 45 4e 53 .;; named LICENS
0090: 45 20 66 72 6f 6d 20 74 68 65 20 6f 72 69 67 69 E from the origi
00a0: 6e 61 6c 20 63 6f 6c 6c 65 63 74 69 6f 6e 20 74 nal collection t
00b0: 68 69 73 20 66 69 6c 65 20 69 73 20 64 69 73 74 his file is dist
00c0: 72 69 62 75 74 65 64 0a 3b 3b 20 77 69 74 68 2e ributed.;; with.
00d0: 20 20 49 66 20 74 68 69 73 20 66 69 6c 65 20 69 If this file i
00e0: 73 20 72 65 64 69 73 74 72 69 62 75 74 65 64 20 s redistributed
00f0: 77 69 74 68 20 73 6f 6d 65 20 6f 74 68 65 72 20 with some other
0100: 63 6f 6c 6c 65 63 74 69 6f 6e 2c 20 6d 79 0a 3b collection, my.;
0110: 3b 20 6c 69 63 65 6e 73 65 20 6d 75 73 74 20 61 ; license must a
0120: 6c 73 6f 20 62 65 20 69 6e 63 6c 75 64 65 64 2e lso be included.
0130: 0a 0a 23 21 72 36 72 73 0a 28 6c 69 62 72 61 72 ..#!r6rs.(librar
0140: 79 20 28 73 72 66 69 20 73 33 37 20 61 72 67 73 y (srfi s37 args
0150: 2d 66 6f 6c 64 29 0a 20 20 28 65 78 70 6f 72 74 -fold). (export
0160: 0a 20 20 20 20 61 72 67 73 2d 66 6f 6c 64 0a 20 . args-fold.
0170: 20 20 20 28 72 65 6e 61 6d 65 20 28 6d 61 6b 65 (rename (make
0180: 2d 6f 70 74 69 6f 6e 20 6f 70 74 69 6f 6e 29 29 -option option))
0190: 0a 20 20 20 20 6f 70 74 69 6f 6e 3f 0a 20 20 20 . option?.
01a0: 20 6f 70 74 69 6f 6e 2d 6e 61 6d 65 73 0a 20 20 option-names.
01b0: 20 20 6f 70 74 69 6f 6e 2d 72 65 71 75 69 72 65 option-require
01c0: 64 2d 61 72 67 3f 0a 20 20 20 20 6f 70 74 69 6f d-arg?. optio
01d0: 6e 2d 6f 70 74 69 6f 6e 61 6c 2d 61 72 67 3f 0a n-optional-arg?.
01e0: 20 20 20 20 6f 70 74 69 6f 6e 2d 70 72 6f 63 65 option-proce
01f0: 73 73 6f 72 29 0a 20 20 28 69 6d 70 6f 72 74 20 ssor). (import
0200: 0a 20 20 20 20 28 72 6e 72 73 29 0a 20 20 20 20 . (rnrs).
0210: 28 73 72 66 69 20 70 72 69 76 61 74 65 20 69 6e (srfi private in
0220: 63 6c 75 64 65 29 29 0a 20 20 0a 20 20 0a 20 20 clude)). . .
0230: 28 64 65 66 69 6e 65 2d 72 65 63 6f 72 64 2d 74 (define-record-t
0240: 79 70 65 20 6f 70 74 69 6f 6e 0a 20 20 20 20 28 ype option. (
0250: 66 69 65 6c 64 73 20 0a 20 20 20 20 20 20 6e 61 fields . na
0260: 6d 65 73 20 72 65 71 75 69 72 65 64 2d 61 72 67 mes required-arg
0270: 3f 20 6f 70 74 69 6f 6e 61 6c 2d 61 72 67 3f 20 ? optional-arg?
0280: 70 72 6f 63 65 73 73 6f 72 29 0a 20 20 20 20 28 processor). (
0290: 70 72 6f 74 6f 63 6f 6c 20 0a 20 20 20 20 20 20 protocol .
02a0: 28 6c 61 6d 62 64 61 20 28 63 29 20 0a 20 20 20 (lambda (c) .
02b0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6e 20 (lambda (n
02c0: 72 61 20 6f 61 20 70 29 0a 20 20 20 20 20 20 20 ra oa p).
02d0: 20 20 20 28 69 66 20 28 61 6e 64 20 0a 20 20 20 (if (and .
02e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 6e (an
02f0: 64 20 28 6c 69 73 74 3f 20 6e 29 0a 20 20 20 20 d (list? n).
0300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0310: 20 28 70 6f 73 69 74 69 76 65 3f 20 28 6c 65 6e (positive? (len
0320: 67 74 68 20 6e 29 29 0a 20 20 20 20 20 20 20 20 gth n)).
0330: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6f (fo
0340: 72 2d 61 6c 6c 20 28 6c 61 6d 62 64 61 20 28 78 r-all (lambda (x
0350: 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ) .
0360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0370: 20 20 20 28 6f 72 20 28 61 6e 64 20 28 73 74 72 (or (and (str
0380: 69 6e 67 3f 20 78 29 20 28 70 6f 73 69 74 69 76 ing? x) (positiv
0390: 65 3f 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 e? (string-lengt
03a0: 68 20 78 29 29 29 20 0a 20 20 20 20 20 20 20 20 h x))) .
03b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
03c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 68 61 (cha
03d0: 72 3f 20 78 29 29 29 20 0a 20 20 20 20 20 20 20 r? x))) .
03e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
03f0: 20 20 20 20 20 20 20 6e 29 29 0a 20 20 20 20 20 n)).
0400: 20 20 20 20 20 20 20 20 20 20 20 28 62 6f 6f 6c (bool
0410: 65 61 6e 3f 20 72 61 29 0a 20 20 20 20 20 20 20 ean? ra).
0420: 20 20 20 20 20 20 20 20 20 28 62 6f 6f 6c 65 61 (boolea
0430: 6e 3f 20 6f 61 29 0a 20 20 20 20 20 20 20 20 20 n? oa).
0440: 20 20 20 20 20 20 20 28 6e 6f 74 20 28 61 6e 64 (not (and
0450: 20 72 61 20 6f 61 29 29 0a 20 20 20 20 20 20 20 ra oa)).
0460: 20 20 20 20 20 20 20 20 20 28 70 72 6f 63 65 64 (proced
0470: 75 72 65 3f 20 70 29 29 0a 20 20 20 20 20 20 20 ure? p)).
0480: 20 20 20 20 20 28 63 20 6e 20 72 61 20 6f 61 20 (c n ra oa
0490: 70 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 p). (
04a0: 61 73 73 65 72 74 69 6f 6e 2d 76 69 6f 6c 61 74 assertion-violat
04b0: 69 6f 6e 20 27 6f 70 74 69 6f 6e 20 22 69 6e 76 ion 'option "inv
04c0: 61 6c 69 64 20 61 72 67 75 6d 65 6e 74 73 22 20 alid arguments"
04d0: 6e 20 72 61 20 6f 61 20 70 29 29 29 29 29 29 0a n ra oa p)))))).
04e0: 0a 20 20 28 64 65 66 69 6e 65 20 61 72 67 73 2d . (define args-
04f0: 66 6f 6c 64 0a 20 20 20 20 28 6c 65 74 20 28 5b fold. (let ([
0500: 6f 70 74 69 6f 6e 20 6d 61 6b 65 2d 6f 70 74 69 option make-opti
0510: 6f 6e 5d 29 0a 20 20 20 20 20 20 28 69 6e 63 6c on]). (incl
0520: 75 64 65 2f 72 65 73 6f 6c 76 65 20 28 22 73 72 ude/resolve ("sr
0530: 66 69 22 20 22 73 33 37 22 29 20 22 73 72 66 69 fi" "s37") "srfi
0540: 2d 33 37 2d 72 65 66 65 72 65 6e 63 65 2e 73 63 -37-reference.sc
0550: 6d 22 29 0a 20 20 20 20 20 20 61 72 67 73 2d 66 m"). args-f
0560: 6f 6c 64 29 29 0a 29 0a old)).).