1  'function.sbp


2 


3 


4  #ifndef _INC_FUNCTION


5  #define _INC_FUNCTION


6 


7 


8  Const _System_PI = 3.14159265358979323846264


9  Const _System_LOG2 = 0.6931471805599453094172321214581765680755


10  Const _System_SQRT2 = 1.41421356237309504880168872421


11 


12 


13  #include <Classes/System/Math.ab>


14 


15 


16  ' サポート関数の定義 


17 


18  Function 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)


30  End Function


31 


32  Function 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


44  End Function


45 


46  Function 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


58  End Function


59 


60  Function 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


76  End Function


77 


78  Function 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


94  End Function


95 


96  #ifdef _WIN64


97 


98  Function _System_GetNaN() As Double


99  SetQWord(VarPtr(_System_GetNaN) As *QWord, &H7FF8000000000000)


100  End Function


101 


102  Function _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)


106  End Function


107 


108  #else


109 


110  Function _System_GetNaN() As Double


111  Dim p As *DWord


112  p = VarPtr(_System_GetNaN) As *DWord


113  p[0] = 0


114  p[1] = &H7FF80000


115  End Function


116 


117  Function _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


124  End Function


125 


126  #endif


127 


128  ' xの符号だけをyのものにした値を返す。


129  ' 引数 x 元となる絶対値


130  ' 引数 y 元となる符号


131  Function CopySign(x As Double, y As Double) As Double


132  SetQWord(VarPtr(CopySign), (GetQWord(VarPtr(x)) And &h7fffffffffffffff) Or (GetQWord(VarPtr(y)) And &h8000000000000000))


133  End Function


134 


135  Function CopySign(x As Single, y As Single) As Single


136  SetDWord(VarPtr(CopySign), (GetDWord(VarPtr(x)) And &h7fffffff) Or (GetDWord(VarPtr(y)) And &h80000000))


137  End Function


138 


139  Function _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


146  End Function


147 


148  Const RAND_MAX=&H7FFFFFFF


149  Dim _System_RndNext=1 As DWord


150 


151  Function rand() As Long


152  _System_RndNext = _System_RndNext * 1103515245 + 12345


153  rand = _System_RndNext >> 1


154  End Function


155 


156  Sub srand(dwSeek As DWord)


157  _System_RndNext = dwSeek


158  End Sub


159 


160 


161  ' ここからBasic標準関数の定義 


162 


163 


164  '


165  ' データ型変換関数


166  '


167 


168  Function CDbl(number As Double) As Double


169  CDbl=number


170  End Function


171 


172  Function _CUDbl(number As QWord) As Double


173  _CUDbl=number As Double


174  End Function


175 


176  Function CDWord(num As Double) As DWord


177  CDWord=num


178  End Function


179 


180  Function CInt(number As Double) As Long


181  CInt=number


182  End Function


183 


184  Function CSng(number As Double) As Single


185  CSng=number


186  End Function


187 


188  #ifdef _WIN64


189  Function Fix(number As Double) As Long


190  Fix=number As Long


191  End Function


192  #else


193  'Fix関数はコンパイラに組み込まれている


194  'Function Fix(number As Double) As Long


195  #endif


196 


197  Function Int(number As Double) As Long


198  Int=Fix(number)


199  If number<0 Then


200  If number<Fix(number) Then Int=Int1


201  End If


202  End 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 


225  Function 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


232  End Function


233 


234  Function Exp(x As Double) As Double


235  Exp = Math.Exp(x)


236  End Function


237 


238  Function Log(x As Double) As Double


239  Log = Math.Log(x)


240  End Function


241 


242  Function Sgn(number As Double) As Long


243  Sgn = Math.Sign(number)


244  End Function


245 


246  Function Sqr(number As Double) As Double


247  Sqr = Math.Sqrt(number)


248  End Function


249 


250  Function Atn(number As Double) As Double


251  Atn = Math.Atan(number)


252  End Function


253 


254  Function _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.4544551033807686783083602485579e6*k


265 


266  x2=x*x


267  t=0


268 


269  For i=19 To 3 Step 2


270  t=x2/(it)


271  Next


272 


273  _Support_tan=x/(1t)


274  End Function


275 


276  Function Atn2(y As Double, x As Double) As Double


277  Atn2 = Math.Atan2(y, x)


278  End Function


279 


280  Function Sin(number As Double) As Double


281  Sin = Math.Sign(number)


282  End Function


283 


284  Function Cos(number As Double) As Double


285  Cos = Math.Cos(number)


286  End Function


287 


288  Function Tan(number As Double) As Double


289  Tan = Math.Tan(number)


290  End Function


291 


292  Function IsNaN(ByVal x As Double) As BOOL


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


303  End Function


304 


305  Function IsInf(x As Double) As BOOL


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)


311  End Function


312 


313  Function IsNaNOrInf(x As Double) As BOOL


314  IsNaNOrInf = IsFinite(x)


315  End Function


316 


317  Function IsFinite(x As Double) As BOOL


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  IsNaNOrInf = (memcmp(p, VarPtr(nan), SizeOf (Double)) = 0)


325  End Function


326 


327  Const RAND_UNIT = (1.0 / (LONG_MAX + 1.0))


328  Function Rnd() As Double


329  Rnd = RAND_UNIT * rand()


330  End Function


331 


332  Const HIBYTE(w) = (((w As Word) >> 8) and &HFF) As Byte


333  Const LOBYTE(w) = ((w As Word) and &HFF) As Byte


334  Const HIWORD(dw) = (((dw As DWord) >> 16) and &HFFFF) As Word


335  Const LOWORD(dw) = ((dw As DWord) and &HFFFF) As Word


336 


337  Const MAKEWORD(a,b) = (((a As Word) and &HFF) or (((b As Word) and &HFF)<<8)) As Word


338  Const MAKELONG(a,b) = (((a As DWord) and &HFFFF) or (((b As DWord) and &HFFFF)<<16)) As Long


339 


340 


341 


342  '


343  ' 文字列関数


344  '


345 


346  Function Asc(buf As String) As Byte


347  Asc = buf[0]


348  End Function


349 


350  Function Chr$(code As Byte) As String


351  Chr$=ZeroString(1)


352  Chr$[0]=code


353  End Function


354 


355  Function Date$() As String


356  Dim st As SYSTEMTIME


357 


358  GetLocalTime(st)


359 


360  'year


361  Date$=Str$(st.wYear)


362 


363  'month


364  If st.wMonth<10 Then


365  Date$=Date$+"/0"


366  Else


367  Date$=Date$+"/"


368  End If


369  Date$=Date$+Str$(st.wMonth)


370 


371  'day


372  If st.wDay<10 Then


373  Date$=Date$+"/0"


374  Else


375  Date$=Date$+"/"


376  End If


377  Date$=Date$+Str$(st.wDay)


378  End Function


379 


380  Function Hex$(num As DWord) As String


381  Dim length As Long


382  Hex$=ZeroString(8)


383  length=wsprintf(Hex$, "%X", num)


384  Hex$=Left$(Hex$,length)


385  End Function


386 


387  Function Hex$(num As QWord) As String


388  Dim length As Long


389  Hex$=ZeroString(16)


390  length=wsprintf(Hex$, "%X%X", num)


391  Hex$=Left$(Hex$,length)


392  End Function


393 


394  Function InStr(StartPos As Long, buf1 As String, buf2 As String) As Long


395  Dim len1 As Long, len2 As Long, i As Long, i2 As Long, i3 As Long


396 


397  len1=Len(buf1)


398  len2=Len(buf2)


399 


400  If len2=0 Then


401  InStr=StartPos


402  Exit Function


403  End If


404 


405  StartPos


406  If StartPos<0 Then


407  'error


408  InStr=0


409  Exit Function


410  End If


411 


412  i=StartPos:InStr=0


413  While i<=len1len2


414  i2=i:i3=0


415  Do


416  If i3=len2 Then


417  InStr=i+1


418  Exit Do


419  End If


420  If buf1[i2]<>buf2[i3] Then Exit Do


421 


422  i2++


423  i3++


424  Loop


425  If InStr Then Exit While


426  i++


427  Wend


