Permalink
Fetching contributors…
Cannot retrieve contributors at this time
238 lines (204 sloc) 8.71 KB
Attribute VB_Name = "libRed"
'=== LibRed imports ===
Private callBlkWord As Long
Private blkWord As Long
Public Enum RedTypes
red_value
red_datatype
red_unset
red_none
red_logic
red_block
red_paren
red_string
red_file
red_url
red_char
red_integer
red_float
red_symbol
red_context
red_word
red_set_word
red_lit_word
red_get_word
red_refinement
red_issue
red_native
red_action
red_op
red_function
red_path
red_lit_path
red_set_path
red_get_path
red_routine
red_bitset
red_point
red_object
red_typeset
red_error
red_vector
red_hash
red_pair
red_percent
red_tuple
red_map
red_binary
red_series
red_time
red_tag
red_email
red_image
red_event
red_date
End Enum
Public Enum RedEncodings
reUTF8 = 1
reUTF16
reVARIANT
End Enum
'--- Setup and terminate ---
Public Declare Sub redOpenReal Lib "libRed.dll" Alias "redOpen" ()
'--- Run Red code ---
Public Declare Function redDo Lib "libRed.dll" (ByRef source As Variant) As Long
Public Declare Function redDoFile Lib "libRed.dll" (ByRef file As Variant) As Long
Public Declare Function redDoBlock Lib "libRed.dll" (ByVal code As Long) As Long
'--- Expose a VB callback in Red ---
Public Declare Function redRoutine Lib "libRed.dll" (ByVal name As Long, ByRef desc As Variant, ByVal ptr As Long) As Long
'--- VB -> Red ---
Public Declare Function redSymbol Lib "libRed.dll" (ByRef word As Variant) As Long
Public Declare Function redUnset Lib "libRed.dll" () As Long
Public Declare Function redNone Lib "libRed.dll" () As Long
Public Declare Function redLogicReal Lib "libRed.dll" Alias "redLogic" (ByVal bool As Long) As Long
Public Declare Function redDatatype Lib "libRed.dll" (ByVal dtype As Long) As Long
Public Declare Function redInteger Lib "libRed.dll" (ByVal number As Long) As Long
Public Declare Function redFloat Lib "libRed.dll" (ByVal number As Double) As Long
Public Declare Function redPair Lib "libRed.dll" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Function redTuple Lib "libRed.dll" (ByVal r As Long, ByVal g As Long, ByVal b As Long) As Long
Public Declare Function redTuple4 Lib "libRed.dll" (ByVal r As Long, ByVal g As Long, ByVal b As Long, ByVal a As Long) As Long
Public Declare Function redString Lib "libRed.dll" (ByRef str As Variant) As Long
Public Declare Function redWord Lib "libRed.dll" (ByRef word As Variant) As Long
Public Declare Function redMakeSeries Lib "libRed.dll" (ByVal t As Long, ByVal size As Long) As Long
'--- Red -> VB ---
Public Declare Function redCInt32 Lib "libRed.dll" (ByVal value As Long) As Long
Public Declare Function redCDouble Lib "libRed.dll" (ByVal value As Long) As Double
Public Declare Function redTypeOf Lib "libRed.dll" (ByVal value As Long) As Long
Public Declare Sub redVString Lib "libRed.dll" (ByVal str As Long, ByRef varg As Variant)
'--- Red actions ---
Public Declare Function redAppend Lib "libRed.dll" (ByVal series As Long, ByVal value As Long) As Long
Public Declare Function redClear Lib "libRed.dll" (ByVal series As Long) As Long
Public Declare Function redCopy Lib "libRed.dll" (ByVal value As Long) As Long
Public Declare Function redFind Lib "libRed.dll" (ByVal series As Long, ByVal value As Long) As Long
Public Declare Function redIndex Lib "libRed.dll" (ByVal series As Long) As Long
Public Declare Function redLength Lib "libRed.dll" (ByVal series As Long) As Long
Public Declare Function redMake Lib "libRed.dll" (ByVal proto As Long, ByVal spec As Long) As Long
Public Declare Function redMold Lib "libRed.dll" (ByVal value As Long) As Long
Public Declare Function redPick Lib "libRed.dll" (ByVal series As Long, ByVal index As Long) As Long
Public Declare Function redPoke Lib "libRed.dll" (ByVal series As Long, ByVal index As Long, ByVal value As Long) As Long
Public Declare Function redPut Lib "libRed.dll" (ByVal series As Long, ByVal index As Long, ByVal value As Long) As Long
Public Declare Function redRemove Lib "libRed.dll" (ByVal series As Long) As Long
Public Declare Function redSelect Lib "libRed.dll" (ByVal series As Long, ByVal value As Long) As Long
Public Declare Function redSkip Lib "libRed.dll" (ByVal series As Long, ByVal offset As Long) As Long
Public Declare Function redTo Lib "libRed.dll" (ByVal proto As Long, ByVal spec As Long) As Long
'--- Access to a Red global word ---
Public Declare Function redSet Lib "libRed.dll" (ByVal id As Long, ByVal value As Long) As Long
Public Declare Function redGet Lib "libRed.dll" (ByVal id As Long) As Long
'--- Access to a Red path ---
Public Declare Function redSetPath Lib "libRed.dll" (ByVal path As Long, ByVal value As Long) As Long
Public Declare Function redGetPath Lib "libRed.dll" (ByVal path As Long) As Long
'--- Access to a Red object/map/struct field ---
Public Declare Function redSetField Lib "libRed.dll" (ByVal obj As Long, ByVal field as Long, ByVal value As Long) As Long
Public Declare Function redGetField Lib "libRed.dll" (ByVal obj As Long, ByVal field as Long) As Long
'--- libRed settings ---
Public Declare Sub redSetEncoding Lib "libRed.dll" (ByVal encIn As Long, ByVal encOut As Long)
'--- Debugging purpose ---
Public Declare Function redPrint Lib "libRed.dll" (ByVal value As Long)
Public Declare Function redProbe Lib "libRed.dll" (ByVal value As Long) As Long
Public Declare Function redHasError Lib "libRed.dll" () As Long
Public Declare Function redOpenLogWindow Lib "libRed.dll" () As Long
Public Declare Function redCloseLogWindow Lib "libRed.dll" () As Long
Public Declare Sub redOpenLogFile Lib "libRed.dll" (ByVal name As String)
Public Declare Sub redCloseLogFile Lib "libRed.dll" ()
'--- libRed VB-specific wrappers ---
Public Sub redOpen()
redOpenReal
redSetEncoding reVARIANT, reVARIANT
callBlkWord = redSymbol("VBCallBlk")
redSet callBlkWord, redMakeSeries(red_block, 10)
blkWord = redSymbol("blk")
End Sub
Public Function redCString(str As Long)
Dim var
var = ""
redVString str, var
redCString = var
End Function
Public Sub redClose()
'Do nothing for now
End Sub
Public Function redLogic(bool As Boolean) As Long
redLogic = redLogicReal(IIf(bool, 1, 0))
End Function
Private Sub redAppendBlockValue(blk As Long, value As Variant, asWord As Boolean)
Select Case VarType(value)
Case vbInteger, vbLong: redAppend redGet(blk), redInteger(CLng(value))
Case vbSingle, vbDouble: redAppend redGet(blk), redFloat(CDbl(value))
Case vbString: redAppend redGet(blk), IIf(asWord, redWord(CVar(value)), redString(CVar(value)))
Case Else: MsgBox "redAppendBlockValue: Unsupported type"
End Select
End Sub
Public Function redBlock(ParamArray args() As Variant) As Long
Dim i As Long
Dim blk As Long
blk = blkWord
redSet blk, redMakeSeries(red_block, UBound(args) - LBound(args) + 1)
For i = LBound(args) To UBound(args): redAppend redGet(blk), args(i): Next i
redBlock = redGet(blk)
End Function
Public Function redPath(ParamArray args() As Variant) As Long
Dim i As Long
Dim blk As Long
blk = blkWord
redSet blk, redMakeSeries(red_path, UBound(args) - LBound(args) + 1)
For i = LBound(args) To UBound(args): redAppend redGet(blk), args(i), True: Next i
redPath = redGet(blk)
End Function
Public Function redCall(ParamArray args() As Variant) As Long
Dim i As Long
Dim blk As Long
blk = callBlkWord
redClear redGet(blk)
redAppend redGet(blk), args(0)
For i = LBound(args) + 1 To UBound(args): redAppend redGet(blk), args(i), False: Next i
redCall = redDoBlock(redGet(blk))
End Function
Public Function redBlockVB(ParamArray args() As Variant) As Long
Dim i As Long
Dim blk As Long
blk = blkWord
redSet blk, redMakeSeries(red_block, UBound(args) - LBound(args) + 1)
For i = LBound(args) To UBound(args): redAppendBlockValue blk, args(i), False: Next i
redBlockVB = redGet(blk)
End Function
Public Function redPathVB(ParamArray args() As Variant) As Long
Dim i As Long
Dim blk As Long
blk = blkWord
redSet blk, redMakeSeries(red_path, UBound(args) - LBound(args) + 1)
For i = LBound(args) To UBound(args): redAppendBlockValue blk, args(i), True: Next i
redPathVB = redGet(blk)
End Function
Public Function redCallVB(ParamArray args() As Variant) As Long
Dim i As Long
Dim blk As Long
If VarType(args(0)) <> vbString Then
MsgBox "Error in redCallVB(), first argument must be a string"
redCallVB = redUnset
End If
blk = callBlkWord
redClear redGet(blk)
redAppend redGet(blk), redWord(CVar(args(0)))
For i = LBound(args) + 1 To UBound(args): redAppendBlockValue blk, args(i), False: Next i
redCallVB = redDoBlock(redGet(blk))
End Function