1  'function.sbp


2 


3  Const _System_PI = 3.14159265358979323846264


4  Const _System_SQRT2 = 1.41421356237309504880168872421


5 


6  ' サポート関数の定義 


7 


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


9  ipow = ActiveBasic.Math.pow(x, n)


10  End Function


11 


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


13  pow = ActiveBasic.Math.pow(x, y)


14  End Function


15 


16  Const RAND_MAX = &H7FFFFFFF


17  Dim _System_RndNext = 1 As DWord


18 


19  Function rand() As Long


20  _System_RndNext = _System_RndNext * 1103515245 + 12345


21  rand = (_System_RndNext >> 1) As Long


22  End Function


23 


24  Sub srand(dwSeek As DWord)


25  _System_RndNext = dwSeek


26  End Sub


27 


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


29 


30  '


31  ' データ型変換関数


32  '


33 


34  Function CDbl(number As Double) As Double


35  CDbl=number


36  End Function


37 


38  Function _CUDbl(number As QWord) As Double


39  _CUDbl=number As Double


40  End Function


41 


42  Function CDWord(num As Double) As DWord


43  CDWord=num As DWord


44  End Function


45 


46  Function CInt(number As Double) As Long


47  CInt=number As Long


48  End Function


49 


50  Function CSng(number As Double) As Single


51  CSng=number As Single


52  End Function


53 


54  #ifdef _WIN64


55  Function Fix(number As Double) As Long


56  Fix=number As Long


57  End Function


58  #else


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


60  'Function Fix(number As Double) As Long


61  #endif


62 


63  Function Int(number As Double) As Long


64  Int = Fix(number)


65  If number < 0 Then


66  If number < Fix(number) Then Int


67  End If


68  End Function


69 


70 


71  '


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


73  '


74 


75  'Function GetDouble(p As DWord) As Double


76  'Function GetSingle(p As DWord) As Single


77  'Function GetDWord(p As DWord) As DWord


78  'Function GetWord(p As DWord) As Word


79  'Function GetByte(p As DWord) As Byte


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


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


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


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


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


85 


86 


87  '


88  ' 算術関数


89  '


90 


91  /*


92  Function Abs(n As Double) As Double


93  Abs = ActiveBasic.Math.Abs(n)


94  End Function


95 


96  Function Abs(n As Single) As Single


97  Abs = ActiveBasic.Math.Abs(n)


98  End Function


99 


100  Function Abs(n As Int64) As Int64


101  Abs = ActiveBasic.Math.Abs(n)


102  End Function


103 


104  Function Abs(n As Long) As Long


105  Abs = ActiveBasic.Math.Abs(n)


106  End Function


107 


108  Function Abs(n As Integer) As Integer


109  Abs = ActiveBasic.Math.Abs(n)


110  End Function


111 


112  Function Abs(n As SByte) As SByte


113  Abs = ActiveBasic.Math.Abs(n)


114  End Function


115 


116  Function Exp(x As Double) As Double


117  Exp = ActiveBasic.Math.Exp(x)


118  End Function


119 


120  Function Log(x As Double) As Double


121  Log = ActiveBasic.Math.Log(x)


122  End Function


123  */


124  Function Sgn(n As Double) As Long


125  ' Sgn = ActiveBasic.Math.Sign(n)


126  End Function


127 


128  Function Sqr(x As Double) As Double


129  Sqr = ActiveBasic.Math.Sqrt(x)


130  End Function


131 


132  Function Atn(x As Double) As Double


133  Atn = ActiveBasic.Math.Atan(x)


134  End Function


135 


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


137  Atn2 = ActiveBasic.Math.Atan2(y, x)


138  End Function


139  /*


140  Function Sin(x As Double) As Double


141  Sin = ActiveBasic.Math.Sin(x)


142  End Function


143 


144  Function Cos(x As Double) As Double


145  Cos = ActiveBasic.Math.Cos(x)


146  End Function


147 


148  Function Tan(x As Double) As Double


149  Tan = ActiveBasic.Math.Tan(x)


150  End Function


151  */


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


153  Function Rnd() As Double


154  Rnd = RAND_UNIT * rand()


