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/06/20 04:12:29 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; LML2 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 #:lml2)
  20
  21 (defun new-string ()
  22   (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))
  23
  24 (set-macro-character #\[
  25   #'(lambda (stream char)
  26       (declare (ignore char))
  27       (let ((forms '())
  28             (curr-string (new-string))
  29             (paren-level 0)
  30             (got-comma nil))
  31         (declare (type fixnum paren-level))
  32         (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
  33             ((eql ch #\]))
  34           (if got-comma
  35               (if (eql ch #\()
  36                   ;; Starting top-level ,(
  37                   (progn
  38                     #+cmu
  39                     (setf curr-string (coerce curr-string `(simple-array character (*))))
  40
  41                     (push `(lml2-princ ,curr-string) forms)
  42                     (setq curr-string (new-string))
  43                     (setq got-comma nil)
  44                     (vector-push #\( curr-string)
  45                     (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
  46                         ((and (eql ch #\)) (zerop paren-level)))
  47                       (when (eql ch #\])
  48                         (format *trace-output* "Syntax error reading #\]")
  49                         (return nil))
  50                       (case ch
  51                         (#\(
  52                          (incf paren-level))
  53                         (#\)
  54                          (decf paren-level)))
  55                       (vector-push-extend ch curr-string))
  56                     (vector-push-extend #\) curr-string)
  57                     (let ((eval-string (read-from-string curr-string))
  58                           (res (gensym)))
  59                       (push
  60                        `(let ((,res ,eval-string))
  61                           (when ,res
  62                             (lml2-princ ,res)))
  63                        forms))
  64                     (setq curr-string (new-string)))
  65                 ;; read comma, then non #\( char
  66                 (progn
  67                   (unless (eql ch #\,)
  68                     (setq got-comma nil))
  69                   (vector-push-extend #\, curr-string) ;; push previous command
  70                   (vector-push-extend ch curr-string)))
  71             ;; previous character is not a comma
  72             (if (eql ch #\,)
  73                 (setq got-comma t)
  74               (progn
  75                 (setq got-comma nil)
  76                 (vector-push-extend ch curr-string)))))
  77
  78         #+cmu
  79         (setf curr-string (coerce curr-string `(simple-array character (*))))
  80
  81         (push `(lml2-princ ,curr-string) forms)
  82         `(progn ,@(nreverse forms)))))