source: branch/egtra-stream-without-en_dec/basic/function.sbp@ 673

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

#202 Compare/CompareOrdinal完了

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