Thunderchez: Hex Artifact Content

Artifact fa14aa53689e6b93e886b58a3ac32626045323ac:

File srfi/s2/and-let.sls — part of check-in [cd7a31d87b] at 2017-05-03 18:01:41 on branch trunk — many fixes to usb.sls (user: aldo size: 1473)
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 32 20 61 6e 64 2d 6c  y (srfi s2 and-l
0150: 65 74 29 0a 20 20 28 65 78 70 6f 72 74 20 0a 20  et).  (export . 
0160: 20 20 20 61 6e 64 2d 6c 65 74 2a 29 0a 20 20 28     and-let*).  (
0170: 69 6d 70 6f 72 74 20 0a 20 20 20 20 28 72 6e 72  import .    (rnr
0180: 73 29 29 0a 20 20 0a 20 20 28 64 65 66 69 6e 65  s)).  .  (define
0190: 2d 73 79 6e 74 61 78 20 61 6e 64 2d 6c 65 74 2a  -syntax and-let*
01a0: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74  .    (lambda (st
01b0: 78 29 0a 20 20 20 20 20 20 28 64 65 66 69 6e 65  x).      (define
01c0: 20 28 67 65 74 2d 69 64 20 63 29 0a 20 20 20 20   (get-id c).    
01d0: 20 20 20 20 28 73 79 6e 74 61 78 2d 63 61 73 65      (syntax-case
01e0: 20 63 20 28 29 20 5b 28 76 61 72 20 65 78 70 72   c () [(var expr
01f0: 29 20 23 27 76 61 72 5d 20 5b 5f 20 23 66 5d 29  ) #'var] [_ #f])
0200: 29 0a 20 20 20 20 20 20 28 73 79 6e 74 61 78 2d  ).      (syntax-
0210: 63 61 73 65 20 73 74 78 20 28 29 0a 20 20 20 20  case stx ().    
0220: 20 20 20 20 5b 28 5f 20 28 63 6c 61 75 73 65 2a      [(_ (clause*
0230: 20 2e 2e 2e 29 20 62 6f 64 79 2a 20 2e 2e 2e 29   ...) body* ...)
0240: 0a 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d 61  .         (for-a
0250: 6c 6c 20 69 64 65 6e 74 69 66 69 65 72 3f 20 28  ll identifier? (
0260: 66 69 6c 74 65 72 20 76 61 6c 75 65 73 20 28 6d  filter values (m
0270: 61 70 20 67 65 74 2d 69 64 20 23 27 28 63 6c 61  ap get-id #'(cla
0280: 75 73 65 2a 20 2e 2e 2e 29 29 29 29 0a 20 20 20  use* ...)))).   
0290: 20 20 20 20 20 20 23 27 28 61 6e 64 2d 6c 65 74        #'(and-let
02a0: 2a 2d 63 6f 72 65 20 23 74 20 28 63 6c 61 75 73  *-core #t (claus
02b0: 65 2a 20 2e 2e 2e 29 20 62 6f 64 79 2a 20 2e 2e  e* ...) body* ..
02c0: 2e 29 5d 29 29 29 0a 20 20 0a 20 20 28 64 65 66  .)]))).  .  (def
02d0: 69 6e 65 2d 73 79 6e 74 61 78 20 61 6e 64 2d 6c  ine-syntax and-l
02e0: 65 74 2a 2d 63 6f 72 65 0a 20 20 20 20 28 6c 61  et*-core.    (la
02f0: 6d 62 64 61 20 28 73 74 78 29 0a 20 20 20 20 20  mbda (stx).     
0300: 20 28 73 79 6e 74 61 78 2d 63 61 73 65 20 73 74   (syntax-case st
0310: 78 20 28 29 0a 20 20 20 20 20 20 20 20 5b 28 6b  x ().        [(k
0320: 77 20 5f 20 28 5b 76 61 72 20 65 78 70 72 5d 20  w _ ([var expr] 
0330: 63 6c 61 75 73 65 2a 20 2e 2e 2e 29 20 62 6f 64  clause* ...) bod
0340: 79 2a 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20 20  y* ...).        
0350: 20 23 27 28 6c 65 74 20 28 5b 76 61 72 20 65 78   #'(let ([var ex
0360: 70 72 5d 29 0a 20 20 20 20 20 20 20 20 20 20 20  pr]).           
0370: 20 20 28 69 66 20 76 61 72 0a 20 20 20 20 20 20    (if var.      
0380: 20 20 20 20 20 20 20 20 20 28 6b 77 20 76 61 72           (kw var
0390: 20 28 63 6c 61 75 73 65 2a 20 2e 2e 2e 29 20 62   (clause* ...) b
03a0: 6f 64 79 2a 20 2e 2e 2e 29 0a 20 20 20 20 20 20  ody* ...).      
03b0: 20 20 20 20 20 20 20 20 20 23 66 29 29 5d 0a 20           #f))]. 
03c0: 20 20 20 20 20 20 20 5b 28 6b 77 20 5f 20 28 5b         [(kw _ ([
03d0: 65 78 70 72 5d 20 63 6c 61 75 73 65 2a 20 2e 2e  expr] clause* ..
03e0: 2e 29 20 62 6f 64 79 2a 20 2e 2e 2e 29 0a 20 20  .) body* ...).  
03f0: 20 20 20 20 20 20 20 23 27 28 6c 65 74 20 28 5b         #'(let ([
0400: 74 20 65 78 70 72 5d 29 0a 20 20 20 20 20 20 20  t expr]).       
0410: 20 20 20 20 20 20 28 69 66 20 74 0a 20 20 20 20        (if t.    
0420: 20 20 20 20 20 20 20 20 20 20 20 28 6b 77 20 74             (kw t
0430: 20 28 63 6c 61 75 73 65 2a 20 2e 2e 2e 29 20 62   (clause* ...) b
0440: 6f 64 79 2a 20 2e 2e 2e 29 0a 20 20 20 20 20 20  ody* ...).      
0450: 20 20 20 20 20 20 20 20 20 23 66 29 29 5d 0a 20           #f))]. 
0460: 20 20 20 20 20 20 20 5b 28 6b 77 20 5f 20 28 69         [(kw _ (i
0470: 64 20 63 6c 61 75 73 65 2a 20 2e 2e 2e 29 20 62  d clause* ...) b
0480: 6f 64 79 2a 20 2e 2e 2e 29 0a 20 20 20 20 20 20  ody* ...).      
0490: 20 20 20 28 6f 72 20 28 69 64 65 6e 74 69 66 69     (or (identifi
04a0: 65 72 3f 20 23 27 69 64 29 0a 20 20 20 20 20 20  er? #'id).      
04b0: 20 20 20 20 20 20 20 28 73 79 6e 74 61 78 2d 76         (syntax-v
04c0: 69 6f 6c 61 74 69 6f 6e 20 23 66 20 22 69 6e 76  iolation #f "inv
04d0: 61 6c 69 64 20 63 6c 61 75 73 65 22 20 73 74 78  alid clause" stx
04e0: 20 23 27 69 64 29 29 0a 20 20 20 20 20 20 20 20   #'id)).        
04f0: 20 23 27 28 69 66 20 69 64 0a 20 20 20 20 20 20   #'(if id.      
0500: 20 20 20 20 20 20 20 28 6b 77 20 69 64 20 28 63         (kw id (c
0510: 6c 61 75 73 65 2a 20 2e 2e 2e 29 20 62 6f 64 79  lause* ...) body
0520: 2a 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20 20 20  * ...).         
0530: 20 20 20 20 23 66 29 5d 0a 20 20 20 20 20 20 20      #f)].       
0540: 20 5b 28 6b 77 20 6c 61 73 74 20 28 29 20 62 6f   [(kw last () bo
0550: 64 79 2a 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20  dy* ...).       
0560: 20 20 28 69 66 20 28 70 6f 73 69 74 69 76 65 3f    (if (positive?
0570: 20 28 6c 65 6e 67 74 68 20 23 27 28 62 6f 64 79   (length #'(body
0580: 2a 20 2e 2e 2e 29 29 29 0a 20 20 20 20 20 20 20  * ...))).       
0590: 20 20 20 20 23 27 28 62 65 67 69 6e 20 62 6f 64      #'(begin bod
05a0: 79 2a 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20 20  y* ...).        
05b0: 20 20 20 23 27 6c 61 73 74 29 5d 29 29 29 0a 29     #'last)]))).)
05c0: 0a                                               .