1;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2;;;; *************************************************************************
3;;;; FILE IDENTIFICATION
4;;;;
5;;;; Name:          read-macro.lisp
6;;;; Purpose:       Lisp Markup Language functions
7;;;; Programmer:    Kevin M. Rosenberg
8;;;; Date Started:  Aug 2002
9;;;;
10;;;; $Id$
11;;;;
12;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
13;;;;
14;;;; LML users are granted the rights to distribute and use this software
15;;;; as governed by the terms of the GNU General Public License v2
16;;;; (http://www.gnu.org/licenses/gpl.html)
17;;;; *************************************************************************
18
19(in-package #:lml)
20
21
22(set-macro-character #\[
23  #'(lambda (stream char)
24      (declare (ignore char))
25      (let ((forms '())
26            (curr-string (new-string))
27            (paren-level 0)
28            (got-comma nil))
29        (declare (type fixnum paren-level))
30        (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
31            ((eql ch #\]))
32          (if got-comma
33              (if (eql ch #\()
34                  ;; Starting top-level ,(
35                  (progn
36                    #+cmu
37                    (setf curr-string (coerce curr-string `(simple-array character (*))))
38
39                    (push `(lml-princ ,curr-string) forms)
40                    (setq curr-string (new-string))
41                    (setq got-comma nil)
42                    (vector-push #\( curr-string)
43                    (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
44                        ((and (eql ch #\)) (zerop paren-level)))
45                      (when (eql ch #\])
46                        (format *trace-output* "Syntax error reading #\]")
47                        (return nil))
48                      (case ch
49                        (#\(
50                         (incf paren-level))
51                        (#\)
52                         (decf paren-level)))
53                      (vector-push-extend ch curr-string))
54                    (vector-push-extend #\) curr-string)
55                    (let ((eval-string (read-from-string curr-string))
56                          (res (gensym)))
57                      (push
58                       `(let ((,res ,eval-string))
59                          (when ,res
60                            (lml-princ ,res)))
61                       forms))
62                    (setq curr-string (new-string)))
63                ;; read comma, then non #\( char
64                (progn
65                  (unless (eql ch #\,)
66                    (setq got-comma nil))
67                  (vector-push-extend #\, curr-string) ;; push previous command
68                  (vector-push-extend ch curr-string)))
69            ;; previous character is not a comma
70            (if (eql ch #\,)
71                (setq got-comma t)
72              (progn
73                (setq got-comma nil)
74                (vector-push-extend ch curr-string)))))
75
76        #+cmu
77        (setf curr-string (coerce curr-string `(simple-array character (*))))
78
79        (push `(lml-princ ,curr-string) forms)
80        `(progn ,@(nreverse forms)))))
81