├── ALGORITHM_OVERVIEW ├── FAQ ├── INSTALL ├── LICENSE ├── Makefile ├── README ├── base.ml ├── check_expr.ml ├── check_term.ml ├── ctx.ml ├── eval.ml ├── examples ├── break.ipl ├── compilation.ipl ├── equality.ipl ├── euler.ipl ├── fibonacci.ipl ├── hedbergs_theorem.ipl ├── methcall.ipl ├── modules.ipl ├── popcount.ipl ├── tutorial.ipl └── unary_arithmetic.ipl ├── expr.ml ├── initial.ml ├── ipl_compile.ml ├── ipl_llvm.ml ├── iplc.ml ├── lex.mll ├── printing.ml ├── reify.ml ├── syntax.mly ├── term.ml ├── test_expr.ml ├── test_llvm.ml ├── test_term.ml ├── value.ml ├── var.ml └── var.mli /ALGORITHM_OVERVIEW: -------------------------------------------------------------------------------- 1 | ================================================================================ 2 | 3 | IPL uses an extension of the algorithm described below to eliminate 4 | constructs that require memory allocation (and subsequently garbage 5 | collection) from programs written in a subset of intensional type 6 | theoy. 7 | 8 | In this note, I will use the following acronyms. 9 | 10 | ITT=intensional type theory with finite sets, Pi (ap, and lam with 11 | eta-rule), Sigma (pair, fst, snd with surjective pairing), Id (refl 12 | and Paulin-Mohring's elimination rule which I will call subst), and a 13 | universe. 14 | 15 | ETT+=extensional type theory with the same sets, plus the rule R, 16 | given by 17 | 18 | ci=c:F 19 | C:F -> set ... 20 | c:F={c1,...,cn} bi:C(ci) 21 | -------------------------------- 22 | case'(c,b1,...,bn):C(c) 23 | 24 | That is, the typing of the branches bi:C(ci) only has to be correct 25 | under the assumption that ci=c:F. Note that the family C can always 26 | be taken to be constantly C(c), as, in each branch, C(c)=C(ci) anyway. 27 | 28 | ETT+ ought to be consistent as the special case' operation can be 29 | defined in terms of the normal operation case. 30 | 31 | case'(c,b1,...,bn) = case(c,(lam x1)b1,...,(lam xn)bn)(refl(c)) : C(c) 32 | 33 | On the left side, the elimination family is C(x), whereas on the right 34 | side it is D(x)=Id(F,x,c)->C(x). Now bi is typed under the assumption 35 | that xi:Id(F,ci,c), and, by extensionality, the definitional equality 36 | can be assumed. 37 | 38 | Note that normal computer datatypes, like 64-bit integers, are finite 39 | sets. All hardware operations on such datatypes can formally be 40 | expressed in terms of the "case'" construct. However, their 41 | implementations can of course be in terms of machine instructions. 42 | 43 | CONJECTURE. If b:F0 (x1:F1,...,xn:Fn) in ITT, where Fi (i=0..n) are 44 | finite sets, then b=b0:F0 (x1:F1,...,xn:Fn) in ETT+ for some term b0 45 | (effectively computable from b) which only contains applications of 46 | case'. 47 | 48 | Proof idea. First normalize b in ITT. 49 | 50 | b=D1(D2(... Dk(xj)...)), where Di(n) has one of the neutral forms 51 | 52 | x (variable), 53 | case'(n,...), 54 | subst(a,b,n,d), 55 | ap(n,a), 56 | fst(n), 57 | snd(n). 58 | 59 | [Note the position of the 'n' in each form.] 60 | 61 | The following equalities hold in ETT+: 62 | 63 | 1:subst(a,b,n,d)=d 64 | 2:ap(case'(n,b1,...,bn),a)=case'(n,ap(b1,a),...,ap(bn,a)) 65 | 3:fst(case'(n,b1,...,bn))=case'(n,fst(b1),...,fst(bn)) 66 | 4:snd(case'(n,b1,...,bn))=case'(n,snd(b1),...,snd(bn)) 67 | 68 | 1: Here I've used Paulin-Mohring's subst rule 69 | 70 | a,b:A n:Id(A,a,b) d:C(a,refl(a)) 71 | ---------------------------------- 72 | subst(a,b,n,d):C(b,n) 73 | 74 | In ETT+, n=refl, a=b, and subst(a,b,n,d)=d. 75 | 76 | 2: For ap, assume that 77 | n:F={c1,...,cn} 78 | C(x)=(Pi y:A(x))B(x,y), 79 | case'(n,b1,...,bn):C(n), 80 | bi:C(ci), 81 | a:A(n). 82 | 83 | Using the rule R, given that ci=n:F, we have bi:C(n) and 84 | ap(bi,a):B(n,a), whence case'(n,ap(b1,a),...,ap(bn,a)):B(n,a). 85 | Furthermore, let 86 | 87 | P=Id(B(n,a),ap(case'(n,b1,...,bn),a),case'(n,ap(b1,a),...,ap(bn,a))). 88 | Then case'(n,refl,...,refl):P, whence equality 1 holds in ETT+. Note 89 | that the family of the case' is constantly P (i.e., P does not depend 90 | on n). 91 | 92 | 3&4: Assume 93 | n:F={c1,...,cn} 94 | bi:(Sigma y:A(ci))B(ci,y), 95 | case'(n,b1,...,bn):(Sigma y:A(n))B(n,y) 96 | 97 | Assuming n=ci:F, bi:(Sigma y:A(n))B(n,y), and fst(bi):A(n), 98 | snd(bi):B(n,fst(bi)), whence the right hand sides are well-formed. 99 | 100 | P=Id(A(n),fst(case'(n,b1,...,bn)),case'(n,fst(b1),...,fst(bn))) 101 | case'(n,refl,...,refl):P 102 | 103 | Q=Id(A(n),snd(case'(n,b1,...,bn)),case'(n,snd(b1),...,snd(bn))) 104 | case'(n,refl,...,refl):Q 105 | 106 | To compute b0 from b, first apply equations 1-4 on the spine until it 107 | consists only of applications of case' (at most k steps). 108 | 109 | Next, we'd like to apply the normalization algorithm of ITT to each of 110 | the branches of each case. 111 | 112 | Note that a termination proof of this step requires a normalization 113 | algorithm that brings terms to ITT-normal form even if the terms are 114 | only type correct in ETT+. I wouldn't be surprised if the correctness 115 | of the standard algorithm also in this setting falls out from some of 116 | the more extensional proofs of NBE termination, but I'm not sure. 117 | 118 | Note that each of the branches still have finite type (in the sense 119 | that they have type F for some finite set F) in the same context. That 120 | is, the (implicit) induction assumption holds good. 121 | 122 | Continue to apply 1-4 to the branches, and repeat until the result 123 | consists only of applications of case. I don't have a cogent argument 124 | for termination. 125 | 126 | ================================================================================ 127 | -------------------------------------------------------------------------------- /FAQ: -------------------------------------------------------------------------------- 1 | * On which platforms does IPL run? 2 | 3 | The IPL compiler runs on any platform which has support for Ocaml and 4 | LLVM with the Ocaml bindings. 5 | 6 | The resulting programs are just LLVM assembly files and run on any 7 | platform which is supported by LLVM. 8 | 9 | * What license is IPL distributed under? 10 | 11 | IPL is distributed under the Apache License version 2.0. 12 | 13 | * How do I find out more about IPL? 14 | 15 | First look at http://intuitionistic.org. Next, join the discussion 16 | group at https://groups.google.com/forum/#!forum/intuitionistic. 17 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | REQUIREMENTS: 2 | 3 | - Ocaml v4.00 or later (tested with Ocaml 4.01). 4 | 5 | - LLVM 3.4.1, installed with OCaml bindings. Easiest way to get 6 | these is to build LLVM from source (after having installed OCaml). 7 | 8 | 9 | INSTALLATION: 10 | 11 | Type 'make' in the IPL main folder. 12 | 13 | The default IPL Makefile target creates the following binaries. 14 | ./iplc The iplc compiler. 15 | ./iplc.opt An optimized version of the iplc compiler. 16 | ./ipltop An Ocaml toplevel with IPL preloaded. 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE 2 | # 3 | # Copyright (c) 2006-2013 Johan G. Granstroem. 4 | # 5 | # Licensed under the Apache License, Version 2.0 (the "License"); 6 | # you may not use this file except in compliance with the License. 7 | # You may obtain a copy of the License at 8 | # 9 | # http://www.apache.org/licenses/LICENSE-2.0 10 | # 11 | # Unless required by applicable law or agreed to in writing, software 12 | # distributed under the License is distributed on an "AS IS" BASIS, 13 | # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | # See the License for the specific language governing permissions and 15 | # limitations under the License. 16 | 17 | OCAMLC=ocamlc 18 | OCAMLOPT=ocamlopt 19 | OCAMLDEP=ocamldep 20 | OCAMLLEX=ocamllex 21 | OCAMLYACC=ocamlyacc 22 | LLC=llc 23 | LLVM_DIS=llvm-dis 24 | # Add non-standard location for LLVM bindings here. For example: 25 | # INCLUDES=-I /my/non-standard/lib 26 | INCLUDES= 27 | OCAMLFLAGS=$(INCLUDES) -g 28 | OCAMLOPTFLAGS=$(INCLUDES) -p 29 | 30 | # ========== MAIN TARGETS 31 | 32 | all: test_term test_expr test_llvm iplc iplc.opt ipltop 33 | 34 | test: all 35 | ./test_term 36 | ./test_expr 37 | ./test_llvm 38 | @for x in $$(ls examples/*.ipl); do echo "checking" $$x "done." && ./iplc $$x; done 39 | @for x in $$(ls examples/*.ipl); do echo "checking (opt)" $$x "done." && ./iplc.opt $$x; done 40 | 41 | clean: 42 | rm -f test_term test_expr test_llvm iplc iplc.opt ipltop syntax.mli syntax.ml lex.ml 43 | rm -f *.cm[ioxa] 44 | rm -f examples/*.bc 45 | rm -f examples/*.s 46 | rm -f examples/*.o 47 | rm -f examples/*.ll 48 | rm -f *.o 49 | rm -f *.s 50 | rm -f syntax.output 51 | rm -f *~ 52 | rm -f examples/*~ 53 | rm -f .depend 54 | 55 | # ========== PATTERN RULES 56 | 57 | %.cmo: %.ml 58 | $(OCAMLC) $(OCAMLFLAGS) -c $< 59 | 60 | %.cmi: %.mli 61 | $(OCAMLC) $(OCAMLFLAGS) -c $< 62 | 63 | %.cmx: %.ml 64 | $(OCAMLOPT) $(OCAMLOPTFLAGS) -c $< 65 | 66 | %.ml %.mli: %.mly 67 | $(OCAMLYACC) -v $< 68 | 69 | %.ml: %.mll 70 | $(OCAMLLEX) $< 71 | 72 | %.bc: %.ipl iplc 73 | ./iplc $< 74 | 75 | %.s: %.bc 76 | $(LLC) $< 77 | 78 | %.ll: %.bc 79 | $(LLVM_DIS) $< 80 | 81 | %.o: %.s 82 | $(CC) -c $< 83 | 84 | .PRECIOUS: %.mli %.mly 85 | 86 | # ========== LEVEL 1 87 | 88 | LEVEL1=var.cmo base.cmo value.cmo term.cmo eval.cmo printing.cmo reify.cmo ctx.cmo check_term.cmo initial.cmo 89 | 90 | TEST_TERM_OBJS=$(LEVEL1) test_term.cmo 91 | test_term: $(TEST_TERM_OBJS) 92 | $(OCAMLC) $(OCAMLFLAGS) $(TEST_TERM_OBJS) -o test_term 93 | 94 | # ========== LEVEL 2 95 | 96 | LEVEL2=$(LEVEL1) expr.cmo check_expr.cmo lex.cmo syntax.cmo 97 | 98 | lex.ml: syntax.cmi syntax.cmo 99 | 100 | TEST_EXPR_OBJS=$(LEVEL2) test_expr.cmo 101 | test_expr: $(TEST_EXPR_OBJS) 102 | $(OCAMLC) $(OCAMLFLAGS) $(TEST_EXPR_OBJS) -o test_expr 103 | 104 | # ========== LEVEL 3 105 | 106 | LEVEL3=$(LEVEL2) ipl_compile.cmo ipl_llvm.cmo 107 | 108 | LLVM_LIBS=llvm.cma llvm_executionengine.cma llvm_analysis.cma llvm_scalar_opts.cma llvm_target.cma llvm_bitwriter.cma 109 | LLVM_FLAGS=-ccopt -lstdc++ 110 | 111 | TEST_LLVM_OBJS=$(LEVEL3) test_llvm.cmo 112 | test_llvm: $(TEST_LLVM_OBJS) 113 | $(OCAMLC) $(OCAMLFLAGS) $(LLVM_FLAGS) $(LLVM_LIBS) $(TEST_LLVM_OBJS) -o test_llvm 114 | 115 | IPLC_OBJS=$(LEVEL3) iplc.cmo 116 | iplc: $(IPLC_OBJS) 117 | $(OCAMLC) $(OCAMLFLAGS) $(LLVM_FLAGS) $(LLVM_LIBS) $(IPLC_OBJS) -o iplc 118 | 119 | # Flag -noassert could be added here, but last time I checked, it made little difference. 120 | iplc.opt: $(IPLC_OBJS:.cmo=.cmx) 121 | $(OCAMLOPT) $(OCAMLOPTFLAGS) $(LLVM_FLAGS) $(LLVM_LIBS:.cma=.cmxa) $(IPLC_OBJS:.cmo=.cmx) -o iplc.opt 122 | 123 | ipltop: $(IPLC_OBJS) 124 | ocamlmktop -custom -ccopt -Wno-write-strings -g unix.cma $(LLVM_FLAGS) $(LLVM_LIBS) $(IPLC_OBJS) -o ipltop 125 | 126 | # ========== DEPENDENCIES 127 | 128 | .depend: 129 | $(OCAMLDEP) $(INCLUDES) *.mli *.ml > .depend 130 | 131 | -include .depend 132 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | SUMMARY. 2 | 3 | The intuitionistic programming language has a semantics based on 4 | intuitionistic type theory and compiles to LLVM bytecode without 5 | runtime garbage collection. 6 | 7 | 8 | DESCRIPTION. 9 | 10 | The intuitionistic programming language (IPL) combines a very high 11 | level of abstraction with compilation to efficient LLVM bytecode. 12 | 13 | The following language level features are supported: 14 | - first class pure functions, 15 | - first class dependent types, 16 | - generic programming, 17 | - first class interfaces, 18 | - first class procedures, 19 | - fully automatic memory management, 20 | - no runtime requirements, 21 | - no runtime garbage collection, 22 | - logical consistency, 23 | - precise type-theoretic semantics, 24 | - theorem proving capabilities. 25 | -------------------------------------------------------------------------------- /base.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | (* Function composition a la F#. *) 18 | let comp f g a = f (g a) 19 | 20 | (* Similar to F-#sharp's List.tryFind. *) 21 | let rec try_find pred = 22 | function 23 | | [] -> None 24 | | a :: rest when pred a -> Some a 25 | | _ :: rest -> try_find pred rest 26 | 27 | type var = Var.t 28 | 29 | (* A variable map is a mapping from strings to things. *) 30 | module Var_map = Map.Make(struct 31 | type t = var 32 | let compare = compare 33 | end) 34 | type 'a var_map = 'a Var_map.t 35 | 36 | (* An enum literal. *) 37 | type enum_lit = Enum_lit of string 38 | 39 | let format_enum_lit : Format.formatter -> enum_lit -> unit = 40 | fun f -> function Enum_lit s -> Format.fprintf f "%s" s 41 | 42 | (* An enumeration map is a mapping from strings to things. *) 43 | module Enum_map = Map.Make(struct 44 | type t = enum_lit 45 | let compare = compare 46 | end) 47 | type 'a enum_map = 'a Enum_map.t 48 | 49 | (* An enumeration is a set of strings. *) 50 | module Enum_set = Set.Make( 51 | struct 52 | type t = enum_lit 53 | let compare = compare 54 | end) 55 | type enum = Enum_set.t 56 | 57 | let format_enum (fmt:Format.formatter) (enum:enum) :unit = 58 | let open Format in 59 | match Enum_set.elements enum with 60 | | [] -> () 61 | | Enum_lit a :: ys -> 62 | fprintf fmt "%s" a; 63 | List.iter (function Enum_lit a -> fprintf fmt ", %s" a) ys; 64 | 65 | exception Duplicate_key of enum_lit 66 | 67 | (* Make an enum map from an association list. *) 68 | let rec enum_map_make : (enum_lit * 'a) list -> 'a enum_map = 69 | function 70 | | [] -> Enum_map.empty 71 | | (a, b) :: c -> 72 | let cc = enum_map_make c in 73 | if Enum_map.mem a cc then raise (Duplicate_key(a)) 74 | else Enum_map.add a b cc 75 | 76 | (* Make an enum from a list of strings. *) 77 | let rec enum_make : enum_lit list -> enum = 78 | function 79 | | [] -> Enum_set.empty 80 | | a :: b -> 81 | let bb = enum_make b in 82 | if Enum_set.mem a bb then raise (Duplicate_key(a)) 83 | else Enum_set.add a bb 84 | 85 | let enum_of_enum_map mp = 86 | Enum_map.fold (fun k _ b -> Enum_set.add k b) mp Enum_set.empty 87 | 88 | let true_lit = Enum_lit "true" 89 | let false_lit = Enum_lit "false" 90 | let bool_enum = enum_make [true_lit; false_lit] 91 | 92 | let unit_lit = Enum_lit "()" 93 | let unit_enum = enum_make [unit_lit] 94 | 95 | let empty_enum = Enum_set.empty 96 | 97 | (* Raised when an explicit presupposition for the invocation of a *) 98 | (* method has beed violated. *) 99 | exception Presupposition_error 100 | 101 | (* The type of positions (line, col). *) 102 | type pos = int * int 103 | 104 | let no_pos = -1, -1 105 | 106 | (* The type of ranges, i.e., two position: from, to. *) 107 | type range = pos * pos 108 | 109 | let no_range = no_pos, no_pos 110 | 111 | (* The type of source file locations. *) 112 | type location = string * range 113 | 114 | let no_location = "", no_range 115 | 116 | (* Type of variable binding patterns. *) 117 | type pattern = 118 | | Pvar of location * var 119 | | Ppair of pattern * pattern 120 | 121 | let no_pattern = Pvar(no_location, Var.no) 122 | 123 | let format_range(fmt:Format.formatter) (((p, q), (r, s)):range) = 124 | if p = r then 125 | if q = s then 126 | Format.fprintf fmt "%d.%d" p q 127 | else 128 | Format.fprintf fmt "%d.%d-%d" p q s 129 | else 130 | Format.fprintf fmt "%d.%d-%d.%d" p q r s 131 | 132 | let format_location(fmt:Format.formatter) ((l,r):location) = 133 | Format.fprintf fmt "%s:%a" l format_range r 134 | 135 | let no_loc_pattern (x:var) = Pvar(no_location, x) 136 | 137 | (* Raised when an equality check between values fails. *) 138 | exception Not_equal 139 | 140 | type i8 = char 141 | type i16 = int 142 | type i32 = int32 143 | type i64 = int64 144 | 145 | type size = 146 | | I8 147 | | I16 148 | | I32 149 | | I64 150 | 151 | type builtin = 152 | | Aeq of size 153 | | Less of size 154 | (* TODO: add Greater, Below, Above, Less_eq, Greater_eq, Below_eq, Above_eq. *) 155 | | Add of size 156 | | Sub of size 157 | | Neg of size 158 | | Mul of size 159 | | Xor of size 160 | | Or of size 161 | | And of size 162 | | Not of size 163 | | Lsl of size 164 | | Lsr of size 165 | | Asr of size 166 | | Sdiv of size 167 | | Srem of size 168 | | Cast of size * size 169 | | Less_trans of size 170 | | Less_antisym of size 171 | | Aeq_prop of size 172 | | Aeq_refl of size 173 | | Add_commutative of size 174 | | Add_associative of size 175 | | Add_unit of size 176 | | Add_inverse of size 177 | | Mul_commutative of size 178 | | Mul_associative of size 179 | | Mul_unit of size 180 | | Distributive of size 181 | | Sub_axiom of size 182 | 183 | type imm = 184 | | Imm8 of i8 185 | | Imm16 of i16 186 | | Imm32 of i32 187 | | Imm64 of i64 188 | | Enum_imm of enum * enum_lit 189 | | Refl 190 | 191 | let true_imm = Enum_imm (bool_enum, true_lit) 192 | let false_imm = Enum_imm (bool_enum, false_lit) 193 | let unit_imm = Enum_imm (unit_enum, unit_lit) 194 | 195 | let bool_of_bool x = if x then true_imm else false_imm 196 | -------------------------------------------------------------------------------- /check_term.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | open Base 18 | 19 | exception Error 20 | 21 | let rec extend (ctx:Ctx.ctx) 22 | :pattern -> Value.set -> Value.el * Ctx.ctx = 23 | function 24 | | Pvar(loc, x) -> 25 | let a = Value.el_of_var x in 26 | fun _A -> a, Ctx.extend ctx loc x a _A 27 | | Ppair(p, q) -> 28 | function 29 | | Value.Sigma(_P, _Q) -> 30 | let x, ctx' = extend ctx p _P in 31 | let y, ctx'' = extend ctx' q (Value.apv _Q x) in 32 | Value.Pair(x, y), ctx'' 33 | | _ -> raise Error 34 | 35 | let rec extend_with_value (ctx:Ctx.ctx) (a:Value.el) 36 | :pattern -> Value.set -> Ctx.ctx = 37 | function 38 | | Pvar(loc, x) -> Ctx.extend ctx loc x a 39 | | Ppair(p, q) -> 40 | function 41 | | Value.Sigma(_P, _Q) -> 42 | let a' = Eval.mkFst a in 43 | let ctx' = extend_with_value ctx a' p _P in 44 | let _Q' = Value.apv _Q a' in 45 | let ctx'' = extend_with_value ctx' (Eval.mkSnd a) q _Q' in 46 | ctx'' 47 | | _ -> raise Error 48 | 49 | (* Check that the given set is well formed in the context. *) 50 | let rec set (ctx : Ctx.ctx) : Term.set -> unit = 51 | function 52 | | Term.Pi (_A, (x, _B)) 53 | | Term.Sigma (_A, (x, _B)) -> 54 | set ctx _A; 55 | let _A' = Eval.set (Ctx.assign ctx) _A in 56 | let _, ctx' = extend ctx x _A' in 57 | set ctx' _B 58 | | Term.Tree (_I, _A) -> 59 | poly ctx Eval.interface _I; 60 | poly ctx Value.Type _A 61 | | Term.Id (_A, a, b) -> 62 | set ctx _A; 63 | let __A = Eval.set (Ctx.assign ctx) _A in 64 | poly ctx __A a; 65 | poly ctx __A b 66 | | Term.Enum _ 67 | | Term.Imm_set _ 68 | | Term.Type -> () 69 | | Term.Hole_set -> () 70 | | Term.T p -> poly ctx Value.Type p 71 | 72 | (* Check that the given polymorphic term is an element of the given 73 | (value) set in the given context. *) 74 | and poly (ctx : Ctx.ctx) (cc : Value.set) (aa : Term.poly) : unit = 75 | let open Value in 76 | match cc, aa with 77 | | Pi(_A, _B), Term.Lambda(x, b) -> 78 | let x', ctx' = extend ctx x _A in 79 | poly ctx' (apv _B x') b 80 | 81 | | Sigma(_A, _B), Term.Pair(a, b) -> 82 | poly ctx _A a; 83 | let a' = Eval.poly (Ctx.assign ctx) a in 84 | poly ctx (apv _B a') b 85 | 86 | | Tree(_, _A), Term.Ret(a) -> poly ctx (Eval.univ _A) a 87 | 88 | | ((Tree(_I, _A)) as _Tree), Term.Invk(c, (x, t)) -> 89 | let _C = Eval.univ (Eval.mkFst _I) in 90 | let _R y = Eval.univ (Eval.mkApp (Eval.mkSnd _I) y) in 91 | let c' = Eval.poly (Ctx.assign ctx) c in 92 | let _, ctx' = extend ctx x (_R c') in 93 | poly ctx _C c; 94 | poly ctx' _Tree t 95 | 96 | | Id(_A, a, b), Term.Mono(Term.Imm Refl) -> 97 | begin 98 | try 99 | eq_el a b 100 | with Not_equal -> raise Error 101 | end 102 | 103 | | _A, Term.Mono a -> 104 | let __B = mono ctx a in 105 | begin 106 | try 107 | eq_set _A __B 108 | with Not_equal -> raise Error 109 | end 110 | 111 | | _C, Term.Beta_poly(a, (x, b)) -> 112 | let _A = mono ctx a in 113 | let a' = Eval.mono (Ctx.assign ctx) a in 114 | let ctx' = extend_with_value ctx a' x _A in 115 | poly ctx' _C b 116 | 117 | | _A, Term.Hole -> () 118 | 119 | | _ -> raise Error 120 | 121 | (* Infer the set to which the given monomorphic term belongs in the 122 | given context. *) 123 | and mono (ctx : Ctx.ctx) (m : Term.mono) : Value.set = 124 | let open Value in 125 | match m with 126 | | Term.Imm Refl -> raise Error 127 | 128 | | Term.Imm v -> set_of_imm v 129 | 130 | | Term.Pi_u (a, (x, b)) 131 | 132 | | Term.Sigma_u (a, (x, b)) -> 133 | poly ctx Type a; 134 | let _A = Eval.univ (Eval.poly (Ctx.assign ctx) a) in 135 | let _, ctx' = extend ctx x _A in 136 | poly ctx' Type b; 137 | Type 138 | 139 | | Term.Tree_u (i, a) -> 140 | poly ctx Eval.interface i; 141 | poly ctx Type a; 142 | Type 143 | 144 | | Term.Id_u (a, b, c) -> 145 | poly ctx Type a; 146 | let _A = Eval.univ (Eval.poly (Ctx.assign ctx) a) in 147 | poly ctx _A b; 148 | poly ctx _A c; 149 | Type 150 | 151 | | Term.Enum_u u -> Type 152 | 153 | | Term.Imm_set_u _ -> Type 154 | 155 | | Term.App (f, a) -> 156 | begin 157 | match mono ctx f with 158 | | Pi(_A, _B) -> 159 | poly ctx _A a; 160 | apv _B (Eval.poly (Ctx.assign ctx) a) 161 | | _ -> raise Error 162 | end 163 | 164 | | Term.Var x -> 165 | begin 166 | try Ctx.find_type x ctx 167 | with Not_found -> raise Error 168 | end 169 | 170 | | Term.Poly (a, _A) -> 171 | set ctx _A; 172 | let __A = Eval.set (Ctx.assign ctx) _A in 173 | poly ctx __A a; 174 | __A 175 | 176 | | Term.Fst (n) -> 177 | begin 178 | match mono ctx n with 179 | | Sigma (_A, _B) -> _A 180 | | _ -> raise Error 181 | end 182 | 183 | | Term.Snd (n) -> 184 | begin 185 | match mono ctx n with 186 | | Sigma (_A, _B) -> 187 | apv _B (Eval.mkFst (Eval.mono (Ctx.assign ctx) n)) 188 | | _ -> raise Error 189 | end 190 | 191 | | Term.Bind(n, _B, (x, b)) -> 192 | poly ctx Value.Type _B; 193 | begin 194 | match mono ctx n with 195 | | Tree(_I, _A) -> 196 | let rho = Ctx.assign ctx in 197 | let _Tree = Tree(_I, Eval.poly rho _B) in 198 | let _, ctx' = extend ctx x (Eval.univ _A) in 199 | poly ctx' _Tree b; 200 | _Tree 201 | | _ -> raise Error 202 | end 203 | 204 | | Term.For(n, (w, _U), _I, (z, b)) -> 205 | (* 206 | n |^ J => A 207 | U : set (w : |J|) 208 | I : interface 209 | b : I => J@z (z : |J|) 210 | U = J@w : type (w : |J|) 211 | ------------------- 212 | for[^wU, I] (z in n) { 213 | b 214 | } |^ I => A 215 | *) 216 | begin 217 | let rho = Ctx.assign ctx in 218 | poly ctx Eval.interface _I; 219 | let _I' = Eval.poly rho _I in 220 | match mono ctx n with 221 | | Tree(_J, _A) -> 222 | let _D = Eval.univ (Eval.mkFst _J) in 223 | let _S x = Eval.mkApp (Eval.mkSnd _J) x in 224 | begin 225 | let _, ctx' = extend ctx w _D in 226 | poly ctx' Value.Type _U 227 | end; 228 | let _U' = Eval.lift Eval.poly rho (w, _U) in 229 | fork eq_el _U' (Fn _S); 230 | let z', ctx' = extend ctx z _D in 231 | poly ctx' (Tree (_I', (_S z'))) b; 232 | Tree (_I', _A) 233 | | _ -> raise Error 234 | end 235 | 236 | | Term.Subst(r, (x, (y, _C)), d) -> 237 | begin 238 | match mono ctx r with 239 | | Id(_A, a, b) -> 240 | let x', ctx' = extend ctx x _A in 241 | let _, ctx'' = extend ctx' y (Id (_A, a, x')) in 242 | set ctx'' _C; 243 | let rho = Ctx.assign ctx in 244 | let _C' = (comp Eval.lift Eval.lift) Eval.set rho (x, (y, _C)) in 245 | poly ctx (apv (apv _C' a) (Imm Refl)) d; 246 | apv (apv _C' b) (Eval.mono rho r) 247 | | _ -> raise Error 248 | end 249 | 250 | | Term.Enum_d (n, (x, _C), cs) -> 251 | begin 252 | match mono ctx n with 253 | | Enum c as _Enum -> 254 | let _, ctx' = extend ctx x _Enum in 255 | set ctx' _C; 256 | (* Verify that cs and c agree on the enum. *) 257 | begin 258 | if not (Enum_set.equal c (enum_of_enum_map cs)) 259 | then raise Error 260 | end; 261 | let rho = Ctx.assign ctx in 262 | let _C' = Eval.lift Eval.set rho (x, _C) in 263 | Enum_map.iter 264 | (fun k v -> 265 | poly ctx (apv _C' (Imm(Enum_imm(c, k)))) v) 266 | cs; 267 | apv _C' (Eval.mono rho n) 268 | | _ -> raise Error 269 | end 270 | 271 | | Term.Range (n, m) -> 272 | poly ctx i32_set m; 273 | poly ctx i32_set m; 274 | Tree(Pair(i32_u, Lambda(Cst unit_u)), unit_u) 275 | 276 | | Term.Builtin (p, rs) -> 277 | let n, dom, cod = Eval.builtin_dom_cod p in 278 | let arg = apply_type ctx n (Eval.univ dom) rs in 279 | Eval.univ (Value.apv cod arg) 280 | 281 | | Term.Beta_mono (a, (x, b)) -> 282 | let _A = mono ctx a in 283 | let a' = Eval.mono (Ctx.assign ctx) a in 284 | let ctx' = extend_with_value ctx a' x _A in 285 | mono ctx' b 286 | 287 | | Term.Local(st, i, a, n, p) -> 288 | local ctx st i a n p 289 | 290 | | Term.Catch(b, i, a, f, p) -> 291 | catch ctx b i a f p 292 | 293 | | Term.Purify(c, m) -> 294 | poly ctx Value.Type c; 295 | let cc = Eval.poly (Ctx.assign ctx) c in 296 | poly ctx (Value.Tree(Eval.empty_interface, cc)) m; 297 | Eval.univ cc 298 | 299 | and local ctx st i a n p = 300 | let rho = Ctx.assign ctx in 301 | poly ctx Eval.interface i; 302 | let ii = Eval.poly rho i in 303 | poly ctx Value.Type a; 304 | let aa = Eval.poly rho a in 305 | poly ctx (Value.Imm_set st) n; 306 | let newi = Eval.interface_plus ii (Eval.ref_interface st) in 307 | poly ctx (Value.Tree(newi, aa)) p; 308 | Value.Tree(ii, aa) 309 | 310 | and catch ctx b i a f p = 311 | let open Value in 312 | let rho = Ctx.assign ctx in 313 | poly ctx Type b; 314 | let bb = Eval.poly rho b in 315 | poly ctx Eval.interface i; 316 | let ii = Eval.poly rho i in 317 | poly ctx Type a; 318 | let aa = Eval.poly rho a in 319 | poly ctx (Pi(Eval.univ bb, Cst(Tree(ii, aa)))) f; 320 | let newi = Eval.interface_plus ii (Eval.catch_interface bb) in 321 | poly ctx (Tree(newi, aa)) p; 322 | Tree(ii, aa) 323 | 324 | and apply_type ctx n dom args = 325 | match dom, args with 326 | | Value.Sigma(_A, _B), a :: bs -> 327 | poly ctx _A a; 328 | let aa = Eval.poly (Ctx.assign ctx) a in 329 | let __B = Value.apv _B aa in 330 | Value.Pair(aa, apply_type ctx (n-1) __B bs) 331 | | _A, [a] -> 332 | assert(n = 1); 333 | poly ctx _A a; 334 | Eval.poly (Ctx.assign ctx) a 335 | | _ -> raise Error 336 | -------------------------------------------------------------------------------- /ctx.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | open Base 18 | 19 | type types = (bool ref * location * Value.set) var_map 20 | 21 | (* The two maps and the set *must* have the same set of keys. *) 22 | type ctx = 23 | | Internal_ctx_ctor of types * Eval.assign 24 | 25 | (* The variable is already bound in the context when trying to bind it. *) 26 | exception Rebound_error of location * location * var 27 | 28 | let empty = Internal_ctx_ctor(Var_map.empty, Var_map.empty) 29 | 30 | let assign : ctx -> Eval.assign = function Internal_ctx_ctor (_, e) -> e 31 | 32 | let find_type x = function 33 | | Internal_ctx_ctor (ts, _) -> 34 | let r, _, t = Var_map.find x ts in 35 | r := true; 36 | t 37 | 38 | let extend (ctx:ctx) (loc:location) (x:var) (a:Value.el) (_A:Value.set) :ctx = 39 | if x = Var.no then ctx 40 | else match ctx with 41 | | Internal_ctx_ctor(ts, es) -> 42 | begin 43 | try 44 | let _, bloc, _ = Var_map.find x ts in 45 | raise (Rebound_error(bloc, loc, x)) 46 | with Not_found -> 47 | Internal_ctx_ctor(Var_map.add x (ref false, loc, _A) ts, 48 | Var_map.add x a es) 49 | end 50 | 51 | let rec extend_with_pattern (ctx:ctx) :pattern -> Value.set -> Value.el * ctx = 52 | function 53 | | Pvar(loc, x) -> 54 | let a = Value.el_of_var x in 55 | fun _A -> a, extend ctx loc x a _A 56 | | Ppair(p, q) -> 57 | function 58 | | Value.Sigma(_P, _Q) -> 59 | let x, ctx' = extend_with_pattern ctx p _P in 60 | let y, ctx'' = extend_with_pattern ctx' q (Value.apv _Q x) in 61 | Value.Pair(x, y), ctx'' 62 | | _ -> raise Presupposition_error 63 | -------------------------------------------------------------------------------- /examples/break.ipl: -------------------------------------------------------------------------------- 1 | fun (I interface) ++ (J interface) interface = meth { 2 | false: I, 3 | true: J 4 | }; 5 | fun !(x bool) = x ? false : true; 6 | 7 | val i_range interface = meth(_ i32) void; 8 | val range type = i_range => void; 9 | val i_break interface = meth(_ i32) bool; 10 | 11 | assert catch is 12 | dep(b type) -> 13 | dep(i interface) -> 14 | dep(a type) -> 15 | dep(f b -> i => a) -> 16 | (i ++ (meth(_ b) enum{}) => a) -> 17 | i => a; 18 | 19 | 20 | fun breakable(rng range) i_break => i32 = 21 | catch(i32)(i_break)(i32)(fun(n) block { yield(n); })( 22 | block { 23 | for c in rng { 24 | val x = do call(false@c); 25 | if !x { val y = do call(true@c); yield(do fun{}(y)); } 26 | } 27 | yield(-1); 28 | }); 29 | 30 | val (+) = mod32::+; 31 | val (*) = mod32::*; 32 | val (<) = mod32::<; 33 | 34 | // Example: compute integer square root of x. 35 | fun isqrt(x i32) = purify i32 { 36 | new square = new_i32(0); 37 | for i in breakable(0..x) { 38 | val old_square = get square; 39 | val new_square = old_square + 2 * i + 1; 40 | if x < new_square { 41 | yield(false); // break; 42 | } else { 43 | square := new_square; 44 | yield(true); // continue; 45 | } 46 | } 47 | }; 48 | 49 | assert isqrt(9) = 3 is i32; 50 | assert isqrt(10) = 3 is i32; 51 | assert isqrt(100) = 10 is i32; 52 | assert isqrt(120) = 10 is i32; 53 | 54 | compile isqrt(x i32) i32 = block { yield(isqrt(x)); }; 55 | 56 | test isqrt(100) = 10; 57 | test isqrt(120) = 10; 58 | test isqrt(500*500 + 10) = 500; 59 | -------------------------------------------------------------------------------- /examples/compilation.ipl: -------------------------------------------------------------------------------- 1 | // This file demonstrates how IPL eliminates closures and pairs during 2 | // compilation. 3 | 4 | fun seq(A type) = (meth(_ A) void) => void; 5 | 6 | val (-.) = mod32::(-.); 7 | val (-) = mod32::-; 8 | val (+) = mod32::+; 9 | val (*) = mod32::*; 10 | val (<) = mod32::<; 11 | val sdiv = mod32::sdiv; 12 | fun is_true(x bool) type = x eq(bool) true; 13 | fun is_false(x bool) type = x eq(bool) false; 14 | 15 | val mean_variance = struct { mean: i32, variance: i32 }; 16 | 17 | // This is a function that performs a computation and returns a 18 | // "closure". 19 | fun compute_mean_and_variance(s seq(i32)) = 20 | purify tuple(x i32, _ is_true(0 < x)) -> mean_variance { 21 | new sum = new_i32(0); 22 | new squares = new_i32(0); 23 | for c in s { 24 | sum := sum + c; 25 | squares := squares + c * c; 26 | } 27 | val sum = get sum; 28 | val squares = get squares; 29 | yield(fun(x, y) ( 30 | val mean = sdiv(sum, x, y); 31 | val variance = sdiv(squares, x, y) - mean * mean; 32 | fun { 33 | mean: mean, 34 | variance: variance 35 | })); 36 | }; 37 | 38 | val is_true_or_false dep(x bool) -> 39 | union { true: is_true(x), false: is_false(x) } = 40 | fun { 41 | true: true@refl, 42 | false: false@refl 43 | }; 44 | 45 | compile compute_variance(from i32, to i32) i32 = block { 46 | val s seq(i32) = block { 47 | for x in from .. to { 48 | do call(x); 49 | } 50 | }; 51 | val n = to - from; 52 | val v i32 = switch is_true_or_false(0 < n) { 53 | case true@x: 54 | val mv = compute_mean_and_variance(s)(n, x); 55 | yield(mv::variance); 56 | case false@_: 57 | yield(-1); 58 | } 59 | yield(v); 60 | }; 61 | 62 | // The variance of 2 3 4 5 6 7 8 9 10 11 12 13 14 is equal to 14. 63 | test compute_variance(2, 15) = 14; 64 | test compute_variance(10, 10) = -1; 65 | 66 | // Here is the resulting bytecode (with variables names improved). 67 | // 68 | // define i32 @compute_variance(i32 %from, i32 %to) { 69 | // entry: 70 | // %0 = sub i32 %to, %from 71 | // %1 = icmp sgt i32 %0, 0 72 | // br i1 %1, label %begin, label %exit 73 | // 74 | // exit: ; preds = %end, %entry 75 | // %result = phi i32 [ -1, %entry ], [ %10, %end ] 76 | // ret i32 %result 77 | // 78 | // begin: ; preds = %loop, %entry 79 | // %squares = phi i32 [ %5, %loop ], [ 0, %entry ] 80 | // %sum = phi i32 [ %3, %loop ], [ 0, %entry ] 81 | // %range = phi i32 [ %6, %loop ], [ %from, %entry ] 82 | // %2 = icmp ult i32 %range, %to 83 | // br i1 %2, label %loop, label %end 84 | // 85 | // loop: ; preds = %begin 86 | // %3 = add i32 %range, %sum 87 | // %4 = mul i32 %range, %range 88 | // %5 = add i32 %4, %squares 89 | // %6 = add i32 %range, 1 90 | // br label %begin 91 | // 92 | // end: ; preds = %begin 93 | // %7 = sdiv i32 %squares, %0 94 | // %8 = sdiv i32 %sum, %0 95 | // %9 = mul i32 %8, %8 96 | // %10 = sub i32 %7, %9 97 | // br label %exit 98 | // } 99 | -------------------------------------------------------------------------------- /examples/equality.ipl: -------------------------------------------------------------------------------- 1 | // This module demonstrates the difference between definitional and 2 | // propositional equality. 3 | // 4 | // Johan Georg Granström. Treatise on Intuitionistic Type Theory. 5 | // Springer, 2011. 6 | 7 | // First, let's define an enumerated set with one element, similar to 8 | // 'void', but with the element 'nil instead of (). 9 | val unit = enum { nil }; 10 | 11 | // A convenient abbreviation. 12 | val unitfn = unit -> unit; 13 | 14 | // Three functions unit -> unit. 15 | fun constant(x unit) unit = 'nil; 16 | fun identity(x unit) = x; 17 | val cases unitfn = fun { nil: 'nil}; 18 | 19 | // Let's check that they indeed have the same type. 20 | assert constant is unitfn; 21 | assert identity is unitfn; 22 | assert cases is unitfn; 23 | 24 | // These three assertions are all invalid. That is, no pair of 25 | // functions are definitionally equal. 26 | // 27 | // assert constant = identity is unitfn; 28 | // assert constant = cases is unitfn; 29 | // assert identity = cases is unitfn; 30 | 31 | // Let's use infix equality (==) for equality between elements of the 32 | // set unit. 33 | fun (x unit) == (y unit) = x eq(unit) y; 34 | 35 | // In fact, despite being definitionally distinct, the three functions 36 | // are in fact extensionally equal, as demonstrated by. 37 | val constant_eq_identity dep(x unit) -> constant(x) == identity(x) = 38 | fun { nil: refl }; 39 | val constant_eq_cases dep(x unit) -> constant(x) == cases(x) = 40 | fun { nil: refl }; 41 | val identity_eq_cases dep(x unit) -> identity(x) == cases(x) = 42 | fun { nil: refl }; 43 | 44 | // This is not surprising in view of the fact that the unit set is 45 | // collapsed in the following sense. 46 | fun collapsed(x unit, y unit) x == y = ( 47 | val tmp dep(xx unit) -> dep(yy unit) -> xx == yy = 48 | fun { nil: fun { nil: refl }}; 49 | tmp(x)(y) 50 | ); 51 | -------------------------------------------------------------------------------- /examples/euler.ipl: -------------------------------------------------------------------------------- 1 | // This module implements the first problem from Project Euler 2 | // (projecteuler.net). 3 | // 4 | // "If we list all the natural numbers below 10 that are multiples of 5 | // 3 or 5, we get 3, 5, 6 and 9. The sum of these multiples is 6 | // 23. Find the sum of all the multiples of 3 or 5 below 1000. Answer: 7 | // 233168." 8 | 9 | // First some useful abbreviations, the first of which should be a 10 | // part of the initially opened module. 11 | fun (x bool) || (y bool) = x ? true : y; 12 | val srem = mod32::srem; 13 | val (+) = mod32::(+); 14 | val (==) = mod32::(==); 15 | 16 | fun euler1(x i32) = 17 | purify i32 { 18 | new c = new_i32(0); 19 | for z in 0..x { 20 | if srem(z, 3, refl) == 0 || srem(z, 5, refl) == 0 { 21 | c := c + z; 22 | } 23 | } 24 | yield(get c); 25 | }; 26 | 27 | // Let the IPL interpreter check that the implementation is correct. 28 | assert euler1(10) = 23 is i32; 29 | assert euler1(1000) = 233168 is i32; 30 | 31 | // We can also compile the euler() function to LLVM bytecode. 32 | compile euler(x i32) i32 = block { 33 | new c = new_i32(0); 34 | for z in 0..x { 35 | if srem(z, 3, refl) == 0 || srem(z, 5, refl) == 0 { 36 | c := c + z; 37 | } 38 | } 39 | yield(get c); 40 | }; 41 | 42 | // Alternatively, we could have reused the definition above, as 43 | // follows. 44 | // 45 | // compile euler(x i32) i32 = block { yield(euler1(x)); }; 46 | // 47 | // 48 | // To use see the resulting bytecode, run 49 | // 50 | // $ ./iplc.opt euler.ipl 51 | // 52 | // This gives a LLVM bytecode file euler.bc. The bytecode file can be 53 | // disassembled using 54 | // 55 | // $ llvm-dis euler.bc 56 | // 57 | // This gives a text file 'euler.ll' containing the LLVM assembly 58 | // listing for the euler() function. At the time of writing, the LLVM 59 | // generated by iplc looks like this: 60 | // 61 | // define i32 @euler(i32 %x) { 62 | // entry: 63 | // br label %begin 64 | // 65 | // begin: ; preds = %merge, %entry 66 | // %c = phi i32 [ 0, %entry ], [ %c2, %merge ] 67 | // %z = phi i32 [ 0, %entry ], [ %z2, %merge ] 68 | // %0 = icmp ult i32 %z, %x 69 | // br i1 %0, label %loop, label %end 70 | // 71 | // loop: ; preds = %begin 72 | // %1 = srem i32 %z, 3 73 | // %2 = icmp eq i32 %1, 0 74 | // br i1 %2, label %merge, label %false 75 | // 76 | // end: ; preds = %begin 77 | // ret i32 %c 78 | // 79 | // false: ; preds = %loop 80 | // %3 = srem i32 %z, 5 81 | // %4 = icmp eq i32 %3, 0 82 | // %phitmp = select i1 %4, i32 %z, i32 0 83 | // br label %merge 84 | // 85 | // merge: ; preds = %false, %loop 86 | // %tmp = phi i32 [ %phitmp, %false ], [ %z, %loop ] 87 | // %c2 = add i32 %tmp, %c 88 | // %z2 = add i32 %z, 1 89 | // br label %begin 90 | // } 91 | 92 | // Finally, we can test the compiled function (as opposed to the 93 | // interpreted function) using the IPL test syntax. 94 | test euler(10) = 23; 95 | test euler(1000) = 233168; 96 | 97 | // These test will load the LLVM bytecode, execute it inside iplc, and 98 | // verify that it gives the expected output. 99 | -------------------------------------------------------------------------------- /examples/fibonacci.ipl: -------------------------------------------------------------------------------- 1 | // This module implements the Fibonacci function. It also gives a 2 | // solution to the second problem from Project Euler 3 | // (projecteuler.net), viz., 4 | // 5 | // "Each new term in the Fibonacci sequence is generated by adding the 6 | // previous two terms. By starting with 1 and 2, the first 10 terms 7 | // will be: 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ... 8 | // 9 | // By considering the terms in the Fibonacci sequence whose values do 10 | // not exceed four million, find the sum of the even-valued terms. 11 | // Answer: 4613732" 12 | 13 | val (+) = mod32::+; 14 | 15 | // This is a simple but reasonably efficent implementation of the 16 | // Fibonacci function. 17 | fun fib(x i32) = purify i32 { 18 | new a = new_i32(0); 19 | new b = new_i32(1); 20 | for _ in 0..x { 21 | val old_a = get a; 22 | val old_b = get b; 23 | a := old_b; 24 | b := old_a + old_b; 25 | } 26 | yield(get a); 27 | }; 28 | 29 | // Test the first few terms of the Fibonacci function. 30 | assert fib(0) = 0 is i32; 31 | assert fib(1) = 1 is i32; 32 | assert fib(2) = 1 is i32; 33 | assert fib(3) = 2 is i32; 34 | assert fib(4) = 3 is i32; 35 | assert fib(5) = 5 is i32; 36 | assert fib(6) = 8 is i32; 37 | assert fib(7) = 13 is i32; 38 | assert fib(8) = 21 is i32; 39 | assert fib(46) = 1836311903 is i32; 40 | 41 | // Compile the Fibonacci function. 42 | compile fib(x i32) i32 = block { yield(fib(x)); }; 43 | test fib(46) = 1836311903; 44 | 45 | // Here is the resulting LLVM listing. 46 | // 47 | // define i32 @fib(i32 %x) { 48 | // entry: 49 | // br label %begin 50 | // 51 | // begin: ; preds = %loop, %entry 52 | // %b = phi i32 [ 1, %entry ], [ %1, %loop ] 53 | // %a = phi i32 [ 0, %entry ], [ %b, %loop ] 54 | // %range = phi i32 [ 0, %entry ], [ %2, %loop ] 55 | // %0 = icmp ult i32 %range, %x 56 | // br i1 %0, label %loop, label %end 57 | // 58 | // loop: ; preds = %begin 59 | // %1 = add i32 %a, %b 60 | // %2 = add i32 %range, 1 61 | // br label %begin 62 | // 63 | // end: ; preds = %begin 64 | // ret i32 %a 65 | // } 66 | 67 | val (<) = mod32::<; 68 | val (==) = mod32::==; 69 | fun (x bool) && (y bool) = x ? y : false; 70 | fun (x bool) || (y bool) = x ? true : y; 71 | fun (x i32) <= (y i32) = x < y || x == y; 72 | val and = mod32::and; 73 | 74 | fun (I interface) ++ (J interface) interface = meth { 75 | false: I, 76 | true: J 77 | }; 78 | fun !(x bool) = x ? false : true; 79 | 80 | val i_range interface = meth(_ i32) void; 81 | val range type = i_range => void; 82 | val i_break interface = meth(_ i32) bool; 83 | val break type = i_break => bool; 84 | 85 | assert catch is 86 | dep(b type) -> 87 | dep(i interface) -> 88 | dep(a type) -> 89 | dep(_ b -> i => a) -> 90 | (i ++ (meth(_ b) enum{}) => a) -> 91 | i => a; 92 | 93 | 94 | fun breakable(rng range) break = 95 | catch(void)(i_break)(bool)(fun(_) block { yield(false); })( 96 | block { 97 | for c in rng { 98 | val x = do call(false@c); 99 | if !x { val y = do call(true@()); yield(do fun{}(y)); } 100 | } 101 | yield(true); 102 | }); 103 | 104 | 105 | // This solution to the second Euler problem is very inefficient and 106 | // doesn't use any properties of the Fibonacci sequence to optimize 107 | // the algorithm. 108 | // 109 | // One natural solution to this problem is to use a while loop, but 110 | // there are currently no plans to implement while loops in IPL, as 111 | // all programs in type theory must be terminating. 112 | // 113 | // A future version of IPL will support range loops with break and 114 | // continue, and, more generally, an efficiently implemented 115 | // throw/catch construct that can be used to break out of (possibly 116 | // nested) loops. 117 | fun euler2(max i32) = purify i32 { 118 | new sum = new_i32(0); 119 | val _ bool = for i in breakable(0..max) { 120 | val a = fib(i); 121 | // Count a if a <= max and the lsb of a is unset. 122 | if a <= max { 123 | if and(a, 1) == 0 { 124 | sum := sum + a; 125 | } 126 | yield(true); // continue 127 | } else { 128 | yield(false); // break 129 | } 130 | } 131 | yield(get sum); 132 | }; 133 | 134 | // Check that we have a correct solution. 135 | assert euler2(4000000) = 4613732 is i32; 136 | 137 | // Compile the solution to the second Euler problem. 138 | compile euler2(max i32) i32 = block { yield(euler2(max)); }; 139 | 140 | // Check that the compiled function works too. 141 | test euler2(4000000) = 4613732; 142 | 143 | // The compiled version of euler2 is rather interesting. 144 | // 145 | // 146 | // define i32 @euler2(i32 %max) { 147 | // entry: 148 | // %0 = icmp sgt i32 %max, 2 149 | // br i1 %0, label %merge37, label %false38 150 | // 151 | // merge37: ; preds = %false38, %entry 152 | // %merge40 = phi i32 [ %phitmp, %false38 ], [ 2, %entry ] 153 | // %1 = icmp sgt i32 %max, 8 154 | // %2 = icmp eq i32 %max, 8 155 | // %. = select i1 %1, i1 true, i1 %2 156 | // %3 = or i32 %merge40, 8 157 | // %local_cell.6 = select i1 %., i32 %3, i32 %merge40 158 | // %4 = icmp sgt i32 %max, 34 159 | // %5 = icmp eq i32 %max, 34 160 | // %.793 = select i1 %4, i1 true, i1 %5 161 | // %6 = add i32 %local_cell.6, 34 162 | // %local_cell.9 = select i1 %.793, i32 %6, i32 %local_cell.6 163 | // %7 = icmp sgt i32 %max, 144 164 | // %8 = icmp eq i32 %max, 144 165 | // %.794 = select i1 %7, i1 true, i1 %8 166 | // %9 = add i32 %local_cell.9, 144 167 | // %local_cell.12 = select i1 %.794, i32 %9, i32 %local_cell.9 168 | // %10 = icmp sgt i32 %max, 610 169 | // %11 = icmp eq i32 %max, 610 170 | // %.795 = select i1 %10, i1 true, i1 %11 171 | // %12 = add i32 %local_cell.12, 610 172 | // %local_cell.15 = select i1 %.795, i32 %12, i32 %local_cell.12 173 | // %13 = icmp sgt i32 %max, 2584 174 | // %14 = icmp eq i32 %max, 2584 175 | // %.796 = select i1 %13, i1 true, i1 %14 176 | // %15 = add i32 %local_cell.15, 2584 177 | // %local_cell.18 = select i1 %.796, i32 %15, i32 %local_cell.15 178 | // %16 = icmp sgt i32 %max, 10946 179 | // %17 = icmp eq i32 %max, 10946 180 | // %.797 = select i1 %16, i1 true, i1 %17 181 | // %18 = add i32 %local_cell.18, 10946 182 | // %local_cell.21 = select i1 %.797, i32 %18, i32 %local_cell.18 183 | // %19 = icmp sgt i32 %max, 46368 184 | // %20 = icmp eq i32 %max, 46368 185 | // %.798 = select i1 %19, i1 true, i1 %20 186 | // %21 = add i32 %local_cell.21, 46368 187 | // %local_cell.24 = select i1 %.798, i32 %21, i32 %local_cell.21 188 | // %22 = icmp sgt i32 %max, 196418 189 | // %23 = icmp eq i32 %max, 196418 190 | // %.799 = select i1 %22, i1 true, i1 %23 191 | // %24 = add i32 %local_cell.24, 196418 192 | // %local_cell.27 = select i1 %.799, i32 %24, i32 %local_cell.24 193 | // %25 = icmp sgt i32 %max, 832040 194 | // %26 = icmp eq i32 %max, 832040 195 | // %.800 = select i1 %25, i1 true, i1 %26 196 | // %27 = add i32 %local_cell.27, 832040 197 | // %local_cell.30 = select i1 %.800, i32 %27, i32 %local_cell.27 198 | // %28 = icmp sgt i32 %max, 3524578 199 | // %29 = icmp eq i32 %max, 3524578 200 | // %.801 = select i1 %28, i1 true, i1 %29 201 | // %30 = add i32 %local_cell.30, 3524578 202 | // %local_cell.33 = select i1 %.801, i32 %30, i32 %local_cell.30 203 | // %31 = icmp sgt i32 %max, 14930352 204 | // %32 = icmp eq i32 %max, 14930352 205 | // %.802 = select i1 %31, i1 true, i1 %32 206 | // %33 = add i32 %local_cell.33, 14930352 207 | // %local_cell.36 = select i1 %.802, i32 %33, i32 %local_cell.33 208 | // %34 = icmp sgt i32 %max, 63245986 209 | // %35 = icmp eq i32 %max, 63245986 210 | // %.803 = select i1 %34, i1 true, i1 %35 211 | // %36 = add i32 %local_cell.36, 63245986 212 | // %local_cell.39 = select i1 %.803, i32 %36, i32 %local_cell.36 213 | // %37 = icmp sgt i32 %max, 267914296 214 | // %38 = icmp eq i32 %max, 267914296 215 | // %.804 = select i1 %37, i1 true, i1 %38 216 | // %39 = add i32 %local_cell.39, 267914296 217 | // %local_cell.42 = select i1 %.804, i32 %39, i32 %local_cell.39 218 | // %40 = icmp sgt i32 %max, 1134903170 219 | // %41 = icmp eq i32 %max, 1134903170 220 | // %.805 = select i1 %40, i1 true, i1 %41 221 | // %42 = add i32 %local_cell.42, 1134903170 222 | // %local_cell.45 = select i1 %.805, i32 %42, i32 %local_cell.42 223 | // ret i32 %local_cell.45 224 | // 225 | // false38: ; preds = %entry 226 | // %43 = icmp eq i32 %max, 2 227 | // %phitmp = select i1 %43, i32 2, i32 0 228 | // br label %merge37 229 | // } 230 | 231 | fun writer(A type) interface = meth(_ A) void; 232 | 233 | // A similar logic can be used to compute a sequence of Fibonacci 234 | // numbers. 235 | fun fib_seq(x i32) writer(i32) => void = block { 236 | val s meth { doit: meth(_ i32)void } => void = block { 237 | new a = new_i32(0); 238 | new b = new_i32(1); 239 | for _ in 0..x { 240 | val old_a = get a; 241 | val old_b = get b; 242 | a := old_b; 243 | val new_b = old_a + old_b; 244 | b := new_b; 245 | do call(doit@new_b); 246 | } 247 | }; 248 | val ss writer(i32) => void = interpret s { 249 | fun { 250 | doit@y: block { do call(y); } 251 | } 252 | }; 253 | yield(do ss); 254 | }; 255 | 256 | // Should 257 | // continue; 258 | // be an abbreviation for 259 | // yield('continue); 260 | // ? and similar for break? 261 | fun euler2v2(max i32) = purify i32 { 262 | new sum = new_i32(0); 263 | val _ bool = for i in breakable(fib_seq(max)) { 264 | if i <= max { 265 | if and(i, 1) == 0 { 266 | sum := sum + i; 267 | } 268 | yield(true); // continue 269 | } else { 270 | yield(false); // break 271 | } 272 | } 273 | yield(get sum); 274 | }; 275 | 276 | // Check that we have a correct solution. 277 | assert euler2v2(4000000) = 4613732 is i32; 278 | 279 | // Compile the solution to the second Euler problem. 280 | compile euler2v2(max i32) i32 = block { yield(euler2(max)); }; 281 | 282 | // Check that the compiled function works too. 283 | test euler2v2(4000000) = 4613732; 284 | -------------------------------------------------------------------------------- /examples/hedbergs_theorem.ipl: -------------------------------------------------------------------------------- 1 | // This is an implementation of Hedberg's theorem in the 2 | // intuitionistic programming language. 3 | // 4 | // Michael Hedberg. "A coherence theorem for Martin-Löf’s type 5 | // theory". In: J. Funct. Programming 8 (1998), pp. 413-436. 6 | // 7 | // The main difference is that we prove the theorem only for small 8 | // types (IPL's 'type' corresponds to the first universe U in ITT). 9 | 10 | // First, propositional equality is symmetric. 11 | fun sym(A type, x A, y A, z x eq(A) y) y eq(A) x = 12 | subst(z, refl)(u, _) u eq(A) x; 13 | 14 | // Propositional equality is transitive. 15 | fun trans(A type, x A, y A, z A, u x eq(A) y, v y eq(A) z) x eq(A) z = 16 | subst(v, u)(i, _) x eq(A) i; 17 | 18 | // If z is a proof that x is equal to y, then sym(z) can be viewed as 19 | // a kind of inverse of z. Similarly, trans(z, w) can be viewed as a 20 | // kind of multiplication of identity proofs. The resulting formal 21 | // structure is called a groupoid. The following groupoid law states, 22 | // informally, that trans(z, sym(z)) is equal to the reflexivity 23 | // proof, which serves as the unit element of the groupoid. 24 | fun groupoid(A type, x A, y A, z x eq(A) y) 25 | trans(A, x, y, x, z, sym(A, x, y, z)) eq(x eq(A) x) refl = ( 26 | fun C(i A, j x eq(A) i) type = 27 | trans(A, x, i, x, j, sym(A, x, i, j)) eq(x eq(A) x) refl; 28 | subst(z, refl)(i, j)C(i, j) 29 | ); 30 | 31 | // This lemma states, informally, that if x is equal to y, then f(x) 32 | // is equal to f(y). 33 | fun lift(A type, f A -> A, x A, y A, p x eq(A) y) f(x) eq(A) f(y) = 34 | subst(p, refl)(i, _) f(x) eq(A) f(i) 35 | ; 36 | 37 | // dec(A) represents the proposition that A is inhabited or empty, 38 | // i.e., that the inhabitation problem for A is decidable. 39 | fun dec(A type) type = union { 40 | inhabited: A, 41 | empty: A -> enum {} 42 | }; 43 | 44 | // A function is constant if, for all x and y, f(x) is equal to f(y). 45 | fun is_c(A type, f A -> A) type = dep(x A, y A) -> f(x) eq(A) f(y); 46 | 47 | // On any decidable set, a constant function can be defined. 48 | fun con(A type) dec(A) -> A -> A = fun { 49 | inhabited@w: fun(_) w, 50 | empty@f: fun(x) fun{}(f(x)) 51 | }; 52 | 53 | // Hedberg's constancy lemma states that the function defined above is 54 | // indeed constant. 55 | fun con_lemma(A type) dep(z dec(A)) -> is_c(A, con(A)(z)) = 56 | fun { 57 | inhabited@_: fun(_, _) refl, 58 | empty@f: fun(x, _) fun{}(f(x)) 59 | }; 60 | 61 | // We say that a set is collapsed, if, for all x and y, x is equal to y. 62 | fun collapsed(A type) type = dep(x A, y A) -> x eq(A) y; 63 | 64 | // A function g is a left inverse to a function g if g(f(x)) is equal 65 | // to x, for all x. 66 | fun is_li(A type, f A -> A, g A -> A) = dep(x A) -> g(f(x)) eq(A) x; 67 | 68 | // Hedberg's collapse lemma states that, if a set admits a constant 69 | // function with a left inverse, then the set is collapsed. 70 | fun collapse_lemma(A type, f A -> A, g A -> A, c is_c(A, f), li is_li(A, f, g)) 71 | collapsed(A) = fun (a, b) ( 72 | val p a eq(A) g(f(a)) = sym(A, g(f(a)), a, li(a)); 73 | val q g(f(a)) eq(A) g(f(b)) = lift(A, g, f(a), f(b), c(a, b)); 74 | val r g(f(b)) eq(A) b = li(b); 75 | val s a eq(A) g(f(b)) = trans(A, a, g(f(a)), g(f(b)), p, q); 76 | trans(A, a, g(f(b)), b, s, r) 77 | ); 78 | 79 | // eq_fam(A) denotes the family of functions on equality proofs on A. 80 | fun eq_fam(A type) type = dep(x A, y A) -> x eq(A) y -> x eq(A) y; 81 | 82 | // Each eq_fam(A) has a family of left inverses. 83 | fun li(A type, v eq_fam(A)) eq_fam(A) = 84 | fun(x, y) fun(w) 85 | trans(A, x, y, y, w, sym(A, y, y, v(y, y)(refl))); 86 | 87 | // Hedberg's left inverse lemma states that the family of defined 88 | // above is a family of left inverses. 89 | fun li_lemma(A type, v eq_fam(A)) 90 | dep(x A, y A) -> 91 | is_li(x eq(A) y, v(x, y), li(A, v)(x, y)) = fun(x, y) fun(z) ( 92 | // Proof obligation is li(A, v)(x, y)(v(x, y)(z)) eq(x eq(A) y) z. But the 93 | // left hand side is definitionally equal to 94 | // trans(A, x, y, y, v(x, y)(z), sym(A, y, y, v(y, y)(refl))). 95 | val p = groupoid(A, x, x, v(x, x)(refl)); 96 | subst(z, p)(i, j) 97 | trans(A, x, i, i, v(x, i)(j), sym(A, i, i, v(i, i)(refl))) eq(x eq(A) i) j 98 | ); 99 | 100 | // dec_eq(A) represents the proposition that A has decidable equality. 101 | fun dec_eq(A type) type = dep(x A, y A) -> dec(x eq(A) y); 102 | 103 | // This is Hedberg's theorem, viz., that a set with decidable equality 104 | // has collapsed equality proofs. 105 | fun hedberg(A type, d dec_eq(A)) dep(x A, y A) -> collapsed(x eq(A) y) = ( 106 | fun v(x A, y A) = con(x eq(A) y)(d(x, y)); 107 | fun vc(x A, y A) is_c(x eq(A) y, v(x, y)) = con_lemma(x eq(A) y)(d(x, y)); 108 | val w eq_fam(A) = li(A, v); 109 | fun wv(x A, y A) is_li(x eq(A) y, v(x, y), w(x, y)) = li_lemma(A, v)(x, y); 110 | fun(x, y) collapse_lemma(x eq(A) y, v(x, y), w(x, y), vc(x, y), wv(x, y)) 111 | ); 112 | -------------------------------------------------------------------------------- /examples/methcall.ipl: -------------------------------------------------------------------------------- 1 | // This file implements the first part of the methcall benchmark from 2 | // the language shootout. 3 | // 4 | // For background on how interfaces and procedures are implemented in 5 | // IPL, please refer to the paper. 6 | // 7 | // Johan Georg Granström. "A new paradigm for component-based 8 | // development". In: J. Software 7 (2012), pp. 1136-1148. 9 | 10 | // First, this is the interface that we must implement. 11 | val I_toggle = meth { 12 | value: meth(_ void) bool, 13 | activate: meth(_ void) void 14 | }; 15 | 16 | // This interface is used internally in IPL to implement the 'new' construct. 17 | fun (I interface) ++ (J interface) interface = meth { 18 | false: I, 19 | true: J 20 | }; 21 | 22 | // This is the interface introduced by new_i32. 23 | val prop32 = meth(_ i32 -> i32) i32; 24 | 25 | // In fact, new_i32 has the following type: 26 | assert new_i32 is 27 | i32 -> 28 | dep(I interface) -> 29 | dep(A type) -> 30 | tuple(J interface, _ (I ++ J => A) -> I => A); 31 | 32 | // Moreover, the interface J is prop32. 33 | assert fst(new_i32(0)(meth {})(enum {})) = prop32 is interface; 34 | 35 | 36 | // Abbreviations for the implementation of the toggle. 37 | val (==) = mod32::==; 38 | val (-) = mod32::-; 39 | 40 | // Here is an implementation of a simple toggler. This constructions 41 | // corresponds to implementing a class with state of type i32 and the 42 | // methods of I_toggle. 43 | // 44 | // A more readable syntax for the same construct would be something 45 | // like this: 46 | // 47 | // class toggle(start_state bool) { 48 | // new state = new_i32(start_state ? 1 : 0); 49 | // meth value(_ void) bool = block { 50 | // val x = get state; 51 | // yield(x == 1); 52 | // }; 53 | // meth activate(_ void) void = block { 54 | // state := 1 - state; 55 | // }; 56 | // }; 57 | // 58 | // Of course, future versions of IPL should support mutable enum 59 | // variables (e.g. bool): in the current version, variables have to 60 | // have type iN for some N in {8, 16, 32, 64}. 61 | // 62 | // The definitions below shows how this class has to be written in the 63 | // current implementation of IPL, and has the virtue of revealing how 64 | // classes are implemented "under the hood". 65 | 66 | fun toggle_helper( 67 | I interface, A type, prog I ++ I_toggle => A) I ++ prop32 => A = 68 | interpret prog { 69 | fun { 70 | false@x: call(false@x), 71 | true@: fun { 72 | value@_: block { val x = get true; yield(x == 1); }, 73 | activate@_: block { val _ = do true.call(fun(x) 1 - x); } 74 | } 75 | } 76 | }; 77 | 78 | fun toggle(start_state bool) 79 | dep(I interface) -> 80 | dep(A type) -> 81 | tuple(J interface, _ (I ++ J => A) -> I => A) = 82 | fun(I) fun(A) 83 | (I_toggle, fun(prog) 84 | snd(new_i32(start_state ? 1 : 0)(I)(A))(toggle_helper(I, A, prog))); 85 | 86 | // This is the way the language shootout problem is implemented i 87 | // C/C++, using a counter val (here bval). Of course, this counter 88 | // could be removed and the final line replaced with 89 | // val x = b.call(value@()); 90 | // yield(x ? 1 : 0); 91 | compile main(n i32) i32 = block { 92 | new bval = new_i32(1); 93 | new b = toggle(true); 94 | for _ in 0 .. n { 95 | do b.call(activate@()); 96 | val x bool = do b.call(value@()); 97 | bval := x ? 1 : 0; 98 | } 99 | yield(get bval); 100 | }; 101 | 102 | test main(1000000) = 1; 103 | -------------------------------------------------------------------------------- /examples/modules.ipl: -------------------------------------------------------------------------------- 1 | // TBR. -------------------------------------------------------------------------------- /examples/popcount.ipl: -------------------------------------------------------------------------------- 1 | val (-) = mod64::-; 2 | val (+) = mod64::+; 3 | val (*) = mod64::*; 4 | val lsr = mod64::lsr; 5 | val and = mod64::and; 6 | 7 | fun popcount(x0 i64) i8 = 8 | ( 9 | val x1 = x0 - and(lsr(x0, 1c), 0x5555555555555555); 10 | val x2 = and(x1, 0x3333333333333333) + and(lsr(x1, 2c), 0x3333333333333333); 11 | val x3 = and(x2 + lsr(x2, 4c), 0x0f0f0f0f0f0f0f0f); 12 | mod64::to_i8(lsr(x3 * 0x0101010101010101, 56c)) 13 | ); 14 | 15 | assert popcount(0q) = 0c is i8; 16 | assert popcount(1q) = 1c is i8; 17 | assert popcount(2q) = 1c is i8; 18 | assert popcount(3q) = 2c is i8; 19 | assert popcount(4q) = 1c is i8; 20 | assert popcount(0x0101010101010101) = 8c is i8; 21 | assert popcount(0xffffffffffffffff) = 64c is i8; 22 | assert popcount(0xf0f0f0f0f0f0f0f0) = 32c is i8; 23 | assert popcount(0x0f0f0f0f0f0f0f0f) = 32c is i8; 24 | 25 | compile popcount(x i64) i8 = block { yield(popcount(x)); }; 26 | 27 | test popcount(0q) = 0c; 28 | test popcount(1q) = 1c; 29 | test popcount(2q) = 1c; 30 | test popcount(3q) = 2c; 31 | test popcount(4q) = 1c; 32 | test popcount(0x0101010101010101) = 8c; 33 | test popcount(0xffffffffffffffff) = 64c; 34 | test popcount(0xf0f0f0f0f0f0f0f0) = 32c; 35 | test popcount(0x0f0f0f0f0f0f0f0f) = 32c; 36 | -------------------------------------------------------------------------------- /examples/tutorial.ipl: -------------------------------------------------------------------------------- 1 | // This whole file can be run through the type checker using the command 2 | // 3 | // $ ./iplc.opt tutorial.ipl. 4 | // 5 | // Many kinds of tests can be done at compile time: this can either be 6 | // small unit test, or type assertions to assist the reader of the 7 | // code. There are two forms of assertions: type assertions and 8 | // equality assertions. 9 | // 10 | // assert is ; 11 | // 12 | // assert = is ; 13 | // 14 | // In IPL, void is a first class type with exacly one value, denoted 15 | // (). In this sense, the type 'void' is similar to Ocaml's 'unit' or 16 | // Haskell's type '()'. 17 | 18 | assert () is void; 19 | assert () = () is void; 20 | 21 | // Of course, void is not an empty type (as Haskell's Void). However, 22 | // the use of word 'void' in this context is motivated by its use in 23 | // C: also, one could argue that the type void is void of information, 24 | // i.e., that an object of type void carries no information content. 25 | 26 | // The type 'bool' is predefined, but if it wasn't predefined, it 27 | // could have been defined as 28 | // 29 | // val bool = enum{false, true}; 30 | // 31 | // Enum types are first class types, and their syntax is inspired by 32 | // C. 33 | assert bool = enum{false, true} is type; 34 | 35 | // The order of the constants of an enum doesn't matter. 36 | assert enum{true, false} = enum{false, true} is type; 37 | 38 | // The constants of an enum are written with a quote, 39 | assert 'foo is enum{foo, bar}; 40 | assert 'bar is enum{foo, bar}; 41 | 42 | // The constants true and false are predefined. 43 | assert true = 'true is bool; 44 | assert false = 'false is bool; 45 | 46 | // The definition of a new value uses the syntax 47 | // 48 | // val = ; 49 | // 50 | // The type annotation is optional if is monomorphic. 51 | // 52 | // val = ; 53 | 54 | // Define the empty type. 55 | val empty = enum{}; 56 | 57 | // Functions are defined using the 'fun' syntax. 58 | fun sample_function1(x empty, y bool) = y; 59 | 60 | // Define the abort function. 61 | fun abort(t type) empty -> t = fun{}; 62 | // The fun{...} construction is explained below. 63 | 64 | // Builtin type of unsigned 32-bit integers. 65 | assert i32 is type; 66 | 67 | // Define abbreviations for the usual arithmetic operators. The full 68 | // list of built-in functions is in the file initial.ml. 69 | val (+) = mod32::+; 70 | val (-) = mod32::-; 71 | val (-.) = mod32::(-.); 72 | val (*) = mod32::*; 73 | val xor = mod32::xor; 74 | val ior = mod32::ior; 75 | val and = mod32::and; 76 | val lsl = mod32::lsl; 77 | val lsr = mod32::lsr; 78 | val asr = mod32::asr; 79 | val (<) = mod32::<; 80 | val (==) = mod32::==; 81 | 82 | // Some tests of builtin arithmetic. 83 | assert 9 = 3 + 3 + 3 is i32; 84 | assert 0xffffffff = 0x0000ffff + 0xffff0000 is i32; 85 | assert 0x00000000 = 0x00000001 + 0xffffffff is i32; 86 | assert 0xffffffff = -1 is i32; 87 | assert 6 = 2 * 3 is i32; 88 | assert 6 = -2 * -3 is i32; 89 | assert 0x0f0f0f0f = xor(0xffffffff, 0xf0f0f0f0) is i32; 90 | assert 0xfffff0f0 = ior(0xffff0000, 0xf0f0f0f0) is i32; 91 | assert 0xf0f00000 = and(0xffff0000, 0xf0f0f0f0) is i32; 92 | assert lsl(1, 31c) = 0x80000000 is i32; 93 | assert lsl(1, 32c) = 1 is i32; 94 | assert lsl(2, 31c) = 0 is i32; 95 | assert lsr(100, 0c) = 100 is i32; 96 | assert lsr(0x80000000, 4c) = 0x08000000 is i32; 97 | assert asr(0x80000000, 4c) = 0xf8000000 is i32; 98 | assert lsr(4, 2c) = 1 is i32; 99 | 100 | // A binary operation binop(t), on a type t, is a function from t 101 | // times t to t. 102 | fun binop(t type) = tuple(_ t, _ t) -> t; 103 | assert (+) is binop(i32); 104 | assert (-) is binop(i32); 105 | 106 | // A (decidable) binary relation binrel(t), on a set t, is a function 107 | // from t times t to bool. 108 | fun binrel(t type) = tuple(_ t, _ t) -> bool; 109 | assert (<) is binrel(i32); 110 | assert (==) is binrel(i32); 111 | 112 | // id is the polymorphic identity function. 113 | fun id(t type) t -> t = fun(x) x; 114 | 115 | // For example: 116 | assert id(bool) = fun(x) x is bool -> bool; 117 | 118 | // This constant function is not equal to the identity function 119 | // id(void). 120 | assert fun(_) () is void -> void; 121 | 122 | // The fun{...} construction is used to create a, possibly 123 | // dependently typed, function defined on an enumerated set. For 124 | // example: 125 | val dep_type bool -> type = fun{true: i32, false: i64}; 126 | assert dep_type('true) = i32 is type; 127 | assert dep_type('false) = i64 is type; 128 | val dep_fun dep(x bool) -> dep_type(x) = fun{ 129 | true: 100, 130 | false: 1000000000q 131 | }; 132 | // Here dep(x A) -> B(x) is the dependent function type, and an 133 | // integer literal ending with a q is a 64-bit literal. 134 | assert dep_fun(true) = 100 is i32; 135 | assert dep_fun(false) = 1000000000q is i64; 136 | 137 | // Dependently typed functions work just like normal function, with 138 | // one difference, viz., that non-dependent functions can be applied 139 | // without having a known type, for example: 140 | assert (fun(x) x + x)(1) = 2 is i32; 141 | // This doesn't work for dependently typed functions. For example, the 142 | // following assertion will give an error. 143 | // 144 | // assert fun{true: 100, false: 1000000000q}(true) = 100 is i32; 145 | // 146 | // This is because the type checking algorithm will erronously deduce 147 | // that fun{...} must have type bool->i32, and the subsequent checking 148 | // of this will fail. 149 | 150 | // Boolean negation is written as in C. 151 | fun !(x bool) = x ? false : true; 152 | // A unary operator is accessed as a function by putting it within 153 | // parenthesis followed by a dot. Without the dot, the corresponding 154 | // binary operator is referenced (if there is one, such as for minus). 155 | assert (!.) is bool -> bool; 156 | // Complete specification! 157 | assert !true = false is bool; 158 | assert !false = true is bool; 159 | 160 | // Boolean conjunction is written as in C. 161 | fun (x bool) && (y bool) = x ? y : false; 162 | assert (&&) is binop(bool); 163 | // Complete specification! 164 | assert true && true = true is bool; 165 | assert true && false = false is bool; 166 | assert false && true = false is bool; 167 | assert false && false = false is bool; 168 | // First argument is evaluated first. 169 | assert fun(x) true && x = id(bool) is bool -> bool; 170 | assert fun(x) false && x = fun(x) false is bool -> bool; 171 | 172 | // Boolean disjunction is written as in C. 173 | fun (x bool) || (y bool) = x ? true : y; 174 | // Complete specification! 175 | assert true || true = true is bool; 176 | assert true || false = true is bool; 177 | assert false || true = true is bool; 178 | assert false || false = false is bool; 179 | assert fun(x) false || x = fun(x) x is bool -> bool; 180 | assert fun(x) true || x = fun(x) true is bool -> bool; 181 | 182 | fun (x bool) ^^ (y bool) = x ? !y : y; 183 | // Complete specification! 184 | assert true ^^ true = false is bool; 185 | assert true ^^ false = true is bool; 186 | assert false ^^ true = true is bool; 187 | assert false ^^ false = false is bool; 188 | assert fun(x) false ^^ x = fun(x) x is bool -> bool; 189 | assert fun(x) true ^^ x = fun(x) !x is bool -> bool; 190 | 191 | // Syntax of structs. 192 | val sample_struct1 = struct {}; 193 | val sample_struct2 = struct {a: bool}; 194 | val sample_struct3 = struct {a: bool, b: i32}; 195 | 196 | // A struct is simply a dependently typed function from an enumerated 197 | // set. 198 | assert struct {x: bool, y: i32} = 199 | dep(z enum{x, y}) -> fun{x: bool, y: i32}(z) 200 | is type; 201 | 202 | // Records. 203 | val record1 sample_struct1 = fun{}; 204 | val record2 sample_struct2 = fun{a: true}; 205 | val record3 sample_struct3 = fun{a:true, b: 42}; 206 | 207 | // Record fields can be accessed using the following notation: 208 | assert record3::a = true is bool; 209 | assert record3::b = 42 is i32; 210 | 211 | // However, record field extraction is simply application. 212 | assert record2('a) = true is bool; 213 | 214 | // A union is a dependently typed pair with an enumerated first 215 | // component. For example: 216 | val sample_union1 = union{}; 217 | val sample_union2 = union{a: bool}; 218 | val sample_union3 = union{a: bool, b: sample_struct3}; 219 | 220 | // The normal syntax for pairs can be used to create union objects. 221 | assert ('a, true) is sample_union2; 222 | assert ('b, fun{a:true, b:0}) is sample_union3; 223 | 224 | // However, the following notation is often more convenient: 225 | assert a@true = ('a, true) is sample_union2; 226 | 227 | // The fun{...} notation is extended to work on unions. 228 | val sample_union_fun sample_union3 -> bool = 229 | fun{a@x: !x, b@y: y::a}; 230 | 231 | assert sample_union_fun(a@false) = true is bool; 232 | 233 | // The type 'interface' is defined as tuple(x type, _ x -> type). The 234 | // constant 'cmd' extracts the commands' of an interface. 235 | assert cmd = fun(i) fst(i) is interface -> type; 236 | assert cmd = fun(i) fst(i) is tuple(x type, _ x -> type) -> type; 237 | 238 | // The constant 'res' extracts the type of responses to a command. 239 | assert res = fun(i, x) snd(i)(x) is 240 | tuple(i interface, _ cmd(i)) -> type; 241 | // Note the dependency in the type of res. 242 | 243 | // Interfaces can be created using normal pair notatation. For 244 | // example: 245 | assert (i32, fun(_) void) is interface; 246 | assert (bool, fun{true: i32, false: void}) is interface; 247 | 248 | // The following notation is a convenient alternative: 249 | assert meth(_ i32) void = (i32, fun(_) void) is interface; 250 | 251 | // Two often useful interface: 252 | fun reader(A type) interface = meth(_ void) A; 253 | fun writer(A type) interface = meth(_ A) void; 254 | 255 | // The meth {...} can be used to create interfaces where the set of 256 | // commands is a union. 257 | val systemX = meth { 258 | do_something: reader(bool), 259 | print_int: writer(i32) 260 | }; 261 | 262 | // To understand how this works, it is important to first understand 263 | // how to take the product of a family of interfaces. 264 | fun interface_prod(A type, F A -> interface) interface = 265 | meth(x A, y cmd(F(x))) res(F(x), y); 266 | 267 | val systemX_cmd = enum{do_something, print_int}; 268 | val systemX_res systemX_cmd -> interface = fun{ 269 | do_something: meth(x void) bool, 270 | print_int: meth(_ i32) void 271 | }; 272 | 273 | // The 'call' syntax is used to create a procedure that invokes a 274 | // command on an interface and returns its result. 275 | assert call(10) is writer(i32) => void; 276 | assert call() is reader(i32) => i32; 277 | assert call(print_int@10) is systemX => void; 278 | 279 | // Several calls can be combined into a block with the do notation. 280 | assert block { 281 | do print_int.call(10); 282 | val x = do call(do_something@()); 283 | if x { 284 | do print_int.call(100); 285 | } 286 | } is systemX => void; 287 | 288 | // A procedure can be "interpreted" using the 'interpret' syntax. For 289 | // example, a fake systemX can be defined over the empty interface. 290 | fun fake_systemX(A type, prog systemX => A) meth {} => A = interpret prog { 291 | fun{ 292 | do_something@_: block {yield(true);} , 293 | print_int@_: block {} 294 | } 295 | }; 296 | 297 | // When dealing with composite interfaces, the dot operation is often 298 | // useful. 299 | assert print_int.call(10) is systemX => void; 300 | // The same notation can be used also in the case where the right hand 301 | // side is a complex program instead of just call(10). 302 | 303 | // The dot syntax can be generalised to the case when the left hand 304 | // side is not an enum literal. 305 | fun dot(A type, 306 | F A -> interface, 307 | D type, 308 | a A, 309 | p F(a) => D) 310 | interface_prod(A, F) => D = 311 | interpret p {fun(x) call(a, x)} 312 | ; 313 | 314 | // For example: 315 | assert 'print_int is systemX_cmd; 316 | assert fun(i) print_int.call(i) = 317 | fun(i) dot(systemX_cmd, 318 | systemX_res, 319 | void, 320 | 'print_int, 321 | call(i)) 322 | is i32 -> systemX => void; 323 | 324 | 325 | // For loops are often used in conjuction with ranges. 326 | fun systemX_example(x i32) systemX => void = block { 327 | for y in 0 .. x { 328 | val ok = do call(do_something@()); 329 | if ok { 330 | do call(print_int@y); 331 | } 332 | do call(print_int@0); 333 | } 334 | }; 335 | 336 | // In addition their usefulness for generic programming with structs, 337 | // unions, and interfaces, dependent types are also useful for 338 | // expressing properties of objects. A popular example is division. 339 | // 340 | // First we introduce the following syntax: 341 | fun is_true(x bool) type = x eq(bool) true; 342 | fun is_false(x bool) type = x eq(bool) false; 343 | 344 | // The special syntax "x eq(X) y" is used to express a special 345 | // equality type. 346 | assert refl is true eq(bool) true; 347 | assert refl is false eq(bool) false; 348 | // But not 349 | // assert refl is true eq(bool) false; 350 | 351 | // In IPL, division has the following type: 352 | assert mod32::sdiv is tuple(_ i32, y i32, _ is_true(0 < y)) -> i32; 353 | // That is, we only allow division with a positive dividend. 354 | // 355 | // Why not just require that is_false(0 == y) instead? 356 | // 357 | // Well, this works fine for unsigned integers, but for signed 358 | // integers hardware often imposes the special restriction that 359 | // division of MIN_INT by -1 is undefined. To avoid a fourth argument 360 | // to sdiv, IPL restricts it to positive dividends. 361 | 362 | // For example, we have 363 | assert mod32::sdiv(10, 2, refl) = 5 is i32; 364 | // But not 365 | // assert mod32::sdiv(1, 0, refl) is i32; 366 | 367 | // The following construct demonstrates that a boolean is either true 368 | // or false. 369 | val is_true_or_false 370 | dep(x bool) -> union{true: is_true(x), false: is_false(x)} = fun{ 371 | true: true@refl, 372 | false: false@refl 373 | }; 374 | 375 | // The following built-in axiom states that integer inequality is 376 | // transitive. 377 | val less_trans dep( 378 | x i32, y i32, z i32, _ is_true(x < y), _ is_true(y < z)) -> 379 | is_true(x < z) = mod32::less_trans; 380 | assert less_trans(0, 1, 2, refl, refl) = refl is true eq(bool) true; 381 | 382 | // Similarly, it is anti-symmetric. 383 | val less_antisym dep(x i32) -> is_false(x < x) = mod32::less_antisym; 384 | assert less_antisym(10) = refl is (10 < 10) eq(bool) false; 385 | 386 | // The following built-in axiom states that if x == y returns true, 387 | // then, in fact, x and y are equal in the propositional sense. 388 | val eq_prop dep(x i32, y i32, z is_true(x == y)) -> x eq(i32) y = mod32::eq_prop; 389 | assert eq_prop(5, 5, refl) = refl is 5 eq(i32) 5; 390 | 391 | // This is the end of this tutorial. Please see the other example 392 | // files for more IPL. Finally, please subscribe to 393 | // https://groups.google.com/forum/#!forum/intuitionistic if you would 394 | // like to keep abreast of the latest developments. 395 | -------------------------------------------------------------------------------- /examples/unary_arithmetic.ipl: -------------------------------------------------------------------------------- 1 | // In proof assistants like Coq, Agda, and Epigram, it is popular to 2 | // do mathematics with unary numbers. This doesn't work so well in 3 | // IPL, as there are no recursive datatypes. However, we can do some 4 | // interesting things with interfaces and procedures. 5 | 6 | // A unary number is represented by a sequence of calls on the trivial 7 | // interface. 8 | val unary = (meth(_ void)void) => void; 9 | 10 | // An integer can be converted to a unary integer. 11 | fun i2u(x i32) unary = block { 12 | for _ in 0..x { 13 | do call(); 14 | } 15 | }; 16 | 17 | // For example: 18 | assert i2u(3) = block { 19 | do call(); 20 | do call(); 21 | do call(); 22 | } is unary; 23 | 24 | 25 | // A unary integer can be converted to an integer. 26 | fun u2i(x unary) = purify i32 { 27 | new c = new_i32(0); 28 | val (+) = mod32::+; 29 | for _ in x { 30 | c := c + 1; 31 | } 32 | yield(get c); 33 | }; 34 | 35 | assert u2i(i2u(1000)) = 1000 is i32; 36 | 37 | // Unary integers can be added. 38 | fun (x unary) + (y unary) unary = block { 39 | do x; 40 | do y; 41 | }; 42 | 43 | // Unary integers can be multiplied. 44 | fun (x unary) * (y unary) unary = block { 45 | for _ in x { 46 | do y; 47 | } 48 | }; 49 | 50 | // Try it all out. 51 | assert i2u(42) * i2u(10) + i2u(33) = 52 | i2u(mod32::+(mod32::*(42, 10), 33)) is unary; 53 | 54 | // Compile unary integer multiplication to LLVM. 55 | compile mult(x i32, y i32) i32 = block { yield(u2i(i2u(x) * i2u(y))); }; 56 | 57 | // Check that the compiled version works. 58 | test mult(1000, 1000) = 1000000; 59 | -------------------------------------------------------------------------------- /expr.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | open Base 18 | 19 | type 'a fn = pattern * 'a 20 | 21 | type enum_loc_lit = location * enum_lit 22 | 23 | type expr' = 24 | | Hole 25 | 26 | | Var of var 27 | 28 | | Imm of imm 29 | 30 | | App of expr * expr 31 | | Enum_d of (enum_loc_lit * expr) list 32 | | Enum_d2 of (enum_loc_lit * expr) list 33 | | Switch of expr * (enum_loc_lit * expr) list 34 | | Switch2 of expr * (enum_loc_lit * expr) list 35 | | First of expr 36 | | Second of expr 37 | | Call of expr 38 | | Purify of expr * expr 39 | 40 | | Complex_interface of (enum_loc_lit * expr) list 41 | 42 | | Dot of expr * expr 43 | 44 | | New of enum_loc_lit * expr * expr 45 | 46 | | Enum_cst of enum_loc_lit 47 | | Pair of expr * expr 48 | | Ret of expr 49 | | Range of expr * expr 50 | | Id of expr * expr * expr 51 | | Enum of enum_loc_lit list 52 | | Type 53 | | Interface 54 | 55 | | Pi of expr * expr fn 56 | | Sigma of expr * expr fn 57 | | Tree of expr * expr 58 | | Let of bool * expr * expr fn 59 | 60 | | For of expr * expr fn 61 | | Interpret of expr * expr 62 | 63 | | Subst of expr * expr fn fn * expr 64 | 65 | (* Optional type declaration being the type of the variable introduced. *) 66 | | Bind of expr * expr option * expr fn 67 | 68 | (* Optional type declaration being the type of the variable introduced. *) 69 | | Pattern of expr option * expr fn 70 | 71 | | Decl of expr * expr 72 | 73 | and expr = location * expr' 74 | 75 | type toplevel' = 76 | | Assert of expr * expr * toplevel 77 | | AssertEq of expr * expr * expr * toplevel 78 | | Val of location * Base.var * expr * toplevel 79 | | Compile of string * (string * expr) list * expr * expr * toplevel 80 | | Test of string * expr list * expr * toplevel 81 | | Eof 82 | 83 | and toplevel = location * toplevel' 84 | -------------------------------------------------------------------------------- /initial.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | open Base 18 | 19 | let verify_type ctx t = Check_term.set ctx (Reify.set t) 20 | 21 | let verify ctx a t = Check_term.poly ctx t (Reify.el a) 22 | 23 | let rec mkctx = 24 | function 25 | | [] -> Ctx.empty 26 | | (x, a, _A) :: cs -> 27 | (* Format.printf "adding %s\n" x; *) 28 | let ctx = mkctx cs in 29 | verify_type ctx _A; 30 | verify ctx a _A; 31 | Ctx.extend ctx no_location (Var.of_string x) a _A 32 | 33 | let mkstruct lst = 34 | let open Value in 35 | let lit x = Enum_lit x in 36 | let types = enum_map_make (List.map (fun (x, _, z) -> lit x, z) lst) in 37 | let values = enum_map_make (List.map (fun (x, y, _) -> lit x, y) lst) in 38 | let cod = Fn(fun x -> Eval.univ (Eval.mkEnum_d x (Cst Type) types)) in 39 | let enum = Enum (enum_of_enum_map values) in 40 | Eval.lambda(fun x -> Eval.mkEnum_d x cod values), Pi(enum, cod) 41 | 42 | let builtin_struct lst = 43 | mkstruct ( 44 | List.map (fun (x, y) -> 45 | let v, t = Eval.builtin_val_type y in x, lazy v, lazy t) 46 | lst) 47 | 48 | let mod_i name x = 49 | let open Value in 50 | let a, _A = 51 | builtin_struct [ 52 | "(+)" , Add x; 53 | "(-)" , Sub x; 54 | "(-.)" , Neg x; 55 | "(*)" , Mul x; 56 | "srem" , Srem x; 57 | "sdiv" , Sdiv x; 58 | "xor" , Xor x; 59 | "ior" , Or x; 60 | "and" , And x; 61 | "not" , Not x; 62 | 63 | "lsl" , Lsl x; 64 | "lsr" , Lsr x; 65 | "asr" , Asr x; 66 | 67 | "(<)" , Less x; 68 | "(==)" , Aeq x; 69 | 70 | "to_i8" , Cast (x, I8); 71 | "to_i16" , Cast (x, I16); 72 | "to_i32" , Cast (x, I32); 73 | "to_i64" , Cast (x, I64); 74 | 75 | "less_trans", Less_trans x; 76 | "less_antisym", Less_antisym x; 77 | "eq_prop", Aeq_prop x; 78 | "eq_refl", Aeq_refl x; 79 | "add_comm", Add_commutative x; 80 | "add_assoc", Add_associative x; 81 | "add_unit", Add_unit x; 82 | "add_inv", Add_inverse x; 83 | "mul_comm", Mul_commutative x; 84 | "mul_assoc", Mul_associative x; 85 | "mul_unit", Mul_unit x; 86 | "dist", Distributive x; 87 | "sub_axiom", Sub_axiom x; 88 | ] in 89 | name, a, _A 90 | 91 | let tree p = Value.Tree_u(Eval.mkFst p, Eval.mkSnd p) 92 | let split f = Eval.lambda(fun x -> f (Eval.mkFst x) (Eval.mkSnd x)) 93 | let res = split (fun y z -> Eval.mkApp (Eval.mkSnd y) z) 94 | let res_type = 95 | let open Value in 96 | Pi(Sigma(Eval.interface, Fn(fun x -> Eval.univ (Eval.mkFst x))), 97 | Cst Type) 98 | 99 | let call_type = 100 | let open Value in 101 | Pi(Sigma(Eval.interface, Fn(fun x -> (Eval.univ(Eval.mkFst x)))), 102 | Fn(fun p -> Tree(Eval.mkFst p, Eval.mkApp res p))) 103 | let call = split (fun _ y -> Value.Invk(y, Value.Fn(fun z -> Value.Ret z))) 104 | 105 | let mk_ref name i = name, Eval.new_ref i, Eval.new_ref_type i 106 | 107 | let ctx = 108 | let open Value in 109 | mkctx [ 110 | "void" , unit_u , Type; 111 | "bool" , bool_u , Type; 112 | "true" , true_cst , bool_set; 113 | "false" , false_cst , bool_set; 114 | "i64" , i64_u , Type; 115 | "i32" , i32_u , Type; 116 | "i16" , i16_u , Type; 117 | "i8" , i8_u , Type; 118 | "cmd" , Eval.lambda(Eval.mkFst) , Pi(Eval.interface, (Cst Type)); 119 | "res" , res , res_type; 120 | "call2" , call , call_type; 121 | "(=>)" , Eval.lambda(tree) , Pi(Sigma(Eval.interface, Cst Type), (Cst Type)); 122 | "catch" , Eval.catch_val , Eval.catch_type; 123 | mod_i "mod8" I8; 124 | mod_i "mod16" I16; 125 | mod_i "mod32" I32; 126 | mod_i "mod64" I64; 127 | mk_ref "new_i8" I8; 128 | mk_ref "new_i16" I16; 129 | mk_ref "new_i32" I32; 130 | mk_ref "new_i64" I64; 131 | ] 132 | -------------------------------------------------------------------------------- /ipl_compile.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | (* 18 | This module implements the most important algorithm of IPL, viz., 19 | the reduction of an arbitrary program of base type, in a context 20 | where all variables are of base type, to a program representation 21 | that easily can be translated to LLVM. 22 | *) 23 | 24 | type el = Value.el 25 | type neut = Value.neut 26 | type component = Value.component 27 | type label = Label of int 28 | type target = Target of int 29 | type alloca = Alloca of int 30 | type size = Base.size 31 | type builtin = Base.builtin 32 | type var = Base.var 33 | type imm = Base.imm 34 | type 'a enum_map = 'a Base.enum_map 35 | 36 | exception Compile_hole 37 | 38 | (* An object of this type represents a piece of code that can be 39 | compiled to an LLVM value. *) 40 | type value = 41 | (* The first value evaluates to an enum literal. *) 42 | | Select of value * value enum_map 43 | (* Gives as result whatever the block returns through End_purify. *) 44 | | Purify of target * block 45 | | Op of builtin * value list 46 | | Var of var 47 | | Imm of imm 48 | 49 | (* An object of this type represents a piece of code that can be 50 | translated to a terminated block of LLVM code. *) 51 | and block' = 52 | (* The first value evaluates to an enum literal: continue with the 53 | specified block. *) 54 | | Switch of value * block enum_map 55 | (* Final return from function. *) 56 | | Ret of value 57 | (* Similar to Ret, but instead of returning, branch to target. *) 58 | | End_purify of value * target 59 | (* Used to implement range loops. *) 60 | | Goto of label 61 | (* Range(from, to, x, loop_label, body, then) *) 62 | | Range of value * value * var * label * block * block 63 | (* Create a variable in the entry block of the function. *) 64 | | Declare_alloca of alloca * size * value * block 65 | (* Load the value of alloca into var, execute first code, update store 66 | with value, and execute second code with var bound to new value. *) 67 | | Load_and_store of alloca * var * value * var * block 68 | (* This construct is only used for memoization. *) 69 | | Block_ref of label 70 | 71 | (* A block can be "labelled" by memoization. *) 72 | and block = label option ref * block' 73 | 74 | (* Code to print values and blocks for debugging purposes. *) 75 | let format_map (vv:Format.formatter -> 'a -> unit) 76 | (fmt:Format.formatter) (a:'a Base.enum_map) = 77 | Base.Enum_map.iter (fun k v -> 78 | Format.fprintf fmt "@ %a: %a" Base.format_enum_lit k vv v) 79 | a 80 | let rec format_value (fmt:Format.formatter) :value -> unit = 81 | let open Format in 82 | function 83 | | Select(c, cs) -> 84 | fprintf fmt "@[(select %a%a)@]" 85 | format_value c (format_map format_value) cs 86 | | Purify(Target l, c) -> 87 | fprintf fmt "@[(purify target_%d@ %a)@]" l format_block c 88 | | Op(op, []) -> raise Base.Presupposition_error 89 | | Op(op, args) -> 90 | fprintf fmt "(%a" Printing.builtin op; 91 | List.iter (fun x -> fprintf fmt " %a" format_value x) args; 92 | fprintf fmt ")" 93 | | Var(x) -> fprintf fmt "%a" Var.format x 94 | | Imm(i) -> fprintf fmt "%s" (Printing.string_of_imm i) 95 | and format_block (fmt:Format.formatter) (bbb:block) :unit = 96 | let open Format in 97 | begin 98 | match !(fst bbb) with 99 | | Some(Label l) -> fprintf fmt "%d@@" l 100 | | None -> () 101 | end; 102 | match snd bbb with 103 | | Switch(c, cs) -> 104 | fprintf fmt "@[[switch %a%a]@]" 105 | format_value c (format_map format_block) cs 106 | | Goto(Label l) -> fprintf fmt "[goto label_%d]" l 107 | | Ret(c) -> fprintf fmt "[ret %a]" format_value c 108 | | End_purify(c, Target l) -> 109 | fprintf fmt "@[[end_purify %a goto target_%d]@]" format_value c l 110 | | Declare_alloca(Alloca a, sz, v, c) -> 111 | fprintf fmt "@[[alloca [cell_%d:%s = %a]@ %a]@]" 112 | a (Printing.string_of_size sz) format_value v format_block c 113 | | Load_and_store(Alloca a, x, st, y, gt) -> 114 | fprintf fmt "@[[%a = [%a = cell_%d; %a]@ %a]@]" 115 | Var.format y Var.format x a format_value st format_block gt 116 | | Range(a, b, x, Label l, bdy, next) -> 117 | fprintf fmt 118 | "@[[range [@[%a in %a .. %a@ next: label_%d@ finally: %a@]]@ %a]@]" 119 | Var.format x format_value a format_value b l format_block next format_block bdy 120 | | Block_ref(Label l) -> fprintf fmt "[goto %d@@]" l 121 | 122 | (* How to compile Value.Ret. *) 123 | type yield = el -> block 124 | 125 | (* How to compile Value.Invoke. *) 126 | type invoke = el -> (el -> block) -> block 127 | 128 | (* How to compile Value.Lambda. *) 129 | type 'a lambda = el Value.fn -> 'a 130 | 131 | (* How to compile Value.Pair. *) 132 | type 'a pair = el -> el -> 'a 133 | 134 | (* These functions are specified when the construct in question is not 135 | applicable, typically as it wouldn't be well typed. *) 136 | let no_yield (_:el):block = raise Base.Presupposition_error 137 | let no_invoke (_:el) (_:el -> block):block = raise Base.Presupposition_error 138 | let no_lambda (_:el Value.fn):'a = raise Base.Presupposition_error 139 | let no_pair (_:el) (_:el):'a = raise Base.Presupposition_error 140 | 141 | (* These counters are used to generate unique names of various sorts. *) 142 | let label_counter = ref 0 143 | let target_counter = ref 0 144 | let alloca_counter = ref 0 145 | let next_label () = 146 | let x = !label_counter in 147 | label_counter:= x + 1; 148 | Label x 149 | let next_target () = 150 | let x = !target_counter in 151 | target_counter:= x + 1; 152 | Target x 153 | let next_alloca () = 154 | let x = !alloca_counter in 155 | alloca_counter:= x + 1; 156 | Alloca x 157 | let reset_counters () = 158 | label_counter := 0; 159 | target_counter := 0; 160 | alloca_counter := 0; 161 | 162 | (* Objects of type Value.el are comparable, and can be the key of a map. *) 163 | module El_map = Map.Make(struct 164 | type t = Value.el 165 | let compare = Value.compare_el 166 | end) 167 | 168 | (* This function is used to memoize a 'yield' function. *) 169 | let memo (yield:yield):yield = 170 | let map :block El_map.t ref = ref El_map.empty in 171 | fun (v:Value.el) -> 172 | (* First, try to find v in map. *) 173 | match try Some (El_map.find v !map) with Not_found -> None with 174 | | None -> 175 | (* Execute implementation function. *) 176 | let r = yield v in 177 | (* This is a new value, it must have label None. *) 178 | assert(!(fst r) = None); 179 | (* The value v wasn't in the map before calling 'yield', check 180 | that it still isn't there. *) 181 | assert(not (El_map.mem v !map)); 182 | (* Add the result r to the map. *) 183 | map := El_map.add v r !map; 184 | (* And return r. *) 185 | r 186 | | Some result -> 187 | (* If the result has no label, i.e., if this is the first time 188 | we reuse it, create a label for it. *) 189 | let l = 190 | match !(fst result) with 191 | | None -> 192 | let l = next_label () in 193 | fst result := Some(l); 194 | l 195 | | Some l -> l 196 | in 197 | ref None, Block_ref l 198 | 199 | (* Here starts the main compilation algorithm of IPL. *) 200 | 201 | (* TODO: Make a special case of neut_value with no lambda and no 202 | pair. This functioncan be memoized. *) 203 | 204 | (* How to translate a Value.neut into a value. *) 205 | let rec neut_lp_value (lambda:value lambda) (pair:value pair) :neut->value = 206 | function 207 | | Value.Var x -> Var x 208 | | Value.Builtin(op, pre, n, post) -> 209 | let pre' = List.map (fun x -> Imm x) pre in 210 | let n' = neut_lp_value no_lambda no_pair n in 211 | let post' = List.map (el_lp_value no_lambda no_pair) post in 212 | Op(op, pre' @ n' :: post') 213 | | Value.Enum_d(n, _, cs) -> 214 | Select(neut_lp_value no_lambda no_pair n, 215 | Base.Enum_map.map (fun x -> el_lp_value lambda pair (Lazy.force x)) cs) 216 | | Value.App(f, a) -> 217 | let lambda' ff = el_lp_value lambda pair (Value.apv ff a) in 218 | neut_lp_value lambda' no_pair f 219 | | Value.Fst(n) -> 220 | let pair' p _ = el_lp_value lambda pair p in 221 | neut_lp_value no_lambda pair' n 222 | | Value.Snd(n) -> 223 | let pair' _ q = el_lp_value lambda pair q in 224 | neut_lp_value no_lambda pair' n 225 | (* Substitution is computationally irrelevant. *) 226 | | Value.Subst(_, _, p) -> el_lp_value lambda pair p 227 | | Value.Purify(_, p) -> 228 | let lbl = next_target () in 229 | let yield' x = ref None, End_purify (el_lp_value lambda pair x, lbl) in 230 | Purify(lbl, neut_iy_block no_invoke (memo yield') p) 231 | (* All other constructors of Value.neut create objets of procedure 232 | type. Hence they cannot end up here. *) 233 | | _ -> raise Base.Presupposition_error 234 | 235 | (* How to translate a Value.el into a value. *) 236 | and el_lp_value (lambda:value lambda) (pair:value pair) :el->value = 237 | function 238 | | Value.Imm(i) -> Imm(i) 239 | | Value.Neut(n) -> neut_lp_value lambda pair n 240 | | Value.Lambda(f) -> lambda f 241 | | Value.Pair(a, b) -> pair a b 242 | | Value.Hole -> raise Compile_hole 243 | (* All other constructors of Value.el create objets of procedure 244 | type, or objects of type Type. Hence they cannot end up here. *) 245 | | _ -> raise Base.Presupposition_error 246 | 247 | (* How to translate a Value.neut of procedure type into a block. *) 248 | and neut_iy_block (invoke:invoke) (yield:yield) :neut->block = 249 | function 250 | (* Note that a and b are integers. *) 251 | | Value.Range1(a, b) -> 252 | range invoke yield 253 | (neut_lp_value no_lambda no_pair a) 254 | (el_lp_value no_lambda no_pair b) 255 | | Value.Range2(a, b) -> 256 | range invoke yield 257 | (Imm (Base.Imm32 a)) 258 | (neut_lp_value no_lambda no_pair b) 259 | | Value.Bind(c, _, t) -> 260 | let yield' a = el_iy_block invoke yield (Value.apv t a) in 261 | neut_iy_block invoke (memo yield') c 262 | | Value.For(n, _, _, t) -> 263 | let invoke' d s = el_iy_block invoke s (Value.apv t d) in 264 | neut_iy_block invoke' yield n 265 | | Value.Local(im, _, _, init, p) -> 266 | local invoke yield im init p 267 | | Value.Catch(_, _, _, f, p) -> 268 | catch invoke yield f p 269 | (* Note that n is of enum type. *) 270 | | Value.Enum_d(n, _, cs) -> 271 | ref None, 272 | Switch(neut_lp_value no_lambda no_pair n, 273 | Base.Enum_map.map (fun x -> el_iy_block invoke yield (Lazy.force x)) cs) 274 | | Value.App(f, a) -> 275 | let lambda' ff = el_iy_block invoke yield (Value.apv ff a) in 276 | neut_lp_block lambda' no_pair f 277 | | Value.Fst(n) -> 278 | let pair' p _ = el_iy_block invoke yield p in 279 | neut_lp_block no_lambda pair' n 280 | | Value.Snd(n) -> 281 | let pair' _ q = el_iy_block invoke yield q in 282 | neut_lp_block no_lambda pair' n 283 | (* Substitution is computationally irrelevant. *) 284 | | Value.Subst(_, _, p) -> el_iy_block invoke yield p 285 | | Value.Purify(_, p) -> 286 | let yield' x = el_iy_block invoke yield x in 287 | neut_iy_block no_invoke (memo yield') p 288 | | _ -> raise Base.Presupposition_error 289 | 290 | (* How to translate a Value.el of procedure type into a block. *) 291 | and el_iy_block (invoke:invoke) (yield:yield) :el->block = 292 | function 293 | | Value.Ret(a) -> yield a 294 | | Value.Invk(c, t) -> 295 | let cont x = el_iy_block invoke yield (Value.apv t x) in 296 | invoke c (memo cont) 297 | | Value.Neut(n) -> neut_iy_block invoke yield n 298 | | Value.Hole -> raise Compile_hole 299 | | _ -> raise Base.Presupposition_error 300 | 301 | (* How to translate a Value.neut of procedure type into a block, when 302 | the translated Value.el in fact is of Pi or Sigma type. *) 303 | and neut_lp_block (lambda:block lambda) (pair:block pair) :neut->block = 304 | function 305 | | Value.Enum_d(n, _, cs) -> 306 | ref None, 307 | Switch(neut_lp_value no_lambda no_pair n, 308 | Base.Enum_map.map (fun x -> el_lp_block lambda pair (Lazy.force x)) cs) 309 | | Value.App(f, a) -> 310 | let lambda' ff = el_lp_block lambda pair (Value.apv ff a) in 311 | neut_lp_block lambda' no_pair f 312 | | Value.Fst(n) -> 313 | let pair' p _ = el_lp_block lambda pair p in 314 | neut_lp_block no_lambda pair' n 315 | | Value.Snd(n) -> 316 | let pair' _ q = el_lp_block lambda pair q in 317 | neut_lp_block no_lambda pair' n 318 | (* Substitution is computationally irrelevant. *) 319 | | Value.Subst(_, _, p) -> el_lp_block lambda pair p 320 | | Value.Purify(_, p) -> 321 | let yield' x = el_lp_block lambda pair x in 322 | neut_iy_block no_invoke (memo yield') p 323 | | _ -> raise Base.Presupposition_error 324 | 325 | (* How to translate a Value.el of procedure type into a block, when 326 | the translated Value.el in fact is of Pi or Sigma type. *) 327 | and el_lp_block (lambda:block lambda) (pair:block pair) :el->block = 328 | function 329 | | Value.Neut(n) -> neut_lp_block lambda pair n 330 | | Value.Lambda(f) -> lambda f 331 | | Value.Pair(a, b) -> pair a b 332 | | Value.Hole -> raise Compile_hole 333 | | _ -> raise Base.Presupposition_error 334 | 335 | (* This function is use to translate Value.Catch into a block. *) 336 | and catch (invoke:invoke) (yield:yield) (f:el) (n:component):block = 337 | let open Value in 338 | let catcher' (y:el):block = 339 | (* f is a function b -> i => a, y is of type b. *) 340 | el_iy_block invoke yield (Eval.mkApp f y) 341 | in 342 | let catcher = memo catcher' in 343 | (* This is how an invocation will be compiled inside n. *) 344 | let invoke' (p:el) (t:el->block):block = 345 | (* p is of sigma type: x is the enum value and y the method argument. *) 346 | let pair (x:el) (y:el):block = 347 | let emit_base () = invoke y t in 348 | let emit_catch () = catcher y in 349 | (* The enum value x may need to be computed. *) 350 | match x with 351 | | Imm(Base.Enum_imm(e, l)) when Base.Enum_set.equal e Base.bool_enum -> 352 | begin 353 | match l with 354 | | w when w = Base.false_lit -> emit_base () 355 | | w when w = Base.true_lit -> emit_catch () 356 | | _ -> raise Base.Presupposition_error 357 | end 358 | | Neut z -> 359 | let zz = neut_lp_value no_lambda no_pair z in 360 | let cases = Base.Enum_map.add Base.false_lit (emit_base ()) ( 361 | Base.Enum_map.add Base.true_lit (emit_catch ()) Base.Enum_map.empty) 362 | in 363 | ref None, Switch(zz, cases) 364 | | _ -> raise Base.Presupposition_error 365 | in 366 | (* invoke p t inside n will be translated as follows. *) 367 | el_lp_block no_lambda pair p 368 | in 369 | let el_of_component = function 370 | | Component1 n -> Neut n 371 | | Component2(a, b) -> Invk(Neut a, b) 372 | | Component3(a, b, c) -> Invk(Pair(Neut a, b), c) 373 | in 374 | el_iy_block invoke' yield (el_of_component n) 375 | 376 | (* This function is used to translate Value.Local into a block. *) 377 | and local (invoke:invoke) (yield:yield) (sz:size) (ini:el) (n:component):block = 378 | let open Value in 379 | let alloca = next_alloca () in 380 | (* This is how an invocation will be compiled inside n. *) 381 | let invoke' (p:el) (t:el->block):block = 382 | (* p is of sigma type: x is the enum value and y the method argument. *) 383 | let pair (x:el) (y:el):block = 384 | let emit_base () = invoke y t in 385 | let emit_getset () = 386 | (* y is a function local->local. *) 387 | let get_var = Var.dummy () in 388 | let get_value = Neut(Var(get_var)) in 389 | let new_value = el_lp_value no_lambda no_pair (Eval.mkApp y get_value) in 390 | let set_var = Var.dummy () in 391 | let set_value = Neut(Var(set_var)) in 392 | let cont_block = t set_value in 393 | ref None, Load_and_store(alloca, get_var, new_value, set_var, cont_block) 394 | in 395 | (* The enum value x may need to be computed. *) 396 | match x with 397 | | Imm(Base.Enum_imm(e, l)) when Base.Enum_set.equal e Base.bool_enum -> 398 | begin 399 | match l with 400 | | w when w = Base.false_lit -> emit_base () 401 | | w when w = Base.true_lit -> emit_getset () 402 | | _ -> raise Base.Presupposition_error 403 | end 404 | | Neut z -> 405 | let zz = neut_lp_value no_lambda no_pair z in 406 | let cases = Base.Enum_map.add Base.false_lit (emit_base ()) ( 407 | Base.Enum_map.add Base.true_lit (emit_getset ()) Base.Enum_map.empty) 408 | in 409 | ref None, Switch(zz, cases) 410 | | _ -> raise Base.Presupposition_error 411 | in 412 | (* invoke p t inside n will be translated as follows. *) 413 | el_lp_block no_lambda pair p 414 | in 415 | (* The initial value is of base type (in fact, enum type). *) 416 | let ini' = el_lp_value no_lambda no_pair ini in 417 | let el_of_component = function 418 | | Component1 n -> Neut n 419 | | Component2(a, b) -> Invk(Neut a, b) 420 | | Component3(a, b, c) -> Invk(Pair(Neut a, b), c) 421 | in 422 | let body = el_iy_block invoke' yield (el_of_component n) in 423 | ref None, Declare_alloca(alloca, sz, ini', body) 424 | 425 | and range (invoke:invoke) (yield:yield) (a:value) (b:value) :block = 426 | let x = Var.dummy () in 427 | let xx = Value.Neut(Value.Var x) in 428 | let lbl = next_label () in 429 | (* No need to memoize this yield function, as it is trivial. *) 430 | let yield' _ = ref None, Goto lbl in 431 | let body = invoke xx yield' in 432 | let term = yield Value.unit_cst in 433 | ref None, Range(a, b, x, lbl, body, term) 434 | 435 | 436 | (* On the toplevel, we'd like to yield by returning from the 437 | function. *) 438 | let ret_yield x = ref None, Ret(el_lp_value no_lambda no_pair x) 439 | 440 | 441 | 442 | (* 443 | 444 | Here is some code that I cound useful for debugging. 445 | 446 | let rep str = 447 | let ctx = Initial.ctx in 448 | let expr = Syntax.expr Lex.token (Lexing.from_string str) in 449 | let _A, a = Check_expr.infer ctx expr in 450 | assert(let _B = Check_term.mono ctx a in 451 | Value.eq_set _A _B; 452 | true); 453 | let aa = Eval.mono (Ctx.assign ctx) a in 454 | (* Format.printf "%a is %a;\n" Printing.el aa Printing.set _A; *) 455 | aa 456 | 457 | 458 | let test () = 459 | let a = rep "( 460 | val (+) = mod32::+; 461 | val (<) = mod32::<; 462 | val (==) = mod32::==; 463 | val fun (x bool) && (y bool) = x ? y : false; 464 | val fun (x bool) || (y bool) = x ? true : y; 465 | val fun (x i32) <= (y i32) = x < y || x == y; 466 | val and = mod32::and; 467 | val fun fib(x i32) = purify i32 { 468 | new a = new_i32(0); 469 | new b = new_i32(1); 470 | for _ in 0..x { 471 | val old_a = get a; 472 | val old_b = get b; 473 | a := old_b; 474 | b := old_a + old_b; 475 | } 476 | yield(get a); 477 | }; 478 | val fun euler3(max i32) = purify i32 { 479 | new sum = new_i32(0); 480 | for i in 0..5 { 481 | val a = fib(i); 482 | // Count a if a <= max and the lsb of a is unset. 483 | if a < max + 1 && and(a, 1) == 0 { 484 | sum := sum + a; 485 | } 486 | } 487 | yield(get sum); 488 | }; 489 | euler3)" 490 | in 491 | let v x = Value.Neut (Value.Var (Base.Variable "x")) in 492 | let b = Eval.mkApp (Eval.mkApp a (v "x")) (v "y") in 493 | let c = el_lp_value no_lambda no_pair b in 494 | c 495 | 496 | 497 | open Ipl_compile;; 498 | #install_printer format_block;; 499 | #install_printer format_value;; 500 | #install_printer Printing.el;; 501 | #install_printer Printing.neut;; 502 | 503 | #trace neut_iy_block;; 504 | #trace el_iy_block;; 505 | #trace neut_lp_block;; 506 | #trace el_lp_block;; 507 | #trace neut_lp_value;; 508 | #trace el_lp_value;; 509 | 510 | #trace neut_iy_block';; 511 | #trace el_iy_block';; 512 | #trace neut_lp_block';; 513 | #trace el_lp_block';; 514 | #trace neut_lp_value';; 515 | #trace el_lp_value';; 516 | 517 | test ();; 518 | 519 | 520 | *) 521 | -------------------------------------------------------------------------------- /ipl_llvm.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | (* 18 | LLVM documentation: 19 | http://www.class.umd.edu/old/enee/759c/llvm/llvm-3.0-install/obj/docs/ocamldoc/html/ 20 | *) 21 | 22 | open Base 23 | 24 | type llvalue = Llvm.llvalue 25 | type lltype = Llvm.lltype 26 | type llbasicblock = Llvm.llbasicblock 27 | type llmodule = Llvm.llmodule 28 | type imm = Base.imm 29 | type el = Value.el 30 | type neut = Value.neut 31 | type value = Ipl_compile.value 32 | type block = Ipl_compile.block 33 | type label = Ipl_compile.label 34 | type target = Ipl_compile.target 35 | type alloca = Ipl_compile.alloca 36 | let dump_value = Llvm.dump_value 37 | let dump_module = Llvm.dump_module 38 | 39 | (* No need to use any other context. *) 40 | let global_context = Llvm.global_context () 41 | let builder = Llvm.builder global_context 42 | let void = Llvm.void_type global_context 43 | let append_block = Llvm.append_block global_context 44 | let i8 = Llvm.i8_type global_context 45 | let i16 = Llvm.i16_type global_context 46 | let i32 = Llvm.i32_type global_context 47 | let i64 = Llvm.i64_type global_context 48 | let const_int = Llvm.const_int 49 | let build_zext t v = Llvm.build_zext v t "" builder 50 | let to_bool = build_zext i32 51 | let const_of_int64 = Llvm.const_of_int64 52 | let type_of = Llvm.type_of 53 | let insertion_block () = Llvm.insertion_block builder 54 | let block_terminator = Llvm.block_terminator 55 | let insertion_block_terminator () = 56 | block_terminator (insertion_block ()) 57 | let position_at_end bb = 58 | Llvm.position_at_end bb builder 59 | let build_br bb = 60 | ignore (Llvm.build_br bb builder) 61 | let function_and_entry bb = 62 | let the_function = Llvm.block_parent bb in 63 | let entry_bb = Llvm.entry_block the_function in 64 | the_function, entry_bb 65 | let new_block name = 66 | append_block name (Llvm.block_parent (insertion_block ())) 67 | 68 | let lltype_of_size:size -> lltype = 69 | function 70 | | I8 -> i8 71 | | I16 -> i16 72 | | I32 -> i32 73 | | I64 -> i64 74 | 75 | (* Find the ordinal number of enum constant c inside enum cs. *) 76 | let enum_ordinal cs c = 77 | match Base.Enum_set.split c cs with 78 | | below, true, _ -> Base.Enum_set.cardinal below 79 | | _ -> raise Base.Presupposition_error 80 | 81 | (* Enum constants are represented by i32 for now. *) 82 | let mk_enum_const cs c = const_int i32 (enum_ordinal cs c) 83 | 84 | (* We actually rely on the fact that false < true. *) 85 | let _ = assert(enum_ordinal bool_enum true_lit = 1) 86 | let _ = assert(enum_ordinal bool_enum false_lit = 0) 87 | 88 | let llvalue_of_imm : imm -> llvalue = 89 | let open Value in 90 | function 91 | | Imm8 x -> const_int i8 (Char.code x) 92 | | Imm16 x -> const_int i16 x 93 | | Imm32 x -> const_of_int64 i32 (Int64.of_int32 x) true 94 | | Imm64 x -> const_of_int64 i64 x true 95 | | Enum_imm(cs, c) -> mk_enum_const cs c 96 | (* Due to eager evaluation, refl objects will need to be compiled 97 | (e.g., for sdiv), but they will not make it into the code. *) 98 | | Refl -> Llvm.undef i8 99 | 100 | let lltype_of_imm:imm -> lltype = 101 | function 102 | | Imm8 _ -> i8 103 | | Imm16 _ -> i16 104 | | Imm32 _ -> i32 105 | | Imm64 _ -> i64 106 | | Enum_imm(_, _) -> i32 107 | | Refl -> i8 108 | 109 | (* Create a shift argument of type a with value y. Only the lowest 110 | bits of y are taken in to account, depending on the size of a. *) 111 | let mk_shift a y = 112 | let ty = lltype_of_size a in 113 | let yy = match a with 114 | | I8 -> y 115 | | _ -> build_zext ty y 116 | in 117 | let tysz = match a with 118 | | I8 -> 0x07 119 | | I16 -> 0x0f 120 | | I32 -> 0x1f 121 | | I64 -> 0x3f 122 | in 123 | Llvm.build_and yy (const_int ty tysz) "shiftprep" builder 124 | 125 | let builtin op vals = 126 | match op, vals with 127 | | Add(_), [x; y] -> Llvm.build_add x y "" builder 128 | | Sub(_), [x; y] -> Llvm.build_sub x y "" builder 129 | | Neg(_), [x] -> Llvm.build_neg x "" builder 130 | | Mul(_), [x; y] -> Llvm.build_mul x y "" builder 131 | | Srem(_), [x; y; _] -> Llvm.build_srem x y "" builder 132 | | Sdiv(_), [x; y; _] -> Llvm.build_sdiv x y "" builder 133 | | Xor _, [x; y] -> Llvm.build_xor x y "" builder 134 | | Or _, [x; y] -> Llvm.build_or x y "" builder 135 | | And _, [x; y] -> Llvm.build_and x y "" builder 136 | | Not _, [x] -> Llvm.build_not x "" builder 137 | | Lsl a, [x; y] -> Llvm.build_shl x (mk_shift a y) "" builder 138 | | Lsr a, [x; y] -> Llvm.build_lshr x (mk_shift a y) "" builder 139 | | Asr a, [x; y] -> Llvm.build_ashr x (mk_shift a y) "" builder 140 | (* Sign extend y to b. *) 141 | | Cast(a, b), [y] when a < b -> 142 | Llvm.build_sext y (lltype_of_size b) "" builder 143 | (* Truncate y to b. *) 144 | | Cast(a, b), [y] when a > b -> 145 | Llvm.build_trunc y (lltype_of_size b) "" builder 146 | | Cast(a, b), [y] (* when a = b *) -> y 147 | | Aeq(_), [x; y] -> 148 | to_bool (Llvm.build_icmp Llvm.Icmp.Eq x y "" builder) 149 | | Less(_), [x; y] -> 150 | to_bool (Llvm.build_icmp Llvm.Icmp.Slt x y "" builder) 151 | (* TODO: can a proof object end up being compiled? If so, simply add 152 | an undef instruction here instead of raising an exception. *) 153 | | _ -> raise Presupposition_error 154 | 155 | let emit_alloca name tt = 156 | let start_bb = insertion_block () in 157 | let _, entry_bb = function_and_entry start_bb in 158 | position_at_end entry_bb; 159 | let local_var = Llvm.build_alloca tt name builder in 160 | position_at_end start_bb; 161 | local_var 162 | 163 | (* A name-value map, mapping variables to LLVM values. *) 164 | type var_map = llvalue Base.var_map 165 | let var_map :var_map ref = ref Base.Var_map.empty 166 | 167 | module Label_map = Map.Make(struct 168 | type t = label 169 | let compare = compare 170 | end) 171 | let lbl_map : llbasicblock Label_map.t ref = ref Label_map.empty 172 | 173 | module Target_map = Map.Make(struct 174 | type t = target 175 | let compare = compare 176 | end) 177 | let target_map : (llbasicblock * llvalue option ref) Target_map.t ref 178 | = ref Target_map.empty 179 | 180 | module Alloca_map = Map.Make(struct 181 | type t = alloca 182 | let compare = compare 183 | end) 184 | let alloca_map : llvalue Alloca_map.t ref = ref Alloca_map.empty 185 | 186 | let rec compile_block (block:block) :unit = 187 | let open Ipl_compile in 188 | begin 189 | match !(fst block) with 190 | | None -> () 191 | | Some (Label name as lbl) -> 192 | (* Declare this label for the rest of this session. *) 193 | let bb = new_block (Printf.sprintf "lbl_%d" name) in 194 | lbl_map := Label_map.add lbl bb !lbl_map; 195 | build_br bb; 196 | position_at_end bb; 197 | end; 198 | match snd block with 199 | | Switch(v, bs) -> 200 | begin 201 | match Enum_map.cardinal bs with 202 | | 0 -> () 203 | | 1 -> compile_block (snd (Enum_map.choose bs)) 204 | | _ -> 205 | let start_bb = insertion_block () in 206 | let unreachable_bb = new_block "unreachable" in 207 | position_at_end unreachable_bb; 208 | ignore (Llvm.build_unreachable builder); 209 | position_at_end start_bb; 210 | let vv = compile_value v in 211 | let switch = 212 | Llvm.build_switch vv unreachable_bb (Enum_map.cardinal bs) builder 213 | in 214 | let cnt = ref 0 in 215 | let compile_case (Enum_lit x) ct = 216 | let bb = new_block x in 217 | Llvm.add_case switch (const_int i32 !cnt) bb; 218 | cnt := !cnt + 1; 219 | position_at_end bb; 220 | compile_block ct; 221 | in 222 | Enum_map.iter compile_case bs; 223 | end 224 | | Ret(v) -> 225 | ignore (Llvm.build_ret (compile_value v) builder) 226 | | End_purify(v, lbl) -> 227 | let vv = compile_value v in 228 | let vbb = insertion_block () in 229 | let bb, phi = Target_map.find lbl !target_map in 230 | begin 231 | match !phi with 232 | | None -> 233 | position_at_end bb; 234 | let p = Llvm.build_phi [vv, vbb] "purify" builder in 235 | phi := Some p; 236 | position_at_end vbb; 237 | | Some p -> 238 | Llvm.add_incoming (vv, vbb) p; 239 | end; 240 | build_br bb 241 | | Block_ref(lbl) 242 | | Goto(lbl) -> 243 | let bb = Label_map.find lbl !lbl_map in 244 | build_br bb; 245 | | Range(from, t0, x, lbl, body, next) -> 246 | (* 247 | start: 248 | ... 249 | %from = 250 | %to = 251 | begin: 252 | %from' = phi [loop:%from''; prev:%from] 253 | if %from' < %to goto loop else goto end; 254 | loop: 255 | 256 | loop_end: 257 | %from'' = %from' + 1 258 | goto begin: 259 | end: 260 | 261 | *) 262 | let t0' = compile_value t0 in 263 | let from' = compile_value from in 264 | let start_bb = insertion_block () in 265 | let begin_bb = new_block "begin" in 266 | let loop_bb = new_block "loop" in 267 | let loop_end_bb = new_block "loop_end" in 268 | let end_bb = new_block "end" in 269 | build_br begin_bb; 270 | position_at_end begin_bb; 271 | let from'' = Llvm.build_phi [from', start_bb] "range" builder in 272 | let cond = Llvm.build_icmp Llvm.Icmp.Ult from'' t0' "" builder in 273 | ignore (Llvm.build_cond_br cond loop_bb end_bb builder); 274 | (* -------- *) 275 | position_at_end loop_bb; 276 | let old_var_map = !var_map in 277 | var_map := Base.Var_map.add x from'' old_var_map; 278 | let old_lbl_map = !lbl_map in 279 | lbl_map := Label_map.add lbl loop_end_bb old_lbl_map; 280 | compile_block body; 281 | position_at_end loop_end_bb; 282 | let from''' = Llvm.build_add from'' (Llvm.const_int i32 1) "" builder in 283 | Llvm.add_incoming (from''', loop_end_bb) from''; 284 | build_br begin_bb; 285 | (* -------- *) 286 | position_at_end end_bb; 287 | var_map := old_var_map; 288 | lbl_map := old_lbl_map; 289 | compile_block next 290 | | Declare_alloca(alloca, sz, init, body) -> 291 | let local_var = emit_alloca "local_cell" (lltype_of_size sz) in 292 | let old_alloca_map = !alloca_map in 293 | alloca_map := Alloca_map.add alloca local_var old_alloca_map; 294 | let init_n = compile_value init in 295 | ignore (Llvm.build_store init_n local_var builder); 296 | compile_block body; 297 | alloca_map := old_alloca_map 298 | | Load_and_store(alloca, x, v, y, body) -> 299 | let local_var = Alloca_map.find alloca !alloca_map in 300 | let local_val = Llvm.build_load local_var "get" builder in 301 | let old_var_map = !var_map in 302 | var_map := Base.Var_map.add x local_val old_var_map; 303 | let vv = compile_value v in 304 | (* Store new value in cell. *) 305 | ignore (Llvm.build_store vv local_var builder); 306 | (* Discard binding for x by using old_var_map. *) 307 | var_map := Base.Var_map.add y vv old_var_map; 308 | compile_block body; 309 | var_map := old_var_map 310 | 311 | and compile_value :value->llvalue = 312 | let open Ipl_compile in 313 | function 314 | | Select(v, vs) -> 315 | begin 316 | match Enum_map.cardinal vs with 317 | | 0 -> Llvm.build_unreachable builder 318 | | 1 -> compile_value (snd (Enum_map.choose vs)) 319 | | _ -> 320 | let start_bb = insertion_block () in 321 | let unreachable_bb = new_block "unreachable" in 322 | let merge_bb = new_block "merge" in 323 | position_at_end unreachable_bb; 324 | ignore (Llvm.build_unreachable builder); 325 | position_at_end start_bb; 326 | let vv = compile_value v in 327 | let switch = 328 | Llvm.build_switch vv unreachable_bb (Enum_map.cardinal vs) builder 329 | in 330 | let cnt = ref 0 in 331 | let compile_case (Enum_lit x, ct) = 332 | let bb = new_block x in 333 | Llvm.add_case switch (const_int i32 !cnt) bb; 334 | cnt := !cnt + 1; 335 | position_at_end bb; 336 | let ct_value = compile_value ct in 337 | let after_bb = insertion_block () in 338 | build_br merge_bb; 339 | ct_value, after_bb 340 | in 341 | (* The return values of compile_case are modelled to be input to 342 | 'build_phi'. *) 343 | let incoming = List.map compile_case (Enum_map.bindings vs) in 344 | position_at_end merge_bb; 345 | let phi = Llvm.build_phi incoming "merge" builder in 346 | phi 347 | end 348 | | Purify(Target name as target, body) -> 349 | let new_bb = new_block (Printf.sprintf "target_%d" name) in 350 | let old_target_map = !target_map in 351 | let phi = ref None in 352 | target_map := Target_map.add target (new_bb, phi) !target_map; 353 | compile_block body; 354 | target_map := old_target_map; 355 | position_at_end new_bb; 356 | begin 357 | match !phi with 358 | | None -> Llvm.build_unreachable builder 359 | | Some p -> p 360 | end 361 | | Op(op, vals) -> builtin op (List.map compile_value vals) 362 | | Var(x) -> Base.Var_map.find x !var_map 363 | | Imm(i) -> llvalue_of_imm i 364 | 365 | 366 | 367 | let setup_module name = 368 | let the_module = Llvm.create_module global_context name in 369 | let open Llvm_executionengine in 370 | ignore (initialize_native_target ()); 371 | (* Create the JIT. *) 372 | let the_execution_engine = ExecutionEngine.create the_module in 373 | (* Should be 'create' instead of create_function? *) 374 | let the_fpm = Llvm.PassManager.create_function the_module in 375 | (* Set up the optimizer pipeline. Start with registering info about how the 376 | * target lays out data structures. *) 377 | Llvm_target.DataLayout.add_to_pass_manager the_fpm 378 | (ExecutionEngine.data_layout the_execution_engine); 379 | (* Promote alloca slots that have only loads and stores to registers. *) 380 | Llvm_scalar_opts.add_memory_to_register_promotion the_fpm; 381 | (* Simplify the control flow graph (deleting unreachable blocks, etc). *) 382 | Llvm_scalar_opts.add_cfg_simplification the_fpm; 383 | (* Loop invariant code motion. *) 384 | Llvm_scalar_opts.add_licm the_fpm; 385 | (* Induction variable simplification. *) 386 | Llvm_scalar_opts.add_ind_var_simplification the_fpm; 387 | (* Loop deletion. *) 388 | Llvm_scalar_opts.add_loop_deletion the_fpm; 389 | (* Do simple "peephole" optimizations and bit-twiddling optzn. *) 390 | Llvm_scalar_opts.add_instruction_combination the_fpm; 391 | (* Reassociate expressions. *) 392 | Llvm_scalar_opts.add_reassociation the_fpm; 393 | (* Combine instructions. *) 394 | Llvm_scalar_opts.add_instruction_combination the_fpm; 395 | (* Propagate constants. *) 396 | Llvm_scalar_opts.add_constant_propagation the_fpm; 397 | (* Sparse conditional constant propagation. *) 398 | Llvm_scalar_opts.add_sccp the_fpm; 399 | (* Eliminate Common SubExpressions. *) 400 | Llvm_scalar_opts.add_gvn the_fpm; 401 | (* Simplify the control flow graph (deleting unreachable blocks, etc). *) 402 | Llvm_scalar_opts.add_cfg_simplification the_fpm; 403 | (* Eliminate Common SubExpressions. *) 404 | Llvm_scalar_opts.add_gvn the_fpm; 405 | (* Simplify the control flow graph (deleting unreachable blocks, etc). *) 406 | Llvm_scalar_opts.add_cfg_simplification the_fpm; 407 | (* Aggressive dead code elimination. *) 408 | Llvm_scalar_opts.add_aggressive_dce the_fpm; 409 | ignore (Llvm.PassManager.initialize the_fpm); 410 | the_execution_engine, the_module, the_fpm 411 | 412 | type llproto = lltype * (string * lltype) list 413 | 414 | let setup_fn the_module name (proto:llproto):Llvm.llvalue * llvalue Var_map.t = 415 | let names = Array.of_list (List.map fst (snd proto)) in 416 | let args = Array.of_list (List.map snd (snd proto)) in 417 | let cod = fst proto in 418 | let ft = Llvm.function_type cod args in 419 | let f = 420 | match Llvm.lookup_function name the_module with 421 | | None -> Llvm.declare_function name ft the_module 422 | | Some _ -> raise Presupposition_error 423 | in 424 | let p = Llvm.params f in 425 | let nameval i a = 426 | let n = names.(i) in 427 | Llvm.set_value_name n a; 428 | Var.of_string n, a 429 | in 430 | let nvals = Array.mapi nameval p in 431 | let m = Array.fold_right (fun (x, y) -> Base.Var_map.add x y) 432 | nvals Base.Var_map.empty 433 | in 434 | f, m 435 | 436 | let main_engine, main_module, main_fpm = setup_module "IPL" 437 | 438 | let compile_function_ name (proto:llproto) (body:el) invoke = 439 | (* Format.printf "Body:%a\n@?" Printing.el body; *) 440 | let the_function, named_values = setup_fn main_module name proto in 441 | (* Create an entry block for alloca. *) 442 | let entry_bb = append_block "entry" the_function in 443 | (* Create a new basic block to start insertion into. *) 444 | let start_bb = append_block "start" the_function in 445 | Llvm.position_at_end start_bb builder; 446 | try 447 | let block = Ipl_compile.el_iy_block 448 | invoke 449 | Ipl_compile.ret_yield 450 | body 451 | in 452 | var_map := named_values; 453 | lbl_map := Label_map.empty; 454 | target_map := Target_map.empty; 455 | alloca_map := Alloca_map.empty; 456 | compile_block block; 457 | Ipl_compile.reset_counters (); 458 | (* Now that all alloca instructions have been inserted to the 459 | entry block, have it jump to the start block at the end of the 460 | entry block. *) 461 | Llvm.position_at_end entry_bb builder; 462 | build_br start_bb; 463 | (* Llvm.dump_module main_module; *) 464 | (* Validate the generated code, checking for consistency. *) 465 | Llvm_analysis.assert_valid_function the_function; 466 | (* Optimize the function. *) 467 | let _ = Llvm.PassManager.run_function the_function main_fpm in 468 | Llvm_analysis.assert_valid_function the_function; 469 | (* Llvm.dump_module main_module; *) 470 | the_function 471 | with 472 | | e -> 473 | Llvm.delete_function the_function; 474 | raise e 475 | 476 | type proto = size * (string * size) list 477 | let compile_function name (proto:proto) (body:el) invoke = 478 | let cod = lltype_of_size (fst proto) in 479 | let dom = List.map (fun (x, y) -> x, lltype_of_size y) (snd proto) in 480 | compile_function_ name (cod, dom) body invoke 481 | 482 | let generic_of_imm:imm -> Llvm_executionengine.GenericValue.t = 483 | let open Llvm_executionengine in 484 | function 485 | | Imm8 x -> GenericValue.of_int i8 (Char.code x) 486 | | Imm16 x -> GenericValue.of_int i16 x 487 | | Imm32 x -> GenericValue.of_int32 i32 x 488 | | Imm64 x -> GenericValue.of_int64 i64 x 489 | | Enum_imm(cs, c) -> GenericValue.of_int i32 (enum_ordinal cs c) 490 | | Refl -> raise Presupposition_error 491 | 492 | let generic_eq_imm (y:Llvm_executionengine.GenericValue.t) = 493 | let open Llvm_executionengine in 494 | function 495 | | Imm8 x -> GenericValue.as_int y = Char.code x 496 | | Imm16 x -> GenericValue.as_int y = x 497 | | Imm32 x -> GenericValue.as_int32 y = x 498 | | Imm64 x -> GenericValue.as_int64 y = x 499 | | Enum_imm(cs, c) -> GenericValue.as_int y = enum_ordinal cs c 500 | | Refl -> raise Presupposition_error 501 | 502 | let size_of_imm = function 503 | | Imm8 _ -> I8 504 | | Imm16 _ -> I16 505 | | Imm32 _ -> I32 506 | | Imm64 _ -> I64 507 | | Enum_imm(_, _) -> I32 508 | | Refl -> raise Presupposition_error 509 | -------------------------------------------------------------------------------- /iplc.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | open Base 18 | 19 | let extend_context ctx loc ident expr = 20 | let _AAA, a = Check_expr.infer ctx expr in 21 | assert(let _BBB = Check_term.mono ctx a in 22 | Value.eq_set _AAA _BBB; 23 | true); 24 | let aa = Eval.mono (Ctx.assign ctx) a in 25 | Ctx.extend ctx loc ident aa _AAA 26 | 27 | let rec toplevel ctx stmt = 28 | (* Format.printf "%a\n" Base.format_location (fst stmt); *) 29 | match snd stmt with 30 | | Expr.Eof -> () 31 | | Expr.Assert (a, _A, rest) -> 32 | let _AA = Check_expr.set ctx _A in 33 | assert(Check_term.set ctx _AA; true); 34 | let _AAA = Eval.set (Ctx.assign ctx) _AA in 35 | let _ = Check_expr.check ctx _AAA a in 36 | toplevel ctx rest 37 | | Expr.AssertEq(a, b, _A, rest) -> 38 | let _AA = Check_expr.set ctx _A in 39 | assert(Check_term.set ctx _AA; true); 40 | let rho = Ctx.assign ctx in 41 | let _AAA = Eval.set rho _AA in 42 | let aa = Check_expr.check ctx _AAA a in 43 | assert(Check_term.poly ctx _AAA aa; true); 44 | let bb = Check_expr.check ctx _AAA b in 45 | assert(Check_term.poly ctx _AAA bb; true); 46 | let aaa = Eval.poly rho aa in 47 | let bbb = Eval.poly rho bb in 48 | begin 49 | try Value.eq_el aaa bbb 50 | with Not_equal -> 51 | Check_expr.report (fst stmt) "assertion failed: not equal"; 52 | Check_expr.report (fst a) "%a" Printing.el aaa; 53 | Check_expr.report (fst b) "%a" Printing.el bbb; 54 | raise Check_expr.Error 55 | end; 56 | toplevel ctx rest 57 | | Expr.Val (loc, v, a, rest) -> toplevel (extend_context ctx loc v a) rest 58 | | Expr.Compile(f, args, cod, def, rest) -> 59 | let imm_set ctx s = 60 | match Eval.set (Ctx.assign ctx) (Check_expr.set ctx s) with 61 | | Value.Imm_set sz -> sz 62 | | _ -> 63 | Check_expr.report (fst s) 64 | "expected set of immediate values (e.g., i32)"; 65 | raise Check_expr.Error 66 | in 67 | let argvals = List.map (fun (x, y) -> x, imm_set ctx y) args in 68 | let codval = imm_set ctx cod in 69 | let ext ctx (v, t) = 70 | let v' = Var.of_string v in 71 | (* TODO: track location of v *) 72 | Ctx.extend ctx no_location v' (Value.el_of_var v') (Value.Imm_set t) in 73 | let ctx' = List.fold_left ext ctx argvals in 74 | let codt = Value.Tree(Eval.empty_interface, (Value.Imm_set_u codval)) in 75 | let defv, _ = Check_expr.check_eval ctx' codt def in 76 | let _ = Ipl_llvm.compile_function f (codval, argvals) defv Ipl_compile.no_invoke in 77 | toplevel ctx rest 78 | | Expr.Test(f, args, expect, rest) -> 79 | let mapper ctx x = 80 | let _AA, a = Check_expr.infer ctx x in 81 | let rho = Ctx.assign ctx in 82 | let aa = Eval.mono rho a in 83 | match match aa with 84 | | Value.Imm (Enum_imm _) -> None 85 | | Value.Imm (Refl) -> None 86 | | Value.Imm i -> Some i 87 | | _ -> None 88 | with 89 | | Some i -> i 90 | | None -> 91 | Check_expr.report (fst x) "expected integer constant"; 92 | raise Check_expr.Error 93 | in 94 | let args' = Array.of_list ( 95 | List.map Ipl_llvm.generic_of_imm ( 96 | List.map (mapper ctx) args)) in 97 | let expect' = mapper ctx expect in 98 | let fn = match Llvm_executionengine.ExecutionEngine.find_function 99 | f Ipl_llvm.main_engine 100 | with 101 | | Some g -> g 102 | | None -> 103 | Check_expr.report (fst stmt) "undefined function '%s'\n" f; 104 | raise Check_expr.Error 105 | in 106 | let r = Llvm_executionengine.ExecutionEngine.run_function 107 | fn args' Ipl_llvm.main_engine 108 | in 109 | if not (Ipl_llvm.generic_eq_imm r expect') then begin 110 | Check_expr.report (fst expect) "expected %s, got %Ld" 111 | (Printing.string_of_imm expect') 112 | (Llvm_executionengine.GenericValue.as_int64 r); 113 | raise Check_expr.Error 114 | end; 115 | toplevel ctx rest 116 | 117 | let run lexbuf = 118 | try 119 | let top = Syntax.file Lex.token lexbuf in 120 | toplevel Initial.ctx top 121 | with 122 | | Parsing.Parse_error -> 123 | let curr = lexbuf.Lexing.lex_curr_p in 124 | let line = curr.Lexing.pos_lnum in 125 | let cnum = curr.Lexing.pos_cnum - curr.Lexing.pos_bol in 126 | let file = curr.Lexing.pos_fname in 127 | let tok = Lexing.lexeme lexbuf in 128 | Format.eprintf "%s:%d.%d: unexpected token: %s\n@?" file line cnum tok; 129 | | Lex.Error(d, e) -> 130 | Format.eprintf "%a\n@?" Lex.format_error (d, e); 131 | | Ctx.Rebound_error(old_loc, new_loc, v) -> 132 | Check_expr.report new_loc "variable %a is already abound" Var.format v; 133 | if old_loc <> no_location then 134 | Check_expr.report old_loc "here"; 135 | Format.eprintf "@?" 136 | | Check_expr.Error -> 137 | (* Error message already printed, including newline. *) 138 | Format.eprintf "@?" 139 | | Base.Duplicate_key k -> 140 | Format.eprintf "duplicate enum literal %a\n@?" 141 | Base.format_enum_lit k 142 | | Ipl_compile.Compile_hole -> 143 | Format.eprintf "cannot compile hole\n@?" 144 | | e -> 145 | Format.eprintf "internal compiler error\n"; 146 | Format.eprintf "please report to georg.granstrom@@acm.org\n@?"; 147 | raise e 148 | 149 | let run_file file = 150 | try 151 | let ch = open_in file in 152 | let lb = Lexing.from_channel ch in 153 | lb.Lexing.lex_curr_p <- {lb.Lexing.lex_curr_p with Lexing.pos_fname = file}; 154 | run lb 155 | with 156 | | Sys_error s -> Format.eprintf "%s\n@?" s 157 | 158 | let run_string str = 159 | let lb = Lexing.from_string str in 160 | lb.Lexing.lex_curr_p <- {lb.Lexing.lex_curr_p with Lexing.pos_fname = ""}; 161 | run lb 162 | 163 | let main () = 164 | let len = Array.length Sys.argv in 165 | if len <> 2 then 166 | Format.eprintf "usage: %s \n@?" Sys.argv.(0) 167 | else begin 168 | let fname = Sys.argv.(1) in 169 | run_file fname; 170 | let outname = 171 | (try 172 | let ri = String.rindex fname '.' in 173 | String.sub fname 0 ri 174 | with Not_found -> fname) ^ ".bc" 175 | in 176 | if not(Llvm_bitwriter.write_bitcode_file Ipl_llvm.main_module outname) then 177 | Printf.eprintf "Could not write to file '%s'\n@?" outname 178 | end 179 | 180 | let _ = if not !Sys.interactive then main () 181 | -------------------------------------------------------------------------------- /lex.mll: -------------------------------------------------------------------------------- 1 | { 2 | 3 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 4 | (* *) 5 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 6 | (* *) 7 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 8 | (* you may not use this file except in compliance with the License. *) 9 | (* You may obtain a copy of the License at *) 10 | (* *) 11 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 12 | (* *) 13 | (* Unless required by applicable law or agreed to in writing, software *) 14 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 15 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 16 | (* See the License for the specific language governing permissions and *) 17 | (* limitations under the License. *) 18 | 19 | open Base 20 | open Syntax 21 | open Lexing 22 | 23 | let incr_lineno lexbuf = 24 | let pos = lexbuf.lex_curr_p in 25 | lexbuf.lex_curr_p <- { pos with 26 | pos_lnum = pos.pos_lnum + 1; 27 | pos_bol = pos.pos_cnum; 28 | } 29 | 30 | type details = 31 | | Illegal_character of char 32 | | Literal_overflow of string 33 | | Invalid_hex 34 | 35 | let format_details (fmt:Format.formatter) (err:details) :unit = 36 | match err with 37 | | Illegal_character c -> 38 | Format.fprintf fmt "illegal character (%s)" (Char.escaped c) 39 | | Literal_overflow ty -> 40 | Format.fprintf fmt "integer literal exceeds representable range for \ 41 | integers of type %s" ty 42 | | Invalid_hex -> 43 | Format.fprintf fmt "hex literal must be of size 2, 4, 8, or 16" 44 | 45 | exception Error of (string * pos) * details 46 | 47 | let format_error (fmt:Format.formatter) 48 | ((fname, (a, b)), (err)):unit = 49 | Format.fprintf fmt "%s:%d.%d: %a" fname a b format_details err 50 | 51 | let pos_of_lexpos (p:Lexing.position) :pos = 52 | (p.Lexing.pos_lnum, p.Lexing.pos_cnum - p.Lexing.pos_bol) 53 | 54 | let currpos (lexbuf:Lexing.lexbuf):string*pos = 55 | lexbuf.lex_curr_p.pos_fname, (pos_of_lexpos (lexbuf.lex_curr_p)) 56 | 57 | let keyword_table = 58 | let bindings = [ 59 | "eq", AEQ; 60 | "assert", ASSERT; 61 | "block", BLOCK; 62 | "call", CALL; 63 | "case", CASE; 64 | "compile", COMPILE; 65 | "dep", DEP; 66 | "do", DO; 67 | "else", ELSE; 68 | "enum", ENUM; 69 | "for", FOR; 70 | "fst", FST; 71 | "fun", FUN; 72 | "get", GET; 73 | "if", IF; 74 | "in", IN; 75 | "interpret", INTERPRET; 76 | "is", IS; 77 | "interface", INTERFACE; 78 | "meth", METH; 79 | "new", NEW; 80 | "opaque", OPAQUE; 81 | "purify", PURIFY; 82 | "refl", REFL; 83 | "snd", SND; 84 | "struct", STRUCT; 85 | "subst", SUBST; 86 | "switch", SWITCH; 87 | "test", TEST; 88 | "tuple", TUPLE; 89 | "type", TYPE; 90 | "union", UNION; 91 | "val", VAL; 92 | "yield", YIELD; 93 | ] in 94 | let tab = Hashtbl.create (List.length bindings) in 95 | List.iter (fun (a, b) -> Hashtbl.add tab a b) bindings; 96 | tab 97 | 98 | let int_of_hex c = 99 | match c with 100 | | x when '0' <= x && x <= '9' -> (Char.code x) - (Char.code '0') 101 | | x when 'a' <= x && x <= 'h' -> (Char.code x) - (Char.code 'a') + 10 102 | | x when 'A' <= x && x <= 'H' -> (Char.code x) - (Char.code 'A') + 10 103 | | _ -> raise Presupposition_error 104 | 105 | let int64_of_hex_string str = 106 | let open Int64 in 107 | let result : int64 ref = ref zero in 108 | for i = 0 to String.length str - 1 do 109 | result := add (shift_left !result 4) (of_int (int_of_hex str.[i])) 110 | done; 111 | !result 112 | 113 | let i64_of_string pos str = 114 | try 115 | Imm64(Int64.of_string str) 116 | with 117 | | Failure _ -> raise (Error(pos, Literal_overflow "i64")) 118 | 119 | let i32_of_string pos str = 120 | try 121 | Imm32(Int32.of_string str) 122 | with 123 | | Failure _ -> raise (Error(pos, Literal_overflow "i32")) 124 | 125 | let i16_of_string pos str = 126 | try 127 | let i = int_of_string str in 128 | if i > 32767 || i < -32768 then raise (Failure "") 129 | else Imm16(i) 130 | with 131 | | Failure _ -> raise (Error(pos, Literal_overflow "i16")) 132 | 133 | let i8_of_string pos str = 134 | try 135 | let i = int_of_string str in 136 | if i > 127 || i < -128 then raise (Failure "") 137 | else Imm8(Char.chr i) 138 | with 139 | | Failure _ -> raise (Error(pos, Literal_overflow "i16")) 140 | 141 | 142 | (* end of preamble *) 143 | } 144 | 145 | let newline = ('\010' | '\013' | "\013\010") 146 | let blank = [' ' '\009' '\012'] 147 | let letter = ['a'-'z' 'A'-'Z'] 148 | let digit = ['0'-'9'] 149 | let hex = digit | ['a'-'h' 'A'-'H'] 150 | let identchar = letter | digit | '_' 151 | let integer = '-'? digit+ 152 | 153 | rule token = parse 154 | | "//" 155 | { 156 | comment lexbuf 157 | } 158 | 159 | | newline 160 | { 161 | incr_lineno lexbuf; 162 | token lexbuf 163 | } 164 | 165 | | blank+ 166 | { 167 | token lexbuf 168 | } 169 | 170 | | letter identchar* 171 | | '_' identchar+ as s 172 | { 173 | try Hashtbl.find keyword_table s 174 | with Not_found -> IDENT s 175 | } 176 | | "_" { BLANK } 177 | 178 | | (integer as d) 'q' { IMM (i64_of_string (currpos lexbuf) d) } 179 | | integer as d { IMM (i32_of_string (currpos lexbuf) d) } 180 | | (integer as d) 's' { IMM (i16_of_string (currpos lexbuf) d) } 181 | | (integer as d) 'c' { IMM (i8_of_string (currpos lexbuf) d) } 182 | 183 | | "0x" (hex+ as d) 184 | { 185 | let p = int64_of_hex_string d in 186 | IMM ( 187 | match String.length d with 188 | | 2 -> Imm8 (Char.chr (Int64.to_int p)) 189 | | 4 -> Imm16 (Int64.to_int p) 190 | | 8 -> Imm32 (Int64.to_int32 p) 191 | | 16 -> Imm64 p 192 | | _ -> raise (Error(currpos lexbuf, Invalid_hex)) 193 | ) 194 | } 195 | 196 | | "&&" { AND_AND } 197 | | "@" { AT } 198 | 199 | | "!" { BANG } 200 | | "!=" { BANG_EQ } 201 | | "||" { BAR_BAR } 202 | 203 | | "^^" { CARET_CARET } 204 | 205 | | "::" { COLON_COLON } 206 | | ":=" { COLON_EQ } 207 | | ":" { COLON } 208 | | "," { COMMA } 209 | 210 | | "." { DOT } 211 | | ".." { DOT_DOT } 212 | 213 | | "=" { EQ } 214 | | "==" { EQ_EQ } 215 | | "===" { EQ_EQ_EQ } 216 | | "=>" { EQ_GREATER } 217 | 218 | | ">" { GREATER } 219 | | ">=" { GREATER_EQ } 220 | 221 | | "<" { LESS } 222 | | "<=" { LESS_EQ } 223 | 224 | | "-" { MINUS } 225 | | "->" { MINUS_GREATER } 226 | 227 | | "+" { PLUS } 228 | | "++" { PLUS_PLUS } 229 | 230 | | "?" { QUESTION } 231 | | "??" { QUESTION_QUESTION } 232 | | "'" { QUOTE } 233 | 234 | | ";" { SEMI } 235 | | "*" { STAR } 236 | | "**" { STAR_STAR } 237 | 238 | | "~" { TILDE } 239 | 240 | (* Delimiter tokens *) 241 | | "{" { LBRACE } 242 | | "[" { LBRACKET } 243 | | "(" { LPAREN } 244 | | "}" { RBRACE } 245 | | "]" { RBRACKET } 246 | | ")" { RPAREN } 247 | 248 | | eof { EOF } 249 | 250 | | _ as c { raise (Error(currpos lexbuf, Illegal_character c)) } 251 | 252 | and comment = parse 253 | | newline 254 | { 255 | incr_lineno lexbuf; 256 | token lexbuf 257 | } 258 | | _ { comment lexbuf } 259 | | eof { EOF } 260 | -------------------------------------------------------------------------------- /printing.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | open Base 18 | open Value 19 | open Format 20 | 21 | let reset_counter fmt fn x = 22 | Var.reset_print (); 23 | let boxes = Format.pp_get_max_boxes fmt () in 24 | pp_set_max_boxes fmt 20; 25 | fprintf fmt "%a" fn x; 26 | pp_set_max_boxes fmt boxes 27 | 28 | let string_of_imm = 29 | function 30 | | Imm8 i8 -> Printf.sprintf "%dc" (Char.code i8) 31 | | Imm16 i16 -> Printf.sprintf "%ds" i16 32 | | Imm32 i32 -> Printf.sprintf "%ld" i32 33 | | Imm64 i64 -> Printf.sprintf "%Ldq" i64 34 | | Enum_imm(_, Enum_lit "()") -> "()" 35 | | Enum_imm(_, Enum_lit x) -> "'" ^ x 36 | | Refl -> "refl" 37 | 38 | let string_of_size = 39 | function 40 | | I8 -> "i8" 41 | | I16 -> "i16" 42 | | I32 -> "i32" 43 | | I64 -> "i64" 44 | 45 | (* Print atomic constructs. *) 46 | let rec set_atom (fmt:formatter) = function 47 | | Enum r when r = Base.unit_enum -> fprintf fmt "void" 48 | | Enum e -> fprintf fmt "enum { %a }" format_enum e 49 | | Imm_set s -> fprintf fmt "%s" (string_of_size s) 50 | | Type -> fprintf fmt "type" 51 | | Sigma(_, _) as s -> 52 | fprintf fmt "tuple("; 53 | let _ = sigma fmt s in 54 | fprintf fmt ")" 55 | | T x -> neut_atom fmt x 56 | | a -> fprintf fmt "(%a)" set_open a 57 | 58 | and neut_atom (fmt:formatter) = function 59 | | Var x -> Var.format fmt x 60 | | App(f, a) -> fprintf fmt "%a(%a)" neut_atom f el_open a 61 | | Fst p -> fprintf fmt "fst(%a)" neut_open p 62 | | Snd p -> fprintf fmt "snd(%a)" neut_open p 63 | | Enum_d (n, _, els) -> 64 | fprintf fmt "fun {@\n @["; 65 | begin 66 | match Enum_map.bindings els with 67 | | [] -> () 68 | | (Enum_lit x, y) :: bs -> 69 | fprintf fmt "%s: %a" x el_atom (Lazy.force y); 70 | List.iter (function (Enum_lit x, y) -> 71 | fprintf fmt ",@\n%s: %a" x el_atom (Lazy.force y)) bs 72 | end; 73 | fprintf fmt "@]@\n}(%a)" neut_open n; 74 | | Builtin(bin, a, b, c) -> 75 | let open Value in 76 | begin 77 | match List.map (fun x -> Imm x) a @ (Neut b) :: c with 78 | | x :: xs -> 79 | fprintf fmt "%a(%a" builtin bin el_atom x; 80 | List.iter (fun x -> fprintf fmt ", %a" el_atom x) xs; 81 | fprintf fmt ")" 82 | | _ -> () 83 | end 84 | | For(_, _, _, _) 85 | | Bind(_, _, _) as x -> 86 | fprintf fmt "block {@\n @[%a@]@\n}" prog (Neut x) 87 | | Local(_, _, _, n, p) -> local fmt n p 88 | | Catch(_, _, _, f, p) -> catch fmt f p 89 | | Purify(s, b) -> fprintf fmt "purify %a {@\n @[%a@]@\n}" el_open s prog (Neut b) 90 | | a -> fprintf fmt "(%a)" neut_open a 91 | 92 | and el_atom (fmt:formatter) = function 93 | | Imm i -> fprintf fmt "%s" (string_of_imm i) 94 | | Pi_u(_, _) 95 | | Sigma_u(_, _) 96 | | Tree_u(_, _) 97 | | Id_u(_, _, _) 98 | | Enum_u(_) 99 | | Imm_set_u(_) as x -> set_atom fmt (Eval.univ x) 100 | | Neut n -> neut_atom fmt n 101 | | Invk(_, _) 102 | | Ret _ as x -> fprintf fmt "block {@\n @[%a@]@\n}" prog x 103 | | a -> fprintf fmt "(%a)" el_open a 104 | 105 | and sigma (fmt:formatter) = function 106 | | Sigma(a, b) -> 107 | let x = Var.print_dummy () in 108 | fprintf fmt "%a %a, " Var.format x set_open a; 109 | let open Value in 110 | let xx = Neut(Var x) in 111 | let bb = sigma fmt (apv b xx) in 112 | Pair(xx, bb) 113 | | a -> 114 | let x = Var.print_dummy () in 115 | fprintf fmt "%a %a" Var.format x set_open a; 116 | let open Value in 117 | Neut(Var x) 118 | 119 | (* Print non-atomic constructs. *) 120 | and set_open (fmt:formatter) = function 121 | | Pi(a, Cst b) -> fprintf fmt "%a -> %a" set_atom a set_open b 122 | | Pi(a, b) -> 123 | fprintf fmt "dep("; 124 | let x = sigma fmt a in 125 | fprintf fmt ") -> %a" set_open (Value.apv b x) 126 | | Tree(a, b) -> fprintf fmt "%a => %a" el_atom a el_open b 127 | | Id(a, b, c) -> fprintf fmt "%a eq(%a) %a" el_atom b set_open a el_atom c 128 | | T x -> neut_open fmt x 129 | | a -> set_atom fmt a 130 | 131 | and neut_open (fmt:formatter) = function 132 | | Subst(n, c, p) -> 133 | let x = Var.print_dummy () in 134 | let y = Var.print_dummy () in 135 | let open Value in 136 | let xx = Neut(Var x) in 137 | let yy = Neut(Var y) in 138 | let cc = apv (apv c xx) yy in 139 | fprintf fmt "subst(%a, %a)(%a, %a) %a" 140 | neut_atom n el_atom p Var.format x Var.format y set_open cc 141 | | Range1(a, b) -> fprintf fmt "%a .. %a" neut_atom a el_atom b 142 | | Range2(a, b) -> fprintf fmt "%ld .. %a" a neut_atom b 143 | | a -> neut_atom fmt a 144 | 145 | and el_open (fmt:formatter) = function 146 | | Pi_u(_, _) 147 | | Sigma_u(_, _) 148 | | Tree_u(_, _) 149 | | Id_u(_, _, _) 150 | | Enum_u(_) 151 | | Imm_set_u(_) as x -> set_open fmt (Eval.univ x) 152 | | Neut n -> neut_open fmt n 153 | | Lambda f -> 154 | let x = Var.print_dummy () in 155 | let open Value in 156 | let xx = Neut(Var x) in 157 | fprintf fmt "fun(%a) %a" Var.format x el_open (apv f xx) 158 | | Pair(p, q) -> fprintf fmt "%a, %a" el_atom p el_open q 159 | | a -> el_atom fmt a 160 | 161 | and prog (fmt:formatter) = function 162 | | Invk(c, t) -> 163 | let x = Var.print_dummy () in 164 | let open Value in 165 | let xx = Neut(Var x) in 166 | fprintf fmt "val %a = call(%a);@\n%a" Var.format x el_open c prog (apv t xx) 167 | | Ret r when r = Value.unit_cst -> () 168 | | Ret r -> fprintf fmt "yield(%a);" el_open r 169 | | Neut(Bind(c, _, t)) -> 170 | let x = Var.print_dummy () in 171 | let open Value in 172 | let xx = Neut(Var x) in 173 | fprintf fmt "val %a = do %a;@\n%a" Var.format x neut_open c prog (apv t xx) 174 | | Neut(For(n, _, _, body)) -> 175 | let x = Var.print_dummy () in 176 | let open Value in 177 | let xx = Neut(Var x) in 178 | fprintf fmt "for %a in %a {@\n @[%a@]@\n}" 179 | Var.format x neut_open n prog (apv body xx) 180 | | Neut(Local(_, _, _, n, p)) -> local fmt n p 181 | | Neut(Catch(_, _, _, f, p)) -> catch fmt f p 182 | | e -> fprintf fmt "yield(do %a);" el_open e 183 | 184 | and local (fmt:formatter) (n:Value.el) (p:component) = 185 | fprintf fmt "local %a {@\n @[%a@]@\n}" el_open n component p 186 | 187 | and catch (fmt:formatter) (n:Value.el) (p:component) = 188 | fprintf fmt "catch %a {@\n @[%a@]@\n}" el_open n component p 189 | 190 | and component (fmt:formatter) :Value.component->unit = 191 | function 192 | | Component1(a) -> prog fmt (Neut a) 193 | | Component2(a, f) -> prog fmt (Invk(Neut a, f)) 194 | | Component3(a, b, f) -> prog fmt (Invk(Pair(Neut a, b), f)) 195 | 196 | 197 | and builtin (fmt:formatter) = 198 | let sz fmt x = 199 | pp_print_string fmt 200 | (match x with 201 | | I8 -> "8" 202 | | I16 -> "16" 203 | | I32 -> "32" 204 | | I64 -> "64") 205 | in 206 | function 207 | | Aeq s -> fprintf fmt "mod%a::==" sz s 208 | | Less s -> fprintf fmt "mod%a::<" sz s 209 | | Add s -> fprintf fmt "mod%a::+" sz s 210 | | Sub s -> fprintf fmt "mod%a::-" sz s 211 | | Neg s -> fprintf fmt "mod%a::(-.)" sz s 212 | | Mul s -> fprintf fmt "mod%a::*" sz s 213 | | Xor s -> fprintf fmt "mod%a::xor" sz s 214 | | Or s -> fprintf fmt "mod%a::ior" sz s 215 | | And s -> fprintf fmt "mod%a::and" sz s 216 | | Not s -> fprintf fmt "mod%a::not" sz s 217 | | Lsl s -> fprintf fmt "mod%a::lsl" sz s 218 | | Lsr s -> fprintf fmt "mod%a::lsr" sz s 219 | | Asr s -> fprintf fmt "mod%a::asr" sz s 220 | | Sdiv s -> fprintf fmt "mod%a::sdiv" sz s 221 | | Srem s -> fprintf fmt "mod%a::srem" sz s 222 | | Cast(s, t) -> fprintf fmt "mod%a::to_i%a" sz s sz t 223 | | Less_trans s -> fprintf fmt "mod%a::less_trans" sz s 224 | | Less_antisym s -> fprintf fmt "mod%a::less_antisym" sz s 225 | | Aeq_prop s -> fprintf fmt "mod%a::eq_prop" sz s 226 | | Aeq_refl s -> fprintf fmt "mod%a::eq_refl" sz s 227 | | Add_commutative s -> fprintf fmt "mod%a::add_comm" sz s 228 | | Add_associative s -> fprintf fmt "mod%a::add_assoc" sz s 229 | | Add_unit s -> fprintf fmt "mod%a::add_unit" sz s 230 | | Add_inverse s -> fprintf fmt "mod%a::add_inv" sz s 231 | | Mul_commutative s -> fprintf fmt "mod%a::mul_comm" sz s 232 | | Mul_associative s -> fprintf fmt "mod%a::mul_assoc" sz s 233 | | Mul_unit s -> fprintf fmt "mod%a::mul_unit" sz s 234 | | Distributive s -> fprintf fmt "mod%a::dist" sz s 235 | | Sub_axiom s -> fprintf fmt "mod%a::sub_axiom" sz s 236 | 237 | let set fmt x = reset_counter fmt set_open x 238 | let neut fmt x = reset_counter fmt neut_open x 239 | let el fmt x = reset_counter fmt el_open x 240 | -------------------------------------------------------------------------------- /reify.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | open Base 18 | 19 | let ulift (f : 'a -> 'b) : 'a Value.fn -> 'b Term.fn = 20 | function 21 | | Value.Cst c -> no_pattern, f c 22 | | Value.Fn(g) -> 23 | let x = Var.dummy () in 24 | Pvar(no_location, x), f (g (Value.el_of_var x)) 25 | 26 | let rec set : Value.set -> Term.set = 27 | let open Value in 28 | function 29 | | Pi(a, b) -> Term.Pi(set a, set_fam b) 30 | | Sigma(a, b) -> Term.Sigma(set a, set_fam b) 31 | | Tree(i, a) -> Term.Tree(el i, el a) 32 | | Id(a, b, c) -> Term.Id(set a, el b, el c) 33 | | Enum a -> Term.Enum a 34 | | Imm_set a -> Term.Imm_set a 35 | | Type -> Term.Type 36 | | Hole_set -> Term.Hole_set 37 | | T n -> Term.T(Term.Mono(neut n)) 38 | 39 | and neut : Value.neut -> Term.mono = 40 | let open Value in 41 | function 42 | | Var x -> Term.Var x 43 | | App(n, v) -> Term.App (neut n, el v) 44 | | Fst(n) -> Term.Fst(neut n) 45 | | Snd(n) -> Term.Snd(neut n) 46 | | Enum_d(n, _C, a) -> 47 | Term.Enum_d(neut n, set_fam _C, Enum_map.map (fun x -> el (Lazy.force x)) a) 48 | | Subst(r, _C, d) -> Term.Subst(neut r, ulift set_fam _C, el d) 49 | | Builtin(p, cs, n, rs) -> 50 | Term.Builtin(p, List.map (fun x -> Term.Mono(Term.Imm x)) cs 51 | @ Term.Mono (neut n) :: List.map el rs) 52 | | For(n, _U, _I, f) -> 53 | Term.For(neut n, el_fam _U, el _I, el_fam f) 54 | | Bind(n, _B, f) -> Term.Bind(neut n, el _B, el_fam f) 55 | | Range1(n, e) -> Term.Range(Term.Mono(neut n), el e) 56 | | Range2(i, n) -> 57 | Term.Range(Term.Mono(Term.Imm (Imm32 i)), Term.Mono(neut n)) 58 | | Local(st, i, a, n, p) -> 59 | Term.Local(st, el i, el a, el n, component p) 60 | | Catch(b, i, a, f, p) -> 61 | Term.Catch(el b, el i, el a, el f, component p) 62 | | Purify(c, m) -> Term.Purify(el c, Term.Mono(neut m)) 63 | 64 | and el : Value.el -> Term.poly = 65 | let open Value in 66 | function 67 | | Imm a -> Term.Mono(Term.Imm a) 68 | | Pi_u(a, b) -> Term.Mono(Term.Pi_u(el a, el_fam b)) 69 | | Sigma_u(a, b) -> Term.Mono(Term.Sigma_u(el a, el_fam b)) 70 | | Tree_u(i, a) -> Term.Mono(Term.Tree_u(el i, el a)) 71 | | Id_u(a, b, c) -> Term.Mono(Term.Id_u(el a, el b, el c)) 72 | | Enum_u a -> Term.Mono(Term.Enum_u a) 73 | | Imm_set_u a -> Term.Mono(Term.Imm_set_u a) 74 | | Lambda(f) -> Term.Lambda(el_fam f) 75 | | Pair(a, b) -> Term.Pair(el a, el b) 76 | | Ret(a) -> Term.Ret(el a) 77 | | Invk(c, t) -> Term.Invk(el c, el_fam t) 78 | | Neut(n) -> Term.Mono(neut n) 79 | | Hole -> Term.Hole 80 | 81 | and component : Value.component -> Term.poly = 82 | let open Value in 83 | function 84 | | Component1 n -> Term.Mono(neut n) 85 | | Component2(p, f) -> Term.Invk(Term.Mono(neut p), el_fam f) 86 | | Component3(n, b, f) -> 87 | Term.Invk(Term.Pair(Term.Mono(neut n), el b), el_fam f) 88 | 89 | 90 | and set_fam x = ulift set x 91 | and el_fam x = ulift el x 92 | -------------------------------------------------------------------------------- /syntax.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | 3 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 4 | (* *) 5 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 6 | (* *) 7 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 8 | (* you may not use this file except in compliance with the License. *) 9 | (* You may obtain a copy of the License at *) 10 | (* *) 11 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 12 | (* *) 13 | (* Unless required by applicable law or agreed to in writing, software *) 14 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 15 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 16 | (* See the License for the specific language governing permissions and *) 17 | (* limitations under the License. *) 18 | 19 | open Base 20 | open Expr 21 | 22 | let pos_of_lexpos (p:Lexing.position) :Base.pos = 23 | (p.Lexing.pos_lnum, p.Lexing.pos_cnum - p.Lexing.pos_bol) 24 | 25 | let filename () = (Parsing.symbol_start_pos ()).Lexing.pos_fname 26 | 27 | let symbol_range () = ( 28 | pos_of_lexpos (Parsing.symbol_start_pos ()), 29 | pos_of_lexpos (Parsing.symbol_end_pos ())) 30 | 31 | let range (a:int) (b:int):range = 32 | (pos_of_lexpos (Parsing.rhs_start_pos a), 33 | pos_of_lexpos (Parsing.rhs_end_pos b)) 34 | 35 | let end_loc (a:int) :location = 36 | let p = pos_of_lexpos (Parsing.rhs_end_pos a) in 37 | (filename (), (p, p)) 38 | 39 | let loc (a:int) (b:int):location = 40 | (filename (), range a b) 41 | 42 | let symbol_loc ():location = 43 | (filename (), symbol_range ()) 44 | 45 | let unit_lit_of_loc l = 46 | let el = l, unit_lit in 47 | l, Decl((l, Enum_cst(el)), (l, Enum [el])) 48 | 49 | let mk_struct_or_union a b c labels = 50 | let l1 = loc a b in 51 | let l2 = loc a c in 52 | let enum = l1, Enum(List.map fst labels) in 53 | let dtor = l2, Enum_d(labels) in 54 | let v = Var.dummy () in 55 | let vv = l1, Var v in 56 | let ap = l2, App(dtor, vv) in 57 | let patt = Pvar(l1, v) in 58 | l2, enum, patt, ap 59 | 60 | let mk_struct a b c labels = 61 | let l, enum, patt, ap = mk_struct_or_union a b c labels in 62 | l, Pi(enum, (patt, ap)) 63 | 64 | let mk_union a b c labels = 65 | let l, enum, patt, ap = mk_struct_or_union a b c labels in 66 | l, Sigma(enum, (patt, ap)) 67 | 68 | let mk_blank loc = Pvar(loc, Var.dummy ()) 69 | 70 | type maybe_bind = 71 | | No_bind of expr 72 | | Do_bind of expr 73 | 74 | 75 | let maybe_bind l1 lwhole body = function 76 | | No_bind e -> lwhole, body e 77 | | Do_bind e -> 78 | let x = Var.dummy () in 79 | lwhole, Bind(e, None, (Pvar(l1, x), (lwhole, body (l1, Var x)))) 80 | 81 | %} 82 | 83 | %token EOF /* */ 84 | %token LITERAL /* string literal */ 85 | %token IDENT /* identifier */ 86 | %token IMM /* numeric literal */ 87 | %token BLANK /* _ */ 88 | 89 | /* Keyword tokens - parser name same as keyword, but in upper case. */ 90 | %token AEQ 91 | %token ASSERT 92 | %token BLOCK 93 | %token CALL 94 | %token CASE 95 | %token COMPILE 96 | %token DEP 97 | %token DO 98 | %token ELSE 99 | %token ENUM 100 | %token FOR 101 | %token FST 102 | %token FUN 103 | %token GET 104 | %token IF 105 | %token IN 106 | %token INTERPRET 107 | %token IS 108 | %token INTERFACE 109 | %token METH 110 | %token NEW 111 | %token OPAQUE 112 | %token PURIFY 113 | %token REFL 114 | %token SND 115 | %token STRUCT 116 | %token SUBST 117 | %token SWITCH 118 | %token TEST 119 | %token TUPLE 120 | %token TYPE 121 | %token UNION 122 | %token VAL 123 | %token YIELD 124 | 125 | /* Infix tokens - special */ 126 | %token AND_AND 127 | %token AT 128 | 129 | %token BANG 130 | %token BANG_EQ 131 | %token BAR_BAR 132 | 133 | %token CARET_CARET 134 | %token COLON 135 | %token COLON_COLON 136 | %token COLON_EQ 137 | %token COMMA 138 | 139 | %token DOT 140 | %token DOT_DOT 141 | 142 | %token EQ 143 | %token EQ_EQ 144 | %token EQ_EQ_EQ 145 | %token EQ_GREATER 146 | 147 | %token GREATER 148 | %token GREATER_EQ 149 | 150 | %token LESS 151 | %token LESS_EQ 152 | 153 | %token MINUS 154 | %token MINUS_GREATER 155 | 156 | %token PLUS 157 | %token PLUS_PLUS 158 | 159 | %token QUESTION 160 | %token QUESTION_QUESTION 161 | %token QUOTE 162 | 163 | %token SEMI 164 | %token STAR 165 | %token STAR_STAR 166 | 167 | %token TILDE 168 | 169 | /* Delimiter tokens */ 170 | %token LBRACE 171 | %token LBRACKET 172 | %token LPAREN 173 | %token RBRACE 174 | %token RBRACKET 175 | %token RPAREN 176 | 177 | %start file 178 | %type file 179 | 180 | %start expr 181 | %type expr 182 | 183 | %% 184 | 185 | 186 | file: 187 | | { symbol_loc (), Eof } 188 | | ASSERT expr IS expr SEMI file { loc 1 5, Assert($2, $4, $6) } 189 | | ASSERT expr EQ expr IS expr SEMI file { loc 1 7, AssertEq($2, $4, $6, $8) } 190 | | VAL variable EQ expr SEMI file { loc 1 5, Val(loc 2 2, $2, $4, $6) } 191 | | VAL variable expr EQ expr SEMI file { 192 | loc 1 6, 193 | Val(loc 2 2, $2, (loc 3 5, Decl($5, $3)), $7) 194 | } 195 | | FUN fun_arglist EQ expr SEMI file { 196 | let (f, fl), (x, _A) = $2 in 197 | loc 1 5, Val(fl, f, (fst $4, Pattern(Some _A, (x, $4))), $6) 198 | } 199 | | FUN fun_arglist expr EQ expr SEMI file { 200 | let (f, fl), (x, _A) = $2 in 201 | let body = loc 3 5, Decl($5, $3) in 202 | loc 1 6, Val(fl, f, (fst body, Pattern(Some _A, (x, body))), $7) 203 | } 204 | | COMPILE ident LPAREN compile_arglist RPAREN expr EQ expr SEMI file { 205 | loc 1 9, Compile($2, $4, $6, $8, $10) 206 | } 207 | | TEST ident LPAREN test_arglist RPAREN EQ expr SEMI file { 208 | loc 1 8, Test($2, $4, $7, $9) 209 | } 210 | ; 211 | 212 | compile_arglist: 213 | | ident expr2 { [$1, $2] } 214 | | ident expr2 COMMA compile_arglist { ($1, $2) :: $4 } 215 | ; 216 | 217 | test_arglist: 218 | | expr2 { [$1] } 219 | | expr2 COMMA test_arglist { $1 :: $3 } 220 | ; 221 | 222 | fun_arglist: 223 | | variable LPAREN arglist RPAREN { ($1, loc 1 1), $3 } 224 | | prefix LPAREN binder expr2 RPAREN { (Var.of_string $1, loc 1 1), ($3, $4) } 225 | | LPAREN binder expr2 RPAREN infix LPAREN binder expr2 RPAREN { 226 | (Var.of_string $5, loc 5 5), 227 | (Ppair($2, $7), (loc 2 8, Sigma($3, ($2, $8)))) 228 | } 229 | ; 230 | 231 | ident: 232 | | IDENT { $1 } 233 | | LPAREN infix RPAREN { $2 } 234 | | LPAREN prefix DOT RPAREN { $2 } 235 | ; 236 | enum_lit: ident { loc 1 1, Enum_lit $1 }; 237 | variable: ident { Var.of_string $1 }; 238 | 239 | binder: 240 | | variable { Pvar(loc 1 1, $1) } 241 | | BLANK { mk_blank (loc 1 1) } 242 | ; 243 | 244 | binders: 245 | | pattern { $1 } 246 | | pattern COMMA binders { Ppair($1, $3) } 247 | ; 248 | 249 | pattern: 250 | | binder { $1 } 251 | | LPAREN binders RPAREN { $2 } 252 | ; 253 | 254 | arglist: 255 | | binder expr2 { $1, $2 } 256 | | binder expr2 COMMA arglist { 257 | let p2, t2 = $4 in 258 | Ppair($1, p2), 259 | (loc 1 2, Sigma($2, ($1, t2))) 260 | }; 261 | 262 | labels1: 263 | | enum_lit COLON expr2 { [$1, $3] } 264 | | enum_lit COLON expr2 COMMA labels1 { ($1, $3) :: $5 } 265 | ; 266 | 267 | labels: 268 | | { [] } 269 | | labels1 { $1 } 270 | ; 271 | 272 | bpattern: 273 | | enum_lit AT COLON expr2 { ($1, $4) } 274 | | enum_lit AT pattern COLON expr2 { 275 | ($1, (loc 3 5, Pattern(None, ($3, $5)))) 276 | } 277 | ; 278 | 279 | blabels: 280 | | bpattern { [$1] } 281 | | bpattern COMMA blabels { $1 :: $3 } 282 | ; 283 | 284 | enum_labels1: 285 | | enum_lit { [$1] } 286 | | enum_lit COMMA enum_labels1 { $1 :: $3 } 287 | ; 288 | 289 | enum_labels: 290 | | { [] } 291 | | enum_labels1 { $1 } 292 | ; 293 | 294 | cases: 295 | | { [] } 296 | | CASE enum_lit COLON stmts cases { ($2, $4) :: $5 } 297 | ; 298 | 299 | bind_cases: 300 | | CASE enum_lit AT pattern COLON stmts { 301 | [$2, (loc 4 6, Pattern(None, ($4, $6)))] 302 | } 303 | | CASE enum_lit AT pattern COLON stmts bind_cases{ 304 | ($2, (loc 4 6, Pattern(None, ($4, $6)))) :: $7 305 | } 306 | ; 307 | 308 | expr_stmt: 309 | | DO expr { $2 } 310 | | GET ident { 311 | let x = Var.dummy () in 312 | loc 1 2, 313 | Call(loc 1 2, 314 | Pair((loc 2 2, 315 | Enum_cst(loc 2 2, Enum_lit $2)), 316 | (loc 2 2, 317 | Pattern(None, (Pvar(loc 1 1, x), 318 | (loc 1 1, Var x)))))) 319 | } 320 | ; 321 | 322 | maybe_bind: 323 | | expr_stmt { Do_bind $1 } 324 | | expr { No_bind $1 } 325 | ; 326 | 327 | simple_stmt: 328 | | IF maybe_bind LBRACE stmts RBRACE { 329 | maybe_bind (loc 1 1) (loc 1 5) (fun x -> 330 | Switch(x, 331 | [(loc 3 3, true_lit), $4; 332 | (loc 5 5, false_lit), 333 | (loc 5 5, Ret(unit_lit_of_loc (loc 5 5)))])) 334 | $2 335 | } 336 | | IF maybe_bind LBRACE stmts RBRACE ELSE LBRACE stmts RBRACE { 337 | maybe_bind (loc 1 1) (loc 1 9) (fun x -> 338 | Switch(x, 339 | [(loc 3 3, true_lit), $4; 340 | (loc 7 7, false_lit), $8])) 341 | $2 342 | } 343 | | FOR pattern IN maybe_bind LBRACE stmts RBRACE { 344 | maybe_bind (loc 3 3) (loc 1 7) (fun x -> For(x, ($2, $6))) $4 345 | } 346 | | SWITCH maybe_bind LBRACE cases RBRACE { 347 | maybe_bind (loc 1 1) (loc 1 5) (fun x -> Switch(x, $4)) $2 348 | } 349 | | SWITCH maybe_bind LBRACE bind_cases RBRACE { 350 | maybe_bind (loc 1 1) (loc 1 5) (fun x -> Switch2(x, $4)) $2 351 | } 352 | ; 353 | 354 | stmt: 355 | | simple_stmt { $1 } 356 | | expr_stmt SEMI { $1 } 357 | ; 358 | 359 | opaque_opt: 360 | | { true } 361 | | OPAQUE { false } 362 | ; 363 | 364 | val_stmt: 365 | | VAL pattern EQ stmt { 366 | fun x -> loc 1 4, Bind($4, None, ($2, x)) 367 | } 368 | | VAL pattern expr EQ stmt { 369 | fun x -> loc 1 5, Bind($5, Some $3, ($2, x)) 370 | } 371 | | VAL pattern EQ opaque_opt expr SEMI { 372 | fun x -> loc 1 6, Let($4, $5, ($2, x)) 373 | } 374 | | VAL pattern expr EQ opaque_opt expr SEMI { 375 | fun x -> loc 1 7, Let($5, (loc 3 6, Decl($6, $3)), ($2, x)) 376 | } 377 | | FUN fun_arglist EQ opaque_opt expr SEMI { 378 | let (f, frange), (x, _A) = $2 in 379 | fun y -> loc 1 6, 380 | Let($4, (loc 5 5, Pattern(Some _A, (x, $5))), 381 | (Pvar(frange, f), y)) 382 | } 383 | | FUN fun_arglist expr EQ opaque_opt expr SEMI { 384 | let (f, frange), (x, _A) = $2 in 385 | fun y -> loc 1 7, 386 | Let($5, (loc 3 6, Pattern(Some _A, (x, (loc 3 6, Decl($6, $3))))), 387 | (Pvar(frange, f), y)) 388 | } 389 | ; 390 | 391 | non_empty_stmts: 392 | | simple_stmt { $1 } 393 | | simple_stmt non_empty_stmts { 394 | let l = end_loc 1 in 395 | loc 1 2, 396 | Bind($1, Some(l, Enum([l, unit_lit])), (mk_blank l, $2)) 397 | } 398 | | DO expr SEMI stmts { 399 | loc 1 4, 400 | Bind($2, Some(loc 3 3, Enum([loc 3 3, unit_lit])), 401 | (mk_blank (loc 3 3), $4)) 402 | } 403 | | YIELD LPAREN expr RPAREN SEMI { loc 1 5, Ret($3) } 404 | | YIELD LPAREN expr_stmt RPAREN SEMI { loc 1 5, snd $3 } 405 | | NEW enum_lit EQ expr SEMI stmts { 406 | loc 1 6, New($2, $4, $6) 407 | } 408 | | val_stmt stmts { loc 1 2, snd ($1 $2) } 409 | | ident COLON_EQ expr SEMI stmts { 410 | let a = loc 1 4, 411 | Call(loc 1 3, 412 | Pair((loc 1 1, Enum_cst(loc 1 1, Enum_lit $1)), 413 | (loc 1 3, 414 | Pattern(None, (Pvar(loc 1 1, Var.of_string $1), $3))))) 415 | in 416 | loc 1 5, 417 | Bind(a, None, (mk_blank (loc 4 4), $5)) 418 | } 419 | ; 420 | 421 | stmts: 422 | | { let l = symbol_loc () in l, Ret(unit_lit_of_loc l) } 423 | | non_empty_stmts { $1 } 424 | ; 425 | 426 | compound_expr: 427 | | val_stmt compound_expr { loc 1 2, snd ($1 $2) } 428 | | expr { $1 } 429 | ; 430 | 431 | prefix: 432 | | BANG { "(!.)" } 433 | | TILDE { "(~.)" } 434 | | MINUS { "(-.)" } 435 | | STAR { "(*.)" } 436 | ; 437 | 438 | gen_prefix: 439 | | prefix { loc 1 1, Var(Var.of_string $1) } 440 | ; 441 | 442 | multiplication: 443 | | STAR { "(*)" } 444 | | STAR_STAR { "(**)" } 445 | ; 446 | 447 | gen_multiplication: 448 | | multiplication { loc 1 1, Var(Var.of_string $1) } 449 | ; 450 | 451 | addition: 452 | | PLUS { "(+)" } 453 | | PLUS_PLUS { "(++)" } 454 | | MINUS { "(-)" } 455 | ; 456 | 457 | gen_addition: 458 | | addition { loc 1 1, Var(Var.of_string $1) } 459 | ; 460 | 461 | relation: 462 | | EQ_EQ { "(==)" } 463 | | EQ_EQ_EQ { "(===)" } 464 | | BANG_EQ { "(!=)" } 465 | | LESS { "(<)" } 466 | | GREATER { "(>)" } 467 | | LESS_EQ { "(<=)" } 468 | | GREATER_EQ { "(>=)" } 469 | ; 470 | 471 | gen_relation: 472 | | relation { loc 1 1, Var(Var.of_string $1) } 473 | ; 474 | 475 | connective: 476 | | AND_AND { "(&&)" } 477 | | BAR_BAR { "(||)" } 478 | | CARET_CARET { "(^^)" } 479 | ; 480 | 481 | gen_connective: 482 | | connective { loc 1 1, Var(Var.of_string $1) } 483 | ; 484 | 485 | infix: 486 | | multiplication { $1 } 487 | | addition { $1 } 488 | | relation { $1 } 489 | | connective { $1 } 490 | ; 491 | 492 | expr10: 493 | | LBRACKET RBRACKET { loc 1 2, Hole } 494 | | IMM { loc 1 1, Imm($1) } 495 | | variable { loc 1 1, Var($1) } 496 | | QUOTE enum_lit { loc 1 2, Enum_cst ($2) } 497 | | REFL { loc 1 1, Imm(Refl) } 498 | | TYPE { loc 1 1, Type } 499 | | INTERFACE { loc 1 1, Interface } 500 | | LPAREN RPAREN { unit_lit_of_loc (loc 1 2) } 501 | | FST LPAREN expr RPAREN { loc 1 4, First $3 } 502 | | SND LPAREN expr RPAREN { loc 1 4, Second $3 } 503 | | CALL LPAREN expr RPAREN { loc 1 4, Call $3 } 504 | | CALL LPAREN RPAREN { loc 1 4, Call(unit_lit_of_loc (loc 2 3)) } 505 | | expr10 LPAREN expr RPAREN { loc 1 4, App($1, $3) } 506 | | expr10 LPAREN RPAREN { loc 1 3, App($1, unit_lit_of_loc (loc 2 3)) } 507 | | expr10 COLON_COLON enum_lit { loc 1 3, App($1, (loc 3 3, Enum_cst $3)) } 508 | | expr10 COLON_COLON infix { loc 1 3, App($1, (loc 3 3, Enum_cst(loc 3 3, Enum_lit $3))) } 509 | | ENUM LBRACE enum_labels RBRACE { loc 1 4, Enum $3 } 510 | | STRUCT LBRACE labels RBRACE { mk_struct 1 2 4 $3 } 511 | | FUN LBRACE labels RBRACE { loc 1 4, Enum_d $3 } 512 | | FUN LBRACE blabels RBRACE { loc 1 4, Enum_d2 $3 } 513 | | UNION LBRACE labels RBRACE { mk_union 1 2 4 $3 } 514 | | TUPLE LPAREN arglist RPAREN { snd $3 } 515 | | METH LBRACE labels RBRACE { loc 1 4, Complex_interface $3 } 516 | | INTERPRET expr LBRACE expr RBRACE { loc 1 4, Interpret($2, $4) } 517 | | BLOCK expr4 EQ_GREATER expr3 LBRACE stmts RBRACE { 518 | loc 1 7, Decl($6, (loc 2 4, Tree($2, $4))) 519 | } 520 | | BLOCK LBRACE stmts RBRACE { $3 } 521 | | PURIFY expr LBRACE stmts RBRACE { 522 | loc 1 5, Purify($2, $4) 523 | } 524 | | LPAREN compound_expr RPAREN { $2 } 525 | ; 526 | 527 | expr9: 528 | | expr10 { $1 } 529 | | enum_lit DOT expr9 { loc 1 3, Dot((loc 1 1, Enum_cst $1), $3) } 530 | | enum_lit AT expr9 { loc 1 3, Pair((loc 1 1, Enum_cst $1), $3) } 531 | ; 532 | 533 | expr8: 534 | | expr9 { $1 } 535 | | gen_prefix expr9 { loc 1 2, App($1, $2) } 536 | ; 537 | 538 | expr7: 539 | | expr8 { $1 } 540 | | expr7 gen_multiplication expr8 { loc 1 3, App($2, (loc 1 3, Pair($1, $3))) } 541 | ; 542 | 543 | expr6: 544 | | expr7 { $1 } 545 | | expr6 gen_addition expr7 { loc 1 3, App($2, (loc 1 3, Pair($1, $3))) } 546 | ; 547 | 548 | expr5: 549 | | expr6 { $1 } 550 | | expr6 gen_relation expr6 { loc 1 3, App($2, (loc 1 3, Pair($1, $3))) } 551 | | expr6 AEQ LPAREN expr2 RPAREN expr6 { 552 | loc 1 6, Id($4, $1, $6) 553 | } 554 | ; 555 | 556 | expr4: 557 | | expr5 { $1 } 558 | | expr5 gen_connective expr5 { loc 1 3, App($2, (loc 1 3, Pair($1, $3))) } 559 | ; 560 | 561 | expr3: 562 | | expr4 { $1 } 563 | | expr4 DOT_DOT expr4 { loc 1 3, Range($1, $3) } 564 | | DEP LPAREN arglist RPAREN MINUS_GREATER expr3 { 565 | let x, _A = $3 in 566 | loc 1 6, Pi(_A, (x, $6)) 567 | } 568 | | expr4 MINUS_GREATER expr3 { 569 | loc 1 3, Pi($1, (mk_blank (loc 2 2), $3)) 570 | } 571 | | expr4 EQ_GREATER expr3 { loc 1 3, Tree($1, $3) } 572 | | expr4 QUESTION expr4 COLON expr4 { 573 | loc 1 5, 574 | Switch($1, [(loc 2 2, true_lit), $3; (loc 4 4, false_lit), $5]) 575 | } 576 | ; 577 | 578 | expr2: 579 | | expr3 { $1 } 580 | | METH LPAREN arglist RPAREN expr2 { 581 | let x, _A = $3 in 582 | let _B = loc 5 5, Pattern(None, (x, $5)) in 583 | loc 1 5, Decl((loc 1 5, Pair(_A, _B)), (loc 1 1, Interface)) 584 | } 585 | | FUN LPAREN arglist RPAREN expr2 { 586 | let x, _A = $3 in 587 | loc 1 5, Pattern(Some _A, (x, $5)) 588 | } 589 | | FUN LPAREN binders RPAREN expr2 { 590 | loc 1 5, Pattern(None, ($3, $5)) 591 | } 592 | | SUBST LPAREN expr2 COMMA expr2 RPAREN LPAREN binder COMMA binder RPAREN expr2 { 593 | loc 1 12, Subst($3, ($8, ($10, $12)), $5) 594 | } 595 | ; 596 | 597 | expr: 598 | | expr2 { $1 } 599 | | expr2 COMMA expr { loc 1 3, Pair($1, $3) } 600 | ; 601 | 602 | %% 603 | -------------------------------------------------------------------------------- /term.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | (* 18 | 19 | The output of the type checker are terms, and terms can be evaluated 20 | to values. 21 | 22 | Expr ---Check_expr---> Term ---Eval---> Value. 23 | 24 | Terms can also be checked for correctness. 25 | *) 26 | 27 | open Base 28 | 29 | (* The type of term-level functions from el to 'cod. As term-level 30 | functions are abstractions, this is is simply a pair of a pattern 31 | and an element of 'cod. *) 32 | type 'cod fn = pattern * 'cod 33 | 34 | (* A monomorphic term is a term whose type can be inferred. For a 35 | detailed desciption of the constructors, see the corresponding 36 | value type. *) 37 | type mono = 38 | (* Monomorphic constructors. *) 39 | | Imm of imm (* A special case is Refl, which is not monomorphic. *) 40 | (* Universe sets. *) 41 | | Pi_u of poly * poly fn 42 | | Sigma_u of poly * poly fn 43 | | Id_u of poly * poly * poly 44 | | Tree_u of poly * poly 45 | | Enum_u of enum 46 | | Imm_set_u of size 47 | (* Application. *) 48 | | App of mono * poly 49 | | Var of var 50 | (* Type declaration. *) 51 | | Poly of poly * set 52 | (* Destructors *) 53 | | Fst of mono 54 | | Snd of mono 55 | | Enum_d of mono * set fn * poly enum_map 56 | | Range of poly * poly 57 | | Subst of mono * set fn fn * poly 58 | | For of mono * poly fn * poly * poly fn 59 | | Bind of mono * poly * poly fn 60 | | Local of size * poly * poly * poly * poly 61 | | Purify of poly * poly 62 | | Catch of poly * poly * poly * poly * poly 63 | | Builtin of builtin * poly list 64 | (* Extra construct for let binding/beta redex. *) 65 | | Beta_mono of mono * mono fn 66 | 67 | (* A polymorphic term can type check against many different sets, even 68 | in the same context. *) 69 | and poly = 70 | (* A monomorphic term is vacuously polymorphic. *) 71 | | Mono of mono 72 | (* Constructors *) 73 | | Lambda of poly fn 74 | | Pair of poly * poly 75 | | Ret of poly 76 | | Invk of poly * poly fn 77 | (* Extra construct for let binding/beta redex. *) 78 | | Beta_poly of mono * poly fn 79 | (* TODO: location for holes? *) 80 | | Hole 81 | 82 | (* A term-level set is just a set on the term-level. *) 83 | and set = 84 | | Pi of set * set fn 85 | | Sigma of set * set fn 86 | | Id of set * poly * poly 87 | | Tree of poly * poly 88 | | Enum of enum 89 | | Imm_set of size 90 | | Type 91 | | T of poly 92 | | Hole_set 93 | 94 | let poly_of_var x = Mono(Var x) 95 | let mono_of_var x = Var x 96 | 97 | let true_cst = Imm(true_imm) 98 | let false_cst = Imm(false_imm) 99 | let bool_set = Enum bool_enum 100 | let bool_u = Enum_u bool_enum 101 | 102 | let unit_cst = Imm(unit_imm) 103 | let unit_set = Enum unit_enum 104 | let unit_u = Enum_u unit_enum 105 | 106 | let empty_set = Enum empty_enum 107 | let empty_u = Enum_u empty_enum 108 | -------------------------------------------------------------------------------- /test_expr.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | open Base 18 | 19 | let maybe_print str = () (* Printf.printf "%s" str *) 20 | 21 | let initial_ctx = Initial.ctx 22 | 23 | let verify a __A = 24 | let ___A = Reify.set __A in 25 | Check_term.set initial_ctx ___A; 26 | let ____A = Eval.set (Ctx.assign initial_ctx) ___A in 27 | let _____A = Reify.set ____A in 28 | Value.eq_set __A ____A; 29 | Check_term.poly initial_ctx __A a; 30 | let aa = Eval.poly (Ctx.assign initial_ctx) a in 31 | let aaa = Reify.el aa in 32 | Check_term.poly initial_ctx __A aaa; 33 | let aaaa = Eval.poly (Ctx.assign initial_ctx) aaa in 34 | Value.eq_el aa aaaa 35 | 36 | let parse_string' str = 37 | let lb = Lexing.from_string str in 38 | lb.Lexing.lex_curr_p <- { 39 | lb.Lexing.lex_curr_p with Lexing.pos_fname = str 40 | }; 41 | try 42 | Syntax.expr Lex.token lb 43 | with Parsing.Parse_error -> 44 | let curr = lb.Lexing.lex_curr_p in 45 | let line = curr.Lexing.pos_lnum in 46 | let cnum = curr.Lexing.pos_cnum - curr.Lexing.pos_bol in 47 | let tok = Lexing.lexeme lb in 48 | Printf.printf "Parse: %s\n" str; 49 | Printf.printf "%d:%d unexpected token: %s\n" line cnum tok; 50 | raise Parsing.Parse_error 51 | 52 | let with_reporting str f a b = 53 | f a b 54 | (* try *) 55 | (* with *) 56 | (* | Check_expr.Error as e -> *) 57 | (* Format.eprintf "\n\n@?%s" str; *) 58 | (* raise e *) 59 | (* | e -> *) 60 | (* Format.print_string str; *) 61 | (* raise e *) 62 | 63 | let parse_string str = 64 | let a, b = 65 | with_reporting (Printf.sprintf "Infer: %s" str) 66 | Check_expr.infer 67 | initial_ctx 68 | (parse_string' str) 69 | in 70 | with_reporting "Verify" 71 | verify 72 | (Term.Mono b) 73 | a; 74 | maybe_print (Printf.sprintf "OK: success '%s'\n" str); 75 | a, b 76 | 77 | let parse_set str = 78 | ignore ( 79 | with_reporting (Printf.sprintf "Check set: %s" str) 80 | Check_expr.set 81 | initial_ctx 82 | (parse_string' str)); 83 | maybe_print (Printf.sprintf "OK: success set '%s'\n" str) 84 | 85 | let _ = parse_string "(val x = true; x)" 86 | let _ = parse_string "(fun f(x i32) i32 = x; f)" 87 | let _ = parse_set "enum {false,true}" 88 | let _ = parse_set "enum {}" 89 | let _ = parse_set "dep(x enum {false,true}) -> dep(y type) -> y" 90 | let _ = parse_set "tuple(x bool, _ bool)" 91 | let _ = parse_set "struct {x: bool}" 92 | let _ = parse_set "struct {x: bool, y: void}" 93 | let _ = parse_set "struct {}" 94 | let _ = parse_set "union {x: bool}" 95 | let _ = parse_set "union {x: bool, y: struct {}}" 96 | let _ = parse_set "union {}" 97 | let _ = parse_string "()" 98 | let _ = parse_string "(val x void = (); x)" 99 | let _ = parse_set "interface" 100 | let _ = parse_string "(val x enum {false,true} = 'true; x)" 101 | let _ = parse_set "struct {a: i32, C: dep(x i32)->i32}" 102 | let _ = parse_set "(meth(x void) bool) => i8" 103 | let _ = parse_set "(meth(x void, y bool) i32) => i8" 104 | let _ = parse_string 105 | "( 106 | val string = void; 107 | val open = meth(x string) i32; 108 | val close = meth(_ i32) bool; 109 | () 110 | )" 111 | let _ = parse_string " 112 | (val x = 113 | block meth {} => bool { 114 | if true { yield(()); } else { } 115 | yield(true); 116 | }; 117 | x)" 118 | 119 | let _ = parse_string "true ? true : false" 120 | 121 | let _ = parse_string "( 122 | val (+) = mod32::(+); 123 | val test_for2 = block (meth(_ i32)bool) => void { 124 | for x in 0..(1+1) { 125 | val _ = do call2(meth(_ i32)bool, x); 126 | } 127 | }; () )" 128 | 129 | let _ = parse_string "( 130 | fun (||)(z bool, y bool) bool = z ? true : y; 131 | val (==) = mod32::(==); 132 | val (+) = mod32::(+); 133 | val srem = mod32::srem; 134 | fun euler2(x i32) = block meth {} => i32 { 135 | new c = new_i32(0); 136 | for z in 0..x { 137 | if srem(z, 3, refl) == 0 || srem(z, 5, refl) == 0 { 138 | val _ = do c.call(fun(u) u + z); 139 | } 140 | } 141 | val w i32 = do c.call(fun(u) u); 142 | yield(w); 143 | }; 144 | () 145 | )" 146 | 147 | let _ = parse_string "( 148 | val (==) = mod32::(==); 149 | fun (||)(z bool, y bool) bool = z ? true : y; 150 | val (+) = mod32::(+); 151 | val srem = mod32::srem; 152 | fun euler2(x i32) = block meth {} => i32 { 153 | new c = new_i32(0); 154 | for z in 0..x { 155 | if srem(z, 3, refl) == 0 || srem(z, 5, refl) == 0 { 156 | val _ = do call(c@(fun(u) u + z)); 157 | } 158 | } 159 | yield(do call(c@(fun(u) u))); 160 | }; 161 | () 162 | )" 163 | -------------------------------------------------------------------------------- /test_llvm.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | open Base 18 | 19 | let parse_string' str = 20 | let lexbuf = Lexing.from_string str in 21 | try 22 | Syntax.expr Lex.token lexbuf 23 | with Parsing.Parse_error -> 24 | let curr = lexbuf.Lexing.lex_curr_p in 25 | let line = curr.Lexing.pos_lnum in 26 | let cnum = curr.Lexing.pos_cnum - curr.Lexing.pos_bol in 27 | let tok = Lexing.lexeme lexbuf in 28 | Printf.printf "%d:%d unexpected token: %s\n" line cnum tok; 29 | raise Parsing.Parse_error 30 | 31 | let parse_string ctx t str = 32 | let a_poly = Check_expr.check ctx t (parse_string' str) in 33 | Check_term.poly ctx t a_poly; 34 | let a_value = Eval.poly (Ctx.assign ctx) a_poly in 35 | a_value 36 | 37 | let compile name (proto : Ipl_llvm.proto) str = 38 | let cod, args = proto in 39 | let codt = Value.Tree(Eval.empty_interface, (Value.Imm_set_u cod)) in 40 | let ext ctx (v, t) = 41 | let v' = Var.of_string v in 42 | Ctx.extend ctx no_location v' (Value.el_of_var v') (Value.Imm_set t) in 43 | let ctx = List.fold_left ext Initial.ctx args in 44 | let ct = parse_string ctx codt str in 45 | let fn = Ipl_llvm.compile_function name proto ct Ipl_compile.no_invoke in 46 | ct, fn 47 | 48 | open Llvm_executionengine 49 | 50 | let test name (result:imm) (args:(string * imm) list) str = 51 | let cod = Ipl_llvm.size_of_imm result in 52 | let dom = List.map (fun (x, y) -> x, Ipl_llvm.size_of_imm y) args in 53 | let ct, fn = compile name (cod, dom) str in 54 | (* Llvm.dump_value fn; *) 55 | (* Interpret function. *) 56 | let poly = Reify.el ct in 57 | let ext ctx (v, t) = 58 | let v' = Var.of_string v in 59 | Ctx.extend ctx no_location v' (Value.Imm t) 60 | (Value.Imm_set (Ipl_llvm.size_of_imm t)) 61 | in 62 | let ctx = List.fold_left ext Initial.ctx args in 63 | let rho = Ctx.assign ctx in 64 | begin 65 | match Eval.poly rho poly with 66 | | Value.Ret(Value.Imm m) when m = result -> () 67 | | Value.Ret(Value.Imm m) -> 68 | failwith (Format.sprintf "Expected %s, got %s." 69 | (Printing.string_of_imm result) 70 | (Printing.string_of_imm m)) 71 | | m -> 72 | Format.eprintf "Expected %s. Got:\n" (Printing.string_of_imm result); 73 | Printing.el Format.err_formatter m; 74 | raise Presupposition_error 75 | end; 76 | (* Execute compiled function. *) 77 | let cargs = 78 | Array.of_list (List.map (fun (_, x) -> Ipl_llvm.generic_of_imm x) args) 79 | in 80 | let r = ExecutionEngine.run_function fn cargs Ipl_llvm.main_engine in 81 | if not (Ipl_llvm.generic_eq_imm r result) then 82 | failwith (Format.sprintf "Expected %s." (Printing.string_of_imm result)) 83 | 84 | let i32 x = Imm32 (Int32.of_int x) 85 | 86 | let _ = test "test1" (i32 10) ["x", i32 5] 87 | "block { 88 | fun dup(z i32) tuple(_ i32, _ i32) = z, z; 89 | val (+) = mod32::(+); 90 | yield((+)(dup(x))); 91 | }" 92 | 93 | 94 | let _ = test "test2" (i32 20) ["x", i32 10; "y", i32 11] 95 | "block { 96 | val (+) = mod32::(+); 97 | val (<) = mod32::(<); 98 | fun dup(z i32) tuple(_ i32, _ i32) = z, z; 99 | val tmp tuple(_ i32, _ i32) = x < y ? dup(x) : dup(y); 100 | val tmp2 = fst(tmp) + snd(tmp); 101 | yield(tmp2); 102 | }" 103 | 104 | let _ = test "test3" (i32 8) ["x", i32 3; "y", i32 5] 105 | "block { 106 | for z in x..y { } 107 | val (+) = mod32::(+); 108 | yield(x+y); 109 | }" 110 | 111 | let _ = test "test4" (i32 20) ["x", i32 10] 112 | "block { 113 | val (+) = mod32::(+); 114 | new c = new_i32(x); 115 | val w i32 = do c.call(fun(u) u + x); 116 | yield(w); 117 | }" 118 | 119 | 120 | (* Initial value of counter 99. Increase 3 (=x) times 33 gives 198. *) 121 | let _ = test "test5" (i32 198) ["x", i32 3] 122 | "block { 123 | val (+) = mod32::(+); 124 | new c = new_i32(99); 125 | for z in 0..x { 126 | val _ i32 = do c.call(fun(i) i + 33); 127 | } 128 | yield(do c.call(fun(i)i)); 129 | }" 130 | 131 | let _ = test "euler3" (i32 233168) ["x", i32 1000] 132 | "block { 133 | fun (z bool) || (y bool) = z ? true : y; 134 | val (==) = mod32::(==); 135 | val (+) = mod32::(+); 136 | val srem = mod32::srem; 137 | new c = new_i32(0); 138 | for z in 0..x { 139 | if srem(z, 3, refl) == 0 || srem(z, 5, refl) == 0 { 140 | c := c + z; 141 | } 142 | } 143 | yield(get c); 144 | }" 145 | -------------------------------------------------------------------------------- /test_term.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | open Base 18 | 19 | (* This program simply checks that the initial context loads properly. *) 20 | 21 | let main () = () 22 | 23 | let _ = main () 24 | -------------------------------------------------------------------------------- /value.ml: -------------------------------------------------------------------------------- 1 | (* INTUITIONISTIC TYPE THEORY PROGRAMMING LANGUAGE *) 2 | (* *) 3 | (* Copyright (c) 2006-2013 Johan G. Granstroem. *) 4 | (* *) 5 | (* Licensed under the Apache License, Version 2.0 (the "License"); *) 6 | (* you may not use this file except in compliance with the License. *) 7 | (* You may obtain a copy of the License at *) 8 | (* *) 9 | (* http://www.apache.org/licenses/LICENSE-2.0 *) 10 | (* *) 11 | (* Unless required by applicable law or agreed to in writing, software *) 12 | (* distributed under the License is distributed on an "AS IS" BASIS, *) 13 | (* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *) 14 | (* See the License for the specific language governing permissions and *) 15 | (* limitations under the License. *) 16 | 17 | open Base 18 | 19 | (* The type of value-level functions from el to 'cod. *) 20 | type 'cod fn = 21 | | Fn of (el -> 'cod) 22 | | Cst of 'cod 23 | 24 | (* The type of value-level elements of sets. *) 25 | and el = 26 | (* Immediate constant. *) 27 | | Imm of imm 28 | (* The universe code for the Pi set. *) 29 | | Pi_u of el * el fn 30 | (* The universe code for the Sigma set. *) 31 | | Sigma_u of el * el fn 32 | (* The universe code for the Id set. *) 33 | | Id_u of el * el * el 34 | (* The universe code for the Tree set. *) 35 | | Tree_u of el * el 36 | (* The universe code for an enumerated set. *) 37 | | Enum_u of enum 38 | (* The unverse code for set of immediates. *) 39 | | Imm_set_u of size 40 | (* Canonical element of the Pi set. *) 41 | | Lambda of el fn 42 | (* Canonical element of the Sigma set. *) 43 | | Pair of el * el 44 | (* Canonical element on return form of the Tree set. *) 45 | | Ret of el 46 | (* Canonical element on invoke form of the Tree set. *) 47 | | Invk of el * el fn 48 | (* Noncanonical value-level element. *) 49 | | Neut of neut 50 | (* A 'hole' has the property that destructor(hole) = hole. A hole is 51 | equal to anything else. *) 52 | | Hole 53 | 54 | (* The type of value-level neutral elements of sets. *) 55 | and neut = 56 | (* Variable. *) 57 | | Var of var 58 | (* Application - destructor of Pi set. *) 59 | | App of neut * el 60 | (* First destructor of Sigma set. *) 61 | | Fst of neut 62 | (* Second destructor of Sigma set. *) 63 | | Snd of neut 64 | (* Destructor of enumerated set. *) 65 | | Enum_d of neut * set fn * el Lazy.t enum_map 66 | (* Destructor of Id set. *) 67 | | Subst of neut * set fn fn * el 68 | (* Lifting of component. *) 69 | | For of neut * el fn * el * el fn 70 | (* Bind operation on programs. *) 71 | | Bind of neut * el * el fn 72 | (* Range of integers. *) 73 | | Range1 of neut * el 74 | | Range2 of int32 * neut 75 | (* local(sz, i, a, init, p), where p is netural. *) 76 | | Local of size * el * el * el * component 77 | (* Purify. *) 78 | | Purify of el * neut 79 | (* catch(B, I, A, f, p), where p is neutral. *) 80 | | Catch of el * el * el * el * component 81 | (* Builtin primitive operation. *) 82 | | Builtin of builtin * imm list * neut * el list 83 | 84 | and component = 85 | (* Neutral object of type meth { C1:I1, ..., Cn:In } => A. *) 86 | | Component1 of neut 87 | (* Neutral object of pair type. *) 88 | | Component2 of neut * el fn 89 | (* Neutral object of enum type. *) 90 | | Component3 of neut * el * el fn 91 | 92 | (* The type of value-level sets. *) 93 | and set = 94 | (* The Pi set of functions. *) 95 | | Pi of set * set fn 96 | (* The Sigma set of pairs. *) 97 | | Sigma of set * set fn 98 | (* The Id set of equality proofs. *) 99 | | Id of set * el * el 100 | (* The Tree set of programs (interface * type). *) 101 | | Tree of el * el 102 | (* Enumerated sets. *) 103 | | Enum of enum 104 | (* Sets of immedate values. *) 105 | | Imm_set of size 106 | (* The universe of sets. *) 107 | | Type 108 | (* Decoding of a code for a set. *) 109 | | T of neut 110 | (* An hole that is a set. *) 111 | | Hole_set 112 | 113 | (* Create an element of the specified variable. *) 114 | let el_of_var (x : var) : el = Neut (Var x) 115 | 116 | (* Crate a new dummy element. *) 117 | let dummy_el () = el_of_var (Var.dummy ()) 118 | 119 | (* Create a new element from the given pattern. *) 120 | let rec el_of_pattern = function 121 | | Pvar (_, var) -> 122 | assert(var <> Var.no); 123 | Neut(Var(var)) 124 | | Ppair(p, q) -> Pair(el_of_pattern p, el_of_pattern q) 125 | 126 | (* Apply the given function to the given value. *) 127 | let apv (f : 'a fn) (a : el) : 'a = 128 | match f with 129 | | Fn(g) -> g a 130 | | Cst(c) -> c 131 | 132 | (* Apply the given function to the given lazy value. *) 133 | let ap (f : 'a fn) (a : el lazy_t) : 'a = 134 | match f with 135 | | Fn(g) -> g (Lazy.force a) 136 | | Cst(c) -> c 137 | 138 | (* Precompose the function f with the function g. *) 139 | let precomp (f : 'a -> 'b) (g : 'a fn) : 'b fn = 140 | match g with 141 | | Cst(c) -> Cst(f c) 142 | | Fn(h) -> Fn(fun x -> f (h x)) 143 | 144 | let true_cst = Imm(true_imm) 145 | let false_cst = Imm(false_imm) 146 | let bool_set = Enum bool_enum 147 | let bool_u = Enum_u bool_enum 148 | 149 | let unit_cst = Imm(unit_imm) 150 | let unit_set = Enum unit_enum 151 | let unit_u = Enum_u unit_enum 152 | 153 | let empty_set = Enum empty_enum 154 | let empty_u = Enum_u empty_enum 155 | 156 | let i64_set = Imm_set(I64) 157 | let i32_set = Imm_set(I32) 158 | let i16_set = Imm_set(I16) 159 | let i8_set = Imm_set(I8) 160 | let i64_u = Imm_set_u(I64) 161 | let i32_u = Imm_set_u(I32) 162 | let i16_u = Imm_set_u(I16) 163 | let i8_u = Imm_set_u(I8) 164 | 165 | let set_of_imm = function 166 | | Imm8 _ -> i8_set 167 | | Imm16 _ -> i16_set 168 | | Imm32 _ -> i32_set 169 | | Imm64 _ -> i64_set 170 | | Enum_imm (e, _) -> Enum e 171 | | Refl -> raise Presupposition_error 172 | 173 | (* Apply x and y to a common dummy variable and pass the results through f. *) 174 | let fork (f : 'a -> 'b -> 'c) (x : 'a fn) (y : 'b fn) : 'c = 175 | let dummy = dummy_el () in 176 | let dx = apv x dummy in 177 | let dy = apv y dummy in 178 | f dx dy 179 | 180 | (* Raise a Not_equal exception if the two sets are not equal. *) 181 | let rec eq_set (x : set) (y : set) : unit = 182 | match x, y with 183 | | Pi(a, b), Pi(aa, bb) 184 | | Sigma(a, b), Sigma(aa, bb) -> eq_set a aa; fork eq_set b bb 185 | | Tree(i, a), Tree(ii, aa) -> 186 | eq_el i ii; eq_el a aa 187 | | Id(a, b, c), Id(aa, bb, cc) -> eq_set a aa; eq_el b bb; eq_el c cc 188 | | Enum a, Enum b when Enum_set.equal a b -> () 189 | | Imm_set a, Imm_set b when a = b -> () 190 | | Type, Type -> () 191 | | T n, T m -> eq_neut n m 192 | (* A hole is equal to any other set. *) 193 | | Hole_set, _ 194 | | _, Hole_set -> () 195 | | _ -> raise Not_equal 196 | 197 | (* Raise a Not_equal exception if the two elements are not equal. *) 198 | and eq_el (x : el) (y : el) : unit = 199 | match x, y with 200 | | Imm a, Imm b -> eq_imm a b 201 | | Pi_u(a, b), Pi_u(aa, bb) 202 | | Sigma_u(a, b), Sigma_u(aa, bb) -> eq_el a aa; fork eq_el b bb 203 | | Tree_u(i, a), Tree_u(ii, aa) -> 204 | eq_el i ii; eq_el a aa 205 | | Id_u(a, b, c), Id_u(aa, bb, cc) -> eq_el a aa; eq_el b bb; eq_el c cc 206 | | Enum_u a, Enum_u b when Enum_set.equal a b -> () 207 | | Imm_set_u a, Imm_set_u b when a = b -> () 208 | | Lambda(f), Lambda(g) -> fork eq_el f g 209 | | Lambda(f), Neut(g) -> 210 | let dummy = dummy_el () in 211 | eq_el (apv f dummy) (Neut(App(g, dummy))) 212 | | Neut(g), Lambda(f) -> 213 | let dummy = dummy_el () in 214 | eq_el (Neut(App(g, dummy))) (apv f dummy) 215 | | Pair(a, b), Pair(aa, bb) -> eq_el a aa; eq_el b bb 216 | | Pair(a, b), Neut(c) -> eq_el a (Neut (Fst c)); eq_el b (Neut (Snd c)) 217 | | Neut(c), Pair(a, b) -> eq_el (Neut (Fst c)) a; eq_el (Neut (Snd c)) b 218 | | Ret(a), Ret(aa) -> eq_el a aa 219 | | Invk(c, t), Invk(cc, tt) -> eq_el c cc; fork eq_el t tt 220 | | Neut(n), Neut(m) -> eq_neut n m 221 | | Hole, _ 222 | | _, Hole -> () 223 | | _ -> raise Not_equal 224 | 225 | and eq_el_array (x : el array) (y : el array) : unit = 226 | assert(Array.length x <> Array.length y); 227 | (* Duh, no Array.iter2... *) 228 | Array.iteri (fun i yy -> eq_el (Array.get x i) yy) y 229 | 230 | (* Raise a Not_equal exception if the two neutral elements are not equal. *) 231 | and eq_neut (x : neut) (y : neut) : unit = 232 | match x, y with 233 | | For (n, _U, _I, f), For (m, _V, _J, g) -> 234 | eq_neut n m; fork eq_el _U _V; 235 | eq_el _I _J; fork eq_el f g 236 | | Bind (n, _B, f), Bind (m, _C, g) -> 237 | eq_neut n m; eq_el _B _C; fork eq_el f g 238 | | Var x, Var y when x = y -> () 239 | | App(n, v), App(nn, vv) -> eq_neut n nn; eq_el v vv 240 | | Fst(n), Fst(nn) 241 | | Snd(n), Snd(nn) -> eq_neut n nn; 242 | | Enum_d(n, _C, a), Enum_d(nn, _CC, aa) -> 243 | begin 244 | eq_neut n nn; fork eq_set _C _CC; 245 | let mergefn _ u v = 246 | match u, v with 247 | | Some xx, Some yy -> eq_el (Lazy.force xx) (Lazy.force yy); None 248 | (* The two neuts are not equal because they have different 249 | keys in the destructor function. *) 250 | | _ -> raise Not_equal 251 | in 252 | ignore (Enum_map.merge mergefn a aa) 253 | end 254 | | Subst(r, _C, d), Subst(rr, _CC, dd) -> 255 | eq_neut r rr; (comp fork fork) eq_set _C _CC; eq_el d dd 256 | | Builtin (p, c, n, r), Builtin (p', c', n', r') 257 | when p = p' && 258 | List.length c = List.length c' && 259 | List.length r = List.length r' -> 260 | begin 261 | List.iter2 eq_imm c c'; 262 | eq_neut n n'; 263 | List.iter2 eq_el r r' 264 | end 265 | | Local(sz, i, a, n, p), Local(sz', i', a', n', p') when sz = sz' -> 266 | eq_el i i'; eq_el a a'; eq_el n n'; eq_component p p' 267 | | Purify(c1, m1), Purify(c2, m2) -> eq_el c1 c2; eq_neut m1 m2 268 | | Range1(n, e), Range1(nn, ee) -> 269 | eq_neut n nn; eq_el e ee 270 | | Range2(n, e), Range2(nn, ee) when n == nn -> eq_neut e ee 271 | | Catch(b, i, a, f, p), Catch(b', i', a', f', p') -> 272 | eq_el b b'; eq_el i i'; eq_el a a'; eq_el f f'; eq_component p p' 273 | | _ -> raise Not_equal 274 | 275 | and eq_imm (xx:imm) (yy:imm) :unit = 276 | match xx, yy with 277 | | Imm8 x, Imm8 y when x = y -> () 278 | | Imm16 x, Imm16 y when x = y -> () 279 | | Imm32 x, Imm32 y when x = y -> () 280 | | Imm64 x, Imm64 y when x = y -> () 281 | | Enum_imm(e, Enum_lit x), Enum_imm(f, Enum_lit y) 282 | when Enum_set.equal e f && x = y -> () 283 | | Refl, Refl -> () 284 | | _ -> raise Not_equal 285 | 286 | and eq_component (a:component) (b:component) :unit = 287 | match a, b with 288 | | Component1(n), Component1(n') -> 289 | eq_neut n n' 290 | | Component2(n, f), Component2(n', f') -> 291 | eq_neut n n'; 292 | fork eq_el f f' 293 | | Component3(n, b, f), Component3(n', b', f') -> 294 | eq_neut n n'; 295 | eq_el b b'; 296 | fork eq_el f f' 297 | | _ -> raise Not_equal 298 | 299 | (* Comparison of elements so that they can be keys of maps. *) 300 | let el_ordinal = 301 | function 302 | | Imm(_) -> 0 303 | | Lambda(_) -> 1 304 | | Pair(_, _) -> 2 305 | | Ret(_) -> 3 306 | | Invk(_) -> 4 307 | | Neut(_) -> 5 308 | | Pi_u(_, _) -> 6 309 | | Sigma_u(_, _) -> 7 310 | | Tree_u(_, _) -> 8 311 | | Id_u(_, _, _) -> 9 312 | | Enum_u(_) -> 10 313 | | Imm_set_u(_) -> 11 314 | (* Hole cannot be compared. *) 315 | | Hole -> raise Presupposition_error 316 | 317 | let neut_ordinal = 318 | function 319 | | Var(_) -> 0 320 | | App(_, _) -> 1 321 | | Fst(_) -> 2 322 | | Snd(_) -> 3 323 | | Enum_d(_, _, _) -> 4 324 | | Subst(_, _, _) -> 5 325 | | For(_, _, _, _) -> 6 326 | | Bind(_, _, _) -> 7 327 | | Range1(_, _) -> 8 328 | | Range2(_, _) -> 9 329 | | Local(_, _, _, _, _) -> 10 330 | | Purify(_, _) -> 11 331 | | Catch(_, _, _, _, _) -> 12 332 | | Builtin(_, _, _, _) -> 13 333 | 334 | let component_ordinal = function 335 | | Component1(_) -> 0 336 | | Component2(_, _) -> 1 337 | | Component3(_, _, _) -> 2 338 | 339 | let rec cmpfold = 340 | function 341 | | [] -> 0 342 | | x :: xs -> 343 | let xx = Lazy.force x in 344 | if xx = 0 then cmpfold xs 345 | else xx 346 | 347 | let rec compare_el (x : el) (y : el) : int = 348 | match x, y with 349 | | Imm a, Imm b -> compare a b 350 | | Pi_u(a, b), Pi_u(aa, bb) 351 | | Sigma_u(a, b), Sigma_u(aa, bb) -> 352 | cmpfold [lazy (compare_el a aa); lazy (fork compare_el b bb)] 353 | | Tree_u(i, a), Tree_u(ii, aa) -> 354 | cmpfold [lazy (compare_el i ii); lazy (compare_el a aa)] 355 | | Id_u(a, b, c), Id_u(aa, bb, cc) -> 356 | cmpfold [lazy (compare_el a aa); 357 | lazy (compare_el b bb); 358 | lazy (compare_el c cc)] 359 | | Enum_u a, Enum_u b -> Enum_set.compare a b 360 | | Imm_set_u a, Imm_set_u b -> compare a b 361 | | Lambda(f), Lambda(g) -> fork compare_el f g 362 | | Lambda(f), Neut(g) -> 363 | let dummy = dummy_el () in 364 | compare_el (apv f dummy) (Neut(App(g, dummy))) 365 | | Neut(g), Lambda(f) -> 366 | let dummy = dummy_el () in 367 | compare_el (Neut(App(g, dummy))) (apv f dummy) 368 | | Pair(a, b), Pair(aa, bb) -> 369 | cmpfold [lazy (compare_el a aa); lazy (compare_el b bb)]; 370 | | Pair(a, b), Neut(c) -> 371 | cmpfold [lazy (compare_el a (Neut (Fst c))); 372 | lazy (compare_el b (Neut (Snd c)))] 373 | | Neut(c), Pair(a, b) -> 374 | cmpfold [lazy (compare_el (Neut (Fst c)) a); 375 | lazy (compare_el (Neut (Snd c)) b)] 376 | | Ret(a), Ret(aa) -> compare_el a aa 377 | | Invk(c, t), Invk(cc, tt) -> 378 | cmpfold [lazy (compare_el c cc); lazy (fork compare_el t tt)] 379 | | Neut(n), Neut(m) -> compare_neut n m 380 | | _ -> 381 | let xx = el_ordinal x in 382 | let yy = el_ordinal y in 383 | assert(xx <> yy); 384 | compare xx yy 385 | 386 | and compare_neut (x : neut) (y : neut) : int = 387 | match x, y with 388 | | For (n, _, _, f), For (m, _, _, g) -> 389 | cmpfold [lazy (compare_neut n m); lazy (fork compare_el f g)] 390 | | Bind (n, _, f), Bind (m, _, g) -> 391 | cmpfold [lazy (compare_neut n m); lazy (fork compare_el f g)] 392 | | Var x, Var y -> compare x y 393 | | App(n, v), App(nn, vv) -> 394 | cmpfold [lazy (compare_neut n nn); lazy (compare_el v vv)] 395 | | Fst(n), Fst(nn) 396 | | Snd(n), Snd(nn) -> compare_neut n nn 397 | | Enum_d(n, _, a), Enum_d(nn, _, aa) -> 398 | let cmplazy x y = compare_el (Lazy.force x) (Lazy.force y) in 399 | cmpfold [lazy (compare_neut n nn); 400 | lazy (Enum_map.compare cmplazy a aa)] 401 | | Subst(r, _, d), Subst(rr, _, dd) -> 402 | cmpfold [lazy (compare_neut r rr); lazy (compare_el d dd)] 403 | | Builtin (p, c, n, r), Builtin (p', c', n', r') -> 404 | cmpfold [lazy (compare p p'); 405 | lazy (compare (List.length c) (List.length c')); 406 | lazy (cmpfold (List.map Lazy.from_val (List.map2 compare c c'))); 407 | lazy (compare_neut n n'); 408 | lazy (compare (List.length r) (List.length r')); 409 | lazy (cmpfold (List.map2 (fun x y -> lazy (compare_el x y)) r r'))] 410 | | Local(b, _, _, n, p), Local(b', _, _, n', p') -> 411 | cmpfold [lazy (compare b b'); 412 | lazy (compare_el n n'); 413 | lazy (compare_component p p')] 414 | | Catch(b, _, _, f, p), Catch(b', _, _, f', p') -> 415 | cmpfold [lazy (compare_el b b'); 416 | lazy (compare_el f f'); 417 | lazy (compare_component p p')] 418 | | Range1(n, e), Range1(nn, ee) -> 419 | cmpfold [lazy (compare_neut n nn); 420 | lazy (compare_el e ee)] 421 | | Range2(n, e), Range2(nn, ee) -> 422 | cmpfold [lazy (compare n nn); 423 | lazy (compare_neut e ee)] 424 | | Purify(_, m), Purify(_, m') -> compare_neut m m' 425 | | _ -> 426 | let xx = neut_ordinal x in 427 | let yy = neut_ordinal y in 428 | assert(xx <> yy); 429 | compare xx yy 430 | 431 | and compare_component (a:component) (b:component) :int = 432 | match a, b with 433 | | Component1(n), Component1(n') -> 434 | compare_neut n n' 435 | | Component2(n, f), Component2(n', f') -> 436 | cmpfold [lazy (compare_neut n n'); 437 | lazy (fork compare_el f f')] 438 | | Component3(n, b, f), Component3(n', b', f') -> 439 | cmpfold [lazy (compare_neut n n'); 440 | lazy (compare_el b b'); 441 | lazy (fork compare_el f f')] 442 | | _ -> 443 | let xx = component_ordinal a in 444 | let yy = component_ordinal b in 445 | assert(xx <> yy); 446 | compare xx yy 447 | 448 | and compare_arrays i n ar1 ar2 = 449 | if i = n then 0 450 | else 451 | let t = compare_el (Array.get ar1 i) (Array.get ar2 i) in 452 | if t <> 0 then t 453 | else compare_arrays (i + 1) n ar1 ar2 454 | -------------------------------------------------------------------------------- /var.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Variable of string 3 | | Dummy of int 4 | | Print of int 5 | 6 | let no = Variable "" 7 | 8 | let format : Format.formatter -> t -> unit = 9 | fun f -> 10 | function 11 | | Variable "" -> Format.fprintf f "_" 12 | | Variable s -> Format.fprintf f "%s" s 13 | | Dummy x -> Format.fprintf f "#%d" x 14 | | Print x -> Format.fprintf f "@@%d" x 15 | 16 | let dummy : unit -> t = 17 | let counter = ref 1 in 18 | fun () -> 19 | let result = !counter in 20 | counter := result + 1; 21 | Dummy result 22 | 23 | let counter = ref 1 24 | 25 | let print_dummy () = 26 | let result = !counter in 27 | counter := result + 1; 28 | Print result 29 | 30 | let reset_print () = 31 | counter := 0 32 | 33 | (* TODO: validate format of x. *) 34 | let of_string (x:string) = 35 | assert(x <> ""); 36 | Variable x 37 | -------------------------------------------------------------------------------- /var.mli: -------------------------------------------------------------------------------- 1 | type t 2 | val no :t 3 | val format :Format.formatter -> t -> unit 4 | val dummy :unit -> t 5 | val print_dummy :unit -> t 6 | val reset_print :unit -> unit 7 | val of_string :string -> t 8 | --------------------------------------------------------------------------------