source: Include/basic/function.sbp@ 258

'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>


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

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

#ifdef _WIN64

Function _System_GetNaN() As Double
    SetQWord(VarPtr(_System_GetNaN) As *QWord, &H7FF8000000000000)
End Function

Function _System_GetInf(sign As Boolean) As Double
    Dim s = 0 As QWord
    If sign Then s = 1 << 63
    SetQWord(VarPtr(_System_GetInf) As *QWord, &h7FF0000000000000 Or s)
End Function

#else

Function _System_GetNaN() As Double
    Dim p As *DWord
    p = VarPtr(_System_GetNaN) As *DWord
    p[0] = 0
    p[1] = &H7FF80000
End Function

Function _System_GetInf(sign As Boolean) As Double
    Dim s = 0 As DWord
    If sign Then s = (1 As DWord) << 31
    Dim p As *DWord
    p = VarPtr(_System_GetInf) As *DWord
    p[0] = 0
    p[1] = &h7FF00000 Or s
End Function

#endif

' xの符号だけをyのものにした値を返す。
' 引数 x 元となる絶対値
' 引数 y 元となる符号
Function CopySign(x As Double, y As Double) As Double
    SetQWord(VarPtr(CopySign), (GetQWord(VarPtr(x)) And &h7fffffffffffffff) Or (GetQWord(VarPtr(y)) And &h8000000000000000))
End Function

Function CopySign(x As Single, y As Single) As Single
    SetDWord(VarPtr(CopySign), (GetDWord(VarPtr(x)) And &h7fffffff) Or (GetDWord(VarPtr(y)) And &h80000000))
End Function

Function _System_SetSign(x As Double, isNegative As Long) As Double
#ifdef _WIN64
    SetQWord(AddressOf(CopySign), (GetQWord(VarPtr(x)) And &h7fffffffffffffff) Or (isNegative << 63))
#else
    SetDWord(AddressOf(CopySign), GetDWord(VarPtr(x)))
    SetDWord(AddressOf(CopySign) + SizeOf (DWord), GetQWord(VarPtr(x) + SizeOf (DWord)) And &h7fffffff Or (isNegative << 31))
#endif
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
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=Int-1
    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 = Math.Abs(number)
    If number < 0 then
        return -number
    Else
        return number
    End If
End Function

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

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

Function Log1p(x As Double) As Double
    If x < -1 Or IsNaN(x) Then
        Log1p = _System_GetNaN()
    ElseIf x = 0 Then
        x = 0
    ElseIf IsInf(x) Then
        Log1p = x
    Else
        Log1p = _System_Log1p(x)
    End If
End Function

Function _System_Log1p(x As Double) As Double
    Dim s = 0 As Double
    Dim i = 7 As Long
    While i >= 1
        Dim t = (i * x) As Double
        s = t / (2 + t / (2 * i + 1 + s))
        i--
    Wend
    Return x / (1 + s)
End Function

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

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

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

Function _Support_tan(x As Double, ByRef k As Long) As Double
    Dim i As Long
    Dim t As Double, x2 As Double

    If x>=0 Then
        k=Fix(x/(_System_PI/2)+0.5)
    Else
        k=Fix(x/(_System_PI/2)-0.5)
    End If

    x=(x-(CDbl(3217)/CDbl(2048))*k)+4.4544551033807686783083602485579e-6*k

    x2=x*x
    t=0

    For i=19 To 3 Step -2
        t=x2/(i-t)
    Next

    _Support_tan=x/(1-t)
End Function

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

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

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

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

Function IsNaN(ByVal x As Double) As Boolean
    Dim p As *DWord
    p = VarPtr(x) As *DWord
    IsNaN = False
    If (p[1] And &H7FF00000) = &H7FF00000 Then
        If (p[0] <> 0) Or ((p[1] And &HFFFFF) <> 0) Then
            IsNaN = True
        End If
    End If
End Function

Function IsInf(x As Double) As Boolean
    Dim p As *DWord, nan As Double
    p = VarPtr(x) As *DWord
    p[1] And= &h7fffffff
    nan = _System_GetInf(False)
    IsInf = (memcmp(p As *Byte, VarPtr(nan), SizeOf (Double)) = 0)
End Function

Function IsNaNOrInf(x As Double) As Boolean
    IsNaNOrInf = IsFinite(x)
End Function

Function IsFinite(x As Double) As Boolean
    Dim p As *DWord, nan As Double
    p = VarPtr(x) As *DWord
'   p[1] And= &h7ffe0000
    p[1] And= &H7FF00000
    p[0] = 0
    nan = _System_GetInf(/*x,*/ False)
    IsFinite = (memcmp(p As BytePtr, VarPtr(nan), SizeOf (Double)) = 0)
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$ = ZeroString(1)
    Chr$[0] = code
