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  Const _System_Log_N = 7 As Long


12 


13 


14  #require <Classes/System/Math.ab>


15  #require <Classes/System/DateTime.ab>


16  #require <Classes/System/Text/StringBuilder.ab>


17  #require <Classes/ActiveBasic/Math/Math.ab>


18  #require <Classes/ActiveBasic/Strings/Strings.ab>


19 


20 


21  ' サポート関数の定義 


22 


23  Function ldexp(x As Double, n As Long) As Double


24  If x = 0 Then


25  ldexp = 0


26  Exit Function


27  End If


28  Dim pSrc = VarPtr(x) As *QWord


29  Dim pDest = VarPtr(ldexp) As *QWord


30  n += (pSrc[0] >> 52) As DWord And &h7FF


31  pDest[0] = n << 52 Or (pSrc[0] And &h800FFFFFFFFFFFFF)


32  End Function


33 


34  Function frexp(x As Double, ByRef n As Long) As Double


35  If x = 0 Then


36  n = 0


37  frexp = 0


38  Exit Function


39  End If


40 


41  Dim pSrc = VarPtr(x) As *QWord


42  Dim pDest = VarPtr(frexp) As *QWord


43  n = ((pSrc[0] >> 52) As DWord And &h7FF)  1022


44  pDest[0] = (pSrc[0] And &h800FFFFFFFFFFFFF) Or &h3FE0000000000000


45  End Function


46 


47  Function frexp(x As Single, ByRef n As Long) As Single


48  If x = 0 Then


49  n = 0


50  frexp = 0


51  Exit Function


52  End If


53 


54  Dim pSrc As *DWord, pDest As *DWord


55  pSrc = VarPtr(x) As *DWord


56  pDest = VarPtr(frexp) As *DWord


57  n = ((pSrc[0] >> 23) And &hFF)  126


58  pDest[0] = (pSrc[0] And &h807FFFFF) Or &h7E000000


59  End Function


60 


61  Function ipow(x As Double, n As Long) As Double


62  Dim abs_n As Long


63  Dim r = 1 As Double


64 


65  abs_n=Abs(n) As Long


66  While abs_n<>0


67  If abs_n and 1 Then r *= x


68  x = x * x


69  abs_n >>= 1 ' abs_n \= 2


70  Wend


71 


72  If n>=0 Then


73  ipow=r


74  Else


75  ipow=1/r


76  End If


77  End Function


78 


79  Function pow(x As Double, y As Double) As Double


80  If LONG_MAX<=y and y<=LONG_MAX and y=CDbl(Int(y)) Then


81  pow=ipow(x,y As Long)


82  Exit Function


83  End If


84 


85  If x>0 Then


86  pow=Exp(y*Log(x))


87  Exit Function


88  End If


89 


90  If x<>0 or y<=0 Then


91  'error


92  End If


93 


94  pow=0


95  End Function


96 


97  Const RAND_MAX = &H7FFFFFFF


98  Dim _System_RndNext = 1 As DWord


99 


100  Function rand() As Long


101  _System_RndNext = _System_RndNext * 1103515245 + 12345


102  rand = (_System_RndNext >> 1) As Long


103  End Function


104 


105  Sub srand(dwSeek As DWord)


106  _System_RndNext = dwSeek


107  End Sub


108 


109 


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


111 


112  '


113  ' データ型変換関数


114  '


115 


116  Function CDbl(number As Double) As Double


117  CDbl=number


118  End Function


119 


120  Function _CUDbl(number As QWord) As Double


121  _CUDbl=number As Double


122  End Function


123 


124  Function CDWord(num As Double) As DWord


125  CDWord=num As DWord


126  End Function


127 


128  Function CInt(number As Double) As Long


129  CInt=number As Long


130  End Function


131 


132  Function CSng(number As Double) As Single


133  CSng=number As Single


134  End Function


135 


136  #ifdef _WIN64


