Add ensuref, profile-when
author |
Steve Losh <steve@stevelosh.com> |
date |
Wed, 01 Mar 2023 21:12:34 -0500 |
parents |
896559ec54b1
|
children |
218a430ec1a7
|
branches/tags |
(none) |
files |
DOCUMENTATION.markdown src/debugging.lisp src/mutation.lisp src/package.lisp |
Changes
--- a/DOCUMENTATION.markdown Wed Feb 08 21:27:09 2023 -0500
+++ b/DOCUMENTATION.markdown Wed Mar 01 21:12:34 2023 -0500
@@ -1055,6 +1055,14 @@
Profile `form` and dump the report to `lisp.prof`.
+### `PROFILE-WHEN` (macro)
+
+ (PROFILE-WHEN CONDITION
+ &BODY
+ BODY)
+
+Evaluate and return `body`, profiling when `condition` is true.
+
### `SHUT-UP` (macro)
(SHUT-UP
@@ -1965,6 +1973,28 @@
+### `ENSUREF` (macro)
+
+ (ENSUREF &REST PLACE-EXPR-PAIRS)
+
+Set each `place` that is currently `NIL` to its corresponding `expr`.
+
+ Syntactic sugar where `(ensuref place expr)` expands to something like
+ `(or place (setf place expr))` but doesn't multiply-evaluate the place.
+
+ Examples:
+
+ (defparameter *foo* nil)
+ *foo* ; => NIL
+
+ (ensuref *foo* (print 'hello)) ; prints HELLO
+ *foo* ; => HELLO
+
+ (ensuref *foo* (print 'world))
+ *foo* ; => HELLO
+
+
+
### `MODF` (macro)
(MODF PLACE DIVISOR)
--- a/src/debugging.lisp Wed Feb 08 21:27:09 2023 -0500
+++ b/src/debugging.lisp Wed Mar 01 21:12:34 2023 -0500
@@ -209,6 +209,14 @@
(time ,form)
(stop-profiling))))
+(defmacro profile-when (condition &body body)
+ "Evaluate and return `body`, profiling when `condition` is true."
+ (with-gensyms (thunk)
+ `(flet ((,thunk () ,@body))
+ (if ,condition
+ (profile (,thunk))
+ (,thunk)))))
+
(defmacro timing ((&key (time :run) (result-type 'integer)) &body body)
"Execute `body`, discard its result, and return the time taken.
--- a/src/mutation.lisp Wed Feb 08 21:27:09 2023 -0500
+++ b/src/mutation.lisp Wed Mar 01 21:12:34 2023 -0500
@@ -86,3 +86,34 @@
,@(loop :for (place function . nil) :on place-function-pairs :by #'cddr
:collect `(%callf ,place ,function))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun build-ensure (place expr env)
+ (multiple-value-bind (temps exprs stores store-expr access-expr)
+ (get-setf-expansion place env)
+ `(let* (,@(mapcar #'list temps exprs))
+ (unless ,access-expr
+ (let ((,(car stores) ,expr))
+ ,store-expr))))))
+
+(defmacro ensuref (&rest place-expr-pairs &environment env)
+ "Set each `place` that is currently `NIL` to its corresponding `expr`.
+
+ Syntactic sugar where `(ensuref place expr)` expands to something like
+ `(or place (setf place expr))` but doesn't multiply-evaluate the place.
+
+ Examples:
+
+ (defparameter *foo* nil)
+ *foo* ; => NIL
+
+ (ensuref *foo* (print 'hello)) ; prints HELLO
+ *foo* ; => HELLO
+
+ (ensuref *foo* (print 'world))
+ *foo* ; => HELLO
+
+ "
+ `(progn
+ ,@(loop :for (place expr) :on place-expr-pairs :by #'cddr
+ :collect (build-ensure place expr env))))
+
--- a/src/package.lisp Wed Feb 08 21:27:09 2023 -0500
+++ b/src/package.lisp Wed Mar 01 21:12:34 2023 -0500
@@ -133,7 +133,8 @@
:clampf
:negatef
:notf
- :callf))
+ :callf
+ :ensuref))
(defpackage :losh.shell
(:use :cl :iterate :losh.base)
@@ -420,6 +421,7 @@
(:export
#+sbcl :profile
+ #+sbcl :profile-when
#+sbcl :start-profiling
#+sbcl :stop-profiling
:aesthetic-string