From 73a4bfc3d8e9bb5365e33a11a6ad3b8340d5195b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 12 Jun 2022 21:09:35 +0200 Subject: 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. --- module/hnh/util.scm | 68 ++++------------------------------------------- module/hnh/util/graph.scm | 3 ++- module/hnh/util/path.scm | 21 ++++++++------- module/hnh/util/tree.scm | 5 ++-- 4 files changed, 21 insertions(+), 76 deletions(-) (limited to 'module/hnh') 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))))) -- cgit v1.2.3