137  Function Fix(number As Double) As Long


138  Fix=number As Long


139  End Function


140  #else


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


142  'Function Fix(number As Double) As Long


143  #endif


144 


145  Function Int(number As Double) As Long


146  Int = Fix(number)


147  If number < 0 Then


148  If number < Fix(number) Then Int


149  End If


150  End Function


151 


152 


153  '


154  ' ポインタ関数（コンパイラに組み込み）


155  '


156 


157  'Function GetDouble(p As DWord) As Double


158  'Function GetSingle(p As DWord) As Single


159  'Function GetDWord(p As DWord) As DWord


160  'Function GetWord(p As DWord) As Word


161  'Function GetByte(p As DWord) As Byte


162  'Sub SetDouble(p As DWord, dblData As Double)


163  'Sub SetSingle(p As DWord, fltData As Single)


164  'Sub SetDWord(p As DWord, dwData As DWord)


165  'Sub SetWord(p As DWord, wData As Word)


166  'Sub SetByte(p As DWord, byteData As Byte)


167 


168 


169  '


170  ' 算術関数


171  '


172 


173  Function Abs(number As Double) As Double


174  'Abs = System.Math.Abs(number)


175  If number < 0 then


176  Abs = number


177  Else


178  Abs = number


179  End If


180  End Function


181 


182  Function Abs(number As Int64) As Int64


183  If number < 0 then


184  Abs = number


185  Else


186  Abs = number


187  End If


188  End Function


189 


190  Function Abs(number As Long) As Long


191  If number < 0 then


192  Abs = number


193  Else


194  Abs = number


195  End If


196  End Function


197 


198  Function Exp(x As Double) As Double


199  Exp = System.Math.Exp(x)


200  End Function


201 


202  Function Log(x As Double) As Double


203  Log = System.Math.Log(x)


204  End Function


205 


206  Function Sgn(number As Double) As Long


207  Sgn = System.Math.Sign(number)


208  End Function


209 


210  Function Sqr(number As Double) As Double


211  Sqr = System.Math.Sqrt(number)


212  End Function


213 


214  Function Atn(number As Double) As Double


215  Atn = System.Math.Atan(number)


216  End Function


217 


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


219  Atn2 = System.Math.Atan2(y, x)


220  End Function


221 


222  Function Sin(number As Double) As Double


223  Sin = System.Math.Sin(number)


224  End Function


225 


226  Function Cos(number As Double) As Double


227  Cos = System.Math.Cos(number)


228  End Function


229 


230  Function Tan(number As Double) As Double


231  Tan = System.Math.Tan(number)


232  End Function


233 


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


235  Function Rnd() As Double


236  Rnd = RAND_UNIT * rand()


237  End Function


238 


239  Const HIDWORD(qw) = (((qw As QWord) >> 32) And &HFFFFFFFF) As DWord


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


241 


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


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


244 


245  '


246  ' 文字列関数


247  '


248 


249  Function Asc(buf As *StrChar) As StrChar


250  Asc = buf[0]


251  End Function


252 


253  Function Chr$(code As StrChar) As String


254  Chr$ = New String(code, 1)


255  End Function


256 


257  #ifndef __STRING_IS_NOT_UNICODE


258  Function AscW(s As String) As UCSCHAR


259  If s.Length = 0 Then


260  AscW = 0


261  Else


262  If _System_IsSurrogatePair(s[0], s[1]) Then


263  AscW = ((s[0] And &h3FF) As DWord << 10) Or (s[1] And &h3FF)


264  Else


265  AscW = s[0]


266  End If


267  End If


268  End Function


269 


270  Function ChrW(c As UCSCHAR) As String


271  If c <= &hFFFF Then


272  Return New String(c As StrChar, 1)


273  ElseIf c < &h10FFFF Then


274  Dim t[1] = [&hD800 Or (c >> 10), &hDC00 Or (c And &h3FF)] As StrChar


