X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/bb80145308ea388d7c6ed5336c061340e78f66e8..e43d353268fc869045f757932d78d6073db9de6e:/src/optparse.lisp

diff --git a/src/optparse.lisp b/src/optparse.lisp
index a2ac290..74df161 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* "<unknown>"
@@ -62,15 +59,33 @@
    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*)
-
-	*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.
@@ -536,7 +551,7 @@
 	   ,@docs ,@decls
 	   (declare (ignorable ,arg))
 	   (with-locatives ,var
-	     ,@body))
+	     (block ,name ,@body)))
 	 ',name))))
 
 (defun parse-c-integer (string &key radix (start 0) end)
@@ -727,9 +742,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)