├── README.md ├── doc └── pdf │ ├── lach-1998.pdf │ ├── splawski-1993.pdf │ ├── splawski-1999.pdf │ ├── splawski-2002.pdf │ ├── urzyczyn-1999.pdf │ └── wierzbicki-1993.pdf └── src ├── v1 ├── README ├── arithme.sml ├── cotypars.sml ├── environ.sml ├── eval.sml ├── genelim.sml ├── genintro.sml ├── gentraco.sml ├── gentrade.sml ├── gettype.sml ├── ipl.login ├── ipl.sys ├── ipll.sml ├── iterec.sml ├── lampars.sml ├── lamterm.sml ├── lexical.sml ├── listing.sml ├── make-all ├── monamon.sml ├── parser.sml ├── scanner.sml ├── source.sml ├── tylam.sml ├── typaram.sml ├── typars.sml ├── typex.sml ├── typinfo.sml ├── typofter.sml └── unify.sml ├── v2 ├── README ├── compiler │ ├── etElab.sml │ ├── etUnifier.sml │ └── sources.cm ├── et.sml ├── etMain.sml ├── etMake.sml ├── etcm.sml ├── lib.et ├── p1.et ├── p2.et ├── p3.et ├── p4.et ├── p5.et ├── p6.et ├── p7.et ├── parser │ ├── et.grm │ ├── et.lex │ ├── etFromParser.sml │ ├── etLexPos.sml │ ├── etParser.sml │ ├── ml-yacc │ │ ├── base.sig │ │ ├── join.sml │ │ ├── lrtable.sml │ │ ├── parser1.sml │ │ ├── sources.cm │ │ └── stream.sml │ └── sources.cm ├── sources.cm ├── syntax │ ├── etAbstractSyntax.sml │ ├── etEnvironment.sml │ ├── etEval.sml │ ├── etPrettyPrint.sml │ └── sources.cm └── tools │ ├── etTools.sml │ ├── int-inf-sig.sml │ ├── int-inf.sml │ └── sources.cm └── v3 ├── COPYRIGHT ├── Makefile ├── NEWS ├── README.md ├── VERSION ├── ast.mli ├── env.ml ├── env.mli ├── eval.ml ├── eval.mli ├── examples ├── ex1.et ├── ex2.et ├── ex3.et ├── ex4.et ├── ex5.et ├── iplbyex.et ├── iplbyex2.et ├── l3.et ├── l4.et └── poly.et ├── lambda.ml ├── lambda.mli ├── lexer.mli ├── lexer.mll ├── main.ml ├── parser.mly ├── pp.ml ├── pp.mli ├── startup.et ├── tests ├── ex1.et.out ├── ex2.et.out ├── ex3.et.out ├── ex4.et.out ├── ex5.et.out ├── iplbyex.et.out ├── iplbyex2.et.out ├── l3.et.out ├── l4.et.out ├── poly.et.out └── run ├── typing.ml ├── typing.mli ├── tysem.ml ├── tysem.mli ├── tyutil.ml ├── tyutil.mli ├── unionfind.ml ├── unionfind.mli ├── util.ml └── util.mli /README.md: -------------------------------------------------------------------------------- 1 | _et-lang_ 2 | ========= 3 | 4 | Source code of three interpreters for the ET language, also known as IPL: 5 | 6 | 1. The original SML implementation, by Tomasz Wierzbicki, dated 19 November 1993 7 | 8 | 2. An SML implementation, by Marek Łach, dated 6 November 1998 9 | 10 | 3. An OCaml implementation, by [Michał Moskal](http://moskal.me/), dated 5 November 2004 11 | 12 | Includes all available literature. 13 | 14 | 15 | ### Literature 16 | 17 | * Z. Spławski (1988) “Teoriodowodowe podejście do programów funkcyjnych i typów danych” 18 | * Z. Spławski (1991) “Proof-theoretic approach to automatic synthesis of polymorphic programs” 19 | * Z. Spławski (1993) [“IPL by examples”](doc/pdf/splawski-1993.pdf) 20 | * T. Wierzbicki (1993) [“On the implementation of IPL”](doc/pdf/wierzbicki-1993.pdf) 21 | * Z. Spławski (1993) “Proof-theoretic approach to inductive definitions in ML-like programming language vs. second-order lambda calculus” 22 | * Z. Spławski (1995) “Proving equalities in λ→ with positive (co-)inductive data types” 23 | * Z. Spławski (1996) “Subtyping λ→ with positive (co-)inductive data types” 24 | * Z. Spławski (1997) “Proving equalities in second-order lambda calculus with inductive and recursive types” 25 | * M. Łach (1998) [“Teoria typów z definicjami indukcyjnymi jako język programowania”](doc/pdf/lach-1998.pdf) 26 | * Z. Spławski (1998) “Continuations in λ→ with positive (co-)inductive data types” 27 | * Z. Spławski (1999) “Interdefinability of positive coinductive types with corecursors” 28 | * P. Urzyczyn (1999) [“The Curry-Howard isomorphism: Remarks on recursive types”](doc/pdf/urzyczyn-1999.pdf) 29 | * Z. Spławski, P. Urzyczyn (1999) [“Type fixpoints: iteration vs. recursion”](doc/pdf/splawski-1999.pdf) 30 | * Z. Spławski (2002) [“Defining recursors by solving equations in second-order lambda calculus”](doc/pdf/splawski-2002.pdf) 31 | 32 | 33 | ### Related work 34 | 35 | * [_Total_ functional programming](https://github.com/mietek/total-fp) 36 | * [_Totally_ functional programming](https://github.com/mietek/totally-fp) 37 | * [Charity language](https://github.com/mietek/charity-lang) 38 | 39 | 40 | About 41 | ----- 42 | 43 | Packaged by [Miëtek Bak](https://mietek.io/). 44 | -------------------------------------------------------------------------------- /doc/pdf/lach-1998.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mietek/et-lang/e43a5a8f8e4a242319d9dc3f3a62d19bbcb863cb/doc/pdf/lach-1998.pdf -------------------------------------------------------------------------------- /doc/pdf/splawski-1993.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mietek/et-lang/e43a5a8f8e4a242319d9dc3f3a62d19bbcb863cb/doc/pdf/splawski-1993.pdf -------------------------------------------------------------------------------- /doc/pdf/splawski-1999.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mietek/et-lang/e43a5a8f8e4a242319d9dc3f3a62d19bbcb863cb/doc/pdf/splawski-1999.pdf -------------------------------------------------------------------------------- /doc/pdf/splawski-2002.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mietek/et-lang/e43a5a8f8e4a242319d9dc3f3a62d19bbcb863cb/doc/pdf/splawski-2002.pdf -------------------------------------------------------------------------------- /doc/pdf/urzyczyn-1999.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mietek/et-lang/e43a5a8f8e4a242319d9dc3f3a62d19bbcb863cb/doc/pdf/urzyczyn-1999.pdf -------------------------------------------------------------------------------- /doc/pdf/wierzbicki-1993.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mietek/et-lang/e43a5a8f8e4a242319d9dc3f3a62d19bbcb863cb/doc/pdf/wierzbicki-1993.pdf -------------------------------------------------------------------------------- /src/v1/README: -------------------------------------------------------------------------------- 1 | This is The Inferential Programming Language Interpreter v. 2.0 2 | programmed in Standard ML. 3 | 4 | You require Edinburgh Standard ML Core Language compiler v. 4.0 5 | to use this program. In ipl/src directory you find shell 6 | script "make-all". Edit it and run it. Then edit shell script 7 | "ipl" placed in your default directory for binaries. 8 | 9 | You can get Edinburgh SML from anonymous ftp at ftp.dcs.ed.ac.uk, 10 | directory export/edml. 11 | -------------------------------------------------------------------------------- /src/v1/arithme.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* ARITHME.SML - some additional arithmetic functions. *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992. *) 7 | (* *) 8 | (* *) 9 | (* Imports: none *) 10 | (* Exports: *) 11 | (* isqr = fn: int -> int *) 12 | (* odd = fn: int -> bool *) 13 | (* even = fn: int -> bool *) 14 | (* halve = fn: int -> int *) 15 | (* succ = fn: int -> int *) 16 | (* pred = fn: int -> int *) 17 | (* iszero = fn: int -> bool *) 18 | (* infix 2 eqv = fn: bool * bool -> bool *) 19 | (* *) 20 | (*********************************************************************) 21 | 22 | fun isqr n : int = n * n; 23 | 24 | fun odd n = n mod 2 = 1; 25 | fun even n = n mod 2 = 0; 26 | 27 | fun halve n = n div 2; 28 | 29 | fun succ n = n + 1; 30 | fun pred n = n - 1; 31 | 32 | fun iszero n = n = 0; 33 | 34 | infix 2 eqv; 35 | fun a eqv b = (not a orelse b) andalso (not b orelse a); 36 | 37 | (* end of ARITHME.SML ************************************************) 38 | 39 | -------------------------------------------------------------------------------- /src/v1/genelim.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* GENELIM.SML - THE GENERATOR OF THE TYPE OF ELIMINATORS *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from TYLAM.SML: *) 11 | (* datatype typex and tyvar *) 12 | (* Exports: *) 13 | (* splitconty = fn: typex -> typex list *) 14 | (* substy = fn: typex -> (typex -> bool) -> typex -> typex *) 15 | (* genelim = fn: typex -> typex list -> bool -> typex -> *) 16 | (* typex *) 17 | (* *) 18 | (*********************************************************************) 19 | 20 | val splitconty = 21 | let 22 | fun f acc ( Tyfun (t1 , t2) ) = f (acc @ [t1]) t2 23 | | f acc _ = acc; 24 | in 25 | f nil 26 | end; 27 | 28 | fun substy isoldty newty t = 29 | if isoldty t 30 | then newty 31 | else case t of 32 | Tyvar (ref None) => t | 33 | Tyvar (ref (Some ty)) => substy isoldty newty ty | 34 | Tycon (t , para) => 35 | Tycon (t , map (substy isoldty newty) para) | 36 | Tyfun (t1 , t2) => 37 | Tyfun (substy isoldty newty t1 , substy isoldty newty t2) | 38 | Typair (t1 , t2) => 39 | Typair (substy isoldty newty t1 , substy isoldty newty t2)| 40 | Tyun (t1 , t2) => 41 | Tyun (substy isoldty newty t1 , substy isoldty newty t2) | 42 | t => t; 43 | 44 | fun genelim newt contys elim result = 45 | let 46 | val V = if elim then Typair (newt , result) else result; 47 | 48 | fun f (t::ts) = Tyfun (substy (fn t => t = newt) V t , f ts) 49 | | f nil = result; 50 | in 51 | Tyfun (newt , fold (fn (t,ts) => Tyfun (f (splitconty t) , ts)) 52 | contys result) 53 | end; 54 | 55 | (* end of GENELIM.SML ************************************************) 56 | 57 | -------------------------------------------------------------------------------- /src/v1/genintro.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* GENINTRO.SML - THE GENERATOR OF THE TYPE OF INTRODUCTORS *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1993. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from TYLAM.SML: *) 11 | (* datatype typex and tyvar *) 12 | (* from GENELIM.SML: *) 13 | (* substy = fn: typex -> (typex -> bool) -> typex -> typex *) 14 | (* Exports: *) 15 | (* genintro = fn: typex -> typex list -> bool -> typex -> *) 16 | (* typex *) 17 | (* *) 18 | (*********************************************************************) 19 | 20 | fun genintro newt contys elim result = 21 | let 22 | val V = if elim then Tyun (newt , result) else result; 23 | in 24 | fold (fn (t,ts) => 25 | Tyfun ((Tyfun (result,substy (fn t => t = newt) V t)),ts)) 26 | contys (Tyfun (result , newt)) 27 | end; 28 | 29 | (* end of GENINTRO.SML ***********************************************) 30 | 31 | -------------------------------------------------------------------------------- /src/v1/gentraco.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* GENTRACON.SML - THE GENERATOR OF THE TRANSLATION OF CONSTRUCTORS *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from ARITHME.SML: *) 11 | (* pred = fn: int -> int *) 12 | (* from EVAL.SML: *) 13 | (* eval = fn: term -> term *) 14 | (* from ITEREC.SML: *) 15 | (* iter = fn: ('st -> 'st) -> 'st -> int -> 'st *) 16 | (* from MONAMON.SML: *) 17 | (* mon = fn: bool -> tyvar ref -> typex -> bool -> term *) 18 | (* splitconty = fn: typex -> typex list *) 19 | (* from TYLAM.SML: *) 20 | (* datatype term and typex and tyvar and tycon *) 21 | (* Exports: *) 22 | (* gentracon = fn: tyvar ref -> tycon ref -> int -> int -> *) 23 | (* typex -> bool -> term *) 24 | (* *) 25 | (*********************************************************************) 26 | 27 | fun gentracon newtref newtycon pos conum conty elim = 28 | let 29 | val conpara = splitconty conty; 30 | val paranum = length conpara; 31 | in 32 | eval 33 | ( iter (fn trm => Lambda trm) 34 | (#2 (revfold 35 | (fn (p , (j,trm)) => 36 | (pred j, 37 | Application 38 | (trm, 39 | Application 40 | (Application 41 | (mon true newtref p elim, 42 | Lambda 43 | ((fn x => if elim 44 | then Pair (Parameter 0 , x) 45 | else x 46 | )(#2 47 | (iter (fn (k , trm) => 48 | (pred k, 49 | Application 50 | (trm , Parameter k) 51 | ) 52 | ) 53 | (conum, 54 | Application 55 | ((if elim 56 | then Recursor 57 | else Iterator) newtycon, 58 | Parameter 0 59 | ) 60 | ) 61 | conum 62 | ) 63 | ) 64 | ) 65 | ), 66 | Parameter j 67 | ) 68 | ) 69 | ) 70 | ) 71 | conpara ( conum + paranum - 1 , Parameter pos ) 72 | ) 73 | ) (conum + paranum) 74 | ) 75 | end; 76 | 77 | (* end of GENTRACON.SML **********************************************) 78 | 79 | -------------------------------------------------------------------------------- /src/v1/gentrade.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* GENTRADES.SML - THE GENERATOR OF THE TRANSLATION OF DESTRUCTORS *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1993. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from ARITHME.SML: *) 11 | (* pred = fn: int -> int *) 12 | (* from EVAL.SML: *) 13 | (* eval = fn: term -> term *) 14 | (* from ITEREC.SML: *) 15 | (* iter = fn: ('st -> 'st) -> 'st -> int -> 'st *) 16 | (* from MONAMON.SML: *) 17 | (* mon = fn: bool -> tyvar ref -> typex -> bool -> term *) 18 | (* from TYLAM.SML: *) 19 | (* datatype term and typex and tyvar and tycon *) 20 | (* Exports: *) 21 | (* gentrades = fn: tyvar ref -> tycon ref -> int -> int -> *) 22 | (* typex -> bool -> term *) 23 | (* *) 24 | (*********************************************************************) 25 | 26 | fun gentrades newtref newtycon pos conum conty elim = eval 27 | (iter 28 | (fn trm => Lambda trm) 29 | (Application 30 | (Application 31 | (mon true newtref conty elim, 32 | (fn x => 33 | if elim 34 | then (Lambda 35 | (Application 36 | (Application 37 | (Application (When , Parameter 0), 38 | (Lambda (Parameter 0)) 39 | ), 40 | nest 1 x 41 | ) 42 | )) 43 | else x 44 | ) 45 | (#2 (iter (fn (k , trm) => (pred k, 46 | Application (trm , Parameter k))) 47 | (conum, 48 | (if elim then Recursor else Iterator) newtycon 49 | ) 50 | conum 51 | ) 52 | ) 53 | ), 54 | Application (Parameter (pos + 1), Parameter 0) 55 | ) 56 | ) 57 | (conum + 1) 58 | ); 59 | 60 | (* end of GENTRADES.SML **********************************************) 61 | 62 | -------------------------------------------------------------------------------- /src/v1/gettype.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* GETTYPE.SML - THE PARSER OF TYPE EXPRESSIONS *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992, 1993. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from LEXICAL.SML: *) 11 | (* datatype symbol *) 12 | (* getsym = fn: unit -> symbol *) 13 | (* nextsym = fn: unit -> unit *) 14 | (* from TYLAM.SML: *) 15 | (* datatype typex and tyvar and tycon *) 16 | (* from TYPARAM.SML: *) 17 | (* abstype typaram with *) 18 | (* findtypar = fn: string -> typaram -> tyvar ref *) 19 | (* checktypar = fn: typaram -> unit *) 20 | (* from ENVIRON.SML: *) 21 | (* abstype environment with *) 22 | (* find_ty = fn: string -> environment -> tycon ref *) 23 | (* Exports: *) 24 | (* gettype = fn: typaram -> environment -> typex -> *) 25 | (* string -> typex *) 26 | (* con Type_expected = - : exn *) 27 | (* *) 28 | (*********************************************************************) 29 | 30 | exception Type_expected; 31 | 32 | fun gettype param env newt newtid = 33 | let 34 | fun gettycon str = 35 | if str = newtid 36 | then ( nextsym() ; checktypar param ; newt ) 37 | else let 38 | val t as ref (Type {varlist=vl,...}) = find_ty str env; 39 | in 40 | nextsym(); 41 | Tycon (t , iter (fn para => para @ 42 | [gettype param env newt newtid]) nil (length vl)) 43 | end; 44 | 45 | fun atomic () = 46 | case getsym() of 47 | Ident' str => ( nextsym() ; Tyvar (findtypar str param) ) | 48 | Identupper str => gettycon str | 49 | Identlower str => gettycon str | 50 | Boolsym => ( nextsym() ; Tybool ) | 51 | Tyunitsym => ( nextsym() ; Tyunit ) | 52 | Absym => ( nextsym() ; Absurd ) | 53 | Left_brace => ( nextsym(); 54 | let 55 | val t = gettype param env newt newtid; 56 | in 57 | if getsym() = Right_brace 58 | then ( nextsym() ; t ) 59 | else raise Right_brace_expected 60 | end 61 | ) | 62 | _ => raise Type_expected; 63 | 64 | fun typair () = 65 | let 66 | fun f t = if getsym() = Star 67 | then ( nextsym() ; f (Typair (t , atomic())) ) 68 | else t 69 | in 70 | f ( atomic() ) 71 | end; 72 | 73 | val ty = 74 | let 75 | fun f t = if getsym() = Plus 76 | then ( nextsym() ; f (Tyun (t , typair())) ) 77 | else t 78 | in 79 | f ( typair() ) 80 | end; 81 | in 82 | if getsym() = Thinarrow 83 | then ( nextsym() ; Tyfun (ty , gettype param env newt newtid) ) 84 | else ty 85 | end; (* gettype *) 86 | 87 | (* end of GETTYPE.SML ************************************************) 88 | 89 | -------------------------------------------------------------------------------- /src/v1/ipl.login: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* LOGIN.SML - EXECUTED AT THE BEGINNING OF THE IPLL SESSION *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from IPLL.SML: *) 11 | (* ipl = fn: unit -> unit *) 12 | (* Exports: none *) 13 | (* *) 14 | (*********************************************************************) 15 | 16 | ipl(); 17 | 18 | (* end of LOGIN.SML **************************************************) 19 | 20 | -------------------------------------------------------------------------------- /src/v1/ipl.sys: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* IPL.SYS - COMPILES THE PROGRAM AND SAVES IT IN A SML STATE FILE *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992, 1993. *) 7 | (* *) 8 | (* Imports: *) 9 | (* ipl_dir = ? : string *) 10 | (* *) 11 | (* Exports: *) 12 | (* ipll_ver = ? : string *) 13 | (* *) 14 | (*********************************************************************) 15 | 16 | val ipll_ver = "ver. 2.0 (13-SEP-1993)"; 17 | 18 | app ( fn filename => use ( filename ^ ".sml" ) ) 19 | [ 20 | "iterec", 21 | "arithme", 22 | "listing", 23 | "source", 24 | "scanner", 25 | "lexical", 26 | "tylam", 27 | "typex", 28 | "lamterm", 29 | "unify", 30 | "typofter", 31 | "eval", 32 | "typinfo", 33 | "environ", 34 | "lampars", 35 | "typaram", 36 | "gettype", 37 | "genelim", 38 | "genintro", 39 | "monamon", 40 | "gentraco", 41 | "gentrade", 42 | "typars", 43 | "cotypars", 44 | "parser", 45 | "ipll" 46 | ]; 47 | 48 | let 49 | val msg = "Welcome to the IPL. Use 'ipl' function in SML and " ^ 50 | "'exit' command in IPL to switch between these two " ^ 51 | "systems."; 52 | in 53 | ExportML ( ipl_dir ^ "/ipl.env" , msg , [ipl_dir ^ "/ipl.login"] ) 54 | end; 55 | 56 | (* end of IPLL.SYS ***************************************************) 57 | 58 | -------------------------------------------------------------------------------- /src/v1/ipll.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* IPLL.SML - THE INFERENTIAL PROGRAMMING LANGUAGE AND LOGIC SYSTEM *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992, 1993. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from ENVIRON.SML: *) 11 | (* abstype environment with *) 12 | (* emptyenv = - : environment *) 13 | (* from LISTING.SML: *) 14 | (* start_output = fn: string -> unit *) 15 | (* stop_output = fn: unit -> unit *) 16 | (* from PARSER.SML: *) 17 | (* parse = fn: string -> environment -> unit *) 18 | (* con Use_error = - : exn *) 19 | (* Exports: *) 20 | (* ipl = fn: unit -> unit *) 21 | (* ipl_clear = fn: unit -> unit *) 22 | (* ipl_env = - : environment ref *) 23 | (* ipl_run = fn: string -> string -> environment -> unit *) 24 | (* *) 25 | (*********************************************************************) 26 | 27 | val ipl_env = ref emptyenv; 28 | 29 | fun ipl_clear () = ipl_env := emptyenv; 30 | 31 | fun ipl_run infile outfile env = 32 | ( start_output outfile; 33 | ( ipl_env := parse infile env handle Use_error => () ); 34 | stop_output() 35 | ); 36 | 37 | fun ipl () = ipl_run "" "" (! ipl_env); 38 | 39 | (* end of IPLL.SML ***************************************************) 40 | 41 | -------------------------------------------------------------------------------- /src/v1/iterec.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* ITEREC.SML - curry/uncurry converters; iterators and recursors *) 5 | (* for cardinals and lists. *) 6 | (* *) 7 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992. *) 8 | (* *) 9 | (* *) 10 | (* Imports: none *) 11 | (* Exports: *) 12 | (* curry = fn: ('a * 'b -> 'c) -> 'a -> 'b -> 'c *) 13 | (* uncurry = fn: ('a -> 'b -> 'c) -> 'a * 'b -> 'c *) 14 | (* con Iter = - : exn *) 15 | (* iter = fn: ('st -> 'st) -> 'st -> int -> 'st *) 16 | (* con Recur = - : exn *) 17 | (* recur = fn: (int -> 'st -> 'st) -> 'st -> int -> 'st *) 18 | (* listiter = fn: 'res -> ('elem -> 'res -> 'res) -> *) 19 | (* 'elem list -> 'res *) 20 | (* listrecur = fn: 'res -> *) 21 | (* ('elem -> 'elem list -> 'res -> 'res) -> *) 22 | (* 'elem list -> 'res *) 23 | (* *) 24 | (*********************************************************************) 25 | 26 | 27 | (******************************* CURRY *******************************) 28 | 29 | fun curry f x y = f (x,y); 30 | fun uncurry f (x,y) = f x y; 31 | 32 | (***************************** CARDINALS *****************************) 33 | 34 | (* 35 | Idea : 36 | fun iter next state 0 = state 37 | | iter next state n = next ( iter next state (n-1) ); 38 | *) 39 | exception Iter; 40 | fun iter next state n = 41 | let 42 | fun f state 0 = state 43 | | f state n = f (next state) (n-1); 44 | in 45 | if n<0 46 | then raise Iter 47 | else f state n 48 | end; 49 | 50 | (* 51 | Idea : 52 | fun recur h g 0 = g 53 | | recur h g n = h n ( recur h g (n-1) ); 54 | *) 55 | exception Recur; 56 | fun recur h g n = 57 | let 58 | fun f x y = if x = n then y else f (x+1) (h x y); 59 | in 60 | if n<0 61 | then raise Recur 62 | else f 0 g 63 | end; 64 | 65 | (******************************* LISTS *******************************) 66 | 67 | (* 68 | Idea : 69 | fun listiter g h nil = g 70 | | listiter g h (x::xs) = h x (listiter g h xs); 71 | *) 72 | fun listiter g h l = 73 | let 74 | fun f (x::xs) acc = f xs (h x acc) 75 | | f nil acc = acc; 76 | in 77 | f (rev l) g 78 | end; 79 | 80 | (* 81 | Idea : 82 | fun listrecur g h nil = g 83 | | listrecur g h (x::xs) = h x xs (listiter g h xs); 84 | *) 85 | fun listrecur g h l = 86 | let 87 | fun f (x::xs) acc = f xs (h x xs acc) 88 | | f nil acc = acc; 89 | in 90 | f (rev l) g 91 | end; 92 | 93 | (* end of ITEREC.SML *************************************************) 94 | 95 | -------------------------------------------------------------------------------- /src/v1/lamterm.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* LAMTERM.SML - TOOLS FOR DEALING WITH LAMBDA TERMS *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992, 1993. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from ARITHME.SML: *) 11 | (* succ = fn: int -> int *) 12 | (* from LISTING.SML: *) 13 | (* out = fn: string -> unit *) 14 | (* from TYLAM.SML: *) 15 | (* datatype term and constr and tycon *) 16 | (* Exports: *) 17 | (* nest = fn: int -> term -> term *) 18 | (* occvar = fn: term -> bool *) 19 | (* freevar = fn: term -> bool *) 20 | (* printerm = fn: int -> term -> unit *) 21 | (* z = ? : int *) 22 | (* *) 23 | (*********************************************************************) 24 | 25 | fun nest n = 26 | let 27 | fun f l (Parameter k) = Parameter (if k >= l then k+n else k) 28 | | f l (Lambda t) = Lambda ( f (succ l) t ) 29 | | f l (Application (t1,t2)) = Application (f l t1 , f l t2) 30 | | f l (Conditional (t1,t2,t3)) = 31 | Conditional (f l t1 , f l t2 , f l t3) 32 | | f l (Equality (t1,t2)) = Equality (f l t1 , f l t2) 33 | | f l (Pair (t1,t2)) = Pair (f l t1 , f l t2) 34 | | f _ t = t; 35 | in 36 | f 0 37 | end; 38 | 39 | local 40 | fun f p l (Parameter n) = p (n,l) 41 | | f p l (Lambda t) = f p (succ l) t 42 | | f p l (Application (t1,t2)) = f p l t1 orelse f p l t2 43 | | f p l (Conditional (t1,t2,t3)) = f p l t1 orelse f p l t2 orelse 44 | f p l t3 45 | | f p l (Equality (t1,t2)) = f p l t1 orelse f p l t2 46 | | f p l (Pair (t1,t2)) = f p l t1 orelse f p l t2 47 | | f _ _ _ = false; 48 | in 49 | val occvar = f op = 0; 50 | val freevar = f op >= 0; 51 | end; 52 | 53 | val z = ord "z"; 54 | 55 | fun printerm level (Parameter n) = out ( chr (z-level+n+1) ) 56 | | printerm _ (Constructor (Constr (ref {name=id,...}))) = out id 57 | | printerm _ (Iterator (ref (Type {name=id,coty=ct,...}))) = 58 | out ("_" ^ id ^ (if ct then "ci" else "it")) 59 | | printerm _ (Recursor (ref (Type {name=id,coty=ct,...}))) = 60 | out ("_" ^ id ^ (if ct then "cr" else "rec")) 61 | | printerm level (trm as Lambda _) = 62 | ( out "fn"; 63 | let 64 | fun param (l , Lambda t) = 65 | ( out ( " " ^ chr (z-l) ) ; param (succ l , t) ) 66 | | param arg = arg; 67 | val (l , t) = param (level , trm); 68 | in 69 | out " => " ; printerm l t 70 | end 71 | ) 72 | | printerm level (Application (rator,rand)) = 73 | ( case rator of 74 | Lambda _ => (out"(" ; printerm level rator ; out")") | 75 | Conditional _ => (out"(" ; printerm level rator ; out")") | 76 | _ => printerm level rator; 77 | out " "; 78 | case rand of 79 | Lambda _ => (out"(" ; printerm level rand ; out")") | 80 | Application _ => (out"(" ; printerm level rand ; out")") | 81 | Conditional _ => (out"(" ; printerm level rand ; out")") | 82 | Equality _ => (out"(" ; printerm level rand ; out")") | 83 | Pair _ => (out"(" ; printerm level rand ; out")") | 84 | _ => printerm level rand 85 | ) 86 | | printerm _ True = out "True" 87 | | printerm _ False = out "False" 88 | | printerm _ Inl = out "Inl" 89 | | printerm _ Inr = out "Inr" 90 | | printerm _ When = out "when" 91 | | printerm _ Case0 = out "case0" 92 | | printerm _ Case1 = out "case1" 93 | | printerm _ Fst = out "fst" 94 | | printerm _ Snd = out "snd" 95 | | printerm _ Unit = out "()" 96 | | printerm level (Conditional (t1,t2,t3)) = 97 | ( out "if "; 98 | printerm level t1; 99 | out " then "; 100 | printerm level t2; 101 | out " else "; 102 | printerm level t3 103 | ) 104 | | printerm level (Equality (t1,t2)) = 105 | ( printerm level t1; 106 | out " = "; 107 | printerm level t2 108 | ) 109 | | printerm level (Pair (t1,t2)) = 110 | ( case t1 of 111 | Lambda _ => (out "(" ; printerm level t1 ; out ")" ) | 112 | Conditional _ => (out "(" ; printerm level t1 ; out ")" ) | 113 | Equality _ => (out "(" ; printerm level t1 ; out ")" ) | 114 | _ => printerm level t1; 115 | out " , "; 116 | case t2 of 117 | Lambda _ => (out "(" ; printerm level t2 ; out ")" ) | 118 | Conditional _ => (out "(" ; printerm level t2 ; out ")" ) | 119 | Equality _ => (out "(" ; printerm level t2 ; out ")" ) | 120 | Pair _ => (out "(" ; printerm level t2 ; out ")" ) | 121 | _ => printerm level t2 122 | ); 123 | 124 | (* end of LAMTERM.SML ************************************************) 125 | 126 | -------------------------------------------------------------------------------- /src/v1/listing.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* LISTING.SML - THE OUTPUT STREAM INTERFACE *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992, 1993. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from IPLL.SYS: *) 11 | (* ipll_ver = ? : string *) 12 | (* Exports: *) 13 | (* type character *) 14 | (* start_output = fn: string -> unit *) 15 | (* stop_output = fn: unit -> unit *) 16 | (* copy = fn: bool -> character -> unit *) 17 | (* out = fn: string -> unit *) 18 | (* prompt = ? : string *) 19 | (* contprompt = ? : string *) 20 | (* *) 21 | (*********************************************************************) 22 | 23 | type character = string; 24 | 25 | val prompt = "+ "; 26 | val contprompt = "= "; 27 | 28 | local 29 | val greeting = "\n\n THE INFERENTIAL PROGRAMMING LANGUAGE " ^ 30 | "INTERPRETER " ^ ipll_ver ^ "\n" ^ 31 | " (c) Technical University of " ^ 32 | "Wroclaw, 1992, 1993\n\n"; 33 | val goodbye = "IPL exit - returning to SML\n\n"; 34 | val stream = ref std_out; 35 | val is_std = ref true; 36 | val newline = ref false; 37 | val copying = ref true; 38 | fun write s = output (! stream , s); 39 | in 40 | fun start_output name = 41 | ( is_std := name = ""; 42 | if ! is_std 43 | then () 44 | else stream := open_out name; 45 | write greeting 46 | ); 47 | 48 | fun stop_output () = 49 | ( write goodbye; 50 | if ! is_std 51 | then () 52 | else ( close_out (! stream) ; stream := std_out ) 53 | ); 54 | 55 | fun copy console (ch : character) = 56 | if console 57 | then 58 | if ! copying 59 | then if ch = "\n" 60 | then write contprompt 61 | else () 62 | else ( if ch = "\n" 63 | then write prompt 64 | else (); 65 | copying := true; 66 | newline := true 67 | ) 68 | else 69 | if ! copying 70 | then ( if ! newline 71 | then ( newline := false ; write contprompt ) 72 | else (); 73 | write ch; 74 | if ch = "\n" 75 | then newline := true 76 | else () 77 | ) 78 | else ( newline := false; 79 | write prompt; 80 | copying := true; 81 | if ch = "\n" 82 | then () 83 | else write ch 84 | ); 85 | 86 | fun out str = 87 | ( (* if ! copying 88 | then write "\n" 89 | else (); *) 90 | copying := false; 91 | newline := true; 92 | write str 93 | ); 94 | end; 95 | 96 | (* end of LISTING.SML ************************************************) 97 | 98 | -------------------------------------------------------------------------------- /src/v1/make-all: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | #make-all: compile IPL sources end export SML environment file 3 | 4 | ###################### edit the following lines ########################## 5 | 6 | #Define here two environment variables: 7 | # IPLBIN: the directory to hold Edinburg SML environment file 8 | # SMLCOMP: ML compliler (usually "sml" or "edml") 9 | # Use whole paths from the root directory! 10 | # Do not move files placed in directory $IPLBIN, rather change this 11 | # variable and recompile the program 12 | IPLBIN=/home/splawski/bin 13 | SMLCOMP="edml" 14 | 15 | #Additional parameter: 16 | # output file for sml listing 17 | RECOMP_LST="recomp.lst" 18 | 19 | ########################################################################## 20 | 21 | echo Started at `date` 22 | 23 | if test -f $IPLBIN/ipl.login 24 | then echo 'ipl.login already copied to '$IPLBIN', OK.' 25 | else echo 'Copying ipl.login to '$IPLBIN 26 | cp ipl.login $IPLBIN/ipl.login 27 | fi 28 | 29 | echo 'Creating file ipl' 30 | echo '#! /bin/sh' > $IPLBIN/ipl 31 | echo '# Run this file to invoke ipl system' >> $IPLBIN/ipl 32 | echo 'FAM=/usr/local/bin/fam' >> $IPLBIN/ipl 33 | echo '$FAM -h 10000 $* '$IPLBIN'/ipl.env' >> $IPLBIN/ipl 34 | chmod 755 $IPLBIN/ipl 35 | 36 | echo 'Compiling IPL sources using '$SMLCOMP 37 | echo 'Output will be redirected to file '$RECOMP_LST 38 | echo 'Be patient -- this will take a while ... (about 1 minute)' 39 | echo 'val ipl_dir="'$IPLBIN'";use"ipl.sys";exit;' | $SMLCOMP >& $RECOMP_LST 40 | 41 | echo Finished at `date` 42 | 43 | echo 'Now edit file '$IPLBIN'/ipl' 44 | -------------------------------------------------------------------------------- /src/v1/scanner.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* SCANNER.SML - FUNCTIONS SCANNING THE TEXT BEFORE LEXICAL ANALYSIS *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from LISTING.SML: *) 11 | (* type character *) 12 | (* from SOURCE.SML: *) 13 | (* eot = fn: unit -> bool *) 14 | (* getchar = fn: unit -> character *) 15 | (* nextchar = fn: unit -> unit *) 16 | (* con EOT = - : exn *) 17 | (* Exports: *) 18 | (* skip = fn: unit -> unit *) 19 | (* comment = fn: unit -> unit *) 20 | (* uppercase = fn: character -> bool *) 21 | (* lowercase = fn: character -> bool *) 22 | (* digit = fn: character -> bool *) 23 | (* getalnum = fn: unit -> string *) 24 | (* getstring = fn: unit -> string *) 25 | (* con EOT_in_comment = - : exn *) 26 | (* con EOT_in_string = - : exn *) 27 | (* *) 28 | (*********************************************************************) 29 | 30 | exception EOT_in_comment and EOT_in_string; 31 | 32 | fun skip () = 33 | let 34 | fun white ch = ch = " " orelse ch = "\t" orelse ch = "\n"; 35 | in 36 | if not ( eot() ) andalso white ( getchar() ) 37 | then ( nextchar() ; skip() ) 38 | else () 39 | end; 40 | 41 | fun comment () = 42 | ( if getchar() = "*" 43 | then ( nextchar(); 44 | if getchar() = ")" 45 | then nextchar() 46 | else comment() 47 | ) 48 | else ( nextchar() ; comment() ) 49 | ) handle EOT => raise EOT_in_comment; 50 | 51 | fun uppercase (ch : character) = ch >= "A" andalso ch <= "Z"; 52 | fun lowercase (ch : character) = ch >= "a" andalso ch <= "z"; 53 | fun digit (ch : character) = ch >= "0" andalso ch <= "9"; 54 | 55 | fun getalnum () = 56 | let 57 | fun alfanum ch = uppercase ch orelse lowercase ch orelse 58 | digit ch orelse ch = "'" orelse ch = "_"; 59 | fun f s = 60 | if not ( eot() ) andalso alfanum ( getchar() ) 61 | then let 62 | val ch = getchar() 63 | in 64 | nextchar(); 65 | f (s ^ ch) 66 | end 67 | else s 68 | in 69 | f "" 70 | end; 71 | 72 | fun getstring () = 73 | let 74 | fun f s = 75 | let 76 | val ch = getchar(); 77 | in 78 | nextchar(); 79 | if ch = "\"" 80 | then s 81 | else f (s ^ ch) 82 | end 83 | handle EOT => raise EOT_in_string; 84 | in 85 | f "" 86 | end; 87 | 88 | (* end of SCANNER.SML ************************************************) 89 | 90 | -------------------------------------------------------------------------------- /src/v1/source.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* SOURCE.SML - THE SOURCE TEXT INTERFACE *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from LISTING.SML: *) 11 | (* type character *) 12 | (* copy = fn: bool -> character -> unit *) 13 | (* prompt = ? : string *) 14 | (* Exports: *) 15 | (* open_text = fn: string -> unit *) 16 | (* close_text = fn: unit -> unit *) 17 | (* eot = fn: unit -> bool *) 18 | (* getchar = fn: unit -> character *) 19 | (* nextchar = fn: unit -> unit *) 20 | (* sweep = fn: unit -> unit *) 21 | (* con EOT = - : exn *) 22 | (* con Source = - : exn *) 23 | (* con SOpen = - : exn *) 24 | (* and standard exception Io may be raised while running theese *) 25 | (* functions *) 26 | (* *) 27 | (*********************************************************************) 28 | 29 | exception EOT and Source and SOpen; 30 | 31 | local 32 | val streams = ref nil; 33 | val snames = ref nil; 34 | val interactive = ref true; 35 | in 36 | fun open_text name = 37 | ( if name = "" 38 | then ( streams := std_in :: (! streams); 39 | out ( "Opening interactive session\n" ^ prompt ) 40 | ) 41 | else ( streams := open_in name :: (! streams); 42 | out ( "Opening " ^ name ^ "\n" ) 43 | ) handle Io _ => raise SOpen; 44 | snames := name :: (! snames); 45 | interactive := name = "" 46 | ); 47 | 48 | fun close_text () = 49 | if ! snames = nil 50 | then raise Source 51 | else 52 | ( if ! interactive 53 | then out "Closing interactive session\n" 54 | else ( out ( "Closing " ^ hd (! snames) ^ "\n" ); 55 | close_in ( hd (! streams) ) 56 | ) handle Io _ => (); 57 | snames := tl (! snames); 58 | streams := tl (! streams); 59 | interactive := ( (! snames) = nil orelse 60 | hd (! snames) = "" 61 | ) 62 | ); 63 | 64 | fun eot () = end_of_stream ( hd (! streams) ) 65 | handle Hd => raise Source; 66 | 67 | fun getchar () : character = 68 | if eot () 69 | then raise EOT 70 | else lookahead ( hd (! streams) ); 71 | 72 | fun nextchar () = 73 | if eot () 74 | then raise EOT 75 | else copy (! interactive) (input (hd (! streams) , 1)); 76 | 77 | fun sweep () = 78 | if ! interactive 79 | then let 80 | fun f () = if getchar() = "\n" 81 | then () 82 | else ( nextchar() ; f() ); 83 | in 84 | f() 85 | end 86 | else (); 87 | end; 88 | 89 | (* end of SOURCE.SML *************************************************) 90 | 91 | -------------------------------------------------------------------------------- /src/v1/tylam.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* TYLAM.SML - THE DEFINITION OF TYPED LAMBDA TERMS *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992, 1993. *) 7 | (* *) 8 | (* *) 9 | (* Imports: none *) 10 | (* Exports: datatype term and typex and tyvar and constr and tycon *) 11 | (* *) 12 | (*********************************************************************) 13 | 14 | datatype term = Parameter of int | 15 | Constructor of constr | 16 | Iterator of tycon ref | 17 | Recursor of tycon ref | 18 | Lambda of term | 19 | Application of term * term | 20 | True | 21 | False | 22 | Conditional of term * term * term | 23 | Equality of term * term | 24 | Pair of term * term | 25 | Fst | 26 | Snd | 27 | Inl | 28 | Inr | 29 | Unit | 30 | When | 31 | Case0 | 32 | Case1 33 | 34 | and typex = Tyvar of tyvar ref | 35 | Tycon of tycon ref * typex list | 36 | Tyfun of typex * typex | 37 | Tybool | 38 | Typair of typex * typex | 39 | Tyun of typex * typex | 40 | Absurd | 41 | Tyunit 42 | 43 | and tyvar = None | 44 | Some of typex | 45 | Label of int 46 | 47 | and constr = Constr of { name : string, 48 | coty : bool, 49 | ty : typex, 50 | trai : term, 51 | trar : term 52 | } ref 53 | 54 | and tycon = Type of { name : string, 55 | induc : bool, 56 | coty : bool, 57 | varlist : tyvar ref list, 58 | typiter : typex, 59 | typrec : typex, 60 | conlist : constr list 61 | } | 62 | Marker; 63 | 64 | (* end of TYLAM.SML **************************************************) 65 | 66 | -------------------------------------------------------------------------------- /src/v1/typaram.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* TYPARAM.SML - TOOLS FOR DEALING WITH TYPE PARAMETERS *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from LEXICAL.SML: *) 11 | (* datatype symbol *) 12 | (* getsym = fn: unit -> symbol *) 13 | (* nextsym = fn: unit -> unit *) 14 | (* from TYLAM.SML: *) 15 | (* datatype tyvar *) 16 | (* Exports: *) 17 | (* con Unknown_type_param = - : exn *) 18 | (* con Bad_typaram = - : exn *) 19 | (* con Typaram_expected = - : exn *) 20 | (* con Unused_typaram = - : exn *) 21 | (* abstype typaram with *) 22 | (* gettypar = fn: unit -> typaram *) 23 | (* findtypar = fn: string -> tyvar ref *) 24 | (* checktypar = fn: typaram -> unit *) 25 | (* mktyvars = fn: typaram -> tyvar ref list *) 26 | (* usedtypar = fn: typaram -> unit *) 27 | (* *) 28 | (*********************************************************************) 29 | 30 | exception Unknown_type_param 31 | and Bad_typaram 32 | and Typaram_expected 33 | and Unused_typaram; 34 | 35 | abstype 36 | typaram = TP of (string * tyvar ref * bool ref) list 37 | with 38 | fun gettypar () = 39 | let 40 | fun f param = 41 | case getsym() of 42 | Ident' str => 43 | ( nextsym(); 44 | f ( param @ [ (str , ref None , ref false) ] ) 45 | ) | 46 | _ => param; 47 | in 48 | nextsym() ; TP (f nil) 49 | end; 50 | 51 | fun findtypar str (TP ((id , tr , u) :: param)) = 52 | if id = str 53 | then (u := true ; tr) 54 | else findtypar str (TP param) 55 | | findtypar _ (TP nil) = raise Unknown_type_param; 56 | 57 | fun checktypar (TP param) = 58 | let 59 | fun f ((id,_,_) :: param) = 60 | ( case getsym() of 61 | Ident' str => if id = str 62 | then ( nextsym() ; f param ) 63 | else raise Bad_typaram | 64 | _ => raise Typaram_expected 65 | ) 66 | | f nil = (); 67 | in 68 | f param 69 | end; 70 | 71 | fun mktyvars (TP param) = map (#2) param; 72 | 73 | fun usedtypar (TP param) = 74 | app (fn (_,_,ref true ) => () | 75 | (_,_,ref false) => raise Unused_typaram) param; 76 | end; (* typaram *) 77 | 78 | (* end of TYPARAM.SML ************************************************) 79 | 80 | -------------------------------------------------------------------------------- /src/v1/typinfo.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* TYPINFO.SML - INFORMATION ABOUT TYPES *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992, 1993. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from LAMTERM.SML: *) 11 | (* nest = fn: int -> term -> term *) 12 | (* printerm = fn: int -> term -> unit *) 13 | (* z = ? : int *) 14 | (* from LISTING.SML: *) 15 | (* out = fn: string -> unit *) 16 | (* from TYLAM.SML: *) 17 | (* datatype term and typex and tyvar and constr and tycon *) 18 | (* from TYPEX.SML: *) 19 | (* numtyvar = fn: typex -> unit *) 20 | (* eratyvar = fn: typex -> unit *) 21 | (* a = ? : int *) 22 | (* printy = fn: typex -> unit *) 23 | (* Exports: *) 24 | (* typinfo = fn: tycon ref -> unit *) 25 | (* *) 26 | (*********************************************************************) 27 | 28 | fun typinfo ( ref (Type {name=id,induc=ic,coty=ct,varlist=vl, 29 | typiter=ti,typrec=tr,conlist=cl}) ) = 30 | let 31 | val conum = length cl; 32 | val varnum = revfold (fn (tr,k) => (tr := Label k;succ k)) vl 0; 33 | val costr = if ct then "co" else ""; 34 | 35 | fun info elim = 36 | let 37 | val eliminator = 38 | costr ^ (if elim then "rec " else "iter "); 39 | val elimname = if ct then (if elim then "cr" else "ci") 40 | else (if elim then "rec" else "it"); 41 | fun f (n , Lambda trm) = f (succ n , trm) 42 | | f x = x; 43 | val prinpar = iter 44 | (fn k => ( out (" " ^ chr (z-k)) ; succ k )) 45 | in 46 | out ( eliminator ^ "_" ^ id ^ elimname ^ " : " ); 47 | printy (if elim then tr else ti) ; out "\n"; 48 | if ct 49 | then 50 | app (fn Constr (ref {name=str,trai=tri,trar=trr,...}) => 51 | let 52 | val (lamnum , trm') = 53 | f (0 , if elim then trr else tri); 54 | val etan = conum+1-lamnum; 55 | val trm = if etan >= 0 56 | then recur (fn n => fn t => Application 57 | (t , Parameter (etan-n-1))) 58 | (nest etan trm') etan 59 | else iter (fn t => Lambda t) trm' (~etan); 60 | in 61 | out ( "comp " ^ str ^ " "); 62 | out ("(_" ^ id ^ elimname); 63 | prinpar 0 (conum+1); 64 | out ") = "; 65 | printerm (conum+1) trm; out "\n" 66 | end 67 | ) cl 68 | else 69 | app ( fn Constr (ref {name=str,trai=tri,trar=trr,...}) => 70 | let 71 | val (lamnum , trm) = 72 | f (0 , if elim then trr else tri); 73 | val argnum = max (lamnum - conum , 0); 74 | in 75 | out ( "comp _" ^ id ^ elimname ^ " " ); 76 | if argnum > 0 77 | then (out ("("^str); 78 | prinpar 0 argnum; 79 | out ")") 80 | else out str; 81 | out " = " ; printerm argnum 82 | (iter (fn t => Lambda t) trm (lamnum-argnum)); 83 | out "\n" 84 | end 85 | ) cl 86 | end; 87 | in 88 | numtyvar ti varnum; 89 | out ( costr ^ "datatype " ^ id ); 90 | iter (fn k => ( out ( " '" ^ chr (a+k) ) ; succ k )) 0 varnum; 91 | out "\n"; 92 | app ( fn Constr (ref {name=str,ty=t,...}) => 93 | ( out ( (if ct then "des " else "con ") ^ str ^ 94 | " : " ) ; printy t ; out "\n" ) 95 | ) cl; 96 | info false; 97 | if ic then info true 98 | else out (costr ^ "rec _" ^ id ^ 99 | (if ct then "cr" else "rec") ^ " = _" ^ id ^ 100 | (if ct then "ci" else "it") ^ "\n"); 101 | eratyvar ti 102 | end; (* typinfo *) 103 | 104 | (* end of TYPINFO.SML ************************************************) 105 | 106 | -------------------------------------------------------------------------------- /src/v1/typofter.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* TYPOFTERM.SML - THE ANALYSER OF TYPES OF LAMBDA TERMS *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992, 1993. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from TYLAM.SML: *) 11 | (* datatype term and typex and tyvar and constr and tycon *) 12 | (* from TYPEX.SML: *) 13 | (* derefer = fn: typex -> typex *) 14 | (* tycopy = fn: typex -> typex *) 15 | (* from UNIFY.SML: *) 16 | (* occurs = fn: tyvar ref -> typex -> unit *) 17 | (* infix unify = fn: typex * typex -> unit *) 18 | (* con Type_mismatch = - : exn *) 19 | (* Exports: *) 20 | (* typofterm = fn: term -> typex *) 21 | (* *) 22 | (*********************************************************************) 23 | 24 | val typofterm = 25 | let 26 | fun f var ( Parameter n ) = nth ( var , n ) 27 | | f _ ( Constructor ( Constr (ref {ty=t,...}) ) ) = tycopy t 28 | | f _ ( Iterator ( ref (Type {typiter=t,...}) ) ) = tycopy t 29 | | f _ ( Recursor ( ref (Type {typrec =t,...}) ) ) = tycopy t 30 | | f var ( Lambda trm ) = 31 | let 32 | val argty = Tyvar (ref None); 33 | in 34 | Tyfun ( argty , f ( argty :: var ) trm ) 35 | end 36 | | f var ( Application (rator,rand) ) = 37 | let 38 | val tyran = derefer (f var rand); 39 | in 40 | case derefer (f var rator) of 41 | Tyfun (t1,t2) => ( t1 unify tyran ; t2 ) | 42 | Tyvar tr => 43 | let 44 | val tyres = Tyvar (ref None); 45 | in 46 | occurs tr tyran; 47 | tr := Some ( Tyfun (tyran , tyres) ); 48 | tyres 49 | end | 50 | _ => raise Type_mismatch 51 | end 52 | | f _ True = Tybool 53 | | f _ False = Tybool 54 | | f _ Unit = Tyunit 55 | | f _ Case0 = Tyfun (Absurd , Tyvar (ref None)) 56 | | f _ Case1 = 57 | let 58 | val tv = Tyvar (ref None); 59 | in 60 | Tyfun (Tyunit , Tyfun (tv , tv)) 61 | end 62 | | f _ When = 63 | let 64 | val lefty = Tyvar (ref None); 65 | val righty = Tyvar (ref None); 66 | val resulty = Tyvar (ref None); 67 | in 68 | Tyfun (Tyun (lefty , righty), 69 | Tyfun (Tyfun (lefty , resulty), 70 | Tyfun (Tyfun (righty , resulty), 71 | resulty 72 | ) 73 | ) 74 | ) 75 | end 76 | | f var Inl = 77 | let 78 | val lefty = Tyvar (ref None) 79 | in 80 | Tyfun (lefty , Tyun (lefty , Tyvar (ref None))) 81 | end 82 | | f var Inr = 83 | let 84 | val righty = Tyvar (ref None) 85 | in 86 | Tyfun (righty , Tyun (Tyvar (ref None) , righty)) 87 | end 88 | | f var ( Conditional (t1,t2,t3) ) = 89 | ( f var t1 unify Tybool; 90 | let 91 | val result = f var t2; 92 | in 93 | result unify f var t3; 94 | result 95 | end 96 | ) 97 | | f var ( Equality (t1,t2) ) = 98 | ( f var t1 unify f var t2 ; Tybool ) 99 | | f var ( Pair (t1,t2) ) = Typair ( f var t1 , f var t2 ) 100 | | f var Fst = let 101 | val tv = Tyvar (ref None); 102 | in 103 | Tyfun ( Typair (tv , Tyvar (ref None)) , tv ) 104 | end 105 | | f var Snd = let 106 | val tv = Tyvar (ref None); 107 | in 108 | Tyfun ( Typair (Tyvar (ref None) , tv) , tv ) 109 | end; 110 | in 111 | f nil 112 | end; 113 | 114 | (* end of TYPOFTERM.SML **********************************************) 115 | 116 | -------------------------------------------------------------------------------- /src/v1/unify.sml: -------------------------------------------------------------------------------- 1 | 2 | (*********************************************************************) 3 | (* *) 4 | (* UNIFY.SML - THE TYPE UNIFICATION ALGORITHM *) 5 | (* *) 6 | (* Programmed in Standard ML by Tomasz Wierzbicki, 1992, 1993. *) 7 | (* *) 8 | (* *) 9 | (* Imports: *) 10 | (* from TYLAM.SML: *) 11 | (* datatype typex and tyvar *) 12 | (* from TYPEX.SML: *) 13 | (* derefer = fn: typex -> typex *) 14 | (* Exports: *) 15 | (* occurs = fn: tyvar ref -> typex -> unit *) 16 | (* infix unify = fn: typex * typex -> unit *) 17 | (* con Infinite_type = - : exn *) 18 | (* con Type_mismatch = - : exn *) 19 | (* *) 20 | (*********************************************************************) 21 | 22 | exception Infinite_type and Type_mismatch; 23 | 24 | fun occurs tr ( Tyvar (tr' as ref None) ) = if tr = tr' 25 | then raise Infinite_type 26 | else () 27 | | occurs tr ( Tyvar ( ref (Some ty) ) ) = occurs tr ty 28 | | occurs tr ( Tycon (_,para) ) = app (occurs tr) para 29 | | occurs tr ( Tyfun (t1,t2) ) = ( occurs tr t1 ; occurs tr t2 ) 30 | | occurs tr ( Typair (t1,t2) ) = ( occurs tr t1 ; occurs tr t2 ) 31 | | occurs tr ( Tyun (t1,t2) ) = ( occurs tr t1 ; occurs tr t2 ) 32 | | occurs _ _ = (); 33 | 34 | infix unify; 35 | fun ( Tyvar (tr as ref None) ) unify t = 36 | let 37 | val t' = derefer t; 38 | in 39 | case t' of 40 | Tyvar tr' => if tr = tr' 41 | then () 42 | else tr := Some t' | 43 | _ => ( occurs tr t' ; tr := Some t' ) 44 | end 45 | | ( Tyvar ( tr as ref (Some ty) ) ) unify t = ty unify t 46 | | t unify ( t' as Tyvar _ ) = t' unify t 47 | | ( Tycon (t , para) ) unify ( Tycon (t' , para') ) = 48 | if t <> t' 49 | then raise Type_mismatch 50 | else let 51 | fun f (t::ts) (t'::ts') = ( t unify t' ; f ts ts' ) 52 | | f nil nil = (); 53 | in 54 | f para para' 55 | end 56 | | ( Tyfun (t1,t2) ) unify ( Tyfun (t1',t2') ) = 57 | ( t1 unify t1' ; t2 unify t2' ) 58 | | Tybool unify Tybool = () 59 | | Tyunit unify Tyunit = () 60 | | Absurd unify Absurd = () 61 | | ( Typair (t1,t2) ) unify ( Typair (t1',t2') ) = 62 | ( t1 unify t1' ; t2 unify t2' ) 63 | | ( Tyun (t1,t2) ) unify ( Tyun (t1',t2') ) = 64 | ( t1 unify t1' ; t2 unify t2' ) 65 | | _ unify _ = raise Type_mismatch; 66 | 67 | (* end of UNIFY.SML **************************************************) 68 | 69 | -------------------------------------------------------------------------------- /src/v2/README: -------------------------------------------------------------------------------- 1 | Installation instructions for ET 2 | 3 | All needed files should be copied from floppy disk to directory choosed 4 | for installation (eg. C:\et for Windows or /usr/local/et for Unix). 5 | 6 | 1. Quick Windows installation. 7 | ------------------------------ 8 | For installation of binary version of ET on Microsoft Windows run file 9 | etwin.exe which is self-extracting archive. 10 | 11 | Run command et to start ET system. 12 | 13 | 2. Quick Linux installation. 14 | ---------------------------- 15 | For installation of binary version of ET on Linux extract compressed tar 16 | file etlin.tgz using command 17 | %tar xzf etlin.tgz 18 | 19 | Run command et to start ET system. 20 | 21 | (File run.x86-linux is dynamically linked with libc5. If you have system 22 | with glibc you should use file run.x86-linux from sml distribution, or 23 | install needed libraries). 24 | 25 | 3. Compilation from sources. 26 | ---------------------------- 27 | Unpack sources using command 28 | %tar xf etsrc.tar 29 | 30 | If you have installed sml with Compilation Manager (sml-cm) run command 31 | %sml-cm 32 | and (in sml) start compilation by 33 | - CM.make(); 34 | then use 35 | - use "etMake.sml"; 36 | to generate heap with compiled version of ET (et.name_of_your_system). 37 | 38 | If don't have sml with Compilation Manager run command 39 | %sml 40 | and compile ET by 41 | - use "et.sml"; use "etMake.sml"; 42 | 43 | You should find file run.name_of_your_system in sml installation. 44 | To run ET you have to run this file with argument 45 | @SMLload=et.name_of_your_system. 46 | 47 | These are examples: 48 | - for Linux: 49 | ./run.x86-linux @SMLload=et.x86-linux 50 | 51 | - for Windows: 52 | run.x86-win32.exe @SMLload=et.x86-win32 53 | -------------------------------------------------------------------------------- /src/v2/compiler/etUnifier.sml: -------------------------------------------------------------------------------- 1 | signature etUNIFIER = 2 | sig 3 | structure AbsSyn : etABSTRACTSYNTAX 4 | 5 | structure Env : etENVIRONMENT 6 | 7 | datatype DisPair = 8 | DPair of AbsSyn.etType * AbsSyn.etType | Pi 9 | 10 | type Substitution 11 | 12 | exception Fail 13 | 14 | val SId : Substitution 15 | val addS : Substitution -> AbsSyn.etType * AbsSyn.etType -> Substitution 16 | val addLtoS : Substitution -> 17 | (AbsSyn.etType * AbsSyn.etType) list -> Substitution 18 | val addStoS : Substitution -> Substitution -> Substitution 19 | val appS : Substitution -> AbsSyn.etType -> AbsSyn.etType 20 | val appStoEnv : Substitution -> Env.Env -> Env.Env 21 | 22 | val unify : (AbsSyn.etType * AbsSyn.etType) list -> Substitution 23 | end 24 | 25 | functor etUnifierFun (structure AbsSyn : etABSTRACTSYNTAX 26 | structure Env : etENVIRONMENT 27 | sharing AbsSyn = Env.AbsSyn):etUNIFIER = 28 | struct 29 | 30 | structure AbsSyn = AbsSyn 31 | 32 | structure Env = Env 33 | 34 | datatype DisPair = Pi | DPair of AbsSyn.etType * AbsSyn.etType 35 | 36 | type Substitution = (AbsSyn.etType * AbsSyn.etType) list 37 | 38 | val SId = nil 39 | 40 | local 41 | fun app ((v,e)::tl) t = if t=v then e else app tl t 42 | | app nil t = t 43 | in 44 | fun appS sub (tv as AbsSyn.TypeVar i) = app sub tv 45 | | appS sub (AbsSyn.TypeApp (i,lt)) = AbsSyn.TypeApp (i,map (appS sub) lt) 46 | end 47 | 48 | fun addS sub (p as (v,e)) = let 49 | val s = map (fn (a,b) => (a,appS [p] b)) sub 50 | in 51 | (v,appS s e)::s 52 | end 53 | fun addLtoS sub l = List.foldr (fn (a,b) => addS b a) sub l 54 | fun addStoS sub l = List.foldr (fn (a,b) => addS b a) sub l 55 | 56 | exception Fail; 57 | 58 | local 59 | fun D (z as (AbsSyn.TypeVar i1,AbsSyn.TypeVar i2)) = 60 | if i1=i2 then Pi else DPair z 61 | | D (z as (AbsSyn.TypeApp (i1,lt1),AbsSyn.TypeApp (i2,lt2))) = 62 | if (i1=i2) andalso (length lt1 = length lt2) then 63 | D' (ListPair.zip (lt1,lt2)) 64 | else DPair z 65 | | D p = DPair p 66 | and D' [t as (t1,t2)] = D t 67 | | D' ((t as (t1,t2))::tail) = let val d = (D t) 68 | in 69 | if d = Pi then D'(tail) else d 70 | end 71 | | D' [] = Pi 72 | 73 | fun U S (l as ((e,e')::t)) = 74 | let 75 | val se = appS S e 76 | val se' = appS S e' 77 | in 78 | if se = se' then U S t 79 | else let 80 | val (u,v)=(fn DPair a => a 81 | | Pi => raise etTools.InternalError "Error in unifier") 82 | (D (se,se')) 83 | in 84 | if AbsSyn.notTypeVarIn u v then U (addS S (u,v)) l 85 | else 86 | if AbsSyn.notTypeVarIn v u then U (addS S (v,u)) l 87 | else raise Fail 88 | end 89 | end 90 | | U S nil = S 91 | in 92 | fun unify el =U SId el 93 | end 94 | 95 | fun appStoEnv subs env = Env.appFunToEnv env 96 | (fn (a,b,c,t) => (a,b,c,appS subs t)) 97 | end 98 | 99 | structure etUnifier = etUnifierFun (structure AbsSyn = etAbstractSyntax 100 | structure Env = etEnvironment) 101 | -------------------------------------------------------------------------------- /src/v2/compiler/sources.cm: -------------------------------------------------------------------------------- 1 | Group 2 | signature etELAB 3 | signature etPRETTYPRINT 4 | signature etEVAL 5 | signature etENVIRONMENT 6 | structure etElab 7 | structure etPrettyPrint 8 | structure etEval 9 | structure etEnvironment 10 | is 11 | ../parser/sources.cm 12 | ../tools/sources.cm 13 | ../syntax/sources.cm 14 | etUnifier.sml 15 | etElab.sml 16 | -------------------------------------------------------------------------------- /src/v2/et.sml: -------------------------------------------------------------------------------- 1 | use "parser/ml-yacc/base.sig"; 2 | use "parser/ml-yacc/join.sml"; 3 | use "parser/ml-yacc/lrtable.sml"; 4 | use "parser/ml-yacc/stream.sml"; 5 | use "parser/ml-yacc/parser1.sml"; 6 | use "tools/int-inf-sig.sml"; 7 | use "tools/int-inf.sml"; 8 | use "parser/etLexPos.sml"; 9 | use "parser/etFromParser.sml"; 10 | use "parser/et.grm.sig"; 11 | use "parser/et.grm.sml"; 12 | use "parser/et.lex.sml"; 13 | use "parser/etParser.sml"; 14 | use "syntax/etAbstractSyntax.sml"; 15 | use "syntax/etEnvironment.sml"; 16 | use "syntax/etEval.sml"; 17 | use "syntax/etPrettyPrint.sml"; 18 | use "tools/etTools.sml"; 19 | use "compiler/etUnifier.sml"; 20 | use "compiler/etElab.sml"; 21 | use "etMain.sml"; 22 | -------------------------------------------------------------------------------- /src/v2/etMake.sml: -------------------------------------------------------------------------------- 1 | SMLofNJ.exportFn ("et",fn _ => ( 2 | print 3 | " ET interpreter ver 0.3 (September 1998)\n\ 4 | \ Computer Science Department\n\ 5 | \ Wroclaw University of Technology, Poland\n"; 6 | et.fromStdIn et.env;OS.Process.success)); 7 | -------------------------------------------------------------------------------- /src/v2/etcm.sml: -------------------------------------------------------------------------------- 1 | local open Compiler.CMSA val pervenv = pervenv () 2 | val o3 = run ("parser/ml-yacc/base.sig", pervenv) 3 | val d0 = layer [o3, pervenv] 4 | val o4 = run ("parser/ml-yacc/join.sml", d0) 5 | val f0 = filter [SIG "ARG_LEXER", STR "Stream", SIG "TOKEN", SIG "LEXER", SIG "ARG_PARSER", SIG "PARSER", FCT "Join", SIG "PARSER_DATA", SIG "LR_PARSER", STR "LrTable", FCT "JoinWithArg", SIG "LR_TABLE", STR "LrParser", SIG "STREAM"] 6 | val d1 = f0 o4 7 | val o5 = run ("parser/ml-yacc/lrtable.sml", d0) 8 | val o6 = run ("parser/ml-yacc/stream.sml", d0) 9 | val d2 = layer [o3, o5, o6, pervenv] 10 | val o7 = run ("parser/ml-yacc/parser1.sml", d2) 11 | val d3 = f0 o7 12 | val o0 = run ("tools/int-inf-sig.sml", pervenv) 13 | val d4 = layer [o0, pervenv] 14 | val o1 = run ("tools/int-inf.sml", d4) 15 | val f1 = filter [SIG "INT_INF", STR "IntInf", STR "etTools"] 16 | val d5 = f1 o1 17 | val o8 = run ("parser/etLexPos.sml", pervenv) 18 | val d6 = layer [o8, d5, pervenv] 19 | val o9 = run ("parser/etFromParser.sml", d6) 20 | val d7 = f0 o3 21 | val d8 = layer [d5, d7, pervenv] 22 | val o10 = run ("parser/et.grm.sig", d8) 23 | val d9 = layer [o9, o10, d5, d7, pervenv] 24 | val o11 = run ("parser/et.grm.sml", d9) 25 | val d10 = layer [o8, o10, d5, pervenv] 26 | val o12 = run ("parser/et.lex.sml", d10) 27 | val d11 = layer [o9, o11, o12, d1, d3, pervenv] 28 | val o13 = run ("parser/etParser.sml", d11) 29 | val f2 = filter [FCT "etParserFun", STR "etLexPosition", STR "etFromParser", SIG "etPARSER", SIG "etFROMPARSER", SIG "etLEXPOSITION", FCT "etFromParserFun", STR "etParser"] 30 | val d12 = f2 o13 31 | val o14 = run ("syntax/etAbstractSyntax.sml", pervenv) 32 | val d13 = layer [o14, pervenv] 33 | val o15 = run ("syntax/etEnvironment.sml", d13) 34 | val f3 = filter [SIG "etPRETTYPRINT", SIG "etEVAL", STR "etEnvironment", SIG "etENVIRONMENT", STR "etEval", STR "etPrettyPrint"] 35 | val d14 = f3 o15 36 | val d15 = layer [o14, o15, d5, pervenv] 37 | val o16 = run ("syntax/etEval.sml", d15) 38 | val d16 = f3 o16 39 | val d17 = layer [o14, o15, o16, d5, pervenv] 40 | val o17 = run ("syntax/etPrettyPrint.sml", d17) 41 | val d18 = f3 o17 42 | val d19 = f2 o9 43 | val f4 = filter [SIG "etPRETTYPRINT", STR "etAbstractSyntax", SIG "etEVAL", STR "etEnvironment", SIG "etENVIRONMENT", STR "etEval", SIG "etABSTRACTSYNTAX", STR "etPrettyPrint"] 44 | val d20 = f4 o14 45 | val d21 = f4 o15 46 | val o2 = run ("tools/etTools.sml", pervenv) 47 | val d22 = f1 o2 48 | val d23 = layer [d22, d20, d21, pervenv] 49 | val o18 = run ("compiler/etUnifier.sml", d23) 50 | val d24 = layer [o18, d5, d19, d20, d21, pervenv] 51 | val o19 = run ("compiler/etElab.sml", d24) 52 | val f5 = filter [SIG "etPRETTYPRINT", SIG "etEVAL", STR "etEnvironment", SIG "etENVIRONMENT", STR "etEval", SIG "etELAB", STR "etElab", STR "etPrettyPrint"] 53 | val d25 = f5 o19 54 | val d26 = layer [d12, d14, d16, d18, d25, pervenv] 55 | val o20 = run ("etMain.sml", d26) 56 | val f6 = filter [SIG "ET", STR "et"] 57 | val d27 = f6 o20 58 | in val _ = register d27 end 59 | -------------------------------------------------------------------------------- /src/v2/lib.et: -------------------------------------------------------------------------------- 1 | (* przykład 1 *) 2 | val term = fn x y z => (fn v => x z v) (y z); 3 | 4 | (* przykład 2 *) 5 | val proof = fn a => when a (fn x => Inl (fst x),Inl (snd x)) 6 | (fn y => Inr (fst y),Inr (snd y)); 7 | 8 | (* przykład 3 *) 9 | val ifZero = fn n a b => _NATit n (fn x =>b) a; 10 | 11 | val le = fn u => _NATit u (fn y v => ifZero v False (y (pred v))) 12 | (fn v => True); 13 | 14 | (* przykład 4*) 15 | datatype LIST 'a = Cons from 'a LIST 'a | Nil; 16 | 17 | val append = fn list => _LISTit list Cons; 18 | 19 | val map = 20 | fn fun list => _LISTit list (fn head tail => Cons (fun head) tail) Nil; 21 | 22 | (* przykład 5 *) 23 | codatatype STREAM 'a = Shd to 'a & Stl to STREAM 'a; 24 | 25 | val smap = fn fun str => _STREAMci (fn x=> fun (Shd x)) Stl str; 26 | 27 | val natstr = _STREAMci (fn x => x) Suc ; 28 | 29 | val getNth = fn stream number => Shd (_NATit number Stl stream); 30 | 31 | (* przykład 6 *) 32 | datatype TOWER = Source | Dest | Aux; 33 | 34 | val mkMove = fn from_ to_ => (from_,to_); 35 | 36 | val subTower = fn s d a tower => _TOWERit tower s d a; 37 | 38 | val appSubToList = fn sub list => _LISTit list 39 | (fn m => Cons (mkMove (sub (fst m)) (sub (snd m)))) Nil; 40 | 41 | val hanoi = fn number => _NATit number 42 | (fn x => append (appSubToList (subTower Source Aux Dest) x) 43 | (Cons (mkMove Source Dest) 44 | (appSubToList (subTower Aux Dest Source) x))) Nil; 45 | 46 | val hanoiStream = _STREAMci (fn x => x) 47 | (fn x => append (appSubToList (subTower Source Aux Dest) x) 48 | (Cons (mkMove Source Dest) 49 | (appSubToList (subTower Aux Dest Source) x))) 50 | Nil; 51 | 52 | (* przykład 7 *) 53 | val add1 = fn m => _NATit m (fn x y => Suc (x y)) (fn n => n); 54 | 55 | val prz = fn x n => Suc (x n); 56 | 57 | fn m => add (Suc m) = prz (add m); 58 | fn m => add1 (Suc m) = prz (add1 m); 59 | -------------------------------------------------------------------------------- /src/v2/p1.et: -------------------------------------------------------------------------------- 1 | (* przykład 1 *) 2 | val term = fn x y z => (fn v => x z v) (y z); 3 | -------------------------------------------------------------------------------- /src/v2/p2.et: -------------------------------------------------------------------------------- 1 | (* przykład 2 *) 2 | val proof = fn a => when a (fn x => Inl (fst x),Inl (snd x)) 3 | (fn y => Inr (fst y),Inr (snd y)); 4 | -------------------------------------------------------------------------------- /src/v2/p3.et: -------------------------------------------------------------------------------- 1 | (* przykład 3 *) 2 | val ifZero = fn n a b => _NATit n (fn x =>b) a; 3 | 4 | val le = fn u => _NATit u (fn y v => ifZero v False (y (pred v))) 5 | (fn v => True); 6 | -------------------------------------------------------------------------------- /src/v2/p4.et: -------------------------------------------------------------------------------- 1 | (* przykład 4*) 2 | datatype LIST 'a = Cons from 'a LIST 'a | Nil; 3 | 4 | val append = fn list => _LISTit list Cons; 5 | 6 | val map = 7 | fn fun list => _LISTit list (fn head tail => Cons (fun head) tail) Nil; 8 | -------------------------------------------------------------------------------- /src/v2/p5.et: -------------------------------------------------------------------------------- 1 | (* przykład 5 *) 2 | codatatype STREAM 'a = Shd to 'a & Stl to STREAM 'a; 3 | 4 | val smap = fn fun str => _STREAMci (fn x=> fun (Shd x)) Stl str; 5 | 6 | val natstr = _STREAMci (fn x => x) Suc ; 7 | 8 | val getNth = fn stream number => Shd (_NATit number Stl stream); 9 | -------------------------------------------------------------------------------- /src/v2/p6.et: -------------------------------------------------------------------------------- 1 | (* przykład 6 *) 2 | datatype TOWER = Source | Dest | Aux; 3 | 4 | val mkMove = fn from_ to_ => (from_,to_); 5 | 6 | val subTower = fn s d a tower => _TOWERit tower s d a; 7 | 8 | val appSubToList = fn sub list => _LISTit list 9 | (fn m => Cons (mkMove (sub (fst m)) (sub (snd m)))) Nil; 10 | 11 | val hanoi = fn number => _NATit number 12 | (fn x => append (appSubToList (subTower Source Aux Dest) x) 13 | (Cons (mkMove Source Dest) 14 | (appSubToList (subTower Aux Dest Source) x))) Nil; 15 | 16 | val hanoiStream = _STREAMci (fn x => x) 17 | (fn x => append (appSubToList (subTower Source Aux Dest) x) 18 | (Cons (mkMove Source Dest) 19 | (appSubToList (subTower Aux Dest Source) x))) 20 | Nil; 21 | -------------------------------------------------------------------------------- /src/v2/p7.et: -------------------------------------------------------------------------------- 1 | (* przykład 7 *) 2 | val add1 = fn m => _NATit m (fn x y => Suc (x y)) (fn n => n); 3 | 4 | val prz = fn x n => Suc (x n); 5 | 6 | fn m => add (Suc m) = prz (add m); 7 | fn m => add1 (Suc m) = prz (add1 m); 8 | -------------------------------------------------------------------------------- /src/v2/parser/et.lex: -------------------------------------------------------------------------------- 1 | (* this is lexfile for et *) 2 | type pos = LexPosition.Position 3 | type svalue = Tokens.svalue 4 | type ('a,'b) token = ('a,'b) Tokens.token 5 | type arg = LexPosition.Position ref * bool ref 6 | 7 | type lexresult = (svalue,LexPosition.Position) token 8 | fun eof (currPos,_) = Tokens.Eof (!currPos,!currPos) 9 | 10 | exception LexError of string * LexPosition.Position * LexPosition.Position 11 | 12 | fun whitesp yytext currPos duringParsing lex = 13 | let 14 | val cPos = !currPos 15 | val nPos =LexPosition.addText cPos yytext 16 | in 17 | (currPos:=nPos;lex (currPos,duringParsing) ()) 18 | end 19 | 20 | fun newline yytext currPos duringParsing lex = 21 | let 22 | val cPos = !currPos 23 | val nPos =LexPosition.newLine cPos 24 | in 25 | (currPos:=nPos;lex (currPos,duringParsing) ()) 26 | end 27 | 28 | fun makeToken token yytext currPos duringParsing= 29 | let 30 | val cPos = !currPos 31 | val nPos =LexPosition.addText cPos yytext 32 | in 33 | (duringParsing:=true;currPos:=nPos;token (cPos,nPos)) 34 | end 35 | 36 | fun makeValToken token value yytext currPos duringParsing= 37 | let 38 | val cPos = !currPos 39 | val nPos =LexPosition.addText cPos yytext 40 | in 41 | (duringParsing:=true;currPos:=nPos;token (value, cPos, nPos)) 42 | end 43 | 44 | fun makeError yytext currPos _= 45 | let 46 | val cPos = !currPos 47 | val nPos =LexPosition.addText cPos yytext 48 | in 49 | (currPos:=nPos;raise LexError (yytext,cPos,nPos)) 50 | end 51 | %% 52 | %header (functor etLexFun(structure Tokens:et_TOKENS 53 | structure LexPosition:etLEXPOSITION)); 54 | 55 | %arg (currPos:LexPosition.Position ref,duringParsing:bool ref); 56 | 57 | WhiteSpaces = [\ \t\013\012]+; 58 | NewLine = \n; 59 | Digit = [0-9]; 60 | LowerCase = [a-z]; 61 | UpperCase = [A-Z]; 62 | Letter = {UpperCase} | {LowerCase}; 63 | Alphanum = ({Letter} | {Digit} | [_'])*; 64 | DatatypeCons = {Letter} {Alphanum}; 65 | LowerIdent = {LowerCase} {Alphanum}; 66 | UpperIdent = {UpperCase} {Alphanum}; 67 | Iterator = _ {DatatypeCons} "it"; 68 | Recursor = _ {DatatypeCons} "rec"; 69 | Coiterator = _ {DatatypeCons} "ci"; 70 | Corecursor = _ {DatatypeCons} "cr"; 71 | TypeVar = ' {Alphanum}; 72 | %% 73 | {WhiteSpaces} => (whitesp yytext currPos duringParsing lex); 74 | {NewLine} => (newline yytext currPos duringParsing lex); 75 | "fn" => (makeToken Tokens.Fn yytext currPos duringParsing); 76 | "val" => (makeToken Tokens.Val yytext currPos duringParsing); 77 | "let" => (makeToken Tokens.Let yytext currPos duringParsing); 78 | "in" => (makeToken Tokens.In yytext currPos duringParsing); 79 | "end" => (makeToken Tokens.End yytext currPos duringParsing); 80 | "datatype" => (makeToken Tokens.Datatype yytext currPos duringParsing); 81 | "from" => (makeToken Tokens.From yytext currPos duringParsing); 82 | "codatatype" => (makeToken Tokens.Codatatype yytext currPos duringParsing); 83 | "to" => (makeToken Tokens.To yytext currPos duringParsing); 84 | \( => (makeToken Tokens.LeftParen yytext currPos duringParsing); 85 | \) => (makeToken Tokens.RightParen yytext currPos duringParsing); 86 | "=>" => (makeToken Tokens.DArrow yytext currPos duringParsing); 87 | , => (makeToken Tokens.Colon yytext currPos duringParsing); 88 | \= => (makeToken Tokens.Equals yytext currPos duringParsing); 89 | \; => (makeToken Tokens.Semicolon yytext currPos duringParsing); 90 | \| => (makeToken Tokens.Bar yytext currPos duringParsing); 91 | & => (makeToken Tokens.Ampersand yytext currPos duringParsing); 92 | \* => (makeToken Tokens.Star yytext currPos duringParsing); 93 | \+ => (makeToken Tokens.Plus yytext currPos duringParsing); 94 | "->" => (makeToken Tokens.Arrow yytext currPos duringParsing); 95 | "if" => (makeToken Tokens.If yytext currPos duringParsing); 96 | "then" => (makeToken Tokens.Then yytext currPos duringParsing); 97 | "else" => (makeToken Tokens.Else yytext currPos duringParsing); 98 | "use" => (makeToken Tokens.Use yytext currPos duringParsing); 99 | "exit" => (makeToken Tokens.Exit yytext currPos duringParsing); 100 | "show" => (makeToken Tokens.Show yytext currPos duringParsing); 101 | "norm" => (makeToken Tokens.Norm yytext currPos duringParsing); 102 | {Digit}+ => (makeValToken Tokens.Number 103 | ((fn SOME a => a | NONE => IntInf.fromInt 0) 104 | (IntInf.fromString yytext)) 105 | yytext currPos duringParsing); 106 | "()" => (makeToken Tokens.LRParen yytext currPos duringParsing); 107 | "{}" => (makeToken Tokens.LRBrace yytext currPos duringParsing); 108 | \"[^"]*\" => (makeValToken Tokens.Str yytext yytext currPos duringParsing); 109 | "(*"(((([^*]\))*)|([^\)]*))*)"*)" => 110 | (whitesp yytext currPos duringParsing lex); 111 | {UpperIdent} => (makeValToken Tokens.UpperIdent yytext yytext 112 | currPos duringParsing); 113 | {LowerIdent} => (makeValToken Tokens.LowerIdent yytext yytext 114 | currPos duringParsing); 115 | {TypeVar} => (makeValToken Tokens.TypeVar yytext yytext 116 | currPos duringParsing); 117 | {Iterator} => (makeValToken Tokens.Iterator yytext yytext 118 | currPos duringParsing); 119 | {Recursor} => (makeValToken Tokens.Recursor yytext yytext 120 | currPos duringParsing); 121 | {Coiterator} => (makeValToken Tokens.Coiterator yytext yytext 122 | currPos duringParsing); 123 | {Corecursor} => (makeValToken Tokens.Corecursor yytext yytext 124 | currPos duringParsing); 125 | . => (makeError yytext currPos duringParsing); 126 | -------------------------------------------------------------------------------- /src/v2/parser/etFromParser.sml: -------------------------------------------------------------------------------- 1 | signature etFROMPARSER= 2 | sig 3 | structure Position : etLEXPOSITION 4 | 5 | type LRPos 6 | 7 | type String = string * LRPos 8 | 9 | datatype etTerm = 10 | Let of (etValBinding list * etTerm) * LRPos 11 | | Fn of (String list * etTerm ) * LRPos 12 | | Ident of string * LRPos 13 | | App of (etTerm * etTerm) * LRPos 14 | | Number of (IntInf.int) * LRPos 15 | and etValBinding = 16 | Val of (String * etTerm) * LRPos 17 | 18 | datatype etType = 19 | TypeVar of string * LRPos 20 | | TypeApp of (String * etType list) * LRPos 21 | 22 | datatype etDeclaration = 23 | LexerError of string * LRPos 24 | | ParserError of string * LRPos 25 | | Eof of unit * LRPos 26 | | Command of (string * string) * LRPos 27 | | Norm of (etTerm) * LRPos 28 | | Empty of unit * LRPos 29 | | Term of etTerm * LRPos 30 | | ValBind of etValBinding * LRPos 31 | | DatatypeDef 32 | of (String * (String list) * (String * etType list) list) * LRPos 33 | | CodatatypeDef 34 | of (String * (String list) * (String * etType list) list) * LRPos 35 | 36 | val mkLRPos : Position.Position -> Position.Position -> LRPos 37 | val mkTermWithPos : ('a * LRPos -> 'b ) -> 'a -> Position.Position 38 | -> Position.Position -> 'b 39 | val getTerm : 'a * LRPos -> 'a 40 | val getLeftPos : 'a * LRPos -> Position.Position 41 | val getRightPos : 'a * LRPos -> Position.Position 42 | end 43 | 44 | functor etFromParserFun (structure Position:etLEXPOSITION) : etFROMPARSER = 45 | struct 46 | structure Position = Position 47 | 48 | type LRPos = (Position.Position * Position.Position) 49 | 50 | type String = string * LRPos 51 | 52 | datatype etTerm = 53 | Let of (etValBinding list * etTerm) * LRPos 54 | | Fn of (String list * etTerm ) * LRPos 55 | | Ident of string * LRPos 56 | | App of (etTerm * etTerm) * LRPos 57 | | Number of (IntInf.int) * LRPos 58 | and etValBinding = 59 | Val of (String * etTerm) * LRPos 60 | 61 | datatype etType = 62 | TypeVar of string * LRPos 63 | | TypeApp of (String * etType list) * LRPos 64 | 65 | datatype etDeclaration = 66 | LexerError of string * LRPos 67 | | ParserError of string * LRPos 68 | | Eof of unit * LRPos 69 | | Command of (string * string) * LRPos 70 | | Norm of (etTerm) * LRPos 71 | | Empty of unit * LRPos 72 | | Term of etTerm * LRPos 73 | | ValBind of etValBinding * LRPos 74 | | DatatypeDef 75 | of (String * (String list) * (String * etType list) list) * LRPos 76 | | CodatatypeDef 77 | of (String * (String list) * (String * etType list) list) * LRPos 78 | 79 | fun mkLRPos lpos rpos = (lpos,rpos) 80 | fun mkTermWithPos cons t lpos rpos = cons (t,mkLRPos lpos rpos) 81 | fun getTerm (t,(lpos,rpos)) = t 82 | fun getLeftPos (t,(lpos,rpos)) = lpos 83 | fun getRightPos (t,(lpos,rpos)) = rpos 84 | end 85 | 86 | structure etFromParser = etFromParserFun(structure Position=etLexPosition) 87 | -------------------------------------------------------------------------------- /src/v2/parser/etLexPos.sml: -------------------------------------------------------------------------------- 1 | signature etLEXPOSITION = 2 | sig 3 | type Position 4 | val startPos : Position 5 | val startPosFile : string -> Position 6 | val newLine : Position -> Position 7 | val addText : Position -> string -> Position 8 | val getFile : Position -> string 9 | val getLine : Position -> int 10 | val getColumn : Position -> int 11 | val getTextLine : Position -> string 12 | end; 13 | 14 | structure etLexPosition : etLEXPOSITION = 15 | struct 16 | type Position = {file: string,line: int,column: int,textline:string} 17 | 18 | val startPos = {file="",line=1,column=0,textline=""} 19 | fun startPosFile name = {file=name,line=1,column=0,textline=""} 20 | fun newLine (p:Position) = {file=(#file p),line=(#line p +1), 21 | column=0,textline=""} 22 | fun addText (p:Position) text = {file=(#file p),line=(#line p), 23 | column=(#column p)+String.size(text), 24 | textline=(#textline p) ^ text} 25 | fun getFile (p:Position) = (#file p) 26 | fun getLine (p:Position) = (#line p) 27 | fun getColumn (p:Position) = (#column p) 28 | fun getTextLine (p:Position) = (#textline p) 29 | end; 30 | -------------------------------------------------------------------------------- /src/v2/parser/etParser.sml: -------------------------------------------------------------------------------- 1 | signature etPARSER = 2 | sig 3 | structure FromParser : etFROMPARSER 4 | 5 | type LexerType 6 | 7 | val makeLexer : (int -> string) -> (bool -> unit) -> LexerType 8 | val parse : LexerType -> FromParser.Position.Position -> 9 | (FromParser.etDeclaration * LexerType * FromParser.Position.Position) 10 | end 11 | 12 | functor etParserFun (structure FromParser : etFROMPARSER) : etPARSER = 13 | struct 14 | structure FromParser = FromParser 15 | 16 | structure etLrVals=etLrValsFun( 17 | structure Token = LrParser.Token 18 | structure FromParser = FromParser) 19 | 20 | structure etLex=etLexFun(structure Tokens = etLrVals.Tokens 21 | structure LexPosition = FromParser.Position) 22 | 23 | structure etYacc=JoinWithArg 24 | (structure ParserData=etLrVals.ParserData 25 | structure Lex = etLex 26 | structure LrParser = LrParser) 27 | 28 | val dummyEof = etLrVals.Tokens.Eof 29 | (FromParser.Position.startPos,FromParser.Position.startPos) 30 | 31 | val dummySemicolon = etLrVals.Tokens.Semicolon 32 | (FromParser.Position.startPos,FromParser.Position.startPos) 33 | 34 | exception etParseError of string * FromParser.LRPos 35 | 36 | val currPos = ref FromParser.Position.startPos 37 | 38 | val duringParsing = ref true 39 | 40 | val invoke = fn lexstream => 41 | let 42 | val errorInParsing = fn (s,lPos,rPos) => 43 | raise etParseError (s,FromParser.mkLRPos lPos rPos) 44 | in 45 | etYacc.parse(0,lexstream,errorInParsing,()) 46 | end; 47 | 48 | type LexerType = (etYacc.svalue,etYacc.pos) LrParser.Token.token 49 | LrParser.Stream.stream 50 | 51 | fun makeLexer inputFun outputFun = etYacc.makeLexer 52 | (fn i => (outputFun (!duringParsing); 53 | inputFun i)) 54 | (currPos,duringParsing); 55 | 56 | fun parse lexer pos = 57 | let 58 | val _ = currPos:=pos; 59 | val _ = duringParsing:=false; 60 | val (nextToken,nextlexer)=etYacc.Stream.get lexer 61 | in 62 | if etYacc.sameToken(nextToken,dummyEof) then 63 | (FromParser.mkTermWithPos FromParser.Eof () pos pos,lexer,pos) 64 | else 65 | let 66 | val (result,lexer) = invoke lexer 67 | val (nextToken,lexer)=etYacc.Stream.get lexer 68 | in 69 | if etYacc.sameToken(nextToken,dummySemicolon) then 70 | (result,lexer,!currPos) 71 | else 72 | raise etParseError 73 | ("syntax error, Semicolon expected", 74 | FromParser.mkLRPos (!currPos) (!currPos)) 75 | end 76 | end 77 | handle etParseError (s,lrpos) => 78 | (FromParser.ParserError ("syntax error",lrpos),lexer,!currPos) 79 | | etLex.UserDeclarations.LexError (s,lpos,rpos) => 80 | (FromParser.LexerError 81 | ("unrecognized character: "^s, 82 | FromParser.mkLRPos (lpos) (rpos)),lexer,!currPos) 83 | end 84 | 85 | structure etParser = etParserFun(structure FromParser=etFromParser) 86 | -------------------------------------------------------------------------------- /src/v2/parser/ml-yacc/join.sml: -------------------------------------------------------------------------------- 1 | (* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi 2 | * 3 | * $Log: join.sml,v $ 4 | * Revision 1.1.1.1 1997/01/14 01:38:04 george 5 | * Version 109.24 6 | * 7 | * Revision 1.1.1.1 1996/01/31 16:01:42 george 8 | * Version 109 9 | * 10 | *) 11 | 12 | (* functor Join creates a user parser by putting together a Lexer structure, 13 | an LrValues structure, and a polymorphic parser structure. Note that 14 | the Lexer and LrValues structure must share the type pos (i.e. the type 15 | of line numbers), the type svalues for semantic values, and the type 16 | of tokens. 17 | *) 18 | 19 | functor Join(structure Lex : LEXER 20 | structure ParserData: PARSER_DATA 21 | structure LrParser : LR_PARSER 22 | sharing ParserData.LrTable = LrParser.LrTable 23 | sharing ParserData.Token = LrParser.Token 24 | sharing type Lex.UserDeclarations.svalue = ParserData.svalue 25 | sharing type Lex.UserDeclarations.pos = ParserData.pos 26 | sharing type Lex.UserDeclarations.token = ParserData.Token.token) 27 | : PARSER = 28 | struct 29 | structure Token = ParserData.Token 30 | structure Stream = LrParser.Stream 31 | 32 | exception ParseError = LrParser.ParseError 33 | 34 | type arg = ParserData.arg 35 | type pos = ParserData.pos 36 | type result = ParserData.result 37 | type svalue = ParserData.svalue 38 | val makeLexer = LrParser.Stream.streamify o Lex.makeLexer 39 | val parse = fn (lookahead,lexer,error,arg) => 40 | (fn (a,b) => (ParserData.Actions.extract a,b)) 41 | (LrParser.parse {table = ParserData.table, 42 | lexer=lexer, 43 | lookahead=lookahead, 44 | saction = ParserData.Actions.actions, 45 | arg=arg, 46 | void= ParserData.Actions.void, 47 | ec = {is_keyword = ParserData.EC.is_keyword, 48 | noShift = ParserData.EC.noShift, 49 | preferred_change = ParserData.EC.preferred_change, 50 | errtermvalue = ParserData.EC.errtermvalue, 51 | error=error, 52 | showTerminal = ParserData.EC.showTerminal, 53 | terms = ParserData.EC.terms}} 54 | ) 55 | val sameToken = Token.sameToken 56 | end 57 | 58 | (* functor JoinWithArg creates a variant of the parser structure produced 59 | above. In this case, the makeLexer take an additional argument before 60 | yielding a value of type unit -> (svalue,pos) token 61 | *) 62 | 63 | functor JoinWithArg(structure Lex : ARG_LEXER 64 | structure ParserData: PARSER_DATA 65 | structure LrParser : LR_PARSER 66 | sharing ParserData.LrTable = LrParser.LrTable 67 | sharing ParserData.Token = LrParser.Token 68 | sharing type Lex.UserDeclarations.svalue = ParserData.svalue 69 | sharing type Lex.UserDeclarations.pos = ParserData.pos 70 | sharing type Lex.UserDeclarations.token = ParserData.Token.token) 71 | : ARG_PARSER = 72 | struct 73 | structure Token = ParserData.Token 74 | structure Stream = LrParser.Stream 75 | 76 | exception ParseError = LrParser.ParseError 77 | 78 | type arg = ParserData.arg 79 | type lexarg = Lex.UserDeclarations.arg 80 | type pos = ParserData.pos 81 | type result = ParserData.result 82 | type svalue = ParserData.svalue 83 | 84 | val makeLexer = fn s => fn arg => 85 | LrParser.Stream.streamify (Lex.makeLexer s arg) 86 | val parse = fn (lookahead,lexer,error,arg) => 87 | (fn (a,b) => (ParserData.Actions.extract a,b)) 88 | (LrParser.parse {table = ParserData.table, 89 | lexer=lexer, 90 | lookahead=lookahead, 91 | saction = ParserData.Actions.actions, 92 | arg=arg, 93 | void= ParserData.Actions.void, 94 | ec = {is_keyword = ParserData.EC.is_keyword, 95 | noShift = ParserData.EC.noShift, 96 | preferred_change = ParserData.EC.preferred_change, 97 | errtermvalue = ParserData.EC.errtermvalue, 98 | error=error, 99 | showTerminal = ParserData.EC.showTerminal, 100 | terms = ParserData.EC.terms}} 101 | ) 102 | val sameToken = Token.sameToken 103 | end; 104 | -------------------------------------------------------------------------------- /src/v2/parser/ml-yacc/lrtable.sml: -------------------------------------------------------------------------------- 1 | (* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi 2 | * 3 | * $Log: lrtable.sml,v $ 4 | * Revision 1.1.1.1 1997/01/14 01:38:04 george 5 | * Version 109.24 6 | * 7 | * Revision 1.1.1.1 1996/01/31 16:01:42 george 8 | * Version 109 9 | * 10 | *) 11 | 12 | structure LrTable : LR_TABLE = 13 | struct 14 | open Array List 15 | infix 9 sub 16 | datatype ('a,'b) pairlist = EMPTY 17 | | PAIR of 'a * 'b * ('a,'b) pairlist 18 | datatype term = T of int 19 | datatype nonterm = NT of int 20 | datatype state = STATE of int 21 | datatype action = SHIFT of state 22 | | REDUCE of int (* rulenum from grammar *) 23 | | ACCEPT 24 | | ERROR 25 | exception Goto of state * nonterm 26 | type table = {states: int, rules : int,initialState: state, 27 | action: ((term,action) pairlist * action) array, 28 | goto : (nonterm,state) pairlist array} 29 | val numStates = fn ({states,...} : table) => states 30 | val numRules = fn ({rules,...} : table) => rules 31 | val describeActions = 32 | fn ({action,...} : table) => 33 | fn (STATE s) => action sub s 34 | val describeGoto = 35 | fn ({goto,...} : table) => 36 | fn (STATE s) => goto sub s 37 | fun findTerm (T term,row,default) = 38 | let fun find (PAIR (T key,data,r)) = 39 | if key < term then find r 40 | else if key=term then data 41 | else default 42 | | find EMPTY = default 43 | in find row 44 | end 45 | fun findNonterm (NT nt,row) = 46 | let fun find (PAIR (NT key,data,r)) = 47 | if key < nt then find r 48 | else if key=nt then SOME data 49 | else NONE 50 | | find EMPTY = NONE 51 | in find row 52 | end 53 | val action = fn ({action,...} : table) => 54 | fn (STATE state,term) => 55 | let val (row,default) = action sub state 56 | in findTerm(term,row,default) 57 | end 58 | val goto = fn ({goto,...} : table) => 59 | fn (a as (STATE state,nonterm)) => 60 | case findNonterm(nonterm,goto sub state) 61 | of SOME state => state 62 | | NONE => raise (Goto a) 63 | val initialState = fn ({initialState,...} : table) => initialState 64 | val mkLrTable = fn {actions,gotos,initialState,numStates,numRules} => 65 | ({action=actions,goto=gotos, 66 | states=numStates, 67 | rules=numRules, 68 | initialState=initialState} : table) 69 | end; 70 | -------------------------------------------------------------------------------- /src/v2/parser/ml-yacc/parser1.sml: -------------------------------------------------------------------------------- 1 | (* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi 2 | * 3 | * $Log: parser1.sml,v $ 4 | * Revision 1.2 1997/09/10 18:34:22 jhr 5 | * Changed "abstraction" to ":>". 6 | * 7 | # Revision 1.1.1.1 1997/01/14 01:38:04 george 8 | # Version 109.24 9 | # 10 | * Revision 1.1.1.1 1996/01/31 16:01:42 george 11 | * Version 109 12 | * 13 | *) 14 | 15 | (* This file was modified by Marek Lach to make it work with SMLNJ 110.0.3 . 16 | The same modifications were made by authors in parser2.sml. 17 | makestring was replaced by Int.toString, output by TextIO.output and 18 | std_out by TextIO.stdOut 19 | *) 20 | 21 | (* drt (12/15/89) -- the functor should be used during development work, 22 | but it is wastes space in the release version. 23 | 24 | functor ParserGen(structure LrTable : LR_TABLE 25 | structure Stream : STREAM) : LR_PARSER = 26 | *) 27 | 28 | structure LrParser :> LR_PARSER = 29 | struct 30 | val print = fn s => TextIO.output(TextIO.stdOut,s) 31 | val println = fn s => (print s; print "\n") 32 | structure LrTable = LrTable 33 | structure Stream = Stream 34 | structure Token : TOKEN = 35 | struct 36 | structure LrTable = LrTable 37 | datatype ('a,'b) token = TOKEN of LrTable.term * ('a * 'b * 'b) 38 | val sameToken = fn (TOKEN (t,_),TOKEN(t',_)) => t=t' 39 | end 40 | 41 | 42 | open LrTable 43 | open Token 44 | 45 | val DEBUG = false 46 | exception ParseError 47 | 48 | type ('a,'b) elem = (state * ('a * 'b * 'b)) 49 | type ('a,'b) stack = ('a,'b) elem list 50 | 51 | val showState = fn (STATE s) => ("STATE " ^ (Int.toString s)) 52 | 53 | fun printStack(stack: ('a,'b) elem list, n: int) = 54 | case stack 55 | of (state, _) :: rest => 56 | (print(" " ^ Int.toString n ^ ": "); 57 | println(showState state); 58 | printStack(rest, n+1) 59 | ) 60 | | nil => () 61 | 62 | val parse = fn {arg : 'a, 63 | table : LrTable.table, 64 | lexer : ('_b,'_c) token Stream.stream, 65 | saction : int * '_c * ('_b,'_c) stack * 'a -> 66 | nonterm * ('_b * '_c * '_c) * ('_b,'_c) stack, 67 | void : '_b, 68 | ec = {is_keyword,preferred_change, 69 | errtermvalue,showTerminal, 70 | error,terms,noShift}, 71 | lookahead} => 72 | let fun prAction(stack as (state, _) :: _, 73 | next as (TOKEN (term,_),_), action) = 74 | (println "Parse: state stack:"; 75 | printStack(stack, 0); 76 | print(" state=" 77 | ^ showState state 78 | ^ " next=" 79 | ^ showTerminal term 80 | ^ " action=" 81 | ); 82 | case action 83 | of SHIFT s => println ("SHIFT " ^ showState s) 84 | | REDUCE i => println ("REDUCE " ^ (Int.toString i)) 85 | | ERROR => println "ERROR" 86 | | ACCEPT => println "ACCEPT"; 87 | action) 88 | | prAction (_,_,action) = action 89 | 90 | val action = LrTable.action table 91 | val goto = LrTable.goto table 92 | 93 | fun parseStep(next as (TOKEN (terminal, value as (_,leftPos,_)),lexer) : 94 | ('_b,'_c) token * ('_b,'_c) token Stream.stream, 95 | stack as (state,_) :: _ : ('_b ,'_c) stack) = 96 | case (if DEBUG then prAction(stack, next,action(state, terminal)) 97 | else action(state, terminal)) 98 | of SHIFT s => parseStep(Stream.get lexer, (s,value) :: stack) 99 | | REDUCE i => 100 | let val (nonterm,value,stack as (state,_) :: _ ) = 101 | saction(i,leftPos,stack,arg) 102 | in parseStep(next,(goto(state,nonterm),value)::stack) 103 | end 104 | | ERROR => let val (_,leftPos,rightPos) = value 105 | in error("syntax error\n",leftPos,rightPos); 106 | raise ParseError 107 | end 108 | | ACCEPT => let val (_,(topvalue,_,_)) :: _ = stack 109 | val (token,restLexer) = next 110 | in (topvalue,Stream.cons(token,lexer)) 111 | end 112 | val next as (TOKEN (terminal,(_,leftPos,_)),_) = Stream.get lexer 113 | in parseStep(next,[(initialState table,(void,leftPos,leftPos))]) 114 | end 115 | end; 116 | 117 | (* drt (12/15/89) -- this needs to be used only when the parsing engine 118 | (the code above) is functorized. 119 | 120 | structure LrParser = ParserGen(structure LrTable = LrTable 121 | structure Stream = Stream); 122 | *) 123 | -------------------------------------------------------------------------------- /src/v2/parser/ml-yacc/sources.cm: -------------------------------------------------------------------------------- 1 | (* sources file for ML-Yacc library *) 2 | 3 | Library 4 | 5 | signature STREAM 6 | signature LR_TABLE 7 | signature TOKEN 8 | signature LR_PARSER 9 | signature LEXER 10 | signature ARG_LEXER 11 | signature PARSER_DATA 12 | signature PARSER 13 | signature ARG_PARSER 14 | functor Join 15 | functor JoinWithArg 16 | structure LrTable 17 | structure Stream 18 | structure LrParser 19 | 20 | is 21 | 22 | base.sig 23 | join.sml 24 | lrtable.sml 25 | stream.sml 26 | parser1.sml 27 | -------------------------------------------------------------------------------- /src/v2/parser/ml-yacc/stream.sml: -------------------------------------------------------------------------------- 1 | (* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi 2 | * 3 | * $Log: stream.sml,v $ 4 | * Revision 1.2 1997/08/26 19:18:55 jhr 5 | * Replaced used of "abstraction" with ":>". 6 | * 7 | # Revision 1.1.1.1 1997/01/14 01:38:04 george 8 | # Version 109.24 9 | # 10 | * Revision 1.1.1.1 1996/01/31 16:01:43 george 11 | * Version 109 12 | * 13 | *) 14 | 15 | (* Stream: a structure implementing a lazy stream. The signature STREAM 16 | is found in base.sig *) 17 | 18 | structure Stream :> STREAM = 19 | struct 20 | datatype 'a str = EVAL of 'a * 'a str ref | UNEVAL of (unit->'a) 21 | 22 | type 'a stream = 'a str ref 23 | 24 | fun get(ref(EVAL t)) = t 25 | | get(s as ref(UNEVAL f)) = 26 | let val t = (f(), ref(UNEVAL f)) in s := EVAL t; t end 27 | 28 | fun streamify f = ref(UNEVAL f) 29 | fun cons(a,s) = ref(EVAL(a,s)) 30 | 31 | end; 32 | -------------------------------------------------------------------------------- /src/v2/parser/sources.cm: -------------------------------------------------------------------------------- 1 | Group 2 | signature etLEXPOSITION 3 | signature etFROMPARSER 4 | signature etPARSER 5 | functor etFromParserFun 6 | functor etParserFun 7 | structure etLexPosition 8 | structure etFromParser 9 | structure etParser 10 | is 11 | ml-yacc/sources.cm 12 | ../tools/sources.cm 13 | et.lex 14 | et.grm 15 | etLexPos.sml 16 | etFromParser.sml 17 | etParser.sml 18 | -------------------------------------------------------------------------------- /src/v2/sources.cm: -------------------------------------------------------------------------------- 1 | Group 2 | signature ET 3 | structure et 4 | is 5 | tools/sources.cm 6 | parser/sources.cm 7 | compiler/sources.cm 8 | etMain.sml 9 | -------------------------------------------------------------------------------- /src/v2/syntax/etAbstractSyntax.sml: -------------------------------------------------------------------------------- 1 | signature etABSTRACTSYNTAX = 2 | sig 3 | type TypeNumberId = int 4 | type TermNumberId = int 5 | 6 | datatype etType = 7 | TypeVar of TypeNumberId 8 | | TypeApp of TypeNumberId * etType list 9 | 10 | datatype etTerm = 11 | Var of TermNumberId 12 | | BoundVar of int 13 | | App of etTerm * etTerm 14 | | Abs of string * etTerm 15 | | Cons of string * TypeNumberId * int * int * etTerm * etTerm * (etTerm list) 16 | | Iter of string * TypeNumberId * int 17 | | Rec of string * TypeNumberId * int 18 | | Des of string * TypeNumberId * int * etTerm * etTerm 19 | | Coit of string * TypeNumberId * int * (etTerm list) 20 | | Corec of string * TypeNumberId * int * (etTerm list) 21 | 22 | val maxTypeVar : etType -> int 23 | val maxTypeVarL : etType list -> int 24 | val maxTermVar : etTerm -> int 25 | val maxTermVarL : etTerm list -> int 26 | 27 | val allTypeVarIn : etType -> etType list 28 | val notTypeVarIn : etType -> etType -> bool 29 | val notTypeVarInL : etType -> etType list -> bool 30 | end 31 | 32 | structure etAbstractSyntax : etABSTRACTSYNTAX = 33 | struct 34 | type TypeNumberId = int 35 | type TermNumberId = int 36 | 37 | datatype etType = 38 | TypeVar of TypeNumberId 39 | | TypeApp of TypeNumberId * etType list 40 | 41 | datatype etTerm = 42 | Var of TermNumberId 43 | | BoundVar of int 44 | | App of etTerm * etTerm 45 | | Abs of string * etTerm 46 | | Cons of string * TypeNumberId * int * int * etTerm * etTerm * (etTerm list) 47 | | Iter of string * TypeNumberId * int 48 | | Rec of string * TypeNumberId * int 49 | | Des of string * TypeNumberId * int * etTerm * etTerm 50 | | Coit of string * TypeNumberId * int * (etTerm list) 51 | | Corec of string * TypeNumberId * int * (etTerm list) 52 | 53 | fun maxTypeVar (TypeVar i) = i 54 | | maxTypeVar (TypeApp (i,lt)) = Int.max (i,maxTypeVarL lt) 55 | and maxTypeVarL tl = foldl (fn (a,b) => Int.max (maxTypeVar a,b)) 0 tl 56 | 57 | fun maxTermVar (Var i) = i 58 | | maxTermVar (BoundVar i) = 0 59 | | maxTermVar (App (t1,t2)) = Int.max (maxTermVar t1,maxTermVar t2) 60 | | maxTermVar (Abs (_,t)) = maxTermVar t 61 | | maxTermVar (Cons (_,_,_,_,t1,t2,tl)) = maxTermVarL (tl@[t1,t2]) 62 | | maxTermVar (Iter _) = 0 63 | | maxTermVar (Rec _) = 0 64 | | maxTermVar (Des (_,_,_,t1,t2)) = maxTermVarL ([t1,t2]) 65 | | maxTermVar (Coit (_,_,_,tl)) = maxTermVarL tl 66 | | maxTermVar (Corec (_,_,_,tl)) = maxTermVarL tl 67 | and maxTermVarL tl = foldl (fn (a,b) => Int.max (maxTermVar a,b)) 0 tl 68 | 69 | local 70 | fun alltv (t as (TypeVar _)) = [t] 71 | | alltv (TypeApp (_,lt)) = List.concat (map alltv lt) 72 | 73 | fun uniq (h::t) = h::(List.filter (fn x => x<>h) t) 74 | | uniq nil = nil 75 | in 76 | fun allTypeVarIn t = uniq (alltv t) 77 | end 78 | 79 | fun notTypeVarIn (TypeVar i) (TypeVar j) = i<>j 80 | | notTypeVarIn (tv1 as TypeVar _) (TypeApp (_,tl))= 81 | notTypeVarInL tv1 tl 82 | | notTypeVarIn _ _ = false 83 | and notTypeVarInL (tv1 as TypeVar _) tl = 84 | List.all (fn x => notTypeVarIn tv1 x) tl 85 | | notTypeVarInL _ _ = false 86 | end 87 | -------------------------------------------------------------------------------- /src/v2/syntax/sources.cm: -------------------------------------------------------------------------------- 1 | Group 2 | signature etABSTRACTSYNTAX 3 | signature etPRETTYPRINT 4 | signature etEVAL 5 | signature etENVIRONMENT 6 | structure etAbstractSyntax 7 | structure etPrettyPrint 8 | structure etEval 9 | structure etEnvironment 10 | is 11 | ../tools/sources.cm 12 | etAbstractSyntax.sml 13 | etEnvironment.sml 14 | etPrettyPrint.sml 15 | etEval.sml 16 | -------------------------------------------------------------------------------- /src/v2/tools/etTools.sml: -------------------------------------------------------------------------------- 1 | structure etTools = 2 | struct 3 | exception InternalError of string 4 | end; 5 | -------------------------------------------------------------------------------- /src/v2/tools/int-inf-sig.sml: -------------------------------------------------------------------------------- 1 | (* int-inf-sig.sml 2 | * 3 | * COPYRIGHT (c) 1995 by AT&T Bell Laboratories. See COPYRIGHT file for details. 4 | * 5 | * This package is derived from Andrzej Filinski's bignum package. It is versy 6 | * close to the definition of the optional IntInf structure in the SML'97 basis. 7 | *) 8 | 9 | signature INT_INF = 10 | sig 11 | include INTEGER 12 | 13 | val divmod : (int * int) -> (int * int) 14 | val quotrem : (int * int) -> (int * int) 15 | val pow : (int * Int.int) -> int 16 | val log2 : int -> Int.int 17 | 18 | end (* signature INT_INF *) 19 | -------------------------------------------------------------------------------- /src/v2/tools/sources.cm: -------------------------------------------------------------------------------- 1 | Group 2 | signature INT_INF 3 | structure etTools 4 | structure IntInf 5 | is 6 | etTools.sml 7 | int-inf-sig.sml 8 | int-inf.sml 9 | -------------------------------------------------------------------------------- /src/v3/COPYRIGHT: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2002, 2003, 2004 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. Neither the name of the University nor the names of its contributors 14 | * may be used to endorse or promote products derived from this software 15 | * without specific prior written permission. 16 | * 17 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 18 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 21 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 | * SUCH DAMAGE. 28 | *) 29 | -------------------------------------------------------------------------------- /src/v3/Makefile: -------------------------------------------------------------------------------- 1 | obj = \ 2 | unionfind.cmo util.cmo lexer.cmo parser.cmo pp.cmo env.cmo \ 3 | lambda.cmo tyutil.cmo tysem.cmo typing.cmo eval.cmo main.cmo 4 | opt_obj = ${obj:.cmo=.cmx} 5 | target = et 6 | OCAMLC = ocamlc -g 7 | OCAMLC_OPT = ocamlopt 8 | 9 | CMA_LIBS = 10 | 11 | all: $(target) fake-ast 12 | native: opt 13 | opt: $(target).opt 14 | 15 | $(target): $(obj) 16 | $(OCAMLC) -o $@ $(CMA_LIBS) $(obj) 17 | -copy $(target) $(target).exe 18 | 19 | $(target).opt: $(opt_obj) 20 | $(OCAMLC_OPT) -o $@ ${CMA_LIBS:.cma=.cmax} $(opt_obj) 21 | 22 | .PHONY: tags 23 | 24 | tags: 25 | otags -vi *.ml *.mli 26 | 27 | .SECONDARY: parser.ml lexer.ml parser.mli 28 | .PHONY: t 29 | 30 | %.cmo: %.ml 31 | $(OCAMLC) -c $< 32 | 33 | %.cmi: %.mli 34 | $(OCAMLC) -c $< 35 | 36 | %.cmx: %.ml 37 | $(OCAMLC_OPT) -c $< 38 | 39 | %.ml: %.mll 40 | ocamllex $< 41 | 42 | %.ml %.mli: %.mly 43 | ocamlyacc -v $< 44 | 45 | # ocamldebug is stupid and needs it 46 | fake-ast: ast.cmo 47 | 48 | ast.cmo: ast.mli 49 | $(OCAMLC) -c -impl ast.mli 50 | 51 | .deps: parser.ml lexer.ml Makefile 52 | ocamldep *.ml *.mli > .deps 53 | 54 | -include .deps 55 | 56 | clean: 57 | rm -f *.cmo *.cmi *.o *.cmx core $(target) $(target).opt parser.output 58 | 59 | nuke: clean 60 | rm -f parser.ml parser.mli lexer.ml parser.output 61 | rm -f .deps TAGS tags 62 | 63 | count: 64 | wc `ls *.ml *.mli *.mly *.mll | egrep -v '(parser|lexer)\.(ml|mli)$$'` 65 | 66 | VER := $(shell cat VERSION) 67 | DISTDIR := et-$(VER) 68 | 69 | dist: 70 | update-svn-changelog || : 71 | rm -rf $(DISTDIR) 72 | svn export . $(DISTDIR) 73 | -cp ChangeLog $(DISTDIR) 74 | $(MAKE) -C $(DISTDIR)/doc 75 | $(MAKE) -C $(DISTDIR)/doc dist-clean 76 | tar cf - $(DISTDIR) | gzip -9nf > $(DISTDIR).tar.gz 77 | rm -rf $(DISTDIR) 78 | 79 | t: 80 | cd tests; ./run 81 | -------------------------------------------------------------------------------- /src/v3/NEWS: -------------------------------------------------------------------------------- 1 | version 2.0.5, Nov 5 2004 2 | - fixed some nasty bugs with let-polymorphism, reported by Tomasz 3 | Wegrzynowski 4 | - we can now handle multiple arguments in codatatypes without the help of 5 | the UNION type 6 | 7 | version 2.0.4, Oct 19 2004 8 | - more documentation -- IPL manual along with a mental patch has been 9 | included 10 | - GNU Make for Windows binary has been included 11 | - FALSE datatype has been renamed to BOTTOM (in startup.et) 12 | - there are now a few aliases for startup.et types and values, used 13 | also during pretty printing the result: 14 | {} = BOTTOM 15 | case0 = _BOTTOMit 16 | case1 = _UNITit 17 | when = _UNIONit 18 | () = Unit 19 | The Pair and _BOOLit shortcuts (, and if-then-else) are now also used 20 | in pretty printing. 21 | snd and fst are used instead of _UNIONit. It is only relevant to pretty 22 | printing, so don't be confused by the eta long form of + fst;. 23 | 24 | version 2.0.3, Oct 3 2004 25 | - fixed bug in coiterator generation 26 | - added UNIT to startup.et 27 | 28 | version 2.0.1, Mar 13 2003 29 | - implemented 'show' command, use 'show;' or 'show id;' 30 | - session log is written to session.et in current directory, just in case 31 | you need to recall something from interactive session. 32 | -------------------------------------------------------------------------------- /src/v3/README.md: -------------------------------------------------------------------------------- 1 | # ET version 2, UFO strikes back 2 | 3 | ## Intro 4 | 5 | This tarball contains sources for the ET (formerly IPL) interpreter. 6 | ET is a ML-like language with the strong normalization property. It's 7 | mainly meant for research. 8 | 9 | This is the third implementation of ET. 10 | 11 | 12 | ## Compilation 13 | 14 | In order to compile ET you need OCaml distribution. I tried with 3.06 15 | and later versions. You need ocamlc, ocamllex and ocamlyacc, that all 16 | come with the OCaml distribution. No library beside standard OCaml 17 | libraries is needed. 18 | 19 | In addition to OCaml you need GNU Make. A binary executable of GNU Make 20 | for MS Windows is included with this source distribution. 21 | 22 | This version of ET was tested on the PLD Linux, FreeBSD and Windows XP 23 | operating systems. 24 | 25 | To compile ET just type `make` (or `gmake` if you're on BSD). 26 | 27 | 28 | ## Installation 29 | 30 | None yet. Just run et from current directory. It needs to find 31 | `startup.et` file. 32 | 33 | 34 | ## Authors 35 | 36 | The language was invented by Zdzisław Spławski . 37 | This implementation of interpreter was written by Michał Moskal . 38 | 39 | 40 | ## Reference Manual 41 | 42 | Please consult the `doc/iplman1.pdf` file for a description of the previous 43 | implementation of ET, by ToMasz Wierzbicki. This implementation provides very 44 | similar interface, changes are described below. 45 | 46 | This section can be thought of as a kind of mental patch. 47 | 48 | 49 | ### Changes 50 | 51 | All special type constructors, beside ->, are simply defined in the 52 | startup.et file. They are often referred to as in IPL, with special 53 | symbols, though they real names can sometimes show up. 54 | 55 | The `del` declaration is not supported. 56 | 57 | `quit;` in the `use`-ed file, kill the interpreter. 58 | 59 | Comments can be nested, though contents of the comment is not lexed, so 60 | "" have no special meaning within it. 61 | 62 | The interpreter does not care about symbol redefinition, so be careful 63 | not to override something from the `startup.et` file, other wise Bad Things 64 | Will Happen To You [tm]. 65 | 66 | 67 | ### New features 68 | 69 | There are a few new syntactic conventions. 70 | 71 | "\x. y" stands for "fn x => y". The \-form is also used in the output. 72 | 73 | "let" can be used instead of "val", the OCaml like "let x = y in z" 74 | is not supported, use "let val x = y; in z end". 75 | 76 | "quit;" is an alias to the "exit;". 77 | 78 | A new declaration "set" has been introduced. "set" is followed by an 79 | identifier or a string. Both mean the same thing. Following "set" 80 | arguments are supported: 81 | 82 | * debug, nodebug -- control some debugging output during mon/amon invocations, in short -- don't use. 83 | * quiet, noquiet -- whether to output types of the values defined, and definitions of introduced type iterators, recursors etc. 84 | 85 | The reasonable use of the "set" declaration is as follows: 86 | 87 | set quiet; 88 | (* some program *) 89 | set noquiet; 90 | (* some interesting part of the program *) 91 | set quiet; 92 | (* blah *) 93 | set noquiet; 94 | 95 | in a file of course. 96 | 97 | Apart from syntax -- user input from each session is stored in the 98 | "session.et" file in the current directory. It is overwritten each time. 99 | 100 | Wrocław, 2003, 2004. 101 | -------------------------------------------------------------------------------- /src/v3/VERSION: -------------------------------------------------------------------------------- 1 | 2.0.5 2 | -------------------------------------------------------------------------------- /src/v3/ast.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2002, 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | 34 | (* Location in source file. *) 35 | type location = {mutable loc_file: string; 36 | mutable loc_char: int; 37 | mutable loc_line: int} 38 | 39 | type tyvar = string 40 | 41 | type 'a located = {v : 'a; l : location} 42 | 43 | type raw_decl = 44 | | Value_binding of string * pterm 45 | | Term of pterm 46 | | Type of string * tyvar list * cdtor list 47 | | Cotype of string * tyvar list * cdtor list 48 | | Exit_cmd 49 | | Show_cmd of string 50 | | Use_cmd of string 51 | | Set_cmd of string 52 | | Eq_test of pterm * pterm 53 | and cdtor = 54 | {cd_name : string; 55 | cd_args : ty list} 56 | and decl = raw_decl located 57 | 58 | and raw_pterm = 59 | | T_app of pterm * pterm 60 | | T_abs of string * pterm 61 | | T_ref of string 62 | | T_let of (string * pterm) list * pterm 63 | 64 | and pterm = raw_pterm located 65 | 66 | and 'a name = {n_name : string; 67 | mutable n_binding : 'a option} 68 | 69 | and ty = 70 | | Tyvar of string 71 | | Tycon of tycon name * ty list 72 | | Tybox of tybox 73 | 74 | and tybox = 75 | { 76 | mutable box_value : ty option; 77 | mutable box_set : int; 78 | box_id : int; 79 | } 80 | 81 | (* For environment. *) 82 | 83 | and signess = Positive | Negative | Signless | Bisigned 84 | 85 | and tycon = 86 | { 87 | tc_name : string; 88 | tc_args : signess list; 89 | tc_is_cotype : bool; 90 | mutable tc_cons : (value * ty list) list; 91 | mutable tc_it : value; 92 | mutable tc_rec : value; 93 | mutable tc_tyvars : string list; 94 | mutable tc_rules : rule list; 95 | mutable tc_outdated : bool; 96 | } 97 | 98 | and rule = 99 | { 100 | r_vars : int list; 101 | r_elim : value; 102 | r_ctor : value; 103 | r_value : term; 104 | } 105 | 106 | and semantics = 107 | | Shorthand of term 108 | | Alias of term 109 | | Constructor of tycon 110 | | Eliminator of tycon 111 | | Dummy 112 | 113 | and value = 114 | { 115 | val_name : string; 116 | val_ty : ty; 117 | val_semantics : semantics; 118 | } 119 | 120 | and term = 121 | | App of term * term 122 | | Abs of int * term 123 | | Var of int 124 | | Value of value 125 | -------------------------------------------------------------------------------- /src/v3/env.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2002, 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | open Ast 34 | open Util 35 | 36 | type env = 37 | {e_tycons : tycon Stringmap.t; 38 | e_values : value Stringmap.t} 39 | 40 | let add_tycon e t = 41 | let () = 42 | if Stringmap.mem t.tc_name e.e_tycons then 43 | (Stringmap.find t.tc_name e.e_tycons).tc_outdated <- true 44 | in {e with e_tycons = Stringmap.add t.tc_name t e.e_tycons} 45 | 46 | let add_value e t = 47 | {e with e_values = Stringmap.add t.val_name t e.e_values} 48 | 49 | let get_tycon e n = 50 | try 51 | Stringmap.find n e.e_tycons 52 | with Not_found -> 53 | raise (Unlocated_error ("unbound type constructor `" ^ n ^ "'")) 54 | 55 | let get_value e n = 56 | try 57 | Stringmap.find n e.e_values 58 | with Not_found -> 59 | raise (Unlocated_error ("unbound value `" ^ n ^ "'")) 60 | 61 | let null_env = 62 | {e_tycons = Stringmap.empty; 63 | e_values = Stringmap.empty} 64 | 65 | let dummy_value = {val_name = "???"; val_ty = Tyvar "'?"; val_semantics = Dummy} 66 | 67 | let value_names env = Stringmap.fold (fun n _ l -> n :: l) env.e_values [] 68 | let tycon_names env = Stringmap.fold (fun n _ l -> n :: l) env.e_tycons [] 69 | 70 | let empty_env = 71 | List.fold_left add_tycon null_env 72 | [{tc_name = "->"; 73 | tc_is_cotype = false; 74 | tc_args = [Negative; Positive]; 75 | tc_cons = []; 76 | tc_tyvars = ["'a"; "'b"]; 77 | tc_it = {dummy_value with val_name = "_FUNit"}; 78 | tc_rec = {dummy_value with val_name = "_FUNrec"}; 79 | tc_rules = []; 80 | tc_outdated = false}] 81 | 82 | -------------------------------------------------------------------------------- /src/v3/env.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2002, 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | open Ast 34 | 35 | type env 36 | 37 | val empty_env : env 38 | 39 | val dummy_value : value 40 | 41 | val add_tycon : env -> tycon -> env 42 | val add_value : env -> value -> env 43 | 44 | val get_tycon : env -> string -> tycon 45 | val get_value : env -> string -> value 46 | 47 | val value_names : env -> string list 48 | val tycon_names : env -> string list 49 | -------------------------------------------------------------------------------- /src/v3/eval.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | open Ast 34 | open Util 35 | open Tyutil 36 | open Lambda 37 | 38 | let pf = Printf.printf 39 | 40 | (* Compile pterm [t], that is already typed. *) 41 | let compile genv t = 42 | let rec f env t = 43 | match t.v with 44 | | T_app (t1, t2) -> 45 | App (f env t1, f env t2) 46 | | T_abs (v, t) -> 47 | let k = gen_var () in 48 | let env = Stringmap.add v (rf k) env in 49 | lambda [k] (f env t) 50 | | T_ref s when Stringmap.mem s env -> Stringmap.find s env 51 | | T_ref s -> 52 | begin 53 | match Env.get_value genv s with 54 | | {val_semantics = Shorthand t} 55 | | {val_semantics = Alias t} -> t 56 | | x -> Value x 57 | end 58 | | T_let (bindings, t) -> 59 | let add e (n, v) = Stringmap.add n (f env v) e in 60 | f (List.fold_left add env bindings) t 61 | in f Stringmap.empty t 62 | 63 | let show env name = 64 | let show_tycon n = 65 | if n <> "->" then Tysem.print_type (Env.get_tycon env n) 66 | in 67 | let show_value n = 68 | let v = Env.get_value env n in 69 | match v.val_semantics with 70 | | Alias t -> 71 | if name <> "" then begin 72 | pf "alias %s = %s;\n" v.val_name (Pp.string_of_term t); 73 | print_val "val" v; 74 | pf "\n" 75 | end 76 | | Shorthand t -> 77 | pf "val %s = %s;\n" v.val_name (Pp.string_of_term t); 78 | print_val "val" v; 79 | pf "\n" 80 | | Constructor _ -> if name <> "" then print_val "con" v 81 | | Eliminator _ -> if name <> "" then print_val "des" v 82 | | Dummy -> assert false 83 | in 84 | match name with 85 | | "" -> 86 | List.iter show_tycon (Env.tycon_names env); 87 | List.iter show_value (Env.value_names env) 88 | | _ -> 89 | (try show_tycon name with Unlocated_error _ -> ()); 90 | (try show_value name with Unlocated_error _ -> ()) 91 | 92 | let eval_decl env d = 93 | match d.v with 94 | | Value_binding (n, m) -> 95 | let ty = Typing.type_pterm env m in 96 | let vv = {val_name = n; 97 | val_ty = ty; 98 | val_semantics = Shorthand (compile env m)} in 99 | let () = print_val "val" vv in 100 | Env.add_value env vv 101 | | Term m -> 102 | let ty = Typing.type_pterm env m in 103 | let norm = nf (compile env m) in 104 | let () = pf "%s : %s\n" (Pp.string_of_term norm) (Pp.string_of_ty ty) in 105 | env 106 | | Type (n, tv, tors) -> Tysem.add_type env n tv tors 107 | | Cotype (n, tv, tors) -> Tysem.add_cotype env n tv tors 108 | | Eq_test (t1, t2) -> 109 | let ty1 = Typing.type_pterm env t1 in 110 | let ty2 = Typing.type_pterm env t2 in 111 | let n1 = nf (compile env t1) in 112 | let n2 = nf (compile env t2) in 113 | let r = 114 | if eq n1 n2 then "True" 115 | else "False" 116 | in 117 | if !debug then 118 | pf "%s : %s =? %s : %s = %s\n" 119 | (Pp.string_of_term n1) (Pp.string_of_ty ty1) 120 | (Pp.string_of_term n2) (Pp.string_of_ty ty2) 121 | r; 122 | pf "%s : BOOL\n" r; 123 | env 124 | 125 | | Exit_cmd -> exit 0 126 | | Show_cmd n -> show env n; env 127 | | Use_cmd _ -> env 128 | | Set_cmd "debug" -> 129 | debug := true; env 130 | | Set_cmd "nodebug" -> 131 | debug := false; env 132 | | Set_cmd "quiet" -> 133 | quiet := true; env 134 | | Set_cmd "noquiet" -> 135 | quiet := false; env 136 | | Set_cmd x -> 137 | pf "unknown set: %s\n" x; env 138 | 139 | -------------------------------------------------------------------------------- /src/v3/eval.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | open Ast 34 | 35 | val eval_decl : Env.env -> decl -> Env.env 36 | -------------------------------------------------------------------------------- /src/v3/examples/ex1.et: -------------------------------------------------------------------------------- 1 | datatype NAT = S from NAT | O; 2 | 3 | val le = fn u => _NATit u (fn y v => _NATrec v (fn x => y (fst x)) False) 4 | (fn v => True); 5 | 6 | (fn v => le O v) = (fn v => True); 7 | (fn u v => le (S u) O) = (fn u v => False); 8 | (fn u v => le (S u) (S v)) = (fn u v => le u v); 9 | 10 | datatype LIST 'a = Cons from 'a (LIST 'a) | Nil; 11 | val tl = fn xs => _LISTrec xs (fn h p => fst p) Nil; 12 | datatype HDexception = Hd; 13 | val hd = fn xs => _LISTit xs (fn h t => Inl h) (Inr Hd); 14 | val append = fn xs ys => _LISTit xs Cons ys; 15 | 16 | datatype BT 'a = Node from 'a (BT 'a) (BT 'a) | Tip; 17 | val toBST = fn x t => _BTrec t (fn a lp rp => 18 | if le x a then Node a (snd lp) (fst rp) 19 | else Node a (fst lp) (snd rp)) (Node x Tip Tip); 20 | 21 | val listToBST = fn xs => _LISTit xs toBST Tip; 22 | 23 | val inorder = fn t => _BTit t (fn a l r => append l (Cons a r)) Nil; 24 | 25 | val quicksort = fn xs => inorder (listToBST xs); 26 | 27 | val one = S O; 28 | val two = S one; 29 | val three = S two; 30 | val l = Cons two (Cons one (Cons three (Cons O Nil))); 31 | quicksort l; 32 | 33 | (* vim: ft=sml 34 | *) 35 | -------------------------------------------------------------------------------- /src/v3/examples/ex2.et: -------------------------------------------------------------------------------- 1 | datatype CHAR = A|B|C|D|E|F|G|H|I|J|K|L|M; 2 | datatype LIST 'a = Nil | Cons from 'a (LIST 'a); 3 | datatype TREE 'a = Leaf from 'a | Node from 'a (TREE 'a) (TREE 'a); 4 | datatype CONT 'a = DC | CC from ((CONT 'a) -> LIST 'a) -> LIST 'a; 5 | val o = fn g f x => g (f x); 6 | val apply = fn k => _CONTit k (fn g => g DC) 7 | (fn h g => h (fn f => g (CC f))); 8 | val breadth = fn t => _TREEit t 9 | (fn a now => CC (fn later => Cons a (apply now later))) 10 | (fn a brl brr now => CC (fn later => Cons a (apply now (o later (o brl brr))))); 11 | 12 | val extract = fn k => _CONTit k Nil (fn f => f (fn l => l)); 13 | 14 | val run = fn t => extract (breadth t DC); 15 | 16 | val t = Node A 17 | (Node B 18 | (Node D (Leaf H) (Leaf I)) 19 | (Node E (Leaf J) (Leaf K)) 20 | ) 21 | (Node C 22 | (Leaf F) 23 | (Node G (Leaf L) (Leaf M)) 24 | ); 25 | run t; 26 | 27 | (* vim: ft=sml *) 28 | -------------------------------------------------------------------------------- /src/v3/examples/ex3.et: -------------------------------------------------------------------------------- 1 | datatype NAT = S from NAT | O; 2 | codatatype STREAM 'a = Shd to 'a & Stl to STREAM 'a; 3 | val smap = fn f s => _STREAMci (fn x => f (Shd x)) Stl s; 4 | val natstr = fn n => _STREAMci (fn x => x) S n; 5 | val sprefix = fn h s => _STREAMcr (fn x => h) (fn x => Inl s) s; 6 | val ns = natstr O; 7 | Shd ns; 8 | Shd (Stl ns); 9 | val ns' = sprefix (S (S O)) ns; 10 | Shd ns'; 11 | Shd (Stl ns'); 12 | 13 | (* vim: ft=sml 14 | *) 15 | -------------------------------------------------------------------------------- /src/v3/examples/ex4.et: -------------------------------------------------------------------------------- 1 | datatype Z 'a = InZ from 'a -> Z 'a; 2 | datatype Y 'a = InY from (Z 'a) -> Y 'a; 3 | datatype X = InX from (Y X); 4 | -------------------------------------------------------------------------------- /src/v3/examples/ex5.et: -------------------------------------------------------------------------------- 1 | codatatype Z2 'a = OutZ2 to ('a -> Z2 'a); 2 | codatatype Y2 'a = OutY2 to ((Z2 'a) -> Y2 'a) ; 3 | (* We had a bug here. *) 4 | codatatype X2 = OutX2 to (Y2 X2); 5 | -------------------------------------------------------------------------------- /src/v3/examples/iplbyex.et: -------------------------------------------------------------------------------- 1 | val f1 = \p q r. p r; 2 | f1; 3 | \x y z. x z = f1; 4 | val s = \f g x. f x (g x); 5 | val k = \x y. x; 6 | s k k; 7 | val i = let val ss = \f g x. f x (g x); 8 | val kk = \x y. x; 9 | in ss kk kk end; 10 | i; 11 | -------------------------------------------------------------------------------- /src/v3/examples/iplbyex2.et: -------------------------------------------------------------------------------- 1 | datatype PROD1 'a 'b = Pair' from 'a 'b; 2 | codatatype PROD2 'a 'b = Fst to 'a & Snd to 'b; 3 | val pair = \x y. _PROD2ci (\z. x) (\z. y) True; 4 | val split = \p z. z (Fst p) (Snd p); 5 | \x y. _PROD1it (Pair' x y) = \x y. split (pair x y); 6 | val prod = \f1 f2 x. Pair' (f1 x) (f2 x); 7 | val fst' = \p. _PROD1it p \x y. x; 8 | val snd' = \p. _PROD1it p \x y. y; 9 | \f g x. Fst (_PROD2ci f g x) = \f g x. fst' (prod f g x); 10 | \f g x. Snd (_PROD2ci f g x) = \f g x. snd' (prod f g x); 11 | -------------------------------------------------------------------------------- /src/v3/examples/l3.et: -------------------------------------------------------------------------------- 1 | datatype NAT = O | S from NAT; 2 | 3 | val add = \x y. _NATit x y (\y. S y); 4 | 5 | \x y. add (S x) y = \x y. S (add x y); 6 | \x. add O x = \x. x; 7 | 8 | val mult = \x y. _NATit x O (\z. add z y); 9 | 10 | \x y. mult (S x) y = \x y. add (mult x y) y; 11 | \y. mult O y = \y. O; 12 | 13 | val exp = \x y. _NATit y (S O) (\z. mult z x); 14 | 15 | \x y. exp x (S y) = \x y. mult (exp x y) x; 16 | \x. exp x O = \x. (S O); 17 | 18 | val pred = \x. _NATrec x O fst; 19 | 20 | \x. pred (S x) = \x. x; 21 | pred O = O; 22 | 23 | val subtr = \m n. _NATit n m (\x. pred x); 24 | 25 | \x y. subtr x (S y) = \x y. pred (subtr x y); 26 | \x. subtr x O = \x. x; 27 | 28 | val is_zero = \x. _NATit x True (\x. False); 29 | is_zero O = True; 30 | \x. is_zero (S x) = \x. False; 31 | 32 | val eq = \m n. 33 | if is_zero (subtr m n) then 34 | is_zero (subtr n m) 35 | else False; 36 | 37 | val eq = \m n. fst (_NATit m (True, n) 38 | (\x. if is_zero (snd x) then (False, O) else (fst x, pred (snd x)))); 39 | 40 | val is_one = \x. is_zero (pred x); 41 | val eq = \m n. is_one (subtr (S m) n); 42 | 43 | eq O O = True; 44 | \x. eq (S x) O = \x. False; 45 | \x. eq O (S x) = \x. False; 46 | \x y. eq (S x) y = \x y. eq x (pred y); 47 | \x y. eq x (S y) = \x y. eq (pred x) y; 48 | 49 | val le = \m n. is_zero (subtr m n); 50 | 51 | le O O = True; 52 | \x. le (S x) O = \x. False; 53 | \x. le O (S x) = \x. True; 54 | \x y. le (S x) y = \x y. le x (pred y); 55 | 56 | val ack = \m n. (_NATit m (\n. (S n)) (\f. \n. _NATit n (f (S O)) f)) n; 57 | 58 | val ack' = \z. _NATit z S (\y x. _NATit x (y (S O)) y); 59 | 60 | \n. ack O n = \n. S n; 61 | \m. ack (S m) O = \m. ack m (S O); 62 | \m n. ack (S m) (S n) = \m n. ack m (ack (S m) n); 63 | 64 | datatype LIST 'a = Nil | Cons from 'a (LIST 'a); 65 | 66 | val length = \l. _LISTit l O (\x y. S y); 67 | 68 | length Nil = O; 69 | \x y. length (Cons x y) = \x y. S (length y); 70 | 71 | val append = \x y. _LISTit x y Cons; 72 | 73 | \x. append Nil x = \x. x; 74 | \x y z. append (Cons x y) z = \x y z. Cons x (append y z); 75 | 76 | val map = \f l. _LISTit l Nil (\x y. Cons (f x) y); 77 | 78 | \f. map f Nil = \f. Nil; 79 | \f x y. map f (Cons x y) = \f x y. Cons (f x) (map f y); 80 | 81 | datatype TREE 'a = Tip | Node from 'a (TREE 'a) (TREE 'a); 82 | 83 | val max = \x y. if le x y then y else x; 84 | val height = \t. _TREEit t O (\a x y. S (max x y)); 85 | 86 | height Tip = O; 87 | \x y z. height (Node x y z) = \x y z. S (max (height y) (height z)); 88 | 89 | (* vim: ft=sml 90 | *) 91 | -------------------------------------------------------------------------------- /src/v3/examples/l4.et: -------------------------------------------------------------------------------- 1 | datatype NAT = O | S from NAT; 2 | 3 | val add = \x y. _NATit x y (\y. S y); 4 | 5 | \x y. add (S x) y = \x y. S (add x y); 6 | \x. add O x = \x. x; 7 | 8 | val mult = \x y. _NATit x O (\z. add z y); 9 | 10 | \x y. mult (S x) y = \x y. add (mult x y) y; 11 | \y. mult O y = \y. O; 12 | 13 | val pred = \x. _NATrec x O fst; 14 | 15 | \x. pred (S x) = \x. x; 16 | pred O = O; 17 | 18 | val subtr = \m n. _NATit n m (\x. pred x); 19 | 20 | \x y. subtr x (S y) = \x y. pred (subtr x y); 21 | \x. subtr x O = \x. x; 22 | 23 | val is_zero = \x. _NATit x True (\x. False); 24 | val is_one = \x. if is_zero x then False else is_zero (pred x); 25 | 26 | is_zero O = True; 27 | \x. is_zero (S x) = \x. False; 28 | 29 | val le = \m n. is_zero (subtr m n); 30 | val eq = \x. _NATit x is_zero (\f. 31 | \y. 32 | if is_zero y then False 33 | else f (pred y)); 34 | 35 | \x y. eq (S x) (S y) = \x y. eq x y; 36 | eq O O = True; 37 | \x. eq (S x) O = \x. False; 38 | \x. eq O (S x) = \x. False; 39 | 40 | (* 41 | eq (S x) = 42 | \y. if is_zero y then False 43 | else eq x (pred y) 44 | 45 | eq O = is_zero 46 | (S y) = \x y. eq x y; 47 | eq (S x) O = \x. False; 48 | eq O O = True; 49 | \x. eq O (S x) = \x. False; 50 | *) 51 | 52 | val n2 = (S (S O)); 53 | val n3 = (S (S (S O))); 54 | val n4 = (S (S (S (S O)))); 55 | val n5 = (S (S (S (S (S O))))); 56 | 57 | val divmod = \m n. _NATit m (O, O) (\p. 58 | if is_one (subtr n (snd p)) then 59 | (S (fst p), O) 60 | else 61 | (fst p, S (snd p))); 62 | 63 | (*divmod n5 n2;*) 64 | 65 | \m. divmod O m = \m. (O, O); 66 | \m n. divmod (S m) n = \m n. 67 | (\p. 68 | if is_one (subtr n (snd p)) then 69 | (S (fst p), O) 70 | else 71 | (fst p, S (snd p))) (divmod m n); 72 | 73 | val div = \x y. fst (divmod x y); 74 | val mod = \x y. fst (divmod x y); 75 | 76 | divmod n2 O; 77 | divmod n2 O = (O, n2); 78 | divmod n3 O = (O, n3); 79 | 80 | \m. div m O = O; 81 | \m. mod m O = O; 82 | 83 | codatatype STREAM 'a = Shd to 'a & Stl to STREAM 'a; 84 | val smap = \f s. _STREAMci (\s. f (Shd s)) Stl s; 85 | val natstr = \n. _STREAMci (\x. x) S n; 86 | val sprefix = \x s. _STREAMci (\a. when a fst Shd) (\a. Inr (when a snd Stl)) (Inl (x, s)); 87 | 88 | val fib = \n. snd (_NATit n (S O, O) (\p. (add (fst p) (snd p), fst p))); 89 | 90 | fib O = O; 91 | fib (S O) = S O; 92 | \n. fib (S (S n)) = \n. add (fib (S n)) (fib n); 93 | 94 | (* vim: ft=sml 95 | *) 96 | -------------------------------------------------------------------------------- /src/v3/examples/poly.et: -------------------------------------------------------------------------------- 1 | \x. let val x = fst x; in True end; 2 | \x. let val f = \y. y; in (f True, f x) end; 3 | \x. let val f = \y. (fst x, y); in (f True, f ()) end; 4 | -------------------------------------------------------------------------------- /src/v3/lambda.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | open Ast 34 | open Util 35 | 36 | let xf = Printf.sprintf 37 | let pf = Printf.printf 38 | 39 | type var = int 40 | 41 | let gen_var = 42 | let cnt = ref 1 in 43 | fun () -> 44 | assert (!cnt < 1000000000); incr cnt; !cnt 45 | 46 | let rf x = Var x 47 | 48 | let rec lambda x y = 49 | match x with 50 | | [] -> y 51 | | x :: xs -> Abs (x, lambda xs y) 52 | 53 | let rec app = function 54 | | [] -> assert false 55 | | [x] -> x 56 | | x1 :: x2 :: xs -> app (App (x1, x2) :: xs) 57 | 58 | let var_vect lst = List.map (fun x -> gen_var (), x) lst 59 | 60 | let freshen t = 61 | let rec f map = function 62 | | App (t1, t2) -> 63 | App (f map t1, f map t2) 64 | | Abs (k, t) -> 65 | let k' = gen_var () in 66 | Abs (k', f (Intmap.add k k' map) t) 67 | | Var n when Intmap.mem n map -> Var (Intmap.find n map) 68 | | t -> t 69 | in f Intmap.empty t 70 | 71 | let complete_development t = 72 | let rec f sub = function 73 | | App (Abs (k, t1), t2) -> 74 | let (_, t2') = f sub t2 in 75 | (true, snd (f (Intmap.add k t2' sub) (freshen t1))) 76 | 77 | | App (Value ({val_semantics = Eliminator tc} as ev), t) -> 78 | let (did, t) = f sub t in 79 | let rec find_ctor acc = function 80 | | App (t, t') -> find_ctor (t' :: acc) t 81 | | Value ({val_semantics = Constructor tc'} as cv) when tc == tc' -> 82 | let our_rule r = r.r_elim == ev && r.r_ctor == cv in 83 | Some (List.find our_rule tc.tc_rules, acc) 84 | | _ -> None 85 | in 86 | begin 87 | match find_ctor [] t with 88 | | Some (r, args) when List.length args == List.length r.r_vars -> 89 | let rec add_subst sub = function 90 | | (v :: vs, a :: args) -> add_subst (Intmap.add v a sub) (vs, args) 91 | | ([], []) -> sub 92 | | _ -> assert false 93 | in 94 | let sub = add_subst Intmap.empty (r.r_vars, args) in 95 | (true, snd (f sub (freshen r.r_value))) 96 | | _ -> (did, App (Value ev, t)) 97 | end 98 | 99 | | App (t1, t2) -> 100 | let (did1, t1') = f sub t1 in 101 | let (did2, t2') = f sub t2 in 102 | (did1 || did2, App (t1', t2')) 103 | 104 | | Var k when Intmap.mem k sub -> (false, Intmap.find k sub) 105 | 106 | | Abs (k, t) -> 107 | let rec is_fv = function 108 | | App (t1, t2) -> is_fv t1 || is_fv t2 109 | | Abs (n, t) -> n != k && is_fv t 110 | | Var n -> n == k 111 | | Value _ -> false 112 | in 113 | let (did, t') = f sub t in 114 | begin 115 | match t' with 116 | | App (t, Var k') when k == k' && not (is_fv t) -> (true, t) 117 | | _ -> (did, Abs (k, t')) 118 | end 119 | 120 | | (Var _ as t) | (Value _ as t) -> (false, t) 121 | in f Intmap.empty t 122 | 123 | let nf t = 124 | let rec f t = 125 | (* let () = pf "bn: %s -> " (Pp.string_of_lambda t) in*) 126 | let (didsth, t') = complete_development t in 127 | (* let () = pf "%s\n" (Pp.string_of_lambda t') in *) 128 | if didsth then f t' else t' 129 | in f t 130 | 131 | exception Different 132 | 133 | let eq t1 t2 = 134 | let rec f m = function 135 | | App (t1, t2), App (t1', t2') -> 136 | f (f m (t1, t1')) (t2, t2') 137 | | Abs (k, t), Abs (k', t') -> 138 | f (Intmap.add k' k m) (t, t') 139 | | Var k, Var k' when k == Intmap.find k' m -> m 140 | | Value v, Value v' when v == v' -> m 141 | | _ -> raise Different 142 | in 143 | try 144 | let _ = f Intmap.empty (t1, t2) in 145 | true 146 | with Different -> false 147 | 148 | let make_rule elim con vars t = 149 | {r_vars = vars; 150 | r_elim = elim; 151 | r_ctor = con; 152 | r_value = nf t} 153 | -------------------------------------------------------------------------------- /src/v3/lambda.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | open Ast 34 | 35 | type var 36 | 37 | val lambda : var list -> term -> term 38 | val gen_var : unit -> var 39 | val rf : var -> term 40 | val app : term list -> term 41 | val var_vect : 'a list -> (var * 'a) list 42 | val nf : term -> term 43 | val make_rule : value -> value -> var list -> term -> rule 44 | val eq : term -> term -> bool 45 | -------------------------------------------------------------------------------- /src/v3/lexer.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2002, 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | (* 34 | * Copyright (c) 2002, 2003 The University of Wroclaw. 35 | * All rights reserved. See file COPYRIGHT for details about licensing. 36 | *) 37 | 38 | exception Error of string * int * int * string 39 | exception Eof 40 | 41 | val get_file_name : unit -> string 42 | val set_file_name : string -> unit 43 | val get_line_column : string -> int -> (int * int) 44 | val get_current_location : unit -> (string * int * int) 45 | 46 | val token : Lexing.lexbuf -> Parser.token 47 | -------------------------------------------------------------------------------- /src/v3/lexer.mll: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2002, 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | (* 34 | * Copyright (c) 2002, 2003 The University of Wroclaw. 35 | * All rights reserved. See file COPYRIGHT for details about licensing. 36 | *) 37 | 38 | { 39 | 40 | open Parser (* The type token is defined in parser.mli *) 41 | 42 | type lexer_location = {mutable ll_char : int; 43 | mutable ll_file : string} 44 | type global_lexer = {mutable gl_lexbuf : Lexing.lexbuf option} 45 | 46 | let comment_depth = ref 0 47 | let comment_start = {ll_file = ""; ll_char = 0} 48 | let current_location = {ll_file = "stdin"; ll_char = 0} 49 | 50 | let global_lexer = {gl_lexbuf = None} 51 | 52 | let line_caches : (string, int list ref) Hashtbl.t = Hashtbl.create 16 53 | 54 | (* exported *) 55 | exception Error of string * int * int * string 56 | exception Eof 57 | 58 | let get_file_name () = current_location.ll_file 59 | let set_file_name s = current_location.ll_file <- s 60 | let get_line_column file_name char_no = 61 | try 62 | let stack = Hashtbl.find line_caches file_name in 63 | let rec helper lst = 64 | match lst with 65 | x::xs -> 66 | if char_no >= x then 67 | (x, (List.length xs) + 1) 68 | else 69 | helper xs 70 | | [] -> 71 | (0, 1) in 72 | let (beg, line) = helper !stack in 73 | (line, char_no - beg + 1) 74 | with Not_found -> (1, char_no + 1) 75 | 76 | let get_current_location () = 77 | let (l, c) = 78 | match global_lexer with 79 | | {gl_lexbuf = None} -> 80 | get_line_column (get_file_name ()) 1 81 | | {gl_lexbuf = Some lexbuf} -> 82 | get_line_column (get_file_name ()) 83 | (Lexing.lexeme_end lexbuf) in 84 | (get_file_name (), l, c) 85 | (* /exported *) 86 | 87 | let next_line lexbuf = 88 | global_lexer.gl_lexbuf <- Some lexbuf; 89 | let stack = 90 | try 91 | Hashtbl.find line_caches (get_file_name ()) 92 | with Not_found -> 93 | let lst = ref [0] in 94 | Hashtbl.add line_caches (get_file_name ()) lst; lst 95 | in 96 | stack := ((Lexing.lexeme_end lexbuf)) :: !stack 97 | 98 | } 99 | 100 | let nl = ('\r' '\n' | '\n' | '\r') 101 | 102 | let num = ['0'-'9'] 103 | 104 | let upper = ['A' - 'Z'] 105 | let lower = ['a' - 'z'] 106 | let id_body = (upper | lower | num | "_" | "'") 107 | 108 | rule token = parse 109 | [' ' '\t'] { token lexbuf } (* skip blanks *) 110 | | nl { next_line lexbuf; token lexbuf } 111 | | '"' [^ '"']* '"' 112 | { let s = Lexing.lexeme lexbuf in 113 | STRING (String.sub s 1 (String.length s - 2)) } 114 | | "fn" { KW_FN } 115 | | "set" { KW_SET } 116 | | "val" { KW_VAL } 117 | | "let" { KW_LET } 118 | | "in" { KW_IN } 119 | | "end" { KW_END } 120 | | "datatype" { KW_DATATYPE } 121 | | "from" { KW_FROM } 122 | | "codatatype" { KW_CODATATYPE } 123 | | "to" { KW_TO } 124 | | "use" { KW_USE } 125 | | "exit" { KW_EXIT } 126 | | "quit" { KW_EXIT } 127 | | "show" { KW_SHOW } 128 | | "if" { KW_IF } 129 | | "then" { KW_THEN } 130 | | "else" { KW_ELSE } 131 | | upper id_body * 132 | { UPPER_ID(Lexing.lexeme lexbuf) } 133 | | (lower | "_") id_body * 134 | { LOWER_ID(Lexing.lexeme lexbuf) } 135 | | "'" (lower | upper) id_body* 136 | { TYVAR(Lexing.lexeme lexbuf) } 137 | | "(*" { comment_depth := 1; 138 | comment_start.ll_file <- get_file_name (); 139 | comment_start.ll_char <- (Lexing.lexeme_start lexbuf); 140 | comment lexbuf; 141 | token lexbuf } 142 | | "#" [^ '\n' '\r']* nl { next_line lexbuf; token lexbuf } 143 | | "(" { LPAREN } 144 | | ")" { RPAREN } 145 | | "{" { LBRACE } 146 | | "}" { RBRACE } 147 | | "=>" { DARROW } 148 | | "->" { ARROW } 149 | | "," { COMMA } 150 | | "=" { EQ } 151 | | ";" { SEMICOLON } 152 | | "*" { STAR } 153 | | "+" { PLUS } 154 | | "\\" { LAMBDA } 155 | | "." { DOT } 156 | | "|" { BAR } 157 | | "&" { AND } 158 | | eof { raise Eof } 159 | | _ 160 | { let (f, l, c) = get_current_location () in 161 | raise (Error(f, l, c, "invalid character in input `" ^ 162 | (String.escaped (Lexing.lexeme lexbuf)) ^ "'")) } 163 | 164 | and comment = parse 165 | "*)" { decr comment_depth; 166 | if !comment_depth > 0 then (comment lexbuf) } 167 | | "(*" { incr comment_depth; comment lexbuf } 168 | | nl { next_line lexbuf; comment lexbuf } 169 | | eof { 170 | let (l, c) = get_line_column comment_start.ll_file 171 | comment_start.ll_char in 172 | raise (Error (comment_start.ll_file, l, c, "EOF within comment")) } 173 | | _ { comment lexbuf } 174 | 175 | -------------------------------------------------------------------------------- /src/v3/main.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2002, 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | open Ast 34 | open Util 35 | 36 | let first_mark = ref true 37 | let log_file = ref None 38 | 39 | let channel_reader ch buf s n = 40 | if !buf <> "" then 41 | let len = (min (String.length !buf) n) in 42 | let () = String.blit !buf 0 s 0 len in 43 | let () = buf := String.sub !buf len (String.length !buf - len) in 44 | len 45 | else 46 | let () = 47 | if ch == stdin then 48 | print_verbose (if !first_mark then "+ " else "= ") 49 | in 50 | let () = flush stdout in 51 | let l = 52 | try (input_line ch) ^ "\n" 53 | with End_of_file -> raise Lexer.Eof in 54 | let () = 55 | match !log_file with 56 | | None -> () 57 | | Some ch -> output_string ch l 58 | in 59 | let () = 60 | if ch != stdin then 61 | print_verbose ((if !first_mark then "+ " else "= ") ^ l) 62 | in 63 | let () = first_mark := false in 64 | let ll = String.length l in 65 | if ll <= n then 66 | let () = String.blit l 0 s 0 ll in 67 | ll 68 | else 69 | let () = String.blit l 0 s 0 n in 70 | let () = buf := String.sub l n (ll - n) in 71 | n 72 | 73 | let parse_decl lexbuf = 74 | begin 75 | first_mark := true; 76 | try 77 | let d = Parser.decl Lexer.token lexbuf in 78 | d 79 | with 80 | | Lexer.Error (fn, l, c, msg) -> 81 | raise (Error ({loc_file = fn; loc_line = l; loc_char = c}, msg)) 82 | | Parsing.Parse_error -> 83 | let (fn, l, c) = Lexer.get_current_location () in 84 | raise (Error ({loc_file = fn; loc_line = l; loc_char = c}, 85 | "parse error")) 86 | end 87 | 88 | let handle_file env name = 89 | let f = 90 | try 91 | open_in name 92 | with _ -> 93 | raise (Unlocated_error ("error opening input file: `" ^ name ^ "'")) 94 | in 95 | let lexbuf = Lexing.from_function (channel_reader f (ref "")) in 96 | let rec eval env = 97 | try 98 | let d = parse_decl lexbuf in 99 | let env = Eval.eval_decl env d in 100 | eval env 101 | with 102 | | Error (l, m) -> 103 | let () = report_error l m in 104 | env 105 | | Unlocated_error m -> 106 | let (fn, l, c) = Lexer.get_current_location () in 107 | let () = report_error {loc_file = fn; loc_line = l; loc_char = c} m in 108 | env 109 | | Lexer.Eof -> 110 | let () = print_verbose "EOF.\n" in 111 | env 112 | in 113 | let old_name = Lexer.get_file_name () in 114 | let () = Lexer.set_file_name name in 115 | let env = eval env in 116 | let () = close_in f in 117 | let () = Lexer.set_file_name old_name in 118 | env 119 | 120 | let rec read_eval = 121 | let lexbuf = Lexing.from_function (channel_reader stdin (ref "")) in 122 | fun env -> 123 | if false then () else (* XXX: hack. *) 124 | try 125 | let d = parse_decl lexbuf in 126 | (* let () = Pp.print_decl d in *) 127 | match d.v with 128 | | Use_cmd fn -> read_eval (handle_file env fn) 129 | | _ -> 130 | let env = Eval.eval_decl env d in 131 | read_eval env 132 | with 133 | | Error (l, m) -> 134 | let () = report_error l m in 135 | read_eval env 136 | | Unlocated_error m -> 137 | let (fn, l, c) = Lexer.get_current_location () in 138 | let () = report_error {loc_file = fn; loc_line = l; loc_char = c} m in 139 | read_eval env 140 | 141 | let interactive env = 142 | try 143 | log_file := Some (open_out "session.et"); 144 | read_eval env 145 | with Lexer.Eof -> 146 | let () = print_endline "\nPaka." in 147 | exit 0 148 | 149 | let main () = 150 | let () = 151 | if Array.length Sys.argv > 2 then 152 | begin 153 | prerr_endline ("USAGE: " ^ Sys.argv.(0) ^ " [filename.et]"); 154 | exit 1 155 | end 156 | in 157 | let () = quiet := true in 158 | let env = handle_file Env.empty_env "startup.et" in 159 | let () = quiet := false in 160 | if Array.length Sys.argv == 1 then interactive env 161 | else ignore (handle_file env Sys.argv.(1)) 162 | 163 | let _ = main () 164 | -------------------------------------------------------------------------------- /src/v3/pp.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | open Ast 34 | 35 | val print_decl : decl -> unit 36 | val string_of_ty : ty -> string 37 | val string_of_term : term -> string 38 | val string_of_rule : rule -> string 39 | -------------------------------------------------------------------------------- /src/v3/startup.et: -------------------------------------------------------------------------------- 1 | datatype PAIR 'a 'b = Pair from 'a 'b; 2 | datatype BOTTOM = ; 3 | datatype BOOL = True | False; 4 | datatype UNION 'a 'b = Inl from 'a | Inr from 'b; 5 | datatype UNIT = Unit; 6 | 7 | val fst = \p. _PAIRit p (\x y. x); 8 | val snd = \p. _PAIRit p (\x y. y); 9 | val when = _UNIONit; 10 | val case0 = _BOTTOMit; 11 | val case1 = _UNITit; 12 | 13 | (* vim: ft=sml 14 | *) 15 | -------------------------------------------------------------------------------- /src/v3/tests/ex1.et.out: -------------------------------------------------------------------------------- 1 | + datatype NAT = S from NAT | O; 2 | datatype NAT 3 | con S : NAT -> NAT 4 | con O : NAT 5 | iter _NATit : NAT -> ('a -> 'a) -> 'a -> 'a 6 | rec _NATrec : NAT -> ((NAT * 'a) -> 'a) -> 'a -> 'a 7 | comp _NATit (S z) = \y x. y (_NATit z y x) 8 | comp _NATit (O ) = \z y. y 9 | comp _NATrec (S z) = \y x. y (z, _NATrec z y x) 10 | comp _NATrec (O ) = \z y. y 11 | 12 | + 13 | = val le = fn u => _NATit u (fn y v => _NATrec v (fn x => y (fst x)) False) 14 | = (fn v => True); 15 | val le : NAT -> NAT -> BOOL 16 | + 17 | = (fn v => le O v) = (fn v => True); 18 | True : BOOL 19 | + (fn u v => le (S u) O) = (fn u v => False); 20 | True : BOOL 21 | + (fn u v => le (S u) (S v)) = (fn u v => le u v); 22 | True : BOOL 23 | + 24 | = datatype LIST 'a = Cons from 'a (LIST 'a) | Nil; 25 | datatype LIST 26 | con Cons : 'a -> (LIST 'a) -> (LIST 'a) 27 | con Nil : LIST 'a 28 | iter _LISTit : (LIST 'a) -> ('a -> 'b -> 'b) -> 'b -> 'b 29 | rec _LISTrec : (LIST 'a) -> ('a -> ((LIST 'a) * 'b) -> 'b) -> 'b -> 'b 30 | comp _LISTit (Cons z y) = \x w. x z (_LISTit y x w) 31 | comp _LISTit (Nil ) = \z y. y 32 | comp _LISTrec (Cons z y) = \x w. x z (y, _LISTrec y x w) 33 | comp _LISTrec (Nil ) = \z y. y 34 | 35 | + val tl = fn xs => _LISTrec xs (fn h p => fst p) Nil; 36 | val tl : (LIST 'a) -> (LIST 'a) 37 | + datatype HDexception = Hd; 38 | datatype HDexception 39 | con Hd : HDexception 40 | iter _HDexceptionit : HDexception -> 'a -> 'a 41 | rec _HDexceptionrec = _HDexceptionit 42 | comp _HDexceptionit (Hd ) = \z. z 43 | 44 | + val hd = fn xs => _LISTit xs (fn h t => Inl h) (Inr Hd); 45 | val hd : (LIST 'a) -> ('a + HDexception) 46 | + val append = fn xs ys => _LISTit xs Cons ys; 47 | val append : (LIST 'a) -> (LIST 'a) -> (LIST 'a) 48 | + 49 | = datatype BT 'a = Node from 'a (BT 'a) (BT 'a) | Tip; 50 | datatype BT 51 | con Node : 'a -> (BT 'a) -> (BT 'a) -> (BT 'a) 52 | con Tip : BT 'a 53 | iter _BTit : (BT 'a) -> ('a -> 'b -> 'b -> 'b) -> 'b -> 'b 54 | rec _BTrec : (BT 'a) -> ('a -> ((BT 'a) * 'b) -> ((BT 'a) * 'b) -> 'b) -> 'b -> 'b 55 | comp _BTit (Node z y x) = \w v. w z (_BTit y w v) (_BTit x w v) 56 | comp _BTit (Tip ) = \z y. y 57 | comp _BTrec (Node z y x) = \w v. w z (y, _BTrec y w v) (x, _BTrec x w v) 58 | comp _BTrec (Tip ) = \z y. y 59 | 60 | + val toBST = fn x t => _BTrec t (fn a lp rp => 61 | = if le x a then Node a (snd lp) (fst rp) 62 | = else Node a (fst lp) (snd rp)) (Node x Tip Tip); 63 | val toBST : NAT -> (BT NAT) -> (BT NAT) 64 | + 65 | = val listToBST = fn xs => _LISTit xs toBST Tip; 66 | val listToBST : (LIST NAT) -> (BT NAT) 67 | + 68 | = val inorder = fn t => _BTit t (fn a l r => append l (Cons a r)) Nil; 69 | val inorder : (BT 'a) -> (LIST 'a) 70 | + 71 | = val quicksort = fn xs => inorder (listToBST xs); 72 | val quicksort : (LIST NAT) -> (LIST NAT) 73 | + 74 | = val one = S O; 75 | val one : NAT 76 | + val two = S one; 77 | val two : NAT 78 | + val three = S two; 79 | val three : NAT 80 | + val l = Cons two (Cons one (Cons three (Cons O Nil))); 81 | val l : LIST NAT 82 | + quicksort l; 83 | Cons O (Cons (S O) (Cons (S (S O)) (Cons (S (S (S O))) Nil))) : LIST NAT 84 | + 85 | = (* vim: ft=sml 86 | = *) 87 | EOF. 88 | -------------------------------------------------------------------------------- /src/v3/tests/ex2.et.out: -------------------------------------------------------------------------------- 1 | + datatype CHAR = A|B|C|D|E|F|G|H|I|J|K|L|M; 2 | datatype CHAR 3 | con A : CHAR 4 | con B : CHAR 5 | con C : CHAR 6 | con D : CHAR 7 | con E : CHAR 8 | con F : CHAR 9 | con G : CHAR 10 | con H : CHAR 11 | con I : CHAR 12 | con J : CHAR 13 | con K : CHAR 14 | con L : CHAR 15 | con M : CHAR 16 | iter _CHARit : CHAR -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a -> 'a 17 | rec _CHARrec = _CHARit 18 | comp _CHARit (A ) = \z y x w v u t s r q p o n. z 19 | comp _CHARit (B ) = \z y x w v u t s r q p o n. y 20 | comp _CHARit (C ) = \z y x w v u t s r q p o n. x 21 | comp _CHARit (D ) = \z y x w v u t s r q p o n. w 22 | comp _CHARit (E ) = \z y x w v u t s r q p o n. v 23 | comp _CHARit (F ) = \z y x w v u t s r q p o n. u 24 | comp _CHARit (G ) = \z y x w v u t s r q p o n. t 25 | comp _CHARit (H ) = \z y x w v u t s r q p o n. s 26 | comp _CHARit (I ) = \z y x w v u t s r q p o n. r 27 | comp _CHARit (J ) = \z y x w v u t s r q p o n. q 28 | comp _CHARit (K ) = \z y x w v u t s r q p o n. p 29 | comp _CHARit (L ) = \z y x w v u t s r q p o n. o 30 | comp _CHARit (M ) = \z y x w v u t s r q p o n. n 31 | 32 | + datatype LIST 'a = Nil | Cons from 'a (LIST 'a); 33 | datatype LIST 34 | con Nil : LIST 'a 35 | con Cons : 'a -> (LIST 'a) -> (LIST 'a) 36 | iter _LISTit : (LIST 'a) -> 'b -> ('a -> 'b -> 'b) -> 'b 37 | rec _LISTrec : (LIST 'a) -> 'b -> ('a -> ((LIST 'a) * 'b) -> 'b) -> 'b 38 | comp _LISTit (Nil ) = \z y. z 39 | comp _LISTit (Cons z y) = \x w. w z (_LISTit y x w) 40 | comp _LISTrec (Nil ) = \z y. z 41 | comp _LISTrec (Cons z y) = \x w. w z (y, _LISTrec y x w) 42 | 43 | + datatype TREE 'a = Leaf from 'a | Node from 'a (TREE 'a) (TREE 'a); 44 | datatype TREE 45 | con Leaf : 'a -> (TREE 'a) 46 | con Node : 'a -> (TREE 'a) -> (TREE 'a) -> (TREE 'a) 47 | iter _TREEit : (TREE 'a) -> ('a -> 'b) -> ('a -> 'b -> 'b -> 'b) -> 'b 48 | rec _TREErec : (TREE 'a) -> ('a -> 'b) -> ('a -> ((TREE 'a) * 'b) -> ((TREE 'a) * 'b) -> 'b) -> 'b 49 | comp _TREEit (Leaf z) = \y x. y z 50 | comp _TREEit (Node z y x) = \w v. v z (_TREEit y w v) (_TREEit x w v) 51 | comp _TREErec (Leaf z) = \y x. y z 52 | comp _TREErec (Node z y x) = \w v. v z (y, _TREErec y w v) (x, _TREErec x w v) 53 | 54 | + datatype CONT 'a = DC | CC from ((CONT 'a) -> LIST 'a) -> LIST 'a; 55 | datatype CONT 56 | con DC : CONT 'a 57 | con CC : (((CONT 'a) -> (LIST 'a)) -> (LIST 'a)) -> (CONT 'a) 58 | iter _CONTit : (CONT 'a) -> 'b -> ((('b -> (LIST 'a)) -> (LIST 'a)) -> 'b) -> 'b 59 | rec _CONTrec : (CONT 'a) -> 'b -> (((((CONT 'a) * 'b) -> (LIST 'a)) -> (LIST 'a)) -> 'b) -> 'b 60 | comp _CONTit (DC ) = \z y. z 61 | comp _CONTit (CC z) = \y x. x (\w. z (\v. w (_CONTit v y x))) 62 | comp _CONTrec (DC ) = \z y. z 63 | comp _CONTrec (CC z) = \y x. x (\w. z (\v. w (v, _CONTrec v y x))) 64 | 65 | + val o = fn g f x => g (f x); 66 | val o : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b 67 | + val apply = fn k => _CONTit k (fn g => g DC) 68 | = (fn h g => h (fn f => g (CC f))); 69 | val apply : (CONT 'a) -> ((CONT 'a) -> (LIST 'a)) -> (LIST 'a) 70 | + val breadth = fn t => _TREEit t 71 | = (fn a now => CC (fn later => Cons a (apply now later))) 72 | = (fn a brl brr now => CC (fn later => Cons a (apply now (o later (o brl brr))))); 73 | val breadth : (TREE 'a) -> (CONT 'a) -> (CONT 'a) 74 | + 75 | = val extract = fn k => _CONTit k Nil (fn f => f (fn l => l)); 76 | val extract : (CONT 'a) -> (LIST 'a) 77 | + 78 | = val run = fn t => extract (breadth t DC); 79 | val run : (TREE 'a) -> (LIST 'a) 80 | + 81 | = val t = Node A 82 | = (Node B 83 | = (Node D (Leaf H) (Leaf I)) 84 | = (Node E (Leaf J) (Leaf K)) 85 | = ) 86 | = (Node C 87 | = (Leaf F) 88 | = (Node G (Leaf L) (Leaf M)) 89 | = ); 90 | val t : TREE CHAR 91 | + run t; 92 | Cons A (Cons B (Cons C (Cons D (Cons E (Cons F (Cons G (Cons H (Cons I (Cons J (Cons K (Cons L (Cons M Nil)))))))))))) : LIST CHAR 93 | + 94 | = (* vim: ft=sml *) 95 | EOF. 96 | -------------------------------------------------------------------------------- /src/v3/tests/ex3.et.out: -------------------------------------------------------------------------------- 1 | + datatype NAT = S from NAT | O; 2 | datatype NAT 3 | con S : NAT -> NAT 4 | con O : NAT 5 | iter _NATit : NAT -> ('a -> 'a) -> 'a -> 'a 6 | rec _NATrec : NAT -> ((NAT * 'a) -> 'a) -> 'a -> 'a 7 | comp _NATit (S z) = \y x. y (_NATit z y x) 8 | comp _NATit (O ) = \z y. y 9 | comp _NATrec (S z) = \y x. y (z, _NATrec z y x) 10 | comp _NATrec (O ) = \z y. y 11 | 12 | + codatatype STREAM 'a = Shd to 'a & Stl to STREAM 'a; 13 | codatatype STREAM 14 | des Shd : (STREAM 'a) -> 'a 15 | des Stl : (STREAM 'a) -> (STREAM 'a) 16 | coiter _STREAMci : ('b -> 'a) -> ('b -> 'b) -> 'b -> (STREAM 'a) 17 | corec _STREAMcr : ('b -> 'a) -> ('b -> ((STREAM 'a) + 'b)) -> 'b -> (STREAM 'a) 18 | comp Shd (_STREAMci z y x) = z x 19 | comp Stl (_STREAMci z y x) = _STREAMci z y (y x) 20 | comp Shd (_STREAMcr z y x) = z x 21 | comp Stl (_STREAMcr z y x) = when (y x) (\w. w) (_STREAMcr z y) 22 | 23 | + val smap = fn f s => _STREAMci (fn x => f (Shd x)) Stl s; 24 | val smap : ('a -> 'b) -> (STREAM 'a) -> (STREAM 'b) 25 | + val natstr = fn n => _STREAMci (fn x => x) S n; 26 | val natstr : NAT -> (STREAM NAT) 27 | + val sprefix = fn h s => _STREAMcr (fn x => h) (fn x => Inl s) s; 28 | val sprefix : 'a -> (STREAM 'a) -> (STREAM 'a) 29 | + val ns = natstr O; 30 | val ns : STREAM NAT 31 | + Shd ns; 32 | O : NAT 33 | + Shd (Stl ns); 34 | S O : NAT 35 | + val ns' = sprefix (S (S O)) ns; 36 | val ns' : STREAM NAT 37 | + Shd ns'; 38 | S (S O) : NAT 39 | + Shd (Stl ns'); 40 | O : NAT 41 | + 42 | = (* vim: ft=sml 43 | = *) 44 | EOF. 45 | -------------------------------------------------------------------------------- /src/v3/tests/ex4.et.out: -------------------------------------------------------------------------------- 1 | + datatype Z 'a = InZ from 'a -> Z 'a; 2 | datatype Z 3 | con InZ : ('a -> (Z 'a)) -> (Z 'a) 4 | iter _Zit : (Z 'a) -> (('a -> 'b) -> 'b) -> 'b 5 | rec _Zrec : (Z 'a) -> (('a -> ((Z 'a) * 'b)) -> 'b) -> 'b 6 | comp _Zit (InZ z) = \y. y (\x. _Zit (z x) y) 7 | comp _Zrec (InZ z) = \y. y (\x. z x, _Zrec (z x) y) 8 | 9 | + datatype Y 'a = InY from (Z 'a) -> Y 'a; 10 | datatype Y 11 | con InY : ((Z 'a) -> (Y 'a)) -> (Y 'a) 12 | iter _Yit : (Y 'a) -> (((Z 'a) -> 'b) -> 'b) -> 'b 13 | rec _Yrec : (Y 'a) -> (((Z 'a) -> ((Y 'a) * 'b)) -> 'b) -> 'b 14 | comp _Yit (InY z) = \y. y (\x. _Yit (z x) y) 15 | comp _Yrec (InY z) = \y. y (\x. z x, _Yrec (z x) y) 16 | 17 | + datatype X = InX from (Y X); 18 | datatype X 19 | con InX : (Y X) -> X 20 | iter _Xit : X -> ((Y 'a) -> 'a) -> 'a 21 | rec _Xrec : X -> ((Y (X * 'a)) -> 'a) -> 'a 22 | comp _Xit (InX z) = \y. y (_Yit z (\x. InY (\w. x (_Zit w (\v. InZ (\u. v (_Xit u y))))))) 23 | comp _Xrec (InX z) = \y. y (_Yrec z (\x. InY (\w. snd (x (_Zit w (\v. InZ (\u. snd (v (u, _Xrec u y))))))))) 24 | 25 | EOF. 26 | -------------------------------------------------------------------------------- /src/v3/tests/ex5.et.out: -------------------------------------------------------------------------------- 1 | + codatatype Z2 'a = OutZ2 to ('a -> Z2 'a); 2 | codatatype Z2 3 | des OutZ2 : (Z2 'a) -> 'a -> (Z2 'a) 4 | coiter _Z2ci : ('b -> 'a -> 'b) -> 'b -> (Z2 'a) 5 | corec _Z2cr : ('b -> 'a -> ((Z2 'a) + 'b)) -> 'b -> (Z2 'a) 6 | comp OutZ2 (_Z2ci z y) = \x. _Z2ci z (z y x) 7 | comp OutZ2 (_Z2cr z y) = \x. when (z y x) (\w. w) (_Z2cr z) 8 | 9 | + codatatype Y2 'a = OutY2 to ((Z2 'a) -> Y2 'a) ; 10 | codatatype Y2 11 | des OutY2 : (Y2 'a) -> (Z2 'a) -> (Y2 'a) 12 | coiter _Y2ci : ('b -> (Z2 'a) -> 'b) -> 'b -> (Y2 'a) 13 | corec _Y2cr : ('b -> (Z2 'a) -> ((Y2 'a) + 'b)) -> 'b -> (Y2 'a) 14 | comp OutY2 (_Y2ci z y) = \x. _Y2ci z (z y x) 15 | comp OutY2 (_Y2cr z y) = \x. when (z y x) (\w. w) (_Y2cr z) 16 | 17 | + (* We had a bug here. *) 18 | = codatatype X2 = OutX2 to (Y2 X2); 19 | codatatype X2 20 | des OutX2 : X2 -> (Y2 X2) 21 | coiter _X2ci : ('a -> (Y2 'a)) -> 'a -> X2 22 | corec _X2cr : ('a -> (Y2 (X2 + 'a))) -> 'a -> X2 23 | comp OutX2 (_X2ci z y) = _Y2ci (\x w. OutY2 x (_Z2ci (\v u. OutZ2 v (_X2ci z u)) w)) (z y) 24 | comp OutX2 (_X2cr z y) = _Y2cr (\x w. Inr (OutY2 x (_Z2cr (\v u. Inr (OutZ2 v (when u (\t. t) (_X2cr z)))) w))) (z y) 25 | 26 | EOF. 27 | -------------------------------------------------------------------------------- /src/v3/tests/iplbyex.et.out: -------------------------------------------------------------------------------- 1 | + val f1 = \p q r. p r; 2 | val f1 : ('a -> 'b) -> 'c -> 'a -> 'b 3 | + f1; 4 | \z y. z : ('a -> 'b) -> 'c -> 'a -> 'b 5 | + \x y z. x z = f1; 6 | True : BOOL 7 | + val s = \f g x. f x (g x); 8 | val s : ('a -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'c 9 | + val k = \x y. x; 10 | val k : 'a -> 'b -> 'a 11 | + s k k; 12 | \z. z : 'a -> 'a 13 | + val i = let val ss = \f g x. f x (g x); 14 | = val kk = \x y. x; 15 | = in ss kk kk end; 16 | val ss : ('a -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'c 17 | val kk : 'a -> 'b -> 'a 18 | val i : 'a -> 'a 19 | + i; 20 | \z. z : 'a -> 'a 21 | EOF. 22 | -------------------------------------------------------------------------------- /src/v3/tests/iplbyex2.et.out: -------------------------------------------------------------------------------- 1 | + datatype PROD1 'a 'b = Pair' from 'a 'b; 2 | datatype PROD1 3 | con Pair' : 'a -> 'b -> (PROD1 'a 'b) 4 | iter _PROD1it : (PROD1 'a 'b) -> ('a -> 'b -> 'c) -> 'c 5 | rec _PROD1rec = _PROD1it 6 | comp _PROD1it (Pair' z y) = \x. x z y 7 | 8 | + codatatype PROD2 'a 'b = Fst to 'a & Snd to 'b; 9 | codatatype PROD2 10 | des Fst : (PROD2 'a 'b) -> 'a 11 | des Snd : (PROD2 'a 'b) -> 'b 12 | coiter _PROD2ci : ('c -> 'a) -> ('c -> 'b) -> 'c -> (PROD2 'a 'b) 13 | corec _PROD2cr = _PROD2ci 14 | comp Fst (_PROD2ci z y x) = z x 15 | comp Snd (_PROD2ci z y x) = y x 16 | 17 | + val pair = \x y. _PROD2ci (\z. x) (\z. y) True; 18 | val pair : 'a -> 'b -> (PROD2 'a 'b) 19 | + val split = \p z. z (Fst p) (Snd p); 20 | val split : (PROD2 'a 'b) -> ('a -> 'b -> 'c) -> 'c 21 | + \x y. _PROD1it (Pair' x y) = \x y. split (pair x y); 22 | True : BOOL 23 | + val prod = \f1 f2 x. Pair' (f1 x) (f2 x); 24 | val prod : ('a -> 'b) -> ('a -> 'c) -> 'a -> (PROD1 'b 'c) 25 | + val fst' = \p. _PROD1it p \x y. x; 26 | val fst' : (PROD1 'a 'b) -> 'a 27 | + val snd' = \p. _PROD1it p \x y. y; 28 | val snd' : (PROD1 'a 'b) -> 'b 29 | + \f g x. Fst (_PROD2ci f g x) = \f g x. fst' (prod f g x); 30 | True : BOOL 31 | + \f g x. Snd (_PROD2ci f g x) = \f g x. snd' (prod f g x); 32 | True : BOOL 33 | EOF. 34 | -------------------------------------------------------------------------------- /src/v3/tests/l3.et.out: -------------------------------------------------------------------------------- 1 | + datatype NAT = O | S from NAT; 2 | datatype NAT 3 | con O : NAT 4 | con S : NAT -> NAT 5 | iter _NATit : NAT -> 'a -> ('a -> 'a) -> 'a 6 | rec _NATrec : NAT -> 'a -> ((NAT * 'a) -> 'a) -> 'a 7 | comp _NATit (O ) = \z y. z 8 | comp _NATit (S z) = \y x. x (_NATit z y x) 9 | comp _NATrec (O ) = \z y. z 10 | comp _NATrec (S z) = \y x. x (z, _NATrec z y x) 11 | 12 | + 13 | = val add = \x y. _NATit x y (\y. S y); 14 | val add : NAT -> NAT -> NAT 15 | + 16 | = \x y. add (S x) y = \x y. S (add x y); 17 | True : BOOL 18 | + \x. add O x = \x. x; 19 | True : BOOL 20 | + 21 | = val mult = \x y. _NATit x O (\z. add z y); 22 | val mult : NAT -> NAT -> NAT 23 | + 24 | = \x y. mult (S x) y = \x y. add (mult x y) y; 25 | True : BOOL 26 | + \y. mult O y = \y. O; 27 | True : BOOL 28 | + 29 | = val exp = \x y. _NATit y (S O) (\z. mult z x); 30 | val exp : NAT -> NAT -> NAT 31 | + 32 | = \x y. exp x (S y) = \x y. mult (exp x y) x; 33 | True : BOOL 34 | + \x. exp x O = \x. (S O); 35 | True : BOOL 36 | + 37 | = val pred = \x. _NATrec x O fst; 38 | val pred : NAT -> NAT 39 | + 40 | = \x. pred (S x) = \x. x; 41 | True : BOOL 42 | + pred O = O; 43 | True : BOOL 44 | + 45 | = val subtr = \m n. _NATit n m (\x. pred x); 46 | val subtr : NAT -> NAT -> NAT 47 | + 48 | = \x y. subtr x (S y) = \x y. pred (subtr x y); 49 | True : BOOL 50 | + \x. subtr x O = \x. x; 51 | True : BOOL 52 | + 53 | = val is_zero = \x. _NATit x True (\x. False); 54 | val is_zero : NAT -> BOOL 55 | + is_zero O = True; 56 | True : BOOL 57 | + \x. is_zero (S x) = \x. False; 58 | True : BOOL 59 | + 60 | = val eq = \m n. 61 | = if is_zero (subtr m n) then 62 | = is_zero (subtr n m) 63 | = else False; 64 | val eq : NAT -> NAT -> BOOL 65 | + 66 | = val eq = \m n. fst (_NATit m (True, n) 67 | = (\x. if is_zero (snd x) then (False, O) else (fst x, pred (snd x)))); 68 | val eq : NAT -> NAT -> BOOL 69 | + 70 | = val is_one = \x. is_zero (pred x); 71 | val is_one : NAT -> BOOL 72 | + val eq = \m n. is_one (subtr (S m) n); 73 | val eq : NAT -> NAT -> BOOL 74 | + 75 | = eq O O = True; 76 | True : BOOL 77 | + \x. eq (S x) O = \x. False; 78 | True : BOOL 79 | + \x. eq O (S x) = \x. False; 80 | False : BOOL 81 | + \x y. eq (S x) y = \x y. eq x (pred y); 82 | False : BOOL 83 | + \x y. eq x (S y) = \x y. eq (pred x) y; 84 | False : BOOL 85 | + 86 | = val le = \m n. is_zero (subtr m n); 87 | val le : NAT -> NAT -> BOOL 88 | + 89 | = le O O = True; 90 | True : BOOL 91 | + \x. le (S x) O = \x. False; 92 | True : BOOL 93 | + \x. le O (S x) = \x. True; 94 | False : BOOL 95 | + \x y. le (S x) y = \x y. le x (pred y); 96 | False : BOOL 97 | + 98 | = val ack = \m n. (_NATit m (\n. (S n)) (\f. \n. _NATit n (f (S O)) f)) n; 99 | val ack : NAT -> NAT -> NAT 100 | + 101 | = val ack' = \z. _NATit z S (\y x. _NATit x (y (S O)) y); 102 | val ack' : NAT -> NAT -> NAT 103 | + 104 | = \n. ack O n = \n. S n; 105 | True : BOOL 106 | + \m. ack (S m) O = \m. ack m (S O); 107 | True : BOOL 108 | + \m n. ack (S m) (S n) = \m n. ack m (ack (S m) n); 109 | True : BOOL 110 | + 111 | = datatype LIST 'a = Nil | Cons from 'a (LIST 'a); 112 | datatype LIST 113 | con Nil : LIST 'a 114 | con Cons : 'a -> (LIST 'a) -> (LIST 'a) 115 | iter _LISTit : (LIST 'a) -> 'b -> ('a -> 'b -> 'b) -> 'b 116 | rec _LISTrec : (LIST 'a) -> 'b -> ('a -> ((LIST 'a) * 'b) -> 'b) -> 'b 117 | comp _LISTit (Nil ) = \z y. z 118 | comp _LISTit (Cons z y) = \x w. w z (_LISTit y x w) 119 | comp _LISTrec (Nil ) = \z y. z 120 | comp _LISTrec (Cons z y) = \x w. w z (y, _LISTrec y x w) 121 | 122 | + 123 | = val length = \l. _LISTit l O (\x y. S y); 124 | val length : (LIST 'a) -> NAT 125 | + 126 | = length Nil = O; 127 | True : BOOL 128 | + \x y. length (Cons x y) = \x y. S (length y); 129 | True : BOOL 130 | + 131 | = val append = \x y. _LISTit x y Cons; 132 | val append : (LIST 'a) -> (LIST 'a) -> (LIST 'a) 133 | + 134 | = \x. append Nil x = \x. x; 135 | True : BOOL 136 | + \x y z. append (Cons x y) z = \x y z. Cons x (append y z); 137 | True : BOOL 138 | + 139 | = val map = \f l. _LISTit l Nil (\x y. Cons (f x) y); 140 | val map : ('a -> 'b) -> (LIST 'a) -> (LIST 'b) 141 | + 142 | = \f. map f Nil = \f. Nil; 143 | True : BOOL 144 | + \f x y. map f (Cons x y) = \f x y. Cons (f x) (map f y); 145 | True : BOOL 146 | + 147 | = datatype TREE 'a = Tip | Node from 'a (TREE 'a) (TREE 'a); 148 | datatype TREE 149 | con Tip : TREE 'a 150 | con Node : 'a -> (TREE 'a) -> (TREE 'a) -> (TREE 'a) 151 | iter _TREEit : (TREE 'a) -> 'b -> ('a -> 'b -> 'b -> 'b) -> 'b 152 | rec _TREErec : (TREE 'a) -> 'b -> ('a -> ((TREE 'a) * 'b) -> ((TREE 'a) * 'b) -> 'b) -> 'b 153 | comp _TREEit (Tip ) = \z y. z 154 | comp _TREEit (Node z y x) = \w v. v z (_TREEit y w v) (_TREEit x w v) 155 | comp _TREErec (Tip ) = \z y. z 156 | comp _TREErec (Node z y x) = \w v. v z (y, _TREErec y w v) (x, _TREErec x w v) 157 | 158 | + 159 | = val max = \x y. if le x y then y else x; 160 | val max : NAT -> NAT -> NAT 161 | + val height = \t. _TREEit t O (\a x y. S (max x y)); 162 | val height : (TREE 'a) -> NAT 163 | + 164 | = height Tip = O; 165 | True : BOOL 166 | + \x y z. height (Node x y z) = \x y z. S (max (height y) (height z)); 167 | True : BOOL 168 | + 169 | = (* vim: ft=sml 170 | = *) 171 | EOF. 172 | -------------------------------------------------------------------------------- /src/v3/tests/l4.et.out: -------------------------------------------------------------------------------- 1 | + datatype NAT = O | S from NAT; 2 | datatype NAT 3 | con O : NAT 4 | con S : NAT -> NAT 5 | iter _NATit : NAT -> 'a -> ('a -> 'a) -> 'a 6 | rec _NATrec : NAT -> 'a -> ((NAT * 'a) -> 'a) -> 'a 7 | comp _NATit (O ) = \z y. z 8 | comp _NATit (S z) = \y x. x (_NATit z y x) 9 | comp _NATrec (O ) = \z y. z 10 | comp _NATrec (S z) = \y x. x (z, _NATrec z y x) 11 | 12 | + 13 | = val add = \x y. _NATit x y (\y. S y); 14 | val add : NAT -> NAT -> NAT 15 | + 16 | = \x y. add (S x) y = \x y. S (add x y); 17 | True : BOOL 18 | + \x. add O x = \x. x; 19 | True : BOOL 20 | + 21 | = val mult = \x y. _NATit x O (\z. add z y); 22 | val mult : NAT -> NAT -> NAT 23 | + 24 | = \x y. mult (S x) y = \x y. add (mult x y) y; 25 | True : BOOL 26 | + \y. mult O y = \y. O; 27 | True : BOOL 28 | + 29 | = val pred = \x. _NATrec x O fst; 30 | val pred : NAT -> NAT 31 | + 32 | = \x. pred (S x) = \x. x; 33 | True : BOOL 34 | + pred O = O; 35 | True : BOOL 36 | + 37 | = val subtr = \m n. _NATit n m (\x. pred x); 38 | val subtr : NAT -> NAT -> NAT 39 | + 40 | = \x y. subtr x (S y) = \x y. pred (subtr x y); 41 | True : BOOL 42 | + \x. subtr x O = \x. x; 43 | True : BOOL 44 | + 45 | = val is_zero = \x. _NATit x True (\x. False); 46 | val is_zero : NAT -> BOOL 47 | + val is_one = \x. if is_zero x then False else is_zero (pred x); 48 | val is_one : NAT -> BOOL 49 | + 50 | = is_zero O = True; 51 | True : BOOL 52 | + \x. is_zero (S x) = \x. False; 53 | True : BOOL 54 | + 55 | = val le = \m n. is_zero (subtr m n); 56 | val le : NAT -> NAT -> BOOL 57 | + val eq = \x. _NATit x is_zero (\f. 58 | = \y. 59 | = if is_zero y then False 60 | = else f (pred y)); 61 | val eq : NAT -> NAT -> BOOL 62 | + 63 | = \x y. eq (S x) (S y) = \x y. eq x y; 64 | True : BOOL 65 | + eq O O = True; 66 | True : BOOL 67 | + \x. eq (S x) O = \x. False; 68 | True : BOOL 69 | + \x. eq O (S x) = \x. False; 70 | True : BOOL 71 | + 72 | = (* 73 | = eq (S x) = 74 | = \y. if is_zero y then False 75 | = else eq x (pred y) 76 | = 77 | = eq O = is_zero 78 | = (S y) = \x y. eq x y; 79 | = eq (S x) O = \x. False; 80 | = eq O O = True; 81 | = \x. eq O (S x) = \x. False; 82 | = *) 83 | = 84 | = val n2 = (S (S O)); 85 | val n2 : NAT 86 | + val n3 = (S (S (S O))); 87 | val n3 : NAT 88 | + val n4 = (S (S (S (S O)))); 89 | val n4 : NAT 90 | + val n5 = (S (S (S (S (S O))))); 91 | val n5 : NAT 92 | + 93 | = val divmod = \m n. _NATit m (O, O) (\p. 94 | = if is_one (subtr n (snd p)) then 95 | = (S (fst p), O) 96 | = else 97 | = (fst p, S (snd p))); 98 | val divmod : NAT -> NAT -> (NAT * NAT) 99 | + 100 | = (*divmod n5 n2;*) 101 | = 102 | = \m. divmod O m = \m. (O, O); 103 | True : BOOL 104 | + \m n. divmod (S m) n = \m n. 105 | = (\p. 106 | = if is_one (subtr n (snd p)) then 107 | = (S (fst p), O) 108 | = else 109 | = (fst p, S (snd p))) (divmod m n); 110 | True : BOOL 111 | + 112 | = val div = \x y. fst (divmod x y); 113 | val div : NAT -> NAT -> NAT 114 | + val mod = \x y. fst (divmod x y); 115 | val mod : NAT -> NAT -> NAT 116 | + 117 | = divmod n2 O; 118 | O, S (S O) : NAT * NAT 119 | + divmod n2 O = (O, n2); 120 | True : BOOL 121 | + divmod n3 O = (O, n3); 122 | True : BOOL 123 | + 124 | = \m. div m O = O; 125 | False : BOOL 126 | + \m. mod m O = O; 127 | False : BOOL 128 | + 129 | = codatatype STREAM 'a = Shd to 'a & Stl to STREAM 'a; 130 | codatatype STREAM 131 | des Shd : (STREAM 'a) -> 'a 132 | des Stl : (STREAM 'a) -> (STREAM 'a) 133 | coiter _STREAMci : ('b -> 'a) -> ('b -> 'b) -> 'b -> (STREAM 'a) 134 | corec _STREAMcr : ('b -> 'a) -> ('b -> ((STREAM 'a) + 'b)) -> 'b -> (STREAM 'a) 135 | comp Shd (_STREAMci z y x) = z x 136 | comp Stl (_STREAMci z y x) = _STREAMci z y (y x) 137 | comp Shd (_STREAMcr z y x) = z x 138 | comp Stl (_STREAMcr z y x) = when (y x) (\w. w) (_STREAMcr z y) 139 | 140 | + val smap = \f s. _STREAMci (\s. f (Shd s)) Stl s; 141 | val smap : ('a -> 'b) -> (STREAM 'a) -> (STREAM 'b) 142 | + val natstr = \n. _STREAMci (\x. x) S n; 143 | val natstr : NAT -> (STREAM NAT) 144 | + val sprefix = \x s. _STREAMci (\a. when a fst Shd) (\a. Inr (when a snd Stl)) (Inl (x, s)); 145 | val sprefix : 'a -> (STREAM 'a) -> (STREAM 'a) 146 | + 147 | = val fib = \n. snd (_NATit n (S O, O) (\p. (add (fst p) (snd p), fst p))); 148 | val fib : NAT -> NAT 149 | + 150 | = fib O = O; 151 | True : BOOL 152 | + fib (S O) = S O; 153 | True : BOOL 154 | + \n. fib (S (S n)) = \n. add (fib (S n)) (fib n); 155 | True : BOOL 156 | + 157 | = (* vim: ft=sml 158 | = *) 159 | EOF. 160 | -------------------------------------------------------------------------------- /src/v3/tests/poly.et.out: -------------------------------------------------------------------------------- 1 | + \x. let val x = fst x; in True end; 2 | val x : [23@0] 3 | \z. True : ('a * 'b) -> BOOL 4 | + \x. let val f = \y. y; in (f True, f x) end; 5 | val f : 'a -> 'a 6 | Pair True : 'a -> (BOOL * 'a) 7 | + \x. let val f = \y. (fst x, y); in (f True, f ()) end; 8 | val f : 'a -> ([38@0] * 'a) 9 | \z. fst z, True, fst z, Unit : ('a * 'b) -> (('a * BOOL) * 'a * UNIT) 10 | EOF. 11 | -------------------------------------------------------------------------------- /src/v3/tests/run: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | res=0 4 | for f in ../examples/*.et ; do 5 | n=$(basename $f) 6 | test -f $n.out || continue 7 | echo -n "$n... " 1>&2 8 | (cd ..; ./et examples/$f) > $n.out.now 9 | if cmp -s $n.out $n.out.now ; then 10 | echo "OK" 1>&2 11 | rm -f $n.out.now 12 | else 13 | echo "FAILED" 1>&2 14 | diff -u $n.out $n.out.now 15 | res=1 16 | fi 17 | done 18 | 19 | exit $res 20 | -------------------------------------------------------------------------------- /src/v3/typing.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | open Ast 34 | 35 | val type_pterm : Env.env -> pterm -> ty 36 | -------------------------------------------------------------------------------- /src/v3/tysem.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | open Ast 34 | 35 | val add_type : Env.env -> string -> string list -> cdtor list -> Env.env 36 | val add_cotype : Env.env -> string -> string list -> cdtor list -> Env.env 37 | val print_type : tycon -> unit 38 | -------------------------------------------------------------------------------- /src/v3/tyutil.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | open Ast 34 | open Util 35 | 36 | let xf = Printf.sprintf 37 | let pf = Printf.printf 38 | 39 | let sorry m = raise (Unlocated_error m) 40 | 41 | let bind_ty env t = 42 | let rec f = function 43 | | Tycon (n, a) -> 44 | let tc = Env.get_tycon env n.n_name in 45 | let () = n.n_binding <- Some tc in 46 | let tcl = List.length tc.tc_args in 47 | let al = List.length a in 48 | if tcl != al then 49 | sorry (xf "tycon %s takes %d arguments, while %d is given" 50 | tc.tc_name tcl al) 51 | else 52 | List.iter f a 53 | | Tybox {box_value = Some x} -> f x 54 | | Tyvar _ | Tybox _ -> () 55 | in 56 | f t 57 | 58 | let print_val pref v = 59 | if not !quiet then pf "%s %s : %s\n" pref v.val_name (Pp.string_of_ty v.val_ty) 60 | 61 | let tyvar_no n = 62 | if n <= 25 then xf "'%c" (Char.chr (Char.code 'a' + n)) 63 | else xf "'v%d" n 64 | 65 | -------------------------------------------------------------------------------- /src/v3/tyutil.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | open Ast 34 | 35 | val sorry : string -> 'a 36 | val bind_ty : Env.env -> ty -> unit 37 | val print_val : string -> value -> unit 38 | val tyvar_no : int -> string 39 | -------------------------------------------------------------------------------- /src/v3/unionfind.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | type 'a set = 34 | {mutable data : 'a; 35 | mutable rank : int; 36 | mutable uplink : 'a set option} 37 | 38 | let make_set d = 39 | {data = d; rank = 0; uplink = None} 40 | 41 | let rec parent x = 42 | match x.uplink with 43 | | Some ({uplink = None} as p) -> p 44 | | Some p -> 45 | let pp = parent p in 46 | let () = x.uplink <- Some pp in pp 47 | | None -> x 48 | 49 | let union s1 s2 d = 50 | let s1 = parent s1 in 51 | let s2 = parent s2 in 52 | if s1 == s2 then 53 | () 54 | else 55 | let (s1, s2) = if s1.rank < s2.rank then (s1, s2) else (s2, s1) in 56 | begin 57 | s1.uplink <- Some s2; 58 | s2.rank <- s2.rank + 1; 59 | s2.data <- d 60 | end 61 | 62 | let find s = (parent s).data 63 | 64 | let same_set s1 s2 = parent s1 == parent s2 65 | -------------------------------------------------------------------------------- /src/v3/unionfind.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | type 'a set 34 | 35 | (** Create set with given data. *) 36 | val make_set : 'a -> 'a set 37 | 38 | (** [union s1 s2 d] joins [s1] and [s2] creating set with data [d]. *) 39 | val union : 'a set -> 'a set -> 'a -> unit 40 | 41 | (** Look for data associated with given set. *) 42 | val find : 'a set -> 'a 43 | 44 | (** [same_set s1 s2] checks if descriptors [s1] and [s2] represent the same 45 | set. *) 46 | val same_set : 'a set -> 'a set -> bool 47 | -------------------------------------------------------------------------------- /src/v3/util.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2002, 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | open Ast 34 | 35 | exception Error of location * string 36 | exception Unlocated_error of string 37 | 38 | let report_error loc msg = 39 | let () = Printf.fprintf stderr "%s:%d:%d: %s\n" loc.loc_file loc.loc_line 40 | (loc.loc_char - 1) msg in 41 | let () = flush stderr in 42 | () 43 | 44 | module Int = 45 | struct 46 | type t = int 47 | let compare = Pervasives.compare 48 | end 49 | 50 | module Stringmap = Map.Make(String) 51 | module Stringset = Set.Make(String) 52 | module Intmap = Map.Make(Int) 53 | 54 | let quiet = ref false 55 | let debug = ref false 56 | let print_verbose s = if !quiet then () else print_string s 57 | -------------------------------------------------------------------------------- /src/v3/util.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2003 The University of Wroclaw. 3 | * All rights reserved. 4 | * 5 | * Redistribution and use in source and binary forms, with or without 6 | * modification, are permitted provided that the following conditions 7 | * are met: 8 | * 1. Redistributions of source code must retain the above copyright 9 | * notice, this list of conditions and the following disclaimer. 10 | * 2. Redistributions in binary form must reproduce the above copyright 11 | * notice, this list of conditions and the following disclaimer in the 12 | * documentation and/or other materials provided with the distribution. 13 | * 3. All advertising materials mentioning features or use of this software 14 | * must display the following acknowledgement: 15 | * This product includes software developed by the University of 16 | * Wroclaw and its contributors. 17 | * 4. Neither the name of the University nor the names of its contributors 18 | * may be used to endorse or promote products derived from this software 19 | * without specific prior written permission. 20 | * 21 | * THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``AS IS'' AND 22 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 23 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 24 | * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 25 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 27 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 28 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 | * SUCH DAMAGE. 32 | *) 33 | open Ast 34 | 35 | exception Error of location * string 36 | exception Unlocated_error of string 37 | 38 | val report_error : location -> string -> unit 39 | 40 | module Stringmap : Map.S with type key = string 41 | module Stringset : Set.S with type elt = string 42 | module Intmap : Map.S with type key = int 43 | 44 | val quiet : bool ref 45 | val debug : bool ref 46 | val print_verbose : string -> unit 47 | --------------------------------------------------------------------------------