read-macro.lisp

   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: read-macro.lisp,v 1.1 2003/04/27 17:53:16 kevin Exp $
  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 (declaim (optimize (debug 3) (speed 3) (safety 3) (compilation-speed 0)))
  20 (in-package :lml)
  21
  22
  23 (set-macro-character #\[
  24   #'(lambda (stream char)
  25       (declare (ignore char))
  26       (let ((forms '())
  27             (curr-string (new-string))
  28             (paren-level 0)
  29             (got-comma nil))
  30         (declare (type fixnum paren-level))
  31         (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
  32             ((eql ch #\]))
  33           (if got-comma
  34               (if (eql ch #\()
  35                   ;; Starting top-level ,(
  36                   (progn
  37                     #+cmu
  38                     (setf curr-string (coerce curr-string `(simple-array character (*))))
  39
  40                     (push `(lml-princ ,curr-string) forms)
  41                     (setq curr-string (new-string))
  42                     (setq got-comma nil)
  43                     (vector-push #\( curr-string)
  44                     (do ((ch (read-char stream t nil t) (Read-char stream t nil t)))
  45                         ((and (eql ch #\)) (zerop paren-level)))
  46                       (when (eql ch #\])
  47                         (format *trace-output* "Syntax error reading #\]")
  48                         (return nil))
  49                       (case ch
  50                         (#\(
  51                          (incf paren-level))
  52                         (#\)
  53                          (decf paren-level)))
  54                       (vector-push-extend ch curr-string))
  55                     (vector-push-extend #\) curr-string)
  56                     (let ((eval-string (read-from-string curr-string))
  57                           (res (gensym)))
  58                       (push
  59                        `(let ((,res ,eval-string))
  60                           (when ,res
  61                             (lml-princ ,res)))
  62                        forms))
  63                     (setq curr-string (new-string)))
  64                 ;; read comma, then non #\( char
  65                 (progn
  66                   (unless (eql ch #\,)
  67                     (setq got-comma nil))
  68                   (vector-push-extend #\, curr-string) ;; push previous command
  69                   (vector-push-extend ch curr-string)))
  70             ;; previous character is not a comma
  71             (if (eql ch #\,)
  72                 (setq got-comma t)
  73               (progn
  74                 (setq got-comma nil)
  75                 (vector-push-extend ch curr-string)))))
  76
  77         #+cmu
  78         (setf curr-string (coerce curr-string `(simple-array character (*))))
  79
  80         (push `(lml-princ ,curr-string) forms)
  81         `(progn ,@(nreverse forms)))))