coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
2378056cb3673ea8f3a8a2d4096c0c634a9bd0ca
rose-ash/lib/maude/tests/parse.sx
giles 9f87206949
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m14s
Details
maude: Phase 1 parser — fmod/mod modules, signatures, mixfix terms (65 tests) 
Term representation (lib/maude/term.sx) plus a module parser
(lib/maude/parser.sx) consuming lib/guest/lex + pratt:

- whitespace+bracket tokenizer (--- / *** comments)
- mixfix classification (split op names on _): infix/prefix/postfix/const
- precedence-climbing term parser over a pratt table built from op decls
- fmod/mod ... endfm/endm with sort/subsort/op/var/eq/ceq/rl/crl
- transitive subsort hierarchy + operator overloading queries

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 14:43:02 +00:00

251 lines
7.4 KiB
Plaintext
Raw Blame History

;; lib/maude/tests/parse.sx — Phase 1: tokenizer, signatures, term/eq parsing.
(define mpt-pass 0)
(define mpt-fail 0)
(define mpt-failures (list))
(define
mpt-check!
(fn
(name got expected)
(if
(= got expected)
(set! mpt-pass (+ mpt-pass 1))
(do
(set! mpt-fail (+ mpt-fail 1))
(append!
mpt-failures
(str name " expected: " expected " got: " got))))))
;; ---- modules under test ----
(define
mpt-peano
(mau/parse-module
"fmod PEANO is\n sort Nat .\n op 0 : -> Nat .\n op s_ : Nat -> Nat .\n op _+_ : Nat Nat -> Nat [assoc comm prec 33] .\n op _*_ : Nat Nat -> Nat [assoc comm] .\n vars X Y : Nat .\n eq 0 + X = X .\n eq s X + Y = s (X + Y) .\n eq 0 * X = 0 .\nendfm"))
(define
mpt-natlist
(mau/parse-module
"fmod NATLIST is\n sorts Zero NzNat Nat List .\n subsort Zero < Nat .\n subsort NzNat < Nat .\n subsort Nat < List .\n op 0 : -> Zero .\n op nil : -> List .\n op _;_ : List List -> List [assoc id: nil] .\n op head : List -> Nat .\n op length : List -> Nat .\n vars L M : List .\n var N : Nat .\n eq length(nil) = 0 .\n eq head(N ; L) = N .\nendfm"))
;; ---- tokenizer ----
(define mpt-toks (mau/tokenize "op _+_ : Nat Nat -> Nat [assoc] ."))
(mpt-check! "tok-count" (len mpt-toks) 11)
(mpt-check! "tok-op" (nth mpt-toks 0) "op")
(mpt-check! "tok-mixfix" (nth mpt-toks 1) "_+_")
(mpt-check! "tok-colon" (nth mpt-toks 2) ":")
(mpt-check! "tok-arrow" (nth mpt-toks 5) "->")
(mpt-check! "tok-lbrack" (nth mpt-toks 7) "[")
(mpt-check! "tok-dot" (nth mpt-toks 10) ".")
(mpt-check!
"tok-comment"
(len (mau/tokenize "sort Nat . --- a comment\nop 0 : -> Nat ."))
9)
;; ---- mixfix classification ----
(mpt-check! "form-infix" (get (mau/op-form "_+_") :kind) "infix")
(mpt-check! "form-infix-tok" (get (mau/op-form "_+_") :token) "+")
(mpt-check! "form-prefix" (get (mau/op-form "s_") :kind) "prefix")
(mpt-check! "form-prefix-tok" (get (mau/op-form "s_") :token) "s")
(mpt-check! "form-postfix" (get (mau/op-form "_!") :kind) "postfix")
(mpt-check! "form-const" (get (mau/op-form "nil") :kind) "const")
(mpt-check!
"form-mixfix"
(get (mau/op-form "if_then_else_fi") :kind)
"mixfix")
;; ---- module header / sorts ----
(mpt-check! "mod-name" (mau/module-name mpt-peano) "PEANO")
(mpt-check! "mod-kind" (mau/module-kind mpt-peano) "fmod")
(mpt-check! "mod-sorts" (mau/module-sorts mpt-peano) (list "Nat"))
(mpt-check!
"natlist-sorts-count"
(len (mau/module-sorts mpt-natlist))
4)
;; ---- subsorts (direct + transitive) ----
(mpt-check! "subsort-direct" (mau/subsort? mpt-natlist "NzNat" "Nat") true)
(mpt-check! "subsort-trans" (mau/subsort? mpt-natlist "NzNat" "List") true)
(mpt-check! "subsort-trans2" (mau/subsort? mpt-natlist "Zero" "List") true)
(mpt-check! "subsort-none" (mau/subsort? mpt-natlist "List" "Nat") false)
(mpt-check! "sort<=-refl" (mau/sort<=? mpt-natlist "Nat" "Nat") true)
(mpt-check! "sort<=-trans" (mau/sort<=? mpt-natlist "Zero" "List") true)
;; ---- operators / overloading ----
(mpt-check! "ops-count" (len (mau/module-ops mpt-peano)) 4)
(mpt-check!
"op-arity"
(get (first (mau/ops-named mpt-peano "_+_")) :arity)
(list "Nat" "Nat"))
(mpt-check!
"op-result"
(get (first (mau/ops-named mpt-peano "s_")) :result)
"Nat")
(mpt-check!
"op-const-arity"
(len (get (first (mau/ops-named mpt-peano "0")) :arity))
0)
(mpt-check!
"natlist-ops-count"
(len (mau/module-ops mpt-natlist))
5)
;; ---- attributes ----
(mpt-check!
"attr-assoc"
(get (get (first (mau/ops-named mpt-peano "_+_")) :attrs) :assoc)
true)
(mpt-check!
"attr-comm"
(get (get (first (mau/ops-named mpt-peano "_+_")) :attrs) :comm)
true)
(mpt-check!
"attr-prec"
(get (get (first (mau/ops-named mpt-peano "_+_")) :attrs) :prec)
33)
(mpt-check!
"attr-id"
(get (get (first (mau/ops-named mpt-natlist "_;_")) :attrs) :id)
"nil")
(mpt-check!
"attr-absent"
(get (get (first (mau/ops-named mpt-peano "_*_")) :attrs) :prec)
nil)
;; ---- variables ----
(mpt-check! "var-sort" (get (mau/module-vars mpt-peano) "X") "Nat")
(mpt-check! "var-list-sort" (get (mau/module-vars mpt-natlist) "L") "List")
;; ---- term parsing ----
(mpt-check!
"term-const"
(mau/term->str (mau/parse-term-in mpt-peano "0"))
"0")
(mpt-check!
"term-prefix-mixfix"
(mau/term->str (mau/parse-term-in mpt-peano "s 0"))
"s_(0)")
(mpt-check!
"term-nested-prefix"
(mau/term->str (mau/parse-term-in mpt-peano "s s 0"))
"s_(s_(0))")
(mpt-check!
"term-infix"
(mau/term->str (mau/parse-term-in mpt-peano "X + Y"))
"_+_(X, Y)")
(mpt-check!
"term-prec"
(mau/term->str (mau/parse-term-in mpt-peano "s X + Y"))
"_+_(s_(X), Y)")
(mpt-check!
"term-paren"
(mau/term->str (mau/parse-term-in mpt-peano "s (X + Y)"))
"s_(_+_(X, Y))")
(mpt-check!
"term-left-assoc"
(mau/term->str (mau/parse-term-in mpt-peano "X + Y + X"))
"_+_(_+_(X, Y), X)")
(mpt-check!
"term-prefix-form"
(mau/term->str (mau/parse-term-in mpt-peano "_+_(X, 0)"))
"_+_(X, 0)")
(mpt-check!
"term-funcall"
(mau/term->str (mau/parse-term-in mpt-natlist "length(nil)"))
"length(nil)")
(mpt-check!
"term-onthefly-var"
(mau/var? (mau/parse-term-in mpt-peano "Z:Nat"))
true)
(mpt-check!
"term-onthefly-sort"
(mau/vsort (mau/parse-term-in mpt-peano "Z:Nat"))
"Nat")
(mpt-check!
"term-var-vs-const"
(mau/var? (mau/parse-term-in mpt-peano "X"))
true)
(mpt-check!
"term-const-not-var"
(mau/var? (mau/parse-term-in mpt-peano "0"))
false)
;; ---- equations ----
(mpt-check! "eq-count" (len (mau/module-eqs mpt-peano)) 3)
(mpt-check!
"eq-lhs"
(mau/term->str (get (nth (mau/module-eqs mpt-peano) 1) :lhs))
"_+_(s_(X), Y)")
(mpt-check!
"eq-rhs"
(mau/term->str (get (nth (mau/module-eqs mpt-peano) 1) :rhs))
"s_(_+_(X, Y))")
(mpt-check!
"eq-uncond"
(get (nth (mau/module-eqs mpt-peano) 0) :cond)
nil)
(mpt-check!
"natlist-eq-head"
(mau/term->str (get (nth (mau/module-eqs mpt-natlist) 1) :lhs))
"head(_;_(N, L))")
;; ---- conditional equations ----
(define
mpt-gcd
(mau/parse-module
"fmod GCD is\n sort Nat .\n op _>_ : Nat Nat -> Bool .\n op _-_ : Nat Nat -> Nat .\n op gcd : Nat Nat -> Nat .\n vars X Y : Nat .\n ceq gcd(X, Y) = gcd(X - Y, Y) if X > Y = true .\nendfm"))
(mpt-check! "ceq-count" (len (mau/module-eqs mpt-gcd)) 1)
(mpt-check!
"ceq-has-cond"
(= (get (first (mau/module-eqs mpt-gcd)) :cond) nil)
false)
(mpt-check!
"ceq-cond-kind"
(get (get (first (mau/module-eqs mpt-gcd)) :cond) :kind)
"eq")
(mpt-check!
"ceq-cond-lhs"
(mau/term->str (get (get (first (mau/module-eqs mpt-gcd)) :cond) :lhs))
"_>_(X, Y)")
;; ---- system module + rules ----
(define
mpt-vending
(mau/parse-module
"mod VENDING is\n sort State .\n op _coin : State -> State .\n op buy : State -> State .\n var S : State .\n rl [insert] : S coin => buy(S) .\n crl [guard] : buy(S) => S if S = S .\nendfm"))
(mpt-check! "mod-kind-mod" (mau/module-kind mpt-vending) "mod")
(mpt-check! "rules-count" (len (mau/module-rules mpt-vending)) 2)
(mpt-check!
"rule-label"
(get (first (mau/module-rules mpt-vending)) :label)
"insert")
(mpt-check!
"rule-rhs"
(mau/term->str (get (first (mau/module-rules mpt-vending)) :rhs))
"buy(S)")
(mpt-check!
"crl-label"
(get (nth (mau/module-rules mpt-vending) 1) :label)
"guard")
(mpt-check!
"crl-cond-kind"
(get (get (nth (mau/module-rules mpt-vending) 1) :cond) :kind)
"eq")
(define mau-parse-tests-run! (fn () {:failures mpt-failures :total (+ mpt-pass mpt-fail) :passed mpt-pass :failed mpt-fail}))
Reference in New Issue View Git Blame Copy Permalink