SaplLinkerShared.icl 8.73 KB
Newer Older
1
implementation module Sapl.Linker.SaplLinkerShared
2

3
import StdTuple, StdBool, StdInt, StdFile
4
import Data.Maybe, Text.StringAppender
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
5
from Data.Map import :: Map (..)
6
7
import qualified Data.Map as DM
from Data.Set import :: Set
8
import System.File, System.Directory, Data.Error
9
import Sapl.SaplTokenizer, Sapl.FastString
10

11
12
13
14
from StdList import foldl, removeDup, removeMember, filter, map, hd, tl, isEmpty
from StdArray import class Array(..), instance Array {#} Char
from Data.Set import :: Set, member, insert

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
instance toString LineType
where
	toString (LT_REDIRECT name) = name
	toString (LT_FUNC line _) = line
	toString (LT_MACRO line _) = line	

unpackName (TIdentifier name) = name
unpackName _ = ""

isGlobalFunction name = fst (charIndex name 1 '.') // first char can be skipped safely

// An identifier is a dependency if it contains a "."
generate_dependencies :: [Token] [String] -> [String]
generate_dependencies [TIdentifier name:ts] ds
	= if (isGlobalFunction name) (generate_dependencies ts [name:ds]) (generate_dependencies ts ds)
generate_dependencies [_:ts] ds = generate_dependencies ts ds
generate_dependencies [] ds = ds

read_modules :: [String] FuncTypeMap Warnings !*World -> (FuncTypeMap, Warnings, Maybe String, *World)
read_modules [m:ms] llmap messages world 
	= read_modules_ [m:ms] llmap messages Nothing 0 world
where 
	read_modules_ [m:ms] lmap messages startfn id world 
		# (res, world) = readFileLines m world
		| isOk res
			# (lmap, startfn, id) = foldl read_line (lmap, startfn, id) (fromOk res)
			= read_modules_ ms lmap messages startfn id world
			= read_modules_ ms lmap ["Warning: " +++ m +++ " not found.":messages] startfn id world
		
	read_modules_ [] lmap messages startfn id world = (lmap, messages, startfn, world)

read_module :: !String FuncTypeMap Warnings IdGenerator !*World -> (FuncTypeMap, IdGenerator, Warnings, *World)
read_module m lmap messages id world
	# (res, world) = readFileLines m world
	| isOk res
		# (lmap, startfn, id) = foldl read_line (lmap, Just "dummy", id) (fromOk res)
		= (lmap, id, messages, world)
		= (lmap, id, ["Warning: " +++ m +++ " not found.":messages], world)

/* three kind of lines:
 * :: test_B = test_C a1 | test_D
 * :: test__A = {a, b, c, d, e, f}
 * main a b = ...
 */

read_line (lmap, startfn, id) line 
	# ts = tokens line
	# next = tl ts
	= case hd ts of
			TTypeDef
				# type_name = unpackName (hd next)
				# next = tl next // skip type name	
				# next = tl next // skip "="													
				
				# lmap = case hd next of
70
							TOpenBracket # lmap = 'DM'.put type_name (LT_FUNC line DT_NO_DEPENDENCY) lmap
71
72
73
74
75
										 = parse_record (tl next) type_name lmap // constructors as redirects
										 
										 // For ADTs substitute type name with numeric id (only constructor names used,
										 // and the type name can be identical to one of its constructors name which is not good here)
							_			 # tid = "_"+++toString id
76
										 # lmap = 'DM'.put tid (LT_FUNC line DT_NO_DEPENDENCY) lmap
77
78
79
80
										 = parse_ADT next tid lmap
				= (lmap, startfn, id+1)
									
			(TIdentifier name)
81
				# lmap = case skip_to_definition next of
82
83
84
					[TAssignmentOp, (TIdentifier "StdMisc.undef"):_] // skip functions which are undefined
						= lmap				
					[TAssignmentOp: ts]
85
						= 'DM'.put name (LT_FUNC line (DT_NEED_PROCESS ts)) lmap
86
					[TCAFAssignmentOp: ts]
87
						= 'DM'.put name (LT_FUNC line (DT_NEED_PROCESS ts)) lmap						
88
					[TMacroAssignmentOp: ts]
89
						= 'DM'.put name (LT_MACRO (macroBody ts) (DT_NEED_PROCESS ts)) lmap						
90
91
92
93
94
						= lmap // something wrong with this line: skip it
				= (lmap, if (isNothing startfn && endsWith ".Start" name) (Just name) startfn, id+1)
									   
			_	= (lmap, startfn, id+1) // skip line. e.g. comment
where 
95
96
97
98
	skip_to_definition [TIdentifier _:ts] = skip_to_definition ts
	skip_to_definition [TStrictIdentifier _:ts] = skip_to_definition ts
	skip_to_definition [TTypeDef:ts] = skip_to_definition ts
	skip_to_definition ts = ts
99
100
101
102
103
104
105
106
107
108
109
110
111
	
	macroBody ts = toString (macroBody_ (filter macroTokens ts) newAppender)
	where
		macroBody_ [t] a = a <++ toString t		
		macroBody_ [t:ts] a = a <++ toString t <++ " "		
		macroBody_ [] a = a
		
	macroTokens (TComment _) = False
	macroTokens TEndOfLine = False	
	macroTokens _ = True	
	
// Get contructor names from ADT definition
parse_ADT [(TIdentifier name):ts] fn lmap
112
	= parse_ADT (skip_to_next_const ts) fn ('DM'.put name (LT_REDIRECT fn) lmap)
113
114
115
116
117
118
119
120
121
122
123
124
125
where 
	skip_to_next_const [TVerticalBar:ts] = ts
	skip_to_next_const [_:ts] = skip_to_next_const ts
	skip_to_next_const [] = []	

// This is an incorrect line: skip it
parse_ADT [_:ts] _ lmap
	= lmap

parse_ADT [] _ lmap = lmap

// Get contructor names from record definition
parse_record [TIdentifier name:ts] fn lmap
126
	= parse_record ts fn ('DM'.put name (LT_REDIRECT fn) lmap)
127
128
129
130
131
132
133

// Skip everything else (should be ",")
parse_record [_:ts] fn lmap 
	= parse_record ts fn lmap
	
parse_record [] _ lmap = lmap

134
135
136
137
generate_source :: !FuncTypeMap !SkipSet !(Loader st) !String !StringAppender !*World -> *(!FuncTypeMap, !SkipSet, !(Loader st), !StringAppender, !*World)
generate_source lmap skipset loader=:(lf,ls) fn a world
	# (line, lmap, ls, world) = if (member fn skipset) (Nothing,lmap,ls,world) (lf ls fn lmap world)
	= generate_source_ lmap skipset (lf,ls) fn line a world
138
where 
139
140
	generate_source_ lmap skipset loader fn (Just (LT_REDIRECT name)) a world
		# skipset = insert fn skipset // safe to delete because redirect can't link to macro
141
142
143

		// redirect always redirects to the same module, so it is safe to not
		// to try to load the module
144
		= generate_source_ lmap skipset loader name 
145
				(if (member name skipset) Nothing ('DM'.get name lmap)) a world
146

147
148
	generate_source_ lmap skipset (lf,ls) fn (Just (LT_FUNC line dt)) a world
		# skipset = insert fn skipset
149
		# deps = gendep fn dt
150
		# (lmap, (lf,ls), a, world) = substitute_macros lmap deps (lf,ls) line a world
151
						  
152
153
		= foldl (\(lmap, skipset, loader, a, world) t = generate_source lmap skipset loader t a world) 
															(lmap, skipset, (lf,ls), a, world) deps
154
155
156
	
	// don't delete macros
	// do nothing, macros are substituted
157
158
	generate_source_ lmap skipset loader fn (Just (LT_MACRO _ DT_NO_DEPENDENCY)) a world
		= (lmap, skipset, loader, a, world) 
159
160

	// process macro dependencies only once
161
	generate_source_ lmap skipset loader fn (Just (LT_MACRO body dt)) a world
162
163
		# deps = gendep fn dt
		// macro can't have macro dependency. by design.
164
165
		# (lmap, skipset, loader, a, world) = foldl (\(lmap, skipset, loader, a, world) t = generate_source lmap skipset loader t a world) 
										   (lmap, skipset, loader, a, world) deps
166
		= ('DM'.put fn (LT_MACRO body DT_NO_DEPENDENCY) lmap, skipset, loader, a, world)		
167
168
			
	// try to load the module								
169
170
	generate_source_ lmap skipset loader fn Nothing a world
		= (lmap, skipset, loader, a, world) 
171
172
173
174
175
176
177
178
179
180
181
182
183
184

	gendep fn DT_NO_DEPENDENCY = []
	// Remove cyclyc and duplicate dependencies
	gendep fn (DT_NEED_PROCESS ts) = removeMember fn (removeDup (generate_dependencies ts []))

// [String] : dependencies
load_dependencies :: !FuncTypeMap ![String] ![(String,Maybe LineType)] !(Loader st) *World -> (!FuncTypeMap, ![(String, Maybe LineType)], !(Loader st), !*World)
load_dependencies lmap [m:ms] mlines (lf,ls) world
	# (line, lmap, ls, world) = lf ls m lmap world 
	= load_dependencies lmap ms [(m,line):mlines] (lf,ls) world

load_dependencies lmap [] mlines loader world
	= (lmap, mlines, loader, world)

185
186
substitute_macros :: !FuncTypeMap ![String] !(Loader st) !String !StringAppender !*World  -> (!FuncTypeMap, !(Loader st), !StringAppender, !*World)
substitute_macros lmap deps loader line a world
187
188
189
190
191
192
193
194
195

		// deps: [name], depbodies: [(name, line)]
		# (lmap, depbodies, loader, world) = load_dependencies lmap deps [] loader world
		# macros = map (\(name, Just (LT_MACRO body _))=(name, body)) (filter is_macro depbodies)

		# a = case isEmpty macros of
					True = a <++ line
						 = substitute_macros_ line macros 0 0 a

196
		= (lmap, loader, a, world)
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
	where
		substitute_macros_ line macros base last a
			| base < (size line)
				# (start, newbase, t) = read_token base line
				= case t of
					(TIdentifier name) = case trythem name macros of
											Just body # a = a <++ line % (last, start-1) <++ body
													  =	substitute_macros_ line macros newbase newbase a
													  = substitute_macros_ line macros newbase last a
									   = substitute_macros_ line macros newbase last a
				= a <++ line % (last, size line)
				
		trythem what [(macroname, body): ms]
			| what == macroname 
				= Just body
				= trythem what ms

		trythem _ [] = Nothing

		is_macro (_,(Just (LT_MACRO _ _))) = True
		is_macro _ = False	
				 
219