(fn match [val ...]
  ;; this function takes the AST of values and a single pattern and returns a
  ;; condition to determine if it matches as well as a list of bindings to
  ;; introduce for the duration of the body if it does match.
  (fn match-pattern [vals pattern unifications]
    ;; we have to assume we're matching against multiple values here until we
    ;; know we're either in a multi-valued clause (in which case we know the #
    ;; of vals) or we're not, in which case we only care about the first one.
    (let [[val] vals]
      (if (and (sym? pattern) ; unification with outer locals (or nil)
               (or (in-scope? pattern)
                   (= :nil (tostring pattern))))
          (values `(= @val @pattern) [])

          ;; unify a local we've seen already
          (and (sym? pattern)
               (. unifications (tostring pattern)))
          (values `(= @(. unifications (tostring pattern)) @val) [])

          ;; bind a fresh local
          (sym? pattern)
          (do (if (~= (tostring pattern) "_")
                  (tset unifications (tostring pattern) val))
              (values (if (: (tostring pattern) :find "^?")
                          true `(~= @(sym :nil) @val))
                      [pattern val]))

          ;; multi-valued patterns (represented as lists)
          (list? pattern)
          (let [condition `(and)
                bindings []]
            (each [i pat (ipairs pattern)]
              (let [(subcondition subbindings) (match-pattern [(. vals i)] pat
                                                              unifications)]
                (table.insert condition subcondition)
                (each [_ b (ipairs subbindings)]
                  (table.insert bindings b))))
            (values condition bindings))

          ;; table patterns)
          (= (type pattern) :table)
          (let [condition `(and (= (type @val) :table))
                bindings []]
            (each [k pat (pairs pattern)]
              (if (and (sym? pat) (= "&" (tostring pat)))
                  (do (assert (not (. pattern (+ k 2)))
                              "expected rest argument in final position")
                      (table.insert bindings (. pattern (+ k 1)))
                      (table.insert bindings [`(select @k (unpack @val))]))
                  (and (= :number (type k))
                       (= "&" (tostring (. pattern (- k 1)))))
                  nil ; don't process the pattern right after &; already got it
                  (let [subval `(. @val @k)
                        (subcondition subbindings) (match-pattern [subval] pat
                                                                  unifications)]
                    (table.insert condition subcondition)
                    (each [_ b (ipairs subbindings)]
                      (table.insert bindings b)))))
            (values condition bindings))

          ;; literal value
          (values `(= @val @pattern) []))))

  (fn match-condition [vals clauses]
    (let [out `(if)]
      (for [i 1 (# clauses) 2]
        (let [pattern (. clauses i)
              body (. clauses (+ i 1))
              (condition bindings) (match-pattern vals pattern {})]
          (table.insert out condition)
          (table.insert out `(let @bindings @body))))
      out))

  ;; how many multi-valued clauses are there? return a list of that many gensyms
  (fn val-syms [clauses]
    (let [syms (list (gensym))]
      (for [i 1 (# clauses) 2]
        (if (list? (. clauses i))
            (each [valnum (ipairs (. clauses i))]
              (if (not (. syms valnum))
                  (tset syms valnum (gensym))))))
      syms))

  ;; wrap it in a way that prevents double-evaluation of the matched value
  (let [clauses [...]
        vals (val-syms clauses)]
    (if (~= 0 (% (# clauses) 2)) ; treat odd final clause as default
        (table.insert clauses (# clauses) (sym :_)))
    ;; protect against multiple evaluation of the value, bind against as
    ;; many values as we ever match against in the clauses.
    (list (sym :let) [vals val]
          (match-condition vals clauses))))

Generated by Phil Hagelberg using scpaste at Fri Aug 6 11:29:56 2021. PDT. (original)