[e-lang] A simple interpreter for Kernel-E

[Kevin Reid]

This is a mostly-correct mostly-absorptive interpreter for Kernel-E  
(except for ObjectExprs).

I wrote it as an experiment to see if using it to execute the  
expressions in Updoc scripts in E-on-CL would be more efficient than  
compiling each expression. (It isn't, at the moment, but I intend to  
add ObjectExpr and see whether that's an improvement.)

It would require some changes to run on E-on-Java, due to lack of  
methods for manipulating Scopes directly.


# Copyright 2006 Kevin Reid, under the terms of the MIT X license
# found at http://www.opensource.org/licenses/mit- 
license.html ................

pragma.enable("easy-return")
pragma.disable("explicit-result-guard")

pragma.enable("accumulator")

def Nothing implements DeepFrozen {
   to coerce(_, optEjector) {
     throw.eject(optEjector, "Nothing")
   }
}

def makeInterpreter implements DeepFrozen {
   to run() {
     def interpreter

     def InterpMatches(pattern, &scope) {
       return def matcher {
         to coerce(specimen, optEjector) {
           interpreter."match"(pattern, &scope, specimen, optEjector)
           return specimen
         }
       }
     }

     bind interpreter {
       # XXX if this is a privileged interpreter (can approve audits)  
then the scope must be an ungimmicked var slot or the user could make  
misbehaving objects
       # separate issue: a maximally POLA interpreter would use  
dynamic-extent scope passing so that side effects can't happen at  
surprising later times
       to run(expr, &scope) {

         def hide() {
           return __makeVarSlot(scope.nestOuter())
         }

         return expr.welcome(def visitor {

           to visitAssignExpr(_, left, right) {
             def value := interpreter(right, &scope)
             scope.getSlot(left.getName()).setValue(value)
             return value
           }

           to visitCallExpr(_, recipient, verb, args) {
             # XXX replace inefficient with-chain with a presized list
             # xxx it would be nice to avoid allocating the arglist here
             return E.call(interpreter(recipient, &scope),
                           verb,
                           accum [] for argExpr in args {
                             _.with(interpreter(argExpr, &scope)) })
           }

           to visitCatchExpr(_, body, catchPatt, catchExpr) {
             try {
               return interpreter(body, hide())
             } catch p :InterpMatches(catchPatt, def &catchScope :=  
hide()) {
               return interpreter(catchExpr, &catchScope)
             }
           }

           to visitEscapeExpr(_, ejPattern, body, catchPattern,  
catchExpr) {
             def &catchScope := hide()
             return escape ejector {
               def name := ejPattern.getOptPrincipalNoun()
               # This renaming is a mess.
               def renamedEjector {
                 to __printOn(out :TextWriter) {
                   out.write("<")
                   out.print(name)
                   out.write(" ejector>")
                 }

                 to run() { renamedEjector.run(null) }

                 to run(value) {
                   try {
                     ejector(value)
                   } catch _ { # only possible cause of failure
                     # XXX typed exception
                     throw(`ejector ${E.toQuote(name)} no longer in  
scope`)
                   }
                 }
               }
               def &tryScope := hide()
               interpreter."match"(ejPattern, &tryScope,  
renamedEjector, null)
               interpreter(body, &tryScope)
             } catch escapeValue :if (catchPattern != null)  
{InterpMatches(catchPattern, &catchScope)} else {Nothing} {
               interpreter(catchExpr, &catchScope)
             }
           }

           to visitDefineExpr(_, left, right, ejectorExpr) {
             # XXX left-does-not-refer-to-right check
             def value := interpreter(right, &scope)
             def ejector := if (ejectorExpr != null) {
                              interpreter(ejectorExpr, &scope)
                            }
             interpreter."match"(left, &scope, value, ejector)
             return value
           }

           to visitFinallyExpr(_, body, unwinder) {
             return try {
                      interpreter(body, hide())
                    } finally {
                      interpreter(unwinder, hide())
                    }
           }

           to visitHideExpr(_, sub) {
             return interpreter(sub, hide())
           }

           to visitIfExpr(_, test, thenExpr, elseExpr) {
             def &trueScope := hide()
             return if (interpreter(test, &trueScope)) {
                      interpreter(thenExpr, &trueScope)
                    } else {
                      interpreter(elseExpr, hide())
                    }
           }

           to visitLiteralExpr(_, value) {
             return value
           }

           to visitMatchBindExpr(_, specimenExpr, pattern) {
             def specimen := interpreter(specimenExpr, &scope)
             escape fail {
               interpreter."match"(pattern, &scope, specimen, fail)
               return true
             } catch patternFailure {
               def smashed := Ref.broken(patternFailure)
               for name => _ in pattern.staticScope().varNames() {
                 scope := scope.withSlot(name, smashed)
               }
               for name => _ in pattern.staticScope().defNames() {
                 scope := scope.with(name, smashed)
               }
               return false
             }
           }

           to visitMetaContextExpr(_) {
             def prefix :String := scope.getFQNPrefix()
             return def metaContext implements DeepFrozen {
               to __printOn(out :TextWriter) {
                 out.print("<static context>")
               }

               to getFQNPrefix() { return prefix }
             }
           }

           to visitMetaStateExpr(_) {
             # XXX variously wrong
             return scope
           }

           to visitNounExpr(_, noun) {
             return scope.fetch(noun, thunk { throw(`undefined  
variable: $noun`) })
           }

           to visitObjectExpr(objectExpr, _, _, _, _) {
             # punt
             def [value, newScope] := objectExpr.evalToPair(scope)
             scope := newScope
             return value
           }

           to visitSeqExpr(_, subs :List) {
             var lastValue := "can't happen"
             require(subs.size().aboveZero(), thunk {`SeqExpr with no  
subexpressions`})
             for sub in subs {
               lastValue := interpreter(sub, &scope)
             }
             return lastValue
           }

           to visitSlotExpr(_, nounExpr) {
             def noun := nounExpr.getName()
             return if (scope.maps(noun)) {
                      scope.getSlot(noun)
                    } else {
                      throw(`undefined variable: $noun`)
                    }
           }

         })
       }

       to "match"(pattern, &scope, specimen, ejector) {
         return pattern.welcome(def visitor {
           to visitCdrPattern(_, listPattern, restPattern) {
             def list := List.coerce(specimen, ejector)
             def subs := listPattern.getSubs()
             if ((def ss := subs.size()) > (def ls := list.size())) {
               throw.eject(ejector, `a $ls size list doesn't match a  
 >= $ss size list pattern`)
             }
             for i => subPattern in subs {
               interpreter."match"(subPattern, &scope, list[i], ejector)
             }
             interpreter."match"(restPattern, &scope, list.run 
(subs.size()), ejector)
           }

           to visitFinalPattern(_, nounExpr, optGuardExpr) {
             if (optGuardExpr =~ guardExpr :notNull) {
               scope := scope.with(nounExpr.getName(),
                                   interpreter(guardExpr, &scope) \
                                     .coerce(specimen, ejector))
             } else {
               scope := scope.with(nounExpr.getName(), specimen)
             }
           }

           to visitIgnorePattern(_) {
             # Nothing happens.
           }

           to visitListPattern(_, subs) {
             def list := List.coerce(specimen, ejector)
             if ((def ss := subs.size()) != (def ls := list.size())) {
               throw.eject(ejector, `a $ls size list doesn't match a  
$ss size list pattern`)
             }
             for i => subPattern in subs {
               interpreter."match"(subPattern, &scope, list[i], ejector)
             }
           }

           to visitSlotPattern(_, nounExpr, optGuardExpr) {
             if (optGuardExpr =~ guardExpr :notNull) {
               scope := scope.withSlot(nounExpr.getName(),
                                       interpreter(guardExpr, &scope) \
                                         .coerce(specimen, ejector))
             } else {
               scope := scope.withSlot(nounExpr.getName(), specimen)
             }
           }

           to visitSuchThatPattern(_, subPattern, test) {
             interpreter."match"(subPattern, &scope, specimen, ejector)
             def ok :boolean := interpreter(test, &scope)
             if (!ok) {
               # XXX should throw the Lisp-side exception type such- 
that-error
               throw.eject(ejector, "<such-that-error: " + E.toString 
(test) + " was false for " + E.toQuote(specimen) + ">")
             }
           }

           to visitVarPattern(_, nounExpr, optGuardExpr) {
             if (optGuardExpr =~ guardExpr :notNull) {
               scope := scope.withSlot(nounExpr.getName(),
                 __makeGuardedSlot(interpreter(guardExpr, &scope),
                                   specimen,
                                   ejector))
             } else {
               scope := scope.withSlot(nounExpr.getName(),
                                       __makeVarSlot(specimen))
             }
           }
         })
       }
     }
     return interpreter
   }
}


-- 
Kevin Reid                            <http://homepage.mac.com/kpreid/>