Free implementation of srfi/5

srfi-doc-nonfree/info.rkt

@@ -7,13 +7,11 @@
                      "base"
                      "scribble-lib"
                      "srfi-doc"
-                     "srfi-lib-nonfree"
                      "racket-doc"
                      "r5rs-doc"
                      "r6rs-doc"
                      "compatibility-lib"))
-(define update-implies '("srfi-lib-nonfree"))
 
-(define pkg-desc "documentation part of \"srfi nonfree\"")
+(define pkg-desc "non-free documentation for \"srfi-lib\"")
 
 (define pkg-authors '(mflatt noel chongkai jay))

srfi-doc-nonfree/srfi/scribblings/srfi-nf.scrbl

@@ -43,7 +43,8 @@ The following SRFI specification documents are licensed restrictively.
  (let #t "unnamed")
 )]
 
-Racket provides this SRFI in the @racket[srfi-lib-nonfree] package.
+Racket provides a free implementation of this SRFI in the @racket[srfi-lib] package.
+Only the SRFI specification document is nonfree.
 
 @; ----------------------------------------
 
@@ -59,7 +60,8 @@ Racket provides this SRFI in the @racket[srfi-lib-nonfree] package.
  (localized-template #f "localized-template")
 )]
 
-Racket provides a free implementation of this SRFI in the @racket[srfi-lib] package.  Only the SRFI specification document is nonfree.
+Racket provides a free implementation of this SRFI in the @racket[srfi-lib] package.
+Only the SRFI specification document is nonfree.
 
 @; ----------------------------------------
 

srfi-doc/srfi/scribblings/util.rkt

