source: trunk/ab5.0/ablib/src/basic/function.sbp@ 589

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

数学関数をActiveBasic.Mathへ統合

File size: 19.8 KB
Line 
1'function.sbp
2
3Const _System_PI = 3.14159265358979323846264
4Const _System_SQRT2 = 1.41421356237309504880168872421
5
6'------------- サポート関数の定義 -------------
7
8Function ipow(x As Double, n As Long) As Double
9 ipow = ActiveBasic.Math.pow(x, n)
10End Function
11
12Function pow(x As Double, y As Double) As Double
13 pow = ActiveBasic.Math.pow(x, y)
14End Function
15
16Const RAND_MAX = &H7FFFFFFF
17Dim _System_RndNext = 1 As DWord
18
19Function rand() As Long
20 _System_RndNext = _System_RndNext * 1103515245 + 12345
21 rand = (_System_RndNext >> 1) As Long
22End Function
23
24Sub srand(dwSeek As DWord)
25 _System_RndNext = dwSeek
26End Sub
27
28'------------- ここからBasic標準関数の定義 -------------
29
30'------------------
31' データ型変換関数
32'------------------
33
34Function CDbl(number As Double) As Double
35 CDbl=number
36End Function
37
38Function _CUDbl(number As QWord) As Double
39 _CUDbl=number As Double
40End Function
41
42Function CDWord(num As Double) As DWord
43 CDWord=num As DWord
44End Function
45
46Function CInt(number As Double) As Long
47 CInt=number As Long
48End Function
49
50Function CSng(number As Double) As Single
51 CSng=number As Single
52End Function
53
54#ifdef _WIN64
55Function Fix(number As Double) As Long
56 Fix=number As Long
57End Function
58#else
59'Fix関数はコンパイラに組み込まれている
60'Function Fix(number As Double) As Long
61#endif
62
63Function 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
68End 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/*
92Function Abs(n As Double) As Double
93 Abs = ActiveBasic.Math.Abs(n)
94End Function
95
96Function Abs(n As Single) As Single
97 Abs = ActiveBasic.Math.Abs(n)
98End Function
99
100Function Abs(n As Int64) As Int64
101 Abs = ActiveBasic.Math.Abs(n)
102End Function
103
104Function Abs(n As Long) As Long
105 Abs = ActiveBasic.Math.Abs(n)
106End Function
107
108Function Abs(n As Integer) As Integer
109 Abs = ActiveBasic.Math.Abs(n)
110End Function
111
112Function Abs(n As SByte) As SByte
113 Abs = ActiveBasic.Math.Abs(n)
114End Function
115
116Function Exp(x As Double) As Double
117 Exp = ActiveBasic.Math.Exp(x)
118End Function
119
120Function Log(x As Double) As Double
121 Log = ActiveBasic.Math.Log(x)
122End Function
123*/
124Function Sgn(n As Double) As Long
125' Sgn = ActiveBasic..Math.Sign(n)
126End Function
127
128Function Sqr(x As Double) As Double
129 Sqr = ActiveBasic.Math.Sqrt(x)
130End Function
131
132Function Atn(x As Double) As Double
133 Atn = ActiveBasic.Math.Atan(x)
134End Function
135
136Function Atn2(y As Double, x As Double) As Double
137 Atn2 = ActiveBasic.Math.Atan2(y, x)
138End Function
139/*
140Function Sin(x As Double) As Double
141 Sin = ActiveBasic.Math.Sin(x)
142End Function
143
144Function Cos(x As Double) As Double
145 Cos = ActiveBasic.Math.Cos(x)
146End Function
147
148Function Tan(x As Double) As Double
149 Tan = ActiveBasic.Math.Tan(x)
150End Function
151*/
152Const RAND_UNIT = (1.0 / (LONG_MAX + 1.0))
153Function Rnd() As Double
154 Rnd = RAND_UNIT * rand()
155End Function
156
157Const HIDWORD(qw) = (((qw As QWord) >> 32) And &HFFFFFFFF) As DWord
158Const LODWORD(qw) = ((qw As QWord) And &HFFFFFFFF) As DWord
159
160Const MAKEDWORD(l, h) = (((l As DWord) And &HFFFF) Or (((h As DWord) And &HFFFF) << 16)) As DWord
161Const MAKEQWORD(l, h) = (((l As QWord) And &HFFFFFFFF) Or (((h As QWord) And &HFFFFFFFF) << 32)) As QWord
162
163'------------
164' 文字列関数
165'------------
166
167Function Asc(buf As String) As Char
168 Asc = buf[0]
169End Function
170
171Function Chr$(code As Char) As String
172 Chr$ = New String(code, 1)
173End Function
174
175#ifdef UNICODE
176Function 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
195End Function
196
197Function 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
209End Function
210#endif
211
212Function 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
236End Function
237
238Function Hex$(x As DWord) As String
239 Imports ActiveBasic.Strings.Detail
240 Hex$ = FormatIntegerX(x, 1, 0, None)
241End Function
242
243Function Hex$(x As QWord) As String
244 Imports ActiveBasic.Strings.Detail
245 Hex$ = FormatIntegerLX(x, 1, 0, None)
246End Function
247
248Function 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
284End Function
285
286Function 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
292End Function
293
294Function 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
301End Function
302
303Function 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
311End Function
312
313Function Oct$(n As QWord) As String
314 Imports ActiveBasic.Strings.Detail
315 Oct$ = FormatIntegerLO(n, 1, 0, None)
316End Function
317
318Function Oct$(n As DWord) As String
319 Imports ActiveBasic.Strings.Detail
320 Oct$ = FormatIntegerO(n, 1, 0, None)
321End Function
322
323Function 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), s.Length)
326 Else
327 Right$ = ""
328 End If
329End Function
330
331Function Space$(length As Long) As String
332 Return New String(&h20 As Char, length)
333End Function
334
335Sub _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
350End Sub
351
352Sub _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
398End Sub
399
400Function 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)
477End Function
478
479Function Str$(x As Int64) As String
480 Imports ActiveBasic.Strings.Detail
481 Return FormatIntegerEx(TraitsIntegerD[1], x As QWord, 1, 0, None)
482End Function
483
484Function Str$(x As QWord) As String
485 Imports ActiveBasic.Strings.Detail
486 Return FormatIntegerEx(TraitsIntegerU[1], x, 1, 0, None)
487End Function
488
489Function Str$(x As Long) As String
490 Imports ActiveBasic.Strings.Detail
491 Return FormatIntegerEx(TraitsIntegerD[0], x, 1, 0, None)
492End Function
493
494Function Str$(x As DWord) As String
495 Imports ActiveBasic.Strings.Detail
496 Return FormatIntegerEx(TraitsIntegerU[0], x, 1, 0, None)
497End Function
498
499Function Str$(x As Word) As String
500 Return Str$(x As DWord)
501End Function
502
503Function Str$(x As Integer) As String
504 Return Str$(x As Long)
505End Function
506
507Function Str$(x As Byte) As String
508 Return Str$(x As DWord)
509End Function
510
511Function Str$(x As SByte) As String
512 Return Str$(x As Long)
513End Function
514
515Function Str$(x As Single) As String
516 Return Str$(x As Double)
517End Function
518
519Function Str$(b As Boolean) As String
520 If b Then
521 Return "True"
522 Else
523 Return "False"
524 End If
525End Function
526
527Function Str$(s As String) As String
528 Str$ = s
529End Function
530
531Function String$(n As Long, s As Char) As String
532 Return New String(s, n)
533End Function
534
535#ifdef _AB4_COMPATIBILITY_STRING$_
536Function 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
545End Function
546#else
547Function 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)
555End Function
556#endif
557
558Function 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
583End Function
584
585Function 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
658End Function
659
660
661'--------------
662' ファイル関数
663'--------------
664
665Function Eof(FileNum As Long) As Long
666 FileNum--
667 Dim dwCurrent = SetFilePointer(_System_hFile(FileNum), 0,NULL, FILE_CURRENT)
668 Dim dwEnd = SetFilePointer(_System_hFile(FileNum), 0, NULL, FILE_END)
669 SetFilePointer(_System_hFile(FileNum), dwCurrent, NULL, FILE_BEGIN)
670
671 If dwCurrent>=dwEnd Then
672 Eof=-1
673 Else
674 Eof=0
675 End If
676End Function
677
678Function Lof(FileNum As Long) As Long
679 Lof = GetFileSize(_System_hFile(FileNum-1), 0)
680End Function
681
682Function Loc(FileNum As Long) As Long
683 FileNum--
684
685 Dim NowPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_CURRENT)
686 Dim BeginPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_BEGIN)
687 SetFilePointer(_System_hFile(FileNum), NowPos - BeginPos, 0, FILE_BEGIN)
688
689 Loc = NowPos - BeginPos
690End Function
691
692
693'------------------
694' メモリ関連の関数
695'------------------
696
697Function malloc(stSize As SIZE_T) As VoidPtr
698 Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC)
699End Function
700
701Function calloc(stSize As SIZE_T) As VoidPtr
702 Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC or _System_GC_FLAG_INITZERO)
703End Function
704
705Function realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
706 If lpMem = 0 Then
707 Return malloc(stSize)
708 Else
709 Return _System_pGC->__realloc(lpMem,stSize)
710 End If
711End Function
712
713Sub free(lpMem As VoidPtr)
714 _System_pGC->__free(lpMem)
715End Sub
716
717Function _System_malloc(stSize As SIZE_T) As VoidPtr
718 Return HeapAlloc(_System_hProcessHeap, 0, stSize)
719End Function
720
721Function _System_calloc(stSize As SIZE_T) As VoidPtr
722 Return HeapAlloc(_System_hProcessHeap, HEAP_ZERO_MEMORY, stSize)
723End Function
724
725Function _System_realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
726 If lpMem = 0 Then
727 Return HeapAlloc(_System_hProcessHeap, 0, stSize)
728 Else
729 Return HeapReAlloc(_System_hProcessHeap, 0, lpMem, stSize)
730 End If
731End Function
732
733Sub _System_free(lpMem As VoidPtr)
734 HeapFree(_System_hProcessHeap, 0, lpMem)
735End Sub
736
737
738'--------
739' その他
740'--------
741
742Sub _splitpath(path As PCSTR, drive As PSTR, dir As PSTR, fname As PSTR, ext As PSTR)
743 Dim i As Long, i2 As Long, i3 As Long, length As Long
744 Dim buffer[MAX_PATH] As SByte
745
746 '":\"をチェック
747 If not(path[1]=&H3A and path[2]=&H5C) Then Exit Sub
748
749 'ドライブ名をコピー
750 If drive Then
751 drive[0]=path[0]
752 drive[1]=path[1]
753 drive[2]=0
754 End If
755
756 'ディレクトリ名をコピー
757 i=2
758 i2=0
759 Do
760 If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
761 If dir Then
762 dir[i2]=path[i]
763 dir[i2+1]=path[i+1]
764 End If
765
766 i += 2
767 i2 += 2
768 Continue
769 End If
770
771 If path[i]=0 Then Exit Do
772
773 If path[i]=&H5C Then '"\"記号であるかどうか
774 i3=i2+1
775 End If
776
777 If dir Then dir[i2]=path[i]
778
779 i++
780 i2++
781 Loop
782 If dir Then dir[i3]=0
783 i3 += i-i2
784
785 'ファイル名をコピー
786 i=i3
787 i2=0
788 i3=-1
789 Do
790'#ifdef UNICODE
791' If _System_IsSurrogatePair(path[i], path[i + 1]) Then
792'#else
793 If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
794'#endif
795 If fname Then
796 fname[i2]=path[i]
797 fname[i2+1]=path[i+1]
798 End If
799
800 i += 2
801 i2 += 2
802 Continue
803 End If
804
805 If path[i]=0 Then Exit Do
806
807 If path[i]=&H2E Then '.'記号であるかどうか
808 i3=i2
809 End If
810
811 If fname Then fname[i2]=path[i]
812
813 i++
814 i2++
815 Loop
816 If i3=-1 Then i3=i2
817 If fname Then fname[i3]=0
818 i3 += i-i2
819
820 '拡張子名をコピー
821 If ext Then
822 If i3 Then
823 ActiveBasic.Strings.StrCpy(ext,path+i3)
824 End If
825 else ext[0]=0
826 End If
827End Sub
828
829Function GetBasicColor(ColorCode As Long) As Long
830 Select Case ColorCode
831 Case 0
832 GetBasicColor=RGB(0,0,0)
833 Case 1
834 GetBasicColor=RGB(0,0,255)
835 Case 2
836 GetBasicColor=RGB(255,0,0)
837 Case 3
838 GetBasicColor=RGB(255,0,255)
839 Case 4
840 GetBasicColor=RGB(0,255,0)
841 Case 5
842 GetBasicColor=RGB(0,255,255)
843 Case 6
844 GetBasicColor=RGB(255,255,0)
845 Case 7
846 GetBasicColor=RGB(255,255,255)
847 End Select
848End Function
849
850Function _System_BSwap(x As Word) As Word
851 Dim src = VarPtr(x) As *Byte
852 Dim dst = VarPtr(_System_BSwap) As *Byte
853 dst[0] = src[1]
854 dst[1] = src[0]
855End Function
856
857Function _System_BSwap(x As DWord) As DWord
858 Dim src = VarPtr(x) As *Byte
859 Dim dst = VarPtr(_System_BSwap) As *Byte
860 dst[0] = src[3]
861 dst[1] = src[2]
862 dst[2] = src[1]
863 dst[3] = src[0]
864End Function
865
866Function _System_BSwap(x As QWord) As QWord
867 Dim src = VarPtr(x) As *Byte
868 Dim dst = VarPtr(_System_BSwap) As *Byte
869 dst[0] = src[7]
870 dst[1] = src[6]
871 dst[2] = src[5]
872 dst[3] = src[4]
873 dst[4] = src[3]
874 dst[5] = src[2]
875 dst[6] = src[1]
876 dst[7] = src[0]
877End Function
878
879Function _System_HashFromUInt(x As QWord) As Long
880 Return (HIDWORD(x) Xor LODWORD(x)) As Long
881End Function
882
883Function _System_HashFromUInt(x As DWord) As Long
884 Return x As Long
885End Function
886
887Function _System_HashFromPtr(p As VoidPtr) As Long
888 Return _System_HashFromUInt(p As ULONG_PTR)
889End Function
890
891/*!
892@brief ObjPtrの逆。ABオブジェクトを指すポインタをObject型へ変換。
893@author Egtra
894@date 2007/08/24
895@param[in] p オブジェクトを指すポインタ
896@return Object参照型
897*/
898Function _System_PtrObj(p As VoidPtr) As Object
899 SetPointer(VarPtr(_System_PtrObj), p)
900End Function
901
902/*!
903@brief IUnknownその他COMインタフェースを指すポインタをIUnknown参照型へ変換。
904@author Egtra
905@date 2007/09/24
906@param[in] p COMインタフェースを指すポインタ
907@return IUnknown参照型
908*/
909Function _System_PtrUnknown(p As VoidPtr) As IUnknown
910 SetPointer(VarPtr(_System_PtrUnknown), p)
911End Function
912
913'--------
914' 文字列関数その2
915'--------
916Function _System_IsSurrogatePair(wcHigh As WCHAR, wcLow As WCHAR) As Boolean
917 If _System_IsHighSurrogate(wcHigh) Then
918 If _System_IsLowSurrogate(wcLow) Then
919 Return True
920 End If
921 End If
922 Return False
923End Function
924
925Function _System_IsHighSurrogate(c As WCHAR) As Boolean
926 Return &hD800 <= c And c < &hDC00
927End Function
928
929Function _System_IsLowSurrogate(c As WCHAR) As Boolean
930 Return &hDC00 <= c And c < &hE000
931End Function
932
933Function _System_IsDoubleUnitChar(lead As WCHAR, trail As WCHAR) As Boolean
934 Return _System_IsSurrogatePair(lead, trail)
935End Function
936
937Function _System_IsDoubleUnitChar(lead As SByte, trail As SByte) As Boolean
938 Return IsDBCSLeadByte(lead) <> FALSE
939End Function
940
941Function _System_GetHashFromWordArray(p As *Word, n As SIZE_T) As Long
942 Dim hash = 0 As DWord
943 Dim i As Long
944 For i = 0 To ELM(n)
945 hash = ((hash << 16) + p[i]) Mod &h7fffffff
946 Next
947 _System_GetHashFromWordArray = hash As Long
948End Function
Note: See TracBrowser for help on using the repository browser.