275  Return New String(t, 2)


276  Else


277  'ArgumentOutOfRangeException


278  End If


279  End Function


280  #endif


281 


282  Function Date$() As String


283  Dim date = System.DateTime.Now


284  Dim buf = New System.Text.StringBuilder(10)


285 


286  'year


287  buf.Append(date.Year)


288 


289  'month


290  If date.Month < 10 Then


291  buf.Append("/0")


292  Else


293  buf.Append("/")


294  End If


295  buf.Append(date.Month)


296 


297  'day


298  If date.Day < 10 Then


299  buf.Append("/0")


300  Else


301  buf.Append("/")


302  End If


303  buf.Append(date.Day)


304 


305  Date$ = buf.ToString


306  End Function


307 


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


309 


310  Function _System_Hex(x As DWord, zeroSuppress As Boolean) As String


311  Dim s[7] As StrChar


312  Dim i As Long


313  For i = 0 To ELM(Len (s) \ SizeOf (StrChar))


314  s[i] = _System_HexadecimalTable[x >> 28] As StrChar


315  x <<= 4


316  Next


317  If zeroSuppress Then


318  Dim i As Long


319  For i = 0 To 6


320  If s[i] <> &h30 Then 'Asc("0")


321  Exit For


322  End If


323  Next


324  Return New String(VarPtr(s[i]) As *StrChar, Len (s) \ SizeOf (StrChar)  i)


325  Else


326  Return New String(s As *StrChar, Len (s) \ SizeOf (StrChar))


327  End If


328  End Function


329 


330  Function Hex$(x As DWord) As String


331  Hex$ = _System_Hex(x, True)


332  End Function


333 


334  Function Hex$(x As QWord) As String


335  If HIDWORD(x) = 0 Then


336  Hex$ = _System_Hex(LODWORD(x), True)


337  Else


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


339  End If


340  End Function


341 


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


343  Dim i As Long, i2 As Long, i3 As Long


344 


345  Dim len1 = buf1.Length


346  Dim len2 = buf2.Length


347 


348  If len2=0 Then


349  InStr=StartPos


350  Exit Function


351  End If


352 


353  StartPos


354  If StartPos<0 Then


355  'error


356  InStr=0


357  Exit Function


358  End If


359 


360  i=StartPos:InStr=0


361  While i<=len1len2


362  i2=i:i3=0


363  Do


364  If i3=len2 Then


365  InStr=i+1


366  Exit Do


367  End If


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


369 


370  i2++


371  i3++


372  Loop


373  If InStr Then Exit While


374  i++


375  Wend


376  End Function


377 


378  Function Left$(s As String, length As Long) As String


379  Left$ = s.Substring(0, System.Math.Min(s.Length, length))


380  End Function


381 


382  Function Mid$(s As String, startPos As Long) As String


383  startPos


384  Mid$ = s.Substring(startPos)


385  End Function


386 


387  Function Mid$(s As String, startPos As Long, readLength = 0 As Long) As String


388  startPos


389  Dim length = s.Length


390  Mid$ = s.Substring(System.Math.Min(startPos, length), System.Math.Min(readLength, length  startPos))


391  End Function


392 


393  Const _System_MaxFigure_Oct_QW = 22 As DWord 'QWORD_MAX = &o1,777,777,777,777,777,777,777


394  Function Oct$(n As QWord) As String


395  Dim s[ELM(_System_MaxFigure_Oct_QW)] As StrChar


396  Dim i = ELM(_System_MaxFigure_Oct_QW) As Long


397  Do


398  s[i] = ((n And &o7) + &h30) As StrChar '&h30 = Asc("0")


399  n >>= 3


400  If n = 0 Then


401  Return New String(s + i, _System_MaxFigure_Oct_QW  i)


402  End If


403  i


404  Loop


405  End Function


406 


407  Const _System_MaxFigure_Oct_DW = 11 As DWord 'DWORD_MAX = &o37,777,777,777


