aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/ChangeLog4
-rw-r--r--src/interp/g-opt.boot50
2 files changed, 31 insertions, 23 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 37e87fe7..c17550cc 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,9 @@
2009-07-13 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * interp/g-opt.boot (optCatch): Lift nested functions.
+
+2009-07-13 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* interp/metalex.lisp: "break" is now a keyword.
* interp/fnewmeta.lisp (PARSE-Jump): New.
* interp/compiler.boot (compAtom): Dipatch compilation of "break"
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index f3a29f81..9e08d9a8 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -114,36 +114,40 @@ subrname u ==
COMPILED_-FUNCTION_-P u or MBPIP u => BPINAME u
nil
+changeThrowToExit(s,g) ==
+ atom s or MEMQ(first s,'(QUOTE SEQ REPEAT COLLECT)) => nil
+ s is ["THROW", =g,:u] => (rplac(first s,"EXIT"); rplac(rest s,u))
+ changeThrowToExit(first s,g)
+ changeThrowToExit(rest s,g)
+
+hasNoThrows(a,g) ==
+ a is ["THROW", =g,:.] => false
+ atom a => true
+ hasNoThrows(first a,g) and hasNoThrows(rest a,g)
+
+changeThrowToGo(s,g) ==
+ atom s or first s='QUOTE => nil
+ s is ["THROW", =g,u] =>
+ changeThrowToGo(u,g)
+ rplac(first s,"PROGN")
+ rplac(rest s,[["%LET",second g,u],["GO",second g]])
+ changeThrowToGo(first s,g)
+ changeThrowToGo(rest s,g)
+
optCatch (x is ["CATCH",g,a]) ==
$InteractiveMode => x
atom a => a
if a is ["SEQ",:s,["THROW", =g,u]] then
- changeThrowToExit(s,g) where
- changeThrowToExit(s,g) ==
- atom s or MEMQ(first s,'(QUOTE SEQ REPEAT COLLECT)) => nil
- s is ["THROW", =g,:u] => (rplac(first s,"EXIT"); rplac(rest s,u))
- changeThrowToExit(first s,g)
- changeThrowToExit(rest s,g)
+ changeThrowToExit(s,g)
rplac(rest a,[:s,["EXIT",u]])
["CATCH",y,a]:= optimize x
- if hasNoThrows(a,g) where
- hasNoThrows(a,g) ==
- a is ["THROW", =g,:.] => false
- atom a => true
- hasNoThrows(first a,g) and hasNoThrows(rest a,g)
- then (rplac(first x,first a); rplac(rest x,rest a))
- else
- changeThrowToGo(a,g) where
- changeThrowToGo(s,g) ==
- atom s or first s='QUOTE => nil
- s is ["THROW", =g,u] =>
- changeThrowToGo(u,g)
- rplac(first s,"PROGN")
- rplac(rest s,[["%LET",CADR g,u],["GO",CADR g]])
- changeThrowToGo(first s,g)
- changeThrowToGo(rest s,g)
+ if hasNoThrows(a,g) then
+ rplac(first x,first a)
+ rplac(rest x,rest a)
+ else
+ changeThrowToGo(a,g)
rplac(first x,"SEQ")
- rplac(rest x,[["EXIT",a],CADR g,["EXIT",CADR g]])
+ rplac(rest x,[["EXIT",a],second g,["EXIT",second g]])
x
optSPADCALL(form is ['SPADCALL,:argl]) ==