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

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

例外クラスの実装。ExceptionTestでSystem.Exceptionを使用するようにした。
StringBuilderでコメント化されていた例外を投げる処理を有効にした(除OutOfMemory)。
Str$の実装にSPrintfなどを使用するようにした。
毎回Object.ReferenceEquals(xxx, Nothing)と打つのが面倒なので、IsNothingを導入。

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