source: Include/basic/function.sbp@ 192

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

Currencyを追加、その他修正

File size: 24.3 KB
Line 
1'function.sbp
2
3
4#ifndef _INC_FUNCTION
5#define _INC_FUNCTION
6
7
8Const _System_PI = 3.14159265358979323846264
9Const _System_LOG2 = 0.6931471805599453094172321214581765680755
10Const _System_SQRT2 = 1.41421356237309504880168872421
11
12
13#require <Classes/System/Math.ab>
14
15
16'------------- サポート関数の定義 -------------
17
18Function ldexp(x As Double, n As Long) As Double
19 If x = 0 Then
20 ldexp = 0
21 Exit Function
22 End If
23 Dim pSrc As *QWord, pDest As *QWord
24 pSrc = VarPtr(x) As *QWord
25 pDest = VarPtr(ldexp) As *QWord
26
27 n += (pSrc[0] >> 52) As DWord And &h7FF
28
29 pDest[0] = n << 52 Or (pSrc[0] And &h800FFFFFFFFFFFFF)
30End Function
31
32Function frexp(x As Double, ByRef n As Long) As Double
33 If x = 0 Then
34 n = 0
35 frexp = 0
36 Exit Function
37 End If
38
39 Dim pSrc As *QWord, pDest As *QWord
40 pSrc = VarPtr(x) As *QWord
41 pDest = VarPtr(frexp) As *QWord
42 n = ((pSrc[0] >> 52) As DWord And &h7FF) - 1022
43 pDest[0] = (pSrc[0] And &h800FFFFFFFFFFFFF) Or &h3FE0000000000000
44End Function
45
46Function frexp(x As Single, ByRef n As Long) As Single
47 If x = 0 Then
48 n = 0
49 frexp = 0
50 Exit Function
51 End If
52
53 Dim pSrc As *DWord, pDest As *DWord
54 pSrc = VarPtr(x) As *DWord
55 pDest = VarPtr(frexp) As *DWord
56 n = ((pSrc[0] >> 23) And &hFF) - 126
57 pDest[0] = (pSrc[0] And &h807FFFFF) Or &h7E000000
58End Function
59
60Function ipow(x As Double, n As Long) As Double
61 Dim abs_n As Long
62 Dim r = 1 As Double
63
64 abs_n=Abs(n) As Long
65 While abs_n<>0
66 If abs_n and 1 Then r *= x
67 x = x * x
68 abs_n >>= 1 ' abs_n \= 2
69 Wend
70
71 If n>=0 Then
72 ipow=r
73 Else
74 ipow=1/r
75 End If
76End Function
77
78Function pow(x As Double, y As Double) As Double
79 If -LONG_MAX<=y and y<=LONG_MAX and y=CDbl(Int(y)) Then
80 pow=ipow(x,y As Long)
81 Exit Function
82 End If
83
84 If x>0 Then
85 pow=Exp(y*Log(x))
86 Exit Function
87 End If
88
89 If x<>0 or y<=0 Then
90 'error
91 End If
92
93 pow=0
94End Function
95
96#ifdef _WIN64
97
98Function _System_GetNaN() As Double
99 SetQWord(VarPtr(_System_GetNaN) As *QWord, &H7FF8000000000000)
100End Function
101
102Function _System_GetInf(sign As BOOL) As Double
103 Dim s = 0 As QWord
104 If sign Then s = 1 << 63
105 SetQWord(VarPtr(_System_GetInf) As *QWord, &h7FF0000000000000 Or s)
106End Function
107
108#else
109
110Function _System_GetNaN() As Double
111 Dim p As *DWord
112 p = VarPtr(_System_GetNaN) As *DWord
113 p[0] = 0
114 p[1] = &H7FF80000
115End Function
116
117Function _System_GetInf(sign As BOOL) As Double
118 Dim s = 0 As DWord
119 If sign Then s = (1 As DWord) << 31
120 Dim p As *DWord
121 p = VarPtr(_System_GetInf) As *DWord
122 p[0] = 0
123 p[1] = &h7FF00000 Or s
124End Function
125
126#endif
127
128' xの符号だけをyのものにした値を返す。
129' 引数 x 元となる絶対値
130' 引数 y 元となる符号
131Function CopySign(x As Double, y As Double) As Double
132 SetQWord(VarPtr(CopySign), (GetQWord(VarPtr(x)) And &h7fffffffffffffff) Or (GetQWord(VarPtr(y)) And &h8000000000000000))
133End Function
134
135Function CopySign(x As Single, y As Single) As Single
136 SetDWord(VarPtr(CopySign), (GetDWord(VarPtr(x)) And &h7fffffff) Or (GetDWord(VarPtr(y)) And &h80000000))
137End Function
138
139Function _System_SetSign(x As Double, isNegative As Long) As Double
140#ifdef _WIN64
141 SetQWord(AddressOf(CopySign), (GetQWord(VarPtr(x)) And &h7fffffffffffffff) Or (isNegative << 63))
142#else
143 SetDWord(AddressOf(CopySign), GetDWord(VarPtr(x)))
144 SetDWord(AddressOf(CopySign) + SizeOf (DWord), GetQWord(VarPtr(x) + SizeOf (DWord)) And &h7fffffff Or (isNegative << 31))
145#endif
146End Function
147
148Const RAND_MAX=&H7FFFFFFF
149Dim _System_RndNext=1 As DWord
150
151Function rand() As Long
152 _System_RndNext = _System_RndNext * 1103515245 + 12345
153 rand = _System_RndNext >> 1
154End Function
155
156Sub srand(dwSeek As DWord)
157 _System_RndNext = dwSeek
158End Sub
159
160
161'------------- ここからBasic標準関数の定義 -------------
162
163
164'------------------
165' データ型変換関数
166'------------------
167
168Function CDbl(number As Double) As Double
169 CDbl=number
170End Function
171
172Function _CUDbl(number As QWord) As Double
173 _CUDbl=number As Double
174End Function
175
176Function CDWord(num As Double) As DWord
177 CDWord=num As DWord
178End Function
179
180Function CInt(number As Double) As Long
181 CInt=number As Long
182End Function
183
184Function CSng(number As Double) As Single
185 CSng=number As Single
186End Function
187
188#ifdef _WIN64
189Function Fix(number As Double) As Long
190 Fix=number As Long
191End Function
192#else
193'Fix関数はコンパイラに組み込まれている
194'Function Fix(number As Double) As Long
195#endif
196
197Function Int(number As Double) As Long
198 Int=Fix(number)
199 If number<0 Then
200 If number<Fix(number) Then Int=Int-1
201 End If
202End Function
203
204
205'-------------------------------------
206' ポインタ関数(コンパイラに組み込み)
207'-------------------------------------
208
209'Function GetDouble(p As DWord) As Double
210'Function GetSingle(p As DWord) As Single
211'Function GetDWord(p As DWord) As DWord
212'Function GetWord(p As DWord) As Word
213'Function GetByte(p As DWord) As Byte
214'Sub SetDouble(p As DWord, dblData As Double)
215'Sub SetSingle(p As DWord, fltData As Single)
216'Sub SetDWord(p As DWord, dwData As DWord)
217'Sub SetWord(p As DWord, wData As Word)
218'Sub SetByte(p As DWord, byteData As Byte)
219
220
221'----------
222' 算術関数
223'----------
224
225Function Abs(number As Double) As Double
226 'Abs = Math.Abs(number)
227 If number < 0 then
228 return -number
229 Else
230 return number
231 End If
232End Function
233
234Function Exp(x As Double) As Double
235 Exp = Math.Exp(x)
236End Function
237
238Function Log(x As Double) As Double
239 Log = Math.Log(x)
240End Function
241
242Function Sgn(number As Double) As Long
243 Sgn = Math.Sign(number)
244End Function
245
246Function Sqr(number As Double) As Double
247 Sqr = Math.Sqrt(number)
248End Function
249
250Function Atn(number As Double) As Double
251 Atn = Math.Atan(number)
252End Function
253
254Function _Support_tan(x As Double, ByRef k As Long) As Double
255 Dim i As Long
256 Dim t As Double, x2 As Double
257
258 If x>=0 Then
259 k=Fix(x/(_System_PI/2)+0.5)
260 Else
261 k=Fix(x/(_System_PI/2)-0.5)
262 End If
263
264 x=(x-(CDbl(3217)/CDbl(2048))*k)+4.4544551033807686783083602485579e-6*k
265
266 x2=x*x
267 t=0
268
269 For i=19 To 3 Step -2
270 t=x2/(i-t)
271 Next
272
273 _Support_tan=x/(1-t)
274End Function
275
276Function Atn2(y As Double, x As Double) As Double
277 Atn2 = Math.Atan2(y, x)
278End Function
279
280Function Sin(number As Double) As Double
281 Sin = Math.Sin(number)
282End Function
283
284Function Cos(number As Double) As Double
285 Cos = Math.Cos(number)
286End Function
287
288Function Tan(number As Double) As Double
289 Tan = Math.Tan(number)
290End Function
291
292Function IsNaN(ByVal x As Double) As Boolean
293 Dim p As *DWord
294 p = VarPtr(x) As *DWord
295 IsNaN = FALSE
296 If (p[1] And &H7FF00000) = &H7FF00000 Then
297 If (p[0] <> 0) Or ((p[1] And &HFFFFF) <> 0) Then
298 IsNaN = True
299 End If
300 End If
301
302' IsNaN=FALSE
303End Function
304
305Function IsInf(x As Double) As Boolean
306 Dim p As *DWord, nan As Double
307 p = VarPtr(x) As *DWord
308 p[1] And= &h7fffffff
309 nan = _System_GetInf(FALSE)
310 IsInf = (memcmp(p As *Byte, VarPtr(nan), SizeOf (Double)) = 0)
311End Function
312
313Function IsNaNOrInf(x As Double) As Boolean
314 IsNaNOrInf = IsFinite(x)
315End Function
316
317Function IsFinite(x As Double) As Boolean
318 Dim p As *DWord, nan As Double
319 p = VarPtr(x) As *DWord
320' p[1] And= &h7ffe0000
321 p[1] And= &H7FF00000
322 p[0] = 0
323 nan = _System_GetInf(/*x,*/ FALSE)
324 IsFinite = (memcmp(p As BytePtr, VarPtr(nan), SizeOf (Double)) = 0)
325End Function
326
327Const RAND_UNIT = (1.0 / (LONG_MAX + 1.0))
328Function Rnd() As Double
329 Rnd = RAND_UNIT * rand()
330End Function
331
332Const HIDWORD(qw) = (((qw As QWord) >> 32) And &HFFFFFFFF) As DWord
333Const LODWORD(qw) = ((qw As QWord) And &HFFFFFFFF) As DWord
334
335Const MAKEDWORD(l, h) = (((l As DWord) And &HFFFF) Or (((h As DWord) And &HFFFF) << 16)) As DWord
336Const MAKEQWORD(l, h) = (((l As QWord) And &HFFFFFFFF) Or (((h As QWord) And &HFFFFFFFF) << 32)) As QWord
337
338'------------
339' 文字列関数
340'------------
341
342Function Asc(buf As *StrChar) As StrChar
343 Asc = buf[0]
344End Function
345
346Function Chr$(code As StrChar) As String
347 Chr$ = ZeroString(1)
348 Chr$[0] = code
349End Function
350
351#ifndef __STRING_IS_NOT_UNICODE
352Function AscW(s As *WCHAR) As UCSCHAR
353 If s.Length = 0 Then
354 AscW = 0
355 Else
356 If _System_IsSurrogatePair(s[0], s[1]) Then
357 AscW = ((s[0] And &h3FF) As DWord << 10) Or (s[1] And &h3FF)
358 Else
359 AscW = s[0]
360 End If
361 End If
362End Function
363
364Function ChrW(c As UCSCHAR) As String
365 If c <= &hFFFF Then
366 ChrW.ReSize(1)
367 ChrW[0] = c As WCHAR
368 ElseIf c < &h10FFFF Then
369 ChrW.ReSize(2)
370 ChrW[0] = &hD800 Or (c >> 10)
371 ChrW[1] = &hDC00 Or (c And &h3FF)
372 Else
373 ' OutOfRangeException
374 End If
375End Function
376#endif
377
378Function Date$() As String
379 Dim st As SYSTEMTIME
380 GetLocalTime(st)
381
382 'year
383 Date$=Str$(st.wYear)
384
385 'month
386 If st.wMonth<10 Then
387 Date$=Date$+"/0"
388 Else
389 Date$=Date$+"/"
390 End If
391 Date$=Date$+Str$(st.wMonth)
392
393 'day
394 If st.wDay<10 Then
395 Date$=Date$+"/0"
396 Else
397 Date$=Date$+"/"
398 End If
399 Date$=Date$+Str$(st.wDay)
400End Function
401
402Dim _System_HexadecimalTable[&h10] = [&h30, &h31, &h32, &h33, &h34, &h35, &h36, &h37, &h38, &h39, &h41, &h42, &h43, &h44, &h45, &h46] As Byte
403
404Function _System_Hex(x As DWord, zeroSuppress As Boolean) As String
405 Dim s[7] As StrChar
406 Dim i As Long
407 For i = 0 To ELM(Len (s) \ SizeOf (StrChar))
408 s[i] = _System_HexadecimalTable[x >> 28] As StrChar
409 x <<= 4
410 Next
411 If zeroSuppress Then
412 Dim i As Long
413 For i = 0 To 6
414 If s[i] <> &h30 Then 'Asc("0")
415 Exit For
416 End If
417 Next
418 Return New String(VarPtr(s[i]) As *StrChar, Len (s) \ SizeOf (StrChar) - i)
419 Else
420 Return New String(s As *StrChar, Len (s) \ SizeOf (StrChar))
421 End If
422End Function
423
424Function Hex$(x As DWord) As String
425 Hex$ = _System_Hex(x, True)
426End Function
427
428Function Hex$(x As QWord) As String
429 Hex$ = _System_Hex(HIDWORD(x), True) + _System_Hex(LODWORD(x), False)
430End Function
431
432Function InStr(StartPos As Long, buf1 As String, buf2 As String) As Long
433 Dim i As Long, i2 As Long, i3 As Long
434
435 Dim len1 = buf1.Length
436 Dim len2 = buf2.Length
437
438 If len2=0 Then
439 InStr=StartPos
440 Exit Function
441 End If
442
443 StartPos--
444 If StartPos<0 Then
445 'error
446 InStr=0
447 Exit Function
448 End If
449
450 i=StartPos:InStr=0
451 While i<=len1-len2
452 i2=i:i3=0
453 Do
454 If i3=len2 Then
455 InStr=i+1
456 Exit Do
457 End If
458 If buf1[i2]<>buf2[i3] Then Exit Do
459
460 i2++
461 i3++
462 Loop
463 If InStr Then Exit While
464 i++
465 Wend
466End Function
467
468Function Left$(buf As String, length As Long) As String
469 Left$ = ZeroString(length)
470 memcpy(StrPtr(Left$), StrPtr(buf), SizeOf (StrChar) * length)
471End Function
472
473Function Mid$(buf As String, StartPos As Long)(ReadLength As Long) As String
474 Dim length As Long
475
476 StartPos--
477 If StartPos<0 Then
478 'error
479 'Debug
480 Exit Function
481 End If
482
483 length=Len(buf)
484 If length<=StartPos Then Exit Function
485
486 If ReadLength=0 Then
487 ReadLength=length-StartPos
488 End If
489
490 If ReadLength>length-StartPos Then
491 ReadLength=length-StartPos
492 End If
493
494 Mid$=ZeroString(ReadLength)
495 memcpy(StrPtr(Mid$), VarPtr(buf.Chars[StartPos]), SizeOf (StrChar) * ReadLength)
496End Function
497
498Function Oct$(num As DWord) As String
499 Dim i As DWord, i2 As DWord
500
501 For i=10 To 1 Step -1
502 If (num\CDWord(8^i)) And &H07 Then
503 Exit For
504 End If
505 Next
506
507 Oct$=ZeroString(i+1)
508 i2=0
509 Do
510 Oct$[i2] = &h30 +((num \ CDWord(8 ^ i)) And &H07) ' &h30 = Asc("0")
511 If i=0 Then Exit Do
512 i--
513 i2++
514 Loop
515End Function
516
517Function Right$(buf As String, length As Long) As String
518 Dim i As Long
519
520 i=Len(buf)
521 If i>length Then
522 Right$=ZeroString(length)
523 memcpy(StrPtr(Right$), VarPtr(buf.Chars[i-length]), SizeOf (StrChar) * length)
524 Else
525 Right$=buf
526 End If
527End Function
528
529Function Space$(length As Long) As String
530 Space$.ReSize(length, &H20 As StrChar)
531End Function
532
533Dim _System_ecvt_buffer[16] As StrChar
534Sub _ecvt_support(count As Long)
535 Dim i As Long
536 If _System_ecvt_buffer[count]=9 Then
537 _System_ecvt_buffer[count]=0
538 If count=0 Then
539 For i=16 To 1 Step -1
540 _System_ecvt_buffer[i]=_System_ecvt_buffer[i-1]
541 Next
542 _System_ecvt_buffer[0]=1
543 Else
544 _ecvt_support(count-1)
545 End If
546 Else
547 _System_ecvt_buffer[count]++
548 End If
549End Sub
550Function _ecvt(value As Double, count As Long, ByRef dec As Long, ByRef sign As Long) As *StrChar
551 Dim i As Long, i2 As Long
552
553 _ecvt=_System_ecvt_buffer
554
555 '値が0の場合
556 If value = 0 Then
557 _System_FillChar(_System_ecvt_buffer, count As SIZE_T, &H30 As StrChar)
558 _System_ecvt_buffer[count] = 0
559 dec = 0
560 sign = 0
561 Exit Function
562 End If
563
564 '符号の判断(同時に符号を取り除く)
565 If value < 0 Then
566 sign = 1
567 value = -value
568 Else
569 sign = 0
570 End If
571
572 '正規化
573 dec = 1
574 While value < 0.999999999999999 'value<1
575 value *= 10
576 dec--
577 Wend
578 While 9.99999999999999 <= value '10<=value
579 value /= 10
580 dec++
581 Wend
582
583 For i=0 To count-1
584 _System_ecvt_buffer[i] = Int(value) As StrChar
585
586 value = (value-CDbl(Int(value))) * 10
587 Next
588 _System_ecvt_buffer[i] = 0
589
590 i--
591 If value >= 5 Then
592 '切り上げ処理
593 _ecvt_support(i)
594 End If
595
596 For i=0 To ELM(count)
597 _System_ecvt_buffer[i] += &H30
598 Next
599 _System_ecvt_buffer[i] = 0
600End Function
601
602Function Str$(dbl As Double) As String
603 If IsNaN(dbl) Then
604 Return "NaN"
605 ElseIf IsInf(dbl) Then
606 If dbl > 0 Then
607 Return "Infinity"
608 Else
609 Return "-Infinity"
610 End If
611 End If
612 Dim dec As Long, sign As Long
613 Dim buffer[32] As StrChar, temp As *StrChar
614 Dim i As Long, i2 As Long, i3 As Long
615
616 '浮動小数点を文字列に変換
617 temp = _ecvt(dbl, 15, dec, sign)
618
619 i=0
620
621 '符号の取り付け
622 If sign Then
623 buffer[i] = Asc("-")
624 i++
625 End If
626
627 If dec>15 Then
628 '指数表示(桁が大きい場合)
629 buffer[i] = temp[0]
630 i++
631 buffer[i] = Asc(".")
632 i++
633 memcpy(VarPtr(buffer[i]), VarPtr(temp[1]), SizeOf (StrChar) * 14)
634 i += 14
635 buffer[i] = Asc("e")
636 i++
637 _stprintf(VarPtr(buffer[i]), "+%03d", dec - 1)
638
639 Return MakeStr(buffer)
640 End If
641
642 If dec < -3 Then
643 '指数表示(桁が小さい場合)
644 buffer[i] = temp[0]
645 i++
646 buffer[i] = Asc(".")
647 i++
648 memcpy(VarPtr(buffer[i]), VarPtr(temp[1]), SizeOf (StrChar) * 14)
649 i+=14
650 buffer[i] = Asc("e")
651 i++
652 _stprintf(VarPtr(buffer[i]), "+%03d", dec - 1)
653
654 Return MakeStr(buffer)
655 End If
656
657 '整数部
658 i2=dec
659 i3=0
660 If i2>0 Then
661 While i2>0
662 buffer[i]=temp[i3]
663 i++
664 i3++
665 i2--
666 Wend
667 buffer[i]=Asc(".")
668 i++
669 Else
670 buffer[i]=&H30
671 i++
672 buffer[i]=Asc(".")
673 i++
674
675 i2=dec
676 While i2<0
677 buffer[i]=&H30
678 i++
679 i2++
680 Wend
681 End If
682
683 '小数部
684 While i3<15
685 buffer[i]=temp[i3]
686 i++
687 i3++
688 Wend
689
690 While buffer[i-1]=&H30
691 i--
692 Wend
693 If buffer[i-1]=Asc(".") Then i--
694
695 buffer[i]=0
696 Return MakeStr(buffer)
697End Function
698
699Function Str$(value As Int64) As String
700 Dim temp[255] As Char
701 _sntprintf(temp, Len (temp) \ SizeOf (Char), "%I64d", value)
702 Str$ = New String( temp )
703End Function
704
705Function String$(num As Long, buf As String) As String
706 Dim dwStrPtr As DWord
707 Dim length As Long
708
709 length=Len(buf)
710
711 'バッファ領域を確保
712 String$=ZeroString(length*num)
713
714 '文字列をコピー
715 Dim i As Long
716 For i=0 To num-1
717 memcpy(VarPtr(String$[i*length]), StrPtr(buf), SizeOf (StrChar) * length)
718 Next
719End Function
720
721Function Time$() As String
722 Dim st As SYSTEMTIME
723
724 GetLocalTime(st)
725
726 'hour
727 If st.wHour<10 Then
728 Time$="0"
729 End If
730 Time$=Time$+Str$(st.wHour)
731
732 'minute
733 If st.wMinute<10 Then
734 Time$=Time$+":0"
735 Else
736 Time$=Time$+":"
737 End If
738 Time$=Time$+Str$(st.wMinute)
739
740 'second
741 If st.wSecond<10 Then
742 Time$=Time$+":0"
743 Else
744 Time$=Time$+":"
745 End If
746 Time$=Time$+Str$(st.wSecond)
747End Function
748
749Function Val(buf As *StrChar) As Double
750 Dim i As Long, i2 As Long, i3 As Long, i4 As Long
751 Dim temporary As String
752 Dim TempPtr As *StrChar
753 Dim dbl As Double
754 Dim i64data As Int64
755
756 Val=0
757
758 While buf[0]=Asc(" ") or buf[0]=Asc(Ex"\t")
759 buf++
760 Wend
761
762 If buf[0]=Asc("&") Then
763 temporary = New String( buf )
764 temporary.ToUpper()
765 TempPtr = StrPtr(temporary)
766 If TempPtr(1)=Asc("O") Then
767 '8進数
768 i=2
769 While 1
770 '数字以外の文字の場合は抜け出す
771 i3=TempPtr[i]-&H30
772 If Not (0<=i3 And i3<=7) Then Exit While
773
774 TempPtr[i]=i3 As StrChar
775 i++
776 Wend
777 i--
778
779 i64data=1
780 While i>=2
781 Val += i64data * TempPtr[i]
782
783 i64data *= &O10
784 i--
785 Wend
786 ElseIf TempPtr(1)=Asc("H") Then
787 '16進数
788 i=2
789 While 1
790 '数字以外の文字の場合は抜け出す
791 i3=TempPtr[i]-&H30
792 If Not(0<=i3 and i3<=9) Then
793 i3=TempPtr[i]-&H41+10
794 If Not(&HA<=i3 and i3<=&HF) Then Exit While
795 End If
796
797 TempPtr[i]=i3 As StrChar
798 i++
799 Wend
800 i--
801
802 i64data=1
803 While i>=2
804 Val += (i64data*TempPtr[i]) As Double
805
806 i64data *= &H10
807 i--
808 Wend
809 End If
810 Else
811 '10進数
812 If buf[0]=&H2D Then
813 'マイナス値
814 i4=1
815 buf++
816 Else
817 'プラス値
818 i4=0
819 If buf[0]=&H2B Then
820 buf++
821 End If
822 End If
823
824 i=0
825
826 While 1
827 '数字以外の文字の場合は抜け出す
828 i3=buf[i]-&H30
829 If Not (0<=i3 And i3<=9) Then Exit While
830
831 i++
832 Wend
833
834 '整数部
835 dbl=1
836 i3=i-1
837 While i3>=0
838 Val += dbl*(buf[i3]-&H30)
839
840 dbl *= 10
841 i3--
842 Wend
843
844 If buf[i]=Asc(".") Then
845 '小数部
846 i++
847 dbl=10
848 While 1
849 '数字以外の文字の場合は抜け出す
850 i3=buf[i]-&H30
851 If Not (0<=i3 And i3<=9) Then Exit While
852
853 Val += (buf[i] - &H30) / dbl
854 dbl *= 10
855 i++
856 Wend
857 End If
858
859 If i4 Then Val=-Val
860 End If
861End Function
862
863
864'--------------
865' ファイル関数
866'--------------
867
868Function Eof(FileNum As Long) As Long
869 Dim dwCurrent As DWord, dwEnd As DWord
870
871 FileNum--
872
873 dwCurrent=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_CURRENT)
874 dwEnd=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_END)
875 SetFilePointer(_System_hFile(FileNum),dwCurrent,NULL,FILE_BEGIN)
876
877 If dwCurrent>=dwEnd Then
878 Eof=-1
879 Else
880 Eof=0
881 End If
882End Function
883
884Function Lof(FileNum As Long) As Long
885 Lof = GetFileSize(_System_hFile(FileNum-1), 0)
886End Function
887
888Function Loc(FileNum As Long) As Long
889 Dim NowPos As Long, BeginPos As Long
890
891 FileNum--
892
893 NowPos=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_CURRENT)
894 BeginPos=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_BEGIN)
895 SetFilePointer(_System_hFile(FileNum),NowPos-BeginPos,NULL,FILE_BEGIN)
896
897 Loc=NowPos-BeginPos
898End Function
899
900
901'------------------
902' メモリ関連の関数
903'------------------
904
905Function malloc(stSize As SIZE_T) As VoidPtr
906 Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC)
907End Function
908
909Function calloc(stSize As SIZE_T) As VoidPtr
910 Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC or _System_GC_FLAG_INITZERO)
911End Function
912
913Function realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
914 If lpMem = 0 Then
915 Return malloc(stSize)
916 Else
917 Return _System_pGC->__realloc(lpMem,stSize)
918 End If
919End Function
920
921Sub free(lpMem As VoidPtr)
922 _System_pGC->__free(lpMem)
923End Sub
924
925
926Function _System_malloc(stSize As SIZE_T) As VoidPtr
927 Return HeapAlloc(_System_hProcessHeap,0,stSize)
928End Function
929
930Function _System_calloc(stSize As SIZE_T) As VoidPtr
931 Return HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,stSize)
932End Function
933
934Function _System_realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
935 If lpMem = 0 Then
936 Return HeapAlloc(_System_hProcessHeap, 0, stSize)
937 Else
938 Return HeapReAlloc(_System_hProcessHeap, 0, lpMem, stSize)
939 End If
940End Function
941
942Sub _System_free(lpMem As VoidPtr)
943 HeapFree(_System_hProcessHeap,0,lpMem)
944End Sub
945
946
947'--------
948' その他
949'--------
950
951Sub _splitpath(path As PCSTR, drive As PSTR, dir As PSTR, fname As PSTR, ext As PSTR)
952 Dim i As Long, i2 As Long, i3 As Long, length As Long
953 Dim buffer[MAX_PATH] As SByte
954
955 '":\"をチェック
956 If not(path[1]=&H3A and path[2]=&H5C) Then Exit Sub
957
958 'ドライブ名をコピー
959 If drive Then
960 drive[0]=path[0]
961 drive[1]=path[1]
962 drive[2]=0
963 End If
964
965 'ディレクトリ名をコピー
966 i=2
967 i2=0
968 Do
969 If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
970 If dir Then
971 dir[i2]=path[i]
972 dir[i2+1]=path[i+1]
973 End If
974
975 i += 2
976 i2 += 2
977 Continue
978 End If
979
980 If path[i]=0 Then Exit Do
981
982 If path[i]=&H5C Then '"\"記号であるかどうか
983 i3=i2+1
984 End If
985
986 If dir Then dir[i2]=path[i]
987
988 i++
989 i2++
990 Loop
991 If dir Then dir[i3]=0
992 i3 += i-i2
993
994 'ファイル名をコピー
995 i=i3
996 i2=0
997 i3=-1
998 Do
999'#ifdef UNICODE
1000' If _System_IsSurrogatePair(path[i], path[i + 1]) Then
1001'#else
1002 If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
1003'#endif
1004 If fname Then
1005 fname[i2]=path[i]
1006 fname[i2+1]=path[i+1]
1007 End If
1008
1009 i += 2
1010 i2 += 2
1011 Continue
1012 End If
1013
1014 If path[i]=0 Then Exit Do
1015
1016 If path[i]=&H2E Then '.'記号であるかどうか
1017 i3=i2
1018 End If
1019
1020 If fname Then fname[i2]=path[i]
1021
1022 i++
1023 i2++
1024 Loop
1025 If i3=-1 Then i3=i2
1026 If fname Then fname[i3]=0
1027 i3 += i-i2
1028
1029 '拡張子名をコピー
1030 If ext Then
1031 If i3 Then
1032 lstrcpy(ext,path+i3)
1033 End If
1034 else ext[0]=0
1035 End If
1036End Sub
1037
1038Function GetBasicColor(ColorCode As Long) As Long
1039 Select Case ColorCode
1040 Case 0
1041 GetBasicColor=RGB(0,0,0)
1042 Case 1
1043 GetBasicColor=RGB(0,0,255)
1044 Case 2
1045 GetBasicColor=RGB(255,0,0)
1046 Case 3
1047 GetBasicColor=RGB(255,0,255)
1048 Case 4
1049 GetBasicColor=RGB(0,255,0)
1050 Case 5
1051 GetBasicColor=RGB(0,255,255)
1052 Case 6
1053 GetBasicColor=RGB(255,255,0)
1054 Case 7
1055 GetBasicColor=RGB(255,255,255)
1056 End Select
1057End Function
1058
1059Function _System_BSwap(x As Word) As Word
1060 Dim src = VarPtr(x) As *Byte
1061 Dim dst = VarPtr(_System_BSwap) As *SByte
1062 dst[0] = src[1]
1063 dst[1] = src[0]
1064End Function
1065
1066Function _System_BSwap(x As DWord) As DWord
1067 Dim src = VarPtr(x) As *Byte
1068 Dim dst = VarPtr(_System_BSwap) As *SByte
1069 dst[0] = src[3]
1070 dst[1] = src[2]
1071 dst[2] = src[1]
1072 dst[3] = src[0]
1073End Function
1074
1075Function _System_BSwap(x As QWord) As QWord
1076 Dim src = VarPtr(x) As *Byte
1077 Dim dst = VarPtr(_System_BSwap) As *SByte
1078 dst[0] = src[7]
1079 dst[1] = src[6]
1080 dst[2] = src[5]
1081 dst[3] = src[4]
1082 dst[4] = src[3]
1083 dst[5] = src[2]
1084 dst[6] = src[1]
1085 dst[7] = src[0]
1086End Function
1087
1088Function _System_HashFromPtr(p As VoidPtr) As Long
1089#ifdef _WIN64
1090 Dim qw = p As QWord
1091 Return (HIDWORD(qw) Xor LODWORD(qw)) As Long
1092#else
1093 Return p As Long
1094#endif
1095End Function
1096
1097'--------
1098' 文字列関数その2
1099'--------
1100Function _System_IsSurrogatePair(wcHigh As WCHAR, wcLow As WCHAR) As Boolean
1101 If &hD800 <= wcHigh And wcHigh < &hDC00 Then
1102 If &hDC00 <= wcLow And wcLow < &hE000 Then
1103 Return True
1104 End If
1105 End If
1106 Return False
1107End Function
1108
1109Function _System_IsDoubleUnitChar(lead As WCHAR, trail As WCHAR) As Boolean
1110 Return _System_IsSurrogatePair(lead, trail)
1111End Function
1112
1113Function _System_IsDoubleUnitChar(lead As SByte, trail As SByte) As Boolean
1114 Return IsDBCSLeadByte(lead) <> FALSE
1115End Function
1116
1117Sub _System_FillChar(p As PWSTR, n As SIZE_T, c As WCHAR)
1118 Dim i As SIZE_T
1119 For i = 0 To ELM(n)
1120 p[i] = c
1121 Next
1122End Sub
1123
1124Sub _System_FillChar(p As PSTR, n As SIZE_T, c As SByte)
1125 Dim i As SIZE_T
1126 For i = 0 To ELM(n)
1127 p[i] = c
1128 Next
1129End Sub
1130
1131Function _System_ASCII_IsUpper(c As WCHAR) As Boolean
1132 Return c As DWord - &h41 < 26 ' &h41 = Asc("A")
1133End Function
1134
1135Function _System_ASCII_IsUpper(c As SByte) As Boolean
1136 Return _System_ASCII_IsUpper(c As Byte As WCHAR)
1137End Function
1138
1139Function _System_ASCII_IsLower(c As WCHAR) As Boolean
1140 Return c As DWord - &h61 < 26 ' &h61 = Asc("a")
1141End Function
1142
1143Function _System_ASCII_IsLower(c As SByte) As Boolean
1144 Return _System_ASCII_IsLower(c As Byte As WCHAR)
1145End Function
1146
1147Function _System_ASCII_ToLower(c As WCHAR) As WCHAR
1148 If _System_ASCII_IsUpper(c) Then
1149 Return c Or &h20
1150 Else
1151 Return c
1152 End If
1153End Function
1154
1155Function _System_ASCII_ToLower(c As SByte) As SByte
1156 Return _System_ASCII_ToLower(c As Byte As WCHAR) As Byte As SByte
1157End Function
1158
1159Function _System_ASCII_ToUpper(c As WCHAR) As WCHAR
1160 If _System_ASCII_IsLower(c) Then
1161 Return c And (Not &h20)
1162 Else
1163 Return c
1164 End If
1165End Function
1166
1167Function _System_ASCII_ToUpper(c As SByte) As SByte
1168 Return _System_ASCII_ToUpper(c As Byte As WCHAR) As Byte As SByte
1169End Function
1170
1171
1172Function _System_StrCmp(s1 As PCSTR, s2 As PCSTR) As Long
1173 Dim i = 0 As SIZE_T
1174 While s1[i] = s2[i]
1175 If s1[i] = 0 Then
1176 Exit While
1177 End If
1178 i++
1179 Wend
1180 _System_StrCmp = s1[i] - s2[i]
1181End Function
1182
1183Function _System_StrCmp(s1 As PCWSTR, s2 As PCWSTR) As Long
1184 Dim i = 0 As SIZE_T
1185 While s1[i] = s2[i]
1186 If s1[i] = 0 Then
1187 Exit While
1188 End If
1189 i++
1190 Wend
1191 _System_StrCmp = s1[i] - s2[i]
1192End Function
1193
1194Function _System_GetHashFromWordArray(p As *Word, n As SIZE_T) As Long
1195 Dim hash = 0 As DWord
1196 Dim i As Long
1197 For i = 0 To ELM(n)
1198 hash = ((hash << 16) + p[i]) Mod &h7fffffff
1199 Next
1200 _System_GetHashFromWordArray = hash As Long
1201End Function
1202
1203#endif '_INC_FUNCTION
Note: See TracBrowser for help on using the repository browser.