├── README.md └── examples ├── chap2 ├── Eval.smi ├── Eval.sml ├── Main.smi ├── Main.sml ├── Makefile ├── TM.smi └── TM.sml ├── chap3 ├── main │ ├── Main.smi │ ├── Main.sml │ ├── Makefile │ ├── Top.smi │ └── Top.sml └── readstring │ ├── ReadString.smi │ └── ReadString.sml ├── chap4 ├── lex │ ├── CoreML.lex │ ├── CoreML.lex.smi │ ├── Lexer.smi │ ├── Lexer.sml │ ├── Token.smi │ └── Token.sml └── main │ ├── Main.smi │ ├── Main.sml │ ├── Makefile │ ├── Top.smi │ └── Top.sml ├── chap5 ├── main │ ├── Main.smi │ ├── Main.sml │ ├── Makefile │ ├── Top.smi │ └── Top.sml └── parser │ ├── CoreML.grm │ ├── CoreML.grm.smi │ ├── CoreML.lex │ ├── CoreML.lex.smi │ ├── Parser.smi │ ├── Parser.sml │ ├── Syntax.smi │ └── Syntax.sml ├── chap6-4 ├── main │ ├── Main.smi │ ├── Main.sml │ ├── Makefile │ ├── Top.smi │ └── Top.sml ├── parser │ ├── CoreML.grm │ ├── CoreML.grm.smi │ ├── CoreML.lex │ ├── CoreML.lex.smi │ ├── Parser.smi │ ├── Parser.sml │ ├── Syntax.smi │ └── Syntax.sml └── typeinf │ ├── Type.smi │ ├── Type.sml │ ├── TypeUtils.smi │ ├── TypeUtils.sml │ ├── Typeinf.smi │ ├── Typeinf.sml │ ├── UnifyTy.smi │ └── UnifyTy.sml ├── chap6-5 ├── main │ ├── Main.smi │ ├── Main.sml │ ├── Makefile │ ├── Top.smi │ └── Top.sml ├── parser │ ├── CoreML.grm │ ├── CoreML.grm.smi │ ├── CoreML.lex │ ├── CoreML.lex.smi │ ├── Parser.smi │ ├── Parser.sml │ ├── Syntax.smi │ └── Syntax.sml └── typeinf │ ├── Type.smi │ ├── Type.sml │ ├── TypeUtils.smi │ ├── TypeUtils.sml │ ├── Typeinf.smi │ ├── Typeinf.sml │ ├── UnifyTy.smi │ ├── UnifyTy.sml │ ├── W.smi │ └── W.sml ├── chap7 ├── eval │ ├── Eval.smi │ ├── Eval.sml │ ├── Value.smi │ └── Value.sml ├── main │ ├── Main.smi │ ├── Main.sml │ ├── Makefile │ ├── Top.smi │ └── Top.sml ├── parser │ ├── CoreML.grm │ ├── CoreML.grm.smi │ ├── CoreML.lex │ ├── CoreML.lex.smi │ ├── Parser.smi │ ├── Parser.sml │ ├── Syntax.smi │ └── Syntax.sml └── typeinf │ ├── Type.smi │ ├── Type.sml │ ├── TypeUtils.smi │ ├── TypeUtils.sml │ ├── Typeinf.smi │ ├── Typeinf.sml │ ├── UnifyTy.smi │ ├── UnifyTy.sml │ ├── W.smi │ └── W.sml └── chap8 ├── SECD ├── Comp.smi ├── Comp.sml ├── Exec.smi ├── Exec.sml ├── Instruction.smi ├── Instruction.sml ├── Value.smi └── Value.sml ├── main ├── Main.smi ├── Main.sml ├── Makefile ├── Top.smi └── Top.sml ├── parser ├── CoreML.grm ├── CoreML.grm.smi ├── CoreML.lex ├── CoreML.lex.smi ├── Parser.smi ├── Parser.sml ├── Syntax.smi └── Syntax.sml └── typeinf ├── Type.smi ├── Type.sml ├── TypeUtils.smi ├── TypeUtils.sml ├── Typeinf.smi ├── Typeinf.sml ├── UnifyTy.smi ├── UnifyTy.sml ├── W.smi └── W.sml /README.md: -------------------------------------------------------------------------------- 1 | # コンパイラ ー 原理と構造 2 | 3 | コンパイラの教科書「[コンパイラ ー 原理と構造]」 4 | （大堀 淳著、[共立出版]、2021年9月初版発行）のコード例などのサポートデータを提供． 5 | 6 | 本レポジトリの利用方法を含む本書の説明は、[大堀淳のホームページ]の[コンパイラ教科書ページ]参照． 7 | 8 | ## ファイルの説明 9 | * [`README.md`] 本ファイル． 10 | * [`examples/chap2/`] 〜 [`examples/chap8/`] 11 | 第2章から第8章のコード例を含むフォルダ．簡単な式の評価例等は省略． 12 | 13 | [コンパイラ ー 原理と構造]: https://www.kyoritsu-pub.co.jp/bookdetail/9784320124783 14 | [共立出版]: https://www.kyoritsu-pub.co.jp/ 15 | [大堀淳のホームページ]: https://atsushiohori.github.io 16 | [コンパイラ教科書ページ]: https://atsushiohori.github.io/ja/texts/compiler 17 | [`README.md`]: README.md 18 | [`examples/chap2/`]: examples/chap2/ 19 | [`examples/chap8/`]: examples/chap8/ 20 | 21 | -------------------------------------------------------------------------------- /examples/chap2/Eval.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "reify.smi" 3 | _require "./TM.smi" 4 | structure Eval = 5 | struct 6 | val eval : TM.program -> TM.tape -> TM.tape 7 | end 8 | -------------------------------------------------------------------------------- /examples/chap2/Eval.sml: -------------------------------------------------------------------------------- 1 | structure Eval = 2 | struct 3 | open TM 4 | fun Hd nil = B 5 | | Hd (h :: _) = h 6 | fun Tl nil = nil 7 | | Tl (_ :: tl) = tl 8 | fun Cons (B, nil) = nil 9 | | Cons (h,t) = h::t 10 | fun moveL (LList, h, RList) = 11 | (Tl LList, Hd LList, Cons (h, RList)) 12 | fun moveR (LList, h, RList) = 13 | (Cons (h, LList), Hd RList, Tl RList) 14 | fun move L tape = moveL tape 15 | | move R tape = moveR tape 16 | fun print (q, (LList, h, RList)) = 17 | Dynamic.pp 18 | {state=q, 19 | tape = (List.rev LList, h, RList)} 20 | fun exec delta (q, tape as (LList, h, RList)) = 21 | case List.find (fn (x,y) => x = (q, h)) delta of 22 | NONE => (LList, h, RList) 23 | | SOME (x, (q', s, d)) => 24 | exec delta (q', move d (LList, s, RList)) 25 | fun eval (state, delta) tape = exec delta (state,tape) 26 | end 27 | -------------------------------------------------------------------------------- /examples/chap2/Main.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "reify.smi" 3 | _require "./TM.smi" 4 | _require "./Eval.smi" 5 | -------------------------------------------------------------------------------- /examples/chap2/Main.sml: -------------------------------------------------------------------------------- 1 | open TM 2 | val T = ([I, I, I], I, nil); 3 | val r = Eval.eval P T; 4 | val _ = Dynamic.pp {T = T, r = r}; 5 | -------------------------------------------------------------------------------- /examples/chap2/Makefile: -------------------------------------------------------------------------------- 1 | SMLSHARP = smlsharp 2 | SMLFLAGS = -O2 3 | LIBS = 4 | all: Main 5 | Main: TM.smi Eval.smi Main.smi TM.o Eval.o Main.o 6 | $(SMLSHARP) $(LDFLAGS) -o Main Main.smi $(LIBS) 7 | TM.o: TM.sml TM.smi 8 | $(SMLSHARP) $(SMLFLAGS) -o TM.o -c TM.sml 9 | Eval.o: Eval.sml TM.smi Eval.smi 10 | $(SMLSHARP) $(SMLFLAGS) -o Eval.o -c Eval.sml 11 | Main.o: Main.sml TM.smi Eval.smi Main.smi 12 | $(SMLSHARP) $(SMLFLAGS) -o Main.o -c Main.sml 13 | clean: 14 | rm -f ./Main ./*.o 15 | -------------------------------------------------------------------------------- /examples/chap2/TM.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | structure TM = 3 | struct 4 | datatype D = R | L 5 | datatype S = B | I | O 6 | datatype Q = M | H 7 | type delta = ((Q * S) * (Q * S * D)) list 8 | type program = Q * delta 9 | type tape = S list * S * S list 10 | val P : program 11 | end 12 | -------------------------------------------------------------------------------- /examples/chap2/TM.sml: -------------------------------------------------------------------------------- 1 | structure TM = 2 | struct 3 | datatype D = R | L 4 | datatype S = B | I | O 5 | datatype Q = M | H 6 | type delta = ((Q * S) * (Q * S * D)) list 7 | type program = Q * delta 8 | type tape = S list * S * S list 9 | val P = (M, [((M, I), (M, O, L)), 10 | ((M, O), (H, I, L)), 11 | ((M, B), (H, I, L)) 12 | ]) 13 | end 14 | -------------------------------------------------------------------------------- /examples/chap3/main/Main.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "./Top.smi" 3 | -------------------------------------------------------------------------------- /examples/chap3/main/Main.sml: -------------------------------------------------------------------------------- 1 | val _ = case CommandLine.arguments() of 2 | h::_ => Top.top h 3 | | nil => Top.top ""; 4 | -------------------------------------------------------------------------------- /examples/chap3/main/Makefile: -------------------------------------------------------------------------------- 1 | SMLSHARP = smlsharp 2 | SMLFLAGS = -O2 3 | LIBS = 4 | all: Main 5 | Main: ../readstring/ReadString.smi Top.smi Main.smi ../readstring/ReadString.o \ 6 | Top.o Main.o 7 | $(SMLSHARP) $(LDFLAGS) -o Main Main.smi $(LIBS) 8 | ../readstring/ReadString.o: ../readstring/ReadString.sml \ 9 | ../readstring/ReadString.smi 10 | $(SMLSHARP) $(SMLFLAGS) -o ../readstring/ReadString.o -c \ 11 | ../readstring/ReadString.sml 12 | Top.o: Top.sml ../readstring/ReadString.smi Top.smi 13 | $(SMLSHARP) $(SMLFLAGS) -o Top.o -c Top.sml 14 | Main.o: Main.sml ../readstring/ReadString.smi Top.smi Main.smi 15 | $(SMLSHARP) $(SMLFLAGS) -o Main.o -c Main.sml 16 | clean: 17 | rm Main Main.o Top.o ../readstring/ReadString.o 18 | -------------------------------------------------------------------------------- /examples/chap3/main/Top.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "../readstring/ReadString.smi" 3 | structure Top = 4 | struct 5 | val top : string -> unit 6 | end 7 | -------------------------------------------------------------------------------- /examples/chap3/main/Top.sml: -------------------------------------------------------------------------------- 1 | structure Top = 2 | struct 3 | fun readAndPrintLoop inStream = 4 | let 5 | val _ = ReadString.skipSpaces inStream 6 | val s = ReadString.readString inStream 7 | val _ = print (s ^ "\n") 8 | in 9 | readAndPrintLoop inStream 10 | end 11 | fun top file = 12 | let 13 | val inStream = case file of 14 | "" => TextIO.stdIn 15 | | _ => TextIO.openIn file 16 | in 17 | readAndPrintLoop inStream; 18 | case file of "" => () 19 | | _ => TextIO.closeIn inStream 20 | end 21 | handle ReadString.EOF => () 22 | end 23 | -------------------------------------------------------------------------------- /examples/chap3/readstring/ReadString.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | structure ReadString = 3 | struct 4 | exception EOF 5 | val skipSpaces : TextIO.instream -> unit 6 | val readString : TextIO.instream -> string 7 | end 8 | -------------------------------------------------------------------------------- /examples/chap3/readstring/ReadString.sml: -------------------------------------------------------------------------------- 1 | structure ReadString = 2 | struct 3 | exception EOF 4 | fun skipSpaces inStream = 5 | if TextIO.endOfStream inStream then raise EOF 6 | else case TextIO.lookahead inStream of 7 | SOME c => 8 | if Char.isSpace c then 9 | (TextIO.input1 inStream; skipSpaces inStream) 10 | else () 11 | | NONE => () 12 | fun readString inStream = 13 | let 14 | fun readRest s = 15 | case TextIO.lookahead inStream of 16 | SOME c => if Char.isSpace c then s 17 | else (TextIO.input1 inStream; 18 | readRest (s ^ str c)) 19 | | NONE => s 20 | in 21 | readRest "" 22 | end 23 | end 24 | -------------------------------------------------------------------------------- /examples/chap4/lex/CoreML.lex: -------------------------------------------------------------------------------- 1 | type lexresult = Token.token 2 | val eof = fn () => Token.EOF 3 | fun atoi s = valOf (Int.fromString s) 4 | %% 5 | %structure CoreMLLex 6 | alpha = [A-Za-z]; 7 | digit = [0-9]; 8 | id = {alpha}({alpha}|{digit})*; 9 | num = {digit}+; 10 | frac = "."{num}; 11 | exp = [eE](~?){num}; 12 | real = (~?)(({num}{frac}?{exp})|({num}{frac}{exp}?)); 13 | ws = "\ " | "\t" | "\r\n" | "\n" | "\r"; 14 | %% 15 | \"[^"]*\" => (Token.STRING 16 | (String.substring 17 | (yytext,1,String.size yytext - 2))); 18 | "_" => (Token.UNDERBAR); 19 | {id} => (Token.ID yytext); 20 | {real} => (Token.REAL yytext); 21 | {ws} => (lex()); 22 | . => (Token.SPECIAL yytext); 23 | -------------------------------------------------------------------------------- /examples/chap4/lex/CoreML.lex.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "./Token.smi" 3 | structure CoreMLLex = 4 | struct 5 | val makeLexer : (int -> string) -> unit -> Token.token 6 | end 7 | -------------------------------------------------------------------------------- /examples/chap4/lex/Lexer.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "./Token.smi" 3 | _require "./CoreML.lex.smi" 4 | structure Lexer = 5 | struct 6 | exception EOF 7 | val makeLexer : TextIO.instream -> unit -> Token.token 8 | end 9 | -------------------------------------------------------------------------------- /examples/chap4/lex/Lexer.sml: -------------------------------------------------------------------------------- 1 | structure Lexer = 2 | struct 3 | exception EOF 4 | fun makeLexer inStream = 5 | let val lexer = 6 | CoreMLLex.makeLexer 7 | (fn n => case TextIO.input1 inStream of 8 | SOME c => str c | NONE => "") 9 | in fn () => let val token = lexer () 10 | in if token = Token.EOF then raise EOF 11 | else token 12 | end 13 | end 14 | end 15 | -------------------------------------------------------------------------------- /examples/chap4/lex/Token.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | structure Token = 3 | struct 4 | datatype token 5 | = EOF | UNDERBAR | ID of string 6 | | STRING of string | REAL of string 7 | | SPECIAL of string 8 | val toString : token -> string 9 | end 10 | -------------------------------------------------------------------------------- /examples/chap4/lex/Token.sml: -------------------------------------------------------------------------------- 1 | structure Token = struct 2 | datatype token 3 | = EOF | UNDERBAR | ID of string 4 | | STRING of string | REAL of string 5 | | SPECIAL of string 6 | fun toString token = 7 | case token of 8 | EOF => "EOF " 9 | | ID s => "ID " ^ s 10 | | REAL s => "REAL " ^ s 11 | | STRING s => "STRING " ^ "\"" ^ s ^ "\"" 12 | | UNDERBAR => "UNDERBAR " 13 | | SPECIAL s => "SPECIAL" ^ s 14 | end 15 | -------------------------------------------------------------------------------- /examples/chap4/main/Main.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "./Top.smi" 3 | -------------------------------------------------------------------------------- /examples/chap4/main/Main.sml: -------------------------------------------------------------------------------- 1 | val _ = case CommandLine.arguments() of 2 | h::_ => Top.top h 3 | | nil => () 4 | -------------------------------------------------------------------------------- /examples/chap4/main/Makefile: -------------------------------------------------------------------------------- 1 | SMLSHARP = smlsharp 2 | SMLFLAGS = -O2 3 | LIBS = 4 | all: Main 5 | Main: ../lex/Token.smi ../lex/CoreML.lex.smi ../lex/Lexer.smi Top.smi Main.smi \ 6 | ../lex/Token.o ../lex/CoreML.lex.o ../lex/Lexer.o Top.o Main.o 7 | $(SMLSHARP) $(LDFLAGS) -o Main Main.smi $(LIBS) 8 | ../lex/Token.o: ../lex/Token.sml ../lex/Token.smi 9 | $(SMLSHARP) $(SMLFLAGS) -o ../lex/Token.o -c ../lex/Token.sml 10 | ../lex/CoreML.lex.sml: 11 | smllex ../lex/CoreML.lex 12 | ../lex/CoreML.lex.o: ../lex/CoreML.lex.sml ../lex/Token.smi \ 13 | ../lex/CoreML.lex.smi 14 | $(SMLSHARP) $(SMLFLAGS) -o ../lex/CoreML.lex.o -c ../lex/CoreML.lex.sml 15 | ../lex/Lexer.o: ../lex/Lexer.sml ../lex/Token.smi ../lex/CoreML.lex.smi \ 16 | ../lex/Lexer.smi 17 | $(SMLSHARP) $(SMLFLAGS) -o ../lex/Lexer.o -c ../lex/Lexer.sml 18 | Top.o: Top.sml ../lex/Token.smi ../lex/CoreML.lex.smi ../lex/Lexer.smi Top.smi 19 | $(SMLSHARP) $(SMLFLAGS) -o Top.o -c Top.sml 20 | Main.o: Main.sml ../lex/Token.smi ../lex/CoreML.lex.smi ../lex/Lexer.smi \ 21 | Top.smi Main.smi 22 | $(SMLSHARP) $(SMLFLAGS) -o Main.o -c Main.sml 23 | clean: 24 | rm -f ../lex/Token.o ../lex/CoreML.lex.sml ../lex/CoreML.lex.o ../lex/Lexer.o Top.o Main.o Main 25 | 26 | -------------------------------------------------------------------------------- /examples/chap4/main/Top.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "../lex/Token.smi" 3 | _require "../lex/Lexer.smi" 4 | structure Top = 5 | struct 6 | val top : string -> unit 7 | end 8 | -------------------------------------------------------------------------------- /examples/chap4/main/Top.sml: -------------------------------------------------------------------------------- 1 | structure Top = 2 | struct 3 | fun readAndPrintLoop lexer = 4 | let 5 | val token = lexer() 6 | val _ = print (Token.toString token ^ "\n") 7 | in 8 | readAndPrintLoop lexer 9 | end 10 | fun top file = 11 | let 12 | val inStream = TextIO.openIn file 13 | val lexer = Lexer.makeLexer inStream 14 | in 15 | readAndPrintLoop lexer; 16 | TextIO.closeIn inStream 17 | end 18 | handle Lexer.EOF => () 19 | end 20 | -------------------------------------------------------------------------------- /examples/chap5/main/Main.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "./Top.smi" 3 | -------------------------------------------------------------------------------- /examples/chap5/main/Main.sml: -------------------------------------------------------------------------------- 1 | val _ = case CommandLine.arguments() of 2 | h::_ => Top.top h 3 | | nil => Top.top ""; 4 | -------------------------------------------------------------------------------- /examples/chap5/main/Makefile: -------------------------------------------------------------------------------- 1 | SMLSHARP = smlsharp 2 | SMLFLAGS = -O2 3 | LIBS = 4 | all: Main 5 | Main: ../parser/Syntax.smi ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi \ 6 | ../parser/CoreML.lex.smi ../parser/Parser.smi Top.smi Main.smi \ 7 | ../parser/Syntax.o ../parser/CoreML.grm.o ../parser/CoreML.lex.o \ 8 | ../parser/Parser.o Top.o Main.o 9 | $(SMLSHARP) $(LDFLAGS) -o Main Main.smi $(LIBS) 10 | ../parser/Syntax.o: ../parser/Syntax.sml ../parser/Syntax.smi 11 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/Syntax.o -c ../parser/Syntax.sml 12 | ../parser/CoreML.grm.sig: ../parser/CoreML.grm 13 | smlyacc ../parser/CoreML.grm 14 | ../parser/CoreML.grm.sml: ../parser/CoreML.grm 15 | smlyacc ../parser/CoreML.grm 16 | ../parser/CoreML.grm.o: ../parser/CoreML.grm.sml ../parser/Syntax.smi \ 17 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi 18 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/CoreML.grm.o -c \ 19 | ../parser/CoreML.grm.sml 20 | ../parser/CoreML.lex.sml: ../parser/CoreML.lex 21 | smllex ../parser/CoreML.lex 22 | ../parser/CoreML.lex.o: ../parser/CoreML.lex.sml ../parser/Syntax.smi \ 23 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi 24 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/CoreML.lex.o -c \ 25 | ../parser/CoreML.lex.sml 26 | ../parser/Parser.o: ../parser/Parser.sml ../parser/Syntax.smi \ 27 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi \ 28 | ../parser/Parser.smi 29 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/Parser.o -c ../parser/Parser.sml 30 | Top.o: Top.sml ../parser/Syntax.smi ../parser/CoreML.grm.sig \ 31 | ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi ../parser/Parser.smi Top.smi 32 | $(SMLSHARP) $(SMLFLAGS) -o Top.o -c Top.sml 33 | Main.o: Main.sml ../parser/Syntax.smi ../parser/CoreML.grm.sig \ 34 | ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi ../parser/Parser.smi \ 35 | Top.smi Main.smi 36 | $(SMLSHARP) $(SMLFLAGS) -o Main.o -c Main.sml 37 | clean: 38 | rm -f ./*.o ../parser/*.o ../typeinf/*.o Main 39 | rm -f ../parser/CoreML.grm.sml ../parser/CoreML.grm.sig ../parser/CoreML.lex.sml 40 | .SUFFIXES: .grm .lex 41 | -------------------------------------------------------------------------------- /examples/chap5/main/Top.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "../parser/Syntax.smi" 3 | _require "../parser/Parser.smi" 4 | structure Top = 5 | struct 6 | val top : string -> unit 7 | end 8 | -------------------------------------------------------------------------------- /examples/chap5/main/Top.sml: -------------------------------------------------------------------------------- 1 | structure Top = 2 | struct 3 | fun readAndPrintLoop stream = 4 | let val (dec, stream) = Parser.doParse stream 5 | in readAndPrintLoop stream end 6 | fun top file = 7 | let val inStream = case file of "" => TextIO.stdIn 8 | | _ => TextIO.openIn file 9 | val stream = Parser.makeStream inStream 10 | in readAndPrintLoop stream 11 | handle Parser.EOF => () 12 | | Parser.ParseError => print "Syntax error\n"; 13 | case file of "" => () | _ => TextIO.closeIn inStream 14 | end 15 | end 16 | -------------------------------------------------------------------------------- /examples/chap5/parser/CoreML.grm: -------------------------------------------------------------------------------- 1 | %% 2 | %pos int 3 | %term ADD | COMMA | DARROW | DIV | ELSE | EOF | EQ | EQUAL 4 | | FALSE | FN | FUN | HASH1 | HASH2 | ID of string | IF 5 | | INT of int | LPAREN | MUL | RPAREN | SEMICOLON 6 | | STRING of string | SUB | THEN | TRUE | VAL 7 | %nonterm appexp of Syntax.exp | atexp of Syntax.exp 8 | | const of Syntax.exp | exp of Syntax.exp 9 | | dec of Syntax.dec | top of Syntax.dec 10 | | prim of Syntax.prim 11 | %start top 12 | %name CoreML 13 | %eop EOF SEMICOLON 14 | %noshift EOF 15 | %% 16 | top : dec (dec) 17 | dec : VAL ID EQUAL exp (Syntax.VAL(ID,exp)) 18 | | FUN ID ID EQUAL exp 19 | (Syntax.VAL(ID1, Syntax.EXPFIX(ID1, ID2, exp))) 20 | exp : appexp (appexp) 21 | | IF exp THEN exp ELSE exp (Syntax.EXPIF(exp1, exp2, exp3)) 22 | | FN ID DARROW exp (Syntax.EXPFN(ID, exp)) 23 | appexp : atexp (atexp) 24 | | appexp atexp (Syntax.EXPAPP(appexp, atexp)) 25 | atexp : const (const) 26 | | ID (Syntax.EXPID(ID)) 27 | | LPAREN exp COMMA exp RPAREN 28 | (Syntax.EXPPAIR(exp1, exp2)) 29 | | LPAREN exp RPAREN (exp) 30 | | HASH1 atexp (Syntax.EXPPROJ1 atexp) 31 | | HASH2 atexp (Syntax.EXPPROJ2 atexp) 32 | | prim LPAREN exp COMMA exp RPAREN 33 | (Syntax.EXPPRIM(prim, exp1, exp2)) 34 | const : INT (Syntax.INT(INT)) 35 | | STRING (Syntax.STRING(STRING)) 36 | | TRUE (Syntax.TRUE) | FALSE (Syntax.FALSE) 37 | prim : EQ (Syntax.EQ) | ADD (Syntax.ADD) | SUB (Syntax.SUB) 38 | | MUL (Syntax.MUL) | DIV (Syntax.DIV) 39 | 40 | -------------------------------------------------------------------------------- /examples/chap5/parser/CoreML.grm.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "ml-yacc-lib.smi" 3 | _require "./Syntax.smi" 4 | _require "./CoreML.grm.sig" 5 | structure CoreMLLrVals = 6 | struct 7 | structure Parser = struct 8 | type token (= boxed) 9 | type stream (= boxed) 10 | type result = Syntax.dec 11 | type pos = int 12 | type arg = unit 13 | exception ParseError 14 | val makeStream : {lexer:unit -> token} -> stream 15 | val getStream : stream -> token * stream 16 | val sameToken : token * token -> bool 17 | val parse : {lookahead:int, stream:stream,arg: arg, 18 | error: (string * pos * pos -> unit)} 19 | -> result * stream 20 | end 21 | structure Tokens = struct 22 | type pos = Parser.pos 23 | type token = Parser.token 24 | val EQ: pos * pos -> token 25 | val DIV: pos * pos -> token 26 | val SUB: pos * pos -> token 27 | val MUL: pos * pos -> token 28 | val ADD: pos * pos -> token 29 | val VAL: pos * pos -> token 30 | val THEN: pos * pos -> token 31 | val TRUE: pos * pos -> token 32 | val STRING: (string) * pos * pos -> token 33 | val SEMICOLON: pos * pos -> token 34 | val RPAREN: pos * pos -> token 35 | val LPAREN: pos * pos -> token 36 | val INT: (int) * pos * pos -> token 37 | val IF: pos * pos -> token 38 | val ID: (string) * pos * pos -> token 39 | val HASH2: pos * pos -> token 40 | val HASH1: pos * pos -> token 41 | val FUN: pos * pos -> token 42 | val FN: pos * pos -> token 43 | val FALSE: pos * pos -> token 44 | val EQUAL: pos * pos -> token 45 | val ELSE: pos * pos -> token 46 | val DARROW: pos * pos -> token 47 | val COMMA: pos * pos -> token 48 | val EOF: pos * pos -> token 49 | end 50 | end 51 | 52 | 53 | -------------------------------------------------------------------------------- /examples/chap5/parser/CoreML.lex: -------------------------------------------------------------------------------- 1 | structure Tokens = CoreMLLrVals.Tokens 2 | type token = Tokens.token 3 | type pos = Tokens.pos 4 | type lexresult = Tokens.token 5 | exception Error 6 | 7 | val eof = fn _ => Tokens.EOF (0,0) 8 | fun atoi s = valOf (Int.fromString s) 9 | 10 | %% 11 | %structure CoreMLLex 12 | 13 | alpha = [A-Za-z]; 14 | digit = [0-9]; 15 | num = {digit}+; 16 | idchars = {alpha}|{digit}; 17 | id = {alpha}{idchars}*; 18 | ws = "\ " | "\t" | "\r\n" | "\n" | "\r"; 19 | 20 | %% 21 | 22 | {ws} => (lex()); 23 | "add" => (Tokens.ADD (yypos,yypos+3)); 24 | "mul" => (Tokens.MUL (yypos,yypos+3)); 25 | "sub" => (Tokens.SUB (yypos,yypos+3)); 26 | "div" => (Tokens.DIV (yypos,yypos+3)); 27 | "eq" => (Tokens.EQ (yypos,yypos+2)); 28 | "else" => (Tokens.ELSE (yypos,yypos+4)); 29 | "true" => (Tokens.TRUE (yypos,yypos+4)); 30 | "false" => (Tokens.FALSE (yypos,yypos+5)); 31 | "fn" => (Tokens.FN (yypos,yypos+2)); 32 | "if" => (Tokens.IF (yypos,yypos+2)); 33 | "then" => (Tokens.THEN (yypos,yypos+4)); 34 | "val" => (Tokens.VAL (yypos,yypos+3)); 35 | "fun" => (Tokens.FUN (yypos,yypos+3)); 36 | "(" => (Tokens.LPAREN (yypos,yypos+1)); 37 | ")" => (Tokens.RPAREN (yypos,yypos+1)); 38 | "," => (Tokens.COMMA (yypos,yypos+1)); 39 | ";" => (Tokens.SEMICOLON (yypos,yypos+1)); 40 | "=" => (Tokens.EQUAL (yypos,yypos+1)); 41 | "=>" => (Tokens.DARROW (yypos,yypos+2)); 42 | "#1" => (Tokens.HASH1 (yypos,yypos+2)); 43 | "#2" => (Tokens.HASH2 (yypos,yypos+2)); 44 | {id} => (Tokens.ID 45 | ( 46 | yytext, 47 | yypos, 48 | yypos + String.size yytext 49 | )); 50 | {num} => (Tokens.INT 51 | ( 52 | atoi yytext, 53 | yypos, 54 | yypos + String.size yytext 55 | )); 56 | ~{num} => (Tokens.INT 57 | ( 58 | atoi yytext, 59 | yypos, 60 | yypos + String.size yytext 61 | )); 62 | \"{idchars}*\" => (Tokens.STRING 63 | (String.substring(yytext,1,String.size yytext - 2), 64 | yypos - String.size yytext + 1, 65 | yypos + 1)); 66 | . => (Tokens.ID 67 | (yytext, 68 | yypos, 69 | yypos + 1)); 70 | -------------------------------------------------------------------------------- /examples/chap5/parser/CoreML.lex.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "ml-yacc-lib.smi" 3 | _require "./CoreML.grm.smi" 4 | structure CoreMLLex = 5 | struct 6 | val makeLexer : (int -> string) -> unit 7 | -> CoreMLLrVals.Tokens.token 8 | end 9 | -------------------------------------------------------------------------------- /examples/chap5/parser/Parser.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "./Syntax.smi" 3 | _require "./CoreML.lex.smi" 4 | _require "./CoreML.grm.smi" 5 | structure Parser = 6 | struct 7 | exception EOF 8 | exception ParseError = CoreMLLrVals.Parser.ParseError 9 | type stream (= CoreMLLrVals.Parser.stream) 10 | val doParse : stream -> Syntax.dec * stream 11 | val makeStream : TextIO.instream -> stream 12 | end 13 | -------------------------------------------------------------------------------- /examples/chap5/parser/Parser.sml: -------------------------------------------------------------------------------- 1 | structure Parser = 2 | struct 3 | exception EOF 4 | exception ParseError = CoreMLLrVals.Parser.ParseError 5 | structure P = CoreMLLrVals.Parser 6 | structure T = CoreMLLrVals.Tokens 7 | type stream = P.stream 8 | fun print_error (s,pos1,pos2) = 9 | print ("Syntax error(" 10 | ^ Int.toString pos1 11 | ^ "-" ^ Int.toString pos2 ^ ") :" ^ s ^ "\n") 12 | fun discardSemicolons stream = 13 | let val (token, rest) = P.getStream stream 14 | in if P.sameToken (token, T.SEMICOLON (0,0)) then 15 | discardSemicolons rest 16 | else if P.sameToken (token, T.EOF (0,0)) then raise EOF 17 | else stream 18 | end 19 | fun doParse stream = 20 | let val stream = discardSemicolons stream 21 | val (dec, stream) = 22 | P.parse {lookahead=0, stream=stream, 23 | error=print_error,arg=()} 24 | val _ = print ("Parse result:\n" 25 | ^ (Syntax.decToString dec) ^ "\n") 26 | in (dec, stream) end 27 | fun makeStream inStream = 28 | let val lexer = CoreMLLex.makeLexer 29 | (fn n => TextIO.inputN (inStream,1)) 30 | in P.makeStream {lexer=lexer} end 31 | end 32 | -------------------------------------------------------------------------------- /examples/chap5/parser/Syntax.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | structure Syntax = 3 | struct 4 | datatype prim = EQ | ADD | SUB | MUL | DIV 5 | datatype exp 6 | = EXPID of string | INT of int | STRING of string 7 | | TRUE | FALSE | EXPFN of string * exp 8 | | EXPAPP of exp * exp | EXPPAIR of exp * exp 9 | | EXPPROJ1 of exp | EXPPROJ2 of exp 10 | | EXPPRIM of prim * exp * exp 11 | | EXPIF of exp * exp * exp 12 | | EXPFIX of string * string * exp 13 | and dec 14 | = VAL of string * exp 15 | val expToString : exp -> string 16 | val decToString : dec -> string 17 | end 18 | -------------------------------------------------------------------------------- /examples/chap5/parser/Syntax.sml: -------------------------------------------------------------------------------- 1 | (** 2 | * expression syntax 3 | * @copyright (c) 2006, Tohoku University. 4 | * @author Atsushi Ohori 5 | *) 6 | structure Syntax = 7 | struct 8 | datatype prim = EQ | ADD | SUB | MUL | DIV 9 | datatype exp 10 | = EXPID of string | INT of int | STRING of string 11 | | TRUE | FALSE | EXPFN of string * exp 12 | | EXPAPP of exp * exp | EXPPAIR of exp * exp 13 | | EXPPROJ1 of exp | EXPPROJ2 of exp 14 | | EXPPRIM of prim * exp * exp 15 | | EXPIF of exp * exp * exp 16 | | EXPFIX of string * string * exp 17 | and dec 18 | = VAL of string * exp 19 | fun expToString exp = 20 | case exp of 21 | INT int => Int.toString int 22 | | STRING string => "\"" ^ string ^ "\"" 23 | | TRUE => "true" 24 | | FALSE => "false" 25 | | EXPID string => string 26 | | EXPPAIR (exp1, exp2) => 27 | "(" ^ expToString exp1 ^ "," ^ expToString exp2 ^ ")" 28 | | EXPAPP (exp1, exp2) => 29 | "(" ^ expToString exp1 ^ " " ^ expToString exp2 ^ ")" 30 | | EXPIF (exp1, exp2, exp3) => 31 | "if " 32 | ^ expToString exp1 33 | ^ " then " 34 | ^ expToString exp2 35 | ^ " else " 36 | ^ expToString exp3 37 | | EXPFN (string, exp) => 38 | "(fn " ^ string ^ " => " ^ expToString exp ^ ")" 39 | | EXPPROJ1 exp => "#1 " ^ expToString exp 40 | | EXPPROJ2 exp => "#2 " ^ expToString exp 41 | | EXPFIX (f, x, exp) => 42 | "(fix " 43 | ^ f 44 | ^ "(" 45 | ^ x 46 | ^ ") => " ^ expToString exp ^ ")" 47 | | EXPPRIM (p, exp1, exp2) => 48 | let 49 | val prim = case p of ADD => "add" | SUB => "sub" 50 | | MUL => "mul" | DIV => "div" 51 | | EQ => "eq" 52 | in 53 | "prim(" ^ prim ^ "," ^ expToString exp1 ^ "," ^ expToString exp2 ^ ")" 54 | end 55 | and decToString dec = 56 | case dec of 57 | VAL (x, exp) => 58 | "val " ^ x ^ " = " ^ expToString exp 59 | (* 60 | fun printExp exp = print (expToString exp) 61 | fun printDec dec = print (decToString dec) 62 | fun expToString exp = Dynamic.format exp 63 | fun decToString dec = Dynamic.format dec 64 | *) 65 | end 66 | -------------------------------------------------------------------------------- /examples/chap6-4/main/Main.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "./Top.smi" 3 | -------------------------------------------------------------------------------- /examples/chap6-4/main/Main.sml: -------------------------------------------------------------------------------- 1 | val _ = case CommandLine.arguments() of 2 | h::_ => Top.top h 3 | | nil => Top.top ""; 4 | -------------------------------------------------------------------------------- /examples/chap6-4/main/Makefile: -------------------------------------------------------------------------------- 1 | SMLSHARP = smlsharp 2 | SMLFLAGS = -O2 3 | LIBS = 4 | all: Main 5 | Main: ../parser/Syntax.smi ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi \ 6 | ../parser/CoreML.lex.smi ../parser/Parser.smi ../typeinf/Type.smi \ 7 | ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi ../typeinf/Typeinf.smi \ 8 | Top.smi Main.smi ../parser/Syntax.o ../parser/CoreML.grm.o \ 9 | ../parser/CoreML.lex.o ../parser/Parser.o ../typeinf/Type.o \ 10 | ../typeinf/TypeUtils.o ../typeinf/UnifyTy.o ../typeinf/Typeinf.o Top.o Main.o 11 | $(SMLSHARP) $(LDFLAGS) -o Main Main.smi $(LIBS) 12 | ../parser/Syntax.o: ../parser/Syntax.sml ../parser/Syntax.smi 13 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/Syntax.o -c ../parser/Syntax.sml 14 | ../parser/CoreML.grm.sml: ../parser/CoreML.grm 15 | smlyacc ../parser/CoreML.grm 16 | ../parser/CoreML.grm.sig: ../parser/CoreML.grm 17 | smlyacc ../parser/CoreML.grm 18 | ../parser/CoreML.grm.o: ../parser/CoreML.grm.sml ../parser/Syntax.smi \ 19 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi 20 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/CoreML.grm.o -c \ 21 | ../parser/CoreML.grm.sml 22 | ../parser/CoreML.lex.sml: ../parser/CoreML.lex 23 | smllex ../parser/CoreML.lex 24 | ../parser/CoreML.lex.o: ../parser/CoreML.lex.sml ../parser/Syntax.smi \ 25 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi 26 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/CoreML.lex.o -c \ 27 | ../parser/CoreML.lex.sml 28 | ../parser/Parser.o: ../parser/Parser.sml ../parser/Syntax.smi \ 29 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi \ 30 | ../parser/Parser.smi 31 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/Parser.o -c ../parser/Parser.sml 32 | ../typeinf/Type.o: ../typeinf/Type.sml ../typeinf/Type.smi 33 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/Type.o -c ../typeinf/Type.sml 34 | ../typeinf/TypeUtils.o: ../typeinf/TypeUtils.sml ../typeinf/Type.smi \ 35 | ../typeinf/TypeUtils.smi 36 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/TypeUtils.o -c \ 37 | ../typeinf/TypeUtils.sml 38 | ../typeinf/UnifyTy.o: ../typeinf/UnifyTy.sml ../typeinf/Type.smi \ 39 | ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi 40 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/UnifyTy.o -c \ 41 | ../typeinf/UnifyTy.sml 42 | ../typeinf/Typeinf.o: ../typeinf/Typeinf.sml ../parser/Syntax.smi \ 43 | ../typeinf/Type.smi ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi \ 44 | ../typeinf/Typeinf.smi 45 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/Typeinf.o -c \ 46 | ../typeinf/Typeinf.sml 47 | Top.o: Top.sml ../parser/Syntax.smi ../parser/CoreML.grm.sig \ 48 | ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi ../parser/Parser.smi \ 49 | ../typeinf/Type.smi ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi \ 50 | ../typeinf/Typeinf.smi Top.smi 51 | $(SMLSHARP) $(SMLFLAGS) -o Top.o -c Top.sml 52 | Main.o: Main.sml ../parser/Syntax.smi ../parser/CoreML.grm.sig \ 53 | ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi ../parser/Parser.smi \ 54 | ../typeinf/Type.smi ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi \ 55 | ../typeinf/Typeinf.smi Top.smi Main.smi 56 | $(SMLSHARP) $(SMLFLAGS) -o Main.o -c Main.sml 57 | clean: 58 | rm -f ./*.o ../parser/*.o ../typeinf/*.o Main 59 | rm -f ../parser/CoreML.grm.sml ../parser/CoreML.grm.sig ../parser/CoreML.lex.sml 60 | .SUFFIXES: .grm .lex 61 | -------------------------------------------------------------------------------- /examples/chap6-4/main/Top.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "../parser/Parser.smi" 3 | _require "../typeinf/Typeinf.smi" 4 | structure Top = 5 | struct 6 | val top : string -> unit 7 | end 8 | -------------------------------------------------------------------------------- /examples/chap6-4/main/Top.sml: -------------------------------------------------------------------------------- 1 | structure Top = 2 | struct 3 | open Parser 4 | exception NotImplemented 5 | fun readAndPrintLoop stream = 6 | let 7 | val (dec, stream) = doParse stream 8 | val _ = Typeinf.typeinf dec 9 | in 10 | readAndPrintLoop stream 11 | end 12 | fun top file = 13 | let 14 | val inStream = case file of 15 | "" => TextIO.stdIn 16 | | _ => TextIO.openIn file 17 | val stream = Parser.makeStream inStream 18 | in 19 | readAndPrintLoop stream 20 | handle Parser.EOF => () 21 | | Parser.ParseError => 22 | (print "Syntax error\n"; ()) 23 | | Typeinf.TypeError => 24 | (print "Type error\n"; ()); 25 | case file of "" => () 26 | | _ => TextIO.closeIn inStream 27 | end 28 | end 29 | -------------------------------------------------------------------------------- /examples/chap6-4/parser/CoreML.grm: -------------------------------------------------------------------------------- 1 | %% 2 | %pos int 3 | %term ADD | COMMA | DARROW | DIV | ELSE | EOF | EQ | EQUAL 4 | | FALSE | FN | FUN | HASH1 | HASH2 | ID of string | IF 5 | | INT of int | LPAREN | MUL | RPAREN | SEMICOLON 6 | | STRING of string | SUB | THEN | TRUE | VAL 7 | %nonterm appexp of Syntax.exp | atexp of Syntax.exp 8 | | const of Syntax.exp | exp of Syntax.exp 9 | | dec of Syntax.dec | top of Syntax.dec 10 | | prim of Syntax.prim 11 | %start top 12 | %name CoreML 13 | %eop EOF SEMICOLON 14 | %noshift EOF 15 | %% 16 | top : dec (dec) 17 | dec : VAL ID EQUAL exp (Syntax.VAL(ID,exp)) 18 | | FUN ID ID EQUAL exp 19 | (Syntax.VAL(ID1, Syntax.EXPFIX(ID1, ID2, exp))) 20 | exp : appexp (appexp) 21 | | IF exp THEN exp ELSE exp (Syntax.EXPIF(exp1, exp2, exp3)) 22 | | FN ID DARROW exp (Syntax.EXPFN(ID, exp)) 23 | appexp : atexp (atexp) 24 | | appexp atexp (Syntax.EXPAPP(appexp, atexp)) 25 | atexp : const (const) 26 | | ID (Syntax.EXPID(ID)) 27 | | LPAREN exp COMMA exp RPAREN 28 | (Syntax.EXPPAIR(exp1, exp2)) 29 | | LPAREN exp RPAREN (exp) 30 | | HASH1 atexp (Syntax.EXPPROJ1 atexp) 31 | | HASH2 atexp (Syntax.EXPPROJ2 atexp) 32 | | prim LPAREN exp COMMA exp RPAREN 33 | (Syntax.EXPPRIM(prim, exp1, exp2)) 34 | const : INT (Syntax.INT(INT)) 35 | | STRING (Syntax.STRING(STRING)) 36 | | TRUE (Syntax.TRUE) | FALSE (Syntax.FALSE) 37 | prim : EQ (Syntax.EQ) | ADD (Syntax.ADD) | SUB (Syntax.SUB) 38 | | MUL (Syntax.MUL) | DIV (Syntax.DIV) 39 | 40 | -------------------------------------------------------------------------------- /examples/chap6-4/parser/CoreML.grm.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "ml-yacc-lib.smi" 3 | _require "./Syntax.smi" 4 | _require "./CoreML.grm.sig" 5 | structure CoreMLLrVals = 6 | struct 7 | structure Parser = struct 8 | type token (= boxed) 9 | type stream (= boxed) 10 | type result = Syntax.dec 11 | type pos = int 12 | type arg = unit 13 | exception ParseError 14 | val makeStream : {lexer:unit -> token} -> stream 15 | val getStream : stream -> token * stream 16 | val sameToken : token * token -> bool 17 | val parse : {lookahead:int, stream:stream,arg: arg, 18 | error: (string * pos * pos -> unit)} 19 | -> result * stream 20 | end 21 | structure Tokens = struct 22 | type pos = Parser.pos 23 | type token = Parser.token 24 | val EQ: pos * pos -> token 25 | val DIV: pos * pos -> token 26 | val SUB: pos * pos -> token 27 | val MUL: pos * pos -> token 28 | val ADD: pos * pos -> token 29 | val VAL: pos * pos -> token 30 | val THEN: pos * pos -> token 31 | val TRUE: pos * pos -> token 32 | val STRING: (string) * pos * pos -> token 33 | val SEMICOLON: pos * pos -> token 34 | val RPAREN: pos * pos -> token 35 | val LPAREN: pos * pos -> token 36 | val INT: (int) * pos * pos -> token 37 | val IF: pos * pos -> token 38 | val ID: (string) * pos * pos -> token 39 | val HASH2: pos * pos -> token 40 | val HASH1: pos * pos -> token 41 | val FUN: pos * pos -> token 42 | val FN: pos * pos -> token 43 | val FALSE: pos * pos -> token 44 | val EQUAL: pos * pos -> token 45 | val ELSE: pos * pos -> token 46 | val DARROW: pos * pos -> token 47 | val COMMA: pos * pos -> token 48 | val EOF: pos * pos -> token 49 | end 50 | end 51 | 52 | 53 | -------------------------------------------------------------------------------- /examples/chap6-4/parser/CoreML.lex: -------------------------------------------------------------------------------- 1 | structure Tokens = CoreMLLrVals.Tokens 2 | type token = Tokens.token 3 | type pos = Tokens.pos 4 | type lexresult = Tokens.token 5 | exception Error 6 | 7 | val eof = fn _ => Tokens.EOF (0,0) 8 | fun atoi s = valOf (Int.fromString s) 9 | 10 | %% 11 | %structure CoreMLLex 12 | 13 | alpha = [A-Za-z]; 14 | digit = [0-9]; 15 | num = {digit}+; 16 | idchars = {alpha}|{digit}; 17 | id = {alpha}{idchars}*; 18 | ws = "\ " | "\t" | "\r\n" | "\n" | "\r"; 19 | 20 | %% 21 | 22 | {ws} => (lex()); 23 | "add" => (Tokens.ADD (yypos,yypos+3)); 24 | "mul" => (Tokens.MUL (yypos,yypos+3)); 25 | "sub" => (Tokens.SUB (yypos,yypos+3)); 26 | "div" => (Tokens.DIV (yypos,yypos+3)); 27 | "eq" => (Tokens.EQ (yypos,yypos+2)); 28 | "else" => (Tokens.ELSE (yypos,yypos+4)); 29 | "true" => (Tokens.TRUE (yypos,yypos+4)); 30 | "false" => (Tokens.FALSE (yypos,yypos+5)); 31 | "fn" => (Tokens.FN (yypos,yypos+2)); 32 | "if" => (Tokens.IF (yypos,yypos+2)); 33 | "then" => (Tokens.THEN (yypos,yypos+4)); 34 | "val" => (Tokens.VAL (yypos,yypos+3)); 35 | "fun" => (Tokens.FUN (yypos,yypos+3)); 36 | "(" => (Tokens.LPAREN (yypos,yypos+1)); 37 | ")" => (Tokens.RPAREN (yypos,yypos+1)); 38 | "," => (Tokens.COMMA (yypos,yypos+1)); 39 | ";" => (Tokens.SEMICOLON (yypos,yypos+1)); 40 | "=" => (Tokens.EQUAL (yypos,yypos+1)); 41 | "=>" => (Tokens.DARROW (yypos,yypos+2)); 42 | "#1" => (Tokens.HASH1 (yypos,yypos+2)); 43 | "#2" => (Tokens.HASH2 (yypos,yypos+2)); 44 | {id} => (Tokens.ID 45 | ( 46 | yytext, 47 | yypos, 48 | yypos + String.size yytext 49 | )); 50 | {num} => (Tokens.INT 51 | ( 52 | atoi yytext, 53 | yypos, 54 | yypos + String.size yytext 55 | )); 56 | ~{num} => (Tokens.INT 57 | ( 58 | atoi yytext, 59 | yypos, 60 | yypos + String.size yytext 61 | )); 62 | \"{idchars}*\" => (Tokens.STRING 63 | (String.substring(yytext,1,String.size yytext - 2), 64 | yypos - String.size yytext + 1, 65 | yypos + 1)); 66 | . => (Tokens.ID 67 | (yytext, 68 | yypos, 69 | yypos + 1)); 70 | -------------------------------------------------------------------------------- /examples/chap6-4/parser/CoreML.lex.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "ml-yacc-lib.smi" 3 | _require "./CoreML.grm.smi" 4 | structure CoreMLLex = 5 | struct 6 | val makeLexer : (int -> string) -> unit 7 | -> CoreMLLrVals.Tokens.token 8 | end 9 | -------------------------------------------------------------------------------- /examples/chap6-4/parser/Parser.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "./Syntax.smi" 3 | _require "./CoreML.lex.smi" 4 | _require "./CoreML.grm.smi" 5 | structure Parser = 6 | struct 7 | exception EOF 8 | exception ParseError = CoreMLLrVals.Parser.ParseError 9 | type stream (= CoreMLLrVals.Parser.stream) 10 | val doParse : stream -> Syntax.dec * stream 11 | val makeStream : TextIO.instream -> stream 12 | end 13 | -------------------------------------------------------------------------------- /examples/chap6-4/parser/Parser.sml: -------------------------------------------------------------------------------- 1 | structure Parser = 2 | struct 3 | exception EOF 4 | exception ParseError = CoreMLLrVals.Parser.ParseError 5 | structure P = CoreMLLrVals.Parser 6 | structure T = CoreMLLrVals.Tokens 7 | type stream = P.stream 8 | fun print_error (s,pos1,pos2) = 9 | print ("Syntax error(" 10 | ^ Int.toString pos1 11 | ^ "-" ^ Int.toString pos2 ^ ") :" ^ s ^ "\n") 12 | fun discardSemicolons stream = 13 | let val (token, rest) = P.getStream stream 14 | in if P.sameToken (token, T.SEMICOLON (0,0)) then 15 | discardSemicolons rest 16 | else if P.sameToken (token, T.EOF (0,0)) then raise EOF 17 | else stream 18 | end 19 | fun doParse stream = 20 | let val stream = discardSemicolons stream 21 | val (dec, stream) = 22 | P.parse {lookahead=0, stream=stream, 23 | error=print_error,arg=()} 24 | val _ = print ("Parse result:\n" 25 | ^ (Syntax.decToString dec) ^ "\n") 26 | in (dec, stream) end 27 | fun makeStream inStream = 28 | let val lexer = CoreMLLex.makeLexer 29 | (fn n => TextIO.inputN (inStream,1)) 30 | in P.makeStream {lexer=lexer} end 31 | end 32 | -------------------------------------------------------------------------------- /examples/chap6-4/parser/Syntax.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | structure Syntax = 3 | struct 4 | datatype prim = EQ | ADD | SUB | MUL | DIV 5 | datatype exp 6 | = EXPID of string | INT of int | STRING of string 7 | | TRUE | FALSE | EXPFN of string * exp 8 | | EXPAPP of exp * exp | EXPPAIR of exp * exp 9 | | EXPPROJ1 of exp | EXPPROJ2 of exp 10 | | EXPPRIM of prim * exp * exp 11 | | EXPIF of exp * exp * exp 12 | | EXPFIX of string * string * exp 13 | and dec 14 | = VAL of string * exp 15 | val expToString : exp -> string 16 | val decToString : dec -> string 17 | end 18 | -------------------------------------------------------------------------------- /examples/chap6-4/parser/Syntax.sml: -------------------------------------------------------------------------------- 1 | (** 2 | * expression syntax 3 | * @copyright (c) 2006, Tohoku University. 4 | * @author Atsushi Ohori 5 | *) 6 | structure Syntax = 7 | struct 8 | datatype prim = EQ | ADD | SUB | MUL | DIV 9 | datatype exp 10 | = EXPID of string | INT of int | STRING of string 11 | | TRUE | FALSE | EXPFN of string * exp 12 | | EXPAPP of exp * exp | EXPPAIR of exp * exp 13 | | EXPPROJ1 of exp | EXPPROJ2 of exp 14 | | EXPPRIM of prim * exp * exp 15 | | EXPIF of exp * exp * exp 16 | | EXPFIX of string * string * exp 17 | and dec 18 | = VAL of string * exp 19 | fun expToString exp = 20 | case exp of 21 | INT int => Int.toString int 22 | | STRING string => "\"" ^ string ^ "\"" 23 | | TRUE => "true" 24 | | FALSE => "false" 25 | | EXPID string => string 26 | | EXPPAIR (exp1, exp2) => 27 | "(" ^ expToString exp1 ^ "," ^ expToString exp2 ^ ")" 28 | | EXPAPP (exp1, exp2) => 29 | "(" ^ expToString exp1 ^ " " ^ expToString exp2 ^ ")" 30 | | EXPIF (exp1, exp2, exp3) => 31 | "if " 32 | ^ expToString exp1 33 | ^ " then " 34 | ^ expToString exp2 35 | ^ " else " 36 | ^ expToString exp3 37 | | EXPFN (string, exp) => 38 | "(fn " ^ string ^ " => " ^ expToString exp ^ ")" 39 | | EXPPROJ1 exp => "#1 " ^ expToString exp 40 | | EXPPROJ2 exp => "#2 " ^ expToString exp 41 | | EXPFIX (f, x, exp) => 42 | "(fix " 43 | ^ f 44 | ^ "(" 45 | ^ x 46 | ^ ") => " ^ expToString exp ^ ")" 47 | | EXPPRIM (p, exp1, exp2) => 48 | let 49 | val prim = case p of ADD => "add" | SUB => "sub" 50 | | MUL => "mul" | DIV => "div" 51 | | EQ => "eq" 52 | in 53 | "prim(" ^ prim ^ "," ^ expToString exp1 ^ "," ^ expToString exp2 ^ ")" 54 | end 55 | and decToString dec = 56 | case dec of 57 | VAL (x, exp) => 58 | "val " ^ x ^ " = " ^ expToString exp 59 | (* 60 | fun printExp exp = print (expToString exp) 61 | fun printDec dec = print (decToString dec) 62 | fun expToString exp = Dynamic.format exp 63 | fun decToString dec = Dynamic.format dec 64 | *) 65 | end 66 | -------------------------------------------------------------------------------- /examples/chap6-4/typeinf/Type.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | structure Type = 3 | struct 4 | datatype ty 5 | = TYVARty of string | INTty | STRINGty | BOOLty 6 | | FUNty of ty * ty | PAIRty of ty * ty 7 | | POLYty of string list * ty 8 | val newTy : unit -> ty 9 | val tyToString : ty -> string 10 | end 11 | -------------------------------------------------------------------------------- /examples/chap6-4/typeinf/Type.sml: -------------------------------------------------------------------------------- 1 | structure Type = 2 | struct 3 | local 4 | val nextTyId = ref 0 5 | fun newTyId () = (!nextTyId before nextTyId := !nextTyId + 1) 6 | in 7 | fun initSeed () = nextTyId := 0 8 | fun newTyIdName () = 9 | let 10 | fun tyIdName tid = 11 | let 12 | fun numeral n = 13 | if n < 26 14 | then [ord #"a" + n] 15 | else 16 | let val (msb, rest) = (n mod 26, (n div 26) - 1) 17 | in (ord #"a" + msb) :: (numeral rest) 18 | end 19 | in 20 | (implode(map chr (rev (numeral tid)))) 21 | end 22 | in 23 | tyIdName (newTyId()) 24 | end 25 | end 26 | datatype ty = 27 | INTty 28 | | STRINGty 29 | | BOOLty 30 | | TYVARty of string 31 | | FUNty of ty * ty 32 | | PAIRty of ty * ty 33 | | POLYty of string list * ty 34 | fun newTy () = TYVARty (newTyIdName()) 35 | fun tyToString ty = 36 | case ty of 37 | INTty => "int" 38 | | STRINGty => "string" 39 | | BOOLty => "bool" 40 | | TYVARty string => "'" ^ string 41 | | FUNty (ty1, ty2) => 42 | "(" ^ tyToString ty1 ^ " -> " ^ tyToString ty2 ^ ")" 43 | | PAIRty (ty1, ty2) => 44 | "(" ^ tyToString ty1 ^ " * " ^ tyToString ty2 ^ ")" 45 | | POLYty (tids, ty) => 46 | "[" 47 | ^ 48 | String.concatWith "," tids 49 | ^ 50 | "." 51 | ^ 52 | tyToString ty 53 | ^ 54 | "]" 55 | (* 56 | fun tyToString ty = Dynamic.format ty 57 | *) 58 | end 59 | -------------------------------------------------------------------------------- /examples/chap6-4/typeinf/TypeUtils.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SSet.smi" 3 | _require "compiler/libs/env/main/SEnv.smi" 4 | _require "./Type.smi" 5 | structure TypeUtils = 6 | struct 7 | type subst = Type.ty SEnv.map 8 | type tyEnv = Type.ty SEnv.map 9 | val substTy : subst -> Type.ty -> Type.ty 10 | val emptySubst : subst 11 | val substTyEnv : subst -> tyEnv -> tyEnv 12 | val composeSubst : subst -> subst -> subst 13 | val freshInst : Type.ty -> Type.ty 14 | val emptyTyEnv : tyEnv 15 | val singletonTyEnv : string * Type.ty -> tyEnv 16 | val findTyEnv : tyEnv * string -> Type.ty option 17 | val matches : tyEnv * tyEnv -> (Type.ty * Type.ty) list 18 | val unionTyEnv : tyEnv * tyEnv -> tyEnv 19 | val removeTyEnv : tyEnv * string -> tyEnv 20 | val tyEnvToString : tyEnv -> string 21 | end 22 | -------------------------------------------------------------------------------- /examples/chap6-4/typeinf/TypeUtils.sml: -------------------------------------------------------------------------------- 1 | structure TypeUtils = 2 | struct 3 | local 4 | open Type 5 | in 6 | type subst = ty SEnv.map 7 | val emptySubst = SEnv.empty 8 | fun substTy subst ty = 9 | case ty of 10 | INTty => ty 11 | | STRINGty => ty 12 | | BOOLty => ty 13 | | TYVARty string => 14 | (case SEnv.find (subst, string) of 15 | NONE => ty 16 | | SOME ty => ty) 17 | | FUNty (ty1, ty2) => 18 | FUNty (substTy subst ty1, substTy subst ty2) 19 | | PAIRty (ty1, ty2) => 20 | PAIRty (substTy subst ty1, substTy subst ty2) 21 | | POLYty (tids, ty) => 22 | POLYty (tids, substTy subst ty) 23 | fun composeSubst subst1 subst2 = 24 | SEnv.unionWith 25 | (fn (ty1, ty2) => ty1) 26 | (SEnv.map (substTy subst1) subst2, 27 | subst1) 28 | type tyEnv = ty SEnv.map 29 | val findTyEnv = SEnv.find 30 | fun substTyEnv subst tyEnv = 31 | SEnv.map (substTy subst) tyEnv 32 | val emptyTyEnv = SEnv.empty 33 | fun singletonTyEnv (tyID, ty) = SEnv.singleton (tyID, ty) 34 | fun matches (tyEnv1, tyEnv2) = 35 | SEnv.listItems 36 | (SEnv.intersectWith (fn x => x) (tyEnv1, tyEnv2)) 37 | fun unionTyEnv (tyEnv1, tyEnv2) = 38 | SEnv.unionWith #1 (tyEnv1, tyEnv2) 39 | fun removeTyEnv (tyEnv, string) = #1 (SEnv.remove(tyEnv, string)) 40 | fun freshInst ty = 41 | case ty of 42 | POLYty (tids, ty) => 43 | let val S = 44 | foldr (fn (tid, S) => 45 | let val newty = newTy () 46 | in SEnv.insert(S, tid, newty) end) 47 | emptySubst 48 | tids 49 | in substTy S ty end 50 | | _ => ty 51 | 52 | fun tyEnvToString tyEnv = 53 | let 54 | val stringTyList = SEnv.listItemsi tyEnv 55 | in 56 | "{" ^ (String.concatWith " , " 57 | (map (fn (id,ty) => id ^ ":" ^ tyToString ty) stringTyList)) 58 | ^ "}" 59 | end 60 | end 61 | end 62 | -------------------------------------------------------------------------------- /examples/chap6-4/typeinf/Typeinf.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "../parser/Syntax.smi" 3 | _require "./Type.smi" 4 | _require "./TypeUtils.smi" 5 | _require "./UnifyTy.smi" 6 | structure Typeinf = 7 | struct 8 | exception TypeError 9 | val typeinf : Syntax.dec -> unit 10 | end 11 | -------------------------------------------------------------------------------- /examples/chap6-4/typeinf/Typeinf.sml: -------------------------------------------------------------------------------- 1 | (** 2 | * Type inference module 3 | * @author Atsushi Ohori 4 | *) 5 | structure Typeinf = struct 6 | open Type Syntax TypeUtils UnifyTy 7 | exception TypeError 8 | exception TypeError 9 | fun PTS absyn = 10 | case absyn of 11 | INT int => (emptyTyEnv, INTty) 12 | | STRING string => (emptyTyEnv, INTty) 13 | | TRUE => (emptyTyEnv, BOOLty) 14 | | FALSE => (emptyTyEnv, BOOLty) 15 | | EXPID string => 16 | let 17 | val newty = newTy() 18 | in 19 | (singletonTyEnv(string, newty), newty) 20 | end 21 | | EXPPAIR (exp1, exp2) => 22 | let 23 | val (tyEnv1, ty1) = PTS exp1 24 | val (tyEnv2, ty2) = PTS exp2 25 | val tyEquations = matches (tyEnv1, tyEnv2) 26 | val subst = unify tyEquations 27 | val tEnv3 = 28 | unionTyEnv 29 | (substTyEnv subst tyEnv1, 30 | substTyEnv subst tyEnv2) 31 | in 32 | (tEnv3, substTy subst (PAIRty(ty1, ty2))) 33 | end 34 | | EXPAPP (exp1, exp2) => 35 | let 36 | val (tyEnv1, ty1) = PTS exp1 37 | val (tyEnv2, ty2) = PTS exp2 38 | val tyEquations = matches (tyEnv1, tyEnv2) 39 | val newty = newTy() 40 | val subst = unify ((FUNty(ty2, newty), ty1) 41 | :: tyEquations) 42 | val tyEnv3 = 43 | unionTyEnv 44 | (substTyEnv subst tyEnv1, 45 | substTyEnv subst tyEnv2) 46 | in 47 | (tyEnv3, substTy subst newty) 48 | end 49 | | EXPFN (string, exp) => 50 | let 51 | val (tyEnv, ty) = PTS exp 52 | in 53 | case findTyEnv(tyEnv, string) of 54 | SOME domty => 55 | (removeTyEnv(tyEnv, string), 56 | FUNty(domty, ty)) 57 | | NONE => (tyEnv, FUNty(newTy(), ty)) 58 | end 59 | | _ => raise TypeError 60 | fun typeinf dec = 61 | let 62 | val exp = case dec of 63 | Syntax.VAL (id, exp) => exp 64 | val (tyEnv, ty) = PTS exp 65 | val _ = print 66 | ("Inferred Typing:\n" 67 | ^ TypeUtils.tyEnvToString tyEnv 68 | ^ " |- " 69 | ^ Syntax.expToString exp 70 | ^ " : " 71 | ^ Type.tyToString ty 72 | ^ "\n" 73 | ) 74 | in 75 | () 76 | end 77 | end 78 | -------------------------------------------------------------------------------- /examples/chap6-4/typeinf/UnifyTy.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SSet.smi" 3 | _require "compiler/libs/env/main/SEnv.smi" 4 | _require "./Type.smi" 5 | _require "./TypeUtils.smi" 6 | structure UnifyTy = struct 7 | exception UnifyTy 8 | val FTV : Type.ty -> SSet.set 9 | val unify : (Type.ty * Type.ty) list -> TypeUtils.subst 10 | end 11 | -------------------------------------------------------------------------------- /examples/chap6-4/typeinf/UnifyTy.sml: -------------------------------------------------------------------------------- 1 | structure UnifyTy = struct 2 | open Type TypeUtils 3 | exception UnifyTy 4 | fun FTV ty = 5 | let fun scan ty set = 6 | case ty of 7 | TYVARty string => SSet.add (set,string) 8 | | FUNty (domTy, ranTy) => scan ranTy (scan domTy set) 9 | | PAIRty (fstTy, sndTy) => scan sndTy (scan fstTy set) 10 | | _ => set 11 | in scan ty SSet.empty end 12 | fun occurs (TYVARty string, ty) = SSet.member(FTV ty, string) 13 | | occurs _ = false 14 | fun rewrite (nil, S) = S 15 | | rewrite((ty1,ty2)::E, S) = 16 | if ty1 = ty2 then rewrite(E, S) else 17 | case (ty1,ty2) of 18 | (TYVARty tv, _) => 19 | if occurs (ty1, ty2) then raise UnifyTy else 20 | let val S1 = SEnv.singleton(tv, ty2) 21 | in rewrite (map (fn (ty1,ty2) => 22 | (substTy S1 ty1, substTy S1 ty2)) 23 | E, 24 | composeSubst S1 S) 25 | end 26 | | (_, TYVARty tv) => rewrite ((ty2, ty1)::E, S) 27 | | (FUNty(ty11, ty12), FUNty(ty21, ty22)) => 28 | rewrite ((ty11,ty21)::(ty12,ty22)::E, S) 29 | | (PAIRty(ty11, ty12), PAIRty(ty21, ty22)) => 30 | rewrite ((ty11, ty21)::(ty12, ty22)::E,S) 31 | | _ => raise UnifyTy 32 | fun unify E = rewrite (E, SEnv.empty) 33 | end 34 | 35 | -------------------------------------------------------------------------------- /examples/chap6-5/main/Main.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "./Top.smi" 3 | -------------------------------------------------------------------------------- /examples/chap6-5/main/Main.sml: -------------------------------------------------------------------------------- 1 | val _ = case CommandLine.arguments() of 2 | h::_ => Top.top h 3 | | nil => Top.top ""; 4 | -------------------------------------------------------------------------------- /examples/chap6-5/main/Makefile: -------------------------------------------------------------------------------- 1 | SMLSHARP = smlsharp 2 | SMLFLAGS = -O2 3 | LIBS = 4 | all: Main 5 | Main: ../parser/Syntax.smi ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi \ 6 | ../parser/CoreML.lex.smi ../parser/Parser.smi ../typeinf/Type.smi \ 7 | ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi ../typeinf/Typeinf.smi \ 8 | Top.smi Main.smi ../parser/Syntax.o ../parser/CoreML.grm.o \ 9 | ../parser/CoreML.lex.o ../parser/Parser.o ../typeinf/Type.o \ 10 | ../typeinf/TypeUtils.o ../typeinf/UnifyTy.o ../typeinf/Typeinf.o Top.o Main.o 11 | $(SMLSHARP) $(LDFLAGS) -o Main Main.smi $(LIBS) 12 | ../parser/Syntax.o: ../parser/Syntax.sml ../parser/Syntax.smi 13 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/Syntax.o -c ../parser/Syntax.sml 14 | ../parser/CoreML.grm.sig: ../parser/CoreML.grm 15 | smlyacc ../parser/CoreML.grm 16 | ../parser/CoreML.grm.sml: ../parser/CoreML.grm 17 | smlyacc ../parser/CoreML.grm 18 | ../parser/CoreML.grm.o: ../parser/CoreML.grm.sml ../parser/Syntax.smi \ 19 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi 20 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/CoreML.grm.o -c \ 21 | ../parser/CoreML.grm.sml 22 | ../parser/CoreML.lex.sml: ../parser/CoreML.lex 23 | smllex ../parser/CoreML.lex 24 | ../parser/CoreML.lex.o: ../parser/CoreML.lex.sml ../parser/Syntax.smi \ 25 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi 26 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/CoreML.lex.o -c \ 27 | ../parser/CoreML.lex.sml 28 | ../parser/Parser.o: ../parser/Parser.sml ../parser/Syntax.smi \ 29 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi \ 30 | ../parser/Parser.smi 31 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/Parser.o -c ../parser/Parser.sml 32 | ../typeinf/Type.o: ../typeinf/Type.sml ../typeinf/Type.smi 33 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/Type.o -c ../typeinf/Type.sml 34 | ../typeinf/TypeUtils.o: ../typeinf/TypeUtils.sml ../typeinf/Type.smi \ 35 | ../typeinf/TypeUtils.smi 36 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/TypeUtils.o -c \ 37 | ../typeinf/TypeUtils.sml 38 | ../typeinf/UnifyTy.o: ../typeinf/UnifyTy.sml ../typeinf/Type.smi \ 39 | ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi 40 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/UnifyTy.o -c \ 41 | ../typeinf/UnifyTy.sml 42 | ../typeinf/Typeinf.o: ../typeinf/Typeinf.sml ../parser/Syntax.smi \ 43 | ../typeinf/Type.smi ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi \ 44 | ../typeinf/Typeinf.smi 45 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/Typeinf.o -c \ 46 | ../typeinf/Typeinf.sml 47 | Top.o: Top.sml ../parser/Syntax.smi ../parser/CoreML.grm.sig \ 48 | ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi ../parser/Parser.smi \ 49 | ../typeinf/Type.smi ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi \ 50 | ../typeinf/Typeinf.smi Top.smi 51 | $(SMLSHARP) $(SMLFLAGS) -o Top.o -c Top.sml 52 | Main.o: Main.sml ../parser/Syntax.smi ../parser/CoreML.grm.sig \ 53 | ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi ../parser/Parser.smi \ 54 | ../typeinf/Type.smi ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi \ 55 | ../typeinf/Typeinf.smi Top.smi Main.smi 56 | $(SMLSHARP) $(SMLFLAGS) -o Main.o -c Main.sml 57 | clean: 58 | rm -f ./*.o ../parser/*.o ../typeinf/*.o Main 59 | rm -f ../parser/CoreML.grm.sml ../parser/CoreML.grm.sig ../parser/CoreML.lex.sml 60 | .SUFFIXES: .grm .lex 61 | -------------------------------------------------------------------------------- /examples/chap6-5/main/Top.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SEnv.smi" 3 | _require "compiler/libs/env/main/SSet.smi" 4 | _require "../parser/Syntax.smi" 5 | _require "../parser/Parser.smi" 6 | _require "../typeinf/TypeUtils.smi" 7 | _require "../typeinf/Typeinf.smi" 8 | structure Top = 9 | struct 10 | val top : string -> unit 11 | end 12 | -------------------------------------------------------------------------------- /examples/chap6-5/main/Top.sml: -------------------------------------------------------------------------------- 1 | structure Top = 2 | struct 3 | open Parser 4 | exception NotImplemented 5 | fun readAndPrintLoop gamma stream = 6 | let 7 | val (dec, stream) = doParse stream 8 | val newGamma = Typeinf.typeinf gamma dec 9 | in 10 | readAndPrintLoop newGamma stream 11 | end 12 | fun top file = 13 | let 14 | val inStream = case file of 15 | "" => TextIO.stdIn 16 | | _ => TextIO.openIn file 17 | val stream = Parser.makeStream inStream 18 | val gamma = TypeUtils.emptyTyEnv 19 | in 20 | readAndPrintLoop gamma stream 21 | handle Parser.EOF => () 22 | | Parser.ParseError => 23 | (print "Syntax error\n"; ()) 24 | | Typeinf.TypeError => 25 | (print "Type error\n"; ()); 26 | case file of "" => () 27 | | _ => TextIO.closeIn inStream 28 | end 29 | end 30 | -------------------------------------------------------------------------------- /examples/chap6-5/parser/CoreML.grm: -------------------------------------------------------------------------------- 1 | %% 2 | %pos int 3 | %term ADD | COMMA | DARROW | DIV | ELSE | EOF | EQ | EQUAL 4 | | FALSE | FN | FUN | HASH1 | HASH2 | ID of string | IF 5 | | INT of int | LPAREN | MUL | RPAREN | SEMICOLON 6 | | STRING of string | SUB | THEN | TRUE | VAL 7 | %nonterm appexp of Syntax.exp | atexp of Syntax.exp 8 | | const of Syntax.exp | exp of Syntax.exp 9 | | dec of Syntax.dec | top of Syntax.dec 10 | | prim of Syntax.prim 11 | %start top 12 | %name CoreML 13 | %eop EOF SEMICOLON 14 | %noshift EOF 15 | %% 16 | top : dec (dec) 17 | dec : VAL ID EQUAL exp (Syntax.VAL(ID,exp)) 18 | | FUN ID ID EQUAL exp 19 | (Syntax.VAL(ID1, Syntax.EXPFIX(ID1, ID2, exp))) 20 | exp : appexp (appexp) 21 | | IF exp THEN exp ELSE exp (Syntax.EXPIF(exp1, exp2, exp3)) 22 | | FN ID DARROW exp (Syntax.EXPFN(ID, exp)) 23 | appexp : atexp (atexp) 24 | | appexp atexp (Syntax.EXPAPP(appexp, atexp)) 25 | atexp : const (const) 26 | | ID (Syntax.EXPID(ID)) 27 | | LPAREN exp COMMA exp RPAREN 28 | (Syntax.EXPPAIR(exp1, exp2)) 29 | | LPAREN exp RPAREN (exp) 30 | | HASH1 atexp (Syntax.EXPPROJ1 atexp) 31 | | HASH2 atexp (Syntax.EXPPROJ2 atexp) 32 | | prim LPAREN exp COMMA exp RPAREN 33 | (Syntax.EXPPRIM(prim, exp1, exp2)) 34 | const : INT (Syntax.INT(INT)) 35 | | STRING (Syntax.STRING(STRING)) 36 | | TRUE (Syntax.TRUE) | FALSE (Syntax.FALSE) 37 | prim : EQ (Syntax.EQ) | ADD (Syntax.ADD) | SUB (Syntax.SUB) 38 | | MUL (Syntax.MUL) | DIV (Syntax.DIV) 39 | 40 | -------------------------------------------------------------------------------- /examples/chap6-5/parser/CoreML.grm.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "ml-yacc-lib.smi" 3 | _require "./Syntax.smi" 4 | _require "./CoreML.grm.sig" 5 | structure CoreMLLrVals = 6 | struct 7 | structure Parser = struct 8 | type token (= boxed) 9 | type stream (= boxed) 10 | type result = Syntax.dec 11 | type pos = int 12 | type arg = unit 13 | exception ParseError 14 | val makeStream : {lexer:unit -> token} -> stream 15 | val getStream : stream -> token * stream 16 | val sameToken : token * token -> bool 17 | val parse : {lookahead:int, stream:stream,arg: arg, 18 | error: (string * pos * pos -> unit)} 19 | -> result * stream 20 | end 21 | structure Tokens = struct 22 | type pos = Parser.pos 23 | type token = Parser.token 24 | val EQ: pos * pos -> token 25 | val DIV: pos * pos -> token 26 | val SUB: pos * pos -> token 27 | val MUL: pos * pos -> token 28 | val ADD: pos * pos -> token 29 | val VAL: pos * pos -> token 30 | val THEN: pos * pos -> token 31 | val TRUE: pos * pos -> token 32 | val STRING: (string) * pos * pos -> token 33 | val SEMICOLON: pos * pos -> token 34 | val RPAREN: pos * pos -> token 35 | val LPAREN: pos * pos -> token 36 | val INT: (int) * pos * pos -> token 37 | val IF: pos * pos -> token 38 | val ID: (string) * pos * pos -> token 39 | val HASH2: pos * pos -> token 40 | val HASH1: pos * pos -> token 41 | val FUN: pos * pos -> token 42 | val FN: pos * pos -> token 43 | val FALSE: pos * pos -> token 44 | val EQUAL: pos * pos -> token 45 | val ELSE: pos * pos -> token 46 | val DARROW: pos * pos -> token 47 | val COMMA: pos * pos -> token 48 | val EOF: pos * pos -> token 49 | end 50 | end 51 | 52 | 53 | -------------------------------------------------------------------------------- /examples/chap6-5/parser/CoreML.lex: -------------------------------------------------------------------------------- 1 | structure Tokens = CoreMLLrVals.Tokens 2 | type token = Tokens.token 3 | type pos = Tokens.pos 4 | type lexresult = Tokens.token 5 | exception Error 6 | 7 | val eof = fn _ => Tokens.EOF (0,0) 8 | fun atoi s = valOf (Int.fromString s) 9 | 10 | %% 11 | %structure CoreMLLex 12 | 13 | alpha = [A-Za-z]; 14 | digit = [0-9]; 15 | num = {digit}+; 16 | idchars = {alpha}|{digit}; 17 | id = {alpha}{idchars}*; 18 | ws = "\ " | "\t" | "\r\n" | "\n" | "\r"; 19 | 20 | %% 21 | 22 | {ws} => (lex()); 23 | "add" => (Tokens.ADD (yypos,yypos+3)); 24 | "mul" => (Tokens.MUL (yypos,yypos+3)); 25 | "sub" => (Tokens.SUB (yypos,yypos+3)); 26 | "div" => (Tokens.DIV (yypos,yypos+3)); 27 | "eq" => (Tokens.EQ (yypos,yypos+2)); 28 | "else" => (Tokens.ELSE (yypos,yypos+4)); 29 | "true" => (Tokens.TRUE (yypos,yypos+4)); 30 | "false" => (Tokens.FALSE (yypos,yypos+5)); 31 | "fn" => (Tokens.FN (yypos,yypos+2)); 32 | "if" => (Tokens.IF (yypos,yypos+2)); 33 | "then" => (Tokens.THEN (yypos,yypos+4)); 34 | "val" => (Tokens.VAL (yypos,yypos+3)); 35 | "fun" => (Tokens.FUN (yypos,yypos+3)); 36 | "(" => (Tokens.LPAREN (yypos,yypos+1)); 37 | ")" => (Tokens.RPAREN (yypos,yypos+1)); 38 | "," => (Tokens.COMMA (yypos,yypos+1)); 39 | ";" => (Tokens.SEMICOLON (yypos,yypos+1)); 40 | "=" => (Tokens.EQUAL (yypos,yypos+1)); 41 | "=>" => (Tokens.DARROW (yypos,yypos+2)); 42 | "#1" => (Tokens.HASH1 (yypos,yypos+2)); 43 | "#2" => (Tokens.HASH2 (yypos,yypos+2)); 44 | {id} => (Tokens.ID 45 | ( 46 | yytext, 47 | yypos, 48 | yypos + String.size yytext 49 | )); 50 | {num} => (Tokens.INT 51 | ( 52 | atoi yytext, 53 | yypos, 54 | yypos + String.size yytext 55 | )); 56 | ~{num} => (Tokens.INT 57 | ( 58 | atoi yytext, 59 | yypos, 60 | yypos + String.size yytext 61 | )); 62 | \"{idchars}*\" => (Tokens.STRING 63 | (String.substring(yytext,1,String.size yytext - 2), 64 | yypos - String.size yytext + 1, 65 | yypos + 1)); 66 | . => (Tokens.ID 67 | (yytext, 68 | yypos, 69 | yypos + 1)); 70 | -------------------------------------------------------------------------------- /examples/chap6-5/parser/CoreML.lex.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "ml-yacc-lib.smi" 3 | _require "./CoreML.grm.smi" 4 | structure CoreMLLex = 5 | struct 6 | val makeLexer : (int -> string) -> unit 7 | -> CoreMLLrVals.Tokens.token 8 | end 9 | -------------------------------------------------------------------------------- /examples/chap6-5/parser/Parser.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "./Syntax.smi" 3 | _require "./CoreML.lex.smi" 4 | _require "./CoreML.grm.smi" 5 | structure Parser = 6 | struct 7 | exception EOF 8 | exception ParseError = CoreMLLrVals.Parser.ParseError 9 | type stream (= CoreMLLrVals.Parser.stream) 10 | val doParse : stream -> Syntax.dec * stream 11 | val makeStream : TextIO.instream -> stream 12 | end 13 | -------------------------------------------------------------------------------- /examples/chap6-5/parser/Parser.sml: -------------------------------------------------------------------------------- 1 | structure Parser = 2 | struct 3 | exception EOF 4 | exception ParseError = CoreMLLrVals.Parser.ParseError 5 | structure P = CoreMLLrVals.Parser 6 | structure T = CoreMLLrVals.Tokens 7 | type stream = P.stream 8 | fun print_error (s,pos1,pos2) = 9 | print ("Syntax error(" 10 | ^ Int.toString pos1 11 | ^ "-" ^ Int.toString pos2 ^ ") :" ^ s ^ "\n") 12 | fun discardSemicolons stream = 13 | let val (token, rest) = P.getStream stream 14 | in if P.sameToken (token, T.SEMICOLON (0,0)) then 15 | discardSemicolons rest 16 | else if P.sameToken (token, T.EOF (0,0)) then raise EOF 17 | else stream 18 | end 19 | fun doParse stream = 20 | let val stream = discardSemicolons stream 21 | val (dec, stream) = 22 | P.parse {lookahead=0, stream=stream, 23 | error=print_error,arg=()} 24 | val _ = print ("Parse result:\n" 25 | ^ (Syntax.decToString dec) ^ "\n") 26 | in (dec, stream) end 27 | fun makeStream inStream = 28 | let val lexer = CoreMLLex.makeLexer 29 | (fn n => TextIO.inputN (inStream,1)) 30 | in P.makeStream {lexer=lexer} end 31 | end 32 | -------------------------------------------------------------------------------- /examples/chap6-5/parser/Syntax.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | structure Syntax = 3 | struct 4 | datatype prim = EQ | ADD | SUB | MUL | DIV 5 | datatype exp 6 | = EXPID of string | INT of int | STRING of string 7 | | TRUE | FALSE | EXPFN of string * exp 8 | | EXPAPP of exp * exp | EXPPAIR of exp * exp 9 | | EXPPROJ1 of exp | EXPPROJ2 of exp 10 | | EXPPRIM of prim * exp * exp 11 | | EXPIF of exp * exp * exp 12 | | EXPFIX of string * string * exp 13 | and dec 14 | = VAL of string * exp 15 | val expToString : exp -> string 16 | val decToString : dec -> string 17 | end 18 | -------------------------------------------------------------------------------- /examples/chap6-5/parser/Syntax.sml: -------------------------------------------------------------------------------- 1 | (** 2 | * expression syntax 3 | * @copyright (c) 2006, Tohoku University. 4 | * @author Atsushi Ohori 5 | *) 6 | structure Syntax = 7 | struct 8 | datatype prim = EQ | ADD | SUB | MUL | DIV 9 | datatype exp 10 | = EXPID of string | INT of int | STRING of string 11 | | TRUE | FALSE | EXPFN of string * exp 12 | | EXPAPP of exp * exp | EXPPAIR of exp * exp 13 | | EXPPROJ1 of exp | EXPPROJ2 of exp 14 | | EXPPRIM of prim * exp * exp 15 | | EXPIF of exp * exp * exp 16 | | EXPFIX of string * string * exp 17 | and dec 18 | = VAL of string * exp 19 | fun expToString exp = 20 | case exp of 21 | INT int => Int.toString int 22 | | STRING string => "\"" ^ string ^ "\"" 23 | | TRUE => "true" 24 | | FALSE => "false" 25 | | EXPID string => string 26 | | EXPPAIR (exp1, exp2) => 27 | "(" ^ expToString exp1 ^ "," ^ expToString exp2 ^ ")" 28 | | EXPAPP (exp1, exp2) => 29 | "(" ^ expToString exp1 ^ " " ^ expToString exp2 ^ ")" 30 | | EXPIF (exp1, exp2, exp3) => 31 | "if " 32 | ^ expToString exp1 33 | ^ " then " 34 | ^ expToString exp2 35 | ^ " else " 36 | ^ expToString exp3 37 | | EXPFN (string, exp) => 38 | "(fn " ^ string ^ " => " ^ expToString exp ^ ")" 39 | | EXPPROJ1 exp => "#1 " ^ expToString exp 40 | | EXPPROJ2 exp => "#2 " ^ expToString exp 41 | | EXPFIX (f, x, exp) => 42 | "(fix " 43 | ^ f 44 | ^ "(" 45 | ^ x 46 | ^ ") => " ^ expToString exp ^ ")" 47 | | EXPPRIM (p, exp1, exp2) => 48 | let 49 | val prim = case p of ADD => "add" | SUB => "sub" 50 | | MUL => "mul" | DIV => "div" 51 | | EQ => "eq" 52 | in 53 | "prim(" ^ prim ^ "," ^ expToString exp1 ^ "," ^ expToString exp2 ^ ")" 54 | end 55 | and decToString dec = 56 | case dec of 57 | VAL (x, exp) => 58 | "val " ^ x ^ " = " ^ expToString exp 59 | (* 60 | fun printExp exp = print (expToString exp) 61 | fun printDec dec = print (decToString dec) 62 | fun expToString exp = Dynamic.format exp 63 | fun decToString dec = Dynamic.format dec 64 | *) 65 | end 66 | -------------------------------------------------------------------------------- /examples/chap6-5/typeinf/Type.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | structure Type = 3 | struct 4 | datatype ty 5 | = TYVARty of string | INTty | STRINGty | BOOLty 6 | | FUNty of ty * ty | PAIRty of ty * ty 7 | | POLYty of string list * ty 8 | val newTy : unit -> ty 9 | val tyToString : ty -> string 10 | end 11 | -------------------------------------------------------------------------------- /examples/chap6-5/typeinf/Type.sml: -------------------------------------------------------------------------------- 1 | structure Type = 2 | struct 3 | local 4 | val nextTyId = ref 0 5 | fun newTyId () = (!nextTyId before nextTyId := !nextTyId + 1) 6 | in 7 | fun initSeed () = nextTyId := 0 8 | fun newTyIdName () = 9 | let 10 | fun tyIdName tid = 11 | let 12 | fun numeral n = 13 | if n < 26 14 | then [ord #"a" + n] 15 | else 16 | let val (msb, rest) = (n mod 26, (n div 26) - 1) 17 | in (ord #"a" + msb) :: (numeral rest) 18 | end 19 | in 20 | (implode(map chr (rev (numeral tid)))) 21 | end 22 | in 23 | tyIdName (newTyId()) 24 | end 25 | end 26 | datatype ty = 27 | INTty 28 | | STRINGty 29 | | BOOLty 30 | | TYVARty of string 31 | | FUNty of ty * ty 32 | | PAIRty of ty * ty 33 | | POLYty of string list * ty 34 | fun newTy () = TYVARty (newTyIdName()) 35 | fun tyToString ty = 36 | case ty of 37 | INTty => "int" 38 | | STRINGty => "string" 39 | | BOOLty => "bool" 40 | | TYVARty string => "'" ^ string 41 | | FUNty (ty1, ty2) => 42 | "(" ^ tyToString ty1 ^ " -> " ^ tyToString ty2 ^ ")" 43 | | PAIRty (ty1, ty2) => 44 | "(" ^ tyToString ty1 ^ " * " ^ tyToString ty2 ^ ")" 45 | | POLYty (tids, ty) => 46 | "[" 47 | ^ 48 | String.concatWith "," tids 49 | ^ 50 | "." 51 | ^ 52 | tyToString ty 53 | ^ 54 | "]" 55 | (* 56 | fun tyToString ty = Dynamic.format ty 57 | *) 58 | end 59 | -------------------------------------------------------------------------------- /examples/chap6-5/typeinf/TypeUtils.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SSet.smi" 3 | _require "compiler/libs/env/main/SEnv.smi" 4 | _require "./Type.smi" 5 | structure TypeUtils = 6 | struct 7 | type subst = Type.ty SEnv.map 8 | type tyEnv = Type.ty SEnv.map 9 | val substTy : subst -> Type.ty -> Type.ty 10 | val emptySubst : subst 11 | val substTyEnv : subst -> tyEnv -> tyEnv 12 | val composeSubst : subst -> subst -> subst 13 | val freshInst : Type.ty -> Type.ty 14 | val emptyTyEnv : tyEnv 15 | val singletonTyEnv : string * Type.ty -> tyEnv 16 | val findTyEnv : tyEnv * string -> Type.ty option 17 | val matches : tyEnv * tyEnv -> (Type.ty * Type.ty) list 18 | val unionTyEnv : tyEnv * tyEnv -> tyEnv 19 | val removeTyEnv : tyEnv * string -> tyEnv 20 | val tyEnvToString : tyEnv -> string 21 | end 22 | -------------------------------------------------------------------------------- /examples/chap6-5/typeinf/TypeUtils.sml: -------------------------------------------------------------------------------- 1 | structure TypeUtils = 2 | struct 3 | local 4 | open Type 5 | in 6 | type subst = ty SEnv.map 7 | val emptySubst = SEnv.empty 8 | fun substTy subst ty = 9 | case ty of 10 | INTty => ty 11 | | STRINGty => ty 12 | | BOOLty => ty 13 | | TYVARty string => 14 | (case SEnv.find (subst, string) of 15 | NONE => ty 16 | | SOME ty => ty) 17 | | FUNty (ty1, ty2) => 18 | FUNty (substTy subst ty1, substTy subst ty2) 19 | | PAIRty (ty1, ty2) => 20 | PAIRty (substTy subst ty1, substTy subst ty2) 21 | | POLYty (tids, ty) => 22 | POLYty (tids, substTy subst ty) 23 | fun composeSubst subst1 subst2 = 24 | SEnv.unionWith 25 | (fn (ty1, ty2) => ty1) 26 | (SEnv.map (substTy subst1) subst2, 27 | subst1) 28 | type tyEnv = ty SEnv.map 29 | val findTyEnv = SEnv.find 30 | fun substTyEnv subst tyEnv = 31 | SEnv.map (substTy subst) tyEnv 32 | val emptyTyEnv = SEnv.empty 33 | fun singletonTyEnv (tyID, ty) = SEnv.singleton (tyID, ty) 34 | fun matches (tyEnv1, tyEnv2) = 35 | SEnv.listItems 36 | (SEnv.intersectWith (fn x => x) (tyEnv1, tyEnv2)) 37 | fun unionTyEnv (tyEnv1, tyEnv2) = 38 | SEnv.unionWith #1 (tyEnv1, tyEnv2) 39 | fun removeTyEnv (tyEnv, string) = #1 (SEnv.remove(tyEnv, string)) 40 | fun freshInst ty = 41 | case ty of 42 | POLYty (tids, ty) => 43 | let val S = 44 | foldr (fn (tid, S) => 45 | let val newty = newTy () 46 | in SEnv.insert(S, tid, newty) end) 47 | emptySubst 48 | tids 49 | in substTy S ty end 50 | | _ => ty 51 | 52 | fun tyEnvToString tyEnv = 53 | let 54 | val stringTyList = SEnv.listItemsi tyEnv 55 | in 56 | "{" ^ (String.concatWith " , " 57 | (map (fn (id,ty) => id ^ ":" ^ tyToString ty) stringTyList)) 58 | ^ "}" 59 | end 60 | end 61 | end 62 | -------------------------------------------------------------------------------- /examples/chap6-5/typeinf/Typeinf.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SEnv.smi" 3 | _require "compiler/libs/env/main/SSet.smi" 4 | _require "../parser/Syntax.smi" 5 | _require "./Type.smi" 6 | _require "./TypeUtils.smi" 7 | _require "./UnifyTy.smi" 8 | 9 | structure Typeinf = 10 | struct 11 | exception TypeError 12 | val typeinf : TypeUtils.tyEnv -> Syntax.dec -> TypeUtils.tyEnv 13 | end 14 | -------------------------------------------------------------------------------- /examples/chap6-5/typeinf/Typeinf.sml: -------------------------------------------------------------------------------- 1 | (** 2 | * Type inference module 3 | * @author Atsushi Ohori 4 | *) 5 | structure Typeinf = struct 6 | open Syntax Type TypeUtils UnifyTy 7 | exception TypeError 8 | infixr ++ 9 | fun s1 ++ s2 = composeSubst s1 s2 10 | fun W gamma exp = 11 | case exp of 12 | INT (int) => (emptySubst, INTty) 13 | | EXPID (string) => 14 | (case SEnv.find(gamma, string) of 15 | SOME ty => (emptySubst, freshInst ty) 16 | | NONE => raise TypeError) 17 | | EXPFN (string, exp) => 18 | let val ty1 = newTy() 19 | val newGamma = SEnv.insert(gamma, string, ty1) 20 | val (S, ty2) = W newGamma exp 21 | in 22 | (S, FUNty(substTy S ty1, ty2)) 23 | end 24 | | EXPAPP (exp1, exp2) => 25 | let 26 | val (S1, ty1) = W gamma exp1 27 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 28 | val ty3 = newTy() 29 | val S3 = unify [(FUNty(ty2, ty3), substTy S2 ty1)] 30 | val S4 = composeSubst S3 (composeSubst S2 S1) 31 | in 32 | (S4, substTy S4 ty3) 33 | end 34 | | STRING (string) => (emptySubst, STRINGty) 35 | | TRUE => (emptySubst, BOOLty) 36 | | FALSE => (emptySubst, BOOLty) 37 | | EXPPAIR (exp1, exp2) => 38 | let 39 | val (S1, ty1) = W gamma exp1 40 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 41 | in 42 | ( 43 | S2 ++ S1, 44 | PAIRty(substTy S2 ty1,ty2) 45 | ) 46 | end 47 | | EXPPROJ1 exp => 48 | let 49 | val (S1, ty) = W gamma exp 50 | val ty1 = newTy() 51 | val ty2 = newTy() 52 | val S2 = unify [(ty, PAIRty (ty1, ty2))] 53 | in 54 | ( 55 | S2 ++ S1, 56 | substTy S2 ty1 57 | ) 58 | end 59 | | EXPPROJ2 exp => 60 | let 61 | val (S1, ty) = W gamma exp 62 | val ty1 = newTy() 63 | val ty2 = newTy() 64 | val S2 = unify [(ty, PAIRty (ty1, ty2))] 65 | in 66 | ( 67 | S2 ++ S1, 68 | substTy S2 ty2 69 | ) 70 | end 71 | | EXPIF (exp1, exp2, exp3) => 72 | let 73 | val (S1, ty1) = W gamma exp1 74 | val S2 = unify [(ty1, BOOLty)] 75 | val (S3, ty2) = W (substTyEnv (S2 ++ S1) gamma) exp2 76 | val (S4, ty3) = W (substTyEnv (S3 ++ S2 ++ S1) gamma) exp3 77 | val S5 = unify [(ty2, ty3)] 78 | val S = S5 ++ S4 ++ S3 ++ S2 ++ S1 79 | val newGamma = substTyEnv S gamma 80 | in 81 | (S, substTy S5 ty2) 82 | end 83 | | EXPFIX (fid, xid, exp) => 84 | let 85 | val argTy = newTy() 86 | val bodyTy = newTy() 87 | val funTy = FUNty(argTy, bodyTy) 88 | val newGamma = 89 | SEnv.insert(SEnv.insert(gamma, fid, funTy), 90 | xid, argTy) 91 | val (S1, ty) = W newGamma exp 92 | val S2 = unify [(ty, bodyTy)] 93 | val S = S2 ++ S1 94 | in 95 | (S, substTy S funTy) 96 | end 97 | | EXPPRIM (p, exp1, exp2) => 98 | let 99 | val (S1, ty1) = W gamma exp1 100 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 101 | val S3 = unify [(substTy S2 ty1, INTty), (ty2, INTty)] 102 | val ty3 = 103 | case p of EQ => BOOLty | _ => INTty 104 | in 105 | (S3 ++ S2 ++ S1, ty3) 106 | end 107 | 108 | fun typeinf gamma (VAL (id, exp)) = 109 | let 110 | val (subst, ty) = W gamma exp 111 | val tids = SSet.listItems (FTV ty) 112 | val newTy = if null tids then ty else POLYty (tids, ty) 113 | val _ = print ("Inferred typing:\n" 114 | ^ "val " ^ id ^ " : " 115 | ^ Type.tyToString newTy ^ "\n") 116 | in 117 | SEnv.insert(gamma, id, newTy) 118 | end 119 | handle Unify => raise TypeError 120 | end 121 | -------------------------------------------------------------------------------- /examples/chap6-5/typeinf/UnifyTy.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SSet.smi" 3 | _require "compiler/libs/env/main/SEnv.smi" 4 | _require "./Type.smi" 5 | _require "./TypeUtils.smi" 6 | structure UnifyTy = struct 7 | exception UnifyTy 8 | val FTV : Type.ty -> SSet.set 9 | val unify : (Type.ty * Type.ty) list -> TypeUtils.subst 10 | end 11 | -------------------------------------------------------------------------------- /examples/chap6-5/typeinf/UnifyTy.sml: -------------------------------------------------------------------------------- 1 | structure UnifyTy = struct 2 | open Type TypeUtils 3 | exception UnifyTy 4 | fun FTV ty = 5 | let fun scan ty set = 6 | case ty of 7 | TYVARty string => SSet.add (set,string) 8 | | FUNty (domTy, ranTy) => scan ranTy (scan domTy set) 9 | | PAIRty (fstTy, sndTy) => scan sndTy (scan fstTy set) 10 | | _ => set 11 | in scan ty SSet.empty end 12 | fun occurs (TYVARty string, ty) = SSet.member(FTV ty, string) 13 | | occurs _ = false 14 | fun rewrite (nil, S) = S 15 | | rewrite((ty1,ty2)::E, S) = 16 | if ty1 = ty2 then rewrite(E, S) else 17 | case (ty1,ty2) of 18 | (TYVARty tv, _) => 19 | if occurs (ty1, ty2) then raise UnifyTy else 20 | let val S1 = SEnv.singleton(tv, ty2) 21 | in rewrite (map (fn (ty1,ty2) => 22 | (substTy S1 ty1, substTy S1 ty2)) 23 | E, 24 | composeSubst S1 S) 25 | end 26 | | (_, TYVARty tv) => rewrite ((ty2, ty1)::E, S) 27 | | (FUNty(ty11, ty12), FUNty(ty21, ty22)) => 28 | rewrite ((ty11,ty21)::(ty12,ty22)::E, S) 29 | | (PAIRty(ty11, ty12), PAIRty(ty21, ty22)) => 30 | rewrite ((ty11, ty21)::(ty12, ty22)::E,S) 31 | | _ => raise UnifyTy 32 | fun unify E = rewrite (E, SEnv.empty) 33 | end 34 | 35 | -------------------------------------------------------------------------------- /examples/chap6-5/typeinf/W.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SEnv.smi" 3 | _require "compiler/libs/env/main/SSet.smi" 4 | _require "../parser/Syntax.smi" 5 | _require "./Type.smi" 6 | _require "./TypeUtils.smi" 7 | _require "./UnifyTy.smi" 8 | 9 | structure W = 10 | struct 11 | exception TypeError 12 | val typeinf : TypeUtils.tyEnv -> Syntax.dec -> TypeUtils.tyEnv 13 | end 14 | -------------------------------------------------------------------------------- /examples/chap6-5/typeinf/W.sml: -------------------------------------------------------------------------------- 1 | (** 2 | * Type inference module 3 | * @author Atsushi Ohori 4 | *) 5 | structure W = struct 6 | local 7 | open Absyn Types TypeUtils Unify 8 | in 9 | exception NotImplemented 10 | exception TypeError 11 | infixr ++ 12 | fun s1 ++ s2 = composeSubst s1 s2 13 | fun W gamma absyn = 14 | case absyn of 15 | INT (int) => (emptySubst, INTty) 16 | | STRING (string) => (emptySubst, STRINGty) 17 | | TRUE => (emptySubst, BOOLty) 18 | | FALSE => (emptySubst, BOOLty) 19 | | EXPID (string) => 20 | (case SEnv.find(gamma, string) of 21 | SOME ty => (emptySubst, freshInst ty) 22 | | NONE => raise TypeError 23 | ) 24 | | EXPPAIR (exp1, exp2) => 25 | let 26 | val (S1, ty1) = W gamma exp1 27 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 28 | in 29 | ( 30 | S2 ++ S1, 31 | PAIRty(substTy S2 ty1,ty2) 32 | ) 33 | end 34 | | EXPPROJ1 exp => 35 | let 36 | val (S1, ty) = W gamma exp 37 | val ty1 = newTy() 38 | val ty2 = newTy() 39 | val S2 = unify [(ty, PAIRty (ty1, ty2))] 40 | in 41 | ( 42 | S2 ++ S1, 43 | substTy S2 ty1 44 | ) 45 | end 46 | | EXPPROJ2 exp => 47 | let 48 | val (S1, ty) = W gamma exp 49 | val ty1 = newTy() 50 | val ty2 = newTy() 51 | val S2 = unify [(ty, PAIRty (ty1, ty2))] 52 | in 53 | ( 54 | S2 ++ S1, 55 | substTy S2 ty2 56 | ) 57 | end 58 | | EXPAPP (exp1, exp2) => 59 | let 60 | val (S1, ty1) = W gamma exp1 61 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 62 | val newty = newTy() 63 | val S3 = unify [(FUNty(ty2, newty), substTy S2 ty1)] 64 | in 65 | ( 66 | S3 ++ S2 ++ S1, 67 | substTy S3 newty 68 | ) 69 | end 70 | | EXPFN (string, exp) => 71 | let 72 | val newty = newTy() 73 | val newGamma = SEnv.insert(gamma, string, newty) 74 | val (S, ty) = W newGamma exp 75 | in 76 | (S, 77 | FUNty(substTy S newty, ty) 78 | ) 79 | end 80 | | EXPIF (exp1, exp2, exp3) => 81 | let 82 | val (S1, ty1) = W gamma exp1 83 | val S2 = unify [(ty1, BOOLty)] 84 | val (S3, ty2) = W (substTyEnv (S2 ++ S1) gamma) exp2 85 | val (S4, ty3) = W (substTyEnv (S3 ++ S2 ++ S1) gamma) exp3 86 | val S5 = unify [(ty2, ty3)] 87 | val S = S5 ++ S4 ++ S3 ++ S2 ++ S1 88 | val newGamma = substTyEnv S gamma 89 | in 90 | (S, substTy S5 ty2) 91 | end 92 | | EXPFIX (fid, xid, exp) => 93 | let 94 | val argTy = newTy() 95 | val bodyTy = newTy() 96 | val funTy = FUNty(argTy, bodyTy) 97 | val newGamma = 98 | SEnv.insert(SEnv.insert(gamma, fid, funTy), 99 | xid, argTy) 100 | val (S1, ty) = W newGamma exp 101 | val S2 = unify [(ty, bodyTy)] 102 | val S = S2 ++ S1 103 | in 104 | (S, substTy S funTy) 105 | end 106 | | EXPPRIM (prim, exp1, exp2) => 107 | case prim of 108 | "eq" => 109 | let 110 | val (S1, ty1) = W gamma exp1 111 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 112 | val S3 = unify [(ty1, ty2)] 113 | in 114 | (S3 ++ S2 ++ S1, BOOLty) 115 | end 116 | | _ => 117 | let 118 | val (S1, ty1) = W gamma exp1 119 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 120 | val S3 = unify [(substTy S2 ty1, INTty), (ty2, INTty)] 121 | in 122 | (S3 ++ S2 ++ S1, INTty) 123 | end 124 | 125 | fun typeinf gamma (Absyn.VAL (id, exp)) = 126 | let 127 | val (subst, ty) = W gamma exp 128 | val tids = SSet.listItems (Unify.FTV ty) 129 | val newTy = if null tids then ty else Types.POLYty (tids, ty) 130 | val _ = 131 | print ( 132 | "Inferred typing:\n" 133 | ^ "val " 134 | ^ id 135 | ^ " : " 136 | ^ Types.tyToString newTy 137 | ^ "\n") 138 | val newGamma = SEnv.insert(gamma, id, newTy) 139 | in 140 | newGamma 141 | end 142 | | typeinf gamma _ = raise TypeError 143 | end 144 | end 145 | -------------------------------------------------------------------------------- /examples/chap7/eval/Eval.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SEnv.smi" 3 | _require "../parser/Syntax.smi" 4 | _require "./Value.smi" 5 | structure Eval = struct 6 | exception RuntimeError 7 | val eval : Value.env -> Syntax.dec -> Value.env 8 | end 9 | -------------------------------------------------------------------------------- /examples/chap7/eval/Eval.sml: -------------------------------------------------------------------------------- 1 | structure Eval = struct 2 | structure S = Syntax 3 | structure V = Value 4 | exception RuntimeError 5 | fun evalExp env exp = 6 | case exp of 7 | S.EXPID string => 8 | (case SEnv.find(env, string) of 9 | SOME v => v 10 | | _ => raise RuntimeError) 11 | | S.INT int => V.INT int 12 | | S.STRING string => V.STRING string 13 | | S.TRUE => V.BOOL true 14 | | S.FALSE => V.BOOL false 15 | | S.EXPFN (string, exp) => V.CLS(env, string, exp) 16 | | S.EXPAPP (exp1, exp2) => 17 | let val v1 = evalExp env exp1 18 | val v2 = evalExp env exp2 19 | in case v1 of 20 | V.CLS(env1, x, exp1) => 21 | evalExp (SEnv.insert(env1, x, v2)) exp1 22 | | V.REC(env1, f, x, exp1) => 23 | evalExp (SEnv.insert 24 | (SEnv.insert(env1, f,v1), x, v2)) 25 | exp1 26 | | _ => raise RuntimeError 27 | end 28 | | S.EXPPROJ1 exp => 29 | let 30 | val v = evalExp env exp 31 | in 32 | case v of 33 | V.PAIR (v1,v2) => v1 34 | | _ => raise RuntimeError 35 | end 36 | | S.EXPPROJ2 exp => 37 | let 38 | val v = evalExp env exp 39 | in 40 | case v of 41 | V.PAIR (v1,v2) => v2 42 | | _ => raise RuntimeError 43 | end 44 | | S.EXPPRIM (prim, exp1, exp2) => 45 | let 46 | val v1 = evalExp env exp1 47 | val v2 = evalExp env exp2 48 | val arg = 49 | case (v1,v2) of 50 | (V.INT i1, V.INT i2) => (i1, i2) 51 | | _ => raise RuntimeError 52 | in 53 | case prim of 54 | S.ADD => V.INT (op + arg) 55 | | S.SUB => V.INT (op - arg) 56 | | S.MUL => V.INT (op * arg) 57 | | S.DIV => V.INT (op div arg) 58 | | S.EQ => V.BOOL (op = arg) 59 | end 60 | | S.EXPPAIR (exp1, exp2) => 61 | let 62 | val v1 = evalExp env exp1 63 | val v2 = evalExp env exp2 64 | in 65 | V.PAIR(v1,v2) 66 | end 67 | | S.EXPIF (exp1, exp2, exp3) => 68 | let 69 | val v1 = evalExp env exp1 70 | in 71 | case v1 of 72 | V.BOOL true => evalExp env exp2 73 | | V.BOOL false => evalExp env exp3 74 | | _ => raise RuntimeError 75 | end 76 | | S.EXPFIX (string1, string2, exp) => 77 | V.REC(env, string1, string2, exp) 78 | fun eval env (S.VAL (id, exp)) = 79 | let val v = evalExp env exp 80 | in print ("Evaluated to:\n" 81 | ^ "val " ^ id ^ " = " 82 | ^ Value.valueToString v ^ "\n"); 83 | SEnv.insert(env, id, v) 84 | end 85 | end 86 | 87 | -------------------------------------------------------------------------------- /examples/chap7/eval/Value.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SEnv.smi" 3 | _require "../parser/Syntax.smi" 4 | structure Value = struct 5 | datatype value 6 | = INT of int 7 | | BOOL of bool 8 | | STRING of string 9 | | PAIR of value * value 10 | | CLS of env * string * Syntax.exp 11 | | REC of env * string * string * Syntax.exp 12 | withtype env = value SEnv.map 13 | val emptyEnv : env 14 | val valueToString : value -> string 15 | end 16 | -------------------------------------------------------------------------------- /examples/chap7/eval/Value.sml: -------------------------------------------------------------------------------- 1 | structure Value = struct 2 | local 3 | structure A = Syntax 4 | in 5 | datatype value 6 | = INT of int 7 | | BOOL of bool 8 | | STRING of string 9 | | PAIR of value * value 10 | | CLS of env * string * A.exp 11 | | REC of env * string * string * A.exp 12 | withtype env = value SEnv.map 13 | val emptyEnv = SEnv.empty 14 | fun valueToString value = 15 | case value of 16 | INT int => Int.toString int 17 | | BOOL bool => Bool.toString bool 18 | | STRING string => "\"" ^ string ^ "\"" 19 | | PAIR (v1, v2) => "(" ^ valueToString v1 ^ "," ^ valueToString v2 ^ ")" 20 | | CLS (env, x, exp) => "fn" 21 | | REC (env, f, x, exp) => "fix" 22 | (* fun valueToString value = Dynamic.format value *) 23 | end 24 | end 25 | -------------------------------------------------------------------------------- /examples/chap7/main/Main.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "./Top.smi" 3 | -------------------------------------------------------------------------------- /examples/chap7/main/Main.sml: -------------------------------------------------------------------------------- 1 | val _ = case CommandLine.arguments() of 2 | h::_ => Top.top h 3 | | nil => Top.top ""; 4 | -------------------------------------------------------------------------------- /examples/chap7/main/Makefile: -------------------------------------------------------------------------------- 1 | SMLSHARP = smlsharp 2 | SMLFLAGS = -O2 3 | LIBS = 4 | all: Main 5 | Main: ../parser/Syntax.smi ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi \ 6 | ../parser/CoreML.lex.smi ../parser/Parser.smi ../typeinf/Type.smi \ 7 | ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi ../typeinf/Typeinf.smi \ 8 | ../eval/Value.smi ../eval/Eval.smi Top.smi Main.smi ../parser/Syntax.o \ 9 | ../parser/CoreML.grm.o ../parser/CoreML.lex.o ../parser/Parser.o \ 10 | ../typeinf/Type.o ../typeinf/TypeUtils.o ../typeinf/UnifyTy.o \ 11 | ../typeinf/Typeinf.o ../eval/Value.o ../eval/Eval.o Top.o Main.o 12 | $(SMLSHARP) $(LDFLAGS) -o Main Main.smi $(LIBS) 13 | ../parser/Syntax.o: ../parser/Syntax.sml ../parser/Syntax.smi 14 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/Syntax.o -c ../parser/Syntax.sml 15 | ../parser/CoreML.grm.sig: ../parser/CoreML.grm 16 | smlyacc ../parser/CoreML.grm 17 | ../parser/CoreML.grm.sml: ../parser/CoreML.grm 18 | smlyacc ../parser/CoreML.grm 19 | ../parser/CoreML.grm.o: ../parser/CoreML.grm.sml ../parser/Syntax.smi \ 20 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi 21 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/CoreML.grm.o -c \ 22 | ../parser/CoreML.grm.sml 23 | ../parser/CoreML.lex.sml: ../parser/CoreML.lex 24 | smllex ../parser/CoreML.lex 25 | ../parser/CoreML.lex.o: ../parser/CoreML.lex.sml ../parser/Syntax.smi \ 26 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi 27 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/CoreML.lex.o -c \ 28 | ../parser/CoreML.lex.sml 29 | ../parser/Parser.o: ../parser/Parser.sml ../parser/Syntax.smi \ 30 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi \ 31 | ../parser/Parser.smi 32 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/Parser.o -c ../parser/Parser.sml 33 | ../typeinf/Type.o: ../typeinf/Type.sml ../typeinf/Type.smi 34 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/Type.o -c ../typeinf/Type.sml 35 | ../typeinf/TypeUtils.o: ../typeinf/TypeUtils.sml ../typeinf/Type.smi \ 36 | ../typeinf/TypeUtils.smi 37 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/TypeUtils.o -c \ 38 | ../typeinf/TypeUtils.sml 39 | ../typeinf/UnifyTy.o: ../typeinf/UnifyTy.sml ../typeinf/Type.smi \ 40 | ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi 41 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/UnifyTy.o -c \ 42 | ../typeinf/UnifyTy.sml 43 | ../typeinf/Typeinf.o: ../typeinf/Typeinf.sml ../parser/Syntax.smi \ 44 | ../typeinf/Type.smi ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi \ 45 | ../typeinf/Typeinf.smi 46 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/Typeinf.o -c \ 47 | ../typeinf/Typeinf.sml 48 | ../eval/Value.o: ../eval/Value.sml ../parser/Syntax.smi ../eval/Value.smi 49 | $(SMLSHARP) $(SMLFLAGS) -o ../eval/Value.o -c ../eval/Value.sml 50 | ../eval/Eval.o: ../eval/Eval.sml ../parser/Syntax.smi ../eval/Value.smi \ 51 | ../eval/Eval.smi 52 | $(SMLSHARP) $(SMLFLAGS) -o ../eval/Eval.o -c ../eval/Eval.sml 53 | Top.o: Top.sml ../parser/Syntax.smi ../parser/CoreML.grm.sig \ 54 | ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi ../parser/Parser.smi \ 55 | ../typeinf/Type.smi ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi \ 56 | ../typeinf/Typeinf.smi ../eval/Value.smi ../eval/Eval.smi Top.smi 57 | $(SMLSHARP) $(SMLFLAGS) -o Top.o -c Top.sml 58 | Main.o: Main.sml ../parser/Syntax.smi ../parser/CoreML.grm.sig \ 59 | ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi ../parser/Parser.smi \ 60 | ../typeinf/Type.smi ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi \ 61 | ../typeinf/Typeinf.smi ../eval/Value.smi ../eval/Eval.smi Top.smi Main.smi 62 | $(SMLSHARP) $(SMLFLAGS) -o Main.o -c Main.sml 63 | clean: 64 | rm -f ./*.o ../parser/*.o ../typeinf/*.o ../eval/*.o Main 65 | rm -f ../parser/CoreML.grm.sml ../parser/CoreML.grm.sig ../parser/CoreML.lex.sml 66 | .SUFFIXES: .grm .lex 67 | -------------------------------------------------------------------------------- /examples/chap7/main/Top.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SEnv.smi" 3 | _require "compiler/libs/env/main/SSet.smi" 4 | _require "../parser/Parser.smi" 5 | _require "../parser/Syntax.smi" 6 | _require "../typeinf/Typeinf.smi" 7 | _require "../typeinf/TypeUtils.smi" 8 | _require "../eval/Eval.smi" 9 | _require "../eval/Value.smi" 10 | structure Top = 11 | struct 12 | val top : string -> unit 13 | end 14 | -------------------------------------------------------------------------------- /examples/chap7/main/Top.sml: -------------------------------------------------------------------------------- 1 | structure Top = 2 | struct 3 | fun readAndPrintLoop env gamma stream = 4 | let val (dec, stream) = Parser.doParse stream 5 | val newGamma = Typeinf.typeinf gamma dec 6 | val newEnv = Eval.eval env dec 7 | in readAndPrintLoop newEnv newGamma stream end 8 | fun top file = 9 | let 10 | val inStream = case file of 11 | "" => TextIO.stdIn 12 | | _ => TextIO.openIn file 13 | val stream = Parser.makeStream inStream 14 | in 15 | readAndPrintLoop Value.emptyEnv TypeUtils.emptyTyEnv stream 16 | handle Parser.EOF => () 17 | | Parser.ParseError => print "Syntax error\n" 18 | | Typeinf.TypeError => print "Type error\n" 19 | | Eval.RuntimeError => print "Runtime error\n"; 20 | case file of "" => () 21 | | _ => TextIO.closeIn inStream 22 | end 23 | end 24 | -------------------------------------------------------------------------------- /examples/chap7/parser/CoreML.grm: -------------------------------------------------------------------------------- 1 | %% 2 | %pos int 3 | %term ADD | COMMA | DARROW | DIV | ELSE | EOF | EQ | EQUAL 4 | | FALSE | FN | FUN | HASH1 | HASH2 | ID of string | IF 5 | | INT of int | LPAREN | MUL | RPAREN | SEMICOLON 6 | | STRING of string | SUB | THEN | TRUE | VAL 7 | %nonterm appexp of Syntax.exp | atexp of Syntax.exp 8 | | const of Syntax.exp | exp of Syntax.exp 9 | | dec of Syntax.dec | top of Syntax.dec 10 | | prim of Syntax.prim 11 | %start top 12 | %name CoreML 13 | %eop EOF SEMICOLON 14 | %noshift EOF 15 | %% 16 | top : dec (dec) 17 | dec : VAL ID EQUAL exp (Syntax.VAL(ID,exp)) 18 | | FUN ID ID EQUAL exp 19 | (Syntax.VAL(ID1, Syntax.EXPFIX(ID1, ID2, exp))) 20 | exp : appexp (appexp) 21 | | IF exp THEN exp ELSE exp (Syntax.EXPIF(exp1, exp2, exp3)) 22 | | FN ID DARROW exp (Syntax.EXPFN(ID, exp)) 23 | appexp : atexp (atexp) 24 | | appexp atexp (Syntax.EXPAPP(appexp, atexp)) 25 | atexp : const (const) 26 | | ID (Syntax.EXPID(ID)) 27 | | LPAREN exp COMMA exp RPAREN 28 | (Syntax.EXPPAIR(exp1, exp2)) 29 | | LPAREN exp RPAREN (exp) 30 | | HASH1 atexp (Syntax.EXPPROJ1 atexp) 31 | | HASH2 atexp (Syntax.EXPPROJ2 atexp) 32 | | prim LPAREN exp COMMA exp RPAREN 33 | (Syntax.EXPPRIM(prim, exp1, exp2)) 34 | const : INT (Syntax.INT(INT)) 35 | | STRING (Syntax.STRING(STRING)) 36 | | TRUE (Syntax.TRUE) | FALSE (Syntax.FALSE) 37 | prim : EQ (Syntax.EQ) | ADD (Syntax.ADD) | SUB (Syntax.SUB) 38 | | MUL (Syntax.MUL) | DIV (Syntax.DIV) 39 | 40 | -------------------------------------------------------------------------------- /examples/chap7/parser/CoreML.grm.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "ml-yacc-lib.smi" 3 | _require "./Syntax.smi" 4 | _require "./CoreML.grm.sig" 5 | structure CoreMLLrVals = 6 | struct 7 | structure Parser = struct 8 | type token (= boxed) 9 | type stream (= boxed) 10 | type result = Syntax.dec 11 | type pos = int 12 | type arg = unit 13 | exception ParseError 14 | val makeStream : {lexer:unit -> token} -> stream 15 | val getStream : stream -> token * stream 16 | val sameToken : token * token -> bool 17 | val parse : {lookahead:int, stream:stream,arg: arg, 18 | error: (string * pos * pos -> unit)} 19 | -> result * stream 20 | end 21 | structure Tokens = struct 22 | type pos = Parser.pos 23 | type token = Parser.token 24 | val EQ: pos * pos -> token 25 | val DIV: pos * pos -> token 26 | val SUB: pos * pos -> token 27 | val MUL: pos * pos -> token 28 | val ADD: pos * pos -> token 29 | val VAL: pos * pos -> token 30 | val THEN: pos * pos -> token 31 | val TRUE: pos * pos -> token 32 | val STRING: (string) * pos * pos -> token 33 | val SEMICOLON: pos * pos -> token 34 | val RPAREN: pos * pos -> token 35 | val LPAREN: pos * pos -> token 36 | val INT: (int) * pos * pos -> token 37 | val IF: pos * pos -> token 38 | val ID: (string) * pos * pos -> token 39 | val HASH2: pos * pos -> token 40 | val HASH1: pos * pos -> token 41 | val FUN: pos * pos -> token 42 | val FN: pos * pos -> token 43 | val FALSE: pos * pos -> token 44 | val EQUAL: pos * pos -> token 45 | val ELSE: pos * pos -> token 46 | val DARROW: pos * pos -> token 47 | val COMMA: pos * pos -> token 48 | val EOF: pos * pos -> token 49 | end 50 | end 51 | 52 | 53 | -------------------------------------------------------------------------------- /examples/chap7/parser/CoreML.lex: -------------------------------------------------------------------------------- 1 | structure Tokens = CoreMLLrVals.Tokens 2 | type token = Tokens.token 3 | type pos = Tokens.pos 4 | type lexresult = Tokens.token 5 | exception Error 6 | 7 | val eof = fn _ => Tokens.EOF (0,0) 8 | fun atoi s = valOf (Int.fromString s) 9 | 10 | %% 11 | %structure CoreMLLex 12 | 13 | alpha = [A-Za-z]; 14 | digit = [0-9]; 15 | num = {digit}+; 16 | idchars = {alpha}|{digit}; 17 | id = {alpha}{idchars}*; 18 | ws = "\ " | "\t" | "\r\n" | "\n" | "\r"; 19 | 20 | %% 21 | 22 | {ws} => (lex()); 23 | "add" => (Tokens.ADD (yypos,yypos+3)); 24 | "mul" => (Tokens.MUL (yypos,yypos+3)); 25 | "sub" => (Tokens.SUB (yypos,yypos+3)); 26 | "div" => (Tokens.DIV (yypos,yypos+3)); 27 | "eq" => (Tokens.EQ (yypos,yypos+2)); 28 | "else" => (Tokens.ELSE (yypos,yypos+4)); 29 | "true" => (Tokens.TRUE (yypos,yypos+4)); 30 | "false" => (Tokens.FALSE (yypos,yypos+5)); 31 | "fn" => (Tokens.FN (yypos,yypos+2)); 32 | "if" => (Tokens.IF (yypos,yypos+2)); 33 | "then" => (Tokens.THEN (yypos,yypos+4)); 34 | "val" => (Tokens.VAL (yypos,yypos+3)); 35 | "fun" => (Tokens.FUN (yypos,yypos+3)); 36 | "(" => (Tokens.LPAREN (yypos,yypos+1)); 37 | ")" => (Tokens.RPAREN (yypos,yypos+1)); 38 | "," => (Tokens.COMMA (yypos,yypos+1)); 39 | ";" => (Tokens.SEMICOLON (yypos,yypos+1)); 40 | "=" => (Tokens.EQUAL (yypos,yypos+1)); 41 | "=>" => (Tokens.DARROW (yypos,yypos+2)); 42 | "#1" => (Tokens.HASH1 (yypos,yypos+2)); 43 | "#2" => (Tokens.HASH2 (yypos,yypos+2)); 44 | {id} => (Tokens.ID 45 | ( 46 | yytext, 47 | yypos, 48 | yypos + String.size yytext 49 | )); 50 | {num} => (Tokens.INT 51 | ( 52 | atoi yytext, 53 | yypos, 54 | yypos + String.size yytext 55 | )); 56 | ~{num} => (Tokens.INT 57 | ( 58 | atoi yytext, 59 | yypos, 60 | yypos + String.size yytext 61 | )); 62 | \"{idchars}*\" => (Tokens.STRING 63 | (String.substring(yytext,1,String.size yytext - 2), 64 | yypos - String.size yytext + 1, 65 | yypos + 1)); 66 | . => (Tokens.ID 67 | (yytext, 68 | yypos, 69 | yypos + 1)); 70 | -------------------------------------------------------------------------------- /examples/chap7/parser/CoreML.lex.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "ml-yacc-lib.smi" 3 | _require "./CoreML.grm.smi" 4 | structure CoreMLLex = 5 | struct 6 | val makeLexer : (int -> string) -> unit 7 | -> CoreMLLrVals.Tokens.token 8 | end 9 | -------------------------------------------------------------------------------- /examples/chap7/parser/Parser.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "./Syntax.smi" 3 | _require "./CoreML.lex.smi" 4 | _require "./CoreML.grm.smi" 5 | structure Parser = 6 | struct 7 | exception EOF 8 | exception ParseError = CoreMLLrVals.Parser.ParseError 9 | type stream (= CoreMLLrVals.Parser.stream) 10 | val doParse : stream -> Syntax.dec * stream 11 | val makeStream : TextIO.instream -> stream 12 | end 13 | -------------------------------------------------------------------------------- /examples/chap7/parser/Parser.sml: -------------------------------------------------------------------------------- 1 | structure Parser = 2 | struct 3 | exception EOF 4 | exception ParseError = CoreMLLrVals.Parser.ParseError 5 | structure P = CoreMLLrVals.Parser 6 | structure T = CoreMLLrVals.Tokens 7 | type stream = P.stream 8 | fun print_error (s,pos1,pos2) = 9 | print ("Syntax error(" 10 | ^ Int.toString pos1 11 | ^ "-" ^ Int.toString pos2 ^ ") :" ^ s ^ "\n") 12 | fun discardSemicolons stream = 13 | let val (token, rest) = P.getStream stream 14 | in if P.sameToken (token, T.SEMICOLON (0,0)) then 15 | discardSemicolons rest 16 | else if P.sameToken (token, T.EOF (0,0)) then raise EOF 17 | else stream 18 | end 19 | fun doParse stream = 20 | let val stream = discardSemicolons stream 21 | val (dec, stream) = 22 | P.parse {lookahead=0, stream=stream, 23 | error=print_error,arg=()} 24 | val _ = print ("Parse result:\n" 25 | ^ (Syntax.decToString dec) ^ "\n") 26 | in (dec, stream) end 27 | fun makeStream inStream = 28 | let val lexer = CoreMLLex.makeLexer 29 | (fn n => TextIO.inputN (inStream,1)) 30 | in P.makeStream {lexer=lexer} end 31 | end 32 | -------------------------------------------------------------------------------- /examples/chap7/parser/Syntax.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | structure Syntax = 3 | struct 4 | datatype prim = EQ | ADD | SUB | MUL | DIV 5 | datatype exp 6 | = EXPID of string | INT of int | STRING of string 7 | | TRUE | FALSE | EXPFN of string * exp 8 | | EXPAPP of exp * exp | EXPPAIR of exp * exp 9 | | EXPPROJ1 of exp | EXPPROJ2 of exp 10 | | EXPPRIM of prim * exp * exp 11 | | EXPIF of exp * exp * exp 12 | | EXPFIX of string * string * exp 13 | and dec 14 | = VAL of string * exp 15 | val expToString : exp -> string 16 | val decToString : dec -> string 17 | end 18 | -------------------------------------------------------------------------------- /examples/chap7/parser/Syntax.sml: -------------------------------------------------------------------------------- 1 | (** 2 | * expression syntax 3 | * @copyright (c) 2006, Tohoku University. 4 | * @author Atsushi Ohori 5 | *) 6 | structure Syntax = 7 | struct 8 | datatype prim = EQ | ADD | SUB | MUL | DIV 9 | datatype exp 10 | = EXPID of string | INT of int | STRING of string 11 | | TRUE | FALSE | EXPFN of string * exp 12 | | EXPAPP of exp * exp | EXPPAIR of exp * exp 13 | | EXPPROJ1 of exp | EXPPROJ2 of exp 14 | | EXPPRIM of prim * exp * exp 15 | | EXPIF of exp * exp * exp 16 | | EXPFIX of string * string * exp 17 | and dec 18 | = VAL of string * exp 19 | fun expToString exp = 20 | case exp of 21 | INT int => Int.toString int 22 | | STRING string => "\"" ^ string ^ "\"" 23 | | TRUE => "true" 24 | | FALSE => "false" 25 | | EXPID string => string 26 | | EXPPAIR (exp1, exp2) => 27 | "(" ^ expToString exp1 ^ "," ^ expToString exp2 ^ ")" 28 | | EXPAPP (exp1, exp2) => 29 | "(" ^ expToString exp1 ^ " " ^ expToString exp2 ^ ")" 30 | | EXPIF (exp1, exp2, exp3) => 31 | "if " 32 | ^ expToString exp1 33 | ^ " then " 34 | ^ expToString exp2 35 | ^ " else " 36 | ^ expToString exp3 37 | | EXPFN (string, exp) => 38 | "(fn " ^ string ^ " => " ^ expToString exp ^ ")" 39 | | EXPPROJ1 exp => "#1 " ^ expToString exp 40 | | EXPPROJ2 exp => "#2 " ^ expToString exp 41 | | EXPFIX (f, x, exp) => 42 | "(fix " 43 | ^ f 44 | ^ "(" 45 | ^ x 46 | ^ ") => " ^ expToString exp ^ ")" 47 | | EXPPRIM (p, exp1, exp2) => 48 | let 49 | val prim = case p of ADD => "add" | SUB => "sub" 50 | | MUL => "mul" | DIV => "div" 51 | | EQ => "eq" 52 | in 53 | "prim(" ^ prim ^ "," ^ expToString exp1 ^ "," ^ expToString exp2 ^ ")" 54 | end 55 | and decToString dec = 56 | case dec of 57 | VAL (x, exp) => 58 | "val " ^ x ^ " = " ^ expToString exp 59 | (* 60 | fun printExp exp = print (expToString exp) 61 | fun printDec dec = print (decToString dec) 62 | fun expToString exp = Dynamic.format exp 63 | fun decToString dec = Dynamic.format dec 64 | *) 65 | end 66 | -------------------------------------------------------------------------------- /examples/chap7/typeinf/Type.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | structure Type = 3 | struct 4 | datatype ty 5 | = TYVARty of string | INTty | STRINGty | BOOLty 6 | | FUNty of ty * ty | PAIRty of ty * ty 7 | | POLYty of string list * ty 8 | val newTy : unit -> ty 9 | val tyToString : ty -> string 10 | end 11 | -------------------------------------------------------------------------------- /examples/chap7/typeinf/Type.sml: -------------------------------------------------------------------------------- 1 | structure Type = 2 | struct 3 | local 4 | val nextTyId = ref 0 5 | fun newTyId () = (!nextTyId before nextTyId := !nextTyId + 1) 6 | in 7 | fun initSeed () = nextTyId := 0 8 | fun newTyIdName () = 9 | let 10 | fun tyIdName tid = 11 | let 12 | fun numeral n = 13 | if n < 26 14 | then [ord #"a" + n] 15 | else 16 | let val (msb, rest) = (n mod 26, (n div 26) - 1) 17 | in (ord #"a" + msb) :: (numeral rest) 18 | end 19 | in 20 | (implode(map chr (rev (numeral tid)))) 21 | end 22 | in 23 | tyIdName (newTyId()) 24 | end 25 | end 26 | datatype ty = 27 | INTty 28 | | STRINGty 29 | | BOOLty 30 | | TYVARty of string 31 | | FUNty of ty * ty 32 | | PAIRty of ty * ty 33 | | POLYty of string list * ty 34 | fun newTy () = TYVARty (newTyIdName()) 35 | fun tyToString ty = 36 | case ty of 37 | INTty => "int" 38 | | STRINGty => "string" 39 | | BOOLty => "bool" 40 | | TYVARty string => "'" ^ string 41 | | FUNty (ty1, ty2) => 42 | "(" ^ tyToString ty1 ^ " -> " ^ tyToString ty2 ^ ")" 43 | | PAIRty (ty1, ty2) => 44 | "(" ^ tyToString ty1 ^ " * " ^ tyToString ty2 ^ ")" 45 | | POLYty (tids, ty) => 46 | "[" 47 | ^ 48 | String.concatWith "," tids 49 | ^ 50 | "." 51 | ^ 52 | tyToString ty 53 | ^ 54 | "]" 55 | (* 56 | fun tyToString ty = Dynamic.format ty 57 | *) 58 | end 59 | -------------------------------------------------------------------------------- /examples/chap7/typeinf/TypeUtils.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SSet.smi" 3 | _require "compiler/libs/env/main/SEnv.smi" 4 | _require "./Type.smi" 5 | structure TypeUtils = 6 | struct 7 | type subst = Type.ty SEnv.map 8 | type tyEnv = Type.ty SEnv.map 9 | val substTy : subst -> Type.ty -> Type.ty 10 | val emptySubst : subst 11 | val substTyEnv : subst -> tyEnv -> tyEnv 12 | val composeSubst : subst -> subst -> subst 13 | val freshInst : Type.ty -> Type.ty 14 | val emptyTyEnv : tyEnv 15 | val singletonTyEnv : string * Type.ty -> tyEnv 16 | val findTyEnv : tyEnv * string -> Type.ty option 17 | val matches : tyEnv * tyEnv -> (Type.ty * Type.ty) list 18 | val unionTyEnv : tyEnv * tyEnv -> tyEnv 19 | val removeTyEnv : tyEnv * string -> tyEnv 20 | val tyEnvToString : tyEnv -> string 21 | end 22 | -------------------------------------------------------------------------------- /examples/chap7/typeinf/TypeUtils.sml: -------------------------------------------------------------------------------- 1 | structure TypeUtils = 2 | struct 3 | local 4 | open Type 5 | in 6 | type subst = ty SEnv.map 7 | val emptySubst = SEnv.empty 8 | fun substTy subst ty = 9 | case ty of 10 | INTty => ty 11 | | STRINGty => ty 12 | | BOOLty => ty 13 | | TYVARty string => 14 | (case SEnv.find (subst, string) of 15 | NONE => ty 16 | | SOME ty => ty) 17 | | FUNty (ty1, ty2) => 18 | FUNty (substTy subst ty1, substTy subst ty2) 19 | | PAIRty (ty1, ty2) => 20 | PAIRty (substTy subst ty1, substTy subst ty2) 21 | | POLYty (tids, ty) => 22 | POLYty (tids, substTy subst ty) 23 | fun composeSubst subst1 subst2 = 24 | SEnv.unionWith 25 | (fn (ty1, ty2) => ty1) 26 | (SEnv.map (substTy subst1) subst2, 27 | subst1) 28 | type tyEnv = ty SEnv.map 29 | val findTyEnv = SEnv.find 30 | fun substTyEnv subst tyEnv = 31 | SEnv.map (substTy subst) tyEnv 32 | val emptyTyEnv = SEnv.empty 33 | fun singletonTyEnv (tyID, ty) = SEnv.singleton (tyID, ty) 34 | fun matches (tyEnv1, tyEnv2) = 35 | SEnv.listItems 36 | (SEnv.intersectWith (fn x => x) (tyEnv1, tyEnv2)) 37 | fun unionTyEnv (tyEnv1, tyEnv2) = 38 | SEnv.unionWith #1 (tyEnv1, tyEnv2) 39 | fun removeTyEnv (tyEnv, string) = #1 (SEnv.remove(tyEnv, string)) 40 | fun freshInst ty = 41 | case ty of 42 | POLYty (tids, ty) => 43 | let val S = 44 | foldr (fn (tid, S) => 45 | let val newty = newTy () 46 | in SEnv.insert(S, tid, newty) end) 47 | emptySubst 48 | tids 49 | in substTy S ty end 50 | | _ => ty 51 | 52 | fun tyEnvToString tyEnv = 53 | let 54 | val stringTyList = SEnv.listItemsi tyEnv 55 | in 56 | "{" ^ (String.concatWith " , " 57 | (map (fn (id,ty) => id ^ ":" ^ tyToString ty) stringTyList)) 58 | ^ "}" 59 | end 60 | end 61 | end 62 | -------------------------------------------------------------------------------- /examples/chap7/typeinf/Typeinf.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SEnv.smi" 3 | _require "compiler/libs/env/main/SSet.smi" 4 | _require "../parser/Syntax.smi" 5 | _require "./Type.smi" 6 | _require "./TypeUtils.smi" 7 | _require "./UnifyTy.smi" 8 | 9 | structure Typeinf = 10 | struct 11 | exception TypeError 12 | val typeinf : TypeUtils.tyEnv -> Syntax.dec -> TypeUtils.tyEnv 13 | end 14 | -------------------------------------------------------------------------------- /examples/chap7/typeinf/Typeinf.sml: -------------------------------------------------------------------------------- 1 | (** 2 | * Type inference module 3 | * @author Atsushi Ohori 4 | *) 5 | structure Typeinf = struct 6 | open Syntax Type TypeUtils UnifyTy 7 | exception TypeError 8 | infixr ++ 9 | fun s1 ++ s2 = composeSubst s1 s2 10 | fun W gamma exp = 11 | case exp of 12 | INT (int) => (emptySubst, INTty) 13 | | EXPID (string) => 14 | (case SEnv.find(gamma, string) of 15 | SOME ty => (emptySubst, freshInst ty) 16 | | NONE => raise TypeError) 17 | | EXPFN (string, exp) => 18 | let val ty1 = newTy() 19 | val newGamma = SEnv.insert(gamma, string, ty1) 20 | val (S, ty2) = W newGamma exp 21 | in 22 | (S, FUNty(substTy S ty1, ty2)) 23 | end 24 | | EXPAPP (exp1, exp2) => 25 | let 26 | val (S1, ty1) = W gamma exp1 27 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 28 | val ty3 = newTy() 29 | val S3 = unify [(FUNty(ty2, ty3), substTy S2 ty1)] 30 | val S4 = composeSubst S3 (composeSubst S2 S1) 31 | in 32 | (S4, substTy S4 ty3) 33 | end 34 | | STRING (string) => (emptySubst, STRINGty) 35 | | TRUE => (emptySubst, BOOLty) 36 | | FALSE => (emptySubst, BOOLty) 37 | | EXPPAIR (exp1, exp2) => 38 | let 39 | val (S1, ty1) = W gamma exp1 40 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 41 | in 42 | ( 43 | S2 ++ S1, 44 | PAIRty(substTy S2 ty1,ty2) 45 | ) 46 | end 47 | | EXPPROJ1 exp => 48 | let 49 | val (S1, ty) = W gamma exp 50 | val ty1 = newTy() 51 | val ty2 = newTy() 52 | val S2 = unify [(ty, PAIRty (ty1, ty2))] 53 | in 54 | ( 55 | S2 ++ S1, 56 | substTy S2 ty1 57 | ) 58 | end 59 | | EXPPROJ2 exp => 60 | let 61 | val (S1, ty) = W gamma exp 62 | val ty1 = newTy() 63 | val ty2 = newTy() 64 | val S2 = unify [(ty, PAIRty (ty1, ty2))] 65 | in 66 | ( 67 | S2 ++ S1, 68 | substTy S2 ty2 69 | ) 70 | end 71 | | EXPIF (exp1, exp2, exp3) => 72 | let 73 | val (S1, ty1) = W gamma exp1 74 | val S2 = unify [(ty1, BOOLty)] 75 | val (S3, ty2) = W (substTyEnv (S2 ++ S1) gamma) exp2 76 | val (S4, ty3) = W (substTyEnv (S3 ++ S2 ++ S1) gamma) exp3 77 | val S5 = unify [(ty2, ty3)] 78 | val S = S5 ++ S4 ++ S3 ++ S2 ++ S1 79 | val newGamma = substTyEnv S gamma 80 | in 81 | (S, substTy S5 ty2) 82 | end 83 | | EXPFIX (fid, xid, exp) => 84 | let 85 | val argTy = newTy() 86 | val bodyTy = newTy() 87 | val funTy = FUNty(argTy, bodyTy) 88 | val newGamma = 89 | SEnv.insert(SEnv.insert(gamma, fid, funTy), 90 | xid, argTy) 91 | val (S1, ty) = W newGamma exp 92 | val S2 = unify [(ty, bodyTy)] 93 | val S = S2 ++ S1 94 | in 95 | (S, substTy S funTy) 96 | end 97 | | EXPPRIM (p, exp1, exp2) => 98 | let 99 | val (S1, ty1) = W gamma exp1 100 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 101 | val S3 = unify [(substTy S2 ty1, INTty), (ty2, INTty)] 102 | val ty3 = 103 | case p of EQ => BOOLty | _ => INTty 104 | in 105 | (S3 ++ S2 ++ S1, ty3) 106 | end 107 | 108 | fun typeinf gamma (VAL (id, exp)) = 109 | let 110 | val (subst, ty) = W gamma exp 111 | val tids = SSet.listItems (FTV ty) 112 | val newTy = if null tids then ty else POLYty (tids, ty) 113 | val _ = print ("Inferred typing:\n" 114 | ^ "val " ^ id ^ " : " 115 | ^ Type.tyToString newTy ^ "\n") 116 | in 117 | SEnv.insert(gamma, id, newTy) 118 | end 119 | handle Unify => raise TypeError 120 | end 121 | -------------------------------------------------------------------------------- /examples/chap7/typeinf/UnifyTy.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SSet.smi" 3 | _require "compiler/libs/env/main/SEnv.smi" 4 | _require "./Type.smi" 5 | _require "./TypeUtils.smi" 6 | structure UnifyTy = struct 7 | exception UnifyTy 8 | val FTV : Type.ty -> SSet.set 9 | val unify : (Type.ty * Type.ty) list -> TypeUtils.subst 10 | end 11 | -------------------------------------------------------------------------------- /examples/chap7/typeinf/UnifyTy.sml: -------------------------------------------------------------------------------- 1 | structure UnifyTy = struct 2 | open Type TypeUtils 3 | exception UnifyTy 4 | fun FTV ty = 5 | let fun scan ty set = 6 | case ty of 7 | TYVARty string => SSet.add (set,string) 8 | | FUNty (domTy, ranTy) => scan ranTy (scan domTy set) 9 | | PAIRty (fstTy, sndTy) => scan sndTy (scan fstTy set) 10 | | _ => set 11 | in scan ty SSet.empty end 12 | fun occurs (TYVARty string, ty) = SSet.member(FTV ty, string) 13 | | occurs _ = false 14 | fun rewrite (nil, S) = S 15 | | rewrite((ty1,ty2)::E, S) = 16 | if ty1 = ty2 then rewrite(E, S) else 17 | case (ty1,ty2) of 18 | (TYVARty tv, _) => 19 | if occurs (ty1, ty2) then raise UnifyTy else 20 | let val S1 = SEnv.singleton(tv, ty2) 21 | in rewrite (map (fn (ty1,ty2) => 22 | (substTy S1 ty1, substTy S1 ty2)) 23 | E, 24 | composeSubst S1 S) 25 | end 26 | | (_, TYVARty tv) => rewrite ((ty2, ty1)::E, S) 27 | | (FUNty(ty11, ty12), FUNty(ty21, ty22)) => 28 | rewrite ((ty11,ty21)::(ty12,ty22)::E, S) 29 | | (PAIRty(ty11, ty12), PAIRty(ty21, ty22)) => 30 | rewrite ((ty11, ty21)::(ty12, ty22)::E,S) 31 | | _ => raise UnifyTy 32 | fun unify E = rewrite (E, SEnv.empty) 33 | end 34 | 35 | -------------------------------------------------------------------------------- /examples/chap7/typeinf/W.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SEnv.smi" 3 | _require "compiler/libs/env/main/SSet.smi" 4 | _require "../parser/Syntax.smi" 5 | _require "./Type.smi" 6 | _require "./TypeUtils.smi" 7 | _require "./UnifyTy.smi" 8 | 9 | structure W = 10 | struct 11 | exception TypeError 12 | val typeinf : TypeUtils.tyEnv -> Syntax.dec -> TypeUtils.tyEnv 13 | end 14 | -------------------------------------------------------------------------------- /examples/chap7/typeinf/W.sml: -------------------------------------------------------------------------------- 1 | (** 2 | * Type inference module 3 | * @author Atsushi Ohori 4 | *) 5 | structure W = struct 6 | local 7 | open Absyn Types TypeUtils Unify 8 | in 9 | exception NotImplemented 10 | exception TypeError 11 | infixr ++ 12 | fun s1 ++ s2 = composeSubst s1 s2 13 | fun W gamma absyn = 14 | case absyn of 15 | INT (int) => (emptySubst, INTty) 16 | | STRING (string) => (emptySubst, STRINGty) 17 | | TRUE => (emptySubst, BOOLty) 18 | | FALSE => (emptySubst, BOOLty) 19 | | EXPID (string) => 20 | (case SEnv.find(gamma, string) of 21 | SOME ty => (emptySubst, freshInst ty) 22 | | NONE => raise TypeError 23 | ) 24 | | EXPPAIR (exp1, exp2) => 25 | let 26 | val (S1, ty1) = W gamma exp1 27 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 28 | in 29 | ( 30 | S2 ++ S1, 31 | PAIRty(substTy S2 ty1,ty2) 32 | ) 33 | end 34 | | EXPPROJ1 exp => 35 | let 36 | val (S1, ty) = W gamma exp 37 | val ty1 = newTy() 38 | val ty2 = newTy() 39 | val S2 = unify [(ty, PAIRty (ty1, ty2))] 40 | in 41 | ( 42 | S2 ++ S1, 43 | substTy S2 ty1 44 | ) 45 | end 46 | | EXPPROJ2 exp => 47 | let 48 | val (S1, ty) = W gamma exp 49 | val ty1 = newTy() 50 | val ty2 = newTy() 51 | val S2 = unify [(ty, PAIRty (ty1, ty2))] 52 | in 53 | ( 54 | S2 ++ S1, 55 | substTy S2 ty2 56 | ) 57 | end 58 | | EXPAPP (exp1, exp2) => 59 | let 60 | val (S1, ty1) = W gamma exp1 61 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 62 | val newty = newTy() 63 | val S3 = unify [(FUNty(ty2, newty), substTy S2 ty1)] 64 | in 65 | ( 66 | S3 ++ S2 ++ S1, 67 | substTy S3 newty 68 | ) 69 | end 70 | | EXPFN (string, exp) => 71 | let 72 | val newty = newTy() 73 | val newGamma = SEnv.insert(gamma, string, newty) 74 | val (S, ty) = W newGamma exp 75 | in 76 | (S, 77 | FUNty(substTy S newty, ty) 78 | ) 79 | end 80 | | EXPIF (exp1, exp2, exp3) => 81 | let 82 | val (S1, ty1) = W gamma exp1 83 | val S2 = unify [(ty1, BOOLty)] 84 | val (S3, ty2) = W (substTyEnv (S2 ++ S1) gamma) exp2 85 | val (S4, ty3) = W (substTyEnv (S3 ++ S2 ++ S1) gamma) exp3 86 | val S5 = unify [(ty2, ty3)] 87 | val S = S5 ++ S4 ++ S3 ++ S2 ++ S1 88 | val newGamma = substTyEnv S gamma 89 | in 90 | (S, substTy S5 ty2) 91 | end 92 | | EXPFIX (fid, xid, exp) => 93 | let 94 | val argTy = newTy() 95 | val bodyTy = newTy() 96 | val funTy = FUNty(argTy, bodyTy) 97 | val newGamma = 98 | SEnv.insert(SEnv.insert(gamma, fid, funTy), 99 | xid, argTy) 100 | val (S1, ty) = W newGamma exp 101 | val S2 = unify [(ty, bodyTy)] 102 | val S = S2 ++ S1 103 | in 104 | (S, substTy S funTy) 105 | end 106 | | EXPPRIM (prim, exp1, exp2) => 107 | case prim of 108 | "eq" => 109 | let 110 | val (S1, ty1) = W gamma exp1 111 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 112 | val S3 = unify [(ty1, ty2)] 113 | in 114 | (S3 ++ S2 ++ S1, BOOLty) 115 | end 116 | | _ => 117 | let 118 | val (S1, ty1) = W gamma exp1 119 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 120 | val S3 = unify [(substTy S2 ty1, INTty), (ty2, INTty)] 121 | in 122 | (S3 ++ S2 ++ S1, INTty) 123 | end 124 | 125 | fun typeinf gamma (Absyn.VAL (id, exp)) = 126 | let 127 | val (subst, ty) = W gamma exp 128 | val tids = SSet.listItems (Unify.FTV ty) 129 | val newTy = if null tids then ty else Types.POLYty (tids, ty) 130 | val _ = 131 | print ( 132 | "Inferred typing:\n" 133 | ^ "val " 134 | ^ id 135 | ^ " : " 136 | ^ Types.tyToString newTy 137 | ^ "\n") 138 | val newGamma = SEnv.insert(gamma, id, newTy) 139 | in 140 | newGamma 141 | end 142 | | typeinf gamma _ = raise TypeError 143 | end 144 | end 145 | -------------------------------------------------------------------------------- /examples/chap8/SECD/Comp.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "../parser/Syntax.smi" 3 | _require "./Instruction.smi" 4 | structure Comp = 5 | struct 6 | val compile : Syntax.dec -> string * Instruction.C 7 | end 8 | -------------------------------------------------------------------------------- /examples/chap8/SECD/Comp.sml: -------------------------------------------------------------------------------- 1 | structure Comp = struct 2 | structure S = Syntax 3 | structure I = Instruction 4 | fun comp e K = 5 | case e of 6 | S.INT (int) => I.PushI int :: K 7 | | S.STRING (string) => I.PushS string :: K 8 | | S.TRUE => I.PushB true :: K 9 | | S.FALSE => I.PushB false :: K 10 | | S.EXPID (string) => I.Acc string :: K 11 | | S.EXPFN (x, e) => I.MkCLS(x, comp e [I.Ret]) :: K 12 | | S.EXPAPP (e1, e2) => comp e1 (comp e2 (I.App :: K)) 13 | | S.EXPPAIR (e1, e2) => comp e1 (comp e2 (I.Pair :: K)) 14 | | S.EXPPROJ1 e => comp e (I.Proj1 :: K) 15 | | S.EXPPROJ2 e => comp e (I.Proj2 :: K) 16 | | S.EXPPRIM (prim, e1, e2) => 17 | let 18 | val p = 19 | case prim of S.ADD => I.ADD | S.SUB => I.SUB | S.MUL => I.MUL 20 | | S.DIV => I.DIV | S.EQ => I.EQ 21 | in 22 | comp e1 (comp e2 (I.Prim p::K)) 23 | end 24 | | S.EXPFIX (f, x, e) => I.MkREC(f, x, comp e [I.Ret]) :: K 25 | | S.EXPIF (e1, e2, e3) => 26 | comp e1 (I.If(comp e2 nil, comp e3 nil) :: K) 27 | fun compile (S.VAL (id, e)) = 28 | let val C = comp e nil in 29 | print ( "Compiled to:\n" ^ I.codeToString C ^ "\n"); 30 | (id, C) 31 | end 32 | end 33 | -------------------------------------------------------------------------------- /examples/chap8/SECD/Exec.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SEnv.smi" 3 | _require "./Value.smi" 4 | _require "./Instruction.smi" 5 | structure Exec = struct 6 | exception RuntimeError 7 | val run : Value.E -> string * Instruction.C -> Value.E 8 | end 9 | -------------------------------------------------------------------------------- /examples/chap8/SECD/Exec.sml: -------------------------------------------------------------------------------- 1 | structure Exec = struct 2 | open Instruction Value 3 | exception RuntimeError 4 | fun exec (v::S, _, nil, nil) = v 5 | | exec (S, E, Acc string :: C, D) = 6 | (case SEnv.find(E, string) of 7 | SOME v => exec (v::S, E, C, D) 8 | | _ => raise RuntimeError) 9 | | exec (S, E, PushI int :: C, D) = exec (INT int::S, E, C, D) 10 | | exec (S, E, PushS string :: C, D) = exec (STRING string::S, E, C, D) 11 | | exec (S, E, PushB bool :: C, D) = exec (BOOL bool::S, E, C, D) 12 | | exec (S, E, MkCLS(x,C0) :: C, D) = exec (CLS(E, x, C0)::S, E, C, D) 13 | | exec (S, E, MkREC(f, x, C0) :: C, D) = exec (REC(E, f, x, C0)::S, E, C, D) 14 | | exec (v::CLS(E0, x, C0)::S, E, App :: C, D) = 15 | exec (S, SEnv.insert(E0,x,v), C0, (C,E)::D) 16 | | exec (v1::(v2 as REC(E0, f, x, C0))::S, E, App :: C, D) = 17 | exec (S, SEnv.insert(SEnv.insert(E0,f,v2),x,v1), C0, (C,E)::D) 18 | | exec (v1::v2::S, E, Pair :: C, D) = exec (PAIR(v2,v1)::S, E, C, D) 19 | | exec (PAIR(v1,v2)::S, E, Proj1 :: C, D) = exec (v1::S, E, C, D) 20 | | exec (PAIR(v1,v2)::S, E, Proj2 :: C, D) = exec (v2::S, E, C, D) 21 | | exec (INT i1:: INT i2::S, E, Prim(p) :: C, D) = 22 | (case p of ADD => exec (INT(i2 + i1)::S, E, C, D) 23 | | SUB => exec (INT(i2 - i1)::S, E, C, D) 24 | | MUL => exec (INT(i2 * i1)::S, E, C, D) 25 | | DIV => exec (INT(i2 div i1)::S, E, C, D) 26 | | EQ => exec (BOOL(i2 = i1) ::S, E, C, D)) 27 | | exec (v::S, _, Ret :: C, (C0, E0)::D) = exec (v::S, E0, C0, D) 28 | | exec (BOOL true::S, E, If(C1,C2) :: C, D) = exec (S, E, C1 @ C, D) 29 | | exec (BOOL false::S, E, If(C1,C2) :: C, D) = exec (S, E, C2 @ C, D) 30 | | exec (_, _, C,_) = (print (codeToString C); raise RuntimeError) 31 | fun run env (id, code) = 32 | let val v = exec (nil, env, code, nil) 33 | val newEnv = SEnv.insert(env, id, v) 34 | in 35 | print ("Execution result:\n" 36 | ^ "val " ^ id ^ " = " ^ valueToString v 37 | ^ "\n"); 38 | newEnv 39 | end 40 | end 41 | -------------------------------------------------------------------------------- /examples/chap8/SECD/Instruction.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "reify.smi" 3 | structure Instruction = 4 | struct 5 | datatype prim = EQ | ADD | SUB | MUL | DIV 6 | datatype inst 7 | = PushI of int | PushS of string | PushB of bool 8 | | Acc of string | App | Pair | Proj1 | Proj2 9 | | Prim of prim | MkCLS of string * inst list 10 | | MkREC of string * string * inst list 11 | | If of inst list * inst list | Ret 12 | type C = inst list 13 | val codeToString : C -> string 14 | val instToString : inst -> string 15 | end 16 | -------------------------------------------------------------------------------- /examples/chap8/SECD/Instruction.sml: -------------------------------------------------------------------------------- 1 | structure Instruction = 2 | struct 3 | datatype prim = EQ | ADD | SUB | MUL | DIV 4 | datatype inst 5 | = PushI of int | PushS of string | PushB of bool 6 | | Acc of string | App | Pair | Proj1 | Proj2 7 | | Prim of prim | MkCLS of string * inst list 8 | | MkREC of string * string * inst list 9 | | If of inst list * inst list | Ret 10 | type C = inst list 11 | (* 12 | fun instToString inst = 13 | case inst of 14 | PushI int => "PushI(" ^ Int.toString int ^ ")" 15 | | PushS string => "PushS(\"" ^ string ^ "\")" 16 | | PushB bool => "PushB(" ^ Bool.toString bool ^ ")" 17 | | Acc string => "Acc(" ^ string ^ ")" 18 | | App => "App" 19 | | Pair => "Pair" 20 | | Proj1 => "Proj1" 21 | | Proj2 => "Proj2" 22 | | Prim EQ => "Prim(EQ)" 23 | | Prim ADD => "Prim(ADD)" 24 | | Prim SUB => "Prim(SUB)" 25 | | Prim MUL => "Prim(MUL)" 26 | | Prim DIV => "Prim(DIV)" 27 | | MkCLS (x, code) => "MkCls(" ^ x ^ "," ^ codeToString code ^ ")" 28 | | MkREC (f, x, code) 29 | => "MkCls(" ^ f ^ "," ^ x ^ "," ^ codeToString code ^ ")" 30 | | If (code1, code2) => 31 | "If(" ^ codeToString code1 ^ "," ^ codeToString code2 ^ ")" 32 | | Ret => "Ret" 33 | and codeToString code = 34 | "[" ^ String.concatWith "," (map instToString code) ^ "]" 35 | *) 36 | fun instToString inst = Dynamic.format inst 37 | fun codeToString C = Dynamic.format C 38 | end 39 | -------------------------------------------------------------------------------- /examples/chap8/SECD/Value.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SEnv.smi" 3 | _require "./Instruction.smi" 4 | structure Value = struct 5 | datatype value 6 | = INT of int | BOOL of bool | STRING of string 7 | | PAIR of value * value 8 | | CLS of E * string * Instruction.C 9 | | REC of E * string * string * Instruction.C 10 | withtype E = value SEnv.map 11 | val emptyEnv : E 12 | val valueToString : value -> string 13 | end 14 | -------------------------------------------------------------------------------- /examples/chap8/SECD/Value.sml: -------------------------------------------------------------------------------- 1 | structure Value = struct 2 | datatype value 3 | = INT of int | BOOL of bool | STRING of string 4 | | PAIR of value * value 5 | | CLS of E * string * Instruction.C 6 | | REC of E * string * string * Instruction.C 7 | withtype E = value SEnv.map 8 | val emptyEnv = SEnv.empty 9 | fun valueToString value = 10 | case value of 11 | INT int => Int.toString int 12 | | BOOL bool => Bool.toString bool 13 | | STRING string => "\"" ^ string ^ "\"" 14 | | PAIR (v1, v2) => "(" ^ valueToString v1 ^ "," ^ valueToString v2 ^ ")" 15 | | CLS (env, x, code) => "fn" 16 | | REC (env, f, x, code) => "fix" 17 | (* 18 | fun valueToString v = Dynamic.format v 19 | *) 20 | end 21 | -------------------------------------------------------------------------------- /examples/chap8/main/Main.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "./Top.smi" 3 | -------------------------------------------------------------------------------- /examples/chap8/main/Main.sml: -------------------------------------------------------------------------------- 1 | val _ = case CommandLine.arguments() of 2 | h::_ => Top.top h 3 | | nil => Top.top ""; 4 | -------------------------------------------------------------------------------- /examples/chap8/main/Makefile: -------------------------------------------------------------------------------- 1 | SMLSHARP = smlsharp 2 | SMLFLAGS = -O2 3 | LIBS = 4 | all: Main 5 | Main: ../parser/Syntax.smi ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi \ 6 | ../parser/CoreML.lex.smi ../parser/Parser.smi ../typeinf/Type.smi \ 7 | ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi ../typeinf/Typeinf.smi \ 8 | ../SECD/Instruction.smi ../SECD/Comp.smi ../SECD/Value.smi ../SECD/Exec.smi \ 9 | Top.smi Main.smi ../parser/Syntax.o ../parser/CoreML.grm.o \ 10 | ../parser/CoreML.lex.o ../parser/Parser.o ../typeinf/Type.o \ 11 | ../typeinf/TypeUtils.o ../typeinf/UnifyTy.o ../typeinf/Typeinf.o \ 12 | ../SECD/Instruction.o ../SECD/Comp.o ../SECD/Value.o ../SECD/Exec.o Top.o \ 13 | Main.o 14 | $(SMLSHARP) $(LDFLAGS) -o Main Main.smi $(LIBS) 15 | ../parser/Syntax.o: ../parser/Syntax.sml ../parser/Syntax.smi 16 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/Syntax.o -c ../parser/Syntax.sml 17 | ../parser/CoreML.grm.sig: ../parser/CoreML.grm 18 | smlyacc ../parser/CoreML.grm 19 | ../parser/CoreML.grm.sml: ../parser/CoreML.grm 20 | smlyacc ../parser/CoreML.grm 21 | ../parser/CoreML.grm.o: ../parser/CoreML.grm.sml ../parser/Syntax.smi \ 22 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi 23 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/CoreML.grm.o -c \ 24 | ../parser/CoreML.grm.sml 25 | ../parser/CoreML.lex.sml: ../parser/CoreML.lex 26 | smllex ../parser/CoreML.lex 27 | ../parser/CoreML.lex.o: ../parser/CoreML.lex.sml ../parser/Syntax.smi \ 28 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi 29 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/CoreML.lex.o -c \ 30 | ../parser/CoreML.lex.sml 31 | ../parser/Parser.o: ../parser/Parser.sml ../parser/Syntax.smi \ 32 | ../parser/CoreML.grm.sig ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi \ 33 | ../parser/Parser.smi 34 | $(SMLSHARP) $(SMLFLAGS) -o ../parser/Parser.o -c ../parser/Parser.sml 35 | ../typeinf/Type.o: ../typeinf/Type.sml ../typeinf/Type.smi 36 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/Type.o -c ../typeinf/Type.sml 37 | ../typeinf/TypeUtils.o: ../typeinf/TypeUtils.sml ../typeinf/Type.smi \ 38 | ../typeinf/TypeUtils.smi 39 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/TypeUtils.o -c \ 40 | ../typeinf/TypeUtils.sml 41 | ../typeinf/UnifyTy.o: ../typeinf/UnifyTy.sml ../typeinf/Type.smi \ 42 | ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi 43 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/UnifyTy.o -c \ 44 | ../typeinf/UnifyTy.sml 45 | ../typeinf/Typeinf.o: ../typeinf/Typeinf.sml ../parser/Syntax.smi \ 46 | ../typeinf/Type.smi ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi \ 47 | ../typeinf/Typeinf.smi 48 | $(SMLSHARP) $(SMLFLAGS) -o ../typeinf/Typeinf.o -c \ 49 | ../typeinf/Typeinf.sml 50 | ../SECD/Instruction.o: ../SECD/Instruction.sml ../SECD/Instruction.smi 51 | $(SMLSHARP) $(SMLFLAGS) -o ../SECD/Instruction.o -c \ 52 | ../SECD/Instruction.sml 53 | ../SECD/Comp.o: ../SECD/Comp.sml ../parser/Syntax.smi ../SECD/Instruction.smi \ 54 | ../SECD/Comp.smi 55 | $(SMLSHARP) $(SMLFLAGS) -o ../SECD/Comp.o -c ../SECD/Comp.sml 56 | ../SECD/Value.o: ../SECD/Value.sml ../SECD/Instruction.smi ../SECD/Value.smi 57 | $(SMLSHARP) $(SMLFLAGS) -o ../SECD/Value.o -c ../SECD/Value.sml 58 | ../SECD/Exec.o: ../SECD/Exec.sml ../SECD/Instruction.smi ../SECD/Value.smi \ 59 | ../SECD/Exec.smi 60 | $(SMLSHARP) $(SMLFLAGS) -o ../SECD/Exec.o -c ../SECD/Exec.sml 61 | Top.o: Top.sml ../parser/Syntax.smi ../parser/CoreML.grm.sig \ 62 | ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi ../parser/Parser.smi \ 63 | ../typeinf/Type.smi ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi \ 64 | ../typeinf/Typeinf.smi ../SECD/Instruction.smi ../SECD/Comp.smi \ 65 | ../SECD/Value.smi ../SECD/Exec.smi Top.smi 66 | $(SMLSHARP) $(SMLFLAGS) -o Top.o -c Top.sml 67 | Main.o: Main.sml ../parser/Syntax.smi ../parser/CoreML.grm.sig \ 68 | ../parser/CoreML.grm.smi ../parser/CoreML.lex.smi ../parser/Parser.smi \ 69 | ../typeinf/Type.smi ../typeinf/TypeUtils.smi ../typeinf/UnifyTy.smi \ 70 | ../typeinf/Typeinf.smi ../SECD/Instruction.smi ../SECD/Comp.smi \ 71 | ../SECD/Value.smi ../SECD/Exec.smi Top.smi Main.smi 72 | $(SMLSHARP) $(SMLFLAGS) -o Main.o -c Main.sml 73 | clean: 74 | rm -f ./*.o ../parser/*.o ../typeinf/*.o ../SECD/*.o Main 75 | rm -f ../parser/CoreML.grm.sml ../parser/CoreML.grm.sig ../parser/CoreML.lex.sml 76 | .SUFFIXES: .grm .lex 77 | -------------------------------------------------------------------------------- /examples/chap8/main/Top.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SEnv.smi" 3 | _require "compiler/libs/env/main/SSet.smi" 4 | _require "../parser/Parser.smi" 5 | _require "../parser/Syntax.smi" 6 | _require "../typeinf/Typeinf.smi" 7 | _require "../typeinf/TypeUtils.smi" 8 | _require "../SECD/Comp.smi" 9 | _require "../SECD/Exec.smi" 10 | _require "../SECD/Value.smi" 11 | structure Top = 12 | struct 13 | val top : string -> unit 14 | end 15 | -------------------------------------------------------------------------------- /examples/chap8/main/Top.sml: -------------------------------------------------------------------------------- 1 | structure Top = 2 | struct 3 | fun readAndPrintLoop env gamma stream = 4 | let 5 | val (dec, stream) = Parser.doParse stream 6 | val newGamma = Typeinf.typeinf gamma dec 7 | val namedCode = Comp.compile dec 8 | val newEnv = Exec.run env namedCode 9 | in 10 | readAndPrintLoop newEnv newGamma stream 11 | end 12 | fun top file = 13 | let 14 | val inStream = case file of 15 | "" => TextIO.stdIn 16 | | _ => TextIO.openIn file 17 | val stream = Parser.makeStream inStream 18 | val gamma = TypeUtils.emptyTyEnv 19 | val env = Value.emptyEnv 20 | in 21 | readAndPrintLoop env gamma stream 22 | handle Parser.EOF => () 23 | | Parser.ParseError => print "Syntax error\n" 24 | | Typeinf.TypeError => print "Type error\n" 25 | | Exec.RuntimeError => print "Runtime error\n"; 26 | case file of "" => () 27 | | _ => TextIO.closeIn inStream 28 | end 29 | end 30 | -------------------------------------------------------------------------------- /examples/chap8/parser/CoreML.grm: -------------------------------------------------------------------------------- 1 | %% 2 | %pos int 3 | %term ADD | COMMA | DARROW | DIV | ELSE | EOF | EQ | EQUAL 4 | | FALSE | FN | FUN | HASH1 | HASH2 | ID of string | IF 5 | | INT of int | LPAREN | MUL | RPAREN | SEMICOLON 6 | | STRING of string | SUB | THEN | TRUE | VAL 7 | %nonterm appexp of Syntax.exp | atexp of Syntax.exp 8 | | const of Syntax.exp | exp of Syntax.exp 9 | | dec of Syntax.dec | top of Syntax.dec 10 | | prim of Syntax.prim 11 | %start top 12 | %name CoreML 13 | %eop EOF SEMICOLON 14 | %noshift EOF 15 | %% 16 | top : dec (dec) 17 | dec : VAL ID EQUAL exp (Syntax.VAL(ID,exp)) 18 | | FUN ID ID EQUAL exp 19 | (Syntax.VAL(ID1, Syntax.EXPFIX(ID1, ID2, exp))) 20 | exp : appexp (appexp) 21 | | IF exp THEN exp ELSE exp (Syntax.EXPIF(exp1, exp2, exp3)) 22 | | FN ID DARROW exp (Syntax.EXPFN(ID, exp)) 23 | appexp : atexp (atexp) 24 | | appexp atexp (Syntax.EXPAPP(appexp, atexp)) 25 | atexp : const (const) 26 | | ID (Syntax.EXPID(ID)) 27 | | LPAREN exp COMMA exp RPAREN 28 | (Syntax.EXPPAIR(exp1, exp2)) 29 | | LPAREN exp RPAREN (exp) 30 | | HASH1 atexp (Syntax.EXPPROJ1 atexp) 31 | | HASH2 atexp (Syntax.EXPPROJ2 atexp) 32 | | prim LPAREN exp COMMA exp RPAREN 33 | (Syntax.EXPPRIM(prim, exp1, exp2)) 34 | const : INT (Syntax.INT(INT)) 35 | | STRING (Syntax.STRING(STRING)) 36 | | TRUE (Syntax.TRUE) | FALSE (Syntax.FALSE) 37 | prim : EQ (Syntax.EQ) | ADD (Syntax.ADD) | SUB (Syntax.SUB) 38 | | MUL (Syntax.MUL) | DIV (Syntax.DIV) 39 | 40 | -------------------------------------------------------------------------------- /examples/chap8/parser/CoreML.grm.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "ml-yacc-lib.smi" 3 | _require "./Syntax.smi" 4 | _require "./CoreML.grm.sig" 5 | structure CoreMLLrVals = 6 | struct 7 | structure Parser = struct 8 | type token (= boxed) 9 | type stream (= boxed) 10 | type result = Syntax.dec 11 | type pos = int 12 | type arg = unit 13 | exception ParseError 14 | val makeStream : {lexer:unit -> token} -> stream 15 | val getStream : stream -> token * stream 16 | val sameToken : token * token -> bool 17 | val parse : {lookahead:int, stream:stream,arg: arg, 18 | error: (string * pos * pos -> unit)} 19 | -> result * stream 20 | end 21 | structure Tokens = struct 22 | type pos = Parser.pos 23 | type token = Parser.token 24 | val EQ: pos * pos -> token 25 | val DIV: pos * pos -> token 26 | val SUB: pos * pos -> token 27 | val MUL: pos * pos -> token 28 | val ADD: pos * pos -> token 29 | val VAL: pos * pos -> token 30 | val THEN: pos * pos -> token 31 | val TRUE: pos * pos -> token 32 | val STRING: (string) * pos * pos -> token 33 | val SEMICOLON: pos * pos -> token 34 | val RPAREN: pos * pos -> token 35 | val LPAREN: pos * pos -> token 36 | val INT: (int) * pos * pos -> token 37 | val IF: pos * pos -> token 38 | val ID: (string) * pos * pos -> token 39 | val HASH2: pos * pos -> token 40 | val HASH1: pos * pos -> token 41 | val FUN: pos * pos -> token 42 | val FN: pos * pos -> token 43 | val FALSE: pos * pos -> token 44 | val EQUAL: pos * pos -> token 45 | val ELSE: pos * pos -> token 46 | val DARROW: pos * pos -> token 47 | val COMMA: pos * pos -> token 48 | val EOF: pos * pos -> token 49 | end 50 | end 51 | 52 | 53 | -------------------------------------------------------------------------------- /examples/chap8/parser/CoreML.lex: -------------------------------------------------------------------------------- 1 | structure Tokens = CoreMLLrVals.Tokens 2 | type token = Tokens.token 3 | type pos = Tokens.pos 4 | type lexresult = Tokens.token 5 | exception Error 6 | 7 | val eof = fn _ => Tokens.EOF (0,0) 8 | fun atoi s = valOf (Int.fromString s) 9 | 10 | %% 11 | %structure CoreMLLex 12 | 13 | alpha = [A-Za-z]; 14 | digit = [0-9]; 15 | num = {digit}+; 16 | idchars = {alpha}|{digit}; 17 | id = {alpha}{idchars}*; 18 | ws = "\ " | "\t" | "\r\n" | "\n" | "\r"; 19 | 20 | %% 21 | 22 | {ws} => (lex()); 23 | "add" => (Tokens.ADD (yypos,yypos+3)); 24 | "mul" => (Tokens.MUL (yypos,yypos+3)); 25 | "sub" => (Tokens.SUB (yypos,yypos+3)); 26 | "div" => (Tokens.DIV (yypos,yypos+3)); 27 | "eq" => (Tokens.EQ (yypos,yypos+2)); 28 | "else" => (Tokens.ELSE (yypos,yypos+4)); 29 | "true" => (Tokens.TRUE (yypos,yypos+4)); 30 | "false" => (Tokens.FALSE (yypos,yypos+5)); 31 | "fn" => (Tokens.FN (yypos,yypos+2)); 32 | "if" => (Tokens.IF (yypos,yypos+2)); 33 | "then" => (Tokens.THEN (yypos,yypos+4)); 34 | "val" => (Tokens.VAL (yypos,yypos+3)); 35 | "fun" => (Tokens.FUN (yypos,yypos+3)); 36 | "(" => (Tokens.LPAREN (yypos,yypos+1)); 37 | ")" => (Tokens.RPAREN (yypos,yypos+1)); 38 | "," => (Tokens.COMMA (yypos,yypos+1)); 39 | ";" => (Tokens.SEMICOLON (yypos,yypos+1)); 40 | "=" => (Tokens.EQUAL (yypos,yypos+1)); 41 | "=>" => (Tokens.DARROW (yypos,yypos+2)); 42 | "#1" => (Tokens.HASH1 (yypos,yypos+2)); 43 | "#2" => (Tokens.HASH2 (yypos,yypos+2)); 44 | {id} => (Tokens.ID 45 | ( 46 | yytext, 47 | yypos, 48 | yypos + String.size yytext 49 | )); 50 | {num} => (Tokens.INT 51 | ( 52 | atoi yytext, 53 | yypos, 54 | yypos + String.size yytext 55 | )); 56 | ~{num} => (Tokens.INT 57 | ( 58 | atoi yytext, 59 | yypos, 60 | yypos + String.size yytext 61 | )); 62 | \"{idchars}*\" => (Tokens.STRING 63 | (String.substring(yytext,1,String.size yytext - 2), 64 | yypos - String.size yytext + 1, 65 | yypos + 1)); 66 | . => (Tokens.ID 67 | (yytext, 68 | yypos, 69 | yypos + 1)); 70 | -------------------------------------------------------------------------------- /examples/chap8/parser/CoreML.lex.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "ml-yacc-lib.smi" 3 | _require "./CoreML.grm.smi" 4 | structure CoreMLLex = 5 | struct 6 | val makeLexer : (int -> string) -> unit 7 | -> CoreMLLrVals.Tokens.token 8 | end 9 | -------------------------------------------------------------------------------- /examples/chap8/parser/Parser.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "./Syntax.smi" 3 | _require "./CoreML.lex.smi" 4 | _require "./CoreML.grm.smi" 5 | structure Parser = 6 | struct 7 | exception EOF 8 | exception ParseError = CoreMLLrVals.Parser.ParseError 9 | type stream (= CoreMLLrVals.Parser.stream) 10 | val doParse : stream -> Syntax.dec * stream 11 | val makeStream : TextIO.instream -> stream 12 | end 13 | -------------------------------------------------------------------------------- /examples/chap8/parser/Parser.sml: -------------------------------------------------------------------------------- 1 | structure Parser = 2 | struct 3 | exception EOF 4 | exception ParseError = CoreMLLrVals.Parser.ParseError 5 | structure P = CoreMLLrVals.Parser 6 | structure T = CoreMLLrVals.Tokens 7 | type stream = P.stream 8 | fun print_error (s,pos1,pos2) = 9 | print ("Syntax error(" 10 | ^ Int.toString pos1 11 | ^ "-" ^ Int.toString pos2 ^ ") :" ^ s ^ "\n") 12 | fun discardSemicolons stream = 13 | let val (token, rest) = P.getStream stream 14 | in if P.sameToken (token, T.SEMICOLON (0,0)) then 15 | discardSemicolons rest 16 | else if P.sameToken (token, T.EOF (0,0)) then raise EOF 17 | else stream 18 | end 19 | fun doParse stream = 20 | let val stream = discardSemicolons stream 21 | val (dec, stream) = 22 | P.parse {lookahead=0, stream=stream, 23 | error=print_error,arg=()} 24 | val _ = print ("Parse result:\n" 25 | ^ (Syntax.decToString dec) ^ "\n") 26 | in (dec, stream) end 27 | fun makeStream inStream = 28 | let val lexer = CoreMLLex.makeLexer 29 | (fn n => TextIO.inputN (inStream,1)) 30 | in P.makeStream {lexer=lexer} end 31 | end 32 | -------------------------------------------------------------------------------- /examples/chap8/parser/Syntax.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | structure Syntax = 3 | struct 4 | datatype prim = EQ | ADD | SUB | MUL | DIV 5 | datatype exp 6 | = EXPID of string | INT of int | STRING of string 7 | | TRUE | FALSE | EXPFN of string * exp 8 | | EXPAPP of exp * exp | EXPPAIR of exp * exp 9 | | EXPPROJ1 of exp | EXPPROJ2 of exp 10 | | EXPPRIM of prim * exp * exp 11 | | EXPIF of exp * exp * exp 12 | | EXPFIX of string * string * exp 13 | and dec 14 | = VAL of string * exp 15 | val expToString : exp -> string 16 | val decToString : dec -> string 17 | end 18 | -------------------------------------------------------------------------------- /examples/chap8/parser/Syntax.sml: -------------------------------------------------------------------------------- 1 | (** 2 | * expression syntax 3 | * @copyright (c) 2006, Tohoku University. 4 | * @author Atsushi Ohori 5 | *) 6 | structure Syntax = 7 | struct 8 | datatype prim = EQ | ADD | SUB | MUL | DIV 9 | datatype exp 10 | = EXPID of string | INT of int | STRING of string 11 | | TRUE | FALSE | EXPFN of string * exp 12 | | EXPAPP of exp * exp | EXPPAIR of exp * exp 13 | | EXPPROJ1 of exp | EXPPROJ2 of exp 14 | | EXPPRIM of prim * exp * exp 15 | | EXPIF of exp * exp * exp 16 | | EXPFIX of string * string * exp 17 | and dec 18 | = VAL of string * exp 19 | fun expToString exp = 20 | case exp of 21 | INT int => Int.toString int 22 | | STRING string => "\"" ^ string ^ "\"" 23 | | TRUE => "true" 24 | | FALSE => "false" 25 | | EXPID string => string 26 | | EXPPAIR (exp1, exp2) => 27 | "(" ^ expToString exp1 ^ "," ^ expToString exp2 ^ ")" 28 | | EXPAPP (exp1, exp2) => 29 | "(" ^ expToString exp1 ^ " " ^ expToString exp2 ^ ")" 30 | | EXPIF (exp1, exp2, exp3) => 31 | "if " 32 | ^ expToString exp1 33 | ^ " then " 34 | ^ expToString exp2 35 | ^ " else " 36 | ^ expToString exp3 37 | | EXPFN (string, exp) => 38 | "(fn " ^ string ^ " => " ^ expToString exp ^ ")" 39 | | EXPPROJ1 exp => "#1 " ^ expToString exp 40 | | EXPPROJ2 exp => "#2 " ^ expToString exp 41 | | EXPFIX (f, x, exp) => 42 | "(fix " 43 | ^ f 44 | ^ "(" 45 | ^ x 46 | ^ ") => " ^ expToString exp ^ ")" 47 | | EXPPRIM (p, exp1, exp2) => 48 | let 49 | val prim = case p of ADD => "add" | SUB => "sub" 50 | | MUL => "mul" | DIV => "div" 51 | | EQ => "eq" 52 | in 53 | "prim(" ^ prim ^ "," ^ expToString exp1 ^ "," ^ expToString exp2 ^ ")" 54 | end 55 | and decToString dec = 56 | case dec of 57 | VAL (x, exp) => 58 | "val " ^ x ^ " = " ^ expToString exp 59 | (* 60 | fun printExp exp = print (expToString exp) 61 | fun printDec dec = print (decToString dec) 62 | fun expToString exp = Dynamic.format exp 63 | fun decToString dec = Dynamic.format dec 64 | *) 65 | end 66 | -------------------------------------------------------------------------------- /examples/chap8/typeinf/Type.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | structure Type = 3 | struct 4 | datatype ty 5 | = TYVARty of string | INTty | STRINGty | BOOLty 6 | | FUNty of ty * ty | PAIRty of ty * ty 7 | | POLYty of string list * ty 8 | val newTy : unit -> ty 9 | val tyToString : ty -> string 10 | end 11 | -------------------------------------------------------------------------------- /examples/chap8/typeinf/Type.sml: -------------------------------------------------------------------------------- 1 | structure Type = 2 | struct 3 | local 4 | val nextTyId = ref 0 5 | fun newTyId () = (!nextTyId before nextTyId := !nextTyId + 1) 6 | in 7 | fun initSeed () = nextTyId := 0 8 | fun newTyIdName () = 9 | let 10 | fun tyIdName tid = 11 | let 12 | fun numeral n = 13 | if n < 26 14 | then [ord #"a" + n] 15 | else 16 | let val (msb, rest) = (n mod 26, (n div 26) - 1) 17 | in (ord #"a" + msb) :: (numeral rest) 18 | end 19 | in 20 | (implode(map chr (rev (numeral tid)))) 21 | end 22 | in 23 | tyIdName (newTyId()) 24 | end 25 | end 26 | datatype ty = 27 | INTty 28 | | STRINGty 29 | | BOOLty 30 | | TYVARty of string 31 | | FUNty of ty * ty 32 | | PAIRty of ty * ty 33 | | POLYty of string list * ty 34 | fun newTy () = TYVARty (newTyIdName()) 35 | fun tyToString ty = 36 | case ty of 37 | INTty => "int" 38 | | STRINGty => "string" 39 | | BOOLty => "bool" 40 | | TYVARty string => "'" ^ string 41 | | FUNty (ty1, ty2) => 42 | "(" ^ tyToString ty1 ^ " -> " ^ tyToString ty2 ^ ")" 43 | | PAIRty (ty1, ty2) => 44 | "(" ^ tyToString ty1 ^ " * " ^ tyToString ty2 ^ ")" 45 | | POLYty (tids, ty) => 46 | "[" 47 | ^ 48 | String.concatWith "," tids 49 | ^ 50 | "." 51 | ^ 52 | tyToString ty 53 | ^ 54 | "]" 55 | (* 56 | fun tyToString ty = Dynamic.format ty 57 | *) 58 | end 59 | -------------------------------------------------------------------------------- /examples/chap8/typeinf/TypeUtils.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SSet.smi" 3 | _require "compiler/libs/env/main/SEnv.smi" 4 | _require "./Type.smi" 5 | structure TypeUtils = 6 | struct 7 | type subst = Type.ty SEnv.map 8 | type tyEnv = Type.ty SEnv.map 9 | val substTy : subst -> Type.ty -> Type.ty 10 | val emptySubst : subst 11 | val substTyEnv : subst -> tyEnv -> tyEnv 12 | val composeSubst : subst -> subst -> subst 13 | val freshInst : Type.ty -> Type.ty 14 | val emptyTyEnv : tyEnv 15 | val singletonTyEnv : string * Type.ty -> tyEnv 16 | val findTyEnv : tyEnv * string -> Type.ty option 17 | val matches : tyEnv * tyEnv -> (Type.ty * Type.ty) list 18 | val unionTyEnv : tyEnv * tyEnv -> tyEnv 19 | val removeTyEnv : tyEnv * string -> tyEnv 20 | val tyEnvToString : tyEnv -> string 21 | end 22 | -------------------------------------------------------------------------------- /examples/chap8/typeinf/TypeUtils.sml: -------------------------------------------------------------------------------- 1 | structure TypeUtils = 2 | struct 3 | local 4 | open Type 5 | in 6 | type subst = ty SEnv.map 7 | val emptySubst = SEnv.empty 8 | fun substTy subst ty = 9 | case ty of 10 | INTty => ty 11 | | STRINGty => ty 12 | | BOOLty => ty 13 | | TYVARty string => 14 | (case SEnv.find (subst, string) of 15 | NONE => ty 16 | | SOME ty => ty) 17 | | FUNty (ty1, ty2) => 18 | FUNty (substTy subst ty1, substTy subst ty2) 19 | | PAIRty (ty1, ty2) => 20 | PAIRty (substTy subst ty1, substTy subst ty2) 21 | | POLYty (tids, ty) => 22 | POLYty (tids, substTy subst ty) 23 | fun composeSubst subst1 subst2 = 24 | SEnv.unionWith 25 | (fn (ty1, ty2) => ty1) 26 | (SEnv.map (substTy subst1) subst2, 27 | subst1) 28 | type tyEnv = ty SEnv.map 29 | val findTyEnv = SEnv.find 30 | fun substTyEnv subst tyEnv = 31 | SEnv.map (substTy subst) tyEnv 32 | val emptyTyEnv = SEnv.empty 33 | fun singletonTyEnv (tyID, ty) = SEnv.singleton (tyID, ty) 34 | fun matches (tyEnv1, tyEnv2) = 35 | SEnv.listItems 36 | (SEnv.intersectWith (fn x => x) (tyEnv1, tyEnv2)) 37 | fun unionTyEnv (tyEnv1, tyEnv2) = 38 | SEnv.unionWith #1 (tyEnv1, tyEnv2) 39 | fun removeTyEnv (tyEnv, string) = #1 (SEnv.remove(tyEnv, string)) 40 | fun freshInst ty = 41 | case ty of 42 | POLYty (tids, ty) => 43 | let val S = 44 | foldr (fn (tid, S) => 45 | let val newty = newTy () 46 | in SEnv.insert(S, tid, newty) end) 47 | emptySubst 48 | tids 49 | in substTy S ty end 50 | | _ => ty 51 | 52 | fun tyEnvToString tyEnv = 53 | let 54 | val stringTyList = SEnv.listItemsi tyEnv 55 | in 56 | "{" ^ (String.concatWith " , " 57 | (map (fn (id,ty) => id ^ ":" ^ tyToString ty) stringTyList)) 58 | ^ "}" 59 | end 60 | end 61 | end 62 | -------------------------------------------------------------------------------- /examples/chap8/typeinf/Typeinf.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SEnv.smi" 3 | _require "compiler/libs/env/main/SSet.smi" 4 | _require "../parser/Syntax.smi" 5 | _require "./Type.smi" 6 | _require "./TypeUtils.smi" 7 | _require "./UnifyTy.smi" 8 | 9 | structure Typeinf = 10 | struct 11 | exception TypeError 12 | val typeinf : TypeUtils.tyEnv -> Syntax.dec -> TypeUtils.tyEnv 13 | end 14 | -------------------------------------------------------------------------------- /examples/chap8/typeinf/Typeinf.sml: -------------------------------------------------------------------------------- 1 | (** 2 | * Type inference module 3 | * @author Atsushi Ohori 4 | *) 5 | structure Typeinf = struct 6 | open Syntax Type TypeUtils UnifyTy 7 | exception TypeError 8 | infixr ++ 9 | fun s1 ++ s2 = composeSubst s1 s2 10 | fun W gamma exp = 11 | case exp of 12 | INT (int) => (emptySubst, INTty) 13 | | EXPID (string) => 14 | (case SEnv.find(gamma, string) of 15 | SOME ty => (emptySubst, freshInst ty) 16 | | NONE => raise TypeError) 17 | | EXPFN (string, exp) => 18 | let val ty1 = newTy() 19 | val newGamma = SEnv.insert(gamma, string, ty1) 20 | val (S, ty2) = W newGamma exp 21 | in 22 | (S, FUNty(substTy S ty1, ty2)) 23 | end 24 | | EXPAPP (exp1, exp2) => 25 | let 26 | val (S1, ty1) = W gamma exp1 27 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 28 | val ty3 = newTy() 29 | val S3 = unify [(FUNty(ty2, ty3), substTy S2 ty1)] 30 | val S4 = composeSubst S3 (composeSubst S2 S1) 31 | in 32 | (S4, substTy S4 ty3) 33 | end 34 | | STRING (string) => (emptySubst, STRINGty) 35 | | TRUE => (emptySubst, BOOLty) 36 | | FALSE => (emptySubst, BOOLty) 37 | | EXPPAIR (exp1, exp2) => 38 | let 39 | val (S1, ty1) = W gamma exp1 40 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 41 | in 42 | ( 43 | S2 ++ S1, 44 | PAIRty(substTy S2 ty1,ty2) 45 | ) 46 | end 47 | | EXPPROJ1 exp => 48 | let 49 | val (S1, ty) = W gamma exp 50 | val ty1 = newTy() 51 | val ty2 = newTy() 52 | val S2 = unify [(ty, PAIRty (ty1, ty2))] 53 | in 54 | ( 55 | S2 ++ S1, 56 | substTy S2 ty1 57 | ) 58 | end 59 | | EXPPROJ2 exp => 60 | let 61 | val (S1, ty) = W gamma exp 62 | val ty1 = newTy() 63 | val ty2 = newTy() 64 | val S2 = unify [(ty, PAIRty (ty1, ty2))] 65 | in 66 | ( 67 | S2 ++ S1, 68 | substTy S2 ty2 69 | ) 70 | end 71 | | EXPIF (exp1, exp2, exp3) => 72 | let 73 | val (S1, ty1) = W gamma exp1 74 | val S2 = unify [(ty1, BOOLty)] 75 | val (S3, ty2) = W (substTyEnv (S2 ++ S1) gamma) exp2 76 | val (S4, ty3) = W (substTyEnv (S3 ++ S2 ++ S1) gamma) exp3 77 | val S5 = unify [(ty2, ty3)] 78 | val S = S5 ++ S4 ++ S3 ++ S2 ++ S1 79 | val newGamma = substTyEnv S gamma 80 | in 81 | (S, substTy S5 ty2) 82 | end 83 | | EXPFIX (fid, xid, exp) => 84 | let 85 | val argTy = newTy() 86 | val bodyTy = newTy() 87 | val funTy = FUNty(argTy, bodyTy) 88 | val newGamma = 89 | SEnv.insert(SEnv.insert(gamma, fid, funTy), 90 | xid, argTy) 91 | val (S1, ty) = W newGamma exp 92 | val S2 = unify [(ty, bodyTy)] 93 | val S = S2 ++ S1 94 | in 95 | (S, substTy S funTy) 96 | end 97 | | EXPPRIM (p, exp1, exp2) => 98 | let 99 | val (S1, ty1) = W gamma exp1 100 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 101 | val S3 = unify [(substTy S2 ty1, INTty), (ty2, INTty)] 102 | val ty3 = 103 | case p of EQ => BOOLty | _ => INTty 104 | in 105 | (S3 ++ S2 ++ S1, ty3) 106 | end 107 | 108 | fun typeinf gamma (VAL (id, exp)) = 109 | let 110 | val (subst, ty) = W gamma exp 111 | val tids = SSet.listItems (FTV ty) 112 | val newTy = if null tids then ty else POLYty (tids, ty) 113 | val _ = print ("Inferred typing:\n" 114 | ^ "val " ^ id ^ " : " 115 | ^ Type.tyToString newTy ^ "\n") 116 | in 117 | SEnv.insert(gamma, id, newTy) 118 | end 119 | handle Unify => raise TypeError 120 | end 121 | -------------------------------------------------------------------------------- /examples/chap8/typeinf/UnifyTy.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SSet.smi" 3 | _require "compiler/libs/env/main/SEnv.smi" 4 | _require "./Type.smi" 5 | _require "./TypeUtils.smi" 6 | structure UnifyTy = struct 7 | exception UnifyTy 8 | val FTV : Type.ty -> SSet.set 9 | val unify : (Type.ty * Type.ty) list -> TypeUtils.subst 10 | end 11 | -------------------------------------------------------------------------------- /examples/chap8/typeinf/UnifyTy.sml: -------------------------------------------------------------------------------- 1 | structure UnifyTy = struct 2 | open Type TypeUtils 3 | exception UnifyTy 4 | fun FTV ty = 5 | let fun scan ty set = 6 | case ty of 7 | TYVARty string => SSet.add (set,string) 8 | | FUNty (domTy, ranTy) => scan ranTy (scan domTy set) 9 | | PAIRty (fstTy, sndTy) => scan sndTy (scan fstTy set) 10 | | _ => set 11 | in scan ty SSet.empty end 12 | fun occurs (TYVARty string, ty) = SSet.member(FTV ty, string) 13 | | occurs _ = false 14 | fun rewrite (nil, S) = S 15 | | rewrite((ty1,ty2)::E, S) = 16 | if ty1 = ty2 then rewrite(E, S) else 17 | case (ty1,ty2) of 18 | (TYVARty tv, _) => 19 | if occurs (ty1, ty2) then raise UnifyTy else 20 | let val S1 = SEnv.singleton(tv, ty2) 21 | in rewrite (map (fn (ty1,ty2) => 22 | (substTy S1 ty1, substTy S1 ty2)) 23 | E, 24 | composeSubst S1 S) 25 | end 26 | | (_, TYVARty tv) => rewrite ((ty2, ty1)::E, S) 27 | | (FUNty(ty11, ty12), FUNty(ty21, ty22)) => 28 | rewrite ((ty11,ty21)::(ty12,ty22)::E, S) 29 | | (PAIRty(ty11, ty12), PAIRty(ty21, ty22)) => 30 | rewrite ((ty11, ty21)::(ty12, ty22)::E,S) 31 | | _ => raise UnifyTy 32 | fun unify E = rewrite (E, SEnv.empty) 33 | end 34 | 35 | -------------------------------------------------------------------------------- /examples/chap8/typeinf/W.smi: -------------------------------------------------------------------------------- 1 | _require "basis.smi" 2 | _require "compiler/libs/env/main/SEnv.smi" 3 | _require "compiler/libs/env/main/SSet.smi" 4 | _require "../parser/Syntax.smi" 5 | _require "./Type.smi" 6 | _require "./TypeUtils.smi" 7 | _require "./UnifyTy.smi" 8 | 9 | structure W = 10 | struct 11 | exception TypeError 12 | val typeinf : TypeUtils.tyEnv -> Syntax.dec -> TypeUtils.tyEnv 13 | end 14 | -------------------------------------------------------------------------------- /examples/chap8/typeinf/W.sml: -------------------------------------------------------------------------------- 1 | (** 2 | * Type inference module 3 | * @author Atsushi Ohori 4 | *) 5 | structure W = struct 6 | local 7 | open Absyn Types TypeUtils Unify 8 | in 9 | exception NotImplemented 10 | exception TypeError 11 | infixr ++ 12 | fun s1 ++ s2 = composeSubst s1 s2 13 | fun W gamma absyn = 14 | case absyn of 15 | INT (int) => (emptySubst, INTty) 16 | | STRING (string) => (emptySubst, STRINGty) 17 | | TRUE => (emptySubst, BOOLty) 18 | | FALSE => (emptySubst, BOOLty) 19 | | EXPID (string) => 20 | (case SEnv.find(gamma, string) of 21 | SOME ty => (emptySubst, freshInst ty) 22 | | NONE => raise TypeError 23 | ) 24 | | EXPPAIR (exp1, exp2) => 25 | let 26 | val (S1, ty1) = W gamma exp1 27 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 28 | in 29 | ( 30 | S2 ++ S1, 31 | PAIRty(substTy S2 ty1,ty2) 32 | ) 33 | end 34 | | EXPPROJ1 exp => 35 | let 36 | val (S1, ty) = W gamma exp 37 | val ty1 = newTy() 38 | val ty2 = newTy() 39 | val S2 = unify [(ty, PAIRty (ty1, ty2))] 40 | in 41 | ( 42 | S2 ++ S1, 43 | substTy S2 ty1 44 | ) 45 | end 46 | | EXPPROJ2 exp => 47 | let 48 | val (S1, ty) = W gamma exp 49 | val ty1 = newTy() 50 | val ty2 = newTy() 51 | val S2 = unify [(ty, PAIRty (ty1, ty2))] 52 | in 53 | ( 54 | S2 ++ S1, 55 | substTy S2 ty2 56 | ) 57 | end 58 | | EXPAPP (exp1, exp2) => 59 | let 60 | val (S1, ty1) = W gamma exp1 61 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 62 | val newty = newTy() 63 | val S3 = unify [(FUNty(ty2, newty), substTy S2 ty1)] 64 | in 65 | ( 66 | S3 ++ S2 ++ S1, 67 | substTy S3 newty 68 | ) 69 | end 70 | | EXPFN (string, exp) => 71 | let 72 | val newty = newTy() 73 | val newGamma = SEnv.insert(gamma, string, newty) 74 | val (S, ty) = W newGamma exp 75 | in 76 | (S, 77 | FUNty(substTy S newty, ty) 78 | ) 79 | end 80 | | EXPIF (exp1, exp2, exp3) => 81 | let 82 | val (S1, ty1) = W gamma exp1 83 | val S2 = unify [(ty1, BOOLty)] 84 | val (S3, ty2) = W (substTyEnv (S2 ++ S1) gamma) exp2 85 | val (S4, ty3) = W (substTyEnv (S3 ++ S2 ++ S1) gamma) exp3 86 | val S5 = unify [(ty2, ty3)] 87 | val S = S5 ++ S4 ++ S3 ++ S2 ++ S1 88 | val newGamma = substTyEnv S gamma 89 | in 90 | (S, substTy S5 ty2) 91 | end 92 | | EXPFIX (fid, xid, exp) => 93 | let 94 | val argTy = newTy() 95 | val bodyTy = newTy() 96 | val funTy = FUNty(argTy, bodyTy) 97 | val newGamma = 98 | SEnv.insert(SEnv.insert(gamma, fid, funTy), 99 | xid, argTy) 100 | val (S1, ty) = W newGamma exp 101 | val S2 = unify [(ty, bodyTy)] 102 | val S = S2 ++ S1 103 | in 104 | (S, substTy S funTy) 105 | end 106 | | EXPPRIM (prim, exp1, exp2) => 107 | case prim of 108 | "eq" => 109 | let 110 | val (S1, ty1) = W gamma exp1 111 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 112 | val S3 = unify [(ty1, ty2)] 113 | in 114 | (S3 ++ S2 ++ S1, BOOLty) 115 | end 116 | | _ => 117 | let 118 | val (S1, ty1) = W gamma exp1 119 | val (S2, ty2) = W (substTyEnv S1 gamma) exp2 120 | val S3 = unify [(substTy S2 ty1, INTty), (ty2, INTty)] 121 | in 122 | (S3 ++ S2 ++ S1, INTty) 123 | end 124 | 125 | fun typeinf gamma (Absyn.VAL (id, exp)) = 126 | let 127 | val (subst, ty) = W gamma exp 128 | val tids = SSet.listItems (Unify.FTV ty) 129 | val newTy = if null tids then ty else Types.POLYty (tids, ty) 130 | val _ = 131 | print ( 132 | "Inferred typing:\n" 133 | ^ "val " 134 | ^ id 135 | ^ " : " 136 | ^ Types.tyToString newTy 137 | ^ "\n") 138 | val newGamma = SEnv.insert(gamma, id, newTy) 139 | in 140 | newGamma 141 | end 142 | | typeinf gamma _ = raise TypeError 143 | end 144 | end 145 | --------------------------------------------------------------------------------