source: trunk/Include/basic/function.sbp@ 335

Last change on this file since 335 was 303, checked in by イグトランス (egtra), 17 years ago

フルコンパイルでのミスあぶり出し。註:修正は全て@300や@301以前に行われた。

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