diff --git a/README.md b/README.md index e0c26da..f1d699b 100644 --- a/README.md +++ b/README.md @@ -101,6 +101,19 @@ and now `collecting` is older than `with-collectors` by more than a decade I think. However it has an obvious definition as a shim on top of `with-collectors` and, finally, that now *is* its definition. +See `collect-into` below, which can be handed a local collector function as an argument and will do the right thing. This means that, for instance this will work: + +```lisp +(defun outer (x) + (collecting + (inner x #'collect))) + +(defun inner (x collector) + ... + (collect-into collector ...) + ...) +``` + ### General accumulators: `with-accumulators` **`with-accumulators`** is a variation on the theme of `with-collectors`: it allows you to accumulate things based on any function and a secret accumulator variable. `with-accumulators` takes a number of accumulator specifications as its first argument. These can have either a simple form and a more general form which may be extended in future. @@ -250,7 +263,7 @@ If you provide initial contents and ask for it not to be copied the list will be * `collector` is the collector; * `value` is the object to collect. -It returns its second argument. +It returns its second argument. If `collector` is a function it will simply call it with the second argument: this means it can be used with the local functions bound by `collecting` / `with-collactors` as well. **`collector-contents`** returns the contents of a collector: the list being collected by that collector. It has an optional argument, `appending`: if given this is appended to the value returned, either by using the tail pointer to modify the last cons of the list being built or by simply returning `appending` directly if nothing has been collected. If `appending` is not given, the collector can still be used after this, and the list returned by `collector-contents` will be destructively modified in that case. If `appending` is given then the collector is generally junk as the tail pointer is not updated: doing so would involve traversing `appending` and the whole point of this hack is to avoid doing that. See `nconc-collector-onto` for a function which *does* update the tail pointer. @@ -2069,10 +2082,12 @@ In this case `logging` will log to two destinations for `my-log-entry`. **`once-only-log-entry`** is a condition type which will be logged to at most one destination. ### Logging functions -**`(slog datum [arguments ...])`** takes arguments which denote a condition of default type `simple-log-entry` and signals that condition. The sense in which the 'arguments denote a condition' is exactly the same as for `signal` &c, except that the default condition type is `simple-log-entry`. +**`(slog datum [arguments ...])`** takes arguments which denote a condition of default type `simple-log-entry` and signals that condition. The sense in which the 'arguments denote a condition' is exactly the same as for `signal` &c, except that the default condition type is the value of `*default-log-entry-type*`. **`(slog-to destination datum [arguments ...])`** creates a log entry as `slog` does, but then rather than signalling it logs it directly to `destination`. `slog-to` is what ends up being called when logging destinations are specified by the `logging` macro, but you can also call it yourself. +**`*default-log-entry-type*`** is the condition class used by `slog` when its first argument is a string. Its default value is `simple-log-entry` but you can bind or assign to it to control what class is used. + ### Log destinations and `slog-to` The `logging` macro and the `slog-to` generic function know about *log destinations*. Some types of these are predefined, but you can extend the notion of what a log destination is either by defining methods on `slog-to` (see below for caveats) or, perhaps better, by providing a *fallback destination handler* which `slog-to` will call for destination handlers it does not have specialised methods for. This fallback handler can be bound dynamically. @@ -2334,6 +2349,31 @@ There are some sanity tests for this code which are run on loading `slog`, becau You can use `get-precision-universal-time` to write your own formatters, using `log-entry-internal-time` to get the time the entry was created. +**`reset-precision-time-offsets`** resets, or just reports, the offsets for precision time. Resetting can be necessary to reset the calibration, for instance when an image is saved and reloaded. It returns four values: + +- the universal time at which the clock ticked; +- the corresponding internal time; +- the previous value of the universal time at which the clock ticked; +- the previous corresponding internal time. + +`reset-prevision-time-offsets` takes two keyword arguments: + +- `report-only` says just to report the four values rather than resetting the internal parameters; +- `tries` tells it how many times to try: if it takes more than a single attempt there will be a warning, and an error if more than `tries`. The default value is `3`. + +`reset-precision-time-offsets` takes at least second to run: it's the function that gets called when `slog` is loaded. + +A function defined as + +```lisp +(defun ts () + (multiple-value-bind (ut0 it0 put0 pit0) (reset-precision-time-offsets :report-only t) + (values (float (- ut0 (/ it0 internal-time-units-per-second)) 1.0d0) + (float (- put0 (/ pit0 internal-time-units-per-second)) 1.0d0)))) +``` + +Should, unless the precision time needs to be reset, return two very close values, and probably two values which are actually the same. + ### An example: rotating log files ```lisp (defun rotate-log-files (&key (all nil)) @@ -2372,7 +2412,7 @@ Logging to pathnames rather than explicitly-managed streams may be a little slow --- -The TFEB.ORG Lisp hax are copyright 1989-2022 Tim Bradshaw. See `LICENSE` for the license. +The TFEB.ORG Lisp hax are copyright 1989-2023 Tim Bradshaw. See `LICENSE` for the license. --- diff --git a/VERSION b/VERSION index ae9a76b..8104cab 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -8.0.0 +8.1.0 diff --git a/collecting.lisp b/collecting.lisp index fd41085..961ee3f 100644 --- a/collecting.lisp +++ b/collecting.lisp @@ -258,14 +258,22 @@ pointer and updates the tail pointer appropriately." (defun collect-into (collector value) "Collect VALUE into COLLECTOR, returning VALUE. -This is Interlisp's TCONC." - (let ((it (list value))) - (if (null (cdr collector)) - (setf (car collector) it - (cdr collector) it) - (setf (cdr (cdr collector)) it - (cdr collector) it)) - value)) +If COLLECTOR is something made by MAKE-COLLECTOR, do the right thing. +If it is a function (such as the local functions defined by COLLECTING +/ WITH-COLLECTORS), simply call it with the value. + +This is the closest equivalent to Interlisp's TCONC." + (etypecase collector + (function + (funcall collector value)) + (cons + (let ((it (list value))) + (if (null (cdr collector)) + (setf (car collector) it + (cdr collector) it) + (setf (cdr (cdr collector)) it + (cdr collector) it)) + value)))) (defun nconc-collectors (collector &rest collectors) ;; Note unlike APPEND it makes no sense to call this with no diff --git a/slog.lisp b/slog.lisp index 55983f0..888afa1 100644 --- a/slog.lisp +++ b/slog.lisp @@ -24,6 +24,7 @@ #:log-entry-internal-time #:once-only-log-entry #:simple-log-entry + #:*default-log-entry-type* #:slog #:closing-opened-log-files #:log-file-truename @@ -32,6 +33,7 @@ #:close-open-log-files #:flush-open-log-files #:get-precision-universal-time + #:reset-precision-time-offsets #:default-log-entry-formatter #:*log-entry-formatter* #:slog-to @@ -72,10 +74,15 @@ () (:documentation "simple SLOG condition")) +(defvar *default-log-entry-type* 'simple-log-entry + "The default log entry type for SLOG + +This is SIMPLE-LOG-ENTRY by default.") + (defun ensure-log-entry (datum arguments) (typecase datum (string - (make-condition 'simple-log-entry + (make-condition *default-log-entry-type* :format-control datum :format-arguments arguments)) (log-entry @@ -271,6 +278,12 @@ ;;; Precision universal time ;;; +;;; The zeros for UT and IT +;;; (will be set below) +;;; +(defvar *ut0* 0) +(defvar *it0* 0) + (defun compute-image-time-offsets (&optional (tries 3)) ;; Return a universal time and the internal time at the point it ;; ticked. This necessarily takes more than a second. @@ -299,7 +312,33 @@ (return-from compute-image-time-offsets ;; Just average the two internal times we got to try and ;; get a reasonable offset - (list now (round (+ ib ia) 2))))))))) + (values now (round (+ ib ia) 2))))))))) + +(defun reset-precision-time-offsets (&key report-only (tries 3)) + "Reset, or check, the precision time offsets. + +Returns four values: a universal time and the internal time at which +point the second ticked, and the previous values for these two. By +default this also sets the internal variables to the new values. + +If REPORT-ONLY is given as NIL this will not reset the internal values +but only return them. + +TRIES (default 3) is the number of attempts to make to get this right. +There will be a warning if more than one try is needed, and an error +if more than TRIES is needed. + +This function necessarily takes at least a second to run." + (multiple-value-bind (ut0 it0) (compute-image-time-offsets tries) + (let ((old-ut0 *ut0*) + (old-it0 *it0*)) + (unless report-only + (setf *ut0* ut0 + *it0* it0)) + (values ut0 it0 old-ut0 old-it0)))) + +(eval-when (:load-toplevel :execute) + (reset-precision-time-offsets)) (defconstant default-precision-time-rate (min internal-time-units-per-second 1000)) @@ -308,10 +347,11 @@ (it (get-internal-real-time)) (type 'rational) (rate default-precision-time-rate ratep) - (chide nil)) + (chide nil) + &aux (ut0 *ut0*) (it0 *it0*)) ;; Return two values: the most precise idea of the time we can work ;; out, and the number of significant decimal places (which is just - ;; (log rate 10) + ;; (log rate 10)) (when chide (case type ((single-float short-float) @@ -320,24 +360,23 @@ (when (> rate internal-time-units-per-second) (warn "rate ~D is greater thant internal clock rate ~D" rate internal-time-units-per-second))) - (destructuring-bind (ut0 it0) (load-time-value (compute-image-time-offsets)) - (let ((pt (+ ut0 (/ (round (* rate (- it it0)) internal-time-units-per-second) - rate)))) - (values - (ecase type - ((rational ratio) pt) - ((float double-float ) (* pt 1.0d0)) - ((long-float) (* pt 1.0l0)) - ((single-float) (* pt 1.0f0)) - ((short-float) (* pt 1.0s0))) - rate - (cond - ((not ratep) - (load-time-value (ceiling (log default-precision-time-rate 10)))) - ((= rate internal-time-units-per-second) - (load-time-value (ceiling (log internal-time-units-per-second 10)))) - (t - (ceiling (log rate 10)))))))) + (let ((pt (+ ut0 (/ (round (* rate (- it it0)) internal-time-units-per-second) + rate)))) + (values + (ecase type + ((rational ratio) pt) + ((float double-float ) (* pt 1.0d0)) + ((long-float) (* pt 1.0l0)) + ((single-float) (* pt 1.0f0)) + ((short-float) (* pt 1.0s0))) + rate + (cond + ((not ratep) + (load-time-value (ceiling (log default-precision-time-rate 10)))) + ((= rate internal-time-units-per-second) + (load-time-value (ceiling (log internal-time-units-per-second 10)))) + (t + (ceiling (log rate 10))))))) (defun default-log-entry-formatter () (lambda (to log-entry)