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

11
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,10 +114,10 @@
(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)
(if (pred elt)
(values (if (pair? out) (cons elt in) lis) out)
(values in (if (pair? in) (cons elt out) lis))))))))
(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))))))))
;; This implementation of PARTITION!
;; - doesn't cons, and uses no stack;

59
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,9 +87,9 @@
(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)
(if (null? cars+ans) ans ; Done.
(lp cdrs (apply kons cars+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
(if (null-list? lis) ans
(lp (cdr lis) (kons (car lis) ans))))))
@ -158,13 +157,13 @@
(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))
(if (null? cars) '()
(let recur ((cars cars) (cdrs cdrs))
(let ((vals (apply f cars)))
(receive (cars2 cdrs2) (%cars+cdrs cdrs)
(if (null? cars2) vals
(appender vals (recur cars2 cdrs2))))))))
(let-values ([(cars cdrs) (%cars+cdrs (cons lis1 lists))])
(if (null? cars) '()
(let recur ((cars cars) (cdrs cdrs))
(let ((vals (apply f cars)))
(let-values ([(cars2 cdrs2) (%cars+cdrs cdrs)])
(if (null? cars2) vals
(appender vals (recur cars2 cdrs2))))))))
;; Fast path
(if (null-list? lis1) '()
(let recur ((elt (car lis1)) (rest (cdr lis1)))
@ -194,9 +193,9 @@
(if (pair? lists)
(let lp ((lis1 lis1) (lists lists))
(if (not (null-list? lis1))
(receive (heads tails) (%cars+cdrs/no-test lists)
(set-car! lis1 (apply f (car lis1) heads))
(lp (cdr lis1) tails))))
(let-values ([(heads tails) (%cars+cdrs/no-test lists)])
(set-car! lis1 (apply f (car lis1) heads))
(lp (cdr lis1) tails))))
;; Fast path.
(pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
lis1)
@ -206,11 +205,11 @@
(check-arg procedure? f 'filter-map)
(if (pair? lists)
(let recur ((lists (cons lis1 lists)))
(receive (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.
'())))
(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.
'())))
;; Fast path.
(let recur ((lis lis1))
(if (null-list? lis) lis
@ -226,11 +225,11 @@
(check-arg procedure? f 'map-in-order)
(if (pair? lists)
(let recur ((lists (cons lis1 lists)))
(receive (cars cdrs) (%cars+cdrs lists)
(if (pair? cars)
(let ((x (apply f cars))) ; Do head first,
(cons x (recur cdrs))) ; then tail.
'())))
(let-values ([(cars cdrs) (%cars+cdrs lists)])
(if (pair? cars)
(let ((x (apply f cars))) ; Do head first,
(cons x (recur cdrs))) ; then tail.
'())))
;; Fast path.
(let recur ((lis lis1))
(if (null-list? lis) lis
@ -250,11 +249,11 @@
(check-arg procedure? f for-each)
(if (pair? lists)
(let recur ((lists (cons lis1 lists)))
(receive (cars cdrs) (%cars+cdrs lists)
(if (pair? cars)
(begin
(apply f cars) ; Do head first,
(recur cdrs))))) ; then tail.
(let-values ([(cars cdrs) (%cars+cdrs lists)])
(if (pair? cars)
(begin
(apply f cars) ; Do head first,
(recur cdrs))))) ; then tail.
;; Fast path.
(let recur ((lis lis1))
(if (not (null-list? lis))

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

47
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,10 +64,10 @@
;; N-ary case
(let lp ((list1 list1) (lists lists) (i 0))
(if (null-list? list1) i
(receive (as ds) (%cars+cdrs lists)
(if (null? as) i
(lp (cdr list1) ds
(if (apply pred (car list1) as) (+ i 1) i))))))
(let-values ([(as ds) (%cars+cdrs lists)])
(if (null? as) i
(lp (cdr list1) ds
(if (apply pred (car list1) as) (+ i 1) i))))))
;; Fast path
(let lp ((lis list1) (i 0))
(if (null-list? lis) i
@ -98,39 +97,39 @@
(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))
(values (cons (car elt) a)
(cons (cadr elt) b)))))))
(let-values ([(a b) (recur (cdr lis))])
(values (cons (car elt) a)
(cons (cadr elt) b)))))))
(define (unzip3 lis)
(let recur ((lis lis))
(if (null-list? lis) (values lis lis lis)
(let ((elt (car lis)))
(receive (a b c) (recur (cdr lis))
(values (cons (car elt) a)
(cons (cadr elt) b)
(cons (caddr elt) c)))))))
(let-values ([(a b c) (recur (cdr lis))])
(values (cons (car elt) a)
(cons (cadr elt) b)
(cons (caddr elt) c)))))))
(define (unzip4 lis)
(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))
(values (cons (car elt) a)
(cons (cadr elt) b)
(cons (caddr elt) c)
(cons (cadddr elt) d)))))))
(let-values ([(a b c d) (recur (cdr lis))])
(values (cons (car elt) a)
(cons (cadr elt) b)
(cons (caddr elt) c)
(cons (cadddr elt) d)))))))
(define (unzip5 lis)
(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))
(values (cons (car elt) a)
(cons (cadr elt) b)
(cons (caddr elt) c)
(cons (cadddr elt) d)
(cons (car (cddddr elt)) e)))))))
(let-values ([(a b c d e) (recur (cdr lis))])
(values (cons (car elt) a)
(cons (cadr elt) b)
(cons (caddr elt) c)
(cons (cadddr elt) d)
(cons (car (cddddr elt)) e)))))))
;; append! append-reverse append-reverse! concatenate concatenate!
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

29
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,8 +106,8 @@
(if (null-list? lis) (values '() '())
(let ((x (car lis)))
(if (pred x)
(receive (prefix suffix) (recur (cdr lis))
(values (cons x prefix) suffix))
(let-values ([(prefix suffix) (recur (cdr lis))])
(values (cons x prefix) suffix))
(values '() lis))))))
#;
@ -131,13 +130,13 @@
(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)
(if (pair? next-heads)
(or (apply pred heads) (lp next-heads next-tails))
(apply pred heads)))))) ; Last PRED app is tail call.
(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.
;; Fast path
(and (not (null-list? lis1))
(let lp ((head (car lis1)) (tail (cdr lis1)))
@ -155,13 +154,13 @@
(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)
(if (pair? next-heads)
(and (apply pred heads) (lp next-heads next-tails))
(apply pred heads)))))) ; Last PRED app is tail call.
(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.
;; Fast path
(or (null-list? lis1)
(let lp ((head (car lis1)) (tail (cdr lis1)))
@ -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))))))

7
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,8 +119,8 @@
(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))
(values (cons (car lis) prefix) suffix)))))
(let-values ([(prefix suffix) (recur (cdr lis) (- k 1))])
(values (cons (car lis) prefix) suffix)))))
#;
(define (split-at! x k)

29
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)
(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 ([(list other-lists) (car+cdr lists)])
(if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
(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