source: trunk/Include/basic/function.sbp @ 383

'function.sbp


#ifndef _INC_FUNCTION
#define _INC_FUNCTION


Const _System_PI = 3.14159265358979323846264
Const _System_LOG2 = 0.6931471805599453094172321214581765680755
Const _System_SQRT2 = 1.41421356237309504880168872421
Const _System_Log_N = 7 As Long


#require <Classes/System/Math.ab>
#require <Classes/System/DateTime.ab>
#require <Classes/System/Text/StringBuilder.ab>
#require <Classes/ActiveBasic/Math/Math.ab>
#require <Classes/ActiveBasic/Strings/Strings.ab>


'------------- サポート関数の定義 -------------

Function ldexp(x As Double, n As Long) As Double
    If x = 0 Then
        ldexp = 0
        Exit Function
    End If
    Dim pSrc = VarPtr(x) As *QWord
    Dim pDest = VarPtr(ldexp) As *QWord
    n += (pSrc[0] >> 52) As DWord And &h7FF
    pDest[0] = n << 52 Or (pSrc[0] And &h800FFFFFFFFFFFFF)
End Function

Function frexp(x As Double, ByRef n As Long) As Double
    If x = 0 Then
        n = 0
        frexp = 0
        Exit Function
    End If

    Dim pSrc = VarPtr(x) As *QWord
    Dim pDest = VarPtr(frexp) As *QWord
    n = ((pSrc[0] >> 52) As DWord And &h7FF) - 1022
    pDest[0] = (pSrc[0] And &h800FFFFFFFFFFFFF) Or &h3FE0000000000000
End Function

Function frexp(x As Single, ByRef n As Long) As Single
    If x = 0 Then
        n = 0
        frexp = 0
        Exit Function
    End If

    Dim pSrc As *DWord, pDest As *DWord
    pSrc = VarPtr(x) As *DWord
    pDest = VarPtr(frexp) As *DWord
    n = ((pSrc[0] >> 23) And &hFF) - 126
    pDest[0] = (pSrc[0] And &h807FFFFF) Or &h7E000000
End Function

Function ipow(x As Double, n As Long) As Double
    Dim abs_n As Long
    Dim r = 1 As Double

    abs_n=Abs(n) As Long
    While abs_n<>0
        If abs_n and 1 Then r *= x
        x = x * x
        abs_n >>= 1 ' abs_n \= 2
    Wend

    If n>=0 Then
        ipow=r
    Else
        ipow=1/r
    End If
End Function

Function pow(x As Double, y As Double) As Double
    If -LONG_MAX<=y and y<=LONG_MAX and y=CDbl(Int(y)) Then
        pow=ipow(x,y As Long)
        Exit Function
    End If

    If x>0 Then
        pow=Exp(y*Log(x))
        Exit Function
    End If

    If x<>0 or y<=0 Then
        'error
    End If

    pow=0
End Function

Const RAND_MAX = &H7FFFFFFF
Dim _System_RndNext = 1 As DWord

Function rand() As Long
    _System_RndNext = _System_RndNext * 1103515245 + 12345
    rand = (_System_RndNext >> 1) As Long
End Function

Sub srand(dwSeek As DWord)
    _System_RndNext = dwSeek
End Sub


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

'------------------
' データ型変換関数
'------------------

Function CDbl(number As Double) As Double
    CDbl=number
End Function

Function _CUDbl(number As QWord) As Double
    _CUDbl=number As Double
End Function

Function CDWord(num As Double) As DWord
    CDWord=num As DWord
End Function

Function CInt(number As Double) As Long
    CInt=number As Long
End Function

Function CSng(number As Double) As Single
    CSng=number As Single
End Function

#ifdef _WIN64
Function Fix(number As Double) As Long
    Fix=number As Long
End Function
#else
'Fix関数はコンパイラに組み込まれている
'Function Fix(number As Double) As Long
#endif

Function Int(number As Double) As Long
    Int = Fix(number)
    If number < 0 Then
        If number < Fix(number) Then Int--
    End If
End Function


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

'Function GetDouble(p As DWord) As Double
'Function GetSingle(p As DWord) As Single
'Function GetDWord(p As DWord) As DWord
'Function GetWord(p As DWord) As Word
'Function GetByte(p As DWord) As Byte
'Sub SetDouble(p As DWord, dblData As Double)
'Sub SetSingle(p As DWord, fltData As Single)
'Sub SetDWord(p As DWord, dwData As DWord)
'Sub SetWord(p As DWord, wData As Word)
'Sub SetByte(p As DWord, byteData As Byte)


