SNAPSNAP environment-test-suite

Author: housel

documentation/source/hacker-guide/environment/environment-protocols.rst

@@ -1044,15 +1044,19 @@ Address Objects
 
    :signature: address-read-memory-contents (server addr #key size format from-index to-index) => (printable-strings nxt)
 
-   :parameter server: An instance of :class:`<server>`.
-   :parameter addr: An instance of :class:`<address-object>`.
-   :parameter #key size: An instance of :const:`<data-display-size>`.
+   :parameter server: An instance of :class:`<server>`. The backend dispatching object.
+   :parameter addr: An instance of :class:`<address-object>`. The address at which to base the import.
+   :parameter #key size: An instance of :const:`<data-display-size>`. The granularity at which to read data; defaults to ``#"word"`` (the runtime platform word-size).
    :parameter #key format: An instance of :const:`<data-display-format>`.
    :parameter #key from-index: An instance of :class:`<integer>`.
    :parameter #key to-index: An instance of :class:`<integer>`.
    :value printable-strings: An instance of :class:`<sequence>`.
    :value nxt: An instance of :class:`<address-object>`.
 
+   Import a block of memory contents starting at the supplied address,
+   and return the contents as formatted strings. Also returns the
+   address that immediately follows the block that has been read.
+
 .. method:: address-read-memory-contents
    :specializer: <project-object>, <address-object>
 
@@ -1143,6 +1147,9 @@ Component Objects
 
 .. class:: <component-object>
 
+   Represents a runtime "component", i.e. a DLL/EXE file or a shared
+   object file.
+
    :superclasses: :class:`<application-object>`
 
 
@@ -1231,6 +1238,8 @@ Composite Objects
 .. generic-function:: composite-object-contents
    :open:
 
+   Returns the slot names and values of a composite instance.
+
    :signature: composite-object-contents (server object #key inherited?) => (names values)
 
    :parameter server: An instance of :class:`<server>`.
@@ -1239,6 +1248,9 @@ Composite Objects
    :value names: An instance of :class:`<sequence>`.
    :value values: An instance of :class:`<sequence>`.
 
+   All of the values are wrapped up in :class:`<environment-object>`
+   instances, whereas the slot names are just returned as strings.
+
 .. method:: composite-object-contents
    :specializer: <project-object>, <composite-object>
 
@@ -4086,6 +4098,10 @@ Playground
    :parameter #key just-name?: An instance of :class:`<boolean>`.
    :value playground?: An instance of :class:`<boolean>`.
 
+   The ``just-name?`` keyword should be passed as ``#t`` when you want
+   to test for playground-project-nature, but the project may not have
+   been opened properly yet.
+
 .. function:: playground-application-filename
 
    :signature: playground-application-filename (project) => (filename)

sources/environment/dfmc/application/control-protocols.dylan

@@ -551,6 +551,8 @@ define method register-thread-in-state-model
     := application.application-thread-counter + 1;
   thread-state-model(application, thread)
     := thread-state;
+  debugger-message("Registered thread %d in state model",
+                   thread-state.thread-state-thread-index);
 end method register-thread-in-state-model;
 
 

sources/environment/tests/dfmc/debugging.dylan

@@ -8,6 +8,50 @@ Warranty:     Distributed WITHOUT WARRANTY OF ANY KIND
 
 define constant $debugging-test-application = "cmu-test-suite";
 
+define variable *test-application-application* :: false-or(<application>) = #f;
+
+define function dbg-machine () => (machine :: <machine>);
+  let orb = corba/orb-init(make(corba/<arg-list>), "Open Dylan ORB");
+  let network-address = environment-variable("OPEN_DYLAN_DEBUGGING_MACHINE");
+  if (network-address)
+    let password
+      = environment-variable("OPEN_DYLAN_DEBUGGING_PASSWORD")
+      | error ("Environment variable OPEN_DYLAN_DEBUGGING_PASSWORD is not set");
+    make(<machine>,
+         network-address: network-address,
+         password: password)
+  else
+    environment-host-machine()
+  end if
+end function;
+
+define constant $project-message-queue = make(<deque>);
+define constant $project-message-notification
+  = make(<notification>, lock: make(<lock>));
+
+define function debugging-project-message-callback (message :: <project-message>)
+  with-lock (associated-lock($project-message-notification))
+    push-last($project-message-queue, message);
+    release($project-message-notification);
+  end with-lock;
+end function;
+
+define function await-project-message () => (message :: <project-message>);
+  with-lock (associated-lock($project-message-notification))
+    while (empty?($project-message-queue))
+      wait-for($project-message-notification);
+    end while;
+    pop($project-message-queue)
+  end with-lock
+end function;
+
+define function initialize-application-client
+    (client :: <object>, application :: <application>) => ()
+  register-application-callbacks
+    (application,
+     initialized-callback:         note-application-initialized);
+end function;
+
 define function open-debugging-test-project () => ()
   let application
     = open-project(test-project-location($debugging-test-application));
@@ -21,9 +65,75 @@ define function open-debugging-test-project () => ()
     parse-project-source(application);
   end unless;
   *test-application* := application;
+
+  tune-in($project-channel, debugging-project-message-callback,
+          message-type: <project-message>);
+
+  // FIXME
+  let machine = dbg-machine();
+  *test-application-application*
+    := run-application(*test-application*,
+                       initialize-client: initialize-application-client,
+                       startup-option: #"debug",
+                       machine: machine);
+  iterate loop (initialized? = #f, stopped? = #t, transient-bp-count = 0)
+    format-out("I=%= S=%= BP=%d\n",
+               initialized?, stopped?,
+               transient-bp-count);
+    unless (initialized? & stopped? & zero?(transient-bp-count))
+      let message = await-project-message();
+      format-out("%s\n", message);
+      select (message by instance?)
+        <application-initialized-message> =>
+          format-out("  it is initialized\n");
+          loop(#t, stopped?, transient-bp-count);
+        <application-state-changed-message> =>
+          let state = *test-application-application*.application-state;
+          format-out("  state is now %s\n", state);
+          if (state == #"running")
+            loop(initialized?, #f, transient-bp-count);
+          else
+            loop(initialized?, #t, transient-bp-count);
+          end if;
+        <single-breakpoint-state-change-message> =>
+          let breakpoint = message.message-breakpoint;
+          let state = message.message-breakpoint-state;
+          format-out("  Breakpoint %s (%=) state is now %s\n",
+                     breakpoint,
+                     environment-object-id(*test-application*, breakpoint),
+                     state);
+          if (breakpoint.breakpoint-transient?)
+            select (state)
+              #"created" =>
+                loop(initialized?, stopped?, transient-bp-count + 1);
+              #"destroyed" =>
+                loop(initialized?, stopped?, transient-bp-count - 1);
+            end select;
+          else
+            loop(initialized?, stopped?, transient-bp-count);
+          end if;
+        <application-threads-changed-message> =>
+/*
+*/
+          loop(initialized?, stopped?, transient-bp-count);
+        otherwise =>
+          loop(initialized?, stopped?, transient-bp-count);
+      end select;
+    end unless;
+  end iterate;
+  format-out("It's started; I'm glad\n");
+  for (thread in *test-application-application*.application-threads)
+    format-out("  Thread %s (%s) state %s suspended %=\n",
+               thread,
+               environment-object-primitive-name(*test-application*, thread),
+               thread-state(*test-application*, thread),
+               thread.thread-suspended?);
+  end for;
 end function;
 
 define function close-debugging-test-project () => ()
+  stop-application(*test-application-application*);
+  tune-out($project-channel, debugging-project-message-callback);
   close-project(*test-application*);
 end function;
 

sources/environment/tests/dfmc/library.dylan

@@ -15,14 +15,18 @@ define library dfmc-environment-test-suite
   use source-records;
 
   use testworks;
+  use channels;
+  use dylan-orb;
 
   use environment-protocols;
-  use environment-commands;
-  use environment-application-commands;
+  use dfmc-environment;
+  use dfmc-environment-projects;
+  use dfmc-environment-application;
   use environment-test-suite;
 
   // Back-ends
   use dfmc-back-end-implementations;
+  use remote-access-path;
 
   export dfmc-environment-test-suite;
 end library dfmc-environment-test-suite;

sources/environment/tests/dfmc/module.dylan

@@ -13,17 +13,22 @@ define module dfmc-environment-test-suite
   use standard-io;
   use progress-stream;
   use locators;
+  use file-system;
+  use threads;
 
   use source-records;
   use operating-system,
     exclude: { run-application };
 
   use testworks;
 
+  use channels;
+  use dylan-orb;
+
   use environment-protocols,
     exclude: { application-filename,
                application-arguments };
-  use environment-commands;
+  use dfmc-application;
   use environment-test-suite;
 
   export dfmc-environment-suite;

sources/environment/tests/dfmc/projects.dylan

@@ -91,7 +91,7 @@ define function open-test-projects () => ()
   open-project-compiler-database
     (application, error-handler: project-condition-handler);
 
-  test-project-build(application);
+  test-project-build(application, link?: #t);
 
   unless (open-project-compiler-database
             (library, error-handler: project-condition-handler))
@@ -127,6 +127,9 @@ define test open-projects-test ()
   check-equal("Application project interface type",
               project-interface-type(*test-application*),
               #"gui");
+  check-equal("Application project name",
+              project-name(*test-application*),
+              $test-application);
   check-equal("Application project name",
               environment-object-primitive-name
                 (*test-application*, *test-application*),
@@ -141,6 +144,9 @@ define test open-projects-test ()
   check-equal("Library interface target type",
               project-interface-type(*test-library*),
               #"console");
+  check-equal("Library project name",
+              project-name(*test-library*),
+              $test-library);
   check-equal("Library project name",
               environment-object-primitive-name
                 (*test-library*, *test-library*),
@@ -149,9 +155,29 @@ define test open-projects-test ()
              project-compiled?(*test-library*));
 end test open-projects-test;
 
+define test project-files-test ()
+  check-equal("Library project filename",
+              test-project-location($test-library),
+              project-filename(*test-library*));
+  check-equal("Application project filename",
+              test-project-location($test-application),
+              project-filename(*test-application*));
+
+  check-true("Library project directory exists",
+             file-exists?(project-directory(*test-library*)));
+  for (s in project-sources(*test-library*))
+    check-true("Source file exists",
+               file-exists?(source-record-location(s)));
+  end for;
+  check-true("Library full build file exists",
+             file-exists?(project-full-build-filename(*test-library*)));
+  check-true("Application full build file exists",
+             file-exists?(project-full-build-filename(*test-application*)));
+end test;
 
 /// projects suite
 
 define suite projects-suite ()
   test open-projects-test;
+  test project-files-test;
 end suite projects-suite;

sources/environment/tests/library.dylan

@@ -11,7 +11,7 @@ define library environment-test-suite
   use release-info;
   //---*** andrewa: this needs a DUIM backend to work
   // use environment-framework;
-  use duim-core;
+  //use duim-core;
 
   use testworks;
 

sources/environment/tests/module.dylan

@@ -11,7 +11,7 @@ define module environment-test-suite
   use environment-protocols;
   //---*** andrewa: this needs a DUIM backend to work
   // use environment-framework;
-  use duim;
+  // use duim;
 
   use testworks;