X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=2%2Fread-macro.lisp;fp=2%2Fread-macro.lisp;h=16dc05d177108606514388506208fda94794420d;hb=096b456fe920373f3b54fbe47f10f3e41c4fe925;hp=0000000000000000000000000000000000000000;hpb=9191a298494fa0128d7633518d63c566622bee63;p=lml.git

diff --git a/2/read-macro.lisp b/2/read-macro.lisp
new file mode 100644
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)))))