From a901948043335740e11bc47e6d34849bd36e403a Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Thu, 8 Aug 2019 20:06:51 +0100 Subject: [PATCH] src/optparse.lisp: Muffle warnings about `&optional ... &key ...'. --- src/optparse.lisp | 164 ++++++++++++++++++++++++++++-------------------------- 1 file changed, 86 insertions(+), 78 deletions(-) diff --git a/src/optparse.lisp b/src/optparse.lisp index 1de6dfe..a34a7ea 100644 --- a/src/optparse.lisp +++ b/src/optparse.lisp @@ -32,19 +32,22 @@ ;;; 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)) - #.(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)) +(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*)) (defvar *program-name* "" @@ -151,34 +154,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 - (&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: + (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. @@ -208,13 +215,13 @@ 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))) + (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 @@ -895,40 +902,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) -- 2.11.0