aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/c-util.boot13
-rw-r--r--src/interp/compiler.boot36
-rw-r--r--src/interp/fnewmeta.lisp10
-rw-r--r--src/interp/i-spec1.boot1
-rw-r--r--src/interp/metalex.lisp2
-rw-r--r--src/interp/newaux.lisp3
-rw-r--r--src/interp/parse.boot8
7 files changed, 61 insertions, 12 deletions
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 3d050c51..34c1ce25 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -49,6 +49,19 @@ module c_-util where
$scanIfTrue := false
+++ If within a loop, which kind? (list comprehension or plain old loop)
+$loopKind := nil
+
+++ If within a loop, the program point for the start of the body.
+$repeatBodyLabel := nil
+
+++ The number of occurrance of `iterate' in a (plain old) loop.
+$iterateCount := nil
+
+++ The number of occurrance of `break' in a (plain old) loop.
+$breakCount := 0
+
+
+++ If non nil, holds compiled value of 'Rep' of the current domain.
$Representation := nil
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 2eb63a11..13cb5951 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -397,6 +397,8 @@ transImplementation(op,map,fn) ==
["call",fn]
compAtom(x,m,e) ==
+ x = "break" => compBreak(x,m,e)
+ x = "iterate" => compIterate(x,m,e)
T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => T
x="nil" =>
T:=
@@ -1085,6 +1087,31 @@ compLeave(["leave",level,x],m,e) ==
modifyModeStack(m',index)
[["TAGGEDexit",index,u],m,e]
+jumpFromLoop(kind,key) ==
+ null $exitModeStack or kind ^= $loopKind =>
+ stackAndThrow('"You can use %1b only in %2b loop",[key,kind])
+ false
+ true
+
+compBreak: (%Symbol,%Mode,%Env) -> %Maybe %Triple
+compBreak(x,m,e) ==
+ x ^= "break" or not jumpFromLoop("REPEAT",x) => nil
+ index:= #$exitModeStack-1-$leaveLevelStack.0
+ $breakCount := $breakCount + 1
+ u := coerce(["$NoValue",$Void,e],$exitModeStack.index) or return nil
+ u := coerce(u,m) or return nil
+ modifyModeStack(u.mode,index)
+ [["TAGGEDexit",index,u],m,e]
+
+compIterate: (%Symbol,%Mode,%Env) -> %Maybe %Triple
+compIterate(x,m,e) ==
+ x ^= "iterate" or not jumpFromLoop("REPEAT",x) => nil
+ $iterateCount := $iterateCount + 1
+ -- We don't really produce a value; but we cannot adequately convey
+ -- that to the current 'EXIT' structure. So, pretend we have an
+ -- undefined value, which is a good enough approximation.
+ [["THROW","$loopBodyTag",nil],m,e]
+
--% return
compReturn: (%Form,%Mode,%Env) -> %Maybe %Triple
@@ -2272,6 +2299,9 @@ compRepeatOrCollect(form,m,e) ==
,e) where
fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) ==
$until: local := nil
+ $loopKind: local := nil
+ $iterateCount: local := 0
+ $breakCount: local := 0
oldEnv := e
aggr := nil
[repeatOrCollect,:itl,body]:= form
@@ -2293,9 +2323,15 @@ compRepeatOrCollect(form,m,e) ==
return nil
-- If we're doing a collect, and the type isn't conformable
-- then we've boobed. JHD 26.July.1990
+ -- ??? we hve a plain old loop; the return type should be Void
+ $loopKind := repeatOrCollect
$NoValueMode
[body',m',e']:=
compOrCroak(body,bodyMode,e) or return nil
+ -- Massage the loop body if we have a structured jump.
+ if $iterateCount > 0 then
+ bodyTag := quoteForm GENSYM()
+ body' := ["CATCH",bodyTag,NSUBST(bodyTag,"$loopBodyTag",body')]
if $until then
[untilCode,.,e']:= comp($until,$Boolean,e')
itl':= substitute(["UNTIL",untilCode],'$until,itl')
diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp
index 0e248f83..7df80102 100644
--- a/src/interp/fnewmeta.lisp
+++ b/src/interp/fnewmeta.lisp
@@ -113,7 +113,7 @@
;; Return: 'return' Expression +(return #1) ;
-;; Exit: 'exit' (Expression / +\$NoValue) +(exit #1) ;
+;; Exit: 'exit' Expression +(exit #1) ;
;; Leave: 'leave' ( Expression / +\$NoValue )
;; ('from' Label +(leaveFrom #1 #1) / +(leave #1)) ;
@@ -571,13 +571,19 @@
(PUSH-REDUCTION '|PARSE-Return|
(CONS '|return| (CONS (POP-STACK-1) NIL)))))
+(DEFUN |PARSE-Jump| ()
+ (LET ((S (CURRENT-SYMBOL)))
+ (AND S
+ (ACTION (ADVANCE-TOKEN))
+ (PUSH-REDUCTION '|PARSE-Jump| S))))
+
(DEFUN |PARSE-Exit| ()
(AND (MATCH-ADVANCE-STRING "exit")
(MUST (OR (|PARSE-Expression|)
(PUSH-REDUCTION '|PARSE-Exit| '|$NoValue|)))
(PUSH-REDUCTION '|PARSE-Exit|
- (CONS '|exit| (CONS (POP-STACK-1) NIL)))))
+ (CONS '|exit| (CONS (POP-STACK-1) NIL)))))
(DEFUN |PARSE-Leave| ()
diff --git a/src/interp/i-spec1.boot b/src/interp/i-spec1.boot
index 2ef75f07..20c43c79 100644
--- a/src/interp/i-spec1.boot
+++ b/src/interp/i-spec1.boot
@@ -45,7 +45,6 @@ $specialOps := '(
_[_|_|_] %Macro %MLambda %Import %Export %Inline %With %Add %Match)
$repeatLabel := NIL
-$breakCount := 0
$anonymousMapCounter := 0
++ List of free variables in the current function
diff --git a/src/interp/metalex.lisp b/src/interp/metalex.lisp
index 27b82522..0aaf9d70 100644
--- a/src/interp/metalex.lisp
+++ b/src/interp/metalex.lisp
@@ -573,7 +573,7 @@ empty (if File-Closed (return nil))
'(|or| |and| |isnt| |is| |when| |where| |forall| |exist|
|has| |with| |add| |case| |in| |by| |pretend| |mod|
|exquo| |div| |quo| |else| |rem| |then| |suchthat|
- |if| |yield| |iterate| |from| |exit| |leave| |return|
+ |if| |yield| |iterate| |break| |from| |exit| |leave| |return|
|not| |unless| |repeat| |until| |while| |for| |import| |inline|)
"Alphabetic literal strings occurring in the New Meta code constitute
diff --git a/src/interp/newaux.lisp b/src/interp/newaux.lisp
index db00f018..60475d2e 100644
--- a/src/interp/newaux.lisp
+++ b/src/interp/newaux.lisp
@@ -156,8 +156,9 @@
(|return| 202 201 (|PARSE-Return|))
(|leave| 202 201 (|PARSE-Leave|))
(|exit| 202 201 (|PARSE-Exit|))
+ (|break| 202 201 (|PARSE-Jump|))
+ (|iterate| 202 201 (|PARSE-Jump|))
(|from|)
- (|iterate|)
(|yield|)
(|if| 130 0 (|PARSE-Conditional|)) ; was 130
(|case| 130 190 (|PARSE-Match|))
diff --git a/src/interp/parse.boot b/src/interp/parse.boot
index 2a93222d..e656c023 100644
--- a/src/interp/parse.boot
+++ b/src/interp/parse.boot
@@ -70,7 +70,7 @@ parseTransform x ==
parseTran: %ParseForm -> %Form
parseTran x ==
- atom x => parseAtom x
+ atom x => x
[op,:argl]:= x
u := g(op) where g op == (op is ["elt",op,x] => g x; op)
u="construct" =>
@@ -87,12 +87,6 @@ parseType t ==
parseTypeList l ==
mapInto(l, function parseType)
-parseAtom: %Atom -> %Form
-parseAtom x ==
- -- next line for compatibility with new compiler
- x = "break" => parseLeave ["leave","$NoValue"]
- x
-
parseTranList: %List -> %List
parseTranList l ==
atom l => parseTran l