Context Navigation

function.sbp@ 560

Last change on this file since 560 was 536, checked in by イグトランス (egtra), 16 years ago

細かい修正。
Str$にStringを受け取る多重定義を追加した。
複数libを作るバッチで、コンパイルエラーが発生したら以後のビルドを行わないようにした。
Threadクラスの_beginthreadexをCreateThreadへ変更した。
ole2.abを全体が使える古い版へ戻した。
SendMessageCallback/SendMessageTimeoutを追加した。
GCHandleで登録が解除されない状態が起こる問題を直した。

File size: 21.1 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 = 0 As Long
317	Dim len2 = 0 As Long
318	If Not ActiveBasic.IsNothing(buf1) Then len1 = buf1.Length
319	If Not ActiveBasic.IsNothing(buf2) Then len2 = buf2.Length
320
321	If len2 = 0 Then
322	InStr = StartPos
323	Exit Function
324	End If
325
326	StartPos--
327	If StartPos < 0 Then
328	'error
329	InStr = 0
330	Exit Function
331	End If
332
333	i=StartPos:InStr=0
334	While i<=len1-len2
335	i2=i:i3=0
336	Do
337	If i3=len2 Then
338	InStr=i+1
339	Exit Do
340	End If
341	If buf1[i2]<>buf2[i3] Then Exit Do
342
343	i2++
344	i3++
345	Loop
346	If InStr Then Exit While
347	i++
348	Wend
349	End Function
350
351	Function Left$(s As String, length As Long) As String
352	If Not ActiveBasic.IsNothing(s) Then
353	Left$ = s.Substring(0, System.Math.Min(s.Length, length))
354	Else
355	Left$ = ""
356	End If
357	End Function
358
359	Function Mid$(s As String, startPos As Long) As String
360	If Not ActiveBasic.IsNothing(s) Then
361	startPos--
362	Mid$ = s.Substring(startPos)
363	Else
364	Mid$ = ""
365	End If
366	End Function
367
368	Function Mid$(s As String, startPos As Long, readLength = 0 As Long) As String
369	If Not ActiveBasic.IsNothing(s) Then
370	startPos--
371	Dim length = s.Length
372	Mid$ = s.Substring(System.Math.Min(startPos, length), System.Math.Min(readLength, length - startPos))
373	Else
374	Mid$ = ""
375	End If
376	End Function
377
378	Function Oct$(n As QWord) As String
379	Imports ActiveBasic.Strings.Detail
380	Oct$ = FormatIntegerLO(n, 1, 0, None)
381	End Function
382
383	Function Oct$(n As DWord) As String
384	Imports ActiveBasic.Strings.Detail
385	Oct$ = FormatIntegerO(n, 1, 0, None)
386	End Function
387
388	Function Right$(s As String, length As Long) As String
389	If Not ActiveBasic.IsNothing(s) Then
390	Right$ = s.Substring(System.Math.Max(0, s.Length - length), s.Length)
391	Else
392	Right$ = ""
393	End If
394	End Function
395
396	Function Space$(length As Long) As String
397	Return New String(&h20 As Char, length)
398	End Function
399
400	Sub _ecvt_support(buf As *Char, count As Long, size As Long)
401	Dim i As Long
402	If buf[count] = 9 Then
403	buf[count] = 0
404	If count = 0 Then
405	For i = size To 1 Step -1
406	buf[i] = buf[i-1]
407	Next
408	buf[0] = 1
409	Else
410	_ecvt_support(buf, count-1, size)
411	End If
412	Else
413	buf[count]++
414	End If
415	End Sub
416
417	Sub _ecvt(buffer As *Char, value As Double, count As Long, ByRef dec As Long, ByRef sign As Boolean)
418	Dim i As Long, i2 As Long
419
420	'値が0の場合
421	If value = 0 Then
422	ActiveBasic.Strings.ChrFill(buffer, count As SIZE_T, &h30 As Char)
423	buffer[count] = 0
424	dec = 0
425	sign = 0
426	Exit Function
427	End If
428
429	'符号の判断（同時に符号を取り除く）
430	If value < 0 Then
431	sign = True
432	value = -value
433	Else
434	sign = False
435	End If
436
437	'正規化
438	dec = 1
439	While value < 0.999999999999999 'value<1
440	value *= 10
441	dec--
442	Wend
443	While 9.99999999999999 <= value '10<=value
444	value /= 10
445	dec++
446	Wend
447
448	For i = 0 To count - 1
449	buffer[i] = Int(value) As Char
450	value = (value-CDbl(Int(value))) * 10
451	Next
452
453	i--
454	If value >= 5 Then
455	'切り上げ処理
456	_ecvt_support(buffer, i, count)
457	End If
458
459	For i = 0 To count - 1
460	buffer[i] += &H30
461	Next
462	buffer[i] = 0
463	End Sub
464
465	Function Str$(dbl As Double) As String
466	Imports ActiveBasic.Math
467	Imports ActiveBasic.Strings
468	If IsNaN(dbl) Then
469	Return "NaN"
470	ElseIf IsInf(dbl) Then
471	If dbl > 0 Then
472	Return "Infinity"
473	Else
474	Return "-Infinity"
475	End If
476	End If
477	Dim dec As Long, sign As Boolean
478	Dim buffer[32] As Char, temp[15] As Char
479	Dim i = 0 As Long
480
481	'浮動小数点を文字列に変換
482	_ecvt(temp, dbl, 15, dec, sign)
483
484	'符号の取り付け
485	If sign Then
486	buffer[i] = Asc("-")
487	i++
488	End If
489
490	If dec > 15 Or dec < -3 Then
491	'指数表示
492	buffer[i] = temp[0]
493	i++
494	buffer[i] = Asc(".")
495	i++
496	ChrCopy(VarPtr(buffer[i]), VarPtr(temp[1]), 14 As SIZE_T)
497	i += 14
498	buffer[i] = 0
499	Return MakeStr(buffer) + SPrintf("e%+03d", New System.Int32(dec - 1))
500	End If
501
502	'整数部
503	Dim i2 = dec
504	Dim i3 = 0
505	If i2>0 Then
506	While i2>0
507	buffer[i]=temp[i3]
508	i++
509	i3++
510	i2--
511	Wend
512	buffer[i]=Asc(".")
513	i++
514	Else
515	buffer[i]=&H30
516	i++
517	buffer[i]=Asc(".")
518	i++
519
520	i2=dec
521	While i2<0
522	buffer[i]=&H30
523	i++
524	i2++
525	Wend
526	End If
527
528	'小数部
529	While i3<15
530	buffer[i]=temp[i3]
531	i++
532	i3++
533	Wend
534
535	While buffer[i-1]=&H30
536	i--
537	Wend
538	If buffer[i-1]=Asc(".") Then i--
539
540	buffer[i]=0
541	Return MakeStr(buffer)
542	End Function
543
544	Function Str$(x As Int64) As String
545	Imports ActiveBasic.Strings.Detail
546	Return FormatIntegerEx(TraitsIntegerD[1], x As QWord, 1, 0, None)
547	End Function
548
549	Function Str$(x As QWord) As String
550	Imports ActiveBasic.Strings.Detail
551	Return FormatIntegerEx(TraitsIntegerU[1], x, 1, 0, None)
552	End Function
553
554	Function Str$(x As Long) As String
555	Imports ActiveBasic.Strings.Detail
556	Return FormatIntegerEx(TraitsIntegerD[0], x, 1, 0, None)
557	End Function
558
559	Function Str$(x As DWord) As String
560	Imports ActiveBasic.Strings.Detail
561	Return FormatIntegerEx(TraitsIntegerU[0], x, 1, 0, None)
562	End Function
563
564	Function Str$(x As Word) As String
565	Return Str$(x As DWord)
566	End Function
567
568	Function Str$(x As Integer) As String
569	Return Str$(x As Long)
570	End Function
571
572	Function Str$(x As Byte) As String
573	Return Str$(x As DWord)
574	End Function
575
576	Function Str$(x As SByte) As String
577	Return Str$(x As Long)
578	End Function
579
580	Function Str$(x As Single) As String
581	Return Str$(x As Double)
582	End Function
583
584	Function Str$(b As Boolean) As String
585	If b Then
586	Return "True"
587	Else
588	Return "False"
589	End If
590	End Function
591
592	Function Str$(s As String) As String
593	Str$ = s
594	End Function
595
596	Function String$(n As Long, s As Char) As String
597	Return New String(s, n)
598	End Function
599
600	#ifdef _AB4_COMPATIBILITY_STRING$_
601	Function String$(n As Long, s As String) As String
602	If n < 0 Then
603	'Throw ArgumentOutOfRangeException
604	End If
605	Dim buf = New System.Text.StringBuilder(s.Length * n)
606	Dim i As Long
607	For i = 1 To n
608	buf.Append(s)
609	Next
610	End Function
611	#else
612	Function String$(n As Long, s As String) As String
613	Dim c As Char
614	If String.IsNullOrEmpty(s) Then
615	c = 0
616	Else
617	c = s[0]
618	End If
619	String$ = New String(c, n)
620	End Function
621	#endif
622
623	Function Time$() As String
624	Dim time = System.DateTime.Now
625	Dim buf = New System.Text.StringBuilder(8)
626	'hour
627	If time.Hour < 10 Then
628	buf.Append("0")
629	End If
630	buf.Append(time.Hour)
631
632	'minute
633	If time.Minute < 10 Then
634	buf.Append(":0")
635	Else
636	buf.Append(":")
637	End If
638	buf.Append(time.Minute)
639
640	'second
641	If time.Second < 10 Then
642	buf.Append(":0")
643	Else
644	buf.Append(":")
645	End If
646	buf.Append(time.Second)
647	Time$ = buf.ToString
648	End Function
649
650	Function Val(buf As *Char) As Double
651	If buf = 0 Then
652	Exit Function
653	End If
654
655	Dim i As Long, i2 As Long, i3 As Long, i4 As Long
656	Dim temporary As String
657	Dim TempPtr As *Char
658	Dim dbl As Double
659	Dim i64data As Int64
660
661	Val=0
662
663	While ActiveBasic.CType.IsSpace(buf[0])
664	buf = VarPtr(buf[1])
665	Wend
666
667	If buf[0]=Asc("&") Then
668	temporary = New String( buf )
669	temporary = temporary.ToUpper()
670	TempPtr = StrPtr(temporary)
671	If TempPtr(1) = Asc("O") Then
672	'8進数
673	i=2
674	While 1
675	'数字以外の文字の場合は抜け出す
676	i3=TempPtr[i]-&H30
677	If Not (0<=i3 And i3<=7) Then Exit While
678
679	TempPtr[i]=i3 As Char
680	i++
681	Wend
682	i--
683
684	i64data=1
685	While i>=2
686	Val += ( i64data * TempPtr[i] ) As Double
687
688	i64data *= &O10
689	i--
690	Wend
691	ElseIf TempPtr(1)=Asc("H") Then
692	'16進数
693	i=2
694	While 1
695	'数字以外の文字の場合は抜け出す
696	i3=TempPtr[i]-&H30
697	If Not(0<=i3 and i3<=9) Then
698	i3=TempPtr[i]-&H41+10
699	If Not(&HA<=i3 and i3<=&HF) Then Exit While
700	End If
701
702	TempPtr[i]=i3 As Char
703	i++
704	Wend
705	i--
706
707	i64data=1
708	While i>=2
709	Val += (i64data*TempPtr[i]) As Double
710
711	i64data *= &H10
712	i--
713	Wend
714	End If
715	Else
716	'10進数
717	#ifdef UNICODE
718	swscanf(buf,"%lf",VarPtr(Val))
719	#else
720	sscanf(buf,"%lf",VarPtr(Val))
721	#endif
722	End If
723	End Function
724
725
726	'--------------
727	' ファイル関数
728	'--------------
729
730	Function Eof(FileNum As Long) As Long
731	FileNum--
732	Dim dwCurrent = SetFilePointer(_System_hFile(FileNum), 0,NULL, FILE_CURRENT)
733	Dim dwEnd = SetFilePointer(_System_hFile(FileNum), 0, NULL, FILE_END)
734	SetFilePointer(_System_hFile(FileNum), dwCurrent, NULL, FILE_BEGIN)
735
736	If dwCurrent>=dwEnd Then
737	Eof=-1
738	Else
739	Eof=0
740	End If
741	End Function
742
743	Function Lof(FileNum As Long) As Long
744	Lof = GetFileSize(_System_hFile(FileNum-1), 0)
745	End Function
746
747	Function Loc(FileNum As Long) As Long
748	FileNum--
749
750	Dim NowPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_CURRENT)
751	Dim BeginPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_BEGIN)
752	SetFilePointer(_System_hFile(FileNum), NowPos - BeginPos, 0, FILE_BEGIN)
753
754	Loc = NowPos - BeginPos
755	End Function
756
757
758	'------------------
759	' メモリ関連の関数
760	'------------------
761
762	Function malloc(stSize As SIZE_T) As VoidPtr
763	Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC)
764	End Function
765
766	Function calloc(stSize As SIZE_T) As VoidPtr
767	Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC or _System_GC_FLAG_INITZERO)
768	End Function
769
770	Function realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
771	If lpMem = 0 Then
772	Return malloc(stSize)
773	Else
774	Return _System_pGC->__realloc(lpMem,stSize)
775	End If
776	End Function
777
778	Sub free(lpMem As VoidPtr)
779	_System_pGC->__free(lpMem)
780	End Sub
781
782	Function _System_malloc(stSize As SIZE_T) As VoidPtr
783	Return HeapAlloc(_System_hProcessHeap, 0, stSize)
784	End Function
785
786	Function _System_calloc(stSize As SIZE_T) As VoidPtr
787	Return HeapAlloc(_System_hProcessHeap, HEAP_ZERO_MEMORY, stSize)
788	End Function
789
790	Function _System_realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
791	If lpMem = 0 Then
792	Return HeapAlloc(_System_hProcessHeap, 0, stSize)
793	Else
794	Return HeapReAlloc(_System_hProcessHeap, 0, lpMem, stSize)
795	End If
796	End Function
797
798	Sub _System_free(lpMem As VoidPtr)
799	HeapFree(_System_hProcessHeap, 0, lpMem)
800	End Sub
801
802
803	'--------
804	' その他
805	'--------
806
807	Sub _splitpath(path As PCSTR, drive As PSTR, dir As PSTR, fname As PSTR, ext As PSTR)
808	Dim i As Long, i2 As Long, i3 As Long, length As Long
809	Dim buffer[MAX_PATH] As SByte
810
811	'":\"をチェック
812	If not(path[1]=&H3A and path[2]=&H5C) Then Exit Sub
813
814	'ドライブ名をコピー
815	If drive Then
816	drive[0]=path[0]
817	drive[1]=path[1]
818	drive[2]=0
819	End If
820
821	'ディレクトリ名をコピー
822	i=2
823	i2=0
824	Do
825	If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
826	If dir Then
827	dir[i2]=path[i]
828	dir[i2+1]=path[i+1]
829	End If
830
831	i += 2
832	i2 += 2
833	Continue
834	End If
835
836	If path[i]=0 Then Exit Do
837
838	If path[i]=&H5C Then '"\"記号であるかどうか
839	i3=i2+1
840	End If
841
842	If dir Then dir[i2]=path[i]
843
844	i++
845	i2++
846	Loop
847	If dir Then dir[i3]=0
848	i3 += i-i2
849
850	'ファイル名をコピー
851	i=i3
852	i2=0
853	i3=-1
854	Do
855	'#ifdef UNICODE
856	' If _System_IsSurrogatePair(path[i], path[i + 1]) Then
857	'#else
858	If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
859	'#endif
860	If fname Then
861	fname[i2]=path[i]
862	fname[i2+1]=path[i+1]
863	End If
864
865	i += 2
866	i2 += 2
867	Continue
868	End If
869
870	If path[i]=0 Then Exit Do
871
872	If path[i]=&H2E Then '.'記号であるかどうか
873	i3=i2
874	End If
875
876	If fname Then fname[i2]=path[i]
877
878	i++
879	i2++
880	Loop
881	If i3=-1 Then i3=i2
882	If fname Then fname[i3]=0
883	i3 += i-i2
884
885	'拡張子名をコピー
886	If ext Then
887	If i3 Then
888	lstrcpy(ext,path+i3)
889	End If
890	else ext[0]=0
891	End If
892	End Sub
893
894	Function GetBasicColor(ColorCode As Long) As Long
895	Select Case ColorCode
896	Case 0
897	GetBasicColor=RGB(0,0,0)
898	Case 1
899	GetBasicColor=RGB(0,0,255)
900	Case 2
901	GetBasicColor=RGB(255,0,0)
902	Case 3
903	GetBasicColor=RGB(255,0,255)
904	Case 4
905	GetBasicColor=RGB(0,255,0)
906	Case 5
907	GetBasicColor=RGB(0,255,255)
908	Case 6
909	GetBasicColor=RGB(255,255,0)
910	Case 7
911	GetBasicColor=RGB(255,255,255)
912	End Select
913	End Function
914
915	Function _System_BSwap(x As Word) As Word
916	Dim src = VarPtr(x) As *Byte
917	Dim dst = VarPtr(_System_BSwap) As *Byte
918	dst[0] = src[1]
919	dst[1] = src[0]
920	End Function
921
922	Function _System_BSwap(x As DWord) As DWord
923	Dim src = VarPtr(x) As *Byte
924	Dim dst = VarPtr(_System_BSwap) As *Byte
925	dst[0] = src[3]
926	dst[1] = src[2]
927	dst[2] = src[1]
928	dst[3] = src[0]
929	End Function
930
931	Function _System_BSwap(x As QWord) As QWord
932	Dim src = VarPtr(x) As *Byte
933	Dim dst = VarPtr(_System_BSwap) As *Byte
934	dst[0] = src[7]
935	dst[1] = src[6]
936	dst[2] = src[5]
937	dst[3] = src[4]
938	dst[4] = src[3]
939	dst[5] = src[2]
940	dst[6] = src[1]
941	dst[7] = src[0]
942	End Function
943
944	Function _System_HashFromUInt(x As QWord) As Long
945	Return (HIDWORD(x) Xor LODWORD(x)) As Long
946	End Function
947
948	Function _System_HashFromUInt(x As DWord) As Long
949	Return x As Long
950	End Function
951
952	Function _System_HashFromPtr(p As VoidPtr) As Long
953	Return _System_HashFromUInt(p As ULONG_PTR)
954	End Function
955
956	/*!
957	@brief ObjPtrの逆。ABオブジェクトを指すポインタをObject型へ変換。
958	@author Egtra
959	@date 2007/08/24
960	@param[in] p オブジェクトを指すポインタ
961	@return Object参照型
962	*/
963	Function _System_PtrObj(p As VoidPtr) As Object
964	SetPointer(VarPtr(_System_PtrObj), p)
965	End Function
966
967	/*!
968	@brief IUnknownその他COMインタフェースを指すポインタをIUnknown参照型へ変換。
969	@author Egtra
970	@date 2007/09/24
971	@param[in] p COMインタフェースを指すポインタ
972	@return IUnknown参照型
973	*/
974	Function _System_PtrUnknown(p As VoidPtr) As IUnknown
975	SetPointer(VarPtr(_System_PtrUnknown), p)
976	End Function
977
978	'--------
979	' 文字列関数その2
980	'--------
981	Function _System_IsSurrogatePair(wcHigh As WCHAR, wcLow As WCHAR) As Boolean
982	If _System_IsHighSurrogate(wcHigh) Then
983	If _System_IsLowSurrogate(wcLow) Then
984	Return True
985	End If
986	End If
987	Return False
988	End Function
989
990	Function _System_IsHighSurrogate(c As WCHAR) As Boolean
991	Return &hD800 <= c And c < &hDC00
992	End Function
993
994	Function _System_IsLowSurrogate(c As WCHAR) As Boolean
995	Return &hDC00 <= c And c < &hE000
996	End Function
997
998	Function _System_IsDoubleUnitChar(lead As WCHAR, trail As WCHAR) As Boolean
999	Return _System_IsSurrogatePair(lead, trail)
1000	End Function
1001
1002	Function _System_IsDoubleUnitChar(lead As SByte, trail As SByte) As Boolean
1003	Return IsDBCSLeadByte(lead) <> FALSE
1004	End Function
1005
1006	Function _System_GetHashFromWordArray(p As *Word, n As SIZE_T) As Long
1007	Dim hash = 0 As DWord
1008	Dim i As Long
1009	For i = 0 To ELM(n)
1010	hash = ((hash << 16) + p[i]) Mod &h7fffffff
1011	Next
1012	_System_GetHashFromWordArray = hash As Long
1013	End Function

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

Download in other formats:

Original Format