Buchempfehlung
Windows System Programming
Windows System Programming
Das Kompendium liefert viele interessante Informationen zur Windows-Programmierung auf Englisch. [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

fb:porticula NoPaste

Info
Info / Hilfe
Liste
Übersicht / Liste
Neu
Datei hochladen
Suche
Quellcode suchen
Download
Dateidownload

rtlib.bas

Uploader:MitgliedThePuppetMaster
Datum/Zeit:26.08.2008 22:18:44

'###############################################################################################################
'###############################################################################################################
'###   F B - C O R E
'###############################################################################################################
'###############################################################################################################
'### Version:  1.00.0
'### Revision: 0
'###############################################################################################################
'### (c) 2008 By.: /_\ DeltaLab's Germany [experimental computing]
'### Author:       Martin Wiemann
'### Date of Idea: 2008.08.16 - 17:55:38
'###############################################################################################################
'### Copy('s) of this code or a part of this IS allowed!!!
'###############################################################################################################





'###############################################################################################################
#include once "rtlib_io.bi"
#include once "rtlib_memman.bi"
#include once "rtlib_video.bi"





'###############################################################################################################
Type _FBString
    str_ptr         as UByte Ptr
    str_len         as UInteger
    alloc_size      as UInteger
End Type





'###############################################################################################################
Sub TWait (V_Time as UInteger)
For Y as UInteger = 1 to V_Time
    For X as UInteger = 1 to 400000000
    Next
Next
End Sub





'###############################################################################################################
Public Function _fb_In CDecL Alias "fb_In" (V_Port as UInteger) as Integer
Return inb(V_Port)
End Function



'###############################################################################################################
Public Sub _fb_Cls CDecL Alias "fb_Cls" (V_Mode as UInteger)
Int_Text_CLS()
End Sub


'====================================================================================================================
Public Function _fb_Locate CDecL Alias "fb_Locate" (V_Row as Integer, V_Col as Integer, V_Cursor as Integer) as Integer
Int_Text_Cursor_Move(V_Row, V_Col)
If @V_Cursor <> 0 Then
    If V_Cursor = 0 Then Int_Text_Cursor_Hide Else Int_Text_Cursor_Show
End If
Return V_Row * G_Video_Text_Col * 256 + V_Col
End Function


'====================================================================================================================
Public Function _fb_Color CDecL Alias "fb_Color" (V_ForeColor as Integer, V_BackColor as Integer, V_Flags as Integer) as Integer
G_Video_Text_Color = CByte(V_ForeColor)
Return G_Video_Text_Color
End Function





'###############################################################################################################
Public Sub _fb_PrintByte CDecL Alias "fb_PrintByte" (V_FD as UInteger, V_Value as Byte, V_Mask as UInteger)
If V_FD = 0 Then
    Dim XNum(1 to 20) as UByte
    Dim XNumS AS UByte
    Dim X AS UInteger = 20
    Dim N as UByte = 0
    If V_Value < 0 Then V_Value += Cast(UByte, -1) + 1: N = 1
    Do
        If N = 1 Then
            XNum(X) = 48 - ((V_Value) MOD 10)
        Else: XNum(X) = V_Value MOD 10 + 48
        End If
        X -= 1: V_Value = V_Value \ 10
    Loop Until V_Value = 0
    If N = 1 Then Int_Text_Print_EX("-")
    For X = 1 To 20
        If XNum(X) = 0 AND XNumS = 0 Then Continue For
        Int_Text_Print_EX(, XNum(X))
        XNumS = 1
    Next
    If (V_Mask and 1) = 1 Then Int_Text_Print_EX(, 13): Int_Text_Print_EX(, 10)
Else
End If
End Sub

