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