From 6c0cc18deacadb592fe3d68c5585979f6902cd1a Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Mon, 3 May 2010 20:51:40 +0000
Subject: 	Generate more readable code for functor definitions. 	*
 interp/nruncomp.boot (washFunctorBody): New. 	(buildFunctor): Use it. 
 * interp/g-opt.boot (optBind): New. 	(optLIST): Likewise.

---
 src/interp/g-opt.boot    |  9 +++++++++
 src/interp/nruncomp.boot | 50 +++++++++++++++++++++++++++++++++++-------------
 2 files changed, 46 insertions(+), 13 deletions(-)

(limited to 'src/interp')

diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 31420217..3b0e5b28 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -529,6 +529,13 @@ optLET_* form ==
   rplac(first form,"LET")
   optLET form
 
+optBind form ==
+  rplac(first form,"LET*")
+  optLET_* form
+
+optLIST form ==
+  form is ["LIST"] => nil
+  form
 
 optCollectVector form ==
   [.,eltType,:iters,body] := form
@@ -587,6 +594,8 @@ for x in '( (call         optCall) _
            (SEQ          optSEQ)_
            (LET          optLET)_
            (LET_*        optLET_*)_
+           (%Bind        optBind)_
+           (LIST         optLIST)_
            (MINUS        optMINUS)_
            (QSMINUS      optQSMINUS)_
            (_-           opt_-)_
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index 69a50c7a..e4612f58 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.boot
@@ -377,6 +377,26 @@ NRTdescendCodeTran(u,condList) ==
   u is ['PROGN,:c] => for x in c repeat NRTdescendCodeTran(x,condList)
   nil
 
+++ Remove useless statements from the elaboration `form' of
+++ a function definition.  
+washFunctorBody form == main form where
+  main form ==
+    form' := nil
+    for x in form repeat
+      stmt := clean x
+      stmt = nil => nil
+      stmt is ["PROGN",:l] => form' := [:form',:l]
+      form' := [:form',stmt]
+    form'
+
+  clean x ==
+    x is ["PROGN",:stmts] =>
+      stmts := [s' for s in stmts | (s' := clean s) ~= nil]
+      stmts = nil => nil
+      rest stmts = nil => first stmts
+      ["PROGN",:stmts]
+    x is ["LIST"] => nil
+    x
 
 buildFunctor($definition is [name,:args],sig,code,$locals,$e) ==
 --PARAMETERS
@@ -459,24 +479,27 @@ buildFunctor($definition is [name,:args],sig,code,$locals,$e) ==
        :predBitVectorCode2,storeOperationCode]
 
   $CheckVectorList := NRTcheckVector domainShell
-  --CODE: part 1
-  codePart1:= [:devaluateCode,createDomainCode,
-                createViewCode,setVector0Code, slot3Code,:slamCode] where
-    devaluateCode:= [["%LET",b,['devaluate,a]] for [a,:b] in $devaluateList]
+  -- Local bindings
+  bindings := [:devaluateCode,createDomainCode,
+                 createViewCode,createPredVecCode] where
+    devaluateCode:= [[b,["devaluate",a]] for [a,:b] in $devaluateList]
     createDomainCode:=
-      ["%LET",domname,['LIST,MKQ first $definition,:ASSOCRIGHT $devaluateList]]
-    createViewCode:= ["%LET",'$,["newShell", $NRTbase + $NRTdeltaLength]]
-    setVector0Code:=[$setelt,'$,0,'dv_$]
-    slot3Code := ["setShellEntry",'$,3,["%LET",'pv_$,predBitVectorCode1]]
+      [domname,['LIST,MKQ first $definition,:ASSOCRIGHT $devaluateList]]
+    createViewCode:= ["$",["newShell", $NRTbase + $NRTdeltaLength]]
+    createPredVecCode := ["pv$",predBitVectorCode1]
+
+  --CODE: part 1
+  codePart1:= [setVector0Code, slot3Code,:slamCode] where
+    setVector0Code:=[$setelt,"$",0,"dv$"]
+    slot3Code := ["setShellEntry","$",3,"pv$"]
     slamCode:=
       isCategoryPackageName opOf $definition => nil
-      [NRTaddToSlam($definition,'$)]
+      [NRTaddToSlam($definition,"$")]
 
   --CODE: part 3
   $ConstantAssignments :=
       [NRTputInLocalReferences code for code in $ConstantAssignments]
-  codePart3:= [:constantCode1,
-                :constantCode2,:epilogue] where
+  codePart3:= [:constantCode1, :constantCode2,:epilogue] where
     constantCode1:=
       name='Integer => $ConstantAssignments
       nil
@@ -493,8 +516,9 @@ buildFunctor($definition is [name,:args],sig,code,$locals,$e) ==
       name='Integer => nil
       $ConstantAssignments
     epilogue:= $epilogue
-  ans :=
-    ['PROGN,:optFunctorPROGN [:codePart1,:codePart2,:codePart3], '$]
+  ans := ["%Bind",bindings,
+           :washFunctorBody optFunctorBody
+              [:codePart1,:codePart2,:codePart3],"$"]
   $getDomainCode:= nil
     --if we didn't kill this, DEFINE would insert it in the wrong place
   ans:= minimalise ans
-- 
cgit v1.2.3