408  Function Oct$(n As DWord) As String


409  Dim s[ELM(_System_MaxFigure_Oct_DW)] As StrChar


410  Dim i = ELM(_System_MaxFigure_Oct_DW) As Long


411  Do


412  s[i] = ((n And &o7) + &h30) As StrChar '&h30 = Asc("0")


413  n >>= 3


414  If n = 0 Then


415  Return New String(s + i, _System_MaxFigure_Oct_DW  i)


416  End If


417  i


418  Loop


419  End Function


420 


421  Function Right$(s As String, length As Long) As String


422  Right$ = s.Substring(System.Math.Max(0, s.Length  length), s.Length)


423  End Function


424 


425  Function Space$(length As Long) As String


426  Return New String(&h20 As StrChar, length)


427  End Function


428 


429  Dim _System_ecvt_buffer[16] As StrChar


430  Sub _ecvt_support(count As Long)


431  Dim i As Long


432  If _System_ecvt_buffer[count]=9 Then


433  _System_ecvt_buffer[count]=0


434  If count=0 Then


435  For i=16 To 1 Step 1


436  _System_ecvt_buffer[i]=_System_ecvt_buffer[i1]


437  Next


438  _System_ecvt_buffer[0]=1


439  Else


440  _ecvt_support(count1)


441  End If


442  Else


443  _System_ecvt_buffer[count]++


444  End If


445  End Sub


446  Function _ecvt(value As Double, count As Long, ByRef dec As Long, ByRef sign As Long) As *StrChar


447  Dim i As Long, i2 As Long


448 


449  _ecvt=_System_ecvt_buffer


450 


451  '値が0の場合


452  If value = 0 Then


453  ActiveBasic.Strings.ChrFill(_System_ecvt_buffer, count As SIZE_T, &H30 As StrChar)


454  _System_ecvt_buffer[count] = 0


455  dec = 0


456  sign = 0


457  Exit Function


458  End If


459 


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


461  If value < 0 Then


462  sign = 1


463  value = value


464  Else


465  sign = 0


466  End If


467 


468  '正規化


469  dec = 1


470  While value < 0.999999999999999 'value<1


471  value *= 10


472  dec


473  Wend


474  While 9.99999999999999 <= value '10<=value


475  value /= 10


476  dec++


477  Wend


478 


479  For i=0 To count1


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


481 


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


483  Next


484  _System_ecvt_buffer[i] = 0


485 


486  i


487  If value >= 5 Then


488  '切り上げ処理


489  _ecvt_support(i)


490  End If


491 


492  For i=0 To ELM(count)


493  _System_ecvt_buffer[i] += &H30


494  Next


495  _System_ecvt_buffer[i] = 0


496  End Function


497 


498  Function Str$(dbl As Double) As String


499  If ActiveBasic.Math.IsNaN(dbl) Then


500  Return "NaN"


501  ElseIf ActiveBasic.Math.IsInf(dbl) Then


502  If dbl > 0 Then


503  Return "Infinity"


504  Else


505  Return "Infinity"


506  End If


507  End If


508  Dim dec As Long, sign As Long


509  Dim buffer[32] As StrChar, temp As *StrChar


510  Dim i As Long, i2 As Long, i3 As Long


511 


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


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


514 


515  i=0


516 


517  '符号の取り付け


518  If sign Then


519  buffer[i] = Asc("")


520  i++


521  End If


522 


523  If dec>15 Then


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


525  buffer[i] = temp[0]


526  i++


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


528  i++


529  ActiveBasic.Strings.ChrCopy(VarPtr(buffer[i]), VarPtr(temp[1]), 14 As SIZE_T)


530  i += 14


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


532  i++


533  _stprintf(VarPtr(buffer[i]), "+%03d", dec  1) 'ToDo: __STRING_UNICODE_WINDOWS_ANSI状態への対応


534 


535  Return MakeStr(buffer)


