source: Include/basic/function.sbp@ 1

Last change on this file since 1 was 1, checked in by (none), 18 years ago
File size: 19.8 KB
Line 
1'function.sbp
2
3
4#ifndef _INC_FUNCTION
5#define _INC_FUNCTION
6
7#include <Classes/System/Math.ab>
8
9
10Const _System_PI = 3.14159265358979323846264
11Const _System_LOG2 = 0.6931471805599453094172321214581765680755
12Const _System_SQRT2 = 1.41421356237309504880168872421
13
14
15'------------- サポート関数の定義 -------------
16
17Function ldexp(x As Double, n As Long) As Double
18 If x = 0 Then
19 ldexp = 0
20 Exit Function
21 End If
22 Dim pSrc As *QWord, pDest As *QWord
23 pSrc = VarPtr(x) As *QWord
24 pDest = VarPtr(ldexp) As *QWord
25
26 n += (pSrc[0] >> 52) As DWord And &h7FF
27
28 pDest[0] = n << 52 Or (pSrc[0] And &h800FFFFFFFFFFFFF)
29End Function
30
31Function frexp(x As Double, ByRef n As Long) As Double
32 If x = 0 Then
33 n = 0
34 frexp = 0
35 Exit Function
36 End If
37
38 Dim pSrc As *QWord, pDest As *QWord
39 pSrc = VarPtr(x) As *QWord
40 pDest = VarPtr(frexp) As *QWord
41 n = ((pSrc[0] >> 52) As DWord And &h7FF) - 1022
42 pDest[0] = (pSrc[0] And &h800FFFFFFFFFFFFF) Or &h3FE0000000000000
43End Function
44
45Function frexp(x As Single, ByRef n As Long) As Single
46 If x = 0 Then
47 n = 0
48 frexp = 0
49 Exit Function
50 End If
51
52 Dim pSrc As *DWord, pDest As *DWord
53 pSrc = VarPtr(x) As *DWord
54 pDest = VarPtr(frexp) As *DWord
55 n = ((pSrc[0] >> 23) And &hFF) - 126
56 pDest[0] = (pSrc[0] And &h807FFFFF) Or &h7E000000
57End Function
58
59Function ipow(x As Double, n As Long) As Double
60 Dim abs_n As Long
61 Dim r As Double
62
63 abs_n=Abs(n) As Long
64 r=1
65 While abs_n<>0
66 If abs_n and 1 Then r = 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(VarPtr(CopySign), (GetQWord(VarPtr(x)) And &h7fffffffffffffff) Or (isNegative << 63))
142#else
143 SetDWord(VarPtr(CopySign), GetDWord(VarPtr(x)))
144 SetDWord(VarPtr(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
178End Function
179
180Function CInt(number As Double) As Long
181 CInt=number
182End Function
183
184Function CSng(number As Double) As Single
185 CSng=number
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 If x = 0 Then
278 Atn2 = Sgn(y) * _System_PI * 0.5
279 Else
280 Atn2 = Atn(y / x)
281 If x < 0 Then
282 Atn2 += CopySign(_System_PI, y)
283 End If
284 End If
285End Function
286
287Function Sin(number As Double) As Double
288 Sin = Math.Sign(number)
289End Function
290
291Function Cos(number As Double) As Double
292 Cos = Math.Cos(number)
293End Function
294
295Function Tan(number As Double) As Double
296 Tan = Math.Tan(number)
297End Function
298
299Function IsNaN(ByVal x As Double) As BOOL
300 Dim p As *DWord
301 p = VarPtr(x) As *DWord
302 IsNaN = FALSE
303 If (p[1] And &H7FF00000) = &H7FF00000 Then
304 If (p[0] <> 0) Or ((p[1] And &HFFFFF) <> 0) Then
305 IsNaN = TRUE
306 End If
307 End If
308
309' IsNaN=FALSE
310End Function
311
312Function IsInf(x As Double) As BOOL
313 Dim p As *DWord, nan As Double
314 p = VarPtr(x) As *DWord
315 p[1] And= &h7fffffff
316 nan = _System_GetInf(FALSE)
317 IsInf = (memcmp(p As *Byte, VarPtr(nan), SizeOf (Double)) = 0)
318End Function
319
320Function IsNaNOrInf(x As Double) As BOOL
321 IsNaNOrInf = IsFinite(x)
322End Function
323
324Function IsFinite(x As Double) As BOOL
325 Dim p As *DWord, nan As Double
326 p = VarPtr(x) As *DWord
327' p[1] And= &h7ffe0000
328 p[1] And= &H7FF00000
329 p[0] = 0
330 nan = _System_GetInf(/*x,*/ FALSE)
331 IsNaNOrInf = (memcmp(p, VarPtr(nan), SizeOf (Double)) = 0)
332End Function
333
334Const RAND_UNIT = (1.0 / (LONG_MAX + 1.0))
335Function Rnd() As Double
336 Rnd = RAND_UNIT * rand()
337End Function
338
339Const HIBYTE(w) = (((w As Word) >> 8) and &HFF) As Byte
340Const LOBYTE(w) = ((w As Word) and &HFF) As Byte
341Const HIWORD(dw) = (((dw As DWord) >> 16) and &HFFFF) As Word
342Const LOWORD(dw) = ((dw As DWord) and &HFFFF) As Word
343
344Const MAKEWORD(a,b) = (((a As Word) and &HFF) or (((b As Word) and &HFF)<<8)) As Word
345Const MAKELONG(a,b) = (((a As DWord) and &HFFFF) or (((b As DWord) and &HFFFF)<<16)) As Long
346
347
348
349'------------
350' 文字列関数
351'------------
352
353Function Asc(buf As String) As Byte
354 Asc = buf[0]
355End Function
356
357Function Chr$(code As Byte) As String
358 Chr$=ZeroString(1)
359 Chr$[0]=code
360End Function
361
362Function Date$() As String
363 Dim st As SYSTEMTIME
364
365 GetLocalTime(st)
366
367 'year
368 Date$=Str$(st.wYear)
369
370 'month
371 If st.wMonth<10 Then
372 Date$=Date$+"/0"
373 Else
374 Date$=Date$+"/"
375 End If
376 Date$=Date$+Str$(st.wMonth)
377
378 'day
379 If st.wDay<10 Then
380 Date$=Date$+"/0"
381 Else
382 Date$=Date$+"/"
383 End If
384 Date$=Date$+Str$(st.wDay)
385End Function
386
387Function Hex$(num As DWord) As String
388 Dim length As Long
389 Hex$=ZeroString(8)
390 length=wsprintf(Hex$, "%X", num)
391 Hex$=Left$(Hex$,length)
392End Function
393
394Function Hex$(num As QWord) As String
395 Dim length As Long
396 Hex$=ZeroString(16)
397 length=wsprintf(Hex$, "%X%X", num)
398 Hex$=Left$(Hex$,length)
399End Function
400
401Function InStr(StartPos As Long, buf1 As String, buf2 As String) As Long
402 Dim len1 As Long, len2 As Long, i As Long, i2 As Long, i3 As Long
403
404 len1=Len(buf1)
405 len2=Len(buf2)
406
407 If len2=0 Then
408 InStr=StartPos
409 Exit Function
410 End If
411
412 StartPos=StartPos-1
413 If StartPos<0 Then
414 'error
415 InStr=0
416 Exit Function
417 End If
418
419 i=StartPos:InStr=0
420 While i<=len1-len2
421 i2=i:i3=0
422 Do
423 If i3=len2 Then
424 InStr=i+1
425 Exit Do
426 End If
427 If buf1[i2]<>buf2[i3] Then Exit Do
428
429 i2=i2+1
430 i3=i3+1
431 Loop
432 If InStr Then Exit While
433 i=i+1
434 Wend
435End Function
436
437Function Left$(buf As String, length As Long) As String
438 Left$=ZeroString(length)
439 memcpy(
440 StrPtr(Left$),
441 StrPtr(buf),
442 length)
443End Function
444
445Function Mid$(buf As String, StartPos As Long)(ReadLength As Long) As String
446 Dim length As Long
447
448 StartPos=StartPos-1
449 If StartPos<0 Then
450 'error
451 'Debug
452 Exit Function
453 End If
454
455 length=Len(buf)
456 If length<=StartPos Then Exit Function
457
458 If ReadLength=0 Then
459 ReadLength=length-StartPos
460 End If
461
462 If ReadLength>length-StartPos Then
463 ReadLength=length-StartPos
464 End If
465
466 Mid$=ZeroString(ReadLength)
467 memcpy(StrPtr(Mid$),StrPtr(buf)+StartPos,ReadLength)
468End Function
469
470Function Oct$(num As DWord) As String
471 Dim i As DWord, i2 As DWord
472
473 For i=10 To 1 Step -1
474 If (num\CDWord(8^i)) And &H07 Then
475 Exit For
476 End If
477 Next
478
479 Oct$=ZeroString(i+1)
480 i2=0
481 Do
482 Oct$[i2]=Asc("0")+((num\CDWord(8^i)) And &H07)
483 If i=0 Then Exit Do
484 i--
485 i2++
486 Loop
487End Function
488
489Function Right$(buf As String, length As Long) As String
490 Dim i As Long
491
492 i=Len(buf)
493 If i>length Then
494 Right$=ZeroString(length)
495 memcpy(StrPtr(Right$),StrPtr(buf)+i-length,length)
496 Else
497 Right$=buf
498 End If
499End Function
500
501Function Space$(length As Long) As String
502 Space$=ZeroString(length)
503 FillMemory(StrPtr(Space$),length,&H20)
504End Function
505
506Dim _System_ecvt_buffer[16] As Byte
507Sub _ecvt_support(count As Long)
508 Dim i As Long
509 If _System_ecvt_buffer[count]=9 Then
510 _System_ecvt_buffer[count]=0
511 If count=0 Then
512 For i=16 To 1 Step -1
513 _System_ecvt_buffer[i]=_System_ecvt_buffer[i-1]
514 Next
515 _System_ecvt_buffer[0]=1
516 Else
517 _ecvt_support(count-1)
518 End If
519 Else
520 _System_ecvt_buffer[count]=_System_ecvt_buffer[count]+1 As Byte
521 End If
522End Sub
523Function _ecvt(value As Double, count As Long, ByRef dec As Long, ByRef sign As Long) As BytePtr
524 Dim temp As BytePtr
525 Dim i As Long, i2 As Long
526
527 _ecvt=_System_ecvt_buffer
528
529 '値が0の場合
530 If value=0 Then
531 FillMemory(_System_ecvt_buffer,count,&H30)
532 _System_ecvt_buffer[count]=0
533 dec=0
534 sign=0
535 Exit Function
536 End If
537
538 '符号の判断(同時に符号を取り除く)
539 If value<0 Then
540 sign=1
541 value=-value
542 Else
543 sign=0
544 End If
545
546 '正規化
547 dec=1
548 While value<0.999999999999999 'value<1
549 value=value*10
550 dec=dec-1
551 Wend
552 While 9.99999999999999<=value '10<=value
553 value=value/10
554 dec=dec+1
555 Wend
556
557 For i=0 To count-1
558 _System_ecvt_buffer[i]=Int(value) As Byte
559
560 value=(value-CDbl(Int(value)))*10
561 Next
562 _System_ecvt_buffer[i]=0
563
564 i=i-1
565 If value>=5 Then
566 '切り上げ処理
567 _ecvt_support(i)
568 End If
569
570 For i=0 To count-1
571 _System_ecvt_buffer[i]=_System_ecvt_buffer[i]+&H30
572 Next
573 _System_ecvt_buffer[i]=0
574End Function
575
576Function Str$(dbl As Double) As String
577 If IsNaN(dbl) Then
578 Return "NaN"
579 ElseIf IsInf(dbl) Then
580 If dbl > 0 Then
581 Return "Infinity"
582 Else
583 Return "-Infinity"
584 End If
585 End If
586 Dim dec As Long, sign As Long
587 Dim buffer[32] As Byte, temp As BytePtr
588 Dim i As Long, i2 As Long, i3 As Long
589
590 '浮動小数点を文字列に変換
591 temp=_ecvt(dbl,15,dec,sign)
592
593 i=0
594
595 '符号の取り付け
596 If sign Then
597 buffer[i]=Asc("-")
598 i=i+1
599 End If
600
601 If dec>15 Then
602 '指数表示(桁が大きい場合)
603 buffer[i]=temp[0]
604 i=i+1
605 buffer[i]=Asc(".")
606 i=i+1
607 memcpy(buffer+i,temp+1,14)
608 i=i+14
609 buffer[i]=Asc("e")
610 i=i+1
611 wsprintf(buffer+i,"+%03d",dec-1)
612
613 Return MakeStr(buffer)
614 End If
615
616 If dec<-3 Then
617 '指数表示(桁が小さい場合)
618 buffer[i]=temp[0]
619 i=i+1
620 buffer[i]=Asc(".")
621 i=i+1
622 memcpy(buffer+i,temp+1,14)
623 i=i+14
624 buffer[i]=Asc("e")
625 i=i+1
626 wsprintf(buffer+i,"%03d",dec-1)
627
628 Return MakeStr(buffer)
629 End If
630
631 '整数部
632 i2=dec
633 i3=0
634 If i2>0 Then
635 While i2>0
636 buffer[i]=temp[i3]
637 i=i+1
638 i3=i3+1
639 i2=i2-1
640 Wend
641 buffer[i]=Asc(".")
642 i=i+1
643 Else
644 buffer[i]=&H30
645 i=i+1
646 buffer[i]=Asc(".")
647 i=i+1
648
649 i2=dec
650 While i2<0
651 buffer[i]=&H30
652 i=i+1
653 i2=i2+1
654 Wend
655 End If
656
657 '小数部
658 While i3<15
659 buffer[i]=temp[i3]
660 i=i+1
661 i3=i3+1
662 Wend
663
664 While buffer[i-1]=&H30
665 i=i-1
666 Wend
667 If buffer[i-1]=Asc(".") Then i=i-1
668
669 buffer[i]=0
670 Return MakeStr(buffer)
671End Function
672Function Str$(value As LONG_PTR) As String
673 Dim temp[255] As Byte
674 wsprintf(temp,"%d",value)
675 Str$=MakeStr(temp)
676End Function
677
678Function String$(num As Long, buf As String) As String
679 Dim dwStrPtr As DWord
680 Dim length As Long
681
682 length=Len(buf)
683
684 'バッファ領域を確保
685 String$=ZeroString(length*num)
686
687 '文字列をコピー
688 Dim i As Long
689 For i=0 To num-1
690 memcpy(StrPtr(String$)+i*length,StrPtr(buf),length)
691 Next
692End Function
693
694Function Time$() As String
695 Dim st As SYSTEMTIME
696
697 GetLocalTime(st)
698
699 'hour
700 If st.wHour<10 Then
701 Time$="0"
702 End If
703 Time$=Time$+Str$(st.wHour)
704
705 'minute
706 If st.wMinute<10 Then
707 Time$=Time$+":0"
708 Else
709 Time$=Time$+":"
710 End If
711 Time$=Time$+Str$(st.wMinute)
712
713 'second
714 If st.wSecond<10 Then
715 Time$=Time$+":0"
716 Else
717 Time$=Time$+":"
718 End If
719 Time$=Time$+Str$(st.wSecond)
720End Function
721
722Function Val(buf As BytePtr) As Double
723 Dim i As Long, i2 As Long, i3 As Long, i4 As Long
724 Dim temporary As String
725 Dim TempPtr As BytePtr
726 Dim dbl As Double
727 Dim i64data As Int64
728
729 Val=0
730
731 While buf[0]=Asc(" ") or buf[0]=Asc(Ex"\t")
732 buf++
733 Wend
734
735 If buf[0]=Asc("&") Then
736 temporary=ZeroString(lstrlen(buf))
737 lstrcpy(temporary,buf)
738 TempPtr=StrPtr(temporary)
739 CharUpper(TempPtr)
740 If TempPtr(1)=Asc("O") Then
741 '8進数
742 i=2
743 While 1
744 '数字以外の文字の場合は抜け出す
745 i3=TempPtr[i]-&H30
746 If Not (0<=i3 And i3<=7) Then Exit While
747
748 TempPtr[i]=i3 As Byte
749 i++
750 Wend
751 i--
752
753 i64data=1
754 While i>=2
755 Val=Val+i64data*TempPtr[i]
756
757 i64data=i64data*&O10
758 i=i-1
759 Wend
760 ElseIf TempPtr(1)=Asc("H") Then
761 '16進数
762 i=2
763 While 1
764 '数字以外の文字の場合は抜け出す
765 i3=TempPtr[i]-&H30
766 If Not(0<=i3 and i3<=9) Then
767 i3=TempPtr[i]-&H41+10
768 If Not(&HA<=i3 and i3<=&HF) Then Exit While
769 End If
770
771 TempPtr[i]=i3 As Byte
772 i++
773 Wend
774 i--
775
776 i64data=1
777 While i>=2
778 Val=Val+i64data*TempPtr[i]
779
780 i64data=i64data*&H10
781 i--
782 Wend
783 End If
784 Else
785 '10進数
786 If buf[0]=&H2D Then
787 'マイナス値
788 i4=1
789 buf++
790 Else
791 'プラス値
792 i4=0
793 If buf[0]=&H2B Then
794 buf++
795 End If
796 End If
797
798 i=0
799
800 While 1
801 '数字以外の文字の場合は抜け出す
802 i3=buf[i]-&H30
803 If Not (0<=i3 And i3<=9) Then Exit While
804
805 i++
806 Wend
807
808 '整数部
809 dbl=1
810 i3=i-1
811 While i3>=0
812 Val=Val+dbl*(buf[i3]-&H30)
813
814 dbl=dbl*10
815 i3--
816 Wend
817
818 If buf[i]=Asc(".") Then
819 '小数部
820 i++
821 dbl=10
822 While 1
823 '数字以外の文字の場合は抜け出す
824 i3=buf[i]-&H30
825 If Not (0<=i3 And i3<=9) Then Exit While
826
827 Val += (buf[i] - &H30) / dbl
828 dbl *= 10
829 i++
830 Wend
831 End If
832
833 If i4 Then Val=-Val
834 End If
835End Function
836
837
838'--------------
839' ファイル関数
840'--------------
841
842Function Eof(FileNum As Long) As Long
843 Dim dwCurrent As DWord, dwEnd As DWord
844
845 FileNum--
846
847 dwCurrent=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_CURRENT)
848 dwEnd=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_END)
849 SetFilePointer(_System_hFile(FileNum),dwCurrent,NULL,FILE_BEGIN)
850
851 If dwCurrent>=dwEnd Then
852 Eof=-1
853 Else
854 Eof=0
855 End If
856End Function
857
858Function Lof(FileNum As Long) As Long
859 Lof=GetFileSize(_System_hFile(FileNum-1),NULL)
860End Function
861
862Function Loc(FileNum As Long) As Long
863 Dim NowPos As Long, BeginPos As Long
864
865 FileNum=FileNum-1
866
867 NowPos=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_CURRENT)
868 BeginPos=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_BEGIN)
869 SetFilePointer(_System_hFile(FileNum),NowPos-BeginPos,NULL,FILE_BEGIN)
870
871 Loc=NowPos-BeginPos
872End Function
873
874
875'------------------
876' メモリ関連の関数
877'------------------
878
879Function malloc(stSize As SIZE_T) As VoidPtr
880 Return _System_GC.__malloc(stSize,_System_GC_FLAG_NEEDFREE)
881End Function
882
883Function calloc(stSize As SIZE_T) As VoidPtr
884 Return _System_GC.__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_INITZERO)
885End Function
886
887Function realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
888 If lpMem = 0 Then
889 Return malloc(stSize)
890 Else
891 Return _System_GC.__realloc(lpMem,stSize)
892 End If
893End Function
894
895Sub free(lpMem As VoidPtr)
896 _System_GC.__free(lpMem)
897End Sub
898
899
900Function _System_malloc(stSize As SIZE_T) As VoidPtr
901 Return HeapAlloc(_System_hProcessHeap,0,stSize)
902End Function
903
904Function _System_calloc(stSize As SIZE_T) As VoidPtr
905 Return HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,stSize)
906End Function
907
908Function _System_realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
909 If lpMem = 0 Then
910 Return HeapAlloc(_System_hProcessHeap, 0, stSize)
911 Else
912 Return HeapReAlloc(_System_hProcessHeap, 0, lpMem, stSize)
913 End If
914End Function
915
916Sub _System_free(lpMem As VoidPtr)
917 HeapFree(_System_hProcessHeap,0,lpMem)
918End Sub
919
920
921'--------
922' その他
923'--------
924
925Sub _splitpath(path As BytePtr, drive As BytePtr, dir As BytePtr, fname As BytePtr, ext As BytePtr)
926 Dim i As Long, i2 As Long, i3 As Long, length As Long
927 Dim buffer[MAX_PATH] As Byte
928
929 '":\"をチェック
930 If not(path[1]=&H3A and path[2]=&H5C) Then Exit Sub
931
932 'ドライブ名をコピー
933 If drive Then
934 drive[0]=path[0]
935 drive[1]=path[1]
936 drive[2]=0
937 End If
938
939 'ディレクトリ名をコピー
940 i=2
941 i2=0
942 Do
943 If IsDBCSLeadByte(path[i])=TRUE and path[i+1]<>0 Then
944 If dir Then
945 dir[i2]=path[i]
946 dir[i2+1]=path[i+1]
947 End If
948
949 i=i+2
950 i2=i2+2
951 Continue
952 End If
953
954 If path[i]=0 Then Exit Do
955
956 If path[i]=&H5C Then '"\"記号であるかどうか
957 i3=i2+1
958 End If
959
960 If dir Then dir[i2]=path[i]
961
962 i=i+1
963 i2=i2+1
964 Loop
965 If dir Then dir[i3]=0
966 i3=i3+(i-i2)
967
968 'ファイル名をコピー
969 i=i3
970 i2=0
971 i3=-1
972 Do
973 If IsDBCSLeadByte(path[i])=TRUE and path[i+1]<>0 Then
974 If fname Then
975 fname[i2]=path[i]
976 fname[i2+1]=path[i+1]
977 End If
978
979 i=i+2
980 i2=i2+2
981 Continue
982 End If
983
984 If path[i]=0 Then Exit Do
985
986 If path[i]=&H2E Then '.'記号であるかどうか
987 i3=i2
988 End If
989
990 If fname Then fname[i2]=path[i]
991
992 i=i+1
993 i2=i2+1
994 Loop
995 If i3=-1 Then i3=i2
996 If fname Then fname[i3]=0
997 i3=i3+(i-i2)
998
999 '拡張子名をコピー
1000 If ext Then
1001 If i3 Then
1002 lstrcpy(ext,path+i3)
1003 End If
1004 else ext[0]=0
1005 End If
1006End Sub
1007
1008Function GetBasicColor(ColorCode As Long) As Long
1009 Select Case ColorCode
1010 Case 0
1011 GetBasicColor=RGB(0,0,0)
1012 Case 1
1013 GetBasicColor=RGB(0,0,255)
1014 Case 2
1015 GetBasicColor=RGB(255,0,0)
1016 Case 3
1017 GetBasicColor=RGB(255,0,255)
1018 Case 4
1019 GetBasicColor=RGB(0,255,0)
1020 Case 5
1021 GetBasicColor=RGB(0,255,255)
1022 Case 6
1023 GetBasicColor=RGB(255,255,0)
1024 Case 7
1025 GetBasicColor=RGB(255,255,255)
1026 End Select
1027End Function
1028
1029
1030#endif '_INC_FUNCTION
Note: See TracBrowser for help on using the repository browser.