cl-fringe.lisp: Abstract out the startup stuff.

[fringe] / cl-fringe.lisp

diff --git a/cl-fringe.lisp b/cl-fringe.lisp
index 5af3cc7..0a41838 100644 (file)
--- a/cl-fringe.lisp
+++ b/cl-fringe.lisp
@@ -95,32 +95,43 @@
 ;;;--------------------------------------------------------------------------
 ;;; Main program.
 
-(defun main (args)
+(defun main (prog args)
   "Main program: process ARGS."
-  (destructuring-bind (&optional a b &rest junk) args
-    (cond ((or (null a) junk) (error "bad args"))
-         ((null b) (format t "~{~C~}~%"
-                           (list-iterator (iterate-fringe (parse-tree a)))))
-         (t (format t "~:[no match~;match~]~%"
-                    (same-iterators-p (iterate-fringe (parse-tree a))
-                                      (iterate-fringe (parse-tree b))))))))
-
-#+cl-launch
-(progn
-  (defparameter *program-name*
-    (pathname-name (or (cl-launch:getenv "CL_LAUNCH_FILE")
-                      (namestring *load-pathname*)
-                      "<unknown>")))
-  (defun launch ()
-    (flet ((bail (format args)
-            (format *error-output* "~A: ~?~%" *program-name* format args)
-            (cl-launch:quit 1)))
-      (handler-case
-         (main cl-launch:*arguments*)
+  (flet ((bail (format args)
+          (format *error-output* "~A: ~?~%" prog format args)
+          (return-from main 1)))
+    (handler-case
+       (destructuring-bind (&optional a b &rest junk) args
+         (cond ((or (null a) junk)
+                (error "bad args"))
+               ((null b)
+                (format t "~{~C~}~%"
+                        (list-iterator (iterate-fringe (parse-tree a)))))
+               (t
+                (format t "~:[no match~;match~]~%"
+                        (same-iterators-p
+                         (iterate-fringe (parse-tree a))
+                         (iterate-fringe (parse-tree b)))))))
        (simple-error (err)
          (bail (simple-condition-format-control err)
                (simple-condition-format-arguments err)))
        (error (err)
-         (bail "~A" err))))))
+         (bail "~A" err)))
+    0))
+
+#+cl-launch
+(defun launch ()
+  (cl-launch:quit (main (or (cl-launch:getenv "CL_LAUNCH_FILE")
+                           (namestring *load-pathname*)
+                           "<unknown>")
+                       cl-launch:*arguments*)))
+
+#+(and (not cl-launch) ecl)
+(ext:quit (main (ext:argv 0)
+               (loop for i from 1 below (ext:argc) collect (ext:argv i))))
+
+#+(and (not cl-launch) sbcl)
+(sb-ext:quit :unix-status (main (pathname-name *load-pathname*)
+                               (cdr sb-ext:*posix-argv*)))
 
 ;;;----- That's all, folks --------------------------------------------------