Compare commits
2 Commits
loops/data
...
loops/ocam
| Author | SHA1 | Date | |
|---|---|---|---|
| 9a090c6e42 | |||
| 85b7fed4fc |
@@ -1,300 +0,0 @@
|
||||
;; lib/datalog/builtins.sx — comparison + arithmetic body literals.
|
||||
;;
|
||||
;; Built-in predicates filter / extend candidate substitutions during
|
||||
;; rule evaluation. They are not stored facts and do not participate in
|
||||
;; the Herbrand base.
|
||||
;;
|
||||
;; (< a b) (<= a b) (> a b) (>= a b) ; numeric (or string) compare
|
||||
;; (= a b) ; unify (binds vars)
|
||||
;; (!= a b) ; ground-only inequality
|
||||
;; (is X expr) ; bind X to expr's value
|
||||
;;
|
||||
;; Arithmetic expressions are SX-list compounds:
|
||||
;; (+ a b) (- a b) (* a b) (/ a b)
|
||||
;; or numbers / variables (must be bound at evaluation time).
|
||||
|
||||
(define
|
||||
dl-comparison?
|
||||
(fn
|
||||
(lit)
|
||||
(and
|
||||
(list? lit)
|
||||
(> (len lit) 0)
|
||||
(let
|
||||
((rel (dl-rel-name lit)))
|
||||
(cond
|
||||
((nil? rel) false)
|
||||
(else (dl-member-string? rel (list "<" "<=" ">" ">=" "!="))))))))
|
||||
|
||||
(define
|
||||
dl-eq?
|
||||
(fn
|
||||
(lit)
|
||||
(and
|
||||
(list? lit)
|
||||
(> (len lit) 0)
|
||||
(let ((rel (dl-rel-name lit))) (and (not (nil? rel)) (= rel "="))))))
|
||||
|
||||
(define
|
||||
dl-is?
|
||||
(fn
|
||||
(lit)
|
||||
(and
|
||||
(list? lit)
|
||||
(> (len lit) 0)
|
||||
(let
|
||||
((rel (dl-rel-name lit)))
|
||||
(and (not (nil? rel)) (= rel "is"))))))
|
||||
|
||||
;; Evaluate an arithmetic expression under subst. Returns the numeric
|
||||
;; result, or raises if any operand is unbound or non-numeric.
|
||||
(define
|
||||
dl-eval-arith
|
||||
(fn
|
||||
(expr subst)
|
||||
(let
|
||||
((w (dl-walk expr subst)))
|
||||
(cond
|
||||
((number? w) w)
|
||||
((dl-var? w)
|
||||
(error (str "datalog arith: unbound variable " (symbol->string w))))
|
||||
((list? w)
|
||||
(let
|
||||
((rel (dl-rel-name w)) (args (rest w)))
|
||||
(cond
|
||||
((not (= (len args) 2))
|
||||
(error (str "datalog arith: need 2 args, got " w)))
|
||||
(else
|
||||
(let
|
||||
((a (dl-eval-arith (first args) subst))
|
||||
(b (dl-eval-arith (nth args 1) subst)))
|
||||
(cond
|
||||
((= rel "+") (+ a b))
|
||||
((= rel "-") (- a b))
|
||||
((= rel "*") (* a b))
|
||||
((= rel "/") (/ a b))
|
||||
(else (error (str "datalog arith: unknown op " rel)))))))))
|
||||
(else (error (str "datalog arith: not a number — " w)))))))
|
||||
|
||||
(define
|
||||
dl-eval-compare
|
||||
(fn
|
||||
(lit subst)
|
||||
(let
|
||||
((rel (dl-rel-name lit))
|
||||
(a (dl-walk (nth lit 1) subst))
|
||||
(b (dl-walk (nth lit 2) subst)))
|
||||
(cond
|
||||
((or (dl-var? a) (dl-var? b))
|
||||
(error
|
||||
(str
|
||||
"datalog: comparison "
|
||||
rel
|
||||
" has unbound argument; "
|
||||
"ensure prior body literal binds the variable")))
|
||||
(else
|
||||
(let
|
||||
((ok (cond ((= rel "<") (< a b)) ((= rel "<=") (<= a b)) ((= rel ">") (> a b)) ((= rel ">=") (>= a b)) ((= rel "!=") (not (dl-tuple-equal? a b))) (else (error (str "datalog: unknown compare " rel))))))
|
||||
(if ok subst nil)))))))
|
||||
|
||||
(define
|
||||
dl-eval-eq
|
||||
(fn
|
||||
(lit subst)
|
||||
(dl-unify (nth lit 1) (nth lit 2) subst)))
|
||||
|
||||
(define
|
||||
dl-eval-is
|
||||
(fn
|
||||
(lit subst)
|
||||
(let
|
||||
((target (nth lit 1)) (expr (nth lit 2)))
|
||||
(let
|
||||
((value (dl-eval-arith expr subst)))
|
||||
(dl-unify target value subst)))))
|
||||
|
||||
(define
|
||||
dl-eval-builtin
|
||||
(fn
|
||||
(lit subst)
|
||||
(cond
|
||||
((dl-comparison? lit) (dl-eval-compare lit subst))
|
||||
((dl-eq? lit) (dl-eval-eq lit subst))
|
||||
((dl-is? lit) (dl-eval-is lit subst))
|
||||
(else (error (str "dl-eval-builtin: not a built-in: " lit))))))
|
||||
|
||||
;; ── Safety analysis ──────────────────────────────────────────────
|
||||
;;
|
||||
;; Walks body literals left-to-right tracking a "bound" set. The check
|
||||
;; understands these literal kinds:
|
||||
;;
|
||||
;; positive non-built-in → adds its vars to bound
|
||||
;; (is X expr) → vars(expr) ⊆ bound, then add X (if var)
|
||||
;; <,<=,>,>=,!= → all vars ⊆ bound (no binding)
|
||||
;; (= a b) where:
|
||||
;; both non-vars → constraint check, no binding
|
||||
;; a var, b not → bind a
|
||||
;; b var, a not → bind b
|
||||
;; both vars → at least one in bound; bind the other
|
||||
;; {:neg lit} → all vars ⊆ bound (Phase 7 enforces fully)
|
||||
;;
|
||||
;; At end, head vars (minus `_`) must be ⊆ bound.
|
||||
|
||||
(define
|
||||
dl-vars-not-in
|
||||
(fn
|
||||
(vs bound)
|
||||
(let
|
||||
((out (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(v)
|
||||
(when (not (dl-member-string? v bound)) (append! out v)))
|
||||
vs)
|
||||
out))))
|
||||
|
||||
(define
|
||||
dl-rule-check-safety
|
||||
(fn
|
||||
(rule)
|
||||
(let
|
||||
((head (get rule :head))
|
||||
(body (get rule :body))
|
||||
(bound (list))
|
||||
(err nil))
|
||||
(do
|
||||
(define
|
||||
dl-add-bound!
|
||||
(fn
|
||||
(vs)
|
||||
(for-each
|
||||
(fn
|
||||
(v)
|
||||
(when (not (dl-member-string? v bound)) (append! bound v)))
|
||||
vs)))
|
||||
(define
|
||||
dl-process-eq!
|
||||
(fn
|
||||
(lit)
|
||||
(let
|
||||
((a (nth lit 1)) (b (nth lit 2)))
|
||||
(let
|
||||
((va (dl-var? a)) (vb (dl-var? b)))
|
||||
(cond
|
||||
((and (not va) (not vb)) nil)
|
||||
((and va (not vb))
|
||||
(dl-add-bound! (list (symbol->string a))))
|
||||
((and (not va) vb)
|
||||
(dl-add-bound! (list (symbol->string b))))
|
||||
(else
|
||||
(let
|
||||
((sa (symbol->string a)) (sb (symbol->string b)))
|
||||
(cond
|
||||
((dl-member-string? sa bound)
|
||||
(dl-add-bound! (list sb)))
|
||||
((dl-member-string? sb bound)
|
||||
(dl-add-bound! (list sa)))
|
||||
(else
|
||||
(set!
|
||||
err
|
||||
(str
|
||||
"= between two unbound variables "
|
||||
(list sa sb)
|
||||
" — at least one must be bound by an "
|
||||
"earlier positive body literal")))))))))))
|
||||
(define
|
||||
dl-process-cmp!
|
||||
(fn
|
||||
(lit)
|
||||
(let
|
||||
((needed (dl-vars-of (list (nth lit 1) (nth lit 2)))))
|
||||
(let
|
||||
((missing (dl-vars-not-in needed bound)))
|
||||
(when
|
||||
(> (len missing) 0)
|
||||
(set!
|
||||
err
|
||||
(str
|
||||
"comparison "
|
||||
(dl-rel-name lit)
|
||||
" requires bound variable(s) "
|
||||
missing
|
||||
" (must be bound by an earlier positive "
|
||||
"body literal)")))))))
|
||||
(define
|
||||
dl-process-is!
|
||||
(fn
|
||||
(lit)
|
||||
(let
|
||||
((tgt (nth lit 1)) (expr (nth lit 2)))
|
||||
(let
|
||||
((needed (dl-vars-of expr)))
|
||||
(let
|
||||
((missing (dl-vars-not-in needed bound)))
|
||||
(cond
|
||||
((> (len missing) 0)
|
||||
(set!
|
||||
err
|
||||
(str
|
||||
"is RHS uses unbound variable(s) "
|
||||
missing
|
||||
" — bind them via a prior positive body "
|
||||
"literal")))
|
||||
(else
|
||||
(when
|
||||
(dl-var? tgt)
|
||||
(dl-add-bound! (list (symbol->string tgt)))))))))))
|
||||
(define
|
||||
dl-process-neg!
|
||||
(fn
|
||||
(lit)
|
||||
(let
|
||||
((needed (dl-vars-of (get lit :neg))))
|
||||
(let
|
||||
((missing (dl-vars-not-in needed bound)))
|
||||
(when
|
||||
(> (len missing) 0)
|
||||
(set!
|
||||
err
|
||||
(str
|
||||
"negation refers to unbound variable(s) "
|
||||
missing
|
||||
" — they must be bound by an earlier "
|
||||
"positive body literal")))))))
|
||||
(define
|
||||
dl-process-lit!
|
||||
(fn
|
||||
(lit)
|
||||
(when
|
||||
(nil? err)
|
||||
(cond
|
||||
((and (dict? lit) (has-key? lit :neg))
|
||||
(dl-process-neg! lit))
|
||||
((dl-eq? lit) (dl-process-eq! lit))
|
||||
((dl-is? lit) (dl-process-is! lit))
|
||||
((dl-comparison? lit) (dl-process-cmp! lit))
|
||||
((and (list? lit) (> (len lit) 0))
|
||||
(dl-add-bound! (dl-vars-of lit)))))))
|
||||
(for-each dl-process-lit! body)
|
||||
(when
|
||||
(nil? err)
|
||||
(let
|
||||
((head-vars (dl-vars-of head)) (missing (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(v)
|
||||
(when
|
||||
(and (not (dl-member-string? v bound)) (not (= v "_")))
|
||||
(append! missing v)))
|
||||
head-vars)
|
||||
(when
|
||||
(> (len missing) 0)
|
||||
(set!
|
||||
err
|
||||
(str
|
||||
"head variable(s) "
|
||||
missing
|
||||
" do not appear in any positive body literal"))))))
|
||||
err))))
|
||||
@@ -1,21 +0,0 @@
|
||||
# Datalog conformance config — sourced by lib/guest/conformance.sh.
|
||||
|
||||
LANG_NAME=datalog
|
||||
MODE=dict
|
||||
|
||||
PRELOADS=(
|
||||
lib/datalog/tokenizer.sx
|
||||
lib/datalog/parser.sx
|
||||
lib/datalog/unify.sx
|
||||
lib/datalog/db.sx
|
||||
lib/datalog/builtins.sx
|
||||
lib/datalog/eval.sx
|
||||
)
|
||||
|
||||
SUITES=(
|
||||
"tokenize:lib/datalog/tests/tokenize.sx:(dl-tokenize-tests-run!)"
|
||||
"parse:lib/datalog/tests/parse.sx:(dl-parse-tests-run!)"
|
||||
"unify:lib/datalog/tests/unify.sx:(dl-unify-tests-run!)"
|
||||
"eval:lib/datalog/tests/eval.sx:(dl-eval-tests-run!)"
|
||||
"builtins:lib/datalog/tests/builtins.sx:(dl-builtins-tests-run!)"
|
||||
)
|
||||
@@ -1,3 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
# Thin wrapper — see lib/guest/conformance.sh and lib/datalog/conformance.conf.
|
||||
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
|
||||
@@ -1,227 +0,0 @@
|
||||
;; lib/datalog/db.sx — Datalog database (EDB + IDB + rules) + safety hook.
|
||||
;;
|
||||
;; A db is a mutable dict:
|
||||
;; {:facts {<rel-name-string> -> (literal ...)}
|
||||
;; :rules ({:head literal :body (literal ...)} ...)}
|
||||
;;
|
||||
;; Facts are stored as full literals `(rel arg ... arg)` so they unify
|
||||
;; directly against rule body literals. Each relation's tuple list is
|
||||
;; deduplicated on insert.
|
||||
;;
|
||||
;; Phase 3 introduced safety analysis for head variables; Phase 4 (in
|
||||
;; lib/datalog/builtins.sx) swaps in the real `dl-rule-check-safety`,
|
||||
;; which is order-aware and understands built-in predicates.
|
||||
|
||||
(define dl-make-db (fn () {:facts {} :rules (list)}))
|
||||
|
||||
(define
|
||||
dl-rel-name
|
||||
(fn
|
||||
(lit)
|
||||
(cond
|
||||
((and (dict? lit) (has-key? lit :neg)) (dl-rel-name (get lit :neg)))
|
||||
((and (list? lit) (> (len lit) 0) (symbol? (first lit)))
|
||||
(symbol->string (first lit)))
|
||||
(else nil))))
|
||||
|
||||
(define dl-builtin-rels (list "<" "<=" ">" ">=" "=" "!=" "is"))
|
||||
|
||||
(define
|
||||
dl-member-string?
|
||||
(fn
|
||||
(s xs)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((= (first xs) s) true)
|
||||
(else (dl-member-string? s (rest xs))))))
|
||||
|
||||
(define
|
||||
dl-builtin?
|
||||
(fn
|
||||
(lit)
|
||||
(and
|
||||
(list? lit)
|
||||
(> (len lit) 0)
|
||||
(let
|
||||
((rel (dl-rel-name lit)))
|
||||
(cond
|
||||
((nil? rel) false)
|
||||
(else (dl-member-string? rel dl-builtin-rels)))))))
|
||||
|
||||
(define
|
||||
dl-positive-lit?
|
||||
(fn
|
||||
(lit)
|
||||
(cond
|
||||
((and (dict? lit) (has-key? lit :neg)) false)
|
||||
((dl-builtin? lit) false)
|
||||
((and (list? lit) (> (len lit) 0)) true)
|
||||
(else false))))
|
||||
|
||||
(define
|
||||
dl-tuple-equal?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-tuple-equal-list? a b 0)))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-tuple-equal-list?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-tuple-equal? (nth a i) (nth b i))) false)
|
||||
(else (dl-tuple-equal-list? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-tuple-member?
|
||||
(fn
|
||||
(lit lits)
|
||||
(cond
|
||||
((= (len lits) 0) false)
|
||||
((dl-tuple-equal? lit (first lits)) true)
|
||||
(else (dl-tuple-member? lit (rest lits))))))
|
||||
|
||||
(define
|
||||
dl-ensure-rel!
|
||||
(fn
|
||||
(db rel-key)
|
||||
(let
|
||||
((facts (get db :facts)))
|
||||
(do
|
||||
(when
|
||||
(not (has-key? facts rel-key))
|
||||
(dict-set! facts rel-key (list)))
|
||||
(get facts rel-key)))))
|
||||
|
||||
(define
|
||||
dl-rel-tuples
|
||||
(fn
|
||||
(db rel-key)
|
||||
(let
|
||||
((facts (get db :facts)))
|
||||
(if (has-key? facts rel-key) (get facts rel-key) (list)))))
|
||||
|
||||
(define
|
||||
dl-add-fact!
|
||||
(fn
|
||||
(db lit)
|
||||
(cond
|
||||
((not (and (list? lit) (> (len lit) 0)))
|
||||
(error (str "dl-add-fact!: expected literal list, got " lit)))
|
||||
((not (dl-ground? lit (dl-empty-subst)))
|
||||
(error (str "dl-add-fact!: expected ground literal, got " lit)))
|
||||
(else
|
||||
(let
|
||||
((rel-key (dl-rel-name lit)))
|
||||
(let
|
||||
((tuples (dl-ensure-rel! db rel-key)))
|
||||
(cond
|
||||
((dl-tuple-member? lit tuples) false)
|
||||
(else (do (append! tuples lit) true)))))))))
|
||||
|
||||
;; The full safety check lives in builtins.sx (it has to know which
|
||||
;; predicates are built-ins). dl-add-rule! calls it via forward
|
||||
;; reference; load builtins.sx alongside db.sx in any setup that
|
||||
;; adds rules. The fallback below is used if builtins.sx isn't loaded.
|
||||
(define
|
||||
dl-rule-check-safety
|
||||
(fn
|
||||
(rule)
|
||||
(let
|
||||
((head-vars (dl-vars-of (get rule :head))) (body-vars (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(lit)
|
||||
(when
|
||||
(and
|
||||
(list? lit)
|
||||
(> (len lit) 0)
|
||||
(not (and (dict? lit) (has-key? lit :neg))))
|
||||
(for-each
|
||||
(fn
|
||||
(v)
|
||||
(when
|
||||
(not (dl-member-string? v body-vars))
|
||||
(append! body-vars v)))
|
||||
(dl-vars-of lit))))
|
||||
(get rule :body))
|
||||
(let
|
||||
((missing (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(v)
|
||||
(when
|
||||
(and
|
||||
(not (dl-member-string? v body-vars))
|
||||
(not (= v "_")))
|
||||
(append! missing v)))
|
||||
head-vars)
|
||||
(cond
|
||||
((> (len missing) 0)
|
||||
(str
|
||||
"head variable(s) "
|
||||
missing
|
||||
" do not appear in any body literal"))
|
||||
(else nil))))))))
|
||||
|
||||
(define
|
||||
dl-add-rule!
|
||||
(fn
|
||||
(db rule)
|
||||
(cond
|
||||
((not (dict? rule))
|
||||
(error (str "dl-add-rule!: expected rule dict, got " rule)))
|
||||
((not (has-key? rule :head))
|
||||
(error (str "dl-add-rule!: rule missing :head, got " rule)))
|
||||
(else
|
||||
(let
|
||||
((err (dl-rule-check-safety rule)))
|
||||
(cond
|
||||
((not (nil? err)) (error (str "dl-add-rule!: " err)))
|
||||
(else
|
||||
(let
|
||||
((rules (get db :rules)))
|
||||
(do (append! rules rule) true)))))))))
|
||||
|
||||
(define
|
||||
dl-add-clause!
|
||||
(fn
|
||||
(db clause)
|
||||
(cond
|
||||
((has-key? clause :query) false)
|
||||
((and (has-key? clause :body) (= (len (get clause :body)) 0))
|
||||
(dl-add-fact! db (get clause :head)))
|
||||
(else (dl-add-rule! db clause)))))
|
||||
|
||||
(define
|
||||
dl-load-program!
|
||||
(fn
|
||||
(db source)
|
||||
(let
|
||||
((clauses (dl-parse source)))
|
||||
(do (for-each (fn (c) (dl-add-clause! db c)) clauses) db))))
|
||||
|
||||
(define
|
||||
dl-program
|
||||
(fn (source) (let ((db (dl-make-db))) (dl-load-program! db source))))
|
||||
|
||||
(define dl-rules (fn (db) (get db :rules)))
|
||||
|
||||
(define
|
||||
dl-fact-count
|
||||
(fn
|
||||
(db)
|
||||
(let
|
||||
((facts (get db :facts)) (total 0))
|
||||
(do
|
||||
(for-each
|
||||
(fn (k) (set! total (+ total (len (get facts k)))))
|
||||
(keys facts))
|
||||
total))))
|
||||
@@ -1,147 +0,0 @@
|
||||
;; lib/datalog/eval.sx — naive bottom-up fixpoint evaluator.
|
||||
;;
|
||||
;; (dl-saturate! db) iterates rules until no new tuples are derived.
|
||||
;; The Herbrand base is finite (no function symbols) so termination is
|
||||
;; guaranteed by the language.
|
||||
;;
|
||||
;; Body literal kinds handled here:
|
||||
;; positive (rel arg ... arg) → match against EDB+IDB tuples (dl-match-positive)
|
||||
;; built-in (< X Y), (is X e) → constraint via dl-eval-builtin (Phase 4)
|
||||
;; negation {:neg lit} → Phase 7
|
||||
|
||||
(define
|
||||
dl-match-positive
|
||||
(fn
|
||||
(lit db subst)
|
||||
(let
|
||||
((rel (dl-rel-name lit)) (results (list)))
|
||||
(cond
|
||||
((nil? rel) (error (str "dl-match-positive: bad literal " lit)))
|
||||
(else
|
||||
(let
|
||||
((tuples (dl-rel-tuples db rel)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(tuple)
|
||||
(let
|
||||
((s (dl-unify lit tuple subst)))
|
||||
(when (not (nil? s)) (append! results s))))
|
||||
tuples)
|
||||
results)))))))
|
||||
|
||||
(define
|
||||
dl-match-lit
|
||||
(fn
|
||||
(lit db subst)
|
||||
(cond
|
||||
((and (dict? lit) (has-key? lit :neg))
|
||||
(error "datalog: negation not yet supported (Phase 7)"))
|
||||
((dl-builtin? lit)
|
||||
(let
|
||||
((s (dl-eval-builtin lit subst)))
|
||||
(if (nil? s) (list) (list s))))
|
||||
((and (list? lit) (> (len lit) 0))
|
||||
(dl-match-positive lit db subst))
|
||||
(else (error (str "datalog: unknown body-literal shape: " lit))))))
|
||||
|
||||
(define
|
||||
dl-find-bindings
|
||||
(fn
|
||||
(lits db subst)
|
||||
(cond
|
||||
((nil? subst) (list))
|
||||
((= (len lits) 0) (list subst))
|
||||
(else
|
||||
(let
|
||||
((options (dl-match-lit (first lits) db subst))
|
||||
(results (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(s)
|
||||
(for-each
|
||||
(fn (s2) (append! results s2))
|
||||
(dl-find-bindings (rest lits) db s)))
|
||||
options)
|
||||
results))))))
|
||||
|
||||
(define
|
||||
dl-apply-rule!
|
||||
(fn
|
||||
(db rule)
|
||||
(let
|
||||
((head (get rule :head)) (body (get rule :body)) (new? false))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((derived (dl-apply-subst head s)))
|
||||
(when (dl-add-fact! db derived) (set! new? true))))
|
||||
(dl-find-bindings body db (dl-empty-subst)))
|
||||
new?))))
|
||||
|
||||
(define
|
||||
dl-saturate!
|
||||
(fn
|
||||
(db)
|
||||
(let
|
||||
((changed true))
|
||||
(do
|
||||
(define
|
||||
dl-sat-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
changed
|
||||
(do
|
||||
(set! changed false)
|
||||
(for-each
|
||||
(fn (r) (when (dl-apply-rule! db r) (set! changed true)))
|
||||
(dl-rules db))
|
||||
(dl-sat-loop)))))
|
||||
(dl-sat-loop)
|
||||
db))))
|
||||
|
||||
(define
|
||||
dl-query
|
||||
(fn
|
||||
(db goal)
|
||||
(do
|
||||
(dl-saturate! db)
|
||||
(let
|
||||
((substs (dl-find-bindings (list goal) db (dl-empty-subst)))
|
||||
(vars (dl-vars-of goal))
|
||||
(results (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((proj (dl-project-subst s vars)))
|
||||
(when
|
||||
(not (dl-tuple-member? proj results))
|
||||
(append! results proj))))
|
||||
substs)
|
||||
results)))))
|
||||
|
||||
(define
|
||||
dl-project-subst
|
||||
(fn
|
||||
(subst names)
|
||||
(let
|
||||
((out {}))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(n)
|
||||
(let
|
||||
((sym (string->symbol n)))
|
||||
(let
|
||||
((v (dl-walk sym subst)))
|
||||
(dict-set! out n (dl-apply-subst v subst)))))
|
||||
names)
|
||||
out))))
|
||||
|
||||
(define dl-relation (fn (db name) (dl-rel-tuples db name)))
|
||||
@@ -1,242 +0,0 @@
|
||||
;; lib/datalog/parser.sx — Datalog tokens → AST
|
||||
;;
|
||||
;; Output shapes:
|
||||
;; Literal (positive) := (relname arg ... arg) — SX list
|
||||
;; Literal (negative) := {:neg (relname arg ... arg)} — dict
|
||||
;; Argument := var-symbol | atom-symbol | number | string
|
||||
;; | (op-name arg ... arg) — arithmetic compound
|
||||
;; Fact := {:head literal :body ()}
|
||||
;; Rule := {:head literal :body (lit ... lit)}
|
||||
;; Query := {:query (lit ... lit)}
|
||||
;; Program := list of facts / rules / queries
|
||||
;;
|
||||
;; Variables and constants are both SX symbols; the evaluator dispatches
|
||||
;; on first-char case ('A'..'Z' or '_' = variable, otherwise constant).
|
||||
;;
|
||||
;; The parser permits nested compounds in arg position to support
|
||||
;; arithmetic (e.g. (is Z (+ X Y))). Safety analysis at rule-load time
|
||||
;; rejects compounds whose head is not an arithmetic operator.
|
||||
|
||||
(define
|
||||
dl-pp-peek
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((i (get st :idx)) (tokens (get st :tokens)))
|
||||
(if (< i (len tokens)) (nth tokens i) {:type "eof" :value nil :pos 0}))))
|
||||
|
||||
(define
|
||||
dl-pp-peek2
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((i (+ (get st :idx) 1)) (tokens (get st :tokens)))
|
||||
(if (< i (len tokens)) (nth tokens i) {:type "eof" :value nil :pos 0}))))
|
||||
|
||||
(define
|
||||
dl-pp-advance!
|
||||
(fn (st) (dict-set! st :idx (+ (get st :idx) 1))))
|
||||
|
||||
(define
|
||||
dl-pp-at?
|
||||
(fn
|
||||
(st type value)
|
||||
(let
|
||||
((t (dl-pp-peek st)))
|
||||
(and
|
||||
(= (get t :type) type)
|
||||
(or (= value nil) (= (get t :value) value))))))
|
||||
|
||||
(define
|
||||
dl-pp-error
|
||||
(fn
|
||||
(st msg)
|
||||
(let
|
||||
((t (dl-pp-peek st)))
|
||||
(error
|
||||
(str
|
||||
"Parse error at pos "
|
||||
(get t :pos)
|
||||
": "
|
||||
msg
|
||||
" (got "
|
||||
(get t :type)
|
||||
" '"
|
||||
(if (= (get t :value) nil) "" (get t :value))
|
||||
"')")))))
|
||||
|
||||
(define
|
||||
dl-pp-expect!
|
||||
(fn
|
||||
(st type value)
|
||||
(let
|
||||
((t (dl-pp-peek st)))
|
||||
(if
|
||||
(dl-pp-at? st type value)
|
||||
(do (dl-pp-advance! st) t)
|
||||
(dl-pp-error
|
||||
st
|
||||
(str "expected " type (if (= value nil) "" (str " '" value "'"))))))))
|
||||
|
||||
;; Argument: variable, atom, number, string, or compound (relname/op + parens).
|
||||
(define
|
||||
dl-pp-parse-arg
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((t (dl-pp-peek st)))
|
||||
(let
|
||||
((ty (get t :type)) (vv (get t :value)))
|
||||
(cond
|
||||
((= ty "number") (do (dl-pp-advance! st) vv))
|
||||
((= ty "string") (do (dl-pp-advance! st) vv))
|
||||
((= ty "var") (do (dl-pp-advance! st) (string->symbol vv)))
|
||||
((or (= ty "atom") (= ty "op"))
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(if
|
||||
(dl-pp-at? st "punct" "(")
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(let
|
||||
((args (dl-pp-parse-arg-list st)))
|
||||
(do
|
||||
(dl-pp-expect! st "punct" ")")
|
||||
(cons (string->symbol vv) args))))
|
||||
(string->symbol vv))))
|
||||
(else (dl-pp-error st "expected term")))))))
|
||||
|
||||
;; Comma-separated args inside parens.
|
||||
(define
|
||||
dl-pp-parse-arg-list
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((args (list)))
|
||||
(do
|
||||
(append! args (dl-pp-parse-arg st))
|
||||
(define
|
||||
dl-pp-arg-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(dl-pp-at? st "punct" ",")
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(append! args (dl-pp-parse-arg st))
|
||||
(dl-pp-arg-loop)))))
|
||||
(dl-pp-arg-loop)
|
||||
args))))
|
||||
|
||||
;; A positive literal: relname (atom or op) followed by optional (args).
|
||||
(define
|
||||
dl-pp-parse-positive
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((t (dl-pp-peek st)))
|
||||
(let
|
||||
((ty (get t :type)) (vv (get t :value)))
|
||||
(if
|
||||
(or (= ty "atom") (= ty "op"))
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(if
|
||||
(dl-pp-at? st "punct" "(")
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(let
|
||||
((args (dl-pp-parse-arg-list st)))
|
||||
(do
|
||||
(dl-pp-expect! st "punct" ")")
|
||||
(cons (string->symbol vv) args))))
|
||||
(list (string->symbol vv))))
|
||||
(dl-pp-error st "expected literal head"))))))
|
||||
|
||||
;; A body literal: positive, or not(positive).
|
||||
(define
|
||||
dl-pp-parse-body-lit
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((t1 (dl-pp-peek st)) (t2 (dl-pp-peek2 st)))
|
||||
(if
|
||||
(and
|
||||
(= (get t1 :type) "atom")
|
||||
(= (get t1 :value) "not")
|
||||
(= (get t2 :type) "punct")
|
||||
(= (get t2 :value) "("))
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(dl-pp-advance! st)
|
||||
(let
|
||||
((inner (dl-pp-parse-positive st)))
|
||||
(do (dl-pp-expect! st "punct" ")") {:neg inner})))
|
||||
(dl-pp-parse-positive st)))))
|
||||
|
||||
;; Comma-separated body literals.
|
||||
(define
|
||||
dl-pp-parse-body
|
||||
(fn
|
||||
(st)
|
||||
(let
|
||||
((lits (list)))
|
||||
(do
|
||||
(append! lits (dl-pp-parse-body-lit st))
|
||||
(define
|
||||
dl-pp-body-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(dl-pp-at? st "punct" ",")
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(append! lits (dl-pp-parse-body-lit st))
|
||||
(dl-pp-body-loop)))))
|
||||
(dl-pp-body-loop)
|
||||
lits))))
|
||||
|
||||
;; Single clause: fact, rule, or query. Consumes trailing dot.
|
||||
(define
|
||||
dl-pp-parse-clause
|
||||
(fn
|
||||
(st)
|
||||
(cond
|
||||
((dl-pp-at? st "op" "?-")
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(let
|
||||
((body (dl-pp-parse-body st)))
|
||||
(do (dl-pp-expect! st "punct" ".") {:query body}))))
|
||||
(else
|
||||
(let
|
||||
((head (dl-pp-parse-positive st)))
|
||||
(cond
|
||||
((dl-pp-at? st "op" ":-")
|
||||
(do
|
||||
(dl-pp-advance! st)
|
||||
(let
|
||||
((body (dl-pp-parse-body st)))
|
||||
(do (dl-pp-expect! st "punct" ".") {:body body :head head}))))
|
||||
(else (do (dl-pp-expect! st "punct" ".") {:body (list) :head head}))))))))
|
||||
|
||||
(define
|
||||
dl-parse-program
|
||||
(fn
|
||||
(tokens)
|
||||
(let
|
||||
((st {:tokens tokens :idx 0}) (clauses (list)))
|
||||
(do
|
||||
(define
|
||||
dl-pp-prog-loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(not (dl-pp-at? st "eof" nil))
|
||||
(do
|
||||
(append! clauses (dl-pp-parse-clause st))
|
||||
(dl-pp-prog-loop)))))
|
||||
(dl-pp-prog-loop)
|
||||
clauses))))
|
||||
|
||||
(define dl-parse (fn (src) (dl-parse-program (dl-tokenize src))))
|
||||
@@ -1,14 +0,0 @@
|
||||
{
|
||||
"lang": "datalog",
|
||||
"total_passed": 106,
|
||||
"total_failed": 0,
|
||||
"total": 106,
|
||||
"suites": [
|
||||
{"name":"tokenize","passed":26,"failed":0,"total":26},
|
||||
{"name":"parse","passed":18,"failed":0,"total":18},
|
||||
{"name":"unify","passed":28,"failed":0,"total":28},
|
||||
{"name":"eval","passed":15,"failed":0,"total":15},
|
||||
{"name":"builtins","passed":19,"failed":0,"total":19}
|
||||
],
|
||||
"generated": "2026-05-07T23:50:44+00:00"
|
||||
}
|
||||
@@ -1,11 +0,0 @@
|
||||
# datalog scoreboard
|
||||
|
||||
**106 / 106 passing** (0 failure(s)).
|
||||
|
||||
| Suite | Passed | Total | Status |
|
||||
|-------|--------|-------|--------|
|
||||
| tokenize | 26 | 26 | ok |
|
||||
| parse | 18 | 18 | ok |
|
||||
| unify | 28 | 28 | ok |
|
||||
| eval | 15 | 15 | ok |
|
||||
| builtins | 19 | 19 | ok |
|
||||
@@ -1,228 +0,0 @@
|
||||
;; lib/datalog/tests/builtins.sx — comparison + arithmetic body literals.
|
||||
|
||||
(define dl-bt-pass 0)
|
||||
(define dl-bt-fail 0)
|
||||
(define dl-bt-failures (list))
|
||||
|
||||
(define
|
||||
dl-bt-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-bt-deq-l? a b 0)))
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ka (keys a)) (kb (keys b)))
|
||||
(and (= (len ka) (len kb)) (dl-bt-deq-d? a b ka 0))))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-bt-deq-l?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-bt-deep=? (nth a i) (nth b i))) false)
|
||||
(else (dl-bt-deq-l? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-bt-deq-d?
|
||||
(fn
|
||||
(a b ka i)
|
||||
(cond
|
||||
((>= i (len ka)) true)
|
||||
((let ((k (nth ka i))) (not (dl-bt-deep=? (get a k) (get b k))))
|
||||
false)
|
||||
(else (dl-bt-deq-d? a b ka (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-bt-set=?
|
||||
(fn
|
||||
(a b)
|
||||
(and (= (len a) (len b)) (dl-bt-subset? a b) (dl-bt-subset? b a))))
|
||||
|
||||
(define
|
||||
dl-bt-subset?
|
||||
(fn
|
||||
(xs ys)
|
||||
(cond
|
||||
((= (len xs) 0) true)
|
||||
((not (dl-bt-contains? ys (first xs))) false)
|
||||
(else (dl-bt-subset? (rest xs) ys)))))
|
||||
|
||||
(define
|
||||
dl-bt-contains?
|
||||
(fn
|
||||
(xs target)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((dl-bt-deep=? (first xs) target) true)
|
||||
(else (dl-bt-contains? (rest xs) target)))))
|
||||
|
||||
(define
|
||||
dl-bt-test-set!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-bt-set=? got expected)
|
||||
(set! dl-bt-pass (+ dl-bt-pass 1))
|
||||
(do
|
||||
(set! dl-bt-fail (+ dl-bt-fail 1))
|
||||
(append!
|
||||
dl-bt-failures
|
||||
(str
|
||||
name
|
||||
"\n expected (set): "
|
||||
expected
|
||||
"\n got: "
|
||||
got))))))
|
||||
|
||||
(define
|
||||
dl-bt-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-bt-deep=? got expected)
|
||||
(set! dl-bt-pass (+ dl-bt-pass 1))
|
||||
(do
|
||||
(set! dl-bt-fail (+ dl-bt-fail 1))
|
||||
(append!
|
||||
dl-bt-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-bt-throws?
|
||||
(fn
|
||||
(thunk)
|
||||
(let
|
||||
((threw false))
|
||||
(do (guard (e (#t (set! threw true))) (thunk)) threw))))
|
||||
|
||||
(define
|
||||
dl-bt-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(dl-bt-test-set!
|
||||
"less than filter"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"age(alice, 30). age(bob, 17). age(carol, 22).\n adult(X) :- age(X, A), >=(A, 18).")
|
||||
(list (quote adult) (quote X)))
|
||||
(list {:X (quote alice)} {:X (quote carol)}))
|
||||
(dl-bt-test-set!
|
||||
"less-equal filter"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"n(1). n(2). n(3). n(4). n(5).\n small(X) :- n(X), <=(X, 3).")
|
||||
(list (quote small) (quote X)))
|
||||
(list {:X 1} {:X 2} {:X 3}))
|
||||
(dl-bt-test-set!
|
||||
"not-equal filter"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"p(1, 2). p(2, 2). p(3, 4).\n diff(X, Y) :- p(X, Y), !=(X, Y).")
|
||||
(list (quote diff) (quote X) (quote Y)))
|
||||
(list {:X 1 :Y 2} {:X 3 :Y 4}))
|
||||
(dl-bt-test-set!
|
||||
"is plus"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"n(1). n(2). n(3).\n succ(X, Y) :- n(X), is(Y, +(X, 1)).")
|
||||
(list (quote succ) (quote X) (quote Y)))
|
||||
(list {:X 1 :Y 2} {:X 2 :Y 3} {:X 3 :Y 4}))
|
||||
(dl-bt-test-set!
|
||||
"is multiply"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"n(2). n(3). n(4).\n square(X, Y) :- n(X), is(Y, *(X, X)).")
|
||||
(list (quote square) (quote X) (quote Y)))
|
||||
(list {:X 2 :Y 4} {:X 3 :Y 9} {:X 4 :Y 16}))
|
||||
(dl-bt-test-set!
|
||||
"is nested expr"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"n(1). n(2). n(3).\n f(X, Y) :- n(X), is(Y, *(+(X, 1), 2)).")
|
||||
(list (quote f) (quote X) (quote Y)))
|
||||
(list {:X 1 :Y 4} {:X 2 :Y 6} {:X 3 :Y 8}))
|
||||
(dl-bt-test-set!
|
||||
"is bound LHS — equality"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"n(1, 2). n(2, 5). n(3, 4).\n succ(X, Y) :- n(X, Y), is(Y, +(X, 1)).")
|
||||
(list (quote succ) (quote X) (quote Y)))
|
||||
(list {:X 1 :Y 2} {:X 3 :Y 4}))
|
||||
(dl-bt-test-set!
|
||||
"triple via is"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"n(1). n(2). n(3).\n triple(X, Y) :- n(X), is(Y, *(X, 3)).")
|
||||
(list (quote triple) (quote X) (quote Y)))
|
||||
(list {:X 1 :Y 3} {:X 2 :Y 6} {:X 3 :Y 9}))
|
||||
(dl-bt-test-set!
|
||||
"= unifies var with constant"
|
||||
(dl-query
|
||||
(dl-program "p(a). p(b).\n qual(X) :- p(X), =(X, a).")
|
||||
(list (quote qual) (quote X)))
|
||||
(list {:X (quote a)}))
|
||||
(dl-bt-test-set!
|
||||
"= unifies two vars (one bound)"
|
||||
(dl-query
|
||||
(dl-program "p(a). p(b).\n twin(X, Y) :- p(X), =(Y, X).")
|
||||
(list (quote twin) (quote X) (quote Y)))
|
||||
(list {:X (quote a) :Y (quote a)} {:X (quote b) :Y (quote b)}))
|
||||
(dl-bt-test!
|
||||
"big count"
|
||||
(let
|
||||
((db (dl-program "n(0). n(1). n(2). n(3). n(4). n(5). n(6). n(7). n(8). n(9).\n big(X) :- n(X), >=(X, 5).")))
|
||||
(do (dl-saturate! db) (len (dl-relation db "big"))))
|
||||
5)
|
||||
(dl-bt-test!
|
||||
"unsafe — comparison without binder"
|
||||
(dl-bt-throws? (fn () (dl-program "p(X) :- <(X, 5).")))
|
||||
true)
|
||||
(dl-bt-test!
|
||||
"unsafe — comparison both unbound"
|
||||
(dl-bt-throws? (fn () (dl-program "p(X, Y) :- <(X, Y), q(X).")))
|
||||
true)
|
||||
(dl-bt-test!
|
||||
"unsafe — is uses unbound RHS var"
|
||||
(dl-bt-throws?
|
||||
(fn () (dl-program "p(X, Y) :- q(X), is(Y, +(X, Z)).")))
|
||||
true)
|
||||
(dl-bt-test!
|
||||
"unsafe — is on its own"
|
||||
(dl-bt-throws? (fn () (dl-program "p(Y) :- is(Y, +(X, 1)).")))
|
||||
true)
|
||||
(dl-bt-test!
|
||||
"unsafe — = between two unbound"
|
||||
(dl-bt-throws? (fn () (dl-program "p(X, Y) :- =(X, Y).")))
|
||||
true)
|
||||
(dl-bt-test!
|
||||
"safe — is binds head var"
|
||||
(dl-bt-throws?
|
||||
(fn () (dl-program "n(1). p(Y) :- n(X), is(Y, +(X, 1)).")))
|
||||
false)
|
||||
(dl-bt-test!
|
||||
"safe — comparison after binder"
|
||||
(dl-bt-throws?
|
||||
(fn () (dl-program "n(1). big(X) :- n(X), >=(X, 0).")))
|
||||
false)
|
||||
(dl-bt-test!
|
||||
"safe — = binds head var"
|
||||
(dl-bt-throws?
|
||||
(fn () (dl-program "p(a). p(b). x(Y) :- p(X), =(Y, X).")))
|
||||
false))))
|
||||
|
||||
(define
|
||||
dl-builtins-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-bt-pass 0)
|
||||
(set! dl-bt-fail 0)
|
||||
(set! dl-bt-failures (list))
|
||||
(dl-bt-run-all!)
|
||||
{:failures dl-bt-failures :total (+ dl-bt-pass dl-bt-fail) :passed dl-bt-pass :failed dl-bt-fail})))
|
||||
@@ -1,206 +0,0 @@
|
||||
;; lib/datalog/tests/eval.sx — naive evaluation + safety analysis tests.
|
||||
|
||||
(define dl-et-pass 0)
|
||||
(define dl-et-fail 0)
|
||||
(define dl-et-failures (list))
|
||||
|
||||
;; Same deep-equal helper used in other suites.
|
||||
(define
|
||||
dl-et-deep=?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-et-deq-l? a b 0)))
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ka (keys a)) (kb (keys b)))
|
||||
(and (= (len ka) (len kb)) (dl-et-deq-d? a b ka 0))))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-et-deq-l?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-et-deep=? (nth a i) (nth b i))) false)
|
||||
(else (dl-et-deq-l? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-et-deq-d?
|
||||
(fn
|
||||
(a b ka i)
|
||||
(cond
|
||||
((>= i (len ka)) true)
|
||||
((let ((k (nth ka i))) (not (dl-et-deep=? (get a k) (get b k))))
|
||||
false)
|
||||
(else (dl-et-deq-d? a b ka (+ i 1))))))
|
||||
|
||||
;; Set-equality on lists (order-independent, uses dl-et-deep=?).
|
||||
(define
|
||||
dl-et-set=?
|
||||
(fn
|
||||
(a b)
|
||||
(and (= (len a) (len b)) (dl-et-subset? a b) (dl-et-subset? b a))))
|
||||
|
||||
(define
|
||||
dl-et-subset?
|
||||
(fn
|
||||
(xs ys)
|
||||
(cond
|
||||
((= (len xs) 0) true)
|
||||
((not (dl-et-contains? ys (first xs))) false)
|
||||
(else (dl-et-subset? (rest xs) ys)))))
|
||||
|
||||
(define
|
||||
dl-et-contains?
|
||||
(fn
|
||||
(xs target)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((dl-et-deep=? (first xs) target) true)
|
||||
(else (dl-et-contains? (rest xs) target)))))
|
||||
|
||||
(define
|
||||
dl-et-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-et-deep=? got expected)
|
||||
(set! dl-et-pass (+ dl-et-pass 1))
|
||||
(do
|
||||
(set! dl-et-fail (+ dl-et-fail 1))
|
||||
(append!
|
||||
dl-et-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-et-test-set!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-et-set=? got expected)
|
||||
(set! dl-et-pass (+ dl-et-pass 1))
|
||||
(do
|
||||
(set! dl-et-fail (+ dl-et-fail 1))
|
||||
(append!
|
||||
dl-et-failures
|
||||
(str
|
||||
name
|
||||
"\n expected (set): "
|
||||
expected
|
||||
"\n got: "
|
||||
got))))))
|
||||
|
||||
(define
|
||||
dl-et-throws?
|
||||
(fn
|
||||
(thunk)
|
||||
(let
|
||||
((threw false))
|
||||
(do (guard (e (#t (set! threw true))) (thunk)) threw))))
|
||||
|
||||
(define
|
||||
dl-et-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(dl-et-test-set!
|
||||
"fact lookup any"
|
||||
(dl-query
|
||||
(dl-program "parent(tom, bob). parent(bob, ann).")
|
||||
(list (quote parent) (quote X) (quote Y)))
|
||||
(list {:X (quote tom) :Y (quote bob)} {:X (quote bob) :Y (quote ann)}))
|
||||
(dl-et-test-set!
|
||||
"fact lookup constant arg"
|
||||
(dl-query
|
||||
(dl-program "parent(tom, bob). parent(tom, liz). parent(bob, ann).")
|
||||
(list (quote parent) (quote tom) (quote Y)))
|
||||
(list {:Y (quote bob)} {:Y (quote liz)}))
|
||||
(dl-et-test-set!
|
||||
"no match"
|
||||
(dl-query
|
||||
(dl-program "parent(tom, bob).")
|
||||
(list (quote parent) (quote nobody) (quote X)))
|
||||
(list))
|
||||
(dl-et-test-set!
|
||||
"ancestor closure"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"parent(tom, bob). parent(bob, ann). parent(ann, pat).\n ancestor(X, Y) :- parent(X, Y).\n ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
|
||||
(list (quote ancestor) (quote tom) (quote X)))
|
||||
(list {:X (quote bob)} {:X (quote ann)} {:X (quote pat)}))
|
||||
(dl-et-test-set!
|
||||
"sibling"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"parent(tom, bob). parent(tom, liz). parent(jane, bob). parent(jane, liz).\n sibling(X, Y) :- parent(P, X), parent(P, Y).")
|
||||
(list (quote sibling) (quote bob) (quote Y)))
|
||||
(list {:Y (quote bob)} {:Y (quote liz)}))
|
||||
(dl-et-test-set!
|
||||
"same-generation"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"parent(tom, bob). parent(tom, liz). parent(bob, ann). parent(liz, joe).\n person(tom). person(bob). person(liz). person(ann). person(joe).\n sg(X, X) :- person(X).\n sg(X, Y) :- parent(P1, X), sg(P1, P2), parent(P2, Y).")
|
||||
(list (quote sg) (quote ann) (quote X)))
|
||||
(list {:X (quote ann)} {:X (quote joe)}))
|
||||
(dl-et-test!
|
||||
"ancestor count"
|
||||
(let
|
||||
((db (dl-program "parent(a, b). parent(b, c). parent(c, d).\n ancestor(X, Y) :- parent(X, Y).\n ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")))
|
||||
(do (dl-saturate! db) (len (dl-relation db "ancestor"))))
|
||||
6)
|
||||
(dl-et-test-set!
|
||||
"grandparent"
|
||||
(dl-query
|
||||
(dl-program
|
||||
"parent(a, b). parent(b, c). parent(c, d).\n grandparent(X, Z) :- parent(X, Y), parent(Y, Z).")
|
||||
(list (quote grandparent) (quote X) (quote Y)))
|
||||
(list {:X (quote a) :Y (quote c)} {:X (quote b) :Y (quote d)}))
|
||||
(dl-et-test!
|
||||
"no recursion infinite loop"
|
||||
(let
|
||||
((db (dl-program "edge(1, 2). edge(2, 3). edge(3, 1).\n reach(X, Y) :- edge(X, Y).\n reach(X, Z) :- edge(X, Y), reach(Y, Z).")))
|
||||
(do (dl-saturate! db) (len (dl-relation db "reach"))))
|
||||
9)
|
||||
(dl-et-test!
|
||||
"unsafe head var"
|
||||
(dl-et-throws? (fn () (dl-program "p(X, Y) :- q(X).")))
|
||||
true)
|
||||
(dl-et-test!
|
||||
"unsafe — empty body"
|
||||
(dl-et-throws? (fn () (dl-program "p(X) :- .")))
|
||||
true)
|
||||
(dl-et-test!
|
||||
"underscore var ok"
|
||||
(dl-et-throws? (fn () (dl-program "p(X, _) :- q(X).")))
|
||||
false)
|
||||
(dl-et-test!
|
||||
"var only in head — unsafe"
|
||||
(dl-et-throws? (fn () (dl-program "p(X, Y) :- q(Z).")))
|
||||
true)
|
||||
(dl-et-test!
|
||||
"head var bound by body"
|
||||
(dl-et-throws? (fn () (dl-program "p(X) :- q(X).")))
|
||||
false)
|
||||
(dl-et-test!
|
||||
"head subset of body"
|
||||
(dl-et-throws?
|
||||
(fn
|
||||
()
|
||||
(dl-program
|
||||
"edge(a,b). edge(b,c). reach(X, Z) :- edge(X, Y), edge(Y, Z).")))
|
||||
false))))
|
||||
|
||||
(define
|
||||
dl-eval-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-et-pass 0)
|
||||
(set! dl-et-fail 0)
|
||||
(set! dl-et-failures (list))
|
||||
(dl-et-run-all!)
|
||||
{:failures dl-et-failures :total (+ dl-et-pass dl-et-fail) :passed dl-et-pass :failed dl-et-fail})))
|
||||
@@ -1,147 +0,0 @@
|
||||
;; lib/datalog/tests/parse.sx — parser unit tests
|
||||
;;
|
||||
;; Run via: bash lib/datalog/conformance.sh
|
||||
;; Or: (load "lib/datalog/tokenizer.sx") (load "lib/datalog/parser.sx")
|
||||
;; (load "lib/datalog/tests/parse.sx") (dl-parse-tests-run!)
|
||||
|
||||
(define dl-pt-pass 0)
|
||||
(define dl-pt-fail 0)
|
||||
(define dl-pt-failures (list))
|
||||
|
||||
;; Order-independent structural equality. Lists compared positionally,
|
||||
;; dicts as sets of (key, value) pairs. Numbers via = (so 30.0 = 30).
|
||||
(define
|
||||
dl-deep-equal?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-deep-equal-list? a b 0)))
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ka (keys a)) (kb (keys b)))
|
||||
(and
|
||||
(= (len ka) (len kb))
|
||||
(dl-deep-equal-dict? a b ka 0))))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-deep-equal-list?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-deep-equal? (nth a i) (nth b i))) false)
|
||||
(else (dl-deep-equal-list? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-deep-equal-dict?
|
||||
(fn
|
||||
(a b ka i)
|
||||
(cond
|
||||
((>= i (len ka)) true)
|
||||
((let ((k (nth ka i))) (not (dl-deep-equal? (get a k) (get b k))))
|
||||
false)
|
||||
(else (dl-deep-equal-dict? a b ka (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-pt-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-deep-equal? got expected)
|
||||
(set! dl-pt-pass (+ dl-pt-pass 1))
|
||||
(do
|
||||
(set! dl-pt-fail (+ dl-pt-fail 1))
|
||||
(append!
|
||||
dl-pt-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-pt-throws?
|
||||
(fn
|
||||
(thunk)
|
||||
(let
|
||||
((threw false))
|
||||
(do (guard (e (#t (set! threw true))) (thunk)) threw))))
|
||||
|
||||
(define
|
||||
dl-pt-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(dl-pt-test! "empty program" (dl-parse "") (list))
|
||||
(dl-pt-test! "fact" (dl-parse "parent(tom, bob).") (list {:body (list) :head (list (quote parent) (quote tom) (quote bob))}))
|
||||
(dl-pt-test!
|
||||
"two facts"
|
||||
(dl-parse "parent(tom, bob). parent(bob, ann).")
|
||||
(list {:body (list) :head (list (quote parent) (quote tom) (quote bob))} {:body (list) :head (list (quote parent) (quote bob) (quote ann))}))
|
||||
(dl-pt-test! "zero-ary fact" (dl-parse "ready.") (list {:body (list) :head (list (quote ready))}))
|
||||
(dl-pt-test!
|
||||
"rule one body lit"
|
||||
(dl-parse "ancestor(X, Y) :- parent(X, Y).")
|
||||
(list {:body (list (list (quote parent) (quote X) (quote Y))) :head (list (quote ancestor) (quote X) (quote Y))}))
|
||||
(dl-pt-test!
|
||||
"recursive rule"
|
||||
(dl-parse "ancestor(X, Z) :- parent(X, Y), ancestor(Y, Z).")
|
||||
(list {:body (list (list (quote parent) (quote X) (quote Y)) (list (quote ancestor) (quote Y) (quote Z))) :head (list (quote ancestor) (quote X) (quote Z))}))
|
||||
(dl-pt-test!
|
||||
"query single"
|
||||
(dl-parse "?- ancestor(tom, X).")
|
||||
(list {:query (list (list (quote ancestor) (quote tom) (quote X)))}))
|
||||
(dl-pt-test!
|
||||
"query multi"
|
||||
(dl-parse "?- p(X), q(X).")
|
||||
(list {:query (list (list (quote p) (quote X)) (list (quote q) (quote X)))}))
|
||||
(dl-pt-test!
|
||||
"negation"
|
||||
(dl-parse "safe(X) :- person(X), not(parent(X, _)).")
|
||||
(list {:body (list (list (quote person) (quote X)) {:neg (list (quote parent) (quote X) (quote _))}) :head (list (quote safe) (quote X))}))
|
||||
(dl-pt-test!
|
||||
"number arg"
|
||||
(dl-parse "age(alice, 30).")
|
||||
(list {:body (list) :head (list (quote age) (quote alice) 30)}))
|
||||
(dl-pt-test!
|
||||
"string arg"
|
||||
(dl-parse "label(x, \"hi\").")
|
||||
(list {:body (list) :head (list (quote label) (quote x) "hi")}))
|
||||
(dl-pt-test!
|
||||
"comparison literal"
|
||||
(dl-parse "p(X) :- <(X, 5).")
|
||||
(list {:body (list (list (string->symbol "<") (quote X) 5)) :head (list (quote p) (quote X))}))
|
||||
(dl-pt-test!
|
||||
"is with arith"
|
||||
(dl-parse "succ(X, Y) :- nat(X), is(Y, +(X, 1)).")
|
||||
(list {:body (list (list (quote nat) (quote X)) (list (quote is) (quote Y) (list (string->symbol "+") (quote X) 1))) :head (list (quote succ) (quote X) (quote Y))}))
|
||||
(dl-pt-test!
|
||||
"mixed program"
|
||||
(dl-parse "p(a). p(b). q(X) :- p(X). ?- q(Y).")
|
||||
(list {:body (list) :head (list (quote p) (quote a))} {:body (list) :head (list (quote p) (quote b))} {:body (list (list (quote p) (quote X))) :head (list (quote q) (quote X))} {:query (list (list (quote q) (quote Y)))}))
|
||||
(dl-pt-test!
|
||||
"comments skipped"
|
||||
(dl-parse "% comment\nfoo(a).\n/* block */ bar(b).")
|
||||
(list {:body (list) :head (list (quote foo) (quote a))} {:body (list) :head (list (quote bar) (quote b))}))
|
||||
(dl-pt-test!
|
||||
"underscore var"
|
||||
(dl-parse "p(X) :- q(X, _).")
|
||||
(list {:body (list (list (quote q) (quote X) (quote _))) :head (list (quote p) (quote X))}))
|
||||
(dl-pt-test!
|
||||
"missing dot raises"
|
||||
(dl-pt-throws? (fn () (dl-parse "p(a)")))
|
||||
true)
|
||||
(dl-pt-test!
|
||||
"trailing comma raises"
|
||||
(dl-pt-throws? (fn () (dl-parse "p(a,).")))
|
||||
true))))
|
||||
|
||||
(define
|
||||
dl-parse-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-pt-pass 0)
|
||||
(set! dl-pt-fail 0)
|
||||
(set! dl-pt-failures (list))
|
||||
(dl-pt-run-all!)
|
||||
{:failures dl-pt-failures :total (+ dl-pt-pass dl-pt-fail) :passed dl-pt-pass :failed dl-pt-fail})))
|
||||
@@ -1,139 +0,0 @@
|
||||
;; lib/datalog/tests/tokenize.sx — tokenizer unit tests
|
||||
;;
|
||||
;; Run via: bash lib/datalog/conformance.sh
|
||||
;; Or: (load "lib/datalog/tokenizer.sx") (load "lib/datalog/tests/tokenize.sx")
|
||||
;; (dl-tokenize-tests-run!)
|
||||
|
||||
(define dl-tk-pass 0)
|
||||
(define dl-tk-fail 0)
|
||||
(define dl-tk-failures (list))
|
||||
|
||||
(define
|
||||
dl-tk-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! dl-tk-pass (+ dl-tk-pass 1))
|
||||
(do
|
||||
(set! dl-tk-fail (+ dl-tk-fail 1))
|
||||
(append!
|
||||
dl-tk-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define dl-tk-types (fn (toks) (map (fn (t) (get t :type)) toks)))
|
||||
(define dl-tk-values (fn (toks) (map (fn (t) (get t :value)) toks)))
|
||||
|
||||
(define
|
||||
dl-tk-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(dl-tk-test! "empty" (dl-tk-types (dl-tokenize "")) (list "eof"))
|
||||
(dl-tk-test!
|
||||
"atom dot"
|
||||
(dl-tk-types (dl-tokenize "foo."))
|
||||
(list "atom" "punct" "eof"))
|
||||
(dl-tk-test!
|
||||
"atom dot value"
|
||||
(dl-tk-values (dl-tokenize "foo."))
|
||||
(list "foo" "." nil))
|
||||
(dl-tk-test!
|
||||
"var"
|
||||
(dl-tk-types (dl-tokenize "X."))
|
||||
(list "var" "punct" "eof"))
|
||||
(dl-tk-test!
|
||||
"underscore var"
|
||||
(dl-tk-types (dl-tokenize "_x."))
|
||||
(list "var" "punct" "eof"))
|
||||
(dl-tk-test!
|
||||
"integer"
|
||||
(dl-tk-values (dl-tokenize "42"))
|
||||
(list 42 nil))
|
||||
(dl-tk-test!
|
||||
"decimal"
|
||||
(dl-tk-values (dl-tokenize "3.14"))
|
||||
(list 3.14 nil))
|
||||
(dl-tk-test!
|
||||
"string"
|
||||
(dl-tk-values (dl-tokenize "\"hello\""))
|
||||
(list "hello" nil))
|
||||
(dl-tk-test!
|
||||
"quoted atom"
|
||||
(dl-tk-types (dl-tokenize "'two words'"))
|
||||
(list "atom" "eof"))
|
||||
(dl-tk-test!
|
||||
"quoted atom value"
|
||||
(dl-tk-values (dl-tokenize "'two words'"))
|
||||
(list "two words" nil))
|
||||
(dl-tk-test! ":-" (dl-tk-values (dl-tokenize ":-")) (list ":-" nil))
|
||||
(dl-tk-test! "?-" (dl-tk-values (dl-tokenize "?-")) (list "?-" nil))
|
||||
(dl-tk-test! "<=" (dl-tk-values (dl-tokenize "<=")) (list "<=" nil))
|
||||
(dl-tk-test! ">=" (dl-tk-values (dl-tokenize ">=")) (list ">=" nil))
|
||||
(dl-tk-test! "!=" (dl-tk-values (dl-tokenize "!=")) (list "!=" nil))
|
||||
(dl-tk-test!
|
||||
"single op values"
|
||||
(dl-tk-values (dl-tokenize "< > = + - * /"))
|
||||
(list "<" ">" "=" "+" "-" "*" "/" nil))
|
||||
(dl-tk-test!
|
||||
"single op types"
|
||||
(dl-tk-types (dl-tokenize "< > = + - * /"))
|
||||
(list "op" "op" "op" "op" "op" "op" "op" "eof"))
|
||||
(dl-tk-test!
|
||||
"punct"
|
||||
(dl-tk-values (dl-tokenize "( ) , ."))
|
||||
(list "(" ")" "," "." nil))
|
||||
(dl-tk-test!
|
||||
"fact tokens"
|
||||
(dl-tk-types (dl-tokenize "parent(tom, bob)."))
|
||||
(list "atom" "punct" "atom" "punct" "atom" "punct" "punct" "eof"))
|
||||
(dl-tk-test!
|
||||
"rule shape"
|
||||
(dl-tk-types (dl-tokenize "p(X) :- q(X)."))
|
||||
(list
|
||||
"atom"
|
||||
"punct"
|
||||
"var"
|
||||
"punct"
|
||||
"op"
|
||||
"atom"
|
||||
"punct"
|
||||
"var"
|
||||
"punct"
|
||||
"punct"
|
||||
"eof"))
|
||||
(dl-tk-test!
|
||||
"comparison literal"
|
||||
(dl-tk-values (dl-tokenize "<(X, 5)"))
|
||||
(list "<" "(" "X" "," 5 ")" nil))
|
||||
(dl-tk-test!
|
||||
"is form"
|
||||
(dl-tk-values (dl-tokenize "is(Y, +(X, 1))"))
|
||||
(list "is" "(" "Y" "," "+" "(" "X" "," 1 ")" ")" nil))
|
||||
(dl-tk-test!
|
||||
"line comment"
|
||||
(dl-tk-types (dl-tokenize "% comment line\nfoo."))
|
||||
(list "atom" "punct" "eof"))
|
||||
(dl-tk-test!
|
||||
"block comment"
|
||||
(dl-tk-types (dl-tokenize "/* a\nb */ x."))
|
||||
(list "atom" "punct" "eof"))
|
||||
(dl-tk-test!
|
||||
"whitespace"
|
||||
(dl-tk-types (dl-tokenize " foo ,\t bar ."))
|
||||
(list "atom" "punct" "atom" "punct" "eof"))
|
||||
(dl-tk-test!
|
||||
"positions"
|
||||
(map (fn (t) (get t :pos)) (dl-tokenize "foo bar"))
|
||||
(list 0 4 7)))))
|
||||
|
||||
(define
|
||||
dl-tokenize-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-tk-pass 0)
|
||||
(set! dl-tk-fail 0)
|
||||
(set! dl-tk-failures (list))
|
||||
(dl-tk-run-all!)
|
||||
{:failures dl-tk-failures :total (+ dl-tk-pass dl-tk-fail) :passed dl-tk-pass :failed dl-tk-fail})))
|
||||
@@ -1,185 +0,0 @@
|
||||
;; lib/datalog/tests/unify.sx — unification + substitution tests.
|
||||
|
||||
(define dl-ut-pass 0)
|
||||
(define dl-ut-fail 0)
|
||||
(define dl-ut-failures (list))
|
||||
|
||||
(define
|
||||
dl-ut-deep-equal?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (dl-ut-deq-list? a b 0)))
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ka (keys a)) (kb (keys b)))
|
||||
(and (= (len ka) (len kb)) (dl-ut-deq-dict? a b ka 0))))
|
||||
((and (number? a) (number? b)) (= a b))
|
||||
(else (equal? a b)))))
|
||||
|
||||
(define
|
||||
dl-ut-deq-list?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (dl-ut-deep-equal? (nth a i) (nth b i))) false)
|
||||
(else (dl-ut-deq-list? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-ut-deq-dict?
|
||||
(fn
|
||||
(a b ka i)
|
||||
(cond
|
||||
((>= i (len ka)) true)
|
||||
((let ((k (nth ka i))) (not (dl-ut-deep-equal? (get a k) (get b k))))
|
||||
false)
|
||||
(else (dl-ut-deq-dict? a b ka (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-ut-test!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(dl-ut-deep-equal? got expected)
|
||||
(set! dl-ut-pass (+ dl-ut-pass 1))
|
||||
(do
|
||||
(set! dl-ut-fail (+ dl-ut-fail 1))
|
||||
(append!
|
||||
dl-ut-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define
|
||||
dl-ut-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(dl-ut-test! "var? uppercase" (dl-var? (quote X)) true)
|
||||
(dl-ut-test! "var? underscore" (dl-var? (quote _foo)) true)
|
||||
(dl-ut-test! "var? lowercase" (dl-var? (quote tom)) false)
|
||||
(dl-ut-test! "var? number" (dl-var? 5) false)
|
||||
(dl-ut-test! "var? string" (dl-var? "hi") false)
|
||||
(dl-ut-test! "var? list" (dl-var? (list 1)) false)
|
||||
(dl-ut-test!
|
||||
"atom-atom match"
|
||||
(dl-unify (quote tom) (quote tom) (dl-empty-subst))
|
||||
{})
|
||||
(dl-ut-test!
|
||||
"atom-atom fail"
|
||||
(dl-unify (quote tom) (quote bob) (dl-empty-subst))
|
||||
nil)
|
||||
(dl-ut-test!
|
||||
"num-num match"
|
||||
(dl-unify 5 5 (dl-empty-subst))
|
||||
{})
|
||||
(dl-ut-test!
|
||||
"num-num fail"
|
||||
(dl-unify 5 6 (dl-empty-subst))
|
||||
nil)
|
||||
(dl-ut-test!
|
||||
"string match"
|
||||
(dl-unify "hi" "hi" (dl-empty-subst))
|
||||
{})
|
||||
(dl-ut-test! "string fail" (dl-unify "hi" "bye" (dl-empty-subst)) nil)
|
||||
(dl-ut-test!
|
||||
"var-atom binds"
|
||||
(dl-unify (quote X) (quote tom) (dl-empty-subst))
|
||||
{:X (quote tom)})
|
||||
(dl-ut-test!
|
||||
"atom-var binds"
|
||||
(dl-unify (quote tom) (quote X) (dl-empty-subst))
|
||||
{:X (quote tom)})
|
||||
(dl-ut-test!
|
||||
"var-var same"
|
||||
(dl-unify (quote X) (quote X) (dl-empty-subst))
|
||||
{})
|
||||
(dl-ut-test!
|
||||
"var-var bind"
|
||||
(let
|
||||
((s (dl-unify (quote X) (quote Y) (dl-empty-subst))))
|
||||
(dl-walk (quote X) s))
|
||||
(quote Y))
|
||||
(dl-ut-test!
|
||||
"tuple match"
|
||||
(dl-unify
|
||||
(list (quote parent) (quote X) (quote bob))
|
||||
(list (quote parent) (quote tom) (quote Y))
|
||||
(dl-empty-subst))
|
||||
{:X (quote tom) :Y (quote bob)})
|
||||
(dl-ut-test!
|
||||
"tuple arity mismatch"
|
||||
(dl-unify
|
||||
(list (quote p) (quote X))
|
||||
(list (quote p) (quote a) (quote b))
|
||||
(dl-empty-subst))
|
||||
nil)
|
||||
(dl-ut-test!
|
||||
"tuple head mismatch"
|
||||
(dl-unify
|
||||
(list (quote p) (quote X))
|
||||
(list (quote q) (quote X))
|
||||
(dl-empty-subst))
|
||||
nil)
|
||||
(dl-ut-test!
|
||||
"walk chain"
|
||||
(let
|
||||
((s1 (dl-unify (quote X) (quote Y) (dl-empty-subst))))
|
||||
(let
|
||||
((s2 (dl-unify (quote Y) (quote tom) s1)))
|
||||
(dl-walk (quote X) s2)))
|
||||
(quote tom))
|
||||
(dl-ut-test!
|
||||
"apply subst on tuple"
|
||||
(let
|
||||
((s (dl-bind (quote X) (quote tom) (dl-empty-subst))))
|
||||
(dl-apply-subst (list (quote parent) (quote X) (quote Y)) s))
|
||||
(list (quote parent) (quote tom) (quote Y)))
|
||||
(dl-ut-test!
|
||||
"ground? all const"
|
||||
(dl-ground?
|
||||
(list (quote p) (quote tom) 5)
|
||||
(dl-empty-subst))
|
||||
true)
|
||||
(dl-ut-test!
|
||||
"ground? unbound var"
|
||||
(dl-ground? (list (quote p) (quote X)) (dl-empty-subst))
|
||||
false)
|
||||
(dl-ut-test!
|
||||
"ground? bound var"
|
||||
(let
|
||||
((s (dl-bind (quote X) (quote tom) (dl-empty-subst))))
|
||||
(dl-ground? (list (quote p) (quote X)) s))
|
||||
true)
|
||||
(dl-ut-test!
|
||||
"ground? bare var"
|
||||
(dl-ground? (quote X) (dl-empty-subst))
|
||||
false)
|
||||
(dl-ut-test!
|
||||
"vars-of basic"
|
||||
(dl-vars-of
|
||||
(list (quote p) (quote X) (quote tom) (quote Y) (quote X)))
|
||||
(list "X" "Y"))
|
||||
(dl-ut-test!
|
||||
"vars-of ground"
|
||||
(dl-vars-of (list (quote p) (quote tom) (quote bob)))
|
||||
(list))
|
||||
(dl-ut-test!
|
||||
"vars-of nested compound"
|
||||
(dl-vars-of
|
||||
(list
|
||||
(quote is)
|
||||
(quote Z)
|
||||
(list (string->symbol "+") (quote X) 1)))
|
||||
(list "Z" "X")))))
|
||||
|
||||
(define
|
||||
dl-unify-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! dl-ut-pass 0)
|
||||
(set! dl-ut-fail 0)
|
||||
(set! dl-ut-failures (list))
|
||||
(dl-ut-run-all!)
|
||||
{:failures dl-ut-failures :total (+ dl-ut-pass dl-ut-fail) :passed dl-ut-pass :failed dl-ut-fail})))
|
||||
@@ -1,254 +0,0 @@
|
||||
;; lib/datalog/tokenizer.sx — Datalog source → token stream
|
||||
;;
|
||||
;; Tokens: {:type T :value V :pos P}
|
||||
;; Types:
|
||||
;; "atom" — lowercase-start ident or quoted 'atom'
|
||||
;; "var" — uppercase-start or _-start ident (value is the name)
|
||||
;; "number" — numeric literal (decoded to number)
|
||||
;; "string" — "..." string literal
|
||||
;; "punct" — ( ) , .
|
||||
;; "op" — :- ?- <= >= != < > = + - * /
|
||||
;; "eof"
|
||||
;;
|
||||
;; Datalog has no function symbols in arg position; the parser still
|
||||
;; accepts nested compounds for arithmetic ((is X (+ A B))) but safety
|
||||
;; analysis rejects non-arithmetic nesting at rule-load time.
|
||||
|
||||
(define dl-make-token (fn (type value pos) {:type type :value value :pos pos}))
|
||||
|
||||
(define dl-digit? (fn (c) (and (>= c "0") (<= c "9"))))
|
||||
(define dl-lower? (fn (c) (and (>= c "a") (<= c "z"))))
|
||||
(define dl-upper? (fn (c) (and (>= c "A") (<= c "Z"))))
|
||||
|
||||
(define
|
||||
dl-ident-char?
|
||||
(fn (c) (or (dl-lower? c) (dl-upper? c) (dl-digit? c) (= c "_"))))
|
||||
|
||||
(define dl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
|
||||
|
||||
(define
|
||||
dl-tokenize
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((tokens (list)) (pos 0) (src-len (len src)))
|
||||
(define
|
||||
dl-peek
|
||||
(fn
|
||||
(offset)
|
||||
(if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
|
||||
(define cur (fn () (dl-peek 0)))
|
||||
(define advance! (fn (n) (set! pos (+ pos n))))
|
||||
(define
|
||||
at?
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((sl (len s)))
|
||||
(and (<= (+ pos sl) src-len) (= (slice src pos (+ pos sl)) s)))))
|
||||
(define
|
||||
dl-emit!
|
||||
(fn
|
||||
(type value start)
|
||||
(append! tokens (dl-make-token type value start))))
|
||||
(define
|
||||
skip-line-comment!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (not (= (cur) "\n")))
|
||||
(do (advance! 1) (skip-line-comment!)))))
|
||||
(define
|
||||
skip-block-comment!
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len) nil)
|
||||
((and (= (cur) "*") (< (+ pos 1) src-len) (= (dl-peek 1) "/"))
|
||||
(advance! 2))
|
||||
(else (do (advance! 1) (skip-block-comment!))))))
|
||||
(define
|
||||
skip-ws!
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len) nil)
|
||||
((dl-ws? (cur)) (do (advance! 1) (skip-ws!)))
|
||||
((= (cur) "%")
|
||||
(do (advance! 1) (skip-line-comment!) (skip-ws!)))
|
||||
((and (= (cur) "/") (< (+ pos 1) src-len) (= (dl-peek 1) "*"))
|
||||
(do (advance! 2) (skip-block-comment!) (skip-ws!)))
|
||||
(else nil))))
|
||||
(define
|
||||
read-ident
|
||||
(fn
|
||||
(start)
|
||||
(do
|
||||
(when
|
||||
(and (< pos src-len) (dl-ident-char? (cur)))
|
||||
(do (advance! 1) (read-ident start)))
|
||||
(slice src start pos))))
|
||||
(define
|
||||
read-decimal-digits!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (dl-digit? (cur)))
|
||||
(do (advance! 1) (read-decimal-digits!)))))
|
||||
(define
|
||||
read-number
|
||||
(fn
|
||||
(start)
|
||||
(do
|
||||
(read-decimal-digits!)
|
||||
(when
|
||||
(and
|
||||
(< pos src-len)
|
||||
(= (cur) ".")
|
||||
(< (+ pos 1) src-len)
|
||||
(dl-digit? (dl-peek 1)))
|
||||
(do (advance! 1) (read-decimal-digits!)))
|
||||
(parse-number (slice src start pos)))))
|
||||
(define
|
||||
read-quoted
|
||||
(fn
|
||||
(quote-char)
|
||||
(let
|
||||
((chars (list)))
|
||||
(advance! 1)
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len) nil)
|
||||
((= (cur) "\\")
|
||||
(do
|
||||
(advance! 1)
|
||||
(when
|
||||
(< pos src-len)
|
||||
(let
|
||||
((ch (cur)))
|
||||
(do
|
||||
(cond
|
||||
((= ch "n") (append! chars "\n"))
|
||||
((= ch "t") (append! chars "\t"))
|
||||
((= ch "r") (append! chars "\r"))
|
||||
((= ch "\\") (append! chars "\\"))
|
||||
((= ch "'") (append! chars "'"))
|
||||
((= ch "\"") (append! chars "\""))
|
||||
(else (append! chars ch)))
|
||||
(advance! 1))))
|
||||
(loop)))
|
||||
((= (cur) quote-char) (advance! 1))
|
||||
(else
|
||||
(do (append! chars (cur)) (advance! 1) (loop))))))
|
||||
(loop)
|
||||
(join "" chars))))
|
||||
(define
|
||||
scan!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(skip-ws!)
|
||||
(when
|
||||
(< pos src-len)
|
||||
(let
|
||||
((ch (cur)) (start pos))
|
||||
(cond
|
||||
((at? ":-")
|
||||
(do
|
||||
(dl-emit! "op" ":-" start)
|
||||
(advance! 2)
|
||||
(scan!)))
|
||||
((at? "?-")
|
||||
(do
|
||||
(dl-emit! "op" "?-" start)
|
||||
(advance! 2)
|
||||
(scan!)))
|
||||
((at? "<=")
|
||||
(do
|
||||
(dl-emit! "op" "<=" start)
|
||||
(advance! 2)
|
||||
(scan!)))
|
||||
((at? ">=")
|
||||
(do
|
||||
(dl-emit! "op" ">=" start)
|
||||
(advance! 2)
|
||||
(scan!)))
|
||||
((at? "!=")
|
||||
(do
|
||||
(dl-emit! "op" "!=" start)
|
||||
(advance! 2)
|
||||
(scan!)))
|
||||
((dl-digit? ch)
|
||||
(do
|
||||
(dl-emit! "number" (read-number start) start)
|
||||
(scan!)))
|
||||
((= ch "'")
|
||||
(do (dl-emit! "atom" (read-quoted "'") start) (scan!)))
|
||||
((= ch "\"")
|
||||
(do (dl-emit! "string" (read-quoted "\"") start) (scan!)))
|
||||
((dl-lower? ch)
|
||||
(do (dl-emit! "atom" (read-ident start) start) (scan!)))
|
||||
((or (dl-upper? ch) (= ch "_"))
|
||||
(do (dl-emit! "var" (read-ident start) start) (scan!)))
|
||||
((= ch "(")
|
||||
(do
|
||||
(dl-emit! "punct" "(" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch ")")
|
||||
(do
|
||||
(dl-emit! "punct" ")" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch ",")
|
||||
(do
|
||||
(dl-emit! "punct" "," start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch ".")
|
||||
(do
|
||||
(dl-emit! "punct" "." start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch "<")
|
||||
(do
|
||||
(dl-emit! "op" "<" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch ">")
|
||||
(do
|
||||
(dl-emit! "op" ">" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch "=")
|
||||
(do
|
||||
(dl-emit! "op" "=" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch "+")
|
||||
(do
|
||||
(dl-emit! "op" "+" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch "-")
|
||||
(do
|
||||
(dl-emit! "op" "-" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch "*")
|
||||
(do
|
||||
(dl-emit! "op" "*" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
((= ch "/")
|
||||
(do
|
||||
(dl-emit! "op" "/" start)
|
||||
(advance! 1)
|
||||
(scan!)))
|
||||
(else (do (advance! 1) (scan!)))))))))
|
||||
(scan!)
|
||||
(dl-emit! "eof" nil pos)
|
||||
tokens)))
|
||||
@@ -1,159 +0,0 @@
|
||||
;; lib/datalog/unify.sx — unification + substitution for Datalog terms.
|
||||
;;
|
||||
;; Term taxonomy (after parsing):
|
||||
;; variable — SX symbol whose first char is uppercase A–Z or '_'.
|
||||
;; constant — SX symbol whose first char is lowercase a–z (atom name).
|
||||
;; number — numeric literal.
|
||||
;; string — string literal.
|
||||
;; compound — SX list (functor arg ... arg). In core Datalog these
|
||||
;; only appear as arithmetic expressions (see Phase 4
|
||||
;; safety analysis); compound-against-compound unification
|
||||
;; is supported anyway for completeness.
|
||||
;;
|
||||
;; Substitutions are immutable dicts keyed by variable name (string).
|
||||
;; A failed unification returns nil; success returns the extended subst.
|
||||
|
||||
(define dl-empty-subst (fn () {}))
|
||||
|
||||
(define
|
||||
dl-var?
|
||||
(fn
|
||||
(term)
|
||||
(and
|
||||
(symbol? term)
|
||||
(let
|
||||
((name (symbol->string term)))
|
||||
(and
|
||||
(> (len name) 0)
|
||||
(let
|
||||
((c (slice name 0 1)))
|
||||
(or (and (>= c "A") (<= c "Z")) (= c "_"))))))))
|
||||
|
||||
;; Walk: chase variable bindings until we hit a non-variable or an unbound
|
||||
;; variable. The result is either a non-variable term or an unbound var.
|
||||
(define
|
||||
dl-walk
|
||||
(fn
|
||||
(term subst)
|
||||
(if
|
||||
(dl-var? term)
|
||||
(let
|
||||
((name (symbol->string term)))
|
||||
(if
|
||||
(and (dict? subst) (has-key? subst name))
|
||||
(dl-walk (get subst name) subst)
|
||||
term))
|
||||
term)))
|
||||
|
||||
;; Bind a variable symbol to a value in subst, returning a new subst.
|
||||
(define
|
||||
dl-bind
|
||||
(fn (var-sym value subst) (assoc subst (symbol->string var-sym) value)))
|
||||
|
||||
(define
|
||||
dl-unify
|
||||
(fn
|
||||
(t1 t2 subst)
|
||||
(if
|
||||
(nil? subst)
|
||||
nil
|
||||
(let
|
||||
((u1 (dl-walk t1 subst)) (u2 (dl-walk t2 subst)))
|
||||
(cond
|
||||
((dl-var? u1)
|
||||
(cond
|
||||
((and (dl-var? u2) (= (symbol->string u1) (symbol->string u2)))
|
||||
subst)
|
||||
(else (dl-bind u1 u2 subst))))
|
||||
((dl-var? u2) (dl-bind u2 u1 subst))
|
||||
((and (list? u1) (list? u2))
|
||||
(if
|
||||
(= (len u1) (len u2))
|
||||
(dl-unify-list u1 u2 subst 0)
|
||||
nil))
|
||||
((and (number? u1) (number? u2)) (if (= u1 u2) subst nil))
|
||||
((and (string? u1) (string? u2)) (if (= u1 u2) subst nil))
|
||||
((and (symbol? u1) (symbol? u2))
|
||||
(if (= (symbol->string u1) (symbol->string u2)) subst nil))
|
||||
(else nil))))))
|
||||
|
||||
(define
|
||||
dl-unify-list
|
||||
(fn
|
||||
(a b subst i)
|
||||
(cond
|
||||
((nil? subst) nil)
|
||||
((>= i (len a)) subst)
|
||||
(else
|
||||
(dl-unify-list
|
||||
a
|
||||
b
|
||||
(dl-unify (nth a i) (nth b i) subst)
|
||||
(+ i 1))))))
|
||||
|
||||
;; Apply substitution: walk the term and recurse into lists.
|
||||
(define
|
||||
dl-apply-subst
|
||||
(fn
|
||||
(term subst)
|
||||
(let
|
||||
((w (dl-walk term subst)))
|
||||
(if (list? w) (map (fn (x) (dl-apply-subst x subst)) w) w))))
|
||||
|
||||
;; Ground? — true iff no free variables remain after walking.
|
||||
(define
|
||||
dl-ground?
|
||||
(fn
|
||||
(term subst)
|
||||
(let
|
||||
((w (dl-walk term subst)))
|
||||
(cond
|
||||
((dl-var? w) false)
|
||||
((list? w) (dl-ground-list? w subst 0))
|
||||
(else true)))))
|
||||
|
||||
(define
|
||||
dl-ground-list?
|
||||
(fn
|
||||
(xs subst i)
|
||||
(cond
|
||||
((>= i (len xs)) true)
|
||||
((not (dl-ground? (nth xs i) subst)) false)
|
||||
(else (dl-ground-list? xs subst (+ i 1))))))
|
||||
|
||||
;; Return the list of variable names appearing in a term (deduped, in
|
||||
;; left-to-right order). Useful for safety analysis later.
|
||||
(define
|
||||
dl-vars-of
|
||||
(fn (term) (let ((seen (list))) (do (dl-vars-of-aux term seen) seen))))
|
||||
|
||||
(define
|
||||
dl-vars-of-aux
|
||||
(fn
|
||||
(term acc)
|
||||
(cond
|
||||
((dl-var? term)
|
||||
(let
|
||||
((name (symbol->string term)))
|
||||
(when (not (dl-member? name acc)) (append! acc name))))
|
||||
((list? term) (dl-vars-of-list term acc 0))
|
||||
(else nil))))
|
||||
|
||||
(define
|
||||
dl-vars-of-list
|
||||
(fn
|
||||
(xs acc i)
|
||||
(when
|
||||
(< i (len xs))
|
||||
(do
|
||||
(dl-vars-of-aux (nth xs i) acc)
|
||||
(dl-vars-of-list xs acc (+ i 1))))))
|
||||
|
||||
(define
|
||||
dl-member?
|
||||
(fn
|
||||
(x xs)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((= (first xs) x) true)
|
||||
(else (dl-member? x (rest xs))))))
|
||||
418
lib/ocaml/parser.sx
Normal file
418
lib/ocaml/parser.sx
Normal file
@@ -0,0 +1,418 @@
|
||||
;; lib/ocaml/parser.sx — OCaml expression parser.
|
||||
;;
|
||||
;; Input: token list from (ocaml-tokenize src).
|
||||
;; Output: an OCaml AST. Nodes are plain lists tagged by a keyword head;
|
||||
;; keywords serialize to their string name so `(list :var "x")` is the
|
||||
;; same value as `(list "var" "x")` at runtime.
|
||||
;;
|
||||
;; Scope (this iteration — expressions only):
|
||||
;; atoms int/float/string/char, true/false, unit (), var, con, list literal
|
||||
;; application left-associative, f x y z
|
||||
;; prefix -E unary minus, not E
|
||||
;; infix standard ops via lib/guest/pratt.sx table
|
||||
;; tuple a, b, c (lower than infix, higher than let/if)
|
||||
;; parens (e)
|
||||
;; if if c then t else e (else optional → unit)
|
||||
;; fun fun x y -> body
|
||||
;; let let x = e in body (no rec)
|
||||
;; let f x y = e in body (function shorthand)
|
||||
;; let rec f x = e in body
|
||||
;;
|
||||
;; AST shapes:
|
||||
;; (:int N) (:float N) (:string S) (:char C) (:bool B) (:unit)
|
||||
;; (:var NAME) (:con NAME)
|
||||
;; (:app FN ARG) — binary, chain for multi-arg
|
||||
;; (:op OP LHS RHS) — binary infix; OP is the source string
|
||||
;; (:neg E) (:not E)
|
||||
;; (:tuple ITEMS)
|
||||
;; (:list ITEMS)
|
||||
;; (:if C T E)
|
||||
;; (:fun PARAMS BODY) — PARAMS list of strings (idents)
|
||||
;; (:let NAME PARAMS EXPR BODY)
|
||||
;; (:let-rec NAME PARAMS EXPR BODY)
|
||||
|
||||
(define ocaml-tok-type (fn (t) (if (= t nil) "eof" (get t :type))))
|
||||
|
||||
(define ocaml-tok-value (fn (t) (if (= t nil) nil (get t :value))))
|
||||
|
||||
;; Standard OCaml binary operator table.
|
||||
;; Higher precedence = tighter binding.
|
||||
;; ASSOC is :left or :right.
|
||||
(define
|
||||
ocaml-op-table
|
||||
(list
|
||||
(list "||" 2 :right)
|
||||
(list "or" 2 :right)
|
||||
(list "&&" 3 :right)
|
||||
(list "&" 3 :right)
|
||||
(list "=" 4 :left)
|
||||
(list "<" 4 :left)
|
||||
(list ">" 4 :left)
|
||||
(list "<=" 4 :left)
|
||||
(list ">=" 4 :left)
|
||||
(list "<>" 4 :left)
|
||||
(list "==" 4 :left)
|
||||
(list "!=" 4 :left)
|
||||
(list "|>" 4 :left)
|
||||
(list "@" 5 :right)
|
||||
(list "^" 5 :right)
|
||||
(list "::" 6 :right)
|
||||
(list "+" 7 :left)
|
||||
(list "-" 7 :left)
|
||||
(list "*" 8 :left)
|
||||
(list "/" 8 :left)
|
||||
(list "%" 8 :left)
|
||||
(list "mod" 8 :left)
|
||||
(list "land" 8 :left)
|
||||
(list "lor" 8 :left)
|
||||
(list "lxor" 8 :left)
|
||||
(list "**" 9 :right)
|
||||
(list "lsl" 9 :right)
|
||||
(list "lsr" 9 :right)
|
||||
(list "asr" 9 :right)))
|
||||
|
||||
(define
|
||||
ocaml-binop-prec
|
||||
(fn
|
||||
(op)
|
||||
(let
|
||||
((entry (pratt-op-lookup ocaml-op-table op)))
|
||||
(if (= entry nil) 0 (pratt-op-prec entry)))))
|
||||
|
||||
(define
|
||||
ocaml-binop-right?
|
||||
(fn
|
||||
(op)
|
||||
(let
|
||||
((entry (pratt-op-lookup ocaml-op-table op)))
|
||||
(and (not (= entry nil)) (= (pratt-op-assoc entry) :right)))))
|
||||
|
||||
;; Some OCaml binops are spelled with keyword tokens (mod / land / lor /
|
||||
;; lxor / lsl / lsr / asr / or). Recognise both shapes.
|
||||
(define
|
||||
ocaml-tok-is-binop?
|
||||
(fn
|
||||
(tok)
|
||||
(let
|
||||
((tt (ocaml-tok-type tok)) (tv (ocaml-tok-value tok)))
|
||||
(cond
|
||||
((= tt "op") (not (= (ocaml-binop-prec tv) 0)))
|
||||
((= tt "keyword") (not (= (ocaml-binop-prec tv) 0)))
|
||||
(else false)))))
|
||||
|
||||
(define
|
||||
ocaml-parse
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((tokens (ocaml-tokenize src)) (idx 0) (tok-len 0))
|
||||
(begin
|
||||
(set! tok-len (len tokens))
|
||||
(define peek-tok (fn () (nth tokens idx)))
|
||||
(define advance-tok! (fn () (set! idx (+ idx 1))))
|
||||
(define
|
||||
check-tok?
|
||||
(fn
|
||||
(type value)
|
||||
(let
|
||||
((t (peek-tok)))
|
||||
(and
|
||||
(= (ocaml-tok-type t) type)
|
||||
(or (= value nil) (= (ocaml-tok-value t) value))))))
|
||||
(define
|
||||
consume!
|
||||
(fn
|
||||
(type value)
|
||||
(if
|
||||
(check-tok? type value)
|
||||
(let ((t (peek-tok))) (begin (advance-tok!) t))
|
||||
(error
|
||||
(str
|
||||
"ocaml-parse: expected "
|
||||
type
|
||||
" "
|
||||
value
|
||||
" got "
|
||||
(ocaml-tok-type (peek-tok))
|
||||
" "
|
||||
(ocaml-tok-value (peek-tok)))))))
|
||||
(define at-kw? (fn (kw) (check-tok? "keyword" kw)))
|
||||
(define at-op? (fn (op) (check-tok? "op" op)))
|
||||
(define parse-expr (fn () nil))
|
||||
(define parse-tuple (fn () nil))
|
||||
(define parse-binop-rhs (fn (lhs min-prec) lhs))
|
||||
(define parse-prefix (fn () nil))
|
||||
(define parse-app (fn () nil))
|
||||
(define parse-atom (fn () nil))
|
||||
(set!
|
||||
parse-atom
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((t (peek-tok))
|
||||
(tt (ocaml-tok-type (peek-tok)))
|
||||
(tv (ocaml-tok-value (peek-tok))))
|
||||
(cond
|
||||
((= tt "number")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(if (= (round tv) tv) (list :int tv) (list :float tv))))
|
||||
((= tt "string") (begin (advance-tok!) (list :string tv)))
|
||||
((= tt "char") (begin (advance-tok!) (list :char tv)))
|
||||
((and (= tt "keyword") (= tv "true"))
|
||||
(begin (advance-tok!) (list :bool true)))
|
||||
((and (= tt "keyword") (= tv "false"))
|
||||
(begin (advance-tok!) (list :bool false)))
|
||||
((= tt "ident") (begin (advance-tok!) (list :var tv)))
|
||||
((= tt "ctor") (begin (advance-tok!) (list :con tv)))
|
||||
((and (= tt "op") (= tv "("))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(cond
|
||||
((at-op? ")") (begin (advance-tok!) (list :unit)))
|
||||
(else
|
||||
(let
|
||||
((e (parse-expr)))
|
||||
(begin (consume! "op" ")") e))))))
|
||||
((and (= tt "op") (= tv "["))
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(cond
|
||||
((at-op? "]") (begin (advance-tok!) (list :list)))
|
||||
(else
|
||||
(let
|
||||
((items (list)))
|
||||
(begin
|
||||
(append! items (parse-expr))
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-op? ";")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(when
|
||||
(not (at-op? "]"))
|
||||
(begin
|
||||
(append! items (parse-expr))
|
||||
(loop)))))))
|
||||
(loop)
|
||||
(consume! "op" "]")
|
||||
(cons :list items)))))))
|
||||
((at-kw? "begin")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(let
|
||||
((e (parse-expr)))
|
||||
(begin (consume! "keyword" "end") e))))
|
||||
(else
|
||||
(error
|
||||
(str
|
||||
"ocaml-parse: unexpected token "
|
||||
tt
|
||||
" "
|
||||
tv
|
||||
" at idx "
|
||||
idx)))))))
|
||||
(define
|
||||
at-app-start?
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((tt (ocaml-tok-type (peek-tok)))
|
||||
(tv (ocaml-tok-value (peek-tok))))
|
||||
(cond
|
||||
((= tt "number") true)
|
||||
((= tt "string") true)
|
||||
((= tt "char") true)
|
||||
((= tt "ident") true)
|
||||
((= tt "ctor") true)
|
||||
((and (= tt "keyword") (or (= tv "true") (= tv "false") (= tv "begin")))
|
||||
true)
|
||||
((and (= tt "op") (or (= tv "(") (= tv "["))) true)
|
||||
(else false)))))
|
||||
(set!
|
||||
parse-app
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((head (parse-atom)))
|
||||
(begin
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-app-start?)
|
||||
(let
|
||||
((arg (parse-atom)))
|
||||
(begin (set! head (list :app head arg)) (loop))))))
|
||||
(loop)
|
||||
head))))
|
||||
(set!
|
||||
parse-prefix
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((at-op? "-")
|
||||
(begin (advance-tok!) (list :neg (parse-prefix))))
|
||||
((at-kw? "not")
|
||||
(begin (advance-tok!) (list :not (parse-prefix))))
|
||||
(else (parse-app)))))
|
||||
(set!
|
||||
parse-binop-rhs
|
||||
(fn
|
||||
(lhs min-prec)
|
||||
(let
|
||||
((tok (peek-tok)))
|
||||
(cond
|
||||
((not (ocaml-tok-is-binop? tok)) lhs)
|
||||
(else
|
||||
(let
|
||||
((op (ocaml-tok-value tok))
|
||||
(prec (ocaml-binop-prec (ocaml-tok-value tok))))
|
||||
(cond
|
||||
((< prec min-prec) lhs)
|
||||
(else
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(let
|
||||
((rhs (parse-prefix))
|
||||
(next-min
|
||||
(if
|
||||
(ocaml-binop-right? op)
|
||||
prec
|
||||
(+ prec 1))))
|
||||
(begin
|
||||
(set! rhs (parse-binop-rhs rhs next-min))
|
||||
(parse-binop-rhs (list :op op lhs rhs) min-prec))))))))))))
|
||||
(define
|
||||
parse-binary
|
||||
(fn
|
||||
()
|
||||
(let ((lhs (parse-prefix))) (parse-binop-rhs lhs 1))))
|
||||
(set!
|
||||
parse-tuple
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((first (parse-binary)))
|
||||
(cond
|
||||
((at-op? ",")
|
||||
(let
|
||||
((items (list first)))
|
||||
(begin
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(at-op? ",")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(append! items (parse-binary))
|
||||
(loop)))))
|
||||
(loop)
|
||||
(cons :tuple items))))
|
||||
(else first)))))
|
||||
(define
|
||||
parse-fun
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((params (list)))
|
||||
(begin
|
||||
(define
|
||||
collect-params
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(check-tok? "ident" nil)
|
||||
(begin
|
||||
(append! params (ocaml-tok-value (peek-tok)))
|
||||
(advance-tok!)
|
||||
(collect-params)))))
|
||||
(collect-params)
|
||||
(when
|
||||
(= (len params) 0)
|
||||
(error "ocaml-parse: fun expects at least one parameter"))
|
||||
(consume! "op" "->")
|
||||
(let ((body (parse-expr))) (list :fun params body))))))
|
||||
(define
|
||||
parse-let
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((reccy false))
|
||||
(begin
|
||||
(when
|
||||
(at-kw? "rec")
|
||||
(begin (advance-tok!) (set! reccy true)))
|
||||
(let
|
||||
((name (ocaml-tok-value (consume! "ident" nil)))
|
||||
(params (list)))
|
||||
(begin
|
||||
(define
|
||||
collect-params
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(check-tok? "ident" nil)
|
||||
(begin
|
||||
(append! params (ocaml-tok-value (peek-tok)))
|
||||
(advance-tok!)
|
||||
(collect-params)))))
|
||||
(collect-params)
|
||||
(consume! "op" "=")
|
||||
(let
|
||||
((rhs (parse-expr)))
|
||||
(begin
|
||||
(consume! "keyword" "in")
|
||||
(let
|
||||
((body (parse-expr)))
|
||||
(if
|
||||
reccy
|
||||
(list :let-rec name params rhs body)
|
||||
(list :let name params rhs body)))))))))))
|
||||
(define
|
||||
parse-if
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((cond-expr (parse-expr)))
|
||||
(begin
|
||||
(consume! "keyword" "then")
|
||||
(let
|
||||
((then-expr (parse-expr)))
|
||||
(cond
|
||||
((at-kw? "else")
|
||||
(begin
|
||||
(advance-tok!)
|
||||
(let
|
||||
((else-expr (parse-expr)))
|
||||
(list :if cond-expr then-expr else-expr))))
|
||||
(else (list :if cond-expr then-expr (list :unit)))))))))
|
||||
(set!
|
||||
parse-expr
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((at-kw? "fun") (begin (advance-tok!) (parse-fun)))
|
||||
((at-kw? "let") (begin (advance-tok!) (parse-let)))
|
||||
((at-kw? "if") (begin (advance-tok!) (parse-if)))
|
||||
(else (parse-tuple)))))
|
||||
(let
|
||||
((result (parse-expr)))
|
||||
(begin
|
||||
(when
|
||||
(not (= (ocaml-tok-type (peek-tok)) "eof"))
|
||||
(error
|
||||
(str
|
||||
"ocaml-parse: trailing tokens at idx "
|
||||
idx
|
||||
" — got "
|
||||
(ocaml-tok-type (peek-tok))
|
||||
" "
|
||||
(ocaml-tok-value (peek-tok)))))
|
||||
result))))))
|
||||
426
lib/ocaml/test.sh
Executable file
426
lib/ocaml/test.sh
Executable file
@@ -0,0 +1,426 @@
|
||||
#!/usr/bin/env bash
|
||||
# Fast OCaml-on-SX test runner — epoch protocol direct to sx_server.exe.
|
||||
# Mirrors lib/lua/test.sh.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/ocaml/test.sh # run all tests
|
||||
# bash lib/ocaml/test.sh -v # verbose
|
||||
|
||||
set -uo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
fi
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
echo "ERROR: sx_server.exe not found. Run: cd hosts/ocaml && dune build"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
VERBOSE="${1:-}"
|
||||
PASS=0
|
||||
FAIL=0
|
||||
ERRORS=""
|
||||
TMPFILE=$(mktemp)
|
||||
trap "rm -f $TMPFILE" EXIT
|
||||
|
||||
cat > "$TMPFILE" << 'EPOCHS'
|
||||
(epoch 1)
|
||||
(load "lib/guest/lex.sx")
|
||||
(load "lib/guest/prefix.sx")
|
||||
(load "lib/guest/pratt.sx")
|
||||
(load "lib/ocaml/tokenizer.sx")
|
||||
(load "lib/ocaml/parser.sx")
|
||||
(load "lib/ocaml/tests/tokenize.sx")
|
||||
|
||||
;; ── empty / eof ────────────────────────────────────────────────
|
||||
(epoch 100)
|
||||
(eval "(ocaml-test-tok-count \"\")")
|
||||
(epoch 101)
|
||||
(eval "(ocaml-test-tok-type \"\" 0)")
|
||||
|
||||
;; ── numbers ────────────────────────────────────────────────────
|
||||
(epoch 110)
|
||||
(eval "(ocaml-test-tok-type \"42\" 0)")
|
||||
(epoch 111)
|
||||
(eval "(ocaml-test-tok-value \"42\" 0)")
|
||||
(epoch 112)
|
||||
(eval "(ocaml-test-tok-value \"3.14\" 0)")
|
||||
(epoch 113)
|
||||
(eval "(ocaml-test-tok-value \"0xff\" 0)")
|
||||
(epoch 114)
|
||||
(eval "(ocaml-test-tok-value \"1e3\" 0)")
|
||||
(epoch 115)
|
||||
(eval "(ocaml-test-tok-value \"1_000_000\" 0)")
|
||||
(epoch 116)
|
||||
(eval "(ocaml-test-tok-value \"3.14e-2\" 0)")
|
||||
|
||||
;; ── identifiers / constructors / keywords ─────────────────────
|
||||
(epoch 120)
|
||||
(eval "(ocaml-test-tok-type \"foo\" 0)")
|
||||
(epoch 121)
|
||||
(eval "(ocaml-test-tok-value \"foo_bar1\" 0)")
|
||||
(epoch 122)
|
||||
(eval "(ocaml-test-tok-type \"Some\" 0)")
|
||||
(epoch 123)
|
||||
(eval "(ocaml-test-tok-value \"Some\" 0)")
|
||||
(epoch 124)
|
||||
(eval "(ocaml-test-tok-type \"let\" 0)")
|
||||
(epoch 125)
|
||||
(eval "(ocaml-test-tok-value \"match\" 0)")
|
||||
(epoch 126)
|
||||
(eval "(ocaml-test-tok-type \"true\" 0)")
|
||||
(epoch 127)
|
||||
(eval "(ocaml-test-tok-value \"false\" 0)")
|
||||
(epoch 128)
|
||||
(eval "(ocaml-test-tok-value \"name'\" 0)")
|
||||
|
||||
;; ── strings ────────────────────────────────────────────────────
|
||||
(epoch 130)
|
||||
(eval "(ocaml-test-tok-type \"\\\"hi\\\"\" 0)")
|
||||
(epoch 131)
|
||||
(eval "(ocaml-test-tok-value \"\\\"hi\\\"\" 0)")
|
||||
(epoch 132)
|
||||
(eval "(ocaml-test-tok-value \"\\\"a\\\\nb\\\"\" 0)")
|
||||
|
||||
;; ── chars ──────────────────────────────────────────────────────
|
||||
(epoch 140)
|
||||
(eval "(ocaml-test-tok-type \"'a'\" 0)")
|
||||
(epoch 141)
|
||||
(eval "(ocaml-test-tok-value \"'a'\" 0)")
|
||||
(epoch 142)
|
||||
(eval "(ocaml-test-tok-value \"'\\\\n'\" 0)")
|
||||
|
||||
;; ── type variables ─────────────────────────────────────────────
|
||||
(epoch 145)
|
||||
(eval "(ocaml-test-tok-type \"'a\" 0)")
|
||||
(epoch 146)
|
||||
(eval "(ocaml-test-tok-value \"'a\" 0)")
|
||||
|
||||
;; ── multi-char operators ───────────────────────────────────────
|
||||
(epoch 150)
|
||||
(eval "(ocaml-test-tok-value \"->\" 0)")
|
||||
(epoch 151)
|
||||
(eval "(ocaml-test-tok-value \"|>\" 0)")
|
||||
(epoch 152)
|
||||
(eval "(ocaml-test-tok-value \"<-\" 0)")
|
||||
(epoch 153)
|
||||
(eval "(ocaml-test-tok-value \":=\" 0)")
|
||||
(epoch 154)
|
||||
(eval "(ocaml-test-tok-value \"::\" 0)")
|
||||
(epoch 155)
|
||||
(eval "(ocaml-test-tok-value \";;\" 0)")
|
||||
(epoch 156)
|
||||
(eval "(ocaml-test-tok-value \"@@\" 0)")
|
||||
(epoch 157)
|
||||
(eval "(ocaml-test-tok-value \"<>\" 0)")
|
||||
(epoch 158)
|
||||
(eval "(ocaml-test-tok-value \"&&\" 0)")
|
||||
(epoch 159)
|
||||
(eval "(ocaml-test-tok-value \"||\" 0)")
|
||||
|
||||
;; ── single-char punctuation ────────────────────────────────────
|
||||
(epoch 160)
|
||||
(eval "(ocaml-test-tok-value \"+\" 0)")
|
||||
(epoch 161)
|
||||
(eval "(ocaml-test-tok-value \"|\" 0)")
|
||||
(epoch 162)
|
||||
(eval "(ocaml-test-tok-value \";\" 0)")
|
||||
(epoch 163)
|
||||
(eval "(ocaml-test-tok-value \"(\" 0)")
|
||||
(epoch 164)
|
||||
(eval "(ocaml-test-tok-value \"!\" 0)")
|
||||
(epoch 165)
|
||||
(eval "(ocaml-test-tok-value \"@\" 0)")
|
||||
|
||||
;; ── comments ───────────────────────────────────────────────────
|
||||
(epoch 170)
|
||||
(eval "(ocaml-test-tok-count \"(* hi *)\")")
|
||||
(epoch 171)
|
||||
(eval "(ocaml-test-tok-value \"(* c *) 42\" 0)")
|
||||
(epoch 172)
|
||||
(eval "(ocaml-test-tok-count \"(* outer (* inner *) end *) 1\")")
|
||||
(epoch 173)
|
||||
(eval "(ocaml-test-tok-value \"(* outer (* inner *) end *) 1\" 0)")
|
||||
|
||||
;; ── compound expressions ───────────────────────────────────────
|
||||
(epoch 180)
|
||||
(eval "(ocaml-test-tok-count \"let x = 1\")")
|
||||
(epoch 181)
|
||||
(eval "(ocaml-test-tok-type \"let x = 1\" 0)")
|
||||
(epoch 182)
|
||||
(eval "(ocaml-test-tok-value \"let x = 1\" 0)")
|
||||
(epoch 183)
|
||||
(eval "(ocaml-test-tok-type \"let x = 1\" 1)")
|
||||
(epoch 184)
|
||||
(eval "(ocaml-test-tok-value \"let x = 1\" 2)")
|
||||
(epoch 185)
|
||||
(eval "(ocaml-test-tok-value \"let x = 1\" 3)")
|
||||
|
||||
(epoch 190)
|
||||
(eval "(ocaml-test-tok-count \"match x with | None -> 0 | Some y -> y\")")
|
||||
(epoch 191)
|
||||
(eval "(ocaml-test-tok-value \"fun x -> x + 1\" 2)")
|
||||
(epoch 192)
|
||||
(eval "(ocaml-test-tok-type \"fun x -> x + 1\" 2)")
|
||||
(epoch 193)
|
||||
(eval "(ocaml-test-tok-type \"Some 42\" 0)")
|
||||
(epoch 194)
|
||||
(eval "(ocaml-test-tok-value \"a |> f |> g\" 1)")
|
||||
(epoch 195)
|
||||
(eval "(ocaml-test-tok-value \"x := !y\" 1)")
|
||||
|
||||
;; ── Phase 1.parse: parser ──────────────────────────────────────
|
||||
;; Atoms
|
||||
(epoch 200)
|
||||
(eval "(ocaml-parse \"42\")")
|
||||
(epoch 201)
|
||||
(eval "(ocaml-parse \"3.14\")")
|
||||
(epoch 202)
|
||||
(eval "(ocaml-parse \"\\\"hi\\\"\")")
|
||||
(epoch 203)
|
||||
(eval "(ocaml-parse \"'a'\")")
|
||||
(epoch 204)
|
||||
(eval "(ocaml-parse \"true\")")
|
||||
(epoch 205)
|
||||
(eval "(ocaml-parse \"false\")")
|
||||
(epoch 206)
|
||||
(eval "(ocaml-parse \"x\")")
|
||||
(epoch 207)
|
||||
(eval "(ocaml-parse \"Some\")")
|
||||
(epoch 208)
|
||||
(eval "(ocaml-parse \"()\")")
|
||||
|
||||
;; Application (left-assoc)
|
||||
(epoch 210)
|
||||
(eval "(ocaml-parse \"f x\")")
|
||||
(epoch 211)
|
||||
(eval "(ocaml-parse \"f x y\")")
|
||||
(epoch 212)
|
||||
(eval "(ocaml-parse \"f (g x)\")")
|
||||
(epoch 213)
|
||||
(eval "(ocaml-parse \"Some 42\")")
|
||||
|
||||
;; Binops with precedence
|
||||
(epoch 220)
|
||||
(eval "(ocaml-parse \"1 + 2\")")
|
||||
(epoch 221)
|
||||
(eval "(ocaml-parse \"a + b * c\")")
|
||||
(epoch 222)
|
||||
(eval "(ocaml-parse \"a * b + c\")")
|
||||
(epoch 223)
|
||||
(eval "(ocaml-parse \"a && b || c\")")
|
||||
(epoch 224)
|
||||
(eval "(ocaml-parse \"a = b\")")
|
||||
(epoch 225)
|
||||
(eval "(ocaml-parse \"a ^ b ^ c\")")
|
||||
(epoch 226)
|
||||
(eval "(ocaml-parse \"a :: b :: []\")")
|
||||
(epoch 227)
|
||||
(eval "(ocaml-parse \"(a + b) * c\")")
|
||||
(epoch 228)
|
||||
(eval "(ocaml-parse \"a |> f |> g\")")
|
||||
(epoch 229)
|
||||
(eval "(ocaml-parse \"x mod 2\")")
|
||||
|
||||
;; Prefix
|
||||
(epoch 230)
|
||||
(eval "(ocaml-parse \"-x\")")
|
||||
(epoch 231)
|
||||
(eval "(ocaml-parse \"-1 + 2\")")
|
||||
|
||||
;; Tuples & lists
|
||||
(epoch 240)
|
||||
(eval "(ocaml-parse \"(1, 2, 3)\")")
|
||||
(epoch 241)
|
||||
(eval "(ocaml-parse \"[1; 2; 3]\")")
|
||||
(epoch 242)
|
||||
(eval "(ocaml-parse \"[]\")")
|
||||
|
||||
;; if / fun / let / let rec
|
||||
(epoch 250)
|
||||
(eval "(ocaml-parse \"if x then 1 else 2\")")
|
||||
(epoch 251)
|
||||
(eval "(ocaml-parse \"if c then x\")")
|
||||
(epoch 252)
|
||||
(eval "(ocaml-parse \"fun x -> x + 1\")")
|
||||
(epoch 253)
|
||||
(eval "(ocaml-parse \"fun x y -> x + y\")")
|
||||
(epoch 254)
|
||||
(eval "(ocaml-parse \"let x = 1 in x\")")
|
||||
(epoch 255)
|
||||
(eval "(ocaml-parse \"let f x = x + 1 in f 2\")")
|
||||
(epoch 256)
|
||||
(eval "(ocaml-parse \"let rec f x = f x in f 1\")")
|
||||
(epoch 257)
|
||||
(eval "(ocaml-parse \"let f x y = x + y in f 1 2\")")
|
||||
|
||||
;; begin/end
|
||||
(epoch 260)
|
||||
(eval "(ocaml-parse \"begin 1 + 2 end\")")
|
||||
|
||||
EPOCHS
|
||||
|
||||
OUTPUT=$(timeout 60 "$SX_SERVER" < "$TMPFILE" 2>/dev/null)
|
||||
|
||||
check() {
|
||||
local epoch="$1" desc="$2" expected="$3"
|
||||
local actual
|
||||
actual=$(echo "$OUTPUT" | grep -A1 "^(ok-len $epoch " | tail -1)
|
||||
if [ -z "$actual" ]; then
|
||||
actual=$(echo "$OUTPUT" | grep "^(ok $epoch " || true)
|
||||
fi
|
||||
if [ -z "$actual" ]; then
|
||||
actual=$(echo "$OUTPUT" | grep "^(error $epoch " || true)
|
||||
fi
|
||||
if [ -z "$actual" ]; then
|
||||
actual="<no output for epoch $epoch>"
|
||||
fi
|
||||
|
||||
if echo "$actual" | grep -qF -- "$expected"; then
|
||||
PASS=$((PASS + 1))
|
||||
[ "$VERBOSE" = "-v" ] && echo " ok $desc"
|
||||
else
|
||||
FAIL=$((FAIL + 1))
|
||||
ERRORS+=" FAIL $desc (epoch $epoch)
|
||||
expected: $expected
|
||||
actual: $actual
|
||||
"
|
||||
fi
|
||||
}
|
||||
|
||||
# empty / eof
|
||||
check 100 "empty tokens length" '1'
|
||||
check 101 "empty first is eof" '"eof"'
|
||||
|
||||
# numbers
|
||||
check 110 "int type" '"number"'
|
||||
check 111 "int value" '42'
|
||||
check 112 "float value" '3.14'
|
||||
check 113 "hex value" '255'
|
||||
check 114 "exponent" '1000'
|
||||
check 115 "underscored int" '1000000'
|
||||
check 116 "neg exponent" '0.0314'
|
||||
|
||||
# idents / ctors / keywords
|
||||
check 120 "ident type" '"ident"'
|
||||
check 121 "ident value" '"foo_bar1"'
|
||||
check 122 "ctor type" '"ctor"'
|
||||
check 123 "ctor value" '"Some"'
|
||||
check 124 "let keyword type" '"keyword"'
|
||||
check 125 "match keyword value" '"match"'
|
||||
check 126 "true is keyword" '"keyword"'
|
||||
check 127 "false value" '"false"'
|
||||
check 128 "primed ident" "\"name'\""
|
||||
|
||||
# strings
|
||||
check 130 "string type" '"string"'
|
||||
check 131 "string value" '"hi"'
|
||||
check 132 "escape sequence" '"a'
|
||||
|
||||
# chars
|
||||
check 140 "char type" '"char"'
|
||||
check 141 "char value" '"a"'
|
||||
check 142 "char escape" '"'
|
||||
|
||||
# tyvars
|
||||
check 145 "tyvar type" '"tyvar"'
|
||||
check 146 "tyvar value" '"a"'
|
||||
|
||||
# multi-char ops
|
||||
check 150 "->" '"->"'
|
||||
check 151 "|>" '"|>"'
|
||||
check 152 "<-" '"<-"'
|
||||
check 153 ":=" '":="'
|
||||
check 154 "::" '"::"'
|
||||
check 155 ";;" '";;"'
|
||||
check 156 "@@" '"@@"'
|
||||
check 157 "<>" '"<>"'
|
||||
check 158 "&&" '"&&"'
|
||||
check 159 "||" '"||"'
|
||||
|
||||
# single ops
|
||||
check 160 "+" '"+"'
|
||||
check 161 "|" '"|"'
|
||||
check 162 ";" '";"'
|
||||
check 163 "(" '"("'
|
||||
check 164 "!" '"!"'
|
||||
check 165 "@" '"@"'
|
||||
|
||||
# comments
|
||||
check 170 "block comment alone -> eof" '1'
|
||||
check 171 "num after block comment" '42'
|
||||
check 172 "nested comment count" '2'
|
||||
check 173 "nested comment value" '1'
|
||||
|
||||
# compound
|
||||
check 180 "let x = 1 count" '5'
|
||||
check 181 "let is keyword" '"keyword"'
|
||||
check 182 "let value" '"let"'
|
||||
check 183 "x is ident" '"ident"'
|
||||
check 184 "= value" '"="'
|
||||
check 185 "1 value" '1'
|
||||
|
||||
check 190 "match expr count" '13'
|
||||
check 191 "fun -> arrow value" '"->"'
|
||||
check 192 "fun -> arrow type" '"op"'
|
||||
check 193 "Some is ctor" '"ctor"'
|
||||
check 194 "first |> value" '"|>"'
|
||||
check 195 "ref assign :=" '":="'
|
||||
|
||||
# ── Parser tests ────────────────────────────────────────────────
|
||||
check 200 "parse int" '("int" 42)'
|
||||
check 201 "parse float" '("float" 3.14)'
|
||||
check 202 "parse string" '("string" "hi")'
|
||||
check 203 "parse char" '("char" "a")'
|
||||
check 204 "parse true" '("bool" true)'
|
||||
check 205 "parse false" '("bool" false)'
|
||||
check 206 "parse var" '("var" "x")'
|
||||
check 207 "parse ctor" '("con" "Some")'
|
||||
check 208 "parse unit" '("unit")'
|
||||
|
||||
check 210 "parse f x" '("app" ("var" "f") ("var" "x"))'
|
||||
check 211 "parse f x y left-assoc" '("app" ("app" ("var" "f") ("var" "x")) ("var" "y"))'
|
||||
check 212 "parse f (g x)" '("app" ("var" "f") ("app" ("var" "g") ("var" "x")))'
|
||||
check 213 "parse Some 42" '("app" ("con" "Some") ("int" 42))'
|
||||
|
||||
check 220 "parse 1+2" '("op" "+" ("int" 1) ("int" 2))'
|
||||
check 221 "parse a + b * c prec" '("op" "+" ("var" "a") ("op" "*"'
|
||||
check 222 "parse a*b + c prec" '("op" "+" ("op" "*"'
|
||||
check 223 "parse && / || prec" '("op" "||" ("op" "&&"'
|
||||
check 224 "parse a = b" '("op" "=" ("var" "a") ("var" "b"))'
|
||||
check 225 "parse ^ right-assoc" '("op" "^" ("var" "a") ("op" "^"'
|
||||
check 226 "parse :: right-assoc" '("op" "::" ("var" "a") ("op" "::"'
|
||||
check 227 "parse parens override" '("op" "*" ("op" "+"'
|
||||
check 228 "parse |> chain" '("op" "|>" ("op" "|>"'
|
||||
check 229 "parse mod kw-binop" '("op" "mod" ("var" "x") ("int" 2))'
|
||||
|
||||
check 230 "parse -x" '("neg" ("var" "x"))'
|
||||
check 231 "parse -1+2" '("op" "+" ("neg" ("int" 1)) ("int" 2))'
|
||||
|
||||
check 240 "parse tuple" '("tuple" ("int" 1) ("int" 2) ("int" 3))'
|
||||
check 241 "parse list literal" '("list" ("int" 1) ("int" 2) ("int" 3))'
|
||||
check 242 "parse []" '("list")'
|
||||
|
||||
check 250 "parse if/then/else" '("if" ("var" "x") ("int" 1) ("int" 2))'
|
||||
check 251 "parse if w/o else" '("if" ("var" "c") ("var" "x") ("unit"))'
|
||||
check 252 "parse fun x -> ..." '("fun" ("x") ("op" "+" ("var" "x") ("int" 1)))'
|
||||
check 253 "parse fun x y ->" '("fun" ("x" "y")'
|
||||
check 254 "parse let x = 1 in x" '("let" "x" () ("int" 1) ("var" "x"))'
|
||||
check 255 "parse let f x =" '("let" "f" ("x") ("op" "+"'
|
||||
check 256 "parse let rec f x =" '("let-rec" "f" ("x")'
|
||||
check 257 "parse let f x y =" '("let" "f" ("x" "y")'
|
||||
|
||||
check 260 "parse begin/end" '("op" "+" ("int" 1) ("int" 2))'
|
||||
|
||||
TOTAL=$((PASS + FAIL))
|
||||
if [ $FAIL -eq 0 ]; then
|
||||
echo "ok $PASS/$TOTAL OCaml-on-SX tests passed"
|
||||
else
|
||||
echo "FAIL $PASS/$TOTAL passed, $FAIL failed:"
|
||||
echo ""
|
||||
echo "$ERRORS"
|
||||
fi
|
||||
|
||||
[ $FAIL -eq 0 ]
|
||||
21
lib/ocaml/tests/tokenize.sx
Normal file
21
lib/ocaml/tests/tokenize.sx
Normal file
@@ -0,0 +1,21 @@
|
||||
;; lib/ocaml/tests/tokenize.sx — smoke-test helpers.
|
||||
;;
|
||||
;; Tests are exercised via lib/ocaml/test.sh, which drives sx_server.exe
|
||||
;; over the epoch protocol. This file provides small accessors so the
|
||||
;; bash runner can grep short diagnostic values out of one batched run.
|
||||
|
||||
(define
|
||||
ocaml-test-tok-type
|
||||
(fn (src i) (get (nth (ocaml-tokenize src) i) :type)))
|
||||
|
||||
(define
|
||||
ocaml-test-tok-value
|
||||
(fn (src i) (get (nth (ocaml-tokenize src) i) :value)))
|
||||
|
||||
(define ocaml-test-tok-count (fn (src) (len (ocaml-tokenize src))))
|
||||
|
||||
(define ocaml-test-parse-str (fn (src) (ocaml-parse src)))
|
||||
|
||||
(define
|
||||
ocaml-test-parse-head
|
||||
(fn (src) (nth (ocaml-parse src) 0)))
|
||||
382
lib/ocaml/tokenizer.sx
Normal file
382
lib/ocaml/tokenizer.sx
Normal file
@@ -0,0 +1,382 @@
|
||||
;; lib/ocaml/tokenizer.sx — OCaml lexer.
|
||||
;;
|
||||
;; Tokens: ident, ctor (uppercase ident), keyword, number, string, char, op, eof.
|
||||
;; Token shape: {:type :value :pos} via lex-make-token.
|
||||
;; OCaml is not indentation-sensitive — no layout pass.
|
||||
;; Block comments (* ... *) nest. There is no line-comment syntax.
|
||||
|
||||
(prefix-rename
|
||||
"ocaml-"
|
||||
(quote
|
||||
((make-token lex-make-token)
|
||||
(digit? lex-digit?)
|
||||
(hex-digit? lex-hex-digit?)
|
||||
(alpha? lex-alpha?)
|
||||
(alnum? lex-alnum?)
|
||||
(ident-start? lex-ident-start?)
|
||||
(ident-char? lex-ident-char?)
|
||||
(ws? lex-whitespace?))))
|
||||
|
||||
(define
|
||||
ocaml-keywords
|
||||
(list
|
||||
"and"
|
||||
"as"
|
||||
"assert"
|
||||
"begin"
|
||||
"class"
|
||||
"constraint"
|
||||
"do"
|
||||
"done"
|
||||
"downto"
|
||||
"else"
|
||||
"end"
|
||||
"exception"
|
||||
"external"
|
||||
"false"
|
||||
"for"
|
||||
"fun"
|
||||
"function"
|
||||
"functor"
|
||||
"if"
|
||||
"in"
|
||||
"include"
|
||||
"inherit"
|
||||
"initializer"
|
||||
"lazy"
|
||||
"let"
|
||||
"match"
|
||||
"method"
|
||||
"module"
|
||||
"mutable"
|
||||
"new"
|
||||
"nonrec"
|
||||
"object"
|
||||
"of"
|
||||
"open"
|
||||
"or"
|
||||
"private"
|
||||
"rec"
|
||||
"sig"
|
||||
"struct"
|
||||
"then"
|
||||
"to"
|
||||
"true"
|
||||
"try"
|
||||
"type"
|
||||
"val"
|
||||
"virtual"
|
||||
"when"
|
||||
"while"
|
||||
"with"
|
||||
"land"
|
||||
"lor"
|
||||
"lxor"
|
||||
"lsl"
|
||||
"lsr"
|
||||
"asr"
|
||||
"mod"))
|
||||
|
||||
(define ocaml-keyword? (fn (word) (contains? ocaml-keywords word)))
|
||||
|
||||
(define
|
||||
ocaml-upper?
|
||||
(fn (c) (and (not (= c nil)) (>= c "A") (<= c "Z"))))
|
||||
|
||||
(define
|
||||
ocaml-tokenize
|
||||
(fn
|
||||
(src)
|
||||
(let
|
||||
((tokens (list)) (pos 0) (src-len (len src)))
|
||||
(define
|
||||
ocaml-peek
|
||||
(fn
|
||||
(offset)
|
||||
(if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
|
||||
(define cur (fn () (ocaml-peek 0)))
|
||||
(define advance! (fn (n) (set! pos (+ pos n))))
|
||||
(define
|
||||
push!
|
||||
(fn
|
||||
(type value start)
|
||||
(append! tokens (ocaml-make-token type value start))))
|
||||
(define
|
||||
skip-block-comment!
|
||||
(fn
|
||||
(depth)
|
||||
(cond
|
||||
((>= pos src-len) nil)
|
||||
((and (= (cur) "*") (= (ocaml-peek 1) ")"))
|
||||
(begin
|
||||
(advance! 2)
|
||||
(when
|
||||
(> depth 1)
|
||||
(skip-block-comment! (- depth 1)))))
|
||||
((and (= (cur) "(") (= (ocaml-peek 1) "*"))
|
||||
(begin
|
||||
(advance! 2)
|
||||
(skip-block-comment! (+ depth 1))))
|
||||
(else (begin (advance! 1) (skip-block-comment! depth))))))
|
||||
(define
|
||||
skip-ws!
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len) nil)
|
||||
((ocaml-ws? (cur)) (begin (advance! 1) (skip-ws!)))
|
||||
((and (= (cur) "(") (= (ocaml-peek 1) "*"))
|
||||
(begin
|
||||
(advance! 2)
|
||||
(skip-block-comment! 1)
|
||||
(skip-ws!)))
|
||||
(else nil))))
|
||||
(define
|
||||
read-ident
|
||||
(fn
|
||||
(start)
|
||||
(begin
|
||||
(when
|
||||
(and (< pos src-len) (ocaml-ident-char? (cur)))
|
||||
(begin (advance! 1) (read-ident start)))
|
||||
(when
|
||||
(and (< pos src-len) (= (cur) "'"))
|
||||
(begin (advance! 1) (read-ident start)))
|
||||
(slice src start pos))))
|
||||
(define
|
||||
read-decimal-digits!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (or (ocaml-digit? (cur)) (= (cur) "_")))
|
||||
(begin (advance! 1) (read-decimal-digits!)))))
|
||||
(define
|
||||
read-hex-digits!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and
|
||||
(< pos src-len)
|
||||
(or (ocaml-hex-digit? (cur)) (= (cur) "_")))
|
||||
(begin (advance! 1) (read-hex-digits!)))))
|
||||
(define
|
||||
read-exp-part!
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(and (< pos src-len) (or (= (cur) "e") (= (cur) "E")))
|
||||
(let
|
||||
((p1 (ocaml-peek 1)))
|
||||
(when
|
||||
(or
|
||||
(and (not (= p1 nil)) (ocaml-digit? p1))
|
||||
(and
|
||||
(or (= p1 "+") (= p1 "-"))
|
||||
(< (+ pos 2) src-len)
|
||||
(ocaml-digit? (ocaml-peek 2))))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(when
|
||||
(and
|
||||
(< pos src-len)
|
||||
(or (= (cur) "+") (= (cur) "-")))
|
||||
(advance! 1))
|
||||
(read-decimal-digits!)))))))
|
||||
(define
|
||||
strip-underscores
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((out (list)) (i 0) (n (len s)))
|
||||
(begin
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
()
|
||||
(when
|
||||
(< i n)
|
||||
(begin
|
||||
(when
|
||||
(not (= (nth s i) "_"))
|
||||
(append! out (nth s i)))
|
||||
(set! i (+ i 1))
|
||||
(loop)))))
|
||||
(loop)
|
||||
(join "" out)))))
|
||||
(define
|
||||
read-number
|
||||
(fn
|
||||
(start)
|
||||
(cond
|
||||
((and (= (cur) "0") (< (+ pos 1) src-len) (or (= (ocaml-peek 1) "x") (= (ocaml-peek 1) "X")))
|
||||
(begin
|
||||
(advance! 2)
|
||||
(read-hex-digits!)
|
||||
(let
|
||||
((raw (slice src (+ start 2) pos)))
|
||||
(parse-number (str "0x" (strip-underscores raw))))))
|
||||
(else
|
||||
(begin
|
||||
(read-decimal-digits!)
|
||||
(when
|
||||
(and
|
||||
(< pos src-len)
|
||||
(= (cur) ".")
|
||||
(or
|
||||
(>= (+ pos 1) src-len)
|
||||
(not (= (ocaml-peek 1) "."))))
|
||||
(begin (advance! 1) (read-decimal-digits!)))
|
||||
(read-exp-part!)
|
||||
(parse-number (strip-underscores (slice src start pos))))))))
|
||||
(define
|
||||
read-string-literal
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((chars (list)))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(define
|
||||
loop
|
||||
(fn
|
||||
()
|
||||
(cond
|
||||
((>= pos src-len) nil)
|
||||
((= (cur) "\\")
|
||||
(begin
|
||||
(advance! 1)
|
||||
(when
|
||||
(< pos src-len)
|
||||
(let
|
||||
((ch (cur)))
|
||||
(begin
|
||||
(cond
|
||||
((= ch "n") (append! chars "\n"))
|
||||
((= ch "t") (append! chars "\t"))
|
||||
((= ch "r") (append! chars "\r"))
|
||||
((= ch "b") (append! chars "\\b"))
|
||||
((= ch "\\") (append! chars "\\"))
|
||||
((= ch "'") (append! chars "'"))
|
||||
((= ch "\"") (append! chars "\""))
|
||||
((= ch " ") nil)
|
||||
(else (append! chars ch)))
|
||||
(advance! 1))))
|
||||
(loop)))
|
||||
((= (cur) "\"") (advance! 1))
|
||||
(else
|
||||
(begin
|
||||
(append! chars (cur))
|
||||
(advance! 1)
|
||||
(loop))))))
|
||||
(loop)
|
||||
(join "" chars)))))
|
||||
(define
|
||||
read-char-literal
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(advance! 1)
|
||||
(let
|
||||
((value (cond ((= (cur) "\\") (begin (advance! 1) (let ((ch (cur))) (begin (advance! 1) (cond ((= ch "n") "\n") ((= ch "t") "\t") ((= ch "r") "\r") ((= ch "b") "\\b") ((= ch "\\") "\\") ((= ch "'") "'") ((= ch "\"") "\"") (else ch)))))) (else (let ((ch (cur))) (begin (advance! 1) ch))))))
|
||||
(begin
|
||||
(when
|
||||
(and (< pos src-len) (= (cur) "'"))
|
||||
(advance! 1))
|
||||
value)))))
|
||||
(define
|
||||
try-punct
|
||||
(fn
|
||||
(start)
|
||||
(let
|
||||
((c (cur))
|
||||
(c1 (ocaml-peek 1))
|
||||
(c2 (ocaml-peek 2)))
|
||||
(cond
|
||||
((and (= c ";") (= c1 ";"))
|
||||
(begin (advance! 2) (push! "op" ";;" start) true))
|
||||
((and (= c "-") (= c1 ">"))
|
||||
(begin (advance! 2) (push! "op" "->" start) true))
|
||||
((and (= c "<") (= c1 "-"))
|
||||
(begin (advance! 2) (push! "op" "<-" start) true))
|
||||
((and (= c ":") (= c1 "="))
|
||||
(begin (advance! 2) (push! "op" ":=" start) true))
|
||||
((and (= c ":") (= c1 ":"))
|
||||
(begin (advance! 2) (push! "op" "::" start) true))
|
||||
((and (= c "|") (= c1 "|"))
|
||||
(begin (advance! 2) (push! "op" "||" start) true))
|
||||
((and (= c "&") (= c1 "&"))
|
||||
(begin (advance! 2) (push! "op" "&&" start) true))
|
||||
((and (= c "<") (= c1 "="))
|
||||
(begin (advance! 2) (push! "op" "<=" start) true))
|
||||
((and (= c ">") (= c1 "="))
|
||||
(begin (advance! 2) (push! "op" ">=" start) true))
|
||||
((and (= c "<") (= c1 ">"))
|
||||
(begin (advance! 2) (push! "op" "<>" start) true))
|
||||
((and (= c "=") (= c1 "="))
|
||||
(begin (advance! 2) (push! "op" "==" start) true))
|
||||
((and (= c "!") (= c1 "="))
|
||||
(begin (advance! 2) (push! "op" "!=" start) true))
|
||||
((and (= c "|") (= c1 ">"))
|
||||
(begin (advance! 2) (push! "op" "|>" start) true))
|
||||
((and (= c "<") (= c1 "|"))
|
||||
(begin (advance! 2) (push! "op" "<|" start) true))
|
||||
((and (= c "@") (= c1 "@"))
|
||||
(begin (advance! 2) (push! "op" "@@" start) true))
|
||||
((and (= c "*") (= c1 "*"))
|
||||
(begin (advance! 2) (push! "op" "**" start) true))
|
||||
((or (= c "+") (= c "-") (= c "*") (= c "/") (= c "%") (= c "^") (= c "<") (= c ">") (= c "=") (= c "(") (= c ")") (= c "{") (= c "}") (= c "[") (= c "]") (= c ";") (= c ":") (= c ",") (= c ".") (= c "|") (= c "!") (= c "&") (= c "@") (= c "?") (= c "~") (= c "#"))
|
||||
(begin (advance! 1) (push! "op" c start) true))
|
||||
(else false)))))
|
||||
(define
|
||||
step
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(skip-ws!)
|
||||
(when
|
||||
(< pos src-len)
|
||||
(let
|
||||
((start pos) (c (cur)))
|
||||
(cond
|
||||
((ocaml-ident-start? c)
|
||||
(let
|
||||
((word (read-ident start)))
|
||||
(begin
|
||||
(cond
|
||||
((ocaml-keyword? word)
|
||||
(push! "keyword" word start))
|
||||
((ocaml-upper? c) (push! "ctor" word start))
|
||||
(else (push! "ident" word start)))
|
||||
(step))))
|
||||
((ocaml-digit? c)
|
||||
(let
|
||||
((v (read-number start)))
|
||||
(begin (push! "number" v start) (step))))
|
||||
((= c "\"")
|
||||
(let
|
||||
((s (read-string-literal)))
|
||||
(begin (push! "string" s start) (step))))
|
||||
((and (= c "'") (< (+ pos 1) src-len) (or (and (= (ocaml-peek 1) "\\") (< (+ pos 3) src-len) (= (ocaml-peek 3) "'")) (and (not (= (ocaml-peek 1) "\\")) (< (+ pos 2) src-len) (= (ocaml-peek 2) "'"))))
|
||||
(let
|
||||
((v (read-char-literal)))
|
||||
(begin (push! "char" v start) (step))))
|
||||
((= c "'")
|
||||
(begin
|
||||
(advance! 1)
|
||||
(when
|
||||
(and (< pos src-len) (ocaml-ident-start? (cur)))
|
||||
(begin
|
||||
(advance! 1)
|
||||
(read-ident (+ start 1))))
|
||||
(push!
|
||||
"tyvar"
|
||||
(slice src (+ start 1) pos)
|
||||
start)
|
||||
(step)))
|
||||
((try-punct start) (step))
|
||||
(else
|
||||
(error
|
||||
(str "ocaml-tokenize: unexpected char " c " at " pos)))))))))
|
||||
(step)
|
||||
(push! "eof" nil pos)
|
||||
tokens)))
|
||||
@@ -58,108 +58,50 @@ Key differences from Prolog:
|
||||
## Roadmap
|
||||
|
||||
### Phase 1 — tokenizer + parser
|
||||
- [x] Tokenizer: atoms (lowercase/quoted), variables (uppercase/`_`), numbers, strings,
|
||||
punct (`( )`, `,`, `.`), operators (`:-`, `?-`, `<=`, `>=`, `!=`, `<`, `>`, `=`,
|
||||
`+`, `-`, `*`, `/`), comments (`%`, `/* */`)
|
||||
Note: no function symbol syntax (no nested `f(...)` in arg position) — but the
|
||||
parser permits nested compounds for arithmetic; safety analysis (Phase 3) rejects
|
||||
non-arithmetic nesting.
|
||||
- [x] Parser:
|
||||
- [ ] Tokenizer: atoms (lowercase/quoted), variables (uppercase/`_`), numbers, strings,
|
||||
operators (`:- `, `?-`, `,`, `.`), comments (`%`, `/* */`)
|
||||
Note: no function symbol syntax (no nested `f(...)` in arg position).
|
||||
- [ ] Parser:
|
||||
- Facts: `parent(tom, bob).` → `{:head (parent tom bob) :body ()}`
|
||||
- Rules: `ancestor(X,Z) :- parent(X,Y), ancestor(Y,Z).`
|
||||
→ `{:head (ancestor X Z) :body ((parent X Y) (ancestor Y Z))}`
|
||||
- Queries: `?- ancestor(tom, X).` → `{:query ((ancestor tom X))}`
|
||||
(`:query` value is always a list of literals; `?- p, q.` → `{:query ((p) (q))}`)
|
||||
- Queries: `?- ancestor(tom, X).` → `{:query (ancestor tom X)}`
|
||||
- Negation: `not(parent(X,Y))` in body position → `{:neg (parent X Y)}`
|
||||
- [x] Tests in `lib/datalog/tests/parse.sx` (18) and `lib/datalog/tests/tokenize.sx` (26).
|
||||
Conformance harness: `bash lib/datalog/conformance.sh` → 44 / 44 passing.
|
||||
- [ ] Tests in `lib/datalog/tests/parse.sx`
|
||||
|
||||
### Phase 2 — unification + substitution
|
||||
- [x] Ported (not shared) from `lib/prolog/` — term walk, no occurs check.
|
||||
- [x] `dl-unify t1 t2 subst` → extended subst dict, or `nil` on failure.
|
||||
- [x] `dl-walk`, `dl-bind`, `dl-apply-subst`, `dl-ground?`, `dl-vars-of`.
|
||||
- [x] Substitutions are immutable dicts keyed by variable name (string).
|
||||
Lists/tuples unify element-wise (used for arithmetic compounds too).
|
||||
- [x] Tests in `lib/datalog/tests/unify.sx` (28). 72 / 72 conformance.
|
||||
- [ ] Share or port unification from `lib/prolog/` — term walk, occurs check off by default
|
||||
- [ ] `dl-unify` `t1` `t2` `subst` → extended subst or nil (no function symbols means simpler)
|
||||
- [ ] `dl-ground?` `term` → bool — all variables bound in substitution
|
||||
- [ ] Tests: atom/atom, var/atom, var/var, list args
|
||||
|
||||
### Phase 3 — extensional DB + naive evaluation + safety analysis
|
||||
- [x] EDB+IDB combined: `{:facts {<rel-name-string> -> (literal ...)}}` —
|
||||
relations indexed by name; tuples stored as full literals so they
|
||||
unify directly. Dedup on insert via `dl-tuple-equal?`.
|
||||
- [x] `dl-add-fact! db lit` (rejects non-ground) and `dl-add-rule! db rule`
|
||||
(rejects unsafe). `dl-program source` parses + loads in one step.
|
||||
- [x] Naive evaluation `dl-saturate! db`: iterate rules until no new tuples.
|
||||
`dl-find-bindings` recursively joins body literals; `dl-match-positive`
|
||||
unifies a literal against every tuple in the relation.
|
||||
- [x] `dl-query db goal` → list of substitutions over `goal`'s vars,
|
||||
deduplicated. `dl-relation db name` for derived tuples.
|
||||
- [x] Safety analysis at `dl-add-rule!` time: every head variable except
|
||||
`_` must appear in some positive body literal. Built-ins and negated
|
||||
literals do not satisfy safety. Helpers `dl-positive-body-vars`,
|
||||
`dl-rule-unsafe-head-vars` exposed for later phases.
|
||||
- [x] Negation and arithmetic built-ins error cleanly at saturate time
|
||||
(Phase 4 / Phase 7 will swap in real semantics).
|
||||
- [x] Tests in `lib/datalog/tests/eval.sx` (15): transitive closure,
|
||||
sibling, same-generation, grandparent, cyclic graph reach, six
|
||||
safety cases. 87 / 87 conformance.
|
||||
### Phase 3 — extensional DB + naive evaluation
|
||||
- [ ] EDB: `{:relation-name → set-of-ground-tuples}` using SX sets (Phase 18 of primitives)
|
||||
- [ ] `dl-add-fact!` `db` `relation` `args` → add ground tuple
|
||||
- [ ] `dl-add-rule!` `db` `head` `body` → add rule clause
|
||||
- [ ] Naive evaluation: iterate rules until fixpoint
|
||||
For each rule, for each combination of body tuples that unify, derive head tuple.
|
||||
Repeat until no new tuples added.
|
||||
- [ ] `dl-query` `db` `goal` → list of substitutions satisfying goal against derived DB
|
||||
- [ ] Tests: transitive closure (ancestor), sibling, same-generation — classic Datalog programs
|
||||
|
||||
### Phase 4 — built-in predicates + body arithmetic
|
||||
Almost every real query needs `<`, `=`, simple arithmetic, and string
|
||||
comparisons in body position. These are not EDB lookups — they're
|
||||
constraints that filter bindings.
|
||||
- [x] Recognise built-in predicates in body: `(< X Y)`, `(<= X Y)`, `(> X Y)`,
|
||||
`(>= X Y)`, `(= X Y)`, `(!= X Y)` and arithmetic forms `(is Z (+ X Y))`,
|
||||
`(is Z (- X Y))`, `(is Z (* X Y))`, `(is Z (/ X Y))`. Live in
|
||||
`lib/datalog/builtins.sx`.
|
||||
- [x] `dl-eval-builtin` dispatches; `dl-eval-arith` recursively evaluates
|
||||
`(+ a b)` etc. with full nesting. `=` unifies; `!=` rejects equal
|
||||
ground terms.
|
||||
- [x] Order-aware safety analysis (`dl-rule-check-safety`): walks body
|
||||
left-to-right tracking which vars are bound. `is`'s RHS vars must
|
||||
be already bound; LHS becomes bound. Comparisons require both
|
||||
sides bound. `=` is special-cased — at least one side bound binds
|
||||
the other. Negation vars must be bound (will be enforced fully in
|
||||
Phase 7).
|
||||
- [x] Wired through SX numeric primitives — no separate number tower.
|
||||
- [x] Tests in `lib/datalog/tests/builtins.sx` (19): range filters,
|
||||
arithmetic derivations, equality binding, eight safety violations
|
||||
and three safe-shape tests. Conformance 106 / 106.
|
||||
|
||||
### Phase 5 — semi-naive evaluation (performance)
|
||||
### Phase 4 — semi-naive evaluation (performance)
|
||||
- [ ] Delta sets: track newly derived tuples per iteration
|
||||
- [ ] Semi-naive rule: only join against delta tuples from last iteration, not full relation
|
||||
- [ ] Significant speedup for recursive rules — avoids re-deriving known tuples
|
||||
- [ ] `dl-stratify` `db` → dependency graph + SCC analysis → stratum ordering
|
||||
- [ ] Tests: verify semi-naive produces same results as naive; benchmark on large ancestor chain
|
||||
|
||||
### Phase 6 — magic sets (goal-directed bottom-up, opt-in)
|
||||
Naive bottom-up derives **all** consequences before answering. Magic sets
|
||||
rewrite the program so the fixpoint only derives tuples relevant to the
|
||||
goal — a major perf win for "what's reachable from node X" queries on
|
||||
large graphs.
|
||||
- [ ] Adornments: annotate rule predicates with bound (`b`) / free (`f`)
|
||||
patterns based on how they're called.
|
||||
- [ ] Magic transformation: for each adorned predicate, generate a
|
||||
`magic_<pred>` relation and rewrite rule bodies to filter through it.
|
||||
- [ ] Sideways information passing strategy (SIPS): left-to-right by
|
||||
default; pluggable.
|
||||
- [ ] Optional pass — `(dl-set-strategy! db :magic)`; default semi-naive.
|
||||
- [ ] Tests: equivalence vs naive on small inputs; perf win on a 10k-node
|
||||
reachability query from a single root.
|
||||
|
||||
### Phase 7 — stratified negation
|
||||
### Phase 5 — stratified negation
|
||||
- [ ] Dependency graph analysis: which relations depend on which (positively or negatively)
|
||||
- [ ] Stratification check: error if negation is in a cycle (non-stratifiable program)
|
||||
- [ ] `dl-stratify db` → SCC analysis → stratum ordering
|
||||
- [ ] Evaluation: process strata in order — lower stratum fully computed
|
||||
before using its complement in a higher stratum
|
||||
- [ ] `not(P)` in rule body: at evaluation time, check P is NOT in the
|
||||
derived EDB
|
||||
- [ ] Safety extension: head vars in negative literals must also appear in
|
||||
some positive body literal of the same rule
|
||||
- [ ] Tests: non-member (`not(member(X,L))`), colored-graph
|
||||
(`not(same-color(X,Y))`), stratification error detection
|
||||
- [ ] Evaluation: process strata in order — lower stratum fully computed before using its
|
||||
complement in a higher stratum
|
||||
- [ ] `not(P)` in rule body: at evaluation time, check P is NOT in the derived EDB
|
||||
- [ ] Tests: non-member (`not(member(X,L))`), colored-graph (`not(same-color(X,Y))`),
|
||||
stratification error detection
|
||||
|
||||
### Phase 8 — aggregation (Datalog+)
|
||||
### Phase 6 — aggregation (Datalog+)
|
||||
- [ ] `count(X, Goal)` → number of distinct X satisfying Goal
|
||||
- [ ] `sum(X, Goal)` → sum of X values satisfying Goal
|
||||
- [ ] `min(X, Goal)` / `max(X, Goal)` → min/max of X satisfying Goal
|
||||
@@ -167,7 +109,7 @@ large graphs.
|
||||
- [ ] Aggregation breaks stratification — evaluate in a separate post-fixpoint pass
|
||||
- [ ] Tests: social network statistics, grade aggregation, inventory sums
|
||||
|
||||
### Phase 9 — SX embedding API
|
||||
### Phase 7 — SX embedding API
|
||||
- [ ] `(dl-program facts rules)` → database from SX data directly (no parsing required)
|
||||
```
|
||||
(dl-program
|
||||
@@ -181,7 +123,7 @@ large graphs.
|
||||
- [ ] Integration demo: federation graph query — `(ancestor actor1 actor2)` over
|
||||
rose-ash ActivityPub follow relationships
|
||||
|
||||
### Phase 10 — Datalog as a query language for rose-ash
|
||||
### Phase 8 — Datalog as a query language for rose-ash
|
||||
- [ ] Schema: map SQLAlchemy model relationships to Datalog EDB facts
|
||||
(e.g. `(follows user1 user2)`, `(authored user post)`, `(tagged post tag)`)
|
||||
- [ ] Loader: `dl-load-from-db!` — query PostgreSQL, populate Datalog EDB
|
||||
@@ -200,42 +142,4 @@ _(none yet)_
|
||||
|
||||
_Newest first._
|
||||
|
||||
- 2026-05-07 — Phase 4 done. `lib/datalog/builtins.sx` (~280 LOC) adds
|
||||
`(< X Y)`, `(<= X Y)`, `(> X Y)`, `(>= X Y)`, `(= X Y)`, `(!= X Y)`,
|
||||
and `(is X expr)` with `+ - * /`. `dl-eval-builtin` dispatches;
|
||||
`dl-eval-arith` recursively evaluates nested compounds. Safety
|
||||
check is now order-aware — it walks body literals left-to-right
|
||||
tracking the bound set, requires comparison/`is` inputs to be
|
||||
already bound, and special-cases `=` (binds the var-side; both
|
||||
sides must include at least one bound to bind the other). Phase 3's
|
||||
simple safety check stays in db.sx as a forward-reference fallback;
|
||||
builtins.sx redefines `dl-rule-check-safety` to the comprehensive
|
||||
version. eval.sx's `dl-match-lit` now dispatches built-ins through
|
||||
`dl-eval-builtin`. 19 builtins tests; conformance 106 / 106.
|
||||
|
||||
- 2026-05-07 — Phase 3 done. `lib/datalog/db.sx` (~250 LOC) holds facts
|
||||
indexed by relation name plus the rules list, with `dl-add-fact!` /
|
||||
`dl-add-rule!` (rejects non-ground facts and unsafe rules);
|
||||
`lib/datalog/eval.sx` (~150 LOC) implements the naive bottom-up
|
||||
fixpoint via `dl-find-bindings`/`dl-match-positive`/`dl-saturate!`
|
||||
and `dl-query` (deduped projected substitutions). Safety analysis
|
||||
rejects unsafe head vars at load time. Negation and arithmetic
|
||||
built-ins raise clean errors (lifted in later phases). 15 eval
|
||||
tests cover transitive closure, sibling, same-generation, cyclic
|
||||
graph reach, and six safety violations. Conformance 87 / 87.
|
||||
|
||||
- 2026-05-07 — Phase 2 done. `lib/datalog/unify.sx` (~140 LOC):
|
||||
`dl-var?` (case + underscore), `dl-walk`, `dl-bind`, `dl-unify` (returns
|
||||
extended dict subst or `nil`), `dl-apply-subst`, `dl-ground?`, `dl-vars-of`.
|
||||
Substitutions are immutable dicts; `assoc` builds extended copies. 28
|
||||
unify tests; conformance now 72 / 72.
|
||||
|
||||
- 2026-05-07 — Phase 1 done. `lib/datalog/tokenizer.sx` (~190 LOC) emits
|
||||
`{:type :value :pos}` tokens; `lib/datalog/parser.sx` (~150 LOC) produces
|
||||
`{:head … :body …}` / `{:query …}` clauses, with nested compounds
|
||||
permitted for arithmetic and `not(...)` desugared to `{:neg …}`. 44 / 44
|
||||
via `bash lib/datalog/conformance.sh` (26 tokenize + 18 parse). Local
|
||||
helpers namespace-prefixed (`dl-emit!`, `dl-peek`) after a host-primitive
|
||||
shadow clash. Test harness uses a custom `dl-deep-equal?` that handles
|
||||
out-of-order dict keys and number repr (`equal?` fails on dict key order
|
||||
and on `30` vs `30.0`).
|
||||
_(awaiting phase 1)_
|
||||
|
||||
@@ -116,20 +116,22 @@ SX CEK evaluator (both JS and OCaml hosts)
|
||||
|
||||
### Phase 1 — Tokenizer + parser
|
||||
|
||||
- [ ] **Tokenizer:** keywords (`let`, `rec`, `in`, `fun`, `function`, `match`, `with`,
|
||||
- [x] **Tokenizer:** keywords (`let`, `rec`, `in`, `fun`, `function`, `match`, `with`,
|
||||
`type`, `of`, `module`, `struct`, `end`, `functor`, `sig`, `open`, `include`,
|
||||
`if`, `then`, `else`, `begin`, `try`, `exception`, `raise`, `mutable`,
|
||||
`for`, `while`, `do`, `done`, `and`, `as`, `when`), operators (`->`, `|>`,
|
||||
`<|`, `@@`, `@`, `:=`, `!`, `::`, `**`, `:`, `;`, `;;`), identifiers (lower,
|
||||
upper/ctor, labels `~label:`, optional `?label:`), char literals `'c'`,
|
||||
string literals (escaped + heredoc `{|...|}`), int/float literals,
|
||||
line comments `(*` nested block comments `*)`.
|
||||
- [ ] **Parser:** top-level `let`/`let rec`/`type`/`module`/`exception`/`open`/`include`
|
||||
declarations; expressions: literals, identifiers, constructor application,
|
||||
lambda, application (left-assoc), binary ops with precedence table,
|
||||
`if`/`then`/`else`, `match`/`with`, `try`/`with`, `let`/`in`, `begin`/`end`,
|
||||
`fun`/`function`, tuples, list literals, record literals/updates, field access,
|
||||
sequences `;`, unit `()`.
|
||||
upper/ctor), char literals `'c'`, string literals (escaped),
|
||||
int/float literals (incl. hex, exponent, underscores), nested block
|
||||
comments `(* ... *)`. _(labels `~label:` / `?label:` and heredoc `{|...|}`
|
||||
deferred — surface tokens already work via `~`/`?` punct + `{`/`|` punct.)_
|
||||
- [~] **Parser:** expressions: literals, identifiers, constructor application,
|
||||
lambda, application (left-assoc), binary ops with precedence (29 ops via
|
||||
`lib/guest/pratt.sx`), `if`/`then`/`else`, `let`/`in`, `let rec`,
|
||||
`fun`/`->`, tuples, list literals, `begin`/`end`, unit `()`. _(Pending:
|
||||
top-level `let`/`type`/`module`/`exception`/`open`/`include` decls,
|
||||
`match`/`with`, `try`/`with`, `function`, record literals/updates,
|
||||
field access, sequences `;`.)_
|
||||
- [ ] **Patterns:** constructor, literal, variable, wildcard `_`, tuple, list cons `::`,
|
||||
list literal, record, `as`, or-pattern `P1 | P2`, `when` guard.
|
||||
- [ ] OCaml is **not** indentation-sensitive — no layout algorithm needed.
|
||||
@@ -308,7 +310,20 @@ the "mother tongue" closure: OCaml → SX → OCaml. This means:
|
||||
|
||||
_Newest first._
|
||||
|
||||
_(awaiting phase 1)_
|
||||
- 2026-05-07 Phase 1 — `lib/ocaml/parser.sx` expression parser consuming
|
||||
`lib/guest/pratt.sx` for binop precedence (29 operators across 8 levels,
|
||||
incl. keyword-spelled binops `mod`/`land`/`lor`/`lxor`/`lsl`/`lsr`/`asr`).
|
||||
Atoms (literals + var/con/unit/list), application (left-assoc), prefix
|
||||
`-`/`not`, tuples, parens, `if`/`then`/`else`, `fun x y -> body`,
|
||||
`let`/`let rec` with function shorthand. AST shapes match Haskell-on-SX
|
||||
conventions (`(:int N)` `(:op OP L R)` `(:fun PARAMS BODY)` etc.). Total
|
||||
95/95 tests now passing via `lib/ocaml/test.sh`.
|
||||
- 2026-05-07 Phase 1 — `lib/ocaml/tokenizer.sx` consuming `lib/guest/lex.sx`
|
||||
via `prefix-rename`. Covers idents, ctors, 51 keywords, numbers (int / float
|
||||
/ hex / exponent / underscored), strings (with escapes), chars (with escapes),
|
||||
type variables (`'a`), nested block comments, and 26 operator/punct tokens
|
||||
(incl. `->` `|>` `<-` `:=` `::` `;;` `@@` `<>` `&&` `||` `**` etc.). 58/58
|
||||
tokenizer tests pass via `lib/ocaml/test.sh` driving `sx_server.exe`.
|
||||
|
||||
## Blockers
|
||||
|
||||
|
||||
Reference in New Issue
Block a user