giles
3190e770fb
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
308 lines
9.0 KiB
Plaintext
308 lines
9.0 KiB
Plaintext
;; lib/prolog/parser.sx — tokens → Prolog AST
|
|
;;
|
|
;; Phase 4 grammar (with operator table):
|
|
;; Program := Clause* EOF
|
|
;; Clause := Term[999] "." | Term[999] ":-" Term[1200] "."
|
|
;; Term[Pmax] uses precedence climbing on the operator table:
|
|
;; primary = Atom | Var | Number | String | Compound | List | "(" Term[1200] ")"
|
|
;; while next token is infix op `op` with prec(op) ≤ Pmax:
|
|
;; consume op; parse rhs at right-prec(op); fold into compound(op-name,[lhs,rhs])
|
|
;;
|
|
;; Op type → right-prec for op at precedence P:
|
|
;; xfx → P-1 strict-both
|
|
;; xfy → P right-associative
|
|
;; yfx → P-1 left-associative
|
|
;;
|
|
;; AST shapes are unchanged — operators just become compound terms.
|
|
|
|
(define
|
|
pp-peek
|
|
(fn
|
|
(st)
|
|
(let
|
|
((i (get st :idx)) (tokens (get st :tokens)))
|
|
(if (< i (len tokens)) (nth tokens i) {:pos 0 :value nil :type "eof"}))))
|
|
|
|
(define pp-advance! (fn (st) (dict-set! st :idx (+ (get st :idx) 1))))
|
|
|
|
(define
|
|
pp-at?
|
|
(fn
|
|
(st type value)
|
|
(let
|
|
((t (pp-peek st)))
|
|
(and
|
|
(= (get t :type) type)
|
|
(or (= value nil) (= (get t :value) value))))))
|
|
|
|
(define
|
|
pp-expect!
|
|
(fn
|
|
(st type value)
|
|
(let
|
|
((t (pp-peek st)))
|
|
(if
|
|
(pp-at? st type value)
|
|
(do (pp-advance! st) t)
|
|
(error
|
|
(str
|
|
"Parse error at pos "
|
|
(get t :pos)
|
|
": expected "
|
|
type
|
|
" '"
|
|
(if (= value nil) "" value)
|
|
"' got "
|
|
(get t :type)
|
|
" '"
|
|
(if (= (get t :value) nil) "" (get t :value))
|
|
"'"))))))
|
|
|
|
(define pl-mk-atom (fn (name) (list "atom" name)))
|
|
(define pl-mk-var (fn (name) (list "var" name)))
|
|
(define pl-mk-num (fn (n) (list "num" n)))
|
|
(define pl-mk-str (fn (s) (list "str" s)))
|
|
(define pl-mk-compound (fn (f args) (list "compound" f args)))
|
|
(define pl-mk-cut (fn () (list "cut")))
|
|
|
|
(define pl-term-tag (fn (t) (if (list? t) (first t) nil)))
|
|
(define pl-term-val (fn (t) (nth t 1)))
|
|
(define pl-compound-functor (fn (t) (nth t 1)))
|
|
(define pl-compound-args (fn (t) (nth t 2)))
|
|
|
|
(define pl-nil-term (fn () (pl-mk-atom "[]")))
|
|
(define pl-mk-cons (fn (h t) (pl-mk-compound "." (list h t))))
|
|
|
|
(define
|
|
pl-mk-list-term
|
|
(fn
|
|
(items tail)
|
|
(if
|
|
(= (len items) 0)
|
|
tail
|
|
(pl-mk-cons (first items) (pl-mk-list-term (rest items) tail)))))
|
|
|
|
;; ── Operator table (Phase 4) ──────────────────────────────────────
|
|
;; Each entry: (name precedence type). Type ∈ "xfx" "xfy" "yfx".
|
|
(define
|
|
pl-op-table
|
|
(list
|
|
(list "," 1000 "xfy")
|
|
(list ";" 1100 "xfy")
|
|
(list "->" 1050 "xfy")
|
|
(list "=" 700 "xfx")
|
|
(list "\\=" 700 "xfx")
|
|
(list "is" 700 "xfx")
|
|
(list "<" 700 "xfx")
|
|
(list ">" 700 "xfx")
|
|
(list "=<" 700 "xfx")
|
|
(list ">=" 700 "xfx")
|
|
(list "+" 500 "yfx")
|
|
(list "-" 500 "yfx")
|
|
(list "*" 400 "yfx")
|
|
(list "/" 400 "yfx")
|
|
(list "mod" 400 "yfx")))
|
|
|
|
(define
|
|
pl-op-find
|
|
(fn
|
|
(name table)
|
|
(cond
|
|
((empty? table) nil)
|
|
((= (first (first table)) name) (rest (first table)))
|
|
(true (pl-op-find name (rest table))))))
|
|
|
|
(define pl-op-lookup (fn (name) (pl-op-find name pl-op-table)))
|
|
|
|
;; Token → (name prec type) for known infix ops, else nil.
|
|
(define
|
|
pl-token-op
|
|
(fn
|
|
(t)
|
|
(let
|
|
((ty (get t :type)) (vv (get t :value)))
|
|
(cond
|
|
((and (= ty "punct") (= vv ","))
|
|
(let
|
|
((info (pl-op-lookup ",")))
|
|
(if (nil? info) nil (cons "," info))))
|
|
((= ty "atom")
|
|
(let
|
|
((info (pl-op-lookup vv)))
|
|
(if (nil? info) nil (cons vv info))))
|
|
(true nil)))))
|
|
|
|
;; ── Term parser ─────────────────────────────────────────────────────
|
|
;; Primary term: atom, var, num, str, compound (atom + paren), list, cut, parens.
|
|
(define
|
|
pp-parse-primary
|
|
(fn
|
|
(st)
|
|
(let
|
|
((t (pp-peek st)))
|
|
(let
|
|
((ty (get t :type)) (vv (get t :value)))
|
|
(cond
|
|
((= ty "number") (do (pp-advance! st) (pl-mk-num vv)))
|
|
((= ty "string") (do (pp-advance! st) (pl-mk-str vv)))
|
|
((= ty "var") (do (pp-advance! st) (pl-mk-var vv)))
|
|
((and (= ty "op") (= vv "!"))
|
|
(do (pp-advance! st) (pl-mk-cut)))
|
|
((and (= ty "punct") (= vv "[")) (pp-parse-list st))
|
|
((and (= ty "punct") (= vv "("))
|
|
(do
|
|
(pp-advance! st)
|
|
(let
|
|
((inner (pp-parse-term-prec st 1200)))
|
|
(do (pp-expect! st "punct" ")") inner))))
|
|
((= ty "atom")
|
|
(do
|
|
(pp-advance! st)
|
|
(if
|
|
(pp-at? st "punct" "(")
|
|
(do
|
|
(pp-advance! st)
|
|
(let
|
|
((args (pp-parse-arg-list st)))
|
|
(do (pp-expect! st "punct" ")") (pl-mk-compound vv args))))
|
|
(pl-mk-atom vv))))
|
|
(else
|
|
(error
|
|
(str
|
|
"Parse error at pos "
|
|
(get t :pos)
|
|
": unexpected "
|
|
ty
|
|
" '"
|
|
(if (= vv nil) "" vv)
|
|
"'"))))))))
|
|
|
|
;; Operator-aware term parser: precedence climbing.
|
|
(define
|
|
pp-parse-term-prec
|
|
(fn
|
|
(st max-prec)
|
|
(let ((left (pp-parse-primary st))) (pp-parse-op-rhs st left max-prec))))
|
|
|
|
(define
|
|
pp-parse-op-rhs
|
|
(fn
|
|
(st left max-prec)
|
|
(let
|
|
((op-info (pl-token-op (pp-peek st))))
|
|
(cond
|
|
((nil? op-info) left)
|
|
(true
|
|
(let
|
|
((name (first op-info))
|
|
(prec (nth op-info 1))
|
|
(ty (nth op-info 2)))
|
|
(cond
|
|
((> prec max-prec) left)
|
|
(true
|
|
(let
|
|
((right-prec (if (= ty "xfy") prec (- prec 1))))
|
|
(do
|
|
(pp-advance! st)
|
|
(let
|
|
((right (pp-parse-term-prec st right-prec)))
|
|
(pp-parse-op-rhs
|
|
st
|
|
(pl-mk-compound name (list left right))
|
|
max-prec))))))))))))
|
|
|
|
;; Backwards-compat alias.
|
|
(define pp-parse-term (fn (st) (pp-parse-term-prec st 999)))
|
|
|
|
;; Args inside parens: parse at prec 999 so comma-as-operator (1000)
|
|
;; is not consumed; the explicit comma loop handles separation.
|
|
(define
|
|
pp-parse-arg-list
|
|
(fn
|
|
(st)
|
|
(let
|
|
((first-arg (pp-parse-term-prec st 999)) (args (list)))
|
|
(do
|
|
(append! args first-arg)
|
|
(define
|
|
loop
|
|
(fn
|
|
()
|
|
(when
|
|
(pp-at? st "punct" ",")
|
|
(do
|
|
(pp-advance! st)
|
|
(append! args (pp-parse-term-prec st 999))
|
|
(loop)))))
|
|
(loop)
|
|
args))))
|
|
|
|
;; List literal.
|
|
(define
|
|
pp-parse-list
|
|
(fn
|
|
(st)
|
|
(do
|
|
(pp-expect! st "punct" "[")
|
|
(if
|
|
(pp-at? st "punct" "]")
|
|
(do (pp-advance! st) (pl-nil-term))
|
|
(let
|
|
((items (list)))
|
|
(do
|
|
(append! items (pp-parse-term-prec st 999))
|
|
(define
|
|
comma-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(pp-at? st "punct" ",")
|
|
(do
|
|
(pp-advance! st)
|
|
(append! items (pp-parse-term-prec st 999))
|
|
(comma-loop)))))
|
|
(comma-loop)
|
|
(let
|
|
((tail (if (pp-at? st "punct" "|") (do (pp-advance! st) (pp-parse-term-prec st 999)) (pl-nil-term))))
|
|
(do (pp-expect! st "punct" "]") (pl-mk-list-term items tail)))))))))
|
|
|
|
;; ── Body parsing ────────────────────────────────────────────────────
|
|
;; A body is a single term parsed at prec 1200 — operator parser folds
|
|
;; `,`, `;`, `->` automatically into right-associative compounds.
|
|
(define pp-parse-body (fn (st) (pp-parse-term-prec st 1200)))
|
|
|
|
;; ── Clause parsing ──────────────────────────────────────────────────
|
|
(define
|
|
pp-parse-clause
|
|
(fn
|
|
(st)
|
|
(let
|
|
((head (pp-parse-term-prec st 999)))
|
|
(let
|
|
((body (if (pp-at? st "op" ":-") (do (pp-advance! st) (pp-parse-body st)) (pl-mk-atom "true"))))
|
|
(do (pp-expect! st "punct" ".") (list "clause" head body))))))
|
|
|
|
(define
|
|
pl-parse-program
|
|
(fn
|
|
(tokens)
|
|
(let
|
|
((st {:idx 0 :tokens tokens}) (clauses (list)))
|
|
(do
|
|
(define
|
|
ploop
|
|
(fn
|
|
()
|
|
(when
|
|
(not (pp-at? st "eof" nil))
|
|
(do (append! clauses (pp-parse-clause st)) (ploop)))))
|
|
(ploop)
|
|
clauses))))
|
|
|
|
(define
|
|
pl-parse-query
|
|
(fn (tokens) (let ((st {:idx 0 :tokens tokens})) (pp-parse-body st))))
|
|
|
|
(define pl-parse (fn (src) (pl-parse-program (pl-tokenize src))))
|
|
(define pl-parse-goal (fn (src) (pl-parse-query (pl-tokenize src))))
|