Context Navigation

function.sbp@ 383

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

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

Download in other formats:

Original Format