From 31e749bf5a1af1d2776c876ec66a05d1bf74ece7 Mon Sep 17 00:00:00 2001
From: Justin Ethier <justin.ethier@gmail.com>
Date: Wed, 31 Oct 2018 17:57:30 -0400
Subject: [PATCH] Flatten nested Cyc-seq expressions.

---
 scheme/cyclone/transforms.sld | 36 +++++++++++++++++++++++++++++++++++
 1 file changed, 36 insertions(+)

diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld
index 36cf7c3c..931e1087 100644
--- a/scheme/cyclone/transforms.sld
+++ b/scheme/cyclone/transforms.sld
@@ -776,6 +776,9 @@
     
     ; Application:
     ((app? exp)
+     ;; Easy place to clean up nested Cyc-seq expressions
+     (when (tagged-list? 'Cyc-seq exp)
+           (set! exp (flatten-subcalls exp 'Cyc-seq)))
      (let ((result (map (lambda (e) (wrap-mutables e globals)) exp)))
        ;; This code can eliminate a lambda definition. But typically
        ;; the code that would have such a definition has a recursive
@@ -806,6 +809,39 @@
        result))
     (else            (error "unknown expression type: " exp))))
 
+;; Flatten a list containing subcalls of a given symbol.
+;; For example, the expression: 
+;;
+;;  '(Cyc-seq
+;;         (set! b '(#f . #f))
+;;         ((Cyc-seq
+;;           (set-car!  a 1)
+;;           ((Cyc-seq
+;;             (set-cdr!  a '(2)))))))
+;;
+;; becomes:
+;;
+;;  '(Cyc-seq
+;;     (set! b '(#f . #f))
+;;     (set-car!  a 1)
+;;     (set-cdr!  a '(2)))
+;;
+(define (flatten-subcalls sexp sym)
+  (define (flat sexp acc)
+    (cond
+      ((not (pair? sexp))
+       acc)
+      ((and (app? (car sexp))
+            (app? (caar sexp))
+            (tagged-list? sym (caar sexp)))
+       (flat (cdaar sexp) acc))
+      (else ;;(pair? sexp)
+        (flat (cdr sexp) (cons (car sexp) acc))))
+  )
+  (reverse
+    (flat sexp '())))
+
+
 ;; Alpha conversion
 ;; (aka alpha renaming)
 ;;