Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
(ns prim-wrap
(:require [clojure.math.combinatorics :as comb]))
(declare wrap-prim)
(defn instrument-var [vr]
(wrap-prim vr @vr))
(def prim-invoke-interfaces
(into #{}
(map (fn [ss] (apply str ss))
(apply concat
(for [n (range 1 6)]
(apply comb/cartesian-product (repeat n [\D \O \L])))))
(remove (fn [ss]
(every? #{\O} ss))))))
(defn char->tag [c]
{:pre [(char? c)]
:post [(symbol? %)]}
(case c
\L 'long
\D 'double
\O 'java.lang.Object))
(defn tag->char [t]
{:pre [((some-fn nil? symbol?) t)]
:post [(char? %)]}
(case t
long \L
double \D
(defn gen-prim-invokes [f-this prims]
;(prn "gen-prim-invokes" prims)
(fn [p]
{:pre [(string? p)]}
(let [args (into []
(fn [n c]
(-> (symbol (str "arg" n))
assoc :tag (char->tag c)))))
(butlast p))
interface (symbol (str "clojure.lang.IFn$" p))
rettag (char->tag (nth p (dec (count p))))
;_ (prn "rettag" rettag)
this (gensym 'this)
argvec (-> (vec (cons this args))
#_(vary-meta assoc :tag rettag))]
(binding [*print-meta* true]
(prn "argvec" argvec))
(list 'invokePrim argvec
`(~(f-this this) ~@(map #(with-meta % nil) args)))]))
(defn gen-nonvariadic-invokes [f-this]
(for [arity (range 0 20),
:let [args (repeatedly arity gensym)
this (gensym 'this)]]
`(~'invoke [~this ~@args]
(~(f-this this) ~@args))))
(defn gen-variadic-invoke [f-this]
(let [args (repeatedly 21 gensym)
this (gensym 'this)]
`(~'invoke [~this ~@args] (apply ~(f-this this) ~@args))))
(defn gen-apply-to [f-this]
(let [this (gensym 'this)]
`(~'applyTo [~this args#] (apply ~(f-this this) args#))))
(defn extend-IFn [f-this prims]
~@(gen-nonvariadic-invokes f-this)
~(gen-variadic-invoke f-this)
~(gen-apply-to f-this)
~@(gen-prim-invokes f-this prims)))
(defmacro deftypefn
"Like deftype, but accepts a function f before any specs that is
used to implement clojure.lang.IFn. f should accept at least one
argument, 'this'."
[name prims & opts+specs]
(let [field 'f
f-this (fn [this]
(list '. this (symbol (str "-" field))))
source `(deftype ~name [~field]
~@(extend-IFn f-this prims)
(binding [*print-meta* true]
(pprint source))
(def this-ns *ns*)
(defn arglist-prim-string [args]
{:pre [(vector? args)]
:post [((some-fn nil? string?) %)]}
(let [s (apply str
(->> args
(map (comp :tag meta))
(map tag->char))
[(tag->char (-> args meta :tag))]))]
(when (prim-invoke-interfaces s)
(defn wrap-prim [vr f]
{:pre [(var? vr)]}
;(prn "wrap-prim" vr)
(let [prim-arglists
(->> (-> vr meta :arglists)
(map arglist-prim-string)
(filter string?)))]
(seq prim-arglists)
(let [type-name (symbol
(str "PrimFn"
(apply str
;_ (prn "type-name" type-name)
cls (or #_(ns-resolve this-ns type-name)
(binding [*ns* this-ns]
`(deftypefn ~type-name ~prim-arglists))))
_ (assert (class? cls))
ctor (ns-resolve this-ns
(str "->" type-name)))
_ (assert (var? ctor))]
(ctor f))
:else f)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment