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