536  End If


537 


538  If dec < 3 Then


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


540  buffer[i] = temp[0]


541  i++


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


543  i++


544  ActiveBasic.Strings.ChrCopy(VarPtr(buffer[i]), VarPtr(temp[1]), 14 As SIZE_T)


545  i+=14


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


547  i++


548  _stprintf(VarPtr(buffer[i]), "+%03d", dec  1) 'ToDo: __STRING_UNICODE_WINDOWS_ANSI状態への対応


549 


550  Return MakeStr(buffer)


551  End If


552 


553  '整数部


554  i2=dec


555  i3=0


556  If i2>0 Then


557  While i2>0


558  buffer[i]=temp[i3]


559  i++


560  i3++


561  i2


562  Wend


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


564  i++


565  Else


566  buffer[i]=&H30


567  i++


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


569  i++


570 


571  i2=dec


572  While i2<0


573  buffer[i]=&H30


574  i++


575  i2++


576  Wend


577  End If


578 


579  '小数部


580  While i3<15


581  buffer[i]=temp[i3]


582  i++


583  i3++


584  Wend


585 


586  While buffer[i1]=&H30


587  i


588  Wend


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


590 


591  buffer[i]=0


592  Return MakeStr(buffer)


593  End Function


594 


595  Function Str$(i As Int64) As String


596  If i < 0 Then


597  Return "" & Str$(i As QWord)


598  Else


599  Return Str$(i As QWord)


600  End If


601  End Function


602 


603  Function Str$(x As QWord) As String


604  If x = 0 Then


605  Return "0"


606  End If


607 


608  Dim buf[20] As StrChar


609  'buf[20] = 0


610  Dim i = 19 As Long


611  Do


612  buf[i] = (x Mod 10 + &h30) As StrChar


613  x \= 10


614  If x = 0 Then


615  Exit Do


616  End If


617  i


618  Loop


619  Return New String(VarPtr(buf[i]), 20  i)


620  End Function


621 


622  Function Str$(x As Long) As String


623  #ifdef _WIN64


624  Return Str$(x As Int64)


625  #else


626  If x < 0 Then


627  Return "" & Str$(x As DWord)


628  Else


629  Return Str$(x As DWord)


630  End If


631  #endif


632  End Function


633 


634  Function Str$(x As DWord) As String


635  #ifdef _WIN64


636  Return Str$(x As QWord)


637  #else


638  If x = 0 Then


639  Return "0"


640  End If


641 


642  Dim buf[10] As StrChar


643  buf[10] = 0


644  Dim i = 9 As Long


645  Do


646  buf[i] = (x As Int64 Mod 10 + &h30) As StrChar 'Int64への型変換は#117対策


647  x \= 10


648  If x = 0 Then


649  Return New String(VarPtr(buf[i]), 10  i)


650  End If


651  i


652  Loop


653  #endif


654  End Function


655 


656  Function Str$(x As Word) As String


657  Return Str$(x As ULONG_PTR)


658  End Function


659 


660  Function Str$(x As Integer) As String


661  Return Str$(x As LONG_PTR)


662  End Function


663 


664  Function Str$(x As Byte) As String


665  Return Str$(x As ULONG_PTR)


666  End Function


667 


668  Function Str$(x As SByte) As String


669  Return Str$(x As LONG_PTR)


670  End Function


671 


672  Function Str$(x As Single) As String


673  Return Str$(x As Double)


674  End Function


675 


676  Function Str$(b As Boolean) As String


677  If b Then


678  Return "True"


679  Else


680  Return "False"


681  End If


682  End Function


683 


684  Function String$(n As Long, s As StrChar) As String


685  Return New String(s, n)


686  End Function


687 


688  #ifdef _AB4_COMPATIBILITY_STRING$_


689  Function String$(n As Long, s As String) As String


690  If n < 0 Then


691  'Throw ArgumentOutOfRangeException


692  End If


693 


694  Dim buf = New System.Text.StringBuilder(s.Length * n)


695  Dim i As Long


696  For i = 0 To n


697  buf.Append(s)


698  Next


699  End Function


700  #else


701  Function String$(n As Long, s As String) As String


702  If String.IsNullOrEmpty(s) Then


703  Return New String(0 As StrChar, n)


704  Else


705  Return New String(s[0], n)


706  End If


707  End Function


708  #endif


709 


710  Function Time$() As String


711  Dim time = System.DateTime.Now


712 


713  Dim buf = New System.Text.StringBuilder(8)


714 


715  'hour


716  If time.Hour < 10 Then


717  buf.Append("0")


718  End If


719  buf.Append(time.Hour)


720 


721  'minute


722  If time.Minute < 10 Then


723  buf.Append(":0")


724  Else


725  buf.Append(":")


726  End If


727  buf.Append(time.Minute)


728 


729  'second


730  If time.Second < 10 Then


731  buf.Append(":0")


732  Else


733  buf.Append(":")


734  End If


735  buf.Append(time.Second)


736  Time$ = buf.ToString


737  End Function


738 


739  Function Val(buf As *StrChar) As Double


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


741  Dim temporary As String


742  Dim TempPtr As *StrChar


743  Dim dbl As Double


744  Dim i64data As Int64


745 


746  Val=0


747 


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


749  buf = VarPtr(buf[1])


750  Wend


751 


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


753  temporary = New String( buf )


754  temporary = temporary.ToUpper()


755  TempPtr = StrPtr(temporary)


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


757  '8進数


758  i=2


759  While 1


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


761  i3=TempPtr[i]&H30


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


763 


764  TempPtr[i]=i3 As StrChar


765  i++


766  Wend


767  i


768 


769  i64data=1


770  While i>=2


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


772 


773  i64data *= &O10


774  i


775  Wend


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


777  '16進数


778  i=2


779  While 1


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


781  i3=TempPtr[i]&H30


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


783  i3=TempPtr[i]&H41+10


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


785  End If


786 


787  TempPtr[i]=i3 As StrChar


788  i++


789  Wend


790  i


791 


792  i64data=1


793  While i>=2


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


795 


796  i64data *= &H10


797  i


798  Wend


799  End If


800  Else


801  '10進数


802  sscanf(buf,"%lf",VarPtr(Val))


803  End If


804  End Function


805 


806 


807  '


808  ' ファイル関数


809  '


810 


811  Function Eof(FileNum As Long) As Long


812  Dim dwCurrent As DWord, dwEnd As DWord


813 


814  FileNum


815 


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


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


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


819 


820  If dwCurrent>=dwEnd Then


821  Eof=1


822  Else


823  Eof=0


824  End If


825  End Function


826 


827  Function Lof(FileNum As Long) As Long


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


829  End Function


830 


831  Function Loc(FileNum As Long) As Long


832  FileNum


833 


834  Dim NowPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_CURRENT)


835  Dim BeginPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_BEGIN)


836  SetFilePointer(_System_hFile(FileNum), NowPos  BeginPos, 0, FILE_BEGIN)


837 


838  Loc = NowPos  BeginPos


839  End Function


840 


841 


842  '


843  ' メモリ関連の関数


844  '


845 


846  Function malloc(stSize As SIZE_T) As VoidPtr


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


848  End Function


849 


850  Function calloc(stSize As SIZE_T) As VoidPtr


851  Return _System_pGC>__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC or _System_GC_FLAG_INITZERO)


852  End Function


853 


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


855  If lpMem = 0 Then


856  Return malloc(stSize)


857  Else


858  Return _System_pGC>__realloc(lpMem,stSize)


859  End If


860  End Function


861 


862  Sub free(lpMem As VoidPtr)


863  _System_pGC>__free(lpMem)


864  End Sub


865 


