pygments.rb 0.2.1 → 0.2.2
Sign up to get free protection for your applications and to get access to all the features.
- data/README.md +51 -1
- data/ext/extconf.rb +1 -1
- data/ext/pygments.c +12 -1
- data/lib/pygments/ffi.rb +1 -0
- data/lib/pygments/lexer.rb +1 -1
- data/lib/pygments/version.rb +1 -1
- data/vendor/pygments-main/AUTHORS +3 -0
- data/vendor/pygments-main/CHANGES +5 -0
- data/vendor/pygments-main/REVISION +1 -1
- data/vendor/pygments-main/docs/src/lexerdevelopment.txt +1 -1
- data/vendor/pygments-main/docs/src/styles.txt +1 -1
- data/vendor/pygments-main/pygments/cmdline.py +1 -1
- data/vendor/pygments-main/pygments/formatters/latex.py +1 -1
- data/vendor/pygments-main/pygments/lexers/_mapping.py +4 -1
- data/vendor/pygments-main/pygments/lexers/agile.py +21 -29
- data/vendor/pygments-main/pygments/lexers/functional.py +327 -3
- data/vendor/pygments-main/pygments/lexers/math.py +400 -7
- data/vendor/pygments-main/pygments/lexers/other.py +210 -170
- data/vendor/pygments-main/pygments/lexers/postgres.py +1 -1
- data/vendor/pygments-main/pygments/lexers/pypylog.py +6 -4
- data/vendor/pygments-main/pygments/lexers/web.py +45 -8
- data/vendor/pygments-main/tests/examplefiles/example.sml +156 -0
- data/vendor/pygments-main/tests/examplefiles/intsyn.fun +675 -0
- data/vendor/pygments-main/tests/examplefiles/intsyn.sig +286 -0
- data/vendor/pygments-main/tests/examplefiles/psql_session.txt +1 -0
- data/vendor/pygments-main/tests/examplefiles/test.nim +93 -0
- metadata +10 -6
@@ -234,7 +234,7 @@ re_psql_command = re.compile(r'(\s*)(\\.+?)(\s+)$')
|
|
234
234
|
re_error = re.compile(r'(ERROR|FATAL):')
|
235
235
|
re_message = re.compile(
|
236
236
|
r'((?:DEBUG|INFO|NOTICE|WARNING|ERROR|'
|
237
|
-
r'FATAL|HINT|DETAIL|LINE [0-9]+):)(.*?\n)')
|
237
|
+
r'FATAL|HINT|DETAIL|CONTEXT|LINE [0-9]+):)(.*?\n)')
|
238
238
|
|
239
239
|
def lookahead(x):
|
240
240
|
"""Wrap an iterator and allow pushing back an item."""
|
@@ -49,14 +49,16 @@ class PyPyLogLexer(RegexLexer):
|
|
49
49
|
(r"<.*?>", Name.Builtin),
|
50
50
|
(r"(debug_merge_point|jump|finish)", Name.Class),
|
51
51
|
(r"(int_add_ovf|int_add|int_sub_ovf|int_sub|int_mul_ovf|int_mul|"
|
52
|
-
r"int_mod|int_rshift|int_and|int_or|
|
53
|
-
r"int_gt|int_le|int_lt|int_is_zero|
|
52
|
+
r"int_floordiv|int_mod|int_lshift|int_rshift|int_and|int_or|"
|
53
|
+
r"int_xor|int_eq|int_ne|int_ge|int_gt|int_le|int_lt|int_is_zero|"
|
54
|
+
r"int_is_true|"
|
54
55
|
r"uint_floordiv|uint_ge|uint_lt|"
|
55
56
|
r"float_add|float_sub|float_mul|float_truediv|"
|
56
|
-
r"float_eq|float_ne|float_ge|float_gt|float_le|float_lt|"
|
57
|
+
r"float_eq|float_ne|float_ge|float_gt|float_le|float_lt|float_abs|"
|
57
58
|
r"ptr_eq|"
|
59
|
+
r"cast_int_to_float|cast_float_to_int|cast_opaque_ptr|"
|
58
60
|
r"force_token|quasiimmut_field|same_as|virtual_ref_finish|virtual_ref|"
|
59
|
-
r"call_may_force|call_assembler|call_loopinvariant|call_pure|call|"
|
61
|
+
r"call_may_force|call_assembler|call_loopinvariant|call_release_gil|call_pure|call|"
|
60
62
|
r"new_with_vtable|new_array|newstr|newunicode|new|"
|
61
63
|
r"arraylen_gc|"
|
62
64
|
r"getarrayitem_gc_pure|getarrayitem_gc|setarrayitem_gc|"
|
@@ -68,7 +68,7 @@ class JavascriptLexer(RegexLexer):
|
|
68
68
|
(r'(for|in|while|do|break|return|continue|switch|case|default|if|else|'
|
69
69
|
r'throw|try|catch|finally|new|delete|typeof|instanceof|void|'
|
70
70
|
r'this)\b', Keyword, 'slashstartsregex'),
|
71
|
-
(r'(var|with|function)\b', Keyword.Declaration, 'slashstartsregex'),
|
71
|
+
(r'(var|let|with|function)\b', Keyword.Declaration, 'slashstartsregex'),
|
72
72
|
(r'(abstract|boolean|byte|char|class|const|debugger|double|enum|export|'
|
73
73
|
r'extends|final|float|goto|implements|import|int|interface|long|native|'
|
74
74
|
r'package|private|protected|public|short|static|super|synchronized|throws|'
|
@@ -1716,18 +1716,22 @@ class CoffeeScriptLexer(RegexLexer):
|
|
1716
1716
|
tokens = {
|
1717
1717
|
'commentsandwhitespace': [
|
1718
1718
|
(r'\s+', Text),
|
1719
|
+
(r'###.*?###', Comment.Multiline),
|
1719
1720
|
(r'#.*?\n', Comment.Single),
|
1720
1721
|
],
|
1722
|
+
'multilineregex': [
|
1723
|
+
include('commentsandwhitespace'),
|
1724
|
+
(r'///([gim]+\b|\B)', String.Regex, '#pop'),
|
1725
|
+
(r'/', String.Regex),
|
1726
|
+
(r'[^/#]+', String.Regex)
|
1727
|
+
],
|
1721
1728
|
'slashstartsregex': [
|
1722
1729
|
include('commentsandwhitespace'),
|
1730
|
+
(r'///', String.Regex, ('#pop', 'multilineregex')),
|
1723
1731
|
(r'/(\\.|[^[/\\\n]|\[(\\.|[^\]\\\n])*])+/'
|
1724
1732
|
r'([gim]+\b|\B)', String.Regex, '#pop'),
|
1725
|
-
(r'(?=/)', Text, ('#pop', 'badregex')),
|
1726
1733
|
(r'', Text, '#pop'),
|
1727
1734
|
],
|
1728
|
-
'badregex': [
|
1729
|
-
('\n', Text, '#pop'),
|
1730
|
-
],
|
1731
1735
|
'root': [
|
1732
1736
|
(r'^(?=\s|/|<!--)', Text, 'slashstartsregex'),
|
1733
1737
|
include('commentsandwhitespace'),
|
@@ -1751,13 +1755,46 @@ class CoffeeScriptLexer(RegexLexer):
|
|
1751
1755
|
'slashstartsregex'),
|
1752
1756
|
(r'@[$a-zA-Z_][a-zA-Z0-9_\.:]*\s*[:=]\s', Name.Variable.Instance,
|
1753
1757
|
'slashstartsregex'),
|
1758
|
+
(r'@', Name.Other, 'slashstartsregex'),
|
1754
1759
|
(r'@?[$a-zA-Z_][a-zA-Z0-9_]*', Name.Other, 'slashstartsregex'),
|
1755
1760
|
(r'[0-9][0-9]*\.[0-9]+([eE][0-9]+)?[fd]?', Number.Float),
|
1756
1761
|
(r'0x[0-9a-fA-F]+', Number.Hex),
|
1757
1762
|
(r'[0-9]+', Number.Integer),
|
1758
|
-
(
|
1759
|
-
(
|
1760
|
-
|
1763
|
+
('"""', String, 'tdqs'),
|
1764
|
+
("'''", String, 'tsqs'),
|
1765
|
+
('"', String, 'dqs'),
|
1766
|
+
("'", String, 'sqs'),
|
1767
|
+
],
|
1768
|
+
'strings': [
|
1769
|
+
(r'[^#\\\'"]+', String) # note that all coffee script strings are multi-line.
|
1770
|
+
# hashmarks, quotes and backslashes must be parsed one at a time
|
1771
|
+
],
|
1772
|
+
'interpoling_string' : [
|
1773
|
+
(r'}', String.Interpol, "#pop"),
|
1774
|
+
include('root')
|
1775
|
+
],
|
1776
|
+
'dqs': [
|
1777
|
+
(r'"', String, '#pop'),
|
1778
|
+
(r'\\.|\'', String), # double-quoted string don't need ' escapes
|
1779
|
+
(r'#{', String.Interpol, "interpoling_string"),
|
1780
|
+
include('strings')
|
1781
|
+
],
|
1782
|
+
'sqs': [
|
1783
|
+
(r"'", String, '#pop'),
|
1784
|
+
(r'#|\\.|"', String), # single quoted strings don't need " escapses
|
1785
|
+
include('strings')
|
1786
|
+
],
|
1787
|
+
'tdqs': [
|
1788
|
+
(r'"""', String, '#pop'),
|
1789
|
+
(r'\\.|\'|"', String), # no need to escape quotes in triple-string
|
1790
|
+
(r'#{', String.Interpol, "interpoling_string"),
|
1791
|
+
include('strings'),
|
1792
|
+
],
|
1793
|
+
'tsqs': [
|
1794
|
+
(r"'''", String, '#pop'),
|
1795
|
+
(r'#|\\.|\'|"', String), # no need to escape quotes in triple-strings
|
1796
|
+
include('strings')
|
1797
|
+
],
|
1761
1798
|
}
|
1762
1799
|
|
1763
1800
|
class DuelLexer(RegexLexer):
|
@@ -0,0 +1,156 @@
|
|
1
|
+
structure C = struct
|
2
|
+
val a = 12
|
3
|
+
fun f x = x + 5
|
4
|
+
end
|
5
|
+
|
6
|
+
(*(*(*(*(* This file is all pretty strange Standard ML *)*)*)*) (**)*)
|
7
|
+
(* Robert J. Simmons *)
|
8
|
+
|
9
|
+
(* Comments (* can be nested *) *)
|
10
|
+
structure S = struct
|
11
|
+
val x = (1, 2, "three")
|
12
|
+
end
|
13
|
+
|
14
|
+
structure Sv = struct
|
15
|
+
(* These look good *)
|
16
|
+
val x = (1, 2, "three")
|
17
|
+
val z = #2 x
|
18
|
+
|
19
|
+
(* Although these look bad (not all the numbers are constants), *
|
20
|
+
* they never occur in practice, as they are equivalent to the above. *)
|
21
|
+
val x = {1 = 1, 3 = "three", 2 = 2}
|
22
|
+
val z = #
|
23
|
+
2 x
|
24
|
+
|
25
|
+
val || = 12
|
26
|
+
end
|
27
|
+
|
28
|
+
signature S = sig end
|
29
|
+
|
30
|
+
structure S = struct
|
31
|
+
val x = (1, 2, "three")
|
32
|
+
datatype 'a t = T of 'a
|
33
|
+
and u = U of v * v
|
34
|
+
withtype v = {left: int t, right: int t}
|
35
|
+
exception E1 of int and E2
|
36
|
+
fun 'a id (x: 'a) : 'a = x
|
37
|
+
|
38
|
+
val
|
39
|
+
'a id = fn (x : 'a) => x
|
40
|
+
end
|
41
|
+
|
42
|
+
signature R = sig
|
43
|
+
type t
|
44
|
+
val x : t
|
45
|
+
val f : t * int -> int
|
46
|
+
end
|
47
|
+
structure R : R = struct
|
48
|
+
datatype t = T of int
|
49
|
+
val x : t = T 0
|
50
|
+
fun f (T x, i : int) : int = x + i
|
51
|
+
fun 'a id (x: 'a) : 'a = x
|
52
|
+
end
|
53
|
+
|
54
|
+
signature BA_Z = sig
|
55
|
+
val s: int
|
56
|
+
include S R
|
57
|
+
end
|
58
|
+
|
59
|
+
structure b______ = struct (* What (* A * strange * name *) for ) a ( struct *)
|
60
|
+
|
61
|
+
val !%&$#+-/:<=>?@\~`^|* = 3
|
62
|
+
|
63
|
+
type struct' = int list
|
64
|
+
and 'a sig' = 'a list
|
65
|
+
and ('a, 'b) end' = 'b option * 'a list
|
66
|
+
|
67
|
+
structure baz = struct
|
68
|
+
structure Bar = struct
|
69
|
+
val foo = !%&$#+-/:<=>?@\~`^|*
|
70
|
+
end
|
71
|
+
end
|
72
|
+
|
73
|
+
infixr +!+
|
74
|
+
fun (a +!+ b) = (op +) (a, b)
|
75
|
+
|
76
|
+
open baz S R
|
77
|
+
|
78
|
+
val$$$ = fn x => fn y => fn z => fn w => w
|
79
|
+
val (foo, ++, bar, ||) = (4, baz.Bar.foo, !%&$#+-/:<=>?@\~`^|*, Bar.foo)
|
80
|
+
val _ = $$$foo++bar||
|
81
|
+
|
82
|
+
val val'ue : ' list = []
|
83
|
+
val struct3 : (' -> ') = fn x => x
|
84
|
+
val end_struct_' : ('a -> 'a) = fn x => x
|
85
|
+
val x : (''a -> ''a) = fn x => x
|
86
|
+
val x : ('''' -> '''') = fn x => x
|
87
|
+
val x : unit = print "Weird, huh?\n"
|
88
|
+
val w = {x=1,y=2,##= =3,4=3}
|
89
|
+
val {##=, x, 4=a,...} = w
|
90
|
+
val z = #4 w
|
91
|
+
val z = # ##= w
|
92
|
+
|
93
|
+
fun f x y 0 = 4
|
94
|
+
| f x y z = 4 + Sv.||
|
95
|
+
|
96
|
+
exception Foo of int
|
97
|
+
datatype ('0, 'b, '_, ') f'o'o = Bar | baZ12' | dsfa_fad | #@$ | Bug
|
98
|
+
and (', ''', '''', ''''') bar =
|
99
|
+
Bee of unit
|
100
|
+
| Ben of (', ''', '''', ''''') f'o'o * int
|
101
|
+
| X of ''' list
|
102
|
+
|
103
|
+
fun q x = raise Foo x
|
104
|
+
and h x = raise Foo (~x)
|
105
|
+
|
106
|
+
val x = 4
|
107
|
+
and y = 5
|
108
|
+
|
109
|
+
fun q 0 = 4
|
110
|
+
| q 1 = (case 1 of 1 => 2 | 3 => 4 | x => y)
|
111
|
+
| q y = case y of 1 => 2 | 3 => 4 | x => y
|
112
|
+
|
113
|
+
val x = ref true
|
114
|
+
fun q 0 = 4
|
115
|
+
| q 1 = if false then case 1 of 1 => 2 | 3 => 4 | x => y else 19
|
116
|
+
| q 2 = (while !x handle Match => !x | Fail _ => !x do () ; 2)
|
117
|
+
| q x = (raise Match) handle Domain => 9 | Match => 3
|
118
|
+
|
119
|
+
fun p 0 = 12
|
120
|
+
| p 1 = 8
|
121
|
+
| p 2 = r false
|
122
|
+
| p x = r true
|
123
|
+
and r true = 19
|
124
|
+
| r false = 12
|
125
|
+
|
126
|
+
val _ = 123
|
127
|
+
val _ = 0001
|
128
|
+
val _ = ~123
|
129
|
+
val _ = ~0001
|
130
|
+
val _ = 0w12412
|
131
|
+
val _ = 0w12412
|
132
|
+
val _ = 0xfA0
|
133
|
+
val _ = ~0xfA0
|
134
|
+
val _ = 0wxfA0
|
135
|
+
val _ = 1.4
|
136
|
+
val _ = ~1.4
|
137
|
+
val _ = 1e~2
|
138
|
+
val _ = 1E~2
|
139
|
+
val _ = 1e2
|
140
|
+
val _ = 1E2
|
141
|
+
val _ = 1.4e~2
|
142
|
+
val _ = 1.4E~2
|
143
|
+
val _ = 1.4e2
|
144
|
+
val _ = 1.4E2
|
145
|
+
|
146
|
+
val c = #"\000"
|
147
|
+
val st = "foo \
|
148
|
+
\ bar" ^ "baz \
|
149
|
+
\ and \
|
150
|
+
\ such\n"
|
151
|
+
|
152
|
+
val () = print st
|
153
|
+
|
154
|
+
val _ = foo::bar::4::[++]
|
155
|
+
|
156
|
+
end
|
@@ -0,0 +1,675 @@
|
|
1
|
+
(* Internal Syntax *)
|
2
|
+
(* Author: Frank Pfenning, Carsten Schuermann *)
|
3
|
+
(* Modified: Roberto Virga *)
|
4
|
+
|
5
|
+
functor IntSyn (structure Global : GLOBAL) :> INTSYN =
|
6
|
+
struct
|
7
|
+
|
8
|
+
type cid = int (* Constant identifier *)
|
9
|
+
type name = string (* Variable name *)
|
10
|
+
type mid = int (* Structure identifier *)
|
11
|
+
type csid = int (* CS module identifier *)
|
12
|
+
|
13
|
+
|
14
|
+
(* Contexts *)
|
15
|
+
datatype 'a Ctx = (* Contexts *)
|
16
|
+
Null (* G ::= . *)
|
17
|
+
| Decl of 'a Ctx * 'a (* | G, D *)
|
18
|
+
|
19
|
+
(* ctxPop (G) => G'
|
20
|
+
Invariant: G = G',D
|
21
|
+
*)
|
22
|
+
fun ctxPop (Decl (G, D)) = G
|
23
|
+
|
24
|
+
exception Error of string (* raised if out of space *)
|
25
|
+
(* ctxLookup (G, k) = D, kth declaration in G from right to left
|
26
|
+
Invariant: 1 <= k <= |G|, where |G| is length of G
|
27
|
+
*)
|
28
|
+
|
29
|
+
fun ctxLookup (Decl (G', D), 1) = D
|
30
|
+
| ctxLookup (Decl (G', _), k') = ctxLookup (G', k'-1)
|
31
|
+
(* | ctxLookup (Null, k') = (print ("Looking up k' = " ^ Int.toString k' ^ "\n"); raise Error "Out of Bounce\n")*)
|
32
|
+
(* ctxLookup (Null, k') should not occur by invariant *)
|
33
|
+
|
34
|
+
(* ctxLength G = |G|, the number of declarations in G *)
|
35
|
+
fun ctxLength G =
|
36
|
+
let
|
37
|
+
fun ctxLength' (Null, n) = n
|
38
|
+
| ctxLength' (Decl(G, _), n)= ctxLength' (G, n+1)
|
39
|
+
in
|
40
|
+
ctxLength' (G, 0)
|
41
|
+
end
|
42
|
+
|
43
|
+
type FgnExp = exn (* foreign expression representation *)
|
44
|
+
exception UnexpectedFgnExp of FgnExp
|
45
|
+
(* raised by a constraint solver
|
46
|
+
if passed an incorrect arg *)
|
47
|
+
|
48
|
+
type FgnCnstr = exn (* foreign unification constraint
|
49
|
+
representation *)
|
50
|
+
exception UnexpectedFgnCnstr of FgnCnstr
|
51
|
+
(* raised by a constraint solver
|
52
|
+
if passed an incorrect arg *)
|
53
|
+
|
54
|
+
datatype Depend = (* Dependency information *)
|
55
|
+
No (* P ::= No *)
|
56
|
+
| Maybe (* | Maybe *)
|
57
|
+
| Meta (* | Meta *)
|
58
|
+
|
59
|
+
(* Expressions *)
|
60
|
+
|
61
|
+
datatype Uni = (* Universes: *)
|
62
|
+
Kind (* L ::= Kind *)
|
63
|
+
| Type (* | Type *)
|
64
|
+
|
65
|
+
datatype Exp = (* Expressions: *)
|
66
|
+
Uni of Uni (* U ::= L *)
|
67
|
+
| Pi of (Dec * Depend) * Exp (* | bPi (D, P). V *)
|
68
|
+
| Root of Head * Spine (* | C @ S *)
|
69
|
+
| Redex of Exp * Spine (* | U @ S *)
|
70
|
+
| Lam of Dec * Exp (* | lam D. U *)
|
71
|
+
| EVar of Exp option ref * Dec Ctx * Exp * (Cnstr ref) list ref
|
72
|
+
(* | X<I> : G|-V, Cnstr *)
|
73
|
+
|
74
|
+
| EClo of Exp * Sub (* | U[s] *)
|
75
|
+
| AVar of Exp option ref (* | A<I> *)
|
76
|
+
| NVar of int (* | n (linear, fully applied) *)
|
77
|
+
(* grafting variable *)
|
78
|
+
|
79
|
+
| FgnExp of csid * FgnExp
|
80
|
+
(* | (foreign expression) *)
|
81
|
+
|
82
|
+
and Head = (* Heads: *)
|
83
|
+
BVar of int (* H ::= k *)
|
84
|
+
| Const of cid (* | c *)
|
85
|
+
| Proj of Block * int (* | #k(b) *)
|
86
|
+
| Skonst of cid (* | c# *)
|
87
|
+
| Def of cid (* | d *)
|
88
|
+
| NSDef of cid (* | d (non strict) *)
|
89
|
+
| FVar of name * Exp * Sub (* | F[s] *)
|
90
|
+
| FgnConst of csid * ConDec (* | (foreign constant) *)
|
91
|
+
|
92
|
+
and Spine = (* Spines: *)
|
93
|
+
Nil (* S ::= Nil *)
|
94
|
+
| App of Exp * Spine (* | U ; S *)
|
95
|
+
| SClo of Spine * Sub (* | S[s] *)
|
96
|
+
|
97
|
+
and Sub = (* Explicit substitutions: *)
|
98
|
+
Shift of int (* s ::= ^n *)
|
99
|
+
| Dot of Front * Sub (* | Ft.s *)
|
100
|
+
|
101
|
+
and Front = (* Fronts: *)
|
102
|
+
Idx of int (* Ft ::= k *)
|
103
|
+
| Exp of Exp (* | U *)
|
104
|
+
| Axp of Exp (* | U (assignable) *)
|
105
|
+
| Block of Block (* | _x *)
|
106
|
+
| Undef (* | _ *)
|
107
|
+
|
108
|
+
and Dec = (* Declarations: *)
|
109
|
+
Dec of name option * Exp (* D ::= x:V *)
|
110
|
+
| BDec of name option * (cid * Sub) (* | v:l[s] *)
|
111
|
+
| ADec of name option * int (* | v[^-d] *)
|
112
|
+
| NDec of name option
|
113
|
+
|
114
|
+
and Block = (* Blocks: *)
|
115
|
+
Bidx of int (* b ::= v *)
|
116
|
+
| LVar of Block option ref * Sub * (cid * Sub)
|
117
|
+
(* | L(l[^k],t) *)
|
118
|
+
| Inst of Exp list (* | u1, ..., Un *)
|
119
|
+
|
120
|
+
|
121
|
+
(* Constraints *)
|
122
|
+
|
123
|
+
and Cnstr = (* Constraint: *)
|
124
|
+
Solved (* Cnstr ::= solved *)
|
125
|
+
| Eqn of Dec Ctx * Exp * Exp (* | G|-(U1 == U2) *)
|
126
|
+
| FgnCnstr of csid * FgnCnstr (* | (foreign) *)
|
127
|
+
|
128
|
+
and Status = (* Status of a constant: *)
|
129
|
+
Normal (* inert *)
|
130
|
+
| Constraint of csid * (Dec Ctx * Spine * int -> Exp option)
|
131
|
+
(* acts as constraint *)
|
132
|
+
| Foreign of csid * (Spine -> Exp) (* is converted to foreign *)
|
133
|
+
|
134
|
+
and FgnUnify = (* Result of foreign unify *)
|
135
|
+
Succeed of FgnUnifyResidual list
|
136
|
+
(* succeed with a list of residual operations *)
|
137
|
+
| Fail
|
138
|
+
|
139
|
+
and FgnUnifyResidual = (* Residual of foreign unify *)
|
140
|
+
Assign of Dec Ctx * Exp * Exp * Sub
|
141
|
+
(* perform the assignment G |- X = U [ss] *)
|
142
|
+
| Delay of Exp * Cnstr ref
|
143
|
+
(* delay cnstr, associating it with all the rigid EVars in U *)
|
144
|
+
|
145
|
+
(* Global signature *)
|
146
|
+
|
147
|
+
and ConDec = (* Constant declaration *)
|
148
|
+
ConDec of string * mid option * int * Status
|
149
|
+
(* a : K : kind or *)
|
150
|
+
* Exp * Uni (* c : A : type *)
|
151
|
+
| ConDef of string * mid option * int (* a = A : K : kind or *)
|
152
|
+
* Exp * Exp * Uni (* d = M : A : type *)
|
153
|
+
* Ancestor (* Ancestor info for d or a *)
|
154
|
+
| AbbrevDef of string * mid option * int
|
155
|
+
(* a = A : K : kind or *)
|
156
|
+
* Exp * Exp * Uni (* d = M : A : type *)
|
157
|
+
| BlockDec of string * mid option (* %block l : SOME G1 PI G2 *)
|
158
|
+
* Dec Ctx * Dec list
|
159
|
+
|
160
|
+
| BlockDef of string * mid option * cid list
|
161
|
+
(* %block l = (l1 | ... | ln) *)
|
162
|
+
|
163
|
+
| SkoDec of string * mid option * int (* sa: K : kind or *)
|
164
|
+
* Exp * Uni (* sc: A : type *)
|
165
|
+
|
166
|
+
and Ancestor = (* Ancestor of d or a *)
|
167
|
+
Anc of cid option * int * cid option (* head(expand(d)), height, head(expand[height](d)) *)
|
168
|
+
(* NONE means expands to {x:A}B *)
|
169
|
+
|
170
|
+
datatype StrDec = (* Structure declaration *)
|
171
|
+
StrDec of string * mid option
|
172
|
+
|
173
|
+
(* Form of constant declaration *)
|
174
|
+
datatype ConDecForm =
|
175
|
+
FromCS (* from constraint domain *)
|
176
|
+
| Ordinary (* ordinary declaration *)
|
177
|
+
| Clause (* %clause declaration *)
|
178
|
+
|
179
|
+
(* Type abbreviations *)
|
180
|
+
type dctx = Dec Ctx (* G = . | G,D *)
|
181
|
+
type eclo = Exp * Sub (* Us = U[s] *)
|
182
|
+
type bclo = Block * Sub (* Bs = B[s] *)
|
183
|
+
type cnstr = Cnstr ref
|
184
|
+
|
185
|
+
(* exception Error of string (* raised if out of space *) *)
|
186
|
+
|
187
|
+
|
188
|
+
structure FgnExpStd = struct
|
189
|
+
|
190
|
+
structure ToInternal = FgnOpnTable (type arg = unit
|
191
|
+
type result = Exp)
|
192
|
+
|
193
|
+
structure Map = FgnOpnTable (type arg = Exp -> Exp
|
194
|
+
type result = Exp)
|
195
|
+
|
196
|
+
structure App = FgnOpnTable (type arg = Exp -> unit
|
197
|
+
type result = unit)
|
198
|
+
|
199
|
+
structure EqualTo = FgnOpnTable (type arg = Exp
|
200
|
+
type result = bool)
|
201
|
+
|
202
|
+
structure UnifyWith = FgnOpnTable (type arg = Dec Ctx * Exp
|
203
|
+
type result = FgnUnify)
|
204
|
+
|
205
|
+
|
206
|
+
|
207
|
+
fun fold csfe f b = let
|
208
|
+
val r = ref b
|
209
|
+
fun g U = r := f (U,!r)
|
210
|
+
in
|
211
|
+
App.apply csfe g ; !r
|
212
|
+
end
|
213
|
+
|
214
|
+
end
|
215
|
+
|
216
|
+
structure FgnCnstrStd = struct
|
217
|
+
|
218
|
+
structure ToInternal = FgnOpnTable (type arg = unit
|
219
|
+
type result = (Dec Ctx * Exp) list)
|
220
|
+
|
221
|
+
structure Awake = FgnOpnTable (type arg = unit
|
222
|
+
type result = bool)
|
223
|
+
|
224
|
+
structure Simplify = FgnOpnTable (type arg = unit
|
225
|
+
type result = bool)
|
226
|
+
|
227
|
+
end
|
228
|
+
|
229
|
+
fun conDecName (ConDec (name, _, _, _, _, _)) = name
|
230
|
+
| conDecName (ConDef (name, _, _, _, _, _, _)) = name
|
231
|
+
| conDecName (AbbrevDef (name, _, _, _, _, _)) = name
|
232
|
+
| conDecName (SkoDec (name, _, _, _, _)) = name
|
233
|
+
| conDecName (BlockDec (name, _, _, _)) = name
|
234
|
+
| conDecName (BlockDef (name, _, _)) = name
|
235
|
+
|
236
|
+
fun conDecParent (ConDec (_, parent, _, _, _, _)) = parent
|
237
|
+
| conDecParent (ConDef (_, parent, _, _, _, _, _)) = parent
|
238
|
+
| conDecParent (AbbrevDef (_, parent, _, _, _, _)) = parent
|
239
|
+
| conDecParent (SkoDec (_, parent, _, _, _)) = parent
|
240
|
+
| conDecParent (BlockDec (_, parent, _, _)) = parent
|
241
|
+
| conDecParent (BlockDef (_, parent, _)) = parent
|
242
|
+
|
243
|
+
|
244
|
+
(* conDecImp (CD) = k
|
245
|
+
|
246
|
+
Invariant:
|
247
|
+
If CD is either a declaration, definition, abbreviation, or
|
248
|
+
a Skolem constant
|
249
|
+
then k stands for the number of implicit elements.
|
250
|
+
*)
|
251
|
+
fun conDecImp (ConDec (_, _, i, _, _, _)) = i
|
252
|
+
| conDecImp (ConDef (_, _, i, _, _, _, _)) = i
|
253
|
+
| conDecImp (AbbrevDef (_, _, i, _, _, _)) = i
|
254
|
+
| conDecImp (SkoDec (_, _, i, _, _)) = i
|
255
|
+
| conDecImp (BlockDec (_, _, _, _)) = 0 (* watch out -- carsten *)
|
256
|
+
|
257
|
+
fun conDecStatus (ConDec (_, _, _, status, _, _)) = status
|
258
|
+
| conDecStatus _ = Normal
|
259
|
+
|
260
|
+
(* conDecType (CD) = V
|
261
|
+
|
262
|
+
Invariant:
|
263
|
+
If CD is either a declaration, definition, abbreviation, or
|
264
|
+
a Skolem constant
|
265
|
+
then V is the respective type
|
266
|
+
*)
|
267
|
+
fun conDecType (ConDec (_, _, _, _, V, _)) = V
|
268
|
+
| conDecType (ConDef (_, _, _, _, V, _, _)) = V
|
269
|
+
| conDecType (AbbrevDef (_, _, _, _, V, _)) = V
|
270
|
+
| conDecType (SkoDec (_, _, _, V, _)) = V
|
271
|
+
|
272
|
+
|
273
|
+
(* conDecBlock (CD) = (Gsome, Lpi)
|
274
|
+
|
275
|
+
Invariant:
|
276
|
+
If CD is block definition
|
277
|
+
then Gsome is the context of some variables
|
278
|
+
and Lpi is the list of pi variables
|
279
|
+
*)
|
280
|
+
fun conDecBlock (BlockDec (_, _, Gsome, Lpi)) = (Gsome, Lpi)
|
281
|
+
|
282
|
+
(* conDecUni (CD) = L
|
283
|
+
|
284
|
+
Invariant:
|
285
|
+
If CD is either a declaration, definition, abbreviation, or
|
286
|
+
a Skolem constant
|
287
|
+
then L is the respective universe
|
288
|
+
*)
|
289
|
+
fun conDecUni (ConDec (_, _, _, _, _, L)) = L
|
290
|
+
| conDecUni (ConDef (_, _, _, _, _, L, _)) = L
|
291
|
+
| conDecUni (AbbrevDef (_, _, _, _, _, L)) = L
|
292
|
+
| conDecUni (SkoDec (_, _, _, _, L)) = L
|
293
|
+
|
294
|
+
|
295
|
+
fun strDecName (StrDec (name, _)) = name
|
296
|
+
|
297
|
+
fun strDecParent (StrDec (_, parent)) = parent
|
298
|
+
|
299
|
+
local
|
300
|
+
val maxCid = Global.maxCid
|
301
|
+
val dummyEntry = ConDec("", NONE, 0, Normal, Uni (Kind), Kind)
|
302
|
+
val sgnArray = Array.array (maxCid+1, dummyEntry)
|
303
|
+
: ConDec Array.array
|
304
|
+
val nextCid = ref(0)
|
305
|
+
|
306
|
+
val maxMid = Global.maxMid
|
307
|
+
val sgnStructArray = Array.array (maxMid+1, StrDec("", NONE))
|
308
|
+
: StrDec Array.array
|
309
|
+
val nextMid = ref (0)
|
310
|
+
|
311
|
+
in
|
312
|
+
(* Invariants *)
|
313
|
+
(* Constant declarations are all well-typed *)
|
314
|
+
(* Constant declarations are stored in beta-normal form *)
|
315
|
+
(* All definitions are strict in all their arguments *)
|
316
|
+
(* If Const(cid) is valid, then sgnArray(cid) = ConDec _ *)
|
317
|
+
(* If Def(cid) is valid, then sgnArray(cid) = ConDef _ *)
|
318
|
+
|
319
|
+
fun sgnClean (i) = if i >= !nextCid then ()
|
320
|
+
else (Array.update (sgnArray, i, dummyEntry);
|
321
|
+
sgnClean (i+1))
|
322
|
+
|
323
|
+
fun sgnReset () = ((* Fri Dec 20 12:04:24 2002 -fp *)
|
324
|
+
(* this circumvents a space leak *)
|
325
|
+
sgnClean (0);
|
326
|
+
nextCid := 0; nextMid := 0)
|
327
|
+
fun sgnSize () = (!nextCid, !nextMid)
|
328
|
+
|
329
|
+
fun sgnAdd (conDec) =
|
330
|
+
let
|
331
|
+
val cid = !nextCid
|
332
|
+
in
|
333
|
+
if cid > maxCid
|
334
|
+
then raise Error ("Global signature size " ^ Int.toString (maxCid+1) ^ " exceeded")
|
335
|
+
else (Array.update (sgnArray, cid, conDec) ;
|
336
|
+
nextCid := cid + 1;
|
337
|
+
cid)
|
338
|
+
end
|
339
|
+
|
340
|
+
(* 0 <= cid < !nextCid *)
|
341
|
+
fun sgnLookup (cid) = Array.sub (sgnArray, cid)
|
342
|
+
|
343
|
+
fun sgnApp (f) =
|
344
|
+
let
|
345
|
+
fun sgnApp' (cid) =
|
346
|
+
if cid = !nextCid then () else (f cid; sgnApp' (cid+1))
|
347
|
+
in
|
348
|
+
sgnApp' (0)
|
349
|
+
end
|
350
|
+
|
351
|
+
fun sgnStructAdd (strDec) =
|
352
|
+
let
|
353
|
+
val mid = !nextMid
|
354
|
+
in
|
355
|
+
if mid > maxMid
|
356
|
+
then raise Error ("Global signature size " ^ Int.toString (maxMid+1) ^ " exceeded")
|
357
|
+
else (Array.update (sgnStructArray, mid, strDec) ;
|
358
|
+
nextMid := mid + 1;
|
359
|
+
mid)
|
360
|
+
end
|
361
|
+
|
362
|
+
(* 0 <= mid < !nextMid *)
|
363
|
+
fun sgnStructLookup (mid) = Array.sub (sgnStructArray, mid)
|
364
|
+
|
365
|
+
(* A hack used in Flit - jcreed 6/05 *)
|
366
|
+
fun rename (cid, new) =
|
367
|
+
let
|
368
|
+
val newConDec = case sgnLookup cid of
|
369
|
+
ConDec (n,m,i,s,e,u) => ConDec(new,m,i,s,e,u)
|
370
|
+
| ConDef (n,m,i,e,e',u,a) => ConDef(new,m,i,e,e',u,a)
|
371
|
+
| AbbrevDef (n,m,i,e,e',u) => AbbrevDef (new,m,i,e,e',u)
|
372
|
+
| BlockDec (n,m,d,d') => BlockDec (new,m,d,d')
|
373
|
+
| SkoDec (n,m,i,e,u) => SkoDec (new,m,i,e,u)
|
374
|
+
in
|
375
|
+
Array.update (sgnArray, cid, newConDec)
|
376
|
+
end
|
377
|
+
|
378
|
+
end
|
379
|
+
|
380
|
+
fun constDef (d) =
|
381
|
+
(case sgnLookup (d)
|
382
|
+
of ConDef(_, _, _, U,_, _, _) => U
|
383
|
+
| AbbrevDef (_, _, _, U,_, _) => U)
|
384
|
+
|
385
|
+
fun constType (c) = conDecType (sgnLookup c)
|
386
|
+
fun constImp (c) = conDecImp (sgnLookup c)
|
387
|
+
fun constUni (c) = conDecUni (sgnLookup c)
|
388
|
+
fun constBlock (c) = conDecBlock (sgnLookup c)
|
389
|
+
|
390
|
+
fun constStatus (c) =
|
391
|
+
(case sgnLookup (c)
|
392
|
+
of ConDec (_, _, _, status, _, _) => status
|
393
|
+
| _ => Normal)
|
394
|
+
|
395
|
+
|
396
|
+
(* Explicit Substitutions *)
|
397
|
+
|
398
|
+
(* id = ^0
|
399
|
+
|
400
|
+
Invariant:
|
401
|
+
G |- id : G id is patsub
|
402
|
+
*)
|
403
|
+
val id = Shift(0)
|
404
|
+
|
405
|
+
(* shift = ^1
|
406
|
+
|
407
|
+
Invariant:
|
408
|
+
G, V |- ^ : G ^ is patsub
|
409
|
+
*)
|
410
|
+
val shift = Shift(1)
|
411
|
+
|
412
|
+
(* invShift = ^-1 = _.^0
|
413
|
+
Invariant:
|
414
|
+
G |- ^-1 : G, V ^-1 is patsub
|
415
|
+
*)
|
416
|
+
val invShift = Dot(Undef, id)
|
417
|
+
|
418
|
+
|
419
|
+
(* comp (s1, s2) = s'
|
420
|
+
|
421
|
+
Invariant:
|
422
|
+
If G' |- s1 : G
|
423
|
+
and G'' |- s2 : G'
|
424
|
+
then s' = s1 o s2
|
425
|
+
and G'' |- s1 o s2 : G
|
426
|
+
|
427
|
+
If s1, s2 patsub
|
428
|
+
then s' patsub
|
429
|
+
*)
|
430
|
+
fun comp (Shift (0), s) = s
|
431
|
+
(* next line is an optimization *)
|
432
|
+
(* roughly 15% on standard suite for Twelf 1.1 *)
|
433
|
+
(* Sat Feb 14 10:15:16 1998 -fp *)
|
434
|
+
| comp (s, Shift (0)) = s
|
435
|
+
| comp (Shift (n), Dot (Ft, s)) = comp (Shift (n-1), s)
|
436
|
+
| comp (Shift (n), Shift (m)) = Shift (n+m)
|
437
|
+
| comp (Dot (Ft, s), s') = Dot (frontSub (Ft, s'), comp (s, s'))
|
438
|
+
|
439
|
+
(* bvarSub (n, s) = Ft'
|
440
|
+
|
441
|
+
Invariant:
|
442
|
+
If G |- s : G' G' |- n : V
|
443
|
+
then Ft' = Ftn if s = Ft1 .. Ftn .. ^k
|
444
|
+
or Ft' = ^(n+k) if s = Ft1 .. Ftm ^k and m<n
|
445
|
+
and G |- Ft' : V [s]
|
446
|
+
*)
|
447
|
+
and bvarSub (1, Dot(Ft, s)) = Ft
|
448
|
+
| bvarSub (n, Dot(Ft, s)) = bvarSub (n-1, s)
|
449
|
+
| bvarSub (n, Shift(k)) = Idx (n+k)
|
450
|
+
|
451
|
+
(* blockSub (B, s) = B'
|
452
|
+
|
453
|
+
Invariant:
|
454
|
+
If G |- s : G'
|
455
|
+
and G' |- B block
|
456
|
+
then G |- B' block
|
457
|
+
and B [s] == B'
|
458
|
+
*)
|
459
|
+
(* in front of substitutions, first case is irrelevant *)
|
460
|
+
(* Sun Dec 2 11:56:41 2001 -fp *)
|
461
|
+
and blockSub (Bidx k, s) =
|
462
|
+
(case bvarSub (k, s)
|
463
|
+
of Idx k' => Bidx k'
|
464
|
+
| Block B => B)
|
465
|
+
| blockSub (LVar (ref (SOME B), sk, _), s) =
|
466
|
+
blockSub (B, comp (sk, s))
|
467
|
+
(* -fp Sun Dec 1 21:18:30 2002 *)
|
468
|
+
(* --cs Sun Dec 1 11:25:41 2002 *)
|
469
|
+
(* Since always . |- t : Gsome, discard s *)
|
470
|
+
(* where is this needed? *)
|
471
|
+
(* Thu Dec 6 20:30:26 2001 -fp !!! *)
|
472
|
+
| blockSub (LVar (r as ref NONE, sk, (l, t)), s) =
|
473
|
+
LVar(r, comp(sk, s), (l, t))
|
474
|
+
(* was:
|
475
|
+
LVar (r, comp(sk, s), (l, comp (t, s)))
|
476
|
+
July 22, 2010 -fp -cs
|
477
|
+
*)
|
478
|
+
(* comp(^k, s) = ^k' for some k' by invariant *)
|
479
|
+
| blockSub (L as Inst ULs, s') = Inst (map (fn U => EClo (U, s')) ULs)
|
480
|
+
(* this should be right but somebody should verify *)
|
481
|
+
|
482
|
+
(* frontSub (Ft, s) = Ft'
|
483
|
+
|
484
|
+
Invariant:
|
485
|
+
If G |- s : G' G' |- Ft : V
|
486
|
+
then Ft' = Ft [s]
|
487
|
+
and G |- Ft' : V [s]
|
488
|
+
|
489
|
+
NOTE: EClo (U, s) might be undefined, so if this is ever
|
490
|
+
computed eagerly, we must introduce an "Undefined" exception,
|
491
|
+
raise it in whnf and handle it here so Exp (EClo (U, s)) => Undef
|
492
|
+
*)
|
493
|
+
and frontSub (Idx (n), s) = bvarSub (n, s)
|
494
|
+
| frontSub (Exp (U), s) = Exp (EClo (U, s))
|
495
|
+
| frontSub (Undef, s) = Undef
|
496
|
+
| frontSub (Block (B), s) = Block (blockSub (B, s))
|
497
|
+
|
498
|
+
(* decSub (x:V, s) = D'
|
499
|
+
|
500
|
+
Invariant:
|
501
|
+
If G |- s : G' G' |- V : L
|
502
|
+
then D' = x:V[s]
|
503
|
+
and G |- V[s] : L
|
504
|
+
*)
|
505
|
+
(* First line is an optimization suggested by cs *)
|
506
|
+
(* D[id] = D *)
|
507
|
+
(* Sat Feb 14 18:37:44 1998 -fp *)
|
508
|
+
(* seems to have no statistically significant effect *)
|
509
|
+
(* undo for now Sat Feb 14 20:22:29 1998 -fp *)
|
510
|
+
(*
|
511
|
+
fun decSub (D, Shift(0)) = D
|
512
|
+
| decSub (Dec (x, V), s) = Dec (x, EClo (V, s))
|
513
|
+
*)
|
514
|
+
fun decSub (Dec (x, V), s) = Dec (x, EClo (V, s))
|
515
|
+
| decSub (NDec x, s) = NDec x
|
516
|
+
| decSub (BDec (n, (l, t)), s) = BDec (n, (l, comp (t, s)))
|
517
|
+
|
518
|
+
(* dot1 (s) = s'
|
519
|
+
|
520
|
+
Invariant:
|
521
|
+
If G |- s : G'
|
522
|
+
then s' = 1. (s o ^)
|
523
|
+
and for all V s.t. G' |- V : L
|
524
|
+
G, V[s] |- s' : G', V
|
525
|
+
|
526
|
+
If s patsub then s' patsub
|
527
|
+
*)
|
528
|
+
(* first line is an optimization *)
|
529
|
+
(* roughly 15% on standard suite for Twelf 1.1 *)
|
530
|
+
(* Sat Feb 14 10:16:16 1998 -fp *)
|
531
|
+
fun dot1 (s as Shift (0)) = s
|
532
|
+
| dot1 s = Dot (Idx(1), comp(s, shift))
|
533
|
+
|
534
|
+
(* invDot1 (s) = s'
|
535
|
+
invDot1 (1. s' o ^) = s'
|
536
|
+
|
537
|
+
Invariant:
|
538
|
+
s = 1 . s' o ^
|
539
|
+
If G' |- s' : G
|
540
|
+
(so G',V[s] |- s : G,V)
|
541
|
+
*)
|
542
|
+
fun invDot1 (s) = comp (comp(shift, s), invShift)
|
543
|
+
|
544
|
+
|
545
|
+
(* Declaration Contexts *)
|
546
|
+
|
547
|
+
(* ctxDec (G, k) = x:V
|
548
|
+
Invariant:
|
549
|
+
If |G| >= k, where |G| is size of G,
|
550
|
+
then G |- k : V and G |- V : L
|
551
|
+
*)
|
552
|
+
fun ctxDec (G, k) =
|
553
|
+
let (* ctxDec' (G'', k') = x:V
|
554
|
+
where G |- ^(k-k') : G'', 1 <= k' <= k
|
555
|
+
*)
|
556
|
+
fun ctxDec' (Decl (G', Dec (x, V')), 1) = Dec (x, EClo (V', Shift (k)))
|
557
|
+
| ctxDec' (Decl (G', BDec (n, (l, s))), 1) = BDec (n, (l, comp (s, Shift (k))))
|
558
|
+
| ctxDec' (Decl (G', _), k') = ctxDec' (G', k'-1)
|
559
|
+
(* ctxDec' (Null, k') should not occur by invariant *)
|
560
|
+
in
|
561
|
+
ctxDec' (G, k)
|
562
|
+
end
|
563
|
+
|
564
|
+
(* blockDec (G, v, i) = V
|
565
|
+
|
566
|
+
Invariant:
|
567
|
+
If G (v) = l[s]
|
568
|
+
and Sigma (l) = SOME Gsome BLOCK Lblock
|
569
|
+
and G |- s : Gsome
|
570
|
+
then G |- pi (v, i) : V
|
571
|
+
*)
|
572
|
+
|
573
|
+
fun blockDec (G, v as (Bidx k), i) =
|
574
|
+
let
|
575
|
+
val BDec (_, (l, s)) = ctxDec (G, k)
|
576
|
+
(* G |- s : Gsome *)
|
577
|
+
val (Gsome, Lblock) = conDecBlock (sgnLookup l)
|
578
|
+
fun blockDec' (t, D :: L, 1, j) = decSub (D, t)
|
579
|
+
| blockDec' (t, _ :: L, n, j) =
|
580
|
+
blockDec' (Dot (Exp (Root (Proj (v, j), Nil)), t),
|
581
|
+
L, n-1, j+1)
|
582
|
+
in
|
583
|
+
blockDec' (s, Lblock, i, 1)
|
584
|
+
end
|
585
|
+
|
586
|
+
|
587
|
+
(* EVar related functions *)
|
588
|
+
|
589
|
+
(* newEVar (G, V) = newEVarCnstr (G, V, nil) *)
|
590
|
+
fun newEVar (G, V) = EVar(ref NONE, G, V, ref nil)
|
591
|
+
|
592
|
+
(* newAVar G = new AVar (assignable variable) *)
|
593
|
+
(* AVars carry no type, ctx, or cnstr *)
|
594
|
+
fun newAVar () = AVar(ref NONE)
|
595
|
+
|
596
|
+
(* newTypeVar (G) = X, X new
|
597
|
+
where G |- X : type
|
598
|
+
*)
|
599
|
+
fun newTypeVar (G) = EVar(ref NONE, G, Uni(Type), ref nil)
|
600
|
+
|
601
|
+
(* newLVar (l, s) = (l[s]) *)
|
602
|
+
fun newLVar (sk, (cid, t)) = LVar (ref NONE, sk, (cid, t))
|
603
|
+
|
604
|
+
(* Definition related functions *)
|
605
|
+
(* headOpt (U) = SOME(H) or NONE, U should be strict, normal *)
|
606
|
+
fun headOpt (Root (H, _)) = SOME(H)
|
607
|
+
| headOpt (Lam (_, U)) = headOpt U
|
608
|
+
| headOpt _ = NONE
|
609
|
+
|
610
|
+
fun ancestor' (NONE) = Anc(NONE, 0, NONE)
|
611
|
+
| ancestor' (SOME(Const(c))) = Anc(SOME(c), 1, SOME(c))
|
612
|
+
| ancestor' (SOME(Def(d))) =
|
613
|
+
(case sgnLookup(d)
|
614
|
+
of ConDef(_, _, _, _, _, _, Anc(_, height, cOpt))
|
615
|
+
=> Anc(SOME(d), height+1, cOpt))
|
616
|
+
| ancestor' (SOME _) = (* FgnConst possible, BVar impossible by strictness *)
|
617
|
+
Anc(NONE, 0, NONE)
|
618
|
+
(* ancestor(U) = ancestor info for d = U *)
|
619
|
+
fun ancestor (U) = ancestor' (headOpt U)
|
620
|
+
|
621
|
+
(* defAncestor(d) = ancestor of d, d must be defined *)
|
622
|
+
fun defAncestor (d) =
|
623
|
+
(case sgnLookup(d)
|
624
|
+
of ConDef(_, _, _, _, _, _, anc) => anc)
|
625
|
+
|
626
|
+
(* Type related functions *)
|
627
|
+
|
628
|
+
(* targetHeadOpt (V) = SOME(H) or NONE
|
629
|
+
where H is the head of the atomic target type of V,
|
630
|
+
NONE if V is a kind or object or have variable type.
|
631
|
+
Does not expand type definitions.
|
632
|
+
*)
|
633
|
+
(* should there possibly be a FgnConst case? also targetFamOpt -kw *)
|
634
|
+
fun targetHeadOpt (Root (H, _)) = SOME(H)
|
635
|
+
| targetHeadOpt (Pi(_, V)) = targetHeadOpt V
|
636
|
+
| targetHeadOpt (Redex (V, S)) = targetHeadOpt V
|
637
|
+
| targetHeadOpt (Lam (_, V)) = targetHeadOpt V
|
638
|
+
| targetHeadOpt (EVar (ref (SOME(V)),_,_,_)) = targetHeadOpt V
|
639
|
+
| targetHeadOpt (EClo (V, s)) = targetHeadOpt V
|
640
|
+
| targetHeadOpt _ = NONE
|
641
|
+
(* Root(Bvar _, _), Root(FVar _, _), Root(FgnConst _, _),
|
642
|
+
EVar(ref NONE,..), Uni, FgnExp _
|
643
|
+
*)
|
644
|
+
(* Root(Skonst _, _) can't occur *)
|
645
|
+
(* targetHead (A) = a
|
646
|
+
as in targetHeadOpt, except V must be a valid type
|
647
|
+
*)
|
648
|
+
fun targetHead (A) = valOf (targetHeadOpt A)
|
649
|
+
|
650
|
+
(* targetFamOpt (V) = SOME(cid) or NONE
|
651
|
+
where cid is the type family of the atomic target type of V,
|
652
|
+
NONE if V is a kind or object or have variable type.
|
653
|
+
Does expand type definitions.
|
654
|
+
*)
|
655
|
+
fun targetFamOpt (Root (Const(cid), _)) = SOME(cid)
|
656
|
+
| targetFamOpt (Pi(_, V)) = targetFamOpt V
|
657
|
+
| targetFamOpt (Root (Def(cid), _)) = targetFamOpt (constDef cid)
|
658
|
+
| targetFamOpt (Redex (V, S)) = targetFamOpt V
|
659
|
+
| targetFamOpt (Lam (_, V)) = targetFamOpt V
|
660
|
+
| targetFamOpt (EVar (ref (SOME(V)),_,_,_)) = targetFamOpt V
|
661
|
+
| targetFamOpt (EClo (V, s)) = targetFamOpt V
|
662
|
+
| targetFamOpt _ = NONE
|
663
|
+
(* Root(Bvar _, _), Root(FVar _, _), Root(FgnConst _, _),
|
664
|
+
EVar(ref NONE,..), Uni, FgnExp _
|
665
|
+
*)
|
666
|
+
(* Root(Skonst _, _) can't occur *)
|
667
|
+
(* targetFam (A) = a
|
668
|
+
as in targetFamOpt, except V must be a valid type
|
669
|
+
*)
|
670
|
+
fun targetFam (A) = valOf (targetFamOpt A)
|
671
|
+
|
672
|
+
end; (* functor IntSyn *)
|
673
|
+
|
674
|
+
structure IntSyn :> INTSYN =
|
675
|
+
IntSyn (structure Global = Global);
|