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  return number


177  Else


178  return number


179  End If


180  End Function


181 


182  Function Exp(x As Double) As Double


183  Exp = System.Math.Exp(x)


184  End Function


185 


186  Function Log(x As Double) As Double


187  Log = System.Math.Log(x)


188  End Function


189 


190  Function Sgn(number As Double) As Long


191  Sgn = System.Math.Sign(number)


192  End Function


193 


194  Function Sqr(number As Double) As Double


195  Sqr = System.Math.Sqrt(number)


196  End Function


197 


198  Function Atn(number As Double) As Double


199  Atn = System.Math.Atan(number)


200  End Function


201 


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


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


204  End Function


205 


206  Function Sin(number As Double) As Double


207  Sin = System.Math.Sin(number)


208  End Function


209 


210  Function Cos(number As Double) As Double


211  Cos = System.Math.Cos(number)


212  End Function


213 


214  Function Tan(number As Double) As Double


215  Tan = System.Math.Tan(number)


216  End Function


217 


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


219  Function Rnd() As Double


220  Rnd = RAND_UNIT * rand()


221  End Function


222 


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


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


225 


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


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


228 


229  '


230  ' 文字列関数


231  '


232 


233  Function Asc(buf As *StrChar) As StrChar


234  Asc = buf[0]


235  End Function


236 


237  Function Chr$(code As StrChar) As String


238  Chr$ = New String(code, 1)


239  End Function


240 


241  #ifndef __STRING_IS_NOT_UNICODE


242  Function AscW(s As *WCHAR) As UCSCHAR


243  If s.Length = 0 Then


244  AscW = 0


245  Else


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


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


248  Else


249  AscW = s[0]


250  End If


251  End If


252  End Function


253 


254  Function ChrW(c As UCSCHAR) As String


255  If c <= &hFFFF Then


256  Return New String(c As StrChar, 1)


257  ElseIf c < &h10FFFF Then


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


259  Return New String(t, 2)


260  Else


261  'ArgumentOutOfRangeException


262  End If


263  End Function


264  #endif


265 


266  Function Date$() As String


267  Dim date = DateTime.Now


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


269 


270  'year


271  buf.Append(date.Year)


272 


273  'month


274  If date.Month < 10 Then


275  buf.Append("/0")


276  Else


277  buf.Append("/")


278  End If


279  buf.Append(date.Month)


280 


281  'day


282  If date.Day < 10 Then


283  buf.Append("/0")


284  Else


285  buf.Append("/")


286  End If


287  buf.Append(date.Day)


288 


289  Date$ = buf.ToString


290  End Function


291 


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


293 


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


295  Dim s[7] As StrChar


296  Dim i As Long


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


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


299  x <<= 4


300  Next


301  If zeroSuppress Then


302  Dim i As Long


303  For i = 0 To 6


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


305  Exit For


306  End If


307  Next


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


309  Else


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


311  End If


312  End Function


313 


314  Function Hex$(x As DWord) As String


315  Hex$ = _System_Hex(x, True)


316  End Function


317 


318  Function Hex$(x As QWord) As String


319  If HIDWORD(x) = 0 Then


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


321  Else


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


323  End If


324  End Function


325 


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


327  Dim i As Long, i2 As Long, i3 As Long


328 


329  Dim len1 = buf1.Length


330  Dim len2 = buf2.Length


331 


332  If len2=0 Then


333  InStr=StartPos


334  Exit Function


335  End If


336 


337  StartPos


338  If StartPos<0 Then


339  'error


340  InStr=0


341  Exit Function


342  End If


343 


344  i=StartPos:InStr=0


345  While i<=len1len2


346  i2=i:i3=0


347  Do


348  If i3=len2 Then


349  InStr=i+1


350  Exit Do


351  End If


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


353 


354  i2++


355  i3++


356  Loop


357  If InStr Then Exit While


358  i++


359  Wend


360  End Function


361 


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


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


364  End Function


365 


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


367  startPos


