# evaluator.tcl -- # # Implements the statement and match datatypes, the singleton # reactive/graph database of statements and matches, and the core # log-reducing evaluator for Folk. # namespace eval statement { # A statement contains a clause (a Tcl list which is the actual # 'words'/terms that constitute the statement, like [list the time # is 3:00]) and a resizable list of edges, which are handles of # matches (which are the parents and children of the statement). # A match contains a resizable list of edges, which are handles of # statements (which are the parents and children of the match). variable cc [c create] namespace export $cc $cc include $cc include $cc include # Rather than being heap-allocated, statements and matches are # allocated out of memory pools (later in this file) that have a # generational indexing scheme. # # Therefore, instead of pointing to a statement or match with a # raw pointer, you point to these objects with handles that # consist of a slot index and a slot generation. $cc code { typedef struct statement_handle_t { int32_t idx; int32_t gen; } statement_handle_t; typedef struct match_handle_t { int32_t idx; int32_t gen; } match_handle_t; } $cc rtype statement_handle_t { $robj = Tcl_ObjPrintf("s%d:%d", $rvalue.idx, $rvalue.gen); } $cc argtype statement_handle_t { statement_handle_t $argname; sscanf(Tcl_GetString($obj), "s%d:%d", &$argname.idx, &$argname.gen); } $cc rtype match_handle_t { $robj = Tcl_ObjPrintf("m%d:%d", $rvalue.idx, $rvalue.gen); } $cc argtype match_handle_t { match_handle_t $argname; sscanf(Tcl_GetString($obj), "m%d:%d", &$argname.idx, &$argname.gen); } $cc enum edge_type_t { EMPTY, PARENT, CHILD } $cc struct edge_to_statement_t { edge_type_t type; statement_handle_t statement; } $cc struct match_destructor_t { Tcl_Obj* body; Tcl_Obj* env; } $cc struct match_t { int32_t gen; bool alive; bool isFromCollect; statement_handle_t collectId; match_destructor_t destructors[8]; size_t capacity_edges; size_t n_edges; // This is an estimate. edge_to_statement_t* edges; // Allocated separately so it can be resized. } $cc struct edge_to_match_t { edge_type_t type; match_handle_t match; } $cc struct statement_t { int32_t gen; Tcl_Obj* clause; bool collectNeedsRecollect; // Dirty flag size_t capacity_edges; size_t n_edges; // This is an estimate. edge_to_match_t* edges; // Allocated separately so it can be resized. } $cc include $cc code { // Creates a new statement struct (that the caller will // probably want to put into the statement DB). statement_t statementCreate(Tcl_Obj* clause, size_t n_parents, match_handle_t parents[], size_t n_children, match_handle_t children[]) { statement_t ret; ret.clause = clause; Tcl_IncrRefCount(clause); ret.capacity_edges = (n_parents + n_children) * 2; if (ret.capacity_edges < 8) { ret.capacity_edges = 8; } // FIXME: Use edge helpers. ret.n_edges = 0; ret.edges = (edge_to_match_t *)ckalloc(sizeof(edge_to_match_t) * ret.capacity_edges); for (size_t i = 0; i < n_parents; i++) { ret.edges[ret.n_edges++] = (edge_to_match_t) { .type = PARENT, .match = parents[i] }; } for (size_t i = 0; i < n_children; i++) { ret.edges[ret.n_edges++] = (edge_to_match_t) { .type = CHILD, .match = children[i] }; } return ret; } bool matchHandleIsEqual(match_handle_t a, match_handle_t b) { return a.idx == b.idx && a.gen == b.gen; } bool statementHandleIsEqual(statement_handle_t a, statement_handle_t b) { return a.idx == b.idx && a.gen == b.gen; } static edge_to_match_t* statementEdgeAt(statement_t* stmt, size_t i) { assert(i < stmt->n_edges); assert(stmt->n_edges <= stmt->capacity_edges); assert(i < stmt->capacity_edges); return &stmt->edges[i]; } // Given stmt, moves all non-EMPTY edges to the front of the // statement's edgelist, then updates stmt->n_edges // accordingly. // // Defragmentation is necessary to prevent continual growth of // the statement edgelist if you keep adding and removing // edges on the same statement. static void statementDefragmentEdges(statement_t* stmt) { // Copy all non-EMPTY edges into a new edgelist. size_t n_edges = 0; edge_to_match_t* edges = (edge_to_match_t *)ckalloc(stmt->capacity_edges * sizeof(edge_to_match_t)); memset(edges, 0, stmt->capacity_edges * sizeof(edge_to_match_t)); for (size_t i = 0; i < stmt->n_edges; i++) { edge_to_match_t* edge = statementEdgeAt(stmt, i); if (edge->type != EMPTY) { edges[n_edges++] = *edge; } } stmt->n_edges = n_edges; ckfree((char *)stmt->edges); stmt->edges = edges; } static void matchDefragmentEdges(match_t* match) { // Copy all non-EMPTY edges into a new edgelist. size_t n_edges = 0; edge_to_statement_t* edges = (edge_to_statement_t *)ckalloc(match->capacity_edges * sizeof(edge_to_statement_t)); memset(edges, 0, match->capacity_edges * sizeof(edge_to_statement_t)); for (size_t i = 0; i < match->n_edges; i++) { edge_to_statement_t* edge = &match->edges[i]; if (edge->type != EMPTY) { edges[n_edges++] = *edge; } } match->n_edges = n_edges; ckfree((char *)match->edges); match->edges = edges; } } namespace export clause parentMatchIds childMatchIds $cc proc clause {Tcl_Obj* stmtobj} Tcl_Obj* { assert(stmtobj->typePtr == &statement_t_ObjType); return ((statement_t *)stmtobj->internalRep.ptrAndLongRep.ptr)->clause; } $cc proc edges {Tcl_Interp* interp Tcl_Obj* stmtobj} Tcl_Obj* { assert(stmtobj->typePtr == &statement_t_ObjType); statement_t* stmt = stmtobj->internalRep.ptrAndLongRep.ptr; Tcl_Obj* ret = Tcl_NewListObj(stmt->n_edges, NULL); for (size_t i = 0; i < stmt->n_edges; i++) { edge_to_match_t* edge = statementEdgeAt(stmt, i); Tcl_Obj* edgeobj = Tcl_NewObj(); edgeobj->typePtr = &edge_to_match_t_ObjType; edgeobj->bytes = NULL; edgeobj->internalRep.ptrAndLongRep.ptr = edge; edgeobj->internalRep.ptrAndLongRep.value = 0; Tcl_ListObjAppendElement(interp, ret, edgeobj); } return ret; } proc parentMatchIds {stmt} { concat {*}[lmap edge [edges $stmt] {expr { [dict get $edge type] == 1 ? [list [dict get $edge match] true] : [continue] }}] } proc childMatchIds {stmt} { concat {*}[lmap edge [edges $stmt] {expr { [dict get $edge type] == 2 ? [list [dict get $edge match] true] : [continue] }}] } namespace ensemble create namespace export short proc short {stmt} { set lines [split [clause $stmt] "\n"] set line [lindex $lines 0] if {[string length $line] > 80} {set line "[string range $line 0 80]..."} format "{%s} %s {%s}" [parentMatchIds $stmt] $line [childMatchIds $stmt] } variable negations [list nobody nothing] variable blanks [list someone something anyone anything] # Splits a pattern by & into subpatterns, like # # `/thing/ is red & /thing/ is cool` -> # `/thing/ is red`, # `/thing/ is cool` # # Each subpattern in the out array is a new heap-allocated Tcl_Obj # and should be freed by the caller. $cc proc splitPattern {Tcl_Obj* pattern int maxSubpatternsCount Tcl_Obj** outSubpatterns} int { int patternLength; Tcl_Obj** patternWords; Tcl_ListObjGetElements(NULL, pattern, &patternLength, &patternWords); int subpatternLength = 0; int subpatternsCount = 0; for (int i = 0; i <= patternLength; i++) { if (i == patternLength || strcmp(Tcl_GetString(patternWords[i]), "&") == 0) { Tcl_Obj* subpattern = Tcl_NewListObj(subpatternLength, &patternWords[i - subpatternLength]); outSubpatterns[subpatternsCount++] = subpattern; subpatternLength = 0; } else { subpatternLength++; } } return subpatternsCount; } # Converts a pattern from base form like `the time is /t/` to # claimized form, `/someone/ claims the time is /t/`. Returns NULL # if the pattern already has a verb like `claims` or `wishes` in # second position and shouldn't be claimized. The returned pattern # is a new heap-allocated Tcl_Obj and should be freed by the # caller. $cc proc claimizePattern {Tcl_Obj* pattern} Tcl_Obj* { static Tcl_Obj* someoneClaims[2] = {0}; if (someoneClaims[0] == NULL) { someoneClaims[0] = Tcl_NewStringObj("/someone/", -1); someoneClaims[1] = Tcl_NewStringObj("claims", -1); Tcl_IncrRefCount(someoneClaims[0]); Tcl_IncrRefCount(someoneClaims[1]); } Tcl_Obj* secondWord; if (Tcl_ListObjIndex(NULL, pattern, 1, &secondWord) == TCL_OK) { if (secondWord != NULL && (strcmp(Tcl_GetString(secondWord), "claims") == 0 || strcmp(Tcl_GetString(secondWord), "wishes") == 0)) { return NULL; } } // the time is /t/ -> /someone/ claims the time is /t/ Tcl_Obj* ret = Tcl_DuplicateObj(pattern); Tcl_ListObjReplace(NULL, ret, 0, 0, 2, someoneClaims); return ret; } } namespace eval Statements { ;# singleton Statement store variable cc $::statement::cc namespace import ::statement::$cc $cc code [csubst { typedef struct trie trie_t; statement_t statements[32768]; uint16_t nextStatementIdx = 1; trie_t* statementClauseToId; match_t matches[32768]; uint16_t nextMatchIdx = 1; }] $cc proc statementClauseToIdTrie {} trie_t* { return statementClauseToId; } $cc proc matchNew {} match_handle_t { uint16_t origNextMatchIdx = nextMatchIdx; while (matches[nextMatchIdx].alive) { nextMatchIdx = (nextMatchIdx + 1) % (sizeof(matches)/sizeof(matches[0])); if (nextMatchIdx == origNextMatchIdx) { fprintf(stderr, "Ran out of space for new match\n"); exit(1); } } matches[nextMatchIdx].capacity_edges = 16; matches[nextMatchIdx].edges = (edge_to_statement_t*)ckalloc(16 * sizeof(edge_to_statement_t)); matches[nextMatchIdx].isFromCollect = false; matches[nextMatchIdx].alive = true; return (match_handle_t) { .idx = nextMatchIdx, .gen = matches[nextMatchIdx].gen }; } $cc proc matchGet {match_handle_t matchId} match_t* { if (matchId.gen != matches[matchId.idx].gen || !matches[matchId.idx].alive) { return NULL; } return &matches[matchId.idx]; } $cc proc matchEdges {Tcl_Interp* interp match_handle_t matchId} Tcl_Obj* { match_t* match = matchGet(matchId); Tcl_Obj* ret = Tcl_NewListObj(match->n_edges, NULL); for (size_t i = 0; i < match->n_edges; i++) { edge_to_statement_t* edge = &match->edges[i]; Tcl_Obj* edgeobj = Tcl_NewObj(); edgeobj->typePtr = &edge_to_statement_t_ObjType; edgeobj->bytes = NULL; edgeobj->internalRep.ptrAndLongRep.ptr = edge; edgeobj->internalRep.ptrAndLongRep.value = 0; Tcl_ListObjAppendElement(interp, ret, edgeobj); } return ret; } $cc proc matchRemove {match_handle_t matchId} void { match_t* match = matchGet(matchId); for (int i = 0; i < sizeof(match->destructors)/sizeof(match->destructors[0]); i++) { if (match->destructors[i].body != NULL) { Tcl_DecrRefCount(match->destructors[i].body); Tcl_DecrRefCount(match->destructors[i].env); match->destructors[i].body = NULL; match->destructors[i].env = NULL; } } match->alive = false; match->gen++; match->n_edges = 0; ckfree((char*)match->edges); } $cc proc matchExists {match_handle_t matchId} bool { match_t* match = matchGet(matchId); return match != NULL && match->alive; } $cc proc matchAddDestructor {match_handle_t matchId Tcl_Obj* body Tcl_Obj* env} void { match_t* match = matchGet(matchId); for (int i = 0; i < sizeof(match->destructors)/sizeof(match->destructors[0]); i++) { if (match->destructors[i].body == NULL) { match->destructors[i].body = body; match->destructors[i].env = env; Tcl_IncrRefCount(body); Tcl_IncrRefCount(env); return; } } exit(10); } $cc proc new {} statement_handle_t { while (statements[nextStatementIdx].clause != NULL) { nextStatementIdx = (nextStatementIdx + 1) % (sizeof(statements)/sizeof(statements[0])); } return (statement_handle_t) { .idx = nextStatementIdx, .gen = statements[nextStatementIdx].gen }; } $cc proc get {statement_handle_t id} statement_t* { if (id.gen != statements[id.idx].gen || statements[id.idx].clause == NULL) { return NULL; } return &statements[id.idx]; } $cc proc deref {statement_t* ptr} statement_t { return *ptr; } $cc proc exists {statement_handle_t id} int { return get(id) != NULL; } $cc proc remove_ {statement_handle_t id} void { statement_t* stmt = get(id); int32_t gen = stmt->gen; Tcl_Obj* clause = stmt->clause; ckfree((char *)stmt->edges); memset(stmt, 0, sizeof(*stmt)); trieRemove(NULL, statementClauseToId, clause); Tcl_DecrRefCount(clause); stmt->gen = gen; stmt->gen++; } $cc proc size {} size_t { size_t size = 0; for (int i = 0; i < sizeof(statements)/sizeof(statements[0]); i++) { if (statements[i].clause != NULL) { size++; } } return size; } $cc import ::ctrie::cc create as trieCreate $cc import ::ctrie::cc lookup as trieLookup $cc import ::ctrie::cc lookupLiteral as trieLookupLiteral $cc import ::ctrie::cc add as trieAdd $cc import ::ctrie::cc remove_ as trieRemove $cc import ::ctrie::cc scanVariable as scanVariable $cc proc StatementsInit {} void { statementClauseToId = trieCreate(); } $cc proc addMatchImpl {size_t n_parents statement_handle_t parents[]} match_handle_t { match_handle_t matchId = matchNew(); for (int i = 0; i < n_parents; i++) { matchAddEdgeToStatement(matchId, PARENT, parents[i]); statementAddEdgeToMatch(parents[i], CHILD, matchId); } return matchId; } proc addMatch {parentMatchIds} { addMatchImpl [llength $parentMatchIds] $parentMatchIds } $cc proc addImpl {Tcl_Interp* interp Tcl_Obj* clause size_t n_parents match_handle_t parents[] statement_handle_t* outStatement bool* outIsNewStatement} void { // Is this clause already present among the existing statements? uint64_t ids[10]; int idslen = trieLookupLiteral(interp, ids, 10, statementClauseToId, clause); statement_handle_t id; if (idslen == 1) { id = *(statement_handle_t *)&ids[0]; } else if (idslen == 0) { id.idx = -1; } else { // error WTF printf("WTF: looked up %s\n", Tcl_GetString(clause)); exit(1); } bool isNewStatement = (id.idx == -1); if (isNewStatement) { id = new(); // Unguarded access to statement because it's still uncreated at this point. statements[id.idx] = statementCreate(clause, n_parents, parents, 0, NULL); statements[id.idx].gen = id.gen; trieAdd(interp, &statementClauseToId, clause, *(uint64_t*)&id); } else { for (size_t i = 0; i < n_parents; i++) { statementAddEdgeToMatch(id, PARENT, parents[i]); } } for (size_t i = 0; i < n_parents; i++) { if (parents[i].idx == -1) { continue; } // ? matchAddEdgeToStatement(parents[i], CHILD, id); } *outStatement = id; *outIsNewStatement = isNewStatement; } proc add {clause {parents {{idx -1} true}}} { addImpl $clause [dict size $parents] [dict keys $parents] } $cc code { static statement_t* get(statement_handle_t id); void statementRealloc(statement_handle_t id) { statement_t* stmt = get(id); assert(stmt != NULL); stmt->edges = (edge_to_match_t *)ckrealloc((char *)stmt->edges, stmt->capacity_edges*sizeof(edge_to_match_t)); } void statementAddEdgeToMatch(statement_handle_t statementId, edge_type_t type, match_handle_t matchId) { statement_t* stmt = get(statementId); if (stmt->n_edges == stmt->capacity_edges) { // We've run out of edge slots at the end of the // statement. Try defragmenting the statement. statementDefragmentEdges(stmt); if (stmt->n_edges == stmt->capacity_edges) { // Still no slots? Grow the statement to // accommodate. stmt->capacity_edges = stmt->capacity_edges * 2; statementRealloc(statementId); } } assert(stmt->n_edges < stmt->capacity_edges); // There's a free slot at the end of the edgelist in // the statement. Use it. stmt->edges[stmt->n_edges++] = (edge_to_match_t) { .type = type, .match = matchId }; } int statementRemoveEdgeToMatch(statement_handle_t statementId, edge_type_t type, match_handle_t matchId) { statement_t* stmt = get(statementId); assert(stmt != NULL); int parentEdges = 0; for (size_t i = 0; i < stmt->n_edges; i++) { edge_to_match_t* edge = statementEdgeAt(stmt, i); if (edge->type == type && matchHandleIsEqual(edge->match, matchId)) { edge->type = EMPTY; edge->match = (match_handle_t) {0}; } if (edge->type == PARENT) { parentEdges++; } } return parentEdges; } static match_t* matchGet(match_handle_t id); void matchRealloc(match_handle_t id) { match_t* match = matchGet(id); assert(match != NULL); match->edges = (edge_to_statement_t *)ckrealloc((char *)match->edges, match->capacity_edges*sizeof(edge_to_statement_t)); } void matchAddEdgeToStatement(match_handle_t matchId, edge_type_t type, statement_handle_t statementId) { match_t* match = matchGet(matchId); if (match->n_edges == match->capacity_edges) { // We've run out of edge slots at the end of the // match. Try defragmenting the match. matchDefragmentEdges(match); if (match->n_edges == match->capacity_edges) { // Still no slots? Grow the match to accommodate. match->capacity_edges = match->capacity_edges * 2; matchRealloc(matchId); } } assert(match->n_edges < match->capacity_edges); match->edges[match->n_edges++] = (edge_to_statement_t) { .type = type, .statement = statementId }; } void matchRemoveEdgeToStatement(match_handle_t matchId, edge_type_t type, statement_handle_t statementId) { match_t* match = matchGet(matchId); assert(match != NULL); for (size_t i = 0; i < match->n_edges; i++) { edge_to_statement_t* edge = &match->edges[i]; if (edge->type == type && statementHandleIsEqual(edge->statement, statementId)) { edge->type = EMPTY; edge->statement = (statement_handle_t) {0}; } } // TODO: compact } } $cc struct environment_binding_t { char name[100]; Tcl_Obj* value; } $cc struct environment_t { // This environment corresponds to a single concrete match. // One statement ID for each pattern in the join. int matchedStatementIdsCount; statement_handle_t matchedStatementIds[10]; int bindingsCount; environment_binding_t bindings[1]; } $cc code { Tcl_Obj* environmentLookup(environment_t* env, const char* varName) { for (int i = 0; i < env->bindingsCount; i++) { if (strcmp(env->bindings[i].name, varName) == 0) { return env->bindings[i].value; } } return NULL; } Tcl_Obj* environmentToTclDict(environment_t* env) { Tcl_Obj* ret = Tcl_NewDictObj(); for (int i = 0; i < env->bindingsCount; i++) { Tcl_DictObjPut(NULL, ret, Tcl_NewStringObj(env->bindings[i].name, -1), env->bindings[i].value); } return ret; } } # unify allocates a new environment. $cc proc isBlank {char* varName} bool [subst { [join [lmap blank $statement::blanks {subst { if (strcmp(varName, "$blank") == 0) { return true; } }}] "\n"] return false; }] $cc proc unify {Tcl_Obj* a Tcl_Obj* b} environment_t* { int alen; Tcl_Obj** awords; int blen; Tcl_Obj** bwords; Tcl_ListObjGetElements(NULL, a, &alen, &awords); Tcl_ListObjGetElements(NULL, b, &blen, &bwords); environment_t* env = (environment_t*)ckalloc(sizeof(environment_t) + sizeof(environment_binding_t)*alen); memset(env, 0, sizeof(*env)); for (int i = 0; i < alen; i++) { char aVarName[100] = {0}; char bVarName[100] = {0}; if (scanVariable(awords[i], aVarName, sizeof(aVarName))) { if (aVarName[0] == '.' && aVarName[1] == '.' && aVarName[2] == '.') { environment_binding_t* binding = &env->bindings[env->bindingsCount++]; memcpy(binding->name, aVarName + 3, sizeof(binding->name) - 3); binding->value = Tcl_NewListObj(blen - i, &bwords[i]); } else if (!isBlank(aVarName)) { environment_binding_t* binding = &env->bindings[env->bindingsCount++]; memcpy(binding->name, aVarName, sizeof(binding->name)); binding->value = bwords[i]; } } else if (scanVariable(bwords[i], bVarName, sizeof(bVarName))) { if (bVarName[0] == '.' && bVarName[1] == '.' && bVarName[2] == '.') { environment_binding_t* binding = &env->bindings[env->bindingsCount++]; memcpy(binding->name, bVarName + 3, sizeof(binding->name) - 3); binding->value = Tcl_NewListObj(alen - i, &awords[i]); } else if (!isBlank(bVarName)) { environment_binding_t* binding = &env->bindings[env->bindingsCount++]; memcpy(binding->name, bVarName, sizeof(binding->name)); binding->value = awords[i]; } } else if (!(awords[i] == bwords[i] || strcmp(Tcl_GetString(awords[i]), Tcl_GetString(bwords[i])) == 0)) { ckfree((char *)env); fprintf(stderr, "unification wrt (%s) (%s) failed\n", Tcl_GetString(a), Tcl_GetString(b)); return NULL; } } return env; } $cc proc searchByPattern {Tcl_Obj* pattern int maxResultsCount environment_t** outResults} int { uint64_t ids[maxResultsCount]; int idsCount = trieLookup(NULL, ids, maxResultsCount, statementClauseToId, pattern); int resultsCount = 0; for (int i = 0; i < idsCount; i++) { statement_handle_t id = *(statement_handle_t *)&ids[i]; environment_t* result = unify(pattern, get(id)->clause); if (result != NULL) { result->matchedStatementIdsCount = 1; result->matchedStatementIds[0] = id; outResults[resultsCount++] = result; } } return resultsCount; } $cc proc findMatches {Tcl_Obj* pattern} Tcl_Obj* { Tcl_Obj* ret = Tcl_NewListObj(0, NULL); environment_t* results[1000]; int resultsCount = searchByPattern(pattern, 1000, results); for (int i = 0; i < resultsCount; i++) { Tcl_Obj* matchObj = environmentToTclDict(results[i]); statement_handle_t id = results[i]->matchedStatementIds[0]; Tcl_DictObjPut(NULL, matchObj, Tcl_ObjPrintf("__matcheeIds"), Tcl_ObjPrintf("{s%d:%d}", id.idx, id.gen)); Tcl_ListObjAppendElement(NULL, ret, matchObj); ckfree((char *)results[i]); } return ret; } $cc proc count {Tcl_Obj* pattern} int { environment_t* outResults[1000]; return searchByPattern(pattern, 1000, outResults); } $cc proc searchByPatterns {int patternsCount Tcl_Obj* patterns[] environment_t* env int maxResultsCount environment_t** outResults int* outResultsCount} void { // Do substitution of bindings into first pattern Tcl_Obj* substitutedFirstPattern = Tcl_DuplicateObj(patterns[0]); int wordCount; Tcl_Obj** words; Tcl_ListObjGetElements(NULL, substitutedFirstPattern, &wordCount, &words); for (int i = 0; i < wordCount; i++) { char varName[100]; Tcl_Obj* boundValue = NULL; if (scanVariable(words[i], varName, sizeof(varName)) && env != NULL && (boundValue = environmentLookup(env, varName))) { Tcl_ListObjReplace(NULL, substitutedFirstPattern, i, 1, 1, &boundValue); } } environment_t* resultsForFirstPattern[maxResultsCount]; int resultsForFirstPatternCount = searchByPattern(substitutedFirstPattern, maxResultsCount, resultsForFirstPattern); Tcl_Obj* claimizedSubstitutedFirstPattern = claimizePattern(substitutedFirstPattern); Tcl_DecrRefCount(substitutedFirstPattern); if (claimizedSubstitutedFirstPattern != NULL) { resultsForFirstPatternCount += searchByPattern(claimizedSubstitutedFirstPattern, maxResultsCount - resultsForFirstPatternCount, &resultsForFirstPattern[resultsForFirstPatternCount]); Tcl_DecrRefCount(claimizedSubstitutedFirstPattern); } for (int i = 0; i < resultsForFirstPatternCount; i++) { environment_t* result = resultsForFirstPattern[i]; if (env != NULL) { memcpy(&result->matchedStatementIds[result->matchedStatementIdsCount], &env->matchedStatementIds[0], sizeof(env->matchedStatementIds[0])*env->matchedStatementIdsCount); result->matchedStatementIdsCount += env->matchedStatementIdsCount; memcpy(&result->bindings[result->bindingsCount], &env->bindings[0], sizeof(env->bindings[0])*env->bindingsCount); result->bindingsCount += env->bindingsCount; } if (patternsCount - 1 == 0) { outResults[(*outResultsCount)++] = result; } else { searchByPatterns(patternsCount - 1, &patterns[1], result, maxResultsCount - 1, outResults, outResultsCount); ckfree((char *)result); } } } $cc proc findMatchesJoining {Tcl_Obj* patterns Tcl_Obj* bindings} Tcl_Obj* { environment_t* results[1000]; int patternsCount; Tcl_Obj** patternsObjs; Tcl_ListObjGetElements(NULL, patterns, &patternsCount, &patternsObjs); int resultsCount = 0; environment_t* env = (environment_t*)ckalloc(sizeof(environment_t) + 10*sizeof(environment_binding_t)); memset(env, 0, sizeof(*env)); Tcl_DictSearch search; Tcl_Obj *key, *value; int done; if (Tcl_DictObjFirst(NULL, bindings, &search, &key, &value, &done) != TCL_OK) { exit(2); } for (; !done ; Tcl_DictObjNext(&search, &key, &value, &done)) { environment_binding_t* b = &env->bindings[env->bindingsCount++]; int nameLen; char* namePtr = Tcl_GetStringFromObj(key, &nameLen); memcpy(b->name, namePtr, nameLen); b->value = value; } Tcl_DictObjDone(&search); searchByPatterns(patternsCount, patternsObjs, env, 1000, results, &resultsCount); ckfree((char *)env); Tcl_Obj* ret = Tcl_NewListObj(0, NULL); for (int i = 0; i < resultsCount; i++) { // TODO: Emit __matcheeIds properly based on results[i] Tcl_ListObjAppendElement(NULL, ret, environmentToTclDict(results[i])); ckfree((char *)results[i]); } return ret; } $cc proc all {} Tcl_Obj* { Tcl_Obj* ret = Tcl_NewListObj(0, NULL); for (int i = 0; i < sizeof(statements)/sizeof(statements[0]); i++) { if (statements[i].clause == NULL) continue; Tcl_Obj* s = Tcl_NewObj(); s->bytes = NULL; s->typePtr = &statement_t_ObjType; s->internalRep.ptrAndLongRep.ptr = &statements[i]; s->internalRep.ptrAndLongRep.value = 0; Tcl_ListObjAppendElement(NULL, ret, Tcl_ObjPrintf("s%d:%d", i, statements[i].gen)); Tcl_ListObjAppendElement(NULL, ret, s); } return ret; } proc dot {} { set dot [list] dict for {id stmt} [all] { lappend dot "subgraph {" lappend dot "color=lightgray;" set label [statement clause $stmt] set label [join [lmap line [split $label "\n"] { expr { [string length $line] > 80 ? "[string range $line 0 80]..." : $line } }] "\n"] set label [string map {"\"" "\\\""} [string map {"\\" "\\\\"} $label]] lappend dot "<$id> \[label=\"$id: $label\"\];" dict for {matchId _} [statement parentMatchIds $stmt] { set parents [lmap edge [matchEdges $matchId] {expr { [dict get $edge type] == 1 ? "[dict get $edge statement]" : [continue] }}] lappend dot "<$matchId> \[label=\"$matchId <- $parents\"\];" lappend dot "<$matchId> -> <$id>;" } lappend dot "}" dict for {childMatchId _} [statement childMatchIds $stmt] { lappend dot "<$id> -> <$childMatchId>;" } } return "digraph { rankdir=LR; [join $dot "\n"] }" } proc saveDotToPdf {filename} { exec dot -Tpdf >$filename <<[Statements::dot] } proc print {} { dict for {id stmt} [Statements::all] { puts [statement short $stmt] } } # these are kind of arbitrary/temporary bridge $cc proc matchRemoveFirstDestructor {match_handle_t matchId} void { Tcl_DecrRefCount(matchGet(matchId)->destructors[0].body); Tcl_DecrRefCount(matchGet(matchId)->destructors[0].env); matchGet(matchId)->destructors[0].body = NULL; matchGet(matchId)->destructors[0].env = NULL; } } namespace eval Evaluator { variable cc $::statement::cc namespace import ::statement::$cc $cc code { #include char operationLog[10000][1000]; int operationLogIdx = 0; void op(const char *format, ...) { if (operationLogIdx >= 10000) return; va_list args; va_start(args, format); // vprintf(format, args); printf("\n"); vsnprintf(operationLog[operationLogIdx++], 1000, format, args); va_end(args); } } $cc proc getOperationLog {} Tcl_Obj* { Tcl_Obj* entries[10000]; int i; for (i = 0; i < 10000 && operationLog[i][0] != '\0'; i++) { entries[i] = Tcl_NewStringObj(operationLog[i], -1); } return Tcl_NewListObj(i, entries); } $cc code { // Given a StatementPattern, tells you all the reactions to run // when a matching statement is added to / removed from the // database. StatementId is the ID of the statement that wanted to // react. // // For example, if you add `When the time is /t/`, it will register // a reaction to the addition and removal of statements matching // the pattern `the time is /t/`. // // Trie trie_t* reactionsToStatementAddition; // Used to quickly remove reactions when the reacting statement is removed: // Dict> Tcl_Obj* reactionPatternsOfReactingId[32768]; typedef void (*reaction_fn_t)(Tcl_Interp* interp, statement_handle_t reactingId, Tcl_Obj* reactToPattern, statement_handle_t newStatementId); typedef struct reaction_t { reaction_fn_t react; statement_handle_t reactingId; Tcl_Obj* reactToPattern; } reaction_t; void addReaction(Tcl_Obj* reactToPattern, statement_handle_t reactingId, reaction_fn_t react) { reaction_t *reaction = (reaction_t*)ckalloc(sizeof(reaction_t)); reaction->react = react; reaction->reactingId = reactingId; Tcl_IncrRefCount(reactToPattern); reaction->reactToPattern = reactToPattern; Tcl_Obj* reactToPatternAndReactingId = Tcl_DuplicateObj(reactToPattern); Tcl_Obj* reactingIdObj = Tcl_NewIntObj(reactingId.idx); int reactToPatternLength; Tcl_ListObjLength(NULL, reactToPattern, &reactToPatternLength); Tcl_ListObjReplace(NULL, reactToPatternAndReactingId, reactToPatternLength, 0, 1, &reactingIdObj); trieAdd(NULL, &reactionsToStatementAddition, reactToPatternAndReactingId, (uintptr_t)reaction); if (reactionPatternsOfReactingId[reactingId.idx] == NULL) { reactionPatternsOfReactingId[reactingId.idx] = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(reactionPatternsOfReactingId[reactingId.idx]); } Tcl_ListObjAppendElement(NULL, reactionPatternsOfReactingId[reactingId.idx], reactToPatternAndReactingId); } void removeAllReactions(statement_handle_t reactingId) { if (reactionPatternsOfReactingId[reactingId.idx] == NULL) { return; } int patternCount; Tcl_Obj** patterns; Tcl_ListObjGetElements(NULL, reactionPatternsOfReactingId[reactingId.idx], &patternCount, &patterns); for (int i = 0; i < patternCount; i++) { uint64_t reactionPtrs[1000]; int reactionsCount = trieLookupLiteral(NULL, reactionPtrs, 1000, reactionsToStatementAddition, patterns[i]); for (int j = 0; j < reactionsCount; j++) { reaction_t* reaction = (reaction_t*)(uintptr_t) reactionPtrs[j]; Tcl_DecrRefCount(reaction->reactToPattern); ckfree((char *)reaction); } trieRemove(NULL, reactionsToStatementAddition, patterns[i]); } Tcl_DecrRefCount(reactionPatternsOfReactingId[reactingId.idx]); reactionPatternsOfReactingId[reactingId.idx] = NULL; } void tryRunInSerializedEnvironment(Tcl_Interp* interp, Tcl_Obj* lambda, Tcl_Obj* env) { int objc = 3; Tcl_Obj *objv[3]; objv[0] = Tcl_NewStringObj("Evaluator::tryRunInSerializedEnvironment", -1); objv[1] = lambda; objv[2] = env; if (Tcl_EvalObjv(interp, objc, objv, 0) == TCL_ERROR) { printf("oh god: %s\n", Tcl_GetString(Tcl_GetObjResult(interp))); } } static statement_t* get(statement_handle_t id); static int exists(statement_handle_t id); static match_handle_t addMatchImpl(size_t n_parents, statement_handle_t parents[]); static environment_t* unify(Tcl_Obj* a, Tcl_Obj* b); void reactToStatementAdditionThatMatchesWhen(Tcl_Interp* interp, statement_handle_t whenId, Tcl_Obj* whenPattern, statement_handle_t statementId) { if (!exists(whenId)) { removeAllReactions(whenId); return; } statement_t* when = get(whenId); statement_t* stmt = get(statementId); environment_t* result = unify(whenPattern, stmt->clause); if (result) { int whenClauseLength; Tcl_ListObjLength(NULL, when->clause, &whenClauseLength); statement_handle_t matchParentIds[] = {whenId, statementId}; match_handle_t matchId = addMatchImpl(2, matchParentIds); Tcl_Obj* lambda; Tcl_ListObjIndex(NULL, when->clause, whenClauseLength-4, &lambda); Tcl_Obj* env; Tcl_ListObjIndex(NULL, when->clause, whenClauseLength-1, &env); env = Tcl_DuplicateObj(env); // Append bindings to end of env // TODO: does this preserve order? // FIXME: need to only get bindings on the When side for (int i = 0; i < result->bindingsCount; i++) { /* printf("Appending binding: [%s]->[%s]\n", result->bindings[i].name, Tcl_GetString(result->bindings[i].value)); */ Tcl_ListObjAppendElement(interp, env, result->bindings[i].value); } ckfree((char*)result); Tcl_ObjSetVar2(interp, Tcl_ObjPrintf("::matchId"), NULL, Tcl_ObjPrintf("m%d:%d", matchId.idx, matchId.gen), 0); tryRunInSerializedEnvironment(interp, lambda, env); } } static void LogWriteRecollect(statement_handle_t collectId); static void LogWriteUnmatch(match_handle_t matchId); void reactToStatementAdditionThatMatchesCollect(Tcl_Interp* interp, statement_handle_t collectId, Tcl_Obj* collectPattern, statement_handle_t statementId) { get(collectId)->collectNeedsRecollect = true; LogWriteRecollect(collectId); } } $cc proc EvaluatorInit {} void { reactionsToStatementAddition = trieCreate(); } $cc proc reactToStatementAddition {Tcl_Interp* interp statement_handle_t id} void { Tcl_Obj* clause = get(id)->clause; int clauseLength; Tcl_Obj** clauseWords; Tcl_ListObjGetElements(interp, clause, &clauseLength, &clauseWords); if (strcmp(Tcl_GetString(clauseWords[0]), "when") == 0 && strcmp(Tcl_GetString(clauseWords[1]), "the") == 0 && strcmp(Tcl_GetString(clauseWords[2]), "collected") == 0 && strcmp(Tcl_GetString(clauseWords[3]), "matches") == 0 && strcmp(Tcl_GetString(clauseWords[4]), "for") == 0) { // when the collected matches for [list the time is /t/ & Omar is cool] are /matches/ { ... } with environment /__env/ // -> {the time is /t/} {Omar is cool} Tcl_Obj* pattern = clauseWords[5]; Tcl_Obj* subpatterns[10]; int subpatternsCount = splitPattern(pattern, 10, subpatterns); for (int i = 0; i < subpatternsCount; i++) { Tcl_Obj* subpattern = subpatterns[i]; addReaction(subpattern, id, reactToStatementAdditionThatMatchesCollect); Tcl_Obj* claimizedSubpattern = claimizePattern(subpattern); if (claimizedSubpattern != NULL) { addReaction(claimizedSubpattern, id, reactToStatementAdditionThatMatchesCollect); } } get(id)->collectNeedsRecollect = true; LogWriteRecollect(id); } else if (strcmp(Tcl_GetString(clauseWords[0]), "when") == 0) { // when the time is /t/ { ... } with environment /env/ -> the time is /t/ Tcl_Obj* pattern = Tcl_DuplicateObj(clause); Tcl_ListObjReplace(interp, pattern, clauseLength-4, 4, 0, NULL); Tcl_ListObjReplace(interp, pattern, 0, 1, 0, NULL); addReaction(pattern, id, reactToStatementAdditionThatMatchesWhen); Tcl_Obj* claimizedPattern = claimizePattern(pattern); if (claimizedPattern != NULL) { addReaction(claimizedPattern, id, reactToStatementAdditionThatMatchesWhen); } // Scan the existing statement set for any // already-existing matching statements. uint64_t alreadyMatchingStatementIds[1000]; int alreadyMatchingStatementIdsCount = trieLookup(interp, alreadyMatchingStatementIds, 1000, statementClauseToId, pattern); for (int i = 0; i < alreadyMatchingStatementIdsCount; i++) { statement_handle_t alreadyMatchingStatementId = *(statement_handle_t *)&alreadyMatchingStatementIds[i]; reactToStatementAdditionThatMatchesWhen(interp, id, pattern, alreadyMatchingStatementId); } if (claimizedPattern != NULL) { alreadyMatchingStatementIdsCount = trieLookup(interp, alreadyMatchingStatementIds, 1000, statementClauseToId, claimizedPattern); for (int i = 0; i < alreadyMatchingStatementIdsCount; i++) { statement_handle_t alreadyMatchingStatementId = *(statement_handle_t *)&alreadyMatchingStatementIds[i]; reactToStatementAdditionThatMatchesWhen(interp, id, claimizedPattern, alreadyMatchingStatementId); } } } // Trigger any reactions to the addition of this statement. Tcl_Obj* clauseWithReactingIdWildcard = Tcl_DuplicateObj(clause); { Tcl_Obj* reactingIdWildcard = Tcl_ObjPrintf("/reactingId/"); Tcl_ListObjReplace(interp, clauseWithReactingIdWildcard, clauseLength, 0, 1, &reactingIdWildcard); } uint64_t reactions[1000]; int reactionCount = trieLookup(interp, reactions, 1000, reactionsToStatementAddition, clauseWithReactingIdWildcard); Tcl_DecrRefCount(clauseWithReactingIdWildcard); for (int i = 0; i < reactionCount; i++) { reaction_t* reaction = (reaction_t*)(uintptr_t)reactions[i]; reaction->react(interp, reaction->reactingId, reaction->reactToPattern, id); } } $cc code { static void reactToStatementRemoval(Tcl_Interp* interp, statement_handle_t id); } $cc proc reactToMatchRemoval {Tcl_Interp* interp match_handle_t matchId} void { match_t* match = matchGet(matchId); for (int j = 0; j < match->n_edges; j++) { // this match will be dead, so remove the match from the // other parents of the match if (match->edges[j].type == PARENT) { statement_handle_t parentId = match->edges[j].statement; if (!exists(parentId)) { continue; } statementRemoveEdgeToMatch(parentId, CHILD, matchId); } else if (match->edges[j].type == CHILD) { statement_handle_t childId = match->edges[j].statement; if (!exists(childId)) { continue; } if (statementRemoveEdgeToMatch(childId, PARENT, matchId) == 0) { // is this child statement out of parent matches? => it's dead reactToStatementRemoval(interp, childId); remove_(childId); matchRemoveEdgeToStatement(matchId, CHILD, childId); } } } for (int i = 0; i < sizeof(match->destructors)/sizeof(match->destructors[0]); i++) { if (match->destructors[i].body != NULL) { tryRunInSerializedEnvironment(interp, match->destructors[i].body, match->destructors[i].env); } } } $cc proc reactToStatementRemoval {Tcl_Interp* interp statement_handle_t id} void { // unset all things downstream of statement removeAllReactions(id); statement_t* stmt = get(id); for (int i = 0; i < stmt->n_edges; i++) { edge_to_match_t* edge = statementEdgeAt(stmt, i); if (edge->type == PARENT) { match_handle_t matchId = edge->match; if (!matchExists(matchId)) continue; matchRemoveEdgeToStatement(matchId, CHILD, id); } else if (edge->type == CHILD) { match_handle_t matchId = edge->match; if (!matchExists(matchId)) continue; // if was removed earlier // Test if this child-match is a Collect-match (and // the statement being removed is _not_ its collector) match_t* match = matchGet(matchId); if (match->isFromCollect && !statementHandleIsEqual(match->collectId, id)) { // If so, then it should be marked as dirty and // recollected later, rather than it and its // transitive dependents immediately getting // yanked out. if (exists(match->collectId)) { get(match->collectId)->collectNeedsRecollect = true; LogWriteRecollect(match->collectId); } else { reactToMatchRemoval(interp, matchId); matchRemove(matchId); } } else { reactToMatchRemoval(interp, matchId); matchRemove(matchId); // LogWriteUnmatch(matchId); } } } } $cc proc UnmatchImpl {Tcl_Interp* interp match_handle_t currentMatchId int level} void { match_handle_t unmatchId = currentMatchId; for (int i = 0; i < level; i++) { match_t* unmatch = matchGet(unmatchId); // Get first parent of unmatchId (should be the When) for (int j = 0; j < unmatch->n_edges; j++) { if (unmatch->edges[j].type == PARENT) { statement_handle_t unmatchWhenId = unmatch->edges[j].statement; statement_t* unmatchWhen = get(unmatchWhenId); if (unmatchWhen == NULL) continue; for (int k = 0; k < unmatchWhen->n_edges; k++) { if (unmatchWhen->edges[k].type == PARENT) { unmatchId = unmatchWhen->edges[k].match; break; } } break; } } } reactToMatchRemoval(interp, unmatchId); matchRemove(unmatchId); } proc Unmatch {{level 0}} { # Forces an unmatch of the current match or its `level`-th ancestor match. UnmatchImpl $::matchId $level } $cc proc recollect {Tcl_Interp* interp statement_handle_t collectId} void { // Called when a statement of a pattern that someone is // collecting has been added or removed. statement_t* collect = get(collectId); if (!collect->collectNeedsRecollect) { return; } collect->collectNeedsRecollect = false; Tcl_Obj* clause = collect->clause; int clauseLength; Tcl_Obj** clauseWords; Tcl_ListObjGetElements(interp, clause, &clauseLength, &clauseWords); Tcl_Obj* lambda = clauseWords[clauseLength-4]; char matchesVarName[100]; scanVariable(clauseWords[clauseLength-5], matchesVarName, sizeof(matchesVarName)); Tcl_Obj* env = clauseWords[clauseLength-1]; int resultsCount = 0; environment_t* results[1000]; { Tcl_Obj* pattern = clauseWords[5]; Tcl_Obj* subpatterns[10]; int subpatternsCount = splitPattern(pattern, 10, subpatterns); searchByPatterns(subpatternsCount, subpatterns, NULL, 1000, results, &resultsCount); for (int i = 0; i < subpatternsCount; i++) { Tcl_DecrRefCount(subpatterns[i]); } } Tcl_Obj* matches = Tcl_NewListObj(0, NULL); int parentsCount = 1; statement_handle_t parents[resultsCount*10]; parents[0] = collectId; for (int i = 0; i < resultsCount; i++) { Tcl_ListObjAppendElement(NULL, matches, environmentToTclDict(results[i])); for (int j = 0; j < results[i]->matchedStatementIdsCount; j++) { parents[parentsCount++] = results[i]->matchedStatementIds[j]; } ckfree((char *)results[i]); } // Create a new match for the new collection. match_handle_t matchId = addMatchImpl(parentsCount, parents); match_t* match = matchGet(matchId); match->isFromCollect = true; match->collectId = collectId; // Run the When body within this new match. env = Tcl_DuplicateObj(env); Tcl_ListObjAppendElement(NULL, env, matches); Tcl_ObjSetVar2(interp, Tcl_ObjPrintf("::matchId"), NULL, Tcl_ObjPrintf("m%d:%d", matchId.idx, matchId.gen), 0); tryRunInSerializedEnvironment(interp, lambda, env); // Finally, delete the old match child if any. // (We do this last, _after_ adding the new match, because it helps with incrementality.) for (size_t i = 0; i < collect->n_edges; i++) { edge_to_match_t* edge = statementEdgeAt(collect, i); if (edge->type == CHILD && !matchHandleIsEqual(edge->match, matchId)) { match_handle_t childMatchId = edge->match; // We don't want to fire a new recollect on // destruction. (because we just fired one) matchGet(childMatchId)->isFromCollect = false; // This Unmatch has to be trampolined back up to // the operation log so it happens after Saying // any new statements. LogWriteUnmatch(childMatchId); break; } } } $cc cflags -I./vendor/libpqueue vendor/libpqueue/pqueue.c $cc include "pqueue.h" $cc code { typedef enum { NONE, ASSERT, RETRACT, SAY, UNMATCH, RECOLLECT } queue_op_t; typedef struct queue_entry_t { queue_op_t op; int seq; union { struct { Tcl_Obj* clause; } assert; struct { Tcl_Obj* pattern; } retract; struct { match_handle_t parentMatchId; Tcl_Obj* clause; } say; struct { match_handle_t matchId; } unmatch; struct { statement_handle_t collectId; } recollect; }; } queue_entry_t; pqueue_t* queue; int seq; int queueEntryCompare(pqueue_pri_t next, pqueue_pri_t curr) { return next < curr; } pqueue_pri_t queueEntryGetPriority(void* a) { queue_entry_t* entry = a; switch (entry->op) { case NONE: return 0; case ASSERT: case RETRACT: return 80000 - entry->seq; case SAY: return 80000 + entry->seq; case UNMATCH: return 1000 - entry->seq; case RECOLLECT: return 5000 - entry->seq; } return 0; } void queueEntrySetPriority(void* a, pqueue_pri_t pri) {} size_t queueEntryGetPosition(void* a) { return 0; } void queueEntrySetPosition(void* a, size_t pos) {} } $cc proc init {} void { queue = pqueue_init(16384, queueEntryCompare, queueEntryGetPriority, queueEntrySetPriority, queueEntryGetPosition, queueEntrySetPosition); } $cc proc Evaluate {Tcl_Interp* interp} void { op("Evaluate"); seq = 0; queue_entry_t* entryPtr; while ((entryPtr = pqueue_pop(queue)) != NULL) { queue_entry_t entry = *entryPtr; ckfree((char*) entryPtr); if (entry.op == ASSERT) { op("Assert (%s)", Tcl_GetString(entry.assert.clause)); statement_handle_t id; bool isNewStatement; addImpl(interp, entry.assert.clause, 0, NULL, &id, &isNewStatement); if (isNewStatement) { reactToStatementAddition(interp, id); } Tcl_DecrRefCount(entry.assert.clause); } else if (entry.op == RETRACT) { op("Retract (%s)", Tcl_GetString(entry.retract.pattern)); environment_t* results[1000]; int resultsCount = searchByPattern(entry.retract.pattern, 1000, results); for (int i = 0; i < resultsCount; i++) { statement_handle_t id = results[i]->matchedStatementIds[0]; reactToStatementRemoval(interp, id); remove_(id); ckfree((char *)results[i]); } Tcl_DecrRefCount(entry.retract.pattern); } else if (entry.op == SAY) { op("Say (%s)", Tcl_GetString(entry.say.clause)); if (matchExists(entry.say.parentMatchId)) { statement_handle_t id; bool isNewStatement; addImpl(interp, entry.say.clause, 1, &entry.say.parentMatchId, &id, &isNewStatement); if (isNewStatement) { reactToStatementAddition(interp, id); } } Tcl_DecrRefCount(entry.say.clause); } else if (entry.op == UNMATCH) { op("Unmatch (m%d:%d)", entry.unmatch.matchId.idx, entry.unmatch.matchId.gen); if (matchExists(entry.unmatch.matchId)) { reactToMatchRemoval(interp, entry.unmatch.matchId); matchRemove(entry.unmatch.matchId); } } else if (entry.op == RECOLLECT) { if (exists(entry.recollect.collectId)) { op("Recollect (s%d:%d) (%s)", entry.recollect.collectId.idx, entry.recollect.collectId.gen, Tcl_GetString(get(entry.recollect.collectId)->clause)); recollect(interp, entry.recollect.collectId); } else { op("Recollect (s%d:%d) (DEAD)", entry.recollect.collectId.idx, entry.recollect.collectId.gen); } } } } $cc code { void queueInsert(queue_entry_t entry) { queue_entry_t* ptr = (queue_entry_t*)ckalloc(sizeof(entry)); *ptr = entry; ptr->seq = seq++; pqueue_insert(queue, ptr); } } $cc proc LogWriteAssert {Tcl_Obj* clause} void { Tcl_IncrRefCount(clause); queueInsert((queue_entry_t) { .op = ASSERT, .assert = {.clause=clause} }); } $cc proc LogWriteRetract {Tcl_Obj* pattern} void { Tcl_IncrRefCount(pattern); queueInsert((queue_entry_t) { .op = RETRACT, .retract = {.pattern=pattern} }); } $cc proc LogWriteSay {match_handle_t parentMatchId Tcl_Obj* clause} void { Tcl_IncrRefCount(clause); queueInsert((queue_entry_t) { .op = SAY, .say = {.parentMatchId=parentMatchId, .clause=clause} }); } $cc proc LogWriteUnmatch {match_handle_t matchId} void { // TODO: These should probably precede a recollect. queueInsert((queue_entry_t) { .op = UNMATCH, .unmatch = {.matchId=matchId} }); } $cc proc LogWriteRecollect {statement_handle_t collectId} void { queueInsert((queue_entry_t) { .op = RECOLLECT, .recollect = {.collectId=collectId} }); } $cc proc LogIsEmpty {} bool { return pqueue_peek(queue) == NULL; } $cc compile init } namespace eval Statements { # compatibility with older Tcl statements module interface namespace export reactToStatementAddition reactToStatementRemoval rename remove_ remove rename get getImpl proc get {id} { deref [getImpl $id] } } namespace eval Matches { rename ::Statements::matchExists ::Matches::exists } Statements::StatementsInit Evaluator::EvaluatorInit if {[info exists ::argv0] && $::argv0 eq [info script]} { puts [Statements::addImpl [list whatever dude] 0 [list]] puts [Statements::addImpl [list cool dude] 0 [list]] puts [Statements::addMatch 2 [list 1 2]] puts "matches: [Statements::findStatementsMatching [list /response/ dude]]" }