X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/fc09e191754e82d26723b7c6cbf3bfc24fedbf44..944bf9362ff51217b1617f85126d26e821b8aa91:/src/optparse.lisp

diff --git a/src/optparse.lisp b/src/optparse.lisp
index 9607df7..d03b9cc 100644
--- a/src/optparse.lisp
+++ b/src/optparse.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -23,8 +23,10 @@
 ;;; along with SOD; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
-(cl:defpackage #:optparse
-  (:use #:common-lisp #:cl-launch #:sod-utilities))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (handler-bind ((warning #'muffle-warning))
+    (cl:defpackage #:optparse
+      (:use #:common-lisp #:sod-utilities))))
 
 (cl:in-package #:optparse)
 
@@ -32,21 +34,21 @@
 ;;; Program environment things.
 
 (export 'exit)
-(defun exit (&optional (code 0) &key abrupt)
-  "End program, returning CODE to the caller."
-  (declare (type (unsigned-byte 32) code))
-  #+sbcl (sb-ext:exit :code code :abort abrupt)
-  #+cmu (if abrupt
-	    (unix::void-syscall ("_exit" c-call:int) code)
-	    (ext:quit code))
-  #+clisp (funcall (if abrupt #'ext:quit #'ext:exit) code)
-  #+ecl (ext:quit code)
-
-  #-(or sbcl cmu clisp ecl)
-  (progn
-    (unless (zerop code)
-      (format *error-output*
-	      "~&Exiting unsuccessfully with code ~D.~%" code))
+(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning
+						   sb-ext:compiler-note))
+  (defun exit (&optional (code 0) &key abrupt)
+    "End program, returning CODE to the caller."
+    (declare (type (unsigned-byte 32) code)
+	     )
+    #.(car '(#+sbcl (sb-ext:exit :code code :abort abrupt)
+	     #+cmu (if abrupt
+		       (unix::void-syscall ("_exit" c-call:int) code)
+		       (ext:quit code))
+	     #+clisp (funcall (if abrupt #'ext:quit #'ext:exit) code)
+	     #+ecl (ext:quit code)
+	     (unless (zerop code)
+	       (format *error-output*
+		       "~&Exiting unsuccessfully with code ~D.~%" code))))
     (abort)))
 
 (export '(*program-name* *command-line*))
@@ -62,13 +64,31 @@
    Set `*command-line*' and `*program-name*'."
 
   (setf *command-line*
-	(cons (or (getenv "CL_LAUNCH_FILE")
-		  #+sbcl (car sb-ext:*posix-argv*)
-		  #+cmu (car ext:*command-line-strings*)
-		  #+clisp (aref (ext:argv) 0)
-		  #+ecl (ext:argv 0)
-		  #-(or sbcl cmu clisp ecl) "sod")
-	      *arguments*)
+	(let ((uiop-package (find-package :uiop))
+	      (cll-package (find-package :cl-launch)))
+	  (cons (or (and uiop-package
+			 (funcall (intern "ARGV0" uiop-package)))
+		    (and cll-package
+			 (some (intern "GETENV" cll-package)
+			       (list "__CL_ARGV0" "CL_LAUNCH_FILE")))
+		    #+sbcl (car sb-ext:*posix-argv*)
+		    #+cmu (car ext:*command-line-strings*)
+		    #+clisp (aref (ext:argv) 0)
+		    #+ecl (ext:argv 0)
+		    "sod")
+		(cond (uiop-package
+		       (funcall (intern "COMMAND-LINE-ARGUMENTS"
+					uiop-package)))
+		      (cll-package
+		       (symbol-value (intern "*ARGUMENTS*" cll-package)))
+		      (t #.(or (car '(#+sbcl (cdr sb-ext:*posix-argv*)
+				      #+cmu (cdr ext:*command-line-strings*)
+				      #+clisp (coerce (subseq (ext:argv) 8)
+					       'list)
+				      #+ecl (loop for i from 1
+						  below (ext:argc)
+						  collect (ext:argv i))))
+			       (error "Unsupported Lisp"))))))
 
 	*program-name* (pathname-name (car *command-line*))))
 
