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 @@ ...@@ -49,16 +49,16 @@
;;; Now for the debugging stuff itself. ;;; Now for the debugging stuff itself.
;;; First, my all-purpose print-debugging macro ;;; First, my all-purpose print-debugging macro
(defmacro DBG (tag &rest exprs) (defmacro DBG (tag &rest exprs)
"simple debug statement macro: "debug macro for print-debugging:
TAG is typically a constant string or keyword, TAG is typically a constant string or keyword to identify who is printing,
but in general is an expression returning a tag to be printed first; but can be an arbitrary expression returning a tag to be princ'ed first;
if the expression returns NIL, nothing is printed. if the expression returns NIL, nothing is printed.
EXPRS are expressions, which when the TAG was not NIL are evaluated in order, 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. 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; 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. 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))) (let* ((last-expr (car (last exprs)))
(other-exprs (butlast exprs)) (other-exprs (butlast exprs))
(tag-var (gensym "TAG")) (tag-var (gensym "TAG"))
......
...@@ -240,7 +240,7 @@ if we are not called from a directly executable image." ...@@ -240,7 +240,7 @@ if we are not called from a directly executable image."
(defun restore-image (&key (defun restore-image (&key
(lisp-interaction *lisp-interaction*) (lisp-interaction *lisp-interaction*)
(restore-hook *image-restore-hook* restore-hook-p) (restore-hook *image-restore-hook*)
(prelude *image-prelude*) (prelude *image-prelude*)
(entry-point *image-entry-point*) (entry-point *image-entry-point*)
(if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY"))) (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
...@@ -248,12 +248,14 @@ if we are not called from a directly executable image." ...@@ -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." by setting appropriate variables, running various hooks, and calling any specified entry point."
(when *image-restored-p* (when *image-restored-p*
(if if-already-restored (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))) (return-from restore-image)))
(with-fatal-condition-handler () (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) (setf *image-restored-p* :in-progress)
(when restore-hook-p
(setf *image-restore-hook* restore-hook))
(call-image-restore-hook) (call-image-restore-hook)
(standard-eval-thunk prelude) (standard-eval-thunk prelude)
(setf *image-restored-p* t) (setf *image-restored-p* t)
......
...@@ -726,7 +726,7 @@ package on the list if the list is not empty. ...@@ -726,7 +726,7 @@ package on the list if the list is not empty.
MIX -- Takes a list of package designators. MIX behaves like MIX -- Takes a list of package designators. MIX behaves like
\(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to \(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to
resolve conflicts in favor of the first found symbol. It may still yield 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, 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 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. 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: ...@@ -555,6 +555,16 @@ It returns a process-info plist with possible keys:
(when (eq error-output :stream) (prop :error-stream err)))))) (when (eq error-output :stream) (prop :error-stream err))))))
(nreverse process-info-r)))) (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) (defun %wait-process-result (process-info)
(or (getf process-info :exit-code) (or (getf process-info :exit-code)
(let ((process (getf process-info :process))) (let ((process (getf process-info :process)))
......
...@@ -13,8 +13,9 @@ ...@@ -13,8 +13,9 @@
(:export (:export
;; magic helper to define debugging functions: ;; magic helper to define debugging functions:
#:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility* #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
#:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions ;; (un)defining functions
#:if-let ;; basic flow control #:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability
#:nest #:if-let ;; basic flow control
#:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
#:remove-plist-keys #:remove-plist-key ;; plists #:remove-plist-keys #:remove-plist-key ;; plists
#:emptyp ;; sequences #:emptyp ;; sequences
...@@ -110,11 +111,65 @@ ...@@ -110,11 +111,65 @@
(let* ((utility-file (or utility-file *uiop-debug-utility*)) (let* ((utility-file (or utility-file *uiop-debug-utility*))
(file (ignore-errors (probe-file (eval utility-file))))) (file (ignore-errors (probe-file (eval utility-file)))))
(if file (load 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 ;;; Flow control
(with-upgradability () (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 (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
;; bindings can be (var form) or ((var1 form1) ...) ;; bindings can be (var form) or ((var1 form1) ...)
(let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) (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