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$
  11 ;;;;
  12 ;;;; This file, part of LML2, is Copyright (c) 2000-2003 by Kevin Rosenberg.
  13 ;;;; Rights of modification and redistribution are in the LICENSE file.
  14 ;;;;
  15 ;;;; *************************************************************************
  16
  17 (in-package #:lml2)
  18
  19 (defun new-string ()
  20   (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))
  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 `(lml2-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                             (lml2-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 `(lml2-princ ,curr-string) forms)
  80         `(progn ,@(nreverse forms)))))