WebSVN – Kolibri OS – Blame – /programs/develop/oberon07/Lib/KolibriOS/RTL.ob07

Rev	Author	Line No.	Line
7597	akron1	1	(*
		2	BSD 2-Clause License
6613	leency	3
7597	akron1	4	Copyright (c) 2018, 2019, Anton Krotov
		5	All rights reserved.
6613	leency	6	*)
		7
		8	MODULE RTL;
		9
7597	akron1	10	IMPORT SYSTEM, API;
6613	leency	11
7597	akron1	12
		13	CONST
		14
		15	bit_depth* = 32;
		16	maxint* = 7FFFFFFFH;
		17	minint* = 80000000H;
		18
		19	DLL_PROCESS_ATTACH = 1;
		20	DLL_THREAD_ATTACH = 2;
		21	DLL_THREAD_DETACH = 3;
		22	DLL_PROCESS_DETACH = 0;
		23
		24	SIZE_OF_DWORD = 4;
		25
		26
6613	leency	27	TYPE
		28
7597	akron1	29	DLL_ENTRY* = PROCEDURE (hinstDLL, fdwReason, lpvReserved: INTEGER);
6613	leency	30
7597	akron1	31
6613	leency	32	VAR
		33
7597	akron1	34	name: INTEGER;
		35	types: INTEGER;
6613	leency	36
7597	akron1	37	dll: RECORD
		38	process_detach,
		39	thread_detach,
		40	thread_attach: DLL_ENTRY
		41	END;
		42
		43
		44	PROCEDURE [stdcall] _move* (bytes, source, dest: INTEGER);
6613	leency	45	BEGIN
7597	akron1	46	SYSTEM.CODE(
6613	leency	47
7597	akron1	48	08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
		49	085H, 0C0H, (* test eax, eax *)
		50	07EH, 019H, (* jle L *)
		51	0FCH, (* cld *)
		52	057H, (* push edi *)
		53	056H, (* push esi *)
		54	08BH, 075H, 00CH, (* mov esi, dword [ebp + 12] *)
		55	08BH, 07DH, 010H, (* mov edi, dword [ebp + 16] *)
		56	089H, 0C1H, (* mov ecx, eax *)
		57	0C1H, 0E9H, 002H, (* shr ecx, 2 *)
		58	0F3H, 0A5H, (* rep movsd *)
		59	089H, 0C1H, (* mov ecx, eax *)
		60	083H, 0E1H, 003H, (* and ecx, 3 *)
		61	0F3H, 0A4H, (* rep movsb *)
		62	05EH, (* pop esi *)
		63	05FH (* pop edi *)
		64	(* L: *)
		65	)
		66	END _move;
		67
		68
		69	PROCEDURE [stdcall] _move2* (bytes, dest, source: INTEGER);
6613	leency	70	BEGIN
7597	akron1	71	SYSTEM.CODE(
6613	leency	72
7597	akron1	73	08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
		74	085H, 0C0H, (* test eax, eax *)
		75	07EH, 019H, (* jle L *)
		76	0FCH, (* cld *)
		77	057H, (* push edi *)
		78	056H, (* push esi *)
		79	08BH, 075H, 010H, (* mov esi, dword [ebp + 16] *)
		80	08BH, 07DH, 00CH, (* mov edi, dword [ebp + 12] *)
		81	089H, 0C1H, (* mov ecx, eax *)
		82	0C1H, 0E9H, 002H, (* shr ecx, 2 *)
		83	0F3H, 0A5H, (* rep movsd *)
		84	089H, 0C1H, (* mov ecx, eax *)
		85	083H, 0E1H, 003H, (* and ecx, 3 *)
		86	0F3H, 0A4H, (* rep movsb *)
		87	05EH, (* pop esi *)
		88	05FH (* pop edi *)
		89	(* L: *)
		90	)
		91	END _move2;
		92
		93
		94	PROCEDURE [stdcall] _arrcpy* (base_size, len_dst, dst, len_src, src: INTEGER): BOOLEAN;
		95	VAR
		96	res: BOOLEAN;
		97
6613	leency	98	BEGIN
7597	akron1	99	IF len_src > len_dst THEN
		100	res := FALSE
		101	ELSE
		102	_move(len_src * base_size, src, dst);
		103	res := TRUE
		104	END
6613	leency	105
7597	akron1	106	RETURN res
		107	END _arrcpy;
		108
		109
		110	PROCEDURE [stdcall] _strcpy* (chr_size, len_dst, dst, len_src, src: INTEGER);
6613	leency	111	BEGIN
7597	akron1	112	_move(MIN(len_dst, len_src) * chr_size, src, dst)
		113	END _strcpy;
6613	leency	114
7597	akron1	115
		116	PROCEDURE [stdcall] _strcpy2* (chr_size, len_src, src, len_dst, dst: INTEGER);
6613	leency	117	BEGIN
7597	akron1	118	_move(MIN(len_dst, len_src) * chr_size, src, dst)
		119	END _strcpy2;
6613	leency	120
7597	akron1	121
		122	PROCEDURE [stdcall] _rot* (VAR A: ARRAY OF INTEGER);
		123	VAR
		124	i, n, k: INTEGER;
		125
6613	leency	126	BEGIN
		127
7597	akron1	128	k := LEN(A) - 1;
		129	n := A[0];
		130	i := 0;
		131	WHILE i < k DO
		132	A[i] := A[i + 1];
		133	INC(i)
		134	END;
		135	A[k] := n
		136
		137	END _rot;
		138
		139
		140	PROCEDURE [stdcall] _set2* (a, b: INTEGER): INTEGER;
		141	VAR
		142	res: INTEGER;
		143
6613	leency	144	BEGIN
7597	akron1	145	IF (a <= b) & (a <= 31) & (b >= 0) THEN
		146	IF b > 31 THEN
		147	b := 31
		148	END;
		149	IF a < 0 THEN
		150	a := 0
		151	END;
		152	res := LSR(ASR(ROR(1, 1), b - a), 31 - b)
		153	ELSE
		154	res := 0
		155	END
6613	leency	156
7597	akron1	157	RETURN res
		158	END _set2;
		159
		160
		161	PROCEDURE [stdcall] _set* (b, a: INTEGER): INTEGER;
		162	RETURN _set2(a, b)
		163	END _set;
		164
		165
		166	PROCEDURE [stdcall] divmod (a, b: INTEGER; VAR mod: INTEGER): INTEGER;
6613	leency	167	BEGIN
7597	akron1	168	SYSTEM.CODE(
6613	leency	169
7597	akron1	170	08BH, 045H, 008H, (* mov eax, dword [ebp + 8] *)
		171	08BH, 04DH, 00CH, (* mov ecx, dword [ebp + 12] *)
		172	031H, 0D2H, (* xor edx, edx *)
		173	085H, 0C0H, (* test eax, eax *)
		174	07DH, 002H, (* jge L1 *)
		175	0F7H, 0D2H, (* not edx *)
		176	(* L1: *)
		177	0F7H, 0F9H, (* idiv ecx *)
		178	08BH, 04DH, 010H, (* mov ecx, dword [ebp + 16] *)
		179	089H, 011H, (* mov dword [ecx], edx *)
		180	0C9H, (* leave *)
		181	0C2H, 00CH, 000H (* ret 12 *)
		182	)
		183
		184	RETURN 0
		185	END divmod;
		186
		187
		188	PROCEDURE div_ (x, y: INTEGER): INTEGER;
		189	VAR
		190	div, mod: INTEGER;
		191
6613	leency	192	BEGIN
7597	akron1	193	div := divmod(x, y, mod);
		194	IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
		195	DEC(div)
		196	END
6613	leency	197
7597	akron1	198	RETURN div
		199	END div_;
		200
		201
		202	PROCEDURE mod_ (x, y: INTEGER): INTEGER;
		203	VAR
		204	div, mod: INTEGER;
		205
6613	leency	206	BEGIN
7597	akron1	207	div := divmod(x, y, mod);
		208	IF (mod # 0) & ((x < 0) & (y > 0) OR (x > 0) & (y < 0)) THEN
		209	INC(mod, y)
		210	END
6613	leency	211
7597	akron1	212	RETURN mod
		213	END mod_;
		214
		215
		216	PROCEDURE [stdcall] _div* (b, a: INTEGER): INTEGER;
		217	RETURN div_(a, b)
		218	END _div;
		219
		220
		221	PROCEDURE [stdcall] _div2* (a, b: INTEGER): INTEGER;
		222	RETURN div_(a, b)
		223	END _div2;
		224
		225
		226	PROCEDURE [stdcall] _mod* (b, a: INTEGER): INTEGER;
		227	RETURN mod_(a, b)
		228	END _mod;
		229
		230
		231	PROCEDURE [stdcall] _mod2* (a, b: INTEGER): INTEGER;
		232	RETURN mod_(a, b)
		233	END _mod2;
		234
		235
		236	PROCEDURE [stdcall] _new* (t, size: INTEGER; VAR ptr: INTEGER);
6613	leency	237	BEGIN
7597	akron1	238	ptr := API._NEW(size);
		239	IF ptr # 0 THEN
		240	SYSTEM.PUT(ptr, t);
		241	INC(ptr, SIZE_OF_DWORD)
		242	END
		243	END _new;
6613	leency	244
7597	akron1	245
		246	PROCEDURE [stdcall] _dispose* (VAR ptr: INTEGER);
6613	leency	247	BEGIN
7597	akron1	248	IF ptr # 0 THEN
		249	ptr := API._DISPOSE(ptr - SIZE_OF_DWORD)
		250	END
		251	END _dispose;
		252
		253
		254	PROCEDURE strncmp (a, b, n: INTEGER): INTEGER;
		255	VAR
		256	A, B: CHAR;
		257	res: INTEGER;
		258
		259	BEGIN
		260	res := 0;
		261	WHILE n > 0 DO
		262	SYSTEM.GET(a, A); INC(a);
		263	SYSTEM.GET(b, B); INC(b);
		264	DEC(n);
		265	IF A # B THEN
		266	res := ORD(A) - ORD(B);
		267	n := 0
		268	ELSIF A = 0X THEN
		269	n := 0
		270	END
		271	END
		272	RETURN res
		273	END strncmp;
		274
		275
		276	PROCEDURE strncmpw (a, b, n: INTEGER): INTEGER;
		277	VAR
		278	A, B: WCHAR;
		279	res: INTEGER;
		280
		281	BEGIN
		282	res := 0;
		283	WHILE n > 0 DO
		284	SYSTEM.GET(a, A); INC(a, 2);
		285	SYSTEM.GET(b, B); INC(b, 2);
		286	DEC(n);
		287	IF A # B THEN
		288	res := ORD(A) - ORD(B);
		289	n := 0
		290	ELSIF A = 0X THEN
		291	n := 0
		292	END
		293	END
		294	RETURN res
		295	END strncmpw;
		296
		297
		298	PROCEDURE [stdcall] _length* (len, str: INTEGER): INTEGER;
		299	BEGIN
		300	SYSTEM.CODE(
		301
		302	08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
		303	08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
		304	048H, (* dec eax *)
		305	(* L1: *)
		306	040H, (* inc eax *)
		307	080H, 038H, 000H, (* cmp byte [eax], 0 *)
		308	074H, 003H, (* jz L2 *)
		309	0E2H, 0F8H, (* loop L1 *)
		310	040H, (* inc eax *)
		311	(* L2: *)
		312	02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
		313	0C9H, (* leave *)
		314	0C2H, 008H, 000H (* ret 08h *)
		315	)
		316
		317	RETURN 0
6613	leency	318	END _length;
		319
7597	akron1	320
		321	PROCEDURE [stdcall] _lengthw* (len, str: INTEGER): INTEGER;
6613	leency	322	BEGIN
7597	akron1	323	SYSTEM.CODE(
6613	leency	324
7597	akron1	325	08BH, 045H, 00CH, (* mov eax, dword [ebp + 0Ch] *)
		326	08BH, 04DH, 008H, (* mov ecx, dword [ebp + 08h] *)
		327	048H, (* dec eax *)
		328	048H, (* dec eax *)
		329	(* L1: *)
		330	040H, (* inc eax *)
		331	040H, (* inc eax *)
		332	066H, 083H, 038H, 000H, (* cmp word [eax], 0 *)
		333	074H, 004H, (* jz L2 *)
		334	0E2H, 0F6H, (* loop L1 *)
		335	040H, (* inc eax *)
		336	040H, (* inc eax *)
		337	(* L2: *)
		338	02BH, 045H, 00CH, (* sub eax, dword [ebp + 0Ch] *)
		339	0D1H, 0E8H, (* shr eax, 1 *)
		340	0C9H, (* leave *)
		341	0C2H, 008H, 000H (* ret 08h *)
		342	)
		343
		344	RETURN 0
		345	END _lengthw;
		346
		347
		348	PROCEDURE [stdcall] _strcmp* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
		349	VAR
		350	res: INTEGER;
		351	bRes: BOOLEAN;
		352
6613	leency	353	BEGIN
7597	akron1	354
		355	res := strncmp(str1, str2, MIN(len1, len2));
		356	IF res = 0 THEN
		357	res := _length(len1, str1) - _length(len2, str2)
		358	END;
		359
		360	CASE op OF
		361	\|0: bRes := res = 0
		362	\|1: bRes := res # 0
		363	\|2: bRes := res < 0
		364	\|3: bRes := res <= 0
		365	\|4: bRes := res > 0
		366	\|5: bRes := res >= 0
		367	END
		368
		369	RETURN bRes
6613	leency	370	END _strcmp;
		371
7597	akron1	372
		373	PROCEDURE [stdcall] _strcmp2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
		374	RETURN _strcmp(op, len2, str2, len1, str1)
		375	END _strcmp2;
		376
		377
		378	PROCEDURE [stdcall] _strcmpw* (op, len2, str2, len1, str1: INTEGER): BOOLEAN;
		379	VAR
		380	res: INTEGER;
		381	bRes: BOOLEAN;
		382
6613	leency	383	BEGIN
		384
7597	akron1	385	res := strncmpw(str1, str2, MIN(len1, len2));
		386	IF res = 0 THEN
		387	res := _lengthw(len1, str1) - _lengthw(len2, str2)
		388	END;
		389
		390	CASE op OF
		391	\|0: bRes := res = 0
		392	\|1: bRes := res # 0
		393	\|2: bRes := res < 0
		394	\|3: bRes := res <= 0
		395	\|4: bRes := res > 0
		396	\|5: bRes := res >= 0
		397	END
		398
		399	RETURN bRes
		400	END _strcmpw;
		401
		402
		403	PROCEDURE [stdcall] _strcmpw2* (op, len1, str1, len2, str2: INTEGER): BOOLEAN;
		404	RETURN _strcmpw(op, len2, str2, len1, str1)
		405	END _strcmpw2;
		406
		407
		408	PROCEDURE PCharToStr (pchar: INTEGER; VAR s: ARRAY OF CHAR);
		409	VAR
		410	c: CHAR;
		411	i: INTEGER;
		412
6613	leency	413	BEGIN
7597	akron1	414	i := 0;
		415	REPEAT
		416	SYSTEM.GET(pchar, c);
		417	s[i] := c;
		418	INC(pchar);
		419	INC(i)
		420	UNTIL c = 0X
		421	END PCharToStr;
6613	leency	422
7597	akron1	423
		424	PROCEDURE IntToStr (x: INTEGER; VAR str: ARRAY OF CHAR);
		425	VAR
		426	i, a, b: INTEGER;
		427	c: CHAR;
		428
6613	leency	429	BEGIN
		430
7597	akron1	431	i := 0;
		432	REPEAT
		433	str[i] := CHR(x MOD 10 + ORD("0"));
		434	x := x DIV 10;
		435	INC(i)
		436	UNTIL x = 0;
6613	leency	437
7597	akron1	438	a := 0;
		439	b := i - 1;
		440	WHILE a < b DO
		441	c := str[a];
		442	str[a] := str[b];
		443	str[b] := c;
		444	INC(a);
		445	DEC(b)
		446	END;
		447	str[i] := 0X
		448	END IntToStr;
		449
		450
		451	PROCEDURE append (VAR s1: ARRAY OF CHAR; s2: ARRAY OF CHAR);
		452	VAR
		453	n1, n2, i, j: INTEGER;
		454	BEGIN
		455	n1 := LENGTH(s1);
		456	n2 := LENGTH(s2);
		457
		458	ASSERT(n1 + n2 < LEN(s1));
		459
6613	leency	460	i := 0;
7597	akron1	461	j := n1;
		462	WHILE i < n2 DO
		463	s1[j] := s2[i];
		464	INC(i);
		465	INC(j)
		466	END;
		467
		468	s1[j] := 0X
		469
		470	END append;
		471
		472
		473	PROCEDURE [stdcall] _error* (module, err: INTEGER);
		474	VAR
		475	s, temp: ARRAY 1024 OF CHAR;
		476
		477	BEGIN
		478
		479	s := "";
		480	CASE err MOD 16 OF
		481	\| 1: append(s, "assertion failure")
		482	\| 2: append(s, "NIL dereference")
		483	\| 3: append(s, "division by zero")
		484	\| 4: append(s, "NIL procedure call")
		485	\| 5: append(s, "type guard error")
		486	\| 6: append(s, "index out of range")
		487	\| 7: append(s, "invalid CASE")
		488	\| 8: append(s, "array assignment error")
		489	\| 9: append(s, "CHR out of range")
		490	\|10: append(s, "WCHR out of range")
		491	\|11: append(s, "BYTE out of range")
		492	END;
		493
		494	append(s, API.eol);
		495
		496	append(s, "module: "); PCharToStr(module, temp); append(s, temp); append(s, API.eol);
		497	append(s, "line: "); IntToStr(LSR(err, 4), temp); append(s, temp);
		498
		499	API.DebugMsg(SYSTEM.ADR(s[0]), name);
		500
		501	API.exit_thread(0)
		502	END _error;
		503
		504
		505	PROCEDURE [stdcall] _isrec* (t0, t1, r: INTEGER): BOOLEAN;
		506	BEGIN
		507	(* r IS t0 *)
		508
		509	WHILE (t1 # 0) & (t1 # t0) DO
		510	SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
6613	leency	511	END
		512
7597	akron1	513	RETURN t1 = t0
		514	END _isrec;
		515
		516
		517	PROCEDURE [stdcall] _is* (t0, p: INTEGER): BOOLEAN;
		518	VAR
		519	t1: INTEGER;
		520
6613	leency	521	BEGIN
7597	akron1	522	(* p IS t0 *)
6613	leency	523
7597	akron1	524	IF p # 0 THEN
		525	DEC(p, SIZE_OF_DWORD);
		526	SYSTEM.GET(p, t1);
		527	WHILE (t1 # 0) & (t1 # t0) DO
		528	SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
		529	END
		530	ELSE
		531	t1 := -1
		532	END
		533
		534	RETURN t1 = t0
		535	END _is;
		536
		537
		538	PROCEDURE [stdcall] _guardrec* (t0, t1: INTEGER): BOOLEAN;
6613	leency	539	BEGIN
7597	akron1	540	(* r:t1 IS t0 *)
6613	leency	541
7597	akron1	542	WHILE (t1 # 0) & (t1 # t0) DO
		543	SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
		544	END
		545
		546	RETURN t1 = t0
		547	END _guardrec;
		548
		549
		550	PROCEDURE [stdcall] _guard* (t0, p: INTEGER): BOOLEAN;
		551	VAR
		552	t1: INTEGER;
		553
6613	leency	554	BEGIN
7597	akron1	555	(* p IS t0 *)
		556	SYSTEM.GET(p, p);
		557	IF p # 0 THEN
		558	DEC(p, SIZE_OF_DWORD);
		559	SYSTEM.GET(p, t1);
		560	WHILE (t1 # t0) & (t1 # 0) DO
		561	SYSTEM.GET(types + t1 * SIZE_OF_DWORD, t1)
		562	END
		563	ELSE
		564	t1 := t0
		565	END
6613	leency	566
7597	akron1	567	RETURN t1 = t0
		568	END _guard;
		569
		570
		571	PROCEDURE [stdcall] _dllentry* (hinstDLL, fdwReason, lpvReserved: INTEGER): INTEGER;
		572	VAR
		573	res: INTEGER;
		574
6613	leency	575	BEGIN
7597	akron1	576	CASE fdwReason OF
		577	\|DLL_PROCESS_ATTACH:
		578	res := 1
		579	\|DLL_THREAD_ATTACH:
		580	res := 0;
		581	IF dll.thread_attach # NIL THEN
		582	dll.thread_attach(hinstDLL, fdwReason, lpvReserved)
		583	END
		584	\|DLL_THREAD_DETACH:
		585	res := 0;
		586	IF dll.thread_detach # NIL THEN
		587	dll.thread_detach(hinstDLL, fdwReason, lpvReserved)
		588	END
		589	\|DLL_PROCESS_DETACH:
		590	res := 0;
		591	IF dll.process_detach # NIL THEN
		592	dll.process_detach(hinstDLL, fdwReason, lpvReserved)
		593	END
		594	ELSE
		595	res := 0
		596	END
6613	leency	597
7597	akron1	598	RETURN res
		599	END _dllentry;
		600
		601
		602	PROCEDURE SetDll* (process_detach, thread_detach, thread_attach: DLL_ENTRY);
		603	BEGIN
		604	dll.process_detach := process_detach;
		605	dll.thread_detach := thread_detach;
		606	dll.thread_attach := thread_attach
		607	END SetDll;
		608
		609
		610	PROCEDURE [stdcall] _exit* (code: INTEGER);
		611	BEGIN
		612	API.exit(code)
		613	END _exit;
		614
		615
		616	PROCEDURE [stdcall] _init* (modname: INTEGER; typesc, _types: INTEGER; code, param: INTEGER);
		617	BEGIN
		618	SYSTEM.CODE(09BH, 0DBH, 0E3H); (* finit *)
		619	API.init(param, code);
		620
		621	types := _types;
		622	name := modname;
		623
		624	dll.process_detach := NIL;
		625	dll.thread_detach := NIL;
		626	dll.thread_attach := NIL;
		627	END _init;
		628
		629
6613	leency	630	END RTL.

Subversion Repositories Kolibri OS

(root)/programs/develop/oberon07/Lib/KolibriOS/RTL.ob07 – Rev 7597