aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog16
-rw-r--r--src/algebra/strap/ILIST.lsp21
-rw-r--r--src/algebra/strap/ISTRING.lsp18
-rw-r--r--src/algebra/strap/LIST.lsp6
-rw-r--r--src/algebra/strap/OUTFORM.lsp6
-rw-r--r--src/algebra/strap/SYMBOL.lsp19
-rw-r--r--src/doc/msgs/s2-us.msgs6
-rw-r--r--src/interp/compiler.boot41
-rw-r--r--src/interp/g-opt.boot7
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-26 15:27:39 +0000