Ticket #385: srfi26extension.patch
File srfi26extension.patch, 7.2 KB (added by , 14 years ago) 


chickensyntax.scm
diff git a/chickensyntax.scm b/chickensyntax.scm index f97c22a..16775c6 100644
a b 985 985 (lambda (form r c) 986 986 (let ((%<> (r '<>)) 987 987 (%<...> (r '<...>)) 988 (%apply (r 'apply))) 989 (let loop ([xs (cdr form)] [vars '()] [vals '()] [rest #f]) 990 (if (null? xs) 991 (let ([rvars (reverse vars)] 992 [rvals (reverse vals)] ) 993 (if rest 994 (let ([rv (r (gensym))]) 995 `(##core#lambda 996 (,@rvars . ,rv) 997 (,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) ) 998 `(##core#lambda ,rvars ((##core#begin ,(car rvals)) ,@(cdr rvals)) ) ) ) 999 (cond ((c %<> (car xs)) 1000 (let ([v (r (gensym))]) 1001 (loop (cdr xs) (cons v vars) (cons v vals) #f) ) ) 1002 ((c %<...> (car xs)) (loop '() vars vals #t)) 1003 (else (loop (cdr xs) vars (cons (car xs) vals) #f)) ) ) ) ) ))) 988 (%apply (r 'apply)) 989 (%append (r 'append)) 990 (%list (r 'list)) 991 (%reverse (r 'reverse))) 992 (when (null? (cdr form)) 993 (syntaxerror 'cut "You need to supply at least a procedure" form)) 994 (let loop ([xs (cdr form)] [vars '()] [vals '()] [vars2 '()] [vals2 '()] 995 [rest #f]) 996 (if (null? xs) 997 (let ([rvars (reverse vars)] 998 [rvals (reverse vals)] 999 [rvals2 (reverse vals2)]) 1000 (if rest 1001 (let ([rv (r (gensym))]) 1002 `(##core#lambda (,@rvars . ,rv) 1003 (,%apply 1004 (##core#lambda (,@vars2 . ,rv) 1005 (,%apply ,(car rvals) ,@(cdr rvals) 1006 (,%append (,%reverse ,rv) (,%list ,@rvals2)))) 1007 (,%reverse ,rv)) ) ) 1008 `(##core#lambda ,rvars ((##core#begin ,(car rvals)) ,@(cdr rvals)) ) ) ) 1009 (cond ((c %<> (car xs)) 1010 (let ([v (r (gensym))]) 1011 (if rest 1012 (loop (cdr xs) vars vals 1013 (cons v vars2) (cons v vals2) #t) 1014 (loop (cdr xs) (cons v vars) (cons v vals) '() '() #f)))) 1015 ((c %<...> (car xs)) 1016 (if rest 1017 (syntaxerror 'cut "Only one <...> is allowed" form) 1018 (loop (cdr xs) vars vals '() '() #t))) 1019 (else 1020 (if rest 1021 (loop (cdr xs) vars vals vars2 (cons (car xs) vals2) #t) 1022 (loop (cdr xs) vars (cons (car xs) vals) '() '() #f)))))))))) 1004 1023 1005 1024 (##sys#extendmacroenvironment 1006 1025 'cute … … 1009 1028 (lambda (form r c) 1010 1029 (let ((%apply (r 'apply)) 1011 1030 (%<> (r '<>)) 1012 (%<...> (r '<...>))) 1013 (let loop ([xs (cdr form)] [vars '()] [bs '()] [vals '()] [rest #f]) 1031 (%<...> (r '<...>)) 1032 (%append (r 'append)) 1033 (%list (r 'list)) 1034 (%reverse (r 'reverse))) 1035 (when (null? (cdr form)) 1036 (syntaxerror 'cute "You need to supply at least a procedure" form)) 1037 (let loop ([xs (cdr form)] [bs '()] [vars '()] [vals '()] 1038 [vars2 '()] [vals2 '()] [rest #f]) 1014 1039 (if (null? xs) 1015 1040 (let ([rvars (reverse vars)] 1016 [rvals (reverse vals)] ) 1041 [rvals (reverse vals)] 1042 [rvals2 (reverse vals2)]) 1017 1043 (if rest 1018 1044 (let ([rv (r (gensym))]) 1019 1045 `(##core#let 1020 1046 ,bs 1021 (##core#lambda (,@rvars . ,rv) 1022 (,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) ) ) 1047 (##core#lambda (,@rvars . ,rv) 1048 (,%apply 1049 (##core#lambda (,@vars2 . ,rv) 1050 (,%apply ,(car rvals) ,@(cdr rvals) 1051 (,%append (,%reverse ,rv) (,%list ,@rvals2)))) 1052 (,%reverse ,rv)) ) ) ) 1023 1053 `(##core#let ,bs 1024 1054 (##core#lambda ,rvars (,(car rvals) ,@(cdr rvals)) ) ) ) ) 1025 1055 (cond ((c %<> (car xs)) 1026 1056 (let ([v (r (gensym))]) 1027 (loop (cdr xs) (cons v vars) bs (cons v vals) #f) ) ) 1028 ((c %<...> (car xs)) (loop '() vars bs vals #t)) 1057 (if rest 1058 (loop (cdr xs) bs vars vals 1059 (cons v vars2) (cons v vals2) #t) 1060 (loop (cdr xs) bs (cons v vars) (cons v vals) 1061 '() '() #f)))) 1062 ((c %<...> (car xs)) 1063 (if rest 1064 (syntaxerror 'cut "Only one <...> is allowed" form) 1065 (loop (cdr xs) bs vars vals vars2 vals2 #t))) 1029 1066 (else 1030 1067 (let ([v (r (gensym))]) 1031 (loop (cdr xs) 1032 vars 1033 (cons (list v (car xs)) bs) 1034 (cons v vals) #f) ) )))))))) 1068 (if rest 1069 (loop (cdr xs) (cons (list v (car xs)) bs) 1070 vars vals vars2 (cons v vals2) #t) 1071 (loop (cdr xs) (cons (list v (car xs)) bs) 1072 vars (cons v vals) vars2 vals2 #f)) ) )))))))) 1035 1073 1036 1074 1037 1075 ;;; SRFI31 
tests/syntaxtests.scm
diff git a/tests/syntaxtests.scm b/tests/syntaxtests.scm index c210165..f8d857a 100644
a b 22 22 (t 3 3) 23 23 24 24 (f abc) 25 25 # 26 26 (f (t 3 4)) 27 27 28 28 ;; test syntaxrules … … 478 478 479 479 (import (prefix rfoo f:)) 480 480 (f:rbar 1) 481 # 482 ;;; SRFI26 483 484 ;; Cut 485 (t '() ((cut list))) 486 (t '() ((cut list <...>))) 487 (t '(1) ((cut list 1))) 488 (t '(1) ((cut list <>) 1)) 489 (t '(1) ((cut list <...>) 1)) 490 (t '(1 2) ((cut list 1 2))) 491 (t '(1 2) ((cut list 1 <>) 2)) 492 (t '(1 2) ((cut list 1 <...>) 2)) 493 (t '(1 2 3 4) ((cut list 1 <...>) 2 3 4)) 494 (t '(1 2 3 4) ((cut list 1 <> 3 <>) 2 4)) 495 (t '(1 2 3 4 5 6) ((cut list 1 <> 3 <...>) 2 4 5 6)) 496 (t '(ok) (let* ((x 'wrong) 497 (y (cut list x))) 498 (set! x 'ok) 499 (y))) 500 (t 2 (let ((a 0)) 501 (map (cut + (begin (set! a (+ a 1)) a) <>) 502 '(1 2)) 503 a)) 504 ;; Extensions 505 (t '(1) ((cut list <...> 1))) 506 (t '(1) ((cut list <...> <>) 1)) 507 (t '(1 2) ((cut list <...> 2) 1)) 508 (t '(1 2 3 4) ((cut list <...> 4) 1 2 3)) 509 (t '(1 2 3 4) ((cut list <...> 1 <> 3 <>) 2 4)) 510 (t '(1 2 3 4 5 6) ((cut list <...> 3 <> 5 <>) 1 2 4 6)) 511 (t '(ok) (let* ((x 'wrong) 512 (y (cut list <...> x))) 513 (set! x 'ok) 514 (y))) 515 (t 2 (let ((a 0)) 516 (map (cut + <...> (begin (set! a (+ a 1)) a) <>) 517 '(1 2)) 518 a)) 519 520 521 ;; Cute 522 (t '() ((cute list))) 523 (t '() ((cute list <...>))) 524 (t '(1) ((cute list 1))) 525 (t '(1) ((cute list <>) 1)) 526 (t '(1) ((cute list <...>) 1)) 527 (t '(1 2) ((cute list 1 2))) 528 (t '(1 2) ((cute list 1 <>) 2)) 529 (t '(1 2) ((cute list 1 <...>) 2)) 530 (t '(1 2 3 4) ((cute list 1 <...>) 2 3 4)) 531 (t '(1 2 3 4) ((cute list 1 <> 3 <>) 2 4)) 532 (t '(1 2 3 4 5 6) ((cute list 1 <> 3 <...>) 2 4 5 6)) 533 (t 1 (let ((a 0)) 534 (map (cute + (begin (set! a (+ a 1)) a) <>) 535 '(1 2)) 536 a)) 537 ;; Extensions 538 (t '(1) ((cute list <...> 1))) 539 (t '(1) ((cute list <...> <>) 1)) 540 (t '(1 2) ((cute list <...> 2) 1)) 541 (t '(1 2) ((cute list 1 <...>) 2)) 542 (t '(1 2 3 4) ((cute list <...> 4) 1 2 3)) 543 (t '(1 2 3 4) ((cute list <...> 1 <> 3 <>) 2 4)) 544 (t '(1 2 3 4 5 6) ((cute list <...> 3 <> 5 <>) 1 2 4 6)) 545 (t 1 (let ((a 0)) 546 (map (cute + <...> (begin (set! a (+ a 1)) a) <>) 547 '(1 2)) 548 a)) 549 No newline at end of file