diff options
Diffstat (limited to 'src/interp/compiler.boot')
| -rw-r--r-- | src/interp/compiler.boot | 238 |
1 files changed, 154 insertions, 84 deletions
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] |