Context Navigation

function.sbp@ 522

Last change on this file since 522 was 514, checked in by イグトランス (egtra), 17 years ago
String型引数にNothingが渡された場合への対処。暫定的に""が渡されたのと同じ扱いにしている。
File size: 21.0 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 String$(n As Long, s As Char) As String
593	Return New String(s, n)
594	End Function
595
596	#ifdef _AB4_COMPATIBILITY_STRING$_
597	Function String$(n As Long, s As String) As String
598	If n < 0 Then
599	'Throw ArgumentOutOfRangeException
600	End If
601	Dim buf = New System.Text.StringBuilder(s.Length * n)
602	Dim i As Long
603	For i = 1 To n
604	buf.Append(s)
605	Next
606	End Function
607	#else
608	Function String$(n As Long, s As String) As String
609	Dim c As Char
610	If String.IsNullOrEmpty(s) Then
611	c = 0
612	Else
613	c = s[0]
614	End If
615	String$ = New String(c, n)
616	End Function
617	#endif
618
619	Function Time$() As String
620	Dim time = System.DateTime.Now
621	Dim buf = New System.Text.StringBuilder(8)
622	'hour
623	If time.Hour < 10 Then
624	buf.Append("0")
625	End If
626	buf.Append(time.Hour)
627
628	'minute
629	If time.Minute < 10 Then
630	buf.Append(":0")
631	Else
632	buf.Append(":")
633	End If
634	buf.Append(time.Minute)
635
636	'second
637	If time.Second < 10 Then
638	buf.Append(":0")
639	Else
640	buf.Append(":")
641	End If
642	buf.Append(time.Second)
643	Time$ = buf.ToString
644	End Function
645
646	Function Val(buf As *Char) As Double
647	If buf = 0 Then
648	Exit Function
649	End If
650
651	Dim i As Long, i2 As Long, i3 As Long, i4 As Long
652	Dim temporary As String
653	Dim TempPtr As *Char
654	Dim dbl As Double
655	Dim i64data As Int64
656
657	Val=0
658
659	While ActiveBasic.CType.IsSpace(buf[0])
660	buf = VarPtr(buf[1])
661	Wend
662
663	If buf[0]=Asc("&") Then
664	temporary = New String( buf )
665	temporary = temporary.ToUpper()
666	TempPtr = StrPtr(temporary)
667	If TempPtr(1) = Asc("O") Then
668	'8進数
669	i=2
670	While 1
671	'数字以外の文字の場合は抜け出す
672	i3=TempPtr[i]-&H30
673	If Not (0<=i3 And i3<=7) Then Exit While
674
675	TempPtr[i]=i3 As Char
676	i++
677	Wend
678	i--
679
680	i64data=1
681	While i>=2
682	Val += ( i64data * TempPtr[i] ) As Double
683
684	i64data *= &O10
685	i--
686	Wend
687	ElseIf TempPtr(1)=Asc("H") Then
688	'16進数
689	i=2
690	While 1
691	'数字以外の文字の場合は抜け出す
692	i3=TempPtr[i]-&H30
693	If Not(0<=i3 and i3<=9) Then
694	i3=TempPtr[i]-&H41+10
695	If Not(&HA<=i3 and i3<=&HF) Then Exit While
696	End If
697
698	TempPtr[i]=i3 As Char
699	i++
700	Wend
701	i--
702
703	i64data=1
704	While i>=2
705	Val += (i64data*TempPtr[i]) As Double
706
707	i64data *= &H10
708	i--
709	Wend
710	End If
711	Else
712	'10進数
713	#ifdef UNICODE
714	swscanf(buf,"%lf",VarPtr(Val))
715	#else
716	sscanf(buf,"%lf",VarPtr(Val))
717	#endif
718	End If
719	End Function
720
721
722	'--------------
723	' ファイル関数
724	'--------------
725
726	Function Eof(FileNum As Long) As Long
727	FileNum--
728	Dim dwCurrent = SetFilePointer(_System_hFile(FileNum), 0,NULL, FILE_CURRENT)
729	Dim dwEnd = SetFilePointer(_System_hFile(FileNum), 0, NULL, FILE_END)
730	SetFilePointer(_System_hFile(FileNum), dwCurrent, NULL, FILE_BEGIN)
731
732	If dwCurrent>=dwEnd Then
733	Eof=-1
734	Else
735	Eof=0
736	End If
737	End Function
738
739	Function Lof(FileNum As Long) As Long
740	Lof = GetFileSize(_System_hFile(FileNum-1), 0)
741	End Function
742
743	Function Loc(FileNum As Long) As Long
744	FileNum--
745
746	Dim NowPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_CURRENT)
747	Dim BeginPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_BEGIN)
748	SetFilePointer(_System_hFile(FileNum), NowPos - BeginPos, 0, FILE_BEGIN)
749
750	Loc = NowPos - BeginPos
751	End Function
752
753
754	'------------------
755	' メモリ関連の関数
756	'------------------
757
758	Function malloc(stSize As SIZE_T) As VoidPtr
759	Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC)
760	End Function
761
762	Function calloc(stSize As SIZE_T) As VoidPtr
763	Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC or _System_GC_FLAG_INITZERO)
764	End Function
765
766	Function realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
767	If lpMem = 0 Then
768	Return malloc(stSize)
769	Else
770	Return _System_pGC->__realloc(lpMem,stSize)
771	End If
772	End Function
773
774	Sub free(lpMem As VoidPtr)
775	_System_pGC->__free(lpMem)
776	End Sub
777
778	Function _System_malloc(stSize As SIZE_T) As VoidPtr
779	Return HeapAlloc(_System_hProcessHeap, 0, stSize)
780	End Function
781
782	Function _System_calloc(stSize As SIZE_T) As VoidPtr
783	Return HeapAlloc(_System_hProcessHeap, HEAP_ZERO_MEMORY, stSize)
784	End Function
785
786	Function _System_realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
787	If lpMem = 0 Then
788	Return HeapAlloc(_System_hProcessHeap, 0, stSize)
789	Else
790	Return HeapReAlloc(_System_hProcessHeap, 0, lpMem, stSize)
791	End If
792	End Function
793
794	Sub _System_free(lpMem As VoidPtr)
795	HeapFree(_System_hProcessHeap, 0, lpMem)
796	End Sub
797
798
799	'--------
800	' その他
801	'--------
802
803	Sub _splitpath(path As PCSTR, drive As PSTR, dir As PSTR, fname As PSTR, ext As PSTR)
804	Dim i As Long, i2 As Long, i3 As Long, length As Long
805	Dim buffer[MAX_PATH] As SByte
806
807	'":\"をチェック
808	If not(path[1]=&H3A and path[2]=&H5C) Then Exit Sub
809
810	'ドライブ名をコピー
811	If drive Then
812	drive[0]=path[0]
813	drive[1]=path[1]
814	drive[2]=0
815	End If
816
817	'ディレクトリ名をコピー
818	i=2
819	i2=0
820	Do
821	If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
822	If dir Then
823	dir[i2]=path[i]
824	dir[i2+1]=path[i+1]
825	End If
826
827	i += 2
828	i2 += 2
829	Continue
830	End If
831
832	If path[i]=0 Then Exit Do
833
834	If path[i]=&H5C Then '"\"記号であるかどうか
835	i3=i2+1
836	End If
837
838	If dir Then dir[i2]=path[i]
839
840	i++
841	i2++
842	Loop
843	If dir Then dir[i3]=0
844	i3 += i-i2
845
846	'ファイル名をコピー
847	i=i3
848	i2=0
849	i3=-1
850	Do
851	'#ifdef UNICODE
852	' If _System_IsSurrogatePair(path[i], path[i + 1]) Then
853	'#else
854	If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
855	'#endif
856	If fname Then
857	fname[i2]=path[i]
858	fname[i2+1]=path[i+1]
859	End If
860
861	i += 2
862	i2 += 2
863	Continue
864	End If
865
866	If path[i]=0 Then Exit Do
867
868	If path[i]=&H2E Then '.'記号であるかどうか
869	i3=i2
870	End If
871
872	If fname Then fname[i2]=path[i]
873
874	i++
875	i2++
876	Loop
877	If i3=-1 Then i3=i2
878	If fname Then fname[i3]=0
879	i3 += i-i2
880
881	'拡張子名をコピー
882	If ext Then
883	If i3 Then
884	lstrcpy(ext,path+i3)
885	End If
886	else ext[0]=0
887	End If
888	End Sub
889
890	Function GetBasicColor(ColorCode As Long) As Long
891	Select Case ColorCode
892	Case 0
893	GetBasicColor=RGB(0,0,0)
894	Case 1
895	GetBasicColor=RGB(0,0,255)
896	Case 2
897	GetBasicColor=RGB(255,0,0)
898	Case 3
899	GetBasicColor=RGB(255,0,255)
900	Case 4
901	GetBasicColor=RGB(0,255,0)
902	Case 5
903	GetBasicColor=RGB(0,255,255)
904	Case 6
905	GetBasicColor=RGB(255,255,0)
906	Case 7
907	GetBasicColor=RGB(255,255,255)
908	End Select
909	End Function
910
911	Function _System_BSwap(x As Word) As Word
912	Dim src = VarPtr(x) As *Byte
913	Dim dst = VarPtr(_System_BSwap) As *Byte
914	dst[0] = src[1]
915	dst[1] = src[0]
916	End Function
917
918	Function _System_BSwap(x As DWord) As DWord
919	Dim src = VarPtr(x) As *Byte
920	Dim dst = VarPtr(_System_BSwap) As *Byte
921	dst[0] = src[3]
922	dst[1] = src[2]
923	dst[2] = src[1]
924	dst[3] = src[0]
925	End Function
926
927	Function _System_BSwap(x As QWord) As QWord
928	Dim src = VarPtr(x) As *Byte
929	Dim dst = VarPtr(_System_BSwap) As *Byte
930	dst[0] = src[7]
931	dst[1] = src[6]
932	dst[2] = src[5]
933	dst[3] = src[4]
934	dst[4] = src[3]
935	dst[5] = src[2]
936	dst[6] = src[1]
937	dst[7] = src[0]
938	End Function
939
940	Function _System_HashFromUInt(x As QWord) As Long
941	Return (HIDWORD(x) Xor LODWORD(x)) As Long
942	End Function
943
944	Function _System_HashFromUInt(x As DWord) As Long
945	Return x As Long
946	End Function
947
948	Function _System_HashFromPtr(p As VoidPtr) As Long
949	Return _System_HashFromUInt(p As ULONG_PTR)
950	End Function
951
952	/*!
953	@brief ObjPtrの逆。ABオブジェクトを指すポインタをObject型へ変換。
954	@author Egtra
955	@date 2007/08/24
956	@param[in] p オブジェクトを指すポインタ
957	@return Object参照型
958	*/
959	Function _System_PtrObj(p As VoidPtr) As Object
960	SetPointer(VarPtr(_System_PtrObj), p)
961	End Function
962
963	/*!
964	@brief IUnknownその他COMインタフェースを指すポインタをIUnknown参照型へ変換。
965	@author Egtra
966	@date 2007/09/24
967	@param[in] p COMインタフェースを指すポインタ
968	@return IUnknown参照型
969	*/
970	Function _System_PtrUnknown(p As VoidPtr) As IUnknown
971	SetPointer(VarPtr(_System_PtrUnknown), p)
972	End Function
973
974	'--------
975	' 文字列関数その2
976	'--------
977	Function _System_IsSurrogatePair(wcHigh As WCHAR, wcLow As WCHAR) As Boolean
978	If _System_IsHighSurrogate(wcHigh) Then
979	If _System_IsLowSurrogate(wcLow) Then
980	Return True
981	End If
982	End If
983	Return False
984	End Function
985
986	Function _System_IsHighSurrogate(c As WCHAR) As Boolean
987	Return &hD800 <= c And c < &hDC00
988	End Function
989
990	Function _System_IsLowSurrogate(c As WCHAR) As Boolean
991	Return &hDC00 <= c And c < &hE000
992	End Function
993
994	Function _System_IsDoubleUnitChar(lead As WCHAR, trail As WCHAR) As Boolean
995	Return _System_IsSurrogatePair(lead, trail)
996	End Function
997
998	Function _System_IsDoubleUnitChar(lead As SByte, trail As SByte) As Boolean
999	Return IsDBCSLeadByte(lead) <> FALSE
1000	End Function
1001
1002	Function _System_GetHashFromWordArray(p As *Word, n As SIZE_T) As Long
1003	Dim hash = 0 As DWord
1004	Dim i As Long
1005	For i = 0 To ELM(n)
1006	hash = ((hash << 16) + p[i]) Mod &h7fffffff
1007	Next
1008	_System_GetHashFromWordArray = hash As Long
1009	End Function

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

Download in other formats:

Original Format