From 23416a991adb0a708812ab87e9554f7e7fcc3374 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Sat, 19 Jun 2010 21:04:27 +0100
Subject: [PATCH] cl-fringe.lisp: Abstract out the startup stuff.

Less is `cl-launch' specific.  There's some support for ECL and SBCL
native startup stuff.  Indeed, this seems to work better than `cl-launch'
does, so we'll stick with it.
---
 Makefile       | 11 +++++++----
 cl-fringe.lisp | 55 +++++++++++++++++++++++++++++++++----------------------
 2 files changed, 40 insertions(+), 26 deletions(-)

diff --git a/Makefile b/Makefile
index 6d4455d..d08ed09 100644
--- a/Makefile
+++ b/Makefile
@@ -94,13 +94,16 @@ icon-fringe: icon-fringe.icn
 ###--------------------------------------------------------------------------
 ### Common Lisp.
 
-CLEANFILES		+= *.core
+CLEANFILES		+= *.core *.fasl
+
+.SUFFIXES: .lisp .fasl
+.lisp.fasl:; sbcl --eval '(quit :unix-status (if (compile-file "$<") 0 1))'
 
 LANGS			+= cl
 SOURCES			+= cl-fringe.lisp
-cl-fringe: cl-fringe.lisp
-##	cl-launch -R -o $@ -f `pwd`/$^	-- slow to start
-	cl-launch -o $@ -f `pwd`/$^ +I -r launch -d $@.core
+cl-fringe: cl-fringe.fasl
+       cp $< $@.new && chmod +x $@.new && mv $@.new $@
+##     cl-launch -o $@ -f `pwd`/$^ +I -r launch -d $@.core
 
 ###--------------------------------------------------------------------------
 ### F#.
diff --git a/cl-fringe.lisp b/cl-fringe.lisp
index 5af3cc7..0a41838 100644
--- 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 --------------------------------------------------
-- 
2.11.0