coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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
Details

Browse Source 
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:
giles
2026-06-07 15:44:25 +00:00
parent cc0f3f1ff7
commit 3bb4886f0f
6 changed files with 112 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files

42
lib/maude/parser.sx
View File

@@ -19,7 +19,8 @@
;; 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
;; _+_ 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 ----------
@@ -173,6 +174,21 @@
((p (get (get op :attrs) :prec)))
(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
mau/build-infix-table
(fn
@@ -187,7 +203,11 @@
(if
(= (get form :kind) "infix")
(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))))))
@@ -310,11 +330,13 @@
(do
(tadv!)
(let
((rhs (parse-expr (+ lbp 1))))
(climb
(mau/app
(nth entry 2)
(list acc rhs))))))))))))
((rbp (if (= (nth entry 3) "right") lbp (+ lbp 1))))
(let
((rhs (parse-expr rbp)))
(climb
(mau/app
(nth entry 2)
(list acc rhs)))))))))))))
(climb lhs))))
(parse-expr 0))))
@@ -398,6 +420,12 @@
(do
(dict-set! acc :label (nth ts 1))
(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))))))
(do (loop toks) acc))))