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  Dim dwCurrent = SetFilePointer(_System_hFile(FileNum), 0,NULL, FILE_CURRENT)


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


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


670 


671  If dwCurrent>=dwEnd Then


672  Eof=1


673  Else


674  Eof=0


675  End If


676  End Function


677 


678  Function Lof(FileNum As Long) As Long


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


680  End Function


681 


682  Function Loc(FileNum As Long) As Long


683  FileNum


684 


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


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


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


688 


689  Loc = NowPos  BeginPos


690  End Function


691 


692 


693  '


694  ' メモリ関連の関数


695  '


696 


697  Function malloc(stSize As SIZE_T) As VoidPtr


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


699  End Function


700 


701  Function calloc(stSize As SIZE_T) As VoidPtr


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


703  End Function


704 


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


706  If lpMem = 0 Then


707  Return malloc(stSize)


708  Else


709  Return _System_pGC>__realloc(lpMem,stSize)


710  End If


711  End Function


712 


713  Sub free(lpMem As VoidPtr)


714  _System_pGC>__free(lpMem)


715  End Sub


716 


717  Function _System_malloc(stSize As SIZE_T) As VoidPtr


718  Return HeapAlloc(_System_hProcessHeap, 0, stSize)


719  End Function


720 


721  Function _System_calloc(stSize As SIZE_T) As VoidPtr


722  Return HeapAlloc(_System_hProcessHeap, HEAP_ZERO_MEMORY, stSize)


723  End Function


724 


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


726  If lpMem = 0 Then


727  Return HeapAlloc(_System_hProcessHeap, 0, stSize)


728  Else


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


730  End If


731  End Function


732 


733  Sub _System_free(lpMem As VoidPtr)


734  HeapFree(_System_hProcessHeap, 0, lpMem)


735  End Sub


736 


737 


738  '


739  ' その他


740  '


741 


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


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


744  Dim buffer[MAX_PATH] As SByte


745 


746  '":\"をチェック


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


748 


749  'ドライブ名をコピー


750  If drive Then


751  drive[0]=path[0]


752  drive[1]=path[1]


753  drive[2]=0


754  End If


755 


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


757  i=2


758  i2=0


759  Do


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


761  If dir Then


762  dir[i2]=path[i]


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


764  End If


765 


766  i += 2


767  i2 += 2


768  Continue


769  End If


770 


771  If path[i]=0 Then Exit Do


772 


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


774  i3=i2+1


775  End If


776 


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


778 


779  i++


780  i2++


781  Loop


782  If dir Then dir[i3]=0


783  i3 += ii2


784 


785  'ファイル名をコピー


786  i=i3


787  i2=0


788  i3=1


789  Do


790  '#ifdef UNICODE


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


792  '#else


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


794  '#endif


795  If fname Then


796  fname[i2]=path[i]


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


798  End If


799 


800  i += 2


801  i2 += 2


802  Continue


803  End If


804 


805  If path[i]=0 Then Exit Do


806 


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


808  i3=i2


809  End If


810 


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


812 


813  i++


814  i2++


815  Loop


816  If i3=1 Then i3=i2


817  If fname Then fname[i3]=0


818  i3 += ii2


819 


820  '拡張子名をコピー


821  If ext Then


822  If i3 Then


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


824  End If


825  else ext[0]=0


826  End If


827  End Sub


828 


829  Function GetBasicColor(ColorCode As Long) As Long


830  Select Case ColorCode


831  Case 0


832  GetBasicColor=RGB(0,0,0)


833  Case 1


834  GetBasicColor=RGB(0,0,255)


835  Case 2


836  GetBasicColor=RGB(255,0,0)


837  Case 3


838  GetBasicColor=RGB(255,0,255)


839  Case 4


840  GetBasicColor=RGB(0,255,0)


841  Case 5


842  GetBasicColor=RGB(0,255,255)


843  Case 6


844  GetBasicColor=RGB(255,255,0)


845  Case 7


846  GetBasicColor=RGB(255,255,255)


847  End Select


848  End Function


849 


850  Function _System_BSwap(x As Word) As Word


851  Dim src = VarPtr(x) As *Byte


852  Dim dst = VarPtr(_System_BSwap) As *Byte


853  dst[0] = src[1]


854  dst[1] = src[0]


855  End Function


856 


857  Function _System_BSwap(x As DWord) As DWord


858  Dim src = VarPtr(x) As *Byte


859  Dim dst = VarPtr(_System_BSwap) As *Byte


860  dst[0] = src[3]


861  dst[1] = src[2]


862  dst[2] = src[1]


863  dst[3] = src[0]


864  End Function


865 


866  Function _System_BSwap(x As QWord) As QWord


867  Dim src = VarPtr(x) As *Byte


868  Dim dst = VarPtr(_System_BSwap) As *Byte


869  dst[0] = src[7]


870  dst[1] = src[6]


871  dst[2] = src[5]


872  dst[3] = src[4]


873  dst[4] = src[3]


874  dst[5] = src[2]


875  dst[6] = src[1]


876  dst[7] = src[0]


877  End Function


878 


879  Function _System_HashFromUInt(x As QWord) As Long


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


881  End Function


882 


883  Function _System_HashFromUInt(x As DWord) As Long


884  Return x As Long


885  End Function


886 


887  Function _System_HashFromPtr(p As VoidPtr) As Long


888  Return _System_HashFromUInt(p As ULONG_PTR)


889  End Function


890 


891  /*!


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


893  @author Egtra


894  @date 2007/08/24


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


896  @return Object参照型


897  */


898  Function _System_PtrObj(p As VoidPtr) As Object


899  SetPointer(VarPtr(_System_PtrObj), p)


900  End Function


901 


902  /*!


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


904  @author Egtra


905  @date 2007/09/24


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


907  @return IUnknown参照型


908  */


909  Function _System_PtrUnknown(p As VoidPtr) As IUnknown


910  SetPointer(VarPtr(_System_PtrUnknown), p)


911  End Function


912 


913  '


914  ' 文字列関数その2


915  '


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


917  If _System_IsHighSurrogate(wcHigh) Then


918  If _System_IsLowSurrogate(wcLow) Then


919  Return True


920  End If


921  End If


922  Return False


923  End Function


924 


925  Function _System_IsHighSurrogate(c As WCHAR) As Boolean


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


927  End Function


928 


929  Function _System_IsLowSurrogate(c As WCHAR) As Boolean


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


931  End Function


932 


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


934  Return _System_IsSurrogatePair(lead, trail)


935  End Function


936 


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


938  Return IsDBCSLeadByte(lead) <> FALSE


939  End Function


940 


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


942  Dim hash = 0 As DWord


943  Dim i As Long


944  For i = 0 To ELM(n)


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


946  Next


947  _System_GetHashFromWordArray = hash As Long


948  End Function

