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.23 2003/06/20 08:35:22 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 ;;;; *************************************************************************
21 (defun html4-prologue-string ()
22 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">")
24 (defun xml-prologue-string ()
25 "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>")
27 (defun xhtml-prologue-string ()
28 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">")
30 (defvar *print-spaces* nil)
32 (defun reset-indent ()
35 (defun lml-format (str &rest args)
36 (when (streamp *html-output*)
37 (when *print-spaces* (indent-spaces *indent* *html-output*))
39 (apply #'format *html-output* str args)
40 (write-string str *html-output*))
41 (when *print-spaces* (write-char #\newline *html-output*))))
44 (princ s *html-output*))
47 (format *html-output* "~A~%" s))
49 (defun lml-write-char (char)
50 (write-char char *html-output*))
52 (defun lml-write-string (str)
53 (write-string str *html-output*))
55 (defun lml-print-date (date)
56 (lml-write-string (date-string date)))
58 (defmacro lml-exec-body (&body forms)
66 `(lml-format "~D" ,form))
74 (defmacro with-attr-string (tag attr-string &body body)
75 (let ((attr (gensym)))
76 `(let ((,attr ,attr-string))
77 (lml-format "<~(~A~)~A>" ',tag
78 (if (and (stringp ,attr) (plusp (length ,attr)))
79 (format nil " ~A" ,attr)
82 (lml-exec-body ,@body)
84 (lml-format "</~(~A~)>" ',tag))))
86 (defmacro with-no-endtag-attr-string (tag attr-string)
87 (let ((attr (gensym)))
88 `(let ((,attr ,attr-string))
89 (lml-format "<~(~A~)~A />" ',tag
90 (if (and (stringp ,attr) (plusp (length ,attr)))
91 (format nil " ~A" ,attr)
94 (defun one-keyarg-string (key value)
95 "Return attribute string for keys"
96 (format nil "~(~A~)=\"~A\"" key
99 (string-downcase (symbol-name value)))
105 (defmacro with-keyargs (tag keyargs &body body)
106 (let ((attr (gensym))
110 (dolist (,kv ,keyargs)
112 (push (one-keyarg-string (car ,kv) it) ,attr)))
113 (with-attr-string ,tag (list-to-spaced-string (nreverse ,attr)) ,@body)))))
115 (defmacro with-no-endtag-keyargs (tag keyargs)
116 (let ((attr (gensym))
120 (dolist (,kv ,keyargs)
122 (push (one-keyarg-string (car ,kv) it) ,attr)))
123 (with-no-endtag-attr-string ,tag (list-to-spaced-string (nreverse ,attr)))))))
125 (defmacro bind-one-keyarg (keyarg)
126 `(list ,(car keyarg) ,(cdr keyarg)))
128 (defmacro bind-all-keyargs (keyargs)
129 "Convert a list of keyarg pairs and convert eval/bind arguments"
130 (let* ((npairs (length keyargs))
131 (syms (make-array npairs))
134 (declare (dynamic-extent syms))
136 (setf (aref syms i) (gensym)))
137 `(let ,(mapcar #'(lambda (ka)
139 (list (aref syms ipair) (cdr ka))
142 (list ,@(mapcar #'(lambda (ka)
144 `(cons ,(car ka) ,(aref syms ipair2))
148 (defmacro with (tag &rest args)
149 "Return a list of keyargs and also the body of LML form"
152 (bound-keyargs (gensym)))
153 (do* ((n (length args))
155 (arg (nth i args) (nth i args))
156 (value (when (< (1+ i) n)
160 ((or (not (keyword-symbol? arg))
163 (push (nth (+ i j) args) body)))
164 (push (cons arg value) keyargs))
165 (setq keyargs (nreverse keyargs))
166 (setq body (nreverse body))
167 `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs))))
168 ,(macroexpand `(with-keyargs ,tag ,bound-keyargs ,@body)))))
170 (defmacro with-no-endtag (tag &rest args)
171 "Return a list of keyargs body of LML form"
173 (bound-keyargs (gensym)))
174 (do* ((n (length args))
176 (arg (nth i args) (nth i args))
177 (value (when (< (1+ i) n)
181 ((or (not (keyword-symbol? arg))
183 (push (cons arg value) keyargs))
184 (setq keyargs (nreverse keyargs))
185 `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs))))
186 ,(macroexpand `(with-no-endtag-keyargs ,tag ,bound-keyargs)))))
188 (defmacro jscript (&body body)
189 `(with script :language "JavaScript" :type "text/javascript"
192 (defmacro xhtml-prologue ()
194 (lml-format "~A~%" (xml-prologue-string))
195 (lml-format "~A~%" (xhtml-prologue-string))))
197 (defmacro alink (dest &body body)
198 `(with a :href ,dest ,@body))
200 (defmacro alink-c (class dest &body body)
201 `(with a :href ,dest :class (quote ,class) ,@body))
203 (defmacro img (dest &rest args)
204 `(with-no-endtag img :src ,dest ,@args))
206 (defmacro input (&rest args)
207 `(with-no-endtag input ,@args))
209 (defmacro link (&rest args)
210 `(with-no-endtag link ,@args))
212 (defmacro meta (&rest args)
213 `(with-no-endtag meta ,@args))
215 (defmacro br (&rest args)
216 `(with-no-endtag br ,@args))
218 (defmacro hr (&rest args)
219 `(with-no-endtag hr ,@args))
221 (defmacro lml-tag-macro (tag)
223 (defmacro ,tag (&body body)
224 `(with ,',tag ,@body))
227 (defmacro lml-tag-class-macro (tag)
228 (let ((name (intern (format nil "~A-~A" tag :c))))
230 (defmacro ,name (&body body)
231 `(with ,',tag :class (quote ,(car body)) ,@(cdr body)))
234 (eval-when (:compile-toplevel :load-toplevel :execute)
235 (defparameter *macro-list*
236 '(a div span h1 h2 h3 h4 h5 h6 i b p li ul ol table tbody td th tr body
237 head html title pre tt u dl dt dd kbd code form textarea blockquote
238 var strong small samp big cite address dfn em q area del ins
239 object param caption col colgroup script noscript))
240 (export '(jscript alink alink-c br hr img input meta link meta-key))
241 (export *macro-list*))
243 (loop for i in *macro-list*
245 (eval `(lml-tag-macro ,i))
246 (eval `(lml-tag-class-macro ,i)))
248 (defmacro print-page (title &body body)
254 (defmacro page (out-file &body body)
255 `(with-open-file (*html-output*
256 (lml-file-name ,out-file :output)
258 :if-exists :supersede)
260 (html :xmlns "http://www.w3.org/1999/xhtml"
264 (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))