srfi-1, fixed, for r6rs and r7rs

1 files changed, 138 insertions, 43 deletions

diff --git a/mcgoron/guix/srfi.scm b/mcgoron/guix/srfi.scm
index 0f9d71e..fb469ff 100644
--- a/mcgoron/guix/srfi.scm
+++ b/mcgoron/guix/srfi.scm
@@ -30,6 +30,67 @@
   #:use-module (mcgoron guix scheme-packages)
   #:use-module (guix gexp))
 
+(define srfi-1-exports
+  '(xcons make-list list-tabulate cons* list-copy
+          proper-list? circular-list? dotted-list? not-pair? null-list? list=
+          circular-list length+
+          iota
+          first second third fourth fifth sixth seventh eighth ninth tenth
+          car+cdr
+          take drop
+          take-right drop-right
+          take! drop-right!
+          split-at split-at!
+          last last-pair
+          zip unzip1 unzip2 unzip3 unzip4 unzip5
+          count
+          append! append-reverse append-reverse! concatenate concatenate!
+          unfold fold pair-fold reduce
+          unfold-right fold-right pair-fold-right reduce-right
+          append-map append-map! map! pair-for-each filter-map map-in-order
+          filter partition remove
+          filter! partition! remove!
+          find find-tail any every list-index
+          take-while drop-while take-while!
+          span break span! break!
+          delete delete!
+          alist-cons alist-copy
+          delete-duplicates delete-duplicates!
+          alist-delete alist-delete!
+          reverse!
+          lset<= lset= lset-adjoin
+          lset-union lset-intersection lset-difference lset-xor lset-diff+intersection
+          lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection!
+          map for-each member assoc))
+
+(define srfi-1-special-forms
+  ''(begin
+      (define-syntax let-optionals
+        (syntax-rules ()
+          ((_ expr ((v d) ... . tail) . body)
+           ($let-optionals (v ...) () (d ...) () f tail expr body))))
+      (define-syntax $let-optionals
+        (syntax-rules ()
+          ((_ () (vt ...) _ (cl ...) f tail expr body)
+           (letrec ((f (case-lambda cl ... ((vt ... . tail) . body))))
+             (apply f expr)))
+          ((_ (vrf . vr*) (vt ...) (df . dr*) (cl ...) f . tailexprbody)
+           ($let-optionals vr* (vt ... vrf) dr* (cl ... ((vt ...) (f vt ... df))) f . tailexprbody))))
+      (define-syntax receive
+        (syntax-rules ()
+          ((_ formals value body ...)
+           (let-values ((formals value)) body ...))))
+      (define-syntax :optional
+        (syntax-rules ()
+          ((_ x y) (if (null? x) y (car x)))))
+      (define (for-each f l1 . l-rest)
+        (let loop ((lists (cons l1 l-rest)))
+          (receive (cars cdrs) (%cars+cdrs lists)
+            (if (pair? cars)
+                (begin
+                  (apply f cars)
+                  (loop cdrs))))))))
+
 (define-public srfi-1-r7rs
   (package
    (name "srfi-1-r7rs")
@@ -53,54 +114,88 @@
 ")
    (arguments
     (list
+     #:imported-modules `(,@%copy-build-system-modules (mcgoron guix srfi-util))
      #:phases
      #~ (modify-phases %standard-phases
           (replace 'install
             (lambda* (#:key outputs #:allow-other-keys)
-              (use-modules (rnrs io ports))
+              (use-modules (mcgoron guix srfi-util))
               (let ((lib (string-append (assoc-ref %outputs "out")
                                         "/" #$r7rs-lib-dir
                                         "/srfi")))
                 (mkdir-p lib)
-                (with-output-to-file (string-append lib "/1.sld")
-                  (lambda ()
-                    (display "(define-library (srfi 1) (import (scheme base) (scheme cxr))\n")
-                    (write
-                     '(export
-                       xcons make-list list-tabulate cons* list-copy
-                       proper-list? circular-list? dotted-list? not-pair? null-list? list=
-                       circular-list length+
-                       iota
-                       first second third fourth fifth sixth seventh eighth ninth tenth
-                       car+cdr
-                       take drop
-                       take-right drop-right
-                       take! drop-right!
-                       split-at split-at!
-                       last last-pair
-                       zip unzip1 unzip2 unzip3 unzip4 unzip5
-                       count
-                       append! append-reverse append-reverse! concatenate concatenate!
-                       unfold fold pair-fold reduce
-                       unfold-right fold-right pair-fold-right reduce-right
-                       append-map append-map! map! pair-for-each filter-map map-in-order
-                       filter partition remove
-                       filter! partition! remove!
-                       find find-tail any every list-index
-                       take-while drop-while take-while!
-                       span break span! break!
-                       delete delete!
-                       alist-cons alist-copy
-                       delete-duplicates delete-duplicates!
-                       alist-delete alist-delete!
-                       reverse!
-                       lset<= lset= lset-adjoin
-                       lset-union lset-intersection lset-difference lset-xor lset-diff+intersection
-                       lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection!
-                       map for-each member assoc))
-                    (display "\n(begin\n")
-                    (do ((f (open-input-file "srfi-1-reference.scm"))
-                         (s "" (get-line f)))
-                        ((eof-object? s))
-                      (display s) (newline))
-                    (display "))\n")))))))))))
\ No newline at end of file
+                (splice-files (string-append lib "/1.sld")
+                              7
+                              '(srfi 1)
+                              '#$srfi-1-exports
+                              '((scheme base) (scheme cxr) (scheme case-lambda))
+                              '(define-syntax check-arg
+                                 (syntax-rules ()
+                                   ((_ pred val caller)
+                                    (let ((tmp val))
+                                      (if (pred val)
+                                          val
+                                          (error "Bad argument" 'pred
+                                                 tmp
+                                                 'caller))))))
+                              #$srfi-1-special-forms
+                              "srfi-1-reference.scm")))))))))
+
+(define-public srfi-1-r6rs
+  (package
+   (name "srfi-1-r6rs")
+   (version "errata-7")
+   (source
+    (origin (method git-fetch)
+            (uri (git-reference (url "https://github.com/scheme-requests-for-implementation/srfi-1")
+                                (commit "errata-7")))
+            (sha256 (base32 "18lj5y85zxs0yzkdv66qd290nwms7jy27ky1x3ba9kp6hzjia5kj"))))
+   (build-system copy-build-system)
+   (home-page "https://srfi.schemers.org/srfi-1")
+   (synopsis "List library (R6RS)")
+   (license (non-copyleft "//srfi.schemers.org/srfi-1/srfi-1.html"))
+   (inputs '())
+   (native-inputs '())
+   (description " R5RS Scheme has an impoverished set of list-processing utilities, which is a problem for authors of portable code. This SRFI proposes a coherent and comprehensive set of list-processing procedures; it is accompanied by a reference implementation of the spec. The reference implementation is
+
+    portable
+    efficient
+    completely open, public-domain source
+")
+   (arguments
+    (list
+     #:imported-modules `(,@%copy-build-system-modules (mcgoron guix srfi-util))
+     #:phases
+     #~ (modify-phases %standard-phases
+          (replace 'install
+            (lambda* (#:key outputs #:allow-other-keys)
+              (use-modules (mcgoron guix srfi-util))
+              (let ((lib (string-append (assoc-ref %outputs "out")
+                                        "/" #$r6rs-lib-dir
+                                        "/srfi")))
+                (mkdir-p lib)
+                (splice-files (string-append lib "/srfi-1.sls")
+                              6
+                              '(srfi srfi-1)
+                              '#$srfi-1-exports
+                              '((except (rename (rnrs base) (error %error))
+                                        map
+                                        for-each)
+                                (rnrs control)
+                                (except (rnrs lists) remove find partition filter fold-right cons* member assoc)
+                                (rnrs mutable-pairs) (rnrs r5rs))
+                              '(define-syntax check-arg
+                                 (syntax-rules ()
+                                   ((_ pred val caller)
+                                    (let ((tmp val))
+                                      (if (pred val)
+                                          val
+                                          (assertion-violation
+                                           'caller
+                                           "invalid argument"
+                                           val
+                                           'pred))))))
+                              '(define (error msg . irritants)
+                                 (apply %error #f msg irritants))
+                              #$srfi-1-special-forms
+                              "srfi-1-reference.scm")))))))))
\ No newline at end of file