[Author Prev][Author Next][Thread Prev][Thread Next][Author Index][Thread Index]
gEDA-cvs: gaf.git: branch: master updated (1.7.0-20110116-75-g9e3496e)
The branch, master has been updated
via 9e3496eb1b753ae9e42dfddd2343892a6618455d (commit)
via a827a0424b456e9f4b7b05a24a245cd871b6ce15 (commit)
via 0737c34e057ed008a6c342238d21041a5cb200b5 (commit)
via cbd30169122f7882c4d70db7e6c03604a917c8d2 (commit)
via 081767282d449c93c11e5f7ed91a88ad4ad4276c (commit)
from 2dfb5547bdf486ca4375af9e73cbe318768cb59f (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
=========
Summary
=========
gschem/lib/system-gschemrc.scm | 1 +
gschem/scheme/auto-uref.scm | 105 +++++++++++++++++++++++++++++---------
libgeda/include/prototype_priv.h | 1 +
libgeda/src/g_smob.c | 48 +++++++++++++++++
4 files changed, 130 insertions(+), 25 deletions(-)
=================
Commit Messages
=================
commit 9e3496eb1b753ae9e42dfddd2343892a6618455d
Author: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
Commit: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
auto-uref: initialise data structures at page load
New toplevel procedure is defined in auto-uref.scm to be used with
the new-page-hook:
(add-hook! new-page-hook auto-uref-init-page)
When called, internal refdes map is initialised from attributes of
existing elements on the page.
Closes-bug: lp-787637
:100644 100644 f005b60... 96a0840... M gschem/lib/system-gschemrc.scm
:100644 100644 66c9387... 165b1db... M gschem/scheme/auto-uref.scm
commit a827a0424b456e9f4b7b05a24a245cd871b6ce15
Author: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
Commit: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
auto-uref: keep track of refdeses per page
Affects-bug: lp-787637
:100644 100644 2f74256... 66c9387... M gschem/scheme/auto-uref.scm
commit 0737c34e057ed008a6c342238d21041a5cb200b5
Author: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
Commit: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
libgeda: add comparison function for page smob
Page smobs are now compared using PAGE pointer equality.
This allows to use page smobs as keys in assoc lists in Scheme.
Affects-bug: lp-787637
:100644 100644 edfcd87... d6d5388... M libgeda/src/g_smob.c
commit cbd30169122f7882c4d70db7e6c03604a917c8d2
Author: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
Commit: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
auto-uref: omit inherited refdes attribute
Affects-bug: lp-787637
:100644 100644 e5527c7... 2f74256... M gschem/scheme/auto-uref.scm
commit 081767282d449c93c11e5f7ed91a88ad4ad4276c
Author: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
Commit: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
libgeda: add attrib-inherited? scheme procedure
Affects-bug: lp-787637
:100644 100644 b240e0b... 69cb743... M libgeda/include/prototype_priv.h
:100644 100644 420e45a... edfcd87... M libgeda/src/g_smob.c
=========
Changes
=========
commit 9e3496eb1b753ae9e42dfddd2343892a6618455d
Author: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
Commit: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
auto-uref: initialise data structures at page load
New toplevel procedure is defined in auto-uref.scm to be used with
the new-page-hook:
(add-hook! new-page-hook auto-uref-init-page)
When called, internal refdes map is initialised from attributes of
existing elements on the page.
Closes-bug: lp-787637
diff --git a/gschem/lib/system-gschemrc.scm b/gschem/lib/system-gschemrc.scm
index f005b60..96a0840 100644
--- a/gschem/lib/system-gschemrc.scm
+++ b/gschem/lib/system-gschemrc.scm
@@ -842,6 +842,7 @@
; placing new component and copying components
;
;(load-from-path "auto-uref.scm")
+;(add-hook! new-page-hook auto-uref-init-page)
;(add-hook! add-component-hook auto-uref)
;(add-hook! copy-component-hook auto-uref)
diff --git a/gschem/scheme/auto-uref.scm b/gschem/scheme/auto-uref.scm
index 66c9387..165b1db 100644
--- a/gschem/scheme/auto-uref.scm
+++ b/gschem/scheme/auto-uref.scm
@@ -17,7 +17,7 @@
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-(use-modules (ice-9 regex))
+(use-modules (ice-9 regex) (srfi srfi-1))
;; Two level associative list - page at first level, refdes prefix at second
(define page-prefix-list '())
@@ -67,3 +67,46 @@
(set! page-prefix-list (assoc-set! page-prefix-list
(get-current-page)
refdes-map)))
+
+
+;; Scan for existing refdeses in the page and initialise page-prefix-list
+(define (auto-uref-init-page page)
+
+ ; Return (prefix . number) on match or #f on failure
+ (define (split-attr value)
+ (let ((match (string-match "^([A-Z]+)([0-9]+)$" value)))
+ (if match
+ (cons (match:substring match 1)
+ (string->number (match:substring match 2)))
+ #f)))
+
+ ; Update refdes map with given prefix-num pair
+ (define (update-refdes-map prefix-num)
+ (let* ((prefix (car prefix-num))
+ (value (cdr prefix-num))
+ (old-value (assoc-ref refdes-map prefix))
+ (new-value (if old-value (max old-value value) value)))
+ (set! refdes-map (assoc-set! refdes-map prefix new-value))))
+
+ ; Execute update for a single object
+ (define (handle-object object)
+ (let* ((all-attribs (get-object-attributes object))
+ (own-attribs (filter (lambda (a)
+ (not (attrib-inherited? a))) all-attribs))
+ (name-vals (map get-attribute-name-value own-attribs))
+ (refdeses (filter (lambda (a)
+ (string=? "refdes" (car a)))
+ name-vals))
+ (prefix-pairs (filter-map (lambda (a)
+ (split-attr (cdr a)))
+ refdeses)))
+ (for-each update-refdes-map prefix-pairs)))
+
+ ; Clear refdes map for given page
+ (define (refdes-map) '())
+
+ ; Update refdes maps for objects in given page
+ (for-each handle-object (get-objects-in-page page))
+
+ ; Overwrite map for given page
+ (set! page-prefix-list (assoc-set! page-prefix-list page refdes-map)))
commit a827a0424b456e9f4b7b05a24a245cd871b6ce15
Author: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
Commit: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
auto-uref: keep track of refdeses per page
Affects-bug: lp-787637
diff --git a/gschem/scheme/auto-uref.scm b/gschem/scheme/auto-uref.scm
index 2f74256..66c9387 100644
--- a/gschem/scheme/auto-uref.scm
+++ b/gschem/scheme/auto-uref.scm
@@ -19,39 +19,51 @@
(use-modules (ice-9 regex))
-(define prefix-list '())
+;; Two level associative list - page at first level, refdes prefix at second
+(define page-prefix-list '())
+;; Modify attributes of an object to assign next unused refdes value
(define (auto-uref attribs)
+ ; Map of refdes prefix and next available number for current page
+ (define refdes-map
+ (let ((old (assoc-ref page-prefix-list (get-current-page))))
+ (if old old '())))
+
+ ; Retrieve next available number for given refdes prefix
+ ; Update refdes-map to track used refdeses
(define (get-next-uref prefix)
- (let ((available-prefix (assoc prefix prefix-list)))
- (cond (available-prefix
- (assoc-set! prefix-list
- (car available-prefix)
- (+ (cdr available-prefix) 1))
- (cdr available-prefix))
- (else ; First time prefix was seen
- (set! prefix-list (acons prefix 1 prefix-list))
- 1))))
-
+ (let* ((old (assoc-ref refdes-map prefix))
+ (new (if old (1+ old) 1)))
+ (set! refdes-map (assoc-set! refdes-map prefix new))
+ new))
- ;; Total Guile
+ ; Extract prefix from a refdes attribute value
(define (get-prefix value)
(let ((prefix (string-match "^[A-Z]*" value)))
(if (= 0 (match:end prefix))
#f
(match:substring prefix))))
-
+ ; Process object attributes
(for-each
- (lambda (attrib)
- (let* ((name-value (get-attribute-name-value attrib))
- (name (car name-value))
- (value (cdr name-value))
- (prefix (get-prefix value)))
- ; If get-prefix fails (returns #f) there is no ? in the string
- (if (and prefix (string=? name "refdes") (not (attrib-inherited? attrib)))
- (set-attribute-value! attrib (string-append
- prefix
- (number->string (get-next-uref prefix)))))))
- attribs))
+ (lambda (attrib)
+ (let* ((name-value (get-attribute-name-value attrib))
+ (name (car name-value))
+ (value (cdr name-value))
+ (prefix (get-prefix value)))
+ ; If get-prefix fails (returns #f) there is no ? in the string
+ (if (and prefix
+ (string=? name "refdes")
+ (not (attrib-inherited? attrib)))
+ (set-attribute-value! attrib
+ (string-append
+ prefix
+ (number->string
+ (get-next-uref prefix)))))))
+ attribs)
+
+ ; Update global map with modified map for current page
+ (set! page-prefix-list (assoc-set! page-prefix-list
+ (get-current-page)
+ refdes-map)))
commit 0737c34e057ed008a6c342238d21041a5cb200b5
Author: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
Commit: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
libgeda: add comparison function for page smob
Page smobs are now compared using PAGE pointer equality.
This allows to use page smobs as keys in assoc lists in Scheme.
Affects-bug: lp-787637
diff --git a/libgeda/src/g_smob.c b/libgeda/src/g_smob.c
index edfcd87..d6d5388 100644
--- a/libgeda/src/g_smob.c
+++ b/libgeda/src/g_smob.c
@@ -768,6 +768,32 @@ static int g_print_page_smob(SCM page_smob, SCM port,
return 1;
}
+/*! \brief Compare two page smobs.
+ * \par Function Description
+ * This function compares two given page smobs for equality.
+ * Two smobs are equal if they point to same PAGE structure.
+ *
+ * \param [in] page_smob1 The first page smob.
+ * \param [in] page_smob2 The second page smob.
+ * \return SCM_BOOL_T or SCM_BOOL_F
+ */
+static SCM g_equalp_page_smob (SCM page_smob1,
+ SCM page_smob2)
+{
+ struct st_page_smob *page1 =
+ (struct st_page_smob *) SCM_CDR (page_smob1);
+
+ struct st_page_smob *page2 =
+ (struct st_page_smob *) SCM_CDR (page_smob2);
+
+ if (page1 &&
+ page2 &&
+ page1->page == page2->page)
+ return SCM_BOOL_T;
+ else
+ return SCM_BOOL_F;
+}
+
/*! \brief Initialize the framework to support a page smob.
* \par Function Description
* Initialize the framework to support a page smob.
@@ -781,6 +807,7 @@ void g_init_page_smob(void)
scm_set_smob_mark(page_smob_tag, 0);
scm_set_smob_free(page_smob_tag, g_free_page_smob);
scm_set_smob_print(page_smob_tag, g_print_page_smob);
+ scm_set_smob_equalp(page_smob_tag, g_equalp_page_smob);
scm_c_define_gsubr ("get-page-filename", 1, 0, 0, g_get_page_filename);
scm_c_define_gsubr ("set-page-filename", 2, 0, 0, g_set_page_filename);
commit cbd30169122f7882c4d70db7e6c03604a917c8d2
Author: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
Commit: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
auto-uref: omit inherited refdes attribute
Affects-bug: lp-787637
diff --git a/gschem/scheme/auto-uref.scm b/gschem/scheme/auto-uref.scm
index e5527c7..2f74256 100644
--- a/gschem/scheme/auto-uref.scm
+++ b/gschem/scheme/auto-uref.scm
@@ -50,7 +50,7 @@
(value (cdr name-value))
(prefix (get-prefix value)))
; If get-prefix fails (returns #f) there is no ? in the string
- (if (and prefix (string=? name "refdes"))
+ (if (and prefix (string=? name "refdes") (not (attrib-inherited? attrib)))
(set-attribute-value! attrib (string-append
prefix
(number->string (get-next-uref prefix)))))))
commit 081767282d449c93c11e5f7ed91a88ad4ad4276c
Author: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
Commit: Krzysztof KoÅ?ciuszkiewicz <k.kosciuszkiewicz@xxxxxxxxx>
libgeda: add attrib-inherited? scheme procedure
Affects-bug: lp-787637
diff --git a/libgeda/include/prototype_priv.h b/libgeda/include/prototype_priv.h
index b240e0b..69cb743 100644
--- a/libgeda/include/prototype_priv.h
+++ b/libgeda/include/prototype_priv.h
@@ -46,6 +46,7 @@ SCM g_calcule_new_attrib_bounds (SCM attrib_smob, SCM scm_alignment,
SCM g_get_attrib_bounds(SCM attrib_smob);
SCM g_get_attrib_angle(SCM attrib_smob);
SCM g_get_attrib_value_by_attrib_name(SCM object_smob, SCM scm_attrib_name);
+SCM g_attrib_is_inherited (SCM attrib_smob);
void g_init_object_smob(void);
SCM g_get_object_type(SCM object_smob);
SCM g_get_line_width(SCM object_smob);
diff --git a/libgeda/src/g_smob.c b/libgeda/src/g_smob.c
index 420e45a..edfcd87 100644
--- a/libgeda/src/g_smob.c
+++ b/libgeda/src/g_smob.c
@@ -357,6 +357,7 @@ void g_init_attrib_smob(void)
scm_c_define_gsubr ("get-attribute-angle", 1, 0, 0, g_get_attrib_angle);
scm_c_define_gsubr ("calcule-new-attrib-bounds", 5, 0, 0,
g_calcule_new_attrib_bounds);
+ scm_c_define_gsubr ("attrib-inherited?", 1, 0, 0, g_attrib_is_inherited);
return;
@@ -431,6 +432,26 @@ SCM g_get_attrib_angle(SCM attrib_smob)
return scm_from_int(attribute->attribute->text->angle);
}
+/*! \brief Check if attribute is inherited.
+ * \par Function Description
+ * Return result of o_attrib_is_inherited().
+ * \param [in] attrib_smob Attribute to check.
+ * \return SCM_BOOL_F or SCM_BOOL_T.
+ */
+SCM g_attrib_is_inherited (SCM attrib_smob)
+{
+ struct st_attrib_smob *attribute =
+ (struct st_attrib_smob *) SCM_CDR (attrib_smob);
+
+ if (attribute && attribute->attribute) {
+ OBJECT *object = attribute->attribute;
+ if (object && object->text && o_attrib_is_inherited (object))
+ return SCM_BOOL_T;
+ }
+
+ return SCM_BOOL_F;
+}
+
/*! \brief Free object smob memory.
* \par Function Description
* Free the memory allocated by the object smob and return its size.
_______________________________________________
geda-cvs mailing list
geda-cvs@xxxxxxxxxxxxxx
http://www.seul.org/cgi-bin/mailman/listinfo/geda-cvs