1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Lisp Markup Language functions
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Aug 2002
10 ;;;; $Id: base.lisp,v 1.9 2003/02/07 04:31:48 kevin Exp $
12 ;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
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 ;;;; *************************************************************************
19 (declaim (optimize (debug 3) (speed 3) (safety 3) (compilation-speed 0)))
22 (defun html4-prologue-string ()
23 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">")
25 (defun xml-prologue-string ()
26 "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>")
28 (defun xhtml-prologue-string ()
29 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
31 (defvar *print-spaces* nil)
33 (defun reset-indent ()
36 (defun lml-format (str &rest args)
37 (when (streamp *html-output*)
38 (when *print-spaces* (indent-spaces *indent* *html-output*))
40 (apply #'format *html-output* str args)
41 (princ str *html-output*))
42 (when *print-spaces* (format *html-output* "~%"))
46 (princ s *html-output*))
49 (format *html-output* "~A~%" s))
51 (defun lml-write-char (char)
52 (write-char char *html-output))
54 (defun lml-print-date (date)
55 (lml-princ (date-string date)))
57 (defmacro lml-exec-body (&body forms)
65 `(lml-format "~D" ,form))
73 (defmacro with-attr-string (tag attr-string &body body)
74 (let ((attr (gensym)))
75 `(let ((,attr ,attr-string))
76 (lml-format "<~(~A~) ~A>" ',tag
77 (if (and (stringp ,attr) (plusp (length ,attr)))
78 (format nil "~A" ,attr)
81 (lml-exec-body ,@body)
83 (lml-format "</~(~A~)>" ',tag))))
85 (defmacro with-no-endtag-attr-string (tag attr-string)
86 (let ((attr (gensym)))
87 `(let ((,attr ,attr-string))
88 (lml-format "<~(~A~) ~A />" ',tag
89 (if (and (stringp ,attr) (plusp (length ,attr)))
90 (format nil "~A" ,attr)
93 (defun one-keyarg-string (key value)
94 "Return attribute string for keys"
95 (format nil "~(~A~)=\"~A\"" key
98 (string-downcase (symbol-name value)))
104 (defmacro with-keyargs (tag keyargs &body body)
105 (let ((attr (gensym))
109 (dolist (,kv ,keyargs)
111 (push (one-keyarg-string (car ,kv) it) ,attr)))
112 (with-attr-string ,tag (list-to-spaced-string (nreverse ,attr)) ,@body)))))
114 (defmacro with-no-endtag-keyargs (tag keyargs)
115 (let ((attr (gensym))
119 (dolist (,kv ,keyargs)
121 (push (one-keyarg-string (car ,kv) it) ,attr)))
122 (with-no-endtag-attr-string ,tag (list-to-spaced-string (nreverse ,attr)))))))
124 (defmacro bind-one-keyarg (keyarg)
125 `(list ,(car keyarg) ,(cdr keyarg)))
127 (defmacro bind-all-keyargs (keyargs)
128 "Convert a list of keyarg pairs and convert eval/bind arguments"
129 (let* ((npairs (length keyargs))
130 (syms (make-array npairs))
133 (declare (dynamic-extent syms))
135 (setf (aref syms i) (gensym)))
136 `(let ,(mapcar #'(lambda (ka)
138 (list (aref syms ipair) (cdr ka))
141 (list ,@(mapcar #'(lambda (ka)
143 `(cons ,(car ka) ,(aref syms ipair2))
147 (defmacro with (tag &rest args)
148 "Return a list of keyargs and also the body of LML form"
151 (bound-keyargs (gensym)))
152 (do* ((n (length args))
154 (arg (nth i args) (nth i args))
155 (value (when (< (1+ i) n)
159 ((or (not (keyword-symbol? arg))
162 (push (nth (+ i j) args) body)))
163 (push (cons arg value) keyargs))
164 (setq keyargs (nreverse keyargs))
165 (setq body (nreverse body))
166 `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs))))
167 ,(macroexpand `(with-keyargs ,tag ,bound-keyargs ,@body)))))
169 (defmacro with-no-endtag (tag &rest args)
170 "Return a list of keyargs body of LML form"
172 (bound-keyargs (gensym)))
173 (do* ((n (length args))
175 (arg (nth i args) (nth i args))
176 (value (when (< (1+ i) n)
180 ((or (not (keyword-symbol? arg))
182 (push (cons arg value) keyargs))
183 (setq keyargs (nreverse keyargs))
184 `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs))))
185 ,(macroexpand `(with-no-endtag-keyargs ,tag ,bound-keyargs)))))
187 (defmacro xhtml-prologue ()
189 (lml-format "~A~%" (xml-prologue-string))
190 (lml-format "~A~%" (xhtml-prologue-string))))
192 (defmacro alink (dest &body body)
193 `(with a :href ,dest ,@body))
195 (defmacro alink-c (class dest &body body)
196 `(with a :href ,dest :class (quote ,class) ,@body))
198 (defmacro img (dest &rest args)
199 `(with-no-endtag img :src ,dest ,@args))
201 (defmacro input (&rest args)
202 `(with-no-endtag input ,@args))
204 (defmacro meta (name content)
205 `(with meta :name ,name :content ,content))
207 (defmacro meta-key (&key name content http-equiv)
208 `(with meta :name ,name :content ,content :http-equiv ,http-equiv))
210 (defmacro br (&rest args)
211 `(with-no-endtag br ,@args))
213 (defmacro hr (&rest args)
214 `(with-no-endtag hr ,@args))
216 (defmacro lml-tag-macro (tag)
218 (defmacro ,tag (&body body)
219 `(with ,',tag ,@body))
222 (defmacro lml-tag-class-macro (tag)
223 (let ((name (intern (format nil "~A-~A" tag :c))))
225 (defmacro ,name (&body body)
226 `(with ,',tag :class (quote ,(car body)) ,@(cdr body)))
229 (eval-when (:compile-toplevel :load-toplevel :execute)
230 (defparameter *macro-list*
231 '(a div span h1 h2 h3 h4 h5 h6 i b p li ul ol table tbody td th tr body head
232 html title pre tt u dl dt dd kbd code form textarea link))
233 (export '(alink alink-c br hr img input meta meta-key))
234 (export *macro-list*))
236 (loop for i in *macro-list*
238 (eval `(lml-tag-macro ,i))
239 (eval `(lml-tag-class-macro ,i)))
241 (defmacro print-page (title &body body)
247 (defmacro page (out-file &body body)
248 `(with-open-file (*html-output*
249 (lml-file-name ,out-file :output)
251 :if-exists :supersede)
253 (html :xmlns "http://www.w3.org/1999/xhtml"
257 (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))
259 (set-macro-character #\[
260 #'(lambda (stream char)
261 (declare (ignore char))
263 (curr-string (new-string))
266 (declare (type fixnum paren-level))
267 (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
271 ;; Starting top-level ,(
274 (setf curr-string (coerce curr-string `(simple-array character (*))))
276 (push `(lml-princ ,curr-string) forms)
277 (setq curr-string (new-string))
279 (vector-push #\( curr-string)
280 (do ((ch (read-char stream t nil t) (Read-char stream t nil t)))
281 ((and (eql ch #\)) (zerop paren-level)))
283 (format *trace-output* "Syntax error reading #\]")
290 (vector-push-extend ch curr-string))
291 (vector-push-extend #\) curr-string)
292 (let ((eval-string (read-from-string curr-string))
295 `(let ((,res ,eval-string))
299 (setq curr-string (new-string)))
300 ;; read comma, then non #\( char
303 (setq got-comma nil))
304 (vector-push-extend #\, curr-string) ;; push previous command
305 (vector-push-extend ch curr-string)))
306 ;; previous character is not a comma
311 (vector-push-extend ch curr-string)))))
314 (setf curr-string (coerce curr-string `(simple-array character (*))))
316 (push `(lml-princ ,curr-string) forms)
317 `(progn ,@(nreverse forms)))))