/[defdoc]/DefDoc/src/frontends/basic/engine.lisp
ViewVC logotype

Contents of /DefDoc/src/frontends/basic/engine.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Sun Feb 15 05:01:45 2004 UTC (10 years, 2 months ago) by rjain
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +1 -1 lines
additions and tweaks for the defdoc-generated defdoc website:
elements that are abbreviations for more complex sequences of elements
hyperlink document element
small-caps style element
subtitle in documents
1 (in-package :defdoc.frontends.basic)
2
3 (defvar *documents* (make-hash-table :test 'eq))
4
5 (defun quote-keynames (arglist)
6 (loop
7 for (name val) on arglist by #'cddr
8 collect `',name
9 collect val))
10
11 (defun make-contents-form (contents)
12 (if (every (lambda (item) (typep item '(or string character))) contents)
13 (apply 'concatenate 'string contents)
14 `(list ,@(mapcar (lambda (item)
15 (if (or (stringp item) (characterp item))
16 item
17 `(doc ,@item)))
18 contents))))
19
20 (defmacro doc (type &optional initargs &body body)
21 (let ((initargs (quote-keynames initargs)))
22 `(make-instance ',type
23 'contents ,(make-contents-form body)
24 ,@initargs)))
25
26 (defmacro defdoc (name (&optional (type 'document) &rest initargs) &body body)
27 (let ((initargs (quote-keynames initargs)))
28 `(setf (gethash ',name *documents*)
29 (make-instance ',type
30 'contents ,(make-contents-form body)
31 ,@initargs))))
32
33 (defun undefdoc (name)
34 (remhash name *documents*))
35
36 (defun find-doc (name)
37 (gethash name *documents*))
38
39 (defun convert-doc (name target-type &rest other-initargs)
40 (convert (find-doc name)
41 (apply #'make-instance target-type other-initargs)))
42
43 (defmacro pprint-doc-body ()
44 '(progn
45 (pprint-indent :block 1)
46 (loop
47 (pprint-exit-if-list-exhausted)
48 (write-char #\space)
49 (pprint-newline :linear)
50 (pprint-doc-element *standard-output* (pprint-pop)))))
51
52 (defmacro pprint-doc-initargs ()
53 '(progn
54 (pprint-exit-if-list-exhausted)
55 (loop
56 (write (pprint-pop)) ; key
57 (write-char #\space)
58 (pprint-newline :miser)
59 (write (pprint-pop)) ; val
60 (pprint-exit-if-list-exhausted)
61 (write-char #\space)
62 (pprint-newline :fill))))
63
64 (set-pprint-dispatch
65 '(cons (member defdoc))
66 (lambda (*standard-output* obj)
67 (pprint-logical-block (*standard-output* obj :prefix "(" :suffix ")")
68 (write (pprint-pop)) ; defdoc
69 (write-char #\space)
70 (pprint-newline :miser)
71 (pprint-indent :current 0)
72 (write (pprint-pop)) ; name
73 (write-char #\space)
74 (pprint-newline :fill)
75 (pprint-logical-block (*standard-output*
76 (pprint-pop) :prefix "(" :suffix ")")
77 (pprint-exit-if-list-exhausted)
78 (write (pprint-pop)) ; type
79 (write-char #\space)
80 (pprint-newline :linear)
81 (pprint-indent :current 0)
82 (pprint-doc-initargs))
83 (pprint-doc-body))))
84
85 (defun pprint-doc-element (*standard-output* obj)
86 (pprint-logical-block (*standard-output* obj :prefix "(" :suffix ")")
87 (pprint-indent :block 3)
88 (write (pprint-pop)) ; type
89 (write-char #\space)
90 (pprint-newline :fill)
91 (pprint-logical-block (*standard-output* (pprint-pop) :prefix "(" :suffix ")")
92 (pprint-doc-initargs))
93 (pprint-indent :block 1)
94 (pprint-doc-body)))
95
96 (set-pprint-dispatch
97 '(cons (member doc))
98 (lambda (*standard-output* obj)
99 (pprint-logical-block (*standard-output*
100 obj :prefix "(" :suffix ")")
101 (write (pprint-pop)) ; doc
102 (write-char #\space)
103 (pprint-newline :miser)
104 (pprint-indent :current 0)
105 (write (pprint-pop)) ; type
106 (write-char #\space)
107 (pprint-newline :fill)
108 (pprint-logical-block (*standard-output* (pprint-pop) :prefix "(" :suffix ")")
109 (pprint-doc-initargs))
110 (pprint-indent :block 1)
111 (pprint-doc-body))))

  ViewVC Help
Powered by ViewVC 1.1.5