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