Support multiple scrutinee in is-case pattern matching.

	* interp/compiler.boot (compRetractGruard): Rename from
	compRetractAlternative.  Split.
	(compRecoverGuard): Rename from compRecoverAlternative.  Split.
	(compAlternativeGuardItem): New.  Use them.
	(compAlternativeGuard): New.  
	(compMatchAlternative): New.  Split from compMatch.
	(compMatchScrutinee): Likewise.
	(defineMatchScrutinee): Likewise.
	(compMatch): Rework.

2 files changed, 167 insertions, 84 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 2607f13f..f28d0a42 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,4 +1,17 @@
 2009-06-13  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+	
+	Support multiple scrutinee in is-case pattern matching.
+	* interp/compiler.boot (compRetractGruard): Rename from
+	compRetractAlternative.  Split.
+	(compRecoverGuard): Rename from compRecoverAlternative.  Split.
+	(compAlternativeGuardItem): New.  Use them.
+	(compAlternativeGuard): New.  
+	(compMatchAlternative): New.  Split from compMatch.
+	(compMatchScrutinee): Likewise.
+	(defineMatchScrutinee): Likewise.
+	(compMatch): Rework.
+
+2009-06-13  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
 	* driver/utils.c (openaxiom_execute_core): Workaround GCL oddity.
 
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 201e925f..22c5471c 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -1222,6 +1222,9 @@ canReturn(expr,level,exitCount,ValueFlag) ==  --SPAD: exit and friends
   atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
   op is ["XLAM",args,bods] =>
     and/[canReturn(u,level,exitCount,ValueFlag) for u in expr]
