aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/c-util.boot39
-rw-r--r--src/interp/compiler.boot134
-rw-r--r--src/interp/cparse.boot12
-rw-r--r--src/interp/fnewmeta.lisp10
-rw-r--r--src/interp/g-opt.boot66
-rw-r--r--src/interp/i-funsel.boot2
-rw-r--r--src/interp/i-intern.boot1
-rw-r--r--src/interp/i-spec1.boot6
-rw-r--r--src/interp/i-spec2.boot7
-rw-r--r--src/interp/i-util.boot7
-rw-r--r--src/interp/metalex.lisp2
-rw-r--r--src/interp/newaux.lisp2
-rw-r--r--src/interp/parse.boot8
-rw-r--r--src/interp/pf2sex.boot9
-rw-r--r--src/interp/postpar.boot29
-rw-r--r--src/interp/ptrees.boot6
16 files changed, 330 insertions, 10 deletions
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])
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-20 16:52:46 +0000