17 files changed, 365 insertions, 14 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 8dacf4d6..ec9c0b71 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,9 +1,40 @@
-2008-12-06	Alfredo Portes	<doyenatccny@gmail.com>
+2008-12-07  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
-	* lib/cfuns-c.c (oa_getpid): New function to
-	support getting process id in Windows.
+	* interp/g-opt.boot ($simpleVMoperators): New.
+	(isSimpleVMForm): Likewise.
+	(isFloatableVMForm): Likewise.
+	(optLET): Likewise.  Expand backend let-forms.
+	* interp/c-util.boot (foldSpadcall): Look into LET and COND forms.
+	(replaceSimpleFunctions): Likewise.
+	(mutateCONDFormWithUnaryFunction): New.
+	(mutateLETFormWithUnaryFunction): Likewise.
+	* interp/compiler.boot (tryCourtesyCoercion): Split from coerce.
+	(compRetractAlternative): Simplify. Now try courtesy coercions
+	before retraction.  
+	(compRecoverAlternative): New.
+	(compMatch): Simplify.  Implement type recovery too.
+
+2008-12-06  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
+	* interp/compiler.boot (compRetractAlternative): New.
+	(compMatch): Likewise.  Use it to implement pattern matching
+	for retractable domains.
+	* interp/parse.boot (parseAtAt): New.
+	* interp/postpar.boot (postAtAt): Likewise.
+	(postAlternatives): Likewise.
+	(postMatch): Likewise.
+	* interp/metalex.lisp (Keywords): Remove `otherwise' as keyword.
+	* interp/fnewmeta.lisp (|PARSE-Match|): New local parser.
+	* interp/newaux.lisp (@@): New token.  Align wih interpreter.
+	(otherwise): Remove binding specification.
+	(case): Now also a Nud token.
+
+2008-12-06  Alfredo Portes  <doyenatccny@gmail.com>
+
+	* lib/cfuns-c.c (oa_getpid): New function to support getting
+	process id in Windows. 
 	* include/cfuns.h: Define it.
-    * lib/fnct_key.c: Use it.
+	* lib/fnct_key.c: Use it.
 	* lib/sockio-c.c: Likewise.
 	* lib/util.c: Likewise.
 	* clef/edible.c: Likewise.
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index b859fe80..1298963d 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -916,6 +916,35 @@ updateCapsuleDirectory(entry,pred) ==
   entry isnt ["$",slot,["CONS",["dispatchFunction",fun],:.],:.] => nil
   $capsuleDirectory := [[slot,:fun],:$capsuleDirectory]
 
+
+
+
+--% Tree walkers
+
+++ Walk VM COND-form mutating sub-forms with unary
+++ function `fun'
+mutateCONDFormWithUnaryFunction(form,fun) ==
+  form isnt ["COND",:body] => form
+  for clauses in tails body repeat
+    -- a clause is a list of forms
+    for subForms in tails first clauses repeat
+      rplac(first subForms, FUNCALL(fun, first subForms))
+  form
+
+++ Walk VM LET-form mutating enclosed expression forms with
+++ unary function `fun'.  Every sub-form is visited except
+++ local variable declarations, though their initializers
+++ are visited.
+mutateLETFormWithUnaryFunction(form,fun) ==
+  form isnt ["LET",inits,:body] => form
+  for defs in tails inits repeat
+    def := first defs
+    atom def => nil -- no initializer
+    rplac(second def, FUNCALL(fun, second def))
+  for stmts in tails body repeat
+    rplac(first stmts, FUNCALL(fun, first stmts))
+  form
+
 --% 
 
 ++ List of macros used by the middle end to represent some
@@ -967,6 +996,10 @@ isAtomicForm form ==
 ++ Walk `form' and replace simple functions as appropriate.
 replaceSimpleFunctions form ==
   isAtomicForm form => form