'--------------------------------------------------------------------------------------------------------------------
Public Sub _fb_PrintUByte CDecL Alias "fb_PrintUByte" (V_FD as UInteger, V_Value as UByte, V_Mask as UInteger)
If V_FD = 0 Then
    Dim XNum(1 to 20) as UByte
    Dim XNumS AS UByte
    Dim X AS UInteger = 20
    Do
        XNum(X) = V_Value MOD 10 + 48
        X -= 1: V_Value = V_Value \ 10
    Loop Until V_Value <= 0
    For X = 1 To 20
        If XNum(X) = 0 AND XNumS = 0 Then Continue For
        Int_Text_Print_EX(, XNum(X))
        XNumS = 1
    Next
    If (V_Mask and 1) = 1 Then Int_Text_Print_EX(, 13): Int_Text_Print_EX(, 10)
Else
End If
End Sub

'====================================================================================================================
Public Sub _fb_PrintShort CDecL Alias "fb_PrintShort" (V_FD as UInteger, V_Value as Short, V_Mask as UInteger)
If V_FD = 0 Then
    Dim XNum(1 to 20) as UByte
    Dim XNumS AS UByte
    Dim X AS UInteger = 20
    Dim N as UByte = 0
    If V_Value < 0 Then V_Value += Cast(UShort, -1) + 1: N = 1
    Do
        If N = 1 Then
            XNum(X) = 48 - ((V_Value) MOD 10)
        Else: XNum(X) = V_Value MOD 10 + 48
        End If
        X -= 1: V_Value = V_Value \ 10
    Loop Until V_Value = 0
    If N = 1 Then Int_Text_Print_EX("-")
    For X = 1 To 20
        If XNum(X) = 0 AND XNumS = 0 Then Continue For
        Int_Text_Print_EX(, XNum(X))
        XNumS = 1
    Next
    If (V_Mask and 1) = 1 Then Int_Text_Print_EX(, 13): Int_Text_Print_EX(, 10)
Else
End If
End Sub

'--------------------------------------------------------------------------------------------------------------------
Public Sub _fb_PrintUShort CDecL Alias "fb_PrintUShort" (V_FD as UInteger, V_Value as UShort, V_Mask as UInteger)
If V_FD = 0 Then
    Dim XNum(1 to 20) as UByte
    Dim XNumS AS UByte
    Dim X AS UInteger = 20
    Do
        XNum(X) = V_Value MOD 10 + 48
        X -= 1: V_Value = V_Value \ 10
    Loop Until V_Value <= 0
    For X = 1 To 20
        If XNum(X) = 0 AND XNumS = 0 Then Continue For
        Int_Text_Print_EX(, XNum(X))
        XNumS = 1
    Next
    If (V_Mask and 1) = 1 Then Int_Text_Print_EX(, 13): Int_Text_Print_EX(, 10)
Else
End If
End Sub

'====================================================================================================================
Public Sub _fb_PrintInt CDecL Alias "fb_PrintInt" (V_FD as UInteger, V_Value as Integer, V_Mask as UInteger)
If V_FD = 0 Then
    Dim XNum(1 to 20) as UByte
    Dim XNumS AS UByte
    Dim X AS UInteger = 20
    Dim N as UByte = 0
    If V_Value < 0 Then V_Value += Cast(UInteger, -1) + 1: N = 1
    Do
        If N = 1 Then
            XNum(X) = 48 - ((V_Value) MOD 10)
        Else: XNum(X) = V_Value MOD 10 + 48
        End If
        X -= 1: V_Value = V_Value \ 10
    Loop Until V_Value = 0
    If N = 1 Then Int_Text_Print_EX("-")
    For X = 1 To 20
        If XNum(X) = 0 AND XNumS = 0 Then Continue For
        Int_Text_Print_EX(, XNum(X))
        XNumS = 1
    Next
    If (V_Mask and 1) = 1 Then Int_Text_Print_EX(, 13): Int_Text_Print_EX(, 10)
Else
End If
End Sub