428  End Function


429 


430  Function Left$(buf As String, length As Long) As String


431  Left$=ZeroString(length)


432  memcpy(


433  StrPtr(Left$),


434  StrPtr(buf),


435  length)


436  End Function


437 


438  Function Mid$(buf As String, StartPos As Long)(ReadLength As Long) As String


439  Dim length As Long


440 


441  StartPos


442  If StartPos<0 Then


443  'error


444  'Debug


445  Exit Function


446  End If


447 


448  length=Len(buf)


449  If length<=StartPos Then Exit Function


450 


451  If ReadLength=0 Then


452  ReadLength=lengthStartPos


453  End If


454 


455  If ReadLength>lengthStartPos Then


456  ReadLength=lengthStartPos


457  End If


458 


459  Mid$=ZeroString(ReadLength)


460  memcpy(StrPtr(Mid$),StrPtr(buf)+StartPos,ReadLength)


461  End Function


462 


463  Function Oct$(num As DWord) As String


464  Dim i As DWord, i2 As DWord


465 


466  For i=10 To 1 Step 1


467  If (num\CDWord(8^i)) And &H07 Then


468  Exit For


469  End If


470  Next


471 


472  Oct$=ZeroString(i+1)


473  i2=0


474  Do


475  Oct$[i2]=Asc("0")+((num\CDWord(8^i)) And &H07)


476  If i=0 Then Exit Do


477  i


478  i2++


479  Loop


480  End Function


481 


482  Function Right$(buf As String, length As Long) As String


483  Dim i As Long


484 


485  i=Len(buf)


486  If i>length Then


487  Right$=ZeroString(length)


488  memcpy(StrPtr(Right$),StrPtr(buf)+ilength,length)


489  Else


490  Right$=buf


491  End If


492  End Function


493 


494  Function Space$(length As Long) As String


495  Space$=ZeroString(length)


496  FillMemory(StrPtr(Space$),length,&H20)


497  End Function


498 


499  Dim _System_ecvt_buffer[16] As Byte


500  Sub _ecvt_support(count As Long)


501  Dim i As Long


502  If _System_ecvt_buffer[count]=9 Then


503  _System_ecvt_buffer[count]=0


504  If count=0 Then


505  For i=16 To 1 Step 1


506  _System_ecvt_buffer[i]=_System_ecvt_buffer[i1]


507  Next


508  _System_ecvt_buffer[0]=1


509  Else


510  _ecvt_support(count1)


511  End If


512  Else


513  _System_ecvt_buffer[count]=_System_ecvt_buffer[count]+1 As Byte


514  End If


515  End Sub


516  Function _ecvt(value As Double, count As Long, ByRef dec As Long, ByRef sign As Long) As BytePtr


517  Dim temp As BytePtr


518  Dim i As Long, i2 As Long


519 


520  _ecvt=_System_ecvt_buffer


521 


522  '値が0の場合


523  If value=0 Then


524  FillMemory(_System_ecvt_buffer,count,&H30)


525  _System_ecvt_buffer[count]=0


526  dec=0


527  sign=0


528  Exit Function


529  End If


530 


531  '符号の判断（同時に符号を取り除く）


532  If value<0 Then


533  sign=1


534  value=value


535  Else


536  sign=0


537  End If


538 


539  '正規化


540  dec=1


541  While value<0.999999999999999 'value<1


542  value=value*10


543  dec=dec1


544  Wend


545  While 9.99999999999999<=value '10<=value


546  value=value/10


547  dec=dec+1


548  Wend


549 


550  For i=0 To count1


551  _System_ecvt_buffer[i]=Int(value) As Byte


552 


553  value=(valueCDbl(Int(value)))*10


554  Next


555  _System_ecvt_buffer[i]=0


556 


557  i=i1


558  If value>=5 Then


559  '切り上げ処理


560  _ecvt_support(i)


561  End If


562 


563  For i=0 To count1


564  _System_ecvt_buffer[i]=_System_ecvt_buffer[i]+&H30


565  Next


566  _System_ecvt_buffer[i]=0


567  End Function


568 


569  Function Str$(dbl As Double) As String


