Commit c6a2fc7e9cae40ace5f8c9d5e47025adb217b43b
2018-07-03T11:24:54
fix probed properties
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
diff --git a/core/properties.lisp b/core/properties.lisp
index c30dd3b..ca21e60 100644
--- a/core/properties.lisp
+++ b/core/properties.lisp
@@ -54,8 +54,8 @@
(let* ((k (pop keys))
(v (get-property k properties)))
(unless (eq v +undefined+)
- (push v plist)
- (push k plist))))
+ (push k plist)
+ (push v plist))))
(nreverse plist)))
(defmethod compare-property-values (resource property value1 value2)
@@ -76,30 +76,27 @@ Keeping old value by default."
property resource old new)
old))
-#+nil ;; Is this really the right thing ?
-(defmethod merge-property-values ((resource t)
- (property t)
- (old list)
- (new list))
- (append old new))
-
(defun merge-properties (resource &rest properties)
- (let* ((result (cons nil nil))
- (tail result))
- (loop
- (when (endp properties)
- (return))
- (let* ((key (pop properties))
- (val (pop properties))
- (result-val (getf (cdr result) key +undefined+)))
- (cond ((eq result-val +undefined+)
- (setf (cdr tail) (list key val)
- tail (cddr tail)))
- ((not (equalp result-val val))
- (setf (getf (cdr result) key)
- (merge-property-values resource key result-val val))))))
- (cdr result)))
-
-(let ((p ()))
- (setf (get-property :os p) "OpenBSD")
- p)
+ (let* ((result (pop properties))
+ (tail (last result)))
+ (flet ((push-result (&rest args)
+ (dolist (x args)
+ (let ((new-tail (list x)))
+ (if (endp result)
+ (setf result new-tail
+ tail new-tail)
+ (setf (cdr tail) new-tail
+ tail new-tail))))))
+ (dolist (plist properties)
+ (loop
+ (when (endp plist)
+ (return))
+ (let* ((key (pop plist))
+ (val (pop plist))
+ (result-val (getf result key +undefined+)))
+ (cond ((eq result-val +undefined+)
+ (push-result key val))
+ ((not (equalp result-val val))
+ (setf (getf result key)
+ (merge-property-values resource key result-val val))))))))
+ result))
diff --git a/core/syntaxes.lisp b/core/syntaxes.lisp
index b0f9591..b799700 100644
--- a/core/syntaxes.lisp
+++ b/core/syntaxes.lisp
@@ -32,18 +32,31 @@
(push spec vars)))
(nreverse vars))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun collect-values (specs)
+ (let ((values))
+ (dolist (spec specs)
+ (if (consp spec)
+ (let ((fun (first spec)))
+ (when (and (consp fun) (eq 'function (first fun)))
+ (setq fun (second fun)))
+ (dolist (var (rest spec))
+ (push `(when ,var (,fun ,var)) values)))
+ (push spec values)))
+ (nreverse values))))
+
(defmacro define-syntax (name specs re &body body)
(let* ((parse-name (sym 'parse- name))
(with-name (sym 'with- name))
(doc (when (stringp (first body)) (pop body)))
(vars (collect-vars specs))
- (values (or (first (last body)) `(values ,@vars))))
+ (values (collect-values specs)))
`(progn
(defun ,parse-name (line)
,@(when doc (list doc))
(declare (type string line))
(re-bind ,re ,vars line
- ,@(or body `(,values))))
+ ,@(or body `((values ,@values)))))
(defmacro ,with-name ((,@vars) lines &body with-body)
,@(when doc (list doc))
`(dolist (line ,lines)