X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/9ec578d9fe450b7e7f9030dc9d930185593aa991..00d59354c311fb28730b7c9b117b0d91aac092cc:/src/optparse.lisp diff --git a/src/optparse.lisp b/src/optparse.lisp index fc46ba4..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 #: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,21 +64,31 @@ Set `*command-line*' and `*program-name*'." (setf *command-line* - (or (when (member :cl-launch *features*) - (let* ((cllpkg (find-package :cl-launch)) - (name (funcall (intern "GETENV" cllpkg) - "CL_LAUNCH_FILE")) - (args (symbol-value (intern "*ARGUMENTS*" cllpkg)))) - (if name - (cons name args) - args))) - #+sbcl sb-ext:*posix-argv* - #+cmu ext:*command-line-strings* - #+clisp (loop with argv = (ext:argv) - for i from 7 below (length argv) - collect (aref argv i)) - #+ecl (loop from i below (ext:argc) collect (ext:argv i)) - '("")) + (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*)))) @@ -121,66 +133,6 @@ (do-case2-like 'ecase vform clauses)) ;;;-------------------------------------------------------------------------- -;;; Locatives. - -(export '(loc locp)) -(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer))) - "Locative data type. See `locf' and `ref'." - (reader nil :type function) - (writer nil :type function)) - -(export 'locf) -(defmacro locf (place &environment env) - "Slightly cheesy locatives. - - (locf PLACE) returns an object which, using the `ref' function, can be - used to read or set the value of PLACE. It's cheesy because it uses - closures rather than actually taking the address of something. Also, - unlike Zetalisp, we don't overload `car' to do our dirty work." - (multiple-value-bind - (valtmps valforms newtmps setform getform) - (get-setf-expansion place env) - `(let* (,@(mapcar #'list valtmps valforms)) - (make-loc (lambda () ,getform) - (lambda (,@newtmps) ,setform))))) - -(export 'ref) -(declaim (inline ref (setf ref))) -(defun ref (loc) - "Fetch the value referred to by a locative." - (funcall (loc-reader loc))) -(defun (setf ref) (new loc) - "Store a new value in the place referred to by a locative." - (funcall (loc-writer loc) new)) - -(export 'with-locatives) -(defmacro with-locatives (locs &body body) - "Evaluate BODY with implicit locatives. - - LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a - symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it - defaults to SYM. As an abbreviation for a common case, LOCS may be a - symbol instead of a list. - - The BODY is evaluated in an environment where each SYM is a symbol macro - which expands to (ref LOC-EXPR) -- or, in fact, something similar which - doesn't break if LOC-EXPR has side-effects. Thus, references, including - `setf' forms, fetch or modify the thing referred to by the LOC-EXPR. - Useful for covering over where something uses a locative." - (setf locs (mapcar (lambda (item) - (cond ((atom item) (list item item)) - ((null (cdr item)) (list (car item) (car item))) - (t item))) - (if (listp locs) locs (list locs)))) - (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs)) - (ll (mapcar #'cadr locs)) - (ss (mapcar #'car locs))) - `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll)) - (symbol-macrolet (,@(mapcar (lambda (sym tmp) - `(,sym (ref ,tmp))) ss tt)) - ,@body)))) - -;;;-------------------------------------------------------------------------- ;;; Standard error-reporting functions. (export 'moan) @@ -204,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. @@ -256,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 @@ -278,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 @@ -311,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)) @@ -321,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) @@ -604,7 +567,7 @@ ,@docs ,@decls (declare (ignorable ,arg)) (with-locatives ,var - ,@body)) + (block ,name ,@body))) ',name)))) (defun parse-c-integer (string &key radix (start 0) end) @@ -718,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)) @@ -795,9 +758,12 @@ Option macros should produce a list of expressions producing one option structure each." - `(progn - (setf (get ',name 'optmacro) (lambda ,args ,@body)) - ',name)) + (multiple-value-bind (docs decls body) (parse-body body) + `(progn + (setf (get ',name 'optmacro) (lambda ,args + ,@docs ,@decls + (block ,name ,@body))) + ',name))) (export 'parse-option-form) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -938,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) @@ -1043,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)