Context Navigation

function.sbp@ 673

Last change on this file since 673 was 634, checked in by イグトランス (egtra), 17 years ago
#202 Compare/CompareOrdinal完了
File size: 20.3 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))
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	ActiveBasic.Detail.ThrowIfInvaildFileNum(FileNum)
668	Dim dwCurrent = SetFilePointer(_System_hFile(FileNum), 0,NULL, FILE_CURRENT)
669	Dim dwEnd = SetFilePointer(_System_hFile(FileNum), 0, NULL, FILE_END)
670	SetFilePointer(_System_hFile(FileNum), dwCurrent, NULL, FILE_BEGIN)
671
672	If dwCurrent>=dwEnd Then
673	Eof=-1
674	Else
675	Eof=0
676	End If
677	End Function
678
679	Function Lof(FileNum As Long) As Long
680	FileNum--
681	ActiveBasic.Detail.ThrowIfInvaildFileNum(FileNum)
682	Lof = GetFileSize(_System_hFile(FileNum), 0)
683	End Function
684
685	Function Loc(FileNum As Long) As Long
686	FileNum--
687	ActiveBasic.Detail.ThrowIfInvaildFileNum(FileNum)
688	Dim NowPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_CURRENT)
689	Dim BeginPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_BEGIN)
690	SetFilePointer(_System_hFile(FileNum), NowPos - BeginPos, 0, FILE_BEGIN)
691
692	Loc = NowPos - BeginPos
693	End Function
694
695	Namespace ActiveBasic
696	Namespace Detail
697
698	Sub ThrowIfInvaildFileNum(n As Long)
699	If n < 0 Or n > 255 Then
700	Throw New System.ArgumentOutOfRangeException("FileNum", "Invalid file number")
701	ElseIf _System_hFile(n) = 0 Then
702	Throw New System.InvalidOperationException("File number " & Str$(n + 1) & "is not opend.")
703	End If
704	End Sub
705
706	End Namespace
707	End Namespace
708
709	'------------------
710	' メモリ関連の関数
711	'------------------
712
713	Function malloc(stSize As SIZE_T) As VoidPtr
714	Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC)
715	End Function
716
717	Function calloc(stSize As SIZE_T) As VoidPtr
718	Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC or _System_GC_FLAG_INITZERO)
719	End Function
720
721	Function realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
722	If lpMem = 0 Then
723	Return malloc(stSize)
724	Else
725	Return _System_pGC->__realloc(lpMem,stSize)
726	End If
727	End Function
728
729	Sub free(lpMem As VoidPtr)
730	_System_pGC->__free(lpMem)
731	End Sub
732
733	Function _System_malloc(stSize As SIZE_T) As VoidPtr
734	Return HeapAlloc(_System_hProcessHeap, 0, stSize)
735	End Function
736
737	Function _System_calloc(stSize As SIZE_T) As VoidPtr
738	Return HeapAlloc(_System_hProcessHeap, HEAP_ZERO_MEMORY, stSize)
739	End Function
740
741	Function _System_realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
742	If lpMem = 0 Then
743	Return HeapAlloc(_System_hProcessHeap, 0, stSize)
744	Else
745	Return HeapReAlloc(_System_hProcessHeap, 0, lpMem, stSize)
746	End If
747	End Function
748
749	Sub _System_free(lpMem As VoidPtr)
750	HeapFree(_System_hProcessHeap, 0, lpMem)
751	End Sub
752
753
754	'--------
755	' その他
756	'--------
757
758	Sub _splitpath(path As PCSTR, drive As PSTR, dir As PSTR, fname As PSTR, ext As PSTR)
759	Dim i As Long, i2 As Long, i3 As Long, length As Long
760	Dim buffer[MAX_PATH] As SByte
761
762	'":\"をチェック
763	If not(path[1]=&H3A and path[2]=&H5C) Then Exit Sub
764
765	'ドライブ名をコピー
766	If drive Then
767	drive[0]=path[0]
768	drive[1]=path[1]
769	drive[2]=0
770	End If
771
772	'ディレクトリ名をコピー
773	i=2
774	i2=0
775	Do
776	If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
777	If dir Then
778	dir[i2]=path[i]
779	dir[i2+1]=path[i+1]
780	End If
781
782	i += 2
783	i2 += 2
784	Continue
785	End If
786
787	If path[i]=0 Then Exit Do
788
789	If path[i]=&H5C Then '"\"記号であるかどうか
790	i3=i2+1
791	End If
792
793	If dir Then dir[i2]=path[i]
794
795	i++
796	i2++
797	Loop
798	If dir Then dir[i3]=0
799	i3 += i-i2
800
801	'ファイル名をコピー
802	i=i3
803	i2=0
804	i3=-1
805	Do
806	'#ifdef UNICODE
807	' If _System_IsSurrogatePair(path[i], path[i + 1]) Then
808	'#else
809	If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
810	'#endif
811	If fname Then
812	fname[i2]=path[i]
813	fname[i2+1]=path[i+1]
814	End If
815
816	i += 2
817	i2 += 2
818	Continue
819	End If
820
821	If path[i]=0 Then Exit Do
822
823	If path[i]=&H2E Then '.'記号であるかどうか
824	i3=i2
825	End If
826
827	If fname Then fname[i2]=path[i]
828
829	i++
830	i2++
831	Loop
832	If i3=-1 Then i3=i2
833	If fname Then fname[i3]=0
834	i3 += i-i2
835
836	'拡張子名をコピー
837	If ext Then
838	If i3 Then
839	ActiveBasic.Strings.StrCpy(ext,path+i3)
840	End If
841	else ext[0]=0
842	End If
843	End Sub
844
845	Function GetBasicColor(ColorCode As Long) As Long
846	Select Case ColorCode
847	Case 0
848	GetBasicColor=RGB(0,0,0)
849	Case 1
850	GetBasicColor=RGB(0,0,255)
851	Case 2
852	GetBasicColor=RGB(255,0,0)
853	Case 3
854	GetBasicColor=RGB(255,0,255)
855	Case 4
856	GetBasicColor=RGB(0,255,0)
857	Case 5
858	GetBasicColor=RGB(0,255,255)
859	Case 6
860	GetBasicColor=RGB(255,255,0)
861	Case 7
862	GetBasicColor=RGB(255,255,255)
863	End Select
864	End Function
865
866	Function _System_BSwap(x As Word) As Word
867	Dim src = VarPtr(x) As *Byte
868	Dim dst = VarPtr(_System_BSwap) As *Byte
869	dst[0] = src[1]
870	dst[1] = src[0]
871	End Function
872
873	Function _System_BSwap(x As DWord) As DWord
874	Dim src = VarPtr(x) As *Byte
875	Dim dst = VarPtr(_System_BSwap) As *Byte
876	dst[0] = src[3]
877	dst[1] = src[2]
878	dst[2] = src[1]
879	dst[3] = src[0]
880	End Function
881
882	Function _System_BSwap(x As QWord) As QWord
883	Dim src = VarPtr(x) As *Byte
884	Dim dst = VarPtr(_System_BSwap) As *Byte
885	dst[0] = src[7]
886	dst[1] = src[6]
887	dst[2] = src[5]
888	dst[3] = src[4]
889	dst[4] = src[3]
890	dst[5] = src[2]
891	dst[6] = src[1]
892	dst[7] = src[0]
893	End Function
894
895	Function _System_HashFromUInt(x As QWord) As Long
896	Return (HIDWORD(x) Xor LODWORD(x)) As Long
897	End Function
898
899	Function _System_HashFromUInt(x As DWord) As Long
900	Return x As Long
901	End Function
902
903	Function _System_HashFromPtr(p As VoidPtr) As Long
904	Return _System_HashFromUInt(p As ULONG_PTR)
905	End Function
906
907	/*!
908	@brief ObjPtrの逆。ABオブジェクトを指すポインタをObject型へ変換。
909	@author Egtra
910	@date 2007/08/24
911	@param[in] p オブジェクトを指すポインタ
912	@return Object参照型
913	*/
914	Function _System_PtrObj(p As VoidPtr) As Object
915	SetPointer(VarPtr(_System_PtrObj), p)
916	End Function
917
918	/*!
919	@brief IUnknownその他COMインタフェースを指すポインタをIUnknown参照型へ変換。
920	@author Egtra
921	@date 2007/09/24
922	@param[in] p COMインタフェースを指すポインタ
923	@return IUnknown参照型
924	*/
925	Function _System_PtrUnknown(p As VoidPtr) As IUnknown
926	SetPointer(VarPtr(_System_PtrUnknown), p)
927	End Function
928
929	'--------
930	' 文字列関数その2
931	'--------
932	Function _System_IsSurrogatePair(wcHigh As WCHAR, wcLow As WCHAR) As Boolean
933	If _System_IsHighSurrogate(wcHigh) Then
934	If _System_IsLowSurrogate(wcLow) Then
935	Return True
936	End If
937	End If
938	Return False
939	End Function
940
941	Function _System_IsHighSurrogate(c As WCHAR) As Boolean
942	Return &hD800 <= c And c < &hDC00
943	End Function
944
945	Function _System_IsLowSurrogate(c As WCHAR) As Boolean
946	Return &hDC00 <= c And c < &hE000
947	End Function
948
949	Function _System_IsDoubleUnitChar(lead As WCHAR, trail As WCHAR) As Boolean
950	Return _System_IsSurrogatePair(lead, trail)
951	End Function
952
953	Function _System_IsDoubleUnitChar(lead As SByte, trail As SByte) As Boolean
954	Return IsDBCSLeadByte(lead) <> FALSE
955	End Function
956
957	Function _System_GetHashFromWordArray(p As *Word, n As SIZE_T) As Long
958	Dim hash = 0 As DWord
959	Dim i As Long
960	For i = 0 To ELM(n)
961	hash = ((hash << 16) + p[i]) Mod &h7fffffff
962	Next
963	_System_GetHashFromWordArray = hash As Long
964	End Function

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

Download in other formats:

Original Format