/usr/share/common-lisp/source/metabang-bind/dev/macros.lisp is in cl-metabang-bind 20141106-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 | (in-package #:metabang.bind)
#|
use
(defmethod documentation (object doc-type)
body...)
instead
(documentation :plist 'binding-form)
|#
(defmethod documentation (what (doc-type (eql 'metabang.bind:binding-form)))
(binding-form-docstring what))
(defun binding-form-docstring (name)
"Returns the docstring for a binding form named `name`."
(let* ((docstrings (get 'bind :docstrings))
(forms (get 'bind :binding-forms))
(canonical-name (first (assoc name forms)))
)
(and canonical-name
(assoc canonical-name docstrings))))
(defun (setf binding-form-docstring) (docstring name/s)
(when (atom name/s)
(setf name/s (list name/s)))
(let* ((docstrings (get 'bind :docstrings))
(forms (get 'bind :binding-forms))
(canonical-name (first name/s))
(current-docstring-pair (assoc canonical-name docstrings)))
(loop for name in name/s do
(let ((names-pair (assoc name forms)))
(if names-pair
(setf (cdr names-pair) name/s)
(push (cons name name/s) forms))))
(if current-docstring-pair
(setf (cdr current-docstring-pair) docstring)
(push (cons canonical-name docstring) docstrings))
(setf (get 'bind :docstrings) docstrings)
(setf (get 'bind :binding-forms) forms)
docstring))
(defmacro defbinding-form ((name/s &key docstring remove-nils-p
description (use-values-p t)
(accept-multiple-forms-p nil)) &body body)
"Describe how `bind` should expand particular binding-forms.
`defbinding-form` links a name or type with an expansion. These
definitions are used by `bind` at macro-expansion time to generate
the code that actually does the bindings for you. For example:
(defbinding-form (symbol :use-values-p nil)
(if (keywordp kind)
(error \"Don't have a binding form for ~s\" kind)
`(let (,@(if values
`((,variables ,values))
`(,variables))))))
This binding form tells to expand clauses whose first element is
a symbol using `let`. (It also gets `bind` to signal an error if
the first element is a keyword that doesn't have a defined binding
form.)
"
(declare (ignorable remove-nils-p description))
(let* ((multiple-names? (consp name/s))
(main-method-name nil)
(force-keyword? (or multiple-names?
(eq (symbol-package name/s)
(load-time-value (find-package :keyword)))))
#+(or)
(gignores (gensym "ignores")))
(cond (multiple-names?
(setf main-method-name (gentemp (symbol-name '#:binding-generator)))
)
(t
(setf main-method-name 'bind-generate-bindings)
))
(flet ((form-keyword (name)
(intern (symbol-name name)
(load-time-value (find-package :keyword)))))
(when force-keyword?
(setf name/s (if multiple-names?
(mapcar #'form-keyword name/s)
(form-keyword name/s))))
`(progn
(setf (binding-form-docstring ',name/s) ,docstring)
,@(loop for name in (if multiple-names? name/s (list name/s))
when (keywordp name) collect
`(defmethod binding-form-accepts-multiple-forms-p
((binding-form (eql ,name)))
,accept-multiple-forms-p))
(,(if multiple-names? 'defun 'defmethod) ,main-method-name
(,@(unless multiple-names?
(if force-keyword?
`((kind (eql ,name/s)))
`((kind ,name/s))))
variable-form value-form body declarations remaining-bindings)
,(if use-values-p
;; surely this could be simpler!
`(let ((gvalues (next-value "values-")))
`((let ((,gvalues ,,(if accept-multiple-forms-p
`value-form
`(first value-form))))
(declare (ignorable ,gvalues))
(,@,(if (symbolp (first body))
`(,(first body) variable-form gvalues)
`(funcall (lambda (variables values) ,@body)
variable-form gvalues))
; ,@(when ,gignores `((declare (ignore ,@gignores))))
,@(bind-filter-declarations
declarations variable-form)
,@(bind-macro-helper
remaining-bindings declarations body)))))
``((,@,(if (symbolp (first body))
`(,(first body) variable-form ,(if accept-multiple-forms-p
`value-form
`(first value-form)))
`(funcall (lambda (variables values) ,@body)
variable-form ,(if accept-multiple-forms-p
`value-form
`(first value-form))))
,@(bind-filter-declarations declarations variable-form)
,@(bind-macro-helper
remaining-bindings declarations body)))))
,@(when multiple-names?
(loop for name in name/s collect
`(defmethod bind-generate-bindings
((kind (eql ,name))
variable-form value-form body declarations
remaining-bindings)
(,main-method-name
variable-form value-form body declarations
remaining-bindings))))
#+(or)
,@(when multiple-names?
(loop for name in name/s collect
`(defmethod bind-generate-bindings
((kind (eql ,name))
variable-form value-form body declarations
remaining-bindings)
(,main-method-name
variable-form
,(if accept-multiple-forms-p `value-form `(first value-form))
body declarations
remaining-bindings))))
))))
(defun next-value (x)
(gensym x))
(defmacro lambda-bind ((&rest instrs) &rest body)
"Use `bind' to allow restructuring of argument to lambda expressions.
This lets you funcall and destructure simultaneously. For example
(let ((fn (lambda-bind ((a b) c) (cons a c))))
(funcall fn '(1 2) 3))
;; => (1 . 3)
Via eschulte (see git://gist.github.com/902174.git).
"
#+(or)
(declare (indent 1))
(let* ((evald-instrs instrs)
(syms (mapcar (lambda (_)
(declare (ignore _))
(gensym))
evald-instrs)))
`(lambda ,syms (bind ,(mapcar #'list evald-instrs syms) ,@body))))
|