'----------
' 算術関数
'----------

Function Abs(number As Double) As Double
    'Abs = System.Math.Abs(number)
    If number < 0 then
        Abs = -number
    Else
        Abs = number
    End If
End Function

Function Abs(number As Int64) As Int64
    If number < 0 then
        Abs = -number
    Else
        Abs = number
    End If
End Function

Function Abs(number As Long) As Long
    If number < 0 then
        Abs = -number
    Else
        Abs = number
    End If
End Function

Function Exp(x As Double) As Double
    Exp = System.Math.Exp(x)
End Function

Function Log(x As Double) As Double
    Log = System.Math.Log(x)
End Function

Function Sgn(number As Double) As Long
    Sgn = System.Math.Sign(number)
End Function

Function Sqr(number As Double) As Double
    Sqr = System.Math.Sqrt(number)
End Function

Function Atn(number As Double) As Double
    Atn = System.Math.Atan(number)
End Function

Function Atn2(y As Double, x As Double) As Double
    Atn2 = System.Math.Atan2(y, x)
End Function

Function Sin(number As Double) As Double
    Sin = System.Math.Sin(number)
End Function

Function Cos(number As Double) As Double
    Cos = System.Math.Cos(number)
End Function

Function Tan(number As Double) As Double
    Tan = System.Math.Tan(number)
End Function

Const RAND_UNIT = (1.0 / (LONG_MAX + 1.0))
Function Rnd() As Double
    Rnd = RAND_UNIT * rand()
End Function

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

Const MAKEDWORD(l, h) = (((l As DWord) And &HFFFF) Or (((h As DWord) And &HFFFF) << 16)) As DWord
Const MAKEQWORD(l, h) = (((l As QWord) And &HFFFFFFFF) Or (((h As QWord) And &HFFFFFFFF) << 32)) As QWord

'------------
' 文字列関数
'------------

Function Asc(buf As *StrChar) As StrChar
    Asc = buf[0]
End Function

Function Chr$(code As StrChar) As String
    Chr$ = New String(code, 1)
End Function

#ifndef __STRING_IS_NOT_UNICODE
Function AscW(s As String) As UCSCHAR
    If s.Length = 0 Then
        AscW = 0
    Else
        If _System_IsSurrogatePair(s[0], s[1]) Then
            AscW = ((s[0] And &h3FF) As DWord << 10) Or (s[1] And &h3FF)
        Else
            AscW = s[0]
        End If
    End If
End Function

Function ChrW(c As UCSCHAR) As String
    If c <= &hFFFF Then
        Return New String(c As StrChar, 1)
    ElseIf c < &h10FFFF Then
        Dim t[1] = [&hD800 Or (c >> 10), &hDC00 Or (c And &h3FF)] As StrChar
        Return New String(t, 2)
    Else
        'ArgumentOutOfRangeException
    End If
End Function
#endif

Function Date$() As String
    Dim date = System.DateTime.Now
    Dim buf = New System.Text.StringBuilder(10)

    'year
    buf.Append(date.Year)

    'month
    If date.Month < 10 Then
        buf.Append("/0")
    Else
        buf.Append("/")
    End If
    buf.Append(date.Month)

    'day
    If date.Day < 10 Then
        buf.Append("/0")
    Else
        buf.Append("/")
    End If
    buf.Append(date.Day)

    Date$ = buf.ToString
End Function

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

Function _System_Hex(x As DWord, zeroSuppress As Boolean) As String
    Dim s[7] As StrChar
    Dim i As Long
    For i = 0 To ELM(Len (s) \ SizeOf (StrChar))
        s[i] = _System_HexadecimalTable[x >> 28] As StrChar
        x <<= 4
    Next
    If zeroSuppress Then
        Dim i As Long
        For i = 0 To 6
            If s[i] <> &h30 Then 'Asc("0")
                Exit For
            End If
        Next
        Return New String(VarPtr(s[i]) As *StrChar, Len (s) \ SizeOf (StrChar) - i)
    Else
        Return New String(s As *StrChar, Len (s) \ SizeOf (StrChar))
    End If
End Function

