r5163: *** empty log message ***

[lml.git] / 2 / read-macro.lisp

diff --git a/2/read-macro.lisp b/2/read-macro.lisp
new file mode 100644 (file)
index 0000000..16dc05d
--- /dev/null
+++ b/2/read-macro.lisp
@@ -0,0 +1,82 @@
+;;; -*- 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/06/20 04:12:29 kevin Exp $
+;;;;
+;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; LML2 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 #:lml2)
+
+(defun new-string ()
+  (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))
+
+(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 `(lml2-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
+                           (lml2-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 `(lml2-princ ,curr-string) forms)
+       `(progn ,@(nreverse forms)))))