From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Sun, 27 Apr 2003 17:53:16 +0000 (+0000)
Subject: r4656: *** empty log message ***
X-Git-Tag: v2.5.5~97
X-Git-Url: http://git.kpe.io/?p=lml.git;a=commitdiff_plain;h=4702caa93dd3157528b62c3befc5f86fdfb7ec5c;hp=17f82ef6c56d393c9a63d42c4659928432545666

r4656: *** empty log message ***
---

diff --git a/read-macro.lisp b/read-macro.lisp
new file mode 100644
index 0000000..4ce43d2
--- /dev/null
+++ b/read-macro.lisp
@@ -0,0 +1,81 @@
+;;; -*- 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)))))