Function Hex$(x As DWord) As String
    Hex$ = _System_Hex(x, True)
End Function

Function Hex$(x As QWord) As String
    If HIDWORD(x) = 0 Then
        Hex$ = _System_Hex(LODWORD(x), True)
    Else
        Hex$ = _System_Hex(HIDWORD(x), True) + _System_Hex(LODWORD(x), False)
    End If
End Function

Function InStr(StartPos As Long, buf1 As String, buf2 As String) As Long
    Dim i As Long, i2 As Long, i3 As Long

    Dim len1 = buf1.Length
    Dim len2 = buf2.Length

    If len2=0 Then
        InStr=StartPos
        Exit Function
    End If

    StartPos--
    If StartPos<0 Then
        'error
        InStr=0
        Exit Function
    End If

    i=StartPos:InStr=0
    While i<=len1-len2
        i2=i:i3=0
        Do
            If i3=len2 Then
                InStr=i+1
                Exit Do
            End If
            If buf1[i2]<>buf2[i3] Then Exit Do

            i2++
            i3++
        Loop
        If InStr Then Exit While
        i++
    Wend
End Function

Function Left$(s As String, length As Long) As String
    Left$ = s.Substring(0, System.Math.Min(s.Length, length))
End Function

Function Mid$(s As String, startPos As Long) As String
    startPos--
    Mid$ = s.Substring(startPos)
End Function

Function Mid$(s As String, startPos As Long, readLength = 0 As Long) As String
    startPos--
    Dim length = s.Length
    Mid$ = s.Substring(System.Math.Min(startPos, length), System.Math.Min(readLength, length - startPos))
End Function

Const _System_MaxFigure_Oct_QW = 22 As DWord 'QWORD_MAX = &o1,777,777,777,777,777,777,777
Function Oct$(n As QWord) As String
    Dim s[ELM(_System_MaxFigure_Oct_QW)] As StrChar
    Dim i = ELM(_System_MaxFigure_Oct_QW) As Long
    Do
        s[i] = ((n And &o7) + &h30) As StrChar '&h30 = Asc("0")
        n >>= 3
        If n = 0 Then
            Return New String(s + i, _System_MaxFigure_Oct_QW - i)
        End If
        i--
    Loop
End Function

Const _System_MaxFigure_Oct_DW = 11 As DWord 'DWORD_MAX = &o37,777,777,777
Function Oct$(n As DWord) As String
    Dim s[ELM(_System_MaxFigure_Oct_DW)] As StrChar
    Dim i = ELM(_System_MaxFigure_Oct_DW) As Long
    Do
        s[i] = ((n And &o7) + &h30) As StrChar '&h30 = Asc("0")
        n >>= 3
        If n = 0 Then
            Return New String(s + i, _System_MaxFigure_Oct_DW - i)
        End If
        i--
    Loop
End Function

Function Right$(s As String, length As Long) As String
    Right$ = s.Substring(System.Math.Max(0, s.Length - length), s.Length)
End Function

Function Space$(length As Long) As String
    Return New String(&h20 As StrChar, length)
End Function

Dim _System_ecvt_buffer[16] As StrChar
Sub _ecvt_support(count As Long)
    Dim i As Long
    If _System_ecvt_buffer[count]=9 Then
        _System_ecvt_buffer[count]=0
        If count=0 Then
            For i=16 To 1 Step -1
                _System_ecvt_buffer[i]=_System_ecvt_buffer[i-1]
            Next
            _System_ecvt_buffer[0]=1
        Else
            _ecvt_support(count-1)
        End If
    Else
        _System_ecvt_buffer[count]++
    End If
End Sub
Function _ecvt(value As Double, count As Long, ByRef dec As Long, ByRef sign As Long) As *StrChar
    Dim i As Long, i2 As Long

    _ecvt=_System_ecvt_buffer

    '値が0の場合
    If value = 0 Then
        ActiveBasic.Strings.ChrFill(_System_ecvt_buffer, count As SIZE_T, &H30 As StrChar)
        _System_ecvt_buffer[count] = 0
        dec = 0
        sign = 0
        Exit Function
    End If

    '符号の判断（同時に符号を取り除く）
    If value < 0 Then
        sign = 1
        value = -value
    Else
        sign = 0
    End If

    '正規化
    dec = 1
    While value < 0.999999999999999 'value<1
        value *= 10
        dec--
    Wend
    While 9.99999999999999 <= value '10<=value
        value /= 10
        dec++
    Wend

    For i=0 To count-1
        _System_ecvt_buffer[i] = Int(value) As StrChar

        value = (value-CDbl(Int(value))) * 10
    Next
    _System_ecvt_buffer[i] = 0

    i--
    If value >= 5 Then
        '切り上げ処理
        _ecvt_support(i)
    End If

    For i=0 To ELM(count)
        _System_ecvt_buffer[i] += &H30
    Next
    _System_ecvt_buffer[i] = 0
