'function.sbp


#ifndef _INC_FUNCTION
#define _INC_FUNCTION


Const _System_PI = 3.14159265358979323846264
Const _System_LOG2 = 0.6931471805599453094172321214581765680755
Const _System_SQRT2 = 1.41421356237309504880168872421


#include <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 As *QWord, pDest As *QWord
	pSrc = VarPtr(x) As *QWord
	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 As *QWord, pDest As *QWord
	pSrc = VarPtr(x) As *QWord
	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 BOOL) 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 BOOL) 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 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

'	IsNaN=FALSE
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 HIBYTE(w) = (((w As Word) >> 8) and &HFF) As Byte
Const LOBYTE(w) = ((w As Word) and &HFF) As Byte
Const HIWORD(dw) = (((dw As DWord) >> 16) and &HFFFF) As Word
Const LOWORD(dw) = ((dw As DWord) and &HFFFF) As Word

Const MAKEWORD(a,b) = (((a As Word) and &HFF) or (((b As Word) and &HFF)<<8)) As Word
Const MAKELONG(a,b) = (((a As DWord) and &HFFFF) or (((b As DWord) and &HFFFF)<<16)) As Long



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

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 Hex$(x As DWord) As String
	Dim i = 0
	Hex$ = ZeroString(8)
	While (x And &hf0000000) = 0
		x <<= 4
	Wend
	While x <> 0
		Hex$[i] = _System_HexadecimalTable[(x And &hf0000000) >> 28] As Char
		x <<= 4
		i++
	Wend
	Hex$.ReSize(i)
End Function

Function Hex$(x As QWord) As String
	Hex$ = Hex$((x >> 32) As DWord) + Hex$((x And &hffffffff) As DWord)
End Function

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

	len1=Len(buf1)
	len2=Len(buf2)

	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 (Char) * 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 (Char) * 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) ' &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 (Char) * length)
	Else
		Right$=buf
	End If
End Function

Function Space$(length As Long) As String
	Space$.ReSize(length, &H20 As Char)
End Function

Dim _System_ecvt_buffer[16] As Char
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 *Char
	Dim temp As *Char
	Dim i As Long, i2 As Long

	_ecvt=_System_ecvt_buffer

	'値が0の場合
	If value=0 Then
		_System_FillChar(_System_ecvt_buffer, count, &H30)
		_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 Char

		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 count-1
		_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 Char, temp As *Char
	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 (Char) * 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 (Char) * 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$[i*length]), StrPtr(buf), SizeOf (Char) * 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 *Char) As Double
	Dim i As Long, i2 As Long, i3 As Long, i4 As Long
	Dim temporary As String
	Dim TempPtr As *Char
	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 Char
				i++
			Wend
			i--

			i64data=1
			While i>=2
				Val += i64data * TempPtr[i]

				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 Char
				i++
			Wend
			i--

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

				i64data *= &H10
				i--
			Wend
		End If
	Else
		'10進数
		If buf[0]=&H2D Then
			'マイナス値
			i4=1
			buf++
		Else
			'プラス値
			i4=0
			If buf[0]=&H2B Then
				buf++
			End If
		End If

		i=0

		While 1
			'数字以外の文字の場合は抜け出す
			i3=buf[i]-&H30
			If Not (0<=i3 And i3<=9) Then Exit While

			i++
		Wend

		'整数部
		dbl=1
		i3=i-1
		While i3>=0
			Val += dbl*(buf[i3]-&H30)

			dbl *= 10
			i3--
		Wend

		If buf[i]=Asc(".") Then
			'小数部
			i++
			dbl=10
			While 1
				'数字以外の文字の場合は抜け出す
				i3=buf[i]-&H30
				If Not (0<=i3 And i3<=9) Then Exit While

				Val += (buf[i] - &H30) / dbl
				dbl *= 10
				i++
			Wend
		End If

		If i4 Then Val=-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 Char

	'":\"をチェック
	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
'#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 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

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

#endif '_INC_FUNCTION