Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/smlnj-lib/Reactive/OLD/instr.sml
ViewVC logotype

Annotation of /sml/trunk/src/smlnj-lib/Reactive/OLD/instr.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 7 - (view) (download)

1 : monnier 7 (* instr.sml
2 :     *
3 :     * COPYRIGHT (c) 1997 AT&T Research Labs.
4 :     * COPYRIGHT (c) 1997 Bell Labs, Lucent Technologies
5 :     *
6 :     * The basic instruction and machine types for the reactive engine.
7 :     *)
8 :    
9 :     structure Instr :> sig
10 :    
11 :     datatype state
12 :     = TERM
13 :     | STOP
14 :     | SUSP
15 :    
16 :     type instant = int
17 :    
18 :     type instruction
19 :     type machine
20 :    
21 :     (* instruction methods *)
22 :     val isTerm : instruction -> bool
23 :     val terminate : instruction -> unit
24 :     val reset : instruction -> unit
25 :     val preempt : instruction -> unit
26 :     val activate : (instruction * machine) -> state
27 :    
28 :     (* "pre-methods" for instructions *)
29 :     type 'a instruction_suite = {
30 :     isTerm : 'a -> unit -> bool,
31 :     terminate : 'a -> unit -> unit,
32 :     reset : 'a -> unit -> unit,
33 :     preempt : 'a -> unit -> unit,
34 :     activation : 'a -> machine -> state
35 :     }
36 :    
37 :     val newInstruction : 'a instruction_suite -> 'a -> instruction
38 :    
39 :     (* machine methods *)
40 :     val now : machine -> instant
41 :     val newMove : machine -> unit
42 :     val isEndOfInstant : machine -> bool
43 :     val runOnce : machine -> bool
44 :     val run : machine -> unit
45 :     val say : (machine * string) -> unit
46 :     val newMachine : instruction -> machine
47 :    
48 :     (* signal methods *)
49 :     type signal_state = instant ref
50 :     datatype presence = PRESENT | ABSENT | UNKNOWN
51 :     val getSignal : (machine * Atom.atom) -> signal_state option
52 :     val putSignal : (machine * Atom.atom * signal_state option) -> unit
53 :     val present : (machine * Atom.atom) -> bool
54 :     val presence : (machine * Atom.atom) -> presence
55 :     val emit : (machine * Atom.atom) -> unit
56 :    
57 :     end = struct
58 :    
59 :     datatype state
60 :     = TERM
61 :     | STOP
62 :     | SUSP
63 :    
64 :     type instant = int
65 :     type signal_state = instant ref
66 :    
67 :     datatype instruction = I of {
68 :     isTerm : unit -> bool,
69 :     terminate : unit -> unit,
70 :     reset : unit -> unit,
71 :     preempt : unit -> unit,
72 :     activation : machine -> state
73 :     }
74 :    
75 :     and machine = M of {
76 :     now : instant ref,
77 :     moveFlg : bool ref,
78 :     endOfInstant : bool ref,
79 :     prog : instruction,
80 :     env : signal_state AtomTable.hash_table
81 :     }
82 :    
83 :     fun terminate (I{terminate=f, ...}) = f()
84 :     fun isTerm (I{isTerm=f, ...}) = f()
85 :     fun reset (I{reset=f, ...}) = f()
86 :     fun preempt (I{preempt=f, ...}) = f()
87 :     fun activation (I{activation=f, ...}, m) = f m
88 :    
89 :     (* "pre-methods" for instructions *)
90 :     type 'a instruction_suite = {
91 :     isTerm : 'a -> unit -> bool,
92 :     terminate : 'a -> unit -> unit,
93 :     reset : 'a -> unit -> unit,
94 :     preempt : 'a -> unit -> unit,
95 :     activation : 'a -> machine -> state
96 :     }
97 :    
98 :     fun newInstruction (suite : 'a instruction_suite) state = I{
99 :     isTerm = #isTerm suite state,
100 :     terminate = #terminate suite state,
101 :     reset = #reset suite state,
102 :     preempt = #preempt suite state,
103 :     activation = #activation suite state
104 :     }
105 :    
106 :     fun activate (i, m) = if (isTerm i)
107 :     then TERM
108 :     else (case activation(i, m)
109 :     of TERM => (terminate i; TERM)
110 :     | res => res
111 :     (* end case *))
112 :    
113 :     (* machine methods *)
114 :     fun now (M{now=t, ...}) = !t
115 :     fun newMove (M{moveFlg, ...}) = moveFlg := true
116 :     fun isEndOfInstant (M{endOfInstant, ...}) = !endOfInstant
117 :     fun runOnce (m as M{now, moveFlg, endOfInstant, prog, ...}) = let
118 :     fun untilStop () = (case activate(prog, m)
119 :     of SUSP => (
120 :     if !moveFlg
121 :     then moveFlg := false
122 :     else endOfInstant := true;
123 :     untilStop ())
124 :     | STOP => false
125 :     | TERM => true
126 :     (* end case *))
127 :     in
128 :     endOfInstant := false;
129 :     moveFlg := false;
130 :     untilStop () before now := !now+1
131 :     end
132 :     fun run m = let
133 :     fun lp () = if (runOnce m) then () else lp()
134 :     in
135 :     lp ()
136 :     end
137 :     fun resetMachine (M{now, moveFlg, endOfInstant, prog, env}) = (
138 :     (** what about variables? **)
139 :     now := 1;
140 :     moveFlg := false;
141 :     endOfInstant := false;
142 :     reset prog;
143 :     AtomTable.app (fn r => r := 0) env)
144 :     fun say (m, s) = TextIO.print s
145 :     fun newMachine prog = M{
146 :     now = ref 1,
147 :     moveFlg = ref false,
148 :     endOfInstant = ref false,
149 :     prog = prog,
150 :     env = AtomTable.mkTable (16, Fail "Machine env")
151 :     }
152 :    
153 :     fun getSignal (M{env, ...}, name) = AtomTable.find env name
154 :     fun putSignal (M{env, ...}, name, SOME s) = AtomTable.insert env (name, s)
155 :     | putSignal _ = ()
156 :     fun present (M{env, now, ...}, name) = (!now = !(AtomTable.lookup env name))
157 :     fun absent (M{env, now, ...}, name) = (!now = ~(!(AtomTable.lookup env name)))
158 :     fun emit (M{env, now, ...}, name) = (AtomTable.lookup env name) := !now
159 :    
160 :     datatype presence = PRESENT | ABSENT | UNKNOWN
161 :    
162 :     fun presence (M{env, now, endOfInstant, ...}, name) = let
163 :     val ts = !(AtomTable.lookup env name)
164 :     val now = !now
165 :     in
166 :     if (now = ts) then PRESENT
167 :     else if ((now = ~ts) orelse !endOfInstant) then ABSENT
168 :     else UNKNOWN
169 :     end
170 :    
171 :     end;

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0