diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/c-util.boot | 44 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 34 | ||||
| -rw-r--r-- | src/interp/wi2.boot | 55 |
3 files changed, 43 insertions, 90 deletions
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index 4df0052f..aeb37a22 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -44,6 +44,8 @@ module c_-util where declareUnusedParameters: (%List,%Code) -> %List registerFunctionReplacement: (%Symbol,%Form) -> %Thing getFunctionReplacement: %Symbol -> %Form + getSuccessEnvironment: (%Form,%Env) -> %Env + getInverseEnvironment: (%Form,%Env) -> %Env --% @@ -384,7 +386,47 @@ makeCommonEnvironment(e,e') == nx>ny => fn(rest x,y,nx-1,ny) nx<ny => fn(x,rest y,nx,ny-1) [x,y] - + +++ Return the lexically leftmost location in an assignment for. +lhsOfAssignment x == + x is ["%LET",lhs,:.] => lhsOfAssignment lhs + x + +getSuccessEnvironment(a,e) == + a is ["is",id,m] => + id := lhsOfAssignment id + IDENTP id and isDomainForm(m,$EmptyEnvironment) => + e:=put(id,"specialCase",m,e) + currentProplist:= getProplist(id,e) + [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs + newProplist:= consProplistOf(id,currentProplist,"value",[m,:rest removeEnv T]) + addBinding(id,newProplist,e) + e + a is ["case",x,m] and (x := lhsOfAssignment x) and IDENTP x => + put(x,"condition",[a,:get(x,"condition",e)],e) + a is ["and",:args] => + for form in args repeat + e := getSuccessEnvironment(form,e) + e + a is ["not",a'] => getInverseEnvironment(a',e) + e + +getInverseEnvironment(a,e) == + a is ["case",x,m] and (x := lhsOfAssignment x) and IDENTP x => + --the next two lines are necessary to get 3-branched Unions to work + -- old-style unions, that is + (get(x,"condition",e) is [["OR",:oldpred]]) and member(a,oldpred) => + put(x,"condition",LIST MKPF(delete(a,oldpred),"OR"),e) + getUnionMode(x,e) is ["Union",:l] => + l':= delete(m,l) + for u in l' repeat + if u is ['_:,=m,:.] then l':= delete(u,l') + newpred:= MKPF([["case",x,m'] for m' in l'],"OR") + put(x,"condition",[newpred,:get(x,"condition",e)],e) + e + a is ["not",a'] => getSuccessEnvironment(a',e) + e + printEnv E == for x in E for i in 1.. repeat for y in x for j in 1.. repeat diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index 74847aaa..2e0beda4 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -1258,40 +1258,6 @@ compPredicate(p,E) == [p',m,E] := comp(p,$Boolean,E) or return nil [p',m,getSuccessEnvironment(p,E),getInverseEnvironment(p,E)] -getSuccessEnvironment(a,e) == - a is ["is",id,m] => - IDENTP id and isDomainForm(m,$EmptyEnvironment) => - e:=put(id,"specialCase",m,e) - currentProplist:= getProplist(id,e) - [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs - newProplist:= consProplistOf(id,currentProplist,"value",[m,:rest removeEnv T]) - addBinding(id,newProplist,e) - e - a is ["case",x,m] and IDENTP x => - put(x,"condition",[a,:get(x,"condition",e)],e) - a is ["and",:args] => - for form in args repeat - e := getSuccessEnvironment(form,e) - e - a is ["not",a'] => getInverseEnvironment(a',e) - e - -getInverseEnvironment(a,e) == - a is ["case",x,m] and IDENTP x => - --the next two lines are necessary to get 3-branched Unions to work - -- old-style unions, that is - (get(x,"condition",e) is [["OR",:oldpred]]) and member(a,oldpred) => - put(x,"condition",LIST MKPF(delete(a,oldpred),"OR"),e) - getUnionMode(x,e) is ["Union",:l] => - l':= delete(m,l) - for u in l' repeat - if u is ['_:,=m,:.] then l':= delete(u,l') - newpred:= MKPF([["case",x,m'] for m' in l'],"OR") - put(x,"condition",[newpred,:get(x,"condition",e)],e) - e - a is ["not",a'] => getSuccessEnvironment(a',e) - e - getUnionMode(x,e) == m:= atom x => getmode(x,e) diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot index c66763cf..31983811 100644 --- a/src/interp/wi2.boot +++ b/src/interp/wi2.boot @@ -408,61 +408,6 @@ macroExpand(x,e) == --not worked out yet ['MI,a,macroExpand(b,e)] macroExpandList(x,e) -getSuccessEnvironment(a,e) == - -- the next four lines try to ensure that explicit special-case tests - -- prevent implicit ones from being generated - a is ["has",x,m] => - x := unLet x - IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,e) - e - a is ["is",id,m] => - id := unLet id - IDENTP id and isDomainForm(m,$EmptyEnvironment) => - e:=put(id,"specialCase",m,e) - currentProplist:= getProplist(id,e) - [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs - newProplist:= consProplistOf(id,currentProplist,"value",removeEnv T) - addBinding(id,newProplist,e) - e - a is ["case",x,m] and (x := unLet x) and IDENTP x => - put(x,"condition",[a,:get(x,"condition",e)],e) - e - -getInverseEnvironment(a,E) == - atom a => E - [op,:argl]:= a --- the next five lines try to ensure that explicit special-case tests --- prevent implicit ones from being generated - op="has" => - [x,m]:= argl - x := unLet x - IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,E) - E - a is ["case",x,m] and (x := unLet x) and IDENTP x => - --the next two lines are necessary to get 3-branched Unions to work - -- old-style unions, that is - if corrupted? get(x,"condition",E) then systemError 'condition - (get(x,"condition",E) is [["OR",:oldpred]]) and member(a,oldpred) => - put(x,"condition",LIST MKPF(delete(a,oldpred),"OR"),E) - getUnionMode(x,E) is ["Union",:l] or systemError 'Union - if corrupted? l then systemError 'list - l':= delete(m,l) - for u in l' repeat - if u is ['_:,=m,:.] then l':= delete(u,l') - newpred:= MKPF([["case",x,m'] for m' in l'],"OR") - put(x,"condition",[newpred,:get(x,"condition",E)],E) - E - -unLet x == - x is ["%LET",u,:.] => unLet u - x - -corrupted? u == - u is [op,:r] => - op in '(WI MI PART) => true - or/[corrupted? x for x in r] - false - --====================================================================== -- From apply.boot --====================================================================== |