;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;  Touched: <Sat Jul  4 10:54:00 IST 2009> Madhu <enometh@net.meer>
;;;  Bugs-To: enometh@net.meer
;;;  Status: Experimental. Do not redistribute.
;;;  Copyright (C) 2009 Madhu.  All Rights Reserved.
;;;
(in-package "USER")

(defmacro with-adhoc-parser (string &body body)
  "Internal. Ad Hoc parser.  Evaluate BODY within a named block (named OUTER),
in environment containing the local functions SKIP-WHITE, MATCH-STRING,
READ-FLOAT, and READ-NUMBER.  On failure, each of these local functions exits
the OUTER block, returning as values, NIL, and the index of STRING at which
the error occured.  Otherwise returns the results from evaluating BODY."
  (let ((string-var (gensym)))
    `(let ((,string-var ,string) (idx 0))
       (block outer
	 (flet ((skip-white ()
		  (let ((pos (position-if-not
			      (lambda (c) (find c #(#\Space #\Tab)))
			      ,string-var :start idx)))
		    (if pos
			(setq idx pos)
			(return-from outer (values nil idx)))))
		(match-string (match)
		  (let ((pos (mismatch ,string-var match :start1 idx))
			(end (+ idx (length match))))
		    (if (or (null pos) (= pos end))
			(setq idx end)
			(return-from outer (values nil idx)))))
		(read-number ()
		  (multiple-value-bind (num pos)
		      (parse-integer ,string-var :start idx :junk-allowed t)
		    (unless (and num (setq idx pos))
		      (return-from outer (values nil idx)))
		    num))
		(read-float ()
		  (multiple-value-bind (num pos)
		      (read-from-string ,string-var nil nil :start idx)
		    (cond ((floatp num) (setq idx pos) num)
			  (t (return-from outer (values nil idx))))))
                (read-delim-string (&optional delim)
                  (if (null delim)
                      (prog1 (subseq ,string-var idx)
                        (setq idx (length ,string-var)))
                      (let* ((delims
                              (etypecase delim
                                (sequence delim)
                                (character (setq delim (list delim)))))
                             (pos
                              (position-if (lambda (c) (find c delims))
                                           ,string-var :start idx)))
                        (if pos
                            (prog1 (subseq ,string-var idx pos)
                              (setq idx (1+ pos)))
                            (return-from outer (values nil idx)))))))
	   (declare (ignorable skip-white match-string read-number read-float))
	   ,@body)))))