+  op = "LET" or op = "LET*" =>
+    or/[canReturn(init,level,exitCount,false) for [.,init] in second expr]
+       or canReturn(third expr,exitCount,ValueFlag)
   systemErrorHere ['"canReturn",expr] --for the time being
 
 ++ We are compiling a conditional expression, type check and generate
@@ -1940,44 +1943,41 @@ compResolveCall(op,argTs,m,$e) ==
 
 --% %Match
 
-
-++ Subroutine of compMatch, responsible of compiling individual alternative
-++ of the form 
+++ Subroutine of compAlternativeGuardItem, responsible of compiling 
+++ individual alternative of the form 
 ++      x@t => stmt
-++ in environment `e'.  Here `y' is the scrutinee, and `m' is the
-++ exit mode of `stmt'. And `T' is [y,m,e].
-++ Return a quadruple [code,mode,envTrue,envFalse], where
-++   code is a pair [cond, body]
-++   mode is the final mode (equal to m if everything is OK)
-++   envTrue is the environment resulting from compiling `stmt'
-++   envFalse is the environment for failed match.
-compRetractAlternative(x,t,stmt,m,s,T) ==
+++ in environment `e'.  Here `sn' is the temporary holding the
+++ value of the scrutinee, and `sm' is its type.
+++ Return a quadruple [guard,init,envTrue,envFalse], where
+++   `guard' is code that gates the body of the alternative
+++   `init' is list of possible initializations 
+++   `envTrue' is an environment after the guard evaluates to true
+++   `envFalse' is an environment after the guard environment to false.
+compRetractGuard(x,t,sn,sm,e) ==
   -- The retract pattern is compiled by transforming
-  --     x@t => sttmt
+  --     x@t => stmt
   -- into the following program fragment
-  --   y case t => (x := <init>; stmt)
-  -- where <init> is code that compute appropriate initialization
-  -- for `x' under the condition that either `y' may be implicitly
+  --   sn case t => (x := <expr>; stmt)
+  -- where <expr> is code that computes appropriate initialization
+  -- for `x' under the condition that either `sn' may be implicitly
   -- convertible to t (using only courtesy coerciions) or that
-  -- `y' is retractable to t.
+  -- `sn' is retractable to t.
   --
   -- 1.  Evaluate the retract condition, and retract.
-  y := T.expr            -- guaranteed to be a name.
-  e := T.env
   caseCode := nil
   restrictCode := nil
   envFalse := e
   -- 1.1. Try courtesy coercions first.  That way we can use 
   --      optimized versions where available.  That also
   --      makes the scheme work for untagged unions.
-  if testT := compPredicate(["case",y,t],e) then
+  if testT := compPredicate(["case",sn,t],e) then
     [caseCode,.,e,envFalse] := testT
     [restrictCode,.,e] := 
-      tryCourtesyCoercion([y,T.mode,e],t) or
-        comp(["retract",y],t,e) or return 
-          stackAndThrow('"Could not retract %1 to type %2bp",[s,t])
+      tryCourtesyCoercion([sn,sm,e],t) or
+        comp(["retract",sn],t,e) or return 
+          stackAndThrow('"Could not retract from %1bp to %2bp",[sm,t])
   -- 1.2. Otherwise try retractIfCan, for those `% has RetractableTo t'.
-  else if retractT := comp(["retractIfCan",y],["Union",t,'"failed"],e) then
+  else if retractT := comp(["retractIfCan",sn],["Union",t,'"failed"],e) then
     [retractCode,.,e] := retractT
     -- Assign this value to a temporary.  From the backend point of
     -- view, that temporary needs to have a lifetime that covers both
@@ -1987,51 +1987,43 @@ compRetractAlternative(x,t,stmt,m,s,T) ==
     caseCode := ["PROGN",["%LET",z,retractCode],["QEQCAR",z,0]]
     restrictCode := ["QCDR",z]
   -- 1.3. Everything else failed; nice try.
-  else return stackAndThrow('"%1 is not retractable to %2bp",[s,t])
+  else return stackAndThrow('"%1bp is not retractable to %2bp",[sm,t])
   -- 2.  Now declare `x'.
   [.,.,e] := compMakeDeclaration(x,t,e) or return nil
   e := put(x,"value",[genSomeVariable(),t,$noEnv],e)
-  -- 3.  Compile body of the retract pattern.
-  stmtT := comp(stmt,m,e) or return 
-    stackAndThrow('"could not compile %1b under mode %2pb",[stmt,m])
-  -- 4.  Generate code for the whole pattern.
-  code := [caseCode, ["LET",[[x,restrictCode]],stmtT.expr]]
-  [code,stmtT.mode,stmtT.env,envFalse]
-
-
-++ Subroutine of compMatch, responsible for compiling alternative of
-++ of the form
-++    x: t => stmt
-++ in environment `e', where `y' is the scrutinee, and `m' is the
-++ exit mode of `stmt'. And `T' is [y,m,e].
-++ Return a quadruple [code,mode,envTrue,envFalse], where
-++   code is a pair [cond, body]
-++   mode is the final mode (equal to m if everything is OK)
-++   env is the environment resulting from compiling `stmt'
-compRecoverAlternative(x,t,stmt,m,s,T) ==
+  -- 3.  Assemble result.
+  [caseCode, [[x,restrictCode]],e,envFalse]
+
+
+++ Subroutine of compAlternativeGuardItem, responsible for 
+++ compiling a guad item of the form
+++    x: t
+++ in environment `e', where `sn' is the temporary holding
+++ the value of the scrutinee, and `sm' is its mode.
+++ Return a quadruple [guard,init,envTrue,envFalse], where
+++   `guard' is code that gates the body of the alternative
+++   `init' is list of possible initializations 
+++   `envTrue' is an environment after the guard evaluates to true
+++   `envFalse' is an environment after the guard environment to false.
+compRecoverGuard(x,t,sn,sm,e) ==
   -- The retract pattern is compiled by transforming
-  --     x: t => sttmt
+  --     x: t => stmt
   -- into the following program fragment
-  --   domainOf y is t => (x := <init>; stmt)
-  -- where <init> is code that compute appropriate initialization
-  -- for `x' under the condition that y if of type Any, and the
+  --   domainOf y is t => (x := <expr>; stmt)
+  -- where <expr> is code that compute appropriate initialization
+  -- for `x' under the condition that sm is Any, and the
   -- underlying type is t.
   --
   -- 1.  Evaluate the recovery condition
-  y := T.expr              -- guaranteed to be a name.
-  e := T.env
-  T.mode ^= $Any =>
+  sm ^= $Any =>
     stackAndThrow('"Scrutinee must be of type %b Any %d in type recovery alternative of case pattern",nil)
-  caseCode := ["EQUAL",["devaluate",t],["objMode",y]]
+  caseCode := ["EQUAL",["devaluate",t],["objMode",sn]]
   -- 2. Declare `x'.
+  originalEnv := e
   [.,.,e] := compMakeDeclaration(x,t,e) or return nil
   e := put(x,"value",[genSomeVariable(),t,$noEnv],e)
-  -- 3. Compile body of alternative
-  stmtT := comp(stmt,m,e) or return 
-    stackAndThrow('"could not compile %1b under mode %2pb",[stmt,m])
-  -- 4.  Assemble code
-  code := [caseCode,["LET",[[x,["objVal",y]]],stmtT.expr]]
-  [code,stmtT.mode,stmtT.env,e]
+  -- 3.  Assemble the result
+  [caseCode,[[x,["objVal",sn]]],e,originalEnv]
 
 warnUnreachableAlternative pat ==
   stackWarning('"Alternative with pattern %1b will not be reached",[pat])
@@ -2039,42 +2031,120 @@ warnUnreachableAlternative pat ==
 warnTooManyOtherwise() ==
   stackWarning('"One too many `otherwise' alternative",nil)
 
-compMatch(["%Match",subject,altBlock],m,e) ==
+
+++ Subroutine of compMatch.  Perform semantics analysis of the scrutinee
+++ in a case-pattern.  Return a triple if everything is OK, otherwise nil.
+compMatchScrutinee(form,e) ==
+  form is ["%Comma",:exprs] =>
+    Xs := Ms := nil
+    for expr in exprs repeat
+      [x,m,e] := compOrCroak(expr,$EmptyMode,e)
+      Xs := [x,:Xs]
+      Ms := [m,:Ms]
+    [["%Comma",:nreverse Xs], ["%Cross",:nreverse Ms],e]
+  compOrCroak(form,$EmptyMode,e)
+
+++ Subroutine of compMatch.  We just finished semantics analysis of
+++ the scrutinee.  Define temporary to hold the resulting value in store.
+++ Returns declared temporaries if everything is fine, otherwise nil.
+defineMatchScrutinee(m,e) ==
+    m is ["%Cross",:.] =>
+      [[t for m' in rest m | [t,e] := defTemp(m',e)], e]
+    defTemp(m,e)
+  where defTemp(m,e) ==
+    t := GENSYM()
+    [.,.,e] := compMakeDeclaration(t,m,e)
+    [t,put(t,"value",[genSomeVariable(),m,$noEnv],e)]
+
+++ Generate code for guard in a simple pattern where
+++ `sn' is the name of the temporary holding the scrutinee value,
+++ `sn' is its mode,
+++ `pat' is the simple pattern being compiled.
+++ On success, return a quadruple of the form [guard,init,eT,eF] where
+++   `guard' is the code for guard alternative
+++   `init' is collateral initialization
+++   `eT' is the environment for successful guard
+++   `eF' is the environment for unsuccessful guard 
+compAlternativeGuardItem(sn,sm,pat,e) ==
+  pat is [op,x,t] and op in '(_: _@) =>
+    not IDENTP x => 
+      stackAndThrow('"pattern %1b must declare a variable",[pat])
+    if $catchAllCount > 0 then
+      warnUnreachableAlternative pat
+    op = ":" => compRecoverGuard(x,t,sn,sm,e)
+    compRetractGuard(x,t,sn,sm,e) or
+       stackAndThrow('"cannot compile %1b",[pat])
+  return stackAndThrow('"invalid pattern %1b",[pat])
+
+++ Subroutine of compMatchAlternative.  The parameters
+++ have the same meaning.
+compAlternativeGuard(sn,sm,pat,e) ==
+  pat = "otherwise" =>
+    if $catchAllCount > 0 then
+      warnTooManyOtherwise()
+    $catchAllCount := $catchAllCount + 1
+    [true,nil,e,e]
+  CONSP sn =>
+    pat isnt ["%Comma",:.] =>
+      stackAndThrow('"Pattern must be a tuple for a tuple scrutinee",nil)
+    #sn ^= #rest pat =>
+      stackAndThrow('"Tuple pattern must match tuple scrutinee in length",nil)
+    inits := nil
+    guards := nil
+    ok := true
+    originalEnv := e
+    for n in sn for m in rest sm for p in rest pat while ok repeat
+      [guard,init,e,.] := compAlternativeGuardItem(n,m,p,e) => 
+        guards := [guard,:guards]
+        inits := [init,:inits]
+      ok := false
+    ok => [["AND",:nreverse guards],append/nreverse inits,e,originalEnv]
+    nil
+  compAlternativeGuardItem(sn,sm,pat,e)
+
+++ Subroutine of compMatch. Analyze an alternative in a case-pattern.
+++ `sn' is a name or a list of name for temporaries holding the
+++      value of the scrutinee.
+++ `sm' is the mode of list of modes for the scrutinee.
+++ `pat' is the pattern of the alternative we are compiling
+++ `stmt' is the body of the alternative we are compiling
+++ `m' is the desired mode for the return value.
+++ `e' is the environment in effect at the start of the environment.
+compMatchAlternative(sn,sm,pat,stmt,m,e) ==
+  [guard,inits,e,eF] := compAlternativeGuard(sn,sm,pat,e) or return nil
+  stmtT := comp(stmt,m,e) or
+            stackAndThrow('"could not compile %1b under mode %2pb",[stmt,m])
+  body :=
+    null inits => stmtT.expr
+    atom sn => ["LET",inits,stmtT.expr]
+    ["LET*",inits,stmtT.expr]
+  [[guard,body],stmtT.mode,stmtT.env,eF]
+
+++ Analyze and generate code for `is case'-pattern where the
+++ scrutineeis `subject' and the alternatives are `altBlock'.
+-- FIXME: Make sure nobody asks for creating matter out of void.
+compMatch(["%Match",subject,altBlock],m,env) ==
   altBlock isnt ["%Block",:alts] => 
     stackAndThrow('"case pattern must specify block of alternatives",nil)
-  savedEnv := e
+  savedEnv := env
   -- 1.  subjectTmp := subject
-  [se,sm,e] := comp(subject,$EmptyMode,e) or return nil
-  sn := GENSYM()
-  [.,.,e] := compMakeDeclaration(sn,sm,e) or return nil
-  e := put(sn,"value",[genSomeVariable(),sm,$noEnv],e)
+  [se,sm,env] := compMatchScrutinee(subject,env)
+  [sn,env] := defineMatchScrutinee(sm,env)
   -- 2. compile alternatives.
+  $catchAllCount: local := 0
   altsCode := nil
-  catchAllCount := 0
   for alt in alts repeat
-     alt is ["=>",pat,stmt] =>
-       pat is [op,x,t] and op in '(_: _@) =>
-         not IDENTP x => 
-           stackAndThrow('"pattern %1b must declare a variable",[pat])
-         if catchAllCount > 0 then
-           warnUnreachableAlternative pat
-         [code,mode,.,e] :=
-           op = ":" => compRecoverAlternative(x,t,stmt,m,subject,[sn,sm,e])
-           compRetractAlternative(x,t,stmt,m,subject,[sn,sm,e])
-             or return stackAndThrow('"cannot compile %1b",[alt])
-         altsCode := [code,:altsCode]
-       pat = "otherwise" =>
-         if catchAllCount > 0 then
-           warnTooManyOtherwise()
-         catchAllCount := catchAllCount + 1
-         [code,.,e] := comp(stmt,m,e) or return
-                         stackAndThrow('"cannot compile",[stmt])
-         altsCode := [[true,code],:altsCode]
-       return stackAndThrow('"invalid pattern %1b",[pat])
+     alt is ["=>",pat,stmt] => 
+       [block,mode,.,env] := compMatchAlternative(sn,sm,pat,stmt,m,env) or
+             return stackAndThrow('"cannot compile pattern %1b",[pat])
+       altsCode := [block,:altsCode]
      return stackAndThrow('"invalid alternative %1b",[alt])
-  catchAllCount = 0 => 
+  $catchAllCount = 0 => 
     stackAndThrow('"missing %b otherwise %d alternative in case pattern",nil)
-  code := ["LET",[[sn,se]],["COND",:nreverse altsCode]]
+  code := 
+    atom sn => ["LET",[[sn,se]],["COND",:nreverse altsCode]]
+    ["LET*",[[n,e] for n in sn for e in rest se], 
+       ["COND",:nreverse altsCode]]
   [code,m,savedEnv]