End Function

Function Str$(dbl As Double) As String
    If ActiveBasic.Math.IsNaN(dbl) Then
        Return "NaN"
    ElseIf ActiveBasic.Math.IsInf(dbl) Then
        If dbl > 0 Then
            Return "Infinity"
        Else
            Return "-Infinity"
        End If
    End If
    Dim dec As Long, sign As Long
    Dim buffer[32] As StrChar, temp As *StrChar
    Dim i As Long, i2 As Long, i3 As Long

    '浮動小数点を文字列に変換
    temp = _ecvt(dbl, 15, dec, sign)

    i=0

    '符号の取り付け
    If sign Then
        buffer[i] = Asc("-")
        i++
    End If

    If dec>15 Then
        '指数表示（桁が大きい場合）
        buffer[i] = temp[0]
        i++
        buffer[i] = Asc(".")
        i++
        ActiveBasic.Strings.ChrCopy(VarPtr(buffer[i]), VarPtr(temp[1]), 14 As SIZE_T)
        i += 14
        buffer[i] = Asc("e")
        i++
        _stprintf(VarPtr(buffer[i]), "+%03d", dec - 1) 'ToDo: __STRING_UNICODE_WINDOWS_ANSI状態への対応

        Return MakeStr(buffer)
    End If

    If dec < -3 Then
        '指数表示（桁が小さい場合）
        buffer[i] = temp[0]
        i++
        buffer[i] = Asc(".")
        i++
        ActiveBasic.Strings.ChrCopy(VarPtr(buffer[i]), VarPtr(temp[1]), 14 As SIZE_T)
        i+=14
        buffer[i] = Asc("e")
        i++
        _stprintf(VarPtr(buffer[i]), "+%03d", dec - 1) 'ToDo: __STRING_UNICODE_WINDOWS_ANSI状態への対応

        Return MakeStr(buffer)
    End If

    '整数部
    i2=dec
    i3=0
    If i2>0 Then
        While i2>0
            buffer[i]=temp[i3]
            i++
            i3++
            i2--
        Wend
        buffer[i]=Asc(".")
        i++
    Else
        buffer[i]=&H30
        i++
        buffer[i]=Asc(".")
        i++

        i2=dec
        While i2<0
            buffer[i]=&H30
            i++
            i2++
        Wend
    End If

    '小数部
    While i3<15
        buffer[i]=temp[i3]
        i++
        i3++
    Wend

    While buffer[i-1]=&H30
        i--
    Wend
    If buffer[i-1]=Asc(".") Then i--

    buffer[i]=0
    Return MakeStr(buffer)
End Function

Function Str$(i As Int64) As String
    If i < 0 Then
        Return "-" & Str$(-i As QWord)
    Else
        Return Str$(i As QWord)
    End If
End Function

Function Str$(x As QWord) As String
    If x = 0 Then
        Return "0"
    End If

    Dim buf[20] As StrChar
    'buf[20] = 0
    Dim i = 19 As Long
    Do
        buf[i] = (x Mod 10 + &h30) As StrChar
        x \= 10
        If x = 0 Then
            Exit Do
        End If
        i--
    Loop
    Return New String(VarPtr(buf[i]), 20 - i)
End Function

Function Str$(x As Long) As String
#ifdef _WIN64
    Return Str$(x As Int64)
#else
    If x < 0 Then
        Return "-" & Str$(-x As DWord)
    Else
        Return Str$(x As DWord)
    End If
#endif
End Function

Function Str$(x As DWord) As String
#ifdef _WIN64
    Return Str$(x As QWord)
