Remove custom let*.

While it was nice, the most important part was the multi-valued let from
srfi-71 (which is implemented in srfi-71)). The minor pattern matching
structures could often be replaced with car+cdr, or a propper match.

4 files changed, 21 insertions, 76 deletions

diff --git a/module/hnh/util.scm b/module/hnh/util.scm
index 49fd6ebb..f95a24bf 100644
--- a/module/hnh/util.scm
+++ b/module/hnh/util.scm
@@ -1,5 +1,6 @@
 (define-module (hnh util)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-71)
   #:use-module (srfi srfi-88)           ; postfix keywords
   #:use-module ((ice-9 optargs) #:select (define*-public))
   #:use-module ((sxml fold) #:select (fold-values))
@@ -15,7 +16,7 @@
                 begin1
                 catch*
                 )
-  #:replace (let* set! define-syntax
+  #:replace (set! define-syntax
                   when unless))
 
 ((@ (guile) define-syntax) define-syntax
@@ -78,65 +79,6 @@
 
 
 
-;; Replace let* with a version that can bind from lists.
-;; Also supports SRFI-71 (extended let-syntax for multiple values)
-;; @lisp
-;; (let* ([a b (values 1 2)]               ; @r{SRFI-71}
-;;        [(c d) '(3 4)]                   ; @r{Let-list (mine)}
-;;        [(a b . c) (cons* 1 2 3)]        ; @r{Improper list matching (mine)}
-;;        [e 5])                           ; @r{Regular}
-;;   (list e d c b a))
-;; ;; => (5 4 3 2 1)
-;; @end lisp
-(define-syntax let*
-  (syntax-rules ()
-
-    ;; Base case
-    [(_ () body ...)
-     (begin body ...)]
-
-    ;; (let (((a b) '(1 2))) (list b a)) => (2 1)
-    [(_ (((k ... . (k*)) list-value) rest ...)
-        body ...)
-     (apply (lambda (k ... k*)
-              (let* (rest ...)
-                body ...))
-            list-value)]
-
-    ;; Improper list matching
-    ;; (let* (((a b . c) (cons* 1 2 3))) (list a c)) ; => (1 3)
-    [(_ (((k1 k ... . k*) imp-list) rest ...)
-        body ...)
-     (apply (lambda (k1 k ... k*)
-              (let* (rest ...)
-                body ...))
-            (improper->proper-list
-             imp-list (length (quote (k1 k ...)))))]
-
-    ;; "Regular" case
-    [(_ ((k value) rest ...) body ...)
-     (let ((k value))
-       (let* (rest ...)
-         body ...))]
-
-    ;; SRFI-71 let-values
-    [(_ ((k k* ... values) rest ...) body ...)
-     (call-with-values (lambda () values)
-       (lambda (k k* ...)
-         (let* (rest ...)
-           body ...)))]
-
-    ;; Declare variable without a value (actuall #f).
-    ;; Useful for inner mutation.
-    [(_ (v rest ...) body ...)
-     (let* ((v #f) rest ...) body ...)]
-    ))
-
-(define (improper->proper-list lst len)
-  (let* ((head tail (split-at lst len)))
-    (append head (list tail))))
-
-
 (define-syntax-rule (begin1 first rest ...)
   (call-with-values (lambda () first)
     (lambda returned
@@ -337,7 +279,7 @@
 ;; @end example
 (define-public (assq-merge a b)
   (fold (lambda (entry alist)
-          (let* (((k . v) entry)
+          (let* ((k v (car+cdr entry))
                  (o (assq-ref alist k)))
             (assq-set! alist k (append v (or o '())))))
         (copy-tree a) b))
@@ -415,7 +357,7 @@
 (define-public (cross-product . args)
   (if (null? args)
       '()
-      (let* ((last rest (car+cdr (reverse args))))
+      (let ((last rest (car+cdr (reverse args))))
         (reduce-right cross-product% '()
                       (reverse (cons (map list last) rest ))))))
 
@@ -508,7 +450,7 @@
 ;; Requires that width|(length list)
 (define-public (group list width)
   (unless (null? list)
-    (let* ((row rest (split-at list width)))
+    (let ((row rest (split-at list width)))
       (cons row (group rest width)))))
 
 ;; repeatedly apply @var{proc} to @var{base}
diff --git a/module/hnh/util/graph.scm b/module/hnh/util/graph.scm
index 03c2ae3c..01e9a63a 100644
--- a/module/hnh/util/graph.scm
+++ b/module/hnh/util/graph.scm
@@ -7,6 +7,7 @@
 (define-module (hnh util graph)
   :use-module (hnh util)
   :use-module (srfi srfi-1)
+  :use-module (srfi srfi-71)
   :use-module (srfi srfi-9 gnu))
 
 ;; Immutable directed graph
@@ -88,7 +89,7 @@
       (let loop ((graph graph))
         (if (graph-empty? graph)
             '()
-            (let* ((node graph* (find-and-remove-node-without-dependencies graph)))
+            (let ((node graph* (find-and-remove-node-without-dependencies graph)))
               (cons node (loop graph*))))))
     (lambda (err caller fmt args data)
       (car graph))))
diff --git a/module/hnh/util/path.scm b/module/hnh/util/path.scm
index 7eac630b..340c2d8b 100644
--- a/module/hnh/util/path.scm
+++ b/module/hnh/util/path.scm
@@ -1,5 +1,6 @@
 (define-module (hnh util path)
   :use-module (srfi srfi-1)
+  :use-module (srfi srfi-71)
   :use-module (hnh util))
 
 (define // file-name-separator-string)
@@ -40,16 +41,16 @@
 ;; ⇒ ("" "usr" "lib" "test")
 ;; @end example
 (define-public (path-split path)
-  (let* ((head tail
-               (car+cdr
-                (reverse
-                 (map reverse-list->string
-                      (fold (lambda (c done)
-                              (if (/? c)
-                                  (cons '() done)
-                                  (cons (cons c (car done)) (cdr done))))
-                            '(())
-                            (string->list path)))))))
+  (let ((head tail
+              (car+cdr
+               (reverse
+                (map reverse-list->string
+                     (fold (lambda (c done)
+                             (if (/? c)
+                                 (cons '() done)
+                                 (cons (cons c (car done)) (cdr done))))
+                           '(())
+                           (string->list path)))))))
     (cons head (remove string-null? tail))))
 
 
diff --git a/module/hnh/util/tree.scm b/module/hnh/util/tree.scm
index 95328b5f..34e10365 100644
--- a/module/hnh/util/tree.scm
+++ b/module/hnh/util/tree.scm
@@ -1,5 +1,6 @@
 (define-module (hnh util tree)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-71)
   #:use-module (hnh util)
   #:export (make-tree left-subtree
                       right-subtree
@@ -13,8 +14,8 @@
 ;; both it's children equal to @var{null}.
 (define (make-tree pred? lst)
   (unless (null? lst)
-    (let* ((head tail (partition (lambda (el) (pred? (car lst) el))
-                                 (cdr lst))))
+    (let ((head tail (partition (lambda (el) (pred? (car lst) el))
+                                (cdr lst))))
       (list (car lst)
             (make-tree pred? head)
             (make-tree pred? tail)))))