X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/38b78e8763833fee8b41ecaf7586558e9b60d254..9b9ad6b931736323a34123c11edfdff97a22623e:/src/utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 4935f8b..e7e1ae2 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -34,6 +34,16 @@
 (cl:in-package #:sod-utilities)
 
 ;;;--------------------------------------------------------------------------
+;;; Common symbols.
+;;;
+;;; Sometimes, logically independent packages will want to use the same
+;;; symbol, and these uses (by careful design) don't conflict with each
+;;; other.  If we export the symbols here, then the necessary sharing will
+;;; happen automatically.
+
+(export 'int)				; used by c-types and optparse
+
+;;;--------------------------------------------------------------------------
 ;;; Macro hacks.
 
 (export 'with-gensyms)
@@ -651,16 +661,17 @@
 						   (symbol-name name) "-")))
 			   cat-names))
 	 (items-var (gensym "ITEMS-")))
-    `(let ((,items-var ,items)
-	   ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
-       (dolist (,itemvar ,items-var)
-	 (let* ,bind
-	   (cond ,@(mapcar (lambda (cat-match-form cat-var)
-			     `(,cat-match-form
-			       (push ,itemvar ,cat-var)))
-			   cat-match-forms cat-vars)
-		 ,@(and (not (member t cat-match-forms))
-			`((t (error "Failed to categorize ~A" ,itemvar)))))))
+    `(let (,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
+       (let ((,items-var ,items))
+	 (dolist (,itemvar ,items-var)
+	   (let* ,bind
+	     (cond ,@(mapcar (lambda (cat-match-form cat-var)
+			       `(,cat-match-form
+				 (push ,itemvar ,cat-var)))
+			     cat-match-forms cat-vars)
+		   ,@(and (not (member t cat-match-forms))
+			  `((t (error "Failed to categorize ~A"
+				      ,itemvar))))))))
        (let ,(mapcar (lambda (name var)
 		       `(,name (nreverse ,var)))
 		     cat-names cat-vars)
@@ -842,7 +853,7 @@
 ;;; Functions.
 
 (export 'compose)
-(defun compose (function &rest more-functions)
+(defun compose (&rest functions)
   "Composition of functions.  Functions are applied left-to-right.
 
    This is the reverse order of the usual mathematical notation, but I find
@@ -853,7 +864,9 @@
   (labels ((compose1 (func-a func-b)
 	     (lambda (&rest args)
 	       (multiple-value-call func-b (apply func-a args)))))
-    (reduce #'compose1 more-functions :initial-value function)))
+    (if (null functions) #'values
+	(reduce #'compose1 (cdr functions)
+		:initial-value (car functions)))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Variables.
@@ -933,8 +946,9 @@
    The loop is surrounded by an anonymous BLOCK and the loop body forms an
    implicit TAGBODY, as is usual.  There is no result-form, however."
 
-  (once-only (:environment env seq start end)
-    (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-"))
+  (once-only (:environment env start end)
+    (with-gensyms ((seqvar "SEQ-") (ivar "INDEX-")
+		   (endvar "END-") (bodyfunc "BODY-"))
       (multiple-value-bind (docs decls body) (parse-body body :docp nil)
 	(declare (ignore docs))
 
@@ -943,13 +957,13 @@
 		 (let* ((do-vars nil)
 			(end-condition (if endvar
 					   `(>= ,ivar ,endvar)
-					   `(endp ,seq)))
+					   `(endp ,seqvar)))
 			(item (if listp
-				  `(car ,seq)
-				  `(aref ,seq ,ivar)))
+				  `(car ,seqvar)
+				  `(aref ,seqvar ,ivar)))
 			(body-call `(,bodyfunc ,item)))
 		   (when listp
-		     (push `(,seq (nthcdr ,start ,seq) (cdr ,seq))
+		     (push `(,seqvar (nthcdr ,start ,seqvar) (cdr ,seqvar))
 			   do-vars))
 		   (when indexp
 		     (push `(,ivar ,start (1+ ,ivar)) do-vars))
@@ -958,17 +972,18 @@
 		   `(do ,do-vars (,end-condition) ,body-call))))
 
 	  `(block nil
-	     (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
-		      ,@decls
-		      (tagbody ,@body)))
-	       (etypecase ,seq
-		 (vector
-		  (let ((,endvar (or ,end (length ,seq))))
-		    ,(loopguts t nil endvar)))
-		 (list
-		  (if ,end
-		      ,(loopguts t t end)
-		      ,(loopguts indexvar t nil)))))))))))
+	     (let ((,seqvar ,seq))
+	       (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
+			,@decls
+			(tagbody ,@body)))
+		 (etypecase ,seqvar
+		   (vector
+		    (let ((,endvar (or ,end (length ,seqvar))))
+		      ,(loopguts t nil endvar)))
+		   (list
+		    (if ,end
+			,(loopguts t t end)
+			,(loopguts indexvar t nil))))))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Structure accessor hacks.
@@ -1038,6 +1053,61 @@
 					    condition)))
 	 arguments))
 
+(export '(enclosing-condition enclosed-condition))
+(define-condition enclosing-condition (condition)
+  ((%enclosed-condition :initarg :condition :type condition
+			:reader enclosed-condition))
+  (:documentation
+   "A condition which encloses another condition
+
+   This is useful if one wants to attach additional information to an
+   existing condition.  The enclosed condition can be obtained using the
+   `enclosed-condition' function.")
+  (:report (lambda (condition stream)
+	     (princ (enclosed-condition condition) stream))))
+
+(export 'information)
+(define-condition information (condition)
+  ())
+
+(export 'simple-information)
+(define-condition simple-information (simple-condition information)
+  ())
+
+(export 'info)
+(defun info (datum &rest arguments)
+  "Report some useful diagnostic information.
+
+   Establish a simple restart named `noted', and signal the condition of type
+   `information' designated by DATUM and ARGUMENTS.  Return non-nil if the
+   restart was invoked, otherwise nil."
+  (restart-case
+      (signal (designated-condition 'simple-information datum arguments))
+    (noted () :report "Noted." t)))
+
+(export 'noted)
+(defun noted (&optional condition)
+  "Invoke the `noted' restart, possibly associated with the given CONDITION."
+  (invoke-associated-restart 'noted condition))
+
+(export 'promiscuous-cerror)
+(defun promiscuous-cerror (continue-string datum &rest arguments)
+  "Like standard `cerror', but robust against sneaky changes of conditions.
+
+   It seems that `cerror' (well, at least the version in SBCL) is careful
+   to limit its restart to the specific condition it signalled.  But that's
+   annoying, because `sod-parser:with-default-error-location' substitutes
+   different conditions carrying the error-location information."
+  (restart-case (apply #'error datum arguments)
+    (continue ()
+      :report (lambda (stream)
+		(apply #'format stream continue-string datum arguments))
+      nil)))
+
+(export 'cerror*)
+(defun cerror* (datum &rest arguments)
+  (apply #'promiscuous-cerror "Continue" datum arguments))
+
 ;;;--------------------------------------------------------------------------
 ;;; CLOS hacking.