866  Function _System_malloc(stSize As SIZE_T) As VoidPtr


867  Return HeapAlloc(_System_hProcessHeap,0,stSize)


868  End Function


869 


870  Function _System_calloc(stSize As SIZE_T) As VoidPtr


871  Return HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,stSize)


872  End Function


873 


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


875  If lpMem = 0 Then


876  Return HeapAlloc(_System_hProcessHeap, 0, stSize)


877  Else


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


879  End If


880  End Function


881 


882  Sub _System_free(lpMem As VoidPtr)


883  HeapFree(_System_hProcessHeap,0,lpMem)


884  End Sub


885 


886 


887  '


888  ' その他


889  '


890 


891  Sub _splitpath(path As PCSTR, drive As PSTR, dir As PSTR, fname As PSTR, ext As PSTR)


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


893  Dim buffer[MAX_PATH] As SByte


894 


895  '":\"をチェック


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


897 


898  'ドライブ名をコピー


899  If drive Then


900  drive[0]=path[0]


901  drive[1]=path[1]


902  drive[2]=0


903  End If


904 


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


906  i=2


907  i2=0


908  Do


909  If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then


910  If dir Then


911  dir[i2]=path[i]


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


913  End If


914 


915  i += 2


916  i2 += 2


917  Continue


918  End If


919 


920  If path[i]=0 Then Exit Do


921 


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


923  i3=i2+1


924  End If


925 


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


927 


928  i++


929  i2++


930  Loop


931  If dir Then dir[i3]=0


932  i3 += ii2


933 


934  'ファイル名をコピー


935  i=i3


936  i2=0


937  i3=1


938  Do


939  '#ifdef UNICODE


940  ' If _System_IsSurrogatePair(path[i], path[i + 1]) Then


941  '#else


942  If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then


943  '#endif


944  If fname Then


945  fname[i2]=path[i]


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


947  End If


948 


949  i += 2


950  i2 += 2


951  Continue


952  End If


953 


954  If path[i]=0 Then Exit Do


955 


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


957  i3=i2


958  End If


959 


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


961 


962  i++


963  i2++


964  Loop


965  If i3=1 Then i3=i2


966  If fname Then fname[i3]=0


967  i3 += ii2


968 


969  '拡張子名をコピー


970  If ext Then


971  If i3 Then


972  lstrcpy(ext,path+i3)


973  End If


974  else ext[0]=0


975  End If


976  End Sub


977 


978  Function GetBasicColor(ColorCode As Long) As Long


979  Select Case ColorCode


980  Case 0


981  GetBasicColor=RGB(0,0,0)


982  Case 1


983  GetBasicColor=RGB(0,0,255)


984  Case 2


985  GetBasicColor=RGB(255,0,0)


986  Case 3


987  GetBasicColor=RGB(255,0,255)


988  Case 4


989  GetBasicColor=RGB(0,255,0)


990  Case 5


991  GetBasicColor=RGB(0,255,255)


992  Case 6


993  GetBasicColor=RGB(255,255,0)


994  Case 7


995  GetBasicColor=RGB(255,255,255)


996  End Select


997  End Function


998 


999  Function _System_BSwap(x As Word) As Word


1000  Dim src = VarPtr(x) As *Byte


1001  Dim dst = VarPtr(_System_BSwap) As *Byte


1002  dst[0] = src[1]


1003  dst[1] = src[0]


1004  End Function


1005 


1006  Function _System_BSwap(x As DWord) As DWord


1007  Dim src = VarPtr(x) As *Byte


1008  Dim dst = VarPtr(_System_BSwap) As *Byte


1009  dst[0] = src[3]


1010  dst[1] = src[2]


1011  dst[2] = src[1]


1012  dst[3] = src[0]


1013  End Function


1014 


1015  Function _System_BSwap(x As QWord) As QWord


1016  Dim src = VarPtr(x) As *Byte


1017  Dim dst = VarPtr(_System_BSwap) As *Byte