@@ -26,7 +26,7 @@
                  [sub (if subdir? (format "srfi-~a/" num) "")]
                  [url (λ (b) (format "~a/srfi-std/~asrfi-~a.html" b sub num))])
             (cond-element
-              [(or latex text) @link[(url "http://docs.racket-lang.org") label]]
+              [(or latex text) @link[(url "https://docs.racket-lang.org") label]]
               [else @link[(url ".") label]]))))]
    [(_ num . title) #'(srfi num #:subdir #f . title)]))
 

srfi-lib-nonfree/info.rkt

@@ -2,13 +2,6 @@
 
 (define collection 'multi)
 
-(define deps '("scheme-lib"
-               "base"
-               "r6rs-lib"
-               "srfi-lib"
-               "compatibility-lib"))
-
-
-(define pkg-desc "implementation (no documentation) part of \"srfi nonfree\"")
+(define pkg-desc "deprecated; use \"srfi-lib\"")
 
 (define pkg-authors '(mflatt noel chongkai jay))

srfi-lib/srfi/5/let.rkt

@@ -0,0 +1,57 @@
+#lang racket/base
+
+(require (for-syntax racket/base
+                     syntax/parse))
+(provide s:let)
+
+(define-syntax (s:let stx)
+  (define-syntax-class loopid
+    #:description "loop identifier"
+    (pattern :id))
+  (define-syntax-class binding-pair
+    #:description "binding pair"
+    (pattern [name:id arg:expr]))
+  (define-syntax-class rest-binding
+    #:description "\"rest\" binding"
+    (pattern [rest-name:id rest-arg:expr ...]))
+  (define-splicing-syntax-class let-style-bindings
+    #:description "let-style bindings"
+    #:attributes (loop* [name 1] [arg 1] rest-name [rest-arg 1])
+    ;; in let-style bindings, rest-binding only allowed w/
+    ;; at least one binding-pair
+    (pattern (~seq (~optional loop*:loopid)
+                   (:binding-pair ...))
+             #:with (rest-arg ...) #'()
+             #:attr rest-name #f)
+    (pattern (~seq (~optional loop*:loopid)
+                   (:binding-pair ...+ . :rest-binding))))
+  (define-splicing-syntax-class define-style-bindings
+    #:description "define-style bindings"
+    #:attributes (loop* [name 1] [arg 1] rest-name [rest-arg 1])
+    (pattern (~seq (loop*:loopid :binding-pair ...))
+             #:with (rest-arg ...) #'()
+             #:attr rest-name #f)
+    (pattern (~seq (loop*:loopid
+                    :binding-pair ...
+                    . :rest-binding))))
+  (define-splicing-syntax-class bindings
+    #:description #f
+    #:attributes (loop* [name 1] [arg 1] rest-name [rest-arg 1])
+    (pattern :let-style-bindings)
+    (pattern :define-style-bindings)) 
+  (syntax-parse stx
+    [(_ () body:expr ...+)
+     #'(let () body ...)]
+    [(_ :bindings
+        body:expr ...+)
+     #:fail-when (check-duplicate-identifier
+                  (syntax->list #'(name ... (~? rest-name))))
+     "duplicate variable name"
+     #:with loop (or (attribute loop*) #'tmp-loop)
+     #'(letrec ([loop (λ (~? (name ... . rest-name)
+                             (name ...))
+                        body ...)])
+         (loop arg ...  rest-arg ...))]))
+
+
+

srfi-test/tests/srfi/5/srfi-5-test.rkt

@@ -0,0 +1,122 @@
+#lang racket/base
+
+(require rackunit
+         syntax/macro-testing
+         (rename-in srfi/5
+                    [let s:let])
+         (rename-in racket/base
+                    [let standard-let]))
+
+(provide srfi-5-tests)
+
+(define srfi-5-tests
+  (test-suite
+   "srfi/5 let tests"
+   (test-case
+    "no loop"
+    (check-equal? (s:let () 5)
+                  5
+                  "no bindings")
+    (check-equal? (s:let ([x 5]) x)
+                  5
+                  "one binding: treated normally")
+    (check-equal? (s:let ([x 40][y 2]) (+ x y))
+                  42
+                  "two bindings: treated normally")
+    (check-equal? (s:let ([x 1] . [y 2])
+                         (cons x y))
+                  '(1 2)
+                  "rest binding w/ 1 value")
+    (check-equal? (s:let ([x 1] . [y 2 3])
+                         (cons x y))
+                  '(1 2 3)
+                  "rest binding w/ multiple values")
+    (check-exn exn:fail:syntax?
+               (λ () (convert-syntax-error (s:let ([x 1 2]) x)))
+               "rest binding alone is an error"))
+
+   (test-case
+    "let-style loop"
+    (check-equal? (s:let loop () 1)
+                  1
+                  "loop w/ no bindings is ok")
+    (check-equal? (s:let loop ([continue? #t])
+                         (if continue?
+                             (cons continue? (loop #f))
+                             (list continue?)))
+                  '(#t #f)
+                  "loop w/ 1 normal arg")
+    (check-equal? (s:let loop ([continue? #t]
+                               [x 1])
+                         (if continue?
+                             (cons x (loop #f 2))
+                             (list x)))
+                  '(1 2)
+                  "loop w/ 2 normal args")
+    (check-equal? (s:let loop ([continue? 0]
+                               . [args 'a])
+                         (case continue?
+                           [(0) (cons args (loop 1 'b))]
+                           [(1) (cons args (loop 2 'c 'd))]
+                           [else (list args)]))
+                  '((a) (b) (c d))
+                  "rest binding w/ 1 initial value")
+    (check-equal? (s:let loop ([continue? 0]
+                               . [args 'a 'a1 'a2])
+                         (case continue?
+                           [(0) (cons args (loop 1 'b))]
+                           [(1) (cons args (loop 2 'c 'd))]
+                           [else (list args)]))
+                  '((a a1 a2) (b) (c d))
+                  "rest binding w/ multiple initial values")
+    (check-exn exn:fail:syntax?
+               (λ () (convert-syntax-error (s:let loop ([x 1 2]) x)))
+               "rest binding alone is an error"))
+
+   (test-case
+    "define-style loop"
+    (check-equal? (s:let (loop) 1)
+                  1
+                  "loop w/ no bindings is ok")
+    (check-equal? (s:let (loop [continue? #t])
+                         (if continue?
+                             (cons continue? (loop #f))
+                             (list continue?)))
+                  '(#t #f)
+                  "loop w/ 1 normal arg")
+    (check-equal? (s:let (loop [continue? #t]
+                               [x 1])
+                         (if continue?
+                             (cons x (loop #f 2))
+                             (list x)))
+                  '(1 2)
+                  "loop w/ 2 normal args")
+    (check-equal? (s:let (loop [continue? 0]
+                               . [args 'a])
+                         (case continue?
+                           [(0) (cons args (loop 1 'b))]
+                           [(1) (cons args (loop 2 'c 'd))]
+                           [else (list args)]))
+                  '((a) (b) (c d))
+                  "rest binding w/ 1 initial value")
+    (check-equal? (s:let (loop [continue? 0]
+                               . [args 'a 'a1 'a2])
+                         (case continue?
+                           [(0) (cons args (loop 1 'b))]
+                           [(1) (cons args (loop 2 'c 'd))]
+                           [else (list args)]))
+                  '((a a1 a2) (b) (c d))
+                  "rest binding w/ multiple initial values")
+    (check-equal? (s:let (loop . [args 'a])
+                         (case args
+                           [((a)) (cons args (loop 'b))]
+                           [((b)) (cons args (loop 'c 'd))]
+                           [else (list args)]))
+                  '((a) (b) (c d))
+                  "define-style loop can have only rest arg"))
+
+   (check-exn exn:fail:syntax?
+              (λ ()
+                (convert-syntax-error
+                 (s:let a (b [x 1]) x)))
+              "combining let- and define- style loop names is an error")))

srfi-test/tests/srfi/all-srfi-tests.rkt

@@ -3,6 +3,7 @@
 (require "1/all-1-tests.rkt"
          "2/and-let-test.rkt"
          "4/srfi-4-test.rkt"
+         "5/srfi-5-test.rkt"
          "11/srfi-11-test.rkt"
          "13/string-test.rkt"
          "14/char-set-test.rkt"
@@ -25,4 +26,5 @@
    hash-tests
    srfi-4-tests
    srfi-11-tests
+   srfi-5-tests
    ))

srfi/info.rkt

@@ -3,11 +3,9 @@
 (define collection 'multi)
 
 (define deps '("srfi-lib"
-               "srfi-lib-nonfree"
                "srfi-doc"
                "srfi-doc-nonfree"))
 (define implies '("srfi-lib"
-                  "srfi-lib-nonfree"
                   "srfi-doc"
                   "srfi-doc-nonfree"))