Artifact e46cba7fac83bf9285467759f5a635e44b74c1ff:
- File srfi/private/let-opt.sls — part of check-in [80c8c83034] at 2016-07-07 18:11:39 on branch trunk — initial import (user: ovenpasta@pizzahack.eu size: 5369)
0000: 23 21 72 36 72 73 0a 3b 3b 3b 20 4c 45 54 2d 4f #!r6rs.;;; LET-O 0010: 50 54 49 4f 4e 41 4c 53 20 6d 61 63 72 6f 73 0a PTIONALS macros. 0020: 3b 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 28 63 ;;; Copyright (c 0030: 29 20 32 30 30 31 20 62 79 20 4f 6c 69 6e 20 53 ) 2001 by Olin S 0040: 68 69 76 65 72 73 2e 0a 0a 3b 3b 3b 20 43 6f 70 hivers...;;; Cop 0050: 79 72 69 67 68 74 20 28 63 29 20 31 39 39 33 2d yright (c) 1993- 0060: 32 30 30 33 20 52 69 63 68 61 72 64 20 4b 65 6c 2003 Richard Kel 0070: 73 65 79 20 61 6e 64 20 4a 6f 6e 61 74 68 61 6e sey and Jonathan 0080: 20 52 65 65 73 0a 3b 3b 3b 20 43 6f 70 79 72 69 Rees.;;; Copyri 0090: 67 68 74 20 28 63 29 20 31 39 39 34 2d 32 30 30 ght (c) 1994-200 00a0: 33 20 62 79 20 4f 6c 69 6e 20 53 68 69 76 65 72 3 by Olin Shiver 00b0: 73 20 61 6e 64 20 42 72 69 61 6e 20 44 2e 20 43 s and Brian D. C 00c0: 61 72 6c 73 74 72 6f 6d 2e 0a 3b 3b 3b 20 43 6f arlstrom..;;; Co 00d0: 70 79 72 69 67 68 74 20 28 63 29 20 31 39 39 39 pyright (c) 1999 00e0: 2d 32 30 30 33 20 62 79 20 4d 61 72 74 69 6e 20 -2003 by Martin 00f0: 47 61 73 62 69 63 68 6c 65 72 2e 0a 3b 3b 3b 20 Gasbichler..;;; 0100: 43 6f 70 79 72 69 67 68 74 20 28 63 29 20 32 30 Copyright (c) 20 0110: 30 31 2d 32 30 30 33 20 62 79 20 4d 69 63 68 61 01-2003 by Micha 0120: 65 6c 20 53 70 65 72 62 65 72 2e 0a 3b 3b 3b 0a el Sperber..;;;. 0130: 3b 3b 3b 20 41 6c 6c 20 72 69 67 68 74 73 20 72 ;;; All rights r 0140: 65 73 65 72 76 65 64 2e 0a 3b 3b 3b 0a 3b 3b 3b eserved..;;;.;;; 0150: 20 52 65 64 69 73 74 72 69 62 75 74 69 6f 6e 20 Redistribution 0160: 61 6e 64 20 75 73 65 20 69 6e 20 73 6f 75 72 63 and use in sourc 0170: 65 20 61 6e 64 20 62 69 6e 61 72 79 20 66 6f 72 e and binary for 0180: 6d 73 2c 20 77 69 74 68 20 6f 72 20 77 69 74 68 ms, with or with 0190: 6f 75 74 0a 3b 3b 3b 20 6d 6f 64 69 66 69 63 61 out.;;; modifica 01a0: 74 69 6f 6e 2c 20 61 72 65 20 70 65 72 6d 69 74 tion, are permit 01b0: 74 65 64 20 70 72 6f 76 69 64 65 64 20 74 68 61 ted provided tha 01c0: 74 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 t the following 01d0: 63 6f 6e 64 69 74 69 6f 6e 73 0a 3b 3b 3b 20 61 conditions.;;; a 01e0: 72 65 20 6d 65 74 3a 0a 3b 3b 3b 20 31 2e 20 52 re met:.;;; 1. R 01f0: 65 64 69 73 74 72 69 62 75 74 69 6f 6e 73 20 6f edistributions o 0200: 66 20 73 6f 75 72 63 65 20 63 6f 64 65 20 6d 75 f source code mu 0210: 73 74 20 72 65 74 61 69 6e 20 74 68 65 20 61 62 st retain the ab 0220: 6f 76 65 20 63 6f 70 79 72 69 67 68 74 0a 3b 3b ove copyright.;; 0230: 3b 20 20 20 20 6e 6f 74 69 63 65 2c 20 74 68 69 ; notice, thi 0240: 73 20 6c 69 73 74 20 6f 66 20 63 6f 6e 64 69 74 s list of condit 0250: 69 6f 6e 73 20 61 6e 64 20 74 68 65 20 66 6f 6c ions and the fol 0260: 6c 6f 77 69 6e 67 20 64 69 73 63 6c 61 69 6d 65 lowing disclaime 0270: 72 2e 0a 3b 3b 3b 20 32 2e 20 52 65 64 69 73 74 r..;;; 2. Redist 0280: 72 69 62 75 74 69 6f 6e 73 20 69 6e 20 62 69 6e ributions in bin 0290: 61 72 79 20 66 6f 72 6d 20 6d 75 73 74 20 72 65 ary form must re 02a0: 70 72 6f 64 75 63 65 20 74 68 65 20 61 62 6f 76 produce the abov 02b0: 65 20 63 6f 70 79 72 69 67 68 74 0a 3b 3b 3b 20 e copyright.;;; 02c0: 20 20 20 6e 6f 74 69 63 65 2c 20 74 68 69 73 20 notice, this 02d0: 6c 69 73 74 20 6f 66 20 63 6f 6e 64 69 74 69 6f list of conditio 02e0: 6e 73 20 61 6e 64 20 74 68 65 20 66 6f 6c 6c 6f ns and the follo 02f0: 77 69 6e 67 20 64 69 73 63 6c 61 69 6d 65 72 20 wing disclaimer 0300: 69 6e 20 74 68 65 0a 3b 3b 3b 20 20 20 20 64 6f in the.;;; do 0310: 63 75 6d 65 6e 74 61 74 69 6f 6e 20 61 6e 64 2f cumentation and/ 0320: 6f 72 20 6f 74 68 65 72 20 6d 61 74 65 72 69 61 or other materia 0330: 6c 73 20 70 72 6f 76 69 64 65 64 20 77 69 74 68 ls provided with 0340: 20 74 68 65 20 64 69 73 74 72 69 62 75 74 69 6f the distributio 0350: 6e 2e 0a 3b 3b 3b 20 33 2e 20 54 68 65 20 6e 61 n..;;; 3. The na 0360: 6d 65 20 6f 66 20 74 68 65 20 61 75 74 68 6f 72 me of the author 0370: 73 20 6d 61 79 20 6e 6f 74 20 62 65 20 75 73 65 s may not be use 0380: 64 20 74 6f 20 65 6e 64 6f 72 73 65 20 6f 72 20 d to endorse or 0390: 70 72 6f 6d 6f 74 65 20 70 72 6f 64 75 63 74 73 promote products 03a0: 0a 3b 3b 3b 20 20 20 20 64 65 72 69 76 65 64 20 .;;; derived 03b0: 66 72 6f 6d 20 74 68 69 73 20 73 6f 66 74 77 61 from this softwa 03c0: 72 65 20 77 69 74 68 6f 75 74 20 73 70 65 63 69 re without speci 03d0: 66 69 63 20 70 72 69 6f 72 20 77 72 69 74 74 65 fic prior writte 03e0: 6e 20 70 65 72 6d 69 73 73 69 6f 6e 2e 0a 3b 3b n permission..;; 03f0: 3b 0a 3b 3b 3b 20 54 48 49 53 20 53 4f 46 54 57 ;.;;; THIS SOFTW 0400: 41 52 45 20 49 53 20 50 52 4f 56 49 44 45 44 20 ARE IS PROVIDED 0410: 42 59 20 54 48 45 20 41 55 54 48 4f 52 53 20 60 BY THE AUTHORS ` 0420: 60 41 53 20 49 53 27 27 20 41 4e 44 20 41 4e 59 `AS IS'' AND ANY 0430: 20 45 58 50 52 45 53 53 20 4f 52 0a 3b 3b 3b 20 EXPRESS OR.;;; 0440: 49 4d 50 4c 49 45 44 20 57 41 52 52 41 4e 54 49 IMPLIED WARRANTI 0450: 45 53 2c 20 49 4e 43 4c 55 44 49 4e 47 2c 20 42 ES, INCLUDING, B 0460: 55 54 20 4e 4f 54 20 4c 49 4d 49 54 45 44 20 54 UT NOT LIMITED T 0470: 4f 2c 20 54 48 45 20 49 4d 50 4c 49 45 44 20 57 O, THE IMPLIED W 0480: 41 52 52 41 4e 54 49 45 53 0a 3b 3b 3b 20 4f 46 ARRANTIES.;;; OF 0490: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY 04a0: 20 41 4e 44 20 46 49 54 4e 45 53 53 20 46 4f 52 AND FITNESS FOR 04b0: 20 41 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 A PARTICULAR PU 04c0: 52 50 4f 53 45 20 41 52 45 20 44 49 53 43 4c 41 RPOSE ARE DISCLA 04d0: 49 4d 45 44 2e 0a 3b 3b 3b 20 49 4e 20 4e 4f 20 IMED..;;; IN NO 04e0: 45 56 45 4e 54 20 53 48 41 4c 4c 20 54 48 45 20 EVENT SHALL THE 04f0: 41 55 54 48 4f 52 53 20 42 45 20 4c 49 41 42 4c AUTHORS BE LIABL 0500: 45 20 46 4f 52 20 41 4e 59 20 44 49 52 45 43 54 E FOR ANY DIRECT 0510: 2c 20 49 4e 44 49 52 45 43 54 2c 0a 3b 3b 3b 20 , INDIRECT,.;;; 0520: 49 4e 43 49 44 45 4e 54 41 4c 2c 20 53 50 45 43 INCIDENTAL, SPEC 0530: 49 41 4c 2c 20 45 58 45 4d 50 4c 41 52 59 2c 20 IAL, EXEMPLARY, 0540: 4f 52 20 43 4f 4e 53 45 51 55 45 4e 54 49 41 4c OR CONSEQUENTIAL 0550: 20 44 41 4d 41 47 45 53 20 28 49 4e 43 4c 55 44 DAMAGES (INCLUD 0560: 49 4e 47 2c 20 42 55 54 0a 3b 3b 3b 20 4e 4f 54 ING, BUT.;;; NOT 0570: 20 4c 49 4d 49 54 45 44 20 54 4f 2c 20 50 52 4f LIMITED TO, PRO 0580: 43 55 52 45 4d 45 4e 54 20 4f 46 20 53 55 42 53 CUREMENT OF SUBS 0590: 54 49 54 55 54 45 20 47 4f 4f 44 53 20 4f 52 20 TITUTE GOODS OR 05a0: 53 45 52 56 49 43 45 53 3b 20 4c 4f 53 53 20 4f SERVICES; LOSS O 05b0: 46 20 55 53 45 2c 0a 3b 3b 3b 20 44 41 54 41 2c F USE,.;;; DATA, 05c0: 20 4f 52 20 50 52 4f 46 49 54 53 3b 20 4f 52 20 OR PROFITS; OR 05d0: 42 55 53 49 4e 45 53 53 20 49 4e 54 45 52 52 55 BUSINESS INTERRU 05e0: 50 54 49 4f 4e 29 20 48 4f 57 45 56 45 52 20 43 PTION) HOWEVER C 05f0: 41 55 53 45 44 20 41 4e 44 20 4f 4e 20 41 4e 59 AUSED AND ON ANY 0600: 0a 3b 3b 3b 20 54 48 45 4f 52 59 20 4f 46 20 4c .;;; THEORY OF L 0610: 49 41 42 49 4c 49 54 59 2c 20 57 48 45 54 48 45 IABILITY, WHETHE 0620: 52 20 49 4e 20 43 4f 4e 54 52 41 43 54 2c 20 53 R IN CONTRACT, S 0630: 54 52 49 43 54 20 4c 49 41 42 49 4c 49 54 59 2c TRICT LIABILITY, 0640: 20 4f 52 20 54 4f 52 54 0a 3b 3b 3b 20 28 49 4e OR TORT.;;; (IN 0650: 43 4c 55 44 49 4e 47 20 4e 45 47 4c 49 47 45 4e CLUDING NEGLIGEN 0660: 43 45 20 4f 52 20 4f 54 48 45 52 57 49 53 45 29 CE OR OTHERWISE) 0670: 20 41 52 49 53 49 4e 47 20 49 4e 20 41 4e 59 20 ARISING IN ANY 0680: 57 41 59 20 4f 55 54 20 4f 46 20 54 48 45 20 55 WAY OUT OF THE U 0690: 53 45 20 4f 46 0a 3b 3b 3b 20 54 48 49 53 20 53 SE OF.;;; THIS S 06a0: 4f 46 54 57 41 52 45 2c 20 45 56 45 4e 20 49 46 OFTWARE, EVEN IF 06b0: 20 41 44 56 49 53 45 44 20 4f 46 20 54 48 45 20 ADVISED OF THE 06c0: 50 4f 53 53 49 42 49 4c 49 54 59 20 4f 46 20 53 POSSIBILITY OF S 06d0: 55 43 48 20 44 41 4d 41 47 45 2e 0a 0a 3b 3b 3b UCH DAMAGE...;;; 06e0: 20 4d 61 64 65 20 69 6e 74 6f 20 61 6e 20 52 36 Made into an R6 06f0: 52 53 20 6c 69 62 72 61 72 79 20 62 79 20 44 65 RS library by De 0700: 72 69 63 6b 20 45 64 64 69 6e 67 74 6f 6e 2e 0a rick Eddington.. 0710: 0a 28 6c 69 62 72 61 72 79 20 28 73 72 66 69 20 .(library (srfi 0720: 70 72 69 76 61 74 65 20 6c 65 74 2d 6f 70 74 29 private let-opt) 0730: 0a 20 20 28 65 78 70 6f 72 74 0a 20 20 20 20 6c . (export. l 0740: 65 74 2d 6f 70 74 69 6f 6e 61 6c 73 2a 20 3a 6f et-optionals* :o 0750: 70 74 69 6f 6e 61 6c 29 0a 20 20 28 69 6d 70 6f ptional). (impo 0760: 72 74 0a 20 20 20 20 28 72 6e 72 73 29 29 0a 0a rt. (rnrs)).. 0770: 3b 3b 3b 20 28 3a 6f 70 74 69 6f 6e 61 6c 20 72 ;;; (:optional r 0780: 65 73 74 2d 61 72 67 20 64 65 66 61 75 6c 74 2d est-arg default- 0790: 65 78 70 20 5b 74 65 73 74 2d 70 72 65 64 5d 29 exp [test-pred]) 07a0: 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b .;;;;;;;;;;;;;;; 07b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 07c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 07d0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 07e0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 07f0: 0a 3b 3b 3b 20 54 68 69 73 20 66 6f 72 6d 20 69 .;;; This form i 0800: 73 20 66 6f 72 20 65 76 61 6c 75 61 74 69 6e 67 s for evaluating 0810: 20 6f 70 74 69 6f 6e 61 6c 20 61 72 67 75 6d 65 optional argume 0820: 6e 74 73 20 61 6e 64 20 74 68 65 69 72 20 64 65 nts and their de 0830: 66 61 75 6c 74 73 0a 3b 3b 3b 20 69 6e 20 73 69 faults.;;; in si 0840: 6d 70 6c 65 20 70 72 6f 63 65 64 75 72 65 73 20 mple procedures 0850: 74 68 61 74 20 74 61 6b 65 20 61 20 2a 73 69 6e that take a *sin 0860: 67 6c 65 2a 20 6f 70 74 69 6f 6e 61 6c 20 61 72 gle* optional ar 0870: 67 75 6d 65 6e 74 2e 20 49 74 20 69 73 0a 3b 3b gument. It is.;; 0880: 3b 20 61 20 6d 61 63 72 6f 20 73 6f 20 74 68 61 ; a macro so tha 0890: 74 20 74 68 65 20 64 65 66 61 75 6c 74 20 77 69 t the default wi 08a0: 6c 6c 20 6e 6f 74 20 62 65 20 63 6f 6d 70 75 74 ll not be comput 08b0: 65 64 20 75 6e 6c 65 73 73 20 69 74 20 69 73 20 ed unless it is 08c0: 6e 65 65 64 65 64 2e 0a 3b 3b 3b 20 0a 3b 3b 3b needed..;;; .;;; 08d0: 20 52 45 53 54 2d 41 52 47 20 69 73 20 61 20 72 REST-ARG is a r 08e0: 65 73 74 20 6c 69 73 74 20 66 72 6f 6d 20 61 20 est list from a 08f0: 6c 61 6d 62 64 61 20 2d 2d 20 65 2e 67 2e 2c 20 lambda -- e.g., 0900: 52 20 69 6e 0a 3b 3b 3b 20 20 20 20 20 28 6c 61 R in.;;; (la 0910: 6d 62 64 61 20 28 61 20 62 20 2e 20 72 29 20 2e mbda (a b . r) . 0920: 2e 2e 29 0a 3b 3b 3b 20 2d 20 49 66 20 52 45 53 ..).;;; - If RES 0930: 54 2d 41 52 47 20 68 61 73 20 30 20 65 6c 65 6d T-ARG has 0 elem 0940: 65 6e 74 73 2c 20 65 76 61 6c 75 61 74 65 20 44 ents, evaluate D 0950: 45 46 41 55 4c 54 2d 45 58 50 20 61 6e 64 20 72 EFAULT-EXP and r 0960: 65 74 75 72 6e 20 74 68 61 74 2e 0a 3b 3b 3b 20 eturn that..;;; 0970: 2d 20 49 66 20 52 45 53 54 2d 41 52 47 20 68 61 - If REST-ARG ha 0980: 73 20 31 20 65 6c 65 6d 65 6e 74 2c 20 72 65 74 s 1 element, ret 0990: 75 72 6e 20 74 68 61 74 20 65 6c 65 6d 65 6e 74 urn that element 09a0: 2e 0a 3b 3b 3b 20 2d 20 49 66 20 52 45 53 54 2d ..;;; - If REST- 09b0: 41 52 47 20 68 61 73 20 3e 31 20 65 6c 65 6d 65 ARG has >1 eleme 09c0: 6e 74 2c 20 65 72 72 6f 72 2e 0a 3b 3b 3b 0a 3b nt, error..;;;.; 09d0: 3b 3b 20 49 66 20 74 68 65 72 65 20 69 73 20 61 ;; If there is a 09e0: 6e 20 54 45 53 54 2d 50 52 45 44 20 66 6f 72 6d n TEST-PRED form 09f0: 2c 20 69 74 20 69 73 20 61 20 70 72 65 64 69 63 , it is a predic 0a00: 61 74 65 20 74 68 61 74 20 69 73 20 75 73 65 64 ate that is used 0a10: 20 74 6f 20 74 65 73 74 0a 3b 3b 3b 20 61 20 6e to test.;;; a n 0a20: 6f 6e 2d 64 65 66 61 75 6c 74 20 76 61 6c 75 65 on-default value 0a30: 2e 20 49 66 20 74 68 65 20 70 72 65 64 69 63 61 . If the predica 0a40: 74 65 20 72 65 74 75 72 6e 73 20 66 61 6c 73 65 te returns false 0a50: 2c 20 61 6e 20 65 72 72 6f 72 20 69 73 20 72 61 , an error is ra 0a60: 69 73 65 64 2e 0a 0a 28 64 65 66 69 6e 65 2d 73 ised...(define-s 0a70: 79 6e 74 61 78 20 3a 6f 70 74 69 6f 6e 61 6c 0a yntax :optional. 0a80: 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 (syntax-rules 0a90: 28 29 0a 20 20 20 20 28 5b 5f 20 72 65 73 74 20 (). ([_ rest 0aa0: 64 65 66 61 75 6c 74 2d 65 78 70 5d 0a 20 20 20 default-exp]. 0ab0: 20 20 28 6c 65 74 20 28 28 6d 61 79 62 65 2d 61 (let ((maybe-a 0ac0: 72 67 20 72 65 73 74 29 29 0a 20 20 20 20 20 20 rg rest)). 0ad0: 20 28 69 66 20 28 70 61 69 72 3f 20 6d 61 79 62 (if (pair? mayb 0ae0: 65 2d 61 72 67 29 0a 09 20 20 20 28 69 66 20 28 e-arg).. (if ( 0af0: 6e 75 6c 6c 3f 20 28 63 64 72 20 6d 61 79 62 65 null? (cdr maybe 0b00: 2d 61 72 67 29 29 20 28 63 61 72 20 6d 61 79 62 -arg)) (car mayb 0b10: 65 2d 61 72 67 29 0a 09 20 20 20 20 20 20 20 28 e-arg).. ( 0b20: 65 72 72 6f 72 20 27 3a 6f 70 74 69 6f 6e 61 6c error ':optional 0b30: 20 22 74 6f 6f 20 6d 61 6e 79 20 6f 70 74 69 6f "too many optio 0b40: 6e 61 6c 20 61 72 67 75 6d 65 6e 74 73 22 20 6d nal arguments" m 0b50: 61 79 62 65 2d 61 72 67 29 29 0a 09 20 20 20 64 aybe-arg)).. d 0b60: 65 66 61 75 6c 74 2d 65 78 70 29 29 29 0a 20 20 efault-exp))). 0b70: 20 20 28 5b 5f 20 72 65 73 74 20 64 65 66 61 75 ([_ rest defau 0b80: 6c 74 2d 65 78 70 20 61 72 67 2d 74 65 73 74 5d lt-exp arg-test] 0b90: 0a 20 20 20 20 20 28 6c 65 74 20 28 28 6d 61 79 . (let ((may 0ba0: 62 65 2d 61 72 67 20 72 65 73 74 29 29 0a 20 20 be-arg rest)). 0bb0: 20 20 20 20 20 28 69 66 20 28 70 61 69 72 3f 20 (if (pair? 0bc0: 6d 61 79 62 65 2d 61 72 67 29 0a 09 20 20 20 28 maybe-arg).. ( 0bd0: 69 66 20 28 6e 75 6c 6c 3f 20 28 63 64 72 20 6d if (null? (cdr m 0be0: 61 79 62 65 2d 61 72 67 29 29 0a 09 20 20 20 20 aybe-arg)).. 0bf0: 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 63 (let ((val (c 0c00: 61 72 20 6d 61 79 62 65 2d 61 72 67 29 29 29 0a ar maybe-arg))). 0c10: 09 09 20 28 69 66 20 28 61 72 67 2d 74 65 73 74 .. (if (arg-test 0c20: 20 76 61 6c 29 20 76 61 6c 0a 09 09 20 20 20 20 val) val... 0c30: 20 28 65 72 72 6f 72 20 27 3a 6f 70 74 69 6f 6e (error ':option 0c40: 61 6c 20 22 6f 70 74 69 6f 6e 61 6c 20 61 72 67 al "optional arg 0c50: 75 6d 65 6e 74 20 66 61 69 6c 65 64 20 74 65 73 ument failed tes 0c60: 74 22 20 76 61 6c 29 29 29 0a 09 20 20 20 20 20 t" val))).. 0c70: 20 20 28 65 72 72 6f 72 20 27 3a 6f 70 74 69 6f (error ':optio 0c80: 6e 61 6c 20 22 74 6f 6f 20 6d 61 6e 79 20 6f 70 nal "too many op 0c90: 74 69 6f 6e 61 6c 20 61 72 67 75 6d 65 6e 74 73 tional arguments 0ca0: 22 20 6d 61 79 62 65 2d 61 72 67 29 29 0a 09 20 " maybe-arg)).. 0cb0: 20 20 64 65 66 61 75 6c 74 2d 65 78 70 29 29 29 default-exp))) 0cc0: 29 29 0a 20 3b 20 65 72 75 74 63 75 72 74 73 2d )). ; erutcurts- 0cd0: 65 6e 69 66 65 64 0a 0a 3b 3b 3b 20 48 65 72 65 enifed..;;; Here 0ce0: 20 69 73 20 61 20 73 69 6d 70 6c 65 72 20 62 75 is a simpler bu 0cf0: 74 20 6c 65 73 73 2d 65 66 66 69 63 69 65 6e 74 t less-efficient 0d00: 20 76 65 72 73 69 6f 6e 20 6f 66 20 4c 45 54 2d version of LET- 0d10: 4f 50 54 49 4f 4e 41 4c 53 2a 2e 0a 3b 3b 3b 20 OPTIONALS*..;;; 0d20: 49 74 20 72 65 64 75 6e 64 61 6e 74 6c 79 20 70 It redundantly p 0d30: 65 72 66 6f 72 6d 73 20 65 6e 64 2d 6f 66 2d 6c erforms end-of-l 0d40: 69 73 74 20 63 68 65 63 6b 73 20 66 6f 72 20 65 ist checks for e 0d50: 76 65 72 79 20 6f 70 74 69 6f 6e 61 6c 20 76 61 very optional va 0d60: 72 2c 0a 3b 3b 3b 20 65 76 65 6e 20 61 66 74 65 r,.;;; even afte 0d70: 72 20 74 68 65 20 6c 69 73 74 20 72 75 6e 73 20 r the list runs 0d80: 6f 75 74 2e 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b out..;;;;;;;;;;; 0d90: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 0da0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 0db0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 0dc0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;; 0dd0: 3b 3b 3b 3b 0a 0a 28 64 65 66 69 6e 65 2d 73 79 ;;;;..(define-sy 0de0: 6e 74 61 78 20 6c 65 74 2d 6f 70 74 69 6f 6e 61 ntax let-optiona 0df0: 6c 73 2a 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 ls*. (syntax-ru 0e00: 6c 65 73 20 28 29 0a 20 20 20 20 28 28 6c 65 74 les (). ((let 0e10: 2d 6f 70 74 69 6f 6e 61 6c 73 2a 20 61 72 67 20 -optionals* arg 0e20: 28 6f 70 74 2d 63 6c 61 75 73 65 20 2e 2e 2e 29 (opt-clause ...) 0e30: 20 62 6f 64 79 20 2e 2e 2e 29 0a 20 20 20 20 20 body ...). 0e40: 28 6c 65 74 20 28 28 72 65 73 74 20 61 72 67 29 (let ((rest arg) 0e50: 29 0a 20 20 20 20 20 20 20 28 25 6c 65 74 2d 6f ). (%let-o 0e60: 70 74 69 6f 6e 61 6c 73 2a 20 72 65 73 74 20 28 ptionals* rest ( 0e70: 6f 70 74 2d 63 6c 61 75 73 65 20 2e 2e 2e 29 20 opt-clause ...) 0e80: 0a 09 09 09 28 6c 65 74 20 28 29 20 62 6f 64 79 ....(let () body 0e90: 20 2e 2e 2e 29 29 29 29 29 29 0a 0a 3b 3b 3b 20 ...))))))..;;; 0ea0: 54 68 65 20 61 72 67 2d 6c 69 73 74 20 65 78 70 The arg-list exp 0eb0: 72 65 73 73 69 6f 6e 20 2a 6d 75 73 74 2a 20 62 ression *must* b 0ec0: 65 20 61 20 76 61 72 69 61 62 6c 65 2e 0a 3b 3b e a variable..;; 0ed0: 3b 20 28 4f 72 20 6d 75 73 74 20 62 65 20 73 69 ; (Or must be si 0ee0: 64 65 2d 65 66 66 65 63 74 2d 66 72 65 65 2c 20 de-effect-free, 0ef0: 69 6e 20 61 6e 79 20 65 76 65 6e 74 2e 29 0a 0a in any event.).. 0f00: 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 25 (define-syntax % 0f10: 6c 65 74 2d 6f 70 74 69 6f 6e 61 6c 73 2a 0a 20 let-optionals*. 0f20: 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 (syntax-rules ( 0f30: 29 0a 20 20 20 20 28 28 25 6c 65 74 2d 6f 70 74 ). ((%let-opt 0f40: 69 6f 6e 61 6c 73 2a 20 61 72 67 20 28 28 28 76 ionals* arg (((v 0f50: 61 72 20 2e 2e 2e 29 20 78 70 61 72 73 65 72 29 ar ...) xparser) 0f60: 20 6f 70 74 2d 63 6c 61 75 73 65 20 2e 2e 2e 29 opt-clause ...) 0f70: 20 62 6f 64 79 20 2e 2e 2e 29 0a 20 20 20 20 20 body ...). 0f80: 28 63 61 6c 6c 2d 77 69 74 68 2d 76 61 6c 75 65 (call-with-value 0f90: 73 20 28 6c 61 6d 62 64 61 20 28 29 20 28 78 70 s (lambda () (xp 0fa0: 61 72 73 65 72 20 61 72 67 29 29 0a 20 20 20 20 arser arg)). 0fb0: 20 20 20 28 6c 61 6d 62 64 61 20 28 72 65 73 74 (lambda (rest 0fc0: 20 76 61 72 20 2e 2e 2e 29 0a 20 20 20 20 20 20 var ...). 0fd0: 20 20 20 28 25 6c 65 74 2d 6f 70 74 69 6f 6e 61 (%let-optiona 0fe0: 6c 73 2a 20 72 65 73 74 20 28 6f 70 74 2d 63 6c ls* rest (opt-cl 0ff0: 61 75 73 65 20 2e 2e 2e 29 20 62 6f 64 79 20 2e ause ...) body . 1000: 2e 2e 29 29 29 29 0a 20 20 20 20 0a 20 20 20 20 ..)))). . 1010: 28 28 25 6c 65 74 2d 6f 70 74 69 6f 6e 61 6c 73 ((%let-optionals 1020: 2a 20 61 72 67 20 28 28 76 61 72 20 64 65 66 61 * arg ((var defa 1030: 75 6c 74 29 20 6f 70 74 2d 63 6c 61 75 73 65 20 ult) opt-clause 1040: 2e 2e 2e 29 20 62 6f 64 79 20 2e 2e 2e 29 0a 20 ...) body ...). 1050: 20 20 20 20 28 63 61 6c 6c 2d 77 69 74 68 2d 76 (call-with-v 1060: 61 6c 75 65 73 20 28 6c 61 6d 62 64 61 20 28 29 alues (lambda () 1070: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 61 72 67 29 (if (null? arg) 1080: 20 28 76 61 6c 75 65 73 20 64 65 66 61 75 6c 74 (values default 1090: 20 27 28 29 29 0a 09 09 09 09 20 20 20 20 20 20 '())..... 10a0: 28 76 61 6c 75 65 73 20 28 63 61 72 20 61 72 67 (values (car arg 10b0: 29 20 28 63 64 72 20 61 72 67 29 29 29 29 0a 20 ) (cdr arg)))). 10c0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 76 (lambda (v 10d0: 61 72 20 72 65 73 74 29 0a 09 20 28 25 6c 65 74 ar rest).. (%let 10e0: 2d 6f 70 74 69 6f 6e 61 6c 73 2a 20 72 65 73 74 -optionals* rest 10f0: 20 28 6f 70 74 2d 63 6c 61 75 73 65 20 2e 2e 2e (opt-clause ... 1100: 29 20 62 6f 64 79 20 2e 2e 2e 29 29 29 29 0a 0a ) body ...)))).. 1110: 20 20 20 20 28 28 25 6c 65 74 2d 6f 70 74 69 6f ((%let-optio 1120: 6e 61 6c 73 2a 20 61 72 67 20 28 28 76 61 72 20 nals* arg ((var 1130: 64 65 66 61 75 6c 74 20 74 65 73 74 29 20 6f 70 default test) op 1140: 74 2d 63 6c 61 75 73 65 20 2e 2e 2e 29 20 62 6f t-clause ...) bo 1150: 64 79 20 2e 2e 2e 29 0a 20 20 20 20 20 28 63 61 dy ...). (ca 1160: 6c 6c 2d 77 69 74 68 2d 76 61 6c 75 65 73 20 28 ll-with-values ( 1170: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 28 69 lambda ().... (i 1180: 66 20 28 6e 75 6c 6c 3f 20 61 72 67 29 20 28 76 f (null? arg) (v 1190: 61 6c 75 65 73 20 64 65 66 61 75 6c 74 20 27 28 alues default '( 11a0: 29 29 0a 09 09 09 20 20 20 20 20 28 6c 65 74 20 )).... (let 11b0: 28 28 76 61 72 20 28 63 61 72 20 61 72 67 29 29 ((var (car arg)) 11c0: 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 20 ).... (if 11d0: 74 65 73 74 20 28 76 61 6c 75 65 73 20 76 61 72 test (values var 11e0: 20 28 63 64 72 20 61 72 67 29 29 0a 09 09 09 09 (cdr arg))..... 11f0: 20 20 20 28 65 72 72 6f 72 20 27 6c 65 74 2d 6f (error 'let-o 1200: 70 74 69 6f 6e 61 6c 73 2a 20 22 61 72 67 20 66 ptionals* "arg f 1210: 61 69 6c 65 64 20 4c 45 54 2d 4f 50 54 20 74 65 ailed LET-OPT te 1220: 73 74 22 20 76 61 72 29 29 29 29 29 0a 20 20 20 st" var))))). 1230: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 72 (lambda (var 1240: 20 72 65 73 74 29 0a 09 20 28 25 6c 65 74 2d 6f rest).. (%let-o 1250: 70 74 69 6f 6e 61 6c 73 2a 20 72 65 73 74 20 28 ptionals* rest ( 1260: 6f 70 74 2d 63 6c 61 75 73 65 20 2e 2e 2e 29 20 opt-clause ...) 1270: 62 6f 64 79 20 2e 2e 2e 29 29 29 29 0a 0a 20 20 body ...)))).. 1280: 20 20 28 28 25 6c 65 74 2d 6f 70 74 69 6f 6e 61 ((%let-optiona 1290: 6c 73 2a 20 61 72 67 20 28 28 76 61 72 20 64 65 ls* arg ((var de 12a0: 66 61 75 6c 74 20 74 65 73 74 20 73 75 70 70 6c fault test suppl 12b0: 69 65 64 3f 29 20 6f 70 74 2d 63 6c 61 75 73 65 ied?) opt-clause 12c0: 20 2e 2e 2e 29 20 62 6f 64 79 20 2e 2e 2e 29 0a ...) body ...). 12d0: 20 20 20 20 20 28 63 61 6c 6c 2d 77 69 74 68 2d (call-with- 12e0: 76 61 6c 75 65 73 20 28 6c 61 6d 62 64 61 20 28 values (lambda ( 12f0: 29 0a 09 09 09 20 28 69 66 20 28 6e 75 6c 6c 3f ).... (if (null? 1300: 20 61 72 67 29 20 28 76 61 6c 75 65 73 20 64 65 arg) (values de 1310: 66 61 75 6c 74 20 23 66 20 27 28 29 29 0a 09 09 fault #f '())... 1320: 09 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 72 . (let ((var 1330: 20 28 63 61 72 20 61 72 67 29 29 29 0a 09 09 09 (car arg))).... 1340: 20 20 20 20 20 20 20 28 69 66 20 74 65 73 74 20 (if test 1350: 28 76 61 6c 75 65 73 20 76 61 72 20 23 74 20 28 (values var #t ( 1360: 63 64 72 20 61 72 67 29 29 0a 09 09 09 09 20 20 cdr arg))..... 1370: 20 28 65 72 72 6f 72 20 27 6c 65 74 2d 6f 70 74 (error 'let-opt 1380: 69 6f 6e 61 6c 73 2a 20 22 61 72 67 20 66 61 69 ionals* "arg fai 1390: 6c 65 64 20 4c 45 54 2d 4f 50 54 20 74 65 73 74 led LET-OPT test 13a0: 22 20 76 61 72 29 29 29 29 29 0a 20 20 20 20 20 " var))))). 13b0: 20 20 28 6c 61 6d 62 64 61 20 28 76 61 72 20 73 (lambda (var s 13c0: 75 70 70 6c 69 65 64 3f 20 72 65 73 74 29 0a 09 upplied? rest).. 13d0: 20 28 25 6c 65 74 2d 6f 70 74 69 6f 6e 61 6c 73 (%let-optionals 13e0: 2a 20 72 65 73 74 20 28 6f 70 74 2d 63 6c 61 75 * rest (opt-clau 13f0: 73 65 20 2e 2e 2e 29 20 62 6f 64 79 20 2e 2e 2e se ...) body ... 1400: 29 29 29 29 0a 0a 20 20 20 20 28 28 25 6c 65 74 )))).. ((%let 1410: 2d 6f 70 74 69 6f 6e 61 6c 73 2a 20 61 72 67 20 -optionals* arg 1420: 28 72 65 73 74 29 20 62 6f 64 79 20 2e 2e 2e 29 (rest) body ...) 1430: 0a 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 . (let ((res 1440: 74 20 61 72 67 29 29 20 62 6f 64 79 20 2e 2e 2e t arg)) body ... 1450: 29 29 0a 0a 20 20 20 20 28 28 25 6c 65 74 2d 6f )).. ((%let-o 1460: 70 74 69 6f 6e 61 6c 73 2a 20 61 72 67 20 28 29 ptionals* arg () 1470: 20 62 6f 64 79 20 2e 2e 2e 29 0a 20 20 20 20 20 body ...). 1480: 28 69 66 20 28 6e 75 6c 6c 3f 20 61 72 67 29 20 (if (null? arg) 1490: 28 62 65 67 69 6e 20 62 6f 64 79 20 2e 2e 2e 29 (begin body ...) 14a0: 0a 09 20 28 65 72 72 6f 72 20 27 6c 65 74 2d 6f .. (error 'let-o 14b0: 70 74 69 6f 6e 61 6c 73 2a 20 22 74 6f 6f 20 6d ptionals* "too m 14c0: 61 6e 79 20 61 72 67 75 6d 65 6e 74 73 20 69 6e any arguments in 14d0: 20 6c 65 74 2d 6f 70 74 22 20 61 72 67 29 29 29 let-opt" arg))) 14e0: 29 29 0a 3b 20 65 72 75 74 63 75 72 74 73 2d 65 )).; erutcurts-e 14f0: 6e 69 66 65 64 0a 0a 29 0a nifed..).