End Function

#ifndef __STRING_IS_NOT_UNICODE
Function AscW(s As *WCHAR) 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
        ChrW.ReSize(1)
        ChrW[0] = c As WCHAR
    ElseIf c < &h10FFFF Then
        ChrW.ReSize(2)
        ChrW[0] = &hD800 Or (c >> 10)
        ChrW[1] = &hDC00 Or (c And &h3FF)
    Else
        ' OutOfRangeException
    End If
End Function
#endif

Function Date$() As String
    Dim st As SYSTEMTIME
    GetLocalTime(st)

    'year
    Date$=Str$(st.wYear)

    'month
    If st.wMonth<10 Then
        Date$=Date$+"/0"
    Else
        Date$=Date$+"/"
    End If
    Date$=Date$+Str$(st.wMonth)

    'day
    If st.wDay<10 Then
        Date$=Date$+"/0"
    Else
        Date$=Date$+"/"
    End If
    Date$=Date$+Str$(st.wDay)
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
    Hex$ = _System_Hex(HIDWORD(x), True) + _System_Hex(LODWORD(x), False)
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$(buf As String, length As Long) As String
    Left$ = ZeroString(length)
    memcpy(StrPtr(Left$), StrPtr(buf), SizeOf (StrChar) * length)
End Function

Function Mid$(buf As String, StartPos As Long)(ReadLength As Long) As String
    Dim length As Long

    StartPos--
    If StartPos<0 Then
        'error
        'Debug
        Exit Function
    End If

    length=Len(buf)
    If length<=StartPos Then Exit Function

    If ReadLength=0 Then
        ReadLength=length-StartPos
    End If

    If ReadLength>length-StartPos Then
        ReadLength=length-StartPos
    End If

    Mid$=ZeroString(ReadLength)
    memcpy(StrPtr(Mid$), VarPtr(buf.Chars[StartPos]), SizeOf (StrChar) * ReadLength)
End Function

Function Oct$(num As DWord) As String
    Dim i As DWord, i2 As DWord

    For i=10 To 1 Step -1
        If (num\CDWord(8^i)) And &H07 Then
            Exit For
        End If
    Next

    Oct$=ZeroString(i+1)
    i2=0
    Do
        Oct$[i2] = &h30 +((num \ CDWord(8 ^ i)) And &H07) As StrChar ' &h30 = Asc("0")
        If i=0 Then Exit Do
        i--
        i2++
    Loop
End Function

