Can a Lisp read procedure read this and how?

Question

I'm writing a grammar which I intend to implement in a Lisp read procedure, i.e. reading one expression at a time from an input source which is i.e. mutable. Most of the grammar is just like Lisp, but the two pertinent changes are:

Whitespace is read and is part of the resulting syntax. Contiguous whitespace is grouped together like contiguous non-whitespace characters are grouped as identifiers, and the result of reading such a string is a "whitespace object", which stores the exact sequence of characters read. The evaluator ignores whitespace objects when they appear in a list (in other words, if foo is a whitespace object then (eval '(+ 3 foo 4)) is equivalent to (eval '(+ 3 4))), and if it is asked to evaluate one directly, it is self-evaluating.

Secondly, if several tokens other than whitespace tokens appear on the same line, those tokens are collected into a list and that list is the result of the read.

e.g.,

+ 3 4 5
(+ 3 4 5)
+ 3 4 (+ 1 4)
(+ 3 4 (+ 1 4))

all produce the value 12.

Is it possible to implement this reader as a Lisp read procedure that follows the typical expectations of a read procedure? If so, how? (I'm at a loss.)

Edit: Clarification on whitespace:

If we say that a "whitespace object" is simply a string and read, then reading the following segment:

(foo bar   baz)

produces a syntax object like:

'(foo " " bar "   " baz)

In other words, the whitespace between tokens is stored in the resultant syntax object.

Suppose I write a macro named ->, which takes a syntax object (scheme style macro), and whitespace? is a predicate identifying whitespace syntax objects

(define-macro (-> stx)
  (let* ((stxl (syntax-object->list stx))
         (obj (car stxl))
     (let proc ((res empty))
                (lst (cdr stxl)))
       (let ((method (car lst)))
          (if (whitespace? method)
              ; skip whitespace, recur immediately
              (proc res (cdr lst))
              ; Insert obj as the second element in method
              (let ((modified-method (cons (car method)
                                           (cons obj (cdr method)))))
                ; recur
                (proc (cons res modified-method) (cdr lst))))))))

Answer 1

The reading part of this is pretty easy. You just need a whitespace test, and then your reading function will install a custom reader character macro that detects whitespace and reads consecutive sequences of whitespace into a single object. First, the whitespace test and a whitespace object; these are pretty simple:

(defparameter *whitespace*
  #(#\space #\tab #\return #\newline)
  "A vector of whitespace characters.")

(defun whitespace-p (char)
  "Returns true if CHAR is in *WHITESPACE*."
  (find char *whitespace* :test 'char=))

(defstruct whitespace-object
  characters)

Now the macro character function:

(defun whitespace-macro-char (stream char)
  "A macro character function that consumes characters from
stream (including CHAR), until a non-whitespace character (or end of
file) is encountered.  Returns a whitespace-object whose characters
slot contains a string of the whitespace characters."
  (let ((chars (loop for c = (peek-char nil stream nil #\a)
                  while (whitespace-p c)
                  collect (read-char stream))))
    (make-whitespace-object
     :characters (coerce (list* char chars) 'string))))

Now the read function just has the same signature as the normal read, but copies the readtable, then installs the macro function, and calls read. The result from read is returned, and the readtable is restored:

(defun xread (&optional (stream *standard-input*) (eof-error-p t) eof-value recursive-p)
  "Like READ, but called with *READTABLE* bound to a readtable in
which each whitespace characters (that is, each character in
*WHITESPACE*) is a macro characters whose macro function is
WHITESPACE-MACRO-CHAR."
  (let ((rt (copy-readtable)))
    (map nil (lambda (wchar)
               (set-macro-character wchar #'whitespace-macro-char))
         *whitespace*)
    (unwind-protect (read stream eof-error-p eof-value recursive-p)
      (setf *readtable* rt))))

Example:

(with-input-from-string (in "(+ 1    2  (* 3    
                                         4))")
  (xread in))

(+ #S(WHITESPACE-OBJECT :CHARACTERS " ") 1
   #S(WHITESPACE-OBJECT :CHARACTERS "    ") 2
   #S(WHITESPACE-OBJECT :CHARACTERS "  ")
   (* #S(WHITESPACE-OBJECT :CHARACTERS " ") 3
      #S(WHITESPACE-OBJECT
         :CHARACTERS "  
                                         ")
      4))

Now, to implement the eval counterpart that you want, you need to be able to remove whitespace objects from lists. This isn't too hard, and we can write a slightly more general utility function to do it for us:

(defun remove-element-if (predicate tree)
  "Returns a new tree like TREE, but which contains no elements in an
element position which ssatisfy PREDICATE.  An element is in element
position if it is the car of some cons cell in TREE."
  (if (not (consp tree))
      tree
      (if (funcall predicate (car tree))
          (remove-element-if predicate (cdr tree))
          (cons (remove-element-if predicate (car tree))
                (remove-element-if predicate (cdr tree))))))

CL-USER> (remove-element-if (lambda (x) (and (numberp x) (evenp x))) '(+ 1 2 3 4))
(+ 1 3)

CL-USER> (with-input-from-string (in "(+ 1  2 (* 3
                                                 4))")
           (remove-element-if 'whitespace-object-p (xread in)))
(+ 1 2 (* 3 4))

So now the evaluation function is a simple wrapper around eval:

(defun xeval (form)
  (eval (remove-element-if 'whitespace-object-p form)))

CL-USER> (with-input-from-string (in "(+ 1  2 (* 3
                                                 4))")
           (xeval (xread in)))
15

Let's make sure that standalone whitespace objects still appear as expected:

CL-USER> (with-input-from-string (in "       ")
           (let* ((exp (xread in))
                  (val (xeval exp)))
             (values exp val)))
#S(WHITESPACE-OBJECT :CHARACTERS "       ")
#S(WHITESPACE-OBJECT :CHARACTERS "       ")