1
0
mirror of https://github.com/janet-lang/janet synced 2024-06-16 02:09:56 +00:00

Tail recursive match implementation.

This implementation uses multiple passes on patterns
to remove the need for a sentinel value to check if there was a match.
This also re-uses extracted subpatterns for complicated patterns.
This commit is contained in:
Calvin Rose 2020-12-10 08:29:24 -06:00
parent d53007739e
commit 945cbcfad6
2 changed files with 147 additions and 92 deletions

View File

@ -2,6 +2,7 @@
All notable changes to this project will be documented in this file. All notable changes to this project will be documented in this file.
## Unreleased - ??? ## Unreleased - ???
- `match` macro implemtentation cahned to be tail recursive.
- Adds a :preload loader which allows one to manually put things into `module/cache`. - Adds a :preload loader which allows one to manually put things into `module/cache`.
- Add `buffer/push` function. - Add `buffer/push` function.
- Backtick delimited strings and buffers are now reindented based on the column of the - Backtick delimited strings and buffers are now reindented based on the column of the

View File

@ -1559,85 +1559,9 @@
### ###
### ###
(defmacro- with-idemp
`Return janet code body that has been prepended
with a binding of form to atom. If form is a non-idempotent
form (a function call, etc.), make sure the resulting
code will only evaluate once, even if body contains multiple
copies of binding. In body, use binding instead of form.`
[binding form & body]
(def $result (gensym))
(def $form (gensym))
~(do
(def ,$form ,form)
(def ,binding (if (idempotent? ,$form) ,$form (gensym)))
(def ,$result (do ,;body))
(if (= ,$form ,binding)
,$result
(tuple 'do (tuple 'def ,binding ,$form) ,$result))))
# Sentinel value for mismatches
(def- sentinel ~',(gensym))
(defn- match-1
[pattern expr onmatch seen]
(cond
(= '_ pattern)
(onmatch)
(symbol? pattern)
(if (in seen pattern)
~(if (= ,pattern ,expr) ,(onmatch) ,sentinel)
(do
(put seen pattern true)
~(do (def ,pattern ,expr) ,(onmatch))))
(and (tuple? pattern) (= :parens (tuple/type pattern)))
(if (= (get pattern 0) '@)
# Unification with external values
~(if (= ,(get pattern 1) ,expr) ,(onmatch) ,sentinel)
(match-1
(in pattern 0) expr
(fn []
~(if (and ,;(tuple/slice pattern 1)) ,(onmatch) ,sentinel)) seen))
(indexed? pattern)
(do
(def len (length pattern))
(var i -1)
(with-idemp
$arr expr
~(if (,indexed? ,$arr)
(if (< (,length ,$arr) ,len)
,sentinel
,((fn aux []
(++ i)
(if (= i len)
(onmatch)
(match-1 (in pattern i) (tuple in $arr i) aux seen)))))
,sentinel)))
(dictionary? pattern)
(do
(var key nil)
(with-idemp
$dict expr
~(if (,dictionary? ,$dict)
,((fn aux []
(set key (next pattern key))
(def $val (gensym))
(if (= key nil)
(onmatch)
~(do (def ,$val (,get ,$dict ,key))
,(match-1 [(in pattern key) [not= nil $val]] $val aux seen)))))
,sentinel)))
:else ~(if (= ,pattern ,expr) ,(onmatch) ,sentinel)))
(defmacro match (defmacro match
`Pattern matching. Match an expression x against ```
Pattern matching. Match an expression x against
any number of cases. Each case is a pattern to match against, followed any number of cases. Each case is a pattern to match against, followed
by an expression to evaluate to if that case is matched. A pattern that is by an expression to evaluate to if that case is matched. A pattern that is
a symbol will match anything, binding x's value to that symbol. An array a symbol will match anything, binding x's value to that symbol. An array
@ -1646,22 +1570,152 @@
values in x. A tuple pattern will match if it's first element matches, and the following values in x. A tuple pattern will match if it's first element matches, and the following
elements are treated as predicates and are true. The last special case is elements are treated as predicates and are true. The last special case is
the '_ symbol, which is a wildcard that will match any value without creating a binding. the '_ symbol, which is a wildcard that will match any value without creating a binding.
Any other value pattern will only match if it is equal to x.` Any other value pattern will only match if it is equal to x.
```
[x & cases] [x & cases]
(with-idemp $x x
(def len (length cases))
(def len-1 (dec len))
((fn aux [i]
(cond
(= i len-1) (in cases i)
(< i len-1) (with-syms [$res]
~(if (= ,sentinel (def ,$res ,(match-1 (in cases i) $x (fn [] (in cases (inc i))) @{})))
,(aux (+ 2 i))
,$res)))) 0)))
(undef sentinel) # Partition body into sections.
(undef match-1) (def oddlen (odd? (length cases)))
(undef with-idemp) (def else (if oddlen (last cases)))
(def patterns (partition 2 (if oddlen (slice cases 0 -2) cases)))
# Keep an array for accumulating the compilation output
(def x-sym (if (idempotent? x) x (gensym)))
(def accum @[])
(if (not= x x-sym) (array/push accum ['def x-sym x]))
# Table of gensyms
(def symbols @{[nil nil] x-sym})
(def length-symbols @{})
(defn emit [x] (array/push accum x))
(defn emit-branch [condition result] (array/push accum :branch condition result))
(defn get-sym
[parent-sym key]
(def symbol-key [parent-sym key])
(or (get symbols symbol-key)
(let [s (gensym)]
(put symbols symbol-key s)
(emit ['def s [get parent-sym key]])
s)))
(defn get-length-sym
[parent-sym]
(or (get length-symbols parent-sym)
(let [s (gensym)]
(put length-symbols parent-sym s)
(emit ['def s ['if [indexed? parent-sym] [length parent-sym]]])
s)))
(defn visit-pattern-1
[b2g parent-sym key pattern]
(if (= pattern '_) (break))
(def s (get-sym parent-sym key))
(def t (type pattern))
(def isarr (or (= t :array) (and (= t :tuple) (= (tuple/type pattern) :brackets))))
(cond
# match local binding
(= t :symbol)
(if-let [x (in b2g pattern)]
(array/push x s)
(put b2g pattern @[s]))
# match data structure template
(or isarr (= t :struct) (= t :table))
(do
(when isarr (get-length-sym s))
(eachp [i sub-pattern] pattern
(visit-pattern-1 b2g s i sub-pattern)))
# match global unification
(and (= t :tuple) (= 2 (length pattern)) (= '@ (pattern 0)))
(break)
# match predicated binding
(and (= t :tuple) (>= (length pattern) 2))
(do
(visit-pattern-1 b2g parent-sym key (pattern 0)))))
(defn visit-pattern-2
[anda gun preds parent-sym key pattern]
(if (= pattern '_) (break))
(def s (get-sym parent-sym key))
(def t (type pattern))
(def isarr (or (= t :array) (and (= t :tuple) (= (tuple/type pattern) :brackets))))
(when isarr
(array/push anda (get-length-sym s))
(array/push anda [<= (length pattern) (get-length-sym s)]))
(cond
# match data structure template
(or isarr (= t :struct) (= t :table))
(eachp [i sub-pattern] pattern
(when (not= t :array)
(array/push anda [not= nil (get-sym s i)]))
(visit-pattern-2 anda gun preds s i sub-pattern))
# match local binding
(= t :symbol) (break)
# match global unification
(and (= t :tuple) (= 2 (length pattern)) (= '@ (pattern 0)))
(if-let [x (in gun (pattern 1))]
(array/push x s)
(put gun (pattern 1) @[s]))
# match predicated binding
(and (= t :tuple) (>= (length pattern) 2))
(do
(array/push preds ;(slice pattern 1))
(visit-pattern-2 anda gun preds parent-sym key (pattern 0)))
# match literal
(array/push anda ['= s pattern])))
# Compile the patterns
(each [pattern expression] patterns
(def b2g @{})
(def gun @{})
(def preds @[])
(visit-pattern-1 b2g nil nil pattern)
(def anda @['and])
(visit-pattern-2 anda gun preds nil nil pattern)
# Local unification
(def unify @[])
(each syms b2g
(when (< 1 (length syms))
(array/push unify [= ;syms])))
# Global unification
(eachp [binding syms] gun
(array/push unify [= binding ;syms]))
(sort unify)
(array/concat anda unify)
# Final binding
(def defs (seq [[k v] :in (sort (pairs b2g))] ['def k (first v)]))
# Predicates
(unless (empty? preds)
(def pred-join ~(do ,;defs (and ,;preds)))
(array/push anda pred-join))
(emit-branch (tuple/slice anda) ['do ;defs expression]))
# Expand branches
(def stack @[else])
(each el (reverse accum)
(if (= :branch el)
(let [condition (array/pop stack)
truthy (array/pop stack)
if-form ~(if ,condition ,truthy
,(case (length stack)
0 nil
1 (stack 0)
~(do ,;(reverse stack))))]
(array/remove stack 0 (length stack))
(array/push stack if-form))
(array/push stack el)))
~(do ,;(reverse stack)))
### ###
### ###