+  form is ["COND",:body] =>
+    mutateCONDFormWithUnaryFunction(form,"replaceSimpleFunctions")
+  form is ["LET",:.] =>
+    optLET mutateLETFormWithUnaryFunction(form,"replaceSimpleFunctions")
   -- 1. process argument first.
   for args in tails rest form repeat
     arg' := replaceSimpleFunctions(arg := first args)
@@ -1001,9 +1034,13 @@ replaceSimpleFunctions form ==
 foldSpadcall: %Form -> %Form
 foldSpadcall form ==
   isAtomicForm form => form
+  form is ["LET",inits,:body] =>
+    mutateLETFormWithUnaryFunction(form,"foldSpadcall")
+  form is ["COND",:stmts] =>
+    mutateCONDFormWithUnaryFunction(form,"foldSpadcall")
   for args in tails rest form repeat
     foldSpadcall first args
-  first form isnt "SPADCALL" => form
+  first form ^= "SPADCALL" => form
   fun := lastNode form
   fun isnt [["getShellEntry","$",slot]] => form
   null (op := getCapsuleDirectoryEntry slot) => form
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 81860046..a297b448 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -1420,7 +1420,8 @@ compIs(["is",a,b],m,e) ==
 --  One should always call the correct function, since the represent-
 --  ation of basic objects may not be the same.
 
-coerce(T,m) ==
+tryCourtesyCoercion: (%Triple, %Mode) -> %Maybe %Triple
+tryCourtesyCoercion(T,m) ==
   $InteractiveMode =>
     keyedSystemError("S2GE0016",['"coerce",
       '"function coerce called from the interpreter."])
@@ -1429,6 +1430,10 @@ coerce(T,m) ==
   T':= coerceEasy(T,m) => T'
   T':= coerceSubset(T,m) => T'
   T':= coerceHard(T,m) => T'
+  nil
+
+coerce(T,m) ==
+  T' := tryCourtesyCoercion(T,m) => T'
   -- if from from coerceable, this coerce was just a trial coercion
   -- from compFormWithModemap to filter through the modemaps
   T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil
@@ -1728,6 +1733,132 @@ compMapCond''(cexpr,dc) ==
 compMapCondFun(fnexpr,op,dc,bindings) == 
   [fnexpr,bindings]
 
+
+--% %Match
+
+
+++ Subroutine of compMatch, 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) ==
+  -- The retract pattern is compiled by transforming
+  --     x@t => sttmt
+  -- 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
+  -- convertible to t (using only courtesy coerciions) or that
+  -- `y' is retractable to t.
+  --
+  -- 1.  Evaluate the retract condition.
+  y := T.expr            -- guaranteed to be a name.
+  e := T.env
+  [caseCode,caseMode,e,envFalse] := 
+    compBoolean(["case",y,t],$Boolean,e) or return 
+       stackAndThrow('"%1 is not retractable to %2",[s,t])
+  -- 2.  Evaluate the actual retraction to `t'.
+  --     We try courtesy coercions first, then `retract'.  That way
+  --     we can use optimized versions where available.  That also
+  --     makes the scheme works for untagged unions.
+  [restrictCode,.,e] := tryCourtesyCoercion([y,T.mode,e],t) or
+                          comp(["retract",y],t,e) or return nil
+  -- 3.  Now declare `x'.
+  [.,.,e] := compMakeDeclaration([":",x,t],$EmptyMode,e) or return nil
+  e := put(x,"value",[genSomeVariable(),t,e],e)
+  -- 4.  Compile body of the retract pattern.
+  stmtT := comp(stmt,m,e) or return 
+    stackAndThrow('"could not compile %1b under mode %2pb",[stmt,m])
+  -- 5.  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) ==
+  -- The retract pattern is compiled by transforming
+  --     x: t => sttmt
+  -- 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
+  -- underlying type is t.
+  --
+  -- 1.  Evaluate the recovery condition
+  y := T.expr              -- guaranteed to be a name.
+  e := T.env
+  T.mode ^= $Any =>
+    stackAndThrow('"Scrutinee must be of type %b Any %d in type recovery alternative of case pattern",nil)
+  caseCode := ["EQUAL",["devaluate",t],["objMode",y]]
+  -- 2. Declare `x'.
+  [.,.,e] := compMakeDeclaration([":",x,t],$EmptyMode,e) or return nil
+  e := put(x,"value",[genSomeVariable(),t,e],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]
+
+warnUnreachableAlternative pat ==
+  stackWarning('"Alternative with pattern %1b will not be reached",[pat])
+
+warnTooManyOtherwise() ==
+  stackWarning('"One too many `otherwise' alternative",nil)
+
+compMatch(["%Match",subject,altBlock],m,e) ==
+  altBlock isnt ["%Block",:alts] => 
+    stackAndThrow('"case pattern must specify block of alternatives",nil)
+  savedEnv := e
+  -- 1.  subjectTmp := subject
+  [se,sm,e] := comp(subject,$EmptyMode,e) or return nil
+  sn := GENSYM()
+  [.,.,e] := compMakeDeclaration([":",sn,sm],$EmptyMode,e)
+               or return nil
+  e := put(sn,"value",[genSomeVariable(),sm,e],e)
+  -- 2. compile alternatives.
+  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])
+     return stackAndThrow('"invalid alternative %1b",[alt])
+  catchAllCount = 0 => 
+    stackAndThrow('"missing %b otherwise %d alternative in case pattern",nil)
+  code := ["LET",[[sn,se]],["COND",:nreverse altsCode]]
+  [code,m,savedEnv]
+
 --% Register compilers for special forms.
 -- Those compilers are on the `SPECIAL' property of the corresponding
 -- special form operator symbol.
@@ -1772,5 +1903,6 @@ for x in [["|", :"compSuchthat"],_
 	  ["UnionCategory", :"compConstructorCategory"],_
 	  ["where", :"compWhere"],_
           ["%Comma",:"compComma"],_
+          ["%Match",:"compMatch"],_
           ["[||]", :"compileQuasiquote"]] repeat
   MAKEPROP(first x, "SPECIAL", rest x)
diff --git a/src/interp/cparse.boot b/src/interp/cparse.boot
index 85146e21..7f2c2971 100644
--- a/src/interp/cparse.boot
+++ b/src/interp/cparse.boot
@@ -576,7 +576,19 @@ npIterators()==
 
 npIterator()==   npForIn() or npSuchThat() or npWhile()
 
+
+++ Parse a case-pattern expression.
+++   Case:
+++     CASE Interval IS PileExit
+npCase() ==
+  npEqKey "CASE" =>
+    (npInterval() or npTrap()) and (npEqKey "IS" or npTrap())
+      and (pPP function npPileExit or npTrap())
+        and npPush pfCase(npPop2(), pfSequenceToList npPop1())
+  false
+
 npStatement()==
+        npCase() or
         npExpress() or
         npLoop() or
         npIterate() or
diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp
index 70fd040c..fd15745d 100644
--- a/src/interp/fnewmeta.lisp
+++ b/src/interp/fnewmeta.lisp
@@ -599,6 +599,16 @@
                (CONS 'UNTIL (CONS (POP-STACK-1) NIL)))))) 
 
 
+(DEFUN |PARSE-Match| ()
+  (AND (MATCH-ADVANCE-STRING "case")
+       (MUST (|PARSE-Expr| 400))
+       (MATCH-ADVANCE-STRING "is")
+       (MUST (|PARSE-Expr| 110))
+       (PUSH-REDUCTION '|PARSE-Match|
+		       (CONS '|%Match|
+			     (CONS (POP-STACK-2)
+				   (CONS (POP-STACK-1) NIL))))))
+
 (DEFUN |PARSE-Expr| (RBP)
   (DECLARE (SPECIAL RBP))
   (AND (|PARSE-NudPart| RBP)
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 63f99d40..2b194c76 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -379,13 +379,77 @@ optEQ u ==
     u
   u
 
+$simpleVMoperators == 
+  '(CONS CAR CDR LENGTH SIZE EQUAL EQL EQ
+    INTEGERP FLOATP STRINGP IDENTP SYMBOLP)
+
+isSimpleVMForm form ==
+  isAtomicForm form => true
+  form is [op,:args] and MEMQ(op,$simpleVMoperators) 
+    and ("and"/[isAtomicForm arg for arg in args])
+
+++ Return true if `form' is a VM form whose evaluation does not depend
+++ on the program point where it is evaluated. 
+isFloatableVMForm: %Code -> %Boolean
+isFloatableVMForm form ==
+  atom form => form ^= "$"
+  form is ["QUOTE",:.] => true
+  MEMQ(first form, $simpleVMoperators) and
+    "and"/[isFloatableVMForm arg for arg in rest form]
+    
+
+++ Implement simple-minded LET-inlining.  It seems we can't count
+++ on Lisp implementations to do this simple transformation.
+++ This transformation will probably be more effective when all
+++ type informations are still around.   Which is why we should
+++ have a type directed compilation throughout. 
+optLET u ==
+  -- Hands off non-simple cases.
+  u isnt ["LET",inits,body] => u
+  -- Avoid initialization forms that may not be floatable.
+  not(and/[isFloatableVMForm init for [.,init] in inits]) => u
+  -- Identity function.
+  inits is [[=body,init]] => init
+  -- Handle only most trivial operators.
+  body isnt [op,:args] => u
+  -- Well, with case-patterns, it is beneficial to try a bit harder
+  -- with conditional forms.
+  op = "COND" =>
+    continue := true      -- shall be continue let-inlining?
+    -- Since we do a single pass, we can't reuse the inits list
+    -- as we may find later that we can't really inline into
+    -- all forms due to excessive conversatism.  So we build a 
+    -- substitution list ahead of time.
+    substPairs := [[var,:init] for [var,init] in inits]
+    for clauses in tails args while continue repeat
+      clause := first clauses
+      -- we do not attempt more complicate clauses yet.
+      clause isnt [test,stmt] => continue := false
+      -- Stop inlining at least one test is not simple
+      not isSimpleVMForm test => continue := false
+      rplac(first clause,SUBLIS(substPairs,test))
+      isSimpleVMForm stmt =>
+        rplac(second clause,SUBLIS(substPairs,stmt))
+    continue => body
+    u
+  not MEMQ(op,$simpleVMoperators) => u
+  not(and/[isAtomicForm arg for arg in args]) => u
+  -- Inline only if all parameters are used.  Get cute later.
+  not(and/[MEMQ(x,args) for [x,.] in inits]) => u
+  -- Munge inits into list of dotted-pairs.  Lovely Lisp.
+  for defs in tails inits repeat
+    def := first defs
+    atom def => systemErrorHere "optLET" -- cannot happen
+    rplac(rest def, second def)
+  SUBLIS(inits,body)
+
 lispize x == first optimize [x]
  
 --% optimizer hash table
  
 for x in '( (call         optCall) _
            (SEQ          optSEQ)_
-           (EQ optEQ)
+           (EQ optEQ)_
            (MINUS        optMINUS)_
            (QSMINUS      optQSMINUS)_
            (_-           opt_-)_
diff --git a/src/interp/i-funsel.boot b/src/interp/i-funsel.boot
index a5e90b39..c93a6100 100644
--- a/src/interp/i-funsel.boot
+++ b/src/interp/i-funsel.boot
@@ -731,7 +731,7 @@ findUniqueOpInDomain(op,opName,dom) ==
   -- use evaluation type context to narrow down the candidate set
   if target := getTarget op then
     mmList := [mm for mm in mmList | mm is [=rest target,:.]]
-    null mmList => throwKeyedMsg("S2IS0061",[opName,target,dom])
+    null mmList => throwKeyedMsg("S2IS0062",[opName,target,dom])
   if #mmList > 1 then
     mm := selectMostGeneralMm mmList
     sayKeyedMsg("S2IS0022",[opName,dom,['Mapping,:first mm]])
diff --git a/src/interp/i-intern.boot b/src/interp/i-intern.boot
index 9f78f6d8..245ba9e9 100644
--- a/src/interp/i-intern.boot
+++ b/src/interp/i-intern.boot
@@ -250,6 +250,7 @@ mkAtree3(x,op,argl) ==
       r := [[first types,:at],:r']
       [mkAtreeNode 'DEF,[[op,:v.0],:r],if v.2 then v.2 else true,false]
     [mkAtreeNode 'DEF,[a,:r],true,false]
+  op = "%Match" => [mkAtreeNode op, mkAtree1 first argl, second argl]
   op="[||]" => [mkAtreeNode op, :argl]
   op in '(%Inline %With %Add %Export) => [mkAtreeNode op,:argl]
 --x is ['when,y,pred] =>
diff --git a/src/interp/i-spec1.boot b/src/interp/i-spec1.boot
index ee6d9787..8cc56925 100644
--- a/src/interp/i-spec1.boot
+++ b/src/interp/i-spec1.boot
@@ -42,7 +42,7 @@ $specialOps := '(
   ADEF AlgExtension _and _case COERCE COLLECT construct Declare DEF Dollar
    equation error free has IF _is _isnt iterate _break %LET _local MDEF _or
     pretend QUOTE REDUCE REPEAT _return SEQ TARGET tuple typeOf _where 
-     _[_|_|_] %Macro %MLambda %Import %Export %Inline %With %Add)
+     _[_|_|_] %Macro %MLambda %Import %Export %Inline %With %Add %Match)
 
 $repeatLabel := NIL
 $breakCount := 0
@@ -1134,9 +1134,7 @@ declare(var,mode) ==
   if var is ['free,v] then
     upfreeWithType(v,mode)
     var := v
-  not IDENTP(var) =>
-    throwKeyedMsg("S2IS0016",[STRINGIMAGE var])
-  var in '(% %%) => throwKeyedMsg("S2IS0050",[var])
+  validateVariableNameOrElse var
   if get(var,'isInterpreterFunction,$e) then
     mode isnt ['Mapping,.,:args] =>
       throwKeyedMsg("S2IS0017",[var,mode])
diff --git a/src/interp/i-spec2.boot b/src/interp/i-spec2.boot
index 10776a5f..e843a18e 100644
--- a/src/interp/i-spec2.boot
+++ b/src/interp/i-spec2.boot
@@ -1161,6 +1161,13 @@ copyHack(env) ==
     CONS(CAR p,[(EQCAR(q,'localModemap) => q; copy q) for q in CDR p])
   [[d]]
 
+
+--% Case patterns
+
+up%Match t ==
+  sorry '"case pattern"
+
+
 --% importing domains
 up%Import t ==
   t isnt [.,:types] => nil
diff --git a/src/interp/i-util.boot b/src/interp/i-util.boot
index e4f54cce..aafc33d1 100644
--- a/src/interp/i-util.boot
+++ b/src/interp/i-util.boot
@@ -200,3 +200,10 @@ mkPredList listOfEntries ==
 
 
 
+--%
+
+++ Validate variable name `var', or abort analysis.
+validateVariableNameOrElse var ==
+  not IDENTP var => throwKeyedMsg("S2IS0016",[STRINGIMAGE var])
+  var in '(% %%) => throwKeyedMsg("S2IS0050",[var])
+  true
diff --git a/src/interp/metalex.lisp b/src/interp/metalex.lisp
index 2c1dd294..cc8189c6 100644
--- a/src/interp/metalex.lisp
+++ b/src/interp/metalex.lisp
@@ -570,7 +570,7 @@ empty (if File-Closed (return nil))
 
 
 (defconstant Keywords 
-  '(|or| |and| |isnt| |is| |otherwise| |when| |where|
+  '(|or| |and| |isnt| |is| |when| |where|
     |has| |with| |add| |case| |in| |by| |pretend| |mod|
     |exquo| |div| |quo| |else| |rem| |then| |suchthat|
     |if| |yield| |iterate| |from| |exit| |leave| |return|
diff --git a/src/interp/newaux.lisp b/src/interp/newaux.lisp
index 816d4e29..c0027b68 100644
--- a/src/interp/newaux.lisp
+++ b/src/interp/newaux.lisp
@@ -117,7 +117,6 @@
           (|has| 400 400)
           (|where| 121 104)     ; must be 121 for SPAD, 126 for boot--> nboot
           (|when| 112 190)
-          (|otherwise| 119 190 (|PARSE-Suffix|))
           (|is| 400 400)    (|isnt| 400 400)
           (|and| 250 251)   (|or| 200 201)
           (/\\ 250 251)   (\\/ 200 201)
@@ -159,6 +158,7 @@
           (|iterate|)
           (|yield|)
           (|if| 130 0 (|PARSE-Conditional|))    ; was 130
+          (|case| 130 190 (|PARSE-Match|))
           (\| 0 190)
           (|suchthat|)
           (|then| 0 114)
diff --git a/src/interp/parse.boot b/src/interp/parse.boot
index f4d40583..ba3a9258 100644
--- a/src/interp/parse.boot
+++ b/src/interp/parse.boot
@@ -35,6 +35,8 @@
 import postpar
 namespace BOOT
 
+module parse
+
 --% Transformation of Parser Output
 
 ++ If non nil, holds the operator being being defined.
@@ -190,6 +192,11 @@ parsePretend t ==
   $InteractiveMode => ["pretend",parseTran x,parseTran parseType typ]
   ["pretend",parseTran x,parseTran typ]
  
+parseAtAt: %ParseForm -> %Form
+parseAtAt t ==
+  t isnt ["@@",x,typ] => systemErrorHere "parseAtAt"
+  $InteractiveMode => ["@@",parseTran x,parseTran parseType typ]
+  ["@@",parseTran x,parseTran typ]
 
 parseType: %ParseForm -> %Form
 parseType x ==
@@ -542,6 +549,7 @@ for x in [["<=", :"parseLessEqual"],_
 	  ["MDEF", :"parseMDEF"],_
 	  ["or", :"parseOr"],_
 	  ["pretend", :"parsePretend"],_
+          ["@@",:"parseAtAt"],_
 	  ["return", :"parseReturn"],_
 	  ["SEGMENT", :"parseSegment"],_
 	  ["SEQ", :"parseSeq"],_
diff --git a/src/interp/pf2sex.boot b/src/interp/pf2sex.boot
index 9da4d3b4..56539978 100644
--- a/src/interp/pf2sex.boot
+++ b/src/interp/pf2sex.boot
@@ -175,6 +175,7 @@ pf2Sex1 pf ==
   case pf of
     %Exist(vars,expr) => pfQuantified2Sex("%Exist",vars,expr)
     %Forall(vars,expr) => pfQuantified2Sex("%Forall",vars,expr)
+    %Match(expr,alts) => pfCase2Sex(expr,pfParts alts)
     otherwise => keyedSystemError('"S2GE0017", ['"pf2Sex1"])
 
 pfLiteral2Sex pf ==
@@ -534,3 +535,11 @@ pfInline2Sex pf ==
 pfQualType2Sex pf ==
   -- pfQualTypeQual is always nothing.
   pf2Sex1 pfQualTypeType pf
+
+++ convert interpreter parse forms to traditional s-expressions
+pfCase2Sex(expr,alts) ==
+  ["%Match",pf2Sex1 expr, [alt2Sex alt for alt in alts]] where
+     alt2Sex alt ==
+       not pfExit? alt => 
+         systemError '"alternatives must be exit expressions"
+       [pf2Sex1 pfExitCond alt, pf2Sex1 pfExitExpr alt]
diff --git a/src/interp/postpar.boot b/src/interp/postpar.boot
index 7706a257..c045ffc7 100644
--- a/src/interp/postpar.boot
+++ b/src/interp/postpar.boot
@@ -35,6 +35,8 @@
 import macros
 namespace BOOT
 
+module postpar
+
 ++ The type of parse trees.
 %ParseTree <=> 
   %Number or %Symbol or %String or cons
@@ -141,6 +143,11 @@ postPretend t ==
   t isnt ["pretend",x,y] => systemErrorHere "postPretend"
   ["pretend",postTran x,:postType y]
 
+postAtAt: %ParseTree -> %ParseForm
+postAtAt t ==
+  t isnt ["@@",x,y] => systemErrorHere "postAtAt"
+  ["@@",postTran x,:postType y]
+
 postConstruct: %ParseTree -> %ParseForm
 postConstruct u ==
   u is ["construct",b] =>
@@ -578,6 +585,26 @@ postBootNotEqual u ==
    '"is not valid Spad.  Please use",:bright '"~=",'"instead."]
   ["~=",:postTran rest u]
 
+
+--% %Match
+
+postAlternatives alts ==
+    alts is ["%Block",:cases] => ["%Block",:[tranAlt c for c in cases]]
+    tranAlt alts
+  where
+    tranAlt c ==
+      c is ["=>",pred,conseq] => 
+        ["=>",postTran pred,postTran conseq]
+      postTran c
+
+postMatch: %ParseTree -> %ParseForm
+postMatch t ==
+  t isnt ["%Match",expr,alts] => systemErrorHere "postMatch"
+  alts :=
+    alts is [";",:.] => ["%Block",:postFlattenLeft(alts,";")]
+    alts
+  ["%Match",postTran expr, postAlternatives alts]
+
 --% Register special parse tree tranformers.
 
 for x in [["with", :"postWith"],_
@@ -600,6 +627,7 @@ for x in [["with", :"postWith"],_
 	  [":", :"postColon"],_
 	  ["@", :"postAtSign"],_
 	  ["pretend", :"postPretend"],_
+          ["@@",:"postAtAt"],_
 	  ["if", :"postIf"],_
 	  ["Join", :"postJoin"],_
 	  ["%Signature", :"postSignature"],_
@@ -608,6 +636,7 @@ for x in [["with", :"postWith"],_
 	  ["==>", :"postMDef"],_
 	  ["->", :"postMapping"],_
 	  ["=>", :"postExit"],_
+          ["%Match",:"postMatch"],_
           ["^=", :"postBootNotEqual"],_
 	  ["%Comma", :"post%Comma"]] repeat
   MAKEPROP(first x, "postTran", rest x)
diff --git a/src/interp/ptrees.boot b/src/interp/ptrees.boot
index 3ddc9d96..3f867a1d 100644
--- a/src/interp/ptrees.boot
+++ b/src/interp/ptrees.boot
@@ -446,6 +446,12 @@ pfIfCond pf == second pf       -- was ==>
 pfIfThen pf == third pf       -- was ==>
 pfIfElse pf == CADDDR pf       -- was ==>
 
+-- %Match := (Expr: Expr, Alts: [Exit])
+
+pfCase(pfexpr, pfalts) == pfTree("%Match",[pfexpr,pfalts])
+pfCase? pf == pfAbSynOp?(pf,"%Match")
+pfCaseScrutinee pf == second pf
+pfCaseAlternatives pf == third pf
 
 -- Sequence    := (Args: [Expr])