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  #require <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(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


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 As DWord


178  End Function


179 


180  Function CInt(number As Double) As Long


181  CInt=number As Long


182  End Function


183 


184  Function CSng(number As Double) As Single


185  CSng=number As Single


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.Sin(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 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


303  End Function


304 


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


311  End Function


312 


313  Function IsNaNOrInf(x As Double) As Boolean


314  IsNaNOrInf = IsFinite(x)


315  End Function


316 


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


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 HIDWORD(qw) = (((qw As QWord) >> 32) And &HFFFFFFFF) As DWord


333  Const LODWORD(qw) = ((qw As QWord) And &HFFFFFFFF) As DWord


334 


335  Const MAKEDWORD(l, h) = (((l As DWord) And &HFFFF) Or (((h As DWord) And &HFFFF) << 16)) As DWord


336  Const MAKEQWORD(l, h) = (((l As QWord) And &HFFFFFFFF) Or (((h As QWord) And &HFFFFFFFF) << 32)) As QWord


337 


338  '


339  ' 文字列関数


340  '


341 


342  Function Asc(buf As *StrChar) As StrChar


343  Asc = buf[0]


344  End Function


345 


346  Function Chr$(code As StrChar) As String


347  Chr$ = ZeroString(1)


348  Chr$[0] = code


349  End Function


350 


351  #ifndef __STRING_IS_NOT_UNICODE


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


362  End Function


363 


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


375  End Function


376  #endif


377 


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


400  End Function


401 


402  Dim _System_HexadecimalTable[&h10] = [&h30, &h31, &h32, &h33, &h34, &h35, &h36, &h37, &h38, &h39, &h41, &h42, &h43, &h44, &h45, &h46] As Byte


403 


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


422  End Function


423 


424  Function Hex$(x As DWord) As String


425  Hex$ = _System_Hex(x, True)


426  End Function


427 


428  Function Hex$(x As QWord) As String


429  Hex$ = _System_Hex(HIDWORD(x), True) + _System_Hex(LODWORD(x), False)


430  End Function


431 


432  Function 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<=len1len2


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


466  End Function


467 


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


469  Left$ = ZeroString(length)


470  memcpy(StrPtr(Left$), StrPtr(buf), SizeOf (StrChar) * length)


471  End Function


472 


473  Function 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=lengthStartPos


488  End If


489 


490  If ReadLength>lengthStartPos Then


491  ReadLength=lengthStartPos


492  End If


493 


494  Mid$=ZeroString(ReadLength)


495  memcpy(StrPtr(Mid$), VarPtr(buf.Chars[StartPos]), SizeOf (StrChar) * ReadLength)


496  End Function


497 


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


515  End Function


516 


517  Function 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[ilength]), SizeOf (StrChar) * length)


524  Else


525  Right$=buf


526  End If


527  End Function


528 


529  Function Space$(length As Long) As String


530  Space$.ReSize(length, &H20 As StrChar)


531  End Function


532 


533  Dim _System_ecvt_buffer[16] As StrChar


534  Sub _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[i1]


541  Next


542  _System_ecvt_buffer[0]=1


543  Else


544  _ecvt_support(count1)


545  End If


546  Else


547  _System_ecvt_buffer[count]++


548  End If


549  End Sub


550  Function _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, &H30)


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 count1


584  _System_ecvt_buffer[i] = Int(value) As StrChar


585 


586  value = (valueCDbl(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


600  End Function


601 


602  Function 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[i1]=&H30


691  i


692  Wend


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


694 


695  buffer[i]=0


696  Return MakeStr(buffer)


697  End Function


698 


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


703  End Function


704 


705  Function 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 num1


717  memcpy(VarPtr(String$[i*length]), StrPtr(buf), SizeOf (StrChar) * length)


718  Next


719  End Function


720 


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


747  End Function


748 


749  Function 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=i1


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


861  End Function


862 


863 


864  '


865  ' ファイル関数


866  '


867 


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


882  End Function


883 


884  Function Lof(FileNum As Long) As Long


885  Lof = GetFileSize(_System_hFile(FileNum1), 0)


886  End Function


887 


888  Function 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),NowPosBeginPos,NULL,FILE_BEGIN)


896 


897  Loc=NowPosBeginPos


898  End Function


899 


900 


901  '


902  ' メモリ関連の関数


903  '


904 


905  Function malloc(stSize As SIZE_T) As VoidPtr


906  Return _System_pGC>__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC)


907  End Function


908 


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


911  End Function


912 


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


919  End Function


920 


921  Sub free(lpMem As VoidPtr)


922  _System_pGC>__free(lpMem)


923  End Sub


924 


925 


926  Function _System_malloc(stSize As SIZE_T) As VoidPtr


927  Return HeapAlloc(_System_hProcessHeap,0,stSize)


928  End Function


929 


930  Function _System_calloc(stSize As SIZE_T) As VoidPtr


931  Return HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,stSize)


932  End Function


933 


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


940  End Function


941 


942  Sub _System_free(lpMem As VoidPtr)


943  HeapFree(_System_hProcessHeap,0,lpMem)


944  End Sub


945 


946 


947  '


948  ' その他


949  '


950 


951  Sub _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 += ii2


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 += ii2


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


1036  End Sub


1037 


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


1057  End Function


1058 


1059  Function _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]


1064  End Function


1065 


1066  Function _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]


1073  End Function


1074 


1075  Function _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]


1086  End Function


1087 


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


1095  End Function


1096 


1097  '


1098  ' 文字列関数その2


1099  '


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


1107  End Function


1108 


1109  Function _System_IsDoubleUnitChar(lead As WCHAR, trail As WCHAR) As Boolean


1110  Return _System_IsSurrogatePair(lead, trail)


1111  End Function


1112 


1113  Function _System_IsDoubleUnitChar(lead As SByte, trail As SByte) As Boolean


1114  Return IsDBCSLeadByte(lead) <> FALSE


1115  End Function


1116 


1117  Sub _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


1122  End Sub


1123 


1124  Sub _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


1129  End Sub


1130 


1131  Function _System_ASCII_IsUpper(c As WCHAR) As Boolean


1132  Return c As DWord  &h41 < 26 ' &h41 = Asc("A")


1133  End Function


1134 


1135  Function _System_ASCII_IsUpper(c As SByte) As Boolean


1136  Return _System_ASCII_IsUpper(c As Byte As WCHAR)


1137  End Function


1138 


1139  Function _System_ASCII_IsLower(c As WCHAR) As Boolean


1140  Return c As DWord  &h61 < 26 ' &h61 = Asc("a")


1141  End Function


1142 


1143  Function _System_ASCII_IsLower(c As SByte) As Boolean


1144  Return _System_ASCII_IsLower(c As Byte As WCHAR)


1145  End Function


1146 


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


1153  End Function


1154 


1155  Function _System_ASCII_ToLower(c As SByte) As SByte


1156  Return _System_ASCII_ToLower(c As Byte As WCHAR) As Byte As SByte


1157  End Function


1158 


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


1165  End Function


1166 


1167  Function _System_ASCII_ToUpper(c As SByte) As SByte


1168  Return _System_ASCII_ToUpper(c As Byte As WCHAR) As Byte As SByte


1169  End Function


1170 


1171 


1172  Function _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]


1181  End Function


1182 


1183  Function _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]


1192  End Function


1193 


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


1201  End Function


1202 


1203  #endif '_INC_FUNCTION