368  Mid$ = s.Substring(startPos)


369  End Function


370 


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


372  startPos


373  Dim length = s.Length


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


375  End Function


376 


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


378  Function Oct$(n As QWord) As String


379  Dim s[ELM(_System_MaxFigure_Oct_QW)] As StrChar


380  Dim i = ELM(_System_MaxFigure_Oct_QW) As Long


381  Do


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


383  n >>= 3


384  If n = 0 Then


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


386  End If


387  i


388  Loop


389  End Function


390 


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


392  Function Oct$(n As DWord) As String


393  Dim s[ELM(_System_MaxFigure_Oct_DW)] As StrChar


394  Dim i = ELM(_System_MaxFigure_Oct_DW) As Long


395  Do


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


397  n >>= 3


398  If n = 0 Then


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


400  End If


401  i


402  Loop


403  End Function


404 


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


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


407  End Function


408 


409  Function Space$(length As Long) As String


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


411  End Function


412 


413  Dim _System_ecvt_buffer[16] As StrChar


414  Sub _ecvt_support(count As Long)


415  Dim i As Long


416  If _System_ecvt_buffer[count]=9 Then


417  _System_ecvt_buffer[count]=0


418  If count=0 Then


419  For i=16 To 1 Step 1


420  _System_ecvt_buffer[i]=_System_ecvt_buffer[i1]


421  Next


422  _System_ecvt_buffer[0]=1


423  Else


424  _ecvt_support(count1)


425  End If


426  Else


427  _System_ecvt_buffer[count]++


428  End If


429  End Sub


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


431  Dim i As Long, i2 As Long


432 


433  _ecvt=_System_ecvt_buffer


434 


435  '値が0の場合


436  If value = 0 Then


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


438  _System_ecvt_buffer[count] = 0


439  dec = 0


440  sign = 0


441  Exit Function


442  End If


443 


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


445  If value < 0 Then


446  sign = 1


447  value = value


448  Else


449  sign = 0


450  End If


451 


452  '正規化


453  dec = 1


454  While value < 0.999999999999999 'value<1


455  value *= 10


456  dec


457  Wend


458  While 9.99999999999999 <= value '10<=value


459  value /= 10


460  dec++


461  Wend


462 


463  For i=0 To count1


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


465 


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


467  Next


468  _System_ecvt_buffer[i] = 0


469 


470  i


471  If value >= 5 Then


472  '切り上げ処理


473  _ecvt_support(i)


474  End If


475 


476  For i=0 To ELM(count)


477  _System_ecvt_buffer[i] += &H30


478  Next


479  _System_ecvt_buffer[i] = 0


480  End Function


481 


482  Function Str$(dbl As Double) As String


483  If ActiveBasic.Math.IsNaN(dbl) Then


484  Return "NaN"


485  ElseIf ActiveBasic.Math.IsInf(dbl) Then


486  If dbl > 0 Then


487  Return "Infinity"


488  Else


489  Return "Infinity"


490  End If


491  End If


492  Dim dec As Long, sign As Long


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


494  Dim i As Long, i2 As Long, i3 As Long


495 


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


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


498 


499  i=0


500 


501  '符号の取り付け


502  If sign Then


503  buffer[i] = Asc("")


504  i++


505  End If


506 


507  If dec>15 Then


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


509  buffer[i] = temp[0]


510  i++


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


512  i++


513  ActiveBasic.Strings.ChrCopy(VarPtr(buffer[i]), VarPtr(temp[1]), 14)


514  i += 14


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


516  i++


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


518 


519  Return MakeStr(buffer)


520  End If


521 


522  If dec < 3 Then


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


524  buffer[i] = temp[0]


525  i++


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


527  i++


528  ActiveBasic.Strings.ChrCopy(VarPtr(buffer[i]), VarPtr(temp[1]), 14)


529  i+=14


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


531  i++


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


533 


534  Return MakeStr(buffer)


535  End If


536 


537  '整数部


538  i2=dec


539  i3=0


540  If i2>0 Then


