From 16c9435160426849d0694e9cfddf08f34c5a3f34 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sat, 12 Apr 2014 16:44:49 -0400 Subject: [PATCH 01/80] Make line endings in Ref.cs Unix line endings --- Clojure/Clojure/Lib/Ref.cs | 244 ++++++++++++++++++------------------- 1 file changed, 122 insertions(+), 122 deletions(-) diff --git a/Clojure/Clojure/Lib/Ref.cs b/Clojure/Clojure/Lib/Ref.cs index 5e9d803bd..fc6aff95e 100644 --- a/Clojure/Clojure/Lib/Ref.cs +++ b/Clojure/Clojure/Lib/Ref.cs @@ -96,7 +96,7 @@ public TVal Next /// /// Construct a TVal, linked to a previous TVal. - /// + /// public TVal(object val, long point, TVal prior) { _val = val; @@ -109,7 +109,7 @@ public TVal(object val, long point, TVal prior) /// /// Construct a TVal, linked to itself. - /// + /// public TVal(object val, long point) { _val = val; @@ -126,7 +126,7 @@ public TVal(object val, long point) /// Set the value/point. /// /// - /// + /// public void SetValue(object val, long point) { _val = val; @@ -141,19 +141,19 @@ public void SetValue(object val, long point) #region Data /// - /// Values at points in time for this reference. + /// Values at points in time for this reference. /// TVal _tvals; /// - /// Values at points in time for this reference. - /// - internal TVal TVals - { - get { return _tvals; } - } - - /// + /// Values at points in time for this reference. + /// + internal TVal TVals + { + get { return _tvals; } + } + + /// /// Number of faults for the reference. /// readonly AtomicInteger _faults; @@ -196,8 +196,8 @@ public int MinHistory { get { return _minHistory; } set { _minHistory = value; } - } - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "set")] + } + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "set")] public Ref setMinHistory(int minHistory) { _minHistory = minHistory; @@ -210,8 +210,8 @@ public int MaxHistory { get { return _maxHistory; } set { _maxHistory = value; } - } - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "set")] + } + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "set")] public Ref setMaxHistory(int maxHistory) { _maxHistory = maxHistory; @@ -222,8 +222,8 @@ public Ref setMaxHistory(int maxHistory) /// /// Used to generate unique ids. /// - static readonly AtomicLong _ids = new AtomicLong(); - + static readonly AtomicLong _ids = new AtomicLong(); + bool _disposed = false; #endregion @@ -291,9 +291,9 @@ public Ref(object initval, IPersistentMap meta) #endregion - #region History counts - - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "get")] + #region History counts + + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "get")] public int getHistoryCount() { try @@ -337,7 +337,7 @@ public override object deref() //Console.WriteLine("Thr {0}, {1}: No-trans get => {2}", Thread.CurrentThread.ManagedThreadId,DebugStr(), ret); return ret; } - return t.DoGet(this); + return t.DoGet(this); } object currentVal() @@ -457,8 +457,8 @@ internal void SetValue(object val, long commitPoint) /// Set the value (must be in a transaction). /// /// The new value. - /// The new value. - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "set")] + /// The new value. + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "set")] public object set(object val) { return LockingTransaction.GetEx().DoSet(this, val); @@ -469,8 +469,8 @@ public object set(object val) /// /// The function to apply to the current state and additional arguments. /// Additional arguments. - /// The computed value. - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "commute")] + /// The computed value. + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "commute")] public object commute(IFn fn, ISeq args) { return LockingTransaction.GetEx().DoCommute(this, fn, args); @@ -481,18 +481,18 @@ public object commute(IFn fn, ISeq args) /// /// The function to apply to the current state and additional arguments. /// Additional arguments. - /// The computed value. - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "alter")] + /// The computed value. + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "alter")] public object alter(IFn fn, ISeq args) { LockingTransaction t = LockingTransaction.GetEx(); - return t.DoSet(this, fn.applyTo(RT.cons(t.DoGet(this), args))); + return t.DoSet(this, fn.applyTo(RT.cons(t.DoGet(this), args))); } /// /// Touch the reference. (Add to the tracking list in the current transaction.) - /// - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "touch")] + /// + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "touch")] public void touch() { LockingTransaction.GetEx().DoEnsure(this); @@ -500,10 +500,10 @@ public void touch() #endregion - #region IFn Members - - - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "fn")] + #region IFn Members + + + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "fn")] public IFn fn() { return (IFn)deref(); @@ -666,92 +666,92 @@ public int CompareTo(Ref other) return _id.CompareTo(other._id); } - #endregion - - #region object overrides - - public override bool Equals(object obj) - { - if (ReferenceEquals(this, obj)) - return true; - - Ref r = obj as Ref; - if (r == null) - return false; - - return _id == r._id; - } - - public override int GetHashCode() - { - return _id.GetHashCode(); - } - #endregion - - #region operator overrides - - public static bool operator ==(Ref x, Ref y) - { - if (ReferenceEquals(x, y)) - return true; - - if ((object)x == null) - return false; - - return x.CompareTo(y) == 0; - } - - public static bool operator !=(Ref x, Ref y) - { - return !(x == y); - } - - public static bool operator <(Ref x, Ref y) - { - if (ReferenceEquals(x, y)) - return false; - - if ( ReferenceEquals(x,null) ) - throw new ArgumentException("Cannot compare null","x"); - - return x.CompareTo(y) < 0; - } - - public static bool operator >(Ref x, Ref y) - { - if (ReferenceEquals(x, y)) - return false; - - if ( ReferenceEquals(x,null) ) - throw new ArgumentException("Cannot compare null","x"); - - return x.CompareTo(y) > 0; - } - - #endregion - - #region IDisposable - - public void Dispose() - { - Dispose(true); - GC.SuppressFinalize(this); - } - - private void Dispose(bool disposing) - { - if (!_disposed) - { - if (disposing) - { - if ( _lock != null ) - _lock.Dispose(); - } - - _disposed = true; - } - } - - #endregion + #endregion + + #region object overrides + + public override bool Equals(object obj) + { + if (ReferenceEquals(this, obj)) + return true; + + Ref r = obj as Ref; + if (r == null) + return false; + + return _id == r._id; + } + + public override int GetHashCode() + { + return _id.GetHashCode(); + } + #endregion + + #region operator overrides + + public static bool operator ==(Ref x, Ref y) + { + if (ReferenceEquals(x, y)) + return true; + + if ((object)x == null) + return false; + + return x.CompareTo(y) == 0; + } + + public static bool operator !=(Ref x, Ref y) + { + return !(x == y); + } + + public static bool operator <(Ref x, Ref y) + { + if (ReferenceEquals(x, y)) + return false; + + if ( ReferenceEquals(x,null) ) + throw new ArgumentException("Cannot compare null","x"); + + return x.CompareTo(y) < 0; + } + + public static bool operator >(Ref x, Ref y) + { + if (ReferenceEquals(x, y)) + return false; + + if ( ReferenceEquals(x,null) ) + throw new ArgumentException("Cannot compare null","x"); + + return x.CompareTo(y) > 0; + } + + #endregion + + #region IDisposable + + public void Dispose() + { + Dispose(true); + GC.SuppressFinalize(this); + } + + private void Dispose(bool disposing) + { + if (!_disposed) + { + if (disposing) + { + if ( _lock != null ) + _lock.Dispose(); + } + + _disposed = true; + } + } + + #endregion } } From 1353ef8e241ad566f864ff5042f7e39488911024 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 13 Apr 2014 17:11:58 -0400 Subject: [PATCH 02/80] Patch RT.cs to use System.Environment.CurrentDirectory Unity sets System.AppDomain.CurrentDomain.BaseDirectory to null which causes all kinds of problems. --- Clojure/Clojure/Lib/RT.cs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Clojure/Clojure/Lib/RT.cs b/Clojure/Clojure/Lib/RT.cs index e63fc4d6c..0692fc03e 100644 --- a/Clojure/Clojure/Lib/RT.cs +++ b/Clojure/Clojure/Lib/RT.cs @@ -3407,8 +3407,8 @@ static IEnumerable GetFindFilePaths() static IEnumerable GetFindFilePathsRaw() { - yield return System.AppDomain.CurrentDomain.BaseDirectory; - yield return Path.Combine(System.AppDomain.CurrentDomain.BaseDirectory, "bin"); + yield return System.Environment.CurrentDirectory; + yield return Path.Combine(System.Environment.CurrentDirectory, "bin"); yield return Directory.GetCurrentDirectory(); yield return Path.GetDirectoryName(typeof(RT).Assembly.Location); From 73b1a14606097f88689fdd53334ef3f8d16a087e Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 13 Apr 2014 17:13:05 -0400 Subject: [PATCH 03/80] Comment out any mention of ReaderWriterLockSlim Raises NotImplemented exceptions in Unity otherwise. Refs and MultiFns are broken as a result. --- Clojure/Clojure/Lib/MultiFn.cs | 34 +++++++++++++++++----------------- Clojure/Clojure/Lib/Ref.cs | 22 +++++++++++----------- 2 files changed, 28 insertions(+), 28 deletions(-) diff --git a/Clojure/Clojure/Lib/MultiFn.cs b/Clojure/Clojure/Lib/MultiFn.cs index 0b4504166..c43208687 100644 --- a/Clojure/Clojure/Lib/MultiFn.cs +++ b/Clojure/Clojure/Lib/MultiFn.cs @@ -82,7 +82,7 @@ public IPersistentMap PreferTable /// volatile object _cachedHierarchy; - ReaderWriterLockSlim _rw; + // ReaderWriterLockSlim _rw; bool _disposed = false; //static readonly Var _assoc = RT.var("clojure.core", "assoc"); @@ -112,7 +112,7 @@ public MultiFn(string name, IFn dispatchFn, object defaultDispatchVal, IRef hier _preferTable = PersistentHashMap.EMPTY; _hierarchy = hierarchy; _cachedHierarchy = null; - _rw = new ReaderWriterLockSlim(LockRecursionPolicy.SupportsRecursion); + // _rw = new ReaderWriterLockSlim(LockRecursionPolicy.SupportsRecursion); } #endregion @@ -128,7 +128,7 @@ public MultiFn(string name, IFn dispatchFn, object defaultDispatchVal, IRef hier [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "add")] public MultiFn addMethod(object dispatchVal, IFn method) { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { _methodTable = MethodTable.assoc(dispatchVal, method); @@ -137,7 +137,7 @@ public MultiFn addMethod(object dispatchVal, IFn method) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -150,7 +150,7 @@ public MultiFn addMethod(object dispatchVal, IFn method) [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "remove")] public MultiFn removeMethod(object dispatchVal) { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { _methodTable = MethodTable.without(dispatchVal); @@ -159,7 +159,7 @@ public MultiFn removeMethod(object dispatchVal) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -172,7 +172,7 @@ public MultiFn removeMethod(object dispatchVal) [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "prefer")] public MultiFn preferMethod(object dispatchValX, object dispatchValY) { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { if (Prefers(dispatchValY, dispatchValX)) @@ -185,7 +185,7 @@ public MultiFn preferMethod(object dispatchValX, object dispatchValY) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -242,7 +242,7 @@ private bool Dominates(object x, object y) /// private IPersistentMap ResetCache() { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { _methodCache = MethodTable; @@ -251,7 +251,7 @@ private IPersistentMap ResetCache() } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -294,7 +294,7 @@ private IFn GetFn(object dispatchVal) /// The mest method. private IFn FindAndCacheBestMethod(object dispatchVal) { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); IMapEntry bestEntry; IPersistentMap mt = _methodTable; IPersistentMap pt = _preferTable; @@ -319,11 +319,11 @@ private IFn FindAndCacheBestMethod(object dispatchVal) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } // ensure basis has stayed stable throughout, else redo - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { if (mt == _methodTable @@ -343,7 +343,7 @@ private IFn FindAndCacheBestMethod(object dispatchVal) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -375,7 +375,7 @@ public IPersistentMap getPreferTable() [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "reset")] public MultiFn reset() { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { _methodTable = _methodCache = _preferTable = PersistentHashMap.EMPTY; @@ -384,7 +384,7 @@ public MultiFn reset() } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -787,7 +787,7 @@ private void Dispose(bool disposing) { if (disposing) { - ((IDisposable)_rw).Dispose(); + // ((IDisposable)_rw).Dispose(); } _disposed = true; diff --git a/Clojure/Clojure/Lib/Ref.cs b/Clojure/Clojure/Lib/Ref.cs index fc6aff95e..cedfc2229 100644 --- a/Clojure/Clojure/Lib/Ref.cs +++ b/Clojure/Clojure/Lib/Ref.cs @@ -161,7 +161,7 @@ internal TVal TVals /// /// Reader/writer lock for the reference. /// - readonly ReaderWriterLockSlim _lock; + // readonly ReaderWriterLockSlim _lock; /// /// Info on the transaction locking this ref. @@ -250,7 +250,7 @@ public Ref(object initval, IPersistentMap meta) { _id = _ids.getAndIncrement(); _faults = new AtomicInteger(); - _lock = new ReaderWriterLockSlim(LockRecursionPolicy.NoRecursion); + // _lock = new ReaderWriterLockSlim(LockRecursionPolicy.NoRecursion); _tvals = new TVal(initval, 0); } @@ -344,14 +344,14 @@ object currentVal() { try { - _lock.EnterReadLock(); + // _lock.EnterReadLock(); if (_tvals != null) return _tvals.Val; throw new InvalidOperationException(String.Format("{0} is unbound.", ToString())); } finally { - _lock.ExitReadLock(); + // _lock.ExitReadLock(); } } @@ -364,7 +364,7 @@ object currentVal() /// internal void EnterReadLock() { - _lock.EnterReadLock(); + // _lock.EnterReadLock(); } /// @@ -372,7 +372,7 @@ internal void EnterReadLock() /// internal void ExitReadLock() { - _lock.ExitReadLock(); + // _lock.ExitReadLock(); } /// @@ -380,7 +380,7 @@ internal void ExitReadLock() /// internal void EnterWriteLock() { - _lock.EnterWriteLock(); + // _lock.EnterWriteLock(); } @@ -389,7 +389,7 @@ internal void EnterWriteLock() /// internal bool TryEnterWriteLock(int msecTimeout) { - return _lock.TryEnterWriteLock(msecTimeout); + return true; // _lock.TryEnterWriteLock(msecTimeout); } /// @@ -397,7 +397,7 @@ internal bool TryEnterWriteLock(int msecTimeout) /// internal void ExitWriteLock() { - _lock.ExitWriteLock(); + // _lock.ExitWriteLock(); } /// @@ -744,8 +744,8 @@ private void Dispose(bool disposing) { if (disposing) { - if ( _lock != null ) - _lock.Dispose(); + // if ( _lock != null ) + // _lock.Dispose(); } _disposed = true; From 87b20e524f884bd5a93908d06a3c1d07a4f83f63 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 13 Apr 2014 17:14:30 -0400 Subject: [PATCH 04/80] Add unity-build script to build Clojure using Unity's Mono distribution --- unity-build.sh | 1 + 1 file changed, 1 insertion(+) create mode 100755 unity-build.sh diff --git a/unity-build.sh b/unity-build.sh new file mode 100755 index 000000000..7d932b50a --- /dev/null +++ b/unity-build.sh @@ -0,0 +1 @@ +/Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/bin/mono /Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/lib/mono/2.0/xbuild.exe Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Debug 3.5" /p:Platform="Any CPU" \ No newline at end of file From 5e44e765c63a0c4e477bb9416b12af8d93d75554 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 13 Apr 2014 20:06:26 -0400 Subject: [PATCH 05/80] Add terminal flag to fix broken build --- unity-build.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unity-build.sh b/unity-build.sh index 7d932b50a..5b30c0e0f 100755 --- a/unity-build.sh +++ b/unity-build.sh @@ -1 +1 @@ -/Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/bin/mono /Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/lib/mono/2.0/xbuild.exe Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Debug 3.5" /p:Platform="Any CPU" \ No newline at end of file +EnableNuGetPackageRestore=true /Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/bin/mono /Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/lib/mono/2.0/xbuild.exe Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Debug 3.5" /p:Platform="Any CPU" \ No newline at end of file From 44f3fa74ea7fcd729a5d98b6a4e7d54bd4e5a5c8 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Mon, 14 Apr 2014 17:10:17 -0400 Subject: [PATCH 06/80] Update unity-build to use stock mono xbuild --- unity-build.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unity-build.sh b/unity-build.sh index 5b30c0e0f..fce3e43b4 100755 --- a/unity-build.sh +++ b/unity-build.sh @@ -1 +1 @@ -EnableNuGetPackageRestore=true /Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/bin/mono /Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/lib/mono/2.0/xbuild.exe Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Debug 3.5" /p:Platform="Any CPU" \ No newline at end of file +EnableNuGetPackageRestore=true xbuild Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Debug 3.5" /p:Platform="Any CPU" From 19b3a38f75225168311e579d9fb925ff7a78718b Mon Sep 17 00:00:00 2001 From: timsgardner Date: Sat, 26 Jul 2014 23:29:11 -0400 Subject: [PATCH 07/80] experimentally adding trivially renamed copy of NewInstanceExpr --- .gitignore | 1 + .../CljCompiler/Ast/OtherNewInstanceExpr.cs | 1014 +++++++++++++++++ 2 files changed, 1015 insertions(+) create mode 100644 Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs diff --git a/.gitignore b/.gitignore index cda0086ab..d88f79c97 100644 --- a/.gitignore +++ b/.gitignore @@ -172,3 +172,4 @@ lib/ # Mono *.userprefs +/dist/ diff --git a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs new file mode 100644 index 000000000..594d3ad6c --- /dev/null +++ b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs @@ -0,0 +1,1014 @@ +/** + * Copyright (c) Rich Hickey. All rights reserved. + * The use and distribution terms for this software are covered by the + * Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) + * which can be found in the file epl-v10.html at the root of this distribution. + * By using this software in any fashion, you are agreeing to be bound by + * the terms of this license. + * You must not remove this notice, or any other, from this software. + **/ + +/** + * Author: David Miller + **/ + +using System; +using System.Collections.Generic; +using System.Reflection; +using System.Reflection.Emit; +using System.Runtime.CompilerServices; +using Microsoft.Scripting.Generation; + +namespace clojure.lang.CljCompiler.Ast +{ + sealed class OtherNewInstanceExpr : ObjExpr + { + #region Data + + Dictionary> _methodMap; + + #endregion + + #region C-tors +/** + * Copyright (c) Rich Hickey. All rights reserved. + * The use and distribution terms for this software are covered by the + * Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) + * which can be found in the file epl-v10.html at the root of this distribution. + * By using this software in any fashion, you are agreeing to be bound by + * the terms of this license. + * You must not remove this notice, or any other, from this software. + **/ + +/** + * Author: David Miller + **/ + +using System; +using System.Collections.Generic; +using System.Reflection; +using System.Reflection.Emit; +using System.Runtime.CompilerServices; +using Microsoft.Scripting.Generation; + +namespace clojure.lang.CljCompiler.Ast +{ + sealed class OtherNewInstanceExpr : ObjExpr + { + #region Data + + Dictionary> _methodMap; + + #endregion + + #region C-tors + + public OtherNewInstanceExpr(object tag) + : base(tag) + { + } + + #endregion + + #region Parsing + + public sealed class DefTypeParser : IParser + { + public Expr Parse(ParserContext pcon, object frm) + { + // frm is: (deftype* tagname classname [fields] :implements [interfaces] :tag tagname methods*) + + ISeq rform = (ISeq)frm; + rform = RT.next(rform); + + string tagname = ((Symbol)rform.first()).ToString(); + rform = rform.next(); + Symbol classname = (Symbol)rform.first(); + rform = rform.next(); + IPersistentVector fields = (IPersistentVector)rform.first(); + rform = rform.next(); + IPersistentMap opts = PersistentHashMap.EMPTY; + while (rform != null && rform.first() is Keyword) + { + opts = opts.assoc(rform.first(), RT.second(rform)); + rform = rform.next().next(); + } + + ObjExpr ret = Build((IPersistentVector)RT.get(opts, Compiler.ImplementsKeyword, PersistentVector.EMPTY), fields, null, tagname, classname, + (Symbol)RT.get(opts, RT.TagKey), rform, frm); + + return ret; + } + } + + + public sealed class ReifyParser : IParser + { + public Expr Parse(ParserContext pcon, object frm) + { + // frm is: (reify this-name? [interfaces] (method-name [args] body)* ) + ISeq form = (ISeq)frm; + ObjMethod enclosingMethod = (ObjMethod)Compiler.MethodVar.deref(); + string baseName = enclosingMethod != null + ? (ObjExpr.TrimGenId(enclosingMethod.Objx.Name) + "$") + : (Compiler.munge(Compiler.CurrentNamespace.Name.Name) + "$"); + string simpleName = "reify__" + RT.nextID(); + string className = baseName + simpleName; + + ISeq rform = RT.next(form); + + IPersistentVector interfaces = ((IPersistentVector)RT.first(rform)).cons(Symbol.intern("clojure.lang.IObj")); + + rform = RT.next(rform); + + ObjExpr ret = Build(interfaces, null, null, className, Symbol.intern(className), null, rform,frm); + IObj iobj = frm as IObj; + + if (iobj != null && iobj.meta() != null) + return new MetaExpr(ret, MapExpr.Parse(pcon.EvalOrExpr(),iobj.meta())); + else + return ret; + } + } + + internal static ObjExpr Build( + IPersistentVector interfaceSyms, + IPersistentVector fieldSyms, + Symbol thisSym, + string tagName, + Symbol className, + Symbol typeTag, + ISeq methodForms, + Object frm) + { + OtherNewInstanceExpr ret = new OtherNewInstanceExpr(null); + ret._src = frm; + ret._name = className.ToString(); + ret._classMeta = GenInterface.ExtractAttributes(RT.meta(className)); + ret.InternalName = ret._name; // ret.Name.Replace('.', '/'); + // Java: ret.objtype = Type.getObjectType(ret.internalName); + + if (thisSym != null) + ret._thisName = thisSym.Name; + + if (fieldSyms != null) + { + IPersistentMap fmap = PersistentHashMap.EMPTY; + object[] closesvec = new object[2 * fieldSyms.count()]; + for (int i = 0; i < fieldSyms.count(); i++) + { + Symbol sym = (Symbol)fieldSyms.nth(i); + LocalBinding lb = new LocalBinding(-1, sym, null, new MethodParamExpr(Compiler.TagType(Compiler.TagOf(sym))), false, false, false); + fmap = fmap.assoc(sym, lb); + closesvec[i * 2] = lb; + closesvec[i * 2 + 1] = lb; + } + // Java TODO: inject __meta et al into closes - when? + // use array map to preserve ctor order + ret.Closes = new PersistentArrayMap(closesvec); + ret.Fields = fmap; + for (int i = fieldSyms.count() - 1; i >= 0 && (((Symbol)fieldSyms.nth(i)).Name.Equals("__meta") || ((Symbol)fieldSyms.nth(i)).Name.Equals("__extmap")); --i) + ret._altCtorDrops++; + } + + // Java TODO: set up volatiles + //ret._volatiles = PersistentHashSet.create(RT.seq(RT.get(ret._optionsMap, volatileKey))); + + IPersistentVector interfaces = PersistentVector.EMPTY; + for (ISeq s = RT.seq(interfaceSyms); s != null; s = s.next()) + { + Type t = (Type)Compiler.Resolve((Symbol)s.first()); + if (!t.IsInterface) + throw new ParseException("only interfaces are supported, had: " + t.Name); + interfaces = interfaces.cons(t); + } + Type superClass = typeof(Object); + + Dictionary> overrideables; + GatherMethods(superClass, RT.seq(interfaces), out overrideables); + + ret._methodMap = overrideables; + + + GenContext context = Compiler.IsCompiling + ? Compiler.CompilerContextVar.get() as GenContext + : (ret.IsDefType + ? GenContext.CreateWithExternalAssembly("deftype" + RT.nextID().ToString(), ".dll", true) + : (Compiler.CompilerContextVar.get() as GenContext + ?? + Compiler.EvalContext)); + + GenContext genC = context.WithNewDynInitHelper(ret.InternalName + "__dynInitHelper_" + RT.nextID().ToString()); + + Type stub = CompileStub(genC, superClass, ret, SeqToTypeArray(interfaces), frm); + Symbol thisTag = Symbol.intern(null, stub.FullName); + //Symbol stubTag = Symbol.intern(null,stub.FullName); + //Symbol thisTag = Symbol.intern(null, tagName); + + + try + { + Var.pushThreadBindings( + RT.mapUniqueKeys( + Compiler.ConstantsVar, PersistentVector.EMPTY, + Compiler.ConstantIdsVar, new IdentityHashMap(), + Compiler.KeywordsVar, PersistentHashMap.EMPTY, + Compiler.VarsVar, PersistentHashMap.EMPTY, + Compiler.KeywordCallsitesVar, PersistentVector.EMPTY, + Compiler.ProtocolCallsitesVar, PersistentVector.EMPTY, + Compiler.VarCallsitesVar, Compiler.EmptyVarCallSites(), + Compiler.NoRecurVar, null, + Compiler.CompilerContextVar, genC + )); + + if (ret.IsDefType) + { + Var.pushThreadBindings( + RT.mapUniqueKeys( + Compiler.MethodVar, null, + Compiler.LocalEnvVar, ret.Fields, + Compiler.CompileStubSymVar, Symbol.intern(null, tagName), + Compiler.CompileStubClassVar, stub + )); + ret._hintedFields = RT.subvec(fieldSyms, 0, fieldSyms.count() - ret._altCtorDrops); + } + // now (methodname [args] body)* + + ret.SpanMap = (IPersistentMap)Compiler.SourceSpanVar.deref(); + + IPersistentCollection methods = null; + for (ISeq s = methodForms; s != null; s = RT.next(s)) + { + NewInstanceMethod m = NewInstanceMethod.Parse(ret, (ISeq)RT.first(s), thisTag, overrideables); + methods = RT.conj(methods, m); + } + + ret._methods = methods; + ret.Keywords = (IPersistentMap)Compiler.KeywordsVar.deref(); + ret.Vars = (IPersistentMap)Compiler.VarsVar.deref(); + ret.Constants = (PersistentVector)Compiler.ConstantsVar.deref(); + ret._constantsID = RT.nextID(); + ret.KeywordCallsites = (IPersistentVector)Compiler.KeywordCallsitesVar.deref(); + ret.ProtocolCallsites = (IPersistentVector)Compiler.ProtocolCallsitesVar.deref(); + ret.VarCallsites = (IPersistentSet)Compiler.VarCallsitesVar.deref(); + } + finally + { + if (ret.IsDefType) + Var.popThreadBindings(); + Var.popThreadBindings(); + } + + // TOD: Really, the first stub here should be 'superclass' but can't handle hostexprs nested in method bodies -- reify method compilation takes place before this sucker is compiled, so can't replace the call. + // Might be able to flag stub classes and not try to convert, leading to a dynsite. + + //if (RT.CompileDLR) + ret.Compile(stub, stub, interfaces, false, genC); + //else + // ret.CompileNoDlr(stub, stub, interfaces, false, genC); + + Compiler.RegisterDuplicateType(ret.CompiledType); + + return ret; + } + + private static Type[] SeqToTypeArray(IPersistentVector interfaces) + { + Type[] types = new Type[interfaces.count()]; + for (int i = 0; i < interfaces.count(); i++) + types[i] = (Type)interfaces.nth(i); + + return types; + } + + /*** + * Current host interop uses reflection, which requires pre-existing classes + * Work around this by: + * Generate a stub class that has the same interfaces and fields as the class we are generating. + * Use it as a type hint for this, and bind the simple name of the class to this stub (in resolve etc) + * Unmunge the name (using a magic prefix) on any code gen for classes + */ + + // TODO: Preparse method heads to pick up signatures, implement those methods as abstract or as NotImpelmented so that Reflection can pick up calls during compilation and avoide a callsite. + static Type CompileStub(GenContext context, Type super, OtherNewInstanceExpr ret, Type[] interfaces, Object frm) + { + TypeBuilder tb = context.ModuleBuilder.DefineType(Compiler.CompileStubPrefix + "." + ret.InternalName + RT.nextID(), TypeAttributes.Public | TypeAttributes.Abstract, super, interfaces); + + tb.DefineDefaultConstructor(MethodAttributes.Public); + + // instance fields for closed-overs + for (ISeq s = RT.keys(ret.Closes); s != null; s = s.next()) + { + LocalBinding lb = (LocalBinding)s.first(); + FieldAttributes access = FieldAttributes.Public; + + if (!ret.IsMutable(lb)) + access |= FieldAttributes.InitOnly; + + Type fieldType = lb.PrimitiveType ?? typeof(Object); + + if (ret.IsVolatile(lb)) + tb.DefineField(lb.Name, fieldType, new Type[] { typeof(IsVolatile) }, Type.EmptyTypes, access); + else + tb.DefineField(lb.Name, fieldType, access); + } + + // ctor that takes closed-overs and does nothing + if (ret.CtorTypes().Length > 0) + { + ConstructorBuilder cb = tb.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, ret.CtorTypes()); + CljILGen ilg = new CljILGen(cb.GetILGenerator()); + ilg.EmitLoadArg(0); + ilg.Emit(OpCodes.Call, super.GetConstructor(Type.EmptyTypes)); + ilg.Emit(OpCodes.Ret); + + + if (ret._altCtorDrops > 0) + { + Type[] ctorTypes = ret.CtorTypes(); + int newLen = ctorTypes.Length - ret._altCtorDrops; + if (newLen > 0) + { + Type[] altCtorTypes = new Type[newLen]; + for (int i = 0; i < altCtorTypes.Length; i++) + altCtorTypes[i] = ctorTypes[i]; + ConstructorBuilder cb2 = tb.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, altCtorTypes); + CljILGen ilg2 = new CljILGen(cb2.GetILGenerator()); + ilg2.EmitLoadArg(0); + for (int i = 0; i < newLen; i++) + ilg2.EmitLoadArg(i + 1); + for (int i = 0; i < ret._altCtorDrops; i++) + ilg2.EmitNull(); + ilg2.Emit(OpCodes.Call, cb); + ilg2.Emit(OpCodes.Ret); + } + } + } + + Type t = tb.CreateType(); + //Compiler.RegisterDuplicateType(t); + return t; + } + + + + static string[] InterfaceNames(IPersistentVector interfaces) + { + int icnt = interfaces.count(); + string[] inames = icnt > 0 ? new string[icnt] : null; + for (int i = 0; i < icnt; i++) + inames[i] = SlashName((Type)interfaces.nth(i)); + return inames; + } + + + static string SlashName(Type t) + { + return t.FullName.Replace(',', '/'); + } + + + #endregion + + #region Method reflection + + static void GatherMethods( + Type st, + ISeq interfaces, + out Dictionary> overrides) + { + Dictionary> allm = new Dictionary>(); + GatherMethods(st, allm); + for (; interfaces != null; interfaces = interfaces.next()) + GatherMethods((Type)interfaces.first(), allm); + + overrides = allm; + } + + static void GatherMethods(Type t, Dictionary> mm) + { + for (Type mt = t; mt != null; mt = mt.BaseType) + foreach (MethodInfo m in mt.GetMethods(BindingFlags.FlattenHierarchy | BindingFlags.Instance | BindingFlags.Public | BindingFlags.NonPublic)) + ConsiderMethod(m, mm); + + if (t.IsInterface) + foreach (Type it in t.GetInterfaces()) + GatherMethods(it, mm); + } + + static void ConsiderMethod(MethodInfo m, Dictionary> mm) + { + IPersistentVector mk = MSig(m); + if (!(mm.ContainsKey(mk) + || !(m.IsPublic || m.IsProtected()) + || m.IsStatic + || m.IsFinal)) + AddMethod(mm, mk, m); + } + + public static IPersistentVector MSig(MethodInfo m) + { + return RT.vector(m.Name, RT.seq(Compiler.GetTypes(m.GetParameters())), m.ReturnType); + } + + static void AddMethod(Dictionary> mm, IPersistentVector sig, MethodInfo m) + { + List value; + if (!mm.TryGetValue(sig, out value)) + { + value = new List(); + mm[sig] = value; + } + value.Add(m); + } + + #endregion + + #region ObjExpr methods + + protected override bool SupportsMeta + { + get { return ! IsDefType; } + } + + #endregion + + #region Code generation + + private static string ExplicitMethodName(MethodInfo mi) + { + return mi.DeclaringType.Name + "." + mi.Name; + } + + protected override void EmitStatics(TypeBuilder tb) + { + if (IsDefType) + { + // getBasis() + { + MethodBuilder mbg = tb.DefineMethod("getBasis", MethodAttributes.Public | MethodAttributes.Static, typeof(IPersistentVector), Type.EmptyTypes); + CljILGen ilg = new CljILGen(mbg.GetILGenerator()); + EmitValue(_hintedFields, ilg); + ilg.Emit(OpCodes.Ret); + } + + if (Fields.count() > _hintedFields.count()) + { + // create(IPersistentMap) + MethodBuilder mbc = tb.DefineMethod("create", MethodAttributes.Public | MethodAttributes.Static, tb, new Type[] { typeof(IPersistentMap) }); + CljILGen gen = new CljILGen(mbc.GetILGenerator()); + + LocalBuilder kwLocal = gen.DeclareLocal(typeof(Keyword)); + List locals = new List(); + for (ISeq s = RT.seq(_hintedFields); s != null; s = s.next()) + { + string bName = ((Symbol)s.first()).Name; + Type t = Compiler.TagType(Compiler.TagOf(s.first())); + + // local_kw = Keyword.intern(bname) + // local_i = arg_0.valAt(kw,null) + gen.EmitLoadArg(0); + gen.EmitString(bName); + gen.EmitCall(Compiler.Method_Keyword_intern_string); + gen.Emit(OpCodes.Dup); + gen.Emit(OpCodes.Stloc, kwLocal.LocalIndex); + gen.EmitNull(); + gen.EmitCall(Compiler.Method_IPersistentMap_valAt2); + LocalBuilder lb = gen.DeclareLocal(t); + locals.Add(lb); + if (t.IsPrimitive) + gen.EmitUnbox(t); + gen.Emit(OpCodes.Stloc, lb.LocalIndex); + + // arg_0 = arg_0.without(local_kw); + gen.EmitLoadArg(0); + gen.Emit(OpCodes.Ldloc, kwLocal.LocalIndex); + gen.EmitCall(Compiler.Method_IPersistentMap_without); + gen.EmitStoreArg(0); + } + + foreach (LocalBuilder lb in locals) + gen.Emit(OpCodes.Ldloc, lb.LocalIndex); + gen.EmitNull(); + gen.EmitLoadArg(0); + gen.EmitCall(Compiler.Method_RT_seqOrElse); + gen.EmitNew(_ctorInfo); + + gen.Emit(OpCodes.Ret); + } + } + } + + protected override void EmitMethods(TypeBuilder tb) + { + HashSet implemented = new HashSet(); + + for (ISeq s = RT.seq(_methods); s != null; s = s.next()) + { + NewInstanceMethod method = (NewInstanceMethod)s.first(); + method.Emit(this, tb); + implemented.UnionWith(method.MethodInfos); + } + + foreach (List ms in _methodMap.Values) + foreach (MethodInfo mi in ms) + { + if (NeedsDummy(mi, implemented)) + EmitDummyMethod(tb, mi); + } + + EmitHasArityMethod(_typeBuilder, null, false, 0); + } + + private bool NeedsDummy(MethodInfo mi, HashSet implemented) + { + return !implemented.Contains(mi) && mi.DeclaringType.IsInterface && !(!IsDefType && mi.DeclaringType == typeof(IObj) || mi.DeclaringType == typeof(IMeta)); + } + + private static void EmitDummyMethod(TypeBuilder tb, MethodInfo mi) + { + MethodBuilder mb = tb.DefineMethod(ExplicitMethodName(mi), MethodAttributes.ReuseSlot | MethodAttributes.Public | MethodAttributes.Virtual, mi.ReturnType, Compiler.GetTypes(mi.GetParameters())); + CljILGen gen = new CljILGen(mb.GetILGenerator()); + gen.EmitNew(typeof(NotImplementedException), Type.EmptyTypes); + gen.Emit(OpCodes.Throw); + tb.DefineMethodOverride(mb, mi); + } + + #endregion + } +} + + public OtherNewInstanceExpr(object tag) + : base(tag) + { + } + + #endregion + + #region Parsing + + public sealed class DefTypeParser : IParser + { + public Expr Parse(ParserContext pcon, object frm) + { + // frm is: (deftype* tagname classname [fields] :implements [interfaces] :tag tagname methods*) + + ISeq rform = (ISeq)frm; + rform = RT.next(rform); + + string tagname = ((Symbol)rform.first()).ToString(); + rform = rform.next(); + Symbol classname = (Symbol)rform.first(); + rform = rform.next(); + IPersistentVector fields = (IPersistentVector)rform.first(); + rform = rform.next(); + IPersistentMap opts = PersistentHashMap.EMPTY; + while (rform != null && rform.first() is Keyword) + { + opts = opts.assoc(rform.first(), RT.second(rform)); + rform = rform.next().next(); + } + + ObjExpr ret = Build((IPersistentVector)RT.get(opts, Compiler.ImplementsKeyword, PersistentVector.EMPTY), fields, null, tagname, classname, + (Symbol)RT.get(opts, RT.TagKey), rform, frm); + + return ret; + } + } + + + public sealed class ReifyParser : IParser + { + public Expr Parse(ParserContext pcon, object frm) + { + // frm is: (reify this-name? [interfaces] (method-name [args] body)* ) + ISeq form = (ISeq)frm; + ObjMethod enclosingMethod = (ObjMethod)Compiler.MethodVar.deref(); + string baseName = enclosingMethod != null + ? (ObjExpr.TrimGenId(enclosingMethod.Objx.Name) + "$") + : (Compiler.munge(Compiler.CurrentNamespace.Name.Name) + "$"); + string simpleName = "reify__" + RT.nextID(); + string className = baseName + simpleName; + + ISeq rform = RT.next(form); + + IPersistentVector interfaces = ((IPersistentVector)RT.first(rform)).cons(Symbol.intern("clojure.lang.IObj")); + + rform = RT.next(rform); + + ObjExpr ret = Build(interfaces, null, null, className, Symbol.intern(className), null, rform,frm); + IObj iobj = frm as IObj; + + if (iobj != null && iobj.meta() != null) + return new MetaExpr(ret, MapExpr.Parse(pcon.EvalOrExpr(),iobj.meta())); + else + return ret; + } + } + + internal static ObjExpr Build( + IPersistentVector interfaceSyms, + IPersistentVector fieldSyms, + Symbol thisSym, + string tagName, + Symbol className, + Symbol typeTag, + ISeq methodForms, + Object frm) + { + OtherNewInstanceExpr ret = new OtherNewInstanceExpr(null); + ret._src = frm; + ret._name = className.ToString(); + ret._classMeta = GenInterface.ExtractAttributes(RT.meta(className)); + ret.InternalName = ret._name; // ret.Name.Replace('.', '/'); + // Java: ret.objtype = Type.getObjectType(ret.internalName); + + if (thisSym != null) + ret._thisName = thisSym.Name; + + if (fieldSyms != null) + { + IPersistentMap fmap = PersistentHashMap.EMPTY; + object[] closesvec = new object[2 * fieldSyms.count()]; + for (int i = 0; i < fieldSyms.count(); i++) + { + Symbol sym = (Symbol)fieldSyms.nth(i); + LocalBinding lb = new LocalBinding(-1, sym, null, new MethodParamExpr(Compiler.TagType(Compiler.TagOf(sym))), false, false, false); + fmap = fmap.assoc(sym, lb); + closesvec[i * 2] = lb; + closesvec[i * 2 + 1] = lb; + } + // Java TODO: inject __meta et al into closes - when? + // use array map to preserve ctor order + ret.Closes = new PersistentArrayMap(closesvec); + ret.Fields = fmap; + for (int i = fieldSyms.count() - 1; i >= 0 && (((Symbol)fieldSyms.nth(i)).Name.Equals("__meta") || ((Symbol)fieldSyms.nth(i)).Name.Equals("__extmap")); --i) + ret._altCtorDrops++; + } + + // Java TODO: set up volatiles + //ret._volatiles = PersistentHashSet.create(RT.seq(RT.get(ret._optionsMap, volatileKey))); + + IPersistentVector interfaces = PersistentVector.EMPTY; + for (ISeq s = RT.seq(interfaceSyms); s != null; s = s.next()) + { + Type t = (Type)Compiler.Resolve((Symbol)s.first()); + if (!t.IsInterface) + throw new ParseException("only interfaces are supported, had: " + t.Name); + interfaces = interfaces.cons(t); + } + // Type superClass = typeof(Object); + + Dictionary> overrideables; + GatherMethods(superClass, RT.seq(interfaces), out overrideables); + + ret._methodMap = overrideables; + + + GenContext context = Compiler.IsCompiling + ? Compiler.CompilerContextVar.get() as GenContext + : (ret.IsDefType + ? GenContext.CreateWithExternalAssembly("deftype" + RT.nextID().ToString(), ".dll", true) + : (Compiler.CompilerContextVar.get() as GenContext + ?? + Compiler.EvalContext)); + + GenContext genC = context.WithNewDynInitHelper(ret.InternalName + "__dynInitHelper_" + RT.nextID().ToString()); + + Type stub = CompileStub(genC, superClass, ret, SeqToTypeArray(interfaces), frm); + Symbol thisTag = Symbol.intern(null, stub.FullName); + //Symbol stubTag = Symbol.intern(null,stub.FullName); + //Symbol thisTag = Symbol.intern(null, tagName); + + + try + { + Var.pushThreadBindings( + RT.mapUniqueKeys( + Compiler.ConstantsVar, PersistentVector.EMPTY, + Compiler.ConstantIdsVar, new IdentityHashMap(), + Compiler.KeywordsVar, PersistentHashMap.EMPTY, + Compiler.VarsVar, PersistentHashMap.EMPTY, + Compiler.KeywordCallsitesVar, PersistentVector.EMPTY, + Compiler.ProtocolCallsitesVar, PersistentVector.EMPTY, + Compiler.VarCallsitesVar, Compiler.EmptyVarCallSites(), + Compiler.NoRecurVar, null, + Compiler.CompilerContextVar, genC + )); + + if (ret.IsDefType) + { + Var.pushThreadBindings( + RT.mapUniqueKeys( + Compiler.MethodVar, null, + Compiler.LocalEnvVar, ret.Fields, + Compiler.CompileStubSymVar, Symbol.intern(null, tagName), + Compiler.CompileStubClassVar, stub + )); + ret._hintedFields = RT.subvec(fieldSyms, 0, fieldSyms.count() - ret._altCtorDrops); + } + // now (methodname [args] body)* + + ret.SpanMap = (IPersistentMap)Compiler.SourceSpanVar.deref(); + + IPersistentCollection methods = null; + for (ISeq s = methodForms; s != null; s = RT.next(s)) + { + NewInstanceMethod m = NewInstanceMethod.Parse(ret, (ISeq)RT.first(s), thisTag, overrideables); + methods = RT.conj(methods, m); + } + + ret._methods = methods; + ret.Keywords = (IPersistentMap)Compiler.KeywordsVar.deref(); + ret.Vars = (IPersistentMap)Compiler.VarsVar.deref(); + ret.Constants = (PersistentVector)Compiler.ConstantsVar.deref(); + ret._constantsID = RT.nextID(); + ret.KeywordCallsites = (IPersistentVector)Compiler.KeywordCallsitesVar.deref(); + ret.ProtocolCallsites = (IPersistentVector)Compiler.ProtocolCallsitesVar.deref(); + ret.VarCallsites = (IPersistentSet)Compiler.VarCallsitesVar.deref(); + } + finally + { + if (ret.IsDefType) + Var.popThreadBindings(); + Var.popThreadBindings(); + } + + // TOD: Really, the first stub here should be 'superclass' but can't handle hostexprs nested in method bodies -- reify method compilation takes place before this sucker is compiled, so can't replace the call. + // Might be able to flag stub classes and not try to convert, leading to a dynsite. + + //if (RT.CompileDLR) + ret.Compile(stub, stub, interfaces, false, genC); + //else + // ret.CompileNoDlr(stub, stub, interfaces, false, genC); + + Compiler.RegisterDuplicateType(ret.CompiledType); + + return ret; + } + + private static Type[] SeqToTypeArray(IPersistentVector interfaces) + { + Type[] types = new Type[interfaces.count()]; + for (int i = 0; i < interfaces.count(); i++) + types[i] = (Type)interfaces.nth(i); + + return types; + } + + /*** + * Current host interop uses reflection, which requires pre-existing classes + * Work around this by: + * Generate a stub class that has the same interfaces and fields as the class we are generating. + * Use it as a type hint for this, and bind the simple name of the class to this stub (in resolve etc) + * Unmunge the name (using a magic prefix) on any code gen for classes + */ + + // TODO: Preparse method heads to pick up signatures, implement those methods as abstract or as NotImpelmented so that Reflection can pick up calls during compilation and avoide a callsite. + static Type CompileStub(GenContext context, Type super, OtherNewInstanceExpr ret, Type[] interfaces, Object frm) + { + TypeBuilder tb = context.ModuleBuilder.DefineType(Compiler.CompileStubPrefix + "." + ret.InternalName + RT.nextID(), TypeAttributes.Public | TypeAttributes.Abstract, super, interfaces); + + tb.DefineDefaultConstructor(MethodAttributes.Public); + + // instance fields for closed-overs + for (ISeq s = RT.keys(ret.Closes); s != null; s = s.next()) + { + LocalBinding lb = (LocalBinding)s.first(); + FieldAttributes access = FieldAttributes.Public; + + if (!ret.IsMutable(lb)) + access |= FieldAttributes.InitOnly; + + Type fieldType = lb.PrimitiveType ?? typeof(Object); + + if (ret.IsVolatile(lb)) + tb.DefineField(lb.Name, fieldType, new Type[] { typeof(IsVolatile) }, Type.EmptyTypes, access); + else + tb.DefineField(lb.Name, fieldType, access); + } + + // ctor that takes closed-overs and does nothing + if (ret.CtorTypes().Length > 0) + { + ConstructorBuilder cb = tb.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, ret.CtorTypes()); + CljILGen ilg = new CljILGen(cb.GetILGenerator()); + ilg.EmitLoadArg(0); + ilg.Emit(OpCodes.Call, super.GetConstructor(Type.EmptyTypes)); + ilg.Emit(OpCodes.Ret); + + + if (ret._altCtorDrops > 0) + { + Type[] ctorTypes = ret.CtorTypes(); + int newLen = ctorTypes.Length - ret._altCtorDrops; + if (newLen > 0) + { + Type[] altCtorTypes = new Type[newLen]; + for (int i = 0; i < altCtorTypes.Length; i++) + altCtorTypes[i] = ctorTypes[i]; + ConstructorBuilder cb2 = tb.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, altCtorTypes); + CljILGen ilg2 = new CljILGen(cb2.GetILGenerator()); + ilg2.EmitLoadArg(0); + for (int i = 0; i < newLen; i++) + ilg2.EmitLoadArg(i + 1); + for (int i = 0; i < ret._altCtorDrops; i++) + ilg2.EmitNull(); + ilg2.Emit(OpCodes.Call, cb); + ilg2.Emit(OpCodes.Ret); + } + } + } + + Type t = tb.CreateType(); + //Compiler.RegisterDuplicateType(t); + return t; + } + + + + static string[] InterfaceNames(IPersistentVector interfaces) + { + int icnt = interfaces.count(); + string[] inames = icnt > 0 ? new string[icnt] : null; + for (int i = 0; i < icnt; i++) + inames[i] = SlashName((Type)interfaces.nth(i)); + return inames; + } + + + static string SlashName(Type t) + { + return t.FullName.Replace(',', '/'); + } + + + #endregion + + #region Method reflection + + static void GatherMethods( + Type st, + ISeq interfaces, + out Dictionary> overrides) + { + Dictionary> allm = new Dictionary>(); + GatherMethods(st, allm); + for (; interfaces != null; interfaces = interfaces.next()) + GatherMethods((Type)interfaces.first(), allm); + + overrides = allm; + } + + static void GatherMethods(Type t, Dictionary> mm) + { + for (Type mt = t; mt != null; mt = mt.BaseType) + foreach (MethodInfo m in mt.GetMethods(BindingFlags.FlattenHierarchy | BindingFlags.Instance | BindingFlags.Public | BindingFlags.NonPublic)) + ConsiderMethod(m, mm); + + if (t.IsInterface) + foreach (Type it in t.GetInterfaces()) + GatherMethods(it, mm); + } + + static void ConsiderMethod(MethodInfo m, Dictionary> mm) + { + IPersistentVector mk = MSig(m); + if (!(mm.ContainsKey(mk) + || !(m.IsPublic || m.IsProtected()) + || m.IsStatic + || m.IsFinal)) + AddMethod(mm, mk, m); + } + + public static IPersistentVector MSig(MethodInfo m) + { + return RT.vector(m.Name, RT.seq(Compiler.GetTypes(m.GetParameters())), m.ReturnType); + } + + static void AddMethod(Dictionary> mm, IPersistentVector sig, MethodInfo m) + { + List value; + if (!mm.TryGetValue(sig, out value)) + { + value = new List(); + mm[sig] = value; + } + value.Add(m); + } + + #endregion + + #region ObjExpr methods + + protected override bool SupportsMeta + { + get { return ! IsDefType; } + } + + #endregion + + #region Code generation + + private static string ExplicitMethodName(MethodInfo mi) + { + return mi.DeclaringType.Name + "." + mi.Name; + } + + protected override void EmitStatics(TypeBuilder tb) + { + if (IsDefType) + { + // getBasis() + { + MethodBuilder mbg = tb.DefineMethod("getBasis", MethodAttributes.Public | MethodAttributes.Static, typeof(IPersistentVector), Type.EmptyTypes); + CljILGen ilg = new CljILGen(mbg.GetILGenerator()); + EmitValue(_hintedFields, ilg); + ilg.Emit(OpCodes.Ret); + } + + if (Fields.count() > _hintedFields.count()) + { + // create(IPersistentMap) + MethodBuilder mbc = tb.DefineMethod("create", MethodAttributes.Public | MethodAttributes.Static, tb, new Type[] { typeof(IPersistentMap) }); + CljILGen gen = new CljILGen(mbc.GetILGenerator()); + + LocalBuilder kwLocal = gen.DeclareLocal(typeof(Keyword)); + List locals = new List(); + for (ISeq s = RT.seq(_hintedFields); s != null; s = s.next()) + { + string bName = ((Symbol)s.first()).Name; + Type t = Compiler.TagType(Compiler.TagOf(s.first())); + + // local_kw = Keyword.intern(bname) + // local_i = arg_0.valAt(kw,null) + gen.EmitLoadArg(0); + gen.EmitString(bName); + gen.EmitCall(Compiler.Method_Keyword_intern_string); + gen.Emit(OpCodes.Dup); + gen.Emit(OpCodes.Stloc, kwLocal.LocalIndex); + gen.EmitNull(); + gen.EmitCall(Compiler.Method_IPersistentMap_valAt2); + LocalBuilder lb = gen.DeclareLocal(t); + locals.Add(lb); + if (t.IsPrimitive) + gen.EmitUnbox(t); + gen.Emit(OpCodes.Stloc, lb.LocalIndex); + + // arg_0 = arg_0.without(local_kw); + gen.EmitLoadArg(0); + gen.Emit(OpCodes.Ldloc, kwLocal.LocalIndex); + gen.EmitCall(Compiler.Method_IPersistentMap_without); + gen.EmitStoreArg(0); + } + + foreach (LocalBuilder lb in locals) + gen.Emit(OpCodes.Ldloc, lb.LocalIndex); + gen.EmitNull(); + gen.EmitLoadArg(0); + gen.EmitCall(Compiler.Method_RT_seqOrElse); + gen.EmitNew(_ctorInfo); + + gen.Emit(OpCodes.Ret); + } + } + } + + protected override void EmitMethods(TypeBuilder tb) + { + HashSet implemented = new HashSet(); + + for (ISeq s = RT.seq(_methods); s != null; s = s.next()) + { + NewInstanceMethod method = (NewInstanceMethod)s.first(); + method.Emit(this, tb); + implemented.UnionWith(method.MethodInfos); + } + + foreach (List ms in _methodMap.Values) + foreach (MethodInfo mi in ms) + { + if (NeedsDummy(mi, implemented)) + EmitDummyMethod(tb, mi); + } + + EmitHasArityMethod(_typeBuilder, null, false, 0); + } + + private bool NeedsDummy(MethodInfo mi, HashSet implemented) + { + return !implemented.Contains(mi) && mi.DeclaringType.IsInterface && !(!IsDefType && mi.DeclaringType == typeof(IObj) || mi.DeclaringType == typeof(IMeta)); + } + + private static void EmitDummyMethod(TypeBuilder tb, MethodInfo mi) + { + MethodBuilder mb = tb.DefineMethod(ExplicitMethodName(mi), MethodAttributes.ReuseSlot | MethodAttributes.Public | MethodAttributes.Virtual, mi.ReturnType, Compiler.GetTypes(mi.GetParameters())); + CljILGen gen = new CljILGen(mb.GetILGenerator()); + gen.EmitNew(typeof(NotImplementedException), Type.EmptyTypes); + gen.Emit(OpCodes.Throw); + tb.DefineMethodOverride(mb, mi); + } + + #endregion + } +} From 296f9499c7f1304e4a4d5de280ef5819cb6bb202 Mon Sep 17 00:00:00 2001 From: timsgardner Date: Sun, 27 Jul 2014 01:57:03 -0400 Subject: [PATCH 08/80] Proof of concept for extending stuff --- Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs | 3 +++ Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs | 5 ++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs index 57d90418a..2827cae67 100644 --- a/Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs @@ -151,6 +151,9 @@ internal static ObjExpr Build( interfaces = interfaces.cons(t); } Type superClass = typeof(Object); + //here begins the jank + //System.Type superClass = Type.GetType("UnityEngine.Component, UnityEngine, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null"); + Dictionary> overrideables; GatherMethods(superClass, RT.seq(interfaces), out overrideables); diff --git a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs index 594d3ad6c..d38c25b98 100644 --- a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs @@ -182,7 +182,10 @@ internal static ObjExpr Build( throw new ParseException("only interfaces are supported, had: " + t.Name); interfaces = interfaces.cons(t); } - Type superClass = typeof(Object); + // Type superClass = typeof(Object); + // here begins the jank + System.Type superClass = Type.GetType("UnityEngine.Component, UnityEngine, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null"); + Dictionary> overrideables; GatherMethods(superClass, RT.seq(interfaces), out overrideables); From a4ced7a1f748ee5316fcfb5e1737a363e9b3d99d Mon Sep 17 00:00:00 2001 From: timsgardner Date: Sun, 27 Jul 2014 02:42:06 -0400 Subject: [PATCH 09/80] working on other-deftype --- .../Clojure.Source/clojure/core_deftype.clj | 871 ++++++++++-------- .../CljCompiler/Ast/OtherNewInstanceExpr.cs | 509 +--------- Clojure/Clojure/CljCompiler/Compiler.cs | 5 +- 3 files changed, 486 insertions(+), 899 deletions(-) diff --git a/Clojure/Clojure.Source/clojure/core_deftype.clj b/Clojure/Clojure.Source/clojure/core_deftype.clj index 59e4eb666..2db30d44c 100644 --- a/Clojure/Clojure.Source/clojure/core_deftype.clj +++ b/Clojure/Clojure.Source/clojure/core_deftype.clj @@ -8,31 +8,31 @@ (in-ns 'clojure.core) -;;;;;;;;;;;;;;;;;;;;;;;;;;;; definterface ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (defn namespace-munge - "Convert a Clojure namespace name to a legal Java package name." - {:added "1.2"} - [ns] - (.Replace (str ns) \- \_)) ;;; .replace - -;for now, built on gen-interface -(defmacro definterface - "Creates a new Java interface with the given name and method sigs. - The method return types and parameter types may be specified with type hints, - defaulting to Object if omitted. - - (definterface MyInterface - (^int method1 [x]) - (^Bar method2 [^Baz b ^Quux q]))" - {:added "1.2"} ;; Present since 1.2, but made public in 1.5. - [name & sigs] - (let [tag (fn tag [x] (or (:tag (meta x)) Object)) - psig (fn [[name [& args]]] - (vector name (vec (map tag args)) (tag name) (map meta args))) - cname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name))] - `(let [] - (gen-interface :name ~cname :methods ~(vec (map psig sigs))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;; definterface ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (defn namespace-munge + "Convert a Clojure namespace name to a legal Java package name." + {:added "1.2"} + [ns] + (.Replace (str ns) \- \_)) ;;; .replace + +;for now, built on gen-interface +(defmacro definterface + "Creates a new Java interface with the given name and method sigs. + The method return types and parameter types may be specified with type hints, + defaulting to Object if omitted. + + (definterface MyInterface + (^int method1 [x]) + (^Bar method2 [^Baz b ^Quux q]))" + {:added "1.2"} ;; Present since 1.2, but made public in 1.5. + [name & sigs] + (let [tag (fn tag [x] (or (:tag (meta x)) Object)) + psig (fn [[name [& args]]] + (vector name (vec (map tag args)) (tag name) (map meta args))) + cname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name))] + `(let [] + (gen-interface :name ~cname :methods ~(vec (map psig sigs))) (import ~cname)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; reify/deftype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -60,10 +60,10 @@ set (disj 'Object 'java.lang.Object) vec) - methods (map (fn [[name params & body]] - (cons name (maybe-destructured params body))) - (apply concat (vals impls)))] - (when-let [bad-opts (seq (remove #{:no-print} (keys opts)))] + methods (map (fn [[name params & body]] + (cons name (maybe-destructured params body))) + (apply concat (vals impls)))] + (when-let [bad-opts (seq (remove #{:no-print} (keys opts)))] (throw (ArgumentException. (apply print-str "Unsupported option(s) -" bad-opts)))) ;;; IllegalArgumentException [interfaces methods opts])) @@ -82,11 +82,11 @@ Methods should be supplied for all methods of the desired protocol(s) and interface(s). You can also define overrides for - methods of Object. Note that the first parameter must be supplied to - correspond to the target object ('this' in Java parlance). Thus - methods for interfaces will take one more argument than do the - interface declarations. Note also that recur calls to the method - head should *not* pass the target object, it will be supplied + methods of Object. Note that the first parameter must be supplied to + correspond to the target object ('this' in Java parlance). Thus + methods for interfaces will take one more argument than do the + interface declarations. Note also that recur calls to the method + head should *not* pass the target object, it will be supplied automatically and can not be substituted. The return type can be indicated by a type hint on the method name, @@ -111,12 +111,12 @@ (seq (let [f \"foo\"] (reify clojure.lang.Seqable (seq [this] (seq f))))) - == (\\f \\o \\o)) - - reify always implements clojure.lang.IObj and transfers meta - data of the form to the created object. - - (meta ^{:k :v} (reify Object (toString [this] \"foo\"))) + == (\\f \\o \\o)) + + reify always implements clojure.lang.IObj and transfers meta + data of the form to the created object. + + (meta ^{:k :v} (reify Object (toString [this] \"foo\"))) == {:k :v}" {:added "1.2"} [& opts+specs] @@ -129,24 +129,24 @@ (defn munge [s] ((if (symbol? s) symbol str) (clojure.lang.Compiler/munge (str s)))) -(defn- imap-cons - [^clojure.lang.IPersistentMap this o] - (cond - (instance? clojure.lang.IMapEntry o) ;;; java.util.Map$Entry - (let [^clojure.lang.IMapEntry pair o] ;;; java.util.Map$Entry - (.assoc this (.key pair) (.val pair))) ;;; .getKey .getValue - (instance? System.Collections.DictionaryEntry o) ;;; DM: Added - (let [^clojure.lang.IMapEntry pair o] ;;; DM: Added - (.assoc this (.Key pair) (.Value pair))) ;;; DM: Added - (instance? clojure.lang.IPersistentVector o) - (let [^clojure.lang.IPersistentVector vec o] - (.assoc this (.nth vec 0) (.nth vec 1))) - :else (loop [this this - o o] - (if (seq o) - (let [^clojure.lang.IMapEntry pair (first o)] ;;; java.util.Map$Entry - (recur (.assoc this (.key pair) (.val pair)) (rest o))) ;;; .getKey .getValue - this)))) +(defn- imap-cons + [^clojure.lang.IPersistentMap this o] + (cond + (instance? clojure.lang.IMapEntry o) ;;; java.util.Map$Entry + (let [^clojure.lang.IMapEntry pair o] ;;; java.util.Map$Entry + (.assoc this (.key pair) (.val pair))) ;;; .getKey .getValue + (instance? System.Collections.DictionaryEntry o) ;;; DM: Added + (let [^clojure.lang.IMapEntry pair o] ;;; DM: Added + (.assoc this (.Key pair) (.Value pair))) ;;; DM: Added + (instance? clojure.lang.IPersistentVector o) + (let [^clojure.lang.IPersistentVector vec o] + (.assoc this (.nth vec 0) (.nth vec 1))) + :else (loop [this this + o o] + (if (seq o) + (let [^clojure.lang.IMapEntry pair (first o)] ;;; java.util.Map$Entry + (recur (.assoc this (.key pair) (.val pair)) (rest o))) ;;; .getKey .getValue + this)))) (defn- emit-defrecord "Do not use this directly - use defrecord" @@ -161,153 +161,153 @@ base-fields fields fields (conj fields '__meta '__extmap) type-hash (hash classname)] - (when (some #{:volatile-mutable :unsynchronized-mutable} (mapcat (comp keys meta) hinted-fields)) - (throw (ArgumentException. ":volatile-mutable or :unsynchronized-mutable not supported for record fields"))) ;;; IllegalArgumentException + (when (some #{:volatile-mutable :unsynchronized-mutable} (mapcat (comp keys meta) hinted-fields)) + (throw (ArgumentException. ":volatile-mutable or :unsynchronized-mutable not supported for record fields"))) ;;; IllegalArgumentException (let [gs (gensym)] (letfn - [(irecord [[i m]] - [(conj i 'clojure.lang.IRecord) - m]) - (eqhash [[i m]] - [(conj i 'clojure.lang.IHashEq) - (conj m - `(hasheq [this#] (bit-xor ~type-hash (clojure.lang.APersistentMap/mapHasheq this#))) ;;; .hashCode - `(GetHashCode [this#] (clojure.lang.APersistentMap/mapHash this#)) ;;; hashCode - `(Equals [this# ~gs] (clojure.lang.APersistentMap/mapEquals this# ~gs)))]) ;;; equals + [(irecord [[i m]] + [(conj i 'clojure.lang.IRecord) + m]) + (eqhash [[i m]] + [(conj i 'clojure.lang.IHashEq) + (conj m + `(hasheq [this#] (bit-xor ~type-hash (clojure.lang.APersistentMap/mapHasheq this#))) ;;; .hashCode + `(GetHashCode [this#] (clojure.lang.APersistentMap/mapHash this#)) ;;; hashCode + `(Equals [this# ~gs] (clojure.lang.APersistentMap/mapEquals this# ~gs)))]) ;;; equals (iobj [[i m]] - [(conj i 'clojure.lang.IObj) - (conj m `(meta [this#] ~'__meta) + [(conj i 'clojure.lang.IObj) + (conj m `(meta [this#] ~'__meta) `(withMeta [this# ~gs] (new ~tagname ~@(replace {'__meta gs} fields))))]) (ilookup [[i m]] - [(conj i 'clojure.lang.ILookup 'clojure.lang.IKeywordLookup) - (conj m `(valAt [this# k#] (.valAt this# k# nil)) - `(valAt [this# k# else#] - (case k# ~@(mapcat (fn [fld] [(keyword fld) fld]) - base-fields) - (get ~'__extmap k# else#))) - `(getLookupThunk [this# k#] - (let [~'gclass (class this#)] - (case k# - ~@(let [hinted-target 'gtarget] ;;; Major loss of type hint here: [hinted-target (with-meta 'gtarget {:tag tagname})] - (mapcat - (fn [fld] - [(keyword fld) - `(reify clojure.lang.ILookupThunk - (get [~'thunk ~'gtarget] - (if (identical? (class ~'gtarget) ~'gclass) - (. ~hinted-target ~(symbol (str "-" fld))) - ~'thunk)))]) - base-fields)) + [(conj i 'clojure.lang.ILookup 'clojure.lang.IKeywordLookup) + (conj m `(valAt [this# k#] (.valAt this# k# nil)) + `(valAt [this# k# else#] + (case k# ~@(mapcat (fn [fld] [(keyword fld) fld]) + base-fields) + (get ~'__extmap k# else#))) + `(getLookupThunk [this# k#] + (let [~'gclass (class this#)] + (case k# + ~@(let [hinted-target 'gtarget] ;;; Major loss of type hint here: [hinted-target (with-meta 'gtarget {:tag tagname})] + (mapcat + (fn [fld] + [(keyword fld) + `(reify clojure.lang.ILookupThunk + (get [~'thunk ~'gtarget] + (if (identical? (class ~'gtarget) ~'gclass) + (. ~hinted-target ~(symbol (str "-" fld))) + ~'thunk)))]) + base-fields)) nil))))]) (imap [[i m]] - [(conj i 'clojure.lang.IPersistentMap) - (conj m - `(count [this#] (+ ~(count base-fields) (count ~'__extmap))) - `(empty [this#] (throw (InvalidOperationException. (str "Can't create empty: " ~(str classname))))) ;;; UnsupportedOperationException - `(^ clojure.lang.IPersistentMap cons [this# e#] ((var imap-cons) this# e#)) ;;; type hint added - `(equiv [this# ~gs] - (boolean - (or (identical? this# ~gs) - (when (identical? (class this#) (class ~gs)) - (let [~gs ~gs ] ;;; ~(with-meta gs {:tag tagname})] ----------------major loss of type hint here. TODO: Figure out what the problem is - (and ~@(map (fn [fld] `(= ~fld (. ~gs ~(symbol (str "-" fld))))) base-fields) - (= ~'__extmap (. ~gs ~'__extmap)))))))) - `(containsKey [this# k#] (not (identical? this# (.valAt this# k# this#)))) - `(entryAt [this# k#] (let [v# (.valAt this# k# this#)] - (when-not (identical? this# v#) - (clojure.lang.MapEntry. k# v#)))) - `(seq [this#] (seq (concat [~@(map #(list `new `clojure.lang.MapEntry (keyword %) %) base-fields)] - ~'__extmap))) - `(|System.Collections.Generic.IEnumerable`1[clojure.lang.IMapEntry]|.GetEnumerator [this#] (clojure.lang.IMapEntrySeqEnumerator. this#)) - `(^ clojure.lang.IPersistentMap assoc [this# k# ~gs] ;;; type hint added - (condp identical? k# - ~@(mapcat (fn [fld] - [(keyword fld) (list* `new tagname (replace {fld gs} fields))]) - base-fields) - (new ~tagname ~@(remove #{'__extmap} fields) (assoc ~'__extmap k# ~gs)))) - `(assocEx [this# k# v#] ;;; ADDED - (if (.containsKey k#) ;;; ADDED - (throw (Exception. "Key already present")) ;;; ADDED - (.assoc this# k# v#))) ;;; ADDED - `(without [this# k#] (if (contains? #{~@(map keyword base-fields)} k#) - (dissoc (with-meta (into {} this#) ~'__meta) k#) - (new ~tagname ~@(remove #{'__extmap} fields) - (not-empty (dissoc ~'__extmap k#))))))]) - (dict [[i m]] - [(conj i 'System.Collections.IDictionary) - (conj m ;;; TODO: Need properties, really - `(get_Count [this#] (.count this#)) - `(get_IsFixedSize [this#] true) - `(get_IsReadOnly [this#] true) - `(get_IsSynchronized [this#] true) - `(get_Item [this# k#] (.valAt this# k#)) - `(^System.Void set_Item [this# k# v#] (throw (NotSupportedException.))) - `(Remove [this# k#] (throw (NotSupportedException.))) - `(get_Keys [this#] (set (keys this#))) - `(get_SyncRoot [this#] this#) - `(get_Values [this#] (set (vals this#))) - `(Add [this# k# v#] (throw (NotSupportedException.))) - `(Clear [this#] (throw (NotSupportedException.))) - `(Contains [this# k#] (.containsKey this# k#)) - `(CopyTo [this# a# i#] (throw (InvalidOperationException.))) ;;; TODO: implement this. Got lazy. - `(System.Collections.IDictionary.GetEnumerator [this#] (clojure.lang.Runtime.ImmutableDictionaryEnumerator. this#)) - `(System.Collections.IEnumerable.GetEnumerator [this#] (clojure.lang.IMapEntrySeqEnumerator. (seq this#))) - )]) - (ipc [[i m]] - [(conj i 'clojure.lang.IPersistentCollection) - (conj m - `(clojure.lang.IPersistentCollection.cons [this# e#] ;;; ADDED - ((var imap-cons) this# e#)))]) ;;; ADDED - (associative ;;; ADDED - [[i m]] ;;; ADDED - [(conj i 'clojure.lang.Associative) ;;; ADDED - (conj m - `(clojure.lang.Associative.assoc [this# k# ~gs] ;;; ADDED - (condp identical? k# ;;; ADDED - ~@(mapcat (fn [fld] ;;; ADDED - [(keyword fld) (list* `new tagname (replace {fld gs} fields))]) ;;; ADDED - base-fields) ;;; ADDED - (new ~tagname ~@(remove #{'__extmap} fields) (assoc ~'__extmap k# ~gs)))))])] ;;; ADDED + [(conj i 'clojure.lang.IPersistentMap) + (conj m + `(count [this#] (+ ~(count base-fields) (count ~'__extmap))) + `(empty [this#] (throw (InvalidOperationException. (str "Can't create empty: " ~(str classname))))) ;;; UnsupportedOperationException + `(^ clojure.lang.IPersistentMap cons [this# e#] ((var imap-cons) this# e#)) ;;; type hint added + `(equiv [this# ~gs] + (boolean + (or (identical? this# ~gs) + (when (identical? (class this#) (class ~gs)) + (let [~gs ~gs ] ;;; ~(with-meta gs {:tag tagname})] ----------------major loss of type hint here. TODO: Figure out what the problem is + (and ~@(map (fn [fld] `(= ~fld (. ~gs ~(symbol (str "-" fld))))) base-fields) + (= ~'__extmap (. ~gs ~'__extmap)))))))) + `(containsKey [this# k#] (not (identical? this# (.valAt this# k# this#)))) + `(entryAt [this# k#] (let [v# (.valAt this# k# this#)] + (when-not (identical? this# v#) + (clojure.lang.MapEntry. k# v#)))) + `(seq [this#] (seq (concat [~@(map #(list `new `clojure.lang.MapEntry (keyword %) %) base-fields)] + ~'__extmap))) + `(|System.Collections.Generic.IEnumerable`1[clojure.lang.IMapEntry]|.GetEnumerator [this#] (clojure.lang.IMapEntrySeqEnumerator. this#)) + `(^ clojure.lang.IPersistentMap assoc [this# k# ~gs] ;;; type hint added + (condp identical? k# + ~@(mapcat (fn [fld] + [(keyword fld) (list* `new tagname (replace {fld gs} fields))]) + base-fields) + (new ~tagname ~@(remove #{'__extmap} fields) (assoc ~'__extmap k# ~gs)))) + `(assocEx [this# k# v#] ;;; ADDED + (if (.containsKey k#) ;;; ADDED + (throw (Exception. "Key already present")) ;;; ADDED + (.assoc this# k# v#))) ;;; ADDED + `(without [this# k#] (if (contains? #{~@(map keyword base-fields)} k#) + (dissoc (with-meta (into {} this#) ~'__meta) k#) + (new ~tagname ~@(remove #{'__extmap} fields) + (not-empty (dissoc ~'__extmap k#))))))]) + (dict [[i m]] + [(conj i 'System.Collections.IDictionary) + (conj m ;;; TODO: Need properties, really + `(get_Count [this#] (.count this#)) + `(get_IsFixedSize [this#] true) + `(get_IsReadOnly [this#] true) + `(get_IsSynchronized [this#] true) + `(get_Item [this# k#] (.valAt this# k#)) + `(^System.Void set_Item [this# k# v#] (throw (NotSupportedException.))) + `(Remove [this# k#] (throw (NotSupportedException.))) + `(get_Keys [this#] (set (keys this#))) + `(get_SyncRoot [this#] this#) + `(get_Values [this#] (set (vals this#))) + `(Add [this# k# v#] (throw (NotSupportedException.))) + `(Clear [this#] (throw (NotSupportedException.))) + `(Contains [this# k#] (.containsKey this# k#)) + `(CopyTo [this# a# i#] (throw (InvalidOperationException.))) ;;; TODO: implement this. Got lazy. + `(System.Collections.IDictionary.GetEnumerator [this#] (clojure.lang.Runtime.ImmutableDictionaryEnumerator. this#)) + `(System.Collections.IEnumerable.GetEnumerator [this#] (clojure.lang.IMapEntrySeqEnumerator. (seq this#))) + )]) + (ipc [[i m]] + [(conj i 'clojure.lang.IPersistentCollection) + (conj m + `(clojure.lang.IPersistentCollection.cons [this# e#] ;;; ADDED + ((var imap-cons) this# e#)))]) ;;; ADDED + (associative ;;; ADDED + [[i m]] ;;; ADDED + [(conj i 'clojure.lang.Associative) ;;; ADDED + (conj m + `(clojure.lang.Associative.assoc [this# k# ~gs] ;;; ADDED + (condp identical? k# ;;; ADDED + ~@(mapcat (fn [fld] ;;; ADDED + [(keyword fld) (list* `new tagname (replace {fld gs} fields))]) ;;; ADDED + base-fields) ;;; ADDED + (new ~tagname ~@(remove #{'__extmap} fields) (assoc ~'__extmap k# ~gs)))))])] ;;; ADDED (let [[i m] (-> [interfaces methods] irecord eqhash iobj ilookup imap associative ipc dict)] ;;; Associative, ipc added `(deftype* ~tagname ~(vary-meta classname merge {System.SerializableAttribute {}}) ~(conj hinted-fields '__meta '__extmap) :implements ~(vec i) ~@m)))))) -(defn- build-positional-factory - "Used to build a positional factory for a given type/record. Because of the - limitation of 20 arguments to Clojure functions, this factory needs to be - constructed to deal with more arguments. It does this by building a straight - forward type/record ctor call in the <=20 case, and a call to the same - ctor pulling the extra args out of the & overage parameter. Finally, the - arity is constrained to the number of expected fields and an ArityException - will be thrown at runtime if the actual arg count does not match." - [nom classname fields] - (let [fn-name (symbol (str '-> nom)) - [field-args over] (split-at 20 fields) - field-count (count fields) - arg-count (count field-args) - over-count (count over) - docstring (str "Positional factory function for class " classname ".")] - `(defn ~fn-name - ~docstring - [~@field-args ~@(if (seq over) '[& overage] [])] - ~(if (seq over) - `(if (= (count ~'overage) ~over-count) - (new ~classname - ~@field-args - ~@(for [i (range 0 (count over))] - (list `nth 'overage i))) - (throw (clojure.lang.ArityException. (+ ~arg-count (count ~'overage)) (name '~fn-name)))) - `(new ~classname ~@field-args))))) - -(defn- validate-fields - "" - [fields] - (when-not (vector? fields) - (throw (Exception. "No fields vector given."))) ;;; AssertionError. - (let [specials #{'__meta '__extmap}] - (when (some specials fields) - (throw (Exception. (str "The names in " specials " cannot be used as field names for types or records.")))))) ;;; AssertionError. +(defn- build-positional-factory + "Used to build a positional factory for a given type/record. Because of the + limitation of 20 arguments to Clojure functions, this factory needs to be + constructed to deal with more arguments. It does this by building a straight + forward type/record ctor call in the <=20 case, and a call to the same + ctor pulling the extra args out of the & overage parameter. Finally, the + arity is constrained to the number of expected fields and an ArityException + will be thrown at runtime if the actual arg count does not match." + [nom classname fields] + (let [fn-name (symbol (str '-> nom)) + [field-args over] (split-at 20 fields) + field-count (count fields) + arg-count (count field-args) + over-count (count over) + docstring (str "Positional factory function for class " classname ".")] + `(defn ~fn-name + ~docstring + [~@field-args ~@(if (seq over) '[& overage] [])] + ~(if (seq over) + `(if (= (count ~'overage) ~over-count) + (new ~classname + ~@field-args + ~@(for [i (range 0 (count over))] + (list `nth 'overage i))) + (throw (clojure.lang.ArityException. (+ ~arg-count (count ~'overage)) (name '~fn-name)))) + `(new ~classname ~@field-args))))) + +(defn- validate-fields + "" + [fields] + (when-not (vector? fields) + (throw (Exception. "No fields vector given."))) ;;; AssertionError. + (let [specials #{'__meta '__extmap}] + (when (some specials fields) + (throw (Exception. (str "The names in " specials " cannot be used as field names for types or records.")))))) ;;; AssertionError. (defmacro defrecord "(defrecord name [fields*] options* specs*) @@ -320,16 +320,16 @@ protocol-or-interface-or-Object (methodName [args*] body)* - Dynamically generates compiled bytecode for class with the given - name, in a package with the same name as the current namespace, the - given fields, and, optionally, methods for protocols and/or + Dynamically generates compiled bytecode for class with the given + name, in a package with the same name as the current namespace, the + given fields, and, optionally, methods for protocols and/or interfaces. - The class will have the (immutable) fields named by - fields, which can have type hints. Protocols/interfaces and methods - are optional. The only methods that can be supplied are those - declared in the protocols/interfaces. Note that method bodies are - not closures, the local environment includes only the named fields, + The class will have the (immutable) fields named by + fields, which can have type hints. Protocols/interfaces and methods + are optional. The only methods that can be supplied are those + declared in the protocols/interfaces. Note that method bodies are + not closures, the local environment includes only the named fields, and those fields can be accessed directly. Method definitions take the form: @@ -342,22 +342,22 @@ Methods should be supplied for all methods of the desired protocol(s) and interface(s). You can also define overrides for - methods of Object. Note that a parameter must be supplied to - correspond to the target object ('this' in Java parlance). Thus - methods for interfaces will take one more argument than do the - interface declarations. Note also that recur calls to the method - head should *not* pass the target object, it will be supplied + methods of Object. Note that a parameter must be supplied to + correspond to the target object ('this' in Java parlance). Thus + methods for interfaces will take one more argument than do the + interface declarations. Note also that recur calls to the method + head should *not* pass the target object, it will be supplied automatically and can not be substituted. In the method bodies, the (unqualified) name can be used to name the class (for calls to new, instance? etc). - The class will have implementations of several (clojure.lang) - interfaces generated automatically: IObj (metadata support) and + The class will have implementations of several (clojure.lang) + interfaces generated automatically: IObj (metadata support) and IPersistentMap, and all of their superinterfaces. - In addition, defrecord will define type-and-value-based =, - and will defined Java .hashCode and .equals consistent with the + In addition, defrecord will define type-and-value-based =, + and will defined Java .hashCode and .equals consistent with the contract for java.util.Map. When AOT compiling, generates compiled bytecode for a class with the @@ -367,14 +367,14 @@ Two constructors will be defined, one taking the designated fields followed by a metadata map (nil for none) and an extension field map (nil for none), and one taking only the fields (using nil for - meta and extension fields). Note that the field names __meta - and __extmap are currently reserved and should not be used when - defining your own records. - - Given (defrecord TypeName ...), two factory functions will be - defined: ->TypeName, taking positional parameters for the fields, + meta and extension fields). Note that the field names __meta + and __extmap are currently reserved and should not be used when + defining your own records. + + Given (defrecord TypeName ...), two factory functions will be + defined: ->TypeName, taking positional parameters for the fields, and map->TypeName, taking a map of keywords to field values." - {:added "1.2" + {:added "1.2" :arglists '([name [& fields] & opts+specs])} [name fields & opts+specs] @@ -385,166 +385,255 @@ hinted-fields fields fields (vec (map #(with-meta % nil) fields))] `(let [] - (declare ~(symbol (str '-> gname))) - (declare ~(symbol (str 'map-> gname))) - ~(emit-defrecord name gname (vec hinted-fields) (vec interfaces) methods) - (import ~classname) - ~(build-positional-factory gname classname fields) + (declare ~(symbol (str '-> gname))) + (declare ~(symbol (str 'map-> gname))) + ~(emit-defrecord name gname (vec hinted-fields) (vec interfaces) methods) + (import ~classname) + ~(build-positional-factory gname classname fields) (defn ~(symbol (str 'map-> gname)) ~(str "Factory function for class " classname ", taking a map of keywords to field values.") - ([m#] (~(symbol (str classname "/create")) m#))) + ([m#] (~(symbol (str classname "/create")) m#))) ~classname))) -(defn record? - "Returns true if x is a record" - {:added "1.6" - :static true} - [x] - (instance? clojure.lang.IRecord x)) - - (defn- emit-deftype* - "Do not use this directly - use deftype" - [tagname name fields interfaces methods] - (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name)) - interfaces (conj interfaces 'clojure.lang.IType)] - `(deftype* ~tagname ~classname ~fields - :implements ~interfaces - ~@methods))) - -(defmacro deftype - "(deftype name [fields*] options* specs*) - - Currently there are no options. - - Each spec consists of a protocol or interface name followed by zero - or more method bodies: - - protocol-or-interface-or-Object - (methodName [args*] body)* - - Dynamically generates compiled bytecode for class with the given - name, in a package with the same name as the current namespace, the - given fields, and, optionally, methods for protocols and/or - interfaces. - - The class will have the (by default, immutable) fields named by - fields, which can have type hints. Protocols/interfaces and methods - are optional. The only methods that can be supplied are those - declared in the protocols/interfaces. Note that method bodies are - not closures, the local environment includes only the named fields, - and those fields can be accessed directy. Fields can be qualified - with the metadata :volatile-mutable true or :unsynchronized-mutable - true, at which point (set! afield aval) will be supported in method - bodies. Note well that mutable fields are extremely difficult to use - correctly, and are present only to facilitate the building of higher - level constructs, such as Clojure's reference types, in Clojure - itself. They are for experts only - if the semantics and - implications of :volatile-mutable or :unsynchronized-mutable are not - immediately apparent to you, you should not be using them. - - Method definitions take the form: - - (methodname [args*] body) - - The argument and return types can be hinted on the arg and - methodname symbols. If not supplied, they will be inferred, so type - hints should be reserved for disambiguation. - - Methods should be supplied for all methods of the desired - protocol(s) and interface(s). You can also define overrides for - methods of Object. Note that a parameter must be supplied to - correspond to the target object ('this' in Java parlance). Thus - methods for interfaces will take one more argument than do the - interface declarations. Note also that recur calls to the method - head should *not* pass the target object, it will be supplied - automatically and can not be substituted. - - In the method bodies, the (unqualified) name can be used to name the - class (for calls to new, instance? etc). - - When AOT compiling, generates compiled bytecode for a class with the - given name (a symbol), prepends the current ns as the package, and - writes the .class file to the *compile-path* directory. - - One constructor will be defined, taking the designated fields. Note - that the field names __meta and __extmap are currently reserved and - should not be used when defining your own types. - - Given (deftype TypeName ...), a factory function called ->TypeName +(defn record? + "Returns true if x is a record" + {:added "1.6" + :static true} + [x] + (instance? clojure.lang.IRecord x)) + +(defn- emit-deftype* + "Do not use this directly - use deftype" + [tagname name fields interfaces methods] + (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name)) + interfaces (conj interfaces 'clojure.lang.IType)] + `(deftype* ~tagname ~classname ~fields + :implements ~interfaces + ~@methods))) + +(defn- emit-other-deftype* + "Do not use this directly - use other-deftype" + [tagname name fields interfaces methods] + (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name)) + interfaces (conj interfaces 'clojure.lang.IType)] + `(other-deftype* ~tagname ~classname ~fields + :implements ~interfaces + ~@methods))) + +(defmacro other-deftype + "(other-deftype name [fields*] options* specs*) + + Currently there are no options. + + Each spec consists of a protocol or interface name followed by zero + or more method bodies: + + protocol-or-interface-or-Object + (methodName [args*] body)* + + Dynamically generates compiled bytecode for class with the given + name, in a package with the same name as the current namespace, the + given fields, and, optionally, methods for protocols and/or + interfaces. + + The class will have the (by default, immutable) fields named by + fields, which can have type hints. Protocols/interfaces and methods + are optional. The only methods that can be supplied are those + declared in the protocols/interfaces. Note that method bodies are + not closures, the local environment includes only the named fields, + and those fields can be accessed directy. Fields can be qualified + with the metadata :volatile-mutable true or :unsynchronized-mutable + true, at which point (set! afield aval) will be supported in method + bodies. Note well that mutable fields are extremely difficult to use + correctly, and are present only to facilitate the building of higher + level constructs, such as Clojure's reference types, in Clojure + itself. They are for experts only - if the semantics and + implications of :volatile-mutable or :unsynchronized-mutable are not + immediately apparent to you, you should not be using them. + + Method definitions take the form: + + (methodname [args*] body) + + The argument and return types can be hinted on the arg and + methodname symbols. If not supplied, they will be inferred, so type + hints should be reserved for disambiguation. + + Methods should be supplied for all methods of the desired + protocol(s) and interface(s). You can also define overrides for + methods of Object. Note that a parameter must be supplied to + correspond to the target object ('this' in Java parlance). Thus + methods for interfaces will take one more argument than do the + interface declarations. Note also that recur calls to the method + head should *not* pass the target object, it will be supplied + automatically and can not be substituted. + + In the method bodies, the (unqualified) name can be used to name the + class (for calls to new, instance? etc). + + When AOT compiling, generates compiled bytecode for a class with the + given name (a symbol), prepends the current ns as the package, and + writes the .class file to the *compile-path* directory. + + One constructor will be defined, taking the designated fields. Note + that the field names __meta and __extmap are currently reserved and + should not be used when defining your own types. + + Given (other-deftype TypeName ...), a factory function called ->TypeName + will be defined, taking positional parameters for the fields" + {:added "1.2" + :arglists '([name [& fields] & opts+specs])} + + [name fields & opts+specs] + (validate-fields fields) + (let [gname name + [interfaces methods opts] (parse-opts+specs opts+specs) + ns-part (namespace-munge *ns*) + classname (symbol (str ns-part "." gname)) + hinted-fields fields + fields (vec (map #(with-meta % nil) fields)) + [field-args over] (split-at 20 fields)] + `(let [] + ~(emit-other-deftype* name gname (vec hinted-fields) (vec interfaces) methods) + (import ~classname) + ~(build-positional-factory gname classname fields) + ~classname))) + + +(defmacro deftype + "(deftype name [fields*] options* specs*) + + Currently there are no options. + + Each spec consists of a protocol or interface name followed by zero + or more method bodies: + + protocol-or-interface-or-Object + (methodName [args*] body)* + + Dynamically generates compiled bytecode for class with the given + name, in a package with the same name as the current namespace, the + given fields, and, optionally, methods for protocols and/or + interfaces. + + The class will have the (by default, immutable) fields named by + fields, which can have type hints. Protocols/interfaces and methods + are optional. The only methods that can be supplied are those + declared in the protocols/interfaces. Note that method bodies are + not closures, the local environment includes only the named fields, + and those fields can be accessed directy. Fields can be qualified + with the metadata :volatile-mutable true or :unsynchronized-mutable + true, at which point (set! afield aval) will be supported in method + bodies. Note well that mutable fields are extremely difficult to use + correctly, and are present only to facilitate the building of higher + level constructs, such as Clojure's reference types, in Clojure + itself. They are for experts only - if the semantics and + implications of :volatile-mutable or :unsynchronized-mutable are not + immediately apparent to you, you should not be using them. + + Method definitions take the form: + + (methodname [args*] body) + + The argument and return types can be hinted on the arg and + methodname symbols. If not supplied, they will be inferred, so type + hints should be reserved for disambiguation. + + Methods should be supplied for all methods of the desired + protocol(s) and interface(s). You can also define overrides for + methods of Object. Note that a parameter must be supplied to + correspond to the target object ('this' in Java parlance). Thus + methods for interfaces will take one more argument than do the + interface declarations. Note also that recur calls to the method + head should *not* pass the target object, it will be supplied + automatically and can not be substituted. + + In the method bodies, the (unqualified) name can be used to name the + class (for calls to new, instance? etc). + + When AOT compiling, generates compiled bytecode for a class with the + given name (a symbol), prepends the current ns as the package, and + writes the .class file to the *compile-path* directory. + + One constructor will be defined, taking the designated fields. Note + that the field names __meta and __extmap are currently reserved and + should not be used when defining your own types. + + Given (deftype TypeName ...), a factory function called ->TypeName will be defined, taking positional parameters for the fields" - {:added "1.2" + {:added "1.2" :arglists '([name [& fields] & opts+specs])} - - [name fields & opts+specs] - (validate-fields fields) - (let [gname name - [interfaces methods opts] (parse-opts+specs opts+specs) - ns-part (namespace-munge *ns*) - classname (symbol (str ns-part "." gname)) - hinted-fields fields - fields (vec (map #(with-meta % nil) fields)) - [field-args over] (split-at 20 fields)] - `(let [] - ~(emit-deftype* name gname (vec hinted-fields) (vec interfaces) methods) - (import ~classname) - ~(build-positional-factory gname classname fields) - ~classname))) - + + [name fields & opts+specs] + (validate-fields fields) + (let [gname name + [interfaces methods opts] (parse-opts+specs opts+specs) + ns-part (namespace-munge *ns*) + classname (symbol (str ns-part "." gname)) + hinted-fields fields + fields (vec (map #(with-meta % nil) fields)) + [field-args over] (split-at 20 fields)] + `(let [] + ~(emit-deftype* name gname (vec hinted-fields) (vec interfaces) methods) + (import ~classname) + ~(build-positional-factory gname classname fields) + ~classname))) + ;;;;;;;;;;;;;;;;;;;;;;; protocols ;;;;;;;;;;;;;;;;;;;;;;;; (defn- expand-method-impl-cache [^clojure.lang.MethodImplCache cache c f] (if (.map cache) - (let [cs (assoc (.map cache) c (clojure.lang.MethodImplCache+Entry. c f))] ;;; clojure.lang.MethodImplCache$Entry + (let [cs (assoc (.map cache) c (clojure.lang.MethodImplCache+Entry. c f))] ;;; clojure.lang.MethodImplCache$Entry (clojure.lang.MethodImplCache. (.protocol cache) (.methodk cache) cs)) - (let [cs (into1 {} (remove (fn [[c e]] (nil? e)) (map vec (partition 2 (.table cache))))) - cs (assoc cs c (clojure.lang.MethodImplCache+Entry. c f))] ;;; clojure.lang.MethodImplCache$Entry - (if-let [[shift mask] (maybe-min-hash (map hash (keys cs)))] - (let [table (make-array Object (* 2 (inc mask))) - table (reduce1 (fn [^objects t [c e]] - (let [i (* 2 (int (shift-mask shift mask (hash c))))] - (aset t i c) - (aset t (inc i) e) - t)) - table cs)] - (clojure.lang.MethodImplCache. (.protocol cache) (.methodk cache) shift mask table)) + (let [cs (into1 {} (remove (fn [[c e]] (nil? e)) (map vec (partition 2 (.table cache))))) + cs (assoc cs c (clojure.lang.MethodImplCache+Entry. c f))] ;;; clojure.lang.MethodImplCache$Entry + (if-let [[shift mask] (maybe-min-hash (map hash (keys cs)))] + (let [table (make-array Object (* 2 (inc mask))) + table (reduce1 (fn [^objects t [c e]] + (let [i (* 2 (int (shift-mask shift mask (hash c))))] + (aset t i c) + (aset t (inc i) e) + t)) + table cs)] + (clojure.lang.MethodImplCache. (.protocol cache) (.methodk cache) shift mask table)) (clojure.lang.MethodImplCache. (.protocol cache) (.methodk cache) cs))))) (defn- super-chain [^Type c] ;;; Class (when c (cons c (super-chain (.BaseType c))))) ;;; getSuperclass -(defn- pref - ([] nil) - ([a] a) - ([^Type a ^Type b] ;;; Class - (if (.IsAssignableFrom a b) b a))) ;;; isAssignableFrom +(defn- pref + ([] nil) + ([a] a) + ([^Type a ^Type b] ;;; Class + (if (.IsAssignableFrom a b) b a))) ;;; isAssignableFrom (defn find-protocol-impl [protocol x] (if (instance? (:on-interface protocol) x) x - (let [c (class x) - impl #(get (:impls protocol) %)] - (or (impl c) - (and c (or (first (remove nil? (map impl (butlast (super-chain c))))) - (when-let [t (reduce1 pref (filter impl (disj (supers c) Object)))] + (let [c (class x) + impl #(get (:impls protocol) %)] + (or (impl c) + (and c (or (first (remove nil? (map impl (butlast (super-chain c))))) + (when-let [t (reduce1 pref (filter impl (disj (supers c) Object)))] (impl t)) (impl Object))))))) (defn find-protocol-method [protocol methodk x] (get (find-protocol-impl protocol x) methodk)) -(defn- protocol? - [maybe-p] - (boolean (:on-interface maybe-p))) +(defn- protocol? + [maybe-p] + (boolean (:on-interface maybe-p))) -(defn- implements? [protocol atype] - (and atype (.IsAssignableFrom ^Type (:on-interface protocol) atype))) ;;; isAssignableFrom, Class +(defn- implements? [protocol atype] + (and atype (.IsAssignableFrom ^Type (:on-interface protocol) atype))) ;;; isAssignableFrom, Class (defn extends? "Returns true if atype extends protocol" {:added "1.2"} [protocol atype] - (boolean (or (implements? protocol atype) + (boolean (or (implements? protocol atype) (get (:impls protocol) atype)))) (defn extenders @@ -561,8 +650,8 @@ (defn -cache-protocol-fn [^clojure.lang.AFunction pf x ^Type c ^clojure.lang.IFn interf] ;;; Class (let [cache (.__methodImplCache pf) ;;; isInstance - f (if (.IsInstanceOfType c x) - interf + f (if (.IsInstanceOfType c x) + interf (find-protocol-method (.protocol cache) (.methodk cache) x))] (when-not f (throw (ArgumentException. (str "No implementation of method: " (.methodk cache) ;;; IllegalArgumentException @@ -573,18 +662,18 @@ (defn- emit-method-builder [on-interface method on-method arglists] (let [methodk (keyword method) - gthis (with-meta (gensym) {:tag 'clojure.lang.AFunction}) + gthis (with-meta (gensym) {:tag 'clojure.lang.AFunction}) ginterf (gensym)] `(fn [cache#] - (let [~ginterf - (fn - ~@(map - (fn [args] - (let [gargs (map #(gensym (str "gf__" % "__")) args) - target (first gargs)] - `([~@gargs] - (. ~(with-meta target {:tag on-interface}) (~(or on-method method) ~@(rest gargs)))))) - arglists)) + (let [~ginterf + (fn + ~@(map + (fn [args] + (let [gargs (map #(gensym (str "gf__" % "__")) args) + target (first gargs)] + `([~@gargs] + (. ~(with-meta target {:tag on-interface}) (~(or on-method method) ~@(rest gargs)))))) + arglists)) ^clojure.lang.AFunction f# (fn ~gthis ~@(map @@ -592,10 +681,10 @@ (let [gargs (map #(gensym (str "gf__" % "__")) args) target (first gargs)] `([~@gargs] - (let [cache# (.__methodImplCache ~gthis) - f# (.fnFor cache# (clojure.lang.Util/classOf ~target))] - (if f# - (f# ~@gargs) + (let [cache# (.__methodImplCache ~gthis) + f# (.fnFor cache# (clojure.lang.Util/classOf ~target))] + (if f# + (f# ~@gargs) ((-cache-protocol-fn ~gthis ~target ~on-interface ~ginterf) ~@gargs)))))) arglists))] (set! (.__methodImplCache f#) cache#) @@ -625,24 +714,24 @@ string? (recur (assoc opts :doc (first sigs)) (next sigs)) keyword? (recur (assoc opts (first sigs) (second sigs)) (nnext sigs)) [opts sigs])) - sigs (when sigs - (reduce1 (fn [m s] - (let [name-meta (meta (first s)) - mname (with-meta (first s) nil) - [arglists doc] - (loop [as [] rs (rest s)] - (if (vector? (first rs)) - (recur (conj as (first rs)) (next rs)) - [(seq as) (first rs)]))] - (when (some #{0} (map count arglists)) - (throw (ArgumentException. (str "Definition of function " mname " in protocol " name " must take at least one arg.")))) ;;; IllegalArgumentException - (when (m (keyword mname)) - (throw (ArgumentException. (str "Function " mname " in protocol " name " was redefined. Specify all arities in single definition.")))) ;;; IllegalArgumentException - (assoc m (keyword mname) - (merge name-meta - {:name (vary-meta mname assoc :doc doc :arglists arglists) - :arglists arglists - :doc doc})))) + sigs (when sigs + (reduce1 (fn [m s] + (let [name-meta (meta (first s)) + mname (with-meta (first s) nil) + [arglists doc] + (loop [as [] rs (rest s)] + (if (vector? (first rs)) + (recur (conj as (first rs)) (next rs)) + [(seq as) (first rs)]))] + (when (some #{0} (map count arglists)) + (throw (ArgumentException. (str "Definition of function " mname " in protocol " name " must take at least one arg.")))) ;;; IllegalArgumentException + (when (m (keyword mname)) + (throw (ArgumentException. (str "Function " mname " in protocol " name " was redefined. Specify all arities in single definition.")))) ;;; IllegalArgumentException + (assoc m (keyword mname) + (merge name-meta + {:name (vary-meta mname assoc :doc doc :arglists arglists) + :arglists arglists + :doc doc})))) {} sigs)) meths (mapcat (fn [sig] (let [m (munge (:name sig))] @@ -668,7 +757,7 @@ :method-builders ~(apply hash-map (mapcat - (fn [s] + (fn [s] [`(intern *ns* (with-meta '~(:name s) (merge '~s {:protocol (var ~name)}))) (emit-method-builder (:on-interface opts) (:name s) (:on s) (:arglists s))]) (vals sigs))))) @@ -690,10 +779,10 @@ protocol overall and for each method. The above yields a set of polymorphic functions and a protocol object. All are namespace-qualified by the ns enclosing the definition The resulting - functions dispatch on the type of their first argument, which is - required and corresponds to the implicit target object ('this' in - Java parlance). defprotocol is dynamic, has no special compile-time - effect, and defines no new types or classes. Implementations of + functions dispatch on the type of their first argument, which is + required and corresponds to the implicit target object ('this' in + Java parlance). defprotocol is dynamic, has no special compile-time + effect, and defines no new types or classes. Implementations of the protocol methods can be provided using extend. defprotocol will automatically generate a corresponding interface, @@ -767,12 +856,12 @@ {:added "1.2"} [atype & proto+mmaps] (doseq [[proto mmap] (partition 2 proto+mmaps)] - (when-not (protocol? proto) - (throw (ArgumentException. ;;; IllegalArgumentException - (str proto " is not a protocol")))) - (when (implements? proto atype) - (throw (ArgumentException. ;;; IllegalArgumentException - (str atype " already directly implements " (:on-interface proto) " for protocol:" + (when-not (protocol? proto) + (throw (ArgumentException. ;;; IllegalArgumentException + (str proto " is not a protocol")))) + (when (implements? proto atype) + (throw (ArgumentException. ;;; IllegalArgumentException + (str atype " already directly implements " (:on-interface proto) " for protocol:" (:var proto))))) (-reset-methods (alter-var-root (:var proto) assoc-in [:impls atype] mmap)))) @@ -800,7 +889,7 @@ (defmacro extend-type "A macro that expands into an extend call. Useful when you are supplying the definitions explicitly inline, extend-type - automatically creates the maps required by extend. Propagates the + automatically creates the maps required by extend. Propagates the class as a type hint on the first argument of all fns. (extend-type MyType @@ -867,4 +956,4 @@ {:added "1.2"} [p & specs] - (emit-extend-protocol p specs)) \ No newline at end of file + (emit-extend-protocol p specs)) diff --git a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs index d38c25b98..48b0f832a 100644 --- a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs @@ -1,36 +1,4 @@ /** - * Copyright (c) Rich Hickey. All rights reserved. - * The use and distribution terms for this software are covered by the - * Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) - * which can be found in the file epl-v10.html at the root of this distribution. - * By using this software in any fashion, you are agreeing to be bound by - * the terms of this license. - * You must not remove this notice, or any other, from this software. - **/ - -/** - * Author: David Miller - **/ - -using System; -using System.Collections.Generic; -using System.Reflection; -using System.Reflection.Emit; -using System.Runtime.CompilerServices; -using Microsoft.Scripting.Generation; - -namespace clojure.lang.CljCompiler.Ast -{ - sealed class OtherNewInstanceExpr : ObjExpr - { - #region Data - - Dictionary> _methodMap; - - #endregion - - #region C-tors -/** * Copyright (c) Rich Hickey. All rights reserved. * The use and distribution terms for this software are covered by the * Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) @@ -72,7 +40,7 @@ public OtherNewInstanceExpr(object tag) #region Parsing - public sealed class DefTypeParser : IParser + public sealed class OtherDefTypeParser : IParser { public Expr Parse(ParserContext pcon, object frm) { @@ -541,477 +509,4 @@ private static void EmitDummyMethod(TypeBuilder tb, MethodInfo mi) } } - public OtherNewInstanceExpr(object tag) - : base(tag) - { - } - - #endregion - - #region Parsing - - public sealed class DefTypeParser : IParser - { - public Expr Parse(ParserContext pcon, object frm) - { - // frm is: (deftype* tagname classname [fields] :implements [interfaces] :tag tagname methods*) - - ISeq rform = (ISeq)frm; - rform = RT.next(rform); - - string tagname = ((Symbol)rform.first()).ToString(); - rform = rform.next(); - Symbol classname = (Symbol)rform.first(); - rform = rform.next(); - IPersistentVector fields = (IPersistentVector)rform.first(); - rform = rform.next(); - IPersistentMap opts = PersistentHashMap.EMPTY; - while (rform != null && rform.first() is Keyword) - { - opts = opts.assoc(rform.first(), RT.second(rform)); - rform = rform.next().next(); - } - - ObjExpr ret = Build((IPersistentVector)RT.get(opts, Compiler.ImplementsKeyword, PersistentVector.EMPTY), fields, null, tagname, classname, - (Symbol)RT.get(opts, RT.TagKey), rform, frm); - - return ret; - } - } - - - public sealed class ReifyParser : IParser - { - public Expr Parse(ParserContext pcon, object frm) - { - // frm is: (reify this-name? [interfaces] (method-name [args] body)* ) - ISeq form = (ISeq)frm; - ObjMethod enclosingMethod = (ObjMethod)Compiler.MethodVar.deref(); - string baseName = enclosingMethod != null - ? (ObjExpr.TrimGenId(enclosingMethod.Objx.Name) + "$") - : (Compiler.munge(Compiler.CurrentNamespace.Name.Name) + "$"); - string simpleName = "reify__" + RT.nextID(); - string className = baseName + simpleName; - - ISeq rform = RT.next(form); - - IPersistentVector interfaces = ((IPersistentVector)RT.first(rform)).cons(Symbol.intern("clojure.lang.IObj")); - - rform = RT.next(rform); - - ObjExpr ret = Build(interfaces, null, null, className, Symbol.intern(className), null, rform,frm); - IObj iobj = frm as IObj; - - if (iobj != null && iobj.meta() != null) - return new MetaExpr(ret, MapExpr.Parse(pcon.EvalOrExpr(),iobj.meta())); - else - return ret; - } - } - - internal static ObjExpr Build( - IPersistentVector interfaceSyms, - IPersistentVector fieldSyms, - Symbol thisSym, - string tagName, - Symbol className, - Symbol typeTag, - ISeq methodForms, - Object frm) - { - OtherNewInstanceExpr ret = new OtherNewInstanceExpr(null); - ret._src = frm; - ret._name = className.ToString(); - ret._classMeta = GenInterface.ExtractAttributes(RT.meta(className)); - ret.InternalName = ret._name; // ret.Name.Replace('.', '/'); - // Java: ret.objtype = Type.getObjectType(ret.internalName); - - if (thisSym != null) - ret._thisName = thisSym.Name; - - if (fieldSyms != null) - { - IPersistentMap fmap = PersistentHashMap.EMPTY; - object[] closesvec = new object[2 * fieldSyms.count()]; - for (int i = 0; i < fieldSyms.count(); i++) - { - Symbol sym = (Symbol)fieldSyms.nth(i); - LocalBinding lb = new LocalBinding(-1, sym, null, new MethodParamExpr(Compiler.TagType(Compiler.TagOf(sym))), false, false, false); - fmap = fmap.assoc(sym, lb); - closesvec[i * 2] = lb; - closesvec[i * 2 + 1] = lb; - } - // Java TODO: inject __meta et al into closes - when? - // use array map to preserve ctor order - ret.Closes = new PersistentArrayMap(closesvec); - ret.Fields = fmap; - for (int i = fieldSyms.count() - 1; i >= 0 && (((Symbol)fieldSyms.nth(i)).Name.Equals("__meta") || ((Symbol)fieldSyms.nth(i)).Name.Equals("__extmap")); --i) - ret._altCtorDrops++; - } - - // Java TODO: set up volatiles - //ret._volatiles = PersistentHashSet.create(RT.seq(RT.get(ret._optionsMap, volatileKey))); - - IPersistentVector interfaces = PersistentVector.EMPTY; - for (ISeq s = RT.seq(interfaceSyms); s != null; s = s.next()) - { - Type t = (Type)Compiler.Resolve((Symbol)s.first()); - if (!t.IsInterface) - throw new ParseException("only interfaces are supported, had: " + t.Name); - interfaces = interfaces.cons(t); - } - // Type superClass = typeof(Object); - - Dictionary> overrideables; - GatherMethods(superClass, RT.seq(interfaces), out overrideables); - - ret._methodMap = overrideables; - - - GenContext context = Compiler.IsCompiling - ? Compiler.CompilerContextVar.get() as GenContext - : (ret.IsDefType - ? GenContext.CreateWithExternalAssembly("deftype" + RT.nextID().ToString(), ".dll", true) - : (Compiler.CompilerContextVar.get() as GenContext - ?? - Compiler.EvalContext)); - - GenContext genC = context.WithNewDynInitHelper(ret.InternalName + "__dynInitHelper_" + RT.nextID().ToString()); - - Type stub = CompileStub(genC, superClass, ret, SeqToTypeArray(interfaces), frm); - Symbol thisTag = Symbol.intern(null, stub.FullName); - //Symbol stubTag = Symbol.intern(null,stub.FullName); - //Symbol thisTag = Symbol.intern(null, tagName); - - - try - { - Var.pushThreadBindings( - RT.mapUniqueKeys( - Compiler.ConstantsVar, PersistentVector.EMPTY, - Compiler.ConstantIdsVar, new IdentityHashMap(), - Compiler.KeywordsVar, PersistentHashMap.EMPTY, - Compiler.VarsVar, PersistentHashMap.EMPTY, - Compiler.KeywordCallsitesVar, PersistentVector.EMPTY, - Compiler.ProtocolCallsitesVar, PersistentVector.EMPTY, - Compiler.VarCallsitesVar, Compiler.EmptyVarCallSites(), - Compiler.NoRecurVar, null, - Compiler.CompilerContextVar, genC - )); - - if (ret.IsDefType) - { - Var.pushThreadBindings( - RT.mapUniqueKeys( - Compiler.MethodVar, null, - Compiler.LocalEnvVar, ret.Fields, - Compiler.CompileStubSymVar, Symbol.intern(null, tagName), - Compiler.CompileStubClassVar, stub - )); - ret._hintedFields = RT.subvec(fieldSyms, 0, fieldSyms.count() - ret._altCtorDrops); - } - // now (methodname [args] body)* - - ret.SpanMap = (IPersistentMap)Compiler.SourceSpanVar.deref(); - - IPersistentCollection methods = null; - for (ISeq s = methodForms; s != null; s = RT.next(s)) - { - NewInstanceMethod m = NewInstanceMethod.Parse(ret, (ISeq)RT.first(s), thisTag, overrideables); - methods = RT.conj(methods, m); - } - - ret._methods = methods; - ret.Keywords = (IPersistentMap)Compiler.KeywordsVar.deref(); - ret.Vars = (IPersistentMap)Compiler.VarsVar.deref(); - ret.Constants = (PersistentVector)Compiler.ConstantsVar.deref(); - ret._constantsID = RT.nextID(); - ret.KeywordCallsites = (IPersistentVector)Compiler.KeywordCallsitesVar.deref(); - ret.ProtocolCallsites = (IPersistentVector)Compiler.ProtocolCallsitesVar.deref(); - ret.VarCallsites = (IPersistentSet)Compiler.VarCallsitesVar.deref(); - } - finally - { - if (ret.IsDefType) - Var.popThreadBindings(); - Var.popThreadBindings(); - } - - // TOD: Really, the first stub here should be 'superclass' but can't handle hostexprs nested in method bodies -- reify method compilation takes place before this sucker is compiled, so can't replace the call. - // Might be able to flag stub classes and not try to convert, leading to a dynsite. - - //if (RT.CompileDLR) - ret.Compile(stub, stub, interfaces, false, genC); - //else - // ret.CompileNoDlr(stub, stub, interfaces, false, genC); - - Compiler.RegisterDuplicateType(ret.CompiledType); - - return ret; - } - - private static Type[] SeqToTypeArray(IPersistentVector interfaces) - { - Type[] types = new Type[interfaces.count()]; - for (int i = 0; i < interfaces.count(); i++) - types[i] = (Type)interfaces.nth(i); - - return types; - } - - /*** - * Current host interop uses reflection, which requires pre-existing classes - * Work around this by: - * Generate a stub class that has the same interfaces and fields as the class we are generating. - * Use it as a type hint for this, and bind the simple name of the class to this stub (in resolve etc) - * Unmunge the name (using a magic prefix) on any code gen for classes - */ - - // TODO: Preparse method heads to pick up signatures, implement those methods as abstract or as NotImpelmented so that Reflection can pick up calls during compilation and avoide a callsite. - static Type CompileStub(GenContext context, Type super, OtherNewInstanceExpr ret, Type[] interfaces, Object frm) - { - TypeBuilder tb = context.ModuleBuilder.DefineType(Compiler.CompileStubPrefix + "." + ret.InternalName + RT.nextID(), TypeAttributes.Public | TypeAttributes.Abstract, super, interfaces); - - tb.DefineDefaultConstructor(MethodAttributes.Public); - - // instance fields for closed-overs - for (ISeq s = RT.keys(ret.Closes); s != null; s = s.next()) - { - LocalBinding lb = (LocalBinding)s.first(); - FieldAttributes access = FieldAttributes.Public; - - if (!ret.IsMutable(lb)) - access |= FieldAttributes.InitOnly; - - Type fieldType = lb.PrimitiveType ?? typeof(Object); - - if (ret.IsVolatile(lb)) - tb.DefineField(lb.Name, fieldType, new Type[] { typeof(IsVolatile) }, Type.EmptyTypes, access); - else - tb.DefineField(lb.Name, fieldType, access); - } - - // ctor that takes closed-overs and does nothing - if (ret.CtorTypes().Length > 0) - { - ConstructorBuilder cb = tb.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, ret.CtorTypes()); - CljILGen ilg = new CljILGen(cb.GetILGenerator()); - ilg.EmitLoadArg(0); - ilg.Emit(OpCodes.Call, super.GetConstructor(Type.EmptyTypes)); - ilg.Emit(OpCodes.Ret); - - - if (ret._altCtorDrops > 0) - { - Type[] ctorTypes = ret.CtorTypes(); - int newLen = ctorTypes.Length - ret._altCtorDrops; - if (newLen > 0) - { - Type[] altCtorTypes = new Type[newLen]; - for (int i = 0; i < altCtorTypes.Length; i++) - altCtorTypes[i] = ctorTypes[i]; - ConstructorBuilder cb2 = tb.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, altCtorTypes); - CljILGen ilg2 = new CljILGen(cb2.GetILGenerator()); - ilg2.EmitLoadArg(0); - for (int i = 0; i < newLen; i++) - ilg2.EmitLoadArg(i + 1); - for (int i = 0; i < ret._altCtorDrops; i++) - ilg2.EmitNull(); - ilg2.Emit(OpCodes.Call, cb); - ilg2.Emit(OpCodes.Ret); - } - } - } - - Type t = tb.CreateType(); - //Compiler.RegisterDuplicateType(t); - return t; - } - - - - static string[] InterfaceNames(IPersistentVector interfaces) - { - int icnt = interfaces.count(); - string[] inames = icnt > 0 ? new string[icnt] : null; - for (int i = 0; i < icnt; i++) - inames[i] = SlashName((Type)interfaces.nth(i)); - return inames; - } - - - static string SlashName(Type t) - { - return t.FullName.Replace(',', '/'); - } - - - #endregion - - #region Method reflection - - static void GatherMethods( - Type st, - ISeq interfaces, - out Dictionary> overrides) - { - Dictionary> allm = new Dictionary>(); - GatherMethods(st, allm); - for (; interfaces != null; interfaces = interfaces.next()) - GatherMethods((Type)interfaces.first(), allm); - - overrides = allm; - } - - static void GatherMethods(Type t, Dictionary> mm) - { - for (Type mt = t; mt != null; mt = mt.BaseType) - foreach (MethodInfo m in mt.GetMethods(BindingFlags.FlattenHierarchy | BindingFlags.Instance | BindingFlags.Public | BindingFlags.NonPublic)) - ConsiderMethod(m, mm); - - if (t.IsInterface) - foreach (Type it in t.GetInterfaces()) - GatherMethods(it, mm); - } - - static void ConsiderMethod(MethodInfo m, Dictionary> mm) - { - IPersistentVector mk = MSig(m); - if (!(mm.ContainsKey(mk) - || !(m.IsPublic || m.IsProtected()) - || m.IsStatic - || m.IsFinal)) - AddMethod(mm, mk, m); - } - - public static IPersistentVector MSig(MethodInfo m) - { - return RT.vector(m.Name, RT.seq(Compiler.GetTypes(m.GetParameters())), m.ReturnType); - } - - static void AddMethod(Dictionary> mm, IPersistentVector sig, MethodInfo m) - { - List value; - if (!mm.TryGetValue(sig, out value)) - { - value = new List(); - mm[sig] = value; - } - value.Add(m); - } - - #endregion - - #region ObjExpr methods - - protected override bool SupportsMeta - { - get { return ! IsDefType; } - } - - #endregion - - #region Code generation - - private static string ExplicitMethodName(MethodInfo mi) - { - return mi.DeclaringType.Name + "." + mi.Name; - } - - protected override void EmitStatics(TypeBuilder tb) - { - if (IsDefType) - { - // getBasis() - { - MethodBuilder mbg = tb.DefineMethod("getBasis", MethodAttributes.Public | MethodAttributes.Static, typeof(IPersistentVector), Type.EmptyTypes); - CljILGen ilg = new CljILGen(mbg.GetILGenerator()); - EmitValue(_hintedFields, ilg); - ilg.Emit(OpCodes.Ret); - } - - if (Fields.count() > _hintedFields.count()) - { - // create(IPersistentMap) - MethodBuilder mbc = tb.DefineMethod("create", MethodAttributes.Public | MethodAttributes.Static, tb, new Type[] { typeof(IPersistentMap) }); - CljILGen gen = new CljILGen(mbc.GetILGenerator()); - - LocalBuilder kwLocal = gen.DeclareLocal(typeof(Keyword)); - List locals = new List(); - for (ISeq s = RT.seq(_hintedFields); s != null; s = s.next()) - { - string bName = ((Symbol)s.first()).Name; - Type t = Compiler.TagType(Compiler.TagOf(s.first())); - - // local_kw = Keyword.intern(bname) - // local_i = arg_0.valAt(kw,null) - gen.EmitLoadArg(0); - gen.EmitString(bName); - gen.EmitCall(Compiler.Method_Keyword_intern_string); - gen.Emit(OpCodes.Dup); - gen.Emit(OpCodes.Stloc, kwLocal.LocalIndex); - gen.EmitNull(); - gen.EmitCall(Compiler.Method_IPersistentMap_valAt2); - LocalBuilder lb = gen.DeclareLocal(t); - locals.Add(lb); - if (t.IsPrimitive) - gen.EmitUnbox(t); - gen.Emit(OpCodes.Stloc, lb.LocalIndex); - - // arg_0 = arg_0.without(local_kw); - gen.EmitLoadArg(0); - gen.Emit(OpCodes.Ldloc, kwLocal.LocalIndex); - gen.EmitCall(Compiler.Method_IPersistentMap_without); - gen.EmitStoreArg(0); - } - - foreach (LocalBuilder lb in locals) - gen.Emit(OpCodes.Ldloc, lb.LocalIndex); - gen.EmitNull(); - gen.EmitLoadArg(0); - gen.EmitCall(Compiler.Method_RT_seqOrElse); - gen.EmitNew(_ctorInfo); - - gen.Emit(OpCodes.Ret); - } - } - } - - protected override void EmitMethods(TypeBuilder tb) - { - HashSet implemented = new HashSet(); - - for (ISeq s = RT.seq(_methods); s != null; s = s.next()) - { - NewInstanceMethod method = (NewInstanceMethod)s.first(); - method.Emit(this, tb); - implemented.UnionWith(method.MethodInfos); - } - - foreach (List ms in _methodMap.Values) - foreach (MethodInfo mi in ms) - { - if (NeedsDummy(mi, implemented)) - EmitDummyMethod(tb, mi); - } - - EmitHasArityMethod(_typeBuilder, null, false, 0); - } - - private bool NeedsDummy(MethodInfo mi, HashSet implemented) - { - return !implemented.Contains(mi) && mi.DeclaringType.IsInterface && !(!IsDefType && mi.DeclaringType == typeof(IObj) || mi.DeclaringType == typeof(IMeta)); - } - - private static void EmitDummyMethod(TypeBuilder tb, MethodInfo mi) - { - MethodBuilder mb = tb.DefineMethod(ExplicitMethodName(mi), MethodAttributes.ReuseSlot | MethodAttributes.Public | MethodAttributes.Virtual, mi.ReturnType, Compiler.GetTypes(mi.GetParameters())); - CljILGen gen = new CljILGen(mb.GetILGenerator()); - gen.EmitNew(typeof(NotImplementedException), Type.EmptyTypes); - gen.Emit(OpCodes.Throw); - tb.DefineMethodOverride(mb, mi); - } - - #endregion - } -} + \ No newline at end of file diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index 57bd8fabf..65d027816 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -59,6 +59,7 @@ public static class Compiler public static readonly Symbol MonitorExitSym = Symbol.intern("monitor-exit"); public static readonly Symbol ImportSym = Symbol.intern("clojure.core","import*"); public static readonly Symbol DeftypeSym = Symbol.intern("deftype*"); + public static readonly Symbol OtherDeftypeSym = Symbol.intern("other-deftype*"); public static readonly Symbol CaseSym = Symbol.intern("case*"); public static readonly Symbol NewSym = Symbol.intern("new"); public static readonly Symbol ThisSym = Symbol.intern("this"); @@ -213,6 +214,7 @@ public static object ElideMeta(object m) DotSym, new HostExpr.Parser(), AssignSym, new AssignExpr.Parser(), DeftypeSym, new NewInstanceExpr.DefTypeParser(), + //OtherDeftypeSym, new OtherNewInstanceExpr.OtherDefTypeParser(), ReifySym, new NewInstanceExpr.ReifyParser(), TrySym, new TryExpr.Parser(), ThrowSym, new ThrowExpr.Parser(), @@ -1617,7 +1619,8 @@ internal static bool TryLoadInitType(string relativePath) [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "load")] public static object loadFile(string fileName) - { FileInfo finfo = new FileInfo(fileName); + { + FileInfo finfo = new FileInfo(fileName); if (!finfo.Exists) throw new FileNotFoundException("Cannot find file to load", fileName); From bb0244ef00aaa16d17b88a07d13d29de0d191bbc Mon Sep 17 00:00:00 2001 From: timsgardner Date: Sun, 27 Jul 2014 02:50:46 -0400 Subject: [PATCH 10/80] Compiling nicely for unity! use the stuff produced under dist/Debug 3.5 --- Clojure/Clojure/Clojure.csproj | 1 + 1 file changed, 1 insertion(+) diff --git a/Clojure/Clojure/Clojure.csproj b/Clojure/Clojure/Clojure.csproj index e4761e8d1..986dc368f 100644 --- a/Clojure/Clojure/Clojure.csproj +++ b/Clojure/Clojure/Clojure.csproj @@ -148,6 +148,7 @@ + From fcc198e220acc70ed10e9b67eaa132fc80e41359 Mon Sep 17 00:00:00 2001 From: timsgardner Date: Sun, 27 Jul 2014 07:09:40 -0400 Subject: [PATCH 11/80] other-deftype emiting attachable extensible MonoBehaviors on AOT --- Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs | 2 +- Clojure/Clojure/CljCompiler/Compiler.cs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs index 48b0f832a..00636fb49 100644 --- a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs @@ -152,7 +152,7 @@ internal static ObjExpr Build( } // Type superClass = typeof(Object); // here begins the jank - System.Type superClass = Type.GetType("UnityEngine.Component, UnityEngine, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null"); + System.Type superClass = Type.GetType("UnityEngine.MonoBehaviour, UnityEngine, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null"); Dictionary> overrideables; diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index 65d027816..f99be59b3 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -214,7 +214,7 @@ public static object ElideMeta(object m) DotSym, new HostExpr.Parser(), AssignSym, new AssignExpr.Parser(), DeftypeSym, new NewInstanceExpr.DefTypeParser(), - //OtherDeftypeSym, new OtherNewInstanceExpr.OtherDefTypeParser(), + OtherDeftypeSym, new OtherNewInstanceExpr.OtherDefTypeParser(), ReifySym, new NewInstanceExpr.ReifyParser(), TrySym, new TryExpr.Parser(), ThrowSym, new ThrowExpr.Parser(), From 99793ed883d6c31ba7f7f13ec1f48c10104d2ccd Mon Sep 17 00:00:00 2001 From: timsgardner Date: Wed, 6 Aug 2014 17:29:01 -0400 Subject: [PATCH 12/80] Renaming other-deftype to defscript and OtherNewInstanceExpr to NewScriptInstanceExpr --- Clojure/Clojure.Source/clojure/core_deftype.clj | 14 +++++++------- ...NewInstanceExpr.cs => NewScriptInstanceExpr.cs} | 10 +++++----- Clojure/Clojure/CljCompiler/Compiler.cs | 4 ++-- Clojure/Clojure/Clojure.csproj | 2 +- 4 files changed, 15 insertions(+), 15 deletions(-) rename Clojure/Clojure/CljCompiler/Ast/{OtherNewInstanceExpr.cs => NewScriptInstanceExpr.cs} (96%) diff --git a/Clojure/Clojure.Source/clojure/core_deftype.clj b/Clojure/Clojure.Source/clojure/core_deftype.clj index 2db30d44c..11abd81d1 100644 --- a/Clojure/Clojure.Source/clojure/core_deftype.clj +++ b/Clojure/Clojure.Source/clojure/core_deftype.clj @@ -411,17 +411,17 @@ :implements ~interfaces ~@methods))) -(defn- emit-other-deftype* - "Do not use this directly - use other-deftype" +(defn- emit-defscript* + "Do not use this directly - use defscript" [tagname name fields interfaces methods] (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name)) interfaces (conj interfaces 'clojure.lang.IType)] - `(other-deftype* ~tagname ~classname ~fields + `(defscript* ~tagname ~classname ~fields :implements ~interfaces ~@methods))) -(defmacro other-deftype - "(other-deftype name [fields*] options* specs*) +(defmacro defscript + "(defscript name [fields*] options* specs*) Currently there are no options. @@ -479,7 +479,7 @@ that the field names __meta and __extmap are currently reserved and should not be used when defining your own types. - Given (other-deftype TypeName ...), a factory function called ->TypeName + Given (defscript TypeName ...), a factory function called ->TypeName will be defined, taking positional parameters for the fields" {:added "1.2" :arglists '([name [& fields] & opts+specs])} @@ -494,7 +494,7 @@ fields (vec (map #(with-meta % nil) fields)) [field-args over] (split-at 20 fields)] `(let [] - ~(emit-other-deftype* name gname (vec hinted-fields) (vec interfaces) methods) + ~(emit-defscript* name gname (vec hinted-fields) (vec interfaces) methods) (import ~classname) ~(build-positional-factory gname classname fields) ~classname))) diff --git a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/NewScriptInstanceExpr.cs similarity index 96% rename from Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs rename to Clojure/Clojure/CljCompiler/Ast/NewScriptInstanceExpr.cs index 00636fb49..1da7160ce 100644 --- a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/NewScriptInstanceExpr.cs @@ -21,7 +21,7 @@ namespace clojure.lang.CljCompiler.Ast { - sealed class OtherNewInstanceExpr : ObjExpr + sealed class NewScriptInstanceExpr : ObjExpr { #region Data @@ -31,7 +31,7 @@ sealed class OtherNewInstanceExpr : ObjExpr #region C-tors - public OtherNewInstanceExpr(object tag) + public NewScriptInstanceExpr(object tag) : base(tag) { } @@ -40,7 +40,7 @@ public OtherNewInstanceExpr(object tag) #region Parsing - public sealed class OtherDefTypeParser : IParser + public sealed class DefscriptParser : IParser { public Expr Parse(ParserContext pcon, object frm) { @@ -109,7 +109,7 @@ internal static ObjExpr Build( ISeq methodForms, Object frm) { - OtherNewInstanceExpr ret = new OtherNewInstanceExpr(null); + NewScriptInstanceExpr ret = new NewScriptInstanceExpr(null); ret._src = frm; ret._name = className.ToString(); ret._classMeta = GenInterface.ExtractAttributes(RT.meta(className)); @@ -261,7 +261,7 @@ private static Type[] SeqToTypeArray(IPersistentVector interfaces) */ // TODO: Preparse method heads to pick up signatures, implement those methods as abstract or as NotImpelmented so that Reflection can pick up calls during compilation and avoide a callsite. - static Type CompileStub(GenContext context, Type super, OtherNewInstanceExpr ret, Type[] interfaces, Object frm) + static Type CompileStub(GenContext context, Type super, NewScriptInstanceExpr ret, Type[] interfaces, Object frm) { TypeBuilder tb = context.ModuleBuilder.DefineType(Compiler.CompileStubPrefix + "." + ret.InternalName + RT.nextID(), TypeAttributes.Public | TypeAttributes.Abstract, super, interfaces); diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index f99be59b3..47542f9e1 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -59,7 +59,7 @@ public static class Compiler public static readonly Symbol MonitorExitSym = Symbol.intern("monitor-exit"); public static readonly Symbol ImportSym = Symbol.intern("clojure.core","import*"); public static readonly Symbol DeftypeSym = Symbol.intern("deftype*"); - public static readonly Symbol OtherDeftypeSym = Symbol.intern("other-deftype*"); + public static readonly Symbol DefscriptSym = Symbol.intern("defscript*"); public static readonly Symbol CaseSym = Symbol.intern("case*"); public static readonly Symbol NewSym = Symbol.intern("new"); public static readonly Symbol ThisSym = Symbol.intern("this"); @@ -214,7 +214,7 @@ public static object ElideMeta(object m) DotSym, new HostExpr.Parser(), AssignSym, new AssignExpr.Parser(), DeftypeSym, new NewInstanceExpr.DefTypeParser(), - OtherDeftypeSym, new OtherNewInstanceExpr.OtherDefTypeParser(), + DefscriptSym, new NewScriptInstanceExpr.DefscriptParser(), ReifySym, new NewInstanceExpr.ReifyParser(), TrySym, new TryExpr.Parser(), ThrowSym, new ThrowExpr.Parser(), diff --git a/Clojure/Clojure/Clojure.csproj b/Clojure/Clojure/Clojure.csproj index 986dc368f..719923ae5 100644 --- a/Clojure/Clojure/Clojure.csproj +++ b/Clojure/Clojure/Clojure.csproj @@ -148,7 +148,7 @@ - + From 7064aa6b25c10c4db82105a241aaffbc93f1c4cc Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sat, 12 Apr 2014 16:44:49 -0400 Subject: [PATCH 13/80] Make line endings in Ref.cs Unix line endings --- Clojure/Clojure/Lib/Ref.cs | 244 ++++++++++++++++++------------------- 1 file changed, 122 insertions(+), 122 deletions(-) diff --git a/Clojure/Clojure/Lib/Ref.cs b/Clojure/Clojure/Lib/Ref.cs index be24274e7..900168a06 100644 --- a/Clojure/Clojure/Lib/Ref.cs +++ b/Clojure/Clojure/Lib/Ref.cs @@ -96,7 +96,7 @@ public TVal Next /// /// Construct a TVal, linked to a previous TVal. - /// + /// public TVal(object val, long point, TVal prior) { _val = val; @@ -109,7 +109,7 @@ public TVal(object val, long point, TVal prior) /// /// Construct a TVal, linked to itself. - /// + /// public TVal(object val, long point) { _val = val; @@ -126,7 +126,7 @@ public TVal(object val, long point) /// Set the value/point. /// /// - /// + /// public void SetValue(object val, long point) { _val = val; @@ -141,19 +141,19 @@ public void SetValue(object val, long point) #region Data /// - /// Values at points in time for this reference. + /// Values at points in time for this reference. /// TVal _tvals; /// - /// Values at points in time for this reference. - /// - internal TVal TVals - { - get { return _tvals; } - } - - /// + /// Values at points in time for this reference. + /// + internal TVal TVals + { + get { return _tvals; } + } + + /// /// Number of faults for the reference. /// readonly AtomicInteger _faults; @@ -196,8 +196,8 @@ public int MinHistory { get { return _minHistory; } set { _minHistory = value; } - } - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "set")] + } + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "set")] public Ref setMinHistory(int minHistory) { _minHistory = minHistory; @@ -210,8 +210,8 @@ public int MaxHistory { get { return _maxHistory; } set { _maxHistory = value; } - } - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "set")] + } + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "set")] public Ref setMaxHistory(int maxHistory) { _maxHistory = maxHistory; @@ -222,8 +222,8 @@ public Ref setMaxHistory(int maxHistory) /// /// Used to generate unique ids. /// - static readonly AtomicLong _ids = new AtomicLong(); - + static readonly AtomicLong _ids = new AtomicLong(); + bool _disposed = false; #endregion @@ -291,9 +291,9 @@ public Ref(object initval, IPersistentMap meta) #endregion - #region History counts - - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "get")] + #region History counts + + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "get")] public int getHistoryCount() { try @@ -337,7 +337,7 @@ public override object deref() //Console.WriteLine("Thr {0}, {1}: No-trans get => {2}", Thread.CurrentThread.ManagedThreadId,DebugStr(), ret); return ret; } - return t.DoGet(this); + return t.DoGet(this); } object currentVal() @@ -457,8 +457,8 @@ internal void SetValue(object val, long commitPoint) /// Set the value (must be in a transaction). /// /// The new value. - /// The new value. - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "set")] + /// The new value. + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "set")] public object set(object val) { return LockingTransaction.GetEx().DoSet(this, val); @@ -469,8 +469,8 @@ public object set(object val) /// /// The function to apply to the current state and additional arguments. /// Additional arguments. - /// The computed value. - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "commute")] + /// The computed value. + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "commute")] public object commute(IFn fn, ISeq args) { return LockingTransaction.GetEx().DoCommute(this, fn, args); @@ -481,18 +481,18 @@ public object commute(IFn fn, ISeq args) /// /// The function to apply to the current state and additional arguments. /// Additional arguments. - /// The computed value. - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "alter")] + /// The computed value. + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "alter")] public object alter(IFn fn, ISeq args) { LockingTransaction t = LockingTransaction.GetEx(); - return t.DoSet(this, fn.applyTo(RT.cons(t.DoGet(this), args))); + return t.DoSet(this, fn.applyTo(RT.cons(t.DoGet(this), args))); } /// /// Touch the reference. (Add to the tracking list in the current transaction.) - /// - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "touch")] + /// + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "touch")] public void touch() { LockingTransaction.GetEx().DoEnsure(this); @@ -500,10 +500,10 @@ public void touch() #endregion - #region IFn Members - - - [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "fn")] + #region IFn Members + + + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "fn")] public IFn fn() { return (IFn)deref(); @@ -666,92 +666,92 @@ public int CompareTo(Ref other) return _id.CompareTo(other._id); } - #endregion - - #region object overrides - - public override bool Equals(object obj) - { - if (ReferenceEquals(this, obj)) - return true; - - Ref r = obj as Ref; - if (r == null) - return false; - - return _id == r._id; - } - - public override int GetHashCode() - { - return _id.GetHashCode(); - } - #endregion - - #region operator overrides - - public static bool operator ==(Ref x, Ref y) - { - if (ReferenceEquals(x, y)) - return true; - - if ((object)x == null) - return false; - - return x.CompareTo(y) == 0; - } - - public static bool operator !=(Ref x, Ref y) - { - return !(x == y); - } - - public static bool operator <(Ref x, Ref y) - { - if (ReferenceEquals(x, y)) - return false; - - if ( ReferenceEquals(x,null) ) - throw new ArgumentException("Cannot compare null","x"); - - return x.CompareTo(y) < 0; - } - - public static bool operator >(Ref x, Ref y) - { - if (ReferenceEquals(x, y)) - return false; - - if ( ReferenceEquals(x,null) ) - throw new ArgumentException("Cannot compare null","x"); - - return x.CompareTo(y) > 0; - } - - #endregion - - #region IDisposable - - public void Dispose() - { - Dispose(true); - GC.SuppressFinalize(this); - } - - private void Dispose(bool disposing) - { - if (!_disposed) - { - if (disposing) - { - if ( _lock != null ) - _lock.Dispose(); - } - - _disposed = true; - } - } - - #endregion + #endregion + + #region object overrides + + public override bool Equals(object obj) + { + if (ReferenceEquals(this, obj)) + return true; + + Ref r = obj as Ref; + if (r == null) + return false; + + return _id == r._id; + } + + public override int GetHashCode() + { + return _id.GetHashCode(); + } + #endregion + + #region operator overrides + + public static bool operator ==(Ref x, Ref y) + { + if (ReferenceEquals(x, y)) + return true; + + if ((object)x == null) + return false; + + return x.CompareTo(y) == 0; + } + + public static bool operator !=(Ref x, Ref y) + { + return !(x == y); + } + + public static bool operator <(Ref x, Ref y) + { + if (ReferenceEquals(x, y)) + return false; + + if ( ReferenceEquals(x,null) ) + throw new ArgumentException("Cannot compare null","x"); + + return x.CompareTo(y) < 0; + } + + public static bool operator >(Ref x, Ref y) + { + if (ReferenceEquals(x, y)) + return false; + + if ( ReferenceEquals(x,null) ) + throw new ArgumentException("Cannot compare null","x"); + + return x.CompareTo(y) > 0; + } + + #endregion + + #region IDisposable + + public void Dispose() + { + Dispose(true); + GC.SuppressFinalize(this); + } + + private void Dispose(bool disposing) + { + if (!_disposed) + { + if (disposing) + { + if ( _lock != null ) + _lock.Dispose(); + } + + _disposed = true; + } + } + + #endregion } } From f1f7247d66dc11fed5d0372e667064a85e939731 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 13 Apr 2014 17:11:58 -0400 Subject: [PATCH 14/80] Patch RT.cs to use System.Environment.CurrentDirectory Unity sets System.AppDomain.CurrentDomain.BaseDirectory to null which causes all kinds of problems. --- Clojure/Clojure/Lib/RT.cs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Clojure/Clojure/Lib/RT.cs b/Clojure/Clojure/Lib/RT.cs index 742064bb8..057d3704f 100644 --- a/Clojure/Clojure/Lib/RT.cs +++ b/Clojure/Clojure/Lib/RT.cs @@ -3452,8 +3452,8 @@ static IEnumerable GetFindFilePaths() static IEnumerable GetFindFilePathsRaw() { - yield return System.AppDomain.CurrentDomain.BaseDirectory; - yield return Path.Combine(System.AppDomain.CurrentDomain.BaseDirectory, "bin"); + yield return System.Environment.CurrentDirectory; + yield return Path.Combine(System.Environment.CurrentDirectory, "bin"); yield return Directory.GetCurrentDirectory(); yield return Path.GetDirectoryName(typeof(RT).Assembly.Location); From 897f9f1dfba0a100009c0a615c7c9ba3459e179b Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 13 Apr 2014 17:13:05 -0400 Subject: [PATCH 15/80] Comment out any mention of ReaderWriterLockSlim Raises NotImplemented exceptions in Unity otherwise. Refs and MultiFns are broken as a result. --- Clojure/Clojure/Lib/MultiFn.cs | 34 +++++++++++++++++----------------- Clojure/Clojure/Lib/Ref.cs | 22 +++++++++++----------- 2 files changed, 28 insertions(+), 28 deletions(-) diff --git a/Clojure/Clojure/Lib/MultiFn.cs b/Clojure/Clojure/Lib/MultiFn.cs index cd791e659..7af2d9a43 100644 --- a/Clojure/Clojure/Lib/MultiFn.cs +++ b/Clojure/Clojure/Lib/MultiFn.cs @@ -82,7 +82,7 @@ public IPersistentMap PreferTable /// volatile object _cachedHierarchy; - ReaderWriterLockSlim _rw; + // ReaderWriterLockSlim _rw; bool _disposed = false; //static readonly Var _assoc = RT.var("clojure.core", "assoc"); @@ -112,7 +112,7 @@ public MultiFn(string name, IFn dispatchFn, object defaultDispatchVal, IRef hier _preferTable = PersistentHashMap.EMPTY; _hierarchy = hierarchy; _cachedHierarchy = null; - _rw = new ReaderWriterLockSlim(LockRecursionPolicy.SupportsRecursion); + // _rw = new ReaderWriterLockSlim(LockRecursionPolicy.SupportsRecursion); } #endregion @@ -128,7 +128,7 @@ public MultiFn(string name, IFn dispatchFn, object defaultDispatchVal, IRef hier [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "add")] public MultiFn addMethod(object dispatchVal, IFn method) { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { _methodTable = MethodTable.assoc(dispatchVal, method); @@ -137,7 +137,7 @@ public MultiFn addMethod(object dispatchVal, IFn method) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -150,7 +150,7 @@ public MultiFn addMethod(object dispatchVal, IFn method) [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "remove")] public MultiFn removeMethod(object dispatchVal) { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { _methodTable = MethodTable.without(dispatchVal); @@ -159,7 +159,7 @@ public MultiFn removeMethod(object dispatchVal) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -172,7 +172,7 @@ public MultiFn removeMethod(object dispatchVal) [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "prefer")] public MultiFn preferMethod(object dispatchValX, object dispatchValY) { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { if (Prefers(dispatchValY, dispatchValX)) @@ -185,7 +185,7 @@ public MultiFn preferMethod(object dispatchValX, object dispatchValY) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -242,7 +242,7 @@ private bool Dominates(object x, object y) /// private IPersistentMap ResetCache() { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { _methodCache = MethodTable; @@ -251,7 +251,7 @@ private IPersistentMap ResetCache() } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -289,7 +289,7 @@ private IFn GetFn(object dispatchVal) /// The mest method. private IFn FindAndCacheBestMethod(object dispatchVal) { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); object bestValue; IPersistentMap mt = _methodTable; IPersistentMap pt = _preferTable; @@ -320,11 +320,11 @@ private IFn FindAndCacheBestMethod(object dispatchVal) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } // ensure basis has stayed stable throughout, else redo - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { if (mt == _methodTable @@ -344,7 +344,7 @@ private IFn FindAndCacheBestMethod(object dispatchVal) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -376,7 +376,7 @@ public IPersistentMap getPreferTable() [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "reset")] public MultiFn reset() { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { _methodTable = _methodCache = _preferTable = PersistentHashMap.EMPTY; @@ -385,7 +385,7 @@ public MultiFn reset() } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -788,7 +788,7 @@ private void Dispose(bool disposing) { if (disposing) { - ((IDisposable)_rw).Dispose(); + // ((IDisposable)_rw).Dispose(); } _disposed = true; diff --git a/Clojure/Clojure/Lib/Ref.cs b/Clojure/Clojure/Lib/Ref.cs index 900168a06..cedfc2229 100644 --- a/Clojure/Clojure/Lib/Ref.cs +++ b/Clojure/Clojure/Lib/Ref.cs @@ -161,7 +161,7 @@ internal TVal TVals /// /// Reader/writer lock for the reference. /// - readonly ReaderWriterLockSlim _lock; + // readonly ReaderWriterLockSlim _lock; /// /// Info on the transaction locking this ref. @@ -250,7 +250,7 @@ public Ref(object initval, IPersistentMap meta) { _id = _ids.getAndIncrement(); _faults = new AtomicInteger(); - _lock = new ReaderWriterLockSlim(LockRecursionPolicy.SupportsRecursion); + // _lock = new ReaderWriterLockSlim(LockRecursionPolicy.NoRecursion); _tvals = new TVal(initval, 0); } @@ -344,14 +344,14 @@ object currentVal() { try { - _lock.EnterReadLock(); + // _lock.EnterReadLock(); if (_tvals != null) return _tvals.Val; throw new InvalidOperationException(String.Format("{0} is unbound.", ToString())); } finally { - _lock.ExitReadLock(); + // _lock.ExitReadLock(); } } @@ -364,7 +364,7 @@ object currentVal() /// internal void EnterReadLock() { - _lock.EnterReadLock(); + // _lock.EnterReadLock(); } /// @@ -372,7 +372,7 @@ internal void EnterReadLock() /// internal void ExitReadLock() { - _lock.ExitReadLock(); + // _lock.ExitReadLock(); } /// @@ -380,7 +380,7 @@ internal void ExitReadLock() /// internal void EnterWriteLock() { - _lock.EnterWriteLock(); + // _lock.EnterWriteLock(); } @@ -389,7 +389,7 @@ internal void EnterWriteLock() /// internal bool TryEnterWriteLock(int msecTimeout) { - return _lock.TryEnterWriteLock(msecTimeout); + return true; // _lock.TryEnterWriteLock(msecTimeout); } /// @@ -397,7 +397,7 @@ internal bool TryEnterWriteLock(int msecTimeout) /// internal void ExitWriteLock() { - _lock.ExitWriteLock(); + // _lock.ExitWriteLock(); } /// @@ -744,8 +744,8 @@ private void Dispose(bool disposing) { if (disposing) { - if ( _lock != null ) - _lock.Dispose(); + // if ( _lock != null ) + // _lock.Dispose(); } _disposed = true; From 5a9aeccc4cea7debb39584fcc7188854e50e518e Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 13 Apr 2014 17:14:30 -0400 Subject: [PATCH 16/80] Add unity-build script to build Clojure using Unity's Mono distribution --- unity-build.sh | 1 + 1 file changed, 1 insertion(+) create mode 100755 unity-build.sh diff --git a/unity-build.sh b/unity-build.sh new file mode 100755 index 000000000..7d932b50a --- /dev/null +++ b/unity-build.sh @@ -0,0 +1 @@ +/Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/bin/mono /Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/lib/mono/2.0/xbuild.exe Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Debug 3.5" /p:Platform="Any CPU" \ No newline at end of file From 3395fc107da060c5782b90624c18b727d4422126 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 13 Apr 2014 20:06:26 -0400 Subject: [PATCH 17/80] Add terminal flag to fix broken build --- unity-build.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unity-build.sh b/unity-build.sh index 7d932b50a..5b30c0e0f 100755 --- a/unity-build.sh +++ b/unity-build.sh @@ -1 +1 @@ -/Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/bin/mono /Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/lib/mono/2.0/xbuild.exe Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Debug 3.5" /p:Platform="Any CPU" \ No newline at end of file +EnableNuGetPackageRestore=true /Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/bin/mono /Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/lib/mono/2.0/xbuild.exe Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Debug 3.5" /p:Platform="Any CPU" \ No newline at end of file From f773b42b55791fc96550dccff437cc0d428a1426 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Mon, 14 Apr 2014 17:10:17 -0400 Subject: [PATCH 18/80] Update unity-build to use stock mono xbuild --- unity-build.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unity-build.sh b/unity-build.sh index 5b30c0e0f..fce3e43b4 100755 --- a/unity-build.sh +++ b/unity-build.sh @@ -1 +1 @@ -EnableNuGetPackageRestore=true /Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/bin/mono /Applications/Unity/Unity.app/Contents/Frameworks/MonoBleedingEdge/lib/mono/2.0/xbuild.exe Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Debug 3.5" /p:Platform="Any CPU" \ No newline at end of file +EnableNuGetPackageRestore=true xbuild Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Debug 3.5" /p:Platform="Any CPU" From f46f34140b7aee1cc8c31c33e60483c035b423c9 Mon Sep 17 00:00:00 2001 From: timsgardner Date: Sat, 26 Jul 2014 23:29:11 -0400 Subject: [PATCH 19/80] experimentally adding trivially renamed copy of NewInstanceExpr --- .gitignore | 1 + .../CljCompiler/Ast/OtherNewInstanceExpr.cs | 1014 +++++++++++++++++ 2 files changed, 1015 insertions(+) create mode 100644 Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs diff --git a/.gitignore b/.gitignore index cda0086ab..d88f79c97 100644 --- a/.gitignore +++ b/.gitignore @@ -172,3 +172,4 @@ lib/ # Mono *.userprefs +/dist/ diff --git a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs new file mode 100644 index 000000000..594d3ad6c --- /dev/null +++ b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs @@ -0,0 +1,1014 @@ +/** + * Copyright (c) Rich Hickey. All rights reserved. + * The use and distribution terms for this software are covered by the + * Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) + * which can be found in the file epl-v10.html at the root of this distribution. + * By using this software in any fashion, you are agreeing to be bound by + * the terms of this license. + * You must not remove this notice, or any other, from this software. + **/ + +/** + * Author: David Miller + **/ + +using System; +using System.Collections.Generic; +using System.Reflection; +using System.Reflection.Emit; +using System.Runtime.CompilerServices; +using Microsoft.Scripting.Generation; + +namespace clojure.lang.CljCompiler.Ast +{ + sealed class OtherNewInstanceExpr : ObjExpr + { + #region Data + + Dictionary> _methodMap; + + #endregion + + #region C-tors +/** + * Copyright (c) Rich Hickey. All rights reserved. + * The use and distribution terms for this software are covered by the + * Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) + * which can be found in the file epl-v10.html at the root of this distribution. + * By using this software in any fashion, you are agreeing to be bound by + * the terms of this license. + * You must not remove this notice, or any other, from this software. + **/ + +/** + * Author: David Miller + **/ + +using System; +using System.Collections.Generic; +using System.Reflection; +using System.Reflection.Emit; +using System.Runtime.CompilerServices; +using Microsoft.Scripting.Generation; + +namespace clojure.lang.CljCompiler.Ast +{ + sealed class OtherNewInstanceExpr : ObjExpr + { + #region Data + + Dictionary> _methodMap; + + #endregion + + #region C-tors + + public OtherNewInstanceExpr(object tag) + : base(tag) + { + } + + #endregion + + #region Parsing + + public sealed class DefTypeParser : IParser + { + public Expr Parse(ParserContext pcon, object frm) + { + // frm is: (deftype* tagname classname [fields] :implements [interfaces] :tag tagname methods*) + + ISeq rform = (ISeq)frm; + rform = RT.next(rform); + + string tagname = ((Symbol)rform.first()).ToString(); + rform = rform.next(); + Symbol classname = (Symbol)rform.first(); + rform = rform.next(); + IPersistentVector fields = (IPersistentVector)rform.first(); + rform = rform.next(); + IPersistentMap opts = PersistentHashMap.EMPTY; + while (rform != null && rform.first() is Keyword) + { + opts = opts.assoc(rform.first(), RT.second(rform)); + rform = rform.next().next(); + } + + ObjExpr ret = Build((IPersistentVector)RT.get(opts, Compiler.ImplementsKeyword, PersistentVector.EMPTY), fields, null, tagname, classname, + (Symbol)RT.get(opts, RT.TagKey), rform, frm); + + return ret; + } + } + + + public sealed class ReifyParser : IParser + { + public Expr Parse(ParserContext pcon, object frm) + { + // frm is: (reify this-name? [interfaces] (method-name [args] body)* ) + ISeq form = (ISeq)frm; + ObjMethod enclosingMethod = (ObjMethod)Compiler.MethodVar.deref(); + string baseName = enclosingMethod != null + ? (ObjExpr.TrimGenId(enclosingMethod.Objx.Name) + "$") + : (Compiler.munge(Compiler.CurrentNamespace.Name.Name) + "$"); + string simpleName = "reify__" + RT.nextID(); + string className = baseName + simpleName; + + ISeq rform = RT.next(form); + + IPersistentVector interfaces = ((IPersistentVector)RT.first(rform)).cons(Symbol.intern("clojure.lang.IObj")); + + rform = RT.next(rform); + + ObjExpr ret = Build(interfaces, null, null, className, Symbol.intern(className), null, rform,frm); + IObj iobj = frm as IObj; + + if (iobj != null && iobj.meta() != null) + return new MetaExpr(ret, MapExpr.Parse(pcon.EvalOrExpr(),iobj.meta())); + else + return ret; + } + } + + internal static ObjExpr Build( + IPersistentVector interfaceSyms, + IPersistentVector fieldSyms, + Symbol thisSym, + string tagName, + Symbol className, + Symbol typeTag, + ISeq methodForms, + Object frm) + { + OtherNewInstanceExpr ret = new OtherNewInstanceExpr(null); + ret._src = frm; + ret._name = className.ToString(); + ret._classMeta = GenInterface.ExtractAttributes(RT.meta(className)); + ret.InternalName = ret._name; // ret.Name.Replace('.', '/'); + // Java: ret.objtype = Type.getObjectType(ret.internalName); + + if (thisSym != null) + ret._thisName = thisSym.Name; + + if (fieldSyms != null) + { + IPersistentMap fmap = PersistentHashMap.EMPTY; + object[] closesvec = new object[2 * fieldSyms.count()]; + for (int i = 0; i < fieldSyms.count(); i++) + { + Symbol sym = (Symbol)fieldSyms.nth(i); + LocalBinding lb = new LocalBinding(-1, sym, null, new MethodParamExpr(Compiler.TagType(Compiler.TagOf(sym))), false, false, false); + fmap = fmap.assoc(sym, lb); + closesvec[i * 2] = lb; + closesvec[i * 2 + 1] = lb; + } + // Java TODO: inject __meta et al into closes - when? + // use array map to preserve ctor order + ret.Closes = new PersistentArrayMap(closesvec); + ret.Fields = fmap; + for (int i = fieldSyms.count() - 1; i >= 0 && (((Symbol)fieldSyms.nth(i)).Name.Equals("__meta") || ((Symbol)fieldSyms.nth(i)).Name.Equals("__extmap")); --i) + ret._altCtorDrops++; + } + + // Java TODO: set up volatiles + //ret._volatiles = PersistentHashSet.create(RT.seq(RT.get(ret._optionsMap, volatileKey))); + + IPersistentVector interfaces = PersistentVector.EMPTY; + for (ISeq s = RT.seq(interfaceSyms); s != null; s = s.next()) + { + Type t = (Type)Compiler.Resolve((Symbol)s.first()); + if (!t.IsInterface) + throw new ParseException("only interfaces are supported, had: " + t.Name); + interfaces = interfaces.cons(t); + } + Type superClass = typeof(Object); + + Dictionary> overrideables; + GatherMethods(superClass, RT.seq(interfaces), out overrideables); + + ret._methodMap = overrideables; + + + GenContext context = Compiler.IsCompiling + ? Compiler.CompilerContextVar.get() as GenContext + : (ret.IsDefType + ? GenContext.CreateWithExternalAssembly("deftype" + RT.nextID().ToString(), ".dll", true) + : (Compiler.CompilerContextVar.get() as GenContext + ?? + Compiler.EvalContext)); + + GenContext genC = context.WithNewDynInitHelper(ret.InternalName + "__dynInitHelper_" + RT.nextID().ToString()); + + Type stub = CompileStub(genC, superClass, ret, SeqToTypeArray(interfaces), frm); + Symbol thisTag = Symbol.intern(null, stub.FullName); + //Symbol stubTag = Symbol.intern(null,stub.FullName); + //Symbol thisTag = Symbol.intern(null, tagName); + + + try + { + Var.pushThreadBindings( + RT.mapUniqueKeys( + Compiler.ConstantsVar, PersistentVector.EMPTY, + Compiler.ConstantIdsVar, new IdentityHashMap(), + Compiler.KeywordsVar, PersistentHashMap.EMPTY, + Compiler.VarsVar, PersistentHashMap.EMPTY, + Compiler.KeywordCallsitesVar, PersistentVector.EMPTY, + Compiler.ProtocolCallsitesVar, PersistentVector.EMPTY, + Compiler.VarCallsitesVar, Compiler.EmptyVarCallSites(), + Compiler.NoRecurVar, null, + Compiler.CompilerContextVar, genC + )); + + if (ret.IsDefType) + { + Var.pushThreadBindings( + RT.mapUniqueKeys( + Compiler.MethodVar, null, + Compiler.LocalEnvVar, ret.Fields, + Compiler.CompileStubSymVar, Symbol.intern(null, tagName), + Compiler.CompileStubClassVar, stub + )); + ret._hintedFields = RT.subvec(fieldSyms, 0, fieldSyms.count() - ret._altCtorDrops); + } + // now (methodname [args] body)* + + ret.SpanMap = (IPersistentMap)Compiler.SourceSpanVar.deref(); + + IPersistentCollection methods = null; + for (ISeq s = methodForms; s != null; s = RT.next(s)) + { + NewInstanceMethod m = NewInstanceMethod.Parse(ret, (ISeq)RT.first(s), thisTag, overrideables); + methods = RT.conj(methods, m); + } + + ret._methods = methods; + ret.Keywords = (IPersistentMap)Compiler.KeywordsVar.deref(); + ret.Vars = (IPersistentMap)Compiler.VarsVar.deref(); + ret.Constants = (PersistentVector)Compiler.ConstantsVar.deref(); + ret._constantsID = RT.nextID(); + ret.KeywordCallsites = (IPersistentVector)Compiler.KeywordCallsitesVar.deref(); + ret.ProtocolCallsites = (IPersistentVector)Compiler.ProtocolCallsitesVar.deref(); + ret.VarCallsites = (IPersistentSet)Compiler.VarCallsitesVar.deref(); + } + finally + { + if (ret.IsDefType) + Var.popThreadBindings(); + Var.popThreadBindings(); + } + + // TOD: Really, the first stub here should be 'superclass' but can't handle hostexprs nested in method bodies -- reify method compilation takes place before this sucker is compiled, so can't replace the call. + // Might be able to flag stub classes and not try to convert, leading to a dynsite. + + //if (RT.CompileDLR) + ret.Compile(stub, stub, interfaces, false, genC); + //else + // ret.CompileNoDlr(stub, stub, interfaces, false, genC); + + Compiler.RegisterDuplicateType(ret.CompiledType); + + return ret; + } + + private static Type[] SeqToTypeArray(IPersistentVector interfaces) + { + Type[] types = new Type[interfaces.count()]; + for (int i = 0; i < interfaces.count(); i++) + types[i] = (Type)interfaces.nth(i); + + return types; + } + + /*** + * Current host interop uses reflection, which requires pre-existing classes + * Work around this by: + * Generate a stub class that has the same interfaces and fields as the class we are generating. + * Use it as a type hint for this, and bind the simple name of the class to this stub (in resolve etc) + * Unmunge the name (using a magic prefix) on any code gen for classes + */ + + // TODO: Preparse method heads to pick up signatures, implement those methods as abstract or as NotImpelmented so that Reflection can pick up calls during compilation and avoide a callsite. + static Type CompileStub(GenContext context, Type super, OtherNewInstanceExpr ret, Type[] interfaces, Object frm) + { + TypeBuilder tb = context.ModuleBuilder.DefineType(Compiler.CompileStubPrefix + "." + ret.InternalName + RT.nextID(), TypeAttributes.Public | TypeAttributes.Abstract, super, interfaces); + + tb.DefineDefaultConstructor(MethodAttributes.Public); + + // instance fields for closed-overs + for (ISeq s = RT.keys(ret.Closes); s != null; s = s.next()) + { + LocalBinding lb = (LocalBinding)s.first(); + FieldAttributes access = FieldAttributes.Public; + + if (!ret.IsMutable(lb)) + access |= FieldAttributes.InitOnly; + + Type fieldType = lb.PrimitiveType ?? typeof(Object); + + if (ret.IsVolatile(lb)) + tb.DefineField(lb.Name, fieldType, new Type[] { typeof(IsVolatile) }, Type.EmptyTypes, access); + else + tb.DefineField(lb.Name, fieldType, access); + } + + // ctor that takes closed-overs and does nothing + if (ret.CtorTypes().Length > 0) + { + ConstructorBuilder cb = tb.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, ret.CtorTypes()); + CljILGen ilg = new CljILGen(cb.GetILGenerator()); + ilg.EmitLoadArg(0); + ilg.Emit(OpCodes.Call, super.GetConstructor(Type.EmptyTypes)); + ilg.Emit(OpCodes.Ret); + + + if (ret._altCtorDrops > 0) + { + Type[] ctorTypes = ret.CtorTypes(); + int newLen = ctorTypes.Length - ret._altCtorDrops; + if (newLen > 0) + { + Type[] altCtorTypes = new Type[newLen]; + for (int i = 0; i < altCtorTypes.Length; i++) + altCtorTypes[i] = ctorTypes[i]; + ConstructorBuilder cb2 = tb.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, altCtorTypes); + CljILGen ilg2 = new CljILGen(cb2.GetILGenerator()); + ilg2.EmitLoadArg(0); + for (int i = 0; i < newLen; i++) + ilg2.EmitLoadArg(i + 1); + for (int i = 0; i < ret._altCtorDrops; i++) + ilg2.EmitNull(); + ilg2.Emit(OpCodes.Call, cb); + ilg2.Emit(OpCodes.Ret); + } + } + } + + Type t = tb.CreateType(); + //Compiler.RegisterDuplicateType(t); + return t; + } + + + + static string[] InterfaceNames(IPersistentVector interfaces) + { + int icnt = interfaces.count(); + string[] inames = icnt > 0 ? new string[icnt] : null; + for (int i = 0; i < icnt; i++) + inames[i] = SlashName((Type)interfaces.nth(i)); + return inames; + } + + + static string SlashName(Type t) + { + return t.FullName.Replace(',', '/'); + } + + + #endregion + + #region Method reflection + + static void GatherMethods( + Type st, + ISeq interfaces, + out Dictionary> overrides) + { + Dictionary> allm = new Dictionary>(); + GatherMethods(st, allm); + for (; interfaces != null; interfaces = interfaces.next()) + GatherMethods((Type)interfaces.first(), allm); + + overrides = allm; + } + + static void GatherMethods(Type t, Dictionary> mm) + { + for (Type mt = t; mt != null; mt = mt.BaseType) + foreach (MethodInfo m in mt.GetMethods(BindingFlags.FlattenHierarchy | BindingFlags.Instance | BindingFlags.Public | BindingFlags.NonPublic)) + ConsiderMethod(m, mm); + + if (t.IsInterface) + foreach (Type it in t.GetInterfaces()) + GatherMethods(it, mm); + } + + static void ConsiderMethod(MethodInfo m, Dictionary> mm) + { + IPersistentVector mk = MSig(m); + if (!(mm.ContainsKey(mk) + || !(m.IsPublic || m.IsProtected()) + || m.IsStatic + || m.IsFinal)) + AddMethod(mm, mk, m); + } + + public static IPersistentVector MSig(MethodInfo m) + { + return RT.vector(m.Name, RT.seq(Compiler.GetTypes(m.GetParameters())), m.ReturnType); + } + + static void AddMethod(Dictionary> mm, IPersistentVector sig, MethodInfo m) + { + List value; + if (!mm.TryGetValue(sig, out value)) + { + value = new List(); + mm[sig] = value; + } + value.Add(m); + } + + #endregion + + #region ObjExpr methods + + protected override bool SupportsMeta + { + get { return ! IsDefType; } + } + + #endregion + + #region Code generation + + private static string ExplicitMethodName(MethodInfo mi) + { + return mi.DeclaringType.Name + "." + mi.Name; + } + + protected override void EmitStatics(TypeBuilder tb) + { + if (IsDefType) + { + // getBasis() + { + MethodBuilder mbg = tb.DefineMethod("getBasis", MethodAttributes.Public | MethodAttributes.Static, typeof(IPersistentVector), Type.EmptyTypes); + CljILGen ilg = new CljILGen(mbg.GetILGenerator()); + EmitValue(_hintedFields, ilg); + ilg.Emit(OpCodes.Ret); + } + + if (Fields.count() > _hintedFields.count()) + { + // create(IPersistentMap) + MethodBuilder mbc = tb.DefineMethod("create", MethodAttributes.Public | MethodAttributes.Static, tb, new Type[] { typeof(IPersistentMap) }); + CljILGen gen = new CljILGen(mbc.GetILGenerator()); + + LocalBuilder kwLocal = gen.DeclareLocal(typeof(Keyword)); + List locals = new List(); + for (ISeq s = RT.seq(_hintedFields); s != null; s = s.next()) + { + string bName = ((Symbol)s.first()).Name; + Type t = Compiler.TagType(Compiler.TagOf(s.first())); + + // local_kw = Keyword.intern(bname) + // local_i = arg_0.valAt(kw,null) + gen.EmitLoadArg(0); + gen.EmitString(bName); + gen.EmitCall(Compiler.Method_Keyword_intern_string); + gen.Emit(OpCodes.Dup); + gen.Emit(OpCodes.Stloc, kwLocal.LocalIndex); + gen.EmitNull(); + gen.EmitCall(Compiler.Method_IPersistentMap_valAt2); + LocalBuilder lb = gen.DeclareLocal(t); + locals.Add(lb); + if (t.IsPrimitive) + gen.EmitUnbox(t); + gen.Emit(OpCodes.Stloc, lb.LocalIndex); + + // arg_0 = arg_0.without(local_kw); + gen.EmitLoadArg(0); + gen.Emit(OpCodes.Ldloc, kwLocal.LocalIndex); + gen.EmitCall(Compiler.Method_IPersistentMap_without); + gen.EmitStoreArg(0); + } + + foreach (LocalBuilder lb in locals) + gen.Emit(OpCodes.Ldloc, lb.LocalIndex); + gen.EmitNull(); + gen.EmitLoadArg(0); + gen.EmitCall(Compiler.Method_RT_seqOrElse); + gen.EmitNew(_ctorInfo); + + gen.Emit(OpCodes.Ret); + } + } + } + + protected override void EmitMethods(TypeBuilder tb) + { + HashSet implemented = new HashSet(); + + for (ISeq s = RT.seq(_methods); s != null; s = s.next()) + { + NewInstanceMethod method = (NewInstanceMethod)s.first(); + method.Emit(this, tb); + implemented.UnionWith(method.MethodInfos); + } + + foreach (List ms in _methodMap.Values) + foreach (MethodInfo mi in ms) + { + if (NeedsDummy(mi, implemented)) + EmitDummyMethod(tb, mi); + } + + EmitHasArityMethod(_typeBuilder, null, false, 0); + } + + private bool NeedsDummy(MethodInfo mi, HashSet implemented) + { + return !implemented.Contains(mi) && mi.DeclaringType.IsInterface && !(!IsDefType && mi.DeclaringType == typeof(IObj) || mi.DeclaringType == typeof(IMeta)); + } + + private static void EmitDummyMethod(TypeBuilder tb, MethodInfo mi) + { + MethodBuilder mb = tb.DefineMethod(ExplicitMethodName(mi), MethodAttributes.ReuseSlot | MethodAttributes.Public | MethodAttributes.Virtual, mi.ReturnType, Compiler.GetTypes(mi.GetParameters())); + CljILGen gen = new CljILGen(mb.GetILGenerator()); + gen.EmitNew(typeof(NotImplementedException), Type.EmptyTypes); + gen.Emit(OpCodes.Throw); + tb.DefineMethodOverride(mb, mi); + } + + #endregion + } +} + + public OtherNewInstanceExpr(object tag) + : base(tag) + { + } + + #endregion + + #region Parsing + + public sealed class DefTypeParser : IParser + { + public Expr Parse(ParserContext pcon, object frm) + { + // frm is: (deftype* tagname classname [fields] :implements [interfaces] :tag tagname methods*) + + ISeq rform = (ISeq)frm; + rform = RT.next(rform); + + string tagname = ((Symbol)rform.first()).ToString(); + rform = rform.next(); + Symbol classname = (Symbol)rform.first(); + rform = rform.next(); + IPersistentVector fields = (IPersistentVector)rform.first(); + rform = rform.next(); + IPersistentMap opts = PersistentHashMap.EMPTY; + while (rform != null && rform.first() is Keyword) + { + opts = opts.assoc(rform.first(), RT.second(rform)); + rform = rform.next().next(); + } + + ObjExpr ret = Build((IPersistentVector)RT.get(opts, Compiler.ImplementsKeyword, PersistentVector.EMPTY), fields, null, tagname, classname, + (Symbol)RT.get(opts, RT.TagKey), rform, frm); + + return ret; + } + } + + + public sealed class ReifyParser : IParser + { + public Expr Parse(ParserContext pcon, object frm) + { + // frm is: (reify this-name? [interfaces] (method-name [args] body)* ) + ISeq form = (ISeq)frm; + ObjMethod enclosingMethod = (ObjMethod)Compiler.MethodVar.deref(); + string baseName = enclosingMethod != null + ? (ObjExpr.TrimGenId(enclosingMethod.Objx.Name) + "$") + : (Compiler.munge(Compiler.CurrentNamespace.Name.Name) + "$"); + string simpleName = "reify__" + RT.nextID(); + string className = baseName + simpleName; + + ISeq rform = RT.next(form); + + IPersistentVector interfaces = ((IPersistentVector)RT.first(rform)).cons(Symbol.intern("clojure.lang.IObj")); + + rform = RT.next(rform); + + ObjExpr ret = Build(interfaces, null, null, className, Symbol.intern(className), null, rform,frm); + IObj iobj = frm as IObj; + + if (iobj != null && iobj.meta() != null) + return new MetaExpr(ret, MapExpr.Parse(pcon.EvalOrExpr(),iobj.meta())); + else + return ret; + } + } + + internal static ObjExpr Build( + IPersistentVector interfaceSyms, + IPersistentVector fieldSyms, + Symbol thisSym, + string tagName, + Symbol className, + Symbol typeTag, + ISeq methodForms, + Object frm) + { + OtherNewInstanceExpr ret = new OtherNewInstanceExpr(null); + ret._src = frm; + ret._name = className.ToString(); + ret._classMeta = GenInterface.ExtractAttributes(RT.meta(className)); + ret.InternalName = ret._name; // ret.Name.Replace('.', '/'); + // Java: ret.objtype = Type.getObjectType(ret.internalName); + + if (thisSym != null) + ret._thisName = thisSym.Name; + + if (fieldSyms != null) + { + IPersistentMap fmap = PersistentHashMap.EMPTY; + object[] closesvec = new object[2 * fieldSyms.count()]; + for (int i = 0; i < fieldSyms.count(); i++) + { + Symbol sym = (Symbol)fieldSyms.nth(i); + LocalBinding lb = new LocalBinding(-1, sym, null, new MethodParamExpr(Compiler.TagType(Compiler.TagOf(sym))), false, false, false); + fmap = fmap.assoc(sym, lb); + closesvec[i * 2] = lb; + closesvec[i * 2 + 1] = lb; + } + // Java TODO: inject __meta et al into closes - when? + // use array map to preserve ctor order + ret.Closes = new PersistentArrayMap(closesvec); + ret.Fields = fmap; + for (int i = fieldSyms.count() - 1; i >= 0 && (((Symbol)fieldSyms.nth(i)).Name.Equals("__meta") || ((Symbol)fieldSyms.nth(i)).Name.Equals("__extmap")); --i) + ret._altCtorDrops++; + } + + // Java TODO: set up volatiles + //ret._volatiles = PersistentHashSet.create(RT.seq(RT.get(ret._optionsMap, volatileKey))); + + IPersistentVector interfaces = PersistentVector.EMPTY; + for (ISeq s = RT.seq(interfaceSyms); s != null; s = s.next()) + { + Type t = (Type)Compiler.Resolve((Symbol)s.first()); + if (!t.IsInterface) + throw new ParseException("only interfaces are supported, had: " + t.Name); + interfaces = interfaces.cons(t); + } + // Type superClass = typeof(Object); + + Dictionary> overrideables; + GatherMethods(superClass, RT.seq(interfaces), out overrideables); + + ret._methodMap = overrideables; + + + GenContext context = Compiler.IsCompiling + ? Compiler.CompilerContextVar.get() as GenContext + : (ret.IsDefType + ? GenContext.CreateWithExternalAssembly("deftype" + RT.nextID().ToString(), ".dll", true) + : (Compiler.CompilerContextVar.get() as GenContext + ?? + Compiler.EvalContext)); + + GenContext genC = context.WithNewDynInitHelper(ret.InternalName + "__dynInitHelper_" + RT.nextID().ToString()); + + Type stub = CompileStub(genC, superClass, ret, SeqToTypeArray(interfaces), frm); + Symbol thisTag = Symbol.intern(null, stub.FullName); + //Symbol stubTag = Symbol.intern(null,stub.FullName); + //Symbol thisTag = Symbol.intern(null, tagName); + + + try + { + Var.pushThreadBindings( + RT.mapUniqueKeys( + Compiler.ConstantsVar, PersistentVector.EMPTY, + Compiler.ConstantIdsVar, new IdentityHashMap(), + Compiler.KeywordsVar, PersistentHashMap.EMPTY, + Compiler.VarsVar, PersistentHashMap.EMPTY, + Compiler.KeywordCallsitesVar, PersistentVector.EMPTY, + Compiler.ProtocolCallsitesVar, PersistentVector.EMPTY, + Compiler.VarCallsitesVar, Compiler.EmptyVarCallSites(), + Compiler.NoRecurVar, null, + Compiler.CompilerContextVar, genC + )); + + if (ret.IsDefType) + { + Var.pushThreadBindings( + RT.mapUniqueKeys( + Compiler.MethodVar, null, + Compiler.LocalEnvVar, ret.Fields, + Compiler.CompileStubSymVar, Symbol.intern(null, tagName), + Compiler.CompileStubClassVar, stub + )); + ret._hintedFields = RT.subvec(fieldSyms, 0, fieldSyms.count() - ret._altCtorDrops); + } + // now (methodname [args] body)* + + ret.SpanMap = (IPersistentMap)Compiler.SourceSpanVar.deref(); + + IPersistentCollection methods = null; + for (ISeq s = methodForms; s != null; s = RT.next(s)) + { + NewInstanceMethod m = NewInstanceMethod.Parse(ret, (ISeq)RT.first(s), thisTag, overrideables); + methods = RT.conj(methods, m); + } + + ret._methods = methods; + ret.Keywords = (IPersistentMap)Compiler.KeywordsVar.deref(); + ret.Vars = (IPersistentMap)Compiler.VarsVar.deref(); + ret.Constants = (PersistentVector)Compiler.ConstantsVar.deref(); + ret._constantsID = RT.nextID(); + ret.KeywordCallsites = (IPersistentVector)Compiler.KeywordCallsitesVar.deref(); + ret.ProtocolCallsites = (IPersistentVector)Compiler.ProtocolCallsitesVar.deref(); + ret.VarCallsites = (IPersistentSet)Compiler.VarCallsitesVar.deref(); + } + finally + { + if (ret.IsDefType) + Var.popThreadBindings(); + Var.popThreadBindings(); + } + + // TOD: Really, the first stub here should be 'superclass' but can't handle hostexprs nested in method bodies -- reify method compilation takes place before this sucker is compiled, so can't replace the call. + // Might be able to flag stub classes and not try to convert, leading to a dynsite. + + //if (RT.CompileDLR) + ret.Compile(stub, stub, interfaces, false, genC); + //else + // ret.CompileNoDlr(stub, stub, interfaces, false, genC); + + Compiler.RegisterDuplicateType(ret.CompiledType); + + return ret; + } + + private static Type[] SeqToTypeArray(IPersistentVector interfaces) + { + Type[] types = new Type[interfaces.count()]; + for (int i = 0; i < interfaces.count(); i++) + types[i] = (Type)interfaces.nth(i); + + return types; + } + + /*** + * Current host interop uses reflection, which requires pre-existing classes + * Work around this by: + * Generate a stub class that has the same interfaces and fields as the class we are generating. + * Use it as a type hint for this, and bind the simple name of the class to this stub (in resolve etc) + * Unmunge the name (using a magic prefix) on any code gen for classes + */ + + // TODO: Preparse method heads to pick up signatures, implement those methods as abstract or as NotImpelmented so that Reflection can pick up calls during compilation and avoide a callsite. + static Type CompileStub(GenContext context, Type super, OtherNewInstanceExpr ret, Type[] interfaces, Object frm) + { + TypeBuilder tb = context.ModuleBuilder.DefineType(Compiler.CompileStubPrefix + "." + ret.InternalName + RT.nextID(), TypeAttributes.Public | TypeAttributes.Abstract, super, interfaces); + + tb.DefineDefaultConstructor(MethodAttributes.Public); + + // instance fields for closed-overs + for (ISeq s = RT.keys(ret.Closes); s != null; s = s.next()) + { + LocalBinding lb = (LocalBinding)s.first(); + FieldAttributes access = FieldAttributes.Public; + + if (!ret.IsMutable(lb)) + access |= FieldAttributes.InitOnly; + + Type fieldType = lb.PrimitiveType ?? typeof(Object); + + if (ret.IsVolatile(lb)) + tb.DefineField(lb.Name, fieldType, new Type[] { typeof(IsVolatile) }, Type.EmptyTypes, access); + else + tb.DefineField(lb.Name, fieldType, access); + } + + // ctor that takes closed-overs and does nothing + if (ret.CtorTypes().Length > 0) + { + ConstructorBuilder cb = tb.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, ret.CtorTypes()); + CljILGen ilg = new CljILGen(cb.GetILGenerator()); + ilg.EmitLoadArg(0); + ilg.Emit(OpCodes.Call, super.GetConstructor(Type.EmptyTypes)); + ilg.Emit(OpCodes.Ret); + + + if (ret._altCtorDrops > 0) + { + Type[] ctorTypes = ret.CtorTypes(); + int newLen = ctorTypes.Length - ret._altCtorDrops; + if (newLen > 0) + { + Type[] altCtorTypes = new Type[newLen]; + for (int i = 0; i < altCtorTypes.Length; i++) + altCtorTypes[i] = ctorTypes[i]; + ConstructorBuilder cb2 = tb.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, altCtorTypes); + CljILGen ilg2 = new CljILGen(cb2.GetILGenerator()); + ilg2.EmitLoadArg(0); + for (int i = 0; i < newLen; i++) + ilg2.EmitLoadArg(i + 1); + for (int i = 0; i < ret._altCtorDrops; i++) + ilg2.EmitNull(); + ilg2.Emit(OpCodes.Call, cb); + ilg2.Emit(OpCodes.Ret); + } + } + } + + Type t = tb.CreateType(); + //Compiler.RegisterDuplicateType(t); + return t; + } + + + + static string[] InterfaceNames(IPersistentVector interfaces) + { + int icnt = interfaces.count(); + string[] inames = icnt > 0 ? new string[icnt] : null; + for (int i = 0; i < icnt; i++) + inames[i] = SlashName((Type)interfaces.nth(i)); + return inames; + } + + + static string SlashName(Type t) + { + return t.FullName.Replace(',', '/'); + } + + + #endregion + + #region Method reflection + + static void GatherMethods( + Type st, + ISeq interfaces, + out Dictionary> overrides) + { + Dictionary> allm = new Dictionary>(); + GatherMethods(st, allm); + for (; interfaces != null; interfaces = interfaces.next()) + GatherMethods((Type)interfaces.first(), allm); + + overrides = allm; + } + + static void GatherMethods(Type t, Dictionary> mm) + { + for (Type mt = t; mt != null; mt = mt.BaseType) + foreach (MethodInfo m in mt.GetMethods(BindingFlags.FlattenHierarchy | BindingFlags.Instance | BindingFlags.Public | BindingFlags.NonPublic)) + ConsiderMethod(m, mm); + + if (t.IsInterface) + foreach (Type it in t.GetInterfaces()) + GatherMethods(it, mm); + } + + static void ConsiderMethod(MethodInfo m, Dictionary> mm) + { + IPersistentVector mk = MSig(m); + if (!(mm.ContainsKey(mk) + || !(m.IsPublic || m.IsProtected()) + || m.IsStatic + || m.IsFinal)) + AddMethod(mm, mk, m); + } + + public static IPersistentVector MSig(MethodInfo m) + { + return RT.vector(m.Name, RT.seq(Compiler.GetTypes(m.GetParameters())), m.ReturnType); + } + + static void AddMethod(Dictionary> mm, IPersistentVector sig, MethodInfo m) + { + List value; + if (!mm.TryGetValue(sig, out value)) + { + value = new List(); + mm[sig] = value; + } + value.Add(m); + } + + #endregion + + #region ObjExpr methods + + protected override bool SupportsMeta + { + get { return ! IsDefType; } + } + + #endregion + + #region Code generation + + private static string ExplicitMethodName(MethodInfo mi) + { + return mi.DeclaringType.Name + "." + mi.Name; + } + + protected override void EmitStatics(TypeBuilder tb) + { + if (IsDefType) + { + // getBasis() + { + MethodBuilder mbg = tb.DefineMethod("getBasis", MethodAttributes.Public | MethodAttributes.Static, typeof(IPersistentVector), Type.EmptyTypes); + CljILGen ilg = new CljILGen(mbg.GetILGenerator()); + EmitValue(_hintedFields, ilg); + ilg.Emit(OpCodes.Ret); + } + + if (Fields.count() > _hintedFields.count()) + { + // create(IPersistentMap) + MethodBuilder mbc = tb.DefineMethod("create", MethodAttributes.Public | MethodAttributes.Static, tb, new Type[] { typeof(IPersistentMap) }); + CljILGen gen = new CljILGen(mbc.GetILGenerator()); + + LocalBuilder kwLocal = gen.DeclareLocal(typeof(Keyword)); + List locals = new List(); + for (ISeq s = RT.seq(_hintedFields); s != null; s = s.next()) + { + string bName = ((Symbol)s.first()).Name; + Type t = Compiler.TagType(Compiler.TagOf(s.first())); + + // local_kw = Keyword.intern(bname) + // local_i = arg_0.valAt(kw,null) + gen.EmitLoadArg(0); + gen.EmitString(bName); + gen.EmitCall(Compiler.Method_Keyword_intern_string); + gen.Emit(OpCodes.Dup); + gen.Emit(OpCodes.Stloc, kwLocal.LocalIndex); + gen.EmitNull(); + gen.EmitCall(Compiler.Method_IPersistentMap_valAt2); + LocalBuilder lb = gen.DeclareLocal(t); + locals.Add(lb); + if (t.IsPrimitive) + gen.EmitUnbox(t); + gen.Emit(OpCodes.Stloc, lb.LocalIndex); + + // arg_0 = arg_0.without(local_kw); + gen.EmitLoadArg(0); + gen.Emit(OpCodes.Ldloc, kwLocal.LocalIndex); + gen.EmitCall(Compiler.Method_IPersistentMap_without); + gen.EmitStoreArg(0); + } + + foreach (LocalBuilder lb in locals) + gen.Emit(OpCodes.Ldloc, lb.LocalIndex); + gen.EmitNull(); + gen.EmitLoadArg(0); + gen.EmitCall(Compiler.Method_RT_seqOrElse); + gen.EmitNew(_ctorInfo); + + gen.Emit(OpCodes.Ret); + } + } + } + + protected override void EmitMethods(TypeBuilder tb) + { + HashSet implemented = new HashSet(); + + for (ISeq s = RT.seq(_methods); s != null; s = s.next()) + { + NewInstanceMethod method = (NewInstanceMethod)s.first(); + method.Emit(this, tb); + implemented.UnionWith(method.MethodInfos); + } + + foreach (List ms in _methodMap.Values) + foreach (MethodInfo mi in ms) + { + if (NeedsDummy(mi, implemented)) + EmitDummyMethod(tb, mi); + } + + EmitHasArityMethod(_typeBuilder, null, false, 0); + } + + private bool NeedsDummy(MethodInfo mi, HashSet implemented) + { + return !implemented.Contains(mi) && mi.DeclaringType.IsInterface && !(!IsDefType && mi.DeclaringType == typeof(IObj) || mi.DeclaringType == typeof(IMeta)); + } + + private static void EmitDummyMethod(TypeBuilder tb, MethodInfo mi) + { + MethodBuilder mb = tb.DefineMethod(ExplicitMethodName(mi), MethodAttributes.ReuseSlot | MethodAttributes.Public | MethodAttributes.Virtual, mi.ReturnType, Compiler.GetTypes(mi.GetParameters())); + CljILGen gen = new CljILGen(mb.GetILGenerator()); + gen.EmitNew(typeof(NotImplementedException), Type.EmptyTypes); + gen.Emit(OpCodes.Throw); + tb.DefineMethodOverride(mb, mi); + } + + #endregion + } +} From 7100565c8787232ce37166ab041edf928d202ba5 Mon Sep 17 00:00:00 2001 From: timsgardner Date: Sun, 27 Jul 2014 01:57:03 -0400 Subject: [PATCH 20/80] Proof of concept for extending stuff --- Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs | 3 +++ Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs | 5 ++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs index f2eb3664e..34e40e465 100644 --- a/Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs @@ -151,6 +151,9 @@ internal static ObjExpr Build( interfaces = interfaces.cons(t); } Type superClass = typeof(Object); + //here begins the jank + //System.Type superClass = Type.GetType("UnityEngine.Component, UnityEngine, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null"); + Dictionary> overrideables; GatherMethods(superClass, RT.seq(interfaces), out overrideables); diff --git a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs index 594d3ad6c..d38c25b98 100644 --- a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs @@ -182,7 +182,10 @@ internal static ObjExpr Build( throw new ParseException("only interfaces are supported, had: " + t.Name); interfaces = interfaces.cons(t); } - Type superClass = typeof(Object); + // Type superClass = typeof(Object); + // here begins the jank + System.Type superClass = Type.GetType("UnityEngine.Component, UnityEngine, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null"); + Dictionary> overrideables; GatherMethods(superClass, RT.seq(interfaces), out overrideables); From 2852a6d7a47dd1e17833ee7293a3eeaa5b4a8d83 Mon Sep 17 00:00:00 2001 From: timsgardner Date: Sun, 27 Jul 2014 02:42:06 -0400 Subject: [PATCH 21/80] working on other-deftype --- .../Clojure.Source/clojure/core_deftype.clj | 893 ++++++++++-------- .../CljCompiler/Ast/OtherNewInstanceExpr.cs | 509 +--------- Clojure/Clojure/CljCompiler/Compiler.cs | 5 +- 3 files changed, 497 insertions(+), 910 deletions(-) diff --git a/Clojure/Clojure.Source/clojure/core_deftype.clj b/Clojure/Clojure.Source/clojure/core_deftype.clj index 005edd9ab..87f07d33f 100644 --- a/Clojure/Clojure.Source/clojure/core_deftype.clj +++ b/Clojure/Clojure.Source/clojure/core_deftype.clj @@ -8,31 +8,31 @@ (in-ns 'clojure.core) -;;;;;;;;;;;;;;;;;;;;;;;;;;;; definterface ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (defn namespace-munge - "Convert a Clojure namespace name to a legal Java package name." - {:added "1.2"} - [ns] - (.Replace (str ns) \- \_)) ;;; .replace - -;for now, built on gen-interface -(defmacro definterface - "Creates a new Java interface with the given name and method sigs. - The method return types and parameter types may be specified with type hints, - defaulting to Object if omitted. - - (definterface MyInterface - (^int method1 [x]) - (^Bar method2 [^Baz b ^Quux q]))" - {:added "1.2"} ;; Present since 1.2, but made public in 1.5. - [name & sigs] - (let [tag (fn tag [x] (or (:tag (meta x)) Object)) - psig (fn [[name [& args]]] - (vector name (vec (map tag args)) (tag name) (map meta args))) - cname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name))] - `(let [] - (gen-interface :name ~cname :methods ~(vec (map psig sigs))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;; definterface ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (defn namespace-munge + "Convert a Clojure namespace name to a legal Java package name." + {:added "1.2"} + [ns] + (.Replace (str ns) \- \_)) ;;; .replace + +;for now, built on gen-interface +(defmacro definterface + "Creates a new Java interface with the given name and method sigs. + The method return types and parameter types may be specified with type hints, + defaulting to Object if omitted. + + (definterface MyInterface + (^int method1 [x]) + (^Bar method2 [^Baz b ^Quux q]))" + {:added "1.2"} ;; Present since 1.2, but made public in 1.5. + [name & sigs] + (let [tag (fn tag [x] (or (:tag (meta x)) Object)) + psig (fn [[name [& args]]] + (vector name (vec (map tag args)) (tag name) (map meta args))) + cname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name))] + `(let [] + (gen-interface :name ~cname :methods ~(vec (map psig sigs))) (import ~cname)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; reify/deftype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -60,10 +60,10 @@ set (disj 'Object 'java.lang.Object) vec) - methods (map (fn [[name params & body]] - (cons name (maybe-destructured params body))) - (apply concat (vals impls)))] - (when-let [bad-opts (seq (remove #{:no-print} (keys opts)))] + methods (map (fn [[name params & body]] + (cons name (maybe-destructured params body))) + (apply concat (vals impls)))] + (when-let [bad-opts (seq (remove #{:no-print} (keys opts)))] (throw (ArgumentException. (apply print-str "Unsupported option(s) -" bad-opts)))) ;;; IllegalArgumentException [interfaces methods opts])) @@ -82,11 +82,11 @@ Methods should be supplied for all methods of the desired protocol(s) and interface(s). You can also define overrides for - methods of Object. Note that the first parameter must be supplied to - correspond to the target object ('this' in Java parlance). Thus - methods for interfaces will take one more argument than do the - interface declarations. Note also that recur calls to the method - head should *not* pass the target object, it will be supplied + methods of Object. Note that the first parameter must be supplied to + correspond to the target object ('this' in Java parlance). Thus + methods for interfaces will take one more argument than do the + interface declarations. Note also that recur calls to the method + head should *not* pass the target object, it will be supplied automatically and can not be substituted. The return type can be indicated by a type hint on the method name, @@ -111,12 +111,12 @@ (seq (let [f \"foo\"] (reify clojure.lang.Seqable (seq [this] (seq f))))) - == (\\f \\o \\o)) - - reify always implements clojure.lang.IObj and transfers meta - data of the form to the created object. - - (meta ^{:k :v} (reify Object (toString [this] \"foo\"))) + == (\\f \\o \\o)) + + reify always implements clojure.lang.IObj and transfers meta + data of the form to the created object. + + (meta ^{:k :v} (reify Object (toString [this] \"foo\"))) == {:k :v}" {:added "1.2"} [& opts+specs] @@ -129,24 +129,24 @@ (defn munge [s] ((if (symbol? s) symbol str) (clojure.lang.Compiler/munge (str s)))) -(defn- imap-cons - [^clojure.lang.IPersistentMap this o] - (cond - (instance? clojure.lang.IMapEntry o) ;;; java.util.Map$Entry - (let [^clojure.lang.IMapEntry pair o] ;;; java.util.Map$Entry - (.assoc this (.key pair) (.val pair))) ;;; .getKey .getValue - (instance? System.Collections.DictionaryEntry o) ;;; DM: Added - (let [^clojure.lang.IMapEntry pair o] ;;; DM: Added - (.assoc this (.Key pair) (.Value pair))) ;;; DM: Added - (instance? clojure.lang.IPersistentVector o) - (let [^clojure.lang.IPersistentVector vec o] - (.assoc this (.nth vec 0) (.nth vec 1))) - :else (loop [this this - o o] - (if (seq o) - (let [^clojure.lang.IMapEntry pair (first o)] ;;; java.util.Map$Entry - (recur (.assoc this (.key pair) (.val pair)) (rest o))) ;;; .getKey .getValue - this)))) +(defn- imap-cons + [^clojure.lang.IPersistentMap this o] + (cond + (instance? clojure.lang.IMapEntry o) ;;; java.util.Map$Entry + (let [^clojure.lang.IMapEntry pair o] ;;; java.util.Map$Entry + (.assoc this (.key pair) (.val pair))) ;;; .getKey .getValue + (instance? System.Collections.DictionaryEntry o) ;;; DM: Added + (let [^clojure.lang.IMapEntry pair o] ;;; DM: Added + (.assoc this (.Key pair) (.Value pair))) ;;; DM: Added + (instance? clojure.lang.IPersistentVector o) + (let [^clojure.lang.IPersistentVector vec o] + (.assoc this (.nth vec 0) (.nth vec 1))) + :else (loop [this this + o o] + (if (seq o) + (let [^clojure.lang.IMapEntry pair (first o)] ;;; java.util.Map$Entry + (recur (.assoc this (.key pair) (.val pair)) (rest o))) ;;; .getKey .getValue + this)))) (defn- emit-defrecord "Do not use this directly - use defrecord" @@ -161,163 +161,163 @@ base-fields fields fields (conj fields '__meta '__extmap) type-hash (hash classname)] - (when (some #{:volatile-mutable :unsynchronized-mutable} (mapcat (comp keys meta) hinted-fields)) - (throw (ArgumentException. ":volatile-mutable or :unsynchronized-mutable not supported for record fields"))) ;;; IllegalArgumentException + (when (some #{:volatile-mutable :unsynchronized-mutable} (mapcat (comp keys meta) hinted-fields)) + (throw (ArgumentException. ":volatile-mutable or :unsynchronized-mutable not supported for record fields"))) ;;; IllegalArgumentException (let [gs (gensym)] (letfn - [(irecord [[i m]] - [(conj i 'clojure.lang.IRecord) - m]) - (eqhash [[i m]] - [(conj i 'clojure.lang.IHashEq) - (conj m - `(hasheq [this#] (bit-xor ~type-hash (clojure.lang.APersistentMap/mapHasheq this#))) ;;; .hashCode - `(GetHashCode [this#] (clojure.lang.APersistentMap/mapHash this#)) ;;; hashCode - `(Equals [this# ~gs] (clojure.lang.APersistentMap/mapEquals this# ~gs)))]) ;;; equals + [(irecord [[i m]] + [(conj i 'clojure.lang.IRecord) + m]) + (eqhash [[i m]] + [(conj i 'clojure.lang.IHashEq) + (conj m + `(hasheq [this#] (bit-xor ~type-hash (clojure.lang.APersistentMap/mapHasheq this#))) ;;; .hashCode + `(GetHashCode [this#] (clojure.lang.APersistentMap/mapHash this#)) ;;; hashCode + `(Equals [this# ~gs] (clojure.lang.APersistentMap/mapEquals this# ~gs)))]) ;;; equals (iobj [[i m]] - [(conj i 'clojure.lang.IObj) - (conj m `(meta [this#] ~'__meta) + [(conj i 'clojure.lang.IObj) + (conj m `(meta [this#] ~'__meta) `(withMeta [this# ~gs] (new ~tagname ~@(replace {'__meta gs} fields))))]) (ilookup [[i m]] - [(conj i 'clojure.lang.ILookup 'clojure.lang.IKeywordLookup) - (conj m `(valAt [this# k#] (.valAt this# k# nil)) - `(valAt [this# k# else#] - (case k# ~@(mapcat (fn [fld] [(keyword fld) fld]) - base-fields) - (get ~'__extmap k# else#))) - `(getLookupThunk [this# k#] - (let [~'gclass (class this#)] - (case k# - ~@(let [hinted-target 'gtarget] ;;; Major loss of type hint here: [hinted-target (with-meta 'gtarget {:tag tagname})] - (mapcat - (fn [fld] - [(keyword fld) - `(reify clojure.lang.ILookupThunk - (get [~'thunk ~'gtarget] - (if (identical? (class ~'gtarget) ~'gclass) - (. ~hinted-target ~(symbol (str "-" fld))) - ~'thunk)))]) - base-fields)) + [(conj i 'clojure.lang.ILookup 'clojure.lang.IKeywordLookup) + (conj m `(valAt [this# k#] (.valAt this# k# nil)) + `(valAt [this# k# else#] + (case k# ~@(mapcat (fn [fld] [(keyword fld) fld]) + base-fields) + (get ~'__extmap k# else#))) + `(getLookupThunk [this# k#] + (let [~'gclass (class this#)] + (case k# + ~@(let [hinted-target 'gtarget] ;;; Major loss of type hint here: [hinted-target (with-meta 'gtarget {:tag tagname})] + (mapcat + (fn [fld] + [(keyword fld) + `(reify clojure.lang.ILookupThunk + (get [~'thunk ~'gtarget] + (if (identical? (class ~'gtarget) ~'gclass) + (. ~hinted-target ~(symbol (str "-" fld))) + ~'thunk)))]) + base-fields)) nil))))]) (imap [[i m]] - [(conj i 'clojure.lang.IPersistentMap) - (conj m - `(count [this#] (+ ~(count base-fields) (count ~'__extmap))) - `(empty [this#] (throw (InvalidOperationException. (str "Can't create empty: " ~(str classname))))) ;;; UnsupportedOperationException - `(^ clojure.lang.IPersistentMap cons [this# e#] ((var imap-cons) this# e#)) ;;; type hint added - `(equiv [this# ~gs] - (boolean - (or (identical? this# ~gs) - (when (identical? (class this#) (class ~gs)) - (let [~gs ~gs ] ;;; ~(with-meta gs {:tag tagname})] ----------------major loss of type hint here. TODO: Figure out what the problem is - (and ~@(map (fn [fld] `(= ~fld (. ~gs ~(symbol (str "-" fld))))) base-fields) - (= ~'__extmap (. ~gs ~'__extmap)))))))) - `(containsKey [this# k#] (not (identical? this# (.valAt this# k# this#)))) - `(entryAt [this# k#] (let [v# (.valAt this# k# this#)] - (when-not (identical? this# v#) - (clojure.lang.MapEntry. k# v#)))) - `(seq [this#] (seq (concat [~@(map #(list `new `clojure.lang.MapEntry (keyword %) %) base-fields)] - ~'__extmap))) - `(|System.Collections.Generic.IEnumerable`1[clojure.lang.IMapEntry]|.GetEnumerator [this#] (clojure.lang.IMapEntrySeqEnumerator. this#)) - `(^ clojure.lang.IPersistentMap assoc [this# k# ~gs] ;;; type hint added - (condp identical? k# - ~@(mapcat (fn [fld] - [(keyword fld) (list* `new tagname (replace {fld gs} fields))]) - base-fields) - (new ~tagname ~@(remove #{'__extmap} fields) (assoc ~'__extmap k# ~gs)))) - `(assocEx [this# k# v#] ;;; ADDED - (if (.containsKey k#) ;;; ADDED - (throw (Exception. "Key already present")) ;;; ADDED - (.assoc this# k# v#))) ;;; ADDED - `(without [this# k#] (if (contains? #{~@(map keyword base-fields)} k#) - (dissoc (with-meta (into {} this#) ~'__meta) k#) - (new ~tagname ~@(remove #{'__extmap} fields) - (not-empty (dissoc ~'__extmap k#))))))]) - (dict [[i m]] - [(conj i 'System.Collections.IDictionary) - (conj m ;;; TODO: Need properties, really - `(get_Count [this#] (.count this#)) - `(get_IsFixedSize [this#] true) - `(get_IsReadOnly [this#] true) - `(get_IsSynchronized [this#] true) - `(get_Item [this# k#] (.valAt this# k#)) - `(^System.Void set_Item [this# k# v#] (throw (NotSupportedException.))) - `(Remove [this# k#] (throw (NotSupportedException.))) - `(get_Keys [this#] (set (keys this#))) - `(get_SyncRoot [this#] this#) - `(get_Values [this#] (set (vals this#))) - `(Add [this# k# v#] (throw (NotSupportedException.))) - `(Clear [this#] (throw (NotSupportedException.))) - `(Contains [this# k#] (.containsKey this# k#)) - `(CopyTo [this# a# i#] (throw (InvalidOperationException.))) ;;; TODO: implement this. Got lazy. - `(System.Collections.IDictionary.GetEnumerator [this#] (clojure.lang.Runtime.ImmutableDictionaryEnumerator. this#)) - `(System.Collections.IEnumerable.GetEnumerator [this#] (clojure.lang.IMapEntrySeqEnumerator. (seq this#))) - )]) - (ipc [[i m]] - [(conj i 'clojure.lang.IPersistentCollection) - (conj m - `(clojure.lang.IPersistentCollection.cons [this# e#] ;;; ADDED - ((var imap-cons) this# e#)))]) ;;; ADDED - (associative ;;; ADDED - [[i m]] ;;; ADDED - [(conj i 'clojure.lang.Associative) ;;; ADDED - (conj m - `(clojure.lang.Associative.assoc [this# k# ~gs] ;;; ADDED - (condp identical? k# ;;; ADDED - ~@(mapcat (fn [fld] ;;; ADDED - [(keyword fld) (list* `new tagname (replace {fld gs} fields))]) ;;; ADDED - base-fields) ;;; ADDED - (new ~tagname ~@(remove #{'__extmap} fields) (assoc ~'__extmap k# ~gs)))))])] ;;; ADDED + [(conj i 'clojure.lang.IPersistentMap) + (conj m + `(count [this#] (+ ~(count base-fields) (count ~'__extmap))) + `(empty [this#] (throw (InvalidOperationException. (str "Can't create empty: " ~(str classname))))) ;;; UnsupportedOperationException + `(^ clojure.lang.IPersistentMap cons [this# e#] ((var imap-cons) this# e#)) ;;; type hint added + `(equiv [this# ~gs] + (boolean + (or (identical? this# ~gs) + (when (identical? (class this#) (class ~gs)) + (let [~gs ~gs ] ;;; ~(with-meta gs {:tag tagname})] ----------------major loss of type hint here. TODO: Figure out what the problem is + (and ~@(map (fn [fld] `(= ~fld (. ~gs ~(symbol (str "-" fld))))) base-fields) + (= ~'__extmap (. ~gs ~'__extmap)))))))) + `(containsKey [this# k#] (not (identical? this# (.valAt this# k# this#)))) + `(entryAt [this# k#] (let [v# (.valAt this# k# this#)] + (when-not (identical? this# v#) + (clojure.lang.MapEntry. k# v#)))) + `(seq [this#] (seq (concat [~@(map #(list `new `clojure.lang.MapEntry (keyword %) %) base-fields)] + ~'__extmap))) + `(|System.Collections.Generic.IEnumerable`1[clojure.lang.IMapEntry]|.GetEnumerator [this#] (clojure.lang.IMapEntrySeqEnumerator. this#)) + `(^ clojure.lang.IPersistentMap assoc [this# k# ~gs] ;;; type hint added + (condp identical? k# + ~@(mapcat (fn [fld] + [(keyword fld) (list* `new tagname (replace {fld gs} fields))]) + base-fields) + (new ~tagname ~@(remove #{'__extmap} fields) (assoc ~'__extmap k# ~gs)))) + `(assocEx [this# k# v#] ;;; ADDED + (if (.containsKey k#) ;;; ADDED + (throw (Exception. "Key already present")) ;;; ADDED + (.assoc this# k# v#))) ;;; ADDED + `(without [this# k#] (if (contains? #{~@(map keyword base-fields)} k#) + (dissoc (with-meta (into {} this#) ~'__meta) k#) + (new ~tagname ~@(remove #{'__extmap} fields) + (not-empty (dissoc ~'__extmap k#))))))]) + (dict [[i m]] + [(conj i 'System.Collections.IDictionary) + (conj m ;;; TODO: Need properties, really + `(get_Count [this#] (.count this#)) + `(get_IsFixedSize [this#] true) + `(get_IsReadOnly [this#] true) + `(get_IsSynchronized [this#] true) + `(get_Item [this# k#] (.valAt this# k#)) + `(^System.Void set_Item [this# k# v#] (throw (NotSupportedException.))) + `(Remove [this# k#] (throw (NotSupportedException.))) + `(get_Keys [this#] (set (keys this#))) + `(get_SyncRoot [this#] this#) + `(get_Values [this#] (set (vals this#))) + `(Add [this# k# v#] (throw (NotSupportedException.))) + `(Clear [this#] (throw (NotSupportedException.))) + `(Contains [this# k#] (.containsKey this# k#)) + `(CopyTo [this# a# i#] (throw (InvalidOperationException.))) ;;; TODO: implement this. Got lazy. + `(System.Collections.IDictionary.GetEnumerator [this#] (clojure.lang.Runtime.ImmutableDictionaryEnumerator. this#)) + `(System.Collections.IEnumerable.GetEnumerator [this#] (clojure.lang.IMapEntrySeqEnumerator. (seq this#))) + )]) + (ipc [[i m]] + [(conj i 'clojure.lang.IPersistentCollection) + (conj m + `(clojure.lang.IPersistentCollection.cons [this# e#] ;;; ADDED + ((var imap-cons) this# e#)))]) ;;; ADDED + (associative ;;; ADDED + [[i m]] ;;; ADDED + [(conj i 'clojure.lang.Associative) ;;; ADDED + (conj m + `(clojure.lang.Associative.assoc [this# k# ~gs] ;;; ADDED + (condp identical? k# ;;; ADDED + ~@(mapcat (fn [fld] ;;; ADDED + [(keyword fld) (list* `new tagname (replace {fld gs} fields))]) ;;; ADDED + base-fields) ;;; ADDED + (new ~tagname ~@(remove #{'__extmap} fields) (assoc ~'__extmap k# ~gs)))))])] ;;; ADDED (let [[i m] (-> [interfaces methods] irecord eqhash iobj ilookup imap associative ipc dict)] ;;; Associative, ipc added `(deftype* ~tagname ~(vary-meta classname merge {System.SerializableAttribute {}}) ~(conj hinted-fields '__meta '__extmap) :implements ~(vec i) ~@m)))))) -(defn- build-positional-factory - "Used to build a positional factory for a given type/record. Because of the - limitation of 20 arguments to Clojure functions, this factory needs to be - constructed to deal with more arguments. It does this by building a straight - forward type/record ctor call in the <=20 case, and a call to the same - ctor pulling the extra args out of the & overage parameter. Finally, the - arity is constrained to the number of expected fields and an ArityException - will be thrown at runtime if the actual arg count does not match." - [nom classname fields] - (let [fn-name (symbol (str '-> nom)) - [field-args over] (split-at 20 fields) - field-count (count fields) - arg-count (count field-args) - over-count (count over) - docstring (str "Positional factory function for class " classname ".")] - `(defn ~fn-name - ~docstring - [~@field-args ~@(if (seq over) '[& overage] [])] - ~(if (seq over) - `(if (= (count ~'overage) ~over-count) - (new ~classname - ~@field-args - ~@(for [i (range 0 (count over))] - (list `nth 'overage i))) - (throw (clojure.lang.ArityException. (+ ~arg-count (count ~'overage)) (name '~fn-name)))) - `(new ~classname ~@field-args))))) - -(defn- validate-fields - "" - [fields name] - (when-not (vector? fields) - (throw (Exception. "No fields vector given."))) ;;; AssertionError. - (let [specials #{'__meta '__extmap}] - (when (some specials fields) - (throw (Exception. (str "The names in " specials " cannot be used as field names for types or records."))))) ;;; AssertionError. - (let [non-syms (remove symbol? fields)] - (when (seq non-syms) - (throw (clojure.lang.Compiler+CompilerException. ;;; Compiler$CompilerException - *file* - (.deref clojure.lang.Compiler/LineVar) ;;; LINE - (.deref clojure.lang.Compiler/ColumnVar) ;;; COLUMN - (Exception. ;;; AssertionError. - (str "defrecord and deftype fields must be symbols, " - *ns* "." name " had: " - (apply str (interpose ", " non-syms))))))))) +(defn- build-positional-factory + "Used to build a positional factory for a given type/record. Because of the + limitation of 20 arguments to Clojure functions, this factory needs to be + constructed to deal with more arguments. It does this by building a straight + forward type/record ctor call in the <=20 case, and a call to the same + ctor pulling the extra args out of the & overage parameter. Finally, the + arity is constrained to the number of expected fields and an ArityException + will be thrown at runtime if the actual arg count does not match." + [nom classname fields] + (let [fn-name (symbol (str '-> nom)) + [field-args over] (split-at 20 fields) + field-count (count fields) + arg-count (count field-args) + over-count (count over) + docstring (str "Positional factory function for class " classname ".")] + `(defn ~fn-name + ~docstring + [~@field-args ~@(if (seq over) '[& overage] [])] + ~(if (seq over) + `(if (= (count ~'overage) ~over-count) + (new ~classname + ~@field-args + ~@(for [i (range 0 (count over))] + (list `nth 'overage i))) + (throw (clojure.lang.ArityException. (+ ~arg-count (count ~'overage)) (name '~fn-name)))) + `(new ~classname ~@field-args))))) + +(defn- validate-fields + "" + [fields name] + (when-not (vector? fields) + (throw (Exception. "No fields vector given."))) ;;; AssertionError. + (let [specials #{'__meta '__extmap}] + (when (some specials fields) + (throw (Exception. (str "The names in " specials " cannot be used as field names for types or records."))))) ;;; AssertionError. + (let [non-syms (remove symbol? fields)] + (when (seq non-syms) + (throw (clojure.lang.Compiler+CompilerException. ;;; Compiler$CompilerException + *file* + (.deref clojure.lang.Compiler/LineVar) ;;; LINE + (.deref clojure.lang.Compiler/ColumnVar) ;;; COLUMN + (Exception. ;;; AssertionError. + (str "defrecord and deftype fields must be symbols, " + *ns* "." name " had: " + (apply str (interpose ", " non-syms))))))))) (defmacro defrecord "(defrecord name [fields*] options* specs*) @@ -330,16 +330,16 @@ protocol-or-interface-or-Object (methodName [args*] body)* - Dynamically generates compiled bytecode for class with the given - name, in a package with the same name as the current namespace, the - given fields, and, optionally, methods for protocols and/or + Dynamically generates compiled bytecode for class with the given + name, in a package with the same name as the current namespace, the + given fields, and, optionally, methods for protocols and/or interfaces. - The class will have the (immutable) fields named by - fields, which can have type hints. Protocols/interfaces and methods - are optional. The only methods that can be supplied are those - declared in the protocols/interfaces. Note that method bodies are - not closures, the local environment includes only the named fields, + The class will have the (immutable) fields named by + fields, which can have type hints. Protocols/interfaces and methods + are optional. The only methods that can be supplied are those + declared in the protocols/interfaces. Note that method bodies are + not closures, the local environment includes only the named fields, and those fields can be accessed directly. Method definitions take the form: @@ -352,22 +352,22 @@ Methods should be supplied for all methods of the desired protocol(s) and interface(s). You can also define overrides for - methods of Object. Note that a parameter must be supplied to - correspond to the target object ('this' in Java parlance). Thus - methods for interfaces will take one more argument than do the - interface declarations. Note also that recur calls to the method - head should *not* pass the target object, it will be supplied + methods of Object. Note that a parameter must be supplied to + correspond to the target object ('this' in Java parlance). Thus + methods for interfaces will take one more argument than do the + interface declarations. Note also that recur calls to the method + head should *not* pass the target object, it will be supplied automatically and can not be substituted. In the method bodies, the (unqualified) name can be used to name the class (for calls to new, instance? etc). - The class will have implementations of several (clojure.lang) - interfaces generated automatically: IObj (metadata support) and + The class will have implementations of several (clojure.lang) + interfaces generated automatically: IObj (metadata support) and IPersistentMap, and all of their superinterfaces. - In addition, defrecord will define type-and-value-based =, - and will defined Java .hashCode and .equals consistent with the + In addition, defrecord will define type-and-value-based =, + and will defined Java .hashCode and .equals consistent with the contract for java.util.Map. When AOT compiling, generates compiled bytecode for a class with the @@ -377,14 +377,14 @@ Two constructors will be defined, one taking the designated fields followed by a metadata map (nil for none) and an extension field map (nil for none), and one taking only the fields (using nil for - meta and extension fields). Note that the field names __meta - and __extmap are currently reserved and should not be used when - defining your own records. - - Given (defrecord TypeName ...), two factory functions will be - defined: ->TypeName, taking positional parameters for the fields, + meta and extension fields). Note that the field names __meta + and __extmap are currently reserved and should not be used when + defining your own records. + + Given (defrecord TypeName ...), two factory functions will be + defined: ->TypeName, taking positional parameters for the fields, and map->TypeName, taking a map of keywords to field values." - {:added "1.2" + {:added "1.2" :arglists '([name [& fields] & opts+specs])} [name fields & opts+specs] @@ -396,167 +396,256 @@ hinted-fields fields fields (vec (map #(with-meta % nil) fields))] `(let [] - (declare ~(symbol (str '-> gname))) - (declare ~(symbol (str 'map-> gname))) - ~(emit-defrecord name gname (vec hinted-fields) (vec interfaces) methods) - (import ~classname) - ~(build-positional-factory gname classname fields) + (declare ~(symbol (str '-> gname))) + (declare ~(symbol (str 'map-> gname))) + ~(emit-defrecord name gname (vec hinted-fields) (vec interfaces) methods) + (import ~classname) + ~(build-positional-factory gname classname fields) (defn ~(symbol (str 'map-> gname)) ~(str "Factory function for class " classname ", taking a map of keywords to field values.") - ([m#] (~(symbol (str classname "/create")) - (if (instance? clojure.lang.MapEquivalence m#) m# (into {} m#))))) + ([m#] (~(symbol (str classname "/create")) + (if (instance? clojure.lang.MapEquivalence m#) m# (into {} m#))))) ~classname))) -(defn record? - "Returns true if x is a record" - {:added "1.6" - :static true} - [x] - (instance? clojure.lang.IRecord x)) - - (defn- emit-deftype* - "Do not use this directly - use deftype" - [tagname name fields interfaces methods] - (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name)) - interfaces (conj interfaces 'clojure.lang.IType)] - `(deftype* ~tagname ~classname ~fields - :implements ~interfaces - ~@methods))) - -(defmacro deftype - "(deftype name [fields*] options* specs*) - - Currently there are no options. - - Each spec consists of a protocol or interface name followed by zero - or more method bodies: - - protocol-or-interface-or-Object - (methodName [args*] body)* - - Dynamically generates compiled bytecode for class with the given - name, in a package with the same name as the current namespace, the - given fields, and, optionally, methods for protocols and/or - interfaces. - - The class will have the (by default, immutable) fields named by - fields, which can have type hints. Protocols/interfaces and methods - are optional. The only methods that can be supplied are those - declared in the protocols/interfaces. Note that method bodies are - not closures, the local environment includes only the named fields, - and those fields can be accessed directy. Fields can be qualified - with the metadata :volatile-mutable true or :unsynchronized-mutable - true, at which point (set! afield aval) will be supported in method - bodies. Note well that mutable fields are extremely difficult to use - correctly, and are present only to facilitate the building of higher - level constructs, such as Clojure's reference types, in Clojure - itself. They are for experts only - if the semantics and - implications of :volatile-mutable or :unsynchronized-mutable are not - immediately apparent to you, you should not be using them. - - Method definitions take the form: - - (methodname [args*] body) - - The argument and return types can be hinted on the arg and - methodname symbols. If not supplied, they will be inferred, so type - hints should be reserved for disambiguation. - - Methods should be supplied for all methods of the desired - protocol(s) and interface(s). You can also define overrides for - methods of Object. Note that a parameter must be supplied to - correspond to the target object ('this' in Java parlance). Thus - methods for interfaces will take one more argument than do the - interface declarations. Note also that recur calls to the method - head should *not* pass the target object, it will be supplied - automatically and can not be substituted. - - In the method bodies, the (unqualified) name can be used to name the - class (for calls to new, instance? etc). - - When AOT compiling, generates compiled bytecode for a class with the - given name (a symbol), prepends the current ns as the package, and - writes the .class file to the *compile-path* directory. - - One constructor will be defined, taking the designated fields. Note - that the field names __meta and __extmap are currently reserved and - should not be used when defining your own types. - - Given (deftype TypeName ...), a factory function called ->TypeName +(defn record? + "Returns true if x is a record" + {:added "1.6" + :static true} + [x] + (instance? clojure.lang.IRecord x)) + +(defn- emit-deftype* + "Do not use this directly - use deftype" + [tagname name fields interfaces methods] + (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name)) + interfaces (conj interfaces 'clojure.lang.IType)] + `(deftype* ~tagname ~classname ~fields + :implements ~interfaces + ~@methods))) + +(defn- emit-other-deftype* + "Do not use this directly - use other-deftype" + [tagname name fields interfaces methods] + (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name)) + interfaces (conj interfaces 'clojure.lang.IType)] + `(other-deftype* ~tagname ~classname ~fields + :implements ~interfaces + ~@methods))) + +(defmacro other-deftype + "(other-deftype name [fields*] options* specs*) + + Currently there are no options. + + Each spec consists of a protocol or interface name followed by zero + or more method bodies: + + protocol-or-interface-or-Object + (methodName [args*] body)* + + Dynamically generates compiled bytecode for class with the given + name, in a package with the same name as the current namespace, the + given fields, and, optionally, methods for protocols and/or + interfaces. + + The class will have the (by default, immutable) fields named by + fields, which can have type hints. Protocols/interfaces and methods + are optional. The only methods that can be supplied are those + declared in the protocols/interfaces. Note that method bodies are + not closures, the local environment includes only the named fields, + and those fields can be accessed directy. Fields can be qualified + with the metadata :volatile-mutable true or :unsynchronized-mutable + true, at which point (set! afield aval) will be supported in method + bodies. Note well that mutable fields are extremely difficult to use + correctly, and are present only to facilitate the building of higher + level constructs, such as Clojure's reference types, in Clojure + itself. They are for experts only - if the semantics and + implications of :volatile-mutable or :unsynchronized-mutable are not + immediately apparent to you, you should not be using them. + + Method definitions take the form: + + (methodname [args*] body) + + The argument and return types can be hinted on the arg and + methodname symbols. If not supplied, they will be inferred, so type + hints should be reserved for disambiguation. + + Methods should be supplied for all methods of the desired + protocol(s) and interface(s). You can also define overrides for + methods of Object. Note that a parameter must be supplied to + correspond to the target object ('this' in Java parlance). Thus + methods for interfaces will take one more argument than do the + interface declarations. Note also that recur calls to the method + head should *not* pass the target object, it will be supplied + automatically and can not be substituted. + + In the method bodies, the (unqualified) name can be used to name the + class (for calls to new, instance? etc). + + When AOT compiling, generates compiled bytecode for a class with the + given name (a symbol), prepends the current ns as the package, and + writes the .class file to the *compile-path* directory. + + One constructor will be defined, taking the designated fields. Note + that the field names __meta and __extmap are currently reserved and + should not be used when defining your own types. + + Given (other-deftype TypeName ...), a factory function called ->TypeName will be defined, taking positional parameters for the fields" - {:added "1.2" + {:added "1.2" :arglists '([name [& fields] & opts+specs])} - - [name fields & opts+specs] - (validate-fields fields name) - (let [gname name - [interfaces methods opts] (parse-opts+specs opts+specs) - ns-part (namespace-munge *ns*) - classname (symbol (str ns-part "." gname)) - hinted-fields fields - fields (vec (map #(with-meta % nil) fields)) - [field-args over] (split-at 20 fields)] - `(let [] - ~(emit-deftype* name gname (vec hinted-fields) (vec interfaces) methods) - (import ~classname) - ~(build-positional-factory gname classname fields) - ~classname))) - + + [name fields & opts+specs] + (validate-fields fields) + (let [gname name + [interfaces methods opts] (parse-opts+specs opts+specs) + ns-part (namespace-munge *ns*) + classname (symbol (str ns-part "." gname)) + hinted-fields fields + fields (vec (map #(with-meta % nil) fields)) + [field-args over] (split-at 20 fields)] + `(let [] + ~(emit-other-deftype* name gname (vec hinted-fields) (vec interfaces) methods) + (import ~classname) + ~(build-positional-factory gname classname fields) + ~classname))) + + +(defmacro deftype + "(deftype name [fields*] options* specs*) + + Currently there are no options. + + Each spec consists of a protocol or interface name followed by zero + or more method bodies: + + protocol-or-interface-or-Object + (methodName [args*] body)* + + Dynamically generates compiled bytecode for class with the given + name, in a package with the same name as the current namespace, the + given fields, and, optionally, methods for protocols and/or + interfaces. + + The class will have the (by default, immutable) fields named by + fields, which can have type hints. Protocols/interfaces and methods + are optional. The only methods that can be supplied are those + declared in the protocols/interfaces. Note that method bodies are + not closures, the local environment includes only the named fields, + and those fields can be accessed directy. Fields can be qualified + with the metadata :volatile-mutable true or :unsynchronized-mutable + true, at which point (set! afield aval) will be supported in method + bodies. Note well that mutable fields are extremely difficult to use + correctly, and are present only to facilitate the building of higher + level constructs, such as Clojure's reference types, in Clojure + itself. They are for experts only - if the semantics and + implications of :volatile-mutable or :unsynchronized-mutable are not + immediately apparent to you, you should not be using them. + + Method definitions take the form: + + (methodname [args*] body) + + The argument and return types can be hinted on the arg and + methodname symbols. If not supplied, they will be inferred, so type + hints should be reserved for disambiguation. + + Methods should be supplied for all methods of the desired + protocol(s) and interface(s). You can also define overrides for + methods of Object. Note that a parameter must be supplied to + correspond to the target object ('this' in Java parlance). Thus + methods for interfaces will take one more argument than do the + interface declarations. Note also that recur calls to the method + head should *not* pass the target object, it will be supplied + automatically and can not be substituted. + + In the method bodies, the (unqualified) name can be used to name the + class (for calls to new, instance? etc). + + When AOT compiling, generates compiled bytecode for a class with the + given name (a symbol), prepends the current ns as the package, and + writes the .class file to the *compile-path* directory. + + One constructor will be defined, taking the designated fields. Note + that the field names __meta and __extmap are currently reserved and + should not be used when defining your own types. + + Given (deftype TypeName ...), a factory function called ->TypeName + will be defined, taking positional parameters for the fields" + {:added "1.2" + :arglists '([name [& fields] & opts+specs])} + + [name fields & opts+specs] + (validate-fields fields name) + (let [gname name + [interfaces methods opts] (parse-opts+specs opts+specs) + ns-part (namespace-munge *ns*) + classname (symbol (str ns-part "." gname)) + hinted-fields fields + fields (vec (map #(with-meta % nil) fields)) + [field-args over] (split-at 20 fields)] + `(let [] + ~(emit-deftype* name gname (vec hinted-fields) (vec interfaces) methods) + (import ~classname) + ~(build-positional-factory gname classname fields) + ~classname))) + ;;;;;;;;;;;;;;;;;;;;;;; protocols ;;;;;;;;;;;;;;;;;;;;;;;; (defn- expand-method-impl-cache [^clojure.lang.MethodImplCache cache c f] (if (.map cache) - (let [cs (assoc (.map cache) c (clojure.lang.MethodImplCache+Entry. c f))] ;;; clojure.lang.MethodImplCache$Entry + (let [cs (assoc (.map cache) c (clojure.lang.MethodImplCache+Entry. c f))] ;;; clojure.lang.MethodImplCache$Entry (clojure.lang.MethodImplCache. (.protocol cache) (.methodk cache) cs)) - (let [cs (into1 {} (remove (fn [[c e]] (nil? e)) (map vec (partition 2 (.table cache))))) - cs (assoc cs c (clojure.lang.MethodImplCache+Entry. c f))] ;;; clojure.lang.MethodImplCache$Entry - (if-let [[shift mask] (maybe-min-hash (map hash (keys cs)))] - (let [table (make-array Object (* 2 (inc mask))) - table (reduce1 (fn [^objects t [c e]] - (let [i (* 2 (int (shift-mask shift mask (hash c))))] - (aset t i c) - (aset t (inc i) e) - t)) - table cs)] - (clojure.lang.MethodImplCache. (.protocol cache) (.methodk cache) shift mask table)) + (let [cs (into1 {} (remove (fn [[c e]] (nil? e)) (map vec (partition 2 (.table cache))))) + cs (assoc cs c (clojure.lang.MethodImplCache+Entry. c f))] ;;; clojure.lang.MethodImplCache$Entry + (if-let [[shift mask] (maybe-min-hash (map hash (keys cs)))] + (let [table (make-array Object (* 2 (inc mask))) + table (reduce1 (fn [^objects t [c e]] + (let [i (* 2 (int (shift-mask shift mask (hash c))))] + (aset t i c) + (aset t (inc i) e) + t)) + table cs)] + (clojure.lang.MethodImplCache. (.protocol cache) (.methodk cache) shift mask table)) (clojure.lang.MethodImplCache. (.protocol cache) (.methodk cache) cs))))) (defn- super-chain [^Type c] ;;; Class (when c (cons c (super-chain (.BaseType c))))) ;;; getSuperclass -(defn- pref - ([] nil) - ([a] a) - ([^Type a ^Type b] ;;; Class - (if (.IsAssignableFrom a b) b a))) ;;; isAssignableFrom +(defn- pref + ([] nil) + ([a] a) + ([^Type a ^Type b] ;;; Class + (if (.IsAssignableFrom a b) b a))) ;;; isAssignableFrom (defn find-protocol-impl [protocol x] (if (instance? (:on-interface protocol) x) x - (let [c (class x) - impl #(get (:impls protocol) %)] - (or (impl c) - (and c (or (first (remove nil? (map impl (butlast (super-chain c))))) - (when-let [t (reduce1 pref (filter impl (disj (supers c) Object)))] + (let [c (class x) + impl #(get (:impls protocol) %)] + (or (impl c) + (and c (or (first (remove nil? (map impl (butlast (super-chain c))))) + (when-let [t (reduce1 pref (filter impl (disj (supers c) Object)))] (impl t)) (impl Object))))))) (defn find-protocol-method [protocol methodk x] (get (find-protocol-impl protocol x) methodk)) -(defn- protocol? - [maybe-p] - (boolean (:on-interface maybe-p))) +(defn- protocol? + [maybe-p] + (boolean (:on-interface maybe-p))) -(defn- implements? [protocol atype] - (and atype (.IsAssignableFrom ^Type (:on-interface protocol) atype))) ;;; isAssignableFrom, Class +(defn- implements? [protocol atype] + (and atype (.IsAssignableFrom ^Type (:on-interface protocol) atype))) ;;; isAssignableFrom, Class (defn extends? "Returns true if atype extends protocol" {:added "1.2"} [protocol atype] - (boolean (or (implements? protocol atype) + (boolean (or (implements? protocol atype) (get (:impls protocol) atype)))) (defn extenders @@ -573,8 +662,8 @@ (defn -cache-protocol-fn [^clojure.lang.AFunction pf x ^Type c ^clojure.lang.IFn interf] ;;; Class (let [cache (.__methodImplCache pf) ;;; isInstance - f (if (.IsInstanceOfType c x) - interf + f (if (.IsInstanceOfType c x) + interf (find-protocol-method (.protocol cache) (.methodk cache) x))] (when-not f (throw (ArgumentException. (str "No implementation of method: " (.methodk cache) ;;; IllegalArgumentException @@ -585,18 +674,18 @@ (defn- emit-method-builder [on-interface method on-method arglists] (let [methodk (keyword method) - gthis (with-meta (gensym) {:tag 'clojure.lang.AFunction}) + gthis (with-meta (gensym) {:tag 'clojure.lang.AFunction}) ginterf (gensym)] `(fn [cache#] - (let [~ginterf - (fn - ~@(map - (fn [args] - (let [gargs (map #(gensym (str "gf__" % "__")) args) - target (first gargs)] - `([~@gargs] - (. ~(with-meta target {:tag on-interface}) (~(or on-method method) ~@(rest gargs)))))) - arglists)) + (let [~ginterf + (fn + ~@(map + (fn [args] + (let [gargs (map #(gensym (str "gf__" % "__")) args) + target (first gargs)] + `([~@gargs] + (. ~(with-meta target {:tag on-interface}) (~(or on-method method) ~@(rest gargs)))))) + arglists)) ^clojure.lang.AFunction f# (fn ~gthis ~@(map @@ -604,10 +693,10 @@ (let [gargs (map #(gensym (str "gf__" % "__")) args) target (first gargs)] `([~@gargs] - (let [cache# (.__methodImplCache ~gthis) - f# (.fnFor cache# (clojure.lang.Util/classOf ~target))] - (if f# - (f# ~@gargs) + (let [cache# (.__methodImplCache ~gthis) + f# (.fnFor cache# (clojure.lang.Util/classOf ~target))] + (if f# + (f# ~@gargs) ((-cache-protocol-fn ~gthis ~target ~on-interface ~ginterf) ~@gargs)))))) arglists))] (set! (.__methodImplCache f#) cache#) @@ -637,24 +726,24 @@ string? (recur (assoc opts :doc (first sigs)) (next sigs)) keyword? (recur (assoc opts (first sigs) (second sigs)) (nnext sigs)) [opts sigs])) - sigs (when sigs - (reduce1 (fn [m s] - (let [name-meta (meta (first s)) - mname (with-meta (first s) nil) - [arglists doc] - (loop [as [] rs (rest s)] - (if (vector? (first rs)) - (recur (conj as (first rs)) (next rs)) - [(seq as) (first rs)]))] - (when (some #{0} (map count arglists)) - (throw (ArgumentException. (str "Definition of function " mname " in protocol " name " must take at least one arg.")))) ;;; IllegalArgumentException - (when (m (keyword mname)) - (throw (ArgumentException. (str "Function " mname " in protocol " name " was redefined. Specify all arities in single definition.")))) ;;; IllegalArgumentException - (assoc m (keyword mname) - (merge name-meta - {:name (vary-meta mname assoc :doc doc :arglists arglists) - :arglists arglists - :doc doc})))) + sigs (when sigs + (reduce1 (fn [m s] + (let [name-meta (meta (first s)) + mname (with-meta (first s) nil) + [arglists doc] + (loop [as [] rs (rest s)] + (if (vector? (first rs)) + (recur (conj as (first rs)) (next rs)) + [(seq as) (first rs)]))] + (when (some #{0} (map count arglists)) + (throw (ArgumentException. (str "Definition of function " mname " in protocol " name " must take at least one arg.")))) ;;; IllegalArgumentException + (when (m (keyword mname)) + (throw (ArgumentException. (str "Function " mname " in protocol " name " was redefined. Specify all arities in single definition.")))) ;;; IllegalArgumentException + (assoc m (keyword mname) + (merge name-meta + {:name (vary-meta mname assoc :doc doc :arglists arglists) + :arglists arglists + :doc doc})))) {} sigs)) meths (mapcat (fn [sig] (let [m (munge (:name sig))] @@ -680,7 +769,7 @@ :method-builders ~(apply hash-map (mapcat - (fn [s] + (fn [s] [`(intern *ns* (with-meta '~(:name s) (merge '~s {:protocol (var ~name)}))) (emit-method-builder (:on-interface opts) (:name s) (:on s) (:arglists s))]) (vals sigs))))) @@ -702,10 +791,10 @@ protocol overall and for each method. The above yields a set of polymorphic functions and a protocol object. All are namespace-qualified by the ns enclosing the definition The resulting - functions dispatch on the type of their first argument, which is - required and corresponds to the implicit target object ('this' in - Java parlance). defprotocol is dynamic, has no special compile-time - effect, and defines no new types or classes. Implementations of + functions dispatch on the type of their first argument, which is + required and corresponds to the implicit target object ('this' in + Java parlance). defprotocol is dynamic, has no special compile-time + effect, and defines no new types or classes. Implementations of the protocol methods can be provided using extend. defprotocol will automatically generate a corresponding interface, @@ -779,12 +868,12 @@ {:added "1.2"} [atype & proto+mmaps] (doseq [[proto mmap] (partition 2 proto+mmaps)] - (when-not (protocol? proto) - (throw (ArgumentException. ;;; IllegalArgumentException - (str proto " is not a protocol")))) - (when (implements? proto atype) - (throw (ArgumentException. ;;; IllegalArgumentException - (str atype " already directly implements " (:on-interface proto) " for protocol:" + (when-not (protocol? proto) + (throw (ArgumentException. ;;; IllegalArgumentException + (str proto " is not a protocol")))) + (when (implements? proto atype) + (throw (ArgumentException. ;;; IllegalArgumentException + (str atype " already directly implements " (:on-interface proto) " for protocol:" (:var proto))))) (-reset-methods (alter-var-root (:var proto) assoc-in [:impls atype] mmap)))) @@ -812,7 +901,7 @@ (defmacro extend-type "A macro that expands into an extend call. Useful when you are supplying the definitions explicitly inline, extend-type - automatically creates the maps required by extend. Propagates the + automatically creates the maps required by extend. Propagates the class as a type hint on the first argument of all fns. (extend-type MyType @@ -879,4 +968,4 @@ {:added "1.2"} [p & specs] - (emit-extend-protocol p specs)) \ No newline at end of file + (emit-extend-protocol p specs)) diff --git a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs index d38c25b98..48b0f832a 100644 --- a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs @@ -1,36 +1,4 @@ /** - * Copyright (c) Rich Hickey. All rights reserved. - * The use and distribution terms for this software are covered by the - * Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) - * which can be found in the file epl-v10.html at the root of this distribution. - * By using this software in any fashion, you are agreeing to be bound by - * the terms of this license. - * You must not remove this notice, or any other, from this software. - **/ - -/** - * Author: David Miller - **/ - -using System; -using System.Collections.Generic; -using System.Reflection; -using System.Reflection.Emit; -using System.Runtime.CompilerServices; -using Microsoft.Scripting.Generation; - -namespace clojure.lang.CljCompiler.Ast -{ - sealed class OtherNewInstanceExpr : ObjExpr - { - #region Data - - Dictionary> _methodMap; - - #endregion - - #region C-tors -/** * Copyright (c) Rich Hickey. All rights reserved. * The use and distribution terms for this software are covered by the * Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) @@ -72,7 +40,7 @@ public OtherNewInstanceExpr(object tag) #region Parsing - public sealed class DefTypeParser : IParser + public sealed class OtherDefTypeParser : IParser { public Expr Parse(ParserContext pcon, object frm) { @@ -541,477 +509,4 @@ private static void EmitDummyMethod(TypeBuilder tb, MethodInfo mi) } } - public OtherNewInstanceExpr(object tag) - : base(tag) - { - } - - #endregion - - #region Parsing - - public sealed class DefTypeParser : IParser - { - public Expr Parse(ParserContext pcon, object frm) - { - // frm is: (deftype* tagname classname [fields] :implements [interfaces] :tag tagname methods*) - - ISeq rform = (ISeq)frm; - rform = RT.next(rform); - - string tagname = ((Symbol)rform.first()).ToString(); - rform = rform.next(); - Symbol classname = (Symbol)rform.first(); - rform = rform.next(); - IPersistentVector fields = (IPersistentVector)rform.first(); - rform = rform.next(); - IPersistentMap opts = PersistentHashMap.EMPTY; - while (rform != null && rform.first() is Keyword) - { - opts = opts.assoc(rform.first(), RT.second(rform)); - rform = rform.next().next(); - } - - ObjExpr ret = Build((IPersistentVector)RT.get(opts, Compiler.ImplementsKeyword, PersistentVector.EMPTY), fields, null, tagname, classname, - (Symbol)RT.get(opts, RT.TagKey), rform, frm); - - return ret; - } - } - - - public sealed class ReifyParser : IParser - { - public Expr Parse(ParserContext pcon, object frm) - { - // frm is: (reify this-name? [interfaces] (method-name [args] body)* ) - ISeq form = (ISeq)frm; - ObjMethod enclosingMethod = (ObjMethod)Compiler.MethodVar.deref(); - string baseName = enclosingMethod != null - ? (ObjExpr.TrimGenId(enclosingMethod.Objx.Name) + "$") - : (Compiler.munge(Compiler.CurrentNamespace.Name.Name) + "$"); - string simpleName = "reify__" + RT.nextID(); - string className = baseName + simpleName; - - ISeq rform = RT.next(form); - - IPersistentVector interfaces = ((IPersistentVector)RT.first(rform)).cons(Symbol.intern("clojure.lang.IObj")); - - rform = RT.next(rform); - - ObjExpr ret = Build(interfaces, null, null, className, Symbol.intern(className), null, rform,frm); - IObj iobj = frm as IObj; - - if (iobj != null && iobj.meta() != null) - return new MetaExpr(ret, MapExpr.Parse(pcon.EvalOrExpr(),iobj.meta())); - else - return ret; - } - } - - internal static ObjExpr Build( - IPersistentVector interfaceSyms, - IPersistentVector fieldSyms, - Symbol thisSym, - string tagName, - Symbol className, - Symbol typeTag, - ISeq methodForms, - Object frm) - { - OtherNewInstanceExpr ret = new OtherNewInstanceExpr(null); - ret._src = frm; - ret._name = className.ToString(); - ret._classMeta = GenInterface.ExtractAttributes(RT.meta(className)); - ret.InternalName = ret._name; // ret.Name.Replace('.', '/'); - // Java: ret.objtype = Type.getObjectType(ret.internalName); - - if (thisSym != null) - ret._thisName = thisSym.Name; - - if (fieldSyms != null) - { - IPersistentMap fmap = PersistentHashMap.EMPTY; - object[] closesvec = new object[2 * fieldSyms.count()]; - for (int i = 0; i < fieldSyms.count(); i++) - { - Symbol sym = (Symbol)fieldSyms.nth(i); - LocalBinding lb = new LocalBinding(-1, sym, null, new MethodParamExpr(Compiler.TagType(Compiler.TagOf(sym))), false, false, false); - fmap = fmap.assoc(sym, lb); - closesvec[i * 2] = lb; - closesvec[i * 2 + 1] = lb; - } - // Java TODO: inject __meta et al into closes - when? - // use array map to preserve ctor order - ret.Closes = new PersistentArrayMap(closesvec); - ret.Fields = fmap; - for (int i = fieldSyms.count() - 1; i >= 0 && (((Symbol)fieldSyms.nth(i)).Name.Equals("__meta") || ((Symbol)fieldSyms.nth(i)).Name.Equals("__extmap")); --i) - ret._altCtorDrops++; - } - - // Java TODO: set up volatiles - //ret._volatiles = PersistentHashSet.create(RT.seq(RT.get(ret._optionsMap, volatileKey))); - - IPersistentVector interfaces = PersistentVector.EMPTY; - for (ISeq s = RT.seq(interfaceSyms); s != null; s = s.next()) - { - Type t = (Type)Compiler.Resolve((Symbol)s.first()); - if (!t.IsInterface) - throw new ParseException("only interfaces are supported, had: " + t.Name); - interfaces = interfaces.cons(t); - } - // Type superClass = typeof(Object); - - Dictionary> overrideables; - GatherMethods(superClass, RT.seq(interfaces), out overrideables); - - ret._methodMap = overrideables; - - - GenContext context = Compiler.IsCompiling - ? Compiler.CompilerContextVar.get() as GenContext - : (ret.IsDefType - ? GenContext.CreateWithExternalAssembly("deftype" + RT.nextID().ToString(), ".dll", true) - : (Compiler.CompilerContextVar.get() as GenContext - ?? - Compiler.EvalContext)); - - GenContext genC = context.WithNewDynInitHelper(ret.InternalName + "__dynInitHelper_" + RT.nextID().ToString()); - - Type stub = CompileStub(genC, superClass, ret, SeqToTypeArray(interfaces), frm); - Symbol thisTag = Symbol.intern(null, stub.FullName); - //Symbol stubTag = Symbol.intern(null,stub.FullName); - //Symbol thisTag = Symbol.intern(null, tagName); - - - try - { - Var.pushThreadBindings( - RT.mapUniqueKeys( - Compiler.ConstantsVar, PersistentVector.EMPTY, - Compiler.ConstantIdsVar, new IdentityHashMap(), - Compiler.KeywordsVar, PersistentHashMap.EMPTY, - Compiler.VarsVar, PersistentHashMap.EMPTY, - Compiler.KeywordCallsitesVar, PersistentVector.EMPTY, - Compiler.ProtocolCallsitesVar, PersistentVector.EMPTY, - Compiler.VarCallsitesVar, Compiler.EmptyVarCallSites(), - Compiler.NoRecurVar, null, - Compiler.CompilerContextVar, genC - )); - - if (ret.IsDefType) - { - Var.pushThreadBindings( - RT.mapUniqueKeys( - Compiler.MethodVar, null, - Compiler.LocalEnvVar, ret.Fields, - Compiler.CompileStubSymVar, Symbol.intern(null, tagName), - Compiler.CompileStubClassVar, stub - )); - ret._hintedFields = RT.subvec(fieldSyms, 0, fieldSyms.count() - ret._altCtorDrops); - } - // now (methodname [args] body)* - - ret.SpanMap = (IPersistentMap)Compiler.SourceSpanVar.deref(); - - IPersistentCollection methods = null; - for (ISeq s = methodForms; s != null; s = RT.next(s)) - { - NewInstanceMethod m = NewInstanceMethod.Parse(ret, (ISeq)RT.first(s), thisTag, overrideables); - methods = RT.conj(methods, m); - } - - ret._methods = methods; - ret.Keywords = (IPersistentMap)Compiler.KeywordsVar.deref(); - ret.Vars = (IPersistentMap)Compiler.VarsVar.deref(); - ret.Constants = (PersistentVector)Compiler.ConstantsVar.deref(); - ret._constantsID = RT.nextID(); - ret.KeywordCallsites = (IPersistentVector)Compiler.KeywordCallsitesVar.deref(); - ret.ProtocolCallsites = (IPersistentVector)Compiler.ProtocolCallsitesVar.deref(); - ret.VarCallsites = (IPersistentSet)Compiler.VarCallsitesVar.deref(); - } - finally - { - if (ret.IsDefType) - Var.popThreadBindings(); - Var.popThreadBindings(); - } - - // TOD: Really, the first stub here should be 'superclass' but can't handle hostexprs nested in method bodies -- reify method compilation takes place before this sucker is compiled, so can't replace the call. - // Might be able to flag stub classes and not try to convert, leading to a dynsite. - - //if (RT.CompileDLR) - ret.Compile(stub, stub, interfaces, false, genC); - //else - // ret.CompileNoDlr(stub, stub, interfaces, false, genC); - - Compiler.RegisterDuplicateType(ret.CompiledType); - - return ret; - } - - private static Type[] SeqToTypeArray(IPersistentVector interfaces) - { - Type[] types = new Type[interfaces.count()]; - for (int i = 0; i < interfaces.count(); i++) - types[i] = (Type)interfaces.nth(i); - - return types; - } - - /*** - * Current host interop uses reflection, which requires pre-existing classes - * Work around this by: - * Generate a stub class that has the same interfaces and fields as the class we are generating. - * Use it as a type hint for this, and bind the simple name of the class to this stub (in resolve etc) - * Unmunge the name (using a magic prefix) on any code gen for classes - */ - - // TODO: Preparse method heads to pick up signatures, implement those methods as abstract or as NotImpelmented so that Reflection can pick up calls during compilation and avoide a callsite. - static Type CompileStub(GenContext context, Type super, OtherNewInstanceExpr ret, Type[] interfaces, Object frm) - { - TypeBuilder tb = context.ModuleBuilder.DefineType(Compiler.CompileStubPrefix + "." + ret.InternalName + RT.nextID(), TypeAttributes.Public | TypeAttributes.Abstract, super, interfaces); - - tb.DefineDefaultConstructor(MethodAttributes.Public); - - // instance fields for closed-overs - for (ISeq s = RT.keys(ret.Closes); s != null; s = s.next()) - { - LocalBinding lb = (LocalBinding)s.first(); - FieldAttributes access = FieldAttributes.Public; - - if (!ret.IsMutable(lb)) - access |= FieldAttributes.InitOnly; - - Type fieldType = lb.PrimitiveType ?? typeof(Object); - - if (ret.IsVolatile(lb)) - tb.DefineField(lb.Name, fieldType, new Type[] { typeof(IsVolatile) }, Type.EmptyTypes, access); - else - tb.DefineField(lb.Name, fieldType, access); - } - - // ctor that takes closed-overs and does nothing - if (ret.CtorTypes().Length > 0) - { - ConstructorBuilder cb = tb.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, ret.CtorTypes()); - CljILGen ilg = new CljILGen(cb.GetILGenerator()); - ilg.EmitLoadArg(0); - ilg.Emit(OpCodes.Call, super.GetConstructor(Type.EmptyTypes)); - ilg.Emit(OpCodes.Ret); - - - if (ret._altCtorDrops > 0) - { - Type[] ctorTypes = ret.CtorTypes(); - int newLen = ctorTypes.Length - ret._altCtorDrops; - if (newLen > 0) - { - Type[] altCtorTypes = new Type[newLen]; - for (int i = 0; i < altCtorTypes.Length; i++) - altCtorTypes[i] = ctorTypes[i]; - ConstructorBuilder cb2 = tb.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, altCtorTypes); - CljILGen ilg2 = new CljILGen(cb2.GetILGenerator()); - ilg2.EmitLoadArg(0); - for (int i = 0; i < newLen; i++) - ilg2.EmitLoadArg(i + 1); - for (int i = 0; i < ret._altCtorDrops; i++) - ilg2.EmitNull(); - ilg2.Emit(OpCodes.Call, cb); - ilg2.Emit(OpCodes.Ret); - } - } - } - - Type t = tb.CreateType(); - //Compiler.RegisterDuplicateType(t); - return t; - } - - - - static string[] InterfaceNames(IPersistentVector interfaces) - { - int icnt = interfaces.count(); - string[] inames = icnt > 0 ? new string[icnt] : null; - for (int i = 0; i < icnt; i++) - inames[i] = SlashName((Type)interfaces.nth(i)); - return inames; - } - - - static string SlashName(Type t) - { - return t.FullName.Replace(',', '/'); - } - - - #endregion - - #region Method reflection - - static void GatherMethods( - Type st, - ISeq interfaces, - out Dictionary> overrides) - { - Dictionary> allm = new Dictionary>(); - GatherMethods(st, allm); - for (; interfaces != null; interfaces = interfaces.next()) - GatherMethods((Type)interfaces.first(), allm); - - overrides = allm; - } - - static void GatherMethods(Type t, Dictionary> mm) - { - for (Type mt = t; mt != null; mt = mt.BaseType) - foreach (MethodInfo m in mt.GetMethods(BindingFlags.FlattenHierarchy | BindingFlags.Instance | BindingFlags.Public | BindingFlags.NonPublic)) - ConsiderMethod(m, mm); - - if (t.IsInterface) - foreach (Type it in t.GetInterfaces()) - GatherMethods(it, mm); - } - - static void ConsiderMethod(MethodInfo m, Dictionary> mm) - { - IPersistentVector mk = MSig(m); - if (!(mm.ContainsKey(mk) - || !(m.IsPublic || m.IsProtected()) - || m.IsStatic - || m.IsFinal)) - AddMethod(mm, mk, m); - } - - public static IPersistentVector MSig(MethodInfo m) - { - return RT.vector(m.Name, RT.seq(Compiler.GetTypes(m.GetParameters())), m.ReturnType); - } - - static void AddMethod(Dictionary> mm, IPersistentVector sig, MethodInfo m) - { - List value; - if (!mm.TryGetValue(sig, out value)) - { - value = new List(); - mm[sig] = value; - } - value.Add(m); - } - - #endregion - - #region ObjExpr methods - - protected override bool SupportsMeta - { - get { return ! IsDefType; } - } - - #endregion - - #region Code generation - - private static string ExplicitMethodName(MethodInfo mi) - { - return mi.DeclaringType.Name + "." + mi.Name; - } - - protected override void EmitStatics(TypeBuilder tb) - { - if (IsDefType) - { - // getBasis() - { - MethodBuilder mbg = tb.DefineMethod("getBasis", MethodAttributes.Public | MethodAttributes.Static, typeof(IPersistentVector), Type.EmptyTypes); - CljILGen ilg = new CljILGen(mbg.GetILGenerator()); - EmitValue(_hintedFields, ilg); - ilg.Emit(OpCodes.Ret); - } - - if (Fields.count() > _hintedFields.count()) - { - // create(IPersistentMap) - MethodBuilder mbc = tb.DefineMethod("create", MethodAttributes.Public | MethodAttributes.Static, tb, new Type[] { typeof(IPersistentMap) }); - CljILGen gen = new CljILGen(mbc.GetILGenerator()); - - LocalBuilder kwLocal = gen.DeclareLocal(typeof(Keyword)); - List locals = new List(); - for (ISeq s = RT.seq(_hintedFields); s != null; s = s.next()) - { - string bName = ((Symbol)s.first()).Name; - Type t = Compiler.TagType(Compiler.TagOf(s.first())); - - // local_kw = Keyword.intern(bname) - // local_i = arg_0.valAt(kw,null) - gen.EmitLoadArg(0); - gen.EmitString(bName); - gen.EmitCall(Compiler.Method_Keyword_intern_string); - gen.Emit(OpCodes.Dup); - gen.Emit(OpCodes.Stloc, kwLocal.LocalIndex); - gen.EmitNull(); - gen.EmitCall(Compiler.Method_IPersistentMap_valAt2); - LocalBuilder lb = gen.DeclareLocal(t); - locals.Add(lb); - if (t.IsPrimitive) - gen.EmitUnbox(t); - gen.Emit(OpCodes.Stloc, lb.LocalIndex); - - // arg_0 = arg_0.without(local_kw); - gen.EmitLoadArg(0); - gen.Emit(OpCodes.Ldloc, kwLocal.LocalIndex); - gen.EmitCall(Compiler.Method_IPersistentMap_without); - gen.EmitStoreArg(0); - } - - foreach (LocalBuilder lb in locals) - gen.Emit(OpCodes.Ldloc, lb.LocalIndex); - gen.EmitNull(); - gen.EmitLoadArg(0); - gen.EmitCall(Compiler.Method_RT_seqOrElse); - gen.EmitNew(_ctorInfo); - - gen.Emit(OpCodes.Ret); - } - } - } - - protected override void EmitMethods(TypeBuilder tb) - { - HashSet implemented = new HashSet(); - - for (ISeq s = RT.seq(_methods); s != null; s = s.next()) - { - NewInstanceMethod method = (NewInstanceMethod)s.first(); - method.Emit(this, tb); - implemented.UnionWith(method.MethodInfos); - } - - foreach (List ms in _methodMap.Values) - foreach (MethodInfo mi in ms) - { - if (NeedsDummy(mi, implemented)) - EmitDummyMethod(tb, mi); - } - - EmitHasArityMethod(_typeBuilder, null, false, 0); - } - - private bool NeedsDummy(MethodInfo mi, HashSet implemented) - { - return !implemented.Contains(mi) && mi.DeclaringType.IsInterface && !(!IsDefType && mi.DeclaringType == typeof(IObj) || mi.DeclaringType == typeof(IMeta)); - } - - private static void EmitDummyMethod(TypeBuilder tb, MethodInfo mi) - { - MethodBuilder mb = tb.DefineMethod(ExplicitMethodName(mi), MethodAttributes.ReuseSlot | MethodAttributes.Public | MethodAttributes.Virtual, mi.ReturnType, Compiler.GetTypes(mi.GetParameters())); - CljILGen gen = new CljILGen(mb.GetILGenerator()); - gen.EmitNew(typeof(NotImplementedException), Type.EmptyTypes); - gen.Emit(OpCodes.Throw); - tb.DefineMethodOverride(mb, mi); - } - - #endregion - } -} + \ No newline at end of file diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index 52507450d..9b7353709 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -77,6 +77,7 @@ internal static Type FindDuplicateType(string typename) public static readonly Symbol MonitorExitSym = Symbol.intern("monitor-exit"); public static readonly Symbol ImportSym = Symbol.intern("clojure.core","import*"); public static readonly Symbol DeftypeSym = Symbol.intern("deftype*"); + public static readonly Symbol OtherDeftypeSym = Symbol.intern("other-deftype*"); public static readonly Symbol CaseSym = Symbol.intern("case*"); public static readonly Symbol NewSym = Symbol.intern("new"); public static readonly Symbol ThisSym = Symbol.intern("this"); @@ -251,6 +252,7 @@ public static object ElideMeta(object m) DotSym, new HostExpr.Parser(), AssignSym, new AssignExpr.Parser(), DeftypeSym, new NewInstanceExpr.DefTypeParser(), + //OtherDeftypeSym, new OtherNewInstanceExpr.OtherDefTypeParser(), ReifySym, new NewInstanceExpr.ReifyParser(), TrySym, new TryExpr.Parser(), ThrowSym, new ThrowExpr.Parser(), @@ -1647,7 +1649,8 @@ internal static bool TryLoadInitType(string relativePath) [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "load")] public static object loadFile(string fileName) - { FileInfo finfo = new FileInfo(fileName); + { + FileInfo finfo = new FileInfo(fileName); if (!finfo.Exists) throw new FileNotFoundException("Cannot find file to load", fileName); From 02ea8f510d18b5548e1a17d6ed8690f3fba28975 Mon Sep 17 00:00:00 2001 From: timsgardner Date: Sun, 27 Jul 2014 02:50:46 -0400 Subject: [PATCH 22/80] Compiling nicely for unity! use the stuff produced under dist/Debug 3.5 --- Clojure/Clojure/Clojure.csproj | 1 + 1 file changed, 1 insertion(+) diff --git a/Clojure/Clojure/Clojure.csproj b/Clojure/Clojure/Clojure.csproj index f761bf8c7..d53db75b7 100644 --- a/Clojure/Clojure/Clojure.csproj +++ b/Clojure/Clojure/Clojure.csproj @@ -153,6 +153,7 @@ + From 034c231727b0354451d401a5d56a65c674489345 Mon Sep 17 00:00:00 2001 From: timsgardner Date: Sun, 27 Jul 2014 07:09:40 -0400 Subject: [PATCH 23/80] other-deftype emiting attachable extensible MonoBehaviors on AOT --- Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs | 2 +- Clojure/Clojure/CljCompiler/Compiler.cs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs index 48b0f832a..00636fb49 100644 --- a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs @@ -152,7 +152,7 @@ internal static ObjExpr Build( } // Type superClass = typeof(Object); // here begins the jank - System.Type superClass = Type.GetType("UnityEngine.Component, UnityEngine, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null"); + System.Type superClass = Type.GetType("UnityEngine.MonoBehaviour, UnityEngine, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null"); Dictionary> overrideables; diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index 9b7353709..8031910ad 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -252,7 +252,7 @@ public static object ElideMeta(object m) DotSym, new HostExpr.Parser(), AssignSym, new AssignExpr.Parser(), DeftypeSym, new NewInstanceExpr.DefTypeParser(), - //OtherDeftypeSym, new OtherNewInstanceExpr.OtherDefTypeParser(), + OtherDeftypeSym, new OtherNewInstanceExpr.OtherDefTypeParser(), ReifySym, new NewInstanceExpr.ReifyParser(), TrySym, new TryExpr.Parser(), ThrowSym, new ThrowExpr.Parser(), From 781b4bd1d751cbb9beea679a2d53f8904ccfa51f Mon Sep 17 00:00:00 2001 From: timsgardner Date: Wed, 6 Aug 2014 17:29:01 -0400 Subject: [PATCH 24/80] Renaming other-deftype to defscript and OtherNewInstanceExpr to NewScriptInstanceExpr --- Clojure/Clojure.Source/clojure/core_deftype.clj | 14 +++++++------- ...NewInstanceExpr.cs => NewScriptInstanceExpr.cs} | 10 +++++----- Clojure/Clojure/CljCompiler/Compiler.cs | 4 ++-- Clojure/Clojure/Clojure.csproj | 2 +- 4 files changed, 15 insertions(+), 15 deletions(-) rename Clojure/Clojure/CljCompiler/Ast/{OtherNewInstanceExpr.cs => NewScriptInstanceExpr.cs} (96%) diff --git a/Clojure/Clojure.Source/clojure/core_deftype.clj b/Clojure/Clojure.Source/clojure/core_deftype.clj index 87f07d33f..262c1cfcc 100644 --- a/Clojure/Clojure.Source/clojure/core_deftype.clj +++ b/Clojure/Clojure.Source/clojure/core_deftype.clj @@ -423,17 +423,17 @@ :implements ~interfaces ~@methods))) -(defn- emit-other-deftype* - "Do not use this directly - use other-deftype" +(defn- emit-defscript* + "Do not use this directly - use defscript" [tagname name fields interfaces methods] (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name)) interfaces (conj interfaces 'clojure.lang.IType)] - `(other-deftype* ~tagname ~classname ~fields + `(defscript* ~tagname ~classname ~fields :implements ~interfaces ~@methods))) -(defmacro other-deftype - "(other-deftype name [fields*] options* specs*) +(defmacro defscript + "(defscript name [fields*] options* specs*) Currently there are no options. @@ -491,7 +491,7 @@ that the field names __meta and __extmap are currently reserved and should not be used when defining your own types. - Given (other-deftype TypeName ...), a factory function called ->TypeName + Given (defscript TypeName ...), a factory function called ->TypeName will be defined, taking positional parameters for the fields" {:added "1.2" :arglists '([name [& fields] & opts+specs])} @@ -506,7 +506,7 @@ fields (vec (map #(with-meta % nil) fields)) [field-args over] (split-at 20 fields)] `(let [] - ~(emit-other-deftype* name gname (vec hinted-fields) (vec interfaces) methods) + ~(emit-defscript* name gname (vec hinted-fields) (vec interfaces) methods) (import ~classname) ~(build-positional-factory gname classname fields) ~classname))) diff --git a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/NewScriptInstanceExpr.cs similarity index 96% rename from Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs rename to Clojure/Clojure/CljCompiler/Ast/NewScriptInstanceExpr.cs index 00636fb49..1da7160ce 100644 --- a/Clojure/Clojure/CljCompiler/Ast/OtherNewInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/NewScriptInstanceExpr.cs @@ -21,7 +21,7 @@ namespace clojure.lang.CljCompiler.Ast { - sealed class OtherNewInstanceExpr : ObjExpr + sealed class NewScriptInstanceExpr : ObjExpr { #region Data @@ -31,7 +31,7 @@ sealed class OtherNewInstanceExpr : ObjExpr #region C-tors - public OtherNewInstanceExpr(object tag) + public NewScriptInstanceExpr(object tag) : base(tag) { } @@ -40,7 +40,7 @@ public OtherNewInstanceExpr(object tag) #region Parsing - public sealed class OtherDefTypeParser : IParser + public sealed class DefscriptParser : IParser { public Expr Parse(ParserContext pcon, object frm) { @@ -109,7 +109,7 @@ internal static ObjExpr Build( ISeq methodForms, Object frm) { - OtherNewInstanceExpr ret = new OtherNewInstanceExpr(null); + NewScriptInstanceExpr ret = new NewScriptInstanceExpr(null); ret._src = frm; ret._name = className.ToString(); ret._classMeta = GenInterface.ExtractAttributes(RT.meta(className)); @@ -261,7 +261,7 @@ private static Type[] SeqToTypeArray(IPersistentVector interfaces) */ // TODO: Preparse method heads to pick up signatures, implement those methods as abstract or as NotImpelmented so that Reflection can pick up calls during compilation and avoide a callsite. - static Type CompileStub(GenContext context, Type super, OtherNewInstanceExpr ret, Type[] interfaces, Object frm) + static Type CompileStub(GenContext context, Type super, NewScriptInstanceExpr ret, Type[] interfaces, Object frm) { TypeBuilder tb = context.ModuleBuilder.DefineType(Compiler.CompileStubPrefix + "." + ret.InternalName + RT.nextID(), TypeAttributes.Public | TypeAttributes.Abstract, super, interfaces); diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index 8031910ad..0157986ed 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -77,7 +77,7 @@ internal static Type FindDuplicateType(string typename) public static readonly Symbol MonitorExitSym = Symbol.intern("monitor-exit"); public static readonly Symbol ImportSym = Symbol.intern("clojure.core","import*"); public static readonly Symbol DeftypeSym = Symbol.intern("deftype*"); - public static readonly Symbol OtherDeftypeSym = Symbol.intern("other-deftype*"); + public static readonly Symbol DefscriptSym = Symbol.intern("defscript*"); public static readonly Symbol CaseSym = Symbol.intern("case*"); public static readonly Symbol NewSym = Symbol.intern("new"); public static readonly Symbol ThisSym = Symbol.intern("this"); @@ -252,7 +252,7 @@ public static object ElideMeta(object m) DotSym, new HostExpr.Parser(), AssignSym, new AssignExpr.Parser(), DeftypeSym, new NewInstanceExpr.DefTypeParser(), - OtherDeftypeSym, new OtherNewInstanceExpr.OtherDefTypeParser(), + DefscriptSym, new NewScriptInstanceExpr.DefscriptParser(), ReifySym, new NewInstanceExpr.ReifyParser(), TrySym, new TryExpr.Parser(), ThrowSym, new ThrowExpr.Parser(), diff --git a/Clojure/Clojure/Clojure.csproj b/Clojure/Clojure/Clojure.csproj index d53db75b7..170cbe5de 100644 --- a/Clojure/Clojure/Clojure.csproj +++ b/Clojure/Clojure/Clojure.csproj @@ -153,7 +153,7 @@ - + From 1767c61d377998b89bba8a15027eb6d345296ac0 Mon Sep 17 00:00:00 2001 From: timsgardner Date: Sun, 31 Aug 2014 19:25:27 -0400 Subject: [PATCH 25/80] Adding defclass*, removing defscript* and all derived macros --- .../Clojure.Source/clojure/core_deftype.clj | 89 ----------------- ...nstanceExpr.cs => NewClassInstanceExpr.cs} | 95 +++++++++++-------- Clojure/Clojure/CljCompiler/Compiler.cs | 4 +- Clojure/Clojure/Clojure.csproj | 2 +- 4 files changed, 60 insertions(+), 130 deletions(-) rename Clojure/Clojure/CljCompiler/Ast/{NewScriptInstanceExpr.cs => NewClassInstanceExpr.cs} (86%) diff --git a/Clojure/Clojure.Source/clojure/core_deftype.clj b/Clojure/Clojure.Source/clojure/core_deftype.clj index 262c1cfcc..46bd25501 100644 --- a/Clojure/Clojure.Source/clojure/core_deftype.clj +++ b/Clojure/Clojure.Source/clojure/core_deftype.clj @@ -423,95 +423,6 @@ :implements ~interfaces ~@methods))) -(defn- emit-defscript* - "Do not use this directly - use defscript" - [tagname name fields interfaces methods] - (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name)) - interfaces (conj interfaces 'clojure.lang.IType)] - `(defscript* ~tagname ~classname ~fields - :implements ~interfaces - ~@methods))) - -(defmacro defscript - "(defscript name [fields*] options* specs*) - - Currently there are no options. - - Each spec consists of a protocol or interface name followed by zero - or more method bodies: - - protocol-or-interface-or-Object - (methodName [args*] body)* - - Dynamically generates compiled bytecode for class with the given - name, in a package with the same name as the current namespace, the - given fields, and, optionally, methods for protocols and/or - interfaces. - - The class will have the (by default, immutable) fields named by - fields, which can have type hints. Protocols/interfaces and methods - are optional. The only methods that can be supplied are those - declared in the protocols/interfaces. Note that method bodies are - not closures, the local environment includes only the named fields, - and those fields can be accessed directy. Fields can be qualified - with the metadata :volatile-mutable true or :unsynchronized-mutable - true, at which point (set! afield aval) will be supported in method - bodies. Note well that mutable fields are extremely difficult to use - correctly, and are present only to facilitate the building of higher - level constructs, such as Clojure's reference types, in Clojure - itself. They are for experts only - if the semantics and - implications of :volatile-mutable or :unsynchronized-mutable are not - immediately apparent to you, you should not be using them. - - Method definitions take the form: - - (methodname [args*] body) - - The argument and return types can be hinted on the arg and - methodname symbols. If not supplied, they will be inferred, so type - hints should be reserved for disambiguation. - - Methods should be supplied for all methods of the desired - protocol(s) and interface(s). You can also define overrides for - methods of Object. Note that a parameter must be supplied to - correspond to the target object ('this' in Java parlance). Thus - methods for interfaces will take one more argument than do the - interface declarations. Note also that recur calls to the method - head should *not* pass the target object, it will be supplied - automatically and can not be substituted. - - In the method bodies, the (unqualified) name can be used to name the - class (for calls to new, instance? etc). - - When AOT compiling, generates compiled bytecode for a class with the - given name (a symbol), prepends the current ns as the package, and - writes the .class file to the *compile-path* directory. - - One constructor will be defined, taking the designated fields. Note - that the field names __meta and __extmap are currently reserved and - should not be used when defining your own types. - - Given (defscript TypeName ...), a factory function called ->TypeName - will be defined, taking positional parameters for the fields" - {:added "1.2" - :arglists '([name [& fields] & opts+specs])} - - [name fields & opts+specs] - (validate-fields fields) - (let [gname name - [interfaces methods opts] (parse-opts+specs opts+specs) - ns-part (namespace-munge *ns*) - classname (symbol (str ns-part "." gname)) - hinted-fields fields - fields (vec (map #(with-meta % nil) fields)) - [field-args over] (split-at 20 fields)] - `(let [] - ~(emit-defscript* name gname (vec hinted-fields) (vec interfaces) methods) - (import ~classname) - ~(build-positional-factory gname classname fields) - ~classname))) - - (defmacro deftype "(deftype name [fields*] options* specs*) diff --git a/Clojure/Clojure/CljCompiler/Ast/NewScriptInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs similarity index 86% rename from Clojure/Clojure/CljCompiler/Ast/NewScriptInstanceExpr.cs rename to Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs index 1da7160ce..c4b38bd1b 100644 --- a/Clojure/Clojure/CljCompiler/Ast/NewScriptInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs @@ -21,7 +21,7 @@ namespace clojure.lang.CljCompiler.Ast { - sealed class NewScriptInstanceExpr : ObjExpr + sealed class NewClassInstanceExpr : ObjExpr { #region Data @@ -31,7 +31,7 @@ sealed class NewScriptInstanceExpr : ObjExpr #region C-tors - public NewScriptInstanceExpr(object tag) + public NewClassInstanceExpr(object tag) : base(tag) { } @@ -40,7 +40,7 @@ public NewScriptInstanceExpr(object tag) #region Parsing - public sealed class DefscriptParser : IParser + public sealed class DefclassParser : IParser { public Expr Parse(ParserContext pcon, object frm) { @@ -53,6 +53,10 @@ public Expr Parse(ParserContext pcon, object frm) rform = rform.next(); Symbol classname = (Symbol)rform.first(); rform = rform.next(); + string extends = ((Symbol)rform.first()).ToString(); + rform = rform.next(); + string assemblyname = ((Symbol)rform.first()).ToString(); + rform = rform.next(); IPersistentVector fields = (IPersistentVector)rform.first(); rform = rform.next(); IPersistentMap opts = PersistentHashMap.EMPTY; @@ -62,54 +66,69 @@ public Expr Parse(ParserContext pcon, object frm) rform = rform.next().next(); } - ObjExpr ret = Build((IPersistentVector)RT.get(opts, Compiler.ImplementsKeyword, PersistentVector.EMPTY), fields, null, tagname, classname, - (Symbol)RT.get(opts, RT.TagKey), rform, frm); + ObjExpr ret = + Build( + (IPersistentVector)RT.get( + opts, + Compiler.ImplementsKeyword, + PersistentVector.EMPTY), + fields, + null, + tagname, + classname, + extends, + assemblyname, + (Symbol)RT.get(opts, RT.TagKey), + rform, + frm); return ret; } } - - public sealed class ReifyParser : IParser - { - public Expr Parse(ParserContext pcon, object frm) - { - // frm is: (reify this-name? [interfaces] (method-name [args] body)* ) - ISeq form = (ISeq)frm; - ObjMethod enclosingMethod = (ObjMethod)Compiler.MethodVar.deref(); - string baseName = enclosingMethod != null - ? (ObjExpr.TrimGenId(enclosingMethod.Objx.Name) + "$") - : (Compiler.munge(Compiler.CurrentNamespace.Name.Name) + "$"); - string simpleName = "reify__" + RT.nextID(); - string className = baseName + simpleName; - - ISeq rform = RT.next(form); - - IPersistentVector interfaces = ((IPersistentVector)RT.first(rform)).cons(Symbol.intern("clojure.lang.IObj")); - - rform = RT.next(rform); - - ObjExpr ret = Build(interfaces, null, null, className, Symbol.intern(className), null, rform,frm); - IObj iobj = frm as IObj; - - if (iobj != null && iobj.meta() != null) - return new MetaExpr(ret, MapExpr.Parse(pcon.EvalOrExpr(),iobj.meta())); - else - return ret; - } - } +// +// public sealed class ReifyParser : IParser +// { +// public Expr Parse(ParserContext pcon, object frm) +// { +// // frm is: (reify this-name? [interfaces] (method-name [args] body)* ) +// ISeq form = (ISeq)frm; +// ObjMethod enclosingMethod = (ObjMethod)Compiler.MethodVar.deref(); +// string baseName = enclosingMethod != null +// ? (ObjExpr.TrimGenId(enclosingMethod.Objx.Name) + "$") +// : (Compiler.munge(Compiler.CurrentNamespace.Name.Name) + "$"); +// string simpleName = "reify__" + RT.nextID(); +// string className = baseName + simpleName; +// +// ISeq rform = RT.next(form); +// +// IPersistentVector interfaces = ((IPersistentVector)RT.first(rform)).cons(Symbol.intern("clojure.lang.IObj")); +// +// rform = RT.next(rform); +// +// ObjExpr ret = Build(interfaces, null, null, className, Symbol.intern(className), null, rform,frm); +// IObj iobj = frm as IObj; +// +// if (iobj != null && iobj.meta() != null) +// return new MetaExpr(ret, MapExpr.Parse(pcon.EvalOrExpr(),iobj.meta())); +// else +// return ret; +// } +// } internal static ObjExpr Build( IPersistentVector interfaceSyms, IPersistentVector fieldSyms, Symbol thisSym, string tagName, - Symbol className, + Symbol className, + string extends, + string assemblyname, Symbol typeTag, ISeq methodForms, Object frm) { - NewScriptInstanceExpr ret = new NewScriptInstanceExpr(null); + NewClassInstanceExpr ret = new NewClassInstanceExpr(null); ret._src = frm; ret._name = className.ToString(); ret._classMeta = GenInterface.ExtractAttributes(RT.meta(className)); @@ -152,7 +171,7 @@ internal static ObjExpr Build( } // Type superClass = typeof(Object); // here begins the jank - System.Type superClass = Type.GetType("UnityEngine.MonoBehaviour, UnityEngine, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null"); + System.Type superClass = Type.GetType(extends + ", " + assemblyname); Dictionary> overrideables; @@ -261,7 +280,7 @@ private static Type[] SeqToTypeArray(IPersistentVector interfaces) */ // TODO: Preparse method heads to pick up signatures, implement those methods as abstract or as NotImpelmented so that Reflection can pick up calls during compilation and avoide a callsite. - static Type CompileStub(GenContext context, Type super, NewScriptInstanceExpr ret, Type[] interfaces, Object frm) + static Type CompileStub(GenContext context, Type super, NewClassInstanceExpr ret, Type[] interfaces, Object frm) { TypeBuilder tb = context.ModuleBuilder.DefineType(Compiler.CompileStubPrefix + "." + ret.InternalName + RT.nextID(), TypeAttributes.Public | TypeAttributes.Abstract, super, interfaces); diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index 0157986ed..75ea5d9e9 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -77,7 +77,7 @@ internal static Type FindDuplicateType(string typename) public static readonly Symbol MonitorExitSym = Symbol.intern("monitor-exit"); public static readonly Symbol ImportSym = Symbol.intern("clojure.core","import*"); public static readonly Symbol DeftypeSym = Symbol.intern("deftype*"); - public static readonly Symbol DefscriptSym = Symbol.intern("defscript*"); + public static readonly Symbol DefclassSym = Symbol.intern("defclass*"); public static readonly Symbol CaseSym = Symbol.intern("case*"); public static readonly Symbol NewSym = Symbol.intern("new"); public static readonly Symbol ThisSym = Symbol.intern("this"); @@ -252,7 +252,7 @@ public static object ElideMeta(object m) DotSym, new HostExpr.Parser(), AssignSym, new AssignExpr.Parser(), DeftypeSym, new NewInstanceExpr.DefTypeParser(), - DefscriptSym, new NewScriptInstanceExpr.DefscriptParser(), + DefclassSym, new NewClassInstanceExpr.DefclassParser(), ReifySym, new NewInstanceExpr.ReifyParser(), TrySym, new TryExpr.Parser(), ThrowSym, new ThrowExpr.Parser(), diff --git a/Clojure/Clojure/Clojure.csproj b/Clojure/Clojure/Clojure.csproj index 170cbe5de..39c821320 100644 --- a/Clojure/Clojure/Clojure.csproj +++ b/Clojure/Clojure/Clojure.csproj @@ -153,7 +153,7 @@ - + From 1879db238420363db5d8d2d9206173d72649b270 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Fri, 3 Oct 2014 12:47:43 -0400 Subject: [PATCH 26/80] Stop compiling stub classes for defclass Use superclass in place of stub class for type hinting --- .../CljCompiler/Ast/NewClassInstanceExpr.cs | 78 +------------------ 1 file changed, 3 insertions(+), 75 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs index c4b38bd1b..14980e491 100644 --- a/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs @@ -190,8 +190,7 @@ internal static ObjExpr Build( GenContext genC = context.WithNewDynInitHelper(ret.InternalName + "__dynInitHelper_" + RT.nextID().ToString()); - Type stub = CompileStub(genC, superClass, ret, SeqToTypeArray(interfaces), frm); - Symbol thisTag = Symbol.intern(null, stub.FullName); + Symbol thisTag = Symbol.intern(null, superClass.FullName);; //Symbol stubTag = Symbol.intern(null,stub.FullName); //Symbol thisTag = Symbol.intern(null, tagName); @@ -218,7 +217,7 @@ internal static ObjExpr Build( Compiler.MethodVar, null, Compiler.LocalEnvVar, ret.Fields, Compiler.CompileStubSymVar, Symbol.intern(null, tagName), - Compiler.CompileStubClassVar, stub + Compiler.CompileStubClassVar, superClass )); ret._hintedFields = RT.subvec(fieldSyms, 0, fieldSyms.count() - ret._altCtorDrops); } @@ -253,7 +252,7 @@ internal static ObjExpr Build( // Might be able to flag stub classes and not try to convert, leading to a dynsite. //if (RT.CompileDLR) - ret.Compile(stub, stub, interfaces, false, genC); + ret.Compile(superClass, superClass, interfaces, false, genC); //else // ret.CompileNoDlr(stub, stub, interfaces, false, genC); @@ -270,77 +269,6 @@ private static Type[] SeqToTypeArray(IPersistentVector interfaces) return types; } - - /*** - * Current host interop uses reflection, which requires pre-existing classes - * Work around this by: - * Generate a stub class that has the same interfaces and fields as the class we are generating. - * Use it as a type hint for this, and bind the simple name of the class to this stub (in resolve etc) - * Unmunge the name (using a magic prefix) on any code gen for classes - */ - - // TODO: Preparse method heads to pick up signatures, implement those methods as abstract or as NotImpelmented so that Reflection can pick up calls during compilation and avoide a callsite. - static Type CompileStub(GenContext context, Type super, NewClassInstanceExpr ret, Type[] interfaces, Object frm) - { - TypeBuilder tb = context.ModuleBuilder.DefineType(Compiler.CompileStubPrefix + "." + ret.InternalName + RT.nextID(), TypeAttributes.Public | TypeAttributes.Abstract, super, interfaces); - - tb.DefineDefaultConstructor(MethodAttributes.Public); - - // instance fields for closed-overs - for (ISeq s = RT.keys(ret.Closes); s != null; s = s.next()) - { - LocalBinding lb = (LocalBinding)s.first(); - FieldAttributes access = FieldAttributes.Public; - - if (!ret.IsMutable(lb)) - access |= FieldAttributes.InitOnly; - - Type fieldType = lb.PrimitiveType ?? typeof(Object); - - if (ret.IsVolatile(lb)) - tb.DefineField(lb.Name, fieldType, new Type[] { typeof(IsVolatile) }, Type.EmptyTypes, access); - else - tb.DefineField(lb.Name, fieldType, access); - } - - // ctor that takes closed-overs and does nothing - if (ret.CtorTypes().Length > 0) - { - ConstructorBuilder cb = tb.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, ret.CtorTypes()); - CljILGen ilg = new CljILGen(cb.GetILGenerator()); - ilg.EmitLoadArg(0); - ilg.Emit(OpCodes.Call, super.GetConstructor(Type.EmptyTypes)); - ilg.Emit(OpCodes.Ret); - - - if (ret._altCtorDrops > 0) - { - Type[] ctorTypes = ret.CtorTypes(); - int newLen = ctorTypes.Length - ret._altCtorDrops; - if (newLen > 0) - { - Type[] altCtorTypes = new Type[newLen]; - for (int i = 0; i < altCtorTypes.Length; i++) - altCtorTypes[i] = ctorTypes[i]; - ConstructorBuilder cb2 = tb.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, altCtorTypes); - CljILGen ilg2 = new CljILGen(cb2.GetILGenerator()); - ilg2.EmitLoadArg(0); - for (int i = 0; i < newLen; i++) - ilg2.EmitLoadArg(i + 1); - for (int i = 0; i < ret._altCtorDrops; i++) - ilg2.EmitNull(); - ilg2.Emit(OpCodes.Call, cb); - ilg2.Emit(OpCodes.Ret); - } - } - } - - Type t = tb.CreateType(); - //Compiler.RegisterDuplicateType(t); - return t; - } - - static string[] InterfaceNames(IPersistentVector interfaces) { From 06ae3271f9da1d56757469d3f57de963e1995669 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Fri, 3 Oct 2014 12:48:58 -0400 Subject: [PATCH 27/80] Add note to NewClassInstanceExpr --- Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs | 1 + 1 file changed, 1 insertion(+) diff --git a/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs index 14980e491..c0f56d367 100644 --- a/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs @@ -21,6 +21,7 @@ namespace clojure.lang.CljCompiler.Ast { + // Copied and modified from NewInstanceExpr to support the defclass* special form sealed class NewClassInstanceExpr : ObjExpr { #region Data From c57351d8abbb006a08cf2d773ff36e45d0e81cfa Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Fri, 3 Oct 2014 13:00:26 -0400 Subject: [PATCH 28/80] Compile Release instead of Debug + clean before build --- unity-build.sh | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/unity-build.sh b/unity-build.sh index fce3e43b4..ff9487b50 100755 --- a/unity-build.sh +++ b/unity-build.sh @@ -1 +1,2 @@ -EnableNuGetPackageRestore=true xbuild Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Debug 3.5" /p:Platform="Any CPU" +rm -fr dist bin +EnableNuGetPackageRestore=true xbuild Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Release 3.5" /p:Platform="Any CPU" From db1dabf57855cdc4524a8b35b07c20a7d481ca09 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Fri, 3 Oct 2014 13:22:40 -0400 Subject: [PATCH 29/80] Stop type lookups on lexically bound symbols This is a port of @ztellman's pending patch http://dev.clojure.org/jira/browse/CLJ-1529 This patch avoids unnecessary lookups on symbols that are known to be lexically bound, resulting in significant speedup in many cases. Details are on the Jira page. --- Clojure/Clojure/CljCompiler/Ast/HostExpr.cs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs b/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs index 5381f15b0..cb73b2e5c 100644 --- a/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs @@ -281,6 +281,9 @@ public static Type MaybeType(object form, bool stringOk) if (form is Symbol) { Symbol sym = (Symbol)form; + // if symbol refers to something in the lexical scope, it's not a type + if(Compiler.LocalEnvVar.deref() != null && ((IPersistentMap)Compiler.LocalEnvVar.deref()).containsKey(sym)) + return null; if (sym.Namespace == null) // if ns-qualified, can't be classname { if (Util.equals(sym, Compiler.CompileStubSymVar.get())) @@ -317,7 +320,7 @@ public static Type MaybeType(object form, bool stringOk) internal static Type TagToType(object tag) { - Type t = MaybeType(tag, true); + Type t = null; Symbol sym = tag as Symbol; if (sym != null) @@ -395,6 +398,8 @@ internal static Type TagToType(object tag) } } + if(t == null) + t = MaybeType(tag, true); if (t != null) return t; From a25a5eb233598af2ab80cfb1af6b3efffb39375e Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Fri, 3 Oct 2014 13:39:34 -0400 Subject: [PATCH 30/80] Add fast path for RT.classForName Namespace qualified types skip the slow string comparison code path. This commit also documents when each lookup path can be expected to succeed. --- Clojure/Clojure/Lib/RT.cs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/Clojure/Clojure/Lib/RT.cs b/Clojure/Clojure/Lib/RT.cs index 742064bb8..532f03f47 100644 --- a/Clojure/Clojure/Lib/RT.cs +++ b/Clojure/Clojure/Lib/RT.cs @@ -2811,6 +2811,9 @@ public static Type classForName(string p) { Type t = null; + // fastest path, will succeed for assembly qualified names (returned by Type.AssemblyQualifiedName) + // or namespace qualified names (returned by Type.FullName) in the executing assembly or mscorlib + // e.g. "UnityEngine.Transform, UnityEngine, Version=0.0.0.0, Culture=neutral, PublicKeyToken=null" t = Type.GetType(p, false); if (t != null) @@ -2824,6 +2827,17 @@ public static Type classForName(string p) Assembly[] assys = domain.GetAssemblies(); List candidateTypes = new List(); + // fast path, will succeed for namespace qualified names (returned by Type.FullName) + // e.g. "UnityEngine.Transform" + foreach (Assembly assy in assys) + { + Type t1 = assy.GetType(p, false); + if(t1 != null) + return t1; + } + + // slow path, will succeed for display names (returned by Type.Name) + // e.g. "Transform" foreach (Assembly assy1 in assys) { Type t1 = assy1.GetType(p, false); From 4b9af8470402faca9658d6dd53583ddd80eb2f31 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Fri, 3 Oct 2014 13:44:42 -0400 Subject: [PATCH 31/80] Use dlls over cljs when their timestamps are equal --- Clojure/Clojure/Lib/RT.cs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Clojure/Clojure/Lib/RT.cs b/Clojure/Clojure/Lib/RT.cs index 742064bb8..b0b849d8e 100644 --- a/Clojure/Clojure/Lib/RT.cs +++ b/Clojure/Clojure/Lib/RT.cs @@ -3311,7 +3311,7 @@ public static void load(String relativePath, Boolean failIfNotFound) if ((assyInfo != null && - (cljInfo == null || assyInfo.LastWriteTime > cljInfo.LastWriteTime))) + (cljInfo == null || assyInfo.LastWriteTime >= cljInfo.LastWriteTime))) { try { From ba96626d30bf400d860be389548306ee3c711962 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 5 Oct 2014 20:12:37 -0400 Subject: [PATCH 32/80] Use ReaderWriterLock in place of ReaderWriterLockSlim --- Clojure/Clojure/Lib/MultiFn.cs | 34 +++++++++++++++++----------------- Clojure/Clojure/Lib/Ref.cs | 16 ++++++++-------- 2 files changed, 25 insertions(+), 25 deletions(-) diff --git a/Clojure/Clojure/Lib/MultiFn.cs b/Clojure/Clojure/Lib/MultiFn.cs index 7af2d9a43..ec2d2d22c 100644 --- a/Clojure/Clojure/Lib/MultiFn.cs +++ b/Clojure/Clojure/Lib/MultiFn.cs @@ -82,7 +82,7 @@ public IPersistentMap PreferTable /// volatile object _cachedHierarchy; - // ReaderWriterLockSlim _rw; + ReaderWriterLock _rw; bool _disposed = false; //static readonly Var _assoc = RT.var("clojure.core", "assoc"); @@ -112,7 +112,7 @@ public MultiFn(string name, IFn dispatchFn, object defaultDispatchVal, IRef hier _preferTable = PersistentHashMap.EMPTY; _hierarchy = hierarchy; _cachedHierarchy = null; - // _rw = new ReaderWriterLockSlim(LockRecursionPolicy.SupportsRecursion); + _rw = new ReaderWriterLockSlim(LockRecursionPolicy.SupportsRecursion); } #endregion @@ -128,7 +128,7 @@ public MultiFn(string name, IFn dispatchFn, object defaultDispatchVal, IRef hier [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "add")] public MultiFn addMethod(object dispatchVal, IFn method) { - // _rw.EnterWriteLock(); + _rw.EnterWriteLock(); try { _methodTable = MethodTable.assoc(dispatchVal, method); @@ -137,7 +137,7 @@ public MultiFn addMethod(object dispatchVal, IFn method) } finally { - // _rw.ExitWriteLock(); + _rw.ExitWriteLock(); } } @@ -150,7 +150,7 @@ public MultiFn addMethod(object dispatchVal, IFn method) [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "remove")] public MultiFn removeMethod(object dispatchVal) { - // _rw.EnterWriteLock(); + _rw.EnterWriteLock(); try { _methodTable = MethodTable.without(dispatchVal); @@ -159,7 +159,7 @@ public MultiFn removeMethod(object dispatchVal) } finally { - // _rw.ExitWriteLock(); + _rw.ExitWriteLock(); } } @@ -172,7 +172,7 @@ public MultiFn removeMethod(object dispatchVal) [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "prefer")] public MultiFn preferMethod(object dispatchValX, object dispatchValY) { - // _rw.EnterWriteLock(); + _rw.EnterWriteLock(); try { if (Prefers(dispatchValY, dispatchValX)) @@ -185,7 +185,7 @@ public MultiFn preferMethod(object dispatchValX, object dispatchValY) } finally { - // _rw.ExitWriteLock(); + _rw.ExitWriteLock(); } } @@ -242,7 +242,7 @@ private bool Dominates(object x, object y) /// private IPersistentMap ResetCache() { - // _rw.EnterWriteLock(); + _rw.EnterWriteLock(); try { _methodCache = MethodTable; @@ -251,7 +251,7 @@ private IPersistentMap ResetCache() } finally { - // _rw.ExitWriteLock(); + _rw.ExitWriteLock(); } } @@ -289,7 +289,7 @@ private IFn GetFn(object dispatchVal) /// The mest method. private IFn FindAndCacheBestMethod(object dispatchVal) { - // _rw.EnterWriteLock(); + _rw.EnterWriteLock(); object bestValue; IPersistentMap mt = _methodTable; IPersistentMap pt = _preferTable; @@ -320,11 +320,11 @@ private IFn FindAndCacheBestMethod(object dispatchVal) } finally { - // _rw.ExitWriteLock(); + _rw.ExitWriteLock(); } // ensure basis has stayed stable throughout, else redo - // _rw.EnterWriteLock(); + _rw.EnterWriteLock(); try { if (mt == _methodTable @@ -344,7 +344,7 @@ private IFn FindAndCacheBestMethod(object dispatchVal) } finally { - // _rw.ExitWriteLock(); + _rw.ExitWriteLock(); } } @@ -376,7 +376,7 @@ public IPersistentMap getPreferTable() [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "reset")] public MultiFn reset() { - // _rw.EnterWriteLock(); + _rw.EnterWriteLock(); try { _methodTable = _methodCache = _preferTable = PersistentHashMap.EMPTY; @@ -385,7 +385,7 @@ public MultiFn reset() } finally { - // _rw.ExitWriteLock(); + _rw.ExitWriteLock(); } } @@ -788,7 +788,7 @@ private void Dispose(bool disposing) { if (disposing) { - // ((IDisposable)_rw).Dispose(); + ((IDisposable)_rw).Dispose(); } _disposed = true; diff --git a/Clojure/Clojure/Lib/Ref.cs b/Clojure/Clojure/Lib/Ref.cs index cedfc2229..ae0918f26 100644 --- a/Clojure/Clojure/Lib/Ref.cs +++ b/Clojure/Clojure/Lib/Ref.cs @@ -161,7 +161,7 @@ internal TVal TVals /// /// Reader/writer lock for the reference. /// - // readonly ReaderWriterLockSlim _lock; + readonly ReaderWriterLockSlim _lock; /// /// Info on the transaction locking this ref. @@ -250,7 +250,7 @@ public Ref(object initval, IPersistentMap meta) { _id = _ids.getAndIncrement(); _faults = new AtomicInteger(); - // _lock = new ReaderWriterLockSlim(LockRecursionPolicy.NoRecursion); + _lock = new ReaderWriterLockSlim(LockRecursionPolicy.NoRecursion); _tvals = new TVal(initval, 0); } @@ -344,14 +344,14 @@ object currentVal() { try { - // _lock.EnterReadLock(); + _lock.EnterReadLock(); if (_tvals != null) return _tvals.Val; throw new InvalidOperationException(String.Format("{0} is unbound.", ToString())); } finally { - // _lock.ExitReadLock(); + _lock.ExitReadLock(); } } @@ -364,7 +364,7 @@ object currentVal() /// internal void EnterReadLock() { - // _lock.EnterReadLock(); + _lock.EnterReadLock(); } /// @@ -372,7 +372,7 @@ internal void EnterReadLock() /// internal void ExitReadLock() { - // _lock.ExitReadLock(); + _lock.ExitReadLock(); } /// @@ -380,7 +380,7 @@ internal void ExitReadLock() /// internal void EnterWriteLock() { - // _lock.EnterWriteLock(); + _lock.EnterWriteLock(); } @@ -389,7 +389,7 @@ internal void EnterWriteLock() /// internal bool TryEnterWriteLock(int msecTimeout) { - return true; // _lock.TryEnterWriteLock(msecTimeout); + _lock.TryEnterWriteLock(msecTimeout); } /// From 5bf03c8dc8feb8b985d446e7598713f750547e49 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 5 Oct 2014 20:30:36 -0400 Subject: [PATCH 33/80] Revert "Use ReaderWriterLock in place of ReaderWriterLockSlim" This reverts commit ba96626d30bf400d860be389548306ee3c711962. The semantic changes between ReaderWriterLock and ReaderWriterLockSlim --- Clojure/Clojure/Lib/MultiFn.cs | 34 +++++++++++++++++----------------- Clojure/Clojure/Lib/Ref.cs | 16 ++++++++-------- 2 files changed, 25 insertions(+), 25 deletions(-) diff --git a/Clojure/Clojure/Lib/MultiFn.cs b/Clojure/Clojure/Lib/MultiFn.cs index ec2d2d22c..7af2d9a43 100644 --- a/Clojure/Clojure/Lib/MultiFn.cs +++ b/Clojure/Clojure/Lib/MultiFn.cs @@ -82,7 +82,7 @@ public IPersistentMap PreferTable /// volatile object _cachedHierarchy; - ReaderWriterLock _rw; + // ReaderWriterLockSlim _rw; bool _disposed = false; //static readonly Var _assoc = RT.var("clojure.core", "assoc"); @@ -112,7 +112,7 @@ public MultiFn(string name, IFn dispatchFn, object defaultDispatchVal, IRef hier _preferTable = PersistentHashMap.EMPTY; _hierarchy = hierarchy; _cachedHierarchy = null; - _rw = new ReaderWriterLockSlim(LockRecursionPolicy.SupportsRecursion); + // _rw = new ReaderWriterLockSlim(LockRecursionPolicy.SupportsRecursion); } #endregion @@ -128,7 +128,7 @@ public MultiFn(string name, IFn dispatchFn, object defaultDispatchVal, IRef hier [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "add")] public MultiFn addMethod(object dispatchVal, IFn method) { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { _methodTable = MethodTable.assoc(dispatchVal, method); @@ -137,7 +137,7 @@ public MultiFn addMethod(object dispatchVal, IFn method) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -150,7 +150,7 @@ public MultiFn addMethod(object dispatchVal, IFn method) [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "remove")] public MultiFn removeMethod(object dispatchVal) { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { _methodTable = MethodTable.without(dispatchVal); @@ -159,7 +159,7 @@ public MultiFn removeMethod(object dispatchVal) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -172,7 +172,7 @@ public MultiFn removeMethod(object dispatchVal) [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "prefer")] public MultiFn preferMethod(object dispatchValX, object dispatchValY) { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { if (Prefers(dispatchValY, dispatchValX)) @@ -185,7 +185,7 @@ public MultiFn preferMethod(object dispatchValX, object dispatchValY) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -242,7 +242,7 @@ private bool Dominates(object x, object y) /// private IPersistentMap ResetCache() { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { _methodCache = MethodTable; @@ -251,7 +251,7 @@ private IPersistentMap ResetCache() } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -289,7 +289,7 @@ private IFn GetFn(object dispatchVal) /// The mest method. private IFn FindAndCacheBestMethod(object dispatchVal) { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); object bestValue; IPersistentMap mt = _methodTable; IPersistentMap pt = _preferTable; @@ -320,11 +320,11 @@ private IFn FindAndCacheBestMethod(object dispatchVal) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } // ensure basis has stayed stable throughout, else redo - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { if (mt == _methodTable @@ -344,7 +344,7 @@ private IFn FindAndCacheBestMethod(object dispatchVal) } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -376,7 +376,7 @@ public IPersistentMap getPreferTable() [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "reset")] public MultiFn reset() { - _rw.EnterWriteLock(); + // _rw.EnterWriteLock(); try { _methodTable = _methodCache = _preferTable = PersistentHashMap.EMPTY; @@ -385,7 +385,7 @@ public MultiFn reset() } finally { - _rw.ExitWriteLock(); + // _rw.ExitWriteLock(); } } @@ -788,7 +788,7 @@ private void Dispose(bool disposing) { if (disposing) { - ((IDisposable)_rw).Dispose(); + // ((IDisposable)_rw).Dispose(); } _disposed = true; diff --git a/Clojure/Clojure/Lib/Ref.cs b/Clojure/Clojure/Lib/Ref.cs index ae0918f26..cedfc2229 100644 --- a/Clojure/Clojure/Lib/Ref.cs +++ b/Clojure/Clojure/Lib/Ref.cs @@ -161,7 +161,7 @@ internal TVal TVals /// /// Reader/writer lock for the reference. /// - readonly ReaderWriterLockSlim _lock; + // readonly ReaderWriterLockSlim _lock; /// /// Info on the transaction locking this ref. @@ -250,7 +250,7 @@ public Ref(object initval, IPersistentMap meta) { _id = _ids.getAndIncrement(); _faults = new AtomicInteger(); - _lock = new ReaderWriterLockSlim(LockRecursionPolicy.NoRecursion); + // _lock = new ReaderWriterLockSlim(LockRecursionPolicy.NoRecursion); _tvals = new TVal(initval, 0); } @@ -344,14 +344,14 @@ object currentVal() { try { - _lock.EnterReadLock(); + // _lock.EnterReadLock(); if (_tvals != null) return _tvals.Val; throw new InvalidOperationException(String.Format("{0} is unbound.", ToString())); } finally { - _lock.ExitReadLock(); + // _lock.ExitReadLock(); } } @@ -364,7 +364,7 @@ object currentVal() /// internal void EnterReadLock() { - _lock.EnterReadLock(); + // _lock.EnterReadLock(); } /// @@ -372,7 +372,7 @@ internal void EnterReadLock() /// internal void ExitReadLock() { - _lock.ExitReadLock(); + // _lock.ExitReadLock(); } /// @@ -380,7 +380,7 @@ internal void ExitReadLock() /// internal void EnterWriteLock() { - _lock.EnterWriteLock(); + // _lock.EnterWriteLock(); } @@ -389,7 +389,7 @@ internal void EnterWriteLock() /// internal bool TryEnterWriteLock(int msecTimeout) { - _lock.TryEnterWriteLock(msecTimeout); + return true; // _lock.TryEnterWriteLock(msecTimeout); } /// From 0fee17be009d95fce7d6f90e5b7693e6c828e456 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 9 Nov 2014 18:06:02 -0500 Subject: [PATCH 34/80] Patch MultiFn and Refs to be threadsafe again --- Clojure/Clojure/Lib/MultiFn.cs | 37 +++++++++++++++------------------- Clojure/Clojure/Lib/Ref.cs | 30 +++++++++++++-------------- 2 files changed, 31 insertions(+), 36 deletions(-) diff --git a/Clojure/Clojure/Lib/MultiFn.cs b/Clojure/Clojure/Lib/MultiFn.cs index 7af2d9a43..de783f1cc 100644 --- a/Clojure/Clojure/Lib/MultiFn.cs +++ b/Clojure/Clojure/Lib/MultiFn.cs @@ -82,7 +82,7 @@ public IPersistentMap PreferTable /// volatile object _cachedHierarchy; - // ReaderWriterLockSlim _rw; + ReaderWriterLock _rw; bool _disposed = false; //static readonly Var _assoc = RT.var("clojure.core", "assoc"); @@ -112,7 +112,7 @@ public MultiFn(string name, IFn dispatchFn, object defaultDispatchVal, IRef hier _preferTable = PersistentHashMap.EMPTY; _hierarchy = hierarchy; _cachedHierarchy = null; - // _rw = new ReaderWriterLockSlim(LockRecursionPolicy.SupportsRecursion); + _rw = new ReaderWriterLock(); } #endregion @@ -128,7 +128,7 @@ public MultiFn(string name, IFn dispatchFn, object defaultDispatchVal, IRef hier [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "add")] public MultiFn addMethod(object dispatchVal, IFn method) { - // _rw.EnterWriteLock(); + _rw.AcquireWriterLock(-1); try { _methodTable = MethodTable.assoc(dispatchVal, method); @@ -137,7 +137,7 @@ public MultiFn addMethod(object dispatchVal, IFn method) } finally { - // _rw.ExitWriteLock(); + _rw.ReleaseWriterLock(); } } @@ -150,7 +150,7 @@ public MultiFn addMethod(object dispatchVal, IFn method) [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "remove")] public MultiFn removeMethod(object dispatchVal) { - // _rw.EnterWriteLock(); + _rw.AcquireWriterLock(-1); try { _methodTable = MethodTable.without(dispatchVal); @@ -159,7 +159,7 @@ public MultiFn removeMethod(object dispatchVal) } finally { - // _rw.ExitWriteLock(); + _rw.ReleaseWriterLock(); } } @@ -172,7 +172,7 @@ public MultiFn removeMethod(object dispatchVal) [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "prefer")] public MultiFn preferMethod(object dispatchValX, object dispatchValY) { - // _rw.EnterWriteLock(); + _rw.AcquireWriterLock(-1); try { if (Prefers(dispatchValY, dispatchValX)) @@ -185,7 +185,7 @@ public MultiFn preferMethod(object dispatchValX, object dispatchValY) } finally { - // _rw.ExitWriteLock(); + _rw.ReleaseWriterLock(); } } @@ -242,7 +242,7 @@ private bool Dominates(object x, object y) /// private IPersistentMap ResetCache() { - // _rw.EnterWriteLock(); + _rw.AcquireWriterLock(-1); try { _methodCache = MethodTable; @@ -251,7 +251,7 @@ private IPersistentMap ResetCache() } finally { - // _rw.ExitWriteLock(); + _rw.ReleaseWriterLock(); } } @@ -289,7 +289,7 @@ private IFn GetFn(object dispatchVal) /// The mest method. private IFn FindAndCacheBestMethod(object dispatchVal) { - // _rw.EnterWriteLock(); + _rw.AcquireWriterLock(-1); object bestValue; IPersistentMap mt = _methodTable; IPersistentMap pt = _preferTable; @@ -320,11 +320,11 @@ private IFn FindAndCacheBestMethod(object dispatchVal) } finally { - // _rw.ExitWriteLock(); + _rw.ReleaseWriterLock(); } // ensure basis has stayed stable throughout, else redo - // _rw.EnterWriteLock(); + _rw.AcquireWriterLock(-1); try { if (mt == _methodTable @@ -344,7 +344,7 @@ private IFn FindAndCacheBestMethod(object dispatchVal) } finally { - // _rw.ExitWriteLock(); + _rw.ReleaseWriterLock(); } } @@ -376,7 +376,7 @@ public IPersistentMap getPreferTable() [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "reset")] public MultiFn reset() { - // _rw.EnterWriteLock(); + _rw.AcquireWriterLock(-1); try { _methodTable = _methodCache = _preferTable = PersistentHashMap.EMPTY; @@ -385,7 +385,7 @@ public MultiFn reset() } finally { - // _rw.ExitWriteLock(); + _rw.ReleaseWriterLock(); } } @@ -786,11 +786,6 @@ private void Dispose(bool disposing) { if (!_disposed) { - if (disposing) - { - // ((IDisposable)_rw).Dispose(); - } - _disposed = true; } } diff --git a/Clojure/Clojure/Lib/Ref.cs b/Clojure/Clojure/Lib/Ref.cs index cedfc2229..c70561f24 100644 --- a/Clojure/Clojure/Lib/Ref.cs +++ b/Clojure/Clojure/Lib/Ref.cs @@ -161,7 +161,7 @@ internal TVal TVals /// /// Reader/writer lock for the reference. /// - // readonly ReaderWriterLockSlim _lock; + readonly ReaderWriterLock _lock; /// /// Info on the transaction locking this ref. @@ -250,7 +250,7 @@ public Ref(object initval, IPersistentMap meta) { _id = _ids.getAndIncrement(); _faults = new AtomicInteger(); - // _lock = new ReaderWriterLockSlim(LockRecursionPolicy.NoRecursion); + _lock = new ReaderWriterLock(); _tvals = new TVal(initval, 0); } @@ -344,14 +344,14 @@ object currentVal() { try { - // _lock.EnterReadLock(); + _lock.AcquireReaderLock(-1); if (_tvals != null) return _tvals.Val; throw new InvalidOperationException(String.Format("{0} is unbound.", ToString())); } finally { - // _lock.ExitReadLock(); + _lock.ReleaseReaderLock(); } } @@ -364,7 +364,7 @@ object currentVal() /// internal void EnterReadLock() { - // _lock.EnterReadLock(); + _lock.AcquireReaderLock(-1); } /// @@ -372,7 +372,7 @@ internal void EnterReadLock() /// internal void ExitReadLock() { - // _lock.ExitReadLock(); + _lock.ReleaseReaderLock(); } /// @@ -380,7 +380,7 @@ internal void ExitReadLock() /// internal void EnterWriteLock() { - // _lock.EnterWriteLock(); + _lock.AcquireWriterLock(-1); } @@ -389,7 +389,13 @@ internal void EnterWriteLock() /// internal bool TryEnterWriteLock(int msecTimeout) { - return true; // _lock.TryEnterWriteLock(msecTimeout); + try { + _lock.AcquireWriterLock(msecTimeout); + return true; + + } catch(ApplicationException) { + return false; + } } /// @@ -397,7 +403,7 @@ internal bool TryEnterWriteLock(int msecTimeout) /// internal void ExitWriteLock() { - // _lock.ExitWriteLock(); + _lock.ReleaseWriterLock(); } /// @@ -742,12 +748,6 @@ private void Dispose(bool disposing) { if (!_disposed) { - if (disposing) - { - // if ( _lock != null ) - // _lock.Dispose(); - } - _disposed = true; } } From 35b9c9bde367303c24c2c6db84a939ce7e444d39 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Fri, 14 Nov 2014 13:42:28 -0500 Subject: [PATCH 35/80] CLJCLR-49: Allow arrays of value types in ArraySeq.createFromObject --- Clojure/Clojure/Lib/ArraySeq.cs | 29 ++++++++++++++++++----------- 1 file changed, 18 insertions(+), 11 deletions(-) diff --git a/Clojure/Clojure/Lib/ArraySeq.cs b/Clojure/Clojure/Lib/ArraySeq.cs index 035676f42..73aad871f 100644 --- a/Clojure/Clojure/Lib/ArraySeq.cs +++ b/Clojure/Clojure/Lib/ArraySeq.cs @@ -87,13 +87,12 @@ internal static IArraySeq createFromObject(Object array) return new ArraySeq_uint(null, (uint[])aa, 0); case TypeCode.UInt64: return new ArraySeq_ulong(null, (ulong[])aa, 0); - case TypeCode.Object: - return new ArraySeq_object(null, (object[])aa, 0); default: { - Object[] objArray = new Object[aa.Length]; - Array.Copy(aa, objArray, aa.Length); - return new ArraySeq_object(null, objArray, 0); + Type[] elementTypes = { elementType }; + Type arraySeqType = typeof(TypedArraySeq<>).MakeGenericType(elementTypes); + object[] ctorParams = { PersistentArrayMap.EMPTY, array, 0 }; + return (IArraySeq)Activator.CreateInstance(arraySeqType, ctorParams); } } } @@ -232,7 +231,7 @@ internal static IArraySeq createFromObject(Object array) #endregion [Serializable] - public abstract class TypedArraySeq : ASeq, IArraySeq + public class TypedArraySeq : ASeq, IArraySeq { #region Data @@ -244,7 +243,7 @@ public abstract class TypedArraySeq : ASeq, IArraySeq #region C-tors - protected TypedArraySeq(IPersistentMap meta, T[] array, int index) + public TypedArraySeq(IPersistentMap meta, T[] array, int index) : base(meta) { _array = array; @@ -254,11 +253,19 @@ protected TypedArraySeq(IPersistentMap meta, T[] array, int index) #endregion - #region Abstract methods + #region Virtual methods - protected abstract T ConvertNum(object x); - protected abstract ISeq NextOne(); - protected abstract IObj DuplicateWithMeta(IPersistentMap meta); + protected virtual T ConvertNum(object x) { + return (T)x; + } + + protected virtual ISeq NextOne() { + return new TypedArraySeq(_meta, _array, _i + 1); + } + + protected virtual IObj DuplicateWithMeta(IPersistentMap meta) { + return new TypedArraySeq(meta, _array, _i); + } // TODO: first/reduce do a Numbers.num(x) conversion -- do we need that? From 8f92dfc2dfb479ecf3d6b1a39fb1edea968e7816 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Fri, 14 Nov 2014 13:42:28 -0500 Subject: [PATCH 36/80] CLJCLR-49: Allow arrays of value types in ArraySeq.createFromObject --- Clojure/Clojure/Lib/ArraySeq.cs | 29 ++++++++++++++++++----------- 1 file changed, 18 insertions(+), 11 deletions(-) diff --git a/Clojure/Clojure/Lib/ArraySeq.cs b/Clojure/Clojure/Lib/ArraySeq.cs index 035676f42..73aad871f 100644 --- a/Clojure/Clojure/Lib/ArraySeq.cs +++ b/Clojure/Clojure/Lib/ArraySeq.cs @@ -87,13 +87,12 @@ internal static IArraySeq createFromObject(Object array) return new ArraySeq_uint(null, (uint[])aa, 0); case TypeCode.UInt64: return new ArraySeq_ulong(null, (ulong[])aa, 0); - case TypeCode.Object: - return new ArraySeq_object(null, (object[])aa, 0); default: { - Object[] objArray = new Object[aa.Length]; - Array.Copy(aa, objArray, aa.Length); - return new ArraySeq_object(null, objArray, 0); + Type[] elementTypes = { elementType }; + Type arraySeqType = typeof(TypedArraySeq<>).MakeGenericType(elementTypes); + object[] ctorParams = { PersistentArrayMap.EMPTY, array, 0 }; + return (IArraySeq)Activator.CreateInstance(arraySeqType, ctorParams); } } } @@ -232,7 +231,7 @@ internal static IArraySeq createFromObject(Object array) #endregion [Serializable] - public abstract class TypedArraySeq : ASeq, IArraySeq + public class TypedArraySeq : ASeq, IArraySeq { #region Data @@ -244,7 +243,7 @@ public abstract class TypedArraySeq : ASeq, IArraySeq #region C-tors - protected TypedArraySeq(IPersistentMap meta, T[] array, int index) + public TypedArraySeq(IPersistentMap meta, T[] array, int index) : base(meta) { _array = array; @@ -254,11 +253,19 @@ protected TypedArraySeq(IPersistentMap meta, T[] array, int index) #endregion - #region Abstract methods + #region Virtual methods - protected abstract T ConvertNum(object x); - protected abstract ISeq NextOne(); - protected abstract IObj DuplicateWithMeta(IPersistentMap meta); + protected virtual T ConvertNum(object x) { + return (T)x; + } + + protected virtual ISeq NextOne() { + return new TypedArraySeq(_meta, _array, _i + 1); + } + + protected virtual IObj DuplicateWithMeta(IPersistentMap meta) { + return new TypedArraySeq(meta, _array, _i); + } // TODO: first/reduce do a Numbers.num(x) conversion -- do we need that? From 15f99aec3705554feec7d691b498351a62bd4555 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Wed, 19 Nov 2014 16:13:12 -0500 Subject: [PATCH 37/80] Stop assuming numeric conversions in ArraySeq --- Clojure/Clojure/Lib/ArraySeq.cs | 41 +++++++++++++++------------------ 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/Clojure/Clojure/Lib/ArraySeq.cs b/Clojure/Clojure/Lib/ArraySeq.cs index 73aad871f..86fa05d6d 100644 --- a/Clojure/Clojure/Lib/ArraySeq.cs +++ b/Clojure/Clojure/Lib/ArraySeq.cs @@ -255,7 +255,7 @@ public TypedArraySeq(IPersistentMap meta, T[] array, int index) #region Virtual methods - protected virtual T ConvertNum(object x) { + protected virtual T Convert(object x) { return (T)x; } @@ -352,13 +352,10 @@ public object reduce(IFn f, object start) public override int IndexOf(object value) { - if (Util.IsNumeric(value)) - { - T v = ConvertNum(value); - for (int j = _i; j < _array.Length; j++) - if (v.Equals(_array[j])) - return j - _i; - } + T v = Convert(value); + for (int j = _i; j < _array.Length; j++) + if (v.Equals(_array[j])) + return j - _i; return -1; } @@ -402,7 +399,7 @@ public ArraySeq_byte(IPersistentMap meta, byte[] array, int index) { } - protected override byte ConvertNum(object x) + protected override byte Convert(object x) { return Util.ConvertToByte(x); } @@ -431,7 +428,7 @@ public ArraySeq_sbyte(IPersistentMap meta, sbyte[] array, int index) { } - protected override sbyte ConvertNum(object x) + protected override sbyte Convert(object x) { return Util.ConvertToSByte(x); } @@ -458,7 +455,7 @@ public ArraySeq_short(IPersistentMap meta, short[] array, int index) { } - protected override short ConvertNum(object x) + protected override short Convert(object x) { return Util.ConvertToShort(x); } @@ -486,7 +483,7 @@ public ArraySeq_ushort(IPersistentMap meta, ushort[] array, int index) { } - protected override ushort ConvertNum(object x) + protected override ushort Convert(object x) { return Util.ConvertToUShort(x); } @@ -513,7 +510,7 @@ public ArraySeq_int(IPersistentMap meta, int[] array, int index) { } - protected override int ConvertNum(object x) + protected override int Convert(object x) { return Util.ConvertToInt(x); } @@ -541,7 +538,7 @@ public ArraySeq_uint(IPersistentMap meta, uint[] array, int index) { } - protected override uint ConvertNum(object x) + protected override uint Convert(object x) { return Util.ConvertToUInt(x); } @@ -568,7 +565,7 @@ public ArraySeq_long(IPersistentMap meta, long[] array, int index) { } - protected override long ConvertNum(object x) + protected override long Convert(object x) { return Util.ConvertToLong(x); } @@ -596,7 +593,7 @@ public ArraySeq_ulong(IPersistentMap meta, ulong[] array, int index) { } - protected override ulong ConvertNum(object x) + protected override ulong Convert(object x) { return Util.ConvertToULong(x); } @@ -623,7 +620,7 @@ public ArraySeq_float(IPersistentMap meta, float[] array, int index) { } - protected override float ConvertNum(object x) + protected override float Convert(object x) { return Util.ConvertToFloat(x); } @@ -650,7 +647,7 @@ public ArraySeq_double(IPersistentMap meta, double[] array, int index) { } - protected override double ConvertNum(object x) + protected override double Convert(object x) { return Util.ConvertToDouble(x); } @@ -677,7 +674,7 @@ public ArraySeq_char(IPersistentMap meta, char[] array, int index) { } - protected override char ConvertNum(object x) + protected override char Convert(object x) { return Util.ConvertToChar(x); } @@ -704,7 +701,7 @@ public ArraySeq_bool(IPersistentMap meta, bool[] array, int index) { } - protected override bool ConvertNum(object x) + protected override bool Convert(object x) { return RT.booleanCast(x); } @@ -731,7 +728,7 @@ public ArraySeq_decimal(IPersistentMap meta, decimal[] array, int index) { } - protected override decimal ConvertNum(object x) + protected override decimal Convert(object x) { return Util.ConvertToDecimal(x); } @@ -758,7 +755,7 @@ public ArraySeq_object(IPersistentMap meta, object[] array, int index) { } - protected override object ConvertNum(object x) + protected override object Convert(object x) { return x; } From 3b0a3f69064c9dc3bac10a01da9108180b6bcb47 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Wed, 19 Nov 2014 18:20:10 -0500 Subject: [PATCH 38/80] Start updating NewClassInstanceExpr to match new deftype --- .../CljCompiler/Ast/NewClassInstanceExpr.cs | 36 ++++++++++++++----- 1 file changed, 28 insertions(+), 8 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs index c0f56d367..46b98e4c7 100644 --- a/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs @@ -176,7 +176,8 @@ internal static ObjExpr Build( Dictionary> overrideables; - GatherMethods(superClass, RT.seq(interfaces), out overrideables); + Dictionary> explicits; + GatherMethods(superClass, RT.seq(interfaces), out overrideables, out explicits); ret._methodMap = overrideables; @@ -229,7 +230,7 @@ internal static ObjExpr Build( IPersistentCollection methods = null; for (ISeq s = methodForms; s != null; s = RT.next(s)) { - NewInstanceMethod m = NewInstanceMethod.Parse(ret, (ISeq)RT.first(s), thisTag, overrideables); + NewInstanceMethod m = NewInstanceMethod.Parse(ret, (ISeq)RT.first(s), thisTag, overrideables, explicits); methods = RT.conj(methods, m); } @@ -294,14 +295,17 @@ static string SlashName(Type t) static void GatherMethods( Type st, ISeq interfaces, - out Dictionary> overrides) + out Dictionary> overrides, + out Dictionary> explicits) { - Dictionary> allm = new Dictionary>(); - GatherMethods(st, allm); - for (; interfaces != null; interfaces = interfaces.next()) - GatherMethods((Type)interfaces.first(), allm); + overrides = new Dictionary>(); + explicits = new Dictionary>(); - overrides = allm; + GatherMethods(st, overrides); + for (; interfaces != null; interfaces = interfaces.next()) { + GatherMethods((Type)interfaces.first(), overrides); + GatherInterfaceExplicits((Type)interfaces.first(),explicits); + } } static void GatherMethods(Type t, Dictionary> mm) @@ -340,6 +344,22 @@ static void AddMethod(Dictionary> mm, IPersi } value.Add(m); } + + private static void GatherInterfaceExplicits(Type type, Dictionary> explicits) + { + foreach (MethodInfo m in type.GetMethods(BindingFlags.FlattenHierarchy | BindingFlags.Instance | BindingFlags.Public | BindingFlags.NonPublic)) + { + List value; + IPersistentVector mk = MSig(m); + if ( ! explicits.TryGetValue(mk,out value) ) + { + value = new List(); + explicits[mk] = value; + } + if (!value.Contains(m)) + value.Add(m); + } + } #endregion From 8e40e53bae871f70ff3014c8674fbfb903891611 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Wed, 19 Nov 2014 18:20:31 -0500 Subject: [PATCH 39/80] Make compiler exception fields public --- Clojure/Clojure/CljCompiler/Compiler.cs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index 75ea5d9e9..056beda87 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -1927,8 +1927,8 @@ public sealed class CompilerException : Exception { #region Data - string FileSource { get; set; } - int Line { get; set; } + public string FileSource { get; set; } + public int Line { get; set; } #endregion From 5057b396d87ff8e87d5a6d4c7ee6debc588d9ad7 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 25 Jan 2015 10:03:33 -0500 Subject: [PATCH 40/80] Add unity-install script --- unity-install.sh | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100755 unity-install.sh diff --git a/unity-install.sh b/unity-install.sh new file mode 100755 index 000000000..9a36f8f0e --- /dev/null +++ b/unity-install.sh @@ -0,0 +1,16 @@ +echo "clean up old dlls" +rm -fr $1/Assets/Arcadia/*.dll + +echo "copy infrastructure" +cp bin/3.5/Release/{Clojure,Microsoft.{Dynamic,Scripting,Scripting.{Core,Metadata}}}.dll $1/Assets/Arcadia/ + +echo "copy AOT'd clojure files" +cp bin/3.5/Release/*.clj.dll $1/Assets/Arcadia/ + +echo "copy clojure source" +rm -fr $1/Assets/Arcadia/clojure +cp -r bin/3.5/Release/clojure $1/Assets/Arcadia +rm -fr $1/Assets/Arcadia/clojure/*samples* +rm -fr $1/Assets/Arcadia/clojure/*run_tests* +rm -fr $1/Assets/Arcadia/clojure/*dm-test* +rm -fr $1/Assets/Arcadia/clojure/*test_* From e2b01021f054c9b0c555181ec16490060976fc63 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 25 Jan 2015 10:04:42 -0500 Subject: [PATCH 41/80] Type hint non-primitive types in ObjExprs Makes defcomponents more powerful by allowing complex types which show up in the inspector. Keep an eye on this commit, as it may have farther reaching consequences. --- Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs b/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs index 81ce0794a..e5a58aaac 100644 --- a/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs @@ -507,7 +507,7 @@ protected void EmitClosedOverFields(TypeBuilder tb) attributes |= FieldAttributes.InitOnly; } - Type type = lb.PrimitiveType ?? typeof(object); + Type type = lb.HasClrType ? lb.ClrType : (lb.PrimitiveType ?? typeof(object)); FieldBuilder fb = markVolatile ? tb.DefineField(lb.Name, type, new Type[] { typeof(IsVolatile) }, Type.EmptyTypes, attributes) From f3fac9dccee3cb2036cb522ceba148a7fbc5fda8 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 25 Jan 2015 10:07:00 -0500 Subject: [PATCH 42/80] Update defcomponent constructor logic --- Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs | 6 ++++++ Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs index 46b98e4c7..6bf44ba8d 100644 --- a/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs @@ -438,6 +438,12 @@ protected override void EmitStatics(TypeBuilder tb) } } + protected override ConstructorBuilder EmitConstructor(TypeBuilder fnTB, Type baseType) + { + EmitClosedOverFields(fnTB); + return base.EmitConstructor(fnTB, baseType); + } + protected override void EmitMethods(TypeBuilder tb) { HashSet implemented = new HashSet(); diff --git a/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs b/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs index e5a58aaac..201e66d6a 100644 --- a/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs @@ -534,7 +534,7 @@ private void EmitProtocolCallsites(TypeBuilder tb) } } - private ConstructorBuilder EmitConstructor(TypeBuilder fnTB, Type baseType) + protected virtual ConstructorBuilder EmitConstructor(TypeBuilder fnTB, Type baseType) { ConstructorBuilder cb = fnTB.DefineConstructor(MethodAttributes.Public, CallingConventions.HasThis, CtorTypes()); CljILGen gen = new CljILGen(cb.GetILGenerator()); From 87ccf71eea29a7f875d5e9216557c12083f3e538 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Wed, 28 Jan 2015 21:18:25 -0500 Subject: [PATCH 43/80] Implement *debug* and debug symbol emission --- Clojure/Clojure/CljCompiler/Ast/GenContext.cs | 19 +++++++------------ Clojure/Clojure/CljCompiler/Compiler.cs | 2 ++ 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/GenContext.cs b/Clojure/Clojure/CljCompiler/Ast/GenContext.cs index c3b067291..4137db30d 100644 --- a/Clojure/Clojure/CljCompiler/Ast/GenContext.cs +++ b/Clojure/Clojure/CljCompiler/Ast/GenContext.cs @@ -106,18 +106,13 @@ private static GenContext CreateGenContext(string sourceName, string assyName, s } AssemblyName aname = new AssemblyName(assyName); - return new GenContext(directory, aname, extension, createDynInitHelper, sourceName); - } - - private GenContext(string directory, AssemblyName aname, string extension, bool createDynInitHelper, string sourceName) - { - // TODO: Make this settable from a *debug* flag -#if DEBUG - _isDebuggable = true; -#else - _isDebuggable = false; -#endif - + return new GenContext(directory, aname, extension, createDynInitHelper, sourceName); + } + + private GenContext(string directory, AssemblyName aname, string extension, bool createDynInitHelper, string sourceName) + { + _isDebuggable = (bool)Compiler.DebugVar.deref(); + _assyGen = new AssemblyGen(aname, directory, extension, _isDebuggable); if ( createDynInitHelper ) _dynInitHelper = new DynInitHelper(_assyGen, GenerateName()); diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index 056beda87..ba50d999f 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -125,6 +125,8 @@ internal static Type FindDuplicateType(string typename) internal static readonly Var CompileFilesVar = Var.intern(Namespace.findOrCreate(Symbol.intern("clojure.core")), Symbol.intern("*compile-files*"), false).setDynamic(); + internal static readonly Var DebugVar = Var.intern(Namespace.findOrCreate(Symbol.intern("clojure.core")), + Symbol.intern("*debug*"), false).setDynamic(); internal static readonly Var InstanceVar = Var.intern(Namespace.findOrCreate(Symbol.intern("clojure.core")), Symbol.intern("instance?"), false).setDynamic(); From 77386bd4f3657970cf10b0547c72ff7db5cc2245 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Thu, 29 Jan 2015 23:28:11 -0500 Subject: [PATCH 44/80] Update unity-install to new layout --- unity-install.sh | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/unity-install.sh b/unity-install.sh index 9a36f8f0e..dd0707032 100755 --- a/unity-install.sh +++ b/unity-install.sh @@ -1,16 +1,17 @@ echo "clean up old dlls" -rm -fr $1/Assets/Arcadia/*.dll +rm -fr $1/Assets/Arcadia/Infrastructure/*.dll +rm -fr $1/Assets/Arcadia/Compiled/*.dll echo "copy infrastructure" -cp bin/3.5/Release/{Clojure,Microsoft.{Dynamic,Scripting,Scripting.{Core,Metadata}}}.dll $1/Assets/Arcadia/ +cp bin/3.5/Release/{Clojure,Microsoft.{Dynamic,Scripting,Scripting.{Core,Metadata}}}.dll $1/Assets/Arcadia/Infrastructure echo "copy AOT'd clojure files" -cp bin/3.5/Release/*.clj.dll $1/Assets/Arcadia/ +cp bin/3.5/Release/*.clj.dll $1/Assets/Arcadia/Compiled echo "copy clojure source" -rm -fr $1/Assets/Arcadia/clojure -cp -r bin/3.5/Release/clojure $1/Assets/Arcadia -rm -fr $1/Assets/Arcadia/clojure/*samples* -rm -fr $1/Assets/Arcadia/clojure/*run_tests* -rm -fr $1/Assets/Arcadia/clojure/*dm-test* -rm -fr $1/Assets/Arcadia/clojure/*test_* +rm -fr $1/Assets/Arcadia/Source/clojure +cp -r bin/3.5/Release/clojure $1/Assets/Arcadia/Source +rm -fr $1/Assets/Arcadia/Source/clojure/*samples* +rm -fr $1/Assets/Arcadia/Source/clojure/*run_tests* +rm -fr $1/Assets/Arcadia/Source/clojure/*dm-test* +rm -fr $1/Assets/Arcadia/Source/clojure/*test_* From eb7f75ceb8b0afa71b30c8c963a130385a1c95f2 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Mon, 2 Feb 2015 00:20:12 -0500 Subject: [PATCH 45/80] Make install script install into Arcadia folder --- unity-install.sh | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/unity-install.sh b/unity-install.sh index dd0707032..954429fb4 100755 --- a/unity-install.sh +++ b/unity-install.sh @@ -1,17 +1,17 @@ echo "clean up old dlls" -rm -fr $1/Assets/Arcadia/Infrastructure/*.dll -rm -fr $1/Assets/Arcadia/Compiled/*.dll +rm -fr $1/Infrastructure/*.dll +rm -fr $1/Compiled/*.dll echo "copy infrastructure" -cp bin/3.5/Release/{Clojure,Microsoft.{Dynamic,Scripting,Scripting.{Core,Metadata}}}.dll $1/Assets/Arcadia/Infrastructure +cp bin/3.5/Release/{Clojure,Microsoft.{Dynamic,Scripting,Scripting.{Core,Metadata}}}.dll $1/Infrastructure echo "copy AOT'd clojure files" -cp bin/3.5/Release/*.clj.dll $1/Assets/Arcadia/Compiled +cp bin/3.5/Release/*.clj.dll $1/Compiled echo "copy clojure source" -rm -fr $1/Assets/Arcadia/Source/clojure -cp -r bin/3.5/Release/clojure $1/Assets/Arcadia/Source -rm -fr $1/Assets/Arcadia/Source/clojure/*samples* -rm -fr $1/Assets/Arcadia/Source/clojure/*run_tests* -rm -fr $1/Assets/Arcadia/Source/clojure/*dm-test* -rm -fr $1/Assets/Arcadia/Source/clojure/*test_* +rm -fr $1/Source/clojure +cp -r bin/3.5/Release/clojure $1/Source +rm -fr $1/Source/clojure/*samples* +rm -fr $1/Source/clojure/*run_tests* +rm -fr $1/Source/clojure/*dm-test* +rm -fr $1/Source/clojure/*test_* From 24f58a723e838d6373b2104871c856ab1d587c5d Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Mon, 2 Feb 2015 00:25:55 -0500 Subject: [PATCH 46/80] Comment out gvec in clojure.core --- Clojure/Clojure.Source/clojure/core.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Clojure/Clojure.Source/clojure/core.clj b/Clojure/Clojure.Source/clojure/core.clj index 3e6549cb0..4e6fd576a 100644 --- a/Clojure/Clojure.Source/clojure/core.clj +++ b/Clojure/Clojure.Source/clojure/core.clj @@ -6440,7 +6440,7 @@ (load "genclass") (load "core_deftype") (load "core/protocols") -(load "gvec") +; (load "gvec") (load "instant") (load "uuid") From d5cfb97f1dc3cf0f4264efdf26e3ea69765de0e7 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Mon, 2 Feb 2015 00:51:38 -0500 Subject: [PATCH 47/80] Make deftypes require the namespace they were defined in --- Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs | 18 ++++++++++++++++++ Clojure/Clojure/Lib/RT.cs | 3 +++ 2 files changed, 21 insertions(+) diff --git a/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs b/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs index 201e66d6a..f14da17db 100644 --- a/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs @@ -437,6 +437,9 @@ private void DefineStaticConstructor(TypeBuilder fnTB) private void EmitStaticConstructorBody(CljILGen ilg) { GenContext.EmitDebugInfo(ilg, SpanMap); + + if(IsDefType) + EmitRequireNamespace(ilg); if (Constants.count() > 0) EmitConstantFieldInits(ilg); @@ -446,6 +449,21 @@ private void EmitStaticConstructorBody(CljILGen ilg) ilg.Emit(OpCodes.Ret); } + + private void EmitRequireNamespace(CljILGen ilg) + { + if(((Namespace)RT.CurrentNSVar.deref()).Name.ToString() != "clojure.core") + { + EmitValue(RT.RequireVar, ilg); + ilg.Emit(OpCodes.Call, Compiler.Method_Var_getRawRoot); + ilg.Emit(OpCodes.Castclass, typeof(IFn)); + ilg.EmitNull(); + ilg.EmitString(((Namespace)RT.CurrentNSVar.deref()).Name.Name); + ilg.EmitCall(Compiler.Method_Symbol_intern2); + ilg.Emit(OpCodes.Callvirt, Compiler.Methods_IFn_invoke[1]); + ilg.Emit(OpCodes.Pop); + } + } private void EmitKeywordCallsiteInits(CljILGen ilg) { diff --git a/Clojure/Clojure/Lib/RT.cs b/Clojure/Clojure/Lib/RT.cs index 5b062f5d5..9bee419e3 100644 --- a/Clojure/Clojure/Lib/RT.cs +++ b/Clojure/Clojure/Lib/RT.cs @@ -416,6 +416,9 @@ public static readonly Var AllowSymbolEscapeVar #endregion #region Vars (miscellaneous) + + public static readonly Var RequireVar + = Var.intern(ClojureNamespace, Symbol.intern("require")); public static readonly Var AllowUnresolvedVarsVar //= Var.intern(CLOJURE_NS, Symbol.intern("*allow-unresolved-vars*"), RT.F); From 8eb735fe2de31b1e9b4c308a2c470af30d947ea1 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Mon, 13 Apr 2015 13:21:16 -0400 Subject: [PATCH 48/80] Build debug by default --- unity-build.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unity-build.sh b/unity-build.sh index ff9487b50..bccd690bf 100755 --- a/unity-build.sh +++ b/unity-build.sh @@ -1,2 +1,2 @@ rm -fr dist bin -EnableNuGetPackageRestore=true xbuild Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Release 3.5" /p:Platform="Any CPU" +EnableNuGetPackageRestore=true xbuild Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Debug 3.5" /p:Platform="Any CPU" From 341ed51bf848e3b43d5705b57ca427120fead960 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Tue, 5 May 2015 02:41:58 -0400 Subject: [PATCH 49/80] Add missing methods to Numbers --- Clojure/Clojure/Lib/Numbers.cs | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/Clojure/Clojure/Lib/Numbers.cs b/Clojure/Clojure/Lib/Numbers.cs index c41a9d225..69bb29a24 100644 --- a/Clojure/Clojure/Lib/Numbers.cs +++ b/Clojure/Clojure/Lib/Numbers.cs @@ -567,19 +567,19 @@ public static int unsignedShiftRightInt(int x, int n) } [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly")] - static long unsignedShiftRight(Object x, Object y) + public static long unsignedShiftRight(object x, object y) { return unsignedShiftRight(bitOpsCast(x), bitOpsCast(y)); } [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly")] - public static long unsignedShiftRight(Object x, long y) + public static long unsignedShiftRight(object x, long y) { return unsignedShiftRight(bitOpsCast(x), y); } [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly")] - public static long unsignedShiftRight(long x, Object y) + public static long unsignedShiftRight(long x, object y) { return unsignedShiftRight(x, bitOpsCast(y)); } @@ -2650,6 +2650,22 @@ public static long xor(long x, long y) #endregion + #region not + + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "and")] + public static long not(object x) + { + return not(bitOpsCast(x)); + } + + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "and")] + public static long not(long x) + { + return ~x; + } + + #endregion + #region andNot [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "and")] From 0bb3314aa1aff1dfc7960e2add560d653b90b2c0 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Tue, 5 May 2015 02:42:40 -0400 Subject: [PATCH 50/80] Make RT/LoadCljScript public --- Clojure/Clojure/Lib/RT.cs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Clojure/Clojure/Lib/RT.cs b/Clojure/Clojure/Lib/RT.cs index 9bee419e3..1904adf5a 100644 --- a/Clojure/Clojure/Lib/RT.cs +++ b/Clojure/Clojure/Lib/RT.cs @@ -3422,12 +3422,12 @@ private static void MaybeLoadCljScript(string cljname) LoadCljScript(cljname, false); } - static void LoadCljScript(string cljname) + public static void LoadCljScript(string cljname) { LoadCljScript(cljname, true); } - static void LoadCljScript(string cljname, bool failIfNotFound) + public static void LoadCljScript(string cljname, bool failIfNotFound) { FileInfo cljInfo = FindFile(cljname); if (cljInfo != null) From 070300d92c52e615dba84316e2810369dfdf0a23 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Tue, 5 May 2015 02:44:38 -0400 Subject: [PATCH 51/80] Eliminate dynamic call sites from clojure.core --- Clojure/Clojure.Source/clojure/clr/io.clj | 4 +- Clojure/Clojure.Source/clojure/clr/shell.clj | 4 +- Clojure/Clojure.Source/clojure/core.clj | 996 +++++++++--------- Clojure/Clojure.Source/clojure/core_print.clj | 2 +- Clojure/Clojure.Source/clojure/core_proxy.clj | 36 +- Clojure/Clojure.Source/clojure/main.clj | 180 ++-- .../clojure/pprint/cl_format.clj | 6 +- .../clojure/pprint/dispatch.clj | 2 +- .../clojure/pprint/pretty_writer.clj | 61 +- .../Clojure.Source/clojure/reflect/clr.clj | 16 +- Clojure/Clojure.Source/clojure/stacktrace.clj | 8 +- Clojure/Clojure.Source/clojure/string.clj | 21 +- Clojure/Clojure.Source/clojure/test/junit.clj | 4 +- Clojure/Clojure.Source/clojure/test/tap.clj | 82 +- Clojure/Clojure/CljCompiler/Ast/HostExpr.cs | 18 +- Clojure/Clojure/CljCompiler/Ast/MethodExpr.cs | 2 + Clojure/Clojure/Runtime/Reflector.cs | 9 +- 17 files changed, 743 insertions(+), 708 deletions(-) diff --git a/Clojure/Clojure.Source/clojure/clr/io.clj b/Clojure/Clojure.Source/clojure/clr/io.clj index cda5518ea..30018ba28 100644 --- a/Clojure/Clojure.Source/clojure/clr/io.clj +++ b/Clojure/Clojure.Source/clojure/clr/io.clj @@ -373,8 +373,8 @@ (let [size (.Read input buffer 0 len)] (when (pos? size) (let [ cnt (.GetCharCount decoder buffer 0 size) - chbuf (make-array Char cnt)] - (do (.GetChars decoder buffer 0 size chbuf 0) + ^|System.Char[]| chbuf (make-array Char cnt)] + (do (.GetChars decoder buffer 0 (int size) chbuf 0) (.Write output chbuf 0 cnt) (recur)))))))) diff --git a/Clojure/Clojure.Source/clojure/clr/shell.clj b/Clojure/Clojure.Source/clojure/clr/shell.clj index 4dd991162..0370f30d9 100644 --- a/Clojure/Clojure.Source/clojure/clr/shell.clj +++ b/Clojure/Clojure.Source/clojure/clr/shell.clj @@ -112,8 +112,8 @@ Halloway."} [& args] (let [[cmd opts] (parse-args args) {:keys [in in-enc out-enc]} opts - proc (Process/Start - (make-process-info cmd out-enc (:env opts) (:dir opts)))] + ^ProcessStartInfo process-info (make-process-info cmd out-enc (:env opts) (:dir opts)) + proc (Process/Start process-info)] (future (with-open [stdin (.StandardInput proc)] (when in diff --git a/Clojure/Clojure.Source/clojure/core.clj b/Clojure/Clojure.Source/clojure/core.clj index 4e6fd576a..1de4922b7 100644 --- a/Clojure/Clojure.Source/clojure/core.clj +++ b/Clojure/Clojure.Source/clojure/core.clj @@ -566,10 +566,10 @@ [& clauses] (when clauses (list 'if (first clauses) - (if (next clauses) - (second clauses) - (throw (ArgumentException. ;;;IllegalArgumentException. - "cond requires an even number of forms"))) + (if (next clauses) + (second clauses) + (throw (ArgumentException. ;;;IllegalArgumentException. + "cond requires an even number of forms"))) (cons 'clojure.core/cond (next (next clauses)))))) (defn keyword @@ -631,7 +631,7 @@ ([^clojure.lang.IFn f x y z args] (. f (applyTo (list* x y z args)))) ([^clojure.lang.IFn f a b c d & args] - (. f (applyTo (cons a (cons b (cons c (cons d (spread args))))))))) + (. f (applyTo (cons a (cons b (cons c (cons d (spread args))))))))) (defn vary-meta "Returns an object of the same type and value as obj, with @@ -725,12 +725,12 @@ :static true} [x] (. clojure.lang.Delay (force x))) -(defmacro if-not +(defmacro if-not "Evaluates test. If logical false, evaluates and returns then expr, - otherwise else expr, if supplied, else nil." + otherwise else expr, if supplied, else nil." {:added "1.0"} - ([test then] `(if-not ~test ~then nil)) - ([test then else] + ([test then] `(if-not ~test ~then nil)) + ([test then else] `(if (not ~test) ~then ~else))) (defn identical? @@ -1331,17 +1331,17 @@ {:inline (fn [x n] `(. clojure.lang.Numbers (unsignedShiftRight ~x ~n))) :added "1.6"} [x n] (. clojure.lang.Numbers unsignedShiftRight x n)) - - (defn integer? - "Returns true if n is an integer" + + (defn integer? + "Returns true if n is an integer" {:added "1.0" :static true} - [n] - (or (instance? Int32 n) (instance? UInt32 n) ;;; Integer -> Int32, added UInt32 - (instance? Int64 n) (instance? UInt64 n) ;;; Long -> Int64, added UInt64 - (instance? clojure.lang.BigInt n) - (instance? BigInteger n) (instance? Char n) ;;; added Char test - (instance? Int16 n) (instance? UInt16 n) ;;; Short -> Int16, added UInt16 + [n] + (or (instance? Int32 n) (instance? UInt32 n) ;;; Integer -> Int32, added UInt32 + (instance? Int64 n) (instance? UInt64 n) ;;; Long -> Int64, added UInt64 + (instance? clojure.lang.BigInt n) + (instance? BigInteger n) (instance? Char n) ;;; added Char test + (instance? Int16 n) (instance? UInt16 n) ;;; Short -> Int16, added UInt16 (instance? Byte n) (instance? SByte n))) ;;; Added SByte test (defn even? @@ -1407,14 +1407,14 @@ ;;map stuff (defn contains? - "Returns true if key is present in the given collection, otherwise - returns false. Note that for numerically indexed collections like - vectors and Java arrays, this tests if the numeric key is within the - range of indexes. 'contains?' operates constant or logarithmic time; + "Returns true if key is present in the given collection, otherwise + returns false. Note that for numerically indexed collections like + vectors and Java arrays, this tests if the numeric key is within the + range of indexes. 'contains?' operates constant or logarithmic time; it will not perform a linear search for a value. See also 'some'." {:added "1.0" :static true} - [coll key] (. clojure.lang.RT (contains coll key))) + [coll key] (. clojure.lang.RT (contains coll key))) (defn get "Returns the value mapped to key, not-found or nil if key not present." @@ -1679,7 +1679,7 @@ "Removes the method of multimethod associated with dispatch-value." {:added "1.0" :static true} - [multifn dispatch-val] + [^clojure.lang.MultiFn multifn dispatch-val] (. multifn removeMethod dispatch-val)) (defn prefer-method @@ -1687,7 +1687,7 @@ when there is a conflict" {:added "1.0" :static true} - [multifn dispatch-val-x dispatch-val-y] + [^clojure.lang.MultiFn multifn dispatch-val-x dispatch-val-y] (. multifn preferMethod dispatch-val-x dispatch-val-y)) (defn methods @@ -1711,14 +1711,14 @@ ;;;;;;;;; var stuff -(defmacro ^{:private true} assert-args - [& pairs] - `(do (when-not ~(first pairs) - (throw (ArgumentException. ;;;IllegalArgumentException. - (str (first ~'&form) " requires " ~(second pairs) " in " ~'*ns* ":" (:line (meta ~'&form)))))) - ~(let [more (nnext pairs)] - (when more - (list* `assert-args more))))) +(defmacro ^{:private true} assert-args + [& pairs] + `(do (when-not ~(first pairs) + (throw (ArgumentException. ;;;IllegalArgumentException. + (str (first ~'&form) " requires " ~(second pairs) " in " ~'*ns* ":" (:line (meta ~'&form)))))) + ~(let [more (nnext pairs)] + (when more + (list* `assert-args more))))) (defmacro if-let "bindings => binding-form test @@ -1754,7 +1754,7 @@ (when temp# (let [~form temp#] ~@body))))) - + (defmacro if-some "bindings => binding-form test @@ -1825,17 +1825,17 @@ :static true} [] (clojure.lang.Var/getThreadBindings)) - -(defmacro binding - "binding => var-symbol init-expr - - Creates new bindings for the (already-existing) vars, with the - supplied initial values, executes the exprs in an implicit do, then + +(defmacro binding + "binding => var-symbol init-expr + + Creates new bindings for the (already-existing) vars, with the + supplied initial values, executes the exprs in an implicit do, then re-establishes the bindings that existed before. The new bindings are made in parallel (unlike let); all init-exprs are evaluated - before the vars are bound to their new values." + before the vars are bound to their new values." {:added "1.0"} - [bindings & body] + [bindings & body] (assert-args (vector? bindings) "a vector for its binding" (even? (count bindings)) "an even number of forms in binding vector") @@ -2012,17 +2012,17 @@ [^clojure.lang.Agent a f & args] (.dispatch a (binding [*agent* a] (binding-conveyor-fn f)) args true)) ;;; No CLR equivalent. keep old true/false style -- (apply send-via clojure.lang.Agent/soloExecutor a f args)) -(defn release-pending-sends - "Normally, actions sent directly or indirectly during another action - are held until the action completes (changes the agent's - state). This function can be used to dispatch any pending sent - actions immediately. This has no impact on actions sent during a - transaction, which are still held until commit. If no action is - occurring, does nothing. Returns the number of actions dispatched." +(defn release-pending-sends + "Normally, actions sent directly or indirectly during another action + are held until the action completes (changes the agent's + state). This function can be used to dispatch any pending sent + actions immediately. This has no impact on actions sent during a + transaction, which are still held until commit. If no action is + occurring, does nothing. Returns the number of actions dispatched." {:added "1.0" :static true} - [] (clojure.lang.Agent/releasePendingSends)) - + [] (clojure.lang.Agent/releasePendingSends)) + (defn add-watch "Adds a watch function to an agent/atom/var/ref reference. The watch fn must be a fn of 4 args: a key, the reference, its old-state, its @@ -2047,7 +2047,7 @@ :static true} [^clojure.lang.IRef reference key] (.removeWatch reference key)) - + (defn agent-error "Returns the exception thrown during an asynchronous action of the agent if the agent is failed. Returns nil if the agent is not @@ -2141,33 +2141,33 @@ :static true} [] (. clojure.lang.Agent shutdown)) -(defn ref - "Creates and returns a Ref with an initial value of x and zero or - more options (in any order): - - :meta metadata-map - - :validator validate-fn - - :min-history (default 0) - :max-history (default 10) - - If metadata-map is supplied, it will become the metadata on the - ref. validate-fn must be nil or a side-effect-free fn of one - argument, which will be passed the intended new state on any state - change. If the new state is unacceptable, the validate-fn should - return false or throw an exception. validate-fn will be called on - transaction commit, when all refs have their final values. - - Normally refs accumulate history dynamically as needed to deal with - read demands. If you know in advance you will need a history you can - set :min-history to ensure that it will be available when first needed (instead - of after a read fault). History is limited and the limit can be set - with :max-history." +(defn ref + "Creates and returns a Ref with an initial value of x and zero or + more options (in any order): + + :meta metadata-map + + :validator validate-fn + + :min-history (default 0) + :max-history (default 10) + + If metadata-map is supplied, it will become the metadata on the + ref. validate-fn must be nil or a side-effect-free fn of one + argument, which will be passed the intended new state on any state + change. If the new state is unacceptable, the validate-fn should + return false or throw an exception. validate-fn will be called on + transaction commit, when all refs have their final values. + + Normally refs accumulate history dynamically as needed to deal with + read demands. If you know in advance you will need a history you can + set :min-history to ensure that it will be available when first needed (instead + of after a read fault). History is limited and the limit can be set + with :max-history." {:added "1.0" :static true } - ([x] (new clojure.lang.Ref x)) + ([x] (new clojure.lang.Ref x)) ([x & options] (let [ r ^clojure.lang.Ref (setup-reference (ref x) options) opts (apply hash-map options)] @@ -2186,9 +2186,9 @@ timeout-val)))) (defn deref - "Also reader macro: @ref/@agent/@var/@atom/@delay/@future/@promise. Within a transaction, - returns the in-transaction-value of ref, else returns the - most-recently-committed value of ref. When applied to a var, agent + "Also reader macro: @ref/@agent/@var/@atom/@delay/@future/@promise. Within a transaction, + returns the in-transaction-value of ref, else returns the + most-recently-committed value of ref. When applied to a var, agent or atom, returns its current state. When applied to a delay, forces it if not already forced. When applied to a future, will block if computation not complete. When applied to a promise, will block @@ -2252,18 +2252,18 @@ [^clojure.lang.IAtom atom newval] (.reset atom newval)) (defn set-validator - "Sets the validator-fn for a var/ref/agent/atom. validator-fn must be nil or a - side-effect-free fn of one argument, which will be passed the intended - new state on any state change. If the new state is unacceptable, the - validator-fn should return false or throw an exception. If the current state (root - value if var) is not acceptable to the new validator, an exception - will be thrown and the validator will not be changed." + "Sets the validator-fn for a var/ref/agent/atom. validator-fn must be nil or a + side-effect-free fn of one argument, which will be passed the intended + new state on any state change. If the new state is unacceptable, the + validator-fn should return false or throw an exception. If the current state (root + value if var) is not acceptable to the new validator, an exception + will be thrown and the validator will not be changed." {:added "1.0" :static true} - [^clojure.lang.IRef iref validator-fn] (. iref (setValidator validator-fn))) + [^clojure.lang.IRef iref validator-fn] (. iref (setValidator validator-fn))) (defn get-validator - "Gets the validator-fn for a var/ref/agent/atom." + "Gets the validator-fn for a var/ref/agent/atom." {:added "1.0" :static true} [^clojure.lang.IRef iref] (. iref (getValidator))) @@ -2337,7 +2337,7 @@ {:added "1.1" :static true} ([^clojure.lang.Ref ref] - (.getMinHistory ref)) + (.MinHistory ref)) ;;; was (.getMinHistory ref) ([^clojure.lang.Ref ref n] (.setMinHistory ref n))) @@ -2346,7 +2346,7 @@ {:added "1.1" :static true} ([^clojure.lang.Ref ref] - (.getMaxHistory ref)) + (.MaxHistory ref)) ;;; was (.getMaxHistory ref) ([^clojure.lang.Ref ref n] (.setMaxHistory ref n))) @@ -2374,17 +2374,17 @@ (runInTransaction (fn [] ~@body)))) -(defmacro io! - "If an io! block occurs in a transaction, throws an - IllegalStateException, else runs body in an implicit do. If the - first expression in body is a literal string, will use that as the - exception message." +(defmacro io! + "If an io! block occurs in a transaction, throws an + IllegalStateException, else runs body in an implicit do. If the + first expression in body is a literal string, will use that as the + exception message." {:added "1.0"} - [& body] - (let [message (when (string? (first body)) (first body)) - body (if message (next body) body)] - `(if (clojure.lang.LockingTransaction/isRunning) - (throw (new InvalidOperationException ~(or message "I/O in transaction"))) ;;; IllegalStateException + [& body] + (let [message (when (string? (first body)) (first body)) + body (if message (next body) body)] + `(if (clojure.lang.LockingTransaction/isRunning) + (throw (new InvalidOperationException ~(or message "I/O in transaction"))) ;;; IllegalStateException (do ~@body)))) (defn volatile! @@ -2548,15 +2548,15 @@ :added "1.0"} not-every? (comp not every?)) -(defn some - "Returns the first logical true value of (pred x) for any x in coll, - else nil. One common idiom is to use a set as pred, for example - this will return :fred if :fred is in the sequence, otherwise nil: - (some #{:fred} coll)" +(defn some + "Returns the first logical true value of (pred x) for any x in coll, + else nil. One common idiom is to use a set as pred, for example + this will return :fred if :fred is in the sequence, otherwise nil: + (some #{:fred} coll)" {:added "1.0" :static true} - [pred coll] - (when (seq coll) + [pred coll] + (when (seq coll) (or (pred (first coll)) (recur pred (next coll))))) (def @@ -3081,9 +3081,9 @@ the head of the sequence. Returns nil." {:added "1.0"} [seq-exprs & body] - (assert-args - (vector? seq-exprs) "a vector for its binding" - (even? (count seq-exprs)) "an even number of forms in binding vector") + (assert-args + (vector? seq-exprs) "a vector for its binding" + (even? (count seq-exprs)) "an even number of forms in binding vector") (let [step (fn step [recform exprs] (if-not exprs [true `(do ~@body)] @@ -3131,7 +3131,7 @@ (let [~k (first ~seq-)] ~subform ~@(when needrec [recform]))))))])))))] - (nth (step nil (seq seq-exprs)) 1))) + (nth (step nil (seq seq-exprs)) 1))) (defn await "Blocks the current thread (indefinitely!) until all actions @@ -3141,13 +3141,13 @@ {:added "1.0" :static true} [& agents] - (io! "await in transaction" - (when *agent* - (throw (new Exception "Can't await in agent action"))) - (let [latch (new clojure.lang.CountDownLatch (count agents)) ;;; java.util.concurrent.CountDownLatch - count-down (fn [agent] (. latch (CountDown)) agent)] ;;; countDown - (doseq [agent agents] - (send agent count-down)) + (io! "await in transaction" + (when *agent* + (throw (new Exception "Can't await in agent action"))) + (let [latch (new clojure.lang.CountDownLatch (count agents)) ;;; java.util.concurrent.CountDownLatch + count-down (fn [agent] (. latch (CountDown)) agent)] ;;; countDown + (doseq [agent agents] + (send agent count-down)) (. latch (Await))))) ;;; await (defn ^:static await1 [^clojure.lang.Agent a] @@ -3163,31 +3163,31 @@ {:added "1.0" :static true} [timeout-ms & agents] - (io! "await-for in transaction" - (when *agent* - (throw (new Exception "Can't await in agent action"))) - (let [latch (new clojure.lang.CountDownLatch (count agents)) ;;; java.util.concurrent.CountDownLatch - count-down (fn [agent] (. latch (CountDown)) agent)] ;;; countDown - (doseq [agent agents] - (send agent count-down)) + (io! "await-for in transaction" + (when *agent* + (throw (new Exception "Can't await in agent action"))) + (let [latch (new clojure.lang.CountDownLatch (count agents)) ;;; java.util.concurrent.CountDownLatch + count-down (fn [agent] (. latch (CountDown)) agent)] ;;; countDown + (doseq [agent agents] + (send agent count-down)) (. latch (Await timeout-ms))))) ;;;(await timeout-ms (. java.util.concurrent.TimeUnit MILLISECONDS)))))) -(defmacro dotimes - "bindings => name n - - Repeatedly executes body (presumably for side-effects) with name - bound to integers from 0 through n-1." +(defmacro dotimes + "bindings => name n + + Repeatedly executes body (presumably for side-effects) with name + bound to integers from 0 through n-1." {:added "1.0"} - [bindings & body] - (assert-args - (vector? bindings) "a vector for its binding" - (= 2 (count bindings)) "exactly 2 forms in binding vector") - (let [i (first bindings) - n (second bindings)] - `(let [n# (long ~n)] - (loop [~i 0] - (when (< ~i n#) - ~@body + [bindings & body] + (assert-args + (vector? bindings) "a vector for its binding" + (= 2 (count bindings)) "exactly 2 forms in binding vector") + (let [i (first bindings) + n (second bindings)] + `(let [n# (long ~n)] + (loop [~i 0] + (when (< ~i n#) + ~@body (recur (unchecked-inc ~i))))))) #_(defn into @@ -3283,15 +3283,15 @@ (if (instance? clojure.lang.IEditableCollection to) (persistent! (reduce1 conj! (transient to) from)) (reduce1 conj to from))) - -(defmacro import - "import-list => (package-symbol class-name-symbols*) - - For each name in class-name-symbols, adds a mapping from name to the - class named by package.name to the current namespace. Use :import in the ns - macro in preference to calling this directly." + +(defmacro import + "import-list => (package-symbol class-name-symbols*) + + For each name in class-name-symbols, adds a mapping from name to the + class named by package.name to the current namespace. Use :import in the ns + macro in preference to calling this directly." {:added "1.0"} - [& import-symbols-or-lists] + [& import-symbols-or-lists] (let [specs (map #(if (and (seq? %) (= 'quote (first %))) (second %) %) import-symbols-or-lists)] `(do ~@(map #(list 'clojure.core/import* %) @@ -3424,14 +3424,14 @@ :added "1.3"} [x] (clojure.lang.RT/uncheckedDoubleCast x)) ;;; ^Number - -(defn number? - "Returns true if x is a Number" + +(defn number? + "Returns true if x is a Number" {:added "1.0" :static true} - [x] - (. clojure.lang.Util (IsNumeric x))) ;;; (instance? Number x)) - + [x] + (. clojure.lang.Util (IsNumeric x))) ;;; (instance? Number x)) + (defn mod "Modulus of num and div. Truncates toward negative infinity." {:added "1.0" @@ -3442,12 +3442,12 @@ m (+ m div)))) -(defn ratio? - "Returns true if n is a Ratio" +(defn ratio? + "Returns true if n is a Ratio" {:added "1.0" :static true} - [n] (instance? clojure.lang.Ratio n)) - + [n] (instance? clojure.lang.Ratio n)) + (defn numerator "Returns the numerator part of a Ratio." {:tag BigInteger @@ -3463,29 +3463,29 @@ :static true} [r] (.denominator ^clojure.lang.Ratio r)) - -(defn decimal? - "Returns true if n is a BigDecimal" + +(defn decimal? + "Returns true if n is a BigDecimal" {:added "1.0" :static true} - [n] (instance? BigDecimal n)) - -(defn float? - "Returns true if n is a floating point number" + [n] (instance? BigDecimal n)) + +(defn float? + "Returns true if n is a floating point number" {:added "1.0" :static true} - [n] - (or (instance? Double n) - (instance? Single n))) ;;; Float - -(defn rational? - "Returns true if n is a rational number" + [n] + (or (instance? Double n) + (instance? Single n))) ;;; Float + +(defn rational? + "Returns true if n is a rational number" {:added "1.0" :static true} [n] - (or (integer? n) (ratio? n) (decimal? n))) + (or (integer? n) (ratio? n) (decimal? n))) -(defn bigint +(defn bigint "Coerce to BigInt" {:tag clojure.lang.BigInt :static true @@ -3499,33 +3499,33 @@ (number? x) (clojure.lang.BigInt/valueOf (long x)) (string? x) (bigint (BigInteger/Parse ^String x)) ;; DM: Added string clause :else (bigint (BigInteger. x)))) -(defn biginteger - "Coerce to BigInteger" - {:tag BigInteger +(defn biginteger + "Coerce to BigInteger" + {:tag BigInteger :added "1.0" :static true} - [x] (cond - (instance? BigInteger x) x - (instance? clojure.lang.BigInt x) (.toBigInteger ^clojure.lang.BigInt x) - (decimal? x) (.ToBigInteger ^BigDecimal x) ;;; toBigInteger - (float? x) (.ToBigInteger (BigDecimal/Create (double x))) ;;; (.toBigInteger (. BigDecimal valueOf (double x))) - (ratio? x) (.BigIntegerValue ^clojure.lang.Ratio x) - (number? x) (BigInteger/Create (long x)) (string? x) (bigint (BigInteger/Parse ^String x)) ;;;(BigInteger/valueOf (long x)) DM: Added string clause - :else (BigInteger. x))) - -(defn bigdec - "Coerce to BigDecimal" - {:tag BigDecimal + [x] (cond + (instance? BigInteger x) x + (instance? clojure.lang.BigInt x) (.toBigInteger ^clojure.lang.BigInt x) + (decimal? x) (.ToBigInteger ^BigDecimal x) ;;; toBigInteger + (float? x) (.ToBigInteger (BigDecimal/Create (double x))) ;;; (.toBigInteger (. BigDecimal valueOf (double x))) + (ratio? x) (.BigIntegerValue ^clojure.lang.Ratio x) + (number? x) (BigInteger/Create (long x)) (string? x) (bigint (BigInteger/Parse ^String x)) ;;;(BigInteger/valueOf (long x)) DM: Added string clause + :else (BigInteger. x))) + +(defn bigdec + "Coerce to BigDecimal" + {:tag BigDecimal :added "1.0" :static true} - [x] (cond - (decimal? x) x - (float? x) (BigDecimal/Create (double x)) ;;; (. BigDecimal valueOf (double x)) - (ratio? x) (/ (BigDecimal/Create (.numerator ^clojure.lang.Ratio x)) (.denominator ^clojure.lang.Ratio x)) ;;; (/ (BigDecimal. (.numerator ^clojure.lang.Ratio x)) (.denominator ^clojure.lang.Ratio x)) - (instance? clojure.lang.BigInt x) (.ToBigDecimal ^clojure.lang.BigInt x) ;;; .ToBigDecimal - (instance? BigInteger x) (BigDecimal/Create ^BigInteger x) ;;; (BigDecimal. ^BigInteger x) - (number? x) (BigDecimal/Create (long x)) ;;; (BigDecimal/valueOf (long x)) - :else (BigDecimal/Create x))) ;;; (BigDecimal. x))) + [x] (cond + (decimal? x) x + (float? x) (BigDecimal/Create (double x)) ;;; (. BigDecimal valueOf (double x)) + (ratio? x) (/ (BigDecimal/Create (.numerator ^clojure.lang.Ratio x)) (.denominator ^clojure.lang.Ratio x)) ;;; (/ (BigDecimal. (.numerator ^clojure.lang.Ratio x)) (.denominator ^clojure.lang.Ratio x)) + (instance? clojure.lang.BigInt x) (.ToBigDecimal ^clojure.lang.BigInt x) ;;; .ToBigDecimal + (instance? BigInteger x) (BigDecimal/Create ^BigInteger x) ;;; (BigDecimal. ^BigInteger x) + (number? x) (BigDecimal/Create (long x)) ;;; (BigDecimal/valueOf (long x)) + :else (throw (ArgumentException. (str "Cannot coerce object of type " (.GetType x) " to BigDecimal"))))) ;;; (BigDecimal. x))) (def ^:dynamic ^{:private true} print-initialized false) @@ -3647,55 +3647,55 @@ :static true} [s] (clojure.lang.RT/readString s)) -(defn subvec - "Returns a persistent vector of the items in vector from - start (inclusive) to end (exclusive). If end is not supplied, - defaults to (count vector). This operation is O(1) and very fast, as - the resulting vector shares structure with the original and no - trimming is done." +(defn subvec + "Returns a persistent vector of the items in vector from + start (inclusive) to end (exclusive). If end is not supplied, + defaults to (count vector). This operation is O(1) and very fast, as + the resulting vector shares structure with the original and no + trimming is done." {:added "1.0" :static true} - ([v start] - (subvec v start (count v))) - ([v start end] + ([v start] + (subvec v start (count v))) + ([v start end] (. clojure.lang.RT (subvec v start end)))) (defmacro with-open "bindings => name init - Evaluates body in a try expression with names bound to the values - of the inits, and a finally clause that calls (.close name) on each - name in reverse order." + Evaluates body in a try expression with names bound to the values + of the inits, and a finally clause that calls (.close name) on each + name in reverse order." {:added "1.0"} - [bindings & body] - (assert-args - (vector? bindings) "a vector for its binding" - (even? (count bindings)) "an even number of forms in binding vector") - (cond - (= (count bindings) 0) `(do ~@body) - (symbol? (bindings 0)) `(let ~(subvec bindings 0 2) - (try - (with-open ~(subvec bindings 2) ~@body) - (finally - (. ~(with-meta (bindings 0) {:tag 'IDisposable}) Dispose)))) ;;; close => Dispose - :else (throw (ArgumentException. ;;;IllegalArgumentException. - "with-open only allows Symbols in bindings")))) + [bindings & body] + (assert-args + (vector? bindings) "a vector for its binding" + (even? (count bindings)) "an even number of forms in binding vector") + (cond + (= (count bindings) 0) `(do ~@body) + (symbol? (bindings 0)) `(let ~(subvec bindings 0 2) + (try + (with-open ~(subvec bindings 2) ~@body) + (finally + (. ~(with-meta (bindings 0) {:tag 'IDisposable}) Dispose)))) ;;; close => Dispose + :else (throw (ArgumentException. ;;;IllegalArgumentException. + "with-open only allows Symbols in bindings")))) (defmacro doto - "Evaluates x then calls all of the methods and functions with the - value of x supplied at the front of the given arguments. The forms - are evaluated in order. Returns x. - - (doto (new java.util.HashMap) (.put \"a\" 1) (.put \"b\" 2))" + "Evaluates x then calls all of the methods and functions with the + value of x supplied at the front of the given arguments. The forms + are evaluated in order. Returns x. + + (doto (new java.util.HashMap) (.put \"a\" 1) (.put \"b\" 2))" {:added "1.0"} - [x & forms] - (let [gx (gensym)] - `(let [~gx ~x] - ~@(map (fn [f] - (if (seq? f) - `(~(first f) ~gx ~@(next f)) - `(~f ~gx))) - forms) + [x & forms] + (let [gx (gensym)] + `(let [~gx ~x] + ~@(map (fn [f] + (if (seq? f) + `(~(first f) ~gx ~@(next f)) + `(~f ~gx))) + forms) ~gx))) (defmacro memfn @@ -3742,36 +3742,38 @@ (defn aget "Returns the value at the index/indices. Works on Java arrays of all types." - {:inline (fn [a i] `(. clojure.lang.RT (aget ~a (int ~i)))) + {:inline (fn [^System.Array a i] `(. clojure.lang.RT (aget ~a (int ~i)))) :inline-arities #{2} :added "1.0"} - ([array idx] + ([^System.Array array ^long idx] (clojure.lang.Reflector/prepRet (.GetElementType (class array)) (. array (GetValue idx)))) ;;; was .getComponentType (. Array (get array idx))) ([array idx & idxs] - (apply aget (aget array idx) idxs))) + (let [^System.Array a array] + (apply aget (aget a (int idx)) idxs)))) (defn aset "Sets the value at the index/indices. Works on Java arrays of reference types. Returns val." - {:inline (fn [a i v] `(. clojure.lang.RT (aset ~a (int ~i) ~v))) + {:inline (fn [^System.Array a i v] `(. clojure.lang.RT (aset ~a (int ~i) ~v))) :inline-arities #{3} :added "1.0"} - ([array idx val] - (. array (SetValue val idx)) ;;; was (. Array (set array idx val)) + ([^System.Array array idx val] + (. array (SetValue val (int idx))) ;;; was (. Array (set array idx val)) val) - ([array idx idx2 & idxv] - (apply aset (aget array idx) idx2 idxv))) + ([^System.Array array idx idx2 & idxv] + (apply aset (aget array (int idx)) idx2 idxv))) (defmacro ^{:private true} def-aset [name method coerce] - `(defn ~name - {:arglists '([~'array ~'idx ~'val] [~'array ~'idx ~'idx2 & ~'idxv])} - ([array# idx# val#] - (. clojure.lang.ArrayHelper (~method array# idx# (~coerce val#))) ;;; Array -> ArrayHelper so we can provide the overloads below. - val#) - ([array# idx# idx2# & idxv#] - (apply ~name (aget array# idx#) idx2# idxv#)))) + `(defn ~name + {:arglists '([~'array ~'idx ~'val] [~'array ~'idx ~'idx2 & ~'idxv])} + ([array# idx# val#] + (. clojure.lang.ArrayHelper (~method array# idx# (~coerce val#))) ;;; Array -> ArrayHelper so we can provide the overloads below. + val#) + ([array# idx# idx2# & idxv#] + (let [^System.Array array# array#] + (apply ~name (aget array# (int idx#)) idx2# idxv#))))) (def-aset ^{:doc "Sets the value at the index/indices. Works on arrays of int. Returns val." @@ -3824,10 +3826,12 @@ ([^Type type len] ;;; ^Class (. Array (CreateInstance type (int len)))) ;;; newInstance ([^Type type dim & more-dims] ;;; ^Class - (let [ a (. Array (CreateInstance Array (int dim)))] ;;; [dims (cons dim more-dims) + (let [d (int dim) + ^System.Type t System.Array + ^System.Array a (Array/CreateInstance t d)] ;;; [dims (cons dim more-dims) ;;; ^"[I" dimarray (make-array (. Integer TYPE) (count dims))] (dotimes [i dim] ;;; (dotimes [i (alength dimarray)] - (aset a i (apply make-array type more-dims))) ;;; (aset-int dimarray i (nth dims i))) + (aset a (int i) (apply make-array type more-dims))) ;;; (aset-int dimarray i (nth dims i))) a))) ;;; (. Array (newInstance type dimarray))))) (defn to-array-2d @@ -3838,7 +3842,7 @@ :added "1.0" :static true} [^System.Collections.ICollection coll] ;;; ^java.util.Collection - (let [ret (make-array Object (.Count coll))] ;;; NEED BETTER TYPING HERE (make-array (. Class (forName "[Ljava.lang.Object;")) (. coll (size)))] + (let [^System.Array ret (make-array Object (.Count coll))] ;;; NEED BETTER TYPING HERE (make-array (. Class (forName "[Ljava.lang.Object;")) (. coll (size)))] (loop [i 0 xs (seq coll)] (when xs (aset ret i (to-array (first xs))) @@ -3970,8 +3974,8 @@ [] (clojure.lang.Namespace/all)) (defn the-ns - "If passed a namespace, returns it. Else, when passed a symbol, - returns the namespace named by it, throwing an exception if not + "If passed a namespace, returns it. Else, when passed a symbol, + returns the namespace named by it, throwing an exception if not found." {:added "1.0" :static true} @@ -4011,7 +4015,7 @@ :static true} [ns] (let [ns (the-ns ns)] - (filter-key val (fn [ v] (and (instance? clojure.lang.Var v) ;;; removed the tag on v: ^clojure.lang.Var + (filter-key val (fn [^clojure.lang.Var v] (and (instance? clojure.lang.Var v) ;;; removed the tag on v: ^clojure.lang.Var (= ns (.ns v)) (.isPublic v))) (ns-map ns)))) @@ -4164,15 +4168,15 @@ to the var objects themselves, and must be accessed with var-get and var-set" {:added "1.0"} - [name-vals-vec & body] - (assert-args - (vector? name-vals-vec) "a vector for its binding" - (even? (count name-vals-vec)) "an even number of forms in binding vector") - `(let [~@(interleave (take-nth 2 name-vals-vec) - (repeat '(.. clojure.lang.Var create setDynamic)))] - (. clojure.lang.Var (pushThreadBindings (hash-map ~@name-vals-vec))) - (try - ~@body + [name-vals-vec & body] + (assert-args + (vector? name-vals-vec) "a vector for its binding" + (even? (count name-vals-vec)) "an even number of forms in binding vector") + `(let [~@(interleave (take-nth 2 name-vals-vec) + (repeat '(.. clojure.lang.Var create setDynamic)))] + (. clojure.lang.Var (pushThreadBindings (hash-map ~@name-vals-vec))) + (try + ~@body (finally (. clojure.lang.Var (popThreadBindings)))))) (defn ns-resolve @@ -4271,17 +4275,17 @@ (throw (new Exception (str "Unsupported binding key: " (ffirst kwbs)))) (reduce1 process-entry [] bents))))) -(defmacro let - "binding => binding-form init-expr - - Evaluates the exprs in a lexical context in which the symbols in - the binding-forms are bound to their respective init-exprs or parts - therein." +(defmacro let + "binding => binding-form init-expr + + Evaluates the exprs in a lexical context in which the symbols in + the binding-forms are bound to their respective init-exprs or parts + therein." {:added "1.0", :special-form true, :forms '[(let [bindings*] exprs*)]} - [bindings & body] - (assert-args - (vector? bindings) "a vector for its binding" - (even? (count bindings)) "an even number of forms in binding vector") + [bindings & body] + (assert-args + (vector? bindings) "a vector for its binding" + (even? (count bindings)) "an even number of forms in binding vector") `(let* ~(destructure bindings) ~@body)) (defn ^{:private true} @@ -4370,36 +4374,36 @@ the binding-forms are bound to their respective init-exprs or parts therein. Acts as a recur target." {:added "1.0", :special-form true, :forms '[(loop [bindings*] exprs*)]} - [bindings & body] - (assert-args - (vector? bindings) "a vector for its binding" - (even? (count bindings)) "an even number of forms in binding vector") - (let [db (destructure bindings)] - (if (= db bindings) - `(loop* ~bindings ~@body) - (let [vs (take-nth 2 (drop 1 bindings)) - bs (take-nth 2 bindings) - gs (map (fn [b] (if (symbol? b) b (gensym))) bs) - bfs (reduce1 (fn [ret [b v g]] - (if (symbol? b) - (conj ret g v) - (conj ret g v b g))) - [] (map vector bs vs gs))] - `(let ~bfs - (loop* ~(vec (interleave gs gs)) - (let ~(vec (interleave bs gs)) + [bindings & body] + (assert-args + (vector? bindings) "a vector for its binding" + (even? (count bindings)) "an even number of forms in binding vector") + (let [db (destructure bindings)] + (if (= db bindings) + `(loop* ~bindings ~@body) + (let [vs (take-nth 2 (drop 1 bindings)) + bs (take-nth 2 bindings) + gs (map (fn [b] (if (symbol? b) b (gensym))) bs) + bfs (reduce1 (fn [ret [b v g]] + (if (symbol? b) + (conj ret g v) + (conj ret g v b g))) + [] (map vector bs vs gs))] + `(let ~bfs + (loop* ~(vec (interleave gs gs)) + (let ~(vec (interleave bs gs)) ~@body))))))) -(defmacro when-first - "bindings => x xs - - Roughly the same as (when (seq xs) (let [x (first xs)] body)) but xs is evaluated only once" +(defmacro when-first + "bindings => x xs + + Roughly the same as (when (seq xs) (let [x (first xs)] body)) but xs is evaluated only once" {:added "1.0"} - [bindings & body] - (assert-args - (vector? bindings) "a vector for its binding" - (= 2 (count bindings)) "exactly 2 forms in binding vector") - (let [[x xs] bindings] + [bindings & body] + (assert-args + (vector? bindings) "a vector for its binding" + (= 2 (count bindings)) "exactly 2 forms in binding vector") + (let [[x xs] bindings] `(when-let [xs# (seq ~xs)] (let [~x (first xs#)] ~@body)))) @@ -4567,9 +4571,9 @@ "Create an instance of ExceptionInfo, a RuntimeException subclass that carries a map of additional data." {:added "1.4"} - ([msg map] + ([^System.String msg ^clojure.lang.IPersistentMap map] (ExceptionInfo. msg map)) - ([msg map cause] + ([^System.String msg ^clojure.lang.IPersistentMap map ^System.Exception cause] (ExceptionInfo. msg map cause))) (defn ex-data @@ -4603,14 +4607,14 @@ (do (f) :ok) :no-test))) ;;; Had to add a bogus class clojure.lang.JReMatcher to make the re-* functions work. -(defn re-pattern - "Returns an instance of java.util.regex.Pattern, for use, e.g. in - re-matcher." - {:tag System.Text.RegularExpressions.Regex ;;; {:tag java.util.regex.Pattern} +(defn re-pattern + "Returns an instance of java.util.regex.Pattern, for use, e.g. in + re-matcher." + {:tag System.Text.RegularExpressions.Regex ;;; {:tag java.util.regex.Pattern} :added "1.0" :static true} - [s] (if (instance? System.Text.RegularExpressions.Regex s) ;;; java.util.regex.Pattern - s + [s] (if (instance? System.Text.RegularExpressions.Regex s) ;;; java.util.regex.Pattern + s (System.Text.RegularExpressions.Regex. s))) ;;; (. java.util.regex.Pattern (compile s)))) (defn re-matcher @@ -4837,7 +4841,7 @@ {:private true} [^clojure.lang.Sorted sc test key] (fn [e] - (test (.. sc comparator (compare (. sc entryKey e) key)) 0))) + (test (.. sc comparator (Compare (. sc entryKey e) key)) 0))) (defn subseq "sc must be a sorted collection, test(s) one of <, <=, > or @@ -5339,33 +5343,33 @@ class. h must be a hierarchy obtained from make-hierarchy, if not supplied defaults to, and modifies, the global hierarchy." {:added "1.0"} - ([tag parent] - (assert (namespace parent)) - (assert (or (class? tag) (and (instance? clojure.lang.Named tag) (namespace tag)))) - - (alter-var-root #'global-hierarchy derive tag parent) nil) - ([h tag parent] - (assert (not= tag parent)) - (assert (or (class? tag) (instance? clojure.lang.Named tag))) - (assert (instance? clojure.lang.Named parent)) - - (let [tp (:parents h) - td (:descendants h) - ta (:ancestors h) - tf (fn [m source sources target targets] - (reduce1 (fn [ret k] - (assoc ret k - (reduce1 conj (get targets k #{}) (cons target (targets target))))) - m (cons source (sources source))))] - (or - (when-not (contains? (tp tag) parent) - (when (contains? (ta tag) parent) - (throw (Exception. (print-str tag "already has" parent "as ancestor")))) - (when (contains? (ta parent) tag) - (throw (Exception. (print-str "Cyclic derivation:" parent "has" tag "as ancestor")))) - {:parents (assoc (:parents h) tag (conj (get tp tag #{}) parent)) - :ancestors (tf (:ancestors h) tag td parent ta) - :descendants (tf (:descendants h) parent ta tag td)}) + ([tag parent] + (assert (namespace parent)) + (assert (or (class? tag) (and (instance? clojure.lang.Named tag) (namespace tag)))) + + (alter-var-root #'global-hierarchy derive tag parent) nil) + ([h tag parent] + (assert (not= tag parent)) + (assert (or (class? tag) (instance? clojure.lang.Named tag))) + (assert (instance? clojure.lang.Named parent)) + + (let [tp (:parents h) + td (:descendants h) + ta (:ancestors h) + tf (fn [m source sources target targets] + (reduce1 (fn [ret k] + (assoc ret k + (reduce1 conj (get targets k #{}) (cons target (targets target))))) + m (cons source (sources source))))] + (or + (when-not (contains? (tp tag) parent) + (when (contains? (ta tag) parent) + (throw (Exception. (print-str tag "already has" parent "as ancestor")))) + (when (contains? (ta parent) tag) + (throw (Exception. (print-str "Cyclic derivation:" parent "has" tag "as ancestor")))) + {:parents (assoc (:parents h) tag (conj (get tp tag #{}) parent)) + :ancestors (tf (:ancestors h) tag td parent ta) + :descendants (tf (:descendants h) parent ta tag td)}) h)))) (declare flatten) @@ -5457,8 +5461,8 @@ [fmt & args] (print (apply format fmt args))) -(declare gen-class) -;;; no clear equivalent for us +(declare gen-class) +;;; no clear equivalent for us (defmacro with-loading-context [& body] `((fn loading# [] (. clojure.lang.Var (pushThreadBindings {})) ;;;{clojure.lang.Compiler/LOADER @@ -5467,35 +5471,35 @@ ~@body (finally (. clojure.lang.Var (popThreadBindings))))))) - -(defmacro ns - "Sets *ns* to the namespace named by name (unevaluated), creating it - if needed. references can be zero or more of: (:refer-clojure ...) - (:require ...) (:use ...) (:import ...) (:load ...) (:gen-class) - with the syntax of refer-clojure/require/use/import/load/gen-class - respectively, except the arguments are unevaluated and need not be - quoted. (:gen-class ...), when supplied, defaults to :name - corresponding to the ns name, :main true, :impl-ns same as ns, and - :init-impl-ns true. All options of gen-class are - supported. The :gen-class directive is ignored when not - compiling. If :gen-class is not supplied, when compiled only an - nsname__init.class will be generated. If :refer-clojure is not used, a - default (refer 'clojure.core) is used. Use of ns is preferred to - individual calls to in-ns/require/use/import: - - (ns foo.bar - (:refer-clojure :exclude [ancestors printf]) - (:require (clojure.contrib sql combinatorics)) - (:use (my.lib this that)) - (:import (java.util Date Timer Random) - (java.sql Connection Statement)))" - {:arglists '([name docstring? attr-map? references*]) + +(defmacro ns + "Sets *ns* to the namespace named by name (unevaluated), creating it + if needed. references can be zero or more of: (:refer-clojure ...) + (:require ...) (:use ...) (:import ...) (:load ...) (:gen-class) + with the syntax of refer-clojure/require/use/import/load/gen-class + respectively, except the arguments are unevaluated and need not be + quoted. (:gen-class ...), when supplied, defaults to :name + corresponding to the ns name, :main true, :impl-ns same as ns, and + :init-impl-ns true. All options of gen-class are + supported. The :gen-class directive is ignored when not + compiling. If :gen-class is not supplied, when compiled only an + nsname__init.class will be generated. If :refer-clojure is not used, a + default (refer 'clojure.core) is used. Use of ns is preferred to + individual calls to in-ns/require/use/import: + + (ns foo.bar + (:refer-clojure :exclude [ancestors printf]) + (:require (clojure.contrib sql combinatorics)) + (:use (my.lib this that)) + (:import (java.util Date Timer Random) + (java.sql Connection Statement)))" + {:arglists '([name docstring? attr-map? references*]) :added "1.0"} - [name & references] - (let [process-reference - (fn [[kname & args]] - `(~(symbol "clojure.core" (clojure.core/name kname)) - ~@(map #(list 'quote %) args))) + [name & references] + (let [process-reference + (fn [[kname & args]] + `(~(symbol "clojure.core" (clojure.core/name kname)) + ~@(map #(list 'quote %) args))) docstring (when (string? (first references)) (first references)) references (if docstring (next references) references) name (if docstring @@ -5506,10 +5510,10 @@ name (if metadata (vary-meta name merge metadata) name) - gen-class-clause (first (filter #(= :gen-class (first %)) references)) - gen-class-call - (when gen-class-clause - (list* `gen-class :name (.Replace (str name) \- \_) :impl-ns name :main true (next gen-class-clause))) ;;; .replace + gen-class-clause (first (filter #(= :gen-class (first %)) references)) + gen-class-call + (when gen-class-clause + (list* `gen-class :name (.Replace (str name) \- \_) :impl-ns name :main true (next gen-class-clause))) ;;; .replace references (remove #(= :gen-class (first %)) references) ;ns-effect (clojure.core/in-ns name) ] @@ -5789,34 +5793,34 @@ {:added "1.0"} [] @*loaded-libs*) -(defn load - "Loads Clojure code from resources in classpath. A path is interpreted as - classpath-relative if it begins with a slash or relative to the root - directory for the current namespace otherwise." +(defn load + "Loads Clojure code from resources in classpath. A path is interpreted as + classpath-relative if it begins with a slash or relative to the root + directory for the current namespace otherwise." {:added "1.0"} - [& paths] - (doseq [^String path paths] - (let [^String path (if (.StartsWith path "/") ;;; startsWith - path - (str (root-directory (ns-name *ns*)) \/ path))] - (when *loading-verbosely* - (printf "(clojure.core/load \"%s\")\n" path) - (flush)) + [& paths] + (doseq [^String path paths] + (let [^String path (if (.StartsWith path "/") ;;; startsWith + path + (str (root-directory (ns-name *ns*)) \/ path))] + (when *loading-verbosely* + (printf "(clojure.core/load \"%s\")\n" path) + (flush)) (check-cyclic-dependency path) - (when-not (= path (first *pending-paths*)) - (binding [*pending-paths* (conj *pending-paths* path)] + (when-not (= path (first *pending-paths*)) + (binding [*pending-paths* (conj *pending-paths* path)] (clojure.lang.RT/load (.Substring path 1))))))) ;;; .substring -(defn compile - "Compiles the namespace named by the symbol lib into a set of - classfiles. The source for the lib must be in a proper - classpath-relative directory. The output files will go into the - directory specified by *compile-path*, and that directory too must - be in the classpath." +(defn compile + "Compiles the namespace named by the symbol lib into a set of + classfiles. The source for the lib must be in a proper + classpath-relative directory. The output files will go into the + directory specified by *compile-path*, and that directory too must + be in the classpath." {:added "1.0"} - [lib] - (binding [*compile-files* true] - (load-one lib true true)) + [lib] + (binding [*compile-files* true] + (load-one lib true true)) lib) ;;;;;;;;;;;;; nested associative ops ;;;;;;;;;;; @@ -5907,15 +5911,15 @@ :static true} [x] (instance? clojure.lang.IPersistentSet x)) -(defn ifn? - "Returns true if x implements IFn. Note that many data structures - (e.g. sets and maps) implement IFn" +(defn ifn? + "Returns true if x implements IFn. Note that many data structures + (e.g. sets and maps) implement IFn" {:added "1.0" :static true} [x] (instance? clojure.lang.IFn x)) -(defn fn? - "Returns true if x implements Fn, i.e. is an object created via fn." +(defn fn? + "Returns true if x implements Fn, i.e. is an object created via fn." {:added "1.0" :static true} [x] (instance? clojure.lang.Fn x)) @@ -5971,106 +5975,106 @@ :added "1.0"} *e) -(defn trampoline - "trampoline can be used to convert algorithms requiring mutual - recursion without stack consumption. Calls f with supplied args, if - any. If f returns a fn, calls that fn with no arguments, and - continues to repeat, until the return value is not a fn, then - returns that non-fn value. Note that if you want to return a fn as a - final value, you must wrap it in some data structure and unpack it - after trampoline returns." - {:added "1.0" - :static true} - ([f] - (let [ret (f)] - (if (fn? ret) - (recur ret) - ret))) - ([f & args] - (trampoline #(apply f args)))) - -(defn intern - "Finds or creates a var named by the symbol name in the namespace - ns (which can be a symbol or a namespace), setting its root binding - to val if supplied. The namespace must exist. The var will adopt any - metadata from the name symbol. Returns the var." - {:added "1.0" - :static true} - ([ns ^clojure.lang.Symbol name] - (let [v (clojure.lang.Var/intern (the-ns ns) name)] - (when (meta name) (.setMeta v (meta name))) - v)) - ([ns name val] - (let [v (clojure.lang.Var/intern (the-ns ns) name val)] - (when (meta name) (.setMeta v (meta name))) - v))) - -(defmacro while - "Repeatedly executes body while test expression is true. Presumes - some side-effect will cause test to become false/nil. Returns nil" +(defn trampoline + "trampoline can be used to convert algorithms requiring mutual + recursion without stack consumption. Calls f with supplied args, if + any. If f returns a fn, calls that fn with no arguments, and + continues to repeat, until the return value is not a fn, then + returns that non-fn value. Note that if you want to return a fn as a + final value, you must wrap it in some data structure and unpack it + after trampoline returns." + {:added "1.0" + :static true} + ([f] + (let [ret (f)] + (if (fn? ret) + (recur ret) + ret))) + ([f & args] + (trampoline #(apply f args)))) + +(defn intern + "Finds or creates a var named by the symbol name in the namespace + ns (which can be a symbol or a namespace), setting its root binding + to val if supplied. The namespace must exist. The var will adopt any + metadata from the name symbol. Returns the var." + {:added "1.0" + :static true} + ([ns ^clojure.lang.Symbol name] + (let [v (clojure.lang.Var/intern (the-ns ns) name)] + (when (meta name) (.setMeta v (meta name))) + v)) + ([ns name val] + (let [v (clojure.lang.Var/intern (the-ns ns) name val)] + (when (meta name) (.setMeta v (meta name))) + v))) + +(defmacro while + "Repeatedly executes body while test expression is true. Presumes + some side-effect will cause test to become false/nil. Returns nil" {:added "1.0"} - [test & body] - `(loop [] - (when ~test - ~@body - (recur)))) - -(defn memoize - "Returns a memoized version of a referentially transparent function. The - memoized version of the function keeps a cache of the mapping from arguments - to results and, when calls with the same arguments are repeated often, has - higher performance at the expense of higher memory use." - {:added "1.0" - :static true} - [f] - (let [mem (atom {})] - (fn [& args] - (if-let [e (find @mem args)] - (val e) - (let [ret (apply f args)] - (swap! mem assoc args ret) - ret))))) - -(defmacro condp - "Takes a binary predicate, an expression, and a set of clauses. - Each clause can take the form of either: - - test-expr result-expr - - test-expr :>> result-fn - - Note :>> is an ordinary keyword. - - For each clause, (pred test-expr expr) is evaluated. If it returns - logical true, the clause is a match. If a binary clause matches, the - result-expr is returned, if a ternary clause matches, its result-fn, - which must be a unary function, is called with the result of the - predicate as its argument, the result of that call being the return - value of condp. A single default expression can follow the clauses, - and its value will be returned if no clause matches. If no default - expression is provided and no clause matches, an - IllegalArgumentException is thrown." + [test & body] + `(loop [] + (when ~test + ~@body + (recur)))) + +(defn memoize + "Returns a memoized version of a referentially transparent function. The + memoized version of the function keeps a cache of the mapping from arguments + to results and, when calls with the same arguments are repeated often, has + higher performance at the expense of higher memory use." + {:added "1.0" + :static true} + [f] + (let [mem (atom {})] + (fn [& args] + (if-let [e (find @mem args)] + (val e) + (let [ret (apply f args)] + (swap! mem assoc args ret) + ret))))) + +(defmacro condp + "Takes a binary predicate, an expression, and a set of clauses. + Each clause can take the form of either: + + test-expr result-expr + + test-expr :>> result-fn + + Note :>> is an ordinary keyword. + + For each clause, (pred test-expr expr) is evaluated. If it returns + logical true, the clause is a match. If a binary clause matches, the + result-expr is returned, if a ternary clause matches, its result-fn, + which must be a unary function, is called with the result of the + predicate as its argument, the result of that call being the return + value of condp. A single default expression can follow the clauses, + and its value will be returned if no clause matches. If no default + expression is provided and no clause matches, an + IllegalArgumentException is thrown." {:added "1.0"} - - [pred expr & clauses] - (let [gpred (gensym "pred__") - gexpr (gensym "expr__") - emit (fn emit [pred expr args] - (let [[[a b c :as clause] more] - (split-at (if (= :>> (second args)) 3 2) args) - n (count clause)] - (cond + + [pred expr & clauses] + (let [gpred (gensym "pred__") + gexpr (gensym "expr__") + emit (fn emit [pred expr args] + (let [[[a b c :as clause] more] + (split-at (if (= :>> (second args)) 3 2) args) + n (count clause)] + (cond (= 0 n) `(throw (ArgumentException. (str "No matching clause: " ~expr))) ;;;IllegalArgumentException - (= 1 n) a - (= 2 n) `(if (~pred ~a ~expr) - ~b - ~(emit pred expr more)) - :else `(if-let [p# (~pred ~a ~expr)] - (~c p#) - ~(emit pred expr more))))) - gres (gensym "res__")] - `(let [~gpred ~pred - ~gexpr ~expr] + (= 1 n) a + (= 2 n) `(if (~pred ~a ~expr) + ~b + ~(emit pred expr more)) + :else `(if-let [p# (~pred ~a ~expr)] + (~c p#) + ~(emit pred expr more))))) + gres (gensym "res__")] + `(let [~gpred ~pred + ~gexpr ~expr] ~(emit gpred gexpr clauses)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; var documentation ;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -7271,7 +7275,7 @@ (deftype Eduction [xform coll] System.Collections.IEnumerable ;;; Iterable - (GetEnumerator [_] (.GetEnumerator ^System.Collections.ICollection (sequence xform coll))) ;;; iterator .iterator ^java.util.Collection + (GetEnumerator [_] (.GetEnumerator ^System.Collections.IEnumerable (sequence xform coll))) ;;; iterator .iterator ^java.util.Collection clojure.lang.Seqable (seq [_] (seq (sequence xform coll))) diff --git a/Clojure/Clojure.Source/clojure/core_print.clj b/Clojure/Clojure.Source/clojure/core_print.clj index 1940c48de..e27264a86 100644 --- a/Clojure/Clojure.Source/clojure/core_print.clj +++ b/Clojure/Clojure.Source/clojure/core_print.clj @@ -360,7 +360,7 @@ ;;; ADDED LINES (defmethod print-method clojure.lang.Ratio [o ^System.IO.TextWriter w] (.Write w (str o))) -(defmethod print-dup clojure.lang.BigInteger [o w] +(defmethod print-dup clojure.lang.BigInteger [o ^System.IO.TextWriter w] (.Write w "#=(clojure.lang.BigInteger/Parse ") (print-dup (str o) w) (.Write w ")")) diff --git a/Clojure/Clojure.Source/clojure/core_proxy.clj b/Clojure/Clojure.Source/clojure/core_proxy.clj index 5d1c104bf..7700b850e 100644 --- a/Clojure/Clojure.Source/clojure/core_proxy.clj +++ b/Clojure/Clojure.Source/clojure/core_proxy.clj @@ -43,13 +43,13 @@ (defn proxy-name {:tag String} [^Type super interfaces] ;;; Class - (let [inames (into1 (sorted-set) (map #(.Name ^Type %) interfaces))] ;;; .getName ^Class - (apply str (.Replace (str *ns*) \- \_) ".proxy" ;;; .replace - (interleave (repeat "$") - (concat - [(.Name super)] ;;; .getName - (map #(subs % (inc (.LastIndexOf ^String % "."))) inames) ;;; .lastIndexOf - [(.ToString (hash inames) "X")] [(clojure.lang.Compiler/IsCompilingSuffix)]))))) ;;;[(Integer/toHexString (hash inames))]))))) + (let [inames (into1 (sorted-set) (map #(.Name ^Type %) interfaces))] ;;; .getName ^Class + (apply str (.Replace (str *ns*) \- \_) ".proxy" ;;; .replace + (interleave (repeat "$") + (concat + [(.Name super)] ;;; .getName + (map #(subs % (inc (.LastIndexOf ^String % "."))) inames) ;;; .lastIndexOf + [(.ToString (int (hash inames)) "X")] [(clojure.lang.Compiler/IsCompilingSuffix)]))))) ;;;[(Integer/toHexString (hash inames))]))))) (defn- generate-proxy [^Type super interfaces] ;;; Class (clojure.lang.GenProxy/GenerateProxyClass super interfaces (proxy-name super interfaces))) ;;;DM;; @@ -264,7 +264,7 @@ returns an instance of a proxy class derived from the supplied classes. The resulting value is cached and used for any subsequent requests for the same class set. Returns a Class object." - {:added "1.0"} + {:added "1.0"} [& bases] (let [[super interfaces] (get-super-and-interfaces bases) pname (proxy-name super interfaces)] @@ -275,7 +275,7 @@ (defn construct-proxy "Takes a proxy class and any arguments for its superclass ctor and creates and returns an instance of the proxy." - {:added "1.0"} + {:added "1.0"} [c & ctor-args] (. Reflector (InvokeConstructor c (to-array ctor-args)))) ;;; invokeConstructor @@ -285,7 +285,7 @@ fns (which must take arguments matching the corresponding method, plus an additional (explicit) first arg corresponding to this, and sets the proxy's fn map. Returns the proxy." - {:added "1.0"} + {:added "1.0"} [^IProxy proxy mappings] (. proxy (__initClojureFnMappings mappings)) proxy) @@ -300,14 +300,14 @@ default behavior. Note that this function can be used to update the behavior of an existing instance without changing its identity. Returns the proxy." - {:added "1.0"} + {:added "1.0"} [^IProxy proxy mappings] (. proxy (__updateClojureFnMappings mappings)) proxy) (defn proxy-mappings "Takes a proxy instance and returns the proxy's fn map." - {:added "1.0"} + {:added "1.0"} [^IProxy proxy] (. proxy (__getClojureFnMappings))) @@ -335,7 +335,7 @@ be provided to override protected methods, they have no other access to protected members, nor to super, as these capabilities cannot be proxied." - {:added "1.0"} + {:added "1.0"} [class-and-interfaces args & fs] (let [bases (map #(or (resolve %) (throw (Exception. (str "Can't resolve: " %)))) class-and-interfaces) @@ -345,7 +345,7 @@ ;;; (clojure.lang.Compiler/writeClassFile cname bytecode))) pc-effect (apply get-proxy-class bases) pname (proxy-name super interfaces)] - ;remember the class to prevent it from disappearing before use + ;remember the class to prevent it from disappearing before use (intern *ns* (symbol pname) pc-effect) `(let [;pc# (get-proxy-class ~@class-and-interfaces) p# (new ~(symbol pname) ~@args)] ;(construct-proxy pc# ~@args)] @@ -369,21 +369,21 @@ (defn proxy-call-with-super [call this meth] (let [m (proxy-mappings this)] (update-proxy this (assoc m meth nil)) - (try - (call) + (try + (call) (finally (update-proxy this m))))) (defmacro proxy-super "Use to call a superclass method in the body of a proxy method. Note, expansion captures 'this" - {:added "1.0"} + {:added "1.0"} [meth & args] `(proxy-call-with-super (fn [] (. ~'this ~meth ~@args)) ~'this ~(name meth))) ;;;(defn bean ;;; "Takes a Java object and returns a read-only implementation of the ;;; map abstraction based upon its JavaBean properties." -;;; {:added "1.0"} +;;; {:added "1.0"} ;;; [^Object x] ;;; (let [c (. x (getClass)) ;;; pmap (reduce (fn [m ^java.beans.PropertyDescriptor pd] diff --git a/Clojure/Clojure.Source/clojure/main.clj b/Clojure/Clojure.Source/clojure/main.clj index 269a16d3a..488c4578e 100644 --- a/Clojure/Clojure.Source/clojure/main.clj +++ b/Clojure/Clojure.Source/clojure/main.clj @@ -8,8 +8,8 @@ ;; Originally contributed by Stephen C. Gilardi -(ns ^{:doc "Top-level main function for Clojure REPL and scripts." - :author "Stephen C. Gilardi and Rich Hickey"} +(ns ^{:doc "Top-level main function for Clojure REPL and scripts." + :author "Stephen C. Gilardi and Rich Hickey"} clojure.main (:refer-clojure :exclude [with-bindings]) (:import (clojure.lang Compiler Compiler+CompilerException ;;;Compiler$CompilerException @@ -19,21 +19,21 @@ (declare main) -;;;;;;;;;;;;;;;;;;; redundantly copied from clojure.repl to avoid dep ;;;;;;;;;;;;;; -#_(defn root-cause [x] x) -#_(defn stack-element-str - "Returns a (possibly unmunged) string representation of a StackTraceElement" - {:added "1.3"} - [^StackTraceElement el] - (.getClassName el)) - -(defn demunge - "Given a string representation of a fn class, - as in a stack trace element, returns a readable version." - {:added "1.3"} - [fn-name] - (clojure.lang.Compiler/demunge fn-name)) - +;;;;;;;;;;;;;;;;;;; redundantly copied from clojure.repl to avoid dep ;;;;;;;;;;;;;; +#_(defn root-cause [x] x) +#_(defn stack-element-str + "Returns a (possibly unmunged) string representation of a StackTraceElement" + {:added "1.3"} + [^StackTraceElement el] + (.getClassName el)) + +(defn demunge + "Given a string representation of a fn class, + as in a stack trace element, returns a readable version." + {:added "1.3"} + [fn-name] + (clojure.lang.Compiler/demunge fn-name)) + (defn root-cause "Returns the initial cause of an exception or error by peeling off all of its wrappers" @@ -44,41 +44,41 @@ cause (if-let [cause (.InnerException cause)] ;;; .getCause (recur cause) - cause)))) - -;;; Added -DM - -(defn get-stack-trace - "Gets the stack trace for an Exception" - [^Exception e] - (.GetFrames (System.Diagnostics.StackTrace. e true))) - -(defn stack-element-classname - [^System.Diagnostics.StackFrame el] - (if-let [t (.. el (GetMethod) ReflectedType)] - (.FullName t) - "")) - -(defn stack-element-methodname - [^System.Diagnostics.StackFrame el] - (.. el (GetMethod) Name)) - -;;; - - -(defn stack-element-str - "Returns a (possibly unmunged) string representation of a StackTraceElement" - {:added "1.3"} - [^System.Diagnostics.StackFrame el] ;;; StackTraceElement - (let [file (.GetFileName el) ;;; getFileName - clojure-fn? (and file (or (.EndsWith file ".clj") ;;; endsWith - (= file "NO_SOURCE_FILE")))] - (str (if clojure-fn? - (demunge (stack-element-classname el)) ;;; (.getClassName el)) - (str (stack-element-classname el) "." (stack-element-methodname el))) ;;; (.getClassName el) (.getMethodName el) - " (" (.GetFileName el) ":" (.GetFileLineNumber el) ")"))) ;;; getFileName getLineNumber -;;;;;;;;;;;;;;;;;;; end of redundantly copied from clojure.repl to avoid dep ;;;;;;;;;;;;;; - + cause)))) + +;;; Added -DM + +(defn get-stack-trace + "Gets the stack trace for an Exception" + [^Exception e] + (.GetFrames (System.Diagnostics.StackTrace. e true))) + +(defn stack-element-classname + [^System.Diagnostics.StackFrame el] + (if-let [t (.. el (GetMethod) ReflectedType)] + (.FullName t) + "")) + +(defn stack-element-methodname + [^System.Diagnostics.StackFrame el] + (.. el (GetMethod) Name)) + +;;; + + +(defn stack-element-str + "Returns a (possibly unmunged) string representation of a StackTraceElement" + {:added "1.3"} + [^System.Diagnostics.StackFrame el] ;;; StackTraceElement + (let [file (.GetFileName el) ;;; getFileName + clojure-fn? (and file (or (.EndsWith file ".clj") ;;; endsWith + (= file "NO_SOURCE_FILE")))] + (str (if clojure-fn? + (demunge (stack-element-classname el)) ;;; (.getClassName el)) + (str (stack-element-classname el) "." (stack-element-methodname el))) ;;; (.getClassName el) (.getMethodName el) + " (" (.GetFileName el) ":" (.GetFileLineNumber el) ")"))) ;;; getFileName getLineNumber +;;;;;;;;;;;;;;;;;;; end of redundantly copied from clojure.repl to avoid dep ;;;;;;;;;;;;;; + (defmacro with-bindings "Executes body in the context of thread-local bindings for several vars @@ -116,7 +116,7 @@ must either be an instance of LineNumberingPushbackReader or duplicate its behavior of both supporting .unread and collapsing all of CR, LF, and CRLF to a single \\newline." - [s] + [^clojure.lang.PushbackTextReader s] (let [c (.Read s)] ;;; .read (cond (= c (int \newline)) :line-start @@ -132,7 +132,7 @@ instance of LineNumberingPushbackReader or duplicate its behavior of both supporting .unread and collapsing all of CR, LF, and CRLF to a single \\newline." - [s] + [^clojure.lang.PushbackTextReader s] (loop [c (.Read s)] ;;; .read (cond (= c (int \newline)) :line-start @@ -168,7 +168,7 @@ "Default :caught hook for repl" [e] (let [ex (repl-exception e) - tr (get-stack-trace ex) + ^|System.Diagnostics.StackFrame[]| tr (get-stack-trace ex) el (when-not (zero? (count tr)) (aget tr 0))] (binding [*out* *err*] (println (str (-> ex class .Name) ;;; .getSimpleName @@ -176,18 +176,18 @@ (when-not (instance? clojure.lang.Compiler+CompilerException ex) (str " " (if el (stack-element-str el) "[trace missing]")))))))) -(def ^{:doc "A sequence of lib specs that are applied to `require` -by default when a new command-line REPL is started."} repl-requires - '[[clojure.repl :refer (source apropos dir pst doc find-doc)] - ;;;[clojure.java.javadoc :refer (javadoc)] ;;; commented out - [clojure.pprint :refer (pp pprint)]]) +(def ^{:doc "A sequence of lib specs that are applied to `require` +by default when a new command-line REPL is started."} repl-requires + '[[clojure.repl :refer (source apropos dir pst doc find-doc)] + ;;;[clojure.java.javadoc :refer (javadoc)] ;;; commented out + [clojure.pprint :refer (pp pprint)]]) -(defmacro with-read-known - "Evaluates body with *read-eval* set to a \"known\" value, - i.e. substituting true for :unknown if necessary." - [& body] - `(binding [*read-eval* (if (= :unknown *read-eval*) true *read-eval*)] - ~@body)) +(defmacro with-read-known + "Evaluates body with *read-eval* set to a \"known\" value, + i.e. substituting true for :unknown if necessary." + [& body] + `(binding [*read-eval* (if (= :unknown *read-eval*) true *read-eval*)] + ~@body)) (defn repl "Generic, reusable, read-eval-print loop. By default, reads from *in*, @@ -233,8 +233,8 @@ by default when a new command-line REPL is started."} repl-requires read, eval, or print throws an exception or error default: repl-caught" [& options] - ;;;(let [cl (.getContextClassLoader (Thread/currentThread))] - ;;; (.setContextClassLoader (Thread/currentThread) (clojure.lang.DynamicClassLoader. cl))) + ;;;(let [cl (.getContextClassLoader (Thread/currentThread))] + ;;; (.setContextClassLoader (Thread/currentThread) (clojure.lang.DynamicClassLoader. cl))) (let [{:keys [init need-prompt prompt flush read eval print caught] :or {init #() need-prompt (if (instance? LineNumberingTextReader *in*) ;;; LineNumberingPushbackReader @@ -252,7 +252,7 @@ by default when a new command-line REPL is started."} repl-requires read-eval-print (fn [] (try - (let [read-eval *read-eval* + (let [read-eval *read-eval* input (with-read-known (read request-prompt request-exit))] (or (#{request-prompt request-exit} input) (let [value (binding [*read-eval* read-eval] (eval input))] @@ -272,11 +272,11 @@ by default when a new command-line REPL is started."} repl-requires (prompt) (flush) (loop [] - (when-not - (try (identical? (read-eval-print) request-exit) - (catch Exception e ;;; Throwable - (caught e) - (set! *e e) + (when-not + (try (identical? (read-eval-print) request-exit) + (catch Exception e ;;; Throwable + (caught e) + (set! *e e) nil)) (when (need-prompt) (prompt) @@ -300,8 +300,8 @@ by default when a new command-line REPL is started."} repl-requires (defn- eval-opt "Evals expressions in str, prints each non-nil result using prn" [str] - (let [eof (Object.) - reader (LineNumberingTextReader. (System.IO.StringReader. str))] ;;; LineNumberingPushbackReader. java.io.StringReader. + (let [eof (Object.) + reader (LineNumberingTextReader. (System.IO.StringReader. str))] ;;; LineNumberingPushbackReader. java.io.StringReader. (loop [input (with-read-known (read reader false eof))] (when-not (= input eof) (let [value (eval input)] @@ -325,14 +325,14 @@ by default when a new command-line REPL is started."} repl-requires (doseq [[opt arg] inits] ((init-dispatch opt) arg))) - -(defn- main-opt - "Call the -main function from a namespace with string arguments taken from - the command line." - [[_ main-ns & args] inits] - (with-bindings - (initialize args inits) - (apply (ns-resolve (doto (symbol main-ns) require) '-main) args))) + +(defn- main-opt + "Call the -main function from a namespace with string arguments taken from + the command line." + [[_ main-ns & args] inits] + (with-bindings + (initialize args inits) + (apply (ns-resolve (doto (symbol main-ns) require) '-main) args))) (defn- repl-opt "Start a repl with args and inits. Print greeting if no eval options were @@ -340,8 +340,8 @@ by default when a new command-line REPL is started."} repl-requires [[_ & args] inits] (when-not (some #(= eval-opt (init-dispatch (first %))) inits) (println "Clojure" (clojure-version))) - (repl :init (fn [] - (initialize args inits) + (repl :init (fn [] + (initialize args inits) (apply require repl-requires))) (prn) (Environment/Exit 0)) ;;; System.Exit @@ -384,8 +384,8 @@ by default when a new command-line REPL is started."} repl-requires "Called by the clojure.lang.Repl.main stub to run a repl with args specified the old way" [args] - (println "WARNING: clojure.lang.Repl is deprecated. -Instead, use clojure.main like this: + (println "WARNING: clojure.lang.Repl is deprecated. +Instead, use clojure.main like this: java -cp clojure.jar clojure.main -i init.clj -r args...") (let [[inits [sep & args]] (split-with (complement #{"--"}) args)] (repl-opt (concat ["-r"] args) (map vector (repeat "-i") inits)))) @@ -394,8 +394,8 @@ java -cp clojure.jar clojure.main -i init.clj -r args...") "Called by the clojure.lang.Script.main stub to run a script with args specified the old way" [args] - (println "WARNING: clojure.lang.Script is deprecated. -Instead, use clojure.main like this: + (println "WARNING: clojure.lang.Script is deprecated. +Instead, use clojure.main like this: java -cp clojure.jar clojure.main -i init.clj script.clj args...") (let [[inits [sep & args]] (split-with (complement #{"--"}) args)] (null-opt args (map vector (repeat "-i") inits)))) diff --git a/Clojure/Clojure.Source/clojure/pprint/cl_format.clj b/Clojure/Clojure.Source/clojure/pprint/cl_format.clj index c52959f86..77c5d8222 100644 --- a/Clojure/Clojure.Source/clojure/pprint/cl_format.clj +++ b/Clojure/Clojure.Source/clojure/pprint/cl_format.clj @@ -208,7 +208,7 @@ http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm (cond (integer? x) true (decimal? x) true ;;; TODO: FIX THIS (>= (.ulp (.stripTrailingZeros (bigdec 0))) 1) ; true iff no fractional part DM: ??????? doesn't mention x!!! - (float? x) (= x (Math/Floor x)) ;;; Math/floor + (float? x) (= x (Math/Floor (float x))) ;;; Math/floor (ratio? x) (let [^clojure.lang.Ratio r x] (= 0 (rem (.numerator r) (.denominator r)))) :else false)) @@ -684,8 +684,8 @@ string, or one character longer." fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d) fixed-repr (if (and w d (>= d 1) - (= (.get_Chars fixed-repr 0) \0) ;;; .charAt - (= (.get_Chars fixed-repr 1) \.) ;;; .charAt + (= (.get_Chars ^System.String fixed-repr 0) \0) ;;; .charAt + (= (.get_Chars ^System.String fixed-repr 1) \.) ;;; .charAt (> (count fixed-repr) (- w (if add-sign 1 0)))) (subs fixed-repr 1) ; chop off leading 0 fixed-repr) diff --git a/Clojure/Clojure.Source/clojure/pprint/dispatch.clj b/Clojure/Clojure.Source/clojure/pprint/dispatch.clj index cdc7d6ae7..c6eef9f2c 100644 --- a/Clojure/Clojure.Source/clojure/pprint/dispatch.clj +++ b/Clojure/Clojure.Source/clojure/pprint/dispatch.clj @@ -19,7 +19,7 @@ (defn- use-method "Installs a function as a new method of multimethod associated with dispatch-value. " - [multifn dispatch-val func] + [^clojure.lang.MultiFn multifn dispatch-val func] (. multifn addMethod dispatch-val func)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/Clojure/Clojure.Source/clojure/pprint/pretty_writer.clj b/Clojure/Clojure.Source/clojure/pprint/pretty_writer.clj index 75f310c96..5a89beeb4 100644 --- a/Clojure/Clojure.Source/clojure/pprint/pretty_writer.clj +++ b/Clojure/Clojure.Source/clojure/pprint/pretty_writer.clj @@ -106,7 +106,8 @@ (let [lb (:logical-block token)] (dosync (when-let [^String prefix (:prefix lb)] - (.Write (getf :base) prefix)) + (let [^TextWriter b (getf :base)] + (.Write b prefix))) (let [col (get-column (getf :base))] (ref-set (:start-col lb) col) (ref-set (:indent lb) col))))) @@ -114,7 +115,8 @@ (defmethod write-token :end-block-t [^TextWriter this token] (when-let [cb (getf :logical-block-callback)] (cb :end)) (when-let [^String suffix (:suffix (:logical-block token))] - (.Write (getf :base) suffix))) + (let [^TextWriter b (getf :base)] + (.Write b suffix)))) (defmethod write-token :indent-t [^TextWriter this token] (let [lb (:logical-block token)] @@ -125,7 +127,8 @@ :current (get-column (getf :base))))))) (defmethod write-token :buffer-blob [^TextWriter this token] - (.Write (getf :base) ^String (:data token))) + (let [^TextWriter b (getf :base)] + (.Write b ^String (:data token)))) (defmethod write-token :nl-t [^TextWriter this token] ; (prlabel wt @(:done-nl (:logical-block token))) @@ -135,19 +138,22 @@ @(:done-nl (:logical-block token)))) (emit-nl this token) (if-let [^String tws (getf :trailing-white-space)] - (.Write (getf :base) tws))) + (let [^TextWriter b (getf :base)] + (.Write b tws)))) (dosync (setf :trailing-white-space nil))) (defn- write-tokens [^TextWriter this tokens force-trailing-whitespace] (doseq [token tokens] (if-not (= (:type-tag token) :nl-t) (if-let [^String tws (getf :trailing-white-space)] - (.Write (getf :base) tws))) + (let [^TextWriter b (getf :base)] + (.Write b tws)))) (write-token this token) (setf :trailing-white-space (:trailing-white-space token))) (let [^String tws (getf :trailing-white-space)] (when (and force-trailing-whitespace tws) - (.Write (getf :base) tws) + (let [^TextWriter b (getf :base)] + (.Write b tws)) (setf :trailing-white-space nil)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -225,15 +231,18 @@ (recur (:parent lb))))))) (defn- emit-nl [^TextWriter this nl] - (.Write (getf :base) (pp-newline)) + (let [^TextWriter b (getf :base)] + (.Write b (pp-newline))) (dosync (setf :trailing-white-space nil)) (let [lb (:logical-block nl) ^String prefix (:per-line-prefix lb)] (if prefix - (.Write (getf :base) prefix)) + (let [^TextWriter b (getf :base)] + (.Write b prefix))) (let [^String istr (apply str (repeat (- @(:indent lb) (count prefix)) \space))] - (.Write (getf :base) istr)) + (let [^TextWriter b (getf :base)] + (.Write b istr))) (update-nl-state lb))) (defn- split-at-newline [tokens] @@ -315,7 +324,8 @@ (defn- write-white-space [^TextWriter this] (when-let [^String tws (getf :trailing-white-space)] ; (prlabel wws (str "*" tws "*")) - (.Write (getf :base) tws) + (let [^TextWriter b (getf :base)] + (.Write b tws)) (dosync (setf :trailing-white-space nil)))) @@ -323,7 +333,8 @@ ;;; making the appropriate adjustments. Return the remainder of the string (defn- write-initial-lines [^TextWriter this ^String s] - (let [lines (.Split #"\n" s )] ;;; (.Split s "\n" -1) + (let [lines (.Split #"\n" s ) + ^TextWriter b (getf :base)] ;;; (.Split s "\n" -1) (if (= (count lines) 1) s (dosync @@ -337,22 +348,22 @@ (write-buffered-output this)) (do (write-white-space this) - (.Write (getf :base) l))) - (.Write (getf :base) (int \newline)) + (.Write b l))) + (.Write b (int \newline)) (doseq [^String l (next (butlast lines))] - (.Write (getf :base) l) - (.Write (getf :base) (pp-newline)) + (.Write b l) + (.Write b (pp-newline)) (if prefix - (.Write (getf :base) prefix))) + (.Write b prefix))) (setf :buffering :writing) (last lines)))))) (defn- p-write-char [^TextWriter this c] (let [c (int c)] ;;; replacing type hint ^Int32 c (if (= (getf :mode) :writing) - (do + (let [^TextWriter b (getf :base)] (write-white-space this) - (.Write (getf :base) c)) + (.Write b c)) (if (= c \newline) (write-initial-lines this "\n") (let [oldpos (getf :pos) @@ -394,16 +405,16 @@ mode (getf :mode)] (dosync (if (= mode :writing) - (do + (let [^TextWriter b (getf :base)] (write-white-space this) - (.Write (getf :base) s) + (.Write b s) (setf :trailing-white-space white-space)) (let [oldpos (getf :pos) newpos (+ oldpos (count s0))] (setf :pos newpos) (add-to-buffer this (make-buffer-blob s white-space oldpos newpos)))))) - Char - (p-write-char this (int x)) + Char + (p-write-char this (int x)) Int32 (p-write-char this x) Int64 @@ -440,7 +451,8 @@ (write-white-space this) (when-let [cb (getf :logical-block-callback)] (cb :start)) (if prefix - (.Write (getf :base) prefix)) + (let [^TextWriter b (getf :base)] + (.Write b prefix))) (let [col (get-column (getf :base))] (ref-set (:start-col lb) col) (ref-set (:indent lb) col))) @@ -457,7 +469,8 @@ (do (write-white-space this) (if suffix - (.Write (getf :base) suffix)) + (let [^TextWriter b (getf :base)] + (.Write b suffix))) (when-let [cb (getf :logical-block-callback)] (cb :end))) (let [oldpos (getf :pos) newpos (+ oldpos (if suffix (count suffix) 0))] diff --git a/Clojure/Clojure.Source/clojure/reflect/clr.clj b/Clojure/Clojure.Source/clojure/reflect/clr.clj index c0be29848..9492c82ec 100644 --- a/Clojure/Clojure.Source/clojure/reflect/clr.clj +++ b/Clojure/Clojure.Source/clojure/reflect/clr.clj @@ -146,10 +146,10 @@ (defn- declared-constructors "Return a set of the declared constructors of class as a Clojure map." - [cls] + [^Type cls] (set (map constructor->map - (.GetConstructors (cast Type cls) basic-binding-flags)))) + (.GetConstructors cls basic-binding-flags)))) (defrecord Method [name return-type declaring-class parameter-types flags]) @@ -165,10 +165,10 @@ (defn- declared-methods "Return a set of the declared constructors of class as a Clojure map." - [cls] + [^Type cls] (set (map method->map - (.GetMethods (cast Type cls) basic-binding-flags)))) + (.GetMethods cls basic-binding-flags)))) (defrecord Field [name type declaring-class flags]) @@ -183,10 +183,10 @@ (defn- declared-fields "Return a set of the declared fields of class as a Clojure map." - [cls] + [^Type cls] (set (map field->map - (.GetFields (cast Type cls) basic-binding-flags)))) + (.GetFields cls basic-binding-flags)))) (defrecord Property [name type declaring-class flags]) @@ -201,10 +201,10 @@ (defn- declared-properties "Return a set of the declared fields of class as a Clojure map." - [cls] + [^Type cls] (set (map property->map - (.GetProperties (cast Type cls) basic-binding-flags)))) + (.GetProperties cls basic-binding-flags)))) (deftype ClrReflector [a] diff --git a/Clojure/Clojure.Source/clojure/stacktrace.clj b/Clojure/Clojure.Source/clojure/stacktrace.clj index 47d2c5789..01936657c 100644 --- a/Clojure/Clojure.Source/clojure/stacktrace.clj +++ b/Clojure/Clojure.Source/clojure/stacktrace.clj @@ -11,7 +11,7 @@ ;; by Stuart Sierra ;; January 6, 2009 -(ns ^{:doc "Print stack traces oriented towards Clojure, not Java." +(ns ^{:doc "Print stack traces oriented towards Clojure, not Java." :author "Stuart Sierra"} clojure.stacktrace) @@ -26,7 +26,7 @@ (defn print-trace-element "Prints a Clojure-oriented view of one element in a stack trace." {:added "1.1"} - [e] ;;; in CLR, e will be a StackFrame + [^System.Diagnostics.StackFrame e] ;;; in CLR, e will be a StackFrame (let [class (if-let [t (.. e (GetMethod) ReflectedType)] (.FullName t) "") ;;; (.getClassName e) method (.. e (GetMethod) Name)] ;;; (.getMethodName e)] (let [match (re-matches #"^([A-Za-z0-9_.-]+)\$(\w+)__\d+$" (str class))] @@ -52,8 +52,8 @@ (print-throwable tr) (newline) (print " at ") - (if-let [e (first st)] - (print-trace-element e) + (if-let [e (first st)] + (print-trace-element e) (print "[empty stack trace]")) (newline) (doseq [e (if (nil? n) diff --git a/Clojure/Clojure.Source/clojure/string.clj b/Clojure/Clojure.Source/clojure/string.clj index 57e08a1de..0064da066 100644 --- a/Clojure/Clojure.Source/clojure/string.clj +++ b/Clojure/Clojure.Source/clojure/string.clj @@ -58,9 +58,10 @@ Design notes for clojure.string: replacement) ;;; TODO: a no-op until I figure out the CLR equivalent -- (Matcher/quoteReplacement (.toString ^CharSequence replacement))) (defn- replace-by - [^String s re f] - (.Replace re s ;;; (let [m (re-matcher re s)] - ^MatchEvaluator (gen-delegate MatchEvaluator [m] (f (re-groups-direct m))))) ;;; (if (.find m) + [^String s ^Regex re f] + (let [^MatchEvaluator me (gen-delegate MatchEvaluator [m] (f (re-groups-direct m)))] + (.Replace re s me))) ;;; (let [m (re-matcher re s)] + ;;; (if (.find m) ;;; (let [buffer (StringBuffer. (.length s))] ;;; (loop [found true] ;;; (if found @@ -95,13 +96,13 @@ Design notes for clojure.string: (clojure.string/replace \"Almost Pig Latin\" #\"\\b(\\w)(\\w+)\\b\" \"$2$1ay\") -> \"lmostAay igPay atinLay\"" {:added "1.2"} - [^String s match replacement] + [^String s ^Regex match replacement] (let [] ; ;;; [s (.toString s)] (cond (instance? Char match) (.Replace s ^Char match ^Char replacement) ;;; Character .replace (instance? String match) (.Replace s ^String match ^String replacement) ;;; .replace (instance? Regex match) (if (string? replacement) ;;; Pattern - (.Replace match s replacement) ;;; (.replaceAll (re-matcher ^Pattern match s) + (.Replace match s ^String replacement) ;;; (.replaceAll (re-matcher ^Pattern match s) ;;; (.toString ^CharSequence replacement)) (replace-by s match replacement)) :else (throw (ArgumentException. (str "Invalid match arg: " match)))))) ;;; IllegalArgumentException @@ -109,12 +110,14 @@ Design notes for clojure.string: (defn- replace-first-by [^String s ^Regex re f] ;;; Pattern ;;; (let [m (re-matcher re s)] - (.Replace re s ;;; (if (.find m) - ^MatchEvaluator (gen-delegate MatchEvaluator [m] (f (re-groups-direct m))) ;;; (let [buffer (StringBuffer. (.length s)) - 1)) ;;; rep (Matcher/quoteReplacement (f (re-groups m)))] + (let [^MatchEvaluator me (gen-delegate MatchEvaluator [m] (f (re-groups-direct m)))] + (.Replace re s me 1))) + ;;; (if (.find m) + ;;; (let [buffer (StringBuffer. (.length s)) + ;;; rep (Matcher/quoteReplacement (f (re-groups m)))] ;;; (.appendReplacement m buffer rep) ;;; (.appendTail m buffer) - ;;; (str buffer)) + ;;; (str buffer))) ;;; s))) (defn- replace-first-char diff --git a/Clojure/Clojure.Source/clojure/test/junit.clj b/Clojure/Clojure.Source/clojure/test/junit.clj index e75bdb021..319cade1b 100644 --- a/Clojure/Clojure.Source/clojure/test/junit.clj +++ b/Clojure/Clojure.Source/clojure/test/junit.clj @@ -80,7 +80,7 @@ (reverse (map #(:name (meta %)) vars))))) (defn package-class - [name] + [^System.String name] (let [i (.LastIndexOf name ".")] ;;; lastIndexOf (if (< i 0) [nil name] @@ -182,7 +182,7 @@ (defmacro with-junit-output "Execute body with modified test-is reporting functions that write JUnit-compatible XML output." - {:added "1.1"} + {:added "1.1"} [& body] `(binding [t/report junit-report *var-context* (list) diff --git a/Clojure/Clojure.Source/clojure/test/tap.clj b/Clojure/Clojure.Source/clojure/test/tap.clj index e958c5074..545926927 100644 --- a/Clojure/Clojure.Source/clojure/test/tap.clj +++ b/Clojure/Clojure.Source/clojure/test/tap.clj @@ -20,25 +20,25 @@ -(ns ^{:doc "clojure.test extensions for the Test Anything Protocol (TAP) - - TAP is a simple text-based syntax for reporting test results. TAP - was originally developed for Perl, and now has implementations in - several languages. For more information on TAP, see - http://testanything.org/ and - http://search.cpan.org/~petdance/TAP-1.0.0/TAP.pm - - To use this library, wrap any calls to - clojure.test/run-tests in the with-tap-output macro, - like this: - - (use 'clojure.test) - (use 'clojure.test.tap) - - (with-tap-output - (run-tests 'my.cool.library))" - :author "Stuart Sierra"} - clojure.test.tap +(ns ^{:doc "clojure.test extensions for the Test Anything Protocol (TAP) + + TAP is a simple text-based syntax for reporting test results. TAP + was originally developed for Perl, and now has implementations in + several languages. For more information on TAP, see + http://testanything.org/ and + http://search.cpan.org/~petdance/TAP-1.0.0/TAP.pm + + To use this library, wrap any calls to + clojure.test/run-tests in the with-tap-output macro, + like this: + + (use 'clojure.test) + (use 'clojure.test.tap) + + (with-tap-output + (run-tests 'my.cool.library))" + :author "Stuart Sierra"} + clojure.test.tap (:require [clojure.test :as t] [clojure.stacktrace :as stack])) @@ -53,7 +53,7 @@ string." {:added "1.1"} [data] - (doseq [line (.split ^String data "\n")] + (doseq [line (.Split ^String data "\n")] (println "#" line))) (defn print-tap-pass @@ -75,21 +75,21 @@ (t/with-test-out (print-tap-diagnostic (pr-str data)))) -(defn print-diagnostics [data] - (when (seq t/*testing-contexts*) - (print-tap-diagnostic (t/testing-contexts-str))) - (when (:message data) - (print-tap-diagnostic (:message data))) - (print-tap-diagnostic (str "expected:" (pr-str (:expected data)))) - (if (= :pass (:type data)) - (print-tap-diagnostic (str " actual:" (pr-str (:actual data)))) - (do - (print-tap-diagnostic - (str " actual:" - (with-out-str - (if (instance? Exception (:actual data)) ;;; Throwable - (stack/print-cause-trace (:actual data) t/*stack-trace-depth*) - (prn (:actual data))))))))) +(defn print-diagnostics [data] + (when (seq t/*testing-contexts*) + (print-tap-diagnostic (t/testing-contexts-str))) + (when (:message data) + (print-tap-diagnostic (:message data))) + (print-tap-diagnostic (str "expected:" (pr-str (:expected data)))) + (if (= :pass (:type data)) + (print-tap-diagnostic (str " actual:" (pr-str (:actual data)))) + (do + (print-tap-diagnostic + (str " actual:" + (with-out-str + (if (instance? Exception (:actual data)) ;;; Throwable + (stack/print-cause-trace (:actual data) t/*stack-trace-depth*) + (prn (:actual data))))))))) (defmethod tap-report :pass [data] (t/with-test-out @@ -101,12 +101,12 @@ (t/with-test-out (t/inc-report-counter :error) (print-tap-fail (t/testing-vars-str data)) - (print-diagnostics data))) - -(defmethod tap-report :fail [data] - (t/with-test-out - (t/inc-report-counter :fail) - (print-tap-fail (t/testing-vars-str data)) + (print-diagnostics data))) + +(defmethod tap-report :fail [data] + (t/with-test-out + (t/inc-report-counter :fail) + (print-tap-fail (t/testing-vars-str data)) (print-diagnostics data))) (defmethod tap-report :summary [data] diff --git a/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs b/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs index cb73b2e5c..12ed0881b 100644 --- a/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs @@ -94,17 +94,23 @@ public Expr Parse(ParserContext pcon, object form) return new StaticMethodExpr(source, spanMap, tag, t, fieldName, null, new List()); throw new MissingMemberException(t.Name, fieldName); } - else if (instance != null && instance.HasClrType && instance.ClrType != null) + else if (instance != null) { - Type instanceType = instance.ClrType; - if ((finfo = Reflector.GetField(instanceType, fieldName, false)) != null) + Type instanceType = (instance.HasClrType && instance.ClrType != null) ? instance.ClrType : typeof(object); + + if ((finfo = Reflector.GetField(instanceType, fieldName, false)) != null) { return new InstanceFieldExpr(source, spanMap, tag, instance, fieldName, finfo); - if ((pinfo = Reflector.GetProperty(instanceType, fieldName, false)) != null) + } + if ((pinfo = Reflector.GetProperty(instanceType, fieldName, false)) != null) { return new InstancePropertyExpr(source, spanMap, tag, instance, fieldName, pinfo); - if (!isPropName && Reflector.GetArityZeroMethod(instanceType, fieldName, false) != null) + } + if (!isPropName && Reflector.GetArityZeroMethod(instanceType, fieldName, false) != null) { return new InstanceMethodExpr(source, spanMap, tag, instance, fieldName, null, new List()); - if (pcon.IsAssignContext) + } + if (pcon.IsAssignContext) { + // Console.WriteLine("D"); return new InstanceFieldExpr(source, spanMap, tag, instance, fieldName, null); // same as InstancePropertyExpr when last arg is null + } else return new InstanceZeroArityCallExpr(source, spanMap, tag, instance, fieldName); } diff --git a/Clojure/Clojure/CljCompiler/Ast/MethodExpr.cs b/Clojure/Clojure/CljCompiler/Ast/MethodExpr.cs index d17c3d65b..6b50c99d2 100644 --- a/Clojure/Clojure/CljCompiler/Ast/MethodExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/MethodExpr.cs @@ -174,6 +174,8 @@ private void EmitComplexCall(ObjExpr objx, CljILGen ilg) // emit the args // emit the call (slightly different for light compile vs full) // + + Console.WriteLine("### EmitComplexCall " + _spanMap + " " + _source + " " + _methodName); // Build the parameter list diff --git a/Clojure/Clojure/Runtime/Reflector.cs b/Clojure/Clojure/Runtime/Reflector.cs index 99d7794dc..fca5cb245 100644 --- a/Clojure/Clojure/Runtime/Reflector.cs +++ b/Clojure/Clojure/Runtime/Reflector.cs @@ -177,6 +177,13 @@ public static MethodInfo GetMatchingMethod(IPersistentMap spanMap, Expr target, method = GetMatchingMethodAux(targetType, args, methods, methodName, false); hasMethods = methods.Count > 0; } + else + { + Type targetType = typeof(object); + IList methods = GetMethods(targetType, methodName, typeArgs, args.Count, false); + method = GetMatchingMethodAux(targetType, args, methods, methodName, false); + hasMethods = methods.Count > 0; + } MaybeReflectionWarn(spanMap, (target.HasClrType ? target.ClrType : null), false, hasMethods, method, methodName, args); return (MethodInfo)method; @@ -287,7 +294,7 @@ private static MethodBase GetMatchingMethodAux(Type targetType, IList a foreach (HostArg ha in args) { Expr e = ha.ArgExpr; - Type argType = e.HasClrType ? (e.ClrType ?? typeof(object)) : typeof(Object); + Type argType = e.HasClrType ? (e.ClrType ?? typeof(object)) : typeof(object); Type t; From cc7c02ae02dc9a29263922ac1f5057df8d783118 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sun, 7 Jun 2015 18:08:39 -0400 Subject: [PATCH 52/80] Add public parser context to HostExpr --- Clojure/Clojure/CljCompiler/Ast/HostExpr.cs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs b/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs index 12ed0881b..31df49d20 100644 --- a/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs @@ -29,6 +29,8 @@ public abstract class HostExpr : Expr, MaybePrimitiveExpr #endregion #region Parsing + + public ParserContext ParsedContext { get; set; } public sealed class Parser : IParser { From f7d4d7ed8557b6266f2c76f8e2013ab22974c713 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Wed, 5 Aug 2015 22:04:41 -0400 Subject: [PATCH 53/80] Make changes for MAGE --- Clojure/Clojure/CljCompiler/Ast/AssignExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/BodyExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/CaseExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/DefExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/EmptyExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/Expr.cs | 1 + Clojure/Clojure/CljCompiler/Ast/FnExpr.cs | 2 +- Clojure/Clojure/CljCompiler/Ast/IfExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/ImportExpr.cs | 2 ++ .../Clojure/CljCompiler/Ast/InstanceOfExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/InvokeExpr.cs | 2 ++ .../CljCompiler/Ast/KeywordInvokeExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/LetExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/LetFnExpr.cs | 2 ++ .../Clojure/CljCompiler/Ast/LiteralExpr.cs | 2 ++ .../CljCompiler/Ast/LocalBindingExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/MapExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/MetaExpr.cs | 2 ++ .../CljCompiler/Ast/MethodParamExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/NewExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs | 2 ++ .../Clojure/CljCompiler/Ast/ParserContext.cs | 20 +++++++++++++++++++ Clojure/Clojure/CljCompiler/Ast/RecurExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/SetExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/TheVarExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/TryExpr.cs | 2 ++ .../CljCompiler/Ast/UnresolvedVarExpr.cs | 2 ++ .../Clojure/CljCompiler/Ast/UntypedExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/VarExpr.cs | 2 ++ Clojure/Clojure/CljCompiler/Ast/VectorExpr.cs | 2 ++ 30 files changed, 76 insertions(+), 1 deletion(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/AssignExpr.cs b/Clojure/Clojure/CljCompiler/Ast/AssignExpr.cs index 76857f594..014807a13 100644 --- a/Clojure/Clojure/CljCompiler/Ast/AssignExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/AssignExpr.cs @@ -18,6 +18,8 @@ namespace clojure.lang.CljCompiler.Ast { class AssignExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data readonly AssignableExpr _target; diff --git a/Clojure/Clojure/CljCompiler/Ast/BodyExpr.cs b/Clojure/Clojure/CljCompiler/Ast/BodyExpr.cs index 7c1071c0a..30c7ac3c2 100644 --- a/Clojure/Clojure/CljCompiler/Ast/BodyExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/BodyExpr.cs @@ -18,6 +18,8 @@ namespace clojure.lang.CljCompiler.Ast { class BodyExpr : Expr, MaybePrimitiveExpr { + public ParserContext ParsedContext { get; set; } + #region Data readonly IPersistentVector _exprs; diff --git a/Clojure/Clojure/CljCompiler/Ast/CaseExpr.cs b/Clojure/Clojure/CljCompiler/Ast/CaseExpr.cs index dcd537678..c30354486 100644 --- a/Clojure/Clojure/CljCompiler/Ast/CaseExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/CaseExpr.cs @@ -21,6 +21,8 @@ namespace clojure.lang.CljCompiler.Ast { class CaseExpr : Expr, MaybePrimitiveExpr { + public ParserContext ParsedContext { get; set; } + #region Data readonly LocalBindingExpr _expr; diff --git a/Clojure/Clojure/CljCompiler/Ast/DefExpr.cs b/Clojure/Clojure/CljCompiler/Ast/DefExpr.cs index 8a2ff1445..ea370665c 100644 --- a/Clojure/Clojure/CljCompiler/Ast/DefExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/DefExpr.cs @@ -20,6 +20,8 @@ namespace clojure.lang.CljCompiler.Ast { class DefExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data readonly Var _var; diff --git a/Clojure/Clojure/CljCompiler/Ast/EmptyExpr.cs b/Clojure/Clojure/CljCompiler/Ast/EmptyExpr.cs index 9803f0d21..9e2ccee4e 100644 --- a/Clojure/Clojure/CljCompiler/Ast/EmptyExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/EmptyExpr.cs @@ -20,6 +20,8 @@ namespace clojure.lang.CljCompiler.Ast { class EmptyExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data readonly object _coll; diff --git a/Clojure/Clojure/CljCompiler/Ast/Expr.cs b/Clojure/Clojure/CljCompiler/Ast/Expr.cs index b7fa1a265..97a765777 100644 --- a/Clojure/Clojure/CljCompiler/Ast/Expr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/Expr.cs @@ -24,6 +24,7 @@ public interface Expr object Eval(); void Emit(RHC rhc, ObjExpr objx, CljILGen ilg); + ParserContext ParsedContext { get; set; } bool HasNormalExit(); } diff --git a/Clojure/Clojure/CljCompiler/Ast/FnExpr.cs b/Clojure/Clojure/CljCompiler/Ast/FnExpr.cs index 15f003339..f532d714d 100644 --- a/Clojure/Clojure/CljCompiler/Ast/FnExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/FnExpr.cs @@ -69,7 +69,7 @@ internal void ComputeNames(ISeq form, string name) (Compiler.munge(name).Replace(".", "_DOT_") + (enclosingMethod != null ? "__" + RT.nextID() : "")) : ("fn" - + "__" + RT.nextID()); + + "__" + RT.nextID()); _name = baseName + simpleName; InternalName = _name.Replace('.', '/'); diff --git a/Clojure/Clojure/CljCompiler/Ast/IfExpr.cs b/Clojure/Clojure/CljCompiler/Ast/IfExpr.cs index 81a5bf70b..9d678a254 100644 --- a/Clojure/Clojure/CljCompiler/Ast/IfExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/IfExpr.cs @@ -19,6 +19,8 @@ namespace clojure.lang.CljCompiler.Ast { class IfExpr : Expr, MaybePrimitiveExpr { + public ParserContext ParsedContext { get; set; } + #region Data readonly IPersistentMap _sourceSpan; diff --git a/Clojure/Clojure/CljCompiler/Ast/ImportExpr.cs b/Clojure/Clojure/CljCompiler/Ast/ImportExpr.cs index b175ae427..31ecbf301 100644 --- a/Clojure/Clojure/CljCompiler/Ast/ImportExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/ImportExpr.cs @@ -19,6 +19,8 @@ namespace clojure.lang.CljCompiler.Ast { class ImportExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data readonly string _c; diff --git a/Clojure/Clojure/CljCompiler/Ast/InstanceOfExpr.cs b/Clojure/Clojure/CljCompiler/Ast/InstanceOfExpr.cs index 2b468cc28..8780a1684 100644 --- a/Clojure/Clojure/CljCompiler/Ast/InstanceOfExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/InstanceOfExpr.cs @@ -20,6 +20,8 @@ namespace clojure.lang.CljCompiler.Ast { sealed class InstanceOfExpr : Expr, MaybePrimitiveExpr { + public ParserContext ParsedContext { get; set; } + #region Data readonly Expr _expr; diff --git a/Clojure/Clojure/CljCompiler/Ast/InvokeExpr.cs b/Clojure/Clojure/CljCompiler/Ast/InvokeExpr.cs index 89873aaa2..eb5bbff7e 100644 --- a/Clojure/Clojure/CljCompiler/Ast/InvokeExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/InvokeExpr.cs @@ -21,6 +21,8 @@ namespace clojure.lang.CljCompiler.Ast { class InvokeExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data readonly Expr _fexpr; diff --git a/Clojure/Clojure/CljCompiler/Ast/KeywordInvokeExpr.cs b/Clojure/Clojure/CljCompiler/Ast/KeywordInvokeExpr.cs index e39a298af..c80f0f139 100644 --- a/Clojure/Clojure/CljCompiler/Ast/KeywordInvokeExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/KeywordInvokeExpr.cs @@ -19,6 +19,8 @@ namespace clojure.lang.CljCompiler.Ast { sealed class KeywordInvokeExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data readonly KeywordExpr _kw; diff --git a/Clojure/Clojure/CljCompiler/Ast/LetExpr.cs b/Clojure/Clojure/CljCompiler/Ast/LetExpr.cs index b80c3da34..09fdb0927 100644 --- a/Clojure/Clojure/CljCompiler/Ast/LetExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/LetExpr.cs @@ -20,6 +20,8 @@ namespace clojure.lang.CljCompiler.Ast { class LetExpr : Expr, MaybePrimitiveExpr { + public ParserContext ParsedContext { get; set; } + #region Data readonly IPersistentVector _bindingInits; diff --git a/Clojure/Clojure/CljCompiler/Ast/LetFnExpr.cs b/Clojure/Clojure/CljCompiler/Ast/LetFnExpr.cs index 9ec131856..0b42fd309 100644 --- a/Clojure/Clojure/CljCompiler/Ast/LetFnExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/LetFnExpr.cs @@ -20,6 +20,8 @@ namespace clojure.lang.CljCompiler.Ast { class LetFnExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data readonly IPersistentVector _bindingInits; diff --git a/Clojure/Clojure/CljCompiler/Ast/LiteralExpr.cs b/Clojure/Clojure/CljCompiler/Ast/LiteralExpr.cs index 5d065086a..b383a3ea7 100644 --- a/Clojure/Clojure/CljCompiler/Ast/LiteralExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/LiteralExpr.cs @@ -19,6 +19,8 @@ namespace clojure.lang.CljCompiler.Ast { abstract class LiteralExpr : Expr { + public ParserContext ParsedContext { get; set; } + public abstract object Val { get; } #region Expr Members diff --git a/Clojure/Clojure/CljCompiler/Ast/LocalBindingExpr.cs b/Clojure/Clojure/CljCompiler/Ast/LocalBindingExpr.cs index 42e844533..1f916f855 100644 --- a/Clojure/Clojure/CljCompiler/Ast/LocalBindingExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/LocalBindingExpr.cs @@ -19,6 +19,8 @@ namespace clojure.lang.CljCompiler.Ast { class LocalBindingExpr : Expr, MaybePrimitiveExpr, AssignableExpr { + public ParserContext ParsedContext { get; set; } + #region Data readonly LocalBinding _b; diff --git a/Clojure/Clojure/CljCompiler/Ast/MapExpr.cs b/Clojure/Clojure/CljCompiler/Ast/MapExpr.cs index 04ed3d876..1b7cd1556 100644 --- a/Clojure/Clojure/CljCompiler/Ast/MapExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/MapExpr.cs @@ -19,6 +19,8 @@ namespace clojure.lang.CljCompiler.Ast { class MapExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data readonly IPersistentVector _keyvals; diff --git a/Clojure/Clojure/CljCompiler/Ast/MetaExpr.cs b/Clojure/Clojure/CljCompiler/Ast/MetaExpr.cs index 7135a394b..b5207816b 100644 --- a/Clojure/Clojure/CljCompiler/Ast/MetaExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/MetaExpr.cs @@ -20,6 +20,8 @@ namespace clojure.lang.CljCompiler.Ast { class MetaExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data readonly Expr _expr; diff --git a/Clojure/Clojure/CljCompiler/Ast/MethodParamExpr.cs b/Clojure/Clojure/CljCompiler/Ast/MethodParamExpr.cs index 0a23d196d..230895ecd 100644 --- a/Clojure/Clojure/CljCompiler/Ast/MethodParamExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/MethodParamExpr.cs @@ -19,6 +19,8 @@ namespace clojure.lang.CljCompiler.Ast { sealed class MethodParamExpr : Expr, MaybePrimitiveExpr { + public ParserContext ParsedContext { get; set; } + #region Data readonly Type _t; diff --git a/Clojure/Clojure/CljCompiler/Ast/NewExpr.cs b/Clojure/Clojure/CljCompiler/Ast/NewExpr.cs index 8fb673c15..f8e775abe 100644 --- a/Clojure/Clojure/CljCompiler/Ast/NewExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/NewExpr.cs @@ -29,6 +29,8 @@ namespace clojure.lang.CljCompiler.Ast { class NewExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data readonly List _args; diff --git a/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs b/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs index f14da17db..1eb7d6754 100644 --- a/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs @@ -26,6 +26,8 @@ namespace clojure.lang.CljCompiler.Ast { public class ObjExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data const string ConstPrefix = "const__"; diff --git a/Clojure/Clojure/CljCompiler/Ast/ParserContext.cs b/Clojure/Clojure/CljCompiler/Ast/ParserContext.cs index c87eb5920..7843678c4 100644 --- a/Clojure/Clojure/CljCompiler/Ast/ParserContext.cs +++ b/Clojure/Clojure/CljCompiler/Ast/ParserContext.cs @@ -42,6 +42,26 @@ public bool IsRecurContext { get { return _rhc == RHC.Return; } } + + public bool IsStatementContext + { + get { return _rhc == RHC.Statement; } + } + + public bool IsExpressionContext + { + get { return _rhc == RHC.Expression; } + } + + public bool IsReturnContext + { + get { return _rhc == RHC.Return; } + } + + public bool IsEvalContext + { + get { return _rhc == RHC.Eval; } + } readonly bool _isAssignContext; diff --git a/Clojure/Clojure/CljCompiler/Ast/RecurExpr.cs b/Clojure/Clojure/CljCompiler/Ast/RecurExpr.cs index 7258cf7c4..2784bbb45 100644 --- a/Clojure/Clojure/CljCompiler/Ast/RecurExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/RecurExpr.cs @@ -20,6 +20,8 @@ namespace clojure.lang.CljCompiler.Ast { class RecurExpr : Expr, MaybePrimitiveExpr { + public ParserContext ParsedContext { get; set; } + #region Data readonly IPersistentVector _args; diff --git a/Clojure/Clojure/CljCompiler/Ast/SetExpr.cs b/Clojure/Clojure/CljCompiler/Ast/SetExpr.cs index d22bc0ec8..bb5469e08 100644 --- a/Clojure/Clojure/CljCompiler/Ast/SetExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/SetExpr.cs @@ -19,6 +19,8 @@ namespace clojure.lang.CljCompiler.Ast { class SetExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data readonly IPersistentVector _keys; diff --git a/Clojure/Clojure/CljCompiler/Ast/TheVarExpr.cs b/Clojure/Clojure/CljCompiler/Ast/TheVarExpr.cs index 1cb6a8bb0..f4fd6f32f 100644 --- a/Clojure/Clojure/CljCompiler/Ast/TheVarExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/TheVarExpr.cs @@ -20,6 +20,8 @@ namespace clojure.lang.CljCompiler.Ast { class TheVarExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data readonly Var _var; diff --git a/Clojure/Clojure/CljCompiler/Ast/TryExpr.cs b/Clojure/Clojure/CljCompiler/Ast/TryExpr.cs index baa32da7c..467c5c95d 100644 --- a/Clojure/Clojure/CljCompiler/Ast/TryExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/TryExpr.cs @@ -19,6 +19,8 @@ namespace clojure.lang.CljCompiler.Ast { class TryExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Nested classes public sealed class CatchClause diff --git a/Clojure/Clojure/CljCompiler/Ast/UnresolvedVarExpr.cs b/Clojure/Clojure/CljCompiler/Ast/UnresolvedVarExpr.cs index 61a9108d1..aa5baa648 100644 --- a/Clojure/Clojure/CljCompiler/Ast/UnresolvedVarExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/UnresolvedVarExpr.cs @@ -19,6 +19,8 @@ namespace clojure.lang.CljCompiler.Ast { class UnresolvedVarExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data readonly Symbol _symbol; diff --git a/Clojure/Clojure/CljCompiler/Ast/UntypedExpr.cs b/Clojure/Clojure/CljCompiler/Ast/UntypedExpr.cs index d8782a2a3..7a12e22f7 100644 --- a/Clojure/Clojure/CljCompiler/Ast/UntypedExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/UntypedExpr.cs @@ -19,6 +19,8 @@ namespace clojure.lang.CljCompiler.Ast { abstract class UntypedExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Expr Members public bool HasClrType diff --git a/Clojure/Clojure/CljCompiler/Ast/VarExpr.cs b/Clojure/Clojure/CljCompiler/Ast/VarExpr.cs index 636c289ce..a7cc98b53 100644 --- a/Clojure/Clojure/CljCompiler/Ast/VarExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/VarExpr.cs @@ -20,6 +20,8 @@ namespace clojure.lang.CljCompiler.Ast { class VarExpr : Expr, AssignableExpr { + public ParserContext ParsedContext { get; set; } + #region Data readonly Var _var; diff --git a/Clojure/Clojure/CljCompiler/Ast/VectorExpr.cs b/Clojure/Clojure/CljCompiler/Ast/VectorExpr.cs index e87444bdc..1e5a94514 100644 --- a/Clojure/Clojure/CljCompiler/Ast/VectorExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/VectorExpr.cs @@ -19,6 +19,8 @@ namespace clojure.lang.CljCompiler.Ast { class VectorExpr : Expr { + public ParserContext ParsedContext { get; set; } + #region Data readonly IPersistentVector _args; From 0dec5a11beb1be0e4307afca4fb8368f11287b1a Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Wed, 5 Aug 2015 22:05:25 -0400 Subject: [PATCH 54/80] Emit parsed context for MAGE --- Clojure/Clojure/CljCompiler/Compiler.cs | 38 ++++++++++++++++--------- 1 file changed, 24 insertions(+), 14 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index ba50d999f..f7a7e8ab6 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -1757,6 +1757,7 @@ public static Expr Analyze(ParserContext pcontext, object form, string name) { try { + Expr retExpr = null; if (form is LazySeq) { form = RT.seq(form); @@ -1764,36 +1765,45 @@ public static Expr Analyze(ParserContext pcontext, object form, string name) form = PersistentList.EMPTY; } if (form == null) - return NilExprInstance; + retExpr = NilExprInstance; else if (form is Boolean) - return ((bool)form) ? TrueExprInstance : FalseExprInstance; + retExpr = ((bool)form) ? TrueExprInstance : FalseExprInstance; + + if(retExpr != null) { + retExpr.ParsedContext = pcontext; + return retExpr; + } Type type = form.GetType(); if (type == typeof(Symbol)) - return AnalyzeSymbol((Symbol)form); + retExpr = AnalyzeSymbol((Symbol)form); else if (type == typeof(Keyword)) - return RegisterKeyword((Keyword)form); + retExpr = RegisterKeyword((Keyword)form); else if (Util.IsNumeric(form)) - return NumberExpr.Parse(form); + retExpr = NumberExpr.Parse(form); else if (type == typeof(String)) - return new StringExpr(String.Intern((String)form)); + retExpr = new StringExpr(String.Intern((String)form)); else if (form is IPersistentCollection && ((IPersistentCollection)form).count() == 0) - return OptionallyGenerateMetaInit(pcontext, form, new EmptyExpr(form)); + retExpr = OptionallyGenerateMetaInit(pcontext, form, new EmptyExpr(form)); else if (form is ISeq) - return AnalyzeSeq(pcontext, (ISeq)form, name); + retExpr = AnalyzeSeq(pcontext, (ISeq)form, name); else if (form is IPersistentVector) - return VectorExpr.Parse(pcontext, (IPersistentVector)form); + retExpr = VectorExpr.Parse(pcontext, (IPersistentVector)form); else if (form is IRecord) - return new ConstantExpr(form); + retExpr = new ConstantExpr(form); else if (form is IType) - return new ConstantExpr(form); + retExpr = new ConstantExpr(form); else if (form is IPersistentMap) - return MapExpr.Parse(pcontext, (IPersistentMap)form); + retExpr = MapExpr.Parse(pcontext, (IPersistentMap)form); else if (form is IPersistentSet) - return SetExpr.Parse(pcontext, (IPersistentSet)form); + retExpr = SetExpr.Parse(pcontext, (IPersistentSet)form); else - return new ConstantExpr(form); + retExpr = new ConstantExpr(form); + + retExpr.ParsedContext = pcontext; + return retExpr; + } catch (CompilerException) { From b644996b3d22ca7a6ee4e37c047763811e703a75 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Wed, 5 Aug 2015 22:11:46 -0400 Subject: [PATCH 55/80] Add codepath to TryLoadInitType --- Clojure/Clojure/CljCompiler/Compiler.cs | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index f7a7e8ab6..4ca01e194 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -1642,9 +1642,26 @@ internal static bool TryLoadInitType(string relativePath) if (initType != null) break; } - if (initType == null) - return false; - + // Slow lookup due to possible mono bug -nasser + if (initType == null) + { + foreach (var asm in AppDomain.CurrentDomain.GetAssemblies()) + { + if (initType == null) + { + foreach (var t in asm.GetTypes()) + { + if (t.Name == initClassName) + { + initType = t; + break; + } + } + } else { + break; + } + } + } InvokeInitType(initType.Assembly, initType); return true; } From 7b3b56f4f23a29644db20f19fc3b4f6ba03a1f7b Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Wed, 5 Aug 2015 22:13:06 -0400 Subject: [PATCH 56/80] Support numerical keywords --- Clojure/Clojure/Lib/LispReader.cs | 25 ++++++------------------- 1 file changed, 6 insertions(+), 19 deletions(-) diff --git a/Clojure/Clojure/Lib/LispReader.cs b/Clojure/Clojure/Lib/LispReader.cs index 73c0eeb26..85e50723e 100644 --- a/Clojure/Clojure/Lib/LispReader.cs +++ b/Clojure/Clojure/Lib/LispReader.cs @@ -529,25 +529,12 @@ static object matchSymbol(string token, string mask) return null; } - bool isKeyword = mask[0] == ':'; - - if (isKeyword) - { - Match m2 = symbolPat.Match(mask.Substring(1)); - if (!m2.Success) - return null; - string ns; - string name; - ExtractNamesUsingMask(token.Substring(1), m2.Groups[1].Value, m2.Groups[2].Value, out ns, out name); - return Keyword.intern(ns, name); - } - else - { - string ns; - string name; - ExtractNamesUsingMask(token, maskNS, maskName, out ns, out name); - return Symbol.intern(ns, name); - } + bool isKeyword = token[0] == ':'; + + Symbol sym = Symbol.intern(token.Substring(isKeyword ? 1 : 0)); + if(isKeyword) + return Keyword.intern(sym); + return sym; } return null; From b9d0d7a41f100c471950a5fef2acff3f06f6f3f1 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Thu, 6 Aug 2015 01:04:24 -0400 Subject: [PATCH 57/80] Fix static constructors in defclass The logic that was in the static constructor was moved to an instance method that can be called from the Awake method. This was done to avoid Unity's inability to guarantee the order that static constructors will be called in. The new method is named "CarlylesMouse" on the principled insistence of Tims Gardner who, while striking the arm of Ramsey Nasser repeatedly, made the case that "No, it is not a Static Constructor. It is a mouse. It belongs to Carlyle. It's CarlylesMouse." His wisdom stands. --- .../CljCompiler/Ast/NewClassInstanceExpr.cs | 22 +++++++++++++++++++ Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs | 11 ++++------ 2 files changed, 26 insertions(+), 7 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs index 6bf44ba8d..5d644328e 100644 --- a/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs @@ -19,6 +19,14 @@ using System.Runtime.CompilerServices; using Microsoft.Scripting.Generation; +namespace clojure.lang +{ + public interface IStaticConstructor + { + void CarlylesMouse(); + } +} + namespace clojure.lang.CljCompiler.Ast { // Copied and modified from NewInstanceExpr to support the defclass* special form @@ -263,6 +271,20 @@ internal static ObjExpr Build( return ret; } + protected override void DefineStaticConstructor(TypeBuilder fnTB) + { + MethodBuilder mb = fnTB.DefineMethod( + "IStaticConstructor.CarlylesMouse", + MethodAttributes.ReuseSlot | MethodAttributes.Public | MethodAttributes.Virtual, + typeof(void), + Type.EmptyTypes); + fnTB.DefineMethodOverride(mb, typeof(IStaticConstructor).GetMethod("CarlylesMouse")); + fnTB.AddInterfaceImplementation(typeof(IStaticConstructor)); + CljILGen ilg = new CljILGen(mb.GetILGenerator()); + EmitRequireNamespace(ilg); + EmitStaticConstructorBody(ilg); + } + private static Type[] SeqToTypeArray(IPersistentVector interfaces) { Type[] types = new Type[interfaces.count()]; diff --git a/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs b/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs index 1eb7d6754..dbadefd12 100644 --- a/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs @@ -429,20 +429,17 @@ void EmitKeywordCallsiteDefs(TypeBuilder baseTB) } } - private void DefineStaticConstructor(TypeBuilder fnTB) + protected virtual void DefineStaticConstructor(TypeBuilder fnTB) { ConstructorBuilder cb = fnTB.DefineConstructor(MethodAttributes.Static, CallingConventions.Standard, Type.EmptyTypes); EmitStaticConstructorBody(new CljILGen(cb.GetILGenerator())); } - - private void EmitStaticConstructorBody(CljILGen ilg) + + protected void EmitStaticConstructorBody(CljILGen ilg) { GenContext.EmitDebugInfo(ilg, SpanMap); - if(IsDefType) - EmitRequireNamespace(ilg); - if (Constants.count() > 0) EmitConstantFieldInits(ilg); @@ -452,7 +449,7 @@ private void EmitStaticConstructorBody(CljILGen ilg) ilg.Emit(OpCodes.Ret); } - private void EmitRequireNamespace(CljILGen ilg) + protected void EmitRequireNamespace(CljILGen ilg) { if(((Namespace)RT.CurrentNSVar.deref()).Name.ToString() != "clojure.core") { From f9a1b00f52ca46a884d0aac211e22343666c518e Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Mon, 14 Sep 2015 20:37:57 -0400 Subject: [PATCH 58/80] Disable primitive local error --- Clojure/Clojure/CljCompiler/Ast/LocalBinding.cs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/LocalBinding.cs b/Clojure/Clojure/CljCompiler/Ast/LocalBinding.cs index 9078471f9..6ff82e616 100644 --- a/Clojure/Clojure/CljCompiler/Ast/LocalBinding.cs +++ b/Clojure/Clojure/CljCompiler/Ast/LocalBinding.cs @@ -86,8 +86,8 @@ public bool RecurMismatch public LocalBinding(int index, Symbol sym, Symbol tag, Expr init, bool isThis, bool isArg, bool isByRef) { - if (Compiler.MaybePrimitiveType(init) != null && tag != null) - throw new InvalidOperationException("Can't type hint a local with a primitive initializer"); + // if (Compiler.MaybePrimitiveType(init) != null && tag != null) + // throw new InvalidOperationException("Can't type hint a local with a primitive initializer"); _index = index; _sym = sym; From d835111fdbf15bd23c40bbe99306e9ffef705454 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Wed, 13 Apr 2016 12:20:41 -0400 Subject: [PATCH 59/80] Spot fix type information in HostExpr --- Clojure/Clojure/CljCompiler/Ast/HostExpr.cs | 9 ++++++++- .../Clojure/CljCompiler/Ast/InstanceZeroArityCallExpr.cs | 7 ++++++- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs b/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs index 31df49d20..4efe9d762 100644 --- a/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/HostExpr.cs @@ -98,7 +98,14 @@ public Expr Parse(ParserContext pcon, object form) } else if (instance != null) { - Type instanceType = (instance.HasClrType && instance.ClrType != null) ? instance.ClrType : typeof(object); + Type instanceType; + + // SPOT FIX -nasser + if(instance is InstanceZeroArityCallExpr) { + instanceType = instance.ClrType ?? typeof(object) ; + } else { + instanceType = (instance.HasClrType && instance.ClrType != null) ? instance.ClrType : typeof(object); + } if ((finfo = Reflector.GetField(instanceType, fieldName, false)) != null) { return new InstanceFieldExpr(source, spanMap, tag, instance, fieldName, finfo); diff --git a/Clojure/Clojure/CljCompiler/Ast/InstanceZeroArityCallExpr.cs b/Clojure/Clojure/CljCompiler/Ast/InstanceZeroArityCallExpr.cs index 9e530605b..84e36985f 100644 --- a/Clojure/Clojure/CljCompiler/Ast/InstanceZeroArityCallExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/InstanceZeroArityCallExpr.cs @@ -80,7 +80,12 @@ public override bool HasClrType public override Type ClrType { - get { return HostExpr.TagToType(_tag); } + get + { + return _tag != null + ? HostExpr.TagToType(_tag) + : typeof(object); + } } #endregion From 20835c40d2e30b6a918047762be16231d1438f72 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Wed, 13 Apr 2016 12:28:36 -0400 Subject: [PATCH 60/80] Remove debug message from MethodExpr --- Clojure/Clojure/CljCompiler/Ast/MethodExpr.cs | 2 -- 1 file changed, 2 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/MethodExpr.cs b/Clojure/Clojure/CljCompiler/Ast/MethodExpr.cs index 6b50c99d2..384dd14f2 100644 --- a/Clojure/Clojure/CljCompiler/Ast/MethodExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/MethodExpr.cs @@ -175,8 +175,6 @@ private void EmitComplexCall(ObjExpr objx, CljILGen ilg) // emit the call (slightly different for light compile vs full) // - Console.WriteLine("### EmitComplexCall " + _spanMap + " " + _source + " " + _methodName); - // Build the parameter list List paramExprs = new List(_args.Count + 1); From 69e1e2797d81464282186f9ae0841b0170ad5031 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Wed, 13 Apr 2016 12:29:39 -0400 Subject: [PATCH 61/80] Uncomment timer code in RT --- Clojure/Clojure/Lib/RT.cs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Clojure/Clojure/Lib/RT.cs b/Clojure/Clojure/Lib/RT.cs index 1904adf5a..9ab291b42 100644 --- a/Clojure/Clojure/Lib/RT.cs +++ b/Clojure/Clojure/Lib/RT.cs @@ -601,11 +601,11 @@ static RT() static void DoInit() { - //Stopwatch sw = new Stopwatch(); - //sw.Start(); + Stopwatch sw = new Stopwatch(); + sw.Start(); load("clojure/core"); - //sw.Stop(); - //Console.WriteLine("Initial clojure/core load: {0} milliseconds.", sw.ElapsedMilliseconds); + sw.Stop(); + Console.WriteLine("Initial clojure/core load: {0} milliseconds.", sw.ElapsedMilliseconds); PostBootstrapInit(); } From 97ffb3ce20e3528ed32d08c4e6937aeea3d96f93 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Wed, 13 Apr 2016 12:52:21 -0400 Subject: [PATCH 62/80] Add fast path to compiler init type lookup --- Clojure/Clojure/CljCompiler/Compiler.cs | 31 +++++++++++++------------ 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index 4ca01e194..3f520a642 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -1374,7 +1374,8 @@ public static string IsCompilingSuffix() internal static string InitClassName(string sourcePath) { - return "__Init__$" + sourcePath.Replace(".", "/"); + // munge slashes to __SLASH__ to avoid mono lookup bug -nasser + return "__Init__$" + sourcePath.Replace(".", "/").Replace("/", "__SLASH__"); } public static void PushNS() @@ -1583,20 +1584,8 @@ internal static void LoadAssembly(byte[] assyData, string relativePath) private static Type GetTypeFromAssy(Assembly assy, string typeName) { - if (RT.IsRunningOnMono) - { - // I have no idea why Mono can't find our initializer types using Assembly.GetType(string). - // This is roll-your-own. - Type[] types = assy.GetExportedTypes(); - foreach (Type t in types) - { - if (t.Name.Equals(typeName)) - return t; - } - return null; - } - else - return assy.GetType(typeName); + // removing slashes in init types makes them findable on mono -nasser + return assy.GetType(typeName); } [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Design", "CA1031:DoNotCatchGeneralExceptionTypes")] @@ -1630,6 +1619,17 @@ internal static bool TryLoadInitType(string relativePath) { var initClassName = InitClassName(relativePath); Type initType = null; + + // fastest, look up initClassName and assembly + StringBuilder assemblyQualifiedInitClassName = new StringBuilder(); + assemblyQualifiedInitClassName.Append(initClassName); + assemblyQualifiedInitClassName.Append(", "); + assemblyQualifiedInitClassName.Append(relativePath.Replace("/", ".")); + assemblyQualifiedInitClassName.Append(".clj"); + initType = Type.GetType(assemblyQualifiedInitClassName.ToString()); + + if(initType == null) + { foreach (var asm in AppDomain.CurrentDomain.GetAssemblies()) { #if CLR2 @@ -1642,6 +1642,7 @@ internal static bool TryLoadInitType(string relativePath) if (initType != null) break; } + } // Slow lookup due to possible mono bug -nasser if (initType == null) { From e6d5f5900c1c65b1b030cdf4b15146d0d834c056 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Thu, 14 Apr 2016 19:05:06 -0400 Subject: [PATCH 63/80] Throw meaningful error when import cannot find a type --- Clojure/Clojure/CljCompiler/Ast/ImportExpr.cs | 2 +- Clojure/Clojure/CljCompiler/Compiler.cs | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/ImportExpr.cs b/Clojure/Clojure/CljCompiler/Ast/ImportExpr.cs index 31ecbf301..1b6af2f1d 100644 --- a/Clojure/Clojure/CljCompiler/Ast/ImportExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/ImportExpr.cs @@ -79,7 +79,7 @@ public void Emit(RHC rhc, ObjExpr objx, CljILGen ilg) { ilg.Emit(OpCodes.Call,Compiler.Method_Compiler_CurrentNamespace.GetGetMethod()); ilg.Emit(OpCodes.Ldstr, _c); - ilg.Emit(OpCodes.Call, Compiler.Method_RT_classForName); + ilg.Emit(OpCodes.Call, Compiler.Method_RT_classForNameE); ilg.Emit(OpCodes.Call, Compiler.Method_Namespace_importClass1); if (rhc == RHC.Statement) ilg.Emit(OpCodes.Pop); diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index 3f520a642..75547957f 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -306,6 +306,7 @@ static IParser GetSpecialFormParser(object op) internal static readonly MethodInfo Method_Reflector_SetInstanceFieldOrProperty = typeof(Reflector).GetMethod("SetInstanceFieldOrProperty"); internal static readonly MethodInfo Method_RT_classForName = typeof(RT).GetMethod("classForName"); + internal static readonly MethodInfo Method_RT_classForNameE = typeof(RT).GetMethod("classForNameE"); internal static readonly MethodInfo Method_RT_intCast_long = typeof(RT).GetMethod("intCast", new Type[] { typeof(long) }); internal static readonly MethodInfo Method_RT_uncheckedIntCast_long = typeof(RT).GetMethod("uncheckedIntCast", new Type[] { typeof(long) }); internal static readonly MethodInfo Method_RT_keyword = typeof(RT).GetMethod("keyword"); From db4ab3e6ae8560e1a25fd2ac4c38b095103d9b47 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Mon, 20 Jun 2016 11:54:57 -0400 Subject: [PATCH 64/80] Stop emitting explicit overrides in deftypes Fixes protocol loading bugs --- Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs index 9638b5ca7..6b064c86b 100644 --- a/Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/NewInstanceExpr.cs @@ -553,7 +553,7 @@ private static void EmitDummyMethod(TypeBuilder tb, MethodInfo mi,bool isExplici CljILGen gen = new CljILGen(mb.GetILGenerator()); gen.EmitNew(typeof(NotImplementedException), Type.EmptyTypes); gen.Emit(OpCodes.Throw); - tb.DefineMethodOverride(mb, mi); + // tb.DefineMethodOverride(mb, mi); } #endregion From 0931ce49e6670a20a545abd05e3e7b0d32c421d6 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Wed, 3 Aug 2016 13:36:59 +0300 Subject: [PATCH 65/80] Use better error message on missing init type --- Clojure/Clojure/CljCompiler/Compiler.cs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index 75547957f..d82e655b7 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -1663,6 +1663,10 @@ internal static bool TryLoadInitType(string relativePath) break; } } + } + if(initType == null) + { + throw new AssemblyLoadException(String.Format("Failed loading Init Type for {0}", relativePath)); } InvokeInitType(initType.Assembly, initType); return true; From eace10d8b9ab992bdee7175a09c3aca6efdba617 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Tue, 9 Aug 2016 15:02:06 +0300 Subject: [PATCH 66/80] Allow closures over nil locals Fixes https://github.com/arcadia-unity/Arcadia/issues/158 --- Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs b/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs index dbadefd12..660211a64 100644 --- a/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs @@ -524,7 +524,7 @@ protected void EmitClosedOverFields(TypeBuilder tb) attributes |= FieldAttributes.InitOnly; } - Type type = lb.HasClrType ? lb.ClrType : (lb.PrimitiveType ?? typeof(object)); + Type type = (lb.HasClrType && lb.ClrType != null) ? lb.ClrType : (lb.PrimitiveType ?? typeof(object)); FieldBuilder fb = markVolatile ? tb.DefineField(lb.Name, type, new Type[] { typeof(IsVolatile) }, Type.EmptyTypes, attributes) From 307367aece5a5582391b41365176d631c509723b Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Fri, 27 Jan 2017 20:48:37 -0500 Subject: [PATCH 67/80] Remove NewClassInstanceExpr --- .../CljCompiler/Ast/NewClassInstanceExpr.cs | 508 ------------------ Clojure/Clojure/Clojure.csproj | 3 +- 2 files changed, 1 insertion(+), 510 deletions(-) delete mode 100644 Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs diff --git a/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs b/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs deleted file mode 100644 index 5d644328e..000000000 --- a/Clojure/Clojure/CljCompiler/Ast/NewClassInstanceExpr.cs +++ /dev/null @@ -1,508 +0,0 @@ -/** - * Copyright (c) Rich Hickey. All rights reserved. - * The use and distribution terms for this software are covered by the - * Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) - * which can be found in the file epl-v10.html at the root of this distribution. - * By using this software in any fashion, you are agreeing to be bound by - * the terms of this license. - * You must not remove this notice, or any other, from this software. - **/ - -/** - * Author: David Miller - **/ - -using System; -using System.Collections.Generic; -using System.Reflection; -using System.Reflection.Emit; -using System.Runtime.CompilerServices; -using Microsoft.Scripting.Generation; - -namespace clojure.lang -{ - public interface IStaticConstructor - { - void CarlylesMouse(); - } -} - -namespace clojure.lang.CljCompiler.Ast -{ - // Copied and modified from NewInstanceExpr to support the defclass* special form - sealed class NewClassInstanceExpr : ObjExpr - { - #region Data - - Dictionary> _methodMap; - - #endregion - - #region C-tors - - public NewClassInstanceExpr(object tag) - : base(tag) - { - } - - #endregion - - #region Parsing - - public sealed class DefclassParser : IParser - { - public Expr Parse(ParserContext pcon, object frm) - { - // frm is: (deftype* tagname classname [fields] :implements [interfaces] :tag tagname methods*) - - ISeq rform = (ISeq)frm; - rform = RT.next(rform); - - string tagname = ((Symbol)rform.first()).ToString(); - rform = rform.next(); - Symbol classname = (Symbol)rform.first(); - rform = rform.next(); - string extends = ((Symbol)rform.first()).ToString(); - rform = rform.next(); - string assemblyname = ((Symbol)rform.first()).ToString(); - rform = rform.next(); - IPersistentVector fields = (IPersistentVector)rform.first(); - rform = rform.next(); - IPersistentMap opts = PersistentHashMap.EMPTY; - while (rform != null && rform.first() is Keyword) - { - opts = opts.assoc(rform.first(), RT.second(rform)); - rform = rform.next().next(); - } - - ObjExpr ret = - Build( - (IPersistentVector)RT.get( - opts, - Compiler.ImplementsKeyword, - PersistentVector.EMPTY), - fields, - null, - tagname, - classname, - extends, - assemblyname, - (Symbol)RT.get(opts, RT.TagKey), - rform, - frm); - - return ret; - } - } - -// -// public sealed class ReifyParser : IParser -// { -// public Expr Parse(ParserContext pcon, object frm) -// { -// // frm is: (reify this-name? [interfaces] (method-name [args] body)* ) -// ISeq form = (ISeq)frm; -// ObjMethod enclosingMethod = (ObjMethod)Compiler.MethodVar.deref(); -// string baseName = enclosingMethod != null -// ? (ObjExpr.TrimGenId(enclosingMethod.Objx.Name) + "$") -// : (Compiler.munge(Compiler.CurrentNamespace.Name.Name) + "$"); -// string simpleName = "reify__" + RT.nextID(); -// string className = baseName + simpleName; -// -// ISeq rform = RT.next(form); -// -// IPersistentVector interfaces = ((IPersistentVector)RT.first(rform)).cons(Symbol.intern("clojure.lang.IObj")); -// -// rform = RT.next(rform); -// -// ObjExpr ret = Build(interfaces, null, null, className, Symbol.intern(className), null, rform,frm); -// IObj iobj = frm as IObj; -// -// if (iobj != null && iobj.meta() != null) -// return new MetaExpr(ret, MapExpr.Parse(pcon.EvalOrExpr(),iobj.meta())); -// else -// return ret; -// } -// } - - internal static ObjExpr Build( - IPersistentVector interfaceSyms, - IPersistentVector fieldSyms, - Symbol thisSym, - string tagName, - Symbol className, - string extends, - string assemblyname, - Symbol typeTag, - ISeq methodForms, - Object frm) - { - NewClassInstanceExpr ret = new NewClassInstanceExpr(null); - ret._src = frm; - ret._name = className.ToString(); - ret._classMeta = GenInterface.ExtractAttributes(RT.meta(className)); - ret.InternalName = ret._name; // ret.Name.Replace('.', '/'); - // Java: ret.objtype = Type.getObjectType(ret.internalName); - - if (thisSym != null) - ret._thisName = thisSym.Name; - - if (fieldSyms != null) - { - IPersistentMap fmap = PersistentHashMap.EMPTY; - object[] closesvec = new object[2 * fieldSyms.count()]; - for (int i = 0; i < fieldSyms.count(); i++) - { - Symbol sym = (Symbol)fieldSyms.nth(i); - LocalBinding lb = new LocalBinding(-1, sym, null, new MethodParamExpr(Compiler.TagType(Compiler.TagOf(sym))), false, false, false); - fmap = fmap.assoc(sym, lb); - closesvec[i * 2] = lb; - closesvec[i * 2 + 1] = lb; - } - // Java TODO: inject __meta et al into closes - when? - // use array map to preserve ctor order - ret.Closes = new PersistentArrayMap(closesvec); - ret.Fields = fmap; - for (int i = fieldSyms.count() - 1; i >= 0 && (((Symbol)fieldSyms.nth(i)).Name.Equals("__meta") || ((Symbol)fieldSyms.nth(i)).Name.Equals("__extmap")); --i) - ret._altCtorDrops++; - } - - // Java TODO: set up volatiles - //ret._volatiles = PersistentHashSet.create(RT.seq(RT.get(ret._optionsMap, volatileKey))); - - IPersistentVector interfaces = PersistentVector.EMPTY; - for (ISeq s = RT.seq(interfaceSyms); s != null; s = s.next()) - { - Type t = (Type)Compiler.Resolve((Symbol)s.first()); - if (!t.IsInterface) - throw new ParseException("only interfaces are supported, had: " + t.Name); - interfaces = interfaces.cons(t); - } - // Type superClass = typeof(Object); - // here begins the jank - System.Type superClass = Type.GetType(extends + ", " + assemblyname); - - - Dictionary> overrideables; - Dictionary> explicits; - GatherMethods(superClass, RT.seq(interfaces), out overrideables, out explicits); - - ret._methodMap = overrideables; - - - GenContext context = Compiler.IsCompiling - ? Compiler.CompilerContextVar.get() as GenContext - : (ret.IsDefType - ? GenContext.CreateWithExternalAssembly("deftype" + RT.nextID().ToString(), ".dll", true) - : (Compiler.CompilerContextVar.get() as GenContext - ?? - Compiler.EvalContext)); - - GenContext genC = context.WithNewDynInitHelper(ret.InternalName + "__dynInitHelper_" + RT.nextID().ToString()); - - Symbol thisTag = Symbol.intern(null, superClass.FullName);; - //Symbol stubTag = Symbol.intern(null,stub.FullName); - //Symbol thisTag = Symbol.intern(null, tagName); - - - try - { - Var.pushThreadBindings( - RT.mapUniqueKeys( - Compiler.ConstantsVar, PersistentVector.EMPTY, - Compiler.ConstantIdsVar, new IdentityHashMap(), - Compiler.KeywordsVar, PersistentHashMap.EMPTY, - Compiler.VarsVar, PersistentHashMap.EMPTY, - Compiler.KeywordCallsitesVar, PersistentVector.EMPTY, - Compiler.ProtocolCallsitesVar, PersistentVector.EMPTY, - Compiler.VarCallsitesVar, Compiler.EmptyVarCallSites(), - Compiler.NoRecurVar, null, - Compiler.CompilerContextVar, genC - )); - - if (ret.IsDefType) - { - Var.pushThreadBindings( - RT.mapUniqueKeys( - Compiler.MethodVar, null, - Compiler.LocalEnvVar, ret.Fields, - Compiler.CompileStubSymVar, Symbol.intern(null, tagName), - Compiler.CompileStubClassVar, superClass - )); - ret._hintedFields = RT.subvec(fieldSyms, 0, fieldSyms.count() - ret._altCtorDrops); - } - // now (methodname [args] body)* - - ret.SpanMap = (IPersistentMap)Compiler.SourceSpanVar.deref(); - - IPersistentCollection methods = null; - for (ISeq s = methodForms; s != null; s = RT.next(s)) - { - NewInstanceMethod m = NewInstanceMethod.Parse(ret, (ISeq)RT.first(s), thisTag, overrideables, explicits); - methods = RT.conj(methods, m); - } - - ret._methods = methods; - ret.Keywords = (IPersistentMap)Compiler.KeywordsVar.deref(); - ret.Vars = (IPersistentMap)Compiler.VarsVar.deref(); - ret.Constants = (PersistentVector)Compiler.ConstantsVar.deref(); - ret._constantsID = RT.nextID(); - ret.KeywordCallsites = (IPersistentVector)Compiler.KeywordCallsitesVar.deref(); - ret.ProtocolCallsites = (IPersistentVector)Compiler.ProtocolCallsitesVar.deref(); - ret.VarCallsites = (IPersistentSet)Compiler.VarCallsitesVar.deref(); - } - finally - { - if (ret.IsDefType) - Var.popThreadBindings(); - Var.popThreadBindings(); - } - - // TOD: Really, the first stub here should be 'superclass' but can't handle hostexprs nested in method bodies -- reify method compilation takes place before this sucker is compiled, so can't replace the call. - // Might be able to flag stub classes and not try to convert, leading to a dynsite. - - //if (RT.CompileDLR) - ret.Compile(superClass, superClass, interfaces, false, genC); - //else - // ret.CompileNoDlr(stub, stub, interfaces, false, genC); - - Compiler.RegisterDuplicateType(ret.CompiledType); - - return ret; - } - - protected override void DefineStaticConstructor(TypeBuilder fnTB) - { - MethodBuilder mb = fnTB.DefineMethod( - "IStaticConstructor.CarlylesMouse", - MethodAttributes.ReuseSlot | MethodAttributes.Public | MethodAttributes.Virtual, - typeof(void), - Type.EmptyTypes); - fnTB.DefineMethodOverride(mb, typeof(IStaticConstructor).GetMethod("CarlylesMouse")); - fnTB.AddInterfaceImplementation(typeof(IStaticConstructor)); - CljILGen ilg = new CljILGen(mb.GetILGenerator()); - EmitRequireNamespace(ilg); - EmitStaticConstructorBody(ilg); - } - - private static Type[] SeqToTypeArray(IPersistentVector interfaces) - { - Type[] types = new Type[interfaces.count()]; - for (int i = 0; i < interfaces.count(); i++) - types[i] = (Type)interfaces.nth(i); - - return types; - } - - static string[] InterfaceNames(IPersistentVector interfaces) - { - int icnt = interfaces.count(); - string[] inames = icnt > 0 ? new string[icnt] : null; - for (int i = 0; i < icnt; i++) - inames[i] = SlashName((Type)interfaces.nth(i)); - return inames; - } - - - static string SlashName(Type t) - { - return t.FullName.Replace(',', '/'); - } - - - #endregion - - #region Method reflection - - static void GatherMethods( - Type st, - ISeq interfaces, - out Dictionary> overrides, - out Dictionary> explicits) - { - overrides = new Dictionary>(); - explicits = new Dictionary>(); - - GatherMethods(st, overrides); - for (; interfaces != null; interfaces = interfaces.next()) { - GatherMethods((Type)interfaces.first(), overrides); - GatherInterfaceExplicits((Type)interfaces.first(),explicits); - } - } - - static void GatherMethods(Type t, Dictionary> mm) - { - for (Type mt = t; mt != null; mt = mt.BaseType) - foreach (MethodInfo m in mt.GetMethods(BindingFlags.FlattenHierarchy | BindingFlags.Instance | BindingFlags.Public | BindingFlags.NonPublic)) - ConsiderMethod(m, mm); - - if (t.IsInterface) - foreach (Type it in t.GetInterfaces()) - GatherMethods(it, mm); - } - - static void ConsiderMethod(MethodInfo m, Dictionary> mm) - { - IPersistentVector mk = MSig(m); - if (!(mm.ContainsKey(mk) - || !(m.IsPublic || m.IsProtected()) - || m.IsStatic - || m.IsFinal)) - AddMethod(mm, mk, m); - } - - public static IPersistentVector MSig(MethodInfo m) - { - return RT.vector(m.Name, RT.seq(Compiler.GetTypes(m.GetParameters())), m.ReturnType); - } - - static void AddMethod(Dictionary> mm, IPersistentVector sig, MethodInfo m) - { - List value; - if (!mm.TryGetValue(sig, out value)) - { - value = new List(); - mm[sig] = value; - } - value.Add(m); - } - - private static void GatherInterfaceExplicits(Type type, Dictionary> explicits) - { - foreach (MethodInfo m in type.GetMethods(BindingFlags.FlattenHierarchy | BindingFlags.Instance | BindingFlags.Public | BindingFlags.NonPublic)) - { - List value; - IPersistentVector mk = MSig(m); - if ( ! explicits.TryGetValue(mk,out value) ) - { - value = new List(); - explicits[mk] = value; - } - if (!value.Contains(m)) - value.Add(m); - } - } - - #endregion - - #region ObjExpr methods - - protected override bool SupportsMeta - { - get { return ! IsDefType; } - } - - #endregion - - #region Code generation - - private static string ExplicitMethodName(MethodInfo mi) - { - return mi.DeclaringType.Name + "." + mi.Name; - } - - protected override void EmitStatics(TypeBuilder tb) - { - if (IsDefType) - { - // getBasis() - { - MethodBuilder mbg = tb.DefineMethod("getBasis", MethodAttributes.Public | MethodAttributes.Static, typeof(IPersistentVector), Type.EmptyTypes); - CljILGen ilg = new CljILGen(mbg.GetILGenerator()); - EmitValue(_hintedFields, ilg); - ilg.Emit(OpCodes.Ret); - } - - if (Fields.count() > _hintedFields.count()) - { - // create(IPersistentMap) - MethodBuilder mbc = tb.DefineMethod("create", MethodAttributes.Public | MethodAttributes.Static, tb, new Type[] { typeof(IPersistentMap) }); - CljILGen gen = new CljILGen(mbc.GetILGenerator()); - - LocalBuilder kwLocal = gen.DeclareLocal(typeof(Keyword)); - List locals = new List(); - for (ISeq s = RT.seq(_hintedFields); s != null; s = s.next()) - { - string bName = ((Symbol)s.first()).Name; - Type t = Compiler.TagType(Compiler.TagOf(s.first())); - - // local_kw = Keyword.intern(bname) - // local_i = arg_0.valAt(kw,null) - gen.EmitLoadArg(0); - gen.EmitString(bName); - gen.EmitCall(Compiler.Method_Keyword_intern_string); - gen.Emit(OpCodes.Dup); - gen.Emit(OpCodes.Stloc, kwLocal.LocalIndex); - gen.EmitNull(); - gen.EmitCall(Compiler.Method_IPersistentMap_valAt2); - LocalBuilder lb = gen.DeclareLocal(t); - locals.Add(lb); - if (t.IsPrimitive) - gen.EmitUnbox(t); - gen.Emit(OpCodes.Stloc, lb.LocalIndex); - - // arg_0 = arg_0.without(local_kw); - gen.EmitLoadArg(0); - gen.Emit(OpCodes.Ldloc, kwLocal.LocalIndex); - gen.EmitCall(Compiler.Method_IPersistentMap_without); - gen.EmitStoreArg(0); - } - - foreach (LocalBuilder lb in locals) - gen.Emit(OpCodes.Ldloc, lb.LocalIndex); - gen.EmitNull(); - gen.EmitLoadArg(0); - gen.EmitCall(Compiler.Method_RT_seqOrElse); - gen.EmitNew(_ctorInfo); - - gen.Emit(OpCodes.Ret); - } - } - } - - protected override ConstructorBuilder EmitConstructor(TypeBuilder fnTB, Type baseType) - { - EmitClosedOverFields(fnTB); - return base.EmitConstructor(fnTB, baseType); - } - - protected override void EmitMethods(TypeBuilder tb) - { - HashSet implemented = new HashSet(); - - for (ISeq s = RT.seq(_methods); s != null; s = s.next()) - { - NewInstanceMethod method = (NewInstanceMethod)s.first(); - method.Emit(this, tb); - implemented.UnionWith(method.MethodInfos); - } - - foreach (List ms in _methodMap.Values) - foreach (MethodInfo mi in ms) - { - if (NeedsDummy(mi, implemented)) - EmitDummyMethod(tb, mi); - } - - EmitHasArityMethod(_typeBuilder, null, false, 0); - } - - private bool NeedsDummy(MethodInfo mi, HashSet implemented) - { - return !implemented.Contains(mi) && mi.DeclaringType.IsInterface && !(!IsDefType && mi.DeclaringType == typeof(IObj) || mi.DeclaringType == typeof(IMeta)); - } - - private static void EmitDummyMethod(TypeBuilder tb, MethodInfo mi) - { - MethodBuilder mb = tb.DefineMethod(ExplicitMethodName(mi), MethodAttributes.ReuseSlot | MethodAttributes.Public | MethodAttributes.Virtual, mi.ReturnType, Compiler.GetTypes(mi.GetParameters())); - CljILGen gen = new CljILGen(mb.GetILGenerator()); - gen.EmitNew(typeof(NotImplementedException), Type.EmptyTypes); - gen.Emit(OpCodes.Throw); - tb.DefineMethodOverride(mb, mi); - } - - #endregion - } -} - - \ No newline at end of file diff --git a/Clojure/Clojure/Clojure.csproj b/Clojure/Clojure/Clojure.csproj index 0b1c157d2..33682e677 100644 --- a/Clojure/Clojure/Clojure.csproj +++ b/Clojure/Clojure/Clojure.csproj @@ -32,7 +32,7 @@ false true ..\ - true + false @@ -169,7 +169,6 @@ - From 106363df37b33cce1dd8264fb21100318be975e8 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Fri, 27 Jan 2017 20:51:26 -0500 Subject: [PATCH 68/80] Remove old method from ObjExpr --- Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs b/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs index 54d88aead..116053de9 100644 --- a/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/ObjExpr.cs @@ -423,21 +423,6 @@ protected void EmitStaticConstructorBody(CljILGen ilg) ilg.Emit(OpCodes.Ret); } - protected void EmitRequireNamespace(CljILGen ilg) - { - if(((Namespace)RT.CurrentNSVar.deref()).Name.ToString() != "clojure.core") - { - EmitValue(RT.RequireVar, ilg); - ilg.Emit(OpCodes.Call, Compiler.Method_Var_getRawRoot); - ilg.Emit(OpCodes.Castclass, typeof(IFn)); - ilg.EmitNull(); - ilg.EmitString(((Namespace)RT.CurrentNSVar.deref()).Name.Name); - ilg.EmitCall(Compiler.Method_Symbol_intern2); - ilg.Emit(OpCodes.Callvirt, Compiler.Methods_IFn_invoke[1]); - ilg.Emit(OpCodes.Pop); - } - } - private void EmitLoadNsInitForDeftype(CljILGen ilg) { string nsname = ((Symbol)RT.second(Src)).Namespace; From 6c818bf08df2650c42d423353bcb57bcd5014205 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Fri, 27 Jan 2017 20:53:14 -0500 Subject: [PATCH 69/80] Remove unused properties from Expr --- Clojure/Clojure/CljCompiler/Ast/Expr.cs | 1 - 1 file changed, 1 deletion(-) diff --git a/Clojure/Clojure/CljCompiler/Ast/Expr.cs b/Clojure/Clojure/CljCompiler/Ast/Expr.cs index 97a765777..b7fa1a265 100644 --- a/Clojure/Clojure/CljCompiler/Ast/Expr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/Expr.cs @@ -24,7 +24,6 @@ public interface Expr object Eval(); void Emit(RHC rhc, ObjExpr objx, CljILGen ilg); - ParserContext ParsedContext { get; set; } bool HasNormalExit(); } From ff5e7ac457f303f0cffb637b325f1665550814ff Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Fri, 27 Jan 2017 20:55:48 -0500 Subject: [PATCH 70/80] Add *debug* back --- Clojure/Clojure/CljCompiler/Compiler.cs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index 861e49a12..a92c7f8c2 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -129,6 +129,9 @@ internal static Type FindDuplicateType(string typename) #region Vars //boolean + internal static readonly Var DebugVar = Var.intern(Namespace.findOrCreate(Symbol.intern("clojure.core")), + Symbol.intern("*debug*"), false).setDynamic(); + internal static readonly Var CompileFilesVar = Var.intern(Namespace.findOrCreate(Symbol.intern("clojure.core")), Symbol.intern("*compile-files*"), false).setDynamic(); @@ -1703,7 +1706,8 @@ internal static bool TryLoadInitType(string relativePath) [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "load")] public static object loadFile(string fileName) - { FileInfo finfo = new FileInfo(fileName); + { + FileInfo finfo = new FileInfo(fileName); if (!finfo.Exists) throw new FileNotFoundException("Cannot find file to load", fileName); From 2f41c80214b4a564cab899c7a16a01273e35c4c1 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Fri, 27 Jan 2017 23:08:32 -0500 Subject: [PATCH 71/80] Support direct-linking compiler option on *nix --- Clojure/Clojure.Compile/Clojure.Compile.csproj | 18 ++++++++++-------- Clojure/Clojure/CljCompiler/Compiler.cs | 15 +++++++++++---- 2 files changed, 21 insertions(+), 12 deletions(-) diff --git a/Clojure/Clojure.Compile/Clojure.Compile.csproj b/Clojure/Clojure.Compile/Clojure.Compile.csproj index eda0a5226..c0caf7d43 100644 --- a/Clojure/Clojure.Compile/Clojure.Compile.csproj +++ b/Clojure/Clojure.Compile/Clojure.Compile.csproj @@ -125,19 +125,21 @@ - mono "$(TargetPath)" clojure.core clojure.core.protocols clojure.core.reducers clojure.main clojure.set clojure.zip clojure.walk clojure.stacktrace clojure.template clojure.test clojure.test.tap clojure.test.junit clojure.pprint clojure.clr.io clojure.repl clojure.clr.shell clojure.string clojure.data clojure.reflect clojure.edn "$(TargetPath)" clojure.core clojure.core.protocols clojure.core.reducers clojure.main clojure.set clojure.zip clojure.walk clojure.stacktrace clojure.template clojure.test clojure.test.tap clojure.test.junit clojure.pprint clojure.clr.io clojure.repl clojure.clr.shell clojure.string clojure.data clojure.reflect clojure.edn - set clojure.compiler.direct-linking=$(DirectLinking) -$(TargetPath) clojure.core clojure.core.protocols clojure.core.server clojure.core.reducers clojure.main clojure.set clojure.zip clojure.walk clojure.stacktrace clojure.template clojure.test clojure.test.tap clojure.test.junit clojure.pprint clojure.clr.io clojure.repl clojure.clr.shell clojure.string clojure.data clojure.reflect clojure.edn + CLOJURE_COMPILER_DIRECT_LINKING=$(DirectLinking) +$(TargetPath) clojure.core clojure.core.protocols clojure.core.server clojure.core.reducers clojure.main clojure.set clojure.zip clojure.walk clojure.stacktrace clojure.template clojure.test clojure.test.tap clojure.test.junit clojure.pprint clojure.clr.io clojure.repl clojure.clr.shell clojure.string clojure.data clojure.reflect clojure.edn + set clojure.compiler.direct-linking=$(DirectLinking) +$(TargetPath) clojure.core clojure.core.protocols clojure.core.server clojure.core.reducers clojure.main clojure.set clojure.zip clojure.walk clojure.stacktrace clojure.template clojure.test clojure.test.tap clojure.test.junit clojure.pprint clojure.clr.io clojure.repl clojure.clr.shell clojure.string clojure.data clojure.reflect clojure.edn \ No newline at end of file diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index a92c7f8c2..50afcb24e 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -215,21 +215,28 @@ static void InitializeCompilerOptions() { Object compilerOptions = null; + string nixPrefix = "CLOJURE_COMPILER_"; + string winPrefix = "clojure.compiler."; + IDictionary envVars = Environment.GetEnvironmentVariables(); foreach (DictionaryEntry de in envVars) { string name = (string)de.Key; string v = (string)de.Value; - if (name.StartsWith("CLOJURE_COMPILER_")) + if (name.StartsWith(nixPrefix)) { + // compiler options on *nix need to be of the form + // CLOJURE_COMPILER_DIRECT_LINKING because most shells do not + // support hyphens in variable names + string optionName = name.Substring(1 + nixPrefix.Length).Replace("_", "-").ToLower(); compilerOptions = RT.assoc(compilerOptions, - RT.keyword(null, name.Substring(1 + name.LastIndexOf("_"))), + RT.keyword(null, optionName), RT.readString(v)); } - if ( name.StartsWith("clojure.compiler.")) + if ( name.StartsWith(winPrefix)) { compilerOptions = RT.assoc(compilerOptions, - RT.keyword(null, name.Substring(1 + name.LastIndexOf("."))), + RT.keyword(null, name.Substring(1 + winPrefix.Length)), RT.readString(v)); } From 733a483deaca986cb46f80026d18d691482893b8 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Fri, 27 Jan 2017 23:20:52 -0500 Subject: [PATCH 72/80] Read RestorePackages variable from env --- Clojure/Clojure.Tests/Clojure.Tests.csproj | 2 +- Clojure/Clojure/Clojure.csproj | 2 +- Clojure/Csharp.Tests/Csharp.Tests.csproj | 14 +++++++------- Clojure/DlrConsole/DlrConsole.csproj | 14 +++++++------- Clojure/build.proj | 2 +- 5 files changed, 17 insertions(+), 17 deletions(-) diff --git a/Clojure/Clojure.Tests/Clojure.Tests.csproj b/Clojure/Clojure.Tests/Clojure.Tests.csproj index 8b0e05b7e..6fe4a5217 100644 --- a/Clojure/Clojure.Tests/Clojure.Tests.csproj +++ b/Clojure/Clojure.Tests/Clojure.Tests.csproj @@ -31,7 +31,7 @@ false true ..\ - true + true true diff --git a/Clojure/Clojure/Clojure.csproj b/Clojure/Clojure/Clojure.csproj index 33682e677..97c20fdd7 100644 --- a/Clojure/Clojure/Clojure.csproj +++ b/Clojure/Clojure/Clojure.csproj @@ -32,7 +32,7 @@ false true ..\ - false + true diff --git a/Clojure/Csharp.Tests/Csharp.Tests.csproj b/Clojure/Csharp.Tests/Csharp.Tests.csproj index 197fb5592..67c799d24 100644 --- a/Clojure/Csharp.Tests/Csharp.Tests.csproj +++ b/Clojure/Csharp.Tests/Csharp.Tests.csproj @@ -12,7 +12,7 @@ Csharp.Tests 512 ..\ - true + true true @@ -153,11 +153,11 @@ - \ No newline at end of file diff --git a/Clojure/DlrConsole/DlrConsole.csproj b/Clojure/DlrConsole/DlrConsole.csproj index fb1610b54..fb6173656 100644 --- a/Clojure/DlrConsole/DlrConsole.csproj +++ b/Clojure/DlrConsole/DlrConsole.csproj @@ -15,7 +15,7 @@ 512 ..\ - true + true true @@ -98,11 +98,11 @@ - \ No newline at end of file diff --git a/Clojure/build.proj b/Clojure/build.proj index 29cef78b6..b5fbcc328 100644 --- a/Clojure/build.proj +++ b/Clojure/build.proj @@ -36,7 +36,7 @@ + Properties="RestorePackages=$(RestorePackages);Runtime=$(Runtime);PlatformSym=$(PlatformSym);DirectLinking=$(DirectLinking)"/> From 9f4d8d2291acd31465762f03d031400cdef72a13 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sat, 28 Jan 2017 00:04:52 -0500 Subject: [PATCH 73/80] Work around mono type lookup bug --- Clojure/Clojure/CljCompiler/Compiler.cs | 18 +++--------------- 1 file changed, 3 insertions(+), 15 deletions(-) diff --git a/Clojure/Clojure/CljCompiler/Compiler.cs b/Clojure/Clojure/CljCompiler/Compiler.cs index 50afcb24e..83073f0fc 100644 --- a/Clojure/Clojure/CljCompiler/Compiler.cs +++ b/Clojure/Clojure/CljCompiler/Compiler.cs @@ -1432,7 +1432,8 @@ public static string IsCompilingSuffix() internal static string InitClassName(string sourcePath) { - return "__Init__$" + sourcePath.Replace(".", "/"); + // munge slashes to $ to avoid mono lookup bug -nasser + return "__Init__$" + sourcePath.Replace(".", "/").Replace("/", "$"); } public static void PushNS() @@ -1645,20 +1646,7 @@ internal static void LoadAssembly(byte[] assyData, string relativePath) private static Type GetTypeFromAssy(Assembly assy, string typeName) { - if (RT.IsRunningOnMono) - { - // I have no idea why Mono can't find our initializer types using Assembly.GetType(string). - // This is roll-your-own. - Type[] types = assy.GetExportedTypes(); - foreach (Type t in types) - { - if (t.Name.Equals(typeName)) - return t; - } - return null; - } - else - return assy.GetType(typeName); + return assy.GetType(typeName); } [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Design", "CA1031:DoNotCatchGeneralExceptionTypes")] From cc87e9c758a1a078a316277c2c4dd9ab945cae33 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sat, 28 Jan 2017 00:05:50 -0500 Subject: [PATCH 74/80] Update build script to disable package restore --- unity-build.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unity-build.sh b/unity-build.sh index bccd690bf..fce3fbb99 100755 --- a/unity-build.sh +++ b/unity-build.sh @@ -1,2 +1,2 @@ rm -fr dist bin -EnableNuGetPackageRestore=true xbuild Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Debug 3.5" /p:Platform="Any CPU" +RestorePackages=false xbuild Clojure/build.proj /target:"Dist" /p:Runtime="Mono" /p:Configuration="Debug 3.5" /p:Platform="Any CPU" From 3f13d1910aed1d148c2e03ff50cd8ded5b516236 Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sat, 28 Jan 2017 01:49:35 -0500 Subject: [PATCH 75/80] Backport clojure.spec --- Clojure/Clojure.Source/Clojure.Source.csproj | 11 + Clojure/Clojure.Source/clojure/core.clj | 1064 ++++++----- Clojure/Clojure.Source/clojure/spec.clj | 1726 ++++++++++++++++++ Clojure/Clojure.Source/clojure/spec/gen.clj | 224 +++ Clojure/Clojure.Source/clojure/spec/test.clj | 504 +++++ 5 files changed, 3063 insertions(+), 466 deletions(-) create mode 100644 Clojure/Clojure.Source/clojure/spec.clj create mode 100644 Clojure/Clojure.Source/clojure/spec/gen.clj create mode 100644 Clojure/Clojure.Source/clojure/spec/test.clj diff --git a/Clojure/Clojure.Source/Clojure.Source.csproj b/Clojure/Clojure.Source/Clojure.Source.csproj index 5ca5be1eb..980cd1963 100644 --- a/Clojure/Clojure.Source/Clojure.Source.csproj +++ b/Clojure/Clojure.Source/Clojure.Source.csproj @@ -263,6 +263,17 @@ PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + - mono "$(TargetPath)" clojure.core clojure.core.protocols clojure.core.reducers clojure.main clojure.set clojure.zip clojure.walk clojure.stacktrace clojure.template clojure.test clojure.test.tap clojure.test.junit clojure.pprint clojure.clr.io clojure.repl clojure.clr.shell clojure.string clojure.data clojure.reflect clojure.edn - "$(TargetPath)" clojure.core clojure.core.protocols clojure.core.reducers clojure.main clojure.set clojure.zip clojure.walk clojure.stacktrace clojure.template clojure.test clojure.test.tap clojure.test.junit clojure.pprint clojure.clr.io clojure.repl clojure.clr.shell clojure.string clojure.data clojure.reflect clojure.edn + mono "$(TargetPath)" clojure.core clojure.core.protocols clojure.core.server clojure.core.reducers clojure.main clojure.set clojure.zip clojure.walk clojure.stacktrace clojure.template clojure.test clojure.test.tap clojure.test.junit clojure.pprint clojure.clr.io clojure.repl clojure.clr.shell clojure.string clojure.data clojure.reflect clojure.edn + "$(TargetPath)" clojure.core clojure.core.protocols clojure.core.server clojure.core.reducers clojure.main clojure.set clojure.zip clojure.walk clojure.stacktrace clojure.template clojure.test clojure.test.tap clojure.test.junit clojure.pprint clojure.clr.io clojure.repl clojure.clr.shell clojure.string clojure.data clojure.reflect clojure.edn CLOJURE_COMPILER_DIRECT_LINKING=$(DirectLinking) From 50c7a11a010b8de0e69d16c685804d67e37b563b Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sat, 11 Mar 2017 08:26:33 -0500 Subject: [PATCH 78/80] Remove load time print outs --- Clojure/Clojure/Lib/RT.cs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Clojure/Clojure/Lib/RT.cs b/Clojure/Clojure/Lib/RT.cs index a007163fe..37fa99571 100644 --- a/Clojure/Clojure/Lib/RT.cs +++ b/Clojure/Clojure/Lib/RT.cs @@ -603,11 +603,11 @@ static RT() static void DoInit() { - Stopwatch sw = new Stopwatch(); - sw.Start(); + // Stopwatch sw = new Stopwatch(); + // sw.Start(); load("clojure/core"); - sw.Stop(); - Console.WriteLine("Initial clojure/core load: {0} milliseconds.", sw.ElapsedMilliseconds); + // sw.Stop(); + // Console.WriteLine("Initial clojure/core load: {0} milliseconds.", sw.ElapsedMilliseconds); PostBootstrapInit(); } From 11c33f55a6005c194a261700a7cc378ff89f3b9e Mon Sep 17 00:00:00 2001 From: Ramsey Nasser Date: Sat, 11 Mar 2017 08:31:56 -0500 Subject: [PATCH 79/80] Remove slow path from clojure.lang.RT/classForName Lookups for unqualified, unimported types will throw an exception (as they should). This patch removes lookup logic that was in place due to a mono bug where types with slashes in their names could not be found. The compiler no longer emits such types, so the slow path is no longer needed. --- Clojure/Clojure/Lib/RT.cs | 47 --------------------------------------- 1 file changed, 47 deletions(-) diff --git a/Clojure/Clojure/Lib/RT.cs b/Clojure/Clojure/Lib/RT.cs index 37fa99571..7ccffa361 100644 --- a/Clojure/Clojure/Lib/RT.cs +++ b/Clojure/Clojure/Lib/RT.cs @@ -2925,53 +2925,6 @@ public static Type classForName(string p) return t1; } - // slow path, will succeed for display names (returned by Type.Name) - // e.g. "Transform" - foreach (Assembly assy1 in assys) - { - Type t1 = assy1.GetType(p, false); - - if (IsRunningOnMono) - { - // I do not know why Assembly.GetType fails to find types in our assemblies in Mono - if (t1 == null) - { -#if CLR2 - if (!(assy1 is AssemblyBuilder)) -#else - if (!assy1.IsDynamic) -#endif - { - try - { - - foreach (Type tt in assy1.GetTypes()) - { - if (tt.Name.Equals(p)) - { - t1 = tt; - break; - } - } - } - catch (System.Reflection.ReflectionTypeLoadException) - { - } - } - } - } - - if (t1 != null && !candidateTypes.Contains(t1)) - candidateTypes.Add(t1); - } - - if (candidateTypes.Count == 0) - t = null; - else if (candidateTypes.Count == 1) - t = candidateTypes[0]; - else // multiple, ambiguous - t = null; - if (t == null && p.IndexOfAny(_triggerTypeChars) != -1) t = ClrTypeSpec.GetTypeFromName(p); From a6f8e1f4f7e3b49e96edfa916ba3d55ec3281cb7 Mon Sep 17 00:00:00 2001 From: Oscar Morante Date: Sat, 18 Mar 2017 11:40:34 +0200 Subject: [PATCH 80/80] add some logs to help debug Arcadia start up time --- Clojure/Clojure/Lib/RT.cs | 35 ++++++++++++++++++++++++++++++++--- 1 file changed, 32 insertions(+), 3 deletions(-) diff --git a/Clojure/Clojure/Lib/RT.cs b/Clojure/Clojure/Lib/RT.cs index 7ccffa361..8fc2eef67 100644 --- a/Clojure/Clojure/Lib/RT.cs +++ b/Clojure/Clojure/Lib/RT.cs @@ -3354,9 +3354,15 @@ public static void load(String relativePath) load(relativePath, true); } + private static int loadNesting = -1; + [System.Diagnostics.CodeAnalysis.SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly")] public static void load(String relativePath, Boolean failIfNotFound) { + ++loadNesting; + Console.WriteLine(string.Concat(Enumerable.Repeat(" ", loadNesting).ToArray()) + "--> RT.load({0})", relativePath); + Stopwatch sw = new Stopwatch(); + sw.Start(); string cljname = relativePath + ".clj"; string assemblyname = relativePath.Replace('/', '.') + ".clj.dll"; @@ -3390,19 +3396,30 @@ public static void load(String relativePath, Boolean failIfNotFound) finally { Var.popThreadBindings(); + sw.Stop(); + Console.WriteLine(string.Concat(Enumerable.Repeat(" ", loadNesting).ToArray()) + "<-- RT.load({0}) LoadAssembly - {1} milliseconds.", relativePath, sw.ElapsedMilliseconds); + --loadNesting; } } if (cljInfo != null) { - if (booleanCast(Compiler.CompileFilesVar.deref())) + if (booleanCast(Compiler.CompileFilesVar.deref())) { Compile(cljInfo, cljname); - else + sw.Stop(); + Console.WriteLine(string.Concat(Enumerable.Repeat(" ", loadNesting).ToArray()) + "<-- RT.load({0} Compile - {1} milliseconds.", relativePath, sw.ElapsedMilliseconds); + } else { LoadScript(cljInfo, cljname); + sw.Stop(); + Console.WriteLine(string.Concat(Enumerable.Repeat(" ", loadNesting).ToArray()) + "<-- RT.load({0} LoadScript - {1} milliseconds.", relativePath, sw.ElapsedMilliseconds); + } + --loadNesting; return; } } + var swit = new Stopwatch(); + swit.Start(); try { Var.pushThreadBindings(RT.map(CurrentNSVar, CurrentNSVar.deref(), @@ -3414,17 +3431,29 @@ public static void load(String relativePath, Boolean failIfNotFound) finally { Var.popThreadBindings(); + swit.Stop(); + Console.WriteLine(string.Concat(Enumerable.Repeat(" ", loadNesting).ToArray()) + " RT.load({0} TryLoadInitType - {1} milliseconds.", relativePath, swit.ElapsedMilliseconds); } + var swer = new Stopwatch(); + swer.Start(); bool loaded = TryLoadFromEmbeddedResource(relativePath, assemblyname); + Console.WriteLine(string.Concat(Enumerable.Repeat(" ", loadNesting).ToArray()) + " RT.load({0} TryLoadFromEmbeddedResource - {1} milliseconds.", relativePath, swer.ElapsedMilliseconds); - if (!loaded && failIfNotFound) + if (!loaded && failIfNotFound) { + --loadNesting; + sw.Stop(); + Console.WriteLine(string.Concat(Enumerable.Repeat(" ", loadNesting).ToArray()) + "<-- RT.load({0} ERROR - {1} milliseconds.", relativePath, sw.ElapsedMilliseconds); throw new FileNotFoundException(String.Format("Could not locate {0} or {1} on load path.{2}", assemblyname, cljname, relativePath.Contains("_") ? " Please check that namespaces with dashes use underscores in the Clojure file name." : "")); + } + sw.Stop(); + Console.WriteLine(string.Concat(Enumerable.Repeat(" ", loadNesting).ToArray()) + "<-- RT.load({0} - {1} milliseconds.", relativePath, sw.ElapsedMilliseconds); + --loadNesting; } private static bool TryLoadFromEmbeddedResource(string relativePath, string assemblyname)