Context Navigation

function.sbp@ 593

Last change on this file since 593 was 589, checked in by イグトランス (egtra), 16 years ago
数学関数をActiveBasic.Mathへ統合
File size: 19.8 KB

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

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

Download in other formats:

Original Format