WebSVN – Kolibri OS – Blame – /programs/develop/oberon07/Source/PROG.ob07

Rev	Author	Line No.	Line
7597	akron1	1	(*
		2	BSD 2-Clause License
		3
		4	Copyright (c) 2018, 2019, Anton Krotov
		5	All rights reserved.
		6	*)
		7
		8	MODULE PROG;
		9
		10	IMPORT SCAN, LISTS, ARITH, ERRORS, MACHINE, C := COLLECTIONS, mConst := CONSTANTS, CODE, UTILS;
		11
		12
		13	CONST
		14
		15	MAXARRDIM* = 5;
		16	MAXSCOPE = 16;
		17	MAXSYSVPARAM* = 26;
		18
		19	idNONE* = 0; idGUARD = 1; idMODULE* = 2; idCONST* = 3;
		20	idTYPE* = 4; idSTFUNC* = 5; idSTPROC* = 6; idVAR* = 7;
		21	idPROC* = 8; idVPAR* = 9; idPARAM* = 10; idSYSFUNC* = 11;
		22	idSYSPROC* = 12; idIMP* = 13;
		23
		24	tINTEGER* = 1; tBYTE* = 2; tCHAR* = 3; tSET* = 4;
		25	tBOOLEAN* = 5; tREAL* = 6; tARRAY* = 7; tRECORD* = 8;
		26	tPOINTER* = 9; tPROCEDURE* = 10; tSTRING* = 11; tNIL* = 12;
		27	tCARD16* = 13; tCARD32* = 14; tANYREC* = 15; tWCHAR* = 16;
		28
		29	BASICTYPES* = {tINTEGER, tBYTE, tCHAR, tSET, tBOOLEAN, tREAL, tCARD16, tCARD32, tWCHAR};
		30
		31	stABS* = 1; stASR* = 2; stCHR* = 3; stFLOOR* = 4;
		32	stFLT* = 5; stLEN* = 6; stLSL* = 7; stODD* = 8;
		33	stORD* = 9; stROR* = 10; stASSERT* = 11; stDEC* = 12;
		34	stEXCL* = 13; stINC* = 14; stINCL* = 15; stNEW* = 16;
		35	stPACK* = 17; stUNPK* = 18; sysADR* = 19; sysSIZE* = 20;
		36	sysGET* = 21; sysPUT* = 22;
		37
		38	stDISPOSE* = 23; stLSR* = 24; stBITS* = 25; sysCODE* = 26;
		39	sysMOVE* = 27; stLENGTH* = 28; stMIN* = 29; stMAX* = 30;
		40	sysSADR* = 31; sysTYPEID* = 32; sysCOPY* = 33; sysINF* = 34;
		41	sysPUT8* = 35; sysPUT16* = 36; stCOPY* = 37; stWCHR* = 38;
		42	sysWSADR* = 39; sysPUT32* = 40;
		43
		44	default* = 2;
		45	stdcall* = 4; _stdcall* = stdcall + 1;
		46	ccall* = 6; _ccall* = ccall + 1;
		47	ccall16* = 8; _ccall16* = ccall16 + 1;
		48	win64* = 10; _win64* = win64 + 1;
		49	stdcall64* = 12; _stdcall64* = stdcall64 + 1;
		50	default64* = 14;
		51	systemv* = 16; _systemv* = systemv + 1;
		52
		53	noalign* = 20;
		54
		55	callee_clean_up* = {default, stdcall, _stdcall, default64, stdcall64, _stdcall64};
		56	caller_clean_up* = {ccall, ccall16, win64, systemv, _ccall, _ccall16, _win64, _systemv};
		57	callconv32* = {default, stdcall, ccall, ccall16, _stdcall, _ccall, _ccall16};
		58	callconv64* = {default64, win64, stdcall64, systemv, _win64, _stdcall64, _systemv};
		59
		60	STACK_FRAME = 2;
		61
		62
		63	TYPE
		64
		65	IDENT* = POINTER TO rIDENT;
		66
		67	UNIT* = POINTER TO rUNIT;
		68
		69	PROGRAM* = POINTER TO rPROGRAM;
		70
		71	TYPE_* = POINTER TO rTYPE_;
		72
		73	FRWPTR* = POINTER TO RECORD (LISTS.ITEM)
		74
		75	type: TYPE_;
		76	baseIdent: SCAN.IDENT;
		77	linked: BOOLEAN;
		78
		79	pos*: SCAN.POSITION;
		80	notRecord*: BOOLEAN
		81
		82	END;
		83
		84	IDENTS = POINTER TO RECORD (LISTS.LIST)
		85
		86	add*: PROCEDURE (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT;
		87	get*: PROCEDURE (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT
		88
		89	END;
		90
		91	PROC* = POINTER TO RECORD (LISTS.ITEM)
		92
		93	label*: INTEGER;
		94	used*: BOOLEAN;
		95	processed*: BOOLEAN;
		96	import*: LISTS.ITEM;
		97	using*: LISTS.LIST;
		98	enter*,
		99	leave*: LISTS.ITEM
		100
		101	END;
		102
		103	USED_PROC = POINTER TO RECORD (LISTS.ITEM)
		104
		105	proc: PROC
		106
		107	END;
		108
		109	rUNIT = RECORD (LISTS.ITEM)
		110
		111	program*: PROGRAM;
		112	name*: SCAN.IDENT;
		113	idents*: IDENTS;
		114	frwPointers: LISTS.LIST;
		115	gscope: IDENT;
		116	closed*: BOOLEAN;
		117	scopeLvl*: INTEGER;
		118	sysimport*: BOOLEAN;
		119
		120	scopes*: ARRAY MAXSCOPE OF PROC;
		121
		122	scope*: RECORD
		123
		124	open*: PROCEDURE (unit: UNIT; proc: PROC): BOOLEAN;
		125	close*: PROCEDURE (unit: UNIT; variables: LISTS.LIST)
		126
		127	END;
		128
		129	close*: PROCEDURE (unit: UNIT);
		130	setvars*: PROCEDURE (unit: UNIT; type: TYPE_);
		131
		132	pointers*: RECORD
		133
		134	add*: PROCEDURE (unit: UNIT; type: TYPE_; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
		135	link*: PROCEDURE (unit: UNIT): FRWPTR
		136
		137	END
		138
		139	END;
		140
		141	FIELD* = POINTER TO rFIELD;
		142
		143	PARAM* = POINTER TO rPARAM;
		144
		145	FIELDS = POINTER TO RECORD (LISTS.LIST)
		146
		147	add*: PROCEDURE (rec: TYPE_; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
		148	get*: PROCEDURE (rec: TYPE_; name: SCAN.IDENT; unit: UNIT): FIELD;
		149	set*: PROCEDURE (rec: TYPE_; type: TYPE_): BOOLEAN
		150
		151	END;
		152
		153	PARAMS = POINTER TO RECORD (LISTS.LIST)
		154
		155	size*: INTEGER;
		156
		157	add*: PROCEDURE (proc: TYPE_; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
		158	get*: PROCEDURE (proc: TYPE_; name: SCAN.IDENT): PARAM;
		159	set*: PROCEDURE (proc: TYPE_; type: TYPE_);
		160	getfparams*: PROCEDURE (proc: TYPE_; maxparam: INTEGER; VAR int, flt: INTEGER): SET
		161
		162	END;
		163
		164	rTYPE_ = RECORD (LISTS.ITEM)
		165
		166	typ*: INTEGER;
		167	size*: INTEGER;
		168	length*: INTEGER;
		169	align*: INTEGER;
		170	base*: TYPE_;
		171	fields*: FIELDS;
		172	params*: PARAMS;
		173	unit*: UNIT;
		174	closed*: BOOLEAN;
		175	num*: INTEGER;
		176	call*: INTEGER;
		177	import*: BOOLEAN;
		178	noalign*: BOOLEAN
		179
		180	END;
		181
		182	rFIELD = RECORD (LISTS.ITEM)
		183
		184	type*: TYPE_;
		185	name*: SCAN.IDENT;
		186	export*: BOOLEAN;
		187	offset*: INTEGER
		188
		189	END;
		190
		191	rPARAM = RECORD (LISTS.ITEM)
		192
		193	name*: SCAN.IDENT;
		194	type*: TYPE_;
		195	vPar*: BOOLEAN;
		196	offset*: INTEGER
		197
		198	END;
		199
		200	rIDENT = RECORD (LISTS.ITEM)
		201
		202	name*: SCAN.IDENT;
		203	typ*: INTEGER;
		204	export*: BOOLEAN;
		205	import*: LISTS.ITEM;
		206	unit*: UNIT;
		207	value*: ARITH.VALUE;
		208	type*: TYPE_;
		209	stproc*: INTEGER;
		210	global*: BOOLEAN;
		211	scopeLvl*: INTEGER;
		212	offset*: INTEGER;
		213	proc*: PROC;
		214	pos*: SCAN.POSITION
		215
		216	END;
		217
		218	UNITS* = POINTER TO RECORD (LISTS.LIST)
		219
		220	program: PROGRAM;
		221
		222	create*: PROCEDURE (units: UNITS; name: SCAN.IDENT): UNIT;
		223	get*: PROCEDURE (units: UNITS; name: SCAN.IDENT): UNIT
		224
		225	END;
		226
		227	rPROGRAM = RECORD
		228
		229	recCount: INTEGER;
		230	units*: UNITS;
		231	types*: LISTS.LIST;
		232	sysunit*: UNIT;
		233	rtl*: UNIT;
		234	bss*: INTEGER;
		235	locsize*: INTEGER;
		236
		237	procs*: LISTS.LIST;
		238	dll*: BOOLEAN;
		239	obj*: BOOLEAN;
		240
		241	stTypes*: RECORD
		242
		243	tINTEGER, tBYTE, tCHAR, tWCHAR, tSET, tBOOLEAN, tREAL, tSTRING, tNIL*,
		244	tCARD16, tCARD32, tANYREC*: TYPE_
		245
		246	END;
		247
		248	target*: RECORD
		249
		250	bit_depth*: INTEGER;
		251	word*: INTEGER;
		252	adr*: INTEGER;
		253	sys*: INTEGER
		254
		255	END;
		256
		257	enterType*: PROCEDURE (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_;
		258	getType*: PROCEDURE (program: PROGRAM; typ: INTEGER): TYPE_
		259
		260	END;
		261
		262	DELIMPORT = PROCEDURE (import: LISTS.ITEM);
		263
		264
		265	VAR
		266
		267	idents: C.COLLECTION;
		268
		269
		270	PROCEDURE NewIdent (): IDENT;
		271	VAR
		272	ident: IDENT;
		273	citem: C.ITEM;
		274
		275	BEGIN
		276	citem := C.pop(idents);
		277	IF citem = NIL THEN
		278	NEW(ident)
		279	ELSE
		280	ident := citem(IDENT)
		281	END
		282
		283	RETURN ident
		284	END NewIdent;
		285
		286
		287	PROCEDURE getOffset* (program: PROGRAM; varIdent: IDENT): INTEGER;
		288	VAR
		289	word: INTEGER;
		290	size: INTEGER;
		291
		292	BEGIN
		293	IF varIdent.offset = -1 THEN
		294	IF varIdent.global THEN
		295	IF MACHINE.Align(program.bss, varIdent.type.align) THEN
		296	IF UTILS.maxint - program.bss >= varIdent.type.size THEN
		297	varIdent.offset := program.bss;
		298	INC(program.bss, varIdent.type.size)
		299	END
		300	END
		301	ELSE
		302	word := program.target.word;
		303	size := varIdent.type.size;
		304	IF MACHINE.Align(size, word) THEN
		305	size := size DIV word;
		306	IF UTILS.maxint - program.locsize >= size THEN
		307	INC(program.locsize, size);
		308	varIdent.offset := program.locsize;
		309	END
		310	END
		311	END
		312	END
		313
		314	RETURN varIdent.offset
		315	END getOffset;
		316
		317
		318	PROCEDURE close (unit: UNIT);
		319	VAR
		320	ident, prev: IDENT;
		321	offset: INTEGER;
		322
		323	BEGIN
		324	ident := unit.idents.last(IDENT);
		325	WHILE (ident # NIL) & (ident.typ # idGUARD) DO
		326	IF (ident.typ = idVAR) & (ident.offset = -1) THEN
		327	ERRORS.hintmsg(ident.name.s, ident.pos.line, ident.pos.col, 0);
		328	IF ident.export THEN
		329	offset := getOffset(unit.program, ident)
		330	END
		331	END;
		332	ident := ident.prev(IDENT)
		333	END;
		334
		335	ident := unit.idents.last(IDENT);
		336	WHILE ident # NIL DO
		337	prev := ident.prev(IDENT);
		338	IF ~ident.export THEN
		339	LISTS.delete(unit.idents, ident);
		340	C.push(idents, ident)
		341	END;
		342	ident := prev
		343	END;
		344
		345	unit.closed := TRUE
		346	END close;
		347
		348
		349	PROCEDURE unique (unit: UNIT; ident: SCAN.IDENT): BOOLEAN;
		350	VAR
		351	item: IDENT;
		352
		353	BEGIN
		354	ASSERT(ident # NIL);
		355
		356	item := unit.idents.last(IDENT);
		357	WHILE (item.typ # idGUARD) & (item.name # ident) DO
		358	item := item.prev(IDENT)
		359	END
		360
		361	RETURN item.typ = idGUARD
		362	END unique;
		363
		364
		365	PROCEDURE addIdent (unit: UNIT; ident: SCAN.IDENT; typ: INTEGER): IDENT;
		366	VAR
		367	item: IDENT;
		368	res: BOOLEAN;
		369	proc: PROC;
		370	procs: LISTS.LIST;
		371
		372	BEGIN
		373	ASSERT(unit # NIL);
		374	ASSERT(ident # NIL);
		375
		376	res := unique(unit, ident);
		377
		378	IF res THEN
		379	item := NewIdent();
		380
		381	item.name := ident;
		382	item.typ := typ;
		383	item.unit := NIL;
		384	item.export := FALSE;
		385	item.import := NIL;
		386	item.type := NIL;
		387	item.value.typ := 0;
		388	item.stproc := 0;
		389
		390	item.global := unit.scopeLvl = 0;
		391	item.scopeLvl := unit.scopeLvl;
		392	item.offset := -1;
		393
		394	IF item.typ IN {idPROC, idIMP} THEN
		395	NEW(proc);
		396	proc.import := NIL;
		397	proc.label := 0;
		398	proc.used := FALSE;
		399	proc.processed := FALSE;
		400	proc.using := LISTS.create(NIL);
		401	procs := unit.program.procs;
		402	LISTS.push(procs, proc);
		403	item.proc := proc
		404	END;
		405
		406	LISTS.push(unit.idents, item)
		407	ELSE
		408	item := NIL
		409	END
		410
		411	RETURN item
		412	END addIdent;
		413
		414
		415	PROCEDURE UseProc* (unit: UNIT; call_proc: PROC);
		416	VAR
		417	procs: LISTS.LIST;
		418	cur: LISTS.ITEM;
		419	proc: USED_PROC;
		420
		421	BEGIN
		422	IF unit.scopeLvl = 0 THEN
		423	call_proc.used := TRUE
		424	ELSE
		425	procs := unit.scopes[unit.scopeLvl].using;
		426
		427	cur := procs.first;
		428	WHILE (cur # NIL) & (cur(USED_PROC).proc # call_proc) DO
		429	cur := cur.next
		430	END;
		431
		432	IF cur = NIL THEN
		433	NEW(proc);
		434	proc.proc := call_proc;
		435	LISTS.push(procs, proc)
		436	END
		437	END
		438	END UseProc;
		439
		440
		441	PROCEDURE setvars (unit: UNIT; type: TYPE_);
		442	VAR
		443	item: IDENT;
		444
		445	BEGIN
		446	ASSERT(type # NIL);
		447
		448	item := unit.idents.last(IDENT);
		449	WHILE (item # NIL) & (item.typ = idVAR) & (item.type = NIL) DO
		450	item.type := type;
		451	item := item.prev(IDENT)
		452	END
		453	END setvars;
		454
		455
		456	PROCEDURE getIdent (unit: UNIT; ident: SCAN.IDENT; currentScope: BOOLEAN): IDENT;
		457	VAR
		458	item: IDENT;
		459
		460	BEGIN
		461	ASSERT(ident # NIL);
		462
		463	item := unit.idents.last(IDENT);
		464
		465	ASSERT(item # NIL);
		466
		467	IF currentScope THEN
		468	WHILE (item.name # ident) & (item.typ # idGUARD) DO
		469	item := item.prev(IDENT)
		470	END;
		471	IF item.name # ident THEN
		472	item := NIL
		473	END
		474	ELSE
		475	WHILE (item # NIL) & (item.name # ident) DO
		476	item := item.prev(IDENT)
		477	END
		478	END
		479
		480	RETURN item
		481	END getIdent;
		482
		483
		484	PROCEDURE openScope (unit: UNIT; proc: PROC): BOOLEAN;
		485	VAR
		486	item: IDENT;
		487	res: BOOLEAN;
		488
		489	BEGIN
		490	INC(unit.scopeLvl);
		491
		492	res := unit.scopeLvl < MAXSCOPE;
		493
		494	IF res THEN
		495
		496	unit.scopes[unit.scopeLvl] := proc;
		497
		498	NEW(item);
		499	item := NewIdent();
		500
		501	item.name := NIL;
		502	item.typ := idGUARD;
		503
		504	LISTS.push(unit.idents, item)
		505	END
		506
		507	RETURN res
		508	END openScope;
		509
		510
		511	PROCEDURE closeScope (unit: UNIT; variables: LISTS.LIST);
		512	VAR
		513	item: IDENT;
		514	del: IDENT;
		515	lvar: CODE.LOCALVAR;
		516
		517	BEGIN
		518	item := unit.idents.last(IDENT);
		519
		520	WHILE (item # NIL) & (item.typ # idGUARD) DO
		521	del := item;
		522	item := item.prev(IDENT);
		523	IF (del.typ = idVAR) & (del.offset = -1) THEN
		524	ERRORS.hintmsg(del.name.s, del.pos.line, del.pos.col, 0)
		525	END;
		526	IF (variables # NIL) & (del.typ IN {idVAR, idPARAM}) & (del.offset # -1) THEN
		527	IF del.type.typ IN BASICTYPES - {tREAL} + {tPOINTER, tPROCEDURE} THEN
		528	lvar := CODE.NewVar();
		529	lvar.offset := del.offset;
		530	lvar.size := del.type.size;
		531	IF del.typ = idVAR THEN
		532	lvar.offset := -lvar.offset
		533	END;
		534	LISTS.push(variables, lvar)
		535	END
		536	END;
		537	LISTS.delete(unit.idents, del);
		538	C.push(idents, del)
		539	END;
		540
		541	IF (item # NIL) & (item.typ = idGUARD) THEN
		542	LISTS.delete(unit.idents, item);
		543	C.push(idents, item)
		544	END;
		545
		546	DEC(unit.scopeLvl)
		547
		548	END closeScope;
		549
		550
		551	PROCEDURE frwptr (unit: UNIT; type: TYPE_; baseIdent: SCAN.IDENT; pos: SCAN.POSITION);
		552	VAR
		553	newptr: FRWPTR;
		554
		555	BEGIN
		556	ASSERT(unit # NIL);
		557	ASSERT(type # NIL);
		558	ASSERT(baseIdent # NIL);
		559
		560	NEW(newptr);
		561
		562	newptr.type := type;
		563	newptr.baseIdent := baseIdent;
		564	newptr.pos := pos;
		565	newptr.linked := FALSE;
		566	newptr.notRecord := FALSE;
		567
		568	LISTS.push(unit.frwPointers, newptr)
		569	END frwptr;
		570
		571
		572	PROCEDURE linkptr (unit: UNIT): FRWPTR;
		573	VAR
		574	item: FRWPTR;
		575	ident: IDENT;
		576	res: FRWPTR;
		577
		578	BEGIN
		579	res := NIL;
		580	item := unit.frwPointers.last(FRWPTR);
		581
		582	WHILE (item # NIL) & ~item.linked & (res = NIL) DO
		583	ident := unit.idents.get(unit, item.baseIdent, TRUE);
		584
		585	IF (ident # NIL) THEN
		586	IF (ident.typ = idTYPE) & (ident.type.typ = tRECORD) THEN
		587	item.type.base := ident.type;
		588	item.linked := TRUE
		589	ELSE
		590	item.notRecord := TRUE;
		591	res := item
		592	END
		593	ELSE
		594	item.notRecord := FALSE;
		595	res := item
		596	END;
		597
		598	item := item.prev(FRWPTR)
		599	END
		600
		601	RETURN res
		602	END linkptr;
		603
		604
		605	PROCEDURE isTypeEq* (t1, t2: TYPE_): BOOLEAN;
		606	VAR
		607	res: BOOLEAN;
		608	param1, param2: LISTS.ITEM;
		609
		610	BEGIN
		611	IF t1 = t2 THEN
		612	res := TRUE
		613	ELSIF (t1 = NIL) OR (t2 = NIL) THEN
		614	res := FALSE
		615	ELSIF (t1.typ = tPROCEDURE) & (t2.typ = tPROCEDURE) THEN
		616
		617	param1 := t1.params.first;
		618	param2 := t2.params.first;
		619
		620	res := (t1.call = t2.call) & ((param1 # NIL) = (param2 # NIL));
		621
		622	WHILE res & (param1 # NIL) & (param2 # NIL) DO
		623	res := (param1(PARAM).vPar = param2(PARAM).vPar) & isTypeEq(param1(PARAM).type, param2(PARAM).type);
		624	param1 := param1.next;
		625	param2 := param2.next;
		626	res := res & ((param1 # NIL) = (param2 # NIL))
		627	END;
		628
		629	res := res & isTypeEq(t1.base, t2.base)
		630
		631	ELSIF (t1.typ = tARRAY) & (t2.typ = tARRAY) THEN
		632	res := (t1.length = 0) & (t2.length = 0) & isTypeEq(t1.base, t2.base)
		633	ELSE
		634	res := FALSE
		635	END
		636
		637	RETURN res
		638	END isTypeEq;
		639
		640
		641	PROCEDURE isBaseOf* (t0, t1: TYPE_): BOOLEAN;
		642	VAR
		643	res: BOOLEAN;
		644
		645	BEGIN
		646	res := ((t0.typ = tPOINTER) & (t1.typ = tPOINTER)) OR ((t0.typ = tRECORD) & (t1.typ = tRECORD));
		647
		648	IF (t0.typ = tPOINTER) & (t1.typ = tPOINTER) THEN
		649	t0 := t0.base;
		650	t1 := t1.base
		651	END;
		652
		653	WHILE res & (t1 # NIL) & (t1 # t0) DO
		654	t1 := t1.base
		655	END
		656
		657	RETURN res & (t1 = t0)
		658	END isBaseOf;
		659
		660
		661	PROCEDURE isOpenArray* (t: TYPE_): BOOLEAN;
		662	RETURN (t.typ = tARRAY) & (t.length = 0)
		663	END isOpenArray;
		664
		665
		666	PROCEDURE getunit (units: UNITS; name: SCAN.IDENT): UNIT;
		667	VAR
		668	item: UNIT;
		669
		670	BEGIN
		671	ASSERT(name # NIL);
		672
		673	item := units.first(UNIT);
		674
		675	WHILE (item # NIL) & (item.name # name) DO
		676	item := item.next(UNIT)
		677	END;
		678
		679	IF (item = NIL) & (name.s = "SYSTEM") THEN
		680	item := units.program.sysunit
		681	END
		682
		683	RETURN item
		684	END getunit;
		685
		686
		687	PROCEDURE enterStTypes (unit: UNIT; program: PROGRAM);
		688	VAR
		689	ident: IDENT;
		690	stName: SCAN.IDENT;
		691
		692	BEGIN
		693
		694	stName := SCAN.enterid("INTEGER");
		695	ident := addIdent(unit, stName, idTYPE);
		696	ident.type := program.stTypes.tINTEGER;
		697
		698	stName := SCAN.enterid("BYTE");
		699	ident := addIdent(unit, stName, idTYPE);
		700	ident.type := program.stTypes.tBYTE;
		701
		702	stName := SCAN.enterid("CHAR");
		703	ident := addIdent(unit, stName, idTYPE);
		704	ident.type := program.stTypes.tCHAR;
		705
		706	stName := SCAN.enterid("WCHAR");
		707	ident := addIdent(unit, stName, idTYPE);
		708	ident.type := program.stTypes.tWCHAR;
		709
		710	stName := SCAN.enterid("SET");
		711	ident := addIdent(unit, stName, idTYPE);
		712	ident.type := program.stTypes.tSET;
		713
		714	stName := SCAN.enterid("BOOLEAN");
		715	ident := addIdent(unit, stName, idTYPE);
		716	ident.type := program.stTypes.tBOOLEAN;
		717
		718	stName := SCAN.enterid("REAL");
		719	ident := addIdent(unit, stName, idTYPE);
		720	ident.type := program.stTypes.tREAL;
		721
		722	END enterStTypes;
		723
		724
		725	PROCEDURE enterStProcs (unit: UNIT);
		726
		727
		728	PROCEDURE EnterProc (unit: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER);
		729	VAR
		730	ident: IDENT;
		731	BEGIN
		732	ident := addIdent(unit, SCAN.enterid(name), idtyp);
		733	ident.stproc := proc
		734	END EnterProc;
		735
		736
		737	BEGIN
		738	EnterProc(unit, "ASSERT", idSTPROC, stASSERT);
		739	EnterProc(unit, "DEC", idSTPROC, stDEC);
		740	EnterProc(unit, "EXCL", idSTPROC, stEXCL);
		741	EnterProc(unit, "INC", idSTPROC, stINC);
		742	EnterProc(unit, "INCL", idSTPROC, stINCL);
		743	EnterProc(unit, "NEW", idSTPROC, stNEW);
		744	EnterProc(unit, "PACK", idSTPROC, stPACK);
		745	EnterProc(unit, "UNPK", idSTPROC, stUNPK);
		746	EnterProc(unit, "DISPOSE", idSTPROC, stDISPOSE);
		747	EnterProc(unit, "COPY", idSTPROC, stCOPY);
		748
		749	EnterProc(unit, "ABS", idSTFUNC, stABS);
		750	EnterProc(unit, "ASR", idSTFUNC, stASR);
		751	EnterProc(unit, "CHR", idSTFUNC, stCHR);
		752	EnterProc(unit, "WCHR", idSTFUNC, stWCHR);
		753	EnterProc(unit, "FLOOR", idSTFUNC, stFLOOR);
		754	EnterProc(unit, "FLT", idSTFUNC, stFLT);
		755	EnterProc(unit, "LEN", idSTFUNC, stLEN);
		756	EnterProc(unit, "LSL", idSTFUNC, stLSL);
		757	EnterProc(unit, "ODD", idSTFUNC, stODD);
		758	EnterProc(unit, "ORD", idSTFUNC, stORD);
		759	EnterProc(unit, "ROR", idSTFUNC, stROR);
		760	EnterProc(unit, "BITS", idSTFUNC, stBITS);
		761	EnterProc(unit, "LSR", idSTFUNC, stLSR);
		762	EnterProc(unit, "LENGTH", idSTFUNC, stLENGTH);
		763	EnterProc(unit, "MIN", idSTFUNC, stMIN);
		764	EnterProc(unit, "MAX", idSTFUNC, stMAX);
		765	END enterStProcs;
		766
		767
		768	PROCEDURE newunit (units: UNITS; name: SCAN.IDENT): UNIT;
		769	VAR
		770	unit: UNIT;
		771	idents: IDENTS;
		772
		773	BEGIN
		774	ASSERT(units # NIL);
		775	ASSERT(name # NIL);
		776
		777	NEW(unit);
		778
		779	NEW(idents);
		780	ASSERT(LISTS.create(idents) = idents);
		781
		782	idents.add := addIdent;
		783	idents.get := getIdent;
		784
		785	unit.program := units.program;
		786	unit.name := name;
		787	unit.closed := FALSE;
		788	unit.idents := idents;
		789	unit.frwPointers := LISTS.create(NIL);
		790
		791	unit.scope.open := openScope;
		792	unit.scope.close := closeScope;
		793	unit.close := close;
		794	unit.setvars := setvars;
		795	unit.pointers.add := frwptr;
		796	unit.pointers.link := linkptr;
		797
		798	ASSERT(unit.scope.open(unit, NIL));
		799
		800	enterStTypes(unit, units.program);
		801	enterStProcs(unit);
		802
		803	ASSERT(unit.scope.open(unit, NIL));
		804
		805	unit.gscope := unit.idents.last(IDENT);
		806
		807	LISTS.push(units, unit);
		808
		809	unit.scopeLvl := 0;
		810	unit.scopes[0] := NIL;
		811
		812	unit.sysimport := FALSE;
		813
		814	IF unit.name.s = mConst.RTL_NAME THEN
		815	unit.program.rtl := unit
		816	END
		817
		818	RETURN unit
		819	END newunit;
		820
		821
		822	PROCEDURE getField (self: TYPE_; name: SCAN.IDENT; unit: UNIT): FIELD;
		823	VAR
		824	field: FIELD;
		825
		826	BEGIN
		827	ASSERT(self # NIL);
		828	ASSERT(name # NIL);
		829	ASSERT(unit # NIL);
		830
		831	field := NIL;
		832	WHILE (self # NIL) & (field = NIL) DO
		833
		834	field := self.fields.first(FIELD);
		835
		836	WHILE (field # NIL) & (field.name # name) DO
		837	field := field.next(FIELD)
		838	END;
		839
		840	IF field = NIL THEN
		841	self := self.base
		842	END
		843
		844	END;
		845
		846	IF (field # NIL) & (self.unit # unit) & ~field.export THEN
		847	field := NIL
		848	END
		849
		850	RETURN field
		851	END getField;
		852
		853
		854	PROCEDURE addField (self: TYPE_; name: SCAN.IDENT; export: BOOLEAN): BOOLEAN;
		855	VAR
		856	field: FIELD;
		857	res: BOOLEAN;
		858
		859	BEGIN
		860	ASSERT(name # NIL);
		861
		862	res := getField(self, name, self.unit) = NIL;
		863
		864	IF res THEN
		865	NEW(field);
		866
		867	field.name := name;
		868	field.export := export;
		869	field.type := NIL;
		870	field.offset := self.size;
		871
		872	LISTS.push(self.fields, field)
		873	END
		874
		875	RETURN res
		876	END addField;
		877
		878
		879	PROCEDURE setFields (self: TYPE_; type: TYPE_): BOOLEAN;
		880	VAR
		881	item: FIELD;
		882	res: BOOLEAN;
		883
		884	BEGIN
		885	ASSERT(type # NIL);
		886
		887	item := self.fields.first(FIELD);
		888
		889	WHILE (item # NIL) & (item.type # NIL) DO
		890	item := item.next(FIELD)
		891	END;
		892
		893	res := TRUE;
		894
		895	WHILE res & (item # NIL) & (item.type = NIL) DO
		896	item.type := type;
		897	IF ~self.noalign THEN
		898	res := MACHINE.Align(self.size, type.align)
		899	ELSE
		900	res := TRUE
		901	END;
		902	item.offset := self.size;
		903	res := res & (UTILS.maxint - self.size >= type.size);
		904	IF res THEN
		905	INC(self.size, type.size)
		906	END;
		907	item := item.next(FIELD)
		908	END
		909
		910	RETURN res
		911	END setFields;
		912
		913
		914	PROCEDURE getParam (self: TYPE_; name: SCAN.IDENT): PARAM;
		915	VAR
		916	item: PARAM;
		917
		918	BEGIN
		919	ASSERT(name # NIL);
		920
		921	item := self.params.first(PARAM);
		922
		923	WHILE (item # NIL) & (item.name # name) DO
		924	item := item.next(PARAM)
		925	END
		926
		927	RETURN item
		928	END getParam;
		929
		930
		931	PROCEDURE addParam (self: TYPE_; name: SCAN.IDENT; vPar: BOOLEAN): BOOLEAN;
		932	VAR
		933	param: PARAM;
		934	res: BOOLEAN;
		935
		936	BEGIN
		937	ASSERT(name # NIL);
		938
		939	res := self.params.get(self, name) = NIL;
		940
		941	IF res THEN
		942	NEW(param);
		943
		944	param.name := name;
		945	param.type := NIL;
		946	param.vPar := vPar;
		947
		948	LISTS.push(self.params, param)
		949	END
		950
		951	RETURN res
		952	END addParam;
		953
		954
		955	PROCEDURE Dim* (t: TYPE_): INTEGER;
		956	VAR
		957	res: INTEGER;
		958
		959	BEGIN
		960	res := 0;
		961	WHILE isOpenArray(t) DO
		962	t := t.base;
		963	INC(res)
		964	END
		965	RETURN res
		966	END Dim;
		967
		968
		969	PROCEDURE OpenBase* (t: TYPE_): TYPE_;
		970	BEGIN
		971	WHILE isOpenArray(t) DO t := t.base END
		972	RETURN t
		973	END OpenBase;
		974
		975
		976	PROCEDURE getFloatParamsPos (self: TYPE_; maxoffs: INTEGER; VAR int, flt: INTEGER): SET;
		977	VAR
		978	res: SET;
		979	param: PARAM;
		980
		981	BEGIN
		982	res := {};
		983	int := 0;
		984	flt := 0;
		985	param := self.params.first(PARAM);
		986	WHILE (param # NIL) & (param.offset <= maxoffs + STACK_FRAME) DO
		987	IF ~param.vPar & (param.type.typ = tREAL) THEN
		988	INCL(res, param.offset - STACK_FRAME);
		989	INC(flt)
		990	END;
		991	param := param.next(PARAM)
		992	END;
		993
		994	int := self.params.size - flt
		995
		996	RETURN res
		997	END getFloatParamsPos;
		998
		999
		1000	PROCEDURE setParams (self: TYPE_; type: TYPE_);
		1001	VAR
		1002	item: LISTS.ITEM;
		1003	param: PARAM;
		1004	word, size: INTEGER;
		1005
		1006	BEGIN
		1007	ASSERT(type # NIL);
		1008
		1009	word := MACHINE.target.bit_depth DIV 8;
		1010
		1011	item := self.params.first;
		1012
		1013	WHILE (item # NIL) & (item(PARAM).type # NIL) DO
		1014	item := item.next
		1015	END;
		1016
		1017	WHILE (item # NIL) & (item(PARAM).type = NIL) DO
		1018	param := item(PARAM);
		1019	param.type := type;
		1020	IF param.vPar THEN
		1021	IF type.typ = tRECORD THEN
		1022	size := 2
		1023	ELSIF isOpenArray(type) THEN
		1024	size := Dim(type) + 1
		1025	ELSE
		1026	size := 1
		1027	END;
		1028	param.offset := self.params.size + ORD(type.typ = tRECORD) + Dim(type) + STACK_FRAME;
		1029	INC(self.params.size, size)
		1030	ELSE
		1031	IF type.typ IN {tRECORD, tARRAY} THEN
		1032	IF isOpenArray(type) THEN
		1033	size := Dim(type) + 1
		1034	ELSE
		1035	size := 1
		1036	END
		1037	ELSE
		1038	size := type.size;
		1039	ASSERT(MACHINE.Align(size, word));
		1040	size := size DIV word
		1041	END;
		1042	param.offset := self.params.size + Dim(type) + STACK_FRAME;
		1043	INC(self.params.size, size)
		1044	END;
		1045
		1046	item := item.next
		1047	END
		1048
		1049	END setParams;
		1050
		1051
		1052	PROCEDURE enterType (program: PROGRAM; typ, size, length: INTEGER; unit: UNIT): TYPE_;
		1053	VAR
		1054	t: TYPE_;
		1055	fields: FIELDS;
		1056	params: PARAMS;
		1057
		1058	BEGIN
		1059	NEW(t);
		1060
		1061	NEW(fields);
		1062	ASSERT(LISTS.create(fields) = fields);
		1063
		1064	NEW(params);
		1065	ASSERT(LISTS.create(params) = params);
		1066
		1067	t.typ := typ;
		1068	t.size := size;
		1069	t.length := length;
		1070	t.align := 0;
		1071	t.base := NIL;
		1072	t.fields := fields;
		1073	t.params := params;
		1074	t.unit := unit;
		1075	t.num := 0;
		1076	IF program.target.bit_depth = 32 THEN
		1077	t.call := default
		1078	ELSIF program.target.bit_depth = 64 THEN
		1079	t.call := default64
		1080	END;
		1081	t.import := FALSE;
		1082	t.noalign := FALSE;
		1083
		1084	t.fields.add := addField;
		1085	t.fields.get := getField;
		1086	t.fields.set := setFields;
		1087
		1088	t.params.add := addParam;
		1089	t.params.get := getParam;
		1090	t.params.getfparams := getFloatParamsPos;
		1091	t.params.set := setParams;
		1092	t.params.size := 0;
		1093
		1094	IF typ IN {tARRAY, tRECORD} THEN
		1095	t.closed := FALSE;
		1096	IF typ = tRECORD THEN
		1097	INC(program.recCount);
		1098	t.num := program.recCount
		1099	END
		1100	ELSE
		1101	t.closed := TRUE
		1102	END;
		1103
		1104	LISTS.push(program.types, t)
		1105
		1106	RETURN t
		1107	END enterType;
		1108
		1109
		1110	PROCEDURE getType (program: PROGRAM; typ: INTEGER): TYPE_;
		1111	VAR
		1112	res: TYPE_;
		1113
		1114	BEGIN
		1115
		1116	IF typ = ARITH.tINTEGER THEN
		1117	res := program.stTypes.tINTEGER
		1118	ELSIF typ = ARITH.tREAL THEN
		1119	res := program.stTypes.tREAL
		1120	ELSIF typ = ARITH.tSET THEN
		1121	res := program.stTypes.tSET
		1122	ELSIF typ = ARITH.tBOOLEAN THEN
		1123	res := program.stTypes.tBOOLEAN
		1124	ELSIF typ = ARITH.tCHAR THEN
		1125	res := program.stTypes.tCHAR
		1126	ELSIF typ = ARITH.tWCHAR THEN
		1127	res := program.stTypes.tWCHAR
		1128	ELSIF typ = ARITH.tSTRING THEN
		1129	res := program.stTypes.tSTRING
		1130	ELSE
		1131	res := NIL
		1132	END;
		1133
		1134	ASSERT(res # NIL)
		1135
		1136	RETURN res
		1137	END getType;
		1138
		1139
		1140	PROCEDURE createSysUnit (program: PROGRAM);
		1141	VAR
		1142	ident: IDENT;
		1143	unit: UNIT;
		1144
		1145
		1146	PROCEDURE EnterProc (sys: UNIT; name: SCAN.LEXSTR; idtyp, proc: INTEGER);
		1147	VAR
		1148	ident: IDENT;
		1149	BEGIN
		1150	ident := addIdent(sys, SCAN.enterid(name), idtyp);
		1151	ident.stproc := proc;
		1152	ident.export := TRUE
		1153	END EnterProc;
		1154
		1155
		1156	BEGIN
		1157	unit := program.units.create(program.units, SCAN.enterid("$SYSTEM"));
		1158
		1159	EnterProc(unit, "ADR", idSYSFUNC, sysADR);
		1160	EnterProc(unit, "SIZE", idSYSFUNC, sysSIZE);
		1161	EnterProc(unit, "SADR", idSYSFUNC, sysSADR);
		1162	EnterProc(unit, "WSADR", idSYSFUNC, sysWSADR);
		1163	EnterProc(unit, "TYPEID", idSYSFUNC, sysTYPEID);
		1164	EnterProc(unit, "INF", idSYSFUNC, sysINF);
		1165
		1166	EnterProc(unit, "GET", idSYSPROC, sysGET);
		1167	EnterProc(unit, "PUT", idSYSPROC, sysPUT);
		1168	EnterProc(unit, "PUT8", idSYSPROC, sysPUT8);
		1169	EnterProc(unit, "PUT16", idSYSPROC, sysPUT16);
		1170	EnterProc(unit, "PUT32", idSYSPROC, sysPUT32);
		1171	EnterProc(unit, "CODE", idSYSPROC, sysCODE);
		1172	EnterProc(unit, "MOVE", idSYSPROC, sysMOVE);
		1173	EnterProc(unit, "COPY", idSYSPROC, sysCOPY);
		1174
		1175	ident := addIdent(unit, SCAN.enterid("CARD16"), idTYPE);
		1176	ident.type := program.stTypes.tCARD16;
		1177	ident.export := TRUE;
		1178
		1179	ident := addIdent(unit, SCAN.enterid("CARD32"), idTYPE);
		1180	ident.type := program.stTypes.tCARD32;
		1181	ident.export := TRUE;
		1182
		1183	unit.close(unit);
		1184
		1185	program.sysunit := unit
		1186	END createSysUnit;
		1187
		1188
		1189	PROCEDURE DelUnused* (program: PROGRAM; DelImport: DELIMPORT);
		1190	VAR
		1191	proc: PROC;
		1192	flag: BOOLEAN;
		1193
		1194
		1195	PROCEDURE process (proc: PROC);
		1196	VAR
		1197	used_proc: LISTS.ITEM;
		1198
		1199	BEGIN
		1200	proc.processed := TRUE;
		1201
		1202	used_proc := proc.using.first;
		1203	WHILE used_proc # NIL DO
		1204	used_proc(USED_PROC).proc.used := TRUE;
		1205	used_proc := used_proc.next
		1206	END
		1207
		1208	END process;
		1209
		1210
		1211	BEGIN
		1212
		1213	REPEAT
		1214
		1215	flag := FALSE;
		1216	proc := program.procs.first(PROC);
		1217
		1218	WHILE proc # NIL DO
		1219	IF proc.used & ~proc.processed THEN
		1220	process(proc);
		1221	flag := TRUE
		1222	END;
		1223	proc := proc.next(PROC)
		1224	END
		1225
		1226	UNTIL ~flag;
		1227
		1228	proc := program.procs.first(PROC);
		1229
		1230	WHILE proc # NIL DO
		1231	IF ~proc.used THEN
		1232	IF proc.import = NIL THEN
		1233	CODE.delete2(proc.enter, proc.leave)
		1234	ELSE
		1235	DelImport(proc.import)
		1236	END
		1237	END;
		1238	proc := proc.next(PROC)
		1239	END
		1240
		1241	END DelUnused;
		1242
		1243
		1244	PROCEDURE create* (bit_depth, sys: INTEGER): PROGRAM;
		1245	VAR
		1246	program: PROGRAM;
		1247	units: UNITS;
		1248
		1249	BEGIN
		1250	idents := C.create();
		1251
		1252	MACHINE.SetBitDepth(bit_depth);
		1253	NEW(program);
		1254	NEW(units);
		1255	ASSERT(LISTS.create(units) = units);
		1256
		1257	program.target.bit_depth := bit_depth;
		1258	program.target.word := bit_depth DIV 8;
		1259	program.target.adr := bit_depth DIV 8;
		1260	program.target.sys := sys;
		1261
		1262	program.recCount := -1;
		1263	program.bss := 0;
		1264
		1265	program.units := units;
		1266	program.types := LISTS.create(NIL);
		1267
		1268	program.procs := LISTS.create(NIL);
		1269
		1270	program.enterType := enterType;
		1271	program.getType := getType;
		1272
		1273	program.stTypes.tINTEGER := enterType(program, tINTEGER, program.target.word, 0, NIL);
		1274	program.stTypes.tBYTE := enterType(program, tBYTE, 1, 0, NIL);
		1275	program.stTypes.tCHAR := enterType(program, tCHAR, 1, 0, NIL);
		1276	program.stTypes.tWCHAR := enterType(program, tWCHAR, 2, 0, NIL);
		1277	program.stTypes.tSET := enterType(program, tSET, program.target.word, 0, NIL);
		1278	program.stTypes.tBOOLEAN := enterType(program, tBOOLEAN, 1, 0, NIL);
		1279	program.stTypes.tREAL := enterType(program, tREAL, 8, 0, NIL);
		1280	program.stTypes.tSTRING := enterType(program, tSTRING, program.target.word, 0, NIL);
		1281	program.stTypes.tNIL := enterType(program, tNIL, program.target.word, 0, NIL);
		1282	program.stTypes.tCARD16 := enterType(program, tCARD16, 2, 0, NIL);
		1283	program.stTypes.tCARD32 := enterType(program, tCARD32, 4, 0, NIL);
		1284	program.stTypes.tANYREC := enterType(program, tRECORD, 0, 0, NIL);
		1285	program.stTypes.tANYREC.closed := TRUE;
		1286
		1287	program.stTypes.tINTEGER.align := program.stTypes.tINTEGER.size;
		1288	program.stTypes.tBYTE.align := 1;
		1289	program.stTypes.tCHAR.align := program.stTypes.tCHAR.size;
		1290	program.stTypes.tWCHAR.align := program.stTypes.tWCHAR.size;
		1291	program.stTypes.tSET.align := program.stTypes.tSET.size;
		1292	program.stTypes.tBOOLEAN.align := program.stTypes.tBOOLEAN.size;
		1293	program.stTypes.tREAL.align := program.stTypes.tREAL.size;
		1294	program.stTypes.tCARD16.align := program.stTypes.tCARD16.size;
		1295	program.stTypes.tCARD32.align := program.stTypes.tCARD32.size;
		1296
		1297	units.program := program;
		1298
		1299	units.create := newunit;
		1300	units.get := getunit;
		1301
		1302	program.dll := FALSE;
		1303	program.obj := FALSE;
		1304
		1305	createSysUnit(program)
		1306
		1307	RETURN program
		1308	END create;
		1309
		1310
		1311	END PROG.

Subversion Repositories Kolibri OS

(root)/programs/develop/oberon07/Source/PROG.ob07 – Rev 7597