Skip to content

Instantly share code, notes, and snippets.

@pervognsen
Created March 16, 2010 09:05
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save pervognsen/333781 to your computer and use it in GitHub Desktop.
Save pervognsen/333781 to your computer and use it in GitHub Desktop.
diff --git a/src/clj/clojure/core_deftype.clj b/src/clj/clojure/core_deftype.clj
index 0e72136..7d2e32e 100644
--- a/src/clj/clojure/core_deftype.clj
+++ b/src/clj/clojure/core_deftype.clj
@@ -110,7 +110,7 @@
(defn- emit-deftype*
"Do not use this directly - use deftype"
- [tagname name fields interfaces methods]
+ [tagname name superclass fields interfaces methods]
(let [tag (keyword (str *ns*) (str tagname))
classname (symbol (str *ns* "." name))
interfaces (vec interfaces)
@@ -197,13 +197,14 @@
[i m]))]
(let [[i m] (-> [interfaces methods] eqhash iobj ilookup imap idynamictype)]
`(deftype* ~tagname ~classname ~(conj hinted-fields '__meta '__extmap)
- :implements ~(vec i)
+ :implements ~(vec i)
+ :extends ~superclass
~@m)))))
(defmacro deftype
"Alpha - subject to change
- (deftype name [fields*] options* specs*)
+ (deftype name [fields*] [:extends superclass] options* specs*)
Currently there is only one option:
@@ -290,10 +291,11 @@
[interfaces methods opts] (parse-opts+specs opts+specs)
classname (symbol (str *ns* "." gname))
tag (keyword (str *ns*) (str name))
+ superclass (if-let [s (:extends opts)] (resolve s) Object)
hinted-fields fields
fields (vec (map #(with-meta % nil) fields))]
`(do
- ~(emit-deftype* name gname (vec hinted-fields) (vec interfaces) methods)
+ ~(emit-deftype* name gname superclass (vec hinted-fields) (vec interfaces) methods)
(defmethod print-method ~tag [o# w#]
((var print-deftype) ~(vec (map #(-> % str keyword) fields)) o# w#))
(defn ~name
diff --git a/src/jvm/clojure/lang/Compiler.java b/src/jvm/clojure/lang/Compiler.java
index b484534..da89d25 100644
--- a/src/jvm/clojure/lang/Compiler.java
+++ b/src/jvm/clojure/lang/Compiler.java
@@ -78,6 +78,7 @@ static final Keyword inlineKey = Keyword.intern(null, "inline");
static final Keyword inlineAritiesKey = Keyword.intern(null, "inline-arities");
static final Keyword volatileKey = Keyword.intern(null, "volatile");
+static final Keyword extendsKey = Keyword.intern(null, "extends");
static final Keyword implementsKey = Keyword.intern(null, "implements");
static final String COMPILE_STUB_PREFIX = "compile__stub";
@@ -5977,7 +5978,7 @@ static public class NewInstanceExpr extends ObjExpr{
static class DeftypeParser implements IParser{
public Expr parse(C context, Object frm) throws Exception{
ISeq rform = (ISeq) frm;
- //(deftype* tagname classname [fields] :implements [interfaces] :tag tagname methods*)
+ //(deftype* tagname classname [fields] :extends [superclass] :implements [interfaces] :tag tagname methods*)
rform = RT.next(rform);
String tagname = ((Symbol) rform.first()).toString();
rform = rform.next();
@@ -5991,8 +5992,8 @@ static public class NewInstanceExpr extends ObjExpr{
opts = opts.assoc(rform.first(), RT.second(rform));
rform = rform.next().next();
}
-
- return build((IPersistentVector)RT.get(opts,implementsKey,PersistentVector.EMPTY),fields,null,tagname, classname,
+ Class superclass = (Class) RT.get(opts, extendsKey, Object.class);
+ return build((IPersistentVector)RT.get(opts,implementsKey,PersistentVector.EMPTY),superclass,fields,null,tagname, classname,
(Symbol) RT.get(opts,RT.TAG_KEY),rform);
}
}
@@ -6016,11 +6017,11 @@ static public class NewInstanceExpr extends ObjExpr{
rform = RT.next(rform);
- return build(interfaces, null, null, classname, classname, null, rform);
+ return build(interfaces, Object.class, null, null, classname, classname, null, rform);
}
}
- static ObjExpr build(IPersistentVector interfaceSyms, IPersistentVector fieldSyms, Symbol thisSym,
+ static ObjExpr build(IPersistentVector interfaceSyms, Class superClass, IPersistentVector fieldSyms, Symbol thisSym,
String tagName, String className,
Symbol typeTag, ISeq methodForms) throws Exception{
NewInstanceExpr ret = new NewInstanceExpr(null);
@@ -6066,7 +6067,7 @@ static public class NewInstanceExpr extends ObjExpr{
throw new IllegalArgumentException("only interfaces are supported, had: " + c.getName());
interfaces = interfaces.cons(c);
}
- Class superClass = Object.class;
+ // Class superClass = Object.class;
Map[] mc = gatherMethods(superClass,RT.seq(interfaces));
Map overrideables = mc[0];
Map covariants = mc[1];
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment