From 3351c2b4a9ce2106178bd1eae40b7559b03ba621 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Tue, 9 Dec 2008 02:35:52 +0000 Subject: r12415@gauss: gdr | 2008-12-06 11:42:45 -0600 Implement basic support for pattern matching. r12416@gauss: gdr | 2008-12-06 18:09:19 -0600 Parse case pattern match. r12417@gauss: gdr | 2008-12-06 21:28:30 -0600 Implement basic case pattern matching for retractable domain. r12418@gauss: gdr | 2008-12-07 00:58:58 -0600 Refine retractability implementation. r12419@gauss: gdr | 2008-12-07 01:39:32 -0600 Update cached Lisp translation r12420@gauss: gdr | 2008-12-07 03:52:09 -0600 r12421@gauss: gdr | 2008-12-07 10:30:44 -0600 Implement type recovery too. r12422@gauss: gdr | 2008-12-07 19:18:09 -0600 Simplify LET-forms and COND-forms. r12423@gauss: gdr | 2008-12-07 21:21:12 -0600 Fix typos r12424@gauss: gdr | 2008-12-08 01:14:54 -0600 Parse case-pattern in the interpreter. r12427@gauss: gdr | 2008-12-08 20:32:29 -0600 Handle RetractableTo T. --- src/interp/compiler.boot | 41 ++++++++++++++++++++++++++++------------- src/interp/g-opt.boot | 7 ++++--- 2 files changed, 32 insertions(+), 16 deletions(-) (limited to 'src/interp') diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index a297b448..5aa9e6cb 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -1757,25 +1757,40 @@ compRetractAlternative(x,t,stmt,m,s,T) == -- convertible to t (using only courtesy coerciions) or that -- `y' is retractable to t. -- - -- 1. Evaluate the retract condition. + -- 1. Evaluate the retract condition, and retract. 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'. + 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 := compBoolean(["case",y,t],$Boolean,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]) + -- 1.2. Otherwise try retractIfCan, for those `% has RetractableTo t'. + else if retractT := comp(["retractIfCan",y],["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 + -- the condition and the body of the alternative, so just use + -- assignment here and let the rest of the compiler deal with it. + z := GENSYM() + 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]) + -- 2. 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. + -- 3. 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. + -- 4. Generate code for the whole pattern. code := [caseCode, ["LET",[[x,restrictCode]],stmtT.expr]] [code,stmtT.mode,stmtT.env,envFalse] diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot index 2b194c76..30e253f2 100644 --- a/src/interp/g-opt.boot +++ b/src/interp/g-opt.boot @@ -380,8 +380,8 @@ optEQ u == u $simpleVMoperators == - '(CONS CAR CDR LENGTH SIZE EQUAL EQL EQ - INTEGERP FLOATP STRINGP IDENTP SYMBOLP) + '(CONS CAR CDR LENGTH SIZE EQUAL EQL EQ NOT NULL OR AND + QEQCAR QCDR QCAR INTEGERP FLOATP STRINGP IDENTP SYMBOLP) isSimpleVMForm form == isAtomicForm form => true @@ -423,13 +423,14 @@ optLET u == 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. + -- we do not attempt more complicated 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 := false continue => body u not MEMQ(op,$simpleVMoperators) => u -- cgit v1.2.3