Function Right$(buf As String, length As Long) As String
    Dim i As Long

    i=Len(buf)
    If i>length Then
        Right$=ZeroString(length)
        memcpy(StrPtr(Right$), VarPtr(buf.Chars[i-length]), SizeOf (StrChar) * length)
    Else
        Right$=buf
    End If
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
        _System_FillChar(_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 IsNaN(dbl) Then
        Return "NaN"
    ElseIf 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++
        memcpy(VarPtr(buffer[i]), VarPtr(temp[1]), SizeOf (StrChar) * 14)
        i += 14
        buffer[i] = Asc("e")
        i++
        _stprintf(VarPtr(buffer[i]), "+%03d", dec - 1)

        Return MakeStr(buffer)
    End If

    If dec < -3 Then
        '指数表示（桁が小さい場合）
        buffer[i] = temp[0]
        i++
        buffer[i] = Asc(".")
        i++
        memcpy(VarPtr(buffer[i]), VarPtr(temp[1]), SizeOf (StrChar) * 14)
        i+=14
        buffer[i] = Asc("e")
        i++
        _stprintf(VarPtr(buffer[i]), "+%03d", dec - 1)

        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$(value As Int64) As String
    Dim temp[255] As Char
    _sntprintf(temp, Len (temp) \ SizeOf (Char), "%I64d", value)
    Str$ = New String( temp )
End Function

Function String$(num As Long, buf As String) As String
    Dim dwStrPtr As DWord
    Dim length As Long

    length=Len(buf)

    'バッファ領域を確保
    String$=ZeroString(length*num)

    '文字列をコピー
    Dim i As Long
    For i=0 To num-1
        memcpy(VarPtr(String$.Chars[i*length]), StrPtr(buf), SizeOf (StrChar) * length)
    Next
End Function

Function Time$() As String
    Dim st As SYSTEMTIME

    GetLocalTime(st)

    'hour
    If st.wHour<10 Then
        Time$="0"
    End If
    Time$=Time$+Str$(st.wHour)

    'minute
    If st.wMinute<10 Then
        Time$=Time$+":0"
    Else
        Time$=Time$+":"
    End If
    Time$=Time$+Str$(st.wMinute)

    'second
    If st.wSecond<10 Then
        Time$=Time$+":0"
    Else
        Time$=Time$+":"
    End If
    Time$=Time$+Str$(st.wSecond)
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++
    Wend

    If buf[0]=Asc("&") Then
        temporary = New String( buf )
        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
    Dim NowPos As Long, BeginPos As Long

    FileNum--

    NowPos=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_CURRENT)
    BeginPos=SetFilePointer(_System_hFile(FileNum),0,NULL,FILE_BEGIN)
    SetFilePointer(_System_hFile(FileNum),NowPos-BeginPos,NULL,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

'--------
' 文字列関数その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

Sub _System_FillChar(p As PWSTR, n As SIZE_T, c As WCHAR)
    Dim i As SIZE_T
    For i = 0 To ELM(n)
        p[i] = c
    Next
End Sub

Sub _System_FillChar(p As PSTR, n As SIZE_T, c As SByte)
    Dim i As SIZE_T
    For i = 0 To ELM(n)
        p[i] = c
    Next
End Sub

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_StrCmp(s1 As PCSTR, s2 As PCSTR) As Long
    Dim i = 0 As SIZE_T
    While s1[i] = s2[i]
        If s1[i] = 0 Then
            Exit While
        End If
        i++
    Wend
    _System_StrCmp = s1[i] - s2[i]
End Function

Function _System_StrCmp(s1 As PCWSTR, s2 As PCWSTR) As Long
    Dim i = 0 As SIZE_T
    While s1[i] = s2[i]
        If s1[i] = 0 Then
            Exit While
        End If
        i++
    Wend
    _System_StrCmp = s1[i] - s2[i]
End Function

Function _System_StrCmpN(s1 As PCSTR, s2 As PCSTR, size As SIZE_T) As Long
    Dim i = 0 As SIZE_T
    For i = 0 To ELM(size)
        _System_StrCmpN = s1[i] - s2[i]
        If _System_StrCmpN <> 0 Then
            Exit Function
        End If
    Next
End Function

Function _System_StrCmpN(s1 As PCWSTR, s2 As PCWSTR, size As SIZE_T) As Long
    Dim i = 0 As SIZE_T
    For i = 0 To ELM(size)
        _System_StrCmpN = s1[i] - s2[i]
        If _System_StrCmpN <> 0 Then
            Exit Function
        End If
    Next
End Function

Function _System_MemChr(s As PCSTR, c As CHAR, size As SIZE_T) As PCSTR
    Dim i As SIZE_T
    For i = 0 To ELM(size)
        If s[i] = c Then
            Return VarPtr(s[i])
        End If
    Next
    Return 0
End Function

Function _System_MemChr(s As PCWSTR, c As WCHAR, size As SIZE_T) As PCWSTR
    Dim i As SIZE_T
    For i = 0 To ELM(size)
        If s[i] = c Then
            Return VarPtr(s[i])
        End If
    Next
    Return 0
End Function

Function _System_MemPBrk(str As PCSTR, cStr As SIZE_T, Chars As PCSTR, cChars As SIZE_T) As PCSTR
    Dim i As SIZE_T
    For i = 0 To ELM(cStr)
        If _System_MemChr(Chars, str[i], cChars) Then
            Return VarPtr(str[i])
        End If
    Next
    Return 0
End Function

Function _System_MemPBrk(str As PCWSTR, cStr As SIZE_T, Chars As PCWSTR, cChars As SIZE_T) As PCWSTR
    Dim i As SIZE_T
    For i = 0 To ELM(cStr)
        If _System_MemChr(Chars, str[i], cChars) Then
            Return VarPtr(str[i])
        End If
    Next
    Return 0
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

Namespace ActiveBasic
    Namespace Windows
        Function GetPathFromIDList(pidl As LPITEMIDLIST) As String
            Dim buf[ELM(MAX_PATH)] As TCHAR
            If SHGetPathFromIDList(pidl, buf) Then
                Return New String(buf)
            Else
                Return ""
            End If
        End Function

        Function GetFolderPath(hwnd As HWND, folder As Long) As String
            Dim pidl As LPITEMIDLIST
            Dim hr = SHGetSpecialFolderLocation(hwnd, folder, pidl)
            If SUCCEEDED(hr) Then
                GetFolderPath = GetPathFromIDList(pidl)
                CoTaskMemFree(pidl)
            Else
                GetFolderPath = ""
            End If
        End Function

        Function GetFolderPath(folder As Long) As String
            Return GetFolderPath(0, folder)
        End Function
    End Namespace
End Namespace

#endif '_INC_FUNCTION