155  End Function


156 


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


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


159 


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


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


162 


163  '


164  ' 文字列関数


165  '


166 


167  Function Asc(buf As String) As Char


168  Asc = buf[0]


169  End Function


170 


171  Function Chr$(code As Char) As String


172  Chr$ = New String(code, 1)


173  End Function


174 


175  #ifdef UNICODE


176  Function AscW(s As String) As UCSCHAR


177  If String.IsNullOrEmpty(s) Then


178  AscW = 0


179  'ArgumentNullExceptionに変えるかも


180  Else


181  If _System_IsHighSurrogate(s[0]) Then


182  '有効なサロゲートペアになっていない場合には、


183  '例外を投げるようにしたほうがよいかもしれない。


184  If s.Length > 1 Then


185  If _System_IsLowSurrogate(s[0]) Then


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


187  AscW += &h10000


188  Exit Function


189  End If


190  End If


191  Else


192  AscW = s[0]


193  End If


194  End If


195  End Function


196 


197  Function ChrW(c As UCSCHAR) As String


198  If c <= &hFFFF Then


199  Return New String(c As Char, 1)


200  ElseIf c <= &h10FFFF Then


201  c = &h10000


202  Dim t[1] As WCHAR


203  t[0] = (&hD800 Or (c >> 10)) As WCHAR


204  t[1] = (&hDC00 Or (c And &h3FF)) As WCHAR


205  Return New String(t, 2)


206  Else


207  Throw New System.ArgumentOutOfRangeException("ChrW: c is invalid unicode code point.", "c")


208  End If


209  End Function


210  #endif


211 


212  Function Date$() As String


213  Dim date = System.DateTime.Now


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


215 


216  'year


217  buf.Append(date.Year)


218 


219  'month


220  If date.Month < 10 Then


221  buf.Append("/0")


222  Else


223  buf.Append("/")


224  End If


225  buf.Append(date.Month)


226 


227  'day


228  If date.Day < 10 Then


229  buf.Append("/0")


230  Else


231  buf.Append("/")


232  End If


233  buf.Append(date.Day)


234 


235  Date$ = buf.ToString


236  End Function


237 


238  Function Hex$(x As DWord) As String


239  Imports ActiveBasic.Strings.Detail


240  Hex$ = FormatIntegerX(x, 1, 0, None)


241  End Function


242 


243  Function Hex$(x As QWord) As String


244  Imports ActiveBasic.Strings.Detail


245  Hex$ = FormatIntegerLX(x, 1, 0, None)


246  End Function


247 


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


249  Dim i As Long, i2 As Long, i3 As Long


250 


251  Dim len1 = 0 As Long


252  Dim len2 = 0 As Long


253  If Not ActiveBasic.IsNothing(buf1) Then len1 = buf1.Length


254  If Not ActiveBasic.IsNothing(buf2) Then len2 = buf2.Length


255 


256  If len2 = 0 Then


257  InStr = StartPos


258  Exit Function


259  End If


260 


261  StartPos


262  If StartPos < 0 Then


263  'error


264  InStr = 0


265  Exit Function


266  End If


267 


268  i=StartPos:InStr=0


269  While i<=len1len2


270  i2=i:i3=0


271  Do


272  If i3=len2 Then


273  InStr=i+1


274  Exit Do


275  End If


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


277 


278  i2++


279  i3++


280  Loop


281  If InStr Then Exit While


282  i++


283  Wend


284  End Function


285 


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


287  If Not ActiveBasic.IsNothing(s) Then


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


289  Else


290  Left$ = ""


291  End If


292  End Function


293 


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


295  If Not ActiveBasic.IsNothing(s) Then


296  startPos


297  Mid$ = s.Substring(startPos)


298  Else


299  Mid$ = ""


300  End If


301  End Function


302 


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


304  If Not ActiveBasic.IsNothing(s) Then


305  startPos


306  Dim length = s.Length


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


308  Else


309  Mid$ = ""


310  End If


311  End Function


312 


313  Function Oct$(n As QWord) As String


314  Imports ActiveBasic.Strings.Detail


315  Oct$ = FormatIntegerLO(n, 1, 0, None)


