X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/9ec578d9fe450b7e7f9030dc9d930185593aa991..1c1ea17d710f2e1d40fc1e48a354195303fd7d4f:/src/optparse.lisp diff --git a/src/optparse.lisp b/src/optparse.lisp index fc46ba4..16b5b7b 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 @@ -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,23 +59,33 @@ 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)) - '("")) - - *program-name* (pathname-name (car *command-line*)))) + (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*)))) ;;;-------------------------------------------------------------------------- ;;; Fancy conditionals. @@ -121,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) @@ -219,14 +166,18 @@ (opt-arg-optional-p o) (opt-arg-name o) (opt-documentation o))))) - (:constructor %make-option) + (: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 @@ -263,7 +214,8 @@ (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 @@ -278,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 @@ -311,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)) @@ -321,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) @@ -604,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) @@ -795,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)