Remove redundant factorisation

Shen-Language · Jan 13, 2024 · df1c360 · df1c360
1 parent 8809e40
commit df1c360
Showing 1 changed file with 17 additions and 11 deletions.
diff --git a/sources/core.shen b/sources/core.shen
@@ -292,19 +292,25 @@
 
 (define factor-recognisors
   [[true R] | _]         -> R
-  [[[and P Q] R] | Body] -> (let Pivot         (pivot-on P [[[and P Q] R] | Body] [])
-                                 Before        (fst Pivot)
-                                 After         (snd Pivot)
-                                 Else          (factor-recognisors After)
-                                 Go            (gensym (protect GoTo))
-                                 Then          (reverse [[true [thaw Go]] | Before])
-                                 Code          [let Go [freeze Else]
-                                                 [if P
-                                                     (factor-selectors P (factor-recognisors Then))
-                                                     [thaw Go]]]
-                              (remove-indirection Code))
+  [[[and P Q] R] | Body] -> (let Pivot        (pivot-on P [[[and P Q] R] | Body] [])
+                                 Before       (fst Pivot)
+                              (if (bad-pivot? Before)
+                                  [if [and P Q] R (factor-recognisors Body)]
+                                  (let After  (snd Pivot)
+                                       Else   (factor-recognisors After)
+                                       Go     (gensym (protect GoTo))
+                                       Then   (reverse [[true [thaw Go]] | Before])
+                                       Code   [let Go [freeze Else]
+                                                [if P
+                                                   (factor-selectors P (factor-recognisors Then))
+                                                   [thaw Go]]]
+                                    (remove-indirection Code))))
   [[P R] | Body]         -> [if P R (factor-recognisors Body)])
 
+(define bad-pivot?
+  [_] -> true
+  _   -> false)
+
 (define remove-indirection
   [let Go [freeze [thaw Procedure]] Body] -> (subst Procedure Go Body)  where (symbol? Procedure)
   X -> X)