@@ -136,30 +156,38 @@
 (export '(option optionp make-option
 	  opt-short-name opt-long-name opt-tag opt-negated-tag
 	  opt-arg-name opt-arg-optional-p opt-documentation))
-(defstruct (option
-	     (:predicate optionp)
-	     (:conc-name opt-)
-	     (:print-function
-	      (lambda (o s k)
-		(declare (ignore k))
-		(print-unreadable-object (o s :type t)
-		  (format s "~@[-~C, ~]~@[--~A~]~
+(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning))
+  (defstruct (option
+	       (:predicate optionp)
+	       (:conc-name opt-)
+	       (:print-function
+		(lambda (o s k)
+		  (declare (ignore k))
+		  (print-unreadable-object (o s :type t)
+		    (format s "~@[-~C, ~]~@[--~A~]~
 			     ~*~@[~2:*~:[=~A~;[=~A]~]~]~
 			     ~@[ ~S~]"
-			  (opt-short-name o)
-			  (opt-long-name o)
-			  (opt-arg-optional-p o)
-			  (opt-arg-name o)
-			  (opt-documentation o)))))
-	     (:constructor %make-option)
-	     (:constructor make-option
-		 (long-name short-name
-		  &optional arg-name
-		  &key (tag (intern (string-upcase long-name) :keyword))
-		       negated-tag
-		       arg-optional-p
-		       doc (documentation doc))))
-  "Describes a command-line option.  Slots:
+			    (opt-short-name o)
+			    (opt-long-name o)
+			    (opt-arg-optional-p o)
+			    (opt-arg-name o)
+			    (opt-%documentation o)))))
+	       (:constructor %make-option
+			     (&key long-name tag negated-tag short-name
+				   arg-name arg-optional-p documentation
+				   &aux (%documentation documentation)))
+	       (:constructor make-option
+			     (long-name short-name
+					&optional arg-name
+					&key (tag (intern (string-upcase
+							   long-name)
+							  :keyword))
+					negated-tag
+					arg-optional-p
+					doc (documentation doc)
+					&aux (%documentation
+					      documentation))))
+    "Describes a command-line option.  Slots:
 
    LONG-NAME	The option's long name.  If this is null, the `option' is
 		just a banner to be printed in the program's help text.
@@ -188,14 +216,15 @@
 		wrapped.  If nil, the option is omitted from the help
 		text.
 
-   Usually, one won't use make-option, but use the option macro instead."
-  (long-name nil :type (or null string))
-  (tag nil :type t)
-  (negated-tag nil :type t)
-  (short-name nil :type (or null character))
-  (arg-name nil :type (or null string))
-  (arg-optional-p nil :type t)
-  (documentation nil :type (or null string)))
+   Usually, one won't use `make-option', but use the `option' macro instead."
+    (long-name nil :type (or null string))
+    (tag nil :type t)
+    (negated-tag nil :type t)
+    (short-name nil :type (or null character))
+    (arg-name nil :type (or null string))
+    (arg-optional-p nil :type t)
+    (%documentation nil :type (or null string))))
+(define-access-wrapper opt-documentation opt-%documentation)
 
 (export '(option-parser option-parser-p make-option-parser
 	  op-options op-non-option op-long-only-p op-numeric-p
@@ -210,6 +239,7 @@
 		       negated-numeric-p
 		       long-only-p
 		  &aux (args (cons nil argstmp))
+		       (%options options)
 		       (next args)
 		       (negated-p (or negated-numeric-p
 				      (some #'opt-negated-tag
@@ -243,7 +273,7 @@
 		still allowed, and may be cuddled as usual.  The default is
 		nil."
   (args nil :type list)
-  (options nil :type list)
+  (%options nil :type list)
   (non-option :skip :type (or function (member :skip :stop :return)))
   (next nil :type list)
   (short-opt nil :type (or null string))
@@ -253,6 +283,7 @@
   (numeric-p nil :type t)
   (negated-numeric-p nil :type t)
   (negated-p nil :type t))
+(define-access-wrapper op-options op-%options)
 
 (export 'option-parse-error)
 (define-condition option-parse-error (error simple-condition)
@@ -650,7 +681,7 @@
    RADIX may be nil to allow radix prefixes, or an integer between 2 and 36.
    An option-parse-error is signalled if the ARG is not a valid integer, or
    if it is not between MIN and MAX (either of which may be nil if no lower
-   resp. upper bound is wanted)."
+   or upper bound is wanted)."
   (multiple-value-bind (v end) (parse-c-integer arg :radix radix)
     (unless (and v (>= end (length arg)))
       (option-parse-error "Bad integer `~A'" arg))