570  If IsNaN(dbl) Then


571  Return "NaN"


572  ElseIf IsInf(dbl) Then


573  If dbl > 0 Then


574  Return "Infinity"


575  Else


576  Return "Infinity"


577  End If


578  End If


579  Dim dec As Long, sign As Long


580  Dim buffer[32] As Byte, temp As BytePtr


581  Dim i As Long, i2 As Long, i3 As Long


582 


583  '浮動小数点を文字列に変換


584  temp=_ecvt(dbl,15,dec,sign)


585 


586  i=0


587 


588  '符号の取り付け


589  If sign Then


590  buffer[i]=Asc("")


591  i++


592  End If


593 


594  If dec>15 Then


595  '指数表示（桁が大きい場合）


596  buffer[i]=temp[0]


597  i++


598  buffer[i]=Asc(".")


599  i++


600  memcpy(buffer+i,temp+1,14)


601  i+=14


602  buffer[i]=Asc("e")


603  i++


604  wsprintf(buffer+i,"+%03d",dec1)


605 


606  Return MakeStr(buffer)


607  End If


608 


609  If dec<3 Then


610  '指数表示（桁が小さい場合）


611  buffer[i]=temp[0]


612  i++


613  buffer[i]=Asc(".")


614  i++


615  memcpy(buffer+i,temp+1,14)


616  i+=14


617  buffer[i]=Asc("e")


618  i++


619  wsprintf(buffer+i,"%03d",dec1)


620 


621  Return MakeStr(buffer)


622  End If


623 


624  '整数部


625  i2=dec


626  i3=0


627  If i2>0 Then


628  While i2>0


629  buffer[i]=temp[i3]


630  i++


631  i3++


632  i2


633  Wend


634  buffer[i]=Asc(".")


635  i++


636  Else


637  buffer[i]=&H30


638  i++


639  buffer[i]=Asc(".")


640  i++


641 


642  i2=dec


643  While i2<0


644  buffer[i]=&H30


645  i++


646  i2++


647  Wend


648  End If


649 


650  '小数部


651  While i3<15


652  buffer[i]=temp[i3]


653  i++


654  i3++


655  Wend


656 


657  While buffer[i1]=&H30


658  i


659  Wend


660  If buffer[i1]=Asc(".") Then i


661 


662  buffer[i]=0


663  Return MakeStr(buffer)


664  End Function


665  Function Str$(value As LONG_PTR) As String


666  Dim temp[255] As Byte


667  wsprintf(temp,"%d",value)


668  Str$=MakeStr(temp)


669  End Function


670 


671  Function String$(num As Long, buf As String) As String


672  Dim dwStrPtr As DWord


673  Dim length As Long


674 


675  length=Len(buf)


676 


677  'バッファ領域を確保


678  String$=ZeroString(length*num)


679 


680  '文字列をコピー


681  Dim i As Long


682  For i=0 To num1


683  memcpy(StrPtr(String$)+i*length,StrPtr(buf),length)


684  Next


685  End Function


686 


687  Function Time$() As String


688  Dim st As SYSTEMTIME


689 


690  GetLocalTime(st)


691 


692  'hour


693  If st.wHour<10 Then


694  Time$="0"


695  End If


696  Time$=Time$+Str$(st.wHour)


697 


698  'minute


699  If st.wMinute<10 Then


700  Time$=Time$+":0"


701  Else


702  Time$=Time$+":"


703  End If


704  Time$=Time$+Str$(st.wMinute)


705 


706  'second


707  If st.wSecond<10 Then


708  Time$=Time$+":0"


709  Else


710  Time$=Time$+":"


711  End If


712  Time$=Time$+Str$(st.wSecond)


713  End Function


714 


715  Function Val(buf As BytePtr) As Double


716  Dim i As Long, i2 As Long, i3 As Long, i4 As Long


717  Dim temporary As String


718  Dim TempPtr As BytePtr


719  Dim dbl As Double


720  Dim i64data As Int64


721 


722  Val=0


723 


724  While buf[0]=Asc(" ") or buf[0]=Asc(Ex"\t")


725  buf++


726  Wend


727 


