structure BriLang = struct exception Exn of string; datatype Op = Add | Sub | Mul | Div | Lt | Gt | Le | Ge | Assign | Equals | NotEquals | Question | And | Or | LogicalAnd | LogicalOr | NumericNegate | BinaryNegate | LogicalNegate | Hd | Tl | Cons | Append; datatype Token = Num of int | Identifier of string | StringLiteral of string | Semi | RCurly | LCurly | LParen | RParen | Comma | OpToken of Op | If | Then | Else | Fn | True | False | Null | Colon | Switch | Case | Default | Nil | Rb | Lb | Catch | Throw; datatype Expr = Constant of Value | Variable of string | BinaryExpr of Expr*Op*Expr | UnaryExpr of Op*Expr | AssignExpr of string*Expr | LambdaExpr of string list * Expr | CallExpr of Expr * Expr list | IfExpr of Expr*Expr*Expr | SequenceExpr of Expr list | CaseExpr of Expr * (Expr*Expr) list * Expr option | ListExpr of Expr list | ExceptionHandlerExpr of Expr*string*Expr | ThrowExpr of Expr and Value = StringValue of string | IntValue of int | BoolValue of bool | ListValue of Value list | LambdaValue of string list*Expr*Scope | NullValue | NativeLambdaValue of (Value list -> Value) and Scope = ScopeVal of string*Value*Scope | ScopeTop; exception LangExn of Value; (* helper stuff *) fun foldleft f (e,[]) = e | foldleft f (e,x::xs) = foldleft f (f(e,x), xs); fun isDigit c = c>= #"0" andalso c<= #"9"; fun isAlpha c = c>= #"A" andalso c<= #"Z" orelse c>= #"a" andalso c<= #"z"; fun isAlphaNum c = isAlpha c orelse isDigit c; fun isSpace c = c= #" " orelse c= #"\n"; fun charToInt c = ord(c)-ord(#"0"); fun unaryOp x = (case x of NumericNegate => true | BinaryNegate => true | LogicalNegate => true | Hd => true | Tl => true | _ => false); fun toString(IntValue(i)) = let val s = Int.toString(i) in case (explode s) of (#"~"::rest) => implode(#"-"::rest) | _ => s end | toString(NullValue) = "null" | toString(BoolValue(b)) = if b then "true" else "false" | toString(LambdaValue(_,_,_)) = "*Function*" | toString(NativeLambdaValue(_)) = "*Native Function*" | toString(StringValue(s)) = s | toString(ListValue(l)) = let fun helper(a::b::r,s) = helper(b::r,s^(toString a)^", ") | helper(a::r,s) = helper(r,s^(toString a)) | helper(nil,s) = s^"]" in helper(l,"[") end fun toInt(IntValue(i)) = i | toInt(StringValue(s)) = (case Int.fromString(s) of SOME(i) => i | NONE => 0) | toInt(BoolValue(b)) = if b then 1 else 0 | toInt NullValue = 0 | toInt _ = raise Exn("Can't coerce to an int"); fun toBool(IntValue(i)) = i <> 0 | toBool(StringValue(s)) = s <> "" | toBool(BoolValue(b)) = b | toBool NullValue = false | toBool _ = true; fun toList(ListValue(l)) = l | toList(v) = [v]; fun cmp(StringValue(x),StringValue(y)) = if x = y then 0 else if x < y then ~1 else 1 | cmp(v1,v2) = toInt(v1) - toInt(v2); fun printValue v = TextIO.print(toString(v)^"\n"); fun opDesc x = case x of Add => "add" | Sub => "sub" | Mul => "mul" | Div => "div" | Assign => "assign" | Equals => "equals" | Question => "question" | Le => "le" | Ge => "ge" | Lt => "lt" | Gt => "gt" | And => "and" | Or => "or" | LogicalAnd => "logical and" | LogicalOr => "logical or" | _ => raise Fail("unknown operator in opDesc"); fun tokDesc v = case v of (Num(i)) => "Integer: " ^ Int.toString(i) | (Identifier(s)) => "Identifier: " ^ s | (StringLiteral(s)) => "Literal: "^ s | (OpToken(x)) => "OpToken: " ^ opDesc(x) | Semi => "Semi" | RCurly => "RCurly" | LCurly => "LCurly" | LParen => "LParen" | RParen => "RParen" | Comma => "Comma" | If => "if" | Else => "else" | Then => "then" | Fn => "fn" | True => "true" | False => "false" | Null => "null" | Colon => "colon" | Case => "case" | Switch => "switch" | Default => "default" | Nil => "nil" | Lb => "Lb" | Rb => "Rb" | Catch => "catch" | Throw => "throw"; fun prec x = case x of NumericNegate => 12 | BinaryNegate => 12 | LogicalNegate => 12 | Hd => 12 | Tl => 12 | Mul => 11 | Div => 11 | Add => 10 | Sub => 10 | Gt => 9 | Lt => 9 | Le => 9 | Ge => 9 | Cons => 8 | Append => 8 | Equals => 7 | NotEquals => 7 | Or => 6 | And => 5 | LogicalAnd => 4 | LogicalOr => 3 | Question => 2 | Assign => 1; fun rightAssoc Assign = true | rightAssoc Cons = true | rightAssoc _ = false; fun termToken x = case x of Then => true | Else => true | RParen => true | Semi => true | Colon => true | Case => true | Default => true | Comma => true | Rb => true | _ => false; fun lex s = let fun readInt(n,[]) = (n,nil) | readInt(n,c::cs) = if isDigit(c) then readInt(n*10+charToInt(c),cs) else (n,c::cs); fun readIdentifier(l,[]) = (rev l,nil) | readIdentifier(l,c::cs) = if isAlphaNum(c) then readIdentifier(c::l,cs) else (rev l,c::cs); fun readStringLiteral(l,[]) = (rev l, nil) | readStringLiteral(l,c::cs) = if c = #"\"" then (rev l,cs) else readStringLiteral(c::l,cs) fun readComment([]) = [] | readComment(#"\n"::cs) = cs | readComment(c::cs) = readComment(cs); fun readSymbol(c,rest) = case c of #"+" => (OpToken Add,rest) | #"-" => (OpToken Sub,rest) | #"*" => (OpToken Mul,rest) | #"/" => (OpToken Div,rest) | #"?" => (OpToken Question,rest) | #"=" => (case rest of (#"="::rest2) => (OpToken Equals,rest2) | _ => (OpToken Assign,rest)) | #">" => (case rest of (#"="::rest2) => (OpToken Ge,rest2) | _ => (OpToken Gt,rest)) | #"<" => (case rest of (#"="::rest2) => (OpToken Le,rest2) | _ => (OpToken Lt,rest)) | #"&" => (case rest of (#"&"::rest2) => (OpToken LogicalAnd,rest2) | _ => (OpToken And,rest)) | #"|" => (case rest of (#"|"::rest2) => (OpToken LogicalOr,rest2) | _ => (OpToken Or,rest)) | #";" => (Semi,rest) | #"}" => (RCurly,rest) | #"{" => (LCurly,rest) | #"(" => (LParen,rest) | #")" => (RParen,rest) | #"[" => (Lb,rest) | #"]" => (Rb,rest) | #"," => (Comma,rest) | #"@" => (OpToken Append,rest) | #":" => (case rest of (#":"::rest2) => (OpToken Cons,rest2) | _ => (Colon,rest)) | #"!" => (case rest of (#"="::rest2) => (OpToken NotEquals,rest2) | _ => (OpToken LogicalNegate,rest)) | #"~" => (OpToken BinaryNegate,rest) | _ => raise Exn("Invalid Symbol"); fun helper(tokens, []) = tokens | helper(tokens, c::cs) = if isSpace c then helper(tokens,cs) else if isDigit c then let val (n,cs2) = readInt(0,c::cs) in helper(Num n::tokens,cs2) end else if isAlpha c then let val (l,cs2) = readIdentifier([],c::cs) val s = (implode l) in helper( (case s of "if" => If | "else" => Else | "then" => Then | "fn" => Fn | "true" => True | "false" => False | "null" => Null | "case" => Case | "switch" => Switch | "default" => Default | "hd" => (OpToken Hd) | "tl" => (OpToken Tl) | "nil" => Nil | "catch" => Catch | "throw" => Throw | _ => Identifier s )::tokens,cs2) end else if c = #"\"" then let val (l,cs2) = readStringLiteral([],cs) in helper(StringLiteral(implode l)::tokens,cs2) end else if c = #"#" then helper(tokens,readComment(cs)) else let val (t,cs2) = readSymbol(c,cs) in helper(t::tokens,cs2) end; in rev(helper([], explode s)) end; fun parseSequence toks = let fun helper(exprs, nil) = (exprs,nil) | helper(exprs, tok::toks) = case tok of RCurly => (exprs,tok::toks) | _ => let val (e, toks2) = parseExpr(tok::toks) in helper(e::exprs,toks2) end; val (exprs,toks2) = helper([],toks) in (SequenceExpr(rev exprs),toks2) end and parseExpr toks = let fun consume v [] = raise Exn("expected a token, found eof") | consume v ((tok:Token)::toks) = if v = tok then toks else raise Exn("unexpected token in consume"); fun startExpr(minPrec, tok::toks) = let val (e,toks2) = case tok of Num(n) => (Constant(IntValue n),toks) | StringLiteral(s) => (Constant(StringValue s),toks) | True => (Constant(BoolValue(true)),toks) | False => (Constant(BoolValue(false)),toks) | Null => (Constant(NullValue),toks) | Nil => (Constant(ListValue []),toks) | Fn => let fun parseArgs(args,tok::toks) = (case tok of Identifier(s) => parseArgs(args @ [s], toks) | Comma => if null(args) then raise Exn("unexpected token") else parseArgs(args,toks) | RParen => (args,toks) | _ => raise Exn("expected identifier") (* end case *)) | parseArgs(args,_) = raise Exn("unexpected eof"); val (args,toks2) = parseArgs([],consume LParen toks); val (expr,toks3) = startExpr(0,toks2) in (LambdaExpr(args,expr),toks3) end | Throw => let val (e2,toks) = startExpr(0,toks) in (ThrowExpr(e2),toks) end | OpToken(Sub) => let val (e1,toks) = startExpr(prec NumericNegate, toks) in (UnaryExpr(NumericNegate,e1),toks) end | OpToken(BinaryNegate) => let val (e1,toks) = startExpr(prec BinaryNegate, toks) in (UnaryExpr(BinaryNegate,e1),toks) end | OpToken(LogicalNegate) => let val (e1,toks) = startExpr(prec LogicalNegate, toks) in (UnaryExpr(LogicalNegate,e1),toks) end | OpToken(Hd) => let val (e1,toks) = startExpr(prec Hd,toks) in (UnaryExpr(Hd,e1),toks) end | OpToken(Tl) => let val (e1,toks) = startExpr(prec Tl,toks) in (UnaryExpr(Tl,e1),toks) end | If => let val (e1,toks) = startExpr(0,toks); val (e2,toks) = startExpr(0,consume Then toks); val (e3,toks) = (case toks of (Else::toks) => startExpr(0,toks) | _ => (Constant(NullValue),toks)) in (IfExpr(e1,e2,e3),toks) end | Switch => let fun helper(arms, Case::toks) = let val (k,toks) = startExpr(0,toks); val (v,toks) = startExpr(0,consume Colon toks); in helper((k,v)::arms,toks) end | helper(arms,toks) = (rev arms,toks) val (e,toks) = startExpr(0,toks) val (arms,toks) = helper([],toks); in case toks of (Default::toks) => let val (d,toks) = startExpr(0,consume Colon toks) in (CaseExpr(e,arms,SOME(d)),toks) end | _ => (CaseExpr(e,arms,NONE),toks) end | LCurly => let val (e,toks2) = parseSequence(toks) in (e,consume RCurly toks2) end | Identifier(s) => (Variable(s),toks) | Lb => let fun helper(exprs,nil) = raise Exn("Expected token") | helper(exprs,tok::toks) = case tok of Comma => if null(exprs) then raise Exn("unexpected token") else helper(exprs,toks) | Rb => (rev exprs,toks) | _ => let val (e,toks) = startExpr(0,tok::toks) in helper(e::exprs,toks) end; val (exprs,toks) = helper([],toks); in (ListExpr(exprs),toks) end | LParen => let val (e2,toks2) = startExpr(0,toks) in case toks2 of (RParen::toks) => (e2,toks) | _ => raise Exn("expected Rparen") end | _ => raise Exn("Illegal Start of expression " ^ tokDesc(tok)); in continueExpr(e,minPrec,toks2) end | startExpr(_,[]) = raise Exn("No expression found where expression expected") and continueExpr(e, minPrec,[]) = (e,[]) | continueExpr(e, minPrec, tok::toks) = case tok of OpToken(x) => if unaryOp x then raise Exn("attempted to use a unary operator in a binary context") else if prec x < minPrec orelse (prec x = minPrec andalso not (rightAssoc x)) then (e,tok::toks) else let val (e2,toks2) = startExpr(prec x,toks) val (e3,toks3) = case x of Assign => (case e of Variable(s) => (AssignExpr(s,e2),toks2) | _ => raise Exn("can only assign to an identifier")) | Question => let val (e3,toks3) = startExpr(prec x, consume Colon toks2) in (IfExpr(e,e2,e3),toks3) end | _ => (BinaryExpr(e,x,e2),toks2); in continueExpr(e3,minPrec,toks3) end | LParen => let val (exprs,toks2) = parseCall([],toks) in continueExpr(CallExpr(e,exprs),minPrec,toks2) end | Catch => (case toks of (Identifier(n)::toks) => let val (eh,toks) = startExpr(0,toks) in (ExceptionHandlerExpr(e,n,eh),toks) end | _ => raise Exn("Expected identifier after catch")) | _ => if termToken tok then (e,tok::toks) else raise Exn("invalid continuation token " ^ tokDesc(tok)) and parseCall(exprs,nil) = raise Exn("Expected token") | parseCall(exprs,tok::toks) = case tok of Comma => if null(exprs) then raise Exn("unexpected token") else parseCall(exprs,toks) | RParen => (exprs,toks) | _ => let val (e,toks2) = startExpr(0,tok::toks) in parseCall(exprs @ [e],toks2) end; in case startExpr(0,toks) of (e, Semi::toks2) => (e,toks2) | _ => raise Exn("Expected semi") end; fun scopeGet(n,ScopeTop) = raise Exn(n ^ " not found in scope") | scopeGet(n,ScopeVal(k,v,next)) = if k = n then v else scopeGet(n,next); fun scopePut(k,v,s) = ScopeVal(k,v,s); fun eval (Constant(n),scope) = (n,scope) | eval (Variable(s),scope) = (scopeGet(s,scope),scope) | eval (AssignExpr(n,e),scope) = let val (v,s2) = eval(e,scope) in (v,scopePut(n,v,s2)) end | eval (IfExpr(cond,t,f),scope) = let val (cv,s2) = eval(cond,scope) in eval(if toBool(cv) then t else f, s2) end | eval (ThrowExpr(e),scope) = let val (v,scope) = eval(e,scope) in raise LangExn(v) end | eval (ExceptionHandlerExpr(body,name,catch),scope) = (eval(body,scope) handle LangExn(v) => eval(catch,scopePut(name,v,scope))) | eval (BinaryExpr(e1,LogicalAnd,e2),scope) = let val (v1,scope) = eval(e1,scope) in if toBool(v1) then eval(e2,scope) else (v1,scope) end | eval (BinaryExpr(e1,LogicalOr,e2),scope) = let val (v1,scope) = eval(e1,scope) in if toBool(v1) then (v1,scope) else eval(e2,scope) end | eval (BinaryExpr(e1,opr,e2),scope) = let val (v1,s1) = eval(e1,scope); val (v2,s2) = eval(e2,s1); in ((case opr of Add => (case (v1,v2) of (StringValue(s),_) => StringValue(s ^ toString(v2)) | (_,StringValue(s)) => StringValue(toString(v1) ^ s) | (IntValue(i),IntValue(i2)) => IntValue(i+i2) | _ => IntValue(toInt(v1)+toInt(v2)) (* end case *)) | Equals => BoolValue(cmp(v1,v2) = 0) | NotEquals => BoolValue(cmp(v1,v2) <> 0) | Lt => BoolValue(cmp(v1,v2) < 0) | Gt => BoolValue(cmp(v1,v2) > 0) | Le => BoolValue(cmp(v1,v2) <= 0) | Ge => BoolValue(cmp(v1,v2) >= 0) | And => IntValue(Word.toIntX(Word.andb(Word.fromInt(toInt(v1)),Word.fromInt(toInt(v2))))) | Or => IntValue(Word.toIntX(Word.orb(Word.fromInt(toInt(v1)),Word.fromInt(toInt(v2))))) | Sub => IntValue(toInt(v1) - toInt(v2)) | Mul => IntValue(toInt(v1) * toInt(v2)) | Div => IntValue(toInt(v1) div toInt(v2)) | Cons => ListValue(v1::(toList v2)) | Append => ListValue((toList v1) @ (toList v2)) | _ => raise Fail("no implementation for a binary operator") ),s2) end | eval (UnaryExpr(opr,e),scope) = let val (v,scope) = eval(e,scope) in ((case opr of BinaryNegate => IntValue(Word.toIntX(Word.notb(Word.fromInt(toInt v)))) | NumericNegate => IntValue(~(toInt v)) | LogicalNegate => BoolValue(not(toBool v)) | Hd => hd (toList v) | Tl => ListValue(tl (toList v)) | _ => raise Fail("no implementatin for a unary operator") (* end case *)),scope) end | eval (CaseExpr(e,arms,def),scope) = let val (v,scope) = eval(e,scope) fun helper([],scope) = (case def of SOME(e) => eval(e,scope) | NONE => (NullValue,scope)) | helper((ke,re)::arms,scope) = let val (kv,scope) = eval(ke,scope) in if cmp(v,kv) = 0 then eval(re,scope) else helper(arms,scope) end in helper(arms,scope) end | eval (ListExpr(l),scope) = let val (vs,scope) = runList(l,[],scope) in (ListValue(vs),scope) end | eval (LambdaExpr(args,exprs),scope) = (LambdaValue(args,exprs,scope),scope) | eval (CallExpr(func,args),scope) = let val (v,s2) = eval(func,scope) fun populateScope(nil,_,s) = s | populateScope(n::ns,nil,s) = populateScope(ns,nil,scopePut(n,NullValue,s)) | populateScope(n::ns,v::vs,s) = populateScope(ns,vs,scopePut(n,v,s)) val (argVals,s3) = runList(args,[],s2) in case v of LambdaValue(argNames,expr,parentScope) => let val (v,_) = eval(expr,scopePut("callee",v,populateScope(argNames,argVals,parentScope))); in (v,s3) end | NativeLambdaValue(f) => ((f argVals),s3) | _ => raise Exn(toString(v) ^ " is not callable") end | eval(SequenceExpr(exprs),scope) = let fun helper([],scope,last) = (last,scope) | helper(e::es,scope,last) = let val (v,s2) = eval(e,scope) in helper(es,s2,v) end in helper(exprs,scope,NullValue) end and runList(nil,vals,scope) = (rev vals,scope) | runList(e::es,vals,scope) = let val (v,s2) = eval(e,scope) in runList(es,v::vals,s2) end; val defaultScope = let fun chomp s = (case (rev (explode s)) of (#"\n"::rest) => implode(rev rest) | _ => s) val nativeFuncs = [ ("print",fn(l) => (TextIO.print (foldleft op^ ("",map toString l)^"\n"); NullValue)), ("input",fn(l) => (case (TextIO.inputLine TextIO.stdIn) of SOME(s) => StringValue(chomp s) | NONE => NullValue)), ("parseInt",fn(l) => IntValue(case l of (v::rest) => toInt(v) | _ => 0)), ("rev",fn(l) => ListValue(case l of (v::rest) => rev (toList v) | _ => nil)), ("isnull",fn(l) => BoolValue(case l of(v::rest) => null(toList v) | _ => true)) ]; fun helper([],s) = s | helper((n,f)::es,s) = helper(es,scopePut(n,NativeLambdaValue(f),s)) in helper(nativeFuncs,ScopeTop) end fun runScript s = let val (expr,toks) = parseSequence(lex(s)) in if not (null toks) then raise Exn("Trailing garbage") else let val (v,_) = eval(expr,defaultScope) in v end end; fun main (arg0,args) = case args of (a1::rest) => ( (printValue(runScript(TextIO.inputAll(TextIO.openIn(a1))));OS.Process.success) handle Exn(s) => (TextIO.print("Error: " ^ s ^ "\n"); OS.Process.failure) | LangExn(v) => (TextIO.print("Unhandled language exception: " ^ (toString v) ^ "\n"); OS.Process.failure) | Fail(s) => (TextIO.print("Fail: " ^ s ^ "\n"); OS.Process.failure) | exn => (TextIO.print("Uncaught exception\n"); OS.Process.failure) ) | _ => (TextIO.print("Usage: BriLang foo.bs\n"); OS.Process.failure) end (* structure *)