Commit cbc92b1b authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

UIOP improvements.

Define the :DBG macro, so it's ubiquitously available for print-debugging.
Define and export nest, so it's always there to prevent indentation drift.
Tweak restore-image again for better handling of *lisp-interaction*.
Update docstrings for define-package.
Define %process-info-pid.
parent 283b2f2a
......@@ -49,16 +49,16 @@
;;; Now for the debugging stuff itself.
;;; First, my all-purpose print-debugging macro
(defmacro DBG (tag &rest exprs)
"simple debug statement macro:
TAG is typically a constant string or keyword,
but in general is an expression returning a tag to be printed first;
"debug macro for print-debugging:
TAG is typically a constant string or keyword to identify who is printing,
but can be an arbitrary expression returning a tag to be princ'ed first;
if the expression returns NIL, nothing is printed.
EXPRS are expressions, which when the TAG was not NIL are evaluated in order,
with their source code then their return values being printed each time.
The last expresion is *always* evaluated and its values are returned,
The last expresion is *always* evaluated and its multiple values are returned,
but its source and return values are only printed if TAG was not NIL;
previous expressions are not evaluated at all if TAG returned NIL.
The macro expansion has relatively low overhead in space of time."
The macro expansion has relatively low overhead in space or time."
(let* ((last-expr (car (last exprs)))
(other-exprs (butlast exprs))
(tag-var (gensym "TAG"))
......
......@@ -240,7 +240,7 @@ if we are not called from a directly executable image."
(defun restore-image (&key
(lisp-interaction *lisp-interaction*)
(restore-hook *image-restore-hook* restore-hook-p)
(restore-hook *image-restore-hook*)
(prelude *image-prelude*)
(entry-point *image-entry-point*)
(if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
......@@ -248,12 +248,14 @@ if we are not called from a directly executable image."
by setting appropriate variables, running various hooks, and calling any specified entry point."
(when *image-restored-p*
(if if-already-restored
(call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t))
(call-function if-already-restored "Image already ~:[being ~;~]restored"
(eq *image-restored-p* t))
(return-from restore-image)))
(with-fatal-condition-handler ()
(setf *lisp-interaction* lisp-interaction)
(setf *image-restore-hook* restore-hook)
(setf *image-prelude* prelude)
(setf *image-restored-p* :in-progress)
(when restore-hook-p
(setf *image-restore-hook* restore-hook))
(call-image-restore-hook)
(standard-eval-thunk prelude)
(setf *image-restored-p* t)
......
......@@ -726,7 +726,7 @@ package on the list if the list is not empty.
MIX -- Takes a list of package designators. MIX behaves like
\(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to
resolve conflicts in favor of the first found symbol. It may still yield
an error if there is a conflict with an explicitly :SHADOWING-IMPORT-FROM symbol.
an error if there is a conflict with an explicitly :IMPORT-FROM symbol.
REEXPORT -- Takes a list of package designators. For each package, p, in the list,
export symbols with the same name as those exported from p. Note that in the case
of shadowing, etc. the symbols with the same name may not be the same symbols.
......
......@@ -555,6 +555,16 @@ It returns a process-info plist with possible keys:
(when (eq error-output :stream) (prop :error-stream err))))))
(nreverse process-info-r))))
(defun %process-info-pid (process-info)
(let ((process (getf process-info :process)))
(declare (ignorable process))
#+(or allegro lispworks) process
#+clozure (ccl::external-process-pid process)
#+ecl (si:external-process-pid process)
#+(or cmu scl) (ext:process-pid process)
#+sbcl (sb-ext:process-pid process)
#-(or allegro cmu sbcl scl) (error "~S not implemented" '%process-info-pid)))
(defun %wait-process-result (process-info)
(or (getf process-info :exit-code)
(let ((process (getf process-info :process)))
......
......@@ -13,8 +13,9 @@
(:export
;; magic helper to define debugging functions:
#:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
#:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions
#:if-let ;; basic flow control
;; (un)defining functions
#:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability
#:nest #:if-let ;; basic flow control
#:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
#:remove-plist-keys #:remove-plist-key ;; plists
#:emptyp ;; sequences
......@@ -110,11 +111,65 @@
(let* ((utility-file (or utility-file *uiop-debug-utility*))
(file (ignore-errors (probe-file (eval utility-file)))))
(if file (load file)
(error "Failed to locate debug utility file: ~S" utility-file)))))))
(error "Failed to locate debug utility file: ~S" utility-file))))))
(defmacro :DBG (tag &rest exprs) ;; NB: universally accessible in the KEYWORD package
"debug macro for print-debugging:
TAG is typically a constant string or keyword to identify who is printing,
but can be an arbitrary expression returning a tag to be princ'ed first;
if the expression returns NIL, nothing is printed.
EXPRS are expressions, which when the TAG was not NIL are evaluated in order,
with their source code then their return values being printed each time.
The last expresion is *always* evaluated and its multiple values are returned,
but its source and return values are only printed if TAG was not NIL;
previous expressions are not evaluated at all if TAG returned NIL.
The macro expansion has relatively low overhead in space or time."
(let* ((last-expr (car (last exprs)))
(other-exprs (butlast exprs))
(tag-var (gensym "TAG"))
(thunk-var (gensym "THUNK")))
`(let ((,tag-var ,tag))
(flet ,(when exprs `((,thunk-var () ,last-expr)))
(if ,tag-var
(DBG-helper ,tag-var
(list ,@(loop :for x :in other-exprs :collect
`(cons ',x #'(lambda () ,x))))
',last-expr ,(if exprs `#',thunk-var nil))
,(if exprs `(,thunk-var) '(values)))))))
(defun DBG-helper (tag expressions-thunks last-expression last-thunk)
;; Helper for the above debugging macro
(labels
((f (stream fmt &rest args)
(with-standard-io-syntax
(let ((*print-readably* nil)
(*package* (find-package :cl)))
(apply 'format stream fmt args)
(finish-output stream))))
(z (stream)
(f stream "~&"))
(e (fmt arg)
(f *error-output* fmt arg))
(x (expression thunk)
(e "~& ~S => " expression)
(let ((results (multiple-value-list (funcall thunk))))
(e "~{~S~^ ~}~%" results)
(apply 'values results))))
(map () #'z (list *standard-output* *error-output* *trace-output*))
(e "~A~%" tag)
(loop :for (expression . thunk) :in expressions-thunks
:do (x expression thunk))
(if last-thunk
(x last-expression last-thunk)
(values)))))
;;; Flow control
(with-upgradability ()
(defmacro nest (&rest things)
"Macro to do keep code nesting and indentation under control." ;; Thanks to mbaringer
(reduce #'(lambda (outer inner) `(,@outer ,inner))
things :from-end t))
(defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
;; bindings can be (var form) or ((var1 form1) ...)
(let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment