boot.sml

val _ = main ()

fact.tal

fun f(x) =
  if x then x * f(x - 1)
  else 1;

puts(f(10))

Makefile

tal: parse.sml scan.ulex.sml tal.sml boot.sml 
	mlton \
	-output 'tal' \
	tal.mlb 

scan.ulex.sml: scan.ulex
	ml-ulex scan.ulex

parse.sml: parse.cf
	proglr < parse.cf > parse.sml

clean:
	rm -f tal

parse.cf

token Add "+" ;
token Sub "-" ;
token Mul "*" ;
token Div "/" ;
token LParen "(" ;
token RParen ")" ;
token Eq "=" ;
token Comma "," ;
token Semi ";" ;
token FunKw "fun" ;
token LetKw "let" ;
token InKw "in" ;
token IfKw "if" ;
token ThenKw "then" ;
token ElseKw "else" ;
token Integer of int;
token Ident of string;
token String of string;

Grm. Grm ::= [Top] ;
separator Top ";" ;

Fun. Top ::= "fun" Ident "(" [Param] ")" "=" Exp ;
Exp. Top ::= Exp ;

separator Param "," ;
Param. Param ::= Ident ;

Let. Exp ::= "let" Ident "=" Exp "in" Exp ;
Cnd. Exp ::= "if" Exp "then" Exp "else" Exp ;

separator Exp "," ;

Add. Exp1 ::= Exp1 "+" Exp2 ;
Sub. Exp1 ::= Exp1 "-" Exp2 ;

Mul. Exp2 ::= Exp2 "*" Exp3 ;
Div. Exp2 ::= Exp2 "/" Exp3 ;

App. Exp3 ::= Ident "(" [Exp] ")" ;
Int. Exp3 ::= Integer ;
Str. Exp3 ::= String ;
Var. Exp3 ::= Ident ;

coercions Exp 3;

scan.ulex

%defs (
  open Token
  type lex_result = Token.token
  val eof = fn () => Token.EOF
  fun unescape s = case (String.fromCString s) of NONE => s | SOME s' => s'
);

%name Lexer;
%states IN_STRING IN_COMMENT;

