X-Git-Url: https://git.distorted.org.uk/~mdw/fringe/blobdiff_plain/d782cc40f017562d106f186120df185d9995bc69..8a4f4f075a6e2e90039b172242097a4eca48d60b:/cl-fringe.lisp

diff --git a/cl-fringe.lisp b/cl-fringe.lisp
index a2ddf85..febdada 100644
--- a/cl-fringe.lisp
+++ b/cl-fringe.lisp
@@ -10,14 +10,27 @@
 ;; new iterator function to produce the remaining items; if there are no more
 ;; items, then it returns NIL twice.
 
+(defun reduce-iterator (func init iter)
+  "Invoke FUNC on the elements of ITER.
+
+   We maintain a STATE whose value initially is INIT; for each ITEM, we
+   update the state with the value of (funcall FUNC ITEM STATE); the end
+   result is the final state."
+  (let ((state init) item)
+    (loop
+      (setf (values item iter) (funcall iter))
+      (unless iter (return state))
+      (setf state (funcall func item state)))))
+
 (defun list-iterator (iter)
   "Collect the items from ITER into a list and return it."
-  (labels ((recur (iter list)
-	     (multiple-value-bind (data iter) (funcall iter)
-	       (if iter
-		   (recur iter (cons data list))
-		   (nreverse list)))))
-    (recur iter nil)))
+  (nreverse (reduce-iterator #'cons nil iter)))
+
+(defun iterate-list (list)
+  "Return an iterator for LIST, according to our iteration protocol."
+  (if (endp list)
+      (lambda () (values nil nil))
+      (lambda () (values (car list) (iterate-list (cdr list))))))
 
 (defun same-iterators-p (iter-a iter-b &key (test #'eql))
   "Return whether ITER-A and ITER-B produce the same items."
@@ -51,7 +64,7 @@
 		   (t (values nil nil)))))
     (lambda () (recur node nil))))
 
-(defun parse-tree (string)
+(defun parse-tree (string &key (start 0) (end (length string)))
   "Parse STRING, and return the tree described.
 
    The syntax is simple:
@@ -61,53 +74,63 @@
    The ambiguity is resolved by always treating `(' as a tree when a tree is
    expected."
 
-  (let ((len (length string)))
-    (labels ((parse (i)
-	       (cond ((and (< i len) (char= (char string i) #\())
-		      (multiple-value-bind (left i) (parse (1+ i))
-			(unless (< i len) (error "no data"))
-			(let ((data (char string i)))
-			  (multiple-value-bind (right i) (parse (1+ i))
-			    (unless (and (< i len)
-					 (char= (char string i) #\)))
-			      (error "missing )"))
-			    (values
-			     (make-node :left left :data data :right right)
-			     (1+ i))))))
-		     (t (values nil i)))))
-      (multiple-value-bind (tree i) (parse 0)
-	(unless (= i len) (error "trailing junk"))
-	tree))))
+  (labels ((parse (i)
+	     (cond ((and (< i end) (char= (char string i) #\())
+		    (multiple-value-bind (left i) (parse (1+ i))
+		      (unless (< i end) (error "no data"))
+		      (let ((data (char string i)))
+			(multiple-value-bind (right i) (parse (1+ i))
+			  (unless (and (< i end)
+				       (char= (char string i) #\)))
+			    (error "missing )"))
+			  (values
+			   (make-node :left left :data data :right right)
+			   (1+ i))))))
+		   (t (values nil i)))))
+    (multiple-value-bind (tree i) (parse start)
+      (unless (= i end) (error "trailing junk"))
+      tree)))
 
 ;;;--------------------------------------------------------------------------
 ;;; 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 --------------------------------------------------