Context Navigation

function.sbp@ 388

Last change on this file since 388 was 388, checked in by イグトランス (egtra), 16 years ago
Stringなどで例外を投げるようにした。 #147の解決。 CType ASCII文字判定関数群の追加。
File size: 20.2 KB

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

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

Download in other formats:

Original Format