;; 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."
(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:
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 --------------------------------------------------
~mdw / fringe / blobdiff