Context Navigation

function.sbp@ 497

Last change on this file since 497 was 497, checked in by イグトランス (egtra), 16 years ago
インクルードガードとその他不要な前処理定義などの削除
File size: 20.6 KB

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

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

Download in other formats:

Original Format