maude: gather / parse-time associativity for cons lists (7 tests, 236 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 38s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 38s
Infix ops parse left (default / gather (E e)) or right (gather (e E)) per the gather attribute, so _:_ [gather (e E)] reads a : b : c as right-nested. Full insertion sort now runs over bare cons lists with no parentheses. Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -26,6 +26,7 @@ SUITES=(
|
|||||||
"matching:lib/maude/tests/matching.sx:(mau-matching-tests-run!)"
|
"matching:lib/maude/tests/matching.sx:(mau-matching-tests-run!)"
|
||||||
"conditional:lib/maude/tests/conditional.sx:(mau-conditional-tests-run!)"
|
"conditional:lib/maude/tests/conditional.sx:(mau-conditional-tests-run!)"
|
||||||
"owise:lib/maude/tests/owise.sx:(mau-owise-tests-run!)"
|
"owise:lib/maude/tests/owise.sx:(mau-owise-tests-run!)"
|
||||||
|
"gather:lib/maude/tests/gather.sx:(mau-gather-tests-run!)"
|
||||||
"rewrite:lib/maude/tests/rewrite.sx:(mau-rewrite-tests-run!)"
|
"rewrite:lib/maude/tests/rewrite.sx:(mau-rewrite-tests-run!)"
|
||||||
"searchpath:lib/maude/tests/searchpath.sx:(mau-searchpath-tests-run!)"
|
"searchpath:lib/maude/tests/searchpath.sx:(mau-searchpath-tests-run!)"
|
||||||
"strategy:lib/maude/tests/strategy.sx:(mau-strategy-tests-run!)"
|
"strategy:lib/maude/tests/strategy.sx:(mau-strategy-tests-run!)"
|
||||||
|
|||||||
@@ -19,7 +19,8 @@
|
|||||||
;; Terms: prefix application f(a,b) (op name may contain underscores, e.g.
|
;; Terms: prefix application f(a,b) (op name may contain underscores, e.g.
|
||||||
;; the prefix form _+_(2,3)); mixfix prefix s_ written `s X`; mixfix infix
|
;; the prefix form _+_(2,3)); mixfix prefix s_ written `s X`; mixfix infix
|
||||||
;; _+_ written `X + Y`, parsed by precedence climbing over a table built
|
;; _+_ written `X + Y`, parsed by precedence climbing over a table built
|
||||||
;; from the op declarations.
|
;; from the op declarations. Infix associativity follows `gather`: (E e)=left
|
||||||
|
;; (default), (e E)=right (e.g. cons _:_), so `a : b : c` parses right-nested.
|
||||||
|
|
||||||
;; ---------- tokenizer ----------
|
;; ---------- tokenizer ----------
|
||||||
|
|
||||||
@@ -173,6 +174,21 @@
|
|||||||
((p (get (get op :attrs) :prec)))
|
((p (get (get op :attrs) :prec)))
|
||||||
(if (= p nil) (mau/default-prec (get form :kind)) p))))
|
(if (= p nil) (mau/default-prec (get form :kind)) p))))
|
||||||
|
|
||||||
|
;; parse associativity from a gather spec: (E e)=left, (e E)=right.
|
||||||
|
(define
|
||||||
|
mau/gather-assoc
|
||||||
|
(fn
|
||||||
|
(attrs)
|
||||||
|
(let
|
||||||
|
((g (get attrs :gather)))
|
||||||
|
(if
|
||||||
|
(or (= g nil) (< (len g) 2))
|
||||||
|
"left"
|
||||||
|
(cond
|
||||||
|
((= (nth g 1) "E") "right")
|
||||||
|
((= (nth g 0) "E") "left")
|
||||||
|
(else "left"))))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
mau/build-infix-table
|
mau/build-infix-table
|
||||||
(fn
|
(fn
|
||||||
@@ -187,7 +203,11 @@
|
|||||||
(if
|
(if
|
||||||
(= (get form :kind) "infix")
|
(= (get form :kind) "infix")
|
||||||
(cons
|
(cons
|
||||||
(list (get form :token) (mau/op-prec op form) (get op :name))
|
(list
|
||||||
|
(get form :token)
|
||||||
|
(mau/op-prec op form)
|
||||||
|
(get op :name)
|
||||||
|
(mau/gather-assoc (get op :attrs)))
|
||||||
rest-tbl)
|
rest-tbl)
|
||||||
rest-tbl))))))
|
rest-tbl))))))
|
||||||
|
|
||||||
@@ -310,11 +330,13 @@
|
|||||||
(do
|
(do
|
||||||
(tadv!)
|
(tadv!)
|
||||||
(let
|
(let
|
||||||
((rhs (parse-expr (+ lbp 1))))
|
((rbp (if (= (nth entry 3) "right") lbp (+ lbp 1))))
|
||||||
(climb
|
(let
|
||||||
(mau/app
|
((rhs (parse-expr rbp)))
|
||||||
(nth entry 2)
|
(climb
|
||||||
(list acc rhs))))))))))))
|
(mau/app
|
||||||
|
(nth entry 2)
|
||||||
|
(list acc rhs)))))))))))))
|
||||||
(climb lhs))))
|
(climb lhs))))
|
||||||
(parse-expr 0))))
|
(parse-expr 0))))
|
||||||
|
|
||||||
@@ -398,6 +420,12 @@
|
|||||||
(do
|
(do
|
||||||
(dict-set! acc :label (nth ts 1))
|
(dict-set! acc :label (nth ts 1))
|
||||||
(loop (mau/drop ts 2))))
|
(loop (mau/drop ts 2))))
|
||||||
|
((= (first ts) "gather")
|
||||||
|
(let
|
||||||
|
((after2 (mau/drop ts 2)))
|
||||||
|
(do
|
||||||
|
(dict-set! acc :gather (mau/take-until after2 ")"))
|
||||||
|
(loop (rest (mau/drop-until after2 ")"))))))
|
||||||
(else (loop (rest ts))))))
|
(else (loop (rest ts))))))
|
||||||
(do (loop toks) acc))))
|
(do (loop toks) acc))))
|
||||||
|
|
||||||
|
|||||||
@@ -1,14 +1,15 @@
|
|||||||
{
|
{
|
||||||
"lang": "maude",
|
"lang": "maude",
|
||||||
"total_passed": 229,
|
"total_passed": 236,
|
||||||
"total_failed": 0,
|
"total_failed": 0,
|
||||||
"total": 229,
|
"total": 236,
|
||||||
"suites": [
|
"suites": [
|
||||||
{"name":"parse","passed":65,"failed":0,"total":65},
|
{"name":"parse","passed":65,"failed":0,"total":65},
|
||||||
{"name":"reduce","passed":26,"failed":0,"total":26},
|
{"name":"reduce","passed":26,"failed":0,"total":26},
|
||||||
{"name":"matching","passed":28,"failed":0,"total":28},
|
{"name":"matching","passed":28,"failed":0,"total":28},
|
||||||
{"name":"conditional","passed":19,"failed":0,"total":19},
|
{"name":"conditional","passed":19,"failed":0,"total":19},
|
||||||
{"name":"owise","passed":8,"failed":0,"total":8},
|
{"name":"owise","passed":8,"failed":0,"total":8},
|
||||||
|
{"name":"gather","passed":7,"failed":0,"total":7},
|
||||||
{"name":"rewrite","passed":21,"failed":0,"total":21},
|
{"name":"rewrite","passed":21,"failed":0,"total":21},
|
||||||
{"name":"searchpath","passed":8,"failed":0,"total":8},
|
{"name":"searchpath","passed":8,"failed":0,"total":8},
|
||||||
{"name":"strategy","passed":19,"failed":0,"total":19},
|
{"name":"strategy","passed":19,"failed":0,"total":19},
|
||||||
@@ -16,5 +17,5 @@
|
|||||||
{"name":"pretty","passed":11,"failed":0,"total":11},
|
{"name":"pretty","passed":11,"failed":0,"total":11},
|
||||||
{"name":"run","passed":6,"failed":0,"total":6}
|
{"name":"run","passed":6,"failed":0,"total":6}
|
||||||
],
|
],
|
||||||
"generated": "2026-06-07T15:39:50+00:00"
|
"generated": "2026-06-07T15:43:54+00:00"
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -1,6 +1,6 @@
|
|||||||
# maude scoreboard
|
# maude scoreboard
|
||||||
|
|
||||||
**229 / 229 passing** (0 failure(s)).
|
**236 / 236 passing** (0 failure(s)).
|
||||||
|
|
||||||
| Suite | Passed | Total | Status |
|
| Suite | Passed | Total | Status |
|
||||||
|-------|--------|-------|--------|
|
|-------|--------|-------|--------|
|
||||||
@@ -9,6 +9,7 @@
|
|||||||
| matching | 28 | 28 | ok |
|
| matching | 28 | 28 | ok |
|
||||||
| conditional | 19 | 19 | ok |
|
| conditional | 19 | 19 | ok |
|
||||||
| owise | 8 | 8 | ok |
|
| owise | 8 | 8 | ok |
|
||||||
|
| gather | 7 | 7 | ok |
|
||||||
| rewrite | 21 | 21 | ok |
|
| rewrite | 21 | 21 | ok |
|
||||||
| searchpath | 8 | 8 | ok |
|
| searchpath | 8 | 8 | ok |
|
||||||
| strategy | 19 | 19 | ok |
|
| strategy | 19 | 19 | ok |
|
||||||
|
|||||||
66
lib/maude/tests/gather.sx
Normal file
66
lib/maude/tests/gather.sx
Normal file
@@ -0,0 +1,66 @@
|
|||||||
|
;; lib/maude/tests/gather.sx — gather / parse-time associativity.
|
||||||
|
|
||||||
|
(define mga-pass 0)
|
||||||
|
(define mga-fail 0)
|
||||||
|
(define mga-failures (list))
|
||||||
|
|
||||||
|
(define
|
||||||
|
mga-check!
|
||||||
|
(fn
|
||||||
|
(name got expected)
|
||||||
|
(if
|
||||||
|
(= got expected)
|
||||||
|
(set! mga-pass (+ mga-pass 1))
|
||||||
|
(do
|
||||||
|
(set! mga-fail (+ mga-fail 1))
|
||||||
|
(append!
|
||||||
|
mga-failures
|
||||||
|
(str name " expected: " expected " got: " got))))))
|
||||||
|
|
||||||
|
(define
|
||||||
|
mga-m
|
||||||
|
(mau/parse-module
|
||||||
|
"fmod L is\n sorts Nat List .\n op 0 : -> Nat .\n op s_ : Nat -> Nat .\n op nil : -> List .\n op _:_ : Nat List -> List [gather (e E)] .\n op _+_ : Nat Nat -> Nat .\n op _-_ : Nat Nat -> Nat [gather (E e)] .\n vars X Y : Nat .\nendfm"))
|
||||||
|
|
||||||
|
;; cons is right-associative: a : b : c == a : (b : c)
|
||||||
|
(mga-check!
|
||||||
|
"cons-right"
|
||||||
|
(mau/term->str (mau/parse-term-in mga-m "0 : s 0 : nil"))
|
||||||
|
"_:_(0, _:_(s_(0), nil))")
|
||||||
|
;; + has no gather -> default left-assoc
|
||||||
|
(mga-check!
|
||||||
|
"plus-left"
|
||||||
|
(mau/term->str (mau/parse-term-in mga-m "X + Y + X"))
|
||||||
|
"_+_(_+_(X, Y), X)")
|
||||||
|
;; explicit (E e) is left
|
||||||
|
(mga-check!
|
||||||
|
"minus-left"
|
||||||
|
(mau/term->str (mau/parse-term-in mga-m "X - Y - X"))
|
||||||
|
"_-_(_-_(X, Y), X)")
|
||||||
|
;; gather attr recorded
|
||||||
|
(mga-check!
|
||||||
|
"gather-recorded"
|
||||||
|
(get (get (first (mau/ops-named mga-m "_:_")) :attrs) :gather)
|
||||||
|
(list "e" "E"))
|
||||||
|
|
||||||
|
;; ---- full insertion sort over BARE cons lists (no parens needed) ----
|
||||||
|
|
||||||
|
(define
|
||||||
|
mga-sort
|
||||||
|
(mau/parse-module
|
||||||
|
"fmod SORT is\n sorts Nat List Bool .\n op 0 : -> Nat .\n op s_ : Nat -> Nat .\n op true : -> Bool .\n op false : -> Bool .\n op _<=_ : Nat Nat -> Bool .\n op nil : -> List .\n op _:_ : Nat List -> List [gather (e E)] .\n op insert : Nat List -> List .\n op sort : List -> List .\n vars M N : Nat .\n var L : List .\n eq 0 <= N = true .\n eq s M <= 0 = false .\n eq s M <= s N = M <= N .\n eq insert(N, nil) = N : nil .\n ceq insert(N, M : L) = N : M : L if N <= M = true .\n ceq insert(N, M : L) = M : insert(N, L) if N <= M = false .\n eq sort(nil) = nil .\n eq sort(N : L) = insert(N, sort(L)) .\nendfm"))
|
||||||
|
|
||||||
|
(mga-check!
|
||||||
|
"sort-bare"
|
||||||
|
(mau/creduce->str mga-sort "sort(s s s 0 : s 0 : s s 0 : nil)")
|
||||||
|
"_:_(s_(0), _:_(s_(s_(0)), _:_(s_(s_(s_(0))), nil)))")
|
||||||
|
(mga-check!
|
||||||
|
"sort-bare-5"
|
||||||
|
(mau/creduce->str mga-sort "sort(s s 0 : 0 : s 0 : nil)")
|
||||||
|
"_:_(0, _:_(s_(0), _:_(s_(s_(0)), nil)))")
|
||||||
|
(mga-check!
|
||||||
|
"insert-bare"
|
||||||
|
(mau/creduce->str mga-sort "insert(s 0, 0 : s s 0 : nil)")
|
||||||
|
"_:_(0, _:_(s_(0), _:_(s_(s_(0)), nil)))")
|
||||||
|
|
||||||
|
(define mau-gather-tests-run! (fn () {:failures mga-failures :total (+ mga-pass mga-fail) :passed mga-pass :failed mga-fail}))
|
||||||
@@ -112,6 +112,10 @@ The novel substrate stress: equational matching. Pattern `X + Y` against `1 + 2
|
|||||||
- [x] Witness-path search (`lib/maude/searchpath.sx`) — `mau/search-path` /
|
- [x] Witness-path search (`lib/maude/searchpath.sx`) — `mau/search-path` /
|
||||||
`mau/search-length` return the shortest sequence of states start..goal (the
|
`mau/search-length` return the shortest sequence of states start..goal (the
|
||||||
solution moves), not just yes/no. 8 tests.
|
solution moves), not just yes/no. 8 tests.
|
||||||
|
- [x] `gather` / parse-time associativity — infix ops parse left (default,
|
||||||
|
`(E e)`) or right (`(e E)`) per the gather attr, so cons `_:_ [gather (e E)]`
|
||||||
|
reads `a : b : c` as right-nested. Full insertion sort now runs over BARE cons
|
||||||
|
lists (no parens). 7 tests.
|
||||||
- [x] `owise` equations — parser now reads trailing eq attributes
|
- [x] `owise` equations — parser now reads trailing eq attributes
|
||||||
(`eq L = R [owise] .`), `mau/split-attrs`; `mau/crewrite-top` is two-pass
|
(`eq L = R [owise] .`), `mau/split-attrs`; `mau/crewrite-top` is two-pass
|
||||||
(ordinary equations first, owise last), so an owise catch-all fires only when
|
(ordinary equations first, owise last), so an owise catch-all fires only when
|
||||||
|
|||||||
Reference in New Issue
Block a user