1018  dst[0] = src[7]


1019  dst[1] = src[6]


1020  dst[2] = src[5]


1021  dst[3] = src[4]


1022  dst[4] = src[3]


1023  dst[5] = src[2]


1024  dst[6] = src[1]


1025  dst[7] = src[0]


1026  End Function


1027 


1028  Function _System_HashFromPtr(p As VoidPtr) As Long


1029  #ifdef _WIN64


1030  Dim qw = p As QWord


1031  Return (HIDWORD(qw) Xor LODWORD(qw)) As Long


1032  #else


1033  Return p As Long


1034  #endif


1035  End Function


1036 


1037  /*!


1038  @brief ABオブジェクトを指すポインタをObject型へ変換。


1039  @author Egtra


1040  @date 2007/08/24


1041  @param[in] p COMインタフェースを指すポインタ


1042  @return Object参照型


1043  */


1044  Function _System_PtrObj(p As VoidPtr) As Object


1045  SetPointer(VarPtr(_System_PtrObj), p)


1046  End Function


1047 


1048  /*!


1049  @brief IUnknownその他COMインタフェースを指すポインタをIUnknown参照型へ変換。


1050  @author Egtra


1051  @date 2007/09/24


1052  @param[in] p COMインタフェースを指すポインタ


1053  @return IUnknown参照型


1054  */


1055  Function _System_PtrUnknown(p As VoidPtr) As IUnknown


1056  SetPointer(VarPtr(_System_PtrUnknown), p)


1057  End Function


1058 


1059  '


1060  ' 文字列関数その2


1061  '


1062  Function _System_IsSurrogatePair(wcHigh As WCHAR, wcLow As WCHAR) As Boolean


1063  If &hD800 <= wcHigh And wcHigh < &hDC00 Then


1064  If &hDC00 <= wcLow And wcLow < &hE000 Then


1065  Return True


1066  End If


1067  End If


1068  Return False


1069  End Function


1070 


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


1072  Return _System_IsSurrogatePair(lead, trail)


1073  End Function


1074 


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


1076  Return IsDBCSLeadByte(lead) <> FALSE


1077  End Function


1078 


1079  Function _System_ASCII_IsUpper(c As WCHAR) As Boolean


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


1081  End Function


1082 


1083  Function _System_ASCII_IsUpper(c As SByte) As Boolean


1084  Return _System_ASCII_IsUpper(c As Byte As WCHAR)


1085  End Function


1086 


1087  Function _System_ASCII_IsLower(c As WCHAR) As Boolean


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


1089  End Function


1090 


1091  Function _System_ASCII_IsLower(c As SByte) As Boolean


1092  Return _System_ASCII_IsLower(c As Byte As WCHAR)


1093  End Function


1094 


1095  Function _System_ASCII_ToLower(c As WCHAR) As WCHAR


1096  If _System_ASCII_IsUpper(c) Then


1097  Return c Or &h20


1098  Else


1099  Return c


1100  End If


1101  End Function


1102 


1103  Function _System_ASCII_ToLower(c As SByte) As SByte


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


1105  End Function


1106 


1107  Function _System_ASCII_ToUpper(c As WCHAR) As WCHAR


1108  If _System_ASCII_IsLower(c) Then


1109  Return c And (Not &h20)


1110  Else


1111  Return c


1112  End If


1113  End Function


1114 


1115  Function _System_ASCII_ToUpper(c As SByte) As SByte


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


1117  End Function


1118 


1119  Function _System_GetHashFromWordArray(p As *Word, n As SIZE_T) As Long


1120  Dim hash = 0 As DWord


1121  Dim i As Long


1122  For i = 0 To ELM(n)


1123  hash = ((hash << 16) + p[i]) Mod &h7fffffff


1124  Next


1125  _System_GetHashFromWordArray = hash As Long


1126  End Function


1127 


1128  #endif '_INC_FUNCTION

