Commit 80bcd19e authored by Marco Baringer's avatar Marco Baringer

Inital Import

parents
# CVS default ignores begin
tags
TAGS
.make.state
.nse_depinfo
*~
#*
.#*
,*
_$*
*$
*.old
*.bak
*.BAK
*.orig
*.rej
.del-*
*.a
*.olb
*.o
*.obj
*.so
*.exe
*.Z
*.elc
*.ln
core
# CVS default ignores end
;;;; -*- lisp -*-
;;;_* File Info
;;;; $Id: yaclml.lisp,v 1.6 2003/08/16 15:39:03 mb Exp $
;;;;
;;;; Copyright (c) 2002-2003, Edward Marco Baringer
;;;; All rights reserved.
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions are
;;;; met:
;;;;
;;;; - Redistributions of source code must retain the above copyright
;;;; notice, this list of conditions and the following disclaimer.
;;;;
;;;; - Redistributions in binary form must reproduce the above copyright
;;;; notice, this list of conditions and the following disclaimer in the
;;;; documentation and/or other materials provided with the distribution.
;;;;
;;;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
;;;; of its contributors may be used to endorse or promote products
;;;; derived from this software without specific prior written permission.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :it.bese.yaclml)
;;;_* Various Variables for generating HTML
(defvar *html-prologue* "<!DOCTYPE html
PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"
\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">")
;;;_* Helper code for generating HTML tags
(defmacro defhtml-tag (name-sym inline &rest attributes)
(let (attrs)
(loop for attr in attributes
do (case attr
(:coreattrs
(push* attrs 'id 'class 'style 'title))
(:events
(push* attrs 'onclick 'ondblclick 'onmousedown 'onmouseup
'onmouseover 'onmousemove 'onmouseout 'onkeypress
'onkeydown 'onkeyup))
(:i18n
(push* attrs 'dir 'lang))
(t
(push* attrs attr))))
`(defsimple-xtag ,name-sym ,(eql inline :block) ,@attrs)))
;;;_* HTML tags
(defhtml-tag <:A :inline :coreattrs :events href name rev ref target)
(defhtml-tag <:ABBREV :inline :coreattrs)
(defhtml-tag <:ACRONYM :inline :coreattrs)
(defhtml-tag <:ADDRESS :inline :coreattrs)
(defhtml-tag <:APPLET :block :coreattrs
codebase code name align alt
height width hspace vspace download)
(defhtml-tag <:AREA :block :coreattrs shape alt co-ords href target)
(defhtml-tag <:B :inline :coreattrs)
(defhtml-tag <:BASE :block :coreattrs href target)
(defhtml-tag <:BASEFONT :block :coreattrs size face color)
(defhtml-tag <:BGSOUND :coreattrs src loop volume balance)
(defhtml-tag <:BIG :coreattrs)
(defhtml-tag <:BLINK :coreattrs)
(defhtml-tag <:BLOCKQUOTE :coreattrs cite)
(defhtml-tag <:BODY :block :coreattrs bgcolor link vlink alink text
background bgproperties topmargin leftmargin
rightmargin bottommargin marginwidth marginheight)
(defhtml-tag <:BR :coreattrs clear)
(defhtml-tag <:CAPTION :coreattrs align valign)
(defhtml-tag <:CENTER :coreattrs)
(defhtml-tag <:CITE :coreattrs)
(defhtml-tag <:CODE :coreattrs)
(defhtml-tag <:COL :coreattrs span width align valign bgcolor)
(defhtml-tag <:COLGROUP :coreattrs span width align valign bgcolor)
(defhtml-tag <:DEL :coreattrs datetime cite)
(defhtml-tag <:DFN :coreattrs)
(defhtml-tag <:DIR :coreattrs)
(defhtml-tag <:DIV :coreattrs align)
(defhtml-tag <:DL :coreattrs)
(defhtml-tag <:DT :coreattrs)
(defhtml-tag <:DD :coreattrs)
(defhtml-tag <:EM :coreattrs)
(defhtml-tag <:EMBED :coreattrs src pluginspace width height align
type)
(defhtml-tag <:FONT :coreattrs size face color point-size weight)
(defhtml-tag <:FORM :coreattrs action target method enctype name
accept accept-charset)
(defhtml-tag <:FRAME :coreattrs src name scrolling norize width
height marginwidth marginheight frameborder
bordercolor)
(defhtml-tag <:FRAMESET :coreattrs cols rows border framespacing
frameborder bordercolor)
(defhtml-tag <:H1 :inline :coreattrs align)
(defhtml-tag <:H2 :inline :coreattrs align)
(defhtml-tag <:H3 :inline :coreattrs align)
(defhtml-tag <:H4 :inline :coreattrs align)
(defhtml-tag <:H5 :inline :coreattrs align)
(defhtml-tag <:H6 :inline :coreattrs align)
(defhtml-tag <:HEAD :block :coreattrs profile)
(defhtml-tag <:HR :block :coreattrs align size width color)
(defhtml-tag <:HTML :block :coreattrs lang)
(defhtml-tag <:I :coreattrs)
(defhtml-tag <:IFRAME :coreattrs src width height hspace vspace
align name scrolling warginwidth warginheight
frameborder bgcolor)
(defhtml-tag <:IMG :coreattrs src width height hspace vspace
border alt align usemap ismap lowsrc dynsrc loop
longdesc)
(defhtml-tag <:INPUT :coreattrs name value type size maxlength
checked accept src align width height border alt
usemap ismap)
(defhtml-tag <:INS :coreattrs datetime cite)
(defhtml-tag <:ISINDEX :coreattrs)
(defhtml-tag <:KBD :coreattrs)
(defhtml-tag <:LANG :coreattrs)
(defhtml-tag <:LH :coreattrs)
(defhtml-tag <:LI :coreattrs type value)
(defhtml-tag <:LINK :coreattrs rel type ref rev target charset media)
(defhtml-tag <:LISTING :coreattrs)
(defhtml-tag <:MAP :coreattrs name)
(defhtml-tag <:MARQUEE :coreattrs width height hspace vspace
scrollAmount scrollDelay truespeed loop behavior
direction bgcolor)
(defhtml-tag <:MATH :coreattrs)
(defhtml-tag <:MENU :coreattrs)
(defhtml-tag <:META :coreattrs name content http-equiv scheme)
(defhtml-tag <:MULTICOL :coreattrs cols gutter width)
(defhtml-tag <:NOBR :coreattrs)
(defhtml-tag <:NOEMBED :coreattrs)
(defhtml-tag <:NOFRAMES :coreattrs)
(defhtml-tag <:NOLAYER :coreattrs)
(defhtml-tag <:NOSCRIPT :coreattrs)
(defhtml-tag <:NOTE :coreattrs)
(defhtml-tag <:OL :coreattrs type start)
(defhtml-tag <:OBJECT :coreattrs classid codebase code type data
width height hspace vspace align)
(defhtml-tag <:OVERLAY :coreattrs)
(defhtml-tag <:OPTION :coreattrs value selected)
(defhtml-tag <:P :block :coreattrs align)
(defhtml-tag <:PARAM :coreattrs valuetype name value)
(defhtml-tag <:PLAINTEXT :coreattrs)
(defhtml-tag <:PRE :coreattrs)
(defhtml-tag <:Q :coreattrs)
(defhtml-tag <:RANGE :coreattrs)
(defhtml-tag <:S :coreattrs)
(defhtml-tag <:SAMP :coreattrs)
(defhtml-tag <:SCRIPT :coreattrs language type src for event defer
charset)
(defhtml-tag <:SELECT :coreattrs name size multiple)
(defhtml-tag <:SMALL :coreattrs)
(defhtml-tag <:SPACER :coreattrs type size width height)
(defhtml-tag <:SPAN :coreattrs)
(defhtml-tag <:STRIKE :coreattrs)
(defhtml-tag <:STRONG :coreattrs)
(defhtml-tag <:STYLE :coreattrs media type)
(defhtml-tag <:SUB :coreattrs)
(defhtml-tag <:SUP :coreattrs)
(defhtml-tag <:TAB :coreattrs)
(defhtml-tag <:TABLE :coreattrs border cellspacing cellpadding
bgcolor background bordercolor bordercolorlight
bordercolordark width height hspace vspace align cols
frame rules summary)
(defhtml-tag <:TBODY :coreattrs align valign bgcolor)
(defhtml-tag <:TD :coreattrs align valign bgcolor background
bordercolor colspan rowspan width height headers scope
abbr axis)
(defhtml-tag <:TEXTAREA :coreattrs cols rows readonly wrap name)
(defhtml-tag <:TEXTFLOW :coreattrs)
(defhtml-tag <:TFOOT :coreattrs)
(defhtml-tag <:TH :coreattrs)
(defhtml-tag <:THEAD :coreattrs)
(defhtml-tag <:TITLE :coreattrs)
(defhtml-tag <:TR :coreattrs align valign width height bgcolor
bordercolor)
(defhtml-tag <:TT :coreattrs)
(defhtml-tag <:U :coreattrs)
(defhtml-tag <:UL :coreattrs type)
;;;; -*- lisp -*-
;;;; $Id: packages.lisp,v 1.6 2003/08/13 21:53:46 mb Exp $
;;;;
;;;; Copyright (c) 2002-2003, Edward Marco Baringer
;;;; All rights reserved.
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions are
;;;; met:
;;;;
;;;; - Redistributions of source code must retain the above copyright
;;;; notice, this list of conditions and the following disclaimer.
;;;;
;;;; - Redistributions in binary form must reproduce the above copyright
;;;; notice, this list of conditions and the following disclaimer in the
;;;; documentation and/or other materials provided with the distribution.
;;;;
;;;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
;;;; of its contributors may be used to endorse or promote products
;;;; derived from this software without specific prior written permission.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :common-lisp-user)
(defpackage :it.bese.yaclml
(:use :common-lisp :it.bese.arnesi)
(:export #:process-yaclml-file
#:*yaclml-stream*
#:yaclml-to-file))
(defpackage :it.bese.yaclml.tags
(:nicknames :<)
(:use)
(:export #:a
#:abbrev
#:acronym
#:address
#:applet
#:area
#:author
#:b
#:banner
#:base
#:basefont
#:bgsound
#:big
#:blink
#:blockquote
#:bq
#:body
#:br
#:caption
#:center
#:cite
#:code
#:col
#:colgroup
#:credit
#:del
#:dfn
#:dir
#:div
#:dl
#:dt
#:dd
#:em
#:embed
#:fig
#:fn
#:font
#:form
#:frame
#:frameset
#:h1
#:h2
#:h3
#:h4
#:h5
#:h6
#:head
#:hr
#:html
#:i
#:iframe
#:img
#:input
#:ins
#:isindex
#:kbd
#:lang
#:lh
#:li
#:link
#:listing
#:map
#:marquee
#:math
#:menu
#:meta
#:multicol
#:nobr
#:noembed
#:noframes
#:nolayer
#:noscript
#:note
#:object
#:ol
#:option
#:overlay
#:p
#:param
#:person
#:plaintext
#:pre
#:q
#:range
#:s
#:samp
#:script
#:select
#:small
#:spacer
#:span
#:spot
#:strike
#:strong
#:style
#:sub
#:sup
#:tab
#:table
#:tbody
#:td
#:textarea
#:textflow
#:tfoot
#:th
#:thead
#:title
#:tr
#:tt
#:u
#:ul
#:text
#:submit
#:image
#:checkbox
#:href
#:stylesheet
#:prin
#:as-is
#:page
#:section
#:itemize
;; usefull stuff for writing lisp code (requires a good style sheet)
#:syntax
#:description
#:examples
#:see-also
#:arguments-and-values
#:notes
#:defun
#:defmacro
#:defclass
#:defstruct
#:define-condition
#:defmethod
#:defgeneric))
;;;; -*- lisp -*-
;;;; $Id: yaclml.lisp,v 1.6 2003/08/16 15:39:03 mb Exp $
;;;;
;;;; Copyright (c) 2002-2003, Edward Marco Baringer
;;;; All rights reserved.
;;;;
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions are
;;;; met:
;;;;
;;;; - Redistributions of source code must retain the above copyright
;;;; notice, this list of conditions and the following disclaimer.
;;;;
;;;; - Redistributions in binary form must reproduce the above copyright
;;;; notice, this list of conditions and the following disclaimer in the
;;;; documentation and/or other materials provided with the distribution.
;;;;
;;;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
;;;; of its contributors may be used to endorse or promote products
;;;; derived from this software without specific prior written permission.
;;;;
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :it.bese.yaclml)
(defvar *yaclml-stream* t)
(defmacro with-yaclml-stream ((stream &key &allow-other-keys) &body body)
`(let ((*yaclml-stream* ,stream))
(declare (special *yaclml-stream*))
,@body))
(defvar *yaclml-indent* 0)
(defvar *yaclml-tags* (make-hash-table :test 'eql))
(defun yaclml-princ (item)
"Request that the result of the form ITEM be printed at run item."
(declare (special tag-code %indent%))
(if (constantp item)
(push (princ-to-string item) tag-code)
(push `(princ ,item *yaclml-stream*) tag-code)))
(defun yaclml-collect (form)
"Request that CODE be part of the tag's code."
(declare (special tag-code))
(push form tag-code))
(defun yaclml-princ-attributes (attributes)
(let ((constants '())
(runtime '()))
;; we move the attributes around in order to get the longest constant sequence we can
(dolist (attr attributes)
(when (cdr attr) ;; this implies that passed attributes with a nil value are not printed
(if (constantp (cdr attr))
(push attr constants)
(push attr runtime))))
(dolist (attr (append constants runtime))
(yaclml-princ " ")
(yaclml-princ (car attr))
(unless (eql t (cdr attr))
(yaclml-princ "=\"")
(yaclml-princ (cdr attr))
(yaclml-princ "\"")))))
(defun open-tag (name indentp &rest attributes)
"Used within a DEFTAG makes the proper calls to YACLML-PRINC and
YACLML-COLLECT such that an open tag will be printed when the code
is finally run."
(declare (special %indent%))
(when indentp
(yaclml-princ #\Newline)
(yaclml-princ (make-string %indent% :initial-element #\Space))
(incf %indent%))
(yaclml-princ "<")
(yaclml-princ name)
(yaclml-princ-attributes attributes)
(yaclml-princ ">"))
(defun close-tag (name indentp)
(declare (special %indent%))
(when indentp
(decf %indent%)
(yaclml-princ #\Newline)
(yaclml-princ (make-string %indent% :initial-element #\Space)))
(yaclml-princ "</")
(yaclml-princ name)
(yaclml-princ ">"))
(defun empty-tag (name indentp &rest attributes)
(declare (special %indent%))
(when indentp
(yaclml-princ (make-string %indent% :initial-element #\Space)))
(yaclml-princ "<")
(yaclml-princ name)
(yaclml-princ-attributes attributes)
(yaclml-princ "/>"))
(defun yaclml-do-body (body)
(dolist (form body)
(cond
((and (consp form)
(gethash (car form) *yaclml-tags*))
(funcall (gethash (car form) *yaclml-tags*) (cdr form)))
((and (consp form)
(eql 'yaclml-quote (car form)))
(dolist (b (cdr form))
(yaclml-do-body (list b))))
((or (stringp form)
(characterp form))
(yaclml-princ form))
(t
(yaclml-collect form)))))
(defmacro deftag (name attributes &body body)
(let ((contents (gensym)))
`(progn
(setf (gethash ',name *yaclml-tags*)
(lambda (,contents)
(attribute-bind ,attributes ,contents
,@body)))
(defmacro ,name (&rest contents)
(let ((tag-code nil))
(declare (special tag-code %indent%))
;; build tag's body
(if (boundp '%indent%)
(funcall (gethash ',name *yaclml-tags*) contents)
(let ((%indent% 0))
(declare (special %indent%))
(funcall (gethash ',name *yaclml-tags*) contents)))
(setf tag-code (nreverse tag-code))
`(progn ,@(mapcar (lambda (form)
(if (stringp form)
`(princ ,form *yaclml-stream*)
form))
(fold-strings tag-code))))))))
(defmacro defsimple-xtag (name indentp &rest attributes)
(let ((name-string (string-downcase (string name))))
`(deftag ,name (&attribute ,@attributes &body body)
(if body
(progn
(open-tag ,name-string ,indentp
,@(mapcar (lambda (attr-symbol)
`(cons ,(string-downcase (string attr-symbol))
,attr-symbol))
attributes))
(yaclml-do-body body)
(close-tag ,name-string ,indentp))
(empty-tag ,name-string ,indentp ,@(mapcar (lambda (attr-symbol)
`(cons ,(string-downcase (string attr-symbol))
,attr-symbol))
attributes))))))
(defun parse-attribute-spec (attribute-spec)
(let* ((required '())
(attrs '())
(flags '())
(body-var (gensym))
(put (lambda (item)
(push item required))))
(dolist (attr attribute-spec)
(case attr
(&attribute (setf put (lambda (item)
(if (listp item)
(case (length item)
(1 (push (list (car item) nil) attrs))
(2 (push item attrs))
(t
(error "Bad &attribute spec: ~S" item)))
(push (list item nil) attrs)))))
(&flag (setf put (lambda (item)
(push item flags))))
(&body (setf put (lambda (item)
(setf body-var item))))
(t (funcall put attr))))
(list (nreverse required) (nreverse attrs) (nreverse flags) body-var)))
(defmacro attribute-bind (attribute-spec list &body body)
"Attributes can contain &attribute, &flag and &body."
(destructuring-bind (locals attrs flags body-var)
(parse-attribute-spec attribute-spec)
(let ((list-sym (gensym))
(element-sym (gensym)))
`(let ,(append locals attrs flags (list body-var) (list (list list-sym list)))
(declare (ignorable ,body-var))
,@(loop
for local in locals
collect `(setf ,local (pop ,list-sym)))
(while (and (consp ,list-sym)
(keywordp (car ,list-sym)))
(case-bind ,element-sym (pop ,list-sym)
,@(loop
for attr in attrs
collect `(,(intern (string (car attr)) :keyword) (setf ,(car attr) (pop ,list-sym))))
,@(loop
for flag in flags
collect `(,(intern (string flag) :keyword) (setf ,flag t)))
(t
(error "Unrecognized attribute ~S in ~S" ,element-sym ,list-sym))))
(setf ,body-var ,list-sym)
,@(if (and (consp body)
(consp (car body))
(eql 'declare (car (car body))))
`((locally ,@body))
body)))))
(defun |[ reader| (stream char)
(declare (ignore char))
(with-collector (forms)
(loop
for char = (read-char stream t nil t)
do (case char
(#\\ (forms `(yaclml-print ,(read-char stream t nil t))))
(#\] (return-from |[ reader| `(yaclml-quote ,@(forms))))
(#\, (forms (read stream t nil t)))
(t (forms char))))))
(let ((readers '()))
(defun enable-yaclml-sytax ()
(push (get-macro-character #\[) readers)
(set-macro-character #\[ #'|[ reader|))
(defun disable-yaclml-syntax ()
(unless readers
(error "Can't disable yaclml syntax if it hasn't been enabled."))
(set-macro-character #\[ (pop readers))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment