From ef5f1e26c1d12819acf29d4d0381482d75c022be Mon Sep 17 00:00:00 2001 From: Chongkai Zhu Date: Thu, 23 Nov 2006 23:31:27 +0000 Subject: [PATCH] new SRFI 71 implementation svn: r4942 --- collects/srfi/71.ss | 13 ++ collects/srfi/71/letvalues.ss | 232 ++++++++++++++++++++++++++++++ collects/tests/srfi/load-srfis.ss | 2 + 3 files changed, 247 insertions(+) create mode 100644 collects/srfi/71.ss create mode 100644 collects/srfi/71/letvalues.ss diff --git a/collects/srfi/71.ss b/collects/srfi/71.ss new file mode 100644 index 0000000000..d4a5ff3329 --- /dev/null +++ b/collects/srfi/71.ss @@ -0,0 +1,13 @@ +;; module loader for SRFI-71 +(module |71| mzscheme + (require (lib "letvalues.ss" "srfi" "71")) + (provide (all-from-except (lib "letvalues.ss" "srfi" "71") + srfi-let + srfi-let* + srfi-letrec + srfi-letrec*) + (rename srfi-let let) + (rename srfi-let* let*) + (rename srfi-letrec letrec) + (rename srfi-letrec* letrec*))) + \ No newline at end of file diff --git a/collects/srfi/71/letvalues.ss b/collects/srfi/71/letvalues.ss new file mode 100644 index 0000000000..d18aae2604 --- /dev/null +++ b/collects/srfi/71/letvalues.ss @@ -0,0 +1,232 @@ +; Reference implementation of SRFI-71 using PLT 208's modules +; Sebastian.Egner@philips.com, 29-Apr-2005 + +(module letvalues mzscheme + + ;(provide (all-from-except mzscheme let let* letrec)) + + (provide srfi-let + srfi-let* + srfi-letrec + srfi-letrec* + uncons unlist unvector + values->list values->vector + uncons-2 uncons-3 uncons-4 + uncons-cons) + + ; --- textual copy of 'letvalues.scm' starts here --- + + ; Reference implementation of SRFI-71 (generic part) + ; Sebastian.Egner@philips.com, 20-May-2005, PLT 208 + ; + ; In order to avoid conflicts with the existing let etc. + ; the macros defined here are called srfi-let etc., + ; and they are defined in terms of r5rs-let etc. + ; It is up to the actual implementation to save let/*/rec + ; in r5rs-let/*/rec first and redefine let/*/rec + ; by srfi-let/*/rec then. + ; + ; There is also a srfi-letrec* being defined (in view of R6RS.) + ; + ; Macros used internally are named i:. + ; + ; Abbreviations for macro arguments: + ; bs - + ; b - component of a binding spec (values, , or ) + ; v - + ; vr - for rest list + ; x - + ; t - newly introduced temporary variable + ; vx - ( ) + ; rec - flag if letrec is produced (and not let) + ; cwv - call-with-value skeleton of the form (x formals) + ; (call-with-values (lambda () x) (lambda formals /payload/)) + ; where /payload/ is of the form (let (vx ...) body1 body ...). + ; + ; Remark (*): + ; We bind the variables of a letrec to i:undefined since there is + ; no portable (R5RS) way of binding a variable to a values that + ; raises an error when read uninitialized. + + (define i:undefined 'undefined) + + (define-syntax srfi-letrec* ; -> srfi-letrec + (syntax-rules () + ((srfi-letrec* () body1 body ...) + (srfi-letrec () body1 body ...)) + ((srfi-letrec* (bs) body1 body ...) + (srfi-letrec (bs) body1 body ...)) + ((srfi-letrec* (bs1 bs2 bs ...) body1 body ...) + (srfi-letrec (bs1) (srfi-letrec* (bs2 bs ...) body1 body ...))))) + + (define-syntax srfi-letrec ; -> i:let + (syntax-rules () + ((srfi-letrec ((b1 b2 b ...) ...) body1 body ...) + (i:let "bs" #t () () (body1 body ...) ((b1 b2 b ...) ...))))) + + (define-syntax srfi-let* ; -> srfi-let + (syntax-rules () + ((srfi-let* () body1 body ...) + (srfi-let () body1 body ...)) + ((srfi-let* (bs) body1 body ...) + (srfi-let (bs) body1 body ...)) + ((srfi-let* (bs1 bs2 bs ...) body1 body ...) + (srfi-let (bs1) (srfi-let* (bs2 bs ...) body1 body ...))))) + + (define-syntax srfi-let ; -> i:let or i:named-let + (syntax-rules () + ((srfi-let ((b1 b2 b ...) ...) body1 body ...) + (i:let "bs" #f () () (body1 body ...) ((b1 b2 b ...) ...))) + ((srfi-let tag ((b1 b2 b ...) ...) body1 body ...) + (i:named-let tag () (body1 body ...) ((b1 b2 b ...) ...))))) + + (define-syntax i:let + (syntax-rules (values) + + ; (i:let "bs" rec (cwv ...) (vx ...) body (bs ...)) + ; processes the binding specs bs ... by adding call-with-values + ; skeletons to cwv ... and bindings to vx ..., and afterwards + ; wrapping the skeletons around the payload (let (vx ...) . body). + + ; no more bs to process -> wrap call-with-values skeletons + ((i:let "bs" rec (cwv ...) vxs body ()) + (i:let "wrap" rec vxs body cwv ...)) + + ; recognize form1 without variable -> dummy binding for side-effects + ((i:let "bs" rec cwvs (vx ...) body (((values) x) bs ...)) + (i:let "bs" rec cwvs (vx ... (dummy (begin x #f))) body (bs ...))) + + ; recognize form1 with single variable -> just extend vx ... + ((i:let "bs" rec cwvs (vx ...) body (((values v) x) bs ...)) + (i:let "bs" rec cwvs (vx ... (v x)) body (bs ...))) + + ; recognize form1 without rest arg -> generate cwv + ((i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...)) + (i:let "form1" rec cwvs vxs body (bs ...) (x ()) (values v ...))) + + ; recognize form1 with rest arg -> generate cwv + ((i:let "bs" rec cwvs vxs body (((values . vs) x) bs ...)) + (i:let "form1+" rec cwvs vxs body (bs ...) (x ()) (values . vs))) + + ; recognize form2 with single variable -> just extend vx ... + ((i:let "bs" rec cwvs (vx ...) body ((v x) bs ...)) + (i:let "bs" rec cwvs (vx ... (v x)) body (bs ...))) + + ; recognize form2 with >=2 variables -> transform to form1 + ((i:let "bs" rec cwvs vxs body ((b1 b2 b3 b ...) bs ...)) + (i:let "form2" rec cwvs vxs body (bs ...) (b1 b2) (b3 b ...))) + + ; (i:let "form1" rec cwvs vxs body bss (x (t ...)) (values v1 v2 v ...)) + ; processes the variables in v1 v2 v ... adding them to (t ...) + ; and producing a cwv when finished. There is not rest argument. + + ((i:let "form1" rec (cwv ...) vxs body bss (x ts) (values)) + (i:let "bs" rec (cwv ... (x ts)) vxs body bss)) + ((i:let "form1" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v ...)) + (i:let "form1" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v ...))) + + ; (i:let "form1+" rec cwvs vxs body bss (x (t ...)) (values v ... . vr)) + ; processes the variables in v ... . vr adding them to (t ...) + ; and producing a cwv when finished. The rest arg is vr. + + ((i:let "form1+" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v2 . vs)) + (i:let "form1+" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v2 . vs))) + ((i:let "form1+" rec (cwv ...) (vx ...) body bss (x (t ...)) (values v1 . vr)) + (i:let "bs" rec (cwv ... (x (t ... t1 . tr))) (vx ... (v1 t1) (vr tr)) body bss)) + ((i:let "form1+" rec (cwv ...) (vx ...) body bss (x ()) (values . vr)) + (i:let "bs" rec (cwv ... (x tr)) (vx ... (vr tr)) body bss)) + + ; (i:let "form2" rec cwvs vxs body bss (v ...) (b ... x)) + ; processes the binding items (b ... x) from form2 as in + ; (v ... b ... x) into ((values v ... b ...) x), i.e. form1. + ; Then call "bs" recursively. + + ((i:let "form2" rec cwvs vxs body (bs ...) (v ...) (x)) + (i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...))) + ((i:let "form2" rec cwvs vxs body bss (v ...) (b1 b2 b ...)) + (i:let "form2" rec cwvs vxs body bss (v ... b1) (b2 b ...))) + + ; (i:let "wrap" rec ((v x) ...) (body ...) cwv ...) + ; wraps cwv ... around the payload generating the actual code. + ; For letrec this is of course different than for let. + + ((i:let "wrap" #f vxs body) + (let vxs . body)) + ((i:let "wrap" #f vxs body (x formals) cwv ...) + (call-with-values + (lambda () x) + (lambda formals (i:let "wrap" #f vxs body cwv ...)))) + + ((i:let "wrap" #t vxs body) + (letrec vxs . body)) + ((i:let "wrap" #t ((v t) ...) body cwv ...) + (let ((v i:undefined) ...) ; (*) + (i:let "wraprec" ((v t) ...) body cwv ...))) + + ; (i:let "wraprec" ((v t) ...) body cwv ...) + ; generate the inner code for a letrec. The variables v ... + ; are the user-visible variables (bound outside), and t ... + ; are the temporary variables bound by the cwv consumers. + + ((i:let "wraprec" ((v t) ...) (body ...)) + (begin (set! v t) ... (let () body ...))) + ((i:let "wraprec" vxs body (x formals) cwv ...) + (call-with-values + (lambda () x) + (lambda formals (i:let "wraprec" vxs body cwv ...)))) + + )) + + (define-syntax i:named-let + (syntax-rules (values) + + ; (i:named-let tag (vx ...) body (bs ...)) + ; processes the binding specs bs ... by extracting the variable + ; and expression, adding them to vx and turning the result into + ; an ordinary named let. + + ((i:named-let tag vxs body ()) + (let tag vxs . body)) + ((i:named-let tag (vx ...) body (((values v) x) bs ...)) + (i:named-let tag (vx ... (v x)) body (bs ...))) + ((i:named-let tag (vx ...) body ((v x) bs ...)) + (i:named-let tag (vx ... (v x)) body (bs ...))))) + + ; --- standard procedures --- + + (define (uncons pair) + (values (car pair) (cdr pair))) + + (define (uncons-2 list) + (values (car list) (cadr list) (cddr list))) + + (define (uncons-3 list) + (values (car list) (cadr list) (caddr list) (cdddr list))) + + (define (uncons-4 list) + (values (car list) (cadr list) (caddr list) (cadddr list) (cddddr list))) + + (define (uncons-cons alist) + (values (caar alist) (cdar alist) (cdr alist))) + + (define (unlist list) + (apply values list)) + + (define (unvector vector) + (apply values (vector->list vector))) + + ; --- standard macros --- + + (define-syntax values->list + (syntax-rules () + ((values->list x) + (call-with-values (lambda () x) list)))) + + (define-syntax values->vector + (syntax-rules () + ((values->vector x) + (call-with-values (lambda () x) vector)))) + + ; --- textual copy of 'letvalues.scm' ends here --- + + ) ; module letvalues diff --git a/collects/tests/srfi/load-srfis.ss b/collects/tests/srfi/load-srfis.ss index 7e6c36c5c8..b05d005892 100644 --- a/collects/tests/srfi/load-srfis.ss +++ b/collects/tests/srfi/load-srfis.ss @@ -34,6 +34,7 @@ (require (lib "66.ss" "srfi")) (require (lib "67.ss" "srfi")) (require (lib "69.ss" "srfi")) +(require (lib "71.ss" "srfi")) (require (lib "74.ss" "srfi")) (require (lib "78.ss" "srfi")) @@ -68,5 +69,6 @@ (require (lib "66.ss" "srfi" "66")) (require (lib "compare.ss" "srfi" "67")) (require (lib "hash.ss" "srfi" "69")) +(require (lib "letvalues.ss" "srfi" "71")) (require (lib "74.ss" "srfi" "74")) (require (lib "check.ss" "srfi" "78"))