[gnunet-scheme] 03/16: hat-let: Port to Racket Scheme.

[gnunet]

This is an automated email from the git hooks/post-receive script.

maxime-devos pushed a commit to branch master
in repository gnunet-scheme.

commit c402eddd599db8dccdf6c3f27e0d7edf2b34f7fb
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sat Sep 3 21:32:58 2022 +0200

    hat-let: Port to Racket Scheme.
    
    * gnu/gnunet/utils/hat-lets.scm: Add phasing, and check for _ differently.
---
 gnu/gnunet/utils/hat-let.scm | 119 +++++++++++++++++++++----------------------
 1 file changed, 59 insertions(+), 60 deletions(-)

diff --git a/gnu/gnunet/utils/hat-let.scm b/gnu/gnunet/utils/hat-let.scm
index 582d452..5ed7759 100644
--- a/gnu/gnunet/utils/hat-let.scm
+++ b/gnu/gnunet/utils/hat-let.scm
@@ -38,66 +38,65 @@
 
 (library (gnu gnunet utils hat-let (2 5))
   (export let^)
-  (import (except (rnrs base) _)
-         (rename (rnrs base) (_ rnrs:_)))
-
+  (import (for (rnrs base) run expand)
+         (for (rnrs syntax-case) expand))
   ;; A generalisation of let*, and-let*, receive, begin,
   ;; and generalised let for avoiding nesting.
   (define-syntax let^
-    (syntax-rules (? ! !! _ rnrs:_ <- <-- /o/)
-      ((: () code ...)
-       (let () code ...))
-      ;; if x, then return @code{(begin esc esc* ...)}
-      ((: ((? x esc esc* ...) etc ...) code ...)
-       (if x
-          (begin esc esc* ...)
-          (let^ (etc ...) code ...)))
-      ;; Define a procedure
-      ((: ((! (x . args) body ...) etc ...) code ...)
-       (let ((x (lambda args body ...)))
-        (let^ (etc ...)
-              code ...)))
-      ;; Define a procedure, and let the body of the procedure be
-      ;; a let^ form.  @var{docstring} is assumed to be a literal string.
-      ((: ((!^ (x . args) docstring bindings body ...) etc ...) code ...)
-       (let^ ((! (x . args)
-                docstring
-                (let^ bindings body ...))
-             etc ...)
-            code ...))
-      ;; Bind y to x
-      ((: ((! x y) etc ...) code ...)
-       (let ((x y))
-        (let^ (etc ...) code ...)))
-      ;; Assert it is true!
-      ((: ((!! x) etc ...) code ...)
-       (begin
-        (assert x)
-        (let^ (etc ...) code ...)))
-      ;; Throw a result away.  Allow both RnRS _ and unbound _.
-      ((: ((_ x) etc ...) code ...)
-       (begin
-        x
-        (let^ (etc ...) code ...)))
-      ((: ((rnrs:_ x) etc ...) code ...)
-       (begin
-        x
-        (let^ (etc ...) code ...)))
-      ;; Assign multiple values (from a thunk).
-      ;; This is a historical mistake, use <--
-      ;; instead (see mini changelog).
-      ((: ((<- (x ...) thunk) etc ...) code ...)
-       (call-with-values thunk
-        (lambda (x ...)
-          (let^ (etc ...)
-                code ...))))
-      ;; Assign multiple values.
-      ((: ((<-- dotted-variable-list exp) etc ...) code ...)
-       (call-with-values (lambda () exp)
-        (lambda dotted-variable-list
-          (let^ (etc ...) code ...))))
-      ;; Tail-call into a generalised let
-      ((: ((/o/ loop (x y) ...) etc ...) code ...)
-       (let loop ((x y) ...)
-        (let^ (etc ...)
-              code ...))))))
+    (lambda (s)
+      (syntax-case s (? ! !! <- <-- /o/)
+       ((: () code ...)
+        #'(let () code ...))
+       ;; if x, then return @code{(begin esc esc* ...)}
+       ((: ((? x esc esc* ...) etc ...) code ...)
+        #'(if x
+              (begin esc esc* ...)
+              (let^ (etc ...) code ...)))
+       ;; Define a procedure
+       ((: ((! (x . args) body ...) etc ...) code ...)
+        #'(let ((x (lambda args body ...)))
+            (let^ (etc ...)
+                  code ...)))
+       ;; Define a procedure, and let the body of the procedure be
+       ;; a let^ form.  @var{docstring} is assumed to be a literal string.
+       ((: ((!^ (x . args) docstring bindings body ...) etc ...) code ...)
+        #'(let^ ((! (x . args)
+                    docstring
+                    (let^ bindings body ...))
+                 etc ...)
+                code ...))
+       ;; Bind y to x
+       ((: ((! x y) etc ...) code ...)
+        #'(let ((x y))
+            (let^ (etc ...) code ...)))
+       ;; Assert it is true!
+       ((: ((!! x) etc ...) code ...)
+        #'(begin
+            (assert x)
+            (let^ (etc ...) code ...)))
+       ;; Throw a result away.  Allow both RnRS _ and unbound _.  We used to
+       ;; write two cases here for the RnRS _ and unbound _, but Racket Scheme
+       ;; forbids using _ as a literal, so do some syntax-case tricks instead.
+       ((: ((underscore x) etc ...) code ...)
+        (eq? (syntax->datum #'underscore) '_)
+        #'(begin
+            x
+            (let^ (etc ...) code ...)))
+       ;; Assign multiple values (from a thunk).
+       ;; This is a historical mistake, use <--
+       ;; instead (see mini changelog).
+       ((: ((<- (x ...) thunk) etc ...) code ...)
+        #'(call-with-values thunk
+            (lambda (x ...)
+              (let^ (etc ...)
+                    code ...))))
+       ;; Assign multiple values.
+       ((: ((<-- dotted-variable-list exp) etc ...) code ...)
+        #'(call-with-values (lambda () exp)
+            (lambda dotted-variable-list
+              (let^ (etc ...) code ...))))
+       ;; Tail-call into a generalised let
+       ((: ((/o/ loop (x y) ...) etc ...) code ...)
+        #'(let loop ((x y) ...)
+            (let^ (etc ...)
+                  code ...)))))))

-- 
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.