99 lines
2.7 KiB
Clojure
99 lines
2.7 KiB
Clojure
(ns expand
|
|
(:require [clojure.core.match :refer [match]]
|
|
[clojure.pprint]
|
|
[clojure.set :as set]
|
|
[clojure.spec.alpha :as s]
|
|
[clojure.walk]
|
|
[spec-dict.main :refer [dict]]
|
|
[scm]))
|
|
|
|
(s/def ::scope symbol?)
|
|
|
|
(s/def ::binding
|
|
#(match %
|
|
[:lexical sym uniq] (and (symbol? sym) (symbol? uniq))
|
|
[:global sym] (symbol? sym)))
|
|
|
|
(s/def ::context (s/coll-of ::scope :kind set?))
|
|
|
|
;; this is an inefficient representation. since we often want to
|
|
;; compute the submap of entries with a symbol 'x' but any scope, it
|
|
;; would be best to 'curry' the map, as Symbol → Scopes →
|
|
;; Binding. however, this is a bit more error-prone and cumbersome for
|
|
;; a prototype.
|
|
(s/def ::store
|
|
(s/map-of (s/tuple symbol? (s/coll-of ::scope :kind set?))
|
|
::binding))
|
|
|
|
(def primitives
|
|
"A set of symbols to be defined as primitive syntax exposed by
|
|
(scheme base)."
|
|
'#{let let-syntax letrec lambda syntax-rules if define
|
|
define-syntax begin})
|
|
|
|
(def builtins
|
|
"A set of symbols to be defined as variables exposed by (scheme
|
|
base)."
|
|
'#{+ * / - car cdr write display newline cons list})
|
|
|
|
(s/def ::denotation
|
|
#(match %
|
|
[:var] true
|
|
[:primitive p] (primitives p)
|
|
;; 나쁜
|
|
[:macro trans] (contains? trans :rules)
|
|
[:syntax datum] true))
|
|
|
|
(s/def ::environment
|
|
(s/map-of ::binding ::denotation))
|
|
|
|
(s/def ::syntax scm/syntax?)
|
|
|
|
(s/def ::identifier
|
|
(s/and ::syntax
|
|
#(symbol? (scm/syntax-e %))))
|
|
|
|
(s/fdef expand
|
|
:args (s/cat :stx ::syntax
|
|
:env ::environment
|
|
:store ::store)
|
|
:ret ::syntax)
|
|
|
|
(s/fdef lookup
|
|
:args (s/cat :ident ::identifier
|
|
:env ::environment
|
|
:store ::store))
|
|
|
|
|
|
|
|
(defn- store-scopes
|
|
"Gather the set of scope-sets associated with a given symbol."
|
|
[store sym]
|
|
(into #{} (for [[[x scopes] _] store
|
|
:when (= sym x)]
|
|
scopes)))
|
|
|
|
(defn nearest [ctx ss]
|
|
(when-some [xs (->> ss
|
|
(filter #(set/subset? % ctx))
|
|
(group-by count)
|
|
seq)]
|
|
(second (apply max-key first xs))))
|
|
|
|
(defn lookup [ident env store]
|
|
(let [sym (scm/syntax-e ident)
|
|
scopes (scm/syntax-context ident)
|
|
ss (store-scopes store sym)]
|
|
(let [xs (nearest scopes ss)
|
|
r (compare (count xs) 1)]
|
|
(cond (neg? r) (throw (ex-info "undefined sym" {:sym sym}))
|
|
(zero? r)
|
|
(or (get env (or (get store [sym (first xs)])
|
|
(throw (ex-info "unreachable" {}))))
|
|
(throw (ex-info "unreachable" {})))
|
|
(pos? r) (throw (ex-info "ambiguous sym" {:sym sym}))))))
|
|
|
|
(defn expand [stx env store-atom]
|
|
(match (scm/syntax-e stx)
|
|
(x :guard scm/constant?) x))
|