541  While i2>0


542  buffer[i]=temp[i3]


543  i++


544  i3++


545  i2


546  Wend


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


548  i++


549  Else


550  buffer[i]=&H30


551  i++


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


553  i++


554 


555  i2=dec


556  While i2<0


557  buffer[i]=&H30


558  i++


559  i2++


560  Wend


561  End If


562 


563  '小数部


564  While i3<15


565  buffer[i]=temp[i3]


566  i++


567  i3++


568  Wend


569 


570  While buffer[i1]=&H30


571  i


572  Wend


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


574 


575  buffer[i]=0


576  Return MakeStr(buffer)


577  End Function


578 


579  Function Str$(i As Int64) As String


580  If i < 0 Then


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


582  Else


583  Return Str$(i As QWord)


584  End If


585  End Function


586 


587  Function Str$(x As QWord) As String


588  If x = 0 Then


589  Return "0"


590  End If


591 


592  Dim buf[20] As StrChar


593  'buf[20] = 0


594  Dim i = 19 As Long


595  Do


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


597  x \= 10


598  If x = 0 Then


599  Exit Do


600  End If


601  i


602  Loop


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


604  End Function


605 


606  Function Str$(x As Long) As String


607  #ifdef _WIN64


608  Return Str$(x As Int64)


609  #else


610  If x < 0 Then


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


612  Else


613  Return Str$(x As DWord)


614  End If


615  #endif


616  End Function


617 


618  Function Str$(x As DWord) As String


619  #ifdef _WIN64


620  Return Str$(x As QWord)


621  #else


622  If x = 0 Then


623  Return "0"


624  End If


625 


626  Dim buf[10] As StrChar


627  buf[10] = 0


628  Dim i = 9 As Long


629  Do


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


631  x \= 10


632  If x = 0 Then


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


634  End If


635  i


636  Loop


637  #endif


638  End Function


639 


640  Function Str$(x As Word) As String


641  Return Str$(x As ULONG_PTR)


642  End Function


643 


644  Function Str$(x As Integer) As String


645  Return Str$(x As LONG_PTR)


646  End Function


647 


648  Function Str$(x As Byte) As String


649  Return Str$(x As ULONG_PTR)


650  End Function


651 


652  Function Str$(x As SByte) As String


653  Return Str$(x As LONG_PTR)


654  End Function


655 


656  Function Str$(x As Single) As String


657  Return Str$(x As Double)


658  End Function


659 


660  Function Str$(b As Boolean) As String


661  If b Then


662  Return "True"


663  Else


664  Return "False"


665  End If


666  End Function


667 


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


669  Return New String(s, n)


670  End Function


671 


672  #ifdef _AB4_COMPATIBILITY_STRING$_


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


674  If n < 0 Then


675  'Throw ArgumentOutOfRangeException


676  End If


677 


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


679  Dim i As Long


680  For i = 0 To n


681  buf.Append(s)


682  Next


683  End Function


684  #else


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


686  If String.IsNullOrEmpty(s) Then


687  Return New String(0 As StrChar, n)


688  Else


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


690  End If


691  End Function


692  #endif


693 


694  Function Time$() As String


695  Dim time = DateTime.Now


696 


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


698 


699  'hour


700  If time.Hour < 10 Then


701  buf.Append("0")


702  End If


703  buf.Append(time.Hour)


704 


705  'minute


706  If time.Minute < 10 Then


707  buf.Append(":0")


708  Else


709  buf.Append(":")


710  End If


711  buf.Append(time.Minute)


712 


713  'second


714  If time.Second < 10 Then


715  buf.Append(":0")


716  Else


717  buf.Append(":")


718  End If


719  buf.Append(time.Second)


720  Time$ = buf.ToString


721  End Function


722 


723  Function Val(buf As *StrChar) As Double


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


725  Dim temporary As String


726  Dim TempPtr As *StrChar


727  Dim dbl As Double


728  Dim i64data As Int64


729 


730  Val=0


731 


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


733  buf = VarPtr(buf[1])


734  Wend


735 


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


737  temporary = New String( buf )


738  temporary = temporary.ToUpper()


739  TempPtr = StrPtr(temporary)


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 StrChar


749  i++


750  Wend


751  i


752 


753  i64data=1


754  While i>=2


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


756 


757  i64data *= &O10


758  i


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 StrChar


772  i++


773  Wend


774  i


775 


776  i64data=1


777  While i>=2


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


779 


780  i64data *= &H10


781  i


782  Wend


783  End If


784  Else


785  '10進数


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


787  End If


788  End Function


789 


790 


791  '


792  ' ファイル関数


793  '


794 


795  Function Eof(FileNum As Long) As Long


796  Dim dwCurrent As DWord, dwEnd As DWord


797 


798  FileNum


799 


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


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


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


803 


804  If dwCurrent>=dwEnd Then


805  Eof=1


806  Else


807  Eof=0


808  End If


809  End Function


810 


811  Function Lof(FileNum As Long) As Long


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


813  End Function


814 


815  Function Loc(FileNum As Long) As Long


816  FileNum


817 


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


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


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


821 


822  Loc = NowPos  BeginPos


823  End Function


824 


825 


826  '


827  ' メモリ関連の関数


828  '


829 


830  Function malloc(stSize As SIZE_T) As VoidPtr


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


832  End Function


833 


834  Function calloc(stSize As SIZE_T) As VoidPtr


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


836  End Function


837 


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


839  If lpMem = 0 Then


840  Return malloc(stSize)


841  Else


842  Return _System_pGC>__realloc(lpMem,stSize)


843  End If


844  End Function


845 


846  Sub free(lpMem As VoidPtr)


847  _System_pGC>__free(lpMem)


848  End Sub


849 


850  Function _System_malloc(stSize As SIZE_T) As VoidPtr


851  Return HeapAlloc(_System_hProcessHeap,0,stSize)


852  End Function


853 


854  Function _System_calloc(stSize As SIZE_T) As VoidPtr


855  Return HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,stSize)


856  End Function


857 


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


859  If lpMem = 0 Then


860  Return HeapAlloc(_System_hProcessHeap, 0, stSize)


861  Else


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


863  End If


864  End Function


865 


866  Sub _System_free(lpMem As VoidPtr)


867  HeapFree(_System_hProcessHeap,0,lpMem)


868  End Sub


869 


870 


871  '


872  ' その他


873  '


874 


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


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


877  Dim buffer[MAX_PATH] As SByte


878 


879  '":\"をチェック


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


881 


882  'ドライブ名をコピー


883  If drive Then


884  drive[0]=path[0]


885  drive[1]=path[1]


886  drive[2]=0


887  End If


888 


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


890  i=2


891  i2=0


892  Do


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


894  If dir Then


895  dir[i2]=path[i]


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


897  End If


898 


899  i += 2


900  i2 += 2


901  Continue


902  End If


903 


904  If path[i]=0 Then Exit Do


905 


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


907  i3=i2+1


908  End If


909 


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


911 


912  i++


913  i2++


914  Loop


915  If dir Then dir[i3]=0


916  i3 += ii2


917 


918  'ファイル名をコピー


919  i=i3


920  i2=0


921  i3=1


922  Do


923  '#ifdef UNICODE


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


925  '#else


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


927  '#endif


928  If fname Then


929  fname[i2]=path[i]


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


931  End If


932 


933  i += 2


934  i2 += 2


935  Continue


936  End If


937 


938  If path[i]=0 Then Exit Do


939 


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


941  i3=i2


942  End If


943 


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


945 


946  i++


947  i2++


948  Loop


949  If i3=1 Then i3=i2


950  If fname Then fname[i3]=0


951  i3 += ii2


952 


953  '拡張子名をコピー


954  If ext Then


955  If i3 Then


956  lstrcpy(ext,path+i3)


957  End If


958  else ext[0]=0


959  End If


960  End Sub


961 


