X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/4ac20e3bbed1cba5c16d4573431db20a84d5e28b..8eb242b160e163a1cfc6e810aeda4788116bba1a:/src/optparse.lisp diff --git a/src/optparse.lisp b/src/optparse.lisp index 70bb012..5268cda 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*)))) @@ -113,66 +128,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) @@ -210,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 @@ -248,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 @@ -270,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 @@ -303,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)) @@ -313,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) @@ -596,7 +558,7 @@ ,@docs ,@decls (declare (ignorable ,arg)) (with-locatives ,var - ,@body)) + (block ,name ,@body))) ',name)))) (defun parse-c-integer (string &key radix (start 0) end) @@ -787,9 +749,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) @@ -931,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."