;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          read-macro.lisp
;;;; Purpose:       Lisp Markup Language functions
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Aug 2002
;;;;
;;;; $Id$
;;;;
;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; LML users are granted the rights to distribute and use this software
;;;; as governed by the terms of the GNU General Public License v2
;;;; (http://www.gnu.org/licenses/gpl.html)
;;;; *************************************************************************

(in-package #:lml)


(set-macro-character #\[
  #'(lambda (stream char)
      (declare (ignore char))
      (let ((forms '())
            (curr-string (new-string))
            (paren-level 0)
            (got-comma nil))
        (declare (type fixnum paren-level))
        (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
            ((eql ch #\]))
          (if got-comma
              (if (eql ch #\()
                  ;; Starting top-level ,(
                  (progn
                    #+cmu
                    (setf curr-string (coerce curr-string `(simple-array character (*))))

                    (push `(lml-princ ,curr-string) forms)
                    (setq curr-string (new-string))
                    (setq got-comma nil)
                    (vector-push #\( curr-string)
                    (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
                        ((and (eql ch #\)) (zerop paren-level)))
                      (when (eql ch #\])
                        (format *trace-output* "Syntax error reading #\]")
                        (return nil))
                      (case ch
                        (#\(
                         (incf paren-level))
                        (#\)
                         (decf paren-level)))
                      (vector-push-extend ch curr-string))
                    (vector-push-extend #\) curr-string)
                    (let ((eval-string (read-from-string curr-string))
                          (res (gensym)))
                      (push
                       `(let ((,res ,eval-string))
                          (when ,res
                            (lml-princ ,res)))
                       forms))
                    (setq curr-string (new-string)))
                ;; read comma, then non #\( char
                (progn
                  (unless (eql ch #\,)
                    (setq got-comma nil))
                  (vector-push-extend #\, curr-string) ;; push previous command
                  (vector-push-extend ch curr-string)))
            ;; previous character is not a comma
            (if (eql ch #\,)
                (setq got-comma t)
              (progn
                (setq got-comma nil)
                (vector-push-extend ch curr-string)))))

        #+cmu
        (setf curr-string (coerce curr-string `(simple-array character (*))))

        (push `(lml-princ ,curr-string) forms)
        `(progn ,@(nreverse forms)))))
