[Author Prev][Author Next][Thread Prev][Thread Next][Author Index][Thread Index]
gEDA-cvs: gaf.git: branch: master updated (1.7.1-20110619-154-g23181c3)
The branch, master has been updated
via 23181c3de91dc22ab40d6a7080e3b094bd4ca0ac (commit)
via 242562c9b0513f451c9ec2b25b1d8df4c71d01e6 (commit)
via 1c8281672b4c1831bd2c7614d9b41ff7720a2be3 (commit)
via 883be5d25f046a06a76f106cb6ad1bde1b14db9f (commit)
via 31fcff837375b3db8649f1f1854dd0daa98e901a (commit)
via 71621e0f9d6ed201ac3968823b0b6b852fe3f070 (commit)
via 01e9ab2b42bff0de6386706ba3eb11e7a7c6f5e9 (commit)
via 208984c6815066a90c7d1d3583f271524344797e (commit)
via 3a47ea70adf7bae086b7d28455c2cacd707b434c (commit)
via 9ac7ddffcdd09ae0bbf9c62af0457ff957510081 (commit)
via ec7825e81a6ac142972bc4f0c28fb2276c3df60c (commit)
via 2fa4f5712cf6decb4bf3b90002634ba607b1aec4 (commit)
via 4f6d3a0fd5810d8fabd93a1629495f5c916ae4d3 (commit)
via e53af99b5b907819da60a2f6d7666038d351ddd6 (commit)
via 01e10f7f71a380e2c6aa192d4da6bf8204cbfe2f (commit)
via 7c88e88e38bcd20f6ad3e46604f2b117b6fef0a6 (commit)
via dd5b9c7c08307104ce360661f6e696ce87c77389 (commit)
via 224e3edec54febcf055810e6d4220369e50f1ade (commit)
via 1e9d73ec74c6abd2ddfcf18cccadc9c0c44ff7ff (commit)
via 832af3a116fd37db9c8a647918179522ee0a10ab (commit)
via be7d5d316bbf944f9e0a618ddff795a073de9183 (commit)
via e7ed5291067d56419efe3764190d22fa7714937e (commit)
via b1ca0b60c9218db51132272ffdf0c1815d29b80f (commit)
via 623b9fe2ad30c517053b2c8b40723435903e2474 (commit)
via 37338045adf382ecef00d5ee5f337c4da250b996 (commit)
via fd1e63aefad0097b1f99cf6cdb31998efec5c407 (commit)
via bcd036f9432335473d5ad64e18d83df669947eb3 (commit)
via 4a3a197ab3519928c1fdb2b31a0cbc272ba75f12 (commit)
via 008ba78fc1a60641b620cabc9ecc198cd0a2225c (commit)
via c0125211b863d0d54554c39abda8c76f7ad27fae (commit)
via 1d97d6c9cad63a79bceaa9d599a757c01f1a60e7 (commit)
via dce70c5e826e2958d02a5bf8089b7dd1eb3a519f (commit)
via b5046514e8c4561de9a5a249624b23e003a2988a (commit)
via 8b9f6235d72ad5be0fca53613e7ca77802543d58 (commit)
via 6b299b8b9f423976f746cf3694a49b9124950237 (commit)
via c6b89e3d030a6fa061598dd467f4bee9c147c28e (commit)
via daaf7d90949a3ac7cfe2914aedd1bb5c170c375b (commit)
via 7c759d21f74e89e41d08bbc871891554ec027607 (commit)
via 9c540461df266e548684ab2f0bd3294605cf749e (commit)
via f7cc58369760991eda968571d5677e97ca2092cd (commit)
via e6870ce5a1aac5f2da8d6bb53495d6a52967a538 (commit)
via ad289e2ea5d5402fd7061965a3939d33323e4292 (commit)
via 0aaabc599c8146801364d5b8bc9e984ea764cc5b (commit)
via 22a146a4a8a221908ab531aafc1d901a3358c133 (commit)
via 0f7d19313b0a8e2ecd7d4a5ea24ee6e0ab243d60 (commit)
via 6b3c4f7f52f684e10c08ef478e341b954032c94b (commit)
via 0b9ce5de9589b09ec35cdf321f5ac8540f81daa1 (commit)
via c761f0ed17f915369143bcf180eafbf52076e1ae (commit)
via 1cd1b3ecf56c183c6b7fd6cd968574f4a3f9c8eb (commit)
via 4feb90789ff1394465d2d6b8a5556da2c1462a14 (commit)
via c5ec85006694d354462680339dbd67499ad1f0a2 (commit)
via 4e191297be1c7a47566a072f1d6e44905fe4647a (commit)
via 0a5ccba701c23e0dadee78e908e9f8f09c590340 (commit)
via 292c930244a9616642ade8a3afd4cc740c61d368 (commit)
via db3b79c7659a7526acf726c457b1c2915254fc4b (commit)
via e21e30af19f0c32743dc4663c19d5672ef3e518f (commit)
via 8c66dc1b9545ed60d25fe7fa2a7f9aa95c2b4a92 (commit)
via 25952c382fc199fb91502279267c45f880a55cdd (commit)
via 5cf897c1c107dc3d0b2e4ef82d1f15cbdeb76041 (commit)
via 1a96308dcf365d4cad0de8373beb108c14dfeae2 (commit)
via c603a85e1cdd63f770a19fb23d2fab49c14b3d0b (commit)
via cc1a3d0209a83aaa82404f41e42bb8a2c0c098b9 (commit)
via f5040254fe52ef181ff8bd205c33315b00e76c2c (commit)
via 30bfe114148d52155ae96226dfcd22484f8629c7 (commit)
via 623341482a94b2f92e662dd8e9ff8f6a218f42cc (commit)
via 91865253d6e4422b06648fe5b0334a5013a7d08a (commit)
via 4bccef20f38b43da0d9916f63601dec35fd5b33c (commit)
via 0d5ec53d5ce3baa3004bd1dbfea2f33c4d4abece (commit)
via d8abb509c60de0fbd4c288ff7fa9c32c2448f1cf (commit)
via b4a75a6ebc480d866d2b268059de04cfcecff40f (commit)
via 228f6b55dc0d95e2a9695fc9cbb019099811524f (commit)
via 91e869f566c82cf2bcd9c501bad2060a257c2192 (commit)
via d0467a2c5c6fde4155bfc57f0345bbb162e1b4c7 (commit)
via 05954f101e9ae90193150e030fb66c1b3d32e44b (commit)
via 62f51dcfeb8a08288bc1854fd1d49e667b03f490 (commit)
via 1121d83a5450ad9040cabb7ef9a8cfb6c2a395f3 (commit)
via cbdeedd05e825c0d11080392c16cd86a1968ba73 (commit)
via 14eab2daf97f03ef7cdb26c2c3e8969f99b22a70 (commit)
via e9f2f0b1285b877a12f0338635af0eade60c7c68 (commit)
via 0344623ea013e54a15735988b75508c07469d4d8 (commit)
via 9415bf958a9cf16461733be58d0f8f257b5b4726 (commit)
via e67d080a7c48dd1300c90c93d8b1723958244a2d (commit)
via 694ccbdec90765ca4cb9b2dbcb1bbe7cdfba2f0b (commit)
via 1543eda1dbb823fd3052a3b831eae5b8316ed690 (commit)
via 19963e962d5baf1cad6de44a2e411f7e5610159c (commit)
via b08d9d08ee4740884de97e87179a9809d6b3dba3 (commit)
via 9379c19a7563a02c271c8640fdb814ef0add5981 (commit)
via f9156f1642e0a24661f06cc335178a14d5fa7b1c (commit)
via cb21936a1e620374a04c4f058458fa72f9933e67 (commit)
via f74b3ba70dc5b7c16613b6e751935fb9e7bdb37a (commit)
via b70513b5260d14e22dde1bc73c9f6c61dbbeb5ca (commit)
via 3940ee1a2704d07f7e6f9f2c71eb65346a709f46 (commit)
via 8c4d33a5f7835b477d6e485ef47ca8c1db3f16a8 (commit)
via a3433b6a4c088b8926f8768e20eff18d0dafea4b (commit)
via a0adbfc6bbc79cb7ac9cc2dd1c894ad0cdc0b872 (commit)
via fc8bcac43b6f3dd611f6030ffe36465d67be379d (commit)
via a21ee2882d662a50418561f8de101d44bba7294c (commit)
via 7f85f28e67c59dbccb0f2a321794b0ddbb3e578f (commit)
via 0a5c0a4f0d9e721bdf198c400db3cef607e72c33 (commit)
via 6359f03b8615d707b122d84c6e73ae6bf99c097b (commit)
via 09ce403fef04ec9a77b611d248da20c375b1e100 (commit)
via c7d44a2507edb830e1592d9390cb32ad5fb658b4 (commit)
via f8b371c8732f128c09fda366916f48d4a3ae8873 (commit)
via c397394b68b27672d1af14d777eea35636b3b365 (commit)
via 780a175f4cff04a4f1b79332b6f604b7d95851ab (commit)
via bf643e97eef4919fb11aace7dd597d0b092170cb (commit)
via d8110db394f56139a4fb75c6447024a28fc12913 (commit)
via 85753049b2b9455d815ede96dca161cb0de2f22b (commit)
via d1d4dbf5841368874215b7ef102090ce4dfc0780 (commit)
via 3c2636864cc838286d31799d800f13c4f38f6d07 (commit)
via 7dacbe7ca2c9d7a209a5f5cc474c58a4cb9a6c24 (commit)
via 7aff6e91ae4520072f4b0272a8fed56e27b82c0a (commit)
via e92b66a8f48a565ae2b8de8d13601b7f54e84bad (commit)
via 709b2707e3ec79422f0485b6e381b5cbc351905e (commit)
via 5ee02960cb8cc90c6c6fd946c53cdf94b0b46b0e (commit)
via d1794e3a90d0774782d3ae37101db984db1038db (commit)
via 68ea0f2273be05499512a1b2a3e557e93c049724 (commit)
via 51afd1e9f5ff6d09e9066e2cc0f7eefab3a79002 (commit)
via bb9e4bcd4d3e5b9b598105f7f6f1aecae880783b (commit)
via 19fbd43464e59cbbed0fb98371b1daf5b3edc363 (commit)
via 420c5126609f2f2f409cbfad50afd2949836fe6e (commit)
via 9042448ea44521adc53375fdfc3d50641da0565a (commit)
via b1056b243513171194ad2e68894d2f618eef6d76 (commit)
via d72e2913f90edf2c02df614fa140c7d13c252362 (commit)
via 6eb023e46dc54a0b702cc9d9616325bf4e25ead4 (commit)
via c759a14672a1ee047c8d27f2d9c39339c88da18e (commit)
via 5d9ca02072ba4309352e39d209f252142a96e0af (commit)
via ee046f0a7c277d65ecb9edad6de5aeac0b81ba52 (commit)
via dbfcf03ba08226b6c752f57006a3e2cde7ffcde8 (commit)
via 275740ab72ae6fd9ab2ddcc024181d1c3330064d (commit)
via 2cd6cf4922ef828ed8bbb2d409d0e40b04f7d8ff (commit)
via c51711b32a5673b6ee3f18d5160c9c4e16d15b5e (commit)
via 662b15fd2dfa47d48410bcd42c75b461ab5f21bd (commit)
via c8140254f0821bd28f84040939329aaf0e744a9a (commit)
via 83e845d1ec88528eb94e58105bf62cb1f5742218 (commit)
via e70250b1f7776e40dcada0d2c0bc3d9d8bc9a8df (commit)
via 810d1982d5b9fcd5d73037292df0be090ce18d84 (commit)
via e461ca858a2d127c17bba84e17c31b626937ee00 (commit)
via 2d9bb54a420197facfe93712fa0e60c6ef35bdf9 (commit)
via a0f0f9c672a5f8955aaf6c37ec509484d9b08714 (commit)
via 2010a33b32dacaf660145b44ad7e93c566a0e9df (commit)
via f0d9875a2eee566cf75b340a98a9471d65fc8ad7 (commit)
via 91d3e917cd11d4c304c84f95431c08210b867a4c (commit)
via 1acff2a3f952b291cbae4e293f9cf703b99645de (commit)
via 4b52e3e739dca7b880f6909110b0225b2a7d6ea4 (commit)
via feefbf9f0746f23c3d388d075c7c5d9c38d91afc (commit)
via 4e1f04c285a0a66f56c027a38709d0b3ec205c65 (commit)
via a61805445c844b30f0e9de1c8003249fdedeee66 (commit)
via 4203e5e08b5341613ad6de08191f4feafb243687 (commit)
via b235a037d0ce1c525195141d77fd7b8cae85e8be (commit)
via 0460b8f476066ee471b4f8a79176e3a1fbbbfc55 (commit)
via 57f5e1eb96577f439840afb5c008ba739055d249 (commit)
from c4ca82095d88e29ade47c8c9f69734cfeaea5c1a (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
=========
NEWS | 8 +
build-tools/icon-theme-installer | 27 +-
configure.ac | 2 +
docs/Makefile.am | 2 +-
docs/scheme-api/Makefile.am | 1 +
docs/scheme-api/geda-scheme.texi | 1645 +++++++++++++++++++
gnetlist/scheme/gnet-drc2.scm | 3 +-
gnetlist/scheme/gnetlist.scm | 1 +
gnetlist/src/g_netlist.c | 15 +-
gnetlist/src/gnetlist.c | 6 +-
gnetlist/tests/Makefile.am | 3 +-
gnetlist/tests/common/inputs/gafrc | 1 +
gnetlist/tests/common/run_backend_tests.sh | 3 +
gnetlist/tests/drc2/Makefile.am | 6 +-
gnetlist/tests/hierarchy/Makefile.am | 5 +-
gnetlist/tests/hierarchy2/Makefile.am | 1 +
gnetlist/tests/runtest.sh | 3 +-
gschem/include/globals.h | 19 +-
gschem/include/gschem.h | 1 +
gschem/include/gschem_struct.h | 2 +
gschem/include/prototype.h | 36 +-
gschem/lib/system-gschemrc.scm | 7 +-
gschem/po/POTFILES.in | 1 +
gschem/scheme/Makefile.am | 19 +-
gschem/scheme/gschem/attrib.scm | 38 +
gschem/scheme/gschem/deprecated.scm | 412 +++++
gschem/scheme/gschem/hook.scm | 45 +
gschem/scheme/gschem/selection.scm | 29 +
gschem/scheme/gschem/window.scm | 30 +
gschem/src/.gitignore | 1 +
gschem/src/Makefile.am | 20 +-
gschem/src/g_attrib.c | 167 ++
gschem/src/g_funcs.c | 94 +-
gschem/src/g_hook.c | 820 ++---------
gschem/src/g_keys.c | 35 +-
gschem/src/g_register.c | 34 +-
gschem/src/g_select.c | 186 +++
gschem/src/g_window.c | 297 ++++
gschem/src/globals.c | 22 +-
gschem/src/gschem.c | 14 +-
gschem/src/gschem_toplevel.c | 3 +
gschem/src/i_callbacks.c | 19 +-
gschem/src/o_arc.c | 5 +-
gschem/src/o_attrib.c | 23 +-
gschem/src/o_box.c | 5 +-
gschem/src/o_bus.c | 5 +-
gschem/src/o_circle.c | 5 +-
gschem/src/o_complex.c | 47 +-
gschem/src/o_copy.c | 39 +-
gschem/src/o_delete.c | 30 +-
gschem/src/o_line.c | 5 +-
gschem/src/o_misc.c | 80 +-
gschem/src/o_move.c | 23 +-
gschem/src/o_net.c | 15 +-
gschem/src/o_picture.c | 5 +-
gschem/src/o_pin.c | 8 +-
gschem/src/o_place.c | 22 +-
gschem/src/o_select.c | 146 +--
gschem/src/o_slot.c | 5 +-
gschem/src/x_autonumber.c | 5 +-
gschem/src/x_event.c | 84 +-
gschem/src/x_menus.c | 17 +-
gschem/src/x_multiattrib.c | 9 +-
gschem/src/x_stroke.c | 5 +-
gschem/src/x_window.c | 20 +-
libgeda/Makefile.am | 2 +-
libgeda/include/Makefile.am | 4 +-
libgeda/include/libgeda/libgedaguile.h | 56 +
libgeda/include/libgeda/prototype.h | 10 -
libgeda/include/libgedaguile_priv.h | 139 ++
libgeda/include/prototype_priv.h | 17 +-
libgeda/lib/system-gafrc | 3 +
libgeda/po/POTFILES.in | 4 +
libgeda/scheme/Makefile.am | 35 +-
libgeda/scheme/geda/attrib.scm | 82 +
libgeda/scheme/geda/deprecated.scm | 117 ++
libgeda/scheme/geda/object.scm | 382 +++++
libgeda/scheme/geda/page.scm | 50 +
libgeda/scheme/unit-test.scm | 130 ++
libgeda/scheme/unit-tests/t0001-geda-conf-lib.scm | 26 +
libgeda/scheme/unit-tests/t0100-object-line.scm | 140 ++
libgeda/scheme/unit-tests/t0101-object-box.scm | 36 +
libgeda/scheme/unit-tests/t0102-object-circle.scm | 31 +
libgeda/scheme/unit-tests/t0103-object-arc.scm | 40 +
libgeda/scheme/unit-tests/t0104-object-text.scm | 84 +
libgeda/scheme/unit-tests/t0105-object-complex.scm | 180 ++
libgeda/scheme/unit-tests/t0106-object-bounds.scm | 53 +
.../scheme/unit-tests/t0107-object-stroke-fill.scm | 43 +
.../scheme/unit-tests/t0108-object-connections.scm | 67 +
libgeda/scheme/unit-tests/t0109-object-copy.scm | 45 +
.../scheme/unit-tests/t0110-object-transform.scm | 90 +
libgeda/scheme/unit-tests/t0200-page.scm | 81 +
libgeda/scheme/unit-tests/t0201-page-dirty.scm | 118 ++
libgeda/scheme/unit-tests/t0202-page-string.scm | 40 +
.../scheme/unit-tests/t0203-page-string-syntax.scm | 11 +
libgeda/scheme/unit-tests/t0300-attribute.scm | 187 +++
.../unit-tests/t0301-promotable-attributes.scm | 30 +
libgeda/scheme/unit-tests/t1000-deprecated.scm | 77 +
libgeda/shell/.gitignore | 5 +
libgeda/shell/Makefile.am | 28 +
libgeda/shell/shell.c | 234 +++
libgeda/src/.gitignore | 1 +
libgeda/src/Makefile.am | 32 +-
libgeda/src/g_basic.c | 6 +
libgeda/src/g_register.c | 13 -
libgeda/src/g_smob.c | 914 -----------
libgeda/src/libgeda.c | 5 +-
libgeda/src/o_complex_basic.c | 14 +-
libgeda/src/scheme_attrib.c | 305 ++++
libgeda/src/scheme_complex.c | 404 +++++
libgeda/src/scheme_deprecated.c | 94 ++
libgeda/src/scheme_init.c | 54 +
libgeda/src/scheme_object.c | 1716 ++++++++++++++++++++
libgeda/src/scheme_page.c | 474 ++++++
libgeda/src/scheme_smob.c | 432 +++++
libgeda/src/scheme_toplevel.c | 138 ++
116 files changed, 9667 insertions(+), 2303 deletions(-)
create mode 100644 docs/scheme-api/Makefile.am
create mode 100644 docs/scheme-api/geda-scheme.texi
create mode 100644 gschem/scheme/gschem/attrib.scm
create mode 100644 gschem/scheme/gschem/deprecated.scm
create mode 100644 gschem/scheme/gschem/hook.scm
create mode 100644 gschem/scheme/gschem/selection.scm
create mode 100644 gschem/scheme/gschem/window.scm
create mode 100644 gschem/src/g_attrib.c
create mode 100644 gschem/src/g_select.c
create mode 100644 gschem/src/g_window.c
create mode 100644 libgeda/include/libgeda/libgedaguile.h
create mode 100644 libgeda/include/libgedaguile_priv.h
create mode 100644 libgeda/scheme/geda/attrib.scm
create mode 100644 libgeda/scheme/geda/deprecated.scm
create mode 100644 libgeda/scheme/geda/object.scm
create mode 100644 libgeda/scheme/geda/page.scm
create mode 100644 libgeda/scheme/unit-test.scm
create mode 100644 libgeda/scheme/unit-tests/t0001-geda-conf-lib.scm
create mode 100644 libgeda/scheme/unit-tests/t0100-object-line.scm
create mode 100644 libgeda/scheme/unit-tests/t0101-object-box.scm
create mode 100644 libgeda/scheme/unit-tests/t0102-object-circle.scm
create mode 100644 libgeda/scheme/unit-tests/t0103-object-arc.scm
create mode 100644 libgeda/scheme/unit-tests/t0104-object-text.scm
create mode 100644 libgeda/scheme/unit-tests/t0105-object-complex.scm
create mode 100644 libgeda/scheme/unit-tests/t0106-object-bounds.scm
create mode 100644 libgeda/scheme/unit-tests/t0107-object-stroke-fill.scm
create mode 100644 libgeda/scheme/unit-tests/t0108-object-connections.scm
create mode 100644 libgeda/scheme/unit-tests/t0109-object-copy.scm
create mode 100644 libgeda/scheme/unit-tests/t0110-object-transform.scm
create mode 100644 libgeda/scheme/unit-tests/t0200-page.scm
create mode 100644 libgeda/scheme/unit-tests/t0201-page-dirty.scm
create mode 100644 libgeda/scheme/unit-tests/t0202-page-string.scm
create mode 100644 libgeda/scheme/unit-tests/t0203-page-string-syntax.scm
create mode 100644 libgeda/scheme/unit-tests/t0300-attribute.scm
create mode 100644 libgeda/scheme/unit-tests/t0301-promotable-attributes.scm
create mode 100644 libgeda/scheme/unit-tests/t1000-deprecated.scm
create mode 100644 libgeda/shell/.gitignore
create mode 100644 libgeda/shell/Makefile.am
create mode 100644 libgeda/shell/shell.c
delete mode 100644 libgeda/src/g_smob.c
create mode 100644 libgeda/src/scheme_attrib.c
create mode 100644 libgeda/src/scheme_complex.c
create mode 100644 libgeda/src/scheme_deprecated.c
create mode 100644 libgeda/src/scheme_init.c
create mode 100644 libgeda/src/scheme_object.c
create mode 100644 libgeda/src/scheme_page.c
create mode 100644 libgeda/src/scheme_smob.c
create mode 100644 libgeda/src/scheme_toplevel.c
=================
Commit Messages
=================
commit 242562c9b0513f451c9ec2b25b1d8df4c71d01e6
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add info directory macros.
:100644 100644 3398fea... ac02d47... M docs/scheme-api/geda-scheme.texi
commit 1c8281672b4c1831bd2c7614d9b41ff7720a2be3
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Run gtk-update-icon-cache when uninstalling.
If `gtk-update-icon-cache' is not run during `make uninstall', then a
stale `icon-theme.cache' is left in the install directory. This
breaks distcheck's uninstall check.
This problem was previously masked due to the fact that the uninstall
check silently allows exactly one leftover file -- and now that we
install Info manuals, this allowance is being used up by the
`${infodir}/dir' file generated by `install-info'.
:100755 100755 e070868... 594dd72... M build-tools/icon-theme-installer
commit 883be5d25f046a06a76f106cb6ad1bde1b14db9f
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Update NEWS for Scheme API.
:100644 100644 97d5996... 34cc2de... M NEWS
commit 31fcff837375b3db8649f1f1854dd0daa98e901a
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Converting pages to/from strings.
:100644 100644 89733b6... 3398fea... M docs/scheme-api/geda-scheme.texi
:100644 100644 ee014d4... 18dd2ac... M libgeda/scheme/Makefile.am
:100644 100644 556f52f... 65d88e3... M libgeda/scheme/geda/page.scm
:000000 100644 0000000... fabf5b6... A libgeda/scheme/unit-tests/t0202-page-string.scm
:000000 100644 0000000... e608017... A libgeda/scheme/unit-tests/t0203-page-string-syntax.scm
:100644 100644 71a2139... 311abb5... M libgeda/src/scheme_page.c
commit 71621e0f9d6ed201ac3968823b0b6b852fe3f070
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add mirror-objects! function.
:100644 100644 cebf872... 89733b6... M docs/scheme-api/geda-scheme.texi
:100644 100644 3848f2b... 2e17a6f... M libgeda/scheme/geda/object.scm
:100644 100644 953c2f6... efdc5cf... M libgeda/scheme/unit-tests/t0110-object-transform.scm
:100644 100644 e1447a8... 8a2ef57... M libgeda/src/scheme_object.c
commit 01e9ab2b42bff0de6386706ba3eb11e7a7c6f5e9
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add rotate-objects! function.
:100644 100644 671cc1a... cebf872... M docs/scheme-api/geda-scheme.texi
:100644 100644 8409d30... 3848f2b... M libgeda/scheme/geda/object.scm
:100644 100644 4c26f72... 953c2f6... M libgeda/scheme/unit-tests/t0110-object-transform.scm
:100644 100644 e616cec... e1447a8... M libgeda/src/scheme_object.c
commit 208984c6815066a90c7d1d3583f271524344797e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add translate-objects! function.
:100644 100644 1eae5e0... 671cc1a... M docs/scheme-api/geda-scheme.texi
:100644 100644 8911218... ee014d4... M libgeda/scheme/Makefile.am
:100644 100644 e3bceb8... 8409d30... M libgeda/scheme/geda/object.scm
:000000 100644 0000000... 4c26f72... A libgeda/scheme/unit-tests/t0110-object-transform.scm
:100644 100644 240a985... e616cec... M libgeda/src/scheme_object.c
commit 3a47ea70adf7bae086b7d28455c2cacd707b434c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Shuffle some unit tests around.
It turns out we need more test numbers for low-level object-related
functions, so shift some stuff about.
:100644 100644 ab946b0... 8911218... M libgeda/scheme/Makefile.am
:100644 000000 7edbb95... 0000000... D libgeda/scheme/unit-tests/t0010-object-line.scm
:100644 000000 15a9612... 0000000... D libgeda/scheme/unit-tests/t0011-object-box.scm
:100644 000000 4cb8323... 0000000... D libgeda/scheme/unit-tests/t0012-object-circle.scm
:100644 000000 d6c038a... 0000000... D libgeda/scheme/unit-tests/t0013-object-arc.scm
:100644 000000 8642243... 0000000... D libgeda/scheme/unit-tests/t0014-object-text.scm
:100644 000000 09cf92f... 0000000... D libgeda/scheme/unit-tests/t0015-object-complex.scm
:100644 000000 a896b8c... 0000000... D libgeda/scheme/unit-tests/t0016-object-bounds.scm
:100644 000000 ecf74c3... 0000000... D libgeda/scheme/unit-tests/t0017-object-stroke-fill.scm
:100644 000000 3665f34... 0000000... D libgeda/scheme/unit-tests/t0018-object-connections.scm
:100644 000000 c5a917f... 0000000... D libgeda/scheme/unit-tests/t0019-object-copy.scm
:100644 000000 0837c92... 0000000... D libgeda/scheme/unit-tests/t0020-page.scm
:100644 000000 b450ed8... 0000000... D libgeda/scheme/unit-tests/t0021-page-dirty.scm
:100644 000000 d63cc07... 0000000... D libgeda/scheme/unit-tests/t0030-attribute.scm
:100644 000000 ba6d668... 0000000... D libgeda/scheme/unit-tests/t0031-promotable-attributes.scm
:000000 100644 0000000... 7edbb95... A libgeda/scheme/unit-tests/t0100-object-line.scm
:000000 100644 0000000... 15a9612... A libgeda/scheme/unit-tests/t0101-object-box.scm
:000000 100644 0000000... 4cb8323... A libgeda/scheme/unit-tests/t0102-object-circle.scm
:000000 100644 0000000... d6c038a... A libgeda/scheme/unit-tests/t0103-object-arc.scm
:000000 100644 0000000... 8642243... A libgeda/scheme/unit-tests/t0104-object-text.scm
:000000 100644 0000000... 09cf92f... A libgeda/scheme/unit-tests/t0105-object-complex.scm
:000000 100644 0000000... a896b8c... A libgeda/scheme/unit-tests/t0106-object-bounds.scm
:000000 100644 0000000... ecf74c3... A libgeda/scheme/unit-tests/t0107-object-stroke-fill.scm
:000000 100644 0000000... 3665f34... A libgeda/scheme/unit-tests/t0108-object-connections.scm
:000000 100644 0000000... c5a917f... A libgeda/scheme/unit-tests/t0109-object-copy.scm
:000000 100644 0000000... 0837c92... A libgeda/scheme/unit-tests/t0200-page.scm
:000000 100644 0000000... b450ed8... A libgeda/scheme/unit-tests/t0201-page-dirty.scm
:000000 100644 0000000... d63cc07... A libgeda/scheme/unit-tests/t0300-attribute.scm
:000000 100644 0000000... ba6d668... A libgeda/scheme/unit-tests/t0301-promotable-attributes.scm
commit 9ac7ddffcdd09ae0bbf9c62af0457ff957510081
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Minor documentation fix-ups.
Corrected encoding, made CC licence URL a proper link, and corrected
case.
:100644 100644 34dac8e... 1eae5e0... M docs/scheme-api/geda-scheme.texi
commit 2fa4f5712cf6decb4bf3b90002634ba607b1aec4
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: gschem API documentation (misc).
:100644 100644 10a021b... 34dac8e... M docs/scheme-api/geda-scheme.texi
commit 4f6d3a0fd5810d8fabd93a1629495f5c916ae4d3
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: gschem API documentation (hooks).
:100644 100644 f1e323a... 10a021b... M docs/scheme-api/geda-scheme.texi
:100644 100644 0640b7e... 3251895... M gschem/scheme/gschem/hook.scm
commit e53af99b5b907819da60a2f6d7666038d351ddd6
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: gschem API documentation (selections).
:100644 100644 d0b8d13... f1e323a... M docs/scheme-api/geda-scheme.texi
commit 01e10f7f71a380e2c6aa192d4da6bf8204cbfe2f
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: gschem API documentation (windows and views).
:100644 100644 49165eb... d0b8d13... M docs/scheme-api/geda-scheme.texi
commit 7c88e88e38bcd20f6ad3e46604f2b117b6fef0a6
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (attributes).
:100644 100644 3e22737... 49165eb... M docs/scheme-api/geda-scheme.texi
:100644 100644 09eeb7b... 11ae368... M libgeda/scheme/geda/attrib.scm
commit dd5b9c7c08307104ce360661f6e696ce87c77389
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (component objects).
:100644 100644 38cb0d7... 3e22737... M docs/scheme-api/geda-scheme.texi
:100644 100644 3d0b414... e3bceb8... M libgeda/scheme/geda/object.scm
commit 224e3edec54febcf055810e6d4220369e50f1ade
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (text objects).
:100644 100644 5f91e76... 38cb0d7... M docs/scheme-api/geda-scheme.texi
:100644 100644 ca84434... 3d0b414... M libgeda/scheme/geda/object.scm
commit 1e9d73ec74c6abd2ddfcf18cccadc9c0c44ff7ff
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (picture and path objects).
:100644 100644 787e765... 5f91e76... M docs/scheme-api/geda-scheme.texi
:100644 100644 ec04e9f... ca84434... M libgeda/scheme/geda/object.scm
commit 832af3a116fd37db9c8a647918179522ee0a10ab
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (arc objects).
:100644 100644 762c73b... 787e765... M docs/scheme-api/geda-scheme.texi
commit be7d5d316bbf944f9e0a618ddff795a073de9183
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (circle objects).
:100644 100644 464af48... 762c73b... M docs/scheme-api/geda-scheme.texi
:100644 100644 b742ce1... ec04e9f... M libgeda/scheme/geda/object.scm
commit e7ed5291067d56419efe3764190d22fa7714937e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (box objects).
:100644 100644 b8d985b... 464af48... M docs/scheme-api/geda-scheme.texi
:100644 100644 0df5a32... b742ce1... M libgeda/scheme/geda/object.scm
commit b1ca0b60c9218db51132272ffdf0c1815d29b80f
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (pin objects).
:100644 100644 10f50d5... b8d985b... M docs/scheme-api/geda-scheme.texi
:100644 100644 2ceefdd... 0df5a32... M libgeda/scheme/geda/object.scm
commit 623b9fe2ad30c517053b2c8b40723435903e2474
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (net and bus objects).
:100644 100644 3433ec0... 10f50d5... M docs/scheme-api/geda-scheme.texi
commit 37338045adf382ecef00d5ee5f337c4da250b996
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (line objects).
:100644 100644 023860b... 3433ec0... M docs/scheme-api/geda-scheme.texi
:100644 100644 da6eff8... 2ceefdd... M libgeda/scheme/geda/object.scm
commit fd1e63aefad0097b1f99cf6cdb31998efec5c407
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (general objects).
:100644 100644 a11db60... 023860b... M docs/scheme-api/geda-scheme.texi
:100644 100644 695dd02... da6eff8... M libgeda/scheme/geda/object.scm
commit bcd036f9432335473d5ad64e18d83df669947eb3
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (pages).
:100644 100644 f44d6fb... a11db60... M docs/scheme-api/geda-scheme.texi
:100644 100644 1738b26... 556f52f... M libgeda/scheme/geda/page.scm
commit 4a3a197ab3519928c1fdb2b31a0cbc272ba75f12
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add documentation skeleton.
:100644 100644 1f2c9fb... 01a65e1... M configure.ac
:100644 100644 9e295f7... d65b9e9... M docs/Makefile.am
:000000 100644 0000000... deef157... A docs/scheme-api/Makefile.am
:000000 100644 0000000... f44d6fb... A docs/scheme-api/geda-scheme.texi
commit 008ba78fc1a60641b620cabc9ecc198cd0a2225c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make promote-attribs! return '() for non-components.
:100644 100644 58ec01b... 09eeb7b... M libgeda/scheme/geda/attrib.scm
:100644 100644 8f61f6a... ba6d668... M libgeda/scheme/unit-tests/t0031-promotable-attributes.scm
commit c0125211b863d0d54554c39abda8c76f7ad27fae
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make %detach-attrib! succeed when not attached.
%detach-attrib! claims to succeed when attempting to detach an
attribute that's not attached to anything, but it lies.
:100644 100644 a82d046... d63cc07... M libgeda/scheme/unit-tests/t0030-attribute.scm
:100644 100644 6167dc0... 1c5f0f4... M libgeda/src/scheme_attrib.c
commit 1d97d6c9cad63a79bceaa9d599a757c01f1a60e7
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make %attach-attrib! succeed when already attached.
Instead of raising an object-state exception when trying to create an
attribute attachment that already exists, succeed silently.
:100644 100644 803fa50... a82d046... M libgeda/scheme/unit-tests/t0030-attribute.scm
:100644 100644 c9b2743... 6167dc0... M libgeda/src/scheme_attrib.c
commit dce70c5e826e2958d02a5bf8089b7dd1eb3a519f
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Replace attach-attrib! and detach-attrib!.
For consistency with the functions for adding and removing objects to
pages and components, this patch makes the following changes:
- Replace attach-attrib! with attach-attribs! which takes multiple
attribute arguments.
- Replace detach-attrib! with detach-attribs! which takes multiple
attribute arguments.
- Make attach-attrib! and detach-attrib! return the target object
rather than the affected attributes.
:100644 100644 375b8f7... 58ec01b... M libgeda/scheme/geda/attrib.scm
:100644 100644 6cdb240... 09cf92f... M libgeda/scheme/unit-tests/t0015-object-complex.scm
:100644 100644 ed57a57... c5a917f... M libgeda/scheme/unit-tests/t0019-object-copy.scm
:100644 100644 78189c2... b450ed8... M libgeda/scheme/unit-tests/t0021-page-dirty.scm
:100644 100644 3ee3e48... 803fa50... M libgeda/scheme/unit-tests/t0030-attribute.scm
:100644 100644 d0ccb5e... 0021a9c... M libgeda/scheme/unit-tests/t1000-deprecated.scm
:100644 100644 615b0d7... c9b2743... M libgeda/src/scheme_attrib.c
commit b5046514e8c4561de9a5a249624b23e003a2988a
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make parse-attrib stricter about input.
parse-attrib now raises an attribute-format exception if input is a
text object but not in the correct format (i.e. it only returns on
success).
:100644 100644 03fe556... 375b8f7... M libgeda/scheme/geda/attrib.scm
:100644 100644 087add1... 3ee3e48... M libgeda/scheme/unit-tests/t0030-attribute.scm
:100644 100644 44dafb6... 615b0d7... M libgeda/src/scheme_attrib.c
commit 8b9f6235d72ad5be0fca53613e7ca77802543d58
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make attribute? only return #t or #f.
:100644 100644 ba77355... 03fe556... M libgeda/scheme/geda/attrib.scm
:100644 100644 b636ddb... 087add1... M libgeda/scheme/unit-tests/t0030-attribute.scm
commit 6b299b8b9f423976f746cf3694a49b9124950237
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make gschem's overridden close-page! never ask.
The original version of the overridden version of close-page! loaded
by gschem into the (geda core page) asked the user to confirm closing
of dirtied pages. It turns out that this was a really bad idea,
because it made the close-page! function impossible to document
clearly. This patch makes the behaviour of gschem's close-page! match
the core library version, i.e. close immediately without question.
:100644 100644 6ecf2ef... ca1023d... M gschem/src/g_window.c
commit c6b89e3d030a6fa061598dd467f4bee9c147c28e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Allow fold-bounds to take any number of arguments.
Also add a unit test.
:100644 100644 766762a... 695dd02... M libgeda/scheme/geda/object.scm
:100644 100644 1768879... a896b8c... M libgeda/scheme/unit-tests/t0016-object-bounds.scm
commit daaf7d90949a3ac7cfe2914aedd1bb5c170c375b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Allow %object-bounds to take no arguments.
Allow %object-bounds to take an empty argument list and return #f.
Since %object-bounds already returns #f in none of the object
arguments has any bounds, it's consistent to return #f in no arguments
are supplied.
:100644 100644 d0e025a... 766762a... M libgeda/scheme/geda/object.scm
:100644 100644 64264ec... 1768879... M libgeda/scheme/unit-tests/t0016-object-bounds.scm
:100644 100644 c3513da... 240a985... M libgeda/src/scheme_object.c
commit 7c759d21f74e89e41d08bbc871891554ec027607
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: %object-type should raise errors on bad type.
If %object-type encounters an object with an invalid type field,
%object-type should raise an error rather than logging a message and
returning #f.
Since we can't actually create an object with an invalid type field
from the Scheme API, there's sadly no way of unit-testing this change.
:100644 100644 a922494... c3513da... M libgeda/src/scheme_object.c
commit f7cc58369760991eda968571d5677e97ca2092cd
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add the set-attrib-value! function.
:100644 100644 17c9866... ba77355... M libgeda/scheme/geda/attrib.scm
:100644 100644 03d29e4... b636ddb... M libgeda/scheme/unit-tests/t0030-attribute.scm
commit e6870ce5a1aac5f2da8d6bb53495d6a52967a538
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add the set-text-string! function.
:100644 100644 99fb777... d0e025a... M libgeda/scheme/geda/object.scm
:100644 100644 9f07edb... 8642243... M libgeda/scheme/unit-tests/t0014-object-text.scm
commit ad289e2ea5d5402fd7061965a3939d33323e4292
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Add pointer-position function.
:100644 100644 50c19da... 62765ed... M gschem/scheme/gschem/window.scm
:100644 100644 0f3fb60... 6ecf2ef... M gschem/src/g_window.c
commit 0aaabc599c8146801364d5b8bc9e984ea764cc5b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Reimplement get-object-bounds in Scheme.
:100644 100644 86f0dee... 463c709... M gschem/include/prototype.h
:100644 100644 67443aa... 8a90e7d... M gschem/scheme/gschem/deprecated.scm
:100644 100644 1470381... 2b3280b... M gschem/src/g_hook.c
:100644 100644 3464101... a053a0f... M gschem/src/g_register.c
commit 22a146a4a8a221908ab531aafc1d901a3358c133
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Document object-bounds and add fold-bounds.
Fold-bounds is a function for combining two bounds as returned by the
object-bounds function.
:100644 100644 cc35975... 99fb777... M libgeda/scheme/geda/object.scm
commit 0f7d19313b0a8e2ecd7d4a5ea24ee6e0ab243d60
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Remove unused g_make_attrib_smob_list().
:100644 100644 fd1ead8... 86f0dee... M gschem/include/prototype.h
:100644 100644 ff10aa9... 1470381... M gschem/src/g_hook.c
commit 6b3c4f7f52f684e10c08ef478e341b954032c94b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Reimplement set-attribute-text-properties! in Scheme.
:100644 100644 0113de0... fd1ead8... M gschem/include/prototype.h
:100644 100644 0182554... 67443aa... M gschem/scheme/gschem/deprecated.scm
:100644 100644 bcb11ad... ff10aa9... M gschem/src/g_hook.c
:100644 100644 b7c4aa7... 3464101... M gschem/src/g_register.c
commit 0b9ce5de9589b09ec35cdf321f5ac8540f81daa1
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Reimplement get-selected-component-attributes in Scheme.
:100644 100644 0c49354... 0113de0... M gschem/include/prototype.h
:100644 100644 ea61d7e... 0182554... M gschem/scheme/gschem/deprecated.scm
:100644 100644 296a2bd... a4cf5e6... M gschem/src/g_funcs.c
:100644 100644 3ba67e8... 55344b3... M gschem/src/g_keys.c
:100644 100644 454c947... b7c4aa7... M gschem/src/g_register.c
commit c761f0ed17f915369143bcf180eafbf52076e1ae
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Reimplement add-component-at-xy in Scheme.
:100644 100644 c7d2968... 0c49354... M gschem/include/prototype.h
:100644 100644 f8f0b1e... ea61d7e... M gschem/scheme/gschem/deprecated.scm
:100644 100644 d5735ee... bcb11ad... M gschem/src/g_hook.c
:100644 100644 18fc1c9... 454c947... M gschem/src/g_register.c
commit 1cd1b3ecf56c183c6b7fd6cd968574f4a3f9c8eb
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Reimplement add-attribute-to-object in Scheme.
:100644 100644 ee6bfeb... c7d2968... M gschem/include/prototype.h
:100644 100644 d517526... f8f0b1e... M gschem/scheme/gschem/deprecated.scm
:100644 100644 13f1217... d5735ee... M gschem/src/g_hook.c
:100644 100644 fbc1b1c... 18fc1c9... M gschem/src/g_register.c
commit 4feb90789ff1394465d2d6b8a5556da2c1462a14
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Improve documentation comments in Scheme code.
:100644 100644 9013b8a... d517526... M gschem/scheme/gschem/deprecated.scm
commit c5ec85006694d354462680339dbd67499ad1f0a2
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Reimplement get-selected-filename in Scheme.
:100644 100644 7fe76a7... ee6bfeb... M gschem/include/prototype.h
:100644 100644 2017a5f... 9013b8a... M gschem/scheme/gschem/deprecated.scm
:100644 100644 400df9e... 296a2bd... M gschem/src/g_funcs.c
:100644 100644 58961ec... 3ba67e8... M gschem/src/g_keys.c
:100644 100644 c214b7c... fbc1b1c... M gschem/src/g_register.c
commit 0a5ccba701c23e0dadee78e908e9f8f09c590340
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add some more tests for copy-object.
Add two tests for copy-object: whether copying an object breaks page,
component and attribute relationships, and whether copying a component
is a deep copy.
:100644 100644 2be9762... ab946b0... M libgeda/scheme/Makefile.am
:000000 100644 0000000... ed57a57... A libgeda/scheme/unit-tests/t0019-object-copy.scm
commit 292c930244a9616642ade8a3afd4cc740c61d368
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add attrib-inherited? function.
:100644 100644 5a77984... 17c9866... M libgeda/scheme/geda/attrib.scm
:100644 100644 2c40ffc... 03d29e4... M libgeda/scheme/unit-tests/t0030-attribute.scm
commit db3b79c7659a7526acf726c457b1c2915254fc4b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add object-component function.
Add a Scheme function for obtaining an object's containing component.
:100644 100644 747d8f2... cc35975... M libgeda/scheme/geda/object.scm
:100644 100644 9d00441... 6cdb240... M libgeda/scheme/unit-tests/t0015-object-complex.scm
:100644 100644 404abd2... a922494... M libgeda/src/scheme_object.c
commit 25952c382fc199fb91502279267c45f880a55cdd
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Correct import of (gschem core attrib) module.
:100644 100644 86dd4e1... c248128... M gschem/scheme/gschem/attrib.scm
commit 5cf897c1c107dc3d0b2e4ef82d1f15cbdeb76041
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Use missing.h to pull in SCM<->C string funcs.
:100644 100644 bd447f2... 9076c5d... M gschem/src/g_attrib.c
:100644 100644 42fe3c7... bb864c2... M gschem/src/g_hook.c
:100644 100644 607a5f7... ad8244d... M libgeda/include/libgedaguile_priv.h
commit 1a96308dcf365d4cad0de8373beb108c14dfeae2
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add add-attrib! function.
Add convenience Scheme API function in gschem to shadow the
o_attrib_add_attrib() C function. Although most of the behaviour of
this function could be provided in pure Scheme, it would be somewhat
annoying to have two lots of code which do the same thing. Also, the
slotting mess is still in C only.
:100644 100644 db4901e... 7fe76a7... M gschem/include/prototype.h
:100644 100644 19e8812... 53902d1... M gschem/scheme/Makefile.am
:000000 100644 0000000... 86dd4e1... A gschem/scheme/gschem/attrib.scm
:100644 100644 3ef894f... 5a1f118... M gschem/src/Makefile.am
:000000 100644 0000000... bd447f2... A gschem/src/g_attrib.c
:100644 100644 2823cc4... ec3452a... M gschem/src/gschem.c
commit c603a85e1cdd63f770a19fb23d2fab49c14b3d0b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add promote-attribs! function.
Add a function to promote any promotable attributes from a component.
:100644 100644 ba960c2... 5a77984... M libgeda/scheme/geda/attrib.scm
:100644 100644 5524fce... 8f61f6a... M libgeda/scheme/unit-tests/t0031-promotable-attributes.scm
commit cc1a3d0209a83aaa82404f41e42bb8a2c0c098b9
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add set-text-visibility! function.
Helper function for toggling visibility of a text object.
:100644 100644 d819cc7... 747d8f2... M libgeda/scheme/geda/object.scm
:100644 100644 3808237... 9f07edb... M libgeda/scheme/unit-tests/t0014-object-text.scm
commit f5040254fe52ef181ff8bd205c33315b00e76c2c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Correct error messages from %set-text!
:100644 100644 1930d11... 404abd2... M libgeda/src/scheme_object.c
commit 30bfe114148d52155ae96226dfcd22484f8629c7
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
build-sys: Remove unused separate guile-snarf macro file.
:100644 100644 406aa53... 388a2d7... M configure.ac
:100644 000000 0956a24... 0000000... D m4/geda-guile-snarf.m4
commit 623341482a94b2f92e662dd8e9ff8f6a218f42cc
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Use UTF-8 instead of locale Scheme string functions.
See commit 09c6613f93b6.
:100644 100644 6f3c678... 42fe3c7... M gschem/src/g_hook.c
:100644 100644 6059b20... 44dafb6... M libgeda/src/scheme_attrib.c
:100644 100644 643316c... 016a8f6... M libgeda/src/scheme_complex.c
:100644 100644 ee0283b... 1930d11... M libgeda/src/scheme_object.c
:100644 100644 f866936... 71a2139... M libgeda/src/scheme_page.c
commit 4bccef20f38b43da0d9916f63601dec35fd5b33c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Better hook behaviour for "Select All".
Run select-objects-hook for all objects selected by the "Select All"
operation at once, not one at a time.
:100644 100644 d1e38b0... 585a85b... M gschem/src/o_select.c
commit 0d5ec53d5ce3baa3004bd1dbfea2f33c4d4abece
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Enable new-page-hook.
This varies slightly from the original behaviour, in that it is only
called when a *new* page is created (e.g. through File->New), and not
on page load.
:100644 100644 a4348ee... 07938ae... M gschem/include/globals.h
:100644 100644 5d864c8... db4901e... M gschem/include/prototype.h
:100644 100644 532f93b... f43eb5d... M gschem/lib/system-gschemrc.scm
:100644 100644 1757ad7... 6f3c678... M gschem/src/g_hook.c
:100644 100644 eaa0bec... c214b7c... M gschem/src/g_register.c
:100644 100644 dc3ec51... 8496cf2... M gschem/src/globals.c
:100644 100644 5a64606... d9f96e5... M gschem/src/x_window.c
commit d8abb509c60de0fbd4c288ff7fa9c32c2448f1cf
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Enable select-objects-hook and deselect-objects-hook.
Not a brilliant implementation -- calls hooks one object at a time
even when a large number of objects are selected/deselected. But it
works.
:100644 100644 c8244da... a4348ee... M gschem/include/globals.h
:100644 100644 3be0560... 5d864c8... M gschem/include/prototype.h
:100644 100644 1dbf872... 2017a5f... M gschem/scheme/gschem/deprecated.scm
:100644 100644 19c447b... eaa0bec... M gschem/src/g_register.c
:100644 100644 3c3f930... dc3ec51... M gschem/src/globals.c
:100644 100644 7bab2d1... ae163c5... M gschem/src/o_attrib.c
:100644 100644 95a8a13... d1e38b0... M gschem/src/o_select.c
commit b4a75a6ebc480d866d2b268059de04cfcecff40f
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Enable attach-attribs-hook and detach-attribs-hook.
:100644 100644 851d021... f8db1bb... M gschem/src/i_callbacks.c
commit 228f6b55dc0d95e2a9695fc9cbb019099811524f
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Enable move-objects-hook and paste-objects-hook.
:100644 100644 23e9555... c8244da... M gschem/include/globals.h
:100644 100644 ce86084... 1dbf872... M gschem/scheme/gschem/deprecated.scm
:100644 100644 48aece2... 19c447b... M gschem/src/g_register.c
:100644 100644 c96f53c... 3c3f930... M gschem/src/globals.c
:100644 100644 0c65b7c... e726458... M gschem/src/o_copy.c
:100644 100644 5017d7e... 00865ed... M gschem/src/o_move.c
:100644 100644 38e65d6... 0eaf6c5... M gschem/src/x_event.c
commit 91e869f566c82cf2bcd9c501bad2060a257c2192
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Enable mirror-objects-hook and rotate-objects-hook.
:100644 100644 d115e98... 23e9555... M gschem/include/globals.h
:100644 100644 0112ffe... 3be0560... M gschem/include/prototype.h
:100644 100644 bc843f0... ce86084... M gschem/scheme/gschem/deprecated.scm
:100644 100644 0fa8cff... 48aece2... M gschem/src/g_register.c
:100644 100644 4a26001... c96f53c... M gschem/src/globals.c
:100644 100644 d72eee7... 49b7161... M gschem/src/o_misc.c
:100644 100644 ad2dd61... 3cfc1da... M gschem/src/o_place.c
commit d0467a2c5c6fde4155bfc57f0345bbb162e1b4c7
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Enable remove-objects-hook.
:100644 100644 970612d... 94f9039... M gschem/src/o_delete.c
:100644 100644 3623b09... e605c81... M gschem/src/x_autonumber.c
:100644 100644 3bf73a5... e00cde9... M gschem/src/x_multiattrib.c
commit 05954f101e9ae90193150e030fb66c1b3d32e44b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Enable add-objects-hook.
:100644 100644 1cb9198... d115e98... M gschem/include/globals.h
:100644 100644 6659ead... 0112ffe... M gschem/include/prototype.h
:100644 100644 33d494f... bc843f0... M gschem/scheme/gschem/deprecated.scm
:100644 100644 9d61a1e... 1757ad7... M gschem/src/g_hook.c
:100644 100644 a24d122... 0fa8cff... M gschem/src/g_register.c
:100644 100644 f8beac3... 4a26001... M gschem/src/globals.c
:100644 100644 83e6c8f... 6e15530... M gschem/src/o_arc.c
:100644 100644 b88026f... 7bab2d1... M gschem/src/o_attrib.c
:100644 100644 6537679... 110421a... M gschem/src/o_box.c
:100644 100644 63aace2... 666669e... M gschem/src/o_bus.c
:100644 100644 95790b8... 815dfcb... M gschem/src/o_circle.c
:100644 100644 e1460bf... 05e4cb3... M gschem/src/o_complex.c
:100644 100644 3039206... 0c65b7c... M gschem/src/o_copy.c
:100644 100644 a3b7cc5... 81dfe95... M gschem/src/o_line.c
:100644 100644 5459ca0... d4b1b27... M gschem/src/o_net.c
:100644 100644 044009a... d64b949... M gschem/src/o_picture.c
:100644 100644 3cf12d7... f2a5ea7... M gschem/src/o_pin.c
:100644 100644 ef65d2c... ad2dd61... M gschem/src/o_place.c
:100644 100644 9f99e9c... 55dffa4... M gschem/src/o_slot.c
:100644 100644 5cacc17... 38e65d6... M gschem/src/x_event.c
:100644 100644 4ca7125... 3bf73a5... M gschem/src/x_multiattrib.c
commit 62f51dcfeb8a08288bc1854fd1d49e667b03f490
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Start implementing simplified hook system.
Rather than the current hook system, which uses misleading hook names
and is only useful for a limited range of use cases, use a smaller
number of more general hooks.
:100644 100644 f80b01c... 6659ead... M gschem/include/prototype.h
:100644 100644 9f8a559... 19e8812... M gschem/scheme/Makefile.am
:000000 100644 0000000... 0640b7e... A gschem/scheme/gschem/hook.scm
:100644 100644 2ec57a0... 3ef894f... M gschem/src/Makefile.am
:100644 100644 8a65e04... 9d61a1e... M gschem/src/g_hook.c
:100644 100644 e2624b6... 63553e2... M gschem/src/gschem.c
commit 1121d83a5450ad9040cabb7ef9a8cfb6c2a395f3
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Only use (ice-9 syncase) if define-syntax missing.
In Guile 2.0, syntax-case is built in by default and importing the
(ice-9 syncase) module isn't required.
:100644 100644 9c0e103... d63bf19... M gnetlist/scheme/gnet-drc2.scm
:100644 100644 dcf2938... 532f93b... M gschem/lib/system-gschemrc.scm
:100644 100644 ccde6da... 2849c8b... M libgeda/scheme/unit-test.scm
:100644 100644 27bbd5d... 78189c2... M libgeda/scheme/unit-tests/t0021-page-dirty.scm
commit cbdeedd05e825c0d11080392c16cd86a1968ba73
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Change format of unit test output.
If running a test caused output to stdout or stderr, it was interposed
between the name of the test and the result. This patch makes the
name and result of the test be printed together after the result has
been determined, resulting in tidier output.
:100644 100644 cb0ee15... ccde6da... M libgeda/scheme/unit-test.scm
commit 14eab2daf97f03ef7cdb26c2c3e8969f99b22a70
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add skip-test macro to unit-test.scm
:100644 100644 48fb271... cb0ee15... M libgeda/scheme/unit-test.scm
commit e9f2f0b1285b877a12f0338635af0eade60c7c68
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Fix (gschem deprecated) module.
The set-attribute-value! function contained a let with invalid syntax.
Guile 2.0 rightly gets upset by this.
:100644 100644 7405185... 33d494f... M gschem/scheme/gschem/deprecated.scm
commit 0344623ea013e54a15735988b75508c07469d4d8
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make tests work with Guile 2.0.
#:use-syntax doesn't work with Guile 2.0, apparently.
:100644 100644 f7cf499... 48fb271... M libgeda/scheme/unit-test.scm
commit 9415bf958a9cf16461733be58d0f8f257b5b4726
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gnetlist: Fix up tests to work with new Scheme API.
Now that gnetlist supports the -L <path> option to add to the Guile
load path, it's possible to make in-tree and out-of-tree builds pass
`make check'.
:100644 100644 ff06ae7... 2bd1117... M gnetlist/tests/Makefile.am
:100644 100644 a7438ae... 3d3665e... M gnetlist/tests/drc2/Makefile.am
:100644 100644 c11abd3... 33a6889... M gnetlist/tests/hierarchy/Makefile.am
:100644 100644 122cb2e... 8fb1ecd... M gnetlist/tests/hierarchy2/Makefile.am
:100755 100755 b0ff718... 713e5ae... M gnetlist/tests/runtest.sh
commit e67d080a7c48dd1300c90c93d8b1723958244a2d
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
libgeda: cleanfiles -> CLEANFILES
Wrong case in automake input resulted in some generated files not
being removed during `make clean'.
:100644 100644 9e6f33f... badcc4f... M libgeda/shell/Makefile.am
commit 694ccbdec90765ca4cb9b2dbcb1bbe7cdfba2f0b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: OBJECT.sel_func doesn't exist any more.
:100644 100644 d76539a... 643316c... M libgeda/src/scheme_complex.c
commit 19963e962d5baf1cad6de44a2e411f7e5610159c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gnetlist: Fix testsuite for Scheme API branch.
Some Scheme procedures used by gnetlist were moved to the (geda
deprecated) module, but the relevant Scheme files couldn't be found by
the gnetlist testsuite. This patch makes sure the gnetlist
environment gets set up correctly.
:100644 100644 eaa83ef... 1f82279... M gnetlist/scheme/gnetlist.scm
:100644 100644 e5072b9... 0f99185... M gnetlist/tests/common/inputs/gafrc
:100755 100755 219e3b1... 1882634... M gnetlist/tests/common/run_backend_tests.sh
commit b08d9d08ee4740884de97e87179a9809d6b3dba3
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
libgeda: Use new config parsing API for geda-shell.
:100644 100644 611750e... b125425... M libgeda/shell/shell.c
commit f9156f1642e0a24661f06cc335178a14d5fa7b1c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Remove some legacy Scheme functions.
Remove some trivially-replaced Scheme functions from gschem to the
(gschem deprecated) module.
:100644 100644 08f2d90... 8f199c8... M gschem/include/prototype.h
:100644 100644 87ca831... 7405185... M gschem/scheme/gschem/deprecated.scm
:100644 100644 c6ee1f0... 8ffc5ef... M gschem/src/g_hook.c
:100644 100644 3e9b09a... dcaaa61... M gschem/src/g_register.c
commit cb21936a1e620374a04c4f058458fa72f9933e67
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Make 7-byte SHA-1 prefix using %.7s format specifier.
:100644 100644 2634004... 611750e... M libgeda/shell/shell.c
commit b70513b5260d14e22dde1bc73c9f6c61dbbeb5ca
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Give geda-shell program -V argument to match gschem.
:100644 100644 9335e37... 2634004... M libgeda/shell/shell.c
commit 8c4d33a5f7835b477d6e485ef47ca8c1db3f16a8
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
build-sys: Check for guile-1.8-snarf for OS X builds.
On OS X, guile-snarf is called guile-1.8-snarf.
Reported-by: Matthew Wampler-Doty <matt@xxxxxxx>
:100644 100644 8c9e92b... 0956a24... M m4/geda-guile-snarf.m4
commit a3433b6a4c088b8926f8768e20eff18d0dafea4b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Remove most legacy libgeda Scheme types & functions.
Removes most of the legacy Scheme types, functions and definitions
from libgeda, replacing them with compatible equivalents based on the
new Scheme API. The remaining Scheme functions are those for working
with the component and source libraries, the various rc functions, and
the eval-* functions, all of which need to be revisited at a later
date.
Also removes set-attribute-value! from gschem and reimplements in
Scheme, since it was sole user of g_set_attrib_value_internal() and it
was easier to replace than rewrite.
:100644 100644 cfc4352... 08f2d90... M gschem/include/prototype.h
:100644 100644 64861fe... 860cf2a... M gschem/lib/system-gschemrc.scm
:100644 100644 0cd3142... 9f8a559... M gschem/scheme/Makefile.am
:000000 100644 0000000... 87ca831... A gschem/scheme/gschem/deprecated.scm
:100644 100644 52cfeaf... c6ee1f0... M gschem/src/g_hook.c
:100644 100644 19f7920... 3e9b09a... M gschem/src/g_register.c
:100644 100644 90d87d0... 100b377... M libgeda/include/libgeda/prototype.h
:100644 100644 14f0c34... 607a5f7... M libgeda/include/libgedaguile_priv.h
:100644 100644 a301128... 16ef560... M libgeda/include/prototype_priv.h
:100644 100644 f238fb1... cfcc6af... M libgeda/lib/system-gafrc
:100644 100644 62fa399... 2be9762... M libgeda/scheme/Makefile.am
:000000 100644 0000000... 5d84e13... A libgeda/scheme/geda/deprecated.scm
:100644 100644 21b67ca... d0ccb5e... M libgeda/scheme/unit-tests/t1000-deprecated.scm
:100644 100644 4619dcd... 8dff2ab... M libgeda/src/Makefile.am
:100644 100644 b69b9d5... 3a33740... M libgeda/src/g_register.c
:100644 000000 04c4139... 0000000... D libgeda/src/g_smob.c
:100644 100644 fc43fb7... ae2a5cd... M libgeda/src/libgeda.c
:000000 100644 0000000... 3a49607... A libgeda/src/scheme_deprecated.c
:100644 100644 26a6e20... 927b3d5... M libgeda/src/scheme_init.c
commit a0adbfc6bbc79cb7ac9cc2dd1c894ad0cdc0b872
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add unit tests for legacy Scheme API.
These will be used to verify that replacement functions based on new
Scheme API are compatible with the originals.
:100644 100644 16657f9... 62fa399... M libgeda/scheme/Makefile.am
:000000 100644 0000000... 21b67ca... A libgeda/scheme/unit-tests/t1000-deprecated.scm
commit fc8bcac43b6f3dd611f6030ffe36465d67be379d
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Port legacy Scheme procedures in C to new smob system.
Make all users of legacy Scheme smobs in libgeda use new Scheme smob
system. This is a preliminary patch so that unit tests can be written
to verify that functions ported to new API work the same way as the
originals.
:100644 100644 d5cae12... 295a3d8... M gnetlist/src/g_netlist.c
:100644 100644 03a0d66... 52cfeaf... M gschem/src/g_hook.c
:100644 100644 348d631... 23507f2... M gschem/src/o_attrib.c
:100644 100644 10f8dbb... 7ec586e... M gschem/src/o_complex.c
:100644 100644 2890bff... fe4b589... M gschem/src/o_misc.c
:100644 100644 14345d7... 79eb3fa... M gschem/src/o_pin.c
:100644 100644 ee17b00... 07a4029... M gschem/src/x_window.c
:100644 100644 c7d9707... 90d87d0... M libgeda/include/libgeda/prototype.h
:100644 100644 ea0980f... 04c4139... M libgeda/src/g_smob.c
commit a21ee2882d662a50418561f8de101d44bba7294c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Show "(null)" instead of "0" when printing deleted smobs.
:100644 100644 de46fb0... f3a90f2... M libgeda/src/scheme_smob.c
commit 7f85f28e67c59dbccb0f2a321794b0ddbb3e578f
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Add e-mail address to copyright headers.
:100644 100644 9f33f73... 4acdef2... M gschem/scheme/gschem/selection.scm
:100644 100644 94254a1... 50c19da... M gschem/scheme/gschem/window.scm
:100644 100644 9ec9a55... 8e5a0c3... M gschem/src/g_select.c
:100644 100644 ec30f1c... 0f3fb60... M gschem/src/g_window.c
:100644 100644 6623d75... ba960c2... M libgeda/scheme/geda/attrib.scm
:100644 100644 bc12810... d819cc7... M libgeda/scheme/geda/object.scm
:100644 100644 e192cd1... 1738b26... M libgeda/scheme/geda/page.scm
commit 0a5c0a4f0d9e721bdf198c400db3cef607e72c33
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Multiple arguments for component & page append/remove.
It's a lot more convenient to write:
(component-append! component x y z ...)
than:
(for-each (lambda (x) (component-append! C x)) (list x y z ...))
So this patch makes it possible.
:100644 100644 611e846... bc12810... M libgeda/scheme/geda/object.scm
:100644 100644 17fcbaf... e192cd1... M libgeda/scheme/geda/page.scm
:100644 100644 ebcd7cd... 9d00441... M libgeda/scheme/unit-tests/t0015-object-complex.scm
:100644 100644 74595fe... 3665f34... M libgeda/scheme/unit-tests/t0018-object-connections.scm
:100644 100644 151338e... 0837c92... M libgeda/scheme/unit-tests/t0020-page.scm
:100644 100644 2de00c5... 27bbd5d... M libgeda/scheme/unit-tests/t0021-page-dirty.scm
:100644 100644 0a6fc07... 2c40ffc... M libgeda/scheme/unit-tests/t0030-attribute.scm
:100644 100644 53b342c... d76539a... M libgeda/src/scheme_complex.c
:100644 100644 5d017ba... f866936... M libgeda/src/scheme_page.c
commit 6359f03b8615d707b122d84c6e73ae6bf99c097b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme_api: Give modifying functions _x suffixes in C.
When Scheme functions modify their arguments or have side-effects,
they use a `!' at the end of the function name. In C, this is
commonly represented with a _x suffix. This patch adopts that
convention.
:100644 100644 b41edc9... 9ec9a55... M gschem/src/g_select.c
:100644 100644 0ce352f... ec30f1c... M gschem/src/g_window.c
:100644 100644 84df721... 6059b20... M libgeda/src/scheme_attrib.c
:100644 100644 189dc91... 53b342c... M libgeda/src/scheme_complex.c
:100644 100644 57272ea... ee0283b... M libgeda/src/scheme_object.c
:100644 100644 4af275e... 5d017ba... M libgeda/src/scheme_page.c
commit c7d44a2507edb830e1592d9390cb32ad5fb658b4
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Promote attributes from components.
:100644 100644 1b62ff7... a301128... M libgeda/include/prototype_priv.h
:100644 100644 49d93ab... 16657f9... M libgeda/scheme/Makefile.am
:100644 100644 efc266e... 6623d75... M libgeda/scheme/geda/attrib.scm
:000000 100644 0000000... 5524fce... A libgeda/scheme/unit-tests/t0031-promotable-attributes.scm
:100644 100644 8d54af4... 971707c... M libgeda/src/o_complex_basic.c
:100644 100644 af23c32... 84df721... M libgeda/src/scheme_attrib.c
commit f8b371c8732f128c09fda366916f48d4a3ae8873
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Get inherited attribs from components.
:100644 100644 8ccad6b... efc266e... M libgeda/scheme/geda/attrib.scm
:100644 100644 eded1be... 0a6fc07... M libgeda/scheme/unit-tests/t0030-attribute.scm
commit c397394b68b27672d1af14d777eea35636b3b365
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make component/library test succeed for out-of-tree builds
:100644 100644 59b46f8... ebcd7cd... M libgeda/scheme/unit-tests/t0015-object-complex.scm
commit 780a175f4cff04a4f1b79332b6f604b7d95851ab
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add missing unit test file.
t0018-object-connections.scm was omitted from commit d8110db394f5.
:000000 100644 0000000... 74595fe... A libgeda/scheme/unit-tests/t0018-object-connections.scm
commit bf643e97eef4919fb11aace7dd597d0b092170cb
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Test if an object is selected.
An obvious omission from commit 85753049b2b9.
:100644 100644 9cbfeb0... 9f33f73... M gschem/scheme/gschem/selection.scm
:100644 100644 83aff1a... b41edc9... M gschem/src/g_select.c
commit d8110db394f56139a4fb75c6447024a28fc12913
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Find connected objects.
Adds a Scheme C procedure for accessing objects that are immediately
connected to an object.
:100644 100644 8030565... 49d93ab... M libgeda/scheme/Makefile.am
:100644 100644 6e44bd5... 611e846... M libgeda/scheme/geda/object.scm
:100644 100644 3b0adc6... 189dc91... M libgeda/src/scheme_complex.c
:100644 100644 fa02519... 57272ea... M libgeda/src/scheme_object.c
commit 85753049b2b9455d815ede96dca161cb0de2f22b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Access to gschem selection.
Makes it possible to retrieve and modify the current selection in
gschem from Scheme code.
:100644 100644 19f5f80... cfc4352... M gschem/include/prototype.h
:100644 100644 6e3e0b4... 0cd3142... M gschem/scheme/Makefile.am
:000000 100644 0000000... 9cbfeb0... A gschem/scheme/gschem/selection.scm
:100644 100644 addd4fd... 1412858... M gschem/src/Makefile.am
:000000 100644 0000000... 83aff1a... A gschem/src/g_select.c
:100644 100644 4c33137... 580f6bb... M gschem/src/gschem.c
commit d1d4dbf5841368874215b7ef102090ce4dfc0780
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Correct some comments.
:100644 100644 7023097... 94254a1... M gschem/scheme/gschem/window.scm
:100644 100644 9ba3a61... 0ce352f... M gschem/src/g_window.c
commit 3c2636864cc838286d31799d800f13c4f38f6d07
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Don't select placed objects.
Stop o_place_end() from modifying the selection. This makes the
behaviour when placing text and components consistent with the
behaviour when placing other objects.
:100644 100644 fd3abc3... fdb6d6e... M gschem/src/o_place.c
commit 7dacbe7ca2c9d7a209a5f5cc474c58a4cb9a6c24
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Make Scheme command entry text box full width of window.
Makes it easier to see what you're doing when playing with Scheme
functions in gschem.
:100644 100644 79e882e... ee17b00... M gschem/src/x_window.c
commit e92b66a8f48a565ae2b8de8d13601b7f54e84bad
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Get and set object fill parameters.
:100644 100644 0040c53... 6e44bd5... M libgeda/scheme/geda/object.scm
:100644 100644 f90e4ca... ecf74c3... M libgeda/scheme/unit-tests/t0017-object-stroke-fill.scm
:100644 100644 69a81cb... fa02519... M libgeda/src/scheme_object.c
commit 709b2707e3ec79422f0485b6e381b5cbc351905e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Simplify generation of unit test failure messages.
Use (simple-format #f msg ...) instead of (with-output-to-string
thunk) to generate unit test failure messages.
:100644 100644 39ac84a... f7cf499... M libgeda/scheme/unit-test.scm
commit 5ee02960cb8cc90c6c6fd946c53cdf94b0b46b0e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Make new C files translatable.
Also marks an new error message in gschem as translatable.
:100644 100644 26bbea7... 3a28705... M gschem/po/POTFILES.in
:100644 100644 aa76707... 9ba3a61... M gschem/src/g_window.c
:100644 100644 41a2a2b... 5a34ae5... M libgeda/po/POTFILES.in
commit d1794e3a90d0774782d3ae37101db984db1038db
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Get and set object stroke parameters.
:100644 100644 45efd6b... 8030565... M libgeda/scheme/Makefile.am
:100644 100644 b7081af... 0040c53... M libgeda/scheme/geda/object.scm
:000000 100644 0000000... f90e4ca... A libgeda/scheme/unit-tests/t0017-object-stroke-fill.scm
:100644 100644 ce31ada... 69a81cb... M libgeda/src/scheme_object.c
commit 68ea0f2273be05499512a1b2a3e557e93c049724
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Get object bounds.
:100644 100644 fa18dea... 45efd6b... M libgeda/scheme/Makefile.am
:100644 100644 4cf1135... b7081af... M libgeda/scheme/geda/object.scm
:000000 100644 0000000... 64264ec... A libgeda/scheme/unit-tests/t0016-object-bounds.scm
:100644 100644 6a789ae... ce31ada... M libgeda/src/scheme_object.c
commit 51afd1e9f5ff6d09e9066e2cc0f7eefab3a79002
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Change page filenames.
:100644 100644 ca7dae0... 17fcbaf... M libgeda/scheme/geda/page.scm
:100644 100644 c059cae... 151338e... M libgeda/scheme/unit-tests/t0020-page.scm
:100644 100644 1d696be... 4af275e... M libgeda/src/scheme_page.c
commit bb9e4bcd4d3e5b9b598105f7f6f1aecae880783b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Delete guile-snarf output files during distclean.
:100644 100644 f858c55... 2216b76... M gschem/src/Makefile.am
:100644 100644 f2da672... 9e6f33f... M libgeda/shell/Makefile.am
:100644 100644 7eee9e9... 4619dcd... M libgeda/src/Makefile.am
commit 19fbd43464e59cbbed0fb98371b1daf5b3edc363
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Include <libgedaguile.h> by default.
:100644 100644 ad69118... 60115dc... M gschem/include/gschem.h
:100644 100644 894753b... d4df053... M gschem/src/g_funcs.c
:100644 100644 a979255... 03a0d66... M gschem/src/g_hook.c
:100644 100644 e702739... aa76707... M gschem/src/g_window.c
commit 420c5126609f2f2f409cbfad50afd2949836fe6e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
libgeda: Calculate bounds correctly for empty components.
:100644 100644 9322634... 8d54af4... M libgeda/src/o_complex_basic.c
commit 9042448ea44521adc53375fdfc3d50641da0565a
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make object & attrib modifications dirty current page.
:100644 100644 37e6371... 14f0c34... M libgeda/include/libgedaguile_priv.h
:100644 100644 f579a0e... 2de00c5... M libgeda/scheme/unit-tests/t0021-page-dirty.scm
:100644 100644 0816136... af23c32... M libgeda/src/scheme_attrib.c
:100644 100644 f094f7a... 3b0adc6... M libgeda/src/scheme_complex.c
:100644 100644 cb92032... 6a789ae... M libgeda/src/scheme_object.c
commit b1056b243513171194ad2e68894d2f618eef6d76
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Improve unit tests for attribute attachment/detachment.
:100644 100644 35be33e... eded1be... M libgeda/scheme/unit-tests/t0030-attribute.scm
commit d72e2913f90edf2c02df614fa140c7d13c252362
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Remove primitives from components that are in pages.
The API currently erroneously throws an error when attempting to
remove a primitive object from a component that is attached to a page.
:100644 100644 849dbc1... 59b46f8... M libgeda/scheme/unit-tests/t0015-object-complex.scm
:100644 100644 c507e77... f094f7a... M libgeda/src/scheme_complex.c
commit 6eb023e46dc54a0b702cc9d9616325bf4e25ead4
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Inspect and modify a page's `CHANGED' flag.
:100644 100644 5b548d6... fa18dea... M libgeda/scheme/Makefile.am
:100644 100644 ffed74d... ca7dae0... M libgeda/scheme/geda/page.scm
:000000 100644 0000000... f579a0e... A libgeda/scheme/unit-tests/t0021-page-dirty.scm
:100644 100644 c255266... 1d696be... M libgeda/src/scheme_page.c
commit c759a14672a1ee047c8d27f2d9c39339c88da18e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Closing pages.
Since it's possible to create new pages from the Scheme API, it's also
useful to be able to close them. This patch adds the close-page!
function to the (geda page) module.
It's necessary for gschem to provide a slightly different
implementation of close-page! which allows for the GUI to be updated
and for the user to be prompted to save changes. To do this, gschem
uses Guile module reflection to change the binding of the close-page!
function during startup.
:100644 100644 b5fdc24... 7023097... M gschem/scheme/gschem/window.scm
:100644 100644 c324808... e702739... M gschem/src/g_window.c
:100644 100644 c335f84... ffed74d... M libgeda/scheme/geda/page.scm
:100644 100644 2154375... c059cae... M libgeda/scheme/unit-tests/t0020-page.scm
:100644 100644 c298c68... c255266... M libgeda/src/scheme_page.c
commit 5d9ca02072ba4309352e39d209f252142a96e0af
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Translate primitive objects in %complex-set!
%complex-set! needs to translate the primitive objects that make up a
complex when its position changes.
:100644 100644 1ac9c49... 849dbc1... M libgeda/scheme/unit-tests/t0015-object-complex.scm
:100644 100644 a6ee505... c507e77... M libgeda/src/scheme_complex.c
commit ee046f0a7c277d65ecb9edad6de5aeac0b81ba52
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Create components from the component library.
:100644 100644 6cd95ca... 4cf1135... M libgeda/scheme/geda/object.scm
:100644 100644 6c200c1... 1ac9c49... M libgeda/scheme/unit-tests/t0015-object-complex.scm
:100644 100644 ec3f7ba... a6ee505... M libgeda/src/scheme_complex.c
commit dbfcf03ba08226b6c752f57006a3e2cde7ffcde8
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Remove some Guile 1.4/1.6 compatibility code.
:100644 100644 fbe0bfd... 7ca8336... M gschem/scheme/gschem.scm
commit 275740ab72ae6fd9ab2ddcc024181d1c3330064d
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Retrieve and change the current gschem page.
:100644 100644 ee4f1f2... 6e3e0b4... M gschem/scheme/Makefile.am
:000000 100644 0000000... b5fdc24... A gschem/scheme/gschem/window.scm
:100644 100644 46e6d6c... c324808... M gschem/src/g_window.c
commit 2cd6cf4922ef828ed8bbb2d409d0e40b04f7d8ff
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Remove global_window_current.
Instead, use the GSCHEM_TOPLEVEL fluid (accessed via
g_current_toplevel()). Although this does indeed remove one magic
global variable in favour of another, the fluid has the advantage of
coping correctly with non-local exits, and is more clearly only for
the benefit of procedures that are called via Scheme.
:100644 100644 8fbeb75... d3689ab... M gschem/include/globals.h
:100644 100644 d2035ab... 894753b... M gschem/src/g_funcs.c
:100644 100644 d75baf4... a979255... M gschem/src/g_hook.c
:100644 100644 0a3331f... ba05a20... M gschem/src/g_keys.c
:100644 100644 e11a110... b7c86b5... M gschem/src/globals.c
:100644 100644 0f0ee8d... 4c33137... M gschem/src/gschem.c
:100644 100644 dfb4ffa... d081323... M gschem/src/x_event.c
:100644 100644 6dc3762... b56cd95... M gschem/src/x_stroke.c
commit c51711b32a5673b6ee3f18d5160c9c4e16d15b5e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Add a fluid for current GSCHEM_TOPLEVEL.
Adds a smob that represents a gschem window structure, and a Guile
fluid that tracks the active window and that can be accessed from
Scheme code. The functions which update the fluid also ensure that
the libgeda TOPLEVEL fluid is updated in lockstep. This ensures that
Scheme code that is not gschem-aware will run correctly in gschem, and
will allow the global_window_current variable to be removed.
:100644 100644 c4754cf... 8bd372f... M gschem/include/gschem_struct.h
:100644 100644 5948c74... 19f5f80... M gschem/include/prototype.h
:100644 100644 dd7d0b6... a1a4506... M gschem/src/.gitignore
:100644 100644 4e04085... f858c55... M gschem/src/Makefile.am
:100644 100644 67c46be... 0a3331f... M gschem/src/g_keys.c
:000000 100644 0000000... 46e6d6c... A gschem/src/g_window.c
:100644 100644 e5e6ca3... 0f0ee8d... M gschem/src/gschem.c
:100644 100644 6bfda7a... af5ac98... M gschem/src/gschem_toplevel.c
:100644 100644 63fe5a6... 91d266f... M gschem/src/x_menus.c
:100644 100644 0259619... 6dc3762... M gschem/src/x_stroke.c
:100644 100644 c44fa12... 79e882e... M gschem/src/x_window.c
commit 662b15fd2dfa47d48410bcd42c75b461ab5f21bd
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Attributes.
Adds support for attributes. In order to make the API safe to use
without memory corruption, there are significant restrictions on the
context in which attribute attachments can be made. Most importantly,
both target and attribute must be part of the same page, or of the
same component, and objects which have attribute attachments cannot be
removed from a page or component's contents.
:100644 100644 cf637dc... 37e6371... M libgeda/include/libgedaguile_priv.h
:100644 100644 9d7fa5b... 5b548d6... M libgeda/scheme/Makefile.am
:000000 100644 0000000... 8ccad6b... A libgeda/scheme/geda/attrib.scm
:100644 100644 e77dc5f... 6c200c1... M libgeda/scheme/unit-tests/t0015-object-complex.scm
:100644 100644 449e1a0... 2154375... M libgeda/scheme/unit-tests/t0020-page.scm
:000000 100644 0000000... 35be33e... A libgeda/scheme/unit-tests/t0030-attribute.scm
:100644 100644 a381b10... 7eee9e9... M libgeda/src/Makefile.am
:000000 100644 0000000... 0816136... A libgeda/src/scheme_attrib.c
:100644 100644 216f5e3... ec3f7ba... M libgeda/src/scheme_complex.c
:100644 100644 9b2a25e... 26a6e20... M libgeda/src/scheme_init.c
:100644 100644 5e4e60f... c298c68... M libgeda/src/scheme_page.c
commit c8140254f0821bd28f84040939329aaf0e744a9a
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Basic page procedures.
This patch implements support for creating and modifying
schematic/symbol pages. It does not yet support file loading/saving,
printing, or closing pages.
:100644 100644 3f0335f... cf637dc... M libgeda/include/libgedaguile_priv.h
:100644 100644 e4b35f4... 9d7fa5b... M libgeda/scheme/Makefile.am
:000000 100644 0000000... c335f84... A libgeda/scheme/geda/page.scm
:100644 100644 d719847... e77dc5f... M libgeda/scheme/unit-tests/t0015-object-complex.scm
:000000 100644 0000000... 449e1a0... A libgeda/scheme/unit-tests/t0020-page.scm
:100644 100644 8c816a3... a381b10... M libgeda/src/Makefile.am
:100644 100644 ebc62da... 9b2a25e... M libgeda/src/scheme_init.c
:000000 100644 0000000... 5e4e60f... A libgeda/src/scheme_page.c
commit 83e845d1ec88528eb94e58105bf62cb1f5742218
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Complex objects.
Support for working with complex objects. Because Guile supports
complex numbers natively, using the word "complex" in function names
etc. is confusing. In the public Scheme API the word "component" is
used instead.
This patch implements support for inspecting and modifying components,
as well as for creating new, empty embedded components. It does not
include support for creating components from files or from the
component library.
:100644 100644 83f4472... 3f0335f... M libgeda/include/libgedaguile_priv.h
:100644 100644 8970893... e4b35f4... M libgeda/scheme/Makefile.am
:100644 100644 ea4b356... 6cd95ca... M libgeda/scheme/geda/object.scm
:000000 100644 0000000... d719847... A libgeda/scheme/unit-tests/t0015-object-complex.scm
:100644 100644 9db26e4... 8c816a3... M libgeda/src/Makefile.am
:000000 100644 0000000... 216f5e3... A libgeda/src/scheme_complex.c
:100644 100644 f32cd31... ebc62da... M libgeda/src/scheme_init.c
commit e70250b1f7776e40dcada0d2c0bc3d9d8bc9a8df
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Text objects.
Basic support for text objects.
:100644 100644 8a8c3db... 8970893... M libgeda/scheme/Makefile.am
:100644 100644 6e510d8... ea4b356... M libgeda/scheme/geda/object.scm
:000000 100644 0000000... 3808237... A libgeda/scheme/unit-tests/t0014-object-text.scm
:100644 100644 391e51b... cb92032... M libgeda/src/scheme_object.c
commit 810d1982d5b9fcd5d73037292df0be090ce18d84
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Path and picture objects.
Just add some predicates for now.
:100644 100644 dad5b59... 6e510d8... M libgeda/scheme/geda/object.scm
commit e461ca858a2d127c17bba84e17c31b626937ee00
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Arc objects.
:100644 100644 88eb7aa... 8a8c3db... M libgeda/scheme/Makefile.am
:100644 100644 e5d860a... dad5b59... M libgeda/scheme/geda/object.scm
:000000 100644 0000000... d6c038a... A libgeda/scheme/unit-tests/t0013-object-arc.scm
:100644 100644 8405183... 391e51b... M libgeda/src/scheme_object.c
commit 2d9bb54a420197facfe93712fa0e60c6ef35bdf9
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Pin objects.
Re-uses the line modification routines for working on pins. Note that
the libgeda C API provides a flag for choosing which end of a pin
should be connectable, but the Scheme API hides this flag, and from
the point of view of Scheme code the connectable end of a pin is
always the start.
:100644 100644 04088a4... e5d860a... M libgeda/scheme/geda/object.scm
:100644 100644 2ce964b... 7edbb95... M libgeda/scheme/unit-tests/t0010-object-line.scm
:100644 100644 bf6d14e... 8405183... M libgeda/src/scheme_object.c
commit a0f0f9c672a5f8955aaf6c37ec509484d9b08714
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Circle objects.
:100644 100644 1d28742... 88eb7aa... M libgeda/scheme/Makefile.am
:100644 100644 b2e9592... 04088a4... M libgeda/scheme/geda/object.scm
:000000 100644 0000000... 4cb8323... A libgeda/scheme/unit-tests/t0012-object-circle.scm
:100644 100644 66d8dc3... bf6d14e... M libgeda/src/scheme_object.c
commit 2010a33b32dacaf660145b44ad7e93c566a0e9df
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Box objects.
:100644 100644 7cf8571... 1d28742... M libgeda/scheme/Makefile.am
:100644 100644 1e19b55... b2e9592... M libgeda/scheme/geda/object.scm
:000000 100644 0000000... 15a9612... A libgeda/scheme/unit-tests/t0011-object-box.scm
:100644 100644 1449a09... 66d8dc3... M libgeda/src/scheme_object.c
commit f0d9875a2eee566cf75b340a98a9471d65fc8ad7
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Line, net and bus objects.
:100644 100644 4ae6b7e... 7cf8571... M libgeda/scheme/Makefile.am
:100644 100644 de18bf7... 1e19b55... M libgeda/scheme/geda/object.scm
:000000 100644 0000000... 2ce964b... A libgeda/scheme/unit-tests/t0010-object-line.scm
:100644 100644 0a85026... 1449a09... M libgeda/src/scheme_object.c
commit 91d3e917cd11d4c304c84f95431c08210b867a4c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Get/set the color of objects, and copy them.
:100644 100644 c9c9df7... de18bf7... M libgeda/scheme/geda/object.scm
:100644 100644 4498464... 0a85026... M libgeda/src/scheme_object.c
commit 1acff2a3f952b291cbae4e293f9cf703b99645de
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Get the type of an object.
Adds a function to the Scheme API for obtaining a symbol indicating
the type of schematic object contained in a Scheme value.
:100644 100644 9bd0e28... 83f4472... M libgeda/include/libgedaguile_priv.h
:100644 100644 bf0b204... 4ae6b7e... M libgeda/scheme/Makefile.am
:000000 100644 0000000... c9c9df7... A libgeda/scheme/geda/object.scm
:100644 100644 3191e0d... 9db26e4... M libgeda/src/Makefile.am
:100644 100644 d3ba1af... f32cd31... M libgeda/src/scheme_init.c
:100644 100644 9221771... 4498464... M libgeda/src/scheme_object.c
commit 4b52e3e739dca7b880f6909110b0225b2a7d6ea4
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Convert Scheme object lists to GLists and vice versa.
The libgeda C API makes extensive use of GLists (doubly-linked lists
from GLib). Since the Scheme API will frequently need to convert back
and forth between these and native Scheme cons-based singly-linked
lists, provide some utility functions for doing this conversion.
:100644 100644 fd3c1d2... 9bd0e28... M libgeda/include/libgedaguile_priv.h
:100644 100644 b42a222... 3191e0d... M libgeda/src/Makefile.am
:000000 100644 0000000... 9221771... A libgeda/src/scheme_object.c
commit feefbf9f0746f23c3d388d075c7c5d9c38d91afc
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Test suite based on geda-shell program.
Adds a test suite for libgeda's Scheme API. This is run using the
geda-shell REPL.
:100644 100644 a0ea6ad... bf0b204... M libgeda/scheme/Makefile.am
:000000 100644 0000000... 39ac84a... A libgeda/scheme/unit-test.scm
:000000 100644 0000000... 38ba902... A libgeda/scheme/unit-tests/t0001-geda-conf-lib.scm
commit 4e1f04c285a0a66f56c027a38709d0b3ec205c65
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
libgeda: Add geda-shell program.
Adds a minimal Scheme REPL program to libgeda. This is not installed,
but is useful for debugging issues with libgeda's Scheme API.
:100644 100644 cd57cb0... 7826550... M configure.ac
:100644 100644 2ecda29... 927c607... M libgeda/Makefile.am
:000000 100644 0000000... b2dd427... A libgeda/shell/.gitignore
:000000 100644 0000000... f2da672... A libgeda/shell/Makefile.am
:000000 100644 0000000... 9335e37... A libgeda/shell/shell.c
commit a61805445c844b30f0e9de1c8003249fdedeee66
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gnetlist: Use TOPLEVEL fluid.
Modifies gnetlist to use edascm_c_current_toplevel() instead of a
global variable to allow Scheme functions to access the global libgeda
state.
:100644 100644 b3af8fa... d5cae12... M gnetlist/src/g_netlist.c
:100644 100644 3471b97... c5490b5... M gnetlist/src/gnetlist.c
commit 4203e5e08b5341613ad6de08191f4feafb243687
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Basic smob predicates.
:100644 100644 e498a48... f440297... M libgeda/include/libgeda/libgedaguile.h
:100644 100644 eb13f0c... de46fb0... M libgeda/src/scheme_smob.c
commit b235a037d0ce1c525195141d77fd7b8cae85e8be
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Basic smob definitions & TOPLEVEL fluid.
Adds a new smob type for gEDA objects (TOPLEVEL, PAGE and OBJECT, at
least initially), along with C functions for creating smobs. Weak
references are used to ensure that smobs pointing to dead objects are
invalidated.
Additionally, defines a fluid which contains the current TOPLEVEL.
This is used by the Scheme API to obtain the TOPLEVEL needed for
calling much of the libgeda API.
:100644 100644 f8043b2... e498a48... M libgeda/include/libgeda/libgedaguile.h
:100644 100644 4ef4ec4... fd3c1d2... M libgeda/include/libgedaguile_priv.h
:100644 100644 77e47ce... b42a222... M libgeda/src/Makefile.am
:100644 100644 15dda39... a19627c... M libgeda/src/g_basic.c
:100644 100644 26618f6... d3ba1af... M libgeda/src/scheme_init.c
:000000 100644 0000000... eb13f0c... A libgeda/src/scheme_smob.c
:000000 100644 0000000... 7774522... A libgeda/src/scheme_toplevel.c
commit 0460b8f476066ee471b4f8a79176e3a1fbbbfc55
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
libgeda: Define non-NULL default for select_func.
The code for loading/saving complex objects uses the nullity of
OBJECT.sel_func to determine whether or not a complex object should be
flagged as selectable or not. So that libgeda applications that do
not define their own select_func can safely load, modify and save
schematic files, it's necessary to have a non-NULL default
select_func.
:100644 100644 31e08f6... 814a12e... M libgeda/src/o_basic.c
commit 57f5e1eb96577f439840afb5c008ba739055d249
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Build infrastructure in libgeda.
:100644 100644 ee16213... cd57cb0... M configure.ac
:100644 100644 a8bfbef... a40af11... M libgeda/include/Makefile.am
:000000 100644 0000000... f8043b2... A libgeda/include/libgeda/libgedaguile.h
:000000 100644 0000000... 4ef4ec4... A libgeda/include/libgedaguile_priv.h
:100644 100644 1a3819e... a0ea6ad... M libgeda/scheme/Makefile.am
:100644 100644 65b98d9... f97d51d... M libgeda/src/.gitignore
:100644 100644 ae62fe8... 77e47ce... M libgeda/src/Makefile.am
:100644 100644 ea11b92... fc43fb7... M libgeda/src/libgeda.c
:000000 100644 0000000... 26618f6... A libgeda/src/scheme_init.c
:000000 100644 0000000... 8c9e92b... A m4/geda-guile-snarf.m4
=========
Changes
=========
commit 242562c9b0513f451c9ec2b25b1d8df4c71d01e6
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add info directory macros.
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 3398fea..ac02d47 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -2,6 +2,10 @@
@setfilename geda-scheme.info
@include version.texi
@documentencoding utf-8
+@dircategory The Algorithmic Language Scheme
+@direntry
+* gEDA Scheme: (geda-scheme). gEDA extensibility with Guile Scheme.
+@end direntry
@settitle gEDA Scheme Reference Manual @value{VERSION}
@copying
commit 1c8281672b4c1831bd2c7614d9b41ff7720a2be3
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Run gtk-update-icon-cache when uninstalling.
If `gtk-update-icon-cache' is not run during `make uninstall', then a
stale `icon-theme.cache' is left in the install directory. This
breaks distcheck's uninstall check.
This problem was previously masked due to the fact that the uninstall
check silently allows exactly one leftover file -- and now that we
install Info manuals, this allowance is being used up by the
`${infodir}/dir' file generated by `install-info'.
diff --git a/build-tools/icon-theme-installer b/build-tools/icon-theme-installer
index e070868..594dd72 100755
--- a/build-tools/icon-theme-installer
+++ b/build-tools/icon-theme-installer
@@ -162,22 +162,19 @@ for icon in $@; do
fi
done
-if test "x$INSTALL" = "xyes"; then
- gtk_update_icon_cache_bin="`(which gtk-update-icon-cache || echo /opt/gnome/bin/gtk-update-icon-cache)2>/dev/null`"
- gtk_update_icon_cache_bin="${GTK_UPDATE_ICON_CACHE_BIN:-$gtk_update_icon_cache_bin}"
-
- gtk_update_icon_cache="$gtk_update_icon_cache_bin -f -t $INSTALL_BASE_DIR"
-
- if test -z "$INSTALL_DEST_DIR"; then
- if test -x $gtk_update_icon_cache_bin; then
- echo "Updating GTK icon cache"
- $gtk_update_icon_cache
- else
- echo "*** Icon cache not updated. Could not execute $gtk_update_icon_cache_bin"
- fi
+gtk_update_icon_cache_bin="`(which gtk-update-icon-cache || echo /opt/gnome/bin/gtk-update-icon-cache)2>/dev/null`"
+gtk_update_icon_cache_bin="${GTK_UPDATE_ICON_CACHE_BIN:-$gtk_update_icon_cache_bin}"
+gtk_update_icon_cache="$gtk_update_icon_cache_bin -f -t $INSTALL_BASE_DIR"
+
+if test -z "$INSTALL_DEST_DIR"; then
+ if test -x $gtk_update_icon_cache_bin; then
+ echo "Updating GTK icon cache"
+ $gtk_update_icon_cache
else
- echo "*** Icon cache not updated. After install, run this:"
- echo "*** $gtk_update_icon_cache"
+ echo "*** Icon cache not updated. Could not execute $gtk_update_icon_cache_bin"
fi
+else
+ echo "*** Icon cache not updated. After install, run this:"
+ echo "*** $gtk_update_icon_cache"
fi
commit 883be5d25f046a06a76f106cb6ad1bde1b14db9f
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Update NEWS for Scheme API.
diff --git a/NEWS b/NEWS
index 97d5996..34cc2de 100644
--- a/NEWS
+++ b/NEWS
@@ -7,6 +7,14 @@ Copyright (C) 1998-2011 gEDA Developers
This file documents important user-visible changes in gEDA/gaf. For
more information, please consult the `ChangeLog' file.
+Notable changes in gEDA/gaf 1.7.2
+=================================
+
+* A greatly expanded Scheme API has been added to gEDA/gaf for use by
+ extension authors. See the `geda-scheme' Info manual for more
+ details. Existing extensions may need to be modified to load the
+ `(geda deprecated)' or `(gschem deprecated)' modules.
+
Notable changes in gEDA/gaf 1.7.1
=================================
commit 31fcff837375b3db8649f1f1854dd0daa98e901a
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Converting pages to/from strings.
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 89733b6..3398fea 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -385,6 +385,26 @@ Sets the filename of @var{page} to @var{filename}. Returns
@var{page}.
@end defun
+@subsection Page serialisation
+
+Pages can be converted to and from strings in the gEDA schematic file
+format.
+
+@defun string->page filename string
+Parses @var{string}, which should be in the gEDA file format, to
+create a new @code{page}. The initial filename for the new
+@code{page} is @var{filename}.
+
+@strong{Warning}: Due to missing functionality in the underlying C
+library, this @code{string->page} cannot currently report invalid
+syntax or other problems in the @var{string} passed.
+@end defun
+
+@defun page->string page
+Returns a string representation of @var{page} in the gEDA file
+format.
+@end defun
+
@subsection Page contents
A schematic or symbol @code{page} is composed of a set of
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index ee014d4..18dd2ac 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -23,11 +23,15 @@ TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0110-object-transform.scm \
unit-tests/t0200-page.scm \
unit-tests/t0201-page-dirty.scm \
+ unit-tests/t0202-page-string.scm \
+ unit-tests/t0203-page-string-syntax.scm \
unit-tests/t0300-attribute.scm \
unit-tests/t0301-promotable-attributes.scm \
unit-tests/t1000-deprecated.scm
-XFAIL_TESTS = unit-tests/t0301-promotable-attributes.scm
+XFAIL_TESTS = \
+ unit-tests/t0203-page-string-syntax.scm \
+ unit-tests/t0301-promotable-attributes.scm
dist_noinst_DATA = unit-test.scm $(TESTS)
diff --git a/libgeda/scheme/geda/page.scm b/libgeda/scheme/geda/page.scm
index 556f52f..65d88e3 100644
--- a/libgeda/scheme/geda/page.scm
+++ b/libgeda/scheme/geda/page.scm
@@ -35,6 +35,8 @@
(define-public set-page-filename! %set-page-filename!)
(define-public page-contents %page-contents)
(define-public page-dirty? %page-dirty?)
+(define-public page->string %page->string)
+(define-public string->page %string->page)
(define-public (page-append! P . objects)
(for-each (lambda (x) (%page-append! P x)) objects)
diff --git a/libgeda/scheme/unit-tests/t0202-page-string.scm b/libgeda/scheme/unit-tests/t0202-page-string.scm
new file mode 100644
index 0000000..fabf5b6
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0202-page-string.scm
@@ -0,0 +1,40 @@
+;; Test Scheme procedures related to converting pages to & from
+;; strings.
+
+(use-modules (unit-test))
+(use-modules (geda page))
+(use-modules (geda object))
+
+;; This is a very roundabout test. We don't want to test string->page
+;; at this point, and we don't want to hardcode any assumptions about
+;; file format into this part of the testsuite, so we just make sure
+;; that pages with identical contents have identical string
+;; representation, and that pages with different contents have
+;; different string representation.
+(begin-test 'page->string
+ (let ((A (make-page "/test/page/A"))
+ (B (make-page "/test/page/B"))
+ (x (make-line '(0 . 0) '(1 . 1)))
+ (y (make-line '(0 . 0) '(1 . 1))))
+ (page-append! A x)
+ (page-append! B y)
+
+ ;; Pages with identical content
+ (assert-equal (page->string A) (page->string B))
+
+ ;; Pages with different content
+ (set-line! y '(0 . 0) '(2 . 2))
+ (assert-true (not (equal? (page->string A) (page->string B))))
+ ))
+
+;; We test string->page by round-tripping a page through a string back
+;; to a page. Note that this test is deliberately designed to avoid
+;; issues related to different gafrc read options.
+(begin-test 'string->page
+ (let ((A (make-page "/test/page/A"))
+ (x (make-line '(0 . 0) '(1 . 1))))
+ (page-append! A x)
+ (let* ((B (string->page "/test/page/B" (page->string A))))
+ (assert-equal "/test/page/B" (page-filename B))
+ (assert-equal 1 (length (page-contents B)))
+ (assert-equal (line-info x) (line-info (car (page-contents B)))))))
diff --git a/libgeda/scheme/unit-tests/t0203-page-string-syntax.scm b/libgeda/scheme/unit-tests/t0203-page-string-syntax.scm
new file mode 100644
index 0000000..e608017
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0203-page-string-syntax.scm
@@ -0,0 +1,11 @@
+;; Test Scheme procedures related to converting pages to & from
+;; strings.
+
+(use-modules (unit-test))
+(use-modules (geda page))
+(use-modules (geda object))
+
+;; string->page should bork if the string contains invalid syntax. It
+;; might not throw a misc-error; this is just a placeholder key.
+(begin-test 'string->page
+ (assert-thrown 'misc-error (string->page "/test/page/A" "__GARBAGE__")))
diff --git a/libgeda/src/scheme_page.c b/libgeda/src/scheme_page.c
index 71a2139..311abb5 100644
--- a/libgeda/src/scheme_page.c
+++ b/libgeda/src/scheme_page.c
@@ -368,6 +368,76 @@ SCM_DEFINE (set_page_dirty_x, "%set-page-dirty!", 2, 0, 0,
return page_s;
}
+/*! \brief Create a string representation of a page.
+ * \par Function Description
+ * Returns a string representation of the contents of \a page_s.
+ *
+ * \note Scheme API: Implements the %page->string procedure of the
+ * (geda core page) module.
+ *
+ * \param page_s page to convert to a string.
+ * \return a string representation of \a page_s.
+ */
+SCM_DEFINE (page_to_string, "%page->string", 1, 0, 0,
+ (SCM page_s),
+ "Create a string representation of a page.")
+{
+ /* Ensure that the argument is a page smob */
+ SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
+ SCM_ARG1, s_page_to_string);
+
+ PAGE *page = edascm_to_page (page_s);
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+
+ gchar *buf = o_save_buffer (toplevel, s_page_objects (page));
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (g_free, buf, SCM_F_WIND_EXPLICITLY);
+ SCM result = scm_from_utf8_string (buf);
+ scm_dynwind_end ();
+ return result;
+}
+
+/*! \brief Create a page from a string representation.
+ * \par Function Description
+ * Returns a page with filename \a filename_s created by parsing \a
+ * str_s.
+ *
+ * \note Scheme API: Implements the %string->page procedure of the
+ * (geda core page) module.
+ *
+ * \bug Should throw an error if \a str_s contains invalid gEDA file
+ * format syntax. Requires support in gEDA file parser.
+ *
+ * \param filename_s Filename for new page.
+ * \param str_s String to parse to create page.
+ * \return a new page created by parsing \a str_s.
+ */
+SCM_DEFINE (string_to_page, "%string->page", 2, 0, 0,
+ (SCM filename_s, SCM str_s),
+ "Create a new page from a string.")
+{
+ /* Ensure that the arguments are strings */
+ SCM_ASSERT (scm_is_string (filename_s), filename_s,
+ SCM_ARG1, s_string_to_page);
+ SCM_ASSERT (scm_is_string (str_s), str_s,
+ SCM_ARG2, s_string_to_page);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ char *filename = scm_to_utf8_string (filename_s);
+ PAGE *page = s_page_new (toplevel, filename);
+ free (filename);
+
+ size_t len;
+ char *str = scm_to_utf8_stringn (str_s, &len);
+ GList *objects = o_read_buffer (toplevel, NULL, str, len,
+ page->page_filename);
+ free (str);
+
+ s_page_append_list (toplevel, page, objects);
+
+ return edascm_from_page (page);
+}
+
/*!
* \brief Create the (geda core page) Scheme module.
* \par Function Description
@@ -385,7 +455,7 @@ init_module_geda_core_page ()
scm_c_export (s_active_pages, s_new_page, s_close_page_x,
s_page_filename, s_set_page_filename_x, s_page_contents,
s_object_page, s_page_append_x, s_page_remove_x, s_page_dirty,
- s_set_page_dirty_x, NULL);
+ s_set_page_dirty_x, s_page_to_string, s_string_to_page, NULL);
}
/*!
commit 71621e0f9d6ed201ac3968823b0b6b852fe3f070
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add mirror-objects! function.
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index cebf872..89733b6 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -572,6 +572,11 @@ Translate @var{objects} anti-clockwise by @var{angle} about
of the modified @var{objects}.
@end defun
+@defun mirror-objects! x-offset [objects...]
+Mirror @var{objects} in the line @samp{x = @var{x-offset}}. Returns a
+list of the modified @var{objects}.
+@end defun
+
@node Object bounds
@subsubsection Object bounds
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 3848f2b..2e17a6f 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -374,3 +374,9 @@
(lambda (x) (%rotate-object! x (car center) (cdr center) angle))
objects)
objects)
+
+(define-public (mirror-objects! x . objects)
+ (for-each
+ (lambda (obj) (%mirror-object! obj x))
+ objects)
+ objects)
diff --git a/libgeda/scheme/unit-tests/t0110-object-transform.scm b/libgeda/scheme/unit-tests/t0110-object-transform.scm
index 953c2f6..efdc5cf 100644
--- a/libgeda/scheme/unit-tests/t0110-object-transform.scm
+++ b/libgeda/scheme/unit-tests/t0110-object-transform.scm
@@ -59,3 +59,32 @@
(assert-equal 0 (component-angle C))
(assert-equal '(1 . 2) (line-start b))
(assert-equal '(3 . 4) (line-end b)) ))
+
+(begin-test 'mirror-objects!
+ (let ((C (make-component "test component" '(1 . 2) 0 #f #f))
+ (a (make-line '(1 . 2) '(3 . 4)))
+ (b (make-line '(1 . 2) '(3 . 4))))
+
+ ;; Mirror nothing
+ (assert-equal '() (mirror-objects! 2))
+
+ ;; Mirror a line
+ (assert-equal (list a) (mirror-objects! 2 a))
+ (assert-equal '(3 . 2) (line-start a))
+ (assert-equal '(1 . 4) (line-end a))
+
+ ;; Mirror a component
+ (component-append! C b)
+ (assert-equal (list C) (mirror-objects! 2 C))
+ (assert-equal '(3 . 2) (component-position C))
+ (assert-true (component-mirror? C))
+ (assert-equal '(3 . 2) (line-start b))
+ (assert-equal '(1 . 4) (line-end b))
+
+ ;; Mirror multiple objects
+ (assert-equal (list a C) (mirror-objects! 2 a C))
+ (assert-equal '(1 . 2) (line-start a))
+ (assert-equal '(3 . 4) (line-end a))
+ (assert-true (not (component-mirror? C)))
+ (assert-equal '(1 . 2) (line-start b))
+ (assert-equal '(3 . 4) (line-end b)) ))
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index e1447a8..8a2ef57 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -1637,6 +1637,39 @@ SCM_DEFINE (rotate_object_x, "%rotate-object!", 4, 0, 0,
return obj_s;
}
+/*! \brief Mirror an object.
+ * \par Function Description
+ * Mirrors \a obj_s in the line x = \a x_s.
+ *
+ * \note Scheme API: Implements the %mirror-object! procedure of the
+ * (geda core object) module.
+ *
+ * \param obj_s #OBJECT smob for object to translate.
+ * \param x_s x-coordinate of centre of rotation.
+ * \return \a obj_s.
+ */
+SCM_DEFINE (mirror_object_x, "%mirror-object!", 2, 0, 0,
+ (SCM obj_s, SCM x_s),
+ "Mirror an object.")
+{
+ /* Check argument types */
+ SCM_ASSERT (edascm_is_object (obj_s), obj_s,
+ SCM_ARG1, s_mirror_object_x);
+ SCM_ASSERT (scm_is_integer (x_s), x_s,
+ SCM_ARG2, s_mirror_object_x);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+ int x = scm_to_int (x_s);
+
+ o_emit_pre_change_notify (toplevel, obj);
+ o_mirror_world (toplevel, x, 0, obj);
+ o_emit_change_notify (toplevel, obj);
+ o_page_changed (toplevel, obj);
+
+ return obj_s;
+}
+
/*!
* \brief Create the (geda core object) Scheme module.
* \par Function Description
@@ -1663,6 +1696,7 @@ init_module_geda_core_object ()
s_make_text, s_set_text_x, s_text_info,
s_object_connections, s_object_complex,
s_translate_object_x, s_rotate_object_x,
+ s_mirror_object_x,
NULL);
}
commit 01e9ab2b42bff0de6386706ba3eb11e7a7c6f5e9
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add rotate-objects! function.
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 671cc1a..cebf872 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -565,6 +565,13 @@ in the form @samp{(x . y)}. Returns a list of the modified
@var{objects}.
@end defun
+@defun rotate-objects! center angle [objects...]
+Translate @var{objects} anti-clockwise by @var{angle} about
+@var{center}, a world coordinate position in the form @samp{(x . y)}.
+@var{angle} must be an integer multiple of 90 degrees. Returns a list
+of the modified @var{objects}.
+@end defun
+
@node Object bounds
@subsubsection Object bounds
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 8409d30..3848f2b 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -368,3 +368,9 @@
(lambda (x) (%translate-object! x (car vector) (cdr vector)))
objects)
objects)
+
+(define-public (rotate-objects! center angle . objects)
+ (for-each
+ (lambda (x) (%rotate-object! x (car center) (cdr center) angle))
+ objects)
+ objects)
diff --git a/libgeda/scheme/unit-tests/t0110-object-transform.scm b/libgeda/scheme/unit-tests/t0110-object-transform.scm
index 4c26f72..953c2f6 100644
--- a/libgeda/scheme/unit-tests/t0110-object-transform.scm
+++ b/libgeda/scheme/unit-tests/t0110-object-transform.scm
@@ -30,3 +30,32 @@
(assert-equal '(1 . 2) (component-position C))
(assert-equal '(1 . 2) (line-start b))
(assert-equal '(3 . 4) (line-end b)) ))
+
+(begin-test 'rotate-objects!
+ (let ((C (make-component "test component" '(1 . 2) 0 #t #f))
+ (a (make-line '(1 . 2) '(3 . 4)))
+ (b (make-line '(1 . 2) '(3 . 4))))
+
+ ;; Rotate nothing
+ (assert-equal '() (rotate-objects! '(1 . 2) 90))
+
+ ;; Rotate a line
+ (assert-equal (list a) (rotate-objects! '(1 . 2) 90 a))
+ (assert-equal '(1 . 2) (line-start a))
+ (assert-equal '(-1 . 4) (line-end a))
+
+ ;; Rotate a component
+ (component-append! C b)
+ (assert-equal (list C) (rotate-objects! '(1 . 2) -270 C))
+ (assert-equal '(1 . 2) (component-position C))
+ (assert-equal 90 (component-angle C))
+ (assert-equal '(1 . 2) (line-start b))
+ (assert-equal '(-1 . 4) (line-end b))
+
+ ;; Rotate multiple objects
+ (assert-equal (list a C) (rotate-objects! '(1 . 2) -90 a C))
+ (assert-equal '(1 . 2) (line-start a))
+ (assert-equal '(3 . 4) (line-end a))
+ (assert-equal 0 (component-angle C))
+ (assert-equal '(1 . 2) (line-start b))
+ (assert-equal '(3 . 4) (line-end b)) ))
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index e616cec..e1447a8 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -1586,6 +1586,57 @@ SCM_DEFINE (translate_object_x, "%translate-object!", 3, 0, 0,
return obj_s;
}
+/*! \brief Rotate an object.
+ * \par Function Description
+ * Rotates \a obj_s anti-clockwise by \a angle_s about the point
+ * specified by \a x_s and \a y_s. \a angle_s must be an integer
+ * multiple of 90 degrees.
+ *
+ * \note Scheme API: Implements the %rotate-object! procedure of the
+ * (geda core object) module.
+ *
+ * \param obj_s #OBJECT smob for object to translate.
+ * \param x_s x-coordinate of centre of rotation.
+ * \param y_s y-coordinate of centre of rotation.
+ * \param angle_s Angle to rotate by.
+ * \return \a obj_s.
+ */
+SCM_DEFINE (rotate_object_x, "%rotate-object!", 4, 0, 0,
+ (SCM obj_s, SCM x_s, SCM y_s, SCM angle_s),
+ "Rotate an object.")
+{
+ /* Check argument types */
+ SCM_ASSERT (edascm_is_object (obj_s), obj_s,
+ SCM_ARG1, s_rotate_object_x);
+ SCM_ASSERT (scm_is_integer (x_s), x_s,
+ SCM_ARG2, s_rotate_object_x);
+ SCM_ASSERT (scm_is_integer (y_s), y_s,
+ SCM_ARG3, s_rotate_object_x);
+ SCM_ASSERT (scm_is_integer (angle_s), angle_s,
+ SCM_ARG4, s_rotate_object_x);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+ int x = scm_to_int (x_s);
+ int y = scm_to_int (y_s);
+ int angle = scm_to_int (angle_s);
+
+ /* FIXME Work around horribly broken libgeda behaviour. Some
+ * libgeda functions treat a rotation of -90 degrees as a rotation
+ * of +90 degrees, etc., which is not sane. */
+ while (angle < 0) angle += 360;
+ while (angle >= 360) angle -= 360;
+ SCM_ASSERT (angle % 90 == 0, angle_s,
+ SCM_ARG4, s_rotate_object_x);
+
+ o_emit_pre_change_notify (toplevel, obj);
+ o_rotate_world (toplevel, x, y, angle, obj);
+ o_emit_change_notify (toplevel, obj);
+ o_page_changed (toplevel, obj);
+
+ return obj_s;
+}
+
/*!
* \brief Create the (geda core object) Scheme module.
* \par Function Description
@@ -1611,7 +1662,7 @@ init_module_geda_core_object ()
s_make_arc, s_set_arc_x, s_arc_info,
s_make_text, s_set_text_x, s_text_info,
s_object_connections, s_object_complex,
- s_translate_object_x,
+ s_translate_object_x, s_rotate_object_x,
NULL);
}
commit 208984c6815066a90c7d1d3583f271524344797e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add translate-objects! function.
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 1eae5e0..671cc1a 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -508,6 +508,7 @@ a list containing the pin @code{object}, and @emph{not} the component.
@menu
* Object sub-types::
+* Object transformations::
* Object bounds::
* Object color::
* Object fill and stroke::
@@ -553,6 +554,17 @@ Returns @samp{#t} if and only if @var{object} is an @code{object} and
that its subtype is @var{type}, which should be a symbol.
@end defun
+@node Object transformations
+@subsubsection Object transformations
+
+Objects can be translated, rotated, or mirrored about a point.
+
+@defun translate-objects! vector [objects...]
+Translate @var{objects} by @var{vector}, a world coordinate distance
+in the form @samp{(x . y)}. Returns a list of the modified
+@var{objects}.
+@end defun
+
@node Object bounds
@subsubsection Object bounds
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 8911218..ee014d4 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -20,6 +20,7 @@ TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0107-object-stroke-fill.scm \
unit-tests/t0108-object-connections.scm \
unit-tests/t0109-object-copy.scm \
+ unit-tests/t0110-object-transform.scm \
unit-tests/t0200-page.scm \
unit-tests/t0201-page-dirty.scm \
unit-tests/t0300-attribute.scm \
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index e3bceb8..8409d30 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -360,3 +360,11 @@
(or a b)))
#f ;; default
bounds))
+
+;;;; Object transformations
+
+(define-public (translate-objects! vector . objects)
+ (for-each
+ (lambda (x) (%translate-object! x (car vector) (cdr vector)))
+ objects)
+ objects)
diff --git a/libgeda/scheme/unit-tests/t0110-object-transform.scm b/libgeda/scheme/unit-tests/t0110-object-transform.scm
new file mode 100644
index 0000000..4c26f72
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0110-object-transform.scm
@@ -0,0 +1,32 @@
+;; Test Scheme procedures for transforming objects
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'translate-objects!
+ (let ((C (make-component "test component" '(1 . 2) 0 #t #f))
+ (a (make-line '(1 . 2) '(3 . 4)))
+ (b (make-line '(1 . 2) '(3 . 4))))
+
+ ;; Translate nothing
+ (assert-equal '() (translate-objects! '(1 . 2)))
+
+ ;; Translate a line
+ (assert-equal (list a) (translate-objects! '(1 . 2) a))
+ (assert-equal '(2 . 4) (line-start a))
+ (assert-equal '(4 . 6) (line-end a))
+
+ ;; Translate a component
+ (component-append! C b)
+ (assert-equal (list C) (translate-objects! '(1 . 2) C))
+ (assert-equal '(2 . 4) (component-position C))
+ (assert-equal '(2 . 4) (line-start b))
+ (assert-equal '(4 . 6) (line-end b))
+
+ ;; Translate multiple objects
+ (assert-equal (list a C) (translate-objects! '(-1 . -2) a C))
+ (assert-equal '(1 . 2) (line-start a))
+ (assert-equal '(3 . 4) (line-end a))
+ (assert-equal '(1 . 2) (component-position C))
+ (assert-equal '(1 . 2) (line-start b))
+ (assert-equal '(3 . 4) (line-end b)) ))
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index 240a985..e616cec 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -1549,6 +1549,43 @@ SCM_DEFINE (object_complex, "%object-complex", 1, 0, 0,
return edascm_from_object (parent);
}
+/*! \brief Translate an object.
+ * \par Function Description
+ * Translates \a obj_s by \a dx_s in the x-axis and \a dy_s in the
+ * y-axis.
+ *
+ * \note Scheme API: Implements the %translate-object! procedure of the
+ * (geda core object) module.
+ *
+ * \param obj_s #OBJECT smob for object to translate.
+ * \param dx_s Integer distance to translate along x-axis.
+ * \param dy_s Integer distance to translate along y-axis.
+ * \return \a obj_s.
+ */
+SCM_DEFINE (translate_object_x, "%translate-object!", 3, 0, 0,
+ (SCM obj_s, SCM dx_s, SCM dy_s), "Translate an object.")
+{
+ /* Check argument types */
+ SCM_ASSERT (edascm_is_object (obj_s), obj_s,
+ SCM_ARG1, s_translate_object_x);
+ SCM_ASSERT (scm_is_integer (dx_s), dx_s,
+ SCM_ARG2, s_translate_object_x);
+ SCM_ASSERT (scm_is_integer (dy_s), dy_s,
+ SCM_ARG3, s_translate_object_x);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+ int dx = scm_to_int (dx_s);
+ int dy = scm_to_int (dy_s);
+
+ o_emit_pre_change_notify (toplevel, obj);
+ o_translate_world (toplevel, dx, dy, obj);
+ o_emit_change_notify (toplevel, obj);
+ o_page_changed (toplevel, obj);
+
+ return obj_s;
+}
+
/*!
* \brief Create the (geda core object) Scheme module.
* \par Function Description
@@ -1574,6 +1611,7 @@ init_module_geda_core_object ()
s_make_arc, s_set_arc_x, s_arc_info,
s_make_text, s_set_text_x, s_text_info,
s_object_connections, s_object_complex,
+ s_translate_object_x,
NULL);
}
commit 3a47ea70adf7bae086b7d28455c2cacd707b434c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Shuffle some unit tests around.
It turns out we need more test numbers for low-level object-related
functions, so shift some stuff about.
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index ab946b0..8911218 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -10,23 +10,23 @@ TESTS_ENVIRONMENT = $(builddir)/../shell/geda-shell -q -L $(srcdir) \
-c '(use-modules (unit-test)) (load (list-ref (command-line) 1)) (exit (if (tests-passed?) 0 1))'
TESTS = unit-tests/t0001-geda-conf-lib.scm \
- unit-tests/t0010-object-line.scm \
- unit-tests/t0011-object-box.scm \
- unit-tests/t0012-object-circle.scm \
- unit-tests/t0013-object-arc.scm\
- unit-tests/t0014-object-text.scm \
- unit-tests/t0015-object-complex.scm \
- unit-tests/t0016-object-bounds.scm \
- unit-tests/t0017-object-stroke-fill.scm \
- unit-tests/t0018-object-connections.scm \
- unit-tests/t0019-object-copy.scm \
- unit-tests/t0020-page.scm \
- unit-tests/t0021-page-dirty.scm \
- unit-tests/t0030-attribute.scm \
- unit-tests/t0031-promotable-attributes.scm \
+ unit-tests/t0100-object-line.scm \
+ unit-tests/t0101-object-box.scm \
+ unit-tests/t0102-object-circle.scm \
+ unit-tests/t0103-object-arc.scm\
+ unit-tests/t0104-object-text.scm \
+ unit-tests/t0105-object-complex.scm \
+ unit-tests/t0106-object-bounds.scm \
+ unit-tests/t0107-object-stroke-fill.scm \
+ unit-tests/t0108-object-connections.scm \
+ unit-tests/t0109-object-copy.scm \
+ unit-tests/t0200-page.scm \
+ unit-tests/t0201-page-dirty.scm \
+ unit-tests/t0300-attribute.scm \
+ unit-tests/t0301-promotable-attributes.scm \
unit-tests/t1000-deprecated.scm
-XFAIL_TESTS = unit-tests/t0031-promotable-attributes.scm
+XFAIL_TESTS = unit-tests/t0301-promotable-attributes.scm
dist_noinst_DATA = unit-test.scm $(TESTS)
diff --git a/libgeda/scheme/unit-tests/t0010-object-line.scm b/libgeda/scheme/unit-tests/t0010-object-line.scm
deleted file mode 100644
index 7edbb95..0000000
--- a/libgeda/scheme/unit-tests/t0010-object-line.scm
+++ /dev/null
@@ -1,140 +0,0 @@
-;; Test Scheme procedures related to line objects.
-
-(use-modules (unit-test))
-(use-modules (geda object))
-
-(begin-test 'lines
- (let ((a (make-line '(1 . 2) '(3 . 4) 21))
- (b (make-line '(1 . 2) '(3 . 4))))
-
- (assert-equal 'line (object-type a))
-
- (assert-true (line? a))
-
- (assert-equal '(1 . 2) (line-start a))
- (assert-equal '(3 . 4) (line-end a))
- (assert-equal (line-start a) (line-start b))
- (assert-equal (line-end a) (line-end b))
- (assert-equal 21 (object-color a))
- (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
-
- (set-line! a '(5 . 6) '(7 . 8))
- (assert-equal '(5 . 6) (line-start a))
- (assert-equal '(7 . 8) (line-end a))
- (assert-equal 21 (object-color a))
-
- (set-line! a '(5 . 6) '(7 . 8) 22)
- (assert-equal 22 (object-color a))
-
- (set-object-color! a 21)
- (assert-equal 21 (list-ref (line-info a) 2))))
-
-(make-net '(1 . 2) '(3 . 4))
-
-(begin-test 'nets
- (let ((a (make-net '(1 . 2) '(3 . 4) 21))
- (b (make-net '(1 . 2) '(3 . 4))))
-
- (assert-equal 'net (object-type a))
-
- (assert-true (net? a))
-
- (assert-equal '(1 . 2) (line-start a))
- (assert-equal '(3 . 4) (line-end a))
- (assert-equal (line-start a) (line-start b))
- (assert-equal (line-end a) (line-end b))
- (assert-equal 21 (object-color a))
- (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
-
- (set-line! a '(5 . 6) '(7 . 8))
- (assert-equal '(5 . 6) (line-start a))
- (assert-equal '(7 . 8) (line-end a))
- (assert-equal 21 (object-color a))
-
- (set-line! a '(5 . 6) '(7 . 8) 22)
- (assert-equal 22 (object-color a))
-
- (set-object-color! a 21)
- (assert-equal 21 (list-ref (line-info a) 2))))
-
-(begin-test 'buses
- (let ((a (make-bus '(1 . 2) '(3 . 4) 21))
- (b (make-bus '(1 . 2) '(3 . 4))))
-
- (assert-equal 'bus (object-type a))
-
- (assert-true (bus? a))
-
- (assert-equal '(1 . 2) (line-start a))
- (assert-equal '(3 . 4) (line-end a))
- (assert-equal (line-start a) (line-start b))
- (assert-equal (line-end a) (line-end b))
- (assert-equal 21 (object-color a))
- (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
-
- (set-line! a '(5 . 6) '(7 . 8))
- (assert-equal '(5 . 6) (line-start a))
- (assert-equal '(7 . 8) (line-end a))
- (assert-equal 21 (object-color a))
-
- (set-line! a '(5 . 6) '(7 . 8) 22)
- (assert-equal 22 (object-color a))
-
- (set-object-color! a 21)
- (assert-equal 21 (list-ref (line-info a) 2))))
-
-(begin-test 'net-pins
- (let ((a (make-net-pin '(1 . 2) '(3 . 4) 21))
- (b (make-net-pin '(1 . 2) '(3 . 4))))
-
- (assert-equal 'pin (object-type a))
-
- (assert-true (pin? a))
- (assert-true (net-pin? a))
- (assert-true (not (bus-pin? a)))
-
- (assert-equal '(1 . 2) (line-start a))
- (assert-equal '(3 . 4) (line-end a))
- (assert-equal (line-start a) (line-start b))
- (assert-equal (line-end a) (line-end b))
- (assert-equal 21 (object-color a))
- (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
-
- (set-line! a '(5 . 6) '(7 . 8))
- (assert-equal '(5 . 6) (line-start a))
- (assert-equal '(7 . 8) (line-end a))
- (assert-equal 21 (object-color a))
-
- (set-line! a '(5 . 6) '(7 . 8) 22)
- (assert-equal 22 (object-color a))
-
- (set-object-color! a 21)
- (assert-equal 21 (list-ref (line-info a) 2))))
-
-(begin-test 'bus-pins
- (let ((a (make-bus-pin '(1 . 2) '(3 . 4) 21))
- (b (make-bus-pin '(1 . 2) '(3 . 4))))
-
- (assert-equal 'pin (object-type a))
-
- (assert-true (pin? a))
- (assert-true (bus-pin? a))
- (assert-true (not (net-pin? a)))
-
- (assert-equal '(1 . 2) (line-start a))
- (assert-equal '(3 . 4) (line-end a))
- (assert-equal (line-start a) (line-start b))
- (assert-equal (line-end a) (line-end b))
- (assert-equal 21 (object-color a))
- (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
-
- (set-line! a '(5 . 6) '(7 . 8))
- (assert-equal '(5 . 6) (line-start a))
- (assert-equal '(7 . 8) (line-end a))
- (assert-equal 21 (object-color a))
-
- (set-line! a '(5 . 6) '(7 . 8) 22)
- (assert-equal 22 (object-color a))
-
- (set-object-color! a 21)
- (assert-equal 21 (list-ref (line-info a) 2))))
diff --git a/libgeda/scheme/unit-tests/t0011-object-box.scm b/libgeda/scheme/unit-tests/t0011-object-box.scm
deleted file mode 100644
index 15a9612..0000000
--- a/libgeda/scheme/unit-tests/t0011-object-box.scm
+++ /dev/null
@@ -1,36 +0,0 @@
-;; Test Scheme procedures related to box objects.
-
-(use-modules (unit-test))
-(use-modules (geda object))
-
-(begin-test 'boxes
- (let* ((a (make-box '(1 . 4) '(3 . 2) 21))
- (b (copy-object a)))
-
- (assert-equal 'box (object-type a))
-
- (assert-true (box? a))
- (assert-true (box? b))
-
- (assert-equal '(1 . 4) (box-top-left a))
- (assert-equal '(3 . 2) (box-bottom-right a))
- (assert-equal (box-top-left a) (box-top-left b))
- (assert-equal (box-bottom-right a) (box-bottom-right b))
- (assert-equal 21 (object-color a))
- (assert-equal (list (box-top-left a) (box-bottom-right a) (object-color a)) (box-info a))
-
- ; Check that set-box! swaps corners around correctly
- (set-box! a '(5 . 6) '(7 . 8))
- (assert-equal '(5 . 8) (box-top-left a))
- (assert-equal '(7 . 6) (box-bottom-right a))
- (set-box! a '(7 . 6) '(5 . 8))
- (assert-equal '(5 . 8) (box-top-left a))
- (assert-equal '(7 . 6) (box-bottom-right a))
- (assert-equal 21 (object-color a))
-
- (set-box! a '(5 . 6) '(7 . 8) 22)
- (assert-equal 22 (object-color a))
-
- (set-object-color! a 21)
- (assert-equal 21 (list-ref (box-info a) 2))
-))
diff --git a/libgeda/scheme/unit-tests/t0012-object-circle.scm b/libgeda/scheme/unit-tests/t0012-object-circle.scm
deleted file mode 100644
index 4cb8323..0000000
--- a/libgeda/scheme/unit-tests/t0012-object-circle.scm
+++ /dev/null
@@ -1,31 +0,0 @@
-;; Test Scheme procedures related to circle objects.
-
-(use-modules (unit-test))
-(use-modules (geda object))
-
-(begin-test 'circles
- (let* ((a (make-circle '(1 . 2) 3 21))
- (b (copy-object a)))
-
- (assert-equal 'circle (object-type a))
-
- (assert-true (circle? a))
- (assert-true (circle? b))
-
- (assert-equal '(1 . 2) (circle-center a))
- (assert-equal 3 (circle-radius a))
- (assert-equal (circle-center a) (circle-center b))
- (assert-equal (circle-radius a) (circle-radius b))
- (assert-equal 21 (object-color a))
- (assert-equal (list (circle-center a) (circle-radius a) (object-color a))
- (circle-info a))
-
- (set-circle! a '(5 . 6) 7)
- (assert-equal '(5 . 6) (circle-center a))
- (assert-equal 7 (circle-radius a))
- (assert-equal 21 (object-color a))
- (set-circle! a '(5 . 6) 7 22)
- (assert-equal 22 (object-color a))
-
- (set-object-color! a 21)
- (assert-equal 21 (list-ref (circle-info a) 2))))
diff --git a/libgeda/scheme/unit-tests/t0013-object-arc.scm b/libgeda/scheme/unit-tests/t0013-object-arc.scm
deleted file mode 100644
index d6c038a..0000000
--- a/libgeda/scheme/unit-tests/t0013-object-arc.scm
+++ /dev/null
@@ -1,40 +0,0 @@
-;; Test Scheme procedures related to arc objects.
-
-(use-modules (unit-test))
-(use-modules (geda object))
-
-(begin-test 'arcs
- (let* ((a (make-arc '(1 . 2) 3 45 90 21))
- (b (copy-object a)))
-
- (assert-equal 'arc (object-type a))
-
- (assert-true (arc? a))
- (assert-true (arc? b))
-
- (assert-equal '(1 . 2) (arc-center a))
- (assert-equal 3 (arc-radius a))
- (assert-equal 45 (arc-start-angle a))
- (assert-equal 90 (arc-end-angle a))
- (assert-equal (arc-center a) (arc-center b))
- (assert-equal (arc-radius a) (arc-radius b))
- (assert-equal (arc-start-angle a) (arc-start-angle b))
- (assert-equal (arc-end-angle a) (arc-end-angle b))
- (assert-equal 21 (object-color a))
- (assert-equal (list (arc-center a) (arc-radius a)
- (arc-start-angle a) (arc-end-angle a)
- (object-color a))
- (arc-info a))
-
- (set-arc! a '(5 . 6) 7 180 270)
- (assert-equal '(5 . 6) (arc-center a))
- (assert-equal 7 (arc-radius a))
- (assert-equal 180 (arc-start-angle a))
- (assert-equal 270 (arc-end-angle a))
- (assert-equal 21 (object-color a))
- (set-arc! a '(5 . 6) 7 180 270 22)
- (assert-equal 22 (object-color a))
-
- (set-object-color! a 21)
- (assert-equal 21 (list-ref (arc-info a) 4))
-))
diff --git a/libgeda/scheme/unit-tests/t0014-object-text.scm b/libgeda/scheme/unit-tests/t0014-object-text.scm
deleted file mode 100644
index 8642243..0000000
--- a/libgeda/scheme/unit-tests/t0014-object-text.scm
+++ /dev/null
@@ -1,84 +0,0 @@
-;; Test Scheme procedures related to text objects.
-
-(use-modules (unit-test))
-(use-modules (geda object))
-
-(begin-test 'text
- (let ((a (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21))
- (b (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both)))
-
- (assert-equal 'text (object-type a))
-
- (assert-true (text? a))
- (assert-true (text? b))
-
- (assert-equal '(1 . 2) (text-anchor a))
- (assert-equal 'lower-left (text-align a))
- (assert-equal 0 (text-angle a))
- (assert-equal "test text" (text-string a))
- (assert-equal 10 (text-size a))
- (assert-true (text-visible? a))
- (assert-equal 'both (text-attribute-mode a))
- (assert-equal 21 (object-color a))
-
- (assert-equal (text-anchor a) (text-anchor b))
- (assert-equal (text-align a) (text-align b))
- (assert-equal (text-angle a) (text-angle b))
- (assert-equal (text-string a) (text-string b))
- (assert-equal (text-size a) (text-size b))
- (assert-equal (text-visible? a) (text-visible? b))
- (assert-equal (text-attribute-mode a) (text-attribute-mode b))
-
- (assert-equal (list (text-anchor a) (text-align a) (text-angle a)
- (text-string a) (text-size a) (text-visible? a)
- (text-attribute-mode a) (object-color a))
- (text-info a))
-
- (set-text! a '(3 . 4) 'upper-right 180 "more text" 20 #f 'name)
- (assert-equal '(3 . 4) (text-anchor a))
- (assert-equal 'upper-right (text-align a))
- (assert-equal 180 (text-angle a))
- (assert-equal "more text" (text-string a))
- (assert-equal 20 (text-size a))
- (assert-true (not (text-visible? a)))
- (assert-equal 'name (text-attribute-mode a))
- (assert-equal 21 (object-color a))
-
- (set-text! a '(3 . 4) 'upper-right 180 "more text" 20 #f 'name 22)
- (assert-equal 22 (object-color a))
-
- (assert-thrown 'misc-error
- (set-text! a '(3 . 4) 'fnord 180 "more text" 20 #f 'name))
- (assert-thrown 'misc-error
- (set-text! a '(3 . 4) 'upper-right 180 "more text" 20 #f 'fnord))
- (assert-thrown 'misc-error
- (set-text! a '(3 . 4) 'upper-right 1 "more text" 20 #f 'name))
- ))
-
-(begin-test 'set-text-visibility!
- (let ((a (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21))
- (b (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21)))
- (assert-true (text-visible? a))
-
- (set-text-visibility! a #f)
- (assert-true (not (text-visible? a)))
-
- (set-text-visibility! a #t)
- (assert-true (text-visible? a))
- (assert-equal (text-info a) (text-info b))
-
- (set-text-visibility! a 'bork)
- (assert-true (text-visible? a))
- (assert-equal (text-info a) (text-info b))))
-
-(begin-test 'set-text-string!
- (let ((a (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21))
- (b (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21)))
- (assert-equal "test text" (text-string a))
-
- (set-text-string! a "new test text")
- (assert-equal "new test text" (text-string a))
-
- (set-text-string! a "test text")
- (assert-equal "test text" (text-string a))
- (assert-equal (text-info a) (text-info b))))
diff --git a/libgeda/scheme/unit-tests/t0015-object-complex.scm b/libgeda/scheme/unit-tests/t0015-object-complex.scm
deleted file mode 100644
index 09cf92f..0000000
--- a/libgeda/scheme/unit-tests/t0015-object-complex.scm
+++ /dev/null
@@ -1,180 +0,0 @@
-;; Test Scheme procedures related to component objects.
-
-(use-modules (unit-test))
-(use-modules (geda object))
-(use-modules (geda page))
-(use-modules (geda attrib))
-
-(begin-test 'component
- (let ((a (make-component "test component" '(1 . 2) 0 #t #f)))
-
- (assert-equal 'complex (object-type a))
-
- (assert-true (component? a))
-
- (assert-equal "test component" (component-basename a))
- (assert-equal '(1 . 2) (component-position a))
- (assert-equal 0 (component-angle a))
- (assert-true (component-mirror? a))
- (assert-true (not (component-locked? a)))
-
- (assert-equal (list (component-basename a) (component-position a)
- (component-angle a) (component-mirror? a)
- (component-locked? a))
- (component-info a))
-
- (set-component! a '(3 . 4) 90 #f #t)
-
- (assert-equal '(3 . 4) (component-position a))
- (assert-equal 90 (component-angle a))
- (assert-true (not (component-mirror? a)))
- (assert-true (component-locked? a))
-
- (assert-thrown 'misc-error
- (set-component! a '(3 . 4) 45 #f #t))))
-
-(begin-test 'component-append
- (let ((A (make-component "test component" '(1 . 2) 0 #t #f))
- (B (make-component "test component" '(1 . 2) 0 #t #f))
- (x (make-line '(0 . 0) '(2 . 0)))
- (y (make-line '(0 . 0) '(0 . 2))))
-
- (assert-equal '() (component-contents A))
-
- (assert-equal A (component-append! A x))
- (assert-equal (list x) (component-contents A))
-
- (component-append! A x)
- (assert-equal (list x) (component-contents A))
-
- (component-append! A y)
- (assert-equal (list x y) (component-contents A))
-
- (assert-thrown 'object-state
- (component-append! B x))))
-
-(begin-test 'component-remove
- (let ((A (make-component "test component" '(1 . 2) 0 #t #f))
- (B (make-component "test component" '(1 . 2) 0 #t #f))
- (x (make-line '(0 . 0) '(2 . 0)))
- (y (make-line '(0 . 0) '(0 . 2)))
- (z (make-line '(1 . 0) '(2 . 2))))
-
- (component-append! A x)
- (assert-equal A (component-remove! A x))
- (assert-equal '() (component-contents A))
- (component-remove! A x)
- (component-remove! B x)
-
- (component-append! A x y)
- (component-remove! A x y)
- (assert-equal '() (component-contents A))
-
- (component-append! A x y)
- (component-remove! A x)
- (assert-equal (list y) (component-contents A))
-
- (assert-thrown 'object-state
- (component-remove! B y))))
-
-(begin-test 'component-append/page
- (let ((P (make-page "/test/page/A"))
- (A (make-component "test component" '(1 . 2) 0 #t #f))
- (x (make-line '(0 . 0) '(2 . 0)))
- (y (make-line '(0 . 0) '(0 . 2))))
- (dynamic-wind
- (lambda () #t)
- (lambda ()
- (page-append! P x)
- (assert-thrown 'object-state
- (component-append! A x))
-
- (page-append! P A)
- (assert-thrown 'object-state
- (component-append! A x))
-
- (component-append! A y)
- (assert-equal (list y) (component-contents A)))
-
- (lambda ()
- (close-page! P)))
- ))
-
-(begin-test 'component-remove/page
- (let ((P (make-page "/test/page/A"))
- (A (make-component "test component" '(1 . 2) 0 #t #f))
- (x (make-line '(0 . 0) '(2 . 0)))
- (y (make-line '(0 . 0) '(0 . 2))))
- (dynamic-wind
- (lambda () #t)
- (lambda ()
- ;; Test that if a primitive object is attached directly to
- ;; a page, attempting to remove it from a component
- ;; doesn't work.
- (page-append! P x)
- (assert-thrown 'object-state
- (component-remove! A x))
-
- (page-append! P A)
- (assert-thrown 'object-state
- (component-remove! A x))
-
- ;; Test that you can remove primitive objects from a
- ;; component that is attached to a page.
- (component-append! A y)
- (component-remove! A y)
- (assert-equal '() (component-contents A)))
-
- (lambda ()
- (close-page! P)))
- ))
-
-(begin-test 'component-translate
- (let* ((A (make-component "test component" '(0 . 0) 0 #t #f))
- (x (make-box '(0 . 2) '(2 . 0))))
-
- (component-append! A x)
- (set-component! A '(1 . 1) 0 #t #f)
- (assert-equal '(1 . 3) (box-top-left x))
- (assert-equal '(3 . 1) (box-bottom-right x))))
-
-(begin-test 'component-remove-attrib
- (let ((comp (make-component "test component" '(1 . 2) 0 #t #f))
- (pin (make-net-pin '(0 . 0) '(100 . 0)))
- (attrib (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both)))
- (component-append! comp pin attrib)
- (attach-attribs! pin attrib)
- (assert-thrown 'object-state (component-remove! comp pin))
- (assert-thrown 'object-state (component-remove! comp attrib))))
-
-
-;; Set up component library, making blatant assumptions about the
-;; directory layout.
-(component-library (string-join (list (getenv "srcdir") "../../symbols/analog") "/")
- "Basic devices")
-
-(begin-test 'component/library
- (let ((A (make-component/library "resistor-1.sym" '(1 . 2) 0 #t #f))
- (B (make-component/library "invalid-component-name" '(1 . 2) 0 #t #f)))
-
- (assert-true A)
- (assert-equal '(1 . 2) (component-position A))
- (assert-equal 0 (component-angle A))
- (assert-true (component-mirror? A))
- (assert-true (not (component-locked? A)))
-
- (assert-equal "resistor-1.sym" (component-basename A))
-
- (assert-true (not (null? (component-contents A))))
-
- (assert-true (not B))))
-
-;; Clear component library again
-(reset-component-library)
-
-(begin-test 'object-component
- (let* ((A (make-component "test component" '(0 . 0) 0 #t #f))
- (x (make-box '(0 . 2) '(2 . 0))))
- (assert-equal #f (object-component x))
- (component-append! A x)
- (assert-equal A (object-component x))))
diff --git a/libgeda/scheme/unit-tests/t0016-object-bounds.scm b/libgeda/scheme/unit-tests/t0016-object-bounds.scm
deleted file mode 100644
index a896b8c..0000000
--- a/libgeda/scheme/unit-tests/t0016-object-bounds.scm
+++ /dev/null
@@ -1,53 +0,0 @@
-;; Test Scheme procedures for working with object bounds.
-
-(use-modules (unit-test))
-(use-modules (geda object))
-
-(begin-test 'bounds
- (let ((x (make-box '(0 . 1) '(1 . 0)))
- (y (make-box '(2 . 3) '(3 . 2)))
- (t (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both))
- (C (make-component "test component" '(0 . 0) 0 #t #f)))
-
- ;; No arguments
- (assert-equal #f (object-bounds))
-
- ;; Single argument
- (assert-equal '((0 . 1) . (1 . 0)) (object-bounds x))
-
- ;; Multiple arguments
- (assert-equal '((0 . 3) . (3 . 0)) (object-bounds x y))
-
- ;; Unfortunately, libgeda has no text renderer, so text never has
- ;; any bounds. What a shame.
- (assert-true (not (object-bounds t)))
-
- ;; Empty components should have no bounds...
- (assert-equal '() (component-contents C))
- (assert-true (not (object-bounds C)))
-
- ;; ... but they should get bounds when you add stuff to them.
- (component-append! C x)
- (assert-equal '((0 . 1) . (1 . 0)) (object-bounds x))
- ))
-
-(begin-test 'fold-bounds
- (let ((x (make-box '(0 . 1) '(1 . 0)))
- (y (make-box '(2 . 3) '(3 . 2))))
-
- ;; No arguments
- (assert-equal #f (fold-bounds #f))
-
- ;; One argument
- (let ((a (object-bounds x)))
- (assert-equal a (fold-bounds a))
- (assert-equal #f (fold-bounds #f)))
-
- ;; > 1 argument
- (let ((a (object-bounds x))
- (b (object-bounds y)))
- (assert-equal '((0 . 3) . (3 . 0))
- (fold-bounds a b))
- (assert-equal a (fold-bounds #f a))
- (assert-equal a (fold-bounds a #f))
- (assert-equal #f (fold-bounds #f #f)))))
diff --git a/libgeda/scheme/unit-tests/t0017-object-stroke-fill.scm b/libgeda/scheme/unit-tests/t0017-object-stroke-fill.scm
deleted file mode 100644
index ecf74c3..0000000
--- a/libgeda/scheme/unit-tests/t0017-object-stroke-fill.scm
+++ /dev/null
@@ -1,43 +0,0 @@
-;; Test Scheme procedures for object stroke properties.
-
-(use-modules (unit-test))
-(use-modules (geda object))
-
-(begin-test 'stroke
- (let ((a (make-line '(1 . 2) '(3 . 4))))
-
- (assert-equal a (set-object-stroke! a 1 'none 'solid 'foo 'bar))
- (assert-equal 1 (object-stroke-width a))
- (assert-equal 'none (object-stroke-cap a))
- (assert-equal '(solid) (object-stroke-dash a))
-
- (set-object-stroke! a 1 'square 'dotted 2 'bar)
- (assert-equal 'square (object-stroke-cap a))
- (assert-equal '(dotted 2) (object-stroke-dash a))
-
- (set-object-stroke! a 1 'round 'dashed 3 4)
- (assert-equal 'round (object-stroke-cap a))
- (assert-equal '(dashed 3 4) (object-stroke-dash a))
-
- (set-object-stroke! a 1 'round 'center 5 6)
- (assert-equal '(center 5 6) (object-stroke-dash a))
-
- (set-object-stroke! a 1 'round 'phantom 7 8)
- (assert-equal '(phantom 7 8) (object-stroke-dash a))
- ))
-
-(begin-test 'fill
- (let ((a (make-box '(1 . 2) '(3 . 4))))
-
- (assert-equal a (set-object-fill! a 'hollow))
- (assert-equal '(hollow) (object-fill a))
-
- (assert-equal a (set-object-fill! a 'solid))
- (assert-equal '(solid) (object-fill a))
-
- (assert-equal a (set-object-fill! a 'hatch 1 2 3))
- (assert-equal '(hatch 1 2 3) (object-fill a))
-
- (assert-equal a (set-object-fill! a 'mesh 4 5 6 7 8))
- (assert-equal '(mesh 4 5 6 7 8) (object-fill a))
- ))
diff --git a/libgeda/scheme/unit-tests/t0018-object-connections.scm b/libgeda/scheme/unit-tests/t0018-object-connections.scm
deleted file mode 100644
index 3665f34..0000000
--- a/libgeda/scheme/unit-tests/t0018-object-connections.scm
+++ /dev/null
@@ -1,67 +0,0 @@
-; Test Scheme procedures for getting connections.
-
-(use-modules (unit-test))
-(use-modules (geda object))
-(use-modules (geda page))
-
-(define P (make-page "/test/page/A"))
-
-(begin-test 'object-connections
- (let ((C (make-component "test component" '(1 . 2) 0 #t #f))
- (np (make-net-pin '(100 . 0) '(0 . 0)))
- (bp (make-bus-pin '(100 . 200) '(0 . 200)))
- (n1 (make-net '(100 . 0) '(100 . 100)))
- (n2 (make-net '(100 . 100) '(200 . 100)))
- (b1 (make-bus '(100 . 200) '(200 . 200)))
- (b2 (make-bus '(200 . 100) '(200 . 200))))
-
- (assert-thrown 'object-state (object-connections np))
-
- ;; Build component
- (component-append! C np bp)
- (assert-thrown 'object-state (object-connections np))
-
- ;; Build page
- (page-append! P C n1 n2 b1 b2)
-
- ;; Test initial connections
- (assert-equal (list n1 b1) (object-connections C))
-
- (assert-equal (list n1) (object-connections np))
- (assert-equal (list np n2) (object-connections n1))
- (assert-equal (list n1) (object-connections n2))
-
- (assert-equal (list b1) (object-connections bp))
- (assert-equal (list bp b2) (object-connections b1))
- (assert-equal (list b1) (object-connections b2))
-
- ;; Break some stuff
- (page-remove! P n1)
- (component-remove! C bp)
-
- ;; Test modified connections
- (assert-equal '() (object-connections np))
- (assert-thrown 'object-state (object-connections n1))
- (assert-equal '() (object-connections n2))
-
- (assert-thrown 'object-state (object-connections bp))
- (assert-equal (list b2) (object-connections b1))
- (assert-equal (list b1) (object-connections b2))
-
- ;; Change stuff back
- (page-append! P n1)
- (component-append! C bp)
-
- ;; Test modified connections
- (assert-equal (list n1 b1) (object-connections C))
-
- (assert-equal (list n1) (object-connections np))
- (assert-equal (list np n2) (object-connections n1))
- (assert-equal (list n1) (object-connections n2))
-
- (assert-equal (list b1) (object-connections bp))
- (assert-equal (list b2 bp) (object-connections b1))
- (assert-equal (list b1) (object-connections b2))
- ))
-
-(close-page! P)
diff --git a/libgeda/scheme/unit-tests/t0019-object-copy.scm b/libgeda/scheme/unit-tests/t0019-object-copy.scm
deleted file mode 100644
index c5a917f..0000000
--- a/libgeda/scheme/unit-tests/t0019-object-copy.scm
+++ /dev/null
@@ -1,45 +0,0 @@
-;; Test object copying
-
-(use-modules (unit-test))
-(use-modules (geda object))
-(use-modules (geda page))
-(use-modules (geda attrib))
-(use-modules (srfi srfi-1))
-
-;; This test verifies that if an object is copied, any links to
-;; containing pages, containing components are removed, and any
-;; attribute attachments are broken.
-(begin-test 'copy-object-breaks-links
- (let ((P (make-page "/test/page/A"))
- (A (make-component "test component" '(0 . 0) 0 #t #f))
- (p (make-net-pin '(0 . 0) '(100 . 0)))
- (x (make-text '(1 . 2) 'lower-left 0 "name=x" 10 #t 'both)))
-
- (page-append! P A x)
-
- (assert-equal P (object-page x))
- (assert-equal #f (object-page (copy-object x)))
-
- (attach-attribs! A x)
-
- (assert-equal A (attrib-attachment x))
- (assert-equal #f (attrib-attachment (copy-object x)))
-
- (detach-attribs! A x)
- (page-remove! P x)
- (component-append! A p x)
-
- (assert-equal A (object-component x))
- (assert-equal #f (object-component (copy-object x)))
-
- (attach-attribs! p x)
- (assert-equal p (attrib-attachment x))
- (assert-equal #f (attrib-attachment (copy-object x)))))
-
-;; This test checks that copies of components are deep copies.
-(begin-test 'copy-object-deep-component
- (let* ((A (make-component "test component" '(0 . 0) 0 #t #f))
- (p (make-net-pin '(0 . 0) '(100 . 0))))
- (component-append! A p)
- (assert-equal (list p) (member p (component-contents A)))
- (assert-equal #f (member p (component-contents (copy-object A))))))
diff --git a/libgeda/scheme/unit-tests/t0020-page.scm b/libgeda/scheme/unit-tests/t0020-page.scm
deleted file mode 100644
index 0837c92..0000000
--- a/libgeda/scheme/unit-tests/t0020-page.scm
+++ /dev/null
@@ -1,81 +0,0 @@
-;; Test Scheme procedures related to pages.
-
-(use-modules (unit-test))
-(use-modules (geda page))
-(use-modules (geda object))
-(use-modules (geda attrib))
-
-(begin-test 'page
- (let ((page-a (make-page "/test/page/A"))
- (page-b (make-page "/test/page/B")))
- (assert-equal "/test/page/A" (page-filename page-a))
- (assert-equal (list page-a page-b) (active-pages))
-
- (assert-equal page-a (set-page-filename! page-a "/test/page/C"))
- (assert-equal "/test/page/C" (page-filename page-a))
-
- (close-page! page-a)
- (assert-equal (list page-b) (active-pages))
- (close-page! page-b)))
-
-(begin-test 'page-append
- (let ((A (make-page "/test/page/C"))
- (B (make-page "/test/page/D"))
- (x (make-line '(0 . 0) '(1 . 2)))
- (y (make-line '(0 . 1) '(2 . 2))))
-
- (dynamic-wind ; Make sure pages are cleaned up
- (lambda () #f)
- (lambda ()
- (assert-equal '() (page-contents A))
-
- (assert-equal A (page-append! A x))
- (assert-equal (list x) (page-contents A))
-
- (assert-equal A (page-append! A x y))
- (assert-equal (list x y) (page-contents A))
-
- (assert-thrown 'object-state
- (page-append! B x))
-
- (assert-thrown 'object-state
- (let* ((C (make-component "test component" '(1 . 2) 0 #t #f))
- (z (make-line '(1 . 0) '(2 . 2))))
- (component-append! C z)
- (page-append! A z))))
-
- (lambda ()
- (close-page! A)
- (close-page! B)))))
-
-(begin-test 'page-remove
- (let ((A (make-page "/test/page/E"))
- (B (make-page "/test/page/F"))
- (C (make-component "test component" '(1 . 2) 0 #t #f))
- (x (make-line '(0 . 0) '(2 . 0)))
- (y (make-line '(0 . 0) '(0 . 2)))
- (z (make-line '(1 . 0) '(2 . 2))))
-
- (dynamic-wind ; Make sure pages are cleaned up
- (lambda () #f)
- (lambda ()
- (page-append! A x)
- (assert-equal A (page-remove! A x))
- (assert-equal '() (page-contents A))
- (assert-equal A (page-remove! A x))
- (assert-equal B (page-remove! B x))
-
- (page-append! A x y)
- (assert-equal A (page-remove! A x))
- (assert-equal (list y) (page-contents A))
-
- (assert-thrown 'object-state
- (page-remove! B y))
-
- (component-append! C z)
- (assert-thrown 'object-state
- (page-remove! A z)))
-
- (lambda ()
- (close-page! A)
- (close-page! B)))))
diff --git a/libgeda/scheme/unit-tests/t0021-page-dirty.scm b/libgeda/scheme/unit-tests/t0021-page-dirty.scm
deleted file mode 100644
index b450ed8..0000000
--- a/libgeda/scheme/unit-tests/t0021-page-dirty.scm
+++ /dev/null
@@ -1,118 +0,0 @@
-;; Test Scheme procedures related to pages' changed flags.
-
-(use-modules (unit-test))
-(use-modules (geda page))
-(use-modules (geda object))
-(use-modules (geda attrib))
-(or (defined? 'define-syntax)
- (use-modules (ice-9 syncase)))
-
-;; Utility macro to avoid boilerplate
-(define-syntax assert-dirties
- (syntax-rules ()
- ((_ P . test-forms)
- (begin (begin . test-forms)
- (assert-true (page-dirty? P))
- (set-page-dirty! P #f)))))
-
-(begin-test 'page-dirty
- (let ((P (make-page "/test/page/A"))
- (C (make-component "test component" '(1 . 2) 0 #t #f)))
-
- (dynamic-wind ; Make sure pages are cleaned up
- (lambda () #f)
- (lambda ()
- (assert-true (not (page-dirty? P)))
-
- (set-page-dirty! P)
- (assert-true (page-dirty? P))
-
- (set-page-dirty! P #f)
- (assert-true (not (page-dirty? P)))
-
- (assert-dirties P (set-page-dirty! P #t))
- (assert-dirties P (page-append! P C))
- (assert-dirties P (page-remove! P C)))
- (lambda ()
- (close-page! P)))))
-
-(begin-test 'page-dirty-objects
- (let ((P (make-page "/test/page/A"))
- (l (make-line '(1 . 2) '(3 . 4)))
- (b (make-box '(1 . 4) '(3 . 2)))
- (c (make-circle '(1 . 2) 3))
- (a (make-arc '(1 . 2) 3 45 90))
- (t (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both))
- (C (make-component "test component" '(1 . 2) 0 #t #f)))
-
- (dynamic-wind ; Make sure pages are cleaned up
- (lambda () #f)
- (lambda ()
-
- ; Add everything to the page
- (assert-dirties P (for-each (lambda (x) (page-append! P x))
- (list l b c a t C)))
-
- (assert-dirties P (apply set-line! l (line-info l)))
- (assert-dirties P (apply set-box! b (box-info b)))
- (assert-dirties P (apply set-circle! c (circle-info c)))
- (assert-dirties P (apply set-arc! a (arc-info a)))
- (assert-dirties P (apply set-text! t (text-info t)))
- (assert-dirties P (apply set-component! C
- (list-tail (component-info C) 1)))
-
- ; Remove primitives from page
- (assert-dirties P (for-each (lambda (x) (page-remove! P x))
- (list l b c a t)))
-
- ; Add primitives to component
- (for-each (lambda (x) (assert-dirties P (component-append! C x)))
- (list l b c a t))
-
- ; Modify primitives within component
- (assert-dirties P (apply set-line! l (line-info l)))
- (assert-dirties P (apply set-box! b (box-info b)))
- (assert-dirties P (apply set-circle! c (circle-info c)))
- (assert-dirties P (apply set-arc! a (arc-info a)))
- (assert-dirties P (apply set-text! t (text-info t)))
-
- ; Remove primitives from component
- (for-each (lambda (x) (assert-dirties P (component-remove! C x)))
- (list l b c a t)))
-
- (lambda ()
- (for-each (lambda (x) (page-remove! P x)) (page-contents P))
- (close-page! P)))
-
- ))
-
-(begin-test 'page-dirty-attribs
- (let ((P (make-page "/test/page/A"))
- (p (make-net-pin '(0 . 0) '(100 . 0)))
- (t (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
- (C (make-component "test component" '(1 . 2) 0 #t #f)))
-
- (dynamic-wind ; Make sure pages are cleaned up
- (lambda () #f)
- (lambda ()
- ; Populate page
- (page-append! P t C) (component-append! C p)
-
- ; Attach attribute to component
- (assert-dirties P (attach-attribs! C t))
- ; Detach attribute from component
- (assert-dirties P (detach-attribs! C t))
-
- ; Move attribute into component
- (page-remove! P t)
- (component-append! C t)
-
- ; Attach attribute to pin
- (assert-dirties P (attach-attribs! p t))
- ; Detach attribute from pin
- (assert-dirties P (detach-attribs! p t))
- )
- (lambda ()
- (close-page! P)))
-
- ))
diff --git a/libgeda/scheme/unit-tests/t0030-attribute.scm b/libgeda/scheme/unit-tests/t0030-attribute.scm
deleted file mode 100644
index d63cc07..0000000
--- a/libgeda/scheme/unit-tests/t0030-attribute.scm
+++ /dev/null
@@ -1,187 +0,0 @@
-;; Test Scheme procedures related to attributes.
-
-(use-modules (unit-test))
-(use-modules (geda attrib))
-(use-modules (geda page))
-(use-modules (geda object))
-
-(begin-test 'parse-attrib
- (let ((good (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
- (bad (make-text '(1 . 2) 'lower-left 0 "name value" 10 #t 'both)))
-
- (assert-equal #t (attribute? good))
- (assert-equal #f (attribute? bad))
-
- (assert-equal "name" (attrib-name good))
- (assert-equal "value" (attrib-value good))
- (assert-equal (cons (attrib-name good) (attrib-value good))
- (parse-attrib good))
-
- (assert-thrown 'attribute-format (parse-attrib bad))
- (assert-thrown 'attribute-format (attrib-name bad))
- (assert-thrown 'attribute-format (attrib-value bad)) ))
-
-(begin-test 'attach-attrib
- (let ((C (make-component "testcomponent1" '(0 . 0) 0 #f #f))
- (D (make-component "testcomponent2" '(0 . 0) 0 #f #f))
- (p (make-net-pin '(0 . 0) '(100 . 0)))
- (q (make-net-pin '(0 . 0) '(100 . 0)))
- (x (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both))
- (y (make-text '(0 . 0) 'lower-left 0 "name=y" 10 #t 'both))
- (z (make-text '(0 . 0) 'lower-left 0 "name=z" 10 #t 'both)))
-
- ;; Attach attribute outside component or page
- (assert-thrown 'object-state (attach-attribs! C x))
- (assert-equal '() (object-attribs C))
- (assert-true (not (attrib-attachment x)))
-
- ;; Populate components
- (component-append! C p q x y)
- (component-append! D z)
-
- ;; Attach attribute to object in same component
- (assert-equal p (attach-attribs! p x))
- (assert-equal (list x) (object-attribs p))
- (assert-equal p (attrib-attachment x))
-
- ;; Attach attribute twice
- (assert-equal p (attach-attribs! p x))
- (assert-equal (list x) (object-attribs p))
- (assert-equal p (attrib-attachment x))
-
- ;; Attach attribute which is already attached, within same
- ;; component
- (assert-thrown 'object-state (attach-attribs! q x))
-
- ;; Attach attribute to object in different component
- (assert-thrown 'object-state (attach-attribs! p z))
- (assert-equal (list x) (object-attribs p))
- (assert-true (not (attrib-attachment z)))
-
- ;; Attach internal attribute to containing component
- (assert-thrown 'object-state (attach-attribs! D z))
- (assert-equal '() (object-attribs D))
- (assert-true (not (attrib-attachment z)))
-
- ;; Attach attribute in component to floating object
- (assert-thrown 'object-state (attach-attribs! C z))
- (assert-equal '() (object-attribs C))
- (assert-true (not (attrib-attachment z)))
-
- ;; Attach floating attribute to object in component
- (component-remove! D z)
- (assert-thrown 'object-state (attach-attribs! p z))
- (assert-equal (list x) (object-attribs p))
- (assert-true (not (attrib-attachment z)))
-
- ;; Attach multiple attributes
- (assert-equal p (attach-attribs! p y))
- (assert-equal (list x y) (object-attribs p))
- (assert-equal p (attrib-attachment y))
- ))
-
-(begin-test 'attach-attrib/page
- (let ((P (make-page "/test/page/A"))
- (Q (make-page "/test/page/A"))
- (p (make-net-pin '(0 . 0) '(100 . 0)))
- (x (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
- (y (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
- (z (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
- (C (make-component "test component" '(1 . 2) 0 #t #f)))
-
- (dynamic-wind ; Make sure pages are cleaned up
- (lambda () #f)
- (lambda ()
- ; Populate pages
- (page-append! P x C)
- (component-append! C p y)
-
- (page-append! Q z)
-
- ; Attach attribute to component in same page
- (attach-attribs! C x)
- (assert-equal (list x) (object-attribs C))
- (assert-equal C (attrib-attachment x))
-
- ; Remove stuff from page
- (assert-thrown 'object-state (page-remove! P x))
- (assert-thrown 'object-state (page-remove! P C))
-
- ; Attach attribute to component in different page
- (assert-thrown 'object-state (attach-attribs! C z))
-
- ; Attach attribute to pin in component in page
- (attach-attribs! p y)
- (assert-equal (list y) (object-attribs p))
- (assert-equal p (attrib-attachment y))
-
- ; Remove stuff from component in page
- (assert-thrown 'object-state (component-remove! C p))
- (assert-thrown 'object-state (component-remove! C y)) )
- (lambda ()
- (close-page! P)
- (close-page! Q) ))
-
- ))
-
-(begin-test 'detach-attrib
- (let ((page (make-page "/test/page/1"))
- (pin1 (make-net-pin '(0 . 0) '(100 . 0)))
- (pin2 (make-net-pin '(0 . 100) '(100 . 100)))
- (x (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both)))
-
- (page-append! page pin1 pin2 x)
-
- ;; Detach when already detached
- (assert-equal pin1 (detach-attribs! pin1 x))
-
- (attach-attribs! pin1 x)
-
- (assert-thrown 'object-state
- (detach-attribs! pin2 x))
-
- (assert-equal pin1 (detach-attribs! pin1 x))
- (assert-equal '() (object-attribs pin1)) ))
-
-(begin-test 'inherited-attribs
- (let ((C (make-component "test component" '(1 . 2) 0 #t #f))
- (p (make-net-pin '(0 . 0) '(100 . 0)))
- (x (make-text '(1 . 2) 'lower-left 0 "name=x" 10 #t 'both))
- (y (make-text '(1 . 2) 'lower-left 0 "name=y" 10 #t 'both)))
-
- (assert-equal '() (inherited-attribs p))
- (assert-equal '() (inherited-attribs C))
-
- ;; Set up component
- (component-append! C p x y)
-
- (assert-equal (list x y) (inherited-attribs C))
-
- (attach-attribs! p x)
-
- (assert-equal (list y) (inherited-attribs C))))
-
-(begin-test 'attrib-inherited?
- (let* ((P (make-page "/test/page/1"))
- (A (make-component "test component" '(0 . 0) 0 #t #f))
- (p (make-net-pin '(0 . 0) '(100 . 0)))
- (w (make-text '(1 . 2) 'lower-left 0 "name=x" 10 #t 'both))
- (x (make-text '(1 . 2) 'lower-left 0 "name=x" 10 #t 'both))
- (y (make-text '(1 . 2) 'lower-left 0 "name=y" 10 #t 'both))
- (z (make-text '(1 . 2) 'lower-left 0 "name=z" 10 #t 'both)))
-
- (page-append! P A w x)
- (attach-attribs! A x)
- (component-append! A p y z)
- (attach-attribs! p y)
-
- (assert-true (not (attrib-inherited? w)))
- (assert-true (not (attrib-inherited? x)))
- (assert-true (not (attrib-inherited? y)))
- (assert-true (attrib-inherited? z))))
-
-(begin-test 'set-attrib-value!
- (let ((a (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both)))
- (set-attrib-value! a "foo")
- (assert-equal "name" (attrib-name a))
- (assert-equal "foo" (attrib-value a))))
diff --git a/libgeda/scheme/unit-tests/t0031-promotable-attributes.scm b/libgeda/scheme/unit-tests/t0031-promotable-attributes.scm
deleted file mode 100644
index ba6d668..0000000
--- a/libgeda/scheme/unit-tests/t0031-promotable-attributes.scm
+++ /dev/null
@@ -1,30 +0,0 @@
-;; Test promotable-attributes function
-
-(use-modules (unit-test))
-(use-modules (geda page))
-(use-modules (geda object))
-(use-modules (geda attrib))
-
-;; Unfortunately, we can't test this at the moment, because the
-;; default list of promotable attribute names is empty. We suppress
-;; config file loading when running the unit tests, and even though we
-;; could call the (always-promote-attributes ...) config file
-;; procedure, but it wouldn't do us any good because we can't call
-;; i_vars_libgeda_set() from Scheme [1]. So instead, we just fail.
-;;
-;; [1] This is a good thing -- it shouldn't be necessary!
-(begin-test 'promotable-attributes
- (throw 'missing-unit-test "We can't test this at the moment"))
-
-(begin-test 'promote-attribs!
- (throw 'missing-unit-test "We can't test this at the moment"))
-
-(begin-test 'promote-attribs!/not-in-page
- (let ((p (make-net-pin '(0 . 0) '(100 . 0))))
- (assert-thrown 'object-state (promote-attribs! p))))
-
-(begin-test 'promote-attribs!/non-component
- (let ((P (make-page "/test/page/A"))
- (p (make-net-pin '(0 . 0) '(100 . 0))))
- (page-append! P p)
- (assert-equal '() (promote-attribs! p))))
diff --git a/libgeda/scheme/unit-tests/t0100-object-line.scm b/libgeda/scheme/unit-tests/t0100-object-line.scm
new file mode 100644
index 0000000..7edbb95
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0100-object-line.scm
@@ -0,0 +1,140 @@
+;; Test Scheme procedures related to line objects.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'lines
+ (let ((a (make-line '(1 . 2) '(3 . 4) 21))
+ (b (make-line '(1 . 2) '(3 . 4))))
+
+ (assert-equal 'line (object-type a))
+
+ (assert-true (line? a))
+
+ (assert-equal '(1 . 2) (line-start a))
+ (assert-equal '(3 . 4) (line-end a))
+ (assert-equal (line-start a) (line-start b))
+ (assert-equal (line-end a) (line-end b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
+
+ (set-line! a '(5 . 6) '(7 . 8))
+ (assert-equal '(5 . 6) (line-start a))
+ (assert-equal '(7 . 8) (line-end a))
+ (assert-equal 21 (object-color a))
+
+ (set-line! a '(5 . 6) '(7 . 8) 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (line-info a) 2))))
+
+(make-net '(1 . 2) '(3 . 4))
+
+(begin-test 'nets
+ (let ((a (make-net '(1 . 2) '(3 . 4) 21))
+ (b (make-net '(1 . 2) '(3 . 4))))
+
+ (assert-equal 'net (object-type a))
+
+ (assert-true (net? a))
+
+ (assert-equal '(1 . 2) (line-start a))
+ (assert-equal '(3 . 4) (line-end a))
+ (assert-equal (line-start a) (line-start b))
+ (assert-equal (line-end a) (line-end b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
+
+ (set-line! a '(5 . 6) '(7 . 8))
+ (assert-equal '(5 . 6) (line-start a))
+ (assert-equal '(7 . 8) (line-end a))
+ (assert-equal 21 (object-color a))
+
+ (set-line! a '(5 . 6) '(7 . 8) 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (line-info a) 2))))
+
+(begin-test 'buses
+ (let ((a (make-bus '(1 . 2) '(3 . 4) 21))
+ (b (make-bus '(1 . 2) '(3 . 4))))
+
+ (assert-equal 'bus (object-type a))
+
+ (assert-true (bus? a))
+
+ (assert-equal '(1 . 2) (line-start a))
+ (assert-equal '(3 . 4) (line-end a))
+ (assert-equal (line-start a) (line-start b))
+ (assert-equal (line-end a) (line-end b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
+
+ (set-line! a '(5 . 6) '(7 . 8))
+ (assert-equal '(5 . 6) (line-start a))
+ (assert-equal '(7 . 8) (line-end a))
+ (assert-equal 21 (object-color a))
+
+ (set-line! a '(5 . 6) '(7 . 8) 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (line-info a) 2))))
+
+(begin-test 'net-pins
+ (let ((a (make-net-pin '(1 . 2) '(3 . 4) 21))
+ (b (make-net-pin '(1 . 2) '(3 . 4))))
+
+ (assert-equal 'pin (object-type a))
+
+ (assert-true (pin? a))
+ (assert-true (net-pin? a))
+ (assert-true (not (bus-pin? a)))
+
+ (assert-equal '(1 . 2) (line-start a))
+ (assert-equal '(3 . 4) (line-end a))
+ (assert-equal (line-start a) (line-start b))
+ (assert-equal (line-end a) (line-end b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
+
+ (set-line! a '(5 . 6) '(7 . 8))
+ (assert-equal '(5 . 6) (line-start a))
+ (assert-equal '(7 . 8) (line-end a))
+ (assert-equal 21 (object-color a))
+
+ (set-line! a '(5 . 6) '(7 . 8) 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (line-info a) 2))))
+
+(begin-test 'bus-pins
+ (let ((a (make-bus-pin '(1 . 2) '(3 . 4) 21))
+ (b (make-bus-pin '(1 . 2) '(3 . 4))))
+
+ (assert-equal 'pin (object-type a))
+
+ (assert-true (pin? a))
+ (assert-true (bus-pin? a))
+ (assert-true (not (net-pin? a)))
+
+ (assert-equal '(1 . 2) (line-start a))
+ (assert-equal '(3 . 4) (line-end a))
+ (assert-equal (line-start a) (line-start b))
+ (assert-equal (line-end a) (line-end b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
+
+ (set-line! a '(5 . 6) '(7 . 8))
+ (assert-equal '(5 . 6) (line-start a))
+ (assert-equal '(7 . 8) (line-end a))
+ (assert-equal 21 (object-color a))
+
+ (set-line! a '(5 . 6) '(7 . 8) 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (line-info a) 2))))
diff --git a/libgeda/scheme/unit-tests/t0101-object-box.scm b/libgeda/scheme/unit-tests/t0101-object-box.scm
new file mode 100644
index 0000000..15a9612
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0101-object-box.scm
@@ -0,0 +1,36 @@
+;; Test Scheme procedures related to box objects.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'boxes
+ (let* ((a (make-box '(1 . 4) '(3 . 2) 21))
+ (b (copy-object a)))
+
+ (assert-equal 'box (object-type a))
+
+ (assert-true (box? a))
+ (assert-true (box? b))
+
+ (assert-equal '(1 . 4) (box-top-left a))
+ (assert-equal '(3 . 2) (box-bottom-right a))
+ (assert-equal (box-top-left a) (box-top-left b))
+ (assert-equal (box-bottom-right a) (box-bottom-right b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (box-top-left a) (box-bottom-right a) (object-color a)) (box-info a))
+
+ ; Check that set-box! swaps corners around correctly
+ (set-box! a '(5 . 6) '(7 . 8))
+ (assert-equal '(5 . 8) (box-top-left a))
+ (assert-equal '(7 . 6) (box-bottom-right a))
+ (set-box! a '(7 . 6) '(5 . 8))
+ (assert-equal '(5 . 8) (box-top-left a))
+ (assert-equal '(7 . 6) (box-bottom-right a))
+ (assert-equal 21 (object-color a))
+
+ (set-box! a '(5 . 6) '(7 . 8) 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (box-info a) 2))
+))
diff --git a/libgeda/scheme/unit-tests/t0102-object-circle.scm b/libgeda/scheme/unit-tests/t0102-object-circle.scm
new file mode 100644
index 0000000..4cb8323
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0102-object-circle.scm
@@ -0,0 +1,31 @@
+;; Test Scheme procedures related to circle objects.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'circles
+ (let* ((a (make-circle '(1 . 2) 3 21))
+ (b (copy-object a)))
+
+ (assert-equal 'circle (object-type a))
+
+ (assert-true (circle? a))
+ (assert-true (circle? b))
+
+ (assert-equal '(1 . 2) (circle-center a))
+ (assert-equal 3 (circle-radius a))
+ (assert-equal (circle-center a) (circle-center b))
+ (assert-equal (circle-radius a) (circle-radius b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (circle-center a) (circle-radius a) (object-color a))
+ (circle-info a))
+
+ (set-circle! a '(5 . 6) 7)
+ (assert-equal '(5 . 6) (circle-center a))
+ (assert-equal 7 (circle-radius a))
+ (assert-equal 21 (object-color a))
+ (set-circle! a '(5 . 6) 7 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (circle-info a) 2))))
diff --git a/libgeda/scheme/unit-tests/t0103-object-arc.scm b/libgeda/scheme/unit-tests/t0103-object-arc.scm
new file mode 100644
index 0000000..d6c038a
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0103-object-arc.scm
@@ -0,0 +1,40 @@
+;; Test Scheme procedures related to arc objects.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'arcs
+ (let* ((a (make-arc '(1 . 2) 3 45 90 21))
+ (b (copy-object a)))
+
+ (assert-equal 'arc (object-type a))
+
+ (assert-true (arc? a))
+ (assert-true (arc? b))
+
+ (assert-equal '(1 . 2) (arc-center a))
+ (assert-equal 3 (arc-radius a))
+ (assert-equal 45 (arc-start-angle a))
+ (assert-equal 90 (arc-end-angle a))
+ (assert-equal (arc-center a) (arc-center b))
+ (assert-equal (arc-radius a) (arc-radius b))
+ (assert-equal (arc-start-angle a) (arc-start-angle b))
+ (assert-equal (arc-end-angle a) (arc-end-angle b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (arc-center a) (arc-radius a)
+ (arc-start-angle a) (arc-end-angle a)
+ (object-color a))
+ (arc-info a))
+
+ (set-arc! a '(5 . 6) 7 180 270)
+ (assert-equal '(5 . 6) (arc-center a))
+ (assert-equal 7 (arc-radius a))
+ (assert-equal 180 (arc-start-angle a))
+ (assert-equal 270 (arc-end-angle a))
+ (assert-equal 21 (object-color a))
+ (set-arc! a '(5 . 6) 7 180 270 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (arc-info a) 4))
+))
diff --git a/libgeda/scheme/unit-tests/t0104-object-text.scm b/libgeda/scheme/unit-tests/t0104-object-text.scm
new file mode 100644
index 0000000..8642243
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0104-object-text.scm
@@ -0,0 +1,84 @@
+;; Test Scheme procedures related to text objects.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'text
+ (let ((a (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21))
+ (b (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both)))
+
+ (assert-equal 'text (object-type a))
+
+ (assert-true (text? a))
+ (assert-true (text? b))
+
+ (assert-equal '(1 . 2) (text-anchor a))
+ (assert-equal 'lower-left (text-align a))
+ (assert-equal 0 (text-angle a))
+ (assert-equal "test text" (text-string a))
+ (assert-equal 10 (text-size a))
+ (assert-true (text-visible? a))
+ (assert-equal 'both (text-attribute-mode a))
+ (assert-equal 21 (object-color a))
+
+ (assert-equal (text-anchor a) (text-anchor b))
+ (assert-equal (text-align a) (text-align b))
+ (assert-equal (text-angle a) (text-angle b))
+ (assert-equal (text-string a) (text-string b))
+ (assert-equal (text-size a) (text-size b))
+ (assert-equal (text-visible? a) (text-visible? b))
+ (assert-equal (text-attribute-mode a) (text-attribute-mode b))
+
+ (assert-equal (list (text-anchor a) (text-align a) (text-angle a)
+ (text-string a) (text-size a) (text-visible? a)
+ (text-attribute-mode a) (object-color a))
+ (text-info a))
+
+ (set-text! a '(3 . 4) 'upper-right 180 "more text" 20 #f 'name)
+ (assert-equal '(3 . 4) (text-anchor a))
+ (assert-equal 'upper-right (text-align a))
+ (assert-equal 180 (text-angle a))
+ (assert-equal "more text" (text-string a))
+ (assert-equal 20 (text-size a))
+ (assert-true (not (text-visible? a)))
+ (assert-equal 'name (text-attribute-mode a))
+ (assert-equal 21 (object-color a))
+
+ (set-text! a '(3 . 4) 'upper-right 180 "more text" 20 #f 'name 22)
+ (assert-equal 22 (object-color a))
+
+ (assert-thrown 'misc-error
+ (set-text! a '(3 . 4) 'fnord 180 "more text" 20 #f 'name))
+ (assert-thrown 'misc-error
+ (set-text! a '(3 . 4) 'upper-right 180 "more text" 20 #f 'fnord))
+ (assert-thrown 'misc-error
+ (set-text! a '(3 . 4) 'upper-right 1 "more text" 20 #f 'name))
+ ))
+
+(begin-test 'set-text-visibility!
+ (let ((a (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21))
+ (b (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21)))
+ (assert-true (text-visible? a))
+
+ (set-text-visibility! a #f)
+ (assert-true (not (text-visible? a)))
+
+ (set-text-visibility! a #t)
+ (assert-true (text-visible? a))
+ (assert-equal (text-info a) (text-info b))
+
+ (set-text-visibility! a 'bork)
+ (assert-true (text-visible? a))
+ (assert-equal (text-info a) (text-info b))))
+
+(begin-test 'set-text-string!
+ (let ((a (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21))
+ (b (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21)))
+ (assert-equal "test text" (text-string a))
+
+ (set-text-string! a "new test text")
+ (assert-equal "new test text" (text-string a))
+
+ (set-text-string! a "test text")
+ (assert-equal "test text" (text-string a))
+ (assert-equal (text-info a) (text-info b))))
diff --git a/libgeda/scheme/unit-tests/t0105-object-complex.scm b/libgeda/scheme/unit-tests/t0105-object-complex.scm
new file mode 100644
index 0000000..09cf92f
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0105-object-complex.scm
@@ -0,0 +1,180 @@
+;; Test Scheme procedures related to component objects.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+(use-modules (geda page))
+(use-modules (geda attrib))
+
+(begin-test 'component
+ (let ((a (make-component "test component" '(1 . 2) 0 #t #f)))
+
+ (assert-equal 'complex (object-type a))
+
+ (assert-true (component? a))
+
+ (assert-equal "test component" (component-basename a))
+ (assert-equal '(1 . 2) (component-position a))
+ (assert-equal 0 (component-angle a))
+ (assert-true (component-mirror? a))
+ (assert-true (not (component-locked? a)))
+
+ (assert-equal (list (component-basename a) (component-position a)
+ (component-angle a) (component-mirror? a)
+ (component-locked? a))
+ (component-info a))
+
+ (set-component! a '(3 . 4) 90 #f #t)
+
+ (assert-equal '(3 . 4) (component-position a))
+ (assert-equal 90 (component-angle a))
+ (assert-true (not (component-mirror? a)))
+ (assert-true (component-locked? a))
+
+ (assert-thrown 'misc-error
+ (set-component! a '(3 . 4) 45 #f #t))))
+
+(begin-test 'component-append
+ (let ((A (make-component "test component" '(1 . 2) 0 #t #f))
+ (B (make-component "test component" '(1 . 2) 0 #t #f))
+ (x (make-line '(0 . 0) '(2 . 0)))
+ (y (make-line '(0 . 0) '(0 . 2))))
+
+ (assert-equal '() (component-contents A))
+
+ (assert-equal A (component-append! A x))
+ (assert-equal (list x) (component-contents A))
+
+ (component-append! A x)
+ (assert-equal (list x) (component-contents A))
+
+ (component-append! A y)
+ (assert-equal (list x y) (component-contents A))
+
+ (assert-thrown 'object-state
+ (component-append! B x))))
+
+(begin-test 'component-remove
+ (let ((A (make-component "test component" '(1 . 2) 0 #t #f))
+ (B (make-component "test component" '(1 . 2) 0 #t #f))
+ (x (make-line '(0 . 0) '(2 . 0)))
+ (y (make-line '(0 . 0) '(0 . 2)))
+ (z (make-line '(1 . 0) '(2 . 2))))
+
+ (component-append! A x)
+ (assert-equal A (component-remove! A x))
+ (assert-equal '() (component-contents A))
+ (component-remove! A x)
+ (component-remove! B x)
+
+ (component-append! A x y)
+ (component-remove! A x y)
+ (assert-equal '() (component-contents A))
+
+ (component-append! A x y)
+ (component-remove! A x)
+ (assert-equal (list y) (component-contents A))
+
+ (assert-thrown 'object-state
+ (component-remove! B y))))
+
+(begin-test 'component-append/page
+ (let ((P (make-page "/test/page/A"))
+ (A (make-component "test component" '(1 . 2) 0 #t #f))
+ (x (make-line '(0 . 0) '(2 . 0)))
+ (y (make-line '(0 . 0) '(0 . 2))))
+ (dynamic-wind
+ (lambda () #t)
+ (lambda ()
+ (page-append! P x)
+ (assert-thrown 'object-state
+ (component-append! A x))
+
+ (page-append! P A)
+ (assert-thrown 'object-state
+ (component-append! A x))
+
+ (component-append! A y)
+ (assert-equal (list y) (component-contents A)))
+
+ (lambda ()
+ (close-page! P)))
+ ))
+
+(begin-test 'component-remove/page
+ (let ((P (make-page "/test/page/A"))
+ (A (make-component "test component" '(1 . 2) 0 #t #f))
+ (x (make-line '(0 . 0) '(2 . 0)))
+ (y (make-line '(0 . 0) '(0 . 2))))
+ (dynamic-wind
+ (lambda () #t)
+ (lambda ()
+ ;; Test that if a primitive object is attached directly to
+ ;; a page, attempting to remove it from a component
+ ;; doesn't work.
+ (page-append! P x)
+ (assert-thrown 'object-state
+ (component-remove! A x))
+
+ (page-append! P A)
+ (assert-thrown 'object-state
+ (component-remove! A x))
+
+ ;; Test that you can remove primitive objects from a
+ ;; component that is attached to a page.
+ (component-append! A y)
+ (component-remove! A y)
+ (assert-equal '() (component-contents A)))
+
+ (lambda ()
+ (close-page! P)))
+ ))
+
+(begin-test 'component-translate
+ (let* ((A (make-component "test component" '(0 . 0) 0 #t #f))
+ (x (make-box '(0 . 2) '(2 . 0))))
+
+ (component-append! A x)
+ (set-component! A '(1 . 1) 0 #t #f)
+ (assert-equal '(1 . 3) (box-top-left x))
+ (assert-equal '(3 . 1) (box-bottom-right x))))
+
+(begin-test 'component-remove-attrib
+ (let ((comp (make-component "test component" '(1 . 2) 0 #t #f))
+ (pin (make-net-pin '(0 . 0) '(100 . 0)))
+ (attrib (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both)))
+ (component-append! comp pin attrib)
+ (attach-attribs! pin attrib)
+ (assert-thrown 'object-state (component-remove! comp pin))
+ (assert-thrown 'object-state (component-remove! comp attrib))))
+
+
+;; Set up component library, making blatant assumptions about the
+;; directory layout.
+(component-library (string-join (list (getenv "srcdir") "../../symbols/analog") "/")
+ "Basic devices")
+
+(begin-test 'component/library
+ (let ((A (make-component/library "resistor-1.sym" '(1 . 2) 0 #t #f))
+ (B (make-component/library "invalid-component-name" '(1 . 2) 0 #t #f)))
+
+ (assert-true A)
+ (assert-equal '(1 . 2) (component-position A))
+ (assert-equal 0 (component-angle A))
+ (assert-true (component-mirror? A))
+ (assert-true (not (component-locked? A)))
+
+ (assert-equal "resistor-1.sym" (component-basename A))
+
+ (assert-true (not (null? (component-contents A))))
+
+ (assert-true (not B))))
+
+;; Clear component library again
+(reset-component-library)
+
+(begin-test 'object-component
+ (let* ((A (make-component "test component" '(0 . 0) 0 #t #f))
+ (x (make-box '(0 . 2) '(2 . 0))))
+ (assert-equal #f (object-component x))
+ (component-append! A x)
+ (assert-equal A (object-component x))))
diff --git a/libgeda/scheme/unit-tests/t0106-object-bounds.scm b/libgeda/scheme/unit-tests/t0106-object-bounds.scm
new file mode 100644
index 0000000..a896b8c
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0106-object-bounds.scm
@@ -0,0 +1,53 @@
+;; Test Scheme procedures for working with object bounds.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'bounds
+ (let ((x (make-box '(0 . 1) '(1 . 0)))
+ (y (make-box '(2 . 3) '(3 . 2)))
+ (t (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both))
+ (C (make-component "test component" '(0 . 0) 0 #t #f)))
+
+ ;; No arguments
+ (assert-equal #f (object-bounds))
+
+ ;; Single argument
+ (assert-equal '((0 . 1) . (1 . 0)) (object-bounds x))
+
+ ;; Multiple arguments
+ (assert-equal '((0 . 3) . (3 . 0)) (object-bounds x y))
+
+ ;; Unfortunately, libgeda has no text renderer, so text never has
+ ;; any bounds. What a shame.
+ (assert-true (not (object-bounds t)))
+
+ ;; Empty components should have no bounds...
+ (assert-equal '() (component-contents C))
+ (assert-true (not (object-bounds C)))
+
+ ;; ... but they should get bounds when you add stuff to them.
+ (component-append! C x)
+ (assert-equal '((0 . 1) . (1 . 0)) (object-bounds x))
+ ))
+
+(begin-test 'fold-bounds
+ (let ((x (make-box '(0 . 1) '(1 . 0)))
+ (y (make-box '(2 . 3) '(3 . 2))))
+
+ ;; No arguments
+ (assert-equal #f (fold-bounds #f))
+
+ ;; One argument
+ (let ((a (object-bounds x)))
+ (assert-equal a (fold-bounds a))
+ (assert-equal #f (fold-bounds #f)))
+
+ ;; > 1 argument
+ (let ((a (object-bounds x))
+ (b (object-bounds y)))
+ (assert-equal '((0 . 3) . (3 . 0))
+ (fold-bounds a b))
+ (assert-equal a (fold-bounds #f a))
+ (assert-equal a (fold-bounds a #f))
+ (assert-equal #f (fold-bounds #f #f)))))
diff --git a/libgeda/scheme/unit-tests/t0107-object-stroke-fill.scm b/libgeda/scheme/unit-tests/t0107-object-stroke-fill.scm
new file mode 100644
index 0000000..ecf74c3
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0107-object-stroke-fill.scm
@@ -0,0 +1,43 @@
+;; Test Scheme procedures for object stroke properties.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'stroke
+ (let ((a (make-line '(1 . 2) '(3 . 4))))
+
+ (assert-equal a (set-object-stroke! a 1 'none 'solid 'foo 'bar))
+ (assert-equal 1 (object-stroke-width a))
+ (assert-equal 'none (object-stroke-cap a))
+ (assert-equal '(solid) (object-stroke-dash a))
+
+ (set-object-stroke! a 1 'square 'dotted 2 'bar)
+ (assert-equal 'square (object-stroke-cap a))
+ (assert-equal '(dotted 2) (object-stroke-dash a))
+
+ (set-object-stroke! a 1 'round 'dashed 3 4)
+ (assert-equal 'round (object-stroke-cap a))
+ (assert-equal '(dashed 3 4) (object-stroke-dash a))
+
+ (set-object-stroke! a 1 'round 'center 5 6)
+ (assert-equal '(center 5 6) (object-stroke-dash a))
+
+ (set-object-stroke! a 1 'round 'phantom 7 8)
+ (assert-equal '(phantom 7 8) (object-stroke-dash a))
+ ))
+
+(begin-test 'fill
+ (let ((a (make-box '(1 . 2) '(3 . 4))))
+
+ (assert-equal a (set-object-fill! a 'hollow))
+ (assert-equal '(hollow) (object-fill a))
+
+ (assert-equal a (set-object-fill! a 'solid))
+ (assert-equal '(solid) (object-fill a))
+
+ (assert-equal a (set-object-fill! a 'hatch 1 2 3))
+ (assert-equal '(hatch 1 2 3) (object-fill a))
+
+ (assert-equal a (set-object-fill! a 'mesh 4 5 6 7 8))
+ (assert-equal '(mesh 4 5 6 7 8) (object-fill a))
+ ))
diff --git a/libgeda/scheme/unit-tests/t0108-object-connections.scm b/libgeda/scheme/unit-tests/t0108-object-connections.scm
new file mode 100644
index 0000000..3665f34
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0108-object-connections.scm
@@ -0,0 +1,67 @@
+; Test Scheme procedures for getting connections.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+(use-modules (geda page))
+
+(define P (make-page "/test/page/A"))
+
+(begin-test 'object-connections
+ (let ((C (make-component "test component" '(1 . 2) 0 #t #f))
+ (np (make-net-pin '(100 . 0) '(0 . 0)))
+ (bp (make-bus-pin '(100 . 200) '(0 . 200)))
+ (n1 (make-net '(100 . 0) '(100 . 100)))
+ (n2 (make-net '(100 . 100) '(200 . 100)))
+ (b1 (make-bus '(100 . 200) '(200 . 200)))
+ (b2 (make-bus '(200 . 100) '(200 . 200))))
+
+ (assert-thrown 'object-state (object-connections np))
+
+ ;; Build component
+ (component-append! C np bp)
+ (assert-thrown 'object-state (object-connections np))
+
+ ;; Build page
+ (page-append! P C n1 n2 b1 b2)
+
+ ;; Test initial connections
+ (assert-equal (list n1 b1) (object-connections C))
+
+ (assert-equal (list n1) (object-connections np))
+ (assert-equal (list np n2) (object-connections n1))
+ (assert-equal (list n1) (object-connections n2))
+
+ (assert-equal (list b1) (object-connections bp))
+ (assert-equal (list bp b2) (object-connections b1))
+ (assert-equal (list b1) (object-connections b2))
+
+ ;; Break some stuff
+ (page-remove! P n1)
+ (component-remove! C bp)
+
+ ;; Test modified connections
+ (assert-equal '() (object-connections np))
+ (assert-thrown 'object-state (object-connections n1))
+ (assert-equal '() (object-connections n2))
+
+ (assert-thrown 'object-state (object-connections bp))
+ (assert-equal (list b2) (object-connections b1))
+ (assert-equal (list b1) (object-connections b2))
+
+ ;; Change stuff back
+ (page-append! P n1)
+ (component-append! C bp)
+
+ ;; Test modified connections
+ (assert-equal (list n1 b1) (object-connections C))
+
+ (assert-equal (list n1) (object-connections np))
+ (assert-equal (list np n2) (object-connections n1))
+ (assert-equal (list n1) (object-connections n2))
+
+ (assert-equal (list b1) (object-connections bp))
+ (assert-equal (list b2 bp) (object-connections b1))
+ (assert-equal (list b1) (object-connections b2))
+ ))
+
+(close-page! P)
diff --git a/libgeda/scheme/unit-tests/t0109-object-copy.scm b/libgeda/scheme/unit-tests/t0109-object-copy.scm
new file mode 100644
index 0000000..c5a917f
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0109-object-copy.scm
@@ -0,0 +1,45 @@
+;; Test object copying
+
+(use-modules (unit-test))
+(use-modules (geda object))
+(use-modules (geda page))
+(use-modules (geda attrib))
+(use-modules (srfi srfi-1))
+
+;; This test verifies that if an object is copied, any links to
+;; containing pages, containing components are removed, and any
+;; attribute attachments are broken.
+(begin-test 'copy-object-breaks-links
+ (let ((P (make-page "/test/page/A"))
+ (A (make-component "test component" '(0 . 0) 0 #t #f))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (x (make-text '(1 . 2) 'lower-left 0 "name=x" 10 #t 'both)))
+
+ (page-append! P A x)
+
+ (assert-equal P (object-page x))
+ (assert-equal #f (object-page (copy-object x)))
+
+ (attach-attribs! A x)
+
+ (assert-equal A (attrib-attachment x))
+ (assert-equal #f (attrib-attachment (copy-object x)))
+
+ (detach-attribs! A x)
+ (page-remove! P x)
+ (component-append! A p x)
+
+ (assert-equal A (object-component x))
+ (assert-equal #f (object-component (copy-object x)))
+
+ (attach-attribs! p x)
+ (assert-equal p (attrib-attachment x))
+ (assert-equal #f (attrib-attachment (copy-object x)))))
+
+;; This test checks that copies of components are deep copies.
+(begin-test 'copy-object-deep-component
+ (let* ((A (make-component "test component" '(0 . 0) 0 #t #f))
+ (p (make-net-pin '(0 . 0) '(100 . 0))))
+ (component-append! A p)
+ (assert-equal (list p) (member p (component-contents A)))
+ (assert-equal #f (member p (component-contents (copy-object A))))))
diff --git a/libgeda/scheme/unit-tests/t0200-page.scm b/libgeda/scheme/unit-tests/t0200-page.scm
new file mode 100644
index 0000000..0837c92
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0200-page.scm
@@ -0,0 +1,81 @@
+;; Test Scheme procedures related to pages.
+
+(use-modules (unit-test))
+(use-modules (geda page))
+(use-modules (geda object))
+(use-modules (geda attrib))
+
+(begin-test 'page
+ (let ((page-a (make-page "/test/page/A"))
+ (page-b (make-page "/test/page/B")))
+ (assert-equal "/test/page/A" (page-filename page-a))
+ (assert-equal (list page-a page-b) (active-pages))
+
+ (assert-equal page-a (set-page-filename! page-a "/test/page/C"))
+ (assert-equal "/test/page/C" (page-filename page-a))
+
+ (close-page! page-a)
+ (assert-equal (list page-b) (active-pages))
+ (close-page! page-b)))
+
+(begin-test 'page-append
+ (let ((A (make-page "/test/page/C"))
+ (B (make-page "/test/page/D"))
+ (x (make-line '(0 . 0) '(1 . 2)))
+ (y (make-line '(0 . 1) '(2 . 2))))
+
+ (dynamic-wind ; Make sure pages are cleaned up
+ (lambda () #f)
+ (lambda ()
+ (assert-equal '() (page-contents A))
+
+ (assert-equal A (page-append! A x))
+ (assert-equal (list x) (page-contents A))
+
+ (assert-equal A (page-append! A x y))
+ (assert-equal (list x y) (page-contents A))
+
+ (assert-thrown 'object-state
+ (page-append! B x))
+
+ (assert-thrown 'object-state
+ (let* ((C (make-component "test component" '(1 . 2) 0 #t #f))
+ (z (make-line '(1 . 0) '(2 . 2))))
+ (component-append! C z)
+ (page-append! A z))))
+
+ (lambda ()
+ (close-page! A)
+ (close-page! B)))))
+
+(begin-test 'page-remove
+ (let ((A (make-page "/test/page/E"))
+ (B (make-page "/test/page/F"))
+ (C (make-component "test component" '(1 . 2) 0 #t #f))
+ (x (make-line '(0 . 0) '(2 . 0)))
+ (y (make-line '(0 . 0) '(0 . 2)))
+ (z (make-line '(1 . 0) '(2 . 2))))
+
+ (dynamic-wind ; Make sure pages are cleaned up
+ (lambda () #f)
+ (lambda ()
+ (page-append! A x)
+ (assert-equal A (page-remove! A x))
+ (assert-equal '() (page-contents A))
+ (assert-equal A (page-remove! A x))
+ (assert-equal B (page-remove! B x))
+
+ (page-append! A x y)
+ (assert-equal A (page-remove! A x))
+ (assert-equal (list y) (page-contents A))
+
+ (assert-thrown 'object-state
+ (page-remove! B y))
+
+ (component-append! C z)
+ (assert-thrown 'object-state
+ (page-remove! A z)))
+
+ (lambda ()
+ (close-page! A)
+ (close-page! B)))))
diff --git a/libgeda/scheme/unit-tests/t0201-page-dirty.scm b/libgeda/scheme/unit-tests/t0201-page-dirty.scm
new file mode 100644
index 0000000..b450ed8
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0201-page-dirty.scm
@@ -0,0 +1,118 @@
+;; Test Scheme procedures related to pages' changed flags.
+
+(use-modules (unit-test))
+(use-modules (geda page))
+(use-modules (geda object))
+(use-modules (geda attrib))
+(or (defined? 'define-syntax)
+ (use-modules (ice-9 syncase)))
+
+;; Utility macro to avoid boilerplate
+(define-syntax assert-dirties
+ (syntax-rules ()
+ ((_ P . test-forms)
+ (begin (begin . test-forms)
+ (assert-true (page-dirty? P))
+ (set-page-dirty! P #f)))))
+
+(begin-test 'page-dirty
+ (let ((P (make-page "/test/page/A"))
+ (C (make-component "test component" '(1 . 2) 0 #t #f)))
+
+ (dynamic-wind ; Make sure pages are cleaned up
+ (lambda () #f)
+ (lambda ()
+ (assert-true (not (page-dirty? P)))
+
+ (set-page-dirty! P)
+ (assert-true (page-dirty? P))
+
+ (set-page-dirty! P #f)
+ (assert-true (not (page-dirty? P)))
+
+ (assert-dirties P (set-page-dirty! P #t))
+ (assert-dirties P (page-append! P C))
+ (assert-dirties P (page-remove! P C)))
+ (lambda ()
+ (close-page! P)))))
+
+(begin-test 'page-dirty-objects
+ (let ((P (make-page "/test/page/A"))
+ (l (make-line '(1 . 2) '(3 . 4)))
+ (b (make-box '(1 . 4) '(3 . 2)))
+ (c (make-circle '(1 . 2) 3))
+ (a (make-arc '(1 . 2) 3 45 90))
+ (t (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both))
+ (C (make-component "test component" '(1 . 2) 0 #t #f)))
+
+ (dynamic-wind ; Make sure pages are cleaned up
+ (lambda () #f)
+ (lambda ()
+
+ ; Add everything to the page
+ (assert-dirties P (for-each (lambda (x) (page-append! P x))
+ (list l b c a t C)))
+
+ (assert-dirties P (apply set-line! l (line-info l)))
+ (assert-dirties P (apply set-box! b (box-info b)))
+ (assert-dirties P (apply set-circle! c (circle-info c)))
+ (assert-dirties P (apply set-arc! a (arc-info a)))
+ (assert-dirties P (apply set-text! t (text-info t)))
+ (assert-dirties P (apply set-component! C
+ (list-tail (component-info C) 1)))
+
+ ; Remove primitives from page
+ (assert-dirties P (for-each (lambda (x) (page-remove! P x))
+ (list l b c a t)))
+
+ ; Add primitives to component
+ (for-each (lambda (x) (assert-dirties P (component-append! C x)))
+ (list l b c a t))
+
+ ; Modify primitives within component
+ (assert-dirties P (apply set-line! l (line-info l)))
+ (assert-dirties P (apply set-box! b (box-info b)))
+ (assert-dirties P (apply set-circle! c (circle-info c)))
+ (assert-dirties P (apply set-arc! a (arc-info a)))
+ (assert-dirties P (apply set-text! t (text-info t)))
+
+ ; Remove primitives from component
+ (for-each (lambda (x) (assert-dirties P (component-remove! C x)))
+ (list l b c a t)))
+
+ (lambda ()
+ (for-each (lambda (x) (page-remove! P x)) (page-contents P))
+ (close-page! P)))
+
+ ))
+
+(begin-test 'page-dirty-attribs
+ (let ((P (make-page "/test/page/A"))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (t (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
+ (C (make-component "test component" '(1 . 2) 0 #t #f)))
+
+ (dynamic-wind ; Make sure pages are cleaned up
+ (lambda () #f)
+ (lambda ()
+ ; Populate page
+ (page-append! P t C) (component-append! C p)
+
+ ; Attach attribute to component
+ (assert-dirties P (attach-attribs! C t))
+ ; Detach attribute from component
+ (assert-dirties P (detach-attribs! C t))
+
+ ; Move attribute into component
+ (page-remove! P t)
+ (component-append! C t)
+
+ ; Attach attribute to pin
+ (assert-dirties P (attach-attribs! p t))
+ ; Detach attribute from pin
+ (assert-dirties P (detach-attribs! p t))
+ )
+ (lambda ()
+ (close-page! P)))
+
+ ))
diff --git a/libgeda/scheme/unit-tests/t0300-attribute.scm b/libgeda/scheme/unit-tests/t0300-attribute.scm
new file mode 100644
index 0000000..d63cc07
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0300-attribute.scm
@@ -0,0 +1,187 @@
+;; Test Scheme procedures related to attributes.
+
+(use-modules (unit-test))
+(use-modules (geda attrib))
+(use-modules (geda page))
+(use-modules (geda object))
+
+(begin-test 'parse-attrib
+ (let ((good (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
+ (bad (make-text '(1 . 2) 'lower-left 0 "name value" 10 #t 'both)))
+
+ (assert-equal #t (attribute? good))
+ (assert-equal #f (attribute? bad))
+
+ (assert-equal "name" (attrib-name good))
+ (assert-equal "value" (attrib-value good))
+ (assert-equal (cons (attrib-name good) (attrib-value good))
+ (parse-attrib good))
+
+ (assert-thrown 'attribute-format (parse-attrib bad))
+ (assert-thrown 'attribute-format (attrib-name bad))
+ (assert-thrown 'attribute-format (attrib-value bad)) ))
+
+(begin-test 'attach-attrib
+ (let ((C (make-component "testcomponent1" '(0 . 0) 0 #f #f))
+ (D (make-component "testcomponent2" '(0 . 0) 0 #f #f))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (q (make-net-pin '(0 . 0) '(100 . 0)))
+ (x (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both))
+ (y (make-text '(0 . 0) 'lower-left 0 "name=y" 10 #t 'both))
+ (z (make-text '(0 . 0) 'lower-left 0 "name=z" 10 #t 'both)))
+
+ ;; Attach attribute outside component or page
+ (assert-thrown 'object-state (attach-attribs! C x))
+ (assert-equal '() (object-attribs C))
+ (assert-true (not (attrib-attachment x)))
+
+ ;; Populate components
+ (component-append! C p q x y)
+ (component-append! D z)
+
+ ;; Attach attribute to object in same component
+ (assert-equal p (attach-attribs! p x))
+ (assert-equal (list x) (object-attribs p))
+ (assert-equal p (attrib-attachment x))
+
+ ;; Attach attribute twice
+ (assert-equal p (attach-attribs! p x))
+ (assert-equal (list x) (object-attribs p))
+ (assert-equal p (attrib-attachment x))
+
+ ;; Attach attribute which is already attached, within same
+ ;; component
+ (assert-thrown 'object-state (attach-attribs! q x))
+
+ ;; Attach attribute to object in different component
+ (assert-thrown 'object-state (attach-attribs! p z))
+ (assert-equal (list x) (object-attribs p))
+ (assert-true (not (attrib-attachment z)))
+
+ ;; Attach internal attribute to containing component
+ (assert-thrown 'object-state (attach-attribs! D z))
+ (assert-equal '() (object-attribs D))
+ (assert-true (not (attrib-attachment z)))
+
+ ;; Attach attribute in component to floating object
+ (assert-thrown 'object-state (attach-attribs! C z))
+ (assert-equal '() (object-attribs C))
+ (assert-true (not (attrib-attachment z)))
+
+ ;; Attach floating attribute to object in component
+ (component-remove! D z)
+ (assert-thrown 'object-state (attach-attribs! p z))
+ (assert-equal (list x) (object-attribs p))
+ (assert-true (not (attrib-attachment z)))
+
+ ;; Attach multiple attributes
+ (assert-equal p (attach-attribs! p y))
+ (assert-equal (list x y) (object-attribs p))
+ (assert-equal p (attrib-attachment y))
+ ))
+
+(begin-test 'attach-attrib/page
+ (let ((P (make-page "/test/page/A"))
+ (Q (make-page "/test/page/A"))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (x (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
+ (y (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
+ (z (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
+ (C (make-component "test component" '(1 . 2) 0 #t #f)))
+
+ (dynamic-wind ; Make sure pages are cleaned up
+ (lambda () #f)
+ (lambda ()
+ ; Populate pages
+ (page-append! P x C)
+ (component-append! C p y)
+
+ (page-append! Q z)
+
+ ; Attach attribute to component in same page
+ (attach-attribs! C x)
+ (assert-equal (list x) (object-attribs C))
+ (assert-equal C (attrib-attachment x))
+
+ ; Remove stuff from page
+ (assert-thrown 'object-state (page-remove! P x))
+ (assert-thrown 'object-state (page-remove! P C))
+
+ ; Attach attribute to component in different page
+ (assert-thrown 'object-state (attach-attribs! C z))
+
+ ; Attach attribute to pin in component in page
+ (attach-attribs! p y)
+ (assert-equal (list y) (object-attribs p))
+ (assert-equal p (attrib-attachment y))
+
+ ; Remove stuff from component in page
+ (assert-thrown 'object-state (component-remove! C p))
+ (assert-thrown 'object-state (component-remove! C y)) )
+ (lambda ()
+ (close-page! P)
+ (close-page! Q) ))
+
+ ))
+
+(begin-test 'detach-attrib
+ (let ((page (make-page "/test/page/1"))
+ (pin1 (make-net-pin '(0 . 0) '(100 . 0)))
+ (pin2 (make-net-pin '(0 . 100) '(100 . 100)))
+ (x (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both)))
+
+ (page-append! page pin1 pin2 x)
+
+ ;; Detach when already detached
+ (assert-equal pin1 (detach-attribs! pin1 x))
+
+ (attach-attribs! pin1 x)
+
+ (assert-thrown 'object-state
+ (detach-attribs! pin2 x))
+
+ (assert-equal pin1 (detach-attribs! pin1 x))
+ (assert-equal '() (object-attribs pin1)) ))
+
+(begin-test 'inherited-attribs
+ (let ((C (make-component "test component" '(1 . 2) 0 #t #f))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (x (make-text '(1 . 2) 'lower-left 0 "name=x" 10 #t 'both))
+ (y (make-text '(1 . 2) 'lower-left 0 "name=y" 10 #t 'both)))
+
+ (assert-equal '() (inherited-attribs p))
+ (assert-equal '() (inherited-attribs C))
+
+ ;; Set up component
+ (component-append! C p x y)
+
+ (assert-equal (list x y) (inherited-attribs C))
+
+ (attach-attribs! p x)
+
+ (assert-equal (list y) (inherited-attribs C))))
+
+(begin-test 'attrib-inherited?
+ (let* ((P (make-page "/test/page/1"))
+ (A (make-component "test component" '(0 . 0) 0 #t #f))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (w (make-text '(1 . 2) 'lower-left 0 "name=x" 10 #t 'both))
+ (x (make-text '(1 . 2) 'lower-left 0 "name=x" 10 #t 'both))
+ (y (make-text '(1 . 2) 'lower-left 0 "name=y" 10 #t 'both))
+ (z (make-text '(1 . 2) 'lower-left 0 "name=z" 10 #t 'both)))
+
+ (page-append! P A w x)
+ (attach-attribs! A x)
+ (component-append! A p y z)
+ (attach-attribs! p y)
+
+ (assert-true (not (attrib-inherited? w)))
+ (assert-true (not (attrib-inherited? x)))
+ (assert-true (not (attrib-inherited? y)))
+ (assert-true (attrib-inherited? z))))
+
+(begin-test 'set-attrib-value!
+ (let ((a (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both)))
+ (set-attrib-value! a "foo")
+ (assert-equal "name" (attrib-name a))
+ (assert-equal "foo" (attrib-value a))))
diff --git a/libgeda/scheme/unit-tests/t0301-promotable-attributes.scm b/libgeda/scheme/unit-tests/t0301-promotable-attributes.scm
new file mode 100644
index 0000000..ba6d668
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0301-promotable-attributes.scm
@@ -0,0 +1,30 @@
+;; Test promotable-attributes function
+
+(use-modules (unit-test))
+(use-modules (geda page))
+(use-modules (geda object))
+(use-modules (geda attrib))
+
+;; Unfortunately, we can't test this at the moment, because the
+;; default list of promotable attribute names is empty. We suppress
+;; config file loading when running the unit tests, and even though we
+;; could call the (always-promote-attributes ...) config file
+;; procedure, but it wouldn't do us any good because we can't call
+;; i_vars_libgeda_set() from Scheme [1]. So instead, we just fail.
+;;
+;; [1] This is a good thing -- it shouldn't be necessary!
+(begin-test 'promotable-attributes
+ (throw 'missing-unit-test "We can't test this at the moment"))
+
+(begin-test 'promote-attribs!
+ (throw 'missing-unit-test "We can't test this at the moment"))
+
+(begin-test 'promote-attribs!/not-in-page
+ (let ((p (make-net-pin '(0 . 0) '(100 . 0))))
+ (assert-thrown 'object-state (promote-attribs! p))))
+
+(begin-test 'promote-attribs!/non-component
+ (let ((P (make-page "/test/page/A"))
+ (p (make-net-pin '(0 . 0) '(100 . 0))))
+ (page-append! P p)
+ (assert-equal '() (promote-attribs! p))))
commit 9ac7ddffcdd09ae0bbf9c62af0457ff957510081
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Minor documentation fix-ups.
Corrected encoding, made CC licence URL a proper link, and corrected
case.
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 34dac8e..1eae5e0 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -1,6 +1,7 @@
\input texinfo @c -*-texinfo-*-
@setfilename geda-scheme.info
@include version.texi
+@documentencoding utf-8
@settitle gEDA Scheme Reference Manual @value{VERSION}
@copying
@@ -11,11 +12,11 @@ Copyright @copyright{} 2011 Peter TB Brett
The text of and illustrations in this document are licensed under a
Creative Commons Attributionâ??Share Alike 3.0 Unported license
("CC-BY-SA"). An explanation of CC-BY-SA is available at
-http://creativecommons.org/licenses/by-sa/3.0/. The original authors
-of this document designate the gEDA Project as the "Attribution Party"
-for purposes of CC-BY-SA. In accordance with CC-BY-SA, if you
-distribute this document or an adaptation of it, you must provide the
-URL for the original version.
+@uref{http://creativecommons.org/licenses/by-sa/3.0/}. The original
+authors of this document designate the gEDA Project as the
+"Attribution Party" for purposes of CC-BY-SA. In accordance with
+CC-BY-SA, if you distribute this document or an adaptation of it, you
+must provide the URL for the original version.
@end copying
@titlepage
@@ -274,7 +275,7 @@ must not begin with a space (@samp{ }, Unicode @code{U+0020}).
@end itemize
@strong{Note}: Due to assumptions made by some gEDA tools, it is
-@emph{strongly recommended} that you use attribute @var{NAME}s which
+@emph{strongly recommended} that you use attribute @var{name}s which
contain only lower-case Latin characters, decimal digits, full stops
@samp{.} (@code{U+002E}), and hyphens @samp{-} (@code{U+002D}).
@@ -285,7 +286,7 @@ There are two types of attribute:
linked to another @code{object}. To attach an attribute to another
schematic element, both @code{object}s must be part of the same
component or part of the same @code{object}. For example, a
-@samp{netname=@var{NAME}} attribute attached to a net @code{object}
+@samp{netname=@var{name}} attribute attached to a net @code{object}
can be used to give that net a specific name in netlist output, such
as @samp{VCC} or @samp{GND}.
commit 2fa4f5712cf6decb4bf3b90002634ba607b1aec4
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: gschem API documentation (misc).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 10a021b..34dac8e 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -1548,6 +1548,36 @@ Called when a new page is created. The argument is the new page.
@node Miscellanous gschem functions
@section Miscellaneous gschem functions
+@subsection gschem Attribute Helpers
+
+To use the functions described in this section, you will need to load
+the @code{(gschem attrib)} module.
+
+@defun add-attrib! target name value visible show
+Create a new attribute, either attached to a @var{target}
+@code{object} in the current @code{page}, or floating in the current
+@code{page} if @var{target} is @samp{#f}. The @var{name} and
+@var{value} for the attribute must be strings, and if visible is
+@samp{#f}, the attribute will be invisible. The @var{show} argument
+controls which parts of the attribute will be visible, and must be one
+of the following symbols:
+
+@itemize
+@item
+@samp{name}
+@item
+@samp{value}
+@item
+@samp{both}
+@end itemize
+
+This function exists to provide a way for actions defined in Scheme to
+use the same attribute placement heuristics as gschem's built-in
+@strong{Add Attribute} action.
+
+@xref{Text}, @ref{Attributes} and @ref{Windows and views}.
+@end defun
+
@node Concept Index
@unnumbered Concept Index
commit 4f6d3a0fd5810d8fabd93a1629495f5c916ae4d3
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: gschem API documentation (hooks).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index f1e323a..10a021b 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -45,6 +45,7 @@ URL for the original version.
* Concept Index::
* Function Index::
+* Variable Index::
@end menu
@node Introduction
@@ -1455,6 +1456,8 @@ Adds @var{object} to the selection of its containing @code{page}. If
@var{object} is not directly included in a @code{page}, raises an
@samp{object-state} error. If @var{object} is already selected, does
nothing. Returns @var{object}.
+
+@strong{Note}: This function does not call @code{select-objects-hook}.
@end defun
@defun deselect-object! object
@@ -1462,11 +1465,86 @@ Removes @var{object} from the selection of its containing @code{page}.
If @var{object} is not directly included in a @code{page}, raises an
@samp{object-state} error. If @var{object} is not selected, does
nothing. Returns @var{object}.
+
+@strong{Note}: This function does not call
+@code{deselect-objects-hook}.
@end defun
@node Hooks
@section Hooks
+To use the hooks described in this section, you will need to load the
+@code{(gschem hook)} module.
+
+gschem defines a number of hooks that allow functions to be
+automatically run whenever a number of built-in actions are invoked by
+the user.
+
+Most Scheme functions do not call these hooks. If it makes sense for
+your code to invoke a standard hook, you should normally do so
+explicitly.
+
+@strong{Warning}: Functions added to these standard hooks should not
+normally modify their arguments.
+
+For more information on hooks in Guile, @pxref{Hooks, , Hooks, guile,
+Guile Reference Manual}.
+
+@defvar add-object-hook
+Called after objects are added to the page, at their initial creation.
+The argument is a list of the objects being added.
+@end defvar
+
+@defvar remove-objects-hook
+Called after objects are removed from the page. Argument is a list of
+the objects being removed.
+@end defvar
+
+@defvar move-objects-hook
+Called after objects are moved. Argument is a list of the objects
+that were mirrored.
+@end defvar
+
+@defvar mirror-objects-hook
+Called after objects are mirrored. Argument is a list of the objects
+that were mirrored.
+@end defvar
+
+@defvar rotate-objects-hook
+Called after objects are rotated. Argument is a list of the objects
+that were rotated.
+@end defvar
+
+@defvar paste-objects-hook
+Called after objects are pasted to the page, either via @strong{Edit â??
+Copy Mode} or similar, or via buffers, or via the clipboard. Argument
+is a list of the objects that were pasted.
+@end defvar
+
+@defvar attach-attribs-hook
+Called after attributes are attached to something. The argument is a
+list of the attributes that were attached.
+@end defvar
+
+@defvar detach-attribs-hook
+Called after attributes are detached from something. The argument is
+a list of the attributes that were detached.
+@end defvar
+
+@defvar select-objects-hook
+Called after objects are added to the selection. The argument is a
+list of objects that were selected.
+@end defvar
+
+@defvar deselect-objects-hook
+Called after objects are removed from the selection. The argument is
+a list of objects that were deselected.
+@end defvar
+
+@defvar new-page-hook
+Called when a new page is created. The argument is the new page.
+@end defvar
+
@node Miscellanous gschem functions
@section Miscellaneous gschem functions
@@ -1480,4 +1558,9 @@ nothing. Returns @var{object}.
@printindex fn
+@node Variable Index
+@unnumbered Variable Index
+
+@printindex vr
+
@bye
diff --git a/gschem/scheme/gschem/hook.scm b/gschem/scheme/gschem/hook.scm
index 0640b7e..3251895 100644
--- a/gschem/scheme/gschem/hook.scm
+++ b/gschem/scheme/gschem/hook.scm
@@ -22,72 +22,24 @@
;; Import C definitions
#:use-module (gschem core hook))
-;; This module defines a number of hooks that can be used to run
-;; arbitrary Scheme code following a variety of user actions. Note
-;; that hook functions should not normally modify their arguments.
-
-;; add-objects-hook
-;;
-;; Called after objects are added to the page, at their initial
-;; creation. Argument is a list of the objects being added.
(define-public add-objects-hook %add-objects-hook)
-;; remove-objects-hook
-;;
-;; Called after objects are removed from the page. Argument is a list
-;; of the objects being removed.
(define-public remove-objects-hook %remove-objects-hook)
-;; move-objects-hook
-;;
-;; Called after objects are moved. Argument is a list of the objects
-;; that were mirrored.
(define-public move-objects-hook %move-objects-hook)
-;; mirror-objects-hook
-;;
-;; Called after objects are mirrored. Argument is a list of the
-;; objects that were mirrored.
(define-public mirror-objects-hook %mirror-objects-hook)
-;; rotate-objects-hook
-;;
-;; Called after objects are rotated. Argument is a list of the
-;; objects that were rotated.
(define-public rotate-objects-hook %rotate-objects-hook)
-;; paste-objects-hook
-;;
-;; Called after objects are pasted to the page, either via "Edit->Copy
-;; Mode" or similar, or via buffers, or via the clipboard. Argument
-;; is a list of the objects that were pasted.
(define-public paste-objects-hook %paste-objects-hook)
-;; attach-attribs-hook
-;;
-;; Called after attributes are attached to something. The argument is
-;; a list of the attributes that were attached.
(define-public attach-attribs-hook %attach-attribs-hook)
-;; detach-attribs-hook
-;;
-;; Called after attributes are detached from something. The argument
-;; is a list of the attributes that were detached.
(define-public detach-attribs-hook %detach-attribs-hook)
-;; select-objects-hook
-;;
-;; Called after objects are added to the selection. The argument is a
-;; list of objects that were selected.
(define-public select-objects-hook %select-objects-hook)
-;; deselect-objects-hook
-;;
-;; Called after objects are removed from the selection. The argument
-;; is a list of objects that were deselected.
(define-public deselect-objects-hook %deselect-objects-hook)
-;; new-page-hook
-;;
-;; Called when a new page is created. The argument is the new page.
(define-public new-page-hook %new-page-hook)
commit e53af99b5b907819da60a2f6d7666038d351ddd6
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: gschem API documentation (selections).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index d0b8d13..f1e323a 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -1429,6 +1429,41 @@ returns @samp{#f}.
@node Selections
@section Selections
+To use the functions described in this section, you will need to load
+the @code{(gschem selection)} module.
+
+Each @code{page} in gschem has a @dfn{selection} associated with it,
+which is some subset of the @code{page}s contents. Most actions in
+gschem operate on the currently selected objects.
+
+@defun page-selection page
+Returns the current selection for @var{page}, as a list of
+@code{object}s.
+@end defun
+
+@defun object-selected? object
+Returns @samp{#t} if @var{object} is in its containing page's
+selection. Otherwise, returns @samp{#f}. If @var{object} is not in a
+@code{page}, raises an @samp{object-state} error.
+
+@strong{Note}: @var{object} must be @emph{directly} included in a
+@code{page}, not via inclusion in a component @code{object}.
+@end defun
+
+@defun select-object! object
+Adds @var{object} to the selection of its containing @code{page}. If
+@var{object} is not directly included in a @code{page}, raises an
+@samp{object-state} error. If @var{object} is already selected, does
+nothing. Returns @var{object}.
+@end defun
+
+@defun deselect-object! object
+Removes @var{object} from the selection of its containing @code{page}.
+If @var{object} is not directly included in a @code{page}, raises an
+@samp{object-state} error. If @var{object} is not selected, does
+nothing. Returns @var{object}.
+@end defun
+
@node Hooks
@section Hooks
commit 01e10f7f71a380e2c6aa192d4da6bf8204cbfe2f
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: gschem API documentation (windows and views).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 49165eb..d0b8d13 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -1409,6 +1409,23 @@ focused on enabling and responding to user editing operations.
@node Windows and views
@section Windows and views
+To use the functions described in this section, you will need to load
+the @code{(gschem window)} module.
+
+@defun active-page
+Returns the @code{page} currently being displayed for editing.
+@end defun
+
+@defun set-active-page! page
+Sets the current @code{page} to @var{page}.
+@end defun
+
+@defun pointer-position
+Returns the current mouse pointer position in world coordinates in the
+form @samp{(x . y)}. If the pointer is outside the display area,
+returns @samp{#f}.
+@end defun
+
@node Selections
@section Selections
commit 7c88e88e38bcd20f6ad3e46604f2b117b6fef0a6
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (attributes).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 3e22737..49165eb 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -1284,6 +1284,114 @@ are attached as an attribute.
@node Core attribute functions
@section Core attribute functions
+To use the functions described in this section, you will need to load
+the @code{(geda attrib)} module.
+
+Attributes are text @code{object}s with a particular format of string.
+They can be floating, or they can be attached to another
+@code{object}.
+
+@defun attribute? object
+Returns true if and only if @var{object} is an attribute (i.e. a text
+@code{object} and in attribute format).
+@end defun
+
+@subsection Attribute names and values
+
+@defun parse-attrib text
+Splits the string from @var{text} (a text @code{object}) into name and
+value, if it is in attribute format. If it is not in attribute
+format, raises an @samp{attribute-format} error. The return value is
+in the form @samp{(@var{name} . @var{value})}.
+@end defun
+
+@defun attrib-name attrib
+Returns the name part of @var{attrib}, as a string.
+@end defun
+
+@defun attrib-value attrib
+Returns the value part of @var{attrib}, as a string.
+@end defun
+
+@defun set-attrib-value! attrib value
+Sets the value part of @var{attrib} to @var{value}.
+@end defun
+
+@subsection Attribute attachment
+
+@defun attrib-attachment attrib
+If @var{attrib} is attached to another @code{object}, returns that
+object. Otherwise, returns @samp{#f}.
+@end defun
+
+@defun object-attribs object
+Returns a list of all attributes attached to @var{object}.
+@end defun
+
+@defun attach-attribs! object [attribs...]
+Attach @var{attribs} to @var{object}. All the @var{attribs} must be
+text @code{object}s. The following conditions must be satisfied, or
+an @samp{object-state} error will be raised:
+
+@itemize
+@item
+Neither @var{object} nor any of the @var{attribs} may be already
+attached as an attribute;
+@item
+Both @var{object} and all @var{attribs} must be part of the same
+@code{page} and/or component @code{object};
+@end itemize
+
+Any @var{attribs} that are already attached to @var{object} are
+ignored. Returns @var{object}.
+
+@strong{Note}: For historical reasons, @code{attach-attribs!} does not
+require that all @var{attribs} satisfy @code{attribute?}.
+Nevertheless, avoid attaching non-attribute text objects as attributes.
+@end defun
+
+@defun detach-attribs! object [attribs...]
+Detach @var{attribs} from @var{object}. Any @var{attribs} that are
+not attached as attributes are ignored. If any @var{attribs} are
+attached to @code{object}s other than @var{object}, an
+@samp{object-state} error is raised.
+@end defun
+
+@subsection Inherited and promoted attributes
+
+@dfn{Inherited attributes} are unattached attributes inside a
+component @code{object}.
+
+@defun inherited-attribs object
+Returns the inherited attributes of @var{object}, if @var{object} is a
+component. If @var{object} is not a component, returns the empty
+list.
+@end defun
+
+@defun attrib-inherited? attrib
+Returns @samp{#t} if @var{attrib} is an inherited attribute.
+@end defun
+
+@dfn{promotable attributes} are inherited attributes that are both
+visible and have names that are in the list of promotable attributes
+set with the @code{always-promote-attributes} rc file parameter.
+
+@defun promotable-attribs component
+Returns a list of promotable attributes of @var{component}.
+@end defun
+
+@defun promote-attribs! component
+Promote all promotable attributes from @var{component} into the
+@code{page} that contains @var{component}. If @var{component} is not
+in a page, an @samp{object-state} error is raised.
+
+All promotable attributes are copied, and made invisible. The copies
+are added to the @code{page}, and attached as attributes of @var{component}.
+
+The promoted attributes are returned. If @var{component} is not in
+fact a component @code{object}, does nothing and returns the empty list.
+@end defun
+
@node gschem API Reference
@chapter gschem API Reference
diff --git a/libgeda/scheme/geda/attrib.scm b/libgeda/scheme/geda/attrib.scm
index 09eeb7b..11ae368 100644
--- a/libgeda/scheme/geda/attrib.scm
+++ b/libgeda/scheme/geda/attrib.scm
@@ -30,57 +30,27 @@
(define-public attrib-attachment %attrib-attachment)
(define-public promotable-attribs %promotable-attribs)
-;; attribute? a
-;;
-;; Returns #t if a is an text object in attribute format.
(define-public (attribute? a)
(false-if-exception (and (parse-attrib a) #t)))
-;; attrib-name a
-;;
-;; Returns the attribute name of a, or raises an attribute-format
-;; error if a is not in attribute format.
(define-public (attrib-name a)
(let ((v (parse-attrib a)))
(if v (car v) v)))
-;; attrib-value a
-;;
-;; Returns the attribute value of a, or raises an attribute-format
-;; error if a is not in attribute format.
(define-public (attrib-value a)
(let ((v (parse-attrib a)))
(if v (cdr v) v)))
-;; set-attrib-value! a val
-;;
-;; Updates the attribute a with the new value val.
(define-public (set-attrib-value! a val)
(let ((name (attrib-name a)))
(set-text-string! a (string-join (list name val) "="))))
-;; inherited-attribs object
-;;
-;; Returns the inherited attributes of object, if object is a
-;; component. The inherited attributes are the unattached top-level
-;; attributes in the component. If object is not a component, returns
-;; the empty list.
(define-public (inherited-attribs object)
(if (component? object)
(filter! (lambda (x) (and (attribute? x) (not (attrib-attachment x))))
(component-contents object))
'()))
-;; promote-attribs! object
-;;
-;; Promotes any promotable attributes from an object into its current
-;; page, if object is a component, keeping the original attributes as
-;; invisible attributes inside the component. Returns a list of the
-;; objects that were added to the page. If object is not a component,
-;; returns the empty list. If object is not in a page, throws an
-;; object-state error.
-;;
-;; See also promotable-attribs.
(define-public (promote-attribs! object)
(let ((p (or (object-page object)
(scm-error 'object-state #f
@@ -99,10 +69,6 @@
(promotable-attribs object))
'())))
-;; attrib-inherited? attrib
-;;
-;; Returns #t if attrib is a toplevel un-attached attribute inside a
-;; component.
(define-public (attrib-inherited? attrib)
(not (or (attrib-attachment attrib)
(not (object-component attrib)))))
commit dd5b9c7c08307104ce360661f6e696ce87c77389
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (component objects).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 38cb0d7..3e22737 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -1146,6 +1146,141 @@ will be one of the following symbols:
@node Components
@subsection Components
+Component @code{object}s represent instances of symbols. They contain
+other @code{object}s copied from the original symbol when it is
+instantiated into a schematic.
+
+A component's @var{basename} is a string used to identify which symbol
+it originated from. When instantiating a symbol on initial placement
+in a schematic, or when recreating a component while loading a
+schematic, the @var{basename} is used to find the underlying symbol
+file in the component library.
+
+@xref{Component objects}.
+
+@strong{Note}: In the gEDA C source code, these are normally called
+``complex'' objects. However, as Guile Scheme supports complex
+numbers, and the procedures related to working with complex numbers
+use the word @samp{complex} to describe them, this API uses
+@samp{component} to avoid ambiguity.
+
+The @var{position}, @var{angle} and @var{mirror} flag of a component
+indicates the transformation that was applied to the contents of the
+original symbol. The transformation is applied in the following order:
+
+@enumerate
+@item
+If @var{mirror} is true, the symbol is reflected in the line x = 0.
+@item
+The symbol is rotated anti-clockwise by @var{angle} degrees about the
+point (0,0) (@var{angle} may only be an integer multiple of 90
+degrees).
+@item
+Finally, the symbol is translated by @var{position}.
+@end enumerate
+
+The component's contents (as returned by @code{component-contents})
+have the transformation already applied to them. Updating the
+translation information using e.g. @code{set-component!} will not
+alter them -- that must be done separately (e.g. by reloading the
+symbol).
+
+@defun component? object
+Returns @samp{#t} if and only if @var{object} is a component @code{object}.
+@end defun
+
+@defun make-component basename position angle mirror locked
+Creates and returns a new, empty component @code{object} with the
+given @var{basename}. @var{position}, @var{angle} and @var{mirror}
+specify the symbol transformation. If @var{locked} is true, the
+component will be protected against accidental selection by the user
+(this is used in gschem e.g. for titleblocks).
+
+No attempt is made to load a symbol matching @var{basename} from
+component libraries, and the returned component is flagged as
+embedded.
+@end defun
+
+@defun make-component/library basename position angle mirror locked
+Searches the component libraries for a symbol matching @var{basename},
+and if found, instantiates the symbol and returns the resulting
+component (which is not flagged as embedded). Arguments are as for
+@code{make-component}.
+
+If no match for @var{basename} is found, @samp{#f} is returned.
+@end defun
+
+@defun set-component! component position angle mirror locked
+Sets the parameters of @var{component}. Arguments are the same as to
+@code{make-component}. Returns @var{component}.
+
+@strong{Note}: Remember that modifying the transformation parameters
+of a component does not update the component's contents.
+@end defun
+
+@defun component-info component
+Returns the parameters of @var{component} as a list of the form:
+
+@example
+(basename (x . y) angle mirror locked)
+@end example
+@end defun
+
+@defun component-basename component
+Returns the basename of @var{component}.
+@end defun
+
+@defun component-position component
+Returns the position to which the original symbol was translated when
+creating @var{component}.
+@end defun
+
+@defun component-angle component
+Returns the angle by which the original symbol was rotated when
+creating @var{component}, as an integer number of degrees.
+@end defun
+
+@defun component-mirror? component
+Returns true if the original symbol was mirrored when creating
+@var{component}.
+@end defun
+
+@defun component-locked? component
+Returns true if @var{component} is non-selectable.
+@end defun
+
+@defun component-contents component
+Returns the contents of @var{components} as a list of objects.
+@end defun
+
+@defun component-append! component objects...
+Appends @var{objects} (which must not be component @code{object}s) to
+the contents of @var{component}. Any @var{objects} which are already
+included in @var{component} are ignored. If any @var{objects} are
+already part of a @code{page} or of another component @code{object},
+an @samp{object-state} error is raised. Returns @var{component}.
+@end defun
+
+@defun component-remove! component objects...
+Removes @var{objects} from the contents of @var{component}. Any
+@var{objects} which are not part of a component or of a page are
+ignored. Returns @var{component}.
+
+An @samp{object-state} error will be raised if any @var{objects}
+satisfy any of the following conditions:
+
+@itemize
+@item
+are part of a @code{page};
+@item
+are part of a component @code{object} other than @var{component};
+@item
+have attached attributes
+@item
+are attached as an attribute.
+@end itemize
+@end defun
+
@node Core attribute functions
@section Core attribute functions
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 3d0b414..e3bceb8 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -276,56 +276,21 @@
(list-ref (text-info t) 6))
;;;; Component objects
-;;
-;; In the gEDA source code, these are normally called "complex"
-;; objects. However, as Guile supports complex numbers, and the
-;; procedures related to working with complex numbers use the word
-;; "complex" to describe them, this API uses "component" in order to
-;; remove the ambiguity.
-;; component? c
-;;
-;; Returns #t if c is a gEDA component object.
(define-public (component? c)
(object-type? c 'complex))
-;; set-component! c position angle mirror locked
-;;
-;; Sets the parameters of a component object c. position is the point
-;; (x . y) at which the component object is located. angle is the
-;; rotation angle of the component object in degrees, and must be 0, 90,
-;; 180, or 270. If mirror is true, the component object will be
-;; flipped, and if locked is true, it will be non-selectable in an
-;; editor.
(define-public (set-component! c position angle mirror locked)
(%set-complex! c (car position) (cdr position) angle mirror locked))
-;; make-component basename position angle mirror locked
-;;
-;; Make a new, empty embedded component object with the given basename
-;; and parameters. See set-component! for full description of
-;; arguments.
(define-public (make-component basename . args)
(let ((c (%make-complex basename)))
(apply set-component! c args)))
-;; make-component/library basename position angle mirror locked
-;;
-;; Make a new component object by searching the component library for
-;; the given basename, and instatiate it with the given parameters.
-;; See set-component! for full description of arguments. Returns #f
-;; if basename was not found in the component library. The component
-;; is not initially embedded.
(define-public (make-component/library basename . args)
(let ((c (%make-complex/library basename)))
(if c (apply set-component! c args) #f)))
-;; component-info c
-;;
-;; Returns the parameters of the component object c as a list of the
-;; form:
-;;
-;; (basename (x . y) angle mirror locked)
(define-public (component-info c)
(let* ((params (%complex-info c))
(tail (list-tail params 3))
@@ -335,54 +300,27 @@
(set-cdr! position tail)
params))
-;; component-basename c
-;;
-;; Returns the basename of the component object c.
(define-public (component-basename c)
(list-ref (component-info c) 0))
-;; component-position c
-;;
-;; Returns the position of the component object c.
(define-public (component-position c)
(list-ref (component-info c) 1))
-;; component-angle c
-;;
-;; Returns the rotation angle of the component object c.
(define-public (component-angle c)
(list-ref (component-info c) 2))
-;; component-mirror? c
-;;
-;; Returns #t if the component object c is mirrored.
(define-public (component-mirror? c)
(list-ref (component-info c) 3))
-;; component-locked? c
-;;
-;; Returns #t if the component object c is non-selectable.
(define-public (component-locked? c)
(list-ref (component-info c) 4))
-;; component-contents c
-;;
-;; Returns a list of the primitive objects which make up the component
-;; object c.
(define-public component-contents %complex-contents)
-;; component-append! c obj ...
-;;
-;; Adds obj (and any additional objects) to the primitive objects of
-;; the component c. Returns c.
(define-public (component-append! component . objects)
(for-each (lambda (x) (%complex-append! component x)) objects)
component)
-;; component-remove! c obj ...
-;;
-;; Adds obj (and any additional objects) from the primitive objects of
-;; the component c. Returns c.
(define-public (component-remove! component . objects)
(for-each (lambda (x) (%complex-remove! component x)) objects)
component)
commit 224e3edec54febcf055810e6d4220369e50f1ade
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (text objects).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 5f91e76..38cb0d7 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -979,6 +979,170 @@ Returns @samp{#t} if and only if @var{object} is a picture @code{object}.
@node Text
@subsection Text
+Text fulfils two roles, as straightforward labels and notes on
+schematics and symbols, and as attached or floating attributes
+(@pxref{Attributes}). A text @code{object} can be aligned in
+different ways relative to its anchor position, and can be displayed
+in different font sizes.
+
+Any text can be set to be visible or invisible on printed output (and
+gschem provides ways to preview invisible text). When a text
+@code{object} is an attribute (i.e. its string is in a
+@samp{@var{name}=@var{value}} format) then the visibility settings are
+more fine-grained: the text can be set to display just the attribute
+name, just the attribute value, or both.
+
+@xref{Attributes}.
+
+@defun text? object
+Returns @samp{#t} if and only if @var{object} is a text @code{object}.
+@end defun
+
+@defun make-text anchor align angle string size visible show [color]
+Creates and returns a new text @code{object}. @var{anchor} is the
+position of the anchor of the new text in the form @code{(x . y)}, and
+@var{align} is a symbol determining how the text should be aligned
+relative to the anchor. @var{align} must be one of the following
+symbols:
+
+@itemize
+@item
+@samp{lower-left}
+@item
+@samp{middle-left}
+@item
+@samp{upper-left}
+@item
+@samp{lower-center}
+@item
+@samp{middle-center}
+@item
+@samp{upper-center}
+@item
+@samp{lower-right}
+@item
+@samp{middle-right}
+@item
+@samp{upper-right}
+@end itemize
+
+For example, if @var{align} is @samp{upper-center}, the anchor will be
+located at the top center of the rendered text block.
+
+@var{angle} should be an integer multiple of 90 degrees, determining
+the angle which the text should be displayed at. @var{string} is the
+string contents for the @code{text} object, and must not contain any
+null characters (@samp{#\0} in Scheme, Unicode
+@samp{U+0000}. @var{size} is the font size to use. If @var{visible}
+is @samp{#f}, the text will be invisible; otherwise, it will be
+visible.
+
+When the @var{string} is in an attribute format (@pxref{Attributes}),
+the @var{show} argument determines which parts of the @var{string}
+will be displayed. It must be one of the following symbols:
+
+@itemize
+@item
+@samp{name}
+@item
+@samp{value}
+@item
+@samp{both}
+@end itemize
+
+If @var{color} is specified, it should be the integer color map index
+of the color with which to draw the text. If @var{color} is not
+specified, the default arc color is used.
+@end defun
+
+@defun set-text! text anchor align angle string size visible show [color]
+Sets the parameters of @var{text}. The arguments are the same as to
+@code{make-text}. Returns @var{text}.
+@end defun
+
+@defun text-info text
+Returns the parameters of @var{text} as a list in the form:
+
+@example
+((anchor-x . anchor-y) align angle string size visible show color)
+@end example
+
+See @code{make-text} for a description of all of these parameters.
+@end defun
+
+@defun text-center text
+Returns the position of the anchor of @var{text} in the form
+@code{(x . y)}.
+@end defun
+
+@defun text-align text
+Returns the alignment of @var{text} as one of the following symbols:
+
+@itemize
+@item
+@samp{lower-left}
+@item
+@samp{middle-left}
+@item
+@samp{upper-left}
+@item
+@samp{lower-center}
+@item
+@samp{middle-center}
+@item
+@samp{upper-center}
+@item
+@samp{lower-right}
+@item
+@samp{middle-right}
+@item
+@samp{upper-right}
+@end itemize
+@end defun
+
+@defun text-angle text
+Returns the angle that @var{text} is displayed at as an integer
+multiple of 90 degrees.
+@end defun
+
+@defun text-string text
+Returns the string content of @var{text}.
+@end defun
+
+@defun set-text-string! text str
+Set the string content of @var{text} to @var{str}. @var{str} must not
+contain any null characters (@samp{#\0} in Scheme, Unicode
+@samp{U+0000}).
+@end defun
+
+@defun text-size text
+Return the font size of @var{text} as an integer.
+@end defun
+
+@defun text-visible? text
+Returns @samp{#t} if and only if @var{text} is set to be visible.
+@end defun
+
+@defun set-text-visibility! text visible?
+If @var{visible?} is @samp{#f}, sets @var{text} to be invisible;
+otherwise, sets it to be visible.
+@end defun
+
+@defun text-attribute-mode text
+Returns a symbol indicating which parts of @var{text} will be
+displayed when @var{text} is a valid attribute. The returned value
+will be one of the following symbols:
+
+@itemize
+@item
+@samp{name}
+@item
+@samp{value}
+@item
+@samp{both}
+@end itemize
+@end defun
+
@node Components
@subsection Components
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index ca84434..3d0b414 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -225,60 +225,18 @@
;;;; Text
-;; text? t
-;;
-;; Returns #t if t is a gEDA text object.
(define-public (text? t)
(object-type? t 'text))
-;; set-text! t anchor align angle string size visible show [color]
-;;
-;; Sets the parameters of a text object. anchor is the point (x . y)
-;; at which the text is anchored. align is the position of the anchor
-;; relative to the text, and must be one of the following symbols:
-;;
-;; lower-left
-;; middle-left
-;; upper-left
-;; lower-center
-;; middle-center
-;; upper-center
-;; lower-right
-;; middle-right
-;; upper-right
-;;
-;; string is the new value of the text object. size is the font size.
-;; If visible is #f, the text object will be flagged as invisible;
-;; otherwise, it will be visible. When the text is an attribute, show
-;; determines which parts of the string will be displayed, and must be
-;; one of the following symbols:
-;;
-;; name
-;; value
-;; both
-;;
-;; The optional color argument is the colormap index of the color
-;; with which to draw the text. If color is not specified, the
-;; default color is used.
(define*-public (set-text! t anchor align angle string size visible show
#:optional color)
(%set-text! t (car anchor) (cdr anchor) align angle string size visible show
(if (not color) (object-color t) color)))
-;; make-text! anchor align angle string size visible show [color]
-;;
-;; Create a new text object. See set-text! for description of arguments.
(define*-public (make-text . args)
(let ((t (%make-text)))
(apply set-text! t args)))
-;; text-info t
-;;
-;; Returns the parameters of the text object t as a list of the form:
-;;
-;; ((anchor-x . anchor-y) align angle string size visible show color)
-;;
-;; See set-text! for description of these parameters.
(define-public (text-info t)
(let* ((params (%text-info t))
(tail (cddr params)))
@@ -286,79 +244,34 @@
(list-ref params 1))
tail)))
-;; text-anchor t
-;;
-;; Returns the anchor point of the text object t.
(define-public (text-anchor t)
(list-ref (text-info t) 0))
-;; text-align t
-;;
-;; Returns the text alignment of the text object t. The returned
-;; value will be one of the following symbols:
-;;
-;; lower-left
-;; middle-left
-;; upper-left
-;; lower-center
-;; middle-center
-;; upper-center
-;; lower-right
-;; middle-right
-;; upper-right
(define-public (text-align t)
(list-ref (text-info t) 1))
-;; text-angle t
-;;
-;; Returns the angle of the text object t.
(define-public (text-angle t)
(list-ref (text-info t) 2))
-;; text-string t
-;;
-;; Returns the string contained in the text object t.
(define-public (text-string t)
(list-ref (text-info t) 3))
-;; set-text-string! t str
-;;
-;; Set the string contained by the text object t.
(define-public (set-text-string! t str)
(let ((i (text-info t)))
(list-set! i 3 str)
(apply set-text! t i)))
-;; text-size t
-;;
-;; Returns the font size of the text object t.
(define-public (text-size t)
(list-ref (text-info t) 4))
-;; text-visible? t
-;;
-;; Returns #t if the text object t is set to be visible.
(define-public (text-visible? t)
(list-ref (text-info t) 5))
-;; set-text-visibility! t visible
-;;
-;; If visible is #f, sets object t to be invisible; otherwise, sets t
-;; to be visible.
(define-public (set-text-visibility! t visible)
(let ((i (text-info t)))
(list-set! i 5 (not (not visible)))
(apply set-text! t i)))
-;; text-attribute-mode t
-;;
-;; Returns the visibility mode of the text object t when the string
-;; contained in t is a valid attribute. The returned value will be
-;; one of the following symbols:
-;;
-;; name
-;; value
-;; both
(define-public (text-attribute-mode t)
(list-ref (text-info t) 6))
commit 1e9d73ec74c6abd2ddfcf18cccadc9c0c44ff7ff
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (picture and path objects).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 787e765..5f91e76 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -965,9 +965,17 @@ Returns the end angle of @var{arc} as an integer number of degrees.
@node Paths
@subsection Paths
+@defun path? object
+Returns @samp{#t} if and only if @var{object} is a path @code{object}.
+@end defun
+
@node Pictures
@subsection Pictures
+@defun picture? object
+Returns @samp{#t} if and only if @var{object} is a picture @code{object}.
+@end defun
+
@node Text
@subsection Text
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index ec04e9f..ca84434 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -178,19 +178,9 @@
;;;; Arcs
-;; arc? x
-;;
-;; Returns #t if x is a gEDA arc object.
(define-public (arc? a)
(object-type? a 'arc))
-;; set-arc! a center radius start-angle end-angle [color]
-;;
-;; Sets the parameters of an arc. center is the new coordinates (x
-;; . y) of the center of the arc, and radius is the new radius of the
-;; arc. start-angle and end-angle are the angles in degrees between
-;; which to draw the arc. The optional color argument is the new
-;; colormap index of the arc's color. Returns a after modifications.
(define*-public (set-arc! a center radius start-angle end-angle
#:optional color)
(%set-arc! a
@@ -200,23 +190,10 @@
(object-color a)
color)))
-;; make-arc center radius start-angle end-angle [color]
-;;
-;; Creates a new arc. center is the coordinates (x . y) of the center
-;; of the arc, and radius is the radius of the circle. start-angle
-;; and end-angle are the angles between which to draw the arc. The
-;; optional color argument is the colormap index of the color with
-;; which to draw the arc. If color is not specified, the default
-;; color is used.
(define*-public (make-arc center radius start-angle end-angle #:optional color)
(let ((c (%make-arc)))
(set-arc! c center radius start-angle end-angle color)))
-;; arc-info c
-;;
-;; Returns the parameters of the arc a as a list of the form:
-;;
-;; ((center-x . center-y) radius start-angle end-angle color)
(define-public (arc-info c)
(let* ((params (%arc-info c))
(tail (cddr params)))
@@ -224,44 +201,25 @@
(list-ref params 1))
tail)))
-;; arc-center a
-;;
-;; Returns the coordinates (x . y) of the center of the gEDA arc
-;; object c.
(define-public (arc-center a)
(list-ref (arc-info a) 0))
-;; arc-radius a
-;;
-;; Returns the radius of the gEDA arc object a.
(define-public (arc-radius a)
(list-ref (arc-info a) 1))
-;; arc-start-angle a
-;;
-;; Returns the start angle of the gEDA arc object a.
(define-public (arc-start-angle a)
(list-ref (arc-info a) 2))
-;; arc-end-angle a
-;;
-;; Returns the end angle of the gEDA arc object a.
(define-public (arc-end-angle a)
(list-ref (arc-info a) 3))
;;;; Paths
-;; path? x
-;;
-;; Returns #t if x is a gEDA path object.
(define-public (path? x)
(object-type? x 'path))
;;;; Pictures
-;; picture? x
-;;
-;; Returns #t if x is a gEDA picture object.
(define-public (picture? x)
(object-type? x 'picture))
commit 832af3a116fd37db9c8a647918179522ee0a10ab
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (arc objects).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 762c73b..787e765 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -922,6 +922,46 @@ stroke settings.
Returns @samp{#t} if and only if @var{object} is an arc @code{object}.
@end defun
+@defun make-arc center radius start-angle end-angle [color]
+Creates and returns a new arc @code{object}. @var{center} is the
+position of the center of the new arc in the form @code{(x . y)}, and
+@var{radius} is the integer radius of the arc. @var{start-angle} and
+@var{end-angle} are the angles at which to start and end the arc, in
+degrees. If @var{color} is specified, it should be the integer color
+map index of the color with which to draw the arc. If @var{color}
+is not specified, the default arc color is used.
+@end defun
+
+@defun set-arc! arc center radius start-angle end-angle [color]
+Sets the parameters of @var{arc}. The arguments are the same as to
+@code{make-arc}. Returns @var{arc}.
+@end defun
+
+@defun arc-info arc
+Returns the parameters of @var{arc} as a list of the form:
+
+@example
+((center-x . center-y) radius start-angle end-angle color)
+@end example
+@end defun
+
+@defun arc-center arc
+Returns the position of the center of @var{arc} in the form
+@code{(x . y)}.
+@end defun
+
+@defun arc-radius arc
+Returns the radius of @var{arc} as an integer.
+@end defun
+
+@defun arc-start-angle arc
+Returns the start angle of @var{arc} as an integer number of degrees.
+@end defun
+
+@defun arc-end-angle arc
+Returns the end angle of @var{arc} as an integer number of degrees.
+@end defun
+
@node Paths
@subsection Paths
commit be7d5d316bbf944f9e0a618ddff795a073de9183
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (circle objects).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 464af48..762c73b 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -869,8 +869,58 @@ form @code{(x . y)}.
@node Circles
@subsection Circles
+Circle @code{objects} are specified by center position and radius, and
+are purely graphical with no electrical meaning. They can be drawn in
+different colors, and with various stroke and fill settings.
+
+@xref{Object color}.
+@xref{Object fill and stroke}.
+
+@defun circle? object
+Returns @samp{#t} if and only of @var{object} is a circle @code{object}.
+@end defun
+
+@defun make-circle center radius [color]
+Creates and returns a new circle @code{object}. @var{center} is the
+position of the center of the new circle in the form @code{(x . y)},
+and @var{radius} is the integer radius of the circle. If @var{color}
+is specified, it should be the integer color map index of the color
+with which to draw the circle. If @var{color} is not specified, the
+default circle color is used.
+@end defun
+
+@defun set-circle! circle center radius [color]
+Sets the parameters of @var{circle}. The arguments are the same as to
+@code{make-circle}. Returns @var{circle}.
+@end defun
+
+@defun circle-info circle
+Returns the parameters of @var{circle} as a list of the form:
+
+@example
+((center-x . center-y) radius color)
+@end example
+@end defun
+
+@defun circle-center circle
+Returns the position of the center of @var{circle} as in the form
+@code{(x . y)}.
+@end defun
+
+@defun circle-radius circle
+Returns the radius of @var{circle} as an integer.
+@end defun
+
@node Arcs
@subsection Arcs
+Arc @code{objects} are specified by center position, radius, and start
+and end angles. They are purely graphical with no electrical
+meaning. They can be drawn in different colors, and with various
+stroke settings.
+
+@defun arc? object
+Returns @samp{#t} if and only if @var{object} is an arc @code{object}.
+@end defun
@node Paths
@subsection Paths
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index b742ce1..ec04e9f 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -148,18 +148,9 @@
;;;; Circles
-;; circle? x
-;;
-;; Returns #t if x is a gEDA circle object.
(define-public (circle? c)
(object-type? c 'circle))
-;; set-circle! c center radius [color]
-;;
-;; Sets the parameters of a circle c. center is the new coordinates (x
-;; . y) of the center of the circle, and radius is the new radius of
-;; the circle. The optional color argument is the new colormap index
-;; of the circle's color. Returns c after modifications.
(define*-public (set-circle! c center radius #:optional color)
(%set-circle! c
(car center) (cdr center)
@@ -168,22 +159,10 @@
(object-color c)
color)))
-;; make-circle center radius [color]
-;;
-;; Creates a new circle. center is the coordinates (x . y) of the
-;; center of the circle, and radius is the radius of the circle. The
-;; optional color argument is the colormap index of the color with
-;; which to draw the circle. If color is not specified, the default
-;; color is used.
(define*-public (make-circle center radius #:optional color)
(let ((c (%make-circle)))
(set-circle! c center radius color)))
-;; circle-info c
-;;
-;; Returns the parameters of the circle c as a list of the form:
-;;
-;; ((center-x . center-y) radius color)
(define-public (circle-info c)
(let* ((params (%circle-info c))
(tail (cddr params)))
@@ -191,16 +170,9 @@
(list-ref params 1))
tail)))
-;; circle-center c
-;;
-;; Returns the coordinates (x . y) of the center of the gEDA circle
-;; object c.
(define-public (circle-center c)
(list-ref (circle-info c) 0))
-;; circle-radius c
-;;
-;; Returns the radius of the gEDA circle object c.
(define-public (circle-radius c)
(list-ref (circle-info c) 1))
commit e7ed5291067d56419efe3764190d22fa7714937e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (box objects).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index b8d985b..464af48 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -822,6 +822,50 @@ Creates and returns a new bus pin @code{object}. Arguments are as for
@node Boxes
@subsection Boxes
+Boxes are rectangles specified by the coordinates of their top left
+and bottom right corners. They are purely graphical, and have no
+electrical meaning. They can be drawn in different colors, and with
+various stroke and fill settings.
+
+@xref{Object color}.
+@xref{Object fill and stroke}.
+
+@defun box? object
+Returns @samp{#t} if and only of @var{object} is a box @code{object}.
+@end defun
+
+@defun make-box top-left bottom-right [color]
+Creates and returns a new box @code{object}. @var{top-left} is the
+position of the top left of the new box in the form @code{(x . y)},
+and @var{bottom-right} is the position of the bottom right of the box.
+If @var{color} is specified, it should be the integer color map index
+of the color with which to draw the box. If @var{color} is not
+specified, the default box color is used.
+@end defun
+
+@defun set-box! box top-left bottom-right [color]
+Sets the parameters of @var{box}. The arguments are the same as to
+@code{make-box}. Returns @var{box}.
+@end defun
+
+@defun box-info box
+Returns the parameters of @var{box}. The return value is a list in the form:
+
+@example
+((top-left-x . top-left-y) (bottom-right-x . bottom-right-y) color)
+@end example
+@end defun
+
+@defun box-top-left box
+Returns the position of the top left corner of @var{box} in the form
+@code{(x . y)}.
+@end defun
+
+@defun box-bottom-right box
+Returns the position of the bottom right corner of @var{box} in the
+form @code{(x . y)}.
+@end defun
+
@node Circles
@subsection Circles
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 0df5a32..b742ce1 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -116,19 +116,10 @@
;;;; Boxes
-;; box? x
-;;
-;; Returns #t if x is a gEDA box object.
+
(define-public (box? l)
(object-type? l 'box))
-;; set-box! b top-left bottom-right [color]
-;;
-;; Sets the parameters of a box b. top-left is the new coordinates (x
-;; . y) of the top left corner of the box, and bottom-right is the new
-;; coordinates of the bottom right corner. The optional color argument
-;; is the new colormap index of the box's color. Returns b after
-;; modifications.
(define*-public (set-box! b top-left bottom-right #:optional color)
(%set-box! b
(car top-left) (cdr top-left)
@@ -137,22 +128,10 @@
(object-color b)
color)))
-;; make-box top-left bottom-right [color]
-;;
-;; Creates a new box. top-left is the coordinates (x . y) of the top
-;; left corner of the box, and bottom-right is the coordinates (x . y)
-;; of the bottom right corner. The optional color argument is the
-;; color index of the color with which to draw the box. If color is
-;; not specified, the default color is used.
(define*-public (make-box top-left bottom-right #:optional color)
(let ((l (%make-box)))
(set-box! l top-left bottom-right color)))
-;; box-info b
-;;
-;; Returns the parameters of the box b as a list of the form:
-;;
-;; ((top-left-x . top-left-y) (bottom-right-x . bottom-right-y) color)
(define-public (box-info b)
(let ((params (%box-info b)))
(list (cons (list-ref params 0)
@@ -161,17 +140,9 @@
(list-ref params 3))
(list-ref params 4))))
-;; box-top-left b
-;;
-;; Returns the coordinates (x . y) of the top left of the gEDA box
-;; object b.
(define-public (box-top-left l)
(list-ref (box-info l) 0))
-;; box-bottom-right b
-;;
-;; Returns the coordinates (x . y) of the bottom right of the gEDA box
-;; object b.
(define-public (box-bottom-right l)
(list-ref (box-info l) 1))
commit b1ca0b60c9218db51132272ffdf0c1815d29b80f
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (pin objects).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 10f50d5..b8d985b 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -780,6 +780,45 @@ Creates and returns a new bus @code{object}. Arguments are as for
@node Pins
@subsection Pins
+Pin @code{objects} are straight line segments which represent
+connectable points in symbols or subcircuits, such as the pins of a
+semiconductor package. Only one end of a pin can be connected to
+nets, buses or other pins; the rest of a pin is purely graphical.
+
+Pins come in two varieties: @dfn{net pins} and @dfn{bus pins}, which
+are used for connections to nets and buses respectively (@pxref{Nets
+and buses}).
+
+All of the functions that work on line @code{object}s also work with
+pins (@pxref{Lines}). Note that @code{line?} will return @code{#f} if
+called with a pin argument.
+
+@defun pin? object
+Returns @samp{#t} if and only if @var{object} is a pin @code{object}.
+@end defun
+
+@defun net-pin? object
+Returns @samp{#t} if and only if @var{object} is a net pin.
+@end defun
+
+@defun make-net-pin start end [color]
+Creates and returns a new net pin @code{object}. @var{start} is the
+position of the start of the new pin (the connectable end) in the form
+@code{(x . y)} and @var{end} is the position of end of the pin. If
+@var{color} is specified, it should be the integer color map index of
+the color with which to draw the pin. If @var{color} is not
+specified, the default pin color is used.
+@end defun
+
+@defun bus-pin? object
+Returns @samp{#t} if and only if @var{object} is a bus pin.
+@end defun
+
+@defun make-bus-pin start end [color]
+Creates and returns a new bus pin @code{object}. Arguments are as for
+@code{make-net-pin}.
+@end defun
+
@node Boxes
@subsection Boxes
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 2ceefdd..0df5a32 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -79,80 +79,37 @@
;;;; Nets
-;; net? x
-;;
-;; Returns #t if x is a gEDA net object.
(define-public (net? l)
(object-type? l 'net))
-;; make-net start end [color]
-;;
-;; Creates a new net. start is the coordinates (x . y) of the start
-;; of the net, and end is the coordinates (x . y) of the end of the
-;; net. The optional color argument is the color index of the color
-;; with which to draw the net. If color is not specified, the
-;; default color is used.
(define*-public (make-net start end #:optional color)
(let ((l (%make-net)))
(set-line! l start end color)))
;;;; Buses
-;; bus? x
-;;
-;; Returns #t if x is a gEDA bus object.
(define-public (bus? l)
(object-type? l 'bus))
-;; make-bus start end [color]
-;;
-;; Creates a new bus. start is the coordinates (x . y) of the start
-;; of the bus, and end is the coordinates (x . y) of the end of the
-;; bus. The optional color argument is the color index of the color
-;; with which to draw the bus. If color is not specified, the
-;; default color is used.
(define*-public (make-bus start end #:optional color)
(let ((l (%make-bus)))
(set-line! l start end color)))
;;;; Pins
-;; pin? x
-;;
-;; Returns #t if x is a gEDA pin object
(define-public (pin? l)
(object-type? l 'pin))
-;; net-pin? x
-;;
-;; Returns #t if x is a gEDA net pin object
(define-public (net-pin? l)
(and (pin? l) (equal? (%pin-type l) 'net)))
-;; bus-pin? x
-;;
-;; Returns #t if x is a gEDA bus pin object
(define-public (bus-pin? l)
(and (pin? l) (equal? (%pin-type l) 'bus)))
-;; make-net-pin start end [color]
-;;
-;; Creates a new net pin. start is the coordinates (x . y) of the
-;; start (the connectable end) of the pin, and end is the coordinates
-;; (x . y) of the end of the pin. The optional color argument is the
-;; color index of the color with which to draw the bus. If color is
-;; not specified, the default color is used.
(define*-public (make-net-pin start end #:optional color)
(let ((l (%make-pin 'net)))
(set-line! l start end color)))
-;; make-bus-pin start end [color]
-;;
-;; Creates a new bus pin. start is the coordinates (x . y) of the
-;; start (the connectable end) of the pin, and end is the coordinates
-;; (x . y) of the end of the pin. The optional color argument is the
-;; color index of the color with which to draw the bus. If color is
-;; not specified, the default color is used.
(define*-public (make-bus-pin start end #:optional color)
(let ((l (%make-pin 'bus)))
(set-line! l start end color)))
commit 623b9fe2ad30c517053b2c8b40723435903e2474
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (net and bus objects).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 3433ec0..10f50d5 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -747,6 +747,36 @@ may be a line, net, bus or pin @code{object}).
@node Nets and buses
@subsection Nets and buses
+Net and bus @code{object}s are straight line segments which represent
+electrical connectivity. Nets represent single wires, and buses
+multi-wire connections of arbitrary composition.
+
+All of the functions that work on line @code{object}s also work with
+nets and buses (@pxref{Lines}). Note that @code{line?} will return
+@code{#f} if called with a net or bus argument.
+
+@defun net? object
+Returns @samp{#t} if and only if @var{object} is a net.
+@end defun
+
+@defun make-net start end [color]
+Creates and returns a new net @code{object}. @var{start} is the
+position of the start of the new net in the form @code{(x . y)} and
+@var{end} is the position of end of the net. If @var{color} is
+specified, it should be the integer color map index of the color with
+which to draw the net. If @var{color} is not specified, the default
+net color is used.
+@end defun
+
+@defun bus? object
+Returns @samp{#t} if and only if @var{object} is a bus.
+@end defun
+
+@defun make-bus start end [color]
+Creates and returns a new bus @code{object}. Arguments are as for
+@code{make-net}.
+@end defun
+
@node Pins
@subsection Pins
commit 37338045adf382ecef00d5ee5f337c4da250b996
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (line objects).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index 023860b..3433ec0 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -694,6 +694,55 @@ list returned by @code{object-fill}. Returns @var{object}.
@node Lines
@subsection Lines
+Line @code{object}s are straight graphical line segments with no
+electrical meaning. A line's geometrical parameters are a start point
+and end point, and it supports different colors and stroke styles.
+
+Many of the functions for manipulating lines are also used to
+manipulate line-like objects such as nets, buses or pins.
+
+@defun line? object
+Returns @samp{#t} if and only if @var{object} is a line @code{object}.
+@end defun
+
+@defun make-line start end [color]
+Creates and returns a new line @code{object}. @var{start} is the
+position of the start of the new line in the form @code{(x . y)} and
+@var{end} is the position of end of the line. If @var{color} is
+specified, it should be the integer color map index of the color with
+which to draw the line. If @var{color} is not specified, the default
+line color is used.
+@end defun
+
+@defun set-line! line start end [color]
+Sets the parameters of @var{line} (which may be a line, net, bus or
+pin @code{object}). The arguments are the same as to
+@code{make-line}. Returns @var{line}.
+@end defun
+
+@defun line-info line
+Returns the parameters of @var{line} (which may be a line, net, bus or
+pin @code{object}). The return value is a list in the form:
+
+@example
+((start-x . start-y) (end-x . end-y) color)
+@end example
+
+@strong{Note}: For pin @code{object}s, first coordinate is the
+connectable point on the pin.
+@end defun
+
+@defun line-start line
+Returns the position @samp{(x . y)} of the start of @var{line} (which
+may be a line, net, bus or pin @code{object}). For pin
+@code{objects}, this is the position of the connectable point on the
+pin.
+@end defun
+
+@defun line-end line
+Returns the position @samp{(x . y)} of the end of @var{line} (which
+may be a line, net, bus or pin @code{object}).
+@end defun
@node Nets and buses
@subsection Nets and buses
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index da6eff8..2ceefdd 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -48,19 +48,9 @@
;;;; Lines
-;; line? x
-;;
-;; Returns #t if x is a gEDA line object.
(define-public (line? l)
(object-type? l 'line))
-;; set-line! l start end [color]
-;;
-;; Sets the parameters of a line, net, bus or pin object l. start is
-;; the new coordinates (x . y) of the start of the line (for pins,
-;; this is the connectable point), and end is the new coordinates of the
-;; end of the line. The optional color argument is the new colormap
-;; index of the line's color. Returns l after modifications.
(define*-public (set-line! l start end #:optional color)
(%set-line! l
(car start) (cdr start)
@@ -69,25 +59,10 @@
(object-color l)
color)))
-;; make-line start end [color]
-;;
-;; Creates a new line. start is the coordinates (x . y) of the start
-;; of the line, and end is the coordinates (x . y) of the end of the
-;; line. The optional color argument is the color index of the color
-;; with which to draw the line. If color is not specified, the
-;; default color is used.
(define*-public (make-line start end #:optional color)
(let ((l (%make-line)))
(set-line! l start end color)))
-;; line-info l
-;;
-;; Returns the parameters of the line, net, bus or pin l as a list of
-;; the form:
-;;
-;; ((start-x . start-y) (end-x . end-y) color)
-;;
-;; For pins, start is the connectable point on the pin.
(define-public (line-info l)
(let ((params (%line-info l)))
(list (cons (list-ref params 0)
@@ -96,18 +71,9 @@
(list-ref params 3))
(list-ref params 4))))
-;; line-start l
-;;
-;; Returns the coordinates (x . y) of the start of the gEDA line, net,
-;; bus or pin object l. For pins, this is is the connectable point on
-;; the pin.
(define-public (line-start l)
(list-ref (line-info l) 0))
-;; line-end l
-;;
-;; Returns the coordinates (x . y) of the end of the gEDA line, net or
-;; bus object l.
(define-public (line-end l)
(list-ref (line-info l) 1))
commit fd1e63aefad0097b1f99cf6cdb31998efec5c407
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (general objects).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index a11db60..023860b 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -477,6 +477,221 @@ the @code{(geda object)} module.
@node General object functions
@subsection General object functions
+@defun object? obj
+Returns @samp{#t} if and only if @var{obj} is an @code{object}.
+@end defun
+
+@defun copy-object object
+Returns a deep copy of @var{object}. The new @code{object} returned
+has no attached attributes, and is not part of a @code{page} or part
+of a component @code{object}.
+@end defun
+
+@defun object-component object
+Returns the component @code{object} that contains @var{object}, or
+@samp{#f} if @var{object} is not part of a component.
+@end defun
+
+@defun object-connections object
+Returns a list of other @code{object}s that are @emph{directly}
+connected to @var{object}. If @code{object} is not included in a
+@code{page}, raises an @samp{object-state} error. The connections
+reported are independent of inclusion in components.
+
+For example, consider a page containing a net and a component, and the
+component contains a single pin. If the connectable end of the pin
+intersects the net, then @code{(object-connections <net>)} will return
+a list containing the pin @code{object}, and @emph{not} the component.
+@end defun
+
+@menu
+* Object sub-types::
+* Object bounds::
+* Object color::
+* Object fill and stroke::
+@end menu
+
+@node Object sub-types
+@subsubsection Object sub-types
+
+Schematic element @code{object}s come in several subtypes.
+
+@defun object-type object
+Returns the sub-type of @var{object} as a symbol. The subtype will be
+one of the following symbols:
+
+@itemize
+@item
+@samp{arc}
+@item
+@samp{box}
+@item
+@samp{bus}
+@item
+@samp{circle}
+@item
+@samp{complex} (indicates a component @code{object})
+@item
+@samp{line}
+@item
+@samp{net}
+@item
+@samp{path}
+@item
+@samp{picture}
+@item
+@samp{pin}
+@item
+@samp{text}
+@end itemize
+@end defun
+
+@defun object-type? object type
+Returns @samp{#t} if and only if @var{object} is an @code{object} and
+that its subtype is @var{type}, which should be a symbol.
+@end defun
+
+@node Object bounds
+@subsubsection Object bounds
+
+The bounds of an object is the smallest bounding rectangle of the
+object, expressed in document coordinates (@pxref{Coordinate system}).
+
+@defun object-bounds objects...
+Returns the world coordinate bounding box containing all of the
+@var{objects} passed as arguments, or @samp{#f} if none of the
+@var{objects} have bounds (for example, this can occur if no
+@var{objects} are specified, or if they are all empty component
+@code{object}s).
+
+@strong{Note}: @code{object-bounds} always returns the actual bounds
+of the @var{objects}, not the visible bounds. This means that the bounds of
+invisible text is always included.
+@end defun
+
+@defun fold-bounds bounds...
+Calculates the union of several sets of @var{bounds} (as returned by
+@code{object-bounds}). If any of the @var{bounds} are @samp{#f}, they
+are skipped; if all of the @var{bounds} are @samp{#f}, @samp{#f} is
+returned.
+@end defun
+
+@node Object color
+@subsubsection Object color
+
+Object colors in gEDA documents are specified as indices into a color
+map. This allows users to specify the color map that suits them when
+viewing schematics and symbols.
+
+@defun object-color object
+Returns the integer color map index of the the color used to draw
+@var{object}.
+@end defun
+
+@defun set-object-color! object color
+Sets the integer color map index for @var{object} to @var{color}.
+Returns @var{object}.
+@end defun
+
+@node Object fill and stroke
+@subsubsection Object fill and stroke
+
+Graphical object subtypes -- lines, boxes, circles, arcs and paths --
+are drawn with a stroke pattern that can be configured in detail.
+
+@defun object-stroke object
+Returns the stroke settings of the @var{object}, which must be a line,
+box, circle, arc or path @code{object}. The return value is a list of
+parameters:
+
+@enumerate
+@item
+stroke width, as an integer number of world units
+@item
+cap style, one of the symbols @code{none}, @code{square} or
+@code{round}.
+@item
+dash style, one of the symbols @code{solid}, @code{dotted},
+@code{dashed}, @code{center} or @code{phantom}.
+@item
+up to two dash parameters, depending on the dash style:
+@itemize
+@item
+for solid lines, no parameters;
+@item
+for dotted lines, dot spacing;
+@item
+for other styles, dot/dash spacing and dash length.
+@end itemize
+@end enumerate
+@end defun
+
+@defun set-object-stroke! object width cap dash [dash-space [dash-length]]
+Set the stroke settings of the @var{object}, which must be a line,
+box, circle, arc or path @code{object}. The arguments are the same as
+the contents of the list returned by @code{object-stroke}. Returns
+@var{object}.
+@end defun
+
+@defun object-stroke-width object
+Returns the integer stroke width of @var{object}, which must be a
+line, box, circle, arc or path @code{object}.
+@end defun
+
+@defun object-stroke-cap object
+Returns the stroke cap style of @var{object}, which must be a line,
+box, circle, arc or path @code{object}. The returned value is one of
+the symbols @code{none}, @code{square} or @code{round}.
+@end defun
+
+@defun object-stroke-dash object
+Returns the dash style of @var{object}, which must be a line, box,
+circle, arc or path @code{object}. The return value is a list of
+between one and three parameters:
+
+@enumerate
+@item
+dash style, one of the symbols @code{solid}, @code{dotted},
+@code{dashed}, @code{center} or @code{phantom}.
+@item
+for styles other than @code{solid}, dot/dash spacing;
+@item
+for @code{dashed}, @code{center} and @code{phantom}, dash length.
+@end enumerate
+@end defun
+
+Some types of @code{object} -- boxes, circles and paths -- can have
+their interiors filled with a variety of patterns.
+
+@defun object-fill object
+Returns the fill settings of @var{object}, which must be a box, circle
+or path @code{object}. The return value is a list of one to six
+parameters:
+
+@enumerate
+@item
+fill style, one of the symbols @code{hollow}, @code{solid},
+@code{mesh} or @code{hatch};
+@item
+up to five fill parameters, depending on fill style:
+@enumerate
+@item
+none for @code{hollow} or @code{solid} fills;
+@item
+line width, line angle (in degrees) and line spacing for @code{hatch} fills;
+@item
+line width, first angle and spacing, and second angle and spacing for
+@code{mesh} fills.
+@end enumerate
+@end enumerate
+@end defun
+
+@defun set-object-fill! object fill-type . fill-args
+Sets the fill settings of @var{object}, which must be a box, circle or
+path @code{object}. The arguments are the same as the contents of the
+list returned by @code{object-fill}. Returns @var{object}.
+@end defun
+
@node Lines
@subsection Lines
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 695dd02..da6eff8 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -655,26 +655,12 @@
(define-public object-stroke %object-stroke)
(define-public set-object-stroke! %set-object-stroke!)
-;; object-stroke-width obj
-;;
-;; Returns the stroke width used to draw obj
(define-public (object-stroke-width obj)
(list-ref (object-stroke obj) 0))
-;; object-stroke-cap obj
-;;
-;; Returns the cap style used to draw obj. One of the symbols none,
-;; square or round.
(define-public (object-stroke-cap obj)
(list-ref (object-stroke obj) 1))
-;; object-stroke-dash obj
-;;
-;; Returns the dash style used to draw obj. The style is returned as
-;; a list, where the first element is the style itself (one of the
-;; symbols solid, dotted, dashed, center or phantom), and the
-;; remaining elements (if present) are the dot/dash spacing and dash
-;; length used in the dash style.
(define-public (object-stroke-dash obj)
(list-tail (object-stroke obj) 2))
@@ -683,24 +669,8 @@
;;;; Object bounds
-;; object-bounds [object...]
-;;
-;; Return the bounds containing the objects passed as arguments. The
-;; bounds returned are in world coordinates, and are given in the
-;; form:
-;;
-;; ((left . top) . (right . bottom))
-;;
-;; Note that this function always returns the actual bounds of the
-;; objects, not the visible bounds.
(define-public object-bounds %object-bounds)
-;; fold-bounds bounds...
-;;
-;; Calculate the extent of the smallest rectangle containing all of
-;; the bounds passed as arguments, which should be bounds as returned
-;; by object-bounds. If any set of bounds is #f, it is ignored; if
-;; all are #f, #f is returned.
(define-public (fold-bounds . bounds)
(fold
(lambda (a b)
commit bcd036f9432335473d5ad64e18d83df669947eb3
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Core API documentation (pages).
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
index f44d6fb..a11db60 100644
--- a/docs/scheme-api/geda-scheme.texi
+++ b/docs/scheme-api/geda-scheme.texi
@@ -342,6 +342,118 @@ available to be used in all gEDA applications.
@node Core page functions
@section Core page functions
+To use the functions described in this section, you will need to load
+the @code{(geda page)} module.
+
+@xref{Pages}.
+
+@defun page? obj
+Returns @samp{#t} if and only if @var{obj} is a @code{page}.
+@end defun
+
+@defun active-pages
+Returns a list of all open @code{page}s.
+@end defun
+
+@subsection Page creation, disposal and filenames
+
+Every @code{page} is associated with a @emph{filename}. The filename
+does not necessarily have to be a file which exists and/or is
+accessible in the filesystem.
+
+@defun make-page filename
+Creates and returns a new, empty @code{page}, with the given
+string @var{filename}.
+@end defun
+
+@defun close-page! page
+Destroys @var{page}. The returned value is undefined.
+
+@strong{Warning}: This function closes and destroys @var{page}
+immediately, regardless of whether the page has been modified since
+loading or saving, and without asking the user.
+@end defun
+
+@defun page-filename page
+Returns the filename associated with @var{page} as a string.
+@end defun
+
+@defun set-page-filename! page filename
+Sets the filename of @var{page} to @var{filename}. Returns
+@var{page}.
+@end defun
+
+@subsection Page contents
+
+A schematic or symbol @code{page} is composed of a set of
+@code{object}s which determine both its graphical appearance and its
+electrical meaning.
+
+@defun page-contents page
+Returns a list of the @code{object}s which make up @var{page}. The
+list can be freely modified without changing the contents of
+@var{page}.
+@end defun
+
+@defun page-append! page objects...
+Appends zero or more @var{objects} to the contents of @var{page} in
+the order given. Returns @var{page}.
+
+If any of the @var{objects} is already part of a @code{page} other
+than @var{page}, or is part of a component @code{object}, raises an
+@code{object-state} error. Any of the @var{objects} that are already
+in the @var{page} are ignored.
+@end defun
+
+@defun page-remove! page objects...
+Removes zero or more @var{objects} from the contents of @var{page}.
+Returns @var{page}.
+
+Any @var{objects} that are not part of a @code{page} or component
+@code{object} are ignored.
+
+An @samp{object-state} error will be thrown if any of the
+@var{objects} satisfies any of the following conditions:
+
+@itemize
+@item
+part of a @code{page} other than @var{page};
+@item
+part of component @code{object};
+@item
+has attached attributes (@pxref{Attributes});
+@item
+is attached as an attribute.
+@end itemize
+@end defun
+
+@defun object-page object
+Returns the @code{page} which contains @var{object} (either directly
+or indirectly), or @samp{#f} if @var{object} is not part of a
+@code{page}.
+
+@strong{Note}: If the @var{object} argument to @code{object-page} is
+part of a component @code{object} which is itself part of a
+@code{page}, that @code{page} will be returned.
+@end defun
+
+@subsection Page dirty flags
+
+A @code{page} has a @emph{dirty flag} that is used to indicate to
+applications that the @code{page} has been modified since it was last
+loaded or saved.
+
+@defun page-dirty? page
+Returns @samp{#t} if the @var{page}'s page has been marked as dirty;
+otherwise, returns @samp{#f}.
+@end defun
+
+@defun set-page-dirty! page [state]
+Sets the dirty flag for @var{page}. If @var{state} is @samp{#f},
+clears the dirty flag; otherwise, or if @var{state} is omitted, marks
+the page as dirty. Returns @var{page}.
+@end defun
+
@node Core object functions
@section Core object functions
diff --git a/libgeda/scheme/geda/page.scm b/libgeda/scheme/geda/page.scm
index 1738b26..556f52f 100644
--- a/libgeda/scheme/geda/page.scm
+++ b/libgeda/scheme/geda/page.scm
@@ -36,25 +36,13 @@
(define-public page-contents %page-contents)
(define-public page-dirty? %page-dirty?)
-;; page-append! P obj ...
-;;
-;; Adds obj (and any additional objects) to the contents of the page
-;; P. Returns P.
(define-public (page-append! P . objects)
(for-each (lambda (x) (%page-append! P x)) objects)
P)
-;; page-remove! P obj ...
-;;
-;; Removes obj (and any additional objects) from the contents of the
-;; page P. Returns P.
(define-public (page-remove! P . objects)
(for-each (lambda (x) (%page-remove! P x)) objects)
P)
-;; set-page-dirty! [state]
-;;
-;; Set whether page is flagged as changed according to the optional
-;; flag state. If state is omitted, the page is marked as changed.
(define*-public (set-page-dirty! page #:optional (state #t))
(%set-page-dirty! page state))
commit 4a3a197ab3519928c1fdb2b31a0cbc272ba75f12
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add documentation skeleton.
diff --git a/configure.ac b/configure.ac
index 1f2c9fb..01a65e1 100644
--- a/configure.ac
+++ b/configure.ac
@@ -264,6 +264,7 @@ AC_CONFIG_FILES([Makefile
symbols/documentation/Makefile
docs/Makefile
+ docs/scheme-api/Makefile
docs/scripts/Makefile
docs/toplevel/Makefile
docs/toplevel/gedadocs.html
diff --git a/docs/Makefile.am b/docs/Makefile.am
index 9e295f7..d65b9e9 100644
--- a/docs/Makefile.am
+++ b/docs/Makefile.am
@@ -1,5 +1,5 @@
-SUBDIRS = toplevel wiki scripts
+SUBDIRS = toplevel wiki scripts scheme-api
EXTRA_DIST = ChangeLog-1.0 ChangeLog
diff --git a/docs/scheme-api/Makefile.am b/docs/scheme-api/Makefile.am
new file mode 100644
index 0000000..deef157
--- /dev/null
+++ b/docs/scheme-api/Makefile.am
@@ -0,0 +1 @@
+info_TEXINFOS = geda-scheme.texi
diff --git a/docs/scheme-api/geda-scheme.texi b/docs/scheme-api/geda-scheme.texi
new file mode 100644
index 0000000..f44d6fb
--- /dev/null
+++ b/docs/scheme-api/geda-scheme.texi
@@ -0,0 +1,437 @@
+\input texinfo @c -*-texinfo-*-
+@setfilename geda-scheme.info
+@include version.texi
+@settitle gEDA Scheme Reference Manual @value{VERSION}
+
+@copying
+This manual is for gEDA/gaf, version @value{VERSION}.
+
+Copyright @copyright{} 2011 Peter TB Brett
+
+The text of and illustrations in this document are licensed under a
+Creative Commons Attributionâ??Share Alike 3.0 Unported license
+("CC-BY-SA"). An explanation of CC-BY-SA is available at
+http://creativecommons.org/licenses/by-sa/3.0/. The original authors
+of this document designate the gEDA Project as the "Attribution Party"
+for purposes of CC-BY-SA. In accordance with CC-BY-SA, if you
+distribute this document or an adaptation of it, you must provide the
+URL for the original version.
+@end copying
+
+@titlepage
+@title gEDA Scheme Reference Manual
+@author Peter TB Brett
+
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+
+@end titlepage
+
+@contents
+
+@ifnottex
+@node Top
+@top gEDA Scheme Reference Manual
+@insertcopying
+@end ifnottex
+
+@menu
+* Introduction::
+
+* Schematic Document Model::
+* Core API Reference::
+* gschem API Reference::
+
+* Concept Index::
+* Function Index::
+@end menu
+
+@node Introduction
+@unnumbered Introduction
+
+@section About gEDA
+
+@dfn{gEDA}, or @emph{GPL Electronic Design Automation}, is a suite of
+free software tools for designing electronics. The gEDA project has
+produced and continues working on a full GPL'd suite and toolkit of
+Electronic Design Automation (EDA) tools. These tools are used for
+electrical circuit design, schematic capture, simulation, prototyping,
+and production. Currently, the gEDA project offers a mature suite of
+free software applications for electronics design, including schematic
+capture, attribute management, bill of materials (BOM) generation,
+netlisting into over 20 netlist formats, analog and digital
+simulation, and printed circuit board (PCB) layout.
+
+The gEDA project was started because of the lack of free EDA tools for
+POSIX systems with the primary purpose of advancing the state of free
+hardware or open source hardware. The suite is mainly being developed
+on the GNU/Linux platform with some development effort going into
+making sure the tools run on other platforms as well.
+
+@section About the gEDA Scheme API
+
+The @dfn{gEDA Scheme API}, documented in this manual, is a set of
+Scheme functions which can be used to enhance gEDA applications by
+adding new functionality or modify existing behaviour.
+
+gEDA has always used a Scheme interpreter for interpreting
+configuration files, managing keybindings in gschem, and implementing
+netlist exporter backends in gnetlist. However, for a long time the
+utility of embedding a Scheme interpreter was diminished by the lack
+of a low-level API for inspecting and modifying schematic documents.
+The Scheme types and functions documented here were added to gEDA to
+address that need.
+
+gEDA uses the @emph{Guile} Scheme implementation (otherwise known as
+the @emph{GNU Ubiquitous Intelligent Language for Extensions}) as its
+embedded Scheme. For more information about Guile, please visit
+@uref{http://www.gnu.org/s/guile/}.
+
+@section Getting Additional Help
+@cindex Reporting bugs
+
+If you think you have found a bug, please file a bug report in
+Launchpad: @uref{http://bugs.launchpad.net/geda}. Please add the tag
+@samp{scheme-api}. It will help us to fix your bug quickly if you can
+describe in detail how to reproduce the bug.
+
+If you have a question about using gEDA, or about extending gEDA using
+Scheme, you may wish to send a message to one of the gEDA mailing
+lists. You may also find additional information in the gEDA
+wiki.
+
+Both the mailing lists and wiki can be accessed from the main gEDA
+website: @uref{http://gpleda.org/}.
+
+@section We Need Feedback!
+
+If you find a typographical error in this manual, or if you have
+thought of a way to make this manual better, we would love to hear
+from you! Please submit a report in Launchpad:
+@uref{http://bugs.launchpad.net/geda}, with the tag @samp{scheme-api}.
+
+@node Schematic Document Model
+@chapter The Schematic Document Model
+
+When using gEDA to design an electronic circuit, users use the
+schematic editor, gschem, to choose and place @emph{schematic symbols}
+on a @emph{schematic page}, and connect the @emph{pins} of the symbols
+together by drawing @emph{nets}. The user may add various
+@emph{attributes} to symbols, nets or pins to modify how the circuit
+diagrams should be interpreted. The resulting schematics are then
+processed with the gnetlist tool to generate a @emph{netlist}.
+
+This chapter describes the different data types used by the Scheme API
+to represent gEDA documents (both schematics and symbols), and how
+they relate to each other.
+
+@menu
+* Pages::
+* Objects::
+* Component objects::
+* Attributes::
+* Coordinate system::
+@end menu
+
+@node Pages
+@section Pages
+@cindex Pages
+@cindex Schematics
+@cindex Symbols
+
+Schematics and symbols are presented as different types of document to
+the user, with different file extensions, icons and mime-types.
+However, when they are loaded into a gEDA application such as gschem
+for editing, they are internally represented in exactly the same way,
+by the @code{page} type. The @code{page} is the top-level gEDA document
+data type.
+
+Internally, the main difference between a @code{page} for a schematic
+and a @code{page} for a symbol is the types of schematic element they
+are permitted to contain (@pxref{Objects}). For example, a symbol is
+not permitted to contain nets, buses, or instances of other symbols,
+and a schematic is not permitted to contain pins.
+
+@strong{Note}: Although the restrictions on what types of primitive
+element schematics and symbols may contain are not enforced by the
+API, designs which violate these restrictions may cause the netlister
+not to work as expected.
+
+Each @code{page} is associated with a filename, although the filename is
+not required by the API either to be valid or to be associated with a
+accessible file in the filesystem.
+
+Pages are not garbage-collected; once you create a @code{page}, you are
+responsible for making sure that it is disposed of when it is no
+longer required.
+
+@node Objects
+@section Objects
+@cindex Objects
+@cindex Schematic elements
+
+Each @code{page} contains some number of @dfn{schematic elements},
+represented by the @code{object} type. There are several sub-types of
+@code{object}, including:
+
+@itemize @bullet
+@item
+graphical lines, circles, arcs, rectangles and paths;
+
+@item
+nets and net pins;
+
+@item
+buses and bus pins;
+
+@item
+pictures;
+
+@item
+text;
+
+@item
+and symbol instances, known as 'components'.
+@end itemize
+
+Each @code{object} can be part of at most a single @code{page} -- they
+cannot be shared between pages. @code{object}s are automatically
+garbage collected.
+
+Most of different @code{object} sub-types are quite straightforward to
+understand. The main exceptions are components, and the text
+@code{object}-based attribute mechanism, which are described in the
+following sections.
+
+@node Component objects
+@section Component objects
+@cindex Component
+@cindex Component library
+@cindex Embedded component
+
+When a symbol is instantiated in a schematic (e.g. by the user
+selecting it from the gschem component library and placing it on the
+page), a compound @code{object} known as a @dfn{component} is created.
+
+Like a @code{page}, a component contains some number of @code{object}
+elements. When a component is created from a symbol, the contents of
+the symbol's @code{page} are copied into the component.
+
+In order to allow the component to appear in the correct place on the
+schematic page, at the correct orientation, etc., a transformation is
+applied to every @code{object} in the component.
+
+Normally, when the schematic @code{page} is closed, the parameters of
+the transformation are stored in the schematic file along with the
+basename of the original symbol, but the @code{object} contents of the
+component are discarded. When the schematic is subsequently
+re-opened, the original symbol is retrieved from the component
+library, and used to recreate the component.
+
+However, a component may optionally be @emph{embedded}. In this case,
+its contents @emph{are} stored in the schematic file.
+
+@strong{Note}: A component cannot contain another component -- only
+other types of @code{object}.
+
+@node Attributes
+@section Attributes
+@cindex Attribute
+@cindex Attribute format
+
+A gEDA user is able to annotate schematic elements with additional
+data, such as footprints for components or net names for nets. This
+is carried out using @dfn{attributes}.
+
+An attribute is text @code{object} which contains a text string in the
+form @samp{@var{name}=@var{value}}. Currently, the restrictions on
+attribute format that are enforced by the API are:
+
+@itemize @bullet
+@item
+Attribute @var{name}s:
+
+@enumerate
+@item
+must contain at least one character;
+@item
+must not contain a @samp{=} character (Unicode @code{U+003D});
+@item
+must not end with a space (@samp{ }, Unicode @code{U+0020}).
+@end enumerate
+
+@item
+Attribute @var{value}s:
+
+@enumerate
+@item
+must contain at least one character;
+@item
+must not begin with a space (@samp{ }, Unicode @code{U+0020}).
+@end enumerate
+@end itemize
+
+@strong{Note}: Due to assumptions made by some gEDA tools, it is
+@emph{strongly recommended} that you use attribute @var{NAME}s which
+contain only lower-case Latin characters, decimal digits, full stops
+@samp{.} (@code{U+002E}), and hyphens @samp{-} (@code{U+002D}).
+
+There are two types of attribute:
+
+@cindex Attached attribute
+@emph{Attached attributes} are attribute text @code{object}s that are
+linked to another @code{object}. To attach an attribute to another
+schematic element, both @code{object}s must be part of the same
+component or part of the same @code{object}. For example, a
+@samp{netname=@var{NAME}} attribute attached to a net @code{object}
+can be used to give that net a specific name in netlist output, such
+as @samp{VCC} or @samp{GND}.
+
+@cindex Floating attribute
+@emph{Floating attributes} are attribute text @code{object}s that are
+not linked to another @code{object}. These attributes affect the
+schematic or symbol that they're part of as a whole. For example, a
+floating @samp{documentation=@var{url}} attribute in a symbol tells
+gschem's @strong{Help â?? Component Documentation} command how to find
+the component's data sheet.
+
+@node Coordinate system
+@section Coordinate system
+
+gEDA documents use a @dfn{coordinate system} (internally referred to
+as `world' coordinates) with coordinates increasing upwards and to the
+right (i.e. a conventional right-handed Cartesian coordinate
+system).
+
+Although all coordinates may be positive or negative, gschem only
+displays objects with positive coordinates (i.e. in the upper right
+quadrant of the coordinate system). It is therefore recommended to
+use only positive coordinates.
+
+In the Scheme API, the coordinate of a point is expressed in the format:
+
+@example
+(x . y)
+@end example
+
+and a set of @dfn{bounds} (i.e. a rectangular area in the document
+plane) is expressed in the format:
+
+@example
+((left . top) . (right . bottom))
+@end example
+
+where @code{left} is the smaller x coordinate, @code{right} is the
+larger x coordinate, and @code{bottom} and @code{top} are respectively
+the smaller and larger y coordinates.
+
+@node Core API Reference
+@chapter Core API Reference
+
+The Scheme modules and functions described in this chapter are
+primitive operations for working with schematics and symbols, and are
+available to be used in all gEDA applications.
+
+@menu
+* Core page functions::
+* Core object functions::
+* Core attribute functions::
+@end menu
+
+@node Core page functions
+@section Core page functions
+
+@node Core object functions
+@section Core object functions
+
+To use the functions described in this section, you will need to load
+the @code{(geda object)} module.
+
+@menu
+* General object functions::
+* Lines::
+* Nets and buses::
+* Pins::
+* Boxes::
+* Circles::
+* Arcs::
+* Paths::
+* Pictures::
+* Text::
+* Components::
+@end menu
+
+@node General object functions
+@subsection General object functions
+
+@node Lines
+@subsection Lines
+
+@node Nets and buses
+@subsection Nets and buses
+
+@node Pins
+@subsection Pins
+
+@node Boxes
+@subsection Boxes
+
+@node Circles
+@subsection Circles
+
+@node Arcs
+@subsection Arcs
+
+@node Paths
+@subsection Paths
+
+@node Pictures
+@subsection Pictures
+
+@node Text
+@subsection Text
+
+@node Components
+@subsection Components
+
+@node Core attribute functions
+@section Core attribute functions
+
+@node gschem API Reference
+@chapter gschem API Reference
+
+The Scheme modules and functions described in this chapter are
+available in the gschem schematic editor application. They are more
+focused on enabling and responding to user editing operations.
+
+@menu
+* Windows and views::
+* Selections::
+* Hooks::
+* Miscellanous gschem functions::
+@end menu
+
+@node Windows and views
+@section Windows and views
+
+@node Selections
+@section Selections
+
+@node Hooks
+@section Hooks
+
+@node Miscellanous gschem functions
+@section Miscellaneous gschem functions
+
+@node Concept Index
+@unnumbered Concept Index
+
+@printindex cp
+
+@node Function Index
+@unnumbered Function Index
+
+@printindex fn
+
+@bye
commit 008ba78fc1a60641b620cabc9ecc198cd0a2225c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make promote-attribs! return '() for non-components.
diff --git a/libgeda/scheme/geda/attrib.scm b/libgeda/scheme/geda/attrib.scm
index 58ec01b..09eeb7b 100644
--- a/libgeda/scheme/geda/attrib.scm
+++ b/libgeda/scheme/geda/attrib.scm
@@ -97,7 +97,7 @@
;; Return copy
y))
(promotable-attribs object))
- #f)))
+ '())))
;; attrib-inherited? attrib
;;
diff --git a/libgeda/scheme/unit-tests/t0031-promotable-attributes.scm b/libgeda/scheme/unit-tests/t0031-promotable-attributes.scm
index 8f61f6a..ba6d668 100644
--- a/libgeda/scheme/unit-tests/t0031-promotable-attributes.scm
+++ b/libgeda/scheme/unit-tests/t0031-promotable-attributes.scm
@@ -1,6 +1,9 @@
;; Test promotable-attributes function
(use-modules (unit-test))
+(use-modules (geda page))
+(use-modules (geda object))
+(use-modules (geda attrib))
;; Unfortunately, we can't test this at the moment, because the
;; default list of promotable attribute names is empty. We suppress
@@ -15,3 +18,13 @@
(begin-test 'promote-attribs!
(throw 'missing-unit-test "We can't test this at the moment"))
+
+(begin-test 'promote-attribs!/not-in-page
+ (let ((p (make-net-pin '(0 . 0) '(100 . 0))))
+ (assert-thrown 'object-state (promote-attribs! p))))
+
+(begin-test 'promote-attribs!/non-component
+ (let ((P (make-page "/test/page/A"))
+ (p (make-net-pin '(0 . 0) '(100 . 0))))
+ (page-append! P p)
+ (assert-equal '() (promote-attribs! p))))
commit c0125211b863d0d54554c39abda8c76f7ad27fae
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make %detach-attrib! succeed when not attached.
%detach-attrib! claims to succeed when attempting to detach an
attribute that's not attached to anything, but it lies.
diff --git a/libgeda/scheme/unit-tests/t0030-attribute.scm b/libgeda/scheme/unit-tests/t0030-attribute.scm
index a82d046..d63cc07 100644
--- a/libgeda/scheme/unit-tests/t0030-attribute.scm
+++ b/libgeda/scheme/unit-tests/t0030-attribute.scm
@@ -132,6 +132,9 @@
(page-append! page pin1 pin2 x)
+ ;; Detach when already detached
+ (assert-equal pin1 (detach-attribs! pin1 x))
+
(attach-attribs! pin1 x)
(assert-thrown 'object-state
diff --git a/libgeda/src/scheme_attrib.c b/libgeda/src/scheme_attrib.c
index 6167dc0..1c5f0f4 100644
--- a/libgeda/src/scheme_attrib.c
+++ b/libgeda/src/scheme_attrib.c
@@ -222,6 +222,11 @@ SCM_DEFINE (detach_attrib_x, "%detach-attrib!", 2, 0, 0,
OBJECT *obj = edascm_to_object (obj_s);
OBJECT *attrib = edascm_to_object (attrib_s);
+ /* If attrib isn't attached, do nothing */
+ if (attrib->attached_to == NULL) {
+ return obj_s;
+ }
+
/* Check that attrib isn't attached elsewhere */
if (attrib->attached_to != obj) {
scm_error (edascm_object_state_sym, s_detach_attrib_x,
commit 1d97d6c9cad63a79bceaa9d599a757c01f1a60e7
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make %attach-attrib! succeed when already attached.
Instead of raising an object-state exception when trying to create an
attribute attachment that already exists, succeed silently.
diff --git a/libgeda/scheme/unit-tests/t0030-attribute.scm b/libgeda/scheme/unit-tests/t0030-attribute.scm
index 803fa50..a82d046 100644
--- a/libgeda/scheme/unit-tests/t0030-attribute.scm
+++ b/libgeda/scheme/unit-tests/t0030-attribute.scm
@@ -44,6 +44,11 @@
(assert-equal (list x) (object-attribs p))
(assert-equal p (attrib-attachment x))
+ ;; Attach attribute twice
+ (assert-equal p (attach-attribs! p x))
+ (assert-equal (list x) (object-attribs p))
+ (assert-equal p (attrib-attachment x))
+
;; Attach attribute which is already attached, within same
;; component
(assert-thrown 'object-state (attach-attribs! q x))
diff --git a/libgeda/src/scheme_attrib.c b/libgeda/src/scheme_attrib.c
index c9b2743..6167dc0 100644
--- a/libgeda/src/scheme_attrib.c
+++ b/libgeda/src/scheme_attrib.c
@@ -139,6 +139,9 @@ SCM_DEFINE (attrib_attachment, "%attrib-attachment", 1, 0, 0,
* API, and are required in order to ensure that the Scheme API is
* safe.
*
+ * If \a attrib_s is already attached to \a obj_s, does nothing
+ * successfully.
+ *
* \note Scheme API: Implements the %attach-attrib! procedure of
* the (geda core attrib) module.
*
@@ -158,6 +161,9 @@ SCM_DEFINE (attach_attrib_x, "%attach-attrib!", 2, 0, 0,
OBJECT *obj = edascm_to_object (obj_s);
OBJECT *attrib = edascm_to_object (attrib_s);
+ /* Check that attachment doesn't already exist */
+ if (attrib->attached_to == obj) return obj_s;
+
/* Check that both are in the same page and/or complex object */
if ((obj->parent != attrib->parent)
|| (o_get_page (toplevel, obj) != o_get_page (toplevel, attrib))
commit dce70c5e826e2958d02a5bf8089b7dd1eb3a519f
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Replace attach-attrib! and detach-attrib!.
For consistency with the functions for adding and removing objects to
pages and components, this patch makes the following changes:
- Replace attach-attrib! with attach-attribs! which takes multiple
attribute arguments.
- Replace detach-attrib! with detach-attribs! which takes multiple
attribute arguments.
- Make attach-attrib! and detach-attrib! return the target object
rather than the affected attributes.
diff --git a/libgeda/scheme/geda/attrib.scm b/libgeda/scheme/geda/attrib.scm
index 375b8f7..58ec01b 100644
--- a/libgeda/scheme/geda/attrib.scm
+++ b/libgeda/scheme/geda/attrib.scm
@@ -28,8 +28,6 @@
(define-public parse-attrib %parse-attrib)
(define-public object-attribs %object-attribs)
(define-public attrib-attachment %attrib-attachment)
-(define-public attach-attrib! %attach-attrib!)
-(define-public detach-attrib! %detach-attrib!)
(define-public promotable-attribs %promotable-attribs)
;; attribute? a
@@ -108,3 +106,11 @@
(define-public (attrib-inherited? attrib)
(not (or (attrib-attachment attrib)
(not (object-component attrib)))))
+
+(define-public (attach-attribs! obj . attribs)
+ (for-each (lambda (x) (%attach-attrib! obj x)) attribs)
+ obj)
+
+(define-public (detach-attribs! obj . attribs)
+ (for-each (lambda (x) (%detach-attrib! obj x)) attribs)
+ obj)
diff --git a/libgeda/scheme/unit-tests/t0015-object-complex.scm b/libgeda/scheme/unit-tests/t0015-object-complex.scm
index 6cdb240..09cf92f 100644
--- a/libgeda/scheme/unit-tests/t0015-object-complex.scm
+++ b/libgeda/scheme/unit-tests/t0015-object-complex.scm
@@ -143,7 +143,7 @@
(pin (make-net-pin '(0 . 0) '(100 . 0)))
(attrib (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both)))
(component-append! comp pin attrib)
- (attach-attrib! pin attrib)
+ (attach-attribs! pin attrib)
(assert-thrown 'object-state (component-remove! comp pin))
(assert-thrown 'object-state (component-remove! comp attrib))))
diff --git a/libgeda/scheme/unit-tests/t0019-object-copy.scm b/libgeda/scheme/unit-tests/t0019-object-copy.scm
index ed57a57..c5a917f 100644
--- a/libgeda/scheme/unit-tests/t0019-object-copy.scm
+++ b/libgeda/scheme/unit-tests/t0019-object-copy.scm
@@ -20,19 +20,19 @@
(assert-equal P (object-page x))
(assert-equal #f (object-page (copy-object x)))
- (attach-attrib! A x)
+ (attach-attribs! A x)
(assert-equal A (attrib-attachment x))
(assert-equal #f (attrib-attachment (copy-object x)))
- (detach-attrib! A x)
+ (detach-attribs! A x)
(page-remove! P x)
(component-append! A p x)
(assert-equal A (object-component x))
(assert-equal #f (object-component (copy-object x)))
- (attach-attrib! p x)
+ (attach-attribs! p x)
(assert-equal p (attrib-attachment x))
(assert-equal #f (attrib-attachment (copy-object x)))))
diff --git a/libgeda/scheme/unit-tests/t0021-page-dirty.scm b/libgeda/scheme/unit-tests/t0021-page-dirty.scm
index 78189c2..b450ed8 100644
--- a/libgeda/scheme/unit-tests/t0021-page-dirty.scm
+++ b/libgeda/scheme/unit-tests/t0021-page-dirty.scm
@@ -99,18 +99,18 @@
(page-append! P t C) (component-append! C p)
; Attach attribute to component
- (assert-dirties P (attach-attrib! C t))
+ (assert-dirties P (attach-attribs! C t))
; Detach attribute from component
- (assert-dirties P (detach-attrib! C t))
+ (assert-dirties P (detach-attribs! C t))
; Move attribute into component
(page-remove! P t)
(component-append! C t)
; Attach attribute to pin
- (assert-dirties P (attach-attrib! p t))
+ (assert-dirties P (attach-attribs! p t))
; Detach attribute from pin
- (assert-dirties P (detach-attrib! p t))
+ (assert-dirties P (detach-attribs! p t))
)
(lambda ()
(close-page! P)))
diff --git a/libgeda/scheme/unit-tests/t0030-attribute.scm b/libgeda/scheme/unit-tests/t0030-attribute.scm
index 3ee3e48..803fa50 100644
--- a/libgeda/scheme/unit-tests/t0030-attribute.scm
+++ b/libgeda/scheme/unit-tests/t0030-attribute.scm
@@ -31,7 +31,7 @@
(z (make-text '(0 . 0) 'lower-left 0 "name=z" 10 #t 'both)))
;; Attach attribute outside component or page
- (assert-thrown 'object-state (attach-attrib! C x))
+ (assert-thrown 'object-state (attach-attribs! C x))
(assert-equal '() (object-attribs C))
(assert-true (not (attrib-attachment x)))
@@ -40,37 +40,37 @@
(component-append! D z)
;; Attach attribute to object in same component
- (assert-equal x (attach-attrib! p x))
+ (assert-equal p (attach-attribs! p x))
(assert-equal (list x) (object-attribs p))
(assert-equal p (attrib-attachment x))
;; Attach attribute which is already attached, within same
;; component
- (assert-thrown 'object-state (attach-attrib! q x))
+ (assert-thrown 'object-state (attach-attribs! q x))
;; Attach attribute to object in different component
- (assert-thrown 'object-state (attach-attrib! p z))
+ (assert-thrown 'object-state (attach-attribs! p z))
(assert-equal (list x) (object-attribs p))
(assert-true (not (attrib-attachment z)))
;; Attach internal attribute to containing component
- (assert-thrown 'object-state (attach-attrib! D z))
+ (assert-thrown 'object-state (attach-attribs! D z))
(assert-equal '() (object-attribs D))
(assert-true (not (attrib-attachment z)))
;; Attach attribute in component to floating object
- (assert-thrown 'object-state (attach-attrib! C z))
+ (assert-thrown 'object-state (attach-attribs! C z))
(assert-equal '() (object-attribs C))
(assert-true (not (attrib-attachment z)))
;; Attach floating attribute to object in component
(component-remove! D z)
- (assert-thrown 'object-state (attach-attrib! p z))
+ (assert-thrown 'object-state (attach-attribs! p z))
(assert-equal (list x) (object-attribs p))
(assert-true (not (attrib-attachment z)))
;; Attach multiple attributes
- (assert-equal y (attach-attrib! p y))
+ (assert-equal p (attach-attribs! p y))
(assert-equal (list x y) (object-attribs p))
(assert-equal p (attrib-attachment y))
))
@@ -94,7 +94,7 @@
(page-append! Q z)
; Attach attribute to component in same page
- (attach-attrib! C x)
+ (attach-attribs! C x)
(assert-equal (list x) (object-attribs C))
(assert-equal C (attrib-attachment x))
@@ -103,10 +103,10 @@
(assert-thrown 'object-state (page-remove! P C))
; Attach attribute to component in different page
- (assert-thrown 'object-state (attach-attrib! C z))
+ (assert-thrown 'object-state (attach-attribs! C z))
; Attach attribute to pin in component in page
- (attach-attrib! p y)
+ (attach-attribs! p y)
(assert-equal (list y) (object-attribs p))
(assert-equal p (attrib-attachment y))
@@ -127,12 +127,12 @@
(page-append! page pin1 pin2 x)
- (attach-attrib! pin1 x)
+ (attach-attribs! pin1 x)
(assert-thrown 'object-state
- (detach-attrib! pin2 x))
+ (detach-attribs! pin2 x))
- (assert-equal x (detach-attrib! pin1 x))
+ (assert-equal pin1 (detach-attribs! pin1 x))
(assert-equal '() (object-attribs pin1)) ))
(begin-test 'inherited-attribs
@@ -149,7 +149,7 @@
(assert-equal (list x y) (inherited-attribs C))
- (attach-attrib! p x)
+ (attach-attribs! p x)
(assert-equal (list y) (inherited-attribs C))))
@@ -163,9 +163,9 @@
(z (make-text '(1 . 2) 'lower-left 0 "name=z" 10 #t 'both)))
(page-append! P A w x)
- (attach-attrib! A x)
+ (attach-attribs! A x)
(component-append! A p y z)
- (attach-attrib! p y)
+ (attach-attribs! p y)
(assert-true (not (attrib-inherited? w)))
(assert-true (not (attrib-inherited? x)))
diff --git a/libgeda/scheme/unit-tests/t1000-deprecated.scm b/libgeda/scheme/unit-tests/t1000-deprecated.scm
index d0ccb5e..0021a9c 100644
--- a/libgeda/scheme/unit-tests/t1000-deprecated.scm
+++ b/libgeda/scheme/unit-tests/t1000-deprecated.scm
@@ -33,7 +33,7 @@
(y (make-text '(0 . 0) 'lower-left 0 "name=y" 10 #t 'both)))
(for-each (lambda (o) (component-append! C o)) (list p x y))
- (for-each (lambda (a) (attach-attrib! p a)) (list x y))
+ (attach-attribs! p x y)
(assert-equal (list y x) (get-object-attributes p))))
@@ -45,7 +45,7 @@
(z (make-text '(0 . 0) 'lower-left 0 "bork=z" 10 #t 'both)))
(for-each (lambda (o) (component-append! C o)) (list p x y z))
- (for-each (lambda (a) (attach-attrib! p a)) (list x y z))
+ (attach-attribs! p x y z)
(assert-equal (list "y" "x") (get-attrib-value-by-attrib-name p "name"))))
diff --git a/libgeda/src/scheme_attrib.c b/libgeda/src/scheme_attrib.c
index 615b0d7..c9b2743 100644
--- a/libgeda/src/scheme_attrib.c
+++ b/libgeda/src/scheme_attrib.c
@@ -144,7 +144,7 @@ SCM_DEFINE (attrib_attachment, "%attrib-attachment", 1, 0, 0,
*
* \param obj_s the object to which to attach an attribute.
* \param attrib_s the attribute to attach.
- * \return \a attrib_s.
+ * \return \a obj_s.
*/
SCM_DEFINE (attach_attrib_x, "%attach-attrib!", 2, 0, 0,
(SCM obj_s, SCM attrib_s), "Attach an attribute to an object.")
@@ -186,7 +186,8 @@ SCM_DEFINE (attach_attrib_x, "%attach-attrib!", 2, 0, 0,
o_page_changed (toplevel, obj);
- return attrib_s;
+ scm_remember_upto_here_1 (attrib_s);
+ return obj_s;
}
/*! \brief Detach an attribute from an object.
@@ -230,7 +231,8 @@ SCM_DEFINE (detach_attrib_x, "%detach-attrib!", 2, 0, 0,
o_page_changed (toplevel, obj);
- return attrib_s;
+ scm_remember_upto_here_1 (attrib_s);
+ return obj_s;
}
/*! \brief Get a complex object's promotable attribs.
commit b5046514e8c4561de9a5a249624b23e003a2988a
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make parse-attrib stricter about input.
parse-attrib now raises an attribute-format exception if input is a
text object but not in the correct format (i.e. it only returns on
success).
diff --git a/libgeda/scheme/geda/attrib.scm b/libgeda/scheme/geda/attrib.scm
index 03fe556..375b8f7 100644
--- a/libgeda/scheme/geda/attrib.scm
+++ b/libgeda/scheme/geda/attrib.scm
@@ -36,20 +36,20 @@
;;
;; Returns #t if a is an text object in attribute format.
(define-public (attribute? a)
- (and (text? a) (parse-attrib a) #t))
+ (false-if-exception (and (parse-attrib a) #t)))
;; attrib-name a
;;
-;; Returns the attribute name of a, or #f if a is not in attribute
-;; format.
+;; Returns the attribute name of a, or raises an attribute-format
+;; error if a is not in attribute format.
(define-public (attrib-name a)
(let ((v (parse-attrib a)))
(if v (car v) v)))
;; attrib-value a
;;
-;; Returns the attribute value of a, or #f if a is not in attribute
-;; format.
+;; Returns the attribute value of a, or raises an attribute-format
+;; error if a is not in attribute format.
(define-public (attrib-value a)
(let ((v (parse-attrib a)))
(if v (cdr v) v)))
diff --git a/libgeda/scheme/unit-tests/t0030-attribute.scm b/libgeda/scheme/unit-tests/t0030-attribute.scm
index 087add1..3ee3e48 100644
--- a/libgeda/scheme/unit-tests/t0030-attribute.scm
+++ b/libgeda/scheme/unit-tests/t0030-attribute.scm
@@ -17,9 +17,9 @@
(assert-equal (cons (attrib-name good) (attrib-value good))
(parse-attrib good))
- (assert-true (not (parse-attrib bad)))
- (assert-true (not (attrib-name bad)))
- (assert-true (not (attrib-value bad))) ))
+ (assert-thrown 'attribute-format (parse-attrib bad))
+ (assert-thrown 'attribute-format (attrib-name bad))
+ (assert-thrown 'attribute-format (attrib-value bad)) ))
(begin-test 'attach-attrib
(let ((C (make-component "testcomponent1" '(0 . 0) 0 #f #f))
diff --git a/libgeda/src/scheme_attrib.c b/libgeda/src/scheme_attrib.c
index 44dafb6..615b0d7 100644
--- a/libgeda/src/scheme_attrib.c
+++ b/libgeda/src/scheme_attrib.c
@@ -1,6 +1,6 @@
/* gEDA - GPL Electronic Design Automation
* libgeda - gEDA's library - Scheme API
- * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+ * Copyright (C) 2010-2011 Peter Brett <peter@xxxxxxxxxxxxx>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -33,7 +33,8 @@ SCM_SYMBOL (attribute_format_sym, "attribute-format");
* \par Function Description
* Tries to parse the underlying string of the text object \a text_s
* into name and value strings. If successful, returns a pair of the
- * form <tt>(name . value)</tt>. Otherwise, returns SCM_BOOL_F.
+ * form <tt>(name . value)</tt>. Otherwise, raises an
+ * <tt>attribute-format</tt> error.
*
* \note Scheme API: Implements the %attrib-parse procedure of the
* (geda core attrib) module.
@@ -51,6 +52,7 @@ SCM_DEFINE (parse_attrib, "%parse-attrib", 1, 0, 0,
SCM_ASSERT (edascm_is_object_type (text_s, OBJ_TEXT), text_s,
SCM_ARG1, s_parse_attrib);
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *text = edascm_to_object (text_s);
scm_dynwind_begin (0);
@@ -60,6 +62,12 @@ SCM_DEFINE (parse_attrib, "%parse-attrib", 1, 0, 0,
if (o_attrib_get_name_value (text, &name, &value)) {
result = scm_cons (scm_from_utf8_string (name),
scm_from_utf8_string (value));
+ } else {
+ scm_error (attribute_format_sym, s_parse_attrib,
+ _("~A is not a valid attribute: invalid string '~A'."),
+ scm_list_2 (text_s,
+ scm_from_utf8_string (o_text_get_string (toplevel, text))),
+ SCM_EOL);
}
scm_dynwind_end ();
commit 8b9f6235d72ad5be0fca53613e7ca77802543d58
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make attribute? only return #t or #f.
diff --git a/libgeda/scheme/geda/attrib.scm b/libgeda/scheme/geda/attrib.scm
index ba77355..03fe556 100644
--- a/libgeda/scheme/geda/attrib.scm
+++ b/libgeda/scheme/geda/attrib.scm
@@ -36,7 +36,7 @@
;;
;; Returns #t if a is an text object in attribute format.
(define-public (attribute? a)
- (and (text? a) (parse-attrib a)))
+ (and (text? a) (parse-attrib a) #t))
;; attrib-name a
;;
diff --git a/libgeda/scheme/unit-tests/t0030-attribute.scm b/libgeda/scheme/unit-tests/t0030-attribute.scm
index b636ddb..087add1 100644
--- a/libgeda/scheme/unit-tests/t0030-attribute.scm
+++ b/libgeda/scheme/unit-tests/t0030-attribute.scm
@@ -9,8 +9,8 @@
(let ((good (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
(bad (make-text '(1 . 2) 'lower-left 0 "name value" 10 #t 'both)))
- (assert-true (attribute? good))
- (assert-true (not (attribute? bad)))
+ (assert-equal #t (attribute? good))
+ (assert-equal #f (attribute? bad))
(assert-equal "name" (attrib-name good))
(assert-equal "value" (attrib-value good))
commit 6b299b8b9f423976f746cf3694a49b9124950237
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make gschem's overridden close-page! never ask.
The original version of the overridden version of close-page! loaded
by gschem into the (geda core page) asked the user to confirm closing
of dirtied pages. It turns out that this was a really bad idea,
because it made the close-page! function impossible to document
clearly. This patch makes the behaviour of gschem's close-page! match
the core library version, i.e. close immediately without question.
diff --git a/gschem/src/g_window.c b/gschem/src/g_window.c
index 6ecf2ef..ca1023d 100644
--- a/gschem/src/g_window.c
+++ b/gschem/src/g_window.c
@@ -1,6 +1,6 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
- * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+ * Copyright (C) 2010-2011 Peter Brett <peter@xxxxxxxxxxxxx>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -215,11 +215,7 @@ SCM_DEFINE (close_page_x, "%close-page!", 1, 0, 0,
if (reset_page)
x_window_set_current_page (w_current, page);
- if (w_current->toplevel->page_current->CHANGED) {
- x_dialog_close_changed_page (w_current, w_current->toplevel->page_current);
- } else {
- x_window_close_page (w_current, w_current->toplevel->page_current);
- }
+ x_window_close_page (w_current, w_current->toplevel->page_current);
if (reset_page)
x_window_set_current_page (w_current, curr_page);
commit c6b89e3d030a6fa061598dd467f4bee9c147c28e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Allow fold-bounds to take any number of arguments.
Also add a unit test.
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 766762a..695dd02 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -25,7 +25,9 @@
#:use-module (geda core complex)
; Optional arguments
- #:use-module (ice-9 optargs))
+ #:use-module (ice-9 optargs)
+
+ #:use-module (srfi srfi-1))
(define-public object-type %object-type)
(define-public object? %object?)
@@ -693,19 +695,23 @@
;; objects, not the visible bounds.
(define-public object-bounds %object-bounds)
-;; fold-bounds a b
-;;
-;; Calculate the bounds of the smallest rectangle containing both the
-;; bounds a and b, which should be bounds as returned by
-;; object-bounds. If either a or b is #f, it is ignored; if both are
-;; #f, #f is returned.
-(define-public (fold-bounds a b)
- (if (and a b)
- ;; calc bounds
- (cons (cons (min (caar a) (caar b)) ; left
- (max (cdar a) (cdar b))) ; top
- (cons (max (cadr a) (cadr b)) ; right
- (min (cddr a) (cddr b)))) ; bottom
-
- ;; return whichever isn't #f
- (or a b)))
+;; fold-bounds bounds...
+;;
+;; Calculate the extent of the smallest rectangle containing all of
+;; the bounds passed as arguments, which should be bounds as returned
+;; by object-bounds. If any set of bounds is #f, it is ignored; if
+;; all are #f, #f is returned.
+(define-public (fold-bounds . bounds)
+ (fold
+ (lambda (a b)
+ (if (and a b)
+ ;; calc bounds
+ (cons (cons (min (caar a) (caar b)) ; left
+ (max (cdar a) (cdar b))) ; top
+ (cons (max (cadr a) (cadr b)) ; right
+ (min (cddr a) (cddr b)))) ; bottom
+
+ ;; return whichever isn't #f
+ (or a b)))
+ #f ;; default
+ bounds))
diff --git a/libgeda/scheme/unit-tests/t0016-object-bounds.scm b/libgeda/scheme/unit-tests/t0016-object-bounds.scm
index 1768879..a896b8c 100644
--- a/libgeda/scheme/unit-tests/t0016-object-bounds.scm
+++ b/libgeda/scheme/unit-tests/t0016-object-bounds.scm
@@ -30,3 +30,24 @@
(component-append! C x)
(assert-equal '((0 . 1) . (1 . 0)) (object-bounds x))
))
+
+(begin-test 'fold-bounds
+ (let ((x (make-box '(0 . 1) '(1 . 0)))
+ (y (make-box '(2 . 3) '(3 . 2))))
+
+ ;; No arguments
+ (assert-equal #f (fold-bounds #f))
+
+ ;; One argument
+ (let ((a (object-bounds x)))
+ (assert-equal a (fold-bounds a))
+ (assert-equal #f (fold-bounds #f)))
+
+ ;; > 1 argument
+ (let ((a (object-bounds x))
+ (b (object-bounds y)))
+ (assert-equal '((0 . 3) . (3 . 0))
+ (fold-bounds a b))
+ (assert-equal a (fold-bounds #f a))
+ (assert-equal a (fold-bounds a #f))
+ (assert-equal #f (fold-bounds #f #f)))))
commit daaf7d90949a3ac7cfe2914aedd1bb5c170c375b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Allow %object-bounds to take no arguments.
Allow %object-bounds to take an empty argument list and return #f.
Since %object-bounds already returns #f in none of the object
arguments has any bounds, it's consistent to return #f in no arguments
are supplied.
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index d0e025a..766762a 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -681,10 +681,11 @@
;;;; Object bounds
-;; object-bounds object [object...]
+;; object-bounds [object...]
;;
-;; Return the bounds containing one or more objects. The bounds
-;; returned are in world coordinates, and are given in the form:
+;; Return the bounds containing the objects passed as arguments. The
+;; bounds returned are in world coordinates, and are given in the
+;; form:
;;
;; ((left . top) . (right . bottom))
;;
diff --git a/libgeda/scheme/unit-tests/t0016-object-bounds.scm b/libgeda/scheme/unit-tests/t0016-object-bounds.scm
index 64264ec..1768879 100644
--- a/libgeda/scheme/unit-tests/t0016-object-bounds.scm
+++ b/libgeda/scheme/unit-tests/t0016-object-bounds.scm
@@ -9,6 +9,9 @@
(t (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both))
(C (make-component "test component" '(0 . 0) 0 #t #f)))
+ ;; No arguments
+ (assert-equal #f (object-bounds))
+
;; Single argument
(assert-equal '((0 . 1) . (1 . 0)) (object-bounds x))
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index c3513da..240a985 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -241,37 +241,32 @@ SCM_DEFINE (object_type, "%object-type", 1, 0, 0,
/*! \brief Get the bounds of a list of objects
* \par Function Description
- * Returns the bounds of the objects in the list formed by prepending
- * \a obj_s to \a rst_s. The bounds are returned as a pair structure
- * of the form:
+ * Returns the bounds of the objects in the variable-length argument
+ * list \a rst_s. The bounds are returned as a pair structure of the
+ * form:
*
* <code>((left . top) . (right . bottom))</code>
*
- * If none of the objects has any bounds (e.g. because they are all
- * empty components and/or text strings), returns SCM_BOOL_F.
+ * If \a rst_s is empty, or none of the objects has any bounds
+ * (e.g. because they are all empty components and/or text strings),
+ * returns SCM_BOOL_F.
*
* \warning This function always returns the actual bounds of the
* objects, not the visible bounds.
*
- * \note Scheme API: Implements the %object-bounds procedure in
- * the (geda core object) module. The procedure takes one or more
+ * \note Scheme API: Implements the %object-bounds procedure in the
+ * (geda core object) module. The procedure takes any number of
* #OBJECT smobs as arguments.
*
- * \param [in] obj_s #OBJECT to get bounds for.
- * \param [in] rst_s Variable-length list of additional #OBJECT arguments.
+ * \param [in] rst_s Variable-length list of #OBJECT arguments.
* \return bounds of objects or SCM_BOOL_F.
*/
-SCM_DEFINE (object_bounds, "%object-bounds", 1, 0, 1,
- (SCM obj_s, SCM rst_s), "Get the bounds of one or more objects")
+SCM_DEFINE (object_bounds, "%object-bounds", 0, 0, 1,
+ (SCM rst_s), "Get the bounds of a list of objects")
{
- SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
- SCM_ARG1, s_object_bounds);
-
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
- OBJECT *obj = edascm_to_object (obj_s);
GList *obj_list = edascm_to_object_glist (rst_s, s_object_bounds);
- obj_list = g_list_prepend (obj_list, obj);
int success, left, top, right, bottom;
if (toplevel->show_hidden_text) {
@@ -296,7 +291,7 @@ SCM_DEFINE (object_bounds, "%object-bounds", 1, 0, 1,
scm_from_int (min(top, bottom))));
}
- scm_remember_upto_here_2 (obj_s, rst_s);
+ scm_remember_upto_here_1 (rst_s);
return result;
}
commit 7c759d21f74e89e41d08bbc871891554ec027607
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: %object-type should raise errors on bad type.
If %object-type encounters an object with an invalid type field,
%object-type should raise an error rather than logging a message and
returning #f.
Since we can't actually create an object with an invalid type field
from the Scheme API, there's sadly no way of unit-testing this change.
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index a922494..c3513da 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -1,6 +1,6 @@
/* gEDA - GPL Electronic Design Automation
* libgeda - gEDA's library - Scheme API
- * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+ * Copyright (C) 2010-2011 Peter Brett <peter@xxxxxxxxxxxxx>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -231,9 +231,9 @@ SCM_DEFINE (object_type, "%object-type", 1, 0, 0,
case OBJ_PIN: result = pin_sym; break;
case OBJ_ARC: result = arc_sym; break;
default:
- g_critical ("o_mirror_world: object %p has bad type '%c'\n",
- obj, obj->type);
- result = SCM_BOOL_F;
+ scm_misc_error (s_object_type, _("Object ~A has bad type '~A'"),
+ scm_list_2 (obj_s,
+ scm_integer_to_char (scm_from_int (obj->type))));
}
return result;
commit f7cc58369760991eda968571d5677e97ca2092cd
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add the set-attrib-value! function.
diff --git a/libgeda/scheme/geda/attrib.scm b/libgeda/scheme/geda/attrib.scm
index 17c9866..ba77355 100644
--- a/libgeda/scheme/geda/attrib.scm
+++ b/libgeda/scheme/geda/attrib.scm
@@ -54,6 +54,13 @@
(let ((v (parse-attrib a)))
(if v (cdr v) v)))
+;; set-attrib-value! a val
+;;
+;; Updates the attribute a with the new value val.
+(define-public (set-attrib-value! a val)
+ (let ((name (attrib-name a)))
+ (set-text-string! a (string-join (list name val) "="))))
+
;; inherited-attribs object
;;
;; Returns the inherited attributes of object, if object is a
diff --git a/libgeda/scheme/unit-tests/t0030-attribute.scm b/libgeda/scheme/unit-tests/t0030-attribute.scm
index 03d29e4..b636ddb 100644
--- a/libgeda/scheme/unit-tests/t0030-attribute.scm
+++ b/libgeda/scheme/unit-tests/t0030-attribute.scm
@@ -171,3 +171,9 @@
(assert-true (not (attrib-inherited? x)))
(assert-true (not (attrib-inherited? y)))
(assert-true (attrib-inherited? z))))
+
+(begin-test 'set-attrib-value!
+ (let ((a (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both)))
+ (set-attrib-value! a "foo")
+ (assert-equal "name" (attrib-name a))
+ (assert-equal "foo" (attrib-value a))))
commit e6870ce5a1aac5f2da8d6bb53495d6a52967a538
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add the set-text-string! function.
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 99fb777..d0e025a 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -495,6 +495,14 @@
(define-public (text-string t)
(list-ref (text-info t) 3))
+;; set-text-string! t str
+;;
+;; Set the string contained by the text object t.
+(define-public (set-text-string! t str)
+ (let ((i (text-info t)))
+ (list-set! i 3 str)
+ (apply set-text! t i)))
+
;; text-size t
;;
;; Returns the font size of the text object t.
diff --git a/libgeda/scheme/unit-tests/t0014-object-text.scm b/libgeda/scheme/unit-tests/t0014-object-text.scm
index 9f07edb..8642243 100644
--- a/libgeda/scheme/unit-tests/t0014-object-text.scm
+++ b/libgeda/scheme/unit-tests/t0014-object-text.scm
@@ -70,3 +70,15 @@
(set-text-visibility! a 'bork)
(assert-true (text-visible? a))
(assert-equal (text-info a) (text-info b))))
+
+(begin-test 'set-text-string!
+ (let ((a (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21))
+ (b (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21)))
+ (assert-equal "test text" (text-string a))
+
+ (set-text-string! a "new test text")
+ (assert-equal "new test text" (text-string a))
+
+ (set-text-string! a "test text")
+ (assert-equal "test text" (text-string a))
+ (assert-equal (text-info a) (text-info b))))
commit ad289e2ea5d5402fd7061965a3939d33323e4292
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Add pointer-position function.
diff --git a/gschem/scheme/gschem/window.scm b/gschem/scheme/gschem/window.scm
index 50c19da..62765ed 100644
--- a/gschem/scheme/gschem/window.scm
+++ b/gschem/scheme/gschem/window.scm
@@ -27,3 +27,4 @@
(define-public active-page %active-page)
(define-public set-active-page! %set-active-page!)
+(define-public pointer-position %pointer-position)
diff --git a/gschem/src/g_window.c b/gschem/src/g_window.c
index 0f3fb60..6ecf2ef 100644
--- a/gschem/src/g_window.c
+++ b/gschem/src/g_window.c
@@ -228,6 +228,30 @@ SCM_DEFINE (close_page_x, "%close-page!", 1, 0, 0,
}
/*!
+ * Get the current pointer position
+ * \par Function Description
+ * Returns the current mouse pointer position, expressed in world
+ * coordinates. If the pointer is outside the schematic drawing area,
+ * returns SCM_BOOL_F.
+ *
+ * The coordinates are returned as a cons:
+ *
+ * <code>(x . y)</code>
+ *
+ * \return The current pointer position, or SCM_BOOL_F.
+ */
+SCM_DEFINE (pointer_position, "%pointer-position", 0, 0, 0,
+ (), "Get the current pointer position.")
+{
+ int x, y;
+ GSCHEM_TOPLEVEL *w_current = g_current_window ();
+ if (x_event_get_pointer_position (w_current, FALSE, &x, &y)) {
+ return scm_cons (scm_from_int (x), scm_from_int (y));
+ }
+ return SCM_BOOL_F;
+}
+
+/*!
* \brief Create the (gschem core window) Scheme module
* \par Function Description
* Defines procedures in the (gschem core window) module. The module
@@ -241,7 +265,7 @@ init_module_gschem_core_window ()
/* Add them to the module's public definitions. */
scm_c_export (s_current_window, s_active_page, s_set_active_page_x,
- s_close_page_x, NULL);
+ s_close_page_x, s_pointer_position, NULL);
/* Override procedures in the (geda core page) module */
{
commit 0aaabc599c8146801364d5b8bc9e984ea764cc5b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Reimplement get-object-bounds in Scheme.
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index 86f0dee..463c709 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -33,7 +33,6 @@ SCM g_funcs_browse_wiki(SCM wikiname);
SCM g_funcs_use_rc_values(void);
SCM get_selected_component_attributes(GSCHEM_TOPLEVEL *w_current);
/* g_hook.c */
-SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclude_object_type);
void g_init_hook ();
void g_run_hook_object (const char *name, OBJECT *obj);
void g_run_hook_object_list (const char *name, GList *obj_lst);
diff --git a/gschem/scheme/gschem/deprecated.scm b/gschem/scheme/gschem/deprecated.scm
index 67443aa..8a90e7d 100644
--- a/gschem/scheme/gschem/deprecated.scm
+++ b/gschem/scheme/gschem/deprecated.scm
@@ -28,7 +28,11 @@
#:use-module (gschem window)
#:use-module (gschem hook)
#:use-module (gschem selection)
- #:use-module (gschem attrib))
+ #:use-module (gschem attrib)
+
+ #:use-module (geda deprecated)
+
+ #:use-module (srfi srfi-1))
;; add-attribute-to-object object name value visible show
;;
@@ -149,6 +153,67 @@
(reverse! (filter! pin? (component-contents object)))
'()))
+;; get-object-bounds object exclude-attribs exclude-types
+;;
+;; Return the bounds of an object, excluding attributes with
+;; particular names or certain object types.
+;;
+;; The exclude-attribs should be a list of attribute names to be
+;; omitted, as strings. If the special string "all" appears in the
+;; list, all attributes are excluded.
+;;
+;; The exclude-types should be a list of single-character strings
+;; containing object type characters (as returned by the deprecated
+;; get-object-type function).
+;;
+;; Note that attributes attached to pins (but not attached to anything
+;; else) are included in the bounds.
+;;
+;; The bounds are returned in the form:
+;;
+;; ((left . right) . (bottom . top))
+;;
+;; N.b. that this is a different form to that returned by
+;; object-bounds, so you can't use fold-bounds directly with bounds
+;; returned by this function.
+(define-public (get-object-bounds object exclude-attribs exclude-types)
+ (define no-attribs (member "all" exclude-attribs))
+
+ (define (exclude? object)
+ (or
+ ;; Is it an excluded type?
+ (member (string (get-object-type object)) exclude-types)
+ ;; Is it invisible text?
+ (and (text? object) (not (text-visible? object)))
+ ;; Is it an excluded attribute?
+ (and (attribute? object)
+ (or no-attribs
+ (member (attrib-name object) exclude-attribs)))))
+
+ (define (excluding-bounds object)
+ (cond
+ ;; If it's excluded, no bounds!
+ ((exclude? object) #f)
+ ;; If it's a component, recurse
+ ((component? object)
+ (fold fold-bounds #f
+ (map excluding-bounds (component-contents object))))
+ ;; If it's a pin, include its attributes
+ ((pin? object)
+ (fold fold-bounds #f
+ (cons (object-bounds object)
+ (map excluding-bounds (object-attribs object)))))
+ ;; Otherwise, just return the object bounds
+ (else (object-bounds object))))
+
+ (let ((bounds (excluding-bounds object)))
+ (if bounds
+ ;; Re-arrange the bounds into the format expected
+ (cons (cons (caar bounds) (cadr bounds))
+ (cons (cddr bounds) (cdar bounds)))
+ ;; Stupid default
+ '((1000000 . 0) . (1000000 . 0)))))
+
;; get-pin-ends pin
;;
;; Return the coordinates of the endpoints of a pin, in the format:
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index 1470381..2b3280b 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -38,259 +38,6 @@ SCM_SYMBOL (core_sym, "core");
SCM_SYMBOL (hook_sym, "hook");
SCM_SYMBOL (run_hook_sym, "run-hook");
-/* Private function declarations */
-static void custom_world_get_single_object_bounds
- (TOPLEVEL *toplevel, OBJECT *o_current,
- int *left, int *top,
- int *right, int *bottom,
- GList *exclude_attrib_list,
- GList *exclude_obj_type_list);
-
-static void custom_world_get_object_glist_bounds
- (TOPLEVEL *toplevel, GList *list,
- int *left, int *top,
- int *right, int *bottom,
- GList *exclude_attrib_list,
- GList *exclude_obj_type_list);
-
-/*! \brief Get the object bounds of the given object, excluding the object
- * types given as parameters.
- * \par Function Description
- * Get the object bounds without considering the attributes in
- * exclude_attrib_list, neither the object types included in
- * exclude_obj_type_list
- * \param [in] toplevel TOPLEVEL structure.
- * \param [in] o_current The object we want to know the bounds of.
- * \param [in] exclude_attrib_list A list with the attribute names we don't
- * want to include when calculing the bounds.
- * \param [in] exclude_obj_type_list A list with the object types we don't
- * want to include when calculing the bounds.
- * The object types are those used in (OBJECT *)->type converted into strings.
- * \param [out] left Left bound of the object.
- * \param [out] top Top bound of the object.
- * \param [out] right Right bound of the object.
- * \param [out] bottom Bottom bound of the object.
- *
- */
-static void custom_world_get_single_object_bounds
- (TOPLEVEL *toplevel, OBJECT *o_current,
- int *left, int *top,
- int *right, int *bottom,
- GList *exclude_attrib_list,
- GList *exclude_obj_type_list) {
- OBJECT *obj_ptr = NULL;
- OBJECT *a_current;
- GList *a_iter;
- int rleft, rright, rbottom, rtop;
- char *name_ptr, aux_ptr[2];
- gboolean include_text;
-
- *left = rleft = toplevel->init_right;
- *top = rtop = toplevel->init_bottom;;
- *right = *bottom = rright = rbottom = 0;
-
- obj_ptr = o_current;
- sprintf(aux_ptr, "%c", obj_ptr->type);
- include_text = TRUE;
- if (!g_list_find_custom(exclude_obj_type_list, aux_ptr,
- (GCompareFunc) &strcmp)) {
-
- switch(obj_ptr->type) {
- case (OBJ_PIN):
- world_get_single_object_bounds (toplevel, obj_ptr,
- &rleft, &rtop, &rright, &rbottom);
- break;
- case (OBJ_TEXT):
- if (o_attrib_get_name_value (obj_ptr, &name_ptr, NULL) &&
- g_list_find_custom (exclude_attrib_list, name_ptr, (GCompareFunc) &strcmp)) {
- include_text = FALSE;
- }
- if (g_list_find_custom (exclude_attrib_list, "all",
- (GCompareFunc) &strcmp)) {
- include_text = FALSE;
- }
- if (include_text) {
- world_get_single_object_bounds (toplevel, obj_ptr,
- &rleft, &rtop, &rright, &rbottom);
- }
- g_free(name_ptr);
- break;
- case (OBJ_COMPLEX):
- case (OBJ_PLACEHOLDER):
- custom_world_get_object_glist_bounds (toplevel,
- o_current->complex->prim_objs,
- left, top, right, bottom,
- exclude_attrib_list,
- exclude_obj_type_list);
- break;
-
- default:
- world_get_single_object_bounds (toplevel, obj_ptr,
- &rleft, &rtop, &rright, &rbottom);
- break;
- }
-
- if (rleft < *left) *left = rleft;
- if (rtop < *top) *top = rtop;
- if (rright > *right) *right = rright;
- if (rbottom > *bottom) *bottom = rbottom;
-
- /* If it's a pin object, check the pin attributes */
- if (obj_ptr->type == OBJ_PIN) {
- a_iter = obj_ptr->attribs;
- while (a_iter != NULL) {
- a_current = a_iter->data;
-
- if (a_current->type == OBJ_TEXT) {
- custom_world_get_single_object_bounds(toplevel,
- a_current,
- &rleft, &rtop,
- &rright, &rbottom,
- exclude_attrib_list,
- exclude_obj_type_list);
- if (rleft < *left) *left = rleft;
- if (rtop < *top) *top = rtop;
- if (rright > *right) *right = rright;
- if (rbottom > *bottom) *bottom = rbottom;
- }
-
- a_iter = g_list_next (a_iter);
- }
- }
- }
-}
-
-static void custom_world_get_object_glist_bounds
- (TOPLEVEL *toplevel, GList *list,
- int *left, int *top,
- int *right, int *bottom,
- GList *exclude_attrib_list,
- GList *exclude_obj_type_list) {
-
- OBJECT *o_current;
- GList *iter;
- int rleft, rtop, rright, rbottom;
-
- *left = rleft = 999999;
- *top = rtop = 9999999;
- *right = rright = 0;
- *bottom = rbottom = 0;
-
-
- iter = list;
-
- while (iter != NULL) {
- o_current = (OBJECT *)iter->data;
- custom_world_get_single_object_bounds (toplevel, o_current, &rleft, &rtop,
- &rright, &rbottom,
- exclude_attrib_list,
- exclude_obj_type_list);
- if (rleft < *left) *left = rleft;
- if (rtop < *top) *top = rtop;
- if (rright > *right) *right = rright;
- if (rbottom > *bottom) *bottom = rbottom;
-
- iter = g_list_next (iter);
- }
-}
-
-static void
-free_string_glist(void *data)
-{
- GList *iter, *glst = *((GList **) data);
-
- for (iter = glst; iter != NULL; iter = g_list_next (iter)) {
- free (iter->data);
- }
- g_list_free (glst);
-}
-
-/*! \brief Get the object bounds of the given object, excluding the object
- * types or the attributes given as parameters.
- * \par Function Description
- * Get the object bounds without considering the attributes in
- * scm_exclude_attribs, neither the object types included in
- * scm_exclude_object_type
- * \param [in] object_smob The object we want to know the bounds of.
- * \param [in] scm_exclude_attribs A list with the attribute names we don't
- * want to include when calculing the bounds.
- * \param [in] scm_exclude_object_type A list with the object types we don't
- * want to include when calculing the bounds.
- * The object types are those used in (OBJECT *)->type converted into strings.
- * \return a list of the bounds of the <B>object smob</B>.
- * The list has the format: ( (left right) (top bottom) )
- * WARNING: top and bottom are mis-named in world-coords,
- * top is the smallest "y" value, and bottom is the largest.
- * Be careful! This doesn't correspond to what you'd expect,
- * nor to the coordinate system who's origin is the bottom, left of the page.
- */
-SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclude_object_type)
-{
-
- TOPLEVEL *toplevel=edascm_c_current_toplevel ();
- OBJECT *object=NULL;
- int left=0, right=0, bottom=0, top=0;
- SCM returned = SCM_EOL;
- SCM vertical = SCM_EOL;
- SCM horizontal = SCM_EOL;
- GList *exclude_attrib_list = NULL, *exclude_obj_type_list = NULL;
- gboolean exclude_all_attribs = FALSE;
- int i;
-
- SCM_ASSERT (scm_list_p(scm_exclude_attribs), scm_exclude_attribs,
- SCM_ARG2, "get-object-bounds");
- SCM_ASSERT (scm_list_p(scm_exclude_object_type), scm_exclude_object_type,
- SCM_ARG3, "get-object-bounds");
-
- /* Build the exclude attrib list */
- scm_dynwind_begin(0);
- scm_dynwind_unwind_handler(free_string_glist, (void *) &exclude_attrib_list, 0);
- scm_dynwind_unwind_handler(free_string_glist, (void *) &exclude_obj_type_list, 0);
-
- for (i=0; i <= scm_to_int(scm_length(scm_exclude_attribs))-1; i++) {
- SCM elem = scm_list_ref(scm_exclude_attribs, scm_from_int(i));
-
- SCM_ASSERT (scm_is_string(elem), scm_exclude_attribs, SCM_ARG2, "get-object-bounds");
- exclude_attrib_list = g_list_append(exclude_attrib_list, scm_to_utf8_string(elem));
- }
-
- /* Build the exclude object type list */
- for (i=0; i <= scm_to_int(scm_length(scm_exclude_object_type))-1; i++) {
- SCM elem = scm_list_ref(scm_exclude_object_type, scm_from_int(i));
-
- SCM_ASSERT (scm_is_string(elem), scm_exclude_object_type, SCM_ARG3, "get-object-bounds");
- exclude_obj_type_list = g_list_append(exclude_obj_type_list, scm_to_utf8_string(elem));
- }
-
- scm_dynwind_end();
-
- /* Get toplevel and o_current. */
- object = edascm_to_object (object_smob);
-
- SCM_ASSERT (toplevel && object,
- object_smob, SCM_ARG1, "get-object-bounds");
-
- if (g_list_find_custom(exclude_attrib_list, "all", (GCompareFunc) &strcmp))
- exclude_all_attribs = TRUE;
-
- custom_world_get_single_object_bounds (toplevel, object,
- &left, &top,
- &right, &bottom,
- exclude_attrib_list,
- exclude_obj_type_list);
-
- /* Free the exclude attrib_list. Don't free the nodes!! */
- g_list_free(exclude_attrib_list);
-
- /* Free the exclude attrib_list. Don't free the nodes!! */
- g_list_free(exclude_obj_type_list);
-
- horizontal = scm_cons (scm_from_int(left), scm_from_int(right));
- vertical = scm_cons (scm_from_int(top), scm_from_int(bottom));
- returned = scm_cons (horizontal, vertical);
- return (returned);
-}
-
/*! \brief Gets a Scheme hook object by name.
* \par Function Description
* Returns the contents of variable with the given name in the (gschem
diff --git a/gschem/src/g_register.c b/gschem/src/g_register.c
index 3464101..a053a0f 100644
--- a/gschem/src/g_register.c
+++ b/gschem/src/g_register.c
@@ -330,7 +330,5 @@ void g_register_funcs (void)
}
/* Hook stuff */
- scm_c_define_gsubr ("get-object-bounds", 3, 0, 0, g_get_object_bounds);
-
complex_place_list_changed_hook = create_hook ("complex-place-list-changed-hook", 1);
}
commit 22a146a4a8a221908ab531aafc1d901a3358c133
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Document object-bounds and add fold-bounds.
Fold-bounds is a function for combining two bounds as returned by the
object-bounds function.
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index cc35975..99fb777 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -37,8 +37,6 @@
(define-public copy-object %copy-object)
-(define-public object-bounds %object-bounds)
-
(define-public object-color %object-color)
(define-public set-object-color! %set-object-color!)
@@ -672,3 +670,33 @@
(define-public object-fill %object-fill)
(define-public set-object-fill! %set-object-fill!)
+
+;;;; Object bounds
+
+;; object-bounds object [object...]
+;;
+;; Return the bounds containing one or more objects. The bounds
+;; returned are in world coordinates, and are given in the form:
+;;
+;; ((left . top) . (right . bottom))
+;;
+;; Note that this function always returns the actual bounds of the
+;; objects, not the visible bounds.
+(define-public object-bounds %object-bounds)
+
+;; fold-bounds a b
+;;
+;; Calculate the bounds of the smallest rectangle containing both the
+;; bounds a and b, which should be bounds as returned by
+;; object-bounds. If either a or b is #f, it is ignored; if both are
+;; #f, #f is returned.
+(define-public (fold-bounds a b)
+ (if (and a b)
+ ;; calc bounds
+ (cons (cons (min (caar a) (caar b)) ; left
+ (max (cdar a) (cdar b))) ; top
+ (cons (max (cadr a) (cadr b)) ; right
+ (min (cddr a) (cddr b)))) ; bottom
+
+ ;; return whichever isn't #f
+ (or a b)))
commit 0f7d19313b0a8e2ecd7d4a5ea24ee6e0ab243d60
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Remove unused g_make_attrib_smob_list().
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index fd1ead8..86f0dee 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -33,7 +33,6 @@ SCM g_funcs_browse_wiki(SCM wikiname);
SCM g_funcs_use_rc_values(void);
SCM get_selected_component_attributes(GSCHEM_TOPLEVEL *w_current);
/* g_hook.c */
-SCM g_make_attrib_smob_list(GSCHEM_TOPLEVEL *w_current, OBJECT *object);
SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclude_object_type);
void g_init_hook ();
void g_run_hook_object (const char *name, OBJECT *obj);
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index ff10aa9..1470381 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -53,44 +53,6 @@ static void custom_world_get_object_glist_bounds
GList *exclude_attrib_list,
GList *exclude_obj_type_list);
-/*! \todo Finish function documentation!!!
- * \brief
- * \par Function Description
- *
- */
-/* Makes a list of all attributes currently connected to object.
- * Uses the attribute list returned by o_attrib_return_attribs()
- */
-SCM g_make_attrib_smob_list (GSCHEM_TOPLEVEL *w_current, OBJECT *object)
-{
- GList *attrib_list;
- GList *a_iter;
- OBJECT *a_current;
- SCM smob_list = SCM_EOL;
-
- if (object == NULL) {
- return SCM_EOL;
- }
-
- attrib_list = o_attrib_return_attribs (object);
-
- if (attrib_list == NULL)
- return SCM_EOL;
-
- /* go through attribs */
- for (a_iter = attrib_list; a_iter != NULL;
- a_iter = g_list_next (a_iter)) {
- a_current = a_iter->data;
-
- smob_list = scm_cons (edascm_from_object (a_current),
- smob_list);
- }
-
- g_list_free (attrib_list);
-
- return smob_list;
-}
-
/*! \brief Get the object bounds of the given object, excluding the object
* types given as parameters.
* \par Function Description
commit 6b3c4f7f52f684e10c08ef478e341b954032c94b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Reimplement set-attribute-text-properties! in Scheme.
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index 0113de0..fd1ead8 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -34,10 +34,6 @@ SCM g_funcs_use_rc_values(void);
SCM get_selected_component_attributes(GSCHEM_TOPLEVEL *w_current);
/* g_hook.c */
SCM g_make_attrib_smob_list(GSCHEM_TOPLEVEL *w_current, OBJECT *object);
-SCM
-g_set_attrib_text_properties(SCM attrib_smob, SCM scm_colorname, SCM scm_size,
- SCM scm_alignment, SCM scm_rotation, SCM scm_x,
- SCM scm_y);
SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclude_object_type);
void g_init_hook ();
void g_run_hook_object (const char *name, OBJECT *obj);
diff --git a/gschem/scheme/gschem/deprecated.scm b/gschem/scheme/gschem/deprecated.scm
index 0182554..67443aa 100644
--- a/gschem/scheme/gschem/deprecated.scm
+++ b/gschem/scheme/gschem/deprecated.scm
@@ -48,6 +48,63 @@
(v 'value)
(else 'both))))) ;; Default
+;; set-attribute-text-properties! attrib color size alignment
+;; rotation x y
+;;
+;; Sets several parameters of the text object attrib. x and y are the
+;; coordinates of the text anchor. color is the colormap index of the
+;; color with which to draw the text. size is the font size, and
+;; angle is the angle at which to draw the text.
+;;
+;; All of the former parameters may be set to -1 to leave the current
+;; value unchanged.
+;;
+;; alignment should be one of the following strings:
+;;
+;; "Lower Left"
+;; "Middle Left"
+;; "Upper Left"
+;; "Lower Middle"
+;; "Middle Middle"
+;; "Upper Middle"
+;; "Lower Right"
+;; "Middle Right"
+;; "Upper Right"
+;;
+;; or the empty string "" to leave the alignment unchanged.
+(define-public (set-attribute-text-properties!
+ attrib color size alignment rotation x y)
+ (set-text! attrib
+ ;; anchor
+ (let ((anchor (text-anchor attrib)))
+ (cons (if (= x -1) (car anchor) x)
+ (if (= y -1) (cdr anchor) y)))
+ ;; align
+ (or
+ (assoc-ref
+ '(("Lower Left" . lower-left)
+ ("Middle Left" . middle-left)
+ ("Upper Left" . upper-left)
+ ("Lower Middle" . lower-center)
+ ("Middle Middle" . middle-center)
+ ("Upper Middle" . upper-center)
+ ("Lower Right" . lower-right)
+ ("Middle Right" . middle-right)
+ ("Upper Right" . upper-right))
+ alignment)
+ (and (string=? "" alignment) (text-align attrib))
+ (error "Invalid text alignment ~A." alignment))
+ ;; angle
+ (if (= rotation -1) (text-angle attrib) rotation)
+ ;; string
+ (text-string attrib)
+ ;; size
+ (if (= size -1) (text-size attrib) size)
+ ;; visible
+ (text-visible? attrib)
+ ;; show
+ (text-attribute-mode attrib)))
+
;; add-component-at-xy page basename x y angle selectable mirror
;;
;; Adds the component called basename from the component library to a
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index bcb11ad..ff10aa9 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -91,130 +91,6 @@ SCM g_make_attrib_smob_list (GSCHEM_TOPLEVEL *w_current, OBJECT *object)
return smob_list;
}
-/*! \todo Finish function documentation!!!
- * \brief
- * \par Function Description
- *
- */
-/*
- * Sets several text properties of the given <B>attribute smob</B>:
- - <B>coloridx</B>: The index of the text color, or -1 to keep previous color.
- - <B>size</B>: Size (numeric) of the text, or -1 to keep the previous size.
- - <B>alignment</B>: String with the alignment of the text. Possible values are:
- * "" : Keep the previous alignment.
- * "Lower Left"
- * "Middle Left"
- * "Upper Left"
- * "Lower Middle"
- * "Middle Middle"
- * "Upper Middle"
- * "Lower Right"
- * "Middle Right"
- * "Upper Right"
- - <B>rotation</B>: Angle of the text, or -1 to keep previous angle.
- - <B>x</B>, <B>y</B>: Coords of the text.
- */
-SCM g_set_attrib_text_properties(SCM attrib_smob, SCM scm_coloridx,
- SCM scm_size, SCM scm_alignment,
- SCM scm_rotation, SCM scm_x, SCM scm_y)
-{
- OBJECT *object = edascm_to_object (attrib_smob);
- GSCHEM_TOPLEVEL *w_current = g_current_window ();
- TOPLEVEL *toplevel = w_current->toplevel;
-
- int color = -1;
- int size = -1;
- char *alignment_string;
- int alignment = -2;
- int rotation = 0;
- int x = -1, y = -1;
-
- SCM_ASSERT (scm_is_integer(scm_coloridx), scm_coloridx,
- SCM_ARG2, "set-attribute-text-properties!");
- SCM_ASSERT ( scm_is_integer(scm_size),
- scm_size, SCM_ARG3, "set-attribute-text-properties!");
- SCM_ASSERT (scm_is_string(scm_alignment), scm_alignment,
- SCM_ARG4, "set-attribute-text-properties!");
- SCM_ASSERT ( scm_is_integer(scm_rotation),
- scm_rotation, SCM_ARG5, "set-attribute-text-properties!");
- SCM_ASSERT ( scm_is_integer(scm_x),
- scm_x, SCM_ARG6, "set-attribute-text-properties!");
- SCM_ASSERT ( scm_is_integer(scm_y),
- scm_y, SCM_ARG7, "set-attribute-text-properties!");
-
- color = scm_to_int(scm_coloridx);
-
- SCM_ASSERT (!(color < -1 || color >= MAX_COLORS),
- scm_coloridx, SCM_ARG2, "set-attribute-text-properties!");
-
- size = scm_to_int(scm_size);
- rotation = scm_to_int(scm_rotation);
- x = scm_to_int(scm_x);
- y = scm_to_int(scm_y);
-
- alignment_string = scm_to_utf8_string(scm_alignment);
-
- if (strlen(alignment_string) == 0) {
- alignment = -1;
- }
- if (strcmp(alignment_string, "Lower Left") == 0) {
- alignment = 0;
- }
- if (strcmp(alignment_string, "Middle Left") == 0) {
- alignment = 1;
- }
- if (strcmp(alignment_string, "Upper Left") == 0) {
- alignment = 2;
- }
- if (strcmp(alignment_string, "Lower Middle") == 0) {
- alignment = 3;
- }
- if (strcmp(alignment_string, "Middle Middle") == 0) {
- alignment = 4;
- }
- if (strcmp(alignment_string, "Upper Middle") == 0) {
- alignment = 5;
- }
- if (strcmp(alignment_string, "Lower Right") == 0) {
- alignment = 6;
- }
- if (strcmp(alignment_string, "Middle Right") == 0) {
- alignment = 7;
- }
- if (strcmp(alignment_string, "Upper Right") == 0) {
- alignment = 8;
- }
-
- free(alignment_string);
-
- if (alignment == -2) {
- /* Bad specified */
- SCM_ASSERT (scm_is_string(scm_alignment), scm_alignment,
- SCM_ARG4, "set-attribute-text-properties!");
- }
-
- if (object &&
- object->text) {
- if (x != -1) {
- object->text->x = x;
- }
- if (y != -1) {
- object->text->y = y;
- }
- if (size != -1) {
- object->text->size = size;
- }
- if (alignment != -1) {
- object->text->alignment = alignment;
- }
- if (rotation != -1) {
- object->text->angle = rotation;
- }
- o_text_recreate(toplevel, object);
- }
- return SCM_BOOL_T;
-}
-
/*! \brief Get the object bounds of the given object, excluding the object
* types given as parameters.
* \par Function Description
diff --git a/gschem/src/g_register.c b/gschem/src/g_register.c
index b7c4aa7..3464101 100644
--- a/gschem/src/g_register.c
+++ b/gschem/src/g_register.c
@@ -331,7 +331,6 @@ void g_register_funcs (void)
/* Hook stuff */
scm_c_define_gsubr ("get-object-bounds", 3, 0, 0, g_get_object_bounds);
- scm_c_define_gsubr ("set-attribute-text-properties!", 7, 0, 0, g_set_attrib_text_properties);
complex_place_list_changed_hook = create_hook ("complex-place-list-changed-hook", 1);
}
commit 0b9ce5de9589b09ec35cdf321f5ac8540f81daa1
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Reimplement get-selected-component-attributes in Scheme.
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index 0c49354..0113de0 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -190,7 +190,6 @@ SCM g_keys_misc3(SCM rest);
SCM g_keys_help_about(SCM rest);
SCM g_keys_help_hotkeys(SCM rest);
SCM g_keys_cancel(SCM rest);
-SCM g_get_selected_component_attributes(void);
/* g_rc.c */
void g_rc_parse_gtkrc();
SCM g_rc_gschem_version(SCM version);
diff --git a/gschem/scheme/gschem/deprecated.scm b/gschem/scheme/gschem/deprecated.scm
index ea61d7e..0182554 100644
--- a/gschem/scheme/gschem/deprecated.scm
+++ b/gschem/scheme/gschem/deprecated.scm
@@ -108,6 +108,15 @@
(define-public (get-selected-filename)
(page-filename (active-page)))
+;; get-selected-component-attributes
+;;
+;; Returns a list of all selected text object strings, with duplicate
+;; values removed (i.e. the name is pretty much unrelated to the
+;; behaviour). Really, seriously, just don't use this in new code.
+(define-public (get-selected-component-attributes)
+ (delete-duplicates!
+ (map text-string (filter! text? (page-selection (active-page))))))
+
;;;; Old-style hooks
;; Adds a function to src-hook. The function is called with a single
diff --git a/gschem/src/g_funcs.c b/gschem/src/g_funcs.c
index 296a2bd..a4cf5e6 100644
--- a/gschem/src/g_funcs.c
+++ b/gschem/src/g_funcs.c
@@ -273,60 +273,6 @@ SCM g_funcs_use_rc_values(void)
return SCM_BOOL_T;
}
-/*! \todo Finish function documentation!!!
- * \brief
- * \par Function Description
- *
- */
-/*
- * Gets names from all objects of current page which selected-flags are true.
- */
-/* all of the declaration part is copied from some other c-code of
- * gEDA gschem.
- * I don't really know, whether this all are necessary or not, but
- * it works :-). */
-static void
-hash_table_2_list (gpointer key,
- gpointer value,
- gpointer user_data)
-{
- SCM *plist = (SCM*)user_data;
- *plist = scm_cons (scm_from_utf8_string ((char*)value), *plist);
-}
-
-/*! \todo Finish function documentation!!!
- * \brief
- * \par Function Description
- *
- */
-SCM get_selected_component_attributes(GSCHEM_TOPLEVEL *w_current)
-{
- SCM list = SCM_EOL;
- OBJECT *obj;
- GHashTable *ht;
- const GList *iter;
-
- /* build a hash table */
- ht = g_hash_table_new (g_str_hash, g_str_equal);
- for (iter = s_page_objects (w_current->toplevel->page_current);
- iter != NULL;
- iter = g_list_next (iter)) {
- obj = (OBJECT *)iter->data;
- if (obj->selected && obj->type == OBJ_TEXT) {
- const gchar *str = o_text_get_string (w_current->toplevel, obj);
- if (str == NULL) continue;
- /* add text string in the hash table */
- g_hash_table_insert (ht, (gchar *) str, (gchar *) str);
- }
- }
- /* now create a scheme list of the entries in the hash table */
- g_hash_table_foreach (ht, hash_table_2_list, &list);
- /* and get ride of the hast table */
- g_hash_table_destroy (ht);
-
- return list;
-}
-
/*! \brief Use gschemdoc to open a browser to a specific wiki page
*
* \param [in] wikiname the name of the wiki page
diff --git a/gschem/src/g_keys.c b/gschem/src/g_keys.c
index 3ba67e8..55344b3 100644
--- a/gschem/src/g_keys.c
+++ b/gschem/src/g_keys.c
@@ -395,13 +395,3 @@ DEFINE_G_KEYS(help_hotkeys)
being called with a null, I suppose we should call it with the right param.
hack */
DEFINE_G_KEYS(cancel)
-
-/*! \todo Finish function documentation!!!
- * \brief
- * \par Function Description
- *
- */
-SCM g_get_selected_component_attributes(void)
-{
- return (get_selected_component_attributes(g_current_window ()));
-}
diff --git a/gschem/src/g_register.c b/gschem/src/g_register.c
index 454c947..b7c4aa7 100644
--- a/gschem/src/g_register.c
+++ b/gschem/src/g_register.c
@@ -296,9 +296,6 @@ static struct gsubr_t gschem_funcs[] = {
{ "misc-misc3", 0, 0, 0, g_keys_misc3 },
{ "cancel", 0, 0, 0, g_keys_cancel },
- /*help functions for generating netlists*/
- { "get-selected-component-attributes", 0, 0, 0, g_get_selected_component_attributes },
-
{ NULL, 0, 0, 0, NULL } };
/*! \brief Define a hook.
commit c761f0ed17f915369143bcf180eafbf52076e1ae
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Reimplement add-component-at-xy in Scheme.
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index c7d2968..0c49354 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -39,8 +39,6 @@ g_set_attrib_text_properties(SCM attrib_smob, SCM scm_colorname, SCM scm_size,
SCM scm_alignment, SCM scm_rotation, SCM scm_x,
SCM scm_y);
SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclude_object_type);
-SCM g_add_component(SCM page_smob, SCM scm_comp_name, SCM scm_x, SCM scm_y,
- SCM scm_angle, SCM scm_selectable, SCM scm_mirror);
void g_init_hook ();
void g_run_hook_object (const char *name, OBJECT *obj);
void g_run_hook_object_list (const char *name, GList *obj_lst);
diff --git a/gschem/scheme/gschem/deprecated.scm b/gschem/scheme/gschem/deprecated.scm
index f8f0b1e..ea61d7e 100644
--- a/gschem/scheme/gschem/deprecated.scm
+++ b/gschem/scheme/gschem/deprecated.scm
@@ -48,6 +48,21 @@
(v 'value)
(else 'both))))) ;; Default
+;; add-component-at-xy page basename x y angle selectable mirror
+;;
+;; Adds the component called basename from the component library to a
+;; page, at the coordinates (x, y) and rotated by the given angle. If
+;; selectable is false, the component will be locked. If mirror is
+;; true, the component will be mirrored.
+(define-public (add-component-at-xy page basename x y angle selectable mirror)
+ (if (or (null? basename) (not basename) (string=? basename ""))
+ #f
+ (let ((C (make-component/library basename
+ (cons x y) angle mirror
+ (not selectable))))
+ (page-append! page C)
+ (run-hook add-objects-hook (cons C (promote-attribs! C))))))
+
;; set-attribute-value! attrib value
;;
;; Set the value part of the text object attrib.
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index d5735ee..bcb11ad 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -453,99 +453,6 @@ SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclu
return (returned);
}
-/*! \brief Add a component to the page.
- * \par Function Description
- * Adds a component <B>scm_comp_name</B> to the schematic, at
- * position (<B>scm_x</B>, <B>scm_y</B>), with some properties set by
- * the parameters:
- * \param [in,out] page_smob Schematic page
- * \param [in] scm_comp_name Component to be added
- * \param [in] scm_x Coordinate X of the symbol.
- * \param [in] scm_y Coordinate Y of the symbol.
- * \param [in] scm_angle Angle of rotation of the symbol.
- * \param [in] scm_selectable True if the symbol is selectable, false otherwise.
- * \param [in] scm_mirror True if the symbol is mirrored, false otherwise.
- * If scm_comp_name is a scheme empty list, SCM_BOOL_F, or an empty
- * string (""), then g_add_component returns SCM_BOOL_F without writing
- * to the log.
- * \return TRUE if the component was added, FALSE otherwise.
- *
- */
-SCM g_add_component(SCM page_smob, SCM scm_comp_name, SCM scm_x, SCM scm_y,
- SCM scm_angle, SCM scm_selectable, SCM scm_mirror)
-{
- TOPLEVEL *toplevel = edascm_c_current_toplevel ();
- PAGE *page;
- gboolean selectable, mirror;
- gchar *comp_name;
- int x, y, angle;
- OBJECT *new_obj;
- GList *added_objects = NULL;
- const CLibSymbol *clib;
-
- /* Return if scm_comp_name is NULL (an empty list) or scheme's FALSE */
- if (SCM_NULLP(scm_comp_name) ||
- (SCM_BOOLP(scm_comp_name) && !(SCM_NFALSEP(scm_comp_name))) ) {
- return SCM_BOOL_F;
- }
-
- /* Get toplevel and the page */
- SCM_ASSERT (edascm_is_page (page_smob),
- page_smob, SCM_ARG1, "add-component-at-xy");
- page = edascm_to_page (page_smob);
-
- /* Check the arguments */
- SCM_ASSERT (scm_is_string(scm_comp_name), scm_comp_name,
- SCM_ARG2, "add-component-at-xy");
- SCM_ASSERT ( scm_is_integer(scm_x), scm_x,
- SCM_ARG3, "add-component-at-xy");
- SCM_ASSERT ( scm_is_integer(scm_y), scm_y,
- SCM_ARG4, "add-component-at-xy");
- SCM_ASSERT ( scm_is_integer(scm_angle), scm_angle,
- SCM_ARG5, "add-component-at-xy");
- SCM_ASSERT ( scm_boolean_p(scm_selectable), scm_selectable,
- SCM_ARG6, "add-component-at-xy");
- SCM_ASSERT ( scm_boolean_p(scm_mirror), scm_mirror,
- SCM_ARG7, "add-component-at-xy");
-
- /* Get the parameters */
- x = scm_to_int(scm_x);
- y = scm_to_int(scm_y);
- angle = scm_to_int(scm_angle);
- selectable = SCM_NFALSEP(scm_selectable);
- mirror = SCM_NFALSEP(scm_mirror);
- comp_name = scm_to_utf8_string(scm_comp_name);
-
- scm_dynwind_begin(0);
- scm_dynwind_free(comp_name);
-
- SCM_ASSERT (comp_name, scm_comp_name,
- SCM_ARG2, "add-component-at-xy");
-
- if (strcmp(comp_name, "") == 0) {
- return SCM_BOOL_F;
- }
-
- clib = s_clib_get_symbol_by_name (comp_name);
-
- new_obj = o_complex_new (toplevel, 'C', DEFAULT_COLOR, x, y, angle, mirror,
- clib, comp_name, selectable);
-
- added_objects = o_complex_promote_attribs (toplevel, new_obj);
- s_page_append_list (toplevel, page,
- g_list_copy (added_objects));
- s_page_append (toplevel, page, new_obj);
-
- scm_dynwind_end();
-
- /* Run the add-objects-hook for the new component & attributes */
- added_objects = g_list_prepend (added_objects, new_obj);
- g_run_hook_object_list ("%add-objects-hook", added_objects);
- g_list_free (added_objects);
-
- return SCM_BOOL_T;
-}
-
/*! \brief Gets a Scheme hook object by name.
* \par Function Description
* Returns the contents of variable with the given name in the (gschem
diff --git a/gschem/src/g_register.c b/gschem/src/g_register.c
index 18fc1c9..454c947 100644
--- a/gschem/src/g_register.c
+++ b/gschem/src/g_register.c
@@ -335,7 +335,6 @@ void g_register_funcs (void)
/* Hook stuff */
scm_c_define_gsubr ("get-object-bounds", 3, 0, 0, g_get_object_bounds);
scm_c_define_gsubr ("set-attribute-text-properties!", 7, 0, 0, g_set_attrib_text_properties);
- scm_c_define_gsubr ("add-component-at-xy", 7, 0, 0, g_add_component);
complex_place_list_changed_hook = create_hook ("complex-place-list-changed-hook", 1);
}
commit 1cd1b3ecf56c183c6b7fd6cd968574f4a3f9c8eb
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Reimplement add-attribute-to-object in Scheme.
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index ee6bfeb..c7d2968 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -34,8 +34,6 @@ SCM g_funcs_use_rc_values(void);
SCM get_selected_component_attributes(GSCHEM_TOPLEVEL *w_current);
/* g_hook.c */
SCM g_make_attrib_smob_list(GSCHEM_TOPLEVEL *w_current, OBJECT *object);
-SCM g_add_attrib(SCM object, SCM attrib_name,
- SCM attrib_value, SCM scm_vis, SCM scm_show);
SCM
g_set_attrib_text_properties(SCM attrib_smob, SCM scm_colorname, SCM scm_size,
SCM scm_alignment, SCM scm_rotation, SCM scm_x,
diff --git a/gschem/scheme/gschem/deprecated.scm b/gschem/scheme/gschem/deprecated.scm
index d517526..f8f0b1e 100644
--- a/gschem/scheme/gschem/deprecated.scm
+++ b/gschem/scheme/gschem/deprecated.scm
@@ -27,7 +27,26 @@
#:use-module (geda attrib)
#:use-module (gschem window)
#:use-module (gschem hook)
- #:use-module (gschem selection))
+ #:use-module (gschem selection)
+ #:use-module (gschem attrib))
+
+;; add-attribute-to-object object name value visible show
+;;
+;; Add an attribute "name=value" to object. If visible is #f, the new
+;; attribute will be invisible. show should be a list containing one
+;; or both of the strings "name and "value" (if neither is specified,
+;; both are assumed).
+;;
+;; See also add-attrib! in the (gschem attrib) module.
+(define-public (add-attribute-to-object object name value visible show)
+ (add-attrib! object name value visible
+ (let ((n (member "name" show))
+ (v (member "value" show)))
+ (cond
+ ((and n v) 'both)
+ (n 'name)
+ (v 'value)
+ (else 'both))))) ;; Default
;; set-attribute-value! attrib value
;;
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index 13f1217..d5735ee 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -97,105 +97,6 @@ SCM g_make_attrib_smob_list (GSCHEM_TOPLEVEL *w_current, OBJECT *object)
*
*/
/*
- * Adds an attribute <B>scm_attrib_name</B> with value <B>scm_attrib_value</B> to the given <B>object</B>.
-The attribute has the visibility <B>scm_vis</B> and show <B>scm_show</B> flags.
-The possible values are:
- - <B>scm_vis</B>: scheme boolean. Visible (TRUE) or hidden (FALSE).
- - <B>scm_show</B>: a list containing what to show: "name", "value", or both.
-The return value is always TRUE.
- */
-SCM g_add_attrib(SCM object, SCM scm_attrib_name,
- SCM scm_attrib_value, SCM scm_vis, SCM scm_show)
-{
- GSCHEM_TOPLEVEL *w_current = g_current_window ();
- OBJECT *o_current=NULL;
- gboolean vis;
- int show=0;
- gchar *attrib_name=NULL;
- gchar *attrib_value=NULL;
- gchar *value=NULL;
- int i;
- gchar *newtext=NULL;
-
- SCM_ASSERT (scm_is_string(scm_attrib_name), scm_attrib_name,
- SCM_ARG2, "add-attribute-to-object");
- SCM_ASSERT (scm_is_string(scm_attrib_value), scm_attrib_value,
- SCM_ARG3, "add-attribute-to-object");
- SCM_ASSERT (scm_boolean_p(scm_vis), scm_vis,
- SCM_ARG4, "add-attribute-to-object");
- SCM_ASSERT (scm_list_p(scm_show), scm_show,
- SCM_ARG5, "add-attribute-to-object");
-
- /* Get toplevel and o_current */
- SCM_ASSERT (edascm_is_object (object),
- object, SCM_ARG1, "add-attribute-to-object");
- o_current = edascm_to_object (object);
-
- scm_dynwind_begin(0);
-
- /* Get parameters */
- attrib_name = scm_to_utf8_string(scm_attrib_name);
- scm_dynwind_free(attrib_name);
-
- attrib_value = scm_to_utf8_string(scm_attrib_value);
- scm_dynwind_free(attrib_value);
-
- vis = SCM_NFALSEP(scm_vis);
-
- for (i=0; i<=scm_to_int(scm_length(scm_show))-1; i++) {
- /* Check every element in the list. It should be a string! */
- SCM_ASSERT(scm_list_ref(scm_show, scm_from_int(i)),
- scm_show,
- SCM_ARG5, "add-attribute-to-object");
- SCM_ASSERT(scm_is_string(scm_list_ref(scm_show, scm_from_int(i))),
- scm_show,
- SCM_ARG5, "add-attribute-to-object");
-
- scm_dynwind_begin(0);
-
- value = scm_to_utf8_string(scm_list_ref(scm_show, scm_from_int(i)));
- scm_dynwind_free(value);
-
- SCM_ASSERT(value, scm_show,
- SCM_ARG5, "add-attribute-to-object");
-
- /* Only "name" or "value" strings are allowed */
- SCM_ASSERT(!((strcasecmp(value, "name") != 0) &&
- (strcasecmp(value, "value") != 0) ), scm_show,
- SCM_ARG5, "add-attribute-to-object");
-
- /* show = 1 => show value;
- show = 2 => show name;
- show = 3 => show both */
- if (strcasecmp(value, "value") == 0) {
- show |= 1;
- }
- else if (strcasecmp(value, "name") == 0) {
- show |= 2;
- }
-
- scm_dynwind_end();
- }
- /* Show name and value (show = 3) => show=0 for gschem */
- if (show == 3) {
- show = 0;
- }
-
- newtext = g_strdup_printf("%s=%s", attrib_name, attrib_value);
- o_attrib_add_attrib (w_current, newtext, vis, show, o_current);
- g_free(newtext);
-
- scm_dynwind_end();
- return SCM_BOOL_T;
-
-}
-
-/*! \todo Finish function documentation!!!
- * \brief
- * \par Function Description
- *
- */
-/*
* Sets several text properties of the given <B>attribute smob</B>:
- <B>coloridx</B>: The index of the text color, or -1 to keep previous color.
- <B>size</B>: Size (numeric) of the text, or -1 to keep the previous size.
diff --git a/gschem/src/g_register.c b/gschem/src/g_register.c
index fbc1b1c..18fc1c9 100644
--- a/gschem/src/g_register.c
+++ b/gschem/src/g_register.c
@@ -333,7 +333,6 @@ void g_register_funcs (void)
}
/* Hook stuff */
- scm_c_define_gsubr ("add-attribute-to-object", 5, 0, 0, g_add_attrib);
scm_c_define_gsubr ("get-object-bounds", 3, 0, 0, g_get_object_bounds);
scm_c_define_gsubr ("set-attribute-text-properties!", 7, 0, 0, g_set_attrib_text_properties);
scm_c_define_gsubr ("add-component-at-xy", 7, 0, 0, g_add_component);
commit 4feb90789ff1394465d2d6b8a5556da2c1462a14
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Improve documentation comments in Scheme code.
diff --git a/gschem/scheme/gschem/deprecated.scm b/gschem/scheme/gschem/deprecated.scm
index 9013b8a..d517526 100644
--- a/gschem/scheme/gschem/deprecated.scm
+++ b/gschem/scheme/gschem/deprecated.scm
@@ -29,22 +29,40 @@
#:use-module (gschem hook)
#:use-module (gschem selection))
+;; set-attribute-value! attrib value
+;;
+;; Set the value part of the text object attrib.
(define-public (set-attribute-value! attrib value)
(let ((params (text-info attrib))
(name-value (attrib-parse attrib)))
(list-set! params 3 (simple-format "~A=~A" (car name-value) value))
(apply set-text! attrib params)))
+;; get-objects-in-page page
+;;
+;; Get the contents of page, in reverse order.
(define-public (get-objects-in-page page)
(reverse! (page-contents page)))
+;; get-current-page
+;;
+;; Return the page which currently has focus in gschem.
(define-public get-current-page active-page)
+;; get-object-pins object
+;;
+;; Return the pin objects from a component's contents, in reverse
+;; order, or the empty list if object is not a component.
(define-public (get-object-pins object)
(if (component? object)
(reverse! (filter! pin? (component-contents object)))
'()))
+;; get-pin-ends pin
+;;
+;; Return the coordinates of the endpoints of a pin, in the format:
+;;
+;; ((x1 . y1) x2 . y2)
(define-public (get-pin-ends pin)
(let ((params (line-info pin)))
(cons (list-ref params 0) (list-ref params 1))))
commit c5ec85006694d354462680339dbd67499ad1f0a2
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Reimplement get-selected-filename in Scheme.
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index 7fe76a7..ee6bfeb 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -32,7 +32,6 @@ SCM g_funcs_filesel(SCM msg, SCM templ, SCM flags);
SCM g_funcs_browse_wiki(SCM wikiname);
SCM g_funcs_use_rc_values(void);
SCM get_selected_component_attributes(GSCHEM_TOPLEVEL *w_current);
-SCM get_selected_filename(GSCHEM_TOPLEVEL *w_current);
/* g_hook.c */
SCM g_make_attrib_smob_list(GSCHEM_TOPLEVEL *w_current, OBJECT *object);
SCM g_add_attrib(SCM object, SCM attrib_name,
@@ -195,7 +194,6 @@ SCM g_keys_misc3(SCM rest);
SCM g_keys_help_about(SCM rest);
SCM g_keys_help_hotkeys(SCM rest);
SCM g_keys_cancel(SCM rest);
-SCM g_get_selected_filename(void);
SCM g_get_selected_component_attributes(void);
/* g_rc.c */
void g_rc_parse_gtkrc();
diff --git a/gschem/scheme/gschem/deprecated.scm b/gschem/scheme/gschem/deprecated.scm
index 2017a5f..9013b8a 100644
--- a/gschem/scheme/gschem/deprecated.scm
+++ b/gschem/scheme/gschem/deprecated.scm
@@ -49,6 +49,13 @@
(let ((params (line-info pin)))
(cons (list-ref params 0) (list-ref params 1))))
+;; get-selected-filename
+;;
+;; Returns the filename associated with the active page in the current
+;; gschem window.
+(define-public (get-selected-filename)
+ (page-filename (active-page)))
+
;;;; Old-style hooks
;; Adds a function to src-hook. The function is called with a single
diff --git a/gschem/src/g_funcs.c b/gschem/src/g_funcs.c
index 400df9e..296a2bd 100644
--- a/gschem/src/g_funcs.c
+++ b/gschem/src/g_funcs.c
@@ -327,26 +327,6 @@ SCM get_selected_component_attributes(GSCHEM_TOPLEVEL *w_current)
return list;
}
-/*! \todo Finish function documentation!!!
- * \brief Get selected filename of current schematic.
- * \par Function Description
- * This function gets the whole filename of the current schematic.
- * Specifically, the <B>page_filename</B> of the current page.
- *
- * \param [in] w_current The GSCHEM_TOPLEVEL object to get filename from.
- * \return whole filename of current schematic.
- */
-SCM get_selected_filename(GSCHEM_TOPLEVEL *w_current)
-{
- SCM return_value;
-
- exit_if_null(w_current);
-
- return_value = scm_take0str (w_current->toplevel->page_current->page_filename);
-
- return(return_value);
-}
-
/*! \brief Use gschemdoc to open a browser to a specific wiki page
*
* \param [in] wikiname the name of the wiki page
diff --git a/gschem/src/g_keys.c b/gschem/src/g_keys.c
index 58961ec..3ba67e8 100644
--- a/gschem/src/g_keys.c
+++ b/gschem/src/g_keys.c
@@ -396,18 +396,6 @@ being called with a null, I suppose we should call it with the right param.
hack */
DEFINE_G_KEYS(cancel)
-
-/*! \todo Finish function documentation!!!
- * \brief
- * \par Function Description
- *
- */
-/*help for generate-netlist hot key*/
-SCM g_get_selected_filename(void)
-{
- return (get_selected_filename(g_current_window ()));
-}
-
/*! \todo Finish function documentation!!!
* \brief
* \par Function Description
diff --git a/gschem/src/g_register.c b/gschem/src/g_register.c
index c214b7c..fbc1b1c 100644
--- a/gschem/src/g_register.c
+++ b/gschem/src/g_register.c
@@ -297,7 +297,6 @@ static struct gsubr_t gschem_funcs[] = {
{ "cancel", 0, 0, 0, g_keys_cancel },
/*help functions for generating netlists*/
- { "get-selected-filename", 0, 0, 0, g_get_selected_filename },
{ "get-selected-component-attributes", 0, 0, 0, g_get_selected_component_attributes },
{ NULL, 0, 0, 0, NULL } };
commit 0a5ccba701c23e0dadee78e908e9f8f09c590340
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add some more tests for copy-object.
Add two tests for copy-object: whether copying an object breaks page,
component and attribute relationships, and whether copying a component
is a deep copy.
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 2be9762..ab946b0 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -19,6 +19,7 @@ TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0016-object-bounds.scm \
unit-tests/t0017-object-stroke-fill.scm \
unit-tests/t0018-object-connections.scm \
+ unit-tests/t0019-object-copy.scm \
unit-tests/t0020-page.scm \
unit-tests/t0021-page-dirty.scm \
unit-tests/t0030-attribute.scm \
diff --git a/libgeda/scheme/unit-tests/t0019-object-copy.scm b/libgeda/scheme/unit-tests/t0019-object-copy.scm
new file mode 100644
index 0000000..ed57a57
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0019-object-copy.scm
@@ -0,0 +1,45 @@
+;; Test object copying
+
+(use-modules (unit-test))
+(use-modules (geda object))
+(use-modules (geda page))
+(use-modules (geda attrib))
+(use-modules (srfi srfi-1))
+
+;; This test verifies that if an object is copied, any links to
+;; containing pages, containing components are removed, and any
+;; attribute attachments are broken.
+(begin-test 'copy-object-breaks-links
+ (let ((P (make-page "/test/page/A"))
+ (A (make-component "test component" '(0 . 0) 0 #t #f))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (x (make-text '(1 . 2) 'lower-left 0 "name=x" 10 #t 'both)))
+
+ (page-append! P A x)
+
+ (assert-equal P (object-page x))
+ (assert-equal #f (object-page (copy-object x)))
+
+ (attach-attrib! A x)
+
+ (assert-equal A (attrib-attachment x))
+ (assert-equal #f (attrib-attachment (copy-object x)))
+
+ (detach-attrib! A x)
+ (page-remove! P x)
+ (component-append! A p x)
+
+ (assert-equal A (object-component x))
+ (assert-equal #f (object-component (copy-object x)))
+
+ (attach-attrib! p x)
+ (assert-equal p (attrib-attachment x))
+ (assert-equal #f (attrib-attachment (copy-object x)))))
+
+;; This test checks that copies of components are deep copies.
+(begin-test 'copy-object-deep-component
+ (let* ((A (make-component "test component" '(0 . 0) 0 #t #f))
+ (p (make-net-pin '(0 . 0) '(100 . 0))))
+ (component-append! A p)
+ (assert-equal (list p) (member p (component-contents A)))
+ (assert-equal #f (member p (component-contents (copy-object A))))))
commit 292c930244a9616642ade8a3afd4cc740c61d368
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add attrib-inherited? function.
diff --git a/libgeda/scheme/geda/attrib.scm b/libgeda/scheme/geda/attrib.scm
index 5a77984..17c9866 100644
--- a/libgeda/scheme/geda/attrib.scm
+++ b/libgeda/scheme/geda/attrib.scm
@@ -93,3 +93,11 @@
y))
(promotable-attribs object))
#f)))
+
+;; attrib-inherited? attrib
+;;
+;; Returns #t if attrib is a toplevel un-attached attribute inside a
+;; component.
+(define-public (attrib-inherited? attrib)
+ (not (or (attrib-attachment attrib)
+ (not (object-component attrib)))))
diff --git a/libgeda/scheme/unit-tests/t0030-attribute.scm b/libgeda/scheme/unit-tests/t0030-attribute.scm
index 2c40ffc..03d29e4 100644
--- a/libgeda/scheme/unit-tests/t0030-attribute.scm
+++ b/libgeda/scheme/unit-tests/t0030-attribute.scm
@@ -152,3 +152,22 @@
(attach-attrib! p x)
(assert-equal (list y) (inherited-attribs C))))
+
+(begin-test 'attrib-inherited?
+ (let* ((P (make-page "/test/page/1"))
+ (A (make-component "test component" '(0 . 0) 0 #t #f))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (w (make-text '(1 . 2) 'lower-left 0 "name=x" 10 #t 'both))
+ (x (make-text '(1 . 2) 'lower-left 0 "name=x" 10 #t 'both))
+ (y (make-text '(1 . 2) 'lower-left 0 "name=y" 10 #t 'both))
+ (z (make-text '(1 . 2) 'lower-left 0 "name=z" 10 #t 'both)))
+
+ (page-append! P A w x)
+ (attach-attrib! A x)
+ (component-append! A p y z)
+ (attach-attrib! p y)
+
+ (assert-true (not (attrib-inherited? w)))
+ (assert-true (not (attrib-inherited? x)))
+ (assert-true (not (attrib-inherited? y)))
+ (assert-true (attrib-inherited? z))))
commit db3b79c7659a7526acf726c457b1c2915254fc4b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add object-component function.
Add a Scheme function for obtaining an object's containing component.
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 747d8f2..cc35975 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -44,6 +44,8 @@
(define-public object-connections %object-connections)
+(define-public object-component %object-complex)
+
;;;; Lines
;; line? x
diff --git a/libgeda/scheme/unit-tests/t0015-object-complex.scm b/libgeda/scheme/unit-tests/t0015-object-complex.scm
index 9d00441..6cdb240 100644
--- a/libgeda/scheme/unit-tests/t0015-object-complex.scm
+++ b/libgeda/scheme/unit-tests/t0015-object-complex.scm
@@ -171,3 +171,10 @@
;; Clear component library again
(reset-component-library)
+
+(begin-test 'object-component
+ (let* ((A (make-component "test component" '(0 . 0) 0 #t #f))
+ (x (make-box '(0 . 2) '(2 . 0))))
+ (assert-equal #f (object-component x))
+ (component-append! A x)
+ (assert-equal A (object-component x))))
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index 404abd2..a922494 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -1527,6 +1527,33 @@ SCM_DEFINE (object_connections, "%object-connections", 1, 0, 0,
return result;
}
+/*! \brief Get the complex object that contains an object.
+ * \par Function Description
+ * Returns the complex object that contains the object \a obj_s. If
+ * \a obj_s is not part of a component, returns SCM_BOOL_F.
+ *
+ * \note Scheme API: Implements the %object-complex procedure of the
+ * (geda core object) module.
+ *
+ * \param obj_s #OBJECT smob for object to get component of.
+ * \return the #OBJECT smob of the containing component, or SCM_BOOL_F.
+ */
+SCM_DEFINE (object_complex, "%object-complex", 1, 0, 0,
+ (SCM obj_s), "Get containing complex object of an object.")
+{
+ /* Ensure that the argument is an object smob */
+ SCM_ASSERT (edascm_is_object (obj_s), obj_s,
+ SCM_ARG1, s_object_complex);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+ OBJECT *parent = o_get_parent (toplevel, obj);
+
+ if (parent == NULL) return SCM_BOOL_F;
+
+ return edascm_from_object (parent);
+}
+
/*!
* \brief Create the (geda core object) Scheme module.
* \par Function Description
@@ -1551,7 +1578,7 @@ init_module_geda_core_object ()
s_make_circle, s_set_circle_x, s_circle_info,
s_make_arc, s_set_arc_x, s_arc_info,
s_make_text, s_set_text_x, s_text_info,
- s_object_connections,
+ s_object_connections, s_object_complex,
NULL);
}
commit 25952c382fc199fb91502279267c45f880a55cdd
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Correct import of (gschem core attrib) module.
diff --git a/gschem/scheme/gschem/attrib.scm b/gschem/scheme/gschem/attrib.scm
index 86dd4e1..c248128 100644
--- a/gschem/scheme/gschem/attrib.scm
+++ b/gschem/scheme/gschem/attrib.scm
@@ -19,7 +19,7 @@
(define-module (gschem attrib)
- #:use-module (gschem attrib))
+ #:use-module (gschem core attrib))
;; add-attrib! target name value visible attribute-mode
;;
commit 5cf897c1c107dc3d0b2e4ef82d1f15cbdeb76041
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Use missing.h to pull in SCM<->C string funcs.
diff --git a/gschem/src/g_attrib.c b/gschem/src/g_attrib.c
index bd447f2..9076c5d 100644
--- a/gschem/src/g_attrib.c
+++ b/gschem/src/g_attrib.c
@@ -24,6 +24,7 @@
*/
#include <config.h>
+#include <missing.h>
#include "gschem.h"
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index 42fe3c7..bb864c2 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -18,6 +18,8 @@
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
#include <config.h>
+#include <missing.h>
+
#include <stdio.h>
#ifdef HAVE_STRING_H
#include <string.h>
@@ -624,7 +626,7 @@ g_get_hook_by_name (const char *name)
{
SCM exp = scm_list_3 (at_sym,
scm_list_3 (gschem_sym, core_sym, hook_sym),
- scm_from_utf_symbol (name));
+ scm_from_utf8_symbol (name));
return g_scm_eval_protected (exp, SCM_UNDEFINED);
}
diff --git a/libgeda/include/libgedaguile_priv.h b/libgeda/include/libgedaguile_priv.h
index 607a5f7..ad8244d 100644
--- a/libgeda/include/libgedaguile_priv.h
+++ b/libgeda/include/libgedaguile_priv.h
@@ -24,6 +24,7 @@
* by Scheme API source files.
*/
+#include <missing.h>
#include <libgeda/libgedaguile.h>
void edascm_init_smob ();
commit 1a96308dcf365d4cad0de8373beb108c14dfeae2
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add add-attrib! function.
Add convenience Scheme API function in gschem to shadow the
o_attrib_add_attrib() C function. Although most of the behaviour of
this function could be provided in pure Scheme, it would be somewhat
annoying to have two lots of code which do the same thing. Also, the
slotting mess is still in C only.
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index db4901e..7fe76a7 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -18,6 +18,8 @@ void a_zoom_box_motion(GSCHEM_TOPLEVEL *w_current, int x, int y);
void a_zoom_box_invalidate_rubber(GSCHEM_TOPLEVEL *w_current);
void a_zoom_box_draw_rubber(GSCHEM_TOPLEVEL *w_current);
void correct_aspect(GSCHEM_TOPLEVEL *w_current);
+/* g_attrib.c */
+void g_init_attrib ();
/* g_funcs.c */
SCM g_funcs_print(SCM filename);
SCM g_funcs_postscript(SCM filename);
diff --git a/gschem/scheme/Makefile.am b/gschem/scheme/Makefile.am
index 19e8812..53902d1 100644
--- a/gschem/scheme/Makefile.am
+++ b/gschem/scheme/Makefile.am
@@ -13,7 +13,8 @@ nobase_dist_scmdata_DATA = \
gschem/window.scm \
gschem/selection.scm \
gschem/deprecated.scm \
- gschem/hook.scm
+ gschem/hook.scm \
+ gschem/attrib.scm
MOSTLYCLEANFILES = *.log *~
CLEANFILES = *.log *~
diff --git a/gschem/scheme/gschem/attrib.scm b/gschem/scheme/gschem/attrib.scm
new file mode 100644
index 0000000..86dd4e1
--- /dev/null
+++ b/gschem/scheme/gschem/attrib.scm
@@ -0,0 +1,38 @@
+;; gEDA - GPL Electronic Design Automation
+;; gschem - gEDA Schematic Capture - Scheme API
+;; Copyright (C) 2011 Peter Brett
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+;;
+
+(define-module (gschem attrib)
+
+ #:use-module (gschem attrib))
+
+;; add-attrib! target name value visible attribute-mode
+;;
+;; Create a new attribute, either attached to a target object in the
+;; current page, or floating in the current page if target is #f. The
+;; name and value for the attribute must be strings, and if visible is
+;; #f, the attribute will be invisible. The attribute-mode controls
+;; which parts of the attribute will be visible, and must be one of
+;; the following symbols:
+;;
+;; name
+;; value
+;; both
+;;
+;; See also active-page in the (gschem window) module.
+(define-public add-attrib! %add-attrib!)
diff --git a/gschem/src/Makefile.am b/gschem/src/Makefile.am
index 3ef894f..5a1f118 100644
--- a/gschem/src/Makefile.am
+++ b/gschem/src/Makefile.am
@@ -1,6 +1,7 @@
bin_PROGRAMS = gschem
BUILT_SOURCES = \
+ g_attrib.x \
g_hook.x \
g_window.x \
g_select.x
@@ -8,6 +9,7 @@ BUILT_SOURCES = \
gschem_SOURCES = \
a_pan.c \
a_zoom.c \
+ g_attrib.c \
g_funcs.c \
g_hook.c \
g_keys.c \
diff --git a/gschem/src/g_attrib.c b/gschem/src/g_attrib.c
new file mode 100644
index 0000000..bd447f2
--- /dev/null
+++ b/gschem/src/g_attrib.c
@@ -0,0 +1,166 @@
+/* gEDA - GPL Electronic Design Automation
+ * gschem - gEDA Schematic Capture
+ * Copyright (C) 2011 Peter Brett <peter@xxxxxxxxxxxxx>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+/*!
+ * \file g_attrib.c
+ * \brief Scheme API functions for manipulating attributes in
+ * gschem-specific ways.
+ */
+
+#include <config.h>
+
+#include "gschem.h"
+
+SCM_SYMBOL (name_sym , "name");
+SCM_SYMBOL (value_sym , "value");
+SCM_SYMBOL (both_sym , "both");
+SCM_SYMBOL (object_state_sym, "object-state");
+
+/*! \brief Add an attribute to an object, or floating.
+ * \par Function Description
+ * Creates a new attribute, either attached to an object or floating.
+ *
+ * The \a name_s and \a value_s should be strings. If \a visible_s is
+ * false, the new attribute will be invisible; otherwise it will be
+ * visible. \a show_s determines which parts of an
+ * attribute-formatted string should be shown, and should be one of
+ * the symbols "name", "value" or "both".
+ *
+ * If \a target_s is specified and is a gEDA object, the new attribute
+ * will be attached to it. If \a target_s is not in gschem's active
+ * page, an "object-state" error will be raised.
+ *
+ * If \a target_s is #f, the new attribute will be floating in
+ * gschem's current active page.
+ *
+ * \note Scheme API: Implements the %add-attrib! procedure in the
+ * (gschem core attrib) module.
+ *
+ * \bug This function does not verify that \a name_s is actually a
+ * valid attribute name.
+ *
+ * \todo It would be nice to support pages other than the current
+ * active page.
+ *
+ * \param target_s where to attach the new attribute.
+ * \param name_s name for the new attribute.
+ * \param value_s value for the new attribute.
+ * \param visible_s visibility of the new attribute (true or false).
+ * \param show_s the attribute part visibility setting.
+ *
+ * \return the newly created text object.
+ */
+SCM_DEFINE (add_attrib_x, "%add-attrib!", 5, 0, 0,
+ (SCM target_s, SCM name_s, SCM value_s, SCM visible_s, SCM show_s),
+ "Add an attribute to an object, or floating")
+{
+ SCM_ASSERT ((edascm_is_page (target_s) ||
+ edascm_is_object (target_s) ||
+ scm_is_false (target_s)),
+ target_s, SCM_ARG1, s_add_attrib_x);
+ SCM_ASSERT (scm_is_string (name_s), name_s, SCM_ARG2, s_add_attrib_x);
+ SCM_ASSERT (scm_is_string (value_s), value_s, SCM_ARG3, s_add_attrib_x);
+ SCM_ASSERT (scm_is_symbol (show_s), show_s, SCM_ARG5, s_add_attrib_x);
+
+ GSCHEM_TOPLEVEL *w_current = g_current_window ();
+ TOPLEVEL *toplevel = w_current->toplevel;
+
+ /* Check target object, if present */
+ OBJECT *obj = NULL;
+ if (edascm_is_object (target_s)) {
+ obj = edascm_to_object (target_s);
+ if (o_get_page (toplevel, obj) != toplevel->page_current) {
+ scm_error (object_state_sym,
+ s_add_attrib_x,
+ _("Object ~A is not included in the current gschem page."),
+ scm_list_1 (target_s), SCM_EOL);
+ }
+ }
+
+ /* Visibility */
+ int visibility;
+ if (scm_is_false (visible_s)) {
+ visibility = INVISIBLE;
+ } else {
+ visibility = VISIBLE;
+ }
+
+ /* Name/value visibility */
+ int show;
+ if (show_s == name_sym) { show = SHOW_NAME; }
+ else if (show_s == value_sym) { show = SHOW_VALUE; }
+ else if (show_s == both_sym) { show = SHOW_NAME_VALUE; }
+ else {
+ scm_misc_error (s_add_attrib_x,
+ _("Invalid text name/value visibility ~A."),
+ scm_list_1 (show_s));
+ }
+
+
+ scm_dynwind_begin (0);
+
+ char *name;
+ name = scm_to_utf8_string (name_s);
+ scm_dynwind_free (name);
+
+ char *value;
+ value = scm_to_utf8_string (value_s);
+ scm_dynwind_free (value);
+
+ gchar *str = g_strdup_printf ("%s=%s", name, value);
+ scm_dynwind_unwind_handler (g_free, str, SCM_F_WIND_EXPLICITLY);
+
+ OBJECT *result = o_attrib_add_attrib (w_current, str, visibility, show, obj);
+
+ scm_dynwind_end ();
+
+ return edascm_from_object (result);
+}
+
+/*!
+ * \brief Create the (geda core object) Scheme module.
+ * \par Function Description
+ * Defines procedures in the (geda core object) module. The module can
+ * be accessed using (use-modules (geda core object)).
+ */
+static void
+init_module_gschem_core_attrib ()
+{
+ /* Register the functions and symbols */
+ #include "g_attrib.x"
+
+ /* Add them to the module's public definitions. */
+ scm_c_export (s_add_attrib_x, NULL);
+}
+
+/*!
+ * \brief Initialise the gschem attribute procedures.
+ * \par Function Description
+
+ * Registers some Scheme procedures for working with
+ * attributes. Should only be called by main_prog().
+ */
+void
+g_init_attrib ()
+{
+ /* Define the (gschem core attrib) module */
+ scm_c_define_module ("gschem core attrib",
+ init_module_gschem_core_attrib,
+ NULL);
+}
diff --git a/gschem/src/gschem.c b/gschem/src/gschem.c
index 2823cc4..ec3452a 100644
--- a/gschem/src/gschem.c
+++ b/gschem/src/gschem.c
@@ -197,6 +197,7 @@ void main_prog(void *closure, int argc, char *argv[])
g_init_window ();
g_init_select ();
g_init_hook ();
+ g_init_attrib ();
/* initialise color map (need to do this before reading rc files */
x_color_init ();
commit c603a85e1cdd63f770a19fb23d2fab49c14b3d0b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add promote-attribs! function.
Add a function to promote any promotable attributes from a component.
diff --git a/libgeda/scheme/geda/attrib.scm b/libgeda/scheme/geda/attrib.scm
index ba960c2..5a77984 100644
--- a/libgeda/scheme/geda/attrib.scm
+++ b/libgeda/scheme/geda/attrib.scm
@@ -1,6 +1,6 @@
;; gEDA - GPL Electronic Design Automation
;; libgeda - gEDA's library - Scheme API
-;; Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+;; Copyright (C) 2010-2011 Peter Brett <peter@xxxxxxxxxxxxx>
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -22,7 +22,8 @@
; Import C procedures
#:use-module (geda core attrib)
- #:use-module (geda object))
+ #:use-module (geda object)
+ #:use-module (geda page))
(define-public parse-attrib %parse-attrib)
(define-public object-attribs %object-attribs)
@@ -64,3 +65,31 @@
(filter! (lambda (x) (and (attribute? x) (not (attrib-attachment x))))
(component-contents object))
'()))
+
+;; promote-attribs! object
+;;
+;; Promotes any promotable attributes from an object into its current
+;; page, if object is a component, keeping the original attributes as
+;; invisible attributes inside the component. Returns a list of the
+;; objects that were added to the page. If object is not a component,
+;; returns the empty list. If object is not in a page, throws an
+;; object-state error.
+;;
+;; See also promotable-attribs.
+(define-public (promote-attribs! object)
+ (let ((p (or (object-page object)
+ (scm-error 'object-state #f
+ "Object ~A is not part of a page" (list object) #f))))
+ (if (component? object)
+ (map (lambda (x)
+ (let ((y (copy-object x)))
+ ;; Make original object invisible
+ (set-text-visibility! x #f)
+ ;; Append copy of the object to page
+ (page-append! p y)
+ ;; Attach it to object
+ (attach-attrib! object y)
+ ;; Return copy
+ y))
+ (promotable-attribs object))
+ #f)))
diff --git a/libgeda/scheme/unit-tests/t0031-promotable-attributes.scm b/libgeda/scheme/unit-tests/t0031-promotable-attributes.scm
index 5524fce..8f61f6a 100644
--- a/libgeda/scheme/unit-tests/t0031-promotable-attributes.scm
+++ b/libgeda/scheme/unit-tests/t0031-promotable-attributes.scm
@@ -12,3 +12,6 @@
;; [1] This is a good thing -- it shouldn't be necessary!
(begin-test 'promotable-attributes
(throw 'missing-unit-test "We can't test this at the moment"))
+
+(begin-test 'promote-attribs!
+ (throw 'missing-unit-test "We can't test this at the moment"))
commit cc1a3d0209a83aaa82404f41e42bb8a2c0c098b9
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add set-text-visibility! function.
Helper function for toggling visibility of a text object.
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index d819cc7..747d8f2 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -1,6 +1,6 @@
;; gEDA - GPL Electronic Design Automation
;; libgeda - gEDA's library - Scheme API
-;; Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+;; Copyright (C) 2010-2011 Peter Brett <peter@xxxxxxxxxxxxx>
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -507,6 +507,15 @@
(define-public (text-visible? t)
(list-ref (text-info t) 5))
+;; set-text-visibility! t visible
+;;
+;; If visible is #f, sets object t to be invisible; otherwise, sets t
+;; to be visible.
+(define-public (set-text-visibility! t visible)
+ (let ((i (text-info t)))
+ (list-set! i 5 (not (not visible)))
+ (apply set-text! t i)))
+
;; text-attribute-mode t
;;
;; Returns the visibility mode of the text object t when the string
diff --git a/libgeda/scheme/unit-tests/t0014-object-text.scm b/libgeda/scheme/unit-tests/t0014-object-text.scm
index 3808237..9f07edb 100644
--- a/libgeda/scheme/unit-tests/t0014-object-text.scm
+++ b/libgeda/scheme/unit-tests/t0014-object-text.scm
@@ -54,3 +54,19 @@
(assert-thrown 'misc-error
(set-text! a '(3 . 4) 'upper-right 1 "more text" 20 #f 'name))
))
+
+(begin-test 'set-text-visibility!
+ (let ((a (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21))
+ (b (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21)))
+ (assert-true (text-visible? a))
+
+ (set-text-visibility! a #f)
+ (assert-true (not (text-visible? a)))
+
+ (set-text-visibility! a #t)
+ (assert-true (text-visible? a))
+ (assert-equal (text-info a) (text-info b))
+
+ (set-text-visibility! a 'bork)
+ (assert-true (text-visible? a))
+ (assert-equal (text-info a) (text-info b))))
commit f5040254fe52ef181ff8bd205c33315b00e76c2c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Correct error messages from %set-text!
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index 1930d11..404abd2 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -1348,7 +1348,7 @@ SCM_DEFINE (set_text_x, "%set-text!", 10, 0, 0,
else {
scm_misc_error (s_set_text_x,
_("Invalid text alignment ~A."),
- scm_list_1 (angle_s));
+ scm_list_1 (align_s));
}
/* Angle */
@@ -1383,7 +1383,7 @@ SCM_DEFINE (set_text_x, "%set-text!", 10, 0, 0,
else {
scm_misc_error (s_set_text_x,
_("Invalid text name/value visibility ~A."),
- scm_list_1 (angle_s));
+ scm_list_1 (show_s));
}
/* Actually make changes */
commit 30bfe114148d52155ae96226dfcd22484f8629c7
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
build-sys: Remove unused separate guile-snarf macro file.
diff --git a/configure.ac b/configure.ac
index 406aa53..388a2d7 100644
--- a/configure.ac
+++ b/configure.ac
@@ -72,8 +72,6 @@ PKG_PROG_PKG_CONFIG
AX_CHECK_GUILE([1.8.0])
-AX_PROG_GUILE_SNARF
-
PKG_CHECK_MODULES(GLIB, [glib-2.0 >= 2.12.0], ,
AC_MSG_ERROR([GLib 2.12.0 or later is required.]))
diff --git a/m4/geda-guile-snarf.m4 b/m4/geda-guile-snarf.m4
deleted file mode 100644
index 0956a24..0000000
--- a/m4/geda-guile-snarf.m4
+++ /dev/null
@@ -1,33 +0,0 @@
-# geda-guile-snarf.m4 -*-Autoconf-*-
-# serial 1
-
-dnl Check for the `guile-snarf' build tool
-dnl Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
-dnl
-dnl This program is free software; you can redistribute it and/or modify
-dnl it under the terms of the GNU General Public License as published by
-dnl the Free Software Foundation; either version 2 of the License, or
-dnl (at your option) any later version.
-dnl
-dnl This program is distributed in the hope that it will be useful,
-dnl but WITHOUT ANY WARRANTY; without even the implied warranty of
-dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-dnl GNU General Public License for more details.
-dnl
-dnl You should have received a copy of the GNU General Public License
-dnl along with this program; if not, write to the Free Software
-dnl Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-
-AC_DEFUN([AX_PROG_GUILE_SNARF],
-[
- AC_PREREQ([2.60])dnl
-
- AC_ARG_VAR([GUILE_SNARF], [path to guile-snarf utility])
-
- AC_CHECK_PROGS([GUILE_SNARF], [guile-snarf guile-1.8-snarf], [no])
- if test "x$GUILE_SNARF" = xno ; then
- AC_MSG_ERROR([The `guile-snarf' tool could not be found. Please ensure that the
-Guile development headers and tools are correctly installed, and rerun
-configure.])
- fi
-])
commit 623341482a94b2f92e662dd8e9ff8f6a218f42cc
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Use UTF-8 instead of locale Scheme string functions.
See commit 09c6613f93b6.
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index 6f3c678..42fe3c7 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -624,7 +624,7 @@ g_get_hook_by_name (const char *name)
{
SCM exp = scm_list_3 (at_sym,
scm_list_3 (gschem_sym, core_sym, hook_sym),
- scm_from_locale_symbol (name));
+ scm_from_utf_symbol (name));
return g_scm_eval_protected (exp, SCM_UNDEFINED);
}
diff --git a/libgeda/src/scheme_attrib.c b/libgeda/src/scheme_attrib.c
index 6059b20..44dafb6 100644
--- a/libgeda/src/scheme_attrib.c
+++ b/libgeda/src/scheme_attrib.c
@@ -58,8 +58,8 @@ SCM_DEFINE (parse_attrib, "%parse-attrib", 1, 0, 0,
scm_dynwind_unwind_handler (g_free, value, SCM_F_WIND_EXPLICITLY);
if (o_attrib_get_name_value (text, &name, &value)) {
- result = scm_cons (scm_from_locale_string (name),
- scm_from_locale_string (value));
+ result = scm_cons (scm_from_utf8_string (name),
+ scm_from_utf8_string (value));
}
scm_dynwind_end ();
diff --git a/libgeda/src/scheme_complex.c b/libgeda/src/scheme_complex.c
index 643316c..016a8f6 100644
--- a/libgeda/src/scheme_complex.c
+++ b/libgeda/src/scheme_complex.c
@@ -43,7 +43,7 @@ SCM_DEFINE (make_complex, "%make-complex", 1, 0, 0,
{
SCM_ASSERT (scm_is_string (basename_s), basename_s, SCM_ARG1, s_make_complex);
- char *tmp = scm_to_locale_string (basename_s);
+ char *tmp = scm_to_utf8_string (basename_s);
OBJECT *obj = o_complex_new_embedded (edascm_c_current_toplevel (),
OBJ_COMPLEX, DEFAULT_COLOR, 0, 0, 0,
FALSE, tmp, TRUE);
@@ -81,7 +81,7 @@ SCM_DEFINE (make_complex_library, "%make-complex/library", 1, 0, 0,
SCM_ASSERT (scm_is_string (basename_s), basename_s, SCM_ARG1,
s_make_complex_library);
- char *basename = scm_to_locale_string (basename_s);
+ char *basename = scm_to_utf8_string (basename_s);
scm_dynwind_begin (0);
scm_dynwind_unwind_handler (free, basename, SCM_F_WIND_EXPLICITLY);
@@ -196,7 +196,7 @@ SCM_DEFINE (complex_info, "%complex-info", 1, 0, 0,
OBJECT *obj = edascm_to_object (complex_s);
- return scm_list_n (scm_from_locale_string (obj->complex_basename),
+ return scm_list_n (scm_from_utf8_string (obj->complex_basename),
scm_from_int (obj->complex->x),
scm_from_int (obj->complex->y),
scm_from_int (obj->complex->angle),
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index ee0283b..1930d11 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -105,8 +105,8 @@ edascm_to_object_glist (SCM objs, const char *subr)
EDASCM_ASSERT_SMOB_VALID (smob);
if (!EDASCM_OBJECTP (smob)) {
scm_error_scm (wrong_type_arg_sym,
- scm_from_locale_string (subr),
- scm_from_locale_string (_("Expected a gEDA object, found ~A")),
+ scm_from_utf8_string (subr),
+ scm_from_utf8_string (_("Expected a gEDA object, found ~A")),
scm_list_1 (smob), scm_list_1 (smob));
}
result = g_list_prepend (result, (gpointer) edascm_to_object (smob));
@@ -1400,7 +1400,7 @@ SCM_DEFINE (set_text_x, "%set-text!", 10, 0, 0,
o_emit_change_notify (toplevel, obj);
- char *tmp = scm_to_locale_string (string_s);
+ char *tmp = scm_to_utf8_string (string_s);
o_text_set_string (toplevel, obj, tmp);
free (tmp);
@@ -1484,7 +1484,7 @@ SCM_DEFINE (text_info, "%text-info", 1, 0, 0,
scm_from_int (obj->text->y),
align_s,
scm_from_int (obj->text->angle),
- scm_from_locale_string (o_text_get_string (toplevel, obj)),
+ scm_from_utf8_string (o_text_get_string (toplevel, obj)),
scm_from_int (obj->text->size),
visible_s,
show_s,
diff --git a/libgeda/src/scheme_page.c b/libgeda/src/scheme_page.c
index f866936..71a2139 100644
--- a/libgeda/src/scheme_page.c
+++ b/libgeda/src/scheme_page.c
@@ -76,7 +76,7 @@ SCM_DEFINE (new_page, "%new-page", 1, 0, 0,
SCM_ASSERT (scm_is_string (filename_s), filename_s,
SCM_ARG1, s_new_page);
- filename = scm_to_locale_string (filename_s);
+ filename = scm_to_utf8_string (filename_s);
page = s_page_new (toplevel, filename);
g_free (filename);
@@ -131,7 +131,7 @@ SCM_DEFINE (page_filename, "%page-filename", 1, 0, 0,
page = edascm_to_page (page_s);
- return scm_from_locale_string (page->page_filename);
+ return scm_from_utf8_string (page->page_filename);
}
/*! \brief Change the filename associated with a page.
@@ -154,7 +154,7 @@ SCM_DEFINE (set_page_filename_x, "%set-page-filename!", 2, 0, 0,
SCM_ARG2, s_set_page_filename_x);
PAGE *page = edascm_to_page (page_s);
- char *new_fn = scm_to_locale_string (filename_s);
+ char *new_fn = scm_to_utf8_string (filename_s);
if (page->page_filename != NULL) {
g_free (page->page_filename);
}
commit 4bccef20f38b43da0d9916f63601dec35fd5b33c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Better hook behaviour for "Select All".
Run select-objects-hook for all objects selected by the "Select All"
operation at once, not one at a time.
diff --git a/gschem/src/o_select.c b/gschem/src/o_select.c
index d1e38b0..585a85b 100644
--- a/gschem/src/o_select.c
+++ b/gschem/src/o_select.c
@@ -476,7 +476,9 @@ void
o_select_visible_unlocked (GSCHEM_TOPLEVEL *w_current)
{
TOPLEVEL *toplevel = w_current->toplevel;
+ SELECTION *selection = toplevel->page_current->selection_list;
const GList *iter;
+ GList *added;
o_select_unselect_all (w_current);
for (iter = s_page_objects (toplevel->page_current);
@@ -491,18 +493,22 @@ o_select_visible_unlocked (GSCHEM_TOPLEVEL *w_current)
/* Skip locked objects. */
if (!obj->selectable) continue;
- /* Run selection hooks & add object to selection. */
+ /* Add object to selection. */
/*! \bug We can't call o_select_object() because it
* behaves differently depending on the state of
* w_current->SHIFTKEY and w_current->CONTROLKEY, which may well
* be set if this function is called via a keystroke
* (e.g. Ctrl-A). */
- o_select_run_hooks (w_current, obj, 1);
- o_selection_add (toplevel, toplevel->page_current->selection_list, obj);
+ o_selection_add (toplevel, selection, obj);
/* Add any attributes of object to selection as well. */
- o_attrib_add_selected (w_current, toplevel->page_current->selection_list,
- obj);
+ o_attrib_add_selected (w_current, selection, obj);
+ }
+
+ /* Run hooks for all items selected */
+ added = geda_list_get_glist (selection);
+ if (added != NULL) {
+ g_run_hook_object_list ("%select-objects-hook", added);
}
}
commit 0d5ec53d5ce3baa3004bd1dbfea2f33c4d4abece
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Enable new-page-hook.
This varies slightly from the original behaviour, in that it is only
called when a *new* page is created (e.g. through File->New), and not
on page load.
diff --git a/gschem/include/globals.h b/gschem/include/globals.h
index a4348ee..07938ae 100644
--- a/gschem/include/globals.h
+++ b/gschem/include/globals.h
@@ -52,7 +52,6 @@ extern GList *object_buffer[MAX_BUFFERS];
/* Hooks */
extern SCM complex_place_list_changed_hook;
-extern SCM new_page_hook;
#include "gettext.h"
#ifdef ENABLE_NLS
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index 5d864c8..db4901e 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -45,6 +45,7 @@ SCM g_add_component(SCM page_smob, SCM scm_comp_name, SCM scm_x, SCM scm_y,
void g_init_hook ();
void g_run_hook_object (const char *name, OBJECT *obj);
void g_run_hook_object_list (const char *name, GList *obj_lst);
+void g_run_hook_page (const char *name, PAGE *page);
/* g_keys.c */
int g_keys_execute(GSCHEM_TOPLEVEL *w_current, int state, int keyval);
GArray *g_keys_dump_keymap (void);
diff --git a/gschem/lib/system-gschemrc.scm b/gschem/lib/system-gschemrc.scm
index 532f93b..f43eb5d 100644
--- a/gschem/lib/system-gschemrc.scm
+++ b/gschem/lib/system-gschemrc.scm
@@ -939,7 +939,7 @@
(use-modules (ice-9 regex))
(display "Your Guile installation doesn't provide the regex module.\n"))
-(add-hook! new-page-hook (lambda (page)
+(add-hook! (@ (gschem hook) new-page-hook) (lambda (page)
; Only place the titleblock if there are no objects in the page
; and the page filename ends in ".sym".
(if (and (null? (get-objects-in-page page))
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index 1757ad7..6f3c678 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -670,6 +670,22 @@ g_run_hook_object (const char *name, OBJECT *obj)
scm_remember_upto_here_1 (args);
}
+/*! \brief Runs a page hook.
+ * \par Function Description
+ * Runs a hook called \a name, which should expect the single #PAGE \a
+ * page as its argument.
+ *
+ * \param name name of hook to run
+ * \param page #PAGE argument for hook.
+ */
+void
+g_run_hook_page (const char *name, PAGE *page)
+{
+ SCM args = scm_list_1 (edascm_from_page (page));
+ scm_run_hook (g_get_hook_by_name (name), args);
+ scm_remember_upto_here_1 (args);
+}
+
/*! \brief Create the (gschem core hook) Scheme module.
* \par Function Description
* Defines some hooks in the (gschem core hook) module. These hooks
diff --git a/gschem/src/g_register.c b/gschem/src/g_register.c
index eaa0bec..c214b7c 100644
--- a/gschem/src/g_register.c
+++ b/gschem/src/g_register.c
@@ -339,6 +339,5 @@ void g_register_funcs (void)
scm_c_define_gsubr ("set-attribute-text-properties!", 7, 0, 0, g_set_attrib_text_properties);
scm_c_define_gsubr ("add-component-at-xy", 7, 0, 0, g_add_component);
- new_page_hook = create_hook ("new-page-hook", 1);
complex_place_list_changed_hook = create_hook ("complex-place-list-changed-hook", 1);
}
diff --git a/gschem/src/globals.c b/gschem/src/globals.c
index dc3ec51..8496cf2 100644
--- a/gschem/src/globals.c
+++ b/gschem/src/globals.c
@@ -51,4 +51,3 @@ GList *object_buffer[MAX_BUFFERS];
/* Hooks */
SCM complex_place_list_changed_hook;
-SCM new_page_hook;
diff --git a/gschem/src/x_window.c b/gschem/src/x_window.c
index 5a64606..d9f96e5 100644
--- a/gschem/src/x_window.c
+++ b/gschem/src/x_window.c
@@ -756,11 +756,12 @@ x_window_open_page (GSCHEM_TOPLEVEL *w_current, const gchar *filename)
if (!quiet_mode)
s_log_message (_("New file [%s]\n"),
toplevel->page_current->page_filename);
- }
- if (scm_is_false (scm_hook_empty_p (new_page_hook)))
- scm_run_hook (new_page_hook,
- scm_list_1 (edascm_from_page (page)));
+ scm_dynwind_begin (0);
+ g_dynwind_window (w_current);
+ g_run_hook_page ("%new-page-hook", toplevel->page_current);
+ scm_dynwind_end ();
+ }
a_zoom_extents (w_current,
s_page_objects (toplevel->page_current),
commit d8abb509c60de0fbd4c288ff7fa9c32c2448f1cf
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Enable select-objects-hook and deselect-objects-hook.
Not a brilliant implementation -- calls hooks one object at a time
even when a large number of objects are selected/deselected. But it
works.
diff --git a/gschem/include/globals.h b/gschem/include/globals.h
index c8244da..a4348ee 100644
--- a/gschem/include/globals.h
+++ b/gschem/include/globals.h
@@ -52,11 +52,6 @@ extern GList *object_buffer[MAX_BUFFERS];
/* Hooks */
extern SCM complex_place_list_changed_hook;
-extern SCM deselect_component_hook;
-extern SCM deselect_net_hook;
-extern SCM deselect_all_hook;
-extern SCM select_component_hook;
-extern SCM select_net_hook;
extern SCM new_page_hook;
#include "gettext.h"
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index 3be0560..5d864c8 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -682,7 +682,6 @@ void o_select_box_search(GSCHEM_TOPLEVEL *w_current);
void o_select_connected_nets(GSCHEM_TOPLEVEL *w_current, OBJECT* o_current);
OBJECT *o_select_return_first_object(GSCHEM_TOPLEVEL *w_current);
int o_select_selected(GSCHEM_TOPLEVEL *w_current);
-void o_select_unselect_list(GSCHEM_TOPLEVEL *w_current, SELECTION *selection);
void o_select_unselect_all(GSCHEM_TOPLEVEL *w_current);
void o_select_visible_unlocked(GSCHEM_TOPLEVEL *w_current);
void o_select_move_to_place_list(GSCHEM_TOPLEVEL *w_current);
diff --git a/gschem/scheme/gschem/deprecated.scm b/gschem/scheme/gschem/deprecated.scm
index 1dbf872..2017a5f 100644
--- a/gschem/scheme/gschem/deprecated.scm
+++ b/gschem/scheme/gschem/deprecated.scm
@@ -26,7 +26,8 @@
#:use-module (geda object)
#:use-module (geda attrib)
#:use-module (gschem window)
- #:use-module (gschem hook))
+ #:use-module (gschem hook)
+ #:use-module (gschem selection))
(define-public (set-attribute-value! attrib value)
(let ((params (text-info attrib))
@@ -175,3 +176,47 @@
(define-public move-component-hook (make-hook 1))
(add-hook!/full-attribs move-objects-hook move-component-hook component?)
+;; deselect-component-hook:
+;;
+;; Called each time a component is removed from the selection,
+;; except if the selection is cleared entirely. Argument is
+;; as select-component-hook.
+(define-public deselect-component-hook (make-hook 1))
+(add-hook!/full-attribs deselect-objects-hook deselect-component-hook
+ component?)
+
+;; deselect-net-hook:
+;;
+;; Called each time a net segment (n.b. *not* bus segment) is added to
+;; the selection. Argument is a list of all attributes of the
+;; net.
+(define-public deselect-net-hook (make-hook 1))
+(add-hook!/full-attribs deselect-objects-hook deselect-net-hook net?)
+
+;; deselect-all-hook:
+;;
+;; Called with the empty list as the argument each time the
+;; selection is emptied, even if the selection is already
+;; empty.
+(define-public deselect-all-hook (make-hook 1))
+(add-hook! deselect-objects-hook
+ (lambda (arg)
+ (if (and (not (null? deselect-all-hook))
+ (null? (page-selection (active-page))))
+ (run-hook deselect-all-hook '()))))
+
+;; select-component-hook:
+;;
+;; Called each time a component is added to the selection.
+;; Argument is a list of all attributes (inherited & promoted)
+;; of the component.
+(define-public select-component-hook (make-hook 1))
+(add-hook!/full-attribs select-objects-hook select-component-hook
+ component?)
+
+;; select-net-hook:
+;;
+;; Called each time a net segment (n.b. *not* bus segment) is
+;; added to the selection. Argument is the empty list.
+(define-public select-net-hook (make-hook 1))
+(add-hook!/full-attribs select-objects-hook select-net-hook net?)
diff --git a/gschem/src/g_register.c b/gschem/src/g_register.c
index 19c447b..eaa0bec 100644
--- a/gschem/src/g_register.c
+++ b/gschem/src/g_register.c
@@ -339,12 +339,6 @@ void g_register_funcs (void)
scm_c_define_gsubr ("set-attribute-text-properties!", 7, 0, 0, g_set_attrib_text_properties);
scm_c_define_gsubr ("add-component-at-xy", 7, 0, 0, g_add_component);
- deselect_component_hook = create_hook ("deselect-component-hook", 1);
- deselect_net_hook = create_hook ("deselect-net-hook", 1);
- deselect_all_hook = create_hook ("deselect-all-hook", 1);
- select_component_hook = create_hook ("select-component-hook", 1);
- select_net_hook = create_hook ("select-net-hook", 1);
-
new_page_hook = create_hook ("new-page-hook", 1);
complex_place_list_changed_hook = create_hook ("complex-place-list-changed-hook", 1);
}
diff --git a/gschem/src/globals.c b/gschem/src/globals.c
index 3c3f930..dc3ec51 100644
--- a/gschem/src/globals.c
+++ b/gschem/src/globals.c
@@ -51,9 +51,4 @@ GList *object_buffer[MAX_BUFFERS];
/* Hooks */
SCM complex_place_list_changed_hook;
-SCM deselect_component_hook;
-SCM deselect_net_hook;
-SCM deselect_all_hook;
-SCM select_component_hook;
-SCM select_net_hook;
SCM new_page_hook;
diff --git a/gschem/src/o_attrib.c b/gschem/src/o_attrib.c
index 7bab2d1..ae163c5 100644
--- a/gschem/src/o_attrib.c
+++ b/gschem/src/o_attrib.c
@@ -54,6 +54,7 @@ void o_attrib_add_selected(GSCHEM_TOPLEVEL *w_current, SELECTION *selection,
{
OBJECT *a_current;
GList *a_iter;
+ GList *selected_objects = NULL;
g_assert( selection != NULL );
@@ -62,8 +63,16 @@ void o_attrib_add_selected(GSCHEM_TOPLEVEL *w_current, SELECTION *selection,
a_current = a_iter->data;
/* make sure object isn't selected already */
- if (!a_current->selected)
+ if (!a_current->selected) {
o_selection_add (w_current->toplevel, selection, a_current);
+ selected_objects = g_list_prepend (selected_objects, a_current);
+ }
+ }
+
+ if (selected_objects != NULL) {
+ /* Run select-objects-hook */
+ g_run_hook_object_list ("%select-objects-hook", selected_objects);
+ g_list_free (selected_objects);
}
}
@@ -272,6 +281,7 @@ OBJECT *o_attrib_add_attrib(GSCHEM_TOPLEVEL *w_current,
/* Call add-objects-hook. */
g_run_hook_object ("%add-objects-hook", new_obj);
+ g_run_hook_object ("%select-objects-hook", new_obj);
toplevel->page_current->CHANGED = 1;
diff --git a/gschem/src/o_select.c b/gschem/src/o_select.c
index 95a8a13..d1e38b0 100644
--- a/gschem/src/o_select.c
+++ b/gschem/src/o_select.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -49,76 +49,17 @@
*/
void o_select_run_hooks(GSCHEM_TOPLEVEL *w_current, OBJECT *o_current, int flag)
{
- /*
- * Run the select_component_hook if the hook has been defined and we
- * are selecting a component. This will likely be used for cross probing
- * between schematics and PCB layout or schematics and simulation results.
- */
- if ( scm_is_false (scm_hook_empty_p (deselect_all_hook)) && flag == 2 )
- {
- scm_run_hook(deselect_all_hook,
- scm_cons (g_make_attrib_smob_list(w_current, o_current),
- SCM_EOL));
- }
-
- /*
- * Run the select_component_hook if the hook has been defined and we
- * are selecting a component. This will likely be used for cross probing
- * between schematics and PCB layout or schematics and simulation results.
- */
- if ( scm_is_false (scm_hook_empty_p (select_component_hook))
- && o_current
- && (o_current->type == OBJ_COMPLEX)
- && flag == 1 )
- {
- scm_run_hook(select_component_hook,
- scm_cons (g_make_attrib_smob_list(w_current, o_current),
- SCM_EOL));
- }
-
- /*
- * Run the deselect_component_hook if the hook has been defined and we
- * are deselecting a component. This will likely be used for cross probing
- * between schematics and PCB layout or schematics and simulation results.
- */
- if ( scm_is_false (scm_hook_empty_p(deselect_component_hook))
- && o_current
- && (o_current->type == OBJ_COMPLEX)
- && flag == 0 )
- {
- scm_run_hook(deselect_component_hook,
- scm_cons (g_make_attrib_smob_list(w_current, o_current),
- SCM_EOL));
- }
-
- /*
- * Run the select_net_hook if the hook has been defined and we
- * are selecting a net. This will likely be used for cross probing
- * between schematics and PCB layout or schematics and simulation results.
- */
- if ( scm_is_false (scm_hook_empty_p (select_net_hook))
- && o_current
- && (o_current->type == OBJ_NET)
- && flag == 1)
- {
- scm_run_hook(select_net_hook,
- scm_cons (g_make_attrib_smob_list(w_current, o_current),
- SCM_EOL));
- }
-
- /*
- * Run the deselect_net_hook if the hook has been defined and we
- * are deselecting a net. This will likely be used for cross probing
- * between schematics and PCB layout or schematics and simulation results.
- */
- if ( scm_is_false (scm_hook_empty_p (select_net_hook))
- && o_current
- && (o_current->type == OBJ_NET)
- && flag == 0)
- {
- scm_run_hook(deselect_net_hook,
- scm_cons (g_make_attrib_smob_list(w_current, o_current),
- SCM_EOL));
+ switch (flag) {
+ /* If flag == 0, then we are deselecting something. */
+ case 0:
+ g_run_hook_object ("%deselect-objects-hook", o_current);
+ break;
+ /* If flag == 1, then we are selecting something. */
+ case 1:
+ g_run_hook_object ("%select-objects-hook", o_current);
+ break;
+ default:
+ g_assert_not_reached ();
}
}
@@ -162,8 +103,7 @@ void o_select_object(GSCHEM_TOPLEVEL *w_current, OBJECT *o_current,
/* condition: for both multiple and single object added */
/* result: remove all objects from selection */
if (count == 0 && !CONTROLKEY) {
- o_select_run_hooks( w_current, NULL, 2 );
- o_select_unselect_list( w_current, toplevel->page_current->selection_list );
+ o_select_unselect_all(w_current);
}
break;
@@ -202,8 +142,7 @@ void o_select_object(GSCHEM_TOPLEVEL *w_current, OBJECT *o_current,
/* 1st result: remove all objects from selection */
/* 2nd result: add object to selection */
if (type == MULTIPLE && count == 0 && !CONTROLKEY) {
- o_select_run_hooks( w_current, NULL, 2 );
- o_select_unselect_list( w_current, toplevel->page_current->selection_list );
+ o_select_unselect_all (w_current);
o_select_run_hooks( w_current, o_current, 1 );
o_selection_add (toplevel,
@@ -215,8 +154,7 @@ void o_select_object(GSCHEM_TOPLEVEL *w_current, OBJECT *o_current,
/* 1st result: remove all objects from selection */
/* 2nd result: add object to selection list */
if (type == SINGLE && !CONTROLKEY) {
- o_select_run_hooks( w_current, NULL, 2 );
- o_select_unselect_list( w_current, toplevel->page_current->selection_list );
+ o_select_unselect_all (w_current);
o_select_run_hooks (w_current, o_current, 1);
o_selection_add (toplevel, toplevel->page_current->
@@ -376,8 +314,7 @@ void o_select_box_search(GSCHEM_TOPLEVEL *w_current)
/* zero, and you need to deselect anything remaining (unless the shift */
/* key was pressed */
if (count == 0 && !SHIFTKEY) {
- o_select_run_hooks( w_current, NULL, 2 );
- o_select_unselect_list( w_current, toplevel->page_current->selection_list );
+ o_select_unselect_all (w_current);
}
i_update_menus(w_current);
}
@@ -503,25 +440,6 @@ int o_select_selected(GSCHEM_TOPLEVEL *w_current)
}
-/*! \brief Unselects all the objects in the given list.
- * \par Unselects all objects in the given list, does the
- * needed work to make the objects visually unselected, and redraw them.
- * \param [in] w_current GSCHEM_TOPLEVEL struct.
- * \param [in] selection Pointer to the selection list
- */
-void o_select_unselect_list(GSCHEM_TOPLEVEL *w_current, SELECTION *selection)
-{
- const GList *list = geda_list_get_glist( selection );
-
- while ( list != NULL ) {
- o_selection_unselect (w_current->toplevel, (OBJECT *)list->data);
- list = g_list_next (list);
- }
-
- geda_list_remove_all( (GedaList *)selection );
-}
-
-
/*! \todo Finish function documentation!!!
* \brief
* \par Function Description
@@ -530,8 +448,20 @@ void o_select_unselect_list(GSCHEM_TOPLEVEL *w_current, SELECTION *selection)
void o_select_unselect_all(GSCHEM_TOPLEVEL *w_current)
{
TOPLEVEL *toplevel = w_current->toplevel;
- o_select_run_hooks( w_current, NULL, 2 );
- o_select_unselect_list( w_current, toplevel->page_current->selection_list );
+ SELECTION *selection = toplevel->page_current->selection_list;
+ GList *removed = NULL;
+ GList *iter;
+
+ removed = g_list_copy (geda_list_get_glist (selection));
+ for (iter = removed; iter != NULL; iter = g_list_next (iter)) {
+ o_selection_remove (toplevel, selection, (OBJECT *) iter->data);
+ }
+
+ /* Call hooks */
+ if (removed != NULL) {
+ g_run_hook_object_list ("%deselect-objects-hook", removed);
+ g_list_free (removed);
+ }
}
/*! \brief Selects all visible objects on the current page.
commit b4a75a6ebc480d866d2b268059de04cfcecff40f
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Enable attach-attribs-hook and detach-attribs-hook.
diff --git a/gschem/src/i_callbacks.c b/gschem/src/i_callbacks.c
index 851d021..f8db1bb 100644
--- a/gschem/src/i_callbacks.c
+++ b/gschem/src/i_callbacks.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -3055,6 +3055,7 @@ DEFINE_I_CALLBACK(attributes_attach)
GSCHEM_TOPLEVEL *w_current = (GSCHEM_TOPLEVEL*) data;
OBJECT *first_object;
GList *s_current;
+ GList *attached_objects = NULL;
exit_if_null(w_current);
@@ -3086,10 +3087,17 @@ DEFINE_I_CALLBACK(attributes_attach)
OBJECT *object = s_current->data;
if (object != NULL) {
o_attrib_attach (w_current->toplevel, object, first_object, TRUE);
+ attached_objects = g_list_prepend (attached_objects, object);
w_current->toplevel->page_current->CHANGED=1;
}
s_current = g_list_next(s_current);
}
+
+ if (attached_objects != NULL) {
+ g_run_hook_object_list ("%attach-attribs-hook", attached_objects);
+ g_list_free (attached_objects);
+ }
+
o_undo_savestate(w_current, UNDO_ALL);
}
@@ -3103,6 +3111,7 @@ DEFINE_I_CALLBACK(attributes_detach)
GSCHEM_TOPLEVEL *w_current = (GSCHEM_TOPLEVEL*) data;
GList *s_current;
OBJECT *o_current;
+ GList *detached_attribs = NULL;
exit_if_null(w_current);
@@ -3121,12 +3130,20 @@ DEFINE_I_CALLBACK(attributes_detach)
o_current = (OBJECT *) s_current->data;
if (o_current) {
if (o_current->attribs) {
+ detached_attribs = g_list_concat (g_list_copy (o_current->attribs),
+ detached_attribs);
o_attrib_detach_all (w_current->toplevel, o_current);
w_current->toplevel->page_current->CHANGED=1;
}
}
s_current = g_list_next(s_current);
}
+
+ if (detached_attribs != NULL) {
+ g_run_hook_object_list ("%detach-attribs-hook", detached_attribs);
+ g_list_free (detached_attribs);
+ }
+
o_undo_savestate(w_current, UNDO_ALL);
}
commit 228f6b55dc0d95e2a9695fc9cbb019099811524f
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Enable move-objects-hook and paste-objects-hook.
diff --git a/gschem/include/globals.h b/gschem/include/globals.h
index 23e9555..c8244da 100644
--- a/gschem/include/globals.h
+++ b/gschem/include/globals.h
@@ -52,8 +52,6 @@ extern GList *object_buffer[MAX_BUFFERS];
/* Hooks */
extern SCM complex_place_list_changed_hook;
-extern SCM copy_component_hook;
-extern SCM move_component_hook;
extern SCM deselect_component_hook;
extern SCM deselect_net_hook;
extern SCM deselect_all_hook;
diff --git a/gschem/scheme/gschem/deprecated.scm b/gschem/scheme/gschem/deprecated.scm
index ce86084..1dbf872 100644
--- a/gschem/scheme/gschem/deprecated.scm
+++ b/gschem/scheme/gschem/deprecated.scm
@@ -157,3 +157,21 @@
;; Same as rotate-component-object-hook, but for pins.
(define-public rotate-pin-hook (make-hook 1))
(add-hook!/filter rotate-objects-hook rotate-pin-hook pin?)
+
+;; copy-component-hook:
+;;
+;; Called each time a component is copied into the schematic.
+;; Argument is a list off all attributes (inherited & promoted) of the
+;; component. Differs from classic behaviour in that it is called on
+;; pasting from buffers and the clipboard, in addition to "Edit->Copy
+;; Mode" and "Edit->Multiple Copy Mode".
+(define-public copy-component-hook (make-hook 1))
+(add-hook!/full-attribs paste-objects-hook copy-component-hook component?)
+
+;; move-component-hook:
+;;
+;; Called each time a component is moved in the schematic.
+;; Argument is as copy-component-hook.
+(define-public move-component-hook (make-hook 1))
+(add-hook!/full-attribs move-objects-hook move-component-hook component?)
+
diff --git a/gschem/src/g_register.c b/gschem/src/g_register.c
index 48aece2..19c447b 100644
--- a/gschem/src/g_register.c
+++ b/gschem/src/g_register.c
@@ -339,8 +339,6 @@ void g_register_funcs (void)
scm_c_define_gsubr ("set-attribute-text-properties!", 7, 0, 0, g_set_attrib_text_properties);
scm_c_define_gsubr ("add-component-at-xy", 7, 0, 0, g_add_component);
- copy_component_hook = create_hook ("copy-component-hook", 1);
- move_component_hook = create_hook ("move-component-hook", 1);
deselect_component_hook = create_hook ("deselect-component-hook", 1);
deselect_net_hook = create_hook ("deselect-net-hook", 1);
deselect_all_hook = create_hook ("deselect-all-hook", 1);
diff --git a/gschem/src/globals.c b/gschem/src/globals.c
index c96f53c..3c3f930 100644
--- a/gschem/src/globals.c
+++ b/gschem/src/globals.c
@@ -51,8 +51,6 @@ GList *object_buffer[MAX_BUFFERS];
/* Hooks */
SCM complex_place_list_changed_hook;
-SCM copy_component_hook;
-SCM move_component_hook;
SCM deselect_component_hook;
SCM deselect_net_hook;
SCM deselect_all_hook;
diff --git a/gschem/src/o_copy.c b/gschem/src/o_copy.c
index 0c65b7c..e726458 100644
--- a/gschem/src/o_copy.c
+++ b/gschem/src/o_copy.c
@@ -64,38 +64,6 @@ void o_copy_start(GSCHEM_TOPLEVEL *w_current, int w_x, int w_y)
o_place_start (w_current, w_x, w_y);
}
-
-/*! \todo Finish function documentation!!!
- * \brief
- * \par Function Description
- *
- */
-static void o_copy_end_generic(GSCHEM_TOPLEVEL *w_current, int multiple)
-{
- GList *new_objects;
- GList *iter;
- OBJECT *object;
-
- o_place_end (w_current, w_current->second_wx, w_current->second_wy, multiple,
- &new_objects, NULL);
-
- /* Run the copy component hook for all new components */
- for (iter = new_objects;
- iter != NULL;
- iter = g_list_next (iter)) {
- object = iter->data;
- if ( (object->type == OBJ_COMPLEX) &&
- scm_is_false (scm_hook_empty_p (copy_component_hook))) {
- scm_run_hook(copy_component_hook,
- scm_cons (g_make_attrib_smob_list(w_current, object),
- SCM_EOL));
- }
- }
-
- g_list_free (new_objects);
-}
-
-
/*! \todo Finish function documentation!!!
* \brief
* \par Function Description
@@ -103,7 +71,8 @@ static void o_copy_end_generic(GSCHEM_TOPLEVEL *w_current, int multiple)
*/
void o_copy_end(GSCHEM_TOPLEVEL *w_current)
{
- o_copy_end_generic (w_current, FALSE);
+ o_place_end (w_current, w_current->second_wx, w_current->second_wy, FALSE,
+ NULL, "%paste-objects-hook");
}
@@ -114,5 +83,6 @@ void o_copy_end(GSCHEM_TOPLEVEL *w_current)
*/
void o_copy_multiple_end(GSCHEM_TOPLEVEL *w_current)
{
- o_copy_end_generic (w_current, TRUE);
+ o_place_end (w_current, w_current->second_wx, w_current->second_wy, TRUE,
+ NULL, "%paste-objects-hook");
}
diff --git a/gschem/src/o_move.c b/gschem/src/o_move.c
index 5017d7e..00865ed 100644
--- a/gschem/src/o_move.c
+++ b/gschem/src/o_move.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -180,13 +180,6 @@ void o_move_end(GSCHEM_TOPLEVEL *w_current)
case (OBJ_COMPLEX):
case (OBJ_PLACEHOLDER):
- if (scm_is_false (scm_hook_empty_p (move_component_hook)) &&
- object != NULL) {
- scm_run_hook(move_component_hook,
- scm_cons (g_make_attrib_smob_list
- (w_current, object), SCM_EOL));
- }
-
/* TODO: Fix so we can just pass the complex to o_move_end_lowlevel,
* IE.. by falling through the bottom of this case statement. */
@@ -227,14 +220,18 @@ void o_move_end(GSCHEM_TOPLEVEL *w_current)
/* Draw the connected nets/buses that were also changed */
o_invalidate_glist (w_current, rubbernet_objects);
+ /* Call move-objects-hook for moved objects and changed connected
+ * nets/buses */
+ GList *moved_list = g_list_concat (toplevel->page_current->place_list,
+ rubbernet_objects);
+ toplevel->page_current->place_list = NULL;
+ rubbernet_objects = NULL;
+ g_run_hook_object_list ("%move-objects-hook", moved_list);
+ g_list_free (moved_list);
+
toplevel->page_current->CHANGED = 1;
o_undo_savestate(w_current, UNDO_ALL);
- g_list_free(rubbernet_objects);
-
- g_list_free(toplevel->page_current->place_list);
- toplevel->page_current->place_list = NULL;
-
s_stretch_destroy_all (w_current->stretch_list);
w_current->stretch_list = NULL;
}
diff --git a/gschem/src/x_event.c b/gschem/src/x_event.c
index 38e65d6..0eaf6c5 100644
--- a/gschem/src/x_event.c
+++ b/gschem/src/x_event.c
@@ -303,7 +303,7 @@ gint x_event_button_pressed(GtkWidget *widget, GdkEventButton *event,
break;
case(ENDPASTE):
- o_place_end(w_current, w_x, w_y, FALSE, NULL, NULL);
+ o_place_end(w_current, w_x, w_y, FALSE, NULL, "%paste-objects-hook");
w_current->inside_action = 0;
i_set_state(w_current, SELECT);
i_update_toolbar(w_current);
commit 91e869f566c82cf2bcd9c501bad2060a257c2192
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Enable mirror-objects-hook and rotate-objects-hook.
diff --git a/gschem/include/globals.h b/gschem/include/globals.h
index d115e98..23e9555 100644
--- a/gschem/include/globals.h
+++ b/gschem/include/globals.h
@@ -51,13 +51,9 @@ extern int auto_place_mode;
extern GList *object_buffer[MAX_BUFFERS];
/* Hooks */
-extern SCM mirror_component_object_hook;
-extern SCM rotate_component_object_hook;
extern SCM complex_place_list_changed_hook;
extern SCM copy_component_hook;
extern SCM move_component_hook;
-extern SCM mirror_pin_hook;
-extern SCM rotate_pin_hook;
extern SCM deselect_component_hook;
extern SCM deselect_net_hook;
extern SCM deselect_all_hook;
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index 0112ffe..3be0560 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -595,7 +595,6 @@ void o_edit(GSCHEM_TOPLEVEL *w_current, GList *list);
void o_lock(GSCHEM_TOPLEVEL *w_current);
void o_unlock(GSCHEM_TOPLEVEL *w_current);
void o_rotate_world_update(GSCHEM_TOPLEVEL *w_current, int centerx, int centery, int angle, GList *list);
-void o_rotate_call_hooks(GSCHEM_TOPLEVEL *w_current, GList *list);
void o_mirror_world_update(GSCHEM_TOPLEVEL *w_current, int centerx, int centery, GList *list);
void o_edit_show_hidden_lowlevel(GSCHEM_TOPLEVEL *w_current, const GList *o_list);
void o_edit_show_hidden(GSCHEM_TOPLEVEL *w_current, const GList *o_list);
diff --git a/gschem/scheme/gschem/deprecated.scm b/gschem/scheme/gschem/deprecated.scm
index bc843f0..ce86084 100644
--- a/gschem/scheme/gschem/deprecated.scm
+++ b/gschem/scheme/gschem/deprecated.scm
@@ -129,3 +129,31 @@
;; pin itself.
(define-public add-pin-hook (make-hook 1))
(add-hook!/filter add-objects-hook add-pin-hook pin?)
+
+;; mirror-component-object-hook
+;;
+;; Called for each component in the selection when a mirror operation
+;; is carried out. The argument is the component itself.
+(define-public mirror-component-object-hook (make-hook 1))
+(add-hook!/filter mirror-objects-hook mirror-component-object-hook component?)
+
+;; mirror-pin-hook
+;;
+;; Same as mirror-component-object-hook, but for pins.
+(define-public mirror-pin-hook (make-hook 1))
+(add-hook!/filter mirror-objects-hook mirror-pin-hook pin?)
+
+;; rotate-component-object-hook
+;;
+;; Called for each component in the selection when a rotate operation
+;; is carried out (including using the middle mouse button during a
+;; move operation, but excluding rotations during component
+;; placement). The argument is the component itself.
+(define-public rotate-component-object-hook (make-hook 1))
+(add-hook!/filter rotate-objects-hook rotate-component-object-hook component?)
+
+;; rotate-pin-hook
+;;
+;; Same as rotate-component-object-hook, but for pins.
+(define-public rotate-pin-hook (make-hook 1))
+(add-hook!/filter rotate-objects-hook rotate-pin-hook pin?)
diff --git a/gschem/src/g_register.c b/gschem/src/g_register.c
index 0fa8cff..48aece2 100644
--- a/gschem/src/g_register.c
+++ b/gschem/src/g_register.c
@@ -339,8 +339,6 @@ void g_register_funcs (void)
scm_c_define_gsubr ("set-attribute-text-properties!", 7, 0, 0, g_set_attrib_text_properties);
scm_c_define_gsubr ("add-component-at-xy", 7, 0, 0, g_add_component);
- rotate_component_object_hook = create_hook ("rotate-component-object-hook", 1);
- mirror_component_object_hook = create_hook ("mirror-component-object-hook", 1);
copy_component_hook = create_hook ("copy-component-hook", 1);
move_component_hook = create_hook ("move-component-hook", 1);
deselect_component_hook = create_hook ("deselect-component-hook", 1);
@@ -349,8 +347,6 @@ void g_register_funcs (void)
select_component_hook = create_hook ("select-component-hook", 1);
select_net_hook = create_hook ("select-net-hook", 1);
- mirror_pin_hook = create_hook ("mirror-pin-hook", 1);
- rotate_pin_hook = create_hook ("rotate-pin-hook", 1);
new_page_hook = create_hook ("new-page-hook", 1);
complex_place_list_changed_hook = create_hook ("complex-place-list-changed-hook", 1);
}
diff --git a/gschem/src/globals.c b/gschem/src/globals.c
index 4a26001..c96f53c 100644
--- a/gschem/src/globals.c
+++ b/gschem/src/globals.c
@@ -50,13 +50,9 @@ int auto_place_mode = FALSE;
GList *object_buffer[MAX_BUFFERS];
/* Hooks */
-SCM mirror_component_object_hook;
-SCM rotate_component_object_hook;
SCM complex_place_list_changed_hook;
SCM copy_component_hook;
SCM move_component_hook;
-SCM rotate_pin_hook;
-SCM mirror_pin_hook;
SCM deselect_component_hook;
SCM deselect_net_hook;
SCM deselect_all_hook;
diff --git a/gschem/src/o_misc.c b/gschem/src/o_misc.c
index d72eee7..49b7161 100644
--- a/gschem/src/o_misc.c
+++ b/gschem/src/o_misc.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -225,8 +225,8 @@ void o_rotate_world_update(GSCHEM_TOPLEVEL *w_current,
o_invalidate_glist (w_current, list);
- /* All objects were rotated. Run the rotate hooks */
- o_rotate_call_hooks (w_current, list);
+ /* Run rotate-objects-hook */
+ g_run_hook_object_list ("%rotate-objects-hook", list);
/* Don't save the undo state if we are inside an action */
/* This is useful when rotating the selection while moving, for example */
@@ -236,42 +236,6 @@ void o_rotate_world_update(GSCHEM_TOPLEVEL *w_current,
}
}
-
-void o_rotate_call_hooks (GSCHEM_TOPLEVEL *w_current, GList *list)
-{
- TOPLEVEL *toplevel = w_current->toplevel;
- OBJECT *o_current;
- GList *iter;
-
- /* Do not run any hooks for simple objects here, like text, since they
- were rotated in the previous pass, and the selection list can contain
- an object and all its attributes (text) */
- for (iter = list; iter != NULL; iter = g_list_next (iter)) {
- o_current = iter->data;
-
- switch (o_current->type) {
- case OBJ_PIN:
- /* Run the rotate pin hook */
- if (scm_is_false (scm_hook_empty_p (rotate_pin_hook))) {
- scm_run_hook (rotate_pin_hook,
- scm_list_1 (edascm_from_object (o_current)));
- }
- break;
-
- case OBJ_COMPLEX:
- /* Run the rotate hook */
- if (scm_is_false (scm_hook_empty_p (rotate_component_object_hook))) {
- scm_run_hook (rotate_component_object_hook,
- scm_list_1 (edascm_from_object (o_current)));
- }
- break;
-
- default:
- break;
- }
- }
-}
-
/*! \todo Finish function documentation!!!
* \brief
* \par Function Description
@@ -315,38 +279,8 @@ void o_mirror_world_update(GSCHEM_TOPLEVEL *w_current, int centerx, int centery,
o_invalidate_glist (w_current, list);
- /* All objects were mirrored. Do a 2nd pass to run the mirror hooks */
- /* Do not run any hooks for simple objects here, like text, since they
- were mirrored in the previous pass, and the selection list can contain
- an object and all its attributes (text) */
- o_iter = list;
- while (o_iter != NULL) {
- o_current = (OBJECT *) o_iter->data;
-
- switch(o_current->type) {
- case(OBJ_PIN):
- /* Run the mirror pin hook */
- if (scm_is_false (scm_hook_empty_p (mirror_pin_hook)) &&
- o_current != NULL) {
- scm_run_hook(mirror_pin_hook,
- scm_list_1 (edascm_from_object (o_current)));
- }
- break;
-
- case (OBJ_COMPLEX):
- /* Run the mirror pin hook */
- if (scm_is_false (scm_hook_empty_p(mirror_component_object_hook)) &&
- o_current != NULL) {
- scm_run_hook(mirror_component_object_hook,
- scm_list_1 (edascm_from_object (o_current)));
- }
- break;
- default:
- break;
- }
-
- o_iter = g_list_next(o_iter);
- }
+ /* Run mirror-objects-hook */
+ g_run_hook_object_list ("%mirror-objects-hook", list);
toplevel->page_current->CHANGED=1;
o_undo_savestate(w_current, UNDO_ALL);
diff --git a/gschem/src/o_place.c b/gschem/src/o_place.c
index ad2dd61..3cfc1da 100644
--- a/gschem/src/o_place.c
+++ b/gschem/src/o_place.c
@@ -319,6 +319,9 @@ void o_place_rotate (GSCHEM_TOPLEVEL *w_current)
o_glist_rotate_world (toplevel,
w_current->first_wx, w_current->first_wy, 90,
toplevel->page_current->place_list);
- /* All objects were rotated. Run the rotate hooks */
- o_rotate_call_hooks (w_current, toplevel->page_current->place_list);
+
+
+ /* Run rotate-objects-hook */
+ g_run_hook_object_list ("%rotate-objects-hook",
+ toplevel->page_current->place_list);
}
commit d0467a2c5c6fde4155bfc57f0345bbb162e1b4c7
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Enable remove-objects-hook.
diff --git a/gschem/src/o_delete.c b/gschem/src/o_delete.c
index 970612d..94f9039 100644
--- a/gschem/src/o_delete.c
+++ b/gschem/src/o_delete.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -41,7 +41,9 @@ void o_delete (GSCHEM_TOPLEVEL *w_current, OBJECT *object)
g_return_if_fail (object != NULL);
+ o_selection_remove (toplevel, toplevel->page_current->selection_list, object);
s_page_remove (toplevel, toplevel->page_current, object);
+ g_run_hook_object ("%remove-objects-hook", object);
s_delete_object (toplevel, object);
toplevel->page_current->CHANGED = 1;
@@ -56,20 +58,28 @@ void o_delete (GSCHEM_TOPLEVEL *w_current, OBJECT *object)
*/
void o_delete_selected (GSCHEM_TOPLEVEL *w_current)
{
- SELECTION *selection = w_current->toplevel->page_current->selection_list;
- GList *s_current;
+ TOPLEVEL *toplevel = w_current->toplevel;
+ SELECTION *selection = toplevel->page_current->selection_list;
+ GList *to_remove;
+ GList *iter;
g_return_if_fail (o_select_selected (w_current));
+ to_remove = g_list_copy (geda_list_get_glist (selection));
- for (s_current = geda_list_get_glist (selection);
- s_current != NULL;
- s_current = g_list_next (s_current)) {
- o_delete (w_current, (OBJECT*)s_current->data);
+ for (iter = to_remove; iter != NULL; iter = g_list_next (iter)) {
+ OBJECT *obj = (OBJECT *) iter->data;
+ o_selection_remove (toplevel, selection, obj);
+ s_page_remove (toplevel, toplevel->page_current, obj);
}
- /* Objects in the selection list have been deleted. */
- /* Empty the list without touching the objects */
- geda_list_remove_all (selection);
+
+ g_run_hook_object_list ("%remove-objects-hook", to_remove);
+
+ for (iter = to_remove; iter != NULL; iter = g_list_next (iter)) {
+ s_delete_object (toplevel, (OBJECT *) iter->data);
+ }
+
+ g_list_free (to_remove);
w_current->inside_action = 0;
o_undo_savestate (w_current, UNDO_ALL);
diff --git a/gschem/src/x_autonumber.c b/gschem/src/x_autonumber.c
index 3623b09..e605c81 100644
--- a/gschem/src/x_autonumber.c
+++ b/gschem/src/x_autonumber.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -587,9 +587,6 @@ void autonumber_remove_number(AUTONUMBER_TEXT * autotext, OBJECT *o_current)
/* Only attempt to remove non-inherited slot attributes */
if (o_slot != NULL && !o_attrib_is_inherited (o_slot)) {
/* delete the slot attribute */
- o_selection_remove (autotext->w_current->toplevel,
- autotext->w_current->toplevel->
- page_current->selection_list, o_slot);
o_delete (autotext->w_current, o_slot);
}
}
diff --git a/gschem/src/x_multiattrib.c b/gschem/src/x_multiattrib.c
index 3bf73a5..e00cde9 100644
--- a/gschem/src/x_multiattrib.c
+++ b/gschem/src/x_multiattrib.c
@@ -747,11 +747,7 @@ static void multiattrib_action_delete_attribute(GSCHEM_TOPLEVEL *w_current,
OBJECT *o_attrib)
{
/* actually deletes the attribute */
- o_selection_remove (w_current->toplevel,
- w_current->toplevel->page_current->selection_list,
- o_attrib);
o_delete (w_current, o_attrib);
- w_current->toplevel->page_current->CHANGED=1;
o_undo_savestate (w_current, UNDO_ALL);
}
commit 05954f101e9ae90193150e030fb66c1b3d32e44b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Enable add-objects-hook.
diff --git a/gschem/include/globals.h b/gschem/include/globals.h
index 1cb9198..d115e98 100644
--- a/gschem/include/globals.h
+++ b/gschem/include/globals.h
@@ -2,6 +2,7 @@
* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -50,17 +51,13 @@ extern int auto_place_mode;
extern GList *object_buffer[MAX_BUFFERS];
/* Hooks */
-extern SCM add_component_hook;
-extern SCM add_component_object_hook;
extern SCM mirror_component_object_hook;
extern SCM rotate_component_object_hook;
extern SCM complex_place_list_changed_hook;
extern SCM copy_component_hook;
extern SCM move_component_hook;
-extern SCM add_pin_hook;
extern SCM mirror_pin_hook;
extern SCM rotate_pin_hook;
-extern SCM add_attribute_hook;
extern SCM deselect_component_hook;
extern SCM deselect_net_hook;
extern SCM deselect_all_hook;
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index 6659ead..0112ffe 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -547,7 +547,6 @@ void o_complex_draw(GSCHEM_TOPLEVEL *w_current, OBJECT *o_current);
void o_complex_draw_place(GSCHEM_TOPLEVEL *w_current, int dx, int dy, OBJECT *complex);
void o_complex_prepare_place(GSCHEM_TOPLEVEL *w_current, const CLibSymbol *sym);
void o_complex_place_changed_run_hook(GSCHEM_TOPLEVEL *w_current);
-void o_complex_end(GSCHEM_TOPLEVEL *w_current, int x, int y, int continue_placing);
void o_complex_translate_all(GSCHEM_TOPLEVEL *w_current, int offset);
/* o_copy.c */
void o_copy_start(GSCHEM_TOPLEVEL *w_current, int x, int y);
@@ -667,7 +666,7 @@ void o_pin_draw_rubber(GSCHEM_TOPLEVEL *w_current);
void o_pin_invalidate_rubber(GSCHEM_TOPLEVEL *w_current);
/* o_place.c */
void o_place_start(GSCHEM_TOPLEVEL *w_current, int x, int y);
-void o_place_end(GSCHEM_TOPLEVEL *w_current, int x, int y, int continue_placing, GList **ret_new_objects);
+void o_place_end(GSCHEM_TOPLEVEL *w_current, int x, int y, int continue_placing, GList **ret_new_objects, const char *hook_name);
void o_place_motion(GSCHEM_TOPLEVEL *w_current, int x, int y);
void o_place_invalidate_rubber(GSCHEM_TOPLEVEL *w_current, int drawing);
void o_place_draw_rubber(GSCHEM_TOPLEVEL *w_current, int drawing);
diff --git a/gschem/scheme/gschem/deprecated.scm b/gschem/scheme/gschem/deprecated.scm
index 33d494f..bc843f0 100644
--- a/gschem/scheme/gschem/deprecated.scm
+++ b/gschem/scheme/gschem/deprecated.scm
@@ -1,6 +1,6 @@
;; gEDA - GPL Electronic Design Automation
;; gschem - gEDA Schematic Capture - Scheme API
-;; Copyright (C) 2010 Peter Brett
+;; Copyright (C) 2010-2011 Peter Brett
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -25,7 +25,8 @@
#:use-module (geda page)
#:use-module (geda object)
#:use-module (geda attrib)
- #:use-module (gschem window))
+ #:use-module (gschem window)
+ #:use-module (gschem hook))
(define-public (set-attribute-value! attrib value)
(let ((params (text-info attrib))
@@ -46,3 +47,85 @@
(define-public (get-pin-ends pin)
(let ((params (line-info pin)))
(cons (list-ref params 0) (list-ref params 1))))
+
+;;;; Old-style hooks
+
+;; Adds a function to src-hook. The function is called with a single
+;; argument, lst, which should be a list of objects. For each member
+;; of lst which matches filter?, the function calls tgt-hook with that
+;; object as the argument.
+(define (add-hook!/filter src-hook tgt-hook filter?)
+ (add-hook! src-hook
+ (lambda (lst)
+ (if (not (hook-empty? tgt-hook))
+ (for-each
+ (lambda (obj)
+ (if (filter? obj)
+ (run-hook tgt-hook obj)))
+ lst)))))
+
+;; Adds a function to src-hook. The function is called with a single
+;; argument, lst, which should be a list of objects. For each member
+;; of lst which matches filter?, the function calls tgt-hook with a
+;; list of all attributes (attached and inherited) of that object.
+(define (add-hook!/full-attribs src-hook tgt-hook filter?)
+ (add-hook! src-hook
+ (lambda (lst)
+ (if (not (hook-empty? tgt-hook))
+ (for-each
+ (lambda (obj)
+ (if (filter? obj)
+ (run-hook tgt-hook
+ (append! (object-attribs obj)
+ (inherited-attribs obj)))))
+ lst)))))
+
+;; add-component-hook:
+;;
+;; Called when a new component is added to the page (not copied etc).
+;; Argument is a list of all attributes (inherited & promoted) of the
+;; component. Differs from the classic behaviour in that it is *not*
+;; also called once for each promoted attribute with the empty list as
+;; the argument.
+(define-public add-component-hook (make-hook 1))
+(add-hook!/full-attribs add-objects-hook add-component-hook component?)
+
+;; add-component-object-hook:
+;;
+;; Called when a new component is added to the page (not copied etc).
+;; Called once with the component itself as the argument, and once for
+;; each promoted attribute, with the attribute as the argument.
+(define-public add-component-object-hook (make-hook 1))
+(add-hook! add-objects-hook
+ (lambda (lst)
+ (if (not (hook-empty? add-component-object-hook))
+ (for-each
+ (lambda (obj)
+ (define (run x) (run-hook add-component-object-hook x))
+ (if (component? obj)
+ (begin (run obj) (for-each run (object-attribs obj)))))
+ lst))))
+
+;; add-attribute-hook
+;;
+;; Called each time an attribute is added to something. Argument is
+;; the thing that had an attribute added. The behaviour here emulates
+;; the classic behaviour as closely as possible -- it doesn't run the
+;; hook on explicit attribute attachment operations (via
+;; "Attributes->Attach"), but does run when an individual attribute is
+;; created and simultaneously attached to something.
+(define-public add-attribute-hook (make-hook 1))
+(add-hook! add-objects-hook
+ (lambda (lst)
+ (if (and (not (hook-empty? add-attribute-hook)) (= 1 (length lst)))
+ (let* ((attrib (car lst))
+ (target (attrib-attachment attrib)))
+ (if (and (attribute? attrib) target)
+ (run-hook add-attribute-hook target))))))
+
+;; add-pin-hook
+;;
+;; Called each time a pin is added to the schematic. Argument is the
+;; pin itself.
+(define-public add-pin-hook (make-hook 1))
+(add-hook!/filter add-objects-hook add-pin-hook pin?)
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index 9d61a1e..1757ad7 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -106,7 +106,6 @@ SCM g_add_attrib(SCM object, SCM scm_attrib_name,
SCM scm_attrib_value, SCM scm_vis, SCM scm_show)
{
GSCHEM_TOPLEVEL *w_current = g_current_window ();
- TOPLEVEL *toplevel = w_current->toplevel;
OBJECT *o_current=NULL;
gboolean vis;
int show=0;
@@ -550,6 +549,7 @@ SCM g_add_component(SCM page_smob, SCM scm_comp_name, SCM scm_x, SCM scm_y,
gchar *comp_name;
int x, y, angle;
OBJECT *new_obj;
+ GList *added_objects = NULL;
const CLibSymbol *clib;
/* Return if scm_comp_name is NULL (an empty list) or scheme's FALSE */
@@ -596,16 +596,17 @@ SCM g_add_component(SCM page_smob, SCM scm_comp_name, SCM scm_x, SCM scm_y,
new_obj = o_complex_new (toplevel, 'C', DEFAULT_COLOR, x, y, angle, mirror,
clib, comp_name, selectable);
+
+ added_objects = o_complex_promote_attribs (toplevel, new_obj);
s_page_append_list (toplevel, page,
- o_complex_promote_attribs (toplevel, new_obj));
+ g_list_copy (added_objects));
s_page_append (toplevel, page, new_obj);
- /* Run the add component hook for the new component */
- if (scm_is_false (scm_hook_empty_p (add_component_object_hook))) {
- scm_run_hook(add_component_object_hook,
- scm_list_1 (edascm_from_object(new_obj)));
- }
+ /* Run the add-objects-hook for the new component & attributes */
+ added_objects = g_list_prepend (added_objects, new_obj);
+ g_run_hook_object_list ("%add-objects-hook", added_objects);
+ g_list_free (added_objects);
return SCM_BOOL_T;
}
diff --git a/gschem/src/g_register.c b/gschem/src/g_register.c
index a24d122..0fa8cff 100644
--- a/gschem/src/g_register.c
+++ b/gschem/src/g_register.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -339,8 +339,6 @@ void g_register_funcs (void)
scm_c_define_gsubr ("set-attribute-text-properties!", 7, 0, 0, g_set_attrib_text_properties);
scm_c_define_gsubr ("add-component-at-xy", 7, 0, 0, g_add_component);
- add_component_hook = create_hook ("add-component-hook", 1);
- add_component_object_hook = create_hook ("add-component-object-hook", 1);
rotate_component_object_hook = create_hook ("rotate-component-object-hook", 1);
mirror_component_object_hook = create_hook ("mirror-component-object-hook", 1);
copy_component_hook = create_hook ("copy-component-hook", 1);
@@ -351,10 +349,8 @@ void g_register_funcs (void)
select_component_hook = create_hook ("select-component-hook", 1);
select_net_hook = create_hook ("select-net-hook", 1);
- add_pin_hook = create_hook ("add-pin-hook", 1);
mirror_pin_hook = create_hook ("mirror-pin-hook", 1);
rotate_pin_hook = create_hook ("rotate-pin-hook", 1);
- add_attribute_hook = create_hook ("add-attribute-hook", 1);
new_page_hook = create_hook ("new-page-hook", 1);
complex_place_list_changed_hook = create_hook ("complex-place-list-changed-hook", 1);
}
diff --git a/gschem/src/globals.c b/gschem/src/globals.c
index f8beac3..4a26001 100644
--- a/gschem/src/globals.c
+++ b/gschem/src/globals.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -50,15 +50,11 @@ int auto_place_mode = FALSE;
GList *object_buffer[MAX_BUFFERS];
/* Hooks */
-SCM add_attribute_hook;
-SCM add_component_hook;
-SCM add_component_object_hook;
SCM mirror_component_object_hook;
SCM rotate_component_object_hook;
SCM complex_place_list_changed_hook;
SCM copy_component_hook;
SCM move_component_hook;
-SCM add_pin_hook;
SCM rotate_pin_hook;
SCM mirror_pin_hook;
SCM deselect_component_hook;
diff --git a/gschem/src/o_arc.c b/gschem/src/o_arc.c
index 83e6c8f..6e15530 100644
--- a/gschem/src/o_arc.c
+++ b/gschem/src/o_arc.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -210,6 +210,9 @@ void o_arc_end4(GSCHEM_TOPLEVEL *w_current, int radius,
w_current->first_wy = -1;
w_current->distance = 0;
+ /* Call add-objects-hook */
+ g_run_hook_object ("%add-objects-hook", new_obj);
+
toplevel->page_current->CHANGED = 1;
o_undo_savestate(w_current, UNDO_ALL);
diff --git a/gschem/src/o_attrib.c b/gschem/src/o_attrib.c
index b88026f..7bab2d1 100644
--- a/gschem/src/o_attrib.c
+++ b/gschem/src/o_attrib.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -270,12 +270,8 @@ OBJECT *o_attrib_add_attrib(GSCHEM_TOPLEVEL *w_current,
o_slot_end (w_current, o_current, text_string);
}
- /* Run the add attribute hook */
- if (scm_is_false (scm_hook_empty_p (add_attribute_hook)) &&
- o_current != NULL) {
- scm_run_hook (add_attribute_hook,
- scm_list_1 (edascm_from_object (o_current)));
- }
+ /* Call add-objects-hook. */
+ g_run_hook_object ("%add-objects-hook", new_obj);
toplevel->page_current->CHANGED = 1;
diff --git a/gschem/src/o_box.c b/gschem/src/o_box.c
index 6537679..110421a 100644
--- a/gschem/src/o_box.c
+++ b/gschem/src/o_box.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -456,6 +456,9 @@ void o_box_end(GSCHEM_TOPLEVEL *w_current, int w_x, int w_y)
w_current->second_wx = (-1);
w_current->second_wy = (-1);
+ /* Call add-objects-hook */
+ g_run_hook_object ("%add-objects-hook", new_obj);
+
toplevel->page_current->CHANGED = 1;
o_undo_savestate(w_current, UNDO_ALL);
diff --git a/gschem/src/o_bus.c b/gschem/src/o_bus.c
index 63aace2..666669e 100644
--- a/gschem/src/o_bus.c
+++ b/gschem/src/o_bus.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -193,6 +193,9 @@ int o_bus_end(GSCHEM_TOPLEVEL *w_current, int w_x, int w_y)
o_invalidate_glist (w_current, prev_conn_objects);
g_list_free (prev_conn_objects);
+ /* Call add-objects-hook */
+ g_run_hook_object ("%add-objects-hook", new_obj);
+
toplevel->page_current->CHANGED=1;
w_current->first_wx = w_current->second_wx;
w_current->first_wy = w_current->second_wy;
diff --git a/gschem/src/o_circle.c b/gschem/src/o_circle.c
index 95790b8..815dfcb 100644
--- a/gschem/src/o_circle.c
+++ b/gschem/src/o_circle.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -427,6 +427,9 @@ void o_circle_end(GSCHEM_TOPLEVEL *w_current, int w_x, int w_y)
w_current->distance);
s_page_append (toplevel, toplevel->page_current, new_obj);
+ /* Call add-objects-hook */
+ g_run_hook_object ("%add-objects-hook", new_obj);
+
toplevel->page_current->CHANGED = 1;
o_undo_savestate(w_current, UNDO_ALL);
}
diff --git a/gschem/src/o_complex.c b/gschem/src/o_complex.c
index e1460bf..05e4cb3 100644
--- a/gschem/src/o_complex.c
+++ b/gschem/src/o_complex.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -155,46 +155,6 @@ void o_complex_place_changed_run_hook(GSCHEM_TOPLEVEL *w_current) {
* \brief
* \par Function Description
*
- */
-void o_complex_end(GSCHEM_TOPLEVEL *w_current, int w_x, int w_y, int continue_placing)
-{
- GList *new_objects;
- GList *iter;
- OBJECT *o_current;
-
- o_place_end (w_current, w_x, w_y, continue_placing, &new_objects);
-
- if (w_current->include_complex) {
- g_list_free (new_objects);
- return;
- }
-
- /* Run the add component hook for the new component */
- for (iter = new_objects;
- iter != NULL;
- iter = g_list_next (iter)) {
- o_current = iter->data;
-
- if (scm_is_false (scm_hook_empty_p (add_component_hook))) {
- scm_run_hook(add_component_hook,
- scm_cons(g_make_attrib_smob_list(w_current, o_current),
- SCM_EOL));
- }
-
- if (scm_is_false (scm_hook_empty_p (add_component_object_hook))) {
- scm_run_hook(add_component_object_hook,
- scm_list_1 (edascm_from_object(o_current)));
- }
- }
-
- g_list_free (new_objects);
-}
-
-
-/*! \todo Finish function documentation!!!
- * \brief
- * \par Function Description
- *
* \note
* don't know if this belongs yet
*/
diff --git a/gschem/src/o_copy.c b/gschem/src/o_copy.c
index 3039206..0c65b7c 100644
--- a/gschem/src/o_copy.c
+++ b/gschem/src/o_copy.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -76,7 +76,8 @@ static void o_copy_end_generic(GSCHEM_TOPLEVEL *w_current, int multiple)
GList *iter;
OBJECT *object;
- o_place_end (w_current, w_current->second_wx, w_current->second_wy, multiple, &new_objects);
+ o_place_end (w_current, w_current->second_wx, w_current->second_wy, multiple,
+ &new_objects, NULL);
/* Run the copy component hook for all new components */
for (iter = new_objects;
diff --git a/gschem/src/o_line.c b/gschem/src/o_line.c
index a3b7cc5..81dfe95 100644
--- a/gschem/src/o_line.c
+++ b/gschem/src/o_line.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -173,6 +173,9 @@ void o_line_end(GSCHEM_TOPLEVEL *w_current, int w_x, int w_y)
w_current->second_wx, w_current->second_wy);
s_page_append (toplevel, toplevel->page_current, new_obj);
+ /* Call add-objects-hook */
+ g_run_hook_object ("%add-objects-hook", new_obj);
+
toplevel->page_current->CHANGED=1;
o_undo_savestate(w_current, UNDO_ALL);
}
diff --git a/gschem/src/o_net.c b/gschem/src/o_net.c
index 5459ca0..d4b1b27 100644
--- a/gschem/src/o_net.c
+++ b/gschem/src/o_net.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -562,6 +562,9 @@ int o_net_end(GSCHEM_TOPLEVEL *w_current, int w_x, int w_y)
GList *prev_conn_objects;
OBJECT *new_net = NULL;
+ /* Save a list of added objects to run the %add-objects-hook later */
+ GList *added_objects = NULL;
+
g_assert( w_current->inside_action != 0 );
o_net_invalidate_rubber (w_current);
@@ -605,6 +608,8 @@ int o_net_end(GSCHEM_TOPLEVEL *w_current, int w_x, int w_y)
w_current->second_wx, w_current->second_wy);
s_page_append (toplevel, toplevel->page_current, new_net);
+ added_objects = g_list_prepend (added_objects, new_net);
+
/* conn stuff */
/* LEAK CHECK 1 */
prev_conn_objects = s_conn_return_others (NULL, new_net);
@@ -638,6 +643,8 @@ int o_net_end(GSCHEM_TOPLEVEL *w_current, int w_x, int w_y)
w_current->third_wx, w_current->third_wy);
s_page_append (toplevel, toplevel->page_current, new_net);
+ added_objects = g_list_prepend (added_objects, new_net);
+
/* conn stuff */
/* LEAK CHECK 2 */
prev_conn_objects = s_conn_return_others (NULL, new_net);
@@ -648,6 +655,12 @@ int o_net_end(GSCHEM_TOPLEVEL *w_current, int w_x, int w_y)
#endif
}
+ /* Call add-objects-hook */
+ if (added_objects != NULL) {
+ g_run_hook_object_list ("%add-objects-hook", added_objects);
+ g_list_free (added_objects);
+ }
+
toplevel->page_current->CHANGED = 1;
w_current->first_wx = save_wx;
w_current->first_wy = save_wy;
diff --git a/gschem/src/o_picture.c b/gschem/src/o_picture.c
index 044009a..d64b949 100644
--- a/gschem/src/o_picture.c
+++ b/gschem/src/o_picture.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -112,6 +112,9 @@ void o_picture_end(GSCHEM_TOPLEVEL *w_current, int w_x, int w_y)
0, FALSE, FALSE);
s_page_append (toplevel, toplevel->page_current, new_obj);
+ /* Run %add-objects-hook */
+ g_run_hook_object ("%add-objects-hook", new_obj);
+
toplevel->page_current->CHANGED = 1;
o_undo_savestate(w_current, UNDO_ALL);
}
diff --git a/gschem/src/o_pin.c b/gschem/src/o_pin.c
index 3cf12d7..f2a5ea7 100644
--- a/gschem/src/o_pin.c
+++ b/gschem/src/o_pin.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -142,10 +142,8 @@ void o_pin_end(GSCHEM_TOPLEVEL *w_current, int x, int y)
PIN_TYPE_NET, 0);
s_page_append (toplevel, toplevel->page_current, new_obj);
- if (scm_is_false (scm_hook_empty_p (add_pin_hook))) {
- scm_run_hook (add_pin_hook,
- scm_list_1 (edascm_from_object (new_obj)));
- }
+ /* Call add-objects-hook */
+ g_run_hook_object ("%add-objects-hook", new_obj);
toplevel->page_current->CHANGED=1;
o_undo_savestate(w_current, UNDO_ALL);
diff --git a/gschem/src/o_place.c b/gschem/src/o_place.c
index ef65d2c..ad2dd61 100644
--- a/gschem/src/o_place.c
+++ b/gschem/src/o_place.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -48,7 +48,8 @@ void o_place_start (GSCHEM_TOPLEVEL *w_current, int w_x, int w_y)
void o_place_end (GSCHEM_TOPLEVEL *w_current,
int w_x, int w_y,
int continue_placing,
- GList **ret_new_objects)
+ GList **ret_new_objects,
+ const char* hook_name)
{
TOPLEVEL *toplevel = w_current->toplevel;
int w_diff_x, w_diff_y;
@@ -100,6 +101,10 @@ void o_place_end (GSCHEM_TOPLEVEL *w_current,
connected_objects = s_conn_return_others (connected_objects, o_current);
}
+ if (hook_name != NULL) {
+ g_run_hook_object_list (hook_name, temp_dest_list);
+ }
+
o_invalidate_glist (w_current, connected_objects);
g_list_free (connected_objects);
connected_objects = NULL;
diff --git a/gschem/src/o_slot.c b/gschem/src/o_slot.c
index 9f99e9c..55dffa4 100644
--- a/gschem/src/o_slot.c
+++ b/gschem/src/o_slot.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -125,6 +125,9 @@ void o_slot_end(GSCHEM_TOPLEVEL *w_current, OBJECT *object, const char *string)
/* manually attach attribute */
o_attrib_attach (toplevel, new_obj, object, FALSE);
+
+ /* Call add-objects-hook */
+ g_run_hook_object ("%add-objects-hook", new_obj);
}
s_slot_update_object (toplevel, object);
diff --git a/gschem/src/x_event.c b/gschem/src/x_event.c
index 5cacc17..38e65d6 100644
--- a/gschem/src/x_event.c
+++ b/gschem/src/x_event.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -293,7 +293,8 @@ gint x_event_button_pressed(GtkWidget *widget, GdkEventButton *event,
}
break;
case(ENDCOMP):
- o_complex_end(w_current, w_x, w_y, w_current->continue_component_place);
+ o_place_end(w_current, w_x, w_y, w_current->continue_component_place,
+ NULL, "%add-objects-hook");
if (!w_current->continue_component_place) {
w_current->inside_action = 0;
i_set_state(w_current, SELECT);
@@ -302,7 +303,7 @@ gint x_event_button_pressed(GtkWidget *widget, GdkEventButton *event,
break;
case(ENDPASTE):
- o_place_end(w_current, w_x, w_y, FALSE, NULL);
+ o_place_end(w_current, w_x, w_y, FALSE, NULL, NULL);
w_current->inside_action = 0;
i_set_state(w_current, SELECT);
i_update_toolbar(w_current);
@@ -328,7 +329,7 @@ gint x_event_button_pressed(GtkWidget *widget, GdkEventButton *event,
break;
case(ENDTEXT):
- o_place_end(w_current, w_x, w_y, FALSE, NULL);
+ o_place_end(w_current, w_x, w_y, FALSE, NULL, "%add-objects-hook");
w_current->inside_action = 0;
i_set_state(w_current, SELECT);
i_update_toolbar(w_current);
diff --git a/gschem/src/x_multiattrib.c b/gschem/src/x_multiattrib.c
index 4ca7125..3bf73a5 100644
--- a/gschem/src/x_multiattrib.c
+++ b/gschem/src/x_multiattrib.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -730,6 +730,9 @@ static void multiattrib_action_promote_attribute (GSCHEM_TOPLEVEL *w_current,
/* add the attribute its parent */
o_attrib_attach (toplevel, o_new, object, TRUE);
/* note: this object is unselected (not added to selection). */
+
+ /* Call add-objects-hook */
+ g_run_hook_object ("%add-objects-hook", o_new);
}
w_current->toplevel->page_current->CHANGED = 1;
o_undo_savestate (w_current, UNDO_ALL);
commit 62f51dcfeb8a08288bc1854fd1d49e667b03f490
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Start implementing simplified hook system.
Rather than the current hook system, which uses misleading hook names
and is only useful for a limited range of use cases, use a smaller
number of more general hooks.
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index f80b01c..6659ead 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -42,6 +42,9 @@ g_set_attrib_text_properties(SCM attrib_smob, SCM scm_colorname, SCM scm_size,
SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclude_object_type);
SCM g_add_component(SCM page_smob, SCM scm_comp_name, SCM scm_x, SCM scm_y,
SCM scm_angle, SCM scm_selectable, SCM scm_mirror);
+void g_init_hook ();
+void g_run_hook_object (const char *name, OBJECT *obj);
+void g_run_hook_object_list (const char *name, GList *obj_lst);
/* g_keys.c */
int g_keys_execute(GSCHEM_TOPLEVEL *w_current, int state, int keyval);
GArray *g_keys_dump_keymap (void);
diff --git a/gschem/scheme/Makefile.am b/gschem/scheme/Makefile.am
index 9f8a559..19e8812 100644
--- a/gschem/scheme/Makefile.am
+++ b/gschem/scheme/Makefile.am
@@ -12,7 +12,8 @@ nobase_dist_scmdata_DATA = \
default-attrib-positions.scm \
gschem/window.scm \
gschem/selection.scm \
- gschem/deprecated.scm
+ gschem/deprecated.scm \
+ gschem/hook.scm
MOSTLYCLEANFILES = *.log *~
CLEANFILES = *.log *~
diff --git a/gschem/scheme/gschem/hook.scm b/gschem/scheme/gschem/hook.scm
new file mode 100644
index 0000000..0640b7e
--- /dev/null
+++ b/gschem/scheme/gschem/hook.scm
@@ -0,0 +1,93 @@
+;; gEDA - GPL Electronic Design Automation
+;; gschem - gEDA Schematic Capture - Scheme API
+;; Copyright (C) 2010-2011 Peter Brett
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+;;
+
+(define-module (gschem hook)
+
+ ;; Import C definitions
+ #:use-module (gschem core hook))
+
+;; This module defines a number of hooks that can be used to run
+;; arbitrary Scheme code following a variety of user actions. Note
+;; that hook functions should not normally modify their arguments.
+
+;; add-objects-hook
+;;
+;; Called after objects are added to the page, at their initial
+;; creation. Argument is a list of the objects being added.
+(define-public add-objects-hook %add-objects-hook)
+
+;; remove-objects-hook
+;;
+;; Called after objects are removed from the page. Argument is a list
+;; of the objects being removed.
+(define-public remove-objects-hook %remove-objects-hook)
+
+;; move-objects-hook
+;;
+;; Called after objects are moved. Argument is a list of the objects
+;; that were mirrored.
+(define-public move-objects-hook %move-objects-hook)
+
+;; mirror-objects-hook
+;;
+;; Called after objects are mirrored. Argument is a list of the
+;; objects that were mirrored.
+(define-public mirror-objects-hook %mirror-objects-hook)
+
+;; rotate-objects-hook
+;;
+;; Called after objects are rotated. Argument is a list of the
+;; objects that were rotated.
+(define-public rotate-objects-hook %rotate-objects-hook)
+
+;; paste-objects-hook
+;;
+;; Called after objects are pasted to the page, either via "Edit->Copy
+;; Mode" or similar, or via buffers, or via the clipboard. Argument
+;; is a list of the objects that were pasted.
+(define-public paste-objects-hook %paste-objects-hook)
+
+;; attach-attribs-hook
+;;
+;; Called after attributes are attached to something. The argument is
+;; a list of the attributes that were attached.
+(define-public attach-attribs-hook %attach-attribs-hook)
+
+;; detach-attribs-hook
+;;
+;; Called after attributes are detached from something. The argument
+;; is a list of the attributes that were detached.
+(define-public detach-attribs-hook %detach-attribs-hook)
+
+;; select-objects-hook
+;;
+;; Called after objects are added to the selection. The argument is a
+;; list of objects that were selected.
+(define-public select-objects-hook %select-objects-hook)
+
+;; deselect-objects-hook
+;;
+;; Called after objects are removed from the selection. The argument
+;; is a list of objects that were deselected.
+(define-public deselect-objects-hook %deselect-objects-hook)
+
+;; new-page-hook
+;;
+;; Called when a new page is created. The argument is the new page.
+(define-public new-page-hook %new-page-hook)
diff --git a/gschem/src/Makefile.am b/gschem/src/Makefile.am
index 2ec57a0..3ef894f 100644
--- a/gschem/src/Makefile.am
+++ b/gschem/src/Makefile.am
@@ -1,6 +1,7 @@
bin_PROGRAMS = gschem
BUILT_SOURCES = \
+ g_hook.x \
g_window.x \
g_select.x
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index 8a65e04..9d61a1e 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -30,6 +30,12 @@
#include <dmalloc.h>
#endif
+SCM_SYMBOL (at_sym, "@");
+SCM_SYMBOL (gschem_sym, "gschem");
+SCM_SYMBOL (core_sym, "core");
+SCM_SYMBOL (hook_sym, "hook");
+SCM_SYMBOL (run_hook_sym, "run-hook");
+
/* Private function declarations */
static void custom_world_get_single_object_bounds
(TOPLEVEL *toplevel, OBJECT *o_current,
@@ -603,3 +609,110 @@ SCM g_add_component(SCM page_smob, SCM scm_comp_name, SCM scm_x, SCM scm_y,
return SCM_BOOL_T;
}
+
+/*! \brief Gets a Scheme hook object by name.
+ * \par Function Description
+ * Returns the contents of variable with the given name in the (gschem
+ * core hook). Used for looking up hook objects.
+ *
+ * \param name name of hook to lookup.
+ * \return value found in the (gschem core hook) module.
+ */
+static SCM
+g_get_hook_by_name (const char *name)
+{
+ SCM exp = scm_list_3 (at_sym,
+ scm_list_3 (gschem_sym, core_sym, hook_sym),
+ scm_from_locale_symbol (name));
+ return g_scm_eval_protected (exp, SCM_UNDEFINED);
+}
+
+/*! \brief Runs a object hook for a list of objects.
+ * \par Function Description
+ * Runs a hook called \a name, which should expect a list of #OBJECT
+ * smobs as its argument, with \a obj_lst as the argument list.
+ *
+ * \see g_run_hook_object()
+ *
+ * \param name name of hook to run.
+ * \param obj_lst list of #OBJECT smobs as hook argument.
+ */
+void
+g_run_hook_object_list (const char *name, GList *obj_lst)
+{
+ SCM lst = SCM_EOL;
+ GList *iter;
+ for (iter = obj_lst; iter != NULL; iter = g_list_next (iter)) {
+ lst = scm_cons (edascm_from_object ((OBJECT *) iter->data), lst);
+ }
+ SCM args = scm_list_1 (scm_reverse_x (lst, SCM_EOL));
+
+ scm_run_hook (g_get_hook_by_name (name), args);
+ scm_remember_upto_here_2 (lst, args);
+}
+
+/*! \brief Runs a object hook with a single OBJECT.
+ * \par Function Description
+ * Runs a hook called \a name, which should expect a list of #OBJECT
+ * smobs as its argument, with a single-element list containing only \a obj.
+ *
+ * \see g_run_hook_object_list()
+ *
+ * \param name name of hook to run.
+ * \param obj #OBJECT argument for hook.
+ */
+void
+g_run_hook_object (const char *name, OBJECT *obj)
+{
+ SCM args = scm_list_1 (scm_list_1 (edascm_from_object (obj)));
+ scm_run_hook (g_get_hook_by_name (name), args);
+ scm_remember_upto_here_1 (args);
+}
+
+/*! \brief Create the (gschem core hook) Scheme module.
+ * \par Function Description
+ * Defines some hooks in the (gschem core hook) module. These hooks
+ * allow Scheme callbacks to be triggered on certain gschem actions.
+ * For a description of the arguments and behaviour of these hooks,
+ * please see ../scheme/gschem/hook.scm.
+ */
+static void
+init_module_gschem_core_hook ()
+{
+
+#include "g_hook.x"
+
+#define DEFINE_HOOK(name) \
+ do { \
+ scm_c_define (name, scm_make_hook (scm_from_int (1))); \
+ scm_c_export (name, NULL); \
+ } while (0)
+
+ DEFINE_HOOK ("%add-objects-hook");
+ DEFINE_HOOK ("%remove-objects-hook");
+ DEFINE_HOOK ("%move-objects-hook");
+ DEFINE_HOOK ("%mirror-objects-hook");
+ DEFINE_HOOK ("%rotate-objects-hook");
+ DEFINE_HOOK ("%paste-objects-hook");
+ DEFINE_HOOK ("%attach-attribs-hook");
+ DEFINE_HOOK ("%detach-attribs-hook");
+ DEFINE_HOOK ("%select-objects-hook");
+ DEFINE_HOOK ("%deselect-objects-hook");
+ DEFINE_HOOK ("%new-page-hook");
+}
+
+/*!
+ * \brief Initialise the gschem hooks.
+ * \par Function Description
+
+ * Registers gschem's Guile hooks for various events.. Should only be
+ * called by main_prog().
+ */
+void
+g_init_hook ()
+{
+ /* Define the (gschem core hook) module */
+ scm_c_define_module ("gschem core hook",
+ init_module_gschem_core_hook,
+ NULL);
+}
diff --git a/gschem/src/gschem.c b/gschem/src/gschem.c
index e2624b6..63553e2 100644
--- a/gschem/src/gschem.c
+++ b/gschem/src/gschem.c
@@ -1,7 +1,7 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
* Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ * Copyright (C) 1998-2011 gEDA Contributors (see ChangeLog for details)
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -195,6 +195,7 @@ void main_prog(void *closure, int argc, char *argv[])
g_register_funcs();
g_init_window ();
g_init_select ();
+ g_init_hook ();
/* initialise color map (need to do this before reading rc files */
x_color_init ();
commit 1121d83a5450ad9040cabb7ef9a8cfb6c2a395f3
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Only use (ice-9 syncase) if define-syntax missing.
In Guile 2.0, syntax-case is built in by default and importing the
(ice-9 syncase) module isn't required.
diff --git a/gnetlist/scheme/gnet-drc2.scm b/gnetlist/scheme/gnet-drc2.scm
index 9c0e103..d63bf19 100644
--- a/gnetlist/scheme/gnet-drc2.scm
+++ b/gnetlist/scheme/gnet-drc2.scm
@@ -168,7 +168,8 @@
;; -------------------------------------------------------------------------------
(use-modules (srfi srfi-1))
-(use-modules (ice-9 syncase))
+(or (defined? 'define-syntax)
+ (use-modules (ice-9 syncase)))
(define-syntax define-undefined
(syntax-rules ()
diff --git a/gschem/lib/system-gschemrc.scm b/gschem/lib/system-gschemrc.scm
index dcf2938..532f93b 100644
--- a/gschem/lib/system-gschemrc.scm
+++ b/gschem/lib/system-gschemrc.scm
@@ -1358,7 +1358,8 @@
; The SEPARATOR keyword is case sensitive and puts a seperator into the menu.
;
-(use-modules (ice-9 syncase))
+(or (defined? 'define-syntax)
+ (use-modules (ice-9 syncase)))
;; Define a no-op macro for flagging strings as translatable.
(define-syntax N_
diff --git a/libgeda/scheme/unit-test.scm b/libgeda/scheme/unit-test.scm
index ccde6da..2849c8b 100644
--- a/libgeda/scheme/unit-test.scm
+++ b/libgeda/scheme/unit-test.scm
@@ -42,7 +42,6 @@
(define-module (unit-test)
#:use-module (ice-9 pretty-print)
- #:use-module (ice-9 syncase)
#:export (assert-true
assert-equal
%assert-thrown
@@ -53,6 +52,9 @@
begin-test
assert-thrown))
+(or (defined? 'define-syntax)
+ (use-modules (ice-9 syncase)))
+
(define *failed-tests* '())
(define *passed-tests* '())
(define *skipped-tests* '())
diff --git a/libgeda/scheme/unit-tests/t0021-page-dirty.scm b/libgeda/scheme/unit-tests/t0021-page-dirty.scm
index 27bbd5d..78189c2 100644
--- a/libgeda/scheme/unit-tests/t0021-page-dirty.scm
+++ b/libgeda/scheme/unit-tests/t0021-page-dirty.scm
@@ -4,7 +4,8 @@
(use-modules (geda page))
(use-modules (geda object))
(use-modules (geda attrib))
-(use-modules (ice-9 syncase))
+(or (defined? 'define-syntax)
+ (use-modules (ice-9 syncase)))
;; Utility macro to avoid boilerplate
(define-syntax assert-dirties
commit cbdeedd05e825c0d11080392c16cd86a1968ba73
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Change format of unit test output.
If running a test caused output to stdout or stderr, it was interposed
between the name of the test and the result. This patch makes the
name and result of the test be printed together after the result has
been determined, resulting in tidier output.
diff --git a/libgeda/scheme/unit-test.scm b/libgeda/scheme/unit-test.scm
index cb0ee15..ccde6da 100644
--- a/libgeda/scheme/unit-test.scm
+++ b/libgeda/scheme/unit-test.scm
@@ -31,12 +31,13 @@
;;
;; Produces the output:
;;
-;; SuccessfulTest... passed
-;; FailTest... failed
+;; PASS: SuccessfulTest
+;; FAIL: FailTest
;; assert-equal: expected: #t got: "string"
;; Test summary
;; Passed: 1
;; Failed: 1
+;; Skipped: 0
;;
(define-module (unit-test)
@@ -82,7 +83,6 @@
(gc)
(let ((test-success #t)
(test-fail-msg #f))
- (display name) (display "... ")
(catch #t test-thunk
(lambda (key . args)
@@ -94,16 +94,13 @@
(if test-success
(begin
- (display "passed")
+ (format #t "PASS: ~A\n" name)
(set! *passed-tests* (cons name *passed-tests*)))
(begin
- (display "failed")
- (if test-fail-msg
- (begin
- (newline)
- (display test-fail-msg)))
- (set! *failed-tests* (cons name *failed-tests*))))
- (newline)))
+ (format #t "FAIL: ~A\n" name)
+ (and test-fail-msg
+ (format #t "~A\n" test-fail-msg))
+ (set! *failed-tests* (cons name *failed-tests*))))))
(define-syntax begin-test
(syntax-rules ()
@@ -114,7 +111,7 @@
(syntax-rules ()
((_ name . test-forms)
(begin
- (format #t "~A... skipped\n" name)
+ (format #t "SKIP: ~A\n" name)
(set! *skipped-tests* (cons name *skipped-tests*))))))
(define-syntax assert-thrown
commit 14eab2daf97f03ef7cdb26c2c3e8969f99b22a70
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add skip-test macro to unit-test.scm
diff --git a/libgeda/scheme/unit-test.scm b/libgeda/scheme/unit-test.scm
index 48fb271..cb0ee15 100644
--- a/libgeda/scheme/unit-test.scm
+++ b/libgeda/scheme/unit-test.scm
@@ -48,11 +48,13 @@
tests-passed?
report-tests
%begin-test)
- #:export-syntax (begin-test
+ #:export-syntax (skip-test
+ begin-test
assert-thrown))
(define *failed-tests* '())
(define *passed-tests* '())
+(define *skipped-tests* '())
(define (assert-true result)
(if result
@@ -77,6 +79,7 @@
(lambda (key . args) #t)))
(define (%begin-test name test-thunk)
+ (gc)
(let ((test-success #t)
(test-fail-msg #f))
(display name) (display "... ")
@@ -107,6 +110,13 @@
((_ name . test-forms)
(%begin-test name (lambda () . test-forms)))))
+(define-syntax skip-test
+ (syntax-rules ()
+ ((_ name . test-forms)
+ (begin
+ (format #t "~A... skipped\n" name)
+ (set! *skipped-tests* (cons name *skipped-tests*))))))
+
(define-syntax assert-thrown
(syntax-rules ()
((_ key . test-forms)
@@ -116,5 +126,6 @@
(define (report-tests)
(display "Test summary")(newline)
- (display "Passed: ") (display (length *passed-tests*)) (newline)
- (display "Failed: ") (display (length *failed-tests*)) (newline))
+ (display "Passed: ") (display (length *passed-tests*)) (newline)
+ (display "Failed: ") (display (length *failed-tests*)) (newline)
+ (display "Skipped: ") (display (length *skipped-tests*)) (newline))
commit e9f2f0b1285b877a12f0338635af0eade60c7c68
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Fix (gschem deprecated) module.
The set-attribute-value! function contained a let with invalid syntax.
Guile 2.0 rightly gets upset by this.
diff --git a/gschem/scheme/gschem/deprecated.scm b/gschem/scheme/gschem/deprecated.scm
index 7405185..33d494f 100644
--- a/gschem/scheme/gschem/deprecated.scm
+++ b/gschem/scheme/gschem/deprecated.scm
@@ -29,9 +29,9 @@
(define-public (set-attribute-value! attrib value)
(let ((params (text-info attrib))
- (name-value (attrib-parse attrib))
- (list-set! params 3 (simple-format "~A=~A" (car name-value) value))
- (apply set-text! attrib params))))
+ (name-value (attrib-parse attrib)))
+ (list-set! params 3 (simple-format "~A=~A" (car name-value) value))
+ (apply set-text! attrib params)))
(define-public (get-objects-in-page page)
(reverse! (page-contents page)))
commit 0344623ea013e54a15735988b75508c07469d4d8
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make tests work with Guile 2.0.
#:use-syntax doesn't work with Guile 2.0, apparently.
diff --git a/libgeda/scheme/unit-test.scm b/libgeda/scheme/unit-test.scm
index f7cf499..48fb271 100644
--- a/libgeda/scheme/unit-test.scm
+++ b/libgeda/scheme/unit-test.scm
@@ -41,7 +41,7 @@
(define-module (unit-test)
#:use-module (ice-9 pretty-print)
- #:use-syntax (ice-9 syncase)
+ #:use-module (ice-9 syncase)
#:export (assert-true
assert-equal
%assert-thrown
commit 9415bf958a9cf16461733be58d0f8f257b5b4726
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gnetlist: Fix up tests to work with new Scheme API.
Now that gnetlist supports the -L <path> option to add to the Guile
load path, it's possible to make in-tree and out-of-tree builds pass
`make check'.
diff --git a/gnetlist/tests/Makefile.am b/gnetlist/tests/Makefile.am
index ff06ae7..2bd1117 100644
--- a/gnetlist/tests/Makefile.am
+++ b/gnetlist/tests/Makefile.am
@@ -138,7 +138,8 @@ tests_ales:
$(BUILDDIR) $(SRCDIR)
# switcap (does not work with make distcheck due to local test.ana file)
- $(GNETLIST) -o $(BUILDDIR)/new_skt.switcap -g switcap \
+ $(GNETLIST) -L $(top_srcdir)/libgeda/scheme \
+ -o $(BUILDDIR)/new_skt.switcap -g switcap \
$(SRCDIR)/../examples/switcap/ckt.sch \
$(SRCDIR)/../examples/switcap/clocks.sch \
$(SRCDIR)/../examples/switcap/analysis.sch
diff --git a/gnetlist/tests/drc2/Makefile.am b/gnetlist/tests/drc2/Makefile.am
index a7438ae..3d3665e 100644
--- a/gnetlist/tests/drc2/Makefile.am
+++ b/gnetlist/tests/drc2/Makefile.am
@@ -65,8 +65,10 @@ tests:
GEDADATARC=$(top_builddir)/gnetlist/lib \
SCMDIR=${top_builddir}/gnetlist/scheme \
SYMDIR=${top_srcdir}/symbols \
- $(GNETLIST) -g drc2 -o $(BUILDDIR)/new_$$file_basename.drc2 \
- $$file ); \
+ $(GNETLIST) -L$(top_srcdir)/libgeda/scheme \
+ -g drc2 \
+ -o $(BUILDDIR)/new_$$file_basename.drc2 \
+ $$file ); \
diff $(SRCDIR)/$$file_basename.drc2 \
$(BUILDDIR)/new_$$file_basename.drc2; \
if [ $$? -ne 0 ]; then \
diff --git a/gnetlist/tests/hierarchy/Makefile.am b/gnetlist/tests/hierarchy/Makefile.am
index c11abd3..33a6889 100644
--- a/gnetlist/tests/hierarchy/Makefile.am
+++ b/gnetlist/tests/hierarchy/Makefile.am
@@ -20,7 +20,10 @@ tests:
GEDADATARC=$(top_builddir)/gnetlist/lib \
SCMDIR=${top_builddir}/gnetlist/scheme \
SYMDIR=$(top_srcdir)/symbols \
- $(GNETLIST) -o $(BUILDDIR)/new_hierarchy.geda -g geda $(SRCDIR)/top.sch )
+ $(GNETLIST) \
+ -L $(top_srcdir)/libgeda/scheme \
+ -o $(BUILDDIR)/new_hierarchy.geda \
+ -g geda $(SRCDIR)/top.sch )
diff $(SRCDIR)/hierarchy.geda $(BUILDDIR)/new_hierarchy.geda;
rm -f $(BUILDDIR)/gnetlistrc
diff --git a/gnetlist/tests/hierarchy2/Makefile.am b/gnetlist/tests/hierarchy2/Makefile.am
index 122cb2e..8fb1ecd 100644
--- a/gnetlist/tests/hierarchy2/Makefile.am
+++ b/gnetlist/tests/hierarchy2/Makefile.am
@@ -18,6 +18,7 @@ tests:
SCMDIR=${top_builddir}/gnetlist/scheme \
SYMDIR=${top_srcdir}/symbols \
$(GNETLIST) \
+ -L $(top_srcdir)/libgeda/scheme \
-o $(BUILDDIR)/new_hierarchy2.geda -g geda \
$(SRCDIR)/top.sch )
diff $(SRCDIR)/hierarchy2.geda $(BUILDDIR)/new_hierarchy2.geda;
diff --git a/gnetlist/tests/runtest.sh b/gnetlist/tests/runtest.sh
index b0ff718..713e5ae 100755
--- a/gnetlist/tests/runtest.sh
+++ b/gnetlist/tests/runtest.sh
@@ -14,7 +14,8 @@ schbasename=`basename $INPUT .sch`
SCMDIR=$SRCDIR/../scheme \
SYMDIR=$SRCDIR/../../symbols \
GEDADATARC=$BUILDDIR/../lib \
-../src/gnetlist -o ${BUILDDIR}/new_${schbasename}.$BACKEND -g $BACKEND $INPUT
+../src/gnetlist -L ${SRCDIR}/../../libgeda/scheme \
+ -o ${BUILDDIR}/new_${schbasename}.$BACKEND -g $BACKEND $INPUT
status=$?
if [ "$status" != 0 ]
commit e67d080a7c48dd1300c90c93d8b1723958244a2d
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
libgeda: cleanfiles -> CLEANFILES
Wrong case in automake input resulted in some generated files not
being removed during `make clean'.
diff --git a/libgeda/shell/Makefile.am b/libgeda/shell/Makefile.am
index 9e6f33f..badcc4f 100644
--- a/libgeda/shell/Makefile.am
+++ b/libgeda/shell/Makefile.am
@@ -25,4 +25,4 @@ snarf_cpp_opts = $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
.c.x:
$(GUILE_SNARF) -o $@ $< $(snarf_cpp_opts)
-cleanfiles = $(BUILT_SOURCES)
+CLEANFILES = $(BUILT_SOURCES)
commit 694ccbdec90765ca4cb9b2dbcb1bbe7cdfba2f0b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: OBJECT.sel_func doesn't exist any more.
diff --git a/libgeda/src/scheme_complex.c b/libgeda/src/scheme_complex.c
index d76539a..643316c 100644
--- a/libgeda/src/scheme_complex.c
+++ b/libgeda/src/scheme_complex.c
@@ -159,7 +159,7 @@ SCM_DEFINE (set_complex_x, "%set-complex!", 6, 0, 0,
obj);
obj->complex->angle = angle;
obj->complex->mirror = scm_is_true (mirror_s);
- obj->sel_func = scm_is_true (locked_s) ? NULL : select_func;
+ obj->selectable = scm_is_false (locked_s);
o_complex_recalc (toplevel, obj); /* We need to do this explicitly... */
@@ -201,7 +201,7 @@ SCM_DEFINE (complex_info, "%complex-info", 1, 0, 0,
scm_from_int (obj->complex->y),
scm_from_int (obj->complex->angle),
obj->complex->mirror ? SCM_BOOL_T : SCM_BOOL_F,
- (obj->sel_func == NULL) ? SCM_BOOL_T : SCM_BOOL_F,
+ obj->selectable ? SCM_BOOL_F : SCM_BOOL_T,
SCM_UNDEFINED);
}
commit 19963e962d5baf1cad6de44a2e411f7e5610159c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gnetlist: Fix testsuite for Scheme API branch.
Some Scheme procedures used by gnetlist were moved to the (geda
deprecated) module, but the relevant Scheme files couldn't be found by
the gnetlist testsuite. This patch makes sure the gnetlist
environment gets set up correctly.
diff --git a/gnetlist/scheme/gnetlist.scm b/gnetlist/scheme/gnetlist.scm
index eaa83ef..1f82279 100644
--- a/gnetlist/scheme/gnetlist.scm
+++ b/gnetlist/scheme/gnetlist.scm
@@ -18,6 +18,7 @@
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
(use-modules (srfi srfi-1))
+(use-modules (geda deprecated))
;;----------------------------------------------------------------------
;; The below functions added by SDB in Sept 2003 to support command-line flag
diff --git a/gnetlist/tests/common/inputs/gafrc b/gnetlist/tests/common/inputs/gafrc
index e5072b9..0f99185 100644
--- a/gnetlist/tests/common/inputs/gafrc
+++ b/gnetlist/tests/common/inputs/gafrc
@@ -1,6 +1,7 @@
;; We want to point at the scheme code that hasn't been installed yet so that
;; 'make check' during development can work correctly.
(scheme-directory "${SCMDIR}")
+(scheme-directory "${GEDASCMDIR}")
;; We want to use the symbols that haven't been installed yet
(map (lambda (x) (component-library (string-join (list "${SYMDIR}/" x) "")))
diff --git a/gnetlist/tests/common/run_backend_tests.sh b/gnetlist/tests/common/run_backend_tests.sh
index 219e3b1..1882634 100755
--- a/gnetlist/tests/common/run_backend_tests.sh
+++ b/gnetlist/tests/common/run_backend_tests.sh
@@ -93,10 +93,12 @@ GNETLIST="${builddir}/../../src/gnetlist"
GEDADATA="${srcdir}/../.." # HACKHACKHACK
GEDADATARC="${builddir}/../../lib"
SCMDIR="${builddir}/../../scheme"
+GEDASCMDIR="${srcdir}/../../../libgeda/scheme"
SYMDIR="${srcdir}/../../../symbols"
export GEDADATA
export GEDADATARC
export SCMDIR
+export GEDASCMDIR
export SYMDIR
rundir=${here}/run
@@ -141,6 +143,7 @@ GNETLIST: ${GNETLIST}
GEDADATA: ${GEDATADA}
GEDADATARC: ${GEDATADARC}
SCMDIR: ${SCMDIR}
+GEDASCMDIR: ${GEDASCMDIR}
SYMDIR: ${SYMDIR}
all_tests:
commit b08d9d08ee4740884de97e87179a9809d6b3dba3
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
libgeda: Use new config parsing API for geda-shell.
diff --git a/libgeda/shell/shell.c b/libgeda/shell/shell.c
index 611750e..b125425 100644
--- a/libgeda/shell/shell.c
+++ b/libgeda/shell/shell.c
@@ -210,11 +210,9 @@ shell_main (void *data, int argc, char **argv)
}
/* Now load rc files, if necessary */
- if (!inhibit_rc) {
- g_rc_parse_system_rc (toplevel, "gafrc");
- g_rc_parse_home_rc (toplevel, "gafrc");
- g_rc_parse_local_rc (toplevel, "gafrc");
- }
+ if (!inhibit_rc)
+ g_rc_parse (toplevel, argv[0], NULL, NULL);
+
i_vars_libgeda_set (toplevel); /* Ugh */
/* Finally evaluate run list */
commit f9156f1642e0a24661f06cc335178a14d5fa7b1c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Remove some legacy Scheme functions.
Remove some trivially-replaced Scheme functions from gschem to the
(gschem deprecated) module.
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index 08f2d90..8f199c8 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -35,17 +35,13 @@ SCM get_selected_filename(GSCHEM_TOPLEVEL *w_current);
SCM g_make_attrib_smob_list(GSCHEM_TOPLEVEL *w_current, OBJECT *object);
SCM g_add_attrib(SCM object, SCM attrib_name,
SCM attrib_value, SCM scm_vis, SCM scm_show);
-SCM g_get_pin_ends(SCM object);
SCM
g_set_attrib_text_properties(SCM attrib_smob, SCM scm_colorname, SCM scm_size,
SCM scm_alignment, SCM scm_rotation, SCM scm_x,
SCM scm_y);
SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclude_object_type);
-SCM g_get_object_pins (SCM object_smob);
SCM g_add_component(SCM page_smob, SCM scm_comp_name, SCM scm_x, SCM scm_y,
SCM scm_angle, SCM scm_selectable, SCM scm_mirror);
-SCM g_get_objects_in_page(SCM page_smob);
-SCM g_get_current_page(void);
/* g_keys.c */
int g_keys_execute(GSCHEM_TOPLEVEL *w_current, int state, int keyval);
GArray *g_keys_dump_keymap (void);
diff --git a/gschem/scheme/gschem/deprecated.scm b/gschem/scheme/gschem/deprecated.scm
index 87ca831..7405185 100644
--- a/gschem/scheme/gschem/deprecated.scm
+++ b/gschem/scheme/gschem/deprecated.scm
@@ -24,10 +24,25 @@
#:use-module (geda page)
#:use-module (geda object)
- #:use-module (geda attrib))
+ #:use-module (geda attrib)
+ #:use-module (gschem window))
(define-public (set-attribute-value! attrib value)
(let ((params (text-info attrib))
(name-value (attrib-parse attrib))
(list-set! params 3 (simple-format "~A=~A" (car name-value) value))
(apply set-text! attrib params))))
+
+(define-public (get-objects-in-page page)
+ (reverse! (page-contents page)))
+
+(define-public get-current-page active-page)
+
+(define-public (get-object-pins object)
+ (if (component? object)
+ (reverse! (filter! pin? (component-contents object)))
+ '()))
+
+(define-public (get-pin-ends pin)
+ (let ((params (line-info pin)))
+ (cons (list-ref params 0) (list-ref params 1))))
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index c6ee1f0..8ffc5ef 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -177,50 +177,6 @@ SCM g_add_attrib(SCM object, SCM scm_attrib_name,
*
*/
/*
- * Returns a list with coords of the ends of the given pin <B>object</B>.
-The list is ( (x0 y0) (x1 y1) ), where the beginning is at (x0,y0) and the end at (x1,y1).
-The active connection end of the pin is the beginning, so this function cares about the whichend property of the pin object. If whichend is 1, then it has to reverse the ends.
- */
-SCM g_get_pin_ends(SCM object)
-{
- TOPLEVEL *toplevel = edascm_c_current_toplevel ();
- OBJECT *o_current;
- SCM coord1 = SCM_EOL;
- SCM coord2 = SCM_EOL;
- SCM coords = SCM_EOL;
-
- /* Get toplevel and o_current */
- SCM_ASSERT (edascm_is_object (object),
- object, SCM_ARG1, "get-pin-ends");
- o_current = edascm_to_object (object);
-
- /* Check that it is a pin object */
- SCM_ASSERT (o_current != NULL,
- object, SCM_ARG1, "get-pin-ends");
- SCM_ASSERT (o_current->type == OBJ_PIN,
- object, SCM_ARG1, "get-pin-ends");
- SCM_ASSERT (o_current->line != NULL,
- object, SCM_ARG1, "get-pin-ends");
-
- coord1 = scm_cons(scm_from_int(o_current->line->x[0]),
- scm_from_int(o_current->line->y[0]));
- coord2 = scm_cons(scm_from_int(o_current->line->x[1]),
- scm_from_int(o_current->line->y[1]));
- if (o_current->whichend == 0) {
- coords = scm_cons(coord1, scm_list(coord2));
- } else {
- coords = scm_cons(coord2, scm_list(coord1));
- }
-
- return coords;
-}
-
-/*! \todo Finish function documentation!!!
- * \brief
- * \par Function Description
- *
- */
-/*
* Sets several text properties of the given <B>attribute smob</B>:
- <B>coloridx</B>: The index of the text color, or -1 to keep previous color.
- <B>size</B>: Size (numeric) of the text, or -1 to keep the previous size.
@@ -561,44 +517,6 @@ SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclu
return (returned);
}
-/*! \todo Finish function documentation!!!
- * \brief
- * \par Function Description
- *
- */
-/*
- *Returns a list of the pins of the <B>object smob</B>.
- */
-SCM g_get_object_pins (SCM object_smob)
-{
- TOPLEVEL *toplevel=edascm_c_current_toplevel ();
- OBJECT *object=NULL;
- OBJECT *prim_obj;
- GList *iter;
- SCM returned=SCM_EOL;
-
- /* Get toplevel and o_current */
- SCM_ASSERT (edascm_is_object (object_smob),
- object_smob, SCM_ARG1, "get-object-pins");
- object = edascm_to_object (object_smob);
-
- if (!object) {
- return (returned);
- }
- if (object->complex && object->complex->prim_objs) {
- iter = object->complex->prim_objs;
- while (iter != NULL) {
- prim_obj = (OBJECT *)iter->data;
- if (prim_obj->type == OBJ_PIN) {
- returned = scm_cons (edascm_from_object (prim_obj), returned);
- }
- iter = g_list_next (iter);
- }
- }
-
- return (returned);
-}
-
/*! \brief Add a component to the page.
* \par Function Description
* Adds a component <B>scm_comp_name</B> to the schematic, at
@@ -685,42 +603,3 @@ SCM g_add_component(SCM page_smob, SCM scm_comp_name, SCM scm_x, SCM scm_y,
return SCM_BOOL_T;
}
-
-/*! \brief Return the objects in a page.
- * \par Function Description
- * Returns an object smob list with all the objects in the given page.
- * \param [in] page_smob Page to look at.
- * \return the object smob list with the objects in the page.
- *
- */
-SCM g_get_objects_in_page(SCM page_smob) {
-
- TOPLEVEL *toplevel = edascm_c_current_toplevel ();
- PAGE *page;
- OBJECT *object;
- const GList *iter;
- SCM return_list=SCM_EOL;
-
- /* Get toplevel and the page */
- SCM_ASSERT (edascm_is_page (page_smob),
- page_smob, SCM_ARG1, "add-component");
- page = edascm_to_page (page_smob);
-
- if (page && s_page_objects (page)) {
- iter = s_page_objects (page);
- while (iter != NULL) {
- object = (OBJECT *)iter->data;
- return_list = scm_cons (edascm_from_object (object),
- return_list);
- iter = g_list_next (iter);
- }
- }
-
- return return_list;
-}
-
-SCM g_get_current_page(void)
-{
- TOPLEVEL *toplevel = edascm_c_current_toplevel ();
- return (edascm_from_page (toplevel->page_current));
-}
diff --git a/gschem/src/g_register.c b/gschem/src/g_register.c
index 3e9b09a..dcaaa61 100644
--- a/gschem/src/g_register.c
+++ b/gschem/src/g_register.c
@@ -337,12 +337,8 @@ void g_register_funcs (void)
/* Hook stuff */
scm_c_define_gsubr ("add-attribute-to-object", 5, 0, 0, g_add_attrib);
scm_c_define_gsubr ("get-object-bounds", 3, 0, 0, g_get_object_bounds);
- scm_c_define_gsubr ("get-object-pins", 1, 0, 0, g_get_object_pins);
- scm_c_define_gsubr ("get-pin-ends", 1, 0, 0, g_get_pin_ends);
scm_c_define_gsubr ("set-attribute-text-properties!", 7, 0, 0, g_set_attrib_text_properties);
scm_c_define_gsubr ("add-component-at-xy", 7, 0, 0, g_add_component);
- scm_c_define_gsubr ("get-objects-in-page", 1, 0, 0, g_get_objects_in_page);
- scm_c_define_gsubr ("get-current-page", 0, 0, 0, g_get_current_page);
add_component_hook = create_hook ("add-component-hook", 1);
add_component_object_hook = create_hook ("add-component-object-hook", 1);
commit cb21936a1e620374a04c4f058458fa72f9933e67
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Make 7-byte SHA-1 prefix using %.7s format specifier.
diff --git a/libgeda/shell/shell.c b/libgeda/shell/shell.c
index 2634004..611750e 100644
--- a/libgeda/shell/shell.c
+++ b/libgeda/shell/shell.c
@@ -66,16 +66,14 @@ usage (int exit_status)
static void
version ()
{
- char *git7 = g_strndup (PACKAGE_GIT_COMMIT, 7);
printf(
-"gEDA %s (g%s)\n"
+"gEDA %s (g%.7s)\n"
"Copyright (C) 1998-2010 gEDA developers\n"
"This is free software, and you are welcome to redistribute it under\n"
"certain conditions. For details, see the file `COPYING', which is\n"
"included in the gEDA distribution.\n"
"There is NO WARRANTY, to the extent permitted by law.\n",
- PACKAGE_DOTTED_VERSION, git7);
- g_free (git7);
+ PACKAGE_DOTTED_VERSION, PACKAGE_GIT_COMMIT);
exit (0);
}
commit b70513b5260d14e22dde1bc73c9f6c61dbbeb5ca
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Give geda-shell program -V argument to match gschem.
diff --git a/libgeda/shell/shell.c b/libgeda/shell/shell.c
index 9335e37..2634004 100644
--- a/libgeda/shell/shell.c
+++ b/libgeda/shell/shell.c
@@ -33,7 +33,7 @@
#include <libgeda/libgeda.h>
#include <libgeda/libgedaguile.h>
-#define GETOPT_OPTIONS "s:c:L:l:qhv"
+#define GETOPT_OPTIONS "s:c:L:l:qhV"
/* Print help info and exit with exit_status */
static void
@@ -55,7 +55,7 @@ usage (int exit_status)
" -l FILE load Scheme source code from FILE\n"
" -q inhibit loading of gafrc files\n"
" -h display this message and exit\n"
-" -v display version information and exit\n"
+" -V display version information and exit\n"
"\n"
"Please report bugs to geda-bug@xxxxxxxx\n"
);
@@ -66,15 +66,17 @@ usage (int exit_status)
static void
version ()
{
- printf (
-"gEDA " PACKAGE_GIT_VERSION "\n"
+ char *git7 = g_strndup (PACKAGE_GIT_COMMIT, 7);
+ printf(
+"gEDA %s (g%s)\n"
"Copyright (C) 1998-2010 gEDA developers\n"
"This is free software, and you are welcome to redistribute it under\n"
"certain conditions. For details, see the file `COPYING', which is\n"
"included in the gEDA distribution.\n"
-"There is NO WARRANTY, to the extent permitted by law.\n"
- );
- exit(0);
+"There is NO WARRANTY, to the extent permitted by law.\n",
+ PACKAGE_DOTTED_VERSION, git7);
+ g_free (git7);
+ exit (0);
}
/* Some symbols we need */
@@ -142,7 +144,7 @@ shell_main (void *data, int argc, char **argv)
break;
case 'h':
usage (0);
- case 'v':
+ case 'V':
version();
case '?':
if ((optopt != ':') && (strchr (GETOPT_OPTIONS, optopt) != NULL)) {
commit 8c4d33a5f7835b477d6e485ef47ca8c1db3f16a8
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
build-sys: Check for guile-1.8-snarf for OS X builds.
On OS X, guile-snarf is called guile-1.8-snarf.
Reported-by: Matthew Wampler-Doty <matt@xxxxxxx>
diff --git a/m4/geda-guile-snarf.m4 b/m4/geda-guile-snarf.m4
index 8c9e92b..0956a24 100644
--- a/m4/geda-guile-snarf.m4
+++ b/m4/geda-guile-snarf.m4
@@ -24,8 +24,8 @@ AC_DEFUN([AX_PROG_GUILE_SNARF],
AC_ARG_VAR([GUILE_SNARF], [path to guile-snarf utility])
- AC_CHECK_PROG([GUILE_SNARF], [guile-snarf], [guile-snarf], [no])
- if test "x$GUILE_SNARF" = x ; then
+ AC_CHECK_PROGS([GUILE_SNARF], [guile-snarf guile-1.8-snarf], [no])
+ if test "x$GUILE_SNARF" = xno ; then
AC_MSG_ERROR([The `guile-snarf' tool could not be found. Please ensure that the
Guile development headers and tools are correctly installed, and rerun
configure.])
commit a3433b6a4c088b8926f8768e20eff18d0dafea4b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Remove most legacy libgeda Scheme types & functions.
Removes most of the legacy Scheme types, functions and definitions
from libgeda, replacing them with compatible equivalents based on the
new Scheme API. The remaining Scheme functions are those for working
with the component and source libraries, the various rc functions, and
the eval-* functions, all of which need to be revisited at a later
date.
Also removes set-attribute-value! from gschem and reimplements in
Scheme, since it was sole user of g_set_attrib_value_internal() and it
was easier to replace than rewrite.
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index cfc4352..08f2d90 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -33,7 +33,6 @@ SCM get_selected_component_attributes(GSCHEM_TOPLEVEL *w_current);
SCM get_selected_filename(GSCHEM_TOPLEVEL *w_current);
/* g_hook.c */
SCM g_make_attrib_smob_list(GSCHEM_TOPLEVEL *w_current, OBJECT *object);
-SCM g_set_attrib_value_x(SCM attrib_smob, SCM scm_value);
SCM g_add_attrib(SCM object, SCM attrib_name,
SCM attrib_value, SCM scm_vis, SCM scm_show);
SCM g_get_pin_ends(SCM object);
diff --git a/gschem/lib/system-gschemrc.scm b/gschem/lib/system-gschemrc.scm
index 64861fe..860cf2a 100644
--- a/gschem/lib/system-gschemrc.scm
+++ b/gschem/lib/system-gschemrc.scm
@@ -3,6 +3,8 @@
; Init file for gschem
;
+(use-modules (gschem deprecated))
+
; ;'s are comments
; keywords are case sensitive (guile feature)
; mode strings are case sensitive
diff --git a/gschem/scheme/Makefile.am b/gschem/scheme/Makefile.am
index 0cd3142..9f8a559 100644
--- a/gschem/scheme/Makefile.am
+++ b/gschem/scheme/Makefile.am
@@ -11,7 +11,8 @@ nobase_dist_scmdata_DATA = \
pcb.scm \
default-attrib-positions.scm \
gschem/window.scm \
- gschem/selection.scm
+ gschem/selection.scm \
+ gschem/deprecated.scm
MOSTLYCLEANFILES = *.log *~
CLEANFILES = *.log *~
diff --git a/gschem/scheme/gschem/deprecated.scm b/gschem/scheme/gschem/deprecated.scm
new file mode 100644
index 0000000..87ca831
--- /dev/null
+++ b/gschem/scheme/gschem/deprecated.scm
@@ -0,0 +1,33 @@
+;; gEDA - GPL Electronic Design Automation
+;; gschem - gEDA Schematic Capture - Scheme API
+;; Copyright (C) 2010 Peter Brett
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+;;
+
+;; This file contains deprecated Scheme API features, which should not
+;; be used in new code.
+
+(define-module (gschem deprecated)
+
+ #:use-module (geda page)
+ #:use-module (geda object)
+ #:use-module (geda attrib))
+
+(define-public (set-attribute-value! attrib value)
+ (let ((params (text-info attrib))
+ (name-value (attrib-parse attrib))
+ (list-set! params 3 (simple-format "~A=~A" (car name-value) value))
+ (apply set-text! attrib params))))
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index 52cfeaf..c6ee1f0 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -88,34 +88,6 @@ SCM g_make_attrib_smob_list (GSCHEM_TOPLEVEL *w_current, OBJECT *object)
* \par Function Description
*
*/
-/**************************************************************************
- * This function partly part of libgeda, since it belongs to the smob *
- * definition. But since I use o_text_change, which is defined in gschem, *
- * we have to do it like this. *
- **************************************************************************/
-SCM g_set_attrib_value_x(SCM attrib_smob, SCM scm_value)
-{
- SCM returned;
- TOPLEVEL *toplevel;
- OBJECT *o_attrib;
- char *new_string;
-
- returned = g_set_attrib_value_internal(attrib_smob, scm_value,
- &toplevel, &o_attrib, &new_string);
-
- o_text_change(g_current_window (), o_attrib, new_string,
- o_attrib->visibility, o_attrib->show_name_value);
-
- g_free(new_string);
-
- return returned;
-}
-
-/*! \todo Finish function documentation!!!
- * \brief
- * \par Function Description
- *
- */
/*
* Adds an attribute <B>scm_attrib_name</B> with value <B>scm_attrib_value</B> to the given <B>object</B>.
The attribute has the visibility <B>scm_vis</B> and show <B>scm_show</B> flags.
diff --git a/gschem/src/g_register.c b/gschem/src/g_register.c
index 19f7920..3e9b09a 100644
--- a/gschem/src/g_register.c
+++ b/gschem/src/g_register.c
@@ -336,12 +336,10 @@ void g_register_funcs (void)
/* Hook stuff */
scm_c_define_gsubr ("add-attribute-to-object", 5, 0, 0, g_add_attrib);
- scm_c_define_gsubr ("get-object-attributes", 1, 0, 0, g_get_object_attributes);
scm_c_define_gsubr ("get-object-bounds", 3, 0, 0, g_get_object_bounds);
scm_c_define_gsubr ("get-object-pins", 1, 0, 0, g_get_object_pins);
scm_c_define_gsubr ("get-pin-ends", 1, 0, 0, g_get_pin_ends);
scm_c_define_gsubr ("set-attribute-text-properties!", 7, 0, 0, g_set_attrib_text_properties);
- scm_c_define_gsubr ("set-attribute-value!", 2, 0, 0, g_set_attrib_value_x);
scm_c_define_gsubr ("add-component-at-xy", 7, 0, 0, g_add_component);
scm_c_define_gsubr ("get-objects-in-page", 1, 0, 0, g_get_objects_in_page);
scm_c_define_gsubr ("get-current-page", 0, 0, 0, g_get_current_page);
diff --git a/libgeda/include/libgeda/prototype.h b/libgeda/include/libgeda/prototype.h
index 90d87d0..100b377 100644
--- a/libgeda/include/libgeda/prototype.h
+++ b/libgeda/include/libgeda/prototype.h
@@ -43,23 +43,6 @@ void g_rc_parse(TOPLEVEL *toplevel, const gchar* rcname,
const gchar* specified_rc_filename);
gint g_rc_parse_specified_rc(TOPLEVEL *toplevel, const gchar *rcfilename);
-/* g_smob.c */
-#if 0
-SCM g_make_attrib_smob(TOPLEVEL *curr_w, OBJECT *curr_attr);
-#endif
-SCM g_set_attrib_value_internal(SCM attrib_smob, SCM scm_value, TOPLEVEL **world, OBJECT **o_attrib, char *new_string[]);
-#if 0
-gboolean g_get_data_from_object_smob(SCM object_smob, TOPLEVEL **toplevel,
- OBJECT **object);
-SCM g_make_object_smob(TOPLEVEL *curr_w, OBJECT *object);
-#endif
-SCM g_get_object_attributes(SCM object_smob);
-#if 0
-SCM g_make_page_smob(TOPLEVEL *curr_w, PAGE *page);
-gboolean g_get_data_from_page_smob(SCM object_smob, TOPLEVEL **toplevel,
- PAGE **object);
-#endif
-
/* i_vars.c */
void i_vars_libgeda_set(TOPLEVEL *toplevel);
void i_vars_libgeda_freenames();
diff --git a/libgeda/include/libgedaguile_priv.h b/libgeda/include/libgedaguile_priv.h
index 14f0c34..607a5f7 100644
--- a/libgeda/include/libgedaguile_priv.h
+++ b/libgeda/include/libgedaguile_priv.h
@@ -32,6 +32,7 @@ void edascm_init_object ();
void edascm_init_complex ();
void edascm_init_page ();
void edascm_init_attrib ();
+void edascm_init_deprecated ();
/* ---------------------------------------- */
diff --git a/libgeda/include/prototype_priv.h b/libgeda/include/prototype_priv.h
index a301128..16ef560 100644
--- a/libgeda/include/prototype_priv.h
+++ b/libgeda/include/prototype_priv.h
@@ -37,21 +37,6 @@ SCM g_rc_print_color_map (SCM scm_map);
void g_register_libgeda_funcs(void);
void g_register_libgeda_vars (void);
-/* g_smob.c */
-void g_init_attrib_smob(void);
-SCM g_get_attrib_name_value(SCM attrib_smob);
-SCM g_calcule_new_attrib_bounds (SCM attrib_smob, SCM scm_alignment,
- SCM scm_angle, SCM scm_x, SCM scm_y);
-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);
-void g_init_object_smob(void);
-SCM g_get_object_type(SCM object_smob);
-SCM g_get_line_width(SCM object_smob);
-void g_init_page_smob(void);
-SCM g_get_page_filename(SCM page_smob);
-SCM g_set_page_filename(SCM page_smob, SCM scm_filename);
-
/* m_bounds.c */
void m_bounds_init(BOUNDS *bounds);
void m_bounds_of_points(BOUNDS *bounds, sPOINT points[], gint count);
diff --git a/libgeda/lib/system-gafrc b/libgeda/lib/system-gafrc
index f238fb1..cfcc6af 100644
--- a/libgeda/lib/system-gafrc
+++ b/libgeda/lib/system-gafrc
@@ -26,6 +26,9 @@
; writing Scheme code for embedding in gaf.
(load-from-path "geda.scm")
+;; Import deprecated Scheme functions
+(use-modules (geda deprecated))
+
;; The directory containing various bitmaps (e.g. icons)
(bitmap-directory (build-path geda-data-path "bitmap"))
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 62fa399..2be9762 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -1,7 +1,7 @@
scmdatadir = $(GEDADATADIR)/scheme
nobase_dist_scmdata_DATA = geda.scm color-map.scm \
- geda/object.scm geda/page.scm geda/attrib.scm
+ geda/object.scm geda/page.scm geda/attrib.scm geda/deprecated.scm
# Unit test support. The unit tests are run using the geda-batch
# program, with config loading disabled (-q) so that user config
diff --git a/libgeda/scheme/geda/deprecated.scm b/libgeda/scheme/geda/deprecated.scm
new file mode 100644
index 0000000..5d84e13
--- /dev/null
+++ b/libgeda/scheme/geda/deprecated.scm
@@ -0,0 +1,117 @@
+;; gEDA - GPL Electronic Design Automation
+;; libgeda - gEDA's library - Scheme API
+;; Copyright (C) 2010 Peter Brett
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+;;
+
+;; This file contains deprecated Scheme API features, which should not
+;; be used in new code.
+
+(define-module (geda deprecated)
+
+ #:use-module (geda page)
+ #:use-module (geda object)
+ #:use-module (geda attrib)
+
+ ;; Import C procedures
+ #:use-module (geda core deprecated)
+ #:re-export (OBJ_LINE OBJ_PATH OBJ_BOX OBJ_PICTURE OBJ_CIRCLE OBJ_NET
+ OBJ_BUS OBJ_COMPLEX OBJ_TEXT OBJ_PIN OBJ_ARC)
+)
+
+(define-public get-line-width %get-line-width)
+
+(define-public get-attribute-name-value parse-attrib)
+
+(define-public get-attribute-angle text-angle)
+
+(define-public (get-object-attributes object)
+ (reverse! (object-attribs object)))
+
+(define-public (get-attrib-value-by-attrib-name object name)
+ (reverse!
+ (filter!
+ string?
+ (map (lambda (x)
+ (let ((name-value (parse-attrib x)))
+ (if (string=? name (car name-value))
+ (cdr name-value)
+ #f)))
+ (object-attribs object)))))
+
+
+(define-public (get-object-type object)
+ (case (object-type object)
+ ((arc) OBJ_ARC)
+ ((box) OBJ_BOX)
+ ((bus) OBJ_BUS)
+ ((circle) OBJ_CIRCLE)
+ ((complex) OBJ_COMPLEX)
+ ((line) OBJ_LINE)
+ ((net) OBJ_NET)
+ ((path) OBJ_PATH)
+ ((picture) OBJ_PICTURE)
+ ((pin) OBJ_PIN)
+ ((text) OBJ_TEXT)
+ (else (error "Unknown object type ~A" (object-type object)))))
+
+(define-public get-page-filename page-filename)
+
+(define-public set-page-filename set-page-filename!)
+
+(define-public (get-attribute-bounds object)
+ ;; object-bounds returns ((left . top) . (right . bottom)).
+ ;; Put in form ((left . right) . (top . bottom))
+ (let* ((bounds (object-bounds object))
+ (top (cdr (car bounds)))
+ (right (car (cdr bounds))))
+ (set-cdr! (car bounds) right)
+ (set-car! (cdr bounds) top)
+ bounds))
+
+(define-public (calcule-new-attrib-bounds attrib align angle x y)
+ (define align-table
+ '(("Lower Left" . lower-left)
+ ("Middle Left" . middle-left)
+ ("Upper Left" . upper-left)
+ ("Lower Middle" . lower-center)
+ ("Middle Middle" . middle-center)
+ ("Upper Middle" . upper-center)
+ ("Lower Right" . lower-right)
+ ("Middle Right" . middle-right)
+ ("Upper Right" . upper-right)))
+
+ (let* ((t (copy-object attrib))
+ (params (text-info t))
+ (location (car params)))
+
+ (apply set-text! t
+ (cons (if (= x -1) (car location) x) ; location
+ (if (= y -1) (cdr location) y))
+ (or (assoc-ref align-table align) (text-align t)) ; alignment
+ (if (= angle -1) (list-ref params 2) angle) ; angle
+ (list-tail params 3)) ; other params
+
+ ;; object-bounds returns ((left . top) . (right . bottom)).
+ ;; Put in form ((left . right) . (bottom . top))
+ (let* ((bounds (object-bounds t))
+ (top (cdr (car bounds)))
+ (bottom (cdr (cdr bounds)))
+ (right (car (cdr bounds))))
+ (set-cdr! (car bounds) right)
+ (set-car! (cdr bounds) bottom)
+ (set-cdr! (cdr bounds) top)
+ bounds)))
diff --git a/libgeda/scheme/unit-tests/t1000-deprecated.scm b/libgeda/scheme/unit-tests/t1000-deprecated.scm
index 21b67ca..d0ccb5e 100644
--- a/libgeda/scheme/unit-tests/t1000-deprecated.scm
+++ b/libgeda/scheme/unit-tests/t1000-deprecated.scm
@@ -1,6 +1,7 @@
;; Test deprecated procedures from legacy Scheme API.
(use-modules (unit-test))
+(use-modules (geda deprecated))
(use-modules (geda object))
(use-modules (geda attrib))
(use-modules (geda page))
diff --git a/libgeda/src/Makefile.am b/libgeda/src/Makefile.am
index 4619dcd..8dff2ab 100644
--- a/libgeda/src/Makefile.am
+++ b/libgeda/src/Makefile.am
@@ -9,7 +9,8 @@ BUILT_SOURCES = \
scheme_object.x \
scheme_complex.x \
scheme_page.x \
- scheme_attrib.x
+ scheme_attrib.x \
+ scheme_deprecated.x
scheme_api_sources = \
scheme_init.c \
@@ -18,7 +19,8 @@ scheme_api_sources = \
scheme_object.c \
scheme_complex.c \
scheme_page.c \
- scheme_attrib.c
+ scheme_attrib.c \
+ scheme_deprecated.c
libgeda_la_SOURCES = \
$(scheme_api_sources) \
@@ -29,7 +31,6 @@ libgeda_la_SOURCES = \
geda_list.c \
g_rc.c \
g_register.c \
- g_smob.c \
i_vars.c \
libgeda.c \
m_basic.c \
diff --git a/libgeda/src/g_register.c b/libgeda/src/g_register.c
index b69b9d5..3a33740 100644
--- a/libgeda/src/g_register.c
+++ b/libgeda/src/g_register.c
@@ -102,17 +102,4 @@ void g_register_libgeda_vars (void)
scm_from_locale_string (s_path_sys_data ()));
scm_c_define("path-sep",
scm_from_locale_string(G_DIR_SEPARATOR_S));
-
- scm_c_define("OBJ_LINE", SCM_MAKE_CHAR((unsigned char) OBJ_LINE));
- scm_c_define("OBJ_BOX", SCM_MAKE_CHAR((unsigned char) OBJ_BOX));
- scm_c_define("OBJ_PICTURE", SCM_MAKE_CHAR((unsigned char) OBJ_PICTURE));
- scm_c_define("OBJ_CIRCLE", SCM_MAKE_CHAR((unsigned char) OBJ_CIRCLE));
- scm_c_define("OBJ_NET", SCM_MAKE_CHAR((unsigned char) OBJ_NET));
- scm_c_define("OBJ_BUS", SCM_MAKE_CHAR((unsigned char) OBJ_BUS));
- scm_c_define("OBJ_COMPLEX", SCM_MAKE_CHAR((unsigned char) OBJ_COMPLEX));
- scm_c_define("OBJ_TEXT", SCM_MAKE_CHAR((unsigned char) OBJ_TEXT));
- scm_c_define("OBJ_PIN", SCM_MAKE_CHAR((unsigned char) OBJ_PIN));
- scm_c_define("OBJ_ARC", SCM_MAKE_CHAR((unsigned char) OBJ_ARC));
- scm_c_define("OBJ_PLACEHOLDER", SCM_MAKE_CHAR((unsigned char) OBJ_PLACEHOLDER));
- scm_c_define("OBJ_PATH", SCM_MAKE_CHAR((unsigned char) OBJ_PATH));
}
diff --git a/libgeda/src/g_smob.c b/libgeda/src/g_smob.c
deleted file mode 100644
index 04c4139..0000000
--- a/libgeda/src/g_smob.c
+++ /dev/null
@@ -1,853 +0,0 @@
-/* gEDA - GPL Electronic Design Automation
- * libgeda - gEDA's library
- * Copyright (C) 1998-2010 Ales Hvezda
- * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
- */
-#include <config.h>
-
-#include <math.h>
-#include <stdio.h>
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-
-#include "libgeda_priv.h"
-#include "libgedaguile.h"
-
-#ifdef HAVE_LIBDMALLOC
-#include <dmalloc.h>
-#endif
-
-#if 0
-static long attrib_smob_tag; /*! Attribute SMOB tag */
-static long object_smob_tag; /*! Object SMOB tag */
-static long page_smob_tag; /*! Page SMOB tag */
-
-/*! \brief Free attribute smob memory.
- * \par Function Description
- * Free the memory allocated by the attribute smob and return its size.
- *
- * \param [in] attrib_smob The attribute smob to free.
- * \return Size of attribute smob.
- */
-static scm_sizet g_free_attrib_smob(SCM attrib_smob)
-{
- struct st_attrib_smob *attribute =
- (struct st_attrib_smob *)SCM_CDR(attrib_smob);
- scm_sizet size = sizeof(struct st_attrib_smob);
-
- free(attribute); /* this should stay as free (allocated from guile) */
- return size;
-}
-
-/*! \brief Prints attribute smob to port.
- * \par Function Description
- * This function prints the given attribute smob to the port.
- * It just prints a string showing it is an attribute and its string.
- *
- * \param [in] attrib_smob The attribute smob.
- * \param [in] port The port to print to.
- * \param [in] pstate Unused.
- * \return non-zero means success.
- */
-static int g_print_attrib_smob(SCM attrib_smob, SCM port,
- scm_print_state *pstate)
-{
- struct st_attrib_smob *attribute =
- (struct st_attrib_smob *)SCM_CDR(attrib_smob);
-
- if (attribute &&
- attribute->attribute &&
- attribute->attribute->text &&
- attribute->attribute->text->string ) {
- scm_puts("#<attribute ", port);
- scm_display (scm_makfrom0str (attribute->attribute->text->string),
- port);
- scm_puts(">", port);
- }
-
- /* non-zero means success */
- return 1;
-}
-
-
-/*! \brief Creates a name-value smob
- * \par Function Description
- * This function Creates and returns a new attribute smob,
- * based on the given TOPLEVEL curr_w and attribute curr_attr.
- *
- * \param [in] curr_w The current TOPLEVEL object.
- * \param [in] curr_attr The current attribute.
- * \return SCM
- */
-SCM g_make_attrib_smob(TOPLEVEL *curr_w, OBJECT *curr_attr)
-{
- struct st_attrib_smob *smob_attribute;
-
- smob_attribute = (struct st_attrib_smob *)
- scm_must_malloc(sizeof(struct st_attrib_smob),
- "attribute");
-
- smob_attribute->world = curr_w;
- smob_attribute->attribute = curr_attr;
-
- /* Assumes Guile version >= 1.3.2 */
- SCM_RETURN_NEWSMOB(attrib_smob_tag, smob_attribute);
-}
-#endif
-
-/*! \brief Get name and value of attribute.
- * \par Function Description
- * Returns a list with the name and value of the given attribute smob
- *
- * \param [in] attrib_smob The attribute smob to get name and value from.
- * \return A list containing the name and value of the attribute.
- */
-SCM g_get_attrib_name_value(SCM attrib_smob)
-{
- OBJECT *attribute;
- char *name = NULL;
- char *value = NULL;
- SCM returned = SCM_EOL;
-
- SCM_ASSERT ( edascm_is_object (attrib_smob),
- attrib_smob, SCM_ARG1, "get-attribute-name-value");
-
- attribute = edascm_to_object (attrib_smob);
-
- if (o_attrib_get_name_value (attribute, &name, &value)) {
- returned = scm_cons (scm_makfrom0str (name),
- scm_makfrom0str (value));
- g_free(name);
- g_free(value);
- }
-
- return returned;
-}
-
-/*! \brief Set the attribute value.
- * \par Function Description
- * This function puts the attribute smob name into a new_string and
- * the new scm_value (attribute=value format). It also returns the
- * TOPLEVEL and OBJECT pointers.
- *
- * \param [in] attrib_smob The attribute to update.
- * \param [in] scm_value The new value of the attribute.
- * \param [in,out] world The TOPLEVEL object.
- * \param [in,out] o_attrib Pointer to the updated attribute smob.
- * \param [in] new_string Returns the attribute=value format string for the
- * updated attribute.
- * \return Always SCM_UNDEFINED
- */
-SCM g_set_attrib_value_internal(SCM attrib_smob, SCM scm_value,
- TOPLEVEL **world, OBJECT **o_attrib,
- char *new_string[])
-{
- OBJECT *attribute;
- char *name = NULL;
- char *value = NULL;
-
- SCM_ASSERT ( edascm_is_object (attrib_smob),
- attrib_smob, SCM_ARG1, "set-attribute-value!");
- SCM_ASSERT (scm_is_string(scm_value), scm_value, SCM_ARG2,
- "set-attribute-value!");
-
- attribute = edascm_to_object (attrib_smob);
- value = scm_to_locale_string (scm_value);
-
- if (attribute != NULL) {
-
- o_attrib_get_name_value (attribute, &name, NULL);
-
- *new_string = g_strconcat (name, "=", value, NULL);
-
- *world = edascm_c_current_toplevel ();
- *o_attrib = attribute;
-
- g_free(name);
- }
-
- free (value);
-
- return SCM_UNDEFINED;
-}
-
-/*! \brief Calcule the attribute bounds as it has the given properties.
- * \par Function Description
- * Given an attribute, and a new angle, position and alignment,
- * this function calcules the bounds of the attribute with the new properties,
- * but without modifying the attribute.
- *
- * \param [in] attrib_smob The attribute.
- * \param [in] scm_alignment The new alignment of the attribute.
- * String with the alignment of the text. Possible values are:
- * "" : Keep the previous alignment.
- * "Lower Left"
- * "Middle Left"
- * "Upper Left"
- * "Lower Middle"
- * "Middle Middle"
- * "Upper Middle"
- * "Lower Right"
- * "Middle Right"
- * "Upper Right"
- * \param [in] scm_angle The new angle of the attribute,
- * or -1 to keep the previous angle.
- * \param [in] scm_x The new x position of the attribute
- * or -1 to keep the previous value.
- * \param [in] scm_y The new y position of the attribute
- * or -1 to keep the prevous value.
- * \return A list of the form ( (x1 x2) (y1 y2) ) with:
- * (x1, y1): bottom left corner.
- * (x2, y2): upper right corner.
- */
-SCM g_calcule_new_attrib_bounds (SCM attrib_smob, SCM scm_alignment,
- SCM scm_angle, SCM scm_x, SCM scm_y) {
-
- TOPLEVEL *toplevel = NULL;
- OBJECT *object = NULL;
- struct st_attrib_smob *attribute;
- char *alignment_string;
- int alignment = -2;
- int angle = 0;
- int x = -1, y = -1;
- int old_angle, old_x, old_y, old_alignment;
- int left=0, right=0, top=0, bottom=0;
- SCM vertical = SCM_EOL;
- SCM horizontal = SCM_EOL;
- SCM returned = SCM_EOL;
-
- SCM_ASSERT (scm_is_string(scm_alignment), scm_alignment,
- SCM_ARG2, "calcule-new-attrib-bounds");
- SCM_ASSERT ( scm_is_integer(scm_angle),
- scm_angle, SCM_ARG3, "calcule-new-attrib-bounds");
- SCM_ASSERT ( scm_is_integer(scm_x),
- scm_x, SCM_ARG4, "calcule-new-attrib-bounds");
- SCM_ASSERT ( scm_is_integer(scm_y),
- scm_y, SCM_ARG5, "calcule-new-attrib-bounds");
-
- angle = scm_to_int(scm_angle);
- x = scm_to_int(scm_x);
- y = scm_to_int(scm_y);
-
- alignment_string = scm_to_locale_string (scm_alignment);
-
- if (strlen(alignment_string) == 0) {
- alignment = -1;
- }
- if (strcmp(alignment_string, "Lower Left") == 0) {
- alignment = 0;
- }
- if (strcmp(alignment_string, "Middle Left") == 0) {
- alignment = 1;
- }
- if (strcmp(alignment_string, "Upper Left") == 0) {
- alignment = 2;
- }
- if (strcmp(alignment_string, "Lower Middle") == 0) {
- alignment = 3;
- }
- if (strcmp(alignment_string, "Middle Middle") == 0) {
- alignment = 4;
- }
- if (strcmp(alignment_string, "Upper Middle") == 0) {
- alignment = 5;
- }
- if (strcmp(alignment_string, "Lower Right") == 0) {
- alignment = 6;
- }
- if (strcmp(alignment_string, "Middle Right") == 0) {
- alignment = 7;
- }
- if (strcmp(alignment_string, "Upper Right") == 0) {
- alignment = 8;
- }
-
- free (alignment_string);
-
- if (alignment == -2) {
- /* Bad specified */
- SCM_ASSERT (scm_is_string(scm_alignment), scm_alignment,
- SCM_ARG2, "calcule-new-attrib-bounds");
- }
-
- toplevel = edascm_c_current_toplevel ();
- object = edascm_to_object (attrib_smob);
-
- SCM_ASSERT ( object &&
- object->text &&
- object->text->string,
- attrib_smob, SCM_ARG1, "calcule-new-attrib-bounds");
-
- /* Store the previous values */
- old_alignment = object->text->alignment;
- old_angle = object->text->angle;
- old_x = object->text->x;
- old_y = object->text->y;
-
- /* Set the new ones */
- if (alignment != -1)
- object->text->alignment = alignment;
- if (angle != -1)
- object->text->angle = angle;
- if (x != -1)
- object->text->x = x;
- if (y != -1)
- object->text->y = y;
-
- o_text_recreate(toplevel, object);
-
- /* Get the new bounds */
- world_get_text_bounds (toplevel, object,
- &left, &top, &right, &bottom);
-
- /* Restore the original attributes */
- object->text->alignment = old_alignment;
- object->text->angle = old_angle;
- object->text->x = old_x;
- object->text->y = old_y;
-
- o_text_recreate(toplevel, object);
-
- /* Construct the return value */
- horizontal = scm_cons (scm_from_int(left), scm_from_int(right));
- vertical = scm_cons (scm_from_int(top), scm_from_int(bottom));
- returned = scm_cons (horizontal, vertical);
-
- return returned;
-}
-
-/*! \brief Initialize the framework to support an attribute smob.
- * \par Function Description
- * Initialize the framework to support an attribute smob.
- *
- */
-void g_init_attrib_smob(void)
-{
-
-#if 0
- attrib_smob_tag = scm_make_smob_type("attribute",
- sizeof (struct st_attrib_smob));
- scm_set_smob_mark(attrib_smob_tag, 0);
- scm_set_smob_free(attrib_smob_tag, g_free_attrib_smob);
- scm_set_smob_print(attrib_smob_tag, g_print_attrib_smob);
-#endif
-
- scm_c_define_gsubr("get-attribute-name-value", 1, 0, 0,
- g_get_attrib_name_value);
-
- scm_c_define_gsubr ("get-attribute-bounds", 1, 0, 0, g_get_attrib_bounds);
- 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);
-
-
- return;
-}
-
-/*! \brief Get the bounds of an attribute.
- * \par Function Description
- * Get the bounds of an attribute.
- * WARNING: top and bottom are mis-named in world-coords,
- * top is the smallest "y" value, and bottom is the largest.
- * Be careful! This doesn't correspond to what you'd expect,
- * nor to the coordinate system who's origin is the bottom, left of the page.
- * \param[in] attrib_smob the attribute.
- * \return a list of the bounds of the <B>attrib smob</B>.
- * The list has the format: ( (left right) (top bottom) )
- */
-SCM g_get_attrib_bounds(SCM attrib_smob)
-{
- TOPLEVEL *toplevel = edascm_c_current_toplevel ();
- OBJECT *attribute;
- SCM vertical = SCM_EOL;
- SCM horizontal = SCM_EOL;
- int left=0, right=0, bottom=0, top=0;
- SCM returned = SCM_EOL;
-
- SCM_ASSERT ( edascm_is_object (attrib_smob),
- attrib_smob, SCM_ARG1, "get-attribute-bounds");
-
- attribute = edascm_to_object (attrib_smob);
-
- if (attribute &&
- attribute->text &&
- attribute->text->string ) {
-
- world_get_text_bounds (toplevel, attribute, &left,
- &top, &right, &bottom);
-
- horizontal = scm_cons (scm_from_int(left), scm_from_int(right));
- vertical = scm_cons (scm_from_int(top), scm_from_int(bottom));
- returned = scm_cons (horizontal, vertical);
- }
-
- return returned;
-}
-
-/*! \brief Get the angle of an attribute.
- * \par Function Description
- * Get the angle of an attribute.
- * \param[in] attrib_smob the attribute.
- * \return the angle of the <B>attrib smob</B>.
- */
-SCM g_get_attrib_angle(SCM attrib_smob)
-{
- TOPLEVEL *toplevel;
- OBJECT *attribute;
-
- SCM_ASSERT ( edascm_is_object (attrib_smob),
- attrib_smob, SCM_ARG1, "get-attribute-angle");
-
- attribute = edascm_to_object (attrib_smob);
- toplevel = edascm_c_current_toplevel ();
-
- SCM_ASSERT ( attribute &&
- attribute->text,
- attrib_smob, SCM_ARG1, "get-attribute-angle");
-
- return scm_from_int(attribute->text->angle);
-}
-
-#if 0
-/*! \brief Free object smob memory.
- * \par Function Description
- * Free the memory allocated by the object smob and return its size.
- *
- * \param [in] object_smob The object smob to free.
- * \return Size of object smob.
- */
-static scm_sizet g_free_object_smob(SCM object_smob)
-{
- struct st_object_smob *object =
- (struct st_object_smob *)SCM_CDR(object_smob);
- scm_sizet size = sizeof(struct st_object_smob);
-
- free(object); /* this should stay as free (allocated from guile) */
- return size;
-}
-
-/*! \brief Prints object smob to port.
- * \par Function Description
- * This function prints the given object smob to the port.
- * It just prints a string showing it is an object and the object name.
- *
- * \param [in] object_smob The object smob.
- * \param [in] port The port to print to.
- * \param [in] pstate Unused.
- * \return non-zero means success.
- */
-static int g_print_object_smob(SCM object_smob, SCM port,
- scm_print_state *pstate)
-{
- struct st_object_smob *object =
- (struct st_object_smob *)SCM_CDR(object_smob);
-
- if (object &&
- object->object &&
- object->object->name) {
- scm_puts("#<object ", port);
- scm_display (scm_makfrom0str (object->object->name),
- port);
- scm_puts(">", port);
- }
-
- /* non-zero means success */
- return 1;
-}
-
-/*! \brief Creates a object smob
- * \par Function Description
- * This function creates and returns a new object smob,
- * from the given TOPLEVEL curr_w and object pointers.
- *
- * \param [in] curr_w The current TOPLEVEL object.
- * \param [in] object The current object.
- * \return SCM
- */
-SCM g_make_object_smob(TOPLEVEL *curr_w, OBJECT *object)
-{
- struct st_object_smob *smob_object;
-
- smob_object = (struct st_object_smob *)
- scm_must_malloc(sizeof(struct st_object_smob), "object");
-
- smob_object->world = curr_w;
- smob_object->object = object;
-
- /* Assumes Guile version >= 1.3.2 */
- SCM_RETURN_NEWSMOB(object_smob_tag, smob_object);
-}
-#endif
-
-/*! \brief Get all object attributes in a list.
- * \par Function Description
- * This function returns a list with all the attributes of a given object smob.
- *
- * \param [in] object_smob The object smob to get attributes from.
- * \return A list of attributes associated with this object smob.
- */
-SCM g_get_object_attributes(SCM object_smob)
-{
- TOPLEVEL *toplevel;
- OBJECT *object;
- SCM returned = SCM_EOL;
- GList *a_iter;
- OBJECT *a_current;
-
- SCM_ASSERT ( edascm_is_object (object_smob),
- object_smob, SCM_ARG1, "get-object-attributes");
-
- object = edascm_to_object (object_smob);
-
- if (object) {
-
- toplevel = edascm_c_current_toplevel ();
- a_iter = object->attribs;
- while (a_iter != NULL) {
- a_current = a_iter->data;
- if (a_current && a_current->text) {
- returned = scm_cons (edascm_from_object (a_current),
- returned);
- }
- a_iter = g_list_next (a_iter);
- }
- }
-
- return returned;
-}
-
-/*! \brief Get the value(s) of the attributes with the given name in the
- * given object.
- * \par Function Description
- * This function returns a list with all the attribute values, providing that
- * its attribute name is the given name, in a given object smob.
- *
- * \param [in] object_smob The object smob to get attributes from.
- * \param [in] scm_attrib_name The name of the attribute you want the value.
- * \return A list of attribute values.
- */
-SCM g_get_attrib_value_by_attrib_name(SCM object_smob, SCM scm_attrib_name)
-{
- TOPLEVEL *toplevel;
- OBJECT *object;
- gchar *attrib_name=NULL;
- SCM returned = SCM_EOL;
- gchar *name=NULL, *value=NULL;
- GList *a_iter;
- OBJECT *a_current;
-
- SCM_ASSERT ( edascm_is_object (object_smob),
- object_smob, SCM_ARG1, "get-attrib-value-by-attrib-name");
-
- SCM_ASSERT (scm_is_string(scm_attrib_name), scm_attrib_name,
- SCM_ARG2, "get-attrib-value-by-attrib-name");
-
- /* Get parameters */
- object = edascm_to_object (object_smob);
- attrib_name = scm_to_locale_string (scm_attrib_name);
-
- if (object) {
-
- toplevel = edascm_c_current_toplevel ();
- a_iter = object->attribs;
- while (a_iter != NULL) {
- a_current = a_iter->data;
- if (a_current != NULL &&
- o_attrib_get_name_value (a_current, &name, &value)) {
- if (strcmp(name, attrib_name) == 0)
- returned = scm_cons (scm_makfrom0str (value), returned);
- g_free (name);
- g_free (value);
- }
- a_iter = g_list_next (a_iter);
- }
- }
-
- free (attrib_name);
-
- return returned;
-}
-
-/*! \brief Get the object type.
- * \par Function Description
- * This function returns a string with the type of a given object smob.
- *
- * \param [in] object_smob The object smob to get the type from.
- * \return A string with the type of the given object.
- * Actually it is the object->type character converted into a string.
- */
-SCM g_get_object_type(SCM object_smob)
-{
- OBJECT *object;
- SCM returned = SCM_EOL;
-
- SCM_ASSERT ( edascm_is_object (object_smob),
- object_smob, SCM_ARG1, "get-object-type");
-
- object = edascm_to_object (object_smob);
-
- returned = SCM_MAKE_CHAR((unsigned char) object->type);
-
- return returned;
-}
-
-/*! \brief Get the line width used to draw an object.
- * \par Function Description
- * This function returns the line width used to draw an object.
- *
- * \param [in] object_smob The object smob to get the line width.
- * \return The line width.
- * Actually it is the object->line_width.
- */
-SCM g_get_line_width(SCM object_smob)
-{
- SCM_ASSERT (edascm_is_object (object_smob),
- object_smob, SCM_ARG1, "get-line-width");
-
- OBJECT *object = edascm_to_object (object_smob);
-
- return scm_from_int(object->line_width);
-}
-
-/*! \brief Initialize the framework to support an object smob.
- * \par Function Description
- * Initialize the framework to support an object smob.
- *
- */
-void g_init_object_smob(void)
-{
-#if 0
- object_smob_tag = scm_make_smob_type("object", sizeof (struct st_object_smob));
- scm_set_smob_mark(object_smob_tag, 0);
- scm_set_smob_free(object_smob_tag, g_free_object_smob);
- scm_set_smob_print(object_smob_tag, g_print_object_smob);
-#endif
-
- scm_c_define_gsubr("get-object-attributes", 1, 0, 0, g_get_object_attributes);
- scm_c_define_gsubr("get-attrib-value-by-attrib-name", 2, 0, 0,
- g_get_attrib_value_by_attrib_name);
- scm_c_define_gsubr("get-object-type", 1, 0, 0, g_get_object_type);
- scm_c_define_gsubr("get-line-width", 1, 0, 0, g_get_line_width);
-
- return;
-}
-
-#if 0
-/*! \brief Get the TOPLEVEL and OBJECT data from an object smob.
- * \par Function Description
- * Get the TOPLEVEL and OBJECT data from an object smob.
- *
- * \param [in] object_smob The object smob to get data from.
- * \param [out] toplevel The TOPLEVEL to write data to.
- * \param [out] object The OBJECT to write data to.
- * \return TRUE on success, FALSE otherwise
- */
-gboolean g_get_data_from_object_smob(SCM object_smob, TOPLEVEL **toplevel,
- OBJECT **object)
-{
-
- if ( (!SCM_NIMP(object_smob)) ||
- ((long) SCM_CAR(object_smob) != object_smob_tag) ) {
- return(FALSE);
- }
- if (toplevel != NULL) {
- *toplevel = (TOPLEVEL *)
- (((struct st_object_smob *)SCM_CDR(object_smob))->world);
- }
- if (object != NULL) {
- *object = (OBJECT *)
- (((struct st_object_smob *)SCM_CDR(object_smob))->object);
- }
- return (TRUE);
-}
-
-/*! \brief Free page smob memory.
- * \par Function Description
- * Free the memory allocated by the page smob and return its size.
- *
- * \param [in] page_smob The page smob to free.
- * \return Size of page smob.
- */
-static scm_sizet g_free_page_smob(SCM page_smob)
-{
- struct st_page_smob *page =
- (struct st_page_smob *)SCM_CDR(page_smob);
- scm_sizet size = sizeof(struct st_page_smob);
-
- free(page); /* this should stay as free (allocated from guile) */
- return size;
-}
-
-/*! \brief Prints page smob to port.
- * \par Function Description
- * This function prints the given page smob to the port.
- * It just prints a string showing it is a page and the page name.
- *
- * \param [in] page_smob The page smob.
- * \param [in] port The port to print to.
- * \param [in] pstate Unused.
- * \return non-zero means success.
- */
-static int g_print_page_smob(SCM page_smob, SCM port,
- scm_print_state *pstate)
-{
- struct st_page_smob *page =
- (struct st_page_smob *)SCM_CDR(page_smob);
-
- if (page &&
- page->page &&
- page->page->page_filename) {
- scm_puts("#<page ", port);
- scm_display (scm_makfrom0str (page->page->page_filename),
- port);
- scm_puts(">", port);
- }
-
- /* non-zero means success */
- return 1;
-}
-#endif
-
-/*! \brief Initialize the framework to support a page smob.
- * \par Function Description
- * Initialize the framework to support a page smob.
- *
- */
-void g_init_page_smob(void)
-{
-#if 0
- page_smob_tag = scm_make_smob_type("page",
- sizeof (struct st_page_smob));
- 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);
-#endif
-
- 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);
-
- return;
-}
-
-#if 0
-/*! \brief Creates a page smob
- * \par Function Description
- * This function creates and returns a new page smob,
- * from the given TOPLEVEL curr_w and page pointers.
- *
- * \param [in] curr_w The current TOPLEVEL object.
- * \param [in] page The page object.
- * \return SCM The new page smob
- */
-SCM g_make_page_smob(TOPLEVEL *curr_w, PAGE *page)
-{
- struct st_page_smob *smob_page;
-
- smob_page = (struct st_page_smob *)
- scm_must_malloc(sizeof(struct st_page_smob), "page");
-
- smob_page->world = curr_w;
- smob_page->page = page;
-
- /* Assumes Guile version >= 1.3.2 */
- SCM_RETURN_NEWSMOB(page_smob_tag, smob_page);
-}
-
-/*! \brief Get the TOPLEVEL and PAGE data from a page smob.
- * \par Function Description
- * Get the TOPLEVEL and OBJECT data from a page smob.
- *
- * \param [in] page_smob The page smob to get data from.
- * \param [out] toplevel The TOPLEVEL to write data to.
- * \param [out] page The PAGE to write data to.
- * \return TRUE on success, FALSE otherwise
- */
-gboolean g_get_data_from_page_smob(SCM page_smob, TOPLEVEL **toplevel,
- PAGE **page)
-{
-
- if ( (!SCM_NIMP(page_smob)) ||
- ((long) SCM_CAR(page_smob) != page_smob_tag) ) {
- return(FALSE);
- }
- if (toplevel != NULL) {
- *toplevel = (TOPLEVEL *)
- (((struct st_page_smob *)SCM_CDR(page_smob))->world);
- }
- if (page != NULL) {
- *page = (PAGE *)
- (((struct st_page_smob *)SCM_CDR(page_smob))->page);
- }
- return (TRUE);
-}
-#endif
-
-/*! \brief Get the page filename from a page smob.
- * \par Function Description
- * Get the page filename from a page smob.
- *
- * \param [in] page_smob The page smob to get the filename from.
- * \return the page filename or SCM_EOL if there was some error.
- */
-SCM g_get_page_filename(SCM page_smob)
-{
- SCM returned = SCM_EOL;
- PAGE *page;
-
- SCM_ASSERT ( edascm_is_page (page_smob),
- page_smob, SCM_ARG1, "get-page-filename");
-
- page = edascm_to_page (page_smob);
-
- if (page->page_filename)
- returned = scm_makfrom0str (page->page_filename);
-
- return (returned);
-}
-
-/*! \brief Set the page filename of the given page smob.
- * \par Function Description
- * Set the page filename of the given page smob.
- *
- * \param [in] page_smob The page smob to set the filename from.
- * \param [in] scm_filename The filename to set.
- * \return the page filename or SCM_EOL if there was some error.
- */
-SCM g_set_page_filename(SCM page_smob, SCM scm_filename)
-{
- PAGE *page;
- char *filename = NULL;
-
- SCM_ASSERT ( edascm_is_page (page_smob),
- page_smob, SCM_ARG1, "set-page-filename");
-
- SCM_ASSERT (scm_is_string(scm_filename), scm_filename,
- SCM_ARG2, "set-page-filename");
-
- page = edascm_to_page (page_smob);
-
- filename = SCM_STRING_CHARS (scm_filename);
-
- if (page->page_filename)
- g_free(page->page_filename);
-
- page->page_filename = g_strdup(filename);
-
- return SCM_BOOL_T;
-}
-
diff --git a/libgeda/src/libgeda.c b/libgeda/src/libgeda.c
index fc43fb7..ae2a5cd 100644
--- a/libgeda/src/libgeda.c
+++ b/libgeda/src/libgeda.c
@@ -63,10 +63,6 @@ void libgeda_init(void)
g_register_libgeda_funcs();
g_register_libgeda_vars();
- g_init_object_smob();
- g_init_attrib_smob();
- g_init_page_smob();
-
edascm_init ();
}
diff --git a/libgeda/src/scheme_deprecated.c b/libgeda/src/scheme_deprecated.c
new file mode 100644
index 0000000..3a49607
--- /dev/null
+++ b/libgeda/src/scheme_deprecated.c
@@ -0,0 +1,94 @@
+/* gEDA - GPL Electronic Design Automation
+ * libgeda - gEDA's library
+ * Copyright (C) 1998-2010 gEDA Contributors (see ChangeLog for details)
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+ */
+
+/*!
+ * \file scheme_init.c
+ * Deprecated Scheme API functions
+ */
+#include <config.h>
+
+#include "libgeda_priv.h"
+#include "libgedaguile_priv.h"
+
+/*! \brief Get the width of line used to draw an object
+ * \par Function Description
+ * Returns the line width used to draw an object. Deprecated because
+ * it doesn't respect type restrictions, unlike the %object-stroke
+ * function in (geda core object).
+ *
+ * \param obj_s the object to get line width for.
+ * \return the line width.
+ */
+SCM_DEFINE (get_line_width, "%get-line-width", 1, 0, 0,
+ (SCM obj_s), "Get the width of line used to draw an object")
+{
+ SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
+ SCM_ARG1, s_get_line_width);
+
+ OBJECT *object = edascm_to_object (obj_s);
+
+ return scm_from_int(object->line_width);
+}
+
+/*!
+ * \brief Create the (geda core deprecated) Scheme module.
+ * \par Function Description
+ * Defines procedures in the (geda core deprecated) module. The module can
+ * be accessed using (use-modules (geda core deprecated)).
+ */
+static void
+init_module_geda_core_deprecated ()
+{
+ /* Register the functions */
+ #include "scheme_deprecated.x"
+
+ /* Some other deprecated definitions */
+ scm_c_define("OBJ_LINE", SCM_MAKE_CHAR((unsigned char) OBJ_LINE));
+ scm_c_define("OBJ_BOX", SCM_MAKE_CHAR((unsigned char) OBJ_BOX));
+ scm_c_define("OBJ_PICTURE", SCM_MAKE_CHAR((unsigned char) OBJ_PICTURE));
+ scm_c_define("OBJ_CIRCLE", SCM_MAKE_CHAR((unsigned char) OBJ_CIRCLE));
+ scm_c_define("OBJ_NET", SCM_MAKE_CHAR((unsigned char) OBJ_NET));
+ scm_c_define("OBJ_BUS", SCM_MAKE_CHAR((unsigned char) OBJ_BUS));
+ scm_c_define("OBJ_COMPLEX", SCM_MAKE_CHAR((unsigned char) OBJ_COMPLEX));
+ scm_c_define("OBJ_TEXT", SCM_MAKE_CHAR((unsigned char) OBJ_TEXT));
+ scm_c_define("OBJ_PIN", SCM_MAKE_CHAR((unsigned char) OBJ_PIN));
+ scm_c_define("OBJ_ARC", SCM_MAKE_CHAR((unsigned char) OBJ_ARC));
+ scm_c_define("OBJ_PLACEHOLDER", SCM_MAKE_CHAR((unsigned char) OBJ_PLACEHOLDER));
+ scm_c_define("OBJ_PATH", SCM_MAKE_CHAR((unsigned char) OBJ_PATH));
+
+ /* Add them to the module's public definitions. */
+ scm_c_export (s_get_line_width, "OBJ_LINE", "OBJ_BOX", "OBJ_PICTURE",
+ "OBJ_CIRCLE", "OBJ_NET", "OBJ_BUS", "OBJ_COMPLEX", "OBJ_TEXT",
+ "OBJ_PIN", "OBJ_ARC", "OBJ_PATH", "OBJ_PLACEHOLDER", NULL);
+}
+
+/*!
+ * \brief Initialise the basic gEDA page manipulation procedures.
+ * \par Function Description
+ * Registers some Scheme procedures for working with #PAGE
+ * smobs. Should only be called by scheme_api_init().
+ */
+void
+edascm_init_deprecated ()
+{
+ /* Define the (geda core page) module */
+ scm_c_define_module ("geda core deprecated",
+ init_module_geda_core_deprecated,
+ NULL);
+}
diff --git a/libgeda/src/scheme_init.c b/libgeda/src/scheme_init.c
index 26a6e20..927b3d5 100644
--- a/libgeda/src/scheme_init.c
+++ b/libgeda/src/scheme_init.c
@@ -50,4 +50,5 @@ edascm_init ()
edascm_init_complex ();
edascm_init_page ();
edascm_init_attrib ();
+ edascm_init_deprecated ();
}
commit a0adbfc6bbc79cb7ac9cc2dd1c894ad0cdc0b872
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add unit tests for legacy Scheme API.
These will be used to verify that replacement functions based on new
Scheme API are compatible with the originals.
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 16657f9..62fa399 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -22,7 +22,8 @@ TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0020-page.scm \
unit-tests/t0021-page-dirty.scm \
unit-tests/t0030-attribute.scm \
- unit-tests/t0031-promotable-attributes.scm
+ unit-tests/t0031-promotable-attributes.scm \
+ unit-tests/t1000-deprecated.scm
XFAIL_TESTS = unit-tests/t0031-promotable-attributes.scm
diff --git a/libgeda/scheme/unit-tests/t1000-deprecated.scm b/libgeda/scheme/unit-tests/t1000-deprecated.scm
new file mode 100644
index 0000000..21b67ca
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t1000-deprecated.scm
@@ -0,0 +1,76 @@
+;; Test deprecated procedures from legacy Scheme API.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+(use-modules (geda attrib))
+(use-modules (geda page))
+
+(begin-test 'get-attribute-name-value
+ (let ((t (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both)))
+ (assert-equal '("name" . "value") (get-attribute-name-value t))))
+
+(begin-test 'calcule-new-attrib-bounds
+ ; Can't actually test this procedure in libgeda only, due to the
+ ; absence of a function for calculating text bounds.
+ #f)
+
+(begin-test 'get-attribute-bounds
+ ; Can't actually test this procedure in libgeda only, due to the
+ ; absence of a function for calculating text bounds.
+ #f)
+
+(begin-test 'get-attribute-angle
+ (let ((t0 (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
+ (t90 (make-text '(1 . 2) 'lower-left 90 "name=value" 10 #t 'both)))
+ (assert-equal 0 (get-attribute-angle t0))
+ (assert-equal 90 (get-attribute-angle t90)) ))
+
+(begin-test 'get-object-attributes
+ (let ((C (make-component "testcomponent" '(0 . 0) 0 #f #f))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (x (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both))
+ (y (make-text '(0 . 0) 'lower-left 0 "name=y" 10 #t 'both)))
+
+ (for-each (lambda (o) (component-append! C o)) (list p x y))
+ (for-each (lambda (a) (attach-attrib! p a)) (list x y))
+
+ (assert-equal (list y x) (get-object-attributes p))))
+
+(begin-test 'get-attrib-value-by-attrib-name
+ (let ((C (make-component "testcomponent" '(0 . 0) 0 #f #f))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (x (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both))
+ (y (make-text '(0 . 0) 'lower-left 0 "name=y" 10 #t 'both))
+ (z (make-text '(0 . 0) 'lower-left 0 "bork=z" 10 #t 'both)))
+
+ (for-each (lambda (o) (component-append! C o)) (list p x y z))
+ (for-each (lambda (a) (attach-attrib! p a)) (list x y z))
+
+ (assert-equal (list "y" "x") (get-attrib-value-by-attrib-name p "name"))))
+
+(begin-test 'get-object-type
+ (let ((C (make-component "testcomponent" '(0 . 0) 0 #f #f))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (t (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both)))
+
+ ; Obviously not exhaustive
+ (assert-equal OBJ_COMPLEX (get-object-type C))
+ (assert-equal OBJ_PIN (get-object-type p))
+ (assert-equal OBJ_TEXT (get-object-type t))))
+
+(begin-test 'get-line-width
+ (let ((p (make-net-pin '(0 . 0) '(100 . 0))))
+
+ ; This will break if you change PIN_WIDTH_NET in defines.h
+ (assert-equal 10 (get-line-width p))))
+
+(define P (make-page "/test/page/A"))
+
+(begin-test 'get-page-filename
+ (assert-equal "/test/page/A" (get-page-filename P)))
+
+(begin-test 'set-page-filename
+ (set-page-filename P "/test/page/B")
+ (assert-equal "/test/page/B" (page-filename P)))
+
+(close-page! P)
commit fc8bcac43b6f3dd611f6030ffe36465d67be379d
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Port legacy Scheme procedures in C to new smob system.
Make all users of legacy Scheme smobs in libgeda use new Scheme smob
system. This is a preliminary patch so that unit tests can be written
to verify that functions ported to new API work the same way as the
originals.
diff --git a/gnetlist/src/g_netlist.c b/gnetlist/src/g_netlist.c
index d5cae12..295a3d8 100644
--- a/gnetlist/src/g_netlist.c
+++ b/gnetlist/src/g_netlist.c
@@ -40,7 +40,7 @@
SCM g_scm_c_get_uref (TOPLEVEL *toplevel, OBJECT *object)
{
SCM func = scm_variable_ref (scm_c_lookup ("get-uref"));
- SCM object_smob = g_make_object_smob (toplevel, object);
+ SCM object_smob = edascm_from_object (object);
SCM exp = scm_list_2 (func, object_smob);
return g_scm_eval_protected (exp, SCM_UNDEFINED);
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index 03a0d66..52cfeaf 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -74,7 +74,7 @@ SCM g_make_attrib_smob_list (GSCHEM_TOPLEVEL *w_current, OBJECT *object)
a_iter = g_list_next (a_iter)) {
a_current = a_iter->data;
- smob_list = scm_cons (g_make_attrib_smob (w_current->toplevel, a_current),
+ smob_list = scm_cons (edascm_from_object (a_current),
smob_list);
}
@@ -148,8 +148,9 @@ SCM g_add_attrib(SCM object, SCM scm_attrib_name,
SCM_ARG5, "add-attribute-to-object");
/* Get toplevel and o_current */
- SCM_ASSERT (g_get_data_from_object_smob (object, &toplevel, &o_current),
+ SCM_ASSERT (edascm_is_object (object),
object, SCM_ARG1, "add-attribute-to-object");
+ o_current = edascm_to_object (object);
/* Get parameters */
attrib_name = SCM_STRING_CHARS(scm_attrib_name);
@@ -210,16 +211,17 @@ The active connection end of the pin is the beginning, so this function cares ab
*/
SCM g_get_pin_ends(SCM object)
{
- TOPLEVEL *toplevel;
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *o_current;
SCM coord1 = SCM_EOL;
SCM coord2 = SCM_EOL;
SCM coords = SCM_EOL;
/* Get toplevel and o_current */
- SCM_ASSERT (g_get_data_from_object_smob (object, &toplevel, &o_current),
+ SCM_ASSERT (edascm_is_object (object),
object, SCM_ARG1, "get-pin-ends");
-
+ o_current = edascm_to_object (object);
+
/* Check that it is a pin object */
SCM_ASSERT (o_current != NULL,
object, SCM_ARG1, "get-pin-ends");
@@ -268,9 +270,7 @@ SCM g_set_attrib_text_properties(SCM attrib_smob, SCM scm_coloridx,
SCM scm_size, SCM scm_alignment,
SCM scm_rotation, SCM scm_x, SCM scm_y)
{
- struct st_attrib_smob *attribute =
- (struct st_attrib_smob *)SCM_CDR(attrib_smob);
- OBJECT *object;
+ OBJECT *object = edascm_to_object (attrib_smob);
GSCHEM_TOPLEVEL *w_current = g_current_window ();
TOPLEVEL *toplevel = w_current->toplevel;
@@ -342,9 +342,6 @@ SCM g_set_attrib_text_properties(SCM attrib_smob, SCM scm_coloridx,
SCM_ARG4, "set-attribute-text-properties!");
}
- if (attribute &&
- attribute->attribute) {
- object = attribute->attribute;
if (object &&
object->text) {
if (x != -1) {
@@ -364,7 +361,6 @@ SCM g_set_attrib_text_properties(SCM attrib_smob, SCM scm_coloridx,
}
o_text_recreate(toplevel, object);
}
- }
return SCM_BOOL_T;
}
@@ -531,7 +527,7 @@ static void custom_world_get_object_glist_bounds
SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclude_object_type)
{
- TOPLEVEL *toplevel=NULL;
+ TOPLEVEL *toplevel=edascm_c_current_toplevel ();
OBJECT *object=NULL;
int left=0, right=0, bottom=0, top=0;
SCM returned = SCM_EOL;
@@ -567,7 +563,7 @@ SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclu
}
/* Get toplevel and o_current. */
- g_get_data_from_object_smob (object_smob, &toplevel, &object);
+ object = edascm_to_object (object_smob);
SCM_ASSERT (toplevel && object,
object_smob, SCM_ARG1, "get-object-bounds");
@@ -603,15 +599,16 @@ SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclu
*/
SCM g_get_object_pins (SCM object_smob)
{
- TOPLEVEL *toplevel=NULL;
+ TOPLEVEL *toplevel=edascm_c_current_toplevel ();
OBJECT *object=NULL;
OBJECT *prim_obj;
GList *iter;
SCM returned=SCM_EOL;
/* Get toplevel and o_current */
- SCM_ASSERT (g_get_data_from_object_smob (object_smob, &toplevel, &object),
+ SCM_ASSERT (edascm_is_object (object_smob),
object_smob, SCM_ARG1, "get-object-pins");
+ object = edascm_to_object (object_smob);
if (!object) {
return (returned);
@@ -621,7 +618,7 @@ SCM g_get_object_pins (SCM object_smob)
while (iter != NULL) {
prim_obj = (OBJECT *)iter->data;
if (prim_obj->type == OBJ_PIN) {
- returned = scm_cons (g_make_object_smob(toplevel, prim_obj),returned);
+ returned = scm_cons (edascm_from_object (prim_obj), returned);
}
iter = g_list_next (iter);
}
@@ -651,7 +648,7 @@ SCM g_get_object_pins (SCM object_smob)
SCM g_add_component(SCM page_smob, SCM scm_comp_name, SCM scm_x, SCM scm_y,
SCM scm_angle, SCM scm_selectable, SCM scm_mirror)
{
- TOPLEVEL *toplevel;
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
PAGE *page;
gboolean selectable, mirror;
gchar *comp_name;
@@ -666,8 +663,10 @@ SCM g_add_component(SCM page_smob, SCM scm_comp_name, SCM scm_x, SCM scm_y,
}
/* Get toplevel and the page */
- SCM_ASSERT (g_get_data_from_page_smob (page_smob, &toplevel, &page),
+ SCM_ASSERT (edascm_is_page (page_smob),
page_smob, SCM_ARG1, "add-component-at-xy");
+ page = edascm_to_page (page_smob);
+
/* Check the arguments */
SCM_ASSERT (scm_is_string(scm_comp_name), scm_comp_name,
SCM_ARG2, "add-component-at-xy");
@@ -709,8 +708,7 @@ SCM g_add_component(SCM page_smob, SCM scm_comp_name, SCM scm_x, SCM scm_y,
/* Run the add component hook for the new component */
if (scm_hook_empty_p(add_component_object_hook) == SCM_BOOL_F) {
scm_run_hook(add_component_object_hook,
- scm_cons(g_make_object_smob(toplevel,
- new_obj), SCM_EOL));
+ scm_list_1 (edascm_from_object(new_obj)));
}
return SCM_BOOL_T;
@@ -725,21 +723,22 @@ SCM g_add_component(SCM page_smob, SCM scm_comp_name, SCM scm_x, SCM scm_y,
*/
SCM g_get_objects_in_page(SCM page_smob) {
- TOPLEVEL *toplevel;
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
PAGE *page;
OBJECT *object;
const GList *iter;
SCM return_list=SCM_EOL;
/* Get toplevel and the page */
- SCM_ASSERT (g_get_data_from_page_smob (page_smob, &toplevel, &page),
+ SCM_ASSERT (edascm_is_page (page_smob),
page_smob, SCM_ARG1, "add-component");
+ page = edascm_to_page (page_smob);
if (page && s_page_objects (page)) {
iter = s_page_objects (page);
while (iter != NULL) {
object = (OBJECT *)iter->data;
- return_list = scm_cons (g_make_object_smob(toplevel, object),
+ return_list = scm_cons (edascm_from_object (object),
return_list);
iter = g_list_next (iter);
}
@@ -751,5 +750,5 @@ SCM g_get_objects_in_page(SCM page_smob) {
SCM g_get_current_page(void)
{
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
- return (g_make_page_smob(toplevel, toplevel->page_current));
+ return (edascm_from_page (toplevel->page_current));
}
diff --git a/gschem/src/o_attrib.c b/gschem/src/o_attrib.c
index 348d631..23507f2 100644
--- a/gschem/src/o_attrib.c
+++ b/gschem/src/o_attrib.c
@@ -274,8 +274,7 @@ OBJECT *o_attrib_add_attrib(GSCHEM_TOPLEVEL *w_current,
if (scm_hook_empty_p(add_attribute_hook) == SCM_BOOL_F &&
o_current != NULL) {
scm_run_hook (add_attribute_hook,
- scm_cons (g_make_object_smob (toplevel, o_current),
- SCM_EOL));
+ scm_list_1 (edascm_from_object (o_current)));
}
toplevel->page_current->CHANGED = 1;
diff --git a/gschem/src/o_complex.c b/gschem/src/o_complex.c
index 10f8dbb..7ec586e 100644
--- a/gschem/src/o_complex.c
+++ b/gschem/src/o_complex.c
@@ -149,9 +149,7 @@ void o_complex_place_changed_run_hook(GSCHEM_TOPLEVEL *w_current) {
ptr = toplevel->page_current->place_list;
while (ptr) {
scm_run_hook(complex_place_list_changed_hook,
- scm_cons (g_make_object_smob
- (toplevel,
- (OBJECT *) ptr->data), SCM_EOL));
+ scm_list_1 (edascm_from_object ((OBJECT *) ptr->data)));
ptr = g_list_next(ptr);
}
@@ -191,8 +189,7 @@ void o_complex_end(GSCHEM_TOPLEVEL *w_current, int w_x, int w_y, int continue_pl
if (scm_hook_empty_p(add_component_object_hook) == SCM_BOOL_F) {
scm_run_hook(add_component_object_hook,
- scm_cons(g_make_object_smob(w_current->toplevel,
- o_current), SCM_EOL));
+ scm_list_1 (edascm_from_object(o_current)));
}
}
diff --git a/gschem/src/o_misc.c b/gschem/src/o_misc.c
index 2890bff..fe4b589 100644
--- a/gschem/src/o_misc.c
+++ b/gschem/src/o_misc.c
@@ -258,8 +258,7 @@ void o_rotate_call_hooks (GSCHEM_TOPLEVEL *w_current, GList *list)
/* Run the rotate pin hook */
if (scm_hook_empty_p (rotate_pin_hook) == SCM_BOOL_F) {
scm_run_hook (rotate_pin_hook,
- scm_cons (g_make_object_smob (toplevel, o_current),
- SCM_EOL));
+ scm_list_1 (edascm_from_object (o_current)));
}
break;
@@ -267,8 +266,7 @@ void o_rotate_call_hooks (GSCHEM_TOPLEVEL *w_current, GList *list)
/* Run the rotate hook */
if (scm_hook_empty_p (rotate_component_object_hook) == SCM_BOOL_F) {
scm_run_hook (rotate_component_object_hook,
- scm_cons (g_make_object_smob (toplevel, o_current),
- SCM_EOL));
+ scm_list_1 (edascm_from_object (o_current)));
}
break;
@@ -335,8 +333,7 @@ void o_mirror_world_update(GSCHEM_TOPLEVEL *w_current, int centerx, int centery,
if (scm_hook_empty_p(mirror_pin_hook) == SCM_BOOL_F &&
o_current != NULL) {
scm_run_hook(mirror_pin_hook,
- scm_cons(g_make_object_smob(toplevel, o_current),
- SCM_EOL));
+ scm_list_1 (edascm_from_object (o_current)));
}
break;
@@ -345,8 +342,7 @@ void o_mirror_world_update(GSCHEM_TOPLEVEL *w_current, int centerx, int centery,
if (scm_hook_empty_p(mirror_component_object_hook) == SCM_BOOL_F &&
o_current != NULL) {
scm_run_hook(mirror_component_object_hook,
- scm_cons(g_make_object_smob(toplevel, o_current),
- SCM_EOL));
+ scm_list_1 (edascm_from_object (o_current)));
}
break;
default:
diff --git a/gschem/src/o_pin.c b/gschem/src/o_pin.c
index 14345d7..79eb3fa 100644
--- a/gschem/src/o_pin.c
+++ b/gschem/src/o_pin.c
@@ -147,7 +147,7 @@ void o_pin_end(GSCHEM_TOPLEVEL *w_current, int x, int y)
if (scm_hook_empty_p (add_pin_hook) == SCM_BOOL_F) {
scm_run_hook (add_pin_hook,
- scm_cons (g_make_object_smob (toplevel, new_obj), SCM_EOL));
+ scm_list_1 (edascm_from_object (new_obj)));
}
toplevel->page_current->CHANGED=1;
diff --git a/gschem/src/x_window.c b/gschem/src/x_window.c
index ee17b00..07a4029 100644
--- a/gschem/src/x_window.c
+++ b/gschem/src/x_window.c
@@ -764,7 +764,7 @@ x_window_open_page (GSCHEM_TOPLEVEL *w_current, const gchar *filename)
if (scm_hook_empty_p (new_page_hook) == SCM_BOOL_F)
scm_run_hook (new_page_hook,
- scm_cons (g_make_page_smob (toplevel, page), SCM_EOL));
+ scm_list_1 (edascm_from_page (page)));
a_zoom_extents (w_current,
s_page_objects (toplevel->page_current),
diff --git a/libgeda/include/libgeda/prototype.h b/libgeda/include/libgeda/prototype.h
index c7d9707..90d87d0 100644
--- a/libgeda/include/libgeda/prototype.h
+++ b/libgeda/include/libgeda/prototype.h
@@ -44,15 +44,21 @@ void g_rc_parse(TOPLEVEL *toplevel, const gchar* rcname,
gint g_rc_parse_specified_rc(TOPLEVEL *toplevel, const gchar *rcfilename);
/* g_smob.c */
+#if 0
SCM g_make_attrib_smob(TOPLEVEL *curr_w, OBJECT *curr_attr);
+#endif
SCM g_set_attrib_value_internal(SCM attrib_smob, SCM scm_value, TOPLEVEL **world, OBJECT **o_attrib, char *new_string[]);
+#if 0
gboolean g_get_data_from_object_smob(SCM object_smob, TOPLEVEL **toplevel,
OBJECT **object);
SCM g_make_object_smob(TOPLEVEL *curr_w, OBJECT *object);
+#endif
SCM g_get_object_attributes(SCM object_smob);
+#if 0
SCM g_make_page_smob(TOPLEVEL *curr_w, PAGE *page);
gboolean g_get_data_from_page_smob(SCM object_smob, TOPLEVEL **toplevel,
PAGE **object);
+#endif
/* i_vars.c */
void i_vars_libgeda_set(TOPLEVEL *toplevel);
diff --git a/libgeda/src/g_smob.c b/libgeda/src/g_smob.c
index ea0980f..04c4139 100644
--- a/libgeda/src/g_smob.c
+++ b/libgeda/src/g_smob.c
@@ -26,11 +26,13 @@
#endif
#include "libgeda_priv.h"
+#include "libgedaguile.h"
#ifdef HAVE_LIBDMALLOC
#include <dmalloc.h>
#endif
+#if 0
static long attrib_smob_tag; /*! Attribute SMOB tag */
static long object_smob_tag; /*! Object SMOB tag */
static long page_smob_tag; /*! Page SMOB tag */
@@ -106,6 +108,7 @@ SCM g_make_attrib_smob(TOPLEVEL *curr_w, OBJECT *curr_attr)
/* Assumes Guile version >= 1.3.2 */
SCM_RETURN_NEWSMOB(attrib_smob_tag, smob_attribute);
}
+#endif
/*! \brief Get name and value of attribute.
* \par Function Description
@@ -116,20 +119,17 @@ SCM g_make_attrib_smob(TOPLEVEL *curr_w, OBJECT *curr_attr)
*/
SCM g_get_attrib_name_value(SCM attrib_smob)
{
- struct st_attrib_smob *attribute;
+ OBJECT *attribute;
char *name = NULL;
char *value = NULL;
SCM returned = SCM_EOL;
- SCM_ASSERT ( SCM_NIMP(attrib_smob) &&
- ((long) SCM_CAR(attrib_smob) == attrib_smob_tag),
+ SCM_ASSERT ( edascm_is_object (attrib_smob),
attrib_smob, SCM_ARG1, "get-attribute-name-value");
- attribute = (struct st_attrib_smob *)SCM_CDR(attrib_smob);
+ attribute = edascm_to_object (attrib_smob);
- if (attribute != NULL &&
- attribute->attribute != NULL &&
- o_attrib_get_name_value (attribute->attribute, &name, &value)) {
+ if (o_attrib_get_name_value (attribute, &name, &value)) {
returned = scm_cons (scm_makfrom0str (name),
scm_makfrom0str (value));
g_free(name);
@@ -157,28 +157,26 @@ SCM g_set_attrib_value_internal(SCM attrib_smob, SCM scm_value,
TOPLEVEL **world, OBJECT **o_attrib,
char *new_string[])
{
- struct st_attrib_smob *attribute;
+ OBJECT *attribute;
char *name = NULL;
char *value = NULL;
- SCM_ASSERT ( SCM_NIMP(attrib_smob) &&
- ((long) SCM_CAR(attrib_smob) == attrib_smob_tag),
+ SCM_ASSERT ( edascm_is_object (attrib_smob),
attrib_smob, SCM_ARG1, "set-attribute-value!");
SCM_ASSERT (scm_is_string(scm_value), scm_value, SCM_ARG2,
"set-attribute-value!");
- attribute = (struct st_attrib_smob *)SCM_CDR(attrib_smob);
+ attribute = edascm_to_object (attrib_smob);
value = scm_to_locale_string (scm_value);
- if (attribute != NULL &&
- attribute->attribute != NULL) {
+ if (attribute != NULL) {
- o_attrib_get_name_value (attribute->attribute, &name, NULL);
+ o_attrib_get_name_value (attribute, &name, NULL);
*new_string = g_strconcat (name, "=", value, NULL);
- *world = attribute->world;
- *o_attrib = attribute->attribute;
+ *world = edascm_c_current_toplevel ();
+ *o_attrib = attribute;
g_free(name);
}
@@ -287,16 +285,13 @@ SCM g_calcule_new_attrib_bounds (SCM attrib_smob, SCM scm_alignment,
SCM_ARG2, "calcule-new-attrib-bounds");
}
- attribute = (struct st_attrib_smob *)SCM_CDR(attrib_smob);
- toplevel = attribute->world;
+ toplevel = edascm_c_current_toplevel ();
+ object = edascm_to_object (attrib_smob);
- SCM_ASSERT ( attribute &&
- attribute->attribute &&
- attribute->attribute->text &&
- attribute->attribute->text->string,
+ SCM_ASSERT ( object &&
+ object->text &&
+ object->text->string,
attrib_smob, SCM_ARG1, "calcule-new-attrib-bounds");
-
- object = (OBJECT *) attribute->attribute;
/* Store the previous values */
old_alignment = object->text->alignment;
@@ -344,11 +339,13 @@ SCM g_calcule_new_attrib_bounds (SCM attrib_smob, SCM scm_alignment,
void g_init_attrib_smob(void)
{
+#if 0
attrib_smob_tag = scm_make_smob_type("attribute",
sizeof (struct st_attrib_smob));
scm_set_smob_mark(attrib_smob_tag, 0);
scm_set_smob_free(attrib_smob_tag, g_free_attrib_smob);
scm_set_smob_print(attrib_smob_tag, g_print_attrib_smob);
+#endif
scm_c_define_gsubr("get-attribute-name-value", 1, 0, 0,
g_get_attrib_name_value);
@@ -375,26 +372,23 @@ void g_init_attrib_smob(void)
*/
SCM g_get_attrib_bounds(SCM attrib_smob)
{
- TOPLEVEL *toplevel;
- struct st_attrib_smob *attribute;
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *attribute;
SCM vertical = SCM_EOL;
SCM horizontal = SCM_EOL;
int left=0, right=0, bottom=0, top=0;
SCM returned = SCM_EOL;
- SCM_ASSERT ( SCM_NIMP(attrib_smob) &&
- ((long) SCM_CAR(attrib_smob) == attrib_smob_tag),
+ SCM_ASSERT ( edascm_is_object (attrib_smob),
attrib_smob, SCM_ARG1, "get-attribute-bounds");
- attribute = (struct st_attrib_smob *)SCM_CDR(attrib_smob);
- toplevel = attribute->world;
+ attribute = edascm_to_object (attrib_smob);
if (attribute &&
- attribute->attribute &&
- attribute->attribute->text &&
- attribute->attribute->text->string ) {
+ attribute->text &&
+ attribute->text->string ) {
- world_get_text_bounds (toplevel, attribute->attribute, &left,
+ world_get_text_bounds (toplevel, attribute, &left,
&top, &right, &bottom);
horizontal = scm_cons (scm_from_int(left), scm_from_int(right));
@@ -414,23 +408,22 @@ SCM g_get_attrib_bounds(SCM attrib_smob)
SCM g_get_attrib_angle(SCM attrib_smob)
{
TOPLEVEL *toplevel;
- struct st_attrib_smob *attribute;
+ OBJECT *attribute;
- SCM_ASSERT ( SCM_NIMP(attrib_smob) &&
- ((long) SCM_CAR(attrib_smob) == attrib_smob_tag),
+ SCM_ASSERT ( edascm_is_object (attrib_smob),
attrib_smob, SCM_ARG1, "get-attribute-angle");
- attribute = (struct st_attrib_smob *)SCM_CDR(attrib_smob);
- toplevel = attribute->world;
+ attribute = edascm_to_object (attrib_smob);
+ toplevel = edascm_c_current_toplevel ();
- SCM_ASSERT ( attribute &&
- attribute->attribute &&
- attribute->attribute->text,
+ SCM_ASSERT ( attribute &&
+ attribute->text,
attrib_smob, SCM_ARG1, "get-attribute-angle");
- return scm_from_int(attribute->attribute->text->angle);
+ return scm_from_int(attribute->text->angle);
}
+#if 0
/*! \brief Free object smob memory.
* \par Function Description
* Free the memory allocated by the object smob and return its size.
@@ -499,6 +492,7 @@ SCM g_make_object_smob(TOPLEVEL *curr_w, OBJECT *object)
/* Assumes Guile version >= 1.3.2 */
SCM_RETURN_NEWSMOB(object_smob_tag, smob_object);
}
+#endif
/*! \brief Get all object attributes in a list.
* \par Function Description
@@ -510,26 +504,24 @@ SCM g_make_object_smob(TOPLEVEL *curr_w, OBJECT *object)
SCM g_get_object_attributes(SCM object_smob)
{
TOPLEVEL *toplevel;
- struct st_object_smob *object;
+ OBJECT *object;
SCM returned = SCM_EOL;
GList *a_iter;
OBJECT *a_current;
- SCM_ASSERT ( SCM_NIMP(object_smob) &&
- ((long) SCM_CAR(object_smob) == object_smob_tag),
+ SCM_ASSERT ( edascm_is_object (object_smob),
object_smob, SCM_ARG1, "get-object-attributes");
- object = (struct st_object_smob *)SCM_CDR(object_smob);
+ object = edascm_to_object (object_smob);
- if (object &&
- object->object) {
+ if (object) {
- toplevel = object->world;
- a_iter = object->object->attribs;
+ toplevel = edascm_c_current_toplevel ();
+ a_iter = object->attribs;
while (a_iter != NULL) {
a_current = a_iter->data;
if (a_current && a_current->text) {
- returned = scm_cons (g_make_attrib_smob (toplevel, a_current),
+ returned = scm_cons (edascm_from_object (a_current),
returned);
}
a_iter = g_list_next (a_iter);
@@ -552,28 +544,27 @@ SCM g_get_object_attributes(SCM object_smob)
SCM g_get_attrib_value_by_attrib_name(SCM object_smob, SCM scm_attrib_name)
{
TOPLEVEL *toplevel;
- struct st_object_smob *object;
+ OBJECT *object;
gchar *attrib_name=NULL;
SCM returned = SCM_EOL;
gchar *name=NULL, *value=NULL;
GList *a_iter;
OBJECT *a_current;
- SCM_ASSERT ( SCM_NIMP(object_smob) &&
- ((long) SCM_CAR(object_smob) == object_smob_tag),
+ SCM_ASSERT ( edascm_is_object (object_smob),
object_smob, SCM_ARG1, "get-attrib-value-by-attrib-name");
SCM_ASSERT (scm_is_string(scm_attrib_name), scm_attrib_name,
SCM_ARG2, "get-attrib-value-by-attrib-name");
/* Get parameters */
- object = (struct st_object_smob *)SCM_CDR(object_smob);
+ object = edascm_to_object (object_smob);
attrib_name = scm_to_locale_string (scm_attrib_name);
- if (object && object->object) {
+ if (object) {
- toplevel = object->world;
- a_iter = object->object->attribs;
+ toplevel = edascm_c_current_toplevel ();
+ a_iter = object->attribs;
while (a_iter != NULL) {
a_current = a_iter->data;
if (a_current != NULL &&
@@ -602,19 +593,13 @@ SCM g_get_attrib_value_by_attrib_name(SCM object_smob, SCM scm_attrib_name)
*/
SCM g_get_object_type(SCM object_smob)
{
- struct st_object_smob *object_struct;
OBJECT *object;
SCM returned = SCM_EOL;
- SCM_ASSERT ( SCM_NIMP(object_smob) &&
- ((long) SCM_CAR(object_smob) == object_smob_tag),
+ SCM_ASSERT ( edascm_is_object (object_smob),
object_smob, SCM_ARG1, "get-object-type");
-
- object_struct = (struct st_object_smob *)SCM_CDR(object_smob);
-
- g_assert (object_struct && object_struct->object);
- object = (OBJECT *) object_struct->object;
+ object = edascm_to_object (object_smob);
returned = SCM_MAKE_CHAR((unsigned char) object->type);
@@ -631,23 +616,12 @@ SCM g_get_object_type(SCM object_smob)
*/
SCM g_get_line_width(SCM object_smob)
{
- struct st_object_smob *object_struct;
- OBJECT *object;
- SCM returned = SCM_EOL;
+ SCM_ASSERT (edascm_is_object (object_smob),
+ object_smob, SCM_ARG1, "get-line-width");
- SCM_ASSERT ( SCM_NIMP(object_smob) &&
- ((long) SCM_CAR(object_smob) == object_smob_tag),
- object_smob, SCM_ARG1, "get-line-width");
+ OBJECT *object = edascm_to_object (object_smob);
- object_struct = (struct st_object_smob *)SCM_CDR(object_smob);
-
- g_assert (object_struct && object_struct->object);
-
- object = (OBJECT *) object_struct->object;
-
- returned = scm_from_int(object->line_width);
-
- return returned;
+ return scm_from_int(object->line_width);
}
/*! \brief Initialize the framework to support an object smob.
@@ -657,11 +631,12 @@ SCM g_get_line_width(SCM object_smob)
*/
void g_init_object_smob(void)
{
-
+#if 0
object_smob_tag = scm_make_smob_type("object", sizeof (struct st_object_smob));
scm_set_smob_mark(object_smob_tag, 0);
scm_set_smob_free(object_smob_tag, g_free_object_smob);
scm_set_smob_print(object_smob_tag, g_print_object_smob);
+#endif
scm_c_define_gsubr("get-object-attributes", 1, 0, 0, g_get_object_attributes);
scm_c_define_gsubr("get-attrib-value-by-attrib-name", 2, 0, 0,
@@ -672,7 +647,7 @@ void g_init_object_smob(void)
return;
}
-
+#if 0
/*! \brief Get the TOPLEVEL and OBJECT data from an object smob.
* \par Function Description
* Get the TOPLEVEL and OBJECT data from an object smob.
@@ -746,6 +721,7 @@ static int g_print_page_smob(SCM page_smob, SCM port,
/* non-zero means success */
return 1;
}
+#endif
/*! \brief Initialize the framework to support a page smob.
* \par Function Description
@@ -754,12 +730,13 @@ static int g_print_page_smob(SCM page_smob, SCM port,
*/
void g_init_page_smob(void)
{
-
+#if 0
page_smob_tag = scm_make_smob_type("page",
sizeof (struct st_page_smob));
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);
+#endif
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);
@@ -767,6 +744,7 @@ void g_init_page_smob(void)
return;
}
+#if 0
/*! \brief Creates a page smob
* \par Function Description
* This function creates and returns a new page smob,
@@ -817,6 +795,7 @@ gboolean g_get_data_from_page_smob(SCM page_smob, TOPLEVEL **toplevel,
}
return (TRUE);
}
+#endif
/*! \brief Get the page filename from a page smob.
* \par Function Description
@@ -830,12 +809,10 @@ SCM g_get_page_filename(SCM page_smob)
SCM returned = SCM_EOL;
PAGE *page;
- SCM_ASSERT ( SCM_NIMP(page_smob) &&
- ((long) SCM_CAR(page_smob) == page_smob_tag),
+ SCM_ASSERT ( edascm_is_page (page_smob),
page_smob, SCM_ARG1, "get-page-filename");
- page = (PAGE *)
- (((struct st_page_smob *)SCM_CDR(page_smob))->page);
+ page = edascm_to_page (page_smob);
if (page->page_filename)
returned = scm_makfrom0str (page->page_filename);
@@ -856,15 +833,13 @@ SCM g_set_page_filename(SCM page_smob, SCM scm_filename)
PAGE *page;
char *filename = NULL;
- SCM_ASSERT ( SCM_NIMP(page_smob) &&
- ((long) SCM_CAR(page_smob) == page_smob_tag),
+ SCM_ASSERT ( edascm_is_page (page_smob),
page_smob, SCM_ARG1, "set-page-filename");
SCM_ASSERT (scm_is_string(scm_filename), scm_filename,
SCM_ARG2, "set-page-filename");
- page = (PAGE *)
- (((struct st_page_smob *)SCM_CDR(page_smob))->page);
+ page = edascm_to_page (page_smob);
filename = SCM_STRING_CHARS (scm_filename);
commit a21ee2882d662a50418561f8de101d44bba7294c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Show "(null)" instead of "0" when printing deleted smobs.
diff --git a/libgeda/src/scheme_smob.c b/libgeda/src/scheme_smob.c
index de46fb0..f3a90f2 100644
--- a/libgeda/src/scheme_smob.c
+++ b/libgeda/src/scheme_smob.c
@@ -161,11 +161,15 @@ smob_print (SCM smob, SCM port, scm_print_state *pstate)
scm_puts ("unknown", port);
}
- scm_dynwind_begin (0);
- hexstring = g_strdup_printf (" %zx", SCM_SMOB_DATA (smob));
- scm_dynwind_unwind_handler (g_free, hexstring, SCM_F_WIND_EXPLICITLY);
- scm_puts (hexstring, port);
- scm_dynwind_end ();
+ if (SCM_SMOB_DATA (smob) != 0) {
+ scm_dynwind_begin (0);
+ hexstring = g_strdup_printf (" %p", (void *) SCM_SMOB_DATA (smob));
+ scm_dynwind_unwind_handler (g_free, hexstring, SCM_F_WIND_EXPLICITLY);
+ scm_puts (hexstring, port);
+ scm_dynwind_end ();
+ } else {
+ scm_puts (" (null)", port);
+ }
scm_puts (">", port);
commit 7f85f28e67c59dbccb0f2a321794b0ddbb3e578f
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Add e-mail address to copyright headers.
diff --git a/gschem/scheme/gschem/selection.scm b/gschem/scheme/gschem/selection.scm
index 9f33f73..4acdef2 100644
--- a/gschem/scheme/gschem/selection.scm
+++ b/gschem/scheme/gschem/selection.scm
@@ -1,6 +1,6 @@
;; gEDA - GPL Electronic Design Automation
;; gschem - gEDA Schematic Capture - Scheme API
-;; Copyright (C) 2010 Peter Brett
+;; Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
diff --git a/gschem/scheme/gschem/window.scm b/gschem/scheme/gschem/window.scm
index 94254a1..50c19da 100644
--- a/gschem/scheme/gschem/window.scm
+++ b/gschem/scheme/gschem/window.scm
@@ -1,6 +1,6 @@
;; gEDA - GPL Electronic Design Automation
;; gschem - gEDA Schematic Capture - Scheme API
-;; Copyright (C) 2010 Peter Brett
+;; Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
diff --git a/gschem/src/g_select.c b/gschem/src/g_select.c
index 9ec9a55..8e5a0c3 100644
--- a/gschem/src/g_select.c
+++ b/gschem/src/g_select.c
@@ -1,6 +1,6 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
- * Copyright (C) 2010 Peter Brett
+ * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
diff --git a/gschem/src/g_window.c b/gschem/src/g_window.c
index ec30f1c..0f3fb60 100644
--- a/gschem/src/g_window.c
+++ b/gschem/src/g_window.c
@@ -1,6 +1,6 @@
/* gEDA - GPL Electronic Design Automation
* gschem - gEDA Schematic Capture
- * Copyright (C) 2010 Peter Brett
+ * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
diff --git a/libgeda/scheme/geda/attrib.scm b/libgeda/scheme/geda/attrib.scm
index 6623d75..ba960c2 100644
--- a/libgeda/scheme/geda/attrib.scm
+++ b/libgeda/scheme/geda/attrib.scm
@@ -1,6 +1,6 @@
;; gEDA - GPL Electronic Design Automation
;; libgeda - gEDA's library - Scheme API
-;; Copyright (C) 2010 Peter Brett
+;; Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index bc12810..d819cc7 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -1,6 +1,6 @@
;; gEDA - GPL Electronic Design Automation
;; libgeda - gEDA's library - Scheme API
-;; Copyright (C) 2010 Peter Brett
+;; Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
diff --git a/libgeda/scheme/geda/page.scm b/libgeda/scheme/geda/page.scm
index e192cd1..1738b26 100644
--- a/libgeda/scheme/geda/page.scm
+++ b/libgeda/scheme/geda/page.scm
@@ -1,6 +1,6 @@
;; gEDA - GPL Electronic Design Automation
;; libgeda - gEDA's library - Scheme API
-;; Copyright (C) 2010 Peter Brett
+;; Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
commit 0a5c0a4f0d9e721bdf198c400db3cef607e72c33
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Multiple arguments for component & page append/remove.
It's a lot more convenient to write:
(component-append! component x y z ...)
than:
(for-each (lambda (x) (component-append! C x)) (list x y z ...))
So this patch makes it possible.
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 611e846..bc12810 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -615,16 +615,21 @@
;; object c.
(define-public component-contents %complex-contents)
-;; component-append! c obj
+;; component-append! c obj ...
;;
-;; Adds obj to the primitive objects of the component c. Returns obj.
-(define-public component-append! %complex-append!)
+;; Adds obj (and any additional objects) to the primitive objects of
+;; the component c. Returns c.
+(define-public (component-append! component . objects)
+ (for-each (lambda (x) (%complex-append! component x)) objects)
+ component)
-;; component-remove! c obj
+;; component-remove! c obj ...
;;
-;; Removes obj from the primitive objects of the component c. Returns
-;; obj.
-(define-public component-remove! %complex-remove!)
+;; Adds obj (and any additional objects) from the primitive objects of
+;; the component c. Returns c.
+(define-public (component-remove! component . objects)
+ (for-each (lambda (x) (%complex-remove! component x)) objects)
+ component)
;;;; Fill and stroke
diff --git a/libgeda/scheme/geda/page.scm b/libgeda/scheme/geda/page.scm
index 17fcbaf..e192cd1 100644
--- a/libgeda/scheme/geda/page.scm
+++ b/libgeda/scheme/geda/page.scm
@@ -34,10 +34,24 @@
(define-public page-filename %page-filename)
(define-public set-page-filename! %set-page-filename!)
(define-public page-contents %page-contents)
-(define-public page-append! %page-append!)
-(define-public page-remove! %page-remove!)
(define-public page-dirty? %page-dirty?)
+;; page-append! P obj ...
+;;
+;; Adds obj (and any additional objects) to the contents of the page
+;; P. Returns P.
+(define-public (page-append! P . objects)
+ (for-each (lambda (x) (%page-append! P x)) objects)
+ P)
+
+;; page-remove! P obj ...
+;;
+;; Removes obj (and any additional objects) from the contents of the
+;; page P. Returns P.
+(define-public (page-remove! P . objects)
+ (for-each (lambda (x) (%page-remove! P x)) objects)
+ P)
+
;; set-page-dirty! [state]
;;
;; Set whether page is flagged as changed according to the optional
diff --git a/libgeda/scheme/unit-tests/t0015-object-complex.scm b/libgeda/scheme/unit-tests/t0015-object-complex.scm
index ebcd7cd..9d00441 100644
--- a/libgeda/scheme/unit-tests/t0015-object-complex.scm
+++ b/libgeda/scheme/unit-tests/t0015-object-complex.scm
@@ -41,13 +41,13 @@
(assert-equal '() (component-contents A))
- (assert-equal x (component-append! A x))
+ (assert-equal A (component-append! A x))
(assert-equal (list x) (component-contents A))
- (assert-equal x (component-append! A x))
+ (component-append! A x)
(assert-equal (list x) (component-contents A))
- (assert-equal y (component-append! A y))
+ (component-append! A y)
(assert-equal (list x y) (component-contents A))
(assert-thrown 'object-state
@@ -61,14 +61,17 @@
(z (make-line '(1 . 0) '(2 . 2))))
(component-append! A x)
- (assert-equal x (component-remove! A x))
+ (assert-equal A (component-remove! A x))
(assert-equal '() (component-contents A))
- (assert-equal x (component-remove! A x))
- (assert-equal x (component-remove! B x))
+ (component-remove! A x)
+ (component-remove! B x)
- (component-append! A x)
- (component-append! A y)
- (assert-equal x (component-remove! A x))
+ (component-append! A x y)
+ (component-remove! A x y)
+ (assert-equal '() (component-contents A))
+
+ (component-append! A x y)
+ (component-remove! A x)
(assert-equal (list y) (component-contents A))
(assert-thrown 'object-state
@@ -128,8 +131,9 @@
(begin-test 'component-translate
(let* ((A (make-component "test component" '(0 . 0) 0 #t #f))
- (x (component-append! A (make-box '(0 . 2) '(2 . 0)))))
+ (x (make-box '(0 . 2) '(2 . 0))))
+ (component-append! A x)
(set-component! A '(1 . 1) 0 #t #f)
(assert-equal '(1 . 3) (box-top-left x))
(assert-equal '(3 . 1) (box-bottom-right x))))
@@ -138,7 +142,7 @@
(let ((comp (make-component "test component" '(1 . 2) 0 #t #f))
(pin (make-net-pin '(0 . 0) '(100 . 0)))
(attrib (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both)))
- (for-each (lambda (x) (component-append! comp x)) (list pin attrib))
+ (component-append! comp pin attrib)
(attach-attrib! pin attrib)
(assert-thrown 'object-state (component-remove! comp pin))
(assert-thrown 'object-state (component-remove! comp attrib))))
diff --git a/libgeda/scheme/unit-tests/t0018-object-connections.scm b/libgeda/scheme/unit-tests/t0018-object-connections.scm
index 74595fe..3665f34 100644
--- a/libgeda/scheme/unit-tests/t0018-object-connections.scm
+++ b/libgeda/scheme/unit-tests/t0018-object-connections.scm
@@ -18,11 +18,11 @@
(assert-thrown 'object-state (object-connections np))
;; Build component
- (for-each (lambda (x) (component-append! C x)) (list np bp))
+ (component-append! C np bp)
(assert-thrown 'object-state (object-connections np))
;; Build page
- (for-each (lambda (x) (page-append! P x)) (list C n1 n2 b1 b2))
+ (page-append! P C n1 n2 b1 b2)
;; Test initial connections
(assert-equal (list n1 b1) (object-connections C))
diff --git a/libgeda/scheme/unit-tests/t0020-page.scm b/libgeda/scheme/unit-tests/t0020-page.scm
index 151338e..0837c92 100644
--- a/libgeda/scheme/unit-tests/t0020-page.scm
+++ b/libgeda/scheme/unit-tests/t0020-page.scm
@@ -29,13 +29,10 @@
(lambda ()
(assert-equal '() (page-contents A))
- (assert-equal x (page-append! A x))
+ (assert-equal A (page-append! A x))
(assert-equal (list x) (page-contents A))
- (assert-equal x (page-append! A x))
- (assert-equal (list x) (page-contents A))
-
- (assert-equal y (page-append! A y))
+ (assert-equal A (page-append! A x y))
(assert-equal (list x y) (page-contents A))
(assert-thrown 'object-state
@@ -43,7 +40,8 @@
(assert-thrown 'object-state
(let* ((C (make-component "test component" '(1 . 2) 0 #t #f))
- (z (component-append! C (make-line '(1 . 0) '(2 . 2)))))
+ (z (make-line '(1 . 0) '(2 . 2))))
+ (component-append! C z)
(page-append! A z))))
(lambda ()
@@ -62,14 +60,13 @@
(lambda () #f)
(lambda ()
(page-append! A x)
- (assert-equal x (page-remove! A x))
+ (assert-equal A (page-remove! A x))
(assert-equal '() (page-contents A))
- (assert-equal x (page-remove! A x))
- (assert-equal x (page-remove! B x))
+ (assert-equal A (page-remove! A x))
+ (assert-equal B (page-remove! B x))
- (page-append! A x)
- (page-append! A y)
- (assert-equal x (page-remove! A x))
+ (page-append! A x y)
+ (assert-equal A (page-remove! A x))
(assert-equal (list y) (page-contents A))
(assert-thrown 'object-state
diff --git a/libgeda/scheme/unit-tests/t0021-page-dirty.scm b/libgeda/scheme/unit-tests/t0021-page-dirty.scm
index 2de00c5..27bbd5d 100644
--- a/libgeda/scheme/unit-tests/t0021-page-dirty.scm
+++ b/libgeda/scheme/unit-tests/t0021-page-dirty.scm
@@ -95,7 +95,7 @@
(lambda () #f)
(lambda ()
; Populate page
- (page-append! P t) (page-append! P C) (component-append! C p)
+ (page-append! P t C) (component-append! C p)
; Attach attribute to component
(assert-dirties P (attach-attrib! C t))
@@ -103,7 +103,8 @@
(assert-dirties P (detach-attrib! C t))
; Move attribute into component
- (component-append! C (page-remove! P t))
+ (page-remove! P t)
+ (component-append! C t)
; Attach attribute to pin
(assert-dirties P (attach-attrib! p t))
diff --git a/libgeda/scheme/unit-tests/t0030-attribute.scm b/libgeda/scheme/unit-tests/t0030-attribute.scm
index 0a6fc07..2c40ffc 100644
--- a/libgeda/scheme/unit-tests/t0030-attribute.scm
+++ b/libgeda/scheme/unit-tests/t0030-attribute.scm
@@ -36,7 +36,7 @@
(assert-true (not (attrib-attachment x)))
;; Populate components
- (for-each (lambda (o) (component-append! C o)) (list p q x y))
+ (component-append! C p q x y)
(component-append! D z)
;; Attach attribute to object in same component
@@ -88,8 +88,8 @@
(lambda () #f)
(lambda ()
; Populate pages
- (page-append! P x) (page-append! P C)
- (component-append! C p) (component-append! C y)
+ (page-append! P x C)
+ (component-append! C p y)
(page-append! Q z)
@@ -125,7 +125,7 @@
(pin2 (make-net-pin '(0 . 100) '(100 . 100)))
(x (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both)))
- (for-each (lambda (x) (page-append! page x)) (list pin1 pin2 x))
+ (page-append! page pin1 pin2 x)
(attach-attrib! pin1 x)
@@ -145,7 +145,7 @@
(assert-equal '() (inherited-attribs C))
;; Set up component
- (for-each (lambda (o) (component-append! C o)) (list p x y))
+ (component-append! C p x y)
(assert-equal (list x y) (inherited-attribs C))
diff --git a/libgeda/src/scheme_complex.c b/libgeda/src/scheme_complex.c
index 53b342c..d76539a 100644
--- a/libgeda/src/scheme_complex.c
+++ b/libgeda/src/scheme_complex.c
@@ -289,7 +289,7 @@ SCM_DEFINE (complex_append_x, "%complex-append!", 2, 0, 0,
o_page_changed (toplevel, parent);
- return obj_s;
+ return complex_s;
}
/*! \brief Remove a primitive object from a complex object.
@@ -367,7 +367,7 @@ SCM_DEFINE (complex_remove_x, "%complex-remove!", 2, 0, 0,
/* Object cleanup now managed by Guile. */
edascm_c_set_gc (obj_s, 1);
- return obj_s;
+ return complex_s;
}
/*!
diff --git a/libgeda/src/scheme_page.c b/libgeda/src/scheme_page.c
index 5d017ba..f866936 100644
--- a/libgeda/src/scheme_page.c
+++ b/libgeda/src/scheme_page.c
@@ -224,7 +224,7 @@ SCM_DEFINE (object_page, "%object-page", 1, 0, 0,
* \note Scheme API: Implements the %page-append! procedure of the
* (geda core page) module.
*
- * \return \a obj_s.
+ * \return \a page_s.
*/
SCM_DEFINE (page_append_x, "%page-append!", 2, 0, 0,
(SCM page_s, SCM obj_s), "Add an object to a page.")
@@ -257,7 +257,7 @@ SCM_DEFINE (page_append_x, "%page-append!", 2, 0, 0,
o_emit_change_notify (toplevel, obj);
page->CHANGED = 1; /* Ugh. */
- return obj_s;
+ return page_s;
}
/*! \brief Remove an object from a page.
@@ -269,7 +269,7 @@ SCM_DEFINE (page_append_x, "%page-append!", 2, 0, 0,
* \note Scheme API: Implements the %page-remove! procedure of the
* (geda core page) module.
*
- * \return \a obj_s.
+ * \return \a page_s.
*/
SCM_DEFINE (page_remove_x, "%page-remove!", 2, 0, 0,
(SCM page_s, SCM obj_s), "Remove an object from a page.")
@@ -318,7 +318,7 @@ SCM_DEFINE (page_remove_x, "%page-remove!", 2, 0, 0,
/* Object cleanup now managed by Guile. */
edascm_c_set_gc (obj_s, 1);
- return obj_s;
+ return page_s;
}
/*! \brief Check whether a page has been flagged as changed.
commit 6359f03b8615d707b122d84c6e73ae6bf99c097b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme_api: Give modifying functions _x suffixes in C.
When Scheme functions modify their arguments or have side-effects,
they use a `!' at the end of the function name. In C, this is
commonly represented with a _x suffix. This patch adopts that
convention.
diff --git a/gschem/src/g_select.c b/gschem/src/g_select.c
index b41edc9..9ec9a55 100644
--- a/gschem/src/g_select.c
+++ b/gschem/src/g_select.c
@@ -63,19 +63,19 @@ SCM_DEFINE (page_selection, "%page-selection", 1, 0, 0,
* \param obj_s #OBJECT smob for object to be selected.
* \return obj_s.
*/
-SCM_DEFINE (select_object_, "%select-object!", 1, 0, 0,
+SCM_DEFINE (select_object_x, "%select-object!", 1, 0, 0,
(SCM obj_s), "Select an object.")
{
/* Ensure that the argument is an object smob */
SCM_ASSERT (edascm_is_object (obj_s), obj_s,
- SCM_ARG1, s_select_object_);
+ SCM_ARG1, s_select_object_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *obj = edascm_to_object (obj_s);
PAGE *page = o_get_page (toplevel, obj);
if ((page == NULL) || (obj->parent != NULL)) {
scm_error (object_state_sym,
- s_select_object_,
+ s_select_object_x,
_("Object ~A is not directly included in a page."),
scm_list_1 (obj_s), SCM_EOL);
}
@@ -100,19 +100,19 @@ SCM_DEFINE (select_object_, "%select-object!", 1, 0, 0,
* \param obj_s #OBJECT smob for object to be deselected.
* \return obj_s.
*/
-SCM_DEFINE (deselect_object, "%deselect-object!", 1, 0, 0,
+SCM_DEFINE (deselect_object_x, "%deselect-object!", 1, 0, 0,
(SCM obj_s), "Deselect an object.")
{
/* Ensure that the argument is an object smob */
SCM_ASSERT (edascm_is_object (obj_s), obj_s,
- SCM_ARG1, s_deselect_object);
+ SCM_ARG1, s_deselect_object_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *obj = edascm_to_object (obj_s);
PAGE *page = o_get_page (toplevel, obj);
if ((page == NULL) || (obj->parent != NULL)) {
scm_error (object_state_sym,
- s_deselect_object,
+ s_deselect_object_x,
_("Object ~A is not directly included in a page."),
scm_list_1 (obj_s), SCM_EOL);
}
@@ -167,7 +167,7 @@ init_module_gschem_core_select ()
#include "g_select.x"
/* Add them to the module's public definitions. */
- scm_c_export (s_page_selection, s_select_object_, s_deselect_object,
+ scm_c_export (s_page_selection, s_select_object_x, s_deselect_object_x,
s_object_selected_p, NULL);
}
diff --git a/gschem/src/g_window.c b/gschem/src/g_window.c
index 0ce352f..ec30f1c 100644
--- a/gschem/src/g_window.c
+++ b/gschem/src/g_window.c
@@ -174,10 +174,10 @@ SCM_DEFINE (active_page, "%active-page", 0, 0, 0,
* \param page_s Page to switch to.
* \return \a page_s.
*/
-SCM_DEFINE (set_active_page, "%set-active-page!", 1, 0, 0,
+SCM_DEFINE (set_active_page_x, "%set-active-page!", 1, 0, 0,
(SCM page_s), "Set the active page.")
{
- SCM_ASSERT (edascm_is_page (page_s), page_s, SCM_ARG1, s_set_active_page);
+ SCM_ASSERT (edascm_is_page (page_s), page_s, SCM_ARG1, s_set_active_page_x);
PAGE *page = edascm_to_page (page_s);
x_window_set_current_page (g_current_window (), page);
@@ -197,12 +197,12 @@ SCM_DEFINE (set_active_page, "%set-active-page!", 1, 0, 0,
* \param page_s Page to close.
* \return SCM_UNDEFINED
*/
-SCM_DEFINE (close_page, "%close-page!", 1, 0, 0,
+SCM_DEFINE (close_page_x, "%close-page!", 1, 0, 0,
(SCM page_s), "Close a page.")
{
/* Ensure that the argument is a page smob */
SCM_ASSERT (edascm_is_page (page_s), page_s,
- SCM_ARG1, s_close_page);
+ SCM_ARG1, s_close_page_x);
GSCHEM_TOPLEVEL *w_current = g_current_window ();
TOPLEVEL *toplevel = w_current->toplevel;
@@ -240,14 +240,14 @@ init_module_gschem_core_window ()
#include "g_window.x"
/* Add them to the module's public definitions. */
- scm_c_export (s_current_window, s_active_page, s_set_active_page, s_close_page,
- NULL);
+ scm_c_export (s_current_window, s_active_page, s_set_active_page_x,
+ s_close_page_x, NULL);
/* Override procedures in the (geda core page) module */
{
SCM geda_page_module = scm_c_resolve_module ("geda core page");
- SCM close_page_proc = scm_variable_ref (scm_c_lookup (s_close_page));
- scm_c_module_define (geda_page_module, s_close_page, close_page_proc);
+ SCM close_page_proc = scm_variable_ref (scm_c_lookup (s_close_page_x));
+ scm_c_module_define (geda_page_module, s_close_page_x, close_page_proc);
}
}
diff --git a/libgeda/src/scheme_attrib.c b/libgeda/src/scheme_attrib.c
index 84df721..6059b20 100644
--- a/libgeda/src/scheme_attrib.c
+++ b/libgeda/src/scheme_attrib.c
@@ -138,13 +138,13 @@ SCM_DEFINE (attrib_attachment, "%attrib-attachment", 1, 0, 0,
* \param attrib_s the attribute to attach.
* \return \a attrib_s.
*/
-SCM_DEFINE (attach_attrib, "%attach-attrib!", 2, 0, 0,
+SCM_DEFINE (attach_attrib_x, "%attach-attrib!", 2, 0, 0,
(SCM obj_s, SCM attrib_s), "Attach an attribute to an object.")
{
SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
- SCM_ARG1, s_attach_attrib);
+ SCM_ARG1, s_attach_attrib_x);
SCM_ASSERT (edascm_is_object_type (attrib_s, OBJ_TEXT), attrib_s,
- SCM_ARG2, s_attach_attrib);
+ SCM_ARG2, s_attach_attrib_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *obj = edascm_to_object (obj_s);
@@ -154,19 +154,19 @@ SCM_DEFINE (attach_attrib, "%attach-attrib!", 2, 0, 0,
if ((obj->parent != attrib->parent)
|| (o_get_page (toplevel, obj) != o_get_page (toplevel, attrib))
|| ((obj->parent == NULL) && (o_get_page (toplevel, obj) == NULL))) {
- scm_error (edascm_object_state_sym, s_attach_attrib,
+ scm_error (edascm_object_state_sym, s_attach_attrib_x,
_("Objects ~A and ~A are not part of the same page and/or complex object"),
scm_list_2 (obj_s, attrib_s), SCM_EOL);
}
/* Check that neither is already an attached attribute */
if (obj->attached_to != NULL) {
- scm_error (edascm_object_state_sym, s_attach_attrib,
+ scm_error (edascm_object_state_sym, s_attach_attrib_x,
_("Object ~A is already attached as an attribute"),
scm_list_1 (obj_s), SCM_EOL);
}
if (attrib->attached_to != NULL) {
- scm_error (edascm_object_state_sym, s_attach_attrib,
+ scm_error (edascm_object_state_sym, s_attach_attrib_x,
_("Object ~A is already attached as an attribute"),
scm_list_1 (attrib_s), SCM_EOL);
}
@@ -195,13 +195,13 @@ SCM_DEFINE (attach_attrib, "%attach-attrib!", 2, 0, 0,
* \param attrib_s the attribute to detach.
* \return \a attrib_s.
*/
-SCM_DEFINE (detach_attrib, "%detach-attrib!", 2, 0, 0,
+SCM_DEFINE (detach_attrib_x, "%detach-attrib!", 2, 0, 0,
(SCM obj_s, SCM attrib_s), "Detach an attribute to an object.")
{
SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
- SCM_ARG1, s_detach_attrib);
+ SCM_ARG1, s_detach_attrib_x);
SCM_ASSERT (edascm_is_object_type (attrib_s, OBJ_TEXT), attrib_s,
- SCM_ARG2, s_detach_attrib);
+ SCM_ARG2, s_detach_attrib_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *obj = edascm_to_object (obj_s);
@@ -209,7 +209,7 @@ SCM_DEFINE (detach_attrib, "%detach-attrib!", 2, 0, 0,
/* Check that attrib isn't attached elsewhere */
if (attrib->attached_to != obj) {
- scm_error (edascm_object_state_sym, s_detach_attrib,
+ scm_error (edascm_object_state_sym, s_detach_attrib_x,
_("Object ~A is attribute of wrong object"),
scm_list_1 (attrib_s), SCM_EOL);
}
@@ -263,7 +263,7 @@ init_module_geda_core_attrib ()
/* Add them to the module's public definitions. */
scm_c_export (s_parse_attrib, s_object_attribs, s_attrib_attachment,
- s_attach_attrib, s_detach_attrib,
+ s_attach_attrib_x, s_detach_attrib_x,
s_promotable_attribs,
NULL);
}
diff --git a/libgeda/src/scheme_complex.c b/libgeda/src/scheme_complex.c
index 189dc91..53b342c 100644
--- a/libgeda/src/scheme_complex.c
+++ b/libgeda/src/scheme_complex.c
@@ -120,15 +120,15 @@ SCM_DEFINE (make_complex_library, "%make-complex/library", 1, 0, 0,
*
* \return the modified \a complex_s.
*/
-SCM_DEFINE (set_complex, "%set-complex!", 6, 0, 0,
+SCM_DEFINE (set_complex_x, "%set-complex!", 6, 0, 0,
(SCM complex_s, SCM x_s, SCM y_s, SCM angle_s, SCM mirror_s,
SCM locked_s), "Set complex object parameters")
{
SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
- SCM_ARG1, s_set_complex);
- SCM_ASSERT (scm_is_integer (x_s), x_s, SCM_ARG2, s_set_complex);
- SCM_ASSERT (scm_is_integer (y_s), y_s, SCM_ARG3, s_set_complex);
- SCM_ASSERT (scm_is_integer (angle_s), angle_s, SCM_ARG4, s_set_complex);
+ SCM_ARG1, s_set_complex_x);
+ SCM_ASSERT (scm_is_integer (x_s), x_s, SCM_ARG2, s_set_complex_x);
+ SCM_ASSERT (scm_is_integer (y_s), y_s, SCM_ARG3, s_set_complex_x);
+ SCM_ASSERT (scm_is_integer (angle_s), angle_s, SCM_ARG4, s_set_complex_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *obj = edascm_to_object (complex_s);
@@ -144,7 +144,7 @@ SCM_DEFINE (set_complex, "%set-complex!", 6, 0, 0,
break;
default:
/* Otherwise, not fine. */
- scm_misc_error (s_set_complex,
+ scm_misc_error (s_set_complex_x,
_("Invalid complex angle ~A. Must be 0, 90, 180, or 270 degrees"),
scm_list_1 (angle_s));
}
@@ -240,17 +240,17 @@ SCM_DEFINE (complex_contents, "%complex-contents", 1, 0, 0,
* \param obj_s primitive object to add.
* \return \a obj_s.
*/
-SCM_DEFINE (complex_append, "%complex-append!", 2, 0, 0,
+SCM_DEFINE (complex_append_x, "%complex-append!", 2, 0, 0,
(SCM complex_s, SCM obj_s),
"Add a primitive object to a complex object")
{
/* Ensure that the arguments have the correct types. */
SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
- SCM_ARG1, s_complex_append);
+ SCM_ARG1, s_complex_append_x);
SCM_ASSERT ((EDASCM_OBJECTP (obj_s)
&& !edascm_is_object_type (obj_s, OBJ_COMPLEX)
&& !edascm_is_object_type (obj_s, OBJ_PLACEHOLDER)),
- obj_s, SCM_ARG2, s_complex_append);
+ obj_s, SCM_ARG2, s_complex_append_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *parent = edascm_to_object (complex_s);
@@ -261,7 +261,7 @@ SCM_DEFINE (complex_append, "%complex-append!", 2, 0, 0,
if ((o_get_page (toplevel, child) != NULL)
|| ((child->parent != NULL) && (child->parent != parent))) {
scm_error (edascm_object_state_sym,
- s_complex_append,
+ s_complex_append_x,
_("Object ~A is already attached to something"),
scm_list_1 (obj_s), SCM_EOL);
}
@@ -305,14 +305,14 @@ SCM_DEFINE (complex_append, "%complex-append!", 2, 0, 0,
* \param obj_s primitive object to remove.
* \return \a obj_s.
*/
-SCM_DEFINE (complex_remove, "%complex-remove!", 2, 0, 0,
+SCM_DEFINE (complex_remove_x, "%complex-remove!", 2, 0, 0,
(SCM complex_s, SCM obj_s),
"Remove a primitive object from a complex object")
{
/* Ensure that the arguments have the correct types. */
SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
- SCM_ARG1, s_complex_remove);
- SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s, SCM_ARG2, s_complex_remove);
+ SCM_ARG1, s_complex_remove_x);
+ SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s, SCM_ARG2, s_complex_remove_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *parent = edascm_to_object (complex_s);
@@ -321,28 +321,28 @@ SCM_DEFINE (complex_remove, "%complex-remove!", 2, 0, 0,
/* Check that object is not attached to a different complex. */
if ((child->parent != NULL) && (child->parent != parent)) {
- scm_error (edascm_object_state_sym, s_complex_remove,
+ scm_error (edascm_object_state_sym, s_complex_remove_x,
_("Object ~A is attached to a different complex"),
scm_list_1 (obj_s), SCM_EOL);
}
/* Check that object is not attached to a page. */
if ((child->parent == NULL) && (child_page != NULL)) {
- scm_error (edascm_object_state_sym, s_complex_remove,
+ scm_error (edascm_object_state_sym, s_complex_remove_x,
_("Object ~A is attached to a page"),
scm_list_1 (obj_s), SCM_EOL);
}
/* Check that object is not attached as an attribute. */
if (child->attached_to != NULL) {
- scm_error (edascm_object_state_sym, s_complex_remove,
+ scm_error (edascm_object_state_sym, s_complex_remove_x,
_("Object ~A is attached as an attribute"),
scm_list_1 (obj_s), SCM_EOL);
}
/* Check that object doesn't have attributes. */
if (child->attribs != NULL) {
- scm_error (edascm_object_state_sym, s_complex_remove,
+ scm_error (edascm_object_state_sym, s_complex_remove_x,
_("Object ~A has attributes"),
scm_list_1 (obj_s), SCM_EOL);
}
@@ -383,9 +383,9 @@ init_module_geda_core_complex ()
#include "scheme_complex.x"
/* Add them to the module's public definitions. */
- scm_c_export (s_make_complex, s_make_complex_library, s_set_complex,
- s_complex_info, s_complex_contents, s_complex_append,
- s_complex_remove, NULL);
+ scm_c_export (s_make_complex, s_make_complex_library, s_set_complex_x,
+ s_complex_info, s_complex_contents, s_complex_append_x,
+ s_complex_remove_x, NULL);
}
/*!
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index 57272ea..ee0283b 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -396,7 +396,7 @@ SCM_DEFINE (object_stroke, "%object-stroke", 1, 0, 0,
* dotted.
* \return \a obj_s.
*/
-SCM_DEFINE (set_object_stroke, "%set-object-stroke!", 4, 2, 0,
+SCM_DEFINE (set_object_stroke_x, "%set-object-stroke!", 4, 2, 0,
(SCM obj_s, SCM width_s, SCM cap_s, SCM dash_s, SCM space_s,
SCM length_s), "Set the stroke properties of an object.")
{
@@ -405,18 +405,18 @@ SCM_DEFINE (set_object_stroke, "%set-object-stroke!", 4, 2, 0,
|| edascm_is_object_type (obj_s, OBJ_CIRCLE)
|| edascm_is_object_type (obj_s, OBJ_ARC)
|| edascm_is_object_type (obj_s, OBJ_PATH)),
- obj_s, SCM_ARG1, s_set_object_stroke);
+ obj_s, SCM_ARG1, s_set_object_stroke_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *obj = edascm_to_object (obj_s);
int cap, type, width, length = -1, space = -1;
SCM_ASSERT (scm_is_integer (width_s), width_s,
- SCM_ARG2, s_set_object_stroke);
+ SCM_ARG2, s_set_object_stroke_x);
SCM_ASSERT (scm_is_symbol (cap_s), cap_s,
- SCM_ARG3, s_set_object_stroke);
+ SCM_ARG3, s_set_object_stroke_x);
SCM_ASSERT (scm_is_symbol (dash_s), dash_s,
- SCM_ARG4, s_set_object_stroke);
+ SCM_ARG4, s_set_object_stroke_x);
width = scm_to_int (width_s);
@@ -424,7 +424,7 @@ SCM_DEFINE (set_object_stroke, "%set-object-stroke!", 4, 2, 0,
else if (cap_s == square_sym) { cap = END_SQUARE; }
else if (cap_s == round_sym) { cap = END_ROUND; }
else {
- scm_misc_error (s_set_object_stroke,
+ scm_misc_error (s_set_object_stroke_x,
_("Invalid stroke cap style ~A."),
scm_list_1 (cap_s));
}
@@ -435,7 +435,7 @@ SCM_DEFINE (set_object_stroke, "%set-object-stroke!", 4, 2, 0,
else if (dash_s == center_sym) { type = TYPE_CENTER; }
else if (dash_s == phantom_sym) { type = TYPE_PHANTOM; }
else {
- scm_misc_error (s_set_object_stroke,
+ scm_misc_error (s_set_object_stroke_x,
_("Invalid stroke dash style ~A."),
scm_list_1 (dash_s));
}
@@ -445,22 +445,22 @@ SCM_DEFINE (set_object_stroke, "%set-object-stroke!", 4, 2, 0,
case TYPE_CENTER:
case TYPE_PHANTOM:
if (length_s == SCM_UNDEFINED) {
- scm_misc_error (s_set_object_stroke,
+ scm_misc_error (s_set_object_stroke_x,
_("Missing dash length parameter for dash style ~A."),
scm_list_1 (length_s));
}
SCM_ASSERT (scm_is_integer (length_s), length_s,
- SCM_ARG6, s_set_object_stroke);
+ SCM_ARG6, s_set_object_stroke_x);
length = scm_to_int (length_s);
/* This case intentionally falls through */
case TYPE_DOTTED:
if (space_s == SCM_UNDEFINED) {
- scm_misc_error (s_set_object_stroke,
+ scm_misc_error (s_set_object_stroke_x,
_("Missing dot/dash space parameter for dash style ~A."),
scm_list_1 (space_s));
}
SCM_ASSERT (scm_is_integer (space_s), space_s,
- SCM_ARG5, s_set_object_stroke);
+ SCM_ARG5, s_set_object_stroke_x);
space = scm_to_int (space_s);
/* This case intentionally falls through */
}
@@ -546,7 +546,7 @@ SCM_DEFINE (object_fill, "%object-fill", 1, 0, 0,
* \param obj_s object to set fill settings for.
* \return \a obj_s.
*/
-SCM_DEFINE (set_object_fill, "%set-object-fill!", 2, 5, 0,
+SCM_DEFINE (set_object_fill_x, "%set-object-fill!", 2, 5, 0,
(SCM obj_s, SCM type_s, SCM width_s, SCM space1_s, SCM angle1_s,
SCM space2_s, SCM angle2_s),
"Set the fill properties of an object.")
@@ -554,7 +554,7 @@ SCM_DEFINE (set_object_fill, "%set-object-fill!", 2, 5, 0,
SCM_ASSERT ((edascm_is_object_type (obj_s, OBJ_BOX)
|| edascm_is_object_type (obj_s, OBJ_CIRCLE)
|| edascm_is_object_type (obj_s, OBJ_PATH)),
- obj_s, SCM_ARG1, s_set_object_fill);
+ obj_s, SCM_ARG1, s_set_object_fill_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *obj = edascm_to_object (obj_s);
@@ -565,7 +565,7 @@ SCM_DEFINE (set_object_fill, "%set-object-fill!", 2, 5, 0,
else if (type_s == hatch_sym) { type = FILLING_HATCH; }
else if (type_s == mesh_sym) { type = FILLING_MESH; }
else {
- scm_misc_error (s_set_object_fill,
+ scm_misc_error (s_set_object_fill_x,
_("Invalid fill style ~A."),
scm_list_1 (type_s));
}
@@ -573,49 +573,49 @@ SCM_DEFINE (set_object_fill, "%set-object-fill!", 2, 5, 0,
switch (type) {
case FILLING_MESH:
if (space2_s == SCM_UNDEFINED) {
- scm_misc_error (s_set_object_fill,
+ scm_misc_error (s_set_object_fill_x,
_("Missing second space parameter for fill style ~A."),
scm_list_1 (space2_s));
}
SCM_ASSERT (scm_is_integer (space2_s), space2_s,
- SCM_ARG6, s_set_object_fill);
+ SCM_ARG6, s_set_object_fill_x);
space2 = scm_to_int (space2_s);
if (angle2_s == SCM_UNDEFINED) {
- scm_misc_error (s_set_object_fill,
+ scm_misc_error (s_set_object_fill_x,
_("Missing second angle parameter for fill style ~A."),
scm_list_1 (angle2_s));
}
SCM_ASSERT (scm_is_integer (angle2_s), angle2_s,
- SCM_ARG7, s_set_object_fill);
+ SCM_ARG7, s_set_object_fill_x);
angle2 = scm_to_int (angle2_s);
/* This case intentionally falls through */
case FILLING_HATCH:
if (width_s == SCM_UNDEFINED) {
- scm_misc_error (s_set_object_fill,
+ scm_misc_error (s_set_object_fill_x,
_("Missing stroke width parameter for fill style ~A."),
scm_list_1 (width_s));
}
SCM_ASSERT (scm_is_integer (width_s), width_s,
- SCM_ARG3, s_set_object_fill);
+ SCM_ARG3, s_set_object_fill_x);
width = scm_to_int (width_s);
if (space1_s == SCM_UNDEFINED) {
- scm_misc_error (s_set_object_fill,
+ scm_misc_error (s_set_object_fill_x,
_("Missing space parameter for fill style ~A."),
scm_list_1 (space1_s));
}
SCM_ASSERT (scm_is_integer (space1_s), space1_s,
- SCM_ARG4, s_set_object_fill);
+ SCM_ARG4, s_set_object_fill_x);
space1 = scm_to_int (space1_s);
if (angle1_s == SCM_UNDEFINED) {
- scm_misc_error (s_set_object_fill,
+ scm_misc_error (s_set_object_fill_x,
_("Missing angle parameter for fill style ~A."),
scm_list_1 (angle1_s));
}
SCM_ASSERT (scm_is_integer (angle1_s), angle1_s,
- SCM_ARG5, s_set_object_fill);
+ SCM_ARG5, s_set_object_fill_x);
angle1 = scm_to_int (angle1_s);
/* This case intentionally falls through */
}
@@ -661,13 +661,13 @@ SCM_DEFINE (object_color, "%object-color", 1, 0, 0,
* \param color_s new colormap index to use for \a obj_s.
* \return the modified \a obj_s.
*/
-SCM_DEFINE (set_object_color, "%set-object-color!", 2, 0, 0,
+SCM_DEFINE (set_object_color_x, "%set-object-color!", 2, 0, 0,
(SCM obj_s, SCM color_s), "Set the color of an object.")
{
SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
- SCM_ARG1, s_set_object_color);
+ SCM_ARG1, s_set_object_color_x);
SCM_ASSERT (scm_is_integer (color_s), color_s,
- SCM_ARG2, s_set_object_color);
+ SCM_ARG2, s_set_object_color_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *obj = edascm_to_object (obj_s);
@@ -724,7 +724,7 @@ SCM_DEFINE (make_line, "%make-line", 0, 0, 0,
*
* \return the modified line object.
*/
-SCM_DEFINE (set_line, "%set-line!", 6, 0, 0,
+SCM_DEFINE (set_line_x, "%set-line!", 6, 0, 0,
(SCM line_s, SCM x1_s, SCM y1_s, SCM x2_s, SCM y2_s, SCM color_s),
"Set line parameters.")
{
@@ -732,13 +732,13 @@ SCM_DEFINE (set_line, "%set-line!", 6, 0, 0,
|| edascm_is_object_type (line_s, OBJ_NET)
|| edascm_is_object_type (line_s, OBJ_BUS)
|| edascm_is_object_type (line_s, OBJ_PIN)),
- line_s, SCM_ARG1, s_set_line);
+ line_s, SCM_ARG1, s_set_line_x);
- SCM_ASSERT (scm_is_integer (x1_s), x1_s, SCM_ARG2, s_set_line);
- SCM_ASSERT (scm_is_integer (y1_s), y1_s, SCM_ARG3, s_set_line);
- SCM_ASSERT (scm_is_integer (x2_s), x2_s, SCM_ARG4, s_set_line);
- SCM_ASSERT (scm_is_integer (y2_s), y2_s, SCM_ARG5, s_set_line);
- SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG6, s_set_line);
+ SCM_ASSERT (scm_is_integer (x1_s), x1_s, SCM_ARG2, s_set_line_x);
+ SCM_ASSERT (scm_is_integer (y1_s), y1_s, SCM_ARG3, s_set_line_x);
+ SCM_ASSERT (scm_is_integer (x2_s), x2_s, SCM_ARG4, s_set_line_x);
+ SCM_ASSERT (scm_is_integer (y2_s), y2_s, SCM_ARG5, s_set_line_x);
+ SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG6, s_set_line_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *obj = edascm_to_object (line_s);
@@ -1002,17 +1002,17 @@ SCM_DEFINE (make_box, "%make-box", 0, 0, 0,
*
* \return the modified box object.
*/
-SCM_DEFINE (set_box, "%set-box!", 6, 0, 0,
+SCM_DEFINE (set_box_x, "%set-box!", 6, 0, 0,
(SCM box_s, SCM x1_s, SCM y1_s, SCM x2_s, SCM y2_s, SCM color_s),
"Set box parameters.")
{
SCM_ASSERT (edascm_is_object_type (box_s, OBJ_BOX), box_s,
- SCM_ARG1, s_set_box);
- SCM_ASSERT (scm_is_integer (x1_s), x1_s, SCM_ARG2, s_set_box);
- SCM_ASSERT (scm_is_integer (y1_s), y1_s, SCM_ARG3, s_set_box);
- SCM_ASSERT (scm_is_integer (x2_s), x2_s, SCM_ARG4, s_set_box);
- SCM_ASSERT (scm_is_integer (y2_s), y2_s, SCM_ARG5, s_set_box);
- SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG6, s_set_box);
+ SCM_ARG1, s_set_box_x);
+ SCM_ASSERT (scm_is_integer (x1_s), x1_s, SCM_ARG2, s_set_box_x);
+ SCM_ASSERT (scm_is_integer (y1_s), y1_s, SCM_ARG3, s_set_box_x);
+ SCM_ASSERT (scm_is_integer (x2_s), x2_s, SCM_ARG4, s_set_box_x);
+ SCM_ASSERT (scm_is_integer (y2_s), y2_s, SCM_ARG5, s_set_box_x);
+ SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG6, s_set_box_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *obj = edascm_to_object (box_s);
@@ -1099,16 +1099,16 @@ SCM_DEFINE (make_circle, "%make-circle", 0, 0, 0,
*
* \return the modified circle object.
*/
-SCM_DEFINE (set_circle, "%set-circle!", 5, 0, 0,
+SCM_DEFINE (set_circle_x, "%set-circle!", 5, 0, 0,
(SCM circle_s, SCM x_s, SCM y_s, SCM r_s, SCM color_s),
"Set circle parameters")
{
SCM_ASSERT (edascm_is_object_type (circle_s, OBJ_CIRCLE), circle_s,
- SCM_ARG1, s_set_circle);
- SCM_ASSERT (scm_is_integer (x_s), x_s, SCM_ARG2, s_set_circle);
- SCM_ASSERT (scm_is_integer (y_s), y_s, SCM_ARG3, s_set_circle);
- SCM_ASSERT (scm_is_integer (r_s), r_s, SCM_ARG4, s_set_circle);
- SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG5, s_set_circle);
+ SCM_ARG1, s_set_circle_x);
+ SCM_ASSERT (scm_is_integer (x_s), x_s, SCM_ARG2, s_set_circle_x);
+ SCM_ASSERT (scm_is_integer (y_s), y_s, SCM_ARG3, s_set_circle_x);
+ SCM_ASSERT (scm_is_integer (r_s), r_s, SCM_ARG4, s_set_circle_x);
+ SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG5, s_set_circle_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *obj = edascm_to_object (circle_s);
@@ -1195,21 +1195,21 @@ SCM_DEFINE (make_arc, "%make-arc", 0, 0, 0,
*
* \return the modified arc object.
*/
-SCM_DEFINE (set_arc, "%set-arc!", 7, 0, 0,
+SCM_DEFINE (set_arc_x, "%set-arc!", 7, 0, 0,
(SCM arc_s, SCM x_s, SCM y_s, SCM r_s, SCM start_angle_s,
SCM end_angle_s, SCM color_s),
"Set arc parameters")
{
SCM_ASSERT (edascm_is_object_type (arc_s, OBJ_ARC), arc_s,
- SCM_ARG1, s_set_arc);
- SCM_ASSERT (scm_is_integer (x_s), x_s, SCM_ARG2, s_set_arc);
- SCM_ASSERT (scm_is_integer (y_s), y_s, SCM_ARG3, s_set_arc);
- SCM_ASSERT (scm_is_integer (r_s), r_s, SCM_ARG4, s_set_arc);
- SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG5, s_set_arc);
+ SCM_ARG1, s_set_arc_x);
+ SCM_ASSERT (scm_is_integer (x_s), x_s, SCM_ARG2, s_set_arc_x);
+ SCM_ASSERT (scm_is_integer (y_s), y_s, SCM_ARG3, s_set_arc_x);
+ SCM_ASSERT (scm_is_integer (r_s), r_s, SCM_ARG4, s_set_arc_x);
+ SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG5, s_set_arc_x);
SCM_ASSERT (scm_is_integer (start_angle_s),
- start_angle_s, SCM_ARG3, s_set_arc);
+ start_angle_s, SCM_ARG3, s_set_arc_x);
SCM_ASSERT (scm_is_integer (end_angle_s),
- end_angle_s, SCM_ARG4, s_set_arc);
+ end_angle_s, SCM_ARG4, s_set_arc_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *obj = edascm_to_object (arc_s);
@@ -1314,22 +1314,22 @@ SCM_DEFINE (make_text, "%make-text", 0, 0, 0,
*
* \return the modified text object.
*/
-SCM_DEFINE (set_text, "%set-text!", 10, 0, 0,
+SCM_DEFINE (set_text_x, "%set-text!", 10, 0, 0,
(SCM text_s, SCM x_s, SCM y_s, SCM align_s, SCM angle_s,
SCM string_s, SCM size_s, SCM visible_s, SCM show_s, SCM color_s),
"Set text parameters")
{
SCM_ASSERT (edascm_is_object_type (text_s, OBJ_TEXT), text_s,
- SCM_ARG1, s_set_text);
- SCM_ASSERT (scm_is_integer (x_s), x_s, SCM_ARG2, s_set_text);
- SCM_ASSERT (scm_is_integer (y_s), y_s, SCM_ARG3, s_set_text);
- SCM_ASSERT (scm_is_symbol (align_s), align_s, SCM_ARG4, s_set_text);
- SCM_ASSERT (scm_is_integer (angle_s), angle_s, SCM_ARG5, s_set_text);
- SCM_ASSERT (scm_is_string (string_s), string_s, SCM_ARG6, s_set_text);
- SCM_ASSERT (scm_is_integer (size_s), size_s, SCM_ARG7, s_set_text);
+ SCM_ARG1, s_set_text_x);
+ SCM_ASSERT (scm_is_integer (x_s), x_s, SCM_ARG2, s_set_text_x);
+ SCM_ASSERT (scm_is_integer (y_s), y_s, SCM_ARG3, s_set_text_x);
+ SCM_ASSERT (scm_is_symbol (align_s), align_s, SCM_ARG4, s_set_text_x);
+ SCM_ASSERT (scm_is_integer (angle_s), angle_s, SCM_ARG5, s_set_text_x);
+ SCM_ASSERT (scm_is_string (string_s), string_s, SCM_ARG6, s_set_text_x);
+ SCM_ASSERT (scm_is_integer (size_s), size_s, SCM_ARG7, s_set_text_x);
- SCM_ASSERT (scm_is_symbol (show_s), show_s, 9, s_set_text);
- SCM_ASSERT (scm_is_integer (color_s), color_s, 10, s_set_text);
+ SCM_ASSERT (scm_is_symbol (show_s), show_s, 9, s_set_text_x);
+ SCM_ASSERT (scm_is_integer (color_s), color_s, 10, s_set_text_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *obj = edascm_to_object (text_s);
@@ -1346,7 +1346,7 @@ SCM_DEFINE (set_text, "%set-text!", 10, 0, 0,
else if (align_s == middle_right_sym) { align = MIDDLE_RIGHT; }
else if (align_s == upper_right_sym) { align = UPPER_RIGHT; }
else {
- scm_misc_error (s_set_text,
+ scm_misc_error (s_set_text_x,
_("Invalid text alignment ~A."),
scm_list_1 (angle_s));
}
@@ -1362,7 +1362,7 @@ SCM_DEFINE (set_text, "%set-text!", 10, 0, 0,
break;
default:
/* Otherwise, not fine. */
- scm_misc_error (s_set_text,
+ scm_misc_error (s_set_text_x,
_("Invalid text angle ~A. Must be 0, 90, 180, or 270 degrees"),
scm_list_1 (angle_s));
}
@@ -1381,7 +1381,7 @@ SCM_DEFINE (set_text, "%set-text!", 10, 0, 0,
else if (show_s == value_sym) { show = SHOW_VALUE; }
else if (show_s == both_sym) { show = SHOW_NAME_VALUE; }
else {
- scm_misc_error (s_set_text,
+ scm_misc_error (s_set_text_x,
_("Invalid text name/value visibility ~A."),
scm_list_1 (angle_s));
}
@@ -1541,16 +1541,16 @@ init_module_geda_core_object ()
/* Add them to the module's public definitions. */
scm_c_export (s_object_type, s_copy_object, s_object_bounds,
- s_object_stroke, s_set_object_stroke,
- s_object_fill, s_set_object_fill,
- s_object_color, s_set_object_color,
+ s_object_stroke, s_set_object_stroke_x,
+ s_object_fill, s_set_object_fill_x,
+ s_object_color, s_set_object_color_x,
s_make_line, s_make_net, s_make_bus,
s_make_pin, s_pin_type,
- s_set_line, s_line_info,
- s_make_box, s_set_box, s_box_info,
- s_make_circle, s_set_circle, s_circle_info,
- s_make_arc, s_set_arc, s_arc_info,
- s_make_text, s_set_text, s_text_info,
+ s_set_line_x, s_line_info,
+ s_make_box, s_set_box_x, s_box_info,
+ s_make_circle, s_set_circle_x, s_circle_info,
+ s_make_arc, s_set_arc_x, s_arc_info,
+ s_make_text, s_set_text_x, s_text_info,
s_object_connections,
NULL);
}
diff --git a/libgeda/src/scheme_page.c b/libgeda/src/scheme_page.c
index 4af275e..5d017ba 100644
--- a/libgeda/src/scheme_page.c
+++ b/libgeda/src/scheme_page.c
@@ -96,12 +96,12 @@ SCM_DEFINE (new_page, "%new-page", 1, 0, 0,
* \param page_s The page to close.
* \return SCM_UNDEFINED.
*/
-SCM_DEFINE (close_page, "%close-page!", 1, 0, 0,
+SCM_DEFINE (close_page_x, "%close-page!", 1, 0, 0,
(SCM page_s), "Close a page.")
{
/* Ensure that the argument is a page smob */
SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
- SCM_ARG1, s_close_page);
+ SCM_ARG1, s_close_page_x);
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
PAGE *page = edascm_to_page (page_s);
@@ -145,13 +145,13 @@ SCM_DEFINE (page_filename, "%page-filename", 1, 0, 0,
* \param filename_s new filename for \a page.
* \return \a page.
*/
-SCM_DEFINE (set_page_filename, "%set-page-filename!", 2, 0, 0,
+SCM_DEFINE (set_page_filename_x, "%set-page-filename!", 2, 0, 0,
(SCM page_s, SCM filename_s), "Set a page's associated filename")
{
SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
- SCM_ARG1, s_set_page_filename);
+ SCM_ARG1, s_set_page_filename_x);
SCM_ASSERT (scm_is_string (filename_s), filename_s,
- SCM_ARG2, s_set_page_filename);
+ SCM_ARG2, s_set_page_filename_x);
PAGE *page = edascm_to_page (page_s);
char *new_fn = scm_to_locale_string (filename_s);
@@ -226,14 +226,14 @@ SCM_DEFINE (object_page, "%object-page", 1, 0, 0,
*
* \return \a obj_s.
*/
-SCM_DEFINE (page_append_, "%page-append!", 2, 0, 0,
+SCM_DEFINE (page_append_x, "%page-append!", 2, 0, 0,
(SCM page_s, SCM obj_s), "Add an object to a page.")
{
/* Ensure that the arguments have the correct types. */
SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
- SCM_ARG1, s_page_append_);
+ SCM_ARG1, s_page_append_x);
SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
- SCM_ARG2, s_page_append_);
+ SCM_ARG2, s_page_append_x);
PAGE *page = edascm_to_page (page_s);
OBJECT *obj = edascm_to_object (obj_s);
@@ -243,7 +243,7 @@ SCM_DEFINE (page_append_, "%page-append!", 2, 0, 0,
PAGE *curr_page = o_get_page (toplevel, obj);
if (((curr_page != NULL) && (curr_page != page))
|| (obj->parent != NULL)) {
- scm_error (edascm_object_state_sym, s_page_append_,
+ scm_error (edascm_object_state_sym, s_page_append_x,
_("Object ~A is already attached to something"),
scm_list_1 (obj_s), SCM_EOL);
}
@@ -271,14 +271,14 @@ SCM_DEFINE (page_append_, "%page-append!", 2, 0, 0,
*
* \return \a obj_s.
*/
-SCM_DEFINE (page_remove_, "%page-remove!", 2, 0, 0,
+SCM_DEFINE (page_remove_x, "%page-remove!", 2, 0, 0,
(SCM page_s, SCM obj_s), "Remove an object from a page.")
{
/* Ensure that the arguments have the correct types. */
SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
- SCM_ARG1, s_page_remove_);
+ SCM_ARG1, s_page_remove_x);
SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
- SCM_ARG2, s_page_remove_);
+ SCM_ARG2, s_page_remove_x);
PAGE *page = edascm_to_page (page_s);
OBJECT *obj = edascm_to_object (obj_s);
@@ -288,21 +288,21 @@ SCM_DEFINE (page_remove_, "%page-remove!", 2, 0, 0,
PAGE *curr_page = o_get_page (toplevel, obj);
if ((curr_page != NULL && curr_page != page)
|| (obj->parent != NULL)) {
- scm_error (edascm_object_state_sym, s_page_remove_,
+ scm_error (edascm_object_state_sym, s_page_remove_x,
_("Object ~A is attached to a complex or different page"),
scm_list_1 (obj_s), SCM_EOL);
}
/* Check that object is not attached as an attribute. */
if (obj->attached_to != NULL) {
- scm_error (edascm_object_state_sym, s_page_remove_,
+ scm_error (edascm_object_state_sym, s_page_remove_x,
_("Object ~A is attached as an attribute"),
scm_list_1 (obj_s), SCM_EOL);
}
/* Check that object doesn't have attributes. */
if (obj->attribs != NULL) {
- scm_error (edascm_object_state_sym, s_page_remove_,
+ scm_error (edascm_object_state_sym, s_page_remove_x,
_("Object ~A has attributes"),
scm_list_1 (obj_s), SCM_EOL);
}
@@ -355,13 +355,13 @@ SCM_DEFINE (page_dirty, "%page-dirty?", 1, 0, 0,
* \param flag_s new flag setting.
* \return \a page_s
*/
-SCM_DEFINE (set_page_dirty, "%set-page-dirty!", 2, 0, 0,
+SCM_DEFINE (set_page_dirty_x, "%set-page-dirty!", 2, 0, 0,
(SCM page_s, SCM flag_s),
"Set whether a page is flagged as changed.")
{
/* Ensure that the argument is a page smob */
SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
- SCM_ARG1, s_set_page_dirty);
+ SCM_ARG1, s_set_page_dirty_x);
PAGE *page = edascm_to_page (page_s);
page->CHANGED = scm_is_true (flag_s);
@@ -382,10 +382,10 @@ init_module_geda_core_page ()
/* Add them to the module's public definitions. */
- scm_c_export (s_active_pages, s_new_page, s_close_page,
- s_page_filename, s_set_page_filename, s_page_contents,
- s_object_page, s_page_append_, s_page_remove_, s_page_dirty,
- s_set_page_dirty, NULL);
+ scm_c_export (s_active_pages, s_new_page, s_close_page_x,
+ s_page_filename, s_set_page_filename_x, s_page_contents,
+ s_object_page, s_page_append_x, s_page_remove_x, s_page_dirty,
+ s_set_page_dirty_x, NULL);
}
/*!
commit c7d44a2507edb830e1592d9390cb32ad5fb658b4
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Promote attributes from components.
diff --git a/libgeda/include/prototype_priv.h b/libgeda/include/prototype_priv.h
index 1b62ff7..a301128 100644
--- a/libgeda/include/prototype_priv.h
+++ b/libgeda/include/prototype_priv.h
@@ -164,6 +164,7 @@ double o_complex_shortest_distance(OBJECT *object, int x, int y, int force_soild
void world_get_complex_bounds(TOPLEVEL *toplevel, OBJECT *complex, int *left, int *top, int *right, int *bottom);
gboolean o_complex_get_position(TOPLEVEL *toplevel, gint *x, gint *y, OBJECT *object);
void o_complex_recalc(TOPLEVEL *toplevel, OBJECT *o_current);
+GList *o_complex_get_promotable (TOPLEVEL *toplevel, OBJECT *object, int detach);
/* o_line_basic.c */
OBJECT *o_line_read(TOPLEVEL *toplevel, char buf[], unsigned int release_ver, unsigned int fileformat_ver);
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 49d93ab..16657f9 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -21,7 +21,10 @@ TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0018-object-connections.scm \
unit-tests/t0020-page.scm \
unit-tests/t0021-page-dirty.scm \
- unit-tests/t0030-attribute.scm
+ unit-tests/t0030-attribute.scm \
+ unit-tests/t0031-promotable-attributes.scm
+
+XFAIL_TESTS = unit-tests/t0031-promotable-attributes.scm
dist_noinst_DATA = unit-test.scm $(TESTS)
diff --git a/libgeda/scheme/geda/attrib.scm b/libgeda/scheme/geda/attrib.scm
index efc266e..6623d75 100644
--- a/libgeda/scheme/geda/attrib.scm
+++ b/libgeda/scheme/geda/attrib.scm
@@ -29,6 +29,7 @@
(define-public attrib-attachment %attrib-attachment)
(define-public attach-attrib! %attach-attrib!)
(define-public detach-attrib! %detach-attrib!)
+(define-public promotable-attribs %promotable-attribs)
;; attribute? a
;;
diff --git a/libgeda/scheme/unit-tests/t0031-promotable-attributes.scm b/libgeda/scheme/unit-tests/t0031-promotable-attributes.scm
new file mode 100644
index 0000000..5524fce
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0031-promotable-attributes.scm
@@ -0,0 +1,14 @@
+;; Test promotable-attributes function
+
+(use-modules (unit-test))
+
+;; Unfortunately, we can't test this at the moment, because the
+;; default list of promotable attribute names is empty. We suppress
+;; config file loading when running the unit tests, and even though we
+;; could call the (always-promote-attributes ...) config file
+;; procedure, but it wouldn't do us any good because we can't call
+;; i_vars_libgeda_set() from Scheme [1]. So instead, we just fail.
+;;
+;; [1] This is a good thing -- it shouldn't be necessary!
+(begin-test 'promotable-attributes
+ (throw 'missing-unit-test "We can't test this at the moment"))
diff --git a/libgeda/src/o_complex_basic.c b/libgeda/src/o_complex_basic.c
index 8d54af4..971707c 100644
--- a/libgeda/src/o_complex_basic.c
+++ b/libgeda/src/o_complex_basic.c
@@ -262,19 +262,16 @@ int o_complex_is_embedded(OBJECT *o_current)
* Returns a GList of OBJECTs which are eligible for promotion from
* within the passed complex OBJECT.
*
- * If detach is TRUE, the function removes these attribute objects from
- * the prim_objs of the complex. It detached, the returned OBJECTs are
- * isolated from each other, having their next and prev pointers set to NULL.
- *
- * If detach is FALSE, the OBJECTs are left in place. Their next and prev
- * pointers form part of the complex's prim_objs linked list.
+ * If detach is TRUE, the function removes these attribute objects
+ * from the prim_objs of the complex. If detach is FALSE, the
+ * OBJECTs are left in place.
*
* \param [in] toplevel The toplevel environment.
* \param [in] object The complex object being modified.
* \param [in] detach Should the attributes be detached?
* \returns A linked list of OBJECTs to promote.
*/
-static GList *o_complex_get_promotable (TOPLEVEL *toplevel, OBJECT *object, int detach)
+GList *o_complex_get_promotable (TOPLEVEL *toplevel, OBJECT *object, int detach)
{
GList *promoted = NULL;
GList *attribs;
diff --git a/libgeda/src/scheme_attrib.c b/libgeda/src/scheme_attrib.c
index af23c32..84df721 100644
--- a/libgeda/src/scheme_attrib.c
+++ b/libgeda/src/scheme_attrib.c
@@ -225,6 +225,29 @@ SCM_DEFINE (detach_attrib, "%detach-attrib!", 2, 0, 0,
return attrib_s;
}
+/*! \brief Get a complex object's promotable attribs.
+ * \par Function Description
+ * Returns the promotable attributes of \a complex_s, according to the
+ * current gEDA configuration.
+ *
+ * \param complex_s the complex object for which to get promotable
+ * attributes.
+ * \return a list of promotable attributes.
+ */
+SCM_DEFINE (promotable_attribs, "%promotable-attribs", 1, 0, 0,
+ (SCM complex_s), "Get a component's promotable attributes")
+{
+ SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
+ SCM_ARG2, s_promotable_attribs);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (complex_s);
+
+ GList *lst = o_complex_get_promotable (toplevel, obj, FALSE);
+
+ return edascm_from_object_glist (lst);
+}
+
/*!
* \brief Create the (geda core attrib) Scheme module.
@@ -241,6 +264,7 @@ init_module_geda_core_attrib ()
/* Add them to the module's public definitions. */
scm_c_export (s_parse_attrib, s_object_attribs, s_attrib_attachment,
s_attach_attrib, s_detach_attrib,
+ s_promotable_attribs,
NULL);
}
commit f8b371c8732f128c09fda366916f48d4a3ae8873
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Get inherited attribs from components.
diff --git a/libgeda/scheme/geda/attrib.scm b/libgeda/scheme/geda/attrib.scm
index 8ccad6b..efc266e 100644
--- a/libgeda/scheme/geda/attrib.scm
+++ b/libgeda/scheme/geda/attrib.scm
@@ -51,3 +51,15 @@
(define-public (attrib-value a)
(let ((v (parse-attrib a)))
(if v (cdr v) v)))
+
+;; inherited-attribs object
+;;
+;; Returns the inherited attributes of object, if object is a
+;; component. The inherited attributes are the unattached top-level
+;; attributes in the component. If object is not a component, returns
+;; the empty list.
+(define-public (inherited-attribs object)
+ (if (component? object)
+ (filter! (lambda (x) (and (attribute? x) (not (attrib-attachment x))))
+ (component-contents object))
+ '()))
diff --git a/libgeda/scheme/unit-tests/t0030-attribute.scm b/libgeda/scheme/unit-tests/t0030-attribute.scm
index eded1be..0a6fc07 100644
--- a/libgeda/scheme/unit-tests/t0030-attribute.scm
+++ b/libgeda/scheme/unit-tests/t0030-attribute.scm
@@ -9,6 +9,9 @@
(let ((good (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
(bad (make-text '(1 . 2) 'lower-left 0 "name value" 10 #t 'both)))
+ (assert-true (attribute? good))
+ (assert-true (not (attribute? bad)))
+
(assert-equal "name" (attrib-name good))
(assert-equal "value" (attrib-value good))
(assert-equal (cons (attrib-name good) (attrib-value good))
@@ -131,3 +134,21 @@
(assert-equal x (detach-attrib! pin1 x))
(assert-equal '() (object-attribs pin1)) ))
+
+(begin-test 'inherited-attribs
+ (let ((C (make-component "test component" '(1 . 2) 0 #t #f))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (x (make-text '(1 . 2) 'lower-left 0 "name=x" 10 #t 'both))
+ (y (make-text '(1 . 2) 'lower-left 0 "name=y" 10 #t 'both)))
+
+ (assert-equal '() (inherited-attribs p))
+ (assert-equal '() (inherited-attribs C))
+
+ ;; Set up component
+ (for-each (lambda (o) (component-append! C o)) (list p x y))
+
+ (assert-equal (list x y) (inherited-attribs C))
+
+ (attach-attrib! p x)
+
+ (assert-equal (list y) (inherited-attribs C))))
commit c397394b68b27672d1af14d777eea35636b3b365
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make component/library test succeed for out-of-tree builds
diff --git a/libgeda/scheme/unit-tests/t0015-object-complex.scm b/libgeda/scheme/unit-tests/t0015-object-complex.scm
index 59b46f8..ebcd7cd 100644
--- a/libgeda/scheme/unit-tests/t0015-object-complex.scm
+++ b/libgeda/scheme/unit-tests/t0015-object-complex.scm
@@ -146,7 +146,8 @@
;; Set up component library, making blatant assumptions about the
;; directory layout.
-(component-library "../../symbols/analog" "Basic devices")
+(component-library (string-join (list (getenv "srcdir") "../../symbols/analog") "/")
+ "Basic devices")
(begin-test 'component/library
(let ((A (make-component/library "resistor-1.sym" '(1 . 2) 0 #t #f))
commit 780a175f4cff04a4f1b79332b6f604b7d95851ab
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Add missing unit test file.
t0018-object-connections.scm was omitted from commit d8110db394f5.
diff --git a/libgeda/scheme/unit-tests/t0018-object-connections.scm b/libgeda/scheme/unit-tests/t0018-object-connections.scm
new file mode 100644
index 0000000..74595fe
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0018-object-connections.scm
@@ -0,0 +1,67 @@
+; Test Scheme procedures for getting connections.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+(use-modules (geda page))
+
+(define P (make-page "/test/page/A"))
+
+(begin-test 'object-connections
+ (let ((C (make-component "test component" '(1 . 2) 0 #t #f))
+ (np (make-net-pin '(100 . 0) '(0 . 0)))
+ (bp (make-bus-pin '(100 . 200) '(0 . 200)))
+ (n1 (make-net '(100 . 0) '(100 . 100)))
+ (n2 (make-net '(100 . 100) '(200 . 100)))
+ (b1 (make-bus '(100 . 200) '(200 . 200)))
+ (b2 (make-bus '(200 . 100) '(200 . 200))))
+
+ (assert-thrown 'object-state (object-connections np))
+
+ ;; Build component
+ (for-each (lambda (x) (component-append! C x)) (list np bp))
+ (assert-thrown 'object-state (object-connections np))
+
+ ;; Build page
+ (for-each (lambda (x) (page-append! P x)) (list C n1 n2 b1 b2))
+
+ ;; Test initial connections
+ (assert-equal (list n1 b1) (object-connections C))
+
+ (assert-equal (list n1) (object-connections np))
+ (assert-equal (list np n2) (object-connections n1))
+ (assert-equal (list n1) (object-connections n2))
+
+ (assert-equal (list b1) (object-connections bp))
+ (assert-equal (list bp b2) (object-connections b1))
+ (assert-equal (list b1) (object-connections b2))
+
+ ;; Break some stuff
+ (page-remove! P n1)
+ (component-remove! C bp)
+
+ ;; Test modified connections
+ (assert-equal '() (object-connections np))
+ (assert-thrown 'object-state (object-connections n1))
+ (assert-equal '() (object-connections n2))
+
+ (assert-thrown 'object-state (object-connections bp))
+ (assert-equal (list b2) (object-connections b1))
+ (assert-equal (list b1) (object-connections b2))
+
+ ;; Change stuff back
+ (page-append! P n1)
+ (component-append! C bp)
+
+ ;; Test modified connections
+ (assert-equal (list n1 b1) (object-connections C))
+
+ (assert-equal (list n1) (object-connections np))
+ (assert-equal (list np n2) (object-connections n1))
+ (assert-equal (list n1) (object-connections n2))
+
+ (assert-equal (list b1) (object-connections bp))
+ (assert-equal (list b2 bp) (object-connections b1))
+ (assert-equal (list b1) (object-connections b2))
+ ))
+
+(close-page! P)
commit bf643e97eef4919fb11aace7dd597d0b092170cb
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Test if an object is selected.
An obvious omission from commit 85753049b2b9.
diff --git a/gschem/scheme/gschem/selection.scm b/gschem/scheme/gschem/selection.scm
index 9cbfeb0..9f33f73 100644
--- a/gschem/scheme/gschem/selection.scm
+++ b/gschem/scheme/gschem/selection.scm
@@ -26,3 +26,4 @@
(define-public select-object! %select-object!)
(define-public deselect-object! %deselect-object!)
+(define-public object-selected? %object-selected?)
diff --git a/gschem/src/g_select.c b/gschem/src/g_select.c
index 83aff1a..b41edc9 100644
--- a/gschem/src/g_select.c
+++ b/gschem/src/g_select.c
@@ -124,6 +124,37 @@ SCM_DEFINE (deselect_object, "%deselect-object!", 1, 0, 0,
return obj_s;
}
+/*! \brief Test if an object is selected.
+ * \par Function Description
+ * If \a obj_s is selected, returns SCM_BOOL_T. Otherwise, returns
+ * SCM_BOOL_F. If \a obj_s is not included directly in a page
+ * (i.e. not via inclusion in a component), throws a Scheme error.
+ *
+ * \note Scheme API: Implements the %object-selected? procedure in the
+ * (gschem core selection) module.
+ *
+ * \param obj_s #OBJECT smob to be tested.
+ * \return SCM_BOOL_T if \a obj_s is selected, otherwise SCM_BOOL_F.
+ */
+SCM_DEFINE (object_selected_p, "%object-selected?", 1, 0, 0,
+ (SCM obj_s), "Test if an object is selected.")
+{
+ /* Ensure that the argument is an object smob */
+ SCM_ASSERT (edascm_is_object (obj_s), obj_s,
+ SCM_ARG1, s_object_selected_p);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+ PAGE *page = o_get_page (toplevel, obj);
+ if ((page == NULL) || (obj->parent != NULL)) {
+ scm_error (object_state_sym,
+ s_object_selected_p,
+ _("Object ~A is not directly included in a page."),
+ scm_list_1 (obj_s), SCM_EOL);
+ }
+ return (obj->selected ? SCM_BOOL_T : SCM_BOOL_F);
+}
+
/*! \brief Create the (gschem core selection) Scheme module
* \par Function Description
* Defines procedures in the (gschem core selection) module. The module
@@ -136,7 +167,8 @@ init_module_gschem_core_select ()
#include "g_select.x"
/* Add them to the module's public definitions. */
- scm_c_export (s_page_selection, s_select_object_, s_deselect_object, NULL);
+ scm_c_export (s_page_selection, s_select_object_, s_deselect_object,
+ s_object_selected_p, NULL);
}
/*! \brief Initialise the selection manipulation procedures.
commit d8110db394f56139a4fb75c6447024a28fc12913
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Find connected objects.
Adds a Scheme C procedure for accessing objects that are immediately
connected to an object.
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 8030565..49d93ab 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -18,6 +18,7 @@ TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0015-object-complex.scm \
unit-tests/t0016-object-bounds.scm \
unit-tests/t0017-object-stroke-fill.scm \
+ unit-tests/t0018-object-connections.scm \
unit-tests/t0020-page.scm \
unit-tests/t0021-page-dirty.scm \
unit-tests/t0030-attribute.scm
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 6e44bd5..611e846 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -42,6 +42,8 @@
(define-public object-color %object-color)
(define-public set-object-color! %set-object-color!)
+(define-public object-connections %object-connections)
+
;;;; Lines
;; line? x
diff --git a/libgeda/src/scheme_complex.c b/libgeda/src/scheme_complex.c
index 3b0adc6..189dc91 100644
--- a/libgeda/src/scheme_complex.c
+++ b/libgeda/src/scheme_complex.c
@@ -281,6 +281,10 @@ SCM_DEFINE (complex_append, "%complex-append!", 2, 0, 0,
o_complex_recalc (toplevel, parent);
+ /* We may need to update connections */
+ s_tile_update_object (toplevel, child);
+ s_conn_update_object (toplevel, child);
+
o_emit_change_notify (toplevel, parent);
o_page_changed (toplevel, parent);
@@ -353,6 +357,10 @@ SCM_DEFINE (complex_remove, "%complex-remove!", 2, 0, 0,
g_list_remove_all (parent->complex->prim_objs, child);
child->parent = NULL;
+ /* We may need to update connections */
+ s_tile_remove_object (child);
+ s_conn_remove_object (toplevel, child);
+
o_emit_change_notify (toplevel, parent);
o_page_changed (toplevel, parent);
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index fa02519..57272ea 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -746,6 +746,10 @@ SCM_DEFINE (set_line, "%set-line!", 6, 0, 0,
int y1 = scm_to_int (y1_s);
int x2 = scm_to_int (x2_s);
int y2 = scm_to_int (y2_s);
+
+ /* We may need to update connectivity. */
+ s_conn_remove_object (toplevel, obj);
+
switch (obj->type) {
case OBJ_LINE:
o_line_modify (toplevel, obj, x1, y1, LINE_END1);
@@ -769,6 +773,10 @@ SCM_DEFINE (set_line, "%set-line!", 6, 0, 0,
}
o_set_color (toplevel, obj, scm_to_int (color_s));
+ /* We may need to update connectivity. */
+ s_tile_update_object (toplevel, obj);
+ s_conn_update_object (toplevel, obj);
+
o_page_changed (toplevel, obj);
return line_s;
@@ -1484,7 +1492,40 @@ SCM_DEFINE (text_info, "%text-info", 1, 0, 0,
SCM_UNDEFINED);
}
+/*! \brief Get objects that are connected to an object.
+ * \par Function Description
+ * Returns a list of all objects directly connected to \a obj_s. If
+ * \a obj_s is not included in a page, throws a Scheme error. If \a
+ * obj_s is not a pin, net, bus, or complex object, returns the empty
+ * list.
+ *
+ * \note Scheme API: Implements the %object-connections procedure of
+ * the (geda core object) module.
+ *
+ * \param obj_s #OBJECT smob for object to get connections for.
+ * \return a list of #OBJECT smobs.
+ */
+SCM_DEFINE (object_connections, "%object-connections", 1, 0, 0,
+ (SCM obj_s), "Get objects that are connected to an object.")
+{
+ /* Ensure that the argument is an object smob */
+ SCM_ASSERT (edascm_is_object (obj_s), obj_s,
+ SCM_ARG1, s_object_connections);
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+ if (o_get_page (toplevel, obj) == NULL) {
+ scm_error (edascm_object_state_sym,
+ s_object_connections,
+ _("Object ~A is not included in a page."),
+ scm_list_1 (obj_s), SCM_EOL);
+ }
+
+ GList *lst = s_conn_return_others (NULL, obj);
+ SCM result = edascm_from_object_glist (lst);
+ g_list_free (lst);
+ return result;
+}
/*!
* \brief Create the (geda core object) Scheme module.
@@ -1510,6 +1551,7 @@ init_module_geda_core_object ()
s_make_circle, s_set_circle, s_circle_info,
s_make_arc, s_set_arc, s_arc_info,
s_make_text, s_set_text, s_text_info,
+ s_object_connections,
NULL);
}
commit 85753049b2b9455d815ede96dca161cb0de2f22b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Access to gschem selection.
Makes it possible to retrieve and modify the current selection in
gschem from Scheme code.
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index 19f5f80..cfc4352 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -278,6 +278,8 @@ SCM g_rc_display_color_map (SCM scm_map);
SCM g_rc_display_outline_color_map (SCM scm_map);
/* g_register.c */
void g_register_funcs(void);
+/* g_select.c */
+void g_init_select ();
/* g_window.c */
GSCHEM_TOPLEVEL *g_current_window ();
void g_dynwind_window (GSCHEM_TOPLEVEL *w_current);
diff --git a/gschem/scheme/Makefile.am b/gschem/scheme/Makefile.am
index 6e3e0b4..0cd3142 100644
--- a/gschem/scheme/Makefile.am
+++ b/gschem/scheme/Makefile.am
@@ -10,7 +10,8 @@ nobase_dist_scmdata_DATA = \
auto-place-attribs.scm \
pcb.scm \
default-attrib-positions.scm \
- gschem/window.scm
+ gschem/window.scm \
+ gschem/selection.scm
MOSTLYCLEANFILES = *.log *~
CLEANFILES = *.log *~
diff --git a/gschem/scheme/gschem/selection.scm b/gschem/scheme/gschem/selection.scm
new file mode 100644
index 0000000..9cbfeb0
--- /dev/null
+++ b/gschem/scheme/gschem/selection.scm
@@ -0,0 +1,28 @@
+;; gEDA - GPL Electronic Design Automation
+;; gschem - gEDA Schematic Capture - Scheme API
+;; Copyright (C) 2010 Peter Brett
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+;;
+
+(define-module (gschem selection)
+
+ ;; Import C procedures
+ #:use-module (gschem core selection))
+
+(define-public page-selection %page-selection)
+
+(define-public select-object! %select-object!)
+(define-public deselect-object! %deselect-object!)
diff --git a/gschem/src/Makefile.am b/gschem/src/Makefile.am
index addd4fd..1412858 100644
--- a/gschem/src/Makefile.am
+++ b/gschem/src/Makefile.am
@@ -1,7 +1,8 @@
bin_PROGRAMS = gschem
BUILT_SOURCES = \
- g_window.x
+ g_window.x \
+ g_select.x
gschem_SOURCES = \
a_pan.c \
@@ -11,6 +12,7 @@ gschem_SOURCES = \
g_keys.c \
g_rc.c \
g_register.c \
+ g_select.c \
g_window.c \
globals.c \
gschem.c \
diff --git a/gschem/src/g_select.c b/gschem/src/g_select.c
new file mode 100644
index 0000000..83aff1a
--- /dev/null
+++ b/gschem/src/g_select.c
@@ -0,0 +1,154 @@
+/* gEDA - GPL Electronic Design Automation
+ * gschem - gEDA Schematic Capture
+ * Copyright (C) 2010 Peter Brett
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+ */
+#include <config.h>
+
+#include "gschem.h"
+
+SCM_SYMBOL (object_state_sym, "object-state");
+
+/*! \brief Get a list of selected objects on a page.
+ * \par Function Description
+ * Retrieve a list of selected objects on \a page_s.
+ *
+ * \note Scheme API: Implements the %page-selection procedure in the
+ * (gschem core selection) module.
+ *
+ * \param page_s #PAGE smob for the page from which to get the selection.
+ * \return a list of #OBJECT smobs.
+ */
+SCM_DEFINE (page_selection, "%page-selection", 1, 0, 0,
+ (SCM page_s), "Get a list of a page's selected objects")
+{
+ /* Ensure that the argument is a page smob */
+ SCM_ASSERT (edascm_is_page (page_s), page_s,
+ SCM_ARG1, s_page_selection);
+
+ PAGE *page = edascm_to_page (page_s);
+ GList *iter;
+ SCM result = SCM_EOL;
+ for (iter = geda_list_get_glist (page->selection_list);
+ iter != NULL; iter = g_list_next (iter)) {
+ result = scm_cons (edascm_from_object ((OBJECT *) iter->data), result);
+ }
+
+ return result;
+}
+
+/*! \brief Select an object.
+ * \par Function Description
+ * Add \a obj_s to its associated page's selection. If \a obj_s is
+ * not included directly in a page (i.e. inclusion in a component is
+ * not permitted), throws a Scheme error. If \a obj_s is already
+ * selected, does nothing.
+ *
+ * \note Scheme API: Implements the %select-object! procedure in the
+ * (gschem core selection) module.
+ *
+ * \param obj_s #OBJECT smob for object to be selected.
+ * \return obj_s.
+ */
+SCM_DEFINE (select_object_, "%select-object!", 1, 0, 0,
+ (SCM obj_s), "Select an object.")
+{
+ /* Ensure that the argument is an object smob */
+ SCM_ASSERT (edascm_is_object (obj_s), obj_s,
+ SCM_ARG1, s_select_object_);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+ PAGE *page = o_get_page (toplevel, obj);
+ if ((page == NULL) || (obj->parent != NULL)) {
+ scm_error (object_state_sym,
+ s_select_object_,
+ _("Object ~A is not directly included in a page."),
+ scm_list_1 (obj_s), SCM_EOL);
+ }
+
+ if (!obj->selected) {
+ o_selection_add (toplevel, page->selection_list, obj);
+ }
+
+ return obj_s;
+}
+
+/*! \brief Deselect an object.
+ * \par Function Description
+ * Remove \a obj_s from its associated page's selection. If \a obj_s
+ * is not included directly in a page (i.e. not via inclusion in a
+ * component), throws a Scheme error. If \a obj_s is not selected,
+ * does nothing.
+ *
+ * \note Scheme API: Implements the %deselect-object! procedure in the
+ * (gschem core selection) module.
+ *
+ * \param obj_s #OBJECT smob for object to be deselected.
+ * \return obj_s.
+ */
+SCM_DEFINE (deselect_object, "%deselect-object!", 1, 0, 0,
+ (SCM obj_s), "Deselect an object.")
+{
+ /* Ensure that the argument is an object smob */
+ SCM_ASSERT (edascm_is_object (obj_s), obj_s,
+ SCM_ARG1, s_deselect_object);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+ PAGE *page = o_get_page (toplevel, obj);
+ if ((page == NULL) || (obj->parent != NULL)) {
+ scm_error (object_state_sym,
+ s_deselect_object,
+ _("Object ~A is not directly included in a page."),
+ scm_list_1 (obj_s), SCM_EOL);
+ }
+
+ if (obj->selected) {
+ o_selection_remove (toplevel, page->selection_list, obj);
+ }
+
+ return obj_s;
+}
+
+/*! \brief Create the (gschem core selection) Scheme module
+ * \par Function Description
+ * Defines procedures in the (gschem core selection) module. The module
+ * can be accessed using (use-modules (gschem core selection)).
+ */
+static void
+init_module_gschem_core_select ()
+{
+ /* Register the functions */
+ #include "g_select.x"
+
+ /* Add them to the module's public definitions. */
+ scm_c_export (s_page_selection, s_select_object_, s_deselect_object, NULL);
+}
+
+/*! \brief Initialise the selection manipulation procedures.
+ * \par Function Description
+ * Registers some Scheme procedures for working with the selection.
+ * Should only be called by main_prog().
+ */
+void
+g_init_select ()
+{
+ /* Define the (gschem core selection) module */
+ scm_c_define_module ("gschem core selection",
+ init_module_gschem_core_select,
+ NULL);
+}
diff --git a/gschem/src/gschem.c b/gschem/src/gschem.c
index 4c33137..580f6bb 100644
--- a/gschem/src/gschem.c
+++ b/gschem/src/gschem.c
@@ -204,6 +204,7 @@ void main_prog(void *closure, int argc, char *argv[])
/* register guile (scheme) functions */
g_register_funcs();
g_init_window ();
+ g_init_select ();
/* initialise color map (need to do this before reading rc files */
x_color_init ();
commit d1d4dbf5841368874215b7ef102090ce4dfc0780
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Correct some comments.
diff --git a/gschem/scheme/gschem/window.scm b/gschem/scheme/gschem/window.scm
index 7023097..94254a1 100644
--- a/gschem/scheme/gschem/window.scm
+++ b/gschem/scheme/gschem/window.scm
@@ -1,5 +1,5 @@
;; gEDA - GPL Electronic Design Automation
-;; libgeda - gEDA's library - Scheme API
+;; gschem - gEDA Schematic Capture - Scheme API
;; Copyright (C) 2010 Peter Brett
;;
;; This program is free software; you can redistribute it and/or modify
diff --git a/gschem/src/g_window.c b/gschem/src/g_window.c
index 9ba3a61..0ce352f 100644
--- a/gschem/src/g_window.c
+++ b/gschem/src/g_window.c
@@ -231,7 +231,7 @@ SCM_DEFINE (close_page, "%close-page!", 1, 0, 0,
* \brief Create the (gschem core window) Scheme module
* \par Function Description
* Defines procedures in the (gschem core window) module. The module
- * can be accessed using (use-modules (geda core toplevel)).
+ * can be accessed using (use-modules (gschem core window)).
*/
static void
init_module_gschem_core_window ()
@@ -270,7 +270,7 @@ g_init_window ()
/* Create fluid */
scheme_window_fluid = scm_permanent_object (scm_make_fluid ());
- /* Define the (geda core toplevel) module */
+ /* Define the (gschem core window) module */
scm_c_define_module ("gschem core window",
init_module_gschem_core_window,
NULL);
commit 3c2636864cc838286d31799d800f13c4f38f6d07
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Don't select placed objects.
Stop o_place_end() from modifying the selection. This makes the
behaviour when placing text and components consistent with the
behaviour when placing other objects.
diff --git a/gschem/src/o_place.c b/gschem/src/o_place.c
index fd3abc3..fdb6d6e 100644
--- a/gschem/src/o_place.c
+++ b/gschem/src/o_place.c
@@ -86,9 +86,6 @@ void o_place_end (GSCHEM_TOPLEVEL *w_current,
o_glist_translate_world(toplevel, w_diff_x, w_diff_y, temp_dest_list);
- /* Clear the old selection list */
- o_select_unselect_all (w_current);
-
/* Attach each item back onto the page's object list. Update object
* connectivity and add the new objects to the selection list.*/
p_current = toplevel->page_current;
@@ -98,9 +95,6 @@ void o_place_end (GSCHEM_TOPLEVEL *w_current,
s_page_append (toplevel, p_current, o_current);
- o_selection_add (toplevel,
- toplevel->page_current->selection_list, o_current);
-
/* Update object connectivity */
s_conn_update_object (toplevel, o_current);
connected_objects = s_conn_return_others (connected_objects, o_current);
commit 7dacbe7ca2c9d7a209a5f5cc474c58a4cb9a6c24
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Make Scheme command entry text box full width of window.
Makes it easier to see what you're doing when playing with Scheme
functions in gschem.
diff --git a/gschem/src/x_window.c b/gschem/src/x_window.c
index 79e882e..ee17b00 100644
--- a/gschem/src/x_window.c
+++ b/gschem/src/x_window.c
@@ -464,8 +464,10 @@ void x_window_create_main(GSCHEM_TOPLEVEL *w_current)
G_CALLBACK(&x_window_invoke_macro), w_current);
w_current->macro_box = gtk_hbox_new(FALSE, 0);
+ gtk_box_pack_start(GTK_BOX (w_current->macro_box),
+ gtk_label_new (_("Evaluate:")), FALSE, FALSE, 2);
gtk_box_pack_start(GTK_BOX(w_current->macro_box), w_current->macro_entry,
- FALSE, FALSE, 2);
+ TRUE, TRUE, 2);
gtk_container_border_width(GTK_CONTAINER(w_current->macro_box), 1);
gtk_box_pack_start (GTK_BOX (main_box), w_current->macro_box,
FALSE, FALSE, 0);
commit e92b66a8f48a565ae2b8de8d13601b7f54e84bad
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Get and set object fill parameters.
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 0040c53..6e44bd5 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -651,3 +651,6 @@
;; length used in the dash style.
(define-public (object-stroke-dash obj)
(list-tail (object-stroke obj) 2))
+
+(define-public object-fill %object-fill)
+(define-public set-object-fill! %set-object-fill!)
diff --git a/libgeda/scheme/unit-tests/t0017-object-stroke-fill.scm b/libgeda/scheme/unit-tests/t0017-object-stroke-fill.scm
index f90e4ca..ecf74c3 100644
--- a/libgeda/scheme/unit-tests/t0017-object-stroke-fill.scm
+++ b/libgeda/scheme/unit-tests/t0017-object-stroke-fill.scm
@@ -25,3 +25,19 @@
(set-object-stroke! a 1 'round 'phantom 7 8)
(assert-equal '(phantom 7 8) (object-stroke-dash a))
))
+
+(begin-test 'fill
+ (let ((a (make-box '(1 . 2) '(3 . 4))))
+
+ (assert-equal a (set-object-fill! a 'hollow))
+ (assert-equal '(hollow) (object-fill a))
+
+ (assert-equal a (set-object-fill! a 'solid))
+ (assert-equal '(solid) (object-fill a))
+
+ (assert-equal a (set-object-fill! a 'hatch 1 2 3))
+ (assert-equal '(hatch 1 2 3) (object-fill a))
+
+ (assert-equal a (set-object-fill! a 'mesh 4 5 6 7 8))
+ (assert-equal '(mesh 4 5 6 7 8) (object-fill a))
+ ))
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index 69a81cb..fa02519 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -64,6 +64,10 @@ SCM_SYMBOL (dashed_sym , "dashed");
SCM_SYMBOL (center_sym , "center");
SCM_SYMBOL (phantom_sym , "phantom");
+SCM_SYMBOL (hollow_sym , "hollow");
+SCM_SYMBOL (mesh_sym , "mesh");
+SCM_SYMBOL (hatch_sym , "hatch");
+
void o_page_changed (TOPLEVEL *t, OBJECT *o)
{
PAGE *p = o_get_page (t, o);
@@ -296,6 +300,7 @@ SCM_DEFINE (object_bounds, "%object-bounds", 1, 0, 1,
return result;
}
+
/*! \brief Get the stroke properties of an object.
* \par Function Description
* Returns the stroke settings of the object \a obj_s. If \a obj_s is
@@ -465,6 +470,162 @@ SCM_DEFINE (set_object_stroke, "%set-object-stroke!", 4, 2, 0,
return obj_s;
}
+/*! \brief Get the fill properties of an object.
+ * \par Function Description
+ * Returns the fill settings of the object \a obj_s. If \a obj_s is
+ * not a box, circle, or path, throws a Scheme error. The return
+ * value is a list of parameters:
+ *
+ * -# fill style (a symbol: hollow, solid, mesh or hatch)
+ * -# up to five fill parameters, depending on fill style:
+ * -# none for hollow or solid fills
+ * -# line width, line angle, and line spacing for hatch fills.
+ * -# line width, first angle and spacing, and second angle and
+ * spacing for mesh fills.
+ *
+ * \note Scheme API: Implements the %object-fill procedure in the
+ * (geda core object) module.
+ *
+ * \param obj_s object to get fill settings for.
+ * \return a list of fill parameters.
+ */
+SCM_DEFINE (object_fill, "%object-fill", 1, 0, 0,
+ (SCM obj_s), "Get the fill properties of an object.")
+{
+ SCM_ASSERT ((edascm_is_object_type (obj_s, OBJ_BOX)
+ || edascm_is_object_type (obj_s, OBJ_CIRCLE)
+ || edascm_is_object_type (obj_s, OBJ_PATH)),
+ obj_s, SCM_ARG1, s_object_fill);
+
+ OBJECT *obj = edascm_to_object (obj_s);
+
+ int type, width, pitch1, angle1, pitch2, angle2;
+ o_get_fill_options (obj, (OBJECT_FILLING *) &type, &width, &pitch1, &angle1,
+ &pitch2, &angle2);
+
+ SCM width_s = scm_from_int (width);
+ SCM pitch1_s = scm_from_int (pitch1);
+ SCM angle1_s = scm_from_int (angle1);
+ SCM pitch2_s = scm_from_int (pitch2);
+ SCM angle2_s = scm_from_int (angle2);
+
+ SCM type_s;
+ switch (type) {
+ case FILLING_HOLLOW: type_s = hollow_sym; break;
+ case FILLING_FILL: type_s = solid_sym; break;
+ case FILLING_MESH: type_s = mesh_sym; break;
+ case FILLING_HATCH: type_s = hatch_sym; break;
+ default:
+ scm_misc_error (s_object_fill,
+ _("Object ~A has invalid fill style ~A"),
+ scm_list_2 (obj_s, scm_from_int (type)));
+ }
+
+ switch (type) {
+ case FILLING_MESH:
+ return scm_list_n (type_s, width_s, pitch1_s, angle1_s, pitch2_s, angle2_s,
+ SCM_UNDEFINED);
+ case FILLING_HATCH:
+ return scm_list_4 (type_s, width_s, pitch1_s, angle1_s);
+ default:
+ return scm_list_1 (type_s);
+ }
+}
+
+/*! \brief Set the fill properties of an object.
+ * \par Function Description
+
+ * Updates the fill settings of the object \a obj_s. If \a obj_s is
+ * not a box, circle, or path, throws a Scheme error. The optional
+ * parameters \a width_s, \a angle1_s, \a space1_s, \a angle2_s and
+ * space2_s
+ *
+ * \note Scheme API: Implements the %object-fill procedure in the
+ * (geda core object) module.
+ *
+ * \param obj_s object to set fill settings for.
+ * \return \a obj_s.
+ */
+SCM_DEFINE (set_object_fill, "%set-object-fill!", 2, 5, 0,
+ (SCM obj_s, SCM type_s, SCM width_s, SCM space1_s, SCM angle1_s,
+ SCM space2_s, SCM angle2_s),
+ "Set the fill properties of an object.")
+{
+ SCM_ASSERT ((edascm_is_object_type (obj_s, OBJ_BOX)
+ || edascm_is_object_type (obj_s, OBJ_CIRCLE)
+ || edascm_is_object_type (obj_s, OBJ_PATH)),
+ obj_s, SCM_ARG1, s_set_object_fill);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+ int type, width = -1, angle1 = -1, space1 = -1, angle2 = -1, space2 = -1;
+
+ if (type_s == hollow_sym) { type = FILLING_HOLLOW; }
+ else if (type_s == solid_sym) { type = FILLING_FILL; }
+ else if (type_s == hatch_sym) { type = FILLING_HATCH; }
+ else if (type_s == mesh_sym) { type = FILLING_MESH; }
+ else {
+ scm_misc_error (s_set_object_fill,
+ _("Invalid fill style ~A."),
+ scm_list_1 (type_s));
+ }
+
+ switch (type) {
+ case FILLING_MESH:
+ if (space2_s == SCM_UNDEFINED) {
+ scm_misc_error (s_set_object_fill,
+ _("Missing second space parameter for fill style ~A."),
+ scm_list_1 (space2_s));
+ }
+ SCM_ASSERT (scm_is_integer (space2_s), space2_s,
+ SCM_ARG6, s_set_object_fill);
+ space2 = scm_to_int (space2_s);
+
+ if (angle2_s == SCM_UNDEFINED) {
+ scm_misc_error (s_set_object_fill,
+ _("Missing second angle parameter for fill style ~A."),
+ scm_list_1 (angle2_s));
+ }
+ SCM_ASSERT (scm_is_integer (angle2_s), angle2_s,
+ SCM_ARG7, s_set_object_fill);
+ angle2 = scm_to_int (angle2_s);
+ /* This case intentionally falls through */
+ case FILLING_HATCH:
+ if (width_s == SCM_UNDEFINED) {
+ scm_misc_error (s_set_object_fill,
+ _("Missing stroke width parameter for fill style ~A."),
+ scm_list_1 (width_s));
+ }
+ SCM_ASSERT (scm_is_integer (width_s), width_s,
+ SCM_ARG3, s_set_object_fill);
+ width = scm_to_int (width_s);
+
+ if (space1_s == SCM_UNDEFINED) {
+ scm_misc_error (s_set_object_fill,
+ _("Missing space parameter for fill style ~A."),
+ scm_list_1 (space1_s));
+ }
+ SCM_ASSERT (scm_is_integer (space1_s), space1_s,
+ SCM_ARG4, s_set_object_fill);
+ space1 = scm_to_int (space1_s);
+
+ if (angle1_s == SCM_UNDEFINED) {
+ scm_misc_error (s_set_object_fill,
+ _("Missing angle parameter for fill style ~A."),
+ scm_list_1 (angle1_s));
+ }
+ SCM_ASSERT (scm_is_integer (angle1_s), angle1_s,
+ SCM_ARG5, s_set_object_fill);
+ angle1 = scm_to_int (angle1_s);
+ /* This case intentionally falls through */
+ }
+
+ o_set_fill_options (toplevel, obj, type, width,
+ space1, angle1, space2, angle2);
+
+ return obj_s;
+}
+
/*! \brief Get the color of an object.
* \par Function Description
* Returns the colormap index of the color used to draw the #OBJECT
@@ -1340,6 +1501,7 @@ init_module_geda_core_object ()
/* Add them to the module's public definitions. */
scm_c_export (s_object_type, s_copy_object, s_object_bounds,
s_object_stroke, s_set_object_stroke,
+ s_object_fill, s_set_object_fill,
s_object_color, s_set_object_color,
s_make_line, s_make_net, s_make_bus,
s_make_pin, s_pin_type,
commit 709b2707e3ec79422f0485b6e381b5cbc351905e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Simplify generation of unit test failure messages.
Use (simple-format #f msg ...) instead of (with-output-to-string
thunk) to generate unit test failure messages.
diff --git a/libgeda/scheme/unit-test.scm b/libgeda/scheme/unit-test.scm
index 39ac84a..f7cf499 100644
--- a/libgeda/scheme/unit-test.scm
+++ b/libgeda/scheme/unit-test.scm
@@ -58,32 +58,22 @@
(if result
#t
(throw 'test-failed-exception
- (with-output-to-string
- (lambda ()
- (display " assert-true: ")
- (display "got: ")
- (write result))))))
+ (simple-format #f " assert-true: got: ~S" result))))
(define (assert-equal expected result)
(if (equal? expected result)
#t
(throw 'test-failed-exception
- (with-output-to-string
- (lambda ()
- (display " assert-equal: expected: ")
- (write expected)
- (display " got: ")
- (write result))))))
+ (simple-format #f " assert-equal: expected: ~S got: ~S"
+ expected result))))
(define (%assert-thrown key thunk)
(catch key
(lambda ()
(thunk)
(throw 'test-failed-exception
- (with-output-to-string
- (lambda ()
- (display " assert-thrown: expected exception: ")
- (write key)))))
+ (simple-format #f " assert-thrown: expected exception: ~S"
+ key)))
(lambda (key . args) #t)))
(define (%begin-test name test-thunk)
@@ -95,12 +85,9 @@
(lambda (key . args)
(set! test-success #f)
(set! test-fail-msg
- (if (eqv? key 'test-failed-exception)
- (car args)
- (with-output-to-string
- (lambda ()
- (display " unexpected exception: ")
- (write (cons key args))))))))
+ (if (eqv? key 'test-failed-exception)
+ (car args)
+ (format #f " unexpected exception: ~S" (cons key args))))))
(if test-success
(begin
commit 5ee02960cb8cc90c6c6fd946c53cdf94b0b46b0e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Make new C files translatable.
Also marks an new error message in gschem as translatable.
diff --git a/gschem/po/POTFILES.in b/gschem/po/POTFILES.in
index 26bbea7..3a28705 100644
--- a/gschem/po/POTFILES.in
+++ b/gschem/po/POTFILES.in
@@ -6,6 +6,7 @@ gschem/src/g_hook.c
gschem/src/g_keys.c
gschem/src/g_rc.c
gschem/src/g_register.c
+gschem/src/g_window.c
gschem/src/globals.c
gschem/src/gschem.c
gschem/src/gschem_accel_label.c
diff --git a/gschem/src/g_window.c b/gschem/src/g_window.c
index aa76707..9ba3a61 100644
--- a/gschem/src/g_window.c
+++ b/gschem/src/g_window.c
@@ -133,7 +133,7 @@ g_current_window ()
if (!(SCM_SMOB_PREDICATE (window_smob_tag, window_s)
&& ((void *)SCM_SMOB_DATA (window_s) != NULL))) {
- scm_misc_error (NULL, "Found invalid gschem window smob ~S",
+ scm_misc_error (NULL, _("Found invalid gschem window smob ~S"),
scm_list_1 (window_s));
}
diff --git a/libgeda/po/POTFILES.in b/libgeda/po/POTFILES.in
index 41a2a2b..5a34ae5 100644
--- a/libgeda/po/POTFILES.in
+++ b/libgeda/po/POTFILES.in
@@ -27,6 +27,10 @@ libgeda/src/s_color.c
libgeda/src/s_hierarchy.c
libgeda/src/s_page.c
libgeda/src/s_slib.c
+libgeda/src/scheme_attrib.c
+libgeda/src/scheme_complex.c
+libgeda/src/scheme_object.c
+libgeda/src/scheme_page.c
intl/plural.c
commit d1794e3a90d0774782d3ae37101db984db1038db
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Get and set object stroke parameters.
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 45efd6b..8030565 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -17,6 +17,7 @@ TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0014-object-text.scm \
unit-tests/t0015-object-complex.scm \
unit-tests/t0016-object-bounds.scm \
+ unit-tests/t0017-object-stroke-fill.scm \
unit-tests/t0020-page.scm \
unit-tests/t0021-page-dirty.scm \
unit-tests/t0030-attribute.scm
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index b7081af..0040c53 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -623,3 +623,31 @@
;; Removes obj from the primitive objects of the component c. Returns
;; obj.
(define-public component-remove! %complex-remove!)
+
+;;;; Fill and stroke
+
+(define-public object-stroke %object-stroke)
+(define-public set-object-stroke! %set-object-stroke!)
+
+;; object-stroke-width obj
+;;
+;; Returns the stroke width used to draw obj
+(define-public (object-stroke-width obj)
+ (list-ref (object-stroke obj) 0))
+
+;; object-stroke-cap obj
+;;
+;; Returns the cap style used to draw obj. One of the symbols none,
+;; square or round.
+(define-public (object-stroke-cap obj)
+ (list-ref (object-stroke obj) 1))
+
+;; object-stroke-dash obj
+;;
+;; Returns the dash style used to draw obj. The style is returned as
+;; a list, where the first element is the style itself (one of the
+;; symbols solid, dotted, dashed, center or phantom), and the
+;; remaining elements (if present) are the dot/dash spacing and dash
+;; length used in the dash style.
+(define-public (object-stroke-dash obj)
+ (list-tail (object-stroke obj) 2))
diff --git a/libgeda/scheme/unit-tests/t0017-object-stroke-fill.scm b/libgeda/scheme/unit-tests/t0017-object-stroke-fill.scm
new file mode 100644
index 0000000..f90e4ca
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0017-object-stroke-fill.scm
@@ -0,0 +1,27 @@
+;; Test Scheme procedures for object stroke properties.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'stroke
+ (let ((a (make-line '(1 . 2) '(3 . 4))))
+
+ (assert-equal a (set-object-stroke! a 1 'none 'solid 'foo 'bar))
+ (assert-equal 1 (object-stroke-width a))
+ (assert-equal 'none (object-stroke-cap a))
+ (assert-equal '(solid) (object-stroke-dash a))
+
+ (set-object-stroke! a 1 'square 'dotted 2 'bar)
+ (assert-equal 'square (object-stroke-cap a))
+ (assert-equal '(dotted 2) (object-stroke-dash a))
+
+ (set-object-stroke! a 1 'round 'dashed 3 4)
+ (assert-equal 'round (object-stroke-cap a))
+ (assert-equal '(dashed 3 4) (object-stroke-dash a))
+
+ (set-object-stroke! a 1 'round 'center 5 6)
+ (assert-equal '(center 5 6) (object-stroke-dash a))
+
+ (set-object-stroke! a 1 'round 'phantom 7 8)
+ (assert-equal '(phantom 7 8) (object-stroke-dash a))
+ ))
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index ce31ada..69a81cb 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -54,6 +54,16 @@ SCM_SYMBOL (name_sym , "name");
SCM_SYMBOL (value_sym , "value");
SCM_SYMBOL (both_sym , "both");
+SCM_SYMBOL (none_sym, "none");
+SCM_SYMBOL (square_sym , "square");
+SCM_SYMBOL (round_sym , "round");
+
+SCM_SYMBOL (solid_sym , "solid");
+SCM_SYMBOL (dotted_sym , "dotted");
+SCM_SYMBOL (dashed_sym , "dashed");
+SCM_SYMBOL (center_sym , "center");
+SCM_SYMBOL (phantom_sym , "phantom");
+
void o_page_changed (TOPLEVEL *t, OBJECT *o)
{
PAGE *p = o_get_page (t, o);
@@ -286,6 +296,175 @@ SCM_DEFINE (object_bounds, "%object-bounds", 1, 0, 1,
return result;
}
+/*! \brief Get the stroke properties of an object.
+ * \par Function Description
+ * Returns the stroke settings of the object \a obj_s. If \a obj_s is
+ * not a line, box, circle, arc, or path, throws a Scheme error. The
+ * return value is a list of parameters:
+ *
+ * -# stroke width
+ * -# cap style (a symbol: none, square or round)
+ * -# dash style (a symbol: solid, dotted, dashed, center or phantom)
+ * -# up to two dash parameters, depending on dash style:
+ * -# For solid lines, no parameters.
+ * -# For dotted lines, dot spacing.
+ * -# For other styles, dot/dash spacing and dash length.
+ *
+ * \note Scheme API: Implements the %object-stroke procedure in the
+ * (geda core object) module.
+ *
+ * \param obj_s object to get stroke settings for.
+ * \return a list of stroke parameters.
+ */
+SCM_DEFINE (object_stroke, "%object-stroke", 1, 0, 0,
+ (SCM obj_s), "Get the stroke properties of an object.")
+{
+ SCM_ASSERT ((edascm_is_object_type (obj_s, OBJ_LINE)
+ || edascm_is_object_type (obj_s, OBJ_BOX)
+ || edascm_is_object_type (obj_s, OBJ_CIRCLE)
+ || edascm_is_object_type (obj_s, OBJ_ARC)
+ || edascm_is_object_type (obj_s, OBJ_PATH)),
+ obj_s, SCM_ARG1, s_object_stroke);
+
+ OBJECT *obj = edascm_to_object (obj_s);
+
+ int end, type, width, length, space;
+ o_get_line_options (obj, (OBJECT_END *) &end, (OBJECT_TYPE *) &type, &width,
+ &length, &space);
+
+ SCM width_s = scm_from_int (width);
+ SCM length_s = scm_from_int (length);
+ SCM space_s = scm_from_int (space);
+
+ SCM cap_s;
+ switch (end) {
+ case END_NONE: cap_s = none_sym; break;
+ case END_SQUARE: cap_s = square_sym; break;
+ case END_ROUND: cap_s = round_sym; break;
+ default:
+ scm_misc_error (s_object_stroke,
+ _("Object ~A has invalid stroke cap style ~A"),
+ scm_list_2 (obj_s, scm_from_int (end)));
+ }
+
+ SCM dash_s;
+ switch (type) {
+ case TYPE_SOLID: dash_s = solid_sym; break;
+ case TYPE_DOTTED: dash_s = dotted_sym; break;
+ case TYPE_DASHED: dash_s = dashed_sym; break;
+ case TYPE_CENTER: dash_s = center_sym; break;
+ case TYPE_PHANTOM: dash_s = phantom_sym; break;
+ default:
+ scm_misc_error (s_object_stroke,
+ _("Object ~A has invalid stroke dash style ~A"),
+ scm_list_2 (obj_s, scm_from_int (type)));
+ }
+
+ switch (type) {
+ case TYPE_DASHED:
+ case TYPE_CENTER:
+ case TYPE_PHANTOM:
+ return scm_list_5 (width_s, cap_s, dash_s, space_s, length_s);
+ case TYPE_DOTTED:
+ return scm_list_4 (width_s, cap_s, dash_s, space_s);
+ default:
+ return scm_list_3 (width_s, cap_s, dash_s);
+ }
+}
+
+/*! \brief Set the stroke properties of an object.
+ * \par Function Description
+ * Updates the stroke settings of the object \a obj_s. If \a obj_s is
+ * not a line, box, circle, arc, or path, throws a Scheme error. The
+ * optional parameters \a space_s and \a length_s can be set to
+ * SCM_UNDEFINED if not required by the dash style \a dash_s.
+ *
+ * \note Scheme API: Implements the %object-stroke procedure in the
+ * (geda core object) module.
+ *
+ * \param obj_s object to set stroke settings for.
+ * \param width_s new stroke width for \a obj_s.
+ * \param cap_s new stroke cap style for \a obj_s.
+ * \param dash_s new dash style for \a obj_s.
+ * \param space_s dot/dash spacing for dash styles other than solid.
+ * \param length_s dash length for dash styles other than solid or
+ * dotted.
+ * \return \a obj_s.
+ */
+SCM_DEFINE (set_object_stroke, "%set-object-stroke!", 4, 2, 0,
+ (SCM obj_s, SCM width_s, SCM cap_s, SCM dash_s, SCM space_s,
+ SCM length_s), "Set the stroke properties of an object.")
+{
+ SCM_ASSERT ((edascm_is_object_type (obj_s, OBJ_LINE)
+ || edascm_is_object_type (obj_s, OBJ_BOX)
+ || edascm_is_object_type (obj_s, OBJ_CIRCLE)
+ || edascm_is_object_type (obj_s, OBJ_ARC)
+ || edascm_is_object_type (obj_s, OBJ_PATH)),
+ obj_s, SCM_ARG1, s_set_object_stroke);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+ int cap, type, width, length = -1, space = -1;
+
+ SCM_ASSERT (scm_is_integer (width_s), width_s,
+ SCM_ARG2, s_set_object_stroke);
+ SCM_ASSERT (scm_is_symbol (cap_s), cap_s,
+ SCM_ARG3, s_set_object_stroke);
+ SCM_ASSERT (scm_is_symbol (dash_s), dash_s,
+ SCM_ARG4, s_set_object_stroke);
+
+ width = scm_to_int (width_s);
+
+ if (cap_s == none_sym) { cap = END_NONE; }
+ else if (cap_s == square_sym) { cap = END_SQUARE; }
+ else if (cap_s == round_sym) { cap = END_ROUND; }
+ else {
+ scm_misc_error (s_set_object_stroke,
+ _("Invalid stroke cap style ~A."),
+ scm_list_1 (cap_s));
+ }
+
+ if (dash_s == solid_sym) { type = TYPE_SOLID; }
+ else if (dash_s == dotted_sym) { type = TYPE_DOTTED; }
+ else if (dash_s == dashed_sym) { type = TYPE_DASHED; }
+ else if (dash_s == center_sym) { type = TYPE_CENTER; }
+ else if (dash_s == phantom_sym) { type = TYPE_PHANTOM; }
+ else {
+ scm_misc_error (s_set_object_stroke,
+ _("Invalid stroke dash style ~A."),
+ scm_list_1 (dash_s));
+ }
+
+ switch (type) {
+ case TYPE_DASHED:
+ case TYPE_CENTER:
+ case TYPE_PHANTOM:
+ if (length_s == SCM_UNDEFINED) {
+ scm_misc_error (s_set_object_stroke,
+ _("Missing dash length parameter for dash style ~A."),
+ scm_list_1 (length_s));
+ }
+ SCM_ASSERT (scm_is_integer (length_s), length_s,
+ SCM_ARG6, s_set_object_stroke);
+ length = scm_to_int (length_s);
+ /* This case intentionally falls through */
+ case TYPE_DOTTED:
+ if (space_s == SCM_UNDEFINED) {
+ scm_misc_error (s_set_object_stroke,
+ _("Missing dot/dash space parameter for dash style ~A."),
+ scm_list_1 (space_s));
+ }
+ SCM_ASSERT (scm_is_integer (space_s), space_s,
+ SCM_ARG5, s_set_object_stroke);
+ space = scm_to_int (space_s);
+ /* This case intentionally falls through */
+ }
+
+ o_set_line_options (toplevel, obj, cap, type, width, length, space);
+
+ return obj_s;
+}
+
/*! \brief Get the color of an object.
* \par Function Description
* Returns the colormap index of the color used to draw the #OBJECT
@@ -1160,6 +1339,7 @@ init_module_geda_core_object ()
/* Add them to the module's public definitions. */
scm_c_export (s_object_type, s_copy_object, s_object_bounds,
+ s_object_stroke, s_set_object_stroke,
s_object_color, s_set_object_color,
s_make_line, s_make_net, s_make_bus,
s_make_pin, s_pin_type,
commit 68ea0f2273be05499512a1b2a3e557e93c049724
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Get object bounds.
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index fa18dea..45efd6b 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -16,6 +16,7 @@ TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0013-object-arc.scm\
unit-tests/t0014-object-text.scm \
unit-tests/t0015-object-complex.scm \
+ unit-tests/t0016-object-bounds.scm \
unit-tests/t0020-page.scm \
unit-tests/t0021-page-dirty.scm \
unit-tests/t0030-attribute.scm
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 4cf1135..b7081af 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -37,6 +37,8 @@
(define-public copy-object %copy-object)
+(define-public object-bounds %object-bounds)
+
(define-public object-color %object-color)
(define-public set-object-color! %set-object-color!)
diff --git a/libgeda/scheme/unit-tests/t0016-object-bounds.scm b/libgeda/scheme/unit-tests/t0016-object-bounds.scm
new file mode 100644
index 0000000..64264ec
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0016-object-bounds.scm
@@ -0,0 +1,29 @@
+;; Test Scheme procedures for working with object bounds.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'bounds
+ (let ((x (make-box '(0 . 1) '(1 . 0)))
+ (y (make-box '(2 . 3) '(3 . 2)))
+ (t (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both))
+ (C (make-component "test component" '(0 . 0) 0 #t #f)))
+
+ ;; Single argument
+ (assert-equal '((0 . 1) . (1 . 0)) (object-bounds x))
+
+ ;; Multiple arguments
+ (assert-equal '((0 . 3) . (3 . 0)) (object-bounds x y))
+
+ ;; Unfortunately, libgeda has no text renderer, so text never has
+ ;; any bounds. What a shame.
+ (assert-true (not (object-bounds t)))
+
+ ;; Empty components should have no bounds...
+ (assert-equal '() (component-contents C))
+ (assert-true (not (object-bounds C)))
+
+ ;; ... but they should get bounds when you add stuff to them.
+ (component-append! C x)
+ (assert-equal '((0 . 1) . (1 . 0)) (object-bounds x))
+ ))
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index 6a789ae..ce31ada 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -225,6 +225,67 @@ SCM_DEFINE (object_type, "%object-type", 1, 0, 0,
return result;
}
+/*! \brief Get the bounds of a list of objects
+ * \par Function Description
+ * Returns the bounds of the objects in the list formed by prepending
+ * \a obj_s to \a rst_s. The bounds are returned as a pair structure
+ * of the form:
+ *
+ * <code>((left . top) . (right . bottom))</code>
+ *
+ * If none of the objects has any bounds (e.g. because they are all
+ * empty components and/or text strings), returns SCM_BOOL_F.
+ *
+ * \warning This function always returns the actual bounds of the
+ * objects, not the visible bounds.
+ *
+ * \note Scheme API: Implements the %object-bounds procedure in
+ * the (geda core object) module. The procedure takes one or more
+ * #OBJECT smobs as arguments.
+ *
+ * \param [in] obj_s #OBJECT to get bounds for.
+ * \param [in] rst_s Variable-length list of additional #OBJECT arguments.
+ * \return bounds of objects or SCM_BOOL_F.
+ */
+SCM_DEFINE (object_bounds, "%object-bounds", 1, 0, 1,
+ (SCM obj_s, SCM rst_s), "Get the bounds of one or more objects")
+{
+ SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
+ SCM_ARG1, s_object_bounds);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+
+ GList *obj_list = edascm_to_object_glist (rst_s, s_object_bounds);
+ obj_list = g_list_prepend (obj_list, obj);
+
+ int success, left, top, right, bottom;
+ if (toplevel->show_hidden_text) {
+ success = world_get_object_glist_bounds (toplevel, obj_list,
+ &left, &top, &right, &bottom);
+ } else {
+ toplevel->show_hidden_text = TRUE;
+ o_recalc_object_glist (toplevel, obj_list);
+
+ success = world_get_object_glist_bounds (toplevel, obj_list,
+ &left, &top, &right, &bottom);
+
+ toplevel->show_hidden_text = FALSE;
+ o_recalc_object_glist (toplevel, obj_list);
+ }
+
+ SCM result = SCM_BOOL_F;
+ if (success) {
+ result = scm_cons (scm_cons (scm_from_int (min(left, right)),
+ scm_from_int (max(top, bottom))),
+ scm_cons (scm_from_int (max(left, right)),
+ scm_from_int (min(top, bottom))));
+ }
+
+ scm_remember_upto_here_2 (obj_s, rst_s);
+ return result;
+}
+
/*! \brief Get the color of an object.
* \par Function Description
* Returns the colormap index of the color used to draw the #OBJECT
@@ -1098,7 +1159,7 @@ init_module_geda_core_object ()
#include "scheme_object.x"
/* Add them to the module's public definitions. */
- scm_c_export (s_object_type, s_copy_object,
+ scm_c_export (s_object_type, s_copy_object, s_object_bounds,
s_object_color, s_set_object_color,
s_make_line, s_make_net, s_make_bus,
s_make_pin, s_pin_type,
commit 51afd1e9f5ff6d09e9066e2cc0f7eefab3a79002
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Change page filenames.
diff --git a/libgeda/scheme/geda/page.scm b/libgeda/scheme/geda/page.scm
index ca7dae0..17fcbaf 100644
--- a/libgeda/scheme/geda/page.scm
+++ b/libgeda/scheme/geda/page.scm
@@ -32,6 +32,7 @@
(define-public make-page %new-page)
(define-public close-page! %close-page!)
(define-public page-filename %page-filename)
+(define-public set-page-filename! %set-page-filename!)
(define-public page-contents %page-contents)
(define-public page-append! %page-append!)
(define-public page-remove! %page-remove!)
diff --git a/libgeda/scheme/unit-tests/t0020-page.scm b/libgeda/scheme/unit-tests/t0020-page.scm
index c059cae..151338e 100644
--- a/libgeda/scheme/unit-tests/t0020-page.scm
+++ b/libgeda/scheme/unit-tests/t0020-page.scm
@@ -10,6 +10,10 @@
(page-b (make-page "/test/page/B")))
(assert-equal "/test/page/A" (page-filename page-a))
(assert-equal (list page-a page-b) (active-pages))
+
+ (assert-equal page-a (set-page-filename! page-a "/test/page/C"))
+ (assert-equal "/test/page/C" (page-filename page-a))
+
(close-page! page-a)
(assert-equal (list page-b) (active-pages))
(close-page! page-b)))
diff --git a/libgeda/src/scheme_page.c b/libgeda/src/scheme_page.c
index 1d696be..4af275e 100644
--- a/libgeda/src/scheme_page.c
+++ b/libgeda/src/scheme_page.c
@@ -134,6 +134,36 @@ SCM_DEFINE (page_filename, "%page-filename", 1, 0, 0,
return scm_from_locale_string (page->page_filename);
}
+/*! \brief Change the filename associated with a page.
+ * \par Function Description
+ * Sets the filename associated with the #PAGE smob \a page_s.
+ *
+ * \note Scheme API: Implements the %set-page-filename! procedure of
+ * the (geda core page) module.
+ *
+ * \param page_s page to set filename for.
+ * \param filename_s new filename for \a page.
+ * \return \a page.
+ */
+SCM_DEFINE (set_page_filename, "%set-page-filename!", 2, 0, 0,
+ (SCM page_s, SCM filename_s), "Set a page's associated filename")
+{
+ SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
+ SCM_ARG1, s_set_page_filename);
+ SCM_ASSERT (scm_is_string (filename_s), filename_s,
+ SCM_ARG2, s_set_page_filename);
+
+ PAGE *page = edascm_to_page (page_s);
+ char *new_fn = scm_to_locale_string (filename_s);
+ if (page->page_filename != NULL) {
+ g_free (page->page_filename);
+ }
+ page->page_filename = g_strdup (new_fn);
+ free (new_fn);
+
+ return page_s;
+}
+
/*! \brief Get a list of objects in a page.
* \par Function Description
* Retrieves the contents of a the #PAGE smob \a page_s as a Scheme
@@ -353,8 +383,9 @@ init_module_geda_core_page ()
/* Add them to the module's public definitions. */
scm_c_export (s_active_pages, s_new_page, s_close_page,
- s_page_filename, s_page_contents, s_object_page, s_page_append_,
- s_page_remove_, s_page_dirty, s_set_page_dirty, NULL);
+ s_page_filename, s_set_page_filename, s_page_contents,
+ s_object_page, s_page_append_, s_page_remove_, s_page_dirty,
+ s_set_page_dirty, NULL);
}
/*!
commit bb9e4bcd4d3e5b9b598105f7f6f1aecae880783b
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
Delete guile-snarf output files during distclean.
diff --git a/gschem/src/Makefile.am b/gschem/src/Makefile.am
index f858c55..2216b76 100644
--- a/gschem/src/Makefile.am
+++ b/gschem/src/Makefile.am
@@ -96,6 +96,6 @@ DEFS = -DLOCALEDIR=\"$(localedir)\" @DEFS@
EXTRA_DIST = rcstrings.c
MOSTLYCLEANFILES = *.log core FILE *~
-CLEANFILES = *.log core FILE *~
+CLEANFILES = *.log core FILE *~ $(BUILT_SOURCES)
DISTCLEANFILES = *.log core FILE *~
MAINTAINERCLEANFILES = *.log core FILE *~ Makefile.in
diff --git a/libgeda/shell/Makefile.am b/libgeda/shell/Makefile.am
index f2da672..9e6f33f 100644
--- a/libgeda/shell/Makefile.am
+++ b/libgeda/shell/Makefile.am
@@ -24,3 +24,5 @@ snarf_cpp_opts = $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
$(geda_shell_CPPFLAGS) $(AM_CFLAGS) $(geda_shell_CFLAGS)
.c.x:
$(GUILE_SNARF) -o $@ $< $(snarf_cpp_opts)
+
+cleanfiles = $(BUILT_SOURCES)
diff --git a/libgeda/src/Makefile.am b/libgeda/src/Makefile.am
index 7eee9e9..4619dcd 100644
--- a/libgeda/src/Makefile.am
+++ b/libgeda/src/Makefile.am
@@ -97,7 +97,7 @@ snarf_cpp_opts = $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
$(GUILE_SNARF) -o $@ $< $(snarf_cpp_opts)
MOSTLYCLEANFILES = *.log core FILE *~
-CLEANFILES = *.log core FILE *~
+CLEANFILES = *.log core FILE *~ $(BUILT_SOURCES)
DISTCLEANFILES = *.log core FILE *~
MAINTAINERCLEANFILES = *.log core FILE *~ Makefile.in
commit 19fbd43464e59cbbed0fb98371b1daf5b3edc363
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Include <libgedaguile.h> by default.
diff --git a/gschem/include/gschem.h b/gschem/include/gschem.h
index ad69118..60115dc 100644
--- a/gschem/include/gschem.h
+++ b/gschem/include/gschem.h
@@ -3,6 +3,7 @@
#include <gtk/gtk.h>
#include <libguile.h>
#include <libgeda/libgeda.h>
+#include <libgeda/libgedaguile.h>
/* gschem headers */
#include "gschem_defines.h"
diff --git a/gschem/src/g_funcs.c b/gschem/src/g_funcs.c
index 894753b..d4df053 100644
--- a/gschem/src/g_funcs.c
+++ b/gschem/src/g_funcs.c
@@ -33,7 +33,6 @@
#endif
#include "gschem.h"
-#include <libgeda/libgedaguile.h>
#ifdef HAVE_LIBDMALLOC
#include <dmalloc.h>
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index a979255..03a0d66 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -25,7 +25,6 @@
#include <math.h>
#include "gschem.h"
-#include <libgeda/libgedaguile.h>
#ifdef HAVE_LIBDMALLOC
#include <dmalloc.h>
diff --git a/gschem/src/g_window.c b/gschem/src/g_window.c
index e702739..aa76707 100644
--- a/gschem/src/g_window.c
+++ b/gschem/src/g_window.c
@@ -19,7 +19,6 @@
#include <config.h>
#include "gschem.h"
-#include <libgeda/libgedaguile.h>
SCM scheme_window_fluid = SCM_UNDEFINED;
commit 420c5126609f2f2f409cbfad50afd2949836fe6e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
libgeda: Calculate bounds correctly for empty components.
diff --git a/libgeda/src/o_complex_basic.c b/libgeda/src/o_complex_basic.c
index 9322634..8d54af4 100644
--- a/libgeda/src/o_complex_basic.c
+++ b/libgeda/src/o_complex_basic.c
@@ -632,6 +632,9 @@ void o_complex_recalc(TOPLEVEL *toplevel, OBJECT *o_current)
if ((!o_current) || (o_current->type != OBJ_COMPLEX && o_current->type != OBJ_PLACEHOLDER))
return;
+ if (o_current->complex->prim_objs == NULL)
+ return;
+
world_get_complex_bounds(toplevel, o_current, &left, &top, &right, &bottom);
o_current->w_left = left;
o_current->w_top = top;
commit 9042448ea44521adc53375fdfc3d50641da0565a
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Make object & attrib modifications dirty current page.
diff --git a/libgeda/include/libgedaguile_priv.h b/libgeda/include/libgedaguile_priv.h
index 37e6371..14f0c34 100644
--- a/libgeda/include/libgedaguile_priv.h
+++ b/libgeda/include/libgedaguile_priv.h
@@ -128,6 +128,10 @@ GList *edascm_to_object_glist (SCM objs, const char *subr);
SCM edascm_from_object_glist (const GList *objs);
int edascm_is_object_type (SCM smob, int type);
+
+/*! \brief Flag an object's page as having been changed. */
+extern inline void o_page_changed (TOPLEVEL *t, OBJECT *o);
+
/* ---------------------------------------- */
extern SCM edascm_object_state_sym;
diff --git a/libgeda/scheme/unit-tests/t0021-page-dirty.scm b/libgeda/scheme/unit-tests/t0021-page-dirty.scm
index f579a0e..2de00c5 100644
--- a/libgeda/scheme/unit-tests/t0021-page-dirty.scm
+++ b/libgeda/scheme/unit-tests/t0021-page-dirty.scm
@@ -3,6 +3,16 @@
(use-modules (unit-test))
(use-modules (geda page))
(use-modules (geda object))
+(use-modules (geda attrib))
+(use-modules (ice-9 syncase))
+
+;; Utility macro to avoid boilerplate
+(define-syntax assert-dirties
+ (syntax-rules ()
+ ((_ P . test-forms)
+ (begin (begin . test-forms)
+ (assert-true (page-dirty? P))
+ (set-page-dirty! P #f)))))
(begin-test 'page-dirty
(let ((P (make-page "/test/page/A"))
@@ -19,16 +29,88 @@
(set-page-dirty! P #f)
(assert-true (not (page-dirty? P)))
- (set-page-dirty! P #t)
- (assert-true (page-dirty? P))
+ (assert-dirties P (set-page-dirty! P #t))
+ (assert-dirties P (page-append! P C))
+ (assert-dirties P (page-remove! P C)))
+ (lambda ()
+ (close-page! P)))))
- (set-page-dirty! P #f)
- (page-append! P C)
- (assert-true (page-dirty? P))
+(begin-test 'page-dirty-objects
+ (let ((P (make-page "/test/page/A"))
+ (l (make-line '(1 . 2) '(3 . 4)))
+ (b (make-box '(1 . 4) '(3 . 2)))
+ (c (make-circle '(1 . 2) 3))
+ (a (make-arc '(1 . 2) 3 45 90))
+ (t (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both))
+ (C (make-component "test component" '(1 . 2) 0 #t #f)))
- (set-page-dirty! P #f)
- (page-remove! P C)
- (assert-true (page-dirty? P)))
+ (dynamic-wind ; Make sure pages are cleaned up
+ (lambda () #f)
+ (lambda ()
+
+ ; Add everything to the page
+ (assert-dirties P (for-each (lambda (x) (page-append! P x))
+ (list l b c a t C)))
+
+ (assert-dirties P (apply set-line! l (line-info l)))
+ (assert-dirties P (apply set-box! b (box-info b)))
+ (assert-dirties P (apply set-circle! c (circle-info c)))
+ (assert-dirties P (apply set-arc! a (arc-info a)))
+ (assert-dirties P (apply set-text! t (text-info t)))
+ (assert-dirties P (apply set-component! C
+ (list-tail (component-info C) 1)))
+
+ ; Remove primitives from page
+ (assert-dirties P (for-each (lambda (x) (page-remove! P x))
+ (list l b c a t)))
+
+ ; Add primitives to component
+ (for-each (lambda (x) (assert-dirties P (component-append! C x)))
+ (list l b c a t))
+
+ ; Modify primitives within component
+ (assert-dirties P (apply set-line! l (line-info l)))
+ (assert-dirties P (apply set-box! b (box-info b)))
+ (assert-dirties P (apply set-circle! c (circle-info c)))
+ (assert-dirties P (apply set-arc! a (arc-info a)))
+ (assert-dirties P (apply set-text! t (text-info t)))
+
+ ; Remove primitives from component
+ (for-each (lambda (x) (assert-dirties P (component-remove! C x)))
+ (list l b c a t)))
(lambda ()
- (close-page! P)))))
+ (for-each (lambda (x) (page-remove! P x)) (page-contents P))
+ (close-page! P)))
+
+ ))
+
+(begin-test 'page-dirty-attribs
+ (let ((P (make-page "/test/page/A"))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (t (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
+ (C (make-component "test component" '(1 . 2) 0 #t #f)))
+
+ (dynamic-wind ; Make sure pages are cleaned up
+ (lambda () #f)
+ (lambda ()
+ ; Populate page
+ (page-append! P t) (page-append! P C) (component-append! C p)
+
+ ; Attach attribute to component
+ (assert-dirties P (attach-attrib! C t))
+ ; Detach attribute from component
+ (assert-dirties P (detach-attrib! C t))
+
+ ; Move attribute into component
+ (component-append! C (page-remove! P t))
+
+ ; Attach attribute to pin
+ (assert-dirties P (attach-attrib! p t))
+ ; Detach attribute from pin
+ (assert-dirties P (detach-attrib! p t))
+ )
+ (lambda ()
+ (close-page! P)))
+
+ ))
diff --git a/libgeda/src/scheme_attrib.c b/libgeda/src/scheme_attrib.c
index 0816136..af23c32 100644
--- a/libgeda/src/scheme_attrib.c
+++ b/libgeda/src/scheme_attrib.c
@@ -176,6 +176,8 @@ SCM_DEFINE (attach_attrib, "%attach-attrib!", 2, 0, 0,
o_attrib_attach (toplevel, attrib, obj, TRUE);
o_emit_change_notify (toplevel, attrib);
+ o_page_changed (toplevel, obj);
+
return attrib_s;
}
@@ -218,6 +220,8 @@ SCM_DEFINE (detach_attrib, "%detach-attrib!", 2, 0, 0,
o_set_color (toplevel, attrib, DETACHED_ATTRIBUTE_COLOR);
o_emit_change_notify (toplevel, attrib);
+ o_page_changed (toplevel, obj);
+
return attrib_s;
}
diff --git a/libgeda/src/scheme_complex.c b/libgeda/src/scheme_complex.c
index f094f7a..3b0adc6 100644
--- a/libgeda/src/scheme_complex.c
+++ b/libgeda/src/scheme_complex.c
@@ -165,6 +165,8 @@ SCM_DEFINE (set_complex, "%set-complex!", 6, 0, 0,
o_emit_change_notify (toplevel, obj);
+ o_page_changed (toplevel, obj);
+
return complex_s;
}
@@ -281,6 +283,8 @@ SCM_DEFINE (complex_append, "%complex-append!", 2, 0, 0,
o_emit_change_notify (toplevel, parent);
+ o_page_changed (toplevel, parent);
+
return obj_s;
}
@@ -351,6 +355,8 @@ SCM_DEFINE (complex_remove, "%complex-remove!", 2, 0, 0,
o_emit_change_notify (toplevel, parent);
+ o_page_changed (toplevel, parent);
+
/* Object cleanup now managed by Guile. */
edascm_c_set_gc (obj_s, 1);
return obj_s;
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index cb92032..6a789ae 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -54,6 +54,12 @@ SCM_SYMBOL (name_sym , "name");
SCM_SYMBOL (value_sym , "value");
SCM_SYMBOL (both_sym , "both");
+void o_page_changed (TOPLEVEL *t, OBJECT *o)
+{
+ PAGE *p = o_get_page (t, o);
+ if (p != NULL) p->CHANGED = TRUE;
+}
+
/*! \brief Convert a Scheme object list to a GList.
* \par Function Description
* Takes a Scheme list of #OBJECT smobs, and returns a GList
@@ -262,8 +268,11 @@ SCM_DEFINE (set_object_color, "%set-object-color!", 2, 0, 0,
SCM_ASSERT (scm_is_integer (color_s), color_s,
SCM_ARG2, s_set_object_color);
- o_set_color (edascm_c_current_toplevel (),
- edascm_to_object (obj_s), scm_to_int (color_s));
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+ o_set_color (toplevel, obj, scm_to_int (color_s));
+
+ o_page_changed (toplevel, obj);
return obj_s;
}
@@ -359,6 +368,8 @@ SCM_DEFINE (set_line, "%set-line!", 6, 0, 0,
}
o_set_color (toplevel, obj, scm_to_int (color_s));
+ o_page_changed (toplevel, obj);
+
return line_s;
}
@@ -601,6 +612,8 @@ SCM_DEFINE (set_box, "%set-box!", 6, 0, 0,
scm_to_int (x2_s), scm_to_int (y2_s));
o_set_color (toplevel, obj, scm_to_int (color_s));
+ o_page_changed (toplevel, obj);
+
return box_s;
}
@@ -695,6 +708,8 @@ SCM_DEFINE (set_circle, "%set-circle!", 5, 0, 0,
o_circle_modify (toplevel, obj, scm_to_int(r_s), 0, CIRCLE_RADIUS);
o_set_color (toplevel, obj, scm_to_int (color_s));
+ o_page_changed (toplevel, obj);
+
return circle_s;
}
@@ -796,6 +811,8 @@ SCM_DEFINE (set_arc, "%set-arc!", 7, 0, 0,
o_arc_modify (toplevel, obj, scm_to_int(end_angle_s), 0, ARC_END_ANGLE);
o_set_color (toplevel, obj, scm_to_int (color_s));
+ o_page_changed (toplevel, obj);
+
return arc_s;
}
@@ -983,6 +1000,8 @@ SCM_DEFINE (set_text, "%set-text!", 10, 0, 0,
/* Color */
o_set_color (toplevel, obj, scm_to_int (color_s));
+ o_page_changed (toplevel, obj);
+
return text_s;
}
commit b1056b243513171194ad2e68894d2f618eef6d76
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Improve unit tests for attribute attachment/detachment.
diff --git a/libgeda/scheme/unit-tests/t0030-attribute.scm b/libgeda/scheme/unit-tests/t0030-attribute.scm
index 35be33e..eded1be 100644
--- a/libgeda/scheme/unit-tests/t0030-attribute.scm
+++ b/libgeda/scheme/unit-tests/t0030-attribute.scm
@@ -19,58 +19,102 @@
(assert-true (not (attrib-value bad))) ))
(begin-test 'attach-attrib
- (let ((page1 (make-page "/test/page/1"))
- (page2 (make-page "/test/page/2"))
- (comp1 (make-component "testcomponent1" '(0 . 0) 0 #f #f))
- (comp2 (make-component "testcomponent2" '(0 . 0) 0 #f #f))
- (pin (make-net-pin '(0 . 0) '(100 . 0)))
+ (let ((C (make-component "testcomponent1" '(0 . 0) 0 #f #f))
+ (D (make-component "testcomponent2" '(0 . 0) 0 #f #f))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (q (make-net-pin '(0 . 0) '(100 . 0)))
(x (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both))
- (y (make-text '(0 . 0) 'lower-left 0 "name=y" 10 #t 'both)))
-
- ;; This test is particularly long-winded because it tries to
- ;; exhaustively test every possible reason for attach-attrib! to
- ;; fail.
-
- (assert-thrown 'object-state
- (attach-attrib! pin x))
-
- (component-append! comp1 pin)
- (assert-thrown 'object-state
- (attach-attrib! pin x))
-
- (component-append! comp1 x)
- (assert-equal x (attach-attrib! pin x))
- (assert-equal (list x) (object-attribs pin))
-
- (assert-thrown 'object-state
- (attach-attrib! x y))
-
- (assert-thrown 'object-state
- (attach-attrib! y x))
-
- (component-append! comp2 y)
- (assert-thrown 'object-state
- (attach-attrib! pin y))
-
- (component-remove! comp2 y)
-
- (page-append! page1 comp1)
- (assert-thrown 'object-state
- (attach-attrib! comp1 y))
-
- (page-append! page1 y)
- (assert-thrown 'object-state
- (attach-attrib! pin y))
-
- (page-remove! page1 y)
- (page-append! page2 y)
- (assert-thrown 'object-state
- (attach-attrib! comp1 y))
-
- (page-remove! page2 y)
- (page-append! page1 y)
- (assert-equal y (attach-attrib! comp1 y))
- (assert-equal (list y) (object-attribs comp1)) ))
+ (y (make-text '(0 . 0) 'lower-left 0 "name=y" 10 #t 'both))
+ (z (make-text '(0 . 0) 'lower-left 0 "name=z" 10 #t 'both)))
+
+ ;; Attach attribute outside component or page
+ (assert-thrown 'object-state (attach-attrib! C x))
+ (assert-equal '() (object-attribs C))
+ (assert-true (not (attrib-attachment x)))
+
+ ;; Populate components
+ (for-each (lambda (o) (component-append! C o)) (list p q x y))
+ (component-append! D z)
+
+ ;; Attach attribute to object in same component
+ (assert-equal x (attach-attrib! p x))
+ (assert-equal (list x) (object-attribs p))
+ (assert-equal p (attrib-attachment x))
+
+ ;; Attach attribute which is already attached, within same
+ ;; component
+ (assert-thrown 'object-state (attach-attrib! q x))
+
+ ;; Attach attribute to object in different component
+ (assert-thrown 'object-state (attach-attrib! p z))
+ (assert-equal (list x) (object-attribs p))
+ (assert-true (not (attrib-attachment z)))
+
+ ;; Attach internal attribute to containing component
+ (assert-thrown 'object-state (attach-attrib! D z))
+ (assert-equal '() (object-attribs D))
+ (assert-true (not (attrib-attachment z)))
+
+ ;; Attach attribute in component to floating object
+ (assert-thrown 'object-state (attach-attrib! C z))
+ (assert-equal '() (object-attribs C))
+ (assert-true (not (attrib-attachment z)))
+
+ ;; Attach floating attribute to object in component
+ (component-remove! D z)
+ (assert-thrown 'object-state (attach-attrib! p z))
+ (assert-equal (list x) (object-attribs p))
+ (assert-true (not (attrib-attachment z)))
+
+ ;; Attach multiple attributes
+ (assert-equal y (attach-attrib! p y))
+ (assert-equal (list x y) (object-attribs p))
+ (assert-equal p (attrib-attachment y))
+ ))
+
+(begin-test 'attach-attrib/page
+ (let ((P (make-page "/test/page/A"))
+ (Q (make-page "/test/page/A"))
+ (p (make-net-pin '(0 . 0) '(100 . 0)))
+ (x (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
+ (y (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
+ (z (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
+ (C (make-component "test component" '(1 . 2) 0 #t #f)))
+
+ (dynamic-wind ; Make sure pages are cleaned up
+ (lambda () #f)
+ (lambda ()
+ ; Populate pages
+ (page-append! P x) (page-append! P C)
+ (component-append! C p) (component-append! C y)
+
+ (page-append! Q z)
+
+ ; Attach attribute to component in same page
+ (attach-attrib! C x)
+ (assert-equal (list x) (object-attribs C))
+ (assert-equal C (attrib-attachment x))
+
+ ; Remove stuff from page
+ (assert-thrown 'object-state (page-remove! P x))
+ (assert-thrown 'object-state (page-remove! P C))
+
+ ; Attach attribute to component in different page
+ (assert-thrown 'object-state (attach-attrib! C z))
+
+ ; Attach attribute to pin in component in page
+ (attach-attrib! p y)
+ (assert-equal (list y) (object-attribs p))
+ (assert-equal p (attrib-attachment y))
+
+ ; Remove stuff from component in page
+ (assert-thrown 'object-state (component-remove! C p))
+ (assert-thrown 'object-state (component-remove! C y)) )
+ (lambda ()
+ (close-page! P)
+ (close-page! Q) ))
+
+ ))
(begin-test 'detach-attrib
(let ((page (make-page "/test/page/1"))
commit d72e2913f90edf2c02df614fa140c7d13c252362
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Remove primitives from components that are in pages.
The API currently erroneously throws an error when attempting to
remove a primitive object from a component that is attached to a page.
diff --git a/libgeda/scheme/unit-tests/t0015-object-complex.scm b/libgeda/scheme/unit-tests/t0015-object-complex.scm
index 849dbc1..59b46f8 100644
--- a/libgeda/scheme/unit-tests/t0015-object-complex.scm
+++ b/libgeda/scheme/unit-tests/t0015-object-complex.scm
@@ -51,17 +51,11 @@
(assert-equal (list x y) (component-contents A))
(assert-thrown 'object-state
- (component-append! B x))
-
- (assert-thrown 'object-state
- (let* ((P (make-page "/test/page/A"))
- (z (page-append! P (make-line '(1 . 0) '(2 . 2)))))
- (component-append! A z)))))
+ (component-append! B x))))
(begin-test 'component-remove
(let ((A (make-component "test component" '(1 . 2) 0 #t #f))
(B (make-component "test component" '(1 . 2) 0 #t #f))
- (P (make-page "/test/page/A"))
(x (make-line '(0 . 0) '(2 . 0)))
(y (make-line '(0 . 0) '(0 . 2)))
(z (make-line '(1 . 0) '(2 . 2))))
@@ -78,11 +72,58 @@
(assert-equal (list y) (component-contents A))
(assert-thrown 'object-state
- (component-remove! B y))
+ (component-remove! B y))))
- (page-append! P z)
- (assert-thrown 'object-state
- (component-remove! A z))
+(begin-test 'component-append/page
+ (let ((P (make-page "/test/page/A"))
+ (A (make-component "test component" '(1 . 2) 0 #t #f))
+ (x (make-line '(0 . 0) '(2 . 0)))
+ (y (make-line '(0 . 0) '(0 . 2))))
+ (dynamic-wind
+ (lambda () #t)
+ (lambda ()
+ (page-append! P x)
+ (assert-thrown 'object-state
+ (component-append! A x))
+
+ (page-append! P A)
+ (assert-thrown 'object-state
+ (component-append! A x))
+
+ (component-append! A y)
+ (assert-equal (list y) (component-contents A)))
+
+ (lambda ()
+ (close-page! P)))
+ ))
+
+(begin-test 'component-remove/page
+ (let ((P (make-page "/test/page/A"))
+ (A (make-component "test component" '(1 . 2) 0 #t #f))
+ (x (make-line '(0 . 0) '(2 . 0)))
+ (y (make-line '(0 . 0) '(0 . 2))))
+ (dynamic-wind
+ (lambda () #t)
+ (lambda ()
+ ;; Test that if a primitive object is attached directly to
+ ;; a page, attempting to remove it from a component
+ ;; doesn't work.
+ (page-append! P x)
+ (assert-thrown 'object-state
+ (component-remove! A x))
+
+ (page-append! P A)
+ (assert-thrown 'object-state
+ (component-remove! A x))
+
+ ;; Test that you can remove primitive objects from a
+ ;; component that is attached to a page.
+ (component-append! A y)
+ (component-remove! A y)
+ (assert-equal '() (component-contents A)))
+
+ (lambda ()
+ (close-page! P)))
))
(begin-test 'component-translate
diff --git a/libgeda/src/scheme_complex.c b/libgeda/src/scheme_complex.c
index c507e77..f094f7a 100644
--- a/libgeda/src/scheme_complex.c
+++ b/libgeda/src/scheme_complex.c
@@ -309,12 +309,19 @@ SCM_DEFINE (complex_remove, "%complex-remove!", 2, 0, 0,
TOPLEVEL *toplevel = edascm_c_current_toplevel ();
OBJECT *parent = edascm_to_object (complex_s);
OBJECT *child = edascm_to_object (obj_s);
+ PAGE *child_page = o_get_page (toplevel, child);
- /* Check that object is not attached to a page or a different complex. */
- if ((o_get_page (toplevel, child) != NULL)
- || ((child->parent != NULL) && (child->parent != parent))) {
+ /* Check that object is not attached to a different complex. */
+ if ((child->parent != NULL) && (child->parent != parent)) {
+ scm_error (edascm_object_state_sym, s_complex_remove,
+ _("Object ~A is attached to a different complex"),
+ scm_list_1 (obj_s), SCM_EOL);
+ }
+
+ /* Check that object is not attached to a page. */
+ if ((child->parent == NULL) && (child_page != NULL)) {
scm_error (edascm_object_state_sym, s_complex_remove,
- _("Object ~A is attached to a page or a different complex"),
+ _("Object ~A is attached to a page"),
scm_list_1 (obj_s), SCM_EOL);
}
commit 6eb023e46dc54a0b702cc9d9616325bf4e25ead4
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Inspect and modify a page's `CHANGED' flag.
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 5b548d6..fa18dea 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -17,6 +17,7 @@ TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0014-object-text.scm \
unit-tests/t0015-object-complex.scm \
unit-tests/t0020-page.scm \
+ unit-tests/t0021-page-dirty.scm \
unit-tests/t0030-attribute.scm
dist_noinst_DATA = unit-test.scm $(TESTS)
diff --git a/libgeda/scheme/geda/page.scm b/libgeda/scheme/geda/page.scm
index ffed74d..ca7dae0 100644
--- a/libgeda/scheme/geda/page.scm
+++ b/libgeda/scheme/geda/page.scm
@@ -21,7 +21,9 @@
; Import C procedures
#:use-module (geda core smob)
- #:use-module (geda core page))
+ #:use-module (geda core page)
+
+ #:use-module (ice-9 optargs))
(define-public object-page %object-page)
@@ -33,3 +35,11 @@
(define-public page-contents %page-contents)
(define-public page-append! %page-append!)
(define-public page-remove! %page-remove!)
+(define-public page-dirty? %page-dirty?)
+
+;; set-page-dirty! [state]
+;;
+;; Set whether page is flagged as changed according to the optional
+;; flag state. If state is omitted, the page is marked as changed.
+(define*-public (set-page-dirty! page #:optional (state #t))
+ (%set-page-dirty! page state))
diff --git a/libgeda/scheme/unit-tests/t0021-page-dirty.scm b/libgeda/scheme/unit-tests/t0021-page-dirty.scm
new file mode 100644
index 0000000..f579a0e
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0021-page-dirty.scm
@@ -0,0 +1,34 @@
+;; Test Scheme procedures related to pages' changed flags.
+
+(use-modules (unit-test))
+(use-modules (geda page))
+(use-modules (geda object))
+
+(begin-test 'page-dirty
+ (let ((P (make-page "/test/page/A"))
+ (C (make-component "test component" '(1 . 2) 0 #t #f)))
+
+ (dynamic-wind ; Make sure pages are cleaned up
+ (lambda () #f)
+ (lambda ()
+ (assert-true (not (page-dirty? P)))
+
+ (set-page-dirty! P)
+ (assert-true (page-dirty? P))
+
+ (set-page-dirty! P #f)
+ (assert-true (not (page-dirty? P)))
+
+ (set-page-dirty! P #t)
+ (assert-true (page-dirty? P))
+
+ (set-page-dirty! P #f)
+ (page-append! P C)
+ (assert-true (page-dirty? P))
+
+ (set-page-dirty! P #f)
+ (page-remove! P C)
+ (assert-true (page-dirty? P)))
+
+ (lambda ()
+ (close-page! P)))))
diff --git a/libgeda/src/scheme_page.c b/libgeda/src/scheme_page.c
index c255266..1d696be 100644
--- a/libgeda/src/scheme_page.c
+++ b/libgeda/src/scheme_page.c
@@ -291,6 +291,53 @@ SCM_DEFINE (page_remove_, "%page-remove!", 2, 0, 0,
return obj_s;
}
+/*! \brief Check whether a page has been flagged as changed.
+ * \par Function Description
+ * Returns SCM_BOOL_T if \a page_s has been flagged as having been
+ * modified.
+ *
+ * \note Scheme API: Implements the %page-dirty? procedure of the
+ * (geda core page) module.
+ *
+ * \param page_s page to inspect.
+ * \return SCM_BOOL_T if page is dirtied, otherwise SCM_BOOL_F.
+ */
+SCM_DEFINE (page_dirty, "%page-dirty?", 1, 0, 0,
+ (SCM page_s), "Check whether a page has been flagged as changed.")
+{
+ /* Ensure that the argument is a page smob */
+ SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
+ SCM_ARG1, s_page_dirty);
+
+ PAGE *page = edascm_to_page (page_s);
+ return page->CHANGED ? SCM_BOOL_T : SCM_BOOL_F;
+}
+
+/*! \brief Set a page's changed flag.
+ * \par Function Description
+ * If \a flag_s is true, flag \a page_s as having been modified.
+ * Otherwise, clears the change flag.
+ *
+ * \note Scheme API: Implements the %set-page-dirty! procedure of the
+ * (geda core page) module.
+ *
+ * \param page_s page to modify.
+ * \param flag_s new flag setting.
+ * \return \a page_s
+ */
+SCM_DEFINE (set_page_dirty, "%set-page-dirty!", 2, 0, 0,
+ (SCM page_s, SCM flag_s),
+ "Set whether a page is flagged as changed.")
+{
+ /* Ensure that the argument is a page smob */
+ SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
+ SCM_ARG1, s_set_page_dirty);
+
+ PAGE *page = edascm_to_page (page_s);
+ page->CHANGED = scm_is_true (flag_s);
+ return page_s;
+}
+
/*!
* \brief Create the (geda core page) Scheme module.
* \par Function Description
@@ -307,7 +354,7 @@ init_module_geda_core_page ()
scm_c_export (s_active_pages, s_new_page, s_close_page,
s_page_filename, s_page_contents, s_object_page, s_page_append_,
- s_page_remove_, NULL);
+ s_page_remove_, s_page_dirty, s_set_page_dirty, NULL);
}
/*!
commit c759a14672a1ee047c8d27f2d9c39339c88da18e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Closing pages.
Since it's possible to create new pages from the Scheme API, it's also
useful to be able to close them. This patch adds the close-page!
function to the (geda page) module.
It's necessary for gschem to provide a slightly different
implementation of close-page! which allows for the GUI to be updated
and for the user to be prompted to save changes. To do this, gschem
uses Guile module reflection to change the binding of the close-page!
function during startup.
diff --git a/gschem/scheme/gschem/window.scm b/gschem/scheme/gschem/window.scm
index b5fdc24..7023097 100644
--- a/gschem/scheme/gschem/window.scm
+++ b/gschem/scheme/gschem/window.scm
@@ -20,7 +20,10 @@
(define-module (gschem window)
; Import C procedures
- #:use-module (gschem core window))
+ #:use-module (gschem core window)
+
+ #:use-module (geda page)
+ #:re-export (close-page!))
(define-public active-page %active-page)
(define-public set-active-page! %set-active-page!)
diff --git a/gschem/src/g_window.c b/gschem/src/g_window.c
index c324808..e702739 100644
--- a/gschem/src/g_window.c
+++ b/gschem/src/g_window.c
@@ -172,7 +172,7 @@ SCM_DEFINE (active_page, "%active-page", 0, 0, 0,
* \note Scheme API: Implements the %set-active-page! procedure in the
* (gschem core window) module.
*
- * \param page_s
+ * \param page_s Page to switch to.
* \return \a page_s.
*/
SCM_DEFINE (set_active_page, "%set-active-page!", 1, 0, 0,
@@ -187,6 +187,48 @@ SCM_DEFINE (set_active_page, "%set-active-page!", 1, 0, 0,
}
/*!
+ * \brief Close a page
+ * \par Function Description
+ * Closes the page \a page_s.
+ *
+ * \note Scheme API: Implements the %close-page! procedure in the
+ * (gschem core window) module. Overrides the %close-page! procedure
+ * in the (geda core page) module.
+ *
+ * \param page_s Page to close.
+ * \return SCM_UNDEFINED
+ */
+SCM_DEFINE (close_page, "%close-page!", 1, 0, 0,
+ (SCM page_s), "Close a page.")
+{
+ /* Ensure that the argument is a page smob */
+ SCM_ASSERT (edascm_is_page (page_s), page_s,
+ SCM_ARG1, s_close_page);
+
+ GSCHEM_TOPLEVEL *w_current = g_current_window ();
+ TOPLEVEL *toplevel = w_current->toplevel;
+ PAGE *page = edascm_to_page (page_s);
+
+ /* If page is not the current page, switch pages, then switch back
+ * after closing page. */
+ PAGE *curr_page = toplevel->page_current;
+ int reset_page = (page != curr_page);
+ if (reset_page)
+ x_window_set_current_page (w_current, page);
+
+ if (w_current->toplevel->page_current->CHANGED) {
+ x_dialog_close_changed_page (w_current, w_current->toplevel->page_current);
+ } else {
+ x_window_close_page (w_current, w_current->toplevel->page_current);
+ }
+
+ if (reset_page)
+ x_window_set_current_page (w_current, curr_page);
+
+ return SCM_UNDEFINED;
+}
+
+/*!
* \brief Create the (gschem core window) Scheme module
* \par Function Description
* Defines procedures in the (gschem core window) module. The module
@@ -199,7 +241,15 @@ init_module_gschem_core_window ()
#include "g_window.x"
/* Add them to the module's public definitions. */
- scm_c_export (s_current_window, s_active_page, s_set_active_page, NULL);
+ scm_c_export (s_current_window, s_active_page, s_set_active_page, s_close_page,
+ NULL);
+
+ /* Override procedures in the (geda core page) module */
+ {
+ SCM geda_page_module = scm_c_resolve_module ("geda core page");
+ SCM close_page_proc = scm_variable_ref (scm_c_lookup (s_close_page));
+ scm_c_module_define (geda_page_module, s_close_page, close_page_proc);
+ }
}
/*!
diff --git a/libgeda/scheme/geda/page.scm b/libgeda/scheme/geda/page.scm
index c335f84..ffed74d 100644
--- a/libgeda/scheme/geda/page.scm
+++ b/libgeda/scheme/geda/page.scm
@@ -28,6 +28,7 @@
(define-public page? %page?)
(define-public active-pages %active-pages)
(define-public make-page %new-page)
+(define-public close-page! %close-page!)
(define-public page-filename %page-filename)
(define-public page-contents %page-contents)
(define-public page-append! %page-append!)
diff --git a/libgeda/scheme/unit-tests/t0020-page.scm b/libgeda/scheme/unit-tests/t0020-page.scm
index 2154375..c059cae 100644
--- a/libgeda/scheme/unit-tests/t0020-page.scm
+++ b/libgeda/scheme/unit-tests/t0020-page.scm
@@ -9,7 +9,10 @@
(let ((page-a (make-page "/test/page/A"))
(page-b (make-page "/test/page/B")))
(assert-equal "/test/page/A" (page-filename page-a))
- (assert-equal (list page-a page-b) (active-pages))))
+ (assert-equal (list page-a page-b) (active-pages))
+ (close-page! page-a)
+ (assert-equal (list page-b) (active-pages))
+ (close-page! page-b)))
(begin-test 'page-append
(let ((A (make-page "/test/page/C"))
@@ -17,24 +20,31 @@
(x (make-line '(0 . 0) '(1 . 2)))
(y (make-line '(0 . 1) '(2 . 2))))
- (assert-equal '() (page-contents A))
+ (dynamic-wind ; Make sure pages are cleaned up
+ (lambda () #f)
+ (lambda ()
+ (assert-equal '() (page-contents A))
- (assert-equal x (page-append! A x))
- (assert-equal (list x) (page-contents A))
+ (assert-equal x (page-append! A x))
+ (assert-equal (list x) (page-contents A))
- (assert-equal x (page-append! A x))
- (assert-equal (list x) (page-contents A))
+ (assert-equal x (page-append! A x))
+ (assert-equal (list x) (page-contents A))
- (assert-equal y (page-append! A y))
- (assert-equal (list x y) (page-contents A))
+ (assert-equal y (page-append! A y))
+ (assert-equal (list x y) (page-contents A))
- (assert-thrown 'object-state
- (page-append! B x))
+ (assert-thrown 'object-state
+ (page-append! B x))
- (assert-thrown 'object-state
- (let* ((C (make-component "test component" '(1 . 2) 0 #t #f))
- (z (component-append! C (make-line '(1 . 0) '(2 . 2)))))
- (page-append! A z)))))
+ (assert-thrown 'object-state
+ (let* ((C (make-component "test component" '(1 . 2) 0 #t #f))
+ (z (component-append! C (make-line '(1 . 0) '(2 . 2)))))
+ (page-append! A z))))
+
+ (lambda ()
+ (close-page! A)
+ (close-page! B)))))
(begin-test 'page-remove
(let ((A (make-page "/test/page/E"))
@@ -44,29 +54,27 @@
(y (make-line '(0 . 0) '(0 . 2)))
(z (make-line '(1 . 0) '(2 . 2))))
- (page-append! A x)
- (assert-equal x (page-remove! A x))
- (assert-equal '() (page-contents A))
- (assert-equal x (page-remove! A x))
- (assert-equal x (page-remove! B x))
-
- (page-append! A x)
- (page-append! A y)
- (assert-equal x (page-remove! A x))
- (assert-equal (list y) (page-contents A))
-
- (assert-thrown 'object-state
- (page-remove! B y))
-
- (component-append! C z)
- (assert-thrown 'object-state
- (page-remove! A z)) ))
-
-(begin-test 'page-remove-attrib
- (let ((page (make-page "/test/page/G"))
- (pin (make-net-pin '(0 . 0) '(100 . 0)))
- (attrib (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both)))
- (for-each (lambda (x) (page-append! page x)) (list pin attrib))
- (attach-attrib! pin attrib)
- (assert-thrown 'object-state (page-remove! page pin))
- (assert-thrown 'object-state (page-remove! page attrib))))
+ (dynamic-wind ; Make sure pages are cleaned up
+ (lambda () #f)
+ (lambda ()
+ (page-append! A x)
+ (assert-equal x (page-remove! A x))
+ (assert-equal '() (page-contents A))
+ (assert-equal x (page-remove! A x))
+ (assert-equal x (page-remove! B x))
+
+ (page-append! A x)
+ (page-append! A y)
+ (assert-equal x (page-remove! A x))
+ (assert-equal (list y) (page-contents A))
+
+ (assert-thrown 'object-state
+ (page-remove! B y))
+
+ (component-append! C z)
+ (assert-thrown 'object-state
+ (page-remove! A z)))
+
+ (lambda ()
+ (close-page! A)
+ (close-page! B)))))
diff --git a/libgeda/src/scheme_page.c b/libgeda/src/scheme_page.c
index c298c68..c255266 100644
--- a/libgeda/src/scheme_page.c
+++ b/libgeda/src/scheme_page.c
@@ -83,6 +83,34 @@ SCM_DEFINE (new_page, "%new-page", 1, 0, 0,
return edascm_from_page (page);
}
+/*! \brief Close a page
+ * \par Function Description
+
+ * Destroys the #PAGE structure \a page_s, freeing all of its
+ * resources. Attempting to use \a page_s after calling this function
+ * will cause an error.
+ *
+ * \note Scheme API: Implements the %close-page procedure of the (geda
+ * core page) module.
+ *
+ * \param page_s The page to close.
+ * \return SCM_UNDEFINED.
+ */
+SCM_DEFINE (close_page, "%close-page!", 1, 0, 0,
+ (SCM page_s), "Close a page.")
+{
+ /* Ensure that the argument is a page smob */
+ SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
+ SCM_ARG1, s_close_page);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ PAGE *page = edascm_to_page (page_s);
+
+ s_page_delete (toplevel, page);
+
+ return SCM_UNDEFINED;
+}
+
/*! \brief Get the filename associated with a page.
* \par Function Description
* Retrieves the filename associated with the #PAGE smob \a page_s.
@@ -277,8 +305,9 @@ init_module_geda_core_page ()
/* Add them to the module's public definitions. */
- scm_c_export (s_active_pages, s_new_page, s_page_filename, s_page_contents,
- s_object_page, s_page_append_, s_page_remove_, NULL);
+ scm_c_export (s_active_pages, s_new_page, s_close_page,
+ s_page_filename, s_page_contents, s_object_page, s_page_append_,
+ s_page_remove_, NULL);
}
/*!
commit 5d9ca02072ba4309352e39d209f252142a96e0af
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Translate primitive objects in %complex-set!
%complex-set! needs to translate the primitive objects that make up a
complex when its position changes.
diff --git a/libgeda/scheme/unit-tests/t0015-object-complex.scm b/libgeda/scheme/unit-tests/t0015-object-complex.scm
index 1ac9c49..849dbc1 100644
--- a/libgeda/scheme/unit-tests/t0015-object-complex.scm
+++ b/libgeda/scheme/unit-tests/t0015-object-complex.scm
@@ -85,6 +85,14 @@
(component-remove! A z))
))
+(begin-test 'component-translate
+ (let* ((A (make-component "test component" '(0 . 0) 0 #t #f))
+ (x (component-append! A (make-box '(0 . 2) '(2 . 0)))))
+
+ (set-component! A '(1 . 1) 0 #t #f)
+ (assert-equal '(1 . 3) (box-top-left x))
+ (assert-equal '(3 . 1) (box-bottom-right x))))
+
(begin-test 'component-remove-attrib
(let ((comp (make-component "test component" '(1 . 2) 0 #t #f))
(pin (make-net-pin '(0 . 0) '(100 . 0)))
diff --git a/libgeda/src/scheme_complex.c b/libgeda/src/scheme_complex.c
index a6ee505..c507e77 100644
--- a/libgeda/src/scheme_complex.c
+++ b/libgeda/src/scheme_complex.c
@@ -151,8 +151,12 @@ SCM_DEFINE (set_complex, "%set-complex!", 6, 0, 0,
o_emit_pre_change_notify (toplevel, obj);
- obj->complex->x = scm_to_int (x_s);
- obj->complex->y = scm_to_int (y_s);
+ int x = scm_to_int (x_s);
+ int y = scm_to_int (y_s);
+ o_translate_world (toplevel,
+ x - obj->complex->x,
+ y - obj->complex->y,
+ obj);
obj->complex->angle = angle;
obj->complex->mirror = scm_is_true (mirror_s);
obj->sel_func = scm_is_true (locked_s) ? NULL : select_func;
commit ee046f0a7c277d65ecb9edad6de5aeac0b81ba52
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Create components from the component library.
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 6cd95ca..4cf1135 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -549,6 +549,17 @@
(let ((c (%make-complex basename)))
(apply set-component! c args)))
+;; make-component/library basename position angle mirror locked
+;;
+;; Make a new component object by searching the component library for
+;; the given basename, and instatiate it with the given parameters.
+;; See set-component! for full description of arguments. Returns #f
+;; if basename was not found in the component library. The component
+;; is not initially embedded.
+(define-public (make-component/library basename . args)
+ (let ((c (%make-complex/library basename)))
+ (if c (apply set-component! c args) #f)))
+
;; component-info c
;;
;; Returns the parameters of the component object c as a list of the
diff --git a/libgeda/scheme/unit-tests/t0015-object-complex.scm b/libgeda/scheme/unit-tests/t0015-object-complex.scm
index 6c200c1..1ac9c49 100644
--- a/libgeda/scheme/unit-tests/t0015-object-complex.scm
+++ b/libgeda/scheme/unit-tests/t0015-object-complex.scm
@@ -93,3 +93,27 @@
(attach-attrib! pin attrib)
(assert-thrown 'object-state (component-remove! comp pin))
(assert-thrown 'object-state (component-remove! comp attrib))))
+
+
+;; Set up component library, making blatant assumptions about the
+;; directory layout.
+(component-library "../../symbols/analog" "Basic devices")
+
+(begin-test 'component/library
+ (let ((A (make-component/library "resistor-1.sym" '(1 . 2) 0 #t #f))
+ (B (make-component/library "invalid-component-name" '(1 . 2) 0 #t #f)))
+
+ (assert-true A)
+ (assert-equal '(1 . 2) (component-position A))
+ (assert-equal 0 (component-angle A))
+ (assert-true (component-mirror? A))
+ (assert-true (not (component-locked? A)))
+
+ (assert-equal "resistor-1.sym" (component-basename A))
+
+ (assert-true (not (null? (component-contents A))))
+
+ (assert-true (not B))))
+
+;; Clear component library again
+(reset-component-library)
diff --git a/libgeda/src/scheme_complex.c b/libgeda/src/scheme_complex.c
index ec3f7ba..a6ee505 100644
--- a/libgeda/src/scheme_complex.c
+++ b/libgeda/src/scheme_complex.c
@@ -58,6 +58,51 @@ SCM_DEFINE (make_complex, "%make-complex", 1, 0, 0,
return result;
}
+/*! \brief Instantiate a complex object from the component library.
+ * \par Function Description
+
+ * Searches the component library for a component with the given \a
+ * basename. If found, creates a new complex object by instantiating
+ * that library component. It is initially set to be unembedded. If
+ * no match is found for \a basename in the library, returns
+ * SCM_BOOL_F.
+ *
+ * \note Scheme API: Implements the %make-complex/library procedure in
+ * the (geda core complex) module.
+ *
+ * \param basename component name to search for in the component
+ * library.
+ * \return a newly-created complex object.
+ */
+SCM_DEFINE (make_complex_library, "%make-complex/library", 1, 0, 0,
+ (SCM basename_s),
+ "Instantiate a complex object from the component library.")
+{
+ SCM_ASSERT (scm_is_string (basename_s), basename_s, SCM_ARG1,
+ s_make_complex_library);
+
+ char *basename = scm_to_locale_string (basename_s);
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (free, basename, SCM_F_WIND_EXPLICITLY);
+
+ SCM result = SCM_BOOL_F;
+ const CLibSymbol *clib = s_clib_get_symbol_by_name (basename);
+ if (clib != NULL) {
+ OBJECT *obj = o_complex_new (edascm_c_current_toplevel (),
+ OBJ_COMPLEX, DEFAULT_COLOR, 0, 0, 0,
+ FALSE, clib, basename, TRUE);
+
+ result = edascm_from_object (obj);
+
+ /* At the moment, the only pointer to the object is owned by the
+ * smob. */
+ edascm_c_set_gc (result, TRUE);
+ }
+
+ scm_dynwind_end ();
+ return result;
+}
+
/*! \brief Set complex object parameters.
* \par Function Description
* Modifies the complex object \a complex_s by setting its parameters
@@ -313,9 +358,9 @@ init_module_geda_core_complex ()
#include "scheme_complex.x"
/* Add them to the module's public definitions. */
- scm_c_export (s_make_complex, s_set_complex, s_complex_info,
- s_complex_contents, s_complex_append, s_complex_remove,
- NULL);
+ scm_c_export (s_make_complex, s_make_complex_library, s_set_complex,
+ s_complex_info, s_complex_contents, s_complex_append,
+ s_complex_remove, NULL);
}
/*!
commit dbfcf03ba08226b6c752f57006a3e2cde7ffcde8
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Remove some Guile 1.4/1.6 compatibility code.
diff --git a/gschem/scheme/gschem.scm b/gschem/scheme/gschem.scm
index fbe0bfd..7ca8336 100644
--- a/gschem/scheme/gschem.scm
+++ b/gschem/scheme/gschem.scm
@@ -17,14 +17,7 @@
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-; guile 1.4/1.6 compatibility: Define an eval-in-currentmodule procedure
-; If this version of guile has an R5RS-compatible eval (that requires a
-; second argument specfying the environment), and a current-module function
-; (like 1.6) use them to define eval-cm. else define eval-cm to eval (for 1.4)
-(if (false-if-exception (eval 'display (current-module)))
- (define (eval-cm exp) (eval exp (current-module)))
- (define eval-cm eval))
+(define (eval-cm exp) (eval exp (current-module)))
(define last-command-sequence #f)
(define current-command-sequence '())
commit 275740ab72ae6fd9ab2ddcc024181d1c3330064d
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Retrieve and change the current gschem page.
diff --git a/gschem/scheme/Makefile.am b/gschem/scheme/Makefile.am
index ee4f1f2..6e3e0b4 100644
--- a/gschem/scheme/Makefile.am
+++ b/gschem/scheme/Makefile.am
@@ -1,11 +1,16 @@
## -*- Makefile -*-
scmdatadir = $(GEDADATADIR)/scheme
-scmdata_DATA = auto-uref.scm generate_netlist.scm gschem.scm list-keys.scm \
- print-NB-attribs.scm auto-place-attribs.scm pcb.scm \
- default-attrib-positions.scm
-
-EXTRA_DIST = $(scmdata_DATA)
+nobase_dist_scmdata_DATA = \
+ auto-uref.scm \
+ generate_netlist.scm \
+ gschem.scm \
+ list-keys.scm \
+ print-NB-attribs.scm \
+ auto-place-attribs.scm \
+ pcb.scm \
+ default-attrib-positions.scm \
+ gschem/window.scm
MOSTLYCLEANFILES = *.log *~
CLEANFILES = *.log *~
diff --git a/gschem/scheme/gschem/window.scm b/gschem/scheme/gschem/window.scm
new file mode 100644
index 0000000..b5fdc24
--- /dev/null
+++ b/gschem/scheme/gschem/window.scm
@@ -0,0 +1,26 @@
+;; gEDA - GPL Electronic Design Automation
+;; libgeda - gEDA's library - Scheme API
+;; Copyright (C) 2010 Peter Brett
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+;;
+
+(define-module (gschem window)
+
+ ; Import C procedures
+ #:use-module (gschem core window))
+
+(define-public active-page %active-page)
+(define-public set-active-page! %set-active-page!)
diff --git a/gschem/src/g_window.c b/gschem/src/g_window.c
index 46e6d6c..c324808 100644
--- a/gschem/src/g_window.c
+++ b/gschem/src/g_window.c
@@ -114,7 +114,7 @@ g_dynwind_window (GSCHEM_TOPLEVEL *w_current)
* Return the value of the #GSCHEM_TOPLEVEL fluid in the current
* dynamic context.
*/
-SCM_DEFINE (g_scm_current_window, "%current-window", 0, 0, 0,
+SCM_DEFINE (current_window, "%current-window", 0, 0, 0,
(),
"Get the GSCHEM_TOPLEVEL for the current dynamic context.")
{
@@ -130,7 +130,7 @@ SCM_DEFINE (g_scm_current_window, "%current-window", 0, 0, 0,
GSCHEM_TOPLEVEL *
g_current_window ()
{
- SCM window_s = g_scm_current_window ();
+ SCM window_s = current_window ();
if (!(SCM_SMOB_PREDICATE (window_smob_tag, window_s)
&& ((void *)SCM_SMOB_DATA (window_s) != NULL))) {
@@ -142,6 +142,51 @@ g_current_window ()
}
/*!
+ * \brief Get the active page.
+ * \par Function Description
+ * Returns the page which is active in the current gschem window. If
+ * there is no active page, returns SCM_BOOL_F.
+ *
+ * \note Scheme API: Implements the %active-page procedure in the
+ * (gschem core window) module.
+ *
+ * \return the active page.
+ */
+SCM_DEFINE (active_page, "%active-page", 0, 0, 0,
+ (), "Get the active page.")
+{
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ if (toplevel->page_current != NULL) {
+ return edascm_from_page (toplevel->page_current);
+ } else {
+ return SCM_BOOL_F;
+ }
+}
+
+/*!
+ * \brief Set the active page.
+ * \par Function Description
+ * Sets the page which is active in the current gschem window to \a
+ * page_s.
+ *
+ * \note Scheme API: Implements the %set-active-page! procedure in the
+ * (gschem core window) module.
+ *
+ * \param page_s
+ * \return \a page_s.
+ */
+SCM_DEFINE (set_active_page, "%set-active-page!", 1, 0, 0,
+ (SCM page_s), "Set the active page.")
+{
+ SCM_ASSERT (edascm_is_page (page_s), page_s, SCM_ARG1, s_set_active_page);
+
+ PAGE *page = edascm_to_page (page_s);
+ x_window_set_current_page (g_current_window (), page);
+
+ return page_s;
+}
+
+/*!
* \brief Create the (gschem core window) Scheme module
* \par Function Description
* Defines procedures in the (gschem core window) module. The module
@@ -154,7 +199,7 @@ init_module_gschem_core_window ()
#include "g_window.x"
/* Add them to the module's public definitions. */
- scm_c_export (s_g_scm_current_window, NULL);
+ scm_c_export (s_current_window, s_active_page, s_set_active_page, NULL);
}
/*!
commit 2cd6cf4922ef828ed8bbb2d409d0e40b04f7d8ff
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Remove global_window_current.
Instead, use the GSCHEM_TOPLEVEL fluid (accessed via
g_current_toplevel()). Although this does indeed remove one magic
global variable in favour of another, the fluid has the advantage of
coping correctly with non-local exits, and is more clearly only for
the benefit of procedures that are called via Scheme.
diff --git a/gschem/include/globals.h b/gschem/include/globals.h
index 8fbeb75..d3689ab 100644
--- a/gschem/include/globals.h
+++ b/gschem/include/globals.h
@@ -21,8 +21,6 @@
#ifndef H_GSCHEM_GLOBALS_H
#define H_GSCHEM_GLOBALS_H
-/* used by various guile functions, set in x_event* functions */
-extern GSCHEM_TOPLEVEL *global_window_current;
/* window list */
extern GList *global_window_list;
diff --git a/gschem/src/g_funcs.c b/gschem/src/g_funcs.c
index d2035ab..894753b 100644
--- a/gschem/src/g_funcs.c
+++ b/gschem/src/g_funcs.c
@@ -33,6 +33,7 @@
#endif
#include "gschem.h"
+#include <libgeda/libgedaguile.h>
#ifdef HAVE_LIBDMALLOC
#include <dmalloc.h>
@@ -45,7 +46,7 @@
*/
SCM g_funcs_print(SCM filename)
{
- TOPLEVEL *toplevel = global_window_current->toplevel;
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
SCM_ASSERT (scm_is_string (filename), filename,
SCM_ARG1, "gschem-print");
@@ -70,7 +71,7 @@ SCM g_funcs_print(SCM filename)
*/
SCM g_funcs_postscript(SCM filename)
{
- TOPLEVEL *toplevel = global_window_current->toplevel;
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
SCM_ASSERT (scm_is_string (filename), filename,
SCM_ARG1, "gschem-postscript");
@@ -98,15 +99,17 @@ SCM g_funcs_image(SCM filename)
SCM_ASSERT (scm_is_string (filename), filename,
SCM_ARG1, "gschem-image");
+ GSCHEM_TOPLEVEL *w_current = g_current_window ();
+
if (output_filename) {
- x_image_lowlevel (global_window_current, output_filename,
- global_window_current->image_width,
- global_window_current->image_height,
+ x_image_lowlevel (w_current, output_filename,
+ w_current->image_width,
+ w_current->image_height,
g_strdup("png"));
} else {
- x_image_lowlevel (global_window_current, SCM_STRING_CHARS (filename),
- global_window_current->image_width,
- global_window_current->image_height,
+ x_image_lowlevel (w_current, SCM_STRING_CHARS (filename),
+ w_current->image_width,
+ w_current->image_height,
g_strdup("png"));
}
@@ -237,7 +240,7 @@ SCM g_funcs_filesel(SCM msg, SCM templ, SCM flags)
*/
SCM g_funcs_use_rc_values(void)
{
- i_vars_set(global_window_current);
+ i_vars_set(g_current_window ());
return SCM_BOOL_T;
}
diff --git a/gschem/src/g_hook.c b/gschem/src/g_hook.c
index d75baf4..a979255 100644
--- a/gschem/src/g_hook.c
+++ b/gschem/src/g_hook.c
@@ -25,6 +25,7 @@
#include <math.h>
#include "gschem.h"
+#include <libgeda/libgedaguile.h>
#ifdef HAVE_LIBDMALLOC
#include <dmalloc.h>
@@ -103,7 +104,7 @@ SCM g_set_attrib_value_x(SCM attrib_smob, SCM scm_value)
returned = g_set_attrib_value_internal(attrib_smob, scm_value,
&toplevel, &o_attrib, &new_string);
- o_text_change(global_window_current, o_attrib, new_string,
+ o_text_change(g_current_window (), o_attrib, new_string,
o_attrib->visibility, o_attrib->show_name_value);
g_free(new_string);
@@ -127,7 +128,7 @@ The return value is always TRUE.
SCM g_add_attrib(SCM object, SCM scm_attrib_name,
SCM scm_attrib_value, SCM scm_vis, SCM scm_show)
{
- GSCHEM_TOPLEVEL *w_current=global_window_current;
+ GSCHEM_TOPLEVEL *w_current = g_current_window ();
TOPLEVEL *toplevel = w_current->toplevel;
OBJECT *o_current=NULL;
gboolean vis;
@@ -271,7 +272,7 @@ SCM g_set_attrib_text_properties(SCM attrib_smob, SCM scm_coloridx,
struct st_attrib_smob *attribute =
(struct st_attrib_smob *)SCM_CDR(attrib_smob);
OBJECT *object;
- GSCHEM_TOPLEVEL *w_current = global_window_current;
+ GSCHEM_TOPLEVEL *w_current = g_current_window ();
TOPLEVEL *toplevel = w_current->toplevel;
int color = -1;
@@ -750,6 +751,6 @@ SCM g_get_objects_in_page(SCM page_smob) {
SCM g_get_current_page(void)
{
- return (g_make_page_smob(global_window_current->toplevel,
- global_window_current->toplevel->page_current));
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ return (g_make_page_smob(toplevel, toplevel->page_current));
}
diff --git a/gschem/src/g_keys.c b/gschem/src/g_keys.c
index 0a3331f..ba05a20 100644
--- a/gschem/src/g_keys.c
+++ b/gschem/src/g_keys.c
@@ -188,8 +188,9 @@ static gboolean clear_keyaccel_string(gpointer data)
#define DEFINE_G_KEYS(name) \
SCM g_keys_ ## name(SCM rest) \
{ \
- g_timeout_add(400, clear_keyaccel_string, global_window_current); \
- i_callback_ ## name(global_window_current, 0, NULL); \
+ GSCHEM_TOPLEVEL *w_current = g_current_window (); \
+ g_timeout_add(400, clear_keyaccel_string, w_current); \
+ i_callback_ ## name(w_current, 0, NULL); \
return SCM_BOOL_T; \
}
@@ -388,7 +389,7 @@ DEFINE_G_KEYS(cancel)
/*help for generate-netlist hot key*/
SCM g_get_selected_filename(void)
{
- return (get_selected_filename(global_window_current));
+ return (get_selected_filename(g_current_window ()));
}
/*! \todo Finish function documentation!!!
@@ -398,5 +399,5 @@ SCM g_get_selected_filename(void)
*/
SCM g_get_selected_component_attributes(void)
{
- return (get_selected_component_attributes(global_window_current));
+ return (get_selected_component_attributes(g_current_window ()));
}
diff --git a/gschem/src/globals.c b/gschem/src/globals.c
index e11a110..b7c86b5 100644
--- a/gschem/src/globals.c
+++ b/gschem/src/globals.c
@@ -29,10 +29,6 @@
#include <dmalloc.h>
#endif
-/* this is needed since guile scripts only deal with the current
- * window set in x_event* functions */
-GSCHEM_TOPLEVEL *global_window_current = NULL;
-
/* window list */
GList *global_window_list = NULL;
diff --git a/gschem/src/gschem.c b/gschem/src/gschem.c
index 0f0ee8d..4c33137 100644
--- a/gschem/src/gschem.c
+++ b/gschem/src/gschem.c
@@ -225,7 +225,6 @@ void main_prog(void *closure, int argc, char *argv[])
/* Allocate w_current */
w_current = gschem_toplevel_new ();
w_current->toplevel = s_toplevel_new ();
- global_window_current = w_current;
w_current->toplevel->load_newer_backup_func = x_fileselect_load_backup;
w_current->toplevel->load_newer_backup_data = w_current;
@@ -238,6 +237,9 @@ void main_prog(void *closure, int argc, char *argv[])
(ChangeNotifyFunc) o_invalidate,
(ChangeNotifyFunc) o_invalidate, w_current);
+ scm_dynwind_begin (0);
+ g_dynwind_window (w_current);
+
/* Now read in RC files. */
g_rc_parse_gtkrc();
g_rc_parse(w_current->toplevel, "gschemrc", rc_filename);
@@ -335,7 +337,9 @@ void main_prog(void *closure, int argc, char *argv[])
/* if there were any symbols which had major changes, put up an error */
/* dialog box */
major_changed_dialog(w_current);
-
+
+ scm_dynwind_end ();
+
/* enter main loop */
gtk_main();
}
diff --git a/gschem/src/x_event.c b/gschem/src/x_event.c
index dfb4ffa..d081323 100644
--- a/gschem/src/x_event.c
+++ b/gschem/src/x_event.c
@@ -60,8 +60,6 @@ gint x_event_expose(GtkWidget *widget, GdkEventExpose *event,
#endif
exit_if_null(w_current);
- /* nasty global variable */
- global_window_current = w_current;
save_cr = w_current->cr;
save_pl = w_current->pl;
@@ -101,7 +99,6 @@ gint x_event_button_pressed(GtkWidget *widget, GdkEventButton *event,
int unsnapped_wx, unsnapped_wy;
exit_if_null(w_current);
- global_window_current = w_current;
#if DEBUG
printf("pressed button %d! \n", event->button);
@@ -132,6 +129,12 @@ gint x_event_button_pressed(GtkWidget *widget, GdkEventButton *event,
w_current->CONTROLKEY = (event->state & GDK_CONTROL_MASK) ? 1 : 0;
w_current->ALTKEY = (event->state & GDK_MOD1_MASK) ? 1 : 0;
+ /* Huge switch statement to evaluate state transitions. Jump to
+ * end_button_pressed label to escape the state evaluation rather than
+ * returning from the function directly. */
+ scm_dynwind_begin (0);
+ g_dynwind_window (w_current);
+
if (event->button == 1) {
switch(w_current->event_state) {
@@ -353,17 +356,15 @@ gint x_event_button_pressed(GtkWidget *widget, GdkEventButton *event,
/* try this out and see how it behaves */
if (w_current->inside_action) {
- if (w_current->event_state == ENDCOMP ||
- w_current->event_state == ENDTEXT ||
- w_current->event_state == ENDMOVE ||
- w_current->event_state == ENDCOPY ||
- w_current->event_state == ENDMCOPY ||
- w_current->event_state == ENDPASTE ) {
- return(0);
- } else {
- i_callback_cancel(w_current, 0, NULL);
- return(0);
- }
+ if (!(w_current->event_state == ENDCOMP ||
+ w_current->event_state == ENDTEXT ||
+ w_current->event_state == ENDMOVE ||
+ w_current->event_state == ENDCOPY ||
+ w_current->event_state == ENDMCOPY ||
+ w_current->event_state == ENDPASTE )) {
+ i_callback_cancel(w_current, 0, NULL);
+ }
+ goto end_button_pressed;
}
switch(w_current->middle_button) {
@@ -394,7 +395,7 @@ gint x_event_button_pressed(GtkWidget *widget, GdkEventButton *event,
w_current->inside_action = 0;
i_set_state(w_current, SELECT);
i_update_toolbar(w_current);
- return(0);
+ goto end_button_pressed;
}
if (w_current->ALTKEY) {
@@ -510,6 +511,10 @@ gint x_event_button_pressed(GtkWidget *widget, GdkEventButton *event,
i_update_toolbar(w_current);
}
}
+
+ end_button_pressed:
+ scm_dynwind_end ();
+
return(0);
}
@@ -527,7 +532,6 @@ gint x_event_button_released(GtkWidget *widget, GdkEventButton *event,
int unsnapped_wx, unsnapped_wy;
exit_if_null(w_current);
- global_window_current = w_current;
#if DEBUG
printf("released! %d \n", w_current->event_state);
@@ -542,6 +546,12 @@ gint x_event_button_released(GtkWidget *widget, GdkEventButton *event,
w_x = snap_grid (w_current, unsnapped_wx);
w_y = snap_grid (w_current, unsnapped_wy);
+ /* Huge switch statement to evaluate state transitions. Jump to
+ * end_button_released label to escape the state evaluation rather
+ * than returning from the function directly. */
+ scm_dynwind_begin (0);
+ g_dynwind_window (w_current);
+
if (event->button == 1) {
switch(w_current->event_state) {
case(SELECT):
@@ -653,7 +663,7 @@ gint x_event_button_released(GtkWidget *widget, GdkEventButton *event,
o_place_invalidate_rubber (w_current, TRUE);
}
w_current->rubber_visible = 1;
- return(0);
+ goto end_button_released;
}
}
@@ -714,6 +724,9 @@ gint x_event_button_released(GtkWidget *widget, GdkEventButton *event,
i_update_toolbar(w_current);
}
}
+ end_button_released:
+ scm_dynwind_end ();
+
return(0);
}
@@ -732,7 +745,6 @@ gint x_event_motion(GtkWidget *widget, GdkEventMotion *event,
GdkEvent *test_event;
exit_if_null(w_current);
- global_window_current = w_current;
w_current->SHIFTKEY = (event->state & GDK_SHIFT_MASK ) ? 1 : 0;
w_current->CONTROLKEY = (event->state & GDK_CONTROL_MASK) ? 1 : 0;
@@ -772,7 +784,6 @@ gint x_event_motion(GtkWidget *widget, GdkEventMotion *event,
if (w_current->cowindow) {
coord_display_update(w_current, (int) event->x, (int) event->y);
}
-
if (w_current->third_button == MOUSEPAN_ENABLED || w_current->middle_button == MID_MOUSEPAN_ENABLED) {
if((w_current->event_state == MOUSEPAN) &&
w_current->inside_action) {
@@ -791,6 +802,12 @@ gint x_event_motion(GtkWidget *widget, GdkEventMotion *event,
}
}
+ /* Huge switch statement to evaluate state transitions. Jump to
+ * end_motion label to escape the state evaluation rather
+ * than returning from the function directly. */
+ scm_dynwind_begin (0);
+ g_dynwind_window (w_current);
+
switch(w_current->event_state) {
case(SELECT):
@@ -894,6 +911,10 @@ gint x_event_motion(GtkWidget *widget, GdkEventMotion *event,
break;
}
+
+ end_motion:
+ scm_dynwind_end ();
+
return(0);
}
@@ -928,7 +949,6 @@ x_event_configure (GtkWidget *widget,
gdouble relativ_zoom_factor = 1.0;
g_assert (toplevel != NULL);
- global_window_current = w_current;
if (toplevel->page_current == NULL) {
/* don't want to call this if the current page isn't setup yet */
@@ -1052,7 +1072,6 @@ void x_event_hschanged (GtkAdjustment *adj, GSCHEM_TOPLEVEL *w_current)
GtkAdjustment *hadjustment;
exit_if_null(w_current);
- global_window_current = w_current;
if (w_current->scrollbars_flag == FALSE) {
return;
@@ -1087,7 +1106,6 @@ void x_event_vschanged (GtkAdjustment *adj, GSCHEM_TOPLEVEL *w_current)
GtkAdjustment *vadjustment;
exit_if_null(w_current);
- global_window_current = w_current;
if (w_current->scrollbars_flag == FALSE) {
return;
@@ -1125,7 +1143,6 @@ gint x_event_enter(GtkWidget *widget, GdkEventCrossing *event,
GSCHEM_TOPLEVEL *w_current)
{
exit_if_null(w_current);
- global_window_current = w_current;
/* do nothing or now */
return(0);
}
@@ -1166,8 +1183,6 @@ gboolean x_event_key (GtkWidget *widget, GdkEventKey *event,
int control_key = 0;
int pressed;
- global_window_current = w_current;
-
#if DEBUG
printf("x_event_key_pressed: Pressed key %i.\n", event->keyval);
#endif
@@ -1199,6 +1214,13 @@ gboolean x_event_key (GtkWidget *widget, GdkEventKey *event,
break;
}
+
+ /* Huge switch statement to evaluate state transitions. Jump to
+ * end_key label to escape the state evaluation rather
+ * than returning from the function directly. */
+ scm_dynwind_begin (0);
+ g_dynwind_window (w_current);
+
switch (w_current->event_state) {
case ENDLINE:
if (control_key) {
@@ -1248,6 +1270,8 @@ gboolean x_event_key (GtkWidget *widget, GdkEventKey *event,
retval = g_keys_execute (w_current, event->state, event->keyval)
? TRUE : FALSE;
+ scm_dynwind_end ();
+
return retval;
}
@@ -1268,7 +1292,6 @@ gint x_event_scroll (GtkWidget *widget, GdkEventScroll *event,
int zoom_direction = ZOOM_IN;
exit_if_null(w_current);
- global_window_current = w_current;
/* update the state of the modifiers */
w_current->SHIFTKEY = (event->state & GDK_SHIFT_MASK ) ? 1 : 0;
diff --git a/gschem/src/x_stroke.c b/gschem/src/x_stroke.c
index 6dc3762..b56cd95 100644
--- a/gschem/src/x_stroke.c
+++ b/gschem/src/x_stroke.c
@@ -159,11 +159,10 @@ x_stroke_translate_and_execute (GSCHEM_TOPLEVEL *w_current)
g_strdup_printf("(eval-stroke \"%s\")", sequence);
SCM ret;
- SCHEME_WINDOW_PUSH(w_current);
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (g_free, guile_string, SCM_F_WIND_EXPLICITLY);
ret = g_scm_c_eval_string_protected (guile_string);
- SCHEME_WINDOW_POP(w_current);
-
- g_free (guile_string);
+ scm_dynwind_end ();
return (SCM_NFALSEP (ret));
}
commit c51711b32a5673b6ee3f18d5160c9c4e16d15b5e
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gschem: Add a fluid for current GSCHEM_TOPLEVEL.
Adds a smob that represents a gschem window structure, and a Guile
fluid that tracks the active window and that can be accessed from
Scheme code. The functions which update the fluid also ensure that
the libgeda TOPLEVEL fluid is updated in lockstep. This ensures that
Scheme code that is not gschem-aware will run correctly in gschem, and
will allow the global_window_current variable to be removed.
diff --git a/gschem/include/gschem_struct.h b/gschem/include/gschem_struct.h
index c4754cf..8bd372f 100644
--- a/gschem/include/gschem_struct.h
+++ b/gschem/include/gschem_struct.h
@@ -209,6 +209,8 @@ struct st_gschem_toplevel {
int scrollpan_steps; /* Number of scroll pan events required to traverse the viewed area */
char *print_command; /* The command to send postscript to when printing */
+
+ SCM smob; /* The Scheme representation of this window */
};
diff --git a/gschem/include/prototype.h b/gschem/include/prototype.h
index 5948c74..19f5f80 100644
--- a/gschem/include/prototype.h
+++ b/gschem/include/prototype.h
@@ -2,6 +2,7 @@
/* gschem_toplevel.c */
GSCHEM_TOPLEVEL *gschem_toplevel_new();
+
/* a_pan.c */
void a_pan_general(GSCHEM_TOPLEVEL *w_current, double world_cx, double world_cy,
double relativ_zoom_factor, int flags);
@@ -277,6 +278,10 @@ SCM g_rc_display_color_map (SCM scm_map);
SCM g_rc_display_outline_color_map (SCM scm_map);
/* g_register.c */
void g_register_funcs(void);
+/* g_window.c */
+GSCHEM_TOPLEVEL *g_current_window ();
+void g_dynwind_window (GSCHEM_TOPLEVEL *w_current);
+void g_init_window ();
/* globals.c */
/* gschem.c */
typedef void (*gschem_atexit_func)(gpointer data);
diff --git a/gschem/src/.gitignore b/gschem/src/.gitignore
index dd7d0b6..a1a4506 100644
--- a/gschem/src/.gitignore
+++ b/gschem/src/.gitignore
@@ -4,5 +4,6 @@ Makefile.in
gschem
gschem.exe
*.o
+*.x
*~
TAGS
diff --git a/gschem/src/Makefile.am b/gschem/src/Makefile.am
index 4e04085..f858c55 100644
--- a/gschem/src/Makefile.am
+++ b/gschem/src/Makefile.am
@@ -1,5 +1,8 @@
bin_PROGRAMS = gschem
+BUILT_SOURCES = \
+ g_window.x
+
gschem_SOURCES = \
a_pan.c \
a_zoom.c \
@@ -8,6 +11,7 @@ gschem_SOURCES = \
g_keys.c \
g_rc.c \
g_register.c \
+ g_window.c \
globals.c \
gschem.c \
gschem_accel_label.c \
@@ -77,6 +81,15 @@ gschem_LDFLAGS = $(LIBSTROKE_LDFLAGS) $(GLIB_LIBS) $(GTK_LIBS) \
$(GTHREAD_LIBS) $(GUILE_LIBS) $(MINGW_GUI_LDFLAGS)
gschem_LDADD = $(top_builddir)/libgeda/src/libgeda.la @LIBINTL@
+
+# This is used to generate boilerplate for defining Scheme functions
+# in C.
+SUFFIXES = .x
+snarf_cpp_opts = $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
+ $(gschem_CPPFLAGS) $(AM_CFLAGS) $(gschem_CFLAGS)
+.c.x:
+ $(GUILE_SNARF) -o $@ $< $(snarf_cpp_opts)
+
localedir = @datadir@/locale
DEFS = -DLOCALEDIR=\"$(localedir)\" @DEFS@
diff --git a/gschem/src/g_keys.c b/gschem/src/g_keys.c
index 67c46be..0a3331f 100644
--- a/gschem/src/g_keys.c
+++ b/gschem/src/g_keys.c
@@ -104,9 +104,13 @@ int g_keys_execute(GSCHEM_TOPLEVEL *w_current, int state, int keyval)
#if DEBUG
printf("_%s_\n", guile_string);
#endif
+
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (g_free, guile_string, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (g_free, modifier, SCM_F_WIND_EXPLICITLY);
+ g_dynwind_window (w_current);
scm_retval = g_scm_c_eval_string_protected (guile_string);
- g_free(guile_string);
- g_free(modifier);
+ scm_dynwind_end ();
return (SCM_FALSEP (scm_retval)) ? 0 : 1;
}
diff --git a/gschem/src/g_window.c b/gschem/src/g_window.c
new file mode 100644
index 0000000..46e6d6c
--- /dev/null
+++ b/gschem/src/g_window.c
@@ -0,0 +1,183 @@
+/* gEDA - GPL Electronic Design Automation
+ * gschem - gEDA Schematic Capture
+ * Copyright (C) 2010 Peter Brett
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+ */
+#include <config.h>
+
+#include "gschem.h"
+#include <libgeda/libgedaguile.h>
+
+SCM scheme_window_fluid = SCM_UNDEFINED;
+
+scm_t_bits window_smob_tag;
+
+/*! \brief Free a #GSCHEM_TOPLEVEL smob.
+ * \par Function Description
+ * Finalizes a window smob for deletion.
+ *
+ * Used internally to Guile
+ */
+static size_t
+smob_free (SCM smob)
+{
+ GSCHEM_TOPLEVEL *window = (GSCHEM_TOPLEVEL *) SCM_SMOB_DATA (smob);
+
+ /* If the weak ref has been cleared, do nothing */
+ if (window == NULL) return 0;
+
+ /* Otherwise, go away. */
+ window->smob = SCM_UNDEFINED;
+
+ return 0;
+}
+
+/*! \brief Print a representation of a #GSCHEM_TOPLEVEL smob.
+ * \par Function Description
+ * Outputs a string representing the \a smob to a Scheme output
+ * \a port. The format used is "#<gschem-window b7ef65d0>".
+ *
+ * Used internally to Guile.
+ */
+static int
+smob_print (SCM smob, SCM port, scm_print_state *pstate)
+{
+ gchar *hexstring;
+
+ scm_puts ("#<gschem-window", port);
+
+ scm_dynwind_begin (0);
+ hexstring = g_strdup_printf (" %zx", SCM_SMOB_DATA (smob));
+ scm_dynwind_unwind_handler (g_free, hexstring, SCM_F_WIND_EXPLICITLY);
+ scm_puts (hexstring, port);
+ scm_dynwind_end ();
+
+ scm_puts (">", port);
+
+ /* Non-zero means success */
+ return 1;
+}
+
+/*! \brief Get the smob for a #GSCHEM_TOPLEVEL.
+ * \par Function Description
+ * Return a smob representing \a window.
+ *
+ * \param window #GSCHEM_TOPLEVEL to obtain a smob for.
+ * \param a smob representing \a window.
+ */
+SCM
+g_scm_from_window (GSCHEM_TOPLEVEL *w_current)
+{
+ g_assert (w_current != NULL);
+
+ if (w_current->smob == SCM_UNDEFINED) {
+ SCM_NEWSMOB (w_current->smob, window_smob_tag, w_current);
+ }
+
+ return w_current->smob;
+}
+
+/*!
+ * \brief Set the #GSCHEM_TOPLEVEL fluid in the current dynamic context.
+ * \par Function Description
+ *
+ * This function must be used inside a pair of calls to
+ * scm_dynwind_begin() and scm_dynwind_end(). During the dynwind
+ * context, the #GSCHEM_TOPLEVEL fluid is set to \a w_current.
+ *
+ * \param [in] w_current The new GSCHEM_TOPLEVEL pointer.
+ */
+void
+g_dynwind_window (GSCHEM_TOPLEVEL *w_current)
+{
+ SCM window_s = g_scm_from_window (w_current);
+ scm_dynwind_fluid (scheme_window_fluid, window_s);
+ edascm_dynwind_toplevel (w_current->toplevel);
+}
+
+/*!
+ * \brief Get the value of the #GSCHEM_TOPLEVEL fluid.
+ * \par Function Description
+ * Return the value of the #GSCHEM_TOPLEVEL fluid in the current
+ * dynamic context.
+ */
+SCM_DEFINE (g_scm_current_window, "%current-window", 0, 0, 0,
+ (),
+ "Get the GSCHEM_TOPLEVEL for the current dynamic context.")
+{
+ return scm_fluid_ref (scheme_window_fluid);
+}
+
+/*!
+ * \brief Get the value of the #GSCHEM_TOPLEVEL fluid.
+ * \par Function Description
+ * Return the value of the #GSCHEM_TOPLEVEL fluid in the current dynamic
+ * context.
+ */
+GSCHEM_TOPLEVEL *
+g_current_window ()
+{
+ SCM window_s = g_scm_current_window ();
+
+ if (!(SCM_SMOB_PREDICATE (window_smob_tag, window_s)
+ && ((void *)SCM_SMOB_DATA (window_s) != NULL))) {
+ scm_misc_error (NULL, "Found invalid gschem window smob ~S",
+ scm_list_1 (window_s));
+ }
+
+ return (GSCHEM_TOPLEVEL *) SCM_SMOB_DATA (window_s);
+}
+
+/*!
+ * \brief Create the (gschem core window) Scheme module
+ * \par Function Description
+ * Defines procedures in the (gschem core window) module. The module
+ * can be accessed using (use-modules (geda core toplevel)).
+ */
+static void
+init_module_gschem_core_window ()
+{
+ /* Register the functions */
+ #include "g_window.x"
+
+ /* Add them to the module's public definitions. */
+ scm_c_export (s_g_scm_current_window, NULL);
+}
+
+/*!
+ * \brief Initialise the GSCHEM_TOPLEVEL manipulation procedures.
+ * \par Function Description
+
+ * Registers some Scheme procedures for working with #GSCHEM_TOPLEVEL
+ * smobs and creates the #GSCHEM_TOPLEVEL fluid. Should only be called
+ * by main_prog().
+ */
+void
+g_init_window ()
+{
+ /* Register gEDA smob type */
+ window_smob_tag = scm_make_smob_type ("gschem-window", 0);
+ scm_set_smob_free (window_smob_tag, smob_free);
+ scm_set_smob_print (window_smob_tag, smob_print);
+
+ /* Create fluid */
+ scheme_window_fluid = scm_permanent_object (scm_make_fluid ());
+
+ /* Define the (geda core toplevel) module */
+ scm_c_define_module ("gschem core window",
+ init_module_gschem_core_window,
+ NULL);
+}
diff --git a/gschem/src/gschem.c b/gschem/src/gschem.c
index e5e6ca3..0f0ee8d 100644
--- a/gschem/src/gschem.c
+++ b/gschem/src/gschem.c
@@ -203,6 +203,7 @@ void main_prog(void *closure, int argc, char *argv[])
/* register guile (scheme) functions */
g_register_funcs();
+ g_init_window ();
/* initialise color map (need to do this before reading rc files */
x_color_init ();
diff --git a/gschem/src/gschem_toplevel.c b/gschem/src/gschem_toplevel.c
index 6bfda7a..af5ac98 100644
--- a/gschem/src/gschem_toplevel.c
+++ b/gschem/src/gschem_toplevel.c
@@ -203,5 +203,8 @@ GSCHEM_TOPLEVEL *gschem_toplevel_new ()
w_current->print_command = NULL;
+ w_current->smob = SCM_UNDEFINED;
+
return w_current;
}
+
diff --git a/gschem/src/x_menus.c b/gschem/src/x_menus.c
index 63fe5a6..91d266f 100644
--- a/gschem/src/x_menus.c
+++ b/gschem/src/x_menus.c
@@ -66,16 +66,19 @@ int npopup_items = sizeof(popup_items) / sizeof(popup_items[0]);
*/
static void g_menu_execute(GtkAction *action, gpointer user_data)
{
- gchar *guile_string;
+ gchar *guile_string = NULL;
const gchar *func = gtk_action_get_name (action);
- /* GSCHEM_TOPLEVEL *w_current = (GSCHEM_TOPLEVEL *) user_data; */
+ GSCHEM_TOPLEVEL *w_current = (GSCHEM_TOPLEVEL *) user_data;
guile_string = g_strdup_printf("(%s)", func);
#if DEBUG
printf("%s\n", guile_string);
#endif
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (g_free, guile_string, SCM_F_WIND_EXPLICITLY);
+ g_dynwind_window (w_current);
g_scm_c_eval_string_protected (guile_string);
- g_free(guile_string);
+ scm_dynwind_end ();
}
/*! \todo Finish function documentation!!!
@@ -112,6 +115,13 @@ get_main_menu(GSCHEM_TOPLEVEL *w_current)
int i, j;
menu_bar = gtk_menu_bar_new ();
+
+ scm_dynwind_begin (0);
+ g_dynwind_window (w_current);
+ /*! \bug This function may leak memory if there is a non-local exit
+ * in Guile code. At some point, unwind handlers need to be added to
+ * clean up heap-allocated strings. */
+
for (i = 0 ; i < s_menu_return_num(); i++) {
scm_items = s_menu_return_entry(i, raw_menu_name);
@@ -220,6 +230,7 @@ get_main_menu(GSCHEM_TOPLEVEL *w_current)
gtk_menu_item_set_submenu (GTK_MENU_ITEM (root_menu), menu);
gtk_menu_bar_append (GTK_MENU_BAR (menu_bar), root_menu);
}
+ scm_dynwind_end ();
g_free(raw_menu_name);
return menu_bar;
diff --git a/gschem/src/x_stroke.c b/gschem/src/x_stroke.c
index 0259619..6dc3762 100644
--- a/gschem/src/x_stroke.c
+++ b/gschem/src/x_stroke.c
@@ -159,7 +159,9 @@ x_stroke_translate_and_execute (GSCHEM_TOPLEVEL *w_current)
g_strdup_printf("(eval-stroke \"%s\")", sequence);
SCM ret;
+ SCHEME_WINDOW_PUSH(w_current);
ret = g_scm_c_eval_string_protected (guile_string);
+ SCHEME_WINDOW_POP(w_current);
g_free (guile_string);
diff --git a/gschem/src/x_window.c b/gschem/src/x_window.c
index c44fa12..79e882e 100644
--- a/gschem/src/x_window.c
+++ b/gschem/src/x_window.c
@@ -229,7 +229,10 @@ static void x_window_invoke_macro(GtkEntry *entry, void *userdata)
interpreter = scm_list_2(scm_from_locale_symbol("invoke-macro"),
scm_from_locale_string(gtk_entry_get_text(entry)));
+ scm_dynwind_begin (0);
+ g_dynwind_window (w_current);
g_scm_eval_protected(interpreter, SCM_UNDEFINED);
+ scm_dynwind_end ();
gtk_widget_hide(w_current->macro_box);
gtk_widget_grab_focus(w_current->drawing_area);
@@ -633,6 +636,12 @@ void x_window_close(GSCHEM_TOPLEVEL *w_current)
x_window_free_gc(w_current);
+ /* Clear Guile smob weak ref */
+ if (w_current->smob != SCM_UNDEFINED) {
+ SCM_SET_SMOB_DATA (w_current->smob, NULL);
+ w_current->smob = SCM_UNDEFINED;
+ }
+
/* finally close the main window */
gtk_widget_destroy(w_current->main_window);
commit 662b15fd2dfa47d48410bcd42c75b461ab5f21bd
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Attributes.
Adds support for attributes. In order to make the API safe to use
without memory corruption, there are significant restrictions on the
context in which attribute attachments can be made. Most importantly,
both target and attribute must be part of the same page, or of the
same component, and objects which have attribute attachments cannot be
removed from a page or component's contents.
diff --git a/libgeda/include/libgedaguile_priv.h b/libgeda/include/libgedaguile_priv.h
index cf637dc..37e6371 100644
--- a/libgeda/include/libgedaguile_priv.h
+++ b/libgeda/include/libgedaguile_priv.h
@@ -31,6 +31,7 @@ void edascm_init_toplevel ();
void edascm_init_object ();
void edascm_init_complex ();
void edascm_init_page ();
+void edascm_init_attrib ();
/* ---------------------------------------- */
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 9d7fa5b..5b548d6 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -1,7 +1,7 @@
scmdatadir = $(GEDADATADIR)/scheme
nobase_dist_scmdata_DATA = geda.scm color-map.scm \
- geda/object.scm geda/page.scm
+ geda/object.scm geda/page.scm geda/attrib.scm
# Unit test support. The unit tests are run using the geda-batch
# program, with config loading disabled (-q) so that user config
@@ -16,7 +16,8 @@ TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0013-object-arc.scm\
unit-tests/t0014-object-text.scm \
unit-tests/t0015-object-complex.scm \
- unit-tests/t0020-page.scm
+ unit-tests/t0020-page.scm \
+ unit-tests/t0030-attribute.scm
dist_noinst_DATA = unit-test.scm $(TESTS)
diff --git a/libgeda/scheme/geda/attrib.scm b/libgeda/scheme/geda/attrib.scm
new file mode 100644
index 0000000..8ccad6b
--- /dev/null
+++ b/libgeda/scheme/geda/attrib.scm
@@ -0,0 +1,53 @@
+;; gEDA - GPL Electronic Design Automation
+;; libgeda - gEDA's library - Scheme API
+;; Copyright (C) 2010 Peter Brett
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+;;
+
+(define-module (geda attrib)
+
+ ; Import C procedures
+ #:use-module (geda core attrib)
+
+ #:use-module (geda object))
+
+(define-public parse-attrib %parse-attrib)
+(define-public object-attribs %object-attribs)
+(define-public attrib-attachment %attrib-attachment)
+(define-public attach-attrib! %attach-attrib!)
+(define-public detach-attrib! %detach-attrib!)
+
+;; attribute? a
+;;
+;; Returns #t if a is an text object in attribute format.
+(define-public (attribute? a)
+ (and (text? a) (parse-attrib a)))
+
+;; attrib-name a
+;;
+;; Returns the attribute name of a, or #f if a is not in attribute
+;; format.
+(define-public (attrib-name a)
+ (let ((v (parse-attrib a)))
+ (if v (car v) v)))
+
+;; attrib-value a
+;;
+;; Returns the attribute value of a, or #f if a is not in attribute
+;; format.
+(define-public (attrib-value a)
+ (let ((v (parse-attrib a)))
+ (if v (cdr v) v)))
diff --git a/libgeda/scheme/unit-tests/t0015-object-complex.scm b/libgeda/scheme/unit-tests/t0015-object-complex.scm
index e77dc5f..6c200c1 100644
--- a/libgeda/scheme/unit-tests/t0015-object-complex.scm
+++ b/libgeda/scheme/unit-tests/t0015-object-complex.scm
@@ -3,6 +3,7 @@
(use-modules (unit-test))
(use-modules (geda object))
(use-modules (geda page))
+(use-modules (geda attrib))
(begin-test 'component
(let ((a (make-component "test component" '(1 . 2) 0 #t #f)))
@@ -60,8 +61,10 @@
(begin-test 'component-remove
(let ((A (make-component "test component" '(1 . 2) 0 #t #f))
(B (make-component "test component" '(1 . 2) 0 #t #f))
+ (P (make-page "/test/page/A"))
(x (make-line '(0 . 0) '(2 . 0)))
- (y (make-line '(0 . 0) '(0 . 2))))
+ (y (make-line '(0 . 0) '(0 . 2)))
+ (z (make-line '(1 . 0) '(2 . 2))))
(component-append! A x)
(assert-equal x (component-remove! A x))
@@ -77,7 +80,16 @@
(assert-thrown 'object-state
(component-remove! B y))
+ (page-append! P z)
(assert-thrown 'object-state
- (let* ((P (make-page "/test/page/A"))
- (z (page-append! P (make-line '(1 . 0) '(2 . 2)))))
- (component-remove! A z)))))
+ (component-remove! A z))
+ ))
+
+(begin-test 'component-remove-attrib
+ (let ((comp (make-component "test component" '(1 . 2) 0 #t #f))
+ (pin (make-net-pin '(0 . 0) '(100 . 0)))
+ (attrib (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both)))
+ (for-each (lambda (x) (component-append! comp x)) (list pin attrib))
+ (attach-attrib! pin attrib)
+ (assert-thrown 'object-state (component-remove! comp pin))
+ (assert-thrown 'object-state (component-remove! comp attrib))))
diff --git a/libgeda/scheme/unit-tests/t0020-page.scm b/libgeda/scheme/unit-tests/t0020-page.scm
index 449e1a0..2154375 100644
--- a/libgeda/scheme/unit-tests/t0020-page.scm
+++ b/libgeda/scheme/unit-tests/t0020-page.scm
@@ -3,6 +3,7 @@
(use-modules (unit-test))
(use-modules (geda page))
(use-modules (geda object))
+(use-modules (geda attrib))
(begin-test 'page
(let ((page-a (make-page "/test/page/A"))
@@ -11,8 +12,8 @@
(assert-equal (list page-a page-b) (active-pages))))
(begin-test 'page-append
- (let ((A (make-page "/test/page/A"))
- (B (make-page "/test/page/B"))
+ (let ((A (make-page "/test/page/C"))
+ (B (make-page "/test/page/D"))
(x (make-line '(0 . 0) '(1 . 2)))
(y (make-line '(0 . 1) '(2 . 2))))
@@ -36,10 +37,12 @@
(page-append! A z)))))
(begin-test 'page-remove
- (let ((A (make-page "/test/page/A"))
- (B (make-page "/test/page/B"))
+ (let ((A (make-page "/test/page/E"))
+ (B (make-page "/test/page/F"))
+ (C (make-component "test component" '(1 . 2) 0 #t #f))
(x (make-line '(0 . 0) '(2 . 0)))
- (y (make-line '(0 . 0) '(0 . 2))))
+ (y (make-line '(0 . 0) '(0 . 2)))
+ (z (make-line '(1 . 0) '(2 . 2))))
(page-append! A x)
(assert-equal x (page-remove! A x))
@@ -55,7 +58,15 @@
(assert-thrown 'object-state
(page-remove! B y))
+ (component-append! C z)
(assert-thrown 'object-state
- (let* ((C (make-component "test component" '(1 . 2) 0 #t #f))
- (z (component-append! C (make-line '(1 . 0) '(2 . 2)))))
- (page-remove! A z))) ))
+ (page-remove! A z)) ))
+
+(begin-test 'page-remove-attrib
+ (let ((page (make-page "/test/page/G"))
+ (pin (make-net-pin '(0 . 0) '(100 . 0)))
+ (attrib (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both)))
+ (for-each (lambda (x) (page-append! page x)) (list pin attrib))
+ (attach-attrib! pin attrib)
+ (assert-thrown 'object-state (page-remove! page pin))
+ (assert-thrown 'object-state (page-remove! page attrib))))
diff --git a/libgeda/scheme/unit-tests/t0030-attribute.scm b/libgeda/scheme/unit-tests/t0030-attribute.scm
new file mode 100644
index 0000000..35be33e
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0030-attribute.scm
@@ -0,0 +1,89 @@
+;; Test Scheme procedures related to attributes.
+
+(use-modules (unit-test))
+(use-modules (geda attrib))
+(use-modules (geda page))
+(use-modules (geda object))
+
+(begin-test 'parse-attrib
+ (let ((good (make-text '(1 . 2) 'lower-left 0 "name=value" 10 #t 'both))
+ (bad (make-text '(1 . 2) 'lower-left 0 "name value" 10 #t 'both)))
+
+ (assert-equal "name" (attrib-name good))
+ (assert-equal "value" (attrib-value good))
+ (assert-equal (cons (attrib-name good) (attrib-value good))
+ (parse-attrib good))
+
+ (assert-true (not (parse-attrib bad)))
+ (assert-true (not (attrib-name bad)))
+ (assert-true (not (attrib-value bad))) ))
+
+(begin-test 'attach-attrib
+ (let ((page1 (make-page "/test/page/1"))
+ (page2 (make-page "/test/page/2"))
+ (comp1 (make-component "testcomponent1" '(0 . 0) 0 #f #f))
+ (comp2 (make-component "testcomponent2" '(0 . 0) 0 #f #f))
+ (pin (make-net-pin '(0 . 0) '(100 . 0)))
+ (x (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both))
+ (y (make-text '(0 . 0) 'lower-left 0 "name=y" 10 #t 'both)))
+
+ ;; This test is particularly long-winded because it tries to
+ ;; exhaustively test every possible reason for attach-attrib! to
+ ;; fail.
+
+ (assert-thrown 'object-state
+ (attach-attrib! pin x))
+
+ (component-append! comp1 pin)
+ (assert-thrown 'object-state
+ (attach-attrib! pin x))
+
+ (component-append! comp1 x)
+ (assert-equal x (attach-attrib! pin x))
+ (assert-equal (list x) (object-attribs pin))
+
+ (assert-thrown 'object-state
+ (attach-attrib! x y))
+
+ (assert-thrown 'object-state
+ (attach-attrib! y x))
+
+ (component-append! comp2 y)
+ (assert-thrown 'object-state
+ (attach-attrib! pin y))
+
+ (component-remove! comp2 y)
+
+ (page-append! page1 comp1)
+ (assert-thrown 'object-state
+ (attach-attrib! comp1 y))
+
+ (page-append! page1 y)
+ (assert-thrown 'object-state
+ (attach-attrib! pin y))
+
+ (page-remove! page1 y)
+ (page-append! page2 y)
+ (assert-thrown 'object-state
+ (attach-attrib! comp1 y))
+
+ (page-remove! page2 y)
+ (page-append! page1 y)
+ (assert-equal y (attach-attrib! comp1 y))
+ (assert-equal (list y) (object-attribs comp1)) ))
+
+(begin-test 'detach-attrib
+ (let ((page (make-page "/test/page/1"))
+ (pin1 (make-net-pin '(0 . 0) '(100 . 0)))
+ (pin2 (make-net-pin '(0 . 100) '(100 . 100)))
+ (x (make-text '(0 . 0) 'lower-left 0 "name=x" 10 #t 'both)))
+
+ (for-each (lambda (x) (page-append! page x)) (list pin1 pin2 x))
+
+ (attach-attrib! pin1 x)
+
+ (assert-thrown 'object-state
+ (detach-attrib! pin2 x))
+
+ (assert-equal x (detach-attrib! pin1 x))
+ (assert-equal '() (object-attribs pin1)) ))
diff --git a/libgeda/src/Makefile.am b/libgeda/src/Makefile.am
index a381b10..7eee9e9 100644
--- a/libgeda/src/Makefile.am
+++ b/libgeda/src/Makefile.am
@@ -8,7 +8,8 @@ BUILT_SOURCES = \
scheme_toplevel.x \
scheme_object.x \
scheme_complex.x \
- scheme_page.x
+ scheme_page.x \
+ scheme_attrib.x
scheme_api_sources = \
scheme_init.c \
@@ -16,7 +17,8 @@ scheme_api_sources = \
scheme_toplevel.c \
scheme_object.c \
scheme_complex.c \
- scheme_page.c
+ scheme_page.c \
+ scheme_attrib.c
libgeda_la_SOURCES = \
$(scheme_api_sources) \
diff --git a/libgeda/src/scheme_attrib.c b/libgeda/src/scheme_attrib.c
new file mode 100644
index 0000000..0816136
--- /dev/null
+++ b/libgeda/src/scheme_attrib.c
@@ -0,0 +1,256 @@
+/* gEDA - GPL Electronic Design Automation
+ * libgeda - gEDA's library - Scheme API
+ * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+ */
+
+/*!
+ * \file scheme_page.c
+ * \brief Scheme API page manipulation procedures.
+ */
+
+#include <config.h>
+
+#include "libgeda_priv.h"
+#include "libgedaguile_priv.h"
+
+SCM_SYMBOL (attribute_format_sym, "attribute-format");
+
+/*! \brief Parse an attribute text object into name and value strings.
+ * \par Function Description
+ * Tries to parse the underlying string of the text object \a text_s
+ * into name and value strings. If successful, returns a pair of the
+ * form <tt>(name . value)</tt>. Otherwise, returns SCM_BOOL_F.
+ *
+ * \note Scheme API: Implements the %attrib-parse procedure of the
+ * (geda core attrib) module.
+ *
+ * \param text_s text object to attempt to split.
+ * \return name/value pair, or SCM_BOOL_F.
+ */
+SCM_DEFINE (parse_attrib, "%parse-attrib", 1, 0, 0,
+ (SCM text_s), "Parse attribute name and value from text object.")
+{
+ gchar *name = NULL;
+ gchar *value = NULL;
+ SCM result = SCM_BOOL_F;
+
+ SCM_ASSERT (edascm_is_object_type (text_s, OBJ_TEXT), text_s,
+ SCM_ARG1, s_parse_attrib);
+
+ OBJECT *text = edascm_to_object (text_s);
+
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (g_free, name, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (g_free, value, SCM_F_WIND_EXPLICITLY);
+
+ if (o_attrib_get_name_value (text, &name, &value)) {
+ result = scm_cons (scm_from_locale_string (name),
+ scm_from_locale_string (value));
+ }
+ scm_dynwind_end ();
+
+ return result;
+}
+
+/*! \brief Get a list of an object's attributes.
+ * \par Function Description
+ * Retrieves the attributes of the smob \a obj_s as a Scheme list of
+ * #OBJECT smobs.
+ *
+ * \note Scheme API: Implements the %object-attribs procedure of the
+ * (geda core attrib) module.
+ *
+ * \param obj_s object to get attributes for.
+ * \return a list of #OBJECT smobs.
+ */
+SCM_DEFINE (object_attribs, "%object-attribs", 1, 0, 0,
+ (SCM obj_s), "Get an object's attributes.")
+{
+ /* Ensure that the argument is an object */
+ SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
+ SCM_ARG1, s_object_attribs);
+
+ OBJECT *obj = edascm_to_object (obj_s);
+
+ return edascm_from_object_glist (obj->attribs);
+}
+
+/*! \brief Get the object that an attribute is attached to.
+ * \par Function Description
+ * Returns the #OBJECT smob that \a attrib_s is attached to. If \a
+ * attrib_s is not attached as an attribute, returns SCM_BOOL_F.
+ *
+ * \note Scheme API: Implements the %attrib-attachment procedure of
+ * the (geda core attrib) module.
+ *
+ * \param attrib_s the object to get attribute attachment for.
+ * \return the object to which \a attrib_s is attached, or SCM_BOOL_F.
+ */
+SCM_DEFINE (attrib_attachment, "%attrib-attachment", 1, 0, 0,
+ (SCM attrib_s), "Get the object that an attribute is attached to.")
+{
+ /* Ensure that the argument is an object */
+ SCM_ASSERT (EDASCM_OBJECTP (attrib_s), attrib_s,
+ SCM_ARG1, s_attrib_attachment);
+
+ OBJECT *obj = edascm_to_object (attrib_s);
+
+ if (obj->attached_to == NULL) {
+ return SCM_BOOL_F;
+ } else {
+ return edascm_from_object (obj->attached_to);
+ }
+}
+
+/*! \brief Attach an attribute to an object.
+ * \par Function Description
+ * Attach \a attrib_s to \a obj_s. The following conditions must be
+ * satisfied:
+ *
+ * - Neither \a obj_s nor \a attrib_s may be already attached as an
+ * attribute.
+ * - Both \a obj_s and \a attrib_s must be part of the same page
+ * and/or complex object. (They can't be "loose" objects).
+ * - \a attrib_s must be a text object.
+ *
+ * These restrictions are intentionally harsher than those of the C
+ * API, and are required in order to ensure that the Scheme API is
+ * safe.
+ *
+ * \note Scheme API: Implements the %attach-attrib! procedure of
+ * the (geda core attrib) module.
+ *
+ * \param obj_s the object to which to attach an attribute.
+ * \param attrib_s the attribute to attach.
+ * \return \a attrib_s.
+ */
+SCM_DEFINE (attach_attrib, "%attach-attrib!", 2, 0, 0,
+ (SCM obj_s, SCM attrib_s), "Attach an attribute to an object.")
+{
+ SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
+ SCM_ARG1, s_attach_attrib);
+ SCM_ASSERT (edascm_is_object_type (attrib_s, OBJ_TEXT), attrib_s,
+ SCM_ARG2, s_attach_attrib);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+ OBJECT *attrib = edascm_to_object (attrib_s);
+
+ /* Check that both are in the same page and/or complex object */
+ if ((obj->parent != attrib->parent)
+ || (o_get_page (toplevel, obj) != o_get_page (toplevel, attrib))
+ || ((obj->parent == NULL) && (o_get_page (toplevel, obj) == NULL))) {
+ scm_error (edascm_object_state_sym, s_attach_attrib,
+ _("Objects ~A and ~A are not part of the same page and/or complex object"),
+ scm_list_2 (obj_s, attrib_s), SCM_EOL);
+ }
+
+ /* Check that neither is already an attached attribute */
+ if (obj->attached_to != NULL) {
+ scm_error (edascm_object_state_sym, s_attach_attrib,
+ _("Object ~A is already attached as an attribute"),
+ scm_list_1 (obj_s), SCM_EOL);
+ }
+ if (attrib->attached_to != NULL) {
+ scm_error (edascm_object_state_sym, s_attach_attrib,
+ _("Object ~A is already attached as an attribute"),
+ scm_list_1 (attrib_s), SCM_EOL);
+ }
+
+ /* Carry out the attachment */
+ o_emit_pre_change_notify (toplevel, attrib);
+ o_attrib_attach (toplevel, attrib, obj, TRUE);
+ o_emit_change_notify (toplevel, attrib);
+
+ return attrib_s;
+}
+
+/*! \brief Detach an attribute from an object.
+ * \par Function Description
+ * Detach \a attrib_s from \a obj_s. If \a attrib_s is not attached
+ * as an attribute, does nothing silently. If \a attrib_s is attached
+ * as an attribute of an object other than \a obj_s, throws a Scheme
+ * error.
+ *
+ * \note Scheme API: Implements the %detach-attrib! procedure of
+ * the (geda core attrib) module.
+ *
+ * \param obj_s the object from which to detach an attribute.
+ * \param attrib_s the attribute to detach.
+ * \return \a attrib_s.
+ */
+SCM_DEFINE (detach_attrib, "%detach-attrib!", 2, 0, 0,
+ (SCM obj_s, SCM attrib_s), "Detach an attribute to an object.")
+{
+ SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
+ SCM_ARG1, s_detach_attrib);
+ SCM_ASSERT (edascm_is_object_type (attrib_s, OBJ_TEXT), attrib_s,
+ SCM_ARG2, s_detach_attrib);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+ OBJECT *attrib = edascm_to_object (attrib_s);
+
+ /* Check that attrib isn't attached elsewhere */
+ if (attrib->attached_to != obj) {
+ scm_error (edascm_object_state_sym, s_detach_attrib,
+ _("Object ~A is attribute of wrong object"),
+ scm_list_1 (attrib_s), SCM_EOL);
+ }
+
+ /* Detach object */
+ o_emit_pre_change_notify (toplevel, attrib);
+ o_attrib_remove (toplevel, &obj->attribs, attrib);
+ o_set_color (toplevel, attrib, DETACHED_ATTRIBUTE_COLOR);
+ o_emit_change_notify (toplevel, attrib);
+
+ return attrib_s;
+}
+
+
+/*!
+ * \brief Create the (geda core attrib) Scheme module.
+ * \par Function Description
+ * Defines procedures in the (geda core attrib) module. The module can
+ * be accessed using (use-modules (geda core attrib)).
+ */
+static void
+init_module_geda_core_attrib ()
+{
+ /* Register the functions */
+ #include "scheme_attrib.x"
+
+ /* Add them to the module's public definitions. */
+ scm_c_export (s_parse_attrib, s_object_attribs, s_attrib_attachment,
+ s_attach_attrib, s_detach_attrib,
+ NULL);
+}
+
+/*!
+ * \brief Initialise the basic gEDA attribute manipulation procedures.
+ * \par Function Description
+ * Registers some Scheme procedures for working with
+ * attributes. Should only be called by scheme_api_init().
+ */
+void
+edascm_init_attrib ()
+{
+ /* Define the (geda core attrib) module */
+ scm_c_define_module ("geda core attrib",
+ init_module_geda_core_attrib,
+ NULL);
+}
diff --git a/libgeda/src/scheme_complex.c b/libgeda/src/scheme_complex.c
index 216f5e3..ec3f7ba 100644
--- a/libgeda/src/scheme_complex.c
+++ b/libgeda/src/scheme_complex.c
@@ -269,6 +269,20 @@ SCM_DEFINE (complex_remove, "%complex-remove!", 2, 0, 0,
scm_list_1 (obj_s), SCM_EOL);
}
+ /* Check that object is not attached as an attribute. */
+ if (child->attached_to != NULL) {
+ scm_error (edascm_object_state_sym, s_complex_remove,
+ _("Object ~A is attached as an attribute"),
+ scm_list_1 (obj_s), SCM_EOL);
+ }
+
+ /* Check that object doesn't have attributes. */
+ if (child->attribs != NULL) {
+ scm_error (edascm_object_state_sym, s_complex_remove,
+ _("Object ~A has attributes"),
+ scm_list_1 (obj_s), SCM_EOL);
+ }
+
if (child->parent == NULL) return obj_s;
/* Don't need to emit change notifications for the child because
diff --git a/libgeda/src/scheme_init.c b/libgeda/src/scheme_init.c
index 9b2a25e..26a6e20 100644
--- a/libgeda/src/scheme_init.c
+++ b/libgeda/src/scheme_init.c
@@ -49,4 +49,5 @@ edascm_init ()
edascm_init_object ();
edascm_init_complex ();
edascm_init_page ();
+ edascm_init_attrib ();
}
diff --git a/libgeda/src/scheme_page.c b/libgeda/src/scheme_page.c
index 5e4e60f..c298c68 100644
--- a/libgeda/src/scheme_page.c
+++ b/libgeda/src/scheme_page.c
@@ -235,6 +235,20 @@ SCM_DEFINE (page_remove_, "%page-remove!", 2, 0, 0,
scm_list_1 (obj_s), SCM_EOL);
}
+ /* Check that object is not attached as an attribute. */
+ if (obj->attached_to != NULL) {
+ scm_error (edascm_object_state_sym, s_page_remove_,
+ _("Object ~A is attached as an attribute"),
+ scm_list_1 (obj_s), SCM_EOL);
+ }
+
+ /* Check that object doesn't have attributes. */
+ if (obj->attribs != NULL) {
+ scm_error (edascm_object_state_sym, s_page_remove_,
+ _("Object ~A has attributes"),
+ scm_list_1 (obj_s), SCM_EOL);
+ }
+
if (curr_page == NULL) return obj_s;
o_emit_pre_change_notify (toplevel, obj);
commit c8140254f0821bd28f84040939329aaf0e744a9a
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Basic page procedures.
This patch implements support for creating and modifying
schematic/symbol pages. It does not yet support file loading/saving,
printing, or closing pages.
diff --git a/libgeda/include/libgedaguile_priv.h b/libgeda/include/libgedaguile_priv.h
index 3f0335f..cf637dc 100644
--- a/libgeda/include/libgedaguile_priv.h
+++ b/libgeda/include/libgedaguile_priv.h
@@ -30,6 +30,7 @@ void edascm_init_smob ();
void edascm_init_toplevel ();
void edascm_init_object ();
void edascm_init_complex ();
+void edascm_init_page ();
/* ---------------------------------------- */
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index e4b35f4..9d7fa5b 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -1,7 +1,7 @@
scmdatadir = $(GEDADATADIR)/scheme
nobase_dist_scmdata_DATA = geda.scm color-map.scm \
- geda/object.scm
+ geda/object.scm geda/page.scm
# Unit test support. The unit tests are run using the geda-batch
# program, with config loading disabled (-q) so that user config
@@ -15,7 +15,8 @@ TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0012-object-circle.scm \
unit-tests/t0013-object-arc.scm\
unit-tests/t0014-object-text.scm \
- unit-tests/t0015-object-complex.scm
+ unit-tests/t0015-object-complex.scm \
+ unit-tests/t0020-page.scm
dist_noinst_DATA = unit-test.scm $(TESTS)
diff --git a/libgeda/scheme/geda/page.scm b/libgeda/scheme/geda/page.scm
new file mode 100644
index 0000000..c335f84
--- /dev/null
+++ b/libgeda/scheme/geda/page.scm
@@ -0,0 +1,34 @@
+;; gEDA - GPL Electronic Design Automation
+;; libgeda - gEDA's library - Scheme API
+;; Copyright (C) 2010 Peter Brett
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+;;
+
+(define-module (geda page)
+
+ ; Import C procedures
+ #:use-module (geda core smob)
+ #:use-module (geda core page))
+
+(define-public object-page %object-page)
+
+(define-public page? %page?)
+(define-public active-pages %active-pages)
+(define-public make-page %new-page)
+(define-public page-filename %page-filename)
+(define-public page-contents %page-contents)
+(define-public page-append! %page-append!)
+(define-public page-remove! %page-remove!)
diff --git a/libgeda/scheme/unit-tests/t0015-object-complex.scm b/libgeda/scheme/unit-tests/t0015-object-complex.scm
index d719847..e77dc5f 100644
--- a/libgeda/scheme/unit-tests/t0015-object-complex.scm
+++ b/libgeda/scheme/unit-tests/t0015-object-complex.scm
@@ -2,6 +2,7 @@
(use-modules (unit-test))
(use-modules (geda object))
+(use-modules (geda page))
(begin-test 'component
(let ((a (make-component "test component" '(1 . 2) 0 #t #f)))
@@ -49,7 +50,12 @@
(assert-equal (list x y) (component-contents A))
(assert-thrown 'object-state
- (component-append! B x))))
+ (component-append! B x))
+
+ (assert-thrown 'object-state
+ (let* ((P (make-page "/test/page/A"))
+ (z (page-append! P (make-line '(1 . 0) '(2 . 2)))))
+ (component-append! A z)))))
(begin-test 'component-remove
(let ((A (make-component "test component" '(1 . 2) 0 #t #f))
@@ -69,4 +75,9 @@
(assert-equal (list y) (component-contents A))
(assert-thrown 'object-state
- (component-remove! B y))))
+ (component-remove! B y))
+
+ (assert-thrown 'object-state
+ (let* ((P (make-page "/test/page/A"))
+ (z (page-append! P (make-line '(1 . 0) '(2 . 2)))))
+ (component-remove! A z)))))
diff --git a/libgeda/scheme/unit-tests/t0020-page.scm b/libgeda/scheme/unit-tests/t0020-page.scm
new file mode 100644
index 0000000..449e1a0
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0020-page.scm
@@ -0,0 +1,61 @@
+;; Test Scheme procedures related to pages.
+
+(use-modules (unit-test))
+(use-modules (geda page))
+(use-modules (geda object))
+
+(begin-test 'page
+ (let ((page-a (make-page "/test/page/A"))
+ (page-b (make-page "/test/page/B")))
+ (assert-equal "/test/page/A" (page-filename page-a))
+ (assert-equal (list page-a page-b) (active-pages))))
+
+(begin-test 'page-append
+ (let ((A (make-page "/test/page/A"))
+ (B (make-page "/test/page/B"))
+ (x (make-line '(0 . 0) '(1 . 2)))
+ (y (make-line '(0 . 1) '(2 . 2))))
+
+ (assert-equal '() (page-contents A))
+
+ (assert-equal x (page-append! A x))
+ (assert-equal (list x) (page-contents A))
+
+ (assert-equal x (page-append! A x))
+ (assert-equal (list x) (page-contents A))
+
+ (assert-equal y (page-append! A y))
+ (assert-equal (list x y) (page-contents A))
+
+ (assert-thrown 'object-state
+ (page-append! B x))
+
+ (assert-thrown 'object-state
+ (let* ((C (make-component "test component" '(1 . 2) 0 #t #f))
+ (z (component-append! C (make-line '(1 . 0) '(2 . 2)))))
+ (page-append! A z)))))
+
+(begin-test 'page-remove
+ (let ((A (make-page "/test/page/A"))
+ (B (make-page "/test/page/B"))
+ (x (make-line '(0 . 0) '(2 . 0)))
+ (y (make-line '(0 . 0) '(0 . 2))))
+
+ (page-append! A x)
+ (assert-equal x (page-remove! A x))
+ (assert-equal '() (page-contents A))
+ (assert-equal x (page-remove! A x))
+ (assert-equal x (page-remove! B x))
+
+ (page-append! A x)
+ (page-append! A y)
+ (assert-equal x (page-remove! A x))
+ (assert-equal (list y) (page-contents A))
+
+ (assert-thrown 'object-state
+ (page-remove! B y))
+
+ (assert-thrown 'object-state
+ (let* ((C (make-component "test component" '(1 . 2) 0 #t #f))
+ (z (component-append! C (make-line '(1 . 0) '(2 . 2)))))
+ (page-remove! A z))) ))
diff --git a/libgeda/src/Makefile.am b/libgeda/src/Makefile.am
index 8c816a3..a381b10 100644
--- a/libgeda/src/Makefile.am
+++ b/libgeda/src/Makefile.am
@@ -7,14 +7,16 @@ BUILT_SOURCES = \
scheme_smob.x \
scheme_toplevel.x \
scheme_object.x \
- scheme_complex.x
+ scheme_complex.x \
+ scheme_page.x
scheme_api_sources = \
scheme_init.c \
scheme_smob.c \
scheme_toplevel.c \
- scheme_object.c\
- scheme_complex.c
+ scheme_object.c \
+ scheme_complex.c \
+ scheme_page.c
libgeda_la_SOURCES = \
$(scheme_api_sources) \
diff --git a/libgeda/src/scheme_init.c b/libgeda/src/scheme_init.c
index ebc62da..9b2a25e 100644
--- a/libgeda/src/scheme_init.c
+++ b/libgeda/src/scheme_init.c
@@ -48,4 +48,5 @@ edascm_init ()
edascm_init_toplevel ();
edascm_init_object ();
edascm_init_complex ();
+ edascm_init_page ();
}
diff --git a/libgeda/src/scheme_page.c b/libgeda/src/scheme_page.c
new file mode 100644
index 0000000..5e4e60f
--- /dev/null
+++ b/libgeda/src/scheme_page.c
@@ -0,0 +1,283 @@
+/* gEDA - GPL Electronic Design Automation
+ * libgeda - gEDA's library - Scheme API
+ * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+ */
+
+/*!
+ * \file scheme_page.c
+ * \brief Scheme API page manipulation procedures.
+ */
+
+#include <config.h>
+
+#include "libgeda_priv.h"
+#include "libgedaguile_priv.h"
+
+/*! \brief Get a of open pages.
+ * \par Function Description
+ * Retrieves a Scheme list of currently-opened pages.
+ *
+ * \note Scheme API: Implements the %active-pages procedure of the
+ * (geda core page) module.
+ *
+ * \return a Scheme list of #PAGE smobs.
+ */
+SCM_DEFINE (active_pages, "%active-pages", 0, 0, 0,
+ (), "Retrieve a list of currently-opened pages")
+{
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ SCM lst = SCM_EOL;
+ SCM rlst;
+ GList *page_list = geda_list_get_glist (toplevel->pages);
+
+ while (page_list != NULL) {
+ lst = scm_cons (edascm_from_page (page_list->data), lst);
+ page_list = g_list_next (page_list);
+ }
+
+ rlst = scm_reverse (lst);
+ scm_remember_upto_here_1 (lst);
+ return rlst;
+}
+
+/*! \brief Create a new page.
+ * \par Function Description
+ * Creates and initialises a new #PAGE structure associated with the
+ * filename \a filename_s. Note that this does not check that a file
+ * exists with that name, or attempt to load any data from it.
+ *
+ * \note Scheme API: Implements the %new-page procedure of the (geda
+ * core page) module.
+ *
+ * \return a newly-created #PAGE smob.
+ */
+SCM_DEFINE (new_page, "%new-page", 1, 0, 0,
+ (SCM filename_s), "Create a new page")
+{
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ char *filename;
+ PAGE *page;
+
+ /* Ensure that the argument is a string */
+ SCM_ASSERT (scm_is_string (filename_s), filename_s,
+ SCM_ARG1, s_new_page);
+
+ filename = scm_to_locale_string (filename_s);
+ page = s_page_new (toplevel, filename);
+ g_free (filename);
+
+ return edascm_from_page (page);
+}
+
+/*! \brief Get the filename associated with a page.
+ * \par Function Description
+ * Retrieves the filename associated with the #PAGE smob \a page_s.
+ *
+ * \note Scheme API: Implements the %page-filename procedure of the
+ * (geda core page) module.
+ *
+ * \return a Scheme string containing the page filename.
+ */
+SCM_DEFINE (page_filename, "%page-filename", 1, 0, 0,
+ (SCM page_s), "Get a page's associated filename")
+{
+ PAGE *page;
+
+ /* Ensure that the argument is a page smob */
+ SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
+ SCM_ARG1, s_page_filename);
+
+
+ page = edascm_to_page (page_s);
+ return scm_from_locale_string (page->page_filename);
+}
+
+/*! \brief Get a list of objects in a page.
+ * \par Function Description
+ * Retrieves the contents of a the #PAGE smob \a page_s as a Scheme
+ * list of #OBJECT smobs.
+ *
+ * \note Scheme API: Implements the %page-contents procedure of the
+ * (geda core page) module.
+ *
+ * \return a list of #OBJECT smobs.
+ */
+SCM_DEFINE (page_contents, "%page-contents", 1, 0, 0,
+ (SCM page_s), "Get a page's contents.")
+{
+ PAGE *page;
+
+ /* Ensure that the argument is a page smob */
+ SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
+ SCM_ARG1, s_page_contents);
+
+ page = edascm_to_page (page_s);
+
+ return edascm_from_object_glist (s_page_objects (page));
+}
+
+/*! \brief Get the page an object belongs to.
+ * \par Function Description
+ * Returns a smob for the #PAGE that \a obj_s belongs to. If \a obj_s
+ * does not belong to a #PAGE, returns SCM_BOOL_F.
+ *
+ * \note Scheme API: Implements the %object-page procedure in the
+ * (geda core page) module.
+ *
+ * \param [in] obj_s an #OBJECT smob.
+ * \return a #PAGE smob or SCM_BOOL_F.
+ */
+SCM_DEFINE (object_page, "%object-page", 1, 0, 0,
+ (SCM obj_s), "Get the page that an object smob belongs to")
+{
+ SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
+ SCM_ARG1, s_object_page);
+
+ PAGE *page = o_get_page (edascm_c_current_toplevel (),
+ edascm_to_object (obj_s));
+
+ if (page != NULL) {
+ return edascm_from_page (page);
+ } else {
+ return SCM_BOOL_F;
+ }
+}
+
+
+/*! \brief Add an object to a page.
+ * \par Function Description
+ * Adds \a obj_s to \a page_s. If \a obj_s is already attached to a
+ * #PAGE or to a complex #OBJECT, throws a Scheme error.
+ *
+ * \note Scheme API: Implements the %page-append! procedure of the
+ * (geda core page) module.
+ *
+ * \return \a obj_s.
+ */
+SCM_DEFINE (page_append_, "%page-append!", 2, 0, 0,
+ (SCM page_s, SCM obj_s), "Add an object to a page.")
+{
+ /* Ensure that the arguments have the correct types. */
+ SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
+ SCM_ARG1, s_page_append_);
+ SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
+ SCM_ARG2, s_page_append_);
+
+ PAGE *page = edascm_to_page (page_s);
+ OBJECT *obj = edascm_to_object (obj_s);
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+
+ /* Check that the object isn't already attached to something. */
+ PAGE *curr_page = o_get_page (toplevel, obj);
+ if (((curr_page != NULL) && (curr_page != page))
+ || (obj->parent != NULL)) {
+ scm_error (edascm_object_state_sym, s_page_append_,
+ _("Object ~A is already attached to something"),
+ scm_list_1 (obj_s), SCM_EOL);
+ }
+
+ if (curr_page == page) return obj_s;
+
+ /* Object cleanup now managed by C code. */
+ edascm_c_set_gc (obj_s, 0);
+ o_emit_pre_change_notify (toplevel, obj);
+ s_page_append (edascm_c_current_toplevel (), page, obj);
+ o_emit_change_notify (toplevel, obj);
+ page->CHANGED = 1; /* Ugh. */
+
+ return obj_s;
+}
+
+/*! \brief Remove an object from a page.
+ * \par Function Description
+ * Removes \a obj_s from \a page_s. If \a obj_s is attached to a
+ * #PAGE other than \a page_s, or to a complex #OBJECT, throws a
+ * Scheme error. If \a obj_s is not attached to a page, does nothing.
+ *
+ * \note Scheme API: Implements the %page-remove! procedure of the
+ * (geda core page) module.
+ *
+ * \return \a obj_s.
+ */
+SCM_DEFINE (page_remove_, "%page-remove!", 2, 0, 0,
+ (SCM page_s, SCM obj_s), "Remove an object from a page.")
+{
+ /* Ensure that the arguments have the correct types. */
+ SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
+ SCM_ARG1, s_page_remove_);
+ SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
+ SCM_ARG2, s_page_remove_);
+
+ PAGE *page = edascm_to_page (page_s);
+ OBJECT *obj = edascm_to_object (obj_s);
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+
+ /* Check that the object is not attached to something else. */
+ PAGE *curr_page = o_get_page (toplevel, obj);
+ if ((curr_page != NULL && curr_page != page)
+ || (obj->parent != NULL)) {
+ scm_error (edascm_object_state_sym, s_page_remove_,
+ _("Object ~A is attached to a complex or different page"),
+ scm_list_1 (obj_s), SCM_EOL);
+ }
+
+ if (curr_page == NULL) return obj_s;
+
+ o_emit_pre_change_notify (toplevel, obj);
+ s_page_remove (toplevel, page, obj);
+ page->CHANGED = 1; /* Ugh. */
+ /* If the object is currently selected, unselect it. */
+ o_selection_remove (toplevel, page->selection_list, obj);
+ o_emit_change_notify (toplevel, obj);
+
+ /* Object cleanup now managed by Guile. */
+ edascm_c_set_gc (obj_s, 1);
+ return obj_s;
+}
+
+/*!
+ * \brief Create the (geda core page) Scheme module.
+ * \par Function Description
+ * Defines procedures in the (geda core page) module. The module can
+ * be accessed using (use-modules (geda core page)).
+ */
+static void
+init_module_geda_core_page ()
+{
+ /* Register the functions */
+ #include "scheme_page.x"
+
+ /* Add them to the module's public definitions. */
+
+ scm_c_export (s_active_pages, s_new_page, s_page_filename, s_page_contents,
+ s_object_page, s_page_append_, s_page_remove_, NULL);
+}
+
+/*!
+ * \brief Initialise the basic gEDA page manipulation procedures.
+ * \par Function Description
+ * Registers some Scheme procedures for working with #PAGE
+ * smobs. Should only be called by scheme_api_init().
+ */
+void
+edascm_init_page ()
+{
+ /* Define the (geda core page) module */
+ scm_c_define_module ("geda core page",
+ init_module_geda_core_page,
+ NULL);
+}
commit 83e845d1ec88528eb94e58105bf62cb1f5742218
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Complex objects.
Support for working with complex objects. Because Guile supports
complex numbers natively, using the word "complex" in function names
etc. is confusing. In the public Scheme API the word "component" is
used instead.
This patch implements support for inspecting and modifying components,
as well as for creating new, empty embedded components. It does not
include support for creating components from files or from the
component library.
diff --git a/libgeda/include/libgedaguile_priv.h b/libgeda/include/libgedaguile_priv.h
index 83f4472..3f0335f 100644
--- a/libgeda/include/libgedaguile_priv.h
+++ b/libgeda/include/libgedaguile_priv.h
@@ -29,6 +29,7 @@
void edascm_init_smob ();
void edascm_init_toplevel ();
void edascm_init_object ();
+void edascm_init_complex ();
/* ---------------------------------------- */
@@ -124,3 +125,7 @@ void edascm_c_set_gc (SCM smob, int gc);
GList *edascm_to_object_glist (SCM objs, const char *subr);
SCM edascm_from_object_glist (const GList *objs);
int edascm_is_object_type (SCM smob, int type);
+
+/* ---------------------------------------- */
+
+extern SCM edascm_object_state_sym;
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 8970893..e4b35f4 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -14,7 +14,8 @@ TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0011-object-box.scm \
unit-tests/t0012-object-circle.scm \
unit-tests/t0013-object-arc.scm\
- unit-tests/t0014-object-text.scm
+ unit-tests/t0014-object-text.scm \
+ unit-tests/t0015-object-complex.scm
dist_noinst_DATA = unit-test.scm $(TESTS)
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index ea4b356..6cd95ca 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -22,6 +22,7 @@
; Import C procedures
#:use-module (geda core smob)
#:use-module (geda core object)
+ #:use-module (geda core complex)
; Optional arguments
#:use-module (ice-9 optargs))
@@ -513,3 +514,99 @@
;; both
(define-public (text-attribute-mode t)
(list-ref (text-info t) 6))
+
+;;;; Component objects
+;;
+;; In the gEDA source code, these are normally called "complex"
+;; objects. However, as Guile supports complex numbers, and the
+;; procedures related to working with complex numbers use the word
+;; "complex" to describe them, this API uses "component" in order to
+;; remove the ambiguity.
+
+;; component? c
+;;
+;; Returns #t if c is a gEDA component object.
+(define-public (component? c)
+ (object-type? c 'complex))
+
+;; set-component! c position angle mirror locked
+;;
+;; Sets the parameters of a component object c. position is the point
+;; (x . y) at which the component object is located. angle is the
+;; rotation angle of the component object in degrees, and must be 0, 90,
+;; 180, or 270. If mirror is true, the component object will be
+;; flipped, and if locked is true, it will be non-selectable in an
+;; editor.
+(define-public (set-component! c position angle mirror locked)
+ (%set-complex! c (car position) (cdr position) angle mirror locked))
+
+;; make-component basename position angle mirror locked
+;;
+;; Make a new, empty embedded component object with the given basename
+;; and parameters. See set-component! for full description of
+;; arguments.
+(define-public (make-component basename . args)
+ (let ((c (%make-complex basename)))
+ (apply set-component! c args)))
+
+;; component-info c
+;;
+;; Returns the parameters of the component object c as a list of the
+;; form:
+;;
+;; (basename (x . y) angle mirror locked)
+(define-public (component-info c)
+ (let* ((params (%complex-info c))
+ (tail (list-tail params 3))
+ (position (list-tail params 1)))
+ (set-car! position (cons (list-ref position 0)
+ (list-ref position 1)))
+ (set-cdr! position tail)
+ params))
+
+;; component-basename c
+;;
+;; Returns the basename of the component object c.
+(define-public (component-basename c)
+ (list-ref (component-info c) 0))
+
+;; component-position c
+;;
+;; Returns the position of the component object c.
+(define-public (component-position c)
+ (list-ref (component-info c) 1))
+
+;; component-angle c
+;;
+;; Returns the rotation angle of the component object c.
+(define-public (component-angle c)
+ (list-ref (component-info c) 2))
+
+;; component-mirror? c
+;;
+;; Returns #t if the component object c is mirrored.
+(define-public (component-mirror? c)
+ (list-ref (component-info c) 3))
+
+;; component-locked? c
+;;
+;; Returns #t if the component object c is non-selectable.
+(define-public (component-locked? c)
+ (list-ref (component-info c) 4))
+
+;; component-contents c
+;;
+;; Returns a list of the primitive objects which make up the component
+;; object c.
+(define-public component-contents %complex-contents)
+
+;; component-append! c obj
+;;
+;; Adds obj to the primitive objects of the component c. Returns obj.
+(define-public component-append! %complex-append!)
+
+;; component-remove! c obj
+;;
+;; Removes obj from the primitive objects of the component c. Returns
+;; obj.
+(define-public component-remove! %complex-remove!)
diff --git a/libgeda/scheme/unit-tests/t0015-object-complex.scm b/libgeda/scheme/unit-tests/t0015-object-complex.scm
new file mode 100644
index 0000000..d719847
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0015-object-complex.scm
@@ -0,0 +1,72 @@
+;; Test Scheme procedures related to component objects.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'component
+ (let ((a (make-component "test component" '(1 . 2) 0 #t #f)))
+
+ (assert-equal 'complex (object-type a))
+
+ (assert-true (component? a))
+
+ (assert-equal "test component" (component-basename a))
+ (assert-equal '(1 . 2) (component-position a))
+ (assert-equal 0 (component-angle a))
+ (assert-true (component-mirror? a))
+ (assert-true (not (component-locked? a)))
+
+ (assert-equal (list (component-basename a) (component-position a)
+ (component-angle a) (component-mirror? a)
+ (component-locked? a))
+ (component-info a))
+
+ (set-component! a '(3 . 4) 90 #f #t)
+
+ (assert-equal '(3 . 4) (component-position a))
+ (assert-equal 90 (component-angle a))
+ (assert-true (not (component-mirror? a)))
+ (assert-true (component-locked? a))
+
+ (assert-thrown 'misc-error
+ (set-component! a '(3 . 4) 45 #f #t))))
+
+(begin-test 'component-append
+ (let ((A (make-component "test component" '(1 . 2) 0 #t #f))
+ (B (make-component "test component" '(1 . 2) 0 #t #f))
+ (x (make-line '(0 . 0) '(2 . 0)))
+ (y (make-line '(0 . 0) '(0 . 2))))
+
+ (assert-equal '() (component-contents A))
+
+ (assert-equal x (component-append! A x))
+ (assert-equal (list x) (component-contents A))
+
+ (assert-equal x (component-append! A x))
+ (assert-equal (list x) (component-contents A))
+
+ (assert-equal y (component-append! A y))
+ (assert-equal (list x y) (component-contents A))
+
+ (assert-thrown 'object-state
+ (component-append! B x))))
+
+(begin-test 'component-remove
+ (let ((A (make-component "test component" '(1 . 2) 0 #t #f))
+ (B (make-component "test component" '(1 . 2) 0 #t #f))
+ (x (make-line '(0 . 0) '(2 . 0)))
+ (y (make-line '(0 . 0) '(0 . 2))))
+
+ (component-append! A x)
+ (assert-equal x (component-remove! A x))
+ (assert-equal '() (component-contents A))
+ (assert-equal x (component-remove! A x))
+ (assert-equal x (component-remove! B x))
+
+ (component-append! A x)
+ (component-append! A y)
+ (assert-equal x (component-remove! A x))
+ (assert-equal (list y) (component-contents A))
+
+ (assert-thrown 'object-state
+ (component-remove! B y))))
diff --git a/libgeda/src/Makefile.am b/libgeda/src/Makefile.am
index 9db26e4..8c816a3 100644
--- a/libgeda/src/Makefile.am
+++ b/libgeda/src/Makefile.am
@@ -3,15 +3,18 @@
lib_LTLIBRARIES = libgeda.la
BUILT_SOURCES = \
+ scheme_init.x \
scheme_smob.x \
scheme_toplevel.x \
- scheme_object.x
+ scheme_object.x \
+ scheme_complex.x
scheme_api_sources = \
scheme_init.c \
scheme_smob.c \
scheme_toplevel.c \
- scheme_object.c
+ scheme_object.c\
+ scheme_complex.c
libgeda_la_SOURCES = \
$(scheme_api_sources) \
diff --git a/libgeda/src/scheme_complex.c b/libgeda/src/scheme_complex.c
new file mode 100644
index 0000000..216f5e3
--- /dev/null
+++ b/libgeda/src/scheme_complex.c
@@ -0,0 +1,320 @@
+/* gEDA - GPL Electronic Design Automation
+ * libgeda - gEDA's library - Scheme API
+ * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+ */
+
+/*!
+ * \file scheme_complex.c
+ * \brief Scheme API complex object manipulation procedures.
+ */
+
+#include <config.h>
+
+#include "libgeda_priv.h"
+#include "libgedaguile_priv.h"
+
+/*! \brief Create a new complex object.
+ * \par Function Description
+ * Creates a new, empty complex object, with the given \a basename and
+ * with all other parameters set to default values. It is initially set
+ * to be embedded.
+ *
+ * \note Scheme API: Implements the %make-complex procedure in the
+ * (geda core complex) module.
+ *
+ * \return a newly-created complex object.
+ */
+SCM_DEFINE (make_complex, "%make-complex", 1, 0, 0,
+ (SCM basename_s), "Create a new complex object.")
+{
+ SCM_ASSERT (scm_is_string (basename_s), basename_s, SCM_ARG1, s_make_complex);
+
+ char *tmp = scm_to_locale_string (basename_s);
+ OBJECT *obj = o_complex_new_embedded (edascm_c_current_toplevel (),
+ OBJ_COMPLEX, DEFAULT_COLOR, 0, 0, 0,
+ FALSE, tmp, TRUE);
+ free (tmp);
+
+ SCM result = edascm_from_object (obj);
+
+ /* At the moment, the only pointer to the object is owned by the
+ * smob. */
+ edascm_c_set_gc (result, TRUE);
+
+ return result;
+}
+
+/*! \brief Set complex object parameters.
+ * \par Function Description
+ * Modifies the complex object \a complex_s by setting its parameters
+ * to new values.
+ *
+ * \note Scheme API: Implements the %set-complex! procedure in the
+ * (geda core complex) module.
+ *
+ * \param complex_s the complex object to modify.
+ * \param x_s the new x-coordinate of the complex object.
+ * \param y_s the new y-coordinate of the complex object.
+ * \param angle_s the new rotation angle.
+ * \param mirror_s whether the complex object should be mirrored.
+ * \param locked_s whether the complex object should be locked.
+ *
+ * \return the modified \a complex_s.
+ */
+SCM_DEFINE (set_complex, "%set-complex!", 6, 0, 0,
+ (SCM complex_s, SCM x_s, SCM y_s, SCM angle_s, SCM mirror_s,
+ SCM locked_s), "Set complex object parameters")
+{
+ SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
+ SCM_ARG1, s_set_complex);
+ SCM_ASSERT (scm_is_integer (x_s), x_s, SCM_ARG2, s_set_complex);
+ SCM_ASSERT (scm_is_integer (y_s), y_s, SCM_ARG3, s_set_complex);
+ SCM_ASSERT (scm_is_integer (angle_s), angle_s, SCM_ARG4, s_set_complex);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (complex_s);
+
+ /* Angle */
+ int angle = scm_to_int (angle_s);
+ switch (angle) {
+ case 0:
+ case 90:
+ case 180:
+ case 270:
+ /* These are all fine. */
+ break;
+ default:
+ /* Otherwise, not fine. */
+ scm_misc_error (s_set_complex,
+ _("Invalid complex angle ~A. Must be 0, 90, 180, or 270 degrees"),
+ scm_list_1 (angle_s));
+ }
+
+ o_emit_pre_change_notify (toplevel, obj);
+
+ obj->complex->x = scm_to_int (x_s);
+ obj->complex->y = scm_to_int (y_s);
+ obj->complex->angle = angle;
+ obj->complex->mirror = scm_is_true (mirror_s);
+ obj->sel_func = scm_is_true (locked_s) ? NULL : select_func;
+
+ o_complex_recalc (toplevel, obj); /* We need to do this explicitly... */
+
+ o_emit_change_notify (toplevel, obj);
+
+ return complex_s;
+}
+
+/*! \brief Get complex object parameters.
+ * \par Function Description
+ * Retrieves the parameters of a complex object. The return value is a
+ * list of parameters:
+ *
+ * -# Basename
+ * -# Base x-coordinate.
+ * -# Base y-coordinate.
+ * -# Rotation angle.
+ * -# Whether object is mirrored.
+ * -# Whether object is locked.
+ *
+ * \note Scheme API: Implements the %complex-info procedure in the
+ * (geda core complex) module.
+ *
+ * \param complex_s the complex object to inspect.
+ * \return a list of complex object parameters.
+ */
+SCM_DEFINE (complex_info, "%complex-info", 1, 0, 0,
+ (SCM complex_s), "Get complex object parameters.")
+{
+ SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
+ SCM_ARG1, s_complex_info);
+
+ OBJECT *obj = edascm_to_object (complex_s);
+
+ return scm_list_n (scm_from_locale_string (obj->complex_basename),
+ scm_from_int (obj->complex->x),
+ scm_from_int (obj->complex->y),
+ scm_from_int (obj->complex->angle),
+ obj->complex->mirror ? SCM_BOOL_T : SCM_BOOL_F,
+ (obj->sel_func == NULL) ? SCM_BOOL_T : SCM_BOOL_F,
+ SCM_UNDEFINED);
+}
+
+/*! \brief Get the contents of a complex object.
+ * \par Function Description
+ * Retrieves a list of the primitive objects that make up a complex object.
+ *
+ * \note Scheme API: Implements the %complex-contents procedure in the
+ * (geda core complex) module.
+ *
+ * \param complex_s a complex object.
+ * \return a list of primitive objects.
+ */
+SCM_DEFINE (complex_contents, "%complex-contents", 1, 0, 0,
+ (SCM complex_s), "Get complex object contents.")
+{
+ SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
+ SCM_ARG1, s_complex_contents);
+
+ OBJECT *obj = edascm_to_object (complex_s);
+
+ return edascm_from_object_glist (obj->complex->prim_objs);
+}
+
+/*! \brief Add a primitive object to a complex object.
+ * \par Function Description
+ * Adds \a obj_s to \a complex_s. If \a obj_s is already attached to
+ * another complex object or to a #PAGE, or if \a obj_s is itself a
+ * complex object, throws a Scheme error. If \a obj_s is already
+ * attached to \a complex_s, does nothing.
+ *
+ * \note Scheme API: Implements the %complex-append! procedure of the
+ * (geda core complex) module.
+ *
+ * \param complex_s complex object to modify.
+ * \param obj_s primitive object to add.
+ * \return \a obj_s.
+ */
+SCM_DEFINE (complex_append, "%complex-append!", 2, 0, 0,
+ (SCM complex_s, SCM obj_s),
+ "Add a primitive object to a complex object")
+{
+ /* Ensure that the arguments have the correct types. */
+ SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
+ SCM_ARG1, s_complex_append);
+ SCM_ASSERT ((EDASCM_OBJECTP (obj_s)
+ && !edascm_is_object_type (obj_s, OBJ_COMPLEX)
+ && !edascm_is_object_type (obj_s, OBJ_PLACEHOLDER)),
+ obj_s, SCM_ARG2, s_complex_append);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *parent = edascm_to_object (complex_s);
+ OBJECT *child = edascm_to_object (obj_s);
+
+ /* Check that object is not already attached to a page or a
+ different complex. */
+ if ((o_get_page (toplevel, child) != NULL)
+ || ((child->parent != NULL) && (child->parent != parent))) {
+ scm_error (edascm_object_state_sym,
+ s_complex_append,
+ _("Object ~A is already attached to something"),
+ scm_list_1 (obj_s), SCM_EOL);
+ }
+
+ if (child->parent == parent) return obj_s;
+
+ /* Object cleanup now managed by C code. */
+ edascm_c_set_gc (obj_s, 0);
+
+ /* Don't need to emit change notifications for the child because
+ * it's guaranteed not to be present in a page at this point. */
+ o_emit_pre_change_notify (toplevel, parent);
+
+ parent->complex->prim_objs =
+ g_list_append (parent->complex->prim_objs, child);
+ child->parent = parent;
+
+ o_complex_recalc (toplevel, parent);
+
+ o_emit_change_notify (toplevel, parent);
+
+ return obj_s;
+}
+
+/*! \brief Remove a primitive object from a complex object.
+ * \par Function Description
+ * Removes \a obj_s from \a complex_s. If \a obj_s is attached to a
+ * #PAGE or to a complex object other than \a complex_s, throws a
+ * Scheme error. If \a obj_s is unattached, does nothing.
+ *
+ * \note Scheme API: Implements the %complex-remove! procedure of the
+ * (geda core complex) module.
+ *
+ * \param complex_s complex object to modify.
+ * \param obj_s primitive object to remove.
+ * \return \a obj_s.
+ */
+SCM_DEFINE (complex_remove, "%complex-remove!", 2, 0, 0,
+ (SCM complex_s, SCM obj_s),
+ "Remove a primitive object from a complex object")
+{
+ /* Ensure that the arguments have the correct types. */
+ SCM_ASSERT (edascm_is_object_type (complex_s, OBJ_COMPLEX), complex_s,
+ SCM_ARG1, s_complex_remove);
+ SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s, SCM_ARG2, s_complex_remove);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *parent = edascm_to_object (complex_s);
+ OBJECT *child = edascm_to_object (obj_s);
+
+ /* Check that object is not attached to a page or a different complex. */
+ if ((o_get_page (toplevel, child) != NULL)
+ || ((child->parent != NULL) && (child->parent != parent))) {
+ scm_error (edascm_object_state_sym, s_complex_remove,
+ _("Object ~A is attached to a page or a different complex"),
+ scm_list_1 (obj_s), SCM_EOL);
+ }
+
+ if (child->parent == NULL) return obj_s;
+
+ /* Don't need to emit change notifications for the child because
+ * only the parent will remain in the page. */
+ o_emit_pre_change_notify (toplevel, parent);
+
+ parent->complex->prim_objs =
+ g_list_remove_all (parent->complex->prim_objs, child);
+ child->parent = NULL;
+
+ o_emit_change_notify (toplevel, parent);
+
+ /* Object cleanup now managed by Guile. */
+ edascm_c_set_gc (obj_s, 1);
+ return obj_s;
+}
+
+/*!
+ * \brief Create the (geda core complex) Scheme module.
+ * \par Function Description
+ * Defines procedures in the (geda core complex) module. The module can
+ * be accessed using (use-modules (geda core complex)).
+ */
+static void
+init_module_geda_core_complex ()
+{
+ /* Register the functions and symbols */
+ #include "scheme_complex.x"
+
+ /* Add them to the module's public definitions. */
+ scm_c_export (s_make_complex, s_set_complex, s_complex_info,
+ s_complex_contents, s_complex_append, s_complex_remove,
+ NULL);
+}
+
+/*!
+ * \brief Initialise the basic gEDA complex object manipulation procedures.
+ * \par Function Description
+ * Registers some Scheme procedures for working with complex #OBJECT
+ * smobs. Should only be called by scheme_api_init().
+ */
+void
+edascm_init_complex ()
+{
+ /* Define the (geda core object) module */
+ scm_c_define_module ("geda core complex",
+ init_module_geda_core_complex,
+ NULL);
+}
diff --git a/libgeda/src/scheme_init.c b/libgeda/src/scheme_init.c
index f32cd31..ebc62da 100644
--- a/libgeda/src/scheme_init.c
+++ b/libgeda/src/scheme_init.c
@@ -29,6 +29,8 @@
/*! Non-zero if the Scheme API has been initialised. */
static int init_called = 0;
+SCM_GLOBAL_SYMBOL (edascm_object_state_sym, "object-state");
+
/*! \brief Initialise the Scheme API.
* \par Function Description
* Registers all modules, procedures and variables exported by the
@@ -40,7 +42,10 @@ edascm_init ()
if (init_called) return;
init_called = 1;
+ #include "scheme_init.x"
+
edascm_init_smob ();
edascm_init_toplevel ();
edascm_init_object ();
+ edascm_init_complex ();
}
commit e70250b1f7776e40dcada0d2c0bc3d9d8bc9a8df
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Text objects.
Basic support for text objects.
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 8a8c3db..8970893 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -13,7 +13,8 @@ TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0010-object-line.scm \
unit-tests/t0011-object-box.scm \
unit-tests/t0012-object-circle.scm \
- unit-tests/t0013-object-arc.scm
+ unit-tests/t0013-object-arc.scm\
+ unit-tests/t0014-object-text.scm
dist_noinst_DATA = unit-test.scm $(TESTS)
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 6e510d8..ea4b356 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -391,3 +391,125 @@
;; Returns #t if x is a gEDA picture object.
(define-public (picture? x)
(object-type? x 'picture))
+
+;;;; Text
+
+;; text? t
+;;
+;; Returns #t if t is a gEDA text object.
+(define-public (text? t)
+ (object-type? t 'text))
+
+;; set-text! t anchor align angle string size visible show [color]
+;;
+;; Sets the parameters of a text object. anchor is the point (x . y)
+;; at which the text is anchored. align is the position of the anchor
+;; relative to the text, and must be one of the following symbols:
+;;
+;; lower-left
+;; middle-left
+;; upper-left
+;; lower-center
+;; middle-center
+;; upper-center
+;; lower-right
+;; middle-right
+;; upper-right
+;;
+;; string is the new value of the text object. size is the font size.
+;; If visible is #f, the text object will be flagged as invisible;
+;; otherwise, it will be visible. When the text is an attribute, show
+;; determines which parts of the string will be displayed, and must be
+;; one of the following symbols:
+;;
+;; name
+;; value
+;; both
+;;
+;; The optional color argument is the colormap index of the color
+;; with which to draw the text. If color is not specified, the
+;; default color is used.
+(define*-public (set-text! t anchor align angle string size visible show
+ #:optional color)
+ (%set-text! t (car anchor) (cdr anchor) align angle string size visible show
+ (if (not color) (object-color t) color)))
+
+;; make-text! anchor align angle string size visible show [color]
+;;
+;; Create a new text object. See set-text! for description of arguments.
+(define*-public (make-text . args)
+ (let ((t (%make-text)))
+ (apply set-text! t args)))
+
+;; text-info t
+;;
+;; Returns the parameters of the text object t as a list of the form:
+;;
+;; ((anchor-x . anchor-y) align angle string size visible show color)
+;;
+;; See set-text! for description of these parameters.
+(define-public (text-info t)
+ (let* ((params (%text-info t))
+ (tail (cddr params)))
+ (cons (cons (list-ref params 0)
+ (list-ref params 1))
+ tail)))
+
+;; text-anchor t
+;;
+;; Returns the anchor point of the text object t.
+(define-public (text-anchor t)
+ (list-ref (text-info t) 0))
+
+;; text-align t
+;;
+;; Returns the text alignment of the text object t. The returned
+;; value will be one of the following symbols:
+;;
+;; lower-left
+;; middle-left
+;; upper-left
+;; lower-center
+;; middle-center
+;; upper-center
+;; lower-right
+;; middle-right
+;; upper-right
+(define-public (text-align t)
+ (list-ref (text-info t) 1))
+
+;; text-angle t
+;;
+;; Returns the angle of the text object t.
+(define-public (text-angle t)
+ (list-ref (text-info t) 2))
+
+;; text-string t
+;;
+;; Returns the string contained in the text object t.
+(define-public (text-string t)
+ (list-ref (text-info t) 3))
+
+;; text-size t
+;;
+;; Returns the font size of the text object t.
+(define-public (text-size t)
+ (list-ref (text-info t) 4))
+
+;; text-visible? t
+;;
+;; Returns #t if the text object t is set to be visible.
+(define-public (text-visible? t)
+ (list-ref (text-info t) 5))
+
+;; text-attribute-mode t
+;;
+;; Returns the visibility mode of the text object t when the string
+;; contained in t is a valid attribute. The returned value will be
+;; one of the following symbols:
+;;
+;; name
+;; value
+;; both
+(define-public (text-attribute-mode t)
+ (list-ref (text-info t) 6))
diff --git a/libgeda/scheme/unit-tests/t0014-object-text.scm b/libgeda/scheme/unit-tests/t0014-object-text.scm
new file mode 100644
index 0000000..3808237
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0014-object-text.scm
@@ -0,0 +1,56 @@
+;; Test Scheme procedures related to text objects.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'text
+ (let ((a (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both 21))
+ (b (make-text '(1 . 2) 'lower-left 0 "test text" 10 #t 'both)))
+
+ (assert-equal 'text (object-type a))
+
+ (assert-true (text? a))
+ (assert-true (text? b))
+
+ (assert-equal '(1 . 2) (text-anchor a))
+ (assert-equal 'lower-left (text-align a))
+ (assert-equal 0 (text-angle a))
+ (assert-equal "test text" (text-string a))
+ (assert-equal 10 (text-size a))
+ (assert-true (text-visible? a))
+ (assert-equal 'both (text-attribute-mode a))
+ (assert-equal 21 (object-color a))
+
+ (assert-equal (text-anchor a) (text-anchor b))
+ (assert-equal (text-align a) (text-align b))
+ (assert-equal (text-angle a) (text-angle b))
+ (assert-equal (text-string a) (text-string b))
+ (assert-equal (text-size a) (text-size b))
+ (assert-equal (text-visible? a) (text-visible? b))
+ (assert-equal (text-attribute-mode a) (text-attribute-mode b))
+
+ (assert-equal (list (text-anchor a) (text-align a) (text-angle a)
+ (text-string a) (text-size a) (text-visible? a)
+ (text-attribute-mode a) (object-color a))
+ (text-info a))
+
+ (set-text! a '(3 . 4) 'upper-right 180 "more text" 20 #f 'name)
+ (assert-equal '(3 . 4) (text-anchor a))
+ (assert-equal 'upper-right (text-align a))
+ (assert-equal 180 (text-angle a))
+ (assert-equal "more text" (text-string a))
+ (assert-equal 20 (text-size a))
+ (assert-true (not (text-visible? a)))
+ (assert-equal 'name (text-attribute-mode a))
+ (assert-equal 21 (object-color a))
+
+ (set-text! a '(3 . 4) 'upper-right 180 "more text" 20 #f 'name 22)
+ (assert-equal 22 (object-color a))
+
+ (assert-thrown 'misc-error
+ (set-text! a '(3 . 4) 'fnord 180 "more text" 20 #f 'name))
+ (assert-thrown 'misc-error
+ (set-text! a '(3 . 4) 'upper-right 180 "more text" 20 #f 'fnord))
+ (assert-thrown 'misc-error
+ (set-text! a '(3 . 4) 'upper-right 1 "more text" 20 #f 'name))
+ ))
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index 391e51b..cb92032 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -40,6 +40,20 @@ SCM_SYMBOL (path_sym , "path");
SCM_SYMBOL (pin_sym , "pin");
SCM_SYMBOL (arc_sym , "arc");
+SCM_SYMBOL (lower_left_sym , "lower-left");
+SCM_SYMBOL (middle_left_sym , "middle-left");
+SCM_SYMBOL (upper_left_sym , "upper-left");
+SCM_SYMBOL (lower_center_sym , "lower-center");
+SCM_SYMBOL (middle_center_sym , "middle-center");
+SCM_SYMBOL (upper_center_sym , "upper-center");
+SCM_SYMBOL (lower_right_sym , "lower-right");
+SCM_SYMBOL (middle_right_sym , "middle-right");
+SCM_SYMBOL (upper_right_sym , "upper-right");
+
+SCM_SYMBOL (name_sym , "name");
+SCM_SYMBOL (value_sym , "value");
+SCM_SYMBOL (both_sym , "both");
+
/*! \brief Convert a Scheme object list to a GList.
* \par Function Description
* Takes a Scheme list of #OBJECT smobs, and returns a GList
@@ -820,6 +834,238 @@ SCM_DEFINE (arc_info, "%arc-info", 1, 0, 0,
SCM_UNDEFINED);
}
+/*! \brief Create a new text item.
+ * \par Function Description
+ * Creates a new text object, with all its parameters set to default
+ * values.
+ *
+ * \note Scheme API: Implements the %make-text procedure in the
+ * (geda core object) module.
+ *
+ * \return a newly-created text object.
+ */
+SCM_DEFINE (make_text, "%make-text", 0, 0, 0,
+ (), "Create a new text object.")
+{
+ OBJECT *obj = o_text_new (edascm_c_current_toplevel (),
+ OBJ_TEXT, DEFAULT_COLOR,
+ 0, 0, LOWER_LEFT, 0, "", 10,
+ VISIBLE, SHOW_NAME_VALUE);
+
+ SCM result = edascm_from_object (obj);
+
+ /* At the moment, the only pointer to the object is owned by the
+ * smob. */
+ edascm_c_set_gc (result, 1);
+
+ return result;
+}
+
+/*! \brief Set text parameters.
+ * \par Function Description
+ * Modifies a text object by setting its parameters to new values.
+ *
+ * The alignment \a align_s should be a symbol of the form "x-y" where
+ * x can be one of "lower", "middle", or "upper", and y can be one of
+ * "left", "center" or "right". \a show_s determines which parts of an
+ * attribute-formatted string should be shown, and should be one of
+ * the symbols "name", "value" or "both".
+ *
+ * \note Scheme API: Implements the %set-text! procedure in the
+ * (geda core object) module.
+ *
+ * \param text_s the text object to modify.
+ * \param x_s the new x-coordinate of the anchor of the text.
+ * \param y_s the new y-coordinate of the anchor of the text.
+ * \param align_s the new alignment of the text on the anchor.
+ * \param angle_s the angle the text in degrees (0, 90, 180 or 270).
+ * \param string_s the new string to display.
+ * \param size_s the new text size.
+ * \param visible_s the new text visibility (SCM_BOOL_T or SCM_BOOL_F).
+ * \param show_s the new attribute part visibility setting.
+ * \param color_s the colormap index of the color to be used for
+ * drawing the text.
+ *
+ * \return the modified text object.
+ */
+SCM_DEFINE (set_text, "%set-text!", 10, 0, 0,
+ (SCM text_s, SCM x_s, SCM y_s, SCM align_s, SCM angle_s,
+ SCM string_s, SCM size_s, SCM visible_s, SCM show_s, SCM color_s),
+ "Set text parameters")
+{
+ SCM_ASSERT (edascm_is_object_type (text_s, OBJ_TEXT), text_s,
+ SCM_ARG1, s_set_text);
+ SCM_ASSERT (scm_is_integer (x_s), x_s, SCM_ARG2, s_set_text);
+ SCM_ASSERT (scm_is_integer (y_s), y_s, SCM_ARG3, s_set_text);
+ SCM_ASSERT (scm_is_symbol (align_s), align_s, SCM_ARG4, s_set_text);
+ SCM_ASSERT (scm_is_integer (angle_s), angle_s, SCM_ARG5, s_set_text);
+ SCM_ASSERT (scm_is_string (string_s), string_s, SCM_ARG6, s_set_text);
+ SCM_ASSERT (scm_is_integer (size_s), size_s, SCM_ARG7, s_set_text);
+
+ SCM_ASSERT (scm_is_symbol (show_s), show_s, 9, s_set_text);
+ SCM_ASSERT (scm_is_integer (color_s), color_s, 10, s_set_text);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (text_s);
+
+ /* Alignment. Sadly we can't switch on pointers. :-( */
+ int align;
+ if (align_s == lower_left_sym) { align = LOWER_LEFT; }
+ else if (align_s == middle_left_sym) { align = MIDDLE_LEFT; }
+ else if (align_s == upper_left_sym) { align = UPPER_LEFT; }
+ else if (align_s == lower_center_sym) { align = LOWER_MIDDLE; }
+ else if (align_s == middle_center_sym) { align = MIDDLE_MIDDLE; }
+ else if (align_s == upper_center_sym) { align = UPPER_MIDDLE; }
+ else if (align_s == lower_right_sym) { align = LOWER_RIGHT; }
+ else if (align_s == middle_right_sym) { align = MIDDLE_RIGHT; }
+ else if (align_s == upper_right_sym) { align = UPPER_RIGHT; }
+ else {
+ scm_misc_error (s_set_text,
+ _("Invalid text alignment ~A."),
+ scm_list_1 (angle_s));
+ }
+
+ /* Angle */
+ int angle = scm_to_int (angle_s);
+ switch (angle) {
+ case 0:
+ case 90:
+ case 180:
+ case 270:
+ /* These are all fine. */
+ break;
+ default:
+ /* Otherwise, not fine. */
+ scm_misc_error (s_set_text,
+ _("Invalid text angle ~A. Must be 0, 90, 180, or 270 degrees"),
+ scm_list_1 (angle_s));
+ }
+
+ /* Visibility */
+ int visibility;
+ if (scm_is_false (visible_s)) {
+ visibility = INVISIBLE;
+ } else {
+ visibility = VISIBLE;
+ }
+
+ /* Name/value visibility */
+ int show;
+ if (show_s == name_sym) { show = SHOW_NAME; }
+ else if (show_s == value_sym) { show = SHOW_VALUE; }
+ else if (show_s == both_sym) { show = SHOW_NAME_VALUE; }
+ else {
+ scm_misc_error (s_set_text,
+ _("Invalid text name/value visibility ~A."),
+ scm_list_1 (angle_s));
+ }
+
+ /* Actually make changes */
+ o_emit_pre_change_notify (toplevel, obj);
+
+ obj->text->x = scm_to_int (x_s);
+ obj->text->y = scm_to_int (y_s);
+ obj->text->alignment = align;
+ obj->text->angle = angle;
+
+ obj->text->size = scm_to_int (size_s);
+ obj->visibility = visibility;
+ obj->show_name_value = show;
+
+ o_emit_change_notify (toplevel, obj);
+
+ char *tmp = scm_to_locale_string (string_s);
+ o_text_set_string (toplevel, obj, tmp);
+ free (tmp);
+
+ o_text_recreate (toplevel, obj);
+
+ /* Color */
+ o_set_color (toplevel, obj, scm_to_int (color_s));
+
+ return text_s;
+}
+
+/*! \brief Get text parameters.
+ * \par Function Description
+ * Retrieves the parameters of a text object. The return value is a
+ * list of parameters:
+ *
+ * -# X-coordinate of anchor of text
+ * -# Y-coordinate of anchor of text
+ * -# Alignment of text
+ * -# Angle of text
+ * -# The string contained in the text object
+ * -# Size of text
+ * -# Text visibility
+ * -# Which part(s) of an text attribute are shown
+ * -# Colormap index of color to be used for drawing the text
+ *
+ * \note Scheme API: Implements the %text-info procedure in the
+ * (geda core object) module.
+ *
+ * \param text_s the text object to inspect.
+ * \return a list of text parameters.
+ */
+SCM_DEFINE (text_info, "%text-info", 1, 0, 0,
+ (SCM text_s), "Get text parameters.")
+{
+ SCM_ASSERT (edascm_is_object_type (text_s, OBJ_TEXT),
+ text_s, SCM_ARG1, s_text_info);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (text_s);
+ SCM align_s, visible_s, show_s;
+
+ switch (obj->text->alignment) {
+ case LOWER_LEFT: align_s = lower_left_sym; break;
+ case MIDDLE_LEFT: align_s = middle_left_sym; break;
+ case UPPER_LEFT: align_s = upper_left_sym; break;
+ case LOWER_MIDDLE: align_s = lower_center_sym; break;
+ case MIDDLE_MIDDLE: align_s = middle_center_sym; break;
+ case UPPER_MIDDLE: align_s = upper_center_sym; break;
+ case LOWER_RIGHT: align_s = lower_right_sym; break;
+ case MIDDLE_RIGHT: align_s = middle_right_sym; break;
+ case UPPER_RIGHT: align_s = upper_right_sym; break;
+ default:
+ scm_misc_error (s_text_info,
+ _("Text object ~A has invalid text alignment ~A"),
+ scm_list_2 (text_s, scm_from_int (obj->text->alignment)));
+ }
+
+ switch (obj->visibility) {
+ case VISIBLE: visible_s = SCM_BOOL_T; break;
+ case INVISIBLE: visible_s = SCM_BOOL_F; break;
+ default:
+ scm_misc_error (s_text_info,
+ _("Text object ~A has invalid visibility ~A"),
+ scm_list_2 (text_s, scm_from_int (obj->visibility)));
+ }
+
+ switch (obj->show_name_value) {
+ case SHOW_NAME: show_s = name_sym; break;
+ case SHOW_VALUE: show_s = value_sym; break;
+ case SHOW_NAME_VALUE: show_s = both_sym; break;
+ default:
+ scm_misc_error (s_text_info,
+ _("Text object ~A has invalid text attribute visibility ~A"),
+ scm_list_2 (text_s, scm_from_int (obj->show_name_value)));
+ }
+
+ return scm_list_n (scm_from_int (obj->text->x),
+ scm_from_int (obj->text->y),
+ align_s,
+ scm_from_int (obj->text->angle),
+ scm_from_locale_string (o_text_get_string (toplevel, obj)),
+ scm_from_int (obj->text->size),
+ visible_s,
+ show_s,
+ scm_from_int (obj->color),
+ SCM_UNDEFINED);
+}
+
+
+
/*!
* \brief Create the (geda core object) Scheme module.
* \par Function Description
@@ -841,6 +1087,7 @@ init_module_geda_core_object ()
s_make_box, s_set_box, s_box_info,
s_make_circle, s_set_circle, s_circle_info,
s_make_arc, s_set_arc, s_arc_info,
+ s_make_text, s_set_text, s_text_info,
NULL);
}
commit 810d1982d5b9fcd5d73037292df0be090ce18d84
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Path and picture objects.
Just add some predicates for now.
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index dad5b59..6e510d8 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -375,3 +375,19 @@
;; Returns the end angle of the gEDA arc object a.
(define-public (arc-end-angle a)
(list-ref (arc-info a) 3))
+
+;;;; Paths
+
+;; path? x
+;;
+;; Returns #t if x is a gEDA path object.
+(define-public (path? x)
+ (object-type? x 'path))
+
+;;;; Pictures
+
+;; picture? x
+;;
+;; Returns #t if x is a gEDA picture object.
+(define-public (picture? x)
+ (object-type? x 'picture))
commit e461ca858a2d127c17bba84e17c31b626937ee00
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Arc objects.
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 88eb7aa..8a8c3db 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -12,7 +12,8 @@ TESTS_ENVIRONMENT = $(builddir)/../shell/geda-shell -q -L $(srcdir) \
TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0010-object-line.scm \
unit-tests/t0011-object-box.scm \
- unit-tests/t0012-object-circle.scm
+ unit-tests/t0012-object-circle.scm \
+ unit-tests/t0013-object-arc.scm
dist_noinst_DATA = unit-test.scm $(TESTS)
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index e5d860a..dad5b59 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -302,3 +302,76 @@
;; Returns the radius of the gEDA circle object c.
(define-public (circle-radius c)
(list-ref (circle-info c) 1))
+
+;;;; Arcs
+
+;; arc? x
+;;
+;; Returns #t if x is a gEDA arc object.
+(define-public (arc? a)
+ (object-type? a 'arc))
+
+;; set-arc! a center radius start-angle end-angle [color]
+;;
+;; Sets the parameters of an arc. center is the new coordinates (x
+;; . y) of the center of the arc, and radius is the new radius of the
+;; arc. start-angle and end-angle are the angles in degrees between
+;; which to draw the arc. The optional color argument is the new
+;; colormap index of the arc's color. Returns a after modifications.
+(define*-public (set-arc! a center radius start-angle end-angle
+ #:optional color)
+ (%set-arc! a
+ (car center) (cdr center)
+ radius start-angle end-angle
+ (if (not color)
+ (object-color a)
+ color)))
+
+;; make-arc center radius start-angle end-angle [color]
+;;
+;; Creates a new arc. center is the coordinates (x . y) of the center
+;; of the arc, and radius is the radius of the circle. start-angle
+;; and end-angle are the angles between which to draw the arc. The
+;; optional color argument is the colormap index of the color with
+;; which to draw the arc. If color is not specified, the default
+;; color is used.
+(define*-public (make-arc center radius start-angle end-angle #:optional color)
+ (let ((c (%make-arc)))
+ (set-arc! c center radius start-angle end-angle color)))
+
+;; arc-info c
+;;
+;; Returns the parameters of the arc a as a list of the form:
+;;
+;; ((center-x . center-y) radius start-angle end-angle color)
+(define-public (arc-info c)
+ (let* ((params (%arc-info c))
+ (tail (cddr params)))
+ (cons (cons (list-ref params 0)
+ (list-ref params 1))
+ tail)))
+
+;; arc-center a
+;;
+;; Returns the coordinates (x . y) of the center of the gEDA arc
+;; object c.
+(define-public (arc-center a)
+ (list-ref (arc-info a) 0))
+
+;; arc-radius a
+;;
+;; Returns the radius of the gEDA arc object a.
+(define-public (arc-radius a)
+ (list-ref (arc-info a) 1))
+
+;; arc-start-angle a
+;;
+;; Returns the start angle of the gEDA arc object a.
+(define-public (arc-start-angle a)
+ (list-ref (arc-info a) 2))
+
+;; arc-end-angle a
+;;
+;; Returns the end angle of the gEDA arc object a.
+(define-public (arc-end-angle a)
+ (list-ref (arc-info a) 3))
diff --git a/libgeda/scheme/unit-tests/t0013-object-arc.scm b/libgeda/scheme/unit-tests/t0013-object-arc.scm
new file mode 100644
index 0000000..d6c038a
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0013-object-arc.scm
@@ -0,0 +1,40 @@
+;; Test Scheme procedures related to arc objects.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'arcs
+ (let* ((a (make-arc '(1 . 2) 3 45 90 21))
+ (b (copy-object a)))
+
+ (assert-equal 'arc (object-type a))
+
+ (assert-true (arc? a))
+ (assert-true (arc? b))
+
+ (assert-equal '(1 . 2) (arc-center a))
+ (assert-equal 3 (arc-radius a))
+ (assert-equal 45 (arc-start-angle a))
+ (assert-equal 90 (arc-end-angle a))
+ (assert-equal (arc-center a) (arc-center b))
+ (assert-equal (arc-radius a) (arc-radius b))
+ (assert-equal (arc-start-angle a) (arc-start-angle b))
+ (assert-equal (arc-end-angle a) (arc-end-angle b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (arc-center a) (arc-radius a)
+ (arc-start-angle a) (arc-end-angle a)
+ (object-color a))
+ (arc-info a))
+
+ (set-arc! a '(5 . 6) 7 180 270)
+ (assert-equal '(5 . 6) (arc-center a))
+ (assert-equal 7 (arc-radius a))
+ (assert-equal 180 (arc-start-angle a))
+ (assert-equal 270 (arc-end-angle a))
+ (assert-equal 21 (object-color a))
+ (set-arc! a '(5 . 6) 7 180 270 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (arc-info a) 4))
+))
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index 8405183..391e51b 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -713,6 +713,113 @@ SCM_DEFINE (circle_info, "%circle-info", 1, 0, 0,
SCM_UNDEFINED);
}
+/*! \brief Create a new arc.
+ * \par Function Description
+ * Creates a new arc object, with all its parameters set to default
+ * values.
+ *
+ * \note Scheme API: Implements the %make-arc procedure in the
+ * (geda core object) module.
+ *
+ * \return a newly-created arc object.
+ */
+SCM_DEFINE (make_arc, "%make-arc", 0, 0, 0,
+ (), "Create a new arc object.")
+{
+ OBJECT *obj = o_arc_new (edascm_c_current_toplevel (),
+ OBJ_ARC, DEFAULT_COLOR,
+ 0, 0, 1, 0, 0);
+
+ SCM result = edascm_from_object (obj);
+
+ /* At the moment, the only pointer to the object is owned by the
+ * smob. */
+ edascm_c_set_gc (result, 1);
+
+ return result;
+}
+
+/*! \brief Set arc parameters.
+ * \par Function Description
+ * Modifies a arc object by setting its parameters to new values.
+ *
+ * \note Scheme API: Implements the %set-arc! procedure in the
+ * (geda core object) module.
+ *
+ * \param arc_s the arc object to modify.
+ * \param x_s the new x-coordinate of the center of the arc.
+ * \param y_s the new y-coordinate of the center of the arc.
+ * \param r_s the new radius of the arc.
+ * \param start_angle_s the start angle of the arc.
+ * \param end_angle_s the start angle of the arc.
+ * \param color_s the colormap index of the color to be used for
+ * drawing the arc.
+ *
+ * \return the modified arc object.
+ */
+SCM_DEFINE (set_arc, "%set-arc!", 7, 0, 0,
+ (SCM arc_s, SCM x_s, SCM y_s, SCM r_s, SCM start_angle_s,
+ SCM end_angle_s, SCM color_s),
+ "Set arc parameters")
+{
+ SCM_ASSERT (edascm_is_object_type (arc_s, OBJ_ARC), arc_s,
+ SCM_ARG1, s_set_arc);
+ SCM_ASSERT (scm_is_integer (x_s), x_s, SCM_ARG2, s_set_arc);
+ SCM_ASSERT (scm_is_integer (y_s), y_s, SCM_ARG3, s_set_arc);
+ SCM_ASSERT (scm_is_integer (r_s), r_s, SCM_ARG4, s_set_arc);
+ SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG5, s_set_arc);
+ SCM_ASSERT (scm_is_integer (start_angle_s),
+ start_angle_s, SCM_ARG3, s_set_arc);
+ SCM_ASSERT (scm_is_integer (end_angle_s),
+ end_angle_s, SCM_ARG4, s_set_arc);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (arc_s);
+ o_arc_modify (toplevel, obj, scm_to_int(x_s), scm_to_int(y_s),
+ ARC_CENTER);
+ o_arc_modify (toplevel, obj, scm_to_int(r_s), 0, ARC_RADIUS);
+ o_arc_modify (toplevel, obj, scm_to_int(start_angle_s), 0, ARC_START_ANGLE);
+ o_arc_modify (toplevel, obj, scm_to_int(end_angle_s), 0, ARC_END_ANGLE);
+ o_set_color (toplevel, obj, scm_to_int (color_s));
+
+ return arc_s;
+}
+
+/*! \brief Get arc parameters.
+ * \par Function Description
+ * Retrieves the parameters of a arc object. The return value is a
+ * list of parameters:
+ *
+ * -# X-coordinate of center of arc
+ * -# Y-coordinate of center of arc
+ * -# Radius of arc
+ * -# Start angle of arc
+ * -# End angle of arc
+ * -# Colormap index of color to be used for drawing the arc
+ *
+ * \note Scheme API: Implements the %arc-info procedure in the
+ * (geda core object) module.
+ *
+ * \param arc_s the arc object to inspect.
+ * \return a list of arc parameters.
+ */
+SCM_DEFINE (arc_info, "%arc-info", 1, 0, 0,
+ (SCM arc_s), "Get arc parameters.")
+{
+ SCM_ASSERT (edascm_is_object_type (arc_s, OBJ_ARC),
+ arc_s, SCM_ARG1, s_arc_info);
+
+ OBJECT *obj = edascm_to_object (arc_s);
+
+ return scm_list_n (scm_from_int (obj->arc->x),
+ scm_from_int (obj->arc->y),
+ scm_from_int (obj->arc->width / 2),
+ scm_from_int (obj->arc->start_angle),
+ scm_from_int (obj->arc->end_angle),
+ scm_from_int (obj->color),
+ SCM_UNDEFINED);
+}
+
/*!
* \brief Create the (geda core object) Scheme module.
* \par Function Description
@@ -733,6 +840,7 @@ init_module_geda_core_object ()
s_set_line, s_line_info,
s_make_box, s_set_box, s_box_info,
s_make_circle, s_set_circle, s_circle_info,
+ s_make_arc, s_set_arc, s_arc_info,
NULL);
}
commit 2d9bb54a420197facfe93712fa0e60c6ef35bdf9
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Pin objects.
Re-uses the line modification routines for working on pins. Note that
the libgeda C API provides a flag for choosing which end of a pin
should be connectable, but the Scheme API hides this flag, and from
the point of view of Scheme code the connectable end of a pin is
always the start.
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 04088a4..e5d860a 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -49,11 +49,11 @@
;; set-line! l start end [color]
;;
-;; Sets the parameters of a line, net or bus object l. start is the
-;; new coordinates (x . y) of the start of the line, and end is the
-;; new coordinates of the end of the line. The optional color argument
-;; is the new colormap index of the line's color. Returns l after
-;; modifications.
+;; Sets the parameters of a line, net, bus or pin object l. start is
+;; the new coordinates (x . y) of the start of the line (for pins,
+;; this is the connectable point), and end is the new coordinates of the
+;; end of the line. The optional color argument is the new colormap
+;; index of the line's color. Returns l after modifications.
(define*-public (set-line! l start end #:optional color)
(%set-line! l
(car start) (cdr start)
@@ -75,10 +75,12 @@
;; line-info l
;;
-;; Returns the parameters of the line, net or bus l as a list of the
-;; form:
+;; Returns the parameters of the line, net, bus or pin l as a list of
+;; the form:
;;
;; ((start-x . start-y) (end-x . end-y) color)
+;;
+;; For pins, start is the connectable point on the pin.
(define-public (line-info l)
(let ((params (%line-info l)))
(list (cons (list-ref params 0)
@@ -89,8 +91,9 @@
;; line-start l
;;
-;; Returns the coordinates (x . y) of the start of the gEDA line, net
-;; or bus object l.
+;; Returns the coordinates (x . y) of the start of the gEDA line, net,
+;; bus or pin object l. For pins, this is is the connectable point on
+;; the pin.
(define-public (line-start l)
(list-ref (line-info l) 0))
@@ -139,6 +142,48 @@
(let ((l (%make-bus)))
(set-line! l start end color)))
+;;;; Pins
+
+;; pin? x
+;;
+;; Returns #t if x is a gEDA pin object
+(define-public (pin? l)
+ (object-type? l 'pin))
+
+;; net-pin? x
+;;
+;; Returns #t if x is a gEDA net pin object
+(define-public (net-pin? l)
+ (and (pin? l) (equal? (%pin-type l) 'net)))
+
+;; bus-pin? x
+;;
+;; Returns #t if x is a gEDA bus pin object
+(define-public (bus-pin? l)
+ (and (pin? l) (equal? (%pin-type l) 'bus)))
+
+;; make-net-pin start end [color]
+;;
+;; Creates a new net pin. start is the coordinates (x . y) of the
+;; start (the connectable end) of the pin, and end is the coordinates
+;; (x . y) of the end of the pin. The optional color argument is the
+;; color index of the color with which to draw the bus. If color is
+;; not specified, the default color is used.
+(define*-public (make-net-pin start end #:optional color)
+ (let ((l (%make-pin 'net)))
+ (set-line! l start end color)))
+
+;; make-bus-pin start end [color]
+;;
+;; Creates a new bus pin. start is the coordinates (x . y) of the
+;; start (the connectable end) of the pin, and end is the coordinates
+;; (x . y) of the end of the pin. The optional color argument is the
+;; color index of the color with which to draw the bus. If color is
+;; not specified, the default color is used.
+(define*-public (make-bus-pin start end #:optional color)
+ (let ((l (%make-pin 'bus)))
+ (set-line! l start end color)))
+
;;;; Boxes
;; box? x
diff --git a/libgeda/scheme/unit-tests/t0010-object-line.scm b/libgeda/scheme/unit-tests/t0010-object-line.scm
index 2ce964b..7edbb95 100644
--- a/libgeda/scheme/unit-tests/t0010-object-line.scm
+++ b/libgeda/scheme/unit-tests/t0010-object-line.scm
@@ -82,3 +82,59 @@
(set-object-color! a 21)
(assert-equal 21 (list-ref (line-info a) 2))))
+
+(begin-test 'net-pins
+ (let ((a (make-net-pin '(1 . 2) '(3 . 4) 21))
+ (b (make-net-pin '(1 . 2) '(3 . 4))))
+
+ (assert-equal 'pin (object-type a))
+
+ (assert-true (pin? a))
+ (assert-true (net-pin? a))
+ (assert-true (not (bus-pin? a)))
+
+ (assert-equal '(1 . 2) (line-start a))
+ (assert-equal '(3 . 4) (line-end a))
+ (assert-equal (line-start a) (line-start b))
+ (assert-equal (line-end a) (line-end b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
+
+ (set-line! a '(5 . 6) '(7 . 8))
+ (assert-equal '(5 . 6) (line-start a))
+ (assert-equal '(7 . 8) (line-end a))
+ (assert-equal 21 (object-color a))
+
+ (set-line! a '(5 . 6) '(7 . 8) 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (line-info a) 2))))
+
+(begin-test 'bus-pins
+ (let ((a (make-bus-pin '(1 . 2) '(3 . 4) 21))
+ (b (make-bus-pin '(1 . 2) '(3 . 4))))
+
+ (assert-equal 'pin (object-type a))
+
+ (assert-true (pin? a))
+ (assert-true (bus-pin? a))
+ (assert-true (not (net-pin? a)))
+
+ (assert-equal '(1 . 2) (line-start a))
+ (assert-equal '(3 . 4) (line-end a))
+ (assert-equal (line-start a) (line-start b))
+ (assert-equal (line-end a) (line-end b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
+
+ (set-line! a '(5 . 6) '(7 . 8))
+ (assert-equal '(5 . 6) (line-start a))
+ (assert-equal '(7 . 8) (line-end a))
+ (assert-equal 21 (object-color a))
+
+ (set-line! a '(5 . 6) '(7 . 8) 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (line-info a) 2))))
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index bf6d14e..8405183 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -287,7 +287,8 @@ SCM_DEFINE (make_line, "%make-line", 0, 0, 0,
* \note Scheme API: Implements the %set-line! procedure in the (geda
* core object) module.
*
- * This function also works on net and bus objects.
+ * This function also works on net, bus and pin objects. For pins,
+ * the start is the connectable point on the pin.
*
* \param line_s the line object to modify.
* \param x1_s the new x-coordinate of the start of the line.
@@ -305,7 +306,8 @@ SCM_DEFINE (set_line, "%set-line!", 6, 0, 0,
{
SCM_ASSERT ((edascm_is_object_type (line_s, OBJ_LINE)
|| edascm_is_object_type (line_s, OBJ_NET)
- || edascm_is_object_type (line_s, OBJ_BUS)),
+ || edascm_is_object_type (line_s, OBJ_BUS)
+ || edascm_is_object_type (line_s, OBJ_PIN)),
line_s, SCM_ARG1, s_set_line);
SCM_ASSERT (scm_is_integer (x1_s), x1_s, SCM_ARG2, s_set_line);
@@ -333,6 +335,11 @@ SCM_DEFINE (set_line, "%set-line!", 6, 0, 0,
o_bus_modify (toplevel, obj, x1, y1, 0);
o_bus_modify (toplevel, obj, x2, y2, 1);
break;
+ case OBJ_PIN:
+ /* Swap ends according to pin's whichend flag. */
+ o_pin_modify (toplevel, obj, x1, y1, obj->whichend ? 1 : 0);
+ o_pin_modify (toplevel, obj, x2, y2, obj->whichend ? 0 : 1);
+ break;
default:
return line_s;
}
@@ -343,7 +350,8 @@ SCM_DEFINE (set_line, "%set-line!", 6, 0, 0,
/*! \brief Get line parameters.
* \par Function Description
- * Retrieves the parameters of a line object. The return value is a list of parameters:
+ * Retrieves the parameters of a line object. The return value is a
+ * list of parameters:
*
* -# X-coordinate of start of line
* -# Y-coordinate of start of line
@@ -351,7 +359,8 @@ SCM_DEFINE (set_line, "%set-line!", 6, 0, 0,
* -# Y-coordinate of end of line
* -# Colormap index of color to be used for drawing the line
*
- * This function also works on net and bus objects.
+ * This function also works on net, bus and pin objects. For pins,
+ * the start is the connectable point on the pin.
*
* \param line_s the line object to inspect.
* \return a list of line parameters.
@@ -361,17 +370,25 @@ SCM_DEFINE (line_info, "%line-info", 1, 0, 0,
{
SCM_ASSERT ((edascm_is_object_type (line_s, OBJ_LINE)
|| edascm_is_object_type (line_s, OBJ_NET)
- || edascm_is_object_type (line_s, OBJ_BUS)),
+ || edascm_is_object_type (line_s, OBJ_BUS)
+ || edascm_is_object_type (line_s, OBJ_PIN)),
line_s, SCM_ARG1, s_line_info);
OBJECT *obj = edascm_to_object (line_s);
+ SCM x1 = scm_from_int (obj->line->x[0]);
+ SCM y1 = scm_from_int (obj->line->y[0]);
+ SCM x2 = scm_from_int (obj->line->x[1]);
+ SCM y2 = scm_from_int (obj->line->y[1]);
+ SCM color = scm_from_int (obj->color);
+
+ /* Swap ends according to pin's whichend flag. */
+ if ((obj->type == OBJ_PIN) && obj->whichend) {
+ SCM s;
+ s = x1; x1 = x2; x2 = s;
+ s = y1; y1 = y2; y2 = s;
+ }
- return scm_list_n (scm_from_int (obj->line->x[0]),
- scm_from_int (obj->line->y[0]),
- scm_from_int (obj->line->x[1]),
- scm_from_int (obj->line->y[1]),
- scm_from_int (obj->color),
- SCM_UNDEFINED);
+ return scm_list_n (x1, y1, x2, y2, color, SCM_UNDEFINED);
}
/*! \brief Create a new net.
@@ -434,6 +451,80 @@ SCM_DEFINE (make_bus, "%make-bus", 0, 0, 0,
return result;
}
+/*! \brief Create a new pin.
+ * \par Function description
+ * Creates a new pin object, with all parameters set to default
+ * values. type_s is a Scheme symbol indicating whether the pin
+ * should be a "net" pin or a "bus" pin.
+ *
+ * \note Scheme API: Implements the %make-pin procedure in the (geda
+ * core object) module.
+ *
+ * \return a newly-created pin object.
+ */
+SCM_DEFINE (make_pin, "%make-pin", 1, 0, 0,
+ (SCM type_s), "Create a new pin object.")
+{
+ SCM_ASSERT (scm_is_symbol (type_s),
+ type_s, SCM_ARG1, s_make_pin);
+
+ int type;
+ if (type_s == net_sym) {
+ type = PIN_TYPE_NET;
+ } else if (type_s == bus_sym) {
+ type = PIN_TYPE_BUS;
+ } else {
+ scm_misc_error (s_make_pin,
+ _("Invalid pin type ~A, must be 'net or 'bus"),
+ scm_list_1 (type_s));
+ }
+
+ OBJECT *obj = o_pin_new (edascm_c_current_toplevel (),
+ OBJ_PIN, PIN_COLOR, 0, 0, 0, 0, type, 0);
+ SCM result = edascm_from_object (obj);
+
+ /* At the moment, the only pointer to the object is owned by the
+ * smob. */
+ edascm_c_set_gc (result, 1);
+
+ return result;
+}
+
+/*! \brief Get the type of a pin object.
+ * \par Function Description
+ * Returns a symbol describing the pin type of the pin object \a
+ * pin_s.
+ *
+ * \note Scheme API: Implements the %make-pin procedure in the (geda
+ * core object) module.
+ *
+ * \return the symbol 'pin or 'bus.
+ */
+SCM_DEFINE (pin_type, "%pin-type", 1, 0, 0,
+ (SCM pin_s), "Get the type of a pin object.")
+{
+ SCM_ASSERT (edascm_is_object_type (pin_s, OBJ_PIN), pin_s,
+ SCM_ARG1, s_pin_type);
+
+ OBJECT *obj = edascm_to_object (pin_s);
+ SCM result;
+
+ switch (obj->pin_type) {
+ case PIN_TYPE_NET:
+ result = net_sym;
+ break;
+ case PIN_TYPE_BUS:
+ result = bus_sym;
+ break;
+ default:
+ scm_misc_error (s_make_pin,
+ _("Object ~A has invalid pin type."),
+ scm_list_1 (pin_s));
+ }
+
+ return result;
+}
+
/*! \brief Create a new box.
* \par Function Description
* Creates a new box object, with all its parameters set to default
@@ -638,6 +729,7 @@ init_module_geda_core_object ()
scm_c_export (s_object_type, s_copy_object,
s_object_color, s_set_object_color,
s_make_line, s_make_net, s_make_bus,
+ s_make_pin, s_pin_type,
s_set_line, s_line_info,
s_make_box, s_set_box, s_box_info,
s_make_circle, s_set_circle, s_circle_info,
commit a0f0f9c672a5f8955aaf6c37ec509484d9b08714
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Circle objects.
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 1d28742..88eb7aa 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -11,7 +11,8 @@ TESTS_ENVIRONMENT = $(builddir)/../shell/geda-shell -q -L $(srcdir) \
TESTS = unit-tests/t0001-geda-conf-lib.scm \
unit-tests/t0010-object-line.scm \
- unit-tests/t0011-object-box.scm
+ unit-tests/t0011-object-box.scm \
+ unit-tests/t0012-object-circle.scm
dist_noinst_DATA = unit-test.scm $(TESTS)
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index b2e9592..04088a4 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -199,3 +199,61 @@
;; object b.
(define-public (box-bottom-right l)
(list-ref (box-info l) 1))
+
+;;;; Circles
+
+;; circle? x
+;;
+;; Returns #t if x is a gEDA circle object.
+(define-public (circle? c)
+ (object-type? c 'circle))
+
+;; set-circle! c center radius [color]
+;;
+;; Sets the parameters of a circle c. center is the new coordinates (x
+;; . y) of the center of the circle, and radius is the new radius of
+;; the circle. The optional color argument is the new colormap index
+;; of the circle's color. Returns c after modifications.
+(define*-public (set-circle! c center radius #:optional color)
+ (%set-circle! c
+ (car center) (cdr center)
+ radius
+ (if (not color)
+ (object-color c)
+ color)))
+
+;; make-circle center radius [color]
+;;
+;; Creates a new circle. center is the coordinates (x . y) of the
+;; center of the circle, and radius is the radius of the circle. The
+;; optional color argument is the colormap index of the color with
+;; which to draw the circle. If color is not specified, the default
+;; color is used.
+(define*-public (make-circle center radius #:optional color)
+ (let ((c (%make-circle)))
+ (set-circle! c center radius color)))
+
+;; circle-info c
+;;
+;; Returns the parameters of the circle c as a list of the form:
+;;
+;; ((center-x . center-y) radius color)
+(define-public (circle-info c)
+ (let* ((params (%circle-info c))
+ (tail (cddr params)))
+ (cons (cons (list-ref params 0)
+ (list-ref params 1))
+ tail)))
+
+;; circle-center c
+;;
+;; Returns the coordinates (x . y) of the center of the gEDA circle
+;; object c.
+(define-public (circle-center c)
+ (list-ref (circle-info c) 0))
+
+;; circle-radius c
+;;
+;; Returns the radius of the gEDA circle object c.
+(define-public (circle-radius c)
+ (list-ref (circle-info c) 1))
diff --git a/libgeda/scheme/unit-tests/t0012-object-circle.scm b/libgeda/scheme/unit-tests/t0012-object-circle.scm
new file mode 100644
index 0000000..4cb8323
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0012-object-circle.scm
@@ -0,0 +1,31 @@
+;; Test Scheme procedures related to circle objects.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'circles
+ (let* ((a (make-circle '(1 . 2) 3 21))
+ (b (copy-object a)))
+
+ (assert-equal 'circle (object-type a))
+
+ (assert-true (circle? a))
+ (assert-true (circle? b))
+
+ (assert-equal '(1 . 2) (circle-center a))
+ (assert-equal 3 (circle-radius a))
+ (assert-equal (circle-center a) (circle-center b))
+ (assert-equal (circle-radius a) (circle-radius b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (circle-center a) (circle-radius a) (object-color a))
+ (circle-info a))
+
+ (set-circle! a '(5 . 6) 7)
+ (assert-equal '(5 . 6) (circle-center a))
+ (assert-equal 7 (circle-radius a))
+ (assert-equal 21 (object-color a))
+ (set-circle! a '(5 . 6) 7 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (circle-info a) 2))))
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index 66d8dc3..bf6d14e 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -529,6 +529,99 @@ SCM_DEFINE (box_info, "%box-info", 1, 0, 0,
SCM_UNDEFINED);
}
+/*! \brief Create a new circle.
+ * \par Function Description
+
+ * Creates a new circle object, with all its parameters set to default
+ * values.
+ *
+ * \note Scheme API: Implements the %make-circle procedure in the
+ * (geda core object) module.
+ *
+ * \return a newly-created circle object.
+ */
+SCM_DEFINE (make_circle, "%make-circle", 0, 0, 0,
+ (), "Create a new circle object.")
+{
+ OBJECT *obj = o_circle_new (edascm_c_current_toplevel (),
+ OBJ_CIRCLE, DEFAULT_COLOR,
+ 0, 0, 1);
+
+ SCM result = edascm_from_object (obj);
+
+ /* At the moment, the only pointer to the object is owned by the
+ * smob. */
+ edascm_c_set_gc (result, 1);
+
+ return result;
+}
+
+/*! \brief Set circle parameters.
+ * \par Function Description
+ * Modifies a circle object by setting its parameters to new values.
+ *
+ * \note Scheme API: Implements the %set-circle! procedure in the
+ * (geda core object) module.
+ *
+ * \param circle_s the circle object to modify.
+ * \param x_s the new x-coordinate of the center of the circle.
+ * \param y_s the new y-coordinate of the center of the circle.
+ * \param r_s the new radius of the circle.
+ * \param color the colormap index of the color to be used for
+ * drawing the circle.
+ *
+ * \return the modified circle object.
+ */
+SCM_DEFINE (set_circle, "%set-circle!", 5, 0, 0,
+ (SCM circle_s, SCM x_s, SCM y_s, SCM r_s, SCM color_s),
+ "Set circle parameters")
+{
+ SCM_ASSERT (edascm_is_object_type (circle_s, OBJ_CIRCLE), circle_s,
+ SCM_ARG1, s_set_circle);
+ SCM_ASSERT (scm_is_integer (x_s), x_s, SCM_ARG2, s_set_circle);
+ SCM_ASSERT (scm_is_integer (y_s), y_s, SCM_ARG3, s_set_circle);
+ SCM_ASSERT (scm_is_integer (r_s), r_s, SCM_ARG4, s_set_circle);
+ SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG5, s_set_circle);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (circle_s);
+ o_circle_modify (toplevel, obj, scm_to_int(x_s), scm_to_int(y_s),
+ CIRCLE_CENTER);
+ o_circle_modify (toplevel, obj, scm_to_int(r_s), 0, CIRCLE_RADIUS);
+ o_set_color (toplevel, obj, scm_to_int (color_s));
+
+ return circle_s;
+}
+
+/*! \brief Get circle parameters.
+ * \par Function Description
+
+ * Retrieves the parameters of a circle object. The return value is a
+ * list of parameters:
+ *
+ * -# X-coordinate of center of circle
+ * -# Y-coordinate of center of circle
+ * -# Radius of circle
+ * -# Colormap index of color to be used for drawing the circle
+ *
+ * \param circle_s the circle object to inspect.
+ * \return a list of circle parameters.
+ */
+SCM_DEFINE (circle_info, "%circle-info", 1, 0, 0,
+ (SCM circle_s), "Get circle parameters.")
+{
+ SCM_ASSERT (edascm_is_object_type (circle_s, OBJ_CIRCLE),
+ circle_s, SCM_ARG1, s_circle_info);
+
+ OBJECT *obj = edascm_to_object (circle_s);
+
+ return scm_list_n (scm_from_int (obj->circle->center_x),
+ scm_from_int (obj->circle->center_y),
+ scm_from_int (obj->circle->radius),
+ scm_from_int (obj->color),
+ SCM_UNDEFINED);
+}
+
/*!
* \brief Create the (geda core object) Scheme module.
* \par Function Description
@@ -547,6 +640,7 @@ init_module_geda_core_object ()
s_make_line, s_make_net, s_make_bus,
s_set_line, s_line_info,
s_make_box, s_set_box, s_box_info,
+ s_make_circle, s_set_circle, s_circle_info,
NULL);
}
commit 2010a33b32dacaf660145b44ad7e93c566a0e9df
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Box objects.
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 7cf8571..1d28742 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -10,7 +10,8 @@ TESTS_ENVIRONMENT = $(builddir)/../shell/geda-shell -q -L $(srcdir) \
-c '(use-modules (unit-test)) (load (list-ref (command-line) 1)) (exit (if (tests-passed?) 0 1))'
TESTS = unit-tests/t0001-geda-conf-lib.scm \
- unit-tests/t0010-object-line.scm
+ unit-tests/t0010-object-line.scm \
+ unit-tests/t0011-object-box.scm
dist_noinst_DATA = unit-test.scm $(TESTS)
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index 1e19b55..b2e9592 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -138,3 +138,64 @@
(define*-public (make-bus start end #:optional color)
(let ((l (%make-bus)))
(set-line! l start end color)))
+
+;;;; Boxes
+
+;; box? x
+;;
+;; Returns #t if x is a gEDA box object.
+(define-public (box? l)
+ (object-type? l 'box))
+
+;; set-box! b top-left bottom-right [color]
+;;
+;; Sets the parameters of a box b. top-left is the new coordinates (x
+;; . y) of the top left corner of the box, and bottom-right is the new
+;; coordinates of the bottom right corner. The optional color argument
+;; is the new colormap index of the box's color. Returns b after
+;; modifications.
+(define*-public (set-box! b top-left bottom-right #:optional color)
+ (%set-box! b
+ (car top-left) (cdr top-left)
+ (car bottom-right) (cdr bottom-right)
+ (if (not color)
+ (object-color b)
+ color)))
+
+;; make-box top-left bottom-right [color]
+;;
+;; Creates a new box. top-left is the coordinates (x . y) of the top
+;; left corner of the box, and bottom-right is the coordinates (x . y)
+;; of the bottom right corner. The optional color argument is the
+;; color index of the color with which to draw the box. If color is
+;; not specified, the default color is used.
+(define*-public (make-box top-left bottom-right #:optional color)
+ (let ((l (%make-box)))
+ (set-box! l top-left bottom-right color)))
+
+;; box-info b
+;;
+;; Returns the parameters of the box b as a list of the form:
+;;
+;; ((top-left-x . top-left-y) (bottom-right-x . bottom-right-y) color)
+(define-public (box-info b)
+ (let ((params (%box-info b)))
+ (list (cons (list-ref params 0)
+ (list-ref params 1))
+ (cons (list-ref params 2)
+ (list-ref params 3))
+ (list-ref params 4))))
+
+;; box-top-left b
+;;
+;; Returns the coordinates (x . y) of the top left of the gEDA box
+;; object b.
+(define-public (box-top-left l)
+ (list-ref (box-info l) 0))
+
+;; box-bottom-right b
+;;
+;; Returns the coordinates (x . y) of the bottom right of the gEDA box
+;; object b.
+(define-public (box-bottom-right l)
+ (list-ref (box-info l) 1))
diff --git a/libgeda/scheme/unit-tests/t0011-object-box.scm b/libgeda/scheme/unit-tests/t0011-object-box.scm
new file mode 100644
index 0000000..15a9612
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0011-object-box.scm
@@ -0,0 +1,36 @@
+;; Test Scheme procedures related to box objects.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'boxes
+ (let* ((a (make-box '(1 . 4) '(3 . 2) 21))
+ (b (copy-object a)))
+
+ (assert-equal 'box (object-type a))
+
+ (assert-true (box? a))
+ (assert-true (box? b))
+
+ (assert-equal '(1 . 4) (box-top-left a))
+ (assert-equal '(3 . 2) (box-bottom-right a))
+ (assert-equal (box-top-left a) (box-top-left b))
+ (assert-equal (box-bottom-right a) (box-bottom-right b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (box-top-left a) (box-bottom-right a) (object-color a)) (box-info a))
+
+ ; Check that set-box! swaps corners around correctly
+ (set-box! a '(5 . 6) '(7 . 8))
+ (assert-equal '(5 . 8) (box-top-left a))
+ (assert-equal '(7 . 6) (box-bottom-right a))
+ (set-box! a '(7 . 6) '(5 . 8))
+ (assert-equal '(5 . 8) (box-top-left a))
+ (assert-equal '(7 . 6) (box-bottom-right a))
+ (assert-equal 21 (object-color a))
+
+ (set-box! a '(5 . 6) '(7 . 8) 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (box-info a) 2))
+))
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index 1449a09..66d8dc3 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -434,6 +434,101 @@ SCM_DEFINE (make_bus, "%make-bus", 0, 0, 0,
return result;
}
+/*! \brief Create a new box.
+ * \par Function Description
+ * Creates a new box object, with all its parameters set to default
+ * values.
+ *
+ * \note Scheme API: Implements the %make-box procedure in the (geda
+ * core object) module.
+ *
+ * \return a newly-created box object.
+ */
+SCM_DEFINE (make_box, "%make-box", 0, 0, 0,
+ (), "Create a new box object.")
+{
+ OBJECT *obj = o_box_new (edascm_c_current_toplevel (),
+ OBJ_BOX, DEFAULT_COLOR,
+ 0, 0, 0, 0);
+
+ SCM result = edascm_from_object (obj);
+
+ /* At the moment, the only pointer to the object is owned by the
+ * smob. */
+ edascm_c_set_gc (result, 1);
+
+ return result;
+}
+
+/*! \brief Set box parameters.
+ * \par Function Description
+ * Modifies a box object by setting its parameters to new values.
+ *
+ * \note Scheme API: Implements the %set-box! procedure in the (geda
+ * core object) module.
+ *
+ * \param box_s the box object to modify.
+ * \param x1_s the new x-coordinate of the top left of the box.
+ * \param y1_s the new y-coordinate of the top left of the box.
+ * \param x2_s the new x-coordinate of the bottom right of the box.
+ * \param y2_s the new y-coordinate of the bottom right of the box.
+ * \param color the colormap index of the color to be used for
+ * drawing the box.
+ *
+ * \return the modified box object.
+ */
+SCM_DEFINE (set_box, "%set-box!", 6, 0, 0,
+ (SCM box_s, SCM x1_s, SCM y1_s, SCM x2_s, SCM y2_s, SCM color_s),
+ "Set box parameters.")
+{
+ SCM_ASSERT (edascm_is_object_type (box_s, OBJ_BOX), box_s,
+ SCM_ARG1, s_set_box);
+ SCM_ASSERT (scm_is_integer (x1_s), x1_s, SCM_ARG2, s_set_box);
+ SCM_ASSERT (scm_is_integer (y1_s), y1_s, SCM_ARG3, s_set_box);
+ SCM_ASSERT (scm_is_integer (x2_s), x2_s, SCM_ARG4, s_set_box);
+ SCM_ASSERT (scm_is_integer (y2_s), y2_s, SCM_ARG5, s_set_box);
+ SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG6, s_set_box);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (box_s);
+ o_box_modify_all (toplevel, obj,
+ scm_to_int (x1_s), scm_to_int (y1_s),
+ scm_to_int (x2_s), scm_to_int (y2_s));
+ o_set_color (toplevel, obj, scm_to_int (color_s));
+
+ return box_s;
+}
+
+/*! \brief Get box parameters.
+ * \par Function Description
+ * Retrieves the parameters of a box object. The return value is a
+ * list of parameters:
+ *
+ * -# X-coordinate of top left of box
+ * -# Y-coordinate of top left of box
+ * -# X-coordinate of bottom right of box
+ * -# Y-coordinate of bottom right of box
+ * -# Colormap index of color to be used for drawing the box
+ *
+ * \param box_s the box object to inspect.
+ * \return a list of box parameters.
+ */
+SCM_DEFINE (box_info, "%box-info", 1, 0, 0,
+ (SCM box_s), "Get box parameters.")
+{
+ SCM_ASSERT (edascm_is_object_type (box_s, OBJ_BOX), box_s,
+ SCM_ARG1, s_box_info);
+
+ OBJECT *obj = edascm_to_object (box_s);
+
+ return scm_list_n (scm_from_int (obj->box->upper_x),
+ scm_from_int (obj->box->upper_y),
+ scm_from_int (obj->box->lower_x),
+ scm_from_int (obj->box->lower_y),
+ scm_from_int (obj->color),
+ SCM_UNDEFINED);
+}
+
/*!
* \brief Create the (geda core object) Scheme module.
* \par Function Description
@@ -451,6 +546,7 @@ init_module_geda_core_object ()
s_object_color, s_set_object_color,
s_make_line, s_make_net, s_make_bus,
s_set_line, s_line_info,
+ s_make_box, s_set_box, s_box_info,
NULL);
}
commit f0d9875a2eee566cf75b340a98a9471d65fc8ad7
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Line, net and bus objects.
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 4ae6b7e..7cf8571 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -9,7 +9,8 @@ nobase_dist_scmdata_DATA = geda.scm color-map.scm \
TESTS_ENVIRONMENT = $(builddir)/../shell/geda-shell -q -L $(srcdir) \
-c '(use-modules (unit-test)) (load (list-ref (command-line) 1)) (exit (if (tests-passed?) 0 1))'
-TESTS = unit-tests/t0001-geda-conf-lib.scm
+TESTS = unit-tests/t0001-geda-conf-lib.scm \
+ unit-tests/t0010-object-line.scm
dist_noinst_DATA = unit-test.scm $(TESTS)
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index de18bf7..1e19b55 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -21,7 +21,10 @@
; Import C procedures
#:use-module (geda core smob)
- #:use-module (geda core object))
+ #:use-module (geda core object)
+
+ ; Optional arguments
+ #:use-module (ice-9 optargs))
(define-public object-type %object-type)
(define-public object? %object?)
@@ -35,3 +38,103 @@
(define-public object-color %object-color)
(define-public set-object-color! %set-object-color!)
+
+;;;; Lines
+
+;; line? x
+;;
+;; Returns #t if x is a gEDA line object.
+(define-public (line? l)
+ (object-type? l 'line))
+
+;; set-line! l start end [color]
+;;
+;; Sets the parameters of a line, net or bus object l. start is the
+;; new coordinates (x . y) of the start of the line, and end is the
+;; new coordinates of the end of the line. The optional color argument
+;; is the new colormap index of the line's color. Returns l after
+;; modifications.
+(define*-public (set-line! l start end #:optional color)
+ (%set-line! l
+ (car start) (cdr start)
+ (car end) (cdr end)
+ (if (not color)
+ (object-color l)
+ color)))
+
+;; make-line start end [color]
+;;
+;; Creates a new line. start is the coordinates (x . y) of the start
+;; of the line, and end is the coordinates (x . y) of the end of the
+;; line. The optional color argument is the color index of the color
+;; with which to draw the line. If color is not specified, the
+;; default color is used.
+(define*-public (make-line start end #:optional color)
+ (let ((l (%make-line)))
+ (set-line! l start end color)))
+
+;; line-info l
+;;
+;; Returns the parameters of the line, net or bus l as a list of the
+;; form:
+;;
+;; ((start-x . start-y) (end-x . end-y) color)
+(define-public (line-info l)
+ (let ((params (%line-info l)))
+ (list (cons (list-ref params 0)
+ (list-ref params 1))
+ (cons (list-ref params 2)
+ (list-ref params 3))
+ (list-ref params 4))))
+
+;; line-start l
+;;
+;; Returns the coordinates (x . y) of the start of the gEDA line, net
+;; or bus object l.
+(define-public (line-start l)
+ (list-ref (line-info l) 0))
+
+;; line-end l
+;;
+;; Returns the coordinates (x . y) of the end of the gEDA line, net or
+;; bus object l.
+(define-public (line-end l)
+ (list-ref (line-info l) 1))
+
+;;;; Nets
+
+;; net? x
+;;
+;; Returns #t if x is a gEDA net object.
+(define-public (net? l)
+ (object-type? l 'net))
+
+;; make-net start end [color]
+;;
+;; Creates a new net. start is the coordinates (x . y) of the start
+;; of the net, and end is the coordinates (x . y) of the end of the
+;; net. The optional color argument is the color index of the color
+;; with which to draw the net. If color is not specified, the
+;; default color is used.
+(define*-public (make-net start end #:optional color)
+ (let ((l (%make-net)))
+ (set-line! l start end color)))
+
+;;;; Buses
+
+;; bus? x
+;;
+;; Returns #t if x is a gEDA bus object.
+(define-public (bus? l)
+ (object-type? l 'bus))
+
+;; make-bus start end [color]
+;;
+;; Creates a new bus. start is the coordinates (x . y) of the start
+;; of the bus, and end is the coordinates (x . y) of the end of the
+;; bus. The optional color argument is the color index of the color
+;; with which to draw the bus. If color is not specified, the
+;; default color is used.
+(define*-public (make-bus start end #:optional color)
+ (let ((l (%make-bus)))
+ (set-line! l start end color)))
diff --git a/libgeda/scheme/unit-tests/t0010-object-line.scm b/libgeda/scheme/unit-tests/t0010-object-line.scm
new file mode 100644
index 0000000..2ce964b
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0010-object-line.scm
@@ -0,0 +1,84 @@
+;; Test Scheme procedures related to line objects.
+
+(use-modules (unit-test))
+(use-modules (geda object))
+
+(begin-test 'lines
+ (let ((a (make-line '(1 . 2) '(3 . 4) 21))
+ (b (make-line '(1 . 2) '(3 . 4))))
+
+ (assert-equal 'line (object-type a))
+
+ (assert-true (line? a))
+
+ (assert-equal '(1 . 2) (line-start a))
+ (assert-equal '(3 . 4) (line-end a))
+ (assert-equal (line-start a) (line-start b))
+ (assert-equal (line-end a) (line-end b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
+
+ (set-line! a '(5 . 6) '(7 . 8))
+ (assert-equal '(5 . 6) (line-start a))
+ (assert-equal '(7 . 8) (line-end a))
+ (assert-equal 21 (object-color a))
+
+ (set-line! a '(5 . 6) '(7 . 8) 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (line-info a) 2))))
+
+(make-net '(1 . 2) '(3 . 4))
+
+(begin-test 'nets
+ (let ((a (make-net '(1 . 2) '(3 . 4) 21))
+ (b (make-net '(1 . 2) '(3 . 4))))
+
+ (assert-equal 'net (object-type a))
+
+ (assert-true (net? a))
+
+ (assert-equal '(1 . 2) (line-start a))
+ (assert-equal '(3 . 4) (line-end a))
+ (assert-equal (line-start a) (line-start b))
+ (assert-equal (line-end a) (line-end b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
+
+ (set-line! a '(5 . 6) '(7 . 8))
+ (assert-equal '(5 . 6) (line-start a))
+ (assert-equal '(7 . 8) (line-end a))
+ (assert-equal 21 (object-color a))
+
+ (set-line! a '(5 . 6) '(7 . 8) 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (line-info a) 2))))
+
+(begin-test 'buses
+ (let ((a (make-bus '(1 . 2) '(3 . 4) 21))
+ (b (make-bus '(1 . 2) '(3 . 4))))
+
+ (assert-equal 'bus (object-type a))
+
+ (assert-true (bus? a))
+
+ (assert-equal '(1 . 2) (line-start a))
+ (assert-equal '(3 . 4) (line-end a))
+ (assert-equal (line-start a) (line-start b))
+ (assert-equal (line-end a) (line-end b))
+ (assert-equal 21 (object-color a))
+ (assert-equal (list (line-start a) (line-end a) (object-color a)) (line-info a))
+
+ (set-line! a '(5 . 6) '(7 . 8))
+ (assert-equal '(5 . 6) (line-start a))
+ (assert-equal '(7 . 8) (line-end a))
+ (assert-equal 21 (object-color a))
+
+ (set-line! a '(5 . 6) '(7 . 8) 22)
+ (assert-equal 22 (object-color a))
+
+ (set-object-color! a 21)
+ (assert-equal 21 (list-ref (line-info a) 2))))
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index 0a85026..1449a09 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -254,6 +254,186 @@ SCM_DEFINE (set_object_color, "%set-object-color!", 2, 0, 0,
return obj_s;
}
+/*! \brief Create a new line.
+ * \par Function Description
+ * Creates a new line object, with all its parameters set to default
+ * values.
+ *
+ * \note Scheme API: Implements the %make-line procedure in the (geda
+ * core object) module.
+ *
+ * \return a newly-created line object.
+ */
+SCM_DEFINE (make_line, "%make-line", 0, 0, 0,
+ (), "Create a new line object.")
+{
+ OBJECT *obj = o_line_new (edascm_c_current_toplevel (),
+ OBJ_LINE, DEFAULT_COLOR,
+ 0, 0, 0, 0);
+
+ SCM result = edascm_from_object (obj);
+
+ /* At the moment, the only pointer to the object is owned by the
+ * smob. */
+ edascm_c_set_gc (result, TRUE);
+
+ return result;
+}
+
+/*! \brief Set line parameters.
+ * \par Function Description
+ * Modifies a line object by setting its parameters to new values.
+ *
+ * \note Scheme API: Implements the %set-line! procedure in the (geda
+ * core object) module.
+ *
+ * This function also works on net and bus objects.
+ *
+ * \param line_s the line object to modify.
+ * \param x1_s the new x-coordinate of the start of the line.
+ * \param y1_s the new y-coordinate of the start of the line.
+ * \param x2_s the new x-coordinate of the end of the line.
+ * \param y2_s the new y-coordinate of the end of the line.
+ * \param color the colormap index of the color to be used for
+ * drawing the line.
+ *
+ * \return the modified line object.
+ */
+SCM_DEFINE (set_line, "%set-line!", 6, 0, 0,
+ (SCM line_s, SCM x1_s, SCM y1_s, SCM x2_s, SCM y2_s, SCM color_s),
+ "Set line parameters.")
+{
+ SCM_ASSERT ((edascm_is_object_type (line_s, OBJ_LINE)
+ || edascm_is_object_type (line_s, OBJ_NET)
+ || edascm_is_object_type (line_s, OBJ_BUS)),
+ line_s, SCM_ARG1, s_set_line);
+
+ SCM_ASSERT (scm_is_integer (x1_s), x1_s, SCM_ARG2, s_set_line);
+ SCM_ASSERT (scm_is_integer (y1_s), y1_s, SCM_ARG3, s_set_line);
+ SCM_ASSERT (scm_is_integer (x2_s), x2_s, SCM_ARG4, s_set_line);
+ SCM_ASSERT (scm_is_integer (y2_s), y2_s, SCM_ARG5, s_set_line);
+ SCM_ASSERT (scm_is_integer (color_s), color_s, SCM_ARG6, s_set_line);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (line_s);
+ int x1 = scm_to_int (x1_s);
+ int y1 = scm_to_int (y1_s);
+ int x2 = scm_to_int (x2_s);
+ int y2 = scm_to_int (y2_s);
+ switch (obj->type) {
+ case OBJ_LINE:
+ o_line_modify (toplevel, obj, x1, y1, LINE_END1);
+ o_line_modify (toplevel, obj, x2, y2, LINE_END2);
+ break;
+ case OBJ_NET:
+ o_net_modify (toplevel, obj, x1, y1, 0);
+ o_net_modify (toplevel, obj, x2, y2, 1);
+ break;
+ case OBJ_BUS:
+ o_bus_modify (toplevel, obj, x1, y1, 0);
+ o_bus_modify (toplevel, obj, x2, y2, 1);
+ break;
+ default:
+ return line_s;
+ }
+ o_set_color (toplevel, obj, scm_to_int (color_s));
+
+ return line_s;
+}
+
+/*! \brief Get line parameters.
+ * \par Function Description
+ * Retrieves the parameters of a line object. The return value is a list of parameters:
+ *
+ * -# X-coordinate of start of line
+ * -# Y-coordinate of start of line
+ * -# X-coordinate of end of line
+ * -# Y-coordinate of end of line
+ * -# Colormap index of color to be used for drawing the line
+ *
+ * This function also works on net and bus objects.
+ *
+ * \param line_s the line object to inspect.
+ * \return a list of line parameters.
+ */
+SCM_DEFINE (line_info, "%line-info", 1, 0, 0,
+ (SCM line_s), "Get line parameters.")
+{
+ SCM_ASSERT ((edascm_is_object_type (line_s, OBJ_LINE)
+ || edascm_is_object_type (line_s, OBJ_NET)
+ || edascm_is_object_type (line_s, OBJ_BUS)),
+ line_s, SCM_ARG1, s_line_info);
+
+ OBJECT *obj = edascm_to_object (line_s);
+
+ return scm_list_n (scm_from_int (obj->line->x[0]),
+ scm_from_int (obj->line->y[0]),
+ scm_from_int (obj->line->x[1]),
+ scm_from_int (obj->line->y[1]),
+ scm_from_int (obj->color),
+ SCM_UNDEFINED);
+}
+
+/*! \brief Create a new net.
+ * \par Function Description
+ * Creates a new net object, with all its parameters set to default
+ * values.
+ *
+ * \note Scheme API: Implements the %make-net procedure in the (geda
+ * core object) module.
+ *
+ * \return a newly-created net object.
+ */
+SCM_DEFINE (make_net, "%make-net", 0, 0, 0,
+ (), "Create a new net object.")
+{
+ OBJECT *obj;
+ SCM result;
+
+ obj = o_net_new (edascm_c_current_toplevel (),
+ OBJ_NET, NET_COLOR, 0, 0, 0, 0);
+
+
+ result = edascm_from_object (obj);
+
+ /* At the moment, the only pointer to the object is owned by the
+ * smob. */
+ edascm_c_set_gc (result, 1);
+
+ return result;
+}
+
+/*! \brief Create a new bus.
+ * \par Function Description
+ * Creates a new bus object, with all its parameters set to default
+ * values.
+ *
+ * \note Scheme API: Implements the %make-bus procedure in the (geda
+ * core object) module.
+ *
+ * \todo Do we need a way to get/set bus ripper direction?
+ *
+ * \return a newly-created bus object.
+ */
+SCM_DEFINE (make_bus, "%make-bus", 0, 0, 0,
+ (), "Create a new bus object.")
+{
+ OBJECT *obj;
+ SCM result;
+
+ obj = o_bus_new (edascm_c_current_toplevel (),
+ OBJ_BUS, BUS_COLOR, 0, 0, 0, 0,
+ 0); /* Bus ripper direction */
+
+ result = edascm_from_object (obj);
+
+ /* At the moment, the only pointer to the object is owned by the
+ * smob. */
+ edascm_c_set_gc (result, 1);
+
+ return result;
+}
+
/*!
* \brief Create the (geda core object) Scheme module.
* \par Function Description
@@ -269,6 +449,8 @@ init_module_geda_core_object ()
/* Add them to the module's public definitions. */
scm_c_export (s_object_type, s_copy_object,
s_object_color, s_set_object_color,
+ s_make_line, s_make_net, s_make_bus,
+ s_set_line, s_line_info,
NULL);
}
commit 91d3e917cd11d4c304c84f95431c08210b867a4c
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Get/set the color of objects, and copy them.
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
index c9c9df7..de18bf7 100644
--- a/libgeda/scheme/geda/object.scm
+++ b/libgeda/scheme/geda/object.scm
@@ -30,3 +30,8 @@
(if (object? x)
(eq? (object-type x) type)
#f))
+
+(define-public copy-object %copy-object)
+
+(define-public object-color %object-color)
+(define-public set-object-color! %set-object-color!)
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index 4498464..0a85026 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -134,6 +134,36 @@ edascm_is_object_type (SCM smob, int type)
return (obj->type == type);
}
+/*! \brief Copy an object.
+ * \par Function Description
+ * Returns a copy of the #OBJECT contained in smob \a obj_s as a new
+ * smob.
+ *
+ * \note Scheme API: Implements the %copy-object procedure in the
+ * (geda core object) module.
+ *
+ * \param [in] obj_s an #OBJECT smob.
+ * \return a new #OBJECT smob containing a copy of the #OBJECT in \a obj_s.
+ */
+SCM_DEFINE (copy_object, "%copy-object", 1, 0, 0,
+ (SCM obj_s), "Copy an object.")
+{
+ SCM result;
+ SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
+ SCM_ARG1, s_copy_object);
+
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
+ OBJECT *obj = edascm_to_object (obj_s);
+
+ result = edascm_from_object (o_object_copy (toplevel, obj));
+
+ /* At the moment, the only pointer to the object is owned by the
+ * smob. */
+ edascm_c_set_gc (result, TRUE);
+
+ return result;
+}
+
/*! \brief Get the type of an object.
* \par Function Description
* Returns a symbol describing the type of the #OBJECT smob \a obj_s.
@@ -175,6 +205,55 @@ SCM_DEFINE (object_type, "%object-type", 1, 0, 0,
return result;
}
+/*! \brief Get the color of an object.
+ * \par Function Description
+ * Returns the colormap index of the color used to draw the #OBJECT
+ * smob \a obj_s. Note that the color may not be meaningful for some
+ * object types.
+ *
+ * \note Scheme API: Implements the %object-color procedure in the
+ * (geda core object) module.
+ *
+ * \param [in] obj_s #OBJECT smob to inspect.
+ * \return The colormap index used by \a obj_s.
+ */
+SCM_DEFINE (object_color, "%object-color", 1, 0, 0,
+ (SCM obj_s), "Get the color of an object.")
+{
+ SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
+ SCM_ARG1, s_object_color);
+
+ OBJECT *obj = edascm_to_object (obj_s);
+ return scm_from_int (obj->color);
+}
+
+/*! \brief Set the color of an object.
+ * \par Function Description
+ * Set the colormap index of the color used to draw the #OBJECT smob
+ * \a obj_s to \a color_s. Note that the color may not be meaningful
+ * for some object types.
+ *
+ * \note Scheme API: Implements the %set-object-color! procedure in
+ * the (geda core object) module.
+ *
+ * \param obj_s #OBJECT smob to modify.
+ * \param color_s new colormap index to use for \a obj_s.
+ * \return the modified \a obj_s.
+ */
+SCM_DEFINE (set_object_color, "%set-object-color!", 2, 0, 0,
+ (SCM obj_s, SCM color_s), "Set the color of an object.")
+{
+ SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
+ SCM_ARG1, s_set_object_color);
+ SCM_ASSERT (scm_is_integer (color_s), color_s,
+ SCM_ARG2, s_set_object_color);
+
+ o_set_color (edascm_c_current_toplevel (),
+ edascm_to_object (obj_s), scm_to_int (color_s));
+
+ return obj_s;
+}
+
/*!
* \brief Create the (geda core object) Scheme module.
* \par Function Description
@@ -188,7 +267,9 @@ init_module_geda_core_object ()
#include "scheme_object.x"
/* Add them to the module's public definitions. */
- scm_c_export (s_object_type, NULL);
+ scm_c_export (s_object_type, s_copy_object,
+ s_object_color, s_set_object_color,
+ NULL);
}
/*!
commit 1acff2a3f952b291cbae4e293f9cf703b99645de
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Get the type of an object.
Adds a function to the Scheme API for obtaining a symbol indicating
the type of schematic object contained in a Scheme value.
diff --git a/libgeda/include/libgedaguile_priv.h b/libgeda/include/libgedaguile_priv.h
index 9bd0e28..83f4472 100644
--- a/libgeda/include/libgedaguile_priv.h
+++ b/libgeda/include/libgedaguile_priv.h
@@ -28,6 +28,7 @@
void edascm_init_smob ();
void edascm_init_toplevel ();
+void edascm_init_object ();
/* ---------------------------------------- */
@@ -122,3 +123,4 @@ void edascm_c_set_gc (SCM smob, int gc);
GList *edascm_to_object_glist (SCM objs, const char *subr);
SCM edascm_from_object_glist (const GList *objs);
+int edascm_is_object_type (SCM smob, int type);
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index bf0b204..4ae6b7e 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -1,6 +1,7 @@
scmdatadir = $(GEDADATADIR)/scheme
-nobase_dist_scmdata_DATA = geda.scm color-map.scm
+nobase_dist_scmdata_DATA = geda.scm color-map.scm \
+ geda/object.scm
# Unit test support. The unit tests are run using the geda-batch
# program, with config loading disabled (-q) so that user config
diff --git a/libgeda/scheme/geda/object.scm b/libgeda/scheme/geda/object.scm
new file mode 100644
index 0000000..c9c9df7
--- /dev/null
+++ b/libgeda/scheme/geda/object.scm
@@ -0,0 +1,32 @@
+;; gEDA - GPL Electronic Design Automation
+;; libgeda - gEDA's library - Scheme API
+;; Copyright (C) 2010 Peter Brett
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+;;
+
+(define-module (geda object)
+
+ ; Import C procedures
+ #:use-module (geda core smob)
+ #:use-module (geda core object))
+
+(define-public object-type %object-type)
+(define-public object? %object?)
+
+(define-public (object-type? x type)
+ (if (object? x)
+ (eq? (object-type x) type)
+ #f))
diff --git a/libgeda/src/Makefile.am b/libgeda/src/Makefile.am
index 3191e0d..9db26e4 100644
--- a/libgeda/src/Makefile.am
+++ b/libgeda/src/Makefile.am
@@ -4,7 +4,8 @@ lib_LTLIBRARIES = libgeda.la
BUILT_SOURCES = \
scheme_smob.x \
- scheme_toplevel.x
+ scheme_toplevel.x \
+ scheme_object.x
scheme_api_sources = \
scheme_init.c \
diff --git a/libgeda/src/scheme_init.c b/libgeda/src/scheme_init.c
index d3ba1af..f32cd31 100644
--- a/libgeda/src/scheme_init.c
+++ b/libgeda/src/scheme_init.c
@@ -42,4 +42,5 @@ edascm_init ()
edascm_init_smob ();
edascm_init_toplevel ();
+ edascm_init_object ();
}
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
index 9221771..4498464 100644
--- a/libgeda/src/scheme_object.c
+++ b/libgeda/src/scheme_object.c
@@ -28,6 +28,17 @@
#include "libgedaguile_priv.h"
SCM_SYMBOL (wrong_type_arg_sym , "wrong-type-arg");
+SCM_SYMBOL (line_sym , "line");
+SCM_SYMBOL (net_sym , "net");
+SCM_SYMBOL (bus_sym , "bus");
+SCM_SYMBOL (box_sym , "box");
+SCM_SYMBOL (picture_sym , "picture");
+SCM_SYMBOL (circle_sym , "circle");
+SCM_SYMBOL (complex_sym , "complex");
+SCM_SYMBOL (text_sym , "text");
+SCM_SYMBOL (path_sym , "path");
+SCM_SYMBOL (pin_sym , "pin");
+SCM_SYMBOL (arc_sym , "arc");
/*! \brief Convert a Scheme object list to a GList.
* \par Function Description
@@ -103,3 +114,94 @@ edascm_from_object_glist (const GList *objs)
scm_remember_upto_here_1 (lst);
return rlst;
}
+
+/*! \brief Test if an object smob is of a particular type.
+ * \par Function Description
+ * Checks if \a smob contains an #OBJECT of the given \a type. This is
+ * intended to be used by C-based Scheme procedures for working with
+ * particular object types.
+ *
+ * \param [in] smob Scheme value to check type for.
+ * \param [in] type Type to check against (e.g. OBJ_LINE).
+ * \return non-zero if \a smob is an #OBJECT smob of \a type.
+ */
+int
+edascm_is_object_type (SCM smob, int type)
+{
+ if (!EDASCM_OBJECTP(smob)) return 0;
+
+ OBJECT *obj = edascm_to_object (smob);
+ return (obj->type == type);
+}
+
+/*! \brief Get the type of an object.
+ * \par Function Description
+ * Returns a symbol describing the type of the #OBJECT smob \a obj_s.
+ *
+ * \note Scheme API: Implements the %object-type procedure in the
+ * (geda core object) module.
+ *
+ * \param [in] obj_s an #OBJECT smob.
+ * \return a Scheme symbol representing the object type.
+ */
+SCM_DEFINE (object_type, "%object-type", 1, 0, 0,
+ (SCM obj_s), "Get an object smob's type")
+{
+ SCM result;
+
+ SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
+ SCM_ARG1, s_object_type);
+
+ OBJECT *obj = edascm_to_object (obj_s);
+ switch (obj->type) {
+ case OBJ_LINE: result = line_sym; break;
+ case OBJ_NET: result = net_sym; break;
+ case OBJ_BUS: result = bus_sym; break;
+ case OBJ_BOX: result = box_sym; break;
+ case OBJ_PICTURE: result = picture_sym; break;
+ case OBJ_CIRCLE: result = circle_sym; break;
+ case OBJ_PLACEHOLDER:
+ case OBJ_COMPLEX: result = complex_sym; break;
+ case OBJ_TEXT: result = text_sym; break;
+ case OBJ_PATH: result = path_sym; break;
+ case OBJ_PIN: result = pin_sym; break;
+ case OBJ_ARC: result = arc_sym; break;
+ default:
+ g_critical ("o_mirror_world: object %p has bad type '%c'\n",
+ obj, obj->type);
+ result = SCM_BOOL_F;
+ }
+
+ return result;
+}
+
+/*!
+ * \brief Create the (geda core object) Scheme module.
+ * \par Function Description
+ * Defines procedures in the (geda core object) module. The module can
+ * be accessed using (use-modules (geda core object)).
+ */
+static void
+init_module_geda_core_object ()
+{
+ /* Register the functions and symbols */
+ #include "scheme_object.x"
+
+ /* Add them to the module's public definitions. */
+ scm_c_export (s_object_type, NULL);
+}
+
+/*!
+ * \brief Initialise the basic gEDA object manipulation procedures.
+ * \par Function Description
+ * Registers some Scheme procedures for working with #OBJECT
+ * smobs. Should only be called by scheme_api_init().
+ */
+void
+edascm_init_object ()
+{
+ /* Define the (geda core object) module */
+ scm_c_define_module ("geda core object",
+ init_module_geda_core_object,
+ NULL);
+}
commit 4b52e3e739dca7b880f6909110b0225b2a7d6ea4
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Convert Scheme object lists to GLists and vice versa.
The libgeda C API makes extensive use of GLists (doubly-linked lists
from GLib). Since the Scheme API will frequently need to convert back
and forth between these and native Scheme cons-based singly-linked
lists, provide some utility functions for doing this conversion.
diff --git a/libgeda/include/libgedaguile_priv.h b/libgeda/include/libgedaguile_priv.h
index fd3c1d2..9bd0e28 100644
--- a/libgeda/include/libgedaguile_priv.h
+++ b/libgeda/include/libgedaguile_priv.h
@@ -117,3 +117,8 @@ SCM edascm_from_toplevel (TOPLEVEL *toplevel);
/* Set whether a gEDA object may be garbage collected. */
void edascm_c_set_gc (SCM smob, int gc);
+
+/* ---------------------------------------- */
+
+GList *edascm_to_object_glist (SCM objs, const char *subr);
+SCM edascm_from_object_glist (const GList *objs);
diff --git a/libgeda/src/Makefile.am b/libgeda/src/Makefile.am
index b42a222..3191e0d 100644
--- a/libgeda/src/Makefile.am
+++ b/libgeda/src/Makefile.am
@@ -9,7 +9,8 @@ BUILT_SOURCES = \
scheme_api_sources = \
scheme_init.c \
scheme_smob.c \
- scheme_toplevel.c
+ scheme_toplevel.c \
+ scheme_object.c
libgeda_la_SOURCES = \
$(scheme_api_sources) \
diff --git a/libgeda/src/scheme_object.c b/libgeda/src/scheme_object.c
new file mode 100644
index 0000000..9221771
--- /dev/null
+++ b/libgeda/src/scheme_object.c
@@ -0,0 +1,105 @@
+/* gEDA - GPL Electronic Design Automation
+ * libgeda - gEDA's library - Scheme API
+ * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+ */
+
+/*!
+ * \file scheme_object.c
+ * \brief Scheme API object manipulation procedures.
+ */
+
+#include <config.h>
+
+#include "libgeda_priv.h"
+#include "libgedaguile_priv.h"
+
+SCM_SYMBOL (wrong_type_arg_sym , "wrong-type-arg");
+
+/*! \brief Convert a Scheme object list to a GList.
+ * \par Function Description
+ * Takes a Scheme list of #OBJECT smobs, and returns a GList
+ * containing the objects. If \a objs is not a list of #OBJECT smobs,
+ * throws a Scheme error.
+ *
+ * \warning If the #OBJECT structures in the GList are to be stored by
+ * C code and later free()'d directly, the smobs must be marked as
+ * unsafe for garbage collection (by calling edascm_c_set_gc()).
+ *
+ * \param [in] objs a Scheme list of #OBJECT smobs.
+ * \param [in] subr the name of the Scheme subroutine (used for error
+ * messages).
+ * \return a #GList of #OBJECT.
+ */
+GList *
+edascm_to_object_glist (SCM objs, const char *subr)
+{
+ GList *result = NULL;
+ SCM lst;
+
+ SCM_ASSERT (scm_is_true (scm_list_p (objs)), objs, SCM_ARGn, subr);
+
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler ((void (*)(void *))g_list_free, result, 0);
+
+ for (lst = objs; lst != SCM_EOL; lst = SCM_CDR (lst)) {
+ SCM smob = SCM_CAR (lst);
+ EDASCM_ASSERT_SMOB_VALID (smob);
+ if (!EDASCM_OBJECTP (smob)) {
+ scm_error_scm (wrong_type_arg_sym,
+ scm_from_locale_string (subr),
+ scm_from_locale_string (_("Expected a gEDA object, found ~A")),
+ scm_list_1 (smob), scm_list_1 (smob));
+ }
+ result = g_list_prepend (result, (gpointer) edascm_to_object (smob));
+ }
+
+ scm_remember_upto_here_1 (lst);
+
+ scm_dynwind_end ();
+
+ return g_list_reverse (result);
+}
+
+/*! \brief Convert a GList of objects into a Scheme list.
+ * \par Function Description
+ * Takes a GList of #OBJECT and returns a Scheme list of corresponding
+ * object smobs.
+ *
+ * \warning If the #OBJECT structures are to be subsequently managed
+ * only by Scheme, the smobs in the returned list must be marked as
+ * safe for garbage collection (by calling edascm_c_set_gc()).
+ *
+ * \param [in] objs a #GList of #OBJECT instances.
+ * \return a Scheme list of smobs corresponding to each #OBJECT.
+ */
+SCM
+edascm_from_object_glist (const GList *objs)
+{
+ SCM lst = SCM_EOL;
+ SCM rlst;
+ GList *iter = (GList *) objs;
+
+ while (iter != NULL) {
+ lst = scm_cons (edascm_from_object (iter->data), lst);
+ iter = g_list_next (iter);
+ }
+
+ rlst = scm_reverse (lst);
+
+ scm_remember_upto_here_1 (lst);
+ return rlst;
+}
commit feefbf9f0746f23c3d388d075c7c5d9c38d91afc
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Test suite based on geda-shell program.
Adds a test suite for libgeda's Scheme API. This is run using the
geda-shell REPL.
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index a0ea6ad..bf0b204 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -2,6 +2,16 @@
scmdatadir = $(GEDADATADIR)/scheme
nobase_dist_scmdata_DATA = geda.scm color-map.scm
+# Unit test support. The unit tests are run using the geda-batch
+# program, with config loading disabled (-q) so that user config
+# already on the system can't interfere with the test process.
+TESTS_ENVIRONMENT = $(builddir)/../shell/geda-shell -q -L $(srcdir) \
+ -c '(use-modules (unit-test)) (load (list-ref (command-line) 1)) (exit (if (tests-passed?) 0 1))'
+
+TESTS = unit-tests/t0001-geda-conf-lib.scm
+
+dist_noinst_DATA = unit-test.scm $(TESTS)
+
MOSTLYCLEANFILES = *.log *~
CLEANFILES = *.log *~
DISTCLEANFILES = *.log core FILE *~
diff --git a/libgeda/scheme/unit-test.scm b/libgeda/scheme/unit-test.scm
new file mode 100644
index 0000000..39ac84a
--- /dev/null
+++ b/libgeda/scheme/unit-test.scm
@@ -0,0 +1,133 @@
+;; Minimal Scheme unit-test framework
+;; Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+;; Example of usage
+;; ----------------
+;;
+;; The following program:
+;;
+;; (use-modules (unit-test))
+;; (begin-test 'SuccessfulTest
+;; (assert-true #t)
+;; (assert-equal 1 1))
+;; (assert-thrown 'misc-error (error "Blah ~A" "Blah"))
+;; (begin-test 'FailTest
+;; (assert-equal #t "string"))
+;; (report-tests)
+;;
+;; Produces the output:
+;;
+;; SuccessfulTest... passed
+;; FailTest... failed
+;; assert-equal: expected: #t got: "string"
+;; Test summary
+;; Passed: 1
+;; Failed: 1
+;;
+
+(define-module (unit-test)
+ #:use-module (ice-9 pretty-print)
+ #:use-syntax (ice-9 syncase)
+ #:export (assert-true
+ assert-equal
+ %assert-thrown
+ tests-passed?
+ report-tests
+ %begin-test)
+ #:export-syntax (begin-test
+ assert-thrown))
+
+(define *failed-tests* '())
+(define *passed-tests* '())
+
+(define (assert-true result)
+ (if result
+ #t
+ (throw 'test-failed-exception
+ (with-output-to-string
+ (lambda ()
+ (display " assert-true: ")
+ (display "got: ")
+ (write result))))))
+
+(define (assert-equal expected result)
+ (if (equal? expected result)
+ #t
+ (throw 'test-failed-exception
+ (with-output-to-string
+ (lambda ()
+ (display " assert-equal: expected: ")
+ (write expected)
+ (display " got: ")
+ (write result))))))
+
+(define (%assert-thrown key thunk)
+ (catch key
+ (lambda ()
+ (thunk)
+ (throw 'test-failed-exception
+ (with-output-to-string
+ (lambda ()
+ (display " assert-thrown: expected exception: ")
+ (write key)))))
+ (lambda (key . args) #t)))
+
+(define (%begin-test name test-thunk)
+ (let ((test-success #t)
+ (test-fail-msg #f))
+ (display name) (display "... ")
+
+ (catch #t test-thunk
+ (lambda (key . args)
+ (set! test-success #f)
+ (set! test-fail-msg
+ (if (eqv? key 'test-failed-exception)
+ (car args)
+ (with-output-to-string
+ (lambda ()
+ (display " unexpected exception: ")
+ (write (cons key args))))))))
+
+ (if test-success
+ (begin
+ (display "passed")
+ (set! *passed-tests* (cons name *passed-tests*)))
+ (begin
+ (display "failed")
+ (if test-fail-msg
+ (begin
+ (newline)
+ (display test-fail-msg)))
+ (set! *failed-tests* (cons name *failed-tests*))))
+ (newline)))
+
+(define-syntax begin-test
+ (syntax-rules ()
+ ((_ name . test-forms)
+ (%begin-test name (lambda () . test-forms)))))
+
+(define-syntax assert-thrown
+ (syntax-rules ()
+ ((_ key . test-forms)
+ (%assert-thrown key (lambda () . test-forms)))))
+
+(define (tests-passed?) (null? *failed-tests*))
+
+(define (report-tests)
+ (display "Test summary")(newline)
+ (display "Passed: ") (display (length *passed-tests*)) (newline)
+ (display "Failed: ") (display (length *failed-tests*)) (newline))
diff --git a/libgeda/scheme/unit-tests/t0001-geda-conf-lib.scm b/libgeda/scheme/unit-tests/t0001-geda-conf-lib.scm
new file mode 100644
index 0000000..38ba902
--- /dev/null
+++ b/libgeda/scheme/unit-tests/t0001-geda-conf-lib.scm
@@ -0,0 +1,26 @@
+;; Test Scheme procedures defined in geda.scm. Makes blatant
+;; assumptions about the current directory. Oh well.
+
+(use-modules (unit-test))
+
+(load-from-path "geda.scm")
+
+(begin-test 'build-path
+ (assert-equal
+ "prefix/suffix"
+ (build-path "prefix" "suffix"))
+ (assert-equal
+ "/path/to/a/directory"
+ (build-path "/path" "to" "a" "directory")))
+
+(begin-test 'regular-file?
+ (assert-true (regular-file? "Makefile"))
+ (assert-true (not (regular-file? "."))))
+
+(begin-test 'directory?
+ (assert-true (directory? "."))
+ (assert-true (not (directory? "Makefile"))))
+
+(begin-test 'has-suffix?
+ (assert-true (has-suffix? "unit-test.scm" ".scm"))
+ (assert-true (not (has-suffix? "Makefile" ".scm"))))
commit 4e1f04c285a0a66f56c027a38709d0b3ec205c65
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
libgeda: Add geda-shell program.
Adds a minimal Scheme REPL program to libgeda. This is not installed,
but is useful for debugging issues with libgeda's Scheme API.
diff --git a/configure.ac b/configure.ac
index cd57cb0..7826550 100644
--- a/configure.ac
+++ b/configure.ac
@@ -174,6 +174,7 @@ AC_CONFIG_FILES([Makefile
libgeda/libgeda.pc
libgeda/po/domain.mak
libgeda/po/Makefile.in
+ libgeda/shell/Makefile
libgeda/data/Makefile
libgeda/docs/Makefile
libgeda/docs/images/Makefile
diff --git a/libgeda/Makefile.am b/libgeda/Makefile.am
index 2ecda29..927c607 100644
--- a/libgeda/Makefile.am
+++ b/libgeda/Makefile.am
@@ -1,5 +1,5 @@
-SUBDIRS = po data docs include lib scheme share src
+SUBDIRS = po data docs include lib src shell scheme share
EXTRA_DIST = HACKING BUGS ChangeLog ChangeLog-1.0 po/domain.mak.in
diff --git a/libgeda/shell/.gitignore b/libgeda/shell/.gitignore
new file mode 100644
index 0000000..b2dd427
--- /dev/null
+++ b/libgeda/shell/.gitignore
@@ -0,0 +1,5 @@
+*.x
+*.o
+geda-shell
+.deps
+.objs
diff --git a/libgeda/shell/Makefile.am b/libgeda/shell/Makefile.am
new file mode 100644
index 0000000..f2da672
--- /dev/null
+++ b/libgeda/shell/Makefile.am
@@ -0,0 +1,26 @@
+noinst_PROGRAMS = geda-shell
+
+BUILT_SOURCES = \
+ shell.x
+
+geda_shell_SOURCES = shell.c
+
+geda_shell_CPPFLAGS = \
+ -I$(srcdir)/../include -I$(top_srcdir) -I$(includedir) \
+ -I$(top_srcdir)/intl
+geda_shell_CFLAGS = \
+ $(GCC_CFLAGS) $(MINGW_CFLAGS) $(GUILE_CFLAGS) $(GLIB_CFLAGS) \
+ $(GDK_PIXBUF_CFLAGS)
+geda_shell_LDFLAGS = $(GLIB_LIBS) $(GUILE_LIBS) $(GDK_PIXBUF_LIBS)
+geda_shell_LDADD = ../src/libgeda.la @LIBINTL@
+
+localedir = @datadir@/locale
+DEFS = -DLOCALEDIR=\"$(localedir)\" @DEFS@
+
+# This is used to generate boilerplate for defining Scheme functions
+# in C.
+SUFFIXES = .x
+snarf_cpp_opts = $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
+ $(geda_shell_CPPFLAGS) $(AM_CFLAGS) $(geda_shell_CFLAGS)
+.c.x:
+ $(GUILE_SNARF) -o $@ $< $(snarf_cpp_opts)
diff --git a/libgeda/shell/shell.c b/libgeda/shell/shell.c
new file mode 100644
index 0000000..9335e37
--- /dev/null
+++ b/libgeda/shell/shell.c
@@ -0,0 +1,236 @@
+/*
+ * geda-shell: Batch processing for gEDA
+ * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
+
+/* A simple batch processing interface to libgeda based on a Scheme
+ * REPL (Read-Eval-Print Loop). */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+#include <version.h>
+
+#include <unistd.h>
+#include <stdio.h>
+#include <string.h>
+#include <ctype.h>
+
+#include <libgeda/libgeda.h>
+#include <libgeda/libgedaguile.h>
+
+#define GETOPT_OPTIONS "s:c:L:l:qhv"
+
+/* Print help info and exit with exit_status */
+static void
+usage (int exit_status)
+{
+ printf(
+"Usage: geda-shell OPTION ...\n"
+"\n"
+"Shell for interactive processing of gEDA data\n"
+"\n"
+" -s FILE load Scheme source code from FILE, and exit\n"
+" -c EXPR evaluate Scheme expression EXPR, and exit\n"
+" -- stop scanning arguments; run interactively\n"
+"\n"
+"The above switches stop argument processing, and pass all\n"
+"remaining arguments as the value of (command-line).\n"
+"\n"
+" -L DIRECTORY add DIRECTORY to the front of the module load path\n"
+" -l FILE load Scheme source code from FILE\n"
+" -q inhibit loading of gafrc files\n"
+" -h display this message and exit\n"
+" -v display version information and exit\n"
+"\n"
+"Please report bugs to geda-bug@xxxxxxxx\n"
+ );
+ exit (exit_status);
+}
+
+/* Print version info and exit */
+static void
+version ()
+{
+ printf (
+"gEDA " PACKAGE_GIT_VERSION "\n"
+"Copyright (C) 1998-2010 gEDA developers\n"
+"This is free software, and you are welcome to redistribute it under\n"
+"certain conditions. For details, see the file `COPYING', which is\n"
+"included in the gEDA distribution.\n"
+"There is NO WARRANTY, to the extent permitted by law.\n"
+ );
+ exit(0);
+}
+
+/* Some symbols we need */
+SCM_SYMBOL (sym_load, "load");
+SCM_SYMBOL (sym_eval_string, "eval-string");
+SCM_SYMBOL (sym_set_x, "set!");
+SCM_SYMBOL (sym_load_path, "%load-path");
+SCM_SYMBOL (sym_cons, "cons");
+SCM_SYMBOL (sym_use_modules, "use-modules");
+SCM_SYMBOL (sym_ice_9, "ice-9");
+SCM_SYMBOL (sym_readline, "readline");
+SCM_SYMBOL (sym_activate_readline, "activate-readline");
+SCM_SYMBOL (sym_top_repl, "top-repl");
+SCM_SYMBOL (sym_quit, "quit");
+SCM_SYMBOL (sym_begin, "begin");
+
+static void
+shell_main (void *data, int argc, char **argv)
+{
+ SCM setup_lst = SCM_EOL; /* We reverse! this before using it. */
+ SCM run_lst = SCM_EOL; /* We reverse! this before using it. */
+ int c;
+ int interactive = 1;
+ int inhibit_rc = 0;
+ int status;
+ TOPLEVEL *toplevel;
+
+ #include "shell.x"
+
+ /* Parse command-line arguments */
+ opterr = 0;
+ while ((c = getopt (argc, argv, GETOPT_OPTIONS)) != -1) {
+ switch (c) {
+ case 's':
+ /* Construct an application of LOAD to the script name */
+ run_lst = scm_cons (scm_list_2 (sym_load,
+ scm_from_locale_string (optarg)),
+ run_lst);
+ interactive = 0;
+ goto endoptloop;
+ case 'c':
+ /* We need to evaluate an expression */
+ run_lst = scm_cons (scm_list_2 (sym_eval_string,
+ scm_from_locale_string (optarg)),
+ run_lst);
+ interactive = 0;
+ goto endoptloop;
+ case 'L':
+ /* Add argument to %load-path */
+ setup_lst = scm_cons (scm_list_3 (sym_set_x,
+ sym_load_path,
+ scm_list_3 (sym_cons,
+ scm_from_locale_string (optarg),
+ sym_load_path)),
+ setup_lst);
+ break;
+ case 'l':
+ /* Same as -s, pretty much */
+ run_lst = scm_cons (scm_list_2 (sym_load,
+ scm_from_locale_string (optarg)),
+ run_lst);
+ break;
+ case 'q':
+ inhibit_rc = 1;
+ break;
+ case 'h':
+ usage (0);
+ case 'v':
+ version();
+ case '?':
+ if ((optopt != ':') && (strchr (GETOPT_OPTIONS, optopt) != NULL)) {
+ fprintf (stderr,
+ "ERROR: -%c option requires an argument.\n\n",
+ optopt);
+ usage (1);
+ } else if (isprint (optopt)) {
+ fprintf (stderr, "ERROR: Unknown option -%c\n\n", optopt);
+ usage (1);
+ } else {
+ fprintf (stderr,
+ "ERROR: Unknown option character `\\x%x'.\n\n",
+ optopt);
+ usage (1);
+ }
+ default:
+ g_assert_not_reached ();
+ }
+ }
+
+ endoptloop:
+ /* Set program arguments visible from Guile */
+ scm_set_program_arguments (argc - optind, argv + optind, "geda-shell");
+
+ /* If interactive mode, load readline and run top REPL. */
+ if (interactive) {
+ run_lst = scm_cons (scm_list_2 (sym_use_modules,
+ scm_list_2 (sym_ice_9, sym_readline)),
+ run_lst);
+ run_lst = scm_cons (scm_list_1 (sym_activate_readline), run_lst);
+ run_lst = scm_cons (scm_list_1 (sym_top_repl), run_lst);
+
+ /* Print GPL bumf if necessary */
+ if (isatty (1) && isatty (0)) {
+
+ printf (
+"gEDA " PACKAGE_GIT_VERSION "\n"
+"Copyright (C) 1998-2010 gEDA developers\n"
+"This is free software, and you are welcome to redistribute it under\n"
+"certain conditions. For details, see the file `COPYING', which is\n"
+"included in the gEDA distribution.\n"
+"There is NO WARRANTY, to the extent permitted by law.\n"
+ );
+ }
+
+ } else {
+ run_lst = scm_cons (scm_list_1 (sym_quit), run_lst);
+ }
+
+ /* Reverse lists */
+ setup_lst = scm_reverse_x (setup_lst, SCM_UNDEFINED);
+ run_lst = scm_reverse_x (run_lst, SCM_UNDEFINED);
+
+ /* Initialise libgeda */
+ libgeda_init ();
+ scm_dynwind_begin (0);
+ toplevel = s_toplevel_new ();
+ edascm_dynwind_toplevel (toplevel);
+
+ /* First run the setup list */
+ if (setup_lst != SCM_EOL) {
+ setup_lst = scm_cons (sym_begin, setup_lst);
+ scm_eval_x (setup_lst, scm_current_module ());
+ }
+
+ /* Now load rc files, if necessary */
+ if (!inhibit_rc) {
+ g_rc_parse_system_rc (toplevel, "gafrc");
+ g_rc_parse_home_rc (toplevel, "gafrc");
+ g_rc_parse_local_rc (toplevel, "gafrc");
+ }
+ i_vars_libgeda_set (toplevel); /* Ugh */
+
+ /* Finally evaluate run list */
+ run_lst = scm_cons (sym_begin, run_lst);
+ status = scm_exit_status (scm_eval_x (run_lst, scm_current_module ()));
+ exit (status);
+
+ scm_dynwind_end ();
+
+ scm_remember_upto_here_2 (setup_lst, run_lst);
+}
+
+/* This just starts guile, which calls shell_main back */
+int
+main (int argc, char **argv)
+{
+ scm_boot_guile (argc, argv, shell_main, NULL);
+ return 0;
+}
commit a61805445c844b30f0e9de1c8003249fdedeee66
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
gnetlist: Use TOPLEVEL fluid.
Modifies gnetlist to use edascm_c_current_toplevel() instead of a
global variable to allow Scheme functions to access the global libgeda
state.
diff --git a/gnetlist/src/g_netlist.c b/gnetlist/src/g_netlist.c
index b3af8fa..d5cae12 100644
--- a/gnetlist/src/g_netlist.c
+++ b/gnetlist/src/g_netlist.c
@@ -27,6 +27,7 @@
#include <math.h>
#include <libgeda/libgeda.h>
+#include <libgeda/libgedaguile.h>
#include "../include/globals.h"
#include "../include/prototype.h"
@@ -36,15 +37,6 @@
#endif
-/* current project */
-static TOPLEVEL *project_current;
-
-void g_set_project_current(TOPLEVEL * pr_current)
-{
- project_current = pr_current;
-}
-
-
SCM g_scm_c_get_uref (TOPLEVEL *toplevel, OBJECT *object)
{
SCM func = scm_variable_ref (scm_c_lookup ("get-uref"));
@@ -687,13 +679,14 @@ SCM g_get_toplevel_attribute(SCM scm_wanted_attrib)
char *wanted_attrib;
char *attrib_value = NULL;
SCM scm_return_value;
+ TOPLEVEL *toplevel = edascm_c_current_toplevel ();
SCM_ASSERT(scm_is_string (scm_wanted_attrib),
scm_wanted_attrib, SCM_ARG1, "gnetlist:get-toplevel-attribute");
wanted_attrib = SCM_STRING_CHARS (scm_wanted_attrib);
- for (p_iter = geda_list_get_glist (project_current->pages); p_iter != NULL;
+ for (p_iter = geda_list_get_glist (toplevel->pages); p_iter != NULL;
p_iter = g_list_next (p_iter)) {
p_current = p_iter->data;
diff --git a/gnetlist/src/gnetlist.c b/gnetlist/src/gnetlist.c
index 3471b97..c5490b5 100644
--- a/gnetlist/src/gnetlist.c
+++ b/gnetlist/src/gnetlist.c
@@ -37,6 +37,7 @@
#include <libgeda/libgeda.h>
+#include <libgeda/libgedaguile.h>
#include "../include/globals.h"
#include "../include/prototype.h"
@@ -157,7 +158,10 @@ void main_prog(void *closure, int argc, char *argv[])
/* register guile (scheme) functions */
g_register_funcs();
+ scm_dynwind_begin (0);
pr_current = s_toplevel_new ();
+ edascm_dynwind_toplevel (pr_current);
+
g_rc_parse(pr_current, "gnetlistrc", rc_filename);
/* immediately setup user params */
i_vars_set (pr_current);
@@ -232,7 +236,6 @@ void main_prog(void *closure, int argc, char *argv[])
usage(argv[0]);
}
- g_set_project_current(pr_current);
#if DEBUG
s_page_print_all(pr_current);
#endif
@@ -312,6 +315,8 @@ void main_prog(void *closure, int argc, char *argv[])
}
gnetlist_quit();
+
+ scm_dynwind_end();
}
int main(int argc, char *argv[])
commit 4203e5e08b5341613ad6de08191f4feafb243687
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Basic smob predicates.
diff --git a/libgeda/include/libgeda/libgedaguile.h b/libgeda/include/libgeda/libgedaguile.h
index e498a48..f440297 100644
--- a/libgeda/include/libgeda/libgedaguile.h
+++ b/libgeda/include/libgeda/libgedaguile.h
@@ -48,3 +48,9 @@ PAGE *edascm_to_page (SCM smob);
/* Retrieve an object structure from a Guile value. */
OBJECT *edascm_to_object (SCM smob);
+
+/* Test if smob is a gEDA page. */
+int edascm_is_page (SCM smob);
+
+/* Test if smob is a gEDA object. */
+int edascm_is_object (SCM smob);
diff --git a/libgeda/src/scheme_smob.c b/libgeda/src/scheme_smob.c
index eb13f0c..de46fb0 100644
--- a/libgeda/src/scheme_smob.c
+++ b/libgeda/src/scheme_smob.c
@@ -319,16 +319,110 @@ edascm_c_set_gc (SCM smob, int gc)
EDASCM_SMOB_SET_GC (smob, gc);
}
-/*! \brief Initialise gEDA smob types etc
+/*! \brief Test whether a smob is a #OBJECT instance
* \par Function Description
- * Carry out initial setup of gEDA smob types, modules, procedures etc.
- * Should only be called by edascm_init().
+ * If \a smob is a #OBJECT instance, returns non-zero. Otherwise,
+ * returns zero.
+ *
+ * \param [in] smob Guile value to test.
+ *
+ * \return non-zero iff \a smob is a #OBJECT instance.
+ */
+int
+edascm_is_object (SCM smob)
+{
+ return EDASCM_OBJECTP (smob);
+}
+
+/*! \brief Test whether a smob is a #PAGE instance
+ * \par Function Description
+ * If \a smob is a #PAGE instance, returns non-zero. Otherwise,
+ * returns zero.
+ *
+ * \param [in] smob Guile value to test.
+ *
+ * \return non-zero iff \a smob is a #PAGE instance.
+ */
+int
+edascm_is_page (SCM smob)
+{
+ return EDASCM_PAGEP (smob);
+}
+
+/*! \brief Test whether a smob is a #PAGE instance.
+ * \par Function Description
+ * If \a page_smob is a #PAGE instance, returns \b SCM_BOOL_T;
+ * otherwise returns \b SCM_BOOL_F.
+ *
+ * \note Scheme API: Implements the %page? procedure in the (geda
+ * core smob) module.
+ *
+ * \param [in] page_smob Guile value to test.
+ *
+ * \return SCM_BOOL_T iff \a page_smob is a #PAGE instance.
+ */
+SCM_DEFINE (page_p, "%page?", 1, 0, 0,
+ (SCM page_smob),
+ "Test whether the value is a gEDA PAGE instance.")
+{
+ return (EDASCM_PAGEP (page_smob) ? SCM_BOOL_T : SCM_BOOL_F);
+}
+
+/*! \brief Test whether a smob is an #OBJECT instance.
+ * \par Function Description
+ * If \a object_smob is an #OBJECT instance, returns \b SCM_BOOL_T;
+ * otherwise returns \b SCM_BOOL_F.
+ *
+ * \note Scheme API: Implements the %object? procedure in the (geda
+ * core smob) module.
+ *
+ * \param [in] object_smob Guile value to test.
+ *
+ * \return SCM_BOOL_T iff \a object_smob is an #OBJECT instance.
+ */
+SCM_DEFINE (object_p, "%object?", 1, 0, 0,
+ (SCM object_smob),
+ "Test whether the value is a gEDA OBJECT instance.")
+{
+ return (EDASCM_OBJECTP (object_smob) ? SCM_BOOL_T : SCM_BOOL_F);
+}
+
+/*!
+ * \brief Create the (geda core smob) Scheme module.
+ * \par Function Description
+ * Defines procedures in the (geda core smob) module. The module can
+ * be accessed using (use-modules (geda core smob)).
+ */
+static void
+init_module_geda_core_smob ()
+{
+ /* Register the functions. */
+ #include "scheme_smob.x"
+
+ /* Add them to the module's public definitions. */
+ scm_c_export (s_page_p, s_object_p, NULL);
+}
+
+/*!
+ * \brief Initialise the basic gEDA smob types.
+ * \par Function Description
+ * Registers the gEDA core smob types and some procedures acting on
+ * them. gEDA only uses a single Guile smob, and uses the flags field
+ * to multiplex the several different underlying C structures that may
+ * be represented by that smob. Should only be called by
+ * edascm_init().
*/
void
edascm_init_smob ()
{
+ /* Register gEDA smob type */
geda_smob_tag = scm_make_smob_type ("geda", 0);
scm_set_smob_free (geda_smob_tag, smob_free);
scm_set_smob_print (geda_smob_tag, smob_print);
scm_set_smob_equalp (geda_smob_tag, smob_equalp);
+
+ /* Define the (geda core smob) module */
+ scm_c_define_module ("geda core smob",
+ init_module_geda_core_smob,
+ NULL);
}
commit b235a037d0ce1c525195141d77fd7b8cae85e8be
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Basic smob definitions & TOPLEVEL fluid.
Adds a new smob type for gEDA objects (TOPLEVEL, PAGE and OBJECT, at
least initially), along with C functions for creating smobs. Weak
references are used to ensure that smobs pointing to dead objects are
invalidated.
Additionally, defines a fluid which contains the current TOPLEVEL.
This is used by the Scheme API to obtain the TOPLEVEL needed for
calling much of the libgeda API.
diff --git a/libgeda/include/libgeda/libgedaguile.h b/libgeda/include/libgeda/libgedaguile.h
index f8043b2..e498a48 100644
--- a/libgeda/include/libgeda/libgedaguile.h
+++ b/libgeda/include/libgeda/libgedaguile.h
@@ -26,3 +26,25 @@
/* Initialise the Scheme API. */
void edascm_init ();
+
+/* Get the value of the #TOPLEVEL fluid. */
+TOPLEVEL *edascm_c_current_toplevel ();
+
+/* Set the #TOPLEVEL fluid in the current dynamic context. */
+void edascm_dynwind_toplevel (TOPLEVEL *toplevel);
+
+/* Set the current #TOPLEVEL temporarily. */
+SCM edascm_c_with_toplevel (TOPLEVEL *toplevel, SCM (*func)(void *),
+ void *user_data);
+
+/* Create a Guile value from a page structure. */
+SCM edascm_from_page (PAGE *page);
+
+/* Create a Guile value from an object structure. */
+SCM edascm_from_object (OBJECT *object);
+
+/* Retrieve a page structure from a Guile value. */
+PAGE *edascm_to_page (SCM smob);
+
+/* Retrieve an object structure from a Guile value. */
+OBJECT *edascm_to_object (SCM smob);
diff --git a/libgeda/include/libgedaguile_priv.h b/libgeda/include/libgedaguile_priv.h
index 4ef4ec4..fd3c1d2 100644
--- a/libgeda/include/libgedaguile_priv.h
+++ b/libgeda/include/libgedaguile_priv.h
@@ -25,3 +25,95 @@
*/
#include <libgeda/libgedaguile.h>
+
+void edascm_init_smob ();
+void edascm_init_toplevel ();
+
+/* ---------------------------------------- */
+
+/* Macros and constants for working with the geda smob type. These are
+ * for the convenience of the other C functions used by the Scheme
+ * API. */
+
+/*! The tag used to identify gEDA data structures in Scheme. */
+extern scm_t_bits geda_smob_tag;
+
+/*! The flags used to determine which C structure a smob contains. */
+enum geda_smob_flags {
+ GEDA_SMOB_TOPLEVEL = 0,
+ GEDA_SMOB_PAGE = 1,
+ GEDA_SMOB_OBJECT = 2,
+ GEDA_SMOB_TYPE_MASK = 0xf,
+ GEDA_SMOB_GC_FLAG = 0x100,
+};
+
+/*! Retrieve the type flags for a gEDA smob. */
+#define EDASCM_SMOB_TYPE(x) (SCM_SMOB_FLAGS (x) & GEDA_SMOB_TYPE_MASK)
+
+/*! \brief Test the type of a gEDA smob.
+ * \par Macro Description
+ * Returns non-zero if \a x is a gEDA smob and the type flags of \a x
+ * match \a type.
+ */
+#define EDASCM_SMOB_TYPEP(x, type) \
+ (SCM_SMOB_PREDICATE (geda_smob_tag, x) && (EDASCM_SMOB_TYPE (x) == type))
+
+/*! \brief Test whether a gEDA smob is valid.
+ * \par Macro Description
+ * Returns non-zero if \a x is a gEDA smob and the pointer it contains
+ * is valid.
+ */
+#define EDASCM_SMOB_VALIDP(x) \
+ (SCM_SMOB_PREDICATE (geda_smob_tag, x) && ((void *)SCM_SMOB_DATA (x) != NULL))
+
+/*! \brief Assert that a gEDA smob is valid.
+ * \par Macro Description
+ * Throw an error if assertions are enabled and \a x is invalid.
+ */
+#ifdef NDEBUG
+# define EDASCM_ASSERT_SMOB_VALID(x)
+#else
+# define EDASCM_ASSERT_SMOB_VALID(x) \
+ do { if (!EDASCM_SMOB_VALIDP(x)) { \
+ scm_misc_error (NULL, "Found invalid gEDA smob ~S", scm_list_1 (x)); \
+ } } while (0)
+#endif
+
+/* Create a Guile value from a TOPLEVEL structure. */
+SCM edascm_from_toplevel (TOPLEVEL *toplevel);
+
+/*! Tests whether a Scheme value is a TOPLEVEL smob. */
+#define EDASCM_TOPLEVELP(x) EDASCM_SMOB_TYPEP(x, GEDA_SMOB_TOPLEVEL)
+
+/*! Tests whether a Scheme value is a PAGE smob. */
+#define EDASCM_PAGEP(x) EDASCM_SMOB_TYPEP(x, GEDA_SMOB_PAGE)
+
+/*! Tests whether a Scheme value is an OBJECT smob. */
+#define EDASCM_OBJECTP(x) EDASCM_SMOB_TYPEP(x, GEDA_SMOB_OBJECT)
+
+/*!
+ * \brief Test whether a structure may be garbage-collected
+ * \par Macro Description
+ * Tests whether the C structure contained by the smob \a x is only
+ * referenced by Scheme code, and thus can be free()'d when \a x is
+ * garbage-collected.
+ */
+#define EDASCM_SMOB_GCP(x) \
+ (SCM_SMOB_PREDICATE (geda_smob_tag, x) && ((SCM_SMOB_FLAGS (x) & GEDA_SMOB_GC_FLAG) != 0))
+
+/*!
+ * \brief Set whether a structure may be garbage-collected
+ * \par Macro Description
+ * Set whether the structure contained by the smob \a x is only
+ * referenced by Scheme code, and thus should be free()'d when \a x is
+ * garbage-collected.
+ *
+ * \param x Smob to modify.
+ * \param gc Non-zero if \a x should be garbage-collected.
+ */
+#define EDASCM_SMOB_SET_GC(x, gc) \
+ SCM_SET_SMOB_FLAGS (x, gc ? (SCM_SMOB_FLAGS (x) | GEDA_SMOB_GC_FLAG) \
+ : (SCM_SMOB_FLAGS (x) & ~GEDA_SMOB_GC_FLAG))
+
+/* Set whether a gEDA object may be garbage collected. */
+void edascm_c_set_gc (SCM smob, int gc);
diff --git a/libgeda/src/Makefile.am b/libgeda/src/Makefile.am
index 77e47ce..b42a222 100644
--- a/libgeda/src/Makefile.am
+++ b/libgeda/src/Makefile.am
@@ -2,10 +2,14 @@
# Build a libtool library for installation in libdir.
lib_LTLIBRARIES = libgeda.la
-BUILT_SOURCES =
+BUILT_SOURCES = \
+ scheme_smob.x \
+ scheme_toplevel.x
scheme_api_sources = \
- scheme_init.c
+ scheme_init.c \
+ scheme_smob.c \
+ scheme_toplevel.c
libgeda_la_SOURCES = \
$(scheme_api_sources) \
diff --git a/libgeda/src/g_basic.c b/libgeda/src/g_basic.c
index 15dda39..a19627c 100644
--- a/libgeda/src/g_basic.c
+++ b/libgeda/src/g_basic.c
@@ -34,6 +34,7 @@
#endif
#include "libgeda_priv.h"
+#include "libgedaguile.h"
#ifdef HAVE_LIBDMALLOC
#include <dmalloc.h>
@@ -244,6 +245,7 @@ g_read_file(TOPLEVEL *toplevel, const gchar *filename)
{
SCM eval_result = SCM_BOOL_F;
SCM expr;
+ SCM s_filename;
char * full_filename;
if (filename == NULL) {
@@ -262,12 +264,19 @@ g_read_file(TOPLEVEL *toplevel, const gchar *filename)
return(-1);
}
- expr = scm_list_2 (scm_from_locale_symbol ("load"),
- scm_from_locale_string (full_filename));
+ s_filename = scm_from_locale_string (full_filename);
+ g_free (full_filename);
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ edascm_dynwind_toplevel (toplevel);
+
+ expr = scm_list_2 (scm_from_locale_symbol ("load"), s_filename);
eval_result = g_scm_eval_protected (expr,
scm_interaction_environment ());
- g_free(full_filename);
+ scm_dynwind_end ();
+
+ scm_remember_upto_here_1 (s_filename);
return (eval_result != SCM_BOOL_F);
}
diff --git a/libgeda/src/scheme_init.c b/libgeda/src/scheme_init.c
index 26618f6..d3ba1af 100644
--- a/libgeda/src/scheme_init.c
+++ b/libgeda/src/scheme_init.c
@@ -40,5 +40,6 @@ edascm_init ()
if (init_called) return;
init_called = 1;
- /* Do nothing yet! */
+ edascm_init_smob ();
+ edascm_init_toplevel ();
}
diff --git a/libgeda/src/scheme_smob.c b/libgeda/src/scheme_smob.c
new file mode 100644
index 0000000..eb13f0c
--- /dev/null
+++ b/libgeda/src/scheme_smob.c
@@ -0,0 +1,334 @@
+/* gEDA - GPL Electronic Design Automation
+ * libgeda - gEDA's library - Scheme API
+ * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+ */
+
+/*!
+ * \file scheme_smob.c
+ * \brief Scheme representations of gEDA C structures
+ *
+ * In order for Scheme code to be able to manipulate libgeda data
+ * structures, it is convenient for it to be able to get handles to
+ * several of the different C structures that libgeda uses, in
+ * particular #TOPLEVEL, #PAGE and #OBJECT.
+ *
+ * A particular issue is that, in principle, Guile can stash a
+ * variable somewhere and only try and access it much later, possibly
+ * after the underlying C structure has already been freed.
+ *
+ * In order to avoid this situation causing a segmentation fault, weak
+ * references are used. In the case of #PAGE and #TOPLEVEL handles,
+ * the usage is quite straightforward; Scheme code can never create or
+ * destroy a #TOPLEVEL; and although a #PAGE can be created by Scheme
+ * code, it must explicitly be destroyed if the Scheme code doesn't
+ * want the #PAGE to hang around after it returns.
+ *
+ * #OBJECT handles are a more complex case. It's possible that Scheme
+ * code may legitimately want to create an #OBJECT and do something
+ * with it (or, similarly, pull an #OBJECT out of a #PAGE), without
+ * needing to carefully keep track of the #OBJECT to avoid dropping it
+ * on the floor. In that case, users should be able to rely on the
+ * garbage collector.
+ *
+ * For that reason, an #OBJECT is marked to be destroyed by
+ * garbage-collection in two cases:
+ *
+ * -# If they have been created by Scheme code, but not yet added to a
+ * PAGE.
+ * -# If they have been removed from a #PAGE by Scheme code, but not
+ * yet re-added to a #PAGE.
+ *
+ * \sa weakref.c
+ */
+
+#include <config.h>
+
+#include "libgeda_priv.h"
+#include "libgedaguile_priv.h"
+
+scm_t_bits geda_smob_tag;
+
+/*! \brief Weak reference notify function for gEDA smobs.
+ * \par Function Description
+ * Clears a gEDA smob's pointer when the target object is destroyed.
+ */
+static void
+smob_weakref_notify (void *target, void *smob) {
+ SCM s = (SCM) smob;
+ SCM_SET_SMOB_DATA (s, NULL);
+}
+
+/*! \brief Free a gEDA smob.
+ * \par Function Description
+ * Finalizes a gEDA smob for deletion, removing the weak reference.
+ *
+ * Used internally to Guile.
+ */
+static size_t
+smob_free (SCM smob)
+{
+ void *data;
+
+ /* If the weak reference has already been cleared, do nothing */
+ if (!EDASCM_SMOB_VALIDP(smob)) return 0;
+
+ data = (void *) SCM_SMOB_DATA (smob);
+
+ /* Otherwise, clear the weak reference */
+ switch (EDASCM_SMOB_TYPE (smob)) {
+ case GEDA_SMOB_TOPLEVEL:
+ s_toplevel_weak_unref ((TOPLEVEL *) data, smob_weakref_notify, smob);
+ break;
+ case GEDA_SMOB_PAGE:
+ s_page_weak_unref ((PAGE *) data, smob_weakref_notify, smob);
+ break;
+ case GEDA_SMOB_OBJECT:
+ s_object_weak_unref ((OBJECT *) data, smob_weakref_notify, smob);
+ break;
+ default:
+ /* This should REALLY definitely never be run */
+ g_critical ("%s: received bad smob flags.", __FUNCTION__);
+ }
+
+ /* If the smob is marked as garbage-collectable, destroy its
+ * contents.
+ *
+ * Because PAGEs and TOPLEVELs should never be garbage collected,
+ * emit critical warnings if the GC tries to free them.
+ */
+ if (EDASCM_SMOB_GCP (smob)) {
+ switch (EDASCM_SMOB_TYPE (smob)) {
+ case GEDA_SMOB_TOPLEVEL:
+ g_critical ("%s: Blocked garbage-collection of TOPLEVEL %p",
+ __FUNCTION__, data);
+ break;
+ case GEDA_SMOB_PAGE:
+ g_critical ("%s: Blocked garbage-collection of PAGE %p",
+ __FUNCTION__, data);
+ break;
+ case GEDA_SMOB_OBJECT:
+ s_delete_object (edascm_c_current_toplevel(), (OBJECT *) data);
+ break;
+ default:
+ /* This should REALLY definitely never be run */
+ g_critical ("%s: received bad smob flags.", __FUNCTION__);
+ }
+ }
+ return 0;
+}
+
+/*! \brief Print a representation of a gEDA smob.
+ * \par Function Description
+ * Outputs a string representing the gEDA \a smob to a Scheme output
+ * \a port. The format used is "#<geda-TYPE b7ef65d0>", where TYPE is
+ * a string describing the C structure represented by the gEDA smob.
+ *
+ * Used internally to Guile.
+ */
+static int
+smob_print (SCM smob, SCM port, scm_print_state *pstate)
+{
+ gchar *hexstring;
+
+ scm_puts ("#<geda-", port);
+
+ switch (EDASCM_SMOB_TYPE (smob)) {
+ case GEDA_SMOB_TOPLEVEL:
+ scm_puts ("toplevel", port);
+ break;
+ case GEDA_SMOB_PAGE:
+ scm_puts ("page", port);
+ break;
+ case GEDA_SMOB_OBJECT:
+ scm_puts ("object", port);
+ break;
+ default:
+ g_critical ("%s: received bad smob flags.", __FUNCTION__);
+ scm_puts ("unknown", port);
+ }
+
+ scm_dynwind_begin (0);
+ hexstring = g_strdup_printf (" %zx", SCM_SMOB_DATA (smob));
+ scm_dynwind_unwind_handler (g_free, hexstring, SCM_F_WIND_EXPLICITLY);
+ scm_puts (hexstring, port);
+ scm_dynwind_end ();
+
+ scm_puts (">", port);
+
+ /* Non-zero means success */
+ return 1;
+}
+
+/*! \brief Check gEDA smobs for equality.
+ * \par Function description
+ * Returns SCM_BOOL_T if \a obj1 represents the same gEDA structure as
+ * \a obj2 does. Otherwise, returns SCM_BOOL_F.
+ *
+ * Used internally to Guile.
+ */
+static SCM
+smob_equalp (SCM obj1, SCM obj2)
+{
+ EDASCM_ASSERT_SMOB_VALID (obj1);
+ EDASCM_ASSERT_SMOB_VALID (obj2);
+
+ if (SCM_SMOB_DATA (obj1) == SCM_SMOB_DATA (obj2)) {
+ return SCM_BOOL_T;
+ } else {
+ return SCM_BOOL_F;
+ }
+}
+
+/*! \brief Get the smob for a TOPLEVEL.
+ * \par Function Description
+ * Create a new smob representing \a toplevel.
+ *
+ * \param toplevel #TOPLEVEL to create a smob for.
+ * \return a smob representing \a toplevel.
+ */
+SCM
+edascm_from_toplevel (TOPLEVEL *toplevel)
+{
+ SCM smob;
+
+ SCM_NEWSMOB (smob, geda_smob_tag, toplevel);
+ SCM_SET_SMOB_FLAGS (smob, GEDA_SMOB_TOPLEVEL);
+
+ /* Set weak reference */
+ s_toplevel_weak_ref (toplevel, smob_weakref_notify, smob);
+
+ return smob;
+}
+
+/*! \brief Get a smob for a page.
+ * \par Function Description
+ * Create a new smob representing \a page.
+ *
+ * \param page #PAGE to create a smob for.
+ * \return a smob representing \a page.
+ */
+SCM
+edascm_from_page (PAGE *page)
+{
+ SCM smob;
+
+ SCM_NEWSMOB (smob, geda_smob_tag, page);
+ SCM_SET_SMOB_FLAGS (smob, GEDA_SMOB_PAGE);
+
+ /* Set weak reference */
+ s_page_weak_ref (page, smob_weakref_notify, smob);
+
+ return smob;
+}
+
+/* \brief Get a page from a smob.
+ * \par Function Description
+ * Return the #PAGE represented by \a smob.
+ *
+ * \param [in] smob Guile value to retrieve #PAGE from.
+ * \return the #PAGE represented by \a smob.
+ */
+PAGE *
+edascm_to_page (SCM smob)
+{
+#ifndef NDEBUG
+ SCM_ASSERT (EDASCM_PAGEP (smob), smob,
+ SCM_ARG1, "edascm_to_page");
+#endif
+ EDASCM_ASSERT_SMOB_VALID (smob);
+
+ return (PAGE *) SCM_SMOB_DATA (smob);
+}
+
+/*! \brief Get a smob for a schematic object.
+ * \par Function Description
+ * Create a new smob representing \a object.
+ *
+ * \warning The returned smob is initially marked as owned by the C
+ * code. If it should be permitted to be garbage-collected, you
+ * should set the garbage-collectable flag by calling:
+ *
+ * \code
+ * SCM x = edascm_c_make_object (object);
+ * edascm_c_set_gc (x, 1);
+ * \endcode
+ *
+ * \param object #OBJECT to create a smob for.
+ * \return a smob representing \a object.
+ */
+SCM
+edascm_from_object (OBJECT *object)
+{
+ SCM smob;
+
+ SCM_NEWSMOB (smob, geda_smob_tag, object);
+ SCM_SET_SMOB_FLAGS (smob, GEDA_SMOB_OBJECT);
+
+ /* Set weak reference */
+ s_object_weak_ref (object, smob_weakref_notify, smob);
+
+ return smob;
+}
+
+/* \brief Get a schematic object from a smob.
+ * \par Function Description
+ * Return the #OBJECT represented by \a smob.
+ *
+ * \param [in] smob Guile value to retrieve #OBJECT from.
+ * \return the #OBJECT represented by \a smob.
+ */
+OBJECT *
+edascm_to_object (SCM smob)
+{
+#ifndef NDEBUG
+ SCM_ASSERT (EDASCM_OBJECTP (smob), smob,
+ SCM_ARG1, "edascm_to_object");
+#endif
+ EDASCM_ASSERT_SMOB_VALID (smob);
+
+ return (OBJECT *) SCM_SMOB_DATA (smob);
+}
+
+/*! \brief Set whether a gEDA object may be garbage collected.
+ * \par Function Description
+ * If \a gc is non-zero, allow the structure represented by \a smob to
+ * be destroyed when \a smob is garbage-collected.
+ *
+ * \param [in,out] smob Smob for which to set garbage-collection
+ * permission.
+ * \param [in] x If non-zero, permit garbage collection.
+ */
+void
+edascm_c_set_gc (SCM smob, int gc)
+{
+ EDASCM_ASSERT_SMOB_VALID (smob);
+ EDASCM_SMOB_SET_GC (smob, gc);
+}
+
+/*! \brief Initialise gEDA smob types etc
+ * \par Function Description
+ * Carry out initial setup of gEDA smob types, modules, procedures etc.
+ * Should only be called by edascm_init().
+ */
+void
+edascm_init_smob ()
+{
+ geda_smob_tag = scm_make_smob_type ("geda", 0);
+ scm_set_smob_free (geda_smob_tag, smob_free);
+ scm_set_smob_print (geda_smob_tag, smob_print);
+ scm_set_smob_equalp (geda_smob_tag, smob_equalp);
+}
diff --git a/libgeda/src/scheme_toplevel.c b/libgeda/src/scheme_toplevel.c
new file mode 100644
index 0000000..7774522
--- /dev/null
+++ b/libgeda/src/scheme_toplevel.c
@@ -0,0 +1,138 @@
+/* gEDA - GPL Electronic Design Automation
+ * libgeda - gEDA's library - Scheme API
+ * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+ */
+
+/*!
+ * \file scheme_toplevel.c
+ * \brief Scheme API procedures for working with the TOPLEVEL.
+ */
+
+#include <config.h>
+
+#include "libgeda_priv.h"
+#include "libgedaguile_priv.h"
+
+SCM scheme_toplevel_fluid = SCM_UNDEFINED;
+
+/*!
+ * \brief Set the #TOPLEVEL fluid in the current dynamic context.
+ * \par Function Description
+ * This function must be used inside a pair of calls to
+ * scm_dynwind_begin() and scm_dynwind_end(). During the dynwind
+ * context, the #TOPLEVEL fluid is set to \a toplevel.
+ *
+ * \note This is a part of the public C interface to the Scheme API.
+ */
+void
+edascm_dynwind_toplevel (TOPLEVEL *toplevel)
+{
+ SCM s_toplevel = edascm_from_toplevel (toplevel);
+
+ scm_dynwind_fluid (scheme_toplevel_fluid, s_toplevel);
+}
+
+/*!
+ * \brief Get the value of the #TOPLEVEL fluid.
+ * \par Function Description
+ * Return the value of the #TOPLEVEL fluid in the current dynamic
+ * context.
+ */
+SCM_DEFINE (edascm_current_toplevel, "%current-toplevel", 0, 0, 0,
+ (),
+ "Get the TOPLEVEL for the current dynamic context.")
+{
+ return scm_fluid_ref (scheme_toplevel_fluid);
+}
+
+/*!
+ * \brief Get the value of the #TOPLEVEL fluid.
+ * \par Function Description
+ * Return the value of the #TOPLEVEL fluid in the current dynamic
+ * context.
+ *
+ * \note This is a part of the public C interface to the Scheme API.
+ */
+TOPLEVEL *
+edascm_c_current_toplevel ()
+{
+ SCM s_toplevel = edascm_current_toplevel ();
+
+ EDASCM_ASSERT_SMOB_VALID(s_toplevel);
+
+ return (TOPLEVEL *) SCM_SMOB_DATA (s_toplevel);
+}
+
+/*!
+ * \brief Set the current #TOPLEVEL temporarily.
+ * \par Function Description
+ * Set the #TOPLEVEL fluid to \a toplevel and call \a thunk.
+ */
+SCM_DEFINE (edascm_with_toplevel, "%with-toplevel", 2, 0, 0,
+ (SCM toplevel, SCM thunk),
+ "Call `thunk', setting the TOPLEVEL fluid to `toplevel'.")
+{
+ return scm_with_fluid (scheme_toplevel_fluid, toplevel, thunk);
+}
+
+/*!
+ * \brief Set the current #TOPLEVEL temporarily.
+ * \par Function Description
+ * Set the #TOPLEVEL fluid to \a toplevel and call \a func with \a
+ * user_data.
+ */
+SCM
+edascm_c_with_toplevel (TOPLEVEL *toplevel, SCM (*func)(void *),
+ void *user_data)
+{
+ SCM s_toplevel = edascm_from_toplevel (toplevel);
+ return scm_c_with_fluid (scheme_toplevel_fluid, s_toplevel, func, user_data);
+}
+
+/*!
+ * \brief Create the (geda core toplevel) Scheme module
+ * \par Function Description
+ * Defines procedures in the (geda core toplevel) module. The module
+ * can be accessed using (use-modules (geda core toplevel)).
+ */
+static void
+init_module_geda_core_toplevel ()
+{
+ /* Register the functions */
+ #include "scheme_toplevel.x"
+
+ /* Add them to the module's public definitions. */
+ scm_c_export (s_edascm_with_toplevel, s_edascm_current_toplevel, NULL);
+}
+
+/*!
+ * \brief Initialise the TOPLEVEL manipulation procedures.
+ * \par Function Description
+ * Registers some Scheme procedures for working with #TOPLEVEL smobs
+ * and creates the #TOPLEVEL fluid. Should only be called by
+ * scheme_api_init().
+ */
+void
+edascm_init_toplevel ()
+{
+ scheme_toplevel_fluid = scm_permanent_object (scm_make_fluid ());
+
+ /* Define the (geda core toplevel) module */
+ scm_c_define_module ("geda core toplevel",
+ init_module_geda_core_toplevel,
+ NULL);
+}
commit 0460b8f476066ee471b4f8a79176e3a1fbbbfc55
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
libgeda: Define non-NULL default for select_func.
The code for loading/saving complex objects uses the nullity of
OBJECT.sel_func to determine whether or not a complex object should be
flagged as selectable or not. So that libgeda applications that do
not define their own select_func can safely load, modify and save
schematic files, it's necessary to have a non-NULL default
select_func.
diff --git a/libgeda/src/o_basic.c b/libgeda/src/o_basic.c
index 31e08f6..814a12e 100644
--- a/libgeda/src/o_basic.c
+++ b/libgeda/src/o_basic.c
@@ -58,8 +58,10 @@
#include <dmalloc.h>
#endif
+
+
/*! Default setting for object selection function. */
-void (*select_func)() = NULL;
+void (*select_func)() = error_if_called;
/*! \brief Check if point is inside a region
commit 57f5e1eb96577f439840afb5c008ba739055d249
Author: Peter TB Brett <peter@xxxxxxxxxxxxx>
Commit: Peter TB Brett <peter@xxxxxxxxxxxxx>
scheme-api: Build infrastructure in libgeda.
diff --git a/configure.ac b/configure.ac
index ee16213..cd57cb0 100644
--- a/configure.ac
+++ b/configure.ac
@@ -72,6 +72,8 @@ PKG_PROG_PKG_CONFIG
AX_CHECK_GUILE([1.8.0])
+AX_PROG_GUILE_SNARF
+
PKG_CHECK_MODULES(GLIB, [glib-2.0 >= 2.12.0], ,
AC_MSG_ERROR([GLib 2.12.0 or later is required.]))
diff --git a/libgeda/include/Makefile.am b/libgeda/include/Makefile.am
index a8bfbef..a40af11 100644
--- a/libgeda/include/Makefile.am
+++ b/libgeda/include/Makefile.am
@@ -11,6 +11,7 @@ libgedainclude_HEADERS = \
libgeda/o_types.h \
libgeda/papersizes.h \
libgeda/prototype.h \
+ libgeda/libgedaguile.h \
libgeda/struct.h
noinst_HEADERS = \
@@ -18,7 +19,8 @@ noinst_HEADERS = \
i_vars_priv.h \
libgeda_priv.h \
prototype_priv.h \
- struct_priv.h
+ struct_priv.h \
+ libgedaguile_priv.h
MOSTLYCLEANFILES = *.log core FILE *~
CLEANFILES = *.log core FILE *~
diff --git a/libgeda/include/libgeda/libgedaguile.h b/libgeda/include/libgeda/libgedaguile.h
new file mode 100644
index 0000000..f8043b2
--- /dev/null
+++ b/libgeda/include/libgeda/libgedaguile.h
@@ -0,0 +1,28 @@
+/* gEDA - GPL Electronic Design Automation
+ * libgeda - gEDA's library - Scheme API
+ * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+ */
+
+/*!
+ * \file libgedaguile.h
+ * Scheme API public declarations and definitions.
+ * \warning Don't include from libgeda.h: should only be included
+ * by source files that need to use the Scheme API.
+ */
+
+/* Initialise the Scheme API. */
+void edascm_init ();
diff --git a/libgeda/include/libgedaguile_priv.h b/libgeda/include/libgedaguile_priv.h
new file mode 100644
index 0000000..4ef4ec4
--- /dev/null
+++ b/libgeda/include/libgedaguile_priv.h
@@ -0,0 +1,27 @@
+/* gEDA - GPL Electronic Design Automation
+ * libgeda - gEDA's library - Scheme API
+ * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+ */
+
+/*!
+ * \file libgedaguile_priv.h
+ * Scheme API private declarations and definitions.
+ * \warning Don't include from libgeda_priv.h: should only be included
+ * by Scheme API source files.
+ */
+
+#include <libgeda/libgedaguile.h>
diff --git a/libgeda/scheme/Makefile.am b/libgeda/scheme/Makefile.am
index 1a3819e..a0ea6ad 100644
--- a/libgeda/scheme/Makefile.am
+++ b/libgeda/scheme/Makefile.am
@@ -1,6 +1,6 @@
scmdatadir = $(GEDADATADIR)/scheme
-dist_scmdata_DATA = geda.scm color-map.scm
+nobase_dist_scmdata_DATA = geda.scm color-map.scm
MOSTLYCLEANFILES = *.log *~
CLEANFILES = *.log *~
diff --git a/libgeda/src/.gitignore b/libgeda/src/.gitignore
index 65b98d9..f97d51d 100644
--- a/libgeda/src/.gitignore
+++ b/libgeda/src/.gitignore
@@ -5,4 +5,5 @@ Makefile
Makefile.in
libgeda.la
*.o
+*.x
*~
diff --git a/libgeda/src/Makefile.am b/libgeda/src/Makefile.am
index ae62fe8..77e47ce 100644
--- a/libgeda/src/Makefile.am
+++ b/libgeda/src/Makefile.am
@@ -2,7 +2,13 @@
# Build a libtool library for installation in libdir.
lib_LTLIBRARIES = libgeda.la
+BUILT_SOURCES =
+
+scheme_api_sources = \
+ scheme_init.c
+
libgeda_la_SOURCES = \
+ $(scheme_api_sources) \
a_basic.c \
f_basic.c \
f_print.c \
@@ -69,6 +75,14 @@ libgeda_la_LDFLAGS = -version-info $(LIBGEDA_SHLIB_VERSION) \
$(GLIB_LIBS) $(GDK_PIXBUF_LIBS)
LIBTOOL=@LIBTOOL@ --silent
+# This is used to generate boilerplate for defining Scheme functions
+# in C.
+SUFFIXES = .x
+snarf_cpp_opts = $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
+ $(libgeda_la_CPPFLAGS) $(AM_CFLAGS) $(libgeda_la_CFLAGS)
+.c.x:
+ $(GUILE_SNARF) -o $@ $< $(snarf_cpp_opts)
+
MOSTLYCLEANFILES = *.log core FILE *~
CLEANFILES = *.log core FILE *~
DISTCLEANFILES = *.log core FILE *~
diff --git a/libgeda/src/libgeda.c b/libgeda/src/libgeda.c
index ea11b92..fc43fb7 100644
--- a/libgeda/src/libgeda.c
+++ b/libgeda/src/libgeda.c
@@ -32,6 +32,7 @@
#endif
#include "libgeda_priv.h"
+#include "libgeda/libgedaguile.h"
#ifdef HAVE_LIBDMALLOC
#include <dmalloc.h>
@@ -65,6 +66,8 @@ void libgeda_init(void)
g_init_object_smob();
g_init_attrib_smob();
g_init_page_smob();
+
+ edascm_init ();
}
diff --git a/libgeda/src/scheme_init.c b/libgeda/src/scheme_init.c
new file mode 100644
index 0000000..26618f6
--- /dev/null
+++ b/libgeda/src/scheme_init.c
@@ -0,0 +1,44 @@
+/* gEDA - GPL Electronic Design Automation
+ * libgeda - gEDA's library - Scheme API
+ * Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+ */
+
+/*!
+ * \file scheme_init.c
+ * Scheme API initialisation
+ */
+#include <config.h>
+
+#include "libgeda_priv.h"
+#include "libgedaguile_priv.h"
+
+/*! Non-zero if the Scheme API has been initialised. */
+static int init_called = 0;
+
+/*! \brief Initialise the Scheme API.
+ * \par Function Description
+ * Registers all modules, procedures and variables exported by the
+ * libgeda Scheme API.
+ */
+void
+edascm_init ()
+{
+ if (init_called) return;
+ init_called = 1;
+
+ /* Do nothing yet! */
+}
diff --git a/m4/geda-guile-snarf.m4 b/m4/geda-guile-snarf.m4
new file mode 100644
index 0000000..8c9e92b
--- /dev/null
+++ b/m4/geda-guile-snarf.m4
@@ -0,0 +1,33 @@
+# geda-guile-snarf.m4 -*-Autoconf-*-
+# serial 1
+
+dnl Check for the `guile-snarf' build tool
+dnl Copyright (C) 2010 Peter Brett <peter@xxxxxxxxxxxxx>
+dnl
+dnl This program is free software; you can redistribute it and/or modify
+dnl it under the terms of the GNU General Public License as published by
+dnl the Free Software Foundation; either version 2 of the License, or
+dnl (at your option) any later version.
+dnl
+dnl This program is distributed in the hope that it will be useful,
+dnl but WITHOUT ANY WARRANTY; without even the implied warranty of
+dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+dnl GNU General Public License for more details.
+dnl
+dnl You should have received a copy of the GNU General Public License
+dnl along with this program; if not, write to the Free Software
+dnl Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+AC_DEFUN([AX_PROG_GUILE_SNARF],
+[
+ AC_PREREQ([2.60])dnl
+
+ AC_ARG_VAR([GUILE_SNARF], [path to guile-snarf utility])
+
+ AC_CHECK_PROG([GUILE_SNARF], [guile-snarf], [guile-snarf], [no])
+ if test "x$GUILE_SNARF" = x ; then
+ AC_MSG_ERROR([The `guile-snarf' tool could not be found. Please ensure that the
+Guile development headers and tools are correctly installed, and rerun
+configure.])
+ fi
+])
_______________________________________________
geda-cvs mailing list
geda-cvs@xxxxxxxxxxxxxx
http://www.seul.org/cgi-bin/mailman/listinfo/geda-cvs