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

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

Subversion Repositories Kolibri OS

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