@@ -873,43 +904,41 @@
 ;;;--------------------------------------------------------------------------
 ;;; Support stuff for help and usage messages.
 
-(defun print-text (string
-		   &optional
-		   (stream *standard-output*)
-		   &key
-		   (start 0)
-		   (end nil))
-  "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and
+(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning))
+  (defun print-text (string
+		     &optional (stream *standard-output*)
+		     &key (start 0) (end nil))
+    "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and
    newlines in the obvious way.  Stuff between square brackets is not broken:
    this makes usage messages work better."
-  (let ((i start)
-	(nest 0)
-	(splitp nil))
-    (flet ((emit ()
-	     (write-string string stream :start start :end i)
-	     (setf start i)))
-      (unless end (setf end (length string)))
-      (loop
-	 (unless (< i end)
-	   (emit)
-	   (return))
-	 (let ((ch (char string i)))
-	   (cond ((char= ch #\newline)
-		  (emit)
-		  (incf start)
-		  (pprint-newline :mandatory stream))
-		 ((whitespace-char-p ch)
-		  (when (zerop nest)
-		    (setf splitp t)))
-		 (t
-		  (when splitp
-		    (emit)
-		    (pprint-newline :fill stream))
-		  (setf splitp nil)
-		  (case ch
-		    (#\[ (incf nest))
-		    (#\] (when (plusp nest) (decf nest))))))
-	   (incf i))))))
+    (let ((i start)
+	  (nest 0)
+	  (splitp nil))
+      (flet ((emit ()
+	       (write-string string stream :start start :end i)
+	       (setf start i)))
+	(unless end (setf end (length string)))
+	(loop
+	  (unless (< i end)
+	    (emit)
+	    (return))
+	  (let ((ch (char string i)))
+	    (cond ((char= ch #\newline)
+		   (emit)
+		   (incf start)
+		   (pprint-newline :mandatory stream))
+		  ((whitespace-char-p ch)
+		   (when (zerop nest)
+		     (setf splitp t)))
+		  (t
+		   (when splitp
+		     (emit)
+		     (pprint-newline :fill stream))
+		   (setf splitp nil)
+		   (case ch
+		     (#\[ (incf nest))
+		     (#\] (when (plusp nest) (decf nest))))))
+	    (incf i)))))))
 
 (export 'simple-usage)
 (defun simple-usage (opts &optional mandatory-args)
@@ -978,22 +1007,25 @@
     (dolist (o opts)
       (let ((doc (opt-documentation o)))
 	(cond ((not o))
-	      ((not (opt-long-name o))
+	      ((not (or (opt-short-name o)
+			(opt-long-name o)))
 	       (when newlinep
 		 (terpri stream)
 		 (setf newlinep nil))
 	       (pprint-logical-block (stream nil)
 		 (print-text doc stream))
 	       (terpri stream))
-	      (t
+	      (doc
 	       (setf newlinep t)
 	       (pprint-logical-block (stream nil :prefix "  ")
-		 (format stream "~:[   ~;-~:*~C,~] --~A"
+		 (format stream "~:[   ~;-~:*~C~:[~;,~]~:*~]~@[ --~A~]"
 			 (opt-short-name o)
 			 (opt-long-name o))
 		 (when (opt-arg-name o)
-		   (format stream "~:[=~A~;[=~A]~]"
+		   (format stream
+			   "~:[~;[~]~:[~0@*~:[ ~;~]~*~;=~]~A~0@*~:[~;]~]"
 			   (opt-arg-optional-p o)
+			   (opt-long-name o)
 			   (opt-arg-name o)))
 		 (write-string "  " stream)
 		 (pprint-tab :line 30 1 stream)