316  End Function


317 


318  Function Oct$(n As DWord) As String


319  Imports ActiveBasic.Strings.Detail


320  Oct$ = FormatIntegerO(n, 1, 0, None)


321  End Function


322 


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


324  If Not ActiveBasic.IsNothing(s) Then


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


326  Else


327  Right$ = ""


328  End If


329  End Function


330 


331  Function Space$(length As Long) As String


332  Return New String(&h20 As Char, length)


333  End Function


334 


335  Sub _ecvt_support(buf As *Char, count As Long, size As Long)


336  Dim i As Long


337  If buf[count] = 9 Then


338  buf[count] = 0


339  If count = 0 Then


340  For i = size To 1 Step 1


341  buf[i] = buf[i1]


342  Next


343  buf[0] = 1


344  Else


345  _ecvt_support(buf, count1, size)


346  End If


347  Else


348  buf[count]++


349  End If


350  End Sub


351 


352  Sub _ecvt(buffer As *Char, value As Double, count As Long, ByRef dec As Long, ByRef sign As Boolean)


353  Dim i As Long, i2 As Long


354 


355  '値が0の場合


356  If value = 0 Then


357  ActiveBasic.Strings.ChrFill(buffer, count As SIZE_T, &h30 As Char)


358  buffer[count] = 0


359  dec = 0


360  sign = 0


361  Exit Function


362  End If


363 


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


365  If value < 0 Then


366  sign = True


367  value = value


368  Else


369  sign = False


370  End If


371 


372  '正規化


373  dec = 1


374  While value < 0.999999999999999 'value<1


375  value *= 10


376  dec


377  Wend


378  While 9.99999999999999 <= value '10<=value


379  value /= 10


380  dec++


381  Wend


382 


383  For i = 0 To count  1


384  buffer[i] = Int(value) As Char


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


386  Next


387 


388  i


389  If value >= 5 Then


390  '切り上げ処理


391  _ecvt_support(buffer, i, count)


392  End If


393 


394  For i = 0 To count  1


395  buffer[i] += &H30


396  Next


397  buffer[i] = 0


398  End Sub


399 


400  Function Str$(dbl As Double) As String


401  Imports ActiveBasic.Math


402  Imports ActiveBasic.Strings


403  If IsNaN(dbl) Then


404  Return "NaN"


405  ElseIf IsInf(dbl) Then


406  If dbl > 0 Then


407  Return "Infinity"


408  Else


409  Return "Infinity"


410  End If


411  End If


412  Dim dec As Long, sign As Boolean


413  Dim buffer[32] As Char, temp[15] As Char


414  Dim i = 0 As Long


415 


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


417  _ecvt(temp, dbl, 15, dec, sign)


418 


419  '符号の取り付け


420  If sign Then


421  buffer[i] = Asc("")


422  i++


423  End If


424 


425  If dec > 15 Or dec < 3 Then


426  '指数表示


427  buffer[i] = temp[0]


428  i++


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


430  i++


431  ChrCopy(VarPtr(buffer[i]), VarPtr(temp[1]), 14 As SIZE_T)


432  i += 14


433  buffer[i] = 0


434  Return MakeStr(buffer) + SPrintf("e%+03d", New System.Int32(dec  1))


435  End If


436 


437  '整数部


438  Dim i2 = dec


439  Dim i3 = 0


440  If i2>0 Then


441  While i2>0


442  buffer[i]=temp[i3]


443  i++


444  i3++


445  i2


446  Wend


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


448  i++


449  Else


450  buffer[i]=&H30


451  i++


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


453  i++


454 


455  i2=dec


456  While i2<0


457  buffer[i]=&H30


458  i++


459  i2++


460  Wend


461  End If


462 


463  '小数部


464  While i3<15


465  buffer[i]=temp[i3]


466  i++


467  i3++


468  Wend


469 


470  While buffer[i1]=&H30


471  i


472  Wend


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


474 


475  buffer[i]=0


476  Return MakeStr(buffer)


477  End Function


478 


479  Function Str$(x As Int64) As String


480  Imports ActiveBasic.Strings.Detail


