diff --git a/docs/grammar.ebnf b/docs/grammar.ebnf index dffffb1..89044db 100644 --- a/docs/grammar.ebnf +++ b/docs/grammar.ebnf @@ -123,9 +123,12 @@ deref = "@" , form ; (* (deref form) *) metadata = "^" , meta-form , ws , form ; (* attach metadata to form *) meta-form = map | keyword | symbol | string ; (* Normalized like Clojure: a symbol or string is a type hint -> {:tag ...}; - a keyword -> {keyword true}; a map is used as-is. On a symbol the metadata - rides on the symbol (it stays a bare symbol, so a hint like ^String is - transparent in params/lets/bodies); other targets use a runtime with-meta. *) + a keyword -> {keyword true}; a map is used as-is. A keyword/symbol/string + meta-form on a symbol rides ON the symbol (it stays a bare symbol, so a hint + like ^String is transparent in params/lets/bodies). A MAP meta-form routes + through a runtime (with-meta form ...) even on a symbol (jolt-8w2), so a name + with ^{:map} metadata reads as a form, not a bare symbol — def/defn/defmacro/ns + unwrap that to the bare name (and attach the metadata). *) (* -------------------------------------------------------------------------- Dispatch forms — introduced by "#". diff --git a/docs/libraries.md b/docs/libraries.md index 330aebf..694e1ef 100644 --- a/docs/libraries.md +++ b/docs/libraries.md @@ -24,6 +24,13 @@ Libraries confirmed to load and pass their conformance checks on Jolt [jolt-lang/db](https://github.com/jolt-lang/db) (`next.jdbc`, `next.jdbc.sql`, `next.jdbc.prepare`, `next.jdbc.transaction`) over `jdbc.core`, for libraries that target the next.jdbc API +* [tools.logging](https://github.com/clojure/tools.logging) — the real + `clojure.tools.logging` source runs verbatim. jolt provides a native + `clojure.tools.logging.impl` backend (a stderr `LoggerFactory` — the library's + designed extension point, where slf4j/log4j/jul adapters normally plug in) plus + the host shims it needs (`agent`/`send-off`, `clojure.lang.LockingTransaction`, + a `clojure.pprint` subset, `clojure.string/trim-newline`). The level macros, + `logf`/`logp`, `spy`, and `enabled?` all work; output goes to stderr. * [migratus](https://github.com/yogthos/migratus) — database migrations; loads unmodified and runs filesystem SQL/EDN migrations against SQLite through the next.jdbc layer above. `migrate`/`rollback` round-trip end to end. Caveat: diff --git a/jolt-core/clojure/core/00-syntax.clj b/jolt-core/clojure/core/00-syntax.clj index 17238a8..0e3fc71 100644 --- a/jolt-core/clojure/core/00-syntax.clj +++ b/jolt-core/clojure/core/00-syntax.clj @@ -110,7 +110,12 @@ ;; then. Its body resolves fn/map/reduce/cond at EXPANSION time, by which point all ;; of 00-syntax has loaded, so using them here is fine. (defmacro ns [nm & clauses] - (let [calls (reduce + ;; ^{:map} metadata on the ns name reads as a (with-meta sym {...}) form, not an + ;; annotated symbol (jolt-8w2). Real libraries put :author/:doc there + ;; (clojure.tools.logging), so unwrap to the bare symbol; jolt does not track + ;; namespace metadata, so the map is dropped. + (let [nm (if (and (seq? nm) (= 'with-meta (first nm))) (second nm) nm) + calls (reduce (fn [acc clause] (if (seq? clause) (let [head (first clause) args (rest clause)] diff --git a/jolt-core/clojure/core/50-io.clj b/jolt-core/clojure/core/50-io.clj index aceff06..98d9ff9 100644 --- a/jolt-core/clojure/core/50-io.clj +++ b/jolt-core/clojure/core/50-io.clj @@ -177,3 +177,30 @@ (defmethod print-method :jolt/chan [c w] (.write w "#") nil) + +;; Minimal synchronous agent shim. jolt has no thread pool or STM, so this is +;; enough for libraries that hold an agent but don't depend on asynchronous +;; dispatch (e.g. clojure.tools.logging's *logging-agent*, which only sends from +;; within a transaction — never the case here, so it always logs directly). An +;; agent is an atom; send/send-off apply the action immediately. NOT concurrent. +(defn agent + "Creates an agent (an atom on jolt — synchronous, no async dispatch)." + [state & _opts] + (atom state)) + +(defn send-off + "Apply (action state & args) to the agent's state immediately; return the agent." + [a f & args] + (apply swap! a f args) + a) + +(defn send + "Like send-off on jolt (no separate thread pool)." + [a f & args] + (apply swap! a f args) + a) + +(defn agent-error + "jolt agents never enter an error state." + [_a] + nil) diff --git a/src/jolt/clojure/pprint.clj b/src/jolt/clojure/pprint.clj new file mode 100644 index 0000000..20f4d49 --- /dev/null +++ b/src/jolt/clojure/pprint.clj @@ -0,0 +1,28 @@ +;; clojure.pprint — minimal jolt shim. +;; +;; The real clojure.pprint is a full pretty-printer (thousands of lines of column +;; tracking / dispatch tables). This shim provides just the surface that portable +;; libraries reach for when they "pretty print" a value — notably +;; clojure.tools.logging/spy (pprint + with-pprint-dispatch + code-dispatch). +;; pprint writes the value readably with a trailing newline (no pretty layout); +;; the dispatch vars are recognized but not used for layout. +(ns clojure.pprint) + +(def code-dispatch + "Recognized but not used for layout on jolt." :code-dispatch) +(def simple-dispatch + "Recognized but not used for layout on jolt." :simple-dispatch) + +(def ^:dynamic *print-pprint-dispatch* simple-dispatch) + +(defn pprint + "Print object readably followed by a newline. Writes to *out* (or the given + writer). Not a pretty-printer on jolt — no column-aware layout." + ([object] (prn object)) + ([object writer] (binding [*out* writer] (prn object)))) + +(defmacro with-pprint-dispatch + "Evaluate body with the given pprint dispatch selected. On jolt the dispatch is + recognized but does not affect layout, so this just evaluates body." + [_dispatch & body] + `(do ~@body)) diff --git a/src/jolt/clojure/string.clj b/src/jolt/clojure/string.clj index c435719..807813e 100644 --- a/src/jolt/clojure/string.clj +++ b/src/jolt/clojure/string.clj @@ -135,3 +135,17 @@ (let [c (str ch)] (if (or (= c "\\") (= c "$")) (str "\\" c) c))) (seq replacement)))) + +;; Ported from clojure.string/trim-newline (CharSequence interop replaced with +;; portable count/subs). Removes all trailing \n or \r characters. +(defn trim-newline + "Removes all trailing newline \\n or return \\r characters from + string. Similar to Perl's chomp." + [s] + (loop [index (count s)] + (if (zero? index) + "" + (let [c (subs s (dec index) index)] + (if (or (= c "\n") (= c "\r")) + (recur (dec index)) + (subs s 0 index)))))) diff --git a/src/jolt/clojure/tools/logging.clj b/src/jolt/clojure/tools/logging.clj index f14ce0d..e963f06 100644 --- a/src/jolt/clojure/tools/logging.clj +++ b/src/jolt/clojure/tools/logging.clj @@ -1,75 +1,338 @@ -;; clojure.tools.logging — jolt shim of the public API. -;; -;; Faithful to the upstream macro surface (logp/logf, the level macros and their -;; f-variants, log, enabled?, spy), dispatching through the Logger/LoggerFactory -;; protocols in clojure.tools.logging.impl. Two deliberate departures from -;; upstream, both forced by jolt not being a JVM: -;; -;; - log* writes directly. The real log* may hand off to an agent when inside a -;; running clojure.lang.LockingTransaction; jolt has neither agents nor STM. -;; - The throwable-first-argument branch is dropped. Upstream splits args on -;; (instance? Throwable x); on jolt that is always false for exception values, -;; so the would-be throwable simply becomes part of the printed message. This -;; also avoids the double-evaluation the branch would otherwise cause here. -(ns clojure.tools.logging +;;; logging.clj -- delegated logging for Clojure + +;; by Alex Taggart +;; July 27, 2009 + +;; Copyright (c) Alex Taggart, July 2009. 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 "Alex Taggart" + :doc "Logging macros which delegate to a specific logging implementation. + + A logging implementation is selected at runtime when this namespace is first + loaded. For more details, see the documentation for *logger-factory*. + + If you want to test that your code emits specific log messages, see the + clojure.tools.logging.test namespace."} + clojure.tools.logging + (:use + [clojure.string :only [trim-newline]] + [clojure.pprint :only [code-dispatch pprint with-pprint-dispatch]]) (:require [clojure.tools.logging.impl :as impl])) -;; The LoggerFactory used to obtain loggers. Defaults to the jolt stderr -;; factory; rebind to plug in a different backend. -(def ^:dynamic *logger-factory* (impl/find-factory)) +(def ^{:doc + "The default agent used for performing logging when direct logging is + disabled. See log* for details." :dynamic true} + *logging-agent* (agent nil :error-mode :continue)) + +(def ^{:doc + "The set of levels that will require using an agent when logging from within a + running transaction. Defaults to #{:info :warn}. See log* for details." :dynamic true} + *tx-agent-levels* #{:info :warn}) + +(def ^{:doc + "Overrides the default rules for choosing between logging directly or via an + agent. Defaults to nil. See log* for details." :dynamic true} + *force* nil) (defn log* - "Write a log entry through the logger. Direct, unlike upstream's agent path." + "Attempts to log a message, either directly or via an agent; does not check if + the level is enabled. + + For performance reasons, an agent will only be used when invoked within a + running transaction, and only for logging levels specified by + *tx-agent-levels*. This allows those entries to only be written once the + transaction commits, and are discarded if it is retried or aborted. As + corollary, other levels (e.g., :debug, :error) will be written even from + failed transactions though at the cost of repeat messages during retries. + + One can override the above by setting *force* to :direct or :agent; all + subsequent writes will be direct or via an agent, respectively." [logger level throwable message] - (impl/write! logger level throwable message) + (if (case *force* + :agent true + :direct false + (and (clojure.lang.LockingTransaction/isRunning) + (*tx-agent-levels* level))) + (send-off *logging-agent* + (fn [_#] (impl/write! logger level throwable message))) + (impl/write! logger level throwable message)) nil) -(defmacro logp - "Log a message built by print-str of args, at the given level. Args are - evaluated only when the level is enabled." - [level & args] - `(let [logger# (clojure.tools.logging.impl/get-logger *logger-factory* ~(str *ns*))] - (when (clojure.tools.logging.impl/enabled? logger# ~level) - (log* logger# ~level nil (print-str ~@args))))) - -(defmacro logf - "Log a clojure.core/format message at the given level. Args are evaluated - only when the level is enabled." - [level & args] - `(let [logger# (clojure.tools.logging.impl/get-logger *logger-factory* ~(str *ns*))] - (when (clojure.tools.logging.impl/enabled? logger# ~level) - (log* logger# ~level nil (format ~@args))))) +(declare ^{:dynamic true} *logger-factory*) ; default LoggerFactory instance for calling impl/get-logger (defmacro log - ([level message] `(logp ~level ~message)) - ([level throwable message] `(logp ~level ~throwable ~message))) + "Evaluates and logs a message only if the specified level is enabled. See log* + for more details." + ([level message] + `(log ~level nil ~message)) + ([level throwable message] + `(log ~*ns* ~level ~throwable ~message)) + ([logger-ns level throwable message] + `(log *logger-factory* ~logger-ns ~level ~throwable ~message)) + ([logger-factory logger-ns level throwable message] + `(let [logger# (impl/get-logger ~logger-factory ~logger-ns)] + (if (impl/enabled? logger# ~level) + (log* logger# ~level ~throwable ~message))))) -(defmacro trace [& args] `(logp :trace ~@args)) -(defmacro debug [& args] `(logp :debug ~@args)) -(defmacro info [& args] `(logp :info ~@args)) -(defmacro warn [& args] `(logp :warn ~@args)) -(defmacro error [& args] `(logp :error ~@args)) -(defmacro fatal [& args] `(logp :fatal ~@args)) +(defmacro logp + "Logs a message using print style args. Can optionally take a throwable as its + second arg. See level-specific macros, e.g., debug. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([level message & more] [level throwable message & more])} + [level x & more] + (if (or (instance? String x) (nil? more)) ; optimize for common case + `(log ~level (print-str ~x ~@more)) + `(let [logger# (impl/get-logger *logger-factory* ~*ns*)] + (if (impl/enabled? logger# ~level) + (let [x# ~x] + (if (instance? Throwable x#) ; type check only when enabled + (log* logger# ~level x# (print-str ~@more)) + (log* logger# ~level nil (print-str x# ~@more)))))))) -(defmacro tracef [& args] `(logf :trace ~@args)) -(defmacro debugf [& args] `(logf :debug ~@args)) -(defmacro infof [& args] `(logf :info ~@args)) -(defmacro warnf [& args] `(logf :warn ~@args)) -(defmacro errorf [& args] `(logf :error ~@args)) -(defmacro fatalf [& args] `(logf :fatal ~@args)) +(defmacro logf + "Logs a message using a format string and args. Can optionally take a + throwable as its second arg. See level-specific macros, e.g., debugf. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([level fmt & fmt-args] [level throwable fmt & fmt-args])} + [level x & more] + (if (or (instance? String x) (nil? more)) ; optimize for common case + `(log ~level (format ~x ~@more)) + `(let [logger# (impl/get-logger *logger-factory* ~*ns*)] + (if (impl/enabled? logger# ~level) + (let [x# ~x] + (if (instance? Throwable x#) ; type check only when enabled + (log* logger# ~level x# (format ~@more)) + (log* logger# ~level nil (format x# ~@more)))))))) (defmacro enabled? - "True if the given level is enabled for the (optionally given) logger ns." - ([level] `(clojure.tools.logging.impl/enabled? (clojure.tools.logging.impl/get-logger *logger-factory* ~(str *ns*)) ~level)) - ([level log-ns] `(clojure.tools.logging.impl/enabled? (clojure.tools.logging.impl/get-logger *logger-factory* ~log-ns) ~level))) + "Returns true if the specific logging level is enabled. Use of this macro + should only be necessary if one needs to execute alternate code paths beyond + whether the log should be written to." + ([level] + `(enabled? ~level ~*ns*)) + ([level logger-ns] + `(impl/enabled? (impl/get-logger *logger-factory* ~logger-ns) ~level))) (defmacro spy - "Evaluate expr, log it at the given level (default :debug) as expr => value, - and return the value. Single variadic arity (jolt defmacro takes only the - first clause of a multi-arity macro), dispatching on arg count." - [& args] - (let [level (if (= 1 (count args)) :debug (first args)) - expr (if (= 1 (count args)) (first args) (second args))] + "Evaluates expr and may write the form and its result to the log. Returns the + result of expr. Defaults to :debug log level." + ([expr] + `(spy :debug ~expr)) + ([level expr] `(let [a# ~expr] - (logp ~level (print-str '~expr "=>" (pr-str a#))) + (log ~level + (let [s# (with-out-str + (with-pprint-dispatch code-dispatch ; need a better way + (pprint '~expr) + (print "=> ") + (pprint a#)))] + (trim-newline s#))) a#))) + +(defmacro spyf + "Evaluates expr and may write (format fmt result) to the log. Returns the + result of expr. Defaults to :debug log level. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + ([fmt expr] + `(spyf :debug ~fmt ~expr)) + ([level fmt expr] + `(let [a# ~expr] + (log ~level (format ~fmt a#)) + a#))) + +(defn log-stream + "Creates a PrintStream that will output to the log at the specified level." + [level logger-ns] + (let [logger (impl/get-logger *logger-factory* logger-ns)] + (java.io.PrintStream. + (proxy [java.io.ByteArrayOutputStream] [] + (flush [] + ; deal with reflection in proxy-super + (let [^java.io.ByteArrayOutputStream this this] + (proxy-super flush) + (let [message (.trim (.toString this))] + (proxy-super reset) + (if (> (.length message) 0) + (log* logger level nil message)))))) + true))) + +(let [orig (atom nil) ; holds original System.out and System.err + monitor (Object.)] ; sync monitor for calling setOut/setErr + (defn log-capture! + "Captures System.out and System.err, piping all writes of those streams to + the log. If unspecified, levels default to :info and :error, respectively. + The specified logger-ns value will be used to namespace all log entries. + + Note: use with-logs to redirect output of *out* or *err*. + + Warning: if the logging implementation is configured to output to System.out + (as is the default with java.util.logging) then using this function will + result in StackOverflowException when writing to the log." + ; Implementation Notes: + ; - only set orig when nil to preserve original out/err + ; - no enabled? check before making streams since that may change later + ([logger-ns] + (log-capture! logger-ns :info :error)) + ([logger-ns out-level err-level] + (locking monitor + (compare-and-set! orig nil [System/out System/err]) + (System/setOut (log-stream out-level logger-ns)) + (System/setErr (log-stream err-level logger-ns))))) + (defn log-uncapture! + "Restores System.out and System.err to their original values." + [] + (locking monitor + (when-let [[out err :as v] @orig] + (swap! orig (constantly nil)) + (System/setOut out) + (System/setErr err))))) + +(defmacro with-logs + "Evaluates exprs in a context in which *out* and *err* write to the log. The + specified logger-ns value will be used to namespace all log entries. + + By default *out* and *err* write to :info and :error, respectively." + {:arglists '([logger-ns & body] + [[logger-ns out-level err-level] & body])} + [arg & body] + ; Implementation Notes: + ; - no enabled? check before making writers since that may change later + (let [[logger-ns out-level err-level] (if (vector? arg) + arg + [arg :info :error])] + `(binding [*out* (java.io.OutputStreamWriter. + (log-stream ~out-level ~logger-ns)) + *err* (java.io.OutputStreamWriter. + (log-stream ~err-level ~logger-ns))] + ~@body))) + +;; level-specific macros + +(defmacro trace + "Trace level logging using print-style args. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([message & more] [throwable message & more])} + [& args] + `(logp :trace ~@args)) + +(defmacro debug + "Debug level logging using print-style args. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([message & more] [throwable message & more])} + [& args] + `(logp :debug ~@args)) + +(defmacro info + "Info level logging using print-style args. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([message & more] [throwable message & more])} + [& args] + `(logp :info ~@args)) + +(defmacro warn + "Warn level logging using print-style args. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([message & more] [throwable message & more])} + [& args] + `(logp :warn ~@args)) + +(defmacro error + "Error level logging using print-style args. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([message & more] [throwable message & more])} + [& args] + `(logp :error ~@args)) + +(defmacro fatal + "Fatal level logging using print-style args. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([message & more] [throwable message & more])} + [& args] + `(logp :fatal ~@args)) + +(defmacro tracef + "Trace level logging using format. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([fmt & fmt-args] [throwable fmt & fmt-args])} + [& args] + `(logf :trace ~@args)) + +(defmacro debugf + "Debug level logging using format. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([fmt & fmt-args] [throwable fmt & fmt-args])} + [& args] + `(logf :debug ~@args)) + +(defmacro infof + "Info level logging using format. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([fmt & fmt-args] [throwable fmt & fmt-args])} + [& args] + `(logf :info ~@args)) + +(defmacro warnf + "Warn level logging using format. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([fmt & fmt-args] [throwable fmt & fmt-args])} + [& args] + `(logf :warn ~@args)) + +(defmacro errorf + "Error level logging using format. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([fmt & fmt-args] [throwable fmt & fmt-args])} + [& args] + `(logf :error ~@args)) + +(defmacro fatalf + "Fatal level logging using format. + Use the 'logging.readable' namespace to avoid wrapping args in pr-str." + {:arglists '([fmt & fmt-args] [throwable fmt & fmt-args])} + [& args] + `(logf :fatal ~@args)) + +(defn- call-str [str] + (let [fq-sym (symbol str) + ns-str (or (namespace fq-sym) + (throw (RuntimeException. + (format "The value of the clojure.tools.logging.factory system property is not fully-qualified: %s" + (pr-str str))))) + ns-sym (symbol ns-str) + _ (try + (require ns-sym) + (catch Exception ex + (throw (RuntimeException. + (format "Could not resolve namespace for %s. Either it does not exist or it has a (circular) dependency on clojure.tools.logging." + (pr-str str)))))) + fn-sym (symbol (name fq-sym)) + fn-var (ns-resolve ns-sym fn-sym)] + (if fn-var + (fn-var) + (throw (RuntimeException. + (format "Could not resolve var for %s." + (pr-str str))))))) + +(defn- find-factory [] + (if-let [factory-fn-str (System/getProperty "clojure.tools.logging.factory")] + (call-str factory-fn-str) + (impl/find-factory))) + +(def ^:dynamic *logger-factory* + "An instance satisfying the clojure.tools.logging.impl/LoggerFactory protocol, + which allows uniform access to an underlying logging implementation. + + The default value will be obtained by invoking a no-arg function named by the + \"clojure.tools.logging.factory\" system property, or if unset, by invoking + clojure.tools.logging.impl/find-factory. + + After loading, this var can be programmatically changed to a different + LoggerFactory implementation via binding or alter-var-root. + + See the various factory functions in clojure.tools.logger.impl." + (find-factory)) diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet index f948ac8..1451786 100644 --- a/src/jolt/evaluator.janet +++ b/src/jolt/evaluator.janet @@ -198,7 +198,16 @@ {:jolt/type :symbol :ns (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx)) :name nm})) - form)) + # Alias-qualified (impl/foo): resolve the alias to its target namespace so the + # emitted symbol resolves at the macro's USE site, which has no such alias + # (jolt-9av). Matches Clojure's syntax-quote. A real ns name (not an alias) + # has no entry and is left as written. + (let [cur (ctx-find-ns ctx (or (get (ctx :env) :compile-ns) (ctx-current-ns ctx))) + target (and cur (or (ns-alias-lookup cur (form :ns)) + (ns-import-lookup cur (form :ns))))] + (if target + {:jolt/type :symbol :ns target :name (form :name)} + form)))) (defn- d-realize "Realize a lazy-seq to an array for positional destructuring / splicing; pass @@ -1828,36 +1837,56 @@ "defmacro" (let [# ^{:map} metadata on the name reads as a (with-meta sym …) # form (jolt-8w2); unwrap to the bare symbol like def does. name-sym (unwrap-meta-name (in form 1)) - rest-form (tuple/slice form 2) - # optional docstring - has-doc? (and (> (length rest-form) 0) (string? (first rest-form))) - raw-args (if has-doc? (in rest-form 1) (first rest-form)) - raw-body (tuple/slice rest-form (if has-doc? 2 1)) - # arity-clause form: (defmacro name ([params] body...)) — like - # fn/defn. In a code form a vector literal is a tuple and a list - # is an array, so a params vector reads as a tuple while an arity - # clause reads as a list (array): unwrap its params + body. Single - # arity only (what real macros use); a multi-arity macro takes the - # first clause. - arity-clause? (array? raw-args) - args-form (if arity-clause? (first raw-args) raw-args) - body (if arity-clause? (tuple/slice raw-args 1) raw-body) - param-info (parse-params args-form) - fixed-pats (param-info :fixed) - rest-pat (param-info :rest) + after-name (tuple/slice form 2) + # Skip an optional leading docstring (string) then an optional + # attr-map (a struct that is not a symbol — a map literal reads + # as a struct), matching defn. Real macros use both, e.g. + # (defmacro info "doc" {:arglists '(...)} [& args] …). + a1 (if (and (> (length after-name) 0) (string? (first after-name))) + (tuple/slice after-name 1) after-name) + after-meta (if (and (> (length a1) 0) + (struct? (first a1)) + (not= :symbol (get (first a1) :jolt/type))) + (tuple/slice a1 1) a1) + # What remains is either a params VECTOR (tuple) + body, or one + # or more arity CLAUSES (each a list, i.e. a janet array). Build + # a uniform arity list [{:params … :body …} …]. + multi? (and (> (length after-meta) 0) (array? (first after-meta))) + arities (if multi? + (map (fn [cl] {:params (first cl) :body (tuple/slice cl 1)}) + after-meta) + @[{:params (first after-meta) :body (tuple/slice after-meta 1)}]) defining-ns (ctx-current-ns ctx)] (def interp-fn (fn [& macro-args] + (def n (length macro-args)) + # Pick the arity: an exact fixed-count match wins; otherwise the + # first variadic arity that accepts n args (Clojure fn dispatch). + (var chosen nil) + (each ar arities + (def pi (parse-params (ar :params))) + (when (and (nil? chosen) (not (pi :rest)) (= n (length (pi :fixed)))) + (set chosen [pi (ar :body)]))) + (when (nil? chosen) + (each ar arities + (def pi (parse-params (ar :params))) + (when (and (nil? chosen) (pi :rest) (>= n (length (pi :fixed)))) + (set chosen [pi (ar :body)])))) + (when (nil? chosen) + (error (string "no matching arity for macro " (name-sym :name) + " (" n " args)"))) + (def pi (chosen 0)) + (def body (chosen 1)) (var new-bindings @{}) (table/setproto new-bindings bindings) (put new-bindings "&env" @{}) # implicit &env for macro bodies (table — nil-safe) (var i 0) # Destructure macro params (like fn), so [& [a & more :as all]] # and {:keys …} rest forms work in macro arglists. - (each pat fixed-pats + (each pat (pi :fixed) (destructure-bind ctx new-bindings pat (macro-args i)) (++ i)) - (when rest-pat - (destructure-bind ctx new-bindings rest-pat (rest-args-val macro-args i))) + (when (pi :rest) + (destructure-bind ctx new-bindings (pi :rest) (rest-args-val macro-args i))) # Use defining namespace for symbol resolution (def saved-ns (ctx-current-ns ctx)) (ctx-set-current-ns ctx defining-ns) @@ -1870,12 +1899,20 @@ (set result (eval-form ctx new-bindings bf))) (ctx-set-current-ns ctx saved-ns) result)) - # Prefer a COMPILED expander (native-speed expansion, zero runtime - # cost). Skip when the body uses &env/&form (the compiled fn has no - # such params) — those fall back to the interpreted closure. - (def uses-env (or (form-uses-sym? body "&env") (form-uses-sym? body "&form"))) + # A COMPILED expander (native-speed) is only built for the + # single-arity case (the compile hook + recompile path take one + # [args body]); multi-arity macros use the interpreted expander. + (def single? (= 1 (length arities))) + (def args-form (and single? ((first arities) :params))) + (def body (and single? ((first arities) :body))) + (def uses-env (do (var u false) + (each ar arities + (when (or (form-uses-sym? (ar :body) "&env") + (form-uses-sym? (ar :body) "&form")) + (set u true))) + u)) (def compiled-fn - (when (and macro-compile-hook (not uses-env)) + (when (and macro-compile-hook single? (not uses-env)) (macro-compile-hook ctx args-form body))) (def macro-fn (or compiled-fn interp-fn)) (let [ns-name (ctx-current-ns ctx) @@ -1886,8 +1923,10 @@ # compile it once the analyzer is alive (staged bootstrap): a # macro defined WHILE the analyzer is still being built gets an # interpreted closure now, a compiled expander later. uses-env - # macros stay interpreted (the compiled fn* has no &env/&form). - (put v :macro-src @[args-form body]) + # macros stay interpreted (the compiled fn* has no &env/&form); + # multi-arity macros keep the interpreted dispatch (no single + # [args body] to recompile). + (when single? (put v :macro-src @[args-form body])) (put v :macro-uses-env uses-env) (when compiled-fn (put v :macro-compiled true)) # A (re)defined macro invalidates any cached expansions. @@ -2412,8 +2451,11 @@ (if (= :jolt/char (form :jolt/type)) form # a UUID/inst value flowing back through eval (macro expansion, eval of a - # read form) is a self-evaluating literal, like chars. - (if (or (= :jolt/uuid (form :jolt/type)) (= :jolt/inst (form :jolt/type))) + # read form) is a self-evaluating literal, like chars. A namespace object + # does too: `~*ns*` in a syntax-quote (clojure.tools.logging) splices the + # live ns into the expansion. + (if (or (= :jolt/uuid (form :jolt/type)) (= :jolt/inst (form :jolt/type)) + (= :jolt/namespace (form :jolt/type))) form (if (= :jolt/set (form :jolt/type)) # evaluate each element (set literals like #{(inc 1)} must compute) diff --git a/src/jolt/javatime.janet b/src/jolt/javatime.janet index d4d718b..5986d4d 100644 --- a/src/jolt/javatime.janet +++ b/src/jolt/javatime.janet @@ -542,6 +542,9 @@ # (resources/). getSystemClassLoader yields the same stub. (each nm ["ClassLoader" "java.lang.ClassLoader"] (register-class-statics! nm @{"getSystemClassLoader" (fn [] @{:jolt/type :jolt/classloader})})) + # No STM on jolt: a transaction is never running, so logging libraries that + # gate agent-vs-direct on it (clojure.tools.logging/log*) always log directly. + (register-class-statics! "clojure.lang.LockingTransaction" @{"isRunning" (fn [] false)}) (register-tagged-methods! :jolt/classloader @{"getResource" (fn [self path] nil) "getResources" (fn [self path] nil) diff --git a/test/integration/conformance-test.janet b/test/integration/conformance-test.janet index ba280ea..2dee3aa 100644 --- a/test/integration/conformance-test.janet +++ b/test/integration/conformance-test.janet @@ -495,6 +495,25 @@ # ns (jolt-9pu — it used to see an empty table). ["cross-ns methods visible" "[:sql]" "(do (ns cf.mm) (defmulti ext identity) (defmethod ext :default [_] :d) (defn allk [] (vec (for [[k v] (methods ext) :when (not= k :default)] k))) (ns cf.mmi) (defmethod cf.mm/ext :sql [_] :s) (in-ns (quote user)) (cf.mm/allk))"] + + ### ---- defmacro surface + syntax-quote/ns (enabling real clojure libs) ---- + # multi-arity defmacro (clojure.tools.logging/log has 4 arities) + ["defmacro multi-arity" "[6 5 6]" + "(do (defmacro mar ([a] (list (quote +) a 1)) ([a b] (list (quote +) a b)) ([a b c] (list (quote +) a b c))) [(mar 5) (mar 2 3) (mar 1 2 3)])"] + # defmacro with docstring AND attr-map before the params (every tools.logging + # level macro is shaped this way) + ["defmacro doc + attr-map" "10" + "(do (defmacro mam \"doc\" {:arglists (quote ([x]))} [x] (list (quote inc) x)) (mam 9))"] + # syntax-quote resolves a namespace ALIAS to its target ns, so a macro's + # template resolves at the USE site (jolt-9av) + ["syntax-quote resolves alias" "\"HI\"" + "(do (ns sq.lib (:require [clojure.string :as s])) (defmacro up [x] `(s/upper-case ~x)) (in-ns (quote user)) (sq.lib/up \"hi\"))"] + # ^{:map} metadata on an ns name (jolt-8w2): the ns name is the bare symbol + ["ns name with ^{:map} meta" "5" + "(do (ns ^{:author \"a\" :doc \"d\"} nm.meta) (def q 5) (in-ns (quote user)) nm.meta/q)"] + # ~*ns* splices the live namespace object into a template (it self-evaluates) + ["unquote *ns* in template" "true" + "(do (defmacro cur-ns [] `(str ~*ns*)) (string? (cur-ns)))"] ]) # Run every case under a given context factory and return the failures. The same diff --git a/test/spec/host-interop-spec.janet b/test/spec/host-interop-spec.janet index a577a5b..19f8c04 100644 --- a/test/spec/host-interop-spec.janet +++ b/test/spec/host-interop-spec.janet @@ -259,8 +259,12 @@ ["file-seq finds files" "true" "(do (require '[clojure.java.io :as io]) (pos? (count (filter (fn [f] (.isFile f)) (file-seq (io/file \"docs\"))))))"]) -# clojure.tools.logging shim (jolt-nzg): the macro surface works, debug/trace -# are suppressed (no-op nil) by default, and the impl protocol layer is present. +# The REAL clojure.tools.logging (vendored verbatim) runs on jolt: a jolt +# clojure.tools.logging.impl backend (stderr LoggerFactory) plus host shims +# (agent/send-off, clojure.lang.LockingTransaction/isRunning, a clojure.pprint +# subset, clojure.string/trim-newline) and the defmacro/syntax-quote/ns fixes. +# These cases assert the public API behaves; the level rows return nil because +# the real level macros return the (nil) result of log* when enabled. (defspec "host-interop / clojure.tools.logging" ["info returns nil" "nil" "(do (require '[clojure.tools.logging :as log]) (log/info \"hi\" 42))"] ["debug suppressed" "nil" "(do (require '[clojure.tools.logging :as log]) (log/debug \"x\"))"] @@ -269,4 +273,20 @@ ["enabled? debug" "false" "(do (require '[clojure.tools.logging :as log]) (log/enabled? :debug))"] ["spy returns value" "3" "(do (require '[clojure.tools.logging :as log]) (log/spy :info (+ 1 2)))"] ["impl factory name" "\"jolt/stderr\"" - "(do (require '[clojure.tools.logging.impl :as impl]) (impl/name (impl/find-factory)))"]) + "(do (require '[clojure.tools.logging.impl :as impl]) (impl/name (impl/find-factory)))"] + # vars that exist only in the real library (not in a hand-rolled shim) + ["real lib *tx-agent-levels*" "#{:info :warn}" + "(do (require '[clojure.tools.logging :as log]) log/*tx-agent-levels*)"] + ["real lib log-capture! present" "true" + "(do (require '[clojure.tools.logging :as log]) (fn? log/log-capture!))"] + ["real lib spyf present" "true" + "(do (require '[clojure.tools.logging :as log]) (boolean (resolve 'log/spyf)))"]) + +# Host shims that let the real clojure.tools.logging load: no STM (a transaction +# is never running) and a minimal clojure.pprint (used by spy). +(defspec "host-interop / logging host shims" + ["LockingTransaction/isRunning" "false" "(clojure.lang.LockingTransaction/isRunning)"] + ["pprint writes value" "\"[1 2 3]\\n\"" + "(do (require '[clojure.pprint :as pp]) (with-out-str (pp/pprint [1 2 3])))"] + ["with-pprint-dispatch runs body" "42" + "(do (require '[clojure.pprint :as pp]) (pp/with-pprint-dispatch pp/code-dispatch 42))"]) diff --git a/test/spec/macros-spec.janet b/test/spec/macros-spec.janet index 5e0d1e5..eb35387 100644 --- a/test/spec/macros-spec.janet +++ b/test/spec/macros-spec.janet @@ -93,3 +93,16 @@ ["docstring + arity" "15" "(do (defmacro th \"triple\" ([x] (list (quote *) x 3))) (th 5))"] ["^{:map} name meta" "7" "(do (defmacro ^{:private true} pm [] 7) (pm))"] ["multi-form body" "6" "(do (defmacro mb ([a b] (list (quote +) a b))) (mb 2 4))"]) + +# Multi-arity defmacro (dispatch on arg count) and the docstring + attr-map + +# params form — both needed to run real Clojure macros, e.g. +# clojure.tools.logging/log (4 arities) and its level macros (jolt-q8l, jolt-qnr). +(defspec "macros / defmacro multi-arity & attr-map" + ["multi-arity 1" "6" "(do (defmacro ma ([a] (list (quote +) a 1)) ([a b] (list (quote +) a b))) (ma 5))"] + ["multi-arity 2" "5" "(do (defmacro ma ([a] (list (quote +) a 1)) ([a b] (list (quote +) a b))) (ma 2 3))"] + ["arity delegates" "[:d nil 9]" + "(do (defmacro lg ([m] `(lg :d nil ~m)) ([l t m] (list (quote vector) l t m))) (lg 9))"] + ["doc + attr-map + params" "10" + "(do (defmacro am \"doc\" {:arglists (quote ([x]))} [x] (list (quote inc) x)) (am 9))"] + ["doc + attr-map + variadic" "6" + "(do (defmacro vg \"d\" {:arglists (quote ([& a]))} [& xs] `(+ ~@xs)) (vg 1 2 3))"]) diff --git a/test/spec/state-spec.janet b/test/spec/state-spec.janet index b959eb2..b35944c 100644 --- a/test/spec/state-spec.janet +++ b/test/spec/state-spec.janet @@ -37,3 +37,12 @@ (defspec "state / promises" ["promise deliver" "5" "(let [p (promise)] (deliver p 5) @p)"] ["promise undelivered" "nil" "(let [p (promise)] @p)"]) + +# Minimal synchronous agent shim (jolt has no thread pool/STM) — enough for +# libraries that hold an agent without depending on async dispatch. +(defspec "state / agents (synchronous shim)" + ["agent deref" "0" "(deref (agent 0))"] + ["agent with opts" "0" "(deref (agent 0 :error-mode :continue))"] + ["send-off applies" "5" "(let [a (agent 0)] (send-off a + 5) (deref a))"] + ["send applies" "7" "(let [a (agent 1)] (send a + 6) (deref a))"] + ["agent-error nil" "nil" "(agent-error (agent 0))"]) diff --git a/test/spec/strings-spec.janet b/test/spec/strings-spec.janet index b0ae2ad..daeceeb 100644 --- a/test/spec/strings-spec.janet +++ b/test/spec/strings-spec.janet @@ -62,3 +62,11 @@ ["get out of range nil" "nil" "(get \"abc\" 9)"] ["get negative nil" "nil" "(get \"abc\" -1)"] ["get default honored" ":none" "(get \"abc\" 9 :none)"]) + +# clojure.string/trim-newline (ported from clojure.string): strips trailing \n/\r. +(defspec "clojure.string / trim-newline" + ["trailing newline" "\"x\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"x\\n\"))"] + ["trailing \\r\\n" "\"x\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"x\\r\\n\"))"] + ["no trailing" "\"ab\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"ab\"))"] + ["only newlines" "\"\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"\\n\\n\"))"] + ["interior kept" "\"a\\nb\"" "(do (require (quote [clojure.string :as s])) (s/trim-newline \"a\\nb\\n\"))"])