--- /dev/null
+;;; -*- 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: read-macro.lisp,v 1.1 2003/04/27 17:53:16 kevin Exp $
+;;;;
+;;;; 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)
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 3) (compilation-speed 0)))
+(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)))))