diff --git a/.gitignore b/.gitignore index 4da745791..609f04b03 100644 --- a/.gitignore +++ b/.gitignore @@ -1,368 +1,368 @@ - -## Ignore Visual Studio temporary files, build results, and -## files generated by popular Visual Studio add-ons. -## -## Get latest from https://github.com/github/gitignore/blob/master/VisualStudio.gitignore - -# User-specific files -*.rsuser -*.suo -*.user -*.userosscache -*.sln.docstates - -# User-specific files (MonoDevelop/Xamarin Studio) -*.userprefs - -# Mono auto generated files -mono_crash.* - -# Build results -[Dd]ebug/ -[Dd]ebugPublic/ -[Rr]elease/ -[Rr]eleases/ -x64/ -x86/ -[Aa][Rr][Mm]/ -[Aa][Rr][Mm]64/ -bld/ -[Bb]in/ -[Oo]bj/ -[Ll]og/ - -# Visual Studio 2015/2017 cache/options directory -.vs/ -# Uncomment if you have tasks that create the project's static files in wwwroot -#wwwroot/ - -# Visual Studio 2017 auto generated files -Generated\ Files/ - -# MSTest test Results -[Tt]est[Rr]esult*/ -[Bb]uild[Ll]og.* - -# NUNIT -*.VisualState.xml -TestResult.xml - -# Build Results of an ATL Project -[Dd]ebugPS/ -[Rr]eleasePS/ -dlldata.c - -# Benchmark Results -BenchmarkDotNet.Artifacts/ - -# .NET Core -project.lock.json -project.fragment.lock.json -artifacts/ - -# StyleCop -StyleCopReport.xml - -# Files built by Visual Studio -*_i.c -*_p.c -*_h.h -*.ilk -*.meta -*.obj -*.iobj -*.pch -*.pdb -*.ipdb -*.pgc -*.pgd -*.rsp -*.sbr -*.tlb -*.tli -*.tlh -*.tmp -*.tmp_proj -*_wpftmp.csproj -*.log -*.vspscc -*.vssscc -.builds -*.pidb -*.svclog -*.scc - -# Chutzpah Test files -_Chutzpah* - -# Visual C++ cache files -ipch/ -*.aps -*.ncb -*.opendb -*.opensdf -*.sdf -*.cachefile -*.VC.db -*.VC.VC.opendb - -# Visual Studio profiler -*.psess -*.vsp -*.vspx -*.sap - -# Visual Studio Trace Files -*.e2e - -# TFS 2012 Local Workspace -$tf/ - -# Guidance Automation Toolkit -*.gpState - -# ReSharper is a .NET coding add-in -_ReSharper*/ -*.[Rr]e[Ss]harper -*.DotSettings.user - -# JustCode is a .NET coding add-in -.JustCode - -# TeamCity is a build add-in -_TeamCity* - -# DotCover is a Code Coverage Tool -*.dotCover - -# AxoCover is a Code Coverage Tool -.axoCover/* -!.axoCover/settings.json - -# Visual Studio code coverage results -*.coverage -*.coveragexml - -# NCrunch -_NCrunch_* -.*crunch*.local.xml -nCrunchTemp_* - -# MightyMoose -*.mm.* -AutoTest.Net/ - -# Web workbench (sass) -.sass-cache/ - -# Installshield output folder -[Ee]xpress/ - -# DocProject is a documentation generator add-in -DocProject/buildhelp/ -DocProject/Help/*.HxT -DocProject/Help/*.HxC -DocProject/Help/*.hhc -DocProject/Help/*.hhk -DocProject/Help/*.hhp -DocProject/Help/Html2 -DocProject/Help/html - -# Click-Once directory -publish/ - -# Publish Web Output -*.[Pp]ublish.xml -*.azurePubxml -# Note: Comment the next line if you want to checkin your web deploy settings, -# but database connection strings (with potential passwords) will be unencrypted -*.pubxml -*.publishproj - -# Microsoft Azure Web App publish settings. Comment the next line if you want to -# checkin your Azure Web App publish settings, but sensitive information contained -# in these scripts will be unencrypted -PublishScripts/ - -# NuGet Packages -*.nupkg -# NuGet Symbol Packages -*.snupkg -# The packages folder can be ignored because of Package Restore -**/[Pp]ackages/* -# except build/, which is used as an MSBuild target. -!**/[Pp]ackages/build/ -# Uncomment if necessary however generally it will be regenerated when needed -#!**/[Pp]ackages/repositories.config -# NuGet v3's project.json files produces more ignorable files -*.nuget.props -*.nuget.targets - -# Microsoft Azure Build Output -csx/ -*.build.csdef - -# Microsoft Azure Emulator -ecf/ -rcf/ - -# Windows Store app package directories and files -AppPackages/ -BundleArtifacts/ -Package.StoreAssociation.xml -_pkginfo.txt -*.appx -*.appxbundle -*.appxupload - -# Visual Studio cache files -# files ending in .cache can be ignored -*.[Cc]ache -# but keep track of directories ending in .cache -!?*.[Cc]ache/ - -# Others -ClientBin/ -~$* -*~ -*.dbmdl -*.dbproj.schemaview -*.jfm -*.pfx -*.publishsettings -orleans.codegen.cs - -# Including strong name files can present a security risk -# (https://github.com/github/gitignore/pull/2483#issue-259490424) -#*.snk - -# Since there are multiple workflows, uncomment next line to ignore bower_components -# (https://github.com/github/gitignore/pull/1529#issuecomment-104372622) -#bower_components/ - -# RIA/Silverlight projects -Generated_Code/ - -# Backup & report files from converting an old project file -# to a newer Visual Studio version. Backup files are not needed, -# because we have git ;-) -_UpgradeReport_Files/ -Backup*/ -UpgradeLog*.XML -UpgradeLog*.htm -ServiceFabricBackup/ -*.rptproj.bak - -# SQL Server files -*.mdf -*.ldf -*.ndf - -# Business Intelligence projects -*.rdl.data -*.bim.layout -*.bim_*.settings -*.rptproj.rsuser -*- [Bb]ackup.rdl -*- [Bb]ackup ([0-9]).rdl -*- [Bb]ackup ([0-9][0-9]).rdl - -# Microsoft Fakes -FakesAssemblies/ - -# GhostDoc plugin setting file -*.GhostDoc.xml - -# Node.js Tools for Visual Studio -.ntvs_analysis.dat -node_modules/ - -# Visual Studio 6 build log -*.plg - -# Visual Studio 6 workspace options file -*.opt - -# Visual Studio 6 auto-generated workspace file (contains which files were open etc.) -*.vbw - -# Visual Studio LightSwitch build output -**/*.HTMLClient/GeneratedArtifacts -**/*.DesktopClient/GeneratedArtifacts -**/*.DesktopClient/ModelManifest.xml -**/*.Server/GeneratedArtifacts -**/*.Server/ModelManifest.xml -_Pvt_Extensions - -# Paket dependency manager -.paket/paket.exe -paket-files/ - -# FAKE - F# Make -.fake/ - -# CodeRush personal settings -.cr/personal - -# Python Tools for Visual Studio (PTVS) -__pycache__/ -*.pyc - -# Cake - Uncomment if you are using it -# tools/** -# !tools/packages.config - -# Tabs Studio -*.tss - -# Telerik's JustMock configuration file -*.jmconfig - -# BizTalk build output -*.btp.cs -*.btm.cs -*.odx.cs -*.xsd.cs - -# OpenCover UI analysis results -OpenCover/ - -# Azure Stream Analytics local run output -ASALocalRun/ - -# MSBuild Binary and Structured Log -*.binlog - -# NVidia Nsight GPU debugger configuration file -*.nvuser - -# MFractors (Xamarin productivity tool) working folder -.mfractor/ - -# Local History for Visual Studio -.localhistory/ - -# BeatPulse healthcheck temp database -healthchecksdb - -# Backup folder for Package Reference Convert tool in Visual Studio 2017 -MigrationBackup/ - -###### -# -# Some of my own stuff -# -###### - -####lib/ - -# Emacs artifacts -*~ -# Java artifacts -*.class -**/pub/ - -# testing directories -testing/ - -Stage/ + +## Ignore Visual Studio temporary files, build results, and +## files generated by popular Visual Studio add-ons. +## +## Get latest from https://github.com/github/gitignore/blob/master/VisualStudio.gitignore + +# User-specific files +*.rsuser +*.suo +*.user +*.userosscache +*.sln.docstates + +# User-specific files (MonoDevelop/Xamarin Studio) +*.userprefs + +# Mono auto generated files +mono_crash.* + +# Build results +[Dd]ebug/ +[Dd]ebugPublic/ +[Rr]elease/ +[Rr]eleases/ +x64/ +x86/ +[Aa][Rr][Mm]/ +[Aa][Rr][Mm]64/ +bld/ +[Bb]in/ +[Oo]bj/ +[Ll]og/ + +# Visual Studio 2015/2017 cache/options directory +.vs/ +# Uncomment if you have tasks that create the project's static files in wwwroot +#wwwroot/ + +# Visual Studio 2017 auto generated files +Generated\ Files/ + +# MSTest test Results +[Tt]est[Rr]esult*/ +[Bb]uild[Ll]og.* + +# NUNIT +*.VisualState.xml +TestResult.xml + +# Build Results of an ATL Project +[Dd]ebugPS/ +[Rr]eleasePS/ +dlldata.c + +# Benchmark Results +BenchmarkDotNet.Artifacts/ + +# .NET Core +project.lock.json +project.fragment.lock.json +artifacts/ + +# StyleCop +StyleCopReport.xml + +# Files built by Visual Studio +*_i.c +*_p.c +*_h.h +*.ilk +*.meta +*.obj +*.iobj +*.pch +*.pdb +*.ipdb +*.pgc +*.pgd +*.rsp +*.sbr +*.tlb +*.tli +*.tlh +*.tmp +*.tmp_proj +*_wpftmp.csproj +*.log +*.vspscc +*.vssscc +.builds +*.pidb +*.svclog +*.scc + +# Chutzpah Test files +_Chutzpah* + +# Visual C++ cache files +ipch/ +*.aps +*.ncb +*.opendb +*.opensdf +*.sdf +*.cachefile +*.VC.db +*.VC.VC.opendb + +# Visual Studio profiler +*.psess +*.vsp +*.vspx +*.sap + +# Visual Studio Trace Files +*.e2e + +# TFS 2012 Local Workspace +$tf/ + +# Guidance Automation Toolkit +*.gpState + +# ReSharper is a .NET coding add-in +_ReSharper*/ +*.[Rr]e[Ss]harper +*.DotSettings.user + +# JustCode is a .NET coding add-in +.JustCode + +# TeamCity is a build add-in +_TeamCity* + +# DotCover is a Code Coverage Tool +*.dotCover + +# AxoCover is a Code Coverage Tool +.axoCover/* +!.axoCover/settings.json + +# Visual Studio code coverage results +*.coverage +*.coveragexml + +# NCrunch +_NCrunch_* +.*crunch*.local.xml +nCrunchTemp_* + +# MightyMoose +*.mm.* +AutoTest.Net/ + +# Web workbench (sass) +.sass-cache/ + +# Installshield output folder +[Ee]xpress/ + +# DocProject is a documentation generator add-in +DocProject/buildhelp/ +DocProject/Help/*.HxT +DocProject/Help/*.HxC +DocProject/Help/*.hhc +DocProject/Help/*.hhk +DocProject/Help/*.hhp +DocProject/Help/Html2 +DocProject/Help/html + +# Click-Once directory +publish/ + +# Publish Web Output +*.[Pp]ublish.xml +*.azurePubxml +# Note: Comment the next line if you want to checkin your web deploy settings, +# but database connection strings (with potential passwords) will be unencrypted +*.pubxml +*.publishproj + +# Microsoft Azure Web App publish settings. Comment the next line if you want to +# checkin your Azure Web App publish settings, but sensitive information contained +# in these scripts will be unencrypted +PublishScripts/ + +# NuGet Packages +*.nupkg +# NuGet Symbol Packages +*.snupkg +# The packages folder can be ignored because of Package Restore +**/[Pp]ackages/* +# except build/, which is used as an MSBuild target. +!**/[Pp]ackages/build/ +# Uncomment if necessary however generally it will be regenerated when needed +#!**/[Pp]ackages/repositories.config +# NuGet v3's project.json files produces more ignorable files +*.nuget.props +*.nuget.targets + +# Microsoft Azure Build Output +csx/ +*.build.csdef + +# Microsoft Azure Emulator +ecf/ +rcf/ + +# Windows Store app package directories and files +AppPackages/ +BundleArtifacts/ +Package.StoreAssociation.xml +_pkginfo.txt +*.appx +*.appxbundle +*.appxupload + +# Visual Studio cache files +# files ending in .cache can be ignored +*.[Cc]ache +# but keep track of directories ending in .cache +!?*.[Cc]ache/ + +# Others +ClientBin/ +~$* +*~ +*.dbmdl +*.dbproj.schemaview +*.jfm +*.pfx +*.publishsettings +orleans.codegen.cs + +# Including strong name files can present a security risk +# (https://github.com/github/gitignore/pull/2483#issue-259490424) +#*.snk + +# Since there are multiple workflows, uncomment next line to ignore bower_components +# (https://github.com/github/gitignore/pull/1529#issuecomment-104372622) +#bower_components/ + +# RIA/Silverlight projects +Generated_Code/ + +# Backup & report files from converting an old project file +# to a newer Visual Studio version. Backup files are not needed, +# because we have git ;-) +_UpgradeReport_Files/ +Backup*/ +UpgradeLog*.XML +UpgradeLog*.htm +ServiceFabricBackup/ +*.rptproj.bak + +# SQL Server files +*.mdf +*.ldf +*.ndf + +# Business Intelligence projects +*.rdl.data +*.bim.layout +*.bim_*.settings +*.rptproj.rsuser +*- [Bb]ackup.rdl +*- [Bb]ackup ([0-9]).rdl +*- [Bb]ackup ([0-9][0-9]).rdl + +# Microsoft Fakes +FakesAssemblies/ + +# GhostDoc plugin setting file +*.GhostDoc.xml + +# Node.js Tools for Visual Studio +.ntvs_analysis.dat +node_modules/ + +# Visual Studio 6 build log +*.plg + +# Visual Studio 6 workspace options file +*.opt + +# Visual Studio 6 auto-generated workspace file (contains which files were open etc.) +*.vbw + +# Visual Studio LightSwitch build output +**/*.HTMLClient/GeneratedArtifacts +**/*.DesktopClient/GeneratedArtifacts +**/*.DesktopClient/ModelManifest.xml +**/*.Server/GeneratedArtifacts +**/*.Server/ModelManifest.xml +_Pvt_Extensions + +# Paket dependency manager +.paket/paket.exe +paket-files/ + +# FAKE - F# Make +.fake/ + +# CodeRush personal settings +.cr/personal + +# Python Tools for Visual Studio (PTVS) +__pycache__/ +*.pyc + +# Cake - Uncomment if you are using it +# tools/** +# !tools/packages.config + +# Tabs Studio +*.tss + +# Telerik's JustMock configuration file +*.jmconfig + +# BizTalk build output +*.btp.cs +*.btm.cs +*.odx.cs +*.xsd.cs + +# OpenCover UI analysis results +OpenCover/ + +# Azure Stream Analytics local run output +ASALocalRun/ + +# MSBuild Binary and Structured Log +*.binlog + +# NVidia Nsight GPU debugger configuration file +*.nvuser + +# MFractors (Xamarin productivity tool) working folder +.mfractor/ + +# Local History for Visual Studio +.localhistory/ + +# BeatPulse healthcheck temp database +healthchecksdb + +# Backup folder for Package Reference Convert tool in Visual Studio 2017 +MigrationBackup/ + +###### +# +# Some of my own stuff +# +###### + +####lib/ + +# Emacs artifacts +*~ +# Java artifacts +*.class +**/pub/ + +# testing directories +testing/ + +Stage/ diff --git a/Clojure.nuspec b/Clojure.nuspec index fd7bdc467..82c702fc4 100644 --- a/Clojure.nuspec +++ b/Clojure.nuspec @@ -1,38 +1,38 @@ - - - - Clojure - 1.10.0 - Rich Hickey, Clojure - false - http://opensource.org/licenses/eclipse-1.0.php - https://github.com/clojure/clojure-clr - http://clojure.org/file/view/clojure-icon.gif - Clojure for the CLR. - clojure clojureclr - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + Clojure + 1.10.0 + Rich Hickey, Clojure + false + http://opensource.org/licenses/eclipse-1.0.php + https://github.com/clojure/clojure-clr + http://clojure.org/file/view/clojure-icon.gif + Clojure for the CLR. + clojure clojureclr + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Clojure/Clojure.Compile/Clojure.Compile.csproj b/Clojure/Clojure.Compile/Clojure.Compile.csproj index e4fb48063..2d7ef37f3 100644 --- a/Clojure/Clojure.Compile/Clojure.Compile.csproj +++ b/Clojure/Clojure.Compile/Clojure.Compile.csproj @@ -1,40 +1,40 @@ - - - - Exe - net462 - BootstrapCompile.Compile - - - - 0 - - - - - - - - - - - - - - - - - $(TargetPath) - mono $(TargetPath) - - - - - - - - - - - - + + + + Exe + net462 + BootstrapCompile.Compile + + + + 0 + + + + + + + + + + + + + + + + + $(TargetPath) + mono $(TargetPath) + + + + + + + + + + + + diff --git a/Clojure/Clojure.Compile/Compile.cs b/Clojure/Clojure.Compile/Compile.cs index ee9b24868..78822494f 100644 --- a/Clojure/Clojure.Compile/Compile.cs +++ b/Clojure/Clojure.Compile/Compile.cs @@ -1,98 +1,98 @@ -/** - * 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.Diagnostics; -using System.IO; -using clojure.lang; - -namespace BootstrapCompile -{ - static class Compile - { - - const string PATH_PROP = "CLOJURE_COMPILE_PATH"; - const string REFLECTION_WARNING_PROP = "CLOJURE_COMPILE_WARN_ON_REFLECTION"; - const string UNCHECKED_MATH_PROP = "CLOJURE_COMPILE_UNCHECKED_MATH"; - - static void Main(string[] args) - { - RT.Init(); - - TextWriter outTW = (TextWriter)RT.OutVar.deref(); - TextWriter errTW = RT.errPrintWriter(); - - string path = Environment.GetEnvironmentVariable(PATH_PROP); - - path = path ?? "."; - - string warnVal = Environment.GetEnvironmentVariable(REFLECTION_WARNING_PROP); - bool warnOnReflection = warnVal == null ? false : warnVal.Equals("true"); - string mathVal = Environment.GetEnvironmentVariable(UNCHECKED_MATH_PROP); - object uncheckedMath = false; - - if ("true".Equals(mathVal)) - uncheckedMath = true; - else if ("warn-on-boxed".Equals(mathVal)) - uncheckedMath = Keyword.intern("warn-on-boxed"); - - - // Force load to avoid transitive compilation during lazy load - Compiler.EnsureMacroCheck(); - - try - { - Var.pushThreadBindings(RT.map( - Compiler.CompilePathVar, path, - RT.WarnOnReflectionVar, warnOnReflection, - RT.UncheckedMathVar, uncheckedMath - )); - - Stopwatch sw = new Stopwatch(); - - foreach (string lib in args) - { - sw.Reset(); - sw.Start(); - outTW.Write("Compiling {0} to {1}", lib, path); - outTW.Flush(); - Compiler.CompileVar.invoke(Symbol.intern(lib)); - sw.Stop(); - outTW.WriteLine(" -- {0} milliseconds.", sw.ElapsedMilliseconds); - } - } - catch (Exception e) - { - errTW.WriteLine(e.ToString()); - errTW.Flush(); - Environment.Exit(1); - } - finally - { - Var.popThreadBindings(); - try { - outTW.Flush(); - } - catch ( IOException e) - { - errTW.WriteLine(e.StackTrace); - errTW.Flush(); - } - } - - - - } - } -} +/** + * 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.Diagnostics; +using System.IO; +using clojure.lang; + +namespace BootstrapCompile +{ + static class Compile + { + + const string PATH_PROP = "CLOJURE_COMPILE_PATH"; + const string REFLECTION_WARNING_PROP = "CLOJURE_COMPILE_WARN_ON_REFLECTION"; + const string UNCHECKED_MATH_PROP = "CLOJURE_COMPILE_UNCHECKED_MATH"; + + static void Main(string[] args) + { + RT.Init(); + + TextWriter outTW = (TextWriter)RT.OutVar.deref(); + TextWriter errTW = RT.errPrintWriter(); + + string path = Environment.GetEnvironmentVariable(PATH_PROP); + + path = path ?? "."; + + string warnVal = Environment.GetEnvironmentVariable(REFLECTION_WARNING_PROP); + bool warnOnReflection = warnVal == null ? false : warnVal.Equals("true"); + string mathVal = Environment.GetEnvironmentVariable(UNCHECKED_MATH_PROP); + object uncheckedMath = false; + + if ("true".Equals(mathVal)) + uncheckedMath = true; + else if ("warn-on-boxed".Equals(mathVal)) + uncheckedMath = Keyword.intern("warn-on-boxed"); + + + // Force load to avoid transitive compilation during lazy load + Compiler.EnsureMacroCheck(); + + try + { + Var.pushThreadBindings(RT.map( + Compiler.CompilePathVar, path, + RT.WarnOnReflectionVar, warnOnReflection, + RT.UncheckedMathVar, uncheckedMath + )); + + Stopwatch sw = new Stopwatch(); + + foreach (string lib in args) + { + sw.Reset(); + sw.Start(); + outTW.Write("Compiling {0} to {1}", lib, path); + outTW.Flush(); + Compiler.CompileVar.invoke(Symbol.intern(lib)); + sw.Stop(); + outTW.WriteLine(" -- {0} milliseconds.", sw.ElapsedMilliseconds); + } + } + catch (Exception e) + { + errTW.WriteLine(e.ToString()); + errTW.Flush(); + Environment.Exit(1); + } + finally + { + Var.popThreadBindings(); + try { + outTW.Flush(); + } + catch ( IOException e) + { + errTW.WriteLine(e.StackTrace); + errTW.Flush(); + } + } + + + + } + } +} diff --git a/Clojure/Clojure.Main/Clojure.Main.csproj b/Clojure/Clojure.Main/Clojure.Main.csproj index d21575f85..8acf599a8 100644 --- a/Clojure/Clojure.Main/Clojure.Main.csproj +++ b/Clojure/Clojure.Main/Clojure.Main.csproj @@ -1,27 +1,27 @@ - - - - Exe - netcoreapp3.1;net6.0;net7.0 - Clojure.CljMain - true - - - - ClojureCLR-REPL - Standard REPL for ClojureCLR. - - - - - - - - - - - - - - - + + + + Exe + netcoreapp3.1;net6.0;net7.0 + Clojure.CljMain + true + + + + ClojureCLR-REPL + Standard REPL for ClojureCLR. + + + + + + + + + + + + + + + diff --git a/Clojure/Clojure.Main/Main.cs b/Clojure/Clojure.Main/Main.cs index afa6589fb..dc3784f26 100644 --- a/Clojure/Clojure.Main/Main.cs +++ b/Clojure/Clojure.Main/Main.cs @@ -1,57 +1,57 @@ -/** - * 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.Linq; -using System.Text; -using clojure.lang; - -namespace Clojure -{ - public static class CljMain - { - private static readonly Symbol CLOJURE_MAIN = Symbol.intern("clojure.main"); - private static readonly Var REQUIRE = RT.var("clojure.core", "require"); - private static readonly Var LEGACY_REPL = RT.var("clojure.main", "legacy-repl"); - private static readonly Var LEGACY_SCRIPT = RT.var("clojure.main", "legacy-script"); - private static readonly Var MAIN = RT.var("clojure.main", "main"); - - static void Main(string[] args) - { - RT.Init(); - REQUIRE.invoke(CLOJURE_MAIN); - MAIN.applyTo(RT.seq(args)); - } - - [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE1006:Naming Styles", Justification = "ClojureJVM name match")] - public static void legacy_repl(string[] args) - { - RT.Init(); - REQUIRE.invoke(CLOJURE_MAIN); - LEGACY_REPL.invoke(RT.seq(args)); - - } - - [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE1006:Naming Styles", Justification = "ClojureJVM name match")] - public static void legacy_script(string[] args) - { - RT.Init(); - REQUIRE.invoke(CLOJURE_MAIN); - LEGACY_SCRIPT.invoke(RT.seq(args)); - } - - - } -} +/** + * 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.Linq; +using System.Text; +using clojure.lang; + +namespace Clojure +{ + public static class CljMain + { + private static readonly Symbol CLOJURE_MAIN = Symbol.intern("clojure.main"); + private static readonly Var REQUIRE = RT.var("clojure.core", "require"); + private static readonly Var LEGACY_REPL = RT.var("clojure.main", "legacy-repl"); + private static readonly Var LEGACY_SCRIPT = RT.var("clojure.main", "legacy-script"); + private static readonly Var MAIN = RT.var("clojure.main", "main"); + + static void Main(string[] args) + { + RT.Init(); + REQUIRE.invoke(CLOJURE_MAIN); + MAIN.applyTo(RT.seq(args)); + } + + [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE1006:Naming Styles", Justification = "ClojureJVM name match")] + public static void legacy_repl(string[] args) + { + RT.Init(); + REQUIRE.invoke(CLOJURE_MAIN); + LEGACY_REPL.invoke(RT.seq(args)); + + } + + [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE1006:Naming Styles", Justification = "ClojureJVM name match")] + public static void legacy_script(string[] args) + { + RT.Init(); + REQUIRE.invoke(CLOJURE_MAIN); + LEGACY_SCRIPT.invoke(RT.seq(args)); + } + + + } +} diff --git a/Clojure/Clojure.Source/Clojure.Source.csproj b/Clojure/Clojure.Source/Clojure.Source.csproj index 6454d1e8e..5705b1c80 100644 --- a/Clojure/Clojure.Source/Clojure.Source.csproj +++ b/Clojure/Clojure.Source/Clojure.Source.csproj @@ -1,137 +1,137 @@ - - - - netstandard2.1;netstandard2.0 - - true - - - - TRACE;DEBUG - - - - - - - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - PreserveNewest - - - - + + + + netstandard2.1;netstandard2.0 + + true + + + + TRACE;DEBUG + + + + + + + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + PreserveNewest + + + + diff --git a/Clojure/Clojure.Source/clojure/clr/io.clj b/Clojure/Clojure.Source/clojure/clr/io.clj index 64981b437..a7a47afdb 100644 --- a/Clojure/Clojure.Source/clojure/clr/io.clj +++ b/Clojure/Clojure.Source/clojure/clr/io.clj @@ -1,468 +1,468 @@ -; 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. - -(ns - ^{:author "David Miller", - :doc "Shamelessly based on the clojure.java.io package authored by Stuart Sierra, Chas Emerick, Stuart Halloway. - This file defines polymorphic I/O utility functions for Clojure."} - clojure.clr.io - (:import - (System.IO - Stream BufferedStream - FileInfo FileStream MemoryStream - FileMode FileShare FileAccess FileOptions - BinaryReader BinaryWriter - StreamReader StreamWriter - StringReader StringWriter - TextReader TextWriter) - (System.Net.Sockets - Socket NetworkStream) - (System.Text - Encoding UTF8Encoding UnicodeEncoding UTF32Encoding UTF7Encoding ASCIIEncoding Decoder Encoder) - (System - Uri UriFormatException))) - - -(defprotocol ^{:added "1.2"} Coercions - "Coerce between various 'resource-namish' things." - (^{:tag System.IO.FileInfo, :added "1.2"} as-file [x] "Coerce argument to a file.") - (^{:tag System.Uri, :added "1.2"} as-uri [x] "Coerce argument to a URI.")) - -(extend-protocol Coercions - nil - (as-file [_] nil) - (as-uri [_] nil) - - String - (as-file [s] (FileInfo. s)) - (as-uri [s] (Uri. s)) - - FileInfo - (as-file [f] f) - (as-uri [f] (Uri. (str "file://" (.FullName f)))) - - Uri - (as-uri [u] u) - (as-file [u] - (if (.IsFile u) - (as-file (.LocalPath u)) - (throw (ArgumentException. (str "Not a file: " u)))))) - -(defprotocol ^{:added "1.2"} IOFactory - "Factory functions that create ready-to-use, buffered versions of - the various Java I/O stream types, on top of anything that can - be unequivocally converted to the requested kind of stream. - - Common options include - - :buffer-size Ths size of buffer to use (default: 1024). - :file-share A value from the System.IO.FileShare enumeration. - :file-mode A value from the System.IO.FileMode enumeration. - :file-access A value from the System.IO.FileAccess enumeration. - :file-options A value from the System.IO.FileOptions enumeration. - :encoding The encoding to use, either as a string, e.g. \"UTF-8\", - a keyword, e.g. :utf-8, or a an System.Text.Encoding instance, - e.g., (System.Text.UTF8Encoding.) - - Callers should generally prefer the higher level API provided by - reader, writer, input-stream, and output-stream." - (^{:added "1.2"} make-text-reader [x opts] "Creates a TextReader. See also IOFactory docs.") - (^{:added "1.2"} make-text-writer [x opts] "Creates a TextWriter. See also IOFactory docs.") - (^{:added "1.2"} make-input-stream [x opts] "Creates a Stream in input mode. See also IOFactory docs.") - (^{:added "1.2"} make-output-stream [x opts] "Creates a Stream in output mode. See also IOFactory docs.") - (^{:added "1.2"} make-binary-reader [x opts] "Creates a BinaryReader. See also IOFactory docs.") - (^{:added "1.2"} make-binary-writer [x opts] "Creates a BinaryWriter. See also IOFactory docs.")) - -(defn ^TextReader text-reader - "Attempts to coerce its argument into an open System.IO.TextReader. - - Default implementations are provided for Stream, Uri, FileInfo, Socket, - byte arrays, and String. - - If argument is a String, it tries to resolve it first as a URI, then - as a local file name. URIs with a 'file' protocol are converted to - local file names. - - Should be used inside with-open to ensure the TextReader is properly - closed." - {:added "1.2"} - [x & opts] - (make-text-reader x (when opts (apply hash-map opts)))) - -(defn ^TextWriter text-writer - "Attempts to coerce its argument into an open System.IO.TextWriter. - - Default implementations are provided for Stream, Uri, FileInfo, Socket, - and String. - - If the argument is a String, it tries to resolve it first as a URI, then - as a local file name. URIs with a 'file' protocol are converted to - local file names. - - Should be used inside with-open to ensure the TestWriter is properly - closed." - {:added "1.2"} - [x & opts] - (make-text-writer x (when opts (apply hash-map opts)))) - -(defn ^Stream input-stream - "Attempts to coerce its argument into an open System.IO.Stream - in input mode. - - Default implementations are defined for Stream, FileInfo, Uri, - Socket, byte array, char array, and String arguments. - - If the argument is a String, it tries to resolve it first as a URI, then - as a local file name. URIs with a 'file' protocol are converted to - local file names. - - Should be used inside with-open to ensure the Stream is properly - closed." - {:added "1.2"} - [x & opts] - (make-input-stream x (when opts (apply hash-map opts)))) - -(defn ^Stream output-stream - "Attempts to coerce its argument into an open System.IO.Stream. - - Default implementations are defined for Stream, FileInfo, URI, - Socket, and String arguments. - - If the argument is a String, it tries to resolve it first as a URI, then - as a local file name. URIs with a 'file' protocol are converted to - local file names. - - Should be used inside with-open to ensure the OutputStream is - properly closed." - {:added "1.2"} - [x & opts] - (make-output-stream x (when opts (apply hash-map opts)))) - - -(defn ^BinaryReader binary-reader - "Attempt to coerce its argument into an open System.IO.BinaryReader. - - Default implementations are defined for Stream, FileInfo, URI, Socket, - byte array, and String arguments. - - If the argument is a String, it tries to resolve it first as a URI, then - as a local file name. URIs with a 'file' protocol are converted to - local file names. - - Should be used inside with-open to ensure the BinaryReader is - properly closed." - {:added "1.2"} - [x & opts] - (make-binary-reader x (when opts (apply hash-map opts)))) - -(defn ^BinaryWriter binary-writer - "Attempt to coerce its argument into an open System.IO.BinaryWriter. - - Default implementations are defined for Stream, FileInfo, URI, Socket, - and String arguments. - - If the argument is a String, it tries to resolve it first as a URI, then - as a local file name. URIs with a 'file' protocol are converted to - local file names. - - Should be used inside with-open to ensure the BinaryWriter is - properly closed." - {:added "1.2"} - [x & opts] - (make-binary-writer x (when opts (apply hash-map opts)))) - -(def string->encoding - { "UTF-8" (UTF8Encoding.) - "UTF-16" (UnicodeEncoding.) - "UTF-32" (UTF32Encoding.) - "UTF-7" (UTF7Encoding.) - "ascii" (ASCIIEncoding.) - "ASCII" (ASCIIEncoding.) - "us-ascii" (ASCIIEncoding.) - :utf8 (UTF8Encoding.) - :utf16 (UnicodeEncoding.) - :utf32 (UTF32Encoding.) - :utf7 (UTF7Encoding.) - :ascii (ASCIIEncoding.) - :utf-8 (UTF8Encoding.) - :utf-16 (UnicodeEncoding.) - :utf-32 (UTF32Encoding.) - :utf-7 (UTF7Encoding.) - }) - -(defn- normalize-encoding [key] - (if (string? key) - (get string->encoding key) - key)) - -(defn- ^Encoding encoding [opts] - (or (normalize-encoding (:encoding opts)) (get string->encoding "UTF-8"))) - -(defn- buffer-size [opts] - (or (:buffer-size opts) 1024)) - -(defn- ^FileMode file-mode [mode opts] - (or (:file-mode opts) - (if (= mode :read) - FileMode/Open - FileMode/OpenOrCreate))) - -(defn- ^FileShare file-share [opts] - (or (:file-share opts) FileShare/None)) - -(defn- ^FileAccess file-access [mode opts] - (or (:file-access opts) - (if (= mode :read) - FileAccess/Read - FileAccess/Write))) - -(defn- ^FileOptions file-options [opts] - (or (:file-options opts) FileOptions/None)) - - -(def default-streams-impl - {:make-text-reader (fn [x opts] (make-text-reader (make-input-stream x opts) opts)) - :make-text-writer (fn [x opts] (make-text-writer (make-output-stream x opts) opts)) - :make-binary-reader (fn [x opts] (make-binary-reader (make-input-stream x opts) opts)) - :make-binary-writer (fn [x opts] (make-binary-writer (make-output-stream x opts) opts)) - :make-input-stream (fn [x opts] - (throw (ArgumentException. - (str "Cannot open <" (pr-str x) "> as an input Stream.")))) - :make-output-stream (fn [x opts] - (throw (ArgumentException. - (str "Cannot open <" (pr-str x) "> as an output Stream."))))}) - -(extend Stream - IOFactory - (assoc default-streams-impl - :make-text-reader (fn [^Stream x opts] (StreamReader. x (encoding opts))) - :make-text-writer (fn [^Stream x opts] (StreamWriter. x (encoding opts))) - :make-binary-reader (fn [^Stream x opts] (BinaryReader. x (encoding opts))) - :make-binary-writer (fn [^Stream x opts] (BinaryWriter. x (encoding opts))) - :make-input-stream (fn [^Stream x opts] (if (.CanRead x) x (throw (ArgumentException. "Cannot convert non-reading stream to input stream")))) - :make-output-stream (fn [^Stream x opts] (if (.CanWrite x) x (throw (ArgumentException. "Cannot convert non-reading stream to input stream")))))) - -(extend BinaryReader - IOFactory - (assoc default-streams-impl - :make-binary-reader (fn [x opts] x) - :make-input-stream (fn [^BinaryReader x opts] (.BaseStream x)) - :make-output-stream (fn [^BinaryReader x opts] (make-output-stream (.BaseStream x) opts)))) - -(extend BinaryWriter - IOFactory - (assoc default-streams-impl - :make-binary-writer (fn [x opts] x) - :make-input-stream (fn [^BinaryWriter x opts] (make-input-stream (.BaseStream x) opts)) - :make-output-stream (fn [^BinaryWriter x opts] (.BaseStream x)))) - -(extend StreamReader - IOFactory - (assoc default-streams-impl - :make-text-reader (fn [x opts] x) - :make-input-stream (fn [^StreamReader x opts] (.BaseStream x)) - :make-output-stream (fn [^StreamReader x opts] (make-output-stream (.BaseStream x) opts)))) - -(extend StreamWriter - IOFactory - (assoc default-streams-impl - :make-text-writer (fn [x opts] x) - :make-input-stream (fn [^StreamWriter x opts] (make-input-stream (.BaseStream x) opts)) - :make-output-stream (fn [^StreamWriter x opts] (.BaseStream x)))) - -(extend StringReader - IOFactory - (assoc default-streams-impl - :make-text-reader (fn [x opts] x))) - -(extend StringWriter - IOFactory - (assoc default-streams-impl - :make-text-writer (fn [x opts] x))) - -(extend FileInfo - IOFactory - (assoc default-streams-impl - :make-input-stream (fn [^FileInfo x opts] - (make-input-stream - (FileStream. (.FullName x) - (file-mode :read opts) - (file-access :read opts) - (file-share opts) - (buffer-size opts) - (file-options opts)) - opts)) - :make-output-stream (fn [^FileInfo x opts] - (make-output-stream - (FileStream. (.FullName x) - (file-mode :write opts) - (file-access :write opts) - (file-share opts) - (buffer-size opts) - (file-options opts)) - opts)))) - -(extend String - IOFactory - (assoc default-streams-impl - :make-input-stream (fn [^String x opts] - (try - (make-input-stream (Uri. x) opts) - (catch UriFormatException err - (make-input-stream (FileInfo. x) opts)))) - :make-output-stream (fn [^String x opts] - (try - (make-output-stream (Uri. x) opts) - (catch UriFormatException err - (make-output-stream (FileInfo. x) opts)))))) -(extend Socket - IOFactory - (assoc default-streams-impl - :make-input-stream (fn [^Socket x opts] (NetworkStream. x (file-access :read opts))) - :make-output-stream (fn [^Socket x opts] (NetworkStream. x (file-access :write opts))))) - - -(extend Uri - IOFactory - (assoc default-streams-impl - :make-input-stream (fn [^Uri x opts] - (if (.IsFile x) - (make-input-stream (FileInfo. (.LocalPath x)) opts) - (.OpenRead (System.Net.WebClient.) x))) - :make-output-stream (fn [^Uri x opts] - (if (.IsFile x) - (make-output-stream (FileInfo. (.LocalPath x)) opts) - (.OpenWrite (System.Net.WebClient.) x))))) - - -(extend |System.Byte[]| - IOFactory - (assoc default-streams-impl - :make-input-stream (fn [^|System.Byte[]| x opts] (MemoryStream. x)))) - -(extend Object - IOFactory - default-streams-impl) - -(extend nil - IOFactory - (assoc default-streams-impl - :make-text-reader (fn [x opts] - (throw (ArgumentException. - (str "Cannot open <" (pr-str x) "> as a Reader.")))) - :make-text-writer (fn [x opts] - (throw (ArgumentException. - (str "Cannot open <" (pr-str x) "> as a Writer.")))))) - - -(defmulti - ^{:doc "Internal helper for copy" - :private true - :arglists '([input output opts])} - do-copy - (fn [input output opts] [(type input) (type output)])) - -(defmethod do-copy [Stream Stream] [^Stream input ^Stream output opts] - (let [ len (buffer-size opts) - ^bytes buffer (make-array Byte len)] - (loop [] - (let [size (.Read input buffer 0 len)] - (when (pos? size) - (do (.Write output buffer 0 size) - (recur))))))) - -(defmethod do-copy [Stream TextWriter] [^Stream input ^TextWriter output opts] - (let [ len (buffer-size opts) - ^bytes buffer (make-array Byte len) - ^Decoder decoder (.GetDecoder (encoding opts)) ] - (loop [] - (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) - (.Write output chbuf 0 cnt) - (recur)))))))) - -(defmethod do-copy [Stream FileInfo] [^Stream input ^FileInfo output opts] - (with-open [out (make-output-stream output opts)] - (do-copy input out opts))) - -(defmethod do-copy [TextReader Stream] [^TextReader input ^Stream output opts] - (let [ len (buffer-size opts) - ^chars buffer (make-array Char len) - ^Encoder encoder (.GetEncoder (encoding opts))] - (loop [] - (let [size (.Read input buffer 0 len)] - (when (pos? size) - (let [cnt (.GetByteCount encoder buffer 0 size false) - bytes (make-array Byte cnt)] - (do (.GetBytes encoder buffer 0 size bytes 0 false) - (.Write output bytes 0 cnt) - (recur)))))))) - -(defmethod do-copy [TextReader TextWriter] [^TextReader input ^TextWriter output opts] - (let [ len (buffer-size opts) - ^chars buffer (make-array Char len)] - (loop [] - (let [size (.Read input buffer 0 len)] - (when (pos? size) - (do (.Write output buffer 0 size) - (recur))))))) - -(defmethod do-copy [TextReader FileInfo] [^TextReader input ^FileInfo output opts] - (with-open [out (make-output-stream output opts)] - (do-copy input out opts))) - -(defmethod do-copy [FileInfo Stream] [^FileInfo input ^Stream output opts] - (with-open [in (make-input-stream input opts)] - (do-copy in output opts))) - -(defmethod do-copy [FileInfo TextWriter] [^FileInfo input ^TextWriter output opts] - (with-open [in (make-input-stream input opts)] - (do-copy in output opts))) - -(defmethod do-copy [FileInfo FileInfo] [^FileInfo input ^FileInfo output opts] - (with-open [in (make-input-stream input opts) - out (make-output-stream output opts)] - (do-copy in out opts))) - -(defmethod do-copy [String Stream] [^String input ^Stream output opts] - (do-copy (StringReader. input) output opts)) - -(defmethod do-copy [String TextWriter] [^String input ^TextWriter output opts] - (do-copy (StringReader. input) output opts)) - -(defmethod do-copy [String FileInfo] [^String input ^FileInfo output opts] - (do-copy (StringReader. input) output opts)) - -(defmethod do-copy [|System.Byte[]| Stream] [^bytes input ^Stream output opts] - (do-copy (MemoryStream. input) output opts)) - -(defmethod do-copy [|System.Byte[]| TextWriter] [^bytes input ^TextWriter output opts] - (do-copy (MemoryStream. input) output opts)) - -(defmethod do-copy [|System.Byte[]| FileInfo] [^bytes input ^FileInfo output opts] - (do-copy (MemoryStream. input) output opts)) - -(defn copy - "Copies input to output. Returns nil or throws IOException. - Input may be an InputStream, Reader, File, byte[], or String. - Output may be an OutputStream, Writer, or File. - - Options are key/value pairs and may be one of - - :buffer-size buffer size to use, default is 1024. - :encoding encoding to use if converting between - byte and char streams. - - Does not close any streams except those it opens itself - (on a File)." - {:added "1.2"} - [input output & opts] - (do-copy input output (when opts (apply hash-map opts)))) +; 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. + +(ns + ^{:author "David Miller", + :doc "Shamelessly based on the clojure.java.io package authored by Stuart Sierra, Chas Emerick, Stuart Halloway. + This file defines polymorphic I/O utility functions for Clojure."} + clojure.clr.io + (:import + (System.IO + Stream BufferedStream + FileInfo FileStream MemoryStream + FileMode FileShare FileAccess FileOptions + BinaryReader BinaryWriter + StreamReader StreamWriter + StringReader StringWriter + TextReader TextWriter) + (System.Net.Sockets + Socket NetworkStream) + (System.Text + Encoding UTF8Encoding UnicodeEncoding UTF32Encoding UTF7Encoding ASCIIEncoding Decoder Encoder) + (System + Uri UriFormatException))) + + +(defprotocol ^{:added "1.2"} Coercions + "Coerce between various 'resource-namish' things." + (^{:tag System.IO.FileInfo, :added "1.2"} as-file [x] "Coerce argument to a file.") + (^{:tag System.Uri, :added "1.2"} as-uri [x] "Coerce argument to a URI.")) + +(extend-protocol Coercions + nil + (as-file [_] nil) + (as-uri [_] nil) + + String + (as-file [s] (FileInfo. s)) + (as-uri [s] (Uri. s)) + + FileInfo + (as-file [f] f) + (as-uri [f] (Uri. (str "file://" (.FullName f)))) + + Uri + (as-uri [u] u) + (as-file [u] + (if (.IsFile u) + (as-file (.LocalPath u)) + (throw (ArgumentException. (str "Not a file: " u)))))) + +(defprotocol ^{:added "1.2"} IOFactory + "Factory functions that create ready-to-use, buffered versions of + the various Java I/O stream types, on top of anything that can + be unequivocally converted to the requested kind of stream. + + Common options include + + :buffer-size Ths size of buffer to use (default: 1024). + :file-share A value from the System.IO.FileShare enumeration. + :file-mode A value from the System.IO.FileMode enumeration. + :file-access A value from the System.IO.FileAccess enumeration. + :file-options A value from the System.IO.FileOptions enumeration. + :encoding The encoding to use, either as a string, e.g. \"UTF-8\", + a keyword, e.g. :utf-8, or a an System.Text.Encoding instance, + e.g., (System.Text.UTF8Encoding.) + + Callers should generally prefer the higher level API provided by + reader, writer, input-stream, and output-stream." + (^{:added "1.2"} make-text-reader [x opts] "Creates a TextReader. See also IOFactory docs.") + (^{:added "1.2"} make-text-writer [x opts] "Creates a TextWriter. See also IOFactory docs.") + (^{:added "1.2"} make-input-stream [x opts] "Creates a Stream in input mode. See also IOFactory docs.") + (^{:added "1.2"} make-output-stream [x opts] "Creates a Stream in output mode. See also IOFactory docs.") + (^{:added "1.2"} make-binary-reader [x opts] "Creates a BinaryReader. See also IOFactory docs.") + (^{:added "1.2"} make-binary-writer [x opts] "Creates a BinaryWriter. See also IOFactory docs.")) + +(defn ^TextReader text-reader + "Attempts to coerce its argument into an open System.IO.TextReader. + + Default implementations are provided for Stream, Uri, FileInfo, Socket, + byte arrays, and String. + + If argument is a String, it tries to resolve it first as a URI, then + as a local file name. URIs with a 'file' protocol are converted to + local file names. + + Should be used inside with-open to ensure the TextReader is properly + closed." + {:added "1.2"} + [x & opts] + (make-text-reader x (when opts (apply hash-map opts)))) + +(defn ^TextWriter text-writer + "Attempts to coerce its argument into an open System.IO.TextWriter. + + Default implementations are provided for Stream, Uri, FileInfo, Socket, + and String. + + If the argument is a String, it tries to resolve it first as a URI, then + as a local file name. URIs with a 'file' protocol are converted to + local file names. + + Should be used inside with-open to ensure the TestWriter is properly + closed." + {:added "1.2"} + [x & opts] + (make-text-writer x (when opts (apply hash-map opts)))) + +(defn ^Stream input-stream + "Attempts to coerce its argument into an open System.IO.Stream + in input mode. + + Default implementations are defined for Stream, FileInfo, Uri, + Socket, byte array, char array, and String arguments. + + If the argument is a String, it tries to resolve it first as a URI, then + as a local file name. URIs with a 'file' protocol are converted to + local file names. + + Should be used inside with-open to ensure the Stream is properly + closed." + {:added "1.2"} + [x & opts] + (make-input-stream x (when opts (apply hash-map opts)))) + +(defn ^Stream output-stream + "Attempts to coerce its argument into an open System.IO.Stream. + + Default implementations are defined for Stream, FileInfo, URI, + Socket, and String arguments. + + If the argument is a String, it tries to resolve it first as a URI, then + as a local file name. URIs with a 'file' protocol are converted to + local file names. + + Should be used inside with-open to ensure the OutputStream is + properly closed." + {:added "1.2"} + [x & opts] + (make-output-stream x (when opts (apply hash-map opts)))) + + +(defn ^BinaryReader binary-reader + "Attempt to coerce its argument into an open System.IO.BinaryReader. + + Default implementations are defined for Stream, FileInfo, URI, Socket, + byte array, and String arguments. + + If the argument is a String, it tries to resolve it first as a URI, then + as a local file name. URIs with a 'file' protocol are converted to + local file names. + + Should be used inside with-open to ensure the BinaryReader is + properly closed." + {:added "1.2"} + [x & opts] + (make-binary-reader x (when opts (apply hash-map opts)))) + +(defn ^BinaryWriter binary-writer + "Attempt to coerce its argument into an open System.IO.BinaryWriter. + + Default implementations are defined for Stream, FileInfo, URI, Socket, + and String arguments. + + If the argument is a String, it tries to resolve it first as a URI, then + as a local file name. URIs with a 'file' protocol are converted to + local file names. + + Should be used inside with-open to ensure the BinaryWriter is + properly closed." + {:added "1.2"} + [x & opts] + (make-binary-writer x (when opts (apply hash-map opts)))) + +(def string->encoding + { "UTF-8" (UTF8Encoding.) + "UTF-16" (UnicodeEncoding.) + "UTF-32" (UTF32Encoding.) + "UTF-7" (UTF7Encoding.) + "ascii" (ASCIIEncoding.) + "ASCII" (ASCIIEncoding.) + "us-ascii" (ASCIIEncoding.) + :utf8 (UTF8Encoding.) + :utf16 (UnicodeEncoding.) + :utf32 (UTF32Encoding.) + :utf7 (UTF7Encoding.) + :ascii (ASCIIEncoding.) + :utf-8 (UTF8Encoding.) + :utf-16 (UnicodeEncoding.) + :utf-32 (UTF32Encoding.) + :utf-7 (UTF7Encoding.) + }) + +(defn- normalize-encoding [key] + (if (string? key) + (get string->encoding key) + key)) + +(defn- ^Encoding encoding [opts] + (or (normalize-encoding (:encoding opts)) (get string->encoding "UTF-8"))) + +(defn- buffer-size [opts] + (or (:buffer-size opts) 1024)) + +(defn- ^FileMode file-mode [mode opts] + (or (:file-mode opts) + (if (= mode :read) + FileMode/Open + FileMode/OpenOrCreate))) + +(defn- ^FileShare file-share [opts] + (or (:file-share opts) FileShare/None)) + +(defn- ^FileAccess file-access [mode opts] + (or (:file-access opts) + (if (= mode :read) + FileAccess/Read + FileAccess/Write))) + +(defn- ^FileOptions file-options [opts] + (or (:file-options opts) FileOptions/None)) + + +(def default-streams-impl + {:make-text-reader (fn [x opts] (make-text-reader (make-input-stream x opts) opts)) + :make-text-writer (fn [x opts] (make-text-writer (make-output-stream x opts) opts)) + :make-binary-reader (fn [x opts] (make-binary-reader (make-input-stream x opts) opts)) + :make-binary-writer (fn [x opts] (make-binary-writer (make-output-stream x opts) opts)) + :make-input-stream (fn [x opts] + (throw (ArgumentException. + (str "Cannot open <" (pr-str x) "> as an input Stream.")))) + :make-output-stream (fn [x opts] + (throw (ArgumentException. + (str "Cannot open <" (pr-str x) "> as an output Stream."))))}) + +(extend Stream + IOFactory + (assoc default-streams-impl + :make-text-reader (fn [^Stream x opts] (StreamReader. x (encoding opts))) + :make-text-writer (fn [^Stream x opts] (StreamWriter. x (encoding opts))) + :make-binary-reader (fn [^Stream x opts] (BinaryReader. x (encoding opts))) + :make-binary-writer (fn [^Stream x opts] (BinaryWriter. x (encoding opts))) + :make-input-stream (fn [^Stream x opts] (if (.CanRead x) x (throw (ArgumentException. "Cannot convert non-reading stream to input stream")))) + :make-output-stream (fn [^Stream x opts] (if (.CanWrite x) x (throw (ArgumentException. "Cannot convert non-reading stream to input stream")))))) + +(extend BinaryReader + IOFactory + (assoc default-streams-impl + :make-binary-reader (fn [x opts] x) + :make-input-stream (fn [^BinaryReader x opts] (.BaseStream x)) + :make-output-stream (fn [^BinaryReader x opts] (make-output-stream (.BaseStream x) opts)))) + +(extend BinaryWriter + IOFactory + (assoc default-streams-impl + :make-binary-writer (fn [x opts] x) + :make-input-stream (fn [^BinaryWriter x opts] (make-input-stream (.BaseStream x) opts)) + :make-output-stream (fn [^BinaryWriter x opts] (.BaseStream x)))) + +(extend StreamReader + IOFactory + (assoc default-streams-impl + :make-text-reader (fn [x opts] x) + :make-input-stream (fn [^StreamReader x opts] (.BaseStream x)) + :make-output-stream (fn [^StreamReader x opts] (make-output-stream (.BaseStream x) opts)))) + +(extend StreamWriter + IOFactory + (assoc default-streams-impl + :make-text-writer (fn [x opts] x) + :make-input-stream (fn [^StreamWriter x opts] (make-input-stream (.BaseStream x) opts)) + :make-output-stream (fn [^StreamWriter x opts] (.BaseStream x)))) + +(extend StringReader + IOFactory + (assoc default-streams-impl + :make-text-reader (fn [x opts] x))) + +(extend StringWriter + IOFactory + (assoc default-streams-impl + :make-text-writer (fn [x opts] x))) + +(extend FileInfo + IOFactory + (assoc default-streams-impl + :make-input-stream (fn [^FileInfo x opts] + (make-input-stream + (FileStream. (.FullName x) + (file-mode :read opts) + (file-access :read opts) + (file-share opts) + (buffer-size opts) + (file-options opts)) + opts)) + :make-output-stream (fn [^FileInfo x opts] + (make-output-stream + (FileStream. (.FullName x) + (file-mode :write opts) + (file-access :write opts) + (file-share opts) + (buffer-size opts) + (file-options opts)) + opts)))) + +(extend String + IOFactory + (assoc default-streams-impl + :make-input-stream (fn [^String x opts] + (try + (make-input-stream (Uri. x) opts) + (catch UriFormatException err + (make-input-stream (FileInfo. x) opts)))) + :make-output-stream (fn [^String x opts] + (try + (make-output-stream (Uri. x) opts) + (catch UriFormatException err + (make-output-stream (FileInfo. x) opts)))))) +(extend Socket + IOFactory + (assoc default-streams-impl + :make-input-stream (fn [^Socket x opts] (NetworkStream. x (file-access :read opts))) + :make-output-stream (fn [^Socket x opts] (NetworkStream. x (file-access :write opts))))) + + +(extend Uri + IOFactory + (assoc default-streams-impl + :make-input-stream (fn [^Uri x opts] + (if (.IsFile x) + (make-input-stream (FileInfo. (.LocalPath x)) opts) + (.OpenRead (System.Net.WebClient.) x))) + :make-output-stream (fn [^Uri x opts] + (if (.IsFile x) + (make-output-stream (FileInfo. (.LocalPath x)) opts) + (.OpenWrite (System.Net.WebClient.) x))))) + + +(extend |System.Byte[]| + IOFactory + (assoc default-streams-impl + :make-input-stream (fn [^|System.Byte[]| x opts] (MemoryStream. x)))) + +(extend Object + IOFactory + default-streams-impl) + +(extend nil + IOFactory + (assoc default-streams-impl + :make-text-reader (fn [x opts] + (throw (ArgumentException. + (str "Cannot open <" (pr-str x) "> as a Reader.")))) + :make-text-writer (fn [x opts] + (throw (ArgumentException. + (str "Cannot open <" (pr-str x) "> as a Writer.")))))) + + +(defmulti + ^{:doc "Internal helper for copy" + :private true + :arglists '([input output opts])} + do-copy + (fn [input output opts] [(type input) (type output)])) + +(defmethod do-copy [Stream Stream] [^Stream input ^Stream output opts] + (let [ len (buffer-size opts) + ^bytes buffer (make-array Byte len)] + (loop [] + (let [size (.Read input buffer 0 len)] + (when (pos? size) + (do (.Write output buffer 0 size) + (recur))))))) + +(defmethod do-copy [Stream TextWriter] [^Stream input ^TextWriter output opts] + (let [ len (buffer-size opts) + ^bytes buffer (make-array Byte len) + ^Decoder decoder (.GetDecoder (encoding opts)) ] + (loop [] + (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) + (.Write output chbuf 0 cnt) + (recur)))))))) + +(defmethod do-copy [Stream FileInfo] [^Stream input ^FileInfo output opts] + (with-open [out (make-output-stream output opts)] + (do-copy input out opts))) + +(defmethod do-copy [TextReader Stream] [^TextReader input ^Stream output opts] + (let [ len (buffer-size opts) + ^chars buffer (make-array Char len) + ^Encoder encoder (.GetEncoder (encoding opts))] + (loop [] + (let [size (.Read input buffer 0 len)] + (when (pos? size) + (let [cnt (.GetByteCount encoder buffer 0 size false) + bytes (make-array Byte cnt)] + (do (.GetBytes encoder buffer 0 size bytes 0 false) + (.Write output bytes 0 cnt) + (recur)))))))) + +(defmethod do-copy [TextReader TextWriter] [^TextReader input ^TextWriter output opts] + (let [ len (buffer-size opts) + ^chars buffer (make-array Char len)] + (loop [] + (let [size (.Read input buffer 0 len)] + (when (pos? size) + (do (.Write output buffer 0 size) + (recur))))))) + +(defmethod do-copy [TextReader FileInfo] [^TextReader input ^FileInfo output opts] + (with-open [out (make-output-stream output opts)] + (do-copy input out opts))) + +(defmethod do-copy [FileInfo Stream] [^FileInfo input ^Stream output opts] + (with-open [in (make-input-stream input opts)] + (do-copy in output opts))) + +(defmethod do-copy [FileInfo TextWriter] [^FileInfo input ^TextWriter output opts] + (with-open [in (make-input-stream input opts)] + (do-copy in output opts))) + +(defmethod do-copy [FileInfo FileInfo] [^FileInfo input ^FileInfo output opts] + (with-open [in (make-input-stream input opts) + out (make-output-stream output opts)] + (do-copy in out opts))) + +(defmethod do-copy [String Stream] [^String input ^Stream output opts] + (do-copy (StringReader. input) output opts)) + +(defmethod do-copy [String TextWriter] [^String input ^TextWriter output opts] + (do-copy (StringReader. input) output opts)) + +(defmethod do-copy [String FileInfo] [^String input ^FileInfo output opts] + (do-copy (StringReader. input) output opts)) + +(defmethod do-copy [|System.Byte[]| Stream] [^bytes input ^Stream output opts] + (do-copy (MemoryStream. input) output opts)) + +(defmethod do-copy [|System.Byte[]| TextWriter] [^bytes input ^TextWriter output opts] + (do-copy (MemoryStream. input) output opts)) + +(defmethod do-copy [|System.Byte[]| FileInfo] [^bytes input ^FileInfo output opts] + (do-copy (MemoryStream. input) output opts)) + +(defn copy + "Copies input to output. Returns nil or throws IOException. + Input may be an InputStream, Reader, File, byte[], or String. + Output may be an OutputStream, Writer, or File. + + Options are key/value pairs and may be one of + + :buffer-size buffer size to use, default is 1024. + :encoding encoding to use if converting between + byte and char streams. + + Does not close any streams except those it opens itself + (on a File)." + {:added "1.2"} + [input output & opts] + (do-copy input output (when opts (apply hash-map opts)))) diff --git a/Clojure/Clojure.Source/clojure/core.clj b/Clojure/Clojure.Source/clojure/core.clj index 5eecd09d8..6bb4bac63 100644 --- a/Clojure/Clojure.Source/clojure/core.clj +++ b/Clojure/Clojure.Source/clojure/core.clj @@ -1,1851 +1,1851 @@ -; 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. - -(ns ^{:doc "The core Clojure language." - :author "Rich Hickey"} - clojure.core) - -(def unquote) -(def unquote-splicing) - -(def - ^{:arglists '([& items]) - :doc "Creates a new list containing the items." - :added "1.0"} - list (. clojure.lang.PersistentList creator)) - -(def - ^{:arglists '([x seq]) - :doc "Returns a new seq where x is the first element and seq is - the rest." - :added "1.0" - :static true} - - cons (fn* ^:static cons [x seq] (. clojure.lang.RT (cons x seq)))) - - ;during bootstrap we don't have destructuring let, loop or fn, will redefine later -(def - ^{:macro true :redef true - :added "1.0"} - let (fn* let [&form &env & decl] (cons 'let* decl))) - -(def - ^{:macro true :redef true - :added "1.0"} - loop (fn* loop [&form &env & decl] (cons 'loop* decl))) - - (def - ^{:macro true :redef true - :added "1.0"} - fn (fn* fn [&form &env & decl] - (.withMeta ^clojure.lang.IObj (cons 'fn* decl) - (.meta ^clojure.lang.IMeta &form)))) - -(def - ^{:arglists '([coll]) - :doc "Returns the first item in the collection. Calls seq on its - argument. If coll is nil, returns nil." - :added "1.0" - :static true} - first (fn ^:static first [coll] (. clojure.lang.RT (first coll)))) - -(def - ^{:arglists '([coll]) - :tag clojure.lang.ISeq - :doc "Returns a seq of the items after the first. Calls seq on its - argument. If there are no more items, returns nil." - :added "1.0" - :static true} - next (fn ^:static next [x] (. clojure.lang.RT (next x)))) - -(def - ^{:arglists '([coll]) - :tag clojure.lang.ISeq - :doc "Returns a possibly empty seq of the items after the first. Calls seq on its - argument." - :added "1.0" - :static true} - rest (fn ^:static rest [x] (. clojure.lang.RT (more x)))) - -(def - ^{:arglists '([] [coll] [coll x] [coll x & xs]) - :doc "conj[oin]. Returns a new collection with the xs - 'added'. (conj nil item) returns (item). - (conj coll) returns coll. (conj) returns []. - The 'addition' may happen at different 'places' depending - on the concrete type." - :added "1.0" - :static true} - conj (fn ^:static conj - ([] []) - ([coll] coll) - ([coll x] (clojure.lang.RT/conj coll x)) - ([coll x & xs] - (if xs - (recur (clojure.lang.RT/conj coll x) (first xs) (next xs)) - (clojure.lang.RT/conj coll x))))) - -(def - ^{:doc "Same as (first (next x))" - :arglists '([x]) - :added "1.0" - :static true} - second (fn ^:static second [x] (first (next x)))) - -(def - ^{:doc "Same as (first (first x))" - :arglists '([x]) - :added "1.0" - :static true} - ffirst (fn ^:static ffirst [x] (first (first x)))) - -(def - ^{:doc "Same as (next(first x))" - :arglists '([x]) - :added "1.0" - :static true} - nfirst (fn ^:static nfirst [x] (next (first x)))) - -(def - ^{:doc "Same as (first (next x))" - :arglists '([x]) - :added "1.0" - :static true} - fnext (fn ^:static fnext [x] (first (next x)))) - -(def - ^{:doc "Same as (next (next x))" - :arglists '([x]) - :added "1.0" - :static true} - nnext (fn ^:static nnext [x] (next (next x)))) - -(def - ^{:arglists '(^clojure.lang.ISeq [coll]) - :doc "Returns a seq on the collection. If the collection is - empty, returns nil. (seq nil) returns nil. seq also works on - Strings, native Java arrays (of reference types) and any objects - that implement Iterable. Note that seqs cache values, thus seq - should not be used on any Iterable whose iterator repeatedly - returns the same mutable object." - :tag clojure.lang.ISeq - :added "1.0" - :static true} - seq (fn ^:static seq [coll] (. clojure.lang.RT (seq coll)))) - -(def - ^{:arglists '([^Type c x]) ;;; Class - :doc "Evaluates x and tests if it is an instance of the class - c. Returns true or false" - :added "1.0"} - instance? (fn instance? [^Type c x] (. c (IsInstanceOfType x)))) ;;; Class isInstanceOfTYpe - -(def - ^{:arglists '([x]) - :doc "Return true if x implements ISeq" - :added "1.0" - :static true} - seq? (fn ^:static seq? [x] (instance? clojure.lang.ISeq x))) - -(def - ^{:arglists '([x]) - :doc "Return true if x is a Character" - :added "1.0" - :static true} - char? (fn ^:static char? [x] (instance? Char x))) ;;; Character - -(def - ^{:arglists '([x]) - :doc "Return true if x is a String" - :added "1.0" - :static true} - string? (fn ^:static string? [x] (instance? String x))) - -(def - ^{:arglists '([x]) - :doc "Return true if x implements IPersistentMap" - :added "1.0" - :static true} - map? (fn ^:static map? [x] (instance? clojure.lang.IPersistentMap x))) - -(def - ^{:arglists '([x]) - :doc "Return true if x implements IPersistentVector " - :added "1.0" - :static true} - vector? (fn ^:static vector? [x] (instance? clojure.lang.IPersistentVector x))) - -(def - ^{:arglists '([map key val] [map key val & kvs]) - :doc "assoc[iate]. When applied to a map, returns a new map of the - same (hashed/sorted) type, that contains the mapping of key(s) to - val(s). When applied to a vector, returns a new vector that - contains val at index. Note - index must be <= (count vector)." - :added "1.0" - :static true} - assoc - (fn ^:static assoc - ([map key val] (clojure.lang.RT/assoc map key val)) - ([map key val & kvs] - (let [ret (clojure.lang.RT/assoc map key val)] - (if kvs - (if (next kvs) - (recur ret (first kvs) (second kvs) (nnext kvs)) - (throw (ArgumentException. ;;; IllegalArgumentException - "assoc expects even number of arguments after map/vector, found odd number"))) - ret))))) - -;;;;;;;;;;;;;;;;; metadata ;;;;;;;;;;;;;;;;;;;;;;;;;;; -(def - ^{:arglists '([obj]) - :doc "Returns the metadata of obj, returns nil if there is no metadata." - :added "1.0" - :static true} - meta (fn ^:static meta [x] - (if (instance? clojure.lang.IMeta x) - (. ^clojure.lang.IMeta x (meta))))) - -(def - ^{:arglists '([^clojure.lang.IObj obj m]) - :doc "Returns an object of the same type and value as obj, with - map m as its metadata." - :added "1.0" - :static true} - with-meta (fn ^:static with-meta [^clojure.lang.IObj x m] - (. x (withMeta m)))) - -(def ^{:private true :dynamic true} - assert-valid-fdecl (fn [fdecl])) - -(def - ^{:private true} - sigs - (fn [fdecl] - (assert-valid-fdecl fdecl) - (let [asig - (fn [fdecl] - (let [arglist (first fdecl) - ;elide implicit macro args - arglist (if (clojure.lang.Util/equals '&form (first arglist)) - (clojure.lang.RT/subvec arglist 2 (clojure.lang.RT/count arglist)) - arglist) - body (next fdecl)] - (if (map? (first body)) - (if (next body) - (with-meta arglist (conj (if (meta arglist) (meta arglist) {}) (first body))) - arglist) - arglist))) - resolve-tag (fn [argvec] - (let [m (meta argvec) - ^clojure.lang.Symbol tag (:tag m)] - (if (instance? clojure.lang.Symbol tag) - (if (clojure.lang.Util/equiv (.IndexOf (.Name tag) ".") -1) ;;; .indexOf .getName - (if (clojure.lang.Util/equals nil (clojure.lang.CljCompiler.Ast.HostExpr/maybeSpecialTag tag)) ;;; clojure.lang.Compiler$HostExpr - (let [c (clojure.lang.CljCompiler.Ast.HostExpr/MaybeType tag false)] ;;; clojure.lang.Compiler$HostExpr maybeClass - (if c - (with-meta argvec (assoc m :tag (clojure.lang.Symbol/intern (.Name c)))) ;;; .getName - argvec)) - argvec) - argvec) - argvec)))] - (if (seq? (first fdecl)) - (loop [ret [] fdecls fdecl] - (if fdecls - (recur (conj ret (resolve-tag (asig (first fdecls)))) (next fdecls)) - (seq ret))) - (list (resolve-tag (asig fdecl))))))) - - -(def - ^{:arglists '([coll]) - :doc "Return the last item in coll, in linear time" - :added "1.0" - :static true} - last (fn ^:static last [s] - (if (next s) - (recur (next s)) - (first s)))) - -(def - ^{:arglists '([coll]) - :doc "Return a seq of all but the last item in coll, in linear time" - :added "1.0" - :static true} - butlast (fn ^:static butlast [s] - (loop [ret [] s s] - (if (next s) - (recur (conj ret (first s)) (next s)) - (seq ret))))) - -(def - - ^{:doc "Same as (def name (fn [params* ] exprs*)) or (def - name (fn ([params* ] exprs*)+)) with any doc-string or attrs added - to the var metadata. prepost-map defines a map with optional keys - :pre and :post that contain collections of pre or post conditions." - :arglists '([name doc-string? attr-map? [params*] prepost-map? body] - [name doc-string? attr-map? ([params*] prepost-map? body)+ attr-map?]) :dynamic true ;;; ADDED :dynamic true -- eventually replace with :redef - :added "1.0"} - defn (fn defn [&form &env name & fdecl] - ;; Note: Cannot delegate this check to def because of the call to (with-meta name ..) - (if (instance? clojure.lang.Symbol name) - nil - (throw (ArgumentException. "First argument to defn must be a symbol"))) ;;; IllegalArgumentException - (let [m (if (string? (first fdecl)) - {:doc (first fdecl)} - {}) - fdecl (if (string? (first fdecl)) - (next fdecl) - fdecl) - m (if (map? (first fdecl)) - (conj m (first fdecl)) - m) - fdecl (if (map? (first fdecl)) - (next fdecl) - fdecl) - fdecl (if (vector? (first fdecl)) - (list fdecl) - fdecl) - m (if (map? (last fdecl)) - (conj m (last fdecl)) - m) - fdecl (if (map? (last fdecl)) - (butlast fdecl) - fdecl) - m (conj {:arglists (list 'quote (sigs fdecl))} m) - m (let [inline (:inline m) - ifn (first inline) - iname (second inline)] - ;; same as: (if (and (= 'fn ifn) (not (symbol? iname))) ...) - (if (if (clojure.lang.Util/equiv 'fn ifn) - (if (instance? clojure.lang.Symbol iname) false true)) - ;; inserts the same fn name to the inline fn if it does not have one - (assoc m :inline (cons ifn (cons (clojure.lang.Symbol/intern (String/Concat (.Name ^clojure.lang.Symbol name) "__inliner")) ;;; .concat .getName - (next inline)))) - m)) - m (conj (if (meta name) (meta name) {}) m)] - (list 'def (with-meta name m) - ;;todo - restore propagation of fn name - ;;must figure out how to convey primitive hints to self calls first - ;;(cons `fn fdecl) - (with-meta (cons `fn fdecl) {:rettag (:tag m)}))))) - -(. (var defn) (setMacro)) - -(defn to-array - "Returns an array of Objects containing the contents of coll, which - can be any Collection. Maps to java.util.Collection.toArray()." - {:tag "System.Object[]" ;;;{:tag "[Ljava.lang.Object;"} - :added "1.0" - :static true} - [coll] (. clojure.lang.RT (toArray coll))) -;;; Not the same as the Java version, but good enough? -(defn cast - "Throws a ClassCastException if x is not a c, else returns x." - {:added "1.0" - :static true} - [^Type c x] ;;; changed Class to Type - (if (clojure.lang.Util/identical x nil) nil (if (. c (IsInstanceOfType x)) x (throw (InvalidCastException. (.ToString (.GetType x))))))) ;;; original (. c (cast x))) - -(defn vector - "Creates a new vector containing the args." - {:added "1.0" - :static true} - ([] []) - ([a] [a]) - ([a b] [a b]) - ([a b c] [a b c]) - ([a b c d] [a b c d]) - ([a b c d e] [a b c d e]) - ([a b c d e f] [a b c d e f]) - ([a b c d e f & args] - (. clojure.lang.LazilyPersistentVector (create (cons a (cons b (cons c (cons d (cons e (cons f args)))))))))) - -(defn vec - "Creates a new vector containing the contents of coll. Java arrays - will be aliased and should not be modified." - {:added "1.0" - :static true} - ([coll] - (if (vector? coll) - (if (instance? clojure.lang.IObj coll) - (with-meta coll nil) - (clojure.lang.LazilyPersistentVector/create coll)) - (clojure.lang.LazilyPersistentVector/create coll)))) - -(defn hash-map - "keyval => key val - Returns a new hash map with supplied mappings. If any keys are - equal, they are handled as if by repeated uses of assoc." - {:added "1.0" - :static true} - ([] {}) - ([& keyvals] - (. clojure.lang.PersistentHashMap (create keyvals)))) - -(defn hash-set - "Returns a new hash set with supplied keys. Any equal keys are - handled as if by repeated uses of conj." - {:added "1.0" - :static true} - ([] #{}) - ([& keys] - (clojure.lang.PersistentHashSet/create keys))) - -(defn sorted-map - "keyval => key val - Returns a new sorted map with supplied mappings. If any keys are - equal, they are handled as if by repeated uses of assoc." - {:added "1.0" - :static true} - ([] clojure.lang.PersistentTreeMap/EMPTY) ;;; I HAD TO ADD THIS EXTRA CASE TO AVOID AMBIGUOUS CALL TO CREATE WITH NULL - ([& keyvals] (. clojure.lang.PersistentTreeMap (create keyvals)))) - -(defn sorted-map-by - "keyval => key val - Returns a new sorted map with supplied mappings, using the supplied - comparator. If any keys are equal, they are handled as if by - repeated uses of assoc." - {:added "1.0" - :static true} - ([comparator & keyvals] - (clojure.lang.PersistentTreeMap/create comparator keyvals))) - -(defn sorted-set - "Returns a new sorted set with supplied keys. Any equal keys are - handled as if by repeated uses of conj." - {:added "1.0" - :static true} - ([] clojure.lang.PersistentTreeSet/EMPTY) ;;; I HAD TO ADD THIS EXTRA CASE TO AVOID AMBIGUOUS CALL TO CREATE WITH NULL - ([& keys] (clojure.lang.PersistentTreeSet/create keys))) - -(defn sorted-set-by - "Returns a new sorted set with supplied keys, using the supplied - comparator. Any equal keys are handled as if by repeated uses of - conj." - {:added "1.1" - :static true} - ([comparator & keys] - (clojure.lang.PersistentTreeSet/create comparator keys))) - - -;;;;;;;;;;;;;;;;;;;; -(defn nil? - "Returns true if x is nil, false otherwise." - {:tag Boolean - :added "1.0" - :static true - :inline (fn [x] (list 'clojure.lang.Util/identical x nil))} - [x] (clojure.lang.Util/identical x nil)) - -(def - - ^{:doc "Like defn, but the resulting function name is declared as a - macro and will be used as a macro by the compiler when it is - called." - :arglists '([name doc-string? attr-map? [params*] body] - [name doc-string? attr-map? ([params*] body)+ attr-map?]) - :added "1.0"} - defmacro (fn [&form &env - name & args] - (let [prefix (loop [p (list name) args args] - (let [f (first args)] - (if (string? f) - (recur (cons f p) (next args)) - (if (map? f) - (recur (cons f p) (next args)) - p)))) - fdecl (loop [fd args] - (if (string? (first fd)) - (recur (next fd)) - (if (map? (first fd)) - (recur (next fd)) - fd))) - fdecl (if (vector? (first fdecl)) - (list fdecl) - fdecl) - add-implicit-args (fn [fd] - (let [args (first fd)] - (cons (vec (cons '&form (cons '&env args))) (next fd)))) - add-args (fn [acc ds] - (if (nil? ds) - acc - (let [d (first ds)] - (if (map? d) - (conj acc d) - (recur (conj acc (add-implicit-args d)) (next ds)))))) - fdecl (seq (add-args [] fdecl)) - decl (loop [p prefix d fdecl] - (if p - (recur (next p) (cons (first p) d)) - d))] - (list 'do - (cons `defn decl) - (list '. (list 'var name) '(setMacro)) - (list 'var name))))) - - -(. (var defmacro) (setMacro)) - -(defmacro when - "Evaluates test. If logical true, evaluates body in an implicit do." - {:added "1.0"} - [test & body] - (list 'if test (cons 'do body))) - -(defmacro when-not - "Evaluates test. If logical false, evaluates body in an implicit do." - {:added "1.0"} - [test & body] - (list 'if test nil (cons 'do body))) - -(defn false? - "Returns true if x is the value false, false otherwise." - {:tag Boolean - :added "1.0" - :static true} - [x] (clojure.lang.Util/identical x false)) - -(defn true? - "Returns true if x is the value true, false otherwise." - {:tag Boolean - :added "1.0" - :static true} - [x] (clojure.lang.Util/identical x true)) - -(defn boolean? - "Return true if x is a Boolean" - {:added "1.9"} - [x] (instance? Boolean x)) - - (defn not - "Returns true if x is logical false, false otherwise." - {:tag Boolean - :added "1.0" - :static true} - [x] (if x false true)) - -(defn some? - "Returns true if x is not nil, false otherwise." - {:tag Boolean - :added "1.6" - :static true} - [x] (not (nil? x))) - -(defn any? - "Returns true given any argument." - {:tag Boolean - :added "1.9"} - [x] true) - -(defn str - "With no args, returns the empty string. With one arg x, returns - x.toString(). (str nil) returns the empty string. With more than - one arg, returns the concatenation of the str values of the args." - {:tag String - :added "1.0" - :static true} - (^String [] "") - (^String [^Object x] - (if (nil? x) "" (clojure.lang.RT/CultureToString x))) ;;;(if (nil? x) "" (. x (toString)))) ;; java: toString - (^String [x & ys] - ((fn [^StringBuilder sb more] - (if more - (recur (. sb (Append (str (first more)))) (next more)) ;; java: append - (str sb))) - (new StringBuilder (str x)) ys))) - - -(defn symbol? - "Return true if x is a Symbol" - {:added "1.0" - :static true} - [x] (instance? clojure.lang.Symbol x)) - -(defn keyword? - "Return true if x is a Keyword" - {:added "1.0" - :static true} - [x] (instance? clojure.lang.Keyword x)) - -(defmacro cond - "Takes a set of test/expr pairs. It evaluates each test one at a - time. If a test returns logical true, cond evaluates and returns - the value of the corresponding expr and doesn't evaluate any of the - other tests or exprs. (cond) returns nil." - {:added "1.0"} - [& clauses] - (when clauses - (list 'if (first clauses) +; 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. + +(ns ^{:doc "The core Clojure language." + :author "Rich Hickey"} + clojure.core) + +(def unquote) +(def unquote-splicing) + +(def + ^{:arglists '([& items]) + :doc "Creates a new list containing the items." + :added "1.0"} + list (. clojure.lang.PersistentList creator)) + +(def + ^{:arglists '([x seq]) + :doc "Returns a new seq where x is the first element and seq is + the rest." + :added "1.0" + :static true} + + cons (fn* ^:static cons [x seq] (. clojure.lang.RT (cons x seq)))) + + ;during bootstrap we don't have destructuring let, loop or fn, will redefine later +(def + ^{:macro true :redef true + :added "1.0"} + let (fn* let [&form &env & decl] (cons 'let* decl))) + +(def + ^{:macro true :redef true + :added "1.0"} + loop (fn* loop [&form &env & decl] (cons 'loop* decl))) + + (def + ^{:macro true :redef true + :added "1.0"} + fn (fn* fn [&form &env & decl] + (.withMeta ^clojure.lang.IObj (cons 'fn* decl) + (.meta ^clojure.lang.IMeta &form)))) + +(def + ^{:arglists '([coll]) + :doc "Returns the first item in the collection. Calls seq on its + argument. If coll is nil, returns nil." + :added "1.0" + :static true} + first (fn ^:static first [coll] (. clojure.lang.RT (first coll)))) + +(def + ^{:arglists '([coll]) + :tag clojure.lang.ISeq + :doc "Returns a seq of the items after the first. Calls seq on its + argument. If there are no more items, returns nil." + :added "1.0" + :static true} + next (fn ^:static next [x] (. clojure.lang.RT (next x)))) + +(def + ^{:arglists '([coll]) + :tag clojure.lang.ISeq + :doc "Returns a possibly empty seq of the items after the first. Calls seq on its + argument." + :added "1.0" + :static true} + rest (fn ^:static rest [x] (. clojure.lang.RT (more x)))) + +(def + ^{:arglists '([] [coll] [coll x] [coll x & xs]) + :doc "conj[oin]. Returns a new collection with the xs + 'added'. (conj nil item) returns (item). + (conj coll) returns coll. (conj) returns []. + The 'addition' may happen at different 'places' depending + on the concrete type." + :added "1.0" + :static true} + conj (fn ^:static conj + ([] []) + ([coll] coll) + ([coll x] (clojure.lang.RT/conj coll x)) + ([coll x & xs] + (if xs + (recur (clojure.lang.RT/conj coll x) (first xs) (next xs)) + (clojure.lang.RT/conj coll x))))) + +(def + ^{:doc "Same as (first (next x))" + :arglists '([x]) + :added "1.0" + :static true} + second (fn ^:static second [x] (first (next x)))) + +(def + ^{:doc "Same as (first (first x))" + :arglists '([x]) + :added "1.0" + :static true} + ffirst (fn ^:static ffirst [x] (first (first x)))) + +(def + ^{:doc "Same as (next(first x))" + :arglists '([x]) + :added "1.0" + :static true} + nfirst (fn ^:static nfirst [x] (next (first x)))) + +(def + ^{:doc "Same as (first (next x))" + :arglists '([x]) + :added "1.0" + :static true} + fnext (fn ^:static fnext [x] (first (next x)))) + +(def + ^{:doc "Same as (next (next x))" + :arglists '([x]) + :added "1.0" + :static true} + nnext (fn ^:static nnext [x] (next (next x)))) + +(def + ^{:arglists '(^clojure.lang.ISeq [coll]) + :doc "Returns a seq on the collection. If the collection is + empty, returns nil. (seq nil) returns nil. seq also works on + Strings, native Java arrays (of reference types) and any objects + that implement Iterable. Note that seqs cache values, thus seq + should not be used on any Iterable whose iterator repeatedly + returns the same mutable object." + :tag clojure.lang.ISeq + :added "1.0" + :static true} + seq (fn ^:static seq [coll] (. clojure.lang.RT (seq coll)))) + +(def + ^{:arglists '([^Type c x]) ;;; Class + :doc "Evaluates x and tests if it is an instance of the class + c. Returns true or false" + :added "1.0"} + instance? (fn instance? [^Type c x] (. c (IsInstanceOfType x)))) ;;; Class isInstanceOfTYpe + +(def + ^{:arglists '([x]) + :doc "Return true if x implements ISeq" + :added "1.0" + :static true} + seq? (fn ^:static seq? [x] (instance? clojure.lang.ISeq x))) + +(def + ^{:arglists '([x]) + :doc "Return true if x is a Character" + :added "1.0" + :static true} + char? (fn ^:static char? [x] (instance? Char x))) ;;; Character + +(def + ^{:arglists '([x]) + :doc "Return true if x is a String" + :added "1.0" + :static true} + string? (fn ^:static string? [x] (instance? String x))) + +(def + ^{:arglists '([x]) + :doc "Return true if x implements IPersistentMap" + :added "1.0" + :static true} + map? (fn ^:static map? [x] (instance? clojure.lang.IPersistentMap x))) + +(def + ^{:arglists '([x]) + :doc "Return true if x implements IPersistentVector " + :added "1.0" + :static true} + vector? (fn ^:static vector? [x] (instance? clojure.lang.IPersistentVector x))) + +(def + ^{:arglists '([map key val] [map key val & kvs]) + :doc "assoc[iate]. When applied to a map, returns a new map of the + same (hashed/sorted) type, that contains the mapping of key(s) to + val(s). When applied to a vector, returns a new vector that + contains val at index. Note - index must be <= (count vector)." + :added "1.0" + :static true} + assoc + (fn ^:static assoc + ([map key val] (clojure.lang.RT/assoc map key val)) + ([map key val & kvs] + (let [ret (clojure.lang.RT/assoc map key val)] + (if kvs + (if (next kvs) + (recur ret (first kvs) (second kvs) (nnext kvs)) + (throw (ArgumentException. ;;; IllegalArgumentException + "assoc expects even number of arguments after map/vector, found odd number"))) + ret))))) + +;;;;;;;;;;;;;;;;; metadata ;;;;;;;;;;;;;;;;;;;;;;;;;;; +(def + ^{:arglists '([obj]) + :doc "Returns the metadata of obj, returns nil if there is no metadata." + :added "1.0" + :static true} + meta (fn ^:static meta [x] + (if (instance? clojure.lang.IMeta x) + (. ^clojure.lang.IMeta x (meta))))) + +(def + ^{:arglists '([^clojure.lang.IObj obj m]) + :doc "Returns an object of the same type and value as obj, with + map m as its metadata." + :added "1.0" + :static true} + with-meta (fn ^:static with-meta [^clojure.lang.IObj x m] + (. x (withMeta m)))) + +(def ^{:private true :dynamic true} + assert-valid-fdecl (fn [fdecl])) + +(def + ^{:private true} + sigs + (fn [fdecl] + (assert-valid-fdecl fdecl) + (let [asig + (fn [fdecl] + (let [arglist (first fdecl) + ;elide implicit macro args + arglist (if (clojure.lang.Util/equals '&form (first arglist)) + (clojure.lang.RT/subvec arglist 2 (clojure.lang.RT/count arglist)) + arglist) + body (next fdecl)] + (if (map? (first body)) + (if (next body) + (with-meta arglist (conj (if (meta arglist) (meta arglist) {}) (first body))) + arglist) + arglist))) + resolve-tag (fn [argvec] + (let [m (meta argvec) + ^clojure.lang.Symbol tag (:tag m)] + (if (instance? clojure.lang.Symbol tag) + (if (clojure.lang.Util/equiv (.IndexOf (.Name tag) ".") -1) ;;; .indexOf .getName + (if (clojure.lang.Util/equals nil (clojure.lang.CljCompiler.Ast.HostExpr/maybeSpecialTag tag)) ;;; clojure.lang.Compiler$HostExpr + (let [c (clojure.lang.CljCompiler.Ast.HostExpr/MaybeType tag false)] ;;; clojure.lang.Compiler$HostExpr maybeClass + (if c + (with-meta argvec (assoc m :tag (clojure.lang.Symbol/intern (.Name c)))) ;;; .getName + argvec)) + argvec) + argvec) + argvec)))] + (if (seq? (first fdecl)) + (loop [ret [] fdecls fdecl] + (if fdecls + (recur (conj ret (resolve-tag (asig (first fdecls)))) (next fdecls)) + (seq ret))) + (list (resolve-tag (asig fdecl))))))) + + +(def + ^{:arglists '([coll]) + :doc "Return the last item in coll, in linear time" + :added "1.0" + :static true} + last (fn ^:static last [s] + (if (next s) + (recur (next s)) + (first s)))) + +(def + ^{:arglists '([coll]) + :doc "Return a seq of all but the last item in coll, in linear time" + :added "1.0" + :static true} + butlast (fn ^:static butlast [s] + (loop [ret [] s s] + (if (next s) + (recur (conj ret (first s)) (next s)) + (seq ret))))) + +(def + + ^{:doc "Same as (def name (fn [params* ] exprs*)) or (def + name (fn ([params* ] exprs*)+)) with any doc-string or attrs added + to the var metadata. prepost-map defines a map with optional keys + :pre and :post that contain collections of pre or post conditions." + :arglists '([name doc-string? attr-map? [params*] prepost-map? body] + [name doc-string? attr-map? ([params*] prepost-map? body)+ attr-map?]) :dynamic true ;;; ADDED :dynamic true -- eventually replace with :redef + :added "1.0"} + defn (fn defn [&form &env name & fdecl] + ;; Note: Cannot delegate this check to def because of the call to (with-meta name ..) + (if (instance? clojure.lang.Symbol name) + nil + (throw (ArgumentException. "First argument to defn must be a symbol"))) ;;; IllegalArgumentException + (let [m (if (string? (first fdecl)) + {:doc (first fdecl)} + {}) + fdecl (if (string? (first fdecl)) + (next fdecl) + fdecl) + m (if (map? (first fdecl)) + (conj m (first fdecl)) + m) + fdecl (if (map? (first fdecl)) + (next fdecl) + fdecl) + fdecl (if (vector? (first fdecl)) + (list fdecl) + fdecl) + m (if (map? (last fdecl)) + (conj m (last fdecl)) + m) + fdecl (if (map? (last fdecl)) + (butlast fdecl) + fdecl) + m (conj {:arglists (list 'quote (sigs fdecl))} m) + m (let [inline (:inline m) + ifn (first inline) + iname (second inline)] + ;; same as: (if (and (= 'fn ifn) (not (symbol? iname))) ...) + (if (if (clojure.lang.Util/equiv 'fn ifn) + (if (instance? clojure.lang.Symbol iname) false true)) + ;; inserts the same fn name to the inline fn if it does not have one + (assoc m :inline (cons ifn (cons (clojure.lang.Symbol/intern (String/Concat (.Name ^clojure.lang.Symbol name) "__inliner")) ;;; .concat .getName + (next inline)))) + m)) + m (conj (if (meta name) (meta name) {}) m)] + (list 'def (with-meta name m) + ;;todo - restore propagation of fn name + ;;must figure out how to convey primitive hints to self calls first + ;;(cons `fn fdecl) + (with-meta (cons `fn fdecl) {:rettag (:tag m)}))))) + +(. (var defn) (setMacro)) + +(defn to-array + "Returns an array of Objects containing the contents of coll, which + can be any Collection. Maps to java.util.Collection.toArray()." + {:tag "System.Object[]" ;;;{:tag "[Ljava.lang.Object;"} + :added "1.0" + :static true} + [coll] (. clojure.lang.RT (toArray coll))) +;;; Not the same as the Java version, but good enough? +(defn cast + "Throws a ClassCastException if x is not a c, else returns x." + {:added "1.0" + :static true} + [^Type c x] ;;; changed Class to Type + (if (clojure.lang.Util/identical x nil) nil (if (. c (IsInstanceOfType x)) x (throw (InvalidCastException. (.ToString (.GetType x))))))) ;;; original (. c (cast x))) + +(defn vector + "Creates a new vector containing the args." + {:added "1.0" + :static true} + ([] []) + ([a] [a]) + ([a b] [a b]) + ([a b c] [a b c]) + ([a b c d] [a b c d]) + ([a b c d e] [a b c d e]) + ([a b c d e f] [a b c d e f]) + ([a b c d e f & args] + (. clojure.lang.LazilyPersistentVector (create (cons a (cons b (cons c (cons d (cons e (cons f args)))))))))) + +(defn vec + "Creates a new vector containing the contents of coll. Java arrays + will be aliased and should not be modified." + {:added "1.0" + :static true} + ([coll] + (if (vector? coll) + (if (instance? clojure.lang.IObj coll) + (with-meta coll nil) + (clojure.lang.LazilyPersistentVector/create coll)) + (clojure.lang.LazilyPersistentVector/create coll)))) + +(defn hash-map + "keyval => key val + Returns a new hash map with supplied mappings. If any keys are + equal, they are handled as if by repeated uses of assoc." + {:added "1.0" + :static true} + ([] {}) + ([& keyvals] + (. clojure.lang.PersistentHashMap (create keyvals)))) + +(defn hash-set + "Returns a new hash set with supplied keys. Any equal keys are + handled as if by repeated uses of conj." + {:added "1.0" + :static true} + ([] #{}) + ([& keys] + (clojure.lang.PersistentHashSet/create keys))) + +(defn sorted-map + "keyval => key val + Returns a new sorted map with supplied mappings. If any keys are + equal, they are handled as if by repeated uses of assoc." + {:added "1.0" + :static true} + ([] clojure.lang.PersistentTreeMap/EMPTY) ;;; I HAD TO ADD THIS EXTRA CASE TO AVOID AMBIGUOUS CALL TO CREATE WITH NULL + ([& keyvals] (. clojure.lang.PersistentTreeMap (create keyvals)))) + +(defn sorted-map-by + "keyval => key val + Returns a new sorted map with supplied mappings, using the supplied + comparator. If any keys are equal, they are handled as if by + repeated uses of assoc." + {:added "1.0" + :static true} + ([comparator & keyvals] + (clojure.lang.PersistentTreeMap/create comparator keyvals))) + +(defn sorted-set + "Returns a new sorted set with supplied keys. Any equal keys are + handled as if by repeated uses of conj." + {:added "1.0" + :static true} + ([] clojure.lang.PersistentTreeSet/EMPTY) ;;; I HAD TO ADD THIS EXTRA CASE TO AVOID AMBIGUOUS CALL TO CREATE WITH NULL + ([& keys] (clojure.lang.PersistentTreeSet/create keys))) + +(defn sorted-set-by + "Returns a new sorted set with supplied keys, using the supplied + comparator. Any equal keys are handled as if by repeated uses of + conj." + {:added "1.1" + :static true} + ([comparator & keys] + (clojure.lang.PersistentTreeSet/create comparator keys))) + + +;;;;;;;;;;;;;;;;;;;; +(defn nil? + "Returns true if x is nil, false otherwise." + {:tag Boolean + :added "1.0" + :static true + :inline (fn [x] (list 'clojure.lang.Util/identical x nil))} + [x] (clojure.lang.Util/identical x nil)) + +(def + + ^{:doc "Like defn, but the resulting function name is declared as a + macro and will be used as a macro by the compiler when it is + called." + :arglists '([name doc-string? attr-map? [params*] body] + [name doc-string? attr-map? ([params*] body)+ attr-map?]) + :added "1.0"} + defmacro (fn [&form &env + name & args] + (let [prefix (loop [p (list name) args args] + (let [f (first args)] + (if (string? f) + (recur (cons f p) (next args)) + (if (map? f) + (recur (cons f p) (next args)) + p)))) + fdecl (loop [fd args] + (if (string? (first fd)) + (recur (next fd)) + (if (map? (first fd)) + (recur (next fd)) + fd))) + fdecl (if (vector? (first fdecl)) + (list fdecl) + fdecl) + add-implicit-args (fn [fd] + (let [args (first fd)] + (cons (vec (cons '&form (cons '&env args))) (next fd)))) + add-args (fn [acc ds] + (if (nil? ds) + acc + (let [d (first ds)] + (if (map? d) + (conj acc d) + (recur (conj acc (add-implicit-args d)) (next ds)))))) + fdecl (seq (add-args [] fdecl)) + decl (loop [p prefix d fdecl] + (if p + (recur (next p) (cons (first p) d)) + d))] + (list 'do + (cons `defn decl) + (list '. (list 'var name) '(setMacro)) + (list 'var name))))) + + +(. (var defmacro) (setMacro)) + +(defmacro when + "Evaluates test. If logical true, evaluates body in an implicit do." + {:added "1.0"} + [test & body] + (list 'if test (cons 'do body))) + +(defmacro when-not + "Evaluates test. If logical false, evaluates body in an implicit do." + {:added "1.0"} + [test & body] + (list 'if test nil (cons 'do body))) + +(defn false? + "Returns true if x is the value false, false otherwise." + {:tag Boolean + :added "1.0" + :static true} + [x] (clojure.lang.Util/identical x false)) + +(defn true? + "Returns true if x is the value true, false otherwise." + {:tag Boolean + :added "1.0" + :static true} + [x] (clojure.lang.Util/identical x true)) + +(defn boolean? + "Return true if x is a Boolean" + {:added "1.9"} + [x] (instance? Boolean x)) + + (defn not + "Returns true if x is logical false, false otherwise." + {:tag Boolean + :added "1.0" + :static true} + [x] (if x false true)) + +(defn some? + "Returns true if x is not nil, false otherwise." + {:tag Boolean + :added "1.6" + :static true} + [x] (not (nil? x))) + +(defn any? + "Returns true given any argument." + {:tag Boolean + :added "1.9"} + [x] true) + +(defn str + "With no args, returns the empty string. With one arg x, returns + x.toString(). (str nil) returns the empty string. With more than + one arg, returns the concatenation of the str values of the args." + {:tag String + :added "1.0" + :static true} + (^String [] "") + (^String [^Object x] + (if (nil? x) "" (clojure.lang.RT/CultureToString x))) ;;;(if (nil? x) "" (. x (toString)))) ;; java: toString + (^String [x & ys] + ((fn [^StringBuilder sb more] + (if more + (recur (. sb (Append (str (first more)))) (next more)) ;; java: append + (str sb))) + (new StringBuilder (str x)) ys))) + + +(defn symbol? + "Return true if x is a Symbol" + {:added "1.0" + :static true} + [x] (instance? clojure.lang.Symbol x)) + +(defn keyword? + "Return true if x is a Keyword" + {:added "1.0" + :static true} + [x] (instance? clojure.lang.Keyword x)) + +(defmacro cond + "Takes a set of test/expr pairs. It evaluates each test one at a + time. If a test returns logical true, cond evaluates and returns + the value of the corresponding expr and doesn't evaluate any of the + other tests or exprs. (cond) returns nil." + {:added "1.0"} + [& clauses] + (when clauses + (list 'if (first clauses) (if (next clauses) (second clauses) (throw (ArgumentException. ;;;IllegalArgumentException. "cond requires an even number of forms"))) - (cons 'clojure.core/cond (next (next clauses)))))) - -(defn symbol - "Returns a Symbol with the given namespace and name. Arity-1 works - on strings, keywords, and vars." - {:tag clojure.lang.Symbol - :added "1.0" - :static true} - ([name] - (cond - (symbol? name) name - (instance? String name) (clojure.lang.Symbol/intern name) - (instance? clojure.lang.Var name) (.ToSymbol ^clojure.lang.Var name) ;;; .toSymbol - (instance? clojure.lang.Keyword name) (.Symbol ^clojure.lang.Keyword name) ;;; .sym - :else (throw (ArgumentException. "no conversion to symbol")))) ;;; IllegalArgumentException. - ([ns name] (clojure.lang.Symbol/intern ns name))) - -(defn gensym - "Returns a new symbol with a unique name. If a prefix string is - supplied, the name is prefix# where # is some unique number. If - prefix is not supplied, the prefix is 'G__'." - {:added "1.0" - :static true} - ([] (gensym "G__")) - ([prefix-string] (. clojure.lang.Symbol (intern (str prefix-string (str (. clojure.lang.RT (nextID)))))))) - - -(defn keyword - "Returns a Keyword with the given namespace and name. Do not use : - in the keyword strings, it will be added automatically." - {:tag clojure.lang.Keyword - :added "1.0" - :static true} - ([name] (cond (keyword? name) name - (symbol? name) (clojure.lang.Keyword/intern ^clojure.lang.Symbol name) - (string? name) (clojure.lang.Keyword/intern ^String name))) - ([ns name] (clojure.lang.Keyword/intern ns name))) - -(defn find-keyword - "Returns a Keyword with the given namespace and name if one already - exists. This function will not intern a new keyword. If the keyword - has not already been interned, it will return nil. Do not use : - in the keyword strings, it will be added automatically." - {:tag clojure.lang.Keyword - :added "1.3" - :static true} - ([name] (cond (keyword? name) name - (symbol? name) (clojure.lang.Keyword/find ^clojure.lang.Symbol name) - (string? name) (clojure.lang.Keyword/find ^String name))) - ([ns name] (clojure.lang.Keyword/find ns name))) - - -(defn spread - {:private true - :static true} - [arglist] - (cond - (nil? arglist) nil - (nil? (next arglist)) (seq (first arglist)) - :else (cons (first arglist) (spread (next arglist))))) - -(defn list* - "Creates a new seq containing the items prepended to the rest, the - last of which will be treated as a sequence." - {:added "1.0" - :static true} - ([args] (seq args)) - ([a args] (cons a args)) - ([a b args] (cons a (cons b args))) - ([a b c args] (cons a (cons b (cons c args)))) - ([a b c d & more] - (cons a (cons b (cons c (cons d (spread more))))))) - -(defn apply - "Applies fn f to the argument list formed by prepending intervening arguments to args." - {:added "1.0" - :static true} - ([^clojure.lang.IFn f args] - (. f (applyTo (seq args)))) - ([^clojure.lang.IFn f x args] - (. f (applyTo (list* x args)))) - ([^clojure.lang.IFn f x y args] - (. f (applyTo (list* x y args)))) - ([^clojure.lang.IFn f x y z args] - (. f (applyTo (list* x y z args)))) - ([^clojure.lang.IFn f a b c d & args] + (cons 'clojure.core/cond (next (next clauses)))))) + +(defn symbol + "Returns a Symbol with the given namespace and name. Arity-1 works + on strings, keywords, and vars." + {:tag clojure.lang.Symbol + :added "1.0" + :static true} + ([name] + (cond + (symbol? name) name + (instance? String name) (clojure.lang.Symbol/intern name) + (instance? clojure.lang.Var name) (.ToSymbol ^clojure.lang.Var name) ;;; .toSymbol + (instance? clojure.lang.Keyword name) (.Symbol ^clojure.lang.Keyword name) ;;; .sym + :else (throw (ArgumentException. "no conversion to symbol")))) ;;; IllegalArgumentException. + ([ns name] (clojure.lang.Symbol/intern ns name))) + +(defn gensym + "Returns a new symbol with a unique name. If a prefix string is + supplied, the name is prefix# where # is some unique number. If + prefix is not supplied, the prefix is 'G__'." + {:added "1.0" + :static true} + ([] (gensym "G__")) + ([prefix-string] (. clojure.lang.Symbol (intern (str prefix-string (str (. clojure.lang.RT (nextID)))))))) + + +(defn keyword + "Returns a Keyword with the given namespace and name. Do not use : + in the keyword strings, it will be added automatically." + {:tag clojure.lang.Keyword + :added "1.0" + :static true} + ([name] (cond (keyword? name) name + (symbol? name) (clojure.lang.Keyword/intern ^clojure.lang.Symbol name) + (string? name) (clojure.lang.Keyword/intern ^String name))) + ([ns name] (clojure.lang.Keyword/intern ns name))) + +(defn find-keyword + "Returns a Keyword with the given namespace and name if one already + exists. This function will not intern a new keyword. If the keyword + has not already been interned, it will return nil. Do not use : + in the keyword strings, it will be added automatically." + {:tag clojure.lang.Keyword + :added "1.3" + :static true} + ([name] (cond (keyword? name) name + (symbol? name) (clojure.lang.Keyword/find ^clojure.lang.Symbol name) + (string? name) (clojure.lang.Keyword/find ^String name))) + ([ns name] (clojure.lang.Keyword/find ns name))) + + +(defn spread + {:private true + :static true} + [arglist] + (cond + (nil? arglist) nil + (nil? (next arglist)) (seq (first arglist)) + :else (cons (first arglist) (spread (next arglist))))) + +(defn list* + "Creates a new seq containing the items prepended to the rest, the + last of which will be treated as a sequence." + {:added "1.0" + :static true} + ([args] (seq args)) + ([a args] (cons a args)) + ([a b args] (cons a (cons b args))) + ([a b c args] (cons a (cons b (cons c args)))) + ([a b c d & more] + (cons a (cons b (cons c (cons d (spread more))))))) + +(defn apply + "Applies fn f to the argument list formed by prepending intervening arguments to args." + {:added "1.0" + :static true} + ([^clojure.lang.IFn f args] + (. f (applyTo (seq args)))) + ([^clojure.lang.IFn f x args] + (. f (applyTo (list* x args)))) + ([^clojure.lang.IFn f x y args] + (. f (applyTo (list* x y args)))) + ([^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))))))))) - -(defn vary-meta - "Returns an object of the same type and value as obj, with - (apply f (meta obj) args) as its metadata." - {:added "1.0" - :static true} - [obj f & args] - (with-meta obj (apply f (meta obj) args))) - -(defmacro lazy-seq - "Takes a body of expressions that returns an ISeq or nil, and yields - a Seqable object that will invoke the body only the first time seq - is called, and will cache the result and return it on all subsequent - seq calls. Se all - realized?" - {:added "1.0"} - [& body] - (list 'new 'clojure.lang.LazySeq (list* '^{:once true} fn* [] body))) - -(defn ^:static ^clojure.lang.ChunkBuffer chunk-buffer ^clojure.lang.ChunkBuffer [capacity] - (clojure.lang.ChunkBuffer. capacity)) - -(defn ^:static chunk-append [^clojure.lang.ChunkBuffer b x] - (.add b x)) - -(defn ^:static ^clojure.lang.IChunk chunk [^clojure.lang.ChunkBuffer b] - (.chunk b)) - -(defn ^:static ^clojure.lang.IChunk chunk-first ^clojure.lang.IChunk [^clojure.lang.IChunkedSeq s] - (.chunkedFirst s)) - -(defn ^:static ^clojure.lang.ISeq chunk-rest ^clojure.lang.ISeq [^clojure.lang.IChunkedSeq s] - (.chunkedMore s)) - -(defn ^:static ^clojure.lang.ISeq chunk-next ^clojure.lang.ISeq [^clojure.lang.IChunkedSeq s] - (.chunkedNext s)) - -(defn ^:static chunk-cons [chunk rest] - (if (clojure.lang.Numbers/isZero (clojure.lang.RT/count chunk)) - rest - (clojure.lang.ChunkedCons. chunk rest))) - -(defn ^:static chunked-seq? [s] - (instance? clojure.lang.IChunkedSeq s)) - -(defn concat - "Returns a lazy seq representing the concatenation of the elements in the supplied colls." - {:added "1.0" - :static true} - ([] (lazy-seq nil)) - ([x] (lazy-seq x)) - ([x y] - (lazy-seq - (let [s (seq x)] - (if s - (if (chunked-seq? s) - (chunk-cons (chunk-first s) (concat (chunk-rest s) y)) - (cons (first s) (concat (rest s) y))) - y)))) - ([x y & zs] - (let [cat (fn cat [xys zs] - (lazy-seq - (let [xys (seq xys)] - (if xys - (if (chunked-seq? xys) - (chunk-cons (chunk-first xys) - (cat (chunk-rest xys) zs)) - (cons (first xys) (cat (rest xys) zs))) - (when zs - (cat (first zs) (next zs)))))))] - (cat (concat x y) zs)))) - -;;;;;;;;;;;;;;;;at this point all the support for syntax-quote exists;;;;;;;;;;;;;;;;;;;;;; -(defmacro delay - "Takes a body of expressions and yields a Delay object than will - invoke the body only the first time it is forced (with force or deref/@), and - will cache the result and return it on all subsequent force - calls. See also - realized?" - {:added "1.0"} - [& body] - (list 'new 'clojure.lang.Delay (list* `^{:once true} fn* [] body))) - -(defn delay? - "returns true if x is a Delay created with delay" - {:added "1.0" - :static true} - [x] (instance? clojure.lang.Delay x)) - -(defn force - "If x is a Delay, returns the (possibly cached) value of its expression, else returns x" - {:added "1.0" - :static true} - [x] (. clojure.lang.Delay (force x))) - + +(defn vary-meta + "Returns an object of the same type and value as obj, with + (apply f (meta obj) args) as its metadata." + {:added "1.0" + :static true} + [obj f & args] + (with-meta obj (apply f (meta obj) args))) + +(defmacro lazy-seq + "Takes a body of expressions that returns an ISeq or nil, and yields + a Seqable object that will invoke the body only the first time seq + is called, and will cache the result and return it on all subsequent + seq calls. Se all - realized?" + {:added "1.0"} + [& body] + (list 'new 'clojure.lang.LazySeq (list* '^{:once true} fn* [] body))) + +(defn ^:static ^clojure.lang.ChunkBuffer chunk-buffer ^clojure.lang.ChunkBuffer [capacity] + (clojure.lang.ChunkBuffer. capacity)) + +(defn ^:static chunk-append [^clojure.lang.ChunkBuffer b x] + (.add b x)) + +(defn ^:static ^clojure.lang.IChunk chunk [^clojure.lang.ChunkBuffer b] + (.chunk b)) + +(defn ^:static ^clojure.lang.IChunk chunk-first ^clojure.lang.IChunk [^clojure.lang.IChunkedSeq s] + (.chunkedFirst s)) + +(defn ^:static ^clojure.lang.ISeq chunk-rest ^clojure.lang.ISeq [^clojure.lang.IChunkedSeq s] + (.chunkedMore s)) + +(defn ^:static ^clojure.lang.ISeq chunk-next ^clojure.lang.ISeq [^clojure.lang.IChunkedSeq s] + (.chunkedNext s)) + +(defn ^:static chunk-cons [chunk rest] + (if (clojure.lang.Numbers/isZero (clojure.lang.RT/count chunk)) + rest + (clojure.lang.ChunkedCons. chunk rest))) + +(defn ^:static chunked-seq? [s] + (instance? clojure.lang.IChunkedSeq s)) + +(defn concat + "Returns a lazy seq representing the concatenation of the elements in the supplied colls." + {:added "1.0" + :static true} + ([] (lazy-seq nil)) + ([x] (lazy-seq x)) + ([x y] + (lazy-seq + (let [s (seq x)] + (if s + (if (chunked-seq? s) + (chunk-cons (chunk-first s) (concat (chunk-rest s) y)) + (cons (first s) (concat (rest s) y))) + y)))) + ([x y & zs] + (let [cat (fn cat [xys zs] + (lazy-seq + (let [xys (seq xys)] + (if xys + (if (chunked-seq? xys) + (chunk-cons (chunk-first xys) + (cat (chunk-rest xys) zs)) + (cons (first xys) (cat (rest xys) zs))) + (when zs + (cat (first zs) (next zs)))))))] + (cat (concat x y) zs)))) + +;;;;;;;;;;;;;;;;at this point all the support for syntax-quote exists;;;;;;;;;;;;;;;;;;;;;; +(defmacro delay + "Takes a body of expressions and yields a Delay object than will + invoke the body only the first time it is forced (with force or deref/@), and + will cache the result and return it on all subsequent force + calls. See also - realized?" + {:added "1.0"} + [& body] + (list 'new 'clojure.lang.Delay (list* `^{:once true} fn* [] body))) + +(defn delay? + "returns true if x is a Delay created with delay" + {:added "1.0" + :static true} + [x] (instance? clojure.lang.Delay x)) + +(defn force + "If x is a Delay, returns the (possibly cached) value of its expression, else returns x" + {:added "1.0" + :static true} + [x] (. clojure.lang.Delay (force x))) + (defmacro if-not - "Evaluates test. If logical false, evaluates and returns then expr, + "Evaluates test. If logical false, evaluates and returns then expr, otherwise else expr, if supplied, else nil." - {:added "1.0"} + {:added "1.0"} ([test then] `(if-not ~test ~then nil)) ([test then else] - `(if (not ~test) ~then ~else))) - -(defn identical? - "Tests if 2 arguments are the same object" - {:inline (fn [x y] `(. clojure.lang.Util identical ~x ~y)) - :inline-arities #{2} - :added "1.0"} - ([x y] (clojure.lang.Util/identical x y))) - -; equiv-based -(defn = - "Equality. Returns true if x equals y, false if not. Same as - Java x.equals(y) except it also works for nil, and compares - numbers and collections in a type-independent manner. Clojure's immutable data - structures define equals() (and thus =) as a value, not an identity, - comparison." - {:inline (fn [x y] `(. clojure.lang.Util equiv ~x ~y)) - :inline-arities #{2} - :added "1.0"} - ([x] true) - ([x y] (clojure.lang.Util/equiv x y)) - ([x y & more] - (if (clojure.lang.Util/equiv x y) - (if (next more) - (recur y (first more) (next more)) - (clojure.lang.Util/equiv y (first more))) - false))) - -;equals-based -#_(defn = - "Equality. Returns true if x equals y, false if not. Same as Java - x.equals(y) except it also works for nil. Boxed numbers must have - same type. Clojure's immutable data structures define equals() (and - thus =) as a vlue, not an identity, comparison." - {:inline (fn [x y] `(. clojure.lang.Util equals ~x ~y)) - :inline-arities #{2} - :added "1.0"} - ([x] true) - ([x y] (clojure.lang.Util/equals x y)) - ([x y & more] - (if (= x y) - (if (next more) - (recur y (first more) (next more)) - (= y (first more))) - false))) - -(defn not= - "Same as (not (= obj1 obj2))" - {:tag Boolean - :added "1.0" - :static true} - ([x] false) - ([x y] (not (= x y))) - ([x y & more] - (not (apply = x y more)))) - - - -(defn compare - "Comparator. Returns a negative number, zero, or a positive number - when x is logically 'less than', 'equal to', or 'greater than' - y. Same as Java x.compareTo(y) except it also works for nil, and - compares numbers and collections in a type-independent manner. x - must implement Comparable" - { - :inline (fn [x y] `(. clojure.lang.Util compare ~x ~y)) - :added "1.0"} - [x y] (. clojure.lang.Util (compare x y))) - -(defmacro and - "Evaluates exprs one at a time, from left to right. If a form - returns logical false (nil or false), and returns that value and - doesn't evaluate any of the other expressions, otherwise it returns - the value of the last expr. (and) returns true." - {:added "1.0"} - ([] true) - ([x] x) - ([x & next] - `(let [and# ~x] - (if and# (and ~@next) and#)))) - -(defmacro or - "Evaluates exprs one at a time, from left to right. If a form - returns a logical true value, or returns that value and doesn't - evaluate any of the other expressions, otherwise it returns the - value of the last expression. (or) returns nil." - {:added "1.0"} - ([] nil) - ([x] x) - ([x & next] - `(let [or# ~x] - (if or# or# (or ~@next))))) - -;;;;;;;;;;;;;;;;;;; sequence fns ;;;;;;;;;;;;;;;;;;;;;;; -(defn zero? - "Returns true if num is zero, else false" - { - :inline (fn [num] `(. clojure.lang.Numbers (isZero ~num))) - :added "1.0"} - [num] (. clojure.lang.Numbers (isZero num))) - -(defn count - "Returns the number of items in the collection. (count nil) returns - 0. Also works on strings, arrays, and Java Collections and Maps" - { - :inline (fn [x] `(. clojure.lang.RT (count ~x))) - :added "1.0"} - [coll] (. clojure.lang.RT (count coll))) - -(defn int ;;; Need to make this handle args out of range - "Coerce to int" - { - :inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedIntCast 'intCast) ~x))) - :added "1.0"} - [x] (. clojure.lang.RT (intCast x))) - -(defn nth - "Returns the value at the index. get returns nil if index out of - bounds, nth throws an exception unless not-found is supplied. nth - also works for strings, Java arrays, regex Matchers and Lists, and, - in O(n) time, for sequences." - {:inline (fn [c i & nf] `(. clojure.lang.RT (nth ~c ~i ~@nf))) - :inline-arities #{2 3} - :added "1.0"} - ([coll index] (. clojure.lang.RT (nth coll index))) - ([coll index not-found] (. clojure.lang.RT (nth coll index not-found)))) - -(defn < - "Returns non-nil if nums are in monotonically increasing order, - otherwise false." - {:inline (fn [x y] `(. clojure.lang.Numbers (lt ~x ~y))) - :inline-arities #{2} - :added "1.0"} - ([x] true) - ([x y] (. clojure.lang.Numbers (lt x y))) - ([x y & more] - (if (< x y) - (if (next more) - (recur y (first more) (next more)) - (< y (first more))) - false))) - -(defn inc' - "Returns a number one greater than num. Supports arbitrary precision. - See also: inc" - {:inline (fn [x] `(. clojure.lang.Numbers (incP ~x))) - :added "1.0"} - [x] (. clojure.lang.Numbers (incP x))) - -(defn inc - "Returns a number one greater than num. Does not auto-promote - longs, will throw on overflow. See also: inc'" - {:inline (fn [x] `(. clojure.lang.Numbers (~(if *unchecked-math* 'unchecked_inc 'inc) ~x))) - :added "1.2"} - [x] (. clojure.lang.Numbers (inc x))) - -;; reduce is defined again later after InternalReduce loads -(defn ^:private ^:static - reduce1 - ([f coll] - (let [s (seq coll)] - (if s - (reduce1 f (first s) (next s)) - (f)))) - ([f val coll] - (let [s (seq coll)] - (if s - (if (chunked-seq? s) - (recur f - (.reduce (chunk-first s) f val) - (chunk-next s)) - (recur f (f val (first s)) (next s))) - val)))) - -(defn reverse - "Returns a seq of the items in coll in reverse order. Not lazy." - {:added "1.0" - :static true} - [coll] - (reduce1 conj () coll)) - -;;math stuff -(defn ^:private nary-inline - ([op] (nary-inline op op)) - ([op unchecked-op] - (fn - ([x] (let [op (if *unchecked-math* unchecked-op op)] - `(. clojure.lang.Numbers (~op ~x)))) - ([x y] (let [op (if *unchecked-math* unchecked-op op)] - `(. clojure.lang.Numbers (~op ~x ~y)))) - ([x y & more] - (let [op (if *unchecked-math* unchecked-op op)] - (reduce1 - (fn [a b] `(. clojure.lang.Numbers (~op ~a ~b))) - `(. clojure.lang.Numbers (~op ~x ~y)) more)))))) - -(defn ^:private >1? [n] (clojure.lang.Numbers/gt n 1)) -(defn ^:private >0? [n] (clojure.lang.Numbers/gt n 0)) - -(defn +' - "Returns the sum of nums. (+') returns 0. Supports arbitrary precision. - See also: +" - {:inline (nary-inline 'addP) - :inline-arities >1? - :added "1.0"} - ([] 0) - ([x] (. clojure.lang.RT (NumberCast x))) ;; (cast Number x)) - ([x y] (. clojure.lang.Numbers (addP x y))) - ([x y & more] - (reduce1 +' (+' x y) more))) - -(defn + - "Returns the sum of nums. (+) returns 0. Does not auto-promote - longs, will throw on overflow. See also: +'" - {:inline (nary-inline 'add 'unchecked_add) - :inline-arities >1? - :added "1.2"} - ([] 0) - ([x] (. clojure.lang.RT (NumberCast x))) ;;; (cast Number x)) - ([x y] (. clojure.lang.Numbers (add x y))) - ([x y & more] - (reduce1 + (+ x y) more))) - -(defn *' - "Returns the product of nums. (*') returns 1. Supports arbitrary precision. - See also: *" - {:inline (nary-inline 'multiplyP) - :inline-arities >1? - :added "1.0"} - ([] 1) - ([x] (. clojure.lang.RT (NumberCast x))) ;; (cast Number x)) - ([x y] (. clojure.lang.Numbers (multiplyP x y))) - ([x y & more] - (reduce1 *' (*' x y) more))) - -(defn * - "Returns the product of nums. (*) returns 1. Does not auto-promote - longs, will throw on overflow. See also: *'" - {:inline (nary-inline 'multiply 'unchecked_multiply) - :inline-arities >1? - :added "1.2"} - ([] 1) - ([x] (. clojure.lang.RT (NumberCast x))) ;;; (cast Number x)) - ([x y] (. clojure.lang.Numbers (multiply x y))) - ([x y & more] - (reduce1 * (* x y) more))) - -(defn / - "If no denominators are supplied, returns 1/numerator, - else returns numerator divided by all of the denominators." - {:inline (nary-inline 'divide) - :inline-arities >1? - :added "1.0"} - ([x] (/ 1 x)) - ([x y] (. clojure.lang.Numbers (divide x y))) - ([x y & more] - (reduce1 / (/ x y) more))) - -(defn -' - "If no ys are supplied, returns the negation of x, else subtracts - the ys from x and returns the result. Supports arbitrary precision. - See also: -" - {:inline (nary-inline 'minusP) - :inline-arities >0? - :added "1.0"} - ([x] (. clojure.lang.Numbers (minusP x))) - ([x y] (. clojure.lang.Numbers (minusP x y))) - ([x y & more] - (reduce1 -' (-' x y) more))) - -(defn - - "If no ys are supplied, returns the negation of x, else subtracts - the ys from x and returns the result. Does not auto-promote - longs, will throw on overflow. See also: -'" - {:inline (nary-inline 'minus 'unchecked_minus) - :inline-arities >0? - :added "1.2"} - ([x] (. clojure.lang.Numbers (minus x))) - ([x y] (. clojure.lang.Numbers (minus x y))) - ([x y & more] - (reduce1 - (- x y) more))) - -(defn <= - "Returns non-nil if nums are in monotonically non-decreasing order, - otherwise false." - {:inline (fn [x y] `(. clojure.lang.Numbers (lte ~x ~y))) - :inline-arities #{2} - :added "1.0"} - ([x] true) - ([x y] (. clojure.lang.Numbers (lte x y))) - ([x y & more] - (if (<= x y) - (if (next more) - (recur y (first more) (next more)) - (<= y (first more))) - false))) - -(defn > - "Returns non-nil if nums are in monotonically decreasing order, - otherwise false." - {:inline (fn [x y] `(. clojure.lang.Numbers (gt ~x ~y))) - :inline-arities #{2} - :added "1.0"} - ([x] true) - ([x y] (. clojure.lang.Numbers (gt x y))) - ([x y & more] - (if (> x y) - (if (next more) - (recur y (first more) (next more)) - (> y (first more))) - false))) - -(defn >= - "Returns non-nil if nums are in monotonically non-increasing order, - otherwise false." - {:inline (fn [x y] `(. clojure.lang.Numbers (gte ~x ~y))) - :inline-arities #{2} - :added "1.0"} - ([x] true) - ([x y] (. clojure.lang.Numbers (gte x y))) - ([x y & more] - (if (>= x y) - (if (next more) - (recur y (first more) (next more)) - (>= y (first more))) - false))) - -(defn == - "Returns non-nil if nums all have the equivalent - value (type-independent), otherwise false" - {:inline (fn [x y] `(. clojure.lang.Numbers (equiv ~x ~y))) - :inline-arities #{2} - :added "1.0"} - ([x] true) - ([x y] (. clojure.lang.Numbers (equiv x y))) - ([x y & more] - (if (== x y) - (if (next more) - (recur y (first more) (next more)) - (== y (first more))) - false))) - -(defn max - "Returns the greatest of the nums." - {:added "1.0" - :inline-arities >1? - :inline (nary-inline 'max)} - ([x] x) - ([x y] (. clojure.lang.Numbers (max x y))) - ([x y & more] - (reduce1 max (max x y) more))) - -(defn min - "Returns the least of the nums." - {:added "1.0" - :inline-arities >1? - :inline (nary-inline 'min)} - ([x] x) - ([x y] (. clojure.lang.Numbers (min x y))) - ([x y & more] - (reduce1 min (min x y) more))) - -(defn abs - {:doc "Returns the absolute value of a. - If a is Long/MIN_VALUE => Long/MIN_VALUE - If a is a double and zero => +0.0 - If a is a double and ##Inf or ##-Inf => ##Inf - If a is a double and ##NaN => ##NaN" - :inline-arities #{1} - :inline (fn [a] `(clojure.lang.Numbers/abs ~a)) - :added "1.11"} - [a] - (clojure.lang.Numbers/abs a)) - -(defn dec' - "Returns a number one less than num. Supports arbitrary precision. - See also: dec" - {:inline (fn [x] `(. clojure.lang.Numbers (decP ~x))) - :added "1.0"} - [x] (. clojure.lang.Numbers (decP x))) - -(defn dec - "Returns a number one less than num. Does not auto-promote - longs, will throw on overflow. See also: dec'" - {:inline (fn [x] `(. clojure.lang.Numbers (~(if *unchecked-math* 'unchecked_dec 'dec) ~x))) - :added "1.2"} - [x] (. clojure.lang.Numbers (dec x))) - -(defn unchecked-inc-int - "Returns a number one greater than x, an int. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_int_inc ~x))) - :added "1.0"} - [x] (. clojure.lang.Numbers (unchecked_int_inc x))) - -(defn unchecked-inc - "Returns a number one greater than x, a long. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_inc ~x))) - :added "1.0"} - [x] (. clojure.lang.Numbers (unchecked_inc x))) - -(defn unchecked-dec-int - "Returns a number one less than x, an int. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_int_dec ~x))) - :added "1.0"} - [x] (. clojure.lang.Numbers (unchecked_int_dec x))) - -(defn unchecked-dec - "Returns a number one less than x, a long. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_dec ~x))) - :added "1.0"} - [x] (. clojure.lang.Numbers (unchecked_dec x))) - -(defn unchecked-negate-int - "Returns the negation of x, an int. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_int_negate ~x))) - :added "1.0"} - [x] (. clojure.lang.Numbers (unchecked_int_negate x))) - -(defn unchecked-negate - "Returns the negation of x, a long. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_minus ~x))) - :added "1.0"} - [x] (. clojure.lang.Numbers (unchecked_minus x))) - -(defn unchecked-add-int - "Returns the sum of x and y, both int. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_int_add ~x ~y))) - :added "1.0"} - [x y] (. clojure.lang.Numbers (unchecked_int_add x y))) - -(defn unchecked-add - "Returns the sum of x and y, both long. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_add ~x ~y))) - :added "1.0"} - [x y] (. clojure.lang.Numbers (unchecked_add x y))) - -(defn unchecked-subtract-int - "Returns the difference of x and y, both int. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_int_subtract ~x ~y))) - :added "1.0"} - [x y] (. clojure.lang.Numbers (unchecked_int_subtract x y))) - -(defn unchecked-subtract - "Returns the difference of x and y, both long. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_minus ~x ~y))) - :added "1.0"} - [x y] (. clojure.lang.Numbers (unchecked_minus x y))) - -(defn unchecked-multiply-int - "Returns the product of x and y, both int. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_int_multiply ~x ~y))) - :added "1.0"} - [x y] (. clojure.lang.Numbers (unchecked_int_multiply x y))) - -(defn unchecked-multiply - "Returns the product of x and y, both long. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_multiply ~x ~y))) - :added "1.0"} - [x y] (. clojure.lang.Numbers (unchecked_multiply x y))) - -(defn unchecked-divide-int - "Returns the division of x by y, both int. - Note - uses a primitive operator subject to truncation." - {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_int_divide ~x ~y))) - :added "1.0"} - [x y] (. clojure.lang.Numbers (unchecked_int_divide x y))) - -(defn unchecked-remainder-int - "Returns the remainder of division of x by y, both int. - Note - uses a primitive operator subject to truncation." - {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_int_remainder ~x ~y))) - :added "1.0"} - [x y] (. clojure.lang.Numbers (unchecked_int_remainder x y))) - -(defn pos? - "Returns true if num is greater than zero, else false" - {:tag Boolean - :inline (fn [num] `(. clojure.lang.Numbers (isPos ~num))) - :added "1.0"} - [num] (. clojure.lang.Numbers (isPos num))) - -(defn neg? - "Returns true if num is less than zero, else false" - { - :inline (fn [num] `(. clojure.lang.Numbers (isNeg ~num))) - :added "1.0"} - [num] (. clojure.lang.Numbers (isNeg num))) - -(defn quot - "quot[ient] of dividing numerator by denominator." - {:added "1.0" - :static true - :inline (fn [x y] `(. clojure.lang.Numbers (quotient ~x ~y)))} - [num div] - (. clojure.lang.Numbers (quotient num div))) - -(defn rem - "remainder of dividing numerator by denominator." - {:added "1.0" - :static true - :inline (fn [x y] `(. clojure.lang.Numbers (remainder ~x ~y)))} - [num div] - (. clojure.lang.Numbers (remainder num div))) - -(defn rationalize - "returns the rational value of num" - {:added "1.0" - :static true} - [num] - (. clojure.lang.Numbers (rationalize num))) - -;;Bit ops - -(defn bit-not - "Bitwise complement" - {:inline (fn [x] `(. clojure.lang.Numbers (not ~x))) - :added "1.0"} - [x] (. clojure.lang.Numbers not x)) - - -(defn bit-and - "Bitwise and" - {:inline (nary-inline 'and) - :inline-arities >1? - :added "1.0"} - ([x y] (. clojure.lang.Numbers and x y)) - ([x y & more] - (reduce1 bit-and (bit-and x y) more))) - -(defn bit-or - "Bitwise or" - {:inline (nary-inline 'or) - :inline-arities >1? - :added "1.0"} - ([x y] (. clojure.lang.Numbers or x y)) - ([x y & more] - (reduce1 bit-or (bit-or x y) more))) - -(defn bit-xor - "Bitwise exclusive or" - {:inline (nary-inline 'xor) - :inline-arities >1? - :added "1.0"} - ([x y] (. clojure.lang.Numbers xor x y)) - ([x y & more] - (reduce1 bit-xor (bit-xor x y) more))) - -(defn bit-and-not - "Bitwise and with complement" - {:inline (nary-inline 'andNot) - :inline-arities >1? - :added "1.0" - :static true} - ([x y] (. clojure.lang.Numbers andNot x y)) - ([x y & more] - (reduce1 bit-and-not (bit-and-not x y) more))) - - -(defn bit-clear - "Clear bit at index n" - {:added "1.0" - :static true} - [x n] (. clojure.lang.Numbers clearBit x n)) - -(defn bit-set - "Set bit at index n" - {:added "1.0" - :static true} - [x n] (. clojure.lang.Numbers setBit x n)) - -(defn bit-flip - "Flip bit at index n" - {:added "1.0 - :static true"} - [x n] (. clojure.lang.Numbers flipBit x n)) - -(defn bit-test - "Test bit at index n" - {:added "1.0" - :static true} - [x n] (. clojure.lang.Numbers testBit x n)) - - -(defn bit-shift-left - "Bitwise shift left" - {:inline (fn [x n] `(. clojure.lang.Numbers (shiftLeft ~x ~n))) - :added "1.0"} - [x n] (. clojure.lang.Numbers shiftLeft x n)) - -(defn bit-shift-right - "Bitwise shift right" - {:inline (fn [x n] `(. clojure.lang.Numbers (shiftRight ~x ~n))) - :added "1.0"} - [x n] (. clojure.lang.Numbers shiftRight x n)) - -(defn unsigned-bit-shift-right - "Bitwise shift right, without sign-extension." - {:inline (fn [x n] `(. clojure.lang.Numbers (unsignedShiftRight ~x ~n))) - :added "1.6"} - [x n] (. clojure.lang.Numbers unsignedShiftRight x n)) + `(if (not ~test) ~then ~else))) + +(defn identical? + "Tests if 2 arguments are the same object" + {:inline (fn [x y] `(. clojure.lang.Util identical ~x ~y)) + :inline-arities #{2} + :added "1.0"} + ([x y] (clojure.lang.Util/identical x y))) + +; equiv-based +(defn = + "Equality. Returns true if x equals y, false if not. Same as + Java x.equals(y) except it also works for nil, and compares + numbers and collections in a type-independent manner. Clojure's immutable data + structures define equals() (and thus =) as a value, not an identity, + comparison." + {:inline (fn [x y] `(. clojure.lang.Util equiv ~x ~y)) + :inline-arities #{2} + :added "1.0"} + ([x] true) + ([x y] (clojure.lang.Util/equiv x y)) + ([x y & more] + (if (clojure.lang.Util/equiv x y) + (if (next more) + (recur y (first more) (next more)) + (clojure.lang.Util/equiv y (first more))) + false))) + +;equals-based +#_(defn = + "Equality. Returns true if x equals y, false if not. Same as Java + x.equals(y) except it also works for nil. Boxed numbers must have + same type. Clojure's immutable data structures define equals() (and + thus =) as a vlue, not an identity, comparison." + {:inline (fn [x y] `(. clojure.lang.Util equals ~x ~y)) + :inline-arities #{2} + :added "1.0"} + ([x] true) + ([x y] (clojure.lang.Util/equals x y)) + ([x y & more] + (if (= x y) + (if (next more) + (recur y (first more) (next more)) + (= y (first more))) + false))) + +(defn not= + "Same as (not (= obj1 obj2))" + {:tag Boolean + :added "1.0" + :static true} + ([x] false) + ([x y] (not (= x y))) + ([x y & more] + (not (apply = x y more)))) + + + +(defn compare + "Comparator. Returns a negative number, zero, or a positive number + when x is logically 'less than', 'equal to', or 'greater than' + y. Same as Java x.compareTo(y) except it also works for nil, and + compares numbers and collections in a type-independent manner. x + must implement Comparable" + { + :inline (fn [x y] `(. clojure.lang.Util compare ~x ~y)) + :added "1.0"} + [x y] (. clojure.lang.Util (compare x y))) + +(defmacro and + "Evaluates exprs one at a time, from left to right. If a form + returns logical false (nil or false), and returns that value and + doesn't evaluate any of the other expressions, otherwise it returns + the value of the last expr. (and) returns true." + {:added "1.0"} + ([] true) + ([x] x) + ([x & next] + `(let [and# ~x] + (if and# (and ~@next) and#)))) + +(defmacro or + "Evaluates exprs one at a time, from left to right. If a form + returns a logical true value, or returns that value and doesn't + evaluate any of the other expressions, otherwise it returns the + value of the last expression. (or) returns nil." + {:added "1.0"} + ([] nil) + ([x] x) + ([x & next] + `(let [or# ~x] + (if or# or# (or ~@next))))) + +;;;;;;;;;;;;;;;;;;; sequence fns ;;;;;;;;;;;;;;;;;;;;;;; +(defn zero? + "Returns true if num is zero, else false" + { + :inline (fn [num] `(. clojure.lang.Numbers (isZero ~num))) + :added "1.0"} + [num] (. clojure.lang.Numbers (isZero num))) + +(defn count + "Returns the number of items in the collection. (count nil) returns + 0. Also works on strings, arrays, and Java Collections and Maps" + { + :inline (fn [x] `(. clojure.lang.RT (count ~x))) + :added "1.0"} + [coll] (. clojure.lang.RT (count coll))) + +(defn int ;;; Need to make this handle args out of range + "Coerce to int" + { + :inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedIntCast 'intCast) ~x))) + :added "1.0"} + [x] (. clojure.lang.RT (intCast x))) + +(defn nth + "Returns the value at the index. get returns nil if index out of + bounds, nth throws an exception unless not-found is supplied. nth + also works for strings, Java arrays, regex Matchers and Lists, and, + in O(n) time, for sequences." + {:inline (fn [c i & nf] `(. clojure.lang.RT (nth ~c ~i ~@nf))) + :inline-arities #{2 3} + :added "1.0"} + ([coll index] (. clojure.lang.RT (nth coll index))) + ([coll index not-found] (. clojure.lang.RT (nth coll index not-found)))) + +(defn < + "Returns non-nil if nums are in monotonically increasing order, + otherwise false." + {:inline (fn [x y] `(. clojure.lang.Numbers (lt ~x ~y))) + :inline-arities #{2} + :added "1.0"} + ([x] true) + ([x y] (. clojure.lang.Numbers (lt x y))) + ([x y & more] + (if (< x y) + (if (next more) + (recur y (first more) (next more)) + (< y (first more))) + false))) + +(defn inc' + "Returns a number one greater than num. Supports arbitrary precision. + See also: inc" + {:inline (fn [x] `(. clojure.lang.Numbers (incP ~x))) + :added "1.0"} + [x] (. clojure.lang.Numbers (incP x))) + +(defn inc + "Returns a number one greater than num. Does not auto-promote + longs, will throw on overflow. See also: inc'" + {:inline (fn [x] `(. clojure.lang.Numbers (~(if *unchecked-math* 'unchecked_inc 'inc) ~x))) + :added "1.2"} + [x] (. clojure.lang.Numbers (inc x))) + +;; reduce is defined again later after InternalReduce loads +(defn ^:private ^:static + reduce1 + ([f coll] + (let [s (seq coll)] + (if s + (reduce1 f (first s) (next s)) + (f)))) + ([f val coll] + (let [s (seq coll)] + (if s + (if (chunked-seq? s) + (recur f + (.reduce (chunk-first s) f val) + (chunk-next s)) + (recur f (f val (first s)) (next s))) + val)))) + +(defn reverse + "Returns a seq of the items in coll in reverse order. Not lazy." + {:added "1.0" + :static true} + [coll] + (reduce1 conj () coll)) + +;;math stuff +(defn ^:private nary-inline + ([op] (nary-inline op op)) + ([op unchecked-op] + (fn + ([x] (let [op (if *unchecked-math* unchecked-op op)] + `(. clojure.lang.Numbers (~op ~x)))) + ([x y] (let [op (if *unchecked-math* unchecked-op op)] + `(. clojure.lang.Numbers (~op ~x ~y)))) + ([x y & more] + (let [op (if *unchecked-math* unchecked-op op)] + (reduce1 + (fn [a b] `(. clojure.lang.Numbers (~op ~a ~b))) + `(. clojure.lang.Numbers (~op ~x ~y)) more)))))) + +(defn ^:private >1? [n] (clojure.lang.Numbers/gt n 1)) +(defn ^:private >0? [n] (clojure.lang.Numbers/gt n 0)) + +(defn +' + "Returns the sum of nums. (+') returns 0. Supports arbitrary precision. + See also: +" + {:inline (nary-inline 'addP) + :inline-arities >1? + :added "1.0"} + ([] 0) + ([x] (. clojure.lang.RT (NumberCast x))) ;; (cast Number x)) + ([x y] (. clojure.lang.Numbers (addP x y))) + ([x y & more] + (reduce1 +' (+' x y) more))) + +(defn + + "Returns the sum of nums. (+) returns 0. Does not auto-promote + longs, will throw on overflow. See also: +'" + {:inline (nary-inline 'add 'unchecked_add) + :inline-arities >1? + :added "1.2"} + ([] 0) + ([x] (. clojure.lang.RT (NumberCast x))) ;;; (cast Number x)) + ([x y] (. clojure.lang.Numbers (add x y))) + ([x y & more] + (reduce1 + (+ x y) more))) + +(defn *' + "Returns the product of nums. (*') returns 1. Supports arbitrary precision. + See also: *" + {:inline (nary-inline 'multiplyP) + :inline-arities >1? + :added "1.0"} + ([] 1) + ([x] (. clojure.lang.RT (NumberCast x))) ;; (cast Number x)) + ([x y] (. clojure.lang.Numbers (multiplyP x y))) + ([x y & more] + (reduce1 *' (*' x y) more))) + +(defn * + "Returns the product of nums. (*) returns 1. Does not auto-promote + longs, will throw on overflow. See also: *'" + {:inline (nary-inline 'multiply 'unchecked_multiply) + :inline-arities >1? + :added "1.2"} + ([] 1) + ([x] (. clojure.lang.RT (NumberCast x))) ;;; (cast Number x)) + ([x y] (. clojure.lang.Numbers (multiply x y))) + ([x y & more] + (reduce1 * (* x y) more))) + +(defn / + "If no denominators are supplied, returns 1/numerator, + else returns numerator divided by all of the denominators." + {:inline (nary-inline 'divide) + :inline-arities >1? + :added "1.0"} + ([x] (/ 1 x)) + ([x y] (. clojure.lang.Numbers (divide x y))) + ([x y & more] + (reduce1 / (/ x y) more))) + +(defn -' + "If no ys are supplied, returns the negation of x, else subtracts + the ys from x and returns the result. Supports arbitrary precision. + See also: -" + {:inline (nary-inline 'minusP) + :inline-arities >0? + :added "1.0"} + ([x] (. clojure.lang.Numbers (minusP x))) + ([x y] (. clojure.lang.Numbers (minusP x y))) + ([x y & more] + (reduce1 -' (-' x y) more))) + +(defn - + "If no ys are supplied, returns the negation of x, else subtracts + the ys from x and returns the result. Does not auto-promote + longs, will throw on overflow. See also: -'" + {:inline (nary-inline 'minus 'unchecked_minus) + :inline-arities >0? + :added "1.2"} + ([x] (. clojure.lang.Numbers (minus x))) + ([x y] (. clojure.lang.Numbers (minus x y))) + ([x y & more] + (reduce1 - (- x y) more))) + +(defn <= + "Returns non-nil if nums are in monotonically non-decreasing order, + otherwise false." + {:inline (fn [x y] `(. clojure.lang.Numbers (lte ~x ~y))) + :inline-arities #{2} + :added "1.0"} + ([x] true) + ([x y] (. clojure.lang.Numbers (lte x y))) + ([x y & more] + (if (<= x y) + (if (next more) + (recur y (first more) (next more)) + (<= y (first more))) + false))) + +(defn > + "Returns non-nil if nums are in monotonically decreasing order, + otherwise false." + {:inline (fn [x y] `(. clojure.lang.Numbers (gt ~x ~y))) + :inline-arities #{2} + :added "1.0"} + ([x] true) + ([x y] (. clojure.lang.Numbers (gt x y))) + ([x y & more] + (if (> x y) + (if (next more) + (recur y (first more) (next more)) + (> y (first more))) + false))) + +(defn >= + "Returns non-nil if nums are in monotonically non-increasing order, + otherwise false." + {:inline (fn [x y] `(. clojure.lang.Numbers (gte ~x ~y))) + :inline-arities #{2} + :added "1.0"} + ([x] true) + ([x y] (. clojure.lang.Numbers (gte x y))) + ([x y & more] + (if (>= x y) + (if (next more) + (recur y (first more) (next more)) + (>= y (first more))) + false))) + +(defn == + "Returns non-nil if nums all have the equivalent + value (type-independent), otherwise false" + {:inline (fn [x y] `(. clojure.lang.Numbers (equiv ~x ~y))) + :inline-arities #{2} + :added "1.0"} + ([x] true) + ([x y] (. clojure.lang.Numbers (equiv x y))) + ([x y & more] + (if (== x y) + (if (next more) + (recur y (first more) (next more)) + (== y (first more))) + false))) + +(defn max + "Returns the greatest of the nums." + {:added "1.0" + :inline-arities >1? + :inline (nary-inline 'max)} + ([x] x) + ([x y] (. clojure.lang.Numbers (max x y))) + ([x y & more] + (reduce1 max (max x y) more))) + +(defn min + "Returns the least of the nums." + {:added "1.0" + :inline-arities >1? + :inline (nary-inline 'min)} + ([x] x) + ([x y] (. clojure.lang.Numbers (min x y))) + ([x y & more] + (reduce1 min (min x y) more))) + +(defn abs + {:doc "Returns the absolute value of a. + If a is Long/MIN_VALUE => Long/MIN_VALUE + If a is a double and zero => +0.0 + If a is a double and ##Inf or ##-Inf => ##Inf + If a is a double and ##NaN => ##NaN" + :inline-arities #{1} + :inline (fn [a] `(clojure.lang.Numbers/abs ~a)) + :added "1.11"} + [a] + (clojure.lang.Numbers/abs a)) + +(defn dec' + "Returns a number one less than num. Supports arbitrary precision. + See also: dec" + {:inline (fn [x] `(. clojure.lang.Numbers (decP ~x))) + :added "1.0"} + [x] (. clojure.lang.Numbers (decP x))) + +(defn dec + "Returns a number one less than num. Does not auto-promote + longs, will throw on overflow. See also: dec'" + {:inline (fn [x] `(. clojure.lang.Numbers (~(if *unchecked-math* 'unchecked_dec 'dec) ~x))) + :added "1.2"} + [x] (. clojure.lang.Numbers (dec x))) + +(defn unchecked-inc-int + "Returns a number one greater than x, an int. + Note - uses a primitive operator subject to overflow." + {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_int_inc ~x))) + :added "1.0"} + [x] (. clojure.lang.Numbers (unchecked_int_inc x))) + +(defn unchecked-inc + "Returns a number one greater than x, a long. + Note - uses a primitive operator subject to overflow." + {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_inc ~x))) + :added "1.0"} + [x] (. clojure.lang.Numbers (unchecked_inc x))) + +(defn unchecked-dec-int + "Returns a number one less than x, an int. + Note - uses a primitive operator subject to overflow." + {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_int_dec ~x))) + :added "1.0"} + [x] (. clojure.lang.Numbers (unchecked_int_dec x))) + +(defn unchecked-dec + "Returns a number one less than x, a long. + Note - uses a primitive operator subject to overflow." + {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_dec ~x))) + :added "1.0"} + [x] (. clojure.lang.Numbers (unchecked_dec x))) + +(defn unchecked-negate-int + "Returns the negation of x, an int. + Note - uses a primitive operator subject to overflow." + {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_int_negate ~x))) + :added "1.0"} + [x] (. clojure.lang.Numbers (unchecked_int_negate x))) + +(defn unchecked-negate + "Returns the negation of x, a long. + Note - uses a primitive operator subject to overflow." + {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_minus ~x))) + :added "1.0"} + [x] (. clojure.lang.Numbers (unchecked_minus x))) + +(defn unchecked-add-int + "Returns the sum of x and y, both int. + Note - uses a primitive operator subject to overflow." + {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_int_add ~x ~y))) + :added "1.0"} + [x y] (. clojure.lang.Numbers (unchecked_int_add x y))) + +(defn unchecked-add + "Returns the sum of x and y, both long. + Note - uses a primitive operator subject to overflow." + {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_add ~x ~y))) + :added "1.0"} + [x y] (. clojure.lang.Numbers (unchecked_add x y))) + +(defn unchecked-subtract-int + "Returns the difference of x and y, both int. + Note - uses a primitive operator subject to overflow." + {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_int_subtract ~x ~y))) + :added "1.0"} + [x y] (. clojure.lang.Numbers (unchecked_int_subtract x y))) + +(defn unchecked-subtract + "Returns the difference of x and y, both long. + Note - uses a primitive operator subject to overflow." + {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_minus ~x ~y))) + :added "1.0"} + [x y] (. clojure.lang.Numbers (unchecked_minus x y))) + +(defn unchecked-multiply-int + "Returns the product of x and y, both int. + Note - uses a primitive operator subject to overflow." + {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_int_multiply ~x ~y))) + :added "1.0"} + [x y] (. clojure.lang.Numbers (unchecked_int_multiply x y))) + +(defn unchecked-multiply + "Returns the product of x and y, both long. + Note - uses a primitive operator subject to overflow." + {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_multiply ~x ~y))) + :added "1.0"} + [x y] (. clojure.lang.Numbers (unchecked_multiply x y))) + +(defn unchecked-divide-int + "Returns the division of x by y, both int. + Note - uses a primitive operator subject to truncation." + {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_int_divide ~x ~y))) + :added "1.0"} + [x y] (. clojure.lang.Numbers (unchecked_int_divide x y))) + +(defn unchecked-remainder-int + "Returns the remainder of division of x by y, both int. + Note - uses a primitive operator subject to truncation." + {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_int_remainder ~x ~y))) + :added "1.0"} + [x y] (. clojure.lang.Numbers (unchecked_int_remainder x y))) + +(defn pos? + "Returns true if num is greater than zero, else false" + {:tag Boolean + :inline (fn [num] `(. clojure.lang.Numbers (isPos ~num))) + :added "1.0"} + [num] (. clojure.lang.Numbers (isPos num))) + +(defn neg? + "Returns true if num is less than zero, else false" + { + :inline (fn [num] `(. clojure.lang.Numbers (isNeg ~num))) + :added "1.0"} + [num] (. clojure.lang.Numbers (isNeg num))) + +(defn quot + "quot[ient] of dividing numerator by denominator." + {:added "1.0" + :static true + :inline (fn [x y] `(. clojure.lang.Numbers (quotient ~x ~y)))} + [num div] + (. clojure.lang.Numbers (quotient num div))) + +(defn rem + "remainder of dividing numerator by denominator." + {:added "1.0" + :static true + :inline (fn [x y] `(. clojure.lang.Numbers (remainder ~x ~y)))} + [num div] + (. clojure.lang.Numbers (remainder num div))) + +(defn rationalize + "returns the rational value of num" + {:added "1.0" + :static true} + [num] + (. clojure.lang.Numbers (rationalize num))) + +;;Bit ops + +(defn bit-not + "Bitwise complement" + {:inline (fn [x] `(. clojure.lang.Numbers (not ~x))) + :added "1.0"} + [x] (. clojure.lang.Numbers not x)) + + +(defn bit-and + "Bitwise and" + {:inline (nary-inline 'and) + :inline-arities >1? + :added "1.0"} + ([x y] (. clojure.lang.Numbers and x y)) + ([x y & more] + (reduce1 bit-and (bit-and x y) more))) + +(defn bit-or + "Bitwise or" + {:inline (nary-inline 'or) + :inline-arities >1? + :added "1.0"} + ([x y] (. clojure.lang.Numbers or x y)) + ([x y & more] + (reduce1 bit-or (bit-or x y) more))) + +(defn bit-xor + "Bitwise exclusive or" + {:inline (nary-inline 'xor) + :inline-arities >1? + :added "1.0"} + ([x y] (. clojure.lang.Numbers xor x y)) + ([x y & more] + (reduce1 bit-xor (bit-xor x y) more))) + +(defn bit-and-not + "Bitwise and with complement" + {:inline (nary-inline 'andNot) + :inline-arities >1? + :added "1.0" + :static true} + ([x y] (. clojure.lang.Numbers andNot x y)) + ([x y & more] + (reduce1 bit-and-not (bit-and-not x y) more))) + + +(defn bit-clear + "Clear bit at index n" + {:added "1.0" + :static true} + [x n] (. clojure.lang.Numbers clearBit x n)) + +(defn bit-set + "Set bit at index n" + {:added "1.0" + :static true} + [x n] (. clojure.lang.Numbers setBit x n)) + +(defn bit-flip + "Flip bit at index n" + {:added "1.0 + :static true"} + [x n] (. clojure.lang.Numbers flipBit x n)) + +(defn bit-test + "Test bit at index n" + {:added "1.0" + :static true} + [x n] (. clojure.lang.Numbers testBit x n)) + + +(defn bit-shift-left + "Bitwise shift left" + {:inline (fn [x n] `(. clojure.lang.Numbers (shiftLeft ~x ~n))) + :added "1.0"} + [x n] (. clojure.lang.Numbers shiftLeft x n)) + +(defn bit-shift-right + "Bitwise shift right" + {:inline (fn [x n] `(. clojure.lang.Numbers (shiftRight ~x ~n))) + :added "1.0"} + [x n] (. clojure.lang.Numbers shiftRight x n)) + +(defn unsigned-bit-shift-right + "Bitwise shift right, without sign-extension." + {: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" - {:added "1.0" - :static true} + {: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? Int16 n) (instance? UInt16 n) ;;; Short -> Int16, added UInt16 - (instance? Byte n) (instance? SByte n))) ;;; Added SByte test - -(defn even? - "Returns true if n is even, throws an exception if n is not an integer" - {:added "1.0" - :static true} - [n] (if (integer? n) - (zero? (bit-and (clojure.lang.RT/uncheckedLongCast n) 1)) - (throw (ArgumentException. (str "Argument must be an integer: " n))))) ;;; IllegalArgumentException. - -(defn odd? - "Returns true if n is odd, throws an exception if n is not an integer" - {:added "1.0" - :static true} - [n] (not (even? n))) - -(defn int? - "Return true if x is a fixed precision integer" ;;; DM: TODO: determine how or whether to handle unsigned types - {:added "1.9"} - [x] (or (instance? Int64 x) ;;; Long - (instance? Int32 x) ;;; Integer - (instance? Int16 x) ;;; Short - (instance? Byte x))) - -(defn pos-int? - "Return true if x is a positive fixed precision integer" - {:added "1.9"} - [x] (and (int? x) - (pos? x))) - -(defn neg-int? - "Return true if x is a negative fixed precision integer" - {:added "1.9"} - [x] (and (int? x) - (neg? x))) - -(defn nat-int? - "Return true if x is a non-negative fixed precision integer" - {:added "1.9"} - [x] (and (int? x) - (not (neg? x)))) - -(defn double? - "Return true if x is a Double" - {:added "1.9"} - [x] (instance? Double x)) - -;; - -(defn complement - "Takes a fn f and returns a fn that takes the same arguments as f, - has the same effects, if any, and returns the opposite truth value." - {:added "1.0" - :static true} - [f] - (fn - ([] (not (f))) - ([x] (not (f x))) - ([x y] (not (f x y))) - ([x y & zs] (not (apply f x y zs))))) - -(defn constantly - "Returns a function that takes any number of arguments and returns x." - {:added "1.0" - :static true} - [x] (fn [& args] x)) - -(defn identity - "Returns its argument." - {:added "1.0" - :static true} - [x] x) - -;;Collection stuff - -;;list stuff -(defn peek - "For a list or queue, same as first, for a vector, same as, but much - more efficient than, last. If the collection is empty, returns nil." - {:added "1.0" - :static true} - [coll] (. clojure.lang.RT (peek coll))) - -(defn pop - "For a list or queue, returns a new list/queue without the first - item, for a vector, returns a new vector without the last item. If - the collection is empty, throws an exception. Note - not the same - as next/butlast." - {:added "1.0" - :static true} - [coll] (. clojure.lang.RT (pop coll))) - -;;map stuff - -(defn map-entry? ;;; hoping this is correct. The equiv of Map$Entry is a struct, so not a base for anything. - "Return true if x is a map entry" ;;; Given the way it is used, adding KeyValuePair and DictionaryEntry doesn't seem right - {:added "1.8"} - [x] - (instance? clojure.lang.IMapEntry x)) ;;; (instance? java.util.Map$Entry x) - -(defn contains? + (instance? Byte n) (instance? SByte n))) ;;; Added SByte test + +(defn even? + "Returns true if n is even, throws an exception if n is not an integer" + {:added "1.0" + :static true} + [n] (if (integer? n) + (zero? (bit-and (clojure.lang.RT/uncheckedLongCast n) 1)) + (throw (ArgumentException. (str "Argument must be an integer: " n))))) ;;; IllegalArgumentException. + +(defn odd? + "Returns true if n is odd, throws an exception if n is not an integer" + {:added "1.0" + :static true} + [n] (not (even? n))) + +(defn int? + "Return true if x is a fixed precision integer" ;;; DM: TODO: determine how or whether to handle unsigned types + {:added "1.9"} + [x] (or (instance? Int64 x) ;;; Long + (instance? Int32 x) ;;; Integer + (instance? Int16 x) ;;; Short + (instance? Byte x))) + +(defn pos-int? + "Return true if x is a positive fixed precision integer" + {:added "1.9"} + [x] (and (int? x) + (pos? x))) + +(defn neg-int? + "Return true if x is a negative fixed precision integer" + {:added "1.9"} + [x] (and (int? x) + (neg? x))) + +(defn nat-int? + "Return true if x is a non-negative fixed precision integer" + {:added "1.9"} + [x] (and (int? x) + (not (neg? x)))) + +(defn double? + "Return true if x is a Double" + {:added "1.9"} + [x] (instance? Double x)) + +;; + +(defn complement + "Takes a fn f and returns a fn that takes the same arguments as f, + has the same effects, if any, and returns the opposite truth value." + {:added "1.0" + :static true} + [f] + (fn + ([] (not (f))) + ([x] (not (f x))) + ([x y] (not (f x y))) + ([x y & zs] (not (apply f x y zs))))) + +(defn constantly + "Returns a function that takes any number of arguments and returns x." + {:added "1.0" + :static true} + [x] (fn [& args] x)) + +(defn identity + "Returns its argument." + {:added "1.0" + :static true} + [x] x) + +;;Collection stuff + +;;list stuff +(defn peek + "For a list or queue, same as first, for a vector, same as, but much + more efficient than, last. If the collection is empty, returns nil." + {:added "1.0" + :static true} + [coll] (. clojure.lang.RT (peek coll))) + +(defn pop + "For a list or queue, returns a new list/queue without the first + item, for a vector, returns a new vector without the last item. If + the collection is empty, throws an exception. Note - not the same + as next/butlast." + {:added "1.0" + :static true} + [coll] (. clojure.lang.RT (pop coll))) + +;;map stuff + +(defn map-entry? ;;; hoping this is correct. The equiv of Map$Entry is a struct, so not a base for anything. + "Return true if x is a map entry" ;;; Given the way it is used, adding KeyValuePair and DictionaryEntry doesn't seem right + {:added "1.8"} + [x] + (instance? clojure.lang.IMapEntry x)) ;;; (instance? java.util.Map$Entry x) + +(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; - it will not perform a linear search for a value. See also 'some'." - {:added "1.0" - :static true} + 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))) - -(defn get - "Returns the value mapped to key, not-found or nil if key not present - in associative collection, set, string, array, or ILookup instance." - {:inline (fn [m k & nf] `(. clojure.lang.RT (get ~m ~k ~@nf))) - :inline-arities #{2 3} - :added "1.0"} - ([map key] - (. clojure.lang.RT (get map key))) - ([map key not-found] - (. clojure.lang.RT (get map key not-found)))) - -(defn dissoc - "dissoc[iate]. Returns a new map of the same (hashed/sorted) type, - that does not contain a mapping for key(s)." - {:added "1.0" - :static true} - ([map] map) - ([map key] - (. clojure.lang.RT (dissoc map key))) - ([map key & ks] - (let [ret (dissoc map key)] - (if ks - (recur ret (first ks) (next ks)) - ret)))) - -(defn disj - "disj[oin]. Returns a new set of the same (hashed/sorted) type, that - does not contain key(s)." - {:added "1.0" - :static true} - ([set] set) - ([^clojure.lang.IPersistentSet set key] - (when set - (. set (disjoin key)))) - ([set key & ks] - (when set - (let [ret (disj set key)] - (if ks - (recur ret (first ks) (next ks)) - ret))))) - -(defn find - "Returns the map entry for key, or nil if key not present." - {:added "1.0" - :static true} - [map key] (. clojure.lang.RT (find map key))) - -(defn select-keys - "Returns a map containing only those entries in map whose key is in keys" - {:added "1.0" - :static true} - [map keyseq] - (loop [ret {} keys (seq keyseq)] - (if keys - (let [entry (. clojure.lang.RT (find map (first keys)))] - (recur - (if entry - (conj ret entry) - ret) - (next keys))) - (with-meta ret (meta map))))) - -(defn keys - "Returns a sequence of the map's keys, in the same order as (seq map)." - {:added "1.0" - :static true} - [map] (. clojure.lang.RT (keys map))) - -(defn vals - "Returns a sequence of the map's values, in the same order as (seq map)." - {:added "1.0" - :static true} - [map] (. clojure.lang.RT (vals map))) - -(defn key - "Returns the key of the map entry." - {:added "1.0" - :static true} - [^clojure.lang.IMapEntry e] ;; [^java.util.Map$Entry e] - (. e (key))) ;; (. e (getKey))) - -(defn val - "Returns the value in the map entry." - {:added "1.0" - :static true} - [^clojure.lang.IMapEntry e] ;; [^java.util.Map$Entry e] - (. e (val))) ;; (. e (getValue))) - -(defn rseq - "Returns, in constant time, a seq of the items in rev (which - can be a vector or sorted-map), in reverse order. If rev is empty returns nil" - {:added "1.0" - :static true} - [^clojure.lang.Reversible rev] - (. rev (rseq))) - -(defn name - "Returns the name String of a string, symbol or keyword." - {:tag String - :added "1.0 - :static true"} - [^clojure.lang.Named x] - (if (string? x) x (. x (getName)))) - -(defn namespace - "Returns the namespace String of a symbol or keyword, or nil if not present." - {:tag String - :added "1.0" - :static true} - [^clojure.lang.Named x] - (. x (getNamespace))) - -(defn boolean - "Coerce to boolean" - { - :inline (fn [x] `(. clojure.lang.RT (booleanCast ~x))) - :added "1.0"} - [x] (clojure.lang.RT/booleanCast x)) - - (defn ident? - "Return true if x is a symbol or keyword" - {:added "1.9"} - [x] (or (keyword? x) (symbol? x))) - -(defn simple-ident? - "Return true if x is a symbol or keyword without a namespace" - {:added "1.9"} - [x] (and (ident? x) (nil? (namespace x)))) - -(defn qualified-ident? - "Return true if x is a symbol or keyword with a namespace" - {:added "1.9"} - [x] (boolean (and (ident? x) (namespace x) true))) - -(defn simple-symbol? - "Return true if x is a symbol without a namespace" - {:added "1.9"} - [x] (and (symbol? x) (nil? (namespace x)))) - -(defn qualified-symbol? - "Return true if x is a symbol with a namespace" - {:added "1.9"} - [x] (boolean (and (symbol? x) (namespace x) true))) - -(defn simple-keyword? - "Return true if x is a keyword without a namespace" - {:added "1.9"} - [x] (and (keyword? x) (nil? (namespace x)))) - -(defn qualified-keyword? - "Return true if x is a keyword with a namespace" - {:added "1.9"} - [x] (boolean (and (keyword? x) (namespace x) true))) - - (defmacro locking - "Executes exprs in an implicit do, while holding the monitor of x. - Will release the monitor of x in all circumstances." - {:added "1.0"} - [x & body] - `(let [lockee# ~x] - (try - (let [locklocal# lockee#] - (monitor-enter locklocal#) - (try - ~@body - (finally - (monitor-exit locklocal#))))))) - -(defmacro .. - "form => fieldName-symbol or (instanceMethodName-symbol args*) - - Expands into a member access (.) of the first member on the first - argument, followed by the next member on the result, etc. For - instance: - - (.. System (getProperties) (get \"os.name\")) - - expands to: - - (. (. System (getProperties)) (get \"os.name\")) - - but is easier to write, read, and understand." - {:added "1.0"} - ([x form] `(. ~x ~form)) - ([x form & more] `(.. (. ~x ~form) ~@more))) - -(defmacro -> - "Threads the expr through the forms. Inserts x as the - second item in the first form, making a list of it if it is not a - list already. If there are more forms, inserts the first form as the - second item in second form, etc." - {:added "1.0"} - [x & forms] - (loop [x x, forms forms] - (if forms - (let [form (first forms) - threaded (if (seq? form) - (with-meta `(~(first form) ~x ~@(next form)) (meta form)) - (list form x))] - (recur threaded (next forms))) - x))) - -(defmacro ->> - "Threads the expr through the forms. Inserts x as the - last item in the first form, making a list of it if it is not a - list already. If there are more forms, inserts the first form as the - last item in second form, etc." - {:added "1.1"} - [x & forms] - (loop [x x, forms forms] - (if forms - (let [form (first forms) - threaded (if (seq? form) - (with-meta `(~(first form) ~@(next form) ~x) (meta form)) - (list form x))] - (recur threaded (next forms))) - x))) - -(def map) - -(defn ^:private check-valid-options - "Throws an exception if the given option map contains keys not listed - as valid, else returns nil." - [options & valid-keys] - (when (seq (apply disj (apply hash-set (keys options)) valid-keys)) - (throw - (ArgumentException. ;;; IllegalArgumentException - (apply str "Only these options are valid: " - (first valid-keys) - (map #(str ", " %) (rest valid-keys))))))) - -;;multimethods -(def global-hierarchy) - -(defmacro defmulti - "Creates a new multimethod with the associated dispatch function. - The docstring and attr-map are optional. - - Options are key-value pairs and may be one of: - - :default - - The default dispatch value, defaults to :default - - :hierarchy - - The value used for hierarchical dispatch (e.g. ::square is-a ::shape) - - Hierarchies are type-like relationships that do not depend upon type - inheritance. By default Clojure's multimethods dispatch off of a - global hierarchy map. However, a hierarchy relationship can be - created with the derive function used to augment the root ancestor - created with make-hierarchy. - - Multimethods expect the value of the hierarchy option to be supplied as - a reference type e.g. a var (i.e. via the Var-quote dispatch macro #' - or the var special form)." - {:arglists '([name docstring? attr-map? dispatch-fn & options]) - :added "1.0"} - [mm-name & options] - (let [docstring (if (string? (first options)) - (first options) - nil) - options (if (string? (first options)) - (next options) - options) - m (if (map? (first options)) - (first options) - {}) - options (if (map? (first options)) - (next options) - options) - dispatch-fn (first options) - options (next options) - m (if docstring - (assoc m :doc docstring) - m) - m (if (meta mm-name) - (conj (meta mm-name) m) - m) - mm-name (with-meta mm-name m)] - (when (= (count options) 1) - (throw (Exception. "The syntax for defmulti has changed. Example: (defmulti name dispatch-fn :default dispatch-value)"))) - (let [options (apply hash-map options) - default (get options :default :default) - hierarchy (get options :hierarchy #'global-hierarchy)] - (check-valid-options options :default :hierarchy) - `(let [v# (def ~mm-name)] - (when-not (and (.hasRoot v#) (instance? clojure.lang.MultiFn (deref v#))) - (def ~mm-name - (new clojure.lang.MultiFn ~(name mm-name) ~dispatch-fn ~default ~hierarchy))))))) - -(defmacro defmethod - "Creates and installs a new method of multimethod associated with dispatch-value. " - {:added "1.0"} - [multifn dispatch-val & fn-tail] - `(. ~(with-meta multifn {:tag 'clojure.lang.MultiFn}) addMethod ~dispatch-val (fn ~@fn-tail))) - -(defn remove-all-methods - "Removes all of the methods of multimethod." - {:added "1.2" - :static true} - [^clojure.lang.MultiFn multifn] - (.reset multifn)) - -(defn remove-method - "Removes the method of multimethod associated with dispatch-value." - {:added "1.0" - :static true} - [multifn dispatch-val] - (. multifn removeMethod dispatch-val)) - -(defn prefer-method - "Causes the multimethod to prefer matches of dispatch-val-x over dispatch-val-y - when there is a conflict" - {:added "1.0" - :static true} - [multifn dispatch-val-x dispatch-val-y] - (. multifn preferMethod dispatch-val-x dispatch-val-y)) - -(defn methods - "Given a multimethod, returns a map of dispatch values -> dispatch fns" - {:added "1.0" - :static true} - [^clojure.lang.MultiFn multifn] (.getMethodTable multifn)) - -(defn get-method - "Given a multimethod and a dispatch value, returns the dispatch fn - that would apply to that value, or nil if none apply and no default" - {:added "1.0" - :static true} - [^clojure.lang.MultiFn multifn dispatch-val] (.getMethod multifn dispatch-val)) - -(defn prefers - "Given a multimethod, returns a map of preferred value -> set of other values" - {:added "1.0" - :static true} - [^clojure.lang.MultiFn multifn] (.getPreferTable multifn)) - -;;;;;;;;; var stuff - + +(defn get + "Returns the value mapped to key, not-found or nil if key not present + in associative collection, set, string, array, or ILookup instance." + {:inline (fn [m k & nf] `(. clojure.lang.RT (get ~m ~k ~@nf))) + :inline-arities #{2 3} + :added "1.0"} + ([map key] + (. clojure.lang.RT (get map key))) + ([map key not-found] + (. clojure.lang.RT (get map key not-found)))) + +(defn dissoc + "dissoc[iate]. Returns a new map of the same (hashed/sorted) type, + that does not contain a mapping for key(s)." + {:added "1.0" + :static true} + ([map] map) + ([map key] + (. clojure.lang.RT (dissoc map key))) + ([map key & ks] + (let [ret (dissoc map key)] + (if ks + (recur ret (first ks) (next ks)) + ret)))) + +(defn disj + "disj[oin]. Returns a new set of the same (hashed/sorted) type, that + does not contain key(s)." + {:added "1.0" + :static true} + ([set] set) + ([^clojure.lang.IPersistentSet set key] + (when set + (. set (disjoin key)))) + ([set key & ks] + (when set + (let [ret (disj set key)] + (if ks + (recur ret (first ks) (next ks)) + ret))))) + +(defn find + "Returns the map entry for key, or nil if key not present." + {:added "1.0" + :static true} + [map key] (. clojure.lang.RT (find map key))) + +(defn select-keys + "Returns a map containing only those entries in map whose key is in keys" + {:added "1.0" + :static true} + [map keyseq] + (loop [ret {} keys (seq keyseq)] + (if keys + (let [entry (. clojure.lang.RT (find map (first keys)))] + (recur + (if entry + (conj ret entry) + ret) + (next keys))) + (with-meta ret (meta map))))) + +(defn keys + "Returns a sequence of the map's keys, in the same order as (seq map)." + {:added "1.0" + :static true} + [map] (. clojure.lang.RT (keys map))) + +(defn vals + "Returns a sequence of the map's values, in the same order as (seq map)." + {:added "1.0" + :static true} + [map] (. clojure.lang.RT (vals map))) + +(defn key + "Returns the key of the map entry." + {:added "1.0" + :static true} + [^clojure.lang.IMapEntry e] ;; [^java.util.Map$Entry e] + (. e (key))) ;; (. e (getKey))) + +(defn val + "Returns the value in the map entry." + {:added "1.0" + :static true} + [^clojure.lang.IMapEntry e] ;; [^java.util.Map$Entry e] + (. e (val))) ;; (. e (getValue))) + +(defn rseq + "Returns, in constant time, a seq of the items in rev (which + can be a vector or sorted-map), in reverse order. If rev is empty returns nil" + {:added "1.0" + :static true} + [^clojure.lang.Reversible rev] + (. rev (rseq))) + +(defn name + "Returns the name String of a string, symbol or keyword." + {:tag String + :added "1.0 + :static true"} + [^clojure.lang.Named x] + (if (string? x) x (. x (getName)))) + +(defn namespace + "Returns the namespace String of a symbol or keyword, or nil if not present." + {:tag String + :added "1.0" + :static true} + [^clojure.lang.Named x] + (. x (getNamespace))) + +(defn boolean + "Coerce to boolean" + { + :inline (fn [x] `(. clojure.lang.RT (booleanCast ~x))) + :added "1.0"} + [x] (clojure.lang.RT/booleanCast x)) + + (defn ident? + "Return true if x is a symbol or keyword" + {:added "1.9"} + [x] (or (keyword? x) (symbol? x))) + +(defn simple-ident? + "Return true if x is a symbol or keyword without a namespace" + {:added "1.9"} + [x] (and (ident? x) (nil? (namespace x)))) + +(defn qualified-ident? + "Return true if x is a symbol or keyword with a namespace" + {:added "1.9"} + [x] (boolean (and (ident? x) (namespace x) true))) + +(defn simple-symbol? + "Return true if x is a symbol without a namespace" + {:added "1.9"} + [x] (and (symbol? x) (nil? (namespace x)))) + +(defn qualified-symbol? + "Return true if x is a symbol with a namespace" + {:added "1.9"} + [x] (boolean (and (symbol? x) (namespace x) true))) + +(defn simple-keyword? + "Return true if x is a keyword without a namespace" + {:added "1.9"} + [x] (and (keyword? x) (nil? (namespace x)))) + +(defn qualified-keyword? + "Return true if x is a keyword with a namespace" + {:added "1.9"} + [x] (boolean (and (keyword? x) (namespace x) true))) + + (defmacro locking + "Executes exprs in an implicit do, while holding the monitor of x. + Will release the monitor of x in all circumstances." + {:added "1.0"} + [x & body] + `(let [lockee# ~x] + (try + (let [locklocal# lockee#] + (monitor-enter locklocal#) + (try + ~@body + (finally + (monitor-exit locklocal#))))))) + +(defmacro .. + "form => fieldName-symbol or (instanceMethodName-symbol args*) + + Expands into a member access (.) of the first member on the first + argument, followed by the next member on the result, etc. For + instance: + + (.. System (getProperties) (get \"os.name\")) + + expands to: + + (. (. System (getProperties)) (get \"os.name\")) + + but is easier to write, read, and understand." + {:added "1.0"} + ([x form] `(. ~x ~form)) + ([x form & more] `(.. (. ~x ~form) ~@more))) + +(defmacro -> + "Threads the expr through the forms. Inserts x as the + second item in the first form, making a list of it if it is not a + list already. If there are more forms, inserts the first form as the + second item in second form, etc." + {:added "1.0"} + [x & forms] + (loop [x x, forms forms] + (if forms + (let [form (first forms) + threaded (if (seq? form) + (with-meta `(~(first form) ~x ~@(next form)) (meta form)) + (list form x))] + (recur threaded (next forms))) + x))) + +(defmacro ->> + "Threads the expr through the forms. Inserts x as the + last item in the first form, making a list of it if it is not a + list already. If there are more forms, inserts the first form as the + last item in second form, etc." + {:added "1.1"} + [x & forms] + (loop [x x, forms forms] + (if forms + (let [form (first forms) + threaded (if (seq? form) + (with-meta `(~(first form) ~@(next form) ~x) (meta form)) + (list form x))] + (recur threaded (next forms))) + x))) + +(def map) + +(defn ^:private check-valid-options + "Throws an exception if the given option map contains keys not listed + as valid, else returns nil." + [options & valid-keys] + (when (seq (apply disj (apply hash-set (keys options)) valid-keys)) + (throw + (ArgumentException. ;;; IllegalArgumentException + (apply str "Only these options are valid: " + (first valid-keys) + (map #(str ", " %) (rest valid-keys))))))) + +;;multimethods +(def global-hierarchy) + +(defmacro defmulti + "Creates a new multimethod with the associated dispatch function. + The docstring and attr-map are optional. + + Options are key-value pairs and may be one of: + + :default + + The default dispatch value, defaults to :default + + :hierarchy + + The value used for hierarchical dispatch (e.g. ::square is-a ::shape) + + Hierarchies are type-like relationships that do not depend upon type + inheritance. By default Clojure's multimethods dispatch off of a + global hierarchy map. However, a hierarchy relationship can be + created with the derive function used to augment the root ancestor + created with make-hierarchy. + + Multimethods expect the value of the hierarchy option to be supplied as + a reference type e.g. a var (i.e. via the Var-quote dispatch macro #' + or the var special form)." + {:arglists '([name docstring? attr-map? dispatch-fn & options]) + :added "1.0"} + [mm-name & options] + (let [docstring (if (string? (first options)) + (first options) + nil) + options (if (string? (first options)) + (next options) + options) + m (if (map? (first options)) + (first options) + {}) + options (if (map? (first options)) + (next options) + options) + dispatch-fn (first options) + options (next options) + m (if docstring + (assoc m :doc docstring) + m) + m (if (meta mm-name) + (conj (meta mm-name) m) + m) + mm-name (with-meta mm-name m)] + (when (= (count options) 1) + (throw (Exception. "The syntax for defmulti has changed. Example: (defmulti name dispatch-fn :default dispatch-value)"))) + (let [options (apply hash-map options) + default (get options :default :default) + hierarchy (get options :hierarchy #'global-hierarchy)] + (check-valid-options options :default :hierarchy) + `(let [v# (def ~mm-name)] + (when-not (and (.hasRoot v#) (instance? clojure.lang.MultiFn (deref v#))) + (def ~mm-name + (new clojure.lang.MultiFn ~(name mm-name) ~dispatch-fn ~default ~hierarchy))))))) + +(defmacro defmethod + "Creates and installs a new method of multimethod associated with dispatch-value. " + {:added "1.0"} + [multifn dispatch-val & fn-tail] + `(. ~(with-meta multifn {:tag 'clojure.lang.MultiFn}) addMethod ~dispatch-val (fn ~@fn-tail))) + +(defn remove-all-methods + "Removes all of the methods of multimethod." + {:added "1.2" + :static true} + [^clojure.lang.MultiFn multifn] + (.reset multifn)) + +(defn remove-method + "Removes the method of multimethod associated with dispatch-value." + {:added "1.0" + :static true} + [multifn dispatch-val] + (. multifn removeMethod dispatch-val)) + +(defn prefer-method + "Causes the multimethod to prefer matches of dispatch-val-x over dispatch-val-y + when there is a conflict" + {:added "1.0" + :static true} + [multifn dispatch-val-x dispatch-val-y] + (. multifn preferMethod dispatch-val-x dispatch-val-y)) + +(defn methods + "Given a multimethod, returns a map of dispatch values -> dispatch fns" + {:added "1.0" + :static true} + [^clojure.lang.MultiFn multifn] (.getMethodTable multifn)) + +(defn get-method + "Given a multimethod and a dispatch value, returns the dispatch fn + that would apply to that value, or nil if none apply and no default" + {:added "1.0" + :static true} + [^clojure.lang.MultiFn multifn dispatch-val] (.getMethod multifn dispatch-val)) + +(defn prefers + "Given a multimethod, returns a map of preferred value -> set of other values" + {:added "1.0" + :static true} + [^clojure.lang.MultiFn multifn] (.getPreferTable multifn)) + +;;;;;;;;; var stuff + (defmacro ^{:private true} assert-args [& pairs] `(do (when-not ~(first pairs) @@ -1854,299 +1854,299 @@ ~(let [more (nnext pairs)] (when more (list* `assert-args more))))) - -(defmacro if-let - "bindings => binding-form test - - If test is true, evaluates then with binding-form bound to the value of - test, if not, yields else" - {:added "1.0"} - ([bindings then] - `(if-let ~bindings ~then nil)) - ([bindings then else & oldform] - (assert-args - (vector? bindings) "a vector for its binding" - (nil? oldform) "1 or 2 forms after binding vector" - (= 2 (count bindings)) "exactly 2 forms in binding vector") - (let [form (bindings 0) tst (bindings 1)] - `(let [temp# ~tst] - (if temp# - (let [~form temp#] - ~then) - ~else))))) - -(defmacro when-let - "bindings => binding-form test - - When test is true, evaluates body with binding-form bound to the value of test" - {:added "1.0"} - [bindings & body] - (assert-args - (vector? bindings) "a vector for its binding" - (== 2 (count bindings)) "exactly 2 forms in binding vector") ;; JVM has only =, I have a boxed type problem here. - (let [form (bindings 0) tst (bindings 1)] - `(let [temp# ~tst] - (when temp# - (let [~form temp#] - ~@body))))) - -(defmacro if-some - "bindings => binding-form test - - If test is not nil, evaluates then with binding-form bound to the - value of test, if not, yields else" - {:added "1.6"} - ([bindings then] - `(if-some ~bindings ~then nil)) - ([bindings then else & oldform] - (assert-args - (vector? bindings) "a vector for its binding" - (nil? oldform) "1 or 2 forms after binding vector" - (= 2 (count bindings)) "exactly 2 forms in binding vector") - (let [form (bindings 0) tst (bindings 1)] - `(let [temp# ~tst] - (if (nil? temp#) - ~else - (let [~form temp#] - ~then)))))) - -(defmacro when-some - "bindings => binding-form test - - When test is not nil, evaluates body with binding-form bound to the - value of test" - {:added "1.6"} - [bindings & body] - (assert-args - (vector? bindings) "a vector for its binding" - (= 2 (count bindings)) "exactly 2 forms in binding vector") - (let [form (bindings 0) tst (bindings 1)] - `(let [temp# ~tst] - (if (nil? temp#) - nil - (let [~form temp#] - ~@body))))) - -(defn push-thread-bindings - "WARNING: This is a low-level function. Prefer high-level macros like - binding where ever possible. - - Takes a map of Var/value pairs. Binds each Var to the associated value for - the current thread. Each call *MUST* be accompanied by a matching call to - pop-thread-bindings wrapped in a try-finally! - - (push-thread-bindings bindings) - (try - ... - (finally - (pop-thread-bindings)))" - {:added "1.1" - :static true} - [bindings] - (clojure.lang.Var/pushThreadBindings bindings)) - -(defn pop-thread-bindings - "Pop one set of bindings pushed with push-binding before. It is an error to - pop bindings without pushing before." - {:added "1.1" - :static true} - [] - (clojure.lang.Var/popThreadBindings)) - -(defn get-thread-bindings - "Get a map with the Var/value pairs which is currently in effect for the - current thread." - {:added "1.1" - :static true} - [] - (clojure.lang.Var/getThreadBindings)) + +(defmacro if-let + "bindings => binding-form test + + If test is true, evaluates then with binding-form bound to the value of + test, if not, yields else" + {:added "1.0"} + ([bindings then] + `(if-let ~bindings ~then nil)) + ([bindings then else & oldform] + (assert-args + (vector? bindings) "a vector for its binding" + (nil? oldform) "1 or 2 forms after binding vector" + (= 2 (count bindings)) "exactly 2 forms in binding vector") + (let [form (bindings 0) tst (bindings 1)] + `(let [temp# ~tst] + (if temp# + (let [~form temp#] + ~then) + ~else))))) + +(defmacro when-let + "bindings => binding-form test + + When test is true, evaluates body with binding-form bound to the value of test" + {:added "1.0"} + [bindings & body] + (assert-args + (vector? bindings) "a vector for its binding" + (== 2 (count bindings)) "exactly 2 forms in binding vector") ;; JVM has only =, I have a boxed type problem here. + (let [form (bindings 0) tst (bindings 1)] + `(let [temp# ~tst] + (when temp# + (let [~form temp#] + ~@body))))) + +(defmacro if-some + "bindings => binding-form test + + If test is not nil, evaluates then with binding-form bound to the + value of test, if not, yields else" + {:added "1.6"} + ([bindings then] + `(if-some ~bindings ~then nil)) + ([bindings then else & oldform] + (assert-args + (vector? bindings) "a vector for its binding" + (nil? oldform) "1 or 2 forms after binding vector" + (= 2 (count bindings)) "exactly 2 forms in binding vector") + (let [form (bindings 0) tst (bindings 1)] + `(let [temp# ~tst] + (if (nil? temp#) + ~else + (let [~form temp#] + ~then)))))) + +(defmacro when-some + "bindings => binding-form test + + When test is not nil, evaluates body with binding-form bound to the + value of test" + {:added "1.6"} + [bindings & body] + (assert-args + (vector? bindings) "a vector for its binding" + (= 2 (count bindings)) "exactly 2 forms in binding vector") + (let [form (bindings 0) tst (bindings 1)] + `(let [temp# ~tst] + (if (nil? temp#) + nil + (let [~form temp#] + ~@body))))) + +(defn push-thread-bindings + "WARNING: This is a low-level function. Prefer high-level macros like + binding where ever possible. + + Takes a map of Var/value pairs. Binds each Var to the associated value for + the current thread. Each call *MUST* be accompanied by a matching call to + pop-thread-bindings wrapped in a try-finally! + + (push-thread-bindings bindings) + (try + ... + (finally + (pop-thread-bindings)))" + {:added "1.1" + :static true} + [bindings] + (clojure.lang.Var/pushThreadBindings bindings)) + +(defn pop-thread-bindings + "Pop one set of bindings pushed with push-binding before. It is an error to + pop bindings without pushing before." + {:added "1.1" + :static true} + [] + (clojure.lang.Var/popThreadBindings)) + +(defn get-thread-bindings + "Get a map with the Var/value pairs which is currently in effect for the + current thread." + {:added "1.1" + :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 - re-establishes the bindings that existed before. The new bindings - are made in parallel (unlike let); all init-exprs are evaluated + 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." - {:added "1.0"} + {: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") - (let [var-ize (fn [var-vals] - (loop [ret [] vvs (seq var-vals)] - (if vvs - (recur (conj (conj ret `(var ~(first vvs))) (second vvs)) - (next (next vvs))) - (seq ret))))] - `(let [] - (push-thread-bindings (hash-map ~@(var-ize bindings))) - (try - ~@body - (finally - (pop-thread-bindings)))))) - -(defn with-bindings* - "Takes a map of Var/value pairs. Installs for the given Vars the associated - values as thread-local bindings. Then calls f with the supplied arguments. - Pops the installed bindings after f returned. Returns whatever f returns." - {:added "1.1" - :static true} - [binding-map f & args] - (push-thread-bindings binding-map) - (try - (apply f args) - (finally - (pop-thread-bindings)))) - -(defmacro with-bindings - "Takes a map of Var/value pairs. Installs for the given Vars the associated - values as thread-local bindings. Then executes body. Pops the installed - bindings after body was evaluated. Returns the value of body." - {:added "1.1"} - [binding-map & body] - `(with-bindings* ~binding-map (fn [] ~@body))) - -(defn bound-fn* - "Returns a function, which will install the same bindings in effect as in - the thread at the time bound-fn* was called and then call f with any given - arguments. This may be used to define a helper function which runs on a - different thread, but needs the same bindings in place." - {:added "1.1" - :static true} - [f] - (let [bindings (get-thread-bindings)] - (fn [& args] - (apply with-bindings* bindings f args)))) - -(defmacro bound-fn - "Returns a function defined by the given fntail, which will install the - same bindings in effect as in the thread at the time bound-fn was called. - This may be used to define a helper function which runs on a different - thread, but needs the same bindings in place." - {:added "1.1"} - [& fntail] - `(bound-fn* (fn ~@fntail))) - -(defn find-var - "Returns the global var named by the namespace-qualified symbol, or - nil if no var with that name." - {:added "1.0" - :static true} - [sym] (. clojure.lang.Var (find sym))) - -(defn binding-conveyor-fn - {:private true - :added "1.3"} - [f] - (let [frame (clojure.lang.Var/cloneThreadBindingFrame)] - (fn - ([] - (clojure.lang.Var/resetThreadBindingFrame frame) - (f)) - ([x] - (clojure.lang.Var/resetThreadBindingFrame frame) - (f x)) - ([x y] - (clojure.lang.Var/resetThreadBindingFrame frame) - (f x y)) - ([x y z] - (clojure.lang.Var/resetThreadBindingFrame frame) - (f x y z)) - ([x y z & args] - (clojure.lang.Var/resetThreadBindingFrame frame) - (apply f x y z args))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Refs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defn ^{:private true} - setup-reference [^clojure.lang.ARef r options] - (let [opts (apply hash-map options)] - (when (:meta opts) - (.resetMeta r (:meta opts))) - (when (:validator opts) - (.setValidator r (:validator opts))) - r)) - -(defn agent - "Creates and returns an agent with an initial value of state and - zero or more options (in any order): - - :meta metadata-map - - :validator validate-fn - - :error-handler handler-fn - - :error-mode mode-keyword - - If metadata-map is supplied, it will become the metadata on the - agent. 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. handler-fn is called if an - action throws an exception or if validate-fn rejects a new state -- - see set-error-handler! for details. The mode-keyword may be either - :continue (the default if an error-handler is given) or :fail (the - default if no error-handler is given) -- see set-error-mode! for - details." - {:added "1.0" - :static true - } - ([state & options] - (let [a (new clojure.lang.Agent state) - opts (apply hash-map options)] - (setup-reference a options) - (when (:error-handler opts) - (.setErrorHandler a (:error-handler opts))) - (.setErrorMode a (or (:error-mode opts) - (if (:error-handler opts) :continue :fail))) - a))) - -(defn set-agent-send-executor! - "Sets the ExecutorService to be used by send" - {:added "1.5"} - [executor] - ) ;;; No CLR equivalent. make a no-op. (set! clojure.lang.Agent/pooledExecutor executor)) - -(defn set-agent-send-off-executor! - "Sets the ExecutorService to be used by send-off" - {:added "1.5"} - [executor] - ) ;;; No CLR equivalent. make a no-op. (set! clojure.lang.Agent/soloExecutor executor)) - -(defn send-via - "Dispatch an action to an agent. Returns the agent immediately. - Subsequently, in a thread supplied by executor, the state of the agent - will be set to the value of: - - (apply action-fn state-of-agent args)" - {:added "1.5"} - [executor ^clojure.lang.Agent a f & args] - (.dispatch a (binding [*agent* a] (binding-conveyor-fn f)) args false)) ;;; No CLR equivalent. Just use the thread pool. -- (.dispatch a (binding [*agent* a] (binding-conveyor-fn f)) args executor)) - -(defn send - "Dispatch an action to an agent. Returns the agent immediately. - Subsequently, in a thread from a thread pool, the state of the agent - will be set to the value of: - - (apply action-fn state-of-agent args)" - {:added "1.0" - :static true} - [^clojure.lang.Agent a f & args] - (.dispatch a (binding [*agent* a] (binding-conveyor-fn f)) args false)) ;;; No CLR equivalent. keep old true/false style -- (apply send-via clojure.lang.Agent/pooledExecutor a f args)) - -(defn send-off - "Dispatch a potentially blocking action to an agent. Returns the - agent immediately. Subsequently, in a separate thread, the state of - the agent will be set to the value of: - - (apply action-fn state-of-agent args)" - {:added "1.0" - :static true} - [^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)) - + (assert-args + (vector? bindings) "a vector for its binding" + (even? (count bindings)) "an even number of forms in binding vector") + (let [var-ize (fn [var-vals] + (loop [ret [] vvs (seq var-vals)] + (if vvs + (recur (conj (conj ret `(var ~(first vvs))) (second vvs)) + (next (next vvs))) + (seq ret))))] + `(let [] + (push-thread-bindings (hash-map ~@(var-ize bindings))) + (try + ~@body + (finally + (pop-thread-bindings)))))) + +(defn with-bindings* + "Takes a map of Var/value pairs. Installs for the given Vars the associated + values as thread-local bindings. Then calls f with the supplied arguments. + Pops the installed bindings after f returned. Returns whatever f returns." + {:added "1.1" + :static true} + [binding-map f & args] + (push-thread-bindings binding-map) + (try + (apply f args) + (finally + (pop-thread-bindings)))) + +(defmacro with-bindings + "Takes a map of Var/value pairs. Installs for the given Vars the associated + values as thread-local bindings. Then executes body. Pops the installed + bindings after body was evaluated. Returns the value of body." + {:added "1.1"} + [binding-map & body] + `(with-bindings* ~binding-map (fn [] ~@body))) + +(defn bound-fn* + "Returns a function, which will install the same bindings in effect as in + the thread at the time bound-fn* was called and then call f with any given + arguments. This may be used to define a helper function which runs on a + different thread, but needs the same bindings in place." + {:added "1.1" + :static true} + [f] + (let [bindings (get-thread-bindings)] + (fn [& args] + (apply with-bindings* bindings f args)))) + +(defmacro bound-fn + "Returns a function defined by the given fntail, which will install the + same bindings in effect as in the thread at the time bound-fn was called. + This may be used to define a helper function which runs on a different + thread, but needs the same bindings in place." + {:added "1.1"} + [& fntail] + `(bound-fn* (fn ~@fntail))) + +(defn find-var + "Returns the global var named by the namespace-qualified symbol, or + nil if no var with that name." + {:added "1.0" + :static true} + [sym] (. clojure.lang.Var (find sym))) + +(defn binding-conveyor-fn + {:private true + :added "1.3"} + [f] + (let [frame (clojure.lang.Var/cloneThreadBindingFrame)] + (fn + ([] + (clojure.lang.Var/resetThreadBindingFrame frame) + (f)) + ([x] + (clojure.lang.Var/resetThreadBindingFrame frame) + (f x)) + ([x y] + (clojure.lang.Var/resetThreadBindingFrame frame) + (f x y)) + ([x y z] + (clojure.lang.Var/resetThreadBindingFrame frame) + (f x y z)) + ([x y z & args] + (clojure.lang.Var/resetThreadBindingFrame frame) + (apply f x y z args))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Refs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defn ^{:private true} + setup-reference [^clojure.lang.ARef r options] + (let [opts (apply hash-map options)] + (when (:meta opts) + (.resetMeta r (:meta opts))) + (when (:validator opts) + (.setValidator r (:validator opts))) + r)) + +(defn agent + "Creates and returns an agent with an initial value of state and + zero or more options (in any order): + + :meta metadata-map + + :validator validate-fn + + :error-handler handler-fn + + :error-mode mode-keyword + + If metadata-map is supplied, it will become the metadata on the + agent. 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. handler-fn is called if an + action throws an exception or if validate-fn rejects a new state -- + see set-error-handler! for details. The mode-keyword may be either + :continue (the default if an error-handler is given) or :fail (the + default if no error-handler is given) -- see set-error-mode! for + details." + {:added "1.0" + :static true + } + ([state & options] + (let [a (new clojure.lang.Agent state) + opts (apply hash-map options)] + (setup-reference a options) + (when (:error-handler opts) + (.setErrorHandler a (:error-handler opts))) + (.setErrorMode a (or (:error-mode opts) + (if (:error-handler opts) :continue :fail))) + a))) + +(defn set-agent-send-executor! + "Sets the ExecutorService to be used by send" + {:added "1.5"} + [executor] + ) ;;; No CLR equivalent. make a no-op. (set! clojure.lang.Agent/pooledExecutor executor)) + +(defn set-agent-send-off-executor! + "Sets the ExecutorService to be used by send-off" + {:added "1.5"} + [executor] + ) ;;; No CLR equivalent. make a no-op. (set! clojure.lang.Agent/soloExecutor executor)) + +(defn send-via + "Dispatch an action to an agent. Returns the agent immediately. + Subsequently, in a thread supplied by executor, the state of the agent + will be set to the value of: + + (apply action-fn state-of-agent args)" + {:added "1.5"} + [executor ^clojure.lang.Agent a f & args] + (.dispatch a (binding [*agent* a] (binding-conveyor-fn f)) args false)) ;;; No CLR equivalent. Just use the thread pool. -- (.dispatch a (binding [*agent* a] (binding-conveyor-fn f)) args executor)) + +(defn send + "Dispatch an action to an agent. Returns the agent immediately. + Subsequently, in a thread from a thread pool, the state of the agent + will be set to the value of: + + (apply action-fn state-of-agent args)" + {:added "1.0" + :static true} + [^clojure.lang.Agent a f & args] + (.dispatch a (binding [*agent* a] (binding-conveyor-fn f)) args false)) ;;; No CLR equivalent. keep old true/false style -- (apply send-via clojure.lang.Agent/pooledExecutor a f args)) + +(defn send-off + "Dispatch a potentially blocking action to an agent. Returns the + agent immediately. Subsequently, in a separate thread, the state of + the agent will be set to the value of: + + (apply action-fn state-of-agent args)" + {:added "1.0" + :static true} + [^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 @@ -2154,128 +2154,128 @@ 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} + {:added "1.0" + :static true} [] (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 - new-state. Whenever the reference's state might have been changed, - any registered watches will have their functions called. The watch fn - will be called synchronously, on the agent's thread if an agent, - before any pending sends if agent or ref. Note that an atom's or - ref's state may have changed again prior to the fn call, so use - old/new-state rather than derefing the reference. Note also that watch - fns may be called from multiple threads simultaneously. Var watchers - are triggered only by root binding changes, not thread-local - set!s. Keys must be unique per reference, and can be used to remove - the watch with remove-watch, but are otherwise considered opaque by - the watch mechanism." - {:added "1.0" - :static true} - [^clojure.lang.IRef reference key fn] (.addWatch reference key fn)) - -(defn remove-watch - "Removes a watch (set by add-watch) from a reference" - {:added "1.0" - :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 - failed." - {:added "1.2" - :static true} - [^clojure.lang.Agent a] (.getError a)) - -(defn restart-agent - "When an agent is failed, changes the agent state to new-state and - then un-fails the agent so that sends are allowed again. If - a :clear-actions true option is given, any actions queued on the - agent that were being held while it was failed will be discarded, - otherwise those held actions will proceed. The new-state must pass - the validator if any, or restart will throw an exception and the - agent will remain failed with its old state and error. Watchers, if - any, will NOT be notified of the new state. Throws an exception if - the agent is not failed." - {:added "1.2" - :static true - } - [^clojure.lang.Agent a, new-state & options] - (let [opts (apply hash-map options)] - (.restart a new-state (if (:clear-actions opts) true false)))) - -(defn set-error-handler! - "Sets the error-handler of agent a to handler-fn. If an action - being run by the agent throws an exception or doesn't pass the - validator fn, handler-fn will be called with two arguments: the - agent and the exception." - {:added "1.2" - :static true} - [^clojure.lang.Agent a, handler-fn] - (.setErrorHandler a handler-fn)) - -(defn error-handler - "Returns the error-handler of agent a, or nil if there is none. - See set-error-handler!" - {:added "1.2" - :static true} - [^clojure.lang.Agent a] - (.getErrorHandler a)) - -(defn set-error-mode! - "Sets the error-mode of agent a to mode-keyword, which must be - either :fail or :continue. If an action being run by the agent - throws an exception or doesn't pass the validator fn, an - error-handler may be called (see set-error-handler!), after which, - if the mode is :continue, the agent will continue as if neither the - action that caused the error nor the error itself ever happened. - - If the mode is :fail, the agent will become failed and will stop - accepting new 'send' and 'send-off' actions, and any previously - queued actions will be held until a 'restart-agent'. Deref will - still work, returning the state of the agent before the error." - {:added "1.2" - :static true} - [^clojure.lang.Agent a, mode-keyword] - (.setErrorMode a mode-keyword)) - -(defn error-mode - "Returns the error-mode of agent a. See set-error-mode!" - {:added "1.2" - :static true} - [^clojure.lang.Agent a] - (.getErrorMode a)) - -(defn agent-errors - "DEPRECATED: Use 'agent-error' instead. - Returns a sequence of the exceptions thrown during asynchronous - actions of the agent." - {:added "1.0" - :deprecated "1.2"} - [a] - (when-let [e (agent-error a)] - (list e))) - -(defn clear-agent-errors - "DEPRECATED: Use 'restart-agent' instead. - Clears any exceptions thrown during asynchronous actions of the - agent, allowing subsequent actions to occur." - {:added "1.0" - :deprecated "1.2"} - [^clojure.lang.Agent a] (restart-agent a (.deref a))) - -(defn shutdown-agents - "Initiates a shutdown of the thread pools that back the agent - system. Running actions will complete, but no new actions will be - accepted" - {:added "1.0" - :static true} - [] (. clojure.lang.Agent shutdown)) - +(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 + new-state. Whenever the reference's state might have been changed, + any registered watches will have their functions called. The watch fn + will be called synchronously, on the agent's thread if an agent, + before any pending sends if agent or ref. Note that an atom's or + ref's state may have changed again prior to the fn call, so use + old/new-state rather than derefing the reference. Note also that watch + fns may be called from multiple threads simultaneously. Var watchers + are triggered only by root binding changes, not thread-local + set!s. Keys must be unique per reference, and can be used to remove + the watch with remove-watch, but are otherwise considered opaque by + the watch mechanism." + {:added "1.0" + :static true} + [^clojure.lang.IRef reference key fn] (.addWatch reference key fn)) + +(defn remove-watch + "Removes a watch (set by add-watch) from a reference" + {:added "1.0" + :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 + failed." + {:added "1.2" + :static true} + [^clojure.lang.Agent a] (.getError a)) + +(defn restart-agent + "When an agent is failed, changes the agent state to new-state and + then un-fails the agent so that sends are allowed again. If + a :clear-actions true option is given, any actions queued on the + agent that were being held while it was failed will be discarded, + otherwise those held actions will proceed. The new-state must pass + the validator if any, or restart will throw an exception and the + agent will remain failed with its old state and error. Watchers, if + any, will NOT be notified of the new state. Throws an exception if + the agent is not failed." + {:added "1.2" + :static true + } + [^clojure.lang.Agent a, new-state & options] + (let [opts (apply hash-map options)] + (.restart a new-state (if (:clear-actions opts) true false)))) + +(defn set-error-handler! + "Sets the error-handler of agent a to handler-fn. If an action + being run by the agent throws an exception or doesn't pass the + validator fn, handler-fn will be called with two arguments: the + agent and the exception." + {:added "1.2" + :static true} + [^clojure.lang.Agent a, handler-fn] + (.setErrorHandler a handler-fn)) + +(defn error-handler + "Returns the error-handler of agent a, or nil if there is none. + See set-error-handler!" + {:added "1.2" + :static true} + [^clojure.lang.Agent a] + (.getErrorHandler a)) + +(defn set-error-mode! + "Sets the error-mode of agent a to mode-keyword, which must be + either :fail or :continue. If an action being run by the agent + throws an exception or doesn't pass the validator fn, an + error-handler may be called (see set-error-handler!), after which, + if the mode is :continue, the agent will continue as if neither the + action that caused the error nor the error itself ever happened. + + If the mode is :fail, the agent will become failed and will stop + accepting new 'send' and 'send-off' actions, and any previously + queued actions will be held until a 'restart-agent'. Deref will + still work, returning the state of the agent before the error." + {:added "1.2" + :static true} + [^clojure.lang.Agent a, mode-keyword] + (.setErrorMode a mode-keyword)) + +(defn error-mode + "Returns the error-mode of agent a. See set-error-mode!" + {:added "1.2" + :static true} + [^clojure.lang.Agent a] + (.getErrorMode a)) + +(defn agent-errors + "DEPRECATED: Use 'agent-error' instead. + Returns a sequence of the exceptions thrown during asynchronous + actions of the agent." + {:added "1.0" + :deprecated "1.2"} + [a] + (when-let [e (agent-error a)] + (list e))) + +(defn clear-agent-errors + "DEPRECATED: Use 'restart-agent' instead. + Clears any exceptions thrown during asynchronous actions of the + agent, allowing subsequent actions to occur." + {:added "1.0" + :deprecated "1.2"} + [^clojure.lang.Agent a] (restart-agent a (.deref a))) + +(defn shutdown-agents + "Initiates a shutdown of the thread pools that back the agent + system. Running actions will complete, but no new actions will be + accepted" + {:added "1.0" + :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): @@ -2299,993 +2299,993 @@ 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 - } + {:added "1.0" + :static true + } ([x] (new clojure.lang.Ref x)) - ([x & options] - (let [ r ^clojure.lang.Ref (setup-reference (ref x) options) - opts (apply hash-map options)] - (when (:max-history opts) - (.setMaxHistory r (:max-history opts))) - (when (:min-history opts) - (.setMinHistory r (:min-history opts))) - r))) - -(defn ^:private deref-future ;;; this won't get used because clojure.lang.Future implements IDeref and IBlockingDeref, but what the heck, why not do it? - ([^clojure.lang.Future fut] ;;; ^java.util.concurrent.Future - (.get fut)) - ([^clojure.lang.Future fut timeout-ms timeout-val] ;;; ^java.util.concurrent.Future - (try (.get fut timeout-ms) ;;; (.get fut timeout-ms java.util.concurrent.TimeUnit/MILLISECONDS) - (catch clojure.lang.FutureTimeoutException e ;;; java.util.concurrent.TimeoutException - timeout-val)))) - -(defn deref + ([x & options] + (let [ r ^clojure.lang.Ref (setup-reference (ref x) options) + opts (apply hash-map options)] + (when (:max-history opts) + (.setMaxHistory r (:max-history opts))) + (when (:min-history opts) + (.setMinHistory r (:min-history opts))) + r))) + +(defn ^:private deref-future ;;; this won't get used because clojure.lang.Future implements IDeref and IBlockingDeref, but what the heck, why not do it? + ([^clojure.lang.Future fut] ;;; ^java.util.concurrent.Future + (.get fut)) + ([^clojure.lang.Future fut timeout-ms timeout-val] ;;; ^java.util.concurrent.Future + (try (.get fut timeout-ms) ;;; (.get fut timeout-ms java.util.concurrent.TimeUnit/MILLISECONDS) + (catch clojure.lang.FutureTimeoutException e ;;; java.util.concurrent.TimeoutException + 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 - 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 - until a value is delivered. The variant taking a timeout can be - used for blocking references (futures and promises), and will return - timeout-val if the timeout (in milliseconds) is reached before a - value is available. See also - realized?." - {:added "1.0" - :static true} - ([ref] (if (instance? clojure.lang.IDeref ref) - (.deref ^clojure.lang.IDeref ref) - (deref-future ref))) - ([ref timeout-ms timeout-val] - (if (instance? clojure.lang.IBlockingDeref ref) - (.deref ^clojure.lang.IBlockingDeref ref timeout-ms timeout-val) - (deref-future ref timeout-ms timeout-val)))) - -(defn atom - "Creates and returns an Atom with an initial value of x and zero or - more options (in any order): - - :meta metadata-map - - :validator validate-fn - - If metadata-map is supplied, it will become the metadata on the - atom. 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." - {:added "1.0" - :static true} - ([x] (new clojure.lang.Atom x)) - ([x & options] (setup-reference (atom x) options))) - -(defn swap! - "Atomically swaps the value of atom to be: - (apply f current-value-of-atom args). Note that f may be called - multiple times, and thus should be free of side effects. Returns - the value that was swapped in." - {:added "1.0" - :static true} - ([^clojure.lang.IAtom atom f] (.swap atom f)) - ([^clojure.lang.IAtom atom f x] (.swap atom f x)) - ([^clojure.lang.IAtom atom f x y] (.swap atom f x y)) - ([^clojure.lang.IAtom atom f x y & args] (.swap atom f x y args))) - -(defn swap-vals! - "Atomically swaps the value of atom to be: - (apply f current-value-of-atom args). Note that f may be called - multiple times, and thus should be free of side effects. - Returns [old new], the value of the atom before and after the swap." - {:added "1.9"} - (^clojure.lang.IPersistentVector [^clojure.lang.IAtom2 atom f] (.swapVals atom f)) - (^clojure.lang.IPersistentVector [^clojure.lang.IAtom2 atom f x] (.swapVals atom f x)) - (^clojure.lang.IPersistentVector [^clojure.lang.IAtom2 atom f x y] (.swapVals atom f x y)) - (^clojure.lang.IPersistentVector [^clojure.lang.IAtom2 atom f x y & args] (.swapVals atom f x y args))) - -(defn compare-and-set! - "Atomically sets the value of atom to newval if and only if the - current value of the atom is identical to oldval. Returns true if - set happened, else false" - {:added "1.0" - :static true} - [^clojure.lang.IAtom atom oldval newval] (.compareAndSet atom oldval newval)) - -(defn reset! - "Sets the value of atom to newval without regard for the - current value. Returns newval." - {:added "1.0" - :static true} - [^clojure.lang.IAtom atom newval] (.reset atom newval)) - -(defn reset-vals! - "Sets the value of atom to newval. Returns [old new], the value of the - atom before and after the reset." - {:added "1.9"} - ^clojure.lang.IPersistentVector [^clojure.lang.IAtom2 atom newval] (.resetVals atom newval)) - -(defn set-validator! + 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 + until a value is delivered. The variant taking a timeout can be + used for blocking references (futures and promises), and will return + timeout-val if the timeout (in milliseconds) is reached before a + value is available. See also - realized?." + {:added "1.0" + :static true} + ([ref] (if (instance? clojure.lang.IDeref ref) + (.deref ^clojure.lang.IDeref ref) + (deref-future ref))) + ([ref timeout-ms timeout-val] + (if (instance? clojure.lang.IBlockingDeref ref) + (.deref ^clojure.lang.IBlockingDeref ref timeout-ms timeout-val) + (deref-future ref timeout-ms timeout-val)))) + +(defn atom + "Creates and returns an Atom with an initial value of x and zero or + more options (in any order): + + :meta metadata-map + + :validator validate-fn + + If metadata-map is supplied, it will become the metadata on the + atom. 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." + {:added "1.0" + :static true} + ([x] (new clojure.lang.Atom x)) + ([x & options] (setup-reference (atom x) options))) + +(defn swap! + "Atomically swaps the value of atom to be: + (apply f current-value-of-atom args). Note that f may be called + multiple times, and thus should be free of side effects. Returns + the value that was swapped in." + {:added "1.0" + :static true} + ([^clojure.lang.IAtom atom f] (.swap atom f)) + ([^clojure.lang.IAtom atom f x] (.swap atom f x)) + ([^clojure.lang.IAtom atom f x y] (.swap atom f x y)) + ([^clojure.lang.IAtom atom f x y & args] (.swap atom f x y args))) + +(defn swap-vals! + "Atomically swaps the value of atom to be: + (apply f current-value-of-atom args). Note that f may be called + multiple times, and thus should be free of side effects. + Returns [old new], the value of the atom before and after the swap." + {:added "1.9"} + (^clojure.lang.IPersistentVector [^clojure.lang.IAtom2 atom f] (.swapVals atom f)) + (^clojure.lang.IPersistentVector [^clojure.lang.IAtom2 atom f x] (.swapVals atom f x)) + (^clojure.lang.IPersistentVector [^clojure.lang.IAtom2 atom f x y] (.swapVals atom f x y)) + (^clojure.lang.IPersistentVector [^clojure.lang.IAtom2 atom f x y & args] (.swapVals atom f x y args))) + +(defn compare-and-set! + "Atomically sets the value of atom to newval if and only if the + current value of the atom is identical to oldval. Returns true if + set happened, else false" + {:added "1.0" + :static true} + [^clojure.lang.IAtom atom oldval newval] (.compareAndSet atom oldval newval)) + +(defn reset! + "Sets the value of atom to newval without regard for the + current value. Returns newval." + {:added "1.0" + :static true} + [^clojure.lang.IAtom atom newval] (.reset atom newval)) + +(defn reset-vals! + "Sets the value of atom to newval. Returns [old new], the value of the + atom before and after the reset." + {:added "1.9"} + ^clojure.lang.IPersistentVector [^clojure.lang.IAtom2 atom newval] (.resetVals 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." - {:added "1.0" - :static true} + {:added "1.0" + :static true} [^clojure.lang.IRef iref validator-fn] (. iref (setValidator validator-fn))) - -(defn get-validator + +(defn get-validator "Gets the validator-fn for a var/ref/agent/atom." - {:added "1.0" - :static true} - [^clojure.lang.IRef iref] (. iref (getValidator))) - -(defn alter-meta! - "Atomically sets the metadata for a namespace/var/ref/agent/atom to be: - - (apply f its-current-meta args) - - f must be free of side-effects" - {:added "1.0" - :static true} - [^clojure.lang.IReference iref f & args] (.alterMeta iref f args)) - -(defn reset-meta! - "Atomically resets the metadata for a namespace/var/ref/agent/atom" - {:added "1.0" - :static true} - [^clojure.lang.IReference iref metadata-map] (.resetMeta iref metadata-map)) - -(defn commute - "Must be called in a transaction. Sets the in-transaction-value of - ref to: - - (apply fun in-transaction-value-of-ref args) - - and returns the in-transaction-value of ref. - - At the commit point of the transaction, sets the value of ref to be: - - (apply fun most-recently-committed-value-of-ref args) - - Thus fun should be commutative, or, failing that, you must accept - last-one-in-wins behavior. commute allows for more concurrency than - ref-set." - {:added "1.0" - :static true} - - [^clojure.lang.Ref ref fun & args] - (. ref (commute fun args))) - -(defn alter - "Must be called in a transaction. Sets the in-transaction-value of - ref to: - - (apply fun in-transaction-value-of-ref args) - - and returns the in-transaction-value of ref." - {:added "1.0" - :static true} - [^clojure.lang.Ref ref fun & args] - (. ref (alter fun args))) - -(defn ref-set - "Must be called in a transaction. Sets the value of ref. - Returns val." - {:added "1.0" - :static true} - [^clojure.lang.Ref ref val] - (. ref (set val))) - -(defn ref-history-count - "Returns the history count of a ref" - {:added "1.1" - :static true} - [^clojure.lang.Ref ref] - (.getHistoryCount ref)) - -(defn ref-min-history - "Gets the min-history of a ref, or sets it and returns the ref" - {:added "1.1" - :static true} - ([^clojure.lang.Ref ref] - (.getMinHistory ref)) - ([^clojure.lang.Ref ref n] - (.setMinHistory ref n))) - -(defn ref-max-history - "Gets the max-history of a ref, or sets it and returns the ref" - {:added "1.1" - :static true} - ([^clojure.lang.Ref ref] - (.getMaxHistory ref)) - ([^clojure.lang.Ref ref n] - (.setMaxHistory ref n))) - -(defn ensure - "Must be called in a transaction. Protects the ref from modification - by other transactions. Returns the in-transaction-value of - ref. Allows for more concurrency than (ref-set ref @ref)" - {:added "1.0" - :static true} - [^clojure.lang.Ref ref] - (. ref (touch)) - (. ref (deref))) - -(defmacro sync - "transaction-flags => TBD, pass nil for now - - Runs the exprs (in an implicit do) in a transaction that encompasses - exprs and any nested calls. Starts a transaction if none is already - running on this thread. Any uncaught exception will abort the - transaction and flow out of sync. The exprs may be run more than - once, but any effects on Refs will be atomic." - {:added "1.0"} - [flags-ignored-for-now & body] - `(. clojure.lang.LockingTransaction - (runInTransaction (fn [] ~@body)))) - - + {:added "1.0" + :static true} + [^clojure.lang.IRef iref] (. iref (getValidator))) + +(defn alter-meta! + "Atomically sets the metadata for a namespace/var/ref/agent/atom to be: + + (apply f its-current-meta args) + + f must be free of side-effects" + {:added "1.0" + :static true} + [^clojure.lang.IReference iref f & args] (.alterMeta iref f args)) + +(defn reset-meta! + "Atomically resets the metadata for a namespace/var/ref/agent/atom" + {:added "1.0" + :static true} + [^clojure.lang.IReference iref metadata-map] (.resetMeta iref metadata-map)) + +(defn commute + "Must be called in a transaction. Sets the in-transaction-value of + ref to: + + (apply fun in-transaction-value-of-ref args) + + and returns the in-transaction-value of ref. + + At the commit point of the transaction, sets the value of ref to be: + + (apply fun most-recently-committed-value-of-ref args) + + Thus fun should be commutative, or, failing that, you must accept + last-one-in-wins behavior. commute allows for more concurrency than + ref-set." + {:added "1.0" + :static true} + + [^clojure.lang.Ref ref fun & args] + (. ref (commute fun args))) + +(defn alter + "Must be called in a transaction. Sets the in-transaction-value of + ref to: + + (apply fun in-transaction-value-of-ref args) + + and returns the in-transaction-value of ref." + {:added "1.0" + :static true} + [^clojure.lang.Ref ref fun & args] + (. ref (alter fun args))) + +(defn ref-set + "Must be called in a transaction. Sets the value of ref. + Returns val." + {:added "1.0" + :static true} + [^clojure.lang.Ref ref val] + (. ref (set val))) + +(defn ref-history-count + "Returns the history count of a ref" + {:added "1.1" + :static true} + [^clojure.lang.Ref ref] + (.getHistoryCount ref)) + +(defn ref-min-history + "Gets the min-history of a ref, or sets it and returns the ref" + {:added "1.1" + :static true} + ([^clojure.lang.Ref ref] + (.getMinHistory ref)) + ([^clojure.lang.Ref ref n] + (.setMinHistory ref n))) + +(defn ref-max-history + "Gets the max-history of a ref, or sets it and returns the ref" + {:added "1.1" + :static true} + ([^clojure.lang.Ref ref] + (.getMaxHistory ref)) + ([^clojure.lang.Ref ref n] + (.setMaxHistory ref n))) + +(defn ensure + "Must be called in a transaction. Protects the ref from modification + by other transactions. Returns the in-transaction-value of + ref. Allows for more concurrency than (ref-set ref @ref)" + {:added "1.0" + :static true} + [^clojure.lang.Ref ref] + (. ref (touch)) + (. ref (deref))) + +(defmacro sync + "transaction-flags => TBD, pass nil for now + + Runs the exprs (in an implicit do) in a transaction that encompasses + exprs and any nested calls. Starts a transaction if none is already + running on this thread. Any uncaught exception will abort the + transaction and flow out of sync. The exprs may be run more than + once, but any effects on Refs will be atomic." + {:added "1.0"} + [flags-ignored-for-now & body] + `(. clojure.lang.LockingTransaction + (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." - {:added "1.0"} + {: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 - (do ~@body)))) - -(defn volatile! - "Creates and returns a Volatile with an initial value of val." - {:added "1.7" - :tag clojure.lang.Volatile} - [val] - (clojure.lang.Volatile. val)) - -(defn vreset! - "Sets the value of volatile to newval without regard for the - current value. Returns newval." - {:added "1.7"} - [^clojure.lang.Volatile vol newval] - (.reset vol newval)) - -(defmacro vswap! - "Non-atomically swaps the value of the volatile as if: - (apply f current-value-of-vol args). Returns the value that - was swapped in." - {:added "1.7"} - [vol f & args] - (let [v (with-meta vol {:tag 'clojure.lang.Volatile})] - `(.reset ~v (~f (.deref ~v) ~@args)))) - -(defn volatile? - "Returns true if x is a volatile." - {:added "1.7"} - [x] - (instance? clojure.lang.Volatile x)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; fn stuff ;;;;;;;;;;;;;;;; - - -(defn comp - "Takes a set of functions and returns a fn that is the composition - of those fns. The returned fn takes a variable number of args, - applies the rightmost of fns to the args, the next - fn (right-to-left) to the result, etc." - {:added "1.0" - :static true} - ([] identity) - ([f] f) - ([f g] - (fn - ([] (f (g))) - ([x] (f (g x))) - ([x y] (f (g x y))) - ([x y z] (f (g x y z))) - ([x y z & args] (f (apply g x y z args))))) - ([f g & fs] - (reduce1 comp (list* f g fs)))) - -(defn juxt - "Takes a set of functions and returns a fn that is the juxtaposition - of those fns. The returned fn takes a variable number of args, and - returns a vector containing the result of applying each fn to the - args (left-to-right). - ((juxt a b c) x) => [(a x) (b x) (c x)]" - {:added "1.1" - :static true} - ([f] - (fn - ([] [(f)]) - ([x] [(f x)]) - ([x y] [(f x y)]) - ([x y z] [(f x y z)]) - ([x y z & args] [(apply f x y z args)]))) - ([f g] - (fn - ([] [(f) (g)]) - ([x] [(f x) (g x)]) - ([x y] [(f x y) (g x y)]) - ([x y z] [(f x y z) (g x y z)]) - ([x y z & args] [(apply f x y z args) (apply g x y z args)]))) - ([f g h] - (fn - ([] [(f) (g) (h)]) - ([x] [(f x) (g x) (h x)]) - ([x y] [(f x y) (g x y) (h x y)]) - ([x y z] [(f x y z) (g x y z) (h x y z)]) - ([x y z & args] [(apply f x y z args) (apply g x y z args) (apply h x y z args)]))) - ([f g h & fs] - (let [fs (list* f g h fs)] - (fn - ([] (reduce1 #(conj %1 (%2)) [] fs)) - ([x] (reduce1 #(conj %1 (%2 x)) [] fs)) - ([x y] (reduce1 #(conj %1 (%2 x y)) [] fs)) - ([x y z] (reduce1 #(conj %1 (%2 x y z)) [] fs)) - ([x y z & args] (reduce1 #(conj %1 (apply %2 x y z args)) [] fs)))))) - -(defn partial - "Takes a function f and fewer than the normal arguments to f, and - returns a fn that takes a variable number of additional args. When - called, the returned function calls f with args + additional args." - {:added "1.0" - :static true} - ([f] f) - ([f arg1] - (fn - ([] (f arg1)) - ([x] (f arg1 x)) - ([x y] (f arg1 x y)) - ([x y z] (f arg1 x y z)) - ([x y z & args] (apply f arg1 x y z args)))) - ([f arg1 arg2] - (fn - ([] (f arg1 arg2)) - ([x] (f arg1 arg2 x)) - ([x y] (f arg1 arg2 x y)) - ([x y z] (f arg1 arg2 x y z)) - ([x y z & args] (apply f arg1 arg2 x y z args)))) - ([f arg1 arg2 arg3] - (fn - ([] (f arg1 arg2 arg3)) - ([x] (f arg1 arg2 arg3 x)) - ([x y] (f arg1 arg2 arg3 x y)) - ([x y z] (f arg1 arg2 arg3 x y z)) - ([x y z & args] (apply f arg1 arg2 arg3 x y z args)))) - ([f arg1 arg2 arg3 & more] - (fn [& args] (apply f arg1 arg2 arg3 (concat more args))))) - -;;;;;;;;;;;;;;;;;;; sequence fns ;;;;;;;;;;;;;;;;;;;;;;; - -(defn sequence - "Coerces coll to a (possibly empty) sequence, if it is not already - one. Will not force a lazy seq. (sequence nil) yields (), When a - transducer is supplied, returns a lazy sequence of applications of - the transform to the items in coll(s), i.e. to the set of first - items of each coll, followed by the set of second - items in each coll, until any one of the colls is exhausted. Any - remaining items in other colls are ignored. The transform should accept - number-of-colls arguments" - {:added "1.0" - :static true} - ([coll] - (if (seq? coll) coll - (or (seq coll) ()))) - ([xform coll] - (or (clojure.lang.RT/chunkEnumeratorSeq ;;; chunkIteratorSeq - (clojure.lang.TransformerEnumerator/create xform (clojure.lang.RT/iter coll))) ;;; TransformerIterator - ())) - ([xform coll & colls] - (or (clojure.lang.RT/chunkEnumeratorSeq ;;; chunkIteratorSeq - (clojure.lang.TransformerEnumerator/createMulti ;;; TransformerIterator - xform - (map #(clojure.lang.RT/iter %) (cons coll colls)))) - ()))) - -(defn every? - "Returns true if (pred x) is logical true for every x in coll, else - false." - {:tag Boolean - :added "1.0" - :static true} - [pred coll] - (cond - (nil? (seq coll)) true - (pred (first coll)) (recur pred (next coll)) - :else false)) - -(def - ^{:tag Boolean - :doc "Returns false if (pred x) is logical true for every x in - coll, else true." - :arglists '([pred coll]) - :added "1.0"} - not-every? (comp not every?)) - + (do ~@body)))) + +(defn volatile! + "Creates and returns a Volatile with an initial value of val." + {:added "1.7" + :tag clojure.lang.Volatile} + [val] + (clojure.lang.Volatile. val)) + +(defn vreset! + "Sets the value of volatile to newval without regard for the + current value. Returns newval." + {:added "1.7"} + [^clojure.lang.Volatile vol newval] + (.reset vol newval)) + +(defmacro vswap! + "Non-atomically swaps the value of the volatile as if: + (apply f current-value-of-vol args). Returns the value that + was swapped in." + {:added "1.7"} + [vol f & args] + (let [v (with-meta vol {:tag 'clojure.lang.Volatile})] + `(.reset ~v (~f (.deref ~v) ~@args)))) + +(defn volatile? + "Returns true if x is a volatile." + {:added "1.7"} + [x] + (instance? clojure.lang.Volatile x)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; fn stuff ;;;;;;;;;;;;;;;; + + +(defn comp + "Takes a set of functions and returns a fn that is the composition + of those fns. The returned fn takes a variable number of args, + applies the rightmost of fns to the args, the next + fn (right-to-left) to the result, etc." + {:added "1.0" + :static true} + ([] identity) + ([f] f) + ([f g] + (fn + ([] (f (g))) + ([x] (f (g x))) + ([x y] (f (g x y))) + ([x y z] (f (g x y z))) + ([x y z & args] (f (apply g x y z args))))) + ([f g & fs] + (reduce1 comp (list* f g fs)))) + +(defn juxt + "Takes a set of functions and returns a fn that is the juxtaposition + of those fns. The returned fn takes a variable number of args, and + returns a vector containing the result of applying each fn to the + args (left-to-right). + ((juxt a b c) x) => [(a x) (b x) (c x)]" + {:added "1.1" + :static true} + ([f] + (fn + ([] [(f)]) + ([x] [(f x)]) + ([x y] [(f x y)]) + ([x y z] [(f x y z)]) + ([x y z & args] [(apply f x y z args)]))) + ([f g] + (fn + ([] [(f) (g)]) + ([x] [(f x) (g x)]) + ([x y] [(f x y) (g x y)]) + ([x y z] [(f x y z) (g x y z)]) + ([x y z & args] [(apply f x y z args) (apply g x y z args)]))) + ([f g h] + (fn + ([] [(f) (g) (h)]) + ([x] [(f x) (g x) (h x)]) + ([x y] [(f x y) (g x y) (h x y)]) + ([x y z] [(f x y z) (g x y z) (h x y z)]) + ([x y z & args] [(apply f x y z args) (apply g x y z args) (apply h x y z args)]))) + ([f g h & fs] + (let [fs (list* f g h fs)] + (fn + ([] (reduce1 #(conj %1 (%2)) [] fs)) + ([x] (reduce1 #(conj %1 (%2 x)) [] fs)) + ([x y] (reduce1 #(conj %1 (%2 x y)) [] fs)) + ([x y z] (reduce1 #(conj %1 (%2 x y z)) [] fs)) + ([x y z & args] (reduce1 #(conj %1 (apply %2 x y z args)) [] fs)))))) + +(defn partial + "Takes a function f and fewer than the normal arguments to f, and + returns a fn that takes a variable number of additional args. When + called, the returned function calls f with args + additional args." + {:added "1.0" + :static true} + ([f] f) + ([f arg1] + (fn + ([] (f arg1)) + ([x] (f arg1 x)) + ([x y] (f arg1 x y)) + ([x y z] (f arg1 x y z)) + ([x y z & args] (apply f arg1 x y z args)))) + ([f arg1 arg2] + (fn + ([] (f arg1 arg2)) + ([x] (f arg1 arg2 x)) + ([x y] (f arg1 arg2 x y)) + ([x y z] (f arg1 arg2 x y z)) + ([x y z & args] (apply f arg1 arg2 x y z args)))) + ([f arg1 arg2 arg3] + (fn + ([] (f arg1 arg2 arg3)) + ([x] (f arg1 arg2 arg3 x)) + ([x y] (f arg1 arg2 arg3 x y)) + ([x y z] (f arg1 arg2 arg3 x y z)) + ([x y z & args] (apply f arg1 arg2 arg3 x y z args)))) + ([f arg1 arg2 arg3 & more] + (fn [& args] (apply f arg1 arg2 arg3 (concat more args))))) + +;;;;;;;;;;;;;;;;;;; sequence fns ;;;;;;;;;;;;;;;;;;;;;;; + +(defn sequence + "Coerces coll to a (possibly empty) sequence, if it is not already + one. Will not force a lazy seq. (sequence nil) yields (), When a + transducer is supplied, returns a lazy sequence of applications of + the transform to the items in coll(s), i.e. to the set of first + items of each coll, followed by the set of second + items in each coll, until any one of the colls is exhausted. Any + remaining items in other colls are ignored. The transform should accept + number-of-colls arguments" + {:added "1.0" + :static true} + ([coll] + (if (seq? coll) coll + (or (seq coll) ()))) + ([xform coll] + (or (clojure.lang.RT/chunkEnumeratorSeq ;;; chunkIteratorSeq + (clojure.lang.TransformerEnumerator/create xform (clojure.lang.RT/iter coll))) ;;; TransformerIterator + ())) + ([xform coll & colls] + (or (clojure.lang.RT/chunkEnumeratorSeq ;;; chunkIteratorSeq + (clojure.lang.TransformerEnumerator/createMulti ;;; TransformerIterator + xform + (map #(clojure.lang.RT/iter %) (cons coll colls)))) + ()))) + +(defn every? + "Returns true if (pred x) is logical true for every x in coll, else + false." + {:tag Boolean + :added "1.0" + :static true} + [pred coll] + (cond + (nil? (seq coll)) true + (pred (first coll)) (recur pred (next coll)) + :else false)) + +(def + ^{:tag Boolean + :doc "Returns false if (pred x) is logical true for every x in + coll, else true." + :arglists '([pred coll]) + :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)" - {:added "1.0" - :static true} + {:added "1.0" + :static true} [pred coll] - (when-let [s (seq coll)] - (or (pred (first s)) (recur pred (next s))))) - -(def - ^{:tag Boolean - :doc "Returns false if (pred x) is logical true for any x in coll, - else true." - :arglists '([pred coll]) - :added "1.0"} - not-any? (comp not some)) - -;will be redefed later with arg checks -(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] - (let [i (first bindings) - n (second bindings)] - `(let [n# (clojure.lang.RT/longCast ~n)] - (loop [~i 0] - (when (< ~i n#) - ~@body - (recur (unchecked-inc ~i))))))) - -(defn map - "Returns a lazy sequence consisting of the result of applying f to - the set of first items of each coll, followed by applying f to the - set of second items in each coll, until any one of the colls is - exhausted. Any remaining items in other colls are ignored. Function - f should accept number-of-colls arguments. Returns a transducer when - no collection is provided." - {:added "1.0" - :static true} - ([f] - (fn [rf] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (rf result (f input))) - ([result input & inputs] - (rf result (apply f input inputs)))))) - ([f coll] - (lazy-seq - (when-let [s (seq coll)] - (if (chunked-seq? s) - (let [c (chunk-first s) - size (int (count c)) - b (chunk-buffer size)] - (dotimes [i size] - (chunk-append b (f (.nth c i)))) - (chunk-cons (chunk b) (map f (chunk-rest s)))) - (cons (f (first s)) (map f (rest s))))))) - ([f c1 c2] - (lazy-seq - (let [s1 (seq c1) s2 (seq c2)] - (when (and s1 s2) - (cons (f (first s1) (first s2)) - (map f (rest s1) (rest s2))))))) - ([f c1 c2 c3] - (lazy-seq - (let [s1 (seq c1) s2 (seq c2) s3 (seq c3)] - (when (and s1 s2 s3) - (cons (f (first s1) (first s2) (first s3)) - (map f (rest s1) (rest s2) (rest s3))))))) - ([f c1 c2 c3 & colls] - (let [step (fn step [cs] - (lazy-seq - (let [ss (map seq cs)] - (when (every? identity ss) - (cons (map first ss) (step (map rest ss)))))))] - (map #(apply f %) (step (conj colls c3 c2 c1)))))) - -(defmacro declare - "defs the supplied var names with no bindings, useful for making forward declarations." - {:added "1.0"} - [& names] `(do ~@(map #(list 'def (vary-meta % assoc :declared true)) names))) - -(declare cat) - -(defn mapcat - "Returns the result of applying concat to the result of applying map - to f and colls. Thus function f should return a collection. Returns - a transducer when no collections are provided" - {:added "1.0" - :static true} - ([f] (comp (map f) cat)) - ([f & colls] - (apply concat (apply map f colls)))) - -(defn filter - "Returns a lazy sequence of the items in coll for which - (pred item) returns logical true. pred must be free of side-effects. - Returns a transducer when no collection is provided." - {:added "1.0" - :static true} - ([pred] - (fn [rf] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (if (pred input) - (rf result input) - result))))) - ([pred coll] - (lazy-seq - (when-let [s (seq coll)] - (if (chunked-seq? s) - (let [c (chunk-first s) - size (count c) - b (chunk-buffer size)] - (dotimes [i size] - (let [v (.nth c i)] - (when (pred v) - (chunk-append b v)))) - (chunk-cons (chunk b) (filter pred (chunk-rest s)))) - (let [f (first s) r (rest s)] - (if (pred f) - (cons f (filter pred r)) - (filter pred r)))))))) - - -(defn remove - "Returns a lazy sequence of the items in coll for which - (pred item) returns logical false. pred must be free of side-effects. - Returns a transducer when no collection is provided." - {:added "1.0" - :static true} - ([pred] (filter (complement pred))) - ([pred coll] - (filter (complement pred) coll))) - -(defn reduced - "Wraps x in a way such that a reduce will terminate with the value x" - {:added "1.5"} - [x] - (clojure.lang.Reduced. x)) - -(defn reduced? - "Returns true if x is the result of a call to reduced" - {:inline (fn [x] `(clojure.lang.RT/isReduced ~x )) - :inline-arities #{1} - :added "1.5"} - ([x] (clojure.lang.RT/isReduced x))) - -(defn ensure-reduced - "If x is already reduced?, returns it, else returns (reduced x)" - {:added "1.7"} - [x] - (if (reduced? x) x (reduced x))) - -(defn unreduced - "If x is reduced?, returns (deref x), else returns x" - {:added "1.7"} - [x] - (if (reduced? x) (deref x) x)) - -(defn take - "Returns a lazy sequence of the first n items in coll, or all items if - there are fewer than n. Returns a stateful transducer when - no collection is provided." - {:added "1.0" - :static true} - ([n] - (fn [rf] - (let [nv (volatile! n)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (let [n @nv - nn (vswap! nv dec) - result (if (pos? n) - (rf result input) - result)] - (if (not (pos? nn)) - (ensure-reduced result) - result))))))) - ([n coll] - (lazy-seq - (when (pos? n) - (when-let [s (seq coll)] - (cons (first s) (take (dec n) (rest s)))))))) - -(defn take-while - "Returns a lazy sequence of successive items from coll while - (pred item) returns logical true. pred must be free of side-effects. - Returns a transducer when no collection is provided." - {:added "1.0" - :static true} - ([pred] - (fn [rf] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (if (pred input) - (rf result input) - (reduced result)))))) - ([pred coll] - (lazy-seq - (when-let [s (seq coll)] - (when (pred (first s)) - (cons (first s) (take-while pred (rest s)))))))) - -(defn drop - "Returns a laziness-preserving sequence of all but the first n items in coll. - Returns a stateful transducer when no collection is provided." - {:added "1.0" - :static true} - ([n] - (fn [rf] - (let [nv (volatile! n)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (let [n @nv] - (vswap! nv dec) - (if (pos? n) - result - (rf result input)))))))) - ([n coll] - (if (instance? clojure.lang.IDrop coll) - (or (.drop ^clojure.lang.IDrop coll n) ()) - (let [step (fn [n coll] - (let [s (seq coll)] - (if (and (pos? n) s) - (recur (dec n) (rest s)) - s)))] - (lazy-seq (step n coll)))))) - -(defn drop-last - "Return a lazy sequence of all but the last n (default 1) items in coll" - {:added "1.0" - :static true} - ([coll] (drop-last 1 coll)) - ([n coll] (map (fn [x _] x) coll (drop n coll)))) - -(defn take-last - "Returns a seq of the last n items in coll. Depending on the type - of coll may be no better than linear time. For vectors, see also subvec." - {:added "1.1" - :static true} - [n coll] - (loop [s (seq coll), lead (seq (drop n coll))] - (if lead - (recur (next s) (next lead)) - s))) - -(defn drop-while - "Returns a lazy sequence of the items in coll starting from the - first item for which (pred item) returns logical false. Returns a - stateful transducer when no collection is provided." - {:added "1.0" - :static true} - ([pred] - (fn [rf] - (let [dv (volatile! true)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (let [drop? @dv] - (if (and drop? (pred input)) - result - (do - (vreset! dv nil) - (rf result input))))))))) - ([pred coll] - (let [step (fn [pred coll] - (let [s (seq coll)] - (if (and s (pred (first s))) - (recur pred (rest s)) - s)))] - (lazy-seq (step pred coll))))) - -(defn cycle - "Returns a lazy (infinite!) sequence of repetitions of the items in coll." - {:added "1.0" - :static true} - [coll] (clojure.lang.Cycle/create (seq coll))) - -(defn split-at - "Returns a vector of [(take n coll) (drop n coll)]" - {:added "1.0" - :static true} - [n coll] - [(take n coll) (drop n coll)]) - -(defn split-with - "Returns a vector of [(take-while pred coll) (drop-while pred coll)]" - {:added "1.0" - :static true} - [pred coll] - [(take-while pred coll) (drop-while pred coll)]) - -(defn repeat - "Returns a lazy (infinite! or length n if supplied) sequence of xs." - {:added "1.0" - :static true} - ([x] (clojure.lang.Repeat/create x)) - ([n x] (clojure.lang.Repeat/create n x))) - -(defn replicate - "DEPRECATED: Use 'repeat' instead. - Returns a lazy seq of n xs." - {:added "1.0" - :deprecated "1.3"} - [n x] (take n (repeat x))) - -(defn iterate - "Returns a lazy sequence of x, (f x), (f (f x)) etc. f must be free of side-effects" - {:added "1.0" - :static true} - [f x] (clojure.lang.Iterate/create f x) ) - -(defn range - "Returns a lazy seq of nums from start (inclusive) to end - (exclusive), by step, where start defaults to 0 and step to 1, and end to - infinity. When step is equal to 0, returns an infinite sequence of - start. When start is equal to end, returns empty list." - {:added "1.0" - :static true} - ([] - (iterate inc' 0)) - ([end] - (if (instance? Int64 end) ;;; Long - (clojure.lang.LongRange/create end) - (clojure.lang.Range/create end))) - ([start end] - (if (and (instance? Int64 start) (instance? Int64 end)) ;;; Long Long - (clojure.lang.LongRange/create start end) - (clojure.lang.Range/create start end))) - ([start end step] - (if (and (instance? Int64 start) (instance? Int64 end) (instance? Int64 step)) ;;; Long Long Long - (clojure.lang.LongRange/create start end step) - (clojure.lang.Range/create start end step)))) - -(defn merge - "Returns a map that consists of the rest of the maps conj-ed onto - the first. If a key occurs in more than one map, the mapping from - the latter (left-to-right) will be the mapping in the result." - {:added "1.0" - :static true} - [& maps] - (when (some identity maps) - (reduce1 #(conj (or %1 {}) %2) maps))) - -(defn merge-with - "Returns a map that consists of the rest of the maps conj-ed onto - the first. If a key occurs in more than one map, the mapping(s) - from the latter (left-to-right) will be combined with the mapping in - the result by calling (f val-in-result val-in-latter)." - {:added "1.0" - :static true} - [f & maps] - (when (some identity maps) - (let [merge-entry (fn [m e] - (let [k (key e) v (val e)] - (if (contains? m k) - (assoc m k (f (get m k) v)) - (assoc m k v)))) - merge2 (fn [m1 m2] - (reduce1 merge-entry (or m1 {}) (seq m2)))] - (reduce1 merge2 maps)))) - -(defn line-seq - "Returns the lines of text from rdr as a lazy sequence of strings. - rdr must implement java.io.BufferedReader." - {:added "1.0" - :static true} - [^System.IO.TextReader rdr ] ;;; [^java.io.BufferedReader rdr] - (when-let [line (.ReadLine rdr)] ;;; readLine - (cons line (lazy-seq (line-seq rdr))))) - -(defn ^:static comparator - "Returns an implementation of java.util.Comparator based upon pred." - {:added "1.0" - :static true} - [pred] - (fn [x y] - (cond (pred x y) -1 (pred y x) 1 :else 0))) - -(defn sort - "Returns a sorted sequence of the items in coll. If no comparator is - supplied, uses compare. comparator must implement - java.util.Comparator. Guaranteed to be stable: equal elements will - not be reordered. If coll is a Java array, it will be modified. To - avoid this, sort a copy of the array." - {:added "1.0" - :static true} - ([coll] - (sort compare coll)) - ([comp coll] ;;; We can't pass in a Comparator directly at this point, only a ClojureRuntimeDelegate : [^java.util.Comparator comp coll] - (if (seq coll) - (let [a (to-array coll)] - (. clojure.lang.RT (SortArray a comp)) ;;; see above: (. java.util.Arrays (sort a comp)) - (with-meta (seq a) (meta coll))) - ()))) - -(defn sort-by - "Returns a sorted sequence of the items in coll, where the sort - order is determined by comparing (keyfn item). If no comparator is - supplied, uses compare. comparator must implement - java.util.Comparator. Guaranteed to be stable: equal elements will - not be reordered. If coll is a Java array, it will be modified. To - avoid this, sort a copy of the array." - {:added "1.0" - :static true} - ([keyfn coll] - (sort-by keyfn compare coll)) - ([keyfn comp coll] ;;; --- Can't pass a Comparator directly: [keyfn ^java.util.Comparator comp coll] - (sort (fn [x y] (comp (keyfn x) (keyfn y))) coll))) ;;;(sort (fn [x y] (. comp (compare (keyfn x) (keyfn y)))) coll))) - -(defn dorun - "When lazy sequences are produced via functions that have side - effects, any effects other than those needed to produce the first - element in the seq do not occur until the seq is consumed. dorun can - be used to force any effects. Walks through the successive nexts of - the seq, does not retain the head and returns nil." - {:added "1.0" - :static true} - ([coll] - (when-let [s (seq coll)] - (recur (next s)))) - ([n coll] - (when (and (seq coll) (pos? n)) - (recur (dec n) (next coll))))) - -(defn doall - "When lazy sequences are produced via functions that have side - effects, any effects other than those needed to produce the first - element in the seq do not occur until the seq is consumed. doall can - be used to force any effects. Walks through the successive nexts of - the seq, retains the head and returns it, thus causing the entire - seq to reside in memory at one time." - {:added "1.0" - :static true} - ([coll] - (dorun coll) - coll) - ([n coll] - (dorun n coll) - coll)) - -(defn nthnext - "Returns the nth next of coll, (seq coll) when n is 0." - {:added "1.0" - :static true} - [coll n] - (if (instance? clojure.lang.IDrop coll) - (.drop ^clojure.lang.IDrop coll n) - (loop [n n xs (seq coll)] - (if (and xs (pos? n)) - (recur (dec n) (next xs)) - xs)))) - -(defn nthrest - "Returns the nth rest of coll, coll when n is 0." - {:added "1.3" - :static true} - [coll n] - (if (instance? clojure.lang.IDrop coll) - (or (.drop ^clojure.lang.IDrop coll n) ()) - (loop [n n xs coll] - (if-let [xs (and (pos? n) (seq xs))] - (recur (dec n) (rest xs)) - xs)))) - -(defn partition - "Returns a lazy sequence of lists of n items each, at offsets step - apart. If step is not supplied, defaults to n, i.e. the partitions - do not overlap. If a pad collection is supplied, use its elements as - necessary to complete last partition upto n items. In case there are - not enough padding elements, return a partition with less than n items." - {:added "1.0" - :static true} - ([n coll] - (partition n n coll)) - ([n step coll] - (lazy-seq - (when-let [s (seq coll)] - (let [p (doall (take n s))] - (when (= n (count p)) - (cons p (partition n step (nthrest s step)))))))) - ([n step pad coll] - (lazy-seq - (when-let [s (seq coll)] - (let [p (doall (take n s))] - (if (= n (count p)) - (cons p (partition n step pad (nthrest s step))) - (list (take n (concat p pad))))))))) - -;; evaluation - -(defn eval - "Evaluates the form data structure (not text!) and returns the result." - {:added "1.0" - :static true} - [form] (. clojure.lang.Compiler (eval form))) - -(defmacro doseq - "Repeatedly executes body (presumably for side-effects) with - bindings and filtering as provided by \"for\". Does not retain - the head of the sequence. Returns nil." - {:added "1.0"} - [seq-exprs & body] + (when-let [s (seq coll)] + (or (pred (first s)) (recur pred (next s))))) + +(def + ^{:tag Boolean + :doc "Returns false if (pred x) is logical true for any x in coll, + else true." + :arglists '([pred coll]) + :added "1.0"} + not-any? (comp not some)) + +;will be redefed later with arg checks +(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] + (let [i (first bindings) + n (second bindings)] + `(let [n# (clojure.lang.RT/longCast ~n)] + (loop [~i 0] + (when (< ~i n#) + ~@body + (recur (unchecked-inc ~i))))))) + +(defn map + "Returns a lazy sequence consisting of the result of applying f to + the set of first items of each coll, followed by applying f to the + set of second items in each coll, until any one of the colls is + exhausted. Any remaining items in other colls are ignored. Function + f should accept number-of-colls arguments. Returns a transducer when + no collection is provided." + {:added "1.0" + :static true} + ([f] + (fn [rf] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (rf result (f input))) + ([result input & inputs] + (rf result (apply f input inputs)))))) + ([f coll] + (lazy-seq + (when-let [s (seq coll)] + (if (chunked-seq? s) + (let [c (chunk-first s) + size (int (count c)) + b (chunk-buffer size)] + (dotimes [i size] + (chunk-append b (f (.nth c i)))) + (chunk-cons (chunk b) (map f (chunk-rest s)))) + (cons (f (first s)) (map f (rest s))))))) + ([f c1 c2] + (lazy-seq + (let [s1 (seq c1) s2 (seq c2)] + (when (and s1 s2) + (cons (f (first s1) (first s2)) + (map f (rest s1) (rest s2))))))) + ([f c1 c2 c3] + (lazy-seq + (let [s1 (seq c1) s2 (seq c2) s3 (seq c3)] + (when (and s1 s2 s3) + (cons (f (first s1) (first s2) (first s3)) + (map f (rest s1) (rest s2) (rest s3))))))) + ([f c1 c2 c3 & colls] + (let [step (fn step [cs] + (lazy-seq + (let [ss (map seq cs)] + (when (every? identity ss) + (cons (map first ss) (step (map rest ss)))))))] + (map #(apply f %) (step (conj colls c3 c2 c1)))))) + +(defmacro declare + "defs the supplied var names with no bindings, useful for making forward declarations." + {:added "1.0"} + [& names] `(do ~@(map #(list 'def (vary-meta % assoc :declared true)) names))) + +(declare cat) + +(defn mapcat + "Returns the result of applying concat to the result of applying map + to f and colls. Thus function f should return a collection. Returns + a transducer when no collections are provided" + {:added "1.0" + :static true} + ([f] (comp (map f) cat)) + ([f & colls] + (apply concat (apply map f colls)))) + +(defn filter + "Returns a lazy sequence of the items in coll for which + (pred item) returns logical true. pred must be free of side-effects. + Returns a transducer when no collection is provided." + {:added "1.0" + :static true} + ([pred] + (fn [rf] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (if (pred input) + (rf result input) + result))))) + ([pred coll] + (lazy-seq + (when-let [s (seq coll)] + (if (chunked-seq? s) + (let [c (chunk-first s) + size (count c) + b (chunk-buffer size)] + (dotimes [i size] + (let [v (.nth c i)] + (when (pred v) + (chunk-append b v)))) + (chunk-cons (chunk b) (filter pred (chunk-rest s)))) + (let [f (first s) r (rest s)] + (if (pred f) + (cons f (filter pred r)) + (filter pred r)))))))) + + +(defn remove + "Returns a lazy sequence of the items in coll for which + (pred item) returns logical false. pred must be free of side-effects. + Returns a transducer when no collection is provided." + {:added "1.0" + :static true} + ([pred] (filter (complement pred))) + ([pred coll] + (filter (complement pred) coll))) + +(defn reduced + "Wraps x in a way such that a reduce will terminate with the value x" + {:added "1.5"} + [x] + (clojure.lang.Reduced. x)) + +(defn reduced? + "Returns true if x is the result of a call to reduced" + {:inline (fn [x] `(clojure.lang.RT/isReduced ~x )) + :inline-arities #{1} + :added "1.5"} + ([x] (clojure.lang.RT/isReduced x))) + +(defn ensure-reduced + "If x is already reduced?, returns it, else returns (reduced x)" + {:added "1.7"} + [x] + (if (reduced? x) x (reduced x))) + +(defn unreduced + "If x is reduced?, returns (deref x), else returns x" + {:added "1.7"} + [x] + (if (reduced? x) (deref x) x)) + +(defn take + "Returns a lazy sequence of the first n items in coll, or all items if + there are fewer than n. Returns a stateful transducer when + no collection is provided." + {:added "1.0" + :static true} + ([n] + (fn [rf] + (let [nv (volatile! n)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [n @nv + nn (vswap! nv dec) + result (if (pos? n) + (rf result input) + result)] + (if (not (pos? nn)) + (ensure-reduced result) + result))))))) + ([n coll] + (lazy-seq + (when (pos? n) + (when-let [s (seq coll)] + (cons (first s) (take (dec n) (rest s)))))))) + +(defn take-while + "Returns a lazy sequence of successive items from coll while + (pred item) returns logical true. pred must be free of side-effects. + Returns a transducer when no collection is provided." + {:added "1.0" + :static true} + ([pred] + (fn [rf] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (if (pred input) + (rf result input) + (reduced result)))))) + ([pred coll] + (lazy-seq + (when-let [s (seq coll)] + (when (pred (first s)) + (cons (first s) (take-while pred (rest s)))))))) + +(defn drop + "Returns a laziness-preserving sequence of all but the first n items in coll. + Returns a stateful transducer when no collection is provided." + {:added "1.0" + :static true} + ([n] + (fn [rf] + (let [nv (volatile! n)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [n @nv] + (vswap! nv dec) + (if (pos? n) + result + (rf result input)))))))) + ([n coll] + (if (instance? clojure.lang.IDrop coll) + (or (.drop ^clojure.lang.IDrop coll n) ()) + (let [step (fn [n coll] + (let [s (seq coll)] + (if (and (pos? n) s) + (recur (dec n) (rest s)) + s)))] + (lazy-seq (step n coll)))))) + +(defn drop-last + "Return a lazy sequence of all but the last n (default 1) items in coll" + {:added "1.0" + :static true} + ([coll] (drop-last 1 coll)) + ([n coll] (map (fn [x _] x) coll (drop n coll)))) + +(defn take-last + "Returns a seq of the last n items in coll. Depending on the type + of coll may be no better than linear time. For vectors, see also subvec." + {:added "1.1" + :static true} + [n coll] + (loop [s (seq coll), lead (seq (drop n coll))] + (if lead + (recur (next s) (next lead)) + s))) + +(defn drop-while + "Returns a lazy sequence of the items in coll starting from the + first item for which (pred item) returns logical false. Returns a + stateful transducer when no collection is provided." + {:added "1.0" + :static true} + ([pred] + (fn [rf] + (let [dv (volatile! true)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [drop? @dv] + (if (and drop? (pred input)) + result + (do + (vreset! dv nil) + (rf result input))))))))) + ([pred coll] + (let [step (fn [pred coll] + (let [s (seq coll)] + (if (and s (pred (first s))) + (recur pred (rest s)) + s)))] + (lazy-seq (step pred coll))))) + +(defn cycle + "Returns a lazy (infinite!) sequence of repetitions of the items in coll." + {:added "1.0" + :static true} + [coll] (clojure.lang.Cycle/create (seq coll))) + +(defn split-at + "Returns a vector of [(take n coll) (drop n coll)]" + {:added "1.0" + :static true} + [n coll] + [(take n coll) (drop n coll)]) + +(defn split-with + "Returns a vector of [(take-while pred coll) (drop-while pred coll)]" + {:added "1.0" + :static true} + [pred coll] + [(take-while pred coll) (drop-while pred coll)]) + +(defn repeat + "Returns a lazy (infinite! or length n if supplied) sequence of xs." + {:added "1.0" + :static true} + ([x] (clojure.lang.Repeat/create x)) + ([n x] (clojure.lang.Repeat/create n x))) + +(defn replicate + "DEPRECATED: Use 'repeat' instead. + Returns a lazy seq of n xs." + {:added "1.0" + :deprecated "1.3"} + [n x] (take n (repeat x))) + +(defn iterate + "Returns a lazy sequence of x, (f x), (f (f x)) etc. f must be free of side-effects" + {:added "1.0" + :static true} + [f x] (clojure.lang.Iterate/create f x) ) + +(defn range + "Returns a lazy seq of nums from start (inclusive) to end + (exclusive), by step, where start defaults to 0 and step to 1, and end to + infinity. When step is equal to 0, returns an infinite sequence of + start. When start is equal to end, returns empty list." + {:added "1.0" + :static true} + ([] + (iterate inc' 0)) + ([end] + (if (instance? Int64 end) ;;; Long + (clojure.lang.LongRange/create end) + (clojure.lang.Range/create end))) + ([start end] + (if (and (instance? Int64 start) (instance? Int64 end)) ;;; Long Long + (clojure.lang.LongRange/create start end) + (clojure.lang.Range/create start end))) + ([start end step] + (if (and (instance? Int64 start) (instance? Int64 end) (instance? Int64 step)) ;;; Long Long Long + (clojure.lang.LongRange/create start end step) + (clojure.lang.Range/create start end step)))) + +(defn merge + "Returns a map that consists of the rest of the maps conj-ed onto + the first. If a key occurs in more than one map, the mapping from + the latter (left-to-right) will be the mapping in the result." + {:added "1.0" + :static true} + [& maps] + (when (some identity maps) + (reduce1 #(conj (or %1 {}) %2) maps))) + +(defn merge-with + "Returns a map that consists of the rest of the maps conj-ed onto + the first. If a key occurs in more than one map, the mapping(s) + from the latter (left-to-right) will be combined with the mapping in + the result by calling (f val-in-result val-in-latter)." + {:added "1.0" + :static true} + [f & maps] + (when (some identity maps) + (let [merge-entry (fn [m e] + (let [k (key e) v (val e)] + (if (contains? m k) + (assoc m k (f (get m k) v)) + (assoc m k v)))) + merge2 (fn [m1 m2] + (reduce1 merge-entry (or m1 {}) (seq m2)))] + (reduce1 merge2 maps)))) + +(defn line-seq + "Returns the lines of text from rdr as a lazy sequence of strings. + rdr must implement java.io.BufferedReader." + {:added "1.0" + :static true} + [^System.IO.TextReader rdr ] ;;; [^java.io.BufferedReader rdr] + (when-let [line (.ReadLine rdr)] ;;; readLine + (cons line (lazy-seq (line-seq rdr))))) + +(defn ^:static comparator + "Returns an implementation of java.util.Comparator based upon pred." + {:added "1.0" + :static true} + [pred] + (fn [x y] + (cond (pred x y) -1 (pred y x) 1 :else 0))) + +(defn sort + "Returns a sorted sequence of the items in coll. If no comparator is + supplied, uses compare. comparator must implement + java.util.Comparator. Guaranteed to be stable: equal elements will + not be reordered. If coll is a Java array, it will be modified. To + avoid this, sort a copy of the array." + {:added "1.0" + :static true} + ([coll] + (sort compare coll)) + ([comp coll] ;;; We can't pass in a Comparator directly at this point, only a ClojureRuntimeDelegate : [^java.util.Comparator comp coll] + (if (seq coll) + (let [a (to-array coll)] + (. clojure.lang.RT (SortArray a comp)) ;;; see above: (. java.util.Arrays (sort a comp)) + (with-meta (seq a) (meta coll))) + ()))) + +(defn sort-by + "Returns a sorted sequence of the items in coll, where the sort + order is determined by comparing (keyfn item). If no comparator is + supplied, uses compare. comparator must implement + java.util.Comparator. Guaranteed to be stable: equal elements will + not be reordered. If coll is a Java array, it will be modified. To + avoid this, sort a copy of the array." + {:added "1.0" + :static true} + ([keyfn coll] + (sort-by keyfn compare coll)) + ([keyfn comp coll] ;;; --- Can't pass a Comparator directly: [keyfn ^java.util.Comparator comp coll] + (sort (fn [x y] (comp (keyfn x) (keyfn y))) coll))) ;;;(sort (fn [x y] (. comp (compare (keyfn x) (keyfn y)))) coll))) + +(defn dorun + "When lazy sequences are produced via functions that have side + effects, any effects other than those needed to produce the first + element in the seq do not occur until the seq is consumed. dorun can + be used to force any effects. Walks through the successive nexts of + the seq, does not retain the head and returns nil." + {:added "1.0" + :static true} + ([coll] + (when-let [s (seq coll)] + (recur (next s)))) + ([n coll] + (when (and (seq coll) (pos? n)) + (recur (dec n) (next coll))))) + +(defn doall + "When lazy sequences are produced via functions that have side + effects, any effects other than those needed to produce the first + element in the seq do not occur until the seq is consumed. doall can + be used to force any effects. Walks through the successive nexts of + the seq, retains the head and returns it, thus causing the entire + seq to reside in memory at one time." + {:added "1.0" + :static true} + ([coll] + (dorun coll) + coll) + ([n coll] + (dorun n coll) + coll)) + +(defn nthnext + "Returns the nth next of coll, (seq coll) when n is 0." + {:added "1.0" + :static true} + [coll n] + (if (instance? clojure.lang.IDrop coll) + (.drop ^clojure.lang.IDrop coll n) + (loop [n n xs (seq coll)] + (if (and xs (pos? n)) + (recur (dec n) (next xs)) + xs)))) + +(defn nthrest + "Returns the nth rest of coll, coll when n is 0." + {:added "1.3" + :static true} + [coll n] + (if (instance? clojure.lang.IDrop coll) + (or (.drop ^clojure.lang.IDrop coll n) ()) + (loop [n n xs coll] + (if-let [xs (and (pos? n) (seq xs))] + (recur (dec n) (rest xs)) + xs)))) + +(defn partition + "Returns a lazy sequence of lists of n items each, at offsets step + apart. If step is not supplied, defaults to n, i.e. the partitions + do not overlap. If a pad collection is supplied, use its elements as + necessary to complete last partition upto n items. In case there are + not enough padding elements, return a partition with less than n items." + {:added "1.0" + :static true} + ([n coll] + (partition n n coll)) + ([n step coll] + (lazy-seq + (when-let [s (seq coll)] + (let [p (doall (take n s))] + (when (= n (count p)) + (cons p (partition n step (nthrest s step)))))))) + ([n step pad coll] + (lazy-seq + (when-let [s (seq coll)] + (let [p (doall (take n s))] + (if (= n (count p)) + (cons p (partition n step pad (nthrest s step))) + (list (take n (concat p pad))))))))) + +;; evaluation + +(defn eval + "Evaluates the form data structure (not text!) and returns the result." + {:added "1.0" + :static true} + [form] (. clojure.lang.Compiler (eval form))) + +(defmacro doseq + "Repeatedly executes body (presumably for side-effects) with + bindings and filtering as provided by \"for\". Does not retain + 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") - (let [step (fn step [recform exprs] - (if-not exprs - [true `(do ~@body)] - (let [k (first exprs) - v (second exprs)] - (if (keyword? k) - (let [steppair (step recform (nnext exprs)) - needrec (steppair 0) - subform (steppair 1)] - (cond - (= k :let) [needrec `(let ~v ~subform)] - (= k :while) [false `(when ~v - ~subform - ~@(when needrec [recform]))] - (= k :when) [false `(if ~v - (do - ~subform - ~@(when needrec [recform])) - ~recform)])) - (let [seq- (gensym "seq_") - chunk- (with-meta (gensym "chunk_") - {:tag 'clojure.lang.IChunk}) - count- (gensym "count_") - i- (gensym "i_") - recform `(recur (next ~seq-) nil 0 0) - steppair (step recform (nnext exprs)) - needrec (steppair 0) - subform (steppair 1) - recform-chunk - `(recur ~seq- ~chunk- ~count- (unchecked-inc ~i-)) - steppair-chunk (step recform-chunk (nnext exprs)) - subform-chunk (steppair-chunk 1)] - [true - `(loop [~seq- (seq ~v), ~chunk- nil, - ~count- 0, ~i- 0] - (if (< ~i- ~count-) - (let [~k (.nth ~chunk- ~i-)] - ~subform-chunk - ~@(when needrec [recform-chunk])) - (when-let [~seq- (seq ~seq-)] - (if (chunked-seq? ~seq-) - (let [c# (chunk-first ~seq-)] - (recur (chunk-rest ~seq-) c# - (int (count c#)) (int 0))) - (let [~k (first ~seq-)] - ~subform - ~@(when needrec [recform]))))))])))))] + (let [step (fn step [recform exprs] + (if-not exprs + [true `(do ~@body)] + (let [k (first exprs) + v (second exprs)] + (if (keyword? k) + (let [steppair (step recform (nnext exprs)) + needrec (steppair 0) + subform (steppair 1)] + (cond + (= k :let) [needrec `(let ~v ~subform)] + (= k :while) [false `(when ~v + ~subform + ~@(when needrec [recform]))] + (= k :when) [false `(if ~v + (do + ~subform + ~@(when needrec [recform])) + ~recform)])) + (let [seq- (gensym "seq_") + chunk- (with-meta (gensym "chunk_") + {:tag 'clojure.lang.IChunk}) + count- (gensym "count_") + i- (gensym "i_") + recform `(recur (next ~seq-) nil 0 0) + steppair (step recform (nnext exprs)) + needrec (steppair 0) + subform (steppair 1) + recform-chunk + `(recur ~seq- ~chunk- ~count- (unchecked-inc ~i-)) + steppair-chunk (step recform-chunk (nnext exprs)) + subform-chunk (steppair-chunk 1)] + [true + `(loop [~seq- (seq ~v), ~chunk- nil, + ~count- 0, ~i- 0] + (if (< ~i- ~count-) + (let [~k (.nth ~chunk- ~i-)] + ~subform-chunk + ~@(when needrec [recform-chunk])) + (when-let [~seq- (seq ~seq-)] + (if (chunked-seq? ~seq-) + (let [c# (chunk-first ~seq-)] + (recur (chunk-rest ~seq-) c# + (int (count c#)) (int 0))) + (let [~k (first ~seq-)] + ~subform + ~@(when needrec [recform]))))))])))))] (nth (step nil (seq seq-exprs)) 1))) - -(defn await - "Blocks the current thread (indefinitely!) until all actions - dispatched thus far, from this thread or agent, to the agent(s) have - occurred. Will block on failed agents. Will never return if - a failed agent is restarted with :clear-actions true or shutdown-agents was called." - {:added "1.0" - :static true} - [& agents] + +(defn await + "Blocks the current thread (indefinitely!) until all actions + dispatched thus far, from this thread or agent, to the agent(s) have + occurred. Will block on failed agents. Will never return if + a failed agent is restarted with :clear-actions true or shutdown-agents was called." + {:added "1.0" + :static true} + [& agents] (io! "await in transaction" (when *agent* (throw (new Exception "Can't await in agent action"))) @@ -3293,21 +3293,21 @@ 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] - (when (pos? (.getQueueCount a)) - (await a)) - a) - -(defn await-for - "Blocks the current thread until all actions dispatched thus - far (from this thread or agent) to the agents have occurred, or the - timeout (in milliseconds) has elapsed. Returns logical false if - returning due to timeout, logical true otherwise." - {:added "1.0" - :static true} - [timeout-ms & agents] + (. latch (Await))))) ;;; await + +(defn ^:static await1 [^clojure.lang.Agent a] + (when (pos? (.getQueueCount a)) + (await a)) + a) + +(defn await-for + "Blocks the current thread until all actions dispatched thus + far (from this thread or agent) to the agents have occurred, or the + timeout (in milliseconds) has elapsed. Returns logical false if + returning due to timeout, logical true otherwise." + {:added "1.0" + :static true} + [timeout-ms & agents] (io! "await-for in transaction" (when *agent* (throw (new Exception "Can't await in agent action"))) @@ -3315,14 +3315,14 @@ 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)))))) - + (. 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." - {:added "1.0"} + {:added "1.0"} [bindings & body] (assert-args (vector? bindings) "a vector for its binding" @@ -3333,101 +3333,101 @@ (loop [~i 0] (when (< ~i n#) ~@body - (recur (unchecked-inc ~i))))))) - -#_(defn into - "Returns a new coll consisting of to-coll with all of the items of - from-coll conjoined." - {:added "1.0"} - [to from] - (let [ret to items (seq from)] - (if items - (recur (conj ret (first items)) (next items)) - ret))) - -;;;;;;;;;;;;;;;;;;;;; editable collections ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defn transient - "Returns a new, transient version of the collection, in constant time." - {:added "1.1" - :static true} - [^clojure.lang.IEditableCollection coll] - (.asTransient coll)) - -(defn persistent! - "Returns a new, persistent version of the transient collection, in - constant time. The transient collection cannot be used after this - call, any such use will throw an exception." - {:added "1.1" - :static true} - [^clojure.lang.ITransientCollection coll] - (.persistent coll)) - -(defn conj! - "Adds x to the transient collection, and return coll. The 'addition' - may happen at different 'places' depending on the concrete type." - {:added "1.1" - :static true} - ([] (transient [])) - ([coll] coll) - ([^clojure.lang.ITransientCollection coll x] - (.conj coll x))) - -(defn assoc! - "When applied to a transient map, adds mapping of key(s) to - val(s). When applied to a transient vector, sets the val at index. - Note - index must be <= (count vector). Returns coll." - {:added "1.1" - :static true} - ([^clojure.lang.ITransientAssociative coll key val] (.assoc coll key val)) - ([^clojure.lang.ITransientAssociative coll key val & kvs] - (let [ret (.assoc coll key val)] - (if kvs - (recur ret (first kvs) (second kvs) (nnext kvs)) - ret)))) - -(defn dissoc! - "Returns a transient map that doesn't contain a mapping for key(s)." - {:added "1.1" - :static true} - ([^clojure.lang.ITransientMap map key] (.without map key)) - ([^clojure.lang.ITransientMap map key & ks] - (let [ret (.without map key)] - (if ks - (recur ret (first ks) (next ks)) - ret)))) - -(defn pop! - "Removes the last item from a transient vector. If - the collection is empty, throws an exception. Returns coll" - {:added "1.1" - :static true} - [^clojure.lang.ITransientVector coll] - (.pop coll)) - -(defn disj! - "disj[oin]. Returns a transient set of the same (hashed/sorted) type, that - does not contain key(s)." - {:added "1.1" - :static true} - ([set] set) - ([^clojure.lang.ITransientSet set key] - (. set (disjoin key))) - ([^clojure.lang.ITransientSet set key & ks] - (let [ret (. set (disjoin key))] - (if ks - (recur ret (first ks) (next ks)) - ret)))) - -;redef into with batch support -(defn ^:private into1 - "Returns a new coll consisting of to-coll with all of the items of - from-coll conjoined." - {:added "1.0" - :static true} - [to from] - (if (instance? clojure.lang.IEditableCollection to) - (persistent! (reduce1 conj! (transient to) from)) - (reduce1 conj to from))) + (recur (unchecked-inc ~i))))))) + +#_(defn into + "Returns a new coll consisting of to-coll with all of the items of + from-coll conjoined." + {:added "1.0"} + [to from] + (let [ret to items (seq from)] + (if items + (recur (conj ret (first items)) (next items)) + ret))) + +;;;;;;;;;;;;;;;;;;;;; editable collections ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defn transient + "Returns a new, transient version of the collection, in constant time." + {:added "1.1" + :static true} + [^clojure.lang.IEditableCollection coll] + (.asTransient coll)) + +(defn persistent! + "Returns a new, persistent version of the transient collection, in + constant time. The transient collection cannot be used after this + call, any such use will throw an exception." + {:added "1.1" + :static true} + [^clojure.lang.ITransientCollection coll] + (.persistent coll)) + +(defn conj! + "Adds x to the transient collection, and return coll. The 'addition' + may happen at different 'places' depending on the concrete type." + {:added "1.1" + :static true} + ([] (transient [])) + ([coll] coll) + ([^clojure.lang.ITransientCollection coll x] + (.conj coll x))) + +(defn assoc! + "When applied to a transient map, adds mapping of key(s) to + val(s). When applied to a transient vector, sets the val at index. + Note - index must be <= (count vector). Returns coll." + {:added "1.1" + :static true} + ([^clojure.lang.ITransientAssociative coll key val] (.assoc coll key val)) + ([^clojure.lang.ITransientAssociative coll key val & kvs] + (let [ret (.assoc coll key val)] + (if kvs + (recur ret (first kvs) (second kvs) (nnext kvs)) + ret)))) + +(defn dissoc! + "Returns a transient map that doesn't contain a mapping for key(s)." + {:added "1.1" + :static true} + ([^clojure.lang.ITransientMap map key] (.without map key)) + ([^clojure.lang.ITransientMap map key & ks] + (let [ret (.without map key)] + (if ks + (recur ret (first ks) (next ks)) + ret)))) + +(defn pop! + "Removes the last item from a transient vector. If + the collection is empty, throws an exception. Returns coll" + {:added "1.1" + :static true} + [^clojure.lang.ITransientVector coll] + (.pop coll)) + +(defn disj! + "disj[oin]. Returns a transient set of the same (hashed/sorted) type, that + does not contain key(s)." + {:added "1.1" + :static true} + ([set] set) + ([^clojure.lang.ITransientSet set key] + (. set (disjoin key))) + ([^clojure.lang.ITransientSet set key & ks] + (let [ret (. set (disjoin key))] + (if ks + (recur ret (first ks) (next ks)) + ret)))) + +;redef into with batch support +(defn ^:private into1 + "Returns a new coll consisting of to-coll with all of the items of + from-coll conjoined." + {:added "1.0" + :static true} + [to from] + (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*) @@ -3435,213 +3435,213 @@ 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"} + {:added "1.0"} [& import-symbols-or-lists] - (let [specs (map #(if (and (seq? %) (= 'quote (first %))) (second %) %) - import-symbols-or-lists)] - `(do ~@(map #(list 'clojure.core/import* %) - (reduce1 (fn [v spec] - (if (symbol? spec) - (conj v (name spec)) - (let [p (first spec) cs (rest spec)] - (into1 v (map #(str p "." %) cs))))) - [] specs))))) - -(defn into-array - "Returns an array with components set to the values in aseq. The array's - component type is type if provided, or the type of the first value in - aseq if present, or Object. All values in aseq must be compatible with - the component type. Class objects for the primitive types can be obtained - using, e.g., Integer/TYPE." - {:added "1.0" - :static true} - ([aseq] - (clojure.lang.RT/seqToTypedArray (seq aseq))) - ([type aseq] - (clojure.lang.RT/seqToTypedArray type (seq aseq)))) - -(defn ^{:private true} - array [& items] - (into-array items)) - -(defn class - "Returns the Class of x" - {:added "1.0" - :static true} - ^Type [^Object x] (if (nil? x) x (. x (GetType)))) ;;; Class getClass - -(defn type - "Returns the :type metadata of x, or its Class if none" - {:added "1.0" - :static true} - [x] - (or (get (meta x) :type) (class x))) - -(defn num - "Coerce to Number" - {:tag Object ;;; Number - :inline (fn [x] `(. clojure.lang.Numbers (num ~x))) - :added "1.0"} - [x] (. clojure.lang.Numbers (num x))) - - (defn long - "Coerce to long" - {:inline (fn [x] `(. clojure.lang.RT (longCast ~x))) - :added "1.0"} - [x] (. clojure.lang.RT (longCast x))) - -(defn float - "Coerce to float" - {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedFloatCast 'floatCast) ~x))) - :added "1.0"} - [x] (. clojure.lang.RT (floatCast x))) - -(defn double - "Coerce to double" - {:inline (fn [x] `(. clojure.lang.RT (doubleCast ~x))) - :added "1.0"} - [x] (. clojure.lang.RT (doubleCast x))) - -(defn short - "Coerce to short" - {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedShortCast 'shortCast) ~x))) - :added "1.0"} - [x] (. clojure.lang.RT (shortCast x))) - -(defn byte - "Coerce to byte" - {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedByteCast 'byteCast) ~x))) - :added "1.0"} - [x] (. clojure.lang.RT (byteCast x))) - -(defn char - "Coerce to char" - {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedCharCast 'charCast) ~x))) - :added "1.1"} - [x] (. clojure.lang.RT (charCast x))) - -(defn unchecked-byte - "Coerce to byte. Subject to rounding or truncation." - {:inline (fn [x] `(. clojure.lang.RT (uncheckedByteCast ~x))) - :added "1.3"} - [x] (clojure.lang.RT/uncheckedByteCast x)) ;;; ^Number - -(defn unchecked-short - "Coerce to short. Subject to rounding or truncation." - {:inline (fn [x] `(. clojure.lang.RT (uncheckedShortCast ~x))) - :added "1.3"} - [x] (clojure.lang.RT/uncheckedShortCast x)) ;;; ^Number - -(defn unchecked-char - "Coerce to char. Subject to rounding or truncation." - {:inline (fn [x] `(. clojure.lang.RT (uncheckedCharCast ~x))) - :added "1.3"} - [x] (. clojure.lang.RT (uncheckedCharCast x))) - -(defn unchecked-int - "Coerce to int. Subject to rounding or truncation." - {:inline (fn [x] `(. clojure.lang.RT (uncheckedIntCast ~x))) - :added "1.3"} - [x] (clojure.lang.RT/uncheckedIntCast x)) ;;; ^Number - -(defn unchecked-long - "Coerce to long. Subject to rounding or truncation." - {:inline (fn [x] `(. clojure.lang.RT (uncheckedLongCast ~x))) - :added "1.3"} - [x] (clojure.lang.RT/uncheckedLongCast x)) ;;; ^Number - -(defn unchecked-float - "Coerce to float. Subject to rounding." - {:inline (fn [x] `(. clojure.lang.RT (uncheckedFloatCast ~x))) - :added "1.3"} - [x] (clojure.lang.RT/uncheckedFloatCast x)) ;;; ^Number - -(defn unchecked-double - "Coerce to double. Subject to rounding." - {:inline (fn [x] `(. clojure.lang.RT (uncheckedDoubleCast ~x))) - :added "1.3"} - [x] (clojure.lang.RT/uncheckedDoubleCast x)) ;;; ^Number - + (let [specs (map #(if (and (seq? %) (= 'quote (first %))) (second %) %) + import-symbols-or-lists)] + `(do ~@(map #(list 'clojure.core/import* %) + (reduce1 (fn [v spec] + (if (symbol? spec) + (conj v (name spec)) + (let [p (first spec) cs (rest spec)] + (into1 v (map #(str p "." %) cs))))) + [] specs))))) + +(defn into-array + "Returns an array with components set to the values in aseq. The array's + component type is type if provided, or the type of the first value in + aseq if present, or Object. All values in aseq must be compatible with + the component type. Class objects for the primitive types can be obtained + using, e.g., Integer/TYPE." + {:added "1.0" + :static true} + ([aseq] + (clojure.lang.RT/seqToTypedArray (seq aseq))) + ([type aseq] + (clojure.lang.RT/seqToTypedArray type (seq aseq)))) + +(defn ^{:private true} + array [& items] + (into-array items)) + +(defn class + "Returns the Class of x" + {:added "1.0" + :static true} + ^Type [^Object x] (if (nil? x) x (. x (GetType)))) ;;; Class getClass + +(defn type + "Returns the :type metadata of x, or its Class if none" + {:added "1.0" + :static true} + [x] + (or (get (meta x) :type) (class x))) + +(defn num + "Coerce to Number" + {:tag Object ;;; Number + :inline (fn [x] `(. clojure.lang.Numbers (num ~x))) + :added "1.0"} + [x] (. clojure.lang.Numbers (num x))) + + (defn long + "Coerce to long" + {:inline (fn [x] `(. clojure.lang.RT (longCast ~x))) + :added "1.0"} + [x] (. clojure.lang.RT (longCast x))) + +(defn float + "Coerce to float" + {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedFloatCast 'floatCast) ~x))) + :added "1.0"} + [x] (. clojure.lang.RT (floatCast x))) + +(defn double + "Coerce to double" + {:inline (fn [x] `(. clojure.lang.RT (doubleCast ~x))) + :added "1.0"} + [x] (. clojure.lang.RT (doubleCast x))) + +(defn short + "Coerce to short" + {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedShortCast 'shortCast) ~x))) + :added "1.0"} + [x] (. clojure.lang.RT (shortCast x))) + +(defn byte + "Coerce to byte" + {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedByteCast 'byteCast) ~x))) + :added "1.0"} + [x] (. clojure.lang.RT (byteCast x))) + +(defn char + "Coerce to char" + {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedCharCast 'charCast) ~x))) + :added "1.1"} + [x] (. clojure.lang.RT (charCast x))) + +(defn unchecked-byte + "Coerce to byte. Subject to rounding or truncation." + {:inline (fn [x] `(. clojure.lang.RT (uncheckedByteCast ~x))) + :added "1.3"} + [x] (clojure.lang.RT/uncheckedByteCast x)) ;;; ^Number + +(defn unchecked-short + "Coerce to short. Subject to rounding or truncation." + {:inline (fn [x] `(. clojure.lang.RT (uncheckedShortCast ~x))) + :added "1.3"} + [x] (clojure.lang.RT/uncheckedShortCast x)) ;;; ^Number + +(defn unchecked-char + "Coerce to char. Subject to rounding or truncation." + {:inline (fn [x] `(. clojure.lang.RT (uncheckedCharCast ~x))) + :added "1.3"} + [x] (. clojure.lang.RT (uncheckedCharCast x))) + +(defn unchecked-int + "Coerce to int. Subject to rounding or truncation." + {:inline (fn [x] `(. clojure.lang.RT (uncheckedIntCast ~x))) + :added "1.3"} + [x] (clojure.lang.RT/uncheckedIntCast x)) ;;; ^Number + +(defn unchecked-long + "Coerce to long. Subject to rounding or truncation." + {:inline (fn [x] `(. clojure.lang.RT (uncheckedLongCast ~x))) + :added "1.3"} + [x] (clojure.lang.RT/uncheckedLongCast x)) ;;; ^Number + +(defn unchecked-float + "Coerce to float. Subject to rounding." + {:inline (fn [x] `(. clojure.lang.RT (uncheckedFloatCast ~x))) + :added "1.3"} + [x] (clojure.lang.RT/uncheckedFloatCast x)) ;;; ^Number + +(defn unchecked-double + "Coerce to double. Subject to rounding." + {:inline (fn [x] `(. clojure.lang.RT (uncheckedDoubleCast ~x))) + :added "1.3"} + [x] (clojure.lang.RT/uncheckedDoubleCast x)) ;;; ^Number + (defn number? "Returns true if x is a Number" - {:added "1.0" - :static true} + {:added "1.0" + :static true} [x] (. clojure.lang.Util (IsNumeric x))) ;;; (instance? Number x)) -(defn mod - "Modulus of num and div. Truncates toward negative infinity." - {:added "1.0" - :static true} - [num div] - (let [m (rem num div)] - (if (or (zero? m) (= (pos? num) (pos? div))) - m - (+ m div)))) - +(defn mod + "Modulus of num and div. Truncates toward negative infinity." + {:added "1.0" + :static true} + [num div] + (let [m (rem num div)] + (if (or (zero? m) (= (pos? num) (pos? div))) + m + (+ m div)))) + (defn ratio? "Returns true if n is a Ratio" - {:added "1.0" - :static true} + {:added "1.0" + :static true} [n] (instance? clojure.lang.Ratio n)) -(defn numerator - "Returns the numerator part of a Ratio." - {:tag BigInteger - :added "1.2" - :static true} - [r] - (.numerator ^clojure.lang.Ratio r)) - -(defn denominator - "Returns the denominator part of a Ratio." - {:tag BigInteger - :added "1.2" - :static true} - [r] - (.denominator ^clojure.lang.Ratio r)) +(defn numerator + "Returns the numerator part of a Ratio." + {:tag BigInteger + :added "1.2" + :static true} + [r] + (.numerator ^clojure.lang.Ratio r)) + +(defn denominator + "Returns the denominator part of a Ratio." + {:tag BigInteger + :added "1.2" + :static true} + [r] + (.denominator ^clojure.lang.Ratio r)) (defn decimal? "Returns true if n is a BigDecimal" - {:added "1.0" - :static true} + {:added "1.0" + :static true} [n] (instance? BigDecimal n)) (defn float? "Returns true if n is a floating point number" - {:added "1.0" - :static true} + {:added "1.0" + :static true} [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] + {:added "1.0" + :static true} + [n] (or (integer? n) (ratio? n) (decimal? n))) - + (defn bigint - "Coerce to BigInt" - {:tag clojure.lang.BigInt - :static true - :added "1.3"} - [x] (cond - (instance? clojure.lang.BigInt x) x - (instance? BigInteger x) (clojure.lang.BigInt/fromBigInteger x) - (decimal? x) (bigint (.ToBigInteger ^BigDecimal x)) - (float? x) (bigint (BigDecimal/Create (double x))) ;;; (. BigDecimal valueOf (double x)) - (ratio? x) (bigint (.BigIntegerValue ^clojure.lang.Ratio x)) - (number? x) (clojure.lang.BigInt/valueOf (long x)) (string? x) (bigint (BigInteger/Parse ^String x)) ;; DM: Added string clause - :else (bigint (BigInteger. x)))) - + "Coerce to BigInt" + {:tag clojure.lang.BigInt + :static true + :added "1.3"} + [x] (cond + (instance? clojure.lang.BigInt x) x + (instance? BigInteger x) (clojure.lang.BigInt/fromBigInteger x) + (decimal? x) (bigint (.ToBigInteger ^BigDecimal x)) + (float? x) (bigint (BigDecimal/Create (double x))) ;;; (. BigDecimal valueOf (double x)) + (ratio? x) (bigint (.BigIntegerValue ^clojure.lang.Ratio x)) + (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 - :added "1.0" - :static true} + :added "1.0" + :static true} [x] (cond (instance? BigInteger x) x (instance? clojure.lang.BigInt x) (.toBigInteger ^clojure.lang.BigInt x) @@ -3654,194 +3654,194 @@ (defn bigdec "Coerce to BigDecimal" {:tag BigDecimal - :added "1.0" - :static true} + :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 + (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))) - -(def ^:dynamic ^{:private true} print-initialized false) - -(defmulti print-method (fn [x writer] - (let [t (get (meta x) :type)] - (if (keyword? t) t (class x))))) -(defmulti print-dup (fn [x writer] (class x))) - -(defn pr-on - {:private true - :static true} - [x w] - (if *print-dup* - (print-dup x w) - (print-method x w)) - nil) - -(defn pr - "Prints the object(s) to the output stream that is the current value - of *out*. Prints the object(s), separated by spaces if there is - more than one. By default, pr and prn print in a way that objects - can be read by the reader" - {:dynamic true - :added "1.0"} - ([] nil) - ([x] - (pr-on x *out*)) - ([x & more] - (pr x) - (. *out* (Write \space)) ;; append -> Write - (if-let [nmore (next more)] - (recur (first more) nmore) - (apply pr more)))) - -(def ^:private ^String system-newline - (Environment/NewLine)) ;;; (System/getProperty "line.separator") - -(defn newline - "Writes a platform-specific newline to *out*" - {:added "1.0" - :static true} - [] - (. *out* (Write system-newline)) ;; append -> Write - nil) - -(defn flush - "Flushes the output stream that is the current value of - *out*" - {:added "1.0" - :static true} - [] - (. *out* (Flush)) ;; flush => Flush - nil) - -(defn prn - "Same as pr followed by (newline). Observes *flush-on-newline*" - {:added "1.0" - :static true} - [& more] - (apply pr more) - (newline) - (when *flush-on-newline* - (flush))) - -(defn print - "Prints the object(s) to the output stream that is the current value - of *out*. print and println produce output for human consumption." - {:added "1.0" - :static true} - [& more] - (binding [*print-readably* nil] - (apply pr more))) - -(defn println - "Same as print followed by (newline)" - {:added "1.0" - :static true} - [& more] - (binding [*print-readably* nil] - (apply prn more))) - -(defn read ;;; still have an error here, probably from leftover newline causing interference with REPL - "Reads the next object from stream, which must be an instance of - java.io.PushbackReader or some derivee. stream defaults to the - current value of *in*. - - Opts is a persistent map with valid keys: - :read-cond - :allow to process reader conditionals, or - :preserve to keep all branches - :features - persistent set of feature keywords for reader conditionals - :eof - on eof, return value unless :eofthrow, then throw. - if not specified, will throw - -Note that read can execute code (controlled by *read-eval*), - and as such should be used only with trusted sources. - - For data structure interop use clojure.edn/read" - {:added "1.0" - :static true} - ([] - (read *in*)) - ([stream] - (read stream true nil)) - ([stream eof-error? eof-value] - (read stream eof-error? eof-value false)) - ([stream eof-error? eof-value recursive?] - (. clojure.lang.LispReader (read stream (boolean eof-error?) eof-value recursive?))) - ([opts stream] - (. clojure.lang.LispReader (read stream opts)))) - -(defn read+string - "Like read, and taking the same args. stream must be a LineNumberingPushbackReader. - Returns a vector containing the object read and the (whitespace-trimmed) string read." - {:added "1.10"} - ([] (read+string *in*)) - ([stream] (read+string stream true nil)) - ([stream eof-error? eof-value] (read+string stream eof-error? eof-value false)) - ([^clojure.lang.LineNumberingTextReader stream eof-error? eof-value recursive?] ;;; LineNumberingPushbackReader - (try - (.CaptureString stream) ;;; .captureString - (let [o (read stream eof-error? eof-value recursive?) - s (.Trim (.GetString stream))] ;;; .trim .getString - [o s]) - (catch Exception ex ;;; Throwable - (.GetString stream) ;;; .getString - (throw ex)))) - ([opts ^clojure.lang.LineNumberingTextReader stream] ;;; LineNumberingPushbackReader - (try - (.CaptureString stream) ;;; .captureString - (let [o (read opts stream) - s (.Trim (.GetString stream))] ;;; .trim .getString - [o s]) - (catch Exception ex ;;; Throwable - (.GetString stream) ;;; .getString - (throw ex))))) - -(defn read-line - "Reads the next line from stream that is the current value of *in* ." - {:added "1.0" - :static true} - [] (.ReadLine ^System.IO.TextReader *in* )) ;;; readLine => ReadLine ^java.io.BufferedReader -;;; (if (instance? clojure.lang.LineNumberingPushbackReader *in*) -;;; (.readLine ^clojure.lang.LineNumberingPushbackReader *in*) -;;; (.readLine ^java.io.BufferedReader *in*))) - -(defn read-string - "Reads one object from the string s. Optionally include reader - options, as specified in read. - - Note that read-string can execute code (controlled by *read-eval*), - and as such should be used only with trusted sources. - - For data structure interop use clojure.edn/read-string" - {:added "1.0" - :static true} - ([s] (clojure.lang.RT/readString s)) - ([opts s] (clojure.lang.RT/readString s opts))) - + +(def ^:dynamic ^{:private true} print-initialized false) + +(defmulti print-method (fn [x writer] + (let [t (get (meta x) :type)] + (if (keyword? t) t (class x))))) +(defmulti print-dup (fn [x writer] (class x))) + +(defn pr-on + {:private true + :static true} + [x w] + (if *print-dup* + (print-dup x w) + (print-method x w)) + nil) + +(defn pr + "Prints the object(s) to the output stream that is the current value + of *out*. Prints the object(s), separated by spaces if there is + more than one. By default, pr and prn print in a way that objects + can be read by the reader" + {:dynamic true + :added "1.0"} + ([] nil) + ([x] + (pr-on x *out*)) + ([x & more] + (pr x) + (. *out* (Write \space)) ;; append -> Write + (if-let [nmore (next more)] + (recur (first more) nmore) + (apply pr more)))) + +(def ^:private ^String system-newline + (Environment/NewLine)) ;;; (System/getProperty "line.separator") + +(defn newline + "Writes a platform-specific newline to *out*" + {:added "1.0" + :static true} + [] + (. *out* (Write system-newline)) ;; append -> Write + nil) + +(defn flush + "Flushes the output stream that is the current value of + *out*" + {:added "1.0" + :static true} + [] + (. *out* (Flush)) ;; flush => Flush + nil) + +(defn prn + "Same as pr followed by (newline). Observes *flush-on-newline*" + {:added "1.0" + :static true} + [& more] + (apply pr more) + (newline) + (when *flush-on-newline* + (flush))) + +(defn print + "Prints the object(s) to the output stream that is the current value + of *out*. print and println produce output for human consumption." + {:added "1.0" + :static true} + [& more] + (binding [*print-readably* nil] + (apply pr more))) + +(defn println + "Same as print followed by (newline)" + {:added "1.0" + :static true} + [& more] + (binding [*print-readably* nil] + (apply prn more))) + +(defn read ;;; still have an error here, probably from leftover newline causing interference with REPL + "Reads the next object from stream, which must be an instance of + java.io.PushbackReader or some derivee. stream defaults to the + current value of *in*. + + Opts is a persistent map with valid keys: + :read-cond - :allow to process reader conditionals, or + :preserve to keep all branches + :features - persistent set of feature keywords for reader conditionals + :eof - on eof, return value unless :eofthrow, then throw. + if not specified, will throw + +Note that read can execute code (controlled by *read-eval*), + and as such should be used only with trusted sources. + + For data structure interop use clojure.edn/read" + {:added "1.0" + :static true} + ([] + (read *in*)) + ([stream] + (read stream true nil)) + ([stream eof-error? eof-value] + (read stream eof-error? eof-value false)) + ([stream eof-error? eof-value recursive?] + (. clojure.lang.LispReader (read stream (boolean eof-error?) eof-value recursive?))) + ([opts stream] + (. clojure.lang.LispReader (read stream opts)))) + +(defn read+string + "Like read, and taking the same args. stream must be a LineNumberingPushbackReader. + Returns a vector containing the object read and the (whitespace-trimmed) string read." + {:added "1.10"} + ([] (read+string *in*)) + ([stream] (read+string stream true nil)) + ([stream eof-error? eof-value] (read+string stream eof-error? eof-value false)) + ([^clojure.lang.LineNumberingTextReader stream eof-error? eof-value recursive?] ;;; LineNumberingPushbackReader + (try + (.CaptureString stream) ;;; .captureString + (let [o (read stream eof-error? eof-value recursive?) + s (.Trim (.GetString stream))] ;;; .trim .getString + [o s]) + (catch Exception ex ;;; Throwable + (.GetString stream) ;;; .getString + (throw ex)))) + ([opts ^clojure.lang.LineNumberingTextReader stream] ;;; LineNumberingPushbackReader + (try + (.CaptureString stream) ;;; .captureString + (let [o (read opts stream) + s (.Trim (.GetString stream))] ;;; .trim .getString + [o s]) + (catch Exception ex ;;; Throwable + (.GetString stream) ;;; .getString + (throw ex))))) + +(defn read-line + "Reads the next line from stream that is the current value of *in* ." + {:added "1.0" + :static true} + [] (.ReadLine ^System.IO.TextReader *in* )) ;;; readLine => ReadLine ^java.io.BufferedReader +;;; (if (instance? clojure.lang.LineNumberingPushbackReader *in*) +;;; (.readLine ^clojure.lang.LineNumberingPushbackReader *in*) +;;; (.readLine ^java.io.BufferedReader *in*))) + +(defn read-string + "Reads one object from the string s. Optionally include reader + options, as specified in read. + + Note that read-string can execute code (controlled by *read-eval*), + and as such should be used only with trusted sources. + + For data structure interop use clojure.edn/read-string" + {:added "1.0" + :static true} + ([s] (clojure.lang.RT/readString s)) + ([opts s] (clojure.lang.RT/readString s opts))) + (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} + {:added "1.0" + :static true} ([v start] (subvec v start (count v))) ([v start end] - (. clojure.lang.RT (subvec v start end)))) - -(defmacro with-open - "bindings => name init - + (. 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." - {:added "1.0"} + {:added "1.0"} [bindings & body] (assert-args (vector? bindings) "a vector for its binding" @@ -3855,503 +3855,503 @@ Note that read can execute code (controlled by *read-eval*), (. ~(with-meta (bindings 0) {:tag 'IDisposable}) Dispose)))) ;;; close => Dispose :else (throw (ArgumentException. ;;;IllegalArgumentException. "with-open only allows Symbols in bindings")))) - -(defmacro doto + +(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))" - {:added "1.0"} + {:added "1.0"} [x & forms] (let [gx (gensym)] `(let [~gx ~x] ~@(map (fn [f] - (with-meta - (if (seq? f) - `(~(first f) ~gx ~@(next f)) - `(~f ~gx)) + (with-meta + (if (seq? f) + `(~(first f) ~gx ~@(next f)) + `(~f ~gx)) (meta f))) forms) - ~gx))) - -(defmacro memfn - "Expands into code that creates a fn that expects to be passed an - object and any args and calls the named instance method on the - object passing the args. Use when you want to treat a Java method as - a first-class fn. name may be type-hinted with the method receiver's - type in order to avoid reflective calls." - {:added "1.0"} - [name & args] - (let [t (with-meta (gensym "target") - (meta name))] - `(fn [~t ~@args] - (. ~t (~name ~@args))))) - -(defmacro time - "Evaluates expr and prints the time it took. Returns the value of - expr." - {:added "1.0"} - [expr] - `(let [start# (. clojure.lang.RT (StartStopwatch)) ;;; (. System (nanoTime)) - ret# ~expr] - (prn (str "Elapsed time: " (. clojure.lang.RT StopStopwatch) " msecs")) ;;;(/ (double (- (. System (nanoTime)) start#)) 1000000.0) " msecs")) - ret#)) - - - -;;; Java version has: (import '(java.lang.reflect Array)) - -(defn alength - "Returns the length of the Java array. Works on arrays of all - types." - {:inline (fn [a] `(. clojure.lang.RT (alength ~a))) - :added "1.0"} - [array] (. clojure.lang.RT (alength array))) - -(defn aclone - "Returns a clone of the Java array. Works on arrays of known - types." - {:inline (fn [a] `(. clojure.lang.RT (aclone ~a))) - :added "1.0"} - [array] (. clojure.lang.RT (aclone array))) -;;; We have a real problem with aget/aset -- Java has only single dim arrays, CLR has true multidim. How to distinguish true multidim from ragged? For now, treat all as ragged. -(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-arities #{2} - :added "1.0"} - ([array 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))) - -(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-arities #{3} - :added "1.0"} - ([array idx val] - (. array (SetValue val idx)) ;;; was (. Array (set array idx val)) - val) - ([array idx idx2 & idxv] - (apply aset (aget array 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#)))) - -(def-aset - ^{:doc "Sets the value at the index/indices. Works on arrays of int. Returns val." - :added "1.0"} - aset-int setInt int) - -(def-aset - ^{:doc "Sets the value at the index/indices. Works on arrays of long. Returns val." - :added "1.0"} - aset-long setLong long) - -(def-aset - ^{:doc "Sets the value at the index/indices. Works on arrays of boolean. Returns val." - :added "1.0"} - aset-boolean setBoolean boolean) - -(def-aset - ^{:doc "Sets the value at the index/indices. Works on arrays of float. Returns val." - :added "1.0"} - aset-float setFloat float) - -(def-aset - ^{:doc "Sets the value at the index/indices. Works on arrays of double. Returns val." - :added "1.0"} - aset-double setDouble double) - -(def-aset - ^{:doc "Sets the value at the index/indices. Works on arrays of short. Returns val." - :added "1.0"} - aset-short setShort short) - -(def-aset - ^{:doc "Sets the value at the index/indices. Works on arrays of byte. Returns val." - :added "1.0"} - aset-byte setByte byte) - -(def-aset - ^{:doc "Sets the value at the index/indices. Works on arrays of char. Returns val." - :added "1.0"} - aset-char setChar char) -;;; Another ragged versus true multidimensional array problem -- we will go with ragged here so as not to break aget/aset -(defn make-array - "Creates and returns an array of instances of the specified class of - the specified dimension(s). Note that a class object is required. - Class objects can be obtained by using their imported or - fully-qualified name. Class objects for the primitive types can be - obtained using, e.g., Integer/TYPE." - {:added "1.0" - :static true} - ([^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) - ;;; ^"[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))) - a))) ;;; (. Array (newInstance type dimarray))))) - -(defn to-array-2d - "Returns a (potentially-ragged) 2-dimensional array of Objects - containing the contents of coll, which can be any Collection of any - Collection." - {:tag "System.Object[]" ;;; "[[Ljava.lang.Object;" - :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)))] - (loop [i 0 xs (seq coll)] - (when xs - (aset ret i (to-array (first xs))) - (recur (inc i) (next xs)))) - ret)) - -(defn macroexpand-1 - "If form represents a macro form, returns its expansion, - else returns form." - {:added "1.0" - :static true} - [form] - (. clojure.lang.Compiler (macroexpand1 form))) - -(defn macroexpand - "Repeatedly calls macroexpand-1 on form until it no longer - represents a macro form, then returns it. Note neither - macroexpand-1 nor macroexpand expand macros in subforms." - {:added "1.0" - :static true} - [form] - (let [ex (macroexpand-1 form)] - (if (identical? ex form) - form - (macroexpand ex)))) - -(defn create-struct - "Returns a structure basis object." - {:added "1.0" - :static true} - [& keys] - (. clojure.lang.PersistentStructMap (createSlotMap keys))) - -(defmacro defstruct - "Same as (def name (create-struct keys...))" - {:added "1.0" - :static true} - [name & keys] - `(def ~name (create-struct ~@keys))) - -(defn struct-map - "Returns a new structmap instance with the keys of the - structure-basis. keyvals may contain all, some or none of the basis - keys - where values are not supplied they will default to nil. - keyvals can also contain keys not in the basis." - {:added "1.0" - :static true} - [s & inits] - (. clojure.lang.PersistentStructMap (create s inits))) - -(defn struct - "Returns a new structmap instance with the keys of the - structure-basis. vals must be supplied for basis keys in order - - where values are not supplied they will default to nil." - {:added "1.0" - :static true} - [s & vals] - (. clojure.lang.PersistentStructMap (construct s vals))) - -(defn accessor - "Returns a fn that, given an instance of a structmap with the basis, - returns the value at the key. The key must be in the basis. The - returned function should be (slightly) more efficient than using - get, but such use of accessors should be limited to known - performance-critical areas." - {:added "1.0" - :static true} - [s key] - (. clojure.lang.PersistentStructMap (getAccessor s key))) - -(defn load-reader - "Sequentially read and evaluate the set of forms contained in the - stream/file" - {:added "1.0" - :static true} - [rdr] (. clojure.lang.Compiler (load rdr))) - -(defn load-string ;;; EOF problem here. - "Sequentially read and evaluate the set of forms contained in the - string" - {:added "1.0" - :static true} - [s] - (let [rdr (-> (System.IO.StringReader. s) ;;; was (java.io.StringReader. s) - (clojure.lang.LineNumberingTextReader.))] ;;; was (clojure.lang.LineNumberingPushbackReader.))] - (load-reader rdr))) - -(defn set? - "Returns true if x implements IPersistentSet" - {:added "1.0" - :static true} - [x] (instance? clojure.lang.IPersistentSet x)) - -(defn set - "Returns a set of the distinct elements of coll." - {:added "1.0" - :static true} - [coll] - (if (set? coll) - (with-meta coll nil) - (if (instance? clojure.lang.IReduceInit coll) - (persistent! (.reduce ^clojure.lang.IReduceInit coll conj! (transient #{}))) - (persistent! (reduce1 conj! (transient #{}) coll))))) - -(defn ^{:private true - :static true} - filter-key [keyfn pred amap] - (loop [ret {} es (seq amap)] - (if es - (if (pred (keyfn (first es))) - (recur (assoc ret (key (first es)) (val (first es))) (next es)) - (recur ret (next es))) - ret))) - -(defn find-ns - "Returns the namespace named by the symbol or nil if it doesn't exist." - {:added "1.0" - :static true} - [sym] (clojure.lang.Namespace/find sym)) - -(defn create-ns - "Create a new namespace named by the symbol if one doesn't already - exist, returns it or the already-existing namespace of the same - name." - {:added "1.0" - :static true} - [sym] (clojure.lang.Namespace/findOrCreate sym)) - -(defn remove-ns - "Removes the namespace named by the symbol. Use with caution. - Cannot be used to remove the clojure namespace." - {:added "1.0" - :static true} - [sym] (clojure.lang.Namespace/remove sym)) - -(defn all-ns - "Returns a sequence of all namespaces." - {:added "1.0" - :static true} - [] (clojure.lang.Namespace/all)) - -(defn the-ns + ~gx))) + +(defmacro memfn + "Expands into code that creates a fn that expects to be passed an + object and any args and calls the named instance method on the + object passing the args. Use when you want to treat a Java method as + a first-class fn. name may be type-hinted with the method receiver's + type in order to avoid reflective calls." + {:added "1.0"} + [name & args] + (let [t (with-meta (gensym "target") + (meta name))] + `(fn [~t ~@args] + (. ~t (~name ~@args))))) + +(defmacro time + "Evaluates expr and prints the time it took. Returns the value of + expr." + {:added "1.0"} + [expr] + `(let [start# (. clojure.lang.RT (StartStopwatch)) ;;; (. System (nanoTime)) + ret# ~expr] + (prn (str "Elapsed time: " (. clojure.lang.RT StopStopwatch) " msecs")) ;;;(/ (double (- (. System (nanoTime)) start#)) 1000000.0) " msecs")) + ret#)) + + + +;;; Java version has: (import '(java.lang.reflect Array)) + +(defn alength + "Returns the length of the Java array. Works on arrays of all + types." + {:inline (fn [a] `(. clojure.lang.RT (alength ~a))) + :added "1.0"} + [array] (. clojure.lang.RT (alength array))) + +(defn aclone + "Returns a clone of the Java array. Works on arrays of known + types." + {:inline (fn [a] `(. clojure.lang.RT (aclone ~a))) + :added "1.0"} + [array] (. clojure.lang.RT (aclone array))) +;;; We have a real problem with aget/aset -- Java has only single dim arrays, CLR has true multidim. How to distinguish true multidim from ragged? For now, treat all as ragged. +(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-arities #{2} + :added "1.0"} + ([array 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))) + +(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-arities #{3} + :added "1.0"} + ([array idx val] + (. array (SetValue val idx)) ;;; was (. Array (set array idx val)) + val) + ([array idx idx2 & idxv] + (apply aset (aget array 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#)))) + +(def-aset + ^{:doc "Sets the value at the index/indices. Works on arrays of int. Returns val." + :added "1.0"} + aset-int setInt int) + +(def-aset + ^{:doc "Sets the value at the index/indices. Works on arrays of long. Returns val." + :added "1.0"} + aset-long setLong long) + +(def-aset + ^{:doc "Sets the value at the index/indices. Works on arrays of boolean. Returns val." + :added "1.0"} + aset-boolean setBoolean boolean) + +(def-aset + ^{:doc "Sets the value at the index/indices. Works on arrays of float. Returns val." + :added "1.0"} + aset-float setFloat float) + +(def-aset + ^{:doc "Sets the value at the index/indices. Works on arrays of double. Returns val." + :added "1.0"} + aset-double setDouble double) + +(def-aset + ^{:doc "Sets the value at the index/indices. Works on arrays of short. Returns val." + :added "1.0"} + aset-short setShort short) + +(def-aset + ^{:doc "Sets the value at the index/indices. Works on arrays of byte. Returns val." + :added "1.0"} + aset-byte setByte byte) + +(def-aset + ^{:doc "Sets the value at the index/indices. Works on arrays of char. Returns val." + :added "1.0"} + aset-char setChar char) +;;; Another ragged versus true multidimensional array problem -- we will go with ragged here so as not to break aget/aset +(defn make-array + "Creates and returns an array of instances of the specified class of + the specified dimension(s). Note that a class object is required. + Class objects can be obtained by using their imported or + fully-qualified name. Class objects for the primitive types can be + obtained using, e.g., Integer/TYPE." + {:added "1.0" + :static true} + ([^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) + ;;; ^"[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))) + a))) ;;; (. Array (newInstance type dimarray))))) + +(defn to-array-2d + "Returns a (potentially-ragged) 2-dimensional array of Objects + containing the contents of coll, which can be any Collection of any + Collection." + {:tag "System.Object[]" ;;; "[[Ljava.lang.Object;" + :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)))] + (loop [i 0 xs (seq coll)] + (when xs + (aset ret i (to-array (first xs))) + (recur (inc i) (next xs)))) + ret)) + +(defn macroexpand-1 + "If form represents a macro form, returns its expansion, + else returns form." + {:added "1.0" + :static true} + [form] + (. clojure.lang.Compiler (macroexpand1 form))) + +(defn macroexpand + "Repeatedly calls macroexpand-1 on form until it no longer + represents a macro form, then returns it. Note neither + macroexpand-1 nor macroexpand expand macros in subforms." + {:added "1.0" + :static true} + [form] + (let [ex (macroexpand-1 form)] + (if (identical? ex form) + form + (macroexpand ex)))) + +(defn create-struct + "Returns a structure basis object." + {:added "1.0" + :static true} + [& keys] + (. clojure.lang.PersistentStructMap (createSlotMap keys))) + +(defmacro defstruct + "Same as (def name (create-struct keys...))" + {:added "1.0" + :static true} + [name & keys] + `(def ~name (create-struct ~@keys))) + +(defn struct-map + "Returns a new structmap instance with the keys of the + structure-basis. keyvals may contain all, some or none of the basis + keys - where values are not supplied they will default to nil. + keyvals can also contain keys not in the basis." + {:added "1.0" + :static true} + [s & inits] + (. clojure.lang.PersistentStructMap (create s inits))) + +(defn struct + "Returns a new structmap instance with the keys of the + structure-basis. vals must be supplied for basis keys in order - + where values are not supplied they will default to nil." + {:added "1.0" + :static true} + [s & vals] + (. clojure.lang.PersistentStructMap (construct s vals))) + +(defn accessor + "Returns a fn that, given an instance of a structmap with the basis, + returns the value at the key. The key must be in the basis. The + returned function should be (slightly) more efficient than using + get, but such use of accessors should be limited to known + performance-critical areas." + {:added "1.0" + :static true} + [s key] + (. clojure.lang.PersistentStructMap (getAccessor s key))) + +(defn load-reader + "Sequentially read and evaluate the set of forms contained in the + stream/file" + {:added "1.0" + :static true} + [rdr] (. clojure.lang.Compiler (load rdr))) + +(defn load-string ;;; EOF problem here. + "Sequentially read and evaluate the set of forms contained in the + string" + {:added "1.0" + :static true} + [s] + (let [rdr (-> (System.IO.StringReader. s) ;;; was (java.io.StringReader. s) + (clojure.lang.LineNumberingTextReader.))] ;;; was (clojure.lang.LineNumberingPushbackReader.))] + (load-reader rdr))) + +(defn set? + "Returns true if x implements IPersistentSet" + {:added "1.0" + :static true} + [x] (instance? clojure.lang.IPersistentSet x)) + +(defn set + "Returns a set of the distinct elements of coll." + {:added "1.0" + :static true} + [coll] + (if (set? coll) + (with-meta coll nil) + (if (instance? clojure.lang.IReduceInit coll) + (persistent! (.reduce ^clojure.lang.IReduceInit coll conj! (transient #{}))) + (persistent! (reduce1 conj! (transient #{}) coll))))) + +(defn ^{:private true + :static true} + filter-key [keyfn pred amap] + (loop [ret {} es (seq amap)] + (if es + (if (pred (keyfn (first es))) + (recur (assoc ret (key (first es)) (val (first es))) (next es)) + (recur ret (next es))) + ret))) + +(defn find-ns + "Returns the namespace named by the symbol or nil if it doesn't exist." + {:added "1.0" + :static true} + [sym] (clojure.lang.Namespace/find sym)) + +(defn create-ns + "Create a new namespace named by the symbol if one doesn't already + exist, returns it or the already-existing namespace of the same + name." + {:added "1.0" + :static true} + [sym] (clojure.lang.Namespace/findOrCreate sym)) + +(defn remove-ns + "Removes the namespace named by the symbol. Use with caution. + Cannot be used to remove the clojure namespace." + {:added "1.0" + :static true} + [sym] (clojure.lang.Namespace/remove sym)) + +(defn all-ns + "Returns a sequence of all namespaces." + {:added "1.0" + :static true} + [] (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 - found." - {:added "1.0" - :static true} - ^clojure.lang.Namespace [x] - (if (instance? clojure.lang.Namespace x) - x - (or (find-ns x) (throw (Exception. (str "No namespace: " x " found")))))) - -(defn ns-name - "Returns the name of the namespace, a symbol." - {:added "1.0" - :static true} - [ns] - (.getName (the-ns ns))) - -(defn ns-map - "Returns a map of all the mappings for the namespace." - {:added "1.0" - :static true} - [ns] - (.getMappings (the-ns ns))) - -(defn ns-unmap - "Removes the mappings for the symbol from the namespace." - {:added "1.0" - :static true} - [ns sym] - (.unmap (the-ns ns) sym)) -; commented out in Java original -;(defn export [syms] -; (doseq [sym syms] -; (.. *ns* (intern sym) (setExported true)))) - -(defn ns-publics - "Returns a map of the public intern mappings for the namespace." - {:added "1.0" - :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 - (= ns (.ns v)) - (.isPublic v))) - (ns-map ns)))) - -(defn ns-imports - "Returns a map of the import mappings for the namespace." - {:added "1.0" - :static true} - [ns] - (filter-key val (partial instance? Type) (ns-map ns))) ;;; Class => Type - -(defn ns-interns - "Returns a map of the intern mappings for the namespace." - {:added "1.0" - :static true} - [ns] - (let [ns (the-ns ns)] - (filter-key val (fn [^clojure.lang.Var v] (and (instance? clojure.lang.Var v) - (= ns (.ns v)))) - (ns-map ns)))) - -(defn refer - "refers to all public vars of ns, subject to filters. - filters can include at most one each of: - - :exclude list-of-symbols - :only list-of-symbols - :rename map-of-fromsymbol-tosymbol - - For each public interned var in the namespace named by the symbol, - adds a mapping from the name of the var to the var to the current - namespace. Throws an exception if name is already mapped to - something else in the current namespace. Filters can be used to - select a subset, via inclusion or exclusion, or to provide a mapping - to a symbol different from the var's name, in order to prevent - clashes. Use :use in the ns macro in preference to calling this directly." - {:added "1.0"} - [ns-sym & filters] - (let [ns (or (find-ns ns-sym) (throw (new Exception (str "No namespace: " ns-sym)))) - fs (apply hash-map filters) - nspublics (ns-publics ns) - rename (or (:rename fs) {}) - exclude (set (:exclude fs)) - to-do (if (= :all (:refer fs)) - (keys nspublics) - (or (:refer fs) (:only fs) (keys nspublics)))] - (when (and to-do (not (instance? clojure.lang.Sequential to-do))) - (throw (new Exception ":only/:refer value must be a sequential collection of symbols"))) - (doseq [sym to-do] - (when-not (exclude sym) - (let [v (nspublics sym)] - (when-not v - (throw (new InvalidOperationException ;;; java.lang.IllegalAccessError - (if (get (ns-interns ns) sym) - (str sym " is not public") - (str sym " does not exist"))))) - (. *ns* (refer (or (rename sym) sym) v))))))) - -(defn ns-refers - "Returns a map of the refer mappings for the namespace." - {:added "1.0" - :static true} - [ns] - (let [ns (the-ns ns)] - (filter-key val (fn [^clojure.lang.Var v] (and (instance? clojure.lang.Var v) - (not= ns (.ns v)))) - (ns-map ns)))) - -(defn alias - "Add an alias in the current namespace to another - namespace. Arguments are two symbols: the alias to be used, and - the symbolic name of the target namespace. Use :as in the ns macro in preference - to calling this directly." - {:added "1.0" - :static true} - [alias namespace-sym] - (.addAlias *ns* alias (the-ns namespace-sym))) - -(defn ns-aliases - "Returns a map of the aliases for the namespace." - {:added "1.0" - :static true} - [ns] - (.getAliases (the-ns ns))) - -(defn ns-unalias - "Removes the alias for the symbol from the namespace." - {:added "1.0" - :static true} - [ns sym] - (.removeAlias (the-ns ns) sym)) - -(defn take-nth - "Returns a lazy seq of every nth item in coll. Returns a stateful - transducer when no collection is provided." - {:added "1.0" - :static true} - ([n] - (fn [rf] - (let [iv (volatile! -1)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (let [i (vswap! iv inc)] - (if (zero? (rem i n)) - (rf result input) - result))))))) - ([n coll] - (lazy-seq - (when-let [s (seq coll)] - (cons (first s) (take-nth n (drop n s))))))) - -(defn interleave - "Returns a lazy seq of the first item in each coll, then the second etc." - {:added "1.0" - :static true} - ([] ()) - ([c1] (lazy-seq c1)) - ([c1 c2] - (lazy-seq - (let [s1 (seq c1) s2 (seq c2)] - (when (and s1 s2) - (cons (first s1) (cons (first s2) - (interleave (rest s1) (rest s2)))))))) - ([c1 c2 & colls] - (lazy-seq - (let [ss (map seq (conj colls c2 c1))] - (when (every? identity ss) - (concat (map first ss) (apply interleave (map rest ss)))))))) - -(defn var-get - "Gets the value in the var object" - {:added "1.0" - :static true} - [^clojure.lang.Var x] (. x (get))) - -(defn var-set - "Sets the value in the var object to val. The var must be - thread-locally bound." - {:added "1.0" - :static true} - [^clojure.lang.Var x val] (. x (set val))) - -(defmacro with-local-vars - "varbinding=> symbol init-expr - - Executes the exprs in a context in which the symbols are bound to - vars with per-thread bindings to the init-exprs. The symbols refer - to the var objects themselves, and must be accessed with var-get and - var-set" - {:added "1.0"} + found." + {:added "1.0" + :static true} + ^clojure.lang.Namespace [x] + (if (instance? clojure.lang.Namespace x) + x + (or (find-ns x) (throw (Exception. (str "No namespace: " x " found")))))) + +(defn ns-name + "Returns the name of the namespace, a symbol." + {:added "1.0" + :static true} + [ns] + (.getName (the-ns ns))) + +(defn ns-map + "Returns a map of all the mappings for the namespace." + {:added "1.0" + :static true} + [ns] + (.getMappings (the-ns ns))) + +(defn ns-unmap + "Removes the mappings for the symbol from the namespace." + {:added "1.0" + :static true} + [ns sym] + (.unmap (the-ns ns) sym)) +; commented out in Java original +;(defn export [syms] +; (doseq [sym syms] +; (.. *ns* (intern sym) (setExported true)))) + +(defn ns-publics + "Returns a map of the public intern mappings for the namespace." + {:added "1.0" + :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 + (= ns (.ns v)) + (.isPublic v))) + (ns-map ns)))) + +(defn ns-imports + "Returns a map of the import mappings for the namespace." + {:added "1.0" + :static true} + [ns] + (filter-key val (partial instance? Type) (ns-map ns))) ;;; Class => Type + +(defn ns-interns + "Returns a map of the intern mappings for the namespace." + {:added "1.0" + :static true} + [ns] + (let [ns (the-ns ns)] + (filter-key val (fn [^clojure.lang.Var v] (and (instance? clojure.lang.Var v) + (= ns (.ns v)))) + (ns-map ns)))) + +(defn refer + "refers to all public vars of ns, subject to filters. + filters can include at most one each of: + + :exclude list-of-symbols + :only list-of-symbols + :rename map-of-fromsymbol-tosymbol + + For each public interned var in the namespace named by the symbol, + adds a mapping from the name of the var to the var to the current + namespace. Throws an exception if name is already mapped to + something else in the current namespace. Filters can be used to + select a subset, via inclusion or exclusion, or to provide a mapping + to a symbol different from the var's name, in order to prevent + clashes. Use :use in the ns macro in preference to calling this directly." + {:added "1.0"} + [ns-sym & filters] + (let [ns (or (find-ns ns-sym) (throw (new Exception (str "No namespace: " ns-sym)))) + fs (apply hash-map filters) + nspublics (ns-publics ns) + rename (or (:rename fs) {}) + exclude (set (:exclude fs)) + to-do (if (= :all (:refer fs)) + (keys nspublics) + (or (:refer fs) (:only fs) (keys nspublics)))] + (when (and to-do (not (instance? clojure.lang.Sequential to-do))) + (throw (new Exception ":only/:refer value must be a sequential collection of symbols"))) + (doseq [sym to-do] + (when-not (exclude sym) + (let [v (nspublics sym)] + (when-not v + (throw (new InvalidOperationException ;;; java.lang.IllegalAccessError + (if (get (ns-interns ns) sym) + (str sym " is not public") + (str sym " does not exist"))))) + (. *ns* (refer (or (rename sym) sym) v))))))) + +(defn ns-refers + "Returns a map of the refer mappings for the namespace." + {:added "1.0" + :static true} + [ns] + (let [ns (the-ns ns)] + (filter-key val (fn [^clojure.lang.Var v] (and (instance? clojure.lang.Var v) + (not= ns (.ns v)))) + (ns-map ns)))) + +(defn alias + "Add an alias in the current namespace to another + namespace. Arguments are two symbols: the alias to be used, and + the symbolic name of the target namespace. Use :as in the ns macro in preference + to calling this directly." + {:added "1.0" + :static true} + [alias namespace-sym] + (.addAlias *ns* alias (the-ns namespace-sym))) + +(defn ns-aliases + "Returns a map of the aliases for the namespace." + {:added "1.0" + :static true} + [ns] + (.getAliases (the-ns ns))) + +(defn ns-unalias + "Removes the alias for the symbol from the namespace." + {:added "1.0" + :static true} + [ns sym] + (.removeAlias (the-ns ns) sym)) + +(defn take-nth + "Returns a lazy seq of every nth item in coll. Returns a stateful + transducer when no collection is provided." + {:added "1.0" + :static true} + ([n] + (fn [rf] + (let [iv (volatile! -1)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [i (vswap! iv inc)] + (if (zero? (rem i n)) + (rf result input) + result))))))) + ([n coll] + (lazy-seq + (when-let [s (seq coll)] + (cons (first s) (take-nth n (drop n s))))))) + +(defn interleave + "Returns a lazy seq of the first item in each coll, then the second etc." + {:added "1.0" + :static true} + ([] ()) + ([c1] (lazy-seq c1)) + ([c1 c2] + (lazy-seq + (let [s1 (seq c1) s2 (seq c2)] + (when (and s1 s2) + (cons (first s1) (cons (first s2) + (interleave (rest s1) (rest s2)))))))) + ([c1 c2 & colls] + (lazy-seq + (let [ss (map seq (conj colls c2 c1))] + (when (every? identity ss) + (concat (map first ss) (apply interleave (map rest ss)))))))) + +(defn var-get + "Gets the value in the var object" + {:added "1.0" + :static true} + [^clojure.lang.Var x] (. x (get))) + +(defn var-set + "Sets the value in the var object to val. The var must be + thread-locally bound." + {:added "1.0" + :static true} + [^clojure.lang.Var x val] (. x (set val))) + +(defmacro with-local-vars + "varbinding=> symbol init-expr + + Executes the exprs in a context in which the symbols are bound to + vars with per-thread bindings to the init-exprs. The symbols refer + 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" @@ -4361,252 +4361,252 @@ Note that read can execute code (controlled by *read-eval*), (. clojure.lang.Var (pushThreadBindings (hash-map ~@name-vals-vec))) (try ~@body - (finally (. clojure.lang.Var (popThreadBindings)))))) - -(defn ns-resolve - "Returns the var or Class to which a symbol will be resolved in the - namespace (unless found in the environment), else nil. Note that - if the symbol is fully qualified, the var/Class to which it resolves - need not be present in the namespace." - {:added "1.0" - :static true} - ([ns sym] - (ns-resolve ns nil sym)) - ([ns env sym] - (when-not (contains? env sym) - (clojure.lang.Compiler/maybeResolveIn (the-ns ns) sym)))) - -(defn resolve - "same as (ns-resolve *ns* symbol) or (ns-resolve *ns* &env symbol)" - {:added "1.0" - :static true} - ([sym] (ns-resolve *ns* sym)) - ([env sym] (ns-resolve *ns* env sym))) - -(defn array-map - "Constructs an array-map. If any keys are equal, they are handled as - if by repeated uses of assoc." - {:added "1.0" - :static true} - ([] (. clojure.lang.PersistentArrayMap EMPTY)) - ([& keyvals] - (let [ary (to-array keyvals)] - (if (odd? (alength ary)) - (throw (ArgumentException. (str "No value supplied for key: " (last keyvals)))) ;;; IllegalArgumentException - (clojure.lang.PersistentArrayMap/createAsIfByAssoc ary))))) - -(defn seq-to-map-for-destructuring - "Builds a map from a seq as described in - https://clojure.org/reference/special_forms#keyword-arguments" - {:added "1.11"} - [s] - (if (next s) - (clojure.lang.PersistentArrayMap/createAsIfByAssoc (to-array s)) - (if (seq s) (first s) clojure.lang.PersistentArrayMap/EMPTY))) - -;;redefine let and loop with destructuring -(defn destructure [bindings] - (let [bents (partition 2 bindings) - pb (fn pb [bvec b v] - (let [pvec - (fn [bvec b val] - (let [gvec (gensym "vec__") - gseq (gensym "seq__") - gfirst (gensym "first__") - has-rest (some #{'&} b)] - (loop [ret (let [ret (conj bvec gvec val)] - (if has-rest - (conj ret gseq (list `seq gvec)) - ret)) - n 0 - bs b - seen-rest? false] - (if (seq bs) - (let [firstb (first bs)] - (cond - (= firstb '&) (recur (pb ret (second bs) gseq) - n - (nnext bs) - true) - (= firstb :as) (pb ret (second bs) gvec) - :else (if seen-rest? - (throw (new Exception "Unsupported binding form, only :as can follow & parameter")) - (recur (pb (if has-rest - (conj ret - gfirst `(first ~gseq) - gseq `(next ~gseq)) - ret) - firstb - (if has-rest - gfirst - (list `nth gvec n nil))) - (inc n) - (next bs) - seen-rest?)))) - ret)))) - pmap - (fn [bvec b v] - (let [gmap (gensym "map__") - gmapseq (with-meta gmap {:tag 'clojure.lang.ISeq}) - defaults (:or b)] - (loop [ret (-> bvec (conj gmap) (conj v) - (conj gmap) (conj `(if (seq? ~gmap) - (if (next ~gmapseq) - (clojure.lang.PersistentArrayMap/createAsIfByAssoc (to-array ~gmapseq)) - (if (seq ~gmapseq) (first ~gmapseq) clojure.lang.PersistentArrayMap/EMPTY)) - ~gmap)) - ((fn [ret] - (if (:as b) - (conj ret (:as b) gmap) - ret)))) - bes (let [transforms - (reduce1 - (fn [transforms mk] - (if (keyword? mk) - (let [mkns (namespace mk) - mkn (name mk)] - (cond (= mkn "keys") (assoc transforms mk #(keyword (or mkns (namespace %)) (name %))) - (= mkn "syms") (assoc transforms mk #(list `quote (symbol (or mkns (namespace %)) (name %)))) - (= mkn "strs") (assoc transforms mk str) - :else transforms)) - transforms)) - {} - (keys b))] - (reduce1 - (fn [bes entry] - (reduce1 #(assoc %1 %2 ((val entry) %2)) - (dissoc bes (key entry)) - ((key entry) bes))) - (dissoc b :as :or) - transforms))] - (if (seq bes) - (let [bb (key (first bes)) - bk (val (first bes)) - local (if (instance? clojure.lang.Named bb) (with-meta (symbol nil (name bb)) (meta bb)) bb) - bv (if (contains? defaults local) - (list `get gmap bk (defaults local)) - (list `get gmap bk))] - (recur (if (ident? bb) - (-> ret (conj local bv)) - (pb ret bb bv)) - (next bes))) - ret))))] - (cond - (symbol? b) (-> bvec (conj b) (conj v)) - (vector? b) (pvec bvec b v) - (map? b) (pmap bvec b v) - :else (throw (new Exception (str "Unsupported binding form: " b)))))) - process-entry (fn [bvec b] (pb bvec (first b) (second b)))] - (if (every? symbol? (map first bents)) - bindings - (reduce1 process-entry [] bents)))) - + (finally (. clojure.lang.Var (popThreadBindings)))))) + +(defn ns-resolve + "Returns the var or Class to which a symbol will be resolved in the + namespace (unless found in the environment), else nil. Note that + if the symbol is fully qualified, the var/Class to which it resolves + need not be present in the namespace." + {:added "1.0" + :static true} + ([ns sym] + (ns-resolve ns nil sym)) + ([ns env sym] + (when-not (contains? env sym) + (clojure.lang.Compiler/maybeResolveIn (the-ns ns) sym)))) + +(defn resolve + "same as (ns-resolve *ns* symbol) or (ns-resolve *ns* &env symbol)" + {:added "1.0" + :static true} + ([sym] (ns-resolve *ns* sym)) + ([env sym] (ns-resolve *ns* env sym))) + +(defn array-map + "Constructs an array-map. If any keys are equal, they are handled as + if by repeated uses of assoc." + {:added "1.0" + :static true} + ([] (. clojure.lang.PersistentArrayMap EMPTY)) + ([& keyvals] + (let [ary (to-array keyvals)] + (if (odd? (alength ary)) + (throw (ArgumentException. (str "No value supplied for key: " (last keyvals)))) ;;; IllegalArgumentException + (clojure.lang.PersistentArrayMap/createAsIfByAssoc ary))))) + +(defn seq-to-map-for-destructuring + "Builds a map from a seq as described in + https://clojure.org/reference/special_forms#keyword-arguments" + {:added "1.11"} + [s] + (if (next s) + (clojure.lang.PersistentArrayMap/createAsIfByAssoc (to-array s)) + (if (seq s) (first s) clojure.lang.PersistentArrayMap/EMPTY))) + +;;redefine let and loop with destructuring +(defn destructure [bindings] + (let [bents (partition 2 bindings) + pb (fn pb [bvec b v] + (let [pvec + (fn [bvec b val] + (let [gvec (gensym "vec__") + gseq (gensym "seq__") + gfirst (gensym "first__") + has-rest (some #{'&} b)] + (loop [ret (let [ret (conj bvec gvec val)] + (if has-rest + (conj ret gseq (list `seq gvec)) + ret)) + n 0 + bs b + seen-rest? false] + (if (seq bs) + (let [firstb (first bs)] + (cond + (= firstb '&) (recur (pb ret (second bs) gseq) + n + (nnext bs) + true) + (= firstb :as) (pb ret (second bs) gvec) + :else (if seen-rest? + (throw (new Exception "Unsupported binding form, only :as can follow & parameter")) + (recur (pb (if has-rest + (conj ret + gfirst `(first ~gseq) + gseq `(next ~gseq)) + ret) + firstb + (if has-rest + gfirst + (list `nth gvec n nil))) + (inc n) + (next bs) + seen-rest?)))) + ret)))) + pmap + (fn [bvec b v] + (let [gmap (gensym "map__") + gmapseq (with-meta gmap {:tag 'clojure.lang.ISeq}) + defaults (:or b)] + (loop [ret (-> bvec (conj gmap) (conj v) + (conj gmap) (conj `(if (seq? ~gmap) + (if (next ~gmapseq) + (clojure.lang.PersistentArrayMap/createAsIfByAssoc (to-array ~gmapseq)) + (if (seq ~gmapseq) (first ~gmapseq) clojure.lang.PersistentArrayMap/EMPTY)) + ~gmap)) + ((fn [ret] + (if (:as b) + (conj ret (:as b) gmap) + ret)))) + bes (let [transforms + (reduce1 + (fn [transforms mk] + (if (keyword? mk) + (let [mkns (namespace mk) + mkn (name mk)] + (cond (= mkn "keys") (assoc transforms mk #(keyword (or mkns (namespace %)) (name %))) + (= mkn "syms") (assoc transforms mk #(list `quote (symbol (or mkns (namespace %)) (name %)))) + (= mkn "strs") (assoc transforms mk str) + :else transforms)) + transforms)) + {} + (keys b))] + (reduce1 + (fn [bes entry] + (reduce1 #(assoc %1 %2 ((val entry) %2)) + (dissoc bes (key entry)) + ((key entry) bes))) + (dissoc b :as :or) + transforms))] + (if (seq bes) + (let [bb (key (first bes)) + bk (val (first bes)) + local (if (instance? clojure.lang.Named bb) (with-meta (symbol nil (name bb)) (meta bb)) bb) + bv (if (contains? defaults local) + (list `get gmap bk (defaults local)) + (list `get gmap bk))] + (recur (if (ident? bb) + (-> ret (conj local bv)) + (pb ret bb bv)) + (next bes))) + ret))))] + (cond + (symbol? b) (-> bvec (conj b) (conj v)) + (vector? b) (pvec bvec b v) + (map? b) (pmap bvec b v) + :else (throw (new Exception (str "Unsupported binding form: " b)))))) + process-entry (fn [bvec b] (pb bvec (first b) (second b)))] + (if (every? symbol? (map first bents)) + bindings + (reduce1 process-entry [] bents)))) + (defmacro let "binding => binding-form init-expr - binding-form => name, or destructuring-form + binding-form => name, or destructuring-form destructuring-form => map-destructure-form, or seq-destructure-form 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. - - See https://clojure.org/reference/special_forms#binding-forms for + therein. + + See https://clojure.org/reference/special_forms#binding-forms for more information about destructuring." - {:added "1.0", :special-form true, :forms '[(let [bindings*] exprs*)]} + {: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") - `(let* ~(destructure bindings) ~@body)) - -(defn ^{:private true} - maybe-destructured - [params body] - (if (every? symbol? params) - (cons params body) - (loop [params params - new-params (with-meta [] (meta params)) - lets []] - (if params - (if (symbol? (first params)) - (recur (next params) (conj new-params (first params)) lets) - (let [gparam (gensym "p__")] - (recur (next params) (conj new-params gparam) - (-> lets (conj (first params)) (conj gparam))))) - `(~new-params - (let ~lets - ~@body)))))) - -;redefine fn with destructuring and pre/post conditions -(defmacro fn - "params => positional-params*, or positional-params* & rest-param - positional-param => binding-form - rest-param => binding-form - binding-form => name, or destructuring-form - - Defines a function. - - See https://clojure.org/reference/special_forms#fn for more information" - {:added "1.0", :special-form true, - :forms '[(fn name? [params* ] exprs*) (fn name? ([params* ] exprs*)+)]} - [& sigs] - (let [name (if (symbol? (first sigs)) (first sigs) nil) - sigs (if name (next sigs) sigs) - sigs (if (vector? (first sigs)) - (list sigs) - (if (seq? (first sigs)) - sigs - ;; Assume single arity syntax - (throw (ArgumentException. ;;; IllegalArgumentException - (if (seq sigs) - (str "Parameter declaration " - (first sigs) - " should be a vector") - (str "Parameter declaration missing")))))) - psig (fn* [sig] - ;; Ensure correct type before destructuring sig - (when (not (seq? sig)) - (throw (ArgumentException. ;;; IllegalArgumentException - (str "Invalid signature " sig - " should be a list")))) - (let [[params & body] sig - _ (when (not (vector? params)) - (throw (ArgumentException. ;;; IllegalArgumentException - (if (seq? (first sigs)) - (str "Parameter declaration " params - " should be a vector") - (str "Invalid signature " sig - " should be a list"))))) - conds (when (and (next body) (map? (first body))) - (first body)) - body (if conds (next body) body) - conds (or conds (meta params)) - pre (:pre conds) - post (:post conds) - body (if post - `((let [~'% ~(if (< 1 (count body)) - `(do ~@body) - (first body))] - ~@(map (fn* [c] `(assert ~c)) post) - ~'%)) - body) - body (if pre - (concat (map (fn* [c] `(assert ~c)) pre) - body) - body)] - (maybe-destructured params body))) - new-sigs (map psig sigs)] - (with-meta - (if name - (list* 'fn* name new-sigs) - (cons 'fn* new-sigs)) - (meta &form)))) - -(defmacro loop - "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. Acts as a recur target." - {:added "1.0", :special-form true, :forms '[(loop [bindings*] exprs*)]} + `(let* ~(destructure bindings) ~@body)) + +(defn ^{:private true} + maybe-destructured + [params body] + (if (every? symbol? params) + (cons params body) + (loop [params params + new-params (with-meta [] (meta params)) + lets []] + (if params + (if (symbol? (first params)) + (recur (next params) (conj new-params (first params)) lets) + (let [gparam (gensym "p__")] + (recur (next params) (conj new-params gparam) + (-> lets (conj (first params)) (conj gparam))))) + `(~new-params + (let ~lets + ~@body)))))) + +;redefine fn with destructuring and pre/post conditions +(defmacro fn + "params => positional-params*, or positional-params* & rest-param + positional-param => binding-form + rest-param => binding-form + binding-form => name, or destructuring-form + + Defines a function. + + See https://clojure.org/reference/special_forms#fn for more information" + {:added "1.0", :special-form true, + :forms '[(fn name? [params* ] exprs*) (fn name? ([params* ] exprs*)+)]} + [& sigs] + (let [name (if (symbol? (first sigs)) (first sigs) nil) + sigs (if name (next sigs) sigs) + sigs (if (vector? (first sigs)) + (list sigs) + (if (seq? (first sigs)) + sigs + ;; Assume single arity syntax + (throw (ArgumentException. ;;; IllegalArgumentException + (if (seq sigs) + (str "Parameter declaration " + (first sigs) + " should be a vector") + (str "Parameter declaration missing")))))) + psig (fn* [sig] + ;; Ensure correct type before destructuring sig + (when (not (seq? sig)) + (throw (ArgumentException. ;;; IllegalArgumentException + (str "Invalid signature " sig + " should be a list")))) + (let [[params & body] sig + _ (when (not (vector? params)) + (throw (ArgumentException. ;;; IllegalArgumentException + (if (seq? (first sigs)) + (str "Parameter declaration " params + " should be a vector") + (str "Invalid signature " sig + " should be a list"))))) + conds (when (and (next body) (map? (first body))) + (first body)) + body (if conds (next body) body) + conds (or conds (meta params)) + pre (:pre conds) + post (:post conds) + body (if post + `((let [~'% ~(if (< 1 (count body)) + `(do ~@body) + (first body))] + ~@(map (fn* [c] `(assert ~c)) post) + ~'%)) + body) + body (if pre + (concat (map (fn* [c] `(assert ~c)) pre) + body) + body)] + (maybe-destructured params body))) + new-sigs (map psig sigs)] + (with-meta + (if name + (list* 'fn* name new-sigs) + (cons 'fn* new-sigs)) + (meta &form)))) + +(defmacro loop + "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. 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" @@ -4625,1042 +4625,1042 @@ Note that read can execute code (controlled by *read-eval*), `(let ~bfs (loop* ~(vec (interleave gs gs)) (let ~(vec (interleave bs gs)) - ~@body))))))) - + ~@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" - {:added "1.0"} + {: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] - `(when-let [xs# (seq ~xs)] - (let [~x (first xs#)] - ~@body)))) - -(defmacro lazy-cat - "Expands to code which yields a lazy sequence of the concatenation - of the supplied colls. Each coll expr is not evaluated until it is - needed. - - (lazy-cat xs ys zs) === (concat (lazy-seq xs) (lazy-seq ys) (lazy-seq zs))" - {:added "1.0"} - [& colls] - `(concat ~@(map #(list `lazy-seq %) colls))) - -(defmacro for - "List comprehension. Takes a vector of one or more - binding-form/collection-expr pairs, each followed by zero or more - modifiers, and yields a lazy sequence of evaluations of expr. - Collections are iterated in a nested fashion, rightmost fastest, - and nested coll-exprs can refer to bindings created in prior - binding-forms. Supported modifiers are: :let [binding-form expr ...], - :while test, :when test. - - (take 100 (for [x (range 100000000) y (range 1000000) :while (< y x)] [x y]))" - {:added "1.0"} - [seq-exprs body-expr] - (assert-args - (vector? seq-exprs) "a vector for its binding" - (even? (count seq-exprs)) "an even number of forms in binding vector") - (let [to-groups (fn [seq-exprs] - (reduce1 (fn [groups [k v]] - (if (keyword? k) - (conj (pop groups) (conj (peek groups) [k v])) - (conj groups [k v]))) - [] (partition 2 seq-exprs))) - err (fn [& msg] (throw (ArgumentException. ^String (apply str msg)))) ;;; IllegalArgumentException - emit-bind (fn emit-bind [[[bind expr & mod-pairs] - & [[_ next-expr] :as next-groups]]] - (let [giter (gensym "iter__") - gxs (gensym "s__") - do-mod (fn do-mod [[[k v :as pair] & etc]] - (cond - (= k :let) `(let ~v ~(do-mod etc)) - (= k :while) `(when ~v ~(do-mod etc)) - (= k :when) `(if ~v - ~(do-mod etc) - (recur (rest ~gxs))) - (keyword? k) (err "Invalid 'for' keyword " k) - next-groups - `(let [iterys# ~(emit-bind next-groups) - fs# (seq (iterys# ~next-expr))] - (if fs# - (concat fs# (~giter (rest ~gxs))) - (recur (rest ~gxs)))) - :else `(cons ~body-expr - (~giter (rest ~gxs)))))] - (if next-groups - #_"not the inner-most loop" - `(fn ~giter [~gxs] - (lazy-seq - (loop [~gxs ~gxs] - (when-first [~bind ~gxs] - ~(do-mod mod-pairs))))) - #_"inner-most loop" - (let [gi (gensym "i__") - gb (gensym "b__") - do-cmod (fn do-cmod [[[k v :as pair] & etc]] - (cond - (= k :let) `(let ~v ~(do-cmod etc)) - (= k :while) `(when ~v ~(do-cmod etc)) - (= k :when) `(if ~v - ~(do-cmod etc) - (recur - (unchecked-inc ~gi))) - (keyword? k) - (err "Invalid 'for' keyword " k) - :else - `(do (chunk-append ~gb ~body-expr) - (recur (unchecked-inc ~gi)))))] - `(fn ~giter [~gxs] - (lazy-seq - (loop [~gxs ~gxs] - (when-let [~gxs (seq ~gxs)] - (if (chunked-seq? ~gxs) - (let [c# (chunk-first ~gxs) - size# (int (count c#)) - ~gb (chunk-buffer size#)] - (if (loop [~gi (int 0)] - (if (< ~gi size#) - (let [~bind (.nth c# ~gi)] - ~(do-cmod mod-pairs)) - true)) - (chunk-cons - (chunk ~gb) - (~giter (chunk-rest ~gxs))) - (chunk-cons (chunk ~gb) nil))) - (let [~bind (first ~gxs)] - ~(do-mod mod-pairs)))))))))))] - `(let [iter# ~(emit-bind (to-groups seq-exprs))] - (iter# ~(second seq-exprs))))) - -(defmacro comment - "Ignores body, yields nil" - {:added "1.0"} - [& body]) - -(defmacro with-out-str - "Evaluates exprs in a context in which *out* is bound to a fresh - StringWriter. Returns the string created by any nested printing - calls." - {:added "1.0"} - [& body] - `(let [s# (new System.IO.StringWriter)] ;;; Was java.io.StringWriter - (binding [*out* s#] - ~@body - (str s#)))) - -(defmacro with-in-str - "Evaluates body in a context in which *in* is bound to a fresh - StringReader initialized with the string s." - {:added "1.0"} - [s & body] - `(with-open [s# (-> (System.IO.StringReader. ~s) clojure.lang.LineNumberingTextReader.)] ;;; were java.io.StringReader & clojure.lang.LineNumberingPushbackReader - (binding [*in* s#] - ~@body))) - -(defn pr-str - "pr to a string, returning it" - {:tag String - :added "1.0" - :static true} - [& xs] - (with-out-str - (apply pr xs))) - -(defn prn-str - "prn to a string, returning it" - {:tag String - :added "1.0" - :static true} - [& xs] - (with-out-str - (apply prn xs))) - -(defn print-str - "print to a string, returning it" - {:tag String - :added "1.0" - :static true} - [& xs] - (with-out-str - (apply print xs))) - -(defn println-str - "println to a string, returning it" - {:tag String - :added "1.0" - :static true} - [& xs] - (with-out-str - (apply println xs))) - -(import clojure.lang.ExceptionInfo clojure.lang.IExceptionInfo) - -(defn ^:private elide-top-frames ;;; we can't actually modify the stack trace of an exception. we will just store the modified stack trace under the "StackTrace" key in the Data map - [^Exception ex class-name] ;;; Throwable - (let [tr (.GetFrames (or (System.Diagnostics.StackTrace. ex true) (System.Diagnostics.StackTrace.)))] ;;; (.getStackTrace ex) if the exception has not been thrown, it will not have a stack trace, so we create one from the current stack - (.Add (.Data ex) ;;; (doto ex - "StackTrace" ;;; (.setStackTrace - (when tr - (into-array System.Diagnostics.StackFrame ;;; StackTraceElement - (drop-while #(= class-name (.Name (.GetMethod ^System.Diagnostics.StackFrame %1))) tr))))) ex) ;;; .getMethodName => .Name .GetMethod StackTraceElement - -(defn ex-info - "Create an instance of ExceptionInfo, a RuntimeException subclass - that carries a map of additional data." - {:added "1.4"} - ([msg map] - (elide-top-frames (ExceptionInfo. msg map) "clojure.core$ex_info")) - ([msg map cause] - (elide-top-frames (ExceptionInfo. msg map cause) "clojure.core$ex_info"))) - -(defn ex-data - "Returns exception data (a map) if ex is an IExceptionInfo. - Otherwise returns nil." - {:added "1.4"} - [ex] - (when (instance? IExceptionInfo ex) - (.getData ^IExceptionInfo ex))) - -(defn ex-message - "Returns the message attached to ex if ex is a Throwable. - Otherwise returns nil." - {:added "1.10"} - [ex] - (when (instance? Exception ex) ;;; Throwable - (.Message ^Exception ex))) ;;; .getMessage Throwable - -(defn ex-cause - "Returns the cause of ex if ex is a Throwable. - Otherwise returns nil." - {:tag Exception ;;;Throwable - :added "1.10"} - [ex] - (when (instance? Exception ex) ;;; Throwable - (.InnerException ^Exception ex))) ;;; .getCause Throwable - -(defmacro assert - "Evaluates expr and throws an exception if it does not evaluate to - logical true." - {:added "1.0"} - ([x] - (when *assert* - `(when-not ~x - (throw (new Exception (str "Assert failed: " (pr-str '~x))))))) ;;; AssertionError - ([x message] - (when *assert* - `(when-not ~x - (throw (new Exception (str "Assert failed: " ~message "\n" (pr-str '~x)))))))) ;;; AssertionError - -(defn test - "test [v] finds fn at key :test in var metadata and calls it, - presuming failure will throw exception" - {:added "1.0"} - [v] - (let [f (:test (meta v))] - (if f - (do (f) :ok) - :no-test))) -;;; Had to add a bogus class clojure.lang.JReMatcher to make the re-* functions work. + `(when-let [xs# (seq ~xs)] + (let [~x (first xs#)] + ~@body)))) + +(defmacro lazy-cat + "Expands to code which yields a lazy sequence of the concatenation + of the supplied colls. Each coll expr is not evaluated until it is + needed. + + (lazy-cat xs ys zs) === (concat (lazy-seq xs) (lazy-seq ys) (lazy-seq zs))" + {:added "1.0"} + [& colls] + `(concat ~@(map #(list `lazy-seq %) colls))) + +(defmacro for + "List comprehension. Takes a vector of one or more + binding-form/collection-expr pairs, each followed by zero or more + modifiers, and yields a lazy sequence of evaluations of expr. + Collections are iterated in a nested fashion, rightmost fastest, + and nested coll-exprs can refer to bindings created in prior + binding-forms. Supported modifiers are: :let [binding-form expr ...], + :while test, :when test. + + (take 100 (for [x (range 100000000) y (range 1000000) :while (< y x)] [x y]))" + {:added "1.0"} + [seq-exprs body-expr] + (assert-args + (vector? seq-exprs) "a vector for its binding" + (even? (count seq-exprs)) "an even number of forms in binding vector") + (let [to-groups (fn [seq-exprs] + (reduce1 (fn [groups [k v]] + (if (keyword? k) + (conj (pop groups) (conj (peek groups) [k v])) + (conj groups [k v]))) + [] (partition 2 seq-exprs))) + err (fn [& msg] (throw (ArgumentException. ^String (apply str msg)))) ;;; IllegalArgumentException + emit-bind (fn emit-bind [[[bind expr & mod-pairs] + & [[_ next-expr] :as next-groups]]] + (let [giter (gensym "iter__") + gxs (gensym "s__") + do-mod (fn do-mod [[[k v :as pair] & etc]] + (cond + (= k :let) `(let ~v ~(do-mod etc)) + (= k :while) `(when ~v ~(do-mod etc)) + (= k :when) `(if ~v + ~(do-mod etc) + (recur (rest ~gxs))) + (keyword? k) (err "Invalid 'for' keyword " k) + next-groups + `(let [iterys# ~(emit-bind next-groups) + fs# (seq (iterys# ~next-expr))] + (if fs# + (concat fs# (~giter (rest ~gxs))) + (recur (rest ~gxs)))) + :else `(cons ~body-expr + (~giter (rest ~gxs)))))] + (if next-groups + #_"not the inner-most loop" + `(fn ~giter [~gxs] + (lazy-seq + (loop [~gxs ~gxs] + (when-first [~bind ~gxs] + ~(do-mod mod-pairs))))) + #_"inner-most loop" + (let [gi (gensym "i__") + gb (gensym "b__") + do-cmod (fn do-cmod [[[k v :as pair] & etc]] + (cond + (= k :let) `(let ~v ~(do-cmod etc)) + (= k :while) `(when ~v ~(do-cmod etc)) + (= k :when) `(if ~v + ~(do-cmod etc) + (recur + (unchecked-inc ~gi))) + (keyword? k) + (err "Invalid 'for' keyword " k) + :else + `(do (chunk-append ~gb ~body-expr) + (recur (unchecked-inc ~gi)))))] + `(fn ~giter [~gxs] + (lazy-seq + (loop [~gxs ~gxs] + (when-let [~gxs (seq ~gxs)] + (if (chunked-seq? ~gxs) + (let [c# (chunk-first ~gxs) + size# (int (count c#)) + ~gb (chunk-buffer size#)] + (if (loop [~gi (int 0)] + (if (< ~gi size#) + (let [~bind (.nth c# ~gi)] + ~(do-cmod mod-pairs)) + true)) + (chunk-cons + (chunk ~gb) + (~giter (chunk-rest ~gxs))) + (chunk-cons (chunk ~gb) nil))) + (let [~bind (first ~gxs)] + ~(do-mod mod-pairs)))))))))))] + `(let [iter# ~(emit-bind (to-groups seq-exprs))] + (iter# ~(second seq-exprs))))) + +(defmacro comment + "Ignores body, yields nil" + {:added "1.0"} + [& body]) + +(defmacro with-out-str + "Evaluates exprs in a context in which *out* is bound to a fresh + StringWriter. Returns the string created by any nested printing + calls." + {:added "1.0"} + [& body] + `(let [s# (new System.IO.StringWriter)] ;;; Was java.io.StringWriter + (binding [*out* s#] + ~@body + (str s#)))) + +(defmacro with-in-str + "Evaluates body in a context in which *in* is bound to a fresh + StringReader initialized with the string s." + {:added "1.0"} + [s & body] + `(with-open [s# (-> (System.IO.StringReader. ~s) clojure.lang.LineNumberingTextReader.)] ;;; were java.io.StringReader & clojure.lang.LineNumberingPushbackReader + (binding [*in* s#] + ~@body))) + +(defn pr-str + "pr to a string, returning it" + {:tag String + :added "1.0" + :static true} + [& xs] + (with-out-str + (apply pr xs))) + +(defn prn-str + "prn to a string, returning it" + {:tag String + :added "1.0" + :static true} + [& xs] + (with-out-str + (apply prn xs))) + +(defn print-str + "print to a string, returning it" + {:tag String + :added "1.0" + :static true} + [& xs] + (with-out-str + (apply print xs))) + +(defn println-str + "println to a string, returning it" + {:tag String + :added "1.0" + :static true} + [& xs] + (with-out-str + (apply println xs))) + +(import clojure.lang.ExceptionInfo clojure.lang.IExceptionInfo) + +(defn ^:private elide-top-frames ;;; we can't actually modify the stack trace of an exception. we will just store the modified stack trace under the "StackTrace" key in the Data map + [^Exception ex class-name] ;;; Throwable + (let [tr (.GetFrames (or (System.Diagnostics.StackTrace. ex true) (System.Diagnostics.StackTrace.)))] ;;; (.getStackTrace ex) if the exception has not been thrown, it will not have a stack trace, so we create one from the current stack + (.Add (.Data ex) ;;; (doto ex + "StackTrace" ;;; (.setStackTrace + (when tr + (into-array System.Diagnostics.StackFrame ;;; StackTraceElement + (drop-while #(= class-name (.Name (.GetMethod ^System.Diagnostics.StackFrame %1))) tr))))) ex) ;;; .getMethodName => .Name .GetMethod StackTraceElement + +(defn ex-info + "Create an instance of ExceptionInfo, a RuntimeException subclass + that carries a map of additional data." + {:added "1.4"} + ([msg map] + (elide-top-frames (ExceptionInfo. msg map) "clojure.core$ex_info")) + ([msg map cause] + (elide-top-frames (ExceptionInfo. msg map cause) "clojure.core$ex_info"))) + +(defn ex-data + "Returns exception data (a map) if ex is an IExceptionInfo. + Otherwise returns nil." + {:added "1.4"} + [ex] + (when (instance? IExceptionInfo ex) + (.getData ^IExceptionInfo ex))) + +(defn ex-message + "Returns the message attached to ex if ex is a Throwable. + Otherwise returns nil." + {:added "1.10"} + [ex] + (when (instance? Exception ex) ;;; Throwable + (.Message ^Exception ex))) ;;; .getMessage Throwable + +(defn ex-cause + "Returns the cause of ex if ex is a Throwable. + Otherwise returns nil." + {:tag Exception ;;;Throwable + :added "1.10"} + [ex] + (when (instance? Exception ex) ;;; Throwable + (.InnerException ^Exception ex))) ;;; .getCause Throwable + +(defmacro assert + "Evaluates expr and throws an exception if it does not evaluate to + logical true." + {:added "1.0"} + ([x] + (when *assert* + `(when-not ~x + (throw (new Exception (str "Assert failed: " (pr-str '~x))))))) ;;; AssertionError + ([x message] + (when *assert* + `(when-not ~x + (throw (new Exception (str "Assert failed: " ~message "\n" (pr-str '~x)))))))) ;;; AssertionError + +(defn test + "test [v] finds fn at key :test in var metadata and calls it, + presuming failure will throw exception" + {:added "1.0"} + [v] + (let [f (:test (meta v))] + (if f + (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} - :added "1.0" - :static true} + :added "1.0" + :static true} [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 - "Returns an instance of java.util.regex.Matcher, for use, e.g. in - re-find." - {:tag clojure.lang.JReMatcher ;;; {:tag java.util.regex.Matcher} - :added "1.0" - :static true} - [^System.Text.RegularExpressions.Regex re s] ;;; java.util.regex.Pattern - (clojure.lang.JReMatcher. re s)) ;;; (. re (matcher s))) - -(defn re-groups - "Returns the groups from the most recent match/find. If there are no - nested groups, returns a string of the entire match. If there are - nested groups, returns a vector of the groups, the first element - being the entire match." - {:added "1.0" - :static true} - [^clojure.lang.JReMatcher m] ;;; java.util.regex.Matcher - (let [gc (. m (groupCount))] - (if (zero? gc) - (. m (group)) - (loop [ret [] c 0] - (if (<= c gc) - (recur (conj ret (. m (group c))) (inc c)) - ret))))) - -(defn re-seq - "Returns a lazy sequence of successive matches of pattern in string, - using java.util.regex.Matcher.find(), each such match processed with - re-groups." - {:added "1.0" - :static true} - [^System.Text.RegularExpressions.Regex re s] ;;; java.util.regex.Pattern - (let [m (re-matcher re s)] - ((fn step [] - (when (. m (find)) - (cons (re-groups m) (lazy-seq (step)))))))) - -(defn re-matches - "Returns the match, if any, of string to pattern, using - java.util.regex.Matcher.matches(). Uses re-groups to return the - groups." - {:added "1.0" - :static true} - [^System.Text.RegularExpressions.Regex re s] ;;; java.util.regex.Pattern - (let [m (re-matcher re s)] - (when (. m (matches)) - (re-groups m)))) - - -(defn re-find - "Returns the next regex match, if any, of string to pattern, using - java.util.regex.Matcher.find(). Uses re-groups to return the - groups." - {:added "1.0" - :static true} - ([^clojure.lang.JReMatcher m] ;;; java.util.regex.Matcher - (when (. m (find)) - (re-groups m))) - ([^System.Text.RegularExpressions.Regex re s] ;;; java.util.regex.Pattern - (let [m (re-matcher re s)] - (re-find m)))) - -(defn rand - "Returns a random floating point number between 0 (inclusive) and - n (default 1) (exclusive)." - {:added "1.0" - :static true} - ([] (. clojure.lang.RT (random))) ;;; Math ==> RT. No Math.random in CLR. - ([n] (* n (rand)))) - -(defn rand-int - "Returns a random integer between 0 (inclusive) and n (exclusive)." - {:added "1.0" - :static true} - [n] (int (rand n))) - -(defmacro defn- - "same as defn, yielding non-public def" - {:added "1.0"} - [name & decls] - (list* `defn (with-meta name (assoc (meta name) :private true)) decls)) - -(defn tree-seq - "Returns a lazy sequence of the nodes in a tree, via a depth-first walk. - branch? must be a fn of one arg that returns true if passed a node - that can have children (but may not). children must be a fn of one - arg that returns a sequence of the children. Will only be called on - nodes for which branch? returns true. Root is the root node of the - tree." - {:added "1.0" - :static true} - [branch? children root] - (let [walk (fn walk [node] - (lazy-seq - (cons node - (when (branch? node) - (mapcat walk (children node))))))] - (walk root))) - -(defn file-seq - "A tree seq on java.io.Files" - {:added "1.0" - :static true} - [dir] - (tree-seq - (fn [x] (instance? System.IO.DirectoryInfo x)) ;;; (fn [^java.io.File f] (. f (isDirectory))) - (fn [^System.IO.DirectoryInfo d] (seq (.GetFileSystemInfos d))) ;;; (fn [^java.io.File d] (seq (. d (listFiles)))) - dir)) - -(defn xml-seq - "A tree seq on the xml elements as per xml/parse" - {:added "1.0" - :static true} - [root] - (tree-seq - (complement string?) - (comp seq :content) - root)) - -(defn special-symbol? - "Returns true if s names a special form" - {:added "1.0" - :static true} - [s] - (contains? (. clojure.lang.Compiler specials) s)) - -(defn var? - "Returns true if v is of type clojure.lang.Var" - {:added "1.0" - :static true} - [v] (instance? clojure.lang.Var v)) - -(defn subs - "Returns the substring of s beginning at start inclusive, and ending - at end (defaults to length of string), exclusive." - {:added "1.0" - :static true} - (^String [^String s start] (. s (Substring start))) ;;; substring => Substring - (^String [^String s start end] (. s (Substring start (- end start))))) ;;; was (substring start end) -- different interpretation of second arg - -(defn max-key - "Returns the x for which (k x), a number, is greatest. - - If there are multiple such xs, the last one is returned." - {:added "1.0" - :static true} - ([k x] x) - ([k x y] (if (> (k x) (k y)) x y)) - ([k x y & more] - (let [kx (k x) ky (k y) - [v kv] (if (> kx ky) [x kx] [y ky])] - (loop [v v kv kv more more] - (if more - (let [w (first more) - kw (k w)] - (if (>= kw kv) - (recur w kw (next more)) - (recur v kv (next more)))) - v))))) - -(defn min-key - "Returns the x for which (k x), a number, is least. - - If there are multiple such xs, the last one is returned." - {:added "1.0" - :static true} - ([k x] x) - ([k x y] (if (< (k x) (k y)) x y)) - ([k x y & more] - (let [kx (k x) ky (k y) - [v kv] (if (< kx ky) [x kx] [y ky])] - (loop [v v kv kv more more] - (if more - (let [w (first more) - kw (k w)] - (if (<= kw kv) - (recur w kw (next more)) - (recur v kv (next more)))) - v))))) - -(defn distinct - "Returns a lazy sequence of the elements of coll with duplicates removed. - Returns a stateful transducer when no collection is provided." - {:added "1.0" - :static true} - ([] - (fn [rf] - (let [seen (volatile! #{})] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (if (contains? @seen input) - result - (do (vswap! seen conj input) - (rf result input)))))))) - ([coll] - (let [step (fn step [xs seen] - (lazy-seq - ((fn [[f :as xs] seen] - (when-let [s (seq xs)] - (if (contains? seen f) - (recur (rest s) seen) - (cons f (step (rest s) (conj seen f)))))) - xs seen)))] - (step coll #{})))) - - - -(defn replace - "Given a map of replacement pairs and a vector/collection, returns a - vector/seq with any elements = a key in smap replaced with the - corresponding val in smap. Returns a transducer when no collection - is provided." - {:added "1.0" - :static true} - ([smap] - (map #(if-let [e (find smap %)] (val e) %))) - ([smap coll] - (if (vector? coll) - (reduce1 (fn [v i] - (if-let [e (find smap (nth v i))] - (assoc v i (val e)) - v)) - coll (range (count coll))) - (map #(if-let [e (find smap %)] (val e) %) coll)))) - -(defmacro dosync - "Runs the exprs (in an implicit do) in a transaction that encompasses - exprs and any nested calls. Starts a transaction if none is already - running on this thread. Any uncaught exception will abort the - transaction and flow out of dosync. The exprs may be run more than - once, but any effects on Refs will be atomic." - {:added "1.0"} - [& exprs] - `(sync nil ~@exprs)) - -(defmacro with-precision - "Sets the precision and rounding mode to be used for BigDecimal operations. - - Usage: (with-precision 10 (/ 1M 3)) - or: (with-precision 10 :rounding HALF_DOWN (/ 1M 3)) - - The rounding mode is one of CEILING, FLOOR, HALF_UP, HALF_DOWN, - HALF_EVEN, UP, DOWN and UNNECESSARY; it defaults to HALF_UP." - {:added "1.0"} - [precision & exprs] - (let [[body rm] (if (= (first exprs) :rounding) - [(next (next exprs)) - `((Enum/Parse clojure.lang.BigDecimal+RoundingMode (name '~(second exprs))))] ;;; `((. java.math.RoundingMode ~(second exprs)))] - [exprs nil])] - `(binding [*math-context* (clojure.lang.BigDecimal+Context. ~precision ~@rm)] ;;; (java.math.MathContext. ~precision ~@rm)] - ~@body))) - -(defn mk-bound-fn - {:private true} - [^clojure.lang.Sorted sc test key] - (fn [e] - (test (.. sc comparator (compare (. sc entryKey e) key)) 0))) - -(defn subseq - "sc must be a sorted collection, test(s) one of <, <=, > or - >=. Returns a seq of those entries with keys ek for - which (test (.. sc comparator (compare ek key)) 0) is true" - {:added "1.0" - :static true} - ([^clojure.lang.Sorted sc test key] - (let [include (mk-bound-fn sc test key)] - (if (#{> >=} test) - (when-let [[e :as s] (. sc seqFrom key true)] - (if (include e) s (next s))) - (take-while include (. sc seq true))))) - ([^clojure.lang.Sorted sc start-test start-key end-test end-key] - (when-let [[e :as s] (. sc seqFrom start-key true)] - (take-while (mk-bound-fn sc end-test end-key) - (if ((mk-bound-fn sc start-test start-key) e) s (next s)))))) - -(defn rsubseq - "sc must be a sorted collection, test(s) one of <, <=, > or - >=. Returns a reverse seq of those entries with keys ek for - which (test (.. sc comparator (compare ek key)) 0) is true" - {:added "1.0" - :static true} - ([^clojure.lang.Sorted sc test key] - (let [include (mk-bound-fn sc test key)] - (if (#{< <=} test) - (when-let [[e :as s] (. sc seqFrom key false)] - (if (include e) s (next s))) - (take-while include (. sc seq false))))) - ([^clojure.lang.Sorted sc start-test start-key end-test end-key] - (when-let [[e :as s] (. sc seqFrom end-key false)] - (take-while (mk-bound-fn sc start-test start-key) - (if ((mk-bound-fn sc end-test end-key) e) s (next s)))))) - -(defn repeatedly - "Takes a function of no args, presumably with side effects, and - returns an infinite (or length n if supplied) lazy sequence of calls - to it" - {:added "1.0" - :static true} - ([f] (lazy-seq (cons (f) (repeatedly f)))) - ([n f] (take n (repeatedly f)))) -;;; What is CLR equivalent -- should this just be a no-op? -;(defn add-classpath -; "DEPRECATED -; -; Adds the url (String or URL object) to the classpath per -; URLClassLoader.addURL" -; {:added "1.0" -; :deprecated "1.2"} -; [url] -; (println "WARNING: add-classpath is deprecated") -; (clojure.lang.RT/addURL url)) - - - -(defn hash - "Returns the hash code of its argument. Note this is the hash code - consistent with =, and thus is different than .hashCode for Integer, - Short, Byte and Clojure collections." - - {:added "1.0" - :static true} - [x] (. clojure.lang.Util (hasheq x))) - - -(defn mix-collection-hash - "Mix final collection hash for ordered or unordered collections. - hash-basis is the combined collection hash, count is the number - of elements included in the basis. Note this is the hash code - consistent with =, different from .hashCode. - See http://clojure.org/data_structures#hash for full algorithms." - {:added "1.6" - :static true} - ^long - [^long hash-basis ^long count] (clojure.lang.Murmur3/MixCollHash hash-basis count)) ;;; mixCollHash - -(defn hash-ordered-coll - "Returns the hash code, consistent with =, for an external ordered - collection implementing Iterable. - See http://clojure.org/data_structures#hash for full algorithms." - {:added "1.6" - :static true} - ^long - [coll] (clojure.lang.Murmur3/HashOrdered coll)) ;;; hashOrdered - -(defn hash-unordered-coll - "Returns the hash code, consistent with =, for an external unordered - collection implementing Iterable. For maps, the iterator should - return map entries whose hash is computed as - (hash-ordered-coll [k v]). - See http://clojure.org/data_structures#hash for full algorithms." - {:added "1.6" - :static true} - ^long - [coll] (clojure.lang.Murmur3/HashUnordered coll)) ;;; hashUnordered - -(defn interpose - "Returns a lazy seq of the elements of coll separated by sep. - Returns a stateful transducer when no collection is provided." - {:added "1.0" - :static true} - ([sep] - (fn [rf] - (let [started (volatile! false)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (if @started - (let [sepr (rf result sep)] - (if (reduced? sepr) - sepr - (rf sepr input))) - (do - (vreset! started true) - (rf result input)))))))) - ([sep coll] - (drop 1 (interleave (repeat sep) coll)))) - -(defmacro definline - "Experimental - like defmacro, except defines a named function whose - body is the expansion, calls to which may be expanded inline as if - it were a macro. Cannot be used with variadic (&) args." - {:added "1.0"} - [name & decl] - (let [[pre-args [args expr]] (split-with (comp not vector?) decl)] - `(do - (defn ~name ~@pre-args ~args ~(apply (eval (list `fn args expr)) args)) - (alter-meta! (var ~name) assoc :inline (fn ~name ~args ~expr)) - (var ~name)))) - -(defn empty - "Returns an empty collection of the same category as coll, or nil" - {:added "1.0" - :static true} - [coll] - (when (instance? clojure.lang.IPersistentCollection coll) - (.empty ^clojure.lang.IPersistentCollection coll))) - -(defmacro amap - "Maps an expression across an array a, using an index named idx, and - return value named ret, initialized to a clone of a, then setting - each element of ret to the evaluation of expr, returning the new - array ret." - {:added "1.0"} - [a idx ret expr] - `(let [a# ~a l# (alength a#) - ~ret (aclone a#)] - (loop [~idx 0] - (if (< ~idx l#) - (do - (aset ~ret ~idx ~expr) - (recur (unchecked-inc ~idx))) - ~ret)))) - -(defmacro areduce - "Reduces an expression across an array a, using an index named idx, - and return value named ret, initialized to init, setting ret to the - evaluation of expr at each step, returning ret." - {:added "1.0"} - [a idx ret init expr] - `(let [a# ~a l# (alength a#)] - (loop [~idx 0 ~ret ~init] - (if (< ~idx l#) - (recur (unchecked-inc-int ~idx) ~expr) - ~ret)))) - -(defn float-array - "Creates an array of floats" - {:inline (fn [& args] `(. clojure.lang.Numbers float_array ~@args)) - :inline-arities #{1 2} - :added "1.0"} - ([size-or-seq] (. clojure.lang.Numbers float_array size-or-seq)) - ([size init-val-or-seq] (. clojure.lang.Numbers float_array size init-val-or-seq))) - -(defn boolean-array - "Creates an array of booleans" - {:inline (fn [& args] `(. clojure.lang.Numbers boolean_array ~@args)) - :inline-arities #{1 2} - :added "1.1"} - ([size-or-seq] (. clojure.lang.Numbers boolean_array size-or-seq)) - ([size init-val-or-seq] (. clojure.lang.Numbers boolean_array size init-val-or-seq))) - -(defn byte-array - "Creates an array of bytes" - {:inline (fn [& args] `(. clojure.lang.Numbers byte_array ~@args)) - :inline-arities #{1 2} - :added "1.1"} - ([size-or-seq] (. clojure.lang.Numbers byte_array size-or-seq)) - ([size init-val-or-seq] (. clojure.lang.Numbers byte_array size init-val-or-seq))) - -(defn char-array - "Creates an array of chars" - {:inline (fn [& args] `(. clojure.lang.Numbers char_array ~@args)) - :inline-arities #{1 2} - :added "1.1"} - ([size-or-seq] (. clojure.lang.Numbers char_array size-or-seq)) - ([size init-val-or-seq] (. clojure.lang.Numbers char_array size init-val-or-seq))) - -(defn short-array - "Creates an array of shorts" - {:inline (fn [& args] `(. clojure.lang.Numbers short_array ~@args)) - :inline-arities #{1 2} - :added "1.1"} - ([size-or-seq] (. clojure.lang.Numbers short_array size-or-seq)) - ([size init-val-or-seq] (. clojure.lang.Numbers short_array size init-val-or-seq))) - -(defn double-array - "Creates an array of doubles" - {:inline (fn [& args] `(. clojure.lang.Numbers double_array ~@args)) - :inline-arities #{1 2} - :added "1.0"} - ([size-or-seq] (. clojure.lang.Numbers double_array size-or-seq)) - ([size init-val-or-seq] (. clojure.lang.Numbers double_array size init-val-or-seq))) - -(defn object-array - "Creates an array of objects" - {:inline (fn [arg] `(. clojure.lang.RT object_array ~arg)) - :inline-arities #{1} - :added "1.2"} - ([size-or-seq] (. clojure.lang.RT object_array size-or-seq))) - -(defn int-array - "Creates an array of ints" - {:inline (fn [& args] `(. clojure.lang.Numbers int_array ~@args)) - :inline-arities #{1 2} - :added "1.0"} - ([size-or-seq] (. clojure.lang.Numbers int_array size-or-seq)) - ([size init-val-or-seq] (. clojure.lang.Numbers int_array size init-val-or-seq))) - -(defn long-array - "Creates an array of longs" - {:inline (fn [& args] `(. clojure.lang.Numbers long_array ~@args)) - :inline-arities #{1 2} - :added "1.0"} - ([size-or-seq] (. clojure.lang.Numbers long_array size-or-seq)) - ([size init-val-or-seq] (. clojure.lang.Numbers long_array size init-val-or-seq))) - -(definline booleans - "Casts to boolean[]" - {:added "1.1"} - [xs] `(. clojure.lang.Numbers booleans ~xs)) - -(definline bytes - "Casts to bytes[]" - {:added "1.1"} - [xs] `(. clojure.lang.Numbers bytes ~xs)) - -(definline chars - "Casts to chars[]" - {:added "1.1"} - [xs] `(. clojure.lang.Numbers chars ~xs)) - -(definline shorts - "Casts to shorts[]" - {:added "1.1"} - [xs] `(. clojure.lang.Numbers shorts ~xs)) - -(definline floats - "Casts to float[]" - {:added "1.0"} - [xs] `(. clojure.lang.Numbers floats ~xs)) - -(definline ints - "Casts to int[]" - {:added "1.0"} - [xs] `(. clojure.lang.Numbers ints ~xs)) - -(definline doubles - "Casts to double[]" - {:added "1.0"} - [xs] `(. clojure.lang.Numbers doubles ~xs)) - -(definline longs - "Casts to long[]" - {:added "1.0"} - [xs] `(. clojure.lang.Numbers longs ~xs)) - -(defn bytes? - "Return true if x is a byte array" - {:added "1.9"} - [x] (if (nil? x) - false - (let [t (class x)] (and (.IsArray t) (= (.GetElementType t) Byte))))) ;;; (-> x class .getComponentType (= Byte/TYPE)) - -;(import '(java.util.concurrent BlockingQueue LinkedBlockingQueue)) -;;;NOT WORTH THE EFFORT AT THE MOMENT -;(defn seque -; "Creates a queued seq on another (presumably lazy) seq s. The queued -; seq will produce a concrete seq in the background, and can get up to -; n items ahead of the consumer. n-or-q can be an integer n buffer -; size, or an instance of java.util.concurrent BlockingQueue. Note -; that reading from a seque can block if the reader gets ahead of the -; producer." -; {:added "1.0" -; :static true} -; ([s] (seque 100 s)) -; ([n-or-q s] -; (let [^BlockingQueue q (if (instance? BlockingQueue n-or-q) -; n-or-q -; (LinkedBlockingQueue. (int n-or-q))) -; NIL (Object.) ;nil sentinel since LBQ doesn't support nils -; agt (agent (lazy-seq s)) ; never start with nil; that signifies we've already put eos -; log-error (fn [q e] -; (if (.offer q q) -; (throw e) -; e)) -; fill (fn [s] -; (when s -; (if (instance? Exception s) ; we failed to .offer an error earlier -; (log-error q s) -; (try -; (loop [[x & xs :as s] (seq s)] -; (if s -; (if (.offer q (if (nil? x) NIL x)) -; (recur xs) -; s) -; (when-not (.offer q q) ; q itself is eos sentinel -; ()))) ; empty seq, not nil, so we know to put eos next time -; (catch Exception e -; (log-error q e)))))) -; drain (fn drain [] -; (lazy-seq -; (let [x (.take q)] -; (if (identical? x q) ;q itself is eos sentinel -; (do @agt nil) ;touch agent just to propagate errors -; (do -; (send-off agt fill) -; (release-pending-sends) -; (cons (if (identical? x NIL) nil x) (drain)))))))] -; (send-off agt fill) -; (drain)))) - -(defn class? - "Returns true if x is an instance of Class" - {:added "1.0" - :static true} - [x] (instance? Type x)) ;; Class ==> Type - -;(defn- is-annotation? [c] -; (and (class? c) -; (.isAssignableFrom java.lang.annotation.Annotation c))) -; -;(defn- is-runtime-annotation? [^Class c] -; (boolean -; (and (is-annotation? c) -; (when-let [^java.lang.annotation.Retention r -; (.getAnnotation c java.lang.annotation.Retention)] -; (= (.value r) java.lang.annotation.RetentionPolicy/RUNTIME))))) -; -;(defn- descriptor [^Class c] (clojure.asm.Type/getDescriptor c)) -; -;(declare process-annotation) -;(defn- add-annotation [^clojure.asm.AnnotationVisitor av name v] -; (cond -; (vector? v) (let [avec (.visitArray av name)] -; (doseq [vval v] -; (add-annotation avec "value" vval)) -; (.visitEnd avec)) -; (symbol? v) (let [ev (eval v)] -; (cond -; (instance? java.lang.Enum ev) -; (.visitEnum av name (descriptor (class ev)) (str ev)) -; (class? ev) (.visit av name (clojure.asm.Type/getType ev)) -; :else (throw (IllegalArgumentException. -; (str "Unsupported annotation value: " v " of class " (class ev)))))) -; (seq? v) (let [[nested nv] v -; c (resolve nested) -; nav (.visitAnnotation av name (descriptor c))] -; (process-annotation nav nv) -; (.visitEnd nav)) -; :else (.visit av name v))) -; -;(defn- process-annotation [av v] -; (if (map? v) -; (doseq [[k v] v] -; (add-annotation av (name k) v)) -; (add-annotation av "value" v))) -; -;(defn- add-annotations -; ([visitor m] (add-annotations visitor m nil)) -; ([visitor m i] -; (doseq [[k v] m] -; (when (symbol? k) -; (when-let [c (resolve k)] -; (when (is-annotation? c) -; ;this is known duck/reflective as no common base of ASM Visitors -; (let [av (if i -; (.visitParameterAnnotation visitor i (descriptor c) -; (is-runtime-annotation? c)) -; (.visitAnnotation visitor (descriptor c) -; (is-runtime-annotation? c)))] -; (process-annotation av v) -; (.visitEnd av)))))))) - -(defn alter-var-root - "Atomically alters the root binding of var v by applying f to its - current value plus any args" - {:added "1.0" - :static true} - [^clojure.lang.Var v f & args] (.alterRoot v f args)) - -(defn bound? - "Returns true if all of the vars provided as arguments have any bound value, root or thread-local. - Implies that deref'ing the provided vars will succeed. Returns true if no vars are provided." - {:added "1.2" - :static true} - [& vars] - (every? #(.isBound ^clojure.lang.Var %) vars)) - -(defn thread-bound? - "Returns true if all of the vars provided as arguments have thread-local bindings. - Implies that set!'ing the provided vars will succeed. Returns true if no vars are provided." - {:added "1.2" - :static true} - [& vars] - (every? #(.getThreadBinding ^clojure.lang.Var %) vars)) - -(defn make-hierarchy - "Creates a hierarchy object for use with derive, isa? etc." - {:added "1.0" - :static true} - [] {:parents {} :descendants {} :ancestors {}}) - -(def ^{:private true} - global-hierarchy (make-hierarchy)) - -(defn not-empty - "If coll is empty, returns nil, else coll" - {:added "1.0" - :static true} - [coll] (when (seq coll) coll)) - -(defn bases - "Returns the immediate superclass and direct interfaces of c, if any" - {:added "1.0" - :static true} - [^Type c] ;;; Class ==> Type - (when c - (let [i (seq (.GetInterfaces c)) ;;; .getInterfaces ==> .GetInterfaces - s (.BaseType c)] ;;; .getSuperclass ==> BaseType - (if s (cons s i) i)))) - -(defn supers - "Returns the immediate and indirect superclasses and interfaces of c, if any" - {:added "1.0" - :static true} - [^Type class] ;;; Class ==> Type - (loop [ret (set (bases class)) cs ret] - (if (seq cs) - (let [c (first cs) bs (bases c)] - (recur (into1 ret bs) (into1 (disj cs c) bs))) - (not-empty ret)))) - -(defn isa? - "Returns true if (= child parent), or child is directly or indirectly derived from - parent, either via a Java type inheritance relationship or a - relationship established via derive. h must be a hierarchy obtained - from make-hierarchy, if not supplied defaults to the global - hierarchy" - {:added "1.0"} - ([child parent] (isa? global-hierarchy child parent)) - ([h child parent] - (or (= child parent) - (and (class? parent) (class? child) - (. ^Type parent IsAssignableFrom child)) ;;; Class ==> Type, isAssignableFrom - (contains? ((:ancestors h) child) parent) - (and (class? child) (some #(contains? ((:ancestors h) %) parent) (supers child))) - (and (vector? parent) (vector? child) - (= (count parent) (count child)) - (loop [ret true i 0] - (if (or (not ret) (= i (count parent))) - ret - (recur (isa? h (child i) (parent i)) (inc i)))))))) - -(defn parents - "Returns the immediate parents of tag, either via a Java type - inheritance relationship or a relationship established via derive. h - must be a hierarchy obtained from make-hierarchy, if not supplied - defaults to the global hierarchy" - {:added "1.0"} - ([tag] (parents global-hierarchy tag)) - ([h tag] (not-empty - (let [tp (get (:parents h) tag)] - (if (class? tag) - (into1 (set (bases tag)) tp) - tp))))) - -(defn ancestors - "Returns the immediate and indirect parents of tag, either via a Java type - inheritance relationship or a relationship established via derive. h - must be a hierarchy obtained from make-hierarchy, if not supplied - defaults to the global hierarchy" - {:added "1.0"} - ([tag] (ancestors global-hierarchy tag)) - ([h tag] (not-empty - (let [ta (get (:ancestors h) tag)] - (if (class? tag) - (let [superclasses (set (supers tag))] - (reduce1 into1 superclasses - (cons ta - (map #(get (:ancestors h) %) superclasses)))) - ta))))) -;;; NOT TESTED YET -(defn descendants - "Returns the immediate and indirect children of tag, through a - relationship established via derive. h must be a hierarchy obtained - from make-hierarchy, if not supplied defaults to the global - hierarchy. Note: does not work on Java type inheritance - relationships." - {:added "1.0"} - ([tag] (descendants global-hierarchy tag)) - ([h tag] (if (class? tag) - (throw (NotImplementedException. "Can't get descendants of classes")) ;;; java.lang.UnsupportedOperationException --> NotImplementedException - (not-empty (get (:descendants h) tag))))) -;;; NOT TESTED YET -(defn derive - "Establishes a parent/child relationship between parent and - tag. Parent must be a namespace-qualified symbol or keyword and - child can be either a namespace-qualified symbol or keyword or a - class. h must be a hierarchy obtained from make-hierarchy, if not - supplied defaults to, and modifies, the global hierarchy." - {:added "1.0"} + (System.Text.RegularExpressions.Regex. s))) ;;; (. java.util.regex.Pattern (compile s)))) + +(defn re-matcher + "Returns an instance of java.util.regex.Matcher, for use, e.g. in + re-find." + {:tag clojure.lang.JReMatcher ;;; {:tag java.util.regex.Matcher} + :added "1.0" + :static true} + [^System.Text.RegularExpressions.Regex re s] ;;; java.util.regex.Pattern + (clojure.lang.JReMatcher. re s)) ;;; (. re (matcher s))) + +(defn re-groups + "Returns the groups from the most recent match/find. If there are no + nested groups, returns a string of the entire match. If there are + nested groups, returns a vector of the groups, the first element + being the entire match." + {:added "1.0" + :static true} + [^clojure.lang.JReMatcher m] ;;; java.util.regex.Matcher + (let [gc (. m (groupCount))] + (if (zero? gc) + (. m (group)) + (loop [ret [] c 0] + (if (<= c gc) + (recur (conj ret (. m (group c))) (inc c)) + ret))))) + +(defn re-seq + "Returns a lazy sequence of successive matches of pattern in string, + using java.util.regex.Matcher.find(), each such match processed with + re-groups." + {:added "1.0" + :static true} + [^System.Text.RegularExpressions.Regex re s] ;;; java.util.regex.Pattern + (let [m (re-matcher re s)] + ((fn step [] + (when (. m (find)) + (cons (re-groups m) (lazy-seq (step)))))))) + +(defn re-matches + "Returns the match, if any, of string to pattern, using + java.util.regex.Matcher.matches(). Uses re-groups to return the + groups." + {:added "1.0" + :static true} + [^System.Text.RegularExpressions.Regex re s] ;;; java.util.regex.Pattern + (let [m (re-matcher re s)] + (when (. m (matches)) + (re-groups m)))) + + +(defn re-find + "Returns the next regex match, if any, of string to pattern, using + java.util.regex.Matcher.find(). Uses re-groups to return the + groups." + {:added "1.0" + :static true} + ([^clojure.lang.JReMatcher m] ;;; java.util.regex.Matcher + (when (. m (find)) + (re-groups m))) + ([^System.Text.RegularExpressions.Regex re s] ;;; java.util.regex.Pattern + (let [m (re-matcher re s)] + (re-find m)))) + +(defn rand + "Returns a random floating point number between 0 (inclusive) and + n (default 1) (exclusive)." + {:added "1.0" + :static true} + ([] (. clojure.lang.RT (random))) ;;; Math ==> RT. No Math.random in CLR. + ([n] (* n (rand)))) + +(defn rand-int + "Returns a random integer between 0 (inclusive) and n (exclusive)." + {:added "1.0" + :static true} + [n] (int (rand n))) + +(defmacro defn- + "same as defn, yielding non-public def" + {:added "1.0"} + [name & decls] + (list* `defn (with-meta name (assoc (meta name) :private true)) decls)) + +(defn tree-seq + "Returns a lazy sequence of the nodes in a tree, via a depth-first walk. + branch? must be a fn of one arg that returns true if passed a node + that can have children (but may not). children must be a fn of one + arg that returns a sequence of the children. Will only be called on + nodes for which branch? returns true. Root is the root node of the + tree." + {:added "1.0" + :static true} + [branch? children root] + (let [walk (fn walk [node] + (lazy-seq + (cons node + (when (branch? node) + (mapcat walk (children node))))))] + (walk root))) + +(defn file-seq + "A tree seq on java.io.Files" + {:added "1.0" + :static true} + [dir] + (tree-seq + (fn [x] (instance? System.IO.DirectoryInfo x)) ;;; (fn [^java.io.File f] (. f (isDirectory))) + (fn [^System.IO.DirectoryInfo d] (seq (.GetFileSystemInfos d))) ;;; (fn [^java.io.File d] (seq (. d (listFiles)))) + dir)) + +(defn xml-seq + "A tree seq on the xml elements as per xml/parse" + {:added "1.0" + :static true} + [root] + (tree-seq + (complement string?) + (comp seq :content) + root)) + +(defn special-symbol? + "Returns true if s names a special form" + {:added "1.0" + :static true} + [s] + (contains? (. clojure.lang.Compiler specials) s)) + +(defn var? + "Returns true if v is of type clojure.lang.Var" + {:added "1.0" + :static true} + [v] (instance? clojure.lang.Var v)) + +(defn subs + "Returns the substring of s beginning at start inclusive, and ending + at end (defaults to length of string), exclusive." + {:added "1.0" + :static true} + (^String [^String s start] (. s (Substring start))) ;;; substring => Substring + (^String [^String s start end] (. s (Substring start (- end start))))) ;;; was (substring start end) -- different interpretation of second arg + +(defn max-key + "Returns the x for which (k x), a number, is greatest. + + If there are multiple such xs, the last one is returned." + {:added "1.0" + :static true} + ([k x] x) + ([k x y] (if (> (k x) (k y)) x y)) + ([k x y & more] + (let [kx (k x) ky (k y) + [v kv] (if (> kx ky) [x kx] [y ky])] + (loop [v v kv kv more more] + (if more + (let [w (first more) + kw (k w)] + (if (>= kw kv) + (recur w kw (next more)) + (recur v kv (next more)))) + v))))) + +(defn min-key + "Returns the x for which (k x), a number, is least. + + If there are multiple such xs, the last one is returned." + {:added "1.0" + :static true} + ([k x] x) + ([k x y] (if (< (k x) (k y)) x y)) + ([k x y & more] + (let [kx (k x) ky (k y) + [v kv] (if (< kx ky) [x kx] [y ky])] + (loop [v v kv kv more more] + (if more + (let [w (first more) + kw (k w)] + (if (<= kw kv) + (recur w kw (next more)) + (recur v kv (next more)))) + v))))) + +(defn distinct + "Returns a lazy sequence of the elements of coll with duplicates removed. + Returns a stateful transducer when no collection is provided." + {:added "1.0" + :static true} + ([] + (fn [rf] + (let [seen (volatile! #{})] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (if (contains? @seen input) + result + (do (vswap! seen conj input) + (rf result input)))))))) + ([coll] + (let [step (fn step [xs seen] + (lazy-seq + ((fn [[f :as xs] seen] + (when-let [s (seq xs)] + (if (contains? seen f) + (recur (rest s) seen) + (cons f (step (rest s) (conj seen f)))))) + xs seen)))] + (step coll #{})))) + + + +(defn replace + "Given a map of replacement pairs and a vector/collection, returns a + vector/seq with any elements = a key in smap replaced with the + corresponding val in smap. Returns a transducer when no collection + is provided." + {:added "1.0" + :static true} + ([smap] + (map #(if-let [e (find smap %)] (val e) %))) + ([smap coll] + (if (vector? coll) + (reduce1 (fn [v i] + (if-let [e (find smap (nth v i))] + (assoc v i (val e)) + v)) + coll (range (count coll))) + (map #(if-let [e (find smap %)] (val e) %) coll)))) + +(defmacro dosync + "Runs the exprs (in an implicit do) in a transaction that encompasses + exprs and any nested calls. Starts a transaction if none is already + running on this thread. Any uncaught exception will abort the + transaction and flow out of dosync. The exprs may be run more than + once, but any effects on Refs will be atomic." + {:added "1.0"} + [& exprs] + `(sync nil ~@exprs)) + +(defmacro with-precision + "Sets the precision and rounding mode to be used for BigDecimal operations. + + Usage: (with-precision 10 (/ 1M 3)) + or: (with-precision 10 :rounding HALF_DOWN (/ 1M 3)) + + The rounding mode is one of CEILING, FLOOR, HALF_UP, HALF_DOWN, + HALF_EVEN, UP, DOWN and UNNECESSARY; it defaults to HALF_UP." + {:added "1.0"} + [precision & exprs] + (let [[body rm] (if (= (first exprs) :rounding) + [(next (next exprs)) + `((Enum/Parse clojure.lang.BigDecimal+RoundingMode (name '~(second exprs))))] ;;; `((. java.math.RoundingMode ~(second exprs)))] + [exprs nil])] + `(binding [*math-context* (clojure.lang.BigDecimal+Context. ~precision ~@rm)] ;;; (java.math.MathContext. ~precision ~@rm)] + ~@body))) + +(defn mk-bound-fn + {:private true} + [^clojure.lang.Sorted sc test key] + (fn [e] + (test (.. sc comparator (compare (. sc entryKey e) key)) 0))) + +(defn subseq + "sc must be a sorted collection, test(s) one of <, <=, > or + >=. Returns a seq of those entries with keys ek for + which (test (.. sc comparator (compare ek key)) 0) is true" + {:added "1.0" + :static true} + ([^clojure.lang.Sorted sc test key] + (let [include (mk-bound-fn sc test key)] + (if (#{> >=} test) + (when-let [[e :as s] (. sc seqFrom key true)] + (if (include e) s (next s))) + (take-while include (. sc seq true))))) + ([^clojure.lang.Sorted sc start-test start-key end-test end-key] + (when-let [[e :as s] (. sc seqFrom start-key true)] + (take-while (mk-bound-fn sc end-test end-key) + (if ((mk-bound-fn sc start-test start-key) e) s (next s)))))) + +(defn rsubseq + "sc must be a sorted collection, test(s) one of <, <=, > or + >=. Returns a reverse seq of those entries with keys ek for + which (test (.. sc comparator (compare ek key)) 0) is true" + {:added "1.0" + :static true} + ([^clojure.lang.Sorted sc test key] + (let [include (mk-bound-fn sc test key)] + (if (#{< <=} test) + (when-let [[e :as s] (. sc seqFrom key false)] + (if (include e) s (next s))) + (take-while include (. sc seq false))))) + ([^clojure.lang.Sorted sc start-test start-key end-test end-key] + (when-let [[e :as s] (. sc seqFrom end-key false)] + (take-while (mk-bound-fn sc start-test start-key) + (if ((mk-bound-fn sc end-test end-key) e) s (next s)))))) + +(defn repeatedly + "Takes a function of no args, presumably with side effects, and + returns an infinite (or length n if supplied) lazy sequence of calls + to it" + {:added "1.0" + :static true} + ([f] (lazy-seq (cons (f) (repeatedly f)))) + ([n f] (take n (repeatedly f)))) +;;; What is CLR equivalent -- should this just be a no-op? +;(defn add-classpath +; "DEPRECATED +; +; Adds the url (String or URL object) to the classpath per +; URLClassLoader.addURL" +; {:added "1.0" +; :deprecated "1.2"} +; [url] +; (println "WARNING: add-classpath is deprecated") +; (clojure.lang.RT/addURL url)) + + + +(defn hash + "Returns the hash code of its argument. Note this is the hash code + consistent with =, and thus is different than .hashCode for Integer, + Short, Byte and Clojure collections." + + {:added "1.0" + :static true} + [x] (. clojure.lang.Util (hasheq x))) + + +(defn mix-collection-hash + "Mix final collection hash for ordered or unordered collections. + hash-basis is the combined collection hash, count is the number + of elements included in the basis. Note this is the hash code + consistent with =, different from .hashCode. + See http://clojure.org/data_structures#hash for full algorithms." + {:added "1.6" + :static true} + ^long + [^long hash-basis ^long count] (clojure.lang.Murmur3/MixCollHash hash-basis count)) ;;; mixCollHash + +(defn hash-ordered-coll + "Returns the hash code, consistent with =, for an external ordered + collection implementing Iterable. + See http://clojure.org/data_structures#hash for full algorithms." + {:added "1.6" + :static true} + ^long + [coll] (clojure.lang.Murmur3/HashOrdered coll)) ;;; hashOrdered + +(defn hash-unordered-coll + "Returns the hash code, consistent with =, for an external unordered + collection implementing Iterable. For maps, the iterator should + return map entries whose hash is computed as + (hash-ordered-coll [k v]). + See http://clojure.org/data_structures#hash for full algorithms." + {:added "1.6" + :static true} + ^long + [coll] (clojure.lang.Murmur3/HashUnordered coll)) ;;; hashUnordered + +(defn interpose + "Returns a lazy seq of the elements of coll separated by sep. + Returns a stateful transducer when no collection is provided." + {:added "1.0" + :static true} + ([sep] + (fn [rf] + (let [started (volatile! false)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (if @started + (let [sepr (rf result sep)] + (if (reduced? sepr) + sepr + (rf sepr input))) + (do + (vreset! started true) + (rf result input)))))))) + ([sep coll] + (drop 1 (interleave (repeat sep) coll)))) + +(defmacro definline + "Experimental - like defmacro, except defines a named function whose + body is the expansion, calls to which may be expanded inline as if + it were a macro. Cannot be used with variadic (&) args." + {:added "1.0"} + [name & decl] + (let [[pre-args [args expr]] (split-with (comp not vector?) decl)] + `(do + (defn ~name ~@pre-args ~args ~(apply (eval (list `fn args expr)) args)) + (alter-meta! (var ~name) assoc :inline (fn ~name ~args ~expr)) + (var ~name)))) + +(defn empty + "Returns an empty collection of the same category as coll, or nil" + {:added "1.0" + :static true} + [coll] + (when (instance? clojure.lang.IPersistentCollection coll) + (.empty ^clojure.lang.IPersistentCollection coll))) + +(defmacro amap + "Maps an expression across an array a, using an index named idx, and + return value named ret, initialized to a clone of a, then setting + each element of ret to the evaluation of expr, returning the new + array ret." + {:added "1.0"} + [a idx ret expr] + `(let [a# ~a l# (alength a#) + ~ret (aclone a#)] + (loop [~idx 0] + (if (< ~idx l#) + (do + (aset ~ret ~idx ~expr) + (recur (unchecked-inc ~idx))) + ~ret)))) + +(defmacro areduce + "Reduces an expression across an array a, using an index named idx, + and return value named ret, initialized to init, setting ret to the + evaluation of expr at each step, returning ret." + {:added "1.0"} + [a idx ret init expr] + `(let [a# ~a l# (alength a#)] + (loop [~idx 0 ~ret ~init] + (if (< ~idx l#) + (recur (unchecked-inc-int ~idx) ~expr) + ~ret)))) + +(defn float-array + "Creates an array of floats" + {:inline (fn [& args] `(. clojure.lang.Numbers float_array ~@args)) + :inline-arities #{1 2} + :added "1.0"} + ([size-or-seq] (. clojure.lang.Numbers float_array size-or-seq)) + ([size init-val-or-seq] (. clojure.lang.Numbers float_array size init-val-or-seq))) + +(defn boolean-array + "Creates an array of booleans" + {:inline (fn [& args] `(. clojure.lang.Numbers boolean_array ~@args)) + :inline-arities #{1 2} + :added "1.1"} + ([size-or-seq] (. clojure.lang.Numbers boolean_array size-or-seq)) + ([size init-val-or-seq] (. clojure.lang.Numbers boolean_array size init-val-or-seq))) + +(defn byte-array + "Creates an array of bytes" + {:inline (fn [& args] `(. clojure.lang.Numbers byte_array ~@args)) + :inline-arities #{1 2} + :added "1.1"} + ([size-or-seq] (. clojure.lang.Numbers byte_array size-or-seq)) + ([size init-val-or-seq] (. clojure.lang.Numbers byte_array size init-val-or-seq))) + +(defn char-array + "Creates an array of chars" + {:inline (fn [& args] `(. clojure.lang.Numbers char_array ~@args)) + :inline-arities #{1 2} + :added "1.1"} + ([size-or-seq] (. clojure.lang.Numbers char_array size-or-seq)) + ([size init-val-or-seq] (. clojure.lang.Numbers char_array size init-val-or-seq))) + +(defn short-array + "Creates an array of shorts" + {:inline (fn [& args] `(. clojure.lang.Numbers short_array ~@args)) + :inline-arities #{1 2} + :added "1.1"} + ([size-or-seq] (. clojure.lang.Numbers short_array size-or-seq)) + ([size init-val-or-seq] (. clojure.lang.Numbers short_array size init-val-or-seq))) + +(defn double-array + "Creates an array of doubles" + {:inline (fn [& args] `(. clojure.lang.Numbers double_array ~@args)) + :inline-arities #{1 2} + :added "1.0"} + ([size-or-seq] (. clojure.lang.Numbers double_array size-or-seq)) + ([size init-val-or-seq] (. clojure.lang.Numbers double_array size init-val-or-seq))) + +(defn object-array + "Creates an array of objects" + {:inline (fn [arg] `(. clojure.lang.RT object_array ~arg)) + :inline-arities #{1} + :added "1.2"} + ([size-or-seq] (. clojure.lang.RT object_array size-or-seq))) + +(defn int-array + "Creates an array of ints" + {:inline (fn [& args] `(. clojure.lang.Numbers int_array ~@args)) + :inline-arities #{1 2} + :added "1.0"} + ([size-or-seq] (. clojure.lang.Numbers int_array size-or-seq)) + ([size init-val-or-seq] (. clojure.lang.Numbers int_array size init-val-or-seq))) + +(defn long-array + "Creates an array of longs" + {:inline (fn [& args] `(. clojure.lang.Numbers long_array ~@args)) + :inline-arities #{1 2} + :added "1.0"} + ([size-or-seq] (. clojure.lang.Numbers long_array size-or-seq)) + ([size init-val-or-seq] (. clojure.lang.Numbers long_array size init-val-or-seq))) + +(definline booleans + "Casts to boolean[]" + {:added "1.1"} + [xs] `(. clojure.lang.Numbers booleans ~xs)) + +(definline bytes + "Casts to bytes[]" + {:added "1.1"} + [xs] `(. clojure.lang.Numbers bytes ~xs)) + +(definline chars + "Casts to chars[]" + {:added "1.1"} + [xs] `(. clojure.lang.Numbers chars ~xs)) + +(definline shorts + "Casts to shorts[]" + {:added "1.1"} + [xs] `(. clojure.lang.Numbers shorts ~xs)) + +(definline floats + "Casts to float[]" + {:added "1.0"} + [xs] `(. clojure.lang.Numbers floats ~xs)) + +(definline ints + "Casts to int[]" + {:added "1.0"} + [xs] `(. clojure.lang.Numbers ints ~xs)) + +(definline doubles + "Casts to double[]" + {:added "1.0"} + [xs] `(. clojure.lang.Numbers doubles ~xs)) + +(definline longs + "Casts to long[]" + {:added "1.0"} + [xs] `(. clojure.lang.Numbers longs ~xs)) + +(defn bytes? + "Return true if x is a byte array" + {:added "1.9"} + [x] (if (nil? x) + false + (let [t (class x)] (and (.IsArray t) (= (.GetElementType t) Byte))))) ;;; (-> x class .getComponentType (= Byte/TYPE)) + +;(import '(java.util.concurrent BlockingQueue LinkedBlockingQueue)) +;;;NOT WORTH THE EFFORT AT THE MOMENT +;(defn seque +; "Creates a queued seq on another (presumably lazy) seq s. The queued +; seq will produce a concrete seq in the background, and can get up to +; n items ahead of the consumer. n-or-q can be an integer n buffer +; size, or an instance of java.util.concurrent BlockingQueue. Note +; that reading from a seque can block if the reader gets ahead of the +; producer." +; {:added "1.0" +; :static true} +; ([s] (seque 100 s)) +; ([n-or-q s] +; (let [^BlockingQueue q (if (instance? BlockingQueue n-or-q) +; n-or-q +; (LinkedBlockingQueue. (int n-or-q))) +; NIL (Object.) ;nil sentinel since LBQ doesn't support nils +; agt (agent (lazy-seq s)) ; never start with nil; that signifies we've already put eos +; log-error (fn [q e] +; (if (.offer q q) +; (throw e) +; e)) +; fill (fn [s] +; (when s +; (if (instance? Exception s) ; we failed to .offer an error earlier +; (log-error q s) +; (try +; (loop [[x & xs :as s] (seq s)] +; (if s +; (if (.offer q (if (nil? x) NIL x)) +; (recur xs) +; s) +; (when-not (.offer q q) ; q itself is eos sentinel +; ()))) ; empty seq, not nil, so we know to put eos next time +; (catch Exception e +; (log-error q e)))))) +; drain (fn drain [] +; (lazy-seq +; (let [x (.take q)] +; (if (identical? x q) ;q itself is eos sentinel +; (do @agt nil) ;touch agent just to propagate errors +; (do +; (send-off agt fill) +; (release-pending-sends) +; (cons (if (identical? x NIL) nil x) (drain)))))))] +; (send-off agt fill) +; (drain)))) + +(defn class? + "Returns true if x is an instance of Class" + {:added "1.0" + :static true} + [x] (instance? Type x)) ;; Class ==> Type + +;(defn- is-annotation? [c] +; (and (class? c) +; (.isAssignableFrom java.lang.annotation.Annotation c))) +; +;(defn- is-runtime-annotation? [^Class c] +; (boolean +; (and (is-annotation? c) +; (when-let [^java.lang.annotation.Retention r +; (.getAnnotation c java.lang.annotation.Retention)] +; (= (.value r) java.lang.annotation.RetentionPolicy/RUNTIME))))) +; +;(defn- descriptor [^Class c] (clojure.asm.Type/getDescriptor c)) +; +;(declare process-annotation) +;(defn- add-annotation [^clojure.asm.AnnotationVisitor av name v] +; (cond +; (vector? v) (let [avec (.visitArray av name)] +; (doseq [vval v] +; (add-annotation avec "value" vval)) +; (.visitEnd avec)) +; (symbol? v) (let [ev (eval v)] +; (cond +; (instance? java.lang.Enum ev) +; (.visitEnum av name (descriptor (class ev)) (str ev)) +; (class? ev) (.visit av name (clojure.asm.Type/getType ev)) +; :else (throw (IllegalArgumentException. +; (str "Unsupported annotation value: " v " of class " (class ev)))))) +; (seq? v) (let [[nested nv] v +; c (resolve nested) +; nav (.visitAnnotation av name (descriptor c))] +; (process-annotation nav nv) +; (.visitEnd nav)) +; :else (.visit av name v))) +; +;(defn- process-annotation [av v] +; (if (map? v) +; (doseq [[k v] v] +; (add-annotation av (name k) v)) +; (add-annotation av "value" v))) +; +;(defn- add-annotations +; ([visitor m] (add-annotations visitor m nil)) +; ([visitor m i] +; (doseq [[k v] m] +; (when (symbol? k) +; (when-let [c (resolve k)] +; (when (is-annotation? c) +; ;this is known duck/reflective as no common base of ASM Visitors +; (let [av (if i +; (.visitParameterAnnotation visitor i (descriptor c) +; (is-runtime-annotation? c)) +; (.visitAnnotation visitor (descriptor c) +; (is-runtime-annotation? c)))] +; (process-annotation av v) +; (.visitEnd av)))))))) + +(defn alter-var-root + "Atomically alters the root binding of var v by applying f to its + current value plus any args" + {:added "1.0" + :static true} + [^clojure.lang.Var v f & args] (.alterRoot v f args)) + +(defn bound? + "Returns true if all of the vars provided as arguments have any bound value, root or thread-local. + Implies that deref'ing the provided vars will succeed. Returns true if no vars are provided." + {:added "1.2" + :static true} + [& vars] + (every? #(.isBound ^clojure.lang.Var %) vars)) + +(defn thread-bound? + "Returns true if all of the vars provided as arguments have thread-local bindings. + Implies that set!'ing the provided vars will succeed. Returns true if no vars are provided." + {:added "1.2" + :static true} + [& vars] + (every? #(.getThreadBinding ^clojure.lang.Var %) vars)) + +(defn make-hierarchy + "Creates a hierarchy object for use with derive, isa? etc." + {:added "1.0" + :static true} + [] {:parents {} :descendants {} :ancestors {}}) + +(def ^{:private true} + global-hierarchy (make-hierarchy)) + +(defn not-empty + "If coll is empty, returns nil, else coll" + {:added "1.0" + :static true} + [coll] (when (seq coll) coll)) + +(defn bases + "Returns the immediate superclass and direct interfaces of c, if any" + {:added "1.0" + :static true} + [^Type c] ;;; Class ==> Type + (when c + (let [i (seq (.GetInterfaces c)) ;;; .getInterfaces ==> .GetInterfaces + s (.BaseType c)] ;;; .getSuperclass ==> BaseType + (if s (cons s i) i)))) + +(defn supers + "Returns the immediate and indirect superclasses and interfaces of c, if any" + {:added "1.0" + :static true} + [^Type class] ;;; Class ==> Type + (loop [ret (set (bases class)) cs ret] + (if (seq cs) + (let [c (first cs) bs (bases c)] + (recur (into1 ret bs) (into1 (disj cs c) bs))) + (not-empty ret)))) + +(defn isa? + "Returns true if (= child parent), or child is directly or indirectly derived from + parent, either via a Java type inheritance relationship or a + relationship established via derive. h must be a hierarchy obtained + from make-hierarchy, if not supplied defaults to the global + hierarchy" + {:added "1.0"} + ([child parent] (isa? global-hierarchy child parent)) + ([h child parent] + (or (= child parent) + (and (class? parent) (class? child) + (. ^Type parent IsAssignableFrom child)) ;;; Class ==> Type, isAssignableFrom + (contains? ((:ancestors h) child) parent) + (and (class? child) (some #(contains? ((:ancestors h) %) parent) (supers child))) + (and (vector? parent) (vector? child) + (= (count parent) (count child)) + (loop [ret true i 0] + (if (or (not ret) (= i (count parent))) + ret + (recur (isa? h (child i) (parent i)) (inc i)))))))) + +(defn parents + "Returns the immediate parents of tag, either via a Java type + inheritance relationship or a relationship established via derive. h + must be a hierarchy obtained from make-hierarchy, if not supplied + defaults to the global hierarchy" + {:added "1.0"} + ([tag] (parents global-hierarchy tag)) + ([h tag] (not-empty + (let [tp (get (:parents h) tag)] + (if (class? tag) + (into1 (set (bases tag)) tp) + tp))))) + +(defn ancestors + "Returns the immediate and indirect parents of tag, either via a Java type + inheritance relationship or a relationship established via derive. h + must be a hierarchy obtained from make-hierarchy, if not supplied + defaults to the global hierarchy" + {:added "1.0"} + ([tag] (ancestors global-hierarchy tag)) + ([h tag] (not-empty + (let [ta (get (:ancestors h) tag)] + (if (class? tag) + (let [superclasses (set (supers tag))] + (reduce1 into1 superclasses + (cons ta + (map #(get (:ancestors h) %) superclasses)))) + ta))))) +;;; NOT TESTED YET +(defn descendants + "Returns the immediate and indirect children of tag, through a + relationship established via derive. h must be a hierarchy obtained + from make-hierarchy, if not supplied defaults to the global + hierarchy. Note: does not work on Java type inheritance + relationships." + {:added "1.0"} + ([tag] (descendants global-hierarchy tag)) + ([h tag] (if (class? tag) + (throw (NotImplementedException. "Can't get descendants of classes")) ;;; java.lang.UnsupportedOperationException --> NotImplementedException + (not-empty (get (:descendants h) tag))))) +;;; NOT TESTED YET +(defn derive + "Establishes a parent/child relationship between parent and + tag. Parent must be a namespace-qualified symbol or keyword and + child can be either a namespace-qualified symbol or keyword or a + 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)))) @@ -5688,471 +5688,471 @@ Note that read can execute code (controlled by *read-eval*), {: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) - -(defn underive - "Removes a parent/child relationship between parent and - tag. h must be a hierarchy obtained from make-hierarchy, if not - supplied defaults to, and modifies, the global hierarchy." - {:added "1.0"} - ([tag parent] (alter-var-root #'global-hierarchy underive tag parent) nil) - ([h tag parent] - (let [parentMap (:parents h) - childsParents (if (parentMap tag) - (disj (parentMap tag) parent) #{}) - newParents (if (not-empty childsParents) - (assoc parentMap tag childsParents) - (dissoc parentMap tag)) - deriv-seq (flatten (map #(cons (key %) (interpose (key %) (val %))) - (seq newParents)))] - (if (contains? (parentMap tag) parent) - (reduce1 #(apply derive %1 %2) (make-hierarchy) - (partition 2 deriv-seq)) - h)))) - - -(defn distinct? - "Returns true if no two of the arguments are =" - {:tag Boolean - :added "1.0" - :static true} - ([x] true) - ([x y] (not (= x y))) - ([x y & more] - (if (not= x y) - (loop [s #{x y} [x & etc :as xs] more] - (if xs - (if (contains? s x) - false - (recur (conj s x) etc)) - true)) - false))) -;;; Not clear what to work against here. -;(defn resultset-seq -; "Creates and returns a lazy sequence of structmaps corresponding to -; the rows in the java.sql.ResultSet rs" -; {:added "1.0"} -; [^java.sql.ResultSet rs] -; (let [rsmeta (. rs (getMetaData)) -; idxs (range 1 (inc (. rsmeta (getColumnCount)))) -; keys (map (comp keyword #(.toLowerCase ^String %)) -; (map (fn [i] (. rsmeta (getColumnLabel i))) idxs)) -; check-keys -; (or (apply distinct? keys) -; (throw (Exception. "ResultSet must have unique column labels"))) -; row-struct (apply create-struct keys) -; row-values (fn [] (map (fn [^Integer i] (. rs (getObject i))) idxs)) -; rows (fn thisfn [] -; (when (. rs (next)) -; (cons (apply struct row-struct (row-values)) (lazy-seq (thisfn)))))] -; (rows))) - -(defn iterator-seq - "Returns a seq on a java.util.Iterator. Note that most collections - providing iterators implement Iterable and thus support seq directly. - Seqs cache values, thus iterator-seq should not be used on any - iterator that repeatedly returns the same mutable object." - {:added "1.0" - :static true} - [iter] - (clojure.lang.RT/chunkEnumeratorSeq iter)) ;;; chunkIteratorSeq - -(defn enumeration-seq - "Returns a seq on a java.util.Enumeration" - {:added "1.0" - :static true} - [e] - (clojure.lang.EnumeratorSeq/create e)) ;;; EnumerationSeq - -(defn format - "Formats a string using java.lang.String.format, see java.util.Formatter for format - string syntax" - {:added "1.0" - :static true} - ^String [fmt & args] - (clojure.lang.Printf/Format fmt (to-array args))) ;;;(String/format fmt (to-array args))) - -(defn printf - "Prints formatted output, as per format" - {:added "1.0" - :static true} - [fmt & args] - (print (apply format fmt args))) - + h)))) + +(declare flatten) + +(defn underive + "Removes a parent/child relationship between parent and + tag. h must be a hierarchy obtained from make-hierarchy, if not + supplied defaults to, and modifies, the global hierarchy." + {:added "1.0"} + ([tag parent] (alter-var-root #'global-hierarchy underive tag parent) nil) + ([h tag parent] + (let [parentMap (:parents h) + childsParents (if (parentMap tag) + (disj (parentMap tag) parent) #{}) + newParents (if (not-empty childsParents) + (assoc parentMap tag childsParents) + (dissoc parentMap tag)) + deriv-seq (flatten (map #(cons (key %) (interpose (key %) (val %))) + (seq newParents)))] + (if (contains? (parentMap tag) parent) + (reduce1 #(apply derive %1 %2) (make-hierarchy) + (partition 2 deriv-seq)) + h)))) + + +(defn distinct? + "Returns true if no two of the arguments are =" + {:tag Boolean + :added "1.0" + :static true} + ([x] true) + ([x y] (not (= x y))) + ([x y & more] + (if (not= x y) + (loop [s #{x y} [x & etc :as xs] more] + (if xs + (if (contains? s x) + false + (recur (conj s x) etc)) + true)) + false))) +;;; Not clear what to work against here. +;(defn resultset-seq +; "Creates and returns a lazy sequence of structmaps corresponding to +; the rows in the java.sql.ResultSet rs" +; {:added "1.0"} +; [^java.sql.ResultSet rs] +; (let [rsmeta (. rs (getMetaData)) +; idxs (range 1 (inc (. rsmeta (getColumnCount)))) +; keys (map (comp keyword #(.toLowerCase ^String %)) +; (map (fn [i] (. rsmeta (getColumnLabel i))) idxs)) +; check-keys +; (or (apply distinct? keys) +; (throw (Exception. "ResultSet must have unique column labels"))) +; row-struct (apply create-struct keys) +; row-values (fn [] (map (fn [^Integer i] (. rs (getObject i))) idxs)) +; rows (fn thisfn [] +; (when (. rs (next)) +; (cons (apply struct row-struct (row-values)) (lazy-seq (thisfn)))))] +; (rows))) + +(defn iterator-seq + "Returns a seq on a java.util.Iterator. Note that most collections + providing iterators implement Iterable and thus support seq directly. + Seqs cache values, thus iterator-seq should not be used on any + iterator that repeatedly returns the same mutable object." + {:added "1.0" + :static true} + [iter] + (clojure.lang.RT/chunkEnumeratorSeq iter)) ;;; chunkIteratorSeq + +(defn enumeration-seq + "Returns a seq on a java.util.Enumeration" + {:added "1.0" + :static true} + [e] + (clojure.lang.EnumeratorSeq/create e)) ;;; EnumerationSeq + +(defn format + "Formats a string using java.lang.String.format, see java.util.Formatter for format + string syntax" + {:added "1.0" + :static true} + ^String [fmt & args] + (clojure.lang.Printf/Format fmt (to-array args))) ;;;(String/format fmt (to-array args))) + +(defn printf + "Prints formatted output, as per format" + {:added "1.0" + :static true} + [fmt & args] + (print (apply format fmt args))) + (declare gen-class) ;;; no clear equivalent for us -(defmacro with-loading-context [& body] - `((fn loading# [] - (. clojure.lang.Var (pushThreadBindings {})) ;;;{clojure.lang.Compiler/LOADER - ;;;(.getClassLoader (.getClass ^Object loading#))})) - (try - ~@body - (finally - (. clojure.lang.Var (popThreadBindings))))))) +(defmacro with-loading-context [& body] + `((fn loading# [] + (. clojure.lang.Var (pushThreadBindings {})) ;;;{clojure.lang.Compiler/LOADER + ;;;(.getClassLoader (.getClass ^Object loading#))})) + (try + ~@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*]) + :added "1.0"} + [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 + (vary-meta name assoc :doc docstring) + name) + metadata (when (map? (first references)) (first references)) + references (if metadata (next references) references) + 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 + references (remove #(= :gen-class (first %)) references) + ;ns-effect (clojure.core/in-ns name) + name-metadata (meta name)] + `(do + (clojure.core/in-ns '~name) + ~@(when name-metadata + `((.resetMeta (clojure.lang.Namespace/find '~name) ~name-metadata))) + (with-loading-context + ~@(when gen-class-call (list gen-class-call)) + ~@(when (and (not= name 'clojure.core) (not-any? #(= :refer-clojure (first %)) references)) + `((clojure.core/refer '~'clojure.core))) + ~@(map process-reference references)) + (if (.Equals '~name 'clojure.core) ;;; .equals + nil + (do (dosync (commute @#'*loaded-libs* conj '~name)) nil))))) + +(defmacro refer-clojure + "Same as (refer 'clojure.core )" + {:added "1.0"} + [& filters] + `(clojure.core/refer '~'clojure.core ~@filters)) + +(defmacro defonce + "defs name to have the root value of the expr iff the named var has no root value, + else expr is unevaluated" + {:added "1.0"} + [name expr] + `(let [v# (def ~name)] + (when-not (.hasRoot v#) + (def ~name ~expr)))) + +;;;;;;;;;;; require/use/load, contributed by Stephen C. Gilardi ;;;;;;;;;;;;;;;;;; + +(defonce ^:dynamic + ^{:private true + :doc "A ref to a sorted set of symbols representing loaded libs"} + *loaded-libs* (ref (sorted-set))) + +(defonce ^:dynamic + ^{:private true + :doc "A stacj of paths currently being loaded by this thread"} + *pending-paths* ()) + +(defonce ^:dynamic + ^{:private true :doc + "True while a verbose load is pending"} + *loading-verbosely* false) + +(defn- throw-if + "Throws a CompileException with a message if pred is true" + [pred fmt & args] + (when pred + (let [ ^String message (apply format fmt args) + exception (Exception. message) + raw-trace (.GetFrames (System.Diagnostics.StackTrace.)) ;;; (.getStackTrace exception) unthrown exception has null stacktrace -- use diagnostics to get the stacktrace + boring? #(not= (.Name (.GetMethod ^System.Diagnostics.StackFrame %)) "doInvoke") ;;; ^StackTraceElement + trace (into-array System.Diagnostics.StackFrame (drop 2 (drop-while boring? raw-trace)))] ;;; .getMethodName => .Name .GetMethod StackTraceElement + (.Add (.Data exception) "StackTrace" trace) ;;; (.setStackTrace exception trace) - can't set stack trace, so store the filtered trace on the Data element' + (throw (clojure.lang.Compiler+CompilerException. ;;; Compiler$CompilerException + *file* + (.deref clojure.lang.Compiler/LineVar) ;;; LINE + (.deref clojure.lang.Compiler/ColumnVar) ;;; COLUMN + exception))))) + +(defn- libspec? + "Returns true if x is a libspec" + [x] + (or (symbol? x) + (and (vector? x) + (or + (nil? (second x)) + (keyword? (second x)))))) + +(defn- prependss + "Prepends a symbol or a seq to coll" + [x coll] + (if (symbol? x) + (cons x coll) + (concat x coll))) + +(defn- root-resource + "Returns the root directory path for a lib" + {:tag String} + [lib] + (str \/ + (.. (name lib) + (Replace \- \_) ;;; replace + (Replace \. \/)))) ;;; replace + +(defn- root-directory + "Returns the root resource path for a lib" + [lib] + (let [d (root-resource lib)] + (subs d 0 (.LastIndexOf d "/")))) ;;; lastIndexOf + +(def ^:declared ^:redef load) + +(defn- load-one + "Loads a lib given its name. If need-ns, ensures that the associated + namespace exists after loading. If require, records the load so any + duplicate loads can be skipped." + [lib need-ns require] + (load (root-resource lib)) + (throw-if (and need-ns (not (find-ns lib))) + "namespace '%s' not found after loading '%s'" + lib (root-resource lib)) + (when require + (dosync + (commute *loaded-libs* conj lib)))) + +(defn- load-all + "Loads a lib given its name and forces a load of any libs it directly or + indirectly loads. If need-ns, ensures that the associated namespace + exists after loading. If require, records the load so any duplicate loads + can be skipped." + [lib need-ns require] + (dosync + (commute *loaded-libs* #(reduce1 conj %1 %2) + (binding [*loaded-libs* (ref (sorted-set))] + (load-one lib need-ns require) + @*loaded-libs*)))) + +(defn- load-lib + "Loads a lib with options" + [prefix lib & options] + (throw-if (and prefix (pos? (.IndexOf (name lib) \.))) ;;; indexOf & (int \.) + "Found lib name '%s' containing period with prefix '%s'. lib names inside prefix lists must not contain periods" + (name lib) prefix) + (let [lib (if prefix (symbol (str prefix \. lib)) lib) + opts (apply hash-map options) + {:keys [as reload reload-all require use verbose as-alias]} opts + loaded (contains? @*loaded-libs* lib) + need-ns (or as use) + load (cond reload-all load-all + reload load-one + (not loaded) (cond need-ns load-one + as-alias (fn [lib _need _require] (create-ns lib)) + :else load-one)) + + filter-opts (select-keys opts '(:exclude :only :rename :refer)) + undefined-on-entry (not (find-ns lib))] + (binding [*loading-verbosely* (or *loading-verbosely* verbose)] + (if load + (try + (load lib need-ns require) + (catch Exception e + (when undefined-on-entry + (remove-ns lib)) + (throw e))) + (throw-if (and need-ns (not (find-ns lib))) + "namespace '%s' not found" lib)) + (when (and need-ns *loading-verbosely*) + (printf "(clojure.core/in-ns '%s)\n" (ns-name *ns*))) + (when as + (when *loading-verbosely* + (printf "(clojure.core/alias '%s '%s)\n" as lib)) + (alias as lib)) + (when as-alias + (when *loading-verbosely* + (printf "(clojure.core/alias '%s '%s)\n" as-alias lib)) + (alias as-alias lib)) + (when (or use (:refer filter-opts)) + (when *loading-verbosely* + (printf "(clojure.core/refer '%s" lib) + (doseq [opt filter-opts] + (printf " %s '%s" (key opt) (print-str (val opt)))) + (printf ")\n")) + (apply refer lib (mapcat seq filter-opts)))))) + +(defn- load-libs + "Loads libs, interpreting libspecs, prefix lists, and flags for + forwarding to load-lib" + [& args] + (let [flags (filter keyword? args) + opts (interleave flags (repeat true)) + args (filter (complement keyword?) args)] + ; check for unsupported options + (let [supported #{:as :reload :reload-all :require :use :verbose :refer :as-alias} + unsupported (seq (remove supported flags))] + (throw-if unsupported + (apply str "Unsupported option(s) supplied: " + (interpose \, unsupported)))) + ; check a load target was specified + (throw-if (not (seq args)) "Nothing specified to load") + (doseq [arg args] + (if (libspec? arg) + (apply load-lib nil (prependss arg opts)) + (let [[prefix & args] arg] + (throw-if (nil? prefix) "prefix cannot be nil") + (doseq [arg args] + (apply load-lib prefix (prependss arg opts)))))))) + +(defn- check-cyclic-dependency + "Detects and rejects non-trivial cyclic load dependencies. The + exception message shows the dependency chain with the cycle + highlighted. Ignores the trivial case of a file attempting to load + itself because that can occur when a gen-class'd class loads its + implementation." + [path] + (when (some #{path} (rest *pending-paths*)) + (let [pending (map #(if (= % path) (str "[ " % " ]") %) + (cons path *pending-paths*)) + chain (apply str (interpose "->" pending))] + (throw-if true "Cyclic load dependency: %s" chain)))) + +;; Public + +(defn require + "Loads libs, skipping any that are already loaded. Each argument is + either a libspec that identifies a lib, a prefix list that identifies + multiple libs whose names share a common prefix, or a flag that modifies + how all the identified libs are loaded. Use :require in the ns macro + in preference to calling this directly. + + Libs + + A 'lib' is a named set of resources in classpath whose contents define a + library of Clojure code. Lib names are symbols and each lib is associated + with a Clojure namespace and a Java package that share its name. A lib's + name also locates its root directory within classpath using Java's + package name to classpath-relative path mapping. All resources in a lib + should be contained in the directory structure under its root directory. + All definitions a lib makes should be in its associated namespace. + + 'require loads a lib by loading its root resource. The root resource path + is derived from the lib name in the following manner: + Consider a lib named by the symbol 'x.y.z; it has the root directory + /x/y/, and its root resource is /x/y/z.clj, or + /x/y/z.cljc if /x/y/z.clj does not exist. The + root resource should contain code to create the lib's + namespace (usually by using the ns macro) and load any additional + lib resources. + + Libspecs + + A libspec is a lib name or a vector containing a lib name followed by + options expressed as sequential keywords and arguments. + + Recognized options: + :as takes a symbol as its argument and makes that symbol an alias to the + lib's namespace in the current namespace. + :as-alias takes a symbol as its argument and aliases like :as, however + the lib will not be loaded. If the lib has not been loaded, a new + empty namespace will be created (as with create-ns). + :refer takes a list of symbols to refer from the namespace or the :all + keyword to bring in all public vars. + + Prefix Lists + + It's common for Clojure code to depend on several libs whose names have + the same prefix. When specifying libs, prefix lists can be used to reduce + repetition. A prefix list contains the shared prefix followed by libspecs + with the shared prefix removed from the lib names. After removing the + prefix, the names that remain must not contain any periods. -(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: + Flags + + A flag is a keyword. + Recognized flags: :reload, :reload-all, :verbose + :reload forces loading of all the identified libs even if they are + already loaded (has no effect on libspecs using :as-alias) + :reload-all implies :reload and also forces loading of all libs that the + identified libs directly or indirectly load via require or use + (has no effect on libspecs using :as-alias) + :verbose triggers printing information about each load, alias, and refer + + Example: + + The following would load the libraries clojure.zip and clojure.set + abbreviated as 's'. + + (require '(clojure zip [set :as s]))" + {:added "1.0"} + + [& args] + (apply load-libs :require args)) + +(defn- serialized-require + "Like 'require', but serializes loading. + Interim function preferred over 'require' for known asynchronous loads. + Future changes may make these equivalent." + {:added "1.10"} + [& args] + (locking clojure.lang.RT/REQUIRE_LOCK + (apply require args))) + +(defn requiring-resolve + "Resolves namespace-qualified sym per 'resolve'. If initial resolve +fails, attempts to require sym's namespace and retries." + {:added "1.10"} + [sym] + (if (qualified-symbol? sym) + (or (resolve sym) + (do (-> sym namespace symbol serialized-require) + (resolve sym))) + (throw (ArgumentException. (str "Not a qualified symbol: " sym))))) ;;; IllegalArgumentException. + +(defn use + "Like 'require, but also refers to each lib's namespace using + clojure.core/refer. Use :use in the ns macro in preference to calling + this directly. + + 'use accepts additional options in libspecs: :exclude, :only, :rename. + The arguments and semantics for :exclude, :only, and :rename are the same + as those documented for clojure.core/refer." + {:added "1.0"} + [& args] (apply load-libs :require :use args)) + +(defn loaded-libs + "Returns a sorted set of symbols naming the currently loaded libs" + {:added "1.0"} + [] @*loaded-libs*) - (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))) - docstring (when (string? (first references)) (first references)) - references (if docstring (next references) references) - name (if docstring - (vary-meta name assoc :doc docstring) - name) - metadata (when (map? (first references)) (first references)) - references (if metadata (next references) references) - 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 - references (remove #(= :gen-class (first %)) references) - ;ns-effect (clojure.core/in-ns name) - name-metadata (meta name)] - `(do - (clojure.core/in-ns '~name) - ~@(when name-metadata - `((.resetMeta (clojure.lang.Namespace/find '~name) ~name-metadata))) - (with-loading-context - ~@(when gen-class-call (list gen-class-call)) - ~@(when (and (not= name 'clojure.core) (not-any? #(= :refer-clojure (first %)) references)) - `((clojure.core/refer '~'clojure.core))) - ~@(map process-reference references)) - (if (.Equals '~name 'clojure.core) ;;; .equals - nil - (do (dosync (commute @#'*loaded-libs* conj '~name)) nil))))) - -(defmacro refer-clojure - "Same as (refer 'clojure.core )" - {:added "1.0"} - [& filters] - `(clojure.core/refer '~'clojure.core ~@filters)) - -(defmacro defonce - "defs name to have the root value of the expr iff the named var has no root value, - else expr is unevaluated" - {:added "1.0"} - [name expr] - `(let [v# (def ~name)] - (when-not (.hasRoot v#) - (def ~name ~expr)))) - -;;;;;;;;;;; require/use/load, contributed by Stephen C. Gilardi ;;;;;;;;;;;;;;;;;; - -(defonce ^:dynamic - ^{:private true - :doc "A ref to a sorted set of symbols representing loaded libs"} - *loaded-libs* (ref (sorted-set))) - -(defonce ^:dynamic - ^{:private true - :doc "A stacj of paths currently being loaded by this thread"} - *pending-paths* ()) - -(defonce ^:dynamic - ^{:private true :doc - "True while a verbose load is pending"} - *loading-verbosely* false) - -(defn- throw-if - "Throws a CompileException with a message if pred is true" - [pred fmt & args] - (when pred - (let [ ^String message (apply format fmt args) - exception (Exception. message) - raw-trace (.GetFrames (System.Diagnostics.StackTrace.)) ;;; (.getStackTrace exception) unthrown exception has null stacktrace -- use diagnostics to get the stacktrace - boring? #(not= (.Name (.GetMethod ^System.Diagnostics.StackFrame %)) "doInvoke") ;;; ^StackTraceElement - trace (into-array System.Diagnostics.StackFrame (drop 2 (drop-while boring? raw-trace)))] ;;; .getMethodName => .Name .GetMethod StackTraceElement - (.Add (.Data exception) "StackTrace" trace) ;;; (.setStackTrace exception trace) - can't set stack trace, so store the filtered trace on the Data element' - (throw (clojure.lang.Compiler+CompilerException. ;;; Compiler$CompilerException - *file* - (.deref clojure.lang.Compiler/LineVar) ;;; LINE - (.deref clojure.lang.Compiler/ColumnVar) ;;; COLUMN - exception))))) - -(defn- libspec? - "Returns true if x is a libspec" - [x] - (or (symbol? x) - (and (vector? x) - (or - (nil? (second x)) - (keyword? (second x)))))) - -(defn- prependss - "Prepends a symbol or a seq to coll" - [x coll] - (if (symbol? x) - (cons x coll) - (concat x coll))) - -(defn- root-resource - "Returns the root directory path for a lib" - {:tag String} - [lib] - (str \/ - (.. (name lib) - (Replace \- \_) ;;; replace - (Replace \. \/)))) ;;; replace - -(defn- root-directory - "Returns the root resource path for a lib" - [lib] - (let [d (root-resource lib)] - (subs d 0 (.LastIndexOf d "/")))) ;;; lastIndexOf - -(def ^:declared ^:redef load) - -(defn- load-one - "Loads a lib given its name. If need-ns, ensures that the associated - namespace exists after loading. If require, records the load so any - duplicate loads can be skipped." - [lib need-ns require] - (load (root-resource lib)) - (throw-if (and need-ns (not (find-ns lib))) - "namespace '%s' not found after loading '%s'" - lib (root-resource lib)) - (when require - (dosync - (commute *loaded-libs* conj lib)))) - -(defn- load-all - "Loads a lib given its name and forces a load of any libs it directly or - indirectly loads. If need-ns, ensures that the associated namespace - exists after loading. If require, records the load so any duplicate loads - can be skipped." - [lib need-ns require] - (dosync - (commute *loaded-libs* #(reduce1 conj %1 %2) - (binding [*loaded-libs* (ref (sorted-set))] - (load-one lib need-ns require) - @*loaded-libs*)))) - -(defn- load-lib - "Loads a lib with options" - [prefix lib & options] - (throw-if (and prefix (pos? (.IndexOf (name lib) \.))) ;;; indexOf & (int \.) - "Found lib name '%s' containing period with prefix '%s'. lib names inside prefix lists must not contain periods" - (name lib) prefix) - (let [lib (if prefix (symbol (str prefix \. lib)) lib) - opts (apply hash-map options) - {:keys [as reload reload-all require use verbose as-alias]} opts - loaded (contains? @*loaded-libs* lib) - need-ns (or as use) - load (cond reload-all load-all - reload load-one - (not loaded) (cond need-ns load-one - as-alias (fn [lib _need _require] (create-ns lib)) - :else load-one)) - - filter-opts (select-keys opts '(:exclude :only :rename :refer)) - undefined-on-entry (not (find-ns lib))] - (binding [*loading-verbosely* (or *loading-verbosely* verbose)] - (if load - (try - (load lib need-ns require) - (catch Exception e - (when undefined-on-entry - (remove-ns lib)) - (throw e))) - (throw-if (and need-ns (not (find-ns lib))) - "namespace '%s' not found" lib)) - (when (and need-ns *loading-verbosely*) - (printf "(clojure.core/in-ns '%s)\n" (ns-name *ns*))) - (when as - (when *loading-verbosely* - (printf "(clojure.core/alias '%s '%s)\n" as lib)) - (alias as lib)) - (when as-alias - (when *loading-verbosely* - (printf "(clojure.core/alias '%s '%s)\n" as-alias lib)) - (alias as-alias lib)) - (when (or use (:refer filter-opts)) - (when *loading-verbosely* - (printf "(clojure.core/refer '%s" lib) - (doseq [opt filter-opts] - (printf " %s '%s" (key opt) (print-str (val opt)))) - (printf ")\n")) - (apply refer lib (mapcat seq filter-opts)))))) - -(defn- load-libs - "Loads libs, interpreting libspecs, prefix lists, and flags for - forwarding to load-lib" - [& args] - (let [flags (filter keyword? args) - opts (interleave flags (repeat true)) - args (filter (complement keyword?) args)] - ; check for unsupported options - (let [supported #{:as :reload :reload-all :require :use :verbose :refer :as-alias} - unsupported (seq (remove supported flags))] - (throw-if unsupported - (apply str "Unsupported option(s) supplied: " - (interpose \, unsupported)))) - ; check a load target was specified - (throw-if (not (seq args)) "Nothing specified to load") - (doseq [arg args] - (if (libspec? arg) - (apply load-lib nil (prependss arg opts)) - (let [[prefix & args] arg] - (throw-if (nil? prefix) "prefix cannot be nil") - (doseq [arg args] - (apply load-lib prefix (prependss arg opts)))))))) - -(defn- check-cyclic-dependency - "Detects and rejects non-trivial cyclic load dependencies. The - exception message shows the dependency chain with the cycle - highlighted. Ignores the trivial case of a file attempting to load - itself because that can occur when a gen-class'd class loads its - implementation." - [path] - (when (some #{path} (rest *pending-paths*)) - (let [pending (map #(if (= % path) (str "[ " % " ]") %) - (cons path *pending-paths*)) - chain (apply str (interpose "->" pending))] - (throw-if true "Cyclic load dependency: %s" chain)))) - -;; Public - -(defn require - "Loads libs, skipping any that are already loaded. Each argument is - either a libspec that identifies a lib, a prefix list that identifies - multiple libs whose names share a common prefix, or a flag that modifies - how all the identified libs are loaded. Use :require in the ns macro - in preference to calling this directly. - - Libs - - A 'lib' is a named set of resources in classpath whose contents define a - library of Clojure code. Lib names are symbols and each lib is associated - with a Clojure namespace and a Java package that share its name. A lib's - name also locates its root directory within classpath using Java's - package name to classpath-relative path mapping. All resources in a lib - should be contained in the directory structure under its root directory. - All definitions a lib makes should be in its associated namespace. - - 'require loads a lib by loading its root resource. The root resource path - is derived from the lib name in the following manner: - Consider a lib named by the symbol 'x.y.z; it has the root directory - /x/y/, and its root resource is /x/y/z.clj, or - /x/y/z.cljc if /x/y/z.clj does not exist. The - root resource should contain code to create the lib's - namespace (usually by using the ns macro) and load any additional - lib resources. - - Libspecs - - A libspec is a lib name or a vector containing a lib name followed by - options expressed as sequential keywords and arguments. - - Recognized options: - :as takes a symbol as its argument and makes that symbol an alias to the - lib's namespace in the current namespace. - :as-alias takes a symbol as its argument and aliases like :as, however - the lib will not be loaded. If the lib has not been loaded, a new - empty namespace will be created (as with create-ns). - :refer takes a list of symbols to refer from the namespace or the :all - keyword to bring in all public vars. - - Prefix Lists - - It's common for Clojure code to depend on several libs whose names have - the same prefix. When specifying libs, prefix lists can be used to reduce - repetition. A prefix list contains the shared prefix followed by libspecs - with the shared prefix removed from the lib names. After removing the - prefix, the names that remain must not contain any periods. - - Flags - - A flag is a keyword. - Recognized flags: :reload, :reload-all, :verbose - :reload forces loading of all the identified libs even if they are - already loaded (has no effect on libspecs using :as-alias) - :reload-all implies :reload and also forces loading of all libs that the - identified libs directly or indirectly load via require or use - (has no effect on libspecs using :as-alias) - :verbose triggers printing information about each load, alias, and refer - - Example: - - The following would load the libraries clojure.zip and clojure.set - abbreviated as 's'. - - (require '(clojure zip [set :as s]))" - {:added "1.0"} - - [& args] - (apply load-libs :require args)) - -(defn- serialized-require - "Like 'require', but serializes loading. - Interim function preferred over 'require' for known asynchronous loads. - Future changes may make these equivalent." - {:added "1.10"} - [& args] - (locking clojure.lang.RT/REQUIRE_LOCK - (apply require args))) - -(defn requiring-resolve - "Resolves namespace-qualified sym per 'resolve'. If initial resolve -fails, attempts to require sym's namespace and retries." - {:added "1.10"} - [sym] - (if (qualified-symbol? sym) - (or (resolve sym) - (do (-> sym namespace symbol serialized-require) - (resolve sym))) - (throw (ArgumentException. (str "Not a qualified symbol: " sym))))) ;;; IllegalArgumentException. - -(defn use - "Like 'require, but also refers to each lib's namespace using - clojure.core/refer. Use :use in the ns macro in preference to calling - this directly. - - 'use accepts additional options in libspecs: :exclude, :only, :rename. - The arguments and semantics for :exclude, :only, and :rename are the same - as those documented for clojure.core/refer." - {:added "1.0"} - [& args] (apply load-libs :require :use args)) - -(defn loaded-libs - "Returns a sorted set of symbols naming the currently loaded libs" - {: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." - {:redef true - :added "1.0"} + {:redef true + :added "1.0"} [& paths] (doseq [^String path paths] (let [^String path (if (.StartsWith path "/") ;;; startsWith @@ -6161,185 +6161,185 @@ fails, attempts to require sym's namespace and retries." (when *loading-verbosely* (printf "(clojure.core/load \"%s\")\n" path) (flush)) - (check-cyclic-dependency path) + (check-cyclic-dependency path) (when-not (= path (first *pending-paths*)) (binding [*pending-paths* (conj *pending-paths* path)] - (clojure.lang.RT/load (.Substring path 1))))))) ;;; .substring - + (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." - {:added "1.0"} + {:added "1.0"} [lib] (binding [*compile-files* true] (load-one lib true true)) - lib) - -;;;;;;;;;;;;; nested associative ops ;;;;;;;;;;; - -(defn get-in - "Returns the value in a nested associative structure, - where ks is a sequence of keys. Returns nil if the key - is not present, or the not-found value if supplied." - { :added "1.2" - :static true} - ([m ks] - (reduce1 get m ks)) - ([m ks not-found] - (loop [sentinel (Object.) - m m - ks (seq ks)] - (if ks - (let [m (get m (first ks) sentinel)] - (if (identical? sentinel m) - not-found - (recur sentinel m (next ks)))) - m)))) - -(defn assoc-in - "Associates a value in a nested associative structure, where ks is a - sequence of keys and v is the new value and returns a new nested structure. - If any levels do not exist, hash-maps will be created." - {:added "1.0" - :static true} - [m [k & ks] v] - (if ks - (assoc m k (assoc-in (get m k) ks v)) - (assoc m k v))) - -(defn update-in - "'Updates' a value in a nested associative structure, where ks is a - sequence of keys and f is a function that will take the old value - and any supplied args and return the new value, and returns a new - nested structure. If any levels do not exist, hash-maps will be - created." - {:added "1.0" - :static true} - ([m ks f & args] - (let [up (fn up [m ks f args] - (let [[k & ks] ks] - (if ks - (assoc m k (up (get m k) ks f args)) - (assoc m k (apply f (get m k) args)))))] - (up m ks f args)))) - -(defn update - "'Updates' a value in an associative structure, where k is a - key and f is a function that will take the old value - and any supplied args and return the new value, and returns a new - structure. If the key does not exist, nil is passed as the old value." - {:added "1.7" - :static true} - ([m k f] - (assoc m k (f (get m k)))) - ([m k f x] - (assoc m k (f (get m k) x))) - ([m k f x y] - (assoc m k (f (get m k) x y))) - ([m k f x y z] - (assoc m k (f (get m k) x y z))) - ([m k f x y z & more] - (assoc m k (apply f (get m k) x y z more)))) - -(defn coll? - "Returns true if x implements IPersistentCollection" - {:added "1.0" - :static true} - [x] (instance? clojure.lang.IPersistentCollection x)) - -(defn list? - "Returns true if x implements IPersistentList" - {:added "1.0" - :static true} - [x] (instance? clojure.lang.IPersistentList x)) - -(defn seqable? - "Return true if the seq function is supported for x" - {:added "1.9"} + lib) + +;;;;;;;;;;;;; nested associative ops ;;;;;;;;;;; + +(defn get-in + "Returns the value in a nested associative structure, + where ks is a sequence of keys. Returns nil if the key + is not present, or the not-found value if supplied." + { :added "1.2" + :static true} + ([m ks] + (reduce1 get m ks)) + ([m ks not-found] + (loop [sentinel (Object.) + m m + ks (seq ks)] + (if ks + (let [m (get m (first ks) sentinel)] + (if (identical? sentinel m) + not-found + (recur sentinel m (next ks)))) + m)))) + +(defn assoc-in + "Associates a value in a nested associative structure, where ks is a + sequence of keys and v is the new value and returns a new nested structure. + If any levels do not exist, hash-maps will be created." + {:added "1.0" + :static true} + [m [k & ks] v] + (if ks + (assoc m k (assoc-in (get m k) ks v)) + (assoc m k v))) + +(defn update-in + "'Updates' a value in a nested associative structure, where ks is a + sequence of keys and f is a function that will take the old value + and any supplied args and return the new value, and returns a new + nested structure. If any levels do not exist, hash-maps will be + created." + {:added "1.0" + :static true} + ([m ks f & args] + (let [up (fn up [m ks f args] + (let [[k & ks] ks] + (if ks + (assoc m k (up (get m k) ks f args)) + (assoc m k (apply f (get m k) args)))))] + (up m ks f args)))) + +(defn update + "'Updates' a value in an associative structure, where k is a + key and f is a function that will take the old value + and any supplied args and return the new value, and returns a new + structure. If the key does not exist, nil is passed as the old value." + {:added "1.7" + :static true} + ([m k f] + (assoc m k (f (get m k)))) + ([m k f x] + (assoc m k (f (get m k) x))) + ([m k f x y] + (assoc m k (f (get m k) x y))) + ([m k f x y z] + (assoc m k (f (get m k) x y z))) + ([m k f x y z & more] + (assoc m k (apply f (get m k) x y z more)))) + +(defn coll? + "Returns true if x implements IPersistentCollection" + {:added "1.0" + :static true} + [x] (instance? clojure.lang.IPersistentCollection x)) + +(defn list? + "Returns true if x implements IPersistentList" + {:added "1.0" + :static true} + [x] (instance? clojure.lang.IPersistentList x)) + +(defn seqable? + "Return true if the seq function is supported for x" + {:added "1.9"} [x] (clojure.lang.RT/canSeq x)) (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)) - + {: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." - {:added "1.0" - :static true} - [x] (instance? clojure.lang.Fn x)) - - -(defn associative? - "Returns true if coll implements Associative" - {:added "1.0" - :static true} - [coll] (instance? clojure.lang.Associative coll)) - -(defn sequential? - "Returns true if coll implements Sequential" - {:added "1.0" - :static true} - [coll] (instance? clojure.lang.Sequential coll)) - -(defn sorted? - "Returns true if coll implements Sorted" - {:added "1.0" - :static true} - [coll] (instance? clojure.lang.Sorted coll)) - -(defn counted? - "Returns true if coll implements count in constant time" - {:added "1.0" - :static true} - [coll] (instance? clojure.lang.Counted coll)) - -(defn empty? - "Returns true if coll has no items. To check the emptiness of a seq, - please use the idiom (seq x) rather than (not (empty? x))" - {:added "1.0" - :static true} - [coll] - (if (counted? coll) - (zero? (count coll)) - (not (seq coll)))) - - (defn reversible? - "Returns true if coll implements Reversible" - {:added "1.0" - :static true} - [coll] (instance? clojure.lang.Reversible coll)) - -(defn indexed? - "Return true if coll implements Indexed, indicating efficient lookup by index" - {:added "1.9"} - [coll] (instance? clojure.lang.Indexed coll)) - -(def ^:dynamic - ^{:doc "bound in a repl thread to the most recent value printed" - :added "1.0"} - *1) - -(def ^:dynamic - ^{:doc "bound in a repl thread to the second most recent value printed" - :added "1.0"} - *2) - -(def ^:dynamic - ^{:doc "bound in a repl thread to the third most recent value printed" - :added "1.0"} - *3) - -(def ^:dynamic - ^{:doc "bound in a repl thread to the most recent exception caught by the repl" - :added "1.0"} - *e) - + {:added "1.0" + :static true} + [x] (instance? clojure.lang.Fn x)) + + +(defn associative? + "Returns true if coll implements Associative" + {:added "1.0" + :static true} + [coll] (instance? clojure.lang.Associative coll)) + +(defn sequential? + "Returns true if coll implements Sequential" + {:added "1.0" + :static true} + [coll] (instance? clojure.lang.Sequential coll)) + +(defn sorted? + "Returns true if coll implements Sorted" + {:added "1.0" + :static true} + [coll] (instance? clojure.lang.Sorted coll)) + +(defn counted? + "Returns true if coll implements count in constant time" + {:added "1.0" + :static true} + [coll] (instance? clojure.lang.Counted coll)) + +(defn empty? + "Returns true if coll has no items. To check the emptiness of a seq, + please use the idiom (seq x) rather than (not (empty? x))" + {:added "1.0" + :static true} + [coll] + (if (counted? coll) + (zero? (count coll)) + (not (seq coll)))) + + (defn reversible? + "Returns true if coll implements Reversible" + {:added "1.0" + :static true} + [coll] (instance? clojure.lang.Reversible coll)) + +(defn indexed? + "Return true if coll implements Indexed, indicating efficient lookup by index" + {:added "1.9"} + [coll] (instance? clojure.lang.Indexed coll)) + +(def ^:dynamic + ^{:doc "bound in a repl thread to the most recent value printed" + :added "1.0"} + *1) + +(def ^:dynamic + ^{:doc "bound in a repl thread to the second most recent value printed" + :added "1.0"} + *2) + +(def ^:dynamic + ^{:doc "bound in a repl thread to the third most recent value printed" + :added "1.0"} + *3) + +(def ^:dynamic + ^{:doc "bound in a repl thread to the most recent exception caught by the repl" + :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 @@ -6348,8 +6348,8 @@ fails, attempts to require sym's namespace and retries." 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} + {:added "1.0" + :static true} ([f] (let [ret (f)] (if (fn? ret) @@ -6363,8 +6363,8 @@ fails, attempts to require sym's namespace and retries." 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} + {: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))) @@ -6377,7 +6377,7 @@ fails, attempts to require sym's namespace and retries." (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"} + {:added "1.0"} [test & body] `(loop [] (when ~test @@ -6389,8 +6389,8 @@ fails, attempts to require sym's namespace and retries." 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} + {:added "1.0" + :static true} [f] (let [mem (atom {})] (fn [& args] @@ -6419,7 +6419,7 @@ fails, attempts to require sym's namespace and retries." 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"} + {:added "1.0"} [pred expr & clauses] (let [gpred (gensym "pred__") @@ -6429,7 +6429,7 @@ fails, attempts to require sym's namespace and retries." (split-at (if (= :>> (second args)) 3 2) args) n (count clause)] (cond - (= 0 n) `(throw (ArgumentException. (str "No matching clause: " ~expr))) ;;;IllegalArgumentException + (= 0 n) `(throw (ArgumentException. (str "No matching clause: " ~expr))) ;;;IllegalArgumentException (= 1 n) a (= 2 n) `(if (~pred ~a ~expr) ~b @@ -6439,1721 +6439,1721 @@ fails, attempts to require sym's namespace and retries." ~(emit pred expr more)))))] `(let [~gpred ~pred ~gexpr ~expr] - ~(emit gpred gexpr clauses)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; var documentation ;;;;;;;;;;;;;;;;;;;;;;;;;; - -(alter-meta! #'*agent* assoc :added "1.0") -(alter-meta! #'in-ns assoc :added "1.0") -(alter-meta! #'load-file assoc :added "1.0") - -(defmacro add-doc-and-meta {:private true} [name docstring meta] - `(alter-meta! (var ~name) merge (assoc ~meta :doc ~docstring))) - -(add-doc-and-meta *file* - "The path of the file being evaluated, as a String. - - When there is no file, e.g. in the REPL, the value is not defined." - {:added "1.0"}) - -(add-doc-and-meta *command-line-args* - "A sequence of the supplied command line arguments, or nil if - none were supplied" - {:added "1.0"}) - -(add-doc-and-meta *warn-on-reflection* - "When set to true, the compiler will emit warnings when reflection is - needed to resolve Java method calls or field accesses. - - Defaults to false." - {:added "1.0"}) - -(add-doc-and-meta *compile-path* - "Specifies the directory where 'compile' will write out .class - files. This directory must be in the classpath for 'compile' to - work. - - Defaults to \"classes\"" - {:added "1.0"}) - -(add-doc-and-meta *compile-files* - "Set to true when compiling files, false otherwise." - {:added "1.0"}) - -(add-doc-and-meta *unchecked-math* - "While bound to true, compilations of +, -, *, inc, dec and the - coercions will be done without overflow checks. While bound - to :warn-on-boxed, same behavior as true, and a warning is emitted - when compilation uses boxed math. Default: false." - {:added "1.3"}) - -(add-doc-and-meta *compiler-options* - "A map of keys to options. - Note, when binding dynamically make sure to merge with previous value. - Supported options: - :elide-meta - a collection of metadata keys to elide during compilation. - :disable-locals-clearing - set to true to disable clearing, useful for using a debugger - :direct-linking - set to true to use direct static invocation of functions, rather than vars - Note that call sites compiled with direct linking will not be affected by var redefinition. - Use ^:redef (or ^:dynamic) on a var to prevent direct linking and allow redefinition. - See https://clojure.org/reference/compilation for more information." - {:added "1.4"}) - -(add-doc-and-meta *ns* - "A clojure.lang.Namespace object representing the current namespace." - {:added "1.0"}) - -(add-doc-and-meta *in* - "A java.io.Reader object representing standard input for read operations. - - Defaults to System/in, wrapped in a LineNumberingPushbackReader" - {:added "1.0"}) - -(add-doc-and-meta *out* - "A java.io.Writer object representing standard output for print operations. - - Defaults to System/out, wrapped in an OutputStreamWriter" - {:added "1.0"}) - -(add-doc-and-meta *err* - "A java.io.Writer object representing standard error for print operations. - - Defaults to System/err, wrapped in a PrintWriter" - {:added "1.0"}) - -(add-doc-and-meta *flush-on-newline* - "When set to true, output will be flushed whenever a newline is printed. - - Defaults to true." - {:added "1.0"}) - -(add-doc-and-meta *print-meta* - "If set to logical true, when printing an object, its metadata will also - be printed in a form that can be read back by the reader. - - Defaults to false." - {:added "1.0"}) - -(add-doc-and-meta *print-dup* - "When set to logical true, objects will be printed in a way that preserves - their type when read in later. - - Defaults to false." - {:added "1.0"}) - -(add-doc-and-meta *print-readably* - "When set to logical false, strings and characters will be printed with - non-alphanumeric characters converted to the appropriate escape sequences. - - Defaults to true" - {:added "1.0"}) - -(add-doc-and-meta *read-eval* - "Defaults to true (or value specified by system property, see below) - ***This setting implies that the full power of the reader is in play, - including syntax that can cause code to execute. It should never be - used with untrusted sources. See also: clojure.end/read.*** - - When set to logical false in the thread-local binding, - the eval reader (#=) and record/type literal syntax are disabled in read/load. - Example (will fail): (binding [*read-eval* false] (read-string \"#=(* 2 21)\")) - - The default binding can be controlled by the system property - 'clojure.read.eval' System properties can be set on the command line - like this: - - java -Dclojure.read.eval=false ... - - The system property can also be set to 'unknown' via - -Dclojure.read.eval=unknown, in which case the default binding - is :unknown and all reads will fail in contexts where *read-eval* - has not been explicitly bound to either true or false. This setting - can be a useful diagnostic tool to ensure that all of your reads - occur in considered contexts. You can also accomplish this in a - particular scope by binding *read-eval* to :unknown - " - {:added "1.0"}) - -(defn future? - "Returns true if x is a future" - {:added "1.1" - :static true} - [x] (instance? clojure.lang.Future x)) ;;; java.util.concurrent.Future - -(defn future-done? - "Returns true if future f is done" - {:added "1.1" - :static true} - [^clojure.lang.Future f] (.isDone f)) ;;; ^java.util.concurrent.Future - - -(defmacro letfn - "fnspec ==> (fname [params*] exprs) or (fname ([params*] exprs)+) - - Takes a vector of function specs and a body, and generates a set of - bindings of functions to their names. All of the names are available - in all of the definitions of the functions, as well as the body." - {:added "1.0", :forms '[(letfn [fnspecs*] exprs*)], - :special-form true, :url nil} - [fnspecs & body] - `(letfn* ~(vec (interleave (map first fnspecs) - (map #(cons `fn %) fnspecs))) - ~@body)) - -(defn fnil - "Takes a function f, and returns a function that calls f, replacing - a nil first argument to f with the supplied value x. Higher arity - versions can replace arguments in the second and third - positions (y, z). Note that the function f can take any number of - arguments, not just the one(s) being nil-patched." - {:added "1.2" - :static true} - ([f x] - (fn - ([a] (f (if (nil? a) x a))) - ([a b] (f (if (nil? a) x a) b)) - ([a b c] (f (if (nil? a) x a) b c)) - ([a b c & ds] (apply f (if (nil? a) x a) b c ds)))) - ([f x y] - (fn - ([a b] (f (if (nil? a) x a) (if (nil? b) y b))) - ([a b c] (f (if (nil? a) x a) (if (nil? b) y b) c)) - ([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) c ds)))) - ([f x y z] - (fn - ([a b] (f (if (nil? a) x a) (if (nil? b) y b))) - ([a b c] (f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c))) - ([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c) ds))))) - -(defn zipmap - "Returns a map with the keys mapped to the corresponding vals." - {:added "1.0" - :static true} - [keys vals] - (loop [map (transient {}) - ks (seq keys) - vs (seq vals)] - (if (and ks vs) - (recur (assoc! map (first ks) (first vs)) - (next ks) - (next vs)) - (persistent! map)))) - -;;;;;;; case ;;;;;;;;;;;;; -(defn- shift-mask [shift mask x] - (-> x (bit-shift-right shift) (bit-and mask))) - -(def ^:private max-mask-bits 13) -(def ^:private max-switch-table-size (bit-shift-left 1 max-mask-bits)) - -(defn- maybe-min-hash - "takes a collection of hashes and returns [shift mask] or nil if none found" - [hashes] - (first - (filter (fn [[s m]] - (apply distinct? (map #(shift-mask s m %) hashes))) - (for [mask (map #(dec (bit-shift-left 1 %)) (range 1 (inc max-mask-bits))) - shift (range 0 31)] - [shift mask])))) - -(defn- case-map - "Transforms a sequence of test constants and a corresponding sequence of then - expressions into a sorted map to be consumed by case*. The form of the map - entries are {(case-f test) [(test-f test) then]}." - [case-f test-f tests thens] - (into1 (sorted-map) - (zipmap (map case-f tests) - (map vector - (map test-f tests) - thens)))) - -(defn- fits-table? - "Returns true if the collection of ints can fit within the - max-table-switch-size, false otherwise." - [ints] - (< (- (apply max (seq ints)) (apply min (seq ints))) max-switch-table-size)) - -(defn- prep-ints - "Takes a sequence of int-sized test constants and a corresponding sequence of - then expressions. Returns a tuple of [shift mask case-map switch-type] where - case-map is a map of int case values to [test then] tuples, and switch-type - is either :sparse or :compact." - [tests thens] - (if (fits-table? tests) - ; compact case ints, no shift-mask - [0 0 (case-map int int tests thens) :compact] - (let [[shift mask] (or (maybe-min-hash (map int tests)) [0 0])] - (if (zero? mask) - ; sparse case ints, no shift-mask - [0 0 (case-map int int tests thens) :sparse] - ; compact case ints, with shift-mask - [shift mask (case-map #(shift-mask shift mask (int %)) int tests thens) :compact])))) - -(defn- merge-hash-collisions - "Takes a case expression, default expression, and a sequence of test constants - and a corresponding sequence of then expressions. Returns a tuple of - [tests thens skip-check-set] where no tests have the same hash. Each set of - input test constants with the same hash is replaced with a single test - constant (the case int), and their respective thens are combined into: - (condp = expr - test-1 then-1 - ... - test-n then-n - default). - The skip-check is a set of case ints for which post-switch equivalence - checking must not be done (the cases holding the above condp thens)." - [expr-sym default tests thens] - (let [buckets (loop [m {} ks tests vs thens] - (if (and ks vs) - (recur - (update m (clojure.lang.Util/hash (first ks)) (fnil conj []) [(first ks) (first vs)]) - (next ks) (next vs)) - m)) - assoc-multi (fn [m h bucket] - (let [testexprs (mapcat (fn [kv] [(list 'quote (first kv)) (second kv)]) bucket) - expr `(condp = ~expr-sym ~@testexprs ~default)] - (assoc m h expr))) - hmap (reduce1 - (fn [m [h bucket]] - (if (== 1 (count bucket)) - (assoc m (ffirst bucket) (second (first bucket))) - (assoc-multi m h bucket))) - {} buckets) - skip-check (->> buckets - (filter #(< 1 (count (second %)))) - (map first) - (into1 #{}))] - [(keys hmap) (vals hmap) skip-check])) - -(defn- prep-hashes - "Takes a sequence of test constants and a corresponding sequence of then - expressions. Returns a tuple of [shift mask case-map switch-type skip-check] - where case-map is a map of int case values to [test then] tuples, switch-type - is either :sparse or :compact, and skip-check is a set of case ints for which - post-switch equivalence checking must not be done (occurs with hash - collisions)." - [expr-sym default tests thens] - (let [hashcode #(clojure.lang.Util/hash %) - hashes (into1 #{} (map hashcode tests))] - (if (== (count tests) (count hashes)) - (if (fits-table? hashes) - ; compact case ints, no shift-mask - [0 0 (case-map hashcode identity tests thens) :compact] - (let [[shift mask] (or (maybe-min-hash hashes) [0 0])] - (if (zero? mask) - ; sparse case ints, no shift-mask - [0 0 (case-map hashcode identity tests thens) :sparse] - ; compact case ints, with shift-mask - [shift mask (case-map #(shift-mask shift mask (hashcode %)) identity tests thens) :compact]))) - ; resolve hash collisions and try again - (let [[tests thens skip-check] (merge-hash-collisions expr-sym default tests thens) - [shift mask case-map switch-type] (prep-hashes expr-sym default tests thens) - skip-check (if (zero? mask) - skip-check - (into1 #{} (map #(shift-mask shift mask %) skip-check)))] - [shift mask case-map switch-type skip-check])))) - - -(defmacro case - "Takes an expression, and a set of clauses. - - Each clause can take the form of either: - - test-constant result-expr - - (test-constant1 ... test-constantN) result-expr - - The test-constants are not evaluated. They must be compile-time - literals, and need not be quoted. If the expression is equal to a - test-constant, the corresponding result-expr is returned. 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. - - Unlike cond and condp, case does a constant-time dispatch, the - clauses are not considered sequentially. All manner of constant - expressions are acceptable in case, including numbers, strings, - symbols, keywords, and (Clojure) composites thereof. Note that since - lists are used to group multiple constants that map to the same - expression, a vector can be used to match a list if needed. The - test-constants need not be all of the same type." - {:added "1.2"} - - [e & clauses] - (let [ge (with-meta (gensym) {:tag Object}) - default (if (odd? (count clauses)) - (last clauses) - `(throw (ArgumentException. (str "No matching clause: " ~ge))))] ;;; IllegalArgumentException - (if (> 2 (count clauses)) - `(let [~ge ~e] ~default) - (let [pairs (partition 2 clauses) - assoc-test (fn assoc-test [m test expr] - (if (contains? m test) - (throw (ArgumentException. (str "Duplicate case test constant: " test))) ;;; IllegalArgumentException - (assoc m test expr))) - pairs (reduce1 - (fn [m [test expr]] - (if (seq? test) - (reduce1 #(assoc-test %1 %2 expr) m test) - (assoc-test m test expr))) - {} pairs) - tests (keys pairs) - thens (vals pairs) - mode (cond - (every? #(and (integer? %) (not (char? %)) (<= Int32/MinValue % Int32/MaxValue)) tests) ;;; Integer/MIN_VALUE Integer/MAX_VALUE - (not (char? %)) added to match char-handling semantics of JVM - :ints - (every? keyword? tests) - :identity - :else :hashes)] - (condp = mode - :ints - (let [[shift mask imap switch-type] (prep-ints tests thens)] - `(let [~ge ~e] (case* ~ge ~shift ~mask ~default ~imap ~switch-type :int))) - :hashes - (let [[shift mask imap switch-type skip-check] (prep-hashes ge default tests thens)] - `(let [~ge ~e] (case* ~ge ~shift ~mask ~default ~imap ~switch-type :hash-equiv ~skip-check))) - :identity - (let [[shift mask imap switch-type skip-check] (prep-hashes ge default tests thens)] - `(let [~ge ~e] (case* ~ge ~shift ~mask ~default ~imap ~switch-type :hash-identity ~skip-check)))))))) - - -;; redefine reduce with internal-reduce - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; helper files ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(alter-meta! (find-ns 'clojure.core) assoc :doc "Fundamental library of the Clojure language") (load "core_clr") ;;; Added -(load "core_proxy") -(load "core_print") -(load "genclass") -(load "core_deftype") -(load "core/protocols") -(load "gvec") - -(defmacro ^:private when-class [class-name & body] - `(try - (clojure.lang.RT/classForNameE ^String ~class-name) ;;; Class/forName -- not sure what else to replace this with - ~@body - (catch clojure.lang.TypeNotFoundException _#))) ;;; ClassNotFoundException - -(when-class "System.DateTime" ;;; "java.sql.Timestamp" - (load "instant")) - -(defprotocol Inst - (inst-ms* [inst])) - -(extend-protocol Inst - DateTime ;;; java.util.Date - (inst-ms* [inst] (long (.TotalMilliseconds (.Subtract ^DateTime inst (DateTime. 1970 1 1)))))) ;;; (.getTime ^java.util.Date inst) - -(defn inst-ms - "Return the number of milliseconds since January 1, 1970, 00:00:00 GMT" - {:added "1.9"} - [inst] - (inst-ms* inst)) - -(defn inst? - "Return true if x satisfies Inst" - {:added "1.9"} - [x] - (satisfies? Inst x)) - -;;;(extend-protocol clojure.core/Inst -;;; java.time.Instant -;;; (inst-ms* [inst] (.toEpochMilli ^java.time.Instant inst))) - -(load "uuid") - -(defn uuid? - "Return true if x is a java.util.UUID" - {:added "1.9"} - [x] (instance? System.Guid x)) ;;; java.util.UUID - -(defn random-uuid - {:doc "Returns a pseudo-randomly generated java.util.UUID instance (i.e. type 4). - See: https://docs.oracle.com/javase/8/docs/api/java/util/UUID.html#randomUUID--" - :added "1.11"} - ^System.Guid [] (System.Guid/NewGuid)) ;;; ^java.util.UUID java.util.UUID/randomUUID - -(defn reduce - "f should be a function of 2 arguments. If val is not supplied, - returns the result of applying f to the first 2 items in coll, then - applying f to that result and the 3rd item, etc. If coll contains no - items, f must accept no arguments as well, and reduce returns the - result of calling f with no arguments. If coll has only 1 item, it - is returned and f is not called. If val is supplied, returns the - result of applying f to val and the first item in coll, then - applying f to that result and the 2nd item, etc. If coll contains no - items, returns val and f is not called." - {:added "1.0"} - ([f coll] - (if (instance? clojure.lang.IReduce coll) - (.reduce ^clojure.lang.IReduce coll f) - (clojure.core.protocols/coll-reduce coll f))) - ([f val coll] - (if (instance? clojure.lang.IReduceInit coll) - (.reduce ^clojure.lang.IReduceInit coll f val) - (clojure.core.protocols/coll-reduce coll f val)))) - -(extend-protocol clojure.core.protocols/IKVReduce - nil - (kv-reduce - [_ f init] - init) - - ;;slow path default - System.Object - (kv-reduce - [amap f init] - (reduce (fn [ret ^clojure.lang.IMapEntry me] ;;; ^java.util.Map$Entry -- THe problem here is that we don't have an equivalent to java.util.Map$Entry. We will settle on IMapEntry - (f ret - (.key me) ;;; .getKey - (.val me))) ;;; .getValue - init - amap)) - - -clojure.lang.IKVReduce - (kv-reduce - [amap f init] - (.kvreduce amap f init))) - -(defn reduce-kv - "Reduces an associative collection. f should be a function of 3 - arguments. Returns the result of applying f to init, the first key - and the first value in coll, then applying f to that result and the - 2nd key and value, etc. If coll contains no entries, returns init - and f is not called. Note that reduce-kv is supported on vectors, - where the keys will be the ordinals." - {:added "1.4"} - ([f init coll] - (clojure.core.protocols/kv-reduce coll f init))) - -(defn completing - "Takes a reducing function f of 2 args and returns a fn suitable for - transduce by adding an arity-1 signature that calls cf (default - - identity) on the result argument." - {:added "1.7"} - ([f] (completing f identity)) - ([f cf] - (fn - ([] (f)) - ([x] (cf x)) - ([x y] (f x y))))) - -(defn transduce - "reduce with a transformation of f (xf). If init is not - supplied, (f) will be called to produce it. f should be a reducing - step function that accepts both 1 and 2 arguments, if it accepts - only 2 you can add the arity-1 with 'completing'. Returns the result - of applying (the transformed) xf to init and the first item in coll, - then applying xf to that result and the 2nd item, etc. If coll - contains no items, returns init and f is not called. Note that - certain transforms may inject or skip items." {:added "1.7"} - ([xform f coll] (transduce xform f (f) coll)) - ([xform f init coll] - (let [f (xform f) - ret (if (instance? clojure.lang.IReduceInit coll) - (.reduce ^clojure.lang.IReduceInit coll f init) - (clojure.core.protocols/coll-reduce coll f init))] - (f ret)))) - -(defn into - "Returns a new coll consisting of to-coll with all of the items of - from-coll conjoined. A transducer may be supplied." - {:added "1.0" - :static true} - ([] []) - ([to] to) - ([to from] - (if (instance? clojure.lang.IEditableCollection to) - (with-meta (persistent! (reduce conj! (transient to) from)) (meta to)) - (reduce conj to from))) - ([to xform from] - (if (instance? clojure.lang.IEditableCollection to) - (let [tm (meta to) - rf (fn - ([coll] (-> (persistent! coll) (with-meta tm))) - ([coll v] (conj! coll v)))] - (transduce xform rf (transient to) from)) - (transduce xform conj to from)))) - -(defn mapv - "Returns a vector consisting of the result of applying f to the - set of first items of each coll, followed by applying f to the set - of second items in each coll, until any one of the colls is - exhausted. Any remaining items in other colls are ignored. Function - f should accept number-of-colls arguments." - {:added "1.4" - :static true} - ([f coll] - (-> (reduce (fn [v o] (conj! v (f o))) (transient []) coll) - persistent!)) - ([f c1 c2] - (into [] (map f c1 c2))) - ([f c1 c2 c3] - (into [] (map f c1 c2 c3))) - ([f c1 c2 c3 & colls] - (into [] (apply map f c1 c2 c3 colls)))) - -(defn filterv - "Returns a vector of the items in coll for which - (pred item) returns logical true. pred must be free of side-effects." - {:added "1.4" - :static true} - [pred coll] - (-> (reduce (fn [v o] (if (pred o) (conj! v o) v)) - (transient []) - coll) - persistent!)) - -(require '[clojure.clr.io :as cio]) ;;; '[clojure.java.io :as jio]) - -(defn- normalize-slurp-opts - [opts] - (if (string? (first opts)) - (do - (println "WARNING: (slurp f enc) is deprecated, use (slurp f :encoding enc).") - [:encoding (first opts)]) - opts)) - -(defn slurp - "Opens a reader on f and reads all its contents, returning a string. - See clojure.java.io/reader for a complete list of supported arguments." - {:added "1.0" - :tag String} - ([f & opts] - (let [opts (normalize-slurp-opts opts) - sw (System.IO.StringWriter.)] ;;; java.io.StringWriter - (with-open [^System.IO.TextReader r (apply cio/text-reader f opts)] ;;; java.io.Reader jio/reader - (cio/copy r sw) ;;; jio/copy - (.ToString sw))))) ;;; .toString - -(defn spit - "Opposite of slurp. Opens f with writer, writes content, then - closes f. Options passed to clojure.java.io/writer." - {:added "1.2"} - [f content & options] - (with-open [^System.IO.TextWriter w (apply cio/text-writer f options)] ;;; java.io.Writer jio/writer - (.Write w (str content)))) ;;; .write - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; futures (needs proxy);;;;;;;;;;;;;;;;;; -(defn future-call - "Takes a function of no args and yields a future object that will - invoke the function in another thread, and will cache the result and - return it on all subsequent calls to deref/@. If the computation has - not yet finished, calls to deref/@ will block, unless the variant - of deref with timeout is used. See also - realized?." - {:added "1.1" - :static true} - [f] - (let [f (binding-conveyor-fn f)] - (clojure.lang.Future. f))) ;;; fut (.submit clojure.lang.Agent/soloExecutor ^Callable f)] -;;; (reify -;;; clojure.lang.IDeref -;;; (deref [_] (deref-future fut)) -;;; clojure.lang.IBlockingDeref -;;; (deref -;;; [_ timeout-ms timeout-val] -;;; (deref-future fut timeout-ms timeout-val)) -;;; clojure.lang.IPending -;;; (isRealized [_] (.isDone fut)) -;;; java.util.concurrent.Future -;;; (get [_] (.get fut)) -;;; (get [_ timeout unit] (.get fut timeout unit)) -;;; (isCancelled [_] (.isCancelled fut)) -;;; (isDone [_] (.isDone fut)) -;;; (cancel [_ interrupt?] (.cancel fut interrupt?))))) - -(defmacro future - "Takes a body of expressions and yields a future object that will - invoke the body in another thread, and will cache the result and - return it on all subsequent calls to deref/@. If the computation has - not yet finished, calls to deref/@ will block, unless the variant of - deref with timeout is used. See also - realized?.." - {:added "1.1"} - [& body] `(future-call (^{:once true} fn* [] ~@body))) - - -(defn future-cancel - "Cancels the future, if possible." - {:added "1.1" - :static true} - [^clojure.lang.Future f] (.cancel f true)) ;;; java.util.concurrent.Future - -(defn future-cancelled? - "Returns true if future f is cancelled" - {:added "1.1" - :static true} - [^clojure.lang.Future f] (.isCancelled f)) ;;; java.util.concurrent.Future - -(defn pmap - "Like map, except f is applied in parallel. Semi-lazy in that the - parallel computation stays ahead of the consumption, but doesn't - realize the entire result unless required. Only useful for - computationally intensive functions where the time of f dominates - the coordination overhead." - {:added "1.0" - :static true} - ([f coll] - (let [n (+ 2 Environment/ProcessorCount) ;;; (.. Runtime getRuntime availableProcessors) - rets (map #(future (f %)) coll) - step (fn step [[x & xs :as vs] fs] - (lazy-seq - (if-let [s (seq fs)] - (cons (deref x) (step xs (rest s))) - (map deref vs))))] - (step rets (drop n rets)))) - ([f coll & colls] - (let [step (fn step [cs] - (lazy-seq - (let [ss (map seq cs)] - (when (every? identity ss) - (cons (map first ss) (step (map rest ss)))))))] - (pmap #(apply f %) (step (cons coll colls)))))) - -(defn pcalls - "Executes the no-arg fns in parallel, returning a lazy sequence of - their values" - {:added "1.0" - :static true} - [& fns] (pmap #(%) fns)) - -(defmacro pvalues - "Returns a lazy sequence of the values of the exprs, which are - evaluated in parallel" - {:added "1.0" - :static true} - [& exprs] - `(pcalls ~@(map #(list `fn [] %) exprs))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; clojure version number ;;;;;;;;;;;;;;;;;;;;;; -;;; THIS EXPOSES WAY TOO MUCH JVM INTERNALS! -(let [^clojure.runtime.Properties - properties (. clojure.lang.RT GetVersionProperties) ;;; properties (with-open [version-stream (.getResourceAsStream - ;;; (clojure.lang.RT/baseLoader) - ;;; "clojure/version.properties")] - ;;; (doto (new java.util.Properties) - ;;; (.load version-stream)) - version-string (.getProperty properties "version") - [_ major minor incremental qualifier snapshot] - (re-matches - #"(\d+)\.(\d+)\.(\d+)(?:-([a-zA-Z0-9_]+))?(?:-(SNAPSHOT))?" - version-string) - clojure-version {:major (Int32/Parse ^String major) ;;; Integer/valueOf - :minor (Int32/Parse ^String minor) ;;; Integer/valueOf - :incremental (Int32/Parse ^String incremental) ;;; Integer/valueOf - :qualifier (if (= qualifier "SNAPSHOT") nil qualifier)}] - (def ^:dynamic *clojure-version* - (if (.Contains version-string "SNAPSHOT") ;;; .contains - (clojure.lang.RT/assoc clojure-version :interim true) - clojure-version))) - -(add-doc-and-meta *clojure-version* - "The version info for Clojure core, as a map containing :major :minor - :incremental and :qualifier keys. Feature releases may increment - :minor and/or :major, bugfix releases will increment :incremental. - Possible values of :qualifier include \"GA\", \"SNAPSHOT\", \"RC-x\" \"BETA-x\"" - {:added "1.0"}) - -(defn - clojure-version - "Returns clojure version as a printable string." - {:added "1.0"} - [] - (str (:major *clojure-version*) - "." - (:minor *clojure-version*) - (when-let [i (:incremental *clojure-version*)] - (str "." i)) - (when-let [q (:qualifier *clojure-version*)] - (when (pos? (count q)) (str "-" q))) - (when (:interim *clojure-version*) - "-SNAPSHOT"))) - -(defn promise - "Returns a promise object that can be read with deref/@, and set, - once only, with deliver. Calls to deref/@ prior to delivery will - block, unless the variant of deref with timeout is used. All - subsequent derefs will return the same delivered value without - blocking. See also - realized?." - {:added "1.1" - :static true} - [] - (let [d (clojure.lang.CountDownLatch. 1) ;;; java.util.concurrent.CountDownLatch. - v (atom d)] - (reify - clojure.lang.IDeref - (deref [_] (.Await d) @v) ;;; .await - clojure.lang.IBlockingDeref - (deref - [_ timeout-ms timeout-val] - (if (.Await d timeout-ms) ;;; .Await java.util.concurrent.TimeUnit/MILLISECONDS - @v - timeout-val)) - clojure.lang.IPending - (isRealized [this] - (zero? (.Count d))) ;;; .getCount - clojure.lang.IFn - (invoke - [this x] - (when (and (pos? (.Count d)) ;;; getCount - (compare-and-set! v d x)) - (.CountDown d) ;;; countDown - this))))) - -(defn deliver - "Delivers the supplied value to the promise, releasing any pending - derefs. A subsequent call to deliver on a promise will have no effect." - {:added "1.1" - :static true} - [promise val] (promise val)) - - - -(defn flatten - "Takes any nested combination of sequential things (lists, vectors, - etc.) and returns their contents as a single, flat lazy sequence. - (flatten nil) returns an empty sequence." - {:added "1.2" - :static true} - [x] - (filter (complement sequential?) - (rest (tree-seq sequential? seq x)))) - -(defn group-by - "Returns a map of the elements of coll keyed by the result of - f on each element. The value at each key will be a vector of the - corresponding elements, in the order they appeared in coll." - {:added "1.2" - :static true} - [f coll] - (persistent! - (reduce - (fn [ret x] - (let [k (f x)] - (assoc! ret k (conj (get ret k []) x)))) - (transient {}) coll))) - -(defn partition-by - "Applies f to each value in coll, splitting it each time f returns a - new value. Returns a lazy seq of partitions. Returns a stateful - transducer when no collection is provided." - {:added "1.2" - :static true} - ([f] - (fn [rf] - (let [a (System.Collections.ArrayList.) ;;; java.util.ArrayList - pv (volatile! ::none)] - (fn - ([] (rf)) - ([result] - (let [result (if (zero? (.Count a)) ;;; (.isEmpty a) - result - (let [v (vec (.ToArray a))] ;;; .toArray - ;;clear first! - (.Clear a) ;;; .clear - (unreduced (rf result v))))] - (rf result))) - ([result input] - (let [pval @pv - val (f input)] - (vreset! pv val) - (if (or (identical? pval ::none) - (= val pval)) - (do - (.Add a input) ;;; .add - result) - (let [v (vec (.ToArray a))] ;;; .toArray - (.Clear a) ;;; .clear - (let [ret (rf result v)] - (when-not (reduced? ret) - (.Add a input)) ;;; .add - ret))))))))) - ([f coll] - (lazy-seq - (when-let [s (seq coll)] - (let [fst (first s) - fv (f fst) - run (cons fst (take-while #(= fv (f %)) (next s)))] - (cons run (partition-by f (lazy-seq (drop (count run) s))))))))) - -(defn frequencies - "Returns a map from distinct items in coll to the number of times - they appear." - {:added "1.2" - :static true} - [coll] - (persistent! - (reduce (fn [counts x] - (assoc! counts x (inc (get counts x 0)))) - (transient {}) coll))) - -(defn reductions - "Returns a lazy seq of the intermediate values of the reduction (as - per reduce) of coll by f, starting with init." - {:added "1.2"} - ([f coll] - (lazy-seq - (if-let [s (seq coll)] - (reductions f (first s) (rest s)) - (list (f))))) - ([f init coll] - (if (reduced? init) - (list @init) - (cons init - (lazy-seq - (when-let [s (seq coll)] - (reductions f (f init (first s)) (rest s)))))))) - -(defn rand-nth - "Return a random element of the (sequential) collection. Will have - the same performance characteristics as nth for the given - collection." - {:added "1.2" - :static true} - [coll] - (nth coll (rand-int (count coll)))) - -(defn partition-all - "Returns a lazy sequence of lists like partition, but may include - partitions with fewer than n items at the end. Returns a stateful - transducer when no collection is provided." - {:added "1.2" - :static true} - ([^long n] - (fn [rf] - (let [a (System.Collections.ArrayList. n)] ;;; java.util.ArrayList. - (fn - ([] (rf)) - ([result] - (let [result (if (zero? (.Count a)) ;;; (.isEmpty a) - result - (let [v (vec (.ToArray a))] ;;; .toArray - ;;clear first! - (.Clear a) ;;; .clear - (unreduced (rf result v))))] - (rf result))) - ([result input] - (.Add a input) ;;; .add - (if (= n (.Count a)) ;;; .size - (let [v (vec (.ToArray a))] ;;; .toArray - (.Clear a) ;;; .clear - (rf result v)) - result)))))) - ([n coll] - (partition-all n n coll)) - ([n step coll] - (lazy-seq - (when-let [s (seq coll)] - (let [seg (doall (take n s))] - (cons seg (partition-all n step (nthrest s step)))))))) - -(defn splitv-at - "Returns a vector of [(into [] (take n) coll) (drop n coll)]" - {:added "1.12"} - [n coll] - [(into [] (take n) coll) (drop n coll)]) - -(defn partitionv - "Returns a lazy sequence of vectors of n items each, at offsets step - apart. If step is not supplied, defaults to n, i.e. the partitions - do not overlap. If a pad collection is supplied, use its elements as - necessary to complete last partition upto n items. In case there are - not enough padding elements, return a partition with less than n items." - {:added "1.12"} - ([n coll] - (partitionv n n coll)) - ([n step coll] - (lazy-seq - (when-let [s (seq coll)] - (let [p (into [] (take n) s)] - (when (= n (count p)) - (cons p (partitionv n step (nthrest s step)))))))) - ([n step pad coll] - (lazy-seq - (when-let [s (seq coll)] - (let [p (into [] (take n) s)] - (if (= n (count p)) - (cons p (partitionv n step pad (nthrest s step))) - (list (into [] (take n) (concat p pad))))))))) - -(defn partitionv-all - "Returns a lazy sequence of vector partitions, but may include - partitions with fewer than n items at the end. - Returns a stateful transducer when no collection is provided." - {:added "1.12"} - ([n] - (partition-all n)) - ([n coll] - (partitionv-all n n coll)) - ([n step coll] - (lazy-seq - (when-let [s (seq coll)] - (let [seg (into [] (take n) coll)] - (cons seg (partitionv-all n step (drop step s)))))))) - -(defn shuffle - "Return a random permutation of coll" - {:added "1.1" - :static true} - [^System.Collections.ICollection coll] ;;; ^java.util.Collection - (let [al (System.Collections.ArrayList. coll)] ;;; java.util.ArrayList. - (clojure.lang.Util/Shuffle al) ;;; java.util.Collections/shuffle - (clojure.lang.RT/vector (.ToArray al)))) ;;; .toArray - -(defn map-indexed - "Returns a lazy sequence consisting of the result of applying f to 0 - and the first item of coll, followed by applying f to 1 and the second - item in coll, etc, until coll is exhausted. Thus function f should - accept 2 arguments, index and item. Returns a stateful transducer when - no collection is provided." - {:added "1.2" - :static true} - ([f] - (fn [rf] - (let [i (volatile! -1)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (rf result (f (vswap! i inc) input))))))) - ([f coll] - (letfn [(mapi [idx coll] - (lazy-seq - (when-let [s (seq coll)] - (if (chunked-seq? s) - (let [c (chunk-first s) - size (int (count c)) - b (chunk-buffer size)] - (dotimes [i size] - (chunk-append b (f (+ idx i) (.nth c i)))) - (chunk-cons (chunk b) (mapi (+ idx size) (chunk-rest s)))) - (cons (f idx (first s)) (mapi (inc idx) (rest s)))))))] - (mapi 0 coll)))) - -(defn keep - "Returns a lazy sequence of the non-nil results of (f item). Note, - this means false return values will be included. f must be free of - side-effects. Returns a transducer when no collection is provided." - {:added "1.2" - :static true} - ([f] - (fn [rf] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (let [v (f input)] - (if (nil? v) - result - (rf result v))))))) - ([f coll] - (lazy-seq - (when-let [s (seq coll)] - (if (chunked-seq? s) - (let [c (chunk-first s) - size (count c) - b (chunk-buffer size)] - (dotimes [i size] - (let [x (f (.nth c i))] - (when-not (nil? x) - (chunk-append b x)))) - (chunk-cons (chunk b) (keep f (chunk-rest s)))) - (let [x (f (first s))] - (if (nil? x) - (keep f (rest s)) - (cons x (keep f (rest s)))))))))) - -(defn keep-indexed - "Returns a lazy sequence of the non-nil results of (f index item). Note, - this means false return values will be included. f must be free of - side-effects. Returns a stateful transducer when no collection is - provided." - {:added "1.2" - :static true} - ([f] - (fn [rf] - (let [iv (volatile! -1)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (let [i (vswap! iv inc) - v (f i input)] - (if (nil? v) - result - (rf result v)))))))) - ([f coll] - (letfn [(keepi [idx coll] - (lazy-seq - (when-let [s (seq coll)] - (if (chunked-seq? s) - (let [c (chunk-first s) - size (count c) - b (chunk-buffer size)] - (dotimes [i size] - (let [x (f (+ idx i) (.nth c i))] - (when-not (nil? x) - (chunk-append b x)))) - (chunk-cons (chunk b) (keepi (+ idx size) (chunk-rest s)))) - (let [x (f idx (first s))] - (if (nil? x) - (keepi (inc idx) (rest s)) - (cons x (keepi (inc idx) (rest s)))))))))] - (keepi 0 coll)))) - -(defn bounded-count - "If coll is counted? returns its count, else will count at most the first n - elements of coll using its seq" - {:added "1.9"} - [n coll] - (if (counted? coll) - (count coll) - (loop [i 0 s (seq coll)] - (if (and s (< i n)) - (recur (inc i) (next s)) - i)))) - -(defn every-pred - "Takes a set of predicates and returns a function f that returns true if all of its - composing predicates return a logical true value against all of its arguments, else it returns - false. Note that f is short-circuiting in that it will stop execution on the first - argument that triggers a logical false result against the original predicates." - {:added "1.3"} - ([p] - (fn ep1 - ([] true) - ([x] (boolean (p x))) - ([x y] (boolean (and (p x) (p y)))) - ([x y z] (boolean (and (p x) (p y) (p z)))) - ([x y z & args] (boolean (and (ep1 x y z) - (every? p args)))))) - ([p1 p2] - (fn ep2 - ([] true) - ([x] (boolean (and (p1 x) (p2 x)))) - ([x y] (boolean (and (p1 x) (p1 y) (p2 x) (p2 y)))) - ([x y z] (boolean (and (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z)))) - ([x y z & args] (boolean (and (ep2 x y z) - (every? #(and (p1 %) (p2 %)) args)))))) - ([p1 p2 p3] - (fn ep3 - ([] true) - ([x] (boolean (and (p1 x) (p2 x) (p3 x)))) - ([x y] (boolean (and (p1 x) (p1 y) (p2 x) (p2 y) (p3 x) (p3 y)))) - ([x y z] (boolean (and (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z) (p3 x) (p3 y) (p3 z)))) - ([x y z & args] (boolean (and (ep3 x y z) - (every? #(and (p1 %) (p2 %) (p3 %)) args)))))) - ([p1 p2 p3 & ps] - (let [ps (list* p1 p2 p3 ps)] - (fn epn - ([] true) - ([x] (every? #(% x) ps)) - ([x y] (every? #(and (% x) (% y)) ps)) - ([x y z] (every? #(and (% x) (% y) (% z)) ps)) - ([x y z & args] (boolean (and (epn x y z) - (every? #(every? % args) ps)))))))) - -(defn some-fn - "Takes a set of predicates and returns a function f that returns the first logical true value - returned by one of its composing predicates against any of its arguments, else it returns - logical false. Note that f is short-circuiting in that it will stop execution on the first - argument that triggers a logical true result against the original predicates." - {:added "1.3"} - ([p] - (fn sp1 - ([] nil) - ([x] (p x)) - ([x y] (or (p x) (p y))) - ([x y z] (or (p x) (p y) (p z))) - ([x y z & args] (or (sp1 x y z) - (some p args))))) - ([p1 p2] - (fn sp2 - ([] nil) - ([x] (or (p1 x) (p2 x))) - ([x y] (or (p1 x) (p1 y) (p2 x) (p2 y))) - ([x y z] (or (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z))) - ([x y z & args] (or (sp2 x y z) - (some #(or (p1 %) (p2 %)) args))))) - ([p1 p2 p3] - (fn sp3 - ([] nil) - ([x] (or (p1 x) (p2 x) (p3 x))) - ([x y] (or (p1 x) (p1 y) (p2 x) (p2 y) (p3 x) (p3 y))) - ([x y z] (or (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z) (p3 x) (p3 y) (p3 z))) - ([x y z & args] (or (sp3 x y z) - (some #(or (p1 %) (p2 %) (p3 %)) args))))) - ([p1 p2 p3 & ps] - (let [ps (list* p1 p2 p3 ps)] - (fn spn - ([] nil) - ([x] (some #(% x) ps)) - ([x y] (some #(or (% x) (% y)) ps)) - ([x y z] (some #(or (% x) (% y) (% z)) ps)) - ([x y z & args] (or (spn x y z) - (some #(some % args) ps))))))) - -(defn- ^{:dynamic true} assert-valid-fdecl - "A good fdecl looks like (([a] ...) ([a b] ...)) near the end of defn." - [fdecl] - (when (empty? fdecl) (throw (ArgumentException. ;;; IllegalArgumentException - "Parameter declaration missing"))) - (let [argdecls (map - #(if (seq? %) - (first %) - (throw (ArgumentException. ;;; IllegalArgumentException - (if (seq? (first fdecl)) - (str "Invalid signature \"" - % - "\" should be a list") - (str "Parameter declaration \"" - % - "\" should be a vector"))))) - fdecl) - bad-args (seq (remove #(vector? %) argdecls))] - (when bad-args - (throw (ArgumentException. (str "Parameter declaration \"" (first bad-args) ;;; IllegalArgumentException - "\" should be a vector")))))) - -(defn with-redefs-fn - "Temporarily redefines Vars during a call to func. Each val of - binding-map will replace the root value of its key which must be - a Var. After func is called with no args, the root values of all - the Vars will be set back to their old values. These temporary - changes will be visible in all threads. Useful for mocking out - functions during testing." - {:added "1.3"} - [binding-map func] - (let [root-bind (fn [m] - (doseq [[a-var a-val] m] - (.bindRoot ^clojure.lang.Var a-var a-val))) - old-vals (zipmap (keys binding-map) - (map #(.getRawRoot ^clojure.lang.Var %) (keys binding-map)))] - (try - (root-bind binding-map) - (func) - (finally - (root-bind old-vals))))) - -(defmacro with-redefs - "binding => var-symbol temp-value-expr - - Temporarily redefines Vars while executing the body. The - temp-value-exprs will be evaluated and each resulting value will - replace in parallel the root value of its Var. After the body is - executed, the root values of all the Vars will be set back to their - old values. These temporary changes will be visible in all threads. - Useful for mocking out functions during testing." - {:added "1.3"} - [bindings & body] - `(with-redefs-fn ~(zipmap (map #(list `var %) (take-nth 2 bindings)) - (take-nth 2 (next bindings))) - (fn [] ~@body))) - -(defn realized? - "Returns true if a value has been produced for a promise, delay, future or lazy sequence." - {:added "1.3"} - [^clojure.lang.IPending x] (.isRealized x)) - -(defmacro cond-> - "Takes an expression and a set of test/form pairs. Threads expr (via ->) - through each form for which the corresponding test - expression is true. Note that, unlike cond branching, cond-> threading does - not short circuit after the first true test expression." - {:added "1.5"} - [expr & clauses] - (assert (even? (count clauses))) - (let [g (gensym) - steps (map (fn [[test step]] `(if ~test (-> ~g ~step) ~g)) - (partition 2 clauses))] - `(let [~g ~expr - ~@(interleave (repeat g) (butlast steps))] - ~(if (empty? steps) - g - (last steps))))) - -(defmacro cond->> - "Takes an expression and a set of test/form pairs. Threads expr (via ->>) - through each form for which the corresponding test expression - is true. Note that, unlike cond branching, cond->> threading does not short circuit - after the first true test expression." - {:added "1.5"} - [expr & clauses] - (assert (even? (count clauses))) - (let [g (gensym) - steps (map (fn [[test step]] `(if ~test (->> ~g ~step) ~g)) - (partition 2 clauses))] - `(let [~g ~expr - ~@(interleave (repeat g) (butlast steps))] - ~(if (empty? steps) - g - (last steps))))) - -(defmacro as-> - "Binds name to expr, evaluates the first form in the lexical context - of that binding, then binds name to that result, repeating for each - successive form, returning the result of the last form." - {:added "1.5"} - [expr name & forms] - `(let [~name ~expr - ~@(interleave (repeat name) (butlast forms))] - ~(if (empty? forms) - name - (last forms)))) - -(defmacro some-> - "When expr is not nil, threads it into the first form (via ->), - and when that result is not nil, through the next etc" - {:added "1.5"} - [expr & forms] - (let [g (gensym) - steps (map (fn [step] `(if (nil? ~g) nil (-> ~g ~step))) - forms)] - `(let [~g ~expr - ~@(interleave (repeat g) (butlast steps))] - ~(if (empty? steps) - g - (last steps))))) - -(defmacro some->> - "When expr is not nil, threads it into the first form (via ->>), - and when that result is not nil, through the next etc" - {:added "1.5"} - [expr & forms] - (let [g (gensym) - steps (map (fn [step] `(if (nil? ~g) nil (->> ~g ~step))) - forms)] - `(let [~g ~expr - ~@(interleave (repeat g) (butlast steps))] - ~(if (empty? steps) - g - (last steps))))) - -(defn ^:private preserving-reduced - [rf] - #(let [ret (rf %1 %2)] - (if (reduced? ret) - (reduced ret) - ret))) - -(defn cat - "A transducer which concatenates the contents of each input, which must be a - collection, into the reduction." - {:added "1.7"} - [rf] - (let [rrf (preserving-reduced rf)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (reduce rrf result input))))) - -(defn halt-when - "Returns a transducer that ends transduction when pred returns true - for an input. When retf is supplied it must be a fn of 2 arguments - - it will be passed the (completed) result so far and the input that - triggered the predicate, and its return value (if it does not throw - an exception) will be the return value of the transducer. If retf - is not supplied, the input that triggered the predicate will be - returned. If the predicate never returns true the transduction is - unaffected." - {:added "1.9"} - ([pred] (halt-when pred nil)) - ([pred retf] - (fn [rf] - (fn - ([] (rf)) - ([result] - (if (and (map? result) (contains? result ::halt)) - (::halt result) - (rf result))) - ([result input] - (if (pred input) - (reduced {::halt (if retf (retf (rf result) input) input)}) - (rf result input))))))) - -(defn dedupe - "Returns a lazy sequence removing consecutive duplicates in coll. - Returns a transducer when no collection is provided." - {:added "1.7"} - ([] - (fn [rf] - (let [pv (volatile! ::none)] - (fn - ([] (rf)) - ([result] (rf result)) - ([result input] - (let [prior @pv] - (vreset! pv input) - (if (= prior input) - result - (rf result input)))))))) - ([coll] (sequence (dedupe) coll))) - -(defn random-sample - "Returns items from coll with random probability of prob (0.0 - - 1.0). Returns a transducer when no collection is provided." - {:added "1.7"} - ([prob] - (filter (fn [_] (< (rand) prob)))) - ([prob coll] - (filter (fn [_] (< (rand) prob)) coll))) - -(deftype Eduction [xform coll] - System.Collections.IEnumerable ;;; Iterable - (GetEnumerator [_] ;;; iterator - (clojure.lang.TransformerEnumerator/create xform (clojure.lang.RT/iter coll))) ;;; TransformerIterator - - clojure.lang.IReduceInit - (reduce [_ f init] - ;; NB (completing f) isolates completion of inner rf from outer rf - (transduce xform (completing f) init coll)) - - clojure.lang.Sequential) - -(defn eduction - "Returns a reducible/iterable application of the transducers - to the items in coll. Transducers are applied in order as if - combined with comp. Note that these applications will be - performed every time reduce/iterator is called." - {:arglists '([xform* coll]) - :added "1.7"} - [& xforms] - (Eduction. (apply comp (butlast xforms)) (last xforms))) - -(defmethod print-method Eduction [c, ^System.IO.TextWriter w] ;;; ^Writer - (if *print-readably* - (do - (print-sequential "(" pr-on " " ")" c w)) - (print-object c w))) - -(defn run! - "Runs the supplied procedure (via reduce), for purposes of side - effects, on successive items in the collection. Returns nil" - {:added "1.7"} - [proc coll] - (reduce #(proc %2) nil coll) - nil) - - (defn iteration - "Creates a seqable/reducible via repeated calls to step, - a function of some (continuation token) 'k'. The first call to step - will be passed initk, returning 'ret'. Iff (somef ret) is true, - (vf ret) will be included in the iteration, else iteration will - terminate and vf/kf will not be called. If (kf ret) is non-nil it - will be passed to the next step call, else iteration will terminate. - - This can be used e.g. to consume APIs that return paginated or batched data. - - step - (possibly impure) fn of 'k' -> 'ret' - - :somef - fn of 'ret' -> logical true/false, default 'some?' - :vf - fn of 'ret' -> 'v', a value produced by the iteration, default 'identity' - :kf - fn of 'ret' -> 'next-k' or nil (signaling 'do not continue'), default 'identity' - :initk - the first value passed to step, default 'nil' - - It is presumed that step with non-initk is unreproducible/non-idempotent. - If step with initk is unreproducible it is on the consumer to not consume twice." - {:added "1.11"} - [step & {:keys [somef vf kf initk] - :or {vf identity - kf identity - somef some? - initk nil}}] - (reify - clojure.lang.Seqable - (seq [_] - ((fn next [ret] - (when (somef ret) - (cons (vf ret) - (when-some [k (kf ret)] - (lazy-seq (next (step k))))))) - (step initk))) - clojure.lang.IReduceInit - (reduce [_ rf init] - (loop [acc init - ret (step initk)] - (if (somef ret) - (let [acc (rf acc (vf ret))] - (if (reduced? acc) - @acc - (if-some [k (kf ret)] - (recur acc (step k)) - acc))) - acc))))) - - (defn tagged-literal? - "Return true if the value is the data representation of a tagged literal" - {:added "1.7"} - [value] - (instance? clojure.lang.TaggedLiteral value)) - -(defn tagged-literal - "Construct a data representation of a tagged literal from a - tag symbol and a form." - {:added "1.7"} - [^clojure.lang.Symbol tag form] - (clojure.lang.TaggedLiteral/create tag form)) - -(defn reader-conditional? - "Return true if the value is the data representation of a reader conditional" - {:added "1.7"} - [value] - (instance? clojure.lang.ReaderConditional value)) - -(defn reader-conditional - "Construct a data representation of a reader conditional. - If true, splicing? indicates read-cond-splicing." - {:added "1.7"} - [form splicing?] ;;; removed ^Boolean on splicing? - (clojure.lang.ReaderConditional/create form splicing?)) - - - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; data readers ;;;;;;;;;;;;;;;;;; - -(def ^{:added "1.4"} default-data-readers - "Default map of data reader functions provided by Clojure. May be - overridden by binding *data-readers*." - (merge - {'uuid #'clojure.uuid/default-uuid-reader} - (when-class "System.DateTime" ;;; "java.sql.Timestamp" - {'inst #'clojure.instant/read-instant-datetime}))) ;;; read-instant-date - -(def ^{:added "1.4" :dynamic true} *data-readers* - "Map from reader tag symbols to data reader Vars. - - When Clojure starts, it searches for files named 'data_readers.clj' - and 'data_readers.cljc' at the root of the classpath. Each such file - must contain a literal map of symbols, like this: - - {foo/bar my.project.foo/bar - foo/baz my.project/baz} - - The first symbol in each pair is a tag that will be recognized by - the Clojure reader. The second symbol in the pair is the - fully-qualified name of a Var which will be invoked by the reader to - parse the form following the tag. For example, given the - data_readers.clj file above, the Clojure reader would parse this - form: - - #foo/bar [1 2 3] - - by invoking the Var #'my.project.foo/bar on the vector [1 2 3]. The - data reader function is invoked on the form AFTER it has been read - as a normal Clojure data structure by the reader. - - Reader tags without namespace qualifiers are reserved for - Clojure. Default reader tags are defined in - clojure.core/default-data-readers but may be overridden in - data_readers.clj, data_readers.cljc, or by rebinding this Var." - {}) - -(def ^{:added "1.5" :dynamic true} *default-data-reader-fn* - "When no data reader is found for a tag and *default-data-reader-fn* - is non-nil, it will be called with two arguments, - the tag and the value. If *default-data-reader-fn* is nil (the - default), an exception will be thrown for the unknown tag." - nil) - -(defn- data-reader-urls [] ;;; Actually, we will return a sequence of FileInfo instances - (let [] ;;; cl (.. Thread currentThread getContextClassLoader) - (concat - (enumeration-seq (.GetEnumerator ^System.Collections.IEnumerable (clojure.lang.RT/FindFiles "data_readers.clj"))) ;;; (.getResources cl "data_readers.clj") - (enumeration-seq (.GetEnumerator ^System.Collections.IEnumerable (clojure.lang.RT/FindFiles "data_readers.cljc"))) ;;; (.getResources cl "data_readers.cljc") - (enumeration-seq (.GetEnumerator ^System.Collections.IEnumerable (clojure.lang.RT/FindFiles "data_readers.cljr")))))) ;;; DM: Added - -(defn- data-reader-var [sym] - (intern (create-ns (symbol (namespace sym))) - (symbol (name sym)))) - -(defn- load-data-reader-file [mappings ^System.IO.FileInfo url] ;;; ^java.net.URL - (with-open [rdr (clojure.lang.LineNumberingTextReader. ;;; LineNumberingPushbackReader - (.OpenText url) )] ;;; (java.io.InputStreamReader. - ;;; (.openStream url) "UTF-8"))] - (binding [*file* (.Name url)] ;;; .getFile - (let [read-opts (if (.EndsWith (.Name url) "cljc") ;;; .endsWith .getPath - {:eof nil :read-cond :allow} - {:eof nil}) - new-mappings (read read-opts rdr)] - (when (not (map? new-mappings)) - (throw (ex-info (str "Not a valid data-reader map") - {:url url}))) - (reduce - (fn [m [k v]] - (when (not (symbol? k)) - (throw (ex-info (str "Invalid form in data-reader file") - {:url url - :form k}))) - (let [v-var (data-reader-var v)] - (when (and (contains? mappings k) - (not= (mappings k) v-var)) - (throw (ex-info "Conflicting data-reader mapping" - {:url url - :conflict k - :mappings m}))) - (assoc m k v-var))) - mappings - new-mappings))))) - -(defn- load-data-readers [] - (alter-var-root #'*data-readers* - (fn [mappings] - (reduce load-data-reader-file - mappings (data-reader-urls))))) - -(try - (load-data-readers) - (catch Exception t ;;; Throwable - (System.Console/WriteLine (.StackTrace t)) ;;; .printStackTrace - (throw t))) - -(defn uri? - "Return true if x is a java.net.URI" - {:added "1.9"} - [x] (instance? System.Uri x)) ;;; java.net.URI - -(defonce ^:private tapset (atom #{})) -(defonce ^:private ^|System.Collections.Concurrent.BlockingCollection`1[System.Object]| tapq (|System.Collections.Concurrent.BlockingCollection`1[System.Object]|. 1024)) ;;; ^java.util.concurrent.ArrayBlockingQueue java.util.concurrent.ArrayBlockingQueue. - -(defonce ^:private tap-loop - (delay - (doto (System.Threading.Thread. ;;; Thread. - (gen-delegate System.Threading.ThreadStart [] (let [t (.Take tapq) ;;; add gen-delegete, .take - x (if (identical? ::tap-nil t) nil t) - taps @tapset] - (doseq [tap taps] - (try - (tap x) - (catch Exception ex))) ;;; Throwable - (recur)) )) ;;; -- add paren - (.set_Name "clojure.core/tap-loop") ;;; convert ctor name arg to an explicit set - (.set_IsBackground true) ;;; setDaemon - (.Start)))) ;;; .start - -(defn add-tap - "adds f, a fn of one argument, to the tap set. This function will be called with anything sent via tap>. - This function may (briefly) block (e.g. for streams), and will never impede calls to tap>, - but blocking indefinitely may cause tap values to be dropped. - Remember f in order to remove-tap" - {:added "1.10"} - [f] - (force tap-loop) - (swap! tapset conj f) - nil) - - (defn remove-tap - "remove f from the tap set." - {:added "1.10"} - [f] - (swap! tapset disj f) - nil) - - (defn tap> - "sends x to any taps. Will not block. Returns true if there was room in the queue, - false if not (dropped)." - {:added "1.10"} - [x] - (force tap-loop) - (.TryAdd tapq (if (nil? x) ::tap-nil x))) ;;; .offer - - (defn update-vals - "m f => {k (f v) ...} - - Given a map m and a function f of 1-argument, returns a new map where the keys of m - are mapped to result of applying f to the corresponding values of m." - {:added "1.11"} - [m f] - (with-meta - (persistent! - (reduce-kv (fn [acc k v] (assoc! acc k (f v))) - (if (instance? clojure.lang.IEditableCollection m) - (transient m) - (transient {})) - m)) - (meta m))) - -(defn update-keys - "m f => {(f k) v ...} - - Given a map m and a function f of 1-argument, returns a new map whose - keys are the result of applying f to the keys of m, mapped to the - corresponding values of m. - f must return a unique key for each key of m, else the behavior is undefined." - {:added "1.11"} - [m f] - (let [ret (persistent! - (reduce-kv (fn [acc k v] (assoc! acc (f k) v)) - (transient {}) - m))] - (with-meta ret (meta m)))) - -(defn- parsing-err - "Construct message for parsing for non-string parsing error" - ^String [val] - (str "Expected string, got " (if (nil? val) "nil" (-> val class .Name)))) ;;; .getName - -(defn parse-long - {:doc "Parse string of decimal digits with optional leading -/+ and return a - Long value, or nil if parse fails" - :added "1.11"} - [^String s] ;;; ^Long -- no equivalent since this can return nil -- at least until we can return Nullable - (if (string? s) - (try - (Int64/Parse s) ;;; Long/Parse - (catch FormatException _ nil)(catch OverflowException _ nil)) ;;; NumberFormatException -- and added other cases - (throw (ArgumentException. (parsing-err s))))) ;;; IllegalArgumentException - -(defn parse-double - {:doc "Parse string with floating point components and return a Double value, - or nil if parse fails. - - Grammar: https://docs.oracle.com/javase/8/docs/api/java/lang/Double.html#valueOf-java.lang.String-" - :added "1.11"} - [^String s] ;;; ^Double -- no equivalent since this can return nil -- at least until we can return Nullable - (if (string? s) - (try - (Double/Parse s) ;;; Double/valueOf - (catch FormatException _ nil)(catch OverflowException _ nil)) ;;; NumberFormatException -- and added other cases - (throw (ArgumentException. (parsing-err s))))) ;;; IllegalArgumentException - -(defn parse-uuid - {:doc "Parse a string representing a UUID and return a java.util.UUID instance, - or nil if parse fails. - - Grammar: https://docs.oracle.com/javase/8/docs/api/java/util/UUID.html#toString--" - :added "1.11"} - ^System.Guid [^String s] ;;; java.util.UUID - (try - (System.Guid/Parse s) ;;; java.util.UUID/fromString - (catch ArgumentException _ nil)(catch FormatException _ nil))) ;;; IllegalArgumentException -- and added other cases - -(defn parse-boolean - {:doc "Parse strings \"true\" or \"false\" and return a boolean, or nil if invalid" - :added "1.11"} - [^String s] - (if (string? s) - (case s - "true" true - "false" false - nil) - (throw (ArgumentException. (parsing-err s))))) ;;; IllegalArgumentException - -(defn NaN? - {:doc "Returns true if num is NaN, else false" - :inline-arities #{1} - :inline (fn [num] `(Double/IsNaN ~num)) ;;; isNaN - :added "1.11"} - - [^double num] - (Double/IsNaN num)) ;;; isNaN - -(defn infinite? - {:doc "Returns true if num is negative or positive infinity, else false" - :inline-arities #{1} - :inline (fn [num] `(Double/IsInfinity ~num)) ;;; isInfinite - :added "1.11"} - [^double num] + ~(emit gpred gexpr clauses)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; var documentation ;;;;;;;;;;;;;;;;;;;;;;;;;; + +(alter-meta! #'*agent* assoc :added "1.0") +(alter-meta! #'in-ns assoc :added "1.0") +(alter-meta! #'load-file assoc :added "1.0") + +(defmacro add-doc-and-meta {:private true} [name docstring meta] + `(alter-meta! (var ~name) merge (assoc ~meta :doc ~docstring))) + +(add-doc-and-meta *file* + "The path of the file being evaluated, as a String. + + When there is no file, e.g. in the REPL, the value is not defined." + {:added "1.0"}) + +(add-doc-and-meta *command-line-args* + "A sequence of the supplied command line arguments, or nil if + none were supplied" + {:added "1.0"}) + +(add-doc-and-meta *warn-on-reflection* + "When set to true, the compiler will emit warnings when reflection is + needed to resolve Java method calls or field accesses. + + Defaults to false." + {:added "1.0"}) + +(add-doc-and-meta *compile-path* + "Specifies the directory where 'compile' will write out .class + files. This directory must be in the classpath for 'compile' to + work. + + Defaults to \"classes\"" + {:added "1.0"}) + +(add-doc-and-meta *compile-files* + "Set to true when compiling files, false otherwise." + {:added "1.0"}) + +(add-doc-and-meta *unchecked-math* + "While bound to true, compilations of +, -, *, inc, dec and the + coercions will be done without overflow checks. While bound + to :warn-on-boxed, same behavior as true, and a warning is emitted + when compilation uses boxed math. Default: false." + {:added "1.3"}) + +(add-doc-and-meta *compiler-options* + "A map of keys to options. + Note, when binding dynamically make sure to merge with previous value. + Supported options: + :elide-meta - a collection of metadata keys to elide during compilation. + :disable-locals-clearing - set to true to disable clearing, useful for using a debugger + :direct-linking - set to true to use direct static invocation of functions, rather than vars + Note that call sites compiled with direct linking will not be affected by var redefinition. + Use ^:redef (or ^:dynamic) on a var to prevent direct linking and allow redefinition. + See https://clojure.org/reference/compilation for more information." + {:added "1.4"}) + +(add-doc-and-meta *ns* + "A clojure.lang.Namespace object representing the current namespace." + {:added "1.0"}) + +(add-doc-and-meta *in* + "A java.io.Reader object representing standard input for read operations. + + Defaults to System/in, wrapped in a LineNumberingPushbackReader" + {:added "1.0"}) + +(add-doc-and-meta *out* + "A java.io.Writer object representing standard output for print operations. + + Defaults to System/out, wrapped in an OutputStreamWriter" + {:added "1.0"}) + +(add-doc-and-meta *err* + "A java.io.Writer object representing standard error for print operations. + + Defaults to System/err, wrapped in a PrintWriter" + {:added "1.0"}) + +(add-doc-and-meta *flush-on-newline* + "When set to true, output will be flushed whenever a newline is printed. + + Defaults to true." + {:added "1.0"}) + +(add-doc-and-meta *print-meta* + "If set to logical true, when printing an object, its metadata will also + be printed in a form that can be read back by the reader. + + Defaults to false." + {:added "1.0"}) + +(add-doc-and-meta *print-dup* + "When set to logical true, objects will be printed in a way that preserves + their type when read in later. + + Defaults to false." + {:added "1.0"}) + +(add-doc-and-meta *print-readably* + "When set to logical false, strings and characters will be printed with + non-alphanumeric characters converted to the appropriate escape sequences. + + Defaults to true" + {:added "1.0"}) + +(add-doc-and-meta *read-eval* + "Defaults to true (or value specified by system property, see below) + ***This setting implies that the full power of the reader is in play, + including syntax that can cause code to execute. It should never be + used with untrusted sources. See also: clojure.end/read.*** + + When set to logical false in the thread-local binding, + the eval reader (#=) and record/type literal syntax are disabled in read/load. + Example (will fail): (binding [*read-eval* false] (read-string \"#=(* 2 21)\")) + + The default binding can be controlled by the system property + 'clojure.read.eval' System properties can be set on the command line + like this: + + java -Dclojure.read.eval=false ... + + The system property can also be set to 'unknown' via + -Dclojure.read.eval=unknown, in which case the default binding + is :unknown and all reads will fail in contexts where *read-eval* + has not been explicitly bound to either true or false. This setting + can be a useful diagnostic tool to ensure that all of your reads + occur in considered contexts. You can also accomplish this in a + particular scope by binding *read-eval* to :unknown + " + {:added "1.0"}) + +(defn future? + "Returns true if x is a future" + {:added "1.1" + :static true} + [x] (instance? clojure.lang.Future x)) ;;; java.util.concurrent.Future + +(defn future-done? + "Returns true if future f is done" + {:added "1.1" + :static true} + [^clojure.lang.Future f] (.isDone f)) ;;; ^java.util.concurrent.Future + + +(defmacro letfn + "fnspec ==> (fname [params*] exprs) or (fname ([params*] exprs)+) + + Takes a vector of function specs and a body, and generates a set of + bindings of functions to their names. All of the names are available + in all of the definitions of the functions, as well as the body." + {:added "1.0", :forms '[(letfn [fnspecs*] exprs*)], + :special-form true, :url nil} + [fnspecs & body] + `(letfn* ~(vec (interleave (map first fnspecs) + (map #(cons `fn %) fnspecs))) + ~@body)) + +(defn fnil + "Takes a function f, and returns a function that calls f, replacing + a nil first argument to f with the supplied value x. Higher arity + versions can replace arguments in the second and third + positions (y, z). Note that the function f can take any number of + arguments, not just the one(s) being nil-patched." + {:added "1.2" + :static true} + ([f x] + (fn + ([a] (f (if (nil? a) x a))) + ([a b] (f (if (nil? a) x a) b)) + ([a b c] (f (if (nil? a) x a) b c)) + ([a b c & ds] (apply f (if (nil? a) x a) b c ds)))) + ([f x y] + (fn + ([a b] (f (if (nil? a) x a) (if (nil? b) y b))) + ([a b c] (f (if (nil? a) x a) (if (nil? b) y b) c)) + ([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) c ds)))) + ([f x y z] + (fn + ([a b] (f (if (nil? a) x a) (if (nil? b) y b))) + ([a b c] (f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c))) + ([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c) ds))))) + +(defn zipmap + "Returns a map with the keys mapped to the corresponding vals." + {:added "1.0" + :static true} + [keys vals] + (loop [map (transient {}) + ks (seq keys) + vs (seq vals)] + (if (and ks vs) + (recur (assoc! map (first ks) (first vs)) + (next ks) + (next vs)) + (persistent! map)))) + +;;;;;;; case ;;;;;;;;;;;;; +(defn- shift-mask [shift mask x] + (-> x (bit-shift-right shift) (bit-and mask))) + +(def ^:private max-mask-bits 13) +(def ^:private max-switch-table-size (bit-shift-left 1 max-mask-bits)) + +(defn- maybe-min-hash + "takes a collection of hashes and returns [shift mask] or nil if none found" + [hashes] + (first + (filter (fn [[s m]] + (apply distinct? (map #(shift-mask s m %) hashes))) + (for [mask (map #(dec (bit-shift-left 1 %)) (range 1 (inc max-mask-bits))) + shift (range 0 31)] + [shift mask])))) + +(defn- case-map + "Transforms a sequence of test constants and a corresponding sequence of then + expressions into a sorted map to be consumed by case*. The form of the map + entries are {(case-f test) [(test-f test) then]}." + [case-f test-f tests thens] + (into1 (sorted-map) + (zipmap (map case-f tests) + (map vector + (map test-f tests) + thens)))) + +(defn- fits-table? + "Returns true if the collection of ints can fit within the + max-table-switch-size, false otherwise." + [ints] + (< (- (apply max (seq ints)) (apply min (seq ints))) max-switch-table-size)) + +(defn- prep-ints + "Takes a sequence of int-sized test constants and a corresponding sequence of + then expressions. Returns a tuple of [shift mask case-map switch-type] where + case-map is a map of int case values to [test then] tuples, and switch-type + is either :sparse or :compact." + [tests thens] + (if (fits-table? tests) + ; compact case ints, no shift-mask + [0 0 (case-map int int tests thens) :compact] + (let [[shift mask] (or (maybe-min-hash (map int tests)) [0 0])] + (if (zero? mask) + ; sparse case ints, no shift-mask + [0 0 (case-map int int tests thens) :sparse] + ; compact case ints, with shift-mask + [shift mask (case-map #(shift-mask shift mask (int %)) int tests thens) :compact])))) + +(defn- merge-hash-collisions + "Takes a case expression, default expression, and a sequence of test constants + and a corresponding sequence of then expressions. Returns a tuple of + [tests thens skip-check-set] where no tests have the same hash. Each set of + input test constants with the same hash is replaced with a single test + constant (the case int), and their respective thens are combined into: + (condp = expr + test-1 then-1 + ... + test-n then-n + default). + The skip-check is a set of case ints for which post-switch equivalence + checking must not be done (the cases holding the above condp thens)." + [expr-sym default tests thens] + (let [buckets (loop [m {} ks tests vs thens] + (if (and ks vs) + (recur + (update m (clojure.lang.Util/hash (first ks)) (fnil conj []) [(first ks) (first vs)]) + (next ks) (next vs)) + m)) + assoc-multi (fn [m h bucket] + (let [testexprs (mapcat (fn [kv] [(list 'quote (first kv)) (second kv)]) bucket) + expr `(condp = ~expr-sym ~@testexprs ~default)] + (assoc m h expr))) + hmap (reduce1 + (fn [m [h bucket]] + (if (== 1 (count bucket)) + (assoc m (ffirst bucket) (second (first bucket))) + (assoc-multi m h bucket))) + {} buckets) + skip-check (->> buckets + (filter #(< 1 (count (second %)))) + (map first) + (into1 #{}))] + [(keys hmap) (vals hmap) skip-check])) + +(defn- prep-hashes + "Takes a sequence of test constants and a corresponding sequence of then + expressions. Returns a tuple of [shift mask case-map switch-type skip-check] + where case-map is a map of int case values to [test then] tuples, switch-type + is either :sparse or :compact, and skip-check is a set of case ints for which + post-switch equivalence checking must not be done (occurs with hash + collisions)." + [expr-sym default tests thens] + (let [hashcode #(clojure.lang.Util/hash %) + hashes (into1 #{} (map hashcode tests))] + (if (== (count tests) (count hashes)) + (if (fits-table? hashes) + ; compact case ints, no shift-mask + [0 0 (case-map hashcode identity tests thens) :compact] + (let [[shift mask] (or (maybe-min-hash hashes) [0 0])] + (if (zero? mask) + ; sparse case ints, no shift-mask + [0 0 (case-map hashcode identity tests thens) :sparse] + ; compact case ints, with shift-mask + [shift mask (case-map #(shift-mask shift mask (hashcode %)) identity tests thens) :compact]))) + ; resolve hash collisions and try again + (let [[tests thens skip-check] (merge-hash-collisions expr-sym default tests thens) + [shift mask case-map switch-type] (prep-hashes expr-sym default tests thens) + skip-check (if (zero? mask) + skip-check + (into1 #{} (map #(shift-mask shift mask %) skip-check)))] + [shift mask case-map switch-type skip-check])))) + + +(defmacro case + "Takes an expression, and a set of clauses. + + Each clause can take the form of either: + + test-constant result-expr + + (test-constant1 ... test-constantN) result-expr + + The test-constants are not evaluated. They must be compile-time + literals, and need not be quoted. If the expression is equal to a + test-constant, the corresponding result-expr is returned. 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. + + Unlike cond and condp, case does a constant-time dispatch, the + clauses are not considered sequentially. All manner of constant + expressions are acceptable in case, including numbers, strings, + symbols, keywords, and (Clojure) composites thereof. Note that since + lists are used to group multiple constants that map to the same + expression, a vector can be used to match a list if needed. The + test-constants need not be all of the same type." + {:added "1.2"} + + [e & clauses] + (let [ge (with-meta (gensym) {:tag Object}) + default (if (odd? (count clauses)) + (last clauses) + `(throw (ArgumentException. (str "No matching clause: " ~ge))))] ;;; IllegalArgumentException + (if (> 2 (count clauses)) + `(let [~ge ~e] ~default) + (let [pairs (partition 2 clauses) + assoc-test (fn assoc-test [m test expr] + (if (contains? m test) + (throw (ArgumentException. (str "Duplicate case test constant: " test))) ;;; IllegalArgumentException + (assoc m test expr))) + pairs (reduce1 + (fn [m [test expr]] + (if (seq? test) + (reduce1 #(assoc-test %1 %2 expr) m test) + (assoc-test m test expr))) + {} pairs) + tests (keys pairs) + thens (vals pairs) + mode (cond + (every? #(and (integer? %) (not (char? %)) (<= Int32/MinValue % Int32/MaxValue)) tests) ;;; Integer/MIN_VALUE Integer/MAX_VALUE - (not (char? %)) added to match char-handling semantics of JVM + :ints + (every? keyword? tests) + :identity + :else :hashes)] + (condp = mode + :ints + (let [[shift mask imap switch-type] (prep-ints tests thens)] + `(let [~ge ~e] (case* ~ge ~shift ~mask ~default ~imap ~switch-type :int))) + :hashes + (let [[shift mask imap switch-type skip-check] (prep-hashes ge default tests thens)] + `(let [~ge ~e] (case* ~ge ~shift ~mask ~default ~imap ~switch-type :hash-equiv ~skip-check))) + :identity + (let [[shift mask imap switch-type skip-check] (prep-hashes ge default tests thens)] + `(let [~ge ~e] (case* ~ge ~shift ~mask ~default ~imap ~switch-type :hash-identity ~skip-check)))))))) + + +;; redefine reduce with internal-reduce + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; helper files ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(alter-meta! (find-ns 'clojure.core) assoc :doc "Fundamental library of the Clojure language") (load "core_clr") ;;; Added +(load "core_proxy") +(load "core_print") +(load "genclass") +(load "core_deftype") +(load "core/protocols") +(load "gvec") + +(defmacro ^:private when-class [class-name & body] + `(try + (clojure.lang.RT/classForNameE ^String ~class-name) ;;; Class/forName -- not sure what else to replace this with + ~@body + (catch clojure.lang.TypeNotFoundException _#))) ;;; ClassNotFoundException + +(when-class "System.DateTime" ;;; "java.sql.Timestamp" + (load "instant")) + +(defprotocol Inst + (inst-ms* [inst])) + +(extend-protocol Inst + DateTime ;;; java.util.Date + (inst-ms* [inst] (long (.TotalMilliseconds (.Subtract ^DateTime inst (DateTime. 1970 1 1)))))) ;;; (.getTime ^java.util.Date inst) + +(defn inst-ms + "Return the number of milliseconds since January 1, 1970, 00:00:00 GMT" + {:added "1.9"} + [inst] + (inst-ms* inst)) + +(defn inst? + "Return true if x satisfies Inst" + {:added "1.9"} + [x] + (satisfies? Inst x)) + +;;;(extend-protocol clojure.core/Inst +;;; java.time.Instant +;;; (inst-ms* [inst] (.toEpochMilli ^java.time.Instant inst))) + +(load "uuid") + +(defn uuid? + "Return true if x is a java.util.UUID" + {:added "1.9"} + [x] (instance? System.Guid x)) ;;; java.util.UUID + +(defn random-uuid + {:doc "Returns a pseudo-randomly generated java.util.UUID instance (i.e. type 4). + See: https://docs.oracle.com/javase/8/docs/api/java/util/UUID.html#randomUUID--" + :added "1.11"} + ^System.Guid [] (System.Guid/NewGuid)) ;;; ^java.util.UUID java.util.UUID/randomUUID + +(defn reduce + "f should be a function of 2 arguments. If val is not supplied, + returns the result of applying f to the first 2 items in coll, then + applying f to that result and the 3rd item, etc. If coll contains no + items, f must accept no arguments as well, and reduce returns the + result of calling f with no arguments. If coll has only 1 item, it + is returned and f is not called. If val is supplied, returns the + result of applying f to val and the first item in coll, then + applying f to that result and the 2nd item, etc. If coll contains no + items, returns val and f is not called." + {:added "1.0"} + ([f coll] + (if (instance? clojure.lang.IReduce coll) + (.reduce ^clojure.lang.IReduce coll f) + (clojure.core.protocols/coll-reduce coll f))) + ([f val coll] + (if (instance? clojure.lang.IReduceInit coll) + (.reduce ^clojure.lang.IReduceInit coll f val) + (clojure.core.protocols/coll-reduce coll f val)))) + +(extend-protocol clojure.core.protocols/IKVReduce + nil + (kv-reduce + [_ f init] + init) + + ;;slow path default + System.Object + (kv-reduce + [amap f init] + (reduce (fn [ret ^clojure.lang.IMapEntry me] ;;; ^java.util.Map$Entry -- THe problem here is that we don't have an equivalent to java.util.Map$Entry. We will settle on IMapEntry + (f ret + (.key me) ;;; .getKey + (.val me))) ;;; .getValue + init + amap)) + + +clojure.lang.IKVReduce + (kv-reduce + [amap f init] + (.kvreduce amap f init))) + +(defn reduce-kv + "Reduces an associative collection. f should be a function of 3 + arguments. Returns the result of applying f to init, the first key + and the first value in coll, then applying f to that result and the + 2nd key and value, etc. If coll contains no entries, returns init + and f is not called. Note that reduce-kv is supported on vectors, + where the keys will be the ordinals." + {:added "1.4"} + ([f init coll] + (clojure.core.protocols/kv-reduce coll f init))) + +(defn completing + "Takes a reducing function f of 2 args and returns a fn suitable for + transduce by adding an arity-1 signature that calls cf (default - + identity) on the result argument." + {:added "1.7"} + ([f] (completing f identity)) + ([f cf] + (fn + ([] (f)) + ([x] (cf x)) + ([x y] (f x y))))) + +(defn transduce + "reduce with a transformation of f (xf). If init is not + supplied, (f) will be called to produce it. f should be a reducing + step function that accepts both 1 and 2 arguments, if it accepts + only 2 you can add the arity-1 with 'completing'. Returns the result + of applying (the transformed) xf to init and the first item in coll, + then applying xf to that result and the 2nd item, etc. If coll + contains no items, returns init and f is not called. Note that + certain transforms may inject or skip items." {:added "1.7"} + ([xform f coll] (transduce xform f (f) coll)) + ([xform f init coll] + (let [f (xform f) + ret (if (instance? clojure.lang.IReduceInit coll) + (.reduce ^clojure.lang.IReduceInit coll f init) + (clojure.core.protocols/coll-reduce coll f init))] + (f ret)))) + +(defn into + "Returns a new coll consisting of to-coll with all of the items of + from-coll conjoined. A transducer may be supplied." + {:added "1.0" + :static true} + ([] []) + ([to] to) + ([to from] + (if (instance? clojure.lang.IEditableCollection to) + (with-meta (persistent! (reduce conj! (transient to) from)) (meta to)) + (reduce conj to from))) + ([to xform from] + (if (instance? clojure.lang.IEditableCollection to) + (let [tm (meta to) + rf (fn + ([coll] (-> (persistent! coll) (with-meta tm))) + ([coll v] (conj! coll v)))] + (transduce xform rf (transient to) from)) + (transduce xform conj to from)))) + +(defn mapv + "Returns a vector consisting of the result of applying f to the + set of first items of each coll, followed by applying f to the set + of second items in each coll, until any one of the colls is + exhausted. Any remaining items in other colls are ignored. Function + f should accept number-of-colls arguments." + {:added "1.4" + :static true} + ([f coll] + (-> (reduce (fn [v o] (conj! v (f o))) (transient []) coll) + persistent!)) + ([f c1 c2] + (into [] (map f c1 c2))) + ([f c1 c2 c3] + (into [] (map f c1 c2 c3))) + ([f c1 c2 c3 & colls] + (into [] (apply map f c1 c2 c3 colls)))) + +(defn filterv + "Returns a vector of the items in coll for which + (pred item) returns logical true. pred must be free of side-effects." + {:added "1.4" + :static true} + [pred coll] + (-> (reduce (fn [v o] (if (pred o) (conj! v o) v)) + (transient []) + coll) + persistent!)) + +(require '[clojure.clr.io :as cio]) ;;; '[clojure.java.io :as jio]) + +(defn- normalize-slurp-opts + [opts] + (if (string? (first opts)) + (do + (println "WARNING: (slurp f enc) is deprecated, use (slurp f :encoding enc).") + [:encoding (first opts)]) + opts)) + +(defn slurp + "Opens a reader on f and reads all its contents, returning a string. + See clojure.java.io/reader for a complete list of supported arguments." + {:added "1.0" + :tag String} + ([f & opts] + (let [opts (normalize-slurp-opts opts) + sw (System.IO.StringWriter.)] ;;; java.io.StringWriter + (with-open [^System.IO.TextReader r (apply cio/text-reader f opts)] ;;; java.io.Reader jio/reader + (cio/copy r sw) ;;; jio/copy + (.ToString sw))))) ;;; .toString + +(defn spit + "Opposite of slurp. Opens f with writer, writes content, then + closes f. Options passed to clojure.java.io/writer." + {:added "1.2"} + [f content & options] + (with-open [^System.IO.TextWriter w (apply cio/text-writer f options)] ;;; java.io.Writer jio/writer + (.Write w (str content)))) ;;; .write + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; futures (needs proxy);;;;;;;;;;;;;;;;;; +(defn future-call + "Takes a function of no args and yields a future object that will + invoke the function in another thread, and will cache the result and + return it on all subsequent calls to deref/@. If the computation has + not yet finished, calls to deref/@ will block, unless the variant + of deref with timeout is used. See also - realized?." + {:added "1.1" + :static true} + [f] + (let [f (binding-conveyor-fn f)] + (clojure.lang.Future. f))) ;;; fut (.submit clojure.lang.Agent/soloExecutor ^Callable f)] +;;; (reify +;;; clojure.lang.IDeref +;;; (deref [_] (deref-future fut)) +;;; clojure.lang.IBlockingDeref +;;; (deref +;;; [_ timeout-ms timeout-val] +;;; (deref-future fut timeout-ms timeout-val)) +;;; clojure.lang.IPending +;;; (isRealized [_] (.isDone fut)) +;;; java.util.concurrent.Future +;;; (get [_] (.get fut)) +;;; (get [_ timeout unit] (.get fut timeout unit)) +;;; (isCancelled [_] (.isCancelled fut)) +;;; (isDone [_] (.isDone fut)) +;;; (cancel [_ interrupt?] (.cancel fut interrupt?))))) + +(defmacro future + "Takes a body of expressions and yields a future object that will + invoke the body in another thread, and will cache the result and + return it on all subsequent calls to deref/@. If the computation has + not yet finished, calls to deref/@ will block, unless the variant of + deref with timeout is used. See also - realized?.." + {:added "1.1"} + [& body] `(future-call (^{:once true} fn* [] ~@body))) + + +(defn future-cancel + "Cancels the future, if possible." + {:added "1.1" + :static true} + [^clojure.lang.Future f] (.cancel f true)) ;;; java.util.concurrent.Future + +(defn future-cancelled? + "Returns true if future f is cancelled" + {:added "1.1" + :static true} + [^clojure.lang.Future f] (.isCancelled f)) ;;; java.util.concurrent.Future + +(defn pmap + "Like map, except f is applied in parallel. Semi-lazy in that the + parallel computation stays ahead of the consumption, but doesn't + realize the entire result unless required. Only useful for + computationally intensive functions where the time of f dominates + the coordination overhead." + {:added "1.0" + :static true} + ([f coll] + (let [n (+ 2 Environment/ProcessorCount) ;;; (.. Runtime getRuntime availableProcessors) + rets (map #(future (f %)) coll) + step (fn step [[x & xs :as vs] fs] + (lazy-seq + (if-let [s (seq fs)] + (cons (deref x) (step xs (rest s))) + (map deref vs))))] + (step rets (drop n rets)))) + ([f coll & colls] + (let [step (fn step [cs] + (lazy-seq + (let [ss (map seq cs)] + (when (every? identity ss) + (cons (map first ss) (step (map rest ss)))))))] + (pmap #(apply f %) (step (cons coll colls)))))) + +(defn pcalls + "Executes the no-arg fns in parallel, returning a lazy sequence of + their values" + {:added "1.0" + :static true} + [& fns] (pmap #(%) fns)) + +(defmacro pvalues + "Returns a lazy sequence of the values of the exprs, which are + evaluated in parallel" + {:added "1.0" + :static true} + [& exprs] + `(pcalls ~@(map #(list `fn [] %) exprs))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; clojure version number ;;;;;;;;;;;;;;;;;;;;;; +;;; THIS EXPOSES WAY TOO MUCH JVM INTERNALS! +(let [^clojure.runtime.Properties + properties (. clojure.lang.RT GetVersionProperties) ;;; properties (with-open [version-stream (.getResourceAsStream + ;;; (clojure.lang.RT/baseLoader) + ;;; "clojure/version.properties")] + ;;; (doto (new java.util.Properties) + ;;; (.load version-stream)) + version-string (.getProperty properties "version") + [_ major minor incremental qualifier snapshot] + (re-matches + #"(\d+)\.(\d+)\.(\d+)(?:-([a-zA-Z0-9_]+))?(?:-(SNAPSHOT))?" + version-string) + clojure-version {:major (Int32/Parse ^String major) ;;; Integer/valueOf + :minor (Int32/Parse ^String minor) ;;; Integer/valueOf + :incremental (Int32/Parse ^String incremental) ;;; Integer/valueOf + :qualifier (if (= qualifier "SNAPSHOT") nil qualifier)}] + (def ^:dynamic *clojure-version* + (if (.Contains version-string "SNAPSHOT") ;;; .contains + (clojure.lang.RT/assoc clojure-version :interim true) + clojure-version))) + +(add-doc-and-meta *clojure-version* + "The version info for Clojure core, as a map containing :major :minor + :incremental and :qualifier keys. Feature releases may increment + :minor and/or :major, bugfix releases will increment :incremental. + Possible values of :qualifier include \"GA\", \"SNAPSHOT\", \"RC-x\" \"BETA-x\"" + {:added "1.0"}) + +(defn + clojure-version + "Returns clojure version as a printable string." + {:added "1.0"} + [] + (str (:major *clojure-version*) + "." + (:minor *clojure-version*) + (when-let [i (:incremental *clojure-version*)] + (str "." i)) + (when-let [q (:qualifier *clojure-version*)] + (when (pos? (count q)) (str "-" q))) + (when (:interim *clojure-version*) + "-SNAPSHOT"))) + +(defn promise + "Returns a promise object that can be read with deref/@, and set, + once only, with deliver. Calls to deref/@ prior to delivery will + block, unless the variant of deref with timeout is used. All + subsequent derefs will return the same delivered value without + blocking. See also - realized?." + {:added "1.1" + :static true} + [] + (let [d (clojure.lang.CountDownLatch. 1) ;;; java.util.concurrent.CountDownLatch. + v (atom d)] + (reify + clojure.lang.IDeref + (deref [_] (.Await d) @v) ;;; .await + clojure.lang.IBlockingDeref + (deref + [_ timeout-ms timeout-val] + (if (.Await d timeout-ms) ;;; .Await java.util.concurrent.TimeUnit/MILLISECONDS + @v + timeout-val)) + clojure.lang.IPending + (isRealized [this] + (zero? (.Count d))) ;;; .getCount + clojure.lang.IFn + (invoke + [this x] + (when (and (pos? (.Count d)) ;;; getCount + (compare-and-set! v d x)) + (.CountDown d) ;;; countDown + this))))) + +(defn deliver + "Delivers the supplied value to the promise, releasing any pending + derefs. A subsequent call to deliver on a promise will have no effect." + {:added "1.1" + :static true} + [promise val] (promise val)) + + + +(defn flatten + "Takes any nested combination of sequential things (lists, vectors, + etc.) and returns their contents as a single, flat lazy sequence. + (flatten nil) returns an empty sequence." + {:added "1.2" + :static true} + [x] + (filter (complement sequential?) + (rest (tree-seq sequential? seq x)))) + +(defn group-by + "Returns a map of the elements of coll keyed by the result of + f on each element. The value at each key will be a vector of the + corresponding elements, in the order they appeared in coll." + {:added "1.2" + :static true} + [f coll] + (persistent! + (reduce + (fn [ret x] + (let [k (f x)] + (assoc! ret k (conj (get ret k []) x)))) + (transient {}) coll))) + +(defn partition-by + "Applies f to each value in coll, splitting it each time f returns a + new value. Returns a lazy seq of partitions. Returns a stateful + transducer when no collection is provided." + {:added "1.2" + :static true} + ([f] + (fn [rf] + (let [a (System.Collections.ArrayList.) ;;; java.util.ArrayList + pv (volatile! ::none)] + (fn + ([] (rf)) + ([result] + (let [result (if (zero? (.Count a)) ;;; (.isEmpty a) + result + (let [v (vec (.ToArray a))] ;;; .toArray + ;;clear first! + (.Clear a) ;;; .clear + (unreduced (rf result v))))] + (rf result))) + ([result input] + (let [pval @pv + val (f input)] + (vreset! pv val) + (if (or (identical? pval ::none) + (= val pval)) + (do + (.Add a input) ;;; .add + result) + (let [v (vec (.ToArray a))] ;;; .toArray + (.Clear a) ;;; .clear + (let [ret (rf result v)] + (when-not (reduced? ret) + (.Add a input)) ;;; .add + ret))))))))) + ([f coll] + (lazy-seq + (when-let [s (seq coll)] + (let [fst (first s) + fv (f fst) + run (cons fst (take-while #(= fv (f %)) (next s)))] + (cons run (partition-by f (lazy-seq (drop (count run) s))))))))) + +(defn frequencies + "Returns a map from distinct items in coll to the number of times + they appear." + {:added "1.2" + :static true} + [coll] + (persistent! + (reduce (fn [counts x] + (assoc! counts x (inc (get counts x 0)))) + (transient {}) coll))) + +(defn reductions + "Returns a lazy seq of the intermediate values of the reduction (as + per reduce) of coll by f, starting with init." + {:added "1.2"} + ([f coll] + (lazy-seq + (if-let [s (seq coll)] + (reductions f (first s) (rest s)) + (list (f))))) + ([f init coll] + (if (reduced? init) + (list @init) + (cons init + (lazy-seq + (when-let [s (seq coll)] + (reductions f (f init (first s)) (rest s)))))))) + +(defn rand-nth + "Return a random element of the (sequential) collection. Will have + the same performance characteristics as nth for the given + collection." + {:added "1.2" + :static true} + [coll] + (nth coll (rand-int (count coll)))) + +(defn partition-all + "Returns a lazy sequence of lists like partition, but may include + partitions with fewer than n items at the end. Returns a stateful + transducer when no collection is provided." + {:added "1.2" + :static true} + ([^long n] + (fn [rf] + (let [a (System.Collections.ArrayList. n)] ;;; java.util.ArrayList. + (fn + ([] (rf)) + ([result] + (let [result (if (zero? (.Count a)) ;;; (.isEmpty a) + result + (let [v (vec (.ToArray a))] ;;; .toArray + ;;clear first! + (.Clear a) ;;; .clear + (unreduced (rf result v))))] + (rf result))) + ([result input] + (.Add a input) ;;; .add + (if (= n (.Count a)) ;;; .size + (let [v (vec (.ToArray a))] ;;; .toArray + (.Clear a) ;;; .clear + (rf result v)) + result)))))) + ([n coll] + (partition-all n n coll)) + ([n step coll] + (lazy-seq + (when-let [s (seq coll)] + (let [seg (doall (take n s))] + (cons seg (partition-all n step (nthrest s step)))))))) + +(defn splitv-at + "Returns a vector of [(into [] (take n) coll) (drop n coll)]" + {:added "1.12"} + [n coll] + [(into [] (take n) coll) (drop n coll)]) + +(defn partitionv + "Returns a lazy sequence of vectors of n items each, at offsets step + apart. If step is not supplied, defaults to n, i.e. the partitions + do not overlap. If a pad collection is supplied, use its elements as + necessary to complete last partition upto n items. In case there are + not enough padding elements, return a partition with less than n items." + {:added "1.12"} + ([n coll] + (partitionv n n coll)) + ([n step coll] + (lazy-seq + (when-let [s (seq coll)] + (let [p (into [] (take n) s)] + (when (= n (count p)) + (cons p (partitionv n step (nthrest s step)))))))) + ([n step pad coll] + (lazy-seq + (when-let [s (seq coll)] + (let [p (into [] (take n) s)] + (if (= n (count p)) + (cons p (partitionv n step pad (nthrest s step))) + (list (into [] (take n) (concat p pad))))))))) + +(defn partitionv-all + "Returns a lazy sequence of vector partitions, but may include + partitions with fewer than n items at the end. + Returns a stateful transducer when no collection is provided." + {:added "1.12"} + ([n] + (partition-all n)) + ([n coll] + (partitionv-all n n coll)) + ([n step coll] + (lazy-seq + (when-let [s (seq coll)] + (let [seg (into [] (take n) coll)] + (cons seg (partitionv-all n step (drop step s)))))))) + +(defn shuffle + "Return a random permutation of coll" + {:added "1.1" + :static true} + [^System.Collections.ICollection coll] ;;; ^java.util.Collection + (let [al (System.Collections.ArrayList. coll)] ;;; java.util.ArrayList. + (clojure.lang.Util/Shuffle al) ;;; java.util.Collections/shuffle + (clojure.lang.RT/vector (.ToArray al)))) ;;; .toArray + +(defn map-indexed + "Returns a lazy sequence consisting of the result of applying f to 0 + and the first item of coll, followed by applying f to 1 and the second + item in coll, etc, until coll is exhausted. Thus function f should + accept 2 arguments, index and item. Returns a stateful transducer when + no collection is provided." + {:added "1.2" + :static true} + ([f] + (fn [rf] + (let [i (volatile! -1)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (rf result (f (vswap! i inc) input))))))) + ([f coll] + (letfn [(mapi [idx coll] + (lazy-seq + (when-let [s (seq coll)] + (if (chunked-seq? s) + (let [c (chunk-first s) + size (int (count c)) + b (chunk-buffer size)] + (dotimes [i size] + (chunk-append b (f (+ idx i) (.nth c i)))) + (chunk-cons (chunk b) (mapi (+ idx size) (chunk-rest s)))) + (cons (f idx (first s)) (mapi (inc idx) (rest s)))))))] + (mapi 0 coll)))) + +(defn keep + "Returns a lazy sequence of the non-nil results of (f item). Note, + this means false return values will be included. f must be free of + side-effects. Returns a transducer when no collection is provided." + {:added "1.2" + :static true} + ([f] + (fn [rf] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [v (f input)] + (if (nil? v) + result + (rf result v))))))) + ([f coll] + (lazy-seq + (when-let [s (seq coll)] + (if (chunked-seq? s) + (let [c (chunk-first s) + size (count c) + b (chunk-buffer size)] + (dotimes [i size] + (let [x (f (.nth c i))] + (when-not (nil? x) + (chunk-append b x)))) + (chunk-cons (chunk b) (keep f (chunk-rest s)))) + (let [x (f (first s))] + (if (nil? x) + (keep f (rest s)) + (cons x (keep f (rest s)))))))))) + +(defn keep-indexed + "Returns a lazy sequence of the non-nil results of (f index item). Note, + this means false return values will be included. f must be free of + side-effects. Returns a stateful transducer when no collection is + provided." + {:added "1.2" + :static true} + ([f] + (fn [rf] + (let [iv (volatile! -1)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [i (vswap! iv inc) + v (f i input)] + (if (nil? v) + result + (rf result v)))))))) + ([f coll] + (letfn [(keepi [idx coll] + (lazy-seq + (when-let [s (seq coll)] + (if (chunked-seq? s) + (let [c (chunk-first s) + size (count c) + b (chunk-buffer size)] + (dotimes [i size] + (let [x (f (+ idx i) (.nth c i))] + (when-not (nil? x) + (chunk-append b x)))) + (chunk-cons (chunk b) (keepi (+ idx size) (chunk-rest s)))) + (let [x (f idx (first s))] + (if (nil? x) + (keepi (inc idx) (rest s)) + (cons x (keepi (inc idx) (rest s)))))))))] + (keepi 0 coll)))) + +(defn bounded-count + "If coll is counted? returns its count, else will count at most the first n + elements of coll using its seq" + {:added "1.9"} + [n coll] + (if (counted? coll) + (count coll) + (loop [i 0 s (seq coll)] + (if (and s (< i n)) + (recur (inc i) (next s)) + i)))) + +(defn every-pred + "Takes a set of predicates and returns a function f that returns true if all of its + composing predicates return a logical true value against all of its arguments, else it returns + false. Note that f is short-circuiting in that it will stop execution on the first + argument that triggers a logical false result against the original predicates." + {:added "1.3"} + ([p] + (fn ep1 + ([] true) + ([x] (boolean (p x))) + ([x y] (boolean (and (p x) (p y)))) + ([x y z] (boolean (and (p x) (p y) (p z)))) + ([x y z & args] (boolean (and (ep1 x y z) + (every? p args)))))) + ([p1 p2] + (fn ep2 + ([] true) + ([x] (boolean (and (p1 x) (p2 x)))) + ([x y] (boolean (and (p1 x) (p1 y) (p2 x) (p2 y)))) + ([x y z] (boolean (and (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z)))) + ([x y z & args] (boolean (and (ep2 x y z) + (every? #(and (p1 %) (p2 %)) args)))))) + ([p1 p2 p3] + (fn ep3 + ([] true) + ([x] (boolean (and (p1 x) (p2 x) (p3 x)))) + ([x y] (boolean (and (p1 x) (p1 y) (p2 x) (p2 y) (p3 x) (p3 y)))) + ([x y z] (boolean (and (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z) (p3 x) (p3 y) (p3 z)))) + ([x y z & args] (boolean (and (ep3 x y z) + (every? #(and (p1 %) (p2 %) (p3 %)) args)))))) + ([p1 p2 p3 & ps] + (let [ps (list* p1 p2 p3 ps)] + (fn epn + ([] true) + ([x] (every? #(% x) ps)) + ([x y] (every? #(and (% x) (% y)) ps)) + ([x y z] (every? #(and (% x) (% y) (% z)) ps)) + ([x y z & args] (boolean (and (epn x y z) + (every? #(every? % args) ps)))))))) + +(defn some-fn + "Takes a set of predicates and returns a function f that returns the first logical true value + returned by one of its composing predicates against any of its arguments, else it returns + logical false. Note that f is short-circuiting in that it will stop execution on the first + argument that triggers a logical true result against the original predicates." + {:added "1.3"} + ([p] + (fn sp1 + ([] nil) + ([x] (p x)) + ([x y] (or (p x) (p y))) + ([x y z] (or (p x) (p y) (p z))) + ([x y z & args] (or (sp1 x y z) + (some p args))))) + ([p1 p2] + (fn sp2 + ([] nil) + ([x] (or (p1 x) (p2 x))) + ([x y] (or (p1 x) (p1 y) (p2 x) (p2 y))) + ([x y z] (or (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z))) + ([x y z & args] (or (sp2 x y z) + (some #(or (p1 %) (p2 %)) args))))) + ([p1 p2 p3] + (fn sp3 + ([] nil) + ([x] (or (p1 x) (p2 x) (p3 x))) + ([x y] (or (p1 x) (p1 y) (p2 x) (p2 y) (p3 x) (p3 y))) + ([x y z] (or (p1 x) (p1 y) (p1 z) (p2 x) (p2 y) (p2 z) (p3 x) (p3 y) (p3 z))) + ([x y z & args] (or (sp3 x y z) + (some #(or (p1 %) (p2 %) (p3 %)) args))))) + ([p1 p2 p3 & ps] + (let [ps (list* p1 p2 p3 ps)] + (fn spn + ([] nil) + ([x] (some #(% x) ps)) + ([x y] (some #(or (% x) (% y)) ps)) + ([x y z] (some #(or (% x) (% y) (% z)) ps)) + ([x y z & args] (or (spn x y z) + (some #(some % args) ps))))))) + +(defn- ^{:dynamic true} assert-valid-fdecl + "A good fdecl looks like (([a] ...) ([a b] ...)) near the end of defn." + [fdecl] + (when (empty? fdecl) (throw (ArgumentException. ;;; IllegalArgumentException + "Parameter declaration missing"))) + (let [argdecls (map + #(if (seq? %) + (first %) + (throw (ArgumentException. ;;; IllegalArgumentException + (if (seq? (first fdecl)) + (str "Invalid signature \"" + % + "\" should be a list") + (str "Parameter declaration \"" + % + "\" should be a vector"))))) + fdecl) + bad-args (seq (remove #(vector? %) argdecls))] + (when bad-args + (throw (ArgumentException. (str "Parameter declaration \"" (first bad-args) ;;; IllegalArgumentException + "\" should be a vector")))))) + +(defn with-redefs-fn + "Temporarily redefines Vars during a call to func. Each val of + binding-map will replace the root value of its key which must be + a Var. After func is called with no args, the root values of all + the Vars will be set back to their old values. These temporary + changes will be visible in all threads. Useful for mocking out + functions during testing." + {:added "1.3"} + [binding-map func] + (let [root-bind (fn [m] + (doseq [[a-var a-val] m] + (.bindRoot ^clojure.lang.Var a-var a-val))) + old-vals (zipmap (keys binding-map) + (map #(.getRawRoot ^clojure.lang.Var %) (keys binding-map)))] + (try + (root-bind binding-map) + (func) + (finally + (root-bind old-vals))))) + +(defmacro with-redefs + "binding => var-symbol temp-value-expr + + Temporarily redefines Vars while executing the body. The + temp-value-exprs will be evaluated and each resulting value will + replace in parallel the root value of its Var. After the body is + executed, the root values of all the Vars will be set back to their + old values. These temporary changes will be visible in all threads. + Useful for mocking out functions during testing." + {:added "1.3"} + [bindings & body] + `(with-redefs-fn ~(zipmap (map #(list `var %) (take-nth 2 bindings)) + (take-nth 2 (next bindings))) + (fn [] ~@body))) + +(defn realized? + "Returns true if a value has been produced for a promise, delay, future or lazy sequence." + {:added "1.3"} + [^clojure.lang.IPending x] (.isRealized x)) + +(defmacro cond-> + "Takes an expression and a set of test/form pairs. Threads expr (via ->) + through each form for which the corresponding test + expression is true. Note that, unlike cond branching, cond-> threading does + not short circuit after the first true test expression." + {:added "1.5"} + [expr & clauses] + (assert (even? (count clauses))) + (let [g (gensym) + steps (map (fn [[test step]] `(if ~test (-> ~g ~step) ~g)) + (partition 2 clauses))] + `(let [~g ~expr + ~@(interleave (repeat g) (butlast steps))] + ~(if (empty? steps) + g + (last steps))))) + +(defmacro cond->> + "Takes an expression and a set of test/form pairs. Threads expr (via ->>) + through each form for which the corresponding test expression + is true. Note that, unlike cond branching, cond->> threading does not short circuit + after the first true test expression." + {:added "1.5"} + [expr & clauses] + (assert (even? (count clauses))) + (let [g (gensym) + steps (map (fn [[test step]] `(if ~test (->> ~g ~step) ~g)) + (partition 2 clauses))] + `(let [~g ~expr + ~@(interleave (repeat g) (butlast steps))] + ~(if (empty? steps) + g + (last steps))))) + +(defmacro as-> + "Binds name to expr, evaluates the first form in the lexical context + of that binding, then binds name to that result, repeating for each + successive form, returning the result of the last form." + {:added "1.5"} + [expr name & forms] + `(let [~name ~expr + ~@(interleave (repeat name) (butlast forms))] + ~(if (empty? forms) + name + (last forms)))) + +(defmacro some-> + "When expr is not nil, threads it into the first form (via ->), + and when that result is not nil, through the next etc" + {:added "1.5"} + [expr & forms] + (let [g (gensym) + steps (map (fn [step] `(if (nil? ~g) nil (-> ~g ~step))) + forms)] + `(let [~g ~expr + ~@(interleave (repeat g) (butlast steps))] + ~(if (empty? steps) + g + (last steps))))) + +(defmacro some->> + "When expr is not nil, threads it into the first form (via ->>), + and when that result is not nil, through the next etc" + {:added "1.5"} + [expr & forms] + (let [g (gensym) + steps (map (fn [step] `(if (nil? ~g) nil (->> ~g ~step))) + forms)] + `(let [~g ~expr + ~@(interleave (repeat g) (butlast steps))] + ~(if (empty? steps) + g + (last steps))))) + +(defn ^:private preserving-reduced + [rf] + #(let [ret (rf %1 %2)] + (if (reduced? ret) + (reduced ret) + ret))) + +(defn cat + "A transducer which concatenates the contents of each input, which must be a + collection, into the reduction." + {:added "1.7"} + [rf] + (let [rrf (preserving-reduced rf)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (reduce rrf result input))))) + +(defn halt-when + "Returns a transducer that ends transduction when pred returns true + for an input. When retf is supplied it must be a fn of 2 arguments - + it will be passed the (completed) result so far and the input that + triggered the predicate, and its return value (if it does not throw + an exception) will be the return value of the transducer. If retf + is not supplied, the input that triggered the predicate will be + returned. If the predicate never returns true the transduction is + unaffected." + {:added "1.9"} + ([pred] (halt-when pred nil)) + ([pred retf] + (fn [rf] + (fn + ([] (rf)) + ([result] + (if (and (map? result) (contains? result ::halt)) + (::halt result) + (rf result))) + ([result input] + (if (pred input) + (reduced {::halt (if retf (retf (rf result) input) input)}) + (rf result input))))))) + +(defn dedupe + "Returns a lazy sequence removing consecutive duplicates in coll. + Returns a transducer when no collection is provided." + {:added "1.7"} + ([] + (fn [rf] + (let [pv (volatile! ::none)] + (fn + ([] (rf)) + ([result] (rf result)) + ([result input] + (let [prior @pv] + (vreset! pv input) + (if (= prior input) + result + (rf result input)))))))) + ([coll] (sequence (dedupe) coll))) + +(defn random-sample + "Returns items from coll with random probability of prob (0.0 - + 1.0). Returns a transducer when no collection is provided." + {:added "1.7"} + ([prob] + (filter (fn [_] (< (rand) prob)))) + ([prob coll] + (filter (fn [_] (< (rand) prob)) coll))) + +(deftype Eduction [xform coll] + System.Collections.IEnumerable ;;; Iterable + (GetEnumerator [_] ;;; iterator + (clojure.lang.TransformerEnumerator/create xform (clojure.lang.RT/iter coll))) ;;; TransformerIterator + + clojure.lang.IReduceInit + (reduce [_ f init] + ;; NB (completing f) isolates completion of inner rf from outer rf + (transduce xform (completing f) init coll)) + + clojure.lang.Sequential) + +(defn eduction + "Returns a reducible/iterable application of the transducers + to the items in coll. Transducers are applied in order as if + combined with comp. Note that these applications will be + performed every time reduce/iterator is called." + {:arglists '([xform* coll]) + :added "1.7"} + [& xforms] + (Eduction. (apply comp (butlast xforms)) (last xforms))) + +(defmethod print-method Eduction [c, ^System.IO.TextWriter w] ;;; ^Writer + (if *print-readably* + (do + (print-sequential "(" pr-on " " ")" c w)) + (print-object c w))) + +(defn run! + "Runs the supplied procedure (via reduce), for purposes of side + effects, on successive items in the collection. Returns nil" + {:added "1.7"} + [proc coll] + (reduce #(proc %2) nil coll) + nil) + + (defn iteration + "Creates a seqable/reducible via repeated calls to step, + a function of some (continuation token) 'k'. The first call to step + will be passed initk, returning 'ret'. Iff (somef ret) is true, + (vf ret) will be included in the iteration, else iteration will + terminate and vf/kf will not be called. If (kf ret) is non-nil it + will be passed to the next step call, else iteration will terminate. + + This can be used e.g. to consume APIs that return paginated or batched data. + + step - (possibly impure) fn of 'k' -> 'ret' + + :somef - fn of 'ret' -> logical true/false, default 'some?' + :vf - fn of 'ret' -> 'v', a value produced by the iteration, default 'identity' + :kf - fn of 'ret' -> 'next-k' or nil (signaling 'do not continue'), default 'identity' + :initk - the first value passed to step, default 'nil' + + It is presumed that step with non-initk is unreproducible/non-idempotent. + If step with initk is unreproducible it is on the consumer to not consume twice." + {:added "1.11"} + [step & {:keys [somef vf kf initk] + :or {vf identity + kf identity + somef some? + initk nil}}] + (reify + clojure.lang.Seqable + (seq [_] + ((fn next [ret] + (when (somef ret) + (cons (vf ret) + (when-some [k (kf ret)] + (lazy-seq (next (step k))))))) + (step initk))) + clojure.lang.IReduceInit + (reduce [_ rf init] + (loop [acc init + ret (step initk)] + (if (somef ret) + (let [acc (rf acc (vf ret))] + (if (reduced? acc) + @acc + (if-some [k (kf ret)] + (recur acc (step k)) + acc))) + acc))))) + + (defn tagged-literal? + "Return true if the value is the data representation of a tagged literal" + {:added "1.7"} + [value] + (instance? clojure.lang.TaggedLiteral value)) + +(defn tagged-literal + "Construct a data representation of a tagged literal from a + tag symbol and a form." + {:added "1.7"} + [^clojure.lang.Symbol tag form] + (clojure.lang.TaggedLiteral/create tag form)) + +(defn reader-conditional? + "Return true if the value is the data representation of a reader conditional" + {:added "1.7"} + [value] + (instance? clojure.lang.ReaderConditional value)) + +(defn reader-conditional + "Construct a data representation of a reader conditional. + If true, splicing? indicates read-cond-splicing." + {:added "1.7"} + [form splicing?] ;;; removed ^Boolean on splicing? + (clojure.lang.ReaderConditional/create form splicing?)) + + + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; data readers ;;;;;;;;;;;;;;;;;; + +(def ^{:added "1.4"} default-data-readers + "Default map of data reader functions provided by Clojure. May be + overridden by binding *data-readers*." + (merge + {'uuid #'clojure.uuid/default-uuid-reader} + (when-class "System.DateTime" ;;; "java.sql.Timestamp" + {'inst #'clojure.instant/read-instant-datetime}))) ;;; read-instant-date + +(def ^{:added "1.4" :dynamic true} *data-readers* + "Map from reader tag symbols to data reader Vars. + + When Clojure starts, it searches for files named 'data_readers.clj' + and 'data_readers.cljc' at the root of the classpath. Each such file + must contain a literal map of symbols, like this: + + {foo/bar my.project.foo/bar + foo/baz my.project/baz} + + The first symbol in each pair is a tag that will be recognized by + the Clojure reader. The second symbol in the pair is the + fully-qualified name of a Var which will be invoked by the reader to + parse the form following the tag. For example, given the + data_readers.clj file above, the Clojure reader would parse this + form: + + #foo/bar [1 2 3] + + by invoking the Var #'my.project.foo/bar on the vector [1 2 3]. The + data reader function is invoked on the form AFTER it has been read + as a normal Clojure data structure by the reader. + + Reader tags without namespace qualifiers are reserved for + Clojure. Default reader tags are defined in + clojure.core/default-data-readers but may be overridden in + data_readers.clj, data_readers.cljc, or by rebinding this Var." + {}) + +(def ^{:added "1.5" :dynamic true} *default-data-reader-fn* + "When no data reader is found for a tag and *default-data-reader-fn* + is non-nil, it will be called with two arguments, + the tag and the value. If *default-data-reader-fn* is nil (the + default), an exception will be thrown for the unknown tag." + nil) + +(defn- data-reader-urls [] ;;; Actually, we will return a sequence of FileInfo instances + (let [] ;;; cl (.. Thread currentThread getContextClassLoader) + (concat + (enumeration-seq (.GetEnumerator ^System.Collections.IEnumerable (clojure.lang.RT/FindFiles "data_readers.clj"))) ;;; (.getResources cl "data_readers.clj") + (enumeration-seq (.GetEnumerator ^System.Collections.IEnumerable (clojure.lang.RT/FindFiles "data_readers.cljc"))) ;;; (.getResources cl "data_readers.cljc") + (enumeration-seq (.GetEnumerator ^System.Collections.IEnumerable (clojure.lang.RT/FindFiles "data_readers.cljr")))))) ;;; DM: Added + +(defn- data-reader-var [sym] + (intern (create-ns (symbol (namespace sym))) + (symbol (name sym)))) + +(defn- load-data-reader-file [mappings ^System.IO.FileInfo url] ;;; ^java.net.URL + (with-open [rdr (clojure.lang.LineNumberingTextReader. ;;; LineNumberingPushbackReader + (.OpenText url) )] ;;; (java.io.InputStreamReader. + ;;; (.openStream url) "UTF-8"))] + (binding [*file* (.Name url)] ;;; .getFile + (let [read-opts (if (.EndsWith (.Name url) "cljc") ;;; .endsWith .getPath + {:eof nil :read-cond :allow} + {:eof nil}) + new-mappings (read read-opts rdr)] + (when (not (map? new-mappings)) + (throw (ex-info (str "Not a valid data-reader map") + {:url url}))) + (reduce + (fn [m [k v]] + (when (not (symbol? k)) + (throw (ex-info (str "Invalid form in data-reader file") + {:url url + :form k}))) + (let [v-var (data-reader-var v)] + (when (and (contains? mappings k) + (not= (mappings k) v-var)) + (throw (ex-info "Conflicting data-reader mapping" + {:url url + :conflict k + :mappings m}))) + (assoc m k v-var))) + mappings + new-mappings))))) + +(defn- load-data-readers [] + (alter-var-root #'*data-readers* + (fn [mappings] + (reduce load-data-reader-file + mappings (data-reader-urls))))) + +(try + (load-data-readers) + (catch Exception t ;;; Throwable + (System.Console/WriteLine (.StackTrace t)) ;;; .printStackTrace + (throw t))) + +(defn uri? + "Return true if x is a java.net.URI" + {:added "1.9"} + [x] (instance? System.Uri x)) ;;; java.net.URI + +(defonce ^:private tapset (atom #{})) +(defonce ^:private ^|System.Collections.Concurrent.BlockingCollection`1[System.Object]| tapq (|System.Collections.Concurrent.BlockingCollection`1[System.Object]|. 1024)) ;;; ^java.util.concurrent.ArrayBlockingQueue java.util.concurrent.ArrayBlockingQueue. + +(defonce ^:private tap-loop + (delay + (doto (System.Threading.Thread. ;;; Thread. + (gen-delegate System.Threading.ThreadStart [] (let [t (.Take tapq) ;;; add gen-delegete, .take + x (if (identical? ::tap-nil t) nil t) + taps @tapset] + (doseq [tap taps] + (try + (tap x) + (catch Exception ex))) ;;; Throwable + (recur)) )) ;;; -- add paren + (.set_Name "clojure.core/tap-loop") ;;; convert ctor name arg to an explicit set + (.set_IsBackground true) ;;; setDaemon + (.Start)))) ;;; .start + +(defn add-tap + "adds f, a fn of one argument, to the tap set. This function will be called with anything sent via tap>. + This function may (briefly) block (e.g. for streams), and will never impede calls to tap>, + but blocking indefinitely may cause tap values to be dropped. + Remember f in order to remove-tap" + {:added "1.10"} + [f] + (force tap-loop) + (swap! tapset conj f) + nil) + + (defn remove-tap + "remove f from the tap set." + {:added "1.10"} + [f] + (swap! tapset disj f) + nil) + + (defn tap> + "sends x to any taps. Will not block. Returns true if there was room in the queue, + false if not (dropped)." + {:added "1.10"} + [x] + (force tap-loop) + (.TryAdd tapq (if (nil? x) ::tap-nil x))) ;;; .offer + + (defn update-vals + "m f => {k (f v) ...} + + Given a map m and a function f of 1-argument, returns a new map where the keys of m + are mapped to result of applying f to the corresponding values of m." + {:added "1.11"} + [m f] + (with-meta + (persistent! + (reduce-kv (fn [acc k v] (assoc! acc k (f v))) + (if (instance? clojure.lang.IEditableCollection m) + (transient m) + (transient {})) + m)) + (meta m))) + +(defn update-keys + "m f => {(f k) v ...} + + Given a map m and a function f of 1-argument, returns a new map whose + keys are the result of applying f to the keys of m, mapped to the + corresponding values of m. + f must return a unique key for each key of m, else the behavior is undefined." + {:added "1.11"} + [m f] + (let [ret (persistent! + (reduce-kv (fn [acc k v] (assoc! acc (f k) v)) + (transient {}) + m))] + (with-meta ret (meta m)))) + +(defn- parsing-err + "Construct message for parsing for non-string parsing error" + ^String [val] + (str "Expected string, got " (if (nil? val) "nil" (-> val class .Name)))) ;;; .getName + +(defn parse-long + {:doc "Parse string of decimal digits with optional leading -/+ and return a + Long value, or nil if parse fails" + :added "1.11"} + [^String s] ;;; ^Long -- no equivalent since this can return nil -- at least until we can return Nullable + (if (string? s) + (try + (Int64/Parse s) ;;; Long/Parse + (catch FormatException _ nil)(catch OverflowException _ nil)) ;;; NumberFormatException -- and added other cases + (throw (ArgumentException. (parsing-err s))))) ;;; IllegalArgumentException + +(defn parse-double + {:doc "Parse string with floating point components and return a Double value, + or nil if parse fails. + + Grammar: https://docs.oracle.com/javase/8/docs/api/java/lang/Double.html#valueOf-java.lang.String-" + :added "1.11"} + [^String s] ;;; ^Double -- no equivalent since this can return nil -- at least until we can return Nullable + (if (string? s) + (try + (Double/Parse s) ;;; Double/valueOf + (catch FormatException _ nil)(catch OverflowException _ nil)) ;;; NumberFormatException -- and added other cases + (throw (ArgumentException. (parsing-err s))))) ;;; IllegalArgumentException + +(defn parse-uuid + {:doc "Parse a string representing a UUID and return a java.util.UUID instance, + or nil if parse fails. + + Grammar: https://docs.oracle.com/javase/8/docs/api/java/util/UUID.html#toString--" + :added "1.11"} + ^System.Guid [^String s] ;;; java.util.UUID + (try + (System.Guid/Parse s) ;;; java.util.UUID/fromString + (catch ArgumentException _ nil)(catch FormatException _ nil))) ;;; IllegalArgumentException -- and added other cases + +(defn parse-boolean + {:doc "Parse strings \"true\" or \"false\" and return a boolean, or nil if invalid" + :added "1.11"} + [^String s] + (if (string? s) + (case s + "true" true + "false" false + nil) + (throw (ArgumentException. (parsing-err s))))) ;;; IllegalArgumentException + +(defn NaN? + {:doc "Returns true if num is NaN, else false" + :inline-arities #{1} + :inline (fn [num] `(Double/IsNaN ~num)) ;;; isNaN + :added "1.11"} + + [^double num] + (Double/IsNaN num)) ;;; isNaN + +(defn infinite? + {:doc "Returns true if num is negative or positive infinity, else false" + :inline-arities #{1} + :inline (fn [num] `(Double/IsInfinity ~num)) ;;; isInfinite + :added "1.11"} + [^double num] (Double/IsInfinity num)) ;;; isInfinite \ No newline at end of file diff --git a/Clojure/Clojure.Source/clojure/core/protocols.clj b/Clojure/Clojure.Source/clojure/core/protocols.clj index 10be72688..543442192 100644 --- a/Clojure/Clojure.Source/clojure/core/protocols.clj +++ b/Clojure/Clojure.Source/clojure/core/protocols.clj @@ -1,202 +1,202 @@ -; 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. - -(ns clojure.core.protocols) - -(set! *warn-on-reflection* true) - -(defprotocol CollReduce - "Protocol for collection types that can implement reduce faster than - first/next recursion. Called by clojure.core/reduce. Baseline - implementation defined in terms of Iterable." - (coll-reduce [coll f] [coll f val])) - -(defprotocol InternalReduce - "Protocol for concrete seq types that can reduce themselves - faster than first/next recursion. Called by clojure.core/reduce." - (internal-reduce [seq f start])) - -(defn- seq-reduce - ([coll f] - (if-let [s (seq coll)] - (internal-reduce (next s) f (first s)) - (f))) - ([coll f val] - (let [s (seq coll)] - (internal-reduce s f val)))) - -(defn- iter-reduce - ([^System.Collections.IEnumerable coll f] ;;; ^java.lang.Iterable - (let [iter (.GetEnumerator coll)] ;;; .iterator - (if (.MoveNext iter) ;;; .hasNext - (loop [ret (.Current iter)] ;;; .next - (if (.MoveNext iter) ;;; .hasNext - (let [ret (f ret (.Current iter))] ;;; .next - (if (reduced? ret) - @ret - (recur ret))) - ret)) - (f)))) - ([^System.Collections.IEnumerable coll f val] ;;; ^java.lang.Iterable - (let [iter (.GetEnumerator coll)] ;;; .iterator - (loop [ret val] - (if (.MoveNext iter) ;;; .hasNext - (let [ret (f ret (.Current iter))] ;;; .next - (if (reduced? ret) - @ret - (recur ret))) - ret))))) - -(defn- naive-seq-reduce - "Reduces a seq, ignoring any opportunities to switch to a more - specialized implementation." - [s f val] - (loop [s (seq s) - val val] - (if s - (let [ret (f val (first s))] - (if (reduced? ret) - @ret - (recur (next s) ret))) - val))) - -(defn- interface-or-naive-reduce - "Reduces via IReduceInit if possible, else naively." - [coll f val] - (if (instance? clojure.lang.IReduceInit coll) - (.reduce ^clojure.lang.IReduceInit coll f val) - (naive-seq-reduce coll f val))) - -(extend-protocol CollReduce - nil - (coll-reduce - ([coll f] (f)) - ([coll f val] val)) - - Object - (coll-reduce - ([coll f] (seq-reduce coll f)) - ([coll f val] (seq-reduce coll f val))) - - clojure.lang.IReduceInit - (coll-reduce - ([coll f] (.reduce ^clojure.lang.IReduce coll f)) - ([coll f val] (.reduce coll f val))) - - ;;aseqs are iterable, masking internal-reducers - clojure.lang.ASeq - (coll-reduce - ([coll f] (seq-reduce coll f)) - ([coll f val] (seq-reduce coll f val))) - - ;;for range - clojure.lang.LazySeq - (coll-reduce - ([coll f] (seq-reduce coll f)) - ([coll f val] (seq-reduce coll f val))) - - ;;vector's chunked seq is faster than its iter - clojure.lang.PersistentVector - (coll-reduce - ([coll f] (seq-reduce coll f)) - ([coll f val] (seq-reduce coll f val))) - - System.Collections.IEnumerable ;;;Iterable - (coll-reduce - ([coll f] (iter-reduce coll f)) - ([coll f val] (iter-reduce coll f val))) - - clojure.lang.APersistentMap+KeySeq ;;; $KeySeq - (coll-reduce - ([coll f] (iter-reduce coll f)) - ([coll f val] (iter-reduce coll f val))) - - clojure.lang.APersistentMap+ValSeq ;;; $ValSeq - (coll-reduce - ([coll f] (iter-reduce coll f)) - ([coll f val] (iter-reduce coll f val)))) - -(extend-protocol InternalReduce - nil - (internal-reduce - [s f val] - val) - - ;; handles vectors and ranges - clojure.lang.IChunkedSeq - (internal-reduce - [s f val] - (if-let [s (seq s)] - (if (chunked-seq? s) - (let [ret (.reduce (chunk-first s) f val)] - (if (reduced? ret) - @ret - (recur (chunk-next s) - f - ret))) - (interface-or-naive-reduce s f val)) - val)) - - clojure.lang.StringSeq - (internal-reduce - [str-seq f val] - (let [s (.S str-seq) ;;; .s - len (.Length s)] ;;; .length - (loop [i (.I str-seq) ;;; .i - val val] - (if (< i len) - (let [ret (f val (.get_Chars s i))] ;;; .charAt - (if (reduced? ret) - @ret - (recur (inc i) ret))) - val)))) - - Object ;;;java.lang.Object - (internal-reduce - [s f val] - (loop [cls (class s) - s s - f f - val val] - (if-let [s (seq s)] - (if (identical? (class s) cls) - (let [ret (f val (first s))] - (if (reduced? ret) - @ret - (recur cls (next s) f ret))) - (interface-or-naive-reduce s f val)) - val)))) - -(defprotocol IKVReduce - "Protocol for concrete associative types that can reduce themselves - via a function of key and val faster than first/next recursion over map - entries. Called by clojure.core/reduce-kv, and has same - semantics (just different arg order)." - (kv-reduce [amap f init])) - -(defprotocol Datafiable - :extend-via-metadata true - - (datafy [o] "return a representation of o as data (default identity)")) - -(extend-protocol Datafiable - nil - (datafy [_] nil) - - Object - (datafy [x] x)) - -(defprotocol Navigable - :extend-via-metadata true - - (nav [coll k v] "return (possibly transformed) v in the context of coll and k (a key/index or nil), -defaults to returning v.")) - -(extend-protocol Navigable - Object +; 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. + +(ns clojure.core.protocols) + +(set! *warn-on-reflection* true) + +(defprotocol CollReduce + "Protocol for collection types that can implement reduce faster than + first/next recursion. Called by clojure.core/reduce. Baseline + implementation defined in terms of Iterable." + (coll-reduce [coll f] [coll f val])) + +(defprotocol InternalReduce + "Protocol for concrete seq types that can reduce themselves + faster than first/next recursion. Called by clojure.core/reduce." + (internal-reduce [seq f start])) + +(defn- seq-reduce + ([coll f] + (if-let [s (seq coll)] + (internal-reduce (next s) f (first s)) + (f))) + ([coll f val] + (let [s (seq coll)] + (internal-reduce s f val)))) + +(defn- iter-reduce + ([^System.Collections.IEnumerable coll f] ;;; ^java.lang.Iterable + (let [iter (.GetEnumerator coll)] ;;; .iterator + (if (.MoveNext iter) ;;; .hasNext + (loop [ret (.Current iter)] ;;; .next + (if (.MoveNext iter) ;;; .hasNext + (let [ret (f ret (.Current iter))] ;;; .next + (if (reduced? ret) + @ret + (recur ret))) + ret)) + (f)))) + ([^System.Collections.IEnumerable coll f val] ;;; ^java.lang.Iterable + (let [iter (.GetEnumerator coll)] ;;; .iterator + (loop [ret val] + (if (.MoveNext iter) ;;; .hasNext + (let [ret (f ret (.Current iter))] ;;; .next + (if (reduced? ret) + @ret + (recur ret))) + ret))))) + +(defn- naive-seq-reduce + "Reduces a seq, ignoring any opportunities to switch to a more + specialized implementation." + [s f val] + (loop [s (seq s) + val val] + (if s + (let [ret (f val (first s))] + (if (reduced? ret) + @ret + (recur (next s) ret))) + val))) + +(defn- interface-or-naive-reduce + "Reduces via IReduceInit if possible, else naively." + [coll f val] + (if (instance? clojure.lang.IReduceInit coll) + (.reduce ^clojure.lang.IReduceInit coll f val) + (naive-seq-reduce coll f val))) + +(extend-protocol CollReduce + nil + (coll-reduce + ([coll f] (f)) + ([coll f val] val)) + + Object + (coll-reduce + ([coll f] (seq-reduce coll f)) + ([coll f val] (seq-reduce coll f val))) + + clojure.lang.IReduceInit + (coll-reduce + ([coll f] (.reduce ^clojure.lang.IReduce coll f)) + ([coll f val] (.reduce coll f val))) + + ;;aseqs are iterable, masking internal-reducers + clojure.lang.ASeq + (coll-reduce + ([coll f] (seq-reduce coll f)) + ([coll f val] (seq-reduce coll f val))) + + ;;for range + clojure.lang.LazySeq + (coll-reduce + ([coll f] (seq-reduce coll f)) + ([coll f val] (seq-reduce coll f val))) + + ;;vector's chunked seq is faster than its iter + clojure.lang.PersistentVector + (coll-reduce + ([coll f] (seq-reduce coll f)) + ([coll f val] (seq-reduce coll f val))) + + System.Collections.IEnumerable ;;;Iterable + (coll-reduce + ([coll f] (iter-reduce coll f)) + ([coll f val] (iter-reduce coll f val))) + + clojure.lang.APersistentMap+KeySeq ;;; $KeySeq + (coll-reduce + ([coll f] (iter-reduce coll f)) + ([coll f val] (iter-reduce coll f val))) + + clojure.lang.APersistentMap+ValSeq ;;; $ValSeq + (coll-reduce + ([coll f] (iter-reduce coll f)) + ([coll f val] (iter-reduce coll f val)))) + +(extend-protocol InternalReduce + nil + (internal-reduce + [s f val] + val) + + ;; handles vectors and ranges + clojure.lang.IChunkedSeq + (internal-reduce + [s f val] + (if-let [s (seq s)] + (if (chunked-seq? s) + (let [ret (.reduce (chunk-first s) f val)] + (if (reduced? ret) + @ret + (recur (chunk-next s) + f + ret))) + (interface-or-naive-reduce s f val)) + val)) + + clojure.lang.StringSeq + (internal-reduce + [str-seq f val] + (let [s (.S str-seq) ;;; .s + len (.Length s)] ;;; .length + (loop [i (.I str-seq) ;;; .i + val val] + (if (< i len) + (let [ret (f val (.get_Chars s i))] ;;; .charAt + (if (reduced? ret) + @ret + (recur (inc i) ret))) + val)))) + + Object ;;;java.lang.Object + (internal-reduce + [s f val] + (loop [cls (class s) + s s + f f + val val] + (if-let [s (seq s)] + (if (identical? (class s) cls) + (let [ret (f val (first s))] + (if (reduced? ret) + @ret + (recur cls (next s) f ret))) + (interface-or-naive-reduce s f val)) + val)))) + +(defprotocol IKVReduce + "Protocol for concrete associative types that can reduce themselves + via a function of key and val faster than first/next recursion over map + entries. Called by clojure.core/reduce-kv, and has same + semantics (just different arg order)." + (kv-reduce [amap f init])) + +(defprotocol Datafiable + :extend-via-metadata true + + (datafy [o] "return a representation of o as data (default identity)")) + +(extend-protocol Datafiable + nil + (datafy [_] nil) + + Object + (datafy [x] x)) + +(defprotocol Navigable + :extend-via-metadata true + + (nav [coll k v] "return (possibly transformed) v in the context of coll and k (a key/index or nil), +defaults to returning v.")) + +(extend-protocol Navigable + Object (nav [_ _ x] x)) \ No newline at end of file diff --git a/Clojure/Clojure.Source/clojure/core/reducers.clj b/Clojure/Clojure.Source/clojure/core/reducers.clj index db99836e4..b2ae297e8 100644 --- a/Clojure/Clojure.Source/clojure/core/reducers.clj +++ b/Clojure/Clojure.Source/clojure/core/reducers.clj @@ -170,13 +170,13 @@ [f coll] (folder coll (fn [f1] - (let [f1 (fn - ([ret v] - (let [x (f1 ret v)] (if (reduced? x) (reduced x) x))) - ([ret k v] - (let [x (f1 ret k v)] (if (reduced? x) (reduced x) x))))] - (rfn [f1 k] - ([ret k v] + (let [f1 (fn + ([ret v] + (let [x (f1 ret v)] (if (reduced? x) (reduced x) x))) + ([ret k v] + (let [x (f1 ret k v)] (if (reduced? x) (reduced x) x))))] + (rfn [f1 k] + ([ret k v] (reduce f1 ret (f k v)))))))) (defcurried filter diff --git a/Clojure/Clojure.Source/clojure/core/server.clj b/Clojure/Clojure.Source/clojure/core/server.clj index 4d620baf0..7001b980c 100644 --- a/Clojure/Clojure.Source/clojure/core/server.clj +++ b/Clojure/Clojure.Source/clojure/core/server.clj @@ -12,10 +12,10 @@ (:require [clojure.string :as str] [clojure.edn :as edn] [clojure.main :as m]) - (:import - [clojure.lang LineNumberingTextReader] ;;; LineNumberingPushbackReader - [System.Net.Sockets Socket SocketException TcpListener TcpClient] ;;; [java.net InetAddress Socket ServerSocket SocketException] - [System.IO StreamReader StreamWriter TextReader] ;;; [java.io Reader Writer PrintWriter BufferedWriter BufferedReader InputStreamReader OutputStreamWriter] + (:import + [clojure.lang LineNumberingTextReader] ;;; LineNumberingPushbackReader + [System.Net.Sockets Socket SocketException TcpListener TcpClient] ;;; [java.net InetAddress Socket ServerSocket SocketException] + [System.IO StreamReader StreamWriter TextReader] ;;; [java.io Reader Writer PrintWriter BufferedWriter BufferedReader InputStreamReader OutputStreamWriter] [System.Net Dns IPAddress])) ;;; [java.util.concurrent.locks ReentrantLock] (set! *warn-on-reflection* true) @@ -26,14 +26,14 @@ (defonce ^:private lock (Object.)) ;;; ReentrantLock. -- no CLR equivalent (defonce ^:private servers {}) -(defmacro ^:private with-lock - [lock-expr & body] - `(let [lockee# ~lock-expr] ;;; ~(with-meta lock-expr {:tag 'java.util.concurrent.locks.ReentrantLock}) - (monitor-enter lockee#) ;;; (.lock lockee#) - (try - ~@body - (finally - (monitor-exit lockee#))))) ;;; (.unlock lockee#) +(defmacro ^:private with-lock + [lock-expr & body] + `(let [lockee# ~lock-expr] ;;; ~(with-meta lock-expr {:tag 'java.util.concurrent.locks.ReentrantLock}) + (monitor-enter lockee#) ;;; (.lock lockee#) + (try + ~@body + (finally + (monitor-exit lockee#))))) ;;; (.unlock lockee#) (defmacro ^:private thread [^String name daemon & body] @@ -177,9 +177,9 @@ :repl/quit request-exit input)))) -(defn- ex->data - [ex phase] - (assoc (Throwable->map ex) :phase phase)) +(defn- ex->data + [ex phase] + (assoc (Throwable->map ex) :phase phase)) (defn repl "REPL with predefined hooks for attachable socket server." @@ -188,151 +188,151 @@ :init repl-init :read repl-read)) -(defn prepl - "a REPL with structured output (for programs) - reads forms to eval from in-reader (a LineNumberingPushbackReader) - Closing the input or passing the form :repl/quit will cause it to return - - Calls out-fn with data, one of: - {:tag :ret - :val val ;;eval result, or Throwable->map data if exception thrown - :ns ns-name-string - :ms long ;;eval time in milliseconds - :form string ;;iff successfully read - :exception true ;;iff exception thrown - } - {:tag :out - :val string} ;chars from during-eval *out* - {:tag :err - :val string} ;chars from during-eval *err* - {:tag :tap - :val val} ;values from tap> - - You might get more than one :out or :err per eval, but exactly one :ret - tap output can happen at any time (i.e. between evals) - If during eval an attempt is made to read *in* it will read from in-reader unless :stdin is supplied - - Alpha, subject to change." - {:added "1.10"} - [in-reader out-fn & {:keys [stdin]}] - (let [EOF (Object.) - tapfn #(out-fn {:tag :tap :val %1})] - (m/with-bindings - (in-ns 'user) - (binding [*in* (or stdin in-reader) - *out* (PrintWriter-on #(out-fn {:tag :out :val %1}) nil) - *err* (PrintWriter-on #(out-fn {:tag :err :val %1}) nil)] - (try - (add-tap tapfn) - (loop [] - (when (try - (let [[form s] (read+string {:eof EOF :read-cond :allow} in-reader)] - (try - (when-not (identical? form EOF) - (let [start (clojure.lang.RT/StartStopwatch) ;;; (System/nanoTime) - ret (eval form) - ms (clojure.lang.RT/StopStopwatch)] ;;; (quot (- (System/nanoTime) start) 1000000) - (when-not (= :repl/quit ret) - (set! *3 *2) - (set! *2 *1) - (set! *1 ret) - (out-fn {:tag :ret - :val (if (instance? Exception ret) ;;; Throwable - (Throwable->map ret) - ret) - :ns (str (.Name *ns*)) ;;; .name - :ms ms - :form s}) - true))) - (catch Exception ex ;;; Throwable - (set! *e ex) - (out-fn {:tag :ret :val (ex->data ex (or (-> ex ex-data :clojure.error/phase) :execution)) - :ns (str (.Name *ns*)) :form s ;;; .name - :exception true}) - true))) - (catch Exception ex ;;; Throwable - (set! *e ex) - (out-fn {:tag :ret :val (ex->data ex :read-source) - :ns (str (.Name *ns*)) ;;; .name - :exception true}) - true)) - (recur))) - (finally - (remove-tap tapfn))))))) - - (defn- resolve-fn [valf] - (if (symbol? valf) - (or (resolve valf) - (when-let [nsname (namespace valf)] - (require (symbol nsname)) - (resolve valf)) - (throw (Exception. (str "can't resolve: " valf)))) - valf)) - - (defn io-prepl - "prepl bound to *in* and *out*, suitable for use with e.g. server/repl (socket-repl). - :ret and :tap vals will be processed by valf, a fn of one argument - or a symbol naming same (default pr-str) - - Alpha, subject to change." - {:added "1.10"} - [& {:keys [valf] :or {valf pr-str}}] - (let [valf (resolve-fn valf) - out *out* - lock (Object.)] - (prepl *in* - (fn [m] - (binding [*out* out, *flush-on-newline* true, *print-readably* true] - (locking lock - (prn (if (#{:ret :tap} (:tag m)) - (try - (assoc m :val (valf (:val m))) - (catch Exception ex ;;; Throwable - (assoc m :val (valf (ex->data ex :print-eval-result)) - :exception true))) - m)))))))) - - (defn remote-prepl - "Implements a prepl on in-reader and out-fn by forwarding to a - remote [io-]prepl over a socket. Messages will be read by readf, a - fn of a LineNumberingPushbackReader and EOF value or a symbol naming - same (default #(read %1 false %2)), - :ret and :tap vals will be processed by valf, a fn of one argument - or a symbol naming same (default read-string). If that function - throws, :val will be unprocessed. - - Alpha, subject to change." - {:added "1.10"} - [^String host port ^TextReader ;;; ^Reader - in-reader out-fn & {:keys [valf readf] :or {valf read-string, readf #(read %1 false %2)}}] - (let [valf (resolve-fn valf) - readf (resolve-fn readf) - ^long port (if (string? port) (Int32/Parse ^String port) port) ;;; Integer/valueOf - socket (TcpClient. host port) - rd (-> socket .GetStream StreamReader. LineNumberingTextReader.) ;;; .getInputStream InputStreamReader. BufferedReader. LineNumberingPushbackReader. - wr (-> socket .GetStream StreamWriter.) ;;; .getOutputStream OutputStreamWriter. - EOF (Object.)] - (thread "clojure.core.server/remote-prepl" true - (try (loop [] - (let [{:keys [tag val] :as m} (readf rd EOF)] - (when-not (identical? m EOF) - (out-fn - (if (#{:ret :tap} tag) - (try - (assoc m :val (valf val)) - (catch Exception ex ;;; Throwable - (assoc m :val (ex->data ex :read-eval-result) - :exception true))) - m)) - (recur)))) - (finally - (.Close wr)))) ;;; .close - (let [buf (char-array 1024)] - (try (loop [] - (let [n (.Read in-reader buf 0 1024)] ;;; (.read in-reader buf) - (when-not (= n -1) - (.Write wr buf 0 n) ;;; .write - (.Flush wr) ;;; .flush - (recur)))) - (finally +(defn prepl + "a REPL with structured output (for programs) + reads forms to eval from in-reader (a LineNumberingPushbackReader) + Closing the input or passing the form :repl/quit will cause it to return + + Calls out-fn with data, one of: + {:tag :ret + :val val ;;eval result, or Throwable->map data if exception thrown + :ns ns-name-string + :ms long ;;eval time in milliseconds + :form string ;;iff successfully read + :exception true ;;iff exception thrown + } + {:tag :out + :val string} ;chars from during-eval *out* + {:tag :err + :val string} ;chars from during-eval *err* + {:tag :tap + :val val} ;values from tap> + + You might get more than one :out or :err per eval, but exactly one :ret + tap output can happen at any time (i.e. between evals) + If during eval an attempt is made to read *in* it will read from in-reader unless :stdin is supplied + + Alpha, subject to change." + {:added "1.10"} + [in-reader out-fn & {:keys [stdin]}] + (let [EOF (Object.) + tapfn #(out-fn {:tag :tap :val %1})] + (m/with-bindings + (in-ns 'user) + (binding [*in* (or stdin in-reader) + *out* (PrintWriter-on #(out-fn {:tag :out :val %1}) nil) + *err* (PrintWriter-on #(out-fn {:tag :err :val %1}) nil)] + (try + (add-tap tapfn) + (loop [] + (when (try + (let [[form s] (read+string {:eof EOF :read-cond :allow} in-reader)] + (try + (when-not (identical? form EOF) + (let [start (clojure.lang.RT/StartStopwatch) ;;; (System/nanoTime) + ret (eval form) + ms (clojure.lang.RT/StopStopwatch)] ;;; (quot (- (System/nanoTime) start) 1000000) + (when-not (= :repl/quit ret) + (set! *3 *2) + (set! *2 *1) + (set! *1 ret) + (out-fn {:tag :ret + :val (if (instance? Exception ret) ;;; Throwable + (Throwable->map ret) + ret) + :ns (str (.Name *ns*)) ;;; .name + :ms ms + :form s}) + true))) + (catch Exception ex ;;; Throwable + (set! *e ex) + (out-fn {:tag :ret :val (ex->data ex (or (-> ex ex-data :clojure.error/phase) :execution)) + :ns (str (.Name *ns*)) :form s ;;; .name + :exception true}) + true))) + (catch Exception ex ;;; Throwable + (set! *e ex) + (out-fn {:tag :ret :val (ex->data ex :read-source) + :ns (str (.Name *ns*)) ;;; .name + :exception true}) + true)) + (recur))) + (finally + (remove-tap tapfn))))))) + + (defn- resolve-fn [valf] + (if (symbol? valf) + (or (resolve valf) + (when-let [nsname (namespace valf)] + (require (symbol nsname)) + (resolve valf)) + (throw (Exception. (str "can't resolve: " valf)))) + valf)) + + (defn io-prepl + "prepl bound to *in* and *out*, suitable for use with e.g. server/repl (socket-repl). + :ret and :tap vals will be processed by valf, a fn of one argument + or a symbol naming same (default pr-str) + + Alpha, subject to change." + {:added "1.10"} + [& {:keys [valf] :or {valf pr-str}}] + (let [valf (resolve-fn valf) + out *out* + lock (Object.)] + (prepl *in* + (fn [m] + (binding [*out* out, *flush-on-newline* true, *print-readably* true] + (locking lock + (prn (if (#{:ret :tap} (:tag m)) + (try + (assoc m :val (valf (:val m))) + (catch Exception ex ;;; Throwable + (assoc m :val (valf (ex->data ex :print-eval-result)) + :exception true))) + m)))))))) + + (defn remote-prepl + "Implements a prepl on in-reader and out-fn by forwarding to a + remote [io-]prepl over a socket. Messages will be read by readf, a + fn of a LineNumberingPushbackReader and EOF value or a symbol naming + same (default #(read %1 false %2)), + :ret and :tap vals will be processed by valf, a fn of one argument + or a symbol naming same (default read-string). If that function + throws, :val will be unprocessed. + + Alpha, subject to change." + {:added "1.10"} + [^String host port ^TextReader ;;; ^Reader + in-reader out-fn & {:keys [valf readf] :or {valf read-string, readf #(read %1 false %2)}}] + (let [valf (resolve-fn valf) + readf (resolve-fn readf) + ^long port (if (string? port) (Int32/Parse ^String port) port) ;;; Integer/valueOf + socket (TcpClient. host port) + rd (-> socket .GetStream StreamReader. LineNumberingTextReader.) ;;; .getInputStream InputStreamReader. BufferedReader. LineNumberingPushbackReader. + wr (-> socket .GetStream StreamWriter.) ;;; .getOutputStream OutputStreamWriter. + EOF (Object.)] + (thread "clojure.core.server/remote-prepl" true + (try (loop [] + (let [{:keys [tag val] :as m} (readf rd EOF)] + (when-not (identical? m EOF) + (out-fn + (if (#{:ret :tap} tag) + (try + (assoc m :val (valf val)) + (catch Exception ex ;;; Throwable + (assoc m :val (ex->data ex :read-eval-result) + :exception true))) + m)) + (recur)))) + (finally + (.Close wr)))) ;;; .close + (let [buf (char-array 1024)] + (try (loop [] + (let [n (.Read in-reader buf 0 1024)] ;;; (.read in-reader buf) + (when-not (= n -1) + (.Write wr buf 0 n) ;;; .write + (.Flush wr) ;;; .flush + (recur)))) + (finally (.Close rd)))))) ;;; .close \ No newline at end of file diff --git a/Clojure/Clojure.Source/clojure/core_clr.clj b/Clojure/Clojure.Source/clojure/core_clr.clj index 9a4cad908..0ef606617 100644 --- a/Clojure/Clojure.Source/clojure/core_clr.clj +++ b/Clojure/Clojure.Source/clojure/core_clr.clj @@ -1,18 +1,18 @@ -; 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 - -(in-ns 'clojure.core) - -;;;;;; Extensions to core for the CLR platform ;;;;;;; - - +; 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 + +(in-ns 'clojure.core) + +;;;;;; Extensions to core for the CLR platform ;;;;;;; + + (defmacro gen-delegate [type argVec & body] @@ -22,328 +22,328 @@ ;;; Additional numeric casts ;;; Somewhat useless until our arithmetic package is extended to support all these types. -(defn uint - "Coerce to uint" - {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedUIntCast 'uintCast) ~x))) - :added "1.0"} - [x] (. clojure.lang.RT (uintCast x))) - -(defn ushort - "Coerce to ushort" - {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedUShortCast 'ushortCast) ~x))) - :added "1.0"} - [x] (. clojure.lang.RT (ushortCast x))) - -(defn ulong - "Coerce to ulong" - {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedULongCast 'ulongCast) ~x))) - :added "1.0"} - [x] (. clojure.lang.RT (ulongCast x))) - -(defn decimal - "Coerce to decimal" - {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedDecimalCast 'decimalCast) ~x))) - :added "1.0"} - [x] (. clojure.lang.RT (decimalCast x))) - -(defn sbyte - "Coerce to sbyte" - {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedSByteCast 'sbyteCast) ~x))) - :added "1.0"} - [x] (. clojure.lang.RT (sbyteCast x))) - -;;; Additional aset-XXX variants - -(def-aset - ^{:doc "Sets the value at the index/indices. Works on arrays of uint. Returns val." - :added "1.0"} - aset-uint setUInt uint) - -(def-aset - ^{:doc "Sets the value at the index/indices. Works on arrays of ushort. Returns val." - :added "1.0"} - aset-ushort setUShort ushort) - -(def-aset - ^{:doc "Sets the value at the index/indices. Works on arrays of ulong. Returns val." - :added "1.0"} - aset-ulong setULong ulong) - -(def-aset - ^{:doc "Sets the value at the index/indices. Works on arrays of decimal. Returns val." - :added "1.0"} - aset-decimal setDecimal decimal) - -(def-aset - ^{:doc "Sets the value at the index/indices. Works on arrays of sbyte. Returns val." - :added "1.0"} - aset-sbyte setSByte sbyte) - -;; Addtional array types - -(defn uint-array - "Creates an array of uints" - {:inline (fn [& args] `(. clojure.lang.Numbers uint_array ~@args)) - :inline-arities #{1 2} - :added "1.5"} - ([size-or-seq] (. clojure.lang.Numbers uint_array size-or-seq)) - ([size init-val-or-seq] (. clojure.lang.Numbers uint_array size init-val-or-seq))) - -(defn ushort-array - "Creates an array of ushorts" - {:inline (fn [& args] `(. clojure.lang.Numbers ushort_array ~@args)) - :inline-arities #{1 2} - :added "1.5"} - ([size-or-seq] (. clojure.lang.Numbers ushort_array size-or-seq)) - ([size init-val-or-seq] (. clojure.lang.Numbers ushort_array size init-val-or-seq))) - -(defn ulong-array - "Creates an array of ulongs" - {:inline (fn [& args] `(. clojure.lang.Numbers ulong_array ~@args)) - :inline-arities #{1 2} - :added "1.5"} - ([size-or-seq] (. clojure.lang.Numbers ulong_array size-or-seq)) - ([size init-val-or-seq] (. clojure.lang.Numbers ulong_array size init-val-or-seq))) - -(defn sbyte-array - "Creates an array of sbytes" - {:inline (fn [& args] `(. clojure.lang.Numbers sbyte_array ~@args)) - :inline-arities #{1 2} - :added "1.5"} - ([size-or-seq] (. clojure.lang.Numbers sbyte_array size-or-seq)) - ([size init-val-or-seq] (. clojure.lang.Numbers sbyte_array size init-val-or-seq))) - - -; Support for enums - -(defn enum-val [t n] - "Gets a value from an enum from the name" - {:added "1.0"} - (let [s (if (string? n) n (name n))] - (Enum/Parse t s))) - -(defn enum-or - "Combine via or several enum (flag values). Coerced to type of first value." - {:added "1.3"} +(defn uint + "Coerce to uint" + {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedUIntCast 'uintCast) ~x))) + :added "1.0"} + [x] (. clojure.lang.RT (uintCast x))) + +(defn ushort + "Coerce to ushort" + {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedUShortCast 'ushortCast) ~x))) + :added "1.0"} + [x] (. clojure.lang.RT (ushortCast x))) + +(defn ulong + "Coerce to ulong" + {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedULongCast 'ulongCast) ~x))) + :added "1.0"} + [x] (. clojure.lang.RT (ulongCast x))) + +(defn decimal + "Coerce to decimal" + {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedDecimalCast 'decimalCast) ~x))) + :added "1.0"} + [x] (. clojure.lang.RT (decimalCast x))) + +(defn sbyte + "Coerce to sbyte" + {:inline (fn [x] `(. clojure.lang.RT (~(if *unchecked-math* 'uncheckedSByteCast 'sbyteCast) ~x))) + :added "1.0"} + [x] (. clojure.lang.RT (sbyteCast x))) + +;;; Additional aset-XXX variants + +(def-aset + ^{:doc "Sets the value at the index/indices. Works on arrays of uint. Returns val." + :added "1.0"} + aset-uint setUInt uint) + +(def-aset + ^{:doc "Sets the value at the index/indices. Works on arrays of ushort. Returns val." + :added "1.0"} + aset-ushort setUShort ushort) + +(def-aset + ^{:doc "Sets the value at the index/indices. Works on arrays of ulong. Returns val." + :added "1.0"} + aset-ulong setULong ulong) + +(def-aset + ^{:doc "Sets the value at the index/indices. Works on arrays of decimal. Returns val." + :added "1.0"} + aset-decimal setDecimal decimal) + +(def-aset + ^{:doc "Sets the value at the index/indices. Works on arrays of sbyte. Returns val." + :added "1.0"} + aset-sbyte setSByte sbyte) + +;; Addtional array types + +(defn uint-array + "Creates an array of uints" + {:inline (fn [& args] `(. clojure.lang.Numbers uint_array ~@args)) + :inline-arities #{1 2} + :added "1.5"} + ([size-or-seq] (. clojure.lang.Numbers uint_array size-or-seq)) + ([size init-val-or-seq] (. clojure.lang.Numbers uint_array size init-val-or-seq))) + +(defn ushort-array + "Creates an array of ushorts" + {:inline (fn [& args] `(. clojure.lang.Numbers ushort_array ~@args)) + :inline-arities #{1 2} + :added "1.5"} + ([size-or-seq] (. clojure.lang.Numbers ushort_array size-or-seq)) + ([size init-val-or-seq] (. clojure.lang.Numbers ushort_array size init-val-or-seq))) + +(defn ulong-array + "Creates an array of ulongs" + {:inline (fn [& args] `(. clojure.lang.Numbers ulong_array ~@args)) + :inline-arities #{1 2} + :added "1.5"} + ([size-or-seq] (. clojure.lang.Numbers ulong_array size-or-seq)) + ([size init-val-or-seq] (. clojure.lang.Numbers ulong_array size init-val-or-seq))) + +(defn sbyte-array + "Creates an array of sbytes" + {:inline (fn [& args] `(. clojure.lang.Numbers sbyte_array ~@args)) + :inline-arities #{1 2} + :added "1.5"} + ([size-or-seq] (. clojure.lang.Numbers sbyte_array size-or-seq)) + ([size init-val-or-seq] (. clojure.lang.Numbers sbyte_array size init-val-or-seq))) + + +; Support for enums + +(defn enum-val [t n] + "Gets a value from an enum from the name" + {:added "1.0"} + (let [s (if (string? n) n (name n))] + (Enum/Parse t s))) + +(defn enum-or + "Combine via or several enum (flag values). Coerced to type of first value." + {:added "1.3"} [flag & flags] (Enum/ToObject (class flag) (reduce1 #(bit-or (long %1) (long %2)) flag flags))) - -(defn enum-and - "Combine via and several enum (flag values). Coerced to type of first value." - {:added "1.3"} + +(defn enum-and + "Combine via and several enum (flag values). Coerced to type of first value." + {:added "1.3"} [flag & flags] - (Enum/ToObject (class flag) (reduce1 #(bit-and (long %1) (long %2)) flag flags))) - -; Support for interop - -(defn by-ref - "Signals that a by-ref parameter is desired at this position in an interop call or method signature. - - Should only be used in CLR interop code. Throws an exception otherwise." - {:added "1.2"} - [v] (throw (ArgumentException. "by-ref not used at top-level in an interop call or method signature"))) - -(defn type-args - "Supplies type arguments to a generic method interop call. - - Should only be used in CLR interop code. Throws an exception otherwise. - - Usage: - - (.ClrMethod ^T1 obj (type-args T2) 4 5) is equivalant to C#: ((T1)obj).ClrMethod(4,5) - - Can also be used with static methods: - - (Enumerable/Repeat (type-args Int32) 2 5)" - {:added "1.3"} - [v] (throw (ArgumentException. "type-args not used in interop call"))) - -(defn- str-join ;; clojure.string not yet loaded - [coll] - (loop [sb (StringBuilder. (str (first coll))) - more (next coll)] - (if more - (recur (-> sb (.Append ",") (.Append (str (first more)))) - (next more)) - (str sb)))) - -(defn- generate-generic-delegate - [typename typesyms body] - (let [types (map (fn [tsym] (clojure.lang.CljCompiler.Ast.HostExpr/MaybeType tsym false)) typesyms) - ftype (symbol (str typename "`" (count types) "[" (str-join types) "]"))] - `(gen-delegate ~ftype ~@body))) - -(defmacro sys-func - "Translates to a gen-delegate for a System.Func<,...> call" - {:added "1.3"} - [typesyms & body] - (generate-generic-delegate "System.Func" typesyms body)) - -(defmacro sys-action - "Translates to a gen-delegate for a System.Action<,...> call" - {:added "1.3"} - [typesyms & body] - (generate-generic-delegate "System.Action" typesyms body)) - - -; Attribute handling - -(defn enum? [v] - (instance? Enum v)) - -(defn array? [v] - (instance? Array v)) - -(defn- is-attribute? [c] - (and (class? c) - (.IsAssignableFrom System.Attribute c))) - -(defn- attribute-filter [[k v]] - (when (symbol? k) - (when-let [c (resolve k)] - (is-attribute? c)))) - - -; Note: we are not handling the non-CLS-compliant case of a one-dimensional array of arg values -- yet. -; -; Most often attributes will be attached to classes, methods, etc. via metadata. -; The key will be an class derived from System.Attribute. -; The value will be arguments to the constructor and/or property setters. -; We wish to simplify the syntax for the most common (simplest) cases. -; We have to accommodate: -; positional arguments to pass to constructors -; property/value pairs -; multiple values for an attribute -; The _normalized form_ for an attribute argument is: -; -; #{ init1 init2 ... } -; -; where an is a hash with keys representing property names (and case is important). -; The special key :__args will have as a value a vector of arguments that are passed to the constructor for the attribute class. -; -; The surface synax (the value for the metadata allows the following simplifications: -; -; A set implies multiple values. Each element of the set will be processed to create a standardarized init. -; A vector implies just c-tor args. -; A map will be passed through -; Any other value implies a single argument to a constructor. -; -; System.Serializable {} => System.Serializable #{ {} } => call no-arg c-tor -; -; Assuming we have imported FileIOPermission and SecurityAction from System.Security.Permissions: -; -; FileIOPermission SecurityAction/Demand => FileIOPermission #{ {:__args [SecurityAction/Demand]} } => new FileIOPermission(SecurityAction/Demand) -; -; FileIOPermission #{ SecurityAction/Demand SecurityAction/Deny } -; ==> FileIOPermission #{ {:__args [SecurityAction/Demand]} {:__args [SecurityAction/Deny]} -; ==> new FileIOPermission(SecurityAction/Demand) + new FileIOPermission(SecurityAction/Demand) (multiple values for this attribute) -; -; FileIOPermission #{ SecurityAction/Demand { :__args [SecurityAction/Deny] :Read "abc" } } -; ==> FileIOPermission #{ {:__args [SecurityAction/Demand]} {:__args [SecurityAction/Deny] :Read "abc"} -; ==> new FileIOPermission(SecurityAction/Demand) -; let x = new FileIOPermission(SecurityAction/Demand) + x.Read = "abc" -; (multiple values for this attribute, second has ctor call + property set) -; -; Note that symbols are eval. They must evaluate to either values of enums or to types. - - -(defn- normalize-attribute-arg-value [v] - (cond - (symbol? v) (let [ev (eval v)] - (cond - (enum? ev) ev - (class? ev) ev - :else (throw (ArgumentException. (str "Unsupported attribute argument value: " v " of class " (class ev)))))) - (vector? v) (into1 [] (map normalize-attribute-arg-value v)) - (map? v) (into1 {} (map (fn [[k v]] [k (normalize-attribute-arg-value v)]) v)) - :else v)) - -(defn- normalize-attribute-init [init] - (cond - (vector? init) { :__args (map normalize-attribute-arg-value init) } - (map? init) (into1 {} (map (fn [[k v]] [k (normalize-attribute-arg-value v)]) init)) - :else { :__args [ (normalize-attribute-arg-value init) ] } )) - -(defn- normalize-attribute-arg [arg] - (if (set? arg) - (into1 #{} (map normalize-attribute-init arg)) - #{ (normalize-attribute-init arg) })) - -(defn- resolve-attribute [v] - (cond - (is-attribute? v) v - (symbol? v) (when-let [c (resolve v)] - (when (is-attribute? c) - c)) - :else nil)) - - -(defn- extract-attributes [m] - (into1 {} - (remove nil? - (for [[k v] (seq m)] - (when-let [c (resolve-attribute k)] - [ c (normalize-attribute-arg v) ]))))) - - - -;; assembly loading helpers - -(defn assembly-load - "Load an assembly given its name" - {:added "1.3"} - [^String assembly-name] - (System.Reflection.Assembly/Load assembly-name)) - -(defn assembly-load-from - "Load an assembly given its path" - {:added "1.3"} - [^String assembly-name] - (System.Reflection.Assembly/LoadFrom assembly-name)) - -(defn assembly-load-file - "Load an assembly given its name" - {:added "1.3"} - [^String assembly-name] - (System.Reflection.Assembly/LoadFile assembly-name)) - -(defn assembly-load-with-partial-name - "Load an assembly given a partial name" - {:added "1.4"} - [^String assembly-name] - (System.Reflection.Assembly/LoadWithPartialName assembly-name)) - -(defn add-ns-load-mapping - "Convenience function to assist with loading .clj files embedded in - C# projects. ns-root specifies part of a namespace such as MyNamespace.A and - fs-root specifies the filesystem location in which to look for files within that - namespace. For example, if MyNamespace.A mapped to MyNsA would allow - MyNamespace.A.B to be loaded from MyNsA\\B.clj. When a .clj file is marked as an - embedded resource in a C# project, it will be stored in the resulting .dll with - the default project namespace prefixed to its path. To allow these files to - be loaded dynamically during development, the paths to these files can be mapped - to allow them to be loaded from a different directory other than their root namespace - (i.e. the common case where the project directory is different from its default - namespace)." - {:added "1.5"} - [^String ns-root ^String fs-root] - (swap! *ns-load-mappings* conj - [(.Replace ns-root "." "/") fs-root])) - - -;; Framework version -- alpha - -(def framework-description (System.Runtime.InteropServices.RuntimeInformation/FrameworkDescription)) - -(defn- parse-framework-description [] - (let [descr framework-description - prefixes '(( ".NET Framework " :framework) (".NET Native " :native) (".NET Core " :core) (".NET " :dotnet)) - try-parse (fn [[^String s k]] (when (.StartsWith descr s) [k (.Substring descr (.Length s))]))] - (some try-parse prefixes))) - -(def dotnet-platform (first (parse-framework-description))) -(def dotnet-version (second (parse-framework-description))) - + (Enum/ToObject (class flag) (reduce1 #(bit-and (long %1) (long %2)) flag flags))) + +; Support for interop + +(defn by-ref + "Signals that a by-ref parameter is desired at this position in an interop call or method signature. + + Should only be used in CLR interop code. Throws an exception otherwise." + {:added "1.2"} + [v] (throw (ArgumentException. "by-ref not used at top-level in an interop call or method signature"))) + +(defn type-args + "Supplies type arguments to a generic method interop call. + + Should only be used in CLR interop code. Throws an exception otherwise. + + Usage: + + (.ClrMethod ^T1 obj (type-args T2) 4 5) is equivalant to C#: ((T1)obj).ClrMethod(4,5) + + Can also be used with static methods: + + (Enumerable/Repeat (type-args Int32) 2 5)" + {:added "1.3"} + [v] (throw (ArgumentException. "type-args not used in interop call"))) + +(defn- str-join ;; clojure.string not yet loaded + [coll] + (loop [sb (StringBuilder. (str (first coll))) + more (next coll)] + (if more + (recur (-> sb (.Append ",") (.Append (str (first more)))) + (next more)) + (str sb)))) + +(defn- generate-generic-delegate + [typename typesyms body] + (let [types (map (fn [tsym] (clojure.lang.CljCompiler.Ast.HostExpr/MaybeType tsym false)) typesyms) + ftype (symbol (str typename "`" (count types) "[" (str-join types) "]"))] + `(gen-delegate ~ftype ~@body))) + +(defmacro sys-func + "Translates to a gen-delegate for a System.Func<,...> call" + {:added "1.3"} + [typesyms & body] + (generate-generic-delegate "System.Func" typesyms body)) + +(defmacro sys-action + "Translates to a gen-delegate for a System.Action<,...> call" + {:added "1.3"} + [typesyms & body] + (generate-generic-delegate "System.Action" typesyms body)) + + +; Attribute handling + +(defn enum? [v] + (instance? Enum v)) + +(defn array? [v] + (instance? Array v)) + +(defn- is-attribute? [c] + (and (class? c) + (.IsAssignableFrom System.Attribute c))) + +(defn- attribute-filter [[k v]] + (when (symbol? k) + (when-let [c (resolve k)] + (is-attribute? c)))) + + +; Note: we are not handling the non-CLS-compliant case of a one-dimensional array of arg values -- yet. +; +; Most often attributes will be attached to classes, methods, etc. via metadata. +; The key will be an class derived from System.Attribute. +; The value will be arguments to the constructor and/or property setters. +; We wish to simplify the syntax for the most common (simplest) cases. +; We have to accommodate: +; positional arguments to pass to constructors +; property/value pairs +; multiple values for an attribute +; The _normalized form_ for an attribute argument is: +; +; #{ init1 init2 ... } +; +; where an is a hash with keys representing property names (and case is important). +; The special key :__args will have as a value a vector of arguments that are passed to the constructor for the attribute class. +; +; The surface synax (the value for the metadata allows the following simplifications: +; +; A set implies multiple values. Each element of the set will be processed to create a standardarized init. +; A vector implies just c-tor args. +; A map will be passed through +; Any other value implies a single argument to a constructor. +; +; System.Serializable {} => System.Serializable #{ {} } => call no-arg c-tor +; +; Assuming we have imported FileIOPermission and SecurityAction from System.Security.Permissions: +; +; FileIOPermission SecurityAction/Demand => FileIOPermission #{ {:__args [SecurityAction/Demand]} } => new FileIOPermission(SecurityAction/Demand) +; +; FileIOPermission #{ SecurityAction/Demand SecurityAction/Deny } +; ==> FileIOPermission #{ {:__args [SecurityAction/Demand]} {:__args [SecurityAction/Deny]} +; ==> new FileIOPermission(SecurityAction/Demand) + new FileIOPermission(SecurityAction/Demand) (multiple values for this attribute) +; +; FileIOPermission #{ SecurityAction/Demand { :__args [SecurityAction/Deny] :Read "abc" } } +; ==> FileIOPermission #{ {:__args [SecurityAction/Demand]} {:__args [SecurityAction/Deny] :Read "abc"} +; ==> new FileIOPermission(SecurityAction/Demand) +; let x = new FileIOPermission(SecurityAction/Demand) + x.Read = "abc" +; (multiple values for this attribute, second has ctor call + property set) +; +; Note that symbols are eval. They must evaluate to either values of enums or to types. + + +(defn- normalize-attribute-arg-value [v] + (cond + (symbol? v) (let [ev (eval v)] + (cond + (enum? ev) ev + (class? ev) ev + :else (throw (ArgumentException. (str "Unsupported attribute argument value: " v " of class " (class ev)))))) + (vector? v) (into1 [] (map normalize-attribute-arg-value v)) + (map? v) (into1 {} (map (fn [[k v]] [k (normalize-attribute-arg-value v)]) v)) + :else v)) + +(defn- normalize-attribute-init [init] + (cond + (vector? init) { :__args (map normalize-attribute-arg-value init) } + (map? init) (into1 {} (map (fn [[k v]] [k (normalize-attribute-arg-value v)]) init)) + :else { :__args [ (normalize-attribute-arg-value init) ] } )) + +(defn- normalize-attribute-arg [arg] + (if (set? arg) + (into1 #{} (map normalize-attribute-init arg)) + #{ (normalize-attribute-init arg) })) + +(defn- resolve-attribute [v] + (cond + (is-attribute? v) v + (symbol? v) (when-let [c (resolve v)] + (when (is-attribute? c) + c)) + :else nil)) + + +(defn- extract-attributes [m] + (into1 {} + (remove nil? + (for [[k v] (seq m)] + (when-let [c (resolve-attribute k)] + [ c (normalize-attribute-arg v) ]))))) + + + +;; assembly loading helpers + +(defn assembly-load + "Load an assembly given its name" + {:added "1.3"} + [^String assembly-name] + (System.Reflection.Assembly/Load assembly-name)) + +(defn assembly-load-from + "Load an assembly given its path" + {:added "1.3"} + [^String assembly-name] + (System.Reflection.Assembly/LoadFrom assembly-name)) + +(defn assembly-load-file + "Load an assembly given its name" + {:added "1.3"} + [^String assembly-name] + (System.Reflection.Assembly/LoadFile assembly-name)) + +(defn assembly-load-with-partial-name + "Load an assembly given a partial name" + {:added "1.4"} + [^String assembly-name] + (System.Reflection.Assembly/LoadWithPartialName assembly-name)) + +(defn add-ns-load-mapping + "Convenience function to assist with loading .clj files embedded in + C# projects. ns-root specifies part of a namespace such as MyNamespace.A and + fs-root specifies the filesystem location in which to look for files within that + namespace. For example, if MyNamespace.A mapped to MyNsA would allow + MyNamespace.A.B to be loaded from MyNsA\\B.clj. When a .clj file is marked as an + embedded resource in a C# project, it will be stored in the resulting .dll with + the default project namespace prefixed to its path. To allow these files to + be loaded dynamically during development, the paths to these files can be mapped + to allow them to be loaded from a different directory other than their root namespace + (i.e. the common case where the project directory is different from its default + namespace)." + {:added "1.5"} + [^String ns-root ^String fs-root] + (swap! *ns-load-mappings* conj + [(.Replace ns-root "." "/") fs-root])) + + +;; Framework version -- alpha + +(def framework-description (System.Runtime.InteropServices.RuntimeInformation/FrameworkDescription)) + +(defn- parse-framework-description [] + (let [descr framework-description + prefixes '(( ".NET Framework " :framework) (".NET Native " :native) (".NET Core " :core) (".NET " :dotnet)) + try-parse (fn [[^String s k]] (when (.StartsWith descr s) [k (.Substring descr (.Length s))]))] + (some try-parse prefixes))) + +(def dotnet-platform (first (parse-framework-description))) +(def dotnet-version (second (parse-framework-description))) + (defmacro compile-when {:added "1.11"} [exp & body] diff --git a/Clojure/Clojure.Source/clojure/core_deftype.clj b/Clojure/Clojure.Source/clojure/core_deftype.clj index 1640adf3b..9f25531a3 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,15 +60,15 @@ 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 :load-ns} (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 :load-ns} (keys opts)))] (throw (ArgumentException. (apply print-str "Unsupported option(s) -" bad-opts)))) ;;; IllegalArgumentException [interfaces methods opts])) -(defmacro reify - "reify creates an object implementing a protocol or interface. +(defmacro reify + "reify creates an object implementing a protocol or interface. reify is a macro with the following structure: (reify options* specs*) @@ -83,11 +83,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, @@ -112,12 +112,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] @@ -130,32 +130,32 @@ (defn munge [s] ((if (symbol? s) symbol str) (clojure.lang.Compiler/munge (str s)))) -(defn- imap-cons - [^clojure.lang.IPersistentMap this o] - (cond - (map-entry? 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 [^System.Collections.DictionaryEntry pair o] ;;; DM: Added - (.assoc this (.Key pair) (.Value pair))) ;;; DM: Added - (instance? |System.Collections.Generic.KeyValuePair`2[System.Object,System.Object]| o) ;;; DM: Added - (let [^|System.Collections.Generic.KeyValuePair`2[System.Object,System.Object]| 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 + (map-entry? 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 [^System.Collections.DictionaryEntry pair o] ;;; DM: Added + (.assoc this (.Key pair) (.Value pair))) ;;; DM: Added + (instance? |System.Collections.Generic.KeyValuePair`2[System.Object,System.Object]| o) ;;; DM: Added + (let [^|System.Collections.Generic.KeyValuePair`2[System.Object,System.Object]| 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" {:added "1.2"} - [tagname cname fields interfaces methods opts] + [tagname cname fields interfaces methods opts] (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." cname)) (meta cname)) interfaces (vec interfaces) interface-set (set (map resolve interfaces)) @@ -163,195 +163,195 @@ hinted-fields fields fields (vec (map #(with-meta % nil) fields)) base-fields fields - fields (conj fields '__meta '__extmap - '^:unsynchronized-mutable __hash + fields (conj fields '__meta '__extmap + '^:unsynchronized-mutable __hash '^:unsynchronized-mutable __hasheq) 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#] (let [hq# ~'__hasheq] - (if (zero? hq#) - (let [h# (int (bit-xor ~type-hash (clojure.lang.APersistentMap/mapHasheq this#)))] - (set! ~'__hasheq h#) - h#) - hq#))) - `(GetHashCode [this#] (let [hash# ~'__hash] ;;; hashCode - (if (zero? hash#) - (let [h# (clojure.lang.APersistentMap/mapHash this#)] - (set! ~'__hash h#) - h#) - hash#))) - `(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#] (let [hq# ~'__hasheq] + (if (zero? hq#) + (let [h# (int (bit-xor ~type-hash (clojure.lang.APersistentMap/mapHasheq this#)))] + (set! ~'__hasheq h#) + h#) + hq#))) + `(GetHashCode [this#] (let [hash# ~'__hash] ;;; hashCode + (if (zero? hash#) + (let [h# (clojure.lang.APersistentMap/mapHash this#)] + (set! ~'__hash h#) + h#) + hash#))) + `(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 (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 (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 ~(with-meta gs {:tag tagname}) ] - (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/create k# v#)))) - `(seq [this#] (seq (concat [~@(map #(list `clojure.lang.MapEntry/create (keyword %) %) base-fields)] - ~'__extmap))) - `(|System.Collections.Generic.IEnumerable`1[clojure.lang.IMapEntry]|.GetEnumerator [this#] (.GetEnumerator (clojure.lang.RecordEnumerable. this# [~@(map keyword base-fields)] (clojure.lang.RT/iter ~'__extmap)))) - `(^clojure.lang.IPersistentMap assoc [this# k# ~gs] ;;; type hint added - (condp identical? k# - ~@(mapcat (fn [fld] - [(keyword fld) (list* `new tagname (replace {fld gs} (remove '#{__hash __hasheq} fields)))]) - base-fields) - (new ~tagname ~@(remove '#{__extmap __hash __hasheq} fields) (assoc ~'__extmap k# ~gs)))) - `(^clojure.lang.IPersistentMap assocEx [this# k# v#] ;;; ADDED - (if (.containsKey this# 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 __hash __hasheq} 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#] (.GetEnumerator (clojure.lang.RecordEnumerable. this# [~@(map keyword base-fields)] (clojure.lang.RT/iter ~'__extmap)))) - )]) - (cntd [[i m]] ;;; ADDED - [(conj i 'clojure.lang.Counted) ;;; ADDED - (conj m ;;; ADDED - `(clojure.lang.Counted.count [this#] (+ ~(count base-fields) (count ~'__extmap))))]) ;;; ADDED - (ipc [[i m]] ;;; ADDED - [(conj i 'clojure.lang.IPersistentCollection) ;;; ADDED - (conj m ;;; ADDED - `(clojure.lang.IPersistentCollection.cons [this# e#] ;;; ADDED - ((var imap-cons) this# e#)) ;;; ADDED - `(clojure.lang.IPersistentCollection.count [this#] (+ ~(count base-fields) (count ~'__extmap))))]) ;;; ADDED - (associative ;;; ADDED - [[i m]] ;;; ADDED - [(conj i 'clojure.lang.Associative) ;;; ADDED - (conj m ;;; ADDED - `(clojure.lang.Associative.assoc [this# k# ~gs] ;;; ADDED - (condp identical? k# ;;; ADDED - ~@(mapcat (fn [fld] ;;; ADDED - [(keyword fld) (list* `new tagname (replace {fld gs} (remove '#{__hash __hasheq} fields)))]) ;;; ADDED - base-fields) ;;; ADDED - (new ~tagname ~@(remove '#{__extmap __hash __hasheq} 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 ~(with-meta gs {:tag tagname}) ] + (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/create k# v#)))) + `(seq [this#] (seq (concat [~@(map #(list `clojure.lang.MapEntry/create (keyword %) %) base-fields)] + ~'__extmap))) + `(|System.Collections.Generic.IEnumerable`1[clojure.lang.IMapEntry]|.GetEnumerator [this#] (.GetEnumerator (clojure.lang.RecordEnumerable. this# [~@(map keyword base-fields)] (clojure.lang.RT/iter ~'__extmap)))) + `(^clojure.lang.IPersistentMap assoc [this# k# ~gs] ;;; type hint added + (condp identical? k# + ~@(mapcat (fn [fld] + [(keyword fld) (list* `new tagname (replace {fld gs} (remove '#{__hash __hasheq} fields)))]) + base-fields) + (new ~tagname ~@(remove '#{__extmap __hash __hasheq} fields) (assoc ~'__extmap k# ~gs)))) + `(^clojure.lang.IPersistentMap assocEx [this# k# v#] ;;; ADDED + (if (.containsKey this# 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 __hash __hasheq} 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#] (.GetEnumerator (clojure.lang.RecordEnumerable. this# [~@(map keyword base-fields)] (clojure.lang.RT/iter ~'__extmap)))) + )]) + (cntd [[i m]] ;;; ADDED + [(conj i 'clojure.lang.Counted) ;;; ADDED + (conj m ;;; ADDED + `(clojure.lang.Counted.count [this#] (+ ~(count base-fields) (count ~'__extmap))))]) ;;; ADDED + (ipc [[i m]] ;;; ADDED + [(conj i 'clojure.lang.IPersistentCollection) ;;; ADDED + (conj m ;;; ADDED + `(clojure.lang.IPersistentCollection.cons [this# e#] ;;; ADDED + ((var imap-cons) this# e#)) ;;; ADDED + `(clojure.lang.IPersistentCollection.count [this#] (+ ~(count base-fields) (count ~'__extmap))))]) ;;; ADDED + (associative ;;; ADDED + [[i m]] ;;; ADDED + [(conj i 'clojure.lang.Associative) ;;; ADDED + (conj m ;;; ADDED + `(clojure.lang.Associative.assoc [this# k# ~gs] ;;; ADDED + (condp identical? k# ;;; ADDED + ~@(mapcat (fn [fld] ;;; ADDED + [(keyword fld) (list* `new tagname (replace {fld gs} (remove '#{__hash __hasheq} fields)))]) ;;; ADDED + base-fields) ;;; ADDED + (new ~tagname ~@(remove '#{__extmap __hash __hasheq} fields) (assoc ~'__extmap k# ~gs)))))])] ;;; ADDED (let [[i m] (-> [interfaces methods] irecord eqhash iobj ilookup imap associative cntd ipc dict)] ;;; Associative, ipc, cntd added - `(deftype* ~(symbol (name (ns-name *ns*)) (name tagname)) ~classname - ~(conj hinted-fields '__meta '__extmap - '^int ^:unsynchronized-mutable __hash - '^int ^:unsynchronized-mutable __hasheq) + `(deftype* ~(symbol (name (ns-name *ns*)) (name tagname)) ~classname + ~(conj hinted-fields '__meta '__extmap + '^int ^:unsynchronized-mutable __hash + '^int ^:unsynchronized-mutable __hasheq) :implements ~(vec i) ~@(mapcat identity opts) ~@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 __hash __hasheq __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 __hash __hasheq __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*) - Options are expressed as sequential keywords and arguments (in any order). - - Supported options: - :load-ns - if true, importing the record class will cause the - namespace in which the record was defined to be loaded. + Options are expressed as sequential keywords and arguments (in any order). + + Supported options: + :load-ns - if true, importing the record class will cause the + namespace in which the record was defined to be loaded. Defaults to false. Each spec consists of a protocol or interface name followed by zero @@ -360,16 +360,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: @@ -382,22 +382,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 @@ -407,14 +407,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, - __extmap, __hash and __hasheq 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, + __extmap, __hash and __hasheq 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] @@ -426,173 +426,173 @@ 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 opts) - (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 opts) + (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 cname fields interfaces methods opts] - (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." cname)) (meta cname)) - interfaces (conj interfaces 'clojure.lang.IType)] - `(deftype* ~(symbol (name (ns-name *ns*)) (name tagname)) ~classname ~fields - :implements ~interfaces - ~@(mapcat identity opts) - ~@methods))) - -(defmacro deftype - "(deftype name [fields*] options* specs*) - - Options are expressed as sequential keywords and arguments (in any order). - - Supported options: - :load-ns - if true, importing the type class will cause the - namespace in which the type was defined to be loaded. - Defaults to false. - - 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 directly. 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, __extmap, __hash and __hasheq 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 cname fields interfaces methods opts] + (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." cname)) (meta cname)) + interfaces (conj interfaces 'clojure.lang.IType)] + `(deftype* ~(symbol (name (ns-name *ns*)) (name tagname)) ~classname ~fields + :implements ~interfaces + ~@(mapcat identity opts) + ~@methods))) + +(defmacro deftype + "(deftype name [fields*] options* specs*) + + Options are expressed as sequential keywords and arguments (in any order). + + Supported options: + :load-ns - if true, importing the type class will cause the + namespace in which the type was defined to be loaded. + Defaults to false. + + 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 directly. 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, __extmap, __hash and __hasheq 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 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 opts) - (import ~classname) - ~(build-positional-factory gname classname fields) - ~classname))) - + + [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 opts) + (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. (.sym cache) (.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. (.sym cache) (.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. (.sym cache) (.protocol cache) (.methodk cache) shift mask table)) (clojure.lang.MethodImplCache. (.sym cache) (.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 @@ -609,8 +609,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 @@ -621,40 +621,40 @@ (defn- emit-method-builder [on-interface method on-method arglists extend-via-meta] (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 (fn [args] (let [gargs (map #(gensym (str "gf__" % "__")) args) target (first gargs)] - (if extend-via-meta - `([~@gargs] - (let [cache# (.__methodImplCache ~gthis) - f# (.fnFor cache# (clojure.lang.Util/classOf ~target))] - (if (identical? f# ~ginterf) - (f# ~@gargs) - (if-let [meta# (when-let [m# (meta ~target)] ((.sym cache#) m#))] - (meta# ~@gargs) - (if f# - (f# ~@gargs) - ((-cache-protocol-fn ~gthis ~target ~on-interface ~ginterf) ~@gargs)))))) - `([~@gargs] - (let [cache# (.__methodImplCache ~gthis) - f# (.fnFor cache# (clojure.lang.Util/classOf ~target))] - (if f# - (f# ~@gargs) + (if extend-via-meta + `([~@gargs] + (let [cache# (.__methodImplCache ~gthis) + f# (.fnFor cache# (clojure.lang.Util/classOf ~target))] + (if (identical? f# ~ginterf) + (f# ~@gargs) + (if-let [meta# (when-let [m# (meta ~target)] ((.sym cache#) m#))] + (meta# ~@gargs) + (if f# + (f# ~@gargs) + ((-cache-protocol-fn ~gthis ~target ~on-interface ~ginterf) ~@gargs)))))) + `([~@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#) @@ -684,32 +684,32 @@ 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 [tag-to-class (fn [tag] - (if-let [c (and (instance? clojure.lang.Symbol tag) - (= (.IndexOf (.Name ^clojure.lang.Symbol tag) ".") -1) ;;; .indexOf .getName - (not (contains? '#{int long float double char short byte boolean void uint ulong ushort sbyte ;;; add unsigned types - ints longs floats doubles chars shorts bytes booleans objects uints ulongs ushorts sbytes} tag)) - (resolve tag))] - (symbol (.FullName c)) ;;; .getName - tag)) - name-meta (update-in (meta (first s)) [:tag] tag-to-class) - 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 [tag-to-class (fn [tag] + (if-let [c (and (instance? clojure.lang.Symbol tag) + (= (.IndexOf (.Name ^clojure.lang.Symbol tag) ".") -1) ;;; .indexOf .getName + (not (contains? '#{int long float double char short byte boolean void uint ulong ushort sbyte ;;; add unsigned types + ints longs floats doubles chars shorts bytes booleans objects uints ulongs ushorts sbytes} tag)) + (resolve tag))] + (symbol (.FullName c)) ;;; .getName + tag)) + name-meta (update-in (meta (first s)) [:tag] tag-to-class) + 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))] @@ -735,9 +735,9 @@ :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) + (emit-method-builder (:on-interface opts) (:name s) (:on s) (:arglists s) (:extend-via-metadata opts))]) (vals sigs))))) (-reset-methods ~name) @@ -750,7 +750,7 @@ ;optional doc string \"A doc string for AProtocol abstraction\" - ;options + ;options :extend-via-metadata true ;method signatures @@ -761,17 +761,17 @@ 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. - When :extend-via-metadata is true, values can extend protocols by - adding metadata where keys are fully-qualified protocol function - symbols and values are function implementations. Protocol - implementations are checked first for direct definitions (defrecord, - deftype, reify), then metadata definitions, then external + When :extend-via-metadata is true, values can extend protocols by + adding metadata where keys are fully-qualified protocol function + symbols and values are function implementations. Protocol + implementations are checked first for direct definitions (defrecord, + deftype, reify), then metadata definitions, then external extensions (extend, extend-type, extend-protocol) defprotocol will automatically generate a corresponding interface, @@ -845,12 +845,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)))) @@ -878,7 +878,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 diff --git a/Clojure/Clojure.Source/clojure/core_print.clj b/Clojure/Clojure.Source/clojure/core_print.clj index 2ed71528b..6bb9cd47c 100644 --- a/Clojure/Clojure.Source/clojure/core_print.clj +++ b/Clojure/Clojure.Source/clojure/core_print.clj @@ -1,659 +1,659 @@ -; 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. - -(in-ns 'clojure.core) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; printing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(import 'System.IO.TextWriter) ;;; was (import '(java.io Writer)) (I have replaced ^Writer with ^System.IO.TextWriter throughout -;; Other global replaces: .write => .Write, .append => .Write, ^Class => ^Type, ^Character => ^Char -(set! *warn-on-reflection* true) -(def ^:dynamic - ^{:doc "*print-length* controls how many items of each collection the - printer will print. If it is bound to logical false, there is no - limit. Otherwise, it must be bound to an integer indicating the maximum - number of items of each collection to print. If a collection contains - more items, the printer will print items up to the limit followed by - '...' to represent the remaining items. The root binding is nil - indicating no limit." - :added "1.0"} - *print-length* nil) - -(def ^:dynamic - ^{:doc "*print-level* controls how many levels deep the printer will - print nested objects. If it is bound to logical false, there is no - limit. Otherwise, it must be bound to an integer indicating the maximum - level to print. Each argument to print is at level 0; if an argument is a - collection, its items are at level 1; and so on. If an object is a - collection and is at a level greater than or equal to the value bound to - *print-level*, the printer prints '#' to represent it. The root binding - is nil indicating no limit." - :added "1.0"} - *print-level* nil) - -(def ^:dynamic *verbose-defrecords* false) - -(def ^:dynamic - ^{:doc "*print-namespace-maps* controls whether the printer will print - namespace map literal syntax. It defaults to false, but the REPL binds - to true." - :added "1.9"} - *print-namespace-maps* false) - -(defn- print-sequential [^String begin, print-one, ^String sep, ^String end, sequence, ^System.IO.TextWriter w] - (binding [*print-level* (and (not *print-dup*) *print-level* (dec *print-level*))] - (if (and *print-level* (neg? *print-level*)) - (.Write w "#") - (do - (.Write w begin) - (when-let [xs (seq sequence)] - (if (and (not *print-dup*) *print-length*) - (loop [[x & xs] xs - print-length *print-length*] - (if (zero? print-length) - (.Write w "...") - (do - (print-one x w) - (when xs - (.Write w sep) - (recur xs (dec print-length)))))) - (loop [[x & xs] xs] - (print-one x w) - (when xs - (.Write w sep) - (recur xs))))) - (.Write w end))))) - -(defn- print-meta [o, ^System.IO.TextWriter w] - (when-let [m (meta o)] - (when (and (pos? (count m)) - (or *print-dup* - (and *print-meta* *print-readably*))) - (.Write w "^") - (if (and (= (count m) 1) (:tag m)) - (pr-on (:tag m) w) - (pr-on m w)) - (.Write w " ")))) - -(defn print-simple [o, ^System.IO.TextWriter w] - (print-meta o w) - (.Write w (str o))) - -(defmethod print-method :default [o, ^System.IO.TextWriter w] - (if (instance? clojure.lang.IObj o) - (print-method (vary-meta o #(dissoc % :type)) w) - (print-simple o w))) - -(defmethod print-method nil [o, ^System.IO.TextWriter w] - (.Write w "nil")) - -(defmethod print-dup nil [o w] (print-method o w)) - -(defn print-ctor [o print-args ^System.IO.TextWriter w] - (.Write w "#=(") - (.Write w (.FullName ^Type (class o))) ;;; .getName => .FullName - (.Write w ". ") - (print-args o w) - (.Write w ")")) - -(defn- print-tagged-object [o rep ^System.IO.TextWriter w] - (when (instance? clojure.lang.IMeta o) - (print-meta o w)) - (.Write w "#object[") - (let [c (class o)] - (if (.IsArray c) ;;; .isArray - (print-method (.Name c) w) ;;; .getName - (.Write w (.Name c)))) ;;; .getName - (.Write w " ") - (.Write w (format "0x%x " (System.Runtime.CompilerServices.RuntimeHelpers/GetHashCode o))) ;;; (System/identityHashCode o) - (print-method rep w) - (.Write w "]")) - -(defn- print-object [o, ^System.IO.TextWriter w] - (print-tagged-object o (str o) w)) - -(defmethod print-method Object [o, ^System.IO.TextWriter w] - (print-object o w)) - -(defmethod print-method clojure.lang.Keyword [o, ^System.IO.TextWriter w] - (.Write w (str o))) - -(defmethod print-dup clojure.lang.Keyword [o w] (print-method o w)) -;;; MAJOR PROBLEM: no Number type in CLR. We will just ask every ValueType to print itself. TODO: Need to deal with BigDecimal and BigInteger later. -(defmethod print-method ValueType [o, ^System.IO.TextWriter w] ;; Number => ValueType - (.Write w (str o))) - -;;; DM ADDED - -(defn fp-str [x] - (let [s (str x)] - (if (or (.Contains s ".") (.Contains s "E")) - s - (str s ".0")))) -;;; Whelp, now they have added in print-method for Double and Single, in order to handle infinities and NaN - -(defmethod print-method Double [o, ^System.IO.TextWriter w]+ - (cond - (= Double/PositiveInfinity o) (.Write w "##Inf") ;;; POSITIVE_INFINITY - (= Double/NegativeInfinity o) (.Write w "##-Inf") ;;; NEGATIVE_INFINITY - (Double/IsNaN ^Double o) (.Write w "##NaN") ;;; (.IsNaN ^Double o) - :else (.Write w (fp-str o)))) - -(defmethod print-method Single [o, ^System.IO.TextWriter w] - (cond - (= Single/PositiveInfinity o) (.Write w "##Inf") ;;; Float/POSITIVE_INFINITY - (= Single/NegativeInfinity o) (.Write w "##-Inf") ;;; Float/NEGATIVE_INFINITY - (Single/IsNaN ^Float o) (.Write w "##NaN") ;;; (.IsNaN ^Float o) - :else (.Write w (fp-str o)))) - -;;;We need to cover all the numerics, or we are hosed on print-dup. -(defmethod print-method Int16 [o, ^System.IO.TextWriter w] (.Write w (str o))) -(defmethod print-method Int32 [o, ^System.IO.TextWriter w] (.Write w (str o))) -(defmethod print-method Int64 [o, ^System.IO.TextWriter w] (.Write w (str o))) -(defmethod print-method UInt16 [o, ^System.IO.TextWriter w] (.Write w (str o))) -(defmethod print-method UInt32 [o, ^System.IO.TextWriter w] (.Write w (str o))) -(defmethod print-method UInt64 [o, ^System.IO.TextWriter w] (.Write w (str o))) -(defmethod print-method Byte [o, ^System.IO.TextWriter w] (.Write w (str o))) -(defmethod print-method SByte [o, ^System.IO.TextWriter w] (.Write w (str o))) - -(defmethod print-dup Int16 [o, ^System.IO.TextWriter w] (print-method o w)) -(defmethod print-dup Int32 [o, ^System.IO.TextWriter w] (print-method o w)) -(defmethod print-dup Int64 [o, ^System.IO.TextWriter w] (print-method o w)) -(defmethod print-dup UInt16 [o, ^System.IO.TextWriter w] (print-method o w)) -(defmethod print-dup UInt32 [o, ^System.IO.TextWriter w] (print-method o w)) -(defmethod print-dup UInt64 [o, ^System.IO.TextWriter w] (print-method o w)) -(defmethod print-dup Byte [o, ^System.IO.TextWriter w] (print-method o w)) -(defmethod print-dup SByte [o, ^System.IO.TextWriter w] (print-method o w)) -(defmethod print-dup Double [o, ^System.IO.TextWriter w] (print-method o w)) -(defmethod print-dup Single [o, ^System.IO.TextWriter w] (print-method o w)) - -;;; - -(defmethod print-dup ValueType [o, ^System.IO.TextWriter w] ;;; Number => ValueType - (print-ctor o - (fn [o w] - (print-dup (str o) w)) - w)) - -(defmethod print-dup clojure.lang.Fn [o, ^System.IO.TextWriter w] - (print-ctor o (fn [o w]) w)) - -(prefer-method print-dup clojure.lang.IPersistentCollection clojure.lang.Fn) -(prefer-method print-dup System.Collections.IDictionary clojure.lang.Fn) ;;; java.util.Map -(prefer-method print-dup System.Collections.ICollection clojure.lang.Fn) ;;; java.util.Collection - -(defmethod print-method Boolean [o, ^System.IO.TextWriter w] - (.Write w (if o "true" "false"))) ;;; (.Write w (str o))) else we get True False - -(defmethod print-dup Boolean [o w] (print-method o w)) - -(defmethod print-method clojure.lang.Symbol [o, ^System.IO.TextWriter w] - (print-simple o w)) - -(defmethod print-dup clojure.lang.Symbol [^clojure.lang.Symbol o, ^System.IO.TextWriter w] ;;; (print-method o w)), Added hints - (if (or *print-dup* *print-readably*) - (do - (print-meta o w) - (.Write w (.ToStringEscaped o))) - (print-method o w))) - -(defmethod print-method clojure.lang.Var [o, ^System.IO.TextWriter w] - (print-simple o w)) - -(defmethod print-dup clojure.lang.Var [^clojure.lang.Var o, ^System.IO.TextWriter w] - (.Write w (str "#=(var " (.Name (.ns o)) "/" (.Symbol o) ")"))) ;;; .name => .Name, .sym => .Symbol - -(defmethod print-method clojure.lang.ISeq [o, ^System.IO.TextWriter w] - (print-meta o w) - (print-sequential "(" pr-on " " ")" o w)) - -(defmethod print-dup clojure.lang.ISeq [o w] (print-method o w)) -(defmethod print-dup clojure.lang.IPersistentList [o w] (print-method o w)) -(prefer-method print-method clojure.lang.ISeq clojure.lang.IPersistentCollection) -(prefer-method print-dup clojure.lang.ISeq clojure.lang.IPersistentCollection) -(prefer-method print-method clojure.lang.ISeq System.Collections.ICollection) ;; java: java.util.Collection -(prefer-method print-dup clojure.lang.ISeq System.Collections.ICollection) ;; java: java.util.Collection - - - -(defmethod print-dup System.Collections.ICollection [o, ^System.IO.TextWriter w] ;; java.util.Collection => System.Collections.ICollection - (print-ctor o #(print-sequential "[" print-method " " "]" %1 %2) w)) - -(defmethod print-dup clojure.lang.IPersistentCollection [o, ^System.IO.TextWriter w] - (print-meta o w) - (.Write w "#=(") - (.Write w (.FullName ^Type (class o))) ;; .getName => .FullName - (.Write w "/create ") - (print-sequential "[" print-dup " " "]" o w) - (.Write w ")")) - -(prefer-method print-dup clojure.lang.IPersistentCollection System.Collections.ICollection) ;; java.util.Collection => System.Collections.ICollection - -(def ^{:tag String - :doc "Returns escape string for char or nil if none" - :added "1.0"} - char-escape-string - {\newline "\\n" - \tab "\\t" - \return "\\r" - \" "\\\"" - \\ "\\\\" - \formfeed "\\f" - \backspace "\\b"}) - -(defmethod print-method String [^String s, ^System.IO.TextWriter w] - (if (or *print-dup* *print-readably*) - (do (.Write w \") ;;; " (Just to keep the display happy in the editor) - (dotimes [n (count s)] - (let [c (.get_Chars s n) ;; .charAt => .get_Chars - e (char-escape-string c)] - (if e (.Write w e) (.Write w c)))) - (.Write w \")) ;;; " (Just to keep the display happy in the editor) - (.Write w s)) - nil) - -(defmethod print-dup String [s w] (print-method s w)) - -(defmethod print-method clojure.lang.IPersistentVector [v, ^System.IO.TextWriter w] - (print-meta v w) - (print-sequential "[" pr-on " " "]" v w)) - -(defn- print-prefix-map [prefix kvs print-one w] - (print-sequential - (str prefix "{") - (fn [[k v] ^System.IO.TextWriter w] - (do (print-one k w) (.Write w \space) (print-one v w))) ;;; .append - ", " - "}" - kvs w)) - - (defn- print-map [m print-one w] - (print-prefix-map nil m print-one w)) - -(defn- strip-ns - [named] - (if (symbol? named) - (symbol nil (name named)) - (keyword nil (name named)))) - -(defn- lift-ns - "Returns [lifted-ns lifted-kvs] or nil if m can't be lifted." - [m] - (when *print-namespace-maps* - (loop [ns nil - [[k v :as entry] & entries] (seq m) - kvs []] - (if entry - (when (qualified-ident? k) - (if ns - (when (= ns (namespace k)) - (recur ns entries (conj kvs [(strip-ns k) v]))) - (when-let [new-ns (namespace k)] - (recur new-ns entries (conj kvs [(strip-ns k) v]))))) - [ns kvs])))) - -(defmethod print-method clojure.lang.IPersistentMap [m, ^System.IO.TextWriter w] - (let [[ns lift-kvs] (lift-ns m)] - (if ns - (print-prefix-map (str "#:" ns) lift-kvs pr-on w) - (print-map m pr-on w)))) - -(defmethod print-dup System.Collections.IDictionary [m, ^System.IO.TextWriter w] ;;; java.util.Map - (print-ctor m #(print-map (seq %1) print-method %2) w)) - -(defmethod print-dup clojure.lang.IPersistentMap [m, ^System.IO.TextWriter w] - (print-meta m w) - (.Write w "#=(") - (.Write w (.FullName (class m))) ;; .getName => .FullName - (.Write w "/create ") - (print-map m print-dup w) - (.Write w ")")) - -;; java.util -(prefer-method print-method clojure.lang.IPersistentCollection System.Collections.ICollection) ;;; java.util.Collection -;;;(prefer-method print-method clojure.lang.IPersistentCollection java.util.RandomAccess) -;;;(prefer-method print-method java.util.RandomAccess java.util.List) -(prefer-method print-method clojure.lang.IPersistentCollection System.Collections.IDictionary) ;;; java.util.Map - -(defmethod print-method System.Collections.ICollection [c, ^System.IO.TextWriter w] ;;; java.util.List - (if *print-readably* - (do - (print-meta c w) - (print-sequential "(" pr-on " " ")" c w)) - (print-object c w))) - -;;;(defmethod print-method java.util.RandomAccess [v, ^System.IO.TextWriter w] -;;; (if *print-readably* -;;; (do -;;; (print-meta v w) -;;; (print-sequential "[" pr-on " " "]" v w)) -;;; (print-object v w))) - -(defmethod print-method System.Collections.IDictionary [m, ^System.IO.TextWriter w] ;;; java.util.Map - (if *print-readably* - (do - (print-meta m w) - (print-map m pr-on w)) - (print-object m w))) - -;;;(defmethod print-method java.util.Set [s, ^System.IO.TextWriter w] ;;; One example where we need true generic handling -- this should be ISet -;;; (if *print-readably* -;;; (do -;;; (print-meta s w) -;;; (print-sequential "#{" pr-on " " "}" (seq s) w)) -;;; (print-object s w))) - -;; Records - -(defmethod print-method clojure.lang.IRecord [r, ^System.IO.TextWriter w] - (print-meta r w) - (.Write w "#") - (.Write w (.FullName (class r))) ;; .getName => .FullName - (print-map r pr-on w)) - -(defmethod print-dup clojure.lang.IRecord [r, ^System.IO.TextWriter w] - (print-meta r w) - (.Write w "#") - (.Write w (.FullName (class r))) ;; .getName => .FullName - (if *verbose-defrecords* - (print-map r print-dup w) - (print-sequential "[" pr-on ", " "]" (vals r) w))) - -(prefer-method print-method clojure.lang.IRecord System.Collections.IDictionary) ;; java.util.Map -> System.Collections.IDictionary -(prefer-method print-method clojure.lang.IRecord clojure.lang.IPersistentMap) -(prefer-method print-dup clojure.lang.IRecord clojure.lang.IPersistentMap) -(prefer-method print-dup clojure.lang.IPersistentMap System.Collections.IDictionary) ;; java.util.Map -> System.Collections.IDictionary -(prefer-method print-dup clojure.lang.IRecord clojure.lang.IPersistentCollection) -(prefer-method print-dup clojure.lang.IRecord System.Collections.IDictionary) ;; java.util.Map -> System.Collections.IDictionary -(prefer-method print-dup clojure.lang.IRecord System.Collections.ICollection) -(prefer-method print-method clojure.lang.IRecord System.Collections.ICollection) - -(defmethod print-method clojure.lang.IPersistentSet [s, ^System.IO.TextWriter w] - (print-meta s w) - (print-sequential "#{" pr-on " " "}" (seq s) w)) - -(def ^{:tag String - :doc "Returns name string for char or nil if none" - :added "1.0"} - char-name-string - {\newline "newline" - \tab "tab" - \space "space" - \backspace "backspace" - \formfeed "formfeed" - \return "return"}) - -(defmethod print-method Char [c, ^System.IO.TextWriter w] ;;; ^Character c - (if (or *print-dup* *print-readably*) - (do (.Write w \\) - (let [n (char-name-string c)] - (if n (.Write w n) (.Write w ^Char c)))) - (.Write w ^Char c)) - nil) - -(defmethod print-dup Char [c w] (print-method c w)) ;;; java.lang.Character -;(defmethod print-dup Int32 [o w] (print-method o w)) ;;; java.lang.Integer -;(defmethod print-dup Double [o w] (print-method o w)) ;;; java.lang.Double -(defmethod print-dup clojure.lang.Ratio [o w] (print-method o w)) -(defmethod print-dup clojure.lang.BigDecimal [o w] (print-method o w)) ;;; java.math.BigDecimal -(defmethod print-dup clojure.lang.BigInt [o w] (print-method o w)) -(defmethod print-dup clojure.lang.PersistentHashMap [o w] (print-method o w)) -(defmethod print-dup clojure.lang.PersistentHashSet [o w] (print-method o w)) -(defmethod print-dup clojure.lang.PersistentVector [o w] (print-method o w)) -(defmethod print-dup clojure.lang.LazilyPersistentVector [o w] (print-method o w)) - -;;; ADDED LINES -(defmethod print-method clojure.lang.Ratio [o ^System.IO.TextWriter w] (.Write w (str o))) -(defmethod print-dup clojure.lang.BigInteger [o ^System.IO.TextWriter w] - (.Write w "#=(clojure.lang.BigInteger/Parse ") - (print-dup (str o) w) - (.Write w ")")) - - - -(def primitives-classnames ;; not clear what the equiv should be - {Single "System.Single" ;;{Float/TYPE "Float/TYPE" - Int32 "System.Int32" ;; Integer/TYPE "Integer/TYPE" - Int64 "System.Int64" ;; Long/TYPE "Long/TYPE" - Boolean "System.Boolean" ;; Boolean/TYPE "Boolean/TYPE" - Char "System.Char" ;; Character/TYPE "Character/TYPE" - Double "System.Double" ;; Double/TYPE "Double/TYPE" - Byte "System.Byte" ;; Byte/TYPE "Byte/TYPE" - Int16 "System.Int16" ;; Short/TYPE "Short/TYPE"}) - SByte "System.SByte" ;; ADDED - UInt16 "System.UInt16" ;; ADDED - UInt32 "System.UInt32" ;; ADDED - UInt64 "System.UInt64" ;; ADDED - Decimal "System.Decimal" }) ;; ADDED - -(defmethod print-method Type [^Type c, ^System.IO.TextWriter w] - (.Write w (.FullName c))) ;;; .getName => .FullName - -(defmethod print-dup Type [^Type c, ^System.IO.TextWriter w] - (cond - (.IsPrimitive c) (do ;; .isPrimitive - (.Write w "#=(identity ") - (.Write w ^String (primitives-classnames c)) - (.Write w ")")) - (.IsArray c) (do ;; .isArray , java.lang.Class/forName => - (.Write w "#=(clojure.lang.RT/classForName \"") - (.Write w (.FullName c)) ;; .getName => .FullName - (.Write w "\")")) - :else (do - (.Write w "#=") - (.Write w (.FullName c))))) ;;; .getName => .FullName - -(defmethod print-method clojure.lang.BigDecimal [b, ^System.IO.TextWriter w] ;;; java.math.BigDecimal - (.Write w (str b)) - (.Write w "M")) - -(defmethod print-method clojure.lang.BigInt [b, ^System.IO.TextWriter w] - (.Write w (str b)) - (.Write w "N")) - -(defmethod print-method System.Text.RegularExpressions.Regex [p ^System.IO.TextWriter w] ;;; java.util.regex.Pattern => - (.Write w "#\"") - (loop [[^Char c & r :as s] (seq (.ToString ^System.Text.RegularExpressions.Regex p)) ;;; .pattern => .ToString - qmode false] - (when s - (cond - (= c \\) (let [[^Char c2 & r2] r] - (.Write w \\) - (.Write w c2) - (if qmode - (recur r2 (not= c2 \E)) - (recur r2 (= c2 \Q)))) - (= c \") (do - (if qmode - (.Write w "\\E\\\"\\Q") - (.Write w "\\\"")) - (recur r qmode)) - :else (do - (.Write w c) - (recur r qmode))))) - (.Write w \")) - -(defmethod print-dup System.Text.RegularExpressions.Regex [p ^System.IO.TextWriter w] (print-method p w)) ;;; java.util.regex.Pattern => - -(defmethod print-dup clojure.lang.Namespace [^clojure.lang.Namespace n ^System.IO.TextWriter w] - (.Write w "#=(find-ns ") - (print-dup (.Name n) w) ;; .name - (.Write w ")")) - -(defn- deref-as-map [^clojure.lang.IDeref o] - (let [pending (and (instance? clojure.lang.IPending o) - (not (.isRealized ^clojure.lang.IPending o))) - [ex val] - (when-not pending - (try [false (deref o)] - (catch Exception e ;;; Throwable - [true e])))] - {:status - (cond - (or ex - (and (instance? clojure.lang.Agent o) - (agent-error o))) - :failed - - pending - :pending - - :else - :ready) - - :val val})) - -(defmethod print-method clojure.lang.IDeref [o ^System.IO.TextWriter w] - (print-tagged-object o (deref-as-map o) w)) - -(defmethod print-method System.Diagnostics.StackFrame [^System.Diagnostics.StackFrame o ^System.IO.TextWriter w] ;;; StackTraceElement ^StackTraceElement - (print-method [(symbol (.FullName (.GetType o))) (symbol (.Name (.GetMethod o))) (.GetFileName o) (.GetFileLineNumber o)] w)) ;;; (.getClassName o) (.getMethodName o) .getFileName .getLineNumber - -(defn StackTraceElement->vec - "Constructs a data representation for a StackTraceElement: [class method file line]" - {:added "1.9"} - [^System.Diagnostics.StackFrame o] - (if (nil? o) - nil - [(symbol (.FullName (.GetType o))) - (if-let [m (.GetMethod o)] - (symbol (.Name m)) - "NO_METHOD") - (or (.GetFileName o) "NO_FILE") - (.GetFileLineNumber o)])) - -(defn Throwable->map - "Constructs a data representation for a Throwable with keys: - :cause - root cause message - :phase - error phase - :via - cause chain, with cause keys: - :type - exception class symbol - :message - exception message - :data - ex-data - :at - top stack element - :trace - root cause stack elements" - {:added "1.7"} - [^Exception o] ;;; ^Throwable - (let [base (fn [^Exception t] ;;; ^Throwable - (merge {:type (symbol (.FullName (class t)))} ;;; .getName - (when-let [msg (.Message t)] ;;; .getLocalizedMessage - {:message msg}) - (when-let [ed (ex-data t)] - {:data ed}) - (let [st (.GetFrames (System.Diagnostics.StackTrace. t true))] ;;; (.getStackTrace t) - (when (and st (pos? (alength st))) ;;; added the 'and st' because we may get a null back instread of an array. - {:at (StackTraceElement->vec (aget st 0))})))) ;;; aget - via (loop [via [], ^Exception t o] ;;; ^Throwable - (if t - (recur (conj via t) (.InnerException t)) ;;; .getCause - via)) - ^Exception root (peek via)] ;;; Throwable - (merge {:via (vec (map base via)) - :trace (vec (map StackTraceElement->vec - (.GetFrames (System.Diagnostics.StackTrace. (or root o) true))))} ;;; .getStackTrace ^Throwable - (when-let [root-msg (.Message root)] ;;; (.getLocalizedMessage root) - {:cause root-msg}) - (when-let [data (ex-data root)] - {:data data}) - (when-let [phase (-> o ex-data :clojure.error/phase)] - {:phase phase})))) - -(defn print-throwable [^Exception o ^System.IO.TextWriter w] ;;; ^Throwable - (.Write w "#error {\n :cause ") - (let [{:keys [cause data via trace]} (Throwable->map o) - print-via #(do (.Write w "{:type ") - (print-method (:type %) w) - (.Write w "\n :message ") - (print-method (:message %) w) - (when-let [data (:data %)] - (.Write w "\n :data ") - (print-method data w)) - (when-let [at (:at %)] - (.Write w "\n :at ") - (print-method (:at %) w)) - (.Write w "}"))] - (print-method cause w) - (when data - (.Write w "\n :data ") - (print-method data w)) - (when via - (.Write w "\n :via\n [") - (when-let [fv (first via)] - (print-via fv) - (doseq [v (rest via)] - (.Write w "\n ") - (print-via v))) - (.Write w "]")) - (when trace - (.Write w "\n :trace\n [") - (when-let [ft (first trace)] - (print-method ft w) - (doseq [t (rest trace)] - (.Write w "\n ") - (print-method t w))) - (.Write w "]"))) - (.Write w "}")) - -(defmethod print-method Exception [^Exception o ^System.IO.TextWriter w] ;;; Throwable ^Throwable - (print-throwable o w)) - -(defmethod print-method clojure.lang.TaggedLiteral [o ^System.IO.TextWriter w] - (.Write w "#") - (print-method (:tag o) w) - (.Write w " ") - (print-method (:form o) w)) - -(defmethod print-method clojure.lang.ReaderConditional [o ^System.IO.TextWriter w] - (.Write w "#?") - (when (:splicing? o) (.Write w "@")) - (print-method (:form o) w)) - -(def ^{:private true :dynamic true} print-initialized true) - -;;;(defn ^java.io.PrintWriter PrintWriter-on -;;; "implements java.io.PrintWriter given flush-fn, which will be called -;;; when .flush() is called, with a string built up since the last call to .flush(). -;;; if not nil, close-fn will be called with no arguments when .close is called" -;;; {:added "1.10"} -;;; [flush-fn close-fn] -;;; (let [sb (StringBuilder.)] -;;; (-> (proxy [Writer] [] -;;; (flush [] -;;; (when (pos? (.length sb)) -;;; (flush-fn (.toString sb))) -;;; (.setLength sb 0)) -;;; (close [] -;;; (.flush ^Writer this) -;;; (when close-fn (close-fn)) -;;; nil) -;;; (write [str-cbuf off len] -;;; (when (pos? len) -;;; (if (instance? String str-cbuf) -;;; (.append sb ^String str-cbuf ^int off ^int len) -;;; (.append sb ^chars str-cbuf ^int off ^int len))))) -;;; java.io.BufferedWriter. -;;; java.io.PrintWriter.))) - -(defn ^System.IO.TextWriter PrintWriter-on - [flush-fn close-fn] - (proxy [System.IO.StringWriter] [] - (Flush [] - (let [^System.IO.StringWriter this this] - (proxy-super Flush)) - (let [sb (.GetStringBuilder ^System.IO.StringWriter this)] - (when (pos? (.Length sb)) - (flush-fn (.ToString sb))) - (.set_Length sb 0))) - (Close [] - (.Flush ^System.IO.StringWriter this) - (when close-fn (close-fn)) - (let [^System.IO.StringWriter this this] - (proxy-super Close)) - nil))) - - +; 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. + +(in-ns 'clojure.core) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; printing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(import 'System.IO.TextWriter) ;;; was (import '(java.io Writer)) (I have replaced ^Writer with ^System.IO.TextWriter throughout +;; Other global replaces: .write => .Write, .append => .Write, ^Class => ^Type, ^Character => ^Char +(set! *warn-on-reflection* true) +(def ^:dynamic + ^{:doc "*print-length* controls how many items of each collection the + printer will print. If it is bound to logical false, there is no + limit. Otherwise, it must be bound to an integer indicating the maximum + number of items of each collection to print. If a collection contains + more items, the printer will print items up to the limit followed by + '...' to represent the remaining items. The root binding is nil + indicating no limit." + :added "1.0"} + *print-length* nil) + +(def ^:dynamic + ^{:doc "*print-level* controls how many levels deep the printer will + print nested objects. If it is bound to logical false, there is no + limit. Otherwise, it must be bound to an integer indicating the maximum + level to print. Each argument to print is at level 0; if an argument is a + collection, its items are at level 1; and so on. If an object is a + collection and is at a level greater than or equal to the value bound to + *print-level*, the printer prints '#' to represent it. The root binding + is nil indicating no limit." + :added "1.0"} + *print-level* nil) + +(def ^:dynamic *verbose-defrecords* false) + +(def ^:dynamic + ^{:doc "*print-namespace-maps* controls whether the printer will print + namespace map literal syntax. It defaults to false, but the REPL binds + to true." + :added "1.9"} + *print-namespace-maps* false) + +(defn- print-sequential [^String begin, print-one, ^String sep, ^String end, sequence, ^System.IO.TextWriter w] + (binding [*print-level* (and (not *print-dup*) *print-level* (dec *print-level*))] + (if (and *print-level* (neg? *print-level*)) + (.Write w "#") + (do + (.Write w begin) + (when-let [xs (seq sequence)] + (if (and (not *print-dup*) *print-length*) + (loop [[x & xs] xs + print-length *print-length*] + (if (zero? print-length) + (.Write w "...") + (do + (print-one x w) + (when xs + (.Write w sep) + (recur xs (dec print-length)))))) + (loop [[x & xs] xs] + (print-one x w) + (when xs + (.Write w sep) + (recur xs))))) + (.Write w end))))) + +(defn- print-meta [o, ^System.IO.TextWriter w] + (when-let [m (meta o)] + (when (and (pos? (count m)) + (or *print-dup* + (and *print-meta* *print-readably*))) + (.Write w "^") + (if (and (= (count m) 1) (:tag m)) + (pr-on (:tag m) w) + (pr-on m w)) + (.Write w " ")))) + +(defn print-simple [o, ^System.IO.TextWriter w] + (print-meta o w) + (.Write w (str o))) + +(defmethod print-method :default [o, ^System.IO.TextWriter w] + (if (instance? clojure.lang.IObj o) + (print-method (vary-meta o #(dissoc % :type)) w) + (print-simple o w))) + +(defmethod print-method nil [o, ^System.IO.TextWriter w] + (.Write w "nil")) + +(defmethod print-dup nil [o w] (print-method o w)) + +(defn print-ctor [o print-args ^System.IO.TextWriter w] + (.Write w "#=(") + (.Write w (.FullName ^Type (class o))) ;;; .getName => .FullName + (.Write w ". ") + (print-args o w) + (.Write w ")")) + +(defn- print-tagged-object [o rep ^System.IO.TextWriter w] + (when (instance? clojure.lang.IMeta o) + (print-meta o w)) + (.Write w "#object[") + (let [c (class o)] + (if (.IsArray c) ;;; .isArray + (print-method (.Name c) w) ;;; .getName + (.Write w (.Name c)))) ;;; .getName + (.Write w " ") + (.Write w (format "0x%x " (System.Runtime.CompilerServices.RuntimeHelpers/GetHashCode o))) ;;; (System/identityHashCode o) + (print-method rep w) + (.Write w "]")) + +(defn- print-object [o, ^System.IO.TextWriter w] + (print-tagged-object o (str o) w)) + +(defmethod print-method Object [o, ^System.IO.TextWriter w] + (print-object o w)) + +(defmethod print-method clojure.lang.Keyword [o, ^System.IO.TextWriter w] + (.Write w (str o))) + +(defmethod print-dup clojure.lang.Keyword [o w] (print-method o w)) +;;; MAJOR PROBLEM: no Number type in CLR. We will just ask every ValueType to print itself. TODO: Need to deal with BigDecimal and BigInteger later. +(defmethod print-method ValueType [o, ^System.IO.TextWriter w] ;; Number => ValueType + (.Write w (str o))) + +;;; DM ADDED + +(defn fp-str [x] + (let [s (str x)] + (if (or (.Contains s ".") (.Contains s "E")) + s + (str s ".0")))) +;;; Whelp, now they have added in print-method for Double and Single, in order to handle infinities and NaN + +(defmethod print-method Double [o, ^System.IO.TextWriter w]+ + (cond + (= Double/PositiveInfinity o) (.Write w "##Inf") ;;; POSITIVE_INFINITY + (= Double/NegativeInfinity o) (.Write w "##-Inf") ;;; NEGATIVE_INFINITY + (Double/IsNaN ^Double o) (.Write w "##NaN") ;;; (.IsNaN ^Double o) + :else (.Write w (fp-str o)))) + +(defmethod print-method Single [o, ^System.IO.TextWriter w] + (cond + (= Single/PositiveInfinity o) (.Write w "##Inf") ;;; Float/POSITIVE_INFINITY + (= Single/NegativeInfinity o) (.Write w "##-Inf") ;;; Float/NEGATIVE_INFINITY + (Single/IsNaN ^Float o) (.Write w "##NaN") ;;; (.IsNaN ^Float o) + :else (.Write w (fp-str o)))) + +;;;We need to cover all the numerics, or we are hosed on print-dup. +(defmethod print-method Int16 [o, ^System.IO.TextWriter w] (.Write w (str o))) +(defmethod print-method Int32 [o, ^System.IO.TextWriter w] (.Write w (str o))) +(defmethod print-method Int64 [o, ^System.IO.TextWriter w] (.Write w (str o))) +(defmethod print-method UInt16 [o, ^System.IO.TextWriter w] (.Write w (str o))) +(defmethod print-method UInt32 [o, ^System.IO.TextWriter w] (.Write w (str o))) +(defmethod print-method UInt64 [o, ^System.IO.TextWriter w] (.Write w (str o))) +(defmethod print-method Byte [o, ^System.IO.TextWriter w] (.Write w (str o))) +(defmethod print-method SByte [o, ^System.IO.TextWriter w] (.Write w (str o))) + +(defmethod print-dup Int16 [o, ^System.IO.TextWriter w] (print-method o w)) +(defmethod print-dup Int32 [o, ^System.IO.TextWriter w] (print-method o w)) +(defmethod print-dup Int64 [o, ^System.IO.TextWriter w] (print-method o w)) +(defmethod print-dup UInt16 [o, ^System.IO.TextWriter w] (print-method o w)) +(defmethod print-dup UInt32 [o, ^System.IO.TextWriter w] (print-method o w)) +(defmethod print-dup UInt64 [o, ^System.IO.TextWriter w] (print-method o w)) +(defmethod print-dup Byte [o, ^System.IO.TextWriter w] (print-method o w)) +(defmethod print-dup SByte [o, ^System.IO.TextWriter w] (print-method o w)) +(defmethod print-dup Double [o, ^System.IO.TextWriter w] (print-method o w)) +(defmethod print-dup Single [o, ^System.IO.TextWriter w] (print-method o w)) + +;;; + +(defmethod print-dup ValueType [o, ^System.IO.TextWriter w] ;;; Number => ValueType + (print-ctor o + (fn [o w] + (print-dup (str o) w)) + w)) + +(defmethod print-dup clojure.lang.Fn [o, ^System.IO.TextWriter w] + (print-ctor o (fn [o w]) w)) + +(prefer-method print-dup clojure.lang.IPersistentCollection clojure.lang.Fn) +(prefer-method print-dup System.Collections.IDictionary clojure.lang.Fn) ;;; java.util.Map +(prefer-method print-dup System.Collections.ICollection clojure.lang.Fn) ;;; java.util.Collection + +(defmethod print-method Boolean [o, ^System.IO.TextWriter w] + (.Write w (if o "true" "false"))) ;;; (.Write w (str o))) else we get True False + +(defmethod print-dup Boolean [o w] (print-method o w)) + +(defmethod print-method clojure.lang.Symbol [o, ^System.IO.TextWriter w] + (print-simple o w)) + +(defmethod print-dup clojure.lang.Symbol [^clojure.lang.Symbol o, ^System.IO.TextWriter w] ;;; (print-method o w)), Added hints + (if (or *print-dup* *print-readably*) + (do + (print-meta o w) + (.Write w (.ToStringEscaped o))) + (print-method o w))) + +(defmethod print-method clojure.lang.Var [o, ^System.IO.TextWriter w] + (print-simple o w)) + +(defmethod print-dup clojure.lang.Var [^clojure.lang.Var o, ^System.IO.TextWriter w] + (.Write w (str "#=(var " (.Name (.ns o)) "/" (.Symbol o) ")"))) ;;; .name => .Name, .sym => .Symbol + +(defmethod print-method clojure.lang.ISeq [o, ^System.IO.TextWriter w] + (print-meta o w) + (print-sequential "(" pr-on " " ")" o w)) + +(defmethod print-dup clojure.lang.ISeq [o w] (print-method o w)) +(defmethod print-dup clojure.lang.IPersistentList [o w] (print-method o w)) +(prefer-method print-method clojure.lang.ISeq clojure.lang.IPersistentCollection) +(prefer-method print-dup clojure.lang.ISeq clojure.lang.IPersistentCollection) +(prefer-method print-method clojure.lang.ISeq System.Collections.ICollection) ;; java: java.util.Collection +(prefer-method print-dup clojure.lang.ISeq System.Collections.ICollection) ;; java: java.util.Collection + + + +(defmethod print-dup System.Collections.ICollection [o, ^System.IO.TextWriter w] ;; java.util.Collection => System.Collections.ICollection + (print-ctor o #(print-sequential "[" print-method " " "]" %1 %2) w)) + +(defmethod print-dup clojure.lang.IPersistentCollection [o, ^System.IO.TextWriter w] + (print-meta o w) + (.Write w "#=(") + (.Write w (.FullName ^Type (class o))) ;; .getName => .FullName + (.Write w "/create ") + (print-sequential "[" print-dup " " "]" o w) + (.Write w ")")) + +(prefer-method print-dup clojure.lang.IPersistentCollection System.Collections.ICollection) ;; java.util.Collection => System.Collections.ICollection + +(def ^{:tag String + :doc "Returns escape string for char or nil if none" + :added "1.0"} + char-escape-string + {\newline "\\n" + \tab "\\t" + \return "\\r" + \" "\\\"" + \\ "\\\\" + \formfeed "\\f" + \backspace "\\b"}) + +(defmethod print-method String [^String s, ^System.IO.TextWriter w] + (if (or *print-dup* *print-readably*) + (do (.Write w \") ;;; " (Just to keep the display happy in the editor) + (dotimes [n (count s)] + (let [c (.get_Chars s n) ;; .charAt => .get_Chars + e (char-escape-string c)] + (if e (.Write w e) (.Write w c)))) + (.Write w \")) ;;; " (Just to keep the display happy in the editor) + (.Write w s)) + nil) + +(defmethod print-dup String [s w] (print-method s w)) + +(defmethod print-method clojure.lang.IPersistentVector [v, ^System.IO.TextWriter w] + (print-meta v w) + (print-sequential "[" pr-on " " "]" v w)) + +(defn- print-prefix-map [prefix kvs print-one w] + (print-sequential + (str prefix "{") + (fn [[k v] ^System.IO.TextWriter w] + (do (print-one k w) (.Write w \space) (print-one v w))) ;;; .append + ", " + "}" + kvs w)) + + (defn- print-map [m print-one w] + (print-prefix-map nil m print-one w)) + +(defn- strip-ns + [named] + (if (symbol? named) + (symbol nil (name named)) + (keyword nil (name named)))) + +(defn- lift-ns + "Returns [lifted-ns lifted-kvs] or nil if m can't be lifted." + [m] + (when *print-namespace-maps* + (loop [ns nil + [[k v :as entry] & entries] (seq m) + kvs []] + (if entry + (when (qualified-ident? k) + (if ns + (when (= ns (namespace k)) + (recur ns entries (conj kvs [(strip-ns k) v]))) + (when-let [new-ns (namespace k)] + (recur new-ns entries (conj kvs [(strip-ns k) v]))))) + [ns kvs])))) + +(defmethod print-method clojure.lang.IPersistentMap [m, ^System.IO.TextWriter w] + (let [[ns lift-kvs] (lift-ns m)] + (if ns + (print-prefix-map (str "#:" ns) lift-kvs pr-on w) + (print-map m pr-on w)))) + +(defmethod print-dup System.Collections.IDictionary [m, ^System.IO.TextWriter w] ;;; java.util.Map + (print-ctor m #(print-map (seq %1) print-method %2) w)) + +(defmethod print-dup clojure.lang.IPersistentMap [m, ^System.IO.TextWriter w] + (print-meta m w) + (.Write w "#=(") + (.Write w (.FullName (class m))) ;; .getName => .FullName + (.Write w "/create ") + (print-map m print-dup w) + (.Write w ")")) + +;; java.util +(prefer-method print-method clojure.lang.IPersistentCollection System.Collections.ICollection) ;;; java.util.Collection +;;;(prefer-method print-method clojure.lang.IPersistentCollection java.util.RandomAccess) +;;;(prefer-method print-method java.util.RandomAccess java.util.List) +(prefer-method print-method clojure.lang.IPersistentCollection System.Collections.IDictionary) ;;; java.util.Map + +(defmethod print-method System.Collections.ICollection [c, ^System.IO.TextWriter w] ;;; java.util.List + (if *print-readably* + (do + (print-meta c w) + (print-sequential "(" pr-on " " ")" c w)) + (print-object c w))) + +;;;(defmethod print-method java.util.RandomAccess [v, ^System.IO.TextWriter w] +;;; (if *print-readably* +;;; (do +;;; (print-meta v w) +;;; (print-sequential "[" pr-on " " "]" v w)) +;;; (print-object v w))) + +(defmethod print-method System.Collections.IDictionary [m, ^System.IO.TextWriter w] ;;; java.util.Map + (if *print-readably* + (do + (print-meta m w) + (print-map m pr-on w)) + (print-object m w))) + +;;;(defmethod print-method java.util.Set [s, ^System.IO.TextWriter w] ;;; One example where we need true generic handling -- this should be ISet +;;; (if *print-readably* +;;; (do +;;; (print-meta s w) +;;; (print-sequential "#{" pr-on " " "}" (seq s) w)) +;;; (print-object s w))) + +;; Records + +(defmethod print-method clojure.lang.IRecord [r, ^System.IO.TextWriter w] + (print-meta r w) + (.Write w "#") + (.Write w (.FullName (class r))) ;; .getName => .FullName + (print-map r pr-on w)) + +(defmethod print-dup clojure.lang.IRecord [r, ^System.IO.TextWriter w] + (print-meta r w) + (.Write w "#") + (.Write w (.FullName (class r))) ;; .getName => .FullName + (if *verbose-defrecords* + (print-map r print-dup w) + (print-sequential "[" pr-on ", " "]" (vals r) w))) + +(prefer-method print-method clojure.lang.IRecord System.Collections.IDictionary) ;; java.util.Map -> System.Collections.IDictionary +(prefer-method print-method clojure.lang.IRecord clojure.lang.IPersistentMap) +(prefer-method print-dup clojure.lang.IRecord clojure.lang.IPersistentMap) +(prefer-method print-dup clojure.lang.IPersistentMap System.Collections.IDictionary) ;; java.util.Map -> System.Collections.IDictionary +(prefer-method print-dup clojure.lang.IRecord clojure.lang.IPersistentCollection) +(prefer-method print-dup clojure.lang.IRecord System.Collections.IDictionary) ;; java.util.Map -> System.Collections.IDictionary +(prefer-method print-dup clojure.lang.IRecord System.Collections.ICollection) +(prefer-method print-method clojure.lang.IRecord System.Collections.ICollection) + +(defmethod print-method clojure.lang.IPersistentSet [s, ^System.IO.TextWriter w] + (print-meta s w) + (print-sequential "#{" pr-on " " "}" (seq s) w)) + +(def ^{:tag String + :doc "Returns name string for char or nil if none" + :added "1.0"} + char-name-string + {\newline "newline" + \tab "tab" + \space "space" + \backspace "backspace" + \formfeed "formfeed" + \return "return"}) + +(defmethod print-method Char [c, ^System.IO.TextWriter w] ;;; ^Character c + (if (or *print-dup* *print-readably*) + (do (.Write w \\) + (let [n (char-name-string c)] + (if n (.Write w n) (.Write w ^Char c)))) + (.Write w ^Char c)) + nil) + +(defmethod print-dup Char [c w] (print-method c w)) ;;; java.lang.Character +;(defmethod print-dup Int32 [o w] (print-method o w)) ;;; java.lang.Integer +;(defmethod print-dup Double [o w] (print-method o w)) ;;; java.lang.Double +(defmethod print-dup clojure.lang.Ratio [o w] (print-method o w)) +(defmethod print-dup clojure.lang.BigDecimal [o w] (print-method o w)) ;;; java.math.BigDecimal +(defmethod print-dup clojure.lang.BigInt [o w] (print-method o w)) +(defmethod print-dup clojure.lang.PersistentHashMap [o w] (print-method o w)) +(defmethod print-dup clojure.lang.PersistentHashSet [o w] (print-method o w)) +(defmethod print-dup clojure.lang.PersistentVector [o w] (print-method o w)) +(defmethod print-dup clojure.lang.LazilyPersistentVector [o w] (print-method o w)) + +;;; ADDED LINES +(defmethod print-method clojure.lang.Ratio [o ^System.IO.TextWriter w] (.Write w (str o))) +(defmethod print-dup clojure.lang.BigInteger [o ^System.IO.TextWriter w] + (.Write w "#=(clojure.lang.BigInteger/Parse ") + (print-dup (str o) w) + (.Write w ")")) + + + +(def primitives-classnames ;; not clear what the equiv should be + {Single "System.Single" ;;{Float/TYPE "Float/TYPE" + Int32 "System.Int32" ;; Integer/TYPE "Integer/TYPE" + Int64 "System.Int64" ;; Long/TYPE "Long/TYPE" + Boolean "System.Boolean" ;; Boolean/TYPE "Boolean/TYPE" + Char "System.Char" ;; Character/TYPE "Character/TYPE" + Double "System.Double" ;; Double/TYPE "Double/TYPE" + Byte "System.Byte" ;; Byte/TYPE "Byte/TYPE" + Int16 "System.Int16" ;; Short/TYPE "Short/TYPE"}) + SByte "System.SByte" ;; ADDED + UInt16 "System.UInt16" ;; ADDED + UInt32 "System.UInt32" ;; ADDED + UInt64 "System.UInt64" ;; ADDED + Decimal "System.Decimal" }) ;; ADDED + +(defmethod print-method Type [^Type c, ^System.IO.TextWriter w] + (.Write w (.FullName c))) ;;; .getName => .FullName + +(defmethod print-dup Type [^Type c, ^System.IO.TextWriter w] + (cond + (.IsPrimitive c) (do ;; .isPrimitive + (.Write w "#=(identity ") + (.Write w ^String (primitives-classnames c)) + (.Write w ")")) + (.IsArray c) (do ;; .isArray , java.lang.Class/forName => + (.Write w "#=(clojure.lang.RT/classForName \"") + (.Write w (.FullName c)) ;; .getName => .FullName + (.Write w "\")")) + :else (do + (.Write w "#=") + (.Write w (.FullName c))))) ;;; .getName => .FullName + +(defmethod print-method clojure.lang.BigDecimal [b, ^System.IO.TextWriter w] ;;; java.math.BigDecimal + (.Write w (str b)) + (.Write w "M")) + +(defmethod print-method clojure.lang.BigInt [b, ^System.IO.TextWriter w] + (.Write w (str b)) + (.Write w "N")) + +(defmethod print-method System.Text.RegularExpressions.Regex [p ^System.IO.TextWriter w] ;;; java.util.regex.Pattern => + (.Write w "#\"") + (loop [[^Char c & r :as s] (seq (.ToString ^System.Text.RegularExpressions.Regex p)) ;;; .pattern => .ToString + qmode false] + (when s + (cond + (= c \\) (let [[^Char c2 & r2] r] + (.Write w \\) + (.Write w c2) + (if qmode + (recur r2 (not= c2 \E)) + (recur r2 (= c2 \Q)))) + (= c \") (do + (if qmode + (.Write w "\\E\\\"\\Q") + (.Write w "\\\"")) + (recur r qmode)) + :else (do + (.Write w c) + (recur r qmode))))) + (.Write w \")) + +(defmethod print-dup System.Text.RegularExpressions.Regex [p ^System.IO.TextWriter w] (print-method p w)) ;;; java.util.regex.Pattern => + +(defmethod print-dup clojure.lang.Namespace [^clojure.lang.Namespace n ^System.IO.TextWriter w] + (.Write w "#=(find-ns ") + (print-dup (.Name n) w) ;; .name + (.Write w ")")) + +(defn- deref-as-map [^clojure.lang.IDeref o] + (let [pending (and (instance? clojure.lang.IPending o) + (not (.isRealized ^clojure.lang.IPending o))) + [ex val] + (when-not pending + (try [false (deref o)] + (catch Exception e ;;; Throwable + [true e])))] + {:status + (cond + (or ex + (and (instance? clojure.lang.Agent o) + (agent-error o))) + :failed + + pending + :pending + + :else + :ready) + + :val val})) + +(defmethod print-method clojure.lang.IDeref [o ^System.IO.TextWriter w] + (print-tagged-object o (deref-as-map o) w)) + +(defmethod print-method System.Diagnostics.StackFrame [^System.Diagnostics.StackFrame o ^System.IO.TextWriter w] ;;; StackTraceElement ^StackTraceElement + (print-method [(symbol (.FullName (.GetType o))) (symbol (.Name (.GetMethod o))) (.GetFileName o) (.GetFileLineNumber o)] w)) ;;; (.getClassName o) (.getMethodName o) .getFileName .getLineNumber + +(defn StackTraceElement->vec + "Constructs a data representation for a StackTraceElement: [class method file line]" + {:added "1.9"} + [^System.Diagnostics.StackFrame o] + (if (nil? o) + nil + [(symbol (.FullName (.GetType o))) + (if-let [m (.GetMethod o)] + (symbol (.Name m)) + "NO_METHOD") + (or (.GetFileName o) "NO_FILE") + (.GetFileLineNumber o)])) + +(defn Throwable->map + "Constructs a data representation for a Throwable with keys: + :cause - root cause message + :phase - error phase + :via - cause chain, with cause keys: + :type - exception class symbol + :message - exception message + :data - ex-data + :at - top stack element + :trace - root cause stack elements" + {:added "1.7"} + [^Exception o] ;;; ^Throwable + (let [base (fn [^Exception t] ;;; ^Throwable + (merge {:type (symbol (.FullName (class t)))} ;;; .getName + (when-let [msg (.Message t)] ;;; .getLocalizedMessage + {:message msg}) + (when-let [ed (ex-data t)] + {:data ed}) + (let [st (.GetFrames (System.Diagnostics.StackTrace. t true))] ;;; (.getStackTrace t) + (when (and st (pos? (alength st))) ;;; added the 'and st' because we may get a null back instread of an array. + {:at (StackTraceElement->vec (aget st 0))})))) ;;; aget + via (loop [via [], ^Exception t o] ;;; ^Throwable + (if t + (recur (conj via t) (.InnerException t)) ;;; .getCause + via)) + ^Exception root (peek via)] ;;; Throwable + (merge {:via (vec (map base via)) + :trace (vec (map StackTraceElement->vec + (.GetFrames (System.Diagnostics.StackTrace. (or root o) true))))} ;;; .getStackTrace ^Throwable + (when-let [root-msg (.Message root)] ;;; (.getLocalizedMessage root) + {:cause root-msg}) + (when-let [data (ex-data root)] + {:data data}) + (when-let [phase (-> o ex-data :clojure.error/phase)] + {:phase phase})))) + +(defn print-throwable [^Exception o ^System.IO.TextWriter w] ;;; ^Throwable + (.Write w "#error {\n :cause ") + (let [{:keys [cause data via trace]} (Throwable->map o) + print-via #(do (.Write w "{:type ") + (print-method (:type %) w) + (.Write w "\n :message ") + (print-method (:message %) w) + (when-let [data (:data %)] + (.Write w "\n :data ") + (print-method data w)) + (when-let [at (:at %)] + (.Write w "\n :at ") + (print-method (:at %) w)) + (.Write w "}"))] + (print-method cause w) + (when data + (.Write w "\n :data ") + (print-method data w)) + (when via + (.Write w "\n :via\n [") + (when-let [fv (first via)] + (print-via fv) + (doseq [v (rest via)] + (.Write w "\n ") + (print-via v))) + (.Write w "]")) + (when trace + (.Write w "\n :trace\n [") + (when-let [ft (first trace)] + (print-method ft w) + (doseq [t (rest trace)] + (.Write w "\n ") + (print-method t w))) + (.Write w "]"))) + (.Write w "}")) + +(defmethod print-method Exception [^Exception o ^System.IO.TextWriter w] ;;; Throwable ^Throwable + (print-throwable o w)) + +(defmethod print-method clojure.lang.TaggedLiteral [o ^System.IO.TextWriter w] + (.Write w "#") + (print-method (:tag o) w) + (.Write w " ") + (print-method (:form o) w)) + +(defmethod print-method clojure.lang.ReaderConditional [o ^System.IO.TextWriter w] + (.Write w "#?") + (when (:splicing? o) (.Write w "@")) + (print-method (:form o) w)) + +(def ^{:private true :dynamic true} print-initialized true) + +;;;(defn ^java.io.PrintWriter PrintWriter-on +;;; "implements java.io.PrintWriter given flush-fn, which will be called +;;; when .flush() is called, with a string built up since the last call to .flush(). +;;; if not nil, close-fn will be called with no arguments when .close is called" +;;; {:added "1.10"} +;;; [flush-fn close-fn] +;;; (let [sb (StringBuilder.)] +;;; (-> (proxy [Writer] [] +;;; (flush [] +;;; (when (pos? (.length sb)) +;;; (flush-fn (.toString sb))) +;;; (.setLength sb 0)) +;;; (close [] +;;; (.flush ^Writer this) +;;; (when close-fn (close-fn)) +;;; nil) +;;; (write [str-cbuf off len] +;;; (when (pos? len) +;;; (if (instance? String str-cbuf) +;;; (.append sb ^String str-cbuf ^int off ^int len) +;;; (.append sb ^chars str-cbuf ^int off ^int len))))) +;;; java.io.BufferedWriter. +;;; java.io.PrintWriter.))) + +(defn ^System.IO.TextWriter PrintWriter-on + [flush-fn close-fn] + (proxy [System.IO.StringWriter] [] + (Flush [] + (let [^System.IO.StringWriter this this] + (proxy-super Flush)) + (let [sb (.GetStringBuilder ^System.IO.StringWriter this)] + (when (pos? (.Length sb)) + (flush-fn (.ToString sb))) + (.set_Length sb 0))) + (Close [] + (.Flush ^System.IO.StringWriter this) + (when close-fn (close-fn)) + (let [^System.IO.StringWriter this this] + (proxy-super Close)) + nil))) + + diff --git a/Clojure/Clojure.Source/clojure/core_proxy.clj b/Clojure/Clojure.Source/clojure/core_proxy.clj index 57d4062f9..4ac30dad1 100644 --- a/Clojure/Clojure.Source/clojure/core_proxy.clj +++ b/Clojure/Clojure.Source/clojure/core_proxy.clj @@ -33,9 +33,9 @@ (or (some (fn [t] (when (every? #(isa? t %) rtypes) t)) rtypes) (throw (Exception. "Incompatible return types")))) -(defn- group-by-sig - "Takes a collection of [msig meth] and returns a seq of maps from - return-types to meths." +(defn- group-by-sig + "Takes a collection of [msig meth] and returns a seq of maps from + return-types to meths." [coll] (vals (reduce1 (fn [m [msig meth]] (let [rtype (peek msig) @@ -46,19 +46,19 @@ (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 + (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))]))))) (defn- generate-proxy [^Type super interfaces attributes] ;;; Class (clojure.lang.GenProxy/GenerateProxyClass super interfaces attributes (proxy-name super interfaces))) ;;;DM;; ;;; (let [cv (new ClassWriter (. ClassWriter COMPUTE_MAXS)) -;;; pname (proxy-name super interfaces) +;;; pname (proxy-name super interfaces) ;;; cname (.replace pname \. \/) ;(str "clojure/lang/" (gensym "Proxy__"));;; ctype (. Type (getObjectType cname)) ;;; iname (fn [^Class c] (.. Type (getType c) (getInternalName))) ;;; fmap "__clojureFnMap" @@ -162,21 +162,21 @@ ;;; ;;; (. gen (returnValue)) ;;; (. gen (endMethod))))) -;;; ;disable serialization -;;; (when (some #(isa? % Serializable) (cons super interfaces)) -;;; (let [m (. Method (getMethod "void writeObject(java.io.ObjectOutputStream)")) -;;; gen (new GeneratorAdapter (. Opcodes ACC_PRIVATE) m nil nil cv)] -;;; (. gen (visitCode)) -;;; (. gen (loadThis)) -;;; (. gen (loadArgs)) -;;; (. gen (throwException (totype NotSerializableException) pname)) -;;; (. gen (endMethod))) -;;; (let [m (. Method (getMethod "void readObject(java.io.ObjectInputStream)")) -;;; gen (new GeneratorAdapter (. Opcodes ACC_PRIVATE) m nil nil cv)] -;;; (. gen (visitCode)) -;;; (. gen (loadThis)) -;;; (. gen (loadArgs)) -;;; (. gen (throwException (totype NotSerializableException) pname)) +;;; ;disable serialization +;;; (when (some #(isa? % Serializable) (cons super interfaces)) +;;; (let [m (. Method (getMethod "void writeObject(java.io.ObjectOutputStream)")) +;;; gen (new GeneratorAdapter (. Opcodes ACC_PRIVATE) m nil nil cv)] +;;; (. gen (visitCode)) +;;; (. gen (loadThis)) +;;; (. gen (loadArgs)) +;;; (. gen (throwException (totype NotSerializableException) pname)) +;;; (. gen (endMethod))) +;;; (let [m (. Method (getMethod "void readObject(java.io.ObjectInputStream)")) +;;; gen (new GeneratorAdapter (. Opcodes ACC_PRIVATE) m nil nil cv)] +;;; (. gen (visitCode)) +;;; (. gen (loadThis)) +;;; (. gen (loadArgs)) +;;; (. gen (throwException (totype NotSerializableException) pname)) ;;; (. gen (endMethod)))) ;;; ;add IProxy methods ;;; (let [m (. Method (getMethod "void __initClojureFnMappings(clojure.lang.IPersistentMap)")) @@ -245,15 +245,15 @@ ;;; mb (map #(vector (%1 %2) (vals (dissoc %1 %2))) mgroups rtypes) ;;; bridge? (reduce into #{} (map second mb)) ;;; ifaces-meths (remove bridge? (vals ifaces-meths)) -;;; mm (remove bridge? (vals mm)) -;;; reflect-Method-keyfn (fn [meth] -;;; (let [[name param-types ^Class return-type] (method-sig meth)] -;;; (-> [name] -;;; (into1 (map #(.getName ^Class %) param-types)) -;;; (conj (.getName return-type)))))] +;;; mm (remove bridge? (vals mm)) +;;; reflect-Method-keyfn (fn [meth] +;;; (let [[name param-types ^Class return-type] (method-sig meth)] +;;; (-> [name] +;;; (into1 (map #(.getName ^Class %) param-types)) +;;; (conj (.getName return-type)))))] ;;; ;add methods matching supers', if ;;; ;add methods matching supers', if no mapping -> call super -;;; (doseq [[^java.lang.reflect.Method dest bridges] (sort-by (comp reflect-Method-keyfn first) mb) +;;; (doseq [[^java.lang.reflect.Method dest bridges] (sort-by (comp reflect-Method-keyfn first) mb) ;;; ^java.lang.reflect.Method meth (sort-by reflect-Method-keyfn bridges)] ;;; (gen-bridge meth dest)) ;;; (doseq [^java.lang.reflect.Method meth (sort-by reflect-Method-keyfn mm)] @@ -289,7 +289,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 attributes] (get-super-and-interfaces bases) pname (proxy-name super interfaces)] @@ -300,7 +300,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 @@ -310,7 +310,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) @@ -325,14 +325,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))) @@ -360,7 +360,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) @@ -370,7 +370,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)] @@ -394,21 +394,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] @@ -425,11 +425,11 @@ ;;; snapshot (fn [] ;;; (reduce (fn [m e] ;;; (assoc m (key e) ((val e)))) -;;; {} (seq pmap))) -;;; thisfn (fn thisfn [plseq] -;;; (lazy-seq -;;; (when-let [pseq (seq plseq)] -;;; (cons (clojure.lang.MapEntry/create (first pseq) (v (first pseq))) +;;; {} (seq pmap))) +;;; thisfn (fn thisfn [plseq] +;;; (lazy-seq +;;; (when-let [pseq (seq plseq)] +;;; (cons (clojure.lang.MapEntry/create (first pseq) (v (first pseq))) ;;; (thisfn (rest pseq))))))] ;;; (proxy [clojure.lang.APersistentMap] ;;; [] diff --git a/Clojure/Clojure.Source/clojure/datafy.clj b/Clojure/Clojure.Source/clojure/datafy.clj index 1484c7241..131418d26 100644 --- a/Clojure/Clojure.Source/clojure/datafy.clj +++ b/Clojure/Clojure.Source/clojure/datafy.clj @@ -1,62 +1,62 @@ -; 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. - -(ns ^{:doc "Functions to turn objects into data. Alpha, subject to change"} - clojure.datafy - (:require [clojure.core.protocols :as p])) - -(set! *warn-on-reflection* true) - -(defn datafy - "Attempts to return x as data. - datafy will return the value of clojure.core.protocols/datafy. If - the value has been transformed and the result supports - metadata, :clojure.datafy/obj will be set on the metadata to the - original value of x, and :clojure.datafy/class to the name of the - class of x, as a symbol." - [x] - (let [v (p/datafy x)] - (if (identical? v x) - v - (if (instance? clojure.lang.IObj v) - (vary-meta v assoc ::obj x ::class (-> x class .Name symbol)) ;;; .getName - v)))) - -(defn nav - "Returns (possibly transformed) v in the context of coll and k (a - key/index or nil). Callers should attempt to provide the key/index - context k for Indexed/Associative/ILookup colls if possible, but not - to fabricate one e.g. for sequences (pass nil). nav returns the - value of clojure.core.protocols/nav." - [coll k v] - (p/nav coll k v)) - -(defn- sortmap [m] - (into (sorted-map) m)) - -(extend-protocol p/Datafiable - Exception ;;; Throwable - (datafy [x] - (Throwable->map x)) - - clojure.lang.IRef - (datafy [r] - (with-meta [(deref r)] (meta r))) - - clojure.lang.Namespace - (datafy [n] - (with-meta {:name (.getName n) - :publics (-> n ns-publics sortmap) - :imports (-> n ns-imports sortmap) - :interns (-> n ns-interns sortmap)} - (meta n))) - - System.Type ;;; java.lang.Class - (datafy [c] - (let [{:keys [members] :as ret} ((requiring-resolve 'clojure.reflect/reflect) c)] +; 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. + +(ns ^{:doc "Functions to turn objects into data. Alpha, subject to change"} + clojure.datafy + (:require [clojure.core.protocols :as p])) + +(set! *warn-on-reflection* true) + +(defn datafy + "Attempts to return x as data. + datafy will return the value of clojure.core.protocols/datafy. If + the value has been transformed and the result supports + metadata, :clojure.datafy/obj will be set on the metadata to the + original value of x, and :clojure.datafy/class to the name of the + class of x, as a symbol." + [x] + (let [v (p/datafy x)] + (if (identical? v x) + v + (if (instance? clojure.lang.IObj v) + (vary-meta v assoc ::obj x ::class (-> x class .Name symbol)) ;;; .getName + v)))) + +(defn nav + "Returns (possibly transformed) v in the context of coll and k (a + key/index or nil). Callers should attempt to provide the key/index + context k for Indexed/Associative/ILookup colls if possible, but not + to fabricate one e.g. for sequences (pass nil). nav returns the + value of clojure.core.protocols/nav." + [coll k v] + (p/nav coll k v)) + +(defn- sortmap [m] + (into (sorted-map) m)) + +(extend-protocol p/Datafiable + Exception ;;; Throwable + (datafy [x] + (Throwable->map x)) + + clojure.lang.IRef + (datafy [r] + (with-meta [(deref r)] (meta r))) + + clojure.lang.Namespace + (datafy [n] + (with-meta {:name (.getName n) + :publics (-> n ns-publics sortmap) + :imports (-> n ns-imports sortmap) + :interns (-> n ns-interns sortmap)} + (meta n))) + + System.Type ;;; java.lang.Class + (datafy [c] + (let [{:keys [members] :as ret} ((requiring-resolve 'clojure.reflect/reflect) c)] (assoc ret :name (-> c .Name symbol) :members (->> members (group-by :name) sortmap))))) ;;; .getName \ No newline at end of file diff --git a/Clojure/Clojure.Source/clojure/genclass.clj b/Clojure/Clojure.Source/clojure/genclass.clj index 87084118d..42e45ca8e 100644 --- a/Clojure/Clojure.Source/clojure/genclass.clj +++ b/Clojure/Clojure.Source/clojure/genclass.clj @@ -9,290 +9,290 @@ ; DM: This is one of the few bootstrap *.clj files where I did not even try to do a line-by-line ; modification of the JVM version. Too many differences. ; I put more of the support into C# rather than in Clojure, just so I could bang out the code quicker. -; This could be redone eventually. - - - (in-ns 'clojure.core) - - (import '(System.Reflection ConstructorInfo)) - - ;;; The options-handling code here is taken from the JVM version. - - - (defn- ctor-sigs [^Type super] - (for [^ConstructorInfo ctor (.GetConstructors super) - :when (not (.IsPrivate ctor))] - (apply vector (map #(.ParameterType %) (.GetParameters ctor))))) - - - (def ^{:private true} prim->class - {'int Int32 - 'ints (Type/GetType "System.Int32[]") - 'long Int64 - 'longs (Type/GetType "System.Int64[]") - 'float Single - 'floats (Type/GetType "System.Single[]") - 'double Double - 'doubles (Type/GetType "System.Double[]") - 'void System.Void - 'short Int16 - 'shorts (Type/GetType "System.Int16[]") - 'boolean Boolean - 'booleans (Type/GetType "System.Boolean[]") - 'byte Byte - 'bytes (Type/GetType "System.Byte[]") - 'sbyte SByte - 'sbytes (Type/GetType "System.SByte[]") - 'ushort UInt16 - 'ushorts (Type/GetType "System.UInt16[]") - 'uint UInt32 - 'uints (Type/GetType "System.UInt32[]") - 'ulong UInt64 - 'ulongs (Type/GetType "System.UInt64[]") - 'char Char - 'chars (Type/GetType "System.Char[]")}) - - - (defn- ^Type the-class [x] ;;; ^Class - (cond - (class? x) x - (contains? prim->class x) (prim->class x) - :else (let [strx (str x)] - (clojure.lang.RT/classForName - (if (some #{\. \[} strx) - strx - (str "System." strx)))))) ;;;(str "java.lang." strx)))))) - - (defn- the-class-maybe-by-ref [x] - (cond - (seq? x) (list (first x) (the-class (second x))) ; (by-ref v) - :else (the-class x))) - -;; someday this can be made codepoint aware -(defn- valid-java-method-name - [^String s] - (= s (clojure.lang.Compiler/munge s))) - -(defn- validate-generate-class-options - [{:keys [methods]}] - (let [[mname] (remove valid-java-method-name (map (comp str first) methods))] - (when mname (throw (ArgumentException. (str "Not a valid method name: " mname)))))) ;;; IllegalArgumentException. - - (defn- generate-class [options-map] - (validate-generate-class-options options-map) - (let [default-options {:prefix "-" :load-impl-ns true :impl-ns (ns-name *ns*)} - {:keys [name extends implements constructors methods main factory state init exposes - exposes-methods prefix load-impl-ns impl-ns post-init class-attributes]} ;;; DM: Added class-attributes - (merge default-options options-map) - name (str name) - super (if extends (the-class extends) Object) - interfaces (map the-class implements) - supers (cons super interfaces) - ctor-sig-map (doall (or constructors (zipmap (ctor-sigs super) (ctor-sigs super)))) - class-mapper (fn [coll] (with-meta (doall (map the-class coll)) (meta coll))) - ctor-sig-type-map (doall (zipmap (doall (map class-mapper (keys ctor-sig-map))) (doall (map class-mapper (vals ctor-sig-map))))) - cname (. name (Replace "." "/")) - pkg-name name - impl-pkg-name (str impl-ns) - impl-cname (.. impl-pkg-name (Replace "." "/") (Replace \- \_)) - init-name (str init) - post-init-name (str post-init) - factory-name (str factory) - state-name (str state) - main-name "main" - class-attributes (extract-attributes class-attributes) - methods (map (fn [x] [(nth x 0) - (map the-class (nth x 1)) - (the-class (nth x 2)) - (:static (meta x))]) - methods) - ] - (clojure.lang.GenClass/GenerateClass - name super (seq interfaces) - (seq ctor-sig-map) (seq ctor-sig-type-map) (seq methods) - exposes exposes-methods - prefix (. clojure.lang.RT booleanCast main) - factory-name state-name - init-name post-init-name - impl-cname impl-pkg-name - (. clojure.lang.RT booleanCast load-impl-ns) - class-attributes))) - - - (defmacro gen-class - "When compiling, generates compiled bytecode for a class with the - given package-qualified :name (which, as all names in these - parameters, can be a string or symbol), and writes the .class file - to the *compile-path* directory. When not compiling, does - nothing. The gen-class construct contains no implementation, as the - implementation will be dynamically sought by the generated class in - functions in an implementing Clojure namespace. Given a generated - class org.mydomain.MyClass with a method named mymethod, gen-class - will generate an implementation that looks for a function named by - (str prefix mymethod) (default prefix: \"-\") in a - Clojure namespace specified by :impl-ns - (defaults to the current namespace). All inherited methods, - generated methods, and init and main functions (see :methods, :init, - and :main below) will be found similarly prefixed. By default, the - static initializer for the generated class will attempt to load the - Clojure support code for the class as a resource from the classpath, - e.g. in the example case, ``org/mydomain/MyClass__init.class``. This - behavior can be controlled by :load-impl-ns - - Note that methods with a maximum of 18 parameters are supported. - - In all subsequent sections taking types, the primitive types can be - referred to by their Java names (int, float etc), and classes in the - java.lang package can be used without a package qualifier. All other - classes must be fully qualified. - - Options should be a set of key/value pairs, all except for :name are optional: - - :name aname - - The package-qualified name of the class to be generated - - :extends aclass - - Specifies the superclass, the non-private methods of which will be - overridden by the class. If not provided, defaults to Object. - - :implements [interface ...] - - One or more interfaces, the methods of which will be implemented by the class. - - :init name - - If supplied, names a function that will be called with the arguments - to the constructor. Must return [ [superclass-constructor-args] state] - If not supplied, the constructor args are passed directly to - the superclass constructor and the state will be nil - - :constructors {[param-types] [super-param-types], ...} - - By default, constructors are created for the generated class which - match the signature(s) of the constructors for the superclass. This - parameter may be used to explicitly specify constructors, each entry - providing a mapping from a constructor signature to a superclass - constructor signature. When you supply this, you must supply an :init - specifier. - - :post-init name - - If supplied, names a function that will be called with the object as - the first argument, followed by the arguments to the constructor. - It will be called every time an object of this class is created, - immediately after all the inherited constructors have completed. - Its return value is ignored. - - :methods [ [name [param-types] return-type], ...] - - The generated class automatically defines all of the non-private - methods of its superclasses/interfaces. This parameter can be used - to specify the signatures of additional methods of the generated - class. Static methods can be specified with ^{:static true} in the - signature's metadata. Do not repeat superclass/interface signatures - here. - - :main boolean - - If supplied and true, a static public main function will be generated. It will - pass each string of the String[] argument as a separate argument to - a function called (str prefix main). - - :factory name - - If supplied, a (set of) public static factory function(s) will be - created with the given name, and the same signature(s) as the - constructor(s). - - :state name - - If supplied, a public final instance field with the given name will be - created. You must supply an :init function in order to provide a - value for the state. Note that, though final, the state can be a ref - or agent, supporting the creation of Java objects with transactional - or asynchronous mutation semantics. - - :exposes {protected-field-name {:get name :set name}, ...} - - Since the implementations of the methods of the generated class - occur in Clojure functions, they have no access to the inherited - protected fields of the superclass. This parameter can be used to - generate public getter/setter methods exposing the protected field(s) - for use in the implementation. - - :exposes-methods {super-method-name exposed-name, ...} - - It is sometimes necessary to call the superclass' implementation of an - overridden method. Those methods may be exposed and referred in - the new method implementation by a local name. - - :prefix string - - Default: \"-\" Methods called e.g. Foo will be looked up in vars called - prefixFoo in the implementing ns. - - :impl-ns name - - Default: the name of the current ns. Implementations of methods will be - looked up in this namespace. - - :load-impl-ns boolean - - Default: true. Causes the static initializer for the generated class - to reference the load code for the implementing namespace. Should be - true when implementing-ns is the default, false if you intend to - load the code via some other method." - {:added "1.0"} - - [& options] - (let [x *compile-files*] - (when *compile-files* - (let [options-map (into1 {} (map vec (partition 2 options)))] - `'~(generate-class options-map))))) - - - -;;;;;;;;;;;;;;;;;;;; gen-interface ;;;;;;;;;;;;;;;;;;;;;; -;; based on original contribution by Chris Houser - -(defn- generate-interface - [{:keys [name extends methods]}] - (let [extendTypes (map the-class extends) - methodSigs (map (fn [[mname pclasses rclass pmetas]] [mname (map the-class-maybe-by-ref pclasses) (the-class rclass) pmetas]) methods)] - (clojure.lang.GenInterface/GenerateInterface (str name) (extract-attributes (meta name)) extendTypes methodSigs))) - - -(defmacro gen-interface - "When compiling, generates compiled bytecode for an interface with - the given package-qualified :name (which, as all names in these - parameters, can be a string or symbol), and writes the .class file - to the *compile-path* directory. When not compiling, does nothing. - - In all subsequent sections taking types, the primitive types can be - referred to by their Java names (int, float etc), and classes in the - java.lang package can be used without a package qualifier. All other - classes must be fully qualified. - - Options should be a set of key/value pairs, all except for :name are - optional: - - :name aname - - The package-qualified name of the class to be generated - - :extends [interface ...] - - One or more interfaces, which will be extended by this interface. - - :methods [ [name [param-types] return-type], ...] - - This parameter is used to specify the signatures of the methods of - the generated interface. Do not repeat superinterface signatures - here." - {:added "1.0"} - - [& options] - (let [options-map (into1 {} (map vec (partition 2 options))) ] +; This could be redone eventually. + + + (in-ns 'clojure.core) + + (import '(System.Reflection ConstructorInfo)) + + ;;; The options-handling code here is taken from the JVM version. + + + (defn- ctor-sigs [^Type super] + (for [^ConstructorInfo ctor (.GetConstructors super) + :when (not (.IsPrivate ctor))] + (apply vector (map #(.ParameterType %) (.GetParameters ctor))))) + + + (def ^{:private true} prim->class + {'int Int32 + 'ints (Type/GetType "System.Int32[]") + 'long Int64 + 'longs (Type/GetType "System.Int64[]") + 'float Single + 'floats (Type/GetType "System.Single[]") + 'double Double + 'doubles (Type/GetType "System.Double[]") + 'void System.Void + 'short Int16 + 'shorts (Type/GetType "System.Int16[]") + 'boolean Boolean + 'booleans (Type/GetType "System.Boolean[]") + 'byte Byte + 'bytes (Type/GetType "System.Byte[]") + 'sbyte SByte + 'sbytes (Type/GetType "System.SByte[]") + 'ushort UInt16 + 'ushorts (Type/GetType "System.UInt16[]") + 'uint UInt32 + 'uints (Type/GetType "System.UInt32[]") + 'ulong UInt64 + 'ulongs (Type/GetType "System.UInt64[]") + 'char Char + 'chars (Type/GetType "System.Char[]")}) + + + (defn- ^Type the-class [x] ;;; ^Class + (cond + (class? x) x + (contains? prim->class x) (prim->class x) + :else (let [strx (str x)] + (clojure.lang.RT/classForName + (if (some #{\. \[} strx) + strx + (str "System." strx)))))) ;;;(str "java.lang." strx)))))) + + (defn- the-class-maybe-by-ref [x] + (cond + (seq? x) (list (first x) (the-class (second x))) ; (by-ref v) + :else (the-class x))) + +;; someday this can be made codepoint aware +(defn- valid-java-method-name + [^String s] + (= s (clojure.lang.Compiler/munge s))) + +(defn- validate-generate-class-options + [{:keys [methods]}] + (let [[mname] (remove valid-java-method-name (map (comp str first) methods))] + (when mname (throw (ArgumentException. (str "Not a valid method name: " mname)))))) ;;; IllegalArgumentException. + + (defn- generate-class [options-map] + (validate-generate-class-options options-map) + (let [default-options {:prefix "-" :load-impl-ns true :impl-ns (ns-name *ns*)} + {:keys [name extends implements constructors methods main factory state init exposes + exposes-methods prefix load-impl-ns impl-ns post-init class-attributes]} ;;; DM: Added class-attributes + (merge default-options options-map) + name (str name) + super (if extends (the-class extends) Object) + interfaces (map the-class implements) + supers (cons super interfaces) + ctor-sig-map (doall (or constructors (zipmap (ctor-sigs super) (ctor-sigs super)))) + class-mapper (fn [coll] (with-meta (doall (map the-class coll)) (meta coll))) + ctor-sig-type-map (doall (zipmap (doall (map class-mapper (keys ctor-sig-map))) (doall (map class-mapper (vals ctor-sig-map))))) + cname (. name (Replace "." "/")) + pkg-name name + impl-pkg-name (str impl-ns) + impl-cname (.. impl-pkg-name (Replace "." "/") (Replace \- \_)) + init-name (str init) + post-init-name (str post-init) + factory-name (str factory) + state-name (str state) + main-name "main" + class-attributes (extract-attributes class-attributes) + methods (map (fn [x] [(nth x 0) + (map the-class (nth x 1)) + (the-class (nth x 2)) + (:static (meta x))]) + methods) + ] + (clojure.lang.GenClass/GenerateClass + name super (seq interfaces) + (seq ctor-sig-map) (seq ctor-sig-type-map) (seq methods) + exposes exposes-methods + prefix (. clojure.lang.RT booleanCast main) + factory-name state-name + init-name post-init-name + impl-cname impl-pkg-name + (. clojure.lang.RT booleanCast load-impl-ns) + class-attributes))) + + + (defmacro gen-class + "When compiling, generates compiled bytecode for a class with the + given package-qualified :name (which, as all names in these + parameters, can be a string or symbol), and writes the .class file + to the *compile-path* directory. When not compiling, does + nothing. The gen-class construct contains no implementation, as the + implementation will be dynamically sought by the generated class in + functions in an implementing Clojure namespace. Given a generated + class org.mydomain.MyClass with a method named mymethod, gen-class + will generate an implementation that looks for a function named by + (str prefix mymethod) (default prefix: \"-\") in a + Clojure namespace specified by :impl-ns + (defaults to the current namespace). All inherited methods, + generated methods, and init and main functions (see :methods, :init, + and :main below) will be found similarly prefixed. By default, the + static initializer for the generated class will attempt to load the + Clojure support code for the class as a resource from the classpath, + e.g. in the example case, ``org/mydomain/MyClass__init.class``. This + behavior can be controlled by :load-impl-ns + + Note that methods with a maximum of 18 parameters are supported. + + In all subsequent sections taking types, the primitive types can be + referred to by their Java names (int, float etc), and classes in the + java.lang package can be used without a package qualifier. All other + classes must be fully qualified. + + Options should be a set of key/value pairs, all except for :name are optional: + + :name aname + + The package-qualified name of the class to be generated + + :extends aclass + + Specifies the superclass, the non-private methods of which will be + overridden by the class. If not provided, defaults to Object. + + :implements [interface ...] + + One or more interfaces, the methods of which will be implemented by the class. + + :init name + + If supplied, names a function that will be called with the arguments + to the constructor. Must return [ [superclass-constructor-args] state] + If not supplied, the constructor args are passed directly to + the superclass constructor and the state will be nil + + :constructors {[param-types] [super-param-types], ...} + + By default, constructors are created for the generated class which + match the signature(s) of the constructors for the superclass. This + parameter may be used to explicitly specify constructors, each entry + providing a mapping from a constructor signature to a superclass + constructor signature. When you supply this, you must supply an :init + specifier. + + :post-init name + + If supplied, names a function that will be called with the object as + the first argument, followed by the arguments to the constructor. + It will be called every time an object of this class is created, + immediately after all the inherited constructors have completed. + Its return value is ignored. + + :methods [ [name [param-types] return-type], ...] + + The generated class automatically defines all of the non-private + methods of its superclasses/interfaces. This parameter can be used + to specify the signatures of additional methods of the generated + class. Static methods can be specified with ^{:static true} in the + signature's metadata. Do not repeat superclass/interface signatures + here. + + :main boolean + + If supplied and true, a static public main function will be generated. It will + pass each string of the String[] argument as a separate argument to + a function called (str prefix main). + + :factory name + + If supplied, a (set of) public static factory function(s) will be + created with the given name, and the same signature(s) as the + constructor(s). + + :state name + + If supplied, a public final instance field with the given name will be + created. You must supply an :init function in order to provide a + value for the state. Note that, though final, the state can be a ref + or agent, supporting the creation of Java objects with transactional + or asynchronous mutation semantics. + + :exposes {protected-field-name {:get name :set name}, ...} + + Since the implementations of the methods of the generated class + occur in Clojure functions, they have no access to the inherited + protected fields of the superclass. This parameter can be used to + generate public getter/setter methods exposing the protected field(s) + for use in the implementation. + + :exposes-methods {super-method-name exposed-name, ...} + + It is sometimes necessary to call the superclass' implementation of an + overridden method. Those methods may be exposed and referred in + the new method implementation by a local name. + + :prefix string + + Default: \"-\" Methods called e.g. Foo will be looked up in vars called + prefixFoo in the implementing ns. + + :impl-ns name + + Default: the name of the current ns. Implementations of methods will be + looked up in this namespace. + + :load-impl-ns boolean + + Default: true. Causes the static initializer for the generated class + to reference the load code for the implementing namespace. Should be + true when implementing-ns is the default, false if you intend to + load the code via some other method." + {:added "1.0"} + + [& options] + (let [x *compile-files*] + (when *compile-files* + (let [options-map (into1 {} (map vec (partition 2 options)))] + `'~(generate-class options-map))))) + + + +;;;;;;;;;;;;;;;;;;;; gen-interface ;;;;;;;;;;;;;;;;;;;;;; +;; based on original contribution by Chris Houser + +(defn- generate-interface + [{:keys [name extends methods]}] + (let [extendTypes (map the-class extends) + methodSigs (map (fn [[mname pclasses rclass pmetas]] [mname (map the-class-maybe-by-ref pclasses) (the-class rclass) pmetas]) methods)] + (clojure.lang.GenInterface/GenerateInterface (str name) (extract-attributes (meta name)) extendTypes methodSigs))) + + +(defmacro gen-interface + "When compiling, generates compiled bytecode for an interface with + the given package-qualified :name (which, as all names in these + parameters, can be a string or symbol), and writes the .class file + to the *compile-path* directory. When not compiling, does nothing. + + In all subsequent sections taking types, the primitive types can be + referred to by their Java names (int, float etc), and classes in the + java.lang package can be used without a package qualifier. All other + classes must be fully qualified. + + Options should be a set of key/value pairs, all except for :name are + optional: + + :name aname + + The package-qualified name of the class to be generated + + :extends [interface ...] + + One or more interfaces, which will be extended by this interface. + + :methods [ [name [param-types] return-type], ...] + + This parameter is used to specify the signatures of the methods of + the generated interface. Do not repeat superinterface signatures + here." + {:added "1.0"} + + [& options] + (let [options-map (into1 {} (map vec (partition 2 options))) ] `'~(generate-interface options-map))) \ No newline at end of file diff --git a/Clojure/Clojure.Source/clojure/gvec.clj b/Clojure/Clojure.Source/clojure/gvec.clj index e9086be7f..a35285fee 100644 --- a/Clojure/Clojure.Source/clojure/gvec.clj +++ b/Clojure/Clojure.Source/clojure/gvec.clj @@ -1,585 +1,585 @@ -; 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. - -;;; a generic vector implementation for vectors of primitives - -(in-ns 'clojure.core) - -(import '(clojure.lang Murmur3 IHashEq Sequential Util SeqEnumerator) ;;; SeqIterator - ) '(java.util List) - -(set! *warn-on-reflection* true) - -(deftype VecNode [edit arr]) - -(def EMPTY-NODE (VecNode. nil (object-array 32))) - -(definterface IVecImpl - (^int tailoff []) - (arrayFor [^int i]) - (pushTail [^int level ^clojure.core.VecNode parent ^clojure.core.VecNode tailnode]) - (popTail [^int level node]) - (newPath [edit ^int level node]) - (doAssoc [^int level node ^int i val])) - -(definterface ArrayManager - (array [^int size]) - (^int alength [arr]) - (aclone [arr]) - (aget [arr ^int i]) - (aset [arr ^int i val])) - -(deftype ArrayChunk [^clojure.core.ArrayManager am arr ^int off ^int end] - - clojure.lang.Indexed - (nth [_ i] (.aget am arr (+ off i))) - - (count [_] (- end off)) - - clojure.lang.IChunk - (dropFirst [_] - (if (= off end) - (throw (InvalidProgramException. "dropFirst of empty chunk")) ;;; IllegalStateException - (new ArrayChunk am arr (inc off) end))) - - (reduce [_ f init] - (loop [ret init i off] - (if (< i end) - (let [ret (f ret (.aget am arr i))] - (if (reduced? ret) - ret - (recur ret (inc i)))) - ret)))) - -(deftype VecSeq [^clojure.core.ArrayManager am ^clojure.core.IVecImpl vec anode ^int i ^int offset ^clojure.lang.IPersistentMap _meta] - :no-print true - - clojure.core.protocols.InternalReduce - (internal-reduce - [_ f val] - (loop [result val - aidx (+ i offset)] - (if (< aidx (count vec)) - (let [node (.arrayFor vec aidx) - result (loop [result result - node-idx (bit-and 0x1f aidx)] - (if (< node-idx (.alength am node)) - (let [result (f result (.aget am node node-idx))] - (if (reduced? result) - result - (recur result (inc node-idx)))) - result))] - (if (reduced? result) - @result - (recur result (bit-and 0xffe0 (+ aidx 32))))) - result))) - - clojure.lang.ISeq - (first [_] (.aget am anode offset)) - (next [this] - (if (< (inc offset) (.alength am anode)) - (new VecSeq am vec anode i (inc offset) nil) - (.chunkedNext this))) - (more [this] - (let [s (.next this)] - (or s (clojure.lang.PersistentList/EMPTY)))) - (^clojure.lang.ISeq cons [this ^Object o] ;;; type hint added due to cons overload of ISeq vs IPersistentCollection - (clojure.lang.Cons. o this)) - (count [this] - (loop [i 1 - s (next this)] - (if s - (if (instance? clojure.lang.Counted s) - (+ i (.count s)) - (recur (inc i) (next s))) - i))) - (equiv [this o] - (cond - (identical? this o) true - (or (instance? clojure.lang.Sequential o) (instance? System.Collections.IEnumerable o)) ;;; java.util.List - (loop [me this - you (seq o)] - (if (nil? me) - (nil? you) - (and (clojure.lang.Util/equiv (first me) (first you)) - (recur (next me) (next you))))) - :else false)) - (empty [_] - clojure.lang.PersistentList/EMPTY) - - - clojure.lang.Seqable - (seq [this] this) - - clojure.lang.IChunkedSeq - (chunkedFirst [_] (ArrayChunk. am anode offset (.alength am anode))) - (chunkedNext [_] - (let [nexti (+ i (.alength am anode))] - (when (< nexti (count vec)) - (new VecSeq am vec (.arrayFor vec nexti) nexti 0 nil)))) - (chunkedMore [this] - (let [s (.chunkedNext this)] - (or s (clojure.lang.PersistentList/EMPTY)))) - - clojure.lang.IMeta - (meta [_] - _meta) - - clojure.lang.IObj - (withMeta [_ m] - (new VecSeq am vec anode i offset m)) - -Object - (GetHashCode [this] ;;; hashCode - (loop [hash 1 - s (seq this)] - (if s - (let [v (first s)] - (if (nil? v) - (recur (unchecked-multiply-int 31 hash) (next s)) - (recur (unchecked-add-int (unchecked-multiply-int 31 hash) (.GetHashCode ^Object v)) (next s)))) ;;; .hashCode - hash))) - (Equals [this other] ;;; equals - (cond (identical? this other) true - (or (instance? Sequential other) (instance? System.Collections.IList other)) ;;; List - (loop [s this - os (seq other)] - (if (nil? s) - (nil? os) - (if (Util/equals (first s) (first os)) - (recur (next s) (next os)) - false))) - :else false)) - - IHashEq - (hasheq [this] - (Murmur3/HashOrdered this)) - - System.Collections.IEnumerable ;;; Iterable - (GetEnumerator [this] ;;; iterator - (SeqEnumerator. this))) ;;; SeqIterator - - -(defmethod print-method ::VecSeq [v w] - ((get (methods print-method) clojure.lang.ISeq) v w)) - -(deftype Vec [^clojure.core.ArrayManager am ^int cnt ^int shift ^clojure.core.VecNode root tail _meta] - Object - (Equals [this o] ;;; equals - (cond - (identical? this o) true - (or (instance? clojure.lang.IPersistentVector o) (instance? System.Collections.IList o)) ;;; java.util.RandomAccess -- no such thing, no real guarantee on IList. TODO: decide whether to keep - (and (= cnt (count o)) - (loop [i (int 0)] - (cond - (= i cnt) true - (.Equals (.nth this i) (nth o i)) (recur (inc i)) ;;; .equals - :else false))) - (or (instance? clojure.lang.Sequential o) (instance? System.Collections.IList o)) ;;; java.util.List - (if-let [st (seq this)] - (.Equals ^Object st (seq o)) ;;; .equals, added ^Object - (nil? (seq o))) - :else false)) - - ;todo - cache - (GetHashCode [this] ;;; hashCode - (loop [hash (int 1) i (int 0)] - (if (= i cnt) - hash - (let [val (.nth this i)] - (recur (unchecked-add-int (unchecked-multiply-int 31 hash) - (clojure.lang.Util/hash val)) - (inc i)))))) - - ;todo - cache - clojure.lang.IHashEq - (hasheq [this] - (Murmur3/HashOrdered this)) ;;; hashOrdered - - clojure.lang.Counted - (clojure.lang.Counted.count [_] cnt) - - clojure.lang.IMeta - (meta [_] _meta) - - clojure.lang.IObj - (withMeta [_ m] (new Vec am cnt shift root tail m)) - - clojure.lang.Indexed - (nth [this i] - (let [a (.arrayFor this i)] - (.aget am a (bit-and i (int 0x1f))))) - (nth [this i not-found] - (let [z (int 0)] - (if (and (>= i z) (< i (.count this))) - (.nth this i) - not-found))) - - clojure.lang.IPersistentCollection - (^clojure.lang.IPersistentCollection cons [this ^Object val] ;;; added type hints because we overload cons - (if (< (- cnt (.tailoff this)) (int 32)) - (let [new-tail (.array am (inc (.alength am tail)))] - (Array/Copy ^Array tail ^Array new-tail (.alength am tail)) ;;; (System/arraycopy tail 0 new-tail 0 (.alength am tail)) - (.aset am new-tail (.alength am tail) val) - (new Vec am (inc cnt) shift root new-tail (meta this))) - (let [tail-node (VecNode. (.edit root) tail)] - (if (> (bit-shift-right cnt (int 5)) (bit-shift-left (int 1) shift)) ;overflow root? - (let [new-root (VecNode. (.edit root) (object-array 32))] - (doto ^objects (.arr new-root) - (aset 0 root) - (aset 1 (.newPath this (.edit root) shift tail-node))) - (new Vec am (inc cnt) (+ shift (int 5)) new-root (let [tl (.array am 1)] (.aset am tl 0 val) tl) (meta this))) - (new Vec am (inc cnt) shift (.pushTail this shift root tail-node) - (let [tl (.array am 1)] (.aset am tl 0 val) tl) (meta this)))))) - (count [_] cnt) ;;; ADDED - (empty [_] (new Vec am 0 5 EMPTY-NODE (.array am 0) nil)) - (equiv [this o] - (cond - (or (instance? clojure.lang.IPersistentVector o) (instance? System.Collections.IList o)) ;;; java.util.RandomAccess- TODO: Decide if we should test for IList - (and (= cnt (count o)) - (loop [i (int 0)] - (cond - (= i cnt) true - (= (.nth this i) (nth o i)) (recur (inc i)) - :else false))) - (or (instance? clojure.lang.Sequential o) (instance? System.Collections.IEnumerable o)) ;;; java.util.List - (clojure.lang.Util/equiv (seq this) (seq o)) - :else false)) - - clojure.lang.IPersistentStack - (peek [this] - (when (> cnt (int 0)) - (.nth this (dec cnt)))) - - (pop [this] - (cond - (zero? cnt) - (throw (InvalidProgramException. "Can't pop empty vector")) ;;; IllegalStateException - (= 1 cnt) - (new Vec am 0 5 EMPTY-NODE (.array am 0) (meta this)) - (> (- cnt (.tailoff this)) 1) - (let [new-tail (.array am (dec (.alength am tail)))] - (Array/Copy ^Array tail ^Array new-tail (.alength am new-tail)) ;;; (System/arraycopy tail 0 new-tail 0 (.alength am new-tail)) - (new Vec am (dec cnt) shift root new-tail (meta this))) - :else - (let [new-tail (.arrayFor this (- cnt 2)) - new-root ^clojure.core.VecNode (.popTail this shift root)] - (cond - (nil? new-root) - (new Vec am (dec cnt) shift EMPTY-NODE new-tail (meta this)) - (and (> shift 5) (nil? (aget ^objects (.arr new-root) 1))) - (new Vec am (dec cnt) (- shift 5) (aget ^objects (.arr new-root) 0) new-tail (meta this)) - :else - (new Vec am (dec cnt) shift new-root new-tail (meta this)))))) - - clojure.lang.IPersistentVector - (assocN [this i val] - (cond - (and (<= (int 0) i) (< i cnt)) - (if (>= i (.tailoff this)) - (let [new-tail (.array am (.alength am tail))] - (Array/Copy ^Array tail ^Array new-tail (.alength am tail)) ;;; (System/arraycopy tail 0 new-tail 0 (.alength am tail)) - (.aset am new-tail (bit-and i (int 0x1f)) val) - (new Vec am cnt shift root new-tail (meta this))) - (new Vec am cnt shift (.doAssoc this shift root i val) tail (meta this))) - (= i cnt) (.cons this val) - :else (throw (IndexOutOfRangeException.)))) ;;; IndexOutOfBoundsException - - (clojure.lang.IPersistentVector.count [_] cnt) ;;; ADDED - (length [_] cnt) ;;; ADDED - - clojure.lang.Reversible - (rseq [this] - (if (> (.count this) 0) - (clojure.lang.APersistentVector+RSeq. this (dec (.count this))) ;;; clojure.lang.APersistentVector$RSeq. - nil)) - - clojure.lang.Associative - (assoc [this k v] - (if (clojure.lang.Util/IsInteger k) ;;; isInteger - (.assocN this k v) - (throw (ArgumentException. "Key must be integer")))) ;;; IllegalArgumentException - (containsKey [this k] - (and (clojure.lang.Util/IsInteger k) ;;; isInteger - (<= 0 (int k)) - (< (int k) cnt))) - (entryAt [this k] - (if (.containsKey this k) - (clojure.lang.MapEntry/create k (.nth this (int k))) - nil)) - - clojure.lang.ILookup - (valAt [this k not-found] - (if (clojure.lang.Util/IsInteger k) ;;; isInteger - (let [i (int k)] - (if (and (>= i 0) (< i cnt)) - (.nth this i) - not-found)) - not-found)) - - (valAt [this k] (.valAt this k nil)) - - clojure.lang.IFn - (invoke [this k] - (if (clojure.lang.Util/IsInteger k) ;;; isInteger - (let [i (int k)] - (if (and (>= i 0) (< i cnt)) - (.nth this i) - (throw (IndexOutOfRangeException.)))) ;;; IndexOutOfBoundsException - (throw (ArgumentException. "Key must be integer")))) ;;; IllegalArgumentException - - - clojure.lang.Seqable - (seq [this] - (if (zero? cnt) - nil - (VecSeq. am this (.arrayFor this 0) 0 0 nil))) - - clojure.lang.Sequential ;marker, no methods - - clojure.core.IVecImpl - (tailoff [_] - (- cnt (.alength am tail))) - - (arrayFor [this i] - (if (and (<= (int 0) i) (< i cnt)) - (if (>= i (.tailoff this)) - tail - (loop [node root level shift] - (if (zero? level) - (.arr node) - (recur (aget ^objects (.arr node) (bit-and (bit-shift-right i level) (int 0x1f))) - (long (- level (int 5))))))) ;;; added long cast to deal with occur - (throw (IndexOutOfRangeException.)))) ;;; IndexOutOfBoundsException - - (pushTail [this level parent tailnode] - (let [subidx (bit-and (bit-shift-right (dec cnt) level) (int 0x1f)) - parent ^clojure.core.VecNode parent - ret (VecNode. (.edit parent) (aclone ^objects (.arr parent))) - node-to-insert (if (= level (int 5)) - tailnode - (let [child (aget ^objects (.arr parent) subidx)] - (if child - (.pushTail this (- level (int 5)) child tailnode) - (.newPath this (.edit root) (- level (int 5)) tailnode))))] - (aset ^objects (.arr ret) subidx node-to-insert) - ret)) - - (popTail [this level node] - (let [node ^clojure.core.VecNode node - subidx (bit-and (bit-shift-right (- cnt 2) level) (int 0x1f))] - (cond - (> level 5) - (let [new-child (.popTail this (- level 5) (aget ^objects (.arr node) subidx))] - (if (and (nil? new-child) (zero? subidx)) - nil - (let [arr (aclone ^objects (.arr node))] - (aset arr subidx new-child) - (VecNode. (.edit root) arr)))) - (zero? subidx) nil - :else (let [arr (aclone ^objects (.arr node))] - (aset arr subidx nil) - (VecNode. (.edit root) arr))))) - - (newPath [this edit ^int level node] - (if (zero? level) - node - (let [ret (VecNode. edit (object-array 32))] - (aset ^objects (.arr ret) 0 (.newPath this edit (- level (int 5)) node)) - ret))) - - (doAssoc [this level node i val] - (let [node ^clojure.core.VecNode node] - (if (zero? level) - ;on this branch, array will need val type - (let [arr (.aclone am (.arr node))] - (.aset am arr (bit-and i (int 0x1f)) val) - (VecNode. (.edit node) arr)) - (let [arr (aclone ^objects (.arr node)) - subidx (bit-and (bit-shift-right i level) (int 0x1f))] - (aset arr subidx (.doAssoc this (- level (int 5)) (aget arr subidx) i val)) - (VecNode. (.edit node) arr))))) - - System.IComparable ;;; java.lang.Comparable - (CompareTo [this o] ;;; compareTo - (if (identical? this o) - 0 - (let [^clojure.lang.IPersistentVector v (cast clojure.lang.IPersistentVector o) - vcnt (.length v)] ;;; .count TODO: Figure out why it can't find .count (relates to count being new in IPersistentVector) - (cond - (< cnt vcnt) -1 - (> cnt vcnt) 1 - :else - (loop [i (int 0)] - (if (= i cnt) - 0 - (let [comp (clojure.lang.Util/compare (.nth this i) (.nth v i))] - (if (= 0 comp) - (recur (inc i)) - comp)))))))) - - System.Collections.IEnumerable ;;; java.lang.Iterable - (GetEnumerator [this] ;;; iterator - (let [i (clojure.lang.AtomicInteger. -1)] ;;; java.util.concurrent.atomic.AtomicInteger. - (reify System.Collections.IEnumerator ;;; java.util.Iterator - (MoveNext [_] (< (.incrementAndGet i) cnt)) ;;; (hasNext [_] (< (.get i) cnt)) - (get_Current [_] (try (.nth this (.get i)) (catch IndexOutOfRangeException e (throw (InvalidOperationException.))))) ;;; (next [_] (.nth this (dec (.incrementAndGet i)))) - (Reset [_] (.set i 0))))) ;;; (remove [_] (throw (UnsupportedOperationException.)))))) - - ;java.util.Collection - ;(contains [this o] (boolean (some #(= % o) this))) - ;(containsAll [this c] (every? #(.contains this %) c)) - ;(isEmpty [_] (zero? cnt)) - ;(toArray [this] (into-array Object this)) - ;(^objects toArray [this ^objects arr] - ; (if (>= (count arr) cnt) - ; (do - ; (dotimes [i cnt] - ; (aset arr i (.nth this i))) - ; arr) - ; (into-array Object this))) - ;(size [_] cnt) - ;(add [_ o] (throw (UnsupportedOperationException.))) - ;(addAll [_ c] (throw (UnsupportedOperationException.))) - ;(clear [_] (throw (UnsupportedOperationException.))) - ;(^boolean remove [_ o] (throw (UnsupportedOperationException.))) - ;(removeAll [_ c] (throw (UnsupportedOperationException.))) - ;(retainAll [_ c] (throw (UnsupportedOperationException.))) - - System.Collections.ICollection - (CopyTo [this arr offset] - (dotimes [i cnt] - (aset arr (+ i offset) (.nth this i)))) - - (get_Count [_] cnt) - (get_IsSynchronized [_] true) - (get_SyncRoot [this] this) - - ;java.util.List - ;(get [this i] (.nth this i)) - ;(indexOf [this o] - ; (loop [i (int 0)] - ; (cond - ; (== i cnt) -1 - ; (= o (.nth this i)) i - ; :else (recur (inc i))))) - ;(lastIndexOf [this o] - ; (loop [i (dec cnt)] - ; (cond - ; (< i 0) -1 - ; (= o (.nth this i)) i - ; :else (recur (dec i))))) - ;(listIterator [this] (.listIterator this 0)) - ;(listIterator [this i] - ; (let [i (java.util.concurrent.atomic.AtomicInteger. i)] - ; (reify java.util.ListIterator - ; (hasNext [_] (< (.get i) cnt)) - ; (hasPrevious [_] (pos? i)) - ; (next [_] (.nth this (dec (.incrementAndGet i)))) - ; (nextIndex [_] (.get i)) - ; (previous [_] (.nth this (.decrementAndGet i))) - ; (previousIndex [_] (dec (.get i))) - ; (add [_ e] (throw (UnsupportedOperationException.))) - ; (remove [_] (throw (UnsupportedOperationException.))) - ; (set [_ e] (throw (UnsupportedOperationException.)))))) - ;(subList [this a z] (subvec this a z)) - ;(add [_ i o] (throw (UnsupportedOperationException.))) - ;(addAll [_ i c] (throw (UnsupportedOperationException.))) - ;(^Object remove [_ ^int i] (throw (UnsupportedOperationException.))) - ;(set [_ i e] (throw (UnsupportedOperationException.))) - - System.Collections.IList - (Add [_ v] (throw (InvalidOperationException.))) - (Clear [_] (throw (InvalidOperationException.))) - (Insert [_ i v] (throw (InvalidOperationException.))) - (Remove [_ v] (throw (InvalidOperationException.))) - (RemoveAt [_ i] (throw (InvalidOperationException.))) - (Contains [this o] (boolean (some #(= % o) this))) - (IndexOf [this o] - (loop [i (int 0)] - (cond - (== i cnt) -1 - (= o (.nth this i)) i - :else (recur (inc i))))) - (get_IsFixedSize [_] true) - (get_Item [this i] (.nth this i)) - (set_Item [_ i v] (throw (InvalidOperationException.)))) - -(defmethod print-method ::Vec [v w] - ((get (methods print-method) clojure.lang.IPersistentVector) v w)) - -(defmacro mk-am {:private true} [t] - (let [garr (gensym) - tgarr (with-meta garr {:tag (symbol (str t "s"))})] - `(reify clojure.core.ArrayManager - (array [_ size#] (~(symbol (str t "-array")) size#)) - (alength [_ ~garr] (alength ~tgarr)) - (aclone [_ ~garr] (aclone ~tgarr)) - (aget [_ ~garr i#] (aget ~tgarr i#)) - (aset [_ ~garr i# val#] (aset ~tgarr i# (~t val#)))))) - -(def ^{:private true} ams - {:int (mk-am int) :uint (mk-am uint) - :long (mk-am long) :ulong (mk-am ulong) - :float (mk-am float) - :double (mk-am double) - :byte (mk-am byte) :sbyte (mk-am sbyte) - :short (mk-am short) :ushort (mk-am ushort) - :char (mk-am char) - :boolean (mk-am boolean)}) - -(defmacro ^:private ams-check [t] - `(let [am# (ams ~t)] - (if am# - am# - (throw (ArgumentException. (str "Unrecognized type " ~t)))))) ;;; IllegalArgumentException - -(defn vector-of - "Creates a new vector of a single primitive type t, where t is one - of :int :long :float :double :byte :short :char or :boolean. The - resulting vector complies with the interface of vectors in general, - but stores the values unboxed internally. - - Optionally takes one or more elements to populate the vector." - {:added "1.2" - :arglists '([t] [t & elements])} - ([t] - (let [^clojure.core.ArrayManager am (ams-check t)] - (Vec. am 0 5 EMPTY-NODE (.array am 0) nil))) - ([t x1] - (let [^clojure.core.ArrayManager am (ams-check t) - arr (.array am 1)] - (.aset am arr 0 x1) - (Vec. am 1 5 EMPTY-NODE arr nil))) - ([t x1 x2] - (let [^clojure.core.ArrayManager am (ams-check t) - arr (.array am 2)] - (.aset am arr 0 x1) - (.aset am arr 1 x2) - (Vec. am 2 5 EMPTY-NODE arr nil))) - ([t x1 x2 x3] - (let [^clojure.core.ArrayManager am (ams-check t) - arr (.array am 3)] - (.aset am arr 0 x1) - (.aset am arr 1 x2) - (.aset am arr 2 x3) - (Vec. am 3 5 EMPTY-NODE arr nil))) - ([t x1 x2 x3 x4] - (let [^clojure.core.ArrayManager am (ams-check t) - arr (.array am 4)] - (.aset am arr 0 x1) - (.aset am arr 1 x2) - (.aset am arr 2 x3) - (.aset am arr 3 x4) - (Vec. am 4 5 EMPTY-NODE arr nil))) - ([t x1 x2 x3 x4 & xn] - (loop [v (vector-of t x1 x2 x3 x4) - xn xn] - (if xn - (recur (conj v (first xn)) (next xn)) - v)))) +; 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. + +;;; a generic vector implementation for vectors of primitives + +(in-ns 'clojure.core) + +(import '(clojure.lang Murmur3 IHashEq Sequential Util SeqEnumerator) ;;; SeqIterator + ) '(java.util List) + +(set! *warn-on-reflection* true) + +(deftype VecNode [edit arr]) + +(def EMPTY-NODE (VecNode. nil (object-array 32))) + +(definterface IVecImpl + (^int tailoff []) + (arrayFor [^int i]) + (pushTail [^int level ^clojure.core.VecNode parent ^clojure.core.VecNode tailnode]) + (popTail [^int level node]) + (newPath [edit ^int level node]) + (doAssoc [^int level node ^int i val])) + +(definterface ArrayManager + (array [^int size]) + (^int alength [arr]) + (aclone [arr]) + (aget [arr ^int i]) + (aset [arr ^int i val])) + +(deftype ArrayChunk [^clojure.core.ArrayManager am arr ^int off ^int end] + + clojure.lang.Indexed + (nth [_ i] (.aget am arr (+ off i))) + + (count [_] (- end off)) + + clojure.lang.IChunk + (dropFirst [_] + (if (= off end) + (throw (InvalidProgramException. "dropFirst of empty chunk")) ;;; IllegalStateException + (new ArrayChunk am arr (inc off) end))) + + (reduce [_ f init] + (loop [ret init i off] + (if (< i end) + (let [ret (f ret (.aget am arr i))] + (if (reduced? ret) + ret + (recur ret (inc i)))) + ret)))) + +(deftype VecSeq [^clojure.core.ArrayManager am ^clojure.core.IVecImpl vec anode ^int i ^int offset ^clojure.lang.IPersistentMap _meta] + :no-print true + + clojure.core.protocols.InternalReduce + (internal-reduce + [_ f val] + (loop [result val + aidx (+ i offset)] + (if (< aidx (count vec)) + (let [node (.arrayFor vec aidx) + result (loop [result result + node-idx (bit-and 0x1f aidx)] + (if (< node-idx (.alength am node)) + (let [result (f result (.aget am node node-idx))] + (if (reduced? result) + result + (recur result (inc node-idx)))) + result))] + (if (reduced? result) + @result + (recur result (bit-and 0xffe0 (+ aidx 32))))) + result))) + + clojure.lang.ISeq + (first [_] (.aget am anode offset)) + (next [this] + (if (< (inc offset) (.alength am anode)) + (new VecSeq am vec anode i (inc offset) nil) + (.chunkedNext this))) + (more [this] + (let [s (.next this)] + (or s (clojure.lang.PersistentList/EMPTY)))) + (^clojure.lang.ISeq cons [this ^Object o] ;;; type hint added due to cons overload of ISeq vs IPersistentCollection + (clojure.lang.Cons. o this)) + (count [this] + (loop [i 1 + s (next this)] + (if s + (if (instance? clojure.lang.Counted s) + (+ i (.count s)) + (recur (inc i) (next s))) + i))) + (equiv [this o] + (cond + (identical? this o) true + (or (instance? clojure.lang.Sequential o) (instance? System.Collections.IEnumerable o)) ;;; java.util.List + (loop [me this + you (seq o)] + (if (nil? me) + (nil? you) + (and (clojure.lang.Util/equiv (first me) (first you)) + (recur (next me) (next you))))) + :else false)) + (empty [_] + clojure.lang.PersistentList/EMPTY) + + + clojure.lang.Seqable + (seq [this] this) + + clojure.lang.IChunkedSeq + (chunkedFirst [_] (ArrayChunk. am anode offset (.alength am anode))) + (chunkedNext [_] + (let [nexti (+ i (.alength am anode))] + (when (< nexti (count vec)) + (new VecSeq am vec (.arrayFor vec nexti) nexti 0 nil)))) + (chunkedMore [this] + (let [s (.chunkedNext this)] + (or s (clojure.lang.PersistentList/EMPTY)))) + + clojure.lang.IMeta + (meta [_] + _meta) + + clojure.lang.IObj + (withMeta [_ m] + (new VecSeq am vec anode i offset m)) + +Object + (GetHashCode [this] ;;; hashCode + (loop [hash 1 + s (seq this)] + (if s + (let [v (first s)] + (if (nil? v) + (recur (unchecked-multiply-int 31 hash) (next s)) + (recur (unchecked-add-int (unchecked-multiply-int 31 hash) (.GetHashCode ^Object v)) (next s)))) ;;; .hashCode + hash))) + (Equals [this other] ;;; equals + (cond (identical? this other) true + (or (instance? Sequential other) (instance? System.Collections.IList other)) ;;; List + (loop [s this + os (seq other)] + (if (nil? s) + (nil? os) + (if (Util/equals (first s) (first os)) + (recur (next s) (next os)) + false))) + :else false)) + + IHashEq + (hasheq [this] + (Murmur3/HashOrdered this)) + + System.Collections.IEnumerable ;;; Iterable + (GetEnumerator [this] ;;; iterator + (SeqEnumerator. this))) ;;; SeqIterator + + +(defmethod print-method ::VecSeq [v w] + ((get (methods print-method) clojure.lang.ISeq) v w)) + +(deftype Vec [^clojure.core.ArrayManager am ^int cnt ^int shift ^clojure.core.VecNode root tail _meta] + Object + (Equals [this o] ;;; equals + (cond + (identical? this o) true + (or (instance? clojure.lang.IPersistentVector o) (instance? System.Collections.IList o)) ;;; java.util.RandomAccess -- no such thing, no real guarantee on IList. TODO: decide whether to keep + (and (= cnt (count o)) + (loop [i (int 0)] + (cond + (= i cnt) true + (.Equals (.nth this i) (nth o i)) (recur (inc i)) ;;; .equals + :else false))) + (or (instance? clojure.lang.Sequential o) (instance? System.Collections.IList o)) ;;; java.util.List + (if-let [st (seq this)] + (.Equals ^Object st (seq o)) ;;; .equals, added ^Object + (nil? (seq o))) + :else false)) + + ;todo - cache + (GetHashCode [this] ;;; hashCode + (loop [hash (int 1) i (int 0)] + (if (= i cnt) + hash + (let [val (.nth this i)] + (recur (unchecked-add-int (unchecked-multiply-int 31 hash) + (clojure.lang.Util/hash val)) + (inc i)))))) + + ;todo - cache + clojure.lang.IHashEq + (hasheq [this] + (Murmur3/HashOrdered this)) ;;; hashOrdered + + clojure.lang.Counted + (clojure.lang.Counted.count [_] cnt) + + clojure.lang.IMeta + (meta [_] _meta) + + clojure.lang.IObj + (withMeta [_ m] (new Vec am cnt shift root tail m)) + + clojure.lang.Indexed + (nth [this i] + (let [a (.arrayFor this i)] + (.aget am a (bit-and i (int 0x1f))))) + (nth [this i not-found] + (let [z (int 0)] + (if (and (>= i z) (< i (.count this))) + (.nth this i) + not-found))) + + clojure.lang.IPersistentCollection + (^clojure.lang.IPersistentCollection cons [this ^Object val] ;;; added type hints because we overload cons + (if (< (- cnt (.tailoff this)) (int 32)) + (let [new-tail (.array am (inc (.alength am tail)))] + (Array/Copy ^Array tail ^Array new-tail (.alength am tail)) ;;; (System/arraycopy tail 0 new-tail 0 (.alength am tail)) + (.aset am new-tail (.alength am tail) val) + (new Vec am (inc cnt) shift root new-tail (meta this))) + (let [tail-node (VecNode. (.edit root) tail)] + (if (> (bit-shift-right cnt (int 5)) (bit-shift-left (int 1) shift)) ;overflow root? + (let [new-root (VecNode. (.edit root) (object-array 32))] + (doto ^objects (.arr new-root) + (aset 0 root) + (aset 1 (.newPath this (.edit root) shift tail-node))) + (new Vec am (inc cnt) (+ shift (int 5)) new-root (let [tl (.array am 1)] (.aset am tl 0 val) tl) (meta this))) + (new Vec am (inc cnt) shift (.pushTail this shift root tail-node) + (let [tl (.array am 1)] (.aset am tl 0 val) tl) (meta this)))))) + (count [_] cnt) ;;; ADDED + (empty [_] (new Vec am 0 5 EMPTY-NODE (.array am 0) nil)) + (equiv [this o] + (cond + (or (instance? clojure.lang.IPersistentVector o) (instance? System.Collections.IList o)) ;;; java.util.RandomAccess- TODO: Decide if we should test for IList + (and (= cnt (count o)) + (loop [i (int 0)] + (cond + (= i cnt) true + (= (.nth this i) (nth o i)) (recur (inc i)) + :else false))) + (or (instance? clojure.lang.Sequential o) (instance? System.Collections.IEnumerable o)) ;;; java.util.List + (clojure.lang.Util/equiv (seq this) (seq o)) + :else false)) + + clojure.lang.IPersistentStack + (peek [this] + (when (> cnt (int 0)) + (.nth this (dec cnt)))) + + (pop [this] + (cond + (zero? cnt) + (throw (InvalidProgramException. "Can't pop empty vector")) ;;; IllegalStateException + (= 1 cnt) + (new Vec am 0 5 EMPTY-NODE (.array am 0) (meta this)) + (> (- cnt (.tailoff this)) 1) + (let [new-tail (.array am (dec (.alength am tail)))] + (Array/Copy ^Array tail ^Array new-tail (.alength am new-tail)) ;;; (System/arraycopy tail 0 new-tail 0 (.alength am new-tail)) + (new Vec am (dec cnt) shift root new-tail (meta this))) + :else + (let [new-tail (.arrayFor this (- cnt 2)) + new-root ^clojure.core.VecNode (.popTail this shift root)] + (cond + (nil? new-root) + (new Vec am (dec cnt) shift EMPTY-NODE new-tail (meta this)) + (and (> shift 5) (nil? (aget ^objects (.arr new-root) 1))) + (new Vec am (dec cnt) (- shift 5) (aget ^objects (.arr new-root) 0) new-tail (meta this)) + :else + (new Vec am (dec cnt) shift new-root new-tail (meta this)))))) + + clojure.lang.IPersistentVector + (assocN [this i val] + (cond + (and (<= (int 0) i) (< i cnt)) + (if (>= i (.tailoff this)) + (let [new-tail (.array am (.alength am tail))] + (Array/Copy ^Array tail ^Array new-tail (.alength am tail)) ;;; (System/arraycopy tail 0 new-tail 0 (.alength am tail)) + (.aset am new-tail (bit-and i (int 0x1f)) val) + (new Vec am cnt shift root new-tail (meta this))) + (new Vec am cnt shift (.doAssoc this shift root i val) tail (meta this))) + (= i cnt) (.cons this val) + :else (throw (IndexOutOfRangeException.)))) ;;; IndexOutOfBoundsException + + (clojure.lang.IPersistentVector.count [_] cnt) ;;; ADDED + (length [_] cnt) ;;; ADDED + + clojure.lang.Reversible + (rseq [this] + (if (> (.count this) 0) + (clojure.lang.APersistentVector+RSeq. this (dec (.count this))) ;;; clojure.lang.APersistentVector$RSeq. + nil)) + + clojure.lang.Associative + (assoc [this k v] + (if (clojure.lang.Util/IsInteger k) ;;; isInteger + (.assocN this k v) + (throw (ArgumentException. "Key must be integer")))) ;;; IllegalArgumentException + (containsKey [this k] + (and (clojure.lang.Util/IsInteger k) ;;; isInteger + (<= 0 (int k)) + (< (int k) cnt))) + (entryAt [this k] + (if (.containsKey this k) + (clojure.lang.MapEntry/create k (.nth this (int k))) + nil)) + + clojure.lang.ILookup + (valAt [this k not-found] + (if (clojure.lang.Util/IsInteger k) ;;; isInteger + (let [i (int k)] + (if (and (>= i 0) (< i cnt)) + (.nth this i) + not-found)) + not-found)) + + (valAt [this k] (.valAt this k nil)) + + clojure.lang.IFn + (invoke [this k] + (if (clojure.lang.Util/IsInteger k) ;;; isInteger + (let [i (int k)] + (if (and (>= i 0) (< i cnt)) + (.nth this i) + (throw (IndexOutOfRangeException.)))) ;;; IndexOutOfBoundsException + (throw (ArgumentException. "Key must be integer")))) ;;; IllegalArgumentException + + + clojure.lang.Seqable + (seq [this] + (if (zero? cnt) + nil + (VecSeq. am this (.arrayFor this 0) 0 0 nil))) + + clojure.lang.Sequential ;marker, no methods + + clojure.core.IVecImpl + (tailoff [_] + (- cnt (.alength am tail))) + + (arrayFor [this i] + (if (and (<= (int 0) i) (< i cnt)) + (if (>= i (.tailoff this)) + tail + (loop [node root level shift] + (if (zero? level) + (.arr node) + (recur (aget ^objects (.arr node) (bit-and (bit-shift-right i level) (int 0x1f))) + (long (- level (int 5))))))) ;;; added long cast to deal with occur + (throw (IndexOutOfRangeException.)))) ;;; IndexOutOfBoundsException + + (pushTail [this level parent tailnode] + (let [subidx (bit-and (bit-shift-right (dec cnt) level) (int 0x1f)) + parent ^clojure.core.VecNode parent + ret (VecNode. (.edit parent) (aclone ^objects (.arr parent))) + node-to-insert (if (= level (int 5)) + tailnode + (let [child (aget ^objects (.arr parent) subidx)] + (if child + (.pushTail this (- level (int 5)) child tailnode) + (.newPath this (.edit root) (- level (int 5)) tailnode))))] + (aset ^objects (.arr ret) subidx node-to-insert) + ret)) + + (popTail [this level node] + (let [node ^clojure.core.VecNode node + subidx (bit-and (bit-shift-right (- cnt 2) level) (int 0x1f))] + (cond + (> level 5) + (let [new-child (.popTail this (- level 5) (aget ^objects (.arr node) subidx))] + (if (and (nil? new-child) (zero? subidx)) + nil + (let [arr (aclone ^objects (.arr node))] + (aset arr subidx new-child) + (VecNode. (.edit root) arr)))) + (zero? subidx) nil + :else (let [arr (aclone ^objects (.arr node))] + (aset arr subidx nil) + (VecNode. (.edit root) arr))))) + + (newPath [this edit ^int level node] + (if (zero? level) + node + (let [ret (VecNode. edit (object-array 32))] + (aset ^objects (.arr ret) 0 (.newPath this edit (- level (int 5)) node)) + ret))) + + (doAssoc [this level node i val] + (let [node ^clojure.core.VecNode node] + (if (zero? level) + ;on this branch, array will need val type + (let [arr (.aclone am (.arr node))] + (.aset am arr (bit-and i (int 0x1f)) val) + (VecNode. (.edit node) arr)) + (let [arr (aclone ^objects (.arr node)) + subidx (bit-and (bit-shift-right i level) (int 0x1f))] + (aset arr subidx (.doAssoc this (- level (int 5)) (aget arr subidx) i val)) + (VecNode. (.edit node) arr))))) + + System.IComparable ;;; java.lang.Comparable + (CompareTo [this o] ;;; compareTo + (if (identical? this o) + 0 + (let [^clojure.lang.IPersistentVector v (cast clojure.lang.IPersistentVector o) + vcnt (.length v)] ;;; .count TODO: Figure out why it can't find .count (relates to count being new in IPersistentVector) + (cond + (< cnt vcnt) -1 + (> cnt vcnt) 1 + :else + (loop [i (int 0)] + (if (= i cnt) + 0 + (let [comp (clojure.lang.Util/compare (.nth this i) (.nth v i))] + (if (= 0 comp) + (recur (inc i)) + comp)))))))) + + System.Collections.IEnumerable ;;; java.lang.Iterable + (GetEnumerator [this] ;;; iterator + (let [i (clojure.lang.AtomicInteger. -1)] ;;; java.util.concurrent.atomic.AtomicInteger. + (reify System.Collections.IEnumerator ;;; java.util.Iterator + (MoveNext [_] (< (.incrementAndGet i) cnt)) ;;; (hasNext [_] (< (.get i) cnt)) + (get_Current [_] (try (.nth this (.get i)) (catch IndexOutOfRangeException e (throw (InvalidOperationException.))))) ;;; (next [_] (.nth this (dec (.incrementAndGet i)))) + (Reset [_] (.set i 0))))) ;;; (remove [_] (throw (UnsupportedOperationException.)))))) + + ;java.util.Collection + ;(contains [this o] (boolean (some #(= % o) this))) + ;(containsAll [this c] (every? #(.contains this %) c)) + ;(isEmpty [_] (zero? cnt)) + ;(toArray [this] (into-array Object this)) + ;(^objects toArray [this ^objects arr] + ; (if (>= (count arr) cnt) + ; (do + ; (dotimes [i cnt] + ; (aset arr i (.nth this i))) + ; arr) + ; (into-array Object this))) + ;(size [_] cnt) + ;(add [_ o] (throw (UnsupportedOperationException.))) + ;(addAll [_ c] (throw (UnsupportedOperationException.))) + ;(clear [_] (throw (UnsupportedOperationException.))) + ;(^boolean remove [_ o] (throw (UnsupportedOperationException.))) + ;(removeAll [_ c] (throw (UnsupportedOperationException.))) + ;(retainAll [_ c] (throw (UnsupportedOperationException.))) + + System.Collections.ICollection + (CopyTo [this arr offset] + (dotimes [i cnt] + (aset arr (+ i offset) (.nth this i)))) + + (get_Count [_] cnt) + (get_IsSynchronized [_] true) + (get_SyncRoot [this] this) + + ;java.util.List + ;(get [this i] (.nth this i)) + ;(indexOf [this o] + ; (loop [i (int 0)] + ; (cond + ; (== i cnt) -1 + ; (= o (.nth this i)) i + ; :else (recur (inc i))))) + ;(lastIndexOf [this o] + ; (loop [i (dec cnt)] + ; (cond + ; (< i 0) -1 + ; (= o (.nth this i)) i + ; :else (recur (dec i))))) + ;(listIterator [this] (.listIterator this 0)) + ;(listIterator [this i] + ; (let [i (java.util.concurrent.atomic.AtomicInteger. i)] + ; (reify java.util.ListIterator + ; (hasNext [_] (< (.get i) cnt)) + ; (hasPrevious [_] (pos? i)) + ; (next [_] (.nth this (dec (.incrementAndGet i)))) + ; (nextIndex [_] (.get i)) + ; (previous [_] (.nth this (.decrementAndGet i))) + ; (previousIndex [_] (dec (.get i))) + ; (add [_ e] (throw (UnsupportedOperationException.))) + ; (remove [_] (throw (UnsupportedOperationException.))) + ; (set [_ e] (throw (UnsupportedOperationException.)))))) + ;(subList [this a z] (subvec this a z)) + ;(add [_ i o] (throw (UnsupportedOperationException.))) + ;(addAll [_ i c] (throw (UnsupportedOperationException.))) + ;(^Object remove [_ ^int i] (throw (UnsupportedOperationException.))) + ;(set [_ i e] (throw (UnsupportedOperationException.))) + + System.Collections.IList + (Add [_ v] (throw (InvalidOperationException.))) + (Clear [_] (throw (InvalidOperationException.))) + (Insert [_ i v] (throw (InvalidOperationException.))) + (Remove [_ v] (throw (InvalidOperationException.))) + (RemoveAt [_ i] (throw (InvalidOperationException.))) + (Contains [this o] (boolean (some #(= % o) this))) + (IndexOf [this o] + (loop [i (int 0)] + (cond + (== i cnt) -1 + (= o (.nth this i)) i + :else (recur (inc i))))) + (get_IsFixedSize [_] true) + (get_Item [this i] (.nth this i)) + (set_Item [_ i v] (throw (InvalidOperationException.)))) + +(defmethod print-method ::Vec [v w] + ((get (methods print-method) clojure.lang.IPersistentVector) v w)) + +(defmacro mk-am {:private true} [t] + (let [garr (gensym) + tgarr (with-meta garr {:tag (symbol (str t "s"))})] + `(reify clojure.core.ArrayManager + (array [_ size#] (~(symbol (str t "-array")) size#)) + (alength [_ ~garr] (alength ~tgarr)) + (aclone [_ ~garr] (aclone ~tgarr)) + (aget [_ ~garr i#] (aget ~tgarr i#)) + (aset [_ ~garr i# val#] (aset ~tgarr i# (~t val#)))))) + +(def ^{:private true} ams + {:int (mk-am int) :uint (mk-am uint) + :long (mk-am long) :ulong (mk-am ulong) + :float (mk-am float) + :double (mk-am double) + :byte (mk-am byte) :sbyte (mk-am sbyte) + :short (mk-am short) :ushort (mk-am ushort) + :char (mk-am char) + :boolean (mk-am boolean)}) + +(defmacro ^:private ams-check [t] + `(let [am# (ams ~t)] + (if am# + am# + (throw (ArgumentException. (str "Unrecognized type " ~t)))))) ;;; IllegalArgumentException + +(defn vector-of + "Creates a new vector of a single primitive type t, where t is one + of :int :long :float :double :byte :short :char or :boolean. The + resulting vector complies with the interface of vectors in general, + but stores the values unboxed internally. + + Optionally takes one or more elements to populate the vector." + {:added "1.2" + :arglists '([t] [t & elements])} + ([t] + (let [^clojure.core.ArrayManager am (ams-check t)] + (Vec. am 0 5 EMPTY-NODE (.array am 0) nil))) + ([t x1] + (let [^clojure.core.ArrayManager am (ams-check t) + arr (.array am 1)] + (.aset am arr 0 x1) + (Vec. am 1 5 EMPTY-NODE arr nil))) + ([t x1 x2] + (let [^clojure.core.ArrayManager am (ams-check t) + arr (.array am 2)] + (.aset am arr 0 x1) + (.aset am arr 1 x2) + (Vec. am 2 5 EMPTY-NODE arr nil))) + ([t x1 x2 x3] + (let [^clojure.core.ArrayManager am (ams-check t) + arr (.array am 3)] + (.aset am arr 0 x1) + (.aset am arr 1 x2) + (.aset am arr 2 x3) + (Vec. am 3 5 EMPTY-NODE arr nil))) + ([t x1 x2 x3 x4] + (let [^clojure.core.ArrayManager am (ams-check t) + arr (.array am 4)] + (.aset am arr 0 x1) + (.aset am arr 1 x2) + (.aset am arr 2 x3) + (.aset am arr 3 x4) + (Vec. am 4 5 EMPTY-NODE arr nil))) + ([t x1 x2 x3 x4 & xn] + (loop [v (vector-of t x1 x2 x3 x4) + xn xn] + (if xn + (recur (conj v (first xn)) (next xn)) + v)))) diff --git a/Clojure/Clojure.Source/clojure/instant.clj b/Clojure/Clojure.Source/clojure/instant.clj index 58588dc86..79c425fd3 100644 --- a/Clojure/Clojure.Source/clojure/instant.clj +++ b/Clojure/Clojure.Source/clojure/instant.clj @@ -1,338 +1,338 @@ -; 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. - -(ns clojure.instant - ;;;(:import [java.util Calendar Date GregorianCalendar TimeZone] ;;; Do we want to do - );;; [java.sql Timestamp])) ;;; Do we want to do [System.DataSqlTypes SqlDateTime] - - -(set! *warn-on-reflection* true) - -;;; ------------------------------------------------------------------------ -;;; convenience macros - -(defmacro ^:private fail - [msg] - `(throw (Exception. ~msg))) ;;; RuntimeException. - -(defmacro ^:private verify - ([test msg] `(when-not ~test (fail ~msg))) - ([test] `(verify ~test ~(str "failed: " (pr-str test))))) - -(defn- divisible? - [num div] - (zero? (mod num div))) - -(defn- indivisible? - [num div] - (not (divisible? num div))) - - -;;; ------------------------------------------------------------------------ -;;; parser implementation - -(defn- parse-int [^String s] - (if (String/IsNullOrEmpty s) 0 (Int64/Parse s))) ;;; (Long/parseLong s)) - -(defn- zero-fill-right [^String s width] - (cond (= width (count s)) s - (< width (count s)) (.Substring s 0 width) ;;; .substring - :else (loop [b (StringBuilder. s)] - (if (< (.Length b) width) ;;; .length - (recur (.Append b \0)) ;;; .append - (.ToString b))))) ;;; .toString - -(def ^:private timestamp - #"(\d\d\d\d)(?:-(\d\d)(?:-(\d\d)(?:[T](\d\d)(?::(\d\d)(?::(\d\d)(?:[.](\d+))?)?)?)?)?)?(?:[Z]|([-+])(\d\d):(\d\d))?") - -(defn parse-timestamp - "Parse a string containing an RFC3339-like like timestamp. - -The function new-instant is called with the following arguments. - - min max default - --- ------------ ------- - years 0 9999 N/A (s must provide years) - months 1 12 1 - days 1 31 1 (actual max days depends - hours 0 23 0 on month and year) - minutes 0 59 0 - seconds 0 60 0 (though 60 is only valid - nanoseconds 0 999999999 0 when minutes is 59) - offset-sign -1 1 0 - offset-hours 0 23 0 - offset-minutes 0 59 0 - -These are all integers and will be non-nil. (The listed defaults -will be passed if the corresponding field is not present in s.) - -Grammar (of s): - - date-fullyear = 4DIGIT - date-month = 2DIGIT ; 01-12 - date-mday = 2DIGIT ; 01-28, 01-29, 01-30, 01-31 based on - ; month/year - time-hour = 2DIGIT ; 00-23 - time-minute = 2DIGIT ; 00-59 - time-second = 2DIGIT ; 00-58, 00-59, 00-60 based on leap second - ; rules - time-secfrac = '.' 1*DIGIT - time-numoffset = ('+' / '-') time-hour ':' time-minute - time-offset = 'Z' / time-numoffset - - time-part = time-hour [ ':' time-minute [ ':' time-second - [time-secfrac] [time-offset] ] ] - - timestamp = date-year [ '-' date-month [ '-' date-mday - [ 'T' time-part ] ] ] - -Unlike RFC3339: - - - we only parse the timestamp format - - timestamp can elide trailing components - - time-offset is optional (defaults to +00:00) - -Though time-offset is syntactically optional, a missing time-offset -will be treated as if the time-offset zero (+00:00) had been -specified. -" - [new-instant ^String cs] ;;; ^CharSequence - (if-let [[_ years months days hours minutes seconds fraction - offset-sign offset-hours offset-minutes] - (re-matches timestamp cs)] - (new-instant - (parse-int years) - (if (String/IsNullOrEmpty months) 1 (parse-int months)) ;;; (if-not months 1 (parse-int months)) - (if (String/IsNullOrEmpty days) 1 (parse-int days)) ;;; (if-not days 1 (parse-int days)) - (if (String/IsNullOrEmpty hours) 0 (parse-int hours)) ;;; (if-not hours 0 (parse-int hours)) - (if (String/IsNullOrEmpty minutes) 0 (parse-int minutes)) ;;; (if-not minutes 0 (parse-int minutes)) - (if (String/IsNullOrEmpty seconds) 0 (parse-int seconds)) ;;; (if-not seconds 0 (parse-int seconds)) - (if (String/IsNullOrEmpty fraction) 0 (parse-int (zero-fill-right fraction 9))) ;;; (if-not fraction 0 (parse-int (zero-fill-right fraction 9))) - (cond (= "-" offset-sign) -1 - (= "+" offset-sign) 1 - :else 0) - (if (String/IsNullOrEmpty offset-hours) 0 (parse-int offset-hours)) ;;; (if-not offset-hours 0 (parse-int offset-hours)) - (if (String/IsNullOrEmpty offset-minutes) 0 (parse-int offset-minutes))) ;;; (if-not offset-minutes 0 (parse-int offset-minutes)) - (fail (str "Unrecognized date/time syntax: " cs)))) - - -;;; ------------------------------------------------------------------------ -;;; Verification of Extra-Grammatical Restrictions from RFC3339 - -(defn- leap-year? - [year] - (and (divisible? year 4) - (or (indivisible? year 100) - (divisible? year 400)))) - -(def ^:private days-in-month - (let [dim-norm [nil 31 28 31 30 31 30 31 31 30 31 30 31] - dim-leap [nil 31 29 31 30 31 30 31 31 30 31 30 31]] - (fn [month leap-year?] - ((if leap-year? dim-leap dim-norm) month)))) - -(defn validated - "Return a function which constructs an instant by calling constructor -after first validating that those arguments are in range and otherwise -plausible. The resulting function will throw an exception if called -with invalid arguments." - [new-instance] - (fn [years months days hours minutes seconds nanoseconds - offset-sign offset-hours offset-minutes] - (verify (<= 1 months 12)) - (verify (<= 1 days (days-in-month months (leap-year? years)))) - (verify (<= 0 hours 23)) - (verify (<= 0 minutes 59)) - (verify (<= 0 seconds (if (= minutes 59) 60 59))) - (verify (<= 0 nanoseconds 999999999)) - (verify (<= -1 offset-sign 1)) - (verify (<= 0 offset-hours 23)) - (verify (<= 0 offset-minutes 59)) - (new-instance years months days hours minutes seconds nanoseconds - offset-sign offset-hours offset-minutes))) - - -;;; ------------------------------------------------------------------------ -;;; print integration - -;;;(def ^:private ^ThreadLocal thread-local-utc-date-format -;;; ;; SimpleDateFormat is not thread-safe, so we use a ThreadLocal proxy for access. -;;; ;; http://bugs.sun.com/bugdatabase/view_bug.do?bug_id=4228335 -;;; (proxy [ThreadLocal] [] -;;; (initialValue [] -;;; (doto (java.text.SimpleDateFormat. "yyyy-MM-dd'T'HH:mm:ss.SSS-00:00") -;;; ;; RFC3339 says to use -00:00 when the timezone is unknown (+00:00 implies a known GMT) -;;; (.setTimeZone (java.util.TimeZone/getTimeZone "GMT")))))) - -(defn- print-datetime ;;; print-date - "Print a System.DateTime as RFC3339 timestamp, always in UTC." ;;; java.util.Date - [ ^System.DateTime d, ^System.IO.TextWriter w] ;;; ^java.util.Date ^java.io.Writer - (let [utc-format "yyyy-MM-ddTHH:mm:ss.fff-00:00"] ;;; ^java.text.DateFormat utc-format (.get thread-local-utc-date-format) - (.Write w "#inst \"") ;;; .write - (.Write w (.ToString d utc-format )) ;;; (.write w (.format utc-format d)) - (.Write w "\""))) ;;; .write - -;;; DM Added -(defn- print-datetimeoffset - "Print a System.DateTimeOffset as RFC3339 timestamp, always in UTC." - [ ^System.DateTimeOffset d, ^System.IO.TextWriter w] - (let [utc-format "yyyy-MM-ddTHH:mm:ss.fffzzzz"] - (.Write w "#inst \"") - (.Write w (.ToString d utc-format )) - (.Write w "\""))) -;;; - -(defmethod print-method System.DateTime ;;; java.util.Date - [^System.DateTime d, ^System.IO.TextWriter w] ;;; ^java.util.Date ^java.io.Writer - (print-datetime d w)) ;;; print-date - -(defmethod print-dup System.DateTime ;;; java.util.Date - [^System.DateTime d, ^System.IO.TextWriter w] ;;; ^java.util.Date ^java.io.Writer - (print-datetime d w)) ;;; print-date - -;;;(defn- print-calendar -;;; "Print a java.util.Calendar as RFC3339 timestamp, preserving timezone." -;;; [^java.util.Calendar c, ^java.io.Writer w] -;;; (let [calstr (format "%1$tFT%1$tT.%1$tL%1$tz" c) -;;; offset-minutes (- (.length calstr) 2)] -;;; ;; calstr is almost right, but is missing the colon in the offset -;;; (.write w "#inst \"") -;;; (.write w calstr 0 offset-minutes) -;;; (.write w ":") -;;; (.write w calstr offset-minutes 2) -;;; (.write w "\""))) - -(defmethod print-method System.DateTimeOffset ;;; java.util.Calendar - [^System.DateTimeOffset d, ^System.IO.TextWriter w] ;;; ^java.util.Calendar ^java.io.Writer - (print-datetimeoffset d w)) ;;; print-date - -(defmethod print-dup System.DateTimeOffset ;;; java.util.Calendar - [^System.DateTimeOffset d, ^System.IO.TextWriter w] ;;; ^java.util.Calendar ^java.io.Writer - (print-datetimeoffset d w)) ;;; print-date - -;;;(def ^:private ^ThreadLocal thread-local-utc-timestamp-format -;;; ;; SimpleDateFormat is not thread-safe, so we use a ThreadLocal proxy for access. -;;; ;; http://bugs.sun.com/bugdatabase/view_bug.do?bug_id=4228335 -;;; (proxy [ThreadLocal] [] -;;; (initialValue [] -;;; (doto (java.text.SimpleDateFormat. "yyyy-MM-dd'T'HH:mm:ss") -;;; (.setTimeZone (java.util.TimeZone/getTimeZone "GMT")))))) - -;;;(defn- print-timestamp -;;; "Print a java.sql.Timestamp as RFC3339 timestamp, always in UTC." -;;; [^java.sql.Timestamp ts, ^java.io.Writer w] -;;; (let [^java.text.DateFormat utc-format (.get thread-local-utc-timestamp-format)] -;;; (.write w "#inst \"") -;;; (.write w (.format utc-format ts)) -;;; ;; add on nanos and offset -;;; ;; RFC3339 says to use -00:00 when the timezone is unknown (+00:00 implies a known GMT) -;;; (.write w (format ".%09d-00:00" (.getNanos ts))) -;;; (.write w "\""))) - -;;;(defmethod print-method java.sql.Timestamp -;;; [^java.sql.Timestamp ts, ^java.io.Writer w] -;;; (print-timestamp ts w)) - -;;;(defmethod print-dup java.sql.Timestamp -;;; [^java.sql.Timestamp ts, ^java.io.Writer w] -;;; (print-timestamp ts w)) - - -;;; ------------------------------------------------------------------------ -;;; reader integration - -;;;(defn- construct-calendar -;;; "Construct a java.util.Calendar, preserving the timezone -;;;offset, but truncating the subsecond fraction to milliseconds." -;;; ^GregorianCalendar -;;; [years months days hours minutes seconds nanoseconds -;;; offset-sign offset-hours offset-minutes] -;;; (doto (GregorianCalendar. years (dec months) days hours minutes seconds) -;;; (.set Calendar/MILLISECOND (/ nanoseconds 1000000)) -;;; (.setTimeZone (TimeZone/getTimeZone -;;; (format "GMT%s%02d:%02d" -;;; (if (neg? offset-sign) "-" "+") -;;; offset-hours offset-minutes))))) - -;;; DM: Added -(defn- construct-datetimeoffset - "Construct a System.DateTimeOffset, preserving the timezone offset -but truncating the subsecond fraction to milliseconds." - ^DateTimeOffset - [years months days hours minutes seconds nanoseconds - offset-sign offset-hours offset-minutes] - (DateTimeOffset. years months days hours minutes seconds - (/ nanoseconds 1000000) - (if (neg? offset-sign) - (TimeSpan. (- offset-hours) (- offset-minutes) 0) - (TimeSpan. offset-hours offset-minutes 0)))) -;;; - - -;;;(defn- construct-date -;;; "Construct a java.util.Date, which expresses the original instant as -;;;milliseconds since the epoch, UTC." -;;; [years months days hours minutes seconds nanoseconds -;;; offset-sign offset-hours offset-minutes] -;;; (.getTime (construct-calendar years months days -;;; hours minutes seconds nanoseconds -;;; offset-sign offset-hours offset-minutes))) - -;;; DM: Added -(defn- construct-datetime - "Construct a System.DateTime, which expresses the original instant as -milliseconds since the epoch, UTC." - [years months days hours minutes seconds nanoseconds - offset-sign offset-hours offset-minutes] - (.UtcDateTime (construct-datetimeoffset years months days - hours minutes seconds nanoseconds - offset-sign offset-hours offset-minutes))) -;;; - - -;;;(defn- construct-timestamp -;;; "Construct a java.sql.Timestamp, which has nanosecond precision." -;;; [years months days hours minutes seconds nanoseconds -;;; offset-sign offset-hours offset-minutes] -;;; (doto (Timestamp. -;;; (.getTimeInMillis -;;; (construct-calendar years months days -;;; hours minutes seconds nanoseconds -;;; offset-sign offset-hours offset-minutes))) -;;; (.setNanos nanoseconds))) - -(defn read-instant-datetime ;;; read-instant-date - "To read an instant as a System.DateTime, bind *data-readers* to a map with -this var as the value for the 'inst key. The timezone offset will be used -to convert into UTC." - [^String cs] ;;; CharSequence - (parse-timestamp (validated construct-datetime) cs)) ;;; construct-date - -;;; DM: Added -(defn read-instant-datetimeoffset - "To read an instant as a System.DateTimeOffset, bind *data-readers* to a map with -this var as the value for the 'inst key. The timezone offset will be used -to convert into UTC." - [^String cs] - (parse-timestamp (validated construct-datetimeoffset) cs)) -;;; - -;;;(defn read-instant-calendar -;;; "To read an instant as a java.util.Calendar, bind *data-readers* to a map with -;;;this var as the value for the 'inst key. Calendar preserves the timezone -;;;offset." -;;; [^CharSequence cs] -;;; (parse-timestamp (validated construct-calendar) cs)) - -;;;(defn read-instant-timestamp -;;; "To read an instant as a java.sql.Timestamp, bind *data-readers* to a -;;;map with this var as the value for the 'inst key. Timestamp preserves -;;;fractional seconds with nanosecond precision. The timezone offset will -;;;be used to convert into UTC." -;;; [^CharSequence cs] +; 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. + +(ns clojure.instant + ;;;(:import [java.util Calendar Date GregorianCalendar TimeZone] ;;; Do we want to do + );;; [java.sql Timestamp])) ;;; Do we want to do [System.DataSqlTypes SqlDateTime] + + +(set! *warn-on-reflection* true) + +;;; ------------------------------------------------------------------------ +;;; convenience macros + +(defmacro ^:private fail + [msg] + `(throw (Exception. ~msg))) ;;; RuntimeException. + +(defmacro ^:private verify + ([test msg] `(when-not ~test (fail ~msg))) + ([test] `(verify ~test ~(str "failed: " (pr-str test))))) + +(defn- divisible? + [num div] + (zero? (mod num div))) + +(defn- indivisible? + [num div] + (not (divisible? num div))) + + +;;; ------------------------------------------------------------------------ +;;; parser implementation + +(defn- parse-int [^String s] + (if (String/IsNullOrEmpty s) 0 (Int64/Parse s))) ;;; (Long/parseLong s)) + +(defn- zero-fill-right [^String s width] + (cond (= width (count s)) s + (< width (count s)) (.Substring s 0 width) ;;; .substring + :else (loop [b (StringBuilder. s)] + (if (< (.Length b) width) ;;; .length + (recur (.Append b \0)) ;;; .append + (.ToString b))))) ;;; .toString + +(def ^:private timestamp + #"(\d\d\d\d)(?:-(\d\d)(?:-(\d\d)(?:[T](\d\d)(?::(\d\d)(?::(\d\d)(?:[.](\d+))?)?)?)?)?)?(?:[Z]|([-+])(\d\d):(\d\d))?") + +(defn parse-timestamp + "Parse a string containing an RFC3339-like like timestamp. + +The function new-instant is called with the following arguments. + + min max default + --- ------------ ------- + years 0 9999 N/A (s must provide years) + months 1 12 1 + days 1 31 1 (actual max days depends + hours 0 23 0 on month and year) + minutes 0 59 0 + seconds 0 60 0 (though 60 is only valid + nanoseconds 0 999999999 0 when minutes is 59) + offset-sign -1 1 0 + offset-hours 0 23 0 + offset-minutes 0 59 0 + +These are all integers and will be non-nil. (The listed defaults +will be passed if the corresponding field is not present in s.) + +Grammar (of s): + + date-fullyear = 4DIGIT + date-month = 2DIGIT ; 01-12 + date-mday = 2DIGIT ; 01-28, 01-29, 01-30, 01-31 based on + ; month/year + time-hour = 2DIGIT ; 00-23 + time-minute = 2DIGIT ; 00-59 + time-second = 2DIGIT ; 00-58, 00-59, 00-60 based on leap second + ; rules + time-secfrac = '.' 1*DIGIT + time-numoffset = ('+' / '-') time-hour ':' time-minute + time-offset = 'Z' / time-numoffset + + time-part = time-hour [ ':' time-minute [ ':' time-second + [time-secfrac] [time-offset] ] ] + + timestamp = date-year [ '-' date-month [ '-' date-mday + [ 'T' time-part ] ] ] + +Unlike RFC3339: + + - we only parse the timestamp format + - timestamp can elide trailing components + - time-offset is optional (defaults to +00:00) + +Though time-offset is syntactically optional, a missing time-offset +will be treated as if the time-offset zero (+00:00) had been +specified. +" + [new-instant ^String cs] ;;; ^CharSequence + (if-let [[_ years months days hours minutes seconds fraction + offset-sign offset-hours offset-minutes] + (re-matches timestamp cs)] + (new-instant + (parse-int years) + (if (String/IsNullOrEmpty months) 1 (parse-int months)) ;;; (if-not months 1 (parse-int months)) + (if (String/IsNullOrEmpty days) 1 (parse-int days)) ;;; (if-not days 1 (parse-int days)) + (if (String/IsNullOrEmpty hours) 0 (parse-int hours)) ;;; (if-not hours 0 (parse-int hours)) + (if (String/IsNullOrEmpty minutes) 0 (parse-int minutes)) ;;; (if-not minutes 0 (parse-int minutes)) + (if (String/IsNullOrEmpty seconds) 0 (parse-int seconds)) ;;; (if-not seconds 0 (parse-int seconds)) + (if (String/IsNullOrEmpty fraction) 0 (parse-int (zero-fill-right fraction 9))) ;;; (if-not fraction 0 (parse-int (zero-fill-right fraction 9))) + (cond (= "-" offset-sign) -1 + (= "+" offset-sign) 1 + :else 0) + (if (String/IsNullOrEmpty offset-hours) 0 (parse-int offset-hours)) ;;; (if-not offset-hours 0 (parse-int offset-hours)) + (if (String/IsNullOrEmpty offset-minutes) 0 (parse-int offset-minutes))) ;;; (if-not offset-minutes 0 (parse-int offset-minutes)) + (fail (str "Unrecognized date/time syntax: " cs)))) + + +;;; ------------------------------------------------------------------------ +;;; Verification of Extra-Grammatical Restrictions from RFC3339 + +(defn- leap-year? + [year] + (and (divisible? year 4) + (or (indivisible? year 100) + (divisible? year 400)))) + +(def ^:private days-in-month + (let [dim-norm [nil 31 28 31 30 31 30 31 31 30 31 30 31] + dim-leap [nil 31 29 31 30 31 30 31 31 30 31 30 31]] + (fn [month leap-year?] + ((if leap-year? dim-leap dim-norm) month)))) + +(defn validated + "Return a function which constructs an instant by calling constructor +after first validating that those arguments are in range and otherwise +plausible. The resulting function will throw an exception if called +with invalid arguments." + [new-instance] + (fn [years months days hours minutes seconds nanoseconds + offset-sign offset-hours offset-minutes] + (verify (<= 1 months 12)) + (verify (<= 1 days (days-in-month months (leap-year? years)))) + (verify (<= 0 hours 23)) + (verify (<= 0 minutes 59)) + (verify (<= 0 seconds (if (= minutes 59) 60 59))) + (verify (<= 0 nanoseconds 999999999)) + (verify (<= -1 offset-sign 1)) + (verify (<= 0 offset-hours 23)) + (verify (<= 0 offset-minutes 59)) + (new-instance years months days hours minutes seconds nanoseconds + offset-sign offset-hours offset-minutes))) + + +;;; ------------------------------------------------------------------------ +;;; print integration + +;;;(def ^:private ^ThreadLocal thread-local-utc-date-format +;;; ;; SimpleDateFormat is not thread-safe, so we use a ThreadLocal proxy for access. +;;; ;; http://bugs.sun.com/bugdatabase/view_bug.do?bug_id=4228335 +;;; (proxy [ThreadLocal] [] +;;; (initialValue [] +;;; (doto (java.text.SimpleDateFormat. "yyyy-MM-dd'T'HH:mm:ss.SSS-00:00") +;;; ;; RFC3339 says to use -00:00 when the timezone is unknown (+00:00 implies a known GMT) +;;; (.setTimeZone (java.util.TimeZone/getTimeZone "GMT")))))) + +(defn- print-datetime ;;; print-date + "Print a System.DateTime as RFC3339 timestamp, always in UTC." ;;; java.util.Date + [ ^System.DateTime d, ^System.IO.TextWriter w] ;;; ^java.util.Date ^java.io.Writer + (let [utc-format "yyyy-MM-ddTHH:mm:ss.fff-00:00"] ;;; ^java.text.DateFormat utc-format (.get thread-local-utc-date-format) + (.Write w "#inst \"") ;;; .write + (.Write w (.ToString d utc-format )) ;;; (.write w (.format utc-format d)) + (.Write w "\""))) ;;; .write + +;;; DM Added +(defn- print-datetimeoffset + "Print a System.DateTimeOffset as RFC3339 timestamp, always in UTC." + [ ^System.DateTimeOffset d, ^System.IO.TextWriter w] + (let [utc-format "yyyy-MM-ddTHH:mm:ss.fffzzzz"] + (.Write w "#inst \"") + (.Write w (.ToString d utc-format )) + (.Write w "\""))) +;;; + +(defmethod print-method System.DateTime ;;; java.util.Date + [^System.DateTime d, ^System.IO.TextWriter w] ;;; ^java.util.Date ^java.io.Writer + (print-datetime d w)) ;;; print-date + +(defmethod print-dup System.DateTime ;;; java.util.Date + [^System.DateTime d, ^System.IO.TextWriter w] ;;; ^java.util.Date ^java.io.Writer + (print-datetime d w)) ;;; print-date + +;;;(defn- print-calendar +;;; "Print a java.util.Calendar as RFC3339 timestamp, preserving timezone." +;;; [^java.util.Calendar c, ^java.io.Writer w] +;;; (let [calstr (format "%1$tFT%1$tT.%1$tL%1$tz" c) +;;; offset-minutes (- (.length calstr) 2)] +;;; ;; calstr is almost right, but is missing the colon in the offset +;;; (.write w "#inst \"") +;;; (.write w calstr 0 offset-minutes) +;;; (.write w ":") +;;; (.write w calstr offset-minutes 2) +;;; (.write w "\""))) + +(defmethod print-method System.DateTimeOffset ;;; java.util.Calendar + [^System.DateTimeOffset d, ^System.IO.TextWriter w] ;;; ^java.util.Calendar ^java.io.Writer + (print-datetimeoffset d w)) ;;; print-date + +(defmethod print-dup System.DateTimeOffset ;;; java.util.Calendar + [^System.DateTimeOffset d, ^System.IO.TextWriter w] ;;; ^java.util.Calendar ^java.io.Writer + (print-datetimeoffset d w)) ;;; print-date + +;;;(def ^:private ^ThreadLocal thread-local-utc-timestamp-format +;;; ;; SimpleDateFormat is not thread-safe, so we use a ThreadLocal proxy for access. +;;; ;; http://bugs.sun.com/bugdatabase/view_bug.do?bug_id=4228335 +;;; (proxy [ThreadLocal] [] +;;; (initialValue [] +;;; (doto (java.text.SimpleDateFormat. "yyyy-MM-dd'T'HH:mm:ss") +;;; (.setTimeZone (java.util.TimeZone/getTimeZone "GMT")))))) + +;;;(defn- print-timestamp +;;; "Print a java.sql.Timestamp as RFC3339 timestamp, always in UTC." +;;; [^java.sql.Timestamp ts, ^java.io.Writer w] +;;; (let [^java.text.DateFormat utc-format (.get thread-local-utc-timestamp-format)] +;;; (.write w "#inst \"") +;;; (.write w (.format utc-format ts)) +;;; ;; add on nanos and offset +;;; ;; RFC3339 says to use -00:00 when the timezone is unknown (+00:00 implies a known GMT) +;;; (.write w (format ".%09d-00:00" (.getNanos ts))) +;;; (.write w "\""))) + +;;;(defmethod print-method java.sql.Timestamp +;;; [^java.sql.Timestamp ts, ^java.io.Writer w] +;;; (print-timestamp ts w)) + +;;;(defmethod print-dup java.sql.Timestamp +;;; [^java.sql.Timestamp ts, ^java.io.Writer w] +;;; (print-timestamp ts w)) + + +;;; ------------------------------------------------------------------------ +;;; reader integration + +;;;(defn- construct-calendar +;;; "Construct a java.util.Calendar, preserving the timezone +;;;offset, but truncating the subsecond fraction to milliseconds." +;;; ^GregorianCalendar +;;; [years months days hours minutes seconds nanoseconds +;;; offset-sign offset-hours offset-minutes] +;;; (doto (GregorianCalendar. years (dec months) days hours minutes seconds) +;;; (.set Calendar/MILLISECOND (/ nanoseconds 1000000)) +;;; (.setTimeZone (TimeZone/getTimeZone +;;; (format "GMT%s%02d:%02d" +;;; (if (neg? offset-sign) "-" "+") +;;; offset-hours offset-minutes))))) + +;;; DM: Added +(defn- construct-datetimeoffset + "Construct a System.DateTimeOffset, preserving the timezone offset +but truncating the subsecond fraction to milliseconds." + ^DateTimeOffset + [years months days hours minutes seconds nanoseconds + offset-sign offset-hours offset-minutes] + (DateTimeOffset. years months days hours minutes seconds + (/ nanoseconds 1000000) + (if (neg? offset-sign) + (TimeSpan. (- offset-hours) (- offset-minutes) 0) + (TimeSpan. offset-hours offset-minutes 0)))) +;;; + + +;;;(defn- construct-date +;;; "Construct a java.util.Date, which expresses the original instant as +;;;milliseconds since the epoch, UTC." +;;; [years months days hours minutes seconds nanoseconds +;;; offset-sign offset-hours offset-minutes] +;;; (.getTime (construct-calendar years months days +;;; hours minutes seconds nanoseconds +;;; offset-sign offset-hours offset-minutes))) + +;;; DM: Added +(defn- construct-datetime + "Construct a System.DateTime, which expresses the original instant as +milliseconds since the epoch, UTC." + [years months days hours minutes seconds nanoseconds + offset-sign offset-hours offset-minutes] + (.UtcDateTime (construct-datetimeoffset years months days + hours minutes seconds nanoseconds + offset-sign offset-hours offset-minutes))) +;;; + + +;;;(defn- construct-timestamp +;;; "Construct a java.sql.Timestamp, which has nanosecond precision." +;;; [years months days hours minutes seconds nanoseconds +;;; offset-sign offset-hours offset-minutes] +;;; (doto (Timestamp. +;;; (.getTimeInMillis +;;; (construct-calendar years months days +;;; hours minutes seconds nanoseconds +;;; offset-sign offset-hours offset-minutes))) +;;; (.setNanos nanoseconds))) + +(defn read-instant-datetime ;;; read-instant-date + "To read an instant as a System.DateTime, bind *data-readers* to a map with +this var as the value for the 'inst key. The timezone offset will be used +to convert into UTC." + [^String cs] ;;; CharSequence + (parse-timestamp (validated construct-datetime) cs)) ;;; construct-date + +;;; DM: Added +(defn read-instant-datetimeoffset + "To read an instant as a System.DateTimeOffset, bind *data-readers* to a map with +this var as the value for the 'inst key. The timezone offset will be used +to convert into UTC." + [^String cs] + (parse-timestamp (validated construct-datetimeoffset) cs)) +;;; + +;;;(defn read-instant-calendar +;;; "To read an instant as a java.util.Calendar, bind *data-readers* to a map with +;;;this var as the value for the 'inst key. Calendar preserves the timezone +;;;offset." +;;; [^CharSequence cs] +;;; (parse-timestamp (validated construct-calendar) cs)) + +;;;(defn read-instant-timestamp +;;; "To read an instant as a java.sql.Timestamp, bind *data-readers* to a +;;;map with this var as the value for the 'inst key. Timestamp preserves +;;;fractional seconds with nanosecond precision. The timezone offset will +;;;be used to convert into UTC." +;;; [^CharSequence cs] ;;; (parse-timestamp (validated construct-timestamp) cs)) \ No newline at end of file diff --git a/Clojure/Clojure.Source/clojure/main.clj b/Clojure/Clojure.Source/clojure/main.clj index a0a075b90..727036324 100644 --- a/Clojure/Clojure.Source/clojure/main.clj +++ b/Clojure/Clojure.Source/clojure/main.clj @@ -8,13 +8,13 @@ ;; 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]) (:require [clojure.spec.alpha :as spec]) - (:import (System.IO StringReader FileInfo FileStream Path StreamWriter) ;;; java.io StringReader BufferedWriter FileWriter - ;;; (java.nio.file Files) + (:import (System.IO StringReader FileInfo FileStream Path StreamWriter) ;;; java.io StringReader BufferedWriter FileWriter + ;;; (java.nio.file Files) ;;; (java.nio.file.attribute FileAttribute) (clojure.lang Compiler Compiler+CompilerException ;;; Compiler$CompilerException LineNumberingTextReader RT LispReader+ReaderException)) ;;; LineNumberingPushbackReader LispReader$ReaderException @@ -23,15 +23,15 @@ (declare main) -;;;;;;;;;;;;;;;;;;; redundantly copied from clojure.repl to avoid dep ;;;;;;;;;;;;;; - -(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 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" @@ -43,57 +43,57 @@ cause (if-let [cause (.InnerException cause)] ;;; .getCause (recur cause) - cause)))) - -;;;;;;;;;;;;;;;;;;; end of redundantly copied from clojure.repl to avoid dep ;;;;;;;;;;;;;; - -(def ^:private core-namespaces - #{"clojure.core" "clojure.core.reducers" "clojure.core.protocols" "clojure.data" "clojure.datafy" - "clojure.edn" "clojure.instant" "clojure.java.io" "clojure.main" "clojure.pprint" "clojure.reflect" - "clojure.repl" "clojure.set" "clojure.spec.alpha" "clojure.spec.gen.alpha" "clojure.spec.test.alpha" - "clojure.string" "clojure.template" "clojure.uuid" "clojure.walk" "clojure.xml" "clojure.zip"}) - -(defn- core-class? - [^String class-name] - (and (not (nil? class-name)) - (or (.StartsWith class-name "clojure.lang.") ;;; .startsWith - (contains? core-namespaces (second (re-find #"^([^$]+)\$" class-name)))))) - -;;; 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] + cause)))) + +;;;;;;;;;;;;;;;;;;; end of redundantly copied from clojure.repl to avoid dep ;;;;;;;;;;;;;; + +(def ^:private core-namespaces + #{"clojure.core" "clojure.core.reducers" "clojure.core.protocols" "clojure.data" "clojure.datafy" + "clojure.edn" "clojure.instant" "clojure.java.io" "clojure.main" "clojure.pprint" "clojure.reflect" + "clojure.repl" "clojure.set" "clojure.spec.alpha" "clojure.spec.gen.alpha" "clojure.spec.test.alpha" + "clojure.string" "clojure.template" "clojure.uuid" "clojure.walk" "clojure.xml" "clojure.zip"}) + +(defn- core-class? + [^String class-name] + (and (not (nil? class-name)) + (or (.StartsWith class-name "clojure.lang.") ;;; .startsWith + (contains? core-namespaces (second (re-find #"^([^$]+)\$" class-name)))))) + +;;; 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 (some-> el (.GetMethod) (.ReflectedType))] (.FullName t) "NO_CLASS")) - -(defn stack-element-methodname - [^System.Diagnostics.StackFrame el] + +(defn stack-element-methodname + [^System.Diagnostics.StackFrame el] (or (some-> el (.GetMethod) (.Name)) - "NO_METHOD")) - -;;; - - -(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 - (.EndsWith file ".cljc") (.EndsWith file ".cljr") ;;; endsWith + DM: Added cljr - (= 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 ;;;;;;;;;;;;;; - + "NO_METHOD")) + +;;; + + +(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 + (.EndsWith file ".cljc") (.EndsWith file ".cljr") ;;; endsWith + DM: Added cljr + (= 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 @@ -158,19 +158,19 @@ (or (Char/IsWhiteSpace (char c)) (= c (int \,))) (recur (.Read s)) ;;; (Character/isWhitespace c) .read :else (do (.Unread s c) :body)))) ;;; .unread -(defn renumbering-read - "Reads from reader, which must be a LineNumberingPushbackReader, while capturing - the read string. If the read is successful, reset the line number and re-read. - The line number on re-read is the passed line-number unless :line or - :clojure.core/eval-file meta are explicitly set on the read value." - {:added "1.10"} - ([opts ^LineNumberingTextReader reader line-number] ;;; LineNumberingPushbackReader - (let [pre-line (.LineNumber reader) ;;; .getLineNumber - [pre-read s] (read+string opts reader) - {:keys [clojure.core/eval-file line]} (meta pre-read) - re-reader (doto (LineNumberingTextReader. (StringReader. s)) ;;; LineNumberingPushbackReader. - (.set_LineNumber (if (and line (or eval-file (not= pre-line line))) line line-number)))] ;;; .setLineNumber - (read opts re-reader)))) +(defn renumbering-read + "Reads from reader, which must be a LineNumberingPushbackReader, while capturing + the read string. If the read is successful, reset the line number and re-read. + The line number on re-read is the passed line-number unless :line or + :clojure.core/eval-file meta are explicitly set on the read value." + {:added "1.10"} + ([opts ^LineNumberingTextReader reader line-number] ;;; LineNumberingPushbackReader + (let [pre-line (.LineNumber reader) ;;; .getLineNumber + [pre-read s] (read+string opts reader) + {:keys [clojure.core/eval-file line]} (meta pre-read) + re-reader (doto (LineNumberingTextReader. (StringReader. s)) ;;; LineNumberingPushbackReader. + (.set_LineNumber (if (and line (or eval-file (not= pre-line line))) line line-number)))] ;;; .setLineNumber + (read opts re-reader)))) (defn repl-read "Default :read hook for repl. Reads from *in* which must either be an @@ -195,196 +195,196 @@ [throwable] (root-cause throwable)) -(defn- file-name - "Helper to get just the file name part of a path or nil" - [^String full-path] - (when full-path - (try - (.Name (System.IO.FileInfo. full-path)) ;;; .getName java.io.File. +(defn- file-name + "Helper to get just the file name part of a path or nil" + [^String full-path] + (when full-path + (try + (.Name (System.IO.FileInfo. full-path)) ;;; .getName java.io.File. (catch Exception t)))) ;;; Throwable - -(defn- file-path ;;; probably not exactly equivalante to Java version, not similar notion of relative/absolute. - "Helper to get the relative path to the source file or nil" - [^String full-path] - (when full-path - (try - (let [path (.DirectoryName (System.IO.FileInfo. full-path)) ;;; .getPath java.io.File. - cd-path (str (.DirectoryName (System.IO.FileInfo. "")) "\\")] ;;; .getAbsolutePath java.io.File. "/" - (if (.StartsWith path cd-path) ;;; .startsWith - (subs path (count cd-path)) - path)) - (catch Exception t ;;; Throwable - full-path)))) - -(defn- java-loc->source - "Convert Java class name and method symbol to source symbol, either a - Clojure function or Java class and method." - [clazz method] - (if (#{'invoke 'invokeStatic} method) - (let [degen #(.Replace #"--.*$" ^String % "") ;;; #(.replaceAll ^String % "--.*$" "") - [ns-name fn-name & nested] (->> (str clazz) (.Split #"\$") (map demunge) (map degen))] ;;; .split - (symbol ns-name (String/Join "$" ^|System.String[]| (into-array String (cons fn-name nested))))) ;;; String/join ^"[Ljava.lang.String;" - (symbol (name clazz) (name method)))) - -(defn ex-triage - "Returns an analysis of the phase, error, cause, and location of an error that occurred - based on Throwable data, as returned by Throwable->map. All attributes other than phase - are optional: - :clojure.error/phase - keyword phase indicator, one of: - :read-source :compile-syntax-check :compilation :macro-syntax-check :macroexpansion - :execution :read-eval-result :print-eval-result - :clojure.error/source - file name (no path) - :clojure.error/path - source path - :clojure.error/line - integer line number - :clojure.error/column - integer column number - :clojure.error/symbol - symbol being expanded/compiled/invoked - :clojure.error/class - cause exception class symbol - :clojure.error/cause - cause exception message - :clojure.error/spec - explain-data for spec error" - {:added "1.10"} - [datafied-throwable] - (let [{:keys [via trace phase] :or {phase :execution}} datafied-throwable - {:keys [type message data]} (last via) - {:clojure.spec.alpha/keys [problems fn], :clojure.spec.test.alpha/keys [caller]} data - {:clojure.error/keys [source] :as top-data} (:data (first via))] - (assoc - (case phase - :read-source - (let [{:clojure.error/keys [line column]} data] - (cond-> (merge (-> via second :data) top-data) - source (assoc :clojure.error/source (file-name source) - :clojure.error/path (file-path source)) - (#{"NO_SOURCE_FILE" "NO_SOURCE_PATH"} source) (dissoc :clojure.error/source :clojure.error/path) - message (assoc :clojure.error/cause message))) - - (:compile-syntax-check :compilation :macro-syntax-check :macroexpansion) - (cond-> top-data - source (assoc :clojure.error/source (file-name source) - :clojure.error/path (file-path source)) - (#{"NO_SOURCE_FILE" "NO_SOURCE_PATH"} source) (dissoc :clojure.error/source :clojure.error/path) - type (assoc :clojure.error/class type) - message (assoc :clojure.error/cause message) - problems (assoc :clojure.error/spec data)) - - (:read-eval-result :print-eval-result) - (let [[source method file line] (-> trace first)] - (cond-> top-data - line (assoc :clojure.error/line line) - file (assoc :clojure.error/source file) - (and source method) (assoc :clojure.error/symbol (java-loc->source source method)) - type (assoc :clojure.error/class type) - message (assoc :clojure.error/cause message))) - - :execution - (let [[source method file line] (->> trace (drop-while #(core-class? (name (first %)))) first) - file (first (remove #(or (nil? %) (#{"NO_SOURCE_FILE" "NO_SOURCE_PATH"} %)) [(:file caller) file])) - err-line (or (:line caller) line)] - (cond-> {:clojure.error/class type} - err-line (assoc :clojure.error/line err-line) - message (assoc :clojure.error/cause message) - (or fn (and source method)) (assoc :clojure.error/symbol (or fn (java-loc->source source method))) - file (assoc :clojure.error/source file) - problems (assoc :clojure.error/spec data)))) - :clojure.error/phase phase))) - -(defn ex-str - "Returns a string from exception data, as produced by ex-triage. - The first line summarizes the exception phase and location. - The subsequent lines describe the cause." - {:added "1.10"} - [{:clojure.error/keys [phase source path line column symbol class cause spec] - :as triage-data}] - (let [loc (str (or path source "REPL") ":" (or line 1) (if column (str ":" column) "")) - class-name (name (or class "")) - simple-class (if class (or (first (re-find #"([^.])+$" class-name)) class-name)) ;;; #"([^.])++$" - cause-type (if (contains? #{"Exception" "RuntimeException"} simple-class) - "" ;; omit, not useful - (str " (" simple-class ")"))] - (case phase - :read-source - (format "Syntax error reading source at (%s).%n%s%n" loc cause) - - :macro-syntax-check - (format "Syntax error macroexpanding %sat (%s).%n%s" - (if symbol (str symbol " ") "") - loc - (if spec - (with-out-str - (spec/explain-out - (if (= spec/*explain-out* spec/explain-printer) - (update spec :clojure.spec.alpha/problems - (fn [probs] (map #(dissoc % :in) probs))) - spec))) - (format "%s%n" cause))) - - :macroexpansion - (format "Unexpected error%s macroexpanding %sat (%s).%n%s%n" - cause-type - (if symbol (str symbol " ") "") - loc - cause) - - :compile-syntax-check - (format "Syntax error%s compiling %sat (%s).%n%s%n" - cause-type - (if symbol (str symbol " ") "") - loc - cause) - - :compilation - (format "Unexpected error%s compiling %sat (%s).%n%s%n" - cause-type - (if symbol (str symbol " ") "") - loc - cause) - - :read-eval-result - (format "Error reading eval result%s at %s (%s).%n%s%n" cause-type symbol loc cause) - - :print-eval-result - (format "Error printing return value%s at %s (%s).%n%s%n" cause-type symbol loc cause) - - :execution - (if spec - (format "Execution error - invalid arguments to %s at (%s).%n%s" - symbol - loc - (with-out-str - (spec/explain-out - (if (= spec/*explain-out* spec/explain-printer) - (update spec :clojure.spec.alpha/problems - (fn [probs] (map #(dissoc % :in) probs))) - spec)))) - (format "Execution error%s at %s(%s).%n%s%n" - cause-type - (if symbol (str symbol " ") "") - loc - cause))))) - -(defn err->msg - "Helper to return an error message string from an exception." - [^Exception e] ;;; Throwable + +(defn- file-path ;;; probably not exactly equivalante to Java version, not similar notion of relative/absolute. + "Helper to get the relative path to the source file or nil" + [^String full-path] + (when full-path + (try + (let [path (.DirectoryName (System.IO.FileInfo. full-path)) ;;; .getPath java.io.File. + cd-path (str (.DirectoryName (System.IO.FileInfo. "")) "\\")] ;;; .getAbsolutePath java.io.File. "/" + (if (.StartsWith path cd-path) ;;; .startsWith + (subs path (count cd-path)) + path)) + (catch Exception t ;;; Throwable + full-path)))) + +(defn- java-loc->source + "Convert Java class name and method symbol to source symbol, either a + Clojure function or Java class and method." + [clazz method] + (if (#{'invoke 'invokeStatic} method) + (let [degen #(.Replace #"--.*$" ^String % "") ;;; #(.replaceAll ^String % "--.*$" "") + [ns-name fn-name & nested] (->> (str clazz) (.Split #"\$") (map demunge) (map degen))] ;;; .split + (symbol ns-name (String/Join "$" ^|System.String[]| (into-array String (cons fn-name nested))))) ;;; String/join ^"[Ljava.lang.String;" + (symbol (name clazz) (name method)))) + +(defn ex-triage + "Returns an analysis of the phase, error, cause, and location of an error that occurred + based on Throwable data, as returned by Throwable->map. All attributes other than phase + are optional: + :clojure.error/phase - keyword phase indicator, one of: + :read-source :compile-syntax-check :compilation :macro-syntax-check :macroexpansion + :execution :read-eval-result :print-eval-result + :clojure.error/source - file name (no path) + :clojure.error/path - source path + :clojure.error/line - integer line number + :clojure.error/column - integer column number + :clojure.error/symbol - symbol being expanded/compiled/invoked + :clojure.error/class - cause exception class symbol + :clojure.error/cause - cause exception message + :clojure.error/spec - explain-data for spec error" + {:added "1.10"} + [datafied-throwable] + (let [{:keys [via trace phase] :or {phase :execution}} datafied-throwable + {:keys [type message data]} (last via) + {:clojure.spec.alpha/keys [problems fn], :clojure.spec.test.alpha/keys [caller]} data + {:clojure.error/keys [source] :as top-data} (:data (first via))] + (assoc + (case phase + :read-source + (let [{:clojure.error/keys [line column]} data] + (cond-> (merge (-> via second :data) top-data) + source (assoc :clojure.error/source (file-name source) + :clojure.error/path (file-path source)) + (#{"NO_SOURCE_FILE" "NO_SOURCE_PATH"} source) (dissoc :clojure.error/source :clojure.error/path) + message (assoc :clojure.error/cause message))) + + (:compile-syntax-check :compilation :macro-syntax-check :macroexpansion) + (cond-> top-data + source (assoc :clojure.error/source (file-name source) + :clojure.error/path (file-path source)) + (#{"NO_SOURCE_FILE" "NO_SOURCE_PATH"} source) (dissoc :clojure.error/source :clojure.error/path) + type (assoc :clojure.error/class type) + message (assoc :clojure.error/cause message) + problems (assoc :clojure.error/spec data)) + + (:read-eval-result :print-eval-result) + (let [[source method file line] (-> trace first)] + (cond-> top-data + line (assoc :clojure.error/line line) + file (assoc :clojure.error/source file) + (and source method) (assoc :clojure.error/symbol (java-loc->source source method)) + type (assoc :clojure.error/class type) + message (assoc :clojure.error/cause message))) + + :execution + (let [[source method file line] (->> trace (drop-while #(core-class? (name (first %)))) first) + file (first (remove #(or (nil? %) (#{"NO_SOURCE_FILE" "NO_SOURCE_PATH"} %)) [(:file caller) file])) + err-line (or (:line caller) line)] + (cond-> {:clojure.error/class type} + err-line (assoc :clojure.error/line err-line) + message (assoc :clojure.error/cause message) + (or fn (and source method)) (assoc :clojure.error/symbol (or fn (java-loc->source source method))) + file (assoc :clojure.error/source file) + problems (assoc :clojure.error/spec data)))) + :clojure.error/phase phase))) + +(defn ex-str + "Returns a string from exception data, as produced by ex-triage. + The first line summarizes the exception phase and location. + The subsequent lines describe the cause." + {:added "1.10"} + [{:clojure.error/keys [phase source path line column symbol class cause spec] + :as triage-data}] + (let [loc (str (or path source "REPL") ":" (or line 1) (if column (str ":" column) "")) + class-name (name (or class "")) + simple-class (if class (or (first (re-find #"([^.])+$" class-name)) class-name)) ;;; #"([^.])++$" + cause-type (if (contains? #{"Exception" "RuntimeException"} simple-class) + "" ;; omit, not useful + (str " (" simple-class ")"))] + (case phase + :read-source + (format "Syntax error reading source at (%s).%n%s%n" loc cause) + + :macro-syntax-check + (format "Syntax error macroexpanding %sat (%s).%n%s" + (if symbol (str symbol " ") "") + loc + (if spec + (with-out-str + (spec/explain-out + (if (= spec/*explain-out* spec/explain-printer) + (update spec :clojure.spec.alpha/problems + (fn [probs] (map #(dissoc % :in) probs))) + spec))) + (format "%s%n" cause))) + + :macroexpansion + (format "Unexpected error%s macroexpanding %sat (%s).%n%s%n" + cause-type + (if symbol (str symbol " ") "") + loc + cause) + + :compile-syntax-check + (format "Syntax error%s compiling %sat (%s).%n%s%n" + cause-type + (if symbol (str symbol " ") "") + loc + cause) + + :compilation + (format "Unexpected error%s compiling %sat (%s).%n%s%n" + cause-type + (if symbol (str symbol " ") "") + loc + cause) + + :read-eval-result + (format "Error reading eval result%s at %s (%s).%n%s%n" cause-type symbol loc cause) + + :print-eval-result + (format "Error printing return value%s at %s (%s).%n%s%n" cause-type symbol loc cause) + + :execution + (if spec + (format "Execution error - invalid arguments to %s at (%s).%n%s" + symbol + loc + (with-out-str + (spec/explain-out + (if (= spec/*explain-out* spec/explain-printer) + (update spec :clojure.spec.alpha/problems + (fn [probs] (map #(dissoc % :in) probs))) + spec)))) + (format "Execution error%s at %s(%s).%n%s%n" + cause-type + (if symbol (str symbol " ") "") + loc + cause))))) + +(defn err->msg + "Helper to return an error message string from an exception." + [^Exception e] ;;; Throwable (-> e Throwable->map ex-triage ex-str)) (defn repl-caught "Default :caught hook for repl" [e] - (binding [*out* *err*] - (print (err->msg e)) + (binding [*out* *err*] + (print (err->msg e)) (flush))) -(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*, @@ -430,8 +430,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 @@ -449,19 +449,19 @@ by default when a new command-line REPL is started."} repl-requires read-eval-print (fn [] (try - (let [read-eval *read-eval* - input (try - (with-read-known (read request-prompt request-exit)) - (catch LispReader+ReaderException e ;;; LispReader$ReaderException + (let [read-eval *read-eval* + input (try + (with-read-known (read request-prompt request-exit)) + (catch LispReader+ReaderException e ;;; LispReader$ReaderException (throw (ex-info nil {:clojure.error/phase :read-source} e))))] (or (#{request-prompt request-exit} input) (let [value (binding [*read-eval* read-eval] (eval input))] (set! *3 *2) (set! *2 *1) - (set! *1 value) - (try - (print value) - (catch Exception e ;;; Throwable + (set! *1 value) + (try + (print value) + (catch Exception e ;;; Throwable (throw (ex-info nil {:clojure.error/phase :print-eval-result} e))))))) (catch Exception e ;;; Throwable (caught e) @@ -475,11 +475,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) @@ -503,8 +503,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)] @@ -528,14 +528,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 @@ -543,8 +543,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 @@ -587,8 +587,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)))) @@ -597,43 +597,43 @@ 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)))) -(defn report-error - "Create and output an exception report for a Throwable to target. - - Options: - :target - \"file\" (default), \"stderr\", \"none\" - - If file is specified but cannot be written, falls back to stderr." - [^Exception t & {:keys [target] ;;; Throwable - :or {target "file"} :as opts}] - (when-not (= target "none") - (let [trace (Throwable->map t) - triage (ex-triage trace) - message (ex-str triage) - report (array-map - :clojure.main/message message - :clojure.main/triage triage - :clojure.main/trace trace) - report-str (with-out-str - (binding [*print-namespace-maps* false] - ((requiring-resolve 'clojure.pprint/pprint) report))) - err-path (when (= target "file") - (try - (let [f (FileInfo. (Path/Join (Path/GetTempPath) (str "clojure-" (System.Guid/NewGuid) ".edn")))] ;;; (.toFile (Files/createTempFile "clojure-" ".edn" (into-array FileAttribute []))) - (with-open [w (StreamWriter. (.OpenWrite f))] ;;; [w (BufferedWriter. (FileWriter. f)) - (binding [*out* w] (println report-str))) - (.FullName f)) ;;; .getAbsolutePath - (catch Exception _)))] ;; ignore, fallback to stderr ;;; Throwable - (binding [*out* *err*] - (if err-path - (println (str message (Environment/NewLine) "Full report at:" (Environment/NewLine) err-path)) ;;; System/lineSeparator - (println (str report-str (Environment/NewLine) message))))))) ;;; System/lineSeparator +(defn report-error + "Create and output an exception report for a Throwable to target. + + Options: + :target - \"file\" (default), \"stderr\", \"none\" + + If file is specified but cannot be written, falls back to stderr." + [^Exception t & {:keys [target] ;;; Throwable + :or {target "file"} :as opts}] + (when-not (= target "none") + (let [trace (Throwable->map t) + triage (ex-triage trace) + message (ex-str triage) + report (array-map + :clojure.main/message message + :clojure.main/triage triage + :clojure.main/trace trace) + report-str (with-out-str + (binding [*print-namespace-maps* false] + ((requiring-resolve 'clojure.pprint/pprint) report))) + err-path (when (= target "file") + (try + (let [f (FileInfo. (Path/Join (Path/GetTempPath) (str "clojure-" (System.Guid/NewGuid) ".edn")))] ;;; (.toFile (Files/createTempFile "clojure-" ".edn" (into-array FileAttribute []))) + (with-open [w (StreamWriter. (.OpenWrite f))] ;;; [w (BufferedWriter. (FileWriter. f)) + (binding [*out* w] (println report-str))) + (.FullName f)) ;;; .getAbsolutePath + (catch Exception _)))] ;; ignore, fallback to stderr ;;; Throwable + (binding [*out* *err*] + (if err-path + (println (str message (Environment/NewLine) "Full report at:" (Environment/NewLine) err-path)) ;;; System/lineSeparator + (println (str report-str (Environment/NewLine) message))))))) ;;; System/lineSeparator (defn main "Usage: java -cp clojure.jar clojure.main [init-opt*] [main-opt] [arg*] @@ -643,7 +643,7 @@ java -cp clojure.jar clojure.main -i init.clj script.clj args...") init options: -i, --init path Load a file or resource -e, --eval string Evaluate expressions in string; print non-nil values - --report target Report uncaught exception to \"file\" (default), \"stderr\", + --report target Report uncaught exception to \"file\" (default), \"stderr\", or \"none\", overrides System property clojure.main.report main options: @@ -671,26 +671,26 @@ java -cp clojure.jar clojure.main -i init.clj script.clj args...") [& args] (try (if args - (loop [[opt arg & more :as args] args, inits [], flags nil] - (cond - ;; flag - (contains? #{"--report"} opt) - (recur more inits (merge flags {(subs opt 2) arg})) - - ;; init opt - (init-dispatch opt) - (recur more (conj inits [opt arg]) flags) - - :main-opt - (try - ((main-dispatch opt) args inits) - (catch Exception t ;;; Throwable - (report-error t :target (get flags "report" (or (System.Environment/GetEnvironmentVariable "clojure.main.report") "file"))) ;;; System/getProperty - (Environment/Exit 1))))) ;;; System/exit - (try - (repl-opt nil nil) - (catch Exception t ;;; Throwable - (report-error t :target "file") + (loop [[opt arg & more :as args] args, inits [], flags nil] + (cond + ;; flag + (contains? #{"--report"} opt) + (recur more inits (merge flags {(subs opt 2) arg})) + + ;; init opt + (init-dispatch opt) + (recur more (conj inits [opt arg]) flags) + + :main-opt + (try + ((main-dispatch opt) args inits) + (catch Exception t ;;; Throwable + (report-error t :target (get flags "report" (or (System.Environment/GetEnvironmentVariable "clojure.main.report") "file"))) ;;; System/getProperty + (Environment/Exit 1))))) ;;; System/exit + (try + (repl-opt nil nil) + (catch Exception t ;;; Throwable + (report-error t :target "file") (Environment/Exit 1)))) ;;; System/exit (finally (flush)))) diff --git a/Clojure/Clojure.Source/clojure/pprint.clj b/Clojure/Clojure.Source/clojure/pprint.clj index cc6df5a76..86860e532 100644 --- a/Clojure/Clojure.Source/clojure/pprint.clj +++ b/Clojure/Clojure.Source/clojure/pprint.clj @@ -1,51 +1,51 @@ -;;; pprint.clj -- Pretty printer and Common Lisp compatible format function (cl-format) for Clojure - -; 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: Tom Faulhaber -;; April 3, 2009 - -(ns - ^{:author "Tom Faulhaber", - :doc "A Pretty Printer for Clojure - -clojure.pprint implements a flexible system for printing structured data -in a pleasing, easy-to-understand format. Basic use of the pretty printer is -simple, just call pprint instead of println. More advanced users can use -the building blocks provided to create custom output formats. - -Out of the box, pprint supports a simple structured format for basic data -and a specialized format for Clojure source code. More advanced formats, -including formats that don't look like Clojure data at all like XML and -JSON, can be rendered by creating custom dispatch functions. - -In addition to the pprint function, this module contains cl-format, a text -formatting function which is fully compatible with the format function in -Common Lisp. Because pretty printing directives are directly integrated with -cl-format, it supports very concise custom dispatch. It also provides -a more powerful alternative to Clojure's standard format function. - -See documentation for pprint and cl-format for more information or -complete documentation on the Clojure web site on GitHub.", - :added "1.2"} - clojure.pprint - (:refer-clojure :exclude (deftype)) - (:use [clojure.walk :only [walk]])) - -(set! *warn-on-reflection* true) - -(load "pprint/utilities") -(load "pprint/column_writer") -(load "pprint/pretty_writer") -(load "pprint/pprint_base") -(load "pprint/cl_format") -(load "pprint/dispatch") -(load "pprint/print_table") - -nil +;;; pprint.clj -- Pretty printer and Common Lisp compatible format function (cl-format) for Clojure + +; 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: Tom Faulhaber +;; April 3, 2009 + +(ns + ^{:author "Tom Faulhaber", + :doc "A Pretty Printer for Clojure + +clojure.pprint implements a flexible system for printing structured data +in a pleasing, easy-to-understand format. Basic use of the pretty printer is +simple, just call pprint instead of println. More advanced users can use +the building blocks provided to create custom output formats. + +Out of the box, pprint supports a simple structured format for basic data +and a specialized format for Clojure source code. More advanced formats, +including formats that don't look like Clojure data at all like XML and +JSON, can be rendered by creating custom dispatch functions. + +In addition to the pprint function, this module contains cl-format, a text +formatting function which is fully compatible with the format function in +Common Lisp. Because pretty printing directives are directly integrated with +cl-format, it supports very concise custom dispatch. It also provides +a more powerful alternative to Clojure's standard format function. + +See documentation for pprint and cl-format for more information or +complete documentation on the Clojure web site on GitHub.", + :added "1.2"} + clojure.pprint + (:refer-clojure :exclude (deftype)) + (:use [clojure.walk :only [walk]])) + +(set! *warn-on-reflection* true) + +(load "pprint/utilities") +(load "pprint/column_writer") +(load "pprint/pretty_writer") +(load "pprint/pprint_base") +(load "pprint/cl_format") +(load "pprint/dispatch") +(load "pprint/print_table") + +nil diff --git a/Clojure/Clojure.Source/clojure/pprint/cl_format.clj b/Clojure/Clojure.Source/clojure/pprint/cl_format.clj index 6d05b3442..eebc6ab04 100644 --- a/Clojure/Clojure.Source/clojure/pprint/cl_format.clj +++ b/Clojure/Clojure.Source/clojure/pprint/cl_format.clj @@ -1,1949 +1,1949 @@ -;;; cl_format.clj -- part of the pretty printer for Clojure - -; 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: Tom Faulhaber -;; April 3, 2009 - - -;; This module implements the Common Lisp compatible format function as documented -;; in "Common Lisp the Language, 2nd edition", Chapter 22 (available online at: -;; http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000) - -(in-ns 'clojure.pprint) - -;;; Forward references -(declare compile-format) -(declare execute-format) -(declare init-navigator) -;;; End forward references - -(defn cl-format - "An implementation of a Common Lisp compatible format function. cl-format formats its -arguments to an output stream or string based on the format control string given. It -supports sophisticated formatting of structured data. - -Writer is an instance of java.io.Writer, true to output to *out* or nil to output -to a string, format-in is the format control string and the remaining arguments -are the data to be formatted. - -The format control string is a string to be output with embedded 'format directives' -describing how to format the various arguments passed in. - -If writer is nil, cl-format returns the formatted result string. Otherwise, cl-format -returns nil. - -For example: - (let [results [46 38 22]] - (cl-format true \"There ~[are~;is~:;are~]~:* ~d result~:p: ~{~d~^, ~}~%\" - (count results) results)) - -Prints to *out*: - There are 3 results: 46, 38, 22 - -Detailed documentation on format control strings is available in the \"Common Lisp the -Language, 2nd edition\", Chapter 22 (available online at: -http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000) -and in the Common Lisp HyperSpec at -http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm -" - {:added "1.2", - :see-also [["http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000" - "Common Lisp the Language"] - ["http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm" - "Common Lisp HyperSpec"]]} - [writer format-in & args] - (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) - navigator (init-navigator args)] - (execute-format writer compiled-format navigator))) - -(def ^:dynamic ^{:private true} *format-str* nil) - -(defn- format-error [message offset] - (let [full-message (str message \newline *format-str* \newline - (apply str (repeat offset \space)) "^" \newline)] - (throw (Exception. full-message)))) ;;; RuntimeException - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Argument navigators manage the argument list -;;; as the format statement moves through the list -;;; (possibly going forwards and backwards as it does so) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defstruct ^{:private true} - arg-navigator :seq :rest :pos ) - -(defn- init-navigator - "Create a new arg-navigator from the sequence with the position set to 0" - {:skip-wiki true} - [s] - (let [s (seq s)] - (struct arg-navigator s s 0))) - -;; TODO call format-error with offset -(defn- next-arg [ navigator ] - (let [ rst (:rest navigator) ] - (if rst - [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))] - (throw (new Exception "Not enough arguments for format definition"))))) - -(defn- next-arg-or-nil [navigator] - (let [rst (:rest navigator)] - (if rst - [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))] - [nil navigator]))) - -;; Get an argument off the arg list and compile it if it's not already compiled -(defn- get-format-arg [navigator] - (let [[raw-format navigator] (next-arg navigator) - compiled-format (if (instance? String raw-format) - (compile-format raw-format) - raw-format)] - [compiled-format navigator])) - -(declare relative-reposition) - -(defn- absolute-reposition [navigator position] - (if (>= position (:pos navigator)) - (relative-reposition navigator (- position (:pos navigator))) - (struct arg-navigator (:seq navigator) (drop position (:seq navigator)) position))) - -(defn- relative-reposition [navigator position] - (let [newpos (+ (:pos navigator) position)] - (if (neg? position) - (absolute-reposition navigator newpos) - (struct arg-navigator (:seq navigator) (drop position (:rest navigator)) newpos)))) - -(defstruct ^{:private true} - compiled-directive :func :def :params :offset) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; When looking at the parameter list, we may need to manipulate -;;; the argument list as well (for 'V' and '#' parameter types). -;;; We hide all of this behind a function, but clients need to -;;; manage changing arg navigator -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; TODO: validate parameters when they come from arg list -(defn- realize-parameter [[param [raw-val offset]] navigator] - (let [[real-param new-navigator] - (cond - (contains? #{ :at :colon } param) ;pass flags through unchanged - this really isn't necessary - [raw-val navigator] - - (= raw-val :parameter-from-args) - (next-arg navigator) - - (= raw-val :remaining-arg-count) - [(count (:rest navigator)) navigator] - - true - [raw-val navigator])] - [[param [real-param offset]] new-navigator])) - -(defn- realize-parameter-list [parameter-map navigator] - (let [[pairs new-navigator] - (map-passing-context realize-parameter navigator parameter-map)] - [(into {} pairs) new-navigator])) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Functions that support individual directives -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Common handling code for ~A and ~S -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(declare opt-base-str) - -(def ^{:private true} - special-radix-markers {2 "#b" 8 "#o", 16 "#x"}) - -(defn- format-simple-number [n] - (cond - (integer? n) (if (= *print-base* 10) - (str n (if *print-radix* ".")) - (str - (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r"))) - (opt-base-str *print-base* n))) - (ratio? n) (str - (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r"))) - (opt-base-str *print-base* (.numerator ^clojure.lang.Ratio n)) - "/" - (opt-base-str *print-base* (.denominator ^clojure.lang.Ratio n))) - :else nil)) - -(defn- format-ascii [print-func params arg-navigator offsets] - (let [ [arg arg-navigator] (next-arg arg-navigator) - ^String base-output (or (format-simple-number arg) (print-func arg)) - base-width (.Length base-output) ;;; length - min-width (+ base-width (:minpad params)) - width (if (>= min-width (:mincol params)) - min-width - (+ min-width - (* (+ (quot (- (:mincol params) min-width 1) - (:colinc params) ) - 1) - (:colinc params)))) - chars (apply str (repeat (- width base-width) (:padchar params)))] - (if (:at params) - (print (str chars base-output)) - (print (str base-output chars))) - arg-navigator)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for the integer directives ~D, ~X, ~O, ~B and some -;;; of ~R -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- integral? - "returns true if a number is actually an integer (that is, has no fractional part)" - [x] - (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 (float x))) ;;; Math/floor, added float call - (ratio? x) (let [^clojure.lang.Ratio r x] - (= 0 (rem (.numerator r) (.denominator r)))) - :else false)) - -(defn- remainders - "Return the list of remainders (essentially the 'digits') of val in the given base" - [base val] - (reverse - (first - (consume #(if (pos? %) - [(rem % base) (quot % base)] - [nil nil]) - val)))) - -;;; TODO: xlated-val does not seem to be used here. ---- ;;;; I had to use it to prevent the call to remainders from returning a Double instead of an integer in the last position -(defn- base-str - "Return val as a string in the given base" - [base val] - (if (zero? val) - "0" - (let [xlated-val (cond - (float? val) (bigdec val) - (ratio? val) (let [^clojure.lang.Ratio r val] - (/ (.numerator r) (.denominator r))) - :else val)] - (apply str - (map - #(if (< % 10) (char (+ (int \0) %)) (char (+ (int \a) (- % 10)))) - (remainders base xlated-val)))))) - -(def ^{:private true} - java-base-formats {8 "%o", 10 "%d", 16 "%x"}) - -(defn- opt-base-str - "Return val as a string in the given base, using clojure.core/format if supported -for improved performance" - [base val] - (let [format-str (get java-base-formats base)] - (if (and format-str (integer? val) (not (instance? clojure.lang.BigInt val))) - (clojure.core/format format-str val) - (base-str base val)))) - -(defn- group-by* [unit lis] - (reverse - (first - (consume (fn [x] [(seq (reverse (take unit x))) (seq (drop unit x))]) (reverse lis))))) - -(defn- format-integer [base params arg-navigator offsets] - (let [[arg arg-navigator] (next-arg arg-navigator)] - (if (integral? arg) - (let [neg (neg? arg) - pos-arg (if neg (- arg) arg) - raw-str (opt-base-str base pos-arg) - group-str (if (:colon params) - (let [groups (map #(apply str %) (group-by* (:commainterval params) raw-str)) - commas (repeat (count groups) (:commachar params))] - (apply str (next (interleave commas groups)))) - raw-str) - ^String signed-str (cond - neg (str "-" group-str) - (:at params) (str "+" group-str) - true group-str) - padded-str (if (< (.Length signed-str) (:mincol params)) ;;; length - (str (apply str (repeat (- (:mincol params) (.Length signed-str)) ;;; length - (:padchar params))) - signed-str) - signed-str)] - (print padded-str)) - (format-ascii print-str {:mincol (:mincol params) :colinc 1 :minpad 0 - :padchar (:padchar params) :at true} - (init-navigator [arg]) nil)) - arg-navigator)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for english formats (~R and ~:R) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(def ^{:private true} - english-cardinal-units - ["zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" - "ten" "eleven" "twelve" "thirteen" "fourteen" - "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"]) - -(def ^{:private true} - english-ordinal-units - ["zeroth" "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth" - "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth" - "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"]) - -(def ^{:private true} - english-cardinal-tens - ["" "" "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"]) - -(def ^{:private true} - english-ordinal-tens - ["" "" "twentieth" "thirtieth" "fortieth" "fiftieth" - "sixtieth" "seventieth" "eightieth" "ninetieth"]) - -;; We use "short scale" for our units (see http://en.wikipedia.org/wiki/Long_and_short_scales) -;; Number names from http://www.jimloy.com/math/billion.htm -;; We follow the rules for writing numbers from the Blue Book -;; (http://www.grammarbook.com/numbers/numbers.asp) -(def ^{:private true} - english-scale-numbers - ["" "thousand" "million" "billion" "trillion" "quadrillion" "quintillion" - "sextillion" "septillion" "octillion" "nonillion" "decillion" - "undecillion" "duodecillion" "tredecillion" "quattuordecillion" - "quindecillion" "sexdecillion" "septendecillion" - "octodecillion" "novemdecillion" "vigintillion"]) - -(defn- format-simple-cardinal - "Convert a number less than 1000 to a cardinal english string" - [num] - (let [hundreds (quot num 100) - tens (rem num 100)] - (str - (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred")) - (if (and (pos? hundreds) (pos? tens)) " ") - (if (pos? tens) - (if (< tens 20) - (nth english-cardinal-units tens) - (let [ten-digit (quot tens 10) - unit-digit (rem tens 10)] - (str - (if (pos? ten-digit) (nth english-cardinal-tens ten-digit)) - (if (and (pos? ten-digit) (pos? unit-digit)) "-") - (if (pos? unit-digit) (nth english-cardinal-units unit-digit))))))))) - -(defn- add-english-scales - "Take a sequence of parts, add scale numbers (e.g., million) and combine into a string -offset is a factor of 10^3 to multiply by" - [parts offset] - (let [cnt (count parts)] - (loop [acc [] - pos (dec cnt) - this (first parts) - remainder (next parts)] - (if (nil? remainder) - (str (apply str (interpose ", " acc)) - (if (and (not (empty? this)) (not (empty? acc))) ", ") - this - (if (and (not (empty? this)) (pos? (+ pos offset))) - (str " " (nth english-scale-numbers (+ pos offset))))) - (recur - (if (empty? this) - acc - (conj acc (str this " " (nth english-scale-numbers (+ pos offset))))) - (dec pos) - (first remainder) - (next remainder)))))) - -(defn- format-cardinal-english [params navigator offsets] - (let [[arg navigator] (next-arg navigator)] - (if (= 0 arg) - (print "zero") - (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs - parts (remainders 1000 abs-arg)] - (if (<= (count parts) (count english-scale-numbers)) - (let [parts-strs (map format-simple-cardinal parts) - full-str (add-english-scales parts-strs 0)] - (print (str (if (neg? arg) "minus ") full-str))) - (format-integer ;; for numbers > 10^63, we fall back on ~D - 10 - { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} - (init-navigator [arg]) - { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})))) - navigator)) - -(defn- format-simple-ordinal - "Convert a number less than 1000 to a ordinal english string -Note this should only be used for the last one in the sequence" - [num] - (let [hundreds (quot num 100) - tens (rem num 100)] - (str - (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred")) - (if (and (pos? hundreds) (pos? tens)) " ") - (if (pos? tens) - (if (< tens 20) - (nth english-ordinal-units tens) - (let [ten-digit (quot tens 10) - unit-digit (rem tens 10)] - (if (and (pos? ten-digit) (not (pos? unit-digit))) - (nth english-ordinal-tens ten-digit) - (str - (if (pos? ten-digit) (nth english-cardinal-tens ten-digit)) - (if (and (pos? ten-digit) (pos? unit-digit)) "-") - (if (pos? unit-digit) (nth english-ordinal-units unit-digit)))))) - (if (pos? hundreds) "th"))))) - -(defn- format-ordinal-english [params navigator offsets] - (let [[arg navigator] (next-arg navigator)] - (if (= 0 arg) - (print "zeroth") - (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs - parts (remainders 1000 abs-arg)] - (if (<= (count parts) (count english-scale-numbers)) - (let [parts-strs (map format-simple-cardinal (drop-last parts)) - head-str (add-english-scales parts-strs 1) - tail-str (format-simple-ordinal (last parts))] - (print (str (if (neg? arg) "minus ") - (cond - (and (not (empty? head-str)) (not (empty? tail-str))) - (str head-str ", " tail-str) - - (not (empty? head-str)) (str head-str "th") - :else tail-str)))) - (do (format-integer ;; for numbers > 10^63, we fall back on ~D - 10 - { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} - (init-navigator [arg]) - { :mincol 0, :padchar 0, :commachar 0 :commainterval 0}) - (let [low-two-digits (rem arg 100) - not-teens (or (< 11 low-two-digits) (> 19 low-two-digits)) - low-digit (rem low-two-digits 10)] - (print (cond - (and (== low-digit 1) not-teens) "st" - (and (== low-digit 2) not-teens) "nd" - (and (== low-digit 3) not-teens) "rd" - :else "th"))))))) - navigator)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for roman numeral formats (~@R and ~@:R) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(def ^{:private true} - old-roman-table - [[ "I" "II" "III" "IIII" "V" "VI" "VII" "VIII" "VIIII"] - [ "X" "XX" "XXX" "XXXX" "L" "LX" "LXX" "LXXX" "LXXXX"] - [ "C" "CC" "CCC" "CCCC" "D" "DC" "DCC" "DCCC" "DCCCC"] - [ "M" "MM" "MMM"]]) - -(def ^{:private true} - new-roman-table - [[ "I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX"] - [ "X" "XX" "XXX" "XL" "L" "LX" "LXX" "LXXX" "XC"] - [ "C" "CC" "CCC" "CD" "D" "DC" "DCC" "DCCC" "CM"] - [ "M" "MM" "MMM"]]) - -(defn- format-roman - "Format a roman numeral using the specified look-up table" - [table params navigator offsets] - (let [[arg navigator] (next-arg navigator)] - (if (and (number? arg) (> arg 0) (< arg 4000)) - (let [digits (remainders 10 arg)] - (loop [acc [] - pos (dec (count digits)) - digits digits] - (if (empty? digits) - (print (apply str acc)) - (let [digit (first digits)] - (recur (if (= 0 digit) - acc - (conj acc (nth (nth table pos) (dec digit)))) - (dec pos) - (next digits)))))) - (format-integer ;; for anything <= 0 or > 3999, we fall back on ~D - 10 - { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} - (init-navigator [arg]) - { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})) - navigator)) - -(defn- format-old-roman [params navigator offsets] - (format-roman old-roman-table params navigator offsets)) - -(defn- format-new-roman [params navigator offsets] - (format-roman new-roman-table params navigator offsets)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for character formats (~C) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(def ^{:private true} - special-chars { 8 "Backspace", 9 "Tab", 10 "Newline", 13 "Return", 32 "Space"}) - -(defn- pretty-character [params navigator offsets] - (let [[c navigator] (next-arg navigator) - as-int (int c) - base-char (bit-and as-int 127) - meta (bit-and as-int 128) - special (get special-chars base-char)] - (if (> meta 0) (print "Meta-")) - (print (cond - special special - (< base-char 32) (str "Control-" (char (+ base-char 64))) - (= base-char 127) "Control-?" - :else (char base-char))) - navigator)) - -(defn- readable-character [params navigator offsets] - (let [[c navigator] (next-arg navigator)] - (condp = (:char-format params) - \o (cl-format true "\\o~3,'0o" (int c)) - \u (cl-format true "\\u~4,'0x" (int c)) - nil (pr c)) - navigator)) - -(defn- plain-character [params navigator offsets] - (let [[char navigator] (next-arg navigator)] - (print char) - navigator)) - -;; Check to see if a result is an abort (~^) construct -;; TODO: move these funcs somewhere more appropriate -(defn- abort? [context] - (let [token (first context)] - (or (= :up-arrow token) (= :colon-up-arrow token)))) - -;; Handle the execution of "sub-clauses" in bracket constructions -(defn- execute-sub-format [format args base-args] - (second - (map-passing-context - (fn [element context] - (if (abort? context) - [nil context] ; just keep passing it along - (let [[params args] (realize-parameter-list (:params element) context) - [params offsets] (unzip-map params) - params (assoc params :base-args base-args)] - [nil (apply (:func element) [params args offsets])]))) - args - format))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for real number formats -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; TODO - return exponent as int to eliminate double conversion -(defn- float-parts-base - "Produce string parts for the mantissa (normalized 1-9) and exponent" - [^Object f] - (let [^String s (.ToLower (.ToString f)) ;;; .toLowerCase .toString - exploc (.IndexOf s \e) ;;; .indexOf (int \e) - dotloc (.IndexOf s \.)] ;;; .indexOf (int \.) - (if (neg? exploc) - (if (neg? dotloc) - [s (str (dec (count s)))] - [(str (subs s 0 dotloc) (subs s (inc dotloc))) (str (dec dotloc))]) - (if (neg? dotloc) - [(subs s 0 exploc) (subs s (inc exploc))] - [(str (subs s 0 1) (subs s 2 exploc)) (subs s (inc exploc))])))) - - -(defn- float-parts - "Take care of leading and trailing zeros in decomposed floats" - [f] - (let [[m ^String e] (float-parts-base f) - m1 (rtrim m \0) - m2 (ltrim m1 \0) - delta (- (count m1) (count m2)) - ^String e (if (and (pos? (count e)) (= (nth e 0) \+)) (subs e 1) e)] - (if (empty? m2) - ["0" 0] - [m2 (- (Int32/Parse e) delta)]))) ;;; (Integer/valueOf e) - -(defn- ^String inc-s - "Assumption: The input string consists of one or more decimal digits, -and no other characters. Return a string containing one or more -decimal digits containing a decimal number one larger than the input -string. The output string will always be the same length as the input -string, or one character longer." - [^String s] - (let [len-1 (dec (count s))] - (loop [i (int len-1)] - (cond - (neg? i) (apply str "1" (repeat (inc len-1) "0")) - (= \9 (.get_Chars s i)) (recur (dec i)) ;;; .charAt - :else (apply str (subs s 0 i) - (char (inc (int (.get_Chars s i)))) ;;; .charAt - (repeat (- len-1 i) "0")))))) - -(defn- round-str [m e d w] - (if (or d w) - (let [len (count m) - ;; Every formatted floating point number should include at - ;; least one decimal digit and a decimal point. - w (if w (max 2 w)) - round-pos (cond - ;; If d was given, that forces the rounding - ;; position, regardless of any width that may - ;; have been specified. - d (+ e d 1) - ;; Otherwise w was specified, so pick round-pos - ;; based upon that. - ;; If e>=0, then abs value of number is >= 1.0, - ;; and e+1 is number of decimal digits before the - ;; decimal point when the number is written - ;; without scientific notation. Never round the - ;; number before the decimal point. - (>= e 0) (max (inc e) (dec w)) - ;; e < 0, so number abs value < 1.0 - :else (+ w e)) - [m1 e1 round-pos len] (if (= round-pos 0) - [(str "0" m) (inc e) 1 (inc len)] - [m e round-pos len])] - (if round-pos - (if (neg? round-pos) - ["0" 0 false] - (if (> len round-pos) - (let [round-char (nth m1 round-pos) - ^String result (subs m1 0 round-pos)] - (if (>= (int round-char) (int \5)) - (let [round-up-result (inc-s result) - expanded (> (count round-up-result) (count result))] - [(if expanded - (subs round-up-result 0 (dec (count round-up-result))) - round-up-result) - e1 expanded]) - [result e1 false])) - [m e false])) - [m e false])) - [m e false])) - -(defn- expand-fixed [m e d] - (let [[m1 e1] (if (neg? e) - [(str (apply str (repeat (dec (- e)) \0)) m) -1] - [m e]) - len (count m1) - target-len (if d (+ e1 d 1) (inc e1))] - (if (< len target-len) - (str m1 (apply str (repeat (- target-len len) \0))) - m1))) - -(defn- insert-decimal - "Insert the decimal point at the right spot in the number to match an exponent" - [m e] - (if (neg? e) - (str "." m) - (let [loc (inc e)] - (str (subs m 0 loc) "." (subs m loc))))) - -(defn- get-fixed [m e d] - (insert-decimal (expand-fixed m e d) e)) - -(defn- insert-scaled-decimal - "Insert the decimal point at the right spot in the number to match an exponent" - [m k] - (if (neg? k) - (str "." m) - (str (subs m 0 k) "." (subs m k)))) - -(defn- convert-ratio [x] - (if (ratio? x) - ;; Usually convert to a double, only resorting to the slower - ;; bigdec conversion if the result does not fit within the range - ;; of a double. - (let [d (double x)] - (if (== d 0.0) - (if (not= x 0) - (bigdec x) - d) - (if (or (== d Double/PositiveInfinity) (== d Double/NegativeInfinity)) ;;; Double/POSITIVE_INFINITY Double/NEGATIVE_INFINITY - (bigdec x) - d))) - x)) - -;; the function to render ~F directives -;; TODO: support rationals. Back off to ~D/~A is the appropriate cases -(defn- fixed-float [params navigator offsets] - (let [w (:w params) - d (:d params) - [arg navigator] (next-arg navigator) - [sign abs] (if (neg? arg) ["-" (- arg)] ["+" arg]) - abs (convert-ratio abs) - [mantissa exp] (float-parts abs) - scaled-exp (+ exp (:k params)) - add-sign (or (:at params) (neg? arg)) - append-zero (and (not d) (<= (dec (count mantissa)) scaled-exp)) - [rounded-mantissa scaled-exp expanded] (round-str mantissa scaled-exp - d (if w (- w (if add-sign 1 0)))) - ^String 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 - (> (count fixed-repr) (- w (if add-sign 1 0)))) - (subs fixed-repr 1) ; chop off leading 0 - fixed-repr) - prepend-zero (= (first fixed-repr) \.)] - (if w - (let [len (count fixed-repr) - signed-len (if add-sign (inc len) len) - prepend-zero (and prepend-zero (not (>= signed-len w))) - append-zero (and append-zero (not (>= signed-len w))) - full-len (if (or prepend-zero append-zero) - (inc signed-len) - signed-len)] - (if (and (> full-len w) (:overflowchar params)) - (print (apply str (repeat w (:overflowchar params)))) - (print (str - (apply str (repeat (- w full-len) (:padchar params))) - (if add-sign sign) - (if prepend-zero "0") - fixed-repr - (if append-zero "0"))))) - (print (str - (if add-sign sign) - (if prepend-zero "0") - fixed-repr - (if append-zero "0")))) - navigator)) - - -;; the function to render ~E directives -;; TODO: support rationals. Back off to ~D/~A is the appropriate cases -;; TODO: define ~E representation for Infinity -(defn- exponential-float [params navigator offsets] - (let [[arg navigator] (next-arg navigator) - arg (convert-ratio arg)] - (loop [[mantissa exp] (float-parts (if (neg? arg) (- arg) arg))] - (let [w (:w params) - d (:d params) - e (:e params) - k (:k params) - expchar (or (:exponentchar params) \E) - add-sign (or (:at params) (neg? arg)) - prepend-zero (<= k 0) - ^Int32 scaled-exp (- exp (dec k)) ;;; Integer - scaled-exp-str (str (Math/Abs scaled-exp)) ;;; Math/abs - scaled-exp-str (str expchar (if (neg? scaled-exp) \- \+) - (if e (apply str - (repeat - (- e - (count scaled-exp-str)) - \0))) - scaled-exp-str) - exp-width (count scaled-exp-str) - base-mantissa-width (count mantissa) - scaled-mantissa (str (apply str (repeat (- k) \0)) - mantissa - (if d - (apply str - (repeat - (- d (dec base-mantissa-width) - (if (neg? k) (- k) 0)) \0)))) - w-mantissa (if w (- w exp-width)) - [rounded-mantissa _ incr-exp] (round-str - scaled-mantissa 0 - (cond - (= k 0) (dec d) - (pos? k) d - (neg? k) (dec d)) - (if w-mantissa - (- w-mantissa (if add-sign 1 0)))) - full-mantissa (insert-scaled-decimal rounded-mantissa k) - append-zero (and (= k (count rounded-mantissa)) (nil? d))] - (if (not incr-exp) - (if w - (let [len (+ (count full-mantissa) exp-width) - signed-len (if add-sign (inc len) len) - prepend-zero (and prepend-zero (not (= signed-len w))) - full-len (if prepend-zero (inc signed-len) signed-len) - append-zero (and append-zero (< full-len w))] - (if (and (or (> full-len w) (and e (> (- exp-width 2) e))) - (:overflowchar params)) - (print (apply str (repeat w (:overflowchar params)))) - (print (str - (apply str - (repeat - (- w full-len (if append-zero 1 0) ) - (:padchar params))) - (if add-sign (if (neg? arg) \- \+)) - (if prepend-zero "0") - full-mantissa - (if append-zero "0") - scaled-exp-str)))) - (print (str - (if add-sign (if (neg? arg) \- \+)) - (if prepend-zero "0") - full-mantissa - (if append-zero "0") - scaled-exp-str))) - (recur [rounded-mantissa (inc exp)])))) - navigator)) - -;; the function to render ~G directives -;; This just figures out whether to pass the request off to ~F or ~E based -;; on the algorithm in CLtL. -;; TODO: support rationals. Back off to ~D/~A is the appropriate cases -;; TODO: refactor so that float-parts isn't called twice -(defn- general-float [params navigator offsets] - (let [[arg _] (next-arg navigator) - arg (convert-ratio arg) - [mantissa exp] (float-parts (if (neg? arg) (- arg) arg)) - w (:w params) - d (:d params) - e (:e params) - n (if (= arg 0.0) 0 (inc exp)) - ee (if e (+ e 2) 4) - ww (if w (- w ee)) - d (if d d (max (count mantissa) (min n 7))) - dd (- d n)] - (if (<= 0 dd d) - (let [navigator (fixed-float {:w ww, :d dd, :k 0, - :overflowchar (:overflowchar params), - :padchar (:padchar params), :at (:at params)} - navigator offsets)] - (print (apply str (repeat ee \space))) - navigator) - (exponential-float params navigator offsets)))) - -;; the function to render ~$ directives -;; TODO: support rationals. Back off to ~D/~A is the appropriate cases -(defn- dollar-float [params navigator offsets] - (let [[^Double arg navigator] (next-arg navigator) - [mantissa exp] (float-parts (Math/Abs arg)) ;;; Math/abs - d (:d params) ; digits after the decimal - n (:n params) ; minimum digits before the decimal - w (:w params) ; minimum field width - add-sign (or (:at params) (neg? arg)) - [rounded-mantissa scaled-exp expanded] (round-str mantissa exp d nil) - ^String fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d) - full-repr (str (apply str (repeat (- n (.IndexOf fixed-repr \.)) \0)) fixed-repr) ;;; .indexOf (int \.) - full-len (+ (count full-repr) (if add-sign 1 0))] - (print (str - (if (and (:colon params) add-sign) (if (neg? arg) \- \+)) - (apply str (repeat (- w full-len) (:padchar params))) - (if (and (not (:colon params)) add-sign) (if (neg? arg) \- \+)) - full-repr)) - navigator)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for the '~[...~]' conditional construct in its -;;; different flavors -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; ~[...~] without any modifiers chooses one of the clauses based on the param or -;; next argument -;; TODO check arg is positive int -(defn- choice-conditional [params arg-navigator offsets] - (let [arg (:selector params) - [arg navigator] (if arg [arg arg-navigator] (next-arg arg-navigator)) - clauses (:clauses params) - clause (if (or (neg? arg) (>= arg (count clauses))) - (first (:else params)) - (nth clauses arg))] - (if clause - (execute-sub-format clause navigator (:base-args params)) - navigator))) - -;; ~:[...~] with the colon reads the next argument treating it as a truth value -(defn- boolean-conditional [params arg-navigator offsets] - (let [[arg navigator] (next-arg arg-navigator) - clauses (:clauses params) - clause (if arg - (second clauses) - (first clauses))] - (if clause - (execute-sub-format clause navigator (:base-args params)) - navigator))) - -;; ~@[...~] with the at sign executes the conditional if the next arg is not -;; nil/false without consuming the arg -(defn- check-arg-conditional [params arg-navigator offsets] - (let [[arg navigator] (next-arg arg-navigator) - clauses (:clauses params) - clause (if arg (first clauses))] - (if arg - (if clause - (execute-sub-format clause arg-navigator (:base-args params)) - arg-navigator) - navigator))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for the '~{...~}' iteration construct in its -;;; different flavors -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -;; ~{...~} without any modifiers uses the next argument as an argument list that -;; is consumed by all the iterations -(defn- iterate-sublist [params navigator offsets] - (let [max-count (:max-iterations params) - param-clause (first (:clauses params)) - [clause navigator] (if (empty? param-clause) - (get-format-arg navigator) - [param-clause navigator]) - [arg-list navigator] (next-arg navigator) - args (init-navigator arg-list)] - (loop [count 0 - args args - last-pos (num -1)] - (if (and (not max-count) (= (:pos args) last-pos) (> count 1)) - ;; TODO get the offset in here and call format exception - (throw (Exception. "%{ construct not consuming any arguments: Infinite loop!"))) ;;; RuntimeException - (if (or (and (empty? (:rest args)) - (or (not (:colon (:right-params params))) (> count 0))) - (and max-count (>= count max-count))) - navigator - (let [iter-result (execute-sub-format clause args (:base-args params))] - (if (= :up-arrow (first iter-result)) - navigator - (recur (inc count) iter-result (:pos args)))))))) - -;; ~:{...~} with the colon treats the next argument as a list of sublists. Each of the -;; sublists is used as the arglist for a single iteration. -(defn- iterate-list-of-sublists [params navigator offsets] - (let [max-count (:max-iterations params) - param-clause (first (:clauses params)) - [clause navigator] (if (empty? param-clause) - (get-format-arg navigator) - [param-clause navigator]) - [arg-list navigator] (next-arg navigator)] - (loop [count 0 - arg-list arg-list] - (if (or (and (empty? arg-list) - (or (not (:colon (:right-params params))) (> count 0))) - (and max-count (>= count max-count))) - navigator - (let [iter-result (execute-sub-format - clause - (init-navigator (first arg-list)) - (init-navigator (next arg-list)))] - (if (= :colon-up-arrow (first iter-result)) - navigator - (recur (inc count) (next arg-list)))))))) - -;; ~@{...~} with the at sign uses the main argument list as the arguments to the iterations -;; is consumed by all the iterations -(defn- iterate-main-list [params navigator offsets] - (let [max-count (:max-iterations params) - param-clause (first (:clauses params)) - [clause navigator] (if (empty? param-clause) - (get-format-arg navigator) - [param-clause navigator])] - (loop [count 0 - navigator navigator - last-pos (num -1)] - (if (and (not max-count) (= (:pos navigator) last-pos) (> count 1)) - ;; TODO get the offset in here and call format exception - (throw (Exception. "%@{ construct not consuming any arguments: Infinite loop!"))) ;;; RuntimeException - (if (or (and (empty? (:rest navigator)) - (or (not (:colon (:right-params params))) (> count 0))) - (and max-count (>= count max-count))) - navigator - (let [iter-result (execute-sub-format clause navigator (:base-args params))] - (if (= :up-arrow (first iter-result)) - (second iter-result) - (recur - (inc count) iter-result (:pos navigator)))))))) - -;; ~@:{...~} with both colon and at sign uses the main argument list as a set of sublists, one -;; of which is consumed with each iteration -(defn- iterate-main-sublists [params navigator offsets] - (let [max-count (:max-iterations params) - param-clause (first (:clauses params)) - [clause navigator] (if (empty? param-clause) - (get-format-arg navigator) - [param-clause navigator]) - ] - (loop [count 0 - navigator navigator] - (if (or (and (empty? (:rest navigator)) - (or (not (:colon (:right-params params))) (> count 0))) - (and max-count (>= count max-count))) - navigator - (let [[sublist navigator] (next-arg-or-nil navigator) - iter-result (execute-sub-format clause (init-navigator sublist) navigator)] - (if (= :colon-up-arrow (first iter-result)) - navigator - (recur (inc count) navigator))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The '~< directive has two completely different meanings -;;; in the '~<...~>' form it does justification, but with -;;; ~<...~:>' it represents the logical block operation of the -;;; pretty printer. -;;; -;;; Unfortunately, the current architecture decides what function -;;; to call at form parsing time before the sub-clauses have been -;;; folded, so it is left to run-time to make the decision. -;;; -;;; TODO: make it possible to make these decisions at compile-time. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(declare format-logical-block) -(declare justify-clauses) - -(defn- logical-block-or-justify [params navigator offsets] - (if (:colon (:right-params params)) - (format-logical-block params navigator offsets) - (justify-clauses params navigator offsets))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for the '~<...~>' justification directive -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- render-clauses [clauses navigator base-navigator] - (loop [clauses clauses - acc [] - navigator navigator] - (if (empty? clauses) - [acc navigator] - (let [clause (first clauses) - [iter-result result-str] (binding [*out* (System.IO.StringWriter.)] ;;; java.io.StringWriter. - [(execute-sub-format clause navigator base-navigator) - (.ToString *out*)])] ;;; toString - (if (= :up-arrow (first iter-result)) - [acc (second iter-result)] - (recur (next clauses) (conj acc result-str) iter-result)))))) - -;; TODO support for ~:; constructions -(defn- justify-clauses [params navigator offsets] - (let [[[eol-str] new-navigator] (when-let [else (:else params)] - (render-clauses else navigator (:base-args params))) - navigator (or new-navigator navigator) - [else-params new-navigator] (when-let [p (:else-params params)] - (realize-parameter-list p navigator)) - navigator (or new-navigator navigator) - min-remaining (or (first (:min-remaining else-params)) 0) - max-columns (or (first (:max-columns else-params)) - (get-max-column *out*)) - clauses (:clauses params) - [strs navigator] (render-clauses clauses navigator (:base-args params)) - slots (max 1 - (+ (dec (count strs)) (if (:colon params) 1 0) (if (:at params) 1 0))) - chars (reduce + (map count strs)) - mincol (:mincol params) - minpad (:minpad params) - colinc (:colinc params) - minout (+ chars (* slots minpad)) - result-columns (if (<= minout mincol) - mincol - (+ mincol (* colinc - (+ 1 (quot (- minout mincol 1) colinc))))) - total-pad (- result-columns chars) - pad (max minpad (quot total-pad slots)) - extra-pad (- total-pad (* pad slots)) - pad-str (apply str (repeat pad (:padchar params)))] - (if (and eol-str (> (+ (get-column (:base @@*out*)) min-remaining result-columns) - max-columns)) - (print eol-str)) - (loop [slots slots - extra-pad extra-pad - strs strs - pad-only (or (:colon params) - (and (= (count strs) 1) (not (:at params))))] - (if (seq strs) - (do - (print (str (if (not pad-only) (first strs)) - (if (or pad-only (next strs) (:at params)) pad-str) - (if (pos? extra-pad) (:padchar params)))) - (recur - (dec slots) - (dec extra-pad) - (if pad-only strs (next strs)) - false)))) - navigator)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for case modification with ~(...~). -;;; We do this by wrapping the underlying writer with -;;; a special writer to do the appropriate modification. This -;;; allows us to support arbitrary-sized output and sources -;;; that may block. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- downcase-writer - "Returns a proxy that wraps writer, converting all characters to lower case" - [^System.IO.TextWriter writer] ;;; java.io.Writer - (proxy [System.IO.TextWriter] [] ;;; java.io.Writer - (Close [] (.Close writer)) ;;; close - (Flush [] (.Flush writer)) ;;; flush - (Write ([^chars cbuf off len] ;;; write ^Integer hint removed from off,len - (.Write writer cbuf ^Int32 off ^Int32 len)) ;;; write, hints added - ([x] - (condp = (class x) - String - (let [s ^String x] - (.Write writer (.ToLower s))) ;;; write toLowerCase - - Int32 ;;; Integer - (let [c x] ;;; Character hint removoed - (.Write writer (int (Char/ToLower (char c)))))))))) ;;; .write Character/toLowerCase - -(defn- upcase-writer - "Returns a proxy that wraps writer, converting all characters to upper case" - [^System.IO.TextWriter writer] ;;; java.io.Writer - (proxy [System.IO.TextWriter] [] ;;; java.io.Writer - (Close [] (.Close writer)) - (Flush [] (.Flush writer)) - (Write ([^chars cbuf off len] ;;; ^Integer hint removed from off, len - (.Write writer cbuf ^Int32 off ^Int32 len)) ;; Int32 hints added - ([x] - (condp = (class x) - String - (let [s ^String x] - (.Write writer (.ToUpper s))) - - Int32 - (let [c x] ;;; Character hint removed from c - (.Write writer (int (Char/ToUpper (char c)))))))))) - -(defn- capitalize-string - "Capitalizes the words in a string. If first? is false, don't capitalize the - first character of the string even if it's a letter." - [s first?] - (let [^Char f (first s) ;;; Character - s (if (and first? f (Char/IsLetter f)) ;;; Character/isLetter - (str (Char/ToUpper f) (subs s 1)) ;;; Character/toUpperCase - s)] - (apply str - (first - (consume - (fn [s] - (if (empty? s) - [nil nil] - (let [m (re-matcher #"\W\w" s) - match (re-find m) - offset (and match (inc (.start m)))] ;;; .start - (if offset - [(str (subs s 0 offset) - (Char/ToUpper ^Char (char (nth s offset)))) ;;; Character/toUpperCase Character (char ... ) wrapper added - (subs s (inc offset))] - [s nil])))) - s))))) - -(defn- capitalize-word-writer - "Returns a proxy that wraps writer, capitalizing all words" - [^System.IO.TextWriter writer] ;;; java.io.Writer - (let [last-was-whitespace? (ref true)] - (proxy [System.IO.TextWriter] [] - (Close [] (.Close writer)) - (Flush [] (.Flush writer)) - (Write - ([^chars cbuf off len] (let [off (int off) len (int len)] ;;; remove ^Integer hints on off, len - (.Write writer cbuf off len)) ) - ([x] - (condp = (class x) - String - (let [s ^String x] - (.Write writer - ^String (capitalize-string (.ToLower s) @last-was-whitespace?)) ;;; toLowerCase - (when (pos? (.Length s)) ;;; .length - (dosync - (ref-set last-was-whitespace? - (Char/IsWhiteSpace ;;; Character/isWhitespace - ^Char (nth s (dec (count s)))))))) ;;; ^Character - - Int32 - (let [c (char x)] - (let [mod-c (if @last-was-whitespace? (Char/ToUpper (char x)) c)] - (.Write writer (int mod-c)) - (dosync (ref-set last-was-whitespace? (Char/IsWhiteSpace (char x)))))))))))) - -(defn- init-cap-writer - "Returns a proxy that wraps writer, capitalizing the first word" - [^System.IO.TextWriter writer] ;;; java.io.Writer - (let [capped (ref false)] - (proxy [System.IO.TextWriter] [] - (Close [] (.Close writer)) - (Flush [] (.Flush writer)) - (Write ([^chars cbuf off len] (let [off (int off) len (int len)] ;;; remove ^Integer hints on off, len - (.Write writer cbuf off len)) ) - ([x] - (condp = (class x) - String - (let [s (.ToLower ^String x)] - (if (not @capped) - (let [m (re-matcher #"\S" s) - match (re-find m) - offset (and match (.start m))] ;;; start - (if offset - (do (.Write writer - (str (subs s 0 offset) - (Char/ToUpper ^Char (char (nth s offset))) ;; added (char ... ) - (.ToLower ^String (subs s (inc offset))))) - (dosync (ref-set capped true))) - (.Write writer s))) - (.Write writer (.ToLower s)))) - - Int32 - (let [c ^Char (char x)] - (if (and (not @capped) (Char/IsLetter c)) - (do - (dosync (ref-set capped true)) - (.Write writer (int (Char/ToUpper c)))) - (.Write writer (int (Char/ToLower c))))))))))) - -(defn- modify-case [make-writer params navigator offsets] - (let [clause (first (:clauses params))] - (binding [*out* (make-writer *out*)] - (execute-sub-format clause navigator (:base-args params))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; If necessary, wrap the writer in a PrettyWriter object -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn get-pretty-writer - "Returns the java.io.Writer passed in wrapped in a pretty writer proxy, unless it's -already a pretty writer. Generally, it is unnecessary to call this function, since pprint, -write, and cl-format all call it if they need to. However if you want the state to be -preserved across calls, you will want to wrap them with this. - -For example, when you want to generate column-aware output with multiple calls to cl-format, -do it like in this example: - - (defn print-table [aseq column-width] - (binding [*out* (get-pretty-writer *out*)] - (doseq [row aseq] - (doseq [col row] - (cl-format true \"~4D~7,vT\" col column-width)) - (prn)))) - -Now when you run: - - user> (print-table (map #(vector % (* % %) (* % % %)) (range 1 11)) 8) - -It prints a table of squares and cubes for the numbers from 1 to 10: - - 1 1 1 - 2 4 8 - 3 9 27 - 4 16 64 - 5 25 125 - 6 36 216 - 7 49 343 - 8 64 512 - 9 81 729 - 10 100 1000" - {:added "1.2"} - [writer] - (if (pretty-writer? writer) - writer - (pretty-writer writer *print-right-margin* *print-miser-width*))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for column-aware operations ~&, ~T -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn fresh-line - "Make a newline if *out* is not already at the beginning of the line. If *out* is -not a pretty writer (which keeps track of columns), this function always outputs a newline." - {:added "1.2"} - [] - (if (instance? clojure.lang.IDeref *out*) - (if (not (= 0 (get-column (:base @@*out*)))) - (prn)) - (prn))) - -(defn- absolute-tabulation [params navigator offsets] - (let [colnum (:colnum params) - colinc (:colinc params) - current (get-column (:base @@*out*)) - space-count (cond - (< current colnum) (- colnum current) - (= colinc 0) 0 - :else (- colinc (rem (- current colnum) colinc)))] - (print (apply str (repeat space-count \space)))) - navigator) - -(defn- relative-tabulation [params navigator offsets] - (let [colrel (:colnum params) - colinc (:colinc params) - start-col (+ colrel (get-column (:base @@*out*))) - offset (if (pos? colinc) (rem start-col colinc) 0) - space-count (+ colrel (if (= 0 offset) 0 (- colinc offset)))] - (print (apply str (repeat space-count \space)))) - navigator) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Support for accessing the pretty printer from a format -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; TODO: support ~@; per-line-prefix separator -;; TODO: get the whole format wrapped so we can start the lb at any column -(defn- format-logical-block [params navigator offsets] - (let [clauses (:clauses params) - clause-count (count clauses) - prefix (cond - (> clause-count 1) (:string (:params (first (first clauses)))) - (:colon params) "(") - body (nth clauses (if (> clause-count 1) 1 0)) - suffix (cond - (> clause-count 2) (:string (:params (first (nth clauses 2)))) - (:colon params) ")") - [arg navigator] (next-arg navigator)] - (pprint-logical-block :prefix prefix :suffix suffix - (execute-sub-format - body - (init-navigator arg) - (:base-args params))) - navigator)) - -(defn- set-indent [params navigator offsets] - (let [relative-to (if (:colon params) :current :block)] - (pprint-indent relative-to (:n params)) - navigator)) - -;;; TODO: support ~:T section options for ~T - -(defn- conditional-newline [params navigator offsets] - (let [kind (if (:colon params) - (if (:at params) :mandatory :fill) - (if (:at params) :miser :linear))] - (pprint-newline kind) - navigator)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The table of directives we support, each with its params, -;;; properties, and the compilation function -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; We start with a couple of helpers -(defn- process-directive-table-element [ [ char params flags bracket-info & generator-fn ] ] - [char, - {:directive char, - :params `(array-map ~@params), - :flags flags, - :bracket-info bracket-info, - :generator-fn (concat '(fn [ params offset]) generator-fn) }]) - -(defmacro ^{:private true} - defdirectives - [ & directives ] - `(def ^{:private true} - directive-table (hash-map ~@(mapcat process-directive-table-element directives)))) - -(defdirectives - (\A - [ :mincol [0 Int32] :colinc [1 Int32] :minpad [0 Int32] :padchar [\space Char] ] - #{ :at :colon :both} {} - #(format-ascii print-str %1 %2 %3)) - - (\S - [ :mincol [0 Int32] :colinc [1 Int32] :minpad [0 Int32] :padchar [\space Char] ] - #{ :at :colon :both} {} - #(format-ascii pr-str %1 %2 %3)) - - (\D - [ :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char] - :commainterval [ 3 Int32]] - #{ :at :colon :both } {} - #(format-integer 10 %1 %2 %3)) - - (\B - [ :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char] - :commainterval [ 3 Int32]] - #{ :at :colon :both } {} - #(format-integer 2 %1 %2 %3)) - - (\O - [ :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char] - :commainterval [ 3 Int32]] - #{ :at :colon :both } {} - #(format-integer 8 %1 %2 %3)) - - (\X - [ :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char] - :commainterval [ 3 Int32]] - #{ :at :colon :both } {} - #(format-integer 16 %1 %2 %3)) - - (\R - [:base [nil Int32] :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char] - :commainterval [ 3 Int32]] - #{ :at :colon :both } {} - (do - (cond ; ~R is overloaded with bizareness - (first (:base params)) #(format-integer (:base %1) %1 %2 %3) - (and (:at params) (:colon params)) #(format-old-roman %1 %2 %3) - (:at params) #(format-new-roman %1 %2 %3) - (:colon params) #(format-ordinal-english %1 %2 %3) - true #(format-cardinal-english %1 %2 %3)))) - - (\P - [ ] - #{ :at :colon :both } {} - (fn [params navigator offsets] - (let [navigator (if (:colon params) (relative-reposition navigator -1) navigator) - strs (if (:at params) ["y" "ies"] ["" "s"]) - [arg navigator] (next-arg navigator)] - (print (if (= arg 1) (first strs) (second strs))) - navigator))) - - (\C - [:char-format [nil Char]] - #{ :at :colon :both } {} - (cond - (:colon params) pretty-character - (:at params) readable-character - :else plain-character)) - - (\F - [ :w [nil Int32] :d [nil Int32] :k [0 Int32] :overflowchar [nil Char] - :padchar [\space Char] ] - #{ :at } {} - fixed-float) - - (\E - [ :w [nil Int32] :d [nil Int32] :e [nil Int32] :k [1 Int32] - :overflowchar [nil Char] :padchar [\space Char] - :exponentchar [nil Char] ] - #{ :at } {} - exponential-float) - - (\G - [ :w [nil Int32] :d [nil Int32] :e [nil Int32] :k [1 Int32] - :overflowchar [nil Char] :padchar [\space Char] - :exponentchar [nil Char] ] - #{ :at } {} - general-float) - - (\$ - [ :d [2 Int32] :n [1 Int32] :w [0 Int32] :padchar [\space Char]] - #{ :at :colon :both} {} - dollar-float) - - (\% - [ :count [1 Int32] ] - #{ } {} - (fn [params arg-navigator offsets] - (dotimes [i (:count params)] - (prn)) - arg-navigator)) - - (\& - [ :count [1 Int32] ] - #{ :pretty } {} - (fn [params arg-navigator offsets] - (let [cnt (:count params)] - (if (pos? cnt) (fresh-line)) - (dotimes [i (dec cnt)] - (prn))) - arg-navigator)) - - (\| - [ :count [1 Int32] ] - #{ } {} - (fn [params arg-navigator offsets] - (dotimes [i (:count params)] - (print \formfeed)) - arg-navigator)) - - (\~ - [ :n [1 Int32] ] - #{ } {} - (fn [params arg-navigator offsets] - (let [n (:n params)] - (print (apply str (repeat n \~))) - arg-navigator))) - - (\newline ;; Whitespace supression is handled in the compilation loop - [ ] - #{:colon :at} {} - (fn [params arg-navigator offsets] - (if (:at params) - (prn)) - arg-navigator)) - - (\T - [ :colnum [1 Int32] :colinc [1 Int32] ] - #{ :at :pretty } {} - (if (:at params) - #(relative-tabulation %1 %2 %3) - #(absolute-tabulation %1 %2 %3))) - - (\* - [ :n [nil Int32] ] - #{ :colon :at } {} - (if (:at params) - (fn [params navigator offsets] - (let [n (or (:n params) 0)] ; ~@* has a default n = 0 - (absolute-reposition navigator n))) - (fn [params navigator offsets] - (let [n (or (:n params) 1)] ; whereas ~* and ~:* have a default n = 1 - (relative-reposition navigator (if (:colon params) (- n) n)))))) - - (\? - [ ] - #{ :at } {} - (if (:at params) - (fn [params navigator offsets] ; args from main arg list - (let [[subformat navigator] (get-format-arg navigator)] - (execute-sub-format subformat navigator (:base-args params)))) - (fn [params navigator offsets] ; args from sub-list - (let [[subformat navigator] (get-format-arg navigator) - [subargs navigator] (next-arg navigator) - sub-navigator (init-navigator subargs)] - (execute-sub-format subformat sub-navigator (:base-args params)) - navigator)))) - - - (\( - [ ] - #{ :colon :at :both} { :right \), :allows-separator nil, :else nil } - (let [mod-case-writer (cond - (and (:at params) (:colon params)) - upcase-writer - - (:colon params) - capitalize-word-writer - - (:at params) - init-cap-writer - - :else - downcase-writer)] - #(modify-case mod-case-writer %1 %2 %3))) - - (\) [] #{} {} nil) - - (\[ - [ :selector [nil Int32] ] - #{ :colon :at } { :right \], :allows-separator true, :else :last } - (cond - (:colon params) - boolean-conditional - - (:at params) - check-arg-conditional - - true - choice-conditional)) - - (\; [:min-remaining [nil Int32] :max-columns [nil Int32]] - #{ :colon } { :separator true } nil) - - (\] [] #{} {} nil) - - (\{ - [ :max-iterations [nil Int32] ] - #{ :colon :at :both} { :right \}, :allows-separator false } - (cond - (and (:at params) (:colon params)) - iterate-main-sublists - - (:colon params) - iterate-list-of-sublists - - (:at params) - iterate-main-list - - true - iterate-sublist)) - - - (\} [] #{:colon} {} nil) - - (\< - [:mincol [0 Int32] :colinc [1 Int32] :minpad [0 Int32] :padchar [\space Char]] - #{:colon :at :both :pretty} { :right \>, :allows-separator true, :else :first } - logical-block-or-justify) - - (\> [] #{:colon} {} nil) - - ;; TODO: detect errors in cases where colon not allowed - (\^ [:arg1 [nil Int32] :arg2 [nil Int32] :arg3 [nil Int32]] - #{:colon} {} - (fn [params navigator offsets] - (let [arg1 (:arg1 params) - arg2 (:arg2 params) - arg3 (:arg3 params) - exit (if (:colon params) :colon-up-arrow :up-arrow)] - (cond - (and arg1 arg2 arg3) - (if (<= arg1 arg2 arg3) [exit navigator] navigator) - - (and arg1 arg2) - (if (= arg1 arg2) [exit navigator] navigator) - - arg1 - (if (= arg1 0) [exit navigator] navigator) - - true ; TODO: handle looking up the arglist stack for info - (if (if (:colon params) - (empty? (:rest (:base-args params))) - (empty? (:rest navigator))) - [exit navigator] navigator))))) - - (\W - [] - #{:at :colon :both :pretty} {} - (if (or (:at params) (:colon params)) - (let [bindings (concat - (if (:at params) [:level nil :length nil] []) - (if (:colon params) [:pretty true] []))] - (fn [params navigator offsets] - (let [[arg navigator] (next-arg navigator)] - (if (apply write arg bindings) - [:up-arrow navigator] - navigator)))) - (fn [params navigator offsets] - (let [[arg navigator] (next-arg navigator)] - (if (write-out arg) - [:up-arrow navigator] - navigator))))) - - (\_ - [] - #{:at :colon :both} {} - conditional-newline) - - (\I - [:n [0 Int32]] - #{:colon} {} - set-indent) - ) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Code to manage the parameters and flags associated with each -;;; directive in the format string. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(def ^{:private true} - param-pattern #"^([vV]|#|('.)|([+-]?\d+)|(?=,))") -(def ^{:private true} - special-params #{ :parameter-from-args :remaining-arg-count }) - -(defn- extract-param [[s offset saw-comma]] - (let [m (re-matcher param-pattern s) - param (re-find m)] - (if param - (let [token-str (first (re-groups m)) - remainder (subs s (.end m)) ;;; end - new-offset (+ offset (.end m))] - (if (not (= \, (nth remainder 0))) - [ [token-str offset] [remainder new-offset false]] - [ [token-str offset] [(subs remainder 1) (inc new-offset) true]])) - (if saw-comma - (format-error "Badly formed parameters in format directive" offset) - [ nil [s offset]])))) - - -(defn- extract-params [s offset] - (consume extract-param [s offset false])) - -(defn- translate-param - "Translate the string representation of a param to the internalized - representation" - [[^String p offset]] - [(cond - (= (.Length p) 0) nil - (and (= (.Length p) 1) (contains? #{\v \V} (nth p 0))) :parameter-from-args ;;; length - (and (= (.Length p) 1) (= \# (nth p 0))) :remaining-arg-count - (and (= (.Length p) 2) (= \' (nth p 0))) (nth p 1) - true (Int32/Parse p)) ;;; (new Integer p) - offset]) - -(def ^{:private true} - flag-defs { \: :colon, \@ :at }) - -(defn- extract-flags [s offset] - (consume - (fn [[s offset flags]] - (if (empty? s) - [nil [s offset flags]] - (let [flag (get flag-defs (first s))] - (if flag - (if (contains? flags flag) - (format-error - (str "Flag \"" (first s) "\" appears more than once in a directive") - offset) - [true [(subs s 1) (inc offset) (assoc flags flag [true offset])]]) - [nil [s offset flags]])))) - [s offset {}])) - -(defn- check-flags [def flags] - (let [allowed (:flags def)] - (if (and (not (:at allowed)) (:at flags)) - (format-error (str "\"@\" is an illegal flag for format directive \"" (:directive def) "\"") - (nth (:at flags) 1))) - (if (and (not (:colon allowed)) (:colon flags)) - (format-error (str "\":\" is an illegal flag for format directive \"" (:directive def) "\"") - (nth (:colon flags) 1))) - (if (and (not (:both allowed)) (:at flags) (:colon flags)) - (format-error (str "Cannot combine \"@\" and \":\" flags for format directive \"" - (:directive def) "\"") - (min (nth (:colon flags) 1) (nth (:at flags) 1)))))) - -(defn- map-params - "Takes a directive definition and the list of actual parameters and -a map of flags and returns a map of the parameters and flags with defaults -filled in. We check to make sure that there are the right types and number -of parameters as well." - [def params flags offset] - (check-flags def flags) - (if (> (count params) (count (:params def))) - (format-error - (cl-format - nil - "Too many parameters for directive \"~C\": ~D~:* ~[were~;was~:;were~] specified but only ~D~:* ~[are~;is~:;are~] allowed" - (:directive def) (count params) (count (:params def))) - (second (first params)))) - (doall - (map #(let [val (first %1)] - (if (not (or (nil? val) (contains? special-params val) - (instance? (second (second %2)) val))) - (format-error (str "Parameter " (name (first %2)) - " has bad type in directive \"" (:directive def) "\": " - (class val)) - (second %1))) ) - params (:params def))) - - (merge ; create the result map - (into (array-map) ; start with the default values, make sure the order is right - (reverse (for [[name [default]] (:params def)] [name [default offset]]))) - (reduce #(apply assoc %1 %2) {} (filter #(first (nth % 1)) (zipmap (keys (:params def)) params))) ; add the specified parameters, filtering out nils - flags)) ; and finally add the flags - -(defn- compile-directive [s offset] - (let [[raw-params [rest offset]] (extract-params s offset) - [_ [rest offset flags]] (extract-flags rest offset) - directive (first rest) - def (get directive-table (Char/ToUpper ^Char directive)) ;;; Character/toUpperCase - params (if def (map-params def (map translate-param raw-params) flags offset))] - (if (not directive) - (format-error "Format string ended in the middle of a directive" offset)) - (if (not def) - (format-error (str "Directive \"" directive "\" is undefined") offset)) - [(struct compiled-directive ((:generator-fn def) params offset) def params offset) - (let [remainder (subs rest 1) - offset (inc offset) - trim? (and (= \newline (:directive def)) - (not (:colon params))) - trim-count (if trim? (prefix-count remainder [\space \tab]) 0) - remainder (subs remainder trim-count) - offset (+ offset trim-count)] - [remainder offset])])) - -(defn- compile-raw-string [s offset] - (struct compiled-directive (fn [_ a _] (print s) a) nil { :string s } offset)) - -(defn- right-bracket [this] (:right (:bracket-info (:def this)))) -(defn- separator? [this] (:separator (:bracket-info (:def this)))) -(defn- else-separator? [this] - (and (:separator (:bracket-info (:def this))) - (:colon (:params this)))) - - -(declare collect-clauses) - -(defn- process-bracket [this remainder] - (let [[subex remainder] (collect-clauses (:bracket-info (:def this)) - (:offset this) remainder)] - [(struct compiled-directive - (:func this) (:def this) - (merge (:params this) (tuple-map subex (:offset this))) - (:offset this)) - remainder])) - -(defn- process-clause [bracket-info offset remainder] - (consume - (fn [remainder] - (if (empty? remainder) - (format-error "No closing bracket found." offset) - (let [this (first remainder) - remainder (next remainder)] - (cond - (right-bracket this) - (process-bracket this remainder) - - (= (:right bracket-info) (:directive (:def this))) - [ nil [:right-bracket (:params this) nil remainder]] - - (else-separator? this) - [nil [:else nil (:params this) remainder]] - - (separator? this) - [nil [:separator nil nil remainder]] ;; TODO: check to make sure that there are no params on ~; - - true - [this remainder])))) - remainder)) - -(defn- collect-clauses [bracket-info offset remainder] - (second - (consume - (fn [[clause-map saw-else remainder]] - (let [[clause [type right-params else-params remainder]] - (process-clause bracket-info offset remainder)] - (cond - (= type :right-bracket) - [nil [(merge-with concat clause-map - {(if saw-else :else :clauses) [clause] - :right-params right-params}) - remainder]] - - (= type :else) - (cond - (:else clause-map) - (format-error "Two else clauses (\"~:;\") inside bracket construction." offset) - - (not (:else bracket-info)) - (format-error "An else clause (\"~:;\") is in a bracket type that doesn't support it." - offset) - - (and (= :first (:else bracket-info)) (seq (:clauses clause-map))) - (format-error - "The else clause (\"~:;\") is only allowed in the first position for this directive." - offset) - - true ; if the ~:; is in the last position, the else clause - ; is next, this was a regular clause - (if (= :first (:else bracket-info)) - [true [(merge-with concat clause-map { :else [clause] :else-params else-params}) - false remainder]] - [true [(merge-with concat clause-map { :clauses [clause] }) - true remainder]])) - - (= type :separator) - (cond - saw-else - (format-error "A plain clause (with \"~;\") follows an else clause (\"~:;\") inside bracket construction." offset) - - (not (:allows-separator bracket-info)) - (format-error "A separator (\"~;\") is in a bracket type that doesn't support it." - offset) - - true - [true [(merge-with concat clause-map { :clauses [clause] }) - false remainder]])))) - [{ :clauses [] } false remainder]))) - -(defn- process-nesting - "Take a linearly compiled format and process the bracket directives to give it - the appropriate tree structure" - [format] - (first - (consume - (fn [remainder] - (let [this (first remainder) - remainder (next remainder) - bracket (:bracket-info (:def this))] - (if (:right bracket) - (process-bracket this remainder) - [this remainder]))) - format))) - -(defn- compile-format - "Compiles format-str into a compiled format which can be used as an argument -to cl-format just like a plain format string. Use this function for improved -performance when you're using the same format string repeatedly" - [ format-str ] -; (prlabel compiling format-str) - (binding [*format-str* format-str] - (process-nesting - (first - (consume - (fn [[^String s offset]] - (if (empty? s) - [nil s] - (let [tilde (.IndexOf s \~)] ;;; indexOf (int \~) - (cond - (neg? tilde) [(compile-raw-string s offset) ["" (+ offset (.Length s))]] ;;; length - (zero? tilde) (compile-directive (subs s 1) (inc offset)) - true - [(compile-raw-string (subs s 0 tilde) offset) [(subs s tilde) (+ tilde offset)]])))) - [format-str 0]))))) - -(defn- needs-pretty - "determine whether a given compiled format has any directives that depend on the -column number or pretty printing" - [format] - (loop [format format] - (if (empty? format) - false - (if (or (:pretty (:flags (:def (first format)))) - (some needs-pretty (first (:clauses (:params (first format))))) - (some needs-pretty (first (:else (:params (first format)))))) - true - (recur (next format)))))) - -(defn- execute-format - "Executes the format with the arguments." - {:skip-wiki true} - ([stream format args] - (let [^System.IO.TextWriter real-stream (cond ;;; java.io.Writer - (not stream) (System.IO.StringWriter.) ;;; java.io.StringWriter - (true? stream) *out* - :else stream) - ^System.IO.TextWriter wrapped-stream (if (and (needs-pretty format) ;;; java.io.Writer - (not (pretty-writer? real-stream))) - (get-pretty-writer real-stream) - real-stream)] - (binding [*out* wrapped-stream] - (try - (execute-format format args) - (finally - (if-not (identical? real-stream wrapped-stream) - (.Flush wrapped-stream)))) ;;; flush - (if (not stream) (.ToString real-stream))))) ;;; toString - ([format args] - (map-passing-context - (fn [element context] - (if (abort? context) - [nil context] - (let [[params args] (realize-parameter-list - (:params element) context) - [params offsets] (unzip-map params) - params (assoc params :base-args args)] - [nil (apply (:func element) [params args offsets])]))) - args - format) - nil)) - -;;; This is a bad idea, but it prevents us from leaking private symbols -;;; This should all be replaced by really compiled formats anyway. -(def ^{:private true} cached-compile (memoize compile-format)) - -(defmacro formatter - "Makes a function which can directly run format-in. The function is -fn [stream & args] ... and returns nil unless the stream is nil (meaning -output to a string) in which case it returns the resulting string. - -format-in can be either a control string or a previously compiled format." - {:added "1.2"} - [format-in] - `(let [format-in# ~format-in - my-c-c# (var-get (get (ns-interns (the-ns 'clojure.pprint)) - '~'cached-compile)) - my-e-f# (var-get (get (ns-interns (the-ns 'clojure.pprint)) - '~'execute-format)) - my-i-n# (var-get (get (ns-interns (the-ns 'clojure.pprint)) - '~'init-navigator)) - cf# (if (string? format-in#) (my-c-c# format-in#) format-in#)] - (fn [stream# & args#] - (let [navigator# (my-i-n# args#)] - (my-e-f# stream# cf# navigator#))))) - -(defmacro formatter-out - "Makes a function which can directly run format-in. The function is -fn [& args] ... and returns nil. This version of the formatter macro is -designed to be used with *out* set to an appropriate Writer. In particular, -this is meant to be used as part of a pretty printer dispatch method. - -format-in can be either a control string or a previously compiled format." - {:added "1.2"} - [format-in] - `(let [format-in# ~format-in - cf# (if (string? format-in#) (#'clojure.pprint/cached-compile format-in#) format-in#)] - (fn [& args#] - (let [navigator# (#'clojure.pprint/init-navigator args#)] +;;; cl_format.clj -- part of the pretty printer for Clojure + +; 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: Tom Faulhaber +;; April 3, 2009 + + +;; This module implements the Common Lisp compatible format function as documented +;; in "Common Lisp the Language, 2nd edition", Chapter 22 (available online at: +;; http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000) + +(in-ns 'clojure.pprint) + +;;; Forward references +(declare compile-format) +(declare execute-format) +(declare init-navigator) +;;; End forward references + +(defn cl-format + "An implementation of a Common Lisp compatible format function. cl-format formats its +arguments to an output stream or string based on the format control string given. It +supports sophisticated formatting of structured data. + +Writer is an instance of java.io.Writer, true to output to *out* or nil to output +to a string, format-in is the format control string and the remaining arguments +are the data to be formatted. + +The format control string is a string to be output with embedded 'format directives' +describing how to format the various arguments passed in. + +If writer is nil, cl-format returns the formatted result string. Otherwise, cl-format +returns nil. + +For example: + (let [results [46 38 22]] + (cl-format true \"There ~[are~;is~:;are~]~:* ~d result~:p: ~{~d~^, ~}~%\" + (count results) results)) + +Prints to *out*: + There are 3 results: 46, 38, 22 + +Detailed documentation on format control strings is available in the \"Common Lisp the +Language, 2nd edition\", Chapter 22 (available online at: +http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000) +and in the Common Lisp HyperSpec at +http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm +" + {:added "1.2", + :see-also [["http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000" + "Common Lisp the Language"] + ["http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm" + "Common Lisp HyperSpec"]]} + [writer format-in & args] + (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) + navigator (init-navigator args)] + (execute-format writer compiled-format navigator))) + +(def ^:dynamic ^{:private true} *format-str* nil) + +(defn- format-error [message offset] + (let [full-message (str message \newline *format-str* \newline + (apply str (repeat offset \space)) "^" \newline)] + (throw (Exception. full-message)))) ;;; RuntimeException + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Argument navigators manage the argument list +;;; as the format statement moves through the list +;;; (possibly going forwards and backwards as it does so) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct ^{:private true} + arg-navigator :seq :rest :pos ) + +(defn- init-navigator + "Create a new arg-navigator from the sequence with the position set to 0" + {:skip-wiki true} + [s] + (let [s (seq s)] + (struct arg-navigator s s 0))) + +;; TODO call format-error with offset +(defn- next-arg [ navigator ] + (let [ rst (:rest navigator) ] + (if rst + [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))] + (throw (new Exception "Not enough arguments for format definition"))))) + +(defn- next-arg-or-nil [navigator] + (let [rst (:rest navigator)] + (if rst + [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))] + [nil navigator]))) + +;; Get an argument off the arg list and compile it if it's not already compiled +(defn- get-format-arg [navigator] + (let [[raw-format navigator] (next-arg navigator) + compiled-format (if (instance? String raw-format) + (compile-format raw-format) + raw-format)] + [compiled-format navigator])) + +(declare relative-reposition) + +(defn- absolute-reposition [navigator position] + (if (>= position (:pos navigator)) + (relative-reposition navigator (- position (:pos navigator))) + (struct arg-navigator (:seq navigator) (drop position (:seq navigator)) position))) + +(defn- relative-reposition [navigator position] + (let [newpos (+ (:pos navigator) position)] + (if (neg? position) + (absolute-reposition navigator newpos) + (struct arg-navigator (:seq navigator) (drop position (:rest navigator)) newpos)))) + +(defstruct ^{:private true} + compiled-directive :func :def :params :offset) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; When looking at the parameter list, we may need to manipulate +;;; the argument list as well (for 'V' and '#' parameter types). +;;; We hide all of this behind a function, but clients need to +;;; manage changing arg navigator +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; TODO: validate parameters when they come from arg list +(defn- realize-parameter [[param [raw-val offset]] navigator] + (let [[real-param new-navigator] + (cond + (contains? #{ :at :colon } param) ;pass flags through unchanged - this really isn't necessary + [raw-val navigator] + + (= raw-val :parameter-from-args) + (next-arg navigator) + + (= raw-val :remaining-arg-count) + [(count (:rest navigator)) navigator] + + true + [raw-val navigator])] + [[param [real-param offset]] new-navigator])) + +(defn- realize-parameter-list [parameter-map navigator] + (let [[pairs new-navigator] + (map-passing-context realize-parameter navigator parameter-map)] + [(into {} pairs) new-navigator])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Functions that support individual directives +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Common handling code for ~A and ~S +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declare opt-base-str) + +(def ^{:private true} + special-radix-markers {2 "#b" 8 "#o", 16 "#x"}) + +(defn- format-simple-number [n] + (cond + (integer? n) (if (= *print-base* 10) + (str n (if *print-radix* ".")) + (str + (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r"))) + (opt-base-str *print-base* n))) + (ratio? n) (str + (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r"))) + (opt-base-str *print-base* (.numerator ^clojure.lang.Ratio n)) + "/" + (opt-base-str *print-base* (.denominator ^clojure.lang.Ratio n))) + :else nil)) + +(defn- format-ascii [print-func params arg-navigator offsets] + (let [ [arg arg-navigator] (next-arg arg-navigator) + ^String base-output (or (format-simple-number arg) (print-func arg)) + base-width (.Length base-output) ;;; length + min-width (+ base-width (:minpad params)) + width (if (>= min-width (:mincol params)) + min-width + (+ min-width + (* (+ (quot (- (:mincol params) min-width 1) + (:colinc params) ) + 1) + (:colinc params)))) + chars (apply str (repeat (- width base-width) (:padchar params)))] + (if (:at params) + (print (str chars base-output)) + (print (str base-output chars))) + arg-navigator)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Support for the integer directives ~D, ~X, ~O, ~B and some +;;; of ~R +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- integral? + "returns true if a number is actually an integer (that is, has no fractional part)" + [x] + (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 (float x))) ;;; Math/floor, added float call + (ratio? x) (let [^clojure.lang.Ratio r x] + (= 0 (rem (.numerator r) (.denominator r)))) + :else false)) + +(defn- remainders + "Return the list of remainders (essentially the 'digits') of val in the given base" + [base val] + (reverse + (first + (consume #(if (pos? %) + [(rem % base) (quot % base)] + [nil nil]) + val)))) + +;;; TODO: xlated-val does not seem to be used here. ---- ;;;; I had to use it to prevent the call to remainders from returning a Double instead of an integer in the last position +(defn- base-str + "Return val as a string in the given base" + [base val] + (if (zero? val) + "0" + (let [xlated-val (cond + (float? val) (bigdec val) + (ratio? val) (let [^clojure.lang.Ratio r val] + (/ (.numerator r) (.denominator r))) + :else val)] + (apply str + (map + #(if (< % 10) (char (+ (int \0) %)) (char (+ (int \a) (- % 10)))) + (remainders base xlated-val)))))) + +(def ^{:private true} + java-base-formats {8 "%o", 10 "%d", 16 "%x"}) + +(defn- opt-base-str + "Return val as a string in the given base, using clojure.core/format if supported +for improved performance" + [base val] + (let [format-str (get java-base-formats base)] + (if (and format-str (integer? val) (not (instance? clojure.lang.BigInt val))) + (clojure.core/format format-str val) + (base-str base val)))) + +(defn- group-by* [unit lis] + (reverse + (first + (consume (fn [x] [(seq (reverse (take unit x))) (seq (drop unit x))]) (reverse lis))))) + +(defn- format-integer [base params arg-navigator offsets] + (let [[arg arg-navigator] (next-arg arg-navigator)] + (if (integral? arg) + (let [neg (neg? arg) + pos-arg (if neg (- arg) arg) + raw-str (opt-base-str base pos-arg) + group-str (if (:colon params) + (let [groups (map #(apply str %) (group-by* (:commainterval params) raw-str)) + commas (repeat (count groups) (:commachar params))] + (apply str (next (interleave commas groups)))) + raw-str) + ^String signed-str (cond + neg (str "-" group-str) + (:at params) (str "+" group-str) + true group-str) + padded-str (if (< (.Length signed-str) (:mincol params)) ;;; length + (str (apply str (repeat (- (:mincol params) (.Length signed-str)) ;;; length + (:padchar params))) + signed-str) + signed-str)] + (print padded-str)) + (format-ascii print-str {:mincol (:mincol params) :colinc 1 :minpad 0 + :padchar (:padchar params) :at true} + (init-navigator [arg]) nil)) + arg-navigator)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Support for english formats (~R and ~:R) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def ^{:private true} + english-cardinal-units + ["zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" + "ten" "eleven" "twelve" "thirteen" "fourteen" + "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"]) + +(def ^{:private true} + english-ordinal-units + ["zeroth" "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth" + "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth" + "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"]) + +(def ^{:private true} + english-cardinal-tens + ["" "" "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"]) + +(def ^{:private true} + english-ordinal-tens + ["" "" "twentieth" "thirtieth" "fortieth" "fiftieth" + "sixtieth" "seventieth" "eightieth" "ninetieth"]) + +;; We use "short scale" for our units (see http://en.wikipedia.org/wiki/Long_and_short_scales) +;; Number names from http://www.jimloy.com/math/billion.htm +;; We follow the rules for writing numbers from the Blue Book +;; (http://www.grammarbook.com/numbers/numbers.asp) +(def ^{:private true} + english-scale-numbers + ["" "thousand" "million" "billion" "trillion" "quadrillion" "quintillion" + "sextillion" "septillion" "octillion" "nonillion" "decillion" + "undecillion" "duodecillion" "tredecillion" "quattuordecillion" + "quindecillion" "sexdecillion" "septendecillion" + "octodecillion" "novemdecillion" "vigintillion"]) + +(defn- format-simple-cardinal + "Convert a number less than 1000 to a cardinal english string" + [num] + (let [hundreds (quot num 100) + tens (rem num 100)] + (str + (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred")) + (if (and (pos? hundreds) (pos? tens)) " ") + (if (pos? tens) + (if (< tens 20) + (nth english-cardinal-units tens) + (let [ten-digit (quot tens 10) + unit-digit (rem tens 10)] + (str + (if (pos? ten-digit) (nth english-cardinal-tens ten-digit)) + (if (and (pos? ten-digit) (pos? unit-digit)) "-") + (if (pos? unit-digit) (nth english-cardinal-units unit-digit))))))))) + +(defn- add-english-scales + "Take a sequence of parts, add scale numbers (e.g., million) and combine into a string +offset is a factor of 10^3 to multiply by" + [parts offset] + (let [cnt (count parts)] + (loop [acc [] + pos (dec cnt) + this (first parts) + remainder (next parts)] + (if (nil? remainder) + (str (apply str (interpose ", " acc)) + (if (and (not (empty? this)) (not (empty? acc))) ", ") + this + (if (and (not (empty? this)) (pos? (+ pos offset))) + (str " " (nth english-scale-numbers (+ pos offset))))) + (recur + (if (empty? this) + acc + (conj acc (str this " " (nth english-scale-numbers (+ pos offset))))) + (dec pos) + (first remainder) + (next remainder)))))) + +(defn- format-cardinal-english [params navigator offsets] + (let [[arg navigator] (next-arg navigator)] + (if (= 0 arg) + (print "zero") + (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs + parts (remainders 1000 abs-arg)] + (if (<= (count parts) (count english-scale-numbers)) + (let [parts-strs (map format-simple-cardinal parts) + full-str (add-english-scales parts-strs 0)] + (print (str (if (neg? arg) "minus ") full-str))) + (format-integer ;; for numbers > 10^63, we fall back on ~D + 10 + { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} + (init-navigator [arg]) + { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})))) + navigator)) + +(defn- format-simple-ordinal + "Convert a number less than 1000 to a ordinal english string +Note this should only be used for the last one in the sequence" + [num] + (let [hundreds (quot num 100) + tens (rem num 100)] + (str + (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred")) + (if (and (pos? hundreds) (pos? tens)) " ") + (if (pos? tens) + (if (< tens 20) + (nth english-ordinal-units tens) + (let [ten-digit (quot tens 10) + unit-digit (rem tens 10)] + (if (and (pos? ten-digit) (not (pos? unit-digit))) + (nth english-ordinal-tens ten-digit) + (str + (if (pos? ten-digit) (nth english-cardinal-tens ten-digit)) + (if (and (pos? ten-digit) (pos? unit-digit)) "-") + (if (pos? unit-digit) (nth english-ordinal-units unit-digit)))))) + (if (pos? hundreds) "th"))))) + +(defn- format-ordinal-english [params navigator offsets] + (let [[arg navigator] (next-arg navigator)] + (if (= 0 arg) + (print "zeroth") + (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs + parts (remainders 1000 abs-arg)] + (if (<= (count parts) (count english-scale-numbers)) + (let [parts-strs (map format-simple-cardinal (drop-last parts)) + head-str (add-english-scales parts-strs 1) + tail-str (format-simple-ordinal (last parts))] + (print (str (if (neg? arg) "minus ") + (cond + (and (not (empty? head-str)) (not (empty? tail-str))) + (str head-str ", " tail-str) + + (not (empty? head-str)) (str head-str "th") + :else tail-str)))) + (do (format-integer ;; for numbers > 10^63, we fall back on ~D + 10 + { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} + (init-navigator [arg]) + { :mincol 0, :padchar 0, :commachar 0 :commainterval 0}) + (let [low-two-digits (rem arg 100) + not-teens (or (< 11 low-two-digits) (> 19 low-two-digits)) + low-digit (rem low-two-digits 10)] + (print (cond + (and (== low-digit 1) not-teens) "st" + (and (== low-digit 2) not-teens) "nd" + (and (== low-digit 3) not-teens) "rd" + :else "th"))))))) + navigator)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Support for roman numeral formats (~@R and ~@:R) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def ^{:private true} + old-roman-table + [[ "I" "II" "III" "IIII" "V" "VI" "VII" "VIII" "VIIII"] + [ "X" "XX" "XXX" "XXXX" "L" "LX" "LXX" "LXXX" "LXXXX"] + [ "C" "CC" "CCC" "CCCC" "D" "DC" "DCC" "DCCC" "DCCCC"] + [ "M" "MM" "MMM"]]) + +(def ^{:private true} + new-roman-table + [[ "I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX"] + [ "X" "XX" "XXX" "XL" "L" "LX" "LXX" "LXXX" "XC"] + [ "C" "CC" "CCC" "CD" "D" "DC" "DCC" "DCCC" "CM"] + [ "M" "MM" "MMM"]]) + +(defn- format-roman + "Format a roman numeral using the specified look-up table" + [table params navigator offsets] + (let [[arg navigator] (next-arg navigator)] + (if (and (number? arg) (> arg 0) (< arg 4000)) + (let [digits (remainders 10 arg)] + (loop [acc [] + pos (dec (count digits)) + digits digits] + (if (empty? digits) + (print (apply str acc)) + (let [digit (first digits)] + (recur (if (= 0 digit) + acc + (conj acc (nth (nth table pos) (dec digit)))) + (dec pos) + (next digits)))))) + (format-integer ;; for anything <= 0 or > 3999, we fall back on ~D + 10 + { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true} + (init-navigator [arg]) + { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})) + navigator)) + +(defn- format-old-roman [params navigator offsets] + (format-roman old-roman-table params navigator offsets)) + +(defn- format-new-roman [params navigator offsets] + (format-roman new-roman-table params navigator offsets)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Support for character formats (~C) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def ^{:private true} + special-chars { 8 "Backspace", 9 "Tab", 10 "Newline", 13 "Return", 32 "Space"}) + +(defn- pretty-character [params navigator offsets] + (let [[c navigator] (next-arg navigator) + as-int (int c) + base-char (bit-and as-int 127) + meta (bit-and as-int 128) + special (get special-chars base-char)] + (if (> meta 0) (print "Meta-")) + (print (cond + special special + (< base-char 32) (str "Control-" (char (+ base-char 64))) + (= base-char 127) "Control-?" + :else (char base-char))) + navigator)) + +(defn- readable-character [params navigator offsets] + (let [[c navigator] (next-arg navigator)] + (condp = (:char-format params) + \o (cl-format true "\\o~3,'0o" (int c)) + \u (cl-format true "\\u~4,'0x" (int c)) + nil (pr c)) + navigator)) + +(defn- plain-character [params navigator offsets] + (let [[char navigator] (next-arg navigator)] + (print char) + navigator)) + +;; Check to see if a result is an abort (~^) construct +;; TODO: move these funcs somewhere more appropriate +(defn- abort? [context] + (let [token (first context)] + (or (= :up-arrow token) (= :colon-up-arrow token)))) + +;; Handle the execution of "sub-clauses" in bracket constructions +(defn- execute-sub-format [format args base-args] + (second + (map-passing-context + (fn [element context] + (if (abort? context) + [nil context] ; just keep passing it along + (let [[params args] (realize-parameter-list (:params element) context) + [params offsets] (unzip-map params) + params (assoc params :base-args base-args)] + [nil (apply (:func element) [params args offsets])]))) + args + format))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Support for real number formats +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; TODO - return exponent as int to eliminate double conversion +(defn- float-parts-base + "Produce string parts for the mantissa (normalized 1-9) and exponent" + [^Object f] + (let [^String s (.ToLower (.ToString f)) ;;; .toLowerCase .toString + exploc (.IndexOf s \e) ;;; .indexOf (int \e) + dotloc (.IndexOf s \.)] ;;; .indexOf (int \.) + (if (neg? exploc) + (if (neg? dotloc) + [s (str (dec (count s)))] + [(str (subs s 0 dotloc) (subs s (inc dotloc))) (str (dec dotloc))]) + (if (neg? dotloc) + [(subs s 0 exploc) (subs s (inc exploc))] + [(str (subs s 0 1) (subs s 2 exploc)) (subs s (inc exploc))])))) + + +(defn- float-parts + "Take care of leading and trailing zeros in decomposed floats" + [f] + (let [[m ^String e] (float-parts-base f) + m1 (rtrim m \0) + m2 (ltrim m1 \0) + delta (- (count m1) (count m2)) + ^String e (if (and (pos? (count e)) (= (nth e 0) \+)) (subs e 1) e)] + (if (empty? m2) + ["0" 0] + [m2 (- (Int32/Parse e) delta)]))) ;;; (Integer/valueOf e) + +(defn- ^String inc-s + "Assumption: The input string consists of one or more decimal digits, +and no other characters. Return a string containing one or more +decimal digits containing a decimal number one larger than the input +string. The output string will always be the same length as the input +string, or one character longer." + [^String s] + (let [len-1 (dec (count s))] + (loop [i (int len-1)] + (cond + (neg? i) (apply str "1" (repeat (inc len-1) "0")) + (= \9 (.get_Chars s i)) (recur (dec i)) ;;; .charAt + :else (apply str (subs s 0 i) + (char (inc (int (.get_Chars s i)))) ;;; .charAt + (repeat (- len-1 i) "0")))))) + +(defn- round-str [m e d w] + (if (or d w) + (let [len (count m) + ;; Every formatted floating point number should include at + ;; least one decimal digit and a decimal point. + w (if w (max 2 w)) + round-pos (cond + ;; If d was given, that forces the rounding + ;; position, regardless of any width that may + ;; have been specified. + d (+ e d 1) + ;; Otherwise w was specified, so pick round-pos + ;; based upon that. + ;; If e>=0, then abs value of number is >= 1.0, + ;; and e+1 is number of decimal digits before the + ;; decimal point when the number is written + ;; without scientific notation. Never round the + ;; number before the decimal point. + (>= e 0) (max (inc e) (dec w)) + ;; e < 0, so number abs value < 1.0 + :else (+ w e)) + [m1 e1 round-pos len] (if (= round-pos 0) + [(str "0" m) (inc e) 1 (inc len)] + [m e round-pos len])] + (if round-pos + (if (neg? round-pos) + ["0" 0 false] + (if (> len round-pos) + (let [round-char (nth m1 round-pos) + ^String result (subs m1 0 round-pos)] + (if (>= (int round-char) (int \5)) + (let [round-up-result (inc-s result) + expanded (> (count round-up-result) (count result))] + [(if expanded + (subs round-up-result 0 (dec (count round-up-result))) + round-up-result) + e1 expanded]) + [result e1 false])) + [m e false])) + [m e false])) + [m e false])) + +(defn- expand-fixed [m e d] + (let [[m1 e1] (if (neg? e) + [(str (apply str (repeat (dec (- e)) \0)) m) -1] + [m e]) + len (count m1) + target-len (if d (+ e1 d 1) (inc e1))] + (if (< len target-len) + (str m1 (apply str (repeat (- target-len len) \0))) + m1))) + +(defn- insert-decimal + "Insert the decimal point at the right spot in the number to match an exponent" + [m e] + (if (neg? e) + (str "." m) + (let [loc (inc e)] + (str (subs m 0 loc) "." (subs m loc))))) + +(defn- get-fixed [m e d] + (insert-decimal (expand-fixed m e d) e)) + +(defn- insert-scaled-decimal + "Insert the decimal point at the right spot in the number to match an exponent" + [m k] + (if (neg? k) + (str "." m) + (str (subs m 0 k) "." (subs m k)))) + +(defn- convert-ratio [x] + (if (ratio? x) + ;; Usually convert to a double, only resorting to the slower + ;; bigdec conversion if the result does not fit within the range + ;; of a double. + (let [d (double x)] + (if (== d 0.0) + (if (not= x 0) + (bigdec x) + d) + (if (or (== d Double/PositiveInfinity) (== d Double/NegativeInfinity)) ;;; Double/POSITIVE_INFINITY Double/NEGATIVE_INFINITY + (bigdec x) + d))) + x)) + +;; the function to render ~F directives +;; TODO: support rationals. Back off to ~D/~A is the appropriate cases +(defn- fixed-float [params navigator offsets] + (let [w (:w params) + d (:d params) + [arg navigator] (next-arg navigator) + [sign abs] (if (neg? arg) ["-" (- arg)] ["+" arg]) + abs (convert-ratio abs) + [mantissa exp] (float-parts abs) + scaled-exp (+ exp (:k params)) + add-sign (or (:at params) (neg? arg)) + append-zero (and (not d) (<= (dec (count mantissa)) scaled-exp)) + [rounded-mantissa scaled-exp expanded] (round-str mantissa scaled-exp + d (if w (- w (if add-sign 1 0)))) + ^String 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 + (> (count fixed-repr) (- w (if add-sign 1 0)))) + (subs fixed-repr 1) ; chop off leading 0 + fixed-repr) + prepend-zero (= (first fixed-repr) \.)] + (if w + (let [len (count fixed-repr) + signed-len (if add-sign (inc len) len) + prepend-zero (and prepend-zero (not (>= signed-len w))) + append-zero (and append-zero (not (>= signed-len w))) + full-len (if (or prepend-zero append-zero) + (inc signed-len) + signed-len)] + (if (and (> full-len w) (:overflowchar params)) + (print (apply str (repeat w (:overflowchar params)))) + (print (str + (apply str (repeat (- w full-len) (:padchar params))) + (if add-sign sign) + (if prepend-zero "0") + fixed-repr + (if append-zero "0"))))) + (print (str + (if add-sign sign) + (if prepend-zero "0") + fixed-repr + (if append-zero "0")))) + navigator)) + + +;; the function to render ~E directives +;; TODO: support rationals. Back off to ~D/~A is the appropriate cases +;; TODO: define ~E representation for Infinity +(defn- exponential-float [params navigator offsets] + (let [[arg navigator] (next-arg navigator) + arg (convert-ratio arg)] + (loop [[mantissa exp] (float-parts (if (neg? arg) (- arg) arg))] + (let [w (:w params) + d (:d params) + e (:e params) + k (:k params) + expchar (or (:exponentchar params) \E) + add-sign (or (:at params) (neg? arg)) + prepend-zero (<= k 0) + ^Int32 scaled-exp (- exp (dec k)) ;;; Integer + scaled-exp-str (str (Math/Abs scaled-exp)) ;;; Math/abs + scaled-exp-str (str expchar (if (neg? scaled-exp) \- \+) + (if e (apply str + (repeat + (- e + (count scaled-exp-str)) + \0))) + scaled-exp-str) + exp-width (count scaled-exp-str) + base-mantissa-width (count mantissa) + scaled-mantissa (str (apply str (repeat (- k) \0)) + mantissa + (if d + (apply str + (repeat + (- d (dec base-mantissa-width) + (if (neg? k) (- k) 0)) \0)))) + w-mantissa (if w (- w exp-width)) + [rounded-mantissa _ incr-exp] (round-str + scaled-mantissa 0 + (cond + (= k 0) (dec d) + (pos? k) d + (neg? k) (dec d)) + (if w-mantissa + (- w-mantissa (if add-sign 1 0)))) + full-mantissa (insert-scaled-decimal rounded-mantissa k) + append-zero (and (= k (count rounded-mantissa)) (nil? d))] + (if (not incr-exp) + (if w + (let [len (+ (count full-mantissa) exp-width) + signed-len (if add-sign (inc len) len) + prepend-zero (and prepend-zero (not (= signed-len w))) + full-len (if prepend-zero (inc signed-len) signed-len) + append-zero (and append-zero (< full-len w))] + (if (and (or (> full-len w) (and e (> (- exp-width 2) e))) + (:overflowchar params)) + (print (apply str (repeat w (:overflowchar params)))) + (print (str + (apply str + (repeat + (- w full-len (if append-zero 1 0) ) + (:padchar params))) + (if add-sign (if (neg? arg) \- \+)) + (if prepend-zero "0") + full-mantissa + (if append-zero "0") + scaled-exp-str)))) + (print (str + (if add-sign (if (neg? arg) \- \+)) + (if prepend-zero "0") + full-mantissa + (if append-zero "0") + scaled-exp-str))) + (recur [rounded-mantissa (inc exp)])))) + navigator)) + +;; the function to render ~G directives +;; This just figures out whether to pass the request off to ~F or ~E based +;; on the algorithm in CLtL. +;; TODO: support rationals. Back off to ~D/~A is the appropriate cases +;; TODO: refactor so that float-parts isn't called twice +(defn- general-float [params navigator offsets] + (let [[arg _] (next-arg navigator) + arg (convert-ratio arg) + [mantissa exp] (float-parts (if (neg? arg) (- arg) arg)) + w (:w params) + d (:d params) + e (:e params) + n (if (= arg 0.0) 0 (inc exp)) + ee (if e (+ e 2) 4) + ww (if w (- w ee)) + d (if d d (max (count mantissa) (min n 7))) + dd (- d n)] + (if (<= 0 dd d) + (let [navigator (fixed-float {:w ww, :d dd, :k 0, + :overflowchar (:overflowchar params), + :padchar (:padchar params), :at (:at params)} + navigator offsets)] + (print (apply str (repeat ee \space))) + navigator) + (exponential-float params navigator offsets)))) + +;; the function to render ~$ directives +;; TODO: support rationals. Back off to ~D/~A is the appropriate cases +(defn- dollar-float [params navigator offsets] + (let [[^Double arg navigator] (next-arg navigator) + [mantissa exp] (float-parts (Math/Abs arg)) ;;; Math/abs + d (:d params) ; digits after the decimal + n (:n params) ; minimum digits before the decimal + w (:w params) ; minimum field width + add-sign (or (:at params) (neg? arg)) + [rounded-mantissa scaled-exp expanded] (round-str mantissa exp d nil) + ^String fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d) + full-repr (str (apply str (repeat (- n (.IndexOf fixed-repr \.)) \0)) fixed-repr) ;;; .indexOf (int \.) + full-len (+ (count full-repr) (if add-sign 1 0))] + (print (str + (if (and (:colon params) add-sign) (if (neg? arg) \- \+)) + (apply str (repeat (- w full-len) (:padchar params))) + (if (and (not (:colon params)) add-sign) (if (neg? arg) \- \+)) + full-repr)) + navigator)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Support for the '~[...~]' conditional construct in its +;;; different flavors +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; ~[...~] without any modifiers chooses one of the clauses based on the param or +;; next argument +;; TODO check arg is positive int +(defn- choice-conditional [params arg-navigator offsets] + (let [arg (:selector params) + [arg navigator] (if arg [arg arg-navigator] (next-arg arg-navigator)) + clauses (:clauses params) + clause (if (or (neg? arg) (>= arg (count clauses))) + (first (:else params)) + (nth clauses arg))] + (if clause + (execute-sub-format clause navigator (:base-args params)) + navigator))) + +;; ~:[...~] with the colon reads the next argument treating it as a truth value +(defn- boolean-conditional [params arg-navigator offsets] + (let [[arg navigator] (next-arg arg-navigator) + clauses (:clauses params) + clause (if arg + (second clauses) + (first clauses))] + (if clause + (execute-sub-format clause navigator (:base-args params)) + navigator))) + +;; ~@[...~] with the at sign executes the conditional if the next arg is not +;; nil/false without consuming the arg +(defn- check-arg-conditional [params arg-navigator offsets] + (let [[arg navigator] (next-arg arg-navigator) + clauses (:clauses params) + clause (if arg (first clauses))] + (if arg + (if clause + (execute-sub-format clause arg-navigator (:base-args params)) + arg-navigator) + navigator))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Support for the '~{...~}' iteration construct in its +;;; different flavors +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;; ~{...~} without any modifiers uses the next argument as an argument list that +;; is consumed by all the iterations +(defn- iterate-sublist [params navigator offsets] + (let [max-count (:max-iterations params) + param-clause (first (:clauses params)) + [clause navigator] (if (empty? param-clause) + (get-format-arg navigator) + [param-clause navigator]) + [arg-list navigator] (next-arg navigator) + args (init-navigator arg-list)] + (loop [count 0 + args args + last-pos (num -1)] + (if (and (not max-count) (= (:pos args) last-pos) (> count 1)) + ;; TODO get the offset in here and call format exception + (throw (Exception. "%{ construct not consuming any arguments: Infinite loop!"))) ;;; RuntimeException + (if (or (and (empty? (:rest args)) + (or (not (:colon (:right-params params))) (> count 0))) + (and max-count (>= count max-count))) + navigator + (let [iter-result (execute-sub-format clause args (:base-args params))] + (if (= :up-arrow (first iter-result)) + navigator + (recur (inc count) iter-result (:pos args)))))))) + +;; ~:{...~} with the colon treats the next argument as a list of sublists. Each of the +;; sublists is used as the arglist for a single iteration. +(defn- iterate-list-of-sublists [params navigator offsets] + (let [max-count (:max-iterations params) + param-clause (first (:clauses params)) + [clause navigator] (if (empty? param-clause) + (get-format-arg navigator) + [param-clause navigator]) + [arg-list navigator] (next-arg navigator)] + (loop [count 0 + arg-list arg-list] + (if (or (and (empty? arg-list) + (or (not (:colon (:right-params params))) (> count 0))) + (and max-count (>= count max-count))) + navigator + (let [iter-result (execute-sub-format + clause + (init-navigator (first arg-list)) + (init-navigator (next arg-list)))] + (if (= :colon-up-arrow (first iter-result)) + navigator + (recur (inc count) (next arg-list)))))))) + +;; ~@{...~} with the at sign uses the main argument list as the arguments to the iterations +;; is consumed by all the iterations +(defn- iterate-main-list [params navigator offsets] + (let [max-count (:max-iterations params) + param-clause (first (:clauses params)) + [clause navigator] (if (empty? param-clause) + (get-format-arg navigator) + [param-clause navigator])] + (loop [count 0 + navigator navigator + last-pos (num -1)] + (if (and (not max-count) (= (:pos navigator) last-pos) (> count 1)) + ;; TODO get the offset in here and call format exception + (throw (Exception. "%@{ construct not consuming any arguments: Infinite loop!"))) ;;; RuntimeException + (if (or (and (empty? (:rest navigator)) + (or (not (:colon (:right-params params))) (> count 0))) + (and max-count (>= count max-count))) + navigator + (let [iter-result (execute-sub-format clause navigator (:base-args params))] + (if (= :up-arrow (first iter-result)) + (second iter-result) + (recur + (inc count) iter-result (:pos navigator)))))))) + +;; ~@:{...~} with both colon and at sign uses the main argument list as a set of sublists, one +;; of which is consumed with each iteration +(defn- iterate-main-sublists [params navigator offsets] + (let [max-count (:max-iterations params) + param-clause (first (:clauses params)) + [clause navigator] (if (empty? param-clause) + (get-format-arg navigator) + [param-clause navigator]) + ] + (loop [count 0 + navigator navigator] + (if (or (and (empty? (:rest navigator)) + (or (not (:colon (:right-params params))) (> count 0))) + (and max-count (>= count max-count))) + navigator + (let [[sublist navigator] (next-arg-or-nil navigator) + iter-result (execute-sub-format clause (init-navigator sublist) navigator)] + (if (= :colon-up-arrow (first iter-result)) + navigator + (recur (inc count) navigator))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The '~< directive has two completely different meanings +;;; in the '~<...~>' form it does justification, but with +;;; ~<...~:>' it represents the logical block operation of the +;;; pretty printer. +;;; +;;; Unfortunately, the current architecture decides what function +;;; to call at form parsing time before the sub-clauses have been +;;; folded, so it is left to run-time to make the decision. +;;; +;;; TODO: make it possible to make these decisions at compile-time. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declare format-logical-block) +(declare justify-clauses) + +(defn- logical-block-or-justify [params navigator offsets] + (if (:colon (:right-params params)) + (format-logical-block params navigator offsets) + (justify-clauses params navigator offsets))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Support for the '~<...~>' justification directive +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- render-clauses [clauses navigator base-navigator] + (loop [clauses clauses + acc [] + navigator navigator] + (if (empty? clauses) + [acc navigator] + (let [clause (first clauses) + [iter-result result-str] (binding [*out* (System.IO.StringWriter.)] ;;; java.io.StringWriter. + [(execute-sub-format clause navigator base-navigator) + (.ToString *out*)])] ;;; toString + (if (= :up-arrow (first iter-result)) + [acc (second iter-result)] + (recur (next clauses) (conj acc result-str) iter-result)))))) + +;; TODO support for ~:; constructions +(defn- justify-clauses [params navigator offsets] + (let [[[eol-str] new-navigator] (when-let [else (:else params)] + (render-clauses else navigator (:base-args params))) + navigator (or new-navigator navigator) + [else-params new-navigator] (when-let [p (:else-params params)] + (realize-parameter-list p navigator)) + navigator (or new-navigator navigator) + min-remaining (or (first (:min-remaining else-params)) 0) + max-columns (or (first (:max-columns else-params)) + (get-max-column *out*)) + clauses (:clauses params) + [strs navigator] (render-clauses clauses navigator (:base-args params)) + slots (max 1 + (+ (dec (count strs)) (if (:colon params) 1 0) (if (:at params) 1 0))) + chars (reduce + (map count strs)) + mincol (:mincol params) + minpad (:minpad params) + colinc (:colinc params) + minout (+ chars (* slots minpad)) + result-columns (if (<= minout mincol) + mincol + (+ mincol (* colinc + (+ 1 (quot (- minout mincol 1) colinc))))) + total-pad (- result-columns chars) + pad (max minpad (quot total-pad slots)) + extra-pad (- total-pad (* pad slots)) + pad-str (apply str (repeat pad (:padchar params)))] + (if (and eol-str (> (+ (get-column (:base @@*out*)) min-remaining result-columns) + max-columns)) + (print eol-str)) + (loop [slots slots + extra-pad extra-pad + strs strs + pad-only (or (:colon params) + (and (= (count strs) 1) (not (:at params))))] + (if (seq strs) + (do + (print (str (if (not pad-only) (first strs)) + (if (or pad-only (next strs) (:at params)) pad-str) + (if (pos? extra-pad) (:padchar params)))) + (recur + (dec slots) + (dec extra-pad) + (if pad-only strs (next strs)) + false)))) + navigator)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Support for case modification with ~(...~). +;;; We do this by wrapping the underlying writer with +;;; a special writer to do the appropriate modification. This +;;; allows us to support arbitrary-sized output and sources +;;; that may block. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- downcase-writer + "Returns a proxy that wraps writer, converting all characters to lower case" + [^System.IO.TextWriter writer] ;;; java.io.Writer + (proxy [System.IO.TextWriter] [] ;;; java.io.Writer + (Close [] (.Close writer)) ;;; close + (Flush [] (.Flush writer)) ;;; flush + (Write ([^chars cbuf off len] ;;; write ^Integer hint removed from off,len + (.Write writer cbuf ^Int32 off ^Int32 len)) ;;; write, hints added + ([x] + (condp = (class x) + String + (let [s ^String x] + (.Write writer (.ToLower s))) ;;; write toLowerCase + + Int32 ;;; Integer + (let [c x] ;;; Character hint removoed + (.Write writer (int (Char/ToLower (char c)))))))))) ;;; .write Character/toLowerCase + +(defn- upcase-writer + "Returns a proxy that wraps writer, converting all characters to upper case" + [^System.IO.TextWriter writer] ;;; java.io.Writer + (proxy [System.IO.TextWriter] [] ;;; java.io.Writer + (Close [] (.Close writer)) + (Flush [] (.Flush writer)) + (Write ([^chars cbuf off len] ;;; ^Integer hint removed from off, len + (.Write writer cbuf ^Int32 off ^Int32 len)) ;; Int32 hints added + ([x] + (condp = (class x) + String + (let [s ^String x] + (.Write writer (.ToUpper s))) + + Int32 + (let [c x] ;;; Character hint removed from c + (.Write writer (int (Char/ToUpper (char c)))))))))) + +(defn- capitalize-string + "Capitalizes the words in a string. If first? is false, don't capitalize the + first character of the string even if it's a letter." + [s first?] + (let [^Char f (first s) ;;; Character + s (if (and first? f (Char/IsLetter f)) ;;; Character/isLetter + (str (Char/ToUpper f) (subs s 1)) ;;; Character/toUpperCase + s)] + (apply str + (first + (consume + (fn [s] + (if (empty? s) + [nil nil] + (let [m (re-matcher #"\W\w" s) + match (re-find m) + offset (and match (inc (.start m)))] ;;; .start + (if offset + [(str (subs s 0 offset) + (Char/ToUpper ^Char (char (nth s offset)))) ;;; Character/toUpperCase Character (char ... ) wrapper added + (subs s (inc offset))] + [s nil])))) + s))))) + +(defn- capitalize-word-writer + "Returns a proxy that wraps writer, capitalizing all words" + [^System.IO.TextWriter writer] ;;; java.io.Writer + (let [last-was-whitespace? (ref true)] + (proxy [System.IO.TextWriter] [] + (Close [] (.Close writer)) + (Flush [] (.Flush writer)) + (Write + ([^chars cbuf off len] (let [off (int off) len (int len)] ;;; remove ^Integer hints on off, len + (.Write writer cbuf off len)) ) + ([x] + (condp = (class x) + String + (let [s ^String x] + (.Write writer + ^String (capitalize-string (.ToLower s) @last-was-whitespace?)) ;;; toLowerCase + (when (pos? (.Length s)) ;;; .length + (dosync + (ref-set last-was-whitespace? + (Char/IsWhiteSpace ;;; Character/isWhitespace + ^Char (nth s (dec (count s)))))))) ;;; ^Character + + Int32 + (let [c (char x)] + (let [mod-c (if @last-was-whitespace? (Char/ToUpper (char x)) c)] + (.Write writer (int mod-c)) + (dosync (ref-set last-was-whitespace? (Char/IsWhiteSpace (char x)))))))))))) + +(defn- init-cap-writer + "Returns a proxy that wraps writer, capitalizing the first word" + [^System.IO.TextWriter writer] ;;; java.io.Writer + (let [capped (ref false)] + (proxy [System.IO.TextWriter] [] + (Close [] (.Close writer)) + (Flush [] (.Flush writer)) + (Write ([^chars cbuf off len] (let [off (int off) len (int len)] ;;; remove ^Integer hints on off, len + (.Write writer cbuf off len)) ) + ([x] + (condp = (class x) + String + (let [s (.ToLower ^String x)] + (if (not @capped) + (let [m (re-matcher #"\S" s) + match (re-find m) + offset (and match (.start m))] ;;; start + (if offset + (do (.Write writer + (str (subs s 0 offset) + (Char/ToUpper ^Char (char (nth s offset))) ;; added (char ... ) + (.ToLower ^String (subs s (inc offset))))) + (dosync (ref-set capped true))) + (.Write writer s))) + (.Write writer (.ToLower s)))) + + Int32 + (let [c ^Char (char x)] + (if (and (not @capped) (Char/IsLetter c)) + (do + (dosync (ref-set capped true)) + (.Write writer (int (Char/ToUpper c)))) + (.Write writer (int (Char/ToLower c))))))))))) + +(defn- modify-case [make-writer params navigator offsets] + (let [clause (first (:clauses params))] + (binding [*out* (make-writer *out*)] + (execute-sub-format clause navigator (:base-args params))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; If necessary, wrap the writer in a PrettyWriter object +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn get-pretty-writer + "Returns the java.io.Writer passed in wrapped in a pretty writer proxy, unless it's +already a pretty writer. Generally, it is unnecessary to call this function, since pprint, +write, and cl-format all call it if they need to. However if you want the state to be +preserved across calls, you will want to wrap them with this. + +For example, when you want to generate column-aware output with multiple calls to cl-format, +do it like in this example: + + (defn print-table [aseq column-width] + (binding [*out* (get-pretty-writer *out*)] + (doseq [row aseq] + (doseq [col row] + (cl-format true \"~4D~7,vT\" col column-width)) + (prn)))) + +Now when you run: + + user> (print-table (map #(vector % (* % %) (* % % %)) (range 1 11)) 8) + +It prints a table of squares and cubes for the numbers from 1 to 10: + + 1 1 1 + 2 4 8 + 3 9 27 + 4 16 64 + 5 25 125 + 6 36 216 + 7 49 343 + 8 64 512 + 9 81 729 + 10 100 1000" + {:added "1.2"} + [writer] + (if (pretty-writer? writer) + writer + (pretty-writer writer *print-right-margin* *print-miser-width*))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Support for column-aware operations ~&, ~T +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn fresh-line + "Make a newline if *out* is not already at the beginning of the line. If *out* is +not a pretty writer (which keeps track of columns), this function always outputs a newline." + {:added "1.2"} + [] + (if (instance? clojure.lang.IDeref *out*) + (if (not (= 0 (get-column (:base @@*out*)))) + (prn)) + (prn))) + +(defn- absolute-tabulation [params navigator offsets] + (let [colnum (:colnum params) + colinc (:colinc params) + current (get-column (:base @@*out*)) + space-count (cond + (< current colnum) (- colnum current) + (= colinc 0) 0 + :else (- colinc (rem (- current colnum) colinc)))] + (print (apply str (repeat space-count \space)))) + navigator) + +(defn- relative-tabulation [params navigator offsets] + (let [colrel (:colnum params) + colinc (:colinc params) + start-col (+ colrel (get-column (:base @@*out*))) + offset (if (pos? colinc) (rem start-col colinc) 0) + space-count (+ colrel (if (= 0 offset) 0 (- colinc offset)))] + (print (apply str (repeat space-count \space)))) + navigator) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Support for accessing the pretty printer from a format +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; TODO: support ~@; per-line-prefix separator +;; TODO: get the whole format wrapped so we can start the lb at any column +(defn- format-logical-block [params navigator offsets] + (let [clauses (:clauses params) + clause-count (count clauses) + prefix (cond + (> clause-count 1) (:string (:params (first (first clauses)))) + (:colon params) "(") + body (nth clauses (if (> clause-count 1) 1 0)) + suffix (cond + (> clause-count 2) (:string (:params (first (nth clauses 2)))) + (:colon params) ")") + [arg navigator] (next-arg navigator)] + (pprint-logical-block :prefix prefix :suffix suffix + (execute-sub-format + body + (init-navigator arg) + (:base-args params))) + navigator)) + +(defn- set-indent [params navigator offsets] + (let [relative-to (if (:colon params) :current :block)] + (pprint-indent relative-to (:n params)) + navigator)) + +;;; TODO: support ~:T section options for ~T + +(defn- conditional-newline [params navigator offsets] + (let [kind (if (:colon params) + (if (:at params) :mandatory :fill) + (if (:at params) :miser :linear))] + (pprint-newline kind) + navigator)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The table of directives we support, each with its params, +;;; properties, and the compilation function +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; We start with a couple of helpers +(defn- process-directive-table-element [ [ char params flags bracket-info & generator-fn ] ] + [char, + {:directive char, + :params `(array-map ~@params), + :flags flags, + :bracket-info bracket-info, + :generator-fn (concat '(fn [ params offset]) generator-fn) }]) + +(defmacro ^{:private true} + defdirectives + [ & directives ] + `(def ^{:private true} + directive-table (hash-map ~@(mapcat process-directive-table-element directives)))) + +(defdirectives + (\A + [ :mincol [0 Int32] :colinc [1 Int32] :minpad [0 Int32] :padchar [\space Char] ] + #{ :at :colon :both} {} + #(format-ascii print-str %1 %2 %3)) + + (\S + [ :mincol [0 Int32] :colinc [1 Int32] :minpad [0 Int32] :padchar [\space Char] ] + #{ :at :colon :both} {} + #(format-ascii pr-str %1 %2 %3)) + + (\D + [ :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char] + :commainterval [ 3 Int32]] + #{ :at :colon :both } {} + #(format-integer 10 %1 %2 %3)) + + (\B + [ :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char] + :commainterval [ 3 Int32]] + #{ :at :colon :both } {} + #(format-integer 2 %1 %2 %3)) + + (\O + [ :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char] + :commainterval [ 3 Int32]] + #{ :at :colon :both } {} + #(format-integer 8 %1 %2 %3)) + + (\X + [ :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char] + :commainterval [ 3 Int32]] + #{ :at :colon :both } {} + #(format-integer 16 %1 %2 %3)) + + (\R + [:base [nil Int32] :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char] + :commainterval [ 3 Int32]] + #{ :at :colon :both } {} + (do + (cond ; ~R is overloaded with bizareness + (first (:base params)) #(format-integer (:base %1) %1 %2 %3) + (and (:at params) (:colon params)) #(format-old-roman %1 %2 %3) + (:at params) #(format-new-roman %1 %2 %3) + (:colon params) #(format-ordinal-english %1 %2 %3) + true #(format-cardinal-english %1 %2 %3)))) + + (\P + [ ] + #{ :at :colon :both } {} + (fn [params navigator offsets] + (let [navigator (if (:colon params) (relative-reposition navigator -1) navigator) + strs (if (:at params) ["y" "ies"] ["" "s"]) + [arg navigator] (next-arg navigator)] + (print (if (= arg 1) (first strs) (second strs))) + navigator))) + + (\C + [:char-format [nil Char]] + #{ :at :colon :both } {} + (cond + (:colon params) pretty-character + (:at params) readable-character + :else plain-character)) + + (\F + [ :w [nil Int32] :d [nil Int32] :k [0 Int32] :overflowchar [nil Char] + :padchar [\space Char] ] + #{ :at } {} + fixed-float) + + (\E + [ :w [nil Int32] :d [nil Int32] :e [nil Int32] :k [1 Int32] + :overflowchar [nil Char] :padchar [\space Char] + :exponentchar [nil Char] ] + #{ :at } {} + exponential-float) + + (\G + [ :w [nil Int32] :d [nil Int32] :e [nil Int32] :k [1 Int32] + :overflowchar [nil Char] :padchar [\space Char] + :exponentchar [nil Char] ] + #{ :at } {} + general-float) + + (\$ + [ :d [2 Int32] :n [1 Int32] :w [0 Int32] :padchar [\space Char]] + #{ :at :colon :both} {} + dollar-float) + + (\% + [ :count [1 Int32] ] + #{ } {} + (fn [params arg-navigator offsets] + (dotimes [i (:count params)] + (prn)) + arg-navigator)) + + (\& + [ :count [1 Int32] ] + #{ :pretty } {} + (fn [params arg-navigator offsets] + (let [cnt (:count params)] + (if (pos? cnt) (fresh-line)) + (dotimes [i (dec cnt)] + (prn))) + arg-navigator)) + + (\| + [ :count [1 Int32] ] + #{ } {} + (fn [params arg-navigator offsets] + (dotimes [i (:count params)] + (print \formfeed)) + arg-navigator)) + + (\~ + [ :n [1 Int32] ] + #{ } {} + (fn [params arg-navigator offsets] + (let [n (:n params)] + (print (apply str (repeat n \~))) + arg-navigator))) + + (\newline ;; Whitespace supression is handled in the compilation loop + [ ] + #{:colon :at} {} + (fn [params arg-navigator offsets] + (if (:at params) + (prn)) + arg-navigator)) + + (\T + [ :colnum [1 Int32] :colinc [1 Int32] ] + #{ :at :pretty } {} + (if (:at params) + #(relative-tabulation %1 %2 %3) + #(absolute-tabulation %1 %2 %3))) + + (\* + [ :n [nil Int32] ] + #{ :colon :at } {} + (if (:at params) + (fn [params navigator offsets] + (let [n (or (:n params) 0)] ; ~@* has a default n = 0 + (absolute-reposition navigator n))) + (fn [params navigator offsets] + (let [n (or (:n params) 1)] ; whereas ~* and ~:* have a default n = 1 + (relative-reposition navigator (if (:colon params) (- n) n)))))) + + (\? + [ ] + #{ :at } {} + (if (:at params) + (fn [params navigator offsets] ; args from main arg list + (let [[subformat navigator] (get-format-arg navigator)] + (execute-sub-format subformat navigator (:base-args params)))) + (fn [params navigator offsets] ; args from sub-list + (let [[subformat navigator] (get-format-arg navigator) + [subargs navigator] (next-arg navigator) + sub-navigator (init-navigator subargs)] + (execute-sub-format subformat sub-navigator (:base-args params)) + navigator)))) + + + (\( + [ ] + #{ :colon :at :both} { :right \), :allows-separator nil, :else nil } + (let [mod-case-writer (cond + (and (:at params) (:colon params)) + upcase-writer + + (:colon params) + capitalize-word-writer + + (:at params) + init-cap-writer + + :else + downcase-writer)] + #(modify-case mod-case-writer %1 %2 %3))) + + (\) [] #{} {} nil) + + (\[ + [ :selector [nil Int32] ] + #{ :colon :at } { :right \], :allows-separator true, :else :last } + (cond + (:colon params) + boolean-conditional + + (:at params) + check-arg-conditional + + true + choice-conditional)) + + (\; [:min-remaining [nil Int32] :max-columns [nil Int32]] + #{ :colon } { :separator true } nil) + + (\] [] #{} {} nil) + + (\{ + [ :max-iterations [nil Int32] ] + #{ :colon :at :both} { :right \}, :allows-separator false } + (cond + (and (:at params) (:colon params)) + iterate-main-sublists + + (:colon params) + iterate-list-of-sublists + + (:at params) + iterate-main-list + + true + iterate-sublist)) + + + (\} [] #{:colon} {} nil) + + (\< + [:mincol [0 Int32] :colinc [1 Int32] :minpad [0 Int32] :padchar [\space Char]] + #{:colon :at :both :pretty} { :right \>, :allows-separator true, :else :first } + logical-block-or-justify) + + (\> [] #{:colon} {} nil) + + ;; TODO: detect errors in cases where colon not allowed + (\^ [:arg1 [nil Int32] :arg2 [nil Int32] :arg3 [nil Int32]] + #{:colon} {} + (fn [params navigator offsets] + (let [arg1 (:arg1 params) + arg2 (:arg2 params) + arg3 (:arg3 params) + exit (if (:colon params) :colon-up-arrow :up-arrow)] + (cond + (and arg1 arg2 arg3) + (if (<= arg1 arg2 arg3) [exit navigator] navigator) + + (and arg1 arg2) + (if (= arg1 arg2) [exit navigator] navigator) + + arg1 + (if (= arg1 0) [exit navigator] navigator) + + true ; TODO: handle looking up the arglist stack for info + (if (if (:colon params) + (empty? (:rest (:base-args params))) + (empty? (:rest navigator))) + [exit navigator] navigator))))) + + (\W + [] + #{:at :colon :both :pretty} {} + (if (or (:at params) (:colon params)) + (let [bindings (concat + (if (:at params) [:level nil :length nil] []) + (if (:colon params) [:pretty true] []))] + (fn [params navigator offsets] + (let [[arg navigator] (next-arg navigator)] + (if (apply write arg bindings) + [:up-arrow navigator] + navigator)))) + (fn [params navigator offsets] + (let [[arg navigator] (next-arg navigator)] + (if (write-out arg) + [:up-arrow navigator] + navigator))))) + + (\_ + [] + #{:at :colon :both} {} + conditional-newline) + + (\I + [:n [0 Int32]] + #{:colon} {} + set-indent) + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Code to manage the parameters and flags associated with each +;;; directive in the format string. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def ^{:private true} + param-pattern #"^([vV]|#|('.)|([+-]?\d+)|(?=,))") +(def ^{:private true} + special-params #{ :parameter-from-args :remaining-arg-count }) + +(defn- extract-param [[s offset saw-comma]] + (let [m (re-matcher param-pattern s) + param (re-find m)] + (if param + (let [token-str (first (re-groups m)) + remainder (subs s (.end m)) ;;; end + new-offset (+ offset (.end m))] + (if (not (= \, (nth remainder 0))) + [ [token-str offset] [remainder new-offset false]] + [ [token-str offset] [(subs remainder 1) (inc new-offset) true]])) + (if saw-comma + (format-error "Badly formed parameters in format directive" offset) + [ nil [s offset]])))) + + +(defn- extract-params [s offset] + (consume extract-param [s offset false])) + +(defn- translate-param + "Translate the string representation of a param to the internalized + representation" + [[^String p offset]] + [(cond + (= (.Length p) 0) nil + (and (= (.Length p) 1) (contains? #{\v \V} (nth p 0))) :parameter-from-args ;;; length + (and (= (.Length p) 1) (= \# (nth p 0))) :remaining-arg-count + (and (= (.Length p) 2) (= \' (nth p 0))) (nth p 1) + true (Int32/Parse p)) ;;; (new Integer p) + offset]) + +(def ^{:private true} + flag-defs { \: :colon, \@ :at }) + +(defn- extract-flags [s offset] + (consume + (fn [[s offset flags]] + (if (empty? s) + [nil [s offset flags]] + (let [flag (get flag-defs (first s))] + (if flag + (if (contains? flags flag) + (format-error + (str "Flag \"" (first s) "\" appears more than once in a directive") + offset) + [true [(subs s 1) (inc offset) (assoc flags flag [true offset])]]) + [nil [s offset flags]])))) + [s offset {}])) + +(defn- check-flags [def flags] + (let [allowed (:flags def)] + (if (and (not (:at allowed)) (:at flags)) + (format-error (str "\"@\" is an illegal flag for format directive \"" (:directive def) "\"") + (nth (:at flags) 1))) + (if (and (not (:colon allowed)) (:colon flags)) + (format-error (str "\":\" is an illegal flag for format directive \"" (:directive def) "\"") + (nth (:colon flags) 1))) + (if (and (not (:both allowed)) (:at flags) (:colon flags)) + (format-error (str "Cannot combine \"@\" and \":\" flags for format directive \"" + (:directive def) "\"") + (min (nth (:colon flags) 1) (nth (:at flags) 1)))))) + +(defn- map-params + "Takes a directive definition and the list of actual parameters and +a map of flags and returns a map of the parameters and flags with defaults +filled in. We check to make sure that there are the right types and number +of parameters as well." + [def params flags offset] + (check-flags def flags) + (if (> (count params) (count (:params def))) + (format-error + (cl-format + nil + "Too many parameters for directive \"~C\": ~D~:* ~[were~;was~:;were~] specified but only ~D~:* ~[are~;is~:;are~] allowed" + (:directive def) (count params) (count (:params def))) + (second (first params)))) + (doall + (map #(let [val (first %1)] + (if (not (or (nil? val) (contains? special-params val) + (instance? (second (second %2)) val))) + (format-error (str "Parameter " (name (first %2)) + " has bad type in directive \"" (:directive def) "\": " + (class val)) + (second %1))) ) + params (:params def))) + + (merge ; create the result map + (into (array-map) ; start with the default values, make sure the order is right + (reverse (for [[name [default]] (:params def)] [name [default offset]]))) + (reduce #(apply assoc %1 %2) {} (filter #(first (nth % 1)) (zipmap (keys (:params def)) params))) ; add the specified parameters, filtering out nils + flags)) ; and finally add the flags + +(defn- compile-directive [s offset] + (let [[raw-params [rest offset]] (extract-params s offset) + [_ [rest offset flags]] (extract-flags rest offset) + directive (first rest) + def (get directive-table (Char/ToUpper ^Char directive)) ;;; Character/toUpperCase + params (if def (map-params def (map translate-param raw-params) flags offset))] + (if (not directive) + (format-error "Format string ended in the middle of a directive" offset)) + (if (not def) + (format-error (str "Directive \"" directive "\" is undefined") offset)) + [(struct compiled-directive ((:generator-fn def) params offset) def params offset) + (let [remainder (subs rest 1) + offset (inc offset) + trim? (and (= \newline (:directive def)) + (not (:colon params))) + trim-count (if trim? (prefix-count remainder [\space \tab]) 0) + remainder (subs remainder trim-count) + offset (+ offset trim-count)] + [remainder offset])])) + +(defn- compile-raw-string [s offset] + (struct compiled-directive (fn [_ a _] (print s) a) nil { :string s } offset)) + +(defn- right-bracket [this] (:right (:bracket-info (:def this)))) +(defn- separator? [this] (:separator (:bracket-info (:def this)))) +(defn- else-separator? [this] + (and (:separator (:bracket-info (:def this))) + (:colon (:params this)))) + + +(declare collect-clauses) + +(defn- process-bracket [this remainder] + (let [[subex remainder] (collect-clauses (:bracket-info (:def this)) + (:offset this) remainder)] + [(struct compiled-directive + (:func this) (:def this) + (merge (:params this) (tuple-map subex (:offset this))) + (:offset this)) + remainder])) + +(defn- process-clause [bracket-info offset remainder] + (consume + (fn [remainder] + (if (empty? remainder) + (format-error "No closing bracket found." offset) + (let [this (first remainder) + remainder (next remainder)] + (cond + (right-bracket this) + (process-bracket this remainder) + + (= (:right bracket-info) (:directive (:def this))) + [ nil [:right-bracket (:params this) nil remainder]] + + (else-separator? this) + [nil [:else nil (:params this) remainder]] + + (separator? this) + [nil [:separator nil nil remainder]] ;; TODO: check to make sure that there are no params on ~; + + true + [this remainder])))) + remainder)) + +(defn- collect-clauses [bracket-info offset remainder] + (second + (consume + (fn [[clause-map saw-else remainder]] + (let [[clause [type right-params else-params remainder]] + (process-clause bracket-info offset remainder)] + (cond + (= type :right-bracket) + [nil [(merge-with concat clause-map + {(if saw-else :else :clauses) [clause] + :right-params right-params}) + remainder]] + + (= type :else) + (cond + (:else clause-map) + (format-error "Two else clauses (\"~:;\") inside bracket construction." offset) + + (not (:else bracket-info)) + (format-error "An else clause (\"~:;\") is in a bracket type that doesn't support it." + offset) + + (and (= :first (:else bracket-info)) (seq (:clauses clause-map))) + (format-error + "The else clause (\"~:;\") is only allowed in the first position for this directive." + offset) + + true ; if the ~:; is in the last position, the else clause + ; is next, this was a regular clause + (if (= :first (:else bracket-info)) + [true [(merge-with concat clause-map { :else [clause] :else-params else-params}) + false remainder]] + [true [(merge-with concat clause-map { :clauses [clause] }) + true remainder]])) + + (= type :separator) + (cond + saw-else + (format-error "A plain clause (with \"~;\") follows an else clause (\"~:;\") inside bracket construction." offset) + + (not (:allows-separator bracket-info)) + (format-error "A separator (\"~;\") is in a bracket type that doesn't support it." + offset) + + true + [true [(merge-with concat clause-map { :clauses [clause] }) + false remainder]])))) + [{ :clauses [] } false remainder]))) + +(defn- process-nesting + "Take a linearly compiled format and process the bracket directives to give it + the appropriate tree structure" + [format] + (first + (consume + (fn [remainder] + (let [this (first remainder) + remainder (next remainder) + bracket (:bracket-info (:def this))] + (if (:right bracket) + (process-bracket this remainder) + [this remainder]))) + format))) + +(defn- compile-format + "Compiles format-str into a compiled format which can be used as an argument +to cl-format just like a plain format string. Use this function for improved +performance when you're using the same format string repeatedly" + [ format-str ] +; (prlabel compiling format-str) + (binding [*format-str* format-str] + (process-nesting + (first + (consume + (fn [[^String s offset]] + (if (empty? s) + [nil s] + (let [tilde (.IndexOf s \~)] ;;; indexOf (int \~) + (cond + (neg? tilde) [(compile-raw-string s offset) ["" (+ offset (.Length s))]] ;;; length + (zero? tilde) (compile-directive (subs s 1) (inc offset)) + true + [(compile-raw-string (subs s 0 tilde) offset) [(subs s tilde) (+ tilde offset)]])))) + [format-str 0]))))) + +(defn- needs-pretty + "determine whether a given compiled format has any directives that depend on the +column number or pretty printing" + [format] + (loop [format format] + (if (empty? format) + false + (if (or (:pretty (:flags (:def (first format)))) + (some needs-pretty (first (:clauses (:params (first format))))) + (some needs-pretty (first (:else (:params (first format)))))) + true + (recur (next format)))))) + +(defn- execute-format + "Executes the format with the arguments." + {:skip-wiki true} + ([stream format args] + (let [^System.IO.TextWriter real-stream (cond ;;; java.io.Writer + (not stream) (System.IO.StringWriter.) ;;; java.io.StringWriter + (true? stream) *out* + :else stream) + ^System.IO.TextWriter wrapped-stream (if (and (needs-pretty format) ;;; java.io.Writer + (not (pretty-writer? real-stream))) + (get-pretty-writer real-stream) + real-stream)] + (binding [*out* wrapped-stream] + (try + (execute-format format args) + (finally + (if-not (identical? real-stream wrapped-stream) + (.Flush wrapped-stream)))) ;;; flush + (if (not stream) (.ToString real-stream))))) ;;; toString + ([format args] + (map-passing-context + (fn [element context] + (if (abort? context) + [nil context] + (let [[params args] (realize-parameter-list + (:params element) context) + [params offsets] (unzip-map params) + params (assoc params :base-args args)] + [nil (apply (:func element) [params args offsets])]))) + args + format) + nil)) + +;;; This is a bad idea, but it prevents us from leaking private symbols +;;; This should all be replaced by really compiled formats anyway. +(def ^{:private true} cached-compile (memoize compile-format)) + +(defmacro formatter + "Makes a function which can directly run format-in. The function is +fn [stream & args] ... and returns nil unless the stream is nil (meaning +output to a string) in which case it returns the resulting string. + +format-in can be either a control string or a previously compiled format." + {:added "1.2"} + [format-in] + `(let [format-in# ~format-in + my-c-c# (var-get (get (ns-interns (the-ns 'clojure.pprint)) + '~'cached-compile)) + my-e-f# (var-get (get (ns-interns (the-ns 'clojure.pprint)) + '~'execute-format)) + my-i-n# (var-get (get (ns-interns (the-ns 'clojure.pprint)) + '~'init-navigator)) + cf# (if (string? format-in#) (my-c-c# format-in#) format-in#)] + (fn [stream# & args#] + (let [navigator# (my-i-n# args#)] + (my-e-f# stream# cf# navigator#))))) + +(defmacro formatter-out + "Makes a function which can directly run format-in. The function is +fn [& args] ... and returns nil. This version of the formatter macro is +designed to be used with *out* set to an appropriate Writer. In particular, +this is meant to be used as part of a pretty printer dispatch method. + +format-in can be either a control string or a previously compiled format." + {:added "1.2"} + [format-in] + `(let [format-in# ~format-in + cf# (if (string? format-in#) (#'clojure.pprint/cached-compile format-in#) format-in#)] + (fn [& args#] + (let [navigator# (#'clojure.pprint/init-navigator args#)] (#'clojure.pprint/execute-format cf# navigator#))))) \ No newline at end of file diff --git a/Clojure/Clojure.Source/clojure/pprint/column_writer.clj b/Clojure/Clojure.Source/clojure/pprint/column_writer.clj index e4b0a1757..33f708aa5 100644 --- a/Clojure/Clojure.Source/clojure/pprint/column_writer.clj +++ b/Clojure/Clojure.Source/clojure/pprint/column_writer.clj @@ -1,89 +1,89 @@ -;;; column_writer.clj -- part of the pretty printer for Clojure - - -; 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: Tom Faulhaber -;; April 3, 2009 -;; Revised to use proxy instead of gen-class April 2010 - -;; This module implements a column-aware wrapper around an instance of java.io.Writer - -(in-ns 'clojure.pprint) - -(import [clojure.lang IDeref] - [System.IO TextWriter]) ;;; java.io Writer All instances of Writer replaced by TextWriter - -(def ^:dynamic ^{:private true} *default-page-width* 72) - -(defn- get-field [^TextWriter this sym] - (sym @@this)) - -(defn- set-field [^TextWriter this sym new-val] - (alter @this assoc sym new-val)) - -(defn- get-column [this] - (get-field this :cur)) - -(defn- get-line [this] - (get-field this :line)) - -(defn- get-max-column [this] - (get-field this :max)) - -(defn- set-max-column [this new-max] - (dosync (set-field this :max new-max)) - nil) - -(defn- get-writer [this] - (get-field this :base)) - -(defn- c-write-char [^TextWriter this c] (let [c (int c)] ;;; in place of ^Integer - (dosync (if (= c (int \newline)) - (do - (set-field this :cur 0) - (set-field this :line (inc (get-field this :line)))) - (set-field this :cur (inc (get-field this :cur))))) - (.Write ^TextWriter (get-field this :base) (char c))) ) - -(defn- column-writer - ([writer] (column-writer writer *default-page-width*)) - ([^TextWriter writer max-columns] - (let [fields (ref {:max max-columns, :cur 0, :line 0 :base writer})] - (proxy [TextWriter IDeref] [] - (deref [] fields) - (Flush [] - (.Flush writer)) - (Write - ([^chars cbuf off len] (let [off (int off) len (int len)] ;;; removed ^Integer hints on off, len - (let [^TextWriter writer (get-field this :base)] - (.Write writer cbuf off len))) ) - ([x] - (condp = (class x) - - String - (let [^String s x - nl (.LastIndexOf s \newline)] ;;; (int \newline) - (dosync (if (neg? nl) - (set-field this :cur (+ (get-field this :cur) (count s))) - (do - (set-field this :cur (- (count s) nl 1)) - (set-field this :line (+ (get-field this :line) - (count (filter #(= % \newline) s))))))) - (.Write ^TextWriter (get-field this :base) s)) - - ;Char - ;(.Write writer ^Char x) - - ;;(cc-write-char this x) - - Int32 - (c-write-char this x) - Int64 - (c-write-char this x)))))))) +;;; column_writer.clj -- part of the pretty printer for Clojure + + +; 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: Tom Faulhaber +;; April 3, 2009 +;; Revised to use proxy instead of gen-class April 2010 + +;; This module implements a column-aware wrapper around an instance of java.io.Writer + +(in-ns 'clojure.pprint) + +(import [clojure.lang IDeref] + [System.IO TextWriter]) ;;; java.io Writer All instances of Writer replaced by TextWriter + +(def ^:dynamic ^{:private true} *default-page-width* 72) + +(defn- get-field [^TextWriter this sym] + (sym @@this)) + +(defn- set-field [^TextWriter this sym new-val] + (alter @this assoc sym new-val)) + +(defn- get-column [this] + (get-field this :cur)) + +(defn- get-line [this] + (get-field this :line)) + +(defn- get-max-column [this] + (get-field this :max)) + +(defn- set-max-column [this new-max] + (dosync (set-field this :max new-max)) + nil) + +(defn- get-writer [this] + (get-field this :base)) + +(defn- c-write-char [^TextWriter this c] (let [c (int c)] ;;; in place of ^Integer + (dosync (if (= c (int \newline)) + (do + (set-field this :cur 0) + (set-field this :line (inc (get-field this :line)))) + (set-field this :cur (inc (get-field this :cur))))) + (.Write ^TextWriter (get-field this :base) (char c))) ) + +(defn- column-writer + ([writer] (column-writer writer *default-page-width*)) + ([^TextWriter writer max-columns] + (let [fields (ref {:max max-columns, :cur 0, :line 0 :base writer})] + (proxy [TextWriter IDeref] [] + (deref [] fields) + (Flush [] + (.Flush writer)) + (Write + ([^chars cbuf off len] (let [off (int off) len (int len)] ;;; removed ^Integer hints on off, len + (let [^TextWriter writer (get-field this :base)] + (.Write writer cbuf off len))) ) + ([x] + (condp = (class x) + + String + (let [^String s x + nl (.LastIndexOf s \newline)] ;;; (int \newline) + (dosync (if (neg? nl) + (set-field this :cur (+ (get-field this :cur) (count s))) + (do + (set-field this :cur (- (count s) nl 1)) + (set-field this :line (+ (get-field this :line) + (count (filter #(= % \newline) s))))))) + (.Write ^TextWriter (get-field this :base) s)) + + ;Char + ;(.Write writer ^Char x) + + ;;(cc-write-char this x) + + Int32 + (c-write-char this x) + Int64 + (c-write-char this x)))))))) diff --git a/Clojure/Clojure.Source/clojure/pprint/dispatch.clj b/Clojure/Clojure.Source/clojure/pprint/dispatch.clj index 1663f59b5..9d042d8da 100644 --- a/Clojure/Clojure.Source/clojure/pprint/dispatch.clj +++ b/Clojure/Clojure.Source/clojure/pprint/dispatch.clj @@ -1,568 +1,568 @@ -;; dispatch.clj -- part of the pretty printer for Clojure - -; 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: Tom Faulhaber -;; April 3, 2009 - - -;; This module implements the default dispatch tables for pretty printing code and -;; data. - -(in-ns 'clojure.pprint) - -(defn- use-method - "Installs a function as a new method of multimethod associated with dispatch-value. " - [^clojure.lang.MultiFn multifn dispatch-val func] - (. multifn addMethod dispatch-val func)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Implementations of specific dispatch table entries -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Handle forms that can be "back-translated" to reader macros -;;; Not all reader macros can be dealt with this way or at all. -;;; Macros that we can't deal with at all are: -;;; ; - The comment character is absorbed by the reader and never is part of the form -;;; ` - Is fully processed at read time into a lisp expression (which will contain concats -;;; and regular quotes). -;;; ~@ - Also fully eaten by the processing of ` and can't be used outside. -;;; , - is whitespace and is lost (like all other whitespace). Formats can generate commas -;;; where they deem them useful to help readability. -;;; ^ - Adding metadata completely disappears at read time and the data appears to be -;;; completely lost. -;;; -;;; Most other syntax stuff is dealt with directly by the formats (like (), [], {}, and #{}) -;;; or directly by printing the objects using Clojure's built-in print functions (like -;;; :keyword, \char, or ""). The notable exception is #() which is special-cased. - -(def ^{:private true} reader-macros - {'quote "'", 'clojure.core/deref "@", - 'var "#'", 'clojure.core/unquote "~"}) - -(defn- pprint-reader-macro [alis] - (let [^String macro-char (reader-macros (first alis))] - (when (and macro-char (= 2 (count alis))) - (.Write ^System.IO.TextWriter *out* macro-char) - (write-out (second alis)) - true))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Dispatch for the basic data types when interpreted -;; as data (as opposed to code). -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; TODO: inline these formatter statements into funcs so that we -;;; are a little easier on the stack. (Or, do "real" compilation, a -;;; la Common Lisp) - -(declare pprint-map) - -(defn- pprint-meta [obj] - (when *print-meta* - (when-let [m (meta obj)] - (.Write ^System.IO.TextWriter *out* "^") ;;; ^java.io.Writer - (pprint-map m) - (.Write ^System.IO.TextWriter *out* " ") ;;; ^java.io.Writer - (pprint-newline :linear)))) - -;;; (def pprint-simple-list (formatter-out "~:<~@{~w~^ ~_~}~:>")) -(defn- pprint-simple-list [alis] - (pprint-meta alis) - (pprint-logical-block :prefix "(" :suffix ")" - (print-length-loop [alis (seq alis)] - (when alis - (write-out (first alis)) - (when (next alis) - (.Write ^System.IO.TextWriter *out* " ") - (pprint-newline :linear) - (recur (next alis))))))) - -(defn- pprint-list [alis] - (if-not (pprint-reader-macro alis) - (pprint-simple-list alis))) - -;;; (def pprint-vector (formatter-out "~<[~;~@{~w~^ ~_~}~;]~:>")) -(defn- pprint-vector [avec] - (pprint-meta avec) - (pprint-logical-block :prefix "[" :suffix "]" - (print-length-loop [aseq (seq avec)] - (when aseq - (write-out (first aseq)) - (when (next aseq) - (.Write ^System.IO.TextWriter *out* " ") - (pprint-newline :linear) - (recur (next aseq))))))) - -(def ^{:private true} pprint-array (formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>")) - -;;; (def pprint-map (formatter-out "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>")) -(defn- pprint-map [amap] - (pprint-meta amap) - (let [[ns lift-map] (when (not (record? amap)) - (#'clojure.core/lift-ns amap)) - amap (or lift-map amap) - prefix (if ns (str "#:" ns "{") "{")] - (pprint-logical-block :prefix prefix :suffix "}" - (print-length-loop [aseq (seq amap)] - (when aseq - (pprint-logical-block - (write-out (ffirst aseq)) - (.Write ^System.IO.TextWriter *out* " ") ;;; ^java.io.Writer - (pprint-newline :linear) - (set! *current-length* 0) ; always print both parts of the [k v] pair - (write-out (fnext (first aseq)))) - (when (next aseq) - (.Write ^System.IO.TextWriter *out* ", ") ;;; ^java.io.Writer - (pprint-newline :linear) - (recur (next aseq)))))))) - -;;; (def ^{:private true} pprint-set (formatter-out "~<#{~;~@{~w~^ ~:_~}~;}~:>")) -(defn- pprint-set [aset] - (pprint-meta aset) - (pprint-logical-block :prefix "#{" :suffix "}" - (print-length-loop [aseq (seq aset)] - (when aseq - (write-out (first aseq)) - (when (next aseq) - (.Write ^System.IO.TextWriter *out* " ") ;;; ^java.io.Writer - (pprint-newline :linear) - (recur (next aseq))))))) - -(def ^{:private true} - type-map {"core$future_call" "Future", - "core$promise" "Promise"}) - -(defn- map-ref-type - "Map ugly type names to something simpler" - [name] - (or (when-let [match (re-find #"^[^$]+\$[^$]+" name)] - (type-map match)) - name)) - -(defn- pprint-ideref [o] - (let [prefix (format "#<%s@%x%s: " - (map-ref-type (.Name (class o))) ;;; getSimpleName - (.GetHashCode ^Object o) ;;; System/identityHashCode, added type hint - (if (and (instance? clojure.lang.Agent o) - (agent-error o)) - " FAILED" - ""))] - (pprint-logical-block :prefix prefix :suffix ">" - (pprint-indent :block (-> (count prefix) (- 2) -)) - (pprint-newline :linear) - (write-out (cond - (and (future? o) (not (future-done? o))) :pending - (and (instance? clojure.lang.IPending o) (not (.isRealized ^clojure.lang.IPending o))) :not-delivered - :else @o))))) - -(def ^{:private true} pprint-pqueue (formatter-out "~<<-(~;~@{~w~^ ~_~}~;)-<~:>")) - -(defn- pprint-simple-default [obj] - (cond - (.IsArray (class obj)) (pprint-array obj) - (and *print-suppress-namespaces* (symbol? obj)) (print (name obj)) - :else (pr obj))) - - -(defmulti - simple-dispatch - "The pretty print dispatch function for simple data structure format." - {:added "1.2" :arglists '[[object]]} - class) - -(use-method simple-dispatch clojure.lang.ISeq pprint-list) -(use-method simple-dispatch clojure.lang.IPersistentVector pprint-vector) -(use-method simple-dispatch clojure.lang.IPersistentMap pprint-map) -(use-method simple-dispatch clojure.lang.IPersistentSet pprint-set) -(use-method simple-dispatch clojure.lang.PersistentQueue pprint-pqueue) -(use-method simple-dispatch clojure.lang.Var pprint-simple-default) -(use-method simple-dispatch clojure.lang.IDeref pprint-ideref) -(use-method simple-dispatch nil pr) -(use-method simple-dispatch :default pprint-simple-default) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Dispatch for the code table -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(declare pprint-simple-code-list) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Format the namespace ("ns") macro. This is quite complicated because of all the -;;; different forms supported and because programmers can choose lists or vectors -;;; in various places. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- brackets - "Figure out which kind of brackets to use" - [form] - (if (vector? form) - ["[" "]"] - ["(" ")"])) - -(defn- pprint-ns-reference - "Pretty print a single reference (import, use, etc.) from a namespace decl" - [reference] - (if (sequential? reference) - (let [[start end] (brackets reference) - [keyw & args] reference] - (pprint-logical-block :prefix start :suffix end - ((formatter-out "~w~:i") keyw) - (loop [args args] - (when (seq args) - ((formatter-out " ")) - (let [arg (first args)] - (if (sequential? arg) - (let [[start end] (brackets arg)] - (pprint-logical-block :prefix start :suffix end - (if (and (= (count arg) 3) (keyword? (second arg))) - (let [[ns kw lis] arg] - ((formatter-out "~w ~w ") ns kw) - (if (sequential? lis) - ((formatter-out (if (vector? lis) - "~<[~;~@{~w~^ ~:_~}~;]~:>" - "~<(~;~@{~w~^ ~:_~}~;)~:>")) - lis) - (write-out lis))) - (apply (formatter-out "~w ~:i~@{~w~^ ~:_~}") arg))) - (when (next args) - ((formatter-out "~_")))) - (do - (write-out arg) - (when (next args) - ((formatter-out "~:_")))))) - (recur (next args)))))) - (when reference (write-out reference)))) - -(defn- pprint-ns - "The pretty print dispatch chunk for the ns macro" - [alis] - (if (next alis) - (let [[ns-sym ns-name & stuff] alis - [doc-str stuff] (if (string? (first stuff)) - [(first stuff) (next stuff)] - [nil stuff]) - [attr-map references] (if (map? (first stuff)) - [(first stuff) (next stuff)] - [nil stuff])] - (pprint-logical-block :prefix "(" :suffix ")" - ((formatter-out "~w ~1I~@_~w") ns-sym ns-name) - (when (or doc-str attr-map (seq references)) - ((formatter-out "~@:_"))) - (when doc-str - (cl-format true "\"~a\"~:[~;~:@_~]" doc-str (or attr-map (seq references)))) - (when attr-map - ((formatter-out "~w~:[~;~:@_~]") attr-map (seq references))) - (loop [references references] - (pprint-ns-reference (first references)) - (when-let [references (next references)] - (pprint-newline :linear) - (recur references))))) - (write-out alis))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Format something that looks like a simple def (sans metadata, since the reader -;;; won't give it to us now). -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(def ^{:private true} pprint-hold-first (formatter-out "~:<~w~^ ~@_~w~^ ~_~@{~w~^ ~_~}~:>")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Format something that looks like a defn or defmacro -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Format the params and body of a defn with a single arity -(defn- single-defn [alis has-doc-str?] - (if (seq alis) - (do - (if has-doc-str? - ((formatter-out " ~_")) - ((formatter-out " ~@_"))) - ((formatter-out "~{~w~^ ~_~}") alis)))) - -;;; Format the param and body sublists of a defn with multiple arities -(defn- multi-defn [alis has-doc-str?] - (if (seq alis) - ((formatter-out " ~_~{~w~^ ~_~}") alis))) - -;;; TODO: figure out how to support capturing metadata in defns (we might need a -;;; special reader) -(defn- pprint-defn [alis] - (if (next alis) - (let [[defn-sym defn-name & stuff] alis - [doc-str stuff] (if (string? (first stuff)) - [(first stuff) (next stuff)] - [nil stuff]) - [attr-map stuff] (if (map? (first stuff)) - [(first stuff) (next stuff)] - [nil stuff])] - (pprint-logical-block :prefix "(" :suffix ")" - ((formatter-out "~w ~1I~@_~w") defn-sym defn-name) - (if doc-str - ((formatter-out " ~_~w") doc-str)) - (if attr-map - ((formatter-out " ~_~w") attr-map)) - ;; Note: the multi-defn case will work OK for malformed defns too - (cond - (vector? (first stuff)) (single-defn stuff (or doc-str attr-map)) - :else (multi-defn stuff (or doc-str attr-map))))) - (pprint-simple-code-list alis))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Format something with a binding form -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- pprint-binding-form [binding-vec] - (pprint-logical-block :prefix "[" :suffix "]" - (print-length-loop [binding binding-vec] - (when (seq binding) - (pprint-logical-block binding - (write-out (first binding)) - (when (next binding) - (.Write ^System.IO.TextWriter *out* " ") - (pprint-newline :miser) - (write-out (second binding)))) - (when (next (rest binding)) - (.Write ^System.IO.TextWriter *out* " ") - (pprint-newline :linear) - (recur (next (rest binding)))))))) - -(defn- pprint-let [alis] - (let [base-sym (first alis)] - (pprint-logical-block :prefix "(" :suffix ")" - (if (and (next alis) (vector? (second alis))) - (do - ((formatter-out "~w ~1I~@_") base-sym) - (pprint-binding-form (second alis)) - ((formatter-out " ~_~{~w~^ ~_~}") (next (rest alis)))) - (pprint-simple-code-list alis))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Format something that looks like "if" -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(def ^{:private true} pprint-if (formatter-out "~:<~1I~w~^ ~@_~w~@{ ~_~w~}~:>")) - -(defn- pprint-cond [alis] - (pprint-logical-block :prefix "(" :suffix ")" - (pprint-indent :block 1) - (write-out (first alis)) - (when (next alis) - (.Write ^System.IO.TextWriter *out* " ") - (pprint-newline :linear) - (print-length-loop [alis (next alis)] - (when alis - (pprint-logical-block alis - (write-out (first alis)) - (when (next alis) - (.Write ^System.IO.TextWriter *out* " ") - (pprint-newline :miser) - (write-out (second alis)))) - (when (next (rest alis)) - (.Write ^System.IO.TextWriter *out* " ") - (pprint-newline :linear) - (recur (next (rest alis))))))))) - -(defn- pprint-condp [alis] - (if (> (count alis) 3) - (pprint-logical-block :prefix "(" :suffix ")" - (pprint-indent :block 1) - (apply (formatter-out "~w ~@_~w ~@_~w ~_") alis) - (print-length-loop [alis (seq (drop 3 alis))] - (when alis - (pprint-logical-block alis - (write-out (first alis)) - (when (next alis) - (.Write ^System.IO.TextWriter *out* " ") - (pprint-newline :miser) - (write-out (second alis)))) - (when (next (rest alis)) - (.Write ^System.IO.TextWriter *out* " ") - (pprint-newline :linear) - (recur (next (rest alis))))))) - (pprint-simple-code-list alis))) - -;;; The map of symbols that are defined in an enclosing #() anonymous function -(def ^:dynamic ^{:private true} *symbol-map* {}) - -(defn- pprint-anon-func [alis] - (let [args (second alis) - nlis (first (rest (rest alis)))] - (if (vector? args) - (binding [*symbol-map* (if (= 1 (count args)) - {(first args) "%"} - (into {} - (map - #(vector %1 (str \% %2)) - args - (range 1 (inc (count args))))))] - ((formatter-out "~<#(~;~@{~w~^ ~_~}~;)~:>") nlis)) - (pprint-simple-code-list alis)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The master definitions for formatting lists in code (that is, (fn args...) or -;;; special forms). -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; This is the equivalent of (formatter-out "~:<~1I~@{~w~^ ~_~}~:>"), but is -;;; easier on the stack. - -(defn- pprint-simple-code-list [alis] - (pprint-logical-block :prefix "(" :suffix ")" - (pprint-indent :block 1) - (print-length-loop [alis (seq alis)] - (when alis - (write-out (first alis)) - (when (next alis) - (.Write ^System.IO.TextWriter *out* " ") - (pprint-newline :linear) - (recur (next alis))))))) - -;;; Take a map with symbols as keys and add versions with no namespace. -;;; That is, if ns/sym->val is in the map, add sym->val to the result. -(defn- two-forms [amap] - (into {} - (mapcat - identity - (for [x amap] - [x [(symbol (name (first x))) (second x)]])))) - -(defn- add-core-ns [amap] - (let [core "clojure.core"] - (into {} - (map #(let [[s f] %] - (if (not (or (namespace s) (special-symbol? s))) - [(symbol core (name s)) f] - %)) - amap)))) - -(def ^:dynamic ^{:private true} *code-table* - (two-forms - (add-core-ns - {'def pprint-hold-first, 'defonce pprint-hold-first, - 'defn pprint-defn, 'defn- pprint-defn, 'defmacro pprint-defn, 'fn pprint-defn, - 'let pprint-let, 'loop pprint-let, 'binding pprint-let, - 'with-local-vars pprint-let, 'with-open pprint-let, 'when-let pprint-let, - 'if-let pprint-let, 'doseq pprint-let, 'dotimes pprint-let, - 'when-first pprint-let, - 'if pprint-if, 'if-not pprint-if, 'when pprint-if, 'when-not pprint-if, - 'cond pprint-cond, 'condp pprint-condp, - 'fn* pprint-anon-func, - '. pprint-hold-first, '.. pprint-hold-first, '-> pprint-hold-first, - 'locking pprint-hold-first, 'struct pprint-hold-first, - 'struct-map pprint-hold-first, 'ns pprint-ns - }))) - -(defn- pprint-code-list [alis] - (if-not (pprint-reader-macro alis) - (if-let [special-form (*code-table* (first alis))] - (special-form alis) - (pprint-simple-code-list alis)))) - -(defn- pprint-code-symbol [sym] - (if-let [arg-num (sym *symbol-map*)] - (print arg-num) - (if *print-suppress-namespaces* - (print (name sym)) - (pr sym)))) - -(defmulti - code-dispatch - "The pretty print dispatch function for pretty printing Clojure code." - {:added "1.2" :arglists '[[object]]} - class) - -(use-method code-dispatch clojure.lang.ISeq pprint-code-list) -(use-method code-dispatch clojure.lang.Symbol pprint-code-symbol) - -;; The following are all exact copies of simple-dispatch -(use-method code-dispatch clojure.lang.IPersistentVector pprint-vector) -(use-method code-dispatch clojure.lang.IPersistentMap pprint-map) -(use-method code-dispatch clojure.lang.IPersistentSet pprint-set) -(use-method code-dispatch clojure.lang.PersistentQueue pprint-pqueue) -(use-method code-dispatch clojure.lang.IDeref pprint-ideref) -(use-method code-dispatch nil pr) -(use-method code-dispatch :default pprint-simple-default) - -(set-pprint-dispatch simple-dispatch) - - -;;; For testing -(comment - -(with-pprint-dispatch code-dispatch - (pprint - '(defn cl-format - "An implementation of a Common Lisp compatible format function" - [stream format-in & args] - (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) - navigator (init-navigator args)] - (execute-format stream compiled-format navigator))))) - -(with-pprint-dispatch code-dispatch - (pprint - '(defn cl-format - [stream format-in & args] - (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) - navigator (init-navigator args)] - (execute-format stream compiled-format navigator))))) - -(with-pprint-dispatch code-dispatch - (pprint - '(defn- -write - ([this x] - (condp = (class x) - String - (let [s0 (write-initial-lines this x) - s (.Replace #"\\s+$" s0 "" 1) ;;; (.replaceFirst s0 "\\s+$" "") - white-space (.Substring s0 (count s)) - mode (getf :mode)] - (if (= mode :writing) - (dosync - (write-white-space this) - (.col_write this s) - (setf :trailing-white-space white-space)) - (add-to-buffer this (make-buffer-blob s white-space)))) - - Integer - (let [c ^Char x] - (if (= (getf :mode) :writing) - (do - (write-white-space this) - (.col_write this x)) - (if (= c (int \newline)) - (write-initial-lines this "\n") - (add-to-buffer this (make-buffer-blob (str (char c)) nil)))))))))) - -(with-pprint-dispatch code-dispatch - (pprint - '(defn pprint-defn [writer alis] - (if (next alis) - (let [[defn-sym defn-name & stuff] alis - [doc-str stuff] (if (string? (first stuff)) - [(first stuff) (next stuff)] - [nil stuff]) - [attr-map stuff] (if (map? (first stuff)) - [(first stuff) (next stuff)] - [nil stuff])] - (pprint-logical-block writer :prefix "(" :suffix ")" - (cl-format true "~w ~1I~@_~w" defn-sym defn-name) - (if doc-str - (cl-format true " ~_~w" doc-str)) - (if attr-map - (cl-format true " ~_~w" attr-map)) - ;; Note: the multi-defn case will work OK for malformed defns too - (cond - (vector? (first stuff)) (single-defn stuff (or doc-str attr-map)) - :else (multi-defn stuff (or doc-str attr-map))))) - (pprint-simple-code-list writer alis))))) -) -nil - +;; dispatch.clj -- part of the pretty printer for Clojure + +; 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: Tom Faulhaber +;; April 3, 2009 + + +;; This module implements the default dispatch tables for pretty printing code and +;; data. + +(in-ns 'clojure.pprint) + +(defn- use-method + "Installs a function as a new method of multimethod associated with dispatch-value. " + [^clojure.lang.MultiFn multifn dispatch-val func] + (. multifn addMethod dispatch-val func)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Implementations of specific dispatch table entries +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Handle forms that can be "back-translated" to reader macros +;;; Not all reader macros can be dealt with this way or at all. +;;; Macros that we can't deal with at all are: +;;; ; - The comment character is absorbed by the reader and never is part of the form +;;; ` - Is fully processed at read time into a lisp expression (which will contain concats +;;; and regular quotes). +;;; ~@ - Also fully eaten by the processing of ` and can't be used outside. +;;; , - is whitespace and is lost (like all other whitespace). Formats can generate commas +;;; where they deem them useful to help readability. +;;; ^ - Adding metadata completely disappears at read time and the data appears to be +;;; completely lost. +;;; +;;; Most other syntax stuff is dealt with directly by the formats (like (), [], {}, and #{}) +;;; or directly by printing the objects using Clojure's built-in print functions (like +;;; :keyword, \char, or ""). The notable exception is #() which is special-cased. + +(def ^{:private true} reader-macros + {'quote "'", 'clojure.core/deref "@", + 'var "#'", 'clojure.core/unquote "~"}) + +(defn- pprint-reader-macro [alis] + (let [^String macro-char (reader-macros (first alis))] + (when (and macro-char (= 2 (count alis))) + (.Write ^System.IO.TextWriter *out* macro-char) + (write-out (second alis)) + true))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Dispatch for the basic data types when interpreted +;; as data (as opposed to code). +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; TODO: inline these formatter statements into funcs so that we +;;; are a little easier on the stack. (Or, do "real" compilation, a +;;; la Common Lisp) + +(declare pprint-map) + +(defn- pprint-meta [obj] + (when *print-meta* + (when-let [m (meta obj)] + (.Write ^System.IO.TextWriter *out* "^") ;;; ^java.io.Writer + (pprint-map m) + (.Write ^System.IO.TextWriter *out* " ") ;;; ^java.io.Writer + (pprint-newline :linear)))) + +;;; (def pprint-simple-list (formatter-out "~:<~@{~w~^ ~_~}~:>")) +(defn- pprint-simple-list [alis] + (pprint-meta alis) + (pprint-logical-block :prefix "(" :suffix ")" + (print-length-loop [alis (seq alis)] + (when alis + (write-out (first alis)) + (when (next alis) + (.Write ^System.IO.TextWriter *out* " ") + (pprint-newline :linear) + (recur (next alis))))))) + +(defn- pprint-list [alis] + (if-not (pprint-reader-macro alis) + (pprint-simple-list alis))) + +;;; (def pprint-vector (formatter-out "~<[~;~@{~w~^ ~_~}~;]~:>")) +(defn- pprint-vector [avec] + (pprint-meta avec) + (pprint-logical-block :prefix "[" :suffix "]" + (print-length-loop [aseq (seq avec)] + (when aseq + (write-out (first aseq)) + (when (next aseq) + (.Write ^System.IO.TextWriter *out* " ") + (pprint-newline :linear) + (recur (next aseq))))))) + +(def ^{:private true} pprint-array (formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>")) + +;;; (def pprint-map (formatter-out "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>")) +(defn- pprint-map [amap] + (pprint-meta amap) + (let [[ns lift-map] (when (not (record? amap)) + (#'clojure.core/lift-ns amap)) + amap (or lift-map amap) + prefix (if ns (str "#:" ns "{") "{")] + (pprint-logical-block :prefix prefix :suffix "}" + (print-length-loop [aseq (seq amap)] + (when aseq + (pprint-logical-block + (write-out (ffirst aseq)) + (.Write ^System.IO.TextWriter *out* " ") ;;; ^java.io.Writer + (pprint-newline :linear) + (set! *current-length* 0) ; always print both parts of the [k v] pair + (write-out (fnext (first aseq)))) + (when (next aseq) + (.Write ^System.IO.TextWriter *out* ", ") ;;; ^java.io.Writer + (pprint-newline :linear) + (recur (next aseq)))))))) + +;;; (def ^{:private true} pprint-set (formatter-out "~<#{~;~@{~w~^ ~:_~}~;}~:>")) +(defn- pprint-set [aset] + (pprint-meta aset) + (pprint-logical-block :prefix "#{" :suffix "}" + (print-length-loop [aseq (seq aset)] + (when aseq + (write-out (first aseq)) + (when (next aseq) + (.Write ^System.IO.TextWriter *out* " ") ;;; ^java.io.Writer + (pprint-newline :linear) + (recur (next aseq))))))) + +(def ^{:private true} + type-map {"core$future_call" "Future", + "core$promise" "Promise"}) + +(defn- map-ref-type + "Map ugly type names to something simpler" + [name] + (or (when-let [match (re-find #"^[^$]+\$[^$]+" name)] + (type-map match)) + name)) + +(defn- pprint-ideref [o] + (let [prefix (format "#<%s@%x%s: " + (map-ref-type (.Name (class o))) ;;; getSimpleName + (.GetHashCode ^Object o) ;;; System/identityHashCode, added type hint + (if (and (instance? clojure.lang.Agent o) + (agent-error o)) + " FAILED" + ""))] + (pprint-logical-block :prefix prefix :suffix ">" + (pprint-indent :block (-> (count prefix) (- 2) -)) + (pprint-newline :linear) + (write-out (cond + (and (future? o) (not (future-done? o))) :pending + (and (instance? clojure.lang.IPending o) (not (.isRealized ^clojure.lang.IPending o))) :not-delivered + :else @o))))) + +(def ^{:private true} pprint-pqueue (formatter-out "~<<-(~;~@{~w~^ ~_~}~;)-<~:>")) + +(defn- pprint-simple-default [obj] + (cond + (.IsArray (class obj)) (pprint-array obj) + (and *print-suppress-namespaces* (symbol? obj)) (print (name obj)) + :else (pr obj))) + + +(defmulti + simple-dispatch + "The pretty print dispatch function for simple data structure format." + {:added "1.2" :arglists '[[object]]} + class) + +(use-method simple-dispatch clojure.lang.ISeq pprint-list) +(use-method simple-dispatch clojure.lang.IPersistentVector pprint-vector) +(use-method simple-dispatch clojure.lang.IPersistentMap pprint-map) +(use-method simple-dispatch clojure.lang.IPersistentSet pprint-set) +(use-method simple-dispatch clojure.lang.PersistentQueue pprint-pqueue) +(use-method simple-dispatch clojure.lang.Var pprint-simple-default) +(use-method simple-dispatch clojure.lang.IDeref pprint-ideref) +(use-method simple-dispatch nil pr) +(use-method simple-dispatch :default pprint-simple-default) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Dispatch for the code table +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declare pprint-simple-code-list) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Format the namespace ("ns") macro. This is quite complicated because of all the +;;; different forms supported and because programmers can choose lists or vectors +;;; in various places. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- brackets + "Figure out which kind of brackets to use" + [form] + (if (vector? form) + ["[" "]"] + ["(" ")"])) + +(defn- pprint-ns-reference + "Pretty print a single reference (import, use, etc.) from a namespace decl" + [reference] + (if (sequential? reference) + (let [[start end] (brackets reference) + [keyw & args] reference] + (pprint-logical-block :prefix start :suffix end + ((formatter-out "~w~:i") keyw) + (loop [args args] + (when (seq args) + ((formatter-out " ")) + (let [arg (first args)] + (if (sequential? arg) + (let [[start end] (brackets arg)] + (pprint-logical-block :prefix start :suffix end + (if (and (= (count arg) 3) (keyword? (second arg))) + (let [[ns kw lis] arg] + ((formatter-out "~w ~w ") ns kw) + (if (sequential? lis) + ((formatter-out (if (vector? lis) + "~<[~;~@{~w~^ ~:_~}~;]~:>" + "~<(~;~@{~w~^ ~:_~}~;)~:>")) + lis) + (write-out lis))) + (apply (formatter-out "~w ~:i~@{~w~^ ~:_~}") arg))) + (when (next args) + ((formatter-out "~_")))) + (do + (write-out arg) + (when (next args) + ((formatter-out "~:_")))))) + (recur (next args)))))) + (when reference (write-out reference)))) + +(defn- pprint-ns + "The pretty print dispatch chunk for the ns macro" + [alis] + (if (next alis) + (let [[ns-sym ns-name & stuff] alis + [doc-str stuff] (if (string? (first stuff)) + [(first stuff) (next stuff)] + [nil stuff]) + [attr-map references] (if (map? (first stuff)) + [(first stuff) (next stuff)] + [nil stuff])] + (pprint-logical-block :prefix "(" :suffix ")" + ((formatter-out "~w ~1I~@_~w") ns-sym ns-name) + (when (or doc-str attr-map (seq references)) + ((formatter-out "~@:_"))) + (when doc-str + (cl-format true "\"~a\"~:[~;~:@_~]" doc-str (or attr-map (seq references)))) + (when attr-map + ((formatter-out "~w~:[~;~:@_~]") attr-map (seq references))) + (loop [references references] + (pprint-ns-reference (first references)) + (when-let [references (next references)] + (pprint-newline :linear) + (recur references))))) + (write-out alis))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Format something that looks like a simple def (sans metadata, since the reader +;;; won't give it to us now). +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def ^{:private true} pprint-hold-first (formatter-out "~:<~w~^ ~@_~w~^ ~_~@{~w~^ ~_~}~:>")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Format something that looks like a defn or defmacro +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Format the params and body of a defn with a single arity +(defn- single-defn [alis has-doc-str?] + (if (seq alis) + (do + (if has-doc-str? + ((formatter-out " ~_")) + ((formatter-out " ~@_"))) + ((formatter-out "~{~w~^ ~_~}") alis)))) + +;;; Format the param and body sublists of a defn with multiple arities +(defn- multi-defn [alis has-doc-str?] + (if (seq alis) + ((formatter-out " ~_~{~w~^ ~_~}") alis))) + +;;; TODO: figure out how to support capturing metadata in defns (we might need a +;;; special reader) +(defn- pprint-defn [alis] + (if (next alis) + (let [[defn-sym defn-name & stuff] alis + [doc-str stuff] (if (string? (first stuff)) + [(first stuff) (next stuff)] + [nil stuff]) + [attr-map stuff] (if (map? (first stuff)) + [(first stuff) (next stuff)] + [nil stuff])] + (pprint-logical-block :prefix "(" :suffix ")" + ((formatter-out "~w ~1I~@_~w") defn-sym defn-name) + (if doc-str + ((formatter-out " ~_~w") doc-str)) + (if attr-map + ((formatter-out " ~_~w") attr-map)) + ;; Note: the multi-defn case will work OK for malformed defns too + (cond + (vector? (first stuff)) (single-defn stuff (or doc-str attr-map)) + :else (multi-defn stuff (or doc-str attr-map))))) + (pprint-simple-code-list alis))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Format something with a binding form +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- pprint-binding-form [binding-vec] + (pprint-logical-block :prefix "[" :suffix "]" + (print-length-loop [binding binding-vec] + (when (seq binding) + (pprint-logical-block binding + (write-out (first binding)) + (when (next binding) + (.Write ^System.IO.TextWriter *out* " ") + (pprint-newline :miser) + (write-out (second binding)))) + (when (next (rest binding)) + (.Write ^System.IO.TextWriter *out* " ") + (pprint-newline :linear) + (recur (next (rest binding)))))))) + +(defn- pprint-let [alis] + (let [base-sym (first alis)] + (pprint-logical-block :prefix "(" :suffix ")" + (if (and (next alis) (vector? (second alis))) + (do + ((formatter-out "~w ~1I~@_") base-sym) + (pprint-binding-form (second alis)) + ((formatter-out " ~_~{~w~^ ~_~}") (next (rest alis)))) + (pprint-simple-code-list alis))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Format something that looks like "if" +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def ^{:private true} pprint-if (formatter-out "~:<~1I~w~^ ~@_~w~@{ ~_~w~}~:>")) + +(defn- pprint-cond [alis] + (pprint-logical-block :prefix "(" :suffix ")" + (pprint-indent :block 1) + (write-out (first alis)) + (when (next alis) + (.Write ^System.IO.TextWriter *out* " ") + (pprint-newline :linear) + (print-length-loop [alis (next alis)] + (when alis + (pprint-logical-block alis + (write-out (first alis)) + (when (next alis) + (.Write ^System.IO.TextWriter *out* " ") + (pprint-newline :miser) + (write-out (second alis)))) + (when (next (rest alis)) + (.Write ^System.IO.TextWriter *out* " ") + (pprint-newline :linear) + (recur (next (rest alis))))))))) + +(defn- pprint-condp [alis] + (if (> (count alis) 3) + (pprint-logical-block :prefix "(" :suffix ")" + (pprint-indent :block 1) + (apply (formatter-out "~w ~@_~w ~@_~w ~_") alis) + (print-length-loop [alis (seq (drop 3 alis))] + (when alis + (pprint-logical-block alis + (write-out (first alis)) + (when (next alis) + (.Write ^System.IO.TextWriter *out* " ") + (pprint-newline :miser) + (write-out (second alis)))) + (when (next (rest alis)) + (.Write ^System.IO.TextWriter *out* " ") + (pprint-newline :linear) + (recur (next (rest alis))))))) + (pprint-simple-code-list alis))) + +;;; The map of symbols that are defined in an enclosing #() anonymous function +(def ^:dynamic ^{:private true} *symbol-map* {}) + +(defn- pprint-anon-func [alis] + (let [args (second alis) + nlis (first (rest (rest alis)))] + (if (vector? args) + (binding [*symbol-map* (if (= 1 (count args)) + {(first args) "%"} + (into {} + (map + #(vector %1 (str \% %2)) + args + (range 1 (inc (count args))))))] + ((formatter-out "~<#(~;~@{~w~^ ~_~}~;)~:>") nlis)) + (pprint-simple-code-list alis)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The master definitions for formatting lists in code (that is, (fn args...) or +;;; special forms). +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This is the equivalent of (formatter-out "~:<~1I~@{~w~^ ~_~}~:>"), but is +;;; easier on the stack. + +(defn- pprint-simple-code-list [alis] + (pprint-logical-block :prefix "(" :suffix ")" + (pprint-indent :block 1) + (print-length-loop [alis (seq alis)] + (when alis + (write-out (first alis)) + (when (next alis) + (.Write ^System.IO.TextWriter *out* " ") + (pprint-newline :linear) + (recur (next alis))))))) + +;;; Take a map with symbols as keys and add versions with no namespace. +;;; That is, if ns/sym->val is in the map, add sym->val to the result. +(defn- two-forms [amap] + (into {} + (mapcat + identity + (for [x amap] + [x [(symbol (name (first x))) (second x)]])))) + +(defn- add-core-ns [amap] + (let [core "clojure.core"] + (into {} + (map #(let [[s f] %] + (if (not (or (namespace s) (special-symbol? s))) + [(symbol core (name s)) f] + %)) + amap)))) + +(def ^:dynamic ^{:private true} *code-table* + (two-forms + (add-core-ns + {'def pprint-hold-first, 'defonce pprint-hold-first, + 'defn pprint-defn, 'defn- pprint-defn, 'defmacro pprint-defn, 'fn pprint-defn, + 'let pprint-let, 'loop pprint-let, 'binding pprint-let, + 'with-local-vars pprint-let, 'with-open pprint-let, 'when-let pprint-let, + 'if-let pprint-let, 'doseq pprint-let, 'dotimes pprint-let, + 'when-first pprint-let, + 'if pprint-if, 'if-not pprint-if, 'when pprint-if, 'when-not pprint-if, + 'cond pprint-cond, 'condp pprint-condp, + 'fn* pprint-anon-func, + '. pprint-hold-first, '.. pprint-hold-first, '-> pprint-hold-first, + 'locking pprint-hold-first, 'struct pprint-hold-first, + 'struct-map pprint-hold-first, 'ns pprint-ns + }))) + +(defn- pprint-code-list [alis] + (if-not (pprint-reader-macro alis) + (if-let [special-form (*code-table* (first alis))] + (special-form alis) + (pprint-simple-code-list alis)))) + +(defn- pprint-code-symbol [sym] + (if-let [arg-num (sym *symbol-map*)] + (print arg-num) + (if *print-suppress-namespaces* + (print (name sym)) + (pr sym)))) + +(defmulti + code-dispatch + "The pretty print dispatch function for pretty printing Clojure code." + {:added "1.2" :arglists '[[object]]} + class) + +(use-method code-dispatch clojure.lang.ISeq pprint-code-list) +(use-method code-dispatch clojure.lang.Symbol pprint-code-symbol) + +;; The following are all exact copies of simple-dispatch +(use-method code-dispatch clojure.lang.IPersistentVector pprint-vector) +(use-method code-dispatch clojure.lang.IPersistentMap pprint-map) +(use-method code-dispatch clojure.lang.IPersistentSet pprint-set) +(use-method code-dispatch clojure.lang.PersistentQueue pprint-pqueue) +(use-method code-dispatch clojure.lang.IDeref pprint-ideref) +(use-method code-dispatch nil pr) +(use-method code-dispatch :default pprint-simple-default) + +(set-pprint-dispatch simple-dispatch) + + +;;; For testing +(comment + +(with-pprint-dispatch code-dispatch + (pprint + '(defn cl-format + "An implementation of a Common Lisp compatible format function" + [stream format-in & args] + (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) + navigator (init-navigator args)] + (execute-format stream compiled-format navigator))))) + +(with-pprint-dispatch code-dispatch + (pprint + '(defn cl-format + [stream format-in & args] + (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) + navigator (init-navigator args)] + (execute-format stream compiled-format navigator))))) + +(with-pprint-dispatch code-dispatch + (pprint + '(defn- -write + ([this x] + (condp = (class x) + String + (let [s0 (write-initial-lines this x) + s (.Replace #"\\s+$" s0 "" 1) ;;; (.replaceFirst s0 "\\s+$" "") + white-space (.Substring s0 (count s)) + mode (getf :mode)] + (if (= mode :writing) + (dosync + (write-white-space this) + (.col_write this s) + (setf :trailing-white-space white-space)) + (add-to-buffer this (make-buffer-blob s white-space)))) + + Integer + (let [c ^Char x] + (if (= (getf :mode) :writing) + (do + (write-white-space this) + (.col_write this x)) + (if (= c (int \newline)) + (write-initial-lines this "\n") + (add-to-buffer this (make-buffer-blob (str (char c)) nil)))))))))) + +(with-pprint-dispatch code-dispatch + (pprint + '(defn pprint-defn [writer alis] + (if (next alis) + (let [[defn-sym defn-name & stuff] alis + [doc-str stuff] (if (string? (first stuff)) + [(first stuff) (next stuff)] + [nil stuff]) + [attr-map stuff] (if (map? (first stuff)) + [(first stuff) (next stuff)] + [nil stuff])] + (pprint-logical-block writer :prefix "(" :suffix ")" + (cl-format true "~w ~1I~@_~w" defn-sym defn-name) + (if doc-str + (cl-format true " ~_~w" doc-str)) + (if attr-map + (cl-format true " ~_~w" attr-map)) + ;; Note: the multi-defn case will work OK for malformed defns too + (cond + (vector? (first stuff)) (single-defn stuff (or doc-str attr-map)) + :else (multi-defn stuff (or doc-str attr-map))))) + (pprint-simple-code-list writer alis))))) +) +nil + diff --git a/Clojure/Clojure.Source/clojure/pprint/pprint_base.clj b/Clojure/Clojure.Source/clojure/pprint/pprint_base.clj index 4b6757e5c..16b525457 100644 --- a/Clojure/Clojure.Source/clojure/pprint/pprint_base.clj +++ b/Clojure/Clojure.Source/clojure/pprint/pprint_base.clj @@ -1,403 +1,403 @@ -;;; pprint_base.clj -- part of the pretty printer for Clojure - -; 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: Tom Faulhaber -;; April 3, 2009 - - -;; This module implements the generic pretty print functions and special variables - -(in-ns 'clojure.pprint) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Variables that control the pretty printer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; -;;; *print-length*, *print-level* and *print-dup* are defined in clojure.core -;;; TODO: use *print-dup* here (or is it supplanted by other variables?) -;;; TODO: make dispatch items like "(let..." get counted in *print-length* -;;; constructs - - -(def ^:dynamic - ^{:doc "Bind to true if you want write to use pretty printing", :added "1.2"} - *print-pretty* true) - -(defonce ^:dynamic ; If folks have added stuff here, don't overwrite - ^{:doc "The pretty print dispatch function. Use with-pprint-dispatch or set-pprint-dispatch -to modify.", - :added "1.2"} - *print-pprint-dispatch* nil) - -(def ^:dynamic - ^{:doc "Pretty printing will try to avoid anything going beyond this column. -Set it to nil to have pprint let the line be arbitrarily long. This will ignore all -non-mandatory newlines.", - :added "1.2"} - *print-right-margin* 72) - -(def ^:dynamic - ^{:doc "The column at which to enter miser style. Depending on the dispatch table, -miser style add newlines in more places to try to keep lines short allowing for further -levels of nesting.", - :added "1.2"} - *print-miser-width* 40) - -;;; TODO implement output limiting -(def ^:dynamic - ^{:private true, - :doc "Maximum number of lines to print in a pretty print instance (N.B. This is not yet used)"} - *print-lines* nil) - -;;; TODO: implement circle and shared -(def ^:dynamic - ^{:private true, - :doc "Mark circular structures (N.B. This is not yet used)"} - *print-circle* nil) - -;;; TODO: should we just use *print-dup* here? -(def ^:dynamic - ^{:private true, - :doc "Mark repeated structures rather than repeat them (N.B. This is not yet used)"} - *print-shared* nil) - -(def ^:dynamic - ^{:doc "Don't print namespaces with symbols. This is particularly useful when -pretty printing the results of macro expansions" - :added "1.2"} - *print-suppress-namespaces* nil) - -;;; TODO: support print-base and print-radix in cl-format -;;; TODO: support print-base and print-radix in rationals -(def ^:dynamic - ^{:doc "Print a radix specifier in front of integers and rationals. If *print-base* is 2, 8, -or 16, then the radix specifier used is #b, #o, or #x, respectively. Otherwise the -radix specifier is in the form #XXr where XX is the decimal value of *print-base* " - :added "1.2"} - *print-radix* nil) - -(def ^:dynamic - ^{:doc "The base to use for printing integers and rationals." - :added "1.2"} - *print-base* 10) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Internal variables that keep track of where we are in the -;; structure -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(def ^:dynamic ^{ :private true } *current-level* 0) - -(def ^:dynamic ^{ :private true } *current-length* nil) - -;; TODO: add variables for length, lines. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Support for the write function -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(declare format-simple-number) - -(def ^{:private true} orig-pr pr) - -(defn- pr-with-base [x] - (if-let [s (format-simple-number x)] - (print s) - (orig-pr x))) - -(def ^{:private true} write-option-table - {;:array *print-array* - :base 'clojure.pprint/*print-base*, - ;;:case *print-case*, - :circle 'clojure.pprint/*print-circle*, - ;;:escape *print-escape*, - ;;:gensym *print-gensym*, - :length 'clojure.core/*print-length*, - :level 'clojure.core/*print-level*, - :lines 'clojure.pprint/*print-lines*, - :miser-width 'clojure.pprint/*print-miser-width*, - :dispatch 'clojure.pprint/*print-pprint-dispatch*, - :pretty 'clojure.pprint/*print-pretty*, - :radix 'clojure.pprint/*print-radix*, - :readably 'clojure.core/*print-readably*, - :right-margin 'clojure.pprint/*print-right-margin*, - :suppress-namespaces 'clojure.pprint/*print-suppress-namespaces*}) - - -(defmacro ^{:private true} binding-map [amap & body] - (let [] - `(do - (. clojure.lang.Var (pushThreadBindings ~amap)) - (try - ~@body - (finally - (. clojure.lang.Var (popThreadBindings))))))) - -(defn- table-ize [t m] - (apply hash-map (mapcat - #(when-let [v (get t (key %))] [(find-var v) (val %)]) - m))) - -(defn- pretty-writer? - "Return true iff x is a PrettyWriter" - [x] (and (instance? clojure.lang.IDeref x) (:pretty-writer @@x))) - -(defn- make-pretty-writer - "Wrap base-writer in a PrettyWriter with the specified right-margin and miser-width" - [base-writer right-margin miser-width] - (pretty-writer base-writer right-margin miser-width)) - -(defmacro ^{:private true} with-pretty-writer [base-writer & body] - `(let [base-writer# ~base-writer - new-writer# (not (pretty-writer? base-writer#))] - (binding [*out* (if new-writer# - (make-pretty-writer base-writer# *print-right-margin* *print-miser-width*) - base-writer#)] - ~@body - (.ppflush ^PrettyFlush *out*)))) - - -;;;TODO: if pretty print is not set, don't use pr but rather something that respects *print-base*, etc. -(defn write-out - "Write an object to *out* subject to the current bindings of the printer control -variables. Use the kw-args argument to override individual variables for this call (and -any recursive calls). - -*out* must be a PrettyWriter if pretty printing is enabled. This is the responsibility -of the caller. - -This method is primarily intended for use by pretty print dispatch functions that -already know that the pretty printer will have set up their environment appropriately. -Normal library clients should use the standard \"write\" interface. " - {:added "1.2"} - [object] - (let [length-reached (and - *current-length* - *print-length* - (>= *current-length* *print-length*))] - (if-not *print-pretty* - (pr object) - (if length-reached - (print "...") - (do - (if *current-length* (set! *current-length* (inc *current-length*))) - (*print-pprint-dispatch* object)))) - length-reached)) - -(defn write - "Write an object subject to the current bindings of the printer control variables. -Use the kw-args argument to override individual variables for this call (and any -recursive calls). Returns the string result if :stream is nil or nil otherwise. - -The following keyword arguments can be passed with values: - Keyword Meaning Default value - :stream Writer for output or nil true (indicates *out*) - :base Base to use for writing rationals Current value of *print-base* - :circle* If true, mark circular structures Current value of *print-circle* - :length Maximum elements to show in sublists Current value of *print-length* - :level Maximum depth Current value of *print-level* - :lines* Maximum lines of output Current value of *print-lines* - :miser-width Width to enter miser mode Current value of *print-miser-width* - :dispatch The pretty print dispatch function Current value of *print-pprint-dispatch* - :pretty If true, do pretty printing Current value of *print-pretty* - :radix If true, prepend a radix specifier Current value of *print-radix* - :readably* If true, print readably Current value of *print-readably* - :right-margin The column for the right margin Current value of *print-right-margin* - :suppress-namespaces If true, no namespaces in symbols Current value of *print-suppress-namespaces* - - * = not yet supported -" - {:added "1.2"} - [object & kw-args] - (let [options (merge {:stream true} (apply hash-map kw-args))] - (binding-map (table-ize write-option-table options) - (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) - (let [optval (if (contains? options :stream) - (:stream options) - true) - base-writer (condp = optval - nil (System.IO.StringWriter.) ;;; java.io.StringWriter. - true *out* - optval)] - (if *print-pretty* - (with-pretty-writer base-writer - (write-out object)) - (binding [*out* base-writer] - (pr object))) - (if (nil? optval) - (.ToString ^System.IO.StringWriter base-writer))))))) ;;; toString java.io.StringWriter - - -(defn pprint - "Pretty print object to the optional output writer. If the writer is not provided, -print the object to the currently bound value of *out*." - {:added "1.2"} - ([object] (pprint object *out*)) - ([object writer] - (with-pretty-writer writer - (binding [*print-pretty* true] - (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) - (write-out object))) - (if (not (= 0 (get-column *out*))) - (prn))))) - -(defmacro pp - "A convenience macro that pretty prints the last thing output. This is -exactly equivalent to (pprint *1)." - {:added "1.2"} - [] `(pprint *1)) - -(defn set-pprint-dispatch - "Set the pretty print dispatch function to a function matching (fn [obj] ...) -where obj is the object to pretty print. That function will be called with *out* set -to a pretty printing writer to which it should do its printing. - -For example functions, see simple-dispatch and code-dispatch in -clojure.pprint.dispatch.clj." - {:added "1.2"} - [function] - (let [old-meta (meta #'*print-pprint-dispatch*)] - (alter-var-root #'*print-pprint-dispatch* (constantly function)) - (alter-meta! #'*print-pprint-dispatch* (constantly old-meta))) - nil) - -(defmacro with-pprint-dispatch - "Execute body with the pretty print dispatch function bound to function." - {:added "1.2"} - [function & body] - `(binding [*print-pprint-dispatch* ~function] - ~@body)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Support for the functional interface to the pretty printer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- parse-lb-options [opts body] - (loop [body body - acc []] - (if (opts (first body)) - (recur (drop 2 body) (concat acc (take 2 body))) - [(apply hash-map acc) body]))) - -(defn- check-enumerated-arg [arg choices] - (if-not (choices arg) - (throw - (ArgumentException. ;;; IllegalArgumentException - ;; TODO clean up choices string - (str "Bad argument: " arg ". It must be one of " choices))))) - -(defn- level-exceeded [] - (and *print-level* (>= *current-level* *print-level*))) - -(defmacro pprint-logical-block - "Execute the body as a pretty printing logical block with output to *out* which -must be a pretty printing writer. When used from pprint or cl-format, this can be -assumed. - -This function is intended for use when writing custom dispatch functions. - -Before the body, the caller can optionally specify options: :prefix, :per-line-prefix, -and :suffix." - {:added "1.2", :arglists '[[options* body]]} - [& args] - (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)] - `(do (if (#'clojure.pprint/level-exceeded) - (.Write ^System.IO.TextWriter *out* "#") - (do - (push-thread-bindings {#'clojure.pprint/*current-level* - (inc (var-get #'clojure.pprint/*current-level*)) - #'clojure.pprint/*current-length* 0}) - (try - (#'clojure.pprint/start-block *out* - ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options)) - ~@body - (#'clojure.pprint/end-block *out*) - (finally - (pop-thread-bindings))))) - nil))) - -(defn pprint-newline - "Print a conditional newline to a pretty printing stream. kind specifies if the -newline is :linear, :miser, :fill, or :mandatory. - -This function is intended for use when writing custom dispatch functions. - -Output is sent to *out* which must be a pretty printing writer." - {:added "1.2"} - [kind] - (check-enumerated-arg kind #{:linear :miser :fill :mandatory}) - (nl *out* kind)) - -(defn pprint-indent - "Create an indent at this point in the pretty printing stream. This defines how -following lines are indented. relative-to can be either :block or :current depending -whether the indent should be computed relative to the start of the logical block or -the current column position. n is an offset. - -This function is intended for use when writing custom dispatch functions. - -Output is sent to *out* which must be a pretty printing writer." - {:added "1.2"} - [relative-to n] - (check-enumerated-arg relative-to #{:block :current}) - (indent *out* relative-to n)) - -;; TODO a real implementation for pprint-tab -(defn pprint-tab - "Tab at this point in the pretty printing stream. kind specifies whether the tab -is :line, :section, :line-relative, or :section-relative. - -Colnum and colinc specify the target column and the increment to move the target -forward if the output is already past the original target. - -This function is intended for use when writing custom dispatch functions. - -Output is sent to *out* which must be a pretty printing writer. - -THIS FUNCTION IS NOT YET IMPLEMENTED." - {:added "1.2"} - [kind colnum colinc] - (check-enumerated-arg kind #{:line :section :line-relative :section-relative}) - (throw (NotImplementedException. "pprint-tab is not yet implemented"))) ;;; UnsupportedOperationException - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Helpers for dispatch function writing -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- pll-mod-body [var-sym body] - (letfn [(inner [form] - (if (seq? form) - (let [form (macroexpand form)] - (condp = (first form) - 'loop* form - 'recur (concat `(recur (inc ~var-sym)) (rest form)) - (walk inner identity form))) - form))] - (walk inner identity body))) - -(defmacro print-length-loop - "A version of loop that iterates at most *print-length* times. This is designed -for use in pretty-printer dispatch functions." - {:added "1.3"} - [bindings & body] - (let [count-var (gensym "length-count") - mod-body (pll-mod-body count-var body)] - `(loop ~(apply vector count-var 0 bindings) - (if (or (not *print-length*) (< ~count-var *print-length*)) - (do ~@mod-body) - (.Write ^System.IO.TextWriter *out* "..."))))) ;;;; .write ^java.io.Writer - -nil +;;; pprint_base.clj -- part of the pretty printer for Clojure + +; 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: Tom Faulhaber +;; April 3, 2009 + + +;; This module implements the generic pretty print functions and special variables + +(in-ns 'clojure.pprint) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Variables that control the pretty printer +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; +;;; *print-length*, *print-level* and *print-dup* are defined in clojure.core +;;; TODO: use *print-dup* here (or is it supplanted by other variables?) +;;; TODO: make dispatch items like "(let..." get counted in *print-length* +;;; constructs + + +(def ^:dynamic + ^{:doc "Bind to true if you want write to use pretty printing", :added "1.2"} + *print-pretty* true) + +(defonce ^:dynamic ; If folks have added stuff here, don't overwrite + ^{:doc "The pretty print dispatch function. Use with-pprint-dispatch or set-pprint-dispatch +to modify.", + :added "1.2"} + *print-pprint-dispatch* nil) + +(def ^:dynamic + ^{:doc "Pretty printing will try to avoid anything going beyond this column. +Set it to nil to have pprint let the line be arbitrarily long. This will ignore all +non-mandatory newlines.", + :added "1.2"} + *print-right-margin* 72) + +(def ^:dynamic + ^{:doc "The column at which to enter miser style. Depending on the dispatch table, +miser style add newlines in more places to try to keep lines short allowing for further +levels of nesting.", + :added "1.2"} + *print-miser-width* 40) + +;;; TODO implement output limiting +(def ^:dynamic + ^{:private true, + :doc "Maximum number of lines to print in a pretty print instance (N.B. This is not yet used)"} + *print-lines* nil) + +;;; TODO: implement circle and shared +(def ^:dynamic + ^{:private true, + :doc "Mark circular structures (N.B. This is not yet used)"} + *print-circle* nil) + +;;; TODO: should we just use *print-dup* here? +(def ^:dynamic + ^{:private true, + :doc "Mark repeated structures rather than repeat them (N.B. This is not yet used)"} + *print-shared* nil) + +(def ^:dynamic + ^{:doc "Don't print namespaces with symbols. This is particularly useful when +pretty printing the results of macro expansions" + :added "1.2"} + *print-suppress-namespaces* nil) + +;;; TODO: support print-base and print-radix in cl-format +;;; TODO: support print-base and print-radix in rationals +(def ^:dynamic + ^{:doc "Print a radix specifier in front of integers and rationals. If *print-base* is 2, 8, +or 16, then the radix specifier used is #b, #o, or #x, respectively. Otherwise the +radix specifier is in the form #XXr where XX is the decimal value of *print-base* " + :added "1.2"} + *print-radix* nil) + +(def ^:dynamic + ^{:doc "The base to use for printing integers and rationals." + :added "1.2"} + *print-base* 10) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Internal variables that keep track of where we are in the +;; structure +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def ^:dynamic ^{ :private true } *current-level* 0) + +(def ^:dynamic ^{ :private true } *current-length* nil) + +;; TODO: add variables for length, lines. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Support for the write function +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declare format-simple-number) + +(def ^{:private true} orig-pr pr) + +(defn- pr-with-base [x] + (if-let [s (format-simple-number x)] + (print s) + (orig-pr x))) + +(def ^{:private true} write-option-table + {;:array *print-array* + :base 'clojure.pprint/*print-base*, + ;;:case *print-case*, + :circle 'clojure.pprint/*print-circle*, + ;;:escape *print-escape*, + ;;:gensym *print-gensym*, + :length 'clojure.core/*print-length*, + :level 'clojure.core/*print-level*, + :lines 'clojure.pprint/*print-lines*, + :miser-width 'clojure.pprint/*print-miser-width*, + :dispatch 'clojure.pprint/*print-pprint-dispatch*, + :pretty 'clojure.pprint/*print-pretty*, + :radix 'clojure.pprint/*print-radix*, + :readably 'clojure.core/*print-readably*, + :right-margin 'clojure.pprint/*print-right-margin*, + :suppress-namespaces 'clojure.pprint/*print-suppress-namespaces*}) + + +(defmacro ^{:private true} binding-map [amap & body] + (let [] + `(do + (. clojure.lang.Var (pushThreadBindings ~amap)) + (try + ~@body + (finally + (. clojure.lang.Var (popThreadBindings))))))) + +(defn- table-ize [t m] + (apply hash-map (mapcat + #(when-let [v (get t (key %))] [(find-var v) (val %)]) + m))) + +(defn- pretty-writer? + "Return true iff x is a PrettyWriter" + [x] (and (instance? clojure.lang.IDeref x) (:pretty-writer @@x))) + +(defn- make-pretty-writer + "Wrap base-writer in a PrettyWriter with the specified right-margin and miser-width" + [base-writer right-margin miser-width] + (pretty-writer base-writer right-margin miser-width)) + +(defmacro ^{:private true} with-pretty-writer [base-writer & body] + `(let [base-writer# ~base-writer + new-writer# (not (pretty-writer? base-writer#))] + (binding [*out* (if new-writer# + (make-pretty-writer base-writer# *print-right-margin* *print-miser-width*) + base-writer#)] + ~@body + (.ppflush ^PrettyFlush *out*)))) + + +;;;TODO: if pretty print is not set, don't use pr but rather something that respects *print-base*, etc. +(defn write-out + "Write an object to *out* subject to the current bindings of the printer control +variables. Use the kw-args argument to override individual variables for this call (and +any recursive calls). + +*out* must be a PrettyWriter if pretty printing is enabled. This is the responsibility +of the caller. + +This method is primarily intended for use by pretty print dispatch functions that +already know that the pretty printer will have set up their environment appropriately. +Normal library clients should use the standard \"write\" interface. " + {:added "1.2"} + [object] + (let [length-reached (and + *current-length* + *print-length* + (>= *current-length* *print-length*))] + (if-not *print-pretty* + (pr object) + (if length-reached + (print "...") + (do + (if *current-length* (set! *current-length* (inc *current-length*))) + (*print-pprint-dispatch* object)))) + length-reached)) + +(defn write + "Write an object subject to the current bindings of the printer control variables. +Use the kw-args argument to override individual variables for this call (and any +recursive calls). Returns the string result if :stream is nil or nil otherwise. + +The following keyword arguments can be passed with values: + Keyword Meaning Default value + :stream Writer for output or nil true (indicates *out*) + :base Base to use for writing rationals Current value of *print-base* + :circle* If true, mark circular structures Current value of *print-circle* + :length Maximum elements to show in sublists Current value of *print-length* + :level Maximum depth Current value of *print-level* + :lines* Maximum lines of output Current value of *print-lines* + :miser-width Width to enter miser mode Current value of *print-miser-width* + :dispatch The pretty print dispatch function Current value of *print-pprint-dispatch* + :pretty If true, do pretty printing Current value of *print-pretty* + :radix If true, prepend a radix specifier Current value of *print-radix* + :readably* If true, print readably Current value of *print-readably* + :right-margin The column for the right margin Current value of *print-right-margin* + :suppress-namespaces If true, no namespaces in symbols Current value of *print-suppress-namespaces* + + * = not yet supported +" + {:added "1.2"} + [object & kw-args] + (let [options (merge {:stream true} (apply hash-map kw-args))] + (binding-map (table-ize write-option-table options) + (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) + (let [optval (if (contains? options :stream) + (:stream options) + true) + base-writer (condp = optval + nil (System.IO.StringWriter.) ;;; java.io.StringWriter. + true *out* + optval)] + (if *print-pretty* + (with-pretty-writer base-writer + (write-out object)) + (binding [*out* base-writer] + (pr object))) + (if (nil? optval) + (.ToString ^System.IO.StringWriter base-writer))))))) ;;; toString java.io.StringWriter + + +(defn pprint + "Pretty print object to the optional output writer. If the writer is not provided, +print the object to the currently bound value of *out*." + {:added "1.2"} + ([object] (pprint object *out*)) + ([object writer] + (with-pretty-writer writer + (binding [*print-pretty* true] + (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) + (write-out object))) + (if (not (= 0 (get-column *out*))) + (prn))))) + +(defmacro pp + "A convenience macro that pretty prints the last thing output. This is +exactly equivalent to (pprint *1)." + {:added "1.2"} + [] `(pprint *1)) + +(defn set-pprint-dispatch + "Set the pretty print dispatch function to a function matching (fn [obj] ...) +where obj is the object to pretty print. That function will be called with *out* set +to a pretty printing writer to which it should do its printing. + +For example functions, see simple-dispatch and code-dispatch in +clojure.pprint.dispatch.clj." + {:added "1.2"} + [function] + (let [old-meta (meta #'*print-pprint-dispatch*)] + (alter-var-root #'*print-pprint-dispatch* (constantly function)) + (alter-meta! #'*print-pprint-dispatch* (constantly old-meta))) + nil) + +(defmacro with-pprint-dispatch + "Execute body with the pretty print dispatch function bound to function." + {:added "1.2"} + [function & body] + `(binding [*print-pprint-dispatch* ~function] + ~@body)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Support for the functional interface to the pretty printer +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- parse-lb-options [opts body] + (loop [body body + acc []] + (if (opts (first body)) + (recur (drop 2 body) (concat acc (take 2 body))) + [(apply hash-map acc) body]))) + +(defn- check-enumerated-arg [arg choices] + (if-not (choices arg) + (throw + (ArgumentException. ;;; IllegalArgumentException + ;; TODO clean up choices string + (str "Bad argument: " arg ". It must be one of " choices))))) + +(defn- level-exceeded [] + (and *print-level* (>= *current-level* *print-level*))) + +(defmacro pprint-logical-block + "Execute the body as a pretty printing logical block with output to *out* which +must be a pretty printing writer. When used from pprint or cl-format, this can be +assumed. + +This function is intended for use when writing custom dispatch functions. + +Before the body, the caller can optionally specify options: :prefix, :per-line-prefix, +and :suffix." + {:added "1.2", :arglists '[[options* body]]} + [& args] + (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)] + `(do (if (#'clojure.pprint/level-exceeded) + (.Write ^System.IO.TextWriter *out* "#") + (do + (push-thread-bindings {#'clojure.pprint/*current-level* + (inc (var-get #'clojure.pprint/*current-level*)) + #'clojure.pprint/*current-length* 0}) + (try + (#'clojure.pprint/start-block *out* + ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options)) + ~@body + (#'clojure.pprint/end-block *out*) + (finally + (pop-thread-bindings))))) + nil))) + +(defn pprint-newline + "Print a conditional newline to a pretty printing stream. kind specifies if the +newline is :linear, :miser, :fill, or :mandatory. + +This function is intended for use when writing custom dispatch functions. + +Output is sent to *out* which must be a pretty printing writer." + {:added "1.2"} + [kind] + (check-enumerated-arg kind #{:linear :miser :fill :mandatory}) + (nl *out* kind)) + +(defn pprint-indent + "Create an indent at this point in the pretty printing stream. This defines how +following lines are indented. relative-to can be either :block or :current depending +whether the indent should be computed relative to the start of the logical block or +the current column position. n is an offset. + +This function is intended for use when writing custom dispatch functions. + +Output is sent to *out* which must be a pretty printing writer." + {:added "1.2"} + [relative-to n] + (check-enumerated-arg relative-to #{:block :current}) + (indent *out* relative-to n)) + +;; TODO a real implementation for pprint-tab +(defn pprint-tab + "Tab at this point in the pretty printing stream. kind specifies whether the tab +is :line, :section, :line-relative, or :section-relative. + +Colnum and colinc specify the target column and the increment to move the target +forward if the output is already past the original target. + +This function is intended for use when writing custom dispatch functions. + +Output is sent to *out* which must be a pretty printing writer. + +THIS FUNCTION IS NOT YET IMPLEMENTED." + {:added "1.2"} + [kind colnum colinc] + (check-enumerated-arg kind #{:line :section :line-relative :section-relative}) + (throw (NotImplementedException. "pprint-tab is not yet implemented"))) ;;; UnsupportedOperationException + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Helpers for dispatch function writing +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- pll-mod-body [var-sym body] + (letfn [(inner [form] + (if (seq? form) + (let [form (macroexpand form)] + (condp = (first form) + 'loop* form + 'recur (concat `(recur (inc ~var-sym)) (rest form)) + (walk inner identity form))) + form))] + (walk inner identity body))) + +(defmacro print-length-loop + "A version of loop that iterates at most *print-length* times. This is designed +for use in pretty-printer dispatch functions." + {:added "1.3"} + [bindings & body] + (let [count-var (gensym "length-count") + mod-body (pll-mod-body count-var body)] + `(loop ~(apply vector count-var 0 bindings) + (if (or (not *print-length*) (< ~count-var *print-length*)) + (do ~@mod-body) + (.Write ^System.IO.TextWriter *out* "..."))))) ;;;; .write ^java.io.Writer + +nil diff --git a/Clojure/Clojure.Source/clojure/pprint/pretty_writer.clj b/Clojure/Clojure.Source/clojure/pprint/pretty_writer.clj index 01030fb4e..3682f2485 100644 --- a/Clojure/Clojure.Source/clojure/pprint/pretty_writer.clj +++ b/Clojure/Clojure.Source/clojure/pprint/pretty_writer.clj @@ -1,506 +1,506 @@ -;;; pretty_writer.clj -- part of the pretty printer for Clojure - -; 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: Tom Faulhaber -;; April 3, 2009 -;; Revised to use proxy instead of gen-class April 2010 - -;; This module implements a wrapper around a java.io.Writer which implements the -;; core of the XP algorithm. - -(in-ns 'clojure.pprint) - -(import [clojure.lang IDeref] - [System.IO TextWriter]) ;;; java.io Writer - -;; TODO: Support for tab directives - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Forward declarations -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(declare get-miser-width) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Macros to simplify dealing with types and classes. These are -;;; really utilities, but I'm experimenting with them here. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro ^{:private true} - getf - "Get the value of the field named by the argument (which should be a keyword)." - [sym] - `(~sym @@~'this)) - -(defmacro ^{:private true} - setf - "Set the value of the field SYM to NEW-VAL" - [sym new-val] - `(alter @~'this assoc ~sym ~new-val)) - -(defmacro ^{:private true} - deftype [type-name & fields] - (let [name-str (name type-name)] - `(do - (defstruct ~type-name :type-tag ~@fields) - (alter-meta! #'~type-name assoc :private true) - (defn- ~(symbol (str "make-" name-str)) - [& vals#] (apply struct ~type-name ~(keyword name-str) vals#)) - (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str)))))) - -(defmacro ^{:private true} - write-to-base - "Call .write on Writer (getf :base) with proper type-hinting to - avoid reflection." - [& args] - `(let [^TextWriter w# (getf :base)] - (.Write w# ~@args))) ;;; .write - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The data structures used by pretty-writer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defstruct ^{:private true} logical-block - :parent :section :start-col :indent - :done-nl :intra-block-nl - :prefix :per-line-prefix :suffix - :logical-block-callback) - -(defn- ancestor? [parent child] - (loop [child (:parent child)] - (cond - (nil? child) false - (identical? parent child) true - :else (recur (:parent child))))) - -(defstruct ^{:private true} section :parent) - -(defn- buffer-length [l] - (let [l (seq l)] - (if l - (- (:end-pos (last l)) (:start-pos (first l))) - 0))) - -; A blob of characters (aka a string) -(deftype buffer-blob :data :trailing-white-space :start-pos :end-pos) - -; A newline -(deftype nl-t :type :logical-block :start-pos :end-pos) - -(deftype start-block-t :logical-block :start-pos :end-pos) - -(deftype end-block-t :logical-block :start-pos :end-pos) - -(deftype indent-t :logical-block :relative-to :offset :start-pos :end-pos) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Functions to write tokens in the output buffer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(def ^:private pp-newline (memoize #(Environment/NewLine))) ;;; (System/getProperty "line.separator") - -(declare emit-nl) - -(defmulti ^{:private true} write-token #(:type-tag %2)) -(defmethod write-token :start-block-t [^TextWriter this token] - (when-let [cb (getf :logical-block-callback)] (cb :start)) - (let [lb (:logical-block token)] - (dosync - (when-let [^String prefix (:prefix lb)] - (write-to-base prefix)) - (let [col (get-column (getf :base))] - (ref-set (:start-col lb) col) - (ref-set (:indent lb) col))))) - -(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-to-base suffix))) - -(defmethod write-token :indent-t [^TextWriter this token] - (let [lb (:logical-block token)] - (ref-set (:indent lb) - (+ (:offset token) - (condp = (:relative-to token) - :block @(:start-col lb) - :current (get-column (getf :base))))))) - -(defmethod write-token :buffer-blob [^TextWriter this token] - (write-to-base ^String (:data token))) - -(defmethod write-token :nl-t [^TextWriter this token] -; (prlabel wt @(:done-nl (:logical-block token))) -; (prlabel wt (:type token) (= (:type token) :mandatory)) - (if (or (= (:type token) :mandatory) - (and (not (= (:type token) :fill)) - @(:done-nl (:logical-block token)))) - (emit-nl this token) - (if-let [^String tws (getf :trailing-white-space)] - (write-to-base 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-to-base 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-to-base tws) - (setf :trailing-white-space nil)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; emit-nl? method defs for each type of new line. This makes -;;; the decision about whether to print this type of new line. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defn- tokens-fit? [^TextWriter this tokens] -;;; (prlabel tf? (get-column (getf :base) (buffer-length tokens)) - (let [maxcol (get-max-column (getf :base))] - (or - (nil? maxcol) - (< (+ (get-column (getf :base)) (buffer-length tokens)) maxcol)))) - -(defn- linear-nl? [this lb section] -; (prlabel lnl? @(:done-nl lb) (tokens-fit? this section)) - (or @(:done-nl lb) - (not (tokens-fit? this section)))) - -(defn- miser-nl? [^TextWriter this lb section] - (let [miser-width (get-miser-width this) - maxcol (get-max-column (getf :base))] - (and miser-width maxcol - (>= @(:start-col lb) (- maxcol miser-width)) - (linear-nl? this lb section)))) - -(defmulti ^{:private true} emit-nl? (fn [t _ _ _] (:type t))) - -(defmethod emit-nl? :linear [newl this section _] - (let [lb (:logical-block newl)] - (linear-nl? this lb section))) - -(defmethod emit-nl? :miser [newl this section _] - (let [lb (:logical-block newl)] - (miser-nl? this lb section))) - -(defmethod emit-nl? :fill [newl this section subsection] - (let [lb (:logical-block newl)] - (or @(:intra-block-nl lb) - (not (tokens-fit? this subsection)) - (miser-nl? this lb section)))) - -(defmethod emit-nl? :mandatory [_ _ _ _] - true) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Various support functions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defn- get-section [buffer] - (let [nl (first buffer) - lb (:logical-block nl) - section (seq (take-while #(not (and (nl-t? %) (ancestor? (:logical-block %) lb))) - (next buffer)))] - [section (seq (drop (inc (count section)) buffer))])) - -(defn- get-sub-section [buffer] - (let [nl (first buffer) - lb (:logical-block nl) - section (seq (take-while #(let [nl-lb (:logical-block %)] - (not (and (nl-t? %) (or (= nl-lb lb) (ancestor? nl-lb lb))))) - (next buffer)))] - section)) - -(defn- update-nl-state [lb] - (dosync - (ref-set (:intra-block-nl lb) false) - (ref-set (:done-nl lb) true) - (loop [lb (:parent lb)] - (if lb - (do (ref-set (:done-nl lb) true) - (ref-set (:intra-block-nl lb) true) - (recur (:parent lb))))))) - -(defn- emit-nl [^TextWriter this nl] - (write-to-base ^String (pp-newline)) - (dosync (setf :trailing-white-space nil)) - (let [lb (:logical-block nl) - ^String prefix (:per-line-prefix lb)] - (if prefix - (write-to-base prefix)) - (let [^String istr (apply str (repeat (- @(:indent lb) (count prefix)) - \space))] - (write-to-base istr)) - (update-nl-state lb))) - -(defn- split-at-newline [tokens] - (let [pre (seq (take-while #(not (nl-t? %)) tokens))] - [pre (seq (drop (count pre) tokens))])) - -;;; Methods for showing token strings for debugging - -(defmulti ^{:private true} tok :type-tag) -(defmethod tok :nl-t [token] - (:type token)) -(defmethod tok :buffer-blob [token] - (str \" (:data token) (:trailing-white-space token) \")) -(defmethod tok :default [token] - (:type-tag token)) -(defn- toks [toks] (map tok toks)) - -;;; write-token-string is called when the set of tokens in the buffer -;;; is longer than the available space on the line - -(defn- write-token-string [this tokens] - (let [[a b] (split-at-newline tokens)] -;; (prlabel wts (toks a) (toks b)) - (if a (write-tokens this a false)) - (if b - (let [[section remainder] (get-section b) - newl (first b)] -;; (prlabel wts (toks section)) (prlabel wts (:type newl)) (prlabel wts (toks remainder)) - (let [do-nl (emit-nl? newl this section (get-sub-section b)) - result (if do-nl - (do -;; (prlabel emit-nl (:type newl)) - (emit-nl this newl) - (next b)) - b) - long-section (not (tokens-fit? this result)) - result (if long-section - (let [rem2 (write-token-string this section)] -;;; (prlabel recurse (toks rem2)) - (if (= rem2 section) - (do ; If that didn't produce any output, it has no nls - ; so we'll force it - (write-tokens this section false) - remainder) - (into [] (concat rem2 remainder)))) - result) -;; ff (prlabel wts (toks result)) - ] - result))))) - -(defn- write-line [^TextWriter this] - (dosync - (loop [buffer (getf :buffer)] -;; (prlabel wl1 (toks buffer)) - (setf :buffer (into [] buffer)) - (if (not (tokens-fit? this buffer)) - (let [new-buffer (write-token-string this buffer)] -;; (prlabel wl new-buffer) - (if-not (identical? buffer new-buffer) - (recur new-buffer))))))) - -;;; Add a buffer token to the buffer and see if it's time to start -;;; writing -(defn- add-to-buffer [^TextWriter this token] -; (prlabel a2b token) - (dosync - (setf :buffer (conj (getf :buffer) token)) - (if (not (tokens-fit? this (getf :buffer))) - (write-line this)))) - -;;; Write all the tokens that have been buffered -(defn- write-buffered-output [^TextWriter this] - (write-line this) - (if-let [buf (getf :buffer)] - (do - (write-tokens this buf true) - (setf :buffer [])))) - -(defn- write-white-space [^TextWriter this] - (when-let [^String tws (getf :trailing-white-space)] - ; (prlabel wws (str "*" tws "*")) - (write-to-base tws) - (dosync - (setf :trailing-white-space nil)))) - -;;; If there are newlines in the string, print the lines up until the last newline, -;;; 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) - (if (= (count lines) 1) - s - (dosync - (let [^String prefix (:per-line-prefix (first (getf :logical-blocks))) - ^String l (first lines)] - (if (= :buffering (getf :mode)) - (let [oldpos (getf :pos) - newpos (+ oldpos (count l))] - (setf :pos newpos) - (add-to-buffer this (make-buffer-blob l nil oldpos newpos)) - (write-buffered-output this)) - (do - (write-white-space this) - (write-to-base l))) - (write-to-base (int \newline)) - (doseq [^String l (next (butlast lines))] - (write-to-base l) - (write-to-base ^String (pp-newline)) - (if prefix - (write-to-base 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 - (write-white-space this) - (write-to-base c)) - (if (= c \newline) - (write-initial-lines this "\n") - (let [oldpos (getf :pos) - newpos (inc oldpos)] - (dosync - (setf :pos newpos) - (add-to-buffer this (make-buffer-blob (str (char c)) nil oldpos newpos))))))) ) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Initialize the pretty-writer instance -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defn- pretty-writer [writer max-columns miser-width] - (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false)) - fields (ref {:pretty-writer true - :base (column-writer writer max-columns) - :logical-blocks lb - :sections nil - :mode :writing - :buffer [] - :buffer-block lb - :buffer-level 1 - :miser-width miser-width - :trailing-white-space nil - :pos 0})] - (proxy [TextWriter IDeref PrettyFlush] [] - (deref [] fields) - - (Write - ([x] - ;; (prlabel write x (getf :mode)) - (condp = (class x) - String - (let [^String s0 (write-initial-lines this x) - ^String s (.Replace #"\s+$" s0 "" 1) ;;; (.replaceFirst s0 "\\s+$" "") - white-space (.Substring s0 (count s)) - mode (getf :mode)] - (dosync - (if (= mode :writing) - (do - (write-white-space this) - (write-to-base 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)))))) +;;; pretty_writer.clj -- part of the pretty printer for Clojure + +; 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: Tom Faulhaber +;; April 3, 2009 +;; Revised to use proxy instead of gen-class April 2010 + +;; This module implements a wrapper around a java.io.Writer which implements the +;; core of the XP algorithm. + +(in-ns 'clojure.pprint) + +(import [clojure.lang IDeref] + [System.IO TextWriter]) ;;; java.io Writer + +;; TODO: Support for tab directives + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Forward declarations +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declare get-miser-width) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Macros to simplify dealing with types and classes. These are +;;; really utilities, but I'm experimenting with them here. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro ^{:private true} + getf + "Get the value of the field named by the argument (which should be a keyword)." + [sym] + `(~sym @@~'this)) + +(defmacro ^{:private true} + setf + "Set the value of the field SYM to NEW-VAL" + [sym new-val] + `(alter @~'this assoc ~sym ~new-val)) + +(defmacro ^{:private true} + deftype [type-name & fields] + (let [name-str (name type-name)] + `(do + (defstruct ~type-name :type-tag ~@fields) + (alter-meta! #'~type-name assoc :private true) + (defn- ~(symbol (str "make-" name-str)) + [& vals#] (apply struct ~type-name ~(keyword name-str) vals#)) + (defn- ~(symbol (str name-str "?")) [x#] (= (:type-tag x#) ~(keyword name-str)))))) + +(defmacro ^{:private true} + write-to-base + "Call .write on Writer (getf :base) with proper type-hinting to + avoid reflection." + [& args] + `(let [^TextWriter w# (getf :base)] + (.Write w# ~@args))) ;;; .write + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The data structures used by pretty-writer +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct ^{:private true} logical-block + :parent :section :start-col :indent + :done-nl :intra-block-nl + :prefix :per-line-prefix :suffix + :logical-block-callback) + +(defn- ancestor? [parent child] + (loop [child (:parent child)] + (cond + (nil? child) false + (identical? parent child) true + :else (recur (:parent child))))) + +(defstruct ^{:private true} section :parent) + +(defn- buffer-length [l] + (let [l (seq l)] + (if l + (- (:end-pos (last l)) (:start-pos (first l))) + 0))) + +; A blob of characters (aka a string) +(deftype buffer-blob :data :trailing-white-space :start-pos :end-pos) + +; A newline +(deftype nl-t :type :logical-block :start-pos :end-pos) + +(deftype start-block-t :logical-block :start-pos :end-pos) + +(deftype end-block-t :logical-block :start-pos :end-pos) + +(deftype indent-t :logical-block :relative-to :offset :start-pos :end-pos) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Functions to write tokens in the output buffer +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def ^:private pp-newline (memoize #(Environment/NewLine))) ;;; (System/getProperty "line.separator") + +(declare emit-nl) + +(defmulti ^{:private true} write-token #(:type-tag %2)) +(defmethod write-token :start-block-t [^TextWriter this token] + (when-let [cb (getf :logical-block-callback)] (cb :start)) + (let [lb (:logical-block token)] + (dosync + (when-let [^String prefix (:prefix lb)] + (write-to-base prefix)) + (let [col (get-column (getf :base))] + (ref-set (:start-col lb) col) + (ref-set (:indent lb) col))))) + +(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-to-base suffix))) + +(defmethod write-token :indent-t [^TextWriter this token] + (let [lb (:logical-block token)] + (ref-set (:indent lb) + (+ (:offset token) + (condp = (:relative-to token) + :block @(:start-col lb) + :current (get-column (getf :base))))))) + +(defmethod write-token :buffer-blob [^TextWriter this token] + (write-to-base ^String (:data token))) + +(defmethod write-token :nl-t [^TextWriter this token] +; (prlabel wt @(:done-nl (:logical-block token))) +; (prlabel wt (:type token) (= (:type token) :mandatory)) + (if (or (= (:type token) :mandatory) + (and (not (= (:type token) :fill)) + @(:done-nl (:logical-block token)))) + (emit-nl this token) + (if-let [^String tws (getf :trailing-white-space)] + (write-to-base 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-to-base 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-to-base tws) + (setf :trailing-white-space nil)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; emit-nl? method defs for each type of new line. This makes +;;; the decision about whether to print this type of new line. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defn- tokens-fit? [^TextWriter this tokens] +;;; (prlabel tf? (get-column (getf :base) (buffer-length tokens)) + (let [maxcol (get-max-column (getf :base))] + (or + (nil? maxcol) + (< (+ (get-column (getf :base)) (buffer-length tokens)) maxcol)))) + +(defn- linear-nl? [this lb section] +; (prlabel lnl? @(:done-nl lb) (tokens-fit? this section)) + (or @(:done-nl lb) + (not (tokens-fit? this section)))) + +(defn- miser-nl? [^TextWriter this lb section] + (let [miser-width (get-miser-width this) + maxcol (get-max-column (getf :base))] + (and miser-width maxcol + (>= @(:start-col lb) (- maxcol miser-width)) + (linear-nl? this lb section)))) + +(defmulti ^{:private true} emit-nl? (fn [t _ _ _] (:type t))) + +(defmethod emit-nl? :linear [newl this section _] + (let [lb (:logical-block newl)] + (linear-nl? this lb section))) + +(defmethod emit-nl? :miser [newl this section _] + (let [lb (:logical-block newl)] + (miser-nl? this lb section))) + +(defmethod emit-nl? :fill [newl this section subsection] + (let [lb (:logical-block newl)] + (or @(:intra-block-nl lb) + (not (tokens-fit? this subsection)) + (miser-nl? this lb section)))) + +(defmethod emit-nl? :mandatory [_ _ _ _] + true) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Various support functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defn- get-section [buffer] + (let [nl (first buffer) + lb (:logical-block nl) + section (seq (take-while #(not (and (nl-t? %) (ancestor? (:logical-block %) lb))) + (next buffer)))] + [section (seq (drop (inc (count section)) buffer))])) + +(defn- get-sub-section [buffer] + (let [nl (first buffer) + lb (:logical-block nl) + section (seq (take-while #(let [nl-lb (:logical-block %)] + (not (and (nl-t? %) (or (= nl-lb lb) (ancestor? nl-lb lb))))) + (next buffer)))] + section)) + +(defn- update-nl-state [lb] + (dosync + (ref-set (:intra-block-nl lb) false) + (ref-set (:done-nl lb) true) + (loop [lb (:parent lb)] + (if lb + (do (ref-set (:done-nl lb) true) + (ref-set (:intra-block-nl lb) true) + (recur (:parent lb))))))) + +(defn- emit-nl [^TextWriter this nl] + (write-to-base ^String (pp-newline)) + (dosync (setf :trailing-white-space nil)) + (let [lb (:logical-block nl) + ^String prefix (:per-line-prefix lb)] + (if prefix + (write-to-base prefix)) + (let [^String istr (apply str (repeat (- @(:indent lb) (count prefix)) + \space))] + (write-to-base istr)) + (update-nl-state lb))) + +(defn- split-at-newline [tokens] + (let [pre (seq (take-while #(not (nl-t? %)) tokens))] + [pre (seq (drop (count pre) tokens))])) + +;;; Methods for showing token strings for debugging + +(defmulti ^{:private true} tok :type-tag) +(defmethod tok :nl-t [token] + (:type token)) +(defmethod tok :buffer-blob [token] + (str \" (:data token) (:trailing-white-space token) \")) +(defmethod tok :default [token] + (:type-tag token)) +(defn- toks [toks] (map tok toks)) + +;;; write-token-string is called when the set of tokens in the buffer +;;; is longer than the available space on the line + +(defn- write-token-string [this tokens] + (let [[a b] (split-at-newline tokens)] +;; (prlabel wts (toks a) (toks b)) + (if a (write-tokens this a false)) + (if b + (let [[section remainder] (get-section b) + newl (first b)] +;; (prlabel wts (toks section)) (prlabel wts (:type newl)) (prlabel wts (toks remainder)) + (let [do-nl (emit-nl? newl this section (get-sub-section b)) + result (if do-nl + (do +;; (prlabel emit-nl (:type newl)) + (emit-nl this newl) + (next b)) + b) + long-section (not (tokens-fit? this result)) + result (if long-section + (let [rem2 (write-token-string this section)] +;;; (prlabel recurse (toks rem2)) + (if (= rem2 section) + (do ; If that didn't produce any output, it has no nls + ; so we'll force it + (write-tokens this section false) + remainder) + (into [] (concat rem2 remainder)))) + result) +;; ff (prlabel wts (toks result)) + ] + result))))) + +(defn- write-line [^TextWriter this] + (dosync + (loop [buffer (getf :buffer)] +;; (prlabel wl1 (toks buffer)) + (setf :buffer (into [] buffer)) + (if (not (tokens-fit? this buffer)) + (let [new-buffer (write-token-string this buffer)] +;; (prlabel wl new-buffer) + (if-not (identical? buffer new-buffer) + (recur new-buffer))))))) + +;;; Add a buffer token to the buffer and see if it's time to start +;;; writing +(defn- add-to-buffer [^TextWriter this token] +; (prlabel a2b token) + (dosync + (setf :buffer (conj (getf :buffer) token)) + (if (not (tokens-fit? this (getf :buffer))) + (write-line this)))) + +;;; Write all the tokens that have been buffered +(defn- write-buffered-output [^TextWriter this] + (write-line this) + (if-let [buf (getf :buffer)] + (do + (write-tokens this buf true) + (setf :buffer [])))) + +(defn- write-white-space [^TextWriter this] + (when-let [^String tws (getf :trailing-white-space)] + ; (prlabel wws (str "*" tws "*")) + (write-to-base tws) + (dosync + (setf :trailing-white-space nil)))) + +;;; If there are newlines in the string, print the lines up until the last newline, +;;; 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) + (if (= (count lines) 1) + s + (dosync + (let [^String prefix (:per-line-prefix (first (getf :logical-blocks))) + ^String l (first lines)] + (if (= :buffering (getf :mode)) + (let [oldpos (getf :pos) + newpos (+ oldpos (count l))] + (setf :pos newpos) + (add-to-buffer this (make-buffer-blob l nil oldpos newpos)) + (write-buffered-output this)) + (do + (write-white-space this) + (write-to-base l))) + (write-to-base (int \newline)) + (doseq [^String l (next (butlast lines))] + (write-to-base l) + (write-to-base ^String (pp-newline)) + (if prefix + (write-to-base 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 + (write-white-space this) + (write-to-base c)) + (if (= c \newline) + (write-initial-lines this "\n") + (let [oldpos (getf :pos) + newpos (inc oldpos)] + (dosync + (setf :pos newpos) + (add-to-buffer this (make-buffer-blob (str (char c)) nil oldpos newpos))))))) ) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Initialize the pretty-writer instance +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defn- pretty-writer [writer max-columns miser-width] + (let [lb (struct logical-block nil nil (ref 0) (ref 0) (ref false) (ref false)) + fields (ref {:pretty-writer true + :base (column-writer writer max-columns) + :logical-blocks lb + :sections nil + :mode :writing + :buffer [] + :buffer-block lb + :buffer-level 1 + :miser-width miser-width + :trailing-white-space nil + :pos 0})] + (proxy [TextWriter IDeref PrettyFlush] [] + (deref [] fields) + + (Write + ([x] + ;; (prlabel write x (getf :mode)) + (condp = (class x) + String + (let [^String s0 (write-initial-lines this x) + ^String s (.Replace #"\s+$" s0 "" 1) ;;; (.replaceFirst s0 "\\s+$" "") + white-space (.Substring s0 (count s)) + mode (getf :mode)] + (dosync + (if (= mode :writing) + (do + (write-white-space this) + (write-to-base 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)) - Int32 - (p-write-char this x) - Int64 - (p-write-char this x))) - ([x off len] - (.Write ^TextWriter this (subs (str x) off (+ off len))))) ;;; Added type hint - - (ppflush [] - (if (= (getf :mode) :buffering) - (dosync - (write-tokens this (getf :buffer) true) - (setf :buffer [])) - (write-white-space this))) - (Flush [] ;; flush - (.ppflush ^PrettyFlush this) - (let [^TextWriter w (getf :base)] - (.Flush w))) ;;; .flush - - (Close [] - (.Flush ^TextWriter this))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Methods for pretty-writer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- start-block - [^TextWriter this - ^String prefix ^String per-line-prefix ^String suffix] - (dosync - (let [lb (struct logical-block (getf :logical-blocks) nil (ref 0) (ref 0) - (ref false) (ref false) - prefix per-line-prefix suffix)] - (setf :logical-blocks lb) - (if (= (getf :mode) :writing) - (do - (write-white-space this) - (when-let [cb (getf :logical-block-callback)] (cb :start)) - (if prefix - (write-to-base prefix)) - (let [col (get-column (getf :base))] - (ref-set (:start-col lb) col) - (ref-set (:indent lb) col))) - (let [oldpos (getf :pos) - newpos (+ oldpos (if prefix (count prefix) 0))] - (setf :pos newpos) - (add-to-buffer this (make-start-block-t lb oldpos newpos))))))) - -(defn- end-block [^TextWriter this] - (dosync - (let [lb (getf :logical-blocks) - ^String suffix (:suffix lb)] - (if (= (getf :mode) :writing) - (do - (write-white-space this) - (if suffix - (write-to-base suffix)) - (when-let [cb (getf :logical-block-callback)] (cb :end))) - (let [oldpos (getf :pos) - newpos (+ oldpos (if suffix (count suffix) 0))] - (setf :pos newpos) - (add-to-buffer this (make-end-block-t lb oldpos newpos)))) - (setf :logical-blocks (:parent lb))))) - -(defn- nl [^TextWriter this type] - (dosync - (setf :mode :buffering) - (let [pos (getf :pos)] - (add-to-buffer this (make-nl-t type (getf :logical-blocks) pos pos))))) - -(defn- indent [^TextWriter this relative-to offset] - (dosync - (let [lb (getf :logical-blocks)] - (if (= (getf :mode) :writing) - (do - (write-white-space this) - (ref-set (:indent lb) - (+ offset (condp = relative-to - :block @(:start-col lb) - :current (get-column (getf :base)))))) - (let [pos (getf :pos)] - (add-to-buffer this (make-indent-t lb relative-to offset pos pos))))))) - -(defn- get-miser-width [^TextWriter this] - (getf :miser-width)) - -(defn- set-miser-width [^TextWriter this new-miser-width] - (dosync (setf :miser-width new-miser-width))) - -(defn- set-logical-block-callback [^TextWriter this f] - (dosync (setf :logical-block-callback f))) + Int32 + (p-write-char this x) + Int64 + (p-write-char this x))) + ([x off len] + (.Write ^TextWriter this (subs (str x) off (+ off len))))) ;;; Added type hint + + (ppflush [] + (if (= (getf :mode) :buffering) + (dosync + (write-tokens this (getf :buffer) true) + (setf :buffer [])) + (write-white-space this))) + (Flush [] ;; flush + (.ppflush ^PrettyFlush this) + (let [^TextWriter w (getf :base)] + (.Flush w))) ;;; .flush + + (Close [] + (.Flush ^TextWriter this))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Methods for pretty-writer +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- start-block + [^TextWriter this + ^String prefix ^String per-line-prefix ^String suffix] + (dosync + (let [lb (struct logical-block (getf :logical-blocks) nil (ref 0) (ref 0) + (ref false) (ref false) + prefix per-line-prefix suffix)] + (setf :logical-blocks lb) + (if (= (getf :mode) :writing) + (do + (write-white-space this) + (when-let [cb (getf :logical-block-callback)] (cb :start)) + (if prefix + (write-to-base prefix)) + (let [col (get-column (getf :base))] + (ref-set (:start-col lb) col) + (ref-set (:indent lb) col))) + (let [oldpos (getf :pos) + newpos (+ oldpos (if prefix (count prefix) 0))] + (setf :pos newpos) + (add-to-buffer this (make-start-block-t lb oldpos newpos))))))) + +(defn- end-block [^TextWriter this] + (dosync + (let [lb (getf :logical-blocks) + ^String suffix (:suffix lb)] + (if (= (getf :mode) :writing) + (do + (write-white-space this) + (if suffix + (write-to-base suffix)) + (when-let [cb (getf :logical-block-callback)] (cb :end))) + (let [oldpos (getf :pos) + newpos (+ oldpos (if suffix (count suffix) 0))] + (setf :pos newpos) + (add-to-buffer this (make-end-block-t lb oldpos newpos)))) + (setf :logical-blocks (:parent lb))))) + +(defn- nl [^TextWriter this type] + (dosync + (setf :mode :buffering) + (let [pos (getf :pos)] + (add-to-buffer this (make-nl-t type (getf :logical-blocks) pos pos))))) + +(defn- indent [^TextWriter this relative-to offset] + (dosync + (let [lb (getf :logical-blocks)] + (if (= (getf :mode) :writing) + (do + (write-white-space this) + (ref-set (:indent lb) + (+ offset (condp = relative-to + :block @(:start-col lb) + :current (get-column (getf :base)))))) + (let [pos (getf :pos)] + (add-to-buffer this (make-indent-t lb relative-to offset pos pos))))))) + +(defn- get-miser-width [^TextWriter this] + (getf :miser-width)) + +(defn- set-miser-width [^TextWriter this new-miser-width] + (dosync (setf :miser-width new-miser-width))) + +(defn- set-logical-block-callback [^TextWriter this f] + (dosync (setf :logical-block-callback f))) diff --git a/Clojure/Clojure.Source/clojure/pprint/utilities.clj b/Clojure/Clojure.Source/clojure/pprint/utilities.clj index 9a7c122e2..d60b98e8b 100644 --- a/Clojure/Clojure.Source/clojure/pprint/utilities.clj +++ b/Clojure/Clojure.Source/clojure/pprint/utilities.clj @@ -1,114 +1,114 @@ -;;; utilities.clj -- part of the pretty printer for Clojure - -; 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: Tom Faulhaber -;; April 3, 2009 - -;; This module implements some utility function used in formatting and pretty -;; printing. The functions here could go in a more general purpose library, -;; perhaps. - -(in-ns 'clojure.pprint) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Helper functions for digesting formats in the various -;;; phases of their lives. -;;; These functions are actually pretty general. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defn- map-passing-context [func initial-context lis] - (loop [context initial-context - lis lis - acc []] - (if (empty? lis) - [acc context] - (let [this (first lis) - remainder (next lis) - [result new-context] (apply func [this context])] - (recur new-context remainder (conj acc result)))))) - -(defn- consume [func initial-context] - (loop [context initial-context - acc []] - (let [[result new-context] (apply func [context])] - (if (not result) - [acc new-context] - (recur new-context (conj acc result)))))) - -(defn- consume-while [func initial-context] - (loop [context initial-context - acc []] - (let [[result continue new-context] (apply func [context])] - (if (not continue) - [acc context] - (recur new-context (conj acc result)))))) - -(defn- unzip-map - "Take a map that has pairs in the value slots and produce a pair of maps, - the first having all the first elements of the pairs and the second all - the second elements of the pairs" - [m] - [(into {} (for [[k [v1 v2]] m] [k v1])) - (into {} (for [[k [v1 v2]] m] [k v2]))]) - -(defn- tuple-map - "For all the values, v, in the map, replace them with [v v1]" - [m v1] - (into {} (for [[k v] m] [k [v v1]]))) - -(defn- rtrim - "Trim all instances of c from the end of sequence s" - [s c] - (let [len (count s)] - (if (and (pos? len) (= (nth s (dec (count s))) c)) - (loop [n (dec len)] - (cond - (neg? n) "" - (not (= (nth s n) c)) (subs s 0 (inc n)) - true (recur (dec n)))) - s))) - -(defn- ltrim - "Trim all instances of c from the beginning of sequence s" - [s c] - (let [len (count s)] - (if (and (pos? len) (= (nth s 0) c)) - (loop [n 0] - (if (or (= n len) (not (= (nth s n) c))) - (subs s n) - (recur (inc n)))) - s))) - -(defn- prefix-count - "Return the number of times that val occurs at the start of sequence aseq, -if val is a seq itself, count the number of times any element of val occurs at the -beginning of aseq" - [aseq val] - (let [test (if (coll? val) (set val) #{val})] - (loop [pos 0] - (if (or (= pos (count aseq)) (not (test (nth aseq pos)))) - pos - (recur (inc pos)))))) - -(defn- prerr - "Println to *err*" - [& args] - (binding [*out* *err*] - (apply println args))) - -(defmacro ^{:private true} prlabel - "Print args to *err* in name = value format" - [prefix arg & more-args] - `(prerr ~@(cons (list 'quote prefix) (mapcat #(list (list 'quote %) "=" %) - (cons arg (seq more-args)))))) - -;; Flush the pretty-print buffer without flushing the underlying stream -(definterface PrettyFlush +;;; utilities.clj -- part of the pretty printer for Clojure + +; 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: Tom Faulhaber +;; April 3, 2009 + +;; This module implements some utility function used in formatting and pretty +;; printing. The functions here could go in a more general purpose library, +;; perhaps. + +(in-ns 'clojure.pprint) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Helper functions for digesting formats in the various +;;; phases of their lives. +;;; These functions are actually pretty general. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- map-passing-context [func initial-context lis] + (loop [context initial-context + lis lis + acc []] + (if (empty? lis) + [acc context] + (let [this (first lis) + remainder (next lis) + [result new-context] (apply func [this context])] + (recur new-context remainder (conj acc result)))))) + +(defn- consume [func initial-context] + (loop [context initial-context + acc []] + (let [[result new-context] (apply func [context])] + (if (not result) + [acc new-context] + (recur new-context (conj acc result)))))) + +(defn- consume-while [func initial-context] + (loop [context initial-context + acc []] + (let [[result continue new-context] (apply func [context])] + (if (not continue) + [acc context] + (recur new-context (conj acc result)))))) + +(defn- unzip-map + "Take a map that has pairs in the value slots and produce a pair of maps, + the first having all the first elements of the pairs and the second all + the second elements of the pairs" + [m] + [(into {} (for [[k [v1 v2]] m] [k v1])) + (into {} (for [[k [v1 v2]] m] [k v2]))]) + +(defn- tuple-map + "For all the values, v, in the map, replace them with [v v1]" + [m v1] + (into {} (for [[k v] m] [k [v v1]]))) + +(defn- rtrim + "Trim all instances of c from the end of sequence s" + [s c] + (let [len (count s)] + (if (and (pos? len) (= (nth s (dec (count s))) c)) + (loop [n (dec len)] + (cond + (neg? n) "" + (not (= (nth s n) c)) (subs s 0 (inc n)) + true (recur (dec n)))) + s))) + +(defn- ltrim + "Trim all instances of c from the beginning of sequence s" + [s c] + (let [len (count s)] + (if (and (pos? len) (= (nth s 0) c)) + (loop [n 0] + (if (or (= n len) (not (= (nth s n) c))) + (subs s n) + (recur (inc n)))) + s))) + +(defn- prefix-count + "Return the number of times that val occurs at the start of sequence aseq, +if val is a seq itself, count the number of times any element of val occurs at the +beginning of aseq" + [aseq val] + (let [test (if (coll? val) (set val) #{val})] + (loop [pos 0] + (if (or (= pos (count aseq)) (not (test (nth aseq pos)))) + pos + (recur (inc pos)))))) + +(defn- prerr + "Println to *err*" + [& args] + (binding [*out* *err*] + (apply println args))) + +(defmacro ^{:private true} prlabel + "Print args to *err* in name = value format" + [prefix arg & more-args] + `(prerr ~@(cons (list 'quote prefix) (mapcat #(list (list 'quote %) "=" %) + (cons arg (seq more-args)))))) + +;; Flush the pretty-print buffer without flushing the underlying stream +(definterface PrettyFlush (^void ppflush [])) \ No newline at end of file diff --git a/Clojure/Clojure.Source/clojure/reflect/clr.clj b/Clojure/Clojure.Source/clojure/reflect/clr.clj index a9e8d353d..a005e54c3 100644 --- a/Clojure/Clojure.Source/clojure/reflect/clr.clj +++ b/Clojure/Clojure.Source/clojure/reflect/clr.clj @@ -1,238 +1,238 @@ -; 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. - -;; Java-specific parts of clojure.reflect -(in-ns 'clojure.reflect) - -(require '[clojure.datafy :refer (datafy)] - '[clojure.set :as set] - '[clojure.string :as str]) - -(import '[System.Reflection TypeAttributes MethodAttributes FieldAttributes PropertyAttributes BindingFlags]) - -;(import '[clojure.asm ClassReader ClassVisitor Type] -; '[java.lang.reflect Modifier] -; java.io.InputStream) - -(set! *warn-on-reflection* true) - -(extend-protocol TypeReference - clojure.lang.Symbol - (typename [s] (str s)) ;;; (str/replace (str s) "<>" "[]")) -- we keep them as-is - - Type - (typename - [t] - (or (.FullName t) (.Name t)))) - -(defn- typesym - "Given a typeref, create a legal Clojure symbol version of the - type's name." - [t] - (cond-> - (-> (typename t) - ;;;(str/replace "[]" "<>") - (symbol)) - (class? t) (with-meta {'clojure.core.protocols/datafy - (fn [_] (datafy t))}))) - - -(def class-flags - [ [:public TypeAttributes/VisibilityMask TypeAttributes/Public] - [:nested-public TypeAttributes/VisibilityMask TypeAttributes/NestedPublic] - [:nested-private TypeAttributes/VisibilityMask TypeAttributes/NestedPrivate] - [:nested-family TypeAttributes/VisibilityMask TypeAttributes/NestedFamily] - [:nested-assembly TypeAttributes/VisibilityMask TypeAttributes/NestedAssembly] - [:nested-famandassem TypeAttributes/VisibilityMask TypeAttributes/NestedFamANDAssem] - [:nested-famorassem TypeAttributes/VisibilityMask TypeAttributes/NestedFamORAssem] - [:auto-layout TypeAttributes/LayoutMask TypeAttributes/AutoLayout] - [:sequential-layout TypeAttributes/LayoutMask TypeAttributes/SequentialLayout] - [:explicit-layout TypeAttributes/LayoutMask TypeAttributes/ExplicitLayout] - [:class TypeAttributes/ClassSemanticsMask TypeAttributes/Class] - [:interface TypeAttributes/ClassSemanticsMask TypeAttributes/Interface] - [:abstract TypeAttributes/Abstract TypeAttributes/Abstract] - [:sealed TypeAttributes/Sealed TypeAttributes/Sealed] - [:special-name TypeAttributes/SpecialName TypeAttributes/SpecialName] - [:import TypeAttributes/Import TypeAttributes/Import] - [:serializable TypeAttributes/Serializable TypeAttributes/Serializable] - [:ansi-class TypeAttributes/StringFormatMask TypeAttributes/AnsiClass] - [:unicode-class TypeAttributes/StringFormatMask TypeAttributes/UnicodeClass] - [:auto-class TypeAttributes/StringFormatMask TypeAttributes/AutoClass] - [:before-field-init TypeAttributes/BeforeFieldInit TypeAttributes/BeforeFieldInit] - [:rt-special-name TypeAttributes/ReservedMask TypeAttributes/RTSpecialName] - [:has-security TypeAttributes/ReservedMask TypeAttributes/HasSecurity] - ]) - -(def method-flags - [[:privatescope MethodAttributes/MemberAccessMask MethodAttributes/PrivateScope] - [:private MethodAttributes/MemberAccessMask MethodAttributes/Private] - [:famandassem MethodAttributes/MemberAccessMask MethodAttributes/FamANDAssem] - [:assembly MethodAttributes/MemberAccessMask MethodAttributes/Assembly] - [:family MethodAttributes/MemberAccessMask MethodAttributes/Family] - [:famorassem MethodAttributes/MemberAccessMask MethodAttributes/FamORAssem] - [:public MethodAttributes/MemberAccessMask MethodAttributes/Public] - [:static MethodAttributes/Static MethodAttributes/Static] - [:final MethodAttributes/Final MethodAttributes/Final] - [:virtual MethodAttributes/Virtual MethodAttributes/Virtual] - [:hide-by-sig MethodAttributes/HideBySig MethodAttributes/HideBySig] - [:reuse-slot MethodAttributes/VtableLayoutMask MethodAttributes/ReuseSlot] - [:new-slot MethodAttributes/VtableLayoutMask MethodAttributes/NewSlot] - [:abstract MethodAttributes/Abstract MethodAttributes/Abstract] - [:special-name MethodAttributes/SpecialName MethodAttributes/SpecialName] - [:pinvoke-impl MethodAttributes/PinvokeImpl MethodAttributes/PinvokeImpl] - [:unmanaged-export MethodAttributes/UnmanagedExport MethodAttributes/UnmanagedExport] - [:rt-special-name MethodAttributes/ReservedMask MethodAttributes/RTSpecialName] - [:has-security MethodAttributes/ReservedMask MethodAttributes/HasSecurity] - [:require-sec-object MethodAttributes/ReservedMask MethodAttributes/RequireSecObject] - ]) - -(def field-flags - [[:privatescope FieldAttributes/FieldAccessMask FieldAttributes/PrivateScope] - [:private FieldAttributes/FieldAccessMask FieldAttributes/Private] - [:famandassem FieldAttributes/FieldAccessMask FieldAttributes/FamANDAssem] - [:assembly FieldAttributes/FieldAccessMask FieldAttributes/Assembly] - [:family FieldAttributes/FieldAccessMask FieldAttributes/Family] - [:famorassem FieldAttributes/FieldAccessMask FieldAttributes/FamORAssem] - [:public FieldAttributes/FieldAccessMask FieldAttributes/Public] - [:static FieldAttributes/Static FieldAttributes/Static] - [:init-only FieldAttributes/InitOnly FieldAttributes/InitOnly] - [:literal FieldAttributes/Literal FieldAttributes/Literal] - [:not-serialized FieldAttributes/NotSerialized FieldAttributes/NotSerialized] - [:special-name FieldAttributes/SpecialName FieldAttributes/SpecialName] - [:pinvoke-impl FieldAttributes/PinvokeImpl FieldAttributes/PinvokeImpl] - [:rt-special-name FieldAttributes/ReservedMask FieldAttributes/RTSpecialName] - [:has-field-marshal FieldAttributes/ReservedMask FieldAttributes/HasFieldMarshal] - [:has-default FieldAttributes/ReservedMask FieldAttributes/HasDefault] - [:has-field-rva FieldAttributes/ReservedMask FieldAttributes/HasFieldRVA] - ]) - - (def property-flags - [[:special-name PropertyAttributes/SpecialName PropertyAttributes/SpecialName] - [:rt-special-name PropertyAttributes/ReservedMask PropertyAttributes/RTSpecialName] - [:has-default PropertyAttributes/ReservedMask PropertyAttributes/HasDefault] - ]) - - - -(defn- parse-attributes - "Convert attributes into a set of keywords" - [attributes flags] - (reduce - (fn [result fd] - (if (== (enum-and attributes (nth fd 1)) (nth fd 2)) - (conj result (nth fd 0)) - result)) - #{} - flags)) - -(defn- parameter->info [^System.Reflection.ParameterInfo p] - (let [ t (.ParameterType p) ] - (if (.IsByRef t) - (list :by-ref (typesym t)) - (typesym t)))) - -(defrecord Constructor - [name declaring-class parameter-types flags]) - -(defn- constructor->map - [^System.Reflection.ConstructorInfo constructor] - (Constructor. - (symbol (.Name constructor)) - (typesym (.DeclaringType constructor)) - (vec (map parameter->info (.GetParameters constructor))) - (parse-attributes (.Attributes constructor) method-flags))) - -(def ^:private basic-binding-flags - (enum-or BindingFlags/Public BindingFlags/NonPublic BindingFlags/DeclaredOnly BindingFlags/Instance BindingFlags/Static)) - -(defn- declared-constructors - "Return a set of the declared constructors of class as a Clojure map." - [cls] - (set (map - constructor->map - (.GetConstructors ^Type (cast Type cls) basic-binding-flags)))) - -(defrecord Method - [name return-type declaring-class parameter-types flags]) - -(defn- method->map - [^System.Reflection.MethodInfo method] - (Method. - (symbol (.Name method)) - (typesym (.ReturnType method)) - (typesym (.DeclaringType method)) - (vec (map parameter->info (.GetParameters method))) - (parse-attributes (.Attributes method) method-flags))) - -(defn- declared-methods - "Return a set of the declared constructors of class as a Clojure map." - [cls] - (set (map - method->map - (.GetMethods ^Type (cast Type cls) basic-binding-flags)))) - -(defrecord Field - [name type declaring-class flags]) - -(defn- field->map - [^System.Reflection.FieldInfo field] - (Field. - (symbol (.Name field)) - (typesym (.FieldType field)) - (typesym (.DeclaringType field)) - (parse-attributes (.Attributes field) field-flags))) - -(defn- declared-fields - "Return a set of the declared fields of class as a Clojure map." - [cls] - (set (map - field->map - (.GetFields ^Type (cast Type cls) basic-binding-flags)))) - -(defrecord Property - [name type declaring-class flags]) - -(defn- property->map - [^System.Reflection.PropertyInfo property] - (Property. - (symbol (.Name property)) - (typesym (.PropertyType property)) - (typesym (.DeclaringType property)) - (let [property-attributes (parse-attributes (.Attributes property) property-flags) - getter (.GetGetMethod property true) - method-attributes (when getter (parse-attributes (.Attributes getter) method-flags))] - (set/union property-attributes method-attributes)))) - - -(defn- declared-properties - "Return a set of the declared fields of class as a Clojure map." - [cls] - (set (map - property->map - (.GetProperties ^Type (cast Type cls) basic-binding-flags)))) - -(defn- typeref->class - ^Type [typeref ] ;;; classloader arg removed ^Class - (if (class? typeref) - typeref - (clojure.lang.RT/classForName (typename typeref)))) ;;; false classloader - - -(deftype ClrReflector [a] - Reflector - (do-reflect [_ typeref] - (let [cls (typeref->class typeref)] ;;; classloader arg - {:bases (not-empty (set (map typesym (bases cls)))) - :flags (parse-attributes (.Attributes cls) class-flags) - :members (set/union (declared-fields cls) - (declared-properties cls) - (declared-methods cls) - (declared-constructors cls))}))) - -(def ^:private default-reflector - (ClrReflector. nil)) +; 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. + +;; Java-specific parts of clojure.reflect +(in-ns 'clojure.reflect) + +(require '[clojure.datafy :refer (datafy)] + '[clojure.set :as set] + '[clojure.string :as str]) + +(import '[System.Reflection TypeAttributes MethodAttributes FieldAttributes PropertyAttributes BindingFlags]) + +;(import '[clojure.asm ClassReader ClassVisitor Type] +; '[java.lang.reflect Modifier] +; java.io.InputStream) + +(set! *warn-on-reflection* true) + +(extend-protocol TypeReference + clojure.lang.Symbol + (typename [s] (str s)) ;;; (str/replace (str s) "<>" "[]")) -- we keep them as-is + + Type + (typename + [t] + (or (.FullName t) (.Name t)))) + +(defn- typesym + "Given a typeref, create a legal Clojure symbol version of the + type's name." + [t] + (cond-> + (-> (typename t) + ;;;(str/replace "[]" "<>") + (symbol)) + (class? t) (with-meta {'clojure.core.protocols/datafy + (fn [_] (datafy t))}))) + + +(def class-flags + [ [:public TypeAttributes/VisibilityMask TypeAttributes/Public] + [:nested-public TypeAttributes/VisibilityMask TypeAttributes/NestedPublic] + [:nested-private TypeAttributes/VisibilityMask TypeAttributes/NestedPrivate] + [:nested-family TypeAttributes/VisibilityMask TypeAttributes/NestedFamily] + [:nested-assembly TypeAttributes/VisibilityMask TypeAttributes/NestedAssembly] + [:nested-famandassem TypeAttributes/VisibilityMask TypeAttributes/NestedFamANDAssem] + [:nested-famorassem TypeAttributes/VisibilityMask TypeAttributes/NestedFamORAssem] + [:auto-layout TypeAttributes/LayoutMask TypeAttributes/AutoLayout] + [:sequential-layout TypeAttributes/LayoutMask TypeAttributes/SequentialLayout] + [:explicit-layout TypeAttributes/LayoutMask TypeAttributes/ExplicitLayout] + [:class TypeAttributes/ClassSemanticsMask TypeAttributes/Class] + [:interface TypeAttributes/ClassSemanticsMask TypeAttributes/Interface] + [:abstract TypeAttributes/Abstract TypeAttributes/Abstract] + [:sealed TypeAttributes/Sealed TypeAttributes/Sealed] + [:special-name TypeAttributes/SpecialName TypeAttributes/SpecialName] + [:import TypeAttributes/Import TypeAttributes/Import] + [:serializable TypeAttributes/Serializable TypeAttributes/Serializable] + [:ansi-class TypeAttributes/StringFormatMask TypeAttributes/AnsiClass] + [:unicode-class TypeAttributes/StringFormatMask TypeAttributes/UnicodeClass] + [:auto-class TypeAttributes/StringFormatMask TypeAttributes/AutoClass] + [:before-field-init TypeAttributes/BeforeFieldInit TypeAttributes/BeforeFieldInit] + [:rt-special-name TypeAttributes/ReservedMask TypeAttributes/RTSpecialName] + [:has-security TypeAttributes/ReservedMask TypeAttributes/HasSecurity] + ]) + +(def method-flags + [[:privatescope MethodAttributes/MemberAccessMask MethodAttributes/PrivateScope] + [:private MethodAttributes/MemberAccessMask MethodAttributes/Private] + [:famandassem MethodAttributes/MemberAccessMask MethodAttributes/FamANDAssem] + [:assembly MethodAttributes/MemberAccessMask MethodAttributes/Assembly] + [:family MethodAttributes/MemberAccessMask MethodAttributes/Family] + [:famorassem MethodAttributes/MemberAccessMask MethodAttributes/FamORAssem] + [:public MethodAttributes/MemberAccessMask MethodAttributes/Public] + [:static MethodAttributes/Static MethodAttributes/Static] + [:final MethodAttributes/Final MethodAttributes/Final] + [:virtual MethodAttributes/Virtual MethodAttributes/Virtual] + [:hide-by-sig MethodAttributes/HideBySig MethodAttributes/HideBySig] + [:reuse-slot MethodAttributes/VtableLayoutMask MethodAttributes/ReuseSlot] + [:new-slot MethodAttributes/VtableLayoutMask MethodAttributes/NewSlot] + [:abstract MethodAttributes/Abstract MethodAttributes/Abstract] + [:special-name MethodAttributes/SpecialName MethodAttributes/SpecialName] + [:pinvoke-impl MethodAttributes/PinvokeImpl MethodAttributes/PinvokeImpl] + [:unmanaged-export MethodAttributes/UnmanagedExport MethodAttributes/UnmanagedExport] + [:rt-special-name MethodAttributes/ReservedMask MethodAttributes/RTSpecialName] + [:has-security MethodAttributes/ReservedMask MethodAttributes/HasSecurity] + [:require-sec-object MethodAttributes/ReservedMask MethodAttributes/RequireSecObject] + ]) + +(def field-flags + [[:privatescope FieldAttributes/FieldAccessMask FieldAttributes/PrivateScope] + [:private FieldAttributes/FieldAccessMask FieldAttributes/Private] + [:famandassem FieldAttributes/FieldAccessMask FieldAttributes/FamANDAssem] + [:assembly FieldAttributes/FieldAccessMask FieldAttributes/Assembly] + [:family FieldAttributes/FieldAccessMask FieldAttributes/Family] + [:famorassem FieldAttributes/FieldAccessMask FieldAttributes/FamORAssem] + [:public FieldAttributes/FieldAccessMask FieldAttributes/Public] + [:static FieldAttributes/Static FieldAttributes/Static] + [:init-only FieldAttributes/InitOnly FieldAttributes/InitOnly] + [:literal FieldAttributes/Literal FieldAttributes/Literal] + [:not-serialized FieldAttributes/NotSerialized FieldAttributes/NotSerialized] + [:special-name FieldAttributes/SpecialName FieldAttributes/SpecialName] + [:pinvoke-impl FieldAttributes/PinvokeImpl FieldAttributes/PinvokeImpl] + [:rt-special-name FieldAttributes/ReservedMask FieldAttributes/RTSpecialName] + [:has-field-marshal FieldAttributes/ReservedMask FieldAttributes/HasFieldMarshal] + [:has-default FieldAttributes/ReservedMask FieldAttributes/HasDefault] + [:has-field-rva FieldAttributes/ReservedMask FieldAttributes/HasFieldRVA] + ]) + + (def property-flags + [[:special-name PropertyAttributes/SpecialName PropertyAttributes/SpecialName] + [:rt-special-name PropertyAttributes/ReservedMask PropertyAttributes/RTSpecialName] + [:has-default PropertyAttributes/ReservedMask PropertyAttributes/HasDefault] + ]) + + + +(defn- parse-attributes + "Convert attributes into a set of keywords" + [attributes flags] + (reduce + (fn [result fd] + (if (== (enum-and attributes (nth fd 1)) (nth fd 2)) + (conj result (nth fd 0)) + result)) + #{} + flags)) + +(defn- parameter->info [^System.Reflection.ParameterInfo p] + (let [ t (.ParameterType p) ] + (if (.IsByRef t) + (list :by-ref (typesym t)) + (typesym t)))) + +(defrecord Constructor + [name declaring-class parameter-types flags]) + +(defn- constructor->map + [^System.Reflection.ConstructorInfo constructor] + (Constructor. + (symbol (.Name constructor)) + (typesym (.DeclaringType constructor)) + (vec (map parameter->info (.GetParameters constructor))) + (parse-attributes (.Attributes constructor) method-flags))) + +(def ^:private basic-binding-flags + (enum-or BindingFlags/Public BindingFlags/NonPublic BindingFlags/DeclaredOnly BindingFlags/Instance BindingFlags/Static)) + +(defn- declared-constructors + "Return a set of the declared constructors of class as a Clojure map." + [cls] + (set (map + constructor->map + (.GetConstructors ^Type (cast Type cls) basic-binding-flags)))) + +(defrecord Method + [name return-type declaring-class parameter-types flags]) + +(defn- method->map + [^System.Reflection.MethodInfo method] + (Method. + (symbol (.Name method)) + (typesym (.ReturnType method)) + (typesym (.DeclaringType method)) + (vec (map parameter->info (.GetParameters method))) + (parse-attributes (.Attributes method) method-flags))) + +(defn- declared-methods + "Return a set of the declared constructors of class as a Clojure map." + [cls] + (set (map + method->map + (.GetMethods ^Type (cast Type cls) basic-binding-flags)))) + +(defrecord Field + [name type declaring-class flags]) + +(defn- field->map + [^System.Reflection.FieldInfo field] + (Field. + (symbol (.Name field)) + (typesym (.FieldType field)) + (typesym (.DeclaringType field)) + (parse-attributes (.Attributes field) field-flags))) + +(defn- declared-fields + "Return a set of the declared fields of class as a Clojure map." + [cls] + (set (map + field->map + (.GetFields ^Type (cast Type cls) basic-binding-flags)))) + +(defrecord Property + [name type declaring-class flags]) + +(defn- property->map + [^System.Reflection.PropertyInfo property] + (Property. + (symbol (.Name property)) + (typesym (.PropertyType property)) + (typesym (.DeclaringType property)) + (let [property-attributes (parse-attributes (.Attributes property) property-flags) + getter (.GetGetMethod property true) + method-attributes (when getter (parse-attributes (.Attributes getter) method-flags))] + (set/union property-attributes method-attributes)))) + + +(defn- declared-properties + "Return a set of the declared fields of class as a Clojure map." + [cls] + (set (map + property->map + (.GetProperties ^Type (cast Type cls) basic-binding-flags)))) + +(defn- typeref->class + ^Type [typeref ] ;;; classloader arg removed ^Class + (if (class? typeref) + typeref + (clojure.lang.RT/classForName (typename typeref)))) ;;; false classloader + + +(deftype ClrReflector [a] + Reflector + (do-reflect [_ typeref] + (let [cls (typeref->class typeref)] ;;; classloader arg + {:bases (not-empty (set (map typesym (bases cls)))) + :flags (parse-attributes (.Attributes cls) class-flags) + :members (set/union (declared-fields cls) + (declared-properties cls) + (declared-methods cls) + (declared-constructors cls))}))) + +(def ^:private default-reflector + (ClrReflector. nil)) diff --git a/Clojure/Clojure.Source/clojure/repl.clj b/Clojure/Clojure.Source/clojure/repl.clj index fff0ce3ec..22c432bf9 100644 --- a/Clojure/Clojure.Source/clojure/repl.clj +++ b/Clojure/Clojure.Source/clojure/repl.clj @@ -1,216 +1,216 @@ -; Copyright (c) Chris Houser, Dec 2008. All rights reserved. -; The use and distribution terms for this software are covered by the -; Common Public License 1.0 (http://opensource.org/licenses/cpl.php) -; which can be found in the file CPL.TXT 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. - -; Utilities meant to be used interactively at the REPL - -(ns - ^{:author "Chris Houser, Christophe Grand, Stephen Gilardi, Michel Salim" - :doc "Utilities meant to be used interactively at the REPL"} - clojure.repl - (:require [clojure.spec.alpha :as spec]) - ) ;;;(:import (java.io LineNumberReader InputStreamReader PushbackReader) - ;;; (clojure.lang RT Reflector))) - -(def ^:private special-doc-map - '{. {:url "java_interop#dot" - :forms [(.instanceMember instance args*) - (.instanceMember Classname args*) - (Classname/staticMethod args*) - Classname/staticField] - :doc "The instance member form works for both fields and methods. - They all expand into calls to the dot operator at macroexpansion time."} - def {:forms [(def symbol doc-string? init?)] - :doc "Creates and interns a global var with the name - of symbol in the current namespace (*ns*) or locates such a var if - it already exists. If init is supplied, it is evaluated, and the - root binding of the var is set to the resulting value. If init is - not supplied, the root binding of the var is unaffected."} - do {:forms [(do exprs*)] - :doc "Evaluates the expressions in order and returns the value of - the last. If no expressions are supplied, returns nil."} - if {:forms [(if test then else?)] - :doc "Evaluates test. If not the singular values nil or false, - evaluates and yields then, otherwise, evaluates and yields else. If - else is not supplied it defaults to nil."} - monitor-enter {:forms [(monitor-enter x)] - :doc "Synchronization primitive that should be avoided - in user code. Use the 'locking' macro."} - monitor-exit {:forms [(monitor-exit x)] - :doc "Synchronization primitive that should be avoided - in user code. Use the 'locking' macro."} - new {:forms [(Classname. args*) (new Classname args*)] - :url "java_interop#new" - :doc "The args, if any, are evaluated from left to right, and - passed to the constructor of the class named by Classname. The - constructed object is returned."} - quote {:forms [(quote form)] - :doc "Yields the unevaluated form."} - recur {:forms [(recur exprs*)] - :doc "Evaluates the exprs in order, then, in parallel, rebinds - the bindings of the recursion point to the values of the exprs. - Execution then jumps back to the recursion point, a loop or fn method."} - set! {:forms[(set! var-symbol expr) - (set! (. instance-expr instanceFieldName-symbol) expr) - (set! (. Classname-symbol staticFieldName-symbol) expr)] - :url "vars#set" - :doc "Used to set thread-local-bound vars, Java object instance -fields, and Java class static fields."} - throw {:forms [(throw expr)] - :doc "The expr is evaluated and thrown, therefore it should - yield an instance of some derivee of Throwable."} - try {:forms [(try expr* catch-clause* finally-clause?)] - :doc "catch-clause => (catch classname name expr*) - finally-clause => (finally expr*) - - Catches and handles Java exceptions."} - var {:forms [(var symbol)] - :doc "The symbol must resolve to a var, and the Var object -itself (not its value) is returned. The reader macro #'x expands to (var x)."}}) - -(defn- special-doc [name-symbol] - (assoc (or (special-doc-map name-symbol) (meta (resolve name-symbol))) - :name name-symbol - :special-form true)) - -(defn- namespace-doc [nspace] - (assoc (meta nspace) :name (ns-name nspace))) - -(defn- print-doc [{n :ns - nm :name - :keys [forms arglists special-form doc url macro spec] - :as m}] - (println "-------------------------") - (println (or spec (str (when n (str (ns-name n) "/")) nm))) - (when forms - (doseq [f forms] - (print " ") - (prn f))) - (when arglists - (prn arglists)) - (cond - special-form - (println "Special Form") - macro - (println "Macro") - spec - (println "Spec")) - (when doc (println " " doc)) - (when special-form - (if (contains? m :url) - (when url - (println (str "\n Please see http://clojure.org/" url))) - (println (str "\n Please see http://clojure.org/special_forms#" nm)))) - (when n - (when-let [fnspec (spec/get-spec (symbol (str (ns-name n)) (name nm)))] - (println "Spec") - (doseq [role [:args :ret :fn]] - (when-let [spec (get fnspec role)] - (println " " (str (name role) ":") (spec/describe spec))))))) - -(defn find-doc - "Prints documentation for any var whose documentation or name - contains a match for re-string-or-pattern" - {:added "1.0"} - [re-string-or-pattern] - (let [re (re-pattern re-string-or-pattern) - ms (concat (mapcat #(sort-by :name (map meta (vals (ns-interns %)))) - (all-ns)) - (map namespace-doc (all-ns)) - (map special-doc (keys special-doc-map)))] - (doseq [m ms - :when (and (:doc m) - (or (re-find (re-matcher re (:doc m))) - (re-find (re-matcher re (str (:name m))))))] - (print-doc m)))) - -(defmacro doc - "Prints documentation for a var or special form given its name, - or for a spec if given a keyword" - {:added "1.0"} - [name] - (if-let [special-name ('{& fn catch try finally try} name)] - `(#'print-doc (#'special-doc '~special-name)) - (cond - (special-doc-map name) `(#'print-doc (#'special-doc '~name)) - (keyword? name) `(#'print-doc {:spec '~name :doc '~(spec/describe name)}) - (find-ns name) `(#'print-doc (#'namespace-doc (find-ns '~name))) - (resolve name) `(#'print-doc (meta (var ~name)))))) - -;; ---------------------------------------------------------------------- -;; Examine Clojure functions (Vars, really) - -(defn source-fn - "Returns a string of the source code for the given symbol, if it can -find it. This requires that the symbol resolve to a Var defined in -a namespace for which the .clj is in the classpath. Returns nil if -it can't find the source. For most REPL usage, 'source' is more -convenient. - -Example: (source-fn 'filter)" - [x] - (when-let [v (resolve x)] - (when-let [filepath (:file (meta v))] - (when-let [ ^System.IO.FileInfo info (clojure.lang.RT/FindFile filepath) ] ;;; [strm (.getResourceAsStream (RT/baseLoader) filepath)] - (with-open [ ^System.IO.TextReader rdr (.OpenText info)] ;;; [rdr (LineNumberReader. (InputStreamReader. strm))] - (dotimes [_ (dec (:line (meta v)))] (.ReadLine rdr)) ;;; .readLine - (let [text (StringBuilder.) - pbr (proxy [clojure.lang.PushbackTextReader] [rdr] ;;; [PushbackReader] [rdr] - (Read [] (let [i (proxy-super Read)] ;;; read read - (.Append text (char i)) ;;; .append - i))) - read-opts (if (.EndsWith ^String filepath "cljc") {:read-cond :allow} {})] ;;; .endsWith - (if (= :unknown *read-eval*) - (throw (InvalidOperationException. "Unable to read source while *read-eval* is :unknown.")) ;;; IllegalStateException - (read read-opts (clojure.lang.PushbackTextReader. pbr))) ;;; (read read-opts(PushbackReader. pbr)) - (str text))))))) - -(defmacro source - "Prints the source code for the given symbol, if it can find it. - This requires that the symbol resolve to a Var defined in a - namespace for which the .clj is in the classpath. - - Example: (source filter)" - [n] - `(println (or (source-fn '~n) (str "Source not found")))) - -(defn apropos - "Given a regular expression or stringable thing, return a seq of all -public definitions in all currently-loaded namespaces that match the -str-or-pattern." - [str-or-pattern] - (let [matches? (if (instance? System.Text.RegularExpressions.Regex str-or-pattern) ;;; java.util.regex.Pattern - #(re-find str-or-pattern (str %)) - #(.Contains (str %) (str str-or-pattern)))] ;;; .contains - (sort (mapcat (fn [ns] - (let [ns-name (str ns)] - (map #(symbol ns-name (str %)) - (filter matches? (keys (ns-publics ns)))))) - (all-ns))))) - -(defn dir-fn - "Returns a sorted seq of symbols naming public vars in - a namespace or namespace alias. Looks for aliases in *ns*" - [ns] - (sort (map first (ns-publics (the-ns (get (ns-aliases *ns*) ns ns)))))) - -(defmacro dir - "Prints a sorted directory of public vars in a namespace" - [nsname] - `(doseq [v# (dir-fn '~nsname)] - (println v#))) - -(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)) - +; Copyright (c) Chris Houser, Dec 2008. All rights reserved. +; The use and distribution terms for this software are covered by the +; Common Public License 1.0 (http://opensource.org/licenses/cpl.php) +; which can be found in the file CPL.TXT 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. + +; Utilities meant to be used interactively at the REPL + +(ns + ^{:author "Chris Houser, Christophe Grand, Stephen Gilardi, Michel Salim" + :doc "Utilities meant to be used interactively at the REPL"} + clojure.repl + (:require [clojure.spec.alpha :as spec]) + ) ;;;(:import (java.io LineNumberReader InputStreamReader PushbackReader) + ;;; (clojure.lang RT Reflector))) + +(def ^:private special-doc-map + '{. {:url "java_interop#dot" + :forms [(.instanceMember instance args*) + (.instanceMember Classname args*) + (Classname/staticMethod args*) + Classname/staticField] + :doc "The instance member form works for both fields and methods. + They all expand into calls to the dot operator at macroexpansion time."} + def {:forms [(def symbol doc-string? init?)] + :doc "Creates and interns a global var with the name + of symbol in the current namespace (*ns*) or locates such a var if + it already exists. If init is supplied, it is evaluated, and the + root binding of the var is set to the resulting value. If init is + not supplied, the root binding of the var is unaffected."} + do {:forms [(do exprs*)] + :doc "Evaluates the expressions in order and returns the value of + the last. If no expressions are supplied, returns nil."} + if {:forms [(if test then else?)] + :doc "Evaluates test. If not the singular values nil or false, + evaluates and yields then, otherwise, evaluates and yields else. If + else is not supplied it defaults to nil."} + monitor-enter {:forms [(monitor-enter x)] + :doc "Synchronization primitive that should be avoided + in user code. Use the 'locking' macro."} + monitor-exit {:forms [(monitor-exit x)] + :doc "Synchronization primitive that should be avoided + in user code. Use the 'locking' macro."} + new {:forms [(Classname. args*) (new Classname args*)] + :url "java_interop#new" + :doc "The args, if any, are evaluated from left to right, and + passed to the constructor of the class named by Classname. The + constructed object is returned."} + quote {:forms [(quote form)] + :doc "Yields the unevaluated form."} + recur {:forms [(recur exprs*)] + :doc "Evaluates the exprs in order, then, in parallel, rebinds + the bindings of the recursion point to the values of the exprs. + Execution then jumps back to the recursion point, a loop or fn method."} + set! {:forms[(set! var-symbol expr) + (set! (. instance-expr instanceFieldName-symbol) expr) + (set! (. Classname-symbol staticFieldName-symbol) expr)] + :url "vars#set" + :doc "Used to set thread-local-bound vars, Java object instance +fields, and Java class static fields."} + throw {:forms [(throw expr)] + :doc "The expr is evaluated and thrown, therefore it should + yield an instance of some derivee of Throwable."} + try {:forms [(try expr* catch-clause* finally-clause?)] + :doc "catch-clause => (catch classname name expr*) + finally-clause => (finally expr*) + + Catches and handles Java exceptions."} + var {:forms [(var symbol)] + :doc "The symbol must resolve to a var, and the Var object +itself (not its value) is returned. The reader macro #'x expands to (var x)."}}) + +(defn- special-doc [name-symbol] + (assoc (or (special-doc-map name-symbol) (meta (resolve name-symbol))) + :name name-symbol + :special-form true)) + +(defn- namespace-doc [nspace] + (assoc (meta nspace) :name (ns-name nspace))) + +(defn- print-doc [{n :ns + nm :name + :keys [forms arglists special-form doc url macro spec] + :as m}] + (println "-------------------------") + (println (or spec (str (when n (str (ns-name n) "/")) nm))) + (when forms + (doseq [f forms] + (print " ") + (prn f))) + (when arglists + (prn arglists)) + (cond + special-form + (println "Special Form") + macro + (println "Macro") + spec + (println "Spec")) + (when doc (println " " doc)) + (when special-form + (if (contains? m :url) + (when url + (println (str "\n Please see http://clojure.org/" url))) + (println (str "\n Please see http://clojure.org/special_forms#" nm)))) + (when n + (when-let [fnspec (spec/get-spec (symbol (str (ns-name n)) (name nm)))] + (println "Spec") + (doseq [role [:args :ret :fn]] + (when-let [spec (get fnspec role)] + (println " " (str (name role) ":") (spec/describe spec))))))) + +(defn find-doc + "Prints documentation for any var whose documentation or name + contains a match for re-string-or-pattern" + {:added "1.0"} + [re-string-or-pattern] + (let [re (re-pattern re-string-or-pattern) + ms (concat (mapcat #(sort-by :name (map meta (vals (ns-interns %)))) + (all-ns)) + (map namespace-doc (all-ns)) + (map special-doc (keys special-doc-map)))] + (doseq [m ms + :when (and (:doc m) + (or (re-find (re-matcher re (:doc m))) + (re-find (re-matcher re (str (:name m))))))] + (print-doc m)))) + +(defmacro doc + "Prints documentation for a var or special form given its name, + or for a spec if given a keyword" + {:added "1.0"} + [name] + (if-let [special-name ('{& fn catch try finally try} name)] + `(#'print-doc (#'special-doc '~special-name)) + (cond + (special-doc-map name) `(#'print-doc (#'special-doc '~name)) + (keyword? name) `(#'print-doc {:spec '~name :doc '~(spec/describe name)}) + (find-ns name) `(#'print-doc (#'namespace-doc (find-ns '~name))) + (resolve name) `(#'print-doc (meta (var ~name)))))) + +;; ---------------------------------------------------------------------- +;; Examine Clojure functions (Vars, really) + +(defn source-fn + "Returns a string of the source code for the given symbol, if it can +find it. This requires that the symbol resolve to a Var defined in +a namespace for which the .clj is in the classpath. Returns nil if +it can't find the source. For most REPL usage, 'source' is more +convenient. + +Example: (source-fn 'filter)" + [x] + (when-let [v (resolve x)] + (when-let [filepath (:file (meta v))] + (when-let [ ^System.IO.FileInfo info (clojure.lang.RT/FindFile filepath) ] ;;; [strm (.getResourceAsStream (RT/baseLoader) filepath)] + (with-open [ ^System.IO.TextReader rdr (.OpenText info)] ;;; [rdr (LineNumberReader. (InputStreamReader. strm))] + (dotimes [_ (dec (:line (meta v)))] (.ReadLine rdr)) ;;; .readLine + (let [text (StringBuilder.) + pbr (proxy [clojure.lang.PushbackTextReader] [rdr] ;;; [PushbackReader] [rdr] + (Read [] (let [i (proxy-super Read)] ;;; read read + (.Append text (char i)) ;;; .append + i))) + read-opts (if (.EndsWith ^String filepath "cljc") {:read-cond :allow} {})] ;;; .endsWith + (if (= :unknown *read-eval*) + (throw (InvalidOperationException. "Unable to read source while *read-eval* is :unknown.")) ;;; IllegalStateException + (read read-opts (clojure.lang.PushbackTextReader. pbr))) ;;; (read read-opts(PushbackReader. pbr)) + (str text))))))) + +(defmacro source + "Prints the source code for the given symbol, if it can find it. + This requires that the symbol resolve to a Var defined in a + namespace for which the .clj is in the classpath. + + Example: (source filter)" + [n] + `(println (or (source-fn '~n) (str "Source not found")))) + +(defn apropos + "Given a regular expression or stringable thing, return a seq of all +public definitions in all currently-loaded namespaces that match the +str-or-pattern." + [str-or-pattern] + (let [matches? (if (instance? System.Text.RegularExpressions.Regex str-or-pattern) ;;; java.util.regex.Pattern + #(re-find str-or-pattern (str %)) + #(.Contains (str %) (str str-or-pattern)))] ;;; .contains + (sort (mapcat (fn [ns] + (let [ns-name (str ns)] + (map #(symbol ns-name (str %)) + (filter matches? (keys (ns-publics ns)))))) + (all-ns))))) + +(defn dir-fn + "Returns a sorted seq of symbols naming public vars in + a namespace or namespace alias. Looks for aliases in *ns*" + [ns] + (sort (map first (ns-publics (the-ns (get (ns-aliases *ns*) ns ns)))))) + +(defmacro dir + "Prints a sorted directory of public vars in a namespace" + [nsname] + `(doseq [v# (dir-fn '~nsname)] + (println v#))) + +(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" @@ -221,68 +221,68 @@ str-or-pattern." 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 - (.EndsWith file ".cljc") (.EndsWith ".cljr") ;;; endsWith + DM: Added .cljr - (= 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 - -(defn pst - "Prints a stack trace of the exception, to the depth requsted. If none supplied, uses the root cause of the - most recent repl exception (*e), and a depth of 12." - {:added "1.3"} - ([] (pst 12)) - ([e-or-depth] - (if (instance? Exception e-or-depth) ;;; Throwable - (pst e-or-depth 12) - (when-let [e *e] - (pst (root-cause e) e-or-depth)))) - ([^Exception e depth] ;;; Throwable - (binding [*out* *err*] - (when (#{:read-source :macro-syntax-check :macroexpansion :compile-syntax-check :compilation} - (-> e ex-data :clojure.error/phase)) - (println "Note: The following stack trace applies to the reader or compiler, your code was not executed.")) - (println (str (-> e class .Name) " " ;;; .getSimpleName - (.Message e) ;;; getMessage - (when-let [info (ex-data e)] (str " " (pr-str info))))) - (let [st (get-stack-trace e) ;;; (.getStackTrace e) - cause (.InnerException e)] ;;; .getCause - (doseq [el (take depth - (remove #(#{"clojure.lang.RestFn" "clojure.lang.AFn" "clojure.lang.AFnImpl" "clojure.lang.RestFnImpl"} (stack-element-classname %)) ;;; (.getClassName %) - st))] - (println (str \tab (stack-element-str el)))) - (when cause - (println "Caused by:") - (pst cause (min depth - (+ 2 (- (count (get-stack-trace cause)) ;;; (.getStackTrace cause) - (count st)))))))))) - + 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 + (.EndsWith file ".cljc") (.EndsWith ".cljr") ;;; endsWith + DM: Added .cljr + (= 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 + +(defn pst + "Prints a stack trace of the exception, to the depth requsted. If none supplied, uses the root cause of the + most recent repl exception (*e), and a depth of 12." + {:added "1.3"} + ([] (pst 12)) + ([e-or-depth] + (if (instance? Exception e-or-depth) ;;; Throwable + (pst e-or-depth 12) + (when-let [e *e] + (pst (root-cause e) e-or-depth)))) + ([^Exception e depth] ;;; Throwable + (binding [*out* *err*] + (when (#{:read-source :macro-syntax-check :macroexpansion :compile-syntax-check :compilation} + (-> e ex-data :clojure.error/phase)) + (println "Note: The following stack trace applies to the reader or compiler, your code was not executed.")) + (println (str (-> e class .Name) " " ;;; .getSimpleName + (.Message e) ;;; getMessage + (when-let [info (ex-data e)] (str " " (pr-str info))))) + (let [st (get-stack-trace e) ;;; (.getStackTrace e) + cause (.InnerException e)] ;;; .getCause + (doseq [el (take depth + (remove #(#{"clojure.lang.RestFn" "clojure.lang.AFn" "clojure.lang.AFnImpl" "clojure.lang.RestFnImpl"} (stack-element-classname %)) ;;; (.getClassName %) + st))] + (println (str \tab (stack-element-str el)))) + (when cause + (println "Caused by:") + (pst cause (min depth + (+ 2 (- (count (get-stack-trace cause)) ;;; (.getStackTrace cause) + (count st)))))))))) + diff --git a/Clojure/Clojure.Source/clojure/set.clj b/Clojure/Clojure.Source/clojure/set.clj index c37a99c4e..02f42522d 100644 --- a/Clojure/Clojure.Source/clojure/set.clj +++ b/Clojure/Clojure.Source/clojure/set.clj @@ -6,8 +6,8 @@ ; the terms of this license. ; You must not remove this notice, or any other, from this software. -(ns ^{:doc "Set operations such as union/intersection." - :author "Rich Hickey"} +(ns ^{:doc "Set operations such as union/intersection." + :author "Rich Hickey"} clojure.set) (defn- bubble-max-key @@ -19,7 +19,7 @@ (defn union "Return a set that is the union of the input sets" - {:added "1.0"} + {:added "1.0"} ([] #{}) ([s1] s1) ([s1 s2] @@ -32,7 +32,7 @@ (defn intersection "Return a set that is the intersection of the input sets" - {:added "1.0"} + {:added "1.0"} ([s1] s1) ([s1 s2] (if (< (count s2) (count s1)) @@ -48,7 +48,7 @@ (defn difference "Return a set that is the first set without elements of the remaining sets" - {:added "1.0"} + {:added "1.0"} ([s1] s1) ([s1 s2] (if (< (count s1) (count s2)) @@ -64,38 +64,38 @@ (defn select "Returns a set of the elements for which pred is true" - {:added "1.0"} + {:added "1.0"} [pred xset] (reduce (fn [s k] (if (pred k) s (disj s k))) xset xset)) (defn project "Returns a rel of the elements of xrel with only the keys in ks" - {:added "1.0"} + {:added "1.0"} [xrel ks] (with-meta (set (map #(select-keys % ks) xrel)) (meta xrel))) (defn rename-keys "Returns the map with the keys in kmap renamed to the vals in kmap" - {:added "1.0"} + {:added "1.0"} [map kmap] (reduce (fn [m [old new]] - (if (contains? map old) + (if (contains? map old) (assoc m new (get map old)) m)) (apply dissoc map (keys kmap)) kmap)) (defn rename "Returns a rel of the maps in xrel with the keys in kmap renamed to the vals in kmap" - {:added "1.0"} + {:added "1.0"} [xrel kmap] (with-meta (set (map #(rename-keys % kmap) xrel)) (meta xrel))) (defn index "Returns a map of the distinct values of ks in the xrel mapped to a set of the maps in xrel with the corresponding values of ks." - {:added "1.0"} + {:added "1.0"} [xrel ks] (reduce (fn [m x] @@ -105,18 +105,18 @@ (defn map-invert "Returns the map with the vals mapped to the keys." - {:added "1.0"} - [m] - (persistent! - (reduce-kv (fn [m k v] (assoc! m v k)) - (transient {}) + {:added "1.0"} + [m] + (persistent! + (reduce-kv (fn [m k v] (assoc! m v k)) + (transient {}) m))) (defn join "When passed 2 rels, returns the rel corresponding to the natural join. When passed an additional keymap, joins on the corresponding keys." - {:added "1.0"} + {:added "1.0"} ([xrel yrel] ;natural join (if (and (seq xrel) (seq yrel)) (let [ks (intersection (set (keys (first xrel))) (set (keys (first yrel)))) @@ -143,21 +143,21 @@ ret))) #{} s)))) -(defn subset? - "Is set1 a subset of set2?" - {:added "1.2", - :tag Boolean} - [set1 set2] - (and (<= (count set1) (count set2)) - (every? #(contains? set2 %) set1))) - -(defn superset? - "Is set1 a superset of set2?" - {:added "1.2", - :tag Boolean} - [set1 set2] - (and (>= (count set1) (count set2)) - (every? #(contains? set1 %) set2))) +(defn subset? + "Is set1 a subset of set2?" + {:added "1.2", + :tag Boolean} + [set1 set2] + (and (<= (count set1) (count set2)) + (every? #(contains? set2 %) set1))) + +(defn superset? + "Is set1 a superset of set2?" + {:added "1.2", + :tag Boolean} + [set1 set2] + (and (>= (count set1) (count set2)) + (every? #(contains? set1 %) set2))) (comment (refer 'set) diff --git a/Clojure/Clojure.Source/clojure/stacktrace.clj b/Clojure/Clojure.Source/clojure/stacktrace.clj index 2f2bf7433..6fb7f5900 100644 --- a/Clojure/Clojure.Source/clojure/stacktrace.clj +++ b/Clojure/Clojure.Source/clojure/stacktrace.clj @@ -11,11 +11,11 @@ ;; 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) -(set! *warn-on-reflection* true) +(set! *warn-on-reflection* true) (defn root-cause "Returns the last 'cause' Throwable in a chain of Throwables." @@ -43,13 +43,13 @@ (printf " (%s:%d)" (or (.GetFileName e) "") (.GetFileLineNumber e))) (defn print-throwable1 - "Prints the class and message of a Throwable. Prints the ex-data map + "Prints the class and message of a Throwable. Prints the ex-data map if present." {:added "1.1"} [^Exception tr] ;;; Throwable - (printf "%s: %s" (.FullName (class tr)) (.Message tr)) ;;; .getName .getMessage - (when-let [info (ex-data tr)] - (newline) + (printf "%s: %s" (.FullName (class tr)) (.Message tr)) ;;; .getName .getMessage + (when-let [info (ex-data tr)] + (newline) (pr info))) (defn print-stack-trace @@ -63,8 +63,8 @@ (print-throwable1 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 1b61988da..b4c7f7ef7 100644 --- a/Clojure/Clojure.Source/clojure/string.clj +++ b/Clojure/Clojure.Source/clojure/string.clj @@ -1,387 +1,387 @@ -; 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. - -(ns ^{:doc "Clojure String utilities - -It is poor form to (:use clojure.string). Instead, use require -with :as to specify a prefix, e.g. - -(ns your.namespace.here - (:require [clojure.string :as str])) - -Design notes for clojure.string: - -1. Strings are objects (as opposed to sequences). As such, the - string being manipulated is the first argument to a function; - passing nil will result in a NullPointerException unless - documented otherwise. If you want sequence-y behavior instead, - use a sequence. - -2. Functions are generally not lazy, and call straight to host - methods where those are available and efficient. - -3. Functions take advantage of String implementation details to - write high-performing loop/recurs instead of using higher-order - functions. (This is not idiomatic in general-purpose application - code.) - -4. When a function is documented to accept a string argument, it - will take any implementation of the correct *interface* on the - host platform. In Java, this is CharSequence, which is more - general than String. In ordinary usage you will almost always - pass concrete strings. If you are doing something unusual, - e.g. passing a mutable implementation of CharSequence, then - thread-safety is your responsibility." - :author "Stuart Sierra, Stuart Halloway, David Liebke"} - clojure.string - (:refer-clojure :exclude (replace reverse)) - (:import (System.Text.RegularExpressions Regex MatchEvaluator Match Group) ; java.util.regex Pattern - clojure.lang.LazilyPersistentVector)) -(declare re-groups-direct) ;;; I'm going to add a little helper -(set! *warn-on-reflection* true) - -(defn ^String reverse - "Returns s with its characters reversed." - {:added "1.2"} - [^String s] - (clojure.lang.RT/StringReverse s)) ;;; (.toString (.reverse (StringBuilder. s)))) - -(defn ^String re-quote-replacement - "Given a replacement string that you wish to be a literal - replacement for a pattern match in replace or replace-first, do the - necessary escaping of special characters in the replacement." - {:added "1.5"} - [^String replacement] ;;; ^CharSequence - 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 ^Regex re s ;;; (let [m (re-matcher re s)] DM: Added ^Regex - ^MatchEvaluator (gen-delegate MatchEvaluator [m] (f (re-groups-direct m))))) ;;; (if (.find m) TODO: Figure out why the tag of ^MatchEvaluator does not help - ;;; (let [buffer (StringBuffer. (.length s))] - ;;; (loop [found true] - ;;; (if found - ;;; (do (.appendReplacement m buffer (Matcher/quoteReplacement (f (re-groups m)))) - ;;; (recur (.find m))) - ;;; (do (.appendTail m buffer) - ;;; (.toString buffer))))) - ;;; s))) - -(defn replace - "Replaces all instance of match with replacement in s. - - match/replacement can be: - - string / string - char / char - pattern / (string or function of match). - - See also replace-first. - - The replacement is literal (i.e. none of its characters are treated - specially) for all cases above except pattern / string. - - For pattern / string, $1, $2, etc. in the replacement string are - substituted with the string that matched the corresponding - parenthesized group in the pattern. If you wish your replacement - string r to be used literally, use (re-quote-replacement r) as the - replacement argument. See also documentation for - java.util.regex.Matcher's appendReplacement method. - - Example: - (clojure.string/replace \"Almost Pig Latin\" #\"\\b(\\w)(\\w+)\\b\" \"$2$1ay\") - -> \"lmostAay igPay atinLay\"" - {:added "1.2"} - [^String s 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 ^Regex 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 - -(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)) - (int 1))) ;;; rep (Matcher/quoteReplacement (f (re-groups m)))] - ;;; (.appendReplacement m buffer rep) - ;;; (.appendTail m buffer) - ;;; (str buffer)) - ;;; s))) - -(defn- replace-first-char - [^String s match replace] (let [match ^Char (char match)] ;;; Character hint on match - (let [ ;;; s (.toString s) - i (.IndexOf s match)] ;;; .indexOf (int match) - (if (= -1 i) - s - (str (subs s 0 i) replace (subs s (inc i)))))) ) - -(defn- replace-first-str - [^String s ^String match ^String replace] ;;; ^CharSequence - (let [ ;;; ^String s (.toString s) - i (.IndexOf s match)] ;;; .indexOf - (if (= -1 i) - s - (str (subs s 0 i) replace (subs s (+ i (.Length match))))))) ;;; .length - -(defn replace-first - "Replaces the first instance of match with replacement in s. - - match/replacement can be: - - char / char - string / string - pattern / (string or function of match). - - See also replace. - - The replacement is literal (i.e. none of its characters are treated - specially) for all cases above except pattern / string. - - For pattern / string, $1, $2, etc. in the replacement string are - substituted with the string that matched the corresponding - parenthesized group in the pattern. If you wish your replacement - string r to be used literally, use (re-quote-replacement r) as the - replacement argument. See also documentation for - java.util.regex.Matcher's appendReplacement method. - - Example: - (clojure.string/replace-first \"swap first two words\" - #\"(\\w+)(\\s+)(\\w+)\" \"$3$2$1\") - -> \"first swap two words\"" - - {:added "1.2"} - [^String s match replacement] - ;;;(let [s (.toString s)] - (cond - (instance? Char match) ;;; Character - (replace-first-char s ^Char match replacement) - (instance? String match) ;;; CharSequence - (replace-first-str s match ;;; (.toString ^CharSequence match) - replacement) ;;; (.toString ^CharSequence replacement) - (instance? Regex match) ;;; Pattern - (if (string? replacement) - (.Replace ^Regex match s ^String replacement 1) ;;; (.replaceFirst (re-matcher ^Pattern match s) ^String replacement) - (replace-first-by s match replacement)) - :else (throw (ArgumentException. (str "Invalid match arg: " match))))) ;;; IllegalArgumentException - - -(defn ^String join - "Returns a string of all elements in coll, as returned by (seq coll), - separated by an optional separator." - {:added "1.2"} - ([coll] - (apply str coll)) - ([separator coll] - (loop [sb (StringBuilder. (str (first coll))) - more (next coll) - sep (str separator)] - (if more - (recur (-> sb (.Append sep) (.Append (str (first more)))) ;;; .append - (next more) - sep) - (str sb))))) - -(defn ^String capitalize - "Converts first character of the string to upper-case, all other - characters to lower-case." - {:added "1.2"} - [^String s] ;;; ^CharSequence - (let [] ;;; [s (.toString s)] - (if (< (count s) 2) - (.ToUpper s) ;;; .toUpperCase - (str (.ToUpper ^String (subs s 0 1)) ;;; .toUpperCase - (.ToLower ^String (subs s 1)))))) ;;; .toLowerCase - -(defn ^String upper-case - "Converts string to all upper-case." - {:added "1.2"} - [^String s] - (.ToUpper s)) ;;; .toUpperCase - -(defn ^String lower-case - "Converts string to all lower-case." - {:added "1.2"} - [^String s] - (.ToLower s)) ;;; .toLowerCase - -(defn split - "Splits string on a regular expression. Optional argument limit is - the maximum number of parts. Not lazy. Returns vector of the parts. - Trailing empty strings are not returned - pass limit of -1 to return all." - {:added "1.2"} - ([^String s ^Regex re] ;;; ^Pattern - (LazilyPersistentVector/createOwning (.Split re s))) ;;; .split - ([^String s ^Regex re limit] ;;; ^Pattern - (LazilyPersistentVector/createOwning (.Split re s limit)))) ;;; .split - -(defn split-lines - "Splits s on \\n or \\r\\n. Trailing empty lines are not returned." - {:added "1.2"} - [^String s] - (split s #"\r?\n")) - -(defn ^String trim - "Removes whitespace from both ends of string." - {:added "1.2"} - [^String s] ;;; ^CharSequence - (let [len (.Length s)] ;;; .length - (loop [rindex len] - (if (zero? rindex) - "" - (if (Char/IsWhiteSpace (.get_Chars s (dec rindex))) ;;; Character/isWhitespace .charAt - (recur (dec rindex)) - ;; there is at least one non-whitespace char in the string, - ;; so no need to check for lindex reaching len. - (loop [lindex 0] - (if (Char/IsWhiteSpace (.get_Chars s lindex)) ;;; Character/isWhitespace .charAt - (recur (inc lindex)) - (.. s (Substring lindex (- rindex lindex)))))))))) ;;; (subSequence lindex rindex) toSTring - -(defn ^String triml - "Removes whitespace from the left side of string." - {:added "1.2"} - [^String s] ;;; ^CharSequence - (let [len (.Length s)] ;;; .length - (loop [index 0] - (if (= len index) - "" - (if (Char/IsWhiteSpace (.get_Chars s index)) ;;; Character/isWhitespace .charAt - (recur (unchecked-inc index)) - (.. s (Substring index))))))) ;;; (subSequence index len) toSTring - -(defn ^String trimr - "Removes whitespace from the right side of string." - {:added "1.2"} - [^String s] ;;; ^CharSequence - (loop [index (.Length s)] ;;; .length - (if (zero? index) - "" - (if (Char/IsWhiteSpace (.get_Chars s (unchecked-dec index))) ;;; Character/isWhitespace .charAt - (recur (unchecked-dec index)) - (.. s (Substring 0 index)))))) ;;; (subSequence 0 index) toSTring - -(defn ^String trim-newline - "Removes all trailing newline \\n or return \\r characters from - string. Similar to Perl's chomp." - {:added "1.2"} - [^String s] - (loop [index (.Length s)] ;;; .length - (if (zero? index) - "" - (let [ch (.get_Chars s (dec index))] ;;; .charAt - (if (or (= ch \newline) (= ch \return)) - (recur (dec index)) - (.Substring s 0 index)))))) ;;; .substring - -(defn blank? - "True if s is nil, empty, or contains only whitespace." - {:added "1.2"} - [^String s] ;;; CharSequence - (if s - (loop [index (int 0)] - (if (= (.Length s) index) ;;; .length - true - (if (Char/IsWhiteSpace (.get_Chars s index)) ;;; Character/isWhitespace .charAt - (recur (inc index)) - false))) - true)) - -(defn ^String escape - "Return a new string, using cmap to escape each character ch - from s as follows: - - If (cmap ch) is nil, append ch to the new string. - If (cmap ch) is non-nil, append (str (cmap ch)) instead." - {:added "1.2"} - [^String s cmap] ;;; CharSequence - (loop [index (int 0) - buffer (StringBuilder. (.Length s))] ;;; .length - (if (= (.Length s) index) ;;; .length - (.ToString buffer) ;;; .toString - (let [ch (.get_Chars s index)] ;;; .charAt - (if-let [replacement (cmap ch)] - (.Append buffer replacement) ;;; .append - (.Append buffer ch)) ;;; .append - (recur (inc index) buffer))))) - - -(defn- re-groups-direct - "similar to re-groups, but works on a Match directly, rather than JReMatcher" - [^Match m] - (let [strs (map #(.Value ^Group %) (.Groups ^Match m)) - cnt (count strs)] - (if (<= cnt 1) - (first strs) - (into [] strs)))) - -(defn index-of - "Return index of value (string or char) in s, optionally searching - forward from from-index. Return nil if value not found." - {:added "1.8"} - ([^String s value] ;;; ^CharSequence - (let [result ^long - (if (instance? Char value) ;;; ^Character - (.IndexOf s ^Char value) ;;; (.toString s) ^int(.charValue ^Character value) - (.IndexOf s ^String value))] ;;; (.toString s) - (if (= result -1) - nil - result))) - ([^String s value ^long from-index] ;;; ^CharSequence - (let [result ^long - (if (instance? Char value) ;;; ^Character - (.IndexOf s ^Char value (unchecked-int from-index)) ;;; (.toString s) ^int (.charValue ^Character value) - (.IndexOf s ^String value (unchecked-int from-index)))] ;;; (.toString s) - (if (= result -1) - nil - result)))) - -(defn last-index-of - "Return last index of value (string or char) in s, optionally - searching backward from from-index. Return nil if value not found." - {:added "1.8"} - ([^String s value] ;;; ^CharSequence - (let [result ^long - (if (instance? Char value) ;;; ^Character - (.LastIndexOf s ^Char value) ;;; (.toString s) ^int (.charValue ^Character value) - (.LastIndexOf s ^String value))] ;;; (.toString s) - (if (= result -1) - nil - result))) - ([^String s value ^long from-index] ;;; ^CharSequence - (let [result ^long - (if (instance? Char value) ;;; ^Character - (.LastIndexOf s ^Char value (unchecked-int from-index)) ;;; (.toString s) ^int (.charValue ^Character value) - (.LastIndexOf s ^String value (unchecked-int from-index)))] ;;; (.toString s) - (if (= result -1) - nil - result)))) - -(defn starts-with? - "True if s starts with substr." - {:added "1.8"} - [^String s ^String substr] ;;; ^CharSequence - (.StartsWith s substr)) ;;; (.toString s) - -(defn ends-with? - "True if s ends with substr." - {:added "1.8"} - [^String s ^String substr] ;;; ^CharSequence - (.EndsWith s substr)) ;;; (.toString s) - -(defn includes? - "True if s includes substr." - {:added "1.8"} - [^String s ^String substr] ;;; ^CharSequence +; 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. + +(ns ^{:doc "Clojure String utilities + +It is poor form to (:use clojure.string). Instead, use require +with :as to specify a prefix, e.g. + +(ns your.namespace.here + (:require [clojure.string :as str])) + +Design notes for clojure.string: + +1. Strings are objects (as opposed to sequences). As such, the + string being manipulated is the first argument to a function; + passing nil will result in a NullPointerException unless + documented otherwise. If you want sequence-y behavior instead, + use a sequence. + +2. Functions are generally not lazy, and call straight to host + methods where those are available and efficient. + +3. Functions take advantage of String implementation details to + write high-performing loop/recurs instead of using higher-order + functions. (This is not idiomatic in general-purpose application + code.) + +4. When a function is documented to accept a string argument, it + will take any implementation of the correct *interface* on the + host platform. In Java, this is CharSequence, which is more + general than String. In ordinary usage you will almost always + pass concrete strings. If you are doing something unusual, + e.g. passing a mutable implementation of CharSequence, then + thread-safety is your responsibility." + :author "Stuart Sierra, Stuart Halloway, David Liebke"} + clojure.string + (:refer-clojure :exclude (replace reverse)) + (:import (System.Text.RegularExpressions Regex MatchEvaluator Match Group) ; java.util.regex Pattern + clojure.lang.LazilyPersistentVector)) +(declare re-groups-direct) ;;; I'm going to add a little helper +(set! *warn-on-reflection* true) + +(defn ^String reverse + "Returns s with its characters reversed." + {:added "1.2"} + [^String s] + (clojure.lang.RT/StringReverse s)) ;;; (.toString (.reverse (StringBuilder. s)))) + +(defn ^String re-quote-replacement + "Given a replacement string that you wish to be a literal + replacement for a pattern match in replace or replace-first, do the + necessary escaping of special characters in the replacement." + {:added "1.5"} + [^String replacement] ;;; ^CharSequence + 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 ^Regex re s ;;; (let [m (re-matcher re s)] DM: Added ^Regex + ^MatchEvaluator (gen-delegate MatchEvaluator [m] (f (re-groups-direct m))))) ;;; (if (.find m) TODO: Figure out why the tag of ^MatchEvaluator does not help + ;;; (let [buffer (StringBuffer. (.length s))] + ;;; (loop [found true] + ;;; (if found + ;;; (do (.appendReplacement m buffer (Matcher/quoteReplacement (f (re-groups m)))) + ;;; (recur (.find m))) + ;;; (do (.appendTail m buffer) + ;;; (.toString buffer))))) + ;;; s))) + +(defn replace + "Replaces all instance of match with replacement in s. + + match/replacement can be: + + string / string + char / char + pattern / (string or function of match). + + See also replace-first. + + The replacement is literal (i.e. none of its characters are treated + specially) for all cases above except pattern / string. + + For pattern / string, $1, $2, etc. in the replacement string are + substituted with the string that matched the corresponding + parenthesized group in the pattern. If you wish your replacement + string r to be used literally, use (re-quote-replacement r) as the + replacement argument. See also documentation for + java.util.regex.Matcher's appendReplacement method. + + Example: + (clojure.string/replace \"Almost Pig Latin\" #\"\\b(\\w)(\\w+)\\b\" \"$2$1ay\") + -> \"lmostAay igPay atinLay\"" + {:added "1.2"} + [^String s 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 ^Regex 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 + +(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)) + (int 1))) ;;; rep (Matcher/quoteReplacement (f (re-groups m)))] + ;;; (.appendReplacement m buffer rep) + ;;; (.appendTail m buffer) + ;;; (str buffer)) + ;;; s))) + +(defn- replace-first-char + [^String s match replace] (let [match ^Char (char match)] ;;; Character hint on match + (let [ ;;; s (.toString s) + i (.IndexOf s match)] ;;; .indexOf (int match) + (if (= -1 i) + s + (str (subs s 0 i) replace (subs s (inc i)))))) ) + +(defn- replace-first-str + [^String s ^String match ^String replace] ;;; ^CharSequence + (let [ ;;; ^String s (.toString s) + i (.IndexOf s match)] ;;; .indexOf + (if (= -1 i) + s + (str (subs s 0 i) replace (subs s (+ i (.Length match))))))) ;;; .length + +(defn replace-first + "Replaces the first instance of match with replacement in s. + + match/replacement can be: + + char / char + string / string + pattern / (string or function of match). + + See also replace. + + The replacement is literal (i.e. none of its characters are treated + specially) for all cases above except pattern / string. + + For pattern / string, $1, $2, etc. in the replacement string are + substituted with the string that matched the corresponding + parenthesized group in the pattern. If you wish your replacement + string r to be used literally, use (re-quote-replacement r) as the + replacement argument. See also documentation for + java.util.regex.Matcher's appendReplacement method. + + Example: + (clojure.string/replace-first \"swap first two words\" + #\"(\\w+)(\\s+)(\\w+)\" \"$3$2$1\") + -> \"first swap two words\"" + + {:added "1.2"} + [^String s match replacement] + ;;;(let [s (.toString s)] + (cond + (instance? Char match) ;;; Character + (replace-first-char s ^Char match replacement) + (instance? String match) ;;; CharSequence + (replace-first-str s match ;;; (.toString ^CharSequence match) + replacement) ;;; (.toString ^CharSequence replacement) + (instance? Regex match) ;;; Pattern + (if (string? replacement) + (.Replace ^Regex match s ^String replacement 1) ;;; (.replaceFirst (re-matcher ^Pattern match s) ^String replacement) + (replace-first-by s match replacement)) + :else (throw (ArgumentException. (str "Invalid match arg: " match))))) ;;; IllegalArgumentException + + +(defn ^String join + "Returns a string of all elements in coll, as returned by (seq coll), + separated by an optional separator." + {:added "1.2"} + ([coll] + (apply str coll)) + ([separator coll] + (loop [sb (StringBuilder. (str (first coll))) + more (next coll) + sep (str separator)] + (if more + (recur (-> sb (.Append sep) (.Append (str (first more)))) ;;; .append + (next more) + sep) + (str sb))))) + +(defn ^String capitalize + "Converts first character of the string to upper-case, all other + characters to lower-case." + {:added "1.2"} + [^String s] ;;; ^CharSequence + (let [] ;;; [s (.toString s)] + (if (< (count s) 2) + (.ToUpper s) ;;; .toUpperCase + (str (.ToUpper ^String (subs s 0 1)) ;;; .toUpperCase + (.ToLower ^String (subs s 1)))))) ;;; .toLowerCase + +(defn ^String upper-case + "Converts string to all upper-case." + {:added "1.2"} + [^String s] + (.ToUpper s)) ;;; .toUpperCase + +(defn ^String lower-case + "Converts string to all lower-case." + {:added "1.2"} + [^String s] + (.ToLower s)) ;;; .toLowerCase + +(defn split + "Splits string on a regular expression. Optional argument limit is + the maximum number of parts. Not lazy. Returns vector of the parts. + Trailing empty strings are not returned - pass limit of -1 to return all." + {:added "1.2"} + ([^String s ^Regex re] ;;; ^Pattern + (LazilyPersistentVector/createOwning (.Split re s))) ;;; .split + ([^String s ^Regex re limit] ;;; ^Pattern + (LazilyPersistentVector/createOwning (.Split re s limit)))) ;;; .split + +(defn split-lines + "Splits s on \\n or \\r\\n. Trailing empty lines are not returned." + {:added "1.2"} + [^String s] + (split s #"\r?\n")) + +(defn ^String trim + "Removes whitespace from both ends of string." + {:added "1.2"} + [^String s] ;;; ^CharSequence + (let [len (.Length s)] ;;; .length + (loop [rindex len] + (if (zero? rindex) + "" + (if (Char/IsWhiteSpace (.get_Chars s (dec rindex))) ;;; Character/isWhitespace .charAt + (recur (dec rindex)) + ;; there is at least one non-whitespace char in the string, + ;; so no need to check for lindex reaching len. + (loop [lindex 0] + (if (Char/IsWhiteSpace (.get_Chars s lindex)) ;;; Character/isWhitespace .charAt + (recur (inc lindex)) + (.. s (Substring lindex (- rindex lindex)))))))))) ;;; (subSequence lindex rindex) toSTring + +(defn ^String triml + "Removes whitespace from the left side of string." + {:added "1.2"} + [^String s] ;;; ^CharSequence + (let [len (.Length s)] ;;; .length + (loop [index 0] + (if (= len index) + "" + (if (Char/IsWhiteSpace (.get_Chars s index)) ;;; Character/isWhitespace .charAt + (recur (unchecked-inc index)) + (.. s (Substring index))))))) ;;; (subSequence index len) toSTring + +(defn ^String trimr + "Removes whitespace from the right side of string." + {:added "1.2"} + [^String s] ;;; ^CharSequence + (loop [index (.Length s)] ;;; .length + (if (zero? index) + "" + (if (Char/IsWhiteSpace (.get_Chars s (unchecked-dec index))) ;;; Character/isWhitespace .charAt + (recur (unchecked-dec index)) + (.. s (Substring 0 index)))))) ;;; (subSequence 0 index) toSTring + +(defn ^String trim-newline + "Removes all trailing newline \\n or return \\r characters from + string. Similar to Perl's chomp." + {:added "1.2"} + [^String s] + (loop [index (.Length s)] ;;; .length + (if (zero? index) + "" + (let [ch (.get_Chars s (dec index))] ;;; .charAt + (if (or (= ch \newline) (= ch \return)) + (recur (dec index)) + (.Substring s 0 index)))))) ;;; .substring + +(defn blank? + "True if s is nil, empty, or contains only whitespace." + {:added "1.2"} + [^String s] ;;; CharSequence + (if s + (loop [index (int 0)] + (if (= (.Length s) index) ;;; .length + true + (if (Char/IsWhiteSpace (.get_Chars s index)) ;;; Character/isWhitespace .charAt + (recur (inc index)) + false))) + true)) + +(defn ^String escape + "Return a new string, using cmap to escape each character ch + from s as follows: + + If (cmap ch) is nil, append ch to the new string. + If (cmap ch) is non-nil, append (str (cmap ch)) instead." + {:added "1.2"} + [^String s cmap] ;;; CharSequence + (loop [index (int 0) + buffer (StringBuilder. (.Length s))] ;;; .length + (if (= (.Length s) index) ;;; .length + (.ToString buffer) ;;; .toString + (let [ch (.get_Chars s index)] ;;; .charAt + (if-let [replacement (cmap ch)] + (.Append buffer replacement) ;;; .append + (.Append buffer ch)) ;;; .append + (recur (inc index) buffer))))) + + +(defn- re-groups-direct + "similar to re-groups, but works on a Match directly, rather than JReMatcher" + [^Match m] + (let [strs (map #(.Value ^Group %) (.Groups ^Match m)) + cnt (count strs)] + (if (<= cnt 1) + (first strs) + (into [] strs)))) + +(defn index-of + "Return index of value (string or char) in s, optionally searching + forward from from-index. Return nil if value not found." + {:added "1.8"} + ([^String s value] ;;; ^CharSequence + (let [result ^long + (if (instance? Char value) ;;; ^Character + (.IndexOf s ^Char value) ;;; (.toString s) ^int(.charValue ^Character value) + (.IndexOf s ^String value))] ;;; (.toString s) + (if (= result -1) + nil + result))) + ([^String s value ^long from-index] ;;; ^CharSequence + (let [result ^long + (if (instance? Char value) ;;; ^Character + (.IndexOf s ^Char value (unchecked-int from-index)) ;;; (.toString s) ^int (.charValue ^Character value) + (.IndexOf s ^String value (unchecked-int from-index)))] ;;; (.toString s) + (if (= result -1) + nil + result)))) + +(defn last-index-of + "Return last index of value (string or char) in s, optionally + searching backward from from-index. Return nil if value not found." + {:added "1.8"} + ([^String s value] ;;; ^CharSequence + (let [result ^long + (if (instance? Char value) ;;; ^Character + (.LastIndexOf s ^Char value) ;;; (.toString s) ^int (.charValue ^Character value) + (.LastIndexOf s ^String value))] ;;; (.toString s) + (if (= result -1) + nil + result))) + ([^String s value ^long from-index] ;;; ^CharSequence + (let [result ^long + (if (instance? Char value) ;;; ^Character + (.LastIndexOf s ^Char value (unchecked-int from-index)) ;;; (.toString s) ^int (.charValue ^Character value) + (.LastIndexOf s ^String value (unchecked-int from-index)))] ;;; (.toString s) + (if (= result -1) + nil + result)))) + +(defn starts-with? + "True if s starts with substr." + {:added "1.8"} + [^String s ^String substr] ;;; ^CharSequence + (.StartsWith s substr)) ;;; (.toString s) + +(defn ends-with? + "True if s ends with substr." + {:added "1.8"} + [^String s ^String substr] ;;; ^CharSequence + (.EndsWith s substr)) ;;; (.toString s) + +(defn includes? + "True if s includes substr." + {:added "1.8"} + [^String s ^String substr] ;;; ^CharSequence (.Contains s substr)) ;;; (.toString s) \ No newline at end of file diff --git a/Clojure/Clojure.Source/clojure/template.clj b/Clojure/Clojure.Source/clojure/template.clj index b6ae35799..bda8eae40 100644 --- a/Clojure/Clojure.Source/clojure/template.clj +++ b/Clojure/Clojure.Source/clojure/template.clj @@ -22,8 +22,8 @@ ;; December 15, 2008: first version -(ns ^{:doc "Macros that expand to repeated copies of a template expression." - :author "Stuart Sierra"} +(ns ^{:doc "Macros that expand to repeated copies of a template expression." + :author "Stuart Sierra"} clojure.template (:require [clojure.walk :as walk])) diff --git a/Clojure/Clojure.Source/clojure/test.clj b/Clojure/Clojure.Source/clojure/test.clj index 2e437df29..21bc50d7a 100644 --- a/Clojure/Clojure.Source/clojure/test.clj +++ b/Clojure/Clojure.Source/clojure/test.clj @@ -16,7 +16,7 @@ (ns ^{:author "Stuart Sierra, with contributions and suggestions by - Chas Emerick, Allen Rohner, and Stuart Halloway", + Chas Emerick, Allen Rohner, and Stuart Halloway", :doc "A unit testing framework. ASSERTIONS @@ -281,11 +281,11 @@ (defn file-position "Returns a vector [filename line-number] for the nth call up the - stack. - - Deprecated in 1.2: The information needed for test reporting is - now on :file and :line keys in the result map." - {:added "1.1" + stack. + + Deprecated in 1.2: The information needed for test reporting is + now on :file and :line keys in the result map." + {:added "1.1" :deprecated "1.2"} [n] (let [^System.Diagnostics.StackFrame s (nth (.GetFrames (System.Diagnostics.StackTrace.)) n)] ;;; (let [^StackTraceElement s (nth (.getStackTrace (new java.lang.Throwable)) n)] @@ -296,7 +296,7 @@ in *testing-vars* as a list, then the source file and line of current assertion." {:added "1.1"} - [m] + [m] (let [{:keys [file line]} m] (str ;; Uncomment to include namespace in failure report: @@ -332,39 +332,39 @@ :added "1.1"} report :type) -(defn- file-and-line - {:deprecated "1.8"} - [^Exception exception depth] ;;; Throwable - (let [stacktrace (System.Diagnostics.StackTrace. exception true)] ;;; (.getStackTrace exception) - (if (< depth (.FrameCount stacktrace)) ;;; (count stacktrace) - (let [^System.Diagnostics.StackFrame s (.GetFrame stacktrace depth)] ;;; ^StackTraceElement (nth stacktrace depth) - {:file (.GetFileName s) :line (.GetFileLineNumber s)}) ;;; .getFileName .getLineNumber - {:file nil :line nil}))) - -(defn- stacktrace-file-and-line - [stacktrace] - (if (seq stacktrace) - (let [^System.Diagnostics.StackFrame s (first stacktrace)] ;;; ^StackTraceElement - {:file (.GetFileName s) :line (.GetFileLineNumber s)}) ;;; .getFileName .getLineNumber - {:file nil :line nil})) - -(defn do-report - "Add file and line information to a test result and call report. - If you are writing a custom assert-expr method, call this function - to pass test results to report." - {:added "1.2"} - [m] - (report - (case - (:type m) - :fail (merge (stacktrace-file-and-line (drop-while - #(let [cl-name (.FullName (.DeclaringType (.GetMethod ^System.Diagnostics.StackFrame %)))] ;;; .getClassName ^StackTraceElement - (or (str/starts-with? cl-name "System.") ;;; "java.lang."" - (str/starts-with? cl-name "clojure.test$") - (str/starts-with? cl-name "clojure.core$ex_info"))) - (.GetFrames (System.Diagnostics.StackTrace.)))) m) ;;; (.getStackTrace (Thread/currentThread)) - :error (merge (stacktrace-file-and-line (.GetFrames (System.Diagnostics.StackTrace. ^Exception (:actual m) true))) m) ;;; (.getStackTrace ^Throwable (:actual m)) - m))) +(defn- file-and-line + {:deprecated "1.8"} + [^Exception exception depth] ;;; Throwable + (let [stacktrace (System.Diagnostics.StackTrace. exception true)] ;;; (.getStackTrace exception) + (if (< depth (.FrameCount stacktrace)) ;;; (count stacktrace) + (let [^System.Diagnostics.StackFrame s (.GetFrame stacktrace depth)] ;;; ^StackTraceElement (nth stacktrace depth) + {:file (.GetFileName s) :line (.GetFileLineNumber s)}) ;;; .getFileName .getLineNumber + {:file nil :line nil}))) + +(defn- stacktrace-file-and-line + [stacktrace] + (if (seq stacktrace) + (let [^System.Diagnostics.StackFrame s (first stacktrace)] ;;; ^StackTraceElement + {:file (.GetFileName s) :line (.GetFileLineNumber s)}) ;;; .getFileName .getLineNumber + {:file nil :line nil})) + +(defn do-report + "Add file and line information to a test result and call report. + If you are writing a custom assert-expr method, call this function + to pass test results to report." + {:added "1.2"} + [m] + (report + (case + (:type m) + :fail (merge (stacktrace-file-and-line (drop-while + #(let [cl-name (.FullName (.DeclaringType (.GetMethod ^System.Diagnostics.StackFrame %)))] ;;; .getClassName ^StackTraceElement + (or (str/starts-with? cl-name "System.") ;;; "java.lang."" + (str/starts-with? cl-name "clojure.test$") + (str/starts-with? cl-name "clojure.core$ex_info"))) + (.GetFrames (System.Diagnostics.StackTrace.)))) m) ;;; (.getStackTrace (Thread/currentThread)) + :error (merge (stacktrace-file-and-line (.GetFrames (System.Diagnostics.StackTrace. ^Exception (:actual m) true))) m) ;;; (.getStackTrace ^Throwable (:actual m)) + m))) (defmethod report :default [m] (with-test-out (prn m))) @@ -374,11 +374,11 @@ (defmethod report :fail [m] (with-test-out - (inc-report-counter :fail) - (println "\nFAIL in" (testing-vars-str m)) - (when (seq *testing-contexts*) (println (testing-contexts-str))) - (when-let [message (:message m)] (println message)) - (println "expected:" (pr-str (:expected m))) + (inc-report-counter :fail) + (println "\nFAIL in" (testing-vars-str m)) + (when (seq *testing-contexts*) (println (testing-contexts-str))) + (when-let [message (:message m)] (println message)) + (println "expected:" (pr-str (:expected m))) (println " actual:" (pr-str (:actual m))))) (defmethod report :error [m] @@ -538,7 +538,7 @@ (defmacro try-expr "Used by the 'is' macro to catch unexpected exceptions. You don't call this." - {:added "1.0"} + {:added "1.0"} [msg form] `(try ~(assert-expr msg form) (catch Exception t# ;;; Throwable @@ -584,15 +584,15 @@ Note: This breaks some reporting features, such as line numbers." {:added "1.1"} [argv expr & args] - (if (or - ;; (are [] true) is meaningless but ok - (and (empty? argv) (empty? args)) - ;; Catch wrong number of args - (and (pos? (count argv)) - (pos? (count args)) - (zero? (mod (count args) (count argv))))) - `(temp/do-template ~argv (is ~expr) ~@args) - (throw (ArgumentException. "The number of args doesn't match are's argv.")))) ;;; .IllegalArgumentException + (if (or + ;; (are [] true) is meaningless but ok + (and (empty? argv) (empty? args)) + ;; Catch wrong number of args + (and (pos? (count argv)) + (pos? (count args)) + (zero? (mod (count args) (count argv))))) + `(temp/do-template ~argv (is ~expr) ~@args) + (throw (ArgumentException. "The number of args doesn't match are's argv.")))) ;;; .IllegalArgumentException (defmacro testing "Adds a new string to the list of testing contexts. May be nested, @@ -667,10 +667,10 @@ [key coll] (alter-meta! *ns* assoc key coll)) -(defmulti use-fixtures - "Wrap test runs in a fixture function to perform setup and - teardown. Using a fixture-type of :each wraps every test - individually, while :once wraps the whole run in a single function." +(defmulti use-fixtures + "Wrap test runs in a fixture function to perform setup and + teardown. Using a fixture-type of :each wraps every test + individually, while :once wraps the whole run in a single function." {:added "1.1"} (fn [fixture-type & args] fixture-type)) @@ -720,19 +720,19 @@ :expected nil, :actual e}))) (do-report {:type :end-test-var, :var v})))) -(defn test-vars - "Groups vars by their namespace and runs test-var on them with - appropriate fixtures applied." +(defn test-vars + "Groups vars by their namespace and runs test-var on them with + appropriate fixtures applied." {:added "1.6"} - [vars] - (doseq [[ns vars] (group-by (comp :ns meta) vars)] - (let [once-fixture-fn (join-fixtures (::once-fixtures (meta ns))) - each-fixture-fn (join-fixtures (::each-fixtures (meta ns)))] - (once-fixture-fn - (fn [] - (doseq [v vars] - (when (:test (meta v)) - (each-fixture-fn (fn [] (test-var v)))))))))) + [vars] + (doseq [[ns vars] (group-by (comp :ns meta) vars)] + (let [once-fixture-fn (join-fixtures (::once-fixtures (meta ns))) + each-fixture-fn (join-fixtures (::each-fixtures (meta ns)))] + (once-fixture-fn + (fn [] + (doseq [v vars] + (when (:test (meta v)) + (each-fixture-fn (fn [] (test-var v)))))))))) (defn test-all-vars "Calls test-vars on every var interned in the namespace, with fixtures." @@ -767,14 +767,14 @@ (defn run-tests "Runs all tests in the given namespaces; prints results. - Defaults to current namespace if none given. Returns a map - summarizing test results." + Defaults to current namespace if none given. Returns a map + summarizing test results." {:added "1.1"} ([] (run-tests *ns*)) ([& namespaces] - (let [summary (assoc (apply merge-with + (map test-ns namespaces) ) - :type :summary)] - (do-report summary) + (let [summary (assoc (apply merge-with + (map test-ns namespaces) ) + :type :summary)] + (do-report summary) summary))) (defn run-all-tests @@ -785,45 +785,45 @@ {:added "1.1"} ([] (apply run-tests (all-ns))) ([re] (apply run-tests (filter #(re-matches re (name (ns-name %))) (all-ns))))) - -(defn successful? - "Returns true if the given test summary indicates all tests - were successful, false otherwise." + +(defn successful? + "Returns true if the given test summary indicates all tests + were successful, false otherwise." {:added "1.1"} - [summary] - (and (zero? (:fail summary 0)) - (zero? (:error summary 0)))) - -(defn run-test-var - "Runs the tests for a single Var, with fixtures executed around the test, and summary output after." - {:added "1.11"} - [v] - (binding [*report-counters* (ref *initial-report-counters*)] - (let [ns-obj (-> v meta :ns) - summary (do - (do-report {:type :begin-test-ns - :ns ns-obj}) - (test-vars [v]) - (do-report {:type :end-test-ns - :ns ns-obj}) - (assoc @*report-counters* :type :summary))] - (do-report summary) - summary))) - -(defmacro run-test - "Runs a single test. - Because the intent is to run a single test, there is no check for the namespace test-ns-hook." - {:added "1.11"} - [test-symbol] - (let [test-var (resolve test-symbol)] - (cond - (nil? test-var) - (binding [*out* *err*] - (println "Unable to resolve" test-symbol "to a test function.")) - - (not (-> test-var meta :test)) - (binding [*out* *err*] - (println test-symbol "is not a test.")) - - :else + [summary] + (and (zero? (:fail summary 0)) + (zero? (:error summary 0)))) + +(defn run-test-var + "Runs the tests for a single Var, with fixtures executed around the test, and summary output after." + {:added "1.11"} + [v] + (binding [*report-counters* (ref *initial-report-counters*)] + (let [ns-obj (-> v meta :ns) + summary (do + (do-report {:type :begin-test-ns + :ns ns-obj}) + (test-vars [v]) + (do-report {:type :end-test-ns + :ns ns-obj}) + (assoc @*report-counters* :type :summary))] + (do-report summary) + summary))) + +(defmacro run-test + "Runs a single test. + Because the intent is to run a single test, there is no check for the namespace test-ns-hook." + {:added "1.11"} + [test-symbol] + (let [test-var (resolve test-symbol)] + (cond + (nil? test-var) + (binding [*out* *err*] + (println "Unable to resolve" test-symbol "to a test function.")) + + (not (-> test-var meta :test)) + (binding [*out* *err*] + (println test-symbol "is not a test.")) + + :else `(run-test-var ~test-var)))) \ No newline at end of file diff --git a/Clojure/Clojure.Source/clojure/test/junit.clj b/Clojure/Clojure.Source/clojure/test/junit.clj index 412a01d5e..004dbefe9 100644 --- a/Clojure/Clojure.Source/clojure/test/junit.clj +++ b/Clojure/Clojure.Source/clojure/test/junit.clj @@ -1,195 +1,195 @@ -; 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. - -;; test/junit.clj: Extension to clojure.test for JUnit-compatible XML output - -;; by Jason Sankey -;; June 2009 - -;; DOCUMENTATION -;; - -(ns ^{:doc "clojure.test extension for JUnit-compatible XML output. - - JUnit (http://junit.org/) is the most popular unit-testing library - for Java. As such, tool support for JUnit output formats is - common. By producing compatible output from tests, this tool - support can be exploited. - - To use, wrap any calls to clojure.test/run-tests in the - with-junit-output macro, like this: - - (use 'clojure.test) - (use 'clojure.test.junit) - - (with-junit-output - (run-tests 'my.cool.library)) - - To write the output to a file, rebind clojure.test/*test-out* to - your own PrintWriter (perhaps opened using - clojure.java.io/writer)." - :author "Jason Sankey"} - clojure.test.junit - (:require [clojure.stacktrace :as stack] - [clojure.test :as t])) - -;; copied from clojure.contrib.lazy-xml -(def ^{:private true} - escape-xml-map - (zipmap "'<>\"&" (map #(str \& % \;) '[apos lt gt quot amp]))) -(defn- escape-xml [text] - (apply str (map #(escape-xml-map % %) text))) - -(def ^:dynamic *var-context*) -(def ^:dynamic *depth*) - -(defn indent - [] - (dotimes [n (* *depth* 4)] (print " "))) - -(defn start-element - [tag pretty & [attrs]] - (if pretty (indent)) - (print (str "<" tag)) - (if (seq attrs) - (doseq [[key value] attrs] - (print (str " " (name key) "=\"" (escape-xml value) "\"")))) - (print ">") - (if pretty (println)) - (set! *depth* (inc *depth*))) - -(defn element-content - [content] - (print (escape-xml content))) - -(defn finish-element - [tag pretty] - (set! *depth* (dec *depth*)) - (if pretty (indent)) - (print (str "")) - (if pretty (println))) - -(defn test-name - [vars] - (apply str (interpose "." - (reverse (map #(:name (meta %)) vars))))) - -(defn package-class - [name] - (let [i (.LastIndexOf name ".")] ;;; lastIndexOf - (if (< i 0) - [nil name] - [(.Substring name 0 i) (.Substring name (+ i 1))]))) ;;; .substring - -(defn start-case - [name classname] - (start-element 'testcase true {:name name :classname classname})) - -(defn finish-case - [] - (finish-element 'testcase true)) - -(defn suite-attrs - [package classname] - (let [attrs {:name classname}] - (if package - (assoc attrs :package package) - attrs))) - -(defn start-suite - [name] - (let [[package classname] (package-class name)] - (start-element 'testsuite true (suite-attrs package classname)))) - -(defn finish-suite - [] - (finish-element 'testsuite true)) - -(defn message-el - [tag message expected-str actual-str] - (indent) - (start-element tag false (if message {:message message} {})) - (element-content - (let [[file line] (t/file-position 5) - detail (apply str (interpose - "\n" - [(str "expected: " expected-str) - (str " actual: " actual-str) - (str " at: " file ":" line)]))] - (if message (str message "\n" detail) detail))) - (finish-element tag false) - (println)) - -(defn failure-el - [message expected actual] - (message-el 'failure message (pr-str expected) (pr-str actual))) - -(defn error-el - [message expected actual] - (message-el 'error - message - (pr-str expected) - (if (instance? Exception actual) ;;; Throwable - (with-out-str (stack/print-cause-trace actual t/*stack-trace-depth*)) - (prn actual)))) - -;; This multimethod will override test-is/report -(defmulti ^:dynamic junit-report :type) - -(defmethod junit-report :begin-test-ns [m] - (t/with-test-out - (start-suite (name (ns-name (:ns m)))))) - -(defmethod junit-report :end-test-ns [_] - (t/with-test-out - (finish-suite))) - -(defmethod junit-report :begin-test-var [m] - (t/with-test-out - (let [var (:var m)] - (binding [*var-context* (conj *var-context* var)] - (start-case (test-name *var-context*) (name (ns-name (:ns (meta var))))))))) - -(defmethod junit-report :end-test-var [m] - (t/with-test-out - (finish-case))) - -(defmethod junit-report :pass [m] - (t/with-test-out - (t/inc-report-counter :pass))) - -(defmethod junit-report :fail [m] - (t/with-test-out - (t/inc-report-counter :fail) - (failure-el (:message m) - (:expected m) - (:actual m)))) - -(defmethod junit-report :error [m] - (t/with-test-out - (t/inc-report-counter :error) - (error-el (:message m) - (:expected m) - (:actual m)))) - -(defmethod junit-report :default [_]) - -(defmacro with-junit-output - "Execute body with modified test-is reporting functions that write - JUnit-compatible XML output." +; 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. + +;; test/junit.clj: Extension to clojure.test for JUnit-compatible XML output + +;; by Jason Sankey +;; June 2009 + +;; DOCUMENTATION +;; + +(ns ^{:doc "clojure.test extension for JUnit-compatible XML output. + + JUnit (http://junit.org/) is the most popular unit-testing library + for Java. As such, tool support for JUnit output formats is + common. By producing compatible output from tests, this tool + support can be exploited. + + To use, wrap any calls to clojure.test/run-tests in the + with-junit-output macro, like this: + + (use 'clojure.test) + (use 'clojure.test.junit) + + (with-junit-output + (run-tests 'my.cool.library)) + + To write the output to a file, rebind clojure.test/*test-out* to + your own PrintWriter (perhaps opened using + clojure.java.io/writer)." + :author "Jason Sankey"} + clojure.test.junit + (:require [clojure.stacktrace :as stack] + [clojure.test :as t])) + +;; copied from clojure.contrib.lazy-xml +(def ^{:private true} + escape-xml-map + (zipmap "'<>\"&" (map #(str \& % \;) '[apos lt gt quot amp]))) +(defn- escape-xml [text] + (apply str (map #(escape-xml-map % %) text))) + +(def ^:dynamic *var-context*) +(def ^:dynamic *depth*) + +(defn indent + [] + (dotimes [n (* *depth* 4)] (print " "))) + +(defn start-element + [tag pretty & [attrs]] + (if pretty (indent)) + (print (str "<" tag)) + (if (seq attrs) + (doseq [[key value] attrs] + (print (str " " (name key) "=\"" (escape-xml value) "\"")))) + (print ">") + (if pretty (println)) + (set! *depth* (inc *depth*))) + +(defn element-content + [content] + (print (escape-xml content))) + +(defn finish-element + [tag pretty] + (set! *depth* (dec *depth*)) + (if pretty (indent)) + (print (str "")) + (if pretty (println))) + +(defn test-name + [vars] + (apply str (interpose "." + (reverse (map #(:name (meta %)) vars))))) + +(defn package-class + [name] + (let [i (.LastIndexOf name ".")] ;;; lastIndexOf + (if (< i 0) + [nil name] + [(.Substring name 0 i) (.Substring name (+ i 1))]))) ;;; .substring + +(defn start-case + [name classname] + (start-element 'testcase true {:name name :classname classname})) + +(defn finish-case + [] + (finish-element 'testcase true)) + +(defn suite-attrs + [package classname] + (let [attrs {:name classname}] + (if package + (assoc attrs :package package) + attrs))) + +(defn start-suite + [name] + (let [[package classname] (package-class name)] + (start-element 'testsuite true (suite-attrs package classname)))) + +(defn finish-suite + [] + (finish-element 'testsuite true)) + +(defn message-el + [tag message expected-str actual-str] + (indent) + (start-element tag false (if message {:message message} {})) + (element-content + (let [[file line] (t/file-position 5) + detail (apply str (interpose + "\n" + [(str "expected: " expected-str) + (str " actual: " actual-str) + (str " at: " file ":" line)]))] + (if message (str message "\n" detail) detail))) + (finish-element tag false) + (println)) + +(defn failure-el + [message expected actual] + (message-el 'failure message (pr-str expected) (pr-str actual))) + +(defn error-el + [message expected actual] + (message-el 'error + message + (pr-str expected) + (if (instance? Exception actual) ;;; Throwable + (with-out-str (stack/print-cause-trace actual t/*stack-trace-depth*)) + (prn actual)))) + +;; This multimethod will override test-is/report +(defmulti ^:dynamic junit-report :type) + +(defmethod junit-report :begin-test-ns [m] + (t/with-test-out + (start-suite (name (ns-name (:ns m)))))) + +(defmethod junit-report :end-test-ns [_] + (t/with-test-out + (finish-suite))) + +(defmethod junit-report :begin-test-var [m] + (t/with-test-out + (let [var (:var m)] + (binding [*var-context* (conj *var-context* var)] + (start-case (test-name *var-context*) (name (ns-name (:ns (meta var))))))))) + +(defmethod junit-report :end-test-var [m] + (t/with-test-out + (finish-case))) + +(defmethod junit-report :pass [m] + (t/with-test-out + (t/inc-report-counter :pass))) + +(defmethod junit-report :fail [m] + (t/with-test-out + (t/inc-report-counter :fail) + (failure-el (:message m) + (:expected m) + (:actual m)))) + +(defmethod junit-report :error [m] + (t/with-test-out + (t/inc-report-counter :error) + (error-el (:message m) + (:expected m) + (:actual m)))) + +(defmethod junit-report :default [_]) + +(defmacro with-junit-output + "Execute body with modified test-is reporting functions that write + JUnit-compatible XML output." {:added "1.1"} - [& body] - `(binding [t/report junit-report - *var-context* (list) - *depth* 1] - (t/with-test-out - (println "") - (println "")) - (let [result# (do ~@body)] - (t/with-test-out (println "")) - result#))) + [& body] + `(binding [t/report junit-report + *var-context* (list) + *depth* 1] + (t/with-test-out + (println "") + (println "")) + (let [result# (do ~@body)] + (t/with-test-out (println "")) + result#))) diff --git a/Clojure/Clojure.Source/clojure/test/tap.clj b/Clojure/Clojure.Source/clojure/test/tap.clj index e958c5074..64b4c53d0 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])) @@ -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.Source/clojure/walk.clj b/Clojure/Clojure.Source/clojure/walk.clj index 42f384505..07b1757aa 100644 --- a/Clojure/Clojure.Source/clojure/walk.clj +++ b/Clojure/Clojure.Source/clojure/walk.clj @@ -42,11 +42,11 @@ the sorting function."} [inner outer form] (cond (list? form) (outer (apply list (map inner form))) - (instance? clojure.lang.IMapEntry form) + (instance? clojure.lang.IMapEntry form) (outer (clojure.lang.MapEntry/create (inner (key form)) (inner (val form)))) (instance? System.Collections.DictionaryEntry form) (outer [(inner (.Key ^System.Collections.DictionaryEntry form)) (inner (.Value ^System.Collections.DictionaryEntry form))]) (seq? form) (outer (doall (map inner form))) - (instance? clojure.lang.IRecord form) + (instance? clojure.lang.IRecord form) (outer (reduce (fn [r x] (conj r (inner x))) form form)) (coll? form) (outer (into (empty form) (map inner form))) :else (outer form))) diff --git a/Clojure/Clojure.Source/clojure/zip.clj b/Clojure/Clojure.Source/clojure/zip.clj index 99b3856c3..bd6095d95 100644 --- a/Clojure/Clojure.Source/clojure/zip.clj +++ b/Clojure/Clojure.Source/clojure/zip.clj @@ -9,10 +9,10 @@ ;functional hierarchical zipper, with navigation, editing and enumeration ;see Huet -(ns ^{:doc "Functional hierarchical zipper, with navigation, editing, - and enumeration. See Huet" - :author "Rich Hickey"} - clojure.zip +(ns ^{:doc "Functional hierarchical zipper, with navigation, editing, + and enumeration. See Huet" + :author "Rich Hickey"} + clojure.zip (:refer-clojure :exclude (replace remove next))) (defn zipper @@ -27,14 +27,14 @@ make-node is a fn that, given an existing node and a seq of children, returns a new branch node with the supplied children. root is the root node." - {:added "1.0"} + {:added "1.0"} [branch? children make-node root] ^{:zip/branch? branch? :zip/children children :zip/make-node make-node} [root nil]) (defn seq-zip "Returns a zipper for nested sequences, given a root sequence" - {:added "1.0"} + {:added "1.0"} [root] (zipper seq? identity @@ -43,7 +43,7 @@ (defn vector-zip "Returns a zipper for nested vectors, given a root vector" - {:added "1.0"} + {:added "1.0"} [root] (zipper vector? seq @@ -53,7 +53,7 @@ (defn xml-zip "Returns a zipper for xml elements (as from xml/parse), given a root element" - {:added "1.0"} + {:added "1.0"} [root] (zipper (complement string?) (comp seq :content) @@ -63,45 +63,45 @@ (defn node "Returns the node at loc" - {:added "1.0"} + {:added "1.0"} [loc] (loc 0)) (defn branch? "Returns true if the node at loc is a branch" - {:added "1.0"} + {:added "1.0"} [loc] ((:zip/branch? (meta loc)) (node loc))) (defn children "Returns a seq of the children of node at loc, which must be a branch" - {:added "1.0"} + {:added "1.0"} [loc] - (if (branch? loc) - ((:zip/children (meta loc)) (node loc)) + (if (branch? loc) + ((:zip/children (meta loc)) (node loc)) (throw (Exception. "called children on a leaf node")))) (defn make-node "Returns a new branch node, given an existing node and new children. The loc is only used to supply the constructor." - {:added "1.0"} + {:added "1.0"} [loc node children] ((:zip/make-node (meta loc)) node children)) (defn path "Returns a seq of nodes leading to this loc" - {:added "1.0"} + {:added "1.0"} [loc] (:pnodes (loc 1))) (defn lefts "Returns a seq of the left siblings of this loc" - {:added "1.0"} + {:added "1.0"} [loc] (seq (:l (loc 1)))) (defn rights "Returns a seq of the right siblings of this loc" - {:added "1.0"} + {:added "1.0"} [loc] (:r (loc 1))) @@ -109,21 +109,21 @@ (defn down "Returns the loc of the leftmost child of the node at this loc, or nil if no children" - {:added "1.0"} + {:added "1.0"} [loc] - (when (branch? loc) - (let [[node path] loc - [c & cnext :as cs] (children loc)] - (when cs - (with-meta [c {:l [] - :pnodes (if path (conj (:pnodes path) node) [node]) - :ppath path + (when (branch? loc) + (let [[node path] loc + [c & cnext :as cs] (children loc)] + (when cs + (with-meta [c {:l [] + :pnodes (if path (conj (:pnodes path) node) [node]) + :ppath path :r cnext}] (meta loc)))))) (defn up "Returns the loc of the parent of the node at this loc, or nil if at the top" - {:added "1.0"} + {:added "1.0"} [loc] (let [[node {l :l, ppath :ppath, pnodes :pnodes r :r, changed? :changed?, :as path}] loc] (when pnodes @@ -137,7 +137,7 @@ (defn root "zips all the way up and returns the root node, reflecting any changes." - {:added "1.0"} + {:added "1.0"} [loc] (if (= :end (loc 1)) (node loc) @@ -148,7 +148,7 @@ (defn right "Returns the loc of the right sibling of the node at this loc, or nil" - {:added "1.0"} + {:added "1.0"} [loc] (let [[node {l :l [r & rnext :as rs] :r :as path}] loc] (when (and path rs) @@ -156,7 +156,7 @@ (defn rightmost "Returns the loc of the rightmost sibling of the node at this loc, or self" - {:added "1.0"} + {:added "1.0"} [loc] (let [[node {l :l r :r :as path}] loc] (if (and path r) @@ -165,7 +165,7 @@ (defn left "Returns the loc of the left sibling of the node at this loc, or nil" - {:added "1.0"} + {:added "1.0"} [loc] (let [[node {l :l r :r :as path}] loc] (when (and path (seq l)) @@ -173,7 +173,7 @@ (defn leftmost "Returns the loc of the leftmost sibling of the node at this loc, or self" - {:added "1.0"} + {:added "1.0"} [loc] (let [[node {l :l r :r :as path}] loc] (if (and path (seq l)) @@ -183,7 +183,7 @@ (defn insert-left "Inserts the item as the left sibling of the node at this loc, without moving" - {:added "1.0"} + {:added "1.0"} [loc item] (let [[node {l :l :as path}] loc] (if (nil? path) @@ -193,7 +193,7 @@ (defn insert-right "Inserts the item as the right sibling of the node at this loc, without moving" - {:added "1.0"} + {:added "1.0"} [loc item] (let [[node {r :r :as path}] loc] (if (nil? path) @@ -202,28 +202,28 @@ (defn replace "Replaces the node at this loc, without moving" - {:added "1.0"} + {:added "1.0"} [loc node] (let [[_ path] loc] (with-meta [node (assoc path :changed? true)] (meta loc)))) (defn edit "Replaces the node at this loc with the value of (f node args)" - {:added "1.0"} + {:added "1.0"} [loc f & args] (replace loc (apply f (node loc) args))) (defn insert-child "Inserts the item as the leftmost child of the node at this loc, without moving" - {:added "1.0"} + {:added "1.0"} [loc item] (replace loc (make-node loc (node loc) (cons item (children loc))))) (defn append-child "Inserts the item as the rightmost child of the node at this loc, without moving" - {:added "1.0"} + {:added "1.0"} [loc item] (replace loc (make-node loc (node loc) (concat (children loc) [item])))) @@ -231,7 +231,7 @@ "Moves to the next loc in the hierarchy, depth-first. When reaching the end, returns a distinguished loc detectable via end?. If already at the end, stays there." - {:added "1.0"} + {:added "1.0"} [loc] (if (= :end (loc 1)) loc @@ -246,7 +246,7 @@ (defn prev "Moves to the previous loc in the hierarchy, depth-first. If already at the root, returns nil." - {:added "1.0"} + {:added "1.0"} [loc] (if-let [lloc (left loc)] (loop [loc lloc] @@ -257,14 +257,14 @@ (defn end? "Returns true if loc represents the end of a depth-first walk" - {:added "1.0"} + {:added "1.0"} [loc] (= :end (loc 1))) (defn remove "Removes the node at loc, returning the loc that would have preceded it in a depth-first walk." - {:added "1.0"} + {:added "1.0"} [loc] (let [[node {l :l, ppath :ppath, pnodes :pnodes, rs :r, :as path}] loc] (if (nil? path) diff --git a/Clojure/Clojure.Tests/ReflectorTryCatchFixture.cs b/Clojure/Clojure.Tests/ReflectorTryCatchFixture.cs index 43b023c28..c9d86fbb6 100644 --- a/Clojure/Clojure.Tests/ReflectorTryCatchFixture.cs +++ b/Clojure/Clojure.Tests/ReflectorTryCatchFixture.cs @@ -1,53 +1,53 @@ -/** - * 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; - -namespace clojure.test -{ - // This is pretty irrelevant for CLR. Trying to deal with checked exceptions in the JVM code. - // But no harm in matching their code. - - public class ReflectorTryCatchFixture - { - [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE1006:Naming Styles", Justification = "ClojureJVM name match")] - [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE0060:Remove unused parameter", Justification = "Part of API")] - public static void fail(long x) - { - throw new Cookies("Long"); - } - - [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE1006:Naming Styles", Justification = "ClojureJVM name match")] - [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE0060:Remove unused parameter", Justification = "Part of API")] - public static void fail(double y) - { - throw new Cookies("Double"); - } - - [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE1006:Naming Styles", Justification = "ClojureJVM name match")] - [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE0060:Remove unused parameter", Justification = "Part of API")] - public void failWithCause(Double y) - { - throw new Cookies("Wrapped", new Cookies("Cause")); - } - - - [Serializable] - public sealed class Cookies : Exception - { - public Cookies(String msg) : base(msg) { } - public Cookies(String msg, Exception cause) : base(msg, cause) { } - } - } -} +/** + * 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; + +namespace clojure.test +{ + // This is pretty irrelevant for CLR. Trying to deal with checked exceptions in the JVM code. + // But no harm in matching their code. + + public class ReflectorTryCatchFixture + { + [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE1006:Naming Styles", Justification = "ClojureJVM name match")] + [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE0060:Remove unused parameter", Justification = "Part of API")] + public static void fail(long x) + { + throw new Cookies("Long"); + } + + [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE1006:Naming Styles", Justification = "ClojureJVM name match")] + [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE0060:Remove unused parameter", Justification = "Part of API")] + public static void fail(double y) + { + throw new Cookies("Double"); + } + + [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE1006:Naming Styles", Justification = "ClojureJVM name match")] + [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE0060:Remove unused parameter", Justification = "Part of API")] + public void failWithCause(Double y) + { + throw new Cookies("Wrapped", new Cookies("Cause")); + } + + + [Serializable] + public sealed class Cookies : Exception + { + public Cookies(String msg) : base(msg) { } + public Cookies(String msg, Exception cause) : base(msg, cause) { } + } + } +} diff --git a/Clojure/Clojure.Tests/clojure/run_test.clj b/Clojure/Clojure.Tests/clojure/run_test.clj index d5eb8f193..4de457f2d 100644 --- a/Clojure/Clojure.Tests/clojure/run_test.clj +++ b/Clojure/Clojure.Tests/clojure/run_test.clj @@ -1,16 +1,16 @@ -(assembly-load-from "clojure.tools.namespace.dll") -(assembly-load-from "clojure.tools.reader.dll") +(assembly-load-from "clojure.tools.namespace.dll") +(assembly-load-from "clojure.tools.reader.dll") (assembly-load-from "clojure.data.generators.dll") -(assembly-load-from "clojure.test.generative.dll") -(assembly-load-from "clojure.test.check.dll") - -;;;(System/setProperty "java.awt.headless" "true") -(require - '[clojure.test :as test] - '[clojure.tools.namespace.find :as ns]) -(def namespaces (remove (read-string (or (System.Environment/GetEnvironmentVariable "clojure.test-clojure.exclude-namespaces") "#{}")) ;;; System/getProperty Added the or - (ns/find-namespaces-in-dir (System.IO.DirectoryInfo. "clojure/test_clojure")))) ;;; (java.io.File. "test")(doseq [ns namespaces] (require ns)) -(doseq [ns namespaces] (require ns)) -(let [summary (apply test/run-tests namespaces)] - (print summary) +(assembly-load-from "clojure.test.generative.dll") +(assembly-load-from "clojure.test.check.dll") + +;;;(System/setProperty "java.awt.headless" "true") +(require + '[clojure.test :as test] + '[clojure.tools.namespace.find :as ns]) +(def namespaces (remove (read-string (or (System.Environment/GetEnvironmentVariable "clojure.test-clojure.exclude-namespaces") "#{}")) ;;; System/getProperty Added the or + (ns/find-namespaces-in-dir (System.IO.DirectoryInfo. "clojure/test_clojure")))) ;;; (java.io.File. "test")(doseq [ns namespaces] (require ns)) +(doseq [ns namespaces] (require ns)) +(let [summary (apply test/run-tests namespaces)] + (print summary) (Environment/Exit (if (test/successful? summary) 0 -1))) ;;; System/exit \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/run_test_generative.clj b/Clojure/Clojure.Tests/clojure/run_test_generative.clj index 756be3967..c2528bd8d 100644 --- a/Clojure/Clojure.Tests/clojure/run_test_generative.clj +++ b/Clojure/Clojure.Tests/clojure/run_test_generative.clj @@ -3,7 +3,7 @@ (assembly-load-from "clojure.tools.namespace.dll") (assembly-load-from "clojure.data.generators.dll") (assembly-load-from "clojure.test.generative.dll") -(assembly-load-from "clojure.test.check.dll") +(assembly-load-from "clojure.test.check.dll") (when-not (System.Environment/GetEnvironmentVariable "clojure.test.generative.msec") ;;; System/getProperty (System.Environment/SetEnvironmentVariable "clojure.test.generative.msec" "60000")) ;;; System/setProperty @@ -21,34 +21,34 @@ ; unfortunately, I need a private function to make even that happen. -(defn ns-tests - "Returns all tests in namespaces" - [nses] - (let [load (fn [s] (require s) s)] - (->> nses - (map load) - (apply #'runner/find-vars-in-namespaces) +(defn ns-tests + "Returns all tests in namespaces" + [nses] + (let [load (fn [s] (require s) s)] + (->> nses + (map load) + (apply #'runner/find-vars-in-namespaces) (mapcat runner/get-tests)))) -(defn my-runner - "modifed form runner/-main" - [& nses] - (if (seq nses) - (try - (let [result (runner/run-suite (runner/config) (ns-tests nses))] - (println "\n" result) - (Environment/Exit (:failures result))) ;;; System/exit - (catch Exception t ;;; Throwable - (prn (str "Exception: " (.Message t))) - (clr/print-stack-trace t) ;;; (.printStackTrace t) - (Environment/Exit -1)) ;;; System/exit - (finally - (shutdown-agents))) - (do - (println "Specify at least one namespace with tests") +(defn my-runner + "modifed form runner/-main" + [& nses] + (if (seq nses) + (try + (let [result (runner/run-suite (runner/config) (ns-tests nses))] + (println "\n" result) + (Environment/Exit (:failures result))) ;;; System/exit + (catch Exception t ;;; Throwable + (prn (str "Exception: " (.Message t))) + (clr/print-stack-trace t) ;;; (.printStackTrace t) + (Environment/Exit -1)) ;;; System/exit + (finally + (shutdown-agents))) + (do + (println "Specify at least one namespace with tests") (Environment/Exit -1)))) -(def namespaces (remove (read-string (or (System.Environment/GetEnvironmentVariable "clojure.test-clojure.exclude-namespaces") "#{}")) +(def namespaces (remove (read-string (or (System.Environment/GetEnvironmentVariable "clojure.test-clojure.exclude-namespaces") "#{}")) (ns/find-namespaces-in-dir (System.IO.DirectoryInfo. "clojure/test_clojure")))) diff --git a/Clojure/Clojure.Tests/clojure/run_test_generative_i.clj b/Clojure/Clojure.Tests/clojure/run_test_generative_i.clj index 79914904e..463e82c63 100644 --- a/Clojure/Clojure.Tests/clojure/run_test_generative_i.clj +++ b/Clojure/Clojure.Tests/clojure/run_test_generative_i.clj @@ -1,8 +1,8 @@ -(assembly-load-from "clojure.tools.reader.dll") +(assembly-load-from "clojure.tools.reader.dll") (assembly-load-from "clojure.tools.namespace.dll") (assembly-load-from "clojure.data.generators.dll") (assembly-load-from "clojure.test.generative.dll") -(assembly-load-from "clojure.test.check.dll") +(assembly-load-from "clojure.test.check.dll") (when-not (System.Environment/GetEnvironmentVariable "clojure.test.generative.msec") ;;; System/getProperty (System.Environment/SetEnvironmentVariable "clojure.test.generative.msec" "60000")) ;;; System/setProperty @@ -27,32 +27,32 @@ ; unfortunately, I need a private function to make even that happen. -(defn ns-tests - "Returns all tests in namespaces" - [nses] - (let [load (fn [s] (require s) s)] - (->> nses - (map load) - (apply #'runner/find-vars-in-namespaces) +(defn ns-tests + "Returns all tests in namespaces" + [nses] + (let [load (fn [s] (require s) s)] + (->> nses + (map load) + (apply #'runner/find-vars-in-namespaces) (mapcat runner/get-tests)))) -(defn my-runner - "modifed form runner/-main" - [& nses] - (if (seq nses) - (try - (let [result (runner/run-suite (runner/config) (ns-tests nses))] - (println "\n" result) - (Environment/Exit (:failures result))) ;;; System/exit - (catch Exception t ;;; Throwable - (prn (str "Exception: " (.Message t))) - (clr/print-stack-trace t)) ;;; System/exit - (finally - (shutdown-agents))) - (do +(defn my-runner + "modifed form runner/-main" + [& nses] + (if (seq nses) + (try + (let [result (runner/run-suite (runner/config) (ns-tests nses))] + (println "\n" result) + (Environment/Exit (:failures result))) ;;; System/exit + (catch Exception t ;;; Throwable + (prn (str "Exception: " (.Message t))) + (clr/print-stack-trace t)) ;;; System/exit + (finally + (shutdown-agents))) + (do (println "Specify at least one namespace with tests")))) -(def namespaces (remove (read-string (or (System.Environment/GetEnvironmentVariable "clojure.test-clojure.exclude-namespaces") "#{}")) +(def namespaces (remove (read-string (or (System.Environment/GetEnvironmentVariable "clojure.test-clojure.exclude-namespaces") "#{}")) (ns/find-namespaces-in-dir (System.IO.DirectoryInfo. "clojure/test_clojure")))) (apply my-runner namespaces) diff --git a/Clojure/Clojure.Tests/clojure/run_test_i.clj b/Clojure/Clojure.Tests/clojure/run_test_i.clj index 125fd30a7..bc28fb708 100644 --- a/Clojure/Clojure.Tests/clojure/run_test_i.clj +++ b/Clojure/Clojure.Tests/clojure/run_test_i.clj @@ -1,15 +1,15 @@ -(assembly-load-from "clojure.tools.reader.dll") -(assembly-load-from "clojure.tools.namespace.dll") +(assembly-load-from "clojure.tools.reader.dll") +(assembly-load-from "clojure.tools.namespace.dll") (assembly-load-from "clojure.data.generators.dll") -(assembly-load-from "clojure.test.generative.dll") -(assembly-load-from "clojure.test.check.dll") - -;;;(System/setProperty "java.awt.headless" "true") -(require - '[clojure.test :as test] - '[clojure.tools.namespace.find :as ns]) -(def namespaces (remove (read-string (or (System.Environment/GetEnvironmentVariable "clojure.test-clojure.exclude-namespaces") "#{}")) ;;; System/getProperty Added the or - (ns/find-namespaces-in-dir (System.IO.DirectoryInfo. "clojure/test_clojure")))) ;;; (java.io.File. "test") -(doseq [ns namespaces] (require ns)) -(let [summary (apply test/run-tests namespaces)] +(assembly-load-from "clojure.test.generative.dll") +(assembly-load-from "clojure.test.check.dll") + +;;;(System/setProperty "java.awt.headless" "true") +(require + '[clojure.test :as test] + '[clojure.tools.namespace.find :as ns]) +(def namespaces (remove (read-string (or (System.Environment/GetEnvironmentVariable "clojure.test-clojure.exclude-namespaces") "#{}")) ;;; System/getProperty Added the or + (ns/find-namespaces-in-dir (System.IO.DirectoryInfo. "clojure/test_clojure")))) ;;; (java.io.File. "test") +(doseq [ns namespaces] (require ns)) +(let [summary (apply test/run-tests namespaces)] (print summary)) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/agents.clj b/Clojure/Clojure.Tests/clojure/test_clojure/agents.clj index 4649c2671..6e38f3cde 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/agents.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/agents.clj @@ -154,34 +154,34 @@ (.Join)) (is (= @a :thread-binding)))) -;; check for a race condition that was causing seque to leak threads from the -;; send-off pool. Specifically, if we consume all items from the seque, and -;; the LBQ continues to grow, it means there was an agent action blocking on -;; the .put, which would block indefinitely outside of this test. -;;;(deftest seque-threads -;;; (let [queue-size 5 -;;; slow-seq (for [x (take (* 2 queue-size) (iterate inc 0))] -;;; (do (Thread/sleep 25) -;;; x)) -;;; small-lbq (java.util.concurrent.LinkedBlockingQueue. queue-size) -;;; worker (seque small-lbq slow-seq)] -;;; (dorun worker) -;;; (is (= worker slow-seq)) -;;; (Thread/sleep 250) ;; make sure agents have time to run or get blocked -;;; (let [queue-backlog (.size small-lbq)] -;;; (is (<= 0 queue-backlog queue-size)) -;;; (when-not (zero? queue-backlog) -;;; (.take small-lbq) -;;; (Thread/sleep 250) ;; see if agent was blocking, indicating a thread leak -;;; (is (= (.size small-lbq) +;; check for a race condition that was causing seque to leak threads from the +;; send-off pool. Specifically, if we consume all items from the seque, and +;; the LBQ continues to grow, it means there was an agent action blocking on +;; the .put, which would block indefinitely outside of this test. +;;;(deftest seque-threads +;;; (let [queue-size 5 +;;; slow-seq (for [x (take (* 2 queue-size) (iterate inc 0))] +;;; (do (Thread/sleep 25) +;;; x)) +;;; small-lbq (java.util.concurrent.LinkedBlockingQueue. queue-size) +;;; worker (seque small-lbq slow-seq)] +;;; (dorun worker) +;;; (is (= worker slow-seq)) +;;; (Thread/sleep 250) ;; make sure agents have time to run or get blocked +;;; (let [queue-backlog (.size small-lbq)] +;;; (is (<= 0 queue-backlog queue-size)) +;;; (when-not (zero? queue-backlog) +;;; (.take small-lbq) +;;; (Thread/sleep 250) ;; see if agent was blocking, indicating a thread leak +;;; (is (= (.size small-lbq) ;;; (dec queue-backlog))))))) -;; Check for a deadlock condition when one seque was fed into another -;; seque. Note that this test does not throw an exception or -;; otherwise fail if the issue is not fixed -- it simply deadlocks and -;; hangs until killed. -;;;(deftest seque-into-seque-deadlock -;;; (is (= (range 10) (seque 3 (seque 3 (range 10)))))) +;; Check for a deadlock condition when one seque was fed into another +;; seque. Note that this test does not throw an exception or +;; otherwise fail if the issue is not fixed -- it simply deadlocks and +;; hangs until killed. +;;;(deftest seque-into-seque-deadlock +;;; (is (= (range 10) (seque 3 (seque 3 (range 10)))))) ; http://clojure.org/agents diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/api.clj b/Clojure/Clojure.Tests/clojure/test_clojure/api.clj index cd7028bbc..79fef9bc3 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/api.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/api.clj @@ -1,53 +1,53 @@ -; 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. - -(ns clojure.test-clojure.api - (:require [clojure.test.generative :refer (defspec)] - [clojure.test-clojure.generators :as cgen]) - (:import clojure.lang.IFn - clojure.clr.api.Clojure ;;; clojure.java.api.Clojure - clojure.lang.Var)) - -(set! *warn-on-reflection* true) - -(defn roundtrip - "Print an object and read it back with Clojure/read" - [o] - (binding [*print-length* nil - *print-dup* nil - *print-level* nil] - (Clojure/read (pr-str o)))) - -(defn api-var-str - [^Var v] - (Clojure/var (str (.Name (.ns v))) ;;; .name - (str (.sym v)))) - -(defn api-var - [^Var v] - (Clojure/var (.Name (.ns v)) ;;; .name - (.sym v))) - -(defspec api-can-read - roundtrip - [^{:tag cgen/ednable} o] - (when-not (= o %) - (throw (ex-info "Value cannot roundtrip with Clojure/read" {:printed o :read %})))) - -(defspec api-can-find-var - api-var - [^{:tag cgen/var} v] - (when-not (= v %) - (throw (ex-info "Var cannot roundtrip through Clojure/var" {:from v :to %})))) - -(defspec api-can-find-var-str - api-var-str - [^{:tag cgen/var} v] - (when-not (= v %) - (throw (ex-info "Var cannot roundtrip strings through Clojure/var" {:from v :to %})))) - +; 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. + +(ns clojure.test-clojure.api + (:require [clojure.test.generative :refer (defspec)] + [clojure.test-clojure.generators :as cgen]) + (:import clojure.lang.IFn + clojure.clr.api.Clojure ;;; clojure.java.api.Clojure + clojure.lang.Var)) + +(set! *warn-on-reflection* true) + +(defn roundtrip + "Print an object and read it back with Clojure/read" + [o] + (binding [*print-length* nil + *print-dup* nil + *print-level* nil] + (Clojure/read (pr-str o)))) + +(defn api-var-str + [^Var v] + (Clojure/var (str (.Name (.ns v))) ;;; .name + (str (.sym v)))) + +(defn api-var + [^Var v] + (Clojure/var (.Name (.ns v)) ;;; .name + (.sym v))) + +(defspec api-can-read + roundtrip + [^{:tag cgen/ednable} o] + (when-not (= o %) + (throw (ex-info "Value cannot roundtrip with Clojure/read" {:printed o :read %})))) + +(defspec api-can-find-var + api-var + [^{:tag cgen/var} v] + (when-not (= v %) + (throw (ex-info "Var cannot roundtrip through Clojure/var" {:from v :to %})))) + +(defspec api-can-find-var-str + api-var-str + [^{:tag cgen/var} v] + (when-not (= v %) + (throw (ex-info "Var cannot roundtrip strings through Clojure/var" {:from v :to %})))) + diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/atoms.clj b/Clojure/Clojure.Tests/clojure/test_clojure/atoms.clj index fce705933..c340e1b30 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/atoms.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/atoms.clj @@ -1,44 +1,44 @@ -; 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: Frantisek Sodomka - -(ns clojure.test-clojure.atoms - (:use clojure.test)) - -; http://clojure.org/atoms - -; atom -; deref, @-reader-macro -; swap! reset! -; compare-and-set! - -(deftest swap-vals-returns-old-value - (let [a (atom 0)] - (is (= [0 1] (swap-vals! a inc))) - (is (= [1 2] (swap-vals! a inc))) - (is (= 2 @a)))) - -(deftest deref-swap-arities - (binding [*warn-on-reflection* true] - (let [a (atom 0)] - (is (= [0 1] (swap-vals! a + 1))) - (is (= [1 3] (swap-vals! a + 1 1))) - (is (= [3 6] (swap-vals! a + 1 1 1))) - (is (= [6 10] (swap-vals! a + 1 1 1 1))) - (is (= 10 @a))))) - -(deftest deref-reset-returns-old-value - (let [a (atom 0)] - (is (= [0 :b] (reset-vals! a :b))) - (is (= [:b 45M] (reset-vals! a 45M))) - (is (= 45M @a)))) - -(deftest reset-on-deref-reset-equality - (let [a (atom :usual-value)] +; 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: Frantisek Sodomka + +(ns clojure.test-clojure.atoms + (:use clojure.test)) + +; http://clojure.org/atoms + +; atom +; deref, @-reader-macro +; swap! reset! +; compare-and-set! + +(deftest swap-vals-returns-old-value + (let [a (atom 0)] + (is (= [0 1] (swap-vals! a inc))) + (is (= [1 2] (swap-vals! a inc))) + (is (= 2 @a)))) + +(deftest deref-swap-arities + (binding [*warn-on-reflection* true] + (let [a (atom 0)] + (is (= [0 1] (swap-vals! a + 1))) + (is (= [1 3] (swap-vals! a + 1 1))) + (is (= [3 6] (swap-vals! a + 1 1 1))) + (is (= [6 10] (swap-vals! a + 1 1 1 1))) + (is (= 10 @a))))) + +(deftest deref-reset-returns-old-value + (let [a (atom 0)] + (is (= [0 :b] (reset-vals! a :b))) + (is (= [:b 45M] (reset-vals! a 45M))) + (is (= 45M @a)))) + +(deftest reset-on-deref-reset-equality + (let [a (atom :usual-value)] (is (= :usual-value (reset! a (first (reset-vals! a :almost-never-seen-value))))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/clojure_walk.clj b/Clojure/Clojure.Tests/clojure/test_clojure/clojure_walk.clj index 915c659f0..30b71cca7 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/clojure_walk.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/clojure_walk.clj @@ -33,7 +33,7 @@ 4 5 [5] (list 4 [5]) [1 2 {:a 3} (list 4 [5])]]))) -(defrecord Foo [a b c]) +(defrecord Foo [a b c]) (deftest walk "Checks that walk returns the correct result and type of collection" @@ -42,8 +42,8 @@ #{1 2 3} (sorted-set-by > 1 2 3) {:a 1, :b 2, :c 3} - (sorted-map-by > 1 10, 2 20, 3 30) - (->Foo 1 2 3) + (sorted-map-by > 1 10, 2 20, 3 30) + (->Foo 1 2 3) (map->Foo {:a 1 :b 2 :c 3 :extra 4})]] (doseq [c colls] (let [walked (w/walk identity identity c)] @@ -58,8 +58,8 @@ (instance? clojure.lang.PersistentTreeSet c)) (is (= (.comparator c) (.comparator walked)))))))) -(deftest walk-mapentry - "Checks that walk preserves the MapEntry type. See CLJ-2031." - (let [coll [:html {:a ["b" 1]} ""] - f (fn [e] (if (and (vector? e) (not (map-entry? e))) (apply list e) e))] +(deftest walk-mapentry + "Checks that walk preserves the MapEntry type. See CLJ-2031." + (let [coll [:html {:a ["b" 1]} ""] + f (fn [e] (if (and (vector? e) (not (map-entry? e))) (apply list e) e))] (is (= (list :html {:a (list "b" 1)} "") (w/postwalk f coll))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/clr/added.clj b/Clojure/Clojure.Tests/clojure/test_clojure/clr/added.clj index 4a8cfa7f0..f9f040ba5 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/clr/added.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/clr/added.clj @@ -12,9 +12,9 @@ (:use clojure.test [clojure.test.generative :exclude (is)] clojure.template) - (:require [clojure.data.generators :as gen] - [clojure.test-helper :as helper])) - + (:require [clojure.data.generators :as gen] + [clojure.test-helper :as helper])) + (deftest test-bit-not (are [x y] (= x y) -1 (bit-not 0) diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/compilation.clj b/Clojure/Clojure.Tests/clojure/test_clojure/compilation.clj index e6f2694be..e37bb206e 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/compilation.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/compilation.clj @@ -12,7 +12,7 @@ (assembly-load-from "clojure.test_clojure.compilation.load_ns.clj.dll") ;;; DM:Added (ns clojure.test-clojure.compilation (:import (clojure.lang Compiler Compiler+CompilerException)) ;;; Compiler$CompilerException - (:require [clojure.test.generative :refer (defspec)] + (:require [clojure.test.generative :refer (defspec)] [clojure.data.generators :as gen] [clojure.test-clojure.compilation.line-number-examples :as line] clojure.string) ;;; DM:Added -- seem to have an order dependency that no longer works. @@ -59,8 +59,8 @@ (deftest test-compiler-resolution (testing "resolve nonexistent class create should return nil (assembla #262)" - (is (nil? (resolve 'NonExistentClass.)))) - (testing "resolve nonexistent class should return nil" + (is (nil? (resolve 'NonExistentClass.)))) + (testing "resolve nonexistent class should return nil" (is (nil? (resolve 'NonExistentClass.Name))))) (deftest test-no-recur-across-try @@ -144,15 +144,15 @@ (should-not-reflect #(.Data (clojure.test-clojure.compilation/hinted "arg"))) ;;; .floatValue (should-not-reflect #(.Count (clojure.test-clojure.compilation/hinted :many :rest :args :here)))) ;;; .size -(deftest CLJ-1232-qualify-hints - (let [arglists (-> #'clojure.test-clojure.compilation/hinted meta :arglists)] - (is (= 'String (-> arglists first meta :tag))) ;;; java.lang.String +(deftest CLJ-1232-qualify-hints + (let [arglists (-> #'clojure.test-clojure.compilation/hinted meta :arglists)] + (is (= 'String (-> arglists first meta :tag))) ;;; java.lang.String (is (= 'Exception (-> arglists second meta :tag))))) ;;; java.lang.Integer -(deftest CLJ-1232-return-type-not-imported - (is (thrown-with-cause-msg? Compiler+CompilerException #"Unable to resolve typename: Closeable" ;;; Compiler$CompilerException classname - (eval '(defn a ^Closeable [])))) - (is (thrown-with-cause-msg? Compiler+CompilerException #"Unable to resolve typename: Closeable" ;;; Compiler$CompilerException classname +(deftest CLJ-1232-return-type-not-imported + (is (thrown-with-cause-msg? Compiler+CompilerException #"Unable to resolve typename: Closeable" ;;; Compiler$CompilerException classname + (eval '(defn a ^Closeable [])))) + (is (thrown-with-cause-msg? Compiler+CompilerException #"Unable to resolve typename: Closeable" ;;; Compiler$CompilerException classname (eval '(defn a (^Closeable [])))))) (defn ^String hinting-conflict ^Exception []) ;;; ^Integer @@ -191,263 +191,263 @@ (should-print-err-message #"(?s).*k is not matching primitive.*" #(loop [k (clojure.test-clojure.compilation/primfn)] (recur :foo)))) -#_(deftest CLJ-1154-use-out-after-compile - ;; This test creates a dummy file to compile, sets up a dummy - ;; compiled output directory, and a dummy output stream, and - ;; verifies the stream is still usable after compiling. - (spit "test/dummy.clj" "(ns dummy)") - (try - (let [compile-path (System/getProperty "clojure.compile.path") - tmp (java.io.File. "tmp") - new-out (java.io.OutputStreamWriter. (java.io.ByteArrayOutputStream.))] - (binding [clojure.core/*out* new-out] - (try - (.mkdir tmp) - (System/setProperty "clojure.compile.path" "tmp") - (clojure.lang.Compile/main (into-array ["dummy"])) - (println "this should still work without throwing an exception" ) - (finally - (if compile-path - (System/setProperty "clojure.compile.path" compile-path) - (System/clearProperty "clojure.compile.path")) - (doseq [f (.listFiles tmp)] - (.delete f)) - (.delete tmp))))) - (finally - (doseq [f (.listFiles (java.io.File. "test")) - :when (re-find #"dummy.clj" (str f))] - (.delete f))))) - -(deftest CLJ-1184-do-in-non-list-test - (testing "do in a vector throws an exception" - (is (thrown? Compiler+CompilerException ;;; Compiler$CompilerException - (eval '[do 1 2 3])))) - (testing "do in a set throws an exception" - (is (thrown? Compiler+CompilerException ;;; Compiler$CompilerException - (eval '#{do})))) - - ;; compile uses a separate code path so we have to call it directly - ;; to test it - (letfn [(compile [s] (System.IO.Directory/CreateDirectory "test/clojure") ;;; DM: Added the CreateDirectory - (spit "test/clojure/bad_def_test.clj" (str "(ns test.clojure.bad-def-test)\n" s)) ;;; DM: Added test. to ns - (try - (binding [*compile-path* "test"] - (clojure.core/compile 'test.clojure.bad-def-test)) ;;; DM: Added test. to name - (finally - (doseq [f (.GetFiles (System.IO.DirectoryInfo. "test/clojure")) ;;; .listFiles java.io.File. - :when (re-find #"bad_def_test" (str f))] - (.Delete f)))))] - (testing "do in a vector throws an exception in compilation" - (is (thrown? Compiler+CompilerException (compile "[do 1 2 3]")))) ;;; Compiler$CompilerException - (testing "do in a set throws an exception in compilation" - (is (thrown? Compiler+CompilerException (compile "#{do}")))))) ;;; Compiler$CompilerException - -(defn gen-name [] - ;; Not all names can be correctly demunged. Skip names that contain - ;; a munge word as they will not properly demunge. - (let [munge-words (remove clojure.string/blank? - (conj (map #(clojure.string/replace % "_" "") - (vals Compiler/CHAR_MAP)) "_"))] - (first (filter (fn [n] (not-any? #(>= (.IndexOf n %) 0) munge-words)) ;;; indexOf - (repeatedly #(name (gen/symbol (constantly 10)))))))) - -(defn munge-roundtrip [n] - (Compiler/demunge (Compiler/munge n))) - -(defspec test-munge-roundtrip - munge-roundtrip - [^{:tag clojure.test-clojure.compilation/gen-name} n] - (assert (= n %))) - -(deftest test-fnexpr-type-hint - (testing "CLJ-1378: FnExpr should be allowed to override its reported class with a type hint." - ;;;(is (thrown? Compiler$CompilerException - ;;; (load-string "(.submit (java.util.concurrent.Executors/newCachedThreadPool) #())"))) - ;;;(is (try (load-string "(.submit (java.util.concurrent.Executors/newCachedThreadPool) ^Runnable #())") - ;;; (catch Compiler$CompilerException e nil)))) - (is (thrown? Microsoft.Scripting.ArgumentTypeException - (try (load-string "(System.Threading.Thread. #())") - (catch Compiler+CompilerException e (throw (.InnerException e)))))) - (is (thrown? InvalidCastException - (try (load-string "(System.Threading.Thread. ^System.Threading.ThreadStart #())") - (catch Compiler+CompilerException e (throw (.InnerException e)))))) - )) - -(defn ^{:tag 'long} hinted-primfn [^long x] x) -(defn unhinted-primfn [^long x] x) -(deftest CLJ-1533-primitive-functions-lose-tag - (should-not-reflect #(Math/Abs (clojure.test-clojure.compilation/hinted-primfn 1))) ;;; Math/abs - (should-not-reflect #(Math/Abs ^long (clojure.test-clojure.compilation/unhinted-primfn 1)))) ;;; Math/abs - - - -(defrecord Y [a]) -#clojure.test_clojure.compilation.Y[1] -(defrecord Y [b]) - -(binding [*compile-path* "."] ;;; "target/test-classes" - (compile 'clojure.test-clojure.compilation.examples)) - -#_(deftest test-compiler-line-numbers ;;; DM: TODO :: Improve Compiler source information. And then do https://github.com/clojure/clojure/commit/715754d3f69e85b07fa56047f0d43d400ab36fce - (let [fails-on-line-number? (fn [expected function] - (try - (function) - nil - (catch Exception t ;;; Throwable - (let [frames (filter #(= "line_number_examples.clj" (.GetFileName %)) ;;; .getFileName - (.GetFrames (System.Diagnostics.StackTrace. t true))) ;;; (.getStackTrace t)) - _ (if (zero? (count frames)) - (Console/WriteLine (.ToString t)) ;;; (.printStackTrace t) - ) - actual (.GetFileLineNumber ^System.Diagnostics.StackFrame (first frames))] ;;; .getLineNumber ^StackTraceElement - (= expected actual)))))] - (is (fails-on-line-number? 13 line/instance-field)) - (is (fails-on-line-number? 19 line/instance-field-reflected)) - (is (fails-on-line-number? 25 line/instance-field-unboxed)) - #_(is (fails-on-line-number? 32 line/instance-field-assign)) - (is (fails-on-line-number? 40 line/instance-field-assign-reflected)) - #_(is (fails-on-line-number? 47 line/static-field-assign)) - (is (fails-on-line-number? 54 line/instance-method)) - (is (fails-on-line-number? 61 line/instance-method-reflected)) - (is (fails-on-line-number? 68 line/instance-method-unboxed)) - (is (fails-on-line-number? 74 line/static-method)) - (is (fails-on-line-number? 80 line/static-method-reflected)) - (is (fails-on-line-number? 86 line/static-method-unboxed)) - (is (fails-on-line-number? 92 line/invoke)) - (is (fails-on-line-number? 101 line/threading)) - (is (fails-on-line-number? 112 line/keyword-invoke)) - (is (fails-on-line-number? 119 line/invoke-cast)))) - -(deftest CLJ-979 - (is (= clojure.test_clojure.compilation.examples.X - (class (clojure.test-clojure.compilation.examples/->X)))) - (is (.b (clojure.test_clojure.compilation.Y. 1))) - (is (= clojure.test_clojure.compilation.examples.T - (class (clojure.test_clojure.compilation.examples.T.)) - (class (clojure.test-clojure.compilation.examples/->T))))) - -(deftest clj-1208 - ;; clojure.test-clojure.compilation.load-ns has not been loaded - ;; so this would fail if the deftype didn't load it in its static - ;; initializer as the implementation of f requires a var from - ;; that namespace - (is (= 1 (.f (clojure.test_clojure.compilation.load_ns.x.))))) - -(deftest clj-1568 - (let [compiler-fails-at? - (fn [row col source] - (let [path (name (gensym "clj-1568.example-"))] - (try - (Compiler/load (System.IO.StringReader. source) path "clj-1568.example" "clj-1568.example") ;;; java.io.StringReader, added extra arg - nil - (catch Compiler+CompilerException e ;;; Compiler$CompilerException - (let [data (ex-data e)] - (= [path row col] - [(:clojure.error/source data) (:clojure.error/line data) (:clojure.error/column data)]))))))] - (testing "with error in the initial form" - (are [row col source] (compiler-fails-at? row col source) - ;; note that the spacing of the following string is important - 1 4 " (.foo nil)" - 2 18 " - (/ 1 0)")) - (testing "with error in an non-initial form" - (are [row col source] (compiler-fails-at? row col source) - ;; note that the spacing of the following string is important - 3 18 "(:foo {}) - - (.foo nil)" - 4 20 "(ns clj-1568.example) - - - (/ 1 0)")))) - -(deftype CLJ1399 [munged-field-name]) - -(deftest clj-1399 - ;; throws an exception on failure - (is (eval `(fn [] ~(CLJ1399. 1))))) - -(deftest CLJ-1250-this-clearing - (testing "clearing during try/catch/finally" - (let [closed-over-in-catch (let [x :foo] - (fn [] - (try - (throw (Exception. "boom")) - (catch Exception e - x)))) ;; x should remain accessible to the fn - - a (atom nil) - closed-over-in-finally (fn [] - (try - :ret - (finally - (reset! a :run))))] - (is (= :foo (closed-over-in-catch))) - (is (= :ret (closed-over-in-finally))) - (is (= :run @a)))) - (testing "no clearing when loop not in return context" - (let [x (atom 5) - bad (fn [] - (loop [] (Environment/GetEnvironmentVariables)) ;;; (System/getProperties) - (swap! x dec) - (when (pos? @x) - (recur)))] - (is (nil? (bad)))))) - -(deftest CLJ-1586-lazyseq-literals-preserve-metadata - (should-not-reflect (eval (list '.Substring (with-meta (concat '(identity) '("foo")) {:tag 'String}) 0)))) ;;; .substring - -(deftest CLJ-1456-compiler-error-on-incorrect-number-of-parameters-to-throw - #_(is (thrown? RuntimeException (eval '(defn foo [] (throw))))) ;;; not an error for us. no arg signifies Rethrow - (is (thrown? Exception (eval '(defn foo [] (throw RuntimeException any-symbol))))) ;;; RuntimeException - (is (thrown? Exception (eval '(defn foo [] (throw (RuntimeException.) any-symbol))))) ;;; RuntimeException - (is (var? (eval '(defn foo [] (throw (ArgumentException.))))))) ;;; IllegalArgumentException - -(deftest clj-1809 - (is (eval `(fn [y#] - (try - (finally - (let [z# y#]))))))) - -;; See CLJ-1846 -(deftest incorrect-primitive-type-hint-throws - ;; invalid primitive type hint - (is (thrown-with-cause-msg? Compiler+CompilerException #"Cannot coerce System.Int64 to System.Int32" ;;; Compiler$CompilerException "Cannot coerce long to int - (load-string "(defn returns-long ^long [] 1) (Math/Sign ^int (returns-long))"))) ;;; Integer/bitCount - ;; correct casting instead - (is (= 1 (load-string "(defn returns-long ^long [] 1) (Math/Sign (int (returns-long)))")))) ;;; Integer/bitCount - -;; See CLJ-1825 -(def zf (fn rf [x] (lazy-seq (cons x (rf x))))) -(deftest test-anon-recursive-fn - (is (= [0 0] (take 2 ((fn rf [x] (lazy-seq (cons x (rf x)))) 0)))) - (is (= [0 0] (take 2 (zf 0))))) - -;; See CLJ-1845 -(deftest direct-linking-for-load - (let [called? (atom nil) - logger (fn [& args] - (reset! called? true) - nil)] - (with-redefs [load logger] - ;; doesn't actually load clojure.repl, but should - ;; eventually call `load` and reset called?. - (require 'clojure.repl :reload)) - (is @called?))) - -;;;(deftest clj-1714 -- not relevant -;;; (testing "CLJ-1714 Classes shouldn't have their static initialisers called simply by type hinting or importing" -;;; ;; ClassWithFailingStaticInitialiser will throw if its static initialiser is called -;;; (is (eval '(fn [^compilation.ClassWithFailingStaticInitialiser c]))) -;;; (is (eval '(import (compilation ClassWithFailingStaticInitialiser)))))) -;;; - TODO: when we finally get static methods in interfaces in .Net -- revisit this -;;;(deftest CLJ-2284 -;;; (testing "CLJ-2284 Can call static methods on interfaces" -;;; (is (= 42 (compilation.JDK8InterfaceMethods/staticMethod0 42))) -;;; (is (= "test" (compilation.JDK8InterfaceMethods/staticMethod1 "test"))) -;;; (is (= 1 (if (compilation.JDK8InterfaceMethods/staticMethod2 true) 1 2))))) - -(deftest CLJ-2580 - (testing "CLJ-2580 Correctly calculate exit branches of case" - (is (zero? (let [d (case nil :x nil 0)] d))) +#_(deftest CLJ-1154-use-out-after-compile + ;; This test creates a dummy file to compile, sets up a dummy + ;; compiled output directory, and a dummy output stream, and + ;; verifies the stream is still usable after compiling. + (spit "test/dummy.clj" "(ns dummy)") + (try + (let [compile-path (System/getProperty "clojure.compile.path") + tmp (java.io.File. "tmp") + new-out (java.io.OutputStreamWriter. (java.io.ByteArrayOutputStream.))] + (binding [clojure.core/*out* new-out] + (try + (.mkdir tmp) + (System/setProperty "clojure.compile.path" "tmp") + (clojure.lang.Compile/main (into-array ["dummy"])) + (println "this should still work without throwing an exception" ) + (finally + (if compile-path + (System/setProperty "clojure.compile.path" compile-path) + (System/clearProperty "clojure.compile.path")) + (doseq [f (.listFiles tmp)] + (.delete f)) + (.delete tmp))))) + (finally + (doseq [f (.listFiles (java.io.File. "test")) + :when (re-find #"dummy.clj" (str f))] + (.delete f))))) + +(deftest CLJ-1184-do-in-non-list-test + (testing "do in a vector throws an exception" + (is (thrown? Compiler+CompilerException ;;; Compiler$CompilerException + (eval '[do 1 2 3])))) + (testing "do in a set throws an exception" + (is (thrown? Compiler+CompilerException ;;; Compiler$CompilerException + (eval '#{do})))) + + ;; compile uses a separate code path so we have to call it directly + ;; to test it + (letfn [(compile [s] (System.IO.Directory/CreateDirectory "test/clojure") ;;; DM: Added the CreateDirectory + (spit "test/clojure/bad_def_test.clj" (str "(ns test.clojure.bad-def-test)\n" s)) ;;; DM: Added test. to ns + (try + (binding [*compile-path* "test"] + (clojure.core/compile 'test.clojure.bad-def-test)) ;;; DM: Added test. to name + (finally + (doseq [f (.GetFiles (System.IO.DirectoryInfo. "test/clojure")) ;;; .listFiles java.io.File. + :when (re-find #"bad_def_test" (str f))] + (.Delete f)))))] + (testing "do in a vector throws an exception in compilation" + (is (thrown? Compiler+CompilerException (compile "[do 1 2 3]")))) ;;; Compiler$CompilerException + (testing "do in a set throws an exception in compilation" + (is (thrown? Compiler+CompilerException (compile "#{do}")))))) ;;; Compiler$CompilerException + +(defn gen-name [] + ;; Not all names can be correctly demunged. Skip names that contain + ;; a munge word as they will not properly demunge. + (let [munge-words (remove clojure.string/blank? + (conj (map #(clojure.string/replace % "_" "") + (vals Compiler/CHAR_MAP)) "_"))] + (first (filter (fn [n] (not-any? #(>= (.IndexOf n %) 0) munge-words)) ;;; indexOf + (repeatedly #(name (gen/symbol (constantly 10)))))))) + +(defn munge-roundtrip [n] + (Compiler/demunge (Compiler/munge n))) + +(defspec test-munge-roundtrip + munge-roundtrip + [^{:tag clojure.test-clojure.compilation/gen-name} n] + (assert (= n %))) + +(deftest test-fnexpr-type-hint + (testing "CLJ-1378: FnExpr should be allowed to override its reported class with a type hint." + ;;;(is (thrown? Compiler$CompilerException + ;;; (load-string "(.submit (java.util.concurrent.Executors/newCachedThreadPool) #())"))) + ;;;(is (try (load-string "(.submit (java.util.concurrent.Executors/newCachedThreadPool) ^Runnable #())") + ;;; (catch Compiler$CompilerException e nil)))) + (is (thrown? Microsoft.Scripting.ArgumentTypeException + (try (load-string "(System.Threading.Thread. #())") + (catch Compiler+CompilerException e (throw (.InnerException e)))))) + (is (thrown? InvalidCastException + (try (load-string "(System.Threading.Thread. ^System.Threading.ThreadStart #())") + (catch Compiler+CompilerException e (throw (.InnerException e)))))) + )) + +(defn ^{:tag 'long} hinted-primfn [^long x] x) +(defn unhinted-primfn [^long x] x) +(deftest CLJ-1533-primitive-functions-lose-tag + (should-not-reflect #(Math/Abs (clojure.test-clojure.compilation/hinted-primfn 1))) ;;; Math/abs + (should-not-reflect #(Math/Abs ^long (clojure.test-clojure.compilation/unhinted-primfn 1)))) ;;; Math/abs + + + +(defrecord Y [a]) +#clojure.test_clojure.compilation.Y[1] +(defrecord Y [b]) + +(binding [*compile-path* "."] ;;; "target/test-classes" + (compile 'clojure.test-clojure.compilation.examples)) + +#_(deftest test-compiler-line-numbers ;;; DM: TODO :: Improve Compiler source information. And then do https://github.com/clojure/clojure/commit/715754d3f69e85b07fa56047f0d43d400ab36fce + (let [fails-on-line-number? (fn [expected function] + (try + (function) + nil + (catch Exception t ;;; Throwable + (let [frames (filter #(= "line_number_examples.clj" (.GetFileName %)) ;;; .getFileName + (.GetFrames (System.Diagnostics.StackTrace. t true))) ;;; (.getStackTrace t)) + _ (if (zero? (count frames)) + (Console/WriteLine (.ToString t)) ;;; (.printStackTrace t) + ) + actual (.GetFileLineNumber ^System.Diagnostics.StackFrame (first frames))] ;;; .getLineNumber ^StackTraceElement + (= expected actual)))))] + (is (fails-on-line-number? 13 line/instance-field)) + (is (fails-on-line-number? 19 line/instance-field-reflected)) + (is (fails-on-line-number? 25 line/instance-field-unboxed)) + #_(is (fails-on-line-number? 32 line/instance-field-assign)) + (is (fails-on-line-number? 40 line/instance-field-assign-reflected)) + #_(is (fails-on-line-number? 47 line/static-field-assign)) + (is (fails-on-line-number? 54 line/instance-method)) + (is (fails-on-line-number? 61 line/instance-method-reflected)) + (is (fails-on-line-number? 68 line/instance-method-unboxed)) + (is (fails-on-line-number? 74 line/static-method)) + (is (fails-on-line-number? 80 line/static-method-reflected)) + (is (fails-on-line-number? 86 line/static-method-unboxed)) + (is (fails-on-line-number? 92 line/invoke)) + (is (fails-on-line-number? 101 line/threading)) + (is (fails-on-line-number? 112 line/keyword-invoke)) + (is (fails-on-line-number? 119 line/invoke-cast)))) + +(deftest CLJ-979 + (is (= clojure.test_clojure.compilation.examples.X + (class (clojure.test-clojure.compilation.examples/->X)))) + (is (.b (clojure.test_clojure.compilation.Y. 1))) + (is (= clojure.test_clojure.compilation.examples.T + (class (clojure.test_clojure.compilation.examples.T.)) + (class (clojure.test-clojure.compilation.examples/->T))))) + +(deftest clj-1208 + ;; clojure.test-clojure.compilation.load-ns has not been loaded + ;; so this would fail if the deftype didn't load it in its static + ;; initializer as the implementation of f requires a var from + ;; that namespace + (is (= 1 (.f (clojure.test_clojure.compilation.load_ns.x.))))) + +(deftest clj-1568 + (let [compiler-fails-at? + (fn [row col source] + (let [path (name (gensym "clj-1568.example-"))] + (try + (Compiler/load (System.IO.StringReader. source) path "clj-1568.example" "clj-1568.example") ;;; java.io.StringReader, added extra arg + nil + (catch Compiler+CompilerException e ;;; Compiler$CompilerException + (let [data (ex-data e)] + (= [path row col] + [(:clojure.error/source data) (:clojure.error/line data) (:clojure.error/column data)]))))))] + (testing "with error in the initial form" + (are [row col source] (compiler-fails-at? row col source) + ;; note that the spacing of the following string is important + 1 4 " (.foo nil)" + 2 18 " + (/ 1 0)")) + (testing "with error in an non-initial form" + (are [row col source] (compiler-fails-at? row col source) + ;; note that the spacing of the following string is important + 3 18 "(:foo {}) + + (.foo nil)" + 4 20 "(ns clj-1568.example) + + + (/ 1 0)")))) + +(deftype CLJ1399 [munged-field-name]) + +(deftest clj-1399 + ;; throws an exception on failure + (is (eval `(fn [] ~(CLJ1399. 1))))) + +(deftest CLJ-1250-this-clearing + (testing "clearing during try/catch/finally" + (let [closed-over-in-catch (let [x :foo] + (fn [] + (try + (throw (Exception. "boom")) + (catch Exception e + x)))) ;; x should remain accessible to the fn + + a (atom nil) + closed-over-in-finally (fn [] + (try + :ret + (finally + (reset! a :run))))] + (is (= :foo (closed-over-in-catch))) + (is (= :ret (closed-over-in-finally))) + (is (= :run @a)))) + (testing "no clearing when loop not in return context" + (let [x (atom 5) + bad (fn [] + (loop [] (Environment/GetEnvironmentVariables)) ;;; (System/getProperties) + (swap! x dec) + (when (pos? @x) + (recur)))] + (is (nil? (bad)))))) + +(deftest CLJ-1586-lazyseq-literals-preserve-metadata + (should-not-reflect (eval (list '.Substring (with-meta (concat '(identity) '("foo")) {:tag 'String}) 0)))) ;;; .substring + +(deftest CLJ-1456-compiler-error-on-incorrect-number-of-parameters-to-throw + #_(is (thrown? RuntimeException (eval '(defn foo [] (throw))))) ;;; not an error for us. no arg signifies Rethrow + (is (thrown? Exception (eval '(defn foo [] (throw RuntimeException any-symbol))))) ;;; RuntimeException + (is (thrown? Exception (eval '(defn foo [] (throw (RuntimeException.) any-symbol))))) ;;; RuntimeException + (is (var? (eval '(defn foo [] (throw (ArgumentException.))))))) ;;; IllegalArgumentException + +(deftest clj-1809 + (is (eval `(fn [y#] + (try + (finally + (let [z# y#]))))))) + +;; See CLJ-1846 +(deftest incorrect-primitive-type-hint-throws + ;; invalid primitive type hint + (is (thrown-with-cause-msg? Compiler+CompilerException #"Cannot coerce System.Int64 to System.Int32" ;;; Compiler$CompilerException "Cannot coerce long to int + (load-string "(defn returns-long ^long [] 1) (Math/Sign ^int (returns-long))"))) ;;; Integer/bitCount + ;; correct casting instead + (is (= 1 (load-string "(defn returns-long ^long [] 1) (Math/Sign (int (returns-long)))")))) ;;; Integer/bitCount + +;; See CLJ-1825 +(def zf (fn rf [x] (lazy-seq (cons x (rf x))))) +(deftest test-anon-recursive-fn + (is (= [0 0] (take 2 ((fn rf [x] (lazy-seq (cons x (rf x)))) 0)))) + (is (= [0 0] (take 2 (zf 0))))) + +;; See CLJ-1845 +(deftest direct-linking-for-load + (let [called? (atom nil) + logger (fn [& args] + (reset! called? true) + nil)] + (with-redefs [load logger] + ;; doesn't actually load clojure.repl, but should + ;; eventually call `load` and reset called?. + (require 'clojure.repl :reload)) + (is @called?))) + +;;;(deftest clj-1714 -- not relevant +;;; (testing "CLJ-1714 Classes shouldn't have their static initialisers called simply by type hinting or importing" +;;; ;; ClassWithFailingStaticInitialiser will throw if its static initialiser is called +;;; (is (eval '(fn [^compilation.ClassWithFailingStaticInitialiser c]))) +;;; (is (eval '(import (compilation ClassWithFailingStaticInitialiser)))))) +;;; - TODO: when we finally get static methods in interfaces in .Net -- revisit this +;;;(deftest CLJ-2284 +;;; (testing "CLJ-2284 Can call static methods on interfaces" +;;; (is (= 42 (compilation.JDK8InterfaceMethods/staticMethod0 42))) +;;; (is (= "test" (compilation.JDK8InterfaceMethods/staticMethod1 "test"))) +;;; (is (= 1 (if (compilation.JDK8InterfaceMethods/staticMethod2 true) 1 2))))) + +(deftest CLJ-2580 + (testing "CLJ-2580 Correctly calculate exit branches of case" + (is (zero? (let [d (case nil :x nil 0)] d))) (is (nil? (let [d (case nil :x 0 nil)] d))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/control.clj b/Clojure/Clojure.Tests/clojure/test_clojure/control.clj index 500ef205a..4d4d64cd4 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/control.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/control.clj @@ -152,19 +152,19 @@ (exception)) )) -(deftest test-if-some - (are [x y] (= x y) - 1 (if-some [a 1] a) - false (if-some [a false] a) - nil (if-some [a nil] (exception)) - 3 (if-some [[a b] [1 2]] (+ a b)) - 1 (if-some [[a b] nil] b 1) - 1 (if-some [a nil] (exception) 1))) - -(deftest test-when-some - (are [x y] (= x y) - 1 (when-some [a 1] a) - 2 (when-some [[a b] [1 2]] b) +(deftest test-if-some + (are [x y] (= x y) + 1 (if-some [a 1] a) + false (if-some [a false] a) + nil (if-some [a nil] (exception)) + 3 (if-some [[a b] [1 2]] (+ a b)) + 1 (if-some [[a b] nil] b 1) + 1 (if-some [a nil] (exception) 1))) + +(deftest test-when-some + (are [x y] (= x y) + 1 (when-some [a 1] a) + 2 (when-some [[a b] [1 2]] b) false (when-some [a false] a) nil (when-some [a nil] (exception)))) @@ -362,8 +362,8 @@ (testing "test emits return types" (should-not-reflect (clojure.lang.BigDecimal/Create (case 1 1 1))) ;;; (Long. (case 1 1 1)) ; new Long(long) (should-not-reflect (clojure.lang.BigDecimal/Create (case 1 1 "1")))) ;;; (Long. (case 1 1 "1")) ; new Long(String) - (testing "short or byte expr compiles and matches" - (is (= 3 (case (short 4) 1 2 3))) + (testing "short or byte expr compiles and matches" + (is (= 3 (case (short 4) 1 2 3))) (is (= 3 (case (byte 4) 1 2 3)))) (testing "non-equivalence of chars and nums" (are [result input] (= result (case input 97 :97 :else)) @@ -384,8 +384,8 @@ ^Object y (identity -1)] ;;; (Long. -1) (is (= :diff (case x -1 :oops :diff))) (is (= :same (case y -1 :same :oops))))) - (testing "test correct behavior on hash collision" - ;; case uses Java .hashCode to put values into hash buckets. + (testing "test correct behavior on hash collision" + ;; case uses Java .hashCode to put values into hash buckets. (is (== (.GetHashCode 1) (.GetHashCode 9223372039002259457N))) ;;; .hashCode .hashCode (are [result input] (= result (case input 1 :long @@ -421,13 +421,13 @@ :b 1 :c -2 :d 4294967296 - :d 3) - (are [result input] (= result (case input - #{a} :set - :foo :keyword - a :symbol)) - :symbol 'a - :keyword :foo + :d 3) + (are [result input] (= result (case input + #{a} :set + :foo :keyword + a :symbol)) + :symbol 'a + :keyword :foo :set '#{a})) (testing "test warn for hash collision" (should-print-err-message diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/data_structures.clj b/Clojure/Clojure.Tests/clojure/test_clojure/data_structures.clj index 9c69b8c02..b0a46ceed 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/data_structures.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/data_structures.clj @@ -10,11 +10,11 @@ (ns clojure.test-clojure.data-structures - (:use clojure.test - [clojure.test.generative :exclude (is)]) + (:use clojure.test + [clojure.test.generative :exclude (is)]) (:require [clojure.test-clojure.generators :as cgen] [clojure.data.generators :as gen] - [clojure.string :as string]) + [clojure.string :as string]) (:import [System.Collections ICollection])) ;;; java.util Collection @@ -24,105 +24,105 @@ (seq (reduce disj (set s1) (set s2)))) -;; *** Generative *** -(defspec subcollection-counts-are-consistent - identity - [^{:tag cgen/ednable-collection} coll] - (let [n (count coll)] - (dotimes [i n] - (is (= n - (+ i (count (nthnext coll i))) - (+ i (count (drop i coll)))))))) - -(defn- transient? [x] - (instance? clojure.lang.ITransientCollection x)) - -(defn gen-transient-set-action [] - (gen/rand-nth [[#(conj! %1 %2) #(conj %1 %2) (gen/uniform -100 100)] - [#(disj! %1 %2) #(disj %1 %2) (gen/uniform -100 100)] - [#(deref (future (conj! %1 %2))) #(conj %1 %2) (gen/uniform -100 100)] - [#(deref (future (disj! %1 %2))) #(disj %1 %2) (gen/uniform -100 100)] - [persistent! identity] - [identity transient]])) - -(defn gen-transient-set-actions [] - (gen/reps #(gen/uniform 0 100) gen-transient-set-action)) - -(defn tempty? [t] - (= (count t) 0)) - -(defn gen-transient-vector-action [] - (gen/rand-nth [[#(conj! %1 %2) #(conj %1 %2) (gen/uniform -100 100)] - [(fn [v _] (if (tempty? v) v (pop! v))) - (fn [v _] (if (tempty? v) v (pop v))) - (gen/uniform -100 100)] - [#(deref (future (conj! %1 %2))) #(conj %1 %2) (gen/uniform -100 100)] - [(fn [v _] (if (tempty? v) v (deref (future (pop! v))))) - (fn [v _] (if (tempty? v) v (pop v))) - (gen/uniform -100 100)] - [persistent! identity] - [identity transient]])) - -(defn gen-transient-vector-actions [] - (gen/reps #(gen/uniform 0 100) gen-transient-vector-action)) - -(defn gen-transient-map-action [] - (gen/rand-nth [[#(assoc! %1 %2 %2) #(assoc %1 %2 %2) (gen/uniform -100 100)] - [#(dissoc! %1 %2) #(dissoc %1 %2) (gen/uniform -100 100)] - [#(deref (future (assoc! %1 %2 %2))) #(assoc %1 %2 %2) (gen/uniform -100 100)] - [#(deref (future (dissoc! %1 %2))) #(dissoc %1 %2) (gen/uniform -100 100)] - [persistent! identity] - [identity transient]])) - -(defn gen-transient-map-actions [] - (gen/reps #(gen/uniform 0 100) gen-transient-map-action)) - -(defn assert-same-collection [a b] - (assert (= (count a) (count b) (.count a) (.count b))) ;;; .size .size - (assert (= a b)) - (assert (= b a)) - (assert (.Equals ^Object a b)) ;;; .equals - (assert (.Equals ^Object b a)) ;;; .equals - (assert (= (hash a) (hash b))) - (assert (= (.GetHashCode ^Object a) (.GetHashCode ^Object b))) ;;; .hashCode .hashCode - (assert (= a - (into (empty a) a) - (into (empty b) b) - (into (empty a) b) - (into (empty b) a)))) - -(defn apply-actions [coll actions] - (reduce (fn [c [tfunc pfunc & args]] - (apply (if (transient? c) tfunc pfunc) c args)) - coll - actions)) - -(defn to-persistent [c] - (if (transient? c) (persistent! c) c)) - -(defspec same-output-persistent-transient-set - identity - [^{:tag clojure.test-clojure.data-structures/gen-transient-set-actions} actions] - (assert-same-collection - (to-persistent (apply-actions #{} actions)) - (to-persistent (apply-actions #{} actions)))) - -(defspec same-output-persistent-transient-vector - identity - [^{:tag clojure.test-clojure.data-structures/gen-transient-vector-actions} actions] - (assert-same-collection - (to-persistent (apply-actions [] actions)) - (to-persistent (apply-actions [] actions)))) - -(defspec same-output-persistent-transient-map - identity - [^{:tag clojure.test-clojure.data-structures/gen-transient-map-actions} actions] - (assert-same-collection - (to-persistent (apply-actions clojure.lang.PersistentArrayMap/EMPTY actions)) - (to-persistent (apply-actions clojure.lang.PersistentArrayMap/EMPTY actions))) - (assert-same-collection - (to-persistent (apply-actions clojure.lang.PersistentHashMap/EMPTY actions)) - (to-persistent (apply-actions clojure.lang.PersistentHashMap/EMPTY actions)))) +;; *** Generative *** +(defspec subcollection-counts-are-consistent + identity + [^{:tag cgen/ednable-collection} coll] + (let [n (count coll)] + (dotimes [i n] + (is (= n + (+ i (count (nthnext coll i))) + (+ i (count (drop i coll)))))))) + +(defn- transient? [x] + (instance? clojure.lang.ITransientCollection x)) + +(defn gen-transient-set-action [] + (gen/rand-nth [[#(conj! %1 %2) #(conj %1 %2) (gen/uniform -100 100)] + [#(disj! %1 %2) #(disj %1 %2) (gen/uniform -100 100)] + [#(deref (future (conj! %1 %2))) #(conj %1 %2) (gen/uniform -100 100)] + [#(deref (future (disj! %1 %2))) #(disj %1 %2) (gen/uniform -100 100)] + [persistent! identity] + [identity transient]])) + +(defn gen-transient-set-actions [] + (gen/reps #(gen/uniform 0 100) gen-transient-set-action)) + +(defn tempty? [t] + (= (count t) 0)) + +(defn gen-transient-vector-action [] + (gen/rand-nth [[#(conj! %1 %2) #(conj %1 %2) (gen/uniform -100 100)] + [(fn [v _] (if (tempty? v) v (pop! v))) + (fn [v _] (if (tempty? v) v (pop v))) + (gen/uniform -100 100)] + [#(deref (future (conj! %1 %2))) #(conj %1 %2) (gen/uniform -100 100)] + [(fn [v _] (if (tempty? v) v (deref (future (pop! v))))) + (fn [v _] (if (tempty? v) v (pop v))) + (gen/uniform -100 100)] + [persistent! identity] + [identity transient]])) + +(defn gen-transient-vector-actions [] + (gen/reps #(gen/uniform 0 100) gen-transient-vector-action)) + +(defn gen-transient-map-action [] + (gen/rand-nth [[#(assoc! %1 %2 %2) #(assoc %1 %2 %2) (gen/uniform -100 100)] + [#(dissoc! %1 %2) #(dissoc %1 %2) (gen/uniform -100 100)] + [#(deref (future (assoc! %1 %2 %2))) #(assoc %1 %2 %2) (gen/uniform -100 100)] + [#(deref (future (dissoc! %1 %2))) #(dissoc %1 %2) (gen/uniform -100 100)] + [persistent! identity] + [identity transient]])) + +(defn gen-transient-map-actions [] + (gen/reps #(gen/uniform 0 100) gen-transient-map-action)) + +(defn assert-same-collection [a b] + (assert (= (count a) (count b) (.count a) (.count b))) ;;; .size .size + (assert (= a b)) + (assert (= b a)) + (assert (.Equals ^Object a b)) ;;; .equals + (assert (.Equals ^Object b a)) ;;; .equals + (assert (= (hash a) (hash b))) + (assert (= (.GetHashCode ^Object a) (.GetHashCode ^Object b))) ;;; .hashCode .hashCode + (assert (= a + (into (empty a) a) + (into (empty b) b) + (into (empty a) b) + (into (empty b) a)))) + +(defn apply-actions [coll actions] + (reduce (fn [c [tfunc pfunc & args]] + (apply (if (transient? c) tfunc pfunc) c args)) + coll + actions)) + +(defn to-persistent [c] + (if (transient? c) (persistent! c) c)) + +(defspec same-output-persistent-transient-set + identity + [^{:tag clojure.test-clojure.data-structures/gen-transient-set-actions} actions] + (assert-same-collection + (to-persistent (apply-actions #{} actions)) + (to-persistent (apply-actions #{} actions)))) + +(defspec same-output-persistent-transient-vector + identity + [^{:tag clojure.test-clojure.data-structures/gen-transient-vector-actions} actions] + (assert-same-collection + (to-persistent (apply-actions [] actions)) + (to-persistent (apply-actions [] actions)))) + +(defspec same-output-persistent-transient-map + identity + [^{:tag clojure.test-clojure.data-structures/gen-transient-map-actions} actions] + (assert-same-collection + (to-persistent (apply-actions clojure.lang.PersistentArrayMap/EMPTY actions)) + (to-persistent (apply-actions clojure.lang.PersistentArrayMap/EMPTY actions))) + (assert-same-collection + (to-persistent (apply-actions clojure.lang.PersistentHashMap/EMPTY actions)) + (to-persistent (apply-actions clojure.lang.PersistentHashMap/EMPTY actions)))) ;; *** General *** @@ -592,10 +592,10 @@ ; (class (hash-map :a 1)) => clojure.lang.PersistentHashMap (keys (hash-map)) nil (keys (hash-map :a 1)) '(:a) - (diff (keys (hash-map :a 1 :b 2)) '(:a :b)) nil ) ; (keys (hash-map :a 1 :b 2)) '(:a :b) - - (let [m {:a 1 :b 2} - k (keys m)] + (diff (keys (hash-map :a 1 :b 2)) '(:a :b)) nil ) ; (keys (hash-map :a 1 :b 2)) '(:a :b) + + (let [m {:a 1 :b 2} + k (keys m)] (is (= {:hi :there} (meta (with-meta k {:hi :there})))))) @@ -621,28 +621,28 @@ ; (class (hash-map :a 1)) => clojure.lang.PersistentHashMap (vals (hash-map)) nil (vals (hash-map :a 1)) '(1) - (diff (vals (hash-map :a 1 :b 2)) '(1 2)) nil ) ; (vals (hash-map :a 1 :b 2)) '(1 2) - - (let [m {:a 1 :b 2} - v (vals m)] + (diff (vals (hash-map :a 1 :b 2)) '(1 2)) nil ) ; (vals (hash-map :a 1 :b 2)) '(1 2) + + (let [m {:a 1 :b 2} + v (vals m)] (is (= {:hi :there} (meta (with-meta v {:hi :there})))))) -(deftest test-sorted-map-keys - (is (thrown? InvalidCastException (sorted-map () 1))) ;;; ClassCastException - (is (thrown? InvalidCastException (sorted-map #{} 1))) ;;; ClassCastException - (is (thrown? InvalidCastException (sorted-map {} 1))) ;;; ClassCastException - - (is (thrown? InvalidCastException (assoc (sorted-map) () 1))) ;;; ClassCastException - (is (thrown? InvalidCastException (assoc (sorted-map) #{} 1))) ;;; ClassCastException - (is (thrown? InvalidCastException (assoc (sorted-map) {} 1))) ;;; ClassCastException - - ;; doesn't throw - (let [cmp #(compare (count %1) (count %2))] - (assoc (sorted-map-by cmp) () 1) - (assoc (sorted-map-by cmp) #{} 1) - (assoc (sorted-map-by cmp) {} 1))) - +(deftest test-sorted-map-keys + (is (thrown? InvalidCastException (sorted-map () 1))) ;;; ClassCastException + (is (thrown? InvalidCastException (sorted-map #{} 1))) ;;; ClassCastException + (is (thrown? InvalidCastException (sorted-map {} 1))) ;;; ClassCastException + + (is (thrown? InvalidCastException (assoc (sorted-map) () 1))) ;;; ClassCastException + (is (thrown? InvalidCastException (assoc (sorted-map) #{} 1))) ;;; ClassCastException + (is (thrown? InvalidCastException (assoc (sorted-map) {} 1))) ;;; ClassCastException + + ;; doesn't throw + (let [cmp #(compare (count %1) (count %2))] + (assoc (sorted-map-by cmp) () 1) + (assoc (sorted-map-by cmp) #{} 1) + (assoc (sorted-map-by cmp) {} 1))) + (deftest test-key (are [x] (= (key (first (hash-map x :value))) x) @@ -723,15 +723,15 @@ ai3 ao3 ai4 ao4))) -(deftest test-map-entry? - (testing "map-entry? = false" - (are [entry] - (false? (map-entry? entry)) - nil 5 #{1 2} '(1 2) {:a 1} [] [0] [1 2 3])) - #_(testing "map-entry? = true" - (are [entry] - (true? (map-entry? entry)) - #_(first (doto (System.Collections.Hashtable.) (.Add "x" 1))) ))) ;;; (doto (java.util.HashMap.) (.put "x" 1)) -- we don't cover this case with map-entry? Maybe we should' +(deftest test-map-entry? + (testing "map-entry? = false" + (are [entry] + (false? (map-entry? entry)) + nil 5 #{1 2} '(1 2) {:a 1} [] [0] [1 2 3])) + #_(testing "map-entry? = true" + (are [entry] + (true? (map-entry? entry)) + #_(first (doto (System.Collections.Hashtable.) (.Add "x" 1))) ))) ;;; (doto (java.util.HashMap.) (.put "x" 1)) -- we don't cover this case with map-entry? Maybe we should' ;; *** Sets *** @@ -812,8 +812,8 @@ [] [1 2] ) ; cannot be cast to java.lang.Comparable - (is (thrown? InvalidCastException (sorted-set ()))) ;;; ClassCastException - (is (thrown? InvalidCastException (sorted-set {}))) ;;; ClassCastException + (is (thrown? InvalidCastException (sorted-set ()))) ;;; ClassCastException + (is (thrown? InvalidCastException (sorted-set {}))) ;;; ClassCastException (is (thrown? InvalidCastException (sorted-set #{}))) ;;; ClassCastException (is (thrown? InvalidCastException (sorted-set '(1 2) '(1 2)))) ;;; ClassCastException (is (thrown? InvalidCastException (sorted-set {:a 1 :b 2} {:a 1 :b 2}))) ;;; ClassCastException @@ -1091,8 +1091,8 @@ {x1 v4a, w5a v4c, v4a z3b, y2 2} [x1 v4a, w5a v4a, w5b v4b, v4a z3a, y2 2, v4b z3b, w5c v4c]))) -(deftest test-array-map-arity - (is (thrown? ArgumentException ;;; IllegalArgumentException +(deftest test-array-map-arity + (is (thrown? ArgumentException ;;; IllegalArgumentException (array-map 1 2 3)))) (deftest test-assoc @@ -1105,259 +1105,259 @@ (is (thrown? ArgumentException (assoc [] 0 5 1))) ;;; IllegalArgumentException (is (thrown? ArgumentException (assoc {} :b -2 :a)))) ;;; IllegalArgumentException - (defn is-same-collection [a b] - (let [msg (format "(class a)=%s (class b)=%s a=%s b=%s" - (.Name (class a)) (.Name (class b)) a b)] ;;; .getName .getName - (is (= (count a) (count b)) msg) - (when (instance? ICollection a) ;;; Collection - (is (= (count a) (.get_Count a)) msg)) ;;; .size - (when (instance? ICollection b) ;;; Collection - (is (= (count b) (.get_Count b)) msg)) ;;; .size - (is (= a b) msg) - (is (= b a) msg) - (is (.Equals ^Object a b) msg) ;;; .equals - (is (.Equals ^Object b a) msg) ;;; .equals - (is (= (hash a) (hash b)) msg) - (is (= (.GetHashCode ^Object a) (.GetHashCode ^Object b)) msg))) ;;; .hashCode .hashCode - -(deftest ordered-collection-equality-test - (let [empty-colls [ [] - '() - (lazy-seq) - clojure.lang.PersistentQueue/EMPTY - (vector-of :long) ]] - (doseq [c1 empty-colls, c2 empty-colls] - (is-same-collection c1 c2))) - (let [colls1 [ [-3 :a "7th"] - '(-3 :a "7th") - (lazy-seq (cons -3 - (lazy-seq (cons :a - (lazy-seq (cons "7th" nil)))))) - (into clojure.lang.PersistentQueue/EMPTY - [-3 :a "7th"]) - (sequence (map identity) [-3 :a "7th"]) ]] - (doseq [c1 colls1, c2 colls1] - (is-same-collection c1 c2))) - (let [long-colls [ [2 3 4] - '(2 3 4) - (vector-of :long 2 3 4) - (seq (vector-of :long 2 3 4)) - (range 2 5)]] - (doseq [c1 long-colls, c2 long-colls] - (is-same-collection c1 c2)))) - -(defn case-indendent-string-cmp [s1 s2] - (compare (string/lower-case s1) (string/lower-case s2))) - -(deftest set-equality-test - (let [empty-sets [ #{} - (hash-set) - (sorted-set) - (sorted-set-by case-indendent-string-cmp) ]] - (doseq [s1 empty-sets, s2 empty-sets] - (is-same-collection s1 s2))) - (let [sets1 [ #{"Banana" "apple" "7th"} - (hash-set "Banana" "apple" "7th") - (sorted-set "Banana" "apple" "7th") - (sorted-set-by case-indendent-string-cmp "Banana" "apple" "7th") ]] - (doseq [s1 sets1, s2 sets1] - (is-same-collection s1 s2)))) - -(deftest map-equality-test - (let [empty-maps [ {} - (hash-map) - (array-map) - (sorted-map) - (sorted-map-by case-indendent-string-cmp) ]] - (doseq [m1 empty-maps, m2 empty-maps] - (is-same-collection m1 m2))) - (let [maps1 [ {"Banana" "like", "apple" "love", "7th" "indifferent"} - (hash-map "Banana" "like", "apple" "love", "7th" "indifferent") - (array-map "Banana" "like", "apple" "love", "7th" "indifferent") - (sorted-map "Banana" "like", "apple" "love", "7th" "indifferent") - (sorted-map-by case-indendent-string-cmp - "Banana" "like", "apple" "love", "7th" "indifferent") ]] - (doseq [m1 maps1, m2 maps1] - (is-same-collection m1 m2)))) - -;; *** Collection hashes *** -;; See: http://clojure.org/data_structures#hash - -(defn hash-ordered [collection] - (-> (reduce (fn [acc e] (unchecked-add-int (unchecked-multiply-int 31 acc) (hash e))) - 1 - collection) - (mix-collection-hash (count collection)))) - -(defn hash-unordered [collection] - (-> (reduce unchecked-add-int 0 (map hash collection)) - (mix-collection-hash (count collection)))) - -(defn gen-elements - [] - (gen/vec gen/anything)) - -(defspec ordered-collection-hashes-match - identity - [^{:tag clojure.test-clojure.data-structures/gen-elements} elem] - (let [v (vec elem) - l (apply list elem)] - (is (= (hash v) - (hash l) - (hash (map identity elem)) - (hash-ordered elem))))) - -(defspec unordered-set-hashes-match - identity - [^{:tag clojure.test-clojure.data-structures/gen-elements} elem] - (let [unique-elem (distinct elem) - s (into #{} unique-elem)] - (is (= (hash s) - (hash-unordered unique-elem))))) - -(deftest ireduce-reduced - (let [f (fn [_ a] (if (= a 5) (reduced "foo")))] - (is (= "foo" (.reduce ^clojure.lang.IReduce (list 1 2 3 4 5) f))) - (is (= "foo" (.reduce ^clojure.lang.IReduce (seq (long-array [1 2 3 4 5])) f))))) - -(defn seq-iter-match - [^clojure.lang.Seqable seqable ^System.Collections.IEnumerable iterable] ;;; ^Iterable - (if (nil? iterable) - (when (not (nil? (seq seqable))) - (throw (ex-info "Null iterable but seq has elements" - {:pos 0 :seqable seqable :iterable iterable}))) - (let [i (.GetEnumerator iterable)] ;;; .iterator - (loop [s (seq seqable) - n 0] - (if (seq s) - (do - (when-not (.MoveNext i) ;;; .hasNext - (throw (ex-info "Iterator exhausted before seq" - {:pos n :seqable seqable :iterable iterable}))) - (when-not (= (.Current i) (first s)) ;;; .next - (throw (ex-info "Iterator and seq did not match" - {:pos n :seqable seqable :iterable iterable}))) - (recur (rest s) (inc n))) - (when (.MoveNext i) ;;; .hasNext - (throw (ex-info "Seq exhausted before iterator" - {:pos n :seqable seqable :iterable iterable})))))))) - -(deftest test-seq-iter-match - (let [maps (mapcat #(vector (apply array-map %) - (apply hash-map %) - (apply sorted-map %)) - [[] [nil 1] [nil 1 2 3] [1 2 3 4]])] - (doseq [m maps] - (seq-iter-match m m) - (seq-iter-match (keys m) (keys m)) - (seq-iter-match (vals m) (vals m)) - (seq-iter-match (rest (keys m)) (rest (keys m))) - (seq-iter-match (rest (vals m)) (rest (vals m)))))) - -(defn gen-map - [] - (gen/hash-map (rand-nth cgen/ednable-scalars) (rand-nth cgen/ednable-scalars))) - -(defspec seq-and-iter-match-for-maps - identity - [^{:tag clojure.test-clojure.data-structures/gen-map} m] - (seq-iter-match m m)) - -(defn gen-set - [] - (gen/set (rand-nth cgen/ednable-scalars))) - -(defspec seq-and-iter-match-for-sets - identity - [^{:tag clojure.test-clojure.data-structures/gen-set} s] - (seq-iter-match s s)) - -(defn gen-queue - [] - (into clojure.lang.PersistentQueue/EMPTY - (gen/vec (rand-nth cgen/ednable-scalars)))) - -(defspec seq-and-iter-match-for-queues - identity - [^{:tag clojure.test-clojure.data-structures/gen-queue} q] - (seq-iter-match q q)) - -(defrecord Rec [a b]) - -(defn gen-record - [] - (let [r (->Rec (gen/int) (gen/int))] - (gen/one-of r - (merge r (gen-map))))) - -(defspec seq-and-iter-match-for-records - identity - [^{:tag clojure.test-clojure.data-structures/gen-record} r] - (seq-iter-match r r)) - -(defspec seq-and-iter-match-for-keys - identity - [^{:tag clojure.test-clojure.data-structures/gen-map} m] - (seq-iter-match (keys m) (keys m))) - -(defspec seq-and-iter-match-for-vals - identity - [^{:tag clojure.test-clojure.data-structures/gen-map} m] - (seq-iter-match (vals m) (vals m))) - -(defstruct test-struct :a :b) - -(defn gen-struct - [] - (let [s (struct test-struct (gen/int) (gen/int))] - (gen/one-of s - (assoc s (rand-nth cgen/ednable-scalars) (rand-nth cgen/ednable-scalars))))) - -(defspec seq-and-iter-match-for-structs - identity - [^{:tag clojure.test-clojure.data-structures/gen-struct} s] - (seq-iter-match s s)) - -(deftest record-hashing - (let [r (->Rec 1 1) - _ (hash r) - r2 (assoc r :c 2)] - (is (= (hash (->Rec 1 1)) (hash r))) - (is (= (hash r) (hash (with-meta r {:foo 2})))) - (is (not= (hash (->Rec 1 1)) (hash (assoc (->Rec 1 1) :a 2)))) - (is (not= (hash (->Rec 1 1)) (hash r2))) - (is (not= (hash (->Rec 1 1)) (hash (assoc r :a 2)))) - (is (= (hash (->Rec 1 1)) (hash (assoc r :a 1)))) - (is (= (hash (->Rec 1 1)) (hash (dissoc r2 :c)))) - (is (= (hash (->Rec 1 1)) (hash (dissoc (assoc r :c 1) :c)))))) - -(deftest singleton-map-in-destructure-context - (let [sample-map {:a 1 :b 2} - {:keys [a] :as m1} (list sample-map)] - (is (= m1 sample-map)) - (is (= a 1)))) - -(deftest trailing-map-destructuring - (let [sample-map {:a 1 :b 2} - add (fn [& {:keys [a b]}] (+ a b)) - addn (fn [n & {:keys [a b]}] (+ n a b))] - (testing "that kwargs are applied properly given a map in place of the key/val pairs" - (is (= 3 (add :a 1 :b 2))) - (is (= 3 (add {:a 1 :b 2}))) - (is (= 13 (addn 10 :a 1 :b 2))) - (is (= 13 (addn 10 {:a 1 :b 2}))) - (is (= 103 ((partial addn 100) :a 1 {:b 2}))) - (is (= 103 ((partial addn 100 :a 1) {:b 2}))) - (is (= 107 ((partial addn 100 :a 1) {:a 5 :b 2})))) - (testing "built maps" - (let [{:as m1} (list :a 1 :b 2) - {:as m2} (list :a 1 :b 2 {:c 3}) - {:as m3} (list :a 1 :b 2 {:a 0}) - {:keys [a4] :as m4} (list nil)] - (= m1 {:a 1 :b 2}) - (= m2 {:a 1 :b 2 :c 3}) - (= m3 {:a 0 :b 2}) - (= m1 (seq-to-map-for-destructuring (list :a 1 :b 2))) - (= m2 (seq-to-map-for-destructuring (list :a 1 :b 2 {:c 3}))) - (= m3 (seq-to-map-for-destructuring (list :a 1 :b 2 {:a 0}))) + (defn is-same-collection [a b] + (let [msg (format "(class a)=%s (class b)=%s a=%s b=%s" + (.Name (class a)) (.Name (class b)) a b)] ;;; .getName .getName + (is (= (count a) (count b)) msg) + (when (instance? ICollection a) ;;; Collection + (is (= (count a) (.get_Count a)) msg)) ;;; .size + (when (instance? ICollection b) ;;; Collection + (is (= (count b) (.get_Count b)) msg)) ;;; .size + (is (= a b) msg) + (is (= b a) msg) + (is (.Equals ^Object a b) msg) ;;; .equals + (is (.Equals ^Object b a) msg) ;;; .equals + (is (= (hash a) (hash b)) msg) + (is (= (.GetHashCode ^Object a) (.GetHashCode ^Object b)) msg))) ;;; .hashCode .hashCode + +(deftest ordered-collection-equality-test + (let [empty-colls [ [] + '() + (lazy-seq) + clojure.lang.PersistentQueue/EMPTY + (vector-of :long) ]] + (doseq [c1 empty-colls, c2 empty-colls] + (is-same-collection c1 c2))) + (let [colls1 [ [-3 :a "7th"] + '(-3 :a "7th") + (lazy-seq (cons -3 + (lazy-seq (cons :a + (lazy-seq (cons "7th" nil)))))) + (into clojure.lang.PersistentQueue/EMPTY + [-3 :a "7th"]) + (sequence (map identity) [-3 :a "7th"]) ]] + (doseq [c1 colls1, c2 colls1] + (is-same-collection c1 c2))) + (let [long-colls [ [2 3 4] + '(2 3 4) + (vector-of :long 2 3 4) + (seq (vector-of :long 2 3 4)) + (range 2 5)]] + (doseq [c1 long-colls, c2 long-colls] + (is-same-collection c1 c2)))) + +(defn case-indendent-string-cmp [s1 s2] + (compare (string/lower-case s1) (string/lower-case s2))) + +(deftest set-equality-test + (let [empty-sets [ #{} + (hash-set) + (sorted-set) + (sorted-set-by case-indendent-string-cmp) ]] + (doseq [s1 empty-sets, s2 empty-sets] + (is-same-collection s1 s2))) + (let [sets1 [ #{"Banana" "apple" "7th"} + (hash-set "Banana" "apple" "7th") + (sorted-set "Banana" "apple" "7th") + (sorted-set-by case-indendent-string-cmp "Banana" "apple" "7th") ]] + (doseq [s1 sets1, s2 sets1] + (is-same-collection s1 s2)))) + +(deftest map-equality-test + (let [empty-maps [ {} + (hash-map) + (array-map) + (sorted-map) + (sorted-map-by case-indendent-string-cmp) ]] + (doseq [m1 empty-maps, m2 empty-maps] + (is-same-collection m1 m2))) + (let [maps1 [ {"Banana" "like", "apple" "love", "7th" "indifferent"} + (hash-map "Banana" "like", "apple" "love", "7th" "indifferent") + (array-map "Banana" "like", "apple" "love", "7th" "indifferent") + (sorted-map "Banana" "like", "apple" "love", "7th" "indifferent") + (sorted-map-by case-indendent-string-cmp + "Banana" "like", "apple" "love", "7th" "indifferent") ]] + (doseq [m1 maps1, m2 maps1] + (is-same-collection m1 m2)))) + +;; *** Collection hashes *** +;; See: http://clojure.org/data_structures#hash + +(defn hash-ordered [collection] + (-> (reduce (fn [acc e] (unchecked-add-int (unchecked-multiply-int 31 acc) (hash e))) + 1 + collection) + (mix-collection-hash (count collection)))) + +(defn hash-unordered [collection] + (-> (reduce unchecked-add-int 0 (map hash collection)) + (mix-collection-hash (count collection)))) + +(defn gen-elements + [] + (gen/vec gen/anything)) + +(defspec ordered-collection-hashes-match + identity + [^{:tag clojure.test-clojure.data-structures/gen-elements} elem] + (let [v (vec elem) + l (apply list elem)] + (is (= (hash v) + (hash l) + (hash (map identity elem)) + (hash-ordered elem))))) + +(defspec unordered-set-hashes-match + identity + [^{:tag clojure.test-clojure.data-structures/gen-elements} elem] + (let [unique-elem (distinct elem) + s (into #{} unique-elem)] + (is (= (hash s) + (hash-unordered unique-elem))))) + +(deftest ireduce-reduced + (let [f (fn [_ a] (if (= a 5) (reduced "foo")))] + (is (= "foo" (.reduce ^clojure.lang.IReduce (list 1 2 3 4 5) f))) + (is (= "foo" (.reduce ^clojure.lang.IReduce (seq (long-array [1 2 3 4 5])) f))))) + +(defn seq-iter-match + [^clojure.lang.Seqable seqable ^System.Collections.IEnumerable iterable] ;;; ^Iterable + (if (nil? iterable) + (when (not (nil? (seq seqable))) + (throw (ex-info "Null iterable but seq has elements" + {:pos 0 :seqable seqable :iterable iterable}))) + (let [i (.GetEnumerator iterable)] ;;; .iterator + (loop [s (seq seqable) + n 0] + (if (seq s) + (do + (when-not (.MoveNext i) ;;; .hasNext + (throw (ex-info "Iterator exhausted before seq" + {:pos n :seqable seqable :iterable iterable}))) + (when-not (= (.Current i) (first s)) ;;; .next + (throw (ex-info "Iterator and seq did not match" + {:pos n :seqable seqable :iterable iterable}))) + (recur (rest s) (inc n))) + (when (.MoveNext i) ;;; .hasNext + (throw (ex-info "Seq exhausted before iterator" + {:pos n :seqable seqable :iterable iterable})))))))) + +(deftest test-seq-iter-match + (let [maps (mapcat #(vector (apply array-map %) + (apply hash-map %) + (apply sorted-map %)) + [[] [nil 1] [nil 1 2 3] [1 2 3 4]])] + (doseq [m maps] + (seq-iter-match m m) + (seq-iter-match (keys m) (keys m)) + (seq-iter-match (vals m) (vals m)) + (seq-iter-match (rest (keys m)) (rest (keys m))) + (seq-iter-match (rest (vals m)) (rest (vals m)))))) + +(defn gen-map + [] + (gen/hash-map (rand-nth cgen/ednable-scalars) (rand-nth cgen/ednable-scalars))) + +(defspec seq-and-iter-match-for-maps + identity + [^{:tag clojure.test-clojure.data-structures/gen-map} m] + (seq-iter-match m m)) + +(defn gen-set + [] + (gen/set (rand-nth cgen/ednable-scalars))) + +(defspec seq-and-iter-match-for-sets + identity + [^{:tag clojure.test-clojure.data-structures/gen-set} s] + (seq-iter-match s s)) + +(defn gen-queue + [] + (into clojure.lang.PersistentQueue/EMPTY + (gen/vec (rand-nth cgen/ednable-scalars)))) + +(defspec seq-and-iter-match-for-queues + identity + [^{:tag clojure.test-clojure.data-structures/gen-queue} q] + (seq-iter-match q q)) + +(defrecord Rec [a b]) + +(defn gen-record + [] + (let [r (->Rec (gen/int) (gen/int))] + (gen/one-of r + (merge r (gen-map))))) + +(defspec seq-and-iter-match-for-records + identity + [^{:tag clojure.test-clojure.data-structures/gen-record} r] + (seq-iter-match r r)) + +(defspec seq-and-iter-match-for-keys + identity + [^{:tag clojure.test-clojure.data-structures/gen-map} m] + (seq-iter-match (keys m) (keys m))) + +(defspec seq-and-iter-match-for-vals + identity + [^{:tag clojure.test-clojure.data-structures/gen-map} m] + (seq-iter-match (vals m) (vals m))) + +(defstruct test-struct :a :b) + +(defn gen-struct + [] + (let [s (struct test-struct (gen/int) (gen/int))] + (gen/one-of s + (assoc s (rand-nth cgen/ednable-scalars) (rand-nth cgen/ednable-scalars))))) + +(defspec seq-and-iter-match-for-structs + identity + [^{:tag clojure.test-clojure.data-structures/gen-struct} s] + (seq-iter-match s s)) + +(deftest record-hashing + (let [r (->Rec 1 1) + _ (hash r) + r2 (assoc r :c 2)] + (is (= (hash (->Rec 1 1)) (hash r))) + (is (= (hash r) (hash (with-meta r {:foo 2})))) + (is (not= (hash (->Rec 1 1)) (hash (assoc (->Rec 1 1) :a 2)))) + (is (not= (hash (->Rec 1 1)) (hash r2))) + (is (not= (hash (->Rec 1 1)) (hash (assoc r :a 2)))) + (is (= (hash (->Rec 1 1)) (hash (assoc r :a 1)))) + (is (= (hash (->Rec 1 1)) (hash (dissoc r2 :c)))) + (is (= (hash (->Rec 1 1)) (hash (dissoc (assoc r :c 1) :c)))))) + +(deftest singleton-map-in-destructure-context + (let [sample-map {:a 1 :b 2} + {:keys [a] :as m1} (list sample-map)] + (is (= m1 sample-map)) + (is (= a 1)))) + +(deftest trailing-map-destructuring + (let [sample-map {:a 1 :b 2} + add (fn [& {:keys [a b]}] (+ a b)) + addn (fn [n & {:keys [a b]}] (+ n a b))] + (testing "that kwargs are applied properly given a map in place of the key/val pairs" + (is (= 3 (add :a 1 :b 2))) + (is (= 3 (add {:a 1 :b 2}))) + (is (= 13 (addn 10 :a 1 :b 2))) + (is (= 13 (addn 10 {:a 1 :b 2}))) + (is (= 103 ((partial addn 100) :a 1 {:b 2}))) + (is (= 103 ((partial addn 100 :a 1) {:b 2}))) + (is (= 107 ((partial addn 100 :a 1) {:a 5 :b 2})))) + (testing "built maps" + (let [{:as m1} (list :a 1 :b 2) + {:as m2} (list :a 1 :b 2 {:c 3}) + {:as m3} (list :a 1 :b 2 {:a 0}) + {:keys [a4] :as m4} (list nil)] + (= m1 {:a 1 :b 2}) + (= m2 {:a 1 :b 2 :c 3}) + (= m3 {:a 0 :b 2}) + (= m1 (seq-to-map-for-destructuring (list :a 1 :b 2))) + (= m2 (seq-to-map-for-destructuring (list :a 1 :b 2 {:c 3}))) + (= m3 (seq-to-map-for-destructuring (list :a 1 :b 2 {:a 0}))) (= a4 nil))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/data_structures_interop.clj b/Clojure/Clojure.Tests/clojure/test_clojure/data_structures_interop.clj index a61b455cc..d07be527c 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/data_structures_interop.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/data_structures_interop.clj @@ -1,136 +1,136 @@ -; 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. - -(ns clojure.test-clojure.data-structures-interop - (:require [clojure.test :refer :all] - [clojure.test.check.generators :as gen] - [clojure.test.check.properties :as prop] - [clojure.test.check.clojure-test :refer (defspec)])) - -;;; Irrelevant for ClojureCLR -;;; We use mostly generated IEnumerators via yield. These allow Current to be called after MoveNext hits the end (returns false) with no problem. -;;; This code, if uncommented, will load, but the tests fail. -;;; (The lines commented only by ;;; will work. Those commented out by ;;;;;; make no sense for ClojureCLR, e.g. reverse list iterators.) - -;;;(defn gen-range [min max] -;;; (gen/bind (gen/choose min max) (fn [n] (gen/tuple (gen/return n) -;;; (gen/choose n max))))) - -;;;(defn gen-subvec [generator] -;;; (gen/bind (gen/not-empty generator) -;;; (fn [v] (gen/bind (gen-range 0 (dec (count v))) -;;; (fn [[n m]] (gen/return (subvec v n m))))))) - -;;;(defn gen-gvec -;;; ([] -;;; (gen/bind (gen/elements {:int gen/int -;;; :short (gen/fmap short gen/byte) -;;; :long (gen/fmap long gen/int) -;;; :float (gen/fmap float gen/int) -;;; :double (gen/fmap double gen/int) -;;; :byte gen/byte -;;; :char gen/char -;;; :boolean gen/boolean}) -;;; #(apply gen-gvec %))) -;;; ([type generator] -;;; (gen/bind (gen/list generator) #(gen/return (apply vector-of type %))))) -;;; -;;;(defn gen-hash-set [generator] -;;; (gen/fmap (partial apply hash-set) (gen/list generator))) -;;; -;;;(defn gen-sorted-set [generator] -;;; (gen/fmap (partial apply sorted-set) (gen/list generator))) -;;; -;;;(defn gen-array-map [key-gen val-gen] -;;; (gen/fmap (partial into (array-map)) (gen/map key-gen val-gen))) -;;; -;;;(defn gen-sorted-map [key-gen val-gen] -;;; (gen/fmap (partial into (sorted-map)) (gen/map key-gen val-gen))) -;;; -;;;(defn gen-array -;;; ([] -;;; (gen/bind (gen/elements {int-array gen/int -;;; short-array gen/int -;;; long-array (gen/fmap long gen/int) -;;; float-array (gen/fmap float gen/int) -;;; double-array (gen/fmap double gen/int) -;;; byte-array gen/byte -;;; char-array gen/char -;;; boolean-array gen/boolean -;;; object-array gen/string}) -;;; #(apply gen-array %))) -;;; ([array-fn generator] -;;; (gen/fmap array-fn (gen/list generator)))) -;;; -;;;(defn exaust-iterator-forward [^System.Collections.IEnumerator iter] ;;; ^java.util.Iterator -;;; (loop [] (when (.MoveNext iter) (recur))) ;;; (loop [_ iter] (when (.hasNext iter) (recur (.next iter)))) -;;; (try (.MoveNext iter) (.Current iter) nil (catch Exception t t))) ;;; (.next iter) Throwable -;;; -;;;;;;(defn exaust-iterator-backward [^java.util.ListIterator iter] ;; no backwards iterator -;;;;;; (loop [_ iter] (when (.hasPrevious iter) (recur (.previous iter)))) -;;;;;; (try (.previous iter) nil (catch Throwable t t))) -;;; -;;;(defspec iterator-throws-exception-on-exaustion 100 -;;; (prop/for-all [[_ x] (gen/bind (gen/elements [['list (gen/list gen/int)] -;;; ['vector (gen/vector gen/int)] -;;; ['vector-of (gen-gvec)] -;;; ['subvec (gen-subvec (gen/vector gen/int))] -;;; ['hash-set (gen-hash-set gen/int)] -;;; ['sorted-set (gen-sorted-set gen/int)] -;;; ['hash-map (gen/hash-map gen/symbol gen/int)] -;;; ['array-map (gen-array-map gen/symbol gen/int)] -;;; ['sorted-map (gen-sorted-map gen/symbol gen/int)]]) -;;; (fn [[s g]] (gen/tuple (gen/return s) g)))] -;;; (instance? InvalidOperationException (exaust-iterator-forward (.GetEnumerator x))))) ;;; java.util.NoSuchElementException .iterator -;;; -;;;(defspec array-iterator-throws-exception-on-exaustion 100 -;;; (prop/for-all [arr (gen-array)] -;;; (let [iter (clojure.lang.ArrayIter/createFromObject arr)] -;;; (instance? InvalidOperationException (exaust-iterator-forward iter))))) ;;; java.util.NoSuchElementException -;;; -;;;;;;(defspec list-iterator-throws-exception-on-forward-exaustion 50 -;;;;;; (prop/for-all [[_ x] (gen/bind (gen/elements [['vector (gen/vector gen/int)] -;;;;;; ['subvec (gen-subvec (gen/vector gen/int))] -;;;;;; ['vector-of (gen-gvec)]]) -;;;;;; (fn [[s g]] (gen/tuple (gen/return s) g)))] -;;;;;; (instance? java.util.NoSuchElementException (exaust-iterator-forward (.listIterator x))))) -;;; -;;;;;;(defspec list-iterator-throws-exception-on-backward-exaustion 50 -;;;;;; (prop/for-all [[_ x] (gen/bind (gen/elements [['vector (gen/vector gen/int)] -;;;;;; ['subvec (gen-subvec (gen/vector gen/int))] -;;;;;; ['vector-of (gen-gvec)]]) -;;;;;; (fn [[s g]] (gen/tuple (gen/return s) g)))] -;;;;;; (instance? java.util.NoSuchElementException (exaust-iterator-backward (.listIterator x))))) -;;; -;;;(defspec map-keyset-iterator-throws-exception-on-exaustion 50 -;;; (prop/for-all [[_ m] (gen/bind (gen/elements [['hash-map (gen/hash-map gen/symbol gen/int) -;;; 'array-map (gen-array-map gen/symbol gen/int) -;;; 'sorted-map (gen-sorted-map gen/symbol gen/int)]]) -;;; (fn [[s g]] (gen/tuple (gen/return s) g)))] -;;; (let [iter (.GetEnumerator (.get_Keys m))] ;;; .iterator .keySet -;;; (instance? InvalidOperationException (exaust-iterator-forward iter))))) ;;; java.util.NoSuchElementException -;;; -;;;(defspec map-values-iterator-throws-exception-on-exaustion 50 -;;; (prop/for-all [[_ m] (gen/bind (gen/elements [['hash-map (gen/hash-map gen/symbol gen/int) -;;; 'array-map (gen-array-map gen/symbol gen/int) -;;; 'sorted-map (gen-sorted-map gen/symbol gen/int)]]) -;;; (fn [[s g]] (gen/tuple (gen/return s) g)))] -;;; (let [iter (.GetEnumerator (.get_Values m))] ;;; .iterator .values -;;; (instance? InvalidOperationException (exaust-iterator-forward iter))))) ;;; java.util.NoSuchElementException -;;; -;;;(defspec map-keys-iterator-throws-exception-on-exaustion 50 -;;; (prop/for-all [m (gen-sorted-map gen/symbol gen/int)] -;;; (instance? InvalidOperationException (exaust-iterator-forward (.GetEnumerator (.Keys m)))))) ;;; java.util.NoSuchElementException .keys -;;; -;;;(defspec map-vals-iterator-throws-exception-on-exaustion 50 -;;; (prop/for-all [m (gen-sorted-map gen/symbol gen/int)] -;;; (instance? InvalidOperationException (exaust-iterator-forward (.GetEnumerator (.Values m)))))) ;;; java.util.NoSuchElementException .vals -;;; -;;;;;;(defspec map-reverse-iterator-throws-exception-on-exaustion 50 -;;;;;; (prop/for-all [m (gen-sorted-map gen/symbol gen/int)] +; 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. + +(ns clojure.test-clojure.data-structures-interop + (:require [clojure.test :refer :all] + [clojure.test.check.generators :as gen] + [clojure.test.check.properties :as prop] + [clojure.test.check.clojure-test :refer (defspec)])) + +;;; Irrelevant for ClojureCLR +;;; We use mostly generated IEnumerators via yield. These allow Current to be called after MoveNext hits the end (returns false) with no problem. +;;; This code, if uncommented, will load, but the tests fail. +;;; (The lines commented only by ;;; will work. Those commented out by ;;;;;; make no sense for ClojureCLR, e.g. reverse list iterators.) + +;;;(defn gen-range [min max] +;;; (gen/bind (gen/choose min max) (fn [n] (gen/tuple (gen/return n) +;;; (gen/choose n max))))) + +;;;(defn gen-subvec [generator] +;;; (gen/bind (gen/not-empty generator) +;;; (fn [v] (gen/bind (gen-range 0 (dec (count v))) +;;; (fn [[n m]] (gen/return (subvec v n m))))))) + +;;;(defn gen-gvec +;;; ([] +;;; (gen/bind (gen/elements {:int gen/int +;;; :short (gen/fmap short gen/byte) +;;; :long (gen/fmap long gen/int) +;;; :float (gen/fmap float gen/int) +;;; :double (gen/fmap double gen/int) +;;; :byte gen/byte +;;; :char gen/char +;;; :boolean gen/boolean}) +;;; #(apply gen-gvec %))) +;;; ([type generator] +;;; (gen/bind (gen/list generator) #(gen/return (apply vector-of type %))))) +;;; +;;;(defn gen-hash-set [generator] +;;; (gen/fmap (partial apply hash-set) (gen/list generator))) +;;; +;;;(defn gen-sorted-set [generator] +;;; (gen/fmap (partial apply sorted-set) (gen/list generator))) +;;; +;;;(defn gen-array-map [key-gen val-gen] +;;; (gen/fmap (partial into (array-map)) (gen/map key-gen val-gen))) +;;; +;;;(defn gen-sorted-map [key-gen val-gen] +;;; (gen/fmap (partial into (sorted-map)) (gen/map key-gen val-gen))) +;;; +;;;(defn gen-array +;;; ([] +;;; (gen/bind (gen/elements {int-array gen/int +;;; short-array gen/int +;;; long-array (gen/fmap long gen/int) +;;; float-array (gen/fmap float gen/int) +;;; double-array (gen/fmap double gen/int) +;;; byte-array gen/byte +;;; char-array gen/char +;;; boolean-array gen/boolean +;;; object-array gen/string}) +;;; #(apply gen-array %))) +;;; ([array-fn generator] +;;; (gen/fmap array-fn (gen/list generator)))) +;;; +;;;(defn exaust-iterator-forward [^System.Collections.IEnumerator iter] ;;; ^java.util.Iterator +;;; (loop [] (when (.MoveNext iter) (recur))) ;;; (loop [_ iter] (when (.hasNext iter) (recur (.next iter)))) +;;; (try (.MoveNext iter) (.Current iter) nil (catch Exception t t))) ;;; (.next iter) Throwable +;;; +;;;;;;(defn exaust-iterator-backward [^java.util.ListIterator iter] ;; no backwards iterator +;;;;;; (loop [_ iter] (when (.hasPrevious iter) (recur (.previous iter)))) +;;;;;; (try (.previous iter) nil (catch Throwable t t))) +;;; +;;;(defspec iterator-throws-exception-on-exaustion 100 +;;; (prop/for-all [[_ x] (gen/bind (gen/elements [['list (gen/list gen/int)] +;;; ['vector (gen/vector gen/int)] +;;; ['vector-of (gen-gvec)] +;;; ['subvec (gen-subvec (gen/vector gen/int))] +;;; ['hash-set (gen-hash-set gen/int)] +;;; ['sorted-set (gen-sorted-set gen/int)] +;;; ['hash-map (gen/hash-map gen/symbol gen/int)] +;;; ['array-map (gen-array-map gen/symbol gen/int)] +;;; ['sorted-map (gen-sorted-map gen/symbol gen/int)]]) +;;; (fn [[s g]] (gen/tuple (gen/return s) g)))] +;;; (instance? InvalidOperationException (exaust-iterator-forward (.GetEnumerator x))))) ;;; java.util.NoSuchElementException .iterator +;;; +;;;(defspec array-iterator-throws-exception-on-exaustion 100 +;;; (prop/for-all [arr (gen-array)] +;;; (let [iter (clojure.lang.ArrayIter/createFromObject arr)] +;;; (instance? InvalidOperationException (exaust-iterator-forward iter))))) ;;; java.util.NoSuchElementException +;;; +;;;;;;(defspec list-iterator-throws-exception-on-forward-exaustion 50 +;;;;;; (prop/for-all [[_ x] (gen/bind (gen/elements [['vector (gen/vector gen/int)] +;;;;;; ['subvec (gen-subvec (gen/vector gen/int))] +;;;;;; ['vector-of (gen-gvec)]]) +;;;;;; (fn [[s g]] (gen/tuple (gen/return s) g)))] +;;;;;; (instance? java.util.NoSuchElementException (exaust-iterator-forward (.listIterator x))))) +;;; +;;;;;;(defspec list-iterator-throws-exception-on-backward-exaustion 50 +;;;;;; (prop/for-all [[_ x] (gen/bind (gen/elements [['vector (gen/vector gen/int)] +;;;;;; ['subvec (gen-subvec (gen/vector gen/int))] +;;;;;; ['vector-of (gen-gvec)]]) +;;;;;; (fn [[s g]] (gen/tuple (gen/return s) g)))] +;;;;;; (instance? java.util.NoSuchElementException (exaust-iterator-backward (.listIterator x))))) +;;; +;;;(defspec map-keyset-iterator-throws-exception-on-exaustion 50 +;;; (prop/for-all [[_ m] (gen/bind (gen/elements [['hash-map (gen/hash-map gen/symbol gen/int) +;;; 'array-map (gen-array-map gen/symbol gen/int) +;;; 'sorted-map (gen-sorted-map gen/symbol gen/int)]]) +;;; (fn [[s g]] (gen/tuple (gen/return s) g)))] +;;; (let [iter (.GetEnumerator (.get_Keys m))] ;;; .iterator .keySet +;;; (instance? InvalidOperationException (exaust-iterator-forward iter))))) ;;; java.util.NoSuchElementException +;;; +;;;(defspec map-values-iterator-throws-exception-on-exaustion 50 +;;; (prop/for-all [[_ m] (gen/bind (gen/elements [['hash-map (gen/hash-map gen/symbol gen/int) +;;; 'array-map (gen-array-map gen/symbol gen/int) +;;; 'sorted-map (gen-sorted-map gen/symbol gen/int)]]) +;;; (fn [[s g]] (gen/tuple (gen/return s) g)))] +;;; (let [iter (.GetEnumerator (.get_Values m))] ;;; .iterator .values +;;; (instance? InvalidOperationException (exaust-iterator-forward iter))))) ;;; java.util.NoSuchElementException +;;; +;;;(defspec map-keys-iterator-throws-exception-on-exaustion 50 +;;; (prop/for-all [m (gen-sorted-map gen/symbol gen/int)] +;;; (instance? InvalidOperationException (exaust-iterator-forward (.GetEnumerator (.Keys m)))))) ;;; java.util.NoSuchElementException .keys +;;; +;;;(defspec map-vals-iterator-throws-exception-on-exaustion 50 +;;; (prop/for-all [m (gen-sorted-map gen/symbol gen/int)] +;;; (instance? InvalidOperationException (exaust-iterator-forward (.GetEnumerator (.Values m)))))) ;;; java.util.NoSuchElementException .vals +;;; +;;;;;;(defspec map-reverse-iterator-throws-exception-on-exaustion 50 +;;;;;; (prop/for-all [m (gen-sorted-map gen/symbol gen/int)] ;;;;;; (instance? java.util.NoSuchElementException (exaust-iterator-forward (.reverseIterator m))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/def.clj b/Clojure/Clojure.Tests/clojure/test_clojure/def.clj index 365a93f26..419832589 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/def.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/def.clj @@ -52,13 +52,13 @@ #"Call to clojure.core/defn did not conform to spec" (eval-in-temp-ns (defn a "asdf" ([a] 1) {:a :b} ([] 1))))))) -(deftest non-dynamic-warnings - (testing "no warning for **" - (is (empty? (with-err-print-writer - (eval-in-temp-ns (defn ** ([a b] (Math/pow (double a) (double b))))))))) - (testing "warning for *hello*" - (is (not (empty? (with-err-print-writer - (eval-in-temp-ns (def *hello* "hi")))))))) +(deftest non-dynamic-warnings + (testing "no warning for **" + (is (empty? (with-err-print-writer + (eval-in-temp-ns (defn ** ([a b] (Math/pow (double a) (double b))))))))) + (testing "warning for *hello*" + (is (not (empty? (with-err-print-writer + (eval-in-temp-ns (def *hello* "hi")))))))) (deftest dynamic-redefinition ;; too many contextual things for this kind of caching to work... diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/delays.clj b/Clojure/Clojure.Tests/clojure/test_clojure/delays.clj index 86ee8804b..18114fd2e 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/delays.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/delays.clj @@ -6,88 +6,88 @@ ; the terms of this license. ; You must not remove this notice, or any other, from this software. -(ns clojure.test-clojure.delays - (:use clojure.test) - );;;(:import [System.Threading Barrier Thread ThreadStart]) ;;; [java.util.concurrent CyclicBarrier] - - - -;; DM: Added -;; Copied from reducers.clj, modified compile-if to compile-when +(ns clojure.test-clojure.delays + (:use clojure.test) + );;;(:import [System.Threading Barrier Thread ThreadStart]) ;;; [java.util.concurrent CyclicBarrier] + + + +;; DM: Added +;; Copied from reducers.clj, modified compile-if to compile-when ;;(defmacro ^:private compile-when ;; [exp & body] ;; (when (try (eval exp) ;; (catch Exception _ false)) ;;; Throwable -;; `(do ~@body))) - -(deftest calls-once - (let [a (atom 0) - d (delay (swap! a inc))] - (is (= 0 @a)) - (is (= 1 @d)) - (is (= 1 @d)) - (is (= 1 @a)))) - -(compile-when - (Type/GetType "System.Threading.Barrier") - - ;; DM: Need to conditionally import these names -(import '[System.Threading Barrier Thread ThreadStart]) -(deftest calls-once-in-parallel - - (let [a (atom 0) - d (delay (swap! a inc)) - threads 100 - ^Barrier barrier (Barrier. (+ threads 1))] ;;; ^CyclicBarrier CyclicBarrier. - (is (= 0 @a)) - (dotimes [_ threads] - (-> - (Thread. - (gen-delegate ThreadStart [] ;;; fn - (.SignalAndWait barrier) ;;; .await - (dotimes [_ 10000] - (is (= 1 @d))) - (.SignalAndWait barrier))) ;;; .await - (.Start))) ;;; .start - (.SignalAndWait barrier) ;;; .await - (.SignalAndWait barrier) ;;; .await - (is (= 1 @d)) - (is (= 1 @d)) - (is (= 1 @a)))) -) - -(deftest saves-exceptions - (let [f #(do (throw (Exception. "broken")) - 1) - d (delay (f)) - try-call #(try - @d - (catch Exception e e)) - first-result (try-call)] - (is (instance? Exception first-result)) - (is (identical? first-result (try-call))))) - -#_(deftest saves-exceptions-in-parallel ;;; seems to take forewever - (let [f #(do (throw (Exception. "broken")) - 1) - d (delay (f)) - try-call #(try - @d - (catch Exception e e)) - threads 100 - ^Barrier barrier (Barrier. (+ threads 1))] ;;; ^CyclicBarrier CyclicBarrier. - (dotimes [_ threads] - (-> - (Thread. - (gen-delegate ThreadStart [] ;;; fn - (.SignalAndWait barrier) ;;; .await - (let [first-result (try-call)] - (dotimes [_ 10000] - (is (instance? Exception (try-call))) - (is (identical? first-result (try-call))))) - (.SignalAndWait barrier))) ;;; .await - (.Start))) ;;; .start - (.SignalAndWait barrier) ;;; .await - (.SignalAndWait barrier) ;;; .await - (is (instance? Exception (try-call))) +;; `(do ~@body))) + +(deftest calls-once + (let [a (atom 0) + d (delay (swap! a inc))] + (is (= 0 @a)) + (is (= 1 @d)) + (is (= 1 @d)) + (is (= 1 @a)))) + +(compile-when + (Type/GetType "System.Threading.Barrier") + + ;; DM: Need to conditionally import these names +(import '[System.Threading Barrier Thread ThreadStart]) +(deftest calls-once-in-parallel + + (let [a (atom 0) + d (delay (swap! a inc)) + threads 100 + ^Barrier barrier (Barrier. (+ threads 1))] ;;; ^CyclicBarrier CyclicBarrier. + (is (= 0 @a)) + (dotimes [_ threads] + (-> + (Thread. + (gen-delegate ThreadStart [] ;;; fn + (.SignalAndWait barrier) ;;; .await + (dotimes [_ 10000] + (is (= 1 @d))) + (.SignalAndWait barrier))) ;;; .await + (.Start))) ;;; .start + (.SignalAndWait barrier) ;;; .await + (.SignalAndWait barrier) ;;; .await + (is (= 1 @d)) + (is (= 1 @d)) + (is (= 1 @a)))) +) + +(deftest saves-exceptions + (let [f #(do (throw (Exception. "broken")) + 1) + d (delay (f)) + try-call #(try + @d + (catch Exception e e)) + first-result (try-call)] + (is (instance? Exception first-result)) + (is (identical? first-result (try-call))))) + +#_(deftest saves-exceptions-in-parallel ;;; seems to take forewever + (let [f #(do (throw (Exception. "broken")) + 1) + d (delay (f)) + try-call #(try + @d + (catch Exception e e)) + threads 100 + ^Barrier barrier (Barrier. (+ threads 1))] ;;; ^CyclicBarrier CyclicBarrier. + (dotimes [_ threads] + (-> + (Thread. + (gen-delegate ThreadStart [] ;;; fn + (.SignalAndWait barrier) ;;; .await + (let [first-result (try-call)] + (dotimes [_ 10000] + (is (instance? Exception (try-call))) + (is (identical? first-result (try-call))))) + (.SignalAndWait barrier))) ;;; .await + (.Start))) ;;; .start + (.SignalAndWait barrier) ;;; .await + (.SignalAndWait barrier) ;;; .await + (is (instance? Exception (try-call))) (is (identical? (try-call) (try-call))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/edn.clj b/Clojure/Clojure.Tests/clojure/test_clojure/edn.clj index 0498ae460..80c4b43bf 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/edn.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/edn.clj @@ -1,38 +1,38 @@ -; 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: Stuart Halloway - - -(ns clojure.test-clojure.edn - (:require [clojure.test.generative :refer (defspec)] - [clojure.test-clojure.generators :as cgen] - [clojure.edn :as edn])) - -(defn roundtrip - "Print an object and read it back as edn. Returns rather than throws - any exceptions." - [o] - (binding [*print-length* nil - *print-dup* nil - *print-level* nil] - (try - (-> o pr-str edn/read-string) - (catch Exception t t)))) ;;; Throwable - -(defspec types-that-should-roundtrip - roundtrip - [^{:tag cgen/ednable} o] - (when-not (= o %) - (throw (ex-info "Value cannot roundtrip, see ex-data" {:printed o :read %})))) - -(defspec types-that-should-not-roundtrip - roundtrip - [^{:tag cgen/non-ednable} o] - (when-not (instance? Exception %) ;;; Throwable +; 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: Stuart Halloway + + +(ns clojure.test-clojure.edn + (:require [clojure.test.generative :refer (defspec)] + [clojure.test-clojure.generators :as cgen] + [clojure.edn :as edn])) + +(defn roundtrip + "Print an object and read it back as edn. Returns rather than throws + any exceptions." + [o] + (binding [*print-length* nil + *print-dup* nil + *print-level* nil] + (try + (-> o pr-str edn/read-string) + (catch Exception t t)))) ;;; Throwable + +(defspec types-that-should-roundtrip + roundtrip + [^{:tag cgen/ednable} o] + (when-not (= o %) + (throw (ex-info "Value cannot roundtrip, see ex-data" {:printed o :read %})))) + +(defspec types-that-should-not-roundtrip + roundtrip + [^{:tag cgen/non-ednable} o] + (when-not (instance? Exception %) ;;; Throwable (throw (ex-info "edn/read should have thrown, see ex-data" {:printed o :read %})))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/errors.clj b/Clojure/Clojure.Tests/clojure/test_clojure/errors.clj index 87a5472f4..344979dd5 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/errors.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/errors.clj @@ -16,13 +16,13 @@ (defn f1 [a] a) -;; Function name that includes many special characters to test demunge -(defn f2:+><->!#%&*b [x] x) ;;; f2:+><->!#%&*|b -- removed | because we use for escaping +;; Function name that includes many special characters to test demunge +(defn f2:+><->!#%&*b [x] x) ;;; f2:+><->!#%&*|b -- removed | because we use for escaping (defmacro m0 [] `(identity 0)) (defmacro m1 [a] `(inc ~a)) - + (defmacro m2 [] (assoc)) (deftest arity-exception @@ -34,27 +34,27 @@ (is (thrown-with-msg? ArityException #"Wrong number of args \(1\) passed to" (macroexpand `(m0 1)))) (is (thrown-with-msg? ArityException #"Wrong number of args \(2\) passed to" - (macroexpand `(m1 1 2)))) - (is (thrown-with-msg? ArityException (System.Text.RegularExpressions.Regex. (System.Text.RegularExpressions.Regex/Escape "f2:+><->!#%&*b")) ;;; We don't have \Q... \E : #"\Q/f2:+><->!#%&*|b\E" - (f2:+><->!#%&*b 1 2)) ;;; f2:+><->!#%&*|b - "ArityException messages should demunge function names") - (is (try - (macroexpand `(m2)) - (throw (Exception. "fail")) ;;; RuntimeException. - (catch ArityException e - (is (= 0 (.-Actual e)))))) - (is (try - (macroexpand `(m2 5)) - (throw (Exception. "fail")) ;;; RuntimeException. - (catch ArityException e + (macroexpand `(m1 1 2)))) + (is (thrown-with-msg? ArityException (System.Text.RegularExpressions.Regex. (System.Text.RegularExpressions.Regex/Escape "f2:+><->!#%&*b")) ;;; We don't have \Q... \E : #"\Q/f2:+><->!#%&*|b\E" + (f2:+><->!#%&*b 1 2)) ;;; f2:+><->!#%&*|b + "ArityException messages should demunge function names") + (is (try + (macroexpand `(m2)) + (throw (Exception. "fail")) ;;; RuntimeException. + (catch ArityException e + (is (= 0 (.-Actual e)))))) + (is (try + (macroexpand `(m2 5)) + (throw (Exception. "fail")) ;;; RuntimeException. + (catch ArityException e (is (= 1 (.-Actual e))))))) -(deftest compile-error-examples - (are [form errtype re] (thrown-with-cause-msg? errtype re (eval form)) - '(Int32/Parse) Exception #"No field, property, or method.*taking 0 args.*" ;;; Long/parseLong #"No method.*taking 0 args" - '(Int32/Parse :a :b :c :d) Exception #"No matching member.*taking 4 args") ;;; (Long/parseLong :a :b :c) #"No matching method.*taking 3 args" - (are [form errtype re] (thrown-with-msg? errtype re (eval form)) - '(.jump "foo" 1) Exception #"No matching member.*taking 1 arg")) ;;; #"No matching method.*taking 1 arg" +(deftest compile-error-examples + (are [form errtype re] (thrown-with-cause-msg? errtype re (eval form)) + '(Int32/Parse) Exception #"No field, property, or method.*taking 0 args.*" ;;; Long/parseLong #"No method.*taking 0 args" + '(Int32/Parse :a :b :c :d) Exception #"No matching member.*taking 4 args") ;;; (Long/parseLong :a :b :c) #"No matching method.*taking 3 args" + (are [form errtype re] (thrown-with-msg? errtype re (eval form)) + '(.jump "foo" 1) Exception #"No matching member.*taking 1 arg")) ;;; #"No matching method.*taking 1 arg" (deftest assert-arg-messages ; used to ensure that error messages properly use local names for macros @@ -73,47 +73,47 @@ (is (= {:foo 1} (ex-data t))))) (is (nil? (ex-data (Exception. "example non ex-data"))))) ;;; RuntimeException -(deftest Throwable->map-test - (testing "base functionality" - (let [{:keys [cause via trace]} (Throwable->map - (Exception. "I am a string literal"))] - (is (= cause "I am a string literal")) - (is (= 1 (count via))) - (is (vector? via)) - (is (= ["I am a string literal"] (map :message via))))) - (testing "causes" - (let [{:keys [cause via trace]} (Throwable->map - (Exception. "I am not a number" - (Exception. "double two")))] - (is (= cause "double two")) - (is (= ["I am not a number" "double two"] - (map :message via))))) - (testing "ex-data" - (let [{[{:keys [data]}] :via - data-top-level :data} - (Throwable->map (ex-info "ex-info" - {:some "data"}))] - (is (= data data-top-level {:some "data"})))) - (testing "nil stack handled" - (let [t (Exception. "abc")] ;;; Throwable. - ;; simulate what can happen when Java omits stack traces - ;;;(.setStackTrace t (into-array StackTraceElement [])) -- no equivalent, but an unthrown exception has a null stacktrace - (let [{:keys [cause via trace]} (Throwable->map t)] - (is (= cause "abc")) - (is (= trace [])) - - ;; fail if printing throws an exception - (try - (with-out-str (pr t)) - (catch Exception t (is nil))))))) ;;; Throwable - -(deftest ex-info-disallows-nil-data - (is (thrown? Microsoft.Scripting.ArgumentTypeException (ex-info "message" nil))) ;;; IllegalArgumentException -- we have an overload on ctors --passing nil makes it impossible to determine which to call. - (is (thrown? ArgumentException (ex-info "message" nil (Exception. "cause"))))) ;;; IllegalArgumentException Throwable. - -(deftest ex-info-arities-construct-equivalent-exceptions - (let [ex1 (ex-info "message" {:foo "bar"}) - ex2 (ex-info "message" {:foo "bar"} nil)] - (is (= (.Message ex1) (.Message ex2))) ;;; .getMessage .getMessage - (is (= (.getData ex1) (.getData ex2))) +(deftest Throwable->map-test + (testing "base functionality" + (let [{:keys [cause via trace]} (Throwable->map + (Exception. "I am a string literal"))] + (is (= cause "I am a string literal")) + (is (= 1 (count via))) + (is (vector? via)) + (is (= ["I am a string literal"] (map :message via))))) + (testing "causes" + (let [{:keys [cause via trace]} (Throwable->map + (Exception. "I am not a number" + (Exception. "double two")))] + (is (= cause "double two")) + (is (= ["I am not a number" "double two"] + (map :message via))))) + (testing "ex-data" + (let [{[{:keys [data]}] :via + data-top-level :data} + (Throwable->map (ex-info "ex-info" + {:some "data"}))] + (is (= data data-top-level {:some "data"})))) + (testing "nil stack handled" + (let [t (Exception. "abc")] ;;; Throwable. + ;; simulate what can happen when Java omits stack traces + ;;;(.setStackTrace t (into-array StackTraceElement [])) -- no equivalent, but an unthrown exception has a null stacktrace + (let [{:keys [cause via trace]} (Throwable->map t)] + (is (= cause "abc")) + (is (= trace [])) + + ;; fail if printing throws an exception + (try + (with-out-str (pr t)) + (catch Exception t (is nil))))))) ;;; Throwable + +(deftest ex-info-disallows-nil-data + (is (thrown? Microsoft.Scripting.ArgumentTypeException (ex-info "message" nil))) ;;; IllegalArgumentException -- we have an overload on ctors --passing nil makes it impossible to determine which to call. + (is (thrown? ArgumentException (ex-info "message" nil (Exception. "cause"))))) ;;; IllegalArgumentException Throwable. + +(deftest ex-info-arities-construct-equivalent-exceptions + (let [ex1 (ex-info "message" {:foo "bar"}) + ex2 (ex-info "message" {:foo "bar"} nil)] + (is (= (.Message ex1) (.Message ex2))) ;;; .getMessage .getMessage + (is (= (.getData ex1) (.getData ex2))) (is (= (.InnerException ex1) (.InnerException ex2))))) ;;; .getCause .getCause \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/evaluation.clj b/Clojure/Clojure.Tests/clojure/test_clojure/evaluation.clj index 6e013eaf9..24411b1bd 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/evaluation.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/evaluation.clj @@ -1,226 +1,226 @@ -; 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. - - -;; Tests for the Clojure functions documented at the URL: -;; -;; http://clojure.org/Evaluation -;; -;; by J. McConnell -;; Created 22 October 2008 - -(ns clojure.test-clojure.evaluation - (:use clojure.test)) - -(import ;;; not needed: '(java.lang Boolean) - (clojure.lang Compiler Compiler+CompilerException)) ;;; Compiler$CompilerException - -(defmacro test-that - "Provides a useful way for specifying the purpose of tests. If the first-level - forms are lists that make a call to a clojure.test function, it supplies the - purpose as the msg argument to those functions. Otherwise, the purpose just - acts like a comment and the forms are run unchanged." - [purpose & test-forms] - (let [tests (map - #(if (= (:ns (meta (resolve (first %)))) - (the-ns 'clojure.test)) - (concat % (list purpose)) - %) - test-forms)] - `(do ~@tests))) - -(deftest Eval - (is (= (eval '(+ 1 2 3)) (Compiler/eval '(+ 1 2 3)))) - (is (= (eval '(list 1 2 3)) '(1 2 3))) - (is (= (eval '(list + 1 2 3)) (list clojure.core/+ 1 2 3))) - (test-that "Non-closure fns are supported as code" - (is (= (eval (eval '(list + 1 2 3))) 6))) - (is (= (eval (list '+ 1 2 3)) 6))) - -; not using Clojure's RT/classForName since a bug in it could hide a bug in -; eval's resolution -(defn class-for-name [name] - (Type/GetType name false)) ;;; (java.lang.Class/forName name)) - -(defmacro in-test-ns [& body] - `(binding [*ns* *ns*] - (in-ns 'clojure.test-clojure.evaluation) - ~@body)) - -;;; Literals tests ;;; - -(defmacro ^{:private true} evaluates-to-itself? [expr] - `(let [v# ~expr - q# (quote ~expr)] - (is (= (eval q#) q#) (str q# " does not evaluate to itself")))) - -(deftest Literals - ; Strings, numbers, characters, nil and keywords should evaluate to themselves - (evaluates-to-itself? "test") - (evaluates-to-itself? "test - multi-line - string") - (evaluates-to-itself? 1) - (evaluates-to-itself? 1.0) - (evaluates-to-itself? 1.123456789) - (evaluates-to-itself? 1/2) - (evaluates-to-itself? 1M) - (evaluates-to-itself? 999999999999999999) - (evaluates-to-itself? \a) - (evaluates-to-itself? \newline) - (evaluates-to-itself? nil) - (evaluates-to-itself? :test) - ; Boolean literals should evaluate to Boolean.{TRUE|FALSE} ;;; Except we don't have. Use RT.T and RT.F instead. - ;(is (identical? (eval true) clojure.lang.RT/T)) ;;; Boolean/TRUE)) - );(is (identical? (eval false) clojure.lang.RT/F))) ;;; Boolean/FALSE))) - -;;; Symbol resolution tests ;;; - -(def foo "abc") -(in-ns 'resolution-test) -(def bar 123) -(def ^{:private true} baz 456) -(in-ns 'clojure.test-clojure.evaluation) - -(defn a-match? [re s] (not (nil? (re-find re s)))) ;;; re-matches -- I can't expect an exact match. - -(defmacro throws-with-msg - ([re form] `(throws-with-msg ~re ~form Exception)) - ([re form x] `(throws-with-msg - ~re - ~form - ~(if (instance? Exception x) x Exception) - ~(if (instance? String x) x nil))) - ([re form class msg] - `(let [ex# (try - ~form - (catch ~class e# e#) - (catch Exception e# - (let [cause# (.InnerException e#)] ;;; .getCause - (if (= ~class (class cause#)) cause# (throw e#)))))] - (is (a-match? ~re (.ToString ex#)) ;;; .toString - (or ~msg - (str "Expected exception that matched " (pr-str ~re) - ", but got exception with message: \"" ex#)))))) - -(deftest SymbolResolution - (test-that - "If a symbol is namespace-qualified, the evaluated value is the value - of the binding of the global var named by the symbol" - (is (= (eval 'resolution-test/bar) 123))) - - (test-that - "It is an error if there is no global var named by the symbol" - (throws-with-msg - #"(?s).*Unable to resolve symbol: bar.*" (eval 'bar))) - - (test-that - "It is an error if the symbol reference is to a non-public var in a - different namespace" - (throws-with-msg - #"(?s).*resolution-test/baz is not public.*" - (eval 'resolution-test/baz) - Exception)) ;;; Compiler$CompilerException)) - - (test-that - "If a symbol is package-qualified, its value is the Java class named by the - symbol" - (is (= (eval 'System.Math) (class-for-name "System.Math")))) ;;; java.lang.Math - - (test-that - "If a symbol is package-qualified, it is an error if there is no Class named - by the symbol" - (is (thrown? Exception (eval 'java.lang.FooBar)))) ;;; Compiler$CompilerException - - (test-that - "If a symbol is not qualified, the following applies, in this order: - - 1. If it names a special form it is considered a special form, and must - be utilized accordingly. - - 2. A lookup is done in the current namespace to see if there is a mapping - from the symbol to a class. If so, the symbol is considered to name a - Java class object. - - 3. If in a local scope (i.e. in a function definition), a lookup is done - to see if it names a local binding (e.g. a function argument or - let-bound name). If so, the value is the value of the local binding. - - 4. A lookup is done in the current namespace to see if there is a mapping - from the symbol to a var. If so, the value is the value of the binding - of the var referred-to by the symbol. - - 5. It is an error." - - ; First - (doall (for [form '(def if do let quote var fn loop recur throw try - monitor-enter monitor-exit)] - (is (thrown? Exception (eval form))))) ;;; Compiler$CompilerException - (let [if "foo"] - (is (thrown? Exception (eval 'if))) ;;; Compiler$CompilerException - - ; Second - (is (= (eval 'Boolean) (class-for-name "System.Boolean")))) ;;; "java.lang.Boolean" - (let [Boolean "foo"] - (is (= (eval 'Boolean) (class-for-name "System.Boolean")))) - - ; Third - (is (= (eval '(let [foo "bar"] foo)) "bar")) - - ; Fourth - (in-test-ns (is (= (eval 'foo) "abc"))) - (is (thrown? Exception (eval 'bar))) ; not in this namespace ;;; Compiler$CompilerException - - ; Fifth - (is (thrown? Exception (eval 'foobar))))) ;;; Compiler$CompilerException - -;;; Metadata tests ;;; - -(defstruct struct-with-symbols (with-meta 'k {:a "A"})) - -(deftest Metadata - - (test-that - "find returns key symbols and their metadata" - (let [s (struct struct-with-symbols 1)] - (is (= {:a "A"} (meta (first (find s 'k)))))))) - -;;; Collections tests ;;; -(def x 1) -(def y 2) - -(deftest Collections - (in-test-ns - (test-that - "Vectors and Maps yield vectors and (hash) maps whose contents are the - evaluated values of the objects they contain." - (is (= (eval '[x y 3]) [1 2 3])) - (is (= (eval '{:x x :y y :z 3}) {:x 1 :y 2 :z 3})) - (is (instance? clojure.lang.IPersistentMap (eval '{:x x :y y}))))) - - (in-test-ns - (test-that - "Metadata maps yield maps whose contents are the evaluated values of - the objects they contain. If a vector or map has metadata, the evaluated - metadata map will become the metadata of the resulting value." - (is (= (eval ^{:x x} '[x y]) ^{:x 1} [1 2])))) - - (test-that - "An empty list () evaluates to an empty list." - (is (= (eval '()) ())) - (is (empty? (eval ()))) - (is (= (eval (list)) ()))) - - ;aargh, fragile tests, please fix - #_(test-that - "Non-empty lists are considered calls" - (is (thrown? System.InvalidCastException (eval '(1 2 3)))))) ;;; Compiler$CompilerException -- this is nested - -(deftest Macros) - -(deftest Loading) +; 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. + + +;; Tests for the Clojure functions documented at the URL: +;; +;; http://clojure.org/Evaluation +;; +;; by J. McConnell +;; Created 22 October 2008 + +(ns clojure.test-clojure.evaluation + (:use clojure.test)) + +(import ;;; not needed: '(java.lang Boolean) + (clojure.lang Compiler Compiler+CompilerException)) ;;; Compiler$CompilerException + +(defmacro test-that + "Provides a useful way for specifying the purpose of tests. If the first-level + forms are lists that make a call to a clojure.test function, it supplies the + purpose as the msg argument to those functions. Otherwise, the purpose just + acts like a comment and the forms are run unchanged." + [purpose & test-forms] + (let [tests (map + #(if (= (:ns (meta (resolve (first %)))) + (the-ns 'clojure.test)) + (concat % (list purpose)) + %) + test-forms)] + `(do ~@tests))) + +(deftest Eval + (is (= (eval '(+ 1 2 3)) (Compiler/eval '(+ 1 2 3)))) + (is (= (eval '(list 1 2 3)) '(1 2 3))) + (is (= (eval '(list + 1 2 3)) (list clojure.core/+ 1 2 3))) + (test-that "Non-closure fns are supported as code" + (is (= (eval (eval '(list + 1 2 3))) 6))) + (is (= (eval (list '+ 1 2 3)) 6))) + +; not using Clojure's RT/classForName since a bug in it could hide a bug in +; eval's resolution +(defn class-for-name [name] + (Type/GetType name false)) ;;; (java.lang.Class/forName name)) + +(defmacro in-test-ns [& body] + `(binding [*ns* *ns*] + (in-ns 'clojure.test-clojure.evaluation) + ~@body)) + +;;; Literals tests ;;; + +(defmacro ^{:private true} evaluates-to-itself? [expr] + `(let [v# ~expr + q# (quote ~expr)] + (is (= (eval q#) q#) (str q# " does not evaluate to itself")))) + +(deftest Literals + ; Strings, numbers, characters, nil and keywords should evaluate to themselves + (evaluates-to-itself? "test") + (evaluates-to-itself? "test + multi-line + string") + (evaluates-to-itself? 1) + (evaluates-to-itself? 1.0) + (evaluates-to-itself? 1.123456789) + (evaluates-to-itself? 1/2) + (evaluates-to-itself? 1M) + (evaluates-to-itself? 999999999999999999) + (evaluates-to-itself? \a) + (evaluates-to-itself? \newline) + (evaluates-to-itself? nil) + (evaluates-to-itself? :test) + ; Boolean literals should evaluate to Boolean.{TRUE|FALSE} ;;; Except we don't have. Use RT.T and RT.F instead. + ;(is (identical? (eval true) clojure.lang.RT/T)) ;;; Boolean/TRUE)) + );(is (identical? (eval false) clojure.lang.RT/F))) ;;; Boolean/FALSE))) + +;;; Symbol resolution tests ;;; + +(def foo "abc") +(in-ns 'resolution-test) +(def bar 123) +(def ^{:private true} baz 456) +(in-ns 'clojure.test-clojure.evaluation) + +(defn a-match? [re s] (not (nil? (re-find re s)))) ;;; re-matches -- I can't expect an exact match. + +(defmacro throws-with-msg + ([re form] `(throws-with-msg ~re ~form Exception)) + ([re form x] `(throws-with-msg + ~re + ~form + ~(if (instance? Exception x) x Exception) + ~(if (instance? String x) x nil))) + ([re form class msg] + `(let [ex# (try + ~form + (catch ~class e# e#) + (catch Exception e# + (let [cause# (.InnerException e#)] ;;; .getCause + (if (= ~class (class cause#)) cause# (throw e#)))))] + (is (a-match? ~re (.ToString ex#)) ;;; .toString + (or ~msg + (str "Expected exception that matched " (pr-str ~re) + ", but got exception with message: \"" ex#)))))) + +(deftest SymbolResolution + (test-that + "If a symbol is namespace-qualified, the evaluated value is the value + of the binding of the global var named by the symbol" + (is (= (eval 'resolution-test/bar) 123))) + + (test-that + "It is an error if there is no global var named by the symbol" + (throws-with-msg + #"(?s).*Unable to resolve symbol: bar.*" (eval 'bar))) + + (test-that + "It is an error if the symbol reference is to a non-public var in a + different namespace" + (throws-with-msg + #"(?s).*resolution-test/baz is not public.*" + (eval 'resolution-test/baz) + Exception)) ;;; Compiler$CompilerException)) + + (test-that + "If a symbol is package-qualified, its value is the Java class named by the + symbol" + (is (= (eval 'System.Math) (class-for-name "System.Math")))) ;;; java.lang.Math + + (test-that + "If a symbol is package-qualified, it is an error if there is no Class named + by the symbol" + (is (thrown? Exception (eval 'java.lang.FooBar)))) ;;; Compiler$CompilerException + + (test-that + "If a symbol is not qualified, the following applies, in this order: + + 1. If it names a special form it is considered a special form, and must + be utilized accordingly. + + 2. A lookup is done in the current namespace to see if there is a mapping + from the symbol to a class. If so, the symbol is considered to name a + Java class object. + + 3. If in a local scope (i.e. in a function definition), a lookup is done + to see if it names a local binding (e.g. a function argument or + let-bound name). If so, the value is the value of the local binding. + + 4. A lookup is done in the current namespace to see if there is a mapping + from the symbol to a var. If so, the value is the value of the binding + of the var referred-to by the symbol. + + 5. It is an error." + + ; First + (doall (for [form '(def if do let quote var fn loop recur throw try + monitor-enter monitor-exit)] + (is (thrown? Exception (eval form))))) ;;; Compiler$CompilerException + (let [if "foo"] + (is (thrown? Exception (eval 'if))) ;;; Compiler$CompilerException + + ; Second + (is (= (eval 'Boolean) (class-for-name "System.Boolean")))) ;;; "java.lang.Boolean" + (let [Boolean "foo"] + (is (= (eval 'Boolean) (class-for-name "System.Boolean")))) + + ; Third + (is (= (eval '(let [foo "bar"] foo)) "bar")) + + ; Fourth + (in-test-ns (is (= (eval 'foo) "abc"))) + (is (thrown? Exception (eval 'bar))) ; not in this namespace ;;; Compiler$CompilerException + + ; Fifth + (is (thrown? Exception (eval 'foobar))))) ;;; Compiler$CompilerException + +;;; Metadata tests ;;; + +(defstruct struct-with-symbols (with-meta 'k {:a "A"})) + +(deftest Metadata + + (test-that + "find returns key symbols and their metadata" + (let [s (struct struct-with-symbols 1)] + (is (= {:a "A"} (meta (first (find s 'k)))))))) + +;;; Collections tests ;;; +(def x 1) +(def y 2) + +(deftest Collections + (in-test-ns + (test-that + "Vectors and Maps yield vectors and (hash) maps whose contents are the + evaluated values of the objects they contain." + (is (= (eval '[x y 3]) [1 2 3])) + (is (= (eval '{:x x :y y :z 3}) {:x 1 :y 2 :z 3})) + (is (instance? clojure.lang.IPersistentMap (eval '{:x x :y y}))))) + + (in-test-ns + (test-that + "Metadata maps yield maps whose contents are the evaluated values of + the objects they contain. If a vector or map has metadata, the evaluated + metadata map will become the metadata of the resulting value." + (is (= (eval ^{:x x} '[x y]) ^{:x 1} [1 2])))) + + (test-that + "An empty list () evaluates to an empty list." + (is (= (eval '()) ())) + (is (empty? (eval ()))) + (is (= (eval (list)) ()))) + + ;aargh, fragile tests, please fix + #_(test-that + "Non-empty lists are considered calls" + (is (thrown? System.InvalidCastException (eval '(1 2 3)))))) ;;; Compiler$CompilerException -- this is nested + +(deftest Macros) + +(deftest Loading) diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/fn.clj b/Clojure/Clojure.Tests/clojure/test_clojure/fn.clj index 31f34b1bb..8115f592d 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/fn.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/fn.clj @@ -1,55 +1,55 @@ -; 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: Ambrose Bonnaire-Sergeant - -(ns clojure.test-clojure.fn - (:use clojure.test clojure.test-helper)) - -(deftest fn-error-checking - (testing "bad arglist" - (is (fails-with-cause? clojure.lang.ExceptionInfo - #"Call to clojure.core/fn did not conform to spec" - (eval '(fn "a" a))))) - - (testing "treat first param as args" - (is (fails-with-cause? clojure.lang.ExceptionInfo - #"Call to clojure.core/fn did not conform to spec" - (eval '(fn "a" []))))) - - (testing "looks like listy signature, but malformed declaration" - (is (fails-with-cause? clojure.lang.ExceptionInfo - #"Call to clojure.core/fn did not conform to spec" - (eval '(fn (1)))))) - - (testing "checks each signature" - (is (fails-with-cause? clojure.lang.ExceptionInfo - #"Call to clojure.core/fn did not conform to spec" - (eval '(fn - ([a] 1) - ("a" 2)))))) - - (testing "correct name but invalid args" - (is (fails-with-cause? clojure.lang.ExceptionInfo - #"Call to clojure.core/fn did not conform to spec" - (eval '(fn a "a"))))) - - (testing "first sig looks multiarity, rest of sigs should be lists" - (is (fails-with-cause? clojure.lang.ExceptionInfo - #"Call to clojure.core/fn did not conform to spec" - (eval '(fn a - ([a] 1) - [a b]))))) - - (testing "missing parameter declaration" - (is (fails-with-cause? clojure.lang.ExceptionInfo - #"Call to clojure.core/fn did not conform to spec" - (eval '(fn a)))) - (is (fails-with-cause? clojure.lang.ExceptionInfo - #"Call to clojure.core/fn did not conform to spec" +; 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: Ambrose Bonnaire-Sergeant + +(ns clojure.test-clojure.fn + (:use clojure.test clojure.test-helper)) + +(deftest fn-error-checking + (testing "bad arglist" + (is (fails-with-cause? clojure.lang.ExceptionInfo + #"Call to clojure.core/fn did not conform to spec" + (eval '(fn "a" a))))) + + (testing "treat first param as args" + (is (fails-with-cause? clojure.lang.ExceptionInfo + #"Call to clojure.core/fn did not conform to spec" + (eval '(fn "a" []))))) + + (testing "looks like listy signature, but malformed declaration" + (is (fails-with-cause? clojure.lang.ExceptionInfo + #"Call to clojure.core/fn did not conform to spec" + (eval '(fn (1)))))) + + (testing "checks each signature" + (is (fails-with-cause? clojure.lang.ExceptionInfo + #"Call to clojure.core/fn did not conform to spec" + (eval '(fn + ([a] 1) + ("a" 2)))))) + + (testing "correct name but invalid args" + (is (fails-with-cause? clojure.lang.ExceptionInfo + #"Call to clojure.core/fn did not conform to spec" + (eval '(fn a "a"))))) + + (testing "first sig looks multiarity, rest of sigs should be lists" + (is (fails-with-cause? clojure.lang.ExceptionInfo + #"Call to clojure.core/fn did not conform to spec" + (eval '(fn a + ([a] 1) + [a b]))))) + + (testing "missing parameter declaration" + (is (fails-with-cause? clojure.lang.ExceptionInfo + #"Call to clojure.core/fn did not conform to spec" + (eval '(fn a)))) + (is (fails-with-cause? clojure.lang.ExceptionInfo + #"Call to clojure.core/fn did not conform to spec" (eval '(fn)))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/generators.clj b/Clojure/Clojure.Tests/clojure/test_clojure/generators.clj index f9762e10d..8d5da53a4 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/generators.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/generators.clj @@ -1,132 +1,132 @@ -(ns clojure.test-clojure.generators - (:require [clojure.data.generators :as gen]) - (:refer-clojure :exclude [namespace])) - -(defn var-value-source - "Generates a scalar suitable for an initial var value." - [] - (let [v (gen/scalar)] - (if (symbol? v) - `(quote ~v) - v))) - -(defn var-source - [n] - `(def ~(symbol (str "var" n)) - ~(var-value-source))) - -(defn record-source - [n] - (let [rname (str "ExampleRecord" "-" n) - fldct (gen/geometric 0.1)] - `(defrecord ~(symbol rname) ~(vec (map #(symbol (str "f" %)) (range fldct)))))) - -(defn generate-namespaces - "Returns a map with :nses, :vars, :records" - [{:keys [nses vars-per-ns records-per-ns]}] - (let [nses (mapv #(create-ns (symbol (str "clojure.generated.ns" %))) - (range nses)) - _ (doseq [ns nses] (binding [*ns* ns] (refer 'clojure.core))) - make-in-ns (fn [ns src] (binding [*ns* ns] (eval src))) - vars (->> (mapcat - (fn [ns] - (map - #(make-in-ns ns (var-source %)) - (range vars-per-ns))) - nses) - (into [])) - records (->> (mapcat - (fn [ns] - (map - #(make-in-ns ns (record-source %)) - (range records-per-ns))) - nses) - (into []))] - {:nses nses - :vars vars - :records records})) - -(def shared-generation - (delay (generate-namespaces {:nses 5 :vars-per-ns 5 :records-per-ns 5}))) - -(defn namespace - [] - (gen/rand-nth (:nses @shared-generation))) - -(defn var - [] - (gen/rand-nth (:vars @shared-generation))) - -(defn record - [] - (gen/rand-nth (:records @shared-generation))) - -(def keyword-pool - (delay - (binding [gen/*rnd* (System.Random. 42)] ;;; java.util.Random. - (into [] (repeatedly 1000 gen/keyword))))) - -(defn keyword-from-pool - [] - (gen/rand-nth @keyword-pool)) - -(def symbol-pool - (delay - (binding [gen/*rnd* (System.Random. 42)] ;;; java.util.Random. - (into [] (repeatedly 1000 gen/symbol))))) - -(defn symbol-from-pool - [] - (gen/rand-nth @keyword-pool)) - -(def ednable-scalars - [(constantly nil) - gen/byte - gen/long - gen/boolean - gen/printable-ascii-char - gen/string - symbol-from-pool - keyword-from-pool - gen/uuid - gen/date - gen/ratio - gen/bigint - gen/bigdec]) - -(defn- call-through - "Recursively call x until it doesn't return a function." - [x] - (if (fn? x) - (recur (x)) - x)) - -(defn ednable-scalar - [] - (call-through (rand-nth ednable-scalars))) - -(def ednable-collections - [[gen/vec [ednable-scalars]] - [gen/set [ednable-scalars]] - [gen/hash-map [ednable-scalars ednable-scalars]]]) - -(defn ednable-collection - [] - (let [[coll args] (rand-nth ednable-collections)] - (apply coll (map rand-nth args)))) - -(defn ednable - [] - (gen/one-of ednable-scalar ednable-collection)) - -(defn non-ednable - "Generate something that can be printed with *print-dup*, but - cannot be read back via edn/read." - [] - (gen/one-of namespace var)) - -(defn dup-readable - "Generate something that requires print-dup to be printed in - a roundtrippable way." - [] +(ns clojure.test-clojure.generators + (:require [clojure.data.generators :as gen]) + (:refer-clojure :exclude [namespace])) + +(defn var-value-source + "Generates a scalar suitable for an initial var value." + [] + (let [v (gen/scalar)] + (if (symbol? v) + `(quote ~v) + v))) + +(defn var-source + [n] + `(def ~(symbol (str "var" n)) + ~(var-value-source))) + +(defn record-source + [n] + (let [rname (str "ExampleRecord" "-" n) + fldct (gen/geometric 0.1)] + `(defrecord ~(symbol rname) ~(vec (map #(symbol (str "f" %)) (range fldct)))))) + +(defn generate-namespaces + "Returns a map with :nses, :vars, :records" + [{:keys [nses vars-per-ns records-per-ns]}] + (let [nses (mapv #(create-ns (symbol (str "clojure.generated.ns" %))) + (range nses)) + _ (doseq [ns nses] (binding [*ns* ns] (refer 'clojure.core))) + make-in-ns (fn [ns src] (binding [*ns* ns] (eval src))) + vars (->> (mapcat + (fn [ns] + (map + #(make-in-ns ns (var-source %)) + (range vars-per-ns))) + nses) + (into [])) + records (->> (mapcat + (fn [ns] + (map + #(make-in-ns ns (record-source %)) + (range records-per-ns))) + nses) + (into []))] + {:nses nses + :vars vars + :records records})) + +(def shared-generation + (delay (generate-namespaces {:nses 5 :vars-per-ns 5 :records-per-ns 5}))) + +(defn namespace + [] + (gen/rand-nth (:nses @shared-generation))) + +(defn var + [] + (gen/rand-nth (:vars @shared-generation))) + +(defn record + [] + (gen/rand-nth (:records @shared-generation))) + +(def keyword-pool + (delay + (binding [gen/*rnd* (System.Random. 42)] ;;; java.util.Random. + (into [] (repeatedly 1000 gen/keyword))))) + +(defn keyword-from-pool + [] + (gen/rand-nth @keyword-pool)) + +(def symbol-pool + (delay + (binding [gen/*rnd* (System.Random. 42)] ;;; java.util.Random. + (into [] (repeatedly 1000 gen/symbol))))) + +(defn symbol-from-pool + [] + (gen/rand-nth @keyword-pool)) + +(def ednable-scalars + [(constantly nil) + gen/byte + gen/long + gen/boolean + gen/printable-ascii-char + gen/string + symbol-from-pool + keyword-from-pool + gen/uuid + gen/date + gen/ratio + gen/bigint + gen/bigdec]) + +(defn- call-through + "Recursively call x until it doesn't return a function." + [x] + (if (fn? x) + (recur (x)) + x)) + +(defn ednable-scalar + [] + (call-through (rand-nth ednable-scalars))) + +(def ednable-collections + [[gen/vec [ednable-scalars]] + [gen/set [ednable-scalars]] + [gen/hash-map [ednable-scalars ednable-scalars]]]) + +(defn ednable-collection + [] + (let [[coll args] (rand-nth ednable-collections)] + (apply coll (map rand-nth args)))) + +(defn ednable + [] + (gen/one-of ednable-scalar ednable-collection)) + +(defn non-ednable + "Generate something that can be printed with *print-dup*, but + cannot be read back via edn/read." + [] + (gen/one-of namespace var)) + +(defn dup-readable + "Generate something that requires print-dup to be printed in + a roundtrippable way." + [] (gen/one-of namespace var)) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/java_interop.clj b/Clojure/Clojure.Tests/clojure/test_clojure/java_interop.clj index 36ee5f3bc..9ed1f255c 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/java_interop.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/java_interop.clj @@ -10,13 +10,13 @@ (assembly-load-with-partial-name "System.Drawing") ;;; DM: Added (ns clojure.test-clojure.java-interop - (:use clojure.test) - (:require [clojure.data :as data] - ;;; [clojure.inspector] - [clojure.pprint :as pp] - [clojure.set :as set] + (:use clojure.test) + (:require [clojure.data :as data] + ;;; [clojure.inspector] + [clojure.pprint :as pp] + [clojure.set :as set] [clojure.test-clojure.proxy.examples :as proxy-examples]) - (:import ;;; java.util.Base64 + (:import ;;; java.util.Base64 (clojure.lang AtomicLong AtomicInteger))) ;;; java.util.concurrent.atomic ; http://clojure.org/java_interop @@ -62,15 +62,15 @@ Int32/MaxValue ;;; Integer/MAX_VALUE (. Int32 MaxValue) )) ;;; Integer MAX_VALUE -;;;(definterface I (a [])) -;;;(deftype T [a] I (a [_] "method")) - -;;;(deftest test-reflective-field-name-ambiguous -;;; (let [t (->T "field")] -;;; (is (= "method" (. ^T t a))) -;;; (is (= "field" (. ^T t -a))) -;;; (is (= "method" (. t a))) -;;; (is (= "field" (. t -a))) +;;;(definterface I (a [])) +;;;(deftype T [a] I (a [_] "method")) + +;;;(deftest test-reflective-field-name-ambiguous +;;; (let [t (->T "field")] +;;; (is (= "method" (. ^T t a))) +;;; (is (= "field" (. ^T t -a))) +;;; (is (= "method" (. t a))) +;;; (is (= "field" (. t -a))) ;;; (is (thrown? MissingMethodException (. t -BOGUS))))) ;;; IllegalArgumentException (deftest test-double-dot @@ -121,17 +121,17 @@ Char false ;;; java.lang.Character String false ) ;;; java.lang.String - ; test compiler macro - (is (let [Int64 String] (instance? Int64 "abc"))) ;;; Long Long + ; test compiler macro + (is (let [Int64 String] (instance? Int64 "abc"))) ;;; Long Long (is (thrown? clojure.lang.ArityException (instance? Int64)))) ;;; Long ; set! -(defprotocol p (f [_])) -(deftype t [^:unsynchronized-mutable x] p (f [_] (set! (.x _) 1))) - -(deftest test-set! - (is (= 1 (f (t. 1))))) +(defprotocol p (f [_])) +(deftype t [^:unsynchronized-mutable x] p (f [_] (set! (.x _) 1))) + +(deftest test-set! + (is (= 1 (f (t. 1))))) ; memfn @@ -156,10 +156,10 @@ ;;; (:class b) java.awt.Color ))) -;;;(deftest test-iterable-bean -;;; (let [b (bean (java.util.Date.))] -;;; (is (.iterator ^Iterable b)) -;;; (is (= (into [] b) (into [] (seq b)))) +;;;(deftest test-iterable-bean +;;; (let [b (bean (java.util.Date.))] +;;; (is (.iterator ^Iterable b)) +;;; (is (= (into [] b) (into [] (seq b)))) ;;; (is (hash b)))) @@ -180,92 +180,92 @@ str) "chain chain chain"))) -;;;;https://clojure.atlassian.net/browse/CLJ-1973 -;;;(deftest test-proxy-method-order -;;; (let [class-reader (clojure.asm.ClassReader. proxy-examples/proxy1-class-name) -;;; method-order (atom []) -;;; method-visitor (proxy [clojure.asm.ClassVisitor] [clojure.asm.Opcodes/ASM4 nil] -;;; (visitMethod [access name descriptor signature exceptions] -;;; (swap! method-order conj {:name name :descriptor descriptor}) -;;; nil)) -;;; _ (.accept class-reader method-visitor 0) -;;; expected [{:name "", :descriptor "()V"} -;;; {:name "__initClojureFnMappings", :descriptor "(Lclojure/lang/IPersistentMap;)V"} -;;; {:name "__updateClojureFnMappings", :descriptor "(Lclojure/lang/IPersistentMap;)V"} -;;; {:name "__getClojureFnMappings", :descriptor "()Lclojure/lang/IPersistentMap;"} -;;; {:name "clone", :descriptor "()Ljava/lang/Object;"} -;;; {:name "hashCode", :descriptor "()I"} -;;; {:name "toString", :descriptor "()Ljava/lang/String;"} -;;; {:name "equals", :descriptor "(Ljava/lang/Object;)Z"} -;;; {:name "a", :descriptor "(Ljava/io/File;)Z"} -;;; {:name "a", :descriptor "(Ljava/lang/Boolean;)Ljava/lang/Object;"} -;;; {:name "a", :descriptor "(Ljava/lang/Runnable;)Z"} -;;; {:name "a", :descriptor "(Ljava/lang/String;)I"} -;;; {:name "b", :descriptor "(Ljava/lang/String;)Ljava/lang/Object;"} -;;; {:name "c", :descriptor "(Ljava/lang/String;)Ljava/lang/Object;"} -;;; {:name "d", :descriptor "(Ljava/lang/String;)Ljava/lang/Object;"} -;;; {:name "a", :descriptor "(Ljava/lang/Boolean;Ljava/lang/String;)I"} -;;; {:name "a", :descriptor "(Ljava/lang/String;Ljava/io/File;)Z"} -;;; {:name "a", :descriptor "(Ljava/lang/String;Ljava/lang/Runnable;)Z"} -;;; {:name "a", :descriptor "(Ljava/lang/String;Ljava/lang/String;)I"}] -;;; actual @method-order] -;;; (is (= expected actual) +;;;;https://clojure.atlassian.net/browse/CLJ-1973 +;;;(deftest test-proxy-method-order +;;; (let [class-reader (clojure.asm.ClassReader. proxy-examples/proxy1-class-name) +;;; method-order (atom []) +;;; method-visitor (proxy [clojure.asm.ClassVisitor] [clojure.asm.Opcodes/ASM4 nil] +;;; (visitMethod [access name descriptor signature exceptions] +;;; (swap! method-order conj {:name name :descriptor descriptor}) +;;; nil)) +;;; _ (.accept class-reader method-visitor 0) +;;; expected [{:name "", :descriptor "()V"} +;;; {:name "__initClojureFnMappings", :descriptor "(Lclojure/lang/IPersistentMap;)V"} +;;; {:name "__updateClojureFnMappings", :descriptor "(Lclojure/lang/IPersistentMap;)V"} +;;; {:name "__getClojureFnMappings", :descriptor "()Lclojure/lang/IPersistentMap;"} +;;; {:name "clone", :descriptor "()Ljava/lang/Object;"} +;;; {:name "hashCode", :descriptor "()I"} +;;; {:name "toString", :descriptor "()Ljava/lang/String;"} +;;; {:name "equals", :descriptor "(Ljava/lang/Object;)Z"} +;;; {:name "a", :descriptor "(Ljava/io/File;)Z"} +;;; {:name "a", :descriptor "(Ljava/lang/Boolean;)Ljava/lang/Object;"} +;;; {:name "a", :descriptor "(Ljava/lang/Runnable;)Z"} +;;; {:name "a", :descriptor "(Ljava/lang/String;)I"} +;;; {:name "b", :descriptor "(Ljava/lang/String;)Ljava/lang/Object;"} +;;; {:name "c", :descriptor "(Ljava/lang/String;)Ljava/lang/Object;"} +;;; {:name "d", :descriptor "(Ljava/lang/String;)Ljava/lang/Object;"} +;;; {:name "a", :descriptor "(Ljava/lang/Boolean;Ljava/lang/String;)I"} +;;; {:name "a", :descriptor "(Ljava/lang/String;Ljava/io/File;)Z"} +;;; {:name "a", :descriptor "(Ljava/lang/String;Ljava/lang/Runnable;)Z"} +;;; {:name "a", :descriptor "(Ljava/lang/String;Ljava/lang/String;)I"}] +;;; actual @method-order] +;;; (is (= expected actual) ;;; (with-out-str (pp/pprint (data/diff expected actual)))))) -;; serialized-proxy can be regenerated using a modified version of -;; Clojure with the proxy serialization prohibition disabled and the -;; following code: -;; revert 271674c9b484d798484d134a5ac40a6df15d3ac3 to allow serialization -(comment - (require 'clojure.inspector) - (let [baos (java.io.ByteArrayOutputStream.)] - (with-open [baos baos] - (.writeObject (java.io.ObjectOutputStream. baos) (clojure.inspector/list-model nil))) - (prn (vector (System/getProperty "java.specification.version") - (.encodeToString (java.util.Base64/getEncoder) (.toByteArray baos)))))) - -(def serialized-proxies - {"1.8" "rO0ABXNyAEVjbG9qdXJlLmluc3BlY3Rvci5wcm94eSRqYXZheC5zd2luZy50YWJsZS5BYnN0cmFjdFRhYmxlTW9kZWwkZmYxOTI3NGFydNi2XwhNRQIAAUwADl9fY2xvanVyZUZuTWFwdAAdTGNsb2p1cmUvbGFuZy9JUGVyc2lzdGVudE1hcDt4cgAkamF2YXguc3dpbmcudGFibGUuQWJzdHJhY3RUYWJsZU1vZGVscsvrOK4B/74CAAFMAAxsaXN0ZW5lckxpc3R0ACVMamF2YXgvc3dpbmcvZXZlbnQvRXZlbnRMaXN0ZW5lckxpc3Q7eHBzcgAjamF2YXguc3dpbmcuZXZlbnQuRXZlbnRMaXN0ZW5lckxpc3SxNsZ9hOrWRAMAAHhwcHhzcgAfY2xvanVyZS5sYW5nLlBlcnNpc3RlbnRBcnJheU1hcOM3cA+YxfTfAgACTAAFX21ldGFxAH4AAVsABWFycmF5dAATW0xqYXZhL2xhbmcvT2JqZWN0O3hyABtjbG9qdXJlLmxhbmcuQVBlcnNpc3RlbnRNYXBdfC8DdCByewIAAkkABV9oYXNoSQAHX2hhc2hlcXhwAAAAAAAAAABwdXIAE1tMamF2YS5sYW5nLk9iamVjdDuQzlifEHMpbAIAAHhwAAAABnQADmdldENvbHVtbkNvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTbQ1M9FYoOj9wIAAHhyABZjbG9qdXJlLmxhbmcuQUZ1bmN0aW9uPgZwnJ5G/csCAAFMABFfX21ldGhvZEltcGxDYWNoZXQAHkxjbG9qdXJlL2xhbmcvTWV0aG9kSW1wbENhY2hlO3hwcHQAC2dldFJvd0NvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTgf1DHD2//pRAIAAUwABW5yb3dzdAASTGphdmEvbGFuZy9PYmplY3Q7eHEAfgAPcHB0AApnZXRWYWx1ZUF0c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNjBYQ6uzEwbd+gIAAkwACWdldF9sYWJlbHEAfgAUTAAJZ2V0X3ZhbHVlcQB+ABR4cQB+AA9wcHA=" - "9" "rO0ABXNyAEVjbG9qdXJlLmluc3BlY3Rvci5wcm94eSRqYXZheC5zd2luZy50YWJsZS5BYnN0cmFjdFRhYmxlTW9kZWwkZmYxOTI3NGFydNi2XwhNRQIAAUwADl9fY2xvanVyZUZuTWFwdAAdTGNsb2p1cmUvbGFuZy9JUGVyc2lzdGVudE1hcDt4cgAkamF2YXguc3dpbmcudGFibGUuQWJzdHJhY3RUYWJsZU1vZGVscsvrOK4B/74CAAFMAAxsaXN0ZW5lckxpc3R0ACVMamF2YXgvc3dpbmcvZXZlbnQvRXZlbnRMaXN0ZW5lckxpc3Q7eHBzcgAjamF2YXguc3dpbmcuZXZlbnQuRXZlbnRMaXN0ZW5lckxpc3SxNsZ9hOrWRAMAAHhwcHhzcgAfY2xvanVyZS5sYW5nLlBlcnNpc3RlbnRBcnJheU1hcOM3cA+YxfTfAgACTAAFX21ldGFxAH4AAVsABWFycmF5dAATW0xqYXZhL2xhbmcvT2JqZWN0O3hyABtjbG9qdXJlLmxhbmcuQVBlcnNpc3RlbnRNYXBdfC8DdCByewIAAkkABV9oYXNoSQAHX2hhc2hlcXhwAAAAAAAAAABwdXIAE1tMamF2YS5sYW5nLk9iamVjdDuQzlifEHMpbAIAAHhwAAAABnQADmdldENvbHVtbkNvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTbQ1M9FYoOj9wIAAHhyABZjbG9qdXJlLmxhbmcuQUZ1bmN0aW9uPgZwnJ5G/csCAAFMABFfX21ldGhvZEltcGxDYWNoZXQAHkxjbG9qdXJlL2xhbmcvTWV0aG9kSW1wbENhY2hlO3hwcHQAC2dldFJvd0NvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTgf1DHD2//pRAIAAUwABW5yb3dzdAASTGphdmEvbGFuZy9PYmplY3Q7eHEAfgAPcHB0AApnZXRWYWx1ZUF0c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNjBYQ6uzEwbd+gIAAkwACWdldF9sYWJlbHEAfgAUTAAJZ2V0X3ZhbHVlcQB+ABR4cQB+AA9wcHA=" - "10" "rO0ABXNyAEVjbG9qdXJlLmluc3BlY3Rvci5wcm94eSRqYXZheC5zd2luZy50YWJsZS5BYnN0cmFjdFRhYmxlTW9kZWwkZmYxOTI3NGFydNi2XwhNRQIAAUwADl9fY2xvanVyZUZuTWFwdAAdTGNsb2p1cmUvbGFuZy9JUGVyc2lzdGVudE1hcDt4cgAkamF2YXguc3dpbmcudGFibGUuQWJzdHJhY3RUYWJsZU1vZGVscsvrOK4B/74CAAFMAAxsaXN0ZW5lckxpc3R0ACVMamF2YXgvc3dpbmcvZXZlbnQvRXZlbnRMaXN0ZW5lckxpc3Q7eHBzcgAjamF2YXguc3dpbmcuZXZlbnQuRXZlbnRMaXN0ZW5lckxpc3SRSMwtc98O3gMAAHhwcHhzcgAfY2xvanVyZS5sYW5nLlBlcnNpc3RlbnRBcnJheU1hcOM3cA+YxfTfAgACTAAFX21ldGFxAH4AAVsABWFycmF5dAATW0xqYXZhL2xhbmcvT2JqZWN0O3hyABtjbG9qdXJlLmxhbmcuQVBlcnNpc3RlbnRNYXBdfC8DdCByewIAAkkABV9oYXNoSQAHX2hhc2hlcXhwAAAAAAAAAABwdXIAE1tMamF2YS5sYW5nLk9iamVjdDuQzlifEHMpbAIAAHhwAAAABnQADmdldENvbHVtbkNvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTbQ1M9FYoOj9wIAAHhyABZjbG9qdXJlLmxhbmcuQUZ1bmN0aW9uPgZwnJ5G/csCAAFMABFfX21ldGhvZEltcGxDYWNoZXQAHkxjbG9qdXJlL2xhbmcvTWV0aG9kSW1wbENhY2hlO3hwcHQAC2dldFJvd0NvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTgf1DHD2//pRAIAAUwABW5yb3dzdAASTGphdmEvbGFuZy9PYmplY3Q7eHEAfgAPcHB0AApnZXRWYWx1ZUF0c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNjBYQ6uzEwbd+gIAAkwACWdldF9sYWJlbHEAfgAUTAAJZ2V0X3ZhbHVlcQB+ABR4cQB+AA9wcHA=" - "11" "rO0ABXNyAEVjbG9qdXJlLmluc3BlY3Rvci5wcm94eSRqYXZheC5zd2luZy50YWJsZS5BYnN0cmFjdFRhYmxlTW9kZWwkZmYxOTI3NGFydNi2XwhNRQIAAUwADl9fY2xvanVyZUZuTWFwdAAdTGNsb2p1cmUvbGFuZy9JUGVyc2lzdGVudE1hcDt4cgAkamF2YXguc3dpbmcudGFibGUuQWJzdHJhY3RUYWJsZU1vZGVscsvrOK4B/74CAAFMAAxsaXN0ZW5lckxpc3R0ACVMamF2YXgvc3dpbmcvZXZlbnQvRXZlbnRMaXN0ZW5lckxpc3Q7eHBzcgAjamF2YXguc3dpbmcuZXZlbnQuRXZlbnRMaXN0ZW5lckxpc3SRSMwtc98O3gMAAHhwcHhzcgAfY2xvanVyZS5sYW5nLlBlcnNpc3RlbnRBcnJheU1hcOM3cA+YxfTfAgACTAAFX21ldGFxAH4AAVsABWFycmF5dAATW0xqYXZhL2xhbmcvT2JqZWN0O3hyABtjbG9qdXJlLmxhbmcuQVBlcnNpc3RlbnRNYXBdfC8DdCByewIAAkkABV9oYXNoSQAHX2hhc2hlcXhwAAAAAAAAAABwdXIAE1tMamF2YS5sYW5nLk9iamVjdDuQzlifEHMpbAIAAHhwAAAABnQADmdldENvbHVtbkNvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTbQ1M9FYoOj9wIAAHhyABZjbG9qdXJlLmxhbmcuQUZ1bmN0aW9uPgZwnJ5G/csCAAFMABFfX21ldGhvZEltcGxDYWNoZXQAHkxjbG9qdXJlL2xhbmcvTWV0aG9kSW1wbENhY2hlO3hwcHQAC2dldFJvd0NvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTgf1DHD2//pRAIAAUwABW5yb3dzdAASTGphdmEvbGFuZy9PYmplY3Q7eHEAfgAPcHB0AApnZXRWYWx1ZUF0c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNjBYQ6uzEwbd+gIAAkwACWdldF9sYWJlbHEAfgAUTAAJZ2V0X3ZhbHVlcQB+ABR4cQB+AA9wcHA=" - "12" "rO0ABXNyAEVjbG9qdXJlLmluc3BlY3Rvci5wcm94eSRqYXZheC5zd2luZy50YWJsZS5BYnN0cmFjdFRhYmxlTW9kZWwkZmYxOTI3NGFydNi2XwhNRQIAAUwADl9fY2xvanVyZUZuTWFwdAAdTGNsb2p1cmUvbGFuZy9JUGVyc2lzdGVudE1hcDt4cgAkamF2YXguc3dpbmcudGFibGUuQWJzdHJhY3RUYWJsZU1vZGVscsvrOK4B/74CAAFMAAxsaXN0ZW5lckxpc3R0ACVMamF2YXgvc3dpbmcvZXZlbnQvRXZlbnRMaXN0ZW5lckxpc3Q7eHBzcgAjamF2YXguc3dpbmcuZXZlbnQuRXZlbnRMaXN0ZW5lckxpc3SRSMwtc98O3gMAAHhwcHhzcgAfY2xvanVyZS5sYW5nLlBlcnNpc3RlbnRBcnJheU1hcOM3cA+YxfTfAgACTAAFX21ldGFxAH4AAVsABWFycmF5dAATW0xqYXZhL2xhbmcvT2JqZWN0O3hyABtjbG9qdXJlLmxhbmcuQVBlcnNpc3RlbnRNYXBdfC8DdCByewIAAkkABV9oYXNoSQAHX2hhc2hlcXhwAAAAAAAAAABwdXIAE1tMamF2YS5sYW5nLk9iamVjdDuQzlifEHMpbAIAAHhwAAAABnQADmdldENvbHVtbkNvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzk0ODSK6FCjrbDduAIAAHhyABZjbG9qdXJlLmxhbmcuQUZ1bmN0aW9uPgZwnJ5G/csCAAFMABFfX21ldGhvZEltcGxDYWNoZXQAHkxjbG9qdXJlL2xhbmcvTWV0aG9kSW1wbENhY2hlO3hwcHQAC2dldFJvd0NvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzk0ODZ7gA7CIBYdJAIAAUwABW5yb3dzdAASTGphdmEvbGFuZy9PYmplY3Q7eHEAfgAPcHB0AApnZXRWYWx1ZUF0c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzk0ODiLldew+D3/eAIAAkwACWdldF9sYWJlbHEAfgAUTAAJZ2V0X3ZhbHVlcQB+ABR4cQB+AA9wcHA=" - }) - -(defn- decode-base64 - [^String s] - (.GetString System.Text.Encoding/UTF8 (System.Convert/FromBase64String s))) ;;; (.decode (Base64/getDecoder) s) - -(deftest test-proxy-non-serializable - (testing "That proxy classes refuse serialization and deserialization" - ;; Serializable listed directly in interface list: - (is (thrown? System.Runtime.Serialization.SerializationException ;;; java.io.NotSerializableException - (let [formatter (System.Runtime.Serialization.Formatters.Binary.BinaryFormatter.)] ;;; (-> (java.io.ByteArrayOutputStream.) - (.Serialize formatter (System.IO.MemoryStream.) ;;; (java.io.ObjectOutputStream.) - (proxy [Object System.Runtime.Serialization.ISerializable] []))))) ;;; (.writeObject (proxy [Object java.io.Serializable] []))) - ;; Serializable included via inheritence: - #_(is (thrown? java.io.NotSerializableException - (-> (java.io.ByteArrayOutputStream.) - (java.io.ObjectOutputStream.) - (.writeObject (clojure.inspector/list-model nil))))) - ;; Deserialization also prohibited: - #_(let [java-version (System/getProperty "java.specification.version") ;;; DM -- Added commenting out -- I don't feel like taking the time to reproduce this right now - serialized-proxy (get serialized-proxies java-version)] - (if serialized-proxy - (is (thrown? java.io.NotSerializableException - (-> serialized-proxy - decode-base64 - java.io.ByteArrayInputStream. java.io.ObjectInputStream. - .readObject))) - (println "WARNING: Missing serialized proxy for Java" java-version "in test/clojure/test_clojure/java_interop.clj"))))) +;; serialized-proxy can be regenerated using a modified version of +;; Clojure with the proxy serialization prohibition disabled and the +;; following code: +;; revert 271674c9b484d798484d134a5ac40a6df15d3ac3 to allow serialization +(comment + (require 'clojure.inspector) + (let [baos (java.io.ByteArrayOutputStream.)] + (with-open [baos baos] + (.writeObject (java.io.ObjectOutputStream. baos) (clojure.inspector/list-model nil))) + (prn (vector (System/getProperty "java.specification.version") + (.encodeToString (java.util.Base64/getEncoder) (.toByteArray baos)))))) + +(def serialized-proxies + {"1.8" "rO0ABXNyAEVjbG9qdXJlLmluc3BlY3Rvci5wcm94eSRqYXZheC5zd2luZy50YWJsZS5BYnN0cmFjdFRhYmxlTW9kZWwkZmYxOTI3NGFydNi2XwhNRQIAAUwADl9fY2xvanVyZUZuTWFwdAAdTGNsb2p1cmUvbGFuZy9JUGVyc2lzdGVudE1hcDt4cgAkamF2YXguc3dpbmcudGFibGUuQWJzdHJhY3RUYWJsZU1vZGVscsvrOK4B/74CAAFMAAxsaXN0ZW5lckxpc3R0ACVMamF2YXgvc3dpbmcvZXZlbnQvRXZlbnRMaXN0ZW5lckxpc3Q7eHBzcgAjamF2YXguc3dpbmcuZXZlbnQuRXZlbnRMaXN0ZW5lckxpc3SxNsZ9hOrWRAMAAHhwcHhzcgAfY2xvanVyZS5sYW5nLlBlcnNpc3RlbnRBcnJheU1hcOM3cA+YxfTfAgACTAAFX21ldGFxAH4AAVsABWFycmF5dAATW0xqYXZhL2xhbmcvT2JqZWN0O3hyABtjbG9qdXJlLmxhbmcuQVBlcnNpc3RlbnRNYXBdfC8DdCByewIAAkkABV9oYXNoSQAHX2hhc2hlcXhwAAAAAAAAAABwdXIAE1tMamF2YS5sYW5nLk9iamVjdDuQzlifEHMpbAIAAHhwAAAABnQADmdldENvbHVtbkNvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTbQ1M9FYoOj9wIAAHhyABZjbG9qdXJlLmxhbmcuQUZ1bmN0aW9uPgZwnJ5G/csCAAFMABFfX21ldGhvZEltcGxDYWNoZXQAHkxjbG9qdXJlL2xhbmcvTWV0aG9kSW1wbENhY2hlO3hwcHQAC2dldFJvd0NvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTgf1DHD2//pRAIAAUwABW5yb3dzdAASTGphdmEvbGFuZy9PYmplY3Q7eHEAfgAPcHB0AApnZXRWYWx1ZUF0c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNjBYQ6uzEwbd+gIAAkwACWdldF9sYWJlbHEAfgAUTAAJZ2V0X3ZhbHVlcQB+ABR4cQB+AA9wcHA=" + "9" "rO0ABXNyAEVjbG9qdXJlLmluc3BlY3Rvci5wcm94eSRqYXZheC5zd2luZy50YWJsZS5BYnN0cmFjdFRhYmxlTW9kZWwkZmYxOTI3NGFydNi2XwhNRQIAAUwADl9fY2xvanVyZUZuTWFwdAAdTGNsb2p1cmUvbGFuZy9JUGVyc2lzdGVudE1hcDt4cgAkamF2YXguc3dpbmcudGFibGUuQWJzdHJhY3RUYWJsZU1vZGVscsvrOK4B/74CAAFMAAxsaXN0ZW5lckxpc3R0ACVMamF2YXgvc3dpbmcvZXZlbnQvRXZlbnRMaXN0ZW5lckxpc3Q7eHBzcgAjamF2YXguc3dpbmcuZXZlbnQuRXZlbnRMaXN0ZW5lckxpc3SxNsZ9hOrWRAMAAHhwcHhzcgAfY2xvanVyZS5sYW5nLlBlcnNpc3RlbnRBcnJheU1hcOM3cA+YxfTfAgACTAAFX21ldGFxAH4AAVsABWFycmF5dAATW0xqYXZhL2xhbmcvT2JqZWN0O3hyABtjbG9qdXJlLmxhbmcuQVBlcnNpc3RlbnRNYXBdfC8DdCByewIAAkkABV9oYXNoSQAHX2hhc2hlcXhwAAAAAAAAAABwdXIAE1tMamF2YS5sYW5nLk9iamVjdDuQzlifEHMpbAIAAHhwAAAABnQADmdldENvbHVtbkNvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTbQ1M9FYoOj9wIAAHhyABZjbG9qdXJlLmxhbmcuQUZ1bmN0aW9uPgZwnJ5G/csCAAFMABFfX21ldGhvZEltcGxDYWNoZXQAHkxjbG9qdXJlL2xhbmcvTWV0aG9kSW1wbENhY2hlO3hwcHQAC2dldFJvd0NvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTgf1DHD2//pRAIAAUwABW5yb3dzdAASTGphdmEvbGFuZy9PYmplY3Q7eHEAfgAPcHB0AApnZXRWYWx1ZUF0c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNjBYQ6uzEwbd+gIAAkwACWdldF9sYWJlbHEAfgAUTAAJZ2V0X3ZhbHVlcQB+ABR4cQB+AA9wcHA=" + "10" "rO0ABXNyAEVjbG9qdXJlLmluc3BlY3Rvci5wcm94eSRqYXZheC5zd2luZy50YWJsZS5BYnN0cmFjdFRhYmxlTW9kZWwkZmYxOTI3NGFydNi2XwhNRQIAAUwADl9fY2xvanVyZUZuTWFwdAAdTGNsb2p1cmUvbGFuZy9JUGVyc2lzdGVudE1hcDt4cgAkamF2YXguc3dpbmcudGFibGUuQWJzdHJhY3RUYWJsZU1vZGVscsvrOK4B/74CAAFMAAxsaXN0ZW5lckxpc3R0ACVMamF2YXgvc3dpbmcvZXZlbnQvRXZlbnRMaXN0ZW5lckxpc3Q7eHBzcgAjamF2YXguc3dpbmcuZXZlbnQuRXZlbnRMaXN0ZW5lckxpc3SRSMwtc98O3gMAAHhwcHhzcgAfY2xvanVyZS5sYW5nLlBlcnNpc3RlbnRBcnJheU1hcOM3cA+YxfTfAgACTAAFX21ldGFxAH4AAVsABWFycmF5dAATW0xqYXZhL2xhbmcvT2JqZWN0O3hyABtjbG9qdXJlLmxhbmcuQVBlcnNpc3RlbnRNYXBdfC8DdCByewIAAkkABV9oYXNoSQAHX2hhc2hlcXhwAAAAAAAAAABwdXIAE1tMamF2YS5sYW5nLk9iamVjdDuQzlifEHMpbAIAAHhwAAAABnQADmdldENvbHVtbkNvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTbQ1M9FYoOj9wIAAHhyABZjbG9qdXJlLmxhbmcuQUZ1bmN0aW9uPgZwnJ5G/csCAAFMABFfX21ldGhvZEltcGxDYWNoZXQAHkxjbG9qdXJlL2xhbmcvTWV0aG9kSW1wbENhY2hlO3hwcHQAC2dldFJvd0NvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTgf1DHD2//pRAIAAUwABW5yb3dzdAASTGphdmEvbGFuZy9PYmplY3Q7eHEAfgAPcHB0AApnZXRWYWx1ZUF0c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNjBYQ6uzEwbd+gIAAkwACWdldF9sYWJlbHEAfgAUTAAJZ2V0X3ZhbHVlcQB+ABR4cQB+AA9wcHA=" + "11" "rO0ABXNyAEVjbG9qdXJlLmluc3BlY3Rvci5wcm94eSRqYXZheC5zd2luZy50YWJsZS5BYnN0cmFjdFRhYmxlTW9kZWwkZmYxOTI3NGFydNi2XwhNRQIAAUwADl9fY2xvanVyZUZuTWFwdAAdTGNsb2p1cmUvbGFuZy9JUGVyc2lzdGVudE1hcDt4cgAkamF2YXguc3dpbmcudGFibGUuQWJzdHJhY3RUYWJsZU1vZGVscsvrOK4B/74CAAFMAAxsaXN0ZW5lckxpc3R0ACVMamF2YXgvc3dpbmcvZXZlbnQvRXZlbnRMaXN0ZW5lckxpc3Q7eHBzcgAjamF2YXguc3dpbmcuZXZlbnQuRXZlbnRMaXN0ZW5lckxpc3SRSMwtc98O3gMAAHhwcHhzcgAfY2xvanVyZS5sYW5nLlBlcnNpc3RlbnRBcnJheU1hcOM3cA+YxfTfAgACTAAFX21ldGFxAH4AAVsABWFycmF5dAATW0xqYXZhL2xhbmcvT2JqZWN0O3hyABtjbG9qdXJlLmxhbmcuQVBlcnNpc3RlbnRNYXBdfC8DdCByewIAAkkABV9oYXNoSQAHX2hhc2hlcXhwAAAAAAAAAABwdXIAE1tMamF2YS5sYW5nLk9iamVjdDuQzlifEHMpbAIAAHhwAAAABnQADmdldENvbHVtbkNvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTbQ1M9FYoOj9wIAAHhyABZjbG9qdXJlLmxhbmcuQUZ1bmN0aW9uPgZwnJ5G/csCAAFMABFfX21ldGhvZEltcGxDYWNoZXQAHkxjbG9qdXJlL2xhbmcvTWV0aG9kSW1wbENhY2hlO3hwcHQAC2dldFJvd0NvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNTgf1DHD2//pRAIAAUwABW5yb3dzdAASTGphdmEvbGFuZy9PYmplY3Q7eHEAfgAPcHB0AApnZXRWYWx1ZUF0c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzkxNjBYQ6uzEwbd+gIAAkwACWdldF9sYWJlbHEAfgAUTAAJZ2V0X3ZhbHVlcQB+ABR4cQB+AA9wcHA=" + "12" "rO0ABXNyAEVjbG9qdXJlLmluc3BlY3Rvci5wcm94eSRqYXZheC5zd2luZy50YWJsZS5BYnN0cmFjdFRhYmxlTW9kZWwkZmYxOTI3NGFydNi2XwhNRQIAAUwADl9fY2xvanVyZUZuTWFwdAAdTGNsb2p1cmUvbGFuZy9JUGVyc2lzdGVudE1hcDt4cgAkamF2YXguc3dpbmcudGFibGUuQWJzdHJhY3RUYWJsZU1vZGVscsvrOK4B/74CAAFMAAxsaXN0ZW5lckxpc3R0ACVMamF2YXgvc3dpbmcvZXZlbnQvRXZlbnRMaXN0ZW5lckxpc3Q7eHBzcgAjamF2YXguc3dpbmcuZXZlbnQuRXZlbnRMaXN0ZW5lckxpc3SRSMwtc98O3gMAAHhwcHhzcgAfY2xvanVyZS5sYW5nLlBlcnNpc3RlbnRBcnJheU1hcOM3cA+YxfTfAgACTAAFX21ldGFxAH4AAVsABWFycmF5dAATW0xqYXZhL2xhbmcvT2JqZWN0O3hyABtjbG9qdXJlLmxhbmcuQVBlcnNpc3RlbnRNYXBdfC8DdCByewIAAkkABV9oYXNoSQAHX2hhc2hlcXhwAAAAAAAAAABwdXIAE1tMamF2YS5sYW5nLk9iamVjdDuQzlifEHMpbAIAAHhwAAAABnQADmdldENvbHVtbkNvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzk0ODSK6FCjrbDduAIAAHhyABZjbG9qdXJlLmxhbmcuQUZ1bmN0aW9uPgZwnJ5G/csCAAFMABFfX21ldGhvZEltcGxDYWNoZXQAHkxjbG9qdXJlL2xhbmcvTWV0aG9kSW1wbENhY2hlO3hwcHQAC2dldFJvd0NvdW50c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzk0ODZ7gA7CIBYdJAIAAUwABW5yb3dzdAASTGphdmEvbGFuZy9PYmplY3Q7eHEAfgAPcHB0AApnZXRWYWx1ZUF0c3IAJWNsb2p1cmUuaW5zcGVjdG9yJGxpc3RfbW9kZWwkZm5fXzk0ODiLldew+D3/eAIAAkwACWdldF9sYWJlbHEAfgAUTAAJZ2V0X3ZhbHVlcQB+ABR4cQB+AA9wcHA=" + }) + +(defn- decode-base64 + [^String s] + (.GetString System.Text.Encoding/UTF8 (System.Convert/FromBase64String s))) ;;; (.decode (Base64/getDecoder) s) + +(deftest test-proxy-non-serializable + (testing "That proxy classes refuse serialization and deserialization" + ;; Serializable listed directly in interface list: + (is (thrown? System.Runtime.Serialization.SerializationException ;;; java.io.NotSerializableException + (let [formatter (System.Runtime.Serialization.Formatters.Binary.BinaryFormatter.)] ;;; (-> (java.io.ByteArrayOutputStream.) + (.Serialize formatter (System.IO.MemoryStream.) ;;; (java.io.ObjectOutputStream.) + (proxy [Object System.Runtime.Serialization.ISerializable] []))))) ;;; (.writeObject (proxy [Object java.io.Serializable] []))) + ;; Serializable included via inheritence: + #_(is (thrown? java.io.NotSerializableException + (-> (java.io.ByteArrayOutputStream.) + (java.io.ObjectOutputStream.) + (.writeObject (clojure.inspector/list-model nil))))) + ;; Deserialization also prohibited: + #_(let [java-version (System/getProperty "java.specification.version") ;;; DM -- Added commenting out -- I don't feel like taking the time to reproduce this right now + serialized-proxy (get serialized-proxies java-version)] + (if serialized-proxy + (is (thrown? java.io.NotSerializableException + (-> serialized-proxy + decode-base64 + java.io.ByteArrayInputStream. java.io.ObjectInputStream. + .readObject))) + (println "WARNING: Missing serialized proxy for Java" java-version "in test/clojure/test_clojure/java_interop.clj"))))) (deftest test-bases - (are [x] (nil? (bases x)) - System.Object ;; no super classes/interfaces ;;; java.lang.Object - System.IComparable) ;; no super interfaces ;;;java.lang.Comparable - (are [x y] (set/subset? (set y) (set x)) - (bases System.Math) [System.Object] ;;; java.lang.Math java.lang.Object - (bases System.Collections.ICollection) [System.Collections.IEnumerable] ;;; java.util.Collection java.lang.Iterable + (are [x] (nil? (bases x)) + System.Object ;; no super classes/interfaces ;;; java.lang.Object + System.IComparable) ;; no super interfaces ;;;java.lang.Comparable + (are [x y] (set/subset? (set y) (set x)) + (bases System.Math) [System.Object] ;;; java.lang.Math java.lang.Object + (bases System.Collections.ICollection) [System.Collections.IEnumerable] ;;; java.util.Collection java.lang.Iterable (bases System.Int32) [System.ValueType System.IComparable System.IFormattable])) ;;; java.lang.Integer java.lang.Number java.lang.Comparable (deftest test-supers @@ -276,27 +276,27 @@ #_#{System.IFormattable System.IConvertible System.IComparable |System.IEquatable`1[System.Int32]| |System.IComparable`1[System.Int32]| ;;; java.lang.Number java.lang.Object System.Object System.ValueType} )) ;;; java.lang.Comparable java.io.Serializable} )) -(deftest test-proxy-super - (let [d (proxy [System.Collections.ArrayList] [[1 2 3]] ;;; java.util.BitSet [] - (IndexOf [value startIndex] ;;; flip [bitIndex] - (try - (proxy-super IndexOf value startIndex) ;;; (proxy-super flip bitIndex) - (catch ArgumentOutOfRangeException e ;;; IndexOutOfBoundsException - (throw (ArgumentException. "replaced"))))))] ;;; IllegalArgumentException - ;; normal call - (is (zero? (.IndexOf d 1 0))) ;;; (nil? (.flip d 0)) - ;; exception should use proxied form and return IllegalArg - (is (thrown? ArgumentException (.IndexOf d 1 -1))) ;;; (.flip d -1) IllegalArgumentException - ;; same behavior on second call +(deftest test-proxy-super + (let [d (proxy [System.Collections.ArrayList] [[1 2 3]] ;;; java.util.BitSet [] + (IndexOf [value startIndex] ;;; flip [bitIndex] + (try + (proxy-super IndexOf value startIndex) ;;; (proxy-super flip bitIndex) + (catch ArgumentOutOfRangeException e ;;; IndexOutOfBoundsException + (throw (ArgumentException. "replaced"))))))] ;;; IllegalArgumentException + ;; normal call + (is (zero? (.IndexOf d 1 0))) ;;; (nil? (.flip d 0)) + ;; exception should use proxied form and return IllegalArg + (is (thrown? ArgumentException (.IndexOf d 1 -1))) ;;; (.flip d -1) IllegalArgumentException + ;; same behavior on second call (is (thrown? ArgumentException (.IndexOf d 1 -1))))) ;;; (.flip d -1) IllegalArgumentException ; Arrays: [alength] aget aset [make-array to-array into-array to-array-2d aclone] ; [float-array, int-array, etc] ; amap, areduce -;; http://dev.clojure.org/jira/browse/CLJ-1657 -(deftest test-proxy-abstract-super - (let [p (proxy [System.IO.Stream] [])] ;;; java.io.Writer +;; http://dev.clojure.org/jira/browse/CLJ-1657 +(deftest test-proxy-abstract-super + (let [p (proxy [System.IO.Stream] [])] ;;; java.io.Writer (is (thrown? NotImplementedException (.Write p nil 1 1))))) ;;; UnsupportedOperationException (.close p) (defmacro deftest-type-array [type-array type] @@ -407,29 +407,29 @@ (to-array []) (to-array [1 2 3]) )) - -(defn queue [& contents] - (apply conj (clojure.lang.PersistentQueue/EMPTY) contents)) - -#_(defn array-typed-equals [expected actual] - (and (= (class expected) (class actual)) - (java.util.Arrays/equals expected actual))) - -#_(defmacro test-to-passed-array-for [collection-type] - `(deftest ~(symbol (str "test-to-passed-array-for-" collection-type)) - (let [string-array# (make-array String 5) - shorter# (~collection-type "1" "2" "3") - same-length# (~collection-type "1" "2" "3" "4" "5") - longer# (~collection-type "1" "2" "3" "4" "5" "6")] - (are [expected actual] (array-typed-equals expected actual) - (into-array String ["1" "2" "3" nil nil]) (.toArray shorter# string-array#) - (into-array String ["1" "2" "3" "4" "5"]) (.toArray same-length# string-array#) - (into-array String ["1" "2" "3" "4" "5" "6"]) (.toArray longer# string-array#))))) - -;; Irrelevant for CLR -- CopyArray blows up on shorter destination, no creation of new destination -#_(test-to-passed-array-for vector) -#_(test-to-passed-array-for list) -;;(test-to-passed-array-for hash-set) + +(defn queue [& contents] + (apply conj (clojure.lang.PersistentQueue/EMPTY) contents)) + +#_(defn array-typed-equals [expected actual] + (and (= (class expected) (class actual)) + (java.util.Arrays/equals expected actual))) + +#_(defmacro test-to-passed-array-for [collection-type] + `(deftest ~(symbol (str "test-to-passed-array-for-" collection-type)) + (let [string-array# (make-array String 5) + shorter# (~collection-type "1" "2" "3") + same-length# (~collection-type "1" "2" "3" "4" "5") + longer# (~collection-type "1" "2" "3" "4" "5" "6")] + (are [expected actual] (array-typed-equals expected actual) + (into-array String ["1" "2" "3" nil nil]) (.toArray shorter# string-array#) + (into-array String ["1" "2" "3" "4" "5"]) (.toArray same-length# string-array#) + (into-array String ["1" "2" "3" "4" "5" "6"]) (.toArray longer# string-array#))))) + +;; Irrelevant for CLR -- CopyArray blows up on shorter destination, no creation of new destination +#_(test-to-passed-array-for vector) +#_(test-to-passed-array-for list) +;;(test-to-passed-array-for hash-set) #_(test-to-passed-array-for queue) (deftest test-into-array @@ -574,11 +574,11 @@ (double-array [1 2 3]) (boolean-array [true false]) (byte-array [(byte 1) (byte 2)]) - (byte-array [1 2]) + (byte-array [1 2]) (byte-array 2 [1 2]) (char-array [\a \b \c]) (short-array [(short 1) (short 2)]) - (short-array [1 2]) + (short-array [1 2]) (short-array 2 [1 2]) (make-array Int32 3) ;;;(make-array Integer/TYPE 3) (to-array [1 "a" :k]) @@ -625,18 +625,18 @@ (is (= (char \a) \a))) ;; Note: More coercions in numbers.clj - -; Test that primitive boxing elision in statement context works -; correctly (CLJ-2621) - -(defn inc-atomic-int [^AtomicInteger l] - (.incrementAndGet l) - nil) - -(defn inc-atomic-long [^AtomicLong l] - (.incrementAndGet l) - nil) - -(deftest test-boxing-prevention-when-compiling-statements - (is (= 1 (.get (doto (AtomicInteger. 0) inc-atomic-int)))) + +; Test that primitive boxing elision in statement context works +; correctly (CLJ-2621) + +(defn inc-atomic-int [^AtomicInteger l] + (.incrementAndGet l) + nil) + +(defn inc-atomic-long [^AtomicLong l] + (.incrementAndGet l) + nil) + +(deftest test-boxing-prevention-when-compiling-statements + (is (= 1 (.get (doto (AtomicInteger. 0) inc-atomic-int)))) (is (= 1 (.get (doto (AtomicLong. 0) inc-atomic-long))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/logic.clj b/Clojure/Clojure.Tests/clojure/test_clojure/logic.clj index ca83decd3..ba86abc16 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/logic.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/logic.clj @@ -203,10 +203,10 @@ ; Java objects (DateTime/Now) )) ;;; (new java.util.Date) -(deftest test-some? - (are [expected x] (= expected (some? x)) - false nil - true false - true 0 - true "abc" +(deftest test-some? + (are [expected x] (= expected (some? x)) + false nil + true false + true 0 + true "abc" true [])) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/macros.clj b/Clojure/Clojure.Tests/clojure/test_clojure/macros.clj index b9f2bff5c..be0920fe4 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/macros.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/macros.clj @@ -16,98 +16,98 @@ ; -> ; defmacro definline macroexpand-1 macroexpand - -;; -> and ->> should not be dependent on the meaning of their arguments - -(defmacro c - [arg] - (if (= 'b (first arg)) - :foo - :bar)) - -(deftest ->test - (let [a 2, b identity] - (is (= (-> a b c) - (c (b a)))))) - -(deftest ->>test - (let [a 2, b identity] - (is (= (->> a b c) - (c (b a)))))) - -(deftest ->metadata-test - (testing "a trivial form" - (is (= {:hardy :har :har :-D} - (meta (macroexpand-1 (list `-> (with-meta - 'quoted-symbol - {:hardy :har :har :-D}))))))) - (testing "a nontrivial form" - (let [a (with-meta 'a {:foo :bar}) - b (with-meta '(b c d) {:bar :baz}) - e (with-meta 'e {:baz :quux}) - expanded (macroexpand-1 (list `-> a b e))] - (is (= expanded '(e (b a c d)))) - (is (= {:baz :quux} (meta (first expanded)))) - (is (= {:bar :baz} (meta (second expanded)))) - (is (= {:foo :bar} (meta (second (second expanded)))))))) - - -(deftest ->>metadata-test - (testing "a trivial form" - (is (= {:hardy :har :har :-D} - (meta (macroexpand-1 (list `->> (with-meta - 'quoted-symbol - {:hardy :har :har :-D}))))))) - (testing "a non-trivial form" - (let [a (with-meta 'a {:foo :bar}) - b (with-meta '(b c d) {:bar :baz}) - e (with-meta 'e {:baz :quux}) - expanded (macroexpand-1 (list `->> a b e))] - (is (= expanded '(e (b c d a)))) - (is (= {:baz :quux} (meta (first expanded)))) - (is (= {:bar :baz} (meta (second expanded)))) - (is (= {:foo :bar} (meta (last (second expanded)))))))) - -(def constantly-nil (constantly nil)) - -(deftest some->test - (is (nil? (some-> nil))) - (is (= 0 (some-> 0))) - (is (= -1 (some-> 1 (- 2)))) - (is (nil? (some-> 1 constantly-nil (- 2))))) - -(deftest some->>test - (is (nil? (some->> nil))) - (is (= 0 (some->> 0))) - (is (= 1 (some->> 1 (- 2)))) - (is (nil? (some->> 1 constantly-nil (- 2))))) - -(deftest cond->test - (is (= 0 (cond-> 0))) - (is (= -1 (cond-> 0 true inc true (- 2)))) - (is (= 0 (cond-> 0 false inc))) - (is (= -1 (cond-> 1 true (- 2) false inc)))) - -(deftest cond->>test - (is (= 0 (cond->> 0))) - (is (= 1 (cond->> 0 true inc true (- 2)))) - (is (= 0 (cond->> 0 false inc))) - (is (= 1 (cond->> 1 true (- 2) false inc)))) - -(deftest as->test - (is (= 0 (as-> 0 x))) - (is (= 1 (as-> 0 x (inc x)))) - (is (= 2 (as-> [0 1] x - (map inc x) - (reverse x) - (first x))))) - -(deftest threading-loop-recur - (is (nil? (loop [] - (as-> 0 x - (when-not (zero? x) - (recur)))))) - (is (nil? (loop [x nil] (some-> x recur)))) - (is (nil? (loop [x nil] (some->> x recur)))) - (is (= 0 (loop [x 0] (cond-> x false recur)))) + +;; -> and ->> should not be dependent on the meaning of their arguments + +(defmacro c + [arg] + (if (= 'b (first arg)) + :foo + :bar)) + +(deftest ->test + (let [a 2, b identity] + (is (= (-> a b c) + (c (b a)))))) + +(deftest ->>test + (let [a 2, b identity] + (is (= (->> a b c) + (c (b a)))))) + +(deftest ->metadata-test + (testing "a trivial form" + (is (= {:hardy :har :har :-D} + (meta (macroexpand-1 (list `-> (with-meta + 'quoted-symbol + {:hardy :har :har :-D}))))))) + (testing "a nontrivial form" + (let [a (with-meta 'a {:foo :bar}) + b (with-meta '(b c d) {:bar :baz}) + e (with-meta 'e {:baz :quux}) + expanded (macroexpand-1 (list `-> a b e))] + (is (= expanded '(e (b a c d)))) + (is (= {:baz :quux} (meta (first expanded)))) + (is (= {:bar :baz} (meta (second expanded)))) + (is (= {:foo :bar} (meta (second (second expanded)))))))) + + +(deftest ->>metadata-test + (testing "a trivial form" + (is (= {:hardy :har :har :-D} + (meta (macroexpand-1 (list `->> (with-meta + 'quoted-symbol + {:hardy :har :har :-D}))))))) + (testing "a non-trivial form" + (let [a (with-meta 'a {:foo :bar}) + b (with-meta '(b c d) {:bar :baz}) + e (with-meta 'e {:baz :quux}) + expanded (macroexpand-1 (list `->> a b e))] + (is (= expanded '(e (b c d a)))) + (is (= {:baz :quux} (meta (first expanded)))) + (is (= {:bar :baz} (meta (second expanded)))) + (is (= {:foo :bar} (meta (last (second expanded)))))))) + +(def constantly-nil (constantly nil)) + +(deftest some->test + (is (nil? (some-> nil))) + (is (= 0 (some-> 0))) + (is (= -1 (some-> 1 (- 2)))) + (is (nil? (some-> 1 constantly-nil (- 2))))) + +(deftest some->>test + (is (nil? (some->> nil))) + (is (= 0 (some->> 0))) + (is (= 1 (some->> 1 (- 2)))) + (is (nil? (some->> 1 constantly-nil (- 2))))) + +(deftest cond->test + (is (= 0 (cond-> 0))) + (is (= -1 (cond-> 0 true inc true (- 2)))) + (is (= 0 (cond-> 0 false inc))) + (is (= -1 (cond-> 1 true (- 2) false inc)))) + +(deftest cond->>test + (is (= 0 (cond->> 0))) + (is (= 1 (cond->> 0 true inc true (- 2)))) + (is (= 0 (cond->> 0 false inc))) + (is (= 1 (cond->> 1 true (- 2) false inc)))) + +(deftest as->test + (is (= 0 (as-> 0 x))) + (is (= 1 (as-> 0 x (inc x)))) + (is (= 2 (as-> [0 1] x + (map inc x) + (reverse x) + (first x))))) + +(deftest threading-loop-recur + (is (nil? (loop [] + (as-> 0 x + (when-not (zero? x) + (recur)))))) + (is (nil? (loop [x nil] (some-> x recur)))) + (is (nil? (loop [x nil] (some->> x recur)))) + (is (= 0 (loop [x 0] (cond-> x false recur)))) (is (= 0 (loop [x 0] (cond->> x false recur))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/main.clj b/Clojure/Clojure.Tests/clojure/test_clojure/main.clj index f3f4c8b7e..874a17be1 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/main.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/main.clj @@ -1,79 +1,79 @@ -; 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: Stuart Halloway - - -(ns clojure.test-clojure.main - (:use clojure.test - [clojure.test-helper :only [platform-newlines]]) - (:require [clojure.main :as main])) - -(deftest eval-opt - (testing "evals and prints forms" - (is (= (platform-newlines "2\n4\n") (with-out-str (#'clojure.main/eval-opt "(+ 1 1) (+ 2 2)"))))) - - (testing "skips printing nils" - (is (= (platform-newlines ":a\n:c\n") (with-out-str (#'clojure.main/eval-opt ":a nil :c"))))) - - (testing "does not block access to *in* (#299)" - (with-in-str "(+ 1 1)" - (is (= (platform-newlines "(+ 1 1)\n") (with-out-str (#'clojure.main/eval-opt "(read)"))))))) - -(defmacro with-err-str - "Evaluates exprs in a context in which *err* is bound to a fresh - StringWriter. Returns the string created by any nested printing - calls." - [& body] - `(let [s# (new System.IO.StringWriter) ;;; (new java.io.StringWriter) - p# s#] ;;; (new java.io.PrintWriter s#)] - (binding [*err* p#] - ~@body - (str s#)))) - -(defn run-repl-and-return-err - "Run repl, swallowing stdout and returing stderr." - [in-str] - (with-err-str - (with-out-str - (with-in-str in-str - (main/repl))))) - -;argh - test fragility, please fix -#_(deftest repl-exception-safety - (testing "catches and prints exception on bad equals" - (is (re-find #"^System.MissingMethodException" ;;; (is (= "java.lang.NullPointerException\n" - (run-repl-and-return-err - "(proxy [Object] [] (Equals [o] (.ToString nil)))"))))) ;;; equals .toString - -(deftest null-stack-error-reporting - (let [e (ArgumentException. "xyz") ;;; -- Unthrown exception already has null stacktrace (doto (Error. "xyz") - ;;; (.setStackTrace (into-array java.lang.StackTraceElement nil))) - tr-data (-> e Throwable->map main/ex-triage)] - (is (= tr-data #:clojure.error{:phase :execution, :class 'System.ArgumentException, :cause "xyz"})) ;;; 'java.lang.Error - (is (= (main/ex-str tr-data) "Execution error (ArgumentException) at (REPL:1).\nxyz\n")))) ;;; (Error) Took out call to platform-newlines. Turns out main/ex-str does not create \n\r - -(defn s->lpr - [s] - (-> s (System.IO.StringReader.) (clojure.lang.LineNumberingTextReader.))) ;;; java.io.StringReader. LineNumberingPushbackReader. - -(deftest renumbering-read - (are [s line-in line-out] - (= line-out (-> (main/renumbering-read nil (s->lpr s) line-in) meta :line)) - "(let [x 1] x)" 100 100 - "^{:line 20 :clojure.core/eval-file \"a/b.clj\"} (let [x 1] x)" 100 20 - "^{:line 20} (let [x 1] x)" 100 20)) - -(deftest java-loc->source - (are [c m out] - (= out (#'main/java-loc->source c m)) - 'user$eval1 'invokeStatic 'user/eval1 - 'div$go 'invokeStatic 'div/go - 'user$eval186$fn__187 'invoke 'user/eval186$fn - 'user$ok_fn$broken_fn__164 'invoke 'user/ok-fn$broken-fn +; 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: Stuart Halloway + + +(ns clojure.test-clojure.main + (:use clojure.test + [clojure.test-helper :only [platform-newlines]]) + (:require [clojure.main :as main])) + +(deftest eval-opt + (testing "evals and prints forms" + (is (= (platform-newlines "2\n4\n") (with-out-str (#'clojure.main/eval-opt "(+ 1 1) (+ 2 2)"))))) + + (testing "skips printing nils" + (is (= (platform-newlines ":a\n:c\n") (with-out-str (#'clojure.main/eval-opt ":a nil :c"))))) + + (testing "does not block access to *in* (#299)" + (with-in-str "(+ 1 1)" + (is (= (platform-newlines "(+ 1 1)\n") (with-out-str (#'clojure.main/eval-opt "(read)"))))))) + +(defmacro with-err-str + "Evaluates exprs in a context in which *err* is bound to a fresh + StringWriter. Returns the string created by any nested printing + calls." + [& body] + `(let [s# (new System.IO.StringWriter) ;;; (new java.io.StringWriter) + p# s#] ;;; (new java.io.PrintWriter s#)] + (binding [*err* p#] + ~@body + (str s#)))) + +(defn run-repl-and-return-err + "Run repl, swallowing stdout and returing stderr." + [in-str] + (with-err-str + (with-out-str + (with-in-str in-str + (main/repl))))) + +;argh - test fragility, please fix +#_(deftest repl-exception-safety + (testing "catches and prints exception on bad equals" + (is (re-find #"^System.MissingMethodException" ;;; (is (= "java.lang.NullPointerException\n" + (run-repl-and-return-err + "(proxy [Object] [] (Equals [o] (.ToString nil)))"))))) ;;; equals .toString + +(deftest null-stack-error-reporting + (let [e (ArgumentException. "xyz") ;;; -- Unthrown exception already has null stacktrace (doto (Error. "xyz") + ;;; (.setStackTrace (into-array java.lang.StackTraceElement nil))) + tr-data (-> e Throwable->map main/ex-triage)] + (is (= tr-data #:clojure.error{:phase :execution, :class 'System.ArgumentException, :cause "xyz"})) ;;; 'java.lang.Error + (is (= (main/ex-str tr-data) "Execution error (ArgumentException) at (REPL:1).\nxyz\n")))) ;;; (Error) Took out call to platform-newlines. Turns out main/ex-str does not create \n\r + +(defn s->lpr + [s] + (-> s (System.IO.StringReader.) (clojure.lang.LineNumberingTextReader.))) ;;; java.io.StringReader. LineNumberingPushbackReader. + +(deftest renumbering-read + (are [s line-in line-out] + (= line-out (-> (main/renumbering-read nil (s->lpr s) line-in) meta :line)) + "(let [x 1] x)" 100 100 + "^{:line 20 :clojure.core/eval-file \"a/b.clj\"} (let [x 1] x)" 100 20 + "^{:line 20} (let [x 1] x)" 100 20)) + +(deftest java-loc->source + (are [c m out] + (= out (#'main/java-loc->source c m)) + 'user$eval1 'invokeStatic 'user/eval1 + 'div$go 'invokeStatic 'div/go + 'user$eval186$fn__187 'invoke 'user/eval186$fn + 'user$ok_fn$broken_fn__164 'invoke 'user/ok-fn$broken-fn 'clojure.lang.Numbers 'divide 'clojure.lang.Numbers/divide)) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/metadata.clj b/Clojure/Clojure.Tests/clojure/test_clojure/metadata.clj index fac5f8fbf..f761ca73d 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/metadata.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/metadata.clj @@ -51,12 +51,12 @@ (def ^{:a 1} foo 0) #'foo)] (is (= 1 (-> v meta :a))))) - (testing "const vars preserve metadata" - (let [[v1 v2] (eval-in-temp-ns - (def ^:const foo ^:foo []) - (def ^:const bar ^:foo [:bar]) - [(meta foo) (meta bar)])] - (is (= {:foo true} v1)) + (testing "const vars preserve metadata" + (let [[v1 v2] (eval-in-temp-ns + (def ^:const foo ^:foo []) + (def ^:const bar ^:foo [:bar]) + [(meta foo) (meta bar)])] + (is (= {:foo true} v1)) (is (= {:foo true} v2)))) #_(testing "subsequent declare doesn't overwrite metadata" (let [v (eval-in-temp-ns @@ -217,23 +217,23 @@ ;; no metadata. This seems reasonable. )) -(deftest defn-primitive-args - (testing "Hinting the arg vector of a primitive-taking fn with a non-primitive type should not result in AbstractMethodError when invoked." - (testing "CLJ-850 is fixed when this case passes." - (is (= "foo" - (eval-in-temp-ns - (defn f ^String [^String s ^long i] s) - (f "foo" 1))))) - (testing "These cases should pass, even without a fix for CLJ-850." - (is (= "foo" - (eval-in-temp-ns - (defn f ^String [^String s] s) - (f "foo")))) - (is (= 1 - (eval-in-temp-ns - (defn f ^long [^String s ^long i] i) - (f "foo" 1)))) - (is (= 1 - (eval-in-temp-ns - (defn f ^long [^long i] i) +(deftest defn-primitive-args + (testing "Hinting the arg vector of a primitive-taking fn with a non-primitive type should not result in AbstractMethodError when invoked." + (testing "CLJ-850 is fixed when this case passes." + (is (= "foo" + (eval-in-temp-ns + (defn f ^String [^String s ^long i] s) + (f "foo" 1))))) + (testing "These cases should pass, even without a fix for CLJ-850." + (is (= "foo" + (eval-in-temp-ns + (defn f ^String [^String s] s) + (f "foo")))) + (is (= 1 + (eval-in-temp-ns + (defn f ^long [^String s ^long i] i) + (f "foo" 1)))) + (is (= 1 + (eval-in-temp-ns + (defn f ^long [^long i] i) (f 1))))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/multimethods.clj b/Clojure/Clojure.Tests/clojure/test_clojure/multimethods.clj index 7bf37ea8f..05bee35a4 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/multimethods.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/multimethods.clj @@ -203,69 +203,69 @@ (testing "The prefers method now returns the correct table" (is (= {[::rect ::shape] #{[::shape ::rect]}} (prefers bar))))) -(deftest indirect-preferences-mulitmethod-test - (testing "Using global hierarchy" - (derive ::parent-1 ::grandparent-1) - (derive ::parent-2 ::grandparent-2) - (derive ::child ::parent-1) - (derive ::child ::parent-2) - (testing "x should be preferred over y if x is preferred over an ancestor of y" - (defmulti indirect-1 keyword) - (prefer-method indirect-1 ::parent-1 ::grandparent-2) - (defmethod indirect-1 ::parent-1 [_] ::parent-1) - (defmethod indirect-1 ::parent-2 [_] ::parent-2) - (is (= ::parent-1 (indirect-1 ::child)))) - (testing "x should be preferred over y if an ancestor of x is preferred over y" - (defmulti indirect-2 keyword) - (prefer-method indirect-2 ::grandparent-1 ::parent-2) - (defmethod indirect-2 ::parent-1 [_] ::parent-1) - (defmethod indirect-2 ::parent-2 [_] ::parent-2) - (is (= ::parent-1 (indirect-2 ::child))))) - (testing "Using custom hierarchy" - (def local-h (-> (make-hierarchy) - (derive :parent-1 :grandparent-1) - (derive :parent-2 :grandparent-2) - (derive :child :parent-1) - (derive :child :parent-2))) - (testing "x should be preferred over y if x is preferred over an ancestor of y" - (defmulti indirect-3 keyword :hierarchy #'local-h) - (prefer-method indirect-3 :parent-1 :grandparent-2) - (defmethod indirect-3 :parent-1 [_] :parent-1) - (defmethod indirect-3 :parent-2 [_] :parent-2) - (is (= :parent-1 (indirect-3 :child)))) - (testing "x should be preferred over y if an ancestor of x is preferred over y" - (defmulti indirect-4 keyword :hierarchy #'local-h) - (prefer-method indirect-4 :grandparent-1 :parent-2) - (defmethod indirect-4 :parent-1 [_] :parent-1) - (defmethod indirect-4 :parent-2 [_] :parent-2) - (is (= :parent-1 (indirect-4 :child)))))) +(deftest indirect-preferences-mulitmethod-test + (testing "Using global hierarchy" + (derive ::parent-1 ::grandparent-1) + (derive ::parent-2 ::grandparent-2) + (derive ::child ::parent-1) + (derive ::child ::parent-2) + (testing "x should be preferred over y if x is preferred over an ancestor of y" + (defmulti indirect-1 keyword) + (prefer-method indirect-1 ::parent-1 ::grandparent-2) + (defmethod indirect-1 ::parent-1 [_] ::parent-1) + (defmethod indirect-1 ::parent-2 [_] ::parent-2) + (is (= ::parent-1 (indirect-1 ::child)))) + (testing "x should be preferred over y if an ancestor of x is preferred over y" + (defmulti indirect-2 keyword) + (prefer-method indirect-2 ::grandparent-1 ::parent-2) + (defmethod indirect-2 ::parent-1 [_] ::parent-1) + (defmethod indirect-2 ::parent-2 [_] ::parent-2) + (is (= ::parent-1 (indirect-2 ::child))))) + (testing "Using custom hierarchy" + (def local-h (-> (make-hierarchy) + (derive :parent-1 :grandparent-1) + (derive :parent-2 :grandparent-2) + (derive :child :parent-1) + (derive :child :parent-2))) + (testing "x should be preferred over y if x is preferred over an ancestor of y" + (defmulti indirect-3 keyword :hierarchy #'local-h) + (prefer-method indirect-3 :parent-1 :grandparent-2) + (defmethod indirect-3 :parent-1 [_] :parent-1) + (defmethod indirect-3 :parent-2 [_] :parent-2) + (is (= :parent-1 (indirect-3 :child)))) + (testing "x should be preferred over y if an ancestor of x is preferred over y" + (defmulti indirect-4 keyword :hierarchy #'local-h) + (prefer-method indirect-4 :grandparent-1 :parent-2) + (defmethod indirect-4 :parent-1 [_] :parent-1) + (defmethod indirect-4 :parent-2 [_] :parent-2) + (is (= :parent-1 (indirect-4 :child)))))) (deftest remove-all-methods-test (testing "Core function remove-all-methods works" - (defmulti simple1 identity) - (defmethod simple1 :a [x] :a) - (defmethod simple1 :b [x] :b) + (defmulti simple1 identity) + (defmethod simple1 :a [x] :a) + (defmethod simple1 :b [x] :b) (is (= {} (methods (remove-all-methods simple1)))))) (deftest methods-test (testing "Core function methods works" - (defmulti simple2 identity) - (defmethod simple2 :a [x] :a) - (defmethod simple2 :b [x] :b) - (is (= #{:a :b} (into #{} (keys (methods simple2))))) - (is (= :a ((:a (methods simple2)) 1))) - (defmethod simple2 :c [x] :c) - (is (= #{:a :b :c} (into #{} (keys (methods simple2))))) - (remove-method simple2 :a) + (defmulti simple2 identity) + (defmethod simple2 :a [x] :a) + (defmethod simple2 :b [x] :b) + (is (= #{:a :b} (into #{} (keys (methods simple2))))) + (is (= :a ((:a (methods simple2)) 1))) + (defmethod simple2 :c [x] :c) + (is (= #{:a :b :c} (into #{} (keys (methods simple2))))) + (remove-method simple2 :a) (is (= #{:b :c} (into #{} (keys (methods simple2))))))) (deftest get-method-test (testing "Core function get-method works" - (defmulti simple3 identity) - (defmethod simple3 :a [x] :a) - (defmethod simple3 :b [x] :b) - (is (fn? (get-method simple3 :a))) - (is (= :a ((get-method simple3 :a) 1))) - (is (fn? (get-method simple3 :b))) - (is (= :b ((get-method simple3 :b) 1))) + (defmulti simple3 identity) + (defmethod simple3 :a [x] :a) + (defmethod simple3 :b [x] :b) + (is (fn? (get-method simple3 :a))) + (is (= :a ((get-method simple3 :a) 1))) + (is (fn? (get-method simple3 :b))) + (is (= :b ((get-method simple3 :b) 1))) (is (nil? (get-method simple3 :c))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/ns_libs.clj b/Clojure/Clojure.Tests/clojure/test_clojure/ns_libs.clj index c3f9d2668..316c2f924 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/ns_libs.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/ns_libs.clj @@ -96,50 +96,50 @@ (is (thrown-with-msg? InvalidOperationException #"hidden-var is not public" ;;; IllegalAccessError (refer temp-ns :only '(hidden-var))))))) -(deftest test-defrecord-deftype-err-msg - (is (thrown-with-cause-msg? clojure.lang.Compiler+CompilerException ;;; Compiler$CompilerException - #"defrecord and deftype fields must be symbols, [\w|\p{P}]*\.MyRecord had: :shutdown-fn" ;;; user\.MyRecord - (eval '(defrecord MyRecord [:shutdown-fn])))) - (is (thrown-with-cause-msg? clojure.lang.Compiler+CompilerException ;;; Compiler$CompilerException - #"defrecord and deftype fields must be symbols, [\w|\p{P}]*\.MyType had: :key1" ;;; user\.MyRecord - (eval '(deftype MyType [:key1]))))) - -(deftest require-as-alias - ;; :as-alias does not load - (require '[not.a.real.ns [foo :as-alias foo] - [bar :as-alias bar]]) - (let [aliases (ns-aliases *ns*) - foo-ns (get aliases 'foo) - bar-ns (get aliases 'bar)] - (is (= 'not.a.real.ns.foo (ns-name foo-ns))) - (is (= 'not.a.real.ns.bar (ns-name bar-ns)))) - - (is (= :not.a.real.ns.foo/baz (read-string "::foo/baz"))) - - ;; can use :as-alias in use, but load will occur - (use '[clojure.walk :as-alias e1]) - (is (= 'clojure.walk (ns-name (get (ns-aliases *ns*) 'e1)))) - (is (= :clojure.walk/walk (read-string "::e1/walk"))) - - ;; can use both :as and :as-alias - (require '[clojure.set :as n1 :as-alias n2]) - (let [aliases (ns-aliases *ns*)] - (is (= 'clojure.set (ns-name (get aliases 'n1)))) - (is (= 'clojure.set (ns-name (get aliases 'n2)))) - (is (= (resolve 'n1/union) #'clojure.set/union)) - (is (= (resolve 'n2/union) #'clojure.set/union)))) - -(deftest require-as-alias-then-load-later - ;; alias but don't load - (require '[clojure.test-clojure.ns-libs-load-later :as-alias alias-now]) - (is (contains? (ns-aliases *ns*) 'alias-now)) - (is (not (nil? (find-ns 'clojure.test-clojure.ns-libs-load-later)))) - - ;; not loaded! - (is (nil? (resolve 'alias-now/example))) - - ;; load - (require 'clojure.test-clojure.ns-libs-load-later) - - ;; now loaded! +(deftest test-defrecord-deftype-err-msg + (is (thrown-with-cause-msg? clojure.lang.Compiler+CompilerException ;;; Compiler$CompilerException + #"defrecord and deftype fields must be symbols, [\w|\p{P}]*\.MyRecord had: :shutdown-fn" ;;; user\.MyRecord + (eval '(defrecord MyRecord [:shutdown-fn])))) + (is (thrown-with-cause-msg? clojure.lang.Compiler+CompilerException ;;; Compiler$CompilerException + #"defrecord and deftype fields must be symbols, [\w|\p{P}]*\.MyType had: :key1" ;;; user\.MyRecord + (eval '(deftype MyType [:key1]))))) + +(deftest require-as-alias + ;; :as-alias does not load + (require '[not.a.real.ns [foo :as-alias foo] + [bar :as-alias bar]]) + (let [aliases (ns-aliases *ns*) + foo-ns (get aliases 'foo) + bar-ns (get aliases 'bar)] + (is (= 'not.a.real.ns.foo (ns-name foo-ns))) + (is (= 'not.a.real.ns.bar (ns-name bar-ns)))) + + (is (= :not.a.real.ns.foo/baz (read-string "::foo/baz"))) + + ;; can use :as-alias in use, but load will occur + (use '[clojure.walk :as-alias e1]) + (is (= 'clojure.walk (ns-name (get (ns-aliases *ns*) 'e1)))) + (is (= :clojure.walk/walk (read-string "::e1/walk"))) + + ;; can use both :as and :as-alias + (require '[clojure.set :as n1 :as-alias n2]) + (let [aliases (ns-aliases *ns*)] + (is (= 'clojure.set (ns-name (get aliases 'n1)))) + (is (= 'clojure.set (ns-name (get aliases 'n2)))) + (is (= (resolve 'n1/union) #'clojure.set/union)) + (is (= (resolve 'n2/union) #'clojure.set/union)))) + +(deftest require-as-alias-then-load-later + ;; alias but don't load + (require '[clojure.test-clojure.ns-libs-load-later :as-alias alias-now]) + (is (contains? (ns-aliases *ns*) 'alias-now)) + (is (not (nil? (find-ns 'clojure.test-clojure.ns-libs-load-later)))) + + ;; not loaded! + (is (nil? (resolve 'alias-now/example))) + + ;; load + (require 'clojure.test-clojure.ns-libs-load-later) + + ;; now loaded! (is (not (nil? (resolve 'alias-now/example))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/numbers.clj b/Clojure/Clojure.Tests/clojure/test_clojure/numbers.clj index 0b0e0e581..673a2abd0 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/numbers.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/numbers.clj @@ -15,7 +15,7 @@ (:use clojure.test [clojure.test.generative :exclude (is)] clojure.template) - (:require [clojure.data.generators :as gen] + (:require [clojure.data.generators :as gen] [clojure.test-helper :as helper])) @@ -36,68 +36,68 @@ (not (float? v))))) (deftest BigInteger-conversions - (doseq [coerce-fn [bigint biginteger]] - (doseq [v (map coerce-fn [ Int32/MaxValue ;;; Long/MAX_VALUE - 13178456923875639284562345789M - 13178456923875639284562345789N - Single/MaxValue ;;; Float/MAX_VALUE - (- Single/MaxValue) ;;; (- Float/MAX_VALUE) - Double/MaxValue ;;; Double/MAX_VALUE - (- Double/MaxValue) ;;; (- Double/MAX_VALUE) - (* 2 (bigdec Double/MaxValue)) ])] ;;; Double/MAX_VALUE - (are [x] (true? x) - (integer? v) - (number? v) - (not (decimal? v)) + (doseq [coerce-fn [bigint biginteger]] + (doseq [v (map coerce-fn [ Int32/MaxValue ;;; Long/MAX_VALUE + 13178456923875639284562345789M + 13178456923875639284562345789N + Single/MaxValue ;;; Float/MAX_VALUE + (- Single/MaxValue) ;;; (- Float/MAX_VALUE) + Double/MaxValue ;;; Double/MAX_VALUE + (- Double/MaxValue) ;;; (- Double/MAX_VALUE) + (* 2 (bigdec Double/MaxValue)) ])] ;;; Double/MAX_VALUE + (are [x] (true? x) + (integer? v) + (number? v) + (not (decimal? v)) (not (float? v)))))) -(defn all-pairs-equal [equal-var vals] - (doseq [val1 vals] - (doseq [val2 vals] - (is (equal-var val1 val2) - (str "Test that " val1 " (" (class val1) ") " - equal-var " " val2 " (" (class val2) ")"))))) - -(defn all-pairs-hash-consistent-with-= [vals] - (doseq [val1 vals] - (doseq [val2 vals] - (when (= val1 val2) - (is (= (hash val1) (hash val2)) - (str "Test that (hash " val1 ") (" (class val1) ") " - " = (hash " val2 ") (" (class val2) ")")))))) - -(deftest equality-tests - ;; = only returns true for numbers that are in the same category, - ;; where category is one of INTEGER, FLOATING, DECIMAL, RATIO. - (all-pairs-equal #'= [(byte 2) (short 2) (int 2) (long 2) - (bigint 2) (biginteger 2)]) - (all-pairs-equal #'= [(float 2.0) (double 2.0)]) - (all-pairs-equal #'= [(float 0.0) (double 0.0) (float -0.0) (double -0.0)]) - (all-pairs-equal #'= [2.0M 2.00M]) - (all-pairs-equal #'= [(float 1.5) (double 1.5)]) - (all-pairs-equal #'= [1.50M 1.500M]) - (all-pairs-equal #'= [0.0M 0.00M]) - (all-pairs-equal #'= [(/ 1 2) (/ 2 4)]) - - ;; No BigIntegers or floats in following tests, because hash - ;; consistency with = for them is out of scope for Clojure - ;; (CLJ-1036). - (all-pairs-hash-consistent-with-= [(byte 2) (short 2) (int 2) (long 2) - (bigint 2) - (double 2.0) 2.0M 2.00M]) - (all-pairs-hash-consistent-with-= [(/ 3 2) (double 1.5) 1.50M 1.500M]) - (all-pairs-hash-consistent-with-= [(double -0.0) (double 0.0) -0.0M -0.00M 0.0M 0.00M (float -0.0) (float 0.0)]) - - ;; == tests for numerical equality, returning true even for numbers - ;; in different categories. - (all-pairs-equal #'== [(byte 0) (short 0) (int 0) (long 0) - (bigint 0) (biginteger 0) - (float -0.0) (double -0.0) -0.0M -0.00M - (float 0.0) (double 0.0) 0.0M 0.00M]) - (all-pairs-equal #'== [(byte 2) (short 2) (int 2) (long 2) - (bigint 2) (biginteger 2) - (float 2.0) (double 2.0) 2.0M 2.00M]) - (all-pairs-equal #'== [(/ 3 2) (float 1.5) (double 1.5) 1.50M 1.500M])) +(defn all-pairs-equal [equal-var vals] + (doseq [val1 vals] + (doseq [val2 vals] + (is (equal-var val1 val2) + (str "Test that " val1 " (" (class val1) ") " + equal-var " " val2 " (" (class val2) ")"))))) + +(defn all-pairs-hash-consistent-with-= [vals] + (doseq [val1 vals] + (doseq [val2 vals] + (when (= val1 val2) + (is (= (hash val1) (hash val2)) + (str "Test that (hash " val1 ") (" (class val1) ") " + " = (hash " val2 ") (" (class val2) ")")))))) + +(deftest equality-tests + ;; = only returns true for numbers that are in the same category, + ;; where category is one of INTEGER, FLOATING, DECIMAL, RATIO. + (all-pairs-equal #'= [(byte 2) (short 2) (int 2) (long 2) + (bigint 2) (biginteger 2)]) + (all-pairs-equal #'= [(float 2.0) (double 2.0)]) + (all-pairs-equal #'= [(float 0.0) (double 0.0) (float -0.0) (double -0.0)]) + (all-pairs-equal #'= [2.0M 2.00M]) + (all-pairs-equal #'= [(float 1.5) (double 1.5)]) + (all-pairs-equal #'= [1.50M 1.500M]) + (all-pairs-equal #'= [0.0M 0.00M]) + (all-pairs-equal #'= [(/ 1 2) (/ 2 4)]) + + ;; No BigIntegers or floats in following tests, because hash + ;; consistency with = for them is out of scope for Clojure + ;; (CLJ-1036). + (all-pairs-hash-consistent-with-= [(byte 2) (short 2) (int 2) (long 2) + (bigint 2) + (double 2.0) 2.0M 2.00M]) + (all-pairs-hash-consistent-with-= [(/ 3 2) (double 1.5) 1.50M 1.500M]) + (all-pairs-hash-consistent-with-= [(double -0.0) (double 0.0) -0.0M -0.00M 0.0M 0.00M (float -0.0) (float 0.0)]) + + ;; == tests for numerical equality, returning true even for numbers + ;; in different categories. + (all-pairs-equal #'== [(byte 0) (short 0) (int 0) (long 0) + (bigint 0) (biginteger 0) + (float -0.0) (double -0.0) -0.0M -0.00M + (float 0.0) (double 0.0) 0.0M 0.00M]) + (all-pairs-equal #'== [(byte 2) (short 2) (int 2) (long 2) + (bigint 2) (biginteger 2) + (float 2.0) (double 2.0) 2.0M 2.00M]) + (all-pairs-equal #'== [(/ 3 2) (float 1.5) (double 1.5) 1.50M 1.500M])) (deftest unchecked-cast-num-obj (do-template [prim-array cast] @@ -184,8 +184,8 @@ (catch ArgumentException e :error)))] ;;; IllegalArgumentException (is (= vals (map wrapped inputs))))))) -(deftest test-prim-with-matching-hint - (is (= 1.0 (let [x 1.2] (Math/Round ^double x))))) ;;; 1 round +(deftest test-prim-with-matching-hint + (is (= 1.0 (let [x 1.2] (Math/Round ^double x))))) ;;; 1 round ;; *** Functions *** @@ -266,16 +266,16 @@ (is (> (* 3 (int (/ Int32/MaxValue 2.0))) Int32/MaxValue)) ) ; no overflow ;;; Integer/MAX_VALUE -(deftest test-multiply-longs-at-edge - (are [x] (= x 9223372036854775808N) - (*' -1 Int64/MinValue) ;;; Long/MIN_VALUE - (*' Int64/MinValue -1) ;;; Long/MIN_VALUE - (* -1N Int64/MinValue) ;;; Long/MIN_VALUE - (* Int64/MinValue -1N) ;;; Long/MIN_VALUE - (* -1 (bigint Int64/MinValue)) ;;; Long/MIN_VALUE - (* (bigint Int64/MinValue) -1)) ;;; Long/MIN_VALUE - (is (thrown? ArithmeticException (* Int64/MinValue -1))) ;;; Long/MIN_VALUE - (is (thrown? ArithmeticException (* -1 Int64/MinValue)))) ;;; Long/MIN_VALUE +(deftest test-multiply-longs-at-edge + (are [x] (= x 9223372036854775808N) + (*' -1 Int64/MinValue) ;;; Long/MIN_VALUE + (*' Int64/MinValue -1) ;;; Long/MIN_VALUE + (* -1N Int64/MinValue) ;;; Long/MIN_VALUE + (* Int64/MinValue -1N) ;;; Long/MIN_VALUE + (* -1 (bigint Int64/MinValue)) ;;; Long/MIN_VALUE + (* (bigint Int64/MinValue) -1)) ;;; Long/MIN_VALUE + (is (thrown? ArithmeticException (* Int64/MinValue -1))) ;;; Long/MIN_VALUE + (is (thrown? ArithmeticException (* -1 Int64/MinValue)))) ;;; Long/MIN_VALUE (deftest test-ratios-simplify-to-ints-where-appropriate (testing "negative denominator (assembla #275)" @@ -305,13 +305,13 @@ (is (thrown? ArithmeticException (/ 2 0))) (is (thrown? ArgumentException (/))) ) ;;; IllegalArgumentException -(deftest test-divide-bigint-at-edge - (are [x] (= x (-' Int64/MinValue)) ;;; Long/MIN_VALUE - (/ Int64/MinValue -1N) ;;; Long/MIN_VALUE - (/ (bigint Int64/MinValue) -1) ;;; Long/MIN_VALUE - (/ (bigint Int64/MinValue) -1N) ;;; Long/MIN_VALUE - (quot Int64/MinValue -1N) ;;; Long/MIN_VALUE - (quot (bigint Int64/MinValue) -1) ;;; Long/MIN_VALUE +(deftest test-divide-bigint-at-edge + (are [x] (= x (-' Int64/MinValue)) ;;; Long/MIN_VALUE + (/ Int64/MinValue -1N) ;;; Long/MIN_VALUE + (/ (bigint Int64/MinValue) -1) ;;; Long/MIN_VALUE + (/ (bigint Int64/MinValue) -1N) ;;; Long/MIN_VALUE + (quot Int64/MinValue -1N) ;;; Long/MIN_VALUE + (quot (bigint Int64/MinValue) -1) ;;; Long/MIN_VALUE (quot (bigint Int64/MinValue) -1N))) ;;; Long/MIN_VALUE ;; mod @@ -550,20 +550,20 @@ Math/pow overflows to Infinity." ) (is (thrown? ArgumentException (bit-shift-right 1N 1)))) ;;; IllegalArgumentException -(deftest test-unsigned-bit-shift-right - (are [x y] (= x y) - 2r0 (unsigned-bit-shift-right 2r1 1) - 2r010 (unsigned-bit-shift-right 2r100 1) - 2r001 (unsigned-bit-shift-right 2r100 2) - 2r000 (unsigned-bit-shift-right 2r100 3) - 2r0001011 (unsigned-bit-shift-right 2r00010111 1) - 2r0001011 (apply unsigned-bit-shift-right [2r00010111 1]) - 0 (unsigned-bit-shift-right 2r10 -1) ; truncated to least 6-bits, 63 - 1 (unsigned-bit-shift-right (expt 2 32) 32) - 1 (unsigned-bit-shift-right (expt 2 16) 10000) ; truncated to least 6-bits, 16 - 9223372036854775807 (unsigned-bit-shift-right -2r10 1) - ) - (is (thrown? ArgumentException (unsigned-bit-shift-right 1N 1)))) ;;; IllegalArgumentException +(deftest test-unsigned-bit-shift-right + (are [x y] (= x y) + 2r0 (unsigned-bit-shift-right 2r1 1) + 2r010 (unsigned-bit-shift-right 2r100 1) + 2r001 (unsigned-bit-shift-right 2r100 2) + 2r000 (unsigned-bit-shift-right 2r100 3) + 2r0001011 (unsigned-bit-shift-right 2r00010111 1) + 2r0001011 (apply unsigned-bit-shift-right [2r00010111 1]) + 0 (unsigned-bit-shift-right 2r10 -1) ; truncated to least 6-bits, 63 + 1 (unsigned-bit-shift-right (expt 2 32) 32) + 1 (unsigned-bit-shift-right (expt 2 16) 10000) ; truncated to least 6-bits, 16 + 9223372036854775807 (unsigned-bit-shift-right -2r10 1) + ) + (is (thrown? ArgumentException (unsigned-bit-shift-right 1N 1)))) ;;; IllegalArgumentException (deftest test-bit-clear (is (= 2r1101 (bit-clear 2r1111 1))) @@ -598,7 +598,7 @@ Math/pow overflows to Infinity." (is (== (denominator 1/2) 2)) (is (== (numerator 1/2) 1)) (is (= (bigint (/ 100000000000000000000 3)) 33333333333333333333)) - (is (= (long 10000000000000000000/3) 3333333333333333333))) + (is (= (long 10000000000000000000/3) 3333333333333333333))) (deftest test-arbitrary-precision-subtract (are [x y] (= x y) @@ -647,19 +647,19 @@ Math/pow overflows to Infinity." (is (= Int64 (class (min 1.0 2.0 -10)))) ;;; java.lang.Long (is (= Double (class (min 1 2 -10.0 3 4 5)))))) ;;; java.lang.Double -(deftest test-abs - (are [in ex] (= ex (abs in)) - -1 1 - 1 1 - ;;; Int64/MinValue Int64/MinValue ;; special case! Long/MIN_VALUE Long/MIN_VALUE -- in CLR, taking abs of Int64/MaxValue throws - -1.0 1.0 - -0.0 0.0 - ##-Inf ##Inf - ##Inf ##Inf - -123.456M 123.456M - -123N 123N - -1/5 1/5) - (is (NaN? (abs ##NaN)))) +(deftest test-abs + (are [in ex] (= ex (abs in)) + -1 1 + 1 1 + ;;; Int64/MinValue Int64/MinValue ;; special case! Long/MIN_VALUE Long/MIN_VALUE -- in CLR, taking abs of Int64/MaxValue throws + -1.0 1.0 + -0.0 0.0 + ##-Inf ##Inf + ##Inf ##Inf + -123.456M 123.456M + -123N 123N + -1/5 1/5) + (is (NaN? (abs ##NaN)))) (deftest clj-868 (testing "min/max: NaN is contagious" @@ -676,274 +676,274 @@ Math/pow overflows to Infinity." min max)))) -(defn integer - "Distribution of integers biased towards the small, but - including all longs." - [] - (gen/one-of #(gen/uniform -1 32) gen/byte gen/short gen/int gen/long)) - -(defn longable? - [n] - (try - (long n) - true - (catch Exception _))) - -(defspec integer-commutative-laws - (partial map identity) - [^{:tag `integer} a ^{:tag `integer} b] - (if (longable? (+' a b)) - (assert (= (+ a b) (+ b a) - (+' a b) (+' b a) - (unchecked-add a b) (unchecked-add b a))) - (assert (= (+' a b) (+' b a)))) - (if (longable? (*' a b)) - (assert (= (* a b) (* b a) - (*' a b) (*' b a) - (unchecked-multiply a b) (unchecked-multiply b a))) - (assert (= (*' a b) (*' b a))))) - -(defspec integer-associative-laws - (partial map identity) - [^{:tag `integer} a ^{:tag `integer} b ^{:tag `integer} c] - (if (every? longable? [(+' a b) (+' b c) (+' a b c)]) - (assert (= (+ (+ a b) c) (+ a (+ b c)) - (+' (+' a b) c) (+' a (+' b c)) - (unchecked-add (unchecked-add a b) c) (unchecked-add a (unchecked-add b c)))) - (assert (= (+' (+' a b) c) (+' a (+' b c)) - (+ (+ (bigint a) b) c) (+ a (+ (bigint b) c))))) - (if (every? longable? [(*' a b) (*' b c) (*' a b c)]) - (assert (= (* (* a b) c) (* a (* b c)) - (*' (*' a b) c) (*' a (*' b c)) - (unchecked-multiply (unchecked-multiply a b) c) (unchecked-multiply a (unchecked-multiply b c)))) - (assert (= (*' (*' a b) c) (*' a (*' b c)) - (* (* (bigint a) b) c) (* a (* (bigint b) c)))))) - -(defspec integer-distributive-laws - (partial map identity) - [^{:tag `integer} a ^{:tag `integer} b ^{:tag `integer} c] - (if (every? longable? [(*' a (+' b c)) (+' (*' a b) (*' a c)) - (*' a b) (*' a c) (+' b c)]) - (assert (= (* a (+ b c)) (+ (* a b) (* a c)) - (*' a (+' b c)) (+' (*' a b) (*' a c)) - (unchecked-multiply a (+' b c)) (+' (unchecked-multiply a b) (unchecked-multiply a c)))) - (assert (= (*' a (+' b c)) (+' (*' a b) (*' a c)) - (* a (+ (bigint b) c)) (+ (* (bigint a) b) (* (bigint a) c)))))) - -(defspec addition-undoes-subtraction - (partial map identity) - [^{:tag `integer} a ^{:tag `integer} b] - (if (longable? (-' a b)) - (assert (= a - (-> a (- b) (+ b)) - (-> a (unchecked-subtract b) (unchecked-add b))))) - (assert (= a - (-> a (-' b) (+' b))))) - -(defspec quotient-and-remainder - (fn [a b] (sort [a b])) - [^{:tag `integer} a ^{:tag `integer} b] - (when-not (zero? (second %)) - (let [[a d] % - q (quot a d) - r (rem a d)] - (assert (= a - (+ (* q d) r) - (unchecked-add (unchecked-multiply q d) r)))))) - -(deftest unchecked-inc-overflow - (testing "max value overflows to min value" - (is (= Int64/MinValue (unchecked-inc Int64/MaxValue))) ;;; Long/MIN_VALUE Long/MAX_VALUE - (is (= Int64/MinValue (unchecked-inc ^Object Int64/MaxValue))))) ;;; Long/MIN_VALUE (Long/valueOf Long/MAX_VALUE) - -(deftest unchecked-dec-overflow - (testing "min value overflows to max value" - (is (= Int64/MaxValue (unchecked-dec Int64/MinValue))) ;;; Long/MAX_VALUE Long/MIN_VALUE - (is (= Int64/MaxValue (unchecked-dec ^Object Int64/MinValue))))) ;;; Long/MAX_VALUE (Long/valueOf Long/MIN_VALUE) - -(deftest unchecked-negate-overflow - (testing "negating min value overflows to min value itself" - (is (= Int64/MinValue (unchecked-negate Int64/MinValue))) ;;; Long/MIN_VALUE Long/MIN_VALUE - (is (= Int64/MinValue (unchecked-negate ^Object Int64/MinValue))))) ;;; Long/MIN_VALUE (Long/valueOf Long/MIN_VALUE) - -(deftest unchecked-add-overflow - (testing "max value overflows to min value" - (is (= Int64/MinValue (unchecked-add Int64/MaxValue 1))) ;;; Long/MIN_VALUE Long/MAX_VALUE - (is (= Int64/MinValue (unchecked-add Int64/MaxValue ((fn [] 1))))) ;;; Long/MIN_VALUE (Long/valueOf Long/MAX_VALUE) - (is (= Int64/MinValue (unchecked-add ^Object Int64/MaxValue 1))) ;;; Long/MIN_VALUE (Long/valueOf 1) - (is (= Int64/MinValue (unchecked-add ^Object Int64/MaxValue ((fn [] 1)))))) ;;; Long/MIN_VALUE (Long/valueOf Long/MAX_VALUE) (Long/valueOf 1) - (testing "adding min value to min value results in zero" - (is (= 0 (unchecked-add Int64/MinValue Int64/MinValue))) ;;; Long/MIN_VALUE Long/MIN_VALUE - (is (= 0 (unchecked-add Int64/MinValue ^Object Int64/MinValue))) ;;; Long/MIN_VALUE (Long/valueOf Long/MIN_VALUE) - (is (= 0 (unchecked-add ^Object Int64/MinValue Int64/MinValue))) ;;; (Long/valueOf Long/MIN_VALUE) Long/MIN_VALUE - (is (= 0 (unchecked-add ^Object Int64/MinValue ^Object Int64/MinValue))))) ;;; (Long/valueOf Long/MIN_VALUE) (Long/valueOf Long/MIN_VALUE) - -(deftest unchecked-subtract-overflow - (testing "min value overflows to max-value" ;;; etc - (is (= Int64/MaxValue (unchecked-subtract Int64/MinValue 1))) - (is (= Int64/MaxValue (unchecked-subtract Int64/MinValue ((fn [] 1))))) - (is (= Int64/MaxValue (unchecked-subtract ^Object Int64/MinValue 1))) - (is (= Int64/MaxValue (unchecked-subtract ^Object Int64/MinValue ((fn [] 1)))))) - (testing "negating min value overflows to min value itself" - (is (= Int64/MinValue (unchecked-subtract 0 Int64/MinValue))) - (is (= Int64/MinValue (unchecked-subtract 0 ^Object Int64/MinValue))) - (is (= Int64/MinValue (unchecked-subtract ((fn [] 0)) Int64/MinValue))) - (is (= Int64/MinValue (unchecked-subtract ((fn [] 0)) ^Object Int64/MinValue))))) - -(deftest unchecked-multiply-overflow - (testing "two times max value results in -2" - (is (= -2 (unchecked-multiply Int64/MaxValue 2))) - (is (= -2 (unchecked-multiply Int64/MaxValue ((fn [] 2))))) - (is (= -2 (unchecked-multiply ^Object Int64/MaxValue 2))) - (is (= -2 (unchecked-multiply ^Object Int64/MaxValue ((fn [] 2)))))) - (testing "two times min value results in 0" - (is (= 0 (unchecked-multiply Int64/MinValue 2))) - (is (= 0 (unchecked-multiply Int64/MinValue ((fn [] 2))))) - (is (= 0 (unchecked-multiply ^Object Int64/MinValue 2))) - (is (= 0 (unchecked-multiply ^Object Int64/MinValue ((fn [] 2))))))) - -(defmacro check-warn-on-box [warn? form] - `(do (binding [*unchecked-math* :warn-on-boxed] - (is (= ~warn? - (boolean - (re-find #"^Boxed math warning" - (helper/with-err-string-writer - (helper/eval-in-temp-ns ~form))))))) - (binding [*unchecked-math* true] - (is (false? - (boolean - (re-find #"^Boxed math warning" - (helper/with-err-string-writer - (helper/eval-in-temp-ns ~form))))))) - (binding [*unchecked-math* false] - (is (false? - (boolean - (re-find #"^Boxed math warning" - (helper/with-err-string-writer - (helper/eval-in-temp-ns ~form))))))))) - -(deftest warn-on-boxed - (check-warn-on-box true (#(inc %) 2)) - (check-warn-on-box false (#(inc ^long %) 2)) - (check-warn-on-box false (long-array 5)) - (check-warn-on-box true (> (first (range 3)) 0)) - (check-warn-on-box false (> ^long (first (range 3)) 0))) - - -(deftest comparisons - (let [small-numbers [1 1.0 (int 1) (float 1) 9/10 1N 1M] ;;; (Integer. 1) (Float. 1.0) - big-numbers [10 10.0 (int 10) (float 10.0) 99/10 10N 10N]] ;;; (Integer. 10) (Float. 10.0) - (doseq [small small-numbers big big-numbers] - (is (< small big)) - (is (not (< big small))) - (is (not (< small small))) - (is (< (int small) (int big))) - (is (not (< (int big) (int small)))) - (is (not (< (int small) (int small)))) - (is (< (double small) (double big))) - (is (not (< (double big) (double small)))) - (is (not (< (double small) (double small)))) - (is (<= small big)) - (is (<= small small)) - (is (not (<= big small))) - (is (<= (int small) (int big))) - (is (<= (int small) (int small))) - (is (not (<= (int big) (int small)))) - (is (<= (double small) (double big))) - (is (<= (double small) (double small))) - (is (not (<= (double big) (double small)))) - (is (> big small)) - (is (not (> small big))) - (is (not (> small small))) - (is (> (int big) (int small))) - (is (not (> (int small) (int big)))) - (is (not (> (int small) (int small)))) - (is (> (double big) (double small))) - (is (not (> (double small) (double big)))) - (is (not (> (double small) (double small)))) - (is (>= big small)) - (is (>= small small)) - (is (not (>= small big))) - (is (>= (int big) (int small))) - (is (>= (int small) (int small))) - (is (not (>= (int small) (int big)))) - (is (>= (double big) (double small))) - (is (>= (double small) (double small))) - (is (not (>= (double small) (double big))))))) - -(deftest test-nan-comparison - (are [x y] (= x y) - (< 1000 Double/NaN) (< 1000 (double Double/NaN)) ;;; (Double. Double/NaN) -- no boxed, so kinda pointless - (<= 1000 Double/NaN) (<= 1000 (double Double/NaN)) ;;; (Double. Double/NaN) - (> 1000 Double/NaN) (> 1000 (double Double/NaN)) ;;; (Double. Double/NaN) - (>= 1000 Double/NaN) (>= 1000 (double Double/NaN)))) ;;; (Double. Double/NaN) - -(deftest test-nan-as-operand - (testing "All numeric operations with NaN as an operand produce NaN as a result" - (let [nan Double/NaN - onan (cast Object Double/NaN)] - (are [x] (Double/IsNaN x) ;;; Double/isNaN - (+ nan 1) - (+ nan 0) - (+ nan 0.0) - (+ 1 nan) - (+ 0 nan) - (+ 0.0 nan) - (+ nan nan) - (- nan 1) - (- nan 0) - (- nan 0.0) - (- 1 nan) - (- 0 nan) - (- 0.0 nan) - (- nan nan) - (* nan 1) - (* nan 0) - (* nan 0.0) - (* 1 nan) - (* 0 nan) - (* 0.0 nan) - (* nan nan) - (/ nan 1) - (/ nan 0) - (/ nan 0.0) - (/ 1 nan) - (/ 0 nan) - (/ 0.0 nan) - (/ nan nan) - (+ onan 1) - (+ onan 0) - (+ onan 0.0) - (+ 1 onan) - (+ 0 onan) - (+ 0.0 onan) - (+ onan onan) - (- onan 1) - (- onan 0) - (- onan 0.0) - (- 1 onan) - (- 0 onan) - (- 0.0 onan) - (- onan onan) - (* onan 1) - (* onan 0) - (* onan 0.0) - (* 1 onan) - (* 0 onan) - (* 0.0 onan) - (* onan onan) - (/ onan 1) - (/ onan 0) - (/ onan 0.0) - (/ 1 onan) - (/ 0 onan) - (/ 0.0 onan) - (/ onan onan) - (+ nan onan) - (+ onan nan) - (- nan onan) - (- onan nan) - (* nan onan) - (* onan nan) - (/ nan onan) +(defn integer + "Distribution of integers biased towards the small, but + including all longs." + [] + (gen/one-of #(gen/uniform -1 32) gen/byte gen/short gen/int gen/long)) + +(defn longable? + [n] + (try + (long n) + true + (catch Exception _))) + +(defspec integer-commutative-laws + (partial map identity) + [^{:tag `integer} a ^{:tag `integer} b] + (if (longable? (+' a b)) + (assert (= (+ a b) (+ b a) + (+' a b) (+' b a) + (unchecked-add a b) (unchecked-add b a))) + (assert (= (+' a b) (+' b a)))) + (if (longable? (*' a b)) + (assert (= (* a b) (* b a) + (*' a b) (*' b a) + (unchecked-multiply a b) (unchecked-multiply b a))) + (assert (= (*' a b) (*' b a))))) + +(defspec integer-associative-laws + (partial map identity) + [^{:tag `integer} a ^{:tag `integer} b ^{:tag `integer} c] + (if (every? longable? [(+' a b) (+' b c) (+' a b c)]) + (assert (= (+ (+ a b) c) (+ a (+ b c)) + (+' (+' a b) c) (+' a (+' b c)) + (unchecked-add (unchecked-add a b) c) (unchecked-add a (unchecked-add b c)))) + (assert (= (+' (+' a b) c) (+' a (+' b c)) + (+ (+ (bigint a) b) c) (+ a (+ (bigint b) c))))) + (if (every? longable? [(*' a b) (*' b c) (*' a b c)]) + (assert (= (* (* a b) c) (* a (* b c)) + (*' (*' a b) c) (*' a (*' b c)) + (unchecked-multiply (unchecked-multiply a b) c) (unchecked-multiply a (unchecked-multiply b c)))) + (assert (= (*' (*' a b) c) (*' a (*' b c)) + (* (* (bigint a) b) c) (* a (* (bigint b) c)))))) + +(defspec integer-distributive-laws + (partial map identity) + [^{:tag `integer} a ^{:tag `integer} b ^{:tag `integer} c] + (if (every? longable? [(*' a (+' b c)) (+' (*' a b) (*' a c)) + (*' a b) (*' a c) (+' b c)]) + (assert (= (* a (+ b c)) (+ (* a b) (* a c)) + (*' a (+' b c)) (+' (*' a b) (*' a c)) + (unchecked-multiply a (+' b c)) (+' (unchecked-multiply a b) (unchecked-multiply a c)))) + (assert (= (*' a (+' b c)) (+' (*' a b) (*' a c)) + (* a (+ (bigint b) c)) (+ (* (bigint a) b) (* (bigint a) c)))))) + +(defspec addition-undoes-subtraction + (partial map identity) + [^{:tag `integer} a ^{:tag `integer} b] + (if (longable? (-' a b)) + (assert (= a + (-> a (- b) (+ b)) + (-> a (unchecked-subtract b) (unchecked-add b))))) + (assert (= a + (-> a (-' b) (+' b))))) + +(defspec quotient-and-remainder + (fn [a b] (sort [a b])) + [^{:tag `integer} a ^{:tag `integer} b] + (when-not (zero? (second %)) + (let [[a d] % + q (quot a d) + r (rem a d)] + (assert (= a + (+ (* q d) r) + (unchecked-add (unchecked-multiply q d) r)))))) + +(deftest unchecked-inc-overflow + (testing "max value overflows to min value" + (is (= Int64/MinValue (unchecked-inc Int64/MaxValue))) ;;; Long/MIN_VALUE Long/MAX_VALUE + (is (= Int64/MinValue (unchecked-inc ^Object Int64/MaxValue))))) ;;; Long/MIN_VALUE (Long/valueOf Long/MAX_VALUE) + +(deftest unchecked-dec-overflow + (testing "min value overflows to max value" + (is (= Int64/MaxValue (unchecked-dec Int64/MinValue))) ;;; Long/MAX_VALUE Long/MIN_VALUE + (is (= Int64/MaxValue (unchecked-dec ^Object Int64/MinValue))))) ;;; Long/MAX_VALUE (Long/valueOf Long/MIN_VALUE) + +(deftest unchecked-negate-overflow + (testing "negating min value overflows to min value itself" + (is (= Int64/MinValue (unchecked-negate Int64/MinValue))) ;;; Long/MIN_VALUE Long/MIN_VALUE + (is (= Int64/MinValue (unchecked-negate ^Object Int64/MinValue))))) ;;; Long/MIN_VALUE (Long/valueOf Long/MIN_VALUE) + +(deftest unchecked-add-overflow + (testing "max value overflows to min value" + (is (= Int64/MinValue (unchecked-add Int64/MaxValue 1))) ;;; Long/MIN_VALUE Long/MAX_VALUE + (is (= Int64/MinValue (unchecked-add Int64/MaxValue ((fn [] 1))))) ;;; Long/MIN_VALUE (Long/valueOf Long/MAX_VALUE) + (is (= Int64/MinValue (unchecked-add ^Object Int64/MaxValue 1))) ;;; Long/MIN_VALUE (Long/valueOf 1) + (is (= Int64/MinValue (unchecked-add ^Object Int64/MaxValue ((fn [] 1)))))) ;;; Long/MIN_VALUE (Long/valueOf Long/MAX_VALUE) (Long/valueOf 1) + (testing "adding min value to min value results in zero" + (is (= 0 (unchecked-add Int64/MinValue Int64/MinValue))) ;;; Long/MIN_VALUE Long/MIN_VALUE + (is (= 0 (unchecked-add Int64/MinValue ^Object Int64/MinValue))) ;;; Long/MIN_VALUE (Long/valueOf Long/MIN_VALUE) + (is (= 0 (unchecked-add ^Object Int64/MinValue Int64/MinValue))) ;;; (Long/valueOf Long/MIN_VALUE) Long/MIN_VALUE + (is (= 0 (unchecked-add ^Object Int64/MinValue ^Object Int64/MinValue))))) ;;; (Long/valueOf Long/MIN_VALUE) (Long/valueOf Long/MIN_VALUE) + +(deftest unchecked-subtract-overflow + (testing "min value overflows to max-value" ;;; etc + (is (= Int64/MaxValue (unchecked-subtract Int64/MinValue 1))) + (is (= Int64/MaxValue (unchecked-subtract Int64/MinValue ((fn [] 1))))) + (is (= Int64/MaxValue (unchecked-subtract ^Object Int64/MinValue 1))) + (is (= Int64/MaxValue (unchecked-subtract ^Object Int64/MinValue ((fn [] 1)))))) + (testing "negating min value overflows to min value itself" + (is (= Int64/MinValue (unchecked-subtract 0 Int64/MinValue))) + (is (= Int64/MinValue (unchecked-subtract 0 ^Object Int64/MinValue))) + (is (= Int64/MinValue (unchecked-subtract ((fn [] 0)) Int64/MinValue))) + (is (= Int64/MinValue (unchecked-subtract ((fn [] 0)) ^Object Int64/MinValue))))) + +(deftest unchecked-multiply-overflow + (testing "two times max value results in -2" + (is (= -2 (unchecked-multiply Int64/MaxValue 2))) + (is (= -2 (unchecked-multiply Int64/MaxValue ((fn [] 2))))) + (is (= -2 (unchecked-multiply ^Object Int64/MaxValue 2))) + (is (= -2 (unchecked-multiply ^Object Int64/MaxValue ((fn [] 2)))))) + (testing "two times min value results in 0" + (is (= 0 (unchecked-multiply Int64/MinValue 2))) + (is (= 0 (unchecked-multiply Int64/MinValue ((fn [] 2))))) + (is (= 0 (unchecked-multiply ^Object Int64/MinValue 2))) + (is (= 0 (unchecked-multiply ^Object Int64/MinValue ((fn [] 2))))))) + +(defmacro check-warn-on-box [warn? form] + `(do (binding [*unchecked-math* :warn-on-boxed] + (is (= ~warn? + (boolean + (re-find #"^Boxed math warning" + (helper/with-err-string-writer + (helper/eval-in-temp-ns ~form))))))) + (binding [*unchecked-math* true] + (is (false? + (boolean + (re-find #"^Boxed math warning" + (helper/with-err-string-writer + (helper/eval-in-temp-ns ~form))))))) + (binding [*unchecked-math* false] + (is (false? + (boolean + (re-find #"^Boxed math warning" + (helper/with-err-string-writer + (helper/eval-in-temp-ns ~form))))))))) + +(deftest warn-on-boxed + (check-warn-on-box true (#(inc %) 2)) + (check-warn-on-box false (#(inc ^long %) 2)) + (check-warn-on-box false (long-array 5)) + (check-warn-on-box true (> (first (range 3)) 0)) + (check-warn-on-box false (> ^long (first (range 3)) 0))) + + +(deftest comparisons + (let [small-numbers [1 1.0 (int 1) (float 1) 9/10 1N 1M] ;;; (Integer. 1) (Float. 1.0) + big-numbers [10 10.0 (int 10) (float 10.0) 99/10 10N 10N]] ;;; (Integer. 10) (Float. 10.0) + (doseq [small small-numbers big big-numbers] + (is (< small big)) + (is (not (< big small))) + (is (not (< small small))) + (is (< (int small) (int big))) + (is (not (< (int big) (int small)))) + (is (not (< (int small) (int small)))) + (is (< (double small) (double big))) + (is (not (< (double big) (double small)))) + (is (not (< (double small) (double small)))) + (is (<= small big)) + (is (<= small small)) + (is (not (<= big small))) + (is (<= (int small) (int big))) + (is (<= (int small) (int small))) + (is (not (<= (int big) (int small)))) + (is (<= (double small) (double big))) + (is (<= (double small) (double small))) + (is (not (<= (double big) (double small)))) + (is (> big small)) + (is (not (> small big))) + (is (not (> small small))) + (is (> (int big) (int small))) + (is (not (> (int small) (int big)))) + (is (not (> (int small) (int small)))) + (is (> (double big) (double small))) + (is (not (> (double small) (double big)))) + (is (not (> (double small) (double small)))) + (is (>= big small)) + (is (>= small small)) + (is (not (>= small big))) + (is (>= (int big) (int small))) + (is (>= (int small) (int small))) + (is (not (>= (int small) (int big)))) + (is (>= (double big) (double small))) + (is (>= (double small) (double small))) + (is (not (>= (double small) (double big))))))) + +(deftest test-nan-comparison + (are [x y] (= x y) + (< 1000 Double/NaN) (< 1000 (double Double/NaN)) ;;; (Double. Double/NaN) -- no boxed, so kinda pointless + (<= 1000 Double/NaN) (<= 1000 (double Double/NaN)) ;;; (Double. Double/NaN) + (> 1000 Double/NaN) (> 1000 (double Double/NaN)) ;;; (Double. Double/NaN) + (>= 1000 Double/NaN) (>= 1000 (double Double/NaN)))) ;;; (Double. Double/NaN) + +(deftest test-nan-as-operand + (testing "All numeric operations with NaN as an operand produce NaN as a result" + (let [nan Double/NaN + onan (cast Object Double/NaN)] + (are [x] (Double/IsNaN x) ;;; Double/isNaN + (+ nan 1) + (+ nan 0) + (+ nan 0.0) + (+ 1 nan) + (+ 0 nan) + (+ 0.0 nan) + (+ nan nan) + (- nan 1) + (- nan 0) + (- nan 0.0) + (- 1 nan) + (- 0 nan) + (- 0.0 nan) + (- nan nan) + (* nan 1) + (* nan 0) + (* nan 0.0) + (* 1 nan) + (* 0 nan) + (* 0.0 nan) + (* nan nan) + (/ nan 1) + (/ nan 0) + (/ nan 0.0) + (/ 1 nan) + (/ 0 nan) + (/ 0.0 nan) + (/ nan nan) + (+ onan 1) + (+ onan 0) + (+ onan 0.0) + (+ 1 onan) + (+ 0 onan) + (+ 0.0 onan) + (+ onan onan) + (- onan 1) + (- onan 0) + (- onan 0.0) + (- 1 onan) + (- 0 onan) + (- 0.0 onan) + (- onan onan) + (* onan 1) + (* onan 0) + (* onan 0.0) + (* 1 onan) + (* 0 onan) + (* 0.0 onan) + (* onan onan) + (/ onan 1) + (/ onan 0) + (/ onan 0.0) + (/ 1 onan) + (/ 0 onan) + (/ 0.0 onan) + (/ onan onan) + (+ nan onan) + (+ onan nan) + (- nan onan) + (- onan nan) + (* nan onan) + (* onan nan) + (/ nan onan) (/ onan nan) )))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/other_functions.clj b/Clojure/Clojure.Tests/clojure/test_clojure/other_functions.clj index 87e0ffc5c..b4193cfd8 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/other_functions.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/other_functions.clj @@ -330,17 +330,17 @@ (apply (apply some-fn (repeat i (comp not boolean))) (range i)))) true)))) - -(deftest test-max-min-key - (are [k coll min-item max-item] (and (= min-item (apply min-key k coll)) - (= max-item (apply max-key k coll))) - count ["longest" "a" "xy" "foo" "bar"] "a" "longest" - - [5 10 15 20 25] 25 5 - #(if (neg? %) (- %) %) [-2 -1 0 1 2 3 4] 0 4 - {nil 1 false -1 true 0} [true true false nil] false nil) - (are [f k coll expected] (= expected (apply f k coll)) - min-key :x [{:x 1000} {:x 1001} {:x 1002} {:x 1000 :second true}] {:x 1000 :second true} - max-key :x [{:x 1000} {:x 999} {:x 998} {:x 1000 :second true}] {:x 1000 :second true})) + +(deftest test-max-min-key + (are [k coll min-item max-item] (and (= min-item (apply min-key k coll)) + (= max-item (apply max-key k coll))) + count ["longest" "a" "xy" "foo" "bar"] "a" "longest" + - [5 10 15 20 25] 25 5 + #(if (neg? %) (- %) %) [-2 -1 0 1 2 3 4] 0 4 + {nil 1 false -1 true 0} [true true false nil] false nil) + (are [f k coll expected] (= expected (apply f k coll)) + min-key :x [{:x 1000} {:x 1001} {:x 1002} {:x 1000 :second true}] {:x 1000 :second true} + max-key :x [{:x 1000} {:x 999} {:x 998} {:x 1000 :second true}] {:x 1000 :second true})) ; Printing @@ -350,52 +350,52 @@ ; Regex Support ; re-matcher re-find re-matches re-groups re-seq -(deftest test-regex-matcher - (let [matcher (re-matcher #"(\d{2})/(\d{2})/(\d{4})" "12/02/1975")] - (is (= ["12/02/1975" "12" "02" "1975"] (re-find matcher))) - (is (= ["12/02/1975" "12" "02" "1975"] (re-groups matcher))) - (is (= "12/02/1975" (nth matcher 0) (nth matcher 0 :foo))) - (is (= "12" (nth matcher 1) (nth matcher 1 :foo))) - (is (= "02" (nth matcher 2) (nth matcher 2 :foo))) - (is (= "1975" (nth matcher 3) (nth matcher 3 :foo))) - (is (thrown? ArgumentOutOfRangeException (nth matcher -1))) ;;; IndexOutOfBoundsException - (is (= :foo (nth matcher -1 :foo))) - (is (thrown? ArgumentOutOfRangeException (nth matcher 4))) ;;; IndexOutOfBoundsException +(deftest test-regex-matcher + (let [matcher (re-matcher #"(\d{2})/(\d{2})/(\d{4})" "12/02/1975")] + (is (= ["12/02/1975" "12" "02" "1975"] (re-find matcher))) + (is (= ["12/02/1975" "12" "02" "1975"] (re-groups matcher))) + (is (= "12/02/1975" (nth matcher 0) (nth matcher 0 :foo))) + (is (= "12" (nth matcher 1) (nth matcher 1 :foo))) + (is (= "02" (nth matcher 2) (nth matcher 2 :foo))) + (is (= "1975" (nth matcher 3) (nth matcher 3 :foo))) + (is (thrown? ArgumentOutOfRangeException (nth matcher -1))) ;;; IndexOutOfBoundsException + (is (= :foo (nth matcher -1 :foo))) + (is (thrown? ArgumentOutOfRangeException (nth matcher 4))) ;;; IndexOutOfBoundsException (is (= :foo (nth matcher 4 :foo))))) -; update - -(deftest test-update - (are [result expr] (= result expr) - {:a [1 2]} (update {:a [1]} :a conj 2) - [1] (update [0] 0 inc) - ;; higher-order usage - {:a {:b 2}} (update-in {:a {:b 1}} [:a] update :b inc) - ;; missing field = nil - {:a 1 :b nil} (update {:a 1} :b identity) - ;; 4 hard-coded arities - {:a 1} (update {:a 1} :a +) - {:a 2} (update {:a 1} :a + 1) - {:a 3} (update {:a 1} :a + 1 1) - {:a 4} (update {:a 1} :a + 1 1 1) - ;; rest arity - {:a 5} (update {:a 1} :a + 1 1 1 1) - {:a 6} (update {:a 1} :a + 1 1 1 1 1))) - -(deftest test-update-vals - (let [inm (with-meta {:a 1 :b 2} {:has :meta})] - (are [result expr] (= result expr) - {:a 2 :b 3} (update-vals inm inc) - {:has :meta} (meta (update-vals inm inc)) - {0 2 2 4} (update-vals (hash-map 0 1 2 3) inc) - {0 2 2 4} (update-vals (array-map 0 1 2 3) inc) - {0 2 2 4} (update-vals (sorted-map 2 3 0 1) inc)))) - -(deftest test-update-keys - (let [inm (with-meta {:a 1 :b 2} {:has :meta})] - (are [result expr] (= result expr) - {"a" 1 "b" 2} (update-keys inm name) - {:has :meta} (meta (update-keys inm name)) - {1 1 3 3} (update-keys (hash-map 0 1 2 3) inc) - {1 1 3 3} (update-keys (array-map 0 1 2 3) inc) +; update + +(deftest test-update + (are [result expr] (= result expr) + {:a [1 2]} (update {:a [1]} :a conj 2) + [1] (update [0] 0 inc) + ;; higher-order usage + {:a {:b 2}} (update-in {:a {:b 1}} [:a] update :b inc) + ;; missing field = nil + {:a 1 :b nil} (update {:a 1} :b identity) + ;; 4 hard-coded arities + {:a 1} (update {:a 1} :a +) + {:a 2} (update {:a 1} :a + 1) + {:a 3} (update {:a 1} :a + 1 1) + {:a 4} (update {:a 1} :a + 1 1 1) + ;; rest arity + {:a 5} (update {:a 1} :a + 1 1 1 1) + {:a 6} (update {:a 1} :a + 1 1 1 1 1))) + +(deftest test-update-vals + (let [inm (with-meta {:a 1 :b 2} {:has :meta})] + (are [result expr] (= result expr) + {:a 2 :b 3} (update-vals inm inc) + {:has :meta} (meta (update-vals inm inc)) + {0 2 2 4} (update-vals (hash-map 0 1 2 3) inc) + {0 2 2 4} (update-vals (array-map 0 1 2 3) inc) + {0 2 2 4} (update-vals (sorted-map 2 3 0 1) inc)))) + +(deftest test-update-keys + (let [inm (with-meta {:a 1 :b 2} {:has :meta})] + (are [result expr] (= result expr) + {"a" 1 "b" 2} (update-keys inm name) + {:has :meta} (meta (update-keys inm name)) + {1 1 3 3} (update-keys (hash-map 0 1 2 3) inc) + {1 1 3 3} (update-keys (array-map 0 1 2 3) inc) {1 1 3 3} (update-keys (sorted-map 2 3 0 1) inc)))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/parallel.clj b/Clojure/Clojure.Tests/clojure/test_clojure/parallel.clj index 39971eb8e..93c0b8093 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/parallel.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/parallel.clj @@ -27,13 +27,13 @@ ;; regression fixed in r1218; was OutOfMemoryError (is (= '(1) (pmap inc [0])))) -(def ^:dynamic *test-value* 1) - -(deftest future-fn-properly-retains-conveyed-bindings - (let [a (atom [])] - (binding [*test-value* 2] - @(future (dotimes [_ 3] - ;; we need some binding to trigger binding pop - (binding [*print-dup* false] - (swap! a conj *test-value*)))) +(def ^:dynamic *test-value* 1) + +(deftest future-fn-properly-retains-conveyed-bindings + (let [a (atom [])] + (binding [*test-value* 2] + @(future (dotimes [_ 3] + ;; we need some binding to trigger binding pop + (binding [*print-dup* false] + (swap! a conj *test-value*)))) (is (= [2 2 2] @a))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/pprint/test_cl_format.clj b/Clojure/Clojure.Tests/clojure/test_clojure/pprint/test_cl_format.clj index c4d710f7d..dc0f78f60 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/pprint/test_cl_format.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/pprint/test_cl_format.clj @@ -589,27 +589,27 @@ (format nil "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F" x x x x x x)) -;; big-pos-ratio is a ratio value that is larger than -;; Double/MAX_VALUE, and has a non-terminating decimal representation -;; if you attempt to represent it exactly. -(def big-pos-ratio (/ (* 4 (bigint (BigDecimal/Create Double/MaxValue))) 3)) ;;; (. BigDecimal valueOf Double/MAX_VALUE) -(def big-neg-ratio (- big-pos-ratio)) -;; tiny-pos-ratio is a ratio between 0 and Double/MIN_VALUE. -(def tiny-pos-ratio (/ 1 (bigint (apply str (cons "1" (repeat 340 "0")))))) -(def tiny-neg-ratio (- tiny-pos-ratio)) +;; big-pos-ratio is a ratio value that is larger than +;; Double/MAX_VALUE, and has a non-terminating decimal representation +;; if you attempt to represent it exactly. +(def big-pos-ratio (/ (* 4 (bigint (BigDecimal/Create Double/MaxValue))) 3)) ;;; (. BigDecimal valueOf Double/MAX_VALUE) +(def big-neg-ratio (- big-pos-ratio)) +;; tiny-pos-ratio is a ratio between 0 and Double/MIN_VALUE. +(def tiny-pos-ratio (/ 1 (bigint (apply str (cons "1" (repeat 340 "0")))))) +(def tiny-neg-ratio (- tiny-pos-ratio)) (simple-tests cltl-F-tests - (cl-format false "~10,3f" 4/5) " 0.800" - (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 They have 2396924179816420933333333333333333 - problem in BigDecimal? Maybe JVM - (cl-format false "~10,3f" big-pos-ratio)) "239692417981642094419369898308939100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000.000" - (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 They have 2396924179816420933333333333333333 - problem in BigDecimal? Maybe JVM - (cl-format false "~10,3f" big-neg-ratio)) "-239692417981642094419369898308939100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000.000" - (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 - (cl-format false "~10,3f" tiny-pos-ratio)) " 0.000" - (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 + (cl-format false "~10,3f" 4/5) " 0.800" + (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 They have 2396924179816420933333333333333333 - problem in BigDecimal? Maybe JVM + (cl-format false "~10,3f" big-pos-ratio)) "239692417981642094419369898308939100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000.000" + (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 They have 2396924179816420933333333333333333 - problem in BigDecimal? Maybe JVM + (cl-format false "~10,3f" big-neg-ratio)) "-239692417981642094419369898308939100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000.000" + (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 + (cl-format false "~10,3f" tiny-pos-ratio)) " 0.000" + (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 (cl-format false "~10,3f" tiny-neg-ratio)) " -0.000" (foo 3.14159) " 3.14| 31.42| 3.14|3.1416|3.14|3.14159" - (foo 314159/100000) + (foo 314159/100000) " 3.14| 31.42| 3.14|3.1416|3.14|3.14159" (foo -3.14159) " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" (foo 100.0) "100.00|******|100.00| 100.0|100.00|100.0" @@ -623,17 +623,17 @@ ;; Clojure doesn't support float/double differences in representation (simple-tests cltl-E-tests - (cl-format false "~10,3e" 4/5) " 8.000E-1" - (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 - (cl-format false "~10,3e" big-pos-ratio)) "2.397E+308" - (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 - (cl-format false "~10,3e" big-neg-ratio)) "-2.397E+308" - (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 - (cl-format false "~10,3e" tiny-pos-ratio)) "1.000E-340" - (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 + (cl-format false "~10,3e" 4/5) " 8.000E-1" + (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 + (cl-format false "~10,3e" big-pos-ratio)) "2.397E+308" + (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 + (cl-format false "~10,3e" big-neg-ratio)) "-2.397E+308" + (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 + (cl-format false "~10,3e" tiny-pos-ratio)) "1.000E-340" + (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 (cl-format false "~10,3e" tiny-neg-ratio)) "-1.000E-340" (foo-e 0.0314159) " 3.14E-2| 31.42$-03|+.003E+01| 3.14E-2" ; Added this one - (foo-e 314159/10000000) + (foo-e 314159/10000000) " 3.14E-2| 31.42$-03|+.003E+01| 3.14E-2" (foo-e 3.14159) " 3.14E+0| 31.42$-01|+.003E+03| 3.14E+0" (foo-e -3.14159) " -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0" @@ -672,17 +672,17 @@ ;; Clojure doesn't support float/double differences in representation (simple-tests cltl-G-tests - (cl-format false "~10,3g" 4/5) " 0.800 " - (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 - (cl-format false "~10,3g" big-pos-ratio)) "2.397E+308" - (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 - (cl-format false "~10,3g" big-neg-ratio)) "-2.397E+308" - (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 - (cl-format false "~10,3g" tiny-pos-ratio)) "1.000E-340" - (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 + (cl-format false "~10,3g" 4/5) " 0.800 " + (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 + (cl-format false "~10,3g" big-pos-ratio)) "2.397E+308" + (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 + (cl-format false "~10,3g" big-neg-ratio)) "-2.397E+308" + (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 + (cl-format false "~10,3g" tiny-pos-ratio)) "1.000E-340" + (binding [*math-context* clojure.lang.BigDecimal+Context/Decimal128] ;;; java.math.MathContext/DECIMAL128 (cl-format false "~10,3g" tiny-neg-ratio)) "-1.000E-340" (foo-g 0.0314159) " 3.14E-2|314.2$-04|0.314E-01| 3.14E-2" - (foo-g 314159/10000000) + (foo-g 314159/10000000) " 3.14E-2|314.2$-04|0.314E-01| 3.14E-2" (foo-g 0.314159) " 0.31 |0.314 |0.314 | 0.31 " (foo-g 3.14159) " 3.1 | 3.14 | 3.14 | 3.1 " @@ -824,20 +824,20 @@ but it was called with an argument of type short-float.\n") " ) -(simple-tests *-at-tests - (format nil "~*~c defaults to ~D, so ~~@* goes ~A to the ~@*~A arg." - 'first \n 0 'back) - "n defaults to 0, so ~@* goes back to the first arg." - (format nil "~~n@* is an ~1@*~A ~0@*~A rather than a ~2@*~A ~0@*~A." - 'goto 'absolute 'relative) - "~n@* is an absolute goto rather than a relative goto." - (format nil "We will see no numbers: ~6@*~S" - 0 1 2 3 4 5 :see?) "We will see no numbers: :see?" - (format nil "~4@*~D ~3@*~D ~2@*~D ~1@*~D ~0@*~D" - 0 1 2 3 4) "4 3 2 1 0" - (format nil "~{~A a ~~{ ~3@*~A, the ~1@*~A is ~A to the ~4@*~A of ~A~}[...]" - '("Within" goto relative construct list arguments)) - "Within a ~{ construct, the goto is relative to the list of arguments[...]" - (format nil "~{~2@*~S ~1@*~S ~4@*~S ~3@*~S ~S~}" - '(:a :b :c :d :e)) ":c :b :e :d :e" +(simple-tests *-at-tests + (format nil "~*~c defaults to ~D, so ~~@* goes ~A to the ~@*~A arg." + 'first \n 0 'back) + "n defaults to 0, so ~@* goes back to the first arg." + (format nil "~~n@* is an ~1@*~A ~0@*~A rather than a ~2@*~A ~0@*~A." + 'goto 'absolute 'relative) + "~n@* is an absolute goto rather than a relative goto." + (format nil "We will see no numbers: ~6@*~S" + 0 1 2 3 4 5 :see?) "We will see no numbers: :see?" + (format nil "~4@*~D ~3@*~D ~2@*~D ~1@*~D ~0@*~D" + 0 1 2 3 4) "4 3 2 1 0" + (format nil "~{~A a ~~{ ~3@*~A, the ~1@*~A is ~A to the ~4@*~A of ~A~}[...]" + '("Within" goto relative construct list arguments)) + "Within a ~{ construct, the goto is relative to the list of arguments[...]" + (format nil "~{~2@*~S ~1@*~S ~4@*~S ~3@*~S ~S~}" + '(:a :b :c :d :e)) ":c :b :e :d :e" ) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/pprint/test_pretty.clj b/Clojure/Clojure.Tests/clojure/test_clojure/pprint/test_pretty.clj index 8e7589b49..57261cea8 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/pprint/test_pretty.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/pprint/test_pretty.clj @@ -105,10 +105,10 @@ Usage: *hello* '(add-to-buffer this (make-buffer-blob (str (char c)) nil)) :stream nil))) "(add-to-buffer\n this\n (make-buffer-blob (str (char c)) nil))" - - (binding [*print-pprint-dispatch* simple-dispatch] - (write (var Foo) :stream nil)) - "#'clojure.test-clojure.pprint/Foo" + + (binding [*print-pprint-dispatch* simple-dispatch] + (write (var Foo) :stream nil)) + "#'clojure.test-clojure.pprint/Foo" ) @@ -301,24 +301,24 @@ It is implemented with a number of custom enlive templates.\" (binding [*print-length* 8] (with-out-str (pprint [1 2 3 4 5 6]))) "[1 2 3 4 5 6]\n" - (binding [*print-length* 1] (with-out-str (pprint (sorted-set 1 2 3 4 5 6)))) - "#{1 ...}\n" - (binding [*print-length* 2] (with-out-str (pprint (sorted-set 1 2 3 4 5 6)))) - "#{1 2 ...}\n" - (binding [*print-length* 6] (with-out-str (pprint (sorted-set 1 2 3 4 5 6)))) - "#{1 2 3 4 5 6}\n" - (binding [*print-length* 8] (with-out-str (pprint (sorted-set 1 2 3 4 5 6)))) - "#{1 2 3 4 5 6}\n" - - (binding [*print-length* 1] (with-out-str (pprint (sorted-map 1 2, 3 4, 5 6, 7 8, 9 10, 11 12)))) - "{1 2, ...}\n" - (binding [*print-length* 2] (with-out-str (pprint (sorted-map 1 2, 3 4, 5 6, 7 8, 9 10, 11 12)))) - "{1 2, 3 4, ...}\n" - (binding [*print-length* 6] (with-out-str (pprint (sorted-map 1 2, 3 4, 5 6, 7 8, 9 10, 11 12)))) - "{1 2, 3 4, 5 6, 7 8, 9 10, 11 12}\n" - (binding [*print-length* 8] (with-out-str (pprint (sorted-map 1 2, 3 4, 5 6, 7 8, 9 10, 11 12)))) - "{1 2, 3 4, 5 6, 7 8, 9 10, 11 12}\n" - + (binding [*print-length* 1] (with-out-str (pprint (sorted-set 1 2 3 4 5 6)))) + "#{1 ...}\n" + (binding [*print-length* 2] (with-out-str (pprint (sorted-set 1 2 3 4 5 6)))) + "#{1 2 ...}\n" + (binding [*print-length* 6] (with-out-str (pprint (sorted-set 1 2 3 4 5 6)))) + "#{1 2 3 4 5 6}\n" + (binding [*print-length* 8] (with-out-str (pprint (sorted-set 1 2 3 4 5 6)))) + "#{1 2 3 4 5 6}\n" + + (binding [*print-length* 1] (with-out-str (pprint (sorted-map 1 2, 3 4, 5 6, 7 8, 9 10, 11 12)))) + "{1 2, ...}\n" + (binding [*print-length* 2] (with-out-str (pprint (sorted-map 1 2, 3 4, 5 6, 7 8, 9 10, 11 12)))) + "{1 2, 3 4, ...}\n" + (binding [*print-length* 6] (with-out-str (pprint (sorted-map 1 2, 3 4, 5 6, 7 8, 9 10, 11 12)))) + "{1 2, 3 4, 5 6, 7 8, 9 10, 11 12}\n" + (binding [*print-length* 8] (with-out-str (pprint (sorted-map 1 2, 3 4, 5 6, 7 8, 9 10, 11 12)))) + "{1 2, 3 4, 5 6, 7 8, 9 10, 11 12}\n" + (binding [*print-length* 1] (with-out-str (pprint (int-array [1 2 3 4 5 6])))) "[1, ...]\n" @@ -376,40 +376,40 @@ It is implemented with a number of custom enlive templates.\" (pprint (range 50))) (is (= @flush-count-atom 0) "pprint flushes on newline"))) -(deftest test-pprint-calendar - (let [calendar (.ToDateTime (System.Globalization.GregorianCalendar.) 2014 3 29 14 0 0 0) ;;; (doto (java.util.GregorianCalendar. 2014 3 29 14 0 0) - ;;; (.setTimeZone (java.util.TimeZone/getTimeZone "GMT"))) - calendar-str (with-out-str (pprint calendar))] - (is (= (str/split-lines calendar-str) - ["#inst \"2014-03-29T14:00:00.000-00:00\"" ""]) ;;; "#inst \"2014-04-29T14:00:00.000+00:00\"" Added "" - "calendar object pretty prints"))) - -(deftest test-print-meta - (let [r (with-meta (range 24) {:b 2})] - (are [expected val] (= (platform-newlines expected) (with-out-str (binding [*print-meta* true] (pprint val)))) - "^{:a 1, :b 2} {:x 1, :y 2}\n" - ^{:a 1 :b 2} {:x 1 :y 2} - - "^{:a 1, :b 2}\n{:x\n ^{:b 2}\n (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23),\n :y 1}\n" - ^{:a 1 :b 2} {:x r :y 1} - - "^{:a 1} {:x ^{:foo true} {:y 2}}\n" - ^{:a 1} {:x ^:foo {:y 2}} - - "^{:a 1} [1 2 3 4]\n" - ^{:a 1} [1 2 3 4] - - "^{:a 1} [^{:b 2} [1 2]]\n" - ^{:a 1} [^{:b 2} [1 2]] - - "^{:a 1}\n[[[1\n ^{:b 2}\n (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)]]]\n" - ^{:a 1} [[[1 ^{:b 2} r]]] - - "^{:line 409,\n :column 17,\n :source-span\n {:start-line 409, :start-column 17, :end-line 409, :end-column 25}}\n(1 2 3 4)\n" ;;; "^{:line 409, :column 16} (1 2 3 4)\n" - ^{:a 1} '(1 2 3 4) - - "^{:a 1} (0 1 2 3)\n" - ^{:a 1} (with-meta (range 4) {:a 1}) - - "^{:a 1} #{1 4 3 2}\n" +(deftest test-pprint-calendar + (let [calendar (.ToDateTime (System.Globalization.GregorianCalendar.) 2014 3 29 14 0 0 0) ;;; (doto (java.util.GregorianCalendar. 2014 3 29 14 0 0) + ;;; (.setTimeZone (java.util.TimeZone/getTimeZone "GMT"))) + calendar-str (with-out-str (pprint calendar))] + (is (= (str/split-lines calendar-str) + ["#inst \"2014-03-29T14:00:00.000-00:00\"" ""]) ;;; "#inst \"2014-04-29T14:00:00.000+00:00\"" Added "" + "calendar object pretty prints"))) + +(deftest test-print-meta + (let [r (with-meta (range 24) {:b 2})] + (are [expected val] (= (platform-newlines expected) (with-out-str (binding [*print-meta* true] (pprint val)))) + "^{:a 1, :b 2} {:x 1, :y 2}\n" + ^{:a 1 :b 2} {:x 1 :y 2} + + "^{:a 1, :b 2}\n{:x\n ^{:b 2}\n (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23),\n :y 1}\n" + ^{:a 1 :b 2} {:x r :y 1} + + "^{:a 1} {:x ^{:foo true} {:y 2}}\n" + ^{:a 1} {:x ^:foo {:y 2}} + + "^{:a 1} [1 2 3 4]\n" + ^{:a 1} [1 2 3 4] + + "^{:a 1} [^{:b 2} [1 2]]\n" + ^{:a 1} [^{:b 2} [1 2]] + + "^{:a 1}\n[[[1\n ^{:b 2}\n (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)]]]\n" + ^{:a 1} [[[1 ^{:b 2} r]]] + + "^{:line 409,\n :column 17,\n :source-span\n {:start-line 409, :start-column 17, :end-line 409, :end-column 25}}\n(1 2 3 4)\n" ;;; "^{:line 409, :column 16} (1 2 3 4)\n" + ^{:a 1} '(1 2 3 4) + + "^{:a 1} (0 1 2 3)\n" + ^{:a 1} (with-meta (range 4) {:a 1}) + + "^{:a 1} #{1 4 3 2}\n" ^{:a 1} #{1 2 3 4}))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/predicates.clj b/Clojure/Clojure.Tests/clojure/test_clojure/predicates.clj index 53af3e557..3f05c59ce 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/predicates.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/predicates.clj @@ -1,194 +1,194 @@ -; 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: Frantisek Sodomka - -;; -;; Created 1/28/2009 - -(ns clojure.test-clojure.predicates - (:use clojure.test)) - - -;; *** Type predicates *** - -(def myvar 42) - -(def sample-data { - :nil nil - - :bool-true true - :bool-false false - - :byte (byte 7) - :short (short 7) - :int (int 7) - :long (long 7) - :bigint (bigint 7) - :float (float 7) - :double (double 7) - :bigdec (bigdec 7) - - :ratio 2/3 - - :character \a - :symbol 'abc - :keyword :kw - - :empty-string "" - :empty-regex #"" - :empty-list () - :empty-lazy-seq (lazy-seq nil) - :empty-vector [] - :empty-map {} - :empty-set #{} - :empty-array (into-array []) - - :string "abc" - :regex #"a*b" - :list '(1 2 3) - :lazy-seq (lazy-seq [1 2 3]) - :vector [1 2 3] - :map {:a 1 :b 2 :c 3} - :set #{1 2 3} - :array (into-array [1 2 3]) - - :fn (fn [x] (* 2 x)) - - :class DateTime ;;; java.util.Date - :object (. DateTime Now) ;;; (new java.util.Date) - - :var (var myvar) - :delay (delay (+ 1 2)) -}) - - -(def type-preds { - nil? [:nil] - - true? [:bool-true] - false? [:bool-false] - ; boolean? - - integer? [:byte :short :int :long :bigint] - float? [:float :double] - decimal? [:bigdec] - ratio? [:ratio] - rational? [:byte :short :int :long :bigint :ratio :bigdec] - number? [:byte :short :int :long :bigint :ratio :bigdec :float :double] - - ; character? - symbol? [:symbol] - keyword? [:keyword] - - string? [:empty-string :string] - ; regex? - - list? [:empty-list :list] - vector? [:empty-vector :vector] - map? [:empty-map :map] - set? [:empty-set :set] - - coll? [:empty-list :list - :empty-lazy-seq :lazy-seq - :empty-vector :vector - :empty-map :map - :empty-set :set] - - seq? [:empty-list :list - :empty-lazy-seq :lazy-seq] - ; array? - - fn? [:fn] - ifn? [:fn - :empty-vector :vector :empty-map :map :empty-set :set - :keyword :symbol :var] - - class? [:class] - var? [:var] - delay? [:delay] -}) - - -;; Test all type predicates against all data types -;; -(defn- get-fn-name [f] - (str - (apply str (nthnext (first (.Split (str f) (.ToCharArray "_") 1)) ;;; (.split (str f) "_") - (count "clojure/core$"))) ;;; (count "clojure.core$") - "?")) - -(deftest test-type-preds - (doseq [tp type-preds] - (doseq [dt sample-data] - (if (some #(= % (first dt)) (second tp)) - (is ((first tp) (second dt)) - (pr-str (list (get-fn-name (first tp)) (second dt)))) - (is (not ((first tp) (second dt))) - (pr-str (list 'not (list (get-fn-name (first tp)) (second dt))))))))) - - -;; Additional tests: -;; http://groups.google.com/group/clojure/browse_thread/thread/537761a06edb4b06/bfd4f0705b746a38 -;; -(deftest test-string?-more - (are [x] (not (string? x)) - (new StringBuilder "abc") ;;; java.lang.StringBuilder - )) ;;; (new java.lang.StringBuffer "xyz"))) - -(def pred-val-table - (let [now (System.DateTime.) ;;; java.util.Date. - uuid (System.Guid.) ;;; java.util.UUID/randomUUID - barray (byte-array 0) - uri (System.Uri. "http://clojure.org")] ;;; java.net.URI. - [' - [identity int? pos-int? neg-int? nat-int? double? boolean? indexed? seqable? ident? uuid? decimal? inst? uri? bytes?] - [0 true false false true false false false false false false false false false false] - [1 true true false true false false false false false false false false false false] - [-1 true false true false false false false false false false false false false false] - [1.0 false false false false true false false false false false false false false false] - [true false false false false false true false false false false false false false false] - [[] false false false false false false true true false false false false false false] - [nil false false false false false false false true false false false false false false] - [{} false false false false false false false true false false false false false false] - [:foo false false false false false false false false true false false false false false] - ['foo false false false false false false false false true false false false false false] - [0.0M false false false false false false false false false false true false false false] - [0N false false false false false false false false false false false false false false] - [uuid false false false false false false false false false true false false false false] - [uri false false false false false false false false false false false false true false] - [now false false false false false false false false false false false true false false] - [barray false false false false false false false true false false false false false true]])) - -(deftest test-preds - (let [[preds & rows] pred-val-table] - (doseq [row rows] - (let [v (first row)] - (dotimes [i (count row)] - (is (= ((resolve (nth preds i)) v) (nth row i)) - (pr-str (list (nth preds i) v)))))))) - -;; Special double predicates - -(deftest test-double-preds - (is (NaN? ##NaN)) - (is (NaN? (Double/Parse "NaN"))) ;;; Double/parseDouble - (is (NaN? (Single/Parse "NaN"))) ;;; Float/parseFloat - (is (NaN? Single/NaN)) ;;; Float/NaN - (is (not (NaN? 5))) - (is (thrown? Exception (NaN? nil))) ;;; Throwable - (is (thrown? Exception (NaN? :xyz))) ;;; Throwable - - (is (infinite? ##Inf)) - (is (infinite? ##-Inf)) - (is (infinite? Double/PositiveInfinity)) ;;; POSITIVE_INFINITY - (is (infinite? Double/NegativeInfinity)) ;;; NEGATIVE_INFINITY - (is (infinite? Single/PositiveInfinity)) ;;; Float/POSITIVE_INFINITY - (is (infinite? Single/NegativeInfinity)) ;;; Float/NEGATIVE_INFINITY - (is (thrown? Exception (infinite? nil))) ;;; Throwable +; 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: Frantisek Sodomka + +;; +;; Created 1/28/2009 + +(ns clojure.test-clojure.predicates + (:use clojure.test)) + + +;; *** Type predicates *** + +(def myvar 42) + +(def sample-data { + :nil nil + + :bool-true true + :bool-false false + + :byte (byte 7) + :short (short 7) + :int (int 7) + :long (long 7) + :bigint (bigint 7) + :float (float 7) + :double (double 7) + :bigdec (bigdec 7) + + :ratio 2/3 + + :character \a + :symbol 'abc + :keyword :kw + + :empty-string "" + :empty-regex #"" + :empty-list () + :empty-lazy-seq (lazy-seq nil) + :empty-vector [] + :empty-map {} + :empty-set #{} + :empty-array (into-array []) + + :string "abc" + :regex #"a*b" + :list '(1 2 3) + :lazy-seq (lazy-seq [1 2 3]) + :vector [1 2 3] + :map {:a 1 :b 2 :c 3} + :set #{1 2 3} + :array (into-array [1 2 3]) + + :fn (fn [x] (* 2 x)) + + :class DateTime ;;; java.util.Date + :object (. DateTime Now) ;;; (new java.util.Date) + + :var (var myvar) + :delay (delay (+ 1 2)) +}) + + +(def type-preds { + nil? [:nil] + + true? [:bool-true] + false? [:bool-false] + ; boolean? + + integer? [:byte :short :int :long :bigint] + float? [:float :double] + decimal? [:bigdec] + ratio? [:ratio] + rational? [:byte :short :int :long :bigint :ratio :bigdec] + number? [:byte :short :int :long :bigint :ratio :bigdec :float :double] + + ; character? + symbol? [:symbol] + keyword? [:keyword] + + string? [:empty-string :string] + ; regex? + + list? [:empty-list :list] + vector? [:empty-vector :vector] + map? [:empty-map :map] + set? [:empty-set :set] + + coll? [:empty-list :list + :empty-lazy-seq :lazy-seq + :empty-vector :vector + :empty-map :map + :empty-set :set] + + seq? [:empty-list :list + :empty-lazy-seq :lazy-seq] + ; array? + + fn? [:fn] + ifn? [:fn + :empty-vector :vector :empty-map :map :empty-set :set + :keyword :symbol :var] + + class? [:class] + var? [:var] + delay? [:delay] +}) + + +;; Test all type predicates against all data types +;; +(defn- get-fn-name [f] + (str + (apply str (nthnext (first (.Split (str f) (.ToCharArray "_") 1)) ;;; (.split (str f) "_") + (count "clojure/core$"))) ;;; (count "clojure.core$") + "?")) + +(deftest test-type-preds + (doseq [tp type-preds] + (doseq [dt sample-data] + (if (some #(= % (first dt)) (second tp)) + (is ((first tp) (second dt)) + (pr-str (list (get-fn-name (first tp)) (second dt)))) + (is (not ((first tp) (second dt))) + (pr-str (list 'not (list (get-fn-name (first tp)) (second dt))))))))) + + +;; Additional tests: +;; http://groups.google.com/group/clojure/browse_thread/thread/537761a06edb4b06/bfd4f0705b746a38 +;; +(deftest test-string?-more + (are [x] (not (string? x)) + (new StringBuilder "abc") ;;; java.lang.StringBuilder + )) ;;; (new java.lang.StringBuffer "xyz"))) + +(def pred-val-table + (let [now (System.DateTime.) ;;; java.util.Date. + uuid (System.Guid.) ;;; java.util.UUID/randomUUID + barray (byte-array 0) + uri (System.Uri. "http://clojure.org")] ;;; java.net.URI. + [' + [identity int? pos-int? neg-int? nat-int? double? boolean? indexed? seqable? ident? uuid? decimal? inst? uri? bytes?] + [0 true false false true false false false false false false false false false false] + [1 true true false true false false false false false false false false false false] + [-1 true false true false false false false false false false false false false false] + [1.0 false false false false true false false false false false false false false false] + [true false false false false false true false false false false false false false false] + [[] false false false false false false true true false false false false false false] + [nil false false false false false false false true false false false false false false] + [{} false false false false false false false true false false false false false false] + [:foo false false false false false false false false true false false false false false] + ['foo false false false false false false false false true false false false false false] + [0.0M false false false false false false false false false false true false false false] + [0N false false false false false false false false false false false false false false] + [uuid false false false false false false false false false true false false false false] + [uri false false false false false false false false false false false false true false] + [now false false false false false false false false false false false true false false] + [barray false false false false false false false true false false false false false true]])) + +(deftest test-preds + (let [[preds & rows] pred-val-table] + (doseq [row rows] + (let [v (first row)] + (dotimes [i (count row)] + (is (= ((resolve (nth preds i)) v) (nth row i)) + (pr-str (list (nth preds i) v)))))))) + +;; Special double predicates + +(deftest test-double-preds + (is (NaN? ##NaN)) + (is (NaN? (Double/Parse "NaN"))) ;;; Double/parseDouble + (is (NaN? (Single/Parse "NaN"))) ;;; Float/parseFloat + (is (NaN? Single/NaN)) ;;; Float/NaN + (is (not (NaN? 5))) + (is (thrown? Exception (NaN? nil))) ;;; Throwable + (is (thrown? Exception (NaN? :xyz))) ;;; Throwable + + (is (infinite? ##Inf)) + (is (infinite? ##-Inf)) + (is (infinite? Double/PositiveInfinity)) ;;; POSITIVE_INFINITY + (is (infinite? Double/NegativeInfinity)) ;;; NEGATIVE_INFINITY + (is (infinite? Single/PositiveInfinity)) ;;; Float/POSITIVE_INFINITY + (is (infinite? Single/NegativeInfinity)) ;;; Float/NEGATIVE_INFINITY + (is (thrown? Exception (infinite? nil))) ;;; Throwable (is (thrown? Exception (infinite? :xyz)))) ;;; Throwable \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/printer.clj b/Clojure/Clojure.Tests/clojure/test_clojure/printer.clj index a500e065a..79acbb7b4 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/printer.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/printer.clj @@ -14,8 +14,8 @@ ;; Created 29 October 2008 (ns clojure.test-clojure.printer - (:use clojure.test - [clojure.test-helper :only [platform-newlines]]) + (:use clojure.test + [clojure.test-helper :only [platform-newlines]]) (:require [clojure.pprint :refer [pprint]])) (deftest print-length-empty-seq @@ -101,94 +101,94 @@ 1N 1M "hi")) - -(def ^{:foo :anything} var-with-meta 42) -(def ^{:type :anything} var-with-type 666) - -(deftest print-var - (are [x s] (= s (pr-str x)) - #'pr-str "#'clojure.core/pr-str" - #'var-with-meta "#'clojure.test-clojure.printer/var-with-meta" - #'var-with-type "#'clojure.test-clojure.printer/var-with-type")) - -(deftest print-meta - (are [x s] (binding [*print-meta* true] - (let [pstr (pr-str x)] - (and (.EndsWith pstr s) ;;; .endsWith - (.StartsWith pstr "^") ;;; .startsWith - (.Contains pstr (pr-str (meta x)))))) ;;; .contains - #'pr-str "#'clojure.core/pr-str" - #'var-with-meta "#'clojure.test-clojure.printer/var-with-meta" - #'var-with-type "#'clojure.test-clojure.printer/var-with-type")) - -#_(deftest print-throwable ;;; we don't get stack traces unelss an exception is thrown. - (binding [*data-readers* {'error identity}] - (are [e] (= (-> e Throwable->map) - (-> e pr-str read-string)) - (Exception. "heyo") - (Exception. "I can a throwable" ;;; Throwable - (Exception. "chain 1" - (Exception. "chan 2"))) - (ex-info "an ex-info" {:with "its" :data 29}) - (Exception. "outer" - (ex-info "an ex-info" {:with "data"} - (System.InvalidProgramException. "less outer" ;;; Error. - (ex-info "the root" - {:with "even" :more 'data}))))))) - -(deftest print-ns-maps - (are [m s-on pp-on s-off] - (and (= s-on (binding [*print-namespace-maps* true] (pr-str m))) - (= (platform-newlines pp-on) (binding [*print-namespace-maps* true] (with-out-str (pprint m)))) - (= s-off (binding [*print-namespace-maps* false] (pr-str m)))) - {} "{}" "{}\n" "{}" - {:a 1, :b 2} "{:a 1, :b 2}" "{:a 1, :b 2}\n" "{:a 1, :b 2}" - {:user/a 1} "#:user{:a 1}" "#:user{:a 1}\n" "{:user/a 1}" - {:user/a 1, :user/b 2} "#:user{:a 1, :b 2}" "#:user{:a 1, :b 2}\n" "{:user/a 1, :user/b 2}" - {:user/a 1, :b 2} "{:user/a 1, :b 2}" "{:user/a 1, :b 2}\n" "{:user/a 1, :b 2}" - {:user/a 1, 'user/b 2} "#:user{:a 1, b 2}" "#:user{:a 1, b 2}\n" "{:user/a 1, user/b 2}" - {:user/a 1, :foo/b 2} "{:user/a 1, :foo/b 2}" "{:user/a 1, :foo/b 2}\n" "{:user/a 1, :foo/b 2}" - - {:user/a 1, :user/b 2, 100 200} - "{:user/a 1, :user/b 2, 100 200}" - "{:user/a 1, :user/b 2, 100 200}\n" - "{:user/a 1, :user/b 2, 100 200}" - - ;; CLJ-2469 - (struct (create-struct :q/a :q/b :q/c) 1 2 3) - "#:q{:a 1, :b 2, :c 3}" - "#:q{:a 1, :b 2, :c 3}\n" - "{:q/a 1, :q/b 2, :q/c 3}" - - ;; CLJ-2537 - {:x.y/a {:rem 0}, :x.y/b {:rem 1}} - "#:x.y{:a {:rem 0}, :b {:rem 1}}" - "#:x.y{:a {:rem 0}, :b {:rem 1}}\n" - "{:x.y/a {:rem 0}, :x.y/b {:rem 1}}" - - (into (sorted-map-by (fn [k1 k2] - (when-not (every? qualified-ident? [k1 k2]) - (throw (Exception. (str "Invalid keys:" [k1 k2])))) ;;; RuntimeException. - (compare k1 k2)) - :x.y/a {:rem 0}, :x.y/b {:rem 1})) - "#:x.y{:a {:rem 0}, :b {:rem 1}}" - "#:x.y{:a {:rem 0}, :b {:rem 1}}\n" - "{:x.y/a {:rem 0}, :x.y/b {:rem 1}}" - - (sorted-map-by #(compare %2 %1) :k/a 1 :k/b 2 :k/c 3 :k/d 4 :k/e 5 :k/f 6 :k/g 7 :k/h 8 :k/i 9) - "#:k{:i 9, :h 8, :g 7, :f 6, :e 5, :d 4, :c 3, :b 2, :a 1}" - "#:k{:i 9, :h 8, :g 7, :f 6, :e 5, :d 4, :c 3, :b 2, :a 1}\n" - "{:k/i 9, :k/h 8, :k/g 7, :k/f 6, :k/e 5, :k/d 4, :k/c 3, :k/b 2, :k/a 1}") - - (let [date-map {:day 3, :date 31, :time 0, :month 11, :seconds 0, :year 69, :timezoneOffset 360, :hours 18, :minutes 0}] ;;; (bean (java.util.Date. 0)) -- don't have bean - (is (= (binding [*print-namespace-maps* true] (pr-str date-map)) - (binding [*print-namespace-maps* false] (pr-str date-map)))))) - -(deftest print-symbol-values - (are [s v] (= s (pr-str v)) - "##Inf" Double/PositiveInfinity ;;; Double/POSITIVE_INFINITY - "##-Inf" Double/NegativeInfinity ;;; Double/NEGATIVE_INFINITY - "##NaN" Double/NaN - "##Inf" Single/PositiveInfinity ;;; Float/POSITIVE_INFINITY - "##-Inf" Single/NegativeInfinity ;;; Float/NEGATIVE_INFINITY + +(def ^{:foo :anything} var-with-meta 42) +(def ^{:type :anything} var-with-type 666) + +(deftest print-var + (are [x s] (= s (pr-str x)) + #'pr-str "#'clojure.core/pr-str" + #'var-with-meta "#'clojure.test-clojure.printer/var-with-meta" + #'var-with-type "#'clojure.test-clojure.printer/var-with-type")) + +(deftest print-meta + (are [x s] (binding [*print-meta* true] + (let [pstr (pr-str x)] + (and (.EndsWith pstr s) ;;; .endsWith + (.StartsWith pstr "^") ;;; .startsWith + (.Contains pstr (pr-str (meta x)))))) ;;; .contains + #'pr-str "#'clojure.core/pr-str" + #'var-with-meta "#'clojure.test-clojure.printer/var-with-meta" + #'var-with-type "#'clojure.test-clojure.printer/var-with-type")) + +#_(deftest print-throwable ;;; we don't get stack traces unelss an exception is thrown. + (binding [*data-readers* {'error identity}] + (are [e] (= (-> e Throwable->map) + (-> e pr-str read-string)) + (Exception. "heyo") + (Exception. "I can a throwable" ;;; Throwable + (Exception. "chain 1" + (Exception. "chan 2"))) + (ex-info "an ex-info" {:with "its" :data 29}) + (Exception. "outer" + (ex-info "an ex-info" {:with "data"} + (System.InvalidProgramException. "less outer" ;;; Error. + (ex-info "the root" + {:with "even" :more 'data}))))))) + +(deftest print-ns-maps + (are [m s-on pp-on s-off] + (and (= s-on (binding [*print-namespace-maps* true] (pr-str m))) + (= (platform-newlines pp-on) (binding [*print-namespace-maps* true] (with-out-str (pprint m)))) + (= s-off (binding [*print-namespace-maps* false] (pr-str m)))) + {} "{}" "{}\n" "{}" + {:a 1, :b 2} "{:a 1, :b 2}" "{:a 1, :b 2}\n" "{:a 1, :b 2}" + {:user/a 1} "#:user{:a 1}" "#:user{:a 1}\n" "{:user/a 1}" + {:user/a 1, :user/b 2} "#:user{:a 1, :b 2}" "#:user{:a 1, :b 2}\n" "{:user/a 1, :user/b 2}" + {:user/a 1, :b 2} "{:user/a 1, :b 2}" "{:user/a 1, :b 2}\n" "{:user/a 1, :b 2}" + {:user/a 1, 'user/b 2} "#:user{:a 1, b 2}" "#:user{:a 1, b 2}\n" "{:user/a 1, user/b 2}" + {:user/a 1, :foo/b 2} "{:user/a 1, :foo/b 2}" "{:user/a 1, :foo/b 2}\n" "{:user/a 1, :foo/b 2}" + + {:user/a 1, :user/b 2, 100 200} + "{:user/a 1, :user/b 2, 100 200}" + "{:user/a 1, :user/b 2, 100 200}\n" + "{:user/a 1, :user/b 2, 100 200}" + + ;; CLJ-2469 + (struct (create-struct :q/a :q/b :q/c) 1 2 3) + "#:q{:a 1, :b 2, :c 3}" + "#:q{:a 1, :b 2, :c 3}\n" + "{:q/a 1, :q/b 2, :q/c 3}" + + ;; CLJ-2537 + {:x.y/a {:rem 0}, :x.y/b {:rem 1}} + "#:x.y{:a {:rem 0}, :b {:rem 1}}" + "#:x.y{:a {:rem 0}, :b {:rem 1}}\n" + "{:x.y/a {:rem 0}, :x.y/b {:rem 1}}" + + (into (sorted-map-by (fn [k1 k2] + (when-not (every? qualified-ident? [k1 k2]) + (throw (Exception. (str "Invalid keys:" [k1 k2])))) ;;; RuntimeException. + (compare k1 k2)) + :x.y/a {:rem 0}, :x.y/b {:rem 1})) + "#:x.y{:a {:rem 0}, :b {:rem 1}}" + "#:x.y{:a {:rem 0}, :b {:rem 1}}\n" + "{:x.y/a {:rem 0}, :x.y/b {:rem 1}}" + + (sorted-map-by #(compare %2 %1) :k/a 1 :k/b 2 :k/c 3 :k/d 4 :k/e 5 :k/f 6 :k/g 7 :k/h 8 :k/i 9) + "#:k{:i 9, :h 8, :g 7, :f 6, :e 5, :d 4, :c 3, :b 2, :a 1}" + "#:k{:i 9, :h 8, :g 7, :f 6, :e 5, :d 4, :c 3, :b 2, :a 1}\n" + "{:k/i 9, :k/h 8, :k/g 7, :k/f 6, :k/e 5, :k/d 4, :k/c 3, :k/b 2, :k/a 1}") + + (let [date-map {:day 3, :date 31, :time 0, :month 11, :seconds 0, :year 69, :timezoneOffset 360, :hours 18, :minutes 0}] ;;; (bean (java.util.Date. 0)) -- don't have bean + (is (= (binding [*print-namespace-maps* true] (pr-str date-map)) + (binding [*print-namespace-maps* false] (pr-str date-map)))))) + +(deftest print-symbol-values + (are [s v] (= s (pr-str v)) + "##Inf" Double/PositiveInfinity ;;; Double/POSITIVE_INFINITY + "##-Inf" Double/NegativeInfinity ;;; Double/NEGATIVE_INFINITY + "##NaN" Double/NaN + "##Inf" Single/PositiveInfinity ;;; Float/POSITIVE_INFINITY + "##-Inf" Single/NegativeInfinity ;;; Float/NEGATIVE_INFINITY "##NaN" Single/NaN)) ;;; Float/NaN \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/protocols.clj b/Clojure/Clojure.Tests/clojure/test_clojure/protocols.clj index 38ed28abd..9bd792509 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/protocols.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/protocols.clj @@ -47,12 +47,12 @@ (deftest protocols-test (testing "protocol fns have useful metadata" (let [common-meta {:ns (find-ns 'clojure.test-clojure.protocols.examples) - :protocol #'ExampleProtocol :tag nil}] + :protocol #'ExampleProtocol :tag nil}] (are [m f] (= (merge common-meta m) (meta (var f))) - {:name 'foo :arglists '([a]) :doc "method with one arg"} foo - {:name 'bar :arglists '([a b]) :doc "method with two args"} bar - {:name 'baz :arglists '([a] [a b]) :doc "method with multiple arities" :tag 'System.String} baz ;;; 'java.lang.String + {:name 'foo :arglists '([a]) :doc "method with one arg"} foo + {:name 'bar :arglists '([a b]) :doc "method with two args"} bar + {:name 'baz :arglists '([a] [a b]) :doc "method with multiple arities" :tag 'System.String} baz ;;; 'java.lang.String {:name 'with-quux :arglists '([a]) :doc "method name with a hyphen"} with-quux))) (testing "protocol fns throw IllegalArgumentException if no impl matches" (is (thrown-with-msg? @@ -71,14 +71,14 @@ (baz [a b] "two-arg baz!"))] (is (= "two-arg baz!" (baz obj nil))) (is (thrown? NotImplementedException (baz obj))))) ;;; AbstractMethodError - (testing "error conditions checked when defining protocols" - (is (thrown-with-cause-msg? - Exception - #"Definition of function m in protocol badprotdef must take at least one arg." - (eval '(defprotocol badprotdef (m []))))) - (is (thrown-with-cause-msg? - Exception - #"Function m in protocol badprotdef was redefined. Specify all arities in single definition." + (testing "error conditions checked when defining protocols" + (is (thrown-with-cause-msg? + Exception + #"Definition of function m in protocol badprotdef must take at least one arg." + (eval '(defprotocol badprotdef (m []))))) + (is (thrown-with-cause-msg? + Exception + #"Function m in protocol badprotdef was redefined. Specify all arities in single definition." (eval '(defprotocol badprotdef (m [this arg]) (m [this arg1 arg2])))))) (testing "you can redefine a protocol with different methods" (eval '(defprotocol Elusive (old-method [x]))) @@ -129,10 +129,10 @@ {:foo (fn [this] (str "widget " (.name this)))}) (is (= "widget z" (foo (ExtendTestWidget. "z")))))) -(deftest record-marker-interfaces - (testing "record? and type? return expected result for IRecord and IType" - (let [r (TestRecord. 1 2)] - (is (record? r))))) +(deftest record-marker-interfaces + (testing "record? and type? return expected result for IRecord and IType" + (let [r (TestRecord. 1 2)] + (is (record? r))))) (deftest illegal-extending (testing "you cannot extend a protocol to a type that implements the protocol inline" @@ -312,7 +312,7 @@ (is (nil? (:tag (meta (tbh 2))))))))) (defrecord RecordToTestFactories [a b c]) -(defrecord RecordToTestA [a]) +(defrecord RecordToTestA [a]) (defrecord RecordToTestB [b]) (defrecord RecordToTestHugeFactories [a b c d e f g h i j k l m n o p q r s t u v w x y z]) (defrecord RecordToTestDegenerateFactories []) @@ -321,49 +321,49 @@ (testing "if the definition of a defrecord generates the appropriate factory functions" (let [r (RecordToTestFactories. 1 2 3) r-n (RecordToTestFactories. nil nil nil) - huge (RecordToTestHugeFactories. 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26) - r-a (map->RecordToTestA {:a 1 :b 2}) - r-b (map->RecordToTestB {:a 1 :b 2}) + huge (RecordToTestHugeFactories. 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26) + r-a (map->RecordToTestA {:a 1 :b 2}) + r-b (map->RecordToTestB {:a 1 :b 2}) r-d (RecordToTestDegenerateFactories.)] (testing "that a record created with the ctor equals one by the positional factory fn" (is (= r (->RecordToTestFactories 1 2 3))) (is (= huge (->RecordToTestHugeFactories 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26)))) (testing "that a record created with the ctor equals one by the map-> factory fn" (is (= r (map->RecordToTestFactories {:a 1 :b 2 :c 3}))) - (is (= r-n (map->RecordToTestFactories {}))) - (is (= r (map->RecordToTestFactories (map->RecordToTestFactories {:a 1 :b 2 :c 3})))) - (is (= r-n (map->RecordToTestFactories (map->RecordToTestFactories {})))) - (is (= r-d (map->RecordToTestDegenerateFactories {}))) - (is (= r-d (map->RecordToTestDegenerateFactories - (map->RecordToTestDegenerateFactories {}))))) - (testing "that ext maps work correctly" - (is (= (assoc r :xxx 42) (map->RecordToTestFactories {:a 1 :b 2 :c 3 :xxx 42}))) - (is (= (assoc r :xxx 42) (map->RecordToTestFactories (map->RecordToTestFactories - {:a 1 :b 2 :c 3 :xxx 42})))) - (is (= (assoc r-n :xxx 42) (map->RecordToTestFactories {:xxx 42}))) - (is (= (assoc r-n :xxx 42) (map->RecordToTestFactories (map->RecordToTestFactories - {:xxx 42})))) - (is (= (assoc r-d :xxx 42) (map->RecordToTestDegenerateFactories {:xxx 42}))) - (is (= (assoc r-d :xxx 42) (map->RecordToTestDegenerateFactories - (map->RecordToTestDegenerateFactories {:xxx 42}))))) - (testing "record equality" - (is (not= r-a r-b)) - (is (= (into {} r-a) (into {} r-b))) - (is (not= (into {} r-a) r-b)) - (is (= (map->RecordToTestA {:a 1 :b 2}) - (map->RecordToTestA (map->RecordToTestB {:a 1 :b 2})))) - (is (= (map->RecordToTestA {:a 1 :b 2 :c 3}) - (map->RecordToTestA (map->RecordToTestB {:a 1 :b 2 :c 3})))) - (is (= (map->RecordToTestA {:a 1 :d 4}) - (map->RecordToTestA (map->RecordToTestDegenerateFactories {:a 1 :d 4})))) - (is (= r-n (map->RecordToTestFactories (System.Collections.Hashtable.)))) ;;; (java.util.HashMap.) - (is (= r-a (map->RecordToTestA (into {} r-b)))) - (is (= r-a (map->RecordToTestA r-b))) - (is (not= r-a (map->RecordToTestB r-a))) - (is (= r (assoc r-n :a 1 :b 2 :c 3))) - (is (not= r-a (assoc r-n :a 1 :b 2))) - (is (not= (assoc r-b :c 3 :d 4) (assoc r-n :a 1 :b 2 :c 3 :d 4))) - (is (= (into {} (assoc r-b :c 3 :d 4)) (into {} (assoc r-n :a 1 :b 2 :c 3 :d 4)))) + (is (= r-n (map->RecordToTestFactories {}))) + (is (= r (map->RecordToTestFactories (map->RecordToTestFactories {:a 1 :b 2 :c 3})))) + (is (= r-n (map->RecordToTestFactories (map->RecordToTestFactories {})))) + (is (= r-d (map->RecordToTestDegenerateFactories {}))) + (is (= r-d (map->RecordToTestDegenerateFactories + (map->RecordToTestDegenerateFactories {}))))) + (testing "that ext maps work correctly" + (is (= (assoc r :xxx 42) (map->RecordToTestFactories {:a 1 :b 2 :c 3 :xxx 42}))) + (is (= (assoc r :xxx 42) (map->RecordToTestFactories (map->RecordToTestFactories + {:a 1 :b 2 :c 3 :xxx 42})))) + (is (= (assoc r-n :xxx 42) (map->RecordToTestFactories {:xxx 42}))) + (is (= (assoc r-n :xxx 42) (map->RecordToTestFactories (map->RecordToTestFactories + {:xxx 42})))) + (is (= (assoc r-d :xxx 42) (map->RecordToTestDegenerateFactories {:xxx 42}))) + (is (= (assoc r-d :xxx 42) (map->RecordToTestDegenerateFactories + (map->RecordToTestDegenerateFactories {:xxx 42}))))) + (testing "record equality" + (is (not= r-a r-b)) + (is (= (into {} r-a) (into {} r-b))) + (is (not= (into {} r-a) r-b)) + (is (= (map->RecordToTestA {:a 1 :b 2}) + (map->RecordToTestA (map->RecordToTestB {:a 1 :b 2})))) + (is (= (map->RecordToTestA {:a 1 :b 2 :c 3}) + (map->RecordToTestA (map->RecordToTestB {:a 1 :b 2 :c 3})))) + (is (= (map->RecordToTestA {:a 1 :d 4}) + (map->RecordToTestA (map->RecordToTestDegenerateFactories {:a 1 :d 4})))) + (is (= r-n (map->RecordToTestFactories (System.Collections.Hashtable.)))) ;;; (java.util.HashMap.) + (is (= r-a (map->RecordToTestA (into {} r-b)))) + (is (= r-a (map->RecordToTestA r-b))) + (is (not= r-a (map->RecordToTestB r-a))) + (is (= r (assoc r-n :a 1 :b 2 :c 3))) + (is (not= r-a (assoc r-n :a 1 :b 2))) + (is (not= (assoc r-b :c 3 :d 4) (assoc r-n :a 1 :b 2 :c 3 :d 4))) + (is (= (into {} (assoc r-b :c 3 :d 4)) (into {} (assoc r-n :a 1 :b 2 :c 3 :d 4)))) (is (= (assoc r :d 4) (assoc r-n :a 1 :b 2 :c 3 :d 4)))) (testing "that factory functions have docstrings" ;; just test non-nil to avoid overspecifiying what's in the docstring @@ -490,9 +490,9 @@ (is (thrown? Exception (read-string "(let [s \"en\"] #System.Globalization.CultureInfo[(str 'en)])"))) ;;; java.util.Locale (is (thrown? Exception (read-string "#clojure.test_clojure.protocols.RecordToTestLiterals{(keyword \"a\") 42}")))) - (testing "that ctors can have whitespace after class name but before {" - (is (= (RecordToTestLiterals. 42) - (read-string "#clojure.test_clojure.protocols.RecordToTestLiterals {:a 42}")))) + (testing "that ctors can have whitespace after class name but before {" + (is (= (RecordToTestLiterals. 42) + (read-string "#clojure.test_clojure.protocols.RecordToTestLiterals {:a 42}")))) (testing "that the correct errors are thrown with malformed literals" (is (thrown-with-msg? @@ -613,8 +613,8 @@ (bar [this o] o) (baz [this] 1) (baz [this o] 2))] - (is (= :foo (.bar r :foo))) - (is (= 1 (.baz r))) + (is (= :foo (.bar r :foo))) + (is (= 1 (.baz r))) (is (= 2 (.baz r nil))))) (testing "destructuring in method def" (let [r (reify @@ -665,44 +665,44 @@ (is (= :foo (sqtp :foo)))) -(defprotocol Dasherizer - (-do-dashed [this])) -(deftype Dashed [] - Dasherizer - (-do-dashed [this] 10)) - -(deftest test-leading-dashes - (is (= 10 (-do-dashed (Dashed.)))) - (is (= [10] (map -do-dashed [(Dashed.)])))) - -;; see CLJ-1879 - -(deftest test-base-reduce-kv - (is (= {1 :a 2 :b} - (reduce-kv #(assoc %1 %3 %2) - {} - (seq {:a 1 :b 2}))))) - - -(defn aget-long-hinted ^long [x] (aget (longs-hinted x) 0)) - -(deftest test-longs-hinted-proto - (is (= 1 - (aget-long-hinted - (reify LongsHintedProto - (longs-hinted [_] (long-array [1]))))))) - -;; CLJ-1180 - resolve type hints in protocol methods - -(import 'clojure.lang.ISeq) -(defprotocol P - (^clojure.lang.ISeq f [_])) ;;; added the 'clojure.lang.' -- not sure why it is needed if ClojureJVM does not need it. -(ns clojure.test-clojure.protocols.other - (:use clojure.test)) -(defn cf [val] - (let [aseq (clojure.test-clojure.protocols/f val)] - (count aseq))) -(extend-protocol clojure.test-clojure.protocols/P String - (f [s] (seq s))) -(deftest test-resolve-type-hints-in-protocol-methods +(defprotocol Dasherizer + (-do-dashed [this])) +(deftype Dashed [] + Dasherizer + (-do-dashed [this] 10)) + +(deftest test-leading-dashes + (is (= 10 (-do-dashed (Dashed.)))) + (is (= [10] (map -do-dashed [(Dashed.)])))) + +;; see CLJ-1879 + +(deftest test-base-reduce-kv + (is (= {1 :a 2 :b} + (reduce-kv #(assoc %1 %3 %2) + {} + (seq {:a 1 :b 2}))))) + + +(defn aget-long-hinted ^long [x] (aget (longs-hinted x) 0)) + +(deftest test-longs-hinted-proto + (is (= 1 + (aget-long-hinted + (reify LongsHintedProto + (longs-hinted [_] (long-array [1]))))))) + +;; CLJ-1180 - resolve type hints in protocol methods + +(import 'clojure.lang.ISeq) +(defprotocol P + (^clojure.lang.ISeq f [_])) ;;; added the 'clojure.lang.' -- not sure why it is needed if ClojureJVM does not need it. +(ns clojure.test-clojure.protocols.other + (:use clojure.test)) +(defn cf [val] + (let [aseq (clojure.test-clojure.protocols/f val)] + (count aseq))) +(extend-protocol clojure.test-clojure.protocols/P String + (f [s] (seq s))) +(deftest test-resolve-type-hints-in-protocol-methods (is (= 4 (clojure.test-clojure.protocols/f "test")))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/reader.cljc b/Clojure/Clojure.Tests/clojure/test_clojure/reader.cljc index 29564314f..e8c748a49 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/reader.cljc +++ b/Clojure/Clojure.Tests/clojure/test_clojure/reader.cljc @@ -1,782 +1,782 @@ -; 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: Stephen C. Gilardi - -;; -;; Tests for the Clojure functions documented at the URL: -;; -;; http://clojure.org/Reader -;; -;; scgilardi (gmail) -;; Created 22 October 2008 - -(ns clojure.test-clojure.reader - (:use clojure.test) - (:use [clojure.instant :only [read-instant-datetime ;;; read-instant-date - read-instant-datetimeoffset ;;; read-instant-calendar - ]]) ;;; read-instant-timestamp - (:require clojure.walk - [clojure.edn :as edn] - [clojure.test.generative :refer (defspec)] - [clojure.test-clojure.generators :as cgen] - [clojure.edn :as edn]) - (:import [clojure.lang BigInt Ratio] - System.IO.Path System.IO.FileInfo - )) ;;; java.util.TimeZone - -;; Symbols - -(deftest Symbols - (is (= 'abc (symbol "abc"))) - (is (= '*+!-_? (symbol "*+!-_?"))) - (is (= 'abc:def:ghi (symbol "abc:def:ghi"))) - (is (= 'abc/def (symbol "abc" "def"))) - (is (= 'abc.def/ghi (symbol "abc.def" "ghi"))) - (is (= 'abc/def.ghi (symbol "abc" "def.ghi"))) - (is (= 'abc:def/ghi:jkl.mno (symbol "abc:def" "ghi:jkl.mno"))) - (is (instance? clojure.lang.Symbol 'alphabet)) - ) - -;; Literals - -(deftest Literals - ; 'nil 'false 'true are reserved by Clojure and are not symbols - (is (= 'nil nil)) - (is (= 'false false)) - (is (= 'true true)) ) - -;; Strings - -(defn temp-file - [& ignore] ;;; [prefix suffix] - (FileInfo. ;;; (doto (File/createTempFile prefix suffix) - (Path/GetTempFileName))) ;;; (.deleteOnExit))) - -(defn read-from - [source file form] - (if (= :string source) - (read-string form) - (do - (spit file form :file-mode System.IO.FileMode/Truncate) - (let [v (load-file (str file))] (.Delete file) v)))) ;;; (load-file (str file))))) - -(defn code-units - [s] - (and (instance? String s) (map int s))) - -(deftest Strings - (is (= "abcde" (str \a \b \c \d \e))) - (is (= "abc - def" (str \a \b \c \newline \space \space \d \e \f))) - (let [f (temp-file "clojure.core-reader" "test")] - (doseq [source [:string :file]] - (testing (str "Valid string literals read from " (name source)) - (are [x form] (= x (code-units - (read-from source (temp-file) (str "\"" form "\"")))) ;;; f => (temp-file) - [] "" - [34] "\\\"" - [10] "\\n" - - [0] "\\0" - [0] "\\000" - [3] "\\3" - [3] "\\03" - [3] "\\003" - [0 51] "\\0003" - [3 48] "\\0030" - [0377] "\\377" - [0 56] "\\0008" - - [0] "\\u0000" - [0xd7ff] "\\ud7ff" - [0xd800] "\\ud800" - [0xdfff] "\\udfff" - [0xe000] "\\ue000" - [0xffff] "\\uffff" - [4 49] "\\u00041")) - (testing (str "Errors reading string literals from " (name source)) - (are [err msg form] (thrown-with-cause-msg? err msg - (read-from source f (str "\"" form "\""))) - Exception #"EOF while reading string" "\\" - Exception #"Unsupported escape character: \\o" "\\o" - - Exception #"Octal escape sequence must be in range \[0, 377\]" "\\400" - Exception #"Invalid digit: 8" "\\8" - Exception #"Invalid digit: 8" "\\8000" - Exception #"Invalid digit: 8" "\\0800" - Exception #"Invalid digit: 8" "\\0080" - Exception #"Invalid digit: a" "\\2and" - - Exception #"Invalid unicode escape: \\u" "\\u" - Exception #"Invalid unicode escape: \\ug" "\\ug" - Exception #"Invalid unicode escape: \\ug" "\\ug000" - Exception #"Invalid character length: 1, should be: 4" "\\u0" - Exception #"Invalid character length: 3, should be: 4" "\\u004" - Exception #"Invalid digit: g" "\\u004g"))))) - -;; Numbers - -(deftest Numbers - - ; Read Integer - (is (instance? Int64 2147483647)) ;;; Long - (is (instance? Int64 +1)) - (is (instance? Int64 1)) - (is (instance? Int64 +0)) - (is (instance? Int64 0)) - (is (instance? Int64 -0)) - (is (instance? Int64 -1)) - (is (instance? Int64 -2147483648)) - - ; Read Long - (is (instance? Int64 2147483648)) ;;; Long - (is (instance? Int64 -2147483649)) - (is (instance? Int64 9223372036854775807)) - (is (instance? Int64 -9223372036854775808)) - - ;; Numeric constants of different types don't wash out. Regression fixed in - ;; r1157. Previously the compiler saw 0 and 0.0 as the same constant and - ;; caused the sequence to be built of Doubles. - (let [x 0.0] - (let [sequence (loop [i 0 l '()] - (if (< i 5) - (recur (inc i) (conj l i)) - l))] - (is (= [4 3 2 1 0] sequence)) - (is (every? #(instance? Int64 %) ;;; Long - sequence)))) - - ; Read BigInteger - (is (instance? BigInt 9223372036854775808)) - (is (instance? BigInt -9223372036854775809)) - (is (instance? BigInt 10000000000000000000000000000000000000000000000000)) - (is (instance? BigInt -10000000000000000000000000000000000000000000000000)) - - ; Read Double - (is (instance? Double +1.0e+1)) - (is (instance? Double +1.e+1)) - (is (instance? Double +1e+1)) - - (is (instance? Double +1.0e1)) - (is (instance? Double +1.e1)) - (is (instance? Double +1e1)) - - (is (instance? Double +1.0e-1)) - (is (instance? Double +1.e-1)) - (is (instance? Double +1e-1)) - - (is (instance? Double 1.0e+1)) - (is (instance? Double 1.e+1)) - (is (instance? Double 1e+1)) - - (is (instance? Double 1.0e1)) - (is (instance? Double 1.e1)) - (is (instance? Double 1e1)) - - (is (instance? Double 1.0e-1)) - (is (instance? Double 1.e-1)) - (is (instance? Double 1e-1)) - - (is (instance? Double -1.0e+1)) - (is (instance? Double -1.e+1)) - (is (instance? Double -1e+1)) - - (is (instance? Double -1.0e1)) - (is (instance? Double -1.e1)) - (is (instance? Double -1e1)) - - (is (instance? Double -1.0e-1)) - (is (instance? Double -1.e-1)) - (is (instance? Double -1e-1)) - - (is (instance? Double +1.0)) - (is (instance? Double +1.)) - - (is (instance? Double 1.0)) - (is (instance? Double 1.)) - - (is (instance? Double +0.0)) - (is (instance? Double +0.)) - - (is (instance? Double 0.0)) - (is (instance? Double 0.)) - - (is (instance? Double -0.0)) - (is (instance? Double -0.)) - - (is (instance? Double -1.0)) - (is (instance? Double -1.)) - - (is (= Double/PositiveInfinity ##Inf)) ;;; Double/POSITIVE_INFINITY - (is (= Double/NegativeInfinity ##-Inf)) ;;; Double/NEGATIVE_INFINITY - (is (and (instance? Double ##NaN) (Double/IsNaN ##NaN))) ;;; .isNaN - - ; Read BigDecimal - (is (instance? BigDecimal 9223372036854775808M)) - (is (instance? BigDecimal -9223372036854775809M)) - (is (instance? BigDecimal 2147483647M)) - (is (instance? BigDecimal +1M)) - (is (instance? BigDecimal 1M)) - (is (instance? BigDecimal +0M)) - (is (instance? BigDecimal 0M)) - (is (instance? BigDecimal -0M)) - (is (instance? BigDecimal -1M)) - (is (instance? BigDecimal -2147483648M)) - - (is (instance? BigDecimal +1.0e+1M)) - (is (instance? BigDecimal +1.e+1M)) - (is (instance? BigDecimal +1e+1M)) - - (is (instance? BigDecimal +1.0e1M)) - (is (instance? BigDecimal +1.e1M)) - (is (instance? BigDecimal +1e1M)) - - (is (instance? BigDecimal +1.0e-1M)) - (is (instance? BigDecimal +1.e-1M)) - (is (instance? BigDecimal +1e-1M)) - - (is (instance? BigDecimal 1.0e+1M)) - (is (instance? BigDecimal 1.e+1M)) - (is (instance? BigDecimal 1e+1M)) - - (is (instance? BigDecimal 1.0e1M)) - (is (instance? BigDecimal 1.e1M)) - (is (instance? BigDecimal 1e1M)) - - (is (instance? BigDecimal 1.0e-1M)) - (is (instance? BigDecimal 1.e-1M)) - (is (instance? BigDecimal 1e-1M)) - - (is (instance? BigDecimal -1.0e+1M)) - (is (instance? BigDecimal -1.e+1M)) - (is (instance? BigDecimal -1e+1M)) - - (is (instance? BigDecimal -1.0e1M)) - (is (instance? BigDecimal -1.e1M)) - (is (instance? BigDecimal -1e1M)) - - (is (instance? BigDecimal -1.0e-1M)) - (is (instance? BigDecimal -1.e-1M)) - (is (instance? BigDecimal -1e-1M)) - - (is (instance? BigDecimal +1.0M)) - (is (instance? BigDecimal +1.M)) - - (is (instance? BigDecimal 1.0M)) - (is (instance? BigDecimal 1.M)) - - (is (instance? BigDecimal +0.0M)) - (is (instance? BigDecimal +0.M)) - - (is (instance? BigDecimal 0.0M)) - (is (instance? BigDecimal 0.M)) - - (is (instance? BigDecimal -0.0M)) - (is (instance? BigDecimal -0.M)) - - (is (instance? BigDecimal -1.0M)) - (is (instance? BigDecimal -1.M)) - - (is (instance? Ratio 1/2)) - (is (instance? Ratio -1/2)) - (is (instance? Ratio +1/2)) -) - -;; Characters - -(deftest t-Characters - (let [f (temp-file "clojure.core-reader" "test")] - (doseq [source [:string :file]] - (testing (str "Valid char literals read from " (name source)) - (are [x form] (= x (read-from source (temp-file) form)) ;;; f -> (temp-file) - (first "o") "\\o" - (char 0) "\\o0" - (char 0) "\\o000" - (char 047) "\\o47" - (char 0377) "\\o377" - - (first "u") "\\u" - (first "A") "\\u0041" - (char 0) "\\u0000" - (char 0xd7ff) "\\ud7ff" - (char 0xe000) "\\ue000" - (char 0xffff) "\\uffff")) - (testing (str "Errors reading char literals from " (name source)) - (are [err msg form] (thrown-with-cause-msg? err msg (read-from source f form)) - Exception #"EOF while reading character" "\\" - Exception #"Unsupported character: \\00" "\\00" - Exception #"Unsupported character: \\0009" "\\0009" - - Exception #"Invalid digit: 8" "\\o378" - Exception #"Octal escape sequence must be in range \[0, 377\]" "\\o400" - Exception #"Invalid digit: 8" "\\o800" - Exception #"Invalid digit: a" "\\oand" - Exception #"Invalid octal escape sequence length: 4" "\\o0470" - - Exception #"Invalid unicode character: \\u0" "\\u0" - Exception #"Invalid unicode character: \\ug" "\\ug" - Exception #"Invalid unicode character: \\u000" "\\u000" - Exception #"Invalid character constant: \\ud800" "\\ud800" - Exception #"Invalid character constant: \\udfff" "\\udfff" - Exception #"Invalid unicode character: \\u004" "\\u004" - Exception #"Invalid unicode character: \\u00041" "\\u00041" - Exception #"Invalid digit: g" "\\u004g"))))) - -;; nil - -(deftest t-nil) - -;; Booleans - -(deftest t-Booleans) - -;; Keywords - -(deftest t-Keywords - (is (= :abc (keyword "abc"))) - (is (= :abc (keyword 'abc))) - (is (= :*+!-_? (keyword "*+!-_?"))) - (is (= :abc:def:ghi (keyword "abc:def:ghi"))) - (is (= :abc/def (keyword "abc" "def"))) - (is (= :abc/def (keyword 'abc/def))) - (is (= :abc.def/ghi (keyword "abc.def" "ghi"))) - (is (= :abc/def.ghi (keyword "abc" "def.ghi"))) - (is (= :abc:def/ghi:jkl.mno (keyword "abc:def" "ghi:jkl.mno"))) - (is (instance? clojure.lang.Keyword :alphabet)) - ) - -(deftest reading-keywords - (are [x y] (= x (binding [*ns* (the-ns 'user)] (read-string y))) - :foo ":foo" - :foo/bar ":foo/bar" - :user/foo "::foo") - (are [err msg form] (thrown-with-msg? err msg (read-string form)) - Exception #"Invalid token: foo:" "foo:" - Exception #"Invalid token: :bar/" ":bar/" - Exception #"Invalid token: ::does.not/exist" "::does.not/exist")) -;; Lists - -(deftest t-Lists) - -;; Vectors - -(deftest t-Vectors) - -;; Maps - -(deftest t-Maps) - -;; Sets - -(deftest t-Sets) - -;; Macro characters - -;; Quote (') - -(deftest t-Quote) - -;; Character (\) - -(deftest t-Character) - -;; Comment (;) - -(deftest t-Comment) - -;; Deref (@) - -(deftest t-Deref) - -;; Dispatch (#) - -;; #{} - see Sets above - -;; Regex patterns (#"pattern") - -(deftest t-Regex) - -;; Metadata (^ or #^ (deprecated)) - -(deftest t-line-column-numbers - (let [code "(ns reader-metadata-test - (:require [clojure.java.io - :refer (resource reader)])) - -(let [a 5] - ^:added-metadata - (defn add-5 - [x] - (reduce + x (range a))))" - stream (clojure.lang.LineNumberingTextReader. ;;; clojure.lang.LineNumberingPushbackReader. - (System.IO.StringReader. code)) ;;; java.io.StringReader. - top-levels (take-while identity (repeatedly #(read stream false nil))) - expected-metadata '{ns {:line 1, :column 1} - :require {:line 2, :column 3} - resource {:line 3, :column 21} - let {:line 5, :column 1} - defn {:line 6, :column 3 :added-metadata true} - reduce {:line 9, :column 5} - range {:line 9, :column 17}} - verified-forms (atom 0)] - (doseq [form top-levels] - (clojure.walk/postwalk - #(when (list? %) - (is (= (expected-metadata (first %)) - (meta %))) - (is (->> (meta %) - vals - (filter number?) - (every? (partial instance? Int32)))) ;;; Integer - (swap! verified-forms inc)) - form)) - ;; sanity check against e.g. reading returning () - (is (= (count expected-metadata) @verified-forms)))) - -(deftest set-line-number - (let [r (clojure.lang.LineNumberingTextReader. *in*)] ;;; LineNumberingPushbackReader - (.set_LineNumber r 100) ;;; .setLineNumber - (is (= 100 (.get_LineNumber r))))) ;;; .getLineNumber - -(deftest t-Metadata - (is (= (meta '^:static ^:awesome ^{:static false :bar :baz} sym) {:awesome true, :bar :baz, :static true}))) - -;; Var-quote (#') - -(deftest t-Var-quote) - -;; Anonymous function literal (#()) - -(deftest t-Anonymouns-function-literal) - -;; Syntax-quote (`, note, the "backquote" character), Unquote (~) and -;; Unquote-splicing (~@) - -(deftest t-Syntax-quote - (are [x y] (= x y) - `() () ; was NPE before SVN r1337 - )) - -;; (read) -;; (read stream) -;; (read stream eof-is-error) -;; (read stream eof-is-error eof-value) -;; (read stream eof-is-error eof-value is-recursive) - -(deftest t-read) - -(deftest division - (is (= clojure.core// /)) - (binding [*ns* *ns*] - (eval '(do (ns foo - (:require [clojure.core :as bar]) - (:use [clojure.test])) - (is (= clojure.core// bar//)))))) - -(deftest Instants - (testing "Instants are read as System.DateTime by default" ;;; java.util.Date - (is (= System.DateTime (class #inst "2010-11-12T13:14:15.666")))) ;;; java.util.Date - (let [s "#inst \"2010-11-12T13:14:15.666-06:00\""] - (binding [*data-readers* {'inst read-instant-datetime}] ;;; read-instant-date - (testing "read-instant-datetime produces System.DateTime" ;;; "read-instant-date produces java.util.Date" - (is (= System.DateTime (class (read-string s))))) ;;; java.util.Date - (testing "System.DateTime instants round-trips" ;;; java.util.Date - (is (= (-> s read-string) - (-> s read-string pr-str read-string)))) - (testing "java.util.Date instants round-trip throughout the year" - (doseq [month (range 1 13) day (range 1 29) hour (range 1 23)] - (let [s (format "#inst \"2010-%02d-%02dT%02d:14:15.666-06:00\"" month day hour)] - (is (= (-> s read-string) - (-> s read-string pr-str read-string)))))) - ;;;(testing "java.util.Date handling DST in time zones" ;;; not sure how to do this - ;;; (let [dtz (TimeZone/getDefault)] - ;;; (try - ;;; ;; A timezone with DST in effect during 2010-11-12 - ;;; (TimeZone/setDefault (TimeZone/getTimeZone "Australia/Sydney")) - ;;; (is (= (-> s read-string) - ;;; (-> s read-string pr-str read-string))) - ;;; (finally (TimeZone/setDefault dtz))))) - (testing "java.util.Date should always print in UTC" - (let [d (read-string s) - pstr (print-str d) - len (.Length pstr)] ;;;.length - (is (= (subs pstr (- len 7)) "-00:00\""))))) - (binding [*data-readers* {'inst read-instant-datetimeoffset}] ;;; read-instant-calendar - (testing "read-instant-calendar produces System.DateTimeOffset" ;;; java.util.Calendar - (is (instance? System.DateTimeOffset (read-string s)))) ;;; java.util.Calendar - (testing "System.DateTimeOffset round-trips" ;;; java.util.Calendar - (is (= (-> s read-string) - (-> s read-string pr-str read-string)))) - (testing "System.DateTimeOffset remembers timezone in literal" ;;; java.util.Calendar - (is (= "#inst \"2010-11-12T13:14:15.666-06:00\"" - (-> s read-string pr-str))) - (is (= (-> s read-string) - (-> s read-string pr-str read-string)))) - (testing "System.DateTimeOffset preserves milliseconds" ;;; java.util.Calendar - (is (= 666 (-> s read-string - (.Millisecond))))))) ;;; (.get java.util.Calendar/MILLISECOND))))))) - ;;;(let [s "#inst \"2010-11-12T13:14:15.123456789\"" - ;;; s2 "#inst \"2010-11-12T13:14:15.123\"" - ;;; s3 "#inst \"2010-11-12T13:14:15.123456789123\""] - ;;; (binding [*data-readers* {'inst read-instant-timestamp}] - ;;; (testing "read-instant-timestamp produces java.sql.Timestamp" - ;;; (is (= java.sql.Timestamp (class (read-string s))))) - ;;; (testing "java.sql.Timestamp preserves nanoseconds" - ;;; (is (= 123456789 (-> s read-string .getNanos))) - ;;; (is (= 123456789 (-> s read-string pr-str read-string .getNanos))) - ;;; ;; truncate at nanos for s3 - ;;; (is (= 123456789 (-> s3 read-string pr-str read-string .getNanos)))) - ;;; (testing "java.sql.Timestamp should compare nanos" - ;;; (is (= (read-string s) (read-string s3))) - ;;; (is (not= (read-string s) (read-string s2))))) - ;;; (binding [*data-readers* {'inst read-instant-date}] - ;;; (testing "read-instant-date should truncate at milliseconds" - ;;; (is (= (read-string s) (read-string s2) (read-string s3)))))) - ;;;(let [s "#inst \"2010-11-12T03:14:15.123+05:00\"" - ;;; s2 "#inst \"2010-11-11T22:14:15.123Z\""] - ;;; (binding [*data-readers* {'inst read-instant-date}] - ;;; (testing "read-instant-date should convert to UTC" - ;;; (is (= (read-string s) (read-string s2))))) - ;;; (binding [*data-readers* {'inst read-instant-timestamp}] - ;;; (testing "read-instant-timestamp should convert to UTC" - ;;; (is (= (read-string s) (read-string s2))))) - ;;; (binding [*data-readers* {'inst read-instant-calendar}] - ;;; (testing "read-instant-calendar should preserve timezone" - ;;; (is (not= (read-string s) (read-string s2))))))) - ) -;; UUID Literals -;; #uuid "550e8400-e29b-41d4-a716-446655440000" - -(deftest UUID - (is (= System.Guid (class #uuid "550e8400-e29b-41d4-a716-446655440000"))) ;;; java.util.UUID - (is (.Equals #uuid "550e8400-e29b-41d4-a716-446655440000" ;;; .equals - #uuid "550e8400-e29b-41d4-a716-446655440000")) - #_(is (not (identical? #uuid "550e8400-e29b-41d4-a716-446655440000" ;;; this test doesn't work for us because System.GUid is a value type and value types are treated as values by idnentical? - #uuid "550e8400-e29b-41d4-a716-446655440000"))) - #_(is (= 4 (.version #uuid "550e8400-e29b-41d4-a716-446655440000"))) ;;; No .version in CL - (is (= (print-str #uuid "550e8400-e29b-41d4-a716-446655440000") - "#uuid \"550e8400-e29b-41d4-a716-446655440000\""))) - -(deftest unknown-tag - (let [my-unknown (fn [tag val] {:unknown-tag tag :value val}) - throw-on-unknown (fn [tag val] (throw (Exception. (str "No data reader function for tag " tag)))) ;;; RuntimeException - my-uuid (partial my-unknown 'uuid) - u "#uuid \"550e8400-e29b-41d4-a716-446655440000\"" - s "#never.heard.of/some-tag [1 2]" ] - (binding [*data-readers* {'uuid my-uuid} - *default-data-reader-fn* my-unknown] - (testing "Unknown tag" - (is (= (read-string s) - {:unknown-tag 'never.heard.of/some-tag - :value [1 2]}))) - (testing "Override uuid tag" - (is (= (read-string u) - {:unknown-tag 'uuid - :value "550e8400-e29b-41d4-a716-446655440000"})))) - - (binding [*default-data-reader-fn* throw-on-unknown] - (testing "Unknown tag with custom throw-on-unknown" - (are [err msg form] (thrown-with-msg? err msg (read-string form)) - Exception #"No data reader function for tag foo" "#foo [1 2]" - Exception #"No data reader function for tag bar/foo" "#bar/foo [1 2]" - Exception #"No data reader function for tag bar.baz/foo" "#bar.baz/foo [1 2]"))) - - (testing "Unknown tag out-of-the-box behavior (like Clojure 1.4)" - (are [err msg form] (thrown-with-msg? err msg (read-string form)) - Exception #"No reader function for tag foo" "#foo [1 2]" - Exception #"No reader function for tag bar/foo" "#bar/foo [1 2]" - Exception #"No reader function for tag bar.baz/foo" "#bar.baz/foo [1 2]")))) - - -(defn roundtrip - "Print an object and read it back. Returns rather than throws - any exceptions." - [o] - (binding [*print-length* nil - *print-dup* nil - *print-level* nil] - (try - (-> o pr-str read-string) - (catch Exception t t)))) ;;; Throwable - -(defn roundtrip-dup - "Print an object with print-dup and read it back. - Returns rather than throws any exceptions." - [o] - (binding [*print-length* nil - *print-dup* true - *print-level* nil] - (try - (-> o pr-str read-string) - (catch Exception t t)))) ;;; Throwable - -(defspec types-that-should-roundtrip - roundtrip - [^{:tag cgen/ednable} o] - (when-not (= o %) - (throw (ex-info "Value cannot roundtrip, see ex-data" {:printed o :read %})))) - -(defspec types-that-need-dup-to-roundtrip - roundtrip-dup - [^{:tag cgen/dup-readable} o] - (when-not (= o %) - (throw (ex-info "Value cannot roundtrip, see ex-data" {:printed o :read %})))) - -(defrecord TestRecord [x y]) - -(deftest preserve-read-cond-test - (let [x (read-string {:read-cond :preserve} "#?(:cljr foo :cljs bar)" )] - (is (reader-conditional? x)) - (is (not (:splicing? x))) - (is (= :foo (get x :no-such-key :foo))) - (is (= (:form x) '(:cljr foo :cljs bar))) - (is (= x (reader-conditional '(:cljr foo :cljs bar) false)))) - (let [x (read-string {:read-cond :preserve} "#?@(:cljr [foo])" )] - (is (reader-conditional? x)) - (is (:splicing? x)) - (is (= :foo (get x :no-such-key :foo))) - (is (= (:form x) '(:cljr [foo]))) - (is (= x (reader-conditional '(:cljr [foo]) true)))) - (is (thrown-with-msg? Exception #"No reader function for tag" ;;; RuntimeException - (read-string {:read-cond :preserve} "#js {:x 1 :y 2}" ))) - (let [x (read-string {:read-cond :preserve} "#?(:cljs #js {:x 1 :y 2})") - [platform tl] (:form x)] - (is (reader-conditional? x)) - (is (tagged-literal? tl)) - (is (= 'js (:tag tl))) - (is (= {:x 1 :y 2} (:form tl))) - (is (= :foo (get tl :no-such-key :foo))) - (is (= tl (tagged-literal 'js {:x 1 :y 2})))) - (testing "print form roundtrips" - (doseq [s ["#?(:cljr foo :cljs bar)" - "#?(:cljs #js {:x 1, :y 2})" - "#?(:cljr #clojure.test_clojure.reader.TestRecord [42 85])"]] - (is (= s (pr-str (read-string {:read-cond :preserve} s))))))) - -(deftest reader-conditionals - (testing "basic read-cond" - (is (= '[foo-form] - (read-string {:read-cond :allow :features #{:foo}} "[#?(:foo foo-form :bar bar-form)]"))) - (is (= '[bar-form] - (read-string {:read-cond :allow :features #{:bar}} "[#?(:foo foo-form :bar bar-form)]"))) - (is (= '[foo-form] - (read-string {:read-cond :allow :features #{:foo :bar}} "[#?(:foo foo-form :bar bar-form)]"))) - (is (= '[] - (read-string {:read-cond :allow :features #{:baz}} "[#?( :foo foo-form :bar bar-form)]")))) - (testing "environmental features" - (is (= "clojure" #?(:cljr "clojure" :cljs "clojurescript" :default "default")))) - (testing "default features" - (is (= "default" #?(:clj-clr "clr" :cljs "cljs" :default "default")))) - (testing "splicing" - (is (= [] [#?@(:cljr [])])) - (is (= [:a] [#?@(:cljr [:a])])) - (is (= [:a :b] [#?@(:cljr [:a :b])])) - (is (= [:a :b :c] [#?@(:cljr [:a :b :c])])) - (is (= [:a :b :c] [#?@(:cljr [:a :b :c])]))) - (testing "nested splicing" - (is (= [:a :b :c :d :e] - [#?@(:cljr [:a #?@(:cljr [:b #?@(:cljr [:c]) :d]):e])])) - (is (= '(+ 1 (+ 2 3)) - '(+ #?@(:cljr [1 (+ #?@(:cljr [2 3]))])))) - (is (= '(+ (+ 2 3) 1) - '(+ #?@(:cljr [(+ #?@(:cljr [2 3])) 1])))) - (is (= [:a [:b [:c] :d] :e] - [#?@(:cljr [:a [#?@(:cljr [:b #?@(:cljr [[:c]]) :d])] :e])]))) - (testing "bypass unknown tagged literals" - (is (= [1 2 3] #?(:cljs #js [1 2 3] :cljr [1 2 3]))) - (is (= :clojure #?(:foo #some.nonexistent.Record {:x 1} :cljr :clojure)))) - (testing "error cases" - (is (thrown-with-msg? Exception #"Feature should be a keyword" (read-string {:read-cond :allow} "#?((+ 1 2) :a)"))) ;;; RuntimeException - (is (thrown-with-msg? Exception #"even number of forms" (read-string {:read-cond :allow} "#?(:cljs :a :cljr)"))) ;;; RuntimeException - (is (thrown-with-msg? Exception #"read-cond-splicing must implement" (read-string {:read-cond :allow} "#?@(:cljr :a)"))) ;;; RuntimeException - (is (thrown-with-msg? Exception #"is reserved" (read-string {:read-cond :allow} "#?@(:foo :a :else :b)"))) ;;; RuntimeException - (is (thrown-with-msg? Exception #"must be a list" (read-string {:read-cond :allow} "#?[:foo :a :else :b]"))) ;;; RuntimeException - (is (thrown-with-msg? Exception #"Conditional read not allowed" (read-string {:read-cond :BOGUS} "#?[:cljr :a :default nil]"))) ;;; RuntimeException - (is (thrown-with-msg? Exception #"Conditional read not allowed" (read-string "#?[:cljr :a :default nil]"))) ;;; RuntimeException - (is (thrown-with-msg? Exception #"Reader conditional splicing not allowed at the top level" (read-string {:read-cond :allow} "#?@(:cljr [1 2])"))) ;;; RuntimeException - (is (thrown-with-msg? Exception #"Reader conditional splicing not allowed at the top level" (read-string {:read-cond :allow} "#?@(:cljr [1])"))) ;;; RuntimeException - (is (thrown-with-msg? Exception #"Reader conditional splicing not allowed at the top level" (read-string {:read-cond :allow} "#?@(:cljr []) 1")))) ;;; RuntimeException - (testing "clj-1698-regression" - (let [opts {:features #{:cljr} :read-cond :allow}] - (is (= 1 (read-string opts "#?(:cljs {'a 1 'b 2} :cljr 1)"))) - (is (= 1 (read-string opts "#?(:cljs (let [{{b :b} :a {d :d} :c} {}]) :cljr 1)"))) - (is (= '(def m {}) (read-string opts "(def m #?(:cljs ^{:a :b} {} :cljr ^{:a :b} {}))"))) - (is (= '(def m {}) (read-string opts "(def m #?(:cljs ^{:a :b} {} :cljr ^{:a :b} {}))"))) - (is (= 1 (read-string opts "#?(:cljs {:a #_:b :c} :cljr 1)"))))) - (testing "nil expressions" - (is (nil? #?(:default nil))) - (is (nil? #?(:foo :bar :cljr nil))) - (is (nil? #?(:cljr nil :foo :bar))) - (is (nil? #?(:foo :bar :default nil))))) - -(deftest eof-option - (is (= 23 (read-string {:eof 23} ""))) - (is (= 23 (read {:eof 23} (clojure.lang.LineNumberingTextReader. ;;; clojure.lang.LineNumberingPushbackReader. - (System.IO.StringReader. "")))))) ;;; java.io.StringReader. - -(require '[clojure.string :as s]) -(deftest namespaced-maps - (is (= #:a{1 nil, :b nil, :b/c nil, :_/d nil} - #:a {1 nil, :b nil, :b/c nil, :_/d nil} - {1 nil, :a/b nil, :b/c nil, :d nil})) - (is (= #::{1 nil, :a nil, :a/b nil, :_/d nil} - #:: {1 nil, :a nil, :a/b nil, :_/d nil} - {1 nil, :clojure.test-clojure.reader/a nil, :a/b nil, :d nil} )) - (is (= #::s{1 nil, :a nil, :a/b nil, :_/d nil} - #::s {1 nil, :a nil, :a/b nil, :_/d nil} - {1 nil, :clojure.string/a nil, :a/b nil, :d nil})) - (is (= (read-string "#:a{b 1 b/c 2}") {'a/b 1, 'b/c 2})) - (is (= (binding [*ns* (the-ns 'clojure.test-clojure.reader)] (read-string "#::{b 1, b/c 2, _/d 3}")) {'clojure.test-clojure.reader/b 1, 'b/c 2, 'd 3})) - (is (= (binding [*ns* (the-ns 'clojure.test-clojure.reader)] (read-string "#::s{b 1, b/c 2, _/d 3}")) {'clojure.string/b 1, 'b/c 2, 'd 3}))) - -(deftest namespaced-map-errors - (are [err msg form] (thrown-with-msg? err msg (read-string form)) - Exception #"Invalid token" "#:::" - Exception #"Namespaced map literal must contain an even number of forms" "#:s{1}" - Exception #"Namespaced map must specify a valid namespace" "#:s/t{1 2}" - Exception #"Unknown auto-resolved namespace alias" "#::BOGUS{1 2}" - Exception #"Namespaced map must specify a namespace" "#: s{:a 1}" - Exception #"Duplicate key: :user/a" "#::{:a 1 :a 2}" - Exception #"Duplicate key: user/a" "#::{a 1 a 2}")) - -(deftest namespaced-map-edn - (is (= {1 1, :a/b 2, :b/c 3, :d 4} - (edn/read-string "#:a{1 1, :b 2, :b/c 3, :_/d 4}") - (edn/read-string "#:a {1 1, :b 2, :b/c 3, :_/d 4}")))) - -(deftest invalid-symbol-value - (is (thrown-with-msg? Exception #"Invalid token" (read-string "##5"))) - (is (thrown-with-msg? Exception #"Invalid token" (edn/read-string "##5"))) - (is (thrown-with-msg? Exception #"Unknown symbolic value" (read-string "##Foo"))) - (is (thrown-with-msg? Exception #"Unknown symbolic value" (edn/read-string "##Foo")))) - -(defn str->lnpr - [s] - (-> s (System.IO.StringReader.) (clojure.lang.LineNumberingTextReader.))) ;;; java.io.StringReader. ;;; clojure.lang.LineNumberingPushbackReader. - -(deftest test-read+string - (let [[r s] (read+string (str->lnpr "[:foo 100]"))] - (is (= [:foo 100] r)) - (is (= "[:foo 100]" s))) - - (let [[r s] (read+string {:read-cond :allow :features #{:y}} (str->lnpr "#?(:x :foo :y :bar)"))] - (is (= :bar r)) - (is (= "#?(:x :foo :y :bar)" s)))) - -(deftest t-Explicit-line-column-numbers - (is (= {:line 42 :column 99} - (-> "^{:line 42 :column 99} (1 2)" read-string meta (select-keys [:line :column])))) - - (are [l c s] (= {:line l :column c} (-> s str->lnpr read meta (select-keys [:line :column]))) - 42 99 "^{:line 42 :column 99} (1 2)" - 1 99 "^{:column 99} (1 2)") - - (eval (-> "^{:line 42 :column 99} (defn explicit-line-numbering [])" str->lnpr read)) - (is (= {:line 42 :column 99} - (-> 'explicit-line-numbering resolve meta (select-keys [:line :column]))))) +; 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: Stephen C. Gilardi + +;; +;; Tests for the Clojure functions documented at the URL: +;; +;; http://clojure.org/Reader +;; +;; scgilardi (gmail) +;; Created 22 October 2008 + +(ns clojure.test-clojure.reader + (:use clojure.test) + (:use [clojure.instant :only [read-instant-datetime ;;; read-instant-date + read-instant-datetimeoffset ;;; read-instant-calendar + ]]) ;;; read-instant-timestamp + (:require clojure.walk + [clojure.edn :as edn] + [clojure.test.generative :refer (defspec)] + [clojure.test-clojure.generators :as cgen] + [clojure.edn :as edn]) + (:import [clojure.lang BigInt Ratio] + System.IO.Path System.IO.FileInfo + )) ;;; java.util.TimeZone + +;; Symbols + +(deftest Symbols + (is (= 'abc (symbol "abc"))) + (is (= '*+!-_? (symbol "*+!-_?"))) + (is (= 'abc:def:ghi (symbol "abc:def:ghi"))) + (is (= 'abc/def (symbol "abc" "def"))) + (is (= 'abc.def/ghi (symbol "abc.def" "ghi"))) + (is (= 'abc/def.ghi (symbol "abc" "def.ghi"))) + (is (= 'abc:def/ghi:jkl.mno (symbol "abc:def" "ghi:jkl.mno"))) + (is (instance? clojure.lang.Symbol 'alphabet)) + ) + +;; Literals + +(deftest Literals + ; 'nil 'false 'true are reserved by Clojure and are not symbols + (is (= 'nil nil)) + (is (= 'false false)) + (is (= 'true true)) ) + +;; Strings + +(defn temp-file + [& ignore] ;;; [prefix suffix] + (FileInfo. ;;; (doto (File/createTempFile prefix suffix) + (Path/GetTempFileName))) ;;; (.deleteOnExit))) + +(defn read-from + [source file form] + (if (= :string source) + (read-string form) + (do + (spit file form :file-mode System.IO.FileMode/Truncate) + (let [v (load-file (str file))] (.Delete file) v)))) ;;; (load-file (str file))))) + +(defn code-units + [s] + (and (instance? String s) (map int s))) + +(deftest Strings + (is (= "abcde" (str \a \b \c \d \e))) + (is (= "abc + def" (str \a \b \c \newline \space \space \d \e \f))) + (let [f (temp-file "clojure.core-reader" "test")] + (doseq [source [:string :file]] + (testing (str "Valid string literals read from " (name source)) + (are [x form] (= x (code-units + (read-from source (temp-file) (str "\"" form "\"")))) ;;; f => (temp-file) + [] "" + [34] "\\\"" + [10] "\\n" + + [0] "\\0" + [0] "\\000" + [3] "\\3" + [3] "\\03" + [3] "\\003" + [0 51] "\\0003" + [3 48] "\\0030" + [0377] "\\377" + [0 56] "\\0008" + + [0] "\\u0000" + [0xd7ff] "\\ud7ff" + [0xd800] "\\ud800" + [0xdfff] "\\udfff" + [0xe000] "\\ue000" + [0xffff] "\\uffff" + [4 49] "\\u00041")) + (testing (str "Errors reading string literals from " (name source)) + (are [err msg form] (thrown-with-cause-msg? err msg + (read-from source f (str "\"" form "\""))) + Exception #"EOF while reading string" "\\" + Exception #"Unsupported escape character: \\o" "\\o" + + Exception #"Octal escape sequence must be in range \[0, 377\]" "\\400" + Exception #"Invalid digit: 8" "\\8" + Exception #"Invalid digit: 8" "\\8000" + Exception #"Invalid digit: 8" "\\0800" + Exception #"Invalid digit: 8" "\\0080" + Exception #"Invalid digit: a" "\\2and" + + Exception #"Invalid unicode escape: \\u" "\\u" + Exception #"Invalid unicode escape: \\ug" "\\ug" + Exception #"Invalid unicode escape: \\ug" "\\ug000" + Exception #"Invalid character length: 1, should be: 4" "\\u0" + Exception #"Invalid character length: 3, should be: 4" "\\u004" + Exception #"Invalid digit: g" "\\u004g"))))) + +;; Numbers + +(deftest Numbers + + ; Read Integer + (is (instance? Int64 2147483647)) ;;; Long + (is (instance? Int64 +1)) + (is (instance? Int64 1)) + (is (instance? Int64 +0)) + (is (instance? Int64 0)) + (is (instance? Int64 -0)) + (is (instance? Int64 -1)) + (is (instance? Int64 -2147483648)) + + ; Read Long + (is (instance? Int64 2147483648)) ;;; Long + (is (instance? Int64 -2147483649)) + (is (instance? Int64 9223372036854775807)) + (is (instance? Int64 -9223372036854775808)) + + ;; Numeric constants of different types don't wash out. Regression fixed in + ;; r1157. Previously the compiler saw 0 and 0.0 as the same constant and + ;; caused the sequence to be built of Doubles. + (let [x 0.0] + (let [sequence (loop [i 0 l '()] + (if (< i 5) + (recur (inc i) (conj l i)) + l))] + (is (= [4 3 2 1 0] sequence)) + (is (every? #(instance? Int64 %) ;;; Long + sequence)))) + + ; Read BigInteger + (is (instance? BigInt 9223372036854775808)) + (is (instance? BigInt -9223372036854775809)) + (is (instance? BigInt 10000000000000000000000000000000000000000000000000)) + (is (instance? BigInt -10000000000000000000000000000000000000000000000000)) + + ; Read Double + (is (instance? Double +1.0e+1)) + (is (instance? Double +1.e+1)) + (is (instance? Double +1e+1)) + + (is (instance? Double +1.0e1)) + (is (instance? Double +1.e1)) + (is (instance? Double +1e1)) + + (is (instance? Double +1.0e-1)) + (is (instance? Double +1.e-1)) + (is (instance? Double +1e-1)) + + (is (instance? Double 1.0e+1)) + (is (instance? Double 1.e+1)) + (is (instance? Double 1e+1)) + + (is (instance? Double 1.0e1)) + (is (instance? Double 1.e1)) + (is (instance? Double 1e1)) + + (is (instance? Double 1.0e-1)) + (is (instance? Double 1.e-1)) + (is (instance? Double 1e-1)) + + (is (instance? Double -1.0e+1)) + (is (instance? Double -1.e+1)) + (is (instance? Double -1e+1)) + + (is (instance? Double -1.0e1)) + (is (instance? Double -1.e1)) + (is (instance? Double -1e1)) + + (is (instance? Double -1.0e-1)) + (is (instance? Double -1.e-1)) + (is (instance? Double -1e-1)) + + (is (instance? Double +1.0)) + (is (instance? Double +1.)) + + (is (instance? Double 1.0)) + (is (instance? Double 1.)) + + (is (instance? Double +0.0)) + (is (instance? Double +0.)) + + (is (instance? Double 0.0)) + (is (instance? Double 0.)) + + (is (instance? Double -0.0)) + (is (instance? Double -0.)) + + (is (instance? Double -1.0)) + (is (instance? Double -1.)) + + (is (= Double/PositiveInfinity ##Inf)) ;;; Double/POSITIVE_INFINITY + (is (= Double/NegativeInfinity ##-Inf)) ;;; Double/NEGATIVE_INFINITY + (is (and (instance? Double ##NaN) (Double/IsNaN ##NaN))) ;;; .isNaN + + ; Read BigDecimal + (is (instance? BigDecimal 9223372036854775808M)) + (is (instance? BigDecimal -9223372036854775809M)) + (is (instance? BigDecimal 2147483647M)) + (is (instance? BigDecimal +1M)) + (is (instance? BigDecimal 1M)) + (is (instance? BigDecimal +0M)) + (is (instance? BigDecimal 0M)) + (is (instance? BigDecimal -0M)) + (is (instance? BigDecimal -1M)) + (is (instance? BigDecimal -2147483648M)) + + (is (instance? BigDecimal +1.0e+1M)) + (is (instance? BigDecimal +1.e+1M)) + (is (instance? BigDecimal +1e+1M)) + + (is (instance? BigDecimal +1.0e1M)) + (is (instance? BigDecimal +1.e1M)) + (is (instance? BigDecimal +1e1M)) + + (is (instance? BigDecimal +1.0e-1M)) + (is (instance? BigDecimal +1.e-1M)) + (is (instance? BigDecimal +1e-1M)) + + (is (instance? BigDecimal 1.0e+1M)) + (is (instance? BigDecimal 1.e+1M)) + (is (instance? BigDecimal 1e+1M)) + + (is (instance? BigDecimal 1.0e1M)) + (is (instance? BigDecimal 1.e1M)) + (is (instance? BigDecimal 1e1M)) + + (is (instance? BigDecimal 1.0e-1M)) + (is (instance? BigDecimal 1.e-1M)) + (is (instance? BigDecimal 1e-1M)) + + (is (instance? BigDecimal -1.0e+1M)) + (is (instance? BigDecimal -1.e+1M)) + (is (instance? BigDecimal -1e+1M)) + + (is (instance? BigDecimal -1.0e1M)) + (is (instance? BigDecimal -1.e1M)) + (is (instance? BigDecimal -1e1M)) + + (is (instance? BigDecimal -1.0e-1M)) + (is (instance? BigDecimal -1.e-1M)) + (is (instance? BigDecimal -1e-1M)) + + (is (instance? BigDecimal +1.0M)) + (is (instance? BigDecimal +1.M)) + + (is (instance? BigDecimal 1.0M)) + (is (instance? BigDecimal 1.M)) + + (is (instance? BigDecimal +0.0M)) + (is (instance? BigDecimal +0.M)) + + (is (instance? BigDecimal 0.0M)) + (is (instance? BigDecimal 0.M)) + + (is (instance? BigDecimal -0.0M)) + (is (instance? BigDecimal -0.M)) + + (is (instance? BigDecimal -1.0M)) + (is (instance? BigDecimal -1.M)) + + (is (instance? Ratio 1/2)) + (is (instance? Ratio -1/2)) + (is (instance? Ratio +1/2)) +) + +;; Characters + +(deftest t-Characters + (let [f (temp-file "clojure.core-reader" "test")] + (doseq [source [:string :file]] + (testing (str "Valid char literals read from " (name source)) + (are [x form] (= x (read-from source (temp-file) form)) ;;; f -> (temp-file) + (first "o") "\\o" + (char 0) "\\o0" + (char 0) "\\o000" + (char 047) "\\o47" + (char 0377) "\\o377" + + (first "u") "\\u" + (first "A") "\\u0041" + (char 0) "\\u0000" + (char 0xd7ff) "\\ud7ff" + (char 0xe000) "\\ue000" + (char 0xffff) "\\uffff")) + (testing (str "Errors reading char literals from " (name source)) + (are [err msg form] (thrown-with-cause-msg? err msg (read-from source f form)) + Exception #"EOF while reading character" "\\" + Exception #"Unsupported character: \\00" "\\00" + Exception #"Unsupported character: \\0009" "\\0009" + + Exception #"Invalid digit: 8" "\\o378" + Exception #"Octal escape sequence must be in range \[0, 377\]" "\\o400" + Exception #"Invalid digit: 8" "\\o800" + Exception #"Invalid digit: a" "\\oand" + Exception #"Invalid octal escape sequence length: 4" "\\o0470" + + Exception #"Invalid unicode character: \\u0" "\\u0" + Exception #"Invalid unicode character: \\ug" "\\ug" + Exception #"Invalid unicode character: \\u000" "\\u000" + Exception #"Invalid character constant: \\ud800" "\\ud800" + Exception #"Invalid character constant: \\udfff" "\\udfff" + Exception #"Invalid unicode character: \\u004" "\\u004" + Exception #"Invalid unicode character: \\u00041" "\\u00041" + Exception #"Invalid digit: g" "\\u004g"))))) + +;; nil + +(deftest t-nil) + +;; Booleans + +(deftest t-Booleans) + +;; Keywords + +(deftest t-Keywords + (is (= :abc (keyword "abc"))) + (is (= :abc (keyword 'abc))) + (is (= :*+!-_? (keyword "*+!-_?"))) + (is (= :abc:def:ghi (keyword "abc:def:ghi"))) + (is (= :abc/def (keyword "abc" "def"))) + (is (= :abc/def (keyword 'abc/def))) + (is (= :abc.def/ghi (keyword "abc.def" "ghi"))) + (is (= :abc/def.ghi (keyword "abc" "def.ghi"))) + (is (= :abc:def/ghi:jkl.mno (keyword "abc:def" "ghi:jkl.mno"))) + (is (instance? clojure.lang.Keyword :alphabet)) + ) + +(deftest reading-keywords + (are [x y] (= x (binding [*ns* (the-ns 'user)] (read-string y))) + :foo ":foo" + :foo/bar ":foo/bar" + :user/foo "::foo") + (are [err msg form] (thrown-with-msg? err msg (read-string form)) + Exception #"Invalid token: foo:" "foo:" + Exception #"Invalid token: :bar/" ":bar/" + Exception #"Invalid token: ::does.not/exist" "::does.not/exist")) +;; Lists + +(deftest t-Lists) + +;; Vectors + +(deftest t-Vectors) + +;; Maps + +(deftest t-Maps) + +;; Sets + +(deftest t-Sets) + +;; Macro characters + +;; Quote (') + +(deftest t-Quote) + +;; Character (\) + +(deftest t-Character) + +;; Comment (;) + +(deftest t-Comment) + +;; Deref (@) + +(deftest t-Deref) + +;; Dispatch (#) + +;; #{} - see Sets above + +;; Regex patterns (#"pattern") + +(deftest t-Regex) + +;; Metadata (^ or #^ (deprecated)) + +(deftest t-line-column-numbers + (let [code "(ns reader-metadata-test + (:require [clojure.java.io + :refer (resource reader)])) + +(let [a 5] + ^:added-metadata + (defn add-5 + [x] + (reduce + x (range a))))" + stream (clojure.lang.LineNumberingTextReader. ;;; clojure.lang.LineNumberingPushbackReader. + (System.IO.StringReader. code)) ;;; java.io.StringReader. + top-levels (take-while identity (repeatedly #(read stream false nil))) + expected-metadata '{ns {:line 1, :column 1} + :require {:line 2, :column 3} + resource {:line 3, :column 21} + let {:line 5, :column 1} + defn {:line 6, :column 3 :added-metadata true} + reduce {:line 9, :column 5} + range {:line 9, :column 17}} + verified-forms (atom 0)] + (doseq [form top-levels] + (clojure.walk/postwalk + #(when (list? %) + (is (= (expected-metadata (first %)) + (meta %))) + (is (->> (meta %) + vals + (filter number?) + (every? (partial instance? Int32)))) ;;; Integer + (swap! verified-forms inc)) + form)) + ;; sanity check against e.g. reading returning () + (is (= (count expected-metadata) @verified-forms)))) + +(deftest set-line-number + (let [r (clojure.lang.LineNumberingTextReader. *in*)] ;;; LineNumberingPushbackReader + (.set_LineNumber r 100) ;;; .setLineNumber + (is (= 100 (.get_LineNumber r))))) ;;; .getLineNumber + +(deftest t-Metadata + (is (= (meta '^:static ^:awesome ^{:static false :bar :baz} sym) {:awesome true, :bar :baz, :static true}))) + +;; Var-quote (#') + +(deftest t-Var-quote) + +;; Anonymous function literal (#()) + +(deftest t-Anonymouns-function-literal) + +;; Syntax-quote (`, note, the "backquote" character), Unquote (~) and +;; Unquote-splicing (~@) + +(deftest t-Syntax-quote + (are [x y] (= x y) + `() () ; was NPE before SVN r1337 + )) + +;; (read) +;; (read stream) +;; (read stream eof-is-error) +;; (read stream eof-is-error eof-value) +;; (read stream eof-is-error eof-value is-recursive) + +(deftest t-read) + +(deftest division + (is (= clojure.core// /)) + (binding [*ns* *ns*] + (eval '(do (ns foo + (:require [clojure.core :as bar]) + (:use [clojure.test])) + (is (= clojure.core// bar//)))))) + +(deftest Instants + (testing "Instants are read as System.DateTime by default" ;;; java.util.Date + (is (= System.DateTime (class #inst "2010-11-12T13:14:15.666")))) ;;; java.util.Date + (let [s "#inst \"2010-11-12T13:14:15.666-06:00\""] + (binding [*data-readers* {'inst read-instant-datetime}] ;;; read-instant-date + (testing "read-instant-datetime produces System.DateTime" ;;; "read-instant-date produces java.util.Date" + (is (= System.DateTime (class (read-string s))))) ;;; java.util.Date + (testing "System.DateTime instants round-trips" ;;; java.util.Date + (is (= (-> s read-string) + (-> s read-string pr-str read-string)))) + (testing "java.util.Date instants round-trip throughout the year" + (doseq [month (range 1 13) day (range 1 29) hour (range 1 23)] + (let [s (format "#inst \"2010-%02d-%02dT%02d:14:15.666-06:00\"" month day hour)] + (is (= (-> s read-string) + (-> s read-string pr-str read-string)))))) + ;;;(testing "java.util.Date handling DST in time zones" ;;; not sure how to do this + ;;; (let [dtz (TimeZone/getDefault)] + ;;; (try + ;;; ;; A timezone with DST in effect during 2010-11-12 + ;;; (TimeZone/setDefault (TimeZone/getTimeZone "Australia/Sydney")) + ;;; (is (= (-> s read-string) + ;;; (-> s read-string pr-str read-string))) + ;;; (finally (TimeZone/setDefault dtz))))) + (testing "java.util.Date should always print in UTC" + (let [d (read-string s) + pstr (print-str d) + len (.Length pstr)] ;;;.length + (is (= (subs pstr (- len 7)) "-00:00\""))))) + (binding [*data-readers* {'inst read-instant-datetimeoffset}] ;;; read-instant-calendar + (testing "read-instant-calendar produces System.DateTimeOffset" ;;; java.util.Calendar + (is (instance? System.DateTimeOffset (read-string s)))) ;;; java.util.Calendar + (testing "System.DateTimeOffset round-trips" ;;; java.util.Calendar + (is (= (-> s read-string) + (-> s read-string pr-str read-string)))) + (testing "System.DateTimeOffset remembers timezone in literal" ;;; java.util.Calendar + (is (= "#inst \"2010-11-12T13:14:15.666-06:00\"" + (-> s read-string pr-str))) + (is (= (-> s read-string) + (-> s read-string pr-str read-string)))) + (testing "System.DateTimeOffset preserves milliseconds" ;;; java.util.Calendar + (is (= 666 (-> s read-string + (.Millisecond))))))) ;;; (.get java.util.Calendar/MILLISECOND))))))) + ;;;(let [s "#inst \"2010-11-12T13:14:15.123456789\"" + ;;; s2 "#inst \"2010-11-12T13:14:15.123\"" + ;;; s3 "#inst \"2010-11-12T13:14:15.123456789123\""] + ;;; (binding [*data-readers* {'inst read-instant-timestamp}] + ;;; (testing "read-instant-timestamp produces java.sql.Timestamp" + ;;; (is (= java.sql.Timestamp (class (read-string s))))) + ;;; (testing "java.sql.Timestamp preserves nanoseconds" + ;;; (is (= 123456789 (-> s read-string .getNanos))) + ;;; (is (= 123456789 (-> s read-string pr-str read-string .getNanos))) + ;;; ;; truncate at nanos for s3 + ;;; (is (= 123456789 (-> s3 read-string pr-str read-string .getNanos)))) + ;;; (testing "java.sql.Timestamp should compare nanos" + ;;; (is (= (read-string s) (read-string s3))) + ;;; (is (not= (read-string s) (read-string s2))))) + ;;; (binding [*data-readers* {'inst read-instant-date}] + ;;; (testing "read-instant-date should truncate at milliseconds" + ;;; (is (= (read-string s) (read-string s2) (read-string s3)))))) + ;;;(let [s "#inst \"2010-11-12T03:14:15.123+05:00\"" + ;;; s2 "#inst \"2010-11-11T22:14:15.123Z\""] + ;;; (binding [*data-readers* {'inst read-instant-date}] + ;;; (testing "read-instant-date should convert to UTC" + ;;; (is (= (read-string s) (read-string s2))))) + ;;; (binding [*data-readers* {'inst read-instant-timestamp}] + ;;; (testing "read-instant-timestamp should convert to UTC" + ;;; (is (= (read-string s) (read-string s2))))) + ;;; (binding [*data-readers* {'inst read-instant-calendar}] + ;;; (testing "read-instant-calendar should preserve timezone" + ;;; (is (not= (read-string s) (read-string s2))))))) + ) +;; UUID Literals +;; #uuid "550e8400-e29b-41d4-a716-446655440000" + +(deftest UUID + (is (= System.Guid (class #uuid "550e8400-e29b-41d4-a716-446655440000"))) ;;; java.util.UUID + (is (.Equals #uuid "550e8400-e29b-41d4-a716-446655440000" ;;; .equals + #uuid "550e8400-e29b-41d4-a716-446655440000")) + #_(is (not (identical? #uuid "550e8400-e29b-41d4-a716-446655440000" ;;; this test doesn't work for us because System.GUid is a value type and value types are treated as values by idnentical? + #uuid "550e8400-e29b-41d4-a716-446655440000"))) + #_(is (= 4 (.version #uuid "550e8400-e29b-41d4-a716-446655440000"))) ;;; No .version in CL + (is (= (print-str #uuid "550e8400-e29b-41d4-a716-446655440000") + "#uuid \"550e8400-e29b-41d4-a716-446655440000\""))) + +(deftest unknown-tag + (let [my-unknown (fn [tag val] {:unknown-tag tag :value val}) + throw-on-unknown (fn [tag val] (throw (Exception. (str "No data reader function for tag " tag)))) ;;; RuntimeException + my-uuid (partial my-unknown 'uuid) + u "#uuid \"550e8400-e29b-41d4-a716-446655440000\"" + s "#never.heard.of/some-tag [1 2]" ] + (binding [*data-readers* {'uuid my-uuid} + *default-data-reader-fn* my-unknown] + (testing "Unknown tag" + (is (= (read-string s) + {:unknown-tag 'never.heard.of/some-tag + :value [1 2]}))) + (testing "Override uuid tag" + (is (= (read-string u) + {:unknown-tag 'uuid + :value "550e8400-e29b-41d4-a716-446655440000"})))) + + (binding [*default-data-reader-fn* throw-on-unknown] + (testing "Unknown tag with custom throw-on-unknown" + (are [err msg form] (thrown-with-msg? err msg (read-string form)) + Exception #"No data reader function for tag foo" "#foo [1 2]" + Exception #"No data reader function for tag bar/foo" "#bar/foo [1 2]" + Exception #"No data reader function for tag bar.baz/foo" "#bar.baz/foo [1 2]"))) + + (testing "Unknown tag out-of-the-box behavior (like Clojure 1.4)" + (are [err msg form] (thrown-with-msg? err msg (read-string form)) + Exception #"No reader function for tag foo" "#foo [1 2]" + Exception #"No reader function for tag bar/foo" "#bar/foo [1 2]" + Exception #"No reader function for tag bar.baz/foo" "#bar.baz/foo [1 2]")))) + + +(defn roundtrip + "Print an object and read it back. Returns rather than throws + any exceptions." + [o] + (binding [*print-length* nil + *print-dup* nil + *print-level* nil] + (try + (-> o pr-str read-string) + (catch Exception t t)))) ;;; Throwable + +(defn roundtrip-dup + "Print an object with print-dup and read it back. + Returns rather than throws any exceptions." + [o] + (binding [*print-length* nil + *print-dup* true + *print-level* nil] + (try + (-> o pr-str read-string) + (catch Exception t t)))) ;;; Throwable + +(defspec types-that-should-roundtrip + roundtrip + [^{:tag cgen/ednable} o] + (when-not (= o %) + (throw (ex-info "Value cannot roundtrip, see ex-data" {:printed o :read %})))) + +(defspec types-that-need-dup-to-roundtrip + roundtrip-dup + [^{:tag cgen/dup-readable} o] + (when-not (= o %) + (throw (ex-info "Value cannot roundtrip, see ex-data" {:printed o :read %})))) + +(defrecord TestRecord [x y]) + +(deftest preserve-read-cond-test + (let [x (read-string {:read-cond :preserve} "#?(:cljr foo :cljs bar)" )] + (is (reader-conditional? x)) + (is (not (:splicing? x))) + (is (= :foo (get x :no-such-key :foo))) + (is (= (:form x) '(:cljr foo :cljs bar))) + (is (= x (reader-conditional '(:cljr foo :cljs bar) false)))) + (let [x (read-string {:read-cond :preserve} "#?@(:cljr [foo])" )] + (is (reader-conditional? x)) + (is (:splicing? x)) + (is (= :foo (get x :no-such-key :foo))) + (is (= (:form x) '(:cljr [foo]))) + (is (= x (reader-conditional '(:cljr [foo]) true)))) + (is (thrown-with-msg? Exception #"No reader function for tag" ;;; RuntimeException + (read-string {:read-cond :preserve} "#js {:x 1 :y 2}" ))) + (let [x (read-string {:read-cond :preserve} "#?(:cljs #js {:x 1 :y 2})") + [platform tl] (:form x)] + (is (reader-conditional? x)) + (is (tagged-literal? tl)) + (is (= 'js (:tag tl))) + (is (= {:x 1 :y 2} (:form tl))) + (is (= :foo (get tl :no-such-key :foo))) + (is (= tl (tagged-literal 'js {:x 1 :y 2})))) + (testing "print form roundtrips" + (doseq [s ["#?(:cljr foo :cljs bar)" + "#?(:cljs #js {:x 1, :y 2})" + "#?(:cljr #clojure.test_clojure.reader.TestRecord [42 85])"]] + (is (= s (pr-str (read-string {:read-cond :preserve} s))))))) + +(deftest reader-conditionals + (testing "basic read-cond" + (is (= '[foo-form] + (read-string {:read-cond :allow :features #{:foo}} "[#?(:foo foo-form :bar bar-form)]"))) + (is (= '[bar-form] + (read-string {:read-cond :allow :features #{:bar}} "[#?(:foo foo-form :bar bar-form)]"))) + (is (= '[foo-form] + (read-string {:read-cond :allow :features #{:foo :bar}} "[#?(:foo foo-form :bar bar-form)]"))) + (is (= '[] + (read-string {:read-cond :allow :features #{:baz}} "[#?( :foo foo-form :bar bar-form)]")))) + (testing "environmental features" + (is (= "clojure" #?(:cljr "clojure" :cljs "clojurescript" :default "default")))) + (testing "default features" + (is (= "default" #?(:clj-clr "clr" :cljs "cljs" :default "default")))) + (testing "splicing" + (is (= [] [#?@(:cljr [])])) + (is (= [:a] [#?@(:cljr [:a])])) + (is (= [:a :b] [#?@(:cljr [:a :b])])) + (is (= [:a :b :c] [#?@(:cljr [:a :b :c])])) + (is (= [:a :b :c] [#?@(:cljr [:a :b :c])]))) + (testing "nested splicing" + (is (= [:a :b :c :d :e] + [#?@(:cljr [:a #?@(:cljr [:b #?@(:cljr [:c]) :d]):e])])) + (is (= '(+ 1 (+ 2 3)) + '(+ #?@(:cljr [1 (+ #?@(:cljr [2 3]))])))) + (is (= '(+ (+ 2 3) 1) + '(+ #?@(:cljr [(+ #?@(:cljr [2 3])) 1])))) + (is (= [:a [:b [:c] :d] :e] + [#?@(:cljr [:a [#?@(:cljr [:b #?@(:cljr [[:c]]) :d])] :e])]))) + (testing "bypass unknown tagged literals" + (is (= [1 2 3] #?(:cljs #js [1 2 3] :cljr [1 2 3]))) + (is (= :clojure #?(:foo #some.nonexistent.Record {:x 1} :cljr :clojure)))) + (testing "error cases" + (is (thrown-with-msg? Exception #"Feature should be a keyword" (read-string {:read-cond :allow} "#?((+ 1 2) :a)"))) ;;; RuntimeException + (is (thrown-with-msg? Exception #"even number of forms" (read-string {:read-cond :allow} "#?(:cljs :a :cljr)"))) ;;; RuntimeException + (is (thrown-with-msg? Exception #"read-cond-splicing must implement" (read-string {:read-cond :allow} "#?@(:cljr :a)"))) ;;; RuntimeException + (is (thrown-with-msg? Exception #"is reserved" (read-string {:read-cond :allow} "#?@(:foo :a :else :b)"))) ;;; RuntimeException + (is (thrown-with-msg? Exception #"must be a list" (read-string {:read-cond :allow} "#?[:foo :a :else :b]"))) ;;; RuntimeException + (is (thrown-with-msg? Exception #"Conditional read not allowed" (read-string {:read-cond :BOGUS} "#?[:cljr :a :default nil]"))) ;;; RuntimeException + (is (thrown-with-msg? Exception #"Conditional read not allowed" (read-string "#?[:cljr :a :default nil]"))) ;;; RuntimeException + (is (thrown-with-msg? Exception #"Reader conditional splicing not allowed at the top level" (read-string {:read-cond :allow} "#?@(:cljr [1 2])"))) ;;; RuntimeException + (is (thrown-with-msg? Exception #"Reader conditional splicing not allowed at the top level" (read-string {:read-cond :allow} "#?@(:cljr [1])"))) ;;; RuntimeException + (is (thrown-with-msg? Exception #"Reader conditional splicing not allowed at the top level" (read-string {:read-cond :allow} "#?@(:cljr []) 1")))) ;;; RuntimeException + (testing "clj-1698-regression" + (let [opts {:features #{:cljr} :read-cond :allow}] + (is (= 1 (read-string opts "#?(:cljs {'a 1 'b 2} :cljr 1)"))) + (is (= 1 (read-string opts "#?(:cljs (let [{{b :b} :a {d :d} :c} {}]) :cljr 1)"))) + (is (= '(def m {}) (read-string opts "(def m #?(:cljs ^{:a :b} {} :cljr ^{:a :b} {}))"))) + (is (= '(def m {}) (read-string opts "(def m #?(:cljs ^{:a :b} {} :cljr ^{:a :b} {}))"))) + (is (= 1 (read-string opts "#?(:cljs {:a #_:b :c} :cljr 1)"))))) + (testing "nil expressions" + (is (nil? #?(:default nil))) + (is (nil? #?(:foo :bar :cljr nil))) + (is (nil? #?(:cljr nil :foo :bar))) + (is (nil? #?(:foo :bar :default nil))))) + +(deftest eof-option + (is (= 23 (read-string {:eof 23} ""))) + (is (= 23 (read {:eof 23} (clojure.lang.LineNumberingTextReader. ;;; clojure.lang.LineNumberingPushbackReader. + (System.IO.StringReader. "")))))) ;;; java.io.StringReader. + +(require '[clojure.string :as s]) +(deftest namespaced-maps + (is (= #:a{1 nil, :b nil, :b/c nil, :_/d nil} + #:a {1 nil, :b nil, :b/c nil, :_/d nil} + {1 nil, :a/b nil, :b/c nil, :d nil})) + (is (= #::{1 nil, :a nil, :a/b nil, :_/d nil} + #:: {1 nil, :a nil, :a/b nil, :_/d nil} + {1 nil, :clojure.test-clojure.reader/a nil, :a/b nil, :d nil} )) + (is (= #::s{1 nil, :a nil, :a/b nil, :_/d nil} + #::s {1 nil, :a nil, :a/b nil, :_/d nil} + {1 nil, :clojure.string/a nil, :a/b nil, :d nil})) + (is (= (read-string "#:a{b 1 b/c 2}") {'a/b 1, 'b/c 2})) + (is (= (binding [*ns* (the-ns 'clojure.test-clojure.reader)] (read-string "#::{b 1, b/c 2, _/d 3}")) {'clojure.test-clojure.reader/b 1, 'b/c 2, 'd 3})) + (is (= (binding [*ns* (the-ns 'clojure.test-clojure.reader)] (read-string "#::s{b 1, b/c 2, _/d 3}")) {'clojure.string/b 1, 'b/c 2, 'd 3}))) + +(deftest namespaced-map-errors + (are [err msg form] (thrown-with-msg? err msg (read-string form)) + Exception #"Invalid token" "#:::" + Exception #"Namespaced map literal must contain an even number of forms" "#:s{1}" + Exception #"Namespaced map must specify a valid namespace" "#:s/t{1 2}" + Exception #"Unknown auto-resolved namespace alias" "#::BOGUS{1 2}" + Exception #"Namespaced map must specify a namespace" "#: s{:a 1}" + Exception #"Duplicate key: :user/a" "#::{:a 1 :a 2}" + Exception #"Duplicate key: user/a" "#::{a 1 a 2}")) + +(deftest namespaced-map-edn + (is (= {1 1, :a/b 2, :b/c 3, :d 4} + (edn/read-string "#:a{1 1, :b 2, :b/c 3, :_/d 4}") + (edn/read-string "#:a {1 1, :b 2, :b/c 3, :_/d 4}")))) + +(deftest invalid-symbol-value + (is (thrown-with-msg? Exception #"Invalid token" (read-string "##5"))) + (is (thrown-with-msg? Exception #"Invalid token" (edn/read-string "##5"))) + (is (thrown-with-msg? Exception #"Unknown symbolic value" (read-string "##Foo"))) + (is (thrown-with-msg? Exception #"Unknown symbolic value" (edn/read-string "##Foo")))) + +(defn str->lnpr + [s] + (-> s (System.IO.StringReader.) (clojure.lang.LineNumberingTextReader.))) ;;; java.io.StringReader. ;;; clojure.lang.LineNumberingPushbackReader. + +(deftest test-read+string + (let [[r s] (read+string (str->lnpr "[:foo 100]"))] + (is (= [:foo 100] r)) + (is (= "[:foo 100]" s))) + + (let [[r s] (read+string {:read-cond :allow :features #{:y}} (str->lnpr "#?(:x :foo :y :bar)"))] + (is (= :bar r)) + (is (= "#?(:x :foo :y :bar)" s)))) + +(deftest t-Explicit-line-column-numbers + (is (= {:line 42 :column 99} + (-> "^{:line 42 :column 99} (1 2)" read-string meta (select-keys [:line :column])))) + + (are [l c s] (= {:line l :column c} (-> s str->lnpr read meta (select-keys [:line :column]))) + 42 99 "^{:line 42 :column 99} (1 2)" + 1 99 "^{:column 99} (1 2)") + + (eval (-> "^{:line 42 :column 99} (defn explicit-line-numbering [])" str->lnpr read)) + (is (= {:line 42 :column 99} + (-> 'explicit-line-numbering resolve meta (select-keys [:line :column]))))) diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/reducers.clj b/Clojure/Clojure.Tests/clojure/test_clojure/reducers.clj index 471f160b1..f155e2567 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/reducers.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/reducers.clj @@ -1,95 +1,95 @@ -; 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: Tassilo Horn - -(ns clojure.test-clojure.reducers - (:require [clojure.core.reducers :as r] - [clojure.test.generative :refer (defspec)] - [clojure.data.generators :as gen]) - (:use clojure.test)) - -(defmacro defequivtest - ;; f is the core fn, r is the reducers equivalent, rt is the reducible -> - ;; coll transformer - [name [f r rt] fns] - `(deftest ~name - (let [c# (range -100 1000)] - (doseq [fn# ~fns] - (is (= (~f fn# c#) - (~rt (~r fn# c#)))))))) - -(defequivtest test-map - [map r/map #(into [] %)] - [inc dec #(Math/Sqrt (Math/Abs %))]) ;;; Math/sqrt Math/abs - -(defequivtest test-mapcat - [mapcat r/mapcat #(into [] %)] - [(fn [x] [x]) - (fn [x] [x (inc x)]) - (fn [x] [x (inc x) x])]) - -(deftest test-mapcat-obeys-reduced - (is (= [1 "0" 2 "1" 3] - (->> (concat (range 100) (lazy-seq (throw (Exception. "Too eager")))) - (r/mapcat (juxt inc str)) - (r/take 5) - (into []))))) - - (defequivtest test-reduce - [reduce r/reduce identity] - [+' *']) - -(defequivtest test-filter - [filter r/filter #(into [] %)] - [even? odd? #(< 200 %) identity]) - - - (deftest test-sorted-maps - (let [m (into (sorted-map) - '{1 a, 2 b, 3 c, 4 d})] - (is (= "1a2b3c4d" (reduce-kv str "" m)) - "Sorted maps should reduce-kv in sorted order") - (is (= 1 (reduce-kv (fn [acc k v] - (reduced (+ acc k))) - 0 m)) - "Sorted maps should stop reduction when asked"))) - -(deftest test-nil - (is (= {:k :v} (reduce-kv assoc {:k :v} nil))) - (is (= 0 (r/fold + nil)))) - -(defn gen-num [] - (gen/uniform 0 2000)) - -(defn reduced-at-probe - [m p] - (reduce-kv (fn [_ k v] (when (== p k) (reduced :foo))) nil m)) - -(defspec reduced-always-returns - (fn [probe to-end] - (let [len (+ probe to-end 1) - nums (range len) - m (zipmap nums nums)] - (reduced-at-probe m probe))) - [^{:tag `gen-num} probe ^{:tag `gen-num} to-end] - (assert (= :foo %))) - -(deftest test-fold-runtime-exception - (is (thrown? System.Exception ;;; IndexOutOfBoundsException - this would be an AggregateException in 4.0, something else in 3.5 - (let [test-map-count 1234 - k-fail (rand-int test-map-count)] - (r/fold (fn ([]) - ([ret [k v]]) - ([ret k v] (when (= k k-fail) - (throw (IndexOutOfRangeException.))))) ;;; IndexOutOfBoundsException - (zipmap (range test-map-count) (repeat :dummy))))))) - -#_(deftest test-closed-over-clearing ;;; Temporarily disable to speed up testing -- SEE CLJCLR-96 - ;; this will throw OutOfMemory without proper reference clearing +; 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: Tassilo Horn + +(ns clojure.test-clojure.reducers + (:require [clojure.core.reducers :as r] + [clojure.test.generative :refer (defspec)] + [clojure.data.generators :as gen]) + (:use clojure.test)) + +(defmacro defequivtest + ;; f is the core fn, r is the reducers equivalent, rt is the reducible -> + ;; coll transformer + [name [f r rt] fns] + `(deftest ~name + (let [c# (range -100 1000)] + (doseq [fn# ~fns] + (is (= (~f fn# c#) + (~rt (~r fn# c#)))))))) + +(defequivtest test-map + [map r/map #(into [] %)] + [inc dec #(Math/Sqrt (Math/Abs %))]) ;;; Math/sqrt Math/abs + +(defequivtest test-mapcat + [mapcat r/mapcat #(into [] %)] + [(fn [x] [x]) + (fn [x] [x (inc x)]) + (fn [x] [x (inc x) x])]) + +(deftest test-mapcat-obeys-reduced + (is (= [1 "0" 2 "1" 3] + (->> (concat (range 100) (lazy-seq (throw (Exception. "Too eager")))) + (r/mapcat (juxt inc str)) + (r/take 5) + (into []))))) + + (defequivtest test-reduce + [reduce r/reduce identity] + [+' *']) + +(defequivtest test-filter + [filter r/filter #(into [] %)] + [even? odd? #(< 200 %) identity]) + + + (deftest test-sorted-maps + (let [m (into (sorted-map) + '{1 a, 2 b, 3 c, 4 d})] + (is (= "1a2b3c4d" (reduce-kv str "" m)) + "Sorted maps should reduce-kv in sorted order") + (is (= 1 (reduce-kv (fn [acc k v] + (reduced (+ acc k))) + 0 m)) + "Sorted maps should stop reduction when asked"))) + +(deftest test-nil + (is (= {:k :v} (reduce-kv assoc {:k :v} nil))) + (is (= 0 (r/fold + nil)))) + +(defn gen-num [] + (gen/uniform 0 2000)) + +(defn reduced-at-probe + [m p] + (reduce-kv (fn [_ k v] (when (== p k) (reduced :foo))) nil m)) + +(defspec reduced-always-returns + (fn [probe to-end] + (let [len (+ probe to-end 1) + nums (range len) + m (zipmap nums nums)] + (reduced-at-probe m probe))) + [^{:tag `gen-num} probe ^{:tag `gen-num} to-end] + (assert (= :foo %))) + +(deftest test-fold-runtime-exception + (is (thrown? System.Exception ;;; IndexOutOfBoundsException - this would be an AggregateException in 4.0, something else in 3.5 + (let [test-map-count 1234 + k-fail (rand-int test-map-count)] + (r/fold (fn ([]) + ([ret [k v]]) + ([ret k v] (when (= k k-fail) + (throw (IndexOutOfRangeException.))))) ;;; IndexOutOfBoundsException + (zipmap (range test-map-count) (repeat :dummy))))))) + +#_(deftest test-closed-over-clearing ;;; Temporarily disable to speed up testing -- SEE CLJCLR-96 + ;; this will throw OutOfMemory without proper reference clearing (is (number? (reduce + 0 (r/map identity (range 1e8)))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/repl.clj b/Clojure/Clojure.Tests/clojure/test_clojure/repl.clj index 51a7c090f..c8cbe614a 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/repl.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/repl.clj @@ -8,8 +8,8 @@ (deftest test-doc (testing "with namespaces" (is (= "clojure.pprint" - (second (str/split-lines (with-out-str (doc clojure.pprint))))))) - (testing "with special cases" + (second (str/split-lines (with-out-str (doc clojure.pprint))))))) + (testing "with special cases" (is (= (with-out-str (doc catch)) (with-out-str (doc try)))))) (deftest test-source @@ -17,32 +17,32 @@ (is (= (platform-newlines "(defn foo [])\n") (with-out-str (source clojure.test-clojure.repl.example/foo)))) (is (nil? (source-fn 'non-existent-fn)))) -(deftest test-source-read-eval-unknown - (is (thrown? InvalidOperationException (binding [*read-eval* :unknown] (source reduce))))) ;;; IllegalStateException - -(deftest test-source-read-eval-false - (is (binding [*read-eval* false] (with-out-str (source reduce))))) +(deftest test-source-read-eval-unknown + (is (thrown? InvalidOperationException (binding [*read-eval* :unknown] (source reduce))))) ;;; IllegalStateException + +(deftest test-source-read-eval-false + (is (binding [*read-eval* false] (with-out-str (source reduce))))) (deftest test-dir (is (thrown? Exception (dir-fn 'non-existent-ns))) (is (= '[bar foo] (dir-fn 'clojure.test-clojure.repl.example))) - (binding [*ns* (the-ns 'clojure.test-clojure.repl)] + (binding [*ns* (the-ns 'clojure.test-clojure.repl)] (is (= (dir-fn 'clojure.string) (dir-fn 'str)))) (is (= (platform-newlines "bar\nfoo\n") (with-out-str (dir clojure.test-clojure.repl.example))))) (deftest test-apropos (testing "with a regular expression" - (is (= '[clojure.core/defmacro] (apropos #"^defmacro$"))) + (is (= '[clojure.core/defmacro] (apropos #"^defmacro$"))) (is (some #{'clojure.core/defmacro} (apropos #"def.acr."))) (is (= [] (apropos #"nothing-has-this-name")))) (testing "with a string" - (is (some #{'clojure.core/defmacro} (apropos "defmacro"))) + (is (some #{'clojure.core/defmacro} (apropos "defmacro"))) (is (some #{'clojure.core/defmacro} (apropos "efmac"))) (is (= [] (apropos "nothing-has-this-name")))) (testing "with a symbol" - (is (some #{'clojure.core/defmacro} (apropos 'defmacro))) + (is (some #{'clojure.core/defmacro} (apropos 'defmacro))) (is (some #{'clojure.core/defmacro} (apropos 'efmac))) (is (= [] (apropos 'nothing-has-this-name))))) diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/rt.clj b/Clojure/Clojure.Tests/clojure/test_clojure/rt.clj index 08bab12a2..83d5cafbc 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/rt.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/rt.clj @@ -9,7 +9,7 @@ ; Author: Stuart Halloway (ns clojure.test-clojure.rt - (:require [clojure.string :as string] + (:require [clojure.string :as string] clojure.set) (:use clojure.test clojure.test-helper)) @@ -38,26 +38,26 @@ (defn foo [x] (.blah x)))) (testing "reflection cannot resolve instance method on known class" ;;; TODO: Figure out why the regexes don't match in these two tests. They look identical to me. (should-print-err-message - #"Reflection warning, .*:\d+:\d+ - reference to field/property blah on System\.String can't be resolved\.\r?\n" - (defn foo [^String x] (.blah x)))) - (testing "reflection cannot resolve instance method because it is missing" - (should-print-err-message - #"Reflection warning, .*:\d+:\d+ - call to method zap on System\.String can't be resolved \(no such method\)\.\r?\n" - (defn foo [^String x] (.zap x 1)))) - (testing "reflection cannot resolve instance method because it has incompatible argument types" - (should-print-err-message - #"Reflection warning, .*:\d+:\d+ - call to method IndexOf on System\.String can't be resolved \(argument types: System\.Double, clojure\.lang\.Symbol\)\.\r?\n" - (defn foo [^String x] (.IndexOf x 12.1 'a)))) - (testing "reflection cannot resolve instance method because it has unknown argument types" - (should-print-err-message - #"Reflection warning, .*:\d+:\d+ - call to method IndexOf on System\.String can't be resolved \(argument types: unknown\)\.\r?\n" - (defn foo [^String x y] (.IndexOf x y)))) - (testing "reflection error prints correctly for nil arguments" - (should-print-err-message - #"Reflection warning, .*:\d+:\d+ - call to method IndexOf on System.String can't be resolved \(argument types: unknown, unknown\)\.\r?\n" ;;; divide on java\.math\.BigDecimal - (defn foo [a] (.IndexOf "abc" a nil)))) ;;; .(.Divide 1M a nil) -- we don't have an overload on this - (testing "reflection cannot resolve instance method because target class is unknown" - (should-print-err-message + #"Reflection warning, .*:\d+:\d+ - reference to field/property blah on System\.String can't be resolved\.\r?\n" + (defn foo [^String x] (.blah x)))) + (testing "reflection cannot resolve instance method because it is missing" + (should-print-err-message + #"Reflection warning, .*:\d+:\d+ - call to method zap on System\.String can't be resolved \(no such method\)\.\r?\n" + (defn foo [^String x] (.zap x 1)))) + (testing "reflection cannot resolve instance method because it has incompatible argument types" + (should-print-err-message + #"Reflection warning, .*:\d+:\d+ - call to method IndexOf on System\.String can't be resolved \(argument types: System\.Double, clojure\.lang\.Symbol\)\.\r?\n" + (defn foo [^String x] (.IndexOf x 12.1 'a)))) + (testing "reflection cannot resolve instance method because it has unknown argument types" + (should-print-err-message + #"Reflection warning, .*:\d+:\d+ - call to method IndexOf on System\.String can't be resolved \(argument types: unknown\)\.\r?\n" + (defn foo [^String x y] (.IndexOf x y)))) + (testing "reflection error prints correctly for nil arguments" + (should-print-err-message + #"Reflection warning, .*:\d+:\d+ - call to method IndexOf on System.String can't be resolved \(argument types: unknown, unknown\)\.\r?\n" ;;; divide on java\.math\.BigDecimal + (defn foo [a] (.IndexOf "abc" a nil)))) ;;; .(.Divide 1M a nil) -- we don't have an overload on this + (testing "reflection cannot resolve instance method because target class is unknown" + (should-print-err-message #"Reflection warning, .*:\d+:\d+ - call to method zap can't be resolved \(target class is unknown\)\.\r?\n" (defn foo [x] (.zap x 1)))) (testing "reflection cannot resolve static method" @@ -76,28 +76,28 @@ (.bindRoot #'example-var 0) (is (not (contains? (meta #'example-var) :macro)))) -(deftest ns-intern-policies - (testing "you can replace a core name, with warning" - (let [ns (temp-ns) - replacement (gensym) - e1 (with-err-string-writer (intern ns 'prefers replacement))] - (is (string/starts-with? e1 "WARNING")) - (is (= replacement @('prefers (ns-publics ns)))))) - (testing "you can replace a defined alias" - (let [ns (temp-ns) - s (gensym) - v1 (intern ns 'foo s) - v2 (intern ns 'bar s) - e1 (with-err-string-writer (.refer ns 'flatten v1)) - e2 (with-err-string-writer (.refer ns 'flatten v2))] - (is (string/starts-with? e1 "WARNING")) - (is (string/starts-with? e2 "WARNING")) - (is (= v2 (ns-resolve ns 'flatten))))) - (testing "you cannot replace an interned var" - (let [ns1 (temp-ns) - ns2 (temp-ns) - v1 (intern ns1 'foo 1) - v2 (intern ns2 'foo 2) - e1 (with-err-string-writer (.refer ns1 'foo v2))] - (is (string/starts-with? e1 "REJECTED")) - (is (= v1 (ns-resolve ns1 'foo)))))) +(deftest ns-intern-policies + (testing "you can replace a core name, with warning" + (let [ns (temp-ns) + replacement (gensym) + e1 (with-err-string-writer (intern ns 'prefers replacement))] + (is (string/starts-with? e1 "WARNING")) + (is (= replacement @('prefers (ns-publics ns)))))) + (testing "you can replace a defined alias" + (let [ns (temp-ns) + s (gensym) + v1 (intern ns 'foo s) + v2 (intern ns 'bar s) + e1 (with-err-string-writer (.refer ns 'flatten v1)) + e2 (with-err-string-writer (.refer ns 'flatten v2))] + (is (string/starts-with? e1 "WARNING")) + (is (string/starts-with? e2 "WARNING")) + (is (= v2 (ns-resolve ns 'flatten))))) + (testing "you cannot replace an interned var" + (let [ns1 (temp-ns) + ns2 (temp-ns) + v1 (intern ns1 'foo 1) + v2 (intern ns2 'foo 2) + e1 (with-err-string-writer (.refer ns1 'foo v2))] + (is (string/starts-with? e1 "REJECTED")) + (is (= v1 (ns-resolve ns1 'foo)))))) diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/sequences.clj b/Clojure/Clojure.Tests/clojure/test_clojure/sequences.clj index 806db6c22..ef64b763e 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/sequences.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/sequences.clj @@ -10,10 +10,10 @@ ; Contributors: Stuart Halloway (ns clojure.test-clojure.sequences - (:require [clojure.test :refer :all] - [clojure.test.check.generators :as gen] - [clojure.test.check.properties :as prop] - [clojure.test.check.clojure-test :refer (defspec)]) + (:require [clojure.test :refer :all] + [clojure.test.check.generators :as gen] + [clojure.test.check.properties :as prop] + [clojure.test.check.clojure-test :refer (defspec)]) (:import clojure.lang.IReduce)) ;; *** Tests *** @@ -84,23 +84,23 @@ (reduce #(and %1 %2) all-true) (reduce #(and %1 %2) true all-true))))) -(deftest test-into-IReduceInit - (let [iri (reify clojure.lang.IReduceInit - (reduce [_ f start] - (reduce f start (range 5))))] - (is (= [0 1 2 3 4] (into [] iri))))) - -;; CLJ-1237 regression test -(deftest reduce-with-varying-impls - (is (= 1000000 - (->> (repeat 500000 (cons 1 [1])) - (apply concat) - (reduce +)))) - - (is (= 4500000 - (->> (range 100000) - (mapcat (fn [_] (System.Collections.ArrayList. (range 10)))) ;;; java.util.ArrayList. - (reduce +))))) +(deftest test-into-IReduceInit + (let [iri (reify clojure.lang.IReduceInit + (reduce [_ f start] + (reduce f start (range 5))))] + (is (= [0 1 2 3 4] (into [] iri))))) + +;; CLJ-1237 regression test +(deftest reduce-with-varying-impls + (is (= 1000000 + (->> (repeat 500000 (cons 1 [1])) + (apply concat) + (reduce +)))) + + (is (= 4500000 + (->> (range 100000) + (mapcat (fn [_] (System.Collections.ArrayList. (range 10)))) ;;; java.util.ArrayList. + (reduce +))))) (deftest test-equality ; lazy sequences @@ -112,7 +112,7 @@ (map inc []) () (map inc #{}) () (map inc {}) () - (sequence (map inc) (range 10)) (range 1 11) + (sequence (map inc) (range 10)) (range 1 11) (range 1 11) (sequence (map inc) (range 10)))) @@ -713,10 +713,10 @@ (interleave [] [3 4]) () (interleave [1 2] []) () - (interleave [] []) () - - (interleave [1]) '(1) - + (interleave [] []) () + + (interleave [1]) '(1) + (interleave) () )) @@ -754,15 +754,15 @@ (take 3 (cycle [1])) '(1 1 1) (take 5 (cycle [1 2 3])) '(1 2 3 1 2) - (take 3 (cycle [nil])) '(nil nil nil) - - (transduce (take 5) + (cycle [1])) 5 - (transduce (take 5) + 2 (cycle [1])) 7 - (transduce (take 5) + (cycle [3 7])) 23 - (transduce (take 5) + 2 (cycle [3 7])) 25 - - (take 2 (cycle (map #(/ 42 %) '(2 1 0)))) '(21 42) - (first (next (cycle (map #(/ 42 %) '(2 1 0))))) 42 + (take 3 (cycle [nil])) '(nil nil nil) + + (transduce (take 5) + (cycle [1])) 5 + (transduce (take 5) + 2 (cycle [1])) 7 + (transduce (take 5) + (cycle [3 7])) 23 + (transduce (take 5) + 2 (cycle [3 7])) 25 + + (take 2 (cycle (map #(/ 42 %) '(2 1 0)))) '(21 42) + (first (next (cycle (map #(/ 42 %) '(2 1 0))))) 42 (into [] (take 2) (cycle (map #(/ 42 %) '(2 1 0)))) '(21 42))) @@ -785,56 +785,56 @@ ; (partition 0 [1 2 3]) (repeat nil) ; infinite sequence of nil (partition -1 [1 2 3]) () - (partition -2 [1 2 3]) () ) - - ;; reduce - (is (= [1 2 4 8 16] (map #(reduce * (repeat % 2)) (range 5)))) - (is (= [3 6 12 24 48] (map #(reduce * 3 (repeat % 2)) (range 5)))) - - ;; equality and hashing - (is (= (repeat 5 :x) (repeat 5 :x))) - (is (= (repeat 5 :x) '(:x :x :x :x :x))) - (is (= (hash (repeat 5 :x)) (hash '(:x :x :x :x :x)))) - (is (= (assoc (array-map (repeat 1 :x) :y) '(:x) :z) {'(:x) :z})) - (is (= (assoc (hash-map (repeat 1 :x) :y) '(:x) :z) {'(:x) :z}))) - -(deftest test-partitionv - (are [x y] (= x y) - (partitionv 2 [1 2 3]) '((1 2)) - (partitionv 2 [1 2 3 4]) '((1 2) (3 4)) - (partitionv 2 []) () - - (partitionv 2 3 [1 2 3 4 5 6 7]) '((1 2) (4 5)) - (partitionv 2 3 [1 2 3 4 5 6 7 8]) '((1 2) (4 5) (7 8)) - (partitionv 2 3 []) () - - (partitionv 1 []) () - (partitionv 1 [1 2 3]) '((1) (2) (3)) - - (partitionv 4 4 [0 0 0] (range 10)) '([0 1 2 3] [4 5 6 7] [8 9 0 0]) - - (partitionv 5 [1 2 3]) () - - (partitionv -1 [1 2 3]) () - (partitionv -2 [1 2 3]) () )) - -(deftest test-iterate - (are [x y] (= x y) - (take 0 (iterate inc 0)) () - (take 1 (iterate inc 0)) '(0) - (take 2 (iterate inc 0)) '(0 1) - (take 5 (iterate inc 0)) '(0 1 2 3 4) ) - - ;; test other fns - (is (= '(:foo 42 :foo 42) (take 4 (iterate #(if (= % :foo) 42 :foo) :foo)))) - (is (= '(1 false true true) (take 4 (iterate #(instance? Boolean %) 1)))) - (is (= '(256 128 64 32 16 8 4 2 1 0) (take 10 (iterate #(quot % 2) 256)))) - (is (= '(0 true) (take 2 (iterate zero? 0)))) - (is (= 2 (first (next (next (iterate inc 0)))))) - (is (= [1 2 3] (into [] (take 3) (next (iterate inc 0))))) - - ;; reduce via transduce - (is (= (transduce (take 5) + (iterate #(* 2 %) 2)) 62)) + (partition -2 [1 2 3]) () ) + + ;; reduce + (is (= [1 2 4 8 16] (map #(reduce * (repeat % 2)) (range 5)))) + (is (= [3 6 12 24 48] (map #(reduce * 3 (repeat % 2)) (range 5)))) + + ;; equality and hashing + (is (= (repeat 5 :x) (repeat 5 :x))) + (is (= (repeat 5 :x) '(:x :x :x :x :x))) + (is (= (hash (repeat 5 :x)) (hash '(:x :x :x :x :x)))) + (is (= (assoc (array-map (repeat 1 :x) :y) '(:x) :z) {'(:x) :z})) + (is (= (assoc (hash-map (repeat 1 :x) :y) '(:x) :z) {'(:x) :z}))) + +(deftest test-partitionv + (are [x y] (= x y) + (partitionv 2 [1 2 3]) '((1 2)) + (partitionv 2 [1 2 3 4]) '((1 2) (3 4)) + (partitionv 2 []) () + + (partitionv 2 3 [1 2 3 4 5 6 7]) '((1 2) (4 5)) + (partitionv 2 3 [1 2 3 4 5 6 7 8]) '((1 2) (4 5) (7 8)) + (partitionv 2 3 []) () + + (partitionv 1 []) () + (partitionv 1 [1 2 3]) '((1) (2) (3)) + + (partitionv 4 4 [0 0 0] (range 10)) '([0 1 2 3] [4 5 6 7] [8 9 0 0]) + + (partitionv 5 [1 2 3]) () + + (partitionv -1 [1 2 3]) () + (partitionv -2 [1 2 3]) () )) + +(deftest test-iterate + (are [x y] (= x y) + (take 0 (iterate inc 0)) () + (take 1 (iterate inc 0)) '(0) + (take 2 (iterate inc 0)) '(0 1) + (take 5 (iterate inc 0)) '(0 1 2 3 4) ) + + ;; test other fns + (is (= '(:foo 42 :foo 42) (take 4 (iterate #(if (= % :foo) 42 :foo) :foo)))) + (is (= '(1 false true true) (take 4 (iterate #(instance? Boolean %) 1)))) + (is (= '(256 128 64 32 16 8 4 2 1 0) (take 10 (iterate #(quot % 2) 256)))) + (is (= '(0 true) (take 2 (iterate zero? 0)))) + (is (= 2 (first (next (next (iterate inc 0)))))) + (is (= [1 2 3] (into [] (take 3) (next (iterate inc 0))))) + + ;; reduce via transduce + (is (= (transduce (take 5) + (iterate #(* 2 %) 2)) 62)) (is (= (transduce (take 5) + 1 (iterate #(* 2 %) 2)) 63)) ) @@ -1007,18 +1007,18 @@ () '(1 2) [] [1 2] {} {:a 1 :b 2} - #{} #{1 2}) - - ; CLJ-2718 - (is (= '(:a) (drop 1 (repeat 2 :a)))) - (is (= () (drop 2 (repeat 2 :a)))) + #{} #{1 2}) + + ; CLJ-2718 + (is (= '(:a) (drop 1 (repeat 2 :a)))) + (is (= () (drop 2 (repeat 2 :a)))) (is (= () (drop 3 (repeat 2 :a))))) -(defspec longrange-equals-range 1000 - (prop/for-all [start gen/int - end gen/int - step gen/s-pos-int] - (= (clojure.lang.Range/create start end step) +(defspec longrange-equals-range 1000 + (prop/for-all [start gen/int + end gen/int + step gen/s-pos-int] + (= (clojure.lang.Range/create start end step) (clojure.lang.LongRange/create start end step)))) (deftest test-range @@ -1053,96 +1053,96 @@ (range -2 -2) () (range -2 -5) () - (take 3 (range 3 9 0)) '(3 3 3) - (take 3 (range 9 3 0)) '(9 9 9) + (take 3 (range 3 9 0)) '(3 3 3) + (take 3 (range 9 3 0)) '(9 9 9) (range 0 0 0) () (range 3 9 1) '(3 4 5 6 7 8) (range 3 9 2) '(3 5 7) (range 3 9 3) '(3 6) (range 3 9 10) '(3) - (range 3 9 -1) () - (range 10 10 -1) () - (range 10 9 -1) '(10) - (range 10 8 -1) '(10 9) - (range 10 7 -1) '(10 9 8) - (range 10 0 -2) '(10 8 6 4 2) - - (take 100 (range)) (take 100 (iterate inc 0)) - - (range 1/2 5 1/3) '(1/2 5/6 7/6 3/2 11/6 13/6 5/2 17/6 19/6 7/2 23/6 25/6 9/2 29/6) - (range 0.5 8 1.2) '(0.5 1.7 2.9 4.1 5.3 6.5 7.7) - (range 0.5 -4 -2) '(0.5 -1.5 -3.5) - (take 3 (range Int64/MaxValue Double/PositiveInfinity)) '(9223372036854775807 9223372036854775808N 9223372036854775809N) ;;; Long/MAX_VALUE Double/POSITIVE_INFINITY - - (reduce + (take 100 (range))) 4950 - (reduce + 0 (take 100 (range))) 4950 - (reduce + (range 100)) 4950 - (reduce + 0 (range 100)) 4950 - (reduce + (range 0.0 100.0)) 4950.0 - (reduce + 0 (range 0.0 100.0)) 4950.0 - - (reduce + (iterator-seq (.GetEnumerator (range 100)))) 4950 ;;; .iterator + (range 3 9 -1) () + (range 10 10 -1) () + (range 10 9 -1) '(10) + (range 10 8 -1) '(10 9) + (range 10 7 -1) '(10 9 8) + (range 10 0 -2) '(10 8 6 4 2) + + (take 100 (range)) (take 100 (iterate inc 0)) + + (range 1/2 5 1/3) '(1/2 5/6 7/6 3/2 11/6 13/6 5/2 17/6 19/6 7/2 23/6 25/6 9/2 29/6) + (range 0.5 8 1.2) '(0.5 1.7 2.9 4.1 5.3 6.5 7.7) + (range 0.5 -4 -2) '(0.5 -1.5 -3.5) + (take 3 (range Int64/MaxValue Double/PositiveInfinity)) '(9223372036854775807 9223372036854775808N 9223372036854775809N) ;;; Long/MAX_VALUE Double/POSITIVE_INFINITY + + (reduce + (take 100 (range))) 4950 + (reduce + 0 (take 100 (range))) 4950 + (reduce + (range 100)) 4950 + (reduce + 0 (range 100)) 4950 + (reduce + (range 0.0 100.0)) 4950.0 + (reduce + 0 (range 0.0 100.0)) 4950.0 + + (reduce + (iterator-seq (.GetEnumerator (range 100)))) 4950 ;;; .iterator (reduce + (iterator-seq (.GetEnumerator (range 0.0 100.0 1.0)))) 4950.0 )) ;;; .iterator -(deftest range-meta - (are [r] (= r (with-meta r {:a 1})) - (range 10) - (range 5 10) - (range 5 10 1) - (range 10.0) - (range 5.0 10.0) - (range 5.0 10.0 1.0))) - -(deftest range-test - (let [threads 10 - n 1000 - r (atom (range (inc n))) - m (atom 0)] - ; Iterate through the range concurrently, - ; updating m to the highest seen value in the range - (->> (range threads) - (map (fn [id] - (future - (loop [] - (when-let [r (swap! r next)] - (swap! m max (first r)) - (recur)))))) - (map deref) - dorun) - (is (= n @m)))) - -(defn unlimited-range-create [& args] - (let [[arg1 arg2 arg3] args] - (case (count args) - 1 (clojure.lang.Range/create arg1) - 2 (clojure.lang.Range/create arg1 arg2) - 3 (clojure.lang.Range/create arg1 arg2 arg3)))) - -(deftest test-longrange-corners - (let [lmax Int64/MaxValue ;;; Long/MAX_VALUE - lmax-1 (- Int64/MaxValue 1) ;;; Long/MAX_VALUE - lmax-2 (- Int64/MaxValue 2) ;;; Long/MAX_VALUE - lmax-31 (- Int64/MaxValue 31) ;;; Long/MAX_VALUE - lmax-32 (- Int64/MaxValue 32) ;;; Long/MAX_VALUE - lmax-33 (- Int64/MaxValue 33) ;;; Long/MAX_VALUE - lmin Int64/MinValue ;;; Long/MIN_VALUE - lmin+1 (+ Int64/MinValue 1) ;;; Long/MIN_VALUE - lmin+2 (+ Int64/MinValue 2) ;;; Long/MIN_VALUE - lmin+31 (+ Int64/MinValue 31) ;;; Long/MIN_VALUE - lmin+32 (+ Int64/MinValue 32) ;;; Long/MIN_VALUE - lmin+33 (+ Int64/MinValue 33)] - (doseq [range-args [ [lmax-2 lmax] - [lmax-33 lmax] - [lmax-33 lmax-31] - [lmin+2 lmin -1] - [lmin+33 lmin -1] - [lmin+33 lmin+31 -1] - [lmin lmax lmax] - [lmax lmin lmin] - [-1 lmax lmax] - [1 lmin lmin]]] - (is (= (apply unlimited-range-create range-args) - (apply range range-args)) +(deftest range-meta + (are [r] (= r (with-meta r {:a 1})) + (range 10) + (range 5 10) + (range 5 10 1) + (range 10.0) + (range 5.0 10.0) + (range 5.0 10.0 1.0))) + +(deftest range-test + (let [threads 10 + n 1000 + r (atom (range (inc n))) + m (atom 0)] + ; Iterate through the range concurrently, + ; updating m to the highest seen value in the range + (->> (range threads) + (map (fn [id] + (future + (loop [] + (when-let [r (swap! r next)] + (swap! m max (first r)) + (recur)))))) + (map deref) + dorun) + (is (= n @m)))) + +(defn unlimited-range-create [& args] + (let [[arg1 arg2 arg3] args] + (case (count args) + 1 (clojure.lang.Range/create arg1) + 2 (clojure.lang.Range/create arg1 arg2) + 3 (clojure.lang.Range/create arg1 arg2 arg3)))) + +(deftest test-longrange-corners + (let [lmax Int64/MaxValue ;;; Long/MAX_VALUE + lmax-1 (- Int64/MaxValue 1) ;;; Long/MAX_VALUE + lmax-2 (- Int64/MaxValue 2) ;;; Long/MAX_VALUE + lmax-31 (- Int64/MaxValue 31) ;;; Long/MAX_VALUE + lmax-32 (- Int64/MaxValue 32) ;;; Long/MAX_VALUE + lmax-33 (- Int64/MaxValue 33) ;;; Long/MAX_VALUE + lmin Int64/MinValue ;;; Long/MIN_VALUE + lmin+1 (+ Int64/MinValue 1) ;;; Long/MIN_VALUE + lmin+2 (+ Int64/MinValue 2) ;;; Long/MIN_VALUE + lmin+31 (+ Int64/MinValue 31) ;;; Long/MIN_VALUE + lmin+32 (+ Int64/MinValue 32) ;;; Long/MIN_VALUE + lmin+33 (+ Int64/MinValue 33)] + (doseq [range-args [ [lmax-2 lmax] + [lmax-33 lmax] + [lmax-33 lmax-31] + [lmin+2 lmin -1] + [lmin+33 lmin -1] + [lmin+33 lmin+31 -1] + [lmin lmax lmax] + [lmax lmin lmin] + [-1 lmax lmax] + [1 lmin lmin]]] + (is (= (apply unlimited-range-create range-args) + (apply range range-args)) (apply str "from (range " (concat (interpose " " range-args) ")")))))) (deftest test-empty? @@ -1154,9 +1154,9 @@ {} #{} "" - (into-array []) - (transient []) - (transient #{}) + (into-array []) + (transient []) + (transient #{}) (transient {})) (are [x] (not (empty? x)) @@ -1166,9 +1166,9 @@ {:a 1 :b 2} #{1 2} "abc" - (into-array [1 2]) - (transient [1]) - (transient #{1}) + (into-array [1 2]) + (transient [1]) + (transient #{1}) (transient {1 2}))) @@ -1328,9 +1328,9 @@ ["a" "bb" "cccc" "dd" "eee" "f" "" "hh"] '("a" "bb" "cccc" "dd" "eee" "f" "" "hh")) (is (=(partition-by #{\a \e \i \o \u} "abcdefghijklm") - [[\a] [\b \c \d] [\e] [\f \g \h] [\i] [\j \k \l \m]])) - ;; CLJ-1764 regression test - (is (=(first (second (partition-by zero? (range)))) + [[\a] [\b \c \d] [\e] [\f \g \h] [\i] [\j \k \l \m]])) + ;; CLJ-1764 regression test + (is (=(first (second (partition-by zero? (range)))) 1))) (deftest test-frequencies @@ -1347,20 +1347,20 @@ (is (= (reductions + 10 [1 2 3 4 5]) [10 11 13 16 20 25]))) -(deftest test-reductions-obeys-reduced - (is (= [0 :x] - (reductions (constantly (reduced :x)) - (range)))) - (is (= [:x] - (reductions (fn [acc x] x) - (reduced :x) - (range)))) - (is (= [2 6 12 12] - (reductions (fn [acc x] - (if (= x :stop) - (reduced acc) - (+ acc x))) - [2 4 6 :stop 8 10])))) +(deftest test-reductions-obeys-reduced + (is (= [0 :x] + (reductions (constantly (reduced :x)) + (range)))) + (is (= [:x] + (reductions (fn [acc x] x) + (reduced :x) + (range)))) + (is (= [2 6 12 12] + (reductions (fn [acc x] + (if (= x :stop) + (reduced acc) + (+ acc x))) + [2 4 6 :stop 8 10])))) (deftest test-rand-nth-invariants (let [elt (rand-nth [:a :b :c :d])] @@ -1372,10 +1372,10 @@ (is (= (partition-all 4 2 [1 2 3 4 5 6 7 8 9]) [[1 2 3 4] [3 4 5 6] [5 6 7 8] [7 8 9] [9]]))) -(deftest test-partitionv-all - (is (= (partitionv-all 4 [1 2 3 4 5 6 7 8 9]) - [[1 2 3 4] [5 6 7 8] [9]])) - (is (= (partitionv-all 4 2 [1 2 3 4 5 6 7 8 9]) +(deftest test-partitionv-all + (is (= (partitionv-all 4 [1 2 3 4 5 6 7 8 9]) + [[1 2 3 4] [5 6 7 8] [9]])) + (is (= (partitionv-all 4 2 [1 2 3 4 5 6 7 8 9]) [[1 2 3 4] [3 4 5 6] [5 6 7 8] [7 8 9] [9]]))) (deftest test-shuffle-invariants @@ -1383,174 +1383,174 @@ (let [shuffled-seq (shuffle [1 2 3 4])] (is (every? #{1 2 3 4} shuffled-seq)))) -(deftest test-ArrayIter - (are [arr expected] - (let [iter (clojure.lang.ArrayIter/createFromObject arr)] - (loop [accum []] - (if (.MoveNext iter) ;;; .hasNext - (recur (conj accum (.Current iter))) ;;; .next - (is (= expected accum))))) - nil [] - (object-array ["a" "b" "c"]) ["a" "b" "c"] - (boolean-array [false true false]) [false true false] - (byte-array [1 2]) [(byte 1) (byte 2)] - (short-array [1 2]) [1 2] - (int-array [1 2]) [1 2] - (long-array [1 2]) [1 2] - (float-array [2.0 -2.5]) [2.0 -2.5] - (double-array [1.2 -3.5]) [1.2 -3.5] - (char-array [\H \i]) [\H \i])) - -(deftest CLJ-1633 - (is (= ((fn [& args] (apply (fn [a & b] (apply list b)) args)) 1 2 3) '(2 3)))) - -(deftest test-subseq - (let [s1 (range 100) - s2 (into (sorted-set) s1)] - (is (= s1 (seq s2))) - (doseq [i (range 100)] - (is (= s1 (concat (subseq s2 < i) (subseq s2 >= i)))) - (is (= (reverse s1) (concat (rsubseq s2 >= i) (rsubseq s2 < i))))))) - -(deftest test-sort-retains-meta - (is (= {:a true} (meta (sort (with-meta (range 10) {:a true}))))) - (is (= {:a true} (meta (sort-by :a (with-meta (seq [{:a 5} {:a 2} {:a 3}]) {:a true})))))) - -(deftest test-seqs-implements-iobj - (doseq [coll [[1 2 3] - (vector-of :long 1 2 3) - {:a 1 :b 2 :c 3} - (sorted-map :a 1 :b 2 :c 3) - #{1 2 3} - (sorted-set 1 2 3) - (into clojure.lang.PersistentQueue/EMPTY [1 2 3])]] - (is (= true (instance? clojure.lang.IMeta coll))) - (is (= {:a true} (meta (with-meta coll {:a true})))) - (is (= true (instance? clojure.lang.IMeta (seq coll)))) - (is (= {:a true} (meta (with-meta (seq coll) {:a true})))) - (when (reversible? coll) - (is (= true (instance? clojure.lang.IMeta (rseq coll)))) - (is (= {:a true} (meta (with-meta (rseq coll) {:a true}))))))) - -(deftest test-iteration-opts - (let [genstep (fn [steps] - (fn [k] (swap! steps inc) (inc k))) - test (fn [expect & iteropts] - (is (= expect - (let [nsteps (atom 0) - iter (apply iteration (genstep nsteps) iteropts) - ret (doall (seq iter))] - {:ret ret :steps @nsteps}) - (let [nsteps (atom 0) - iter (apply iteration (genstep nsteps) iteropts) - ret (into [] iter)] - {:ret ret :steps @nsteps}))))] - (test {:ret [1 2 3 4] - :steps 5} - :initk 0 :somef #(< % 5)) - (test {:ret [1 2 3 4 5] - :steps 5} - :initk 0 :kf (fn [ret] (when (< ret 5) ret))) - (test {:ret ["1"] - :steps 2} - :initk 0 :somef #(< % 2) :vf str)) - - ;; kf does not stop on false - (let [iter #(iteration (fn [k] - (if (boolean? k) - [10 :boolean] - [k k])) - :vf second - :kf (fn [[k v]] - (cond - (= k 3) false - (< k 14) (inc k))) - :initk 0)] - (is (= [0 1 2 3 :boolean 11 12 13 14] - (into [] (iter)) - (seq (iter)))))) - -(deftest test-iteration - ;; equivalence to line-seq - (let [readme #(.OpenText (System.IO.FileInfo. "clojure\\edn.clj")) ] ;;; #(java.nio.file.Files/newBufferedReader (.toPath (java.io.File. "readme.txt"))) - (is (= (with-open [r (readme)] - (vec (iteration (fn [_] (.ReadLine r))))) ;;; .readLine - (with-open [r (readme)] - (doall (line-seq r)))))) - - ;; paginated API - (let [items 12 pgsize 5 - src (vec (repeatedly items #(System.Guid/NewGuid))) ;;; java.util.UUID/randomUUID - api (fn [tok] - (let [tok (or tok 0)] - (when (< tok items) - {:tok (+ tok pgsize) - :ret (subvec src tok (min (+ tok pgsize) items))})))] - (is (= src - (mapcat identity (iteration api :kf :tok :vf :ret)) - (into [] cat (iteration api :kf :tok :vf :ret))))) - - (let [src [:a :b :c :d :e] - api (fn [k] - (let [k (or k 0)] - (if (< k (count src)) - {:item (nth src k) - :k (inc k)})))] - (is (= [:a :b :c] - (vec (iteration api - :somef (comp #{:a :b :c} :item) - :kf :k - :vf :item)) - (vec (iteration api - :kf #(some-> % :k #{0 1 2}) - :vf :item)))))) - -(deftest test-reduce-on-coll-seqs - ;; reduce on seq of coll, both with and without an init - (are [coll expected expected-init] - (and - (= expected-init (reduce conj [:init] (seq coll))) - (= expected (reduce conj (seq coll)))) - ;; (seq [ ... ]) - [] [] [:init] - [1] 1 [:init 1] - [[1] 2] [1 2] [:init [1] 2] - - ;; (seq { ... }) - {} [] [:init] - {1 1} [1 1] [:init [1 1]] - {1 1 2 2} [1 1 [2 2]] [:init [1 1] [2 2]] - - ;; (seq (hash-map ... )) - (hash-map) [] [:init] - (hash-map 1 1) [1 1] [:init [1 1]] - (hash-map 1 1 2 2) [1 1 [2 2]] [:init [1 1] [2 2]] - - ;; (seq (sorted-map ... )) - (sorted-map) [] [:init] - (sorted-map 1 1) [1 1] [:init [1 1]] - (sorted-map 1 1 2 2) [1 1 [2 2]] [:init [1 1] [2 2]]) - - (are [coll expected expected-init] - (and - (= expected-init (reduce + 100 (seq coll))) - (= expected (reduce + (seq coll)))) - - ;; (seq (range ...)) - (range 0) 0 100 - (range 1 2) 1 101 - (range 1 3) 3 103)) -(compile-when (>= (.CompareTo dotnet-version "6") 0) -(defspec iteration-seq-equals-reduce 1000 - (prop/for-all [initk gen/int - seed gen/int] - (let [src (fn [] - (let [rng (System.Random. seed)] ;;; java.util.Random. - (iteration #(unchecked-add % (.NextInt64 rng)) ;;; .nextLong - :somef (complement #(zero? (mod % 1000))) - :vf str - :initk initk)))] - (= (into [] (src)) - (into [] (seq (src))))))) - +(deftest test-ArrayIter + (are [arr expected] + (let [iter (clojure.lang.ArrayIter/createFromObject arr)] + (loop [accum []] + (if (.MoveNext iter) ;;; .hasNext + (recur (conj accum (.Current iter))) ;;; .next + (is (= expected accum))))) + nil [] + (object-array ["a" "b" "c"]) ["a" "b" "c"] + (boolean-array [false true false]) [false true false] + (byte-array [1 2]) [(byte 1) (byte 2)] + (short-array [1 2]) [1 2] + (int-array [1 2]) [1 2] + (long-array [1 2]) [1 2] + (float-array [2.0 -2.5]) [2.0 -2.5] + (double-array [1.2 -3.5]) [1.2 -3.5] + (char-array [\H \i]) [\H \i])) + +(deftest CLJ-1633 + (is (= ((fn [& args] (apply (fn [a & b] (apply list b)) args)) 1 2 3) '(2 3)))) + +(deftest test-subseq + (let [s1 (range 100) + s2 (into (sorted-set) s1)] + (is (= s1 (seq s2))) + (doseq [i (range 100)] + (is (= s1 (concat (subseq s2 < i) (subseq s2 >= i)))) + (is (= (reverse s1) (concat (rsubseq s2 >= i) (rsubseq s2 < i))))))) + +(deftest test-sort-retains-meta + (is (= {:a true} (meta (sort (with-meta (range 10) {:a true}))))) + (is (= {:a true} (meta (sort-by :a (with-meta (seq [{:a 5} {:a 2} {:a 3}]) {:a true})))))) + +(deftest test-seqs-implements-iobj + (doseq [coll [[1 2 3] + (vector-of :long 1 2 3) + {:a 1 :b 2 :c 3} + (sorted-map :a 1 :b 2 :c 3) + #{1 2 3} + (sorted-set 1 2 3) + (into clojure.lang.PersistentQueue/EMPTY [1 2 3])]] + (is (= true (instance? clojure.lang.IMeta coll))) + (is (= {:a true} (meta (with-meta coll {:a true})))) + (is (= true (instance? clojure.lang.IMeta (seq coll)))) + (is (= {:a true} (meta (with-meta (seq coll) {:a true})))) + (when (reversible? coll) + (is (= true (instance? clojure.lang.IMeta (rseq coll)))) + (is (= {:a true} (meta (with-meta (rseq coll) {:a true}))))))) + +(deftest test-iteration-opts + (let [genstep (fn [steps] + (fn [k] (swap! steps inc) (inc k))) + test (fn [expect & iteropts] + (is (= expect + (let [nsteps (atom 0) + iter (apply iteration (genstep nsteps) iteropts) + ret (doall (seq iter))] + {:ret ret :steps @nsteps}) + (let [nsteps (atom 0) + iter (apply iteration (genstep nsteps) iteropts) + ret (into [] iter)] + {:ret ret :steps @nsteps}))))] + (test {:ret [1 2 3 4] + :steps 5} + :initk 0 :somef #(< % 5)) + (test {:ret [1 2 3 4 5] + :steps 5} + :initk 0 :kf (fn [ret] (when (< ret 5) ret))) + (test {:ret ["1"] + :steps 2} + :initk 0 :somef #(< % 2) :vf str)) + + ;; kf does not stop on false + (let [iter #(iteration (fn [k] + (if (boolean? k) + [10 :boolean] + [k k])) + :vf second + :kf (fn [[k v]] + (cond + (= k 3) false + (< k 14) (inc k))) + :initk 0)] + (is (= [0 1 2 3 :boolean 11 12 13 14] + (into [] (iter)) + (seq (iter)))))) + +(deftest test-iteration + ;; equivalence to line-seq + (let [readme #(.OpenText (System.IO.FileInfo. "clojure\\edn.clj")) ] ;;; #(java.nio.file.Files/newBufferedReader (.toPath (java.io.File. "readme.txt"))) + (is (= (with-open [r (readme)] + (vec (iteration (fn [_] (.ReadLine r))))) ;;; .readLine + (with-open [r (readme)] + (doall (line-seq r)))))) + + ;; paginated API + (let [items 12 pgsize 5 + src (vec (repeatedly items #(System.Guid/NewGuid))) ;;; java.util.UUID/randomUUID + api (fn [tok] + (let [tok (or tok 0)] + (when (< tok items) + {:tok (+ tok pgsize) + :ret (subvec src tok (min (+ tok pgsize) items))})))] + (is (= src + (mapcat identity (iteration api :kf :tok :vf :ret)) + (into [] cat (iteration api :kf :tok :vf :ret))))) + + (let [src [:a :b :c :d :e] + api (fn [k] + (let [k (or k 0)] + (if (< k (count src)) + {:item (nth src k) + :k (inc k)})))] + (is (= [:a :b :c] + (vec (iteration api + :somef (comp #{:a :b :c} :item) + :kf :k + :vf :item)) + (vec (iteration api + :kf #(some-> % :k #{0 1 2}) + :vf :item)))))) + +(deftest test-reduce-on-coll-seqs + ;; reduce on seq of coll, both with and without an init + (are [coll expected expected-init] + (and + (= expected-init (reduce conj [:init] (seq coll))) + (= expected (reduce conj (seq coll)))) + ;; (seq [ ... ]) + [] [] [:init] + [1] 1 [:init 1] + [[1] 2] [1 2] [:init [1] 2] + + ;; (seq { ... }) + {} [] [:init] + {1 1} [1 1] [:init [1 1]] + {1 1 2 2} [1 1 [2 2]] [:init [1 1] [2 2]] + + ;; (seq (hash-map ... )) + (hash-map) [] [:init] + (hash-map 1 1) [1 1] [:init [1 1]] + (hash-map 1 1 2 2) [1 1 [2 2]] [:init [1 1] [2 2]] + + ;; (seq (sorted-map ... )) + (sorted-map) [] [:init] + (sorted-map 1 1) [1 1] [:init [1 1]] + (sorted-map 1 1 2 2) [1 1 [2 2]] [:init [1 1] [2 2]]) + + (are [coll expected expected-init] + (and + (= expected-init (reduce + 100 (seq coll))) + (= expected (reduce + (seq coll)))) + + ;; (seq (range ...)) + (range 0) 0 100 + (range 1 2) 1 101 + (range 1 3) 3 103)) +(compile-when (>= (.CompareTo dotnet-version "6") 0) +(defspec iteration-seq-equals-reduce 1000 + (prop/for-all [initk gen/int + seed gen/int] + (let [src (fn [] + (let [rng (System.Random. seed)] ;;; java.util.Random. + (iteration #(unchecked-add % (.NextInt64 rng)) ;;; .nextLong + :somef (complement #(zero? (mod % 1000))) + :vf str + :initk initk)))] + (= (into [] (src)) + (into [] (seq (src))))))) + ) ;; compile-when \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/serialization.clj b/Clojure/Clojure.Tests/clojure/test_clojure/serialization.clj index 8d2eccb5f..cc5319f34 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/serialization.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/serialization.clj @@ -44,8 +44,8 @@ rt-seq (-> v seq serialize deserialize)] (and (= v rt) (= (seq v) (seq rt)) - (= (seq v) rt-seq) - (= (hash v) (hash rt)) + (= (seq v) rt-seq) + (= (hash v) (hash rt)) (= (.GetHashCode v) (.GetHashCode rt))))) ;;; .hashCode .hashCode (deftest sequable-serialization @@ -116,11 +116,11 @@ ; misc seqs (seq "s11n") (range 50) - (rseq (apply sorted-set (reverse (range 100)))) - - ;; partially realized chunked range - (let [r (range 50)] - (nth r 35) + (rseq (apply sorted-set (reverse (range 100)))) + + ;; partially realized chunked range + (let [r (range 50)] + (nth r 35) r))) (deftest misc-serialization @@ -130,16 +130,16 @@ ::namespaced-keyword 'symbol)) -(deftest tostringed-bytes - (let [rt #(-> % serialize seq) - s1 (rt 'sym123) - k1 (rt :kw123) - _ (.ToString 'sym123) ;;; .toString - _ (.ToString :kw123) ;;; .toString - s2 (rt 'sym123) - k2 (rt :kw123)] - (is (= s1 s2)) - (is (= k1 k2)))) +(deftest tostringed-bytes + (let [rt #(-> % serialize seq) + s1 (rt 'sym123) + k1 (rt :kw123) + _ (.ToString 'sym123) ;;; .toString + _ (.ToString :kw123) ;;; .toString + s2 (rt 'sym123) + k2 (rt :kw123)] + (is (= s1 s2)) + (is (= k1 k2)))) (deftest interned-serializations (are [v] (identical? v (-> v serialize deserialize)) @@ -147,17 +147,17 @@ ; namespaces just get deserialized back into the same-named ns in the present runtime ; (they're referred to by defrecord instances) - *ns* - - ; vars get serialized back into the same var in the present runtime - #'clojure.core/conj)) - - (deftest new-var-unbound-on-read - (let [v (intern 'user 'foobarbaz 10) - sv (serialize v)] - (ns-unmap 'user 'foobarbaz) ;; unmap #'user.V - (let [v2 (deserialize sv)] ;; deserialize re-interns var - ;; but it is unbound + *ns* + + ; vars get serialized back into the same var in the present runtime + #'clojure.core/conj)) + + (deftest new-var-unbound-on-read + (let [v (intern 'user 'foobarbaz 10) + sv (serialize v)] + (ns-unmap 'user 'foobarbaz) ;; unmap #'user.V + (let [v2 (deserialize sv)] ;; deserialize re-interns var + ;; but it is unbound (is (not (.hasRoot v2)))))) #_(deftest function-serialization <--- nothing left, so just commented it out diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/special.clj b/Clojure/Clojure.Tests/clojure/test_clojure/special.clj index 71812985d..5a2b97f81 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/special.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/special.clj @@ -13,7 +13,7 @@ ;; (ns clojure.test-clojure.special - (:use clojure.test) + (:use clojure.test) (:require [clojure.test-helper :refer [should-not-reflect]])) ; http://clojure.org/special_forms @@ -33,75 +33,75 @@ (let [{:as x} '()] (is (= {} x)))) -(deftest keywords-in-destructuring - (let [m {:a 1 :b 2}] - (let [{:keys [:a :b]} m] - (is (= [1 2] [a b]))) - (let [{:keys [:a :b :c] :or {c 3}} m] - (is (= [1 2 3] [a b c]))))) - -(deftest namespaced-keywords-in-destructuring - (let [m {:a/b 1 :c/d 2}] - (let [{:keys [:a/b :c/d]} m] - (is (= [1 2] [b d]))) - (let [{:keys [:a/b :c/d :e/f] :or {f 3}} m] - (is (= [1 2 3] [b d f]))))) - -(deftest namespaced-keys-in-destructuring - (let [m {:a/b 1 :c/d 2}] - (let [{:keys [a/b c/d]} m] - (is (= [1 2] [b d]))) - (let [{:keys [a/b c/d e/f] :or {f 3}} m] - (is (= [1 2 3] [b d f]))))) - -(deftest namespaced-syms-in-destructuring - (let [{:syms [a/b c/d e/f] :or {f 3}} {'a/b 1 'c/d 2}] - (is (= [1 2 3] [b d f])))) - -(deftest namespaced-keys-syntax - (let [{:a/keys [b c d] :or {d 3}} {:a/b 1 :a/c 2}] - (is (= [1 2 3] [b c d])))) - -(deftest namespaced-syms-syntax - (let [{:a/syms [b c d] :or {d 3}} {'a/b 1 'a/c 2}] - (is (= [1 2 3] [b c d])))) - -(deftest keywords-not-allowed-in-let-bindings - (is (thrown-with-cause-msg? Exception #"did not conform to spec" - (eval '(let [:a 1] a)))) - (is (thrown-with-cause-msg? Exception #"did not conform to spec" - (eval '(let [:a/b 1] b)))) - (is (thrown-with-cause-msg? Exception #"did not conform to spec" - (eval '(let [[:a] [1]] a)))) - (is (thrown-with-cause-msg? Exception #"did not conform to spec" - (eval '(let [[:a/b] [1]] b))))) - -(deftest namespaced-syms-only-allowed-in-map-destructuring - (is (thrown-with-cause-msg? Exception #"did not conform to spec" - (eval '(let [a/x 1, [y] [1]] x)))) - (is (thrown-with-cause-msg? Exception #"did not conform to spec" - (eval '(let [[a/x] [1]] x))))) - -(deftest or-doesnt-create-bindings - (is (thrown-with-cause-msg? Exception #"Unable to resolve symbol: b" - (eval '(let [{:keys [a] :or {b 2}} {:a 1}] [a b]))))) - -(require '[clojure.string :as s]) -(deftest resolve-keyword-ns-alias-in-destructuring - (let [{:keys [::s/x ::s/y ::s/z] :or {z 3}} {:clojure.string/x 1 :clojure.string/y 2}] - (is (= [1 2 3] [x y z])))) - -(deftest quote-with-multiple-args - (let [ex (is (thrown? clojure.lang.Compiler+CompilerException ;;; Compiler$CompilerException - (eval '(quote 1 2 3))))] - (is (= '(quote 1 2 3) - (-> ex - (.InnerException) ;;; .getCause - (ex-data) - (:form)))))) - -(deftest typehints-retained-destructuring - (should-not-reflect - (defn foo - [{:keys [^String s]}] +(deftest keywords-in-destructuring + (let [m {:a 1 :b 2}] + (let [{:keys [:a :b]} m] + (is (= [1 2] [a b]))) + (let [{:keys [:a :b :c] :or {c 3}} m] + (is (= [1 2 3] [a b c]))))) + +(deftest namespaced-keywords-in-destructuring + (let [m {:a/b 1 :c/d 2}] + (let [{:keys [:a/b :c/d]} m] + (is (= [1 2] [b d]))) + (let [{:keys [:a/b :c/d :e/f] :or {f 3}} m] + (is (= [1 2 3] [b d f]))))) + +(deftest namespaced-keys-in-destructuring + (let [m {:a/b 1 :c/d 2}] + (let [{:keys [a/b c/d]} m] + (is (= [1 2] [b d]))) + (let [{:keys [a/b c/d e/f] :or {f 3}} m] + (is (= [1 2 3] [b d f]))))) + +(deftest namespaced-syms-in-destructuring + (let [{:syms [a/b c/d e/f] :or {f 3}} {'a/b 1 'c/d 2}] + (is (= [1 2 3] [b d f])))) + +(deftest namespaced-keys-syntax + (let [{:a/keys [b c d] :or {d 3}} {:a/b 1 :a/c 2}] + (is (= [1 2 3] [b c d])))) + +(deftest namespaced-syms-syntax + (let [{:a/syms [b c d] :or {d 3}} {'a/b 1 'a/c 2}] + (is (= [1 2 3] [b c d])))) + +(deftest keywords-not-allowed-in-let-bindings + (is (thrown-with-cause-msg? Exception #"did not conform to spec" + (eval '(let [:a 1] a)))) + (is (thrown-with-cause-msg? Exception #"did not conform to spec" + (eval '(let [:a/b 1] b)))) + (is (thrown-with-cause-msg? Exception #"did not conform to spec" + (eval '(let [[:a] [1]] a)))) + (is (thrown-with-cause-msg? Exception #"did not conform to spec" + (eval '(let [[:a/b] [1]] b))))) + +(deftest namespaced-syms-only-allowed-in-map-destructuring + (is (thrown-with-cause-msg? Exception #"did not conform to spec" + (eval '(let [a/x 1, [y] [1]] x)))) + (is (thrown-with-cause-msg? Exception #"did not conform to spec" + (eval '(let [[a/x] [1]] x))))) + +(deftest or-doesnt-create-bindings + (is (thrown-with-cause-msg? Exception #"Unable to resolve symbol: b" + (eval '(let [{:keys [a] :or {b 2}} {:a 1}] [a b]))))) + +(require '[clojure.string :as s]) +(deftest resolve-keyword-ns-alias-in-destructuring + (let [{:keys [::s/x ::s/y ::s/z] :or {z 3}} {:clojure.string/x 1 :clojure.string/y 2}] + (is (= [1 2 3] [x y z])))) + +(deftest quote-with-multiple-args + (let [ex (is (thrown? clojure.lang.Compiler+CompilerException ;;; Compiler$CompilerException + (eval '(quote 1 2 3))))] + (is (= '(quote 1 2 3) + (-> ex + (.InnerException) ;;; .getCause + (ex-data) + (:form)))))) + +(deftest typehints-retained-destructuring + (should-not-reflect + (defn foo + [{:keys [^String s]}] (.IndexOf s "boo")))) ;;; .indexOf \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/test.clj b/Clojure/Clojure.Tests/clojure/test_clojure/test.clj index 39f17b6f7..d16c4962d 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/test.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/test.clj @@ -72,14 +72,14 @@ (is (re-matches #"^cd.*$" "abbabba") "Should fail") (is (re-find #"ab" "abbabba") "Should pass") (is (re-find #"cd" "abbabba") "Should fail")) - -(deftest clj-1102-empty-stack-trace-should-not-throw-exceptions ;;; I don';t know any way to do the equivalent of .setStraceTrace on an exception, in CLR-land. - (let [empty-stack (into-array (Type/GetType "System.Diagnostics.StackFrame" false) ;;; (Class/forName "java.lang.StackTraceElement") -- not needed - []) - t (Exception.)] ;;; (doto (Exception.) (.setStackTrace empty-stack)) -- however, an unthrown exception has an empty stack trace - (is (map? (#'clojure.test/file-and-line t 0)) "Should pass") - (is (map? (#'clojure.test/stacktrace-file-and-line empty-stack)) "Should pass") - (is (string? (with-out-str (stack/print-stack-trace t))) "Should pass"))) + +(deftest clj-1102-empty-stack-trace-should-not-throw-exceptions ;;; I don';t know any way to do the equivalent of .setStraceTrace on an exception, in CLR-land. + (let [empty-stack (into-array (Type/GetType "System.Diagnostics.StackFrame" false) ;;; (Class/forName "java.lang.StackTraceElement") -- not needed + []) + t (Exception.)] ;;; (doto (Exception.) (.setStackTrace empty-stack)) -- however, an unthrown exception has an empty stack trace + (is (map? (#'clojure.test/file-and-line t 0)) "Should pass") + (is (map? (#'clojure.test/stacktrace-file-and-line empty-stack)) "Should pass") + (is (string? (with-out-str (stack/print-stack-trace t))) "Should pass"))) (deftest ^{:has-meta true} can-add-metadata-to-tests (is (:has-meta (meta #'can-add-metadata-to-tests)) "Should pass")) @@ -123,7 +123,7 @@ report custom-report] (test-all-vars (find-ns 'clojure.test-clojure.test)))) -(deftest clj-1588-symbols-in-are-isolated-from-test-clauses - (binding [report original-report] - (are [x y] (= x y) +(deftest clj-1588-symbols-in-are-isolated-from-test-clauses + (binding [report original-report] + (are [x y] (= x y) ((fn [x] (inc x)) 1) 2))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/test_fixtures.clj b/Clojure/Clojure.Tests/clojure/test_clojure/test_fixtures.clj index 650980787..13dd2160e 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/test_fixtures.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/test_fixtures.clj @@ -33,14 +33,14 @@ (defn inc-n-fixture [f] (binding [*n* (inc *n*)] (f))) -(def side-effects (atom 0)) -(defn side-effecting-fixture [f] - (swap! side-effects inc) - (f)) +(def side-effects (atom 0)) +(defn side-effecting-fixture [f] + (swap! side-effects inc) + (f)) (use-fixtures :once fixture-a fixture-b) -(use-fixtures :each fixture-c fixture-d inc-n-fixture side-effecting-fixture) +(use-fixtures :each fixture-c fixture-d inc-n-fixture side-effecting-fixture) (use-fixtures :each fixture-c fixture-d inc-n-fixture side-effecting-fixture) (deftest can-use-once-fixtures @@ -53,21 +53,21 @@ (deftest use-fixtures-replaces (is (= *n* 1))) - -(deftest can-run-a-single-test-with-fixtures - ;; We have to use a side-effecting fixture to test that the fixtures are - ;; running, in order to distinguish fixtures run because of our call to - ;; test-vars below from the same fixtures running prior to this test - (let [side-effects-so-far @side-effects - reported (atom [])] - (binding [report (fn [m] (swap! reported conj (:type m)))] - (test-vars [#'can-use-each-fixtures])) - (is (= [:begin-test-var :pass :pass :end-test-var] @reported)) + +(deftest can-run-a-single-test-with-fixtures + ;; We have to use a side-effecting fixture to test that the fixtures are + ;; running, in order to distinguish fixtures run because of our call to + ;; test-vars below from the same fixtures running prior to this test + (let [side-effects-so-far @side-effects + reported (atom [])] + (binding [report (fn [m] (swap! reported conj (:type m)))] + (test-vars [#'can-use-each-fixtures])) + (is (= [:begin-test-var :pass :pass :end-test-var] @reported)) (is (= (inc side-effects-so-far) @side-effects)))) -(defn should-not-trigger-fixtures []) - -(deftest a-var-lacking-test-meta-should-not-trigger-fixtures - (let [side-effects-so-far @side-effects] - (test-vars [#'should-not-trigger-fixtures]) +(defn should-not-trigger-fixtures []) + +(deftest a-var-lacking-test-meta-should-not-trigger-fixtures + (let [side-effects-so-far @side-effects] + (test-vars [#'should-not-trigger-fixtures]) (is (= side-effects-so-far @side-effects)))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/transducers.clj b/Clojure/Clojure.Tests/clojure/test_clojure/transducers.clj index 97a17996b..fcbb284ed 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/transducers.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/transducers.clj @@ -1,409 +1,409 @@ -; 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: Alex Miller - -(ns clojure.test-clojure.transducers - (:require [clojure.string :as s] - [clojure.test :refer :all] - [clojure.test.check :as chk] - [clojure.test.check.generators :as gen] - [clojure.test.check.properties :as prop] - [clojure.test.check.clojure-test :as ctest])) - -(defmacro fbind [source-gen f] - `(gen/fmap - (fn [s#] - {:desc (list '~f (:name s#)) - :seq (partial ~f (:val s#)) - :xf (~f (:val s#))}) - ~source-gen)) - -(defmacro pickfn [& fns] - `(gen/elements - [~@(for [f fns] `{:val ~f :name '~f})])) - -(defn literal - [g] - (gen/fmap - (fn [s] {:val s :name s}) - g)) - -;; These $ versions are "safe" when used with possibly mixed numbers, sequences, etc - -(defn- inc$ [n] - (if (number? n) (inc n) 1)) - -(defn- dec$ [n] - (if (number? n) (dec n) 1)) - -(defn- odd?$ [n] - (if (number? n) (odd? n) false)) - -(defn- pos?$ [n] - (if (number? n) (pos? n) false)) - -(defn- empty?$ [s] - (if (instance? clojure.lang.Seqable s) (empty? s) false)) - -(def gen-mapfn - (pickfn [inc$ dec$])) - -(def gen-mapcatfn - (pickfn vector - #(if (instance? clojure.lang.Seqable %) (partition-all 3 %) (vector %)))) - -(def gen-predfn - (pickfn odd?$ pos?$ empty?$ sequential?)) - -(def gen-indexedfn - (pickfn (fn [index item] index) - (fn [index item] item) - (fn [index item] (if (number? item) (+ index item) index)))) - -(def gen-take (fbind (literal gen/s-pos-int) take)) -(def gen-drop (fbind (literal gen/pos-int) drop)) -(def gen-drop-while (fbind gen-predfn drop-while)) -(def gen-map (fbind gen-mapfn map)) -(def gen-mapcat (fbind gen-mapcatfn mapcat)) -(def gen-filter (fbind gen-predfn filter)) -(def gen-remove (fbind gen-predfn remove)) -(def gen-keep (fbind gen-predfn keep)) -(def gen-partition-all (fbind (literal gen/s-pos-int) partition-all)) -(def gen-partition-by (fbind gen-predfn partition-by)) -(def gen-take-while (fbind gen-predfn take-while)) -(def gen-take-nth (fbind (literal gen/s-pos-int) take-nth)) -(def gen-keep-indexed (fbind gen-indexedfn keep-indexed)) -(def gen-map-indexed (fbind gen-indexedfn map-indexed)) -(def gen-replace (fbind (literal (gen/return (hash-map (range 100) (range 1 100)))) replace)) -(def gen-distinct (gen/return {:desc 'distinct :seq (partial distinct) :xf (distinct)})) -(def gen-dedupe (gen/return {:desc 'dedupe :seq (partial dedupe) :xf (dedupe)})) -(def gen-interpose (fbind (literal gen/s-pos-int) interpose)) - -(def gen-action - (gen/one-of [gen-take gen-drop gen-map gen-mapcat - gen-filter gen-remove gen-keep - gen-partition-all gen-partition-by gen-take-while - gen-take-nth gen-drop-while - gen-keep-indexed gen-map-indexed - gen-distinct gen-dedupe gen-interpose])) - -(def gen-actions - (gen/vector gen-action 1 5)) - -(def gen-coll - (gen/vector gen/int)) - -(defn apply-as-seq [coll actions] - (doall - (loop [s coll - [action & actions'] actions] - (if action - (recur ((:seq action) s) actions') - s)))) - -(defn apply-as-xf-seq - [coll actions] - (doall (sequence (apply comp (map :xf actions)) coll))) - -(defn apply-as-xf-into - [coll actions] - (into [] (apply comp (map :xf actions)) coll)) - -(defn apply-as-xf-eduction - [coll actions] - (into [] (eduction (apply comp (map :xf actions)) coll))) - -(defn apply-as-xf-transduce - [coll actions] - (transduce (apply comp (map :xf actions)) conj coll)) - -(defmacro return-exc [& forms] - `(try ~@forms (catch Exception e# e#))) ;;; Throwable - -(defn build-results - [coll actions] - (let [s (return-exc (apply-as-seq coll actions)) - xs (return-exc (apply-as-xf-seq coll actions)) - xi (return-exc (apply-as-xf-into coll actions)) - xe (return-exc (apply-as-xf-eduction coll actions)) - xt (return-exc (apply-as-xf-transduce coll actions))] - {:coll coll - :actions (concat '(->> coll) (map :desc actions)) - :s s - :xs xs - :xi xi - :xe xe - :xt xt})) - -(def result-gen - (gen/fmap - (fn [[c a]] (build-results c a)) - (gen/tuple gen-coll gen-actions))) - -(defn result-good? - [{:keys [s xs xi xe xt]}] - (= s xs xi xe xt)) - -#_(deftest seq-and-transducer ;;; TODO: This worked prior to the revison. and two more updates haven't changed it. - (let [res (chk/quick-check ;;; Now fails occasionally (takes over 50,000 trials on average) - 200000 ;;; x has indexing exception (nth on a vector) while xs xi xt are okay - (prop/for-all* [result-gen] result-good?))] - (when-not (:result res) - (is - (:result res) - (-> - res - :shrunk - :smallest - first - clojure.pprint/pprint - with-out-str))))) - -(deftest test-transduce - (let [long+ (fn ([a b] (+ (long a) (long b))) - ([a] a) - ([] 0)) - mapinc (map inc) - mapinclong (map (comp inc long)) - arange (range 100) - avec (into [] arange) - alist (into () arange) - obj-array (into-array arange) - int-array (into-array Int32 (map #(int %) arange)) ;;; Integer/TYPE #(Integer. (int %)) - long-array (into-array Int64 arange) ;;; Long/TYPE - float-array (into-array Single arange) ;;; Float/TYPE - char-array (into-array Char (map char arange)) ;;; Character/TYPE - double-array (into-array Double arange) ;;; Double/TYPE - byte-array (into-array Byte (map byte arange)) ;;; Byte/TYPE - int-vec (into (vector-of :int) arange) - long-vec (into (vector-of :long) arange) - float-vec (into (vector-of :float) arange) - char-vec (into (vector-of :char) (map char arange)) - double-vec (into (vector-of :double) arange) - byte-vec (into (vector-of :byte) (map byte arange))] - (is (== 5050 - (transduce mapinc + arange) - (transduce mapinc + avec) - (transduce mapinc + alist) - (transduce mapinc + obj-array) - (transduce mapinc + int-array) - (transduce mapinc + long-array) - (transduce mapinc + float-array) - (transduce mapinclong + char-array) - (transduce mapinc + double-array) - (transduce mapinclong + byte-array) - (transduce mapinc + int-vec) - (transduce mapinc + long-vec) - (transduce mapinc + float-vec) - (transduce mapinclong + char-vec) - (transduce mapinc + double-vec) - (transduce mapinclong + byte-vec) - )) - (is (== 5051 - (transduce mapinc + 1 arange) - (transduce mapinc + 1 avec) - (transduce mapinc + 1 alist) - (transduce mapinc + 1 obj-array) - (transduce mapinc + 1 int-array) - (transduce mapinc + 1 long-array) - (transduce mapinc + 1 float-array) - (transduce mapinclong + 1 char-array) - (transduce mapinc + 1 double-array) - (transduce mapinclong + 1 byte-array) - (transduce mapinc + 1 int-vec) - (transduce mapinc + 1 long-vec) - (transduce mapinc + 1 float-vec) - (transduce mapinclong + 1 char-vec) - (transduce mapinc + 1 double-vec) - (transduce mapinclong + 1 byte-vec))))) - -(deftest test-dedupe - (are [x y] (= (transduce (dedupe) conj x) y) - [] [] - [1] [1] - [1 2 3] [1 2 3] - [1 2 3 1 2 2 1 1] [1 2 3 1 2 1] - [1 1 1 2] [1 2] - [1 1 1 1] [1] - - "" [] - "a" [\a] - "aaaa" [\a] - "aabaa" [\a \b \a] - "abba" [\a \b \a] - - [nil nil nil] [nil] - [1 1.0 1.0M 1N] [1 1.0 1.0M 1N] - [0.5 0.5] [0.5])) - -(deftest test-cat - (are [x y] (= (transduce cat conj x) y) - [] [] - [[1 2]] [1 2] - [[1 2] [3 4]] [1 2 3 4] - [[] [3 4]] [3 4] - [[1 2] []] [1 2] - [[] []] [] - [[1 2] [3 4] [5 6]] [1 2 3 4 5 6])) - -(deftest test-partition-all - (are [n coll y] (= (transduce (partition-all n) conj coll) y) - 2 [1 2 3] '((1 2) (3)) - 2 [1 2 3 4] '((1 2) (3 4)) - 2 [] () - 1 [] () - 1 [1 2 3] '((1) (2) (3)) - 5 [1 2 3] '((1 2 3)))) - -(deftest test-take - (are [n y] (= (transduce (take n) conj [1 2 3 4 5]) y) - 1 '(1) - 3 '(1 2 3) - 5 '(1 2 3 4 5) - 9 '(1 2 3 4 5) - 0 () - -1 () - -2 ())) - -(deftest test-drop - (are [n y] (= (transduce (drop n) conj [1 2 3 4 5]) y) - 1 '(2 3 4 5) - 3 '(4 5) - 5 () - 9 () - 0 '(1 2 3 4 5) - -1 '(1 2 3 4 5) - -2 '(1 2 3 4 5))) - -(deftest test-take-nth - (are [n y] (= (transduce (take-nth n) conj [1 2 3 4 5]) y) - 1 '(1 2 3 4 5) - 2 '(1 3 5) - 3 '(1 4) - 4 '(1 5) - 5 '(1) - 9 '(1))) - -(deftest test-take-while - (are [coll y] (= (transduce (take-while pos?) conj coll) y) - [] () - [1 2 3 4] '(1 2 3 4) - [1 2 3 -1] '(1 2 3) - [1 -1 2 3] '(1) - [-1 1 2 3] () - [-1 -2 -3] ())) - -(deftest test-drop-while - (are [coll y] (= (transduce (drop-while pos?) conj coll) y) - [] () - [1 2 3 4] () - [1 2 3 -1] '(-1) - [1 -1 2 3] '(-1 2 3) - [-1 1 2 3] '(-1 1 2 3) - [-1 -2 -3] '(-1 -2 -3))) - -(deftest test-re-reduced - (is (= [:a] (transduce (take 1) conj [:a]))) - (is (= [:a] (transduce (comp (take 1) (take 1)) conj [:a]))) - (is (= [:a] (transduce (comp (take 1) (take 1) (take 1)) conj [:a]))) - (is (= [:a] (transduce (comp (take 1) (take 1) (take 1) (take 1)) conj [:a]))) - (is (= [[:a]] (transduce (comp (partition-by keyword?) (take 1)) conj [] [:a]))) - (is (= [[:a]] (sequence (comp (partition-by keyword?) (take 1)) [:a]))) - (is (= [[[:a]]] (sequence (comp (partition-by keyword?) (take 1) (partition-by keyword?) (take 1)) [:a]))) - (is (= [[0]] (transduce (comp (take 1) (partition-all 3) (take 1)) conj [] (range 15)))) - (is (= [1] (transduce (take 1) conj (seq (long-array [1 2 3 4])))))) - -(deftest test-sequence-multi-xform - (is (= [11 12 13 14] (sequence (map +) [1 2 3 4] (repeat 10)))) - (is (= [11 12 13 14] (sequence (map +) (repeat 10) [1 2 3 4]))) - (is (= [31 32 33 34] (sequence (map +) (repeat 10) (repeat 20) [1 2 3 4])))) - -(deftest test-eduction - (testing "one xform" - (is (= [1 2 3 4 5] - (eduction (map inc) (range 5))))) - (testing "multiple xforms" - (is (= ["2" "4"] - (eduction (map inc) (filter even?) (map str) (range 5))))) - (testing "materialize at the end" - (is (= [1 1 1 1 2 2 2 3 3 4] - (->> (range 5) - (eduction (mapcat range) (map inc)) - sort))) - (is (= [1 1 2 1 2 3 1 2 3 4] - (vec (->> (range 5) - (eduction (mapcat range) (map inc)) - to-array)))) - (is (= {1 4, 2 3, 3 2, 4 1} - (->> (range 5) - (eduction (mapcat range) (map inc)) - frequencies))) - (is (= ["drib" "god" "hsif" "kravdraa" "tac"] - (->> ["cat" "dog" "fish" "bird" "aardvark"] - (eduction (map clojure.string/reverse)) - (sort-by first))))) - (testing "expanding transducer with nils" - (is (= '(1 2 3 nil 4 5 6 nil) - (eduction cat [[1 2 3 nil] [4 5 6 nil]]))))) - -(deftest test-eduction-completion - (testing "eduction completes inner xformed reducing fn" - (is (= [[0 1 2] [3 4 5] [6 7]] - (into [] - (comp cat (partition-all 3)) - (eduction (partition-all 5) (range 8)))))) - (testing "outer reducing fn completed only once" - (let [counter (atom 0) - ;; outer rfn - rf (completing conj #(do (swap! counter inc) - (vec %))) - coll (eduction (map inc) (range 5)) - res (transduce (map str) rf [] coll)] - (is (= 1 @counter)) - (is (= ["1" "2" "3" "4" "5"] res))))) - -(deftest test-run! - (is (nil? (run! identity [1]))) - (is (nil? (run! reduced (range))))) - -(deftest test-distinct - (are [out in] (= out (sequence (distinct in)) (sequence (distinct) in)) - [] [] - (range 10) (range 10) - [0] (repeat 10 0) - [0 1 2] [0 0 1 1 2 2 1 1 0 0] - [1] [1 1N])) - -(deftest test-interpose - (are [out in] (= out (sequence (interpose :s) in)) - [] (range 0) - [0] (range 1) - [0 :s 1] (range 2) - [0 :s 1 :s 2] (range 3)) - (testing "Can end reduction on separator or input" - (let [expected (interpose :s (range))] - (dotimes [i 10] - (is (= (take i expected) - (sequence (comp (interpose :s) (take i)) - (range)))))))) - -(deftest test-map-indexed - (is (= [] - (sequence (map-indexed vector) []))) - (is (= [[0 1] [1 2] [2 3] [3 4]] - (sequence (map-indexed vector) (range 1 5))))) - -(deftest test-into+halt-when - (is (= :anomaly (into [] (comp (filter some?) (halt-when #{:anomaly})) - [1 2 3 :anomaly 4]))) - (is (= {:anomaly :oh-no!, - :partial-results [1 2]} - (into [] - (halt-when :anomaly #(assoc %2 :partial-results %1)) - [1 2 {:anomaly :oh-no!} 3 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: Alex Miller + +(ns clojure.test-clojure.transducers + (:require [clojure.string :as s] + [clojure.test :refer :all] + [clojure.test.check :as chk] + [clojure.test.check.generators :as gen] + [clojure.test.check.properties :as prop] + [clojure.test.check.clojure-test :as ctest])) + +(defmacro fbind [source-gen f] + `(gen/fmap + (fn [s#] + {:desc (list '~f (:name s#)) + :seq (partial ~f (:val s#)) + :xf (~f (:val s#))}) + ~source-gen)) + +(defmacro pickfn [& fns] + `(gen/elements + [~@(for [f fns] `{:val ~f :name '~f})])) + +(defn literal + [g] + (gen/fmap + (fn [s] {:val s :name s}) + g)) + +;; These $ versions are "safe" when used with possibly mixed numbers, sequences, etc + +(defn- inc$ [n] + (if (number? n) (inc n) 1)) + +(defn- dec$ [n] + (if (number? n) (dec n) 1)) + +(defn- odd?$ [n] + (if (number? n) (odd? n) false)) + +(defn- pos?$ [n] + (if (number? n) (pos? n) false)) + +(defn- empty?$ [s] + (if (instance? clojure.lang.Seqable s) (empty? s) false)) + +(def gen-mapfn + (pickfn [inc$ dec$])) + +(def gen-mapcatfn + (pickfn vector + #(if (instance? clojure.lang.Seqable %) (partition-all 3 %) (vector %)))) + +(def gen-predfn + (pickfn odd?$ pos?$ empty?$ sequential?)) + +(def gen-indexedfn + (pickfn (fn [index item] index) + (fn [index item] item) + (fn [index item] (if (number? item) (+ index item) index)))) + +(def gen-take (fbind (literal gen/s-pos-int) take)) +(def gen-drop (fbind (literal gen/pos-int) drop)) +(def gen-drop-while (fbind gen-predfn drop-while)) +(def gen-map (fbind gen-mapfn map)) +(def gen-mapcat (fbind gen-mapcatfn mapcat)) +(def gen-filter (fbind gen-predfn filter)) +(def gen-remove (fbind gen-predfn remove)) +(def gen-keep (fbind gen-predfn keep)) +(def gen-partition-all (fbind (literal gen/s-pos-int) partition-all)) +(def gen-partition-by (fbind gen-predfn partition-by)) +(def gen-take-while (fbind gen-predfn take-while)) +(def gen-take-nth (fbind (literal gen/s-pos-int) take-nth)) +(def gen-keep-indexed (fbind gen-indexedfn keep-indexed)) +(def gen-map-indexed (fbind gen-indexedfn map-indexed)) +(def gen-replace (fbind (literal (gen/return (hash-map (range 100) (range 1 100)))) replace)) +(def gen-distinct (gen/return {:desc 'distinct :seq (partial distinct) :xf (distinct)})) +(def gen-dedupe (gen/return {:desc 'dedupe :seq (partial dedupe) :xf (dedupe)})) +(def gen-interpose (fbind (literal gen/s-pos-int) interpose)) + +(def gen-action + (gen/one-of [gen-take gen-drop gen-map gen-mapcat + gen-filter gen-remove gen-keep + gen-partition-all gen-partition-by gen-take-while + gen-take-nth gen-drop-while + gen-keep-indexed gen-map-indexed + gen-distinct gen-dedupe gen-interpose])) + +(def gen-actions + (gen/vector gen-action 1 5)) + +(def gen-coll + (gen/vector gen/int)) + +(defn apply-as-seq [coll actions] + (doall + (loop [s coll + [action & actions'] actions] + (if action + (recur ((:seq action) s) actions') + s)))) + +(defn apply-as-xf-seq + [coll actions] + (doall (sequence (apply comp (map :xf actions)) coll))) + +(defn apply-as-xf-into + [coll actions] + (into [] (apply comp (map :xf actions)) coll)) + +(defn apply-as-xf-eduction + [coll actions] + (into [] (eduction (apply comp (map :xf actions)) coll))) + +(defn apply-as-xf-transduce + [coll actions] + (transduce (apply comp (map :xf actions)) conj coll)) + +(defmacro return-exc [& forms] + `(try ~@forms (catch Exception e# e#))) ;;; Throwable + +(defn build-results + [coll actions] + (let [s (return-exc (apply-as-seq coll actions)) + xs (return-exc (apply-as-xf-seq coll actions)) + xi (return-exc (apply-as-xf-into coll actions)) + xe (return-exc (apply-as-xf-eduction coll actions)) + xt (return-exc (apply-as-xf-transduce coll actions))] + {:coll coll + :actions (concat '(->> coll) (map :desc actions)) + :s s + :xs xs + :xi xi + :xe xe + :xt xt})) + +(def result-gen + (gen/fmap + (fn [[c a]] (build-results c a)) + (gen/tuple gen-coll gen-actions))) + +(defn result-good? + [{:keys [s xs xi xe xt]}] + (= s xs xi xe xt)) + +#_(deftest seq-and-transducer ;;; TODO: This worked prior to the revison. and two more updates haven't changed it. + (let [res (chk/quick-check ;;; Now fails occasionally (takes over 50,000 trials on average) + 200000 ;;; x has indexing exception (nth on a vector) while xs xi xt are okay + (prop/for-all* [result-gen] result-good?))] + (when-not (:result res) + (is + (:result res) + (-> + res + :shrunk + :smallest + first + clojure.pprint/pprint + with-out-str))))) + +(deftest test-transduce + (let [long+ (fn ([a b] (+ (long a) (long b))) + ([a] a) + ([] 0)) + mapinc (map inc) + mapinclong (map (comp inc long)) + arange (range 100) + avec (into [] arange) + alist (into () arange) + obj-array (into-array arange) + int-array (into-array Int32 (map #(int %) arange)) ;;; Integer/TYPE #(Integer. (int %)) + long-array (into-array Int64 arange) ;;; Long/TYPE + float-array (into-array Single arange) ;;; Float/TYPE + char-array (into-array Char (map char arange)) ;;; Character/TYPE + double-array (into-array Double arange) ;;; Double/TYPE + byte-array (into-array Byte (map byte arange)) ;;; Byte/TYPE + int-vec (into (vector-of :int) arange) + long-vec (into (vector-of :long) arange) + float-vec (into (vector-of :float) arange) + char-vec (into (vector-of :char) (map char arange)) + double-vec (into (vector-of :double) arange) + byte-vec (into (vector-of :byte) (map byte arange))] + (is (== 5050 + (transduce mapinc + arange) + (transduce mapinc + avec) + (transduce mapinc + alist) + (transduce mapinc + obj-array) + (transduce mapinc + int-array) + (transduce mapinc + long-array) + (transduce mapinc + float-array) + (transduce mapinclong + char-array) + (transduce mapinc + double-array) + (transduce mapinclong + byte-array) + (transduce mapinc + int-vec) + (transduce mapinc + long-vec) + (transduce mapinc + float-vec) + (transduce mapinclong + char-vec) + (transduce mapinc + double-vec) + (transduce mapinclong + byte-vec) + )) + (is (== 5051 + (transduce mapinc + 1 arange) + (transduce mapinc + 1 avec) + (transduce mapinc + 1 alist) + (transduce mapinc + 1 obj-array) + (transduce mapinc + 1 int-array) + (transduce mapinc + 1 long-array) + (transduce mapinc + 1 float-array) + (transduce mapinclong + 1 char-array) + (transduce mapinc + 1 double-array) + (transduce mapinclong + 1 byte-array) + (transduce mapinc + 1 int-vec) + (transduce mapinc + 1 long-vec) + (transduce mapinc + 1 float-vec) + (transduce mapinclong + 1 char-vec) + (transduce mapinc + 1 double-vec) + (transduce mapinclong + 1 byte-vec))))) + +(deftest test-dedupe + (are [x y] (= (transduce (dedupe) conj x) y) + [] [] + [1] [1] + [1 2 3] [1 2 3] + [1 2 3 1 2 2 1 1] [1 2 3 1 2 1] + [1 1 1 2] [1 2] + [1 1 1 1] [1] + + "" [] + "a" [\a] + "aaaa" [\a] + "aabaa" [\a \b \a] + "abba" [\a \b \a] + + [nil nil nil] [nil] + [1 1.0 1.0M 1N] [1 1.0 1.0M 1N] + [0.5 0.5] [0.5])) + +(deftest test-cat + (are [x y] (= (transduce cat conj x) y) + [] [] + [[1 2]] [1 2] + [[1 2] [3 4]] [1 2 3 4] + [[] [3 4]] [3 4] + [[1 2] []] [1 2] + [[] []] [] + [[1 2] [3 4] [5 6]] [1 2 3 4 5 6])) + +(deftest test-partition-all + (are [n coll y] (= (transduce (partition-all n) conj coll) y) + 2 [1 2 3] '((1 2) (3)) + 2 [1 2 3 4] '((1 2) (3 4)) + 2 [] () + 1 [] () + 1 [1 2 3] '((1) (2) (3)) + 5 [1 2 3] '((1 2 3)))) + +(deftest test-take + (are [n y] (= (transduce (take n) conj [1 2 3 4 5]) y) + 1 '(1) + 3 '(1 2 3) + 5 '(1 2 3 4 5) + 9 '(1 2 3 4 5) + 0 () + -1 () + -2 ())) + +(deftest test-drop + (are [n y] (= (transduce (drop n) conj [1 2 3 4 5]) y) + 1 '(2 3 4 5) + 3 '(4 5) + 5 () + 9 () + 0 '(1 2 3 4 5) + -1 '(1 2 3 4 5) + -2 '(1 2 3 4 5))) + +(deftest test-take-nth + (are [n y] (= (transduce (take-nth n) conj [1 2 3 4 5]) y) + 1 '(1 2 3 4 5) + 2 '(1 3 5) + 3 '(1 4) + 4 '(1 5) + 5 '(1) + 9 '(1))) + +(deftest test-take-while + (are [coll y] (= (transduce (take-while pos?) conj coll) y) + [] () + [1 2 3 4] '(1 2 3 4) + [1 2 3 -1] '(1 2 3) + [1 -1 2 3] '(1) + [-1 1 2 3] () + [-1 -2 -3] ())) + +(deftest test-drop-while + (are [coll y] (= (transduce (drop-while pos?) conj coll) y) + [] () + [1 2 3 4] () + [1 2 3 -1] '(-1) + [1 -1 2 3] '(-1 2 3) + [-1 1 2 3] '(-1 1 2 3) + [-1 -2 -3] '(-1 -2 -3))) + +(deftest test-re-reduced + (is (= [:a] (transduce (take 1) conj [:a]))) + (is (= [:a] (transduce (comp (take 1) (take 1)) conj [:a]))) + (is (= [:a] (transduce (comp (take 1) (take 1) (take 1)) conj [:a]))) + (is (= [:a] (transduce (comp (take 1) (take 1) (take 1) (take 1)) conj [:a]))) + (is (= [[:a]] (transduce (comp (partition-by keyword?) (take 1)) conj [] [:a]))) + (is (= [[:a]] (sequence (comp (partition-by keyword?) (take 1)) [:a]))) + (is (= [[[:a]]] (sequence (comp (partition-by keyword?) (take 1) (partition-by keyword?) (take 1)) [:a]))) + (is (= [[0]] (transduce (comp (take 1) (partition-all 3) (take 1)) conj [] (range 15)))) + (is (= [1] (transduce (take 1) conj (seq (long-array [1 2 3 4])))))) + +(deftest test-sequence-multi-xform + (is (= [11 12 13 14] (sequence (map +) [1 2 3 4] (repeat 10)))) + (is (= [11 12 13 14] (sequence (map +) (repeat 10) [1 2 3 4]))) + (is (= [31 32 33 34] (sequence (map +) (repeat 10) (repeat 20) [1 2 3 4])))) + +(deftest test-eduction + (testing "one xform" + (is (= [1 2 3 4 5] + (eduction (map inc) (range 5))))) + (testing "multiple xforms" + (is (= ["2" "4"] + (eduction (map inc) (filter even?) (map str) (range 5))))) + (testing "materialize at the end" + (is (= [1 1 1 1 2 2 2 3 3 4] + (->> (range 5) + (eduction (mapcat range) (map inc)) + sort))) + (is (= [1 1 2 1 2 3 1 2 3 4] + (vec (->> (range 5) + (eduction (mapcat range) (map inc)) + to-array)))) + (is (= {1 4, 2 3, 3 2, 4 1} + (->> (range 5) + (eduction (mapcat range) (map inc)) + frequencies))) + (is (= ["drib" "god" "hsif" "kravdraa" "tac"] + (->> ["cat" "dog" "fish" "bird" "aardvark"] + (eduction (map clojure.string/reverse)) + (sort-by first))))) + (testing "expanding transducer with nils" + (is (= '(1 2 3 nil 4 5 6 nil) + (eduction cat [[1 2 3 nil] [4 5 6 nil]]))))) + +(deftest test-eduction-completion + (testing "eduction completes inner xformed reducing fn" + (is (= [[0 1 2] [3 4 5] [6 7]] + (into [] + (comp cat (partition-all 3)) + (eduction (partition-all 5) (range 8)))))) + (testing "outer reducing fn completed only once" + (let [counter (atom 0) + ;; outer rfn + rf (completing conj #(do (swap! counter inc) + (vec %))) + coll (eduction (map inc) (range 5)) + res (transduce (map str) rf [] coll)] + (is (= 1 @counter)) + (is (= ["1" "2" "3" "4" "5"] res))))) + +(deftest test-run! + (is (nil? (run! identity [1]))) + (is (nil? (run! reduced (range))))) + +(deftest test-distinct + (are [out in] (= out (sequence (distinct in)) (sequence (distinct) in)) + [] [] + (range 10) (range 10) + [0] (repeat 10 0) + [0 1 2] [0 0 1 1 2 2 1 1 0 0] + [1] [1 1N])) + +(deftest test-interpose + (are [out in] (= out (sequence (interpose :s) in)) + [] (range 0) + [0] (range 1) + [0 :s 1] (range 2) + [0 :s 1 :s 2] (range 3)) + (testing "Can end reduction on separator or input" + (let [expected (interpose :s (range))] + (dotimes [i 10] + (is (= (take i expected) + (sequence (comp (interpose :s) (take i)) + (range)))))))) + +(deftest test-map-indexed + (is (= [] + (sequence (map-indexed vector) []))) + (is (= [[0 1] [1 2] [2 3] [3 4]] + (sequence (map-indexed vector) (range 1 5))))) + +(deftest test-into+halt-when + (is (= :anomaly (into [] (comp (filter some?) (halt-when #{:anomaly})) + [1 2 3 :anomaly 4]))) + (is (= {:anomaly :oh-no!, + :partial-results [1 2]} + (into [] + (halt-when :anomaly #(assoc %2 :partial-results %1)) + [1 2 {:anomaly :oh-no!} 3 4])))) diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/transients.clj b/Clojure/Clojure.Tests/clojure/test_clojure/transients.clj index bc7addddb..310760bef 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/transients.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/transients.clj @@ -29,54 +29,54 @@ (testing "disjoin multiple items in one call" (is (= #{5 20} (-> #{5 10 15 20} transient (disj! 10 15) persistent!))))) -(deftest empty-transient - (is (= false (.contains (transient #{}) :bogus-key)))) - -(deftest persistent-assoc-on-collision - (testing "Persistent assoc on a collision node which underwent a transient dissoc" - (let [a (reify Object (GetHashCode [_] 42)) ;;; hashCode - b (reify Object (GetHashCode [_] 42))] ;;; hashCode - (is (= (-> #{a b} transient (disj! a) persistent! (conj a)) - (-> #{a b} transient (disj! a) persistent! (conj a))))))) - -(deftest transient-mod-after-persistent - (let [v [1 2 3] - t (transient v) - t2 (conj! t 4) - p (persistent! t2)] - (is (= [1 2 3 4] p)) - (is (thrown? InvalidOperationException (conj! t2 5))))) ;;; IllegalAccessError - -(deftest transient-mod-ok-across-threads - (let [v [1 2 3] - t (transient v) - t2 @(future (conj! t 4)) - p (persistent! t2)] - (is (= [1 2 3 4] p)))) - - (deftest transient-lookups - (let [tv (transient [1 2 3])] - (is (= 1 (get tv 0))) - (is (= :foo (get tv 4 :foo))) - (is (= true (contains? tv 0))) - (is (= [0 1] (find tv 0))) - (is (= nil (find tv -1)))) - (let [ts (transient #{1 2})] - (is (= true (contains? ts 1))) - (is (= false (contains? ts 99))) - (is (= 1 (get ts 1))) - (is (= nil (get ts 99)))) - (let [tam (transient (array-map :a 1 :b 2))] - (is (= true (contains? tam :a))) - (is (= false (contains? tam :x))) - (is (= 1 (get tam :a))) - (is (= nil (get tam :x))) - (is (= [:a 1] (find tam :a))) - (is (= nil (find tam :x)))) - (let [thm (transient (hash-map :a 1 :b 2))] - (is (= true (contains? thm :a))) - (is (= false (contains? thm :x))) - (is (= 1 (get thm :a))) - (is (= nil (get thm :x))) - (is (= [:a 1] (find thm :a))) +(deftest empty-transient + (is (= false (.contains (transient #{}) :bogus-key)))) + +(deftest persistent-assoc-on-collision + (testing "Persistent assoc on a collision node which underwent a transient dissoc" + (let [a (reify Object (GetHashCode [_] 42)) ;;; hashCode + b (reify Object (GetHashCode [_] 42))] ;;; hashCode + (is (= (-> #{a b} transient (disj! a) persistent! (conj a)) + (-> #{a b} transient (disj! a) persistent! (conj a))))))) + +(deftest transient-mod-after-persistent + (let [v [1 2 3] + t (transient v) + t2 (conj! t 4) + p (persistent! t2)] + (is (= [1 2 3 4] p)) + (is (thrown? InvalidOperationException (conj! t2 5))))) ;;; IllegalAccessError + +(deftest transient-mod-ok-across-threads + (let [v [1 2 3] + t (transient v) + t2 @(future (conj! t 4)) + p (persistent! t2)] + (is (= [1 2 3 4] p)))) + + (deftest transient-lookups + (let [tv (transient [1 2 3])] + (is (= 1 (get tv 0))) + (is (= :foo (get tv 4 :foo))) + (is (= true (contains? tv 0))) + (is (= [0 1] (find tv 0))) + (is (= nil (find tv -1)))) + (let [ts (transient #{1 2})] + (is (= true (contains? ts 1))) + (is (= false (contains? ts 99))) + (is (= 1 (get ts 1))) + (is (= nil (get ts 99)))) + (let [tam (transient (array-map :a 1 :b 2))] + (is (= true (contains? tam :a))) + (is (= false (contains? tam :x))) + (is (= 1 (get tam :a))) + (is (= nil (get tam :x))) + (is (= [:a 1] (find tam :a))) + (is (= nil (find tam :x)))) + (let [thm (transient (hash-map :a 1 :b 2))] + (is (= true (contains? thm :a))) + (is (= false (contains? thm :x))) + (is (= 1 (get thm :a))) + (is (= nil (get thm :x))) + (is (= [:a 1] (find thm :a))) (is (= nil (find thm :x))))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/vars.clj b/Clojure/Clojure.Tests/clojure/test_clojure/vars.clj index 2c2c3ad09..fff5ed600 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/vars.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/vars.clj @@ -1,109 +1,109 @@ -; 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: Frantisek Sodomka, Stephen C. Gilardi - - -(ns clojure.test-clojure.vars - (:use clojure.test)) - -; http://clojure.org/vars - -; def -; defn defn- defonce - -; declare intern binding find-var var - -(def ^:dynamic a) -(deftest test-binding - (are [x y] (= x y) - (eval `(binding [a 4] a)) 4 ; regression in Clojure SVN r1370 - )) - -; var-get var-set alter-var-root [var? (predicates.clj)] -; with-in-str with-out-str -; with-open - -(deftest test-with-local-vars - (let [factorial (fn [x] - (with-local-vars [acc 1, cnt x] - (while (> @cnt 0) - (var-set acc (* @acc @cnt)) - (var-set cnt (dec @cnt))) - @acc))] - (is (= (factorial 5) 120)))) - -(deftest test-with-precision - (are [x y] (= x y) - (with-precision 4 (+ 3.5555555M 1)) 4.556M - (with-precision 6 (+ 3.5555555M 1)) 4.55556M - (with-precision 6 :rounding Ceiling (+ 3.5555555M 1)) 4.55556M ;;; CEILING - (with-precision 6 :rounding Floor (+ 3.5555555M 1)) 4.55555M ;;; FLOOR - (with-precision 6 :rounding HalfUp (+ 3.5555555M 1)) 4.55556M ;;; HALF_UP - (with-precision 6 :rounding HalfDown (+ 3.5555555M 1)) 4.55556M ;;; HALF_DOWN - (with-precision 6 :rounding HalfEven (+ 3.5555555M 1)) 4.55556M ;;; HALF_EVEN - (with-precision 6 :rounding Up (+ 3.5555555M 1)) 4.55556M ;;; UP - (with-precision 6 :rounding Down (+ 3.5555555M 1)) 4.55555M ;;; DOWN - (with-precision 6 :rounding Unnecessary (+ 3.5555M 1)) 4.5555M)) ;;; UNNECESSARY - -(deftest test-settable-math-context - (is (= - (clojure.main/with-bindings - (set! *math-context* (clojure.lang.BigDecimal+Context. 8)) ;;; java.math.MathContext - (+ 3.55555555555555M 1)) - 4.5555556M))) - -; set-validator get-validator - -; doc find-doc test - -(def stub-me :original) - -(deftest test-with-redefs-fn - (let [p (promise)] - (with-redefs-fn {#'stub-me :temp} - (fn [] - (.Start (System.Threading.Thread. (gen-delegate System.Threading.ThreadStart [] (deliver p stub-me)))) ;;; (.start (Thread. #(deliver p nil?))) - @p)) - (is (= :temp @p)) - (is (= :original stub-me)))) - -(deftest test-with-redefs - (let [p (promise)] - (with-redefs [stub-me :temp] - (.Start (System.Threading.Thread. (gen-delegate System.Threading.ThreadStart [] (deliver p stub-me)))) ;;; (.start (Thread. #(deliver p nil?))) - @p) - (is (= :temp @p)) - (is (= :original stub-me)))) - -(deftest test-with-redefs-throw - (let [p (promise)] - (is (thrown? Exception - (with-redefs [stub-me :temp] - (deliver p stub-me) - (throw (Exception. "simulated failure in with-redefs"))))) - (is (= :temp @p)) - (is (= :original stub-me)))) - -(def ^:dynamic dynamic-var 1) - -(deftest test-with-redefs-inside-binding - (binding [dynamic-var 2] - (is (= 2 dynamic-var)) - (with-redefs [dynamic-var 3] - (is (= 2 dynamic-var)))) - (is (= 1 dynamic-var))) - -(defn sample [& args] - 0) - -(deftest test-vars-apply-lazily - (is (= 0 (deref (future (apply sample (range))) - 1000 :timeout))) - (is (= 0 (deref (future (apply #'sample (range))) +; 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: Frantisek Sodomka, Stephen C. Gilardi + + +(ns clojure.test-clojure.vars + (:use clojure.test)) + +; http://clojure.org/vars + +; def +; defn defn- defonce + +; declare intern binding find-var var + +(def ^:dynamic a) +(deftest test-binding + (are [x y] (= x y) + (eval `(binding [a 4] a)) 4 ; regression in Clojure SVN r1370 + )) + +; var-get var-set alter-var-root [var? (predicates.clj)] +; with-in-str with-out-str +; with-open + +(deftest test-with-local-vars + (let [factorial (fn [x] + (with-local-vars [acc 1, cnt x] + (while (> @cnt 0) + (var-set acc (* @acc @cnt)) + (var-set cnt (dec @cnt))) + @acc))] + (is (= (factorial 5) 120)))) + +(deftest test-with-precision + (are [x y] (= x y) + (with-precision 4 (+ 3.5555555M 1)) 4.556M + (with-precision 6 (+ 3.5555555M 1)) 4.55556M + (with-precision 6 :rounding Ceiling (+ 3.5555555M 1)) 4.55556M ;;; CEILING + (with-precision 6 :rounding Floor (+ 3.5555555M 1)) 4.55555M ;;; FLOOR + (with-precision 6 :rounding HalfUp (+ 3.5555555M 1)) 4.55556M ;;; HALF_UP + (with-precision 6 :rounding HalfDown (+ 3.5555555M 1)) 4.55556M ;;; HALF_DOWN + (with-precision 6 :rounding HalfEven (+ 3.5555555M 1)) 4.55556M ;;; HALF_EVEN + (with-precision 6 :rounding Up (+ 3.5555555M 1)) 4.55556M ;;; UP + (with-precision 6 :rounding Down (+ 3.5555555M 1)) 4.55555M ;;; DOWN + (with-precision 6 :rounding Unnecessary (+ 3.5555M 1)) 4.5555M)) ;;; UNNECESSARY + +(deftest test-settable-math-context + (is (= + (clojure.main/with-bindings + (set! *math-context* (clojure.lang.BigDecimal+Context. 8)) ;;; java.math.MathContext + (+ 3.55555555555555M 1)) + 4.5555556M))) + +; set-validator get-validator + +; doc find-doc test + +(def stub-me :original) + +(deftest test-with-redefs-fn + (let [p (promise)] + (with-redefs-fn {#'stub-me :temp} + (fn [] + (.Start (System.Threading.Thread. (gen-delegate System.Threading.ThreadStart [] (deliver p stub-me)))) ;;; (.start (Thread. #(deliver p nil?))) + @p)) + (is (= :temp @p)) + (is (= :original stub-me)))) + +(deftest test-with-redefs + (let [p (promise)] + (with-redefs [stub-me :temp] + (.Start (System.Threading.Thread. (gen-delegate System.Threading.ThreadStart [] (deliver p stub-me)))) ;;; (.start (Thread. #(deliver p nil?))) + @p) + (is (= :temp @p)) + (is (= :original stub-me)))) + +(deftest test-with-redefs-throw + (let [p (promise)] + (is (thrown? Exception + (with-redefs [stub-me :temp] + (deliver p stub-me) + (throw (Exception. "simulated failure in with-redefs"))))) + (is (= :temp @p)) + (is (= :original stub-me)))) + +(def ^:dynamic dynamic-var 1) + +(deftest test-with-redefs-inside-binding + (binding [dynamic-var 2] + (is (= 2 dynamic-var)) + (with-redefs [dynamic-var 3] + (is (= 2 dynamic-var)))) + (is (= 1 dynamic-var))) + +(defn sample [& args] + 0) + +(deftest test-vars-apply-lazily + (is (= 0 (deref (future (apply sample (range))) + 1000 :timeout))) + (is (= 0 (deref (future (apply #'sample (range))) 1000 :timeout)))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/vectors.clj b/Clojure/Clojure.Tests/clojure/test_clojure/vectors.clj index 2ad5daf67..e407c9561 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/vectors.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/vectors.clj @@ -77,14 +77,14 @@ vs-1 vs vs vs-32 vs-32 vs - vs nil)) - (testing "internal-reduce" + vs nil)) + (testing "internal-reduce" (is (= [99] (into [] (drop 99 vs))))))) -(deftest test-primitive-subvector-reduce - ;; regression test for CLJ-1082 - (is (== 60 (let [prim-vec (into (vector-of :long) (range 1000))] - (reduce + (subvec prim-vec 10 15)))))) +(deftest test-primitive-subvector-reduce + ;; regression test for CLJ-1082 + (is (== 60 (let [prim-vec (into (vector-of :long) (range 1000))] + (reduce + (subvec prim-vec 10 15)))))) (deftest test-vec-compare (let [nums (range 1 100) @@ -330,8 +330,8 @@ (vector-of "")))) (testing "vector-like (vector-of :type x1 x2 x3 … xn)" (are [vec gvec] (and (instance? clojure.core.Vec gvec) - (= (into (vector-of :int) vec) gvec) - (= vec gvec) + (= (into (vector-of :int) vec) gvec) + (= vec gvec) (= (hash vec) (hash gvec))) [1] (vector-of :int 1) [1 2] (vector-of :int 1 2) @@ -361,20 +361,20 @@ (vector-of :int #{1 2 3 4}) (vector-of :int (sorted-set 1 2 3 4)) ;;;(vector-of :int 1 2 "3") - )) ;;; (vector-of :int "1" "2" "3") - (testing "instances of IPersistentVector" - (are [gvec] (instance? clojure.lang.IPersistentVector gvec) - (vector-of :int 1 2 3) - (vector-of :double 1 2 3))) - (testing "fully implements IPersistentVector" - (are [gvec] (= 3 (.length gvec)) - (vector-of :int 1 2 3) + )) ;;; (vector-of :int "1" "2" "3") + (testing "instances of IPersistentVector" + (are [gvec] (instance? clojure.lang.IPersistentVector gvec) + (vector-of :int 1 2 3) + (vector-of :double 1 2 3))) + (testing "fully implements IPersistentVector" + (are [gvec] (= 3 (.length gvec)) + (vector-of :int 1 2 3) (vector-of :double 1 2 3))))) -(deftest empty-vector-equality - (let [colls [[] (vector-of :long) '()]] - (doseq [c1 colls, c2 colls] - (is (= c1 c2)) +(deftest empty-vector-equality + (let [colls [[] (vector-of :long) '()]] + (doseq [c1 colls, c2 colls] + (is (= c1 c2)) (is (.Equals c1 c2))))) ;;; .equals (defn =vec @@ -403,28 +403,28 @@ (is (= (v1 50) (v2 0))) (is (= (v1 56) (v2 6))))) -(deftest test-vec - (is (= [1 2] (vec (first {1 2})))) - (is (= [0 1 2 3] (vec [0 1 2 3]))) - (is (= [0 1 2 3] (vec (list 0 1 2 3)))) - (is (= [0 1 2 3] (vec (sorted-set 0 1 2 3)))) - (is (= [[1 2] [3 4]] (vec (sorted-map 1 2 3 4)))) - (is (= [0 1 2 3] (vec (range 4)))) - (is (= [\a \b \c \d] (vec "abcd"))) - (is (= [0 1 2 3] (vec (object-array (range 4))))) - (is (= [1 2 3 4] (vec (eduction (map inc) (range 4))))) - (is (= [0 1 2 3] (vec (reify clojure.lang.IReduceInit - (reduce [_ f start] - (reduce f start (range 4)))))))) - -(deftest test-reduce-kv-vectors - (is (= 25 (reduce-kv + 10 [2 4 6]))) - (is (= 25 (reduce-kv + 10 (subvec [0 2 4 6] 1))))) - -(deftest test-vector-eqv-to-non-counted-types - (is (not= (range) [0 1 2])) - (is (not= [0 1 2] (range))) - (is (= [0 1 2] (take 3 (range)))) - (is (= [0 1 2] (new System.Collections.ArrayList [0 1 2]))) ;;; java.util.ArrayList - (is (not= [1 2] (take 1 (cycle [1 2])))) +(deftest test-vec + (is (= [1 2] (vec (first {1 2})))) + (is (= [0 1 2 3] (vec [0 1 2 3]))) + (is (= [0 1 2 3] (vec (list 0 1 2 3)))) + (is (= [0 1 2 3] (vec (sorted-set 0 1 2 3)))) + (is (= [[1 2] [3 4]] (vec (sorted-map 1 2 3 4)))) + (is (= [0 1 2 3] (vec (range 4)))) + (is (= [\a \b \c \d] (vec "abcd"))) + (is (= [0 1 2 3] (vec (object-array (range 4))))) + (is (= [1 2 3 4] (vec (eduction (map inc) (range 4))))) + (is (= [0 1 2 3] (vec (reify clojure.lang.IReduceInit + (reduce [_ f start] + (reduce f start (range 4)))))))) + +(deftest test-reduce-kv-vectors + (is (= 25 (reduce-kv + 10 [2 4 6]))) + (is (= 25 (reduce-kv + 10 (subvec [0 2 4 6] 1))))) + +(deftest test-vector-eqv-to-non-counted-types + (is (not= (range) [0 1 2])) + (is (not= [0 1 2] (range))) + (is (= [0 1 2] (take 3 (range)))) + (is (= [0 1 2] (new System.Collections.ArrayList [0 1 2]))) ;;; java.util.ArrayList + (is (not= [1 2] (take 1 (cycle [1 2])))) (is (= [1 2 3 nil 4 5 6 nil] (eduction cat [[1 2 3 nil] [4 5 6 nil]])))) \ No newline at end of file diff --git a/Clojure/Clojure.Tests/clojure/test_clojure/volatiles.clj b/Clojure/Clojure.Tests/clojure/test_clojure/volatiles.clj index e4b52928c..5887dcd0c 100644 --- a/Clojure/Clojure.Tests/clojure/test_clojure/volatiles.clj +++ b/Clojure/Clojure.Tests/clojure/test_clojure/volatiles.clj @@ -1,30 +1,30 @@ -; 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: Alex Miller - -(ns clojure.test-clojure.volatiles - (:use clojure.test)) - -(deftest volatile-basics - (let [vol (volatile! "abc")] - (is (volatile? vol)) - (is (= "abc" @vol)) - (is (= "def" (vreset! vol "def"))) - (is (= "def" @vol)))) - -(deftest volatile-vswap! - (let [vol (volatile! 10)] - (is (= 11 (vswap! vol inc))) - (is (= 11 @vol))) - (let [vol (volatile! 10)] - (is (= 20 (vswap! vol + 10))) - (is (= 20 @vol))) - (let [vol (volatile! 10)] - (is (= 25 (vswap! vol + 10 5))) - (is (= 25 @vol)))) +; 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: Alex Miller + +(ns clojure.test-clojure.volatiles + (:use clojure.test)) + +(deftest volatile-basics + (let [vol (volatile! "abc")] + (is (volatile? vol)) + (is (= "abc" @vol)) + (is (= "def" (vreset! vol "def"))) + (is (= "def" @vol)))) + +(deftest volatile-vswap! + (let [vol (volatile! 10)] + (is (= 11 (vswap! vol inc))) + (is (= 11 @vol))) + (let [vol (volatile! 10)] + (is (= 20 (vswap! vol + 10))) + (is (= 20 @vol))) + (let [vol (volatile! 10)] + (is (= 25 (vswap! vol + 10 5))) + (is (= 25 @vol)))) diff --git a/Clojure/Clojure.Tests/clojure/test_helper.clj b/Clojure/Clojure.Tests/clojure/test_helper.clj index 3aa934452..4edffe8e3 100644 --- a/Clojure/Clojure.Tests/clojure/test_helper.clj +++ b/Clojure/Clojure.Tests/clojure/test_helper.clj @@ -1,152 +1,152 @@ -; 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. -; - -;; clojure.test-helper -;; -;; Utility functions shared by various tests in the Clojure -;; test suite -;; -;; tomfaulhaber (gmail) -;; Created 04 November 2010 - -(ns clojure.test-helper - (:use clojure.test) - (:import (System.Reflection BindingFlags))) ;;; added import - -(let [nl Environment/NewLine] ;;; (System/getProperty "line.separator")] - (defn platform-newlines [s] (.Replace s "\n" nl))) ;;; .replace - -(defn temp-ns - "Create and return a temporary ns, using clojure.core + uses" - [& uses] - (binding [*ns* *ns*] - (in-ns (gensym)) - (apply clojure.core/use 'clojure.core uses) - *ns*)) - -(defmacro eval-in-temp-ns [& forms] - `(binding [*ns* *ns*] - (in-ns (gensym)) - (clojure.core/use 'clojure.core) - (eval - '(do ~@forms)))) - -(defn causes - [^Exception throwable] ;;; Throwable - (loop [causes [] - t throwable] - (if t (recur (conj causes t) (.InnerException t)) causes))) ;;; .getCause - -;; this is how I wish clojure.test/thrown? worked... -;; Does body throw expected exception, anywhere in the .getCause chain? -(defmethod assert-expr 'fails-with-cause? - [msg [_ exception-class msg-re & body :as form]] - `(try - ~@body - (report {:type :fail, :message ~msg, :expected '~form, :actual nil}) - (catch Exception t# ;;; Throwable - (if (some (fn [cause#] - (and - (= ~exception-class (class cause#)) - (re-find ~msg-re (.Message cause#)))) ;;; .getMessage - (causes t#)) - (report {:type :pass, :message ~msg, - :expected '~form, :actual t#}) - (report {:type :fail, :message ~msg, - :expected '~form, :actual t#}))))) - - -(defn get-field - "Access to private or protected field. field-name is a symbol or - keyword." - ([klass field-name] - (get-field klass field-name nil)) - ([klass field-name inst] - (-> klass (.GetField (name field-name) (enum-or BindingFlags/Public BindingFlags/NonPublic BindingFlags/DeclaredOnly BindingFlags/Instance BindingFlags/Static)) ;;; (.getDeclaredField (name field-name)) - ;;;(doto (.setAccessible true)) - (.GetValue inst)))) ;;; .get - -(defn set-var-roots - [maplike] - (doseq [[var val] maplike] - (alter-var-root var (fn [_] val)))) - -(defn with-var-roots* - "Temporarily set var roots, run block, then put original roots back." - [root-map f & args] - (let [originals (doall (map (fn [[var _]] [var @var]) root-map))] - (set-var-roots root-map) - (try - (apply f args) - (finally - (set-var-roots originals))))) - -(defmacro with-var-roots - [root-map & body] - `(with-var-roots* ~root-map (fn [] ~@body))) - -(defn exception - "Use this function to ensure that execution of a program doesn't - reach certain point." - [] - (throw (new Exception "Exception which should never occur"))) - -(defmacro with-err-print-writer - "Evaluate with err pointing to a temporary PrintWriter, and - return err contents as a string." - [& body] - `(let [s# (System.IO.StringWriter.) ;;; java.io.StringWriter. - p# s#] ;;; not needed: (java.io.PrintWriter. s#)] - (binding [*err* p#] - ~@body - (str s#)))) - -(defmacro with-err-string-writer - "Evaluate with err pointing to a temporary StringWriter, and - return err contents as a string." - [& body] - `(let [s# (System.IO.StringWriter.)] ;;; java.io.StringWriter. - (binding [*err* s#] - ~@body - (str s#)))) - -(defmacro should-print-err-message - "Turn on all warning flags, and test that error message prints - correctly for all semi-reasonable bindings of *err*." - [msg-re form] - `(binding [*warn-on-reflection* true] - (is (re-matches ~msg-re (with-err-string-writer (eval-in-temp-ns ~form)))) - (is (re-matches ~msg-re (with-err-print-writer (eval-in-temp-ns ~form)))))) - -(defmacro should-not-reflect - "Turn on all warning flags, and test that reflection does not occur - (as identified by messages to *err*)." - [form] - `(binding [*warn-on-reflection* true] - (is (nil? (re-find #"^Reflection warning" (with-err-string-writer (eval-in-temp-ns ~form))))) - (is (nil? (re-find #"^Reflection warning" (with-err-print-writer (eval-in-temp-ns ~form))))))) - -(defmethod clojure.test/assert-expr 'thrown-with-cause-msg? [msg form] - ;; (is (thrown-with-cause-msg? c re expr)) - ;; Asserts that evaluating expr throws an exception of class c. - ;; Also asserts that the message string of the *cause* exception matches - ;; (with re-find) the regular expression re. - (let [klass (nth form 1) - re (nth form 2) - body (nthnext form 3)] - `(try ~@body - (do-report {:type :fail, :message ~msg, :expected '~form, :actual nil}) - (catch ~klass e# - (let [m# (if (.InnerException e#) (.. e# InnerException Message) (.Message e#))] ;.getCause .getCause .getMessage .getMessage - (if (re-find ~re m#) - (do-report {:type :pass, :message ~msg, - :expected '~form, :actual e#}) - (do-report {:type :fail, :message ~msg, - :expected '~form, :actual e#}))) +; 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. +; + +;; clojure.test-helper +;; +;; Utility functions shared by various tests in the Clojure +;; test suite +;; +;; tomfaulhaber (gmail) +;; Created 04 November 2010 + +(ns clojure.test-helper + (:use clojure.test) + (:import (System.Reflection BindingFlags))) ;;; added import + +(let [nl Environment/NewLine] ;;; (System/getProperty "line.separator")] + (defn platform-newlines [s] (.Replace s "\n" nl))) ;;; .replace + +(defn temp-ns + "Create and return a temporary ns, using clojure.core + uses" + [& uses] + (binding [*ns* *ns*] + (in-ns (gensym)) + (apply clojure.core/use 'clojure.core uses) + *ns*)) + +(defmacro eval-in-temp-ns [& forms] + `(binding [*ns* *ns*] + (in-ns (gensym)) + (clojure.core/use 'clojure.core) + (eval + '(do ~@forms)))) + +(defn causes + [^Exception throwable] ;;; Throwable + (loop [causes [] + t throwable] + (if t (recur (conj causes t) (.InnerException t)) causes))) ;;; .getCause + +;; this is how I wish clojure.test/thrown? worked... +;; Does body throw expected exception, anywhere in the .getCause chain? +(defmethod assert-expr 'fails-with-cause? + [msg [_ exception-class msg-re & body :as form]] + `(try + ~@body + (report {:type :fail, :message ~msg, :expected '~form, :actual nil}) + (catch Exception t# ;;; Throwable + (if (some (fn [cause#] + (and + (= ~exception-class (class cause#)) + (re-find ~msg-re (.Message cause#)))) ;;; .getMessage + (causes t#)) + (report {:type :pass, :message ~msg, + :expected '~form, :actual t#}) + (report {:type :fail, :message ~msg, + :expected '~form, :actual t#}))))) + + +(defn get-field + "Access to private or protected field. field-name is a symbol or + keyword." + ([klass field-name] + (get-field klass field-name nil)) + ([klass field-name inst] + (-> klass (.GetField (name field-name) (enum-or BindingFlags/Public BindingFlags/NonPublic BindingFlags/DeclaredOnly BindingFlags/Instance BindingFlags/Static)) ;;; (.getDeclaredField (name field-name)) + ;;;(doto (.setAccessible true)) + (.GetValue inst)))) ;;; .get + +(defn set-var-roots + [maplike] + (doseq [[var val] maplike] + (alter-var-root var (fn [_] val)))) + +(defn with-var-roots* + "Temporarily set var roots, run block, then put original roots back." + [root-map f & args] + (let [originals (doall (map (fn [[var _]] [var @var]) root-map))] + (set-var-roots root-map) + (try + (apply f args) + (finally + (set-var-roots originals))))) + +(defmacro with-var-roots + [root-map & body] + `(with-var-roots* ~root-map (fn [] ~@body))) + +(defn exception + "Use this function to ensure that execution of a program doesn't + reach certain point." + [] + (throw (new Exception "Exception which should never occur"))) + +(defmacro with-err-print-writer + "Evaluate with err pointing to a temporary PrintWriter, and + return err contents as a string." + [& body] + `(let [s# (System.IO.StringWriter.) ;;; java.io.StringWriter. + p# s#] ;;; not needed: (java.io.PrintWriter. s#)] + (binding [*err* p#] + ~@body + (str s#)))) + +(defmacro with-err-string-writer + "Evaluate with err pointing to a temporary StringWriter, and + return err contents as a string." + [& body] + `(let [s# (System.IO.StringWriter.)] ;;; java.io.StringWriter. + (binding [*err* s#] + ~@body + (str s#)))) + +(defmacro should-print-err-message + "Turn on all warning flags, and test that error message prints + correctly for all semi-reasonable bindings of *err*." + [msg-re form] + `(binding [*warn-on-reflection* true] + (is (re-matches ~msg-re (with-err-string-writer (eval-in-temp-ns ~form)))) + (is (re-matches ~msg-re (with-err-print-writer (eval-in-temp-ns ~form)))))) + +(defmacro should-not-reflect + "Turn on all warning flags, and test that reflection does not occur + (as identified by messages to *err*)." + [form] + `(binding [*warn-on-reflection* true] + (is (nil? (re-find #"^Reflection warning" (with-err-string-writer (eval-in-temp-ns ~form))))) + (is (nil? (re-find #"^Reflection warning" (with-err-print-writer (eval-in-temp-ns ~form))))))) + +(defmethod clojure.test/assert-expr 'thrown-with-cause-msg? [msg form] + ;; (is (thrown-with-cause-msg? c re expr)) + ;; Asserts that evaluating expr throws an exception of class c. + ;; Also asserts that the message string of the *cause* exception matches + ;; (with re-find) the regular expression re. + (let [klass (nth form 1) + re (nth form 2) + body (nthnext form 3)] + `(try ~@body + (do-report {:type :fail, :message ~msg, :expected '~form, :actual nil}) + (catch ~klass e# + (let [m# (if (.InnerException e#) (.. e# InnerException Message) (.Message e#))] ;.getCause .getCause .getMessage .getMessage + (if (re-find ~re m#) + (do-report {:type :pass, :message ~msg, + :expected '~form, :actual e#}) + (do-report {:type :fail, :message ~msg, + :expected '~form, :actual e#}))) e#)))) \ No newline at end of file diff --git a/Clojure/Clojure/CljCompiler/ArrayIter.cs b/Clojure/Clojure/CljCompiler/ArrayIter.cs index b1122dc6d..fca8f5063 100644 --- a/Clojure/Clojure/CljCompiler/ArrayIter.cs +++ b/Clojure/Clojure/CljCompiler/ArrayIter.cs @@ -1,73 +1,73 @@ -/** - * 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; -using System.Collections.Generic; -using System.Linq; -using System.Text; - -namespace clojure.lang -{ - public static class ArrayIter - { - - static IEnumerable ArrayEnumerable(T[] array, int start) - { - if (array == null || array.Length == 0 ) - yield break; - else - { - for ( int i=start; i create(params Object[] items ) - { - return ArrayEnumerable(items,0).GetEnumerator(); - } - - [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE1006:Naming Styles", Justification = "ClojureJVM name match")] - public static IEnumerator createFromObject(object array) - { - if (array == null) - return ArrayEnumerable(null,0).GetEnumerator(); - - Type eType = array.GetType().GetElementType(); - - switch (Type.GetTypeCode(eType)) { - - case TypeCode.Int16: return ArrayEnumerable((Int16[])array,0).GetEnumerator(); - case TypeCode.Int32: return ArrayEnumerable((Int32[])array,0).GetEnumerator(); - case TypeCode.Int64: return ArrayEnumerable((Int64[])array,0).GetEnumerator(); - case TypeCode.UInt16: return ArrayEnumerable((UInt16[])array,0).GetEnumerator(); - case TypeCode.UInt32: return ArrayEnumerable((UInt32[])array,0).GetEnumerator(); - case TypeCode.UInt64: return ArrayEnumerable((UInt64[])array,0).GetEnumerator(); - case TypeCode.Single: return ArrayEnumerable((Single[])array,0).GetEnumerator(); - case TypeCode.Double: return ArrayEnumerable((Double[])array,0).GetEnumerator(); - case TypeCode.Byte: return ArrayEnumerable((Byte[])array,0).GetEnumerator(); - case TypeCode.SByte: return ArrayEnumerable((SByte[])array,0).GetEnumerator(); - case TypeCode.Decimal: return ArrayEnumerable((Decimal[])array,0).GetEnumerator(); - case TypeCode.Char: return ArrayEnumerable((Char[])array,0).GetEnumerator(); - case TypeCode.Boolean: return ArrayEnumerable((Boolean[])array,0).GetEnumerator(); - case TypeCode.Object: return ArrayEnumerable((Object[])array,0).GetEnumerator(); - default: - return ((Array)array).GetEnumerator(); - } - - } - } -} +/** + * 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; +using System.Collections.Generic; +using System.Linq; +using System.Text; + +namespace clojure.lang +{ + public static class ArrayIter + { + + static IEnumerable ArrayEnumerable(T[] array, int start) + { + if (array == null || array.Length == 0 ) + yield break; + else + { + for ( int i=start; i create(params Object[] items ) + { + return ArrayEnumerable(items,0).GetEnumerator(); + } + + [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE1006:Naming Styles", Justification = "ClojureJVM name match")] + public static IEnumerator createFromObject(object array) + { + if (array == null) + return ArrayEnumerable(null,0).GetEnumerator(); + + Type eType = array.GetType().GetElementType(); + + switch (Type.GetTypeCode(eType)) { + + case TypeCode.Int16: return ArrayEnumerable((Int16[])array,0).GetEnumerator(); + case TypeCode.Int32: return ArrayEnumerable((Int32[])array,0).GetEnumerator(); + case TypeCode.Int64: return ArrayEnumerable((Int64[])array,0).GetEnumerator(); + case TypeCode.UInt16: return ArrayEnumerable((UInt16[])array,0).GetEnumerator(); + case TypeCode.UInt32: return ArrayEnumerable((UInt32[])array,0).GetEnumerator(); + case TypeCode.UInt64: return ArrayEnumerable((UInt64[])array,0).GetEnumerator(); + case TypeCode.Single: return ArrayEnumerable((Single[])array,0).GetEnumerator(); + case TypeCode.Double: return ArrayEnumerable((Double[])array,0).GetEnumerator(); + case TypeCode.Byte: return ArrayEnumerable((Byte[])array,0).GetEnumerator(); + case TypeCode.SByte: return ArrayEnumerable((SByte[])array,0).GetEnumerator(); + case TypeCode.Decimal: return ArrayEnumerable((Decimal[])array,0).GetEnumerator(); + case TypeCode.Char: return ArrayEnumerable((Char[])array,0).GetEnumerator(); + case TypeCode.Boolean: return ArrayEnumerable((Boolean[])array,0).GetEnumerator(); + case TypeCode.Object: return ArrayEnumerable((Object[])array,0).GetEnumerator(); + default: + return ((Array)array).GetEnumerator(); + } + + } + } +} diff --git a/Clojure/Clojure/CljCompiler/Ast/AssignExpr.cs b/Clojure/Clojure/CljCompiler/Ast/AssignExpr.cs index bc6ab4c6b..29d8d7bd0 100644 --- a/Clojure/Clojure/CljCompiler/Ast/AssignExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/AssignExpr.cs @@ -1,96 +1,96 @@ -/** - * 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; - -namespace clojure.lang.CljCompiler.Ast -{ - public class AssignExpr : Expr - { - #region Data - - readonly AssignableExpr _target; - public AssignableExpr Target { get { return _target; } } - - readonly Expr _val; - public Expr Val { get { return _val; } } - - #endregion - - #region Ctors - - public AssignExpr(AssignableExpr target, Expr val) - { - _target = target; - _val = val; - } - - #endregion - - #region Type mangling - - public bool HasClrType - { - get { return Val.HasClrType; } - } - - public Type ClrType - { - get { return Val.ClrType; } - } - - #endregion - - #region Parsing - - public sealed class Parser : IParser - { - public Expr Parse(ParserContext pcon, object frm) - { - ISeq form = (ISeq)frm; - if (RT.Length(form) != 3) - throw new ParseException("Malformed assignment, expecting (set! target val)"); - Expr target = Compiler.Analyze(new ParserContext(RHC.Expression, true), RT.second(form)); - - if (!(target is AssignableExpr ae)) - throw new ParseException("Invalid assignment target"); - - return new AssignExpr(ae, Compiler.Analyze(pcon.SetRhc(RHC.Expression),RT.third(form))); - } - } - - #endregion - - #region Eval - - public object Eval() - { - return _target.EvalAssign(_val); - } - - #endregion - - #region Code generation - - public void Emit(RHC rhc, ObjExpr objx, CljILGen ilg) - { - _target.EmitAssign(rhc, objx, ilg, _val); - } - - public bool HasNormalExit() { return true; } - - #endregion - - } -} +/** + * 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; + +namespace clojure.lang.CljCompiler.Ast +{ + public class AssignExpr : Expr + { + #region Data + + readonly AssignableExpr _target; + public AssignableExpr Target { get { return _target; } } + + readonly Expr _val; + public Expr Val { get { return _val; } } + + #endregion + + #region Ctors + + public AssignExpr(AssignableExpr target, Expr val) + { + _target = target; + _val = val; + } + + #endregion + + #region Type mangling + + public bool HasClrType + { + get { return Val.HasClrType; } + } + + public Type ClrType + { + get { return Val.ClrType; } + } + + #endregion + + #region Parsing + + public sealed class Parser : IParser + { + public Expr Parse(ParserContext pcon, object frm) + { + ISeq form = (ISeq)frm; + if (RT.Length(form) != 3) + throw new ParseException("Malformed assignment, expecting (set! target val)"); + Expr target = Compiler.Analyze(new ParserContext(RHC.Expression, true), RT.second(form)); + + if (!(target is AssignableExpr ae)) + throw new ParseException("Invalid assignment target"); + + return new AssignExpr(ae, Compiler.Analyze(pcon.SetRhc(RHC.Expression),RT.third(form))); + } + } + + #endregion + + #region Eval + + public object Eval() + { + return _target.EvalAssign(_val); + } + + #endregion + + #region Code generation + + public void Emit(RHC rhc, ObjExpr objx, CljILGen ilg) + { + _target.EmitAssign(rhc, objx, ilg, _val); + } + + public bool HasNormalExit() { return true; } + + #endregion + + } +} diff --git a/Clojure/Clojure/CljCompiler/Ast/AssignableExpr.cs b/Clojure/Clojure/CljCompiler/Ast/AssignableExpr.cs index 380d70bee..b4e894d9b 100644 --- a/Clojure/Clojure/CljCompiler/Ast/AssignableExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/AssignableExpr.cs @@ -1,25 +1,25 @@ -/** - * 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 - **/ - - -namespace clojure.lang.CljCompiler.Ast -{ - [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE1006:Naming Styles", Justification = "ClojureJVM name match")] - public interface AssignableExpr - { - object EvalAssign(Expr val); - void EmitAssign(RHC rhc, ObjExpr objx, CljILGen ilg, Expr val); - - } -} +/** + * 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 + **/ + + +namespace clojure.lang.CljCompiler.Ast +{ + [System.Diagnostics.CodeAnalysis.SuppressMessage("Style", "IDE1006:Naming Styles", Justification = "ClojureJVM name match")] + public interface AssignableExpr + { + object EvalAssign(Expr val); + void EmitAssign(RHC rhc, ObjExpr objx, CljILGen ilg, Expr val); + + } +} diff --git a/Clojure/Clojure/CljCompiler/Ast/BindingInit.cs b/Clojure/Clojure/CljCompiler/Ast/BindingInit.cs index c921d913b..1a6569fc7 100644 --- a/Clojure/Clojure/CljCompiler/Ast/BindingInit.cs +++ b/Clojure/Clojure/CljCompiler/Ast/BindingInit.cs @@ -1,69 +1,69 @@ -/** - * 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 - **/ - - -namespace clojure.lang.CljCompiler.Ast -{ - public struct BindingInit - { - #region Data - - private readonly LocalBinding _binding; - public LocalBinding Binding { get { return _binding; } } - - private readonly Expr _init; - public Expr Init { get { return _init; } } - - #endregion - - #region Ctors - - public BindingInit(LocalBinding binding, Expr init) - { - _binding = binding; - _init = init; - } - - #endregion - - #region Object overrides - - public override bool Equals(object obj) - { - if ( ! (obj is BindingInit) ) - return false; - - BindingInit bi = (BindingInit) obj; - - return _binding.Equals(bi._binding) && bi._init.Equals(bi._init); - } - - public static bool operator ==(BindingInit b1, BindingInit b2) - { - return b1.Equals(b2); - } - - public static bool operator !=(BindingInit b1, BindingInit b2) - { - return !b1.Equals(b2); - } - - public override int GetHashCode() - { - return Util.hashCombine(_binding.GetHashCode(), _init.GetHashCode()); - } - - #endregion - } -} +/** + * 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 + **/ + + +namespace clojure.lang.CljCompiler.Ast +{ + public struct BindingInit + { + #region Data + + private readonly LocalBinding _binding; + public LocalBinding Binding { get { return _binding; } } + + private readonly Expr _init; + public Expr Init { get { return _init; } } + + #endregion + + #region Ctors + + public BindingInit(LocalBinding binding, Expr init) + { + _binding = binding; + _init = init; + } + + #endregion + + #region Object overrides + + public override bool Equals(object obj) + { + if ( ! (obj is BindingInit) ) + return false; + + BindingInit bi = (BindingInit) obj; + + return _binding.Equals(bi._binding) && bi._init.Equals(bi._init); + } + + public static bool operator ==(BindingInit b1, BindingInit b2) + { + return b1.Equals(b2); + } + + public static bool operator !=(BindingInit b1, BindingInit b2) + { + return !b1.Equals(b2); + } + + public override int GetHashCode() + { + return Util.hashCombine(_binding.GetHashCode(), _init.GetHashCode()); + } + + #endregion + } +} diff --git a/Clojure/Clojure/CljCompiler/Ast/BodyExpr.cs b/Clojure/Clojure/CljCompiler/Ast/BodyExpr.cs index 9dc42d0d4..8bee03255 100644 --- a/Clojure/Clojure/CljCompiler/Ast/BodyExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/BodyExpr.cs @@ -1,133 +1,133 @@ -/** - * 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; - -namespace clojure.lang.CljCompiler.Ast -{ - public class BodyExpr : Expr, MaybePrimitiveExpr - { - #region Data - - readonly IPersistentVector _exprs; - public IPersistentVector Exprs { get { return _exprs; } } - - public Expr LastExpr - { - get - { - return (Expr)_exprs.nth(_exprs.count() - 1); - } - } - - #endregion - - #region Ctors - - public BodyExpr(IPersistentVector exprs) - { - _exprs = exprs; - } - - #endregion - - #region Type mangling - - public bool HasClrType - { - get { return LastExpr.HasClrType; } - } - - public Type ClrType - { - get { return LastExpr.ClrType; } - } - - #endregion - - #region Parsing - - public sealed class Parser : IParser - { - public Expr Parse(ParserContext pcon, object frms) - { - ISeq forms = (ISeq)frms; - - if (Util.equals(RT.first(forms), Compiler.DoSym)) - forms = RT.next(forms); - - IPersistentVector exprs = PersistentVector.EMPTY; - - for (; forms != null; forms = forms.next()) - { - Expr e = (pcon.Rhc != RHC.Eval && (pcon.Rhc == RHC.Statement || forms.next() != null)) - ? Compiler.Analyze(pcon.SetRhc(RHC.Statement), forms.first()) - : Compiler.Analyze(pcon, forms.first()); - exprs = exprs.cons(e); - } - if (exprs.count() == 0) - exprs = exprs.cons(Compiler.NilExprInstance); - - return new BodyExpr(exprs); - } - } - - #endregion - - #region eval - - public object Eval() - { - object ret = null; - for ( int i=0; i<_exprs.count(); i++ ) - ret = ((Expr)_exprs.nth(i)).Eval(); - - return ret; - } - - #endregion - - #region Code generation - - public void Emit(RHC rhc, ObjExpr objx, CljILGen ilg) - { - for (int i = 0; i < _exprs.count() - 1; i++) - { - Expr e = (Expr)_exprs.nth(i); - e.Emit(RHC.Statement, objx, ilg); - } - LastExpr.Emit(rhc, objx, ilg); - } - - public bool CanEmitPrimitive - { - get { return LastExpr is MaybePrimitiveExpr expr && expr.CanEmitPrimitive; } - } - - public void EmitUnboxed(RHC rhc, ObjExpr objx, CljILGen ilg) - { - for (int i = 0; i < _exprs.count() - 1; i++) - { - Expr e = (Expr)_exprs.nth(i); - e.Emit(RHC.Statement, objx, ilg); - } - MaybePrimitiveExpr mbe = (MaybePrimitiveExpr)LastExpr; - mbe.EmitUnboxed(rhc, objx, ilg); - } - - public bool HasNormalExit() { return LastExpr.HasNormalExit(); } - - #endregion - } -} +/** + * 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; + +namespace clojure.lang.CljCompiler.Ast +{ + public class BodyExpr : Expr, MaybePrimitiveExpr + { + #region Data + + readonly IPersistentVector _exprs; + public IPersistentVector Exprs { get { return _exprs; } } + + public Expr LastExpr + { + get + { + return (Expr)_exprs.nth(_exprs.count() - 1); + } + } + + #endregion + + #region Ctors + + public BodyExpr(IPersistentVector exprs) + { + _exprs = exprs; + } + + #endregion + + #region Type mangling + + public bool HasClrType + { + get { return LastExpr.HasClrType; } + } + + public Type ClrType + { + get { return LastExpr.ClrType; } + } + + #endregion + + #region Parsing + + public sealed class Parser : IParser + { + public Expr Parse(ParserContext pcon, object frms) + { + ISeq forms = (ISeq)frms; + + if (Util.equals(RT.first(forms), Compiler.DoSym)) + forms = RT.next(forms); + + IPersistentVector exprs = PersistentVector.EMPTY; + + for (; forms != null; forms = forms.next()) + { + Expr e = (pcon.Rhc != RHC.Eval && (pcon.Rhc == RHC.Statement || forms.next() != null)) + ? Compiler.Analyze(pcon.SetRhc(RHC.Statement), forms.first()) + : Compiler.Analyze(pcon, forms.first()); + exprs = exprs.cons(e); + } + if (exprs.count() == 0) + exprs = exprs.cons(Compiler.NilExprInstance); + + return new BodyExpr(exprs); + } + } + + #endregion + + #region eval + + public object Eval() + { + object ret = null; + for ( int i=0; i<_exprs.count(); i++ ) + ret = ((Expr)_exprs.nth(i)).Eval(); + + return ret; + } + + #endregion + + #region Code generation + + public void Emit(RHC rhc, ObjExpr objx, CljILGen ilg) + { + for (int i = 0; i < _exprs.count() - 1; i++) + { + Expr e = (Expr)_exprs.nth(i); + e.Emit(RHC.Statement, objx, ilg); + } + LastExpr.Emit(rhc, objx, ilg); + } + + public bool CanEmitPrimitive + { + get { return LastExpr is MaybePrimitiveExpr expr && expr.CanEmitPrimitive; } + } + + public void EmitUnboxed(RHC rhc, ObjExpr objx, CljILGen ilg) + { + for (int i = 0; i < _exprs.count() - 1; i++) + { + Expr e = (Expr)_exprs.nth(i); + e.Emit(RHC.Statement, objx, ilg); + } + MaybePrimitiveExpr mbe = (MaybePrimitiveExpr)LastExpr; + mbe.EmitUnboxed(rhc, objx, ilg); + } + + public bool HasNormalExit() { return LastExpr.HasNormalExit(); } + + #endregion + } +} diff --git a/Clojure/Clojure/CljCompiler/Ast/BooleanExpr.cs b/Clojure/Clojure/CljCompiler/Ast/BooleanExpr.cs index ffa9ec8aa..ab37d32bd 100644 --- a/Clojure/Clojure/CljCompiler/Ast/BooleanExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/BooleanExpr.cs @@ -1,64 +1,64 @@ -/** - * 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.Reflection.Emit; - -namespace clojure.lang.CljCompiler.Ast -{ - public class BooleanExpr : LiteralExpr // , MaybePrimitiveExpr TODO: No reason this shouldn't be, but it messes up the RecurExpr emit code. - { - #region Data - - readonly bool _val; - public override object Val { get { return _val; } } - - #endregion - - #region C-tors - - public BooleanExpr(bool val) - { - _val = val; - } - - #endregion - - #region Type mangling - - public override bool HasClrType - { - get { return true; } - } - - public override Type ClrType - { - get { return typeof(Boolean); } - } - - #endregion - - #region Code generation - - public override void Emit(RHC rhc, ObjExpr objx, CljILGen ilg) - { - ilg.EmitBoolean(_val); - ilg.Emit(OpCodes.Box,typeof(bool)); - if (rhc == RHC.Statement) - ilg.Emit(OpCodes.Pop); - } - - #endregion - } -} +/** + * 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.Reflection.Emit; + +namespace clojure.lang.CljCompiler.Ast +{ + public class BooleanExpr : LiteralExpr // , MaybePrimitiveExpr TODO: No reason this shouldn't be, but it messes up the RecurExpr emit code. + { + #region Data + + readonly bool _val; + public override object Val { get { return _val; } } + + #endregion + + #region C-tors + + public BooleanExpr(bool val) + { + _val = val; + } + + #endregion + + #region Type mangling + + public override bool HasClrType + { + get { return true; } + } + + public override Type ClrType + { + get { return typeof(Boolean); } + } + + #endregion + + #region Code generation + + public override void Emit(RHC rhc, ObjExpr objx, CljILGen ilg) + { + ilg.EmitBoolean(_val); + ilg.Emit(OpCodes.Box,typeof(bool)); + if (rhc == RHC.Statement) + ilg.Emit(OpCodes.Pop); + } + + #endregion + } +} diff --git a/Clojure/Clojure/CljCompiler/Ast/CaseExpr.cs b/Clojure/Clojure/CljCompiler/Ast/CaseExpr.cs index 962f14ec6..d8575a766 100644 --- a/Clojure/Clojure/CljCompiler/Ast/CaseExpr.cs +++ b/Clojure/Clojure/CljCompiler/Ast/CaseExpr.cs @@ -1,431 +1,431 @@ -/** - * 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.Linq; -using System.Reflection.Emit; - -namespace clojure.lang.CljCompiler.Ast -{ - public class CaseExpr : Expr, MaybePrimitiveExpr - { - #region Data - - readonly LocalBindingExpr _expr; - public LocalBindingExpr Expr { get { return _expr; } } - - readonly int _shift, _mask; - public int Shift { get { return _shift; } } - public int Mask { get { return _mask; } } - - readonly int _low, _high; - public int Low { get { return _low; } } - public int High { get { return _high; } } - - readonly Expr _defaultExpr; - public Expr DefaultExpr { get { return _defaultExpr; } } - - readonly SortedDictionary _tests; - public SortedDictionary Tests { get { return _tests; } } - - readonly Dictionary _thens; - public Dictionary Thens { get { return _thens; } } - - readonly IPersistentMap _sourceSpan; - public IPersistentMap SourceSpan { get { return _sourceSpan; } } - - readonly Keyword _switchType; - public Keyword SwitchType { get { return _switchType; } } - - readonly Keyword _testType; - public Keyword TestType { get { return _testType; } } - - readonly IPersistentSet _skipCheck; - public IPersistentSet SkipCheck { get { return _skipCheck; } } - - readonly Type _returnType; - public Type ReturnType { get { return _returnType; } } - - #endregion - - #region Keywords - - static readonly Keyword _compactKey = Keyword.intern(null, "compact"); - static readonly Keyword _sparseKey = Keyword.intern(null, "sparse"); - static readonly Keyword _hashIdentityKey = Keyword.intern(null, "hash-identity"); - static readonly Keyword _hashEquivKey = Keyword.intern(null, "hash-equiv"); - static readonly Keyword _intKey = Keyword.intern(null, "int"); - - #endregion - - #region C-tors - - public CaseExpr( IPersistentMap sourceSpan, LocalBindingExpr expr, int shift, int mask, int low, int high, Expr defaultExpr, - SortedDictionary tests, Dictionary thens, Keyword switchType, Keyword testType, IPersistentSet skipCheck ) - { - _sourceSpan = sourceSpan; - _expr = expr; - _shift = shift; - _mask = mask; - _low = low; - _high = high; - _defaultExpr = defaultExpr; - _tests = tests; - _thens = thens; - if (switchType != _compactKey && switchType != _sparseKey) - throw new ArgumentException("Unexpected switch type: " + switchType); - _switchType = switchType; - if (testType != _intKey && testType != _hashEquivKey && testType != _hashIdentityKey) - throw new ArgumentException("Unexpected test type: " + testType); - _testType = testType; - _skipCheck = skipCheck; - ICollection returns = new List(thens.Values) - { - defaultExpr - }; - _returnType = Compiler.MaybeClrType(returns); - if (RT.count(skipCheck) > 0 && RT.booleanCast(RT.WarnOnReflectionVar.deref())) - { - RT.errPrintWriter().WriteLine("Performance warning, {0}:{1}:{2} - hash collision of some case test constants; if selected, those entries will be tested sequentially.", - Compiler.SourcePathVar.deref(),Compiler.GetLineFromSpanMap(sourceSpan),Compiler.GetColumnFromSpanMap(sourceSpan)); - RT.errPrintWriter().Flush(); - } - - } - - #endregion - - #region Type munging - - public bool HasClrType - { - get { return _returnType != null; } - } - - public Type ClrType - { - get { return _returnType; } - } - - #endregion - - #region Parsing - - public sealed class Parser : IParser - { - //(case* expr shift mask default map table-type test-type skip-check?) - //prepared by case macro and presumed correct - //case macro binds actual expr in let so expr is always a local, - //no need to worry about multiple evaluation - public Expr Parse(ParserContext pcon, object frm) - { - ISeq form = (ISeq)frm; - - if (pcon.Rhc == RHC.Eval) - return Compiler.Analyze(pcon, RT.list(RT.list(Compiler.FnOnceSym, PersistentVector.EMPTY, form)), "case__" + RT.nextID()); - - IPersistentVector args = LazilyPersistentVector.create(form.next()); - - object exprForm = args.nth(0); - int shift = Util.ConvertToInt(args.nth(1)); - int mask = Util.ConvertToInt(args.nth(2)); - object defaultForm = args.nth(3); - IPersistentMap caseMap = (IPersistentMap)args.nth(4); - Keyword switchType = (Keyword)args.nth(5); - Keyword testType = (Keyword)args.nth(6); - IPersistentSet skipCheck = RT.count(args) < 8 ? null : (IPersistentSet)args.nth(7); - - ISeq keys = RT.keys(caseMap); - int low = Util.ConvertToInt(RT.first(keys)); - int high = Util.ConvertToInt(RT.nth(keys, RT.count(keys) - 1)); - LocalBindingExpr testexpr = (LocalBindingExpr)Compiler.Analyze(pcon.SetRhc(RHC.Expression), exprForm); - - - SortedDictionary tests = new SortedDictionary(); - Dictionary thens = new Dictionary(); - - foreach (IMapEntry me in caseMap) - { - int minhash = Util.ConvertToInt(me.key()); - object pair = me.val(); // [test-val then-expr] - object first = RT.first(pair); - Expr testExpr = testType == _intKey - ? NumberExpr.Parse(Util.ConvertToInt(first)) - : (first == null ? Compiler.NilExprInstance : new ConstantExpr(first)); - - tests[minhash] = testExpr; - Expr thenExpr; - thenExpr = Compiler.Analyze(pcon, RT.second(pair)); - thens[minhash] = thenExpr; - } - - Expr defaultExpr; - defaultExpr = Compiler.Analyze(pcon, defaultForm); - - return new CaseExpr( - (IPersistentMap)Compiler.SourceSpanVar.deref(), - testexpr, - shift, - mask, - low, - high, - defaultExpr, - tests, - thens, - switchType, - testType, - skipCheck); - } - } - - #endregion - - #region eval - - public object Eval() - { - throw new InvalidOperationException("Can't eval case"); - } - - #endregion - - #region Code generation - - // Equivalent to : - // switch (hashed _expr) - // - // case i: if _expr == _test_i - // goto end with _then_i - // else goto default - // - // ... - // default: - // (default_label) - // goto end with _default - // end - // end_label: - - public void Emit(RHC rhc, ObjExpr objx, CljILGen ilg) - { - DoEmit(rhc, objx, ilg, false); - } - - public void DoEmit(RHC rhc, ObjExpr objx, CljILGen ilg, bool emitUnboxed) - { - GenContext.EmitDebugInfo(ilg, _sourceSpan); - - Label defaultLabel = ilg.DefineLabel(); - Label endLabel = ilg.DefineLabel(); - - SortedDictionary labels = new SortedDictionary(); - foreach (int i in _tests.Keys) - labels[i] = ilg.DefineLabel(); - - Type primExprType = Compiler.MaybePrimitiveType(_expr); - - if (_testType == _intKey) - EmitExprForInts(objx, ilg, primExprType, defaultLabel); - else - EmitExprForHashes(objx, ilg); - - if (_switchType == _sparseKey) - { - Label[] la = labels.Values.ToArray