481  Return FormatIntegerEx(TraitsIntegerD[1], x As QWord, 1, 0, None)


482  End Function


483 


484  Function Str$(x As QWord) As String


485  Imports ActiveBasic.Strings.Detail


486  Return FormatIntegerEx(TraitsIntegerU[1], x, 1, 0, None)


487  End Function


488 


489  Function Str$(x As Long) As String


490  Imports ActiveBasic.Strings.Detail


491  Return FormatIntegerEx(TraitsIntegerD[0], x, 1, 0, None)


492  End Function


493 


494  Function Str$(x As DWord) As String


495  Imports ActiveBasic.Strings.Detail


496  Return FormatIntegerEx(TraitsIntegerU[0], x, 1, 0, None)


497  End Function


498 


499  Function Str$(x As Word) As String


500  Return Str$(x As DWord)


501  End Function


502 


503  Function Str$(x As Integer) As String


504  Return Str$(x As Long)


505  End Function


506 


507  Function Str$(x As Byte) As String


508  Return Str$(x As DWord)


509  End Function


510 


511  Function Str$(x As SByte) As String


512  Return Str$(x As Long)


513  End Function


514 


515  Function Str$(x As Single) As String


516  Return Str$(x As Double)


517  End Function


518 


519  Function Str$(b As Boolean) As String


520  If b Then


521  Return "True"


522  Else


523  Return "False"


524  End If


525  End Function


526 


527  Function Str$(s As String) As String


528  Str$ = s


529  End Function


530 


531  Function String$(n As Long, s As Char) As String


532  Return New String(s, n)


533  End Function


534 


535  #ifdef _AB4_COMPATIBILITY_STRING$_


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


537  If n < 0 Then


538  'Throw ArgumentOutOfRangeException


539  End If


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


541  Dim i As Long


542  For i = 1 To n


543  buf.Append(s)


544  Next


545  End Function


546  #else


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


548  Dim c As Char


549  If String.IsNullOrEmpty(s) Then


550  c = 0


551  Else


552  c = s[0]


553  End If


554  String$ = New String(c, n)


555  End Function


556  #endif


557 


558  Function Time$() As String


559  Dim time = System.DateTime.Now


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


561  'hour


562  If time.Hour < 10 Then


563  buf.Append("0")


564  End If


565  buf.Append(time.Hour)


566 


567  'minute


568  If time.Minute < 10 Then


569  buf.Append(":0")


570  Else


571  buf.Append(":")


572  End If


573  buf.Append(time.Minute)


574 


575  'second


576  If time.Second < 10 Then


577  buf.Append(":0")


578  Else


579  buf.Append(":")


580  End If


581  buf.Append(time.Second)


582  Time$ = buf.ToString


583  End Function


584 


585  Function Val(buf As *Char) As Double


586  If buf = 0 Then


587  Exit Function


588  End If


589 


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


591  Dim temporary As String


592  Dim TempPtr As *Char


593  Dim dbl As Double


594  Dim i64data As Int64


595 


596  Val=0


597 


598  While ActiveBasic.CType.IsSpace(buf[0])


599  buf = VarPtr(buf[1])


600  Wend


601 


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


603  temporary = New String( buf )


604  temporary = temporary.ToUpper()


605  TempPtr = StrPtr(temporary)


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


607  '8進数


608  i=2


609  While 1


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


611  i3=TempPtr[i]&H30


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


613 


614  TempPtr[i]=i3 As Char


615  i++


616  Wend


617  i


618 


619  i64data=1


620  While i>=2


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


622 


623  i64data *= &O10


624  i


625  Wend


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


627  '16進数


628  i=2


629  While 1


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


631  i3=TempPtr[i]&H30


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


633  i3=TempPtr[i]&H41+10


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


635  End If


636 


637  TempPtr[i]=i3 As Char


638  i++


639  Wend


640  i


641 


642  i64data=1


643  While i>=2


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


645 


646  i64data *= &H10


647  i


648  Wend


649  End If


650  Else


651  '10進数


652  #ifdef UNICODE


653  swscanf(buf,"%lf",VarPtr(Val))


654  #else


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


656  #endif


657  End If


658  End Function


659 


660 


661  '


662  ' ファイル関数


663  '


664 


665  Function Eof(FileNum As Long) As Long


666  FileNum


667  ActiveBasic.Detail.ThrowIfInvaildFileNum(FileNum)


668  Dim dwCurrent = SetFilePointer(_System_hFile(FileNum), 0,NULL, FILE_CURRENT)


669  Dim dwEnd = SetFilePointer(_System_hFile(FileNum), 0, NULL, FILE_END)


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


671 


672  If dwCurrent>=dwEnd Then


673  Eof=1


674  Else


675  Eof=0


676  End If


677  End Function


678 


679  Function Lof(FileNum As Long) As Long


680  FileNum


681  ActiveBasic.Detail.ThrowIfInvaildFileNum(FileNum)


682  Lof = GetFileSize(_System_hFile(FileNum), 0)


683  End Function


684 


685  Function Loc(FileNum As Long) As Long


686  FileNum


687  ActiveBasic.Detail.ThrowIfInvaildFileNum(FileNum)


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


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


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


691 


692  Loc = NowPos  BeginPos


693  End Function


694 


695  Namespace ActiveBasic


696  Namespace Detail


697 


698  Sub ThrowIfInvaildFileNum(n As Long)


699  If n < 0 Or n > 255 Then


700  Throw New System.ArgumentOutOfRangeException("FileNum", "Invalid file number")


701  ElseIf _System_hFile(n) = 0 Then


702  Throw New System.InvalidOperationException("File number " & Str$(n + 1) & "is not opend.")


703  End If


704  End Sub


705 


706  End Namespace


707  End Namespace


708 


709  '


710  ' メモリ関連の関数


711  '


712 


713  Function malloc(stSize As SIZE_T) As VoidPtr


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


715  End Function


716 


717  Function calloc(stSize As SIZE_T) As VoidPtr


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


719  End Function


720 


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


722  If lpMem = 0 Then


723  Return malloc(stSize)


724  Else


725  Return _System_pGC>__realloc(lpMem,stSize)


726  End If


727  End Function


728 


729  Sub free(lpMem As VoidPtr)


730  _System_pGC>__free(lpMem)


731  End Sub


732 


733  Function _System_malloc(stSize As SIZE_T) As VoidPtr


734  Return HeapAlloc(_System_hProcessHeap, 0, stSize)


735  End Function


736 


737  Function _System_calloc(stSize As SIZE_T) As VoidPtr


738  Return HeapAlloc(_System_hProcessHeap, HEAP_ZERO_MEMORY, stSize)


739  End Function


740 


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


742  If lpMem = 0 Then


743  Return HeapAlloc(_System_hProcessHeap, 0, stSize)


744  Else


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


746  End If


747  End Function


748 


749  Sub _System_free(lpMem As VoidPtr)


750  HeapFree(_System_hProcessHeap, 0, lpMem)


751  End Sub


752 


753 


754  '


755  ' その他


756  '


757 


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


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


760  Dim buffer[MAX_PATH] As SByte


761 


762  '":\"をチェック


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


764 


765  'ドライブ名をコピー


766  If drive Then


767  drive[0]=path[0]


768  drive[1]=path[1]


769  drive[2]=0


770  End If


771 


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


773  i=2


774  i2=0


775  Do


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


777  If dir Then


778  dir[i2]=path[i]


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


780  End If


781 


782  i += 2


783  i2 += 2


784  Continue


785  End If


786 


787  If path[i]=0 Then Exit Do


788 


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


790  i3=i2+1


791  End If


792 


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


794 


795  i++


796  i2++


797  Loop


798  If dir Then dir[i3]=0


799  i3 += ii2


800 


801  'ファイル名をコピー


802  i=i3


803  i2=0


804  i3=1


805  Do


806  '#ifdef UNICODE


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


808  '#else


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


810  '#endif


811  If fname Then


812  fname[i2]=path[i]


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


814  End If


815 


816  i += 2


817  i2 += 2


818  Continue


819  End If


820 


821  If path[i]=0 Then Exit Do


822 


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


824  i3=i2


825  End If


826 


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


828 


