X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=lml.cl;h=c3542bb423a88a28dc3ee5d481484b80a138f826;hb=086d8ddd1fd16532a59740c9cd0843970339632f;hp=1e7aececbccd16ccc31ea76f38186cdeae19617b;hpb=167347087d99a14adaa49b8454b1279cccab4897;p=lml.git diff --git a/lml.cl b/lml.cl index 1e7aece..c3542bb 100644 --- a/lml.cl +++ b/lml.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: lml.cl,v 1.2 2002/09/16 06:26:27 kevin Exp $ +;;;; $Id: lml.cl,v 1.13 2002/09/16 10:18:19 kevin Exp $ ;;;; ;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -19,17 +19,14 @@ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :lml) -(defconstant +html4-prologue-string+ - (format nil - "~%")) +(defun html4-prologue-string () + "") -(defconstant +xml-prologue-string+ - (format nil - "~%")) +(defun xml-prologue-string () + "") -(defconstant +xhtml-prologue-string+ - (format nil - "~%")) +(defun xhtml-prologue-string () + "") (defvar *print-spaces* nil) (defvar *indent* 0) @@ -130,8 +127,8 @@ (defmacro xhtml-prologue () `(progn - (lml-print +xml-prologue-string+) - (lml-print +xhtml-prologue-string+))) + (lml-print "~A~%" (xml-prologue-string)) + (lml-print "~A~%" (xhtml-prologue-string)))) (defmacro link (dest &body body) `(with a :href ,dest ,@body)) @@ -203,3 +200,60 @@ (xhtml-prologue) (html :xmlns "http://www.w3.org/1999/xhtml" ,@body))) + +(defun new-string () + (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character)) + +(set-macro-character #\[ + #'(lambda (stream char) + (declare (ignore char)) + (let ((forms '()) + (curr-string (new-string)) + (paren-level 0) + (got-comma nil)) + (do ((ch (read-char stream t nil t) (read-char stream t nil t))) + ((eql ch #\])) + (if got-comma + (if (eql ch #\() + ;; Starting top-level ,( + (progn + (push `(lml-print ,curr-string) forms) + (setq curr-string (new-string)) + (setq got-comma nil) + (vector-push #\( curr-string) + (do ((ch (read-char stream t nil t) (Read-char stream t nil t))) + ((and (eql ch #\)) (zerop paren-level))) + (when (eql ch #\]) + (format *trace-output* "Syntax error reading #\]") + (return nil)) + (case ch + (#\( + (incf paren-level)) + (#\) + (decf paren-level))) + (vector-push-extend ch curr-string)) + (vector-push-extend #\) curr-string) + (let ((eval-string (read-from-string curr-string)) + (res (gensym))) + (push + `(let ((,res ,eval-string)) + (when ,res + (lml-print ,res))) + forms)) + (setq curr-string (new-string))) + ;; read comma, then non #\( char + (progn + (unless (eql ch #\,) + (setq got-comma nil)) + (vector-push-extend #\, curr-string) ;; push previous command + (vector-push-extend ch curr-string))) + ;; previous character is not a comma + (if (eql ch #\,) + (setq got-comma t) + (progn + (setq got-comma nil) + (vector-push-extend ch curr-string))))) + (push `(lml-print ,curr-string) forms) + `(progn ,@(nreverse forms))))) + +