'--------------------------------------------------------------------------------------------------------------------
Public Sub _fb_PrintUInt CDecL Alias "fb_PrintUInt" (V_FD as UInteger, V_Value as UInteger, V_Mask as UInteger)
If V_FD = 0 Then
    Dim XNum(1 to 20) as UByte
    Dim XNumS AS UByte
    Dim X AS UInteger = 20
    Do
        XNum(X) = V_Value MOD 10 + 48
        X -= 1: V_Value = V_Value \ 10
    Loop Until V_Value <= 0
    For X = 1 To 20
        If XNum(X) = 0 AND XNumS = 0 Then Continue For
        Int_Text_Print_EX(, XNum(X))
        XNumS = 1
    Next
    If (V_Mask and 1) = 1 Then Int_Text_Print_EX(, 13): Int_Text_Print_EX(, 10)
Else
End If
End Sub

'====================================================================================================================
Public Sub _fb_PrintInteger CDecL Alias "fb_PrintInteger" (V_FD as UInteger, V_Value as Integer, V_Mask as UInteger)
If V_FD = 0 Then
    Dim XNum(1 to 20) as UByte
    Dim XNumS AS UByte
    Dim X AS UInteger = 20
    Dim N as UByte = 0
    If V_Value < 0 Then V_Value += Cast(UInteger, -1) + 1: N = 1
    Do
        If N = 1 Then
            XNum(X) = 48 - ((V_Value) MOD 10)
        Else: XNum(X) = V_Value MOD 10 + 48
        End If
        X -= 1: V_Value = V_Value \ 10
    Loop Until V_Value = 0
    If N = 1 Then Int_Text_Print_EX("-")
    For X = 1 To 20
        If XNum(X) = 0 AND XNumS = 0 Then Continue For
        Int_Text_Print_EX(, XNum(X))
        XNumS = 1
    Next
    If (V_Mask and 1) = 1 Then Int_Text_Print_EX(, 13): Int_Text_Print_EX(, 10)
Else
End If
End Sub

'--------------------------------------------------------------------------------------------------------------------
Public Sub _fb_PrintUInteger CDecL Alias "fb_PrintUInteger" (V_FD as UInteger, V_Value as UInteger, V_Mask as UInteger)
If V_FD = 0 Then
    Dim XNum(1 to 20) as UByte
    Dim XNumS AS UByte
    Dim X AS UInteger = 20
    Do
        XNum(X) = V_Value MOD 10 + 48
        X -= 1: V_Value = V_Value \ 10
    Loop Until V_Value <= 0
    For X = 1 To 20
        If XNum(X) = 0 AND XNumS = 0 Then Continue For
        Int_Text_Print_EX(, XNum(X))
        XNumS = 1
    Next
    If (V_Mask and 1) = 1 Then Int_Text_Print_EX(, 13): Int_Text_Print_EX(, 10)
Else
End If
End Sub

'====================================================================================================================
Public Sub _fb_PrintString CDecL Alias "fb_PrintString" (V_FD as UInteger, V_Handle as _FBString Ptr, V_Mask as UInteger)
If V_FD = 0 Then
    Dim XP AS UByte Ptr = V_Handle->str_ptr
'   Int_Text_Add("[PRISTR]     "): _fb_PrintInteger(0, Cast(Integer, V_Handle), 0)
    For X as UInteger = 1 to V_Handle->str_len
        Int_Text_Print_EX(, *XP): XP += 1
    Next
    If (V_Mask and 1) = 1 Then Int_Text_Print_EX(, 13): Int_Text_Print_EX(, 10)
Else
End If
End Sub





'###############################################################################################################
Public Function _malloc CDecL Alias "malloc" (V_Length As UInteger) as Any Ptr
Dim TAPtr as Any Ptr = _mem_alloc(V_Length)
'Int_Text_Add("[MALLOC]  "): _fb_PrintInteger(0, Cast(Integer, TAPtr), 0)
Return TAPtr
End Function





'###############################################################################################################
Public Function _fb_StrAllocTempDescZEx CDecL Alias "fb_StrAllocTempDescZEx" (ByVal str_ptr as UByte Ptr, ByVal str_len AS UInteger) as _FBString Ptr
Dim THandle AS _FBString Ptr = _malloc(SIZEOF(_FBString))
THandle->str_ptr = str_ptr
THandle->str_len = str_len
THandle->alloc_size = str_len
Return THandle
End Function





'###############################################################################################################
Public Function _fb_CHR CDecL Alias "fb_CHR" (V_ArgC as UInteger, ...) as _FBString Ptr
Dim THandle AS _FBString Ptr = _fb_StrAllocTempDescZEx(_malloc(V_ArgC), V_ArgC)
Dim TPtr as UByte Ptr = THandle->str_ptr
Dim XARG as Any Ptr = va_first()
For X as UInteger = 1 to V_ArgC
    *TPtr = va_arg(XARG, UByte)
    XARG = va_next(XARG, UByte)
    TPtr += 1
Next
Return THandle
End Function


'====================================================================================================================
Public Function _fb_ZStrLen(ByRef V_Src as UByte Ptr) as UInteger
Dim XPtr as UByte Ptr = V_Src
Do Until *XPtr = 0
    XPtr += 1
Loop
Return Cast(UInteger, XPtr - V_Src)
End Function

'--------------------------------------------------------------------------------------------------------------------
Public Sub _fb_FIXSTRING(ByRef V_Str as Any Ptr, ByRef V_Size as Integer, ByRef B_StrPtr as UByte Ptr, ByRef B_Size as Integer)
If V_Size = -1 Then
'   Int_Text_Add("[FIXSTR]  +Z+")
    B_StrPtr    = Cast(UByte Ptr, V_Str)
    B_Size      = Cast(Integer, Cast(_FBString Ptr, @V_Str)->str_len)
Else
'   Int_Text_Add("[FIXSTR]  +D+")
    B_StrPtr    = @V_Str
    B_Size      = V_Size - 1
End If
End Sub


'====================================================================================================================
Public Sub _fb_StrDelete CDecL Alias "fb_StrDelete" (ByRef V_String as _FBString Ptr)
'Int_Text_Add("[StrDel]")
_mem_free(V_String->str_ptr)
V_String->str_ptr = 0
V_String->str_len = 0
V_String->alloc_size = 0
_mem_free(V_String)
V_String = 0
End Sub

'--------------------------------------------------------------------------------------------------------------------
Public Function _fb_StrConcat CDecL Alias "fb_StrConcat" (ByVal V_Dest as _FBString Ptr, ByRef V_Src1 as Any Ptr, ByVal V_Src1_Size as Integer, ByRef V_Src2 as Any Ptr, ByVal V_Src2_Size as Integer) as _FBString Ptr
Dim TS1Len as UInteger
Dim TS1Ptr as UByte Ptr
Dim TS2Len as UInteger
Dim TS2Ptr as UByte Ptr
_fb_FIXSTRING(V_Src1, V_Src1_Size, TS1Ptr, TS1Len)
_fb_FIXSTRING(V_Src2, V_Src2_Size, TS2Ptr, TS2Len)
If Cast(_FBString Ptr, V_Dest)->str_ptr <> 0 Then _mem_free(Cast(_FBString Ptr, V_Dest)->str_ptr)
Cast(_FBString Ptr, V_Dest)->str_ptr = _malloc(TS1Len + TS2Len)
Cast(_FBString Ptr, V_Dest)->str_len = TS1Len + TS2Len
Cast(_FBString Ptr, V_Dest)->alloc_size = TS1Len + TS2Len
_memcpy(Cast(_FBString Ptr, V_Dest)->str_ptr, TS1Ptr, TS1Len)
_memcpy(Cast(_FBString Ptr, V_Dest)->str_ptr + TS1Len, TS2Ptr, TS2Len)
Return V_Dest
End Function

'--------------------------------------------------------------------------------------------------------------------
Public Function _fb_StrAssign CDecL Alias "fb_StrAssign" (ByVal V_Dest as Any Ptr, ByVal V_Dest_Size as Integer, ByRef V_Src as Any Ptr, ByVal V_Src_Size as Integer, ByVal V_Fill_Rem as Integer) as Any Ptr
Dim TSLen as UInteger
Dim TSPtr as UByte Ptr
_fb_FIXSTRING(V_Src, V_Src_Size, TSPtr, TSLen)
If V_Dest_Size = -1 Then
    Cast(_FBString Ptr, V_Dest)->str_ptr = _malloc(TSLen)
    Cast(_FBString Ptr, V_Dest)->str_len = TSLen
    Cast(_FBString Ptr, V_Dest)->alloc_size = TSLen
    _memcpy(Cast(_FBString Ptr, V_Dest)->str_ptr, TSPtr, TSLen)