#else
    If x = 0 Then
        Return "0"
    End If

    Dim buf[10] As StrChar
    buf[10] = 0
    Dim i = 9 As Long
    Do
        buf[i] = (x As Int64 Mod 10 + &h30) As StrChar 'Int64への型変換は#117対策
        x \= 10
        If x = 0 Then
            Return New String(VarPtr(buf[i]), 10 - i)
        End If
        i--
    Loop    
#endif
End Function

Function Str$(x As Word) As String
    Return Str$(x As ULONG_PTR)
End Function

Function Str$(x As Integer) As String
    Return Str$(x As LONG_PTR)
End Function

Function Str$(x As Byte) As String
    Return Str$(x As ULONG_PTR)
End Function

Function Str$(x As SByte) As String
    Return Str$(x As LONG_PTR)
End Function

Function Str$(x As Single) As String
    Return Str$(x As Double)
End Function

Function Str$(b As Boolean) As String
    If b Then
        Return "True"
    Else
        Return "False"
    End If
End Function

Function String$(n As Long, s As StrChar) As String
    Return New String(s, n)
End Function
        
#ifdef _AB4_COMPATIBILITY_STRING$_
Function String$(n As Long, s As String) As String
    If n < 0 Then
        'Throw ArgumentOutOfRangeException
    End If

    Dim buf = New System.Text.StringBuilder(s.Length * n)
    Dim i As Long
    For i = 0 To n
        buf.Append(s)
    Next
End Function
#else
Function String$(n As Long, s As String) As String
    If String.IsNullOrEmpty(s) Then
        Return New String(0 As StrChar, n)
            Else
        Return New String(s[0], n)
    End If
End Function
#endif

Function Time$() As String
    Dim time = System.DateTime.Now

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

    'hour
    If time.Hour < 10 Then
        buf.Append("0")
    End If
    buf.Append(time.Hour)

    'minute
    If time.Minute < 10 Then
        buf.Append(":0")
    Else
        buf.Append(":")
    End If
    buf.Append(time.Minute)

    'second
    If time.Second < 10 Then
        buf.Append(":0")
    Else
        buf.Append(":")
    End If
    buf.Append(time.Second)
    Time$ = buf.ToString
End Function

Function Val(buf As *StrChar) As Double
    Dim i As Long, i2 As Long, i3 As Long, i4 As Long
    Dim temporary As String
    Dim TempPtr As *StrChar
    Dim dbl As Double
    Dim i64data As Int64

    Val=0

    While buf[0]=Asc(" ") or buf[0]=Asc(Ex"\t")
        buf = VarPtr(buf[1])
    Wend

    If buf[0]=Asc("&") Then
        temporary = New String( buf )
        temporary = temporary.ToUpper()
        TempPtr = StrPtr(temporary)
        If TempPtr(1)=Asc("O") Then
            '8進数
            i=2
            While 1
                '数字以外の文字の場合は抜け出す
                i3=TempPtr[i]-&H30
                If Not (0<=i3 And i3<=7) Then Exit While

                TempPtr[i]=i3 As StrChar
                i++
            Wend
            i--

            i64data=1
            While i>=2
                Val += ( i64data * TempPtr[i] ) As Double

                i64data *= &O10
                i--
            Wend
        ElseIf TempPtr(1)=Asc("H") Then
            '16進数
            i=2
            While 1
                '数字以外の文字の場合は抜け出す
                i3=TempPtr[i]-&H30
                If Not(0<=i3 and i3<=9) Then
                    i3=TempPtr[i]-&H41+10
                    If Not(&HA<=i3 and i3<=&HF) Then Exit While
                End If

                TempPtr[i]=i3 As StrChar
                i++
            Wend
            i--

            i64data=1
            While i>=2
                Val += (i64data*TempPtr[i]) As Double

                i64data *= &H10
                i--
            Wend
        End If
    Else
        '10進数
        sscanf(buf,"%lf",VarPtr(Val))
    End If
End Function


'--------------
' ファイル関数
'--------------

Function Eof(FileNum As Long) As Long
    Dim dwCurrent As DWord, dwEnd As DWord

    FileNum--

    dwCurrent=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_CURRENT)
    dwEnd=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_END)
    SetFilePointer(_System_hFile(FileNum),dwCurrent,NULL,FILE_BEGIN)

    If dwCurrent>=dwEnd Then
        Eof=-1
    Else
        Eof=0
    End If
End Function

Function Lof(FileNum As Long) As Long
    Lof = GetFileSize(_System_hFile(FileNum-1), 0)
