[Gd-chatter] r11671 - in trunk/libraries: layer layer/layer-test registry/generic
andreas at gwydiondylan.org
andreas at gwydiondylan.org
Sat Feb 9 03:41:32 CET 2008
Author: andreas
Date: Sat Feb 9 03:41:31 2008
New Revision: 11671
Added:
trunk/libraries/layer/layer-test/
trunk/libraries/layer/layer-test/layer-test.dylan (contents, props changed)
trunk/libraries/layer/layer-test/layer-test.hdp (contents, props changed)
trunk/libraries/layer/layer-test/library.dylan (contents, props changed)
trunk/libraries/layer/layer-test/module.dylan (contents, props changed)
trunk/libraries/layer/new-layer.dylan (contents, props changed)
trunk/libraries/registry/generic/layer-test (contents, props changed)
Modified:
trunk/libraries/layer/layer.hdp
trunk/libraries/layer/library.dylan
trunk/libraries/layer/module.dylan
Log:
Job: 7299
* new layer API and definer macros
supporting properties and change-events
* test cases for new layer API
Added: trunk/libraries/layer/layer-test/layer-test.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/layer/layer-test/layer-test.dylan Sat Feb 9 03:41:31 2008
@@ -0,0 +1,57 @@
+Module: layer-test
+Copyright: (c) 2008 Dylan Hackers
+
+
+define layer simple-layer
+ property a :: <integer> = 23;
+end;
+
+define test simple-layer-basic ()
+ let a = make(<simple-layer>);
+ check-instance?("a is instance of simple-layer", <simple-layer>, a);
+ check-equal("layer name is simple-layer0", #"simple-layer0", a.layer-name);
+ check-equal("property a is 23", 23, a. at a);
+ let p = get-property(a, #"a");
+ check-instance?("p is a property", <property>, p);
+ check-equal("property name is correct", #"a", p.property-name);
+ check-equal("property type is correct", <integer>, p.property-type);
+ check-equal("property value is correct", 23, p.property-value);
+ check-equal("property default value is correct", 23, p.property-default-value);
+ check-equal("property owner is correct", a, p.property-owner);
+
+ set-property-value(a, #"a", 42);
+ check-equal("property value is correct after set-property", 42, p.property-value);
+end;
+
+define test simple-layer-with-default ()
+ let a = make(<simple-layer>, a: 42);
+ check-equal("property value is 42", 42, a. at a);
+ check-equal("default-value is 42", 42, get-property(a, #"a").property-default-value);
+end;
+
+define test simple-layer-callback ()
+ let callback-called? = #f;
+ let a = make(<simple-layer>);
+ register-event(get-property(a, #"a"), method(c) callback-called? := #t end);
+ a. at a := 42;
+ check-true("callback called", callback-called?);
+end;
+
+define test simple-layer-null-callback ()
+ let callback-called? = #f;
+ let a = make(<simple-layer>);
+ register-event(get-property(a, #"a"), method(c) callback-called? := #t end);
+ a. at a := 23;
+ check-false("callback not called", callback-called?);
+end;
+
+define suite layer-suite ()
+ test simple-layer-basic;
+ test simple-layer-with-default;
+ test simple-layer-callback;
+ test simple-layer-null-callback;
+end;
+
+begin
+ run-test-application(layer-suite);
+end;
Added: trunk/libraries/layer/layer-test/layer-test.hdp
==============================================================================
--- (empty file)
+++ trunk/libraries/layer/layer-test/layer-test.hdp Sat Feb 9 03:41:31 2008
@@ -0,0 +1,12 @@
+Format-Version: 2
+Library: layer-test
+Copyright: (c) 2008 Dylan Hackers
+Major-Version: 1
+Minor-Version: 0
+Files: library
+ module
+ layer-test
+Start-Function: main
+Compilation-Mode: loose
+Target-Type: executable
+
Added: trunk/libraries/layer/layer-test/library.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/layer/layer-test/library.dylan Sat Feb 9 03:41:31 2008
@@ -0,0 +1,13 @@
+Module: dylan-user
+Copyright: (c) 2008 Dylan Hackers
+
+define library layer-test
+ use dylan;
+ use io;
+ use common-dylan;
+ use testworks;
+ use layer;
+
+ // Add any more module exports here.
+ export layer-test;
+end library layer-test;
Added: trunk/libraries/layer/layer-test/module.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/layer/layer-test/module.dylan Sat Feb 9 03:41:31 2008
@@ -0,0 +1,15 @@
+Module: dylan-user
+Copyright: (c) 2008 Dylan Hackers
+
+define module layer-test
+ use dylan;
+ use format;
+ use format-out;
+ use standard-io;
+ use streams;
+ use new-layer;
+ use testworks;
+
+ // Add binding exports here.
+
+end module layer-test;
Modified: trunk/libraries/layer/layer.hdp
==============================================================================
--- trunk/libraries/layer/layer.hdp (original)
+++ trunk/libraries/layer/layer.hdp Sat Feb 9 03:41:31 2008
@@ -1,6 +1,7 @@
Library: layer
Files: library
module
+ new-layer
layer
tcp
udp
Modified: trunk/libraries/layer/library.dylan
==============================================================================
--- trunk/libraries/layer/library.dylan (original)
+++ trunk/libraries/layer/library.dylan Sat Feb 9 03:41:31 2008
@@ -20,4 +20,5 @@
// Add any more module exports here.
export layer;
+ export new-layer;
end library layer;
Modified: trunk/libraries/layer/module.dylan
==============================================================================
--- trunk/libraries/layer/module.dylan (original)
+++ trunk/libraries/layer/module.dylan Sat Feb 9 03:41:31 2008
@@ -68,3 +68,28 @@
export <pppoe-client>;
end module layer;
+
+define module new-layer
+ use common-dylan;
+
+ export <layer>, layer-name,
+ <event>, <event-source>,
+ event-notify, register-event, deregister-event;
+
+ export <property>, property-name,
+ property-type, property-default-value,
+ property-value, property-value-setter,
+ property-owner;
+
+ export get-property,
+ set-property-value, get-property-value,
+ check-property;
+
+ export <property-changed-event>,
+ property-changed-event-property,
+ property-changed-event-old-value;
+
+ export \layer-definer,
+ \add-properties-to-table,
+ \layer-getter-and-setter-definer;
+end;
Added: trunk/libraries/layer/new-layer.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/layer/new-layer.dylan Sat Feb 9 03:41:31 2008
@@ -0,0 +1,162 @@
+module: new-layer
+
+define open abstract class <layer> (<object>)
+ slot layer-name :: <symbol>;
+ each-subclass slot instance-count :: <integer> = 0;
+ slot properties :: <table> = make(<table>);
+end;
+
+define constant $layer-registry = make(<table>);
+
+
+define macro layer-getter-and-setter-definer
+ { layer-getter-and-setter-definer(?:name) }
+ => { }
+ { layer-getter-and-setter-definer(?:name; property ?pname:name :: ?type:expression = ?default:expression; ?rest:*) }
+ => {
+ define method "@" ## ?pname (lay :: ?name) => (res :: ?type)
+ get-property-value(lay, ?#"pname");
+ end;
+ define method "@" ## ?pname ## "-setter" (new-val :: ?type, lay :: ?name) => (res :: ?type)
+ set-property-value(lay, ?#"pname", new-val)
+ end;
+ layer-getter-and-setter-definer(?name; ?rest) }
+end;
+
+define macro add-properties-to-table
+ { add-properties-to-table(?layer:name; ?properties:*) }
+ => { begin
+ let owner = ?layer;
+ ?properties;
+ end }
+
+ properties:
+ { } => { }
+ { property ?:name :: ?type:expression = ?default:expression; ... } =>
+ { owner.properties[?#"name"] := make(<property>,
+ name: ?#"name",
+ type: ?type,
+ default: ?default,
+ owner: owner,
+ value: ?default);
+ //getter: ?name,
+ //setter: ?name ## "-setter");
+ ... }
+
+end;
+define macro layer-definer
+ { define layer ?:name
+ ?properties:*
+ end }
+ =>
+ { layer-getter-and-setter-definer("<" ## ?name ## ">"; ?properties);
+ define class "<" ## ?name ## ">" (<layer>) end;
+
+ define method initialize (layer :: "<" ## ?name ## ">",
+ #next next-method, #rest rest, #key name, #all-keys);
+ next-method();
+ init-layer(layer, ?"name", name);
+ add-properties-to-table(layer; ?properties);
+ init-properties(layer, rest);
+ end; }
+end;
+
+define function init-layer (layer :: <layer>, default-name :: <string>, name)
+ unless(name)
+ name := as(<symbol>, format-to-string("%s%=", default-name, layer.instance-count));
+ layer.instance-count := layer.instance-count + 1;
+ end;
+ if (element($layer-registry, name, default: #f))
+ error("Can't create layer: name duplication");
+ end;
+ layer.layer-name := name;
+ $layer-registry[name] := layer;
+end;
+
+define function init-properties (layer :: <layer>, args :: <collection>)
+ for (i from 0 below args.size by 2)
+ if (get-property(layer, args[i]))
+ let prop = get-property(layer, args[i]);
+ prop.property-default-value := args[i + 1];
+ prop.%property-value := args[i + 1];
+ end;
+ end;
+end;
+define class <event> (<object>)
+end;
+
+define class <event-source> (<object>)
+ slot listeners = #();
+end;
+
+define method event-notify (source :: <event-source>, event :: <event>)
+ do(method (x) x(event) end, source.listeners)
+end;
+
+define method register-event (source :: <event-source>, callback :: <function>)
+ source.listeners := add!(source.listeners, callback);
+end;
+
+define method deregister-event (source :: <event-source>, callback :: <function>)
+ source.listeners := remove!(source.listeners, callback);
+end;
+
+define class <property> (<event-source>)
+ constant slot property-name :: <symbol>, init-keyword: name:;
+ constant slot property-type :: <type>, init-keyword: type:;
+ slot property-default-value, init-keyword: default:;
+ slot %property-value, init-keyword: value:;
+ constant slot property-owner, init-keyword: owner:;
+ //constant slot property-getter, init-keyword: getter:;
+ //constant slot property-setter, init-keyword: setter:;
+end;
+
+define function get-property (object :: <layer>, property-name :: <symbol>)
+ => (res :: <property>)
+ element(object.properties, property-name);
+end;
+
+define function set-property-value (object :: <layer>, property-name :: <symbol>, new-value)
+ => (res)
+ get-property(object, property-name).property-value := new-value;
+end;
+
+define function get-property-value (object :: <layer>, property-name :: <symbol>)
+ => (res)
+ get-property(object, property-name).property-value;
+end;
+
+define inline method property-value (property :: <property>)
+ %property-value(property)
+end;
+
+define open generic check-property (owner, property-name :: <symbol>, value) => ();
+define method check-property (owner, property-name :: <symbol>, value) => ()
+ //move along
+end;
+define inline method property-value-setter (value, property :: <property>)
+ let old-value = property.property-value;
+ check-property(property.property-owner, property.property-name, value);
+ if (old-value ~= value)
+ property.%property-value := value;
+ let event = make(<property-changed-event>, property: property, old-value: old-value);
+ event-notify(property, event);
+ end;
+ value
+end;
+
+
+define class <property-changed-event> (<event>)
+ constant slot property-changed-event-property :: <property>, required-init-keyword: property:;
+ constant slot property-changed-event-old-value, required-init-keyword: old-value:;
+end;
+
+
+define layer test-ethernet-layer
+ property mac-address :: <mac-address> = mac-address("00:de:ad:be:ef:00");
+ property mtu :: <integer> = 1500;
+end;
+
+
+make(<test-ethernet-layer>, mtu: 1248);
+
Added: trunk/libraries/registry/generic/layer-test
==============================================================================
--- (empty file)
+++ trunk/libraries/registry/generic/layer-test Sat Feb 9 03:41:31 2008
@@ -0,0 +1 @@
+abstract://dylan/layer-test/layer-test.hdp
More information about the chatter
mailing list