1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
|
(in-package #:cl-markdown)
(defmacro defsimple-extension (name &body body)
"Create an extension (a function named `name`) with no arguments that
does not depend on the markdown phase and which does not use the result.
These are handy for simple text substitutions."
(with-gensyms (phase arguments result)
`(progn
(pushnew (list ',name t) *extensions* :key #'car)
(defun ,name (,phase ,arguments ,result)
(declare (ignore ,phase ,arguments ,result))
,@body)
,@(%import/export-symbol name))))
(defun %validate-defextension-arguments (arguments)
(loop for argument in (ensure-list arguments) do
(cond ((atom argument)
(when (eq (symbol-package argument) #.(find-package :keyword))
(error "Argument names may not be keywords and ~s is not"
argument)))
(t
(unless (every (lambda (facet)
(member facet '(:required :keyword :whole)))
(rest argument))
(error "Invalid argument facets in ~s" (rest argument)))))))
(defun %collect-arguments (arguments kind)
(loop for argument in (ensure-list arguments)
when (and (consp argument)
(member kind (rest argument))) collect
(first argument)))
(defun %collect-positionals (arguments)
(loop for argument in (ensure-list arguments)
when (or (atom argument)
(and (consp argument)
(not (member :keyword (rest argument))))) collect
(first (ensure-list argument))))
(defparameter *extensions* nil)
(defmacro defextension ((name &key arguments (insertp nil) (exportp t))
&body body)
(%validate-defextension-arguments arguments)
(bind ((keywords (%collect-arguments arguments :keyword))
(requires (%collect-arguments arguments :required))
(whole (%collect-arguments arguments :whole))
(positionals (%collect-positionals arguments)))
(assert (<= (length whole) 1)
nil "At most one :whole argument is allowed.")
(assert (null (intersection whole keywords))
nil "Keyword arguments cannot be wholes")
`(progn
(setf *extensions* (remove ',name *extensions* :key #'first))
(push (list ',name ,insertp) *extensions*)
(defun ,name (phase args result)
(declare (ignorable phase args result))
(bind (,@(loop for positional in positionals
unless (member positional whole) collect
`(,positional (pop args)))
,@(loop for keyword in keywords collect
`(,keyword
(getf args ,(intern (symbol-name keyword) :keyword)
nil)))
,@(when whole
`((,(first whole)
;; remove keywords from args
(progn
,@(loop for keyword in keywords collect
`(,keyword
(remf args
,(intern (symbol-name keyword) :keyword))))
(if (length-1-list-p args) (first args) args))))))
,@(loop for require in requires collect
`(assert ,require nil ,(format nil "~s is required" require)))
,@body
,@(unless insertp nil)))
,@(when exportp
(%import/export-symbol name)))))
(defun %import/export-symbol (name)
`((eval-when (:compile-toplevel :load-toplevel :execute)
(import ',name ,(find-package :cl-markdown-user))
(export ',name ,(find-package :cl-markdown-user)))))
(defmacro aand+ (&rest args)
"Anaphoric nested AND.
Binds the symbol `it' to the value of the preceding `arg.'"
(cond ((null args) t)
((null (cdr args)) (car args))
(t `(aif ,(car args) (aand ,@(cdr args))))))
|