962  Function GetBasicColor(ColorCode As Long) As Long


963  Select Case ColorCode


964  Case 0


965  GetBasicColor=RGB(0,0,0)


966  Case 1


967  GetBasicColor=RGB(0,0,255)


968  Case 2


969  GetBasicColor=RGB(255,0,0)


970  Case 3


971  GetBasicColor=RGB(255,0,255)


972  Case 4


973  GetBasicColor=RGB(0,255,0)


974  Case 5


975  GetBasicColor=RGB(0,255,255)


976  Case 6


977  GetBasicColor=RGB(255,255,0)


978  Case 7


979  GetBasicColor=RGB(255,255,255)


980  End Select


981  End Function


982 


983  Function _System_BSwap(x As Word) As Word


984  Dim src = VarPtr(x) As *Byte


985  Dim dst = VarPtr(_System_BSwap) As *Byte


986  dst[0] = src[1]


987  dst[1] = src[0]


988  End Function


989 


990  Function _System_BSwap(x As DWord) As DWord


991  Dim src = VarPtr(x) As *Byte


992  Dim dst = VarPtr(_System_BSwap) As *Byte


993  dst[0] = src[3]


994  dst[1] = src[2]


995  dst[2] = src[1]


996  dst[3] = src[0]


997  End Function


998 


999  Function _System_BSwap(x As QWord) As QWord


1000  Dim src = VarPtr(x) As *Byte


1001  Dim dst = VarPtr(_System_BSwap) As *Byte


1002  dst[0] = src[7]


1003  dst[1] = src[6]


1004  dst[2] = src[5]


1005  dst[3] = src[4]


1006  dst[4] = src[3]


1007  dst[5] = src[2]


1008  dst[6] = src[1]


1009  dst[7] = src[0]


1010  End Function


1011 


1012  Function _System_HashFromPtr(p As VoidPtr) As Long


1013  #ifdef _WIN64


1014  Dim qw = p As QWord


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


1016  #else


1017  Return p As Long


1018  #endif


1019  End Function


1020 


1021  '


1022  ' 文字列関数その2


1023  '


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


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


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


1027  Return True


1028  End If


1029  End If


1030  Return False


1031  End Function


1032 


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


1034  Return _System_IsSurrogatePair(lead, trail)


1035  End Function


1036 


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


1038  Return IsDBCSLeadByte(lead) <> FALSE


1039  End Function


1040 


1041  Function _System_ASCII_IsUpper(c As WCHAR) As Boolean


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


1043  End Function


1044 


1045  Function _System_ASCII_IsUpper(c As SByte) As Boolean


1046  Return _System_ASCII_IsUpper(c As Byte As WCHAR)


1047  End Function


1048 


1049  Function _System_ASCII_IsLower(c As WCHAR) As Boolean


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


1051  End Function


1052 


1053  Function _System_ASCII_IsLower(c As SByte) As Boolean


1054  Return _System_ASCII_IsLower(c As Byte As WCHAR)


1055  End Function


1056 


1057  Function _System_ASCII_ToLower(c As WCHAR) As WCHAR


1058  If _System_ASCII_IsUpper(c) Then


1059  Return c Or &h20


1060  Else


1061  Return c


1062  End If


1063  End Function


1064 


1065  Function _System_ASCII_ToLower(c As SByte) As SByte


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


1067  End Function


1068 


1069  Function _System_ASCII_ToUpper(c As WCHAR) As WCHAR


1070  If _System_ASCII_IsLower(c) Then


1071  Return c And (Not &h20)


1072  Else


1073  Return c


1074  End If


1075  End Function


1076 


1077  Function _System_ASCII_ToUpper(c As SByte) As SByte


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


1079  End Function


1080 


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


1082  Dim hash = 0 As DWord


1083  Dim i As Long


1084  For i = 0 To ELM(n)


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


1086  Next


1087  _System_GetHashFromWordArray = hash As Long


1088  End Function


1089 


1090  #endif '_INC_FUNCTION