%let letter = [a-zA-Z\u00c0-\u00ff] & [^\u00d7\u00f7];
%let capital = [A-Z\u00c0-\u00dd] & [^\u00d7];
%let small = [a-z\u00de-\u00ff] & [^\u00f7];
%let digit = [0-9];
%let ident = {letter} | {digit} | [_'];
%let space = [ \t\r\n];
%let quot = ["];
%let backslash = [\\];

<INITIAL> "+" => (Add);
<INITIAL> "-" => (Sub);
<INITIAL> "*" => (Mul);
<INITIAL> "/" => (Div);
<INITIAL> "(" => (LParen);
<INITIAL> ")" => (RParen);
<INITIAL> "=" => (Eq);
<INITIAL> "," => (Comma);
<INITIAL> ";" => (Semi);
<INITIAL> fun => (FunKw);
<INITIAL> let => (LetKw);
<INITIAL> in => (InKw);
<INITIAL> if => (IfKw);
<INITIAL> then => (ThenKw);
<INITIAL> else => (ElseKw);
<INITIAL> {letter} {ident}* => (Ident yytext);
<INITIAL> {digit}+ => (Integer (Option.valOf (Int.fromString (yytext))));
<INITIAL> {quot}{2} => (String "");
<INITIAL> {quot} => (YYBEGIN IN_STRING; continue ());
<INITIAL> "{-" => (YYBEGIN IN_COMMENT; continue ());
<INITIAL> "--" [^\n]* [\n] => (continue ());
<INITIAL> {space}+ => (continue ());

<IN_STRING> ([^"]|{backslash}{quot})* => (String (unescape yytext)); 
<IN_STRING> {quot} => (YYBEGIN INITIAL; continue ());

<IN_COMMENT> "-}" => (YYBEGIN INITIAL; continue ());
<IN_COMMENT> . => (continue ());

tal.mlb

$(SML_LIB)/basis/basis.mlb

smlnj-lib/Util/utf8.mlb

ml-lpt/lib/stream-pos.sml
ml-lpt/lib/antlr-lexer-sig.sml
ml-lpt/lib/antlr-tokens-sig.sml
ml-lpt/lib/ebnf.sml
ml-lpt/lib/repair.sml
ml-lpt/lib/ulex-buffer.sml
ml-lpt/lib/wrapped-strm.sml

parse.sml
scan.ulex.sml
tal.sml
boot.sml

tal.sml

structure Parse = ParseFun(Lexer)

open Parse.Ast

fun nameOf (Param (_, name)) = name

fun mem (x, []) = false
  | mem (x, y::ys) = x = y orelse mem (x, ys)

fun check (Grm (span, tops)) = List.app (fn top => checkTop (top, [])) tops
and checkTop (Fun (span, name, params, body), env) =
      checkExp (body, map nameOf params)
  | checkTop (Exp (span, exp), env) = checkExp (exp, env)
and checkExp (Let (span, name, value, body), env) = (
      checkExp (value, env);
      if mem (name, env) then raise Fail ("dup var: " ^ name)
      else checkExp (body, name::env))
  | checkExp (Cnd (span, cond, t, f), env) =
      (checkExp (cond, env); checkExp (t, env); checkExp (f, env))
  | checkExp (App (span, rator, rands), env) =
      List.app (fn rand => checkExp (rand, env)) rands
  | checkExp (Add (span, e1, e2), env) =
      (checkExp (e1, env); checkExp (e2, env))
  | checkExp (Sub (span, e1, e2), env) =
      (checkExp (e1, env); checkExp (e2, env))
  | checkExp (Mul (span, e1, e2), env) =
      (checkExp (e1, env); checkExp (e2, env))
  | checkExp (Div (span, e1, e2), env) =
      (checkExp (e1, env); checkExp (e2, env))
  | checkExp (Int (span, int), env) = ()
  | checkExp (Str (span, str), env) = ()
  | checkExp (Var (span, var), env) =
      if mem (var, env) then () else raise Fail ("unknown var: " ^ var)

local 
    val n = ref 0
in
    fun newLabel () = "label" ^ Int.toString (!n) before n := !n + 1
end      

fun println s = (print s; print "\n")

fun compile (Grm (span, tops)) = List.app compileTop tops
and compileTop (Fun (span, name, params, body)) = (
      println ("proc " ^ name ^ " {" ^ String.concatWith " " (map nameOf params) ^ "} {");
      println ("::tcl::unsupported::assemble {");
      compileExp body;
      println ("}");
      println ("}"))
  | compileTop (Exp (span, exp)) = (
      println ("::tcl::unsupported::assemble {");
      compileExp exp;
      println ("}"))
and compileExp (Let (span, name, value, body)) = (
      compileExp value;
      println ("store " ^ name);
      println "pop";
      compileExp body)
  | compileExp (Cnd (span, cond, t, f)) =
      let
        val falseLabel = newLabel ()
        val trueLabel = newLabel ()
      in
        compileExp cond;
        println ("jumpFalse " ^ falseLabel);
        compileExp t;
        println ("jump " ^ trueLabel);
        println ("label " ^ falseLabel);
        compileExp f;
        println ("label " ^ trueLabel)
      end
  | compileExp (App (span, rator, rands)) = (
       println ("push " ^ rator);
       List.app compileExp rands;
       println ("invokeStk " ^ Int.toString (length rands + 1)))
  | compileExp (Add (span, e1, e2)) = (
      compileExp e1;
      compileExp e2;
      println "add")
  | compileExp (Sub (span, e1, e2)) = (
      compileExp e1;
      compileExp e2;
      println "sub")
  | compileExp (Mul (span, e1, e2)) = (
      compileExp e1;
      compileExp e2;
      println "mult")
  | compileExp (Div (span, e1, e2)) = (
      compileExp e1;
      compileExp e2;
      println "div")
  | compileExp (Int (span, int)) = println ("push " ^ Int.toString int)
  | compileExp (Str (span, str)) = println ("push {" ^ str ^ "}")
  | compileExp (Var (span, var)) = println ("load " ^ var)

fun main () =
  let
    val strm = Lexer.streamifyInstream TextIO.stdIn
    val sourcemap = AntlrStreamPos.mkSourcemap ()
    val ast = hd (Parse.parse sourcemap strm)
  in
    check ast;
    compile ast
  end

talexec

#/bin/sh

TEMP=$(mktemp)
tal < $1 > $TEMP
tclsh $TEMP
rm -f $TEMP