suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

receive -> let-values

Browse Source 
svn: r8989
This commit is contained in:
Eli Barzilay 2008-03-16 15:28:42 +00:00
parent eb30bc7c88
commit e30a57b5a7
7 changed files with 91 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/srfi/1/filter.ss
View File

@ -36,8 +36,7 @@
(require mzlib/etc
srfi/optional
"predicate.ss"
srfi/8/receive)
"predicate.ss")
(provide filter
partition
@ -115,7 +114,7 @@
(if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists.
(let ((elt (car lis))
(tail (cdr lis)))
(receive (in out) (recur tail)
(let-values ([(in out) (recur tail)])
(if (pred elt)
(values (if (pair? out) (cons elt in) lis) out)
(values in (if (pair? in) (cons elt out) lis))))))))

17
collects/srfi/1/fold.ss
View File

@ -37,8 +37,7 @@
(require srfi/optional
"predicate.ss"
"selector.ss"
"util.ss"
srfi/8/receive)
"util.ss")
(provide (rename my-map map)
(rename my-for-each for-each)
@ -88,7 +87,7 @@
(check-arg procedure? kons 'fold)
(if (pair? lists)
(let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case
(receive (cars+ans cdrs) (%cars+cdrs+ lists ans)
(let-values ([(cars+ans cdrs) (%cars+cdrs+ lists ans)])
(if (null? cars+ans) ans ; Done.
(lp cdrs (apply kons cars+ans)))))
(let lp ((lis lis1) (ans knil)) ; Fast path
@ -158,11 +157,11 @@
(define (really-append-map who appender f lis1 lists)
(check-arg procedure? f 'who)
(if (pair? lists)
(receive (cars cdrs) (%cars+cdrs (cons lis1 lists))
(let-values ([(cars cdrs) (%cars+cdrs (cons lis1 lists))])
(if (null? cars) '()
(let recur ((cars cars) (cdrs cdrs))
(let ((vals (apply f cars)))
(receive (cars2 cdrs2) (%cars+cdrs cdrs)
(let-values ([(cars2 cdrs2) (%cars+cdrs cdrs)])
(if (null? cars2) vals
(appender vals (recur cars2 cdrs2))))))))
;; Fast path
@ -194,7 +193,7 @@
(if (pair? lists)
(let lp ((lis1 lis1) (lists lists))
(if (not (null-list? lis1))
(receive (heads tails) (%cars+cdrs/no-test lists)
(let-values ([(heads tails) (%cars+cdrs/no-test lists)])
(set-car! lis1 (apply f (car lis1) heads))
(lp (cdr lis1) tails))))
;; Fast path.
@ -206,7 +205,7 @@
(check-arg procedure? f 'filter-map)
(if (pair? lists)
(let recur ((lists (cons lis1 lists)))
(receive (cars cdrs) (%cars+cdrs lists)
(let-values ([(cars cdrs) (%cars+cdrs lists)])
(if (pair? cars)
(cond ((apply f cars) => (lambda (x) (cons x (recur cdrs))))
(else (recur cdrs))) ; Tail call in this arm.
@ -226,7 +225,7 @@
(check-arg procedure? f 'map-in-order)
(if (pair? lists)
(let recur ((lists (cons lis1 lists)))
(receive (cars cdrs) (%cars+cdrs lists)
(let-values ([(cars cdrs) (%cars+cdrs lists)])
(if (pair? cars)
(let ((x (apply f cars))) ; Do head first,
(cons x (recur cdrs))) ; then tail.
@ -250,7 +249,7 @@
(check-arg procedure? f for-each)
(if (pair? lists)
(let recur ((lists (cons lis1 lists)))
(receive (cars cdrs) (%cars+cdrs lists)
(let-values ([(cars cdrs) (%cars+cdrs lists)])
(if (pair? cars)
(begin
(apply f cars) ; Do head first,

7
collects/srfi/1/lset.ss
View File

@ -40,8 +40,7 @@
(rename "search.ss" s:member member)
"delete.ss"
"predicate.ss"
"filter.ss"
srfi/8/receive)
"filter.ss")
(provide lset<=
lset=
@ -178,7 +177,7 @@
;; built in.
;; Compute a-b and a^b, then compute b-(a^b) and
;; cons it onto the front of a-b.
(receive (a-b a-int-b) (lset-diff+intersection = a b)
(let-values ([(a-b a-int-b) (lset-diff+intersection = a b)])
(cond ((null? a-b) (lset-difference = b a))
((null? a-int-b) (append b a))
(else (fold (lambda (xb ans)
@ -199,7 +198,7 @@
;; built in.
;; Compute a-b and a^b, then compute b-(a^b) and
;; cons it onto the front of a-b.
(receive (a-b a-int-b) (lset-diff+intersection! = a b)
(let-values ([(a-b a-int-b) (lset-diff+intersection! = a b)])
(cond ((null? a-b) (lset-difference! = b a))
((null? a-int-b) (append! b a))
(else (pair-fold

13
collects/srfi/1/misc.ss
View File

@ -39,8 +39,7 @@
"selector.ss"
"util.ss"
(only "fold.ss" reduce-right)
(rename "fold.ss" srfi-1:map map)
srfi/8/receive)
(rename "fold.ss" srfi-1:map map))
(provide length+
concatenate
@ -65,7 +64,7 @@
;; N-ary case
(let lp ((list1 list1) (lists lists) (i 0))
(if (null-list? list1) i
(receive (as ds) (%cars+cdrs lists)
(let-values ([(as ds) (%cars+cdrs lists)])
(if (null? as) i
(lp (cdr list1) ds
(if (apply pred (car list1) as) (+ i 1) i))))))
@ -98,7 +97,7 @@
(let recur ((lis lis))
(if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle
(let ((elt (car lis))) ; dotted lists.
(receive (a b) (recur (cdr lis))
(let-values ([(a b) (recur (cdr lis))])
(values (cons (car elt) a)
(cons (cadr elt) b)))))))
@ -106,7 +105,7 @@
(let recur ((lis lis))
(if (null-list? lis) (values lis lis lis)
(let ((elt (car lis)))
(receive (a b c) (recur (cdr lis))
(let-values ([(a b c) (recur (cdr lis))])
(values (cons (car elt) a)
(cons (cadr elt) b)
(cons (caddr elt) c)))))))
@ -115,7 +114,7 @@
(let recur ((lis lis))
(if (null-list? lis) (values lis lis lis lis)
(let ((elt (car lis)))
(receive (a b c d) (recur (cdr lis))
(let-values ([(a b c d) (recur (cdr lis))])
(values (cons (car elt) a)
(cons (cadr elt) b)
(cons (caddr elt) c)
@ -125,7 +124,7 @@
(let recur ((lis lis))
(if (null-list? lis) (values lis lis lis lis lis)
(let ((elt (car lis)))
(receive (a b c d e) (recur (cdr lis))
(let-values ([(a b c d e) (recur (cdr lis))])
(values (cons (car elt) a)
(cons (cadr elt) b)
(cons (caddr elt) c)

15
collects/srfi/1/search.ss
View File

@ -37,8 +37,7 @@
(require mzlib/etc
srfi/optional
"predicate.ss"
"util.ss"
srfi/8/receive)
"util.ss")
(provide (rename my-member member)
find
@ -107,7 +106,7 @@
(if (null-list? lis) (values '() '())
(let ((x (car lis)))
(if (pred x)
(receive (prefix suffix) (recur (cdr lis))
(let-values ([(prefix suffix) (recur (cdr lis))])
(values (cons x prefix) suffix))
(values '() lis))))))
@ -131,10 +130,10 @@
(check-arg procedure? pred 'any)
(if (pair? lists)
;; N-ary case
(receive (heads tails) (%cars+cdrs (cons lis1 lists))
(let-values ([(heads tails) (%cars+cdrs (cons lis1 lists))])
(and (pair? heads)
(let lp ((heads heads) (tails tails))
(receive (next-heads next-tails) (%cars+cdrs tails)
(let-values ([(next-heads next-tails) (%cars+cdrs tails)])
(if (pair? next-heads)
(or (apply pred heads) (lp next-heads next-tails))
(apply pred heads)))))) ; Last PRED app is tail call.
@ -155,10 +154,10 @@
(check-arg procedure? pred 'every)
(if (pair? lists)
;; N-ary case
(receive (heads tails) (%cars+cdrs (cons lis1 lists))
(let-values ([(heads tails) (%cars+cdrs (cons lis1 lists))])
(or (not (pair? heads))
(let lp ((heads heads) (tails tails))
(receive (next-heads next-tails) (%cars+cdrs tails)
(let-values ([(next-heads next-tails) (%cars+cdrs tails)])
(if (pair? next-heads)
(and (apply pred heads) (lp next-heads next-tails))
(apply pred heads)))))) ; Last PRED app is tail call.
@ -174,7 +173,7 @@
(if (pair? lists)
;; N-ary case
(let lp ((lists (cons lis1 lists)) (n 0))
(receive (heads tails) (%cars+cdrs lists)
(let-values ([(heads tails) (%cars+cdrs lists)])
(and (pair? heads)
(if (apply pred heads) n
(lp tails (+ n 1))))))

5
collects/srfi/1/selector.ss
View File

@ -34,8 +34,7 @@
#lang mzscheme
(require srfi/optional
srfi/8/receive)
(require srfi/optional)
(provide first second
third fourth
@ -120,7 +119,7 @@
(check-arg integer? k 'split-at)
(let recur ((lis x) (k k))
(if (zero? k) (values '() lis)
(receive (prefix suffix) (recur (cdr lis) (- k 1))
(let-values ([(prefix suffix) (recur (cdr lis) (- k 1))])
(values (cons (car lis) prefix) suffix)))))
#;

27
collects/srfi/1/util.ss
View File

@ -36,8 +36,7 @@
(require srfi/optional
"predicate.ss"
"selector.ss"
srfi/8/receive)
"selector.ss")
(provide %cdrs
%cars+
@ -88,11 +87,11 @@
(lambda (abort)
(let recur ((lists lists))
(if (pair? lists)
(receive (list other-lists) (car+cdr lists)
(let-values ([(list other-lists) (car+cdr lists)])
(if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
(receive (a d) (car+cdr list)
(receive (cars cdrs) (recur other-lists)
(values (cons a cars) (cons d cdrs))))))
(let-values ([(a d) (car+cdr list)]
[(cars cdrs) (recur other-lists)])
(values (cons a cars) (cons d cdrs)))))
(values '() '()))))))
;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the
@ -102,21 +101,21 @@
(lambda (abort)
(let recur ((lists lists))
(if (pair? lists)
(receive (list other-lists) (car+cdr lists)
(let-values ([(list other-lists) (car+cdr lists)])
(if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
(receive (a d) (car+cdr list)
(receive (cars cdrs) (recur other-lists)
(values (cons a cars) (cons d cdrs))))))
(let-values ([(a d) (car+cdr list)]
[(cars cdrs) (recur other-lists)])
(values (cons a cars) (cons d cdrs)))))
(values (list cars-final) '()))))))
;; Like %CARS+CDRS, but blow up if any list is empty.
(define (%cars+cdrs/no-test lists)
(let recur ((lists lists))
(if (pair? lists)
(receive (list other-lists) (car+cdr lists)
(receive (a d) (car+cdr list)
(receive (cars cdrs) (recur other-lists)
(values (cons a cars) (cons d cdrs)))))
(let*-values ([(list other-lists) (car+cdr lists)]
[(a d) (car+cdr list)]
[(cars cdrs) (recur other-lists)])
(values (cons a cars) (cons d cdrs)))
(values '() '()))))
;;; util.ss ends here