X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/fc09e191754e82d26723b7c6cbf3bfc24fedbf44..9252626a58343d3256feb3b8c0456749ec1b4300:/src/optparse.lisp diff --git a/src/optparse.lisp b/src/optparse.lisp index 9607df7..1de6dfe 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 @@ -24,7 +24,7 @@ ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (cl:defpackage #:optparse - (:use #:common-lisp #:cl-launch #:sod-utilities)) + (:use #:common-lisp #:sod-utilities)) (cl:in-package #:optparse) @@ -35,19 +35,16 @@ (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)) - (abort))) + #.(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* "" @@ -62,13 +59,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*)))) @@ -150,15 +165,19 @@ (opt-long-name o) (opt-arg-optional-p o) (opt-arg-name o) - (opt-documentation o))))) - (:constructor %make-option) + (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)))) + 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 @@ -188,14 +207,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." + 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))) + (%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 +230,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 +264,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 +274,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 +672,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)) @@ -874,11 +896,8 @@ ;;; Support stuff for help and usage messages. (defun print-text (string - &optional - (stream *standard-output*) - &key - (start 0) - (end nil)) + &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." @@ -978,22 +997,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)