728  If buf[0]=Asc("&") Then


729  temporary=ZeroString(lstrlen(buf))


730  lstrcpy(temporary,buf)


731  TempPtr=StrPtr(temporary)


732  CharUpper(TempPtr)


733  If TempPtr(1)=Asc("O") Then


734  '8進数


735  i=2


736  While 1


737  '数字以外の文字の場合は抜け出す


738  i3=TempPtr[i]&H30


739  If Not (0<=i3 And i3<=7) Then Exit While


740 


741  TempPtr[i]=i3 As Byte


742  i++


743  Wend


744  i


745 


746  i64data=1


747  While i>=2


748  Val=Val+i64data*TempPtr[i]


749 


750  i64data=i64data*&O10


751  i


752  Wend


753  ElseIf TempPtr(1)=Asc("H") Then


754  '16進数


755  i=2


756  While 1


757  '数字以外の文字の場合は抜け出す


758  i3=TempPtr[i]&H30


759  If Not(0<=i3 and i3<=9) Then


760  i3=TempPtr[i]&H41+10


761  If Not(&HA<=i3 and i3<=&HF) Then Exit While


762  End If


763 


764  TempPtr[i]=i3 As Byte


765  i++


766  Wend


767  i


768 


769  i64data=1


770  While i>=2


771  Val += (i64data*TempPtr[i]) As Double


772 


773  i64data *= &H10


774  i


775  Wend


776  End If


777  Else


778  '10進数


779  If buf[0]=&H2D Then


780  'マイナス値


781  i4=1


782  buf++


783  Else


784  'プラス値


785  i4=0


786  If buf[0]=&H2B Then


787  buf++


788  End If


789  End If


790 


791  i=0


792 


793  While 1


794  '数字以外の文字の場合は抜け出す


795  i3=buf[i]&H30


796  If Not (0<=i3 And i3<=9) Then Exit While


797 


798  i++


799  Wend


800 


801  '整数部


802  dbl=1


803  i3=i1


804  While i3>=0


805  Val += dbl*(buf[i3]&H30)


806 


807  dbl *= 10


808  i3


809  Wend


810 


811  If buf[i]=Asc(".") Then


812  '小数部


813  i++


814  dbl=10


815  While 1


816  '数字以外の文字の場合は抜け出す


817  i3=buf[i]&H30


818  If Not (0<=i3 And i3<=9) Then Exit While


819 


820  Val += (buf[i]  &H30) / dbl


821  dbl *= 10


822  i++


823  Wend


824  End If


825 


826  If i4 Then Val=Val


827  End If


828  End Function


829 


830 


831  '


832  ' ファイル関数


833  '


834 


835  Function Eof(FileNum As Long) As Long


836  Dim dwCurrent As DWord, dwEnd As DWord


837 


838  FileNum


839 


840  dwCurrent=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_CURRENT)


841  dwEnd=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_END)


842  SetFilePointer(_System_hFile(FileNum),dwCurrent,NULL,FILE_BEGIN)


843 


844  If dwCurrent>=dwEnd Then


845  Eof=1


846  Else


847  Eof=0


848  End If


849  End Function


850 


851  Function Lof(FileNum As Long) As Long


852  Lof=GetFileSize(_System_hFile(FileNum1),NULL)


853  End Function


854 


855  Function Loc(FileNum As Long) As Long


856  Dim NowPos As Long, BeginPos As Long


857 


858  FileNum


859 


860  NowPos=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_CURRENT)


861  BeginPos=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_BEGIN)


862  SetFilePointer(_System_hFile(FileNum),NowPosBeginPos,NULL,FILE_BEGIN)


863 


864  Loc=NowPosBeginPos


865  End Function


866 


867 


868  '


869  ' メモリ関連の関数


870  '


871 


872  Function malloc(stSize As SIZE_T) As VoidPtr


873  Return _System_GC.__malloc(stSize,_System_GC_FLAG_NEEDFREE)


874  End Function


875 


876  Function calloc(stSize As SIZE_T) As VoidPtr


877  Return _System_GC.__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_INITZERO)


878  End Function


879 


880  Function realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr


881  If lpMem = 0 Then


882  Return malloc(stSize)


883  Else


884  Return _System_GC.__realloc(lpMem,stSize)


885  End If


886  End Function


887 


888  Sub free(lpMem As VoidPtr)


889  _System_GC.__free(lpMem)


890  End Sub


891 


892 


893  Function _System_malloc(stSize As SIZE_T) As VoidPtr


894  Return HeapAlloc(_System_hProcessHeap,0,stSize)


895  End Function


896 


897  Function _System_calloc(stSize As SIZE_T) As VoidPtr


898  Return HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,stSize)


899  End Function


900 


901  Function _System_realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr


902  If lpMem = 0 Then


903  Return HeapAlloc(_System_hProcessHeap, 0, stSize)


904  Else


905  Return HeapReAlloc(_System_hProcessHeap, 0, lpMem, stSize)


906  End If


907  End Function


908 


909  Sub _System_free(lpMem As VoidPtr)


910  HeapFree(_System_hProcessHeap,0,lpMem)


911  End Sub


912 


913 


914  '


915  ' その他


916  '


917 


918  Sub _splitpath(path As BytePtr, drive As BytePtr, dir As BytePtr, fname As BytePtr, ext As BytePtr)


919  Dim i As Long, i2 As Long, i3 As Long, length As Long


920  Dim buffer[MAX_PATH] As Byte


921 


922  '":\"をチェック


923  If not(path[1]=&H3A and path[2]=&H5C) Then Exit Sub


924 


925  'ドライブ名をコピー


926  If drive Then


927  drive[0]=path[0]


928  drive[1]=path[1]


929  drive[2]=0


930  End If


931 


932  'ディレクトリ名をコピー


933  i=2


934  i2=0


935  Do


936  If IsDBCSLeadByte(path[i])=TRUE and path[i+1]<>0 Then


937  If dir Then


938  dir[i2]=path[i]


939  dir[i2+1]=path[i+1]


940  End If


941 


942  i += 2


943  i2 += 2


944  Continue


945  End If


946 


947  If path[i]=0 Then Exit Do


948 


949  If path[i]=&H5C Then '"\"記号であるかどうか


950  i3=i2+1


951  End If


952 


953  If dir Then dir[i2]=path[i]


954 


955  i++


956  i2++


957  Loop


958  If dir Then dir[i3]=0


959  i3 += ii2


960 


961  'ファイル名をコピー


962  i=i3


963  i2=0


964  i3=1


965  Do


966  If IsDBCSLeadByte(path[i])=TRUE and path[i+1]<>0 Then


967  If fname Then


968  fname[i2]=path[i]


969  fname[i2+1]=path[i+1]


970  End If


971 


972  i += 2


973  i2 += 2


974  Continue


975  End If


976 


977  If path[i]=0 Then Exit Do


978 


979  If path[i]=&H2E Then '.'記号であるかどうか


980  i3=i2


981  End If


982 


983  If fname Then fname[i2]=path[i]


984 


985  i++


986  i2++


987  Loop


988  If i3=1 Then i3=i2


989  If fname Then fname[i3]=0


990  i3 += ii2


991 


992  '拡張子名をコピー


993  If ext Then


994  If i3 Then


995  lstrcpy(ext,path+i3)


996  End If


997  else ext[0]=0


998  End If


999  End Sub


1000 


1001  Function GetBasicColor(ColorCode As Long) As Long


1002  Select Case ColorCode


1003  Case 0


1004  GetBasicColor=RGB(0,0,0)


1005  Case 1


1006  GetBasicColor=RGB(0,0,255)


1007  Case 2


1008  GetBasicColor=RGB(255,0,0)


1009  Case 3


1010  GetBasicColor=RGB(255,0,255)


1011  Case 4


1012  GetBasicColor=RGB(0,255,0)


1013  Case 5


1014  GetBasicColor=RGB(0,255,255)


1015  Case 6


1016  GetBasicColor=RGB(255,255,0)


1017  Case 7


1018  GetBasicColor=RGB(255,255,255)


1019  End Select


1020  End Function


1021 


1022 


1023  #endif '_INC_FUNCTION