829  i++


830  i2++


831  Loop


832  If i3=1 Then i3=i2


833  If fname Then fname[i3]=0


834  i3 += ii2


835 


836  '拡張子名をコピー


837  If ext Then


838  If i3 Then


839  ActiveBasic.Strings.StrCpy(ext,path+i3)


840  End If


841  else ext[0]=0


842  End If


843  End Sub


844 


845  Function GetBasicColor(ColorCode As Long) As Long


846  Select Case ColorCode


847  Case 0


848  GetBasicColor=RGB(0,0,0)


849  Case 1


850  GetBasicColor=RGB(0,0,255)


851  Case 2


852  GetBasicColor=RGB(255,0,0)


853  Case 3


854  GetBasicColor=RGB(255,0,255)


855  Case 4


856  GetBasicColor=RGB(0,255,0)


857  Case 5


858  GetBasicColor=RGB(0,255,255)


859  Case 6


860  GetBasicColor=RGB(255,255,0)


861  Case 7


862  GetBasicColor=RGB(255,255,255)


863  End Select


864  End Function


865 


866  Function _System_BSwap(x As Word) As Word


867  Dim src = VarPtr(x) As *Byte


868  Dim dst = VarPtr(_System_BSwap) As *Byte


869  dst[0] = src[1]


870  dst[1] = src[0]


871  End Function


872 


873  Function _System_BSwap(x As DWord) As DWord


874  Dim src = VarPtr(x) As *Byte


875  Dim dst = VarPtr(_System_BSwap) As *Byte


876  dst[0] = src[3]


877  dst[1] = src[2]


878  dst[2] = src[1]


879  dst[3] = src[0]


880  End Function


881 


882  Function _System_BSwap(x As QWord) As QWord


883  Dim src = VarPtr(x) As *Byte


884  Dim dst = VarPtr(_System_BSwap) As *Byte


885  dst[0] = src[7]


886  dst[1] = src[6]


887  dst[2] = src[5]


888  dst[3] = src[4]


889  dst[4] = src[3]


890  dst[5] = src[2]


891  dst[6] = src[1]


892  dst[7] = src[0]


893  End Function


894 


895  Function _System_HashFromUInt(x As QWord) As Long


896  Return (HIDWORD(x) Xor LODWORD(x)) As Long


897  End Function


898 


899  Function _System_HashFromUInt(x As DWord) As Long


900  Return x As Long


901  End Function


902 


903  Function _System_HashFromPtr(p As VoidPtr) As Long


904  Return _System_HashFromUInt(p As ULONG_PTR)


905  End Function


906 


907  /*!


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


909  @author Egtra


910  @date 2007/08/24


911  @param[in] p オブジェクトを指すポインタ


912  @return Object参照型


913  */


914  Function _System_PtrObj(p As VoidPtr) As Object


915  SetPointer(VarPtr(_System_PtrObj), p)


916  End Function


917 


918  /*!


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


920  @author Egtra


921  @date 2007/09/24


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


923  @return IUnknown参照型


924  */


925  Function _System_PtrUnknown(p As VoidPtr) As IUnknown


926  SetPointer(VarPtr(_System_PtrUnknown), p)


927  End Function


928 


929  '


930  ' 文字列関数その2


931  '


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


933  If _System_IsHighSurrogate(wcHigh) Then


934  If _System_IsLowSurrogate(wcLow) Then


935  Return True


936  End If


937  End If


938  Return False


939  End Function


940 


941  Function _System_IsHighSurrogate(c As WCHAR) As Boolean


942  Return &hD800 <= c And c < &hDC00


943  End Function


944 


945  Function _System_IsLowSurrogate(c As WCHAR) As Boolean


946  Return &hDC00 <= c And c < &hE000


947  End Function


948 


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


950  Return _System_IsSurrogatePair(lead, trail)


951  End Function


952 


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


954  Return IsDBCSLeadByte(lead) <> FALSE


955  End Function


956 


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


958  Dim hash = 0 As DWord


959  Dim i As Long


960  For i = 0 To ELM(n)


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


962  Next


963  _System_GetHashFromWordArray = hash As Long


964  End Function