Else ' ZString
End If
Return V_Dest
End Function

'--------------------------------------------------------------------------------------------------------------------
Public Function _fb_StrConcatAssign CDecL Alias "fb_StrConcatAssign" (ByVal V_Dest as Any Ptr, ByVal V_Dest_Size as Integer, ByRef V_Src as Any Ptr, ByVal V_Src_Size as Integer, ByVal V_Fill_Rem as Integer) as Any Ptr
Dim TSLen as UInteger
Dim TSPtr as UByte Ptr
_fb_FIXSTRING(V_Src, V_Src_Size, TSPtr, TSLen)
If V_Dest_Size = -1 Then
    If Cast(_FBString Ptr, V_Dest)->str_ptr <> 0 Then
        Dim TPtr as UByte Ptr = _malloc(Cast(_FBString Ptr, V_Dest)->str_len + TSLen)
        _memcpy(TPtr, Cast(_FBString Ptr, V_Dest)->str_ptr, Cast(_FBString Ptr, V_Dest)->str_len)
        _memcpy(TPtr + Cast(_FBString Ptr, V_Dest)->str_len, TSPtr, TSLen)
        _mem_free(Cast(_FBString Ptr, V_Dest)->str_ptr)
        Cast(_FBString Ptr, V_Dest)->str_ptr = TPtr
        Cast(_FBString Ptr, V_Dest)->str_len += TSLen
        Cast(_FBString Ptr, V_Dest)->alloc_size += TSLen
    End if
Else ' ZString
End If
Return V_Dest
End Function

'--------------------------------------------------------------------------------------------------------------------
Public Function _fb_StrCompare CDecL Alias "fb_StrCompare" (ByRef V_Src1 as Any Ptr, ByVal V_Src1_Size as Integer, ByRef V_Src2 as Any Ptr, ByVal V_Src2_Size as Integer) as Integer
Dim TS1Len as UInteger
Dim TS1Ptr as UByte Ptr
Dim TS2Len as UInteger
Dim TS2Ptr as UByte Ptr
_fb_FIXSTRING(V_Src1, V_Src1_Size, TS1Ptr, TS1Len)
_fb_FIXSTRING(V_Src2, V_Src2_Size, TS2Ptr, TS2Len)
If TS1Ptr = TS2Ptr Then Return 0
If (TS1Len or TS2Len) = 0 Then Return 0
If TS1Len <> TS2Len Then Return 1
Dim C as UInteger
Do
    If *TS1Ptr <> *TS2Ptr Then Return 1
    TS1Ptr += 1
    TS2Ptr += 1
Loop Until (*TS1Ptr = 0) and (*TS2Ptr = 0)
Return 0
End Function

'--------------------------------------------------------------------------------------------------------------------
Public Function _fb_StrInStr CDecL Alias "fb_StrInstr" (ByVal V_Start as Integer, ByRef V_Src as _FBString, ByRef V_Search as _FBString) as Integer
If V_Src.str_len < V_Start Then Return 0
If V_Search.str_len <= 0 Then Return 0
Dim TSPtr as Ubyte Ptr = V_Src.str_ptr
Dim TFPtr as Ubyte Ptr = V_Search.str_ptr
Dim Y as UInteger
For X as UInteger = V_Start To V_Src.str_len
    If *TSPtr = *TFPtr Then
        For Y = 1 to V_Search.str_len
            If X + Y - 1 > V_Src.str_len Then Return 0
            If *(TSPtr + Y) <> *(TFPtr + Y) Then Exit For
        Next
        If Y = V_Search.str_len Then Return X
    End If
    TSPtr += 1
Next
Return 0
End Function











#include once "rtlib_input.bi"