End Function

Function Loc(FileNum As Long) As Long
    FileNum--

    Dim NowPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_CURRENT)
    Dim BeginPos = SetFilePointer(_System_hFile(FileNum), 0, 0, FILE_BEGIN)
    SetFilePointer(_System_hFile(FileNum), NowPos - BeginPos, 0, FILE_BEGIN)

    Loc = NowPos - BeginPos
End Function


'------------------
' メモリ関連の関数
'------------------

Function malloc(stSize As SIZE_T) As VoidPtr
    Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC)
End Function

Function calloc(stSize As SIZE_T) As VoidPtr
    Return _System_pGC->__malloc(stSize,_System_GC_FLAG_NEEDFREE or _System_GC_FLAG_ATOMIC or _System_GC_FLAG_INITZERO)
End Function

Function realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
    If lpMem = 0 Then
        Return malloc(stSize)
    Else
        Return _System_pGC->__realloc(lpMem,stSize)
    End If
End Function

Sub free(lpMem As VoidPtr)
    _System_pGC->__free(lpMem)
End Sub

Function _System_malloc(stSize As SIZE_T) As VoidPtr
    Return HeapAlloc(_System_hProcessHeap,0,stSize)
End Function

Function _System_calloc(stSize As SIZE_T) As VoidPtr
    Return HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,stSize)
End Function

Function _System_realloc(lpMem As VoidPtr, stSize As SIZE_T) As VoidPtr
    If lpMem = 0 Then
        Return HeapAlloc(_System_hProcessHeap, 0, stSize)
    Else
        Return HeapReAlloc(_System_hProcessHeap, 0, lpMem, stSize)
    End If
End Function

Sub _System_free(lpMem As VoidPtr)
    HeapFree(_System_hProcessHeap,0,lpMem)
End Sub


'--------
' その他
'--------

Sub _splitpath(path As PCSTR, drive As PSTR, dir As PSTR, fname As PSTR, ext As PSTR)
    Dim i As Long, i2 As Long, i3 As Long, length As Long
    Dim buffer[MAX_PATH] As SByte

    '":\"をチェック
    If not(path[1]=&H3A and path[2]=&H5C) Then Exit Sub

    'ドライブ名をコピー
    If drive Then
        drive[0]=path[0]
        drive[1]=path[1]
        drive[2]=0
    End If

    'ディレクトリ名をコピー
    i=2
    i2=0
    Do
        If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
            If dir Then
                dir[i2]=path[i]
                dir[i2+1]=path[i+1]
            End If

            i += 2
            i2 += 2
            Continue
        End If

        If path[i]=0 Then Exit Do

        If path[i]=&H5C Then '"\"記号であるかどうか
            i3=i2+1
        End If

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

        i++
        i2++
    Loop
    If dir Then dir[i3]=0
    i3 += i-i2

    'ファイル名をコピー
    i=i3
    i2=0
    i3=-1
    Do
'#ifdef UNICODE
'       If _System_IsSurrogatePair(path[i], path[i + 1]) Then
'#else
        If IsDBCSLeadByte(path[i]) <> FALSE and path[i + 1] <> 0 Then
'#endif
            If fname Then
                fname[i2]=path[i]
                fname[i2+1]=path[i+1]
            End If

            i += 2
            i2 += 2
            Continue
        End If

        If path[i]=0 Then Exit Do

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

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

        i++
        i2++
    Loop
    If i3=-1 Then i3=i2
    If fname Then fname[i3]=0
    i3 += i-i2

    '拡張子名をコピー
    If ext Then
        If i3 Then
            lstrcpy(ext,path+i3)
        End If
        else ext[0]=0
    End If
End Sub

Function GetBasicColor(ColorCode As Long) As Long
    Select Case ColorCode
        Case 0
            GetBasicColor=RGB(0,0,0)
        Case 1
            GetBasicColor=RGB(0,0,255)
        Case 2
            GetBasicColor=RGB(255,0,0)
        Case 3
            GetBasicColor=RGB(255,0,255)
        Case 4
            GetBasicColor=RGB(0,255,0)
        Case 5
            GetBasicColor=RGB(0,255,255)
        Case 6
            GetBasicColor=RGB(255,255,0)
        Case 7
            GetBasicColor=RGB(255,255,255)
    End Select
End Function

Function _System_BSwap(x As Word) As Word
    Dim src = VarPtr(x) As *Byte
    Dim dst = VarPtr(_System_BSwap) As *Byte
    dst[0] = src[1]
    dst[1] = src[0]
End Function

Function _System_BSwap(x As DWord) As DWord
    Dim src = VarPtr(x) As *Byte
    Dim dst = VarPtr(_System_BSwap) As *Byte
    dst[0] = src[3]
    dst[1] = src[2]
    dst[2] = src[1]
    dst[3] = src[0]
End Function

Function _System_BSwap(x As QWord) As QWord
    Dim src = VarPtr(x) As *Byte
    Dim dst = VarPtr(_System_BSwap) As *Byte
    dst[0] = src[7]
    dst[1] = src[6]
    dst[2] = src[5]
    dst[3] = src[4]
    dst[4] = src[3]
    dst[5] = src[2]
    dst[6] = src[1]
    dst[7] = src[0]
End Function

Function _System_HashFromPtr(p As VoidPtr) As Long
#ifdef _WIN64
    Dim qw = p As QWord
    Return (HIDWORD(qw) Xor LODWORD(qw)) As Long
#else
    Return p As Long
#endif
End Function

/*!
@brief  ABオブジェクトを指すポインタをObject型へ変換。
@author Egtra
@date   2007/08/24
@param[in]  p   COMインタフェースを指すポインタ
@return Object参照型
*/
Function _System_PtrObj(p As VoidPtr) As Object
    SetPointer(VarPtr(_System_PtrObj), p)
End Function

/*!
@brief  IUnknownその他COMインタフェースを指すポインタをIUnknown参照型へ変換。
@author Egtra
@date   2007/09/24
@param[in]  p   COMインタフェースを指すポインタ
@return IUnknown参照型
*/
Function _System_PtrUnknown(p As VoidPtr) As IUnknown
    SetPointer(VarPtr(_System_PtrUnknown), p)
End Function

'--------
' 文字列関数その2
'--------
Function _System_IsSurrogatePair(wcHigh As WCHAR, wcLow As WCHAR) As Boolean
    If &hD800 <= wcHigh And wcHigh < &hDC00 Then
        If &hDC00 <= wcLow And wcLow < &hE000 Then
            Return True
        End If
    End If
    Return False
End Function

Function _System_IsDoubleUnitChar(lead As WCHAR, trail As WCHAR) As Boolean
    Return _System_IsSurrogatePair(lead, trail)
End Function

Function _System_IsDoubleUnitChar(lead As SByte, trail As SByte) As Boolean
    Return IsDBCSLeadByte(lead) <> FALSE
End Function

Function _System_ASCII_IsUpper(c As WCHAR) As Boolean
    Return c As DWord - &h41 < 26 ' &h41 = Asc("A")
End Function

Function _System_ASCII_IsUpper(c As SByte) As Boolean
    Return _System_ASCII_IsUpper(c As Byte As WCHAR)
End Function

Function _System_ASCII_IsLower(c As WCHAR) As Boolean
    Return c As DWord - &h61 < 26 ' &h61 = Asc("a")
End Function

Function _System_ASCII_IsLower(c As SByte) As Boolean
    Return _System_ASCII_IsLower(c As Byte As WCHAR)
End Function

Function _System_ASCII_ToLower(c As WCHAR) As WCHAR
    If _System_ASCII_IsUpper(c) Then
        Return c Or &h20
    Else
        Return c
    End If
End Function

Function _System_ASCII_ToLower(c As SByte) As SByte
    Return _System_ASCII_ToLower(c As Byte As WCHAR) As Byte As SByte
End Function

Function _System_ASCII_ToUpper(c As WCHAR) As WCHAR
    If _System_ASCII_IsLower(c) Then
        Return c And (Not &h20)
    Else
        Return c
    End If
End Function

Function _System_ASCII_ToUpper(c As SByte) As SByte
    Return _System_ASCII_ToUpper(c As Byte As WCHAR) As Byte As SByte
End Function

Function _System_GetHashFromWordArray(p As *Word, n As SIZE_T) As Long
    Dim hash = 0 As DWord
    Dim i As Long
    For i = 0 To ELM(n)
        hash = ((hash << 16) + p[i]) Mod &h7fffffff
    Next
    _System_GetHashFromWordArray = hash As Long
End Function

#endif '_INC_FUNCTION