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

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

_System_HashFromUIntの追加([392]から必要だった)。AscWで上位サロゲートだけのLength = 1の場合に、2字目を読みに行かないようにした。

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