diff options
| -rw-r--r-- | src/ChangeLog | 16 | ||||
| -rw-r--r-- | src/algebra/strap/ILIST.lsp | 21 | ||||
| -rw-r--r-- | src/algebra/strap/ISTRING.lsp | 18 | ||||
| -rw-r--r-- | src/algebra/strap/LIST.lsp | 6 | ||||
| -rw-r--r-- | src/algebra/strap/OUTFORM.lsp | 6 | ||||
| -rw-r--r-- | src/algebra/strap/SYMBOL.lsp | 19 | ||||
| -rw-r--r-- | src/doc/msgs/s2-us.msgs | 6 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 41 | ||||
| -rw-r--r-- | src/interp/g-opt.boot | 7 |
9 files changed, 83 insertions, 57 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index ec9c0b71..e7b02dea 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,18 @@ +2008-12-08 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * interp/compiler.boot (compRetractAlternative): Handle domains + satisfying RetractableTo T. + * interp/g-opt.boot ($simpleVMoperators): Add a few more operators. + (optLET): Fix thinko. + +2008-12-08 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * interp/cparse.boot (npCase): New. + (npStatement): Use it. + * interp/pf2sex.boot (pfCase2Sex): New. + (pf2Sex1): Use it. + * interp/ptrees.boot: Construct %Match ASTs. + 2008-12-07 Gabriel Dos Reis <gdr@cs.tamu.edu> * interp/g-opt.boot ($simpleVMoperators): New. @@ -25,7 +40,6 @@ (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. diff --git a/src/algebra/strap/ILIST.lsp b/src/algebra/strap/ILIST.lsp index 872490b2..addea91c 100644 --- a/src/algebra/strap/ILIST.lsp +++ b/src/algebra/strap/ILIST.lsp @@ -151,26 +151,22 @@ (DEFUN |ILIST;setfirst!;$2S;10| (|x| |s| $) (COND - ((SPADCALL |x| (|getShellEntry| $ 17)) - (|error| "Cannot update an empty list")) + ((NULL |x|) (|error| "Cannot update an empty list")) ('T (QCAR (RPLACA |x| |s|))))) (DEFUN |ILIST;setelt;$first2S;11| (|x| T2 |s| $) (COND - ((SPADCALL |x| (|getShellEntry| $ 17)) - (|error| "Cannot update an empty list")) + ((NULL |x|) (|error| "Cannot update an empty list")) ('T (QCAR (RPLACA |x| |s|))))) (DEFUN |ILIST;setrest!;3$;12| (|x| |y| $) (COND - ((SPADCALL |x| (|getShellEntry| $ 17)) - (|error| "Cannot update an empty list")) + ((NULL |x|) (|error| "Cannot update an empty list")) ('T (QCDR (RPLACD |x| |y|))))) (DEFUN |ILIST;setelt;$rest2$;13| (|x| T3 |y| $) (COND - ((SPADCALL |x| (|getShellEntry| $ 17)) - (|error| "Cannot update an empty list")) + ((NULL |x|) (|error| "Cannot update an empty list")) ('T (QCDR (RPLACD |x| |y|))))) (DEFUN |ILIST;construct;L$;14| (|l| $) (DECLARE (IGNORE $)) |l|) @@ -235,8 +231,7 @@ NIL (GO G190) G191 (EXIT NIL)) (LETT |y| (NREVERSE |y|) |ILIST;coerce;$Of;21|) (EXIT (COND - ((SPADCALL |s| (|getShellEntry| $ 17)) - (SPADCALL |y| (|getShellEntry| $ 40))) + ((NULL |s|) (SPADCALL |y| (|getShellEntry| $ 40))) ('T (SEQ (LETT |z| (SPADCALL @@ -475,10 +470,8 @@ (SEQ (COND ((EQL |n| 2) (COND - ((SPADCALL - (SPADCALL (SPADCALL |p| (|getShellEntry| $ 18)) - (|getShellEntry| $ 13)) - (SPADCALL |p| (|getShellEntry| $ 13)) |f|) + ((SPADCALL (|SPADfirst| (CDR |p|)) (|SPADfirst| |p|) + |f|) (LETT |p| (NREVERSE |p|) |ILIST;mergeSort|))))) (EXIT (COND ((< |n| 3) |p|) diff --git a/src/algebra/strap/ISTRING.lsp b/src/algebra/strap/ISTRING.lsp index d3c63504..d9dea6b1 100644 --- a/src/algebra/strap/ISTRING.lsp +++ b/src/algebra/strap/ISTRING.lsp @@ -702,8 +702,7 @@ (|getShellEntry| $ 6)))) |ISTRING;elt;$Us$;31|) (COND - ((OR (< |l| 0) - (NULL (< |h| (SPADCALL |s| (|getShellEntry| $ 13))))) + ((OR (< |l| 0) (NULL (< |h| (QCSIZE |s|)))) (EXIT (|error| "index out of bound")))) (EXIT (SUBSTRING |s| |l| (MAX 0 (+ (- |h| |l|) 1)))))))) @@ -768,10 +767,11 @@ (COND ((NULL (SPADCALL - (SPADCALL |pattern| + (|ISTRING;elt;$Us$;31| + |pattern| (SPADCALL |m| (- |p| 1) (|getShellEntry| $ 20)) - (|getShellEntry| $ 21)) + $) |target| (|getShellEntry| $ 72))) (EXIT 'NIL))))) @@ -842,13 +842,13 @@ (|getShellEntry| $ 71)) (COND ((NULL - (SPADCALL - (SPADCALL |pattern| + (|ISTRING;suffix?;2$B;21| + (|ISTRING;elt;$Us$;31| + |pattern| (SPADCALL (+ |p| 1) |n| (|getShellEntry| $ 20)) - (|getShellEntry| $ 21)) - |target| - (|getShellEntry| $ 51))) + $) + |target| $)) (EXIT 'NIL))))) (EXIT 'T))))))) #3# (EXIT #3#))))) diff --git a/src/algebra/strap/LIST.lsp b/src/algebra/strap/LIST.lsp index c97fecf3..43656399 100644 --- a/src/algebra/strap/LIST.lsp +++ b/src/algebra/strap/LIST.lsp @@ -164,7 +164,7 @@ (EXIT |lu|))))) (DEFUN |LIST;convert;$If;13| (|x| $) - (PROG (#0=#:G1447 |a| #1=#:G1448) + (PROG (#0=#:G1442 |a| #1=#:G1443) (RETURN (SEQ (SPADCALL (CONS (SPADCALL @@ -191,10 +191,10 @@ (GO G190) G191 (EXIT (NREVERSE0 #0#))))) (|getShellEntry| $ 44)))))) -(DEFUN |List| (#0=#:G1449) +(DEFUN |List| (#0=#:G1444) (PROG () (RETURN - (PROG (#1=#:G1450) + (PROG (#1=#:G1445) (RETURN (COND ((LETT #1# diff --git a/src/algebra/strap/OUTFORM.lsp b/src/algebra/strap/OUTFORM.lsp index d89865c0..027e0a17 100644 --- a/src/algebra/strap/OUTFORM.lsp +++ b/src/algebra/strap/OUTFORM.lsp @@ -668,7 +668,7 @@ (DEFUN |OUTFORM;prefix;$L$;76| (|a| |l| $) (COND - ((NULL (SPADCALL |a| (|getShellEntry| $ 98))) (CONS |a| |l|)) + ((NULL (|OUTFORM;infix?;$B;74| |a| $)) (CONS |a| |l|)) ('T (|OUTFORM;hconcat;3$;48| |a| (|OUTFORM;paren;2$;40| (|OUTFORM;commaSeparate;L$;33| |l| $) @@ -681,7 +681,7 @@ ((SPADCALL (SPADCALL |l| (|getShellEntry| $ 69)) (|getShellEntry| $ 68)) (SPADCALL |l| (|getShellEntry| $ 70))) - ((SPADCALL |a| (|getShellEntry| $ 98)) (CONS |a| |l|)) + ((|OUTFORM;infix?;$B;74| |a| $) (CONS |a| |l|)) ('T (|OUTFORM;hconcat;L$;49| (LIST (SPADCALL |l| (|getShellEntry| $ 70)) |a| @@ -691,7 +691,7 @@ (DEFUN |OUTFORM;infix;4$;78| (|a| |b| |c| $) (COND - ((SPADCALL |a| (|getShellEntry| $ 98)) + ((|OUTFORM;infix?;$B;74| |a| $) (|OUTFORM;bless| (LIST |a| |b| |c|) $)) ('T (|OUTFORM;hconcat;L$;49| (LIST |b| |a| |c|) $)))) diff --git a/src/algebra/strap/SYMBOL.lsp b/src/algebra/strap/SYMBOL.lsp index cbbd5a3b..8c1044f6 100644 --- a/src/algebra/strap/SYMBOL.lsp +++ b/src/algebra/strap/SYMBOL.lsp @@ -115,7 +115,7 @@ (DEFUN |SYMBOL;writeOMSym| (|dev| |x| $) (COND - ((SPADCALL |x| (|getShellEntry| $ 22)) + ((|SYMBOL;scripted?;$B;30| |x| $) (|error| "Cannot convert a scripted symbol to OpenMath")) ('T (SPADCALL |dev| |x| (|getShellEntry| $ 26))))) @@ -293,7 +293,7 @@ (DEFUN |SYMBOL;script;$R$;23| (|sy| |sc| $) (COND - ((SPADCALL |sy| (|getShellEntry| $ 22)) + ((|SYMBOL;scripted?;$B;30| |sy| $) (|error| "Cannot add scripts to a scripted symbol")) ('T (CONS (|SYMBOL;coerce;$Of;11| @@ -307,7 +307,7 @@ (DEFUN |SYMBOL;string;$S;24| (|e| $) (COND - ((NULL (SPADCALL |e| (|getShellEntry| $ 22))) (PNAME |e|)) + ((NULL (|SYMBOL;scripted?;$B;30| |e| $)) (PNAME |e|)) ('T (|error| "Cannot form string from non-atomic symbols.")))) (DEFUN |SYMBOL;latex;$S;25| (|e| $) @@ -323,8 +323,7 @@ (|getShellEntry| $ 86)) (LETT |s| (STRCONC "\\mbox{\\it " (STRCONC |s| "}")) |SYMBOL;latex;$S;25|))))) - (COND - ((NULL (SPADCALL |e| (|getShellEntry| $ 22))) (EXIT |s|))) + (COND ((NULL (|SYMBOL;scripted?;$B;30| |e| $)) (EXIT |s|))) (LETT |ss| (|SYMBOL;scripts;$R;32| |e| $) |SYMBOL;latex;$S;25|) (LETT |lo| (QVELT |ss| 0) |SYMBOL;latex;$S;25|) @@ -511,7 +510,7 @@ (|getShellEntry| $ 98)) (LETT |xx| (COND - ((NULL (SPADCALL |x| (|getShellEntry| $ 22))) + ((NULL (|SYMBOL;scripted?;$B;30| |x| $)) (|SYMBOL;string;$S;24| |x| $)) ('T (|SYMBOL;string;$S;24| (|SYMBOL;name;2$;31| |x| $) @@ -538,7 +537,7 @@ (|getShellEntry| $ 18) $)))) |SYMBOL;new;2$;28|) (COND - ((NULL (SPADCALL |x| (|getShellEntry| $ 22))) + ((NULL (|SYMBOL;scripted?;$B;30| |x| $)) (EXIT (|SYMBOL;coerce;S$;8| |xx| $)))) (EXIT (|SYMBOL;script;$R$;23| (|SYMBOL;coerce;S$;8| |xx| $) (|SYMBOL;scripts;$R;32| |x| $) $)))))) @@ -572,7 +571,7 @@ (PROG (|str| |i| #0=#:G1551 #1=#:G1531 #2=#:G1529) (RETURN (SEQ (EXIT (COND - ((NULL (SPADCALL |sy| (|getShellEntry| $ 22))) |sy|) + ((NULL (|SYMBOL;scripted?;$B;30| |sy| $)) |sy|) ('T (SEQ (LETT |str| (|SYMBOL;string;$S;24| @@ -626,7 +625,7 @@ #1=#:G1552 |i| #2=#:G1553 |a| #3=#:G1554 |allscripts|) (RETURN (SEQ (COND - ((NULL (SPADCALL |sy| (|getShellEntry| $ 22))) + ((NULL (|SYMBOL;scripted?;$B;30| |sy| $)) (VECTOR NIL NIL NIL NIL NIL)) ('T (SEQ (LETT |nscripts| (LIST 0 0 0 0 0) @@ -764,7 +763,7 @@ (DEFUN |SYMBOL;list;$L;34| (|sy| $) (COND - ((NULL (SPADCALL |sy| (|getShellEntry| $ 22))) + ((NULL (|SYMBOL;scripted?;$B;30| |sy| $)) (|error| "Cannot convert a symbol to a list if it is not subscripted")) ('T |sy|))) diff --git a/src/doc/msgs/s2-us.msgs b/src/doc/msgs/s2-us.msgs index 10e02373..c47c0854 100644 --- a/src/doc/msgs/s2-us.msgs +++ b/src/doc/msgs/s2-us.msgs @@ -580,9 +580,13 @@ S2IS0060 the setelt operation. S2IS0061 Unknown type of loop iterator form. -S2IS0061 +S2IS0062 There is no operation named %1b with type %2p in the domain or package %3p. +S2IS0063 + The pattern %1b is invalid because scrutinee is not of mode %b Any %d +S2IS0064 + Could not resolve types %1pb and %2pb. S2IT0001 %1b can have no other options. S2IT0002 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 |