Context Navigation

function.sbp@ 356

Last change on this file since 356 was 355, checked in by イグトランス (egtra), 17 years ago
FormatIntegerDを実装。 UnitTestの失敗時の表示を目立つようにした。 ArrayListを名前空間System.Collectionsに入れた。
File size: 23.3 KB

Line
1	'function.sbp
2
3
4	#ifndef _INC_FUNCTION
5	#define _INC_FUNCTION
6
7
8	Const _System_PI = 3.14159265358979323846264
9	Const _System_LOG2 = 0.6931471805599453094172321214581765680755
10	Const _System_SQRT2 = 1.41421356237309504880168872421
11	Const _System_Log_N = 7 As Long
12
13
14	#require <Classes/System/Math.ab>
15	#require <Classes/System/DateTime.ab>
16	#require <Classes/System/Text/StringBuilder.ab>
17	#require <Classes/ActiveBasic/Math/Math.ab>
18	#require <Classes/ActiveBasic/Strings/Strings.ab>
19
20
21	'------------- サポート関数の定義 -------------
22
23	Function ldexp(x As Double, n As Long) As Double
24	If x = 0 Then
25	ldexp = 0
26	Exit Function
27	End If
28	Dim pSrc = VarPtr(x) As *QWord
29	Dim pDest = VarPtr(ldexp) As *QWord
30	n += (pSrc[0] >> 52) As DWord And &h7FF
31	pDest[0] = n << 52 Or (pSrc[0] And &h800FFFFFFFFFFFFF)
32	End Function
33
34	Function frexp(x As Double, ByRef n As Long) As Double
35	If x = 0 Then
36	n = 0
37	frexp = 0
38	Exit Function
39	End If
40
41	Dim pSrc = VarPtr(x) As *QWord
42	Dim pDest = VarPtr(frexp) As *QWord
43	n = ((pSrc[0] >> 52) As DWord And &h7FF) - 1022
44	pDest[0] = (pSrc[0] And &h800FFFFFFFFFFFFF) Or &h3FE0000000000000
45	End Function
46
47	Function frexp(x As Single, ByRef n As Long) As Single
48	If x = 0 Then
49	n = 0
50	frexp = 0
51	Exit Function
52	End If
53
54	Dim pSrc As DWord, pDest As DWord
55	pSrc = VarPtr(x) As *DWord
56	pDest = VarPtr(frexp) As *DWord
57	n = ((pSrc[0] >> 23) And &hFF) - 126
58	pDest[0] = (pSrc[0] And &h807FFFFF) Or &h7E000000
59	End Function
60
61	Function ipow(x As Double, n As Long) As Double
62	Dim abs_n As Long
63	Dim r = 1 As Double
64
65	abs_n=Abs(n) As Long
66	While abs_n<>0
67	If abs_n and 1 Then r *= x
68	x = x * x
69	abs_n >>= 1 ' abs_n \= 2
70	Wend
71
72	If n>=0 Then
73	ipow=r
74	Else
75	ipow=1/r
76	End If
77	End Function
78
79	Function pow(x As Double, y As Double) As Double
80	If -LONG_MAX<=y and y<=LONG_MAX and y=CDbl(Int(y)) Then
81	pow=ipow(x,y As Long)
82	Exit Function
83	End If
84
85	If x>0 Then
86	pow=Exp(y*Log(x))
87	Exit Function
88	End If
89
90	If x<>0 or y<=0 Then
91	'error
92	End If
93
94	pow=0
95	End Function
96
97	Const RAND_MAX = &H7FFFFFFF
98	Dim _System_RndNext = 1 As DWord
99
100	Function rand() As Long
101	_System_RndNext = _System_RndNext * 1103515245 + 12345
102	rand = (_System_RndNext >> 1) As Long
103	End Function
104
105	Sub srand(dwSeek As DWord)
106	_System_RndNext = dwSeek
107	End Sub
108
109
110	'------------- ここからBasic標準関数の定義 -------------
111
112	'------------------
113	' データ型変換関数
114	'------------------
115
116	Function CDbl(number As Double) As Double
117	CDbl=number
118	End Function
119
120	Function _CUDbl(number As QWord) As Double
121	_CUDbl=number As Double
122	End Function
123
124	Function CDWord(num As Double) As DWord
125	CDWord=num As DWord
126	End Function
127
128	Function CInt(number As Double) As Long
129	CInt=number As Long
130	End Function
131
132	Function CSng(number As Double) As Single
133	CSng=number As Single
134	End Function
135
136	#ifdef _WIN64
137	Function Fix(number As Double) As Long
138	Fix=number As Long
139	End Function
140	#else
141	'Fix関数はコンパイラに組み込まれている
142	'Function Fix(number As Double) As Long
143	#endif
144
145	Function Int(number As Double) As Long
146	Int = Fix(number)
147	If number < 0 Then
148	If number < Fix(number) Then Int--
149	End If
150	End Function
151
152
153	'-------------------------------------
154	' ポインタ関数（コンパイラに組み込み）
155	'-------------------------------------
156
157	'Function GetDouble(p As DWord) As Double
158	'Function GetSingle(p As DWord) As Single
159	'Function GetDWord(p As DWord) As DWord
160	'Function GetWord(p As DWord) As Word
161	'Function GetByte(p As DWord) As Byte
162	'Sub SetDouble(p As DWord, dblData As Double)
163	'Sub SetSingle(p As DWord, fltData As Single)
164	'Sub SetDWord(p As DWord, dwData As DWord)
165	'Sub SetWord(p As DWord, wData As Word)
166	'Sub SetByte(p As DWord, byteData As Byte)
167
168
169	'----------
170	' 算術関数
171	'----------
172
173	Function Abs(number As Double) As Double
174	'Abs = System.Math.Abs(number)
175	If number < 0 then
176	return -number
177	Else
178	return number
179	End If
180	End Function
181
182	Function Exp(x As Double) As Double
183	Exp = System.Math.Exp(x)
184	End Function
185
186	Function Log(x As Double) As Double
187	Log = System.Math.Log(x)
188	End Function
189
190	Function Sgn(number As Double) As Long
191	Sgn = System.Math.Sign(number)
192	End Function
193
194	Function Sqr(number As Double) As Double
195	Sqr = System.Math.Sqrt(number)
196	End Function
197
198	Function Atn(number As Double) As Double
199	Atn = System.Math.Atan(number)
200	End Function
201
202	Function Atn2(y As Double, x As Double) As Double
203	Atn2 = System.Math.Atan2(y, x)
204	End Function
205
206	Function Sin(number As Double) As Double
207	Sin = System.Math.Sin(number)
208	End Function
209
210	Function Cos(number As Double) As Double
211	Cos = System.Math.Cos(number)
212	End Function
213
214	Function Tan(number As Double) As Double
215	Tan = System.Math.Tan(number)
216	End Function
217
218	Const RAND_UNIT = (1.0 / (LONG_MAX + 1.0))
219	Function Rnd() As Double
220	Rnd = RAND_UNIT * rand()
221	End Function
222
223	Const HIDWORD(qw) = (((qw As QWord) >> 32) And &HFFFFFFFF) As DWord
224	Const LODWORD(qw) = ((qw As QWord) And &HFFFFFFFF) As DWord
225
226	Const MAKEDWORD(l, h) = (((l As DWord) And &HFFFF) Or (((h As DWord) And &HFFFF) << 16)) As DWord
227	Const MAKEQWORD(l, h) = (((l As QWord) And &HFFFFFFFF) Or (((h As QWord) And &HFFFFFFFF) << 32)) As QWord
228
229	'------------
230	' 文字列関数
231	'------------
232
233	Function Asc(buf As *StrChar) As StrChar
234	Asc = buf[0]
235	End Function
236
237	Function Chr$(code As StrChar) As String
238	Chr$ = New String(code, 1)
239	End Function
240
241	#ifndef __STRING_IS_NOT_UNICODE
242	Function AscW(s As *WCHAR) As UCSCHAR
243	If s.Length = 0 Then
244	AscW = 0
245	Else
246	If _System_IsSurrogatePair(s[0], s[1]) Then
247	AscW = ((s[0] And &h3FF) As DWord << 10) Or (s[1] And &h3FF)
248	Else
249	AscW = s[0]
250	End If
251	End If
252	End Function
253
254	Function ChrW(c As UCSCHAR) As String
255	If c <= &hFFFF Then
256	Return New String(c As StrChar, 1)
257	ElseIf c < &h10FFFF Then
258	Dim t[1] = [&hD800 Or (c >> 10), &hDC00 Or (c And &h3FF)] As StrChar
259	Return New String(t, 2)
260	Else
261	'ArgumentOutOfRangeException
262	End If
263	End Function
264	#endif
265
266	Function Date$() As String
267	Dim date = System.DateTime.Now
268	Dim buf = New System.Text.StringBuilder(10)
269
270	'year
271	buf.Append(date.Year)
272
273	'month
274	If date.Month < 10 Then
275	buf.Append("/0")
276	Else
277	buf.Append("/")
278	End If
279	buf.Append(date.Month)
280
281	'day
282	If date.Day < 10 Then
283	buf.Append("/0")
284	Else
285	buf.Append("/")
286	End If
287	buf.Append(date.Day)
288
289	Date$ = buf.ToString
290	End Function
291
292	Dim _System_HexadecimalTable[&h10] = [&h30, &h31, &h32, &h33, &h34, &h35, &h36, &h37, &h38, &h39, &h41, &h42, &h43, &h44, &h45, &h46] As Byte
293
294	Function _System_Hex(x As DWord, zeroSuppress As Boolean) As String
295	Dim s[7] As StrChar
296	Dim i As Long
297	For i = 0 To ELM(Len (s) \ SizeOf (StrChar))
298	s[i] = _System_HexadecimalTable[x >> 28] As StrChar
299	x <<= 4
300	Next
301	If zeroSuppress Then
302	Dim i As Long
303	For i = 0 To 6
304	If s[i] <> &h30 Then 'Asc("0")
305	Exit For
306	End If
307	Next
308	Return New String(VarPtr(s[i]) As *StrChar, Len (s) \ SizeOf (StrChar) - i)
309	Else
310	Return New String(s As *StrChar, Len (s) \ SizeOf (StrChar))
311	End If
312	End Function
313
314	Function Hex$(x As DWord) As String
315	Hex$ = _System_Hex(x, True)
316	End Function
317
318	Function Hex$(x As QWord) As String
319	If HIDWORD(x) = 0 Then
320	Hex$ = _System_Hex(LODWORD(x), True)
321	Else
322	Hex$ = _System_Hex(HIDWORD(x), True) + _System_Hex(LODWORD(x), False)
323	End If
324	End Function
325
326	Function InStr(StartPos As Long, buf1 As String, buf2 As String) As Long
327	Dim i As Long, i2 As Long, i3 As Long
328
329	Dim len1 = buf1.Length
330	Dim len2 = buf2.Length
331
332	If len2=0 Then
333	InStr=StartPos
334	Exit Function
335	End If
336
337	StartPos--
338	If StartPos<0 Then
339	'error
340	InStr=0
341	Exit Function
342	End If
343
344	i=StartPos:InStr=0
345	While i<=len1-len2
346	i2=i:i3=0
347	Do
348	If i3=len2 Then
349	InStr=i+1
350	Exit Do
351	End If
352	If buf1[i2]<>buf2[i3] Then Exit Do
353
354	i2++
355	i3++
356	Loop
357	If InStr Then Exit While
358	i++
359	Wend
360	End Function
361
362	Function Left$(s As String, length As Long) As String
363	Left$ = s.Substring(0, System.Math.Min(s.Length, length))
364	End Function
365
366	Function Mid$(s As String, startPos As Long) As String
367	startPos--
368	Mid$ = s.Substring(startPos)
369	End Function
370
371	Function Mid$(s As String, startPos As Long, readLength = 0 As Long) As String
372	startPos--
373	Dim length = s.Length
374	Mid$ = s.Substring(System.Math.Min(startPos, length), System.Math.Min(readLength, length - startPos))
375	End Function
376
377	Const _System_MaxFigure_Oct_QW = 22 As DWord 'QWORD_MAX = &o1,777,777,777,777,777,777,777
378	Function Oct$(n As QWord) As String
379	Dim s[ELM(_System_MaxFigure_Oct_QW)] As StrChar
380	Dim i = ELM(_System_MaxFigure_Oct_QW) As Long
381	Do
382	s[i] = ((n And &o7) + &h30) As StrChar '&h30 = Asc("0")
383	n >>= 3
384	If n = 0 Then
385	Return New String(s + i, _System_MaxFigure_Oct_QW - i)
386	End If
387	i--
388	Loop
389	End Function
390
391	Const _System_MaxFigure_Oct_DW = 11 As DWord 'DWORD_MAX = &o37,777,777,777
392	Function Oct$(n As DWord) As String
393	Dim s[ELM(_System_MaxFigure_Oct_DW)] As StrChar
394	Dim i = ELM(_System_MaxFigure_Oct_DW) As Long
395	Do
396	s[i] = ((n And &o7) + &h30) As StrChar '&h30 = Asc("0")
397	n >>= 3
398	If n = 0 Then
399	Return New String(s + i, _System_MaxFigure_Oct_DW - i)
400	End If
401	i--
402	Loop
403	End Function
404
405	Function Right$(s As String, length As Long) As String
406	Right$ = s.Substring(System.Math.Max(0, s.Length - length), s.Length)
407	End Function
408
409	Function Space$(length As Long) As String
410	Return New String(&h20 As StrChar, length)
411	End Function
412
413	Dim _System_ecvt_buffer[16] As StrChar
414	Sub _ecvt_support(count As Long)
415	Dim i As Long
416	If _System_ecvt_buffer[count]=9 Then
417	_System_ecvt_buffer[count]=0
418	If count=0 Then
419	For i=16 To 1 Step -1
420	_System_ecvt_buffer[i]=_System_ecvt_buffer[i-1]
421	Next
422	_System_ecvt_buffer[0]=1
423	Else
424	_ecvt_support(count-1)
425	End If
426	Else
427	_System_ecvt_buffer[count]++
428	End If
429	End Sub
430	Function _ecvt(value As Double, count As Long, ByRef dec As Long, ByRef sign As Long) As *StrChar
431	Dim i As Long, i2 As Long
432
433	_ecvt=_System_ecvt_buffer
434
435	'値が0の場合
436	If value = 0 Then
437	ActiveBasic.Strings.ChrFill(_System_ecvt_buffer, count As SIZE_T, &H30 As StrChar)
438	_System_ecvt_buffer[count] = 0
439	dec = 0
440	sign = 0
441	Exit Function
442	End If
443
444	'符号の判断（同時に符号を取り除く）
445	If value < 0 Then
446	sign = 1
447	value = -value
448	Else
449	sign = 0
450	End If
451
452	'正規化
453	dec = 1
454	While value < 0.999999999999999 'value<1
455	value *= 10
456	dec--
457	Wend
458	While 9.99999999999999 <= value '10<=value
459	value /= 10
460	dec++
461	Wend
462
463	For i=0 To count-1
464	_System_ecvt_buffer[i] = Int(value) As StrChar
465
466	value = (value-CDbl(Int(value))) * 10
467	Next
468	_System_ecvt_buffer[i] = 0
469
470	i--
471	If value >= 5 Then
472	'切り上げ処理
473	_ecvt_support(i)
474	End If
475
476	For i=0 To ELM(count)
477	_System_ecvt_buffer[i] += &H30
478	Next
479	_System_ecvt_buffer[i] = 0
480	End Function
481
482	Function Str$(dbl As Double) As String
483	If ActiveBasic.Math.IsNaN(dbl) Then
484	Return "NaN"
485	ElseIf ActiveBasic.Math.IsInf(dbl) Then
486	If dbl > 0 Then
487	Return "Infinity"
488	Else
489	Return "-Infinity"
490	End If
491	End If
492	Dim dec As Long, sign As Long
493	Dim buffer[32] As StrChar, temp As *StrChar
494	Dim i As Long, i2 As Long, i3 As Long
495
496	'浮動小数点を文字列に変換
497	temp = _ecvt(dbl, 15, dec, sign)
498
499	i=0
500
501	'符号の取り付け
502	If sign Then
503	buffer[i] = Asc("-")
504	i++
505	End If
506
507	If dec>15 Then
508	'指数表示（桁が大きい場合）
509	buffer[i] = temp[0]
510	i++
511	buffer[i] = Asc(".")
512	i++
513	ActiveBasic.Strings.ChrCopy(VarPtr(buffer[i]), VarPtr(temp[1]), 14 As SIZE_T)
514	i += 14
515	buffer[i] = Asc("e")
516	i++
517	_stprintf(VarPtr(buffer[i]), "+%03d", dec - 1) 'ToDo: __STRING_UNICODE_WINDOWS_ANSI状態への対応
518
519	Return MakeStr(buffer)
520	End If
521
522	If dec < -3 Then
523	'指数表示（桁が小さい場合）
524	buffer[i] = temp[0]
525	i++
526	buffer[i] = Asc(".")
527	i++
528	ActiveBasic.Strings.ChrCopy(VarPtr(buffer[i]), VarPtr(temp[1]), 14 As SIZE_T)
529	i+=14
530	buffer[i] = Asc("e")
531	i++
532	_stprintf(VarPtr(buffer[i]), "+%03d", dec - 1) 'ToDo: __STRING_UNICODE_WINDOWS_ANSI状態への対応
533
534	Return MakeStr(buffer)
535	End If
536
537	'整数部
538	i2=dec
539	i3=0
540	If i2>0 Then
541	While i2>0
542	buffer[i]=temp[i3]
543	i++
544	i3++
545	i2--
546	Wend
547	buffer[i]=Asc(".")
548	i++
549	Else
550	buffer[i]=&H30
551	i++
552	buffer[i]=Asc(".")
553	i++
554
555	i2=dec
556	While i2<0
557	buffer[i]=&H30
558	i++
559	i2++
560	Wend
561	End If
562
563	'小数部
564	While i3<15
565	buffer[i]=temp[i3]
566	i++
567	i3++
568	Wend
569
570	While buffer[i-1]=&H30
571	i--
572	Wend
573	If buffer[i-1]=Asc(".") Then i--
574
575	buffer[i]=0
576	Return MakeStr(buffer)
577	End Function
578
579	Function Str$(i As Int64) As String
580	If i < 0 Then
581	Return "-" & Str$(-i As QWord)
582	Else
583	Return Str$(i As QWord)
584	End If
585	End Function
586
587	Function Str$(x As QWord) As String
588	If x = 0 Then
589	Return "0"
590	End If
591
592	Dim buf[20] As StrChar
593	'buf[20] = 0
594	Dim i = 19 As Long
595	Do
596	buf[i] = (x Mod 10 + &h30) As StrChar
597	x \= 10
598	If x = 0 Then
599	Exit Do
600	End If
601	i--
602	Loop
603	Return New String(VarPtr(buf[i]), 20 - i)
604	End Function
605
606	Function Str$(x As Long) As String
607	#ifdef _WIN64
608	Return Str$(x As Int64)
609	#else
610	If x < 0 Then
611	Return "-" & Str$(-x As DWord)
612	Else
613	Return Str$(x As DWord)
614	End If
615	#endif
616	End Function
617
618	Function Str$(x As DWord) As String
619	#ifdef _WIN64
620	Return Str$(x As QWord)
621	#else
622	If x = 0 Then
623	Return "0"
624	End If
625
626	Dim buf[10] As StrChar
627	buf[10] = 0
628	Dim i = 9 As Long
629	Do
630	buf[i] = (x As Int64 Mod 10 + &h30) As StrChar 'Int64への型変換は#117対策
631	x \= 10
632	If x = 0 Then
633	Return New String(VarPtr(buf[i]), 10 - i)
634	End If
635	i--
636	Loop
637	#endif
638	End Function
639
640	Function Str$(x As Word) As String
641	Return Str$(x As ULONG_PTR)
642	End Function
643
644	Function Str$(x As Integer) As String
645	Return Str$(x As LONG_PTR)
646	End Function
647
648	Function Str$(x As Byte) As String
649	Return Str$(x As ULONG_PTR)
650	End Function
651
652	Function Str$(x As SByte) As String
653	Return Str$(x As LONG_PTR)
654	End Function
655
656	Function Str$(x As Single) As String
657	Return Str$(x As Double)
658	End Function
659
660	Function Str$(b As Boolean) As String
661	If b Then
662	Return "True"
663	Else
664	Return "False"
665	End If
666	End Function
667
668	Function String$(n As Long, s As StrChar) As String
669	Return New String(s, n)
670	End Function
671
672	#ifdef _AB4_COMPATIBILITY_STRING$_
673	Function String$(n As Long, s As String) As String
674	If n < 0 Then
675	'Throw ArgumentOutOfRangeException
676	End If
677
678	Dim buf = New System.Text.StringBuilder(s.Length * n)
679	Dim i As Long
680	For i = 0 To n
681	buf.Append(s)
682	Next
683	End Function
684	#else
685	Function String$(n As Long, s As String) As String
686	If String.IsNullOrEmpty(s) Then
687	Return New String(0 As StrChar, n)
688	Else
689	Return New String(s[0], n)
690	End If
691	End Function
692	#endif
693
694	Function Time$() As String
695	Dim time = System.DateTime.Now
696
697	Dim buf = New System.Text.StringBuilder(8)
698
699	'hour
700	If time.Hour < 10 Then
701	buf.Append("0")
702	End If
703	buf.Append(time.Hour)
704
705	'minute
706	If time.Minute < 10 Then
707	buf.Append(":0")
708	Else
709	buf.Append(":")
710	End If
711	buf.Append(time.Minute)
712
713	'second
714	If time.Second < 10 Then
715	buf.Append(":0")
716	Else
717	buf.Append(":")
718	End If
719	buf.Append(time.Second)
720	Time$ = buf.ToString
721	End Function
722
723	Function Val(buf As *StrChar) As Double
724	Dim i As Long, i2 As Long, i3 As Long, i4 As Long
725	Dim temporary As String
726	Dim TempPtr As *StrChar
727	Dim dbl As Double
728	Dim i64data As Int64
729
730	Val=0
731
732	While buf[0]=Asc(" ") or buf[0]=Asc(Ex"\t")
733	buf = VarPtr(buf[1])
734	Wend
735
736	If buf[0]=Asc("&") Then
737	temporary = New String( buf )
738	temporary = temporary.ToUpper()
739	TempPtr = StrPtr(temporary)
740	If TempPtr(1)=Asc("O") Then
741	'8進数
742	i=2
743	While 1
744	'数字以外の文字の場合は抜け出す
745	i3=TempPtr[i]-&H30
746	If Not (0<=i3 And i3<=7) Then Exit While
747
748	TempPtr[i]=i3 As StrChar
749	i++
750	Wend
751	i--
752
753	i64data=1
754	While i>=2
755	Val += ( i64data * TempPtr[i] ) As Double
756
757	i64data *= &O10
758	i--
759	Wend
760	ElseIf TempPtr(1)=Asc("H") Then
761	'16進数
762	i=2
763	While 1
764	'数字以外の文字の場合は抜け出す
765	i3=TempPtr[i]-&H30
766	If Not(0<=i3 and i3<=9) Then
767	i3=TempPtr[i]-&H41+10
768	If Not(&HA<=i3 and i3<=&HF) Then Exit While
769	End If
770
771	TempPtr[i]=i3 As StrChar
772	i++
773	Wend
774	i--
775
776	i64data=1
777	While i>=2
778	Val += (i64data*TempPtr[i]) As Double
779
780	i64data *= &H10
781	i--
782	Wend
783	End If
784	Else
785	'10進数
786	sscanf(buf,"%lf",VarPtr(Val))
787	End If
788	End Function
789
790
791	'--------------
792	' ファイル関数
793	'--------------
794
795	Function Eof(FileNum As Long) As Long
796	Dim dwCurrent As DWord, dwEnd As DWord
797
798	FileNum--
799
800	dwCurrent=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_CURRENT)
801	dwEnd=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_END)
802	SetFilePointer(_System_hFile(FileNum),dwCurrent,NULL,FILE_BEGIN)
803
804	If dwCurrent>=dwEnd Then
805	Eof=-1
806	Else
807	Eof=0
808	End If
809	End Function
810
811	Function Lof(FileNum As Long) As Long
812	Lof = GetFileSize(_System_hFile(FileNum-1), 0)
813	End Function
814
815	Function Loc(FileNum As Long) As Long
816	FileNum--
817
818	Dim NowPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_CURRENT)
819	Dim BeginPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_BEGIN)
820	SetFilePointer(_System_hFile(FileNum), NowPos - BeginPos, 0, FILE_BEGIN)
821
822	Loc = NowPos - BeginPos
823	End Function
824
825
826	'------------------
827	' メモリ関連の関数
828	'------------------
829
830	Function malloc(stSize As SIZE_T) As VoidPtr
831	Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC)
832	End Function
833
834	Function calloc(stSize As SIZE_T) As VoidPtr
835	Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC or _System_GC_FLAG_INITZERO)
836	End Function
837
838	Function realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
839	If lpMem = 0 Then
840	Return malloc(stSize)
841	Else
842	Return _System_pGC->__realloc(lpMem,stSize)
843	End If
844	End Function
845
846	Sub free(lpMem As VoidPtr)
847	_System_pGC->__free(lpMem)
848	End Sub
849
850	Function _System_malloc(stSize As SIZE_T) As VoidPtr
851	Return HeapAlloc(_System_hProcessHeap,0,stSize)
852	End Function
853
854	Function _System_calloc(stSize As SIZE_T) As VoidPtr
855	Return HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,stSize)
856	End Function
857
858	Function _System_realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
859	If lpMem = 0 Then
860	Return HeapAlloc(_System_hProcessHeap, 0, stSize)
861	Else
862	Return HeapReAlloc(_System_hProcessHeap, 0, lpMem, stSize)
863	End If
864	End Function
865
866	Sub _System_free(lpMem As VoidPtr)
867	HeapFree(_System_hProcessHeap,0,lpMem)
868	End Sub
869
870
871	'--------
872	' その他
873	'--------
874
875	Sub _splitpath(path As PCSTR, drive As PSTR, dir As PSTR, fname As PSTR, ext As PSTR)
876	Dim i As Long, i2 As Long, i3 As Long, length As Long
877	Dim buffer[MAX_PATH] As SByte
878
879	'":\"をチェック
880	If not(path[1]=&H3A and path[2]=&H5C) Then Exit Sub
881
882	'ドライブ名をコピー
883	If drive Then
884	drive[0]=path[0]
885	drive[1]=path[1]
886	drive[2]=0
887	End If
888
889	'ディレクトリ名をコピー
890	i=2
891	i2=0
892	Do
893	If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
894	If dir Then
895	dir[i2]=path[i]
896	dir[i2+1]=path[i+1]
897	End If
898
899	i += 2
900	i2 += 2
901	Continue
902	End If
903
904	If path[i]=0 Then Exit Do
905
906	If path[i]=&H5C Then '"\"記号であるかどうか
907	i3=i2+1
908	End If
909
910	If dir Then dir[i2]=path[i]
911
912	i++
913	i2++
914	Loop
915	If dir Then dir[i3]=0
916	i3 += i-i2
917
918	'ファイル名をコピー
919	i=i3
920	i2=0
921	i3=-1
922	Do
923	'#ifdef UNICODE
924	' If _System_IsSurrogatePair(path[i], path[i + 1]) Then
925	'#else
926	If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
927	'#endif
928	If fname Then
929	fname[i2]=path[i]
930	fname[i2+1]=path[i+1]
931	End If
932
933	i += 2
934	i2 += 2
935	Continue
936	End If
937
938	If path[i]=0 Then Exit Do
939
940	If path[i]=&H2E Then '.'記号であるかどうか
941	i3=i2
942	End If
943
944	If fname Then fname[i2]=path[i]
945
946	i++
947	i2++
948	Loop
949	If i3=-1 Then i3=i2
950	If fname Then fname[i3]=0
951	i3 += i-i2
952
953	'拡張子名をコピー
954	If ext Then
955	If i3 Then
956	lstrcpy(ext,path+i3)
957	End If
958	else ext[0]=0
959	End If
960	End Sub
961
962	Function GetBasicColor(ColorCode As Long) As Long
963	Select Case ColorCode
964	Case 0
965	GetBasicColor=RGB(0,0,0)
966	Case 1
967	GetBasicColor=RGB(0,0,255)
968	Case 2
969	GetBasicColor=RGB(255,0,0)
970	Case 3
971	GetBasicColor=RGB(255,0,255)
972	Case 4
973	GetBasicColor=RGB(0,255,0)
974	Case 5
975	GetBasicColor=RGB(0,255,255)
976	Case 6
977	GetBasicColor=RGB(255,255,0)
978	Case 7
979	GetBasicColor=RGB(255,255,255)
980	End Select
981	End Function
982
983	Function _System_BSwap(x As Word) As Word
984	Dim src = VarPtr(x) As *Byte
985	Dim dst = VarPtr(_System_BSwap) As *Byte
986	dst[0] = src[1]
987	dst[1] = src[0]
988	End Function
989
990	Function _System_BSwap(x As DWord) As DWord
991	Dim src = VarPtr(x) As *Byte
992	Dim dst = VarPtr(_System_BSwap) As *Byte
993	dst[0] = src[3]
994	dst[1] = src[2]
995	dst[2] = src[1]
996	dst[3] = src[0]
997	End Function
998
999	Function _System_BSwap(x As QWord) As QWord
1000	Dim src = VarPtr(x) As *Byte
1001	Dim dst = VarPtr(_System_BSwap) As *Byte
1002	dst[0] = src[7]
1003	dst[1] = src[6]
1004	dst[2] = src[5]
1005	dst[3] = src[4]
1006	dst[4] = src[3]
1007	dst[5] = src[2]
1008	dst[6] = src[1]
1009	dst[7] = src[0]
1010	End Function
1011
1012	Function _System_HashFromPtr(p As VoidPtr) As Long
1013	#ifdef _WIN64
1014	Dim qw = p As QWord
1015	Return (HIDWORD(qw) Xor LODWORD(qw)) As Long
1016	#else
1017	Return p As Long
1018	#endif
1019	End Function
1020
1021	/*!
1022	@brief ABオブジェクトを指すポインタをObject型へ変換。
1023	@author Egtra
1024	@date 2007/08/24
1025	@param[in] p COMインタフェースを指すポインタ
1026	@return Object参照型
1027	*/
1028	Function _System_PtrObj(p As VoidPtr) As Object
1029	SetPointer(VarPtr(_System_PtrObj), p)
1030	End Function
1031
1032	/*!
1033	@brief IUnknownその他COMインタフェースを指すポインタをIUnknown参照型へ変換。
1034	@author Egtra
1035	@date 2007/09/24
1036	@param[in] p COMインタフェースを指すポインタ
1037	@return IUnknown参照型
1038	*/
1039	Function _System_PtrUnknown(p As VoidPtr) As IUnknown
1040	SetPointer(VarPtr(_System_PtrUnknown), p)
1041	End Function
1042
1043	'--------
1044	' 文字列関数その2
1045	'--------
1046	Function _System_IsSurrogatePair(wcHigh As WCHAR, wcLow As WCHAR) As Boolean
1047	If &hD800 <= wcHigh And wcHigh < &hDC00 Then
1048	If &hDC00 <= wcLow And wcLow < &hE000 Then
1049	Return True
1050	End If
1051	End If
1052	Return False
1053	End Function
1054
1055	Function _System_IsDoubleUnitChar(lead As WCHAR, trail As WCHAR) As Boolean
1056	Return _System_IsSurrogatePair(lead, trail)
1057	End Function
1058
1059	Function _System_IsDoubleUnitChar(lead As SByte, trail As SByte) As Boolean
1060	Return IsDBCSLeadByte(lead) <> FALSE
1061	End Function
1062
1063	Function _System_ASCII_IsUpper(c As WCHAR) As Boolean
1064	Return c As DWord - &h41 < 26 ' &h41 = Asc("A")
1065	End Function
1066
1067	Function _System_ASCII_IsUpper(c As SByte) As Boolean
1068	Return _System_ASCII_IsUpper(c As Byte As WCHAR)
1069	End Function
1070
1071	Function _System_ASCII_IsLower(c As WCHAR) As Boolean
1072	Return c As DWord - &h61 < 26 ' &h61 = Asc("a")
1073	End Function
1074
1075	Function _System_ASCII_IsLower(c As SByte) As Boolean
1076	Return _System_ASCII_IsLower(c As Byte As WCHAR)
1077	End Function
1078
1079	Function _System_ASCII_ToLower(c As WCHAR) As WCHAR
1080	If _System_ASCII_IsUpper(c) Then
1081	Return c Or &h20
1082	Else
1083	Return c
1084	End If
1085	End Function
1086
1087	Function _System_ASCII_ToLower(c As SByte) As SByte
1088	Return _System_ASCII_ToLower(c As Byte As WCHAR) As Byte As SByte
1089	End Function
1090
1091	Function _System_ASCII_ToUpper(c As WCHAR) As WCHAR
1092	If _System_ASCII_IsLower(c) Then
1093	Return c And (Not &h20)
1094	Else
1095	Return c
1096	End If
1097	End Function
1098
1099	Function _System_ASCII_ToUpper(c As SByte) As SByte
1100	Return _System_ASCII_ToUpper(c As Byte As WCHAR) As Byte As SByte
1101	End Function
1102
1103	Function _System_GetHashFromWordArray(p As *Word, n As SIZE_T) As Long
1104	Dim hash = 0 As DWord
1105	Dim i As Long
1106	For i = 0 To ELM(n)
1107	hash = ((hash << 16) + p[i]) Mod &h7fffffff
1108	Next
1109	_System_GetHashFromWordArray = hash As Long
1110	End Function
1111
1112	#endif '_INC_FUNCTION

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format