[m-rev.] diff: cleanup extras/concurrency
Julien Fischer
juliensf at cs.mu.OZ.AU
Thu Apr 20 17:29:09 AEST 2006
Estimated hours taken: 2
Branches: main, release
Cleanups and minor bug fixes for extras/concurrency.
extras/concurrency/Mmakefile:
Don't warn about concurrency.m not exporting anything.
extras/concurrency/README:
s/semaphone/semaphore/
extras/concurrency/concurrency.m:
Add an interface declaration.
extras/concurrency/global.m:
Avoid a warning from gcc about deprecated cast expressions in lvalues.
extras/concurrency/mutvar.m:
Delete this module. It has been obsolete since before 2001 and it now
conflicts with the standard library module named mutvar. The
functionality that was available in this module is in mvar.m.
extras/concurrency/*.m:
Convert these modules to four-space indentation.
Use state variables for threading the I/O state.
Use the new foreign language interface throughout.
Format foreign_procs as per our coding standard.
Fix some overlong lines.
Numerous other minor formatting and style cleanups.
Conform to recent changes in the standard library.
Julien.
Index: Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/concurrency/Mmakefile,v
retrieving revision 1.6
diff -u -b -r1.6 Mmakefile
--- Mmakefile 16 Jan 2003 10:44:13 -0000 1.6
+++ Mmakefile 20 Apr 2006 05:18:58 -0000
@@ -19,6 +19,8 @@
realclean: concurrency.realclean $(TESTS:%=%.realclean)
tests: $(TESTS)
+MCFLAGS-concurrency+=--no-warn-nothing-exported --no-warn-interface-imports
+
.PHONY: check
check: all
true
Index: README
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/concurrency/README,v
retrieving revision 1.3
diff -u -b -r1.3 README
--- README 22 Nov 2001 10:52:22 -0000 1.3
+++ README 20 Apr 2006 04:58:42 -0000
@@ -2,7 +2,7 @@
See the example programs:
philo, philo2, philo3
- several variants on the dining philosophers example.
- philo uses a single semaphone for synchronization,
+ philo uses a single semaphore for synchronization,
philo2 uses a single mvar,
while philo3 uses one semaphore per fork.
midimon - a midi data monitor that concurrently reads the bytestream,
Index: channel.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/concurrency/channel.m,v
retrieving revision 1.2
diff -u -b -r1.2 channel.m
--- channel.m 29 May 2001 08:51:57 -0000 1.2
+++ channel.m 20 Apr 2006 03:49:16 -0000
@@ -1,101 +1,109 @@
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
% Copyright (C) 2000-2001 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
%
-% Main author: petdr
+% File: channel.m.
+% Main author: petdr.
% Stability: low.
%
-% A mvar can only contain a single value, a channel on the otherhand
-% provides unbounded buffering.
+% A mvar can only contain a single value, a channel on the other hand provides
+% unbounded buffering.
%
-% For example a program could consist of 2 worker threads and one
-% logging thread. The worker threads can place messages into the
-% channel, and they will be buffered for processing by the logging
-% thread.
+% For example a program could consist of 2 worker threads and one logging
+% thread. The worker threads can place messages into the channel, and they
+% will be buffered for processing by the logging thread.
%
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- module channel.
-
:- interface.
:- import_module io.
+%-----------------------------------------------------------------------------%
+
:- type channel(T).
% Initialise a channel.
-:- pred channel__init(channel(T)::out, io__state::di, io__state::uo) is det.
+ %
+:- pred channel.init(channel(T)::out, io::di, io::uo) is det.
% Put an item at the end of the channel.
-:- pred channel__put(channel(T)::in, T::in,
- io__state::di, io__state::uo) is det.
+ %
+:- pred channel.put(channel(T)::in, T::in, io::di, io::uo) is det.
% Take an item from the start of the channel, block if there is
% nothing in the channel.
-:- pred channel__take(channel(T)::in, T::out,
- io__state::di, io__state::uo) is det.
+ %
+:- pred channel.take(channel(T)::in, T::out, io::di, io::uo) is det.
% Duplicate a channel. The new channel sees all (and only) the
- % data written to the channel after the channel__duplicate call.
-:- pred channel__duplicate(channel(T)::in, channel(T)::out,
- io__state::di, io__state::uo) is det.
+ % data written to the channel after the channel.duplicate call.
+ %
+:- pred channel.duplicate(channel(T)::in, channel(T)::out, io::di, io::uo)
+ is det.
% Place an item back at the start of the channel.
-:- pred channel__untake(channel(T)::in, T::in,
- io__state::di, io__state::uo) is det.
+ %
+:- pred channel.untake(channel(T)::in, T::in, io::di, io::uo) is det.
-%---------------------------------------------------------------------------%
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- implementation.
:- import_module mvar.
+%-----------------------------------------------------------------------------%
+
:- type channel(T)
---> channel(
- mvar(stream(T)), % read end
- mvar(stream(T)) % write end
+ mvar(stream(T)), % Read end.
+ mvar(stream(T)) % Write end.
).
:- type stream(T) == mvar(item(T)).
:- type item(T)
---> item(
- T, % the current item
- stream(T) % the rest of the stream
+ T, % The current item.
+ stream(T) % The rest of the stream.
).
-channel__init(channel(Read, Write)) -->
- mvar__init(Read),
- mvar__init(Write),
- mvar__init(Hole),
- mvar__put(Read, Hole),
- mvar__put(Write, Hole).
-
-channel__put(channel(_Read, Write), Val) -->
- mvar__init(NewHole),
- mvar__take(Write, OldHole),
- mvar__put(Write, NewHole),
- mvar__put(OldHole, item(Val, NewHole)).
-
-channel__take(channel(Read, _Write), Val) -->
- mvar__take(Read, Head),
- mvar__take(Head, item(Val, NewHead)),
- mvar__put(Read, NewHead).
-
-channel__duplicate(channel(_Read, Write), channel(NewRead, Write)) -->
- mvar__init(NewRead),
- mvar__take(Write, Hole),
- mvar__put(Write, Hole),
- mvar__put(NewRead, Hole).
-
-channel__untake(channel(Read, _Write), Val) -->
- mvar__init(NewHead),
- mvar__take(Read, Head),
- mvar__put(NewHead, item(Val, Head)),
- mvar__put(Read, NewHead).
+channel.init(channel(Read, Write), !IO) :-
+ mvar.init(Read, !IO),
+ mvar.init(Write, !IO),
+ mvar.init(Hole, !IO),
+ mvar.put(Read, Hole, !IO),
+ mvar.put(Write, Hole, !IO).
+
+channel.put(channel(_Read, Write), Val, !IO) :-
+ mvar.init(NewHole, !IO),
+ mvar.take(Write, OldHole, !IO),
+ mvar.put(Write, NewHole, !IO),
+ mvar.put(OldHole, item(Val, NewHole), !IO).
+
+channel.take(channel(Read, _Write), Val, !IO) :-
+ mvar.take(Read, Head, !IO),
+ mvar.take(Head, item(Val, NewHead), !IO),
+ mvar.put(Read, NewHead, !IO).
+
+channel.duplicate(channel(_Read, Write), channel(NewRead, Write), !IO) :-
+ mvar.init(NewRead, !IO),
+ mvar.take(Write, Hole, !IO),
+ mvar.put(Write, Hole, !IO),
+ mvar.put(NewRead, Hole, !IO).
+
+channel.untake(channel(Read, _Write), Val, !IO) :-
+ mvar.init(NewHead, !IO),
+ mvar.take(Read, Head, !IO),
+ mvar.put(NewHead, item(Val, Head), !IO),
+ mvar.put(Read, NewHead, !IO).
-%---------------------------------------------------------------------------%
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: concurrency.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/concurrency/concurrency.m,v
retrieving revision 1.1
diff -u -b -r1.1 concurrency.m
--- concurrency.m 6 Mar 2002 10:10:29 -0000 1.1
+++ concurrency.m 20 Apr 2006 03:22:01 -0000
@@ -4,6 +4,14 @@
% Public License - see the file COPYING.LIB in the Mercury distribution.
%---------------------------------------------------------------------------%
-% The "concurrency" library package consists of the following modules.
:- module concurrency.
-:- import_module channel, global, mvar, semaphore, spawn, stream.
+:- interface.
+
+ % The "concurrency" library package consists of the following modules.
+ %
+:- import_module channel.
+:- import_module global.
+:- import_module mvar.
+:- import_module semaphore.
+:- import_module spawn.
+:- import_module stream.
Index: global.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/concurrency/global.m,v
retrieving revision 1.3
diff -u -b -r1.3 global.m
--- global.m 28 Feb 2003 15:20:33 -0000 1.3
+++ global.m 20 Apr 2006 06:35:08 -0000
@@ -1,49 +1,54 @@
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
% Copyright (C) 2000 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
%
-% Main author: conway
+% File: global.m.
+% Main author: conway.
% Stability: medium.
%
% This module provides a simple mechanism for storing values associated
-% with keys in the global io__state. It is quite like library/store.m,
-% except that it implicitly stores things in the io__state rather than in a
+% with keys in the global io.state. It is quite like library/store.m,
+% except that it implicitly stores things in the io.state rather than in a
% separate store.
%
-%---------------------------------------------------------------------------%
-:- module global.
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+:- module global.
:- interface.
:- import_module io.
+%-----------------------------------------------------------------------------%
+
:- type global(T).
-:- pragma foreign_type(c, global(T), "MR_Word").
-:- pragma foreign_type(il, global(T), "class [global__csharp_code]ME_Global").
- % new(Thing, Key, IO0, IO) binds `Key' to an abstract key refering
+ % new(Thing, Key, !IO) binds `Key' to an abstract key referring
% to the object `Thing'.
-:- pred global__new(T, global(T), io__state, io__state).
-:- mode global__new(in, out, di, uo) is det.
+ %
+:- pred global.new(T::in, global(T)::out, io::di, io::uo) is det.
- % get(Key, Thing, IO0, IO) binds `Thing' to the object currently
+ % get(Key, Thing, !IO) binds `Thing' to the object currently
% associated with `Key'.
-:- pred global__get(global(T), T, io__state, io__state).
-:- mode global__get(in, out, di, uo) is det.
+ %
+:- pred global.get(global(T)::in, T::out, io::di, io::uo) is det.
- % set(Key, Thing, IO0, IO) changes the value associated with `Key'
+ % set(Key, Thing, !IO) changes the value associated with `Key'
% to be `Thing'.
-:- pred global__set(global(T), T, io__state, io__state).
-:- mode global__set(in, in, di, uo) is det.
+ %
+:- pred global.set(global(T)::in, T::in, io::di, io::uo) is det.
-%---------------------------------------------------------------------------%
-:- implementation.
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
-:- import_module std_util.
+:- implementation.
-:- type global(T).
+:- pragma foreign_type(c, global(T), "MR_Word").
+:- pragma foreign_type(il, global(T), "class [global__csharp_code]ME_Global").
:- pragma foreign_decl("C#", "
public class ME_Global {
@@ -51,36 +56,56 @@
}
").
-:- pragma c_code(global__new(Thing::in, Glob::out, IO0::di, IO::uo),
- will_not_call_mercury, "{
- MR_Word *tmp;
- MR_incr_hp((MR_Word) tmp, 1);
- *tmp = Thing;
- Glob = (MR_Word) tmp;
+%-----------------------------------------------------------------------------%
+
+:- pragma foreign_proc("C",
+ new(Thing::in, Glob::out, IO0::di, IO::uo),
+ [promise_pure, will_not_call_mercury],
+"
+ MR_Word tmp;
+ MR_incr_hp(tmp, 1);
+ *((MR_Word *)tmp) = Thing;
+ Glob = tmp;
IO = IO0;
-}").
-:- pragma foreign_proc("C#", new(Thing::in, Glob::out, _IO0::di, _IO::uo),
- [will_not_call_mercury, thread_safe, promise_pure], "
+").
+
+:- pragma foreign_proc("C#",
+ new(Thing::in, Glob::out, _IO0::di, _IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
Glob = new ME_Global();
Glob.val = Thing;
").
-:- pragma c_code(global__get(Glob::in, Thing::out, IO0::di, IO::uo),
- will_not_call_mercury, "{
+:- pragma foreign_proc("C",
+ get(Glob::in, Thing::out, IO0::di, IO::uo),
+ [promise_pure, will_not_call_mercury],
+"
Thing = * (MR_Word *) Glob;
IO = IO0;
-}").
-:- pragma foreign_proc("C#", get(Glob::in, Thing::out, _IO0::di, _IO::uo),
- [will_not_call_mercury, thread_safe, promise_pure], "
+").
+
+:- pragma foreign_proc("C#",
+ get(Glob::in, Thing::out, _IO0::di, _IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
Thing = Glob.val;
").
-:- pragma c_code(global__set(Glob::in, Thing::in, IO0::di, IO::uo),
- will_not_call_mercury, "{
+:- pragma foreign_proc("C",
+ set(Glob::in, Thing::in, IO0::di, IO::uo),
+ [promise_pure, will_not_call_mercury],
+"
* ((MR_Word *) Glob) = Thing;
IO = IO0;
-}").
-:- pragma foreign_proc("C#", set(Glob::in, Thing::in, _IO0::di, _IO::uo),
- [will_not_call_mercury, thread_safe, promise_pure], "
+").
+
+:- pragma foreign_proc("C#",
+ set(Glob::in, Thing::in, _IO0::di, _IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
Glob.val = Thing;
").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: midi.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/concurrency/midi.m,v
retrieving revision 1.1
diff -u -b -r1.1 midi.m
--- midi.m 29 Feb 2000 22:37:13 -0000 1.1
+++ midi.m 20 Apr 2006 07:20:33 -0000
@@ -1,26 +1,34 @@
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
% Copyright (C) 2000 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
%
-% Main author: conway
+% File: midi.m.
+% Main author: conway.
%
% This module provides routines for concurrently reading and writing MIDI
% streams. MIDI stands for "Musical Instrument Digital Interface" and is a
% hardware and software protocol for electronic instruments to talk to each
% other.
%
-%------------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- module midi.
-
:- interface.
:- import_module stream.
-:- import_module io, list.
+
+:- import_module io.
+:- import_module list.
+
+%-----------------------------------------------------------------------------%
% For information about the meaning
+ %
:- type message
---> off(channel, note, velocity) % note off
; on(channel, note, velocity) % note on
@@ -31,8 +39,7 @@
; pw(channel, pitch_value) % pitch wheel change
; mm(channel, modes) % mode message
; sys(system) % system message
- ; rt(realtime) % realtime message
- .
+ ; rt(realtime). % realtime message
:- type channel == int. % 0 - 15.
:- type note == int. % 0 - 127
@@ -48,20 +55,17 @@
; ano
; omni(onoff)
; mono(byte)
- ; poly
- .
+ ; poly.
:- type onoff
---> off
- ; on
- .
+ ; on.
:- type system
---> sysex(list(byte))
; pos(int)
; sel(byte)
- ; tune
- .
+ ; tune.
:- type realtime
---> clk
@@ -69,61 +73,76 @@
; cont
; stop
; sense
- ; reset
- .
+ ; reset.
:- type byte == int.
% Reads from a concurrent stream of bytes and puts its outputs
% on to a concurrent stream of midi messages.
-:- pred read_midi(stream(byte), stream(message), io__state, io__state).
-:- mode read_midi(in, in, di, uo) is det.
+ %
+:- pred read_midi(stream(byte)::in, stream(message)::in, io::di, io::uo)
+ is det.
% Reads from a concurrent stream of messages, and puts the messages
% on to a concurrent stream of bytes.
-:- pred write_midi(stream(message), stream(byte), io__state, io__state).
-:- mode write_midi(in, in, di, uo) is det.
+ %
+:- pred write_midi(stream(message)::in, stream(byte)::in, io::di, io::uo)
+ is det.
-%------------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module bool, int, require.
+:- import_module bool.
+:- import_module int.
+:- import_module require.
+
+%-----------------------------------------------------------------------------%
:- type hex
- ---> x0 ; x1 ; x2 ; x3
- ; x4 ; x5 ; x6 ; x7
- ; x8 ; x9 ; xA ; xB
- ; xC ; xD ; xE ; xF
- .
+ ---> x0
+ ; x1
+ ; x2
+ ; x3
+ ; x4
+ ; x5
+ ; x6
+ ; x7
+ ; x8
+ ; x9
+ ; xA
+ ; xB
+ ; xC
+ ; xD
+ ; xE
+ ; xF.
% This type is used for storing the "running status" used by
% most MIDI devices, where if the status-byte of two consecutive
% messages (ignoring any intervening realtime messages) is the
% same, then it may be omitted in the second message.
+ %
:- type status
---> none
; status(kind, channel).
:- type kind
---> one(onebyte)
- ; two(twobyte)
- .
+ ; two(twobyte).
:- type onebyte
---> pc
- ; cp
- .
+ ; cp.
:- type twobyte
---> off
; on
; kp
; cc
- ; pw
- .
+ ; pw.
-%------------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
% The midi protocol has two classes of message. The majority of
% messages including note and controller events fall in the first
@@ -136,371 +155,360 @@
% parsing when it receives a realtime event.
%
% For more info on the MIDI protocol, see a site like
- % ftp://ftp.ucsd.edu/midi/doc/midi-intro.Z
+ % <ftp://ftp.ucsd.edu/midi/doc/midi-intro.Z>
-read_midi(Ins, Outs) -->
- byte0(none, Ins, Outs).
+read_midi(Ins, Outs, !IO) :-
+ byte0(none, Ins, Outs, !IO).
-:- pred byte0(status, stream(byte), stream(message),
- io__state, io__state).
-:- mode byte0(in, in, in, di, uo) is det.
+:- pred byte0(status::in, stream(byte)::in, stream(message)::in,
+ io::di, io::uo) is det.
-byte0(Status, Ins, Outs) -->
- get(Ins, Res0),
+byte0(Status, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
(
- { Res0 = end },
- end(Outs)
+ Res0 = end,
+ end(Outs, !IO)
;
- { Res0 = error(Err) },
- error(Outs, Err)
+ Res0 = error(Err),
+ error(Outs, Err, !IO)
;
- { Res0 = ok(Byte) },
- { byte2hex(Byte, MSN, LSN) },
- byte0a(MSN, LSN, Status, Ins, Outs)
+ Res0 = ok(Byte),
+ byte2hex(Byte, MSN, LSN),
+ byte0a(MSN, LSN, Status, Ins, Outs, !IO)
).
-:- pred byte0a(hex, hex, status, stream(byte), stream(message),
- io__state, io__state).
-:- mode byte0a(in, in, in, in, in, di, uo) is det.
-
-byte0a(x0, LSN, Status, Ins, Outs) -->
- { hex2byte(x0, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte0a(x1, LSN, Status, Ins, Outs) -->
- { hex2byte(x1, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte0a(x2, LSN, Status, Ins, Outs) -->
- { hex2byte(x2, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte0a(x3, LSN, Status, Ins, Outs) -->
- { hex2byte(x3, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte0a(x4, LSN, Status, Ins, Outs) -->
- { hex2byte(x4, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte0a(x5, LSN, Status, Ins, Outs) -->
- { hex2byte(x5, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte0a(x6, LSN, Status, Ins, Outs) -->
- { hex2byte(x6, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte0a(x7, LSN, Status, Ins, Outs) -->
- { hex2byte(x7, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte0a(x8, LSN, _Status, Ins, Outs) -->
- { nibble2hex(Chan, LSN) },
- { Status = status(two(off), Chan) },
- byte1(Status, Ins, Outs).
-byte0a(x9, LSN, _Status, Ins, Outs) -->
- { nibble2hex(Chan, LSN) },
- { Status = status(two(on), Chan) },
- byte1(Status, Ins, Outs).
-byte0a(xA, LSN, _Status, Ins, Outs) -->
- { nibble2hex(Chan, LSN) },
- { Status = status(two(kp), Chan) },
- byte1(Status, Ins, Outs).
-byte0a(xB, LSN, _Status, Ins, Outs) -->
- { nibble2hex(Chan, LSN) },
- { Status = status(two(cc), Chan) },
- byte1(Status, Ins, Outs).
-byte0a(xC, LSN, _Status, Ins, Outs) -->
- { nibble2hex(Chan, LSN) },
- { Status = status(one(pc), Chan) },
- byte1(Status, Ins, Outs).
-byte0a(xD, LSN, _Status, Ins, Outs) -->
- { nibble2hex(Chan, LSN) },
- { Status = status(one(cp), Chan) },
- byte1(Status, Ins, Outs).
-byte0a(xE, LSN, _Status, Ins, Outs) -->
- { nibble2hex(Chan, LSN) },
- { Status = status(two(pw), Chan) },
- byte1(Status, Ins, Outs).
-byte0a(xF, x0, Status, Ins, Outs) -->
- sysex0(Status, Ins, Outs).
-byte0a(xF, x1, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte0a(xF, x2, Status, Ins, Outs) -->
- pos0(Status, Ins, Outs).
-byte0a(xF, x3, Status, Ins, Outs) -->
- sel0(Status, Ins, Outs).
-byte0a(xF, x4, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte0a(xF, x5, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte0a(xF, x6, Status, Ins, Outs) -->
- put(Outs, sys(tune)),
- byte0(Status, Ins, Outs).
-byte0a(xF, x7, _Status, _Ins, Outs) -->
- error(Outs, "unexpected system byte (byte0)").
-byte0a(xF, x8, Status, Ins, Outs) -->
- put(Outs, rt(clk)),
- byte0(Status, Ins, Outs).
-byte0a(xF, x9, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte0a(xF, xA, Status, Ins, Outs) -->
- put(Outs, rt(start)),
- byte0(Status, Ins, Outs).
-byte0a(xF, xB, Status, Ins, Outs) -->
- put(Outs, rt(cont)),
- byte0(Status, Ins, Outs).
-byte0a(xF, xC, Status, Ins, Outs) -->
- put(Outs, rt(stop)),
- byte0(Status, Ins, Outs).
-byte0a(xF, xD, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte0a(xF, xE, Status, Ins, Outs) -->
- put(Outs, rt(sense)),
- byte0(Status, Ins, Outs).
-byte0a(xF, xF, Status, Ins, Outs) -->
- put(Outs, rt(reset)),
- byte0(Status, Ins, Outs).
-
-:- pred byte1(status, stream(byte), stream(message),
- io__state, io__state).
-:- mode byte1(in, in, in, di, uo) is det.
-
-byte1(Status, Ins, Outs) -->
- get(Ins, Res0),
- (
- { Res0 = end },
- error(Outs, "unexpected end of input")
- ;
- { Res0 = error(Err) },
- error(Outs, Err)
- ;
- { Res0 = ok(Byte) },
- { byte2hex(Byte, MSN, LSN) },
- byte1a(MSN, LSN, Status, Ins, Outs)
+:- pred byte0a(hex::in, hex::in, status::in, stream(byte)::in,
+ stream(message)::in, io::di, io::uo) is det.
+
+byte0a(x0, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x0, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x1, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x1, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x2, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x2, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x3, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x3, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x4, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x4, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x5, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x5, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x6, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x6, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x7, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x7, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte0a(x8, LSN, _Status, Ins, Outs, !IO) :-
+ nibble2hex(Chan, LSN),
+ Status = status(two(off), Chan),
+ byte1(Status, Ins, Outs, !IO).
+byte0a(x9, LSN, _Status, Ins, Outs, !IO) :-
+ nibble2hex(Chan, LSN),
+ Status = status(two(on), Chan),
+ byte1(Status, Ins, Outs, !IO).
+byte0a(xA, LSN, _Status, Ins, Outs, !IO) :-
+ nibble2hex(Chan, LSN),
+ Status = status(two(kp), Chan),
+ byte1(Status, Ins, Outs, !IO).
+byte0a(xB, LSN, _Status, Ins, Outs, !IO) :-
+ nibble2hex(Chan, LSN),
+ Status = status(two(cc), Chan),
+ byte1(Status, Ins, Outs, !IO).
+byte0a(xC, LSN, _Status, Ins, Outs, !IO) :-
+ nibble2hex(Chan, LSN),
+ Status = status(one(pc), Chan),
+ byte1(Status, Ins, Outs, !IO).
+byte0a(xD, LSN, _Status, Ins, Outs, !IO) :-
+ nibble2hex(Chan, LSN),
+ Status = status(one(cp), Chan),
+ byte1(Status, Ins, Outs, !IO).
+byte0a(xE, LSN, _Status, Ins, Outs, !IO) :-
+ nibble2hex(Chan, LSN),
+ Status = status(two(pw), Chan),
+ byte1(Status, Ins, Outs, !IO).
+byte0a(xF, x0, Status, Ins, Outs, !IO) :-
+ sysex0(Status, Ins, Outs, !IO).
+byte0a(xF, x1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte0a(xF, x2, Status, Ins, Outs, !IO) :-
+ pos0(Status, Ins, Outs, !IO).
+byte0a(xF, x3, Status, Ins, Outs, !IO) :-
+ sel0(Status, Ins, Outs, !IO).
+byte0a(xF, x4, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte0a(xF, x5, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte0a(xF, x6, Status, Ins, Outs, !IO) :-
+ put(Outs, sys(tune), !IO),
+ byte0(Status, Ins, Outs, !IO).
+byte0a(xF, x7, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte (byte0)", !IO).
+byte0a(xF, x8, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(clk), !IO),
+ byte0(Status, Ins, Outs, !IO).
+byte0a(xF, x9, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte0a(xF, xA, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(start), !IO),
+ byte0(Status, Ins, Outs, !IO).
+byte0a(xF, xB, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(cont), !IO),
+ byte0(Status, Ins, Outs, !IO).
+byte0a(xF, xC, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(stop), !IO),
+ byte0(Status, Ins, Outs, !IO).
+byte0a(xF, xD, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte0a(xF, xE, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(sense), !IO),
+ byte0(Status, Ins, Outs, !IO).
+byte0a(xF, xF, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(reset), !IO),
+ byte0(Status, Ins, Outs, !IO).
+
+:- pred byte1(status::in, stream(byte)::in, stream(message)::in,
+ io::di, io::uo) is det.
+
+byte1(Status, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
+ (
+ Res0 = end,
+ error(Outs, "unexpected end of input", !IO)
+ ;
+ Res0 = error(Err),
+ error(Outs, Err, !IO)
+ ;
+ Res0 = ok(Byte),
+ byte2hex(Byte, MSN, LSN),
+ byte1a(MSN, LSN, Status, Ins, Outs, !IO)
).
-:- pred byte1a(hex, hex, status, stream(byte), stream(message),
- io__state, io__state).
-:- mode byte1a(in, in, in, in, in, di, uo) is det.
-
-byte1a(x0, LSN, Status, Ins, Outs) -->
- { hex2byte(x0, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte1a(x1, LSN, Status, Ins, Outs) -->
- { hex2byte(x1, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte1a(x2, LSN, Status, Ins, Outs) -->
- { hex2byte(x2, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte1a(x3, LSN, Status, Ins, Outs) -->
- { hex2byte(x3, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte1a(x4, LSN, Status, Ins, Outs) -->
- { hex2byte(x4, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte1a(x5, LSN, Status, Ins, Outs) -->
- { hex2byte(x5, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte1a(x6, LSN, Status, Ins, Outs) -->
- { hex2byte(x6, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte1a(x7, LSN, Status, Ins, Outs) -->
- { hex2byte(x7, LSN, Byte) },
- byte1b(Status, Byte, Ins, Outs).
-byte1a(x8, _LSN, _Status, _Ins, Outs) -->
- error(Outs, "unexpected status byte").
-byte1a(x9, _LSN, _Status, _Ins, Outs) -->
- error(Outs, "unexpected status byte").
-byte1a(xA, _LSN, _Status, _Ins, Outs) -->
- error(Outs, "unexpected status byte").
-byte1a(xB, _LSN, _Status, _Ins, Outs) -->
- error(Outs, "unexpected status byte").
-byte1a(xC, _LSN, _Status, _Ins, Outs) -->
- error(Outs, "unexpected status byte").
-byte1a(xD, _LSN, _Status, _Ins, Outs) -->
- error(Outs, "unexpected status byte").
-byte1a(xE, _LSN, _Status, _Ins, Outs) -->
- error(Outs, "unexpected status byte").
-byte1a(xF, x0, _Status, _Ins, Outs) -->
- error(Outs, "unexpected system byte").
-byte1a(xF, x1, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte1a(xF, x2, _Status, _Ins, Outs) -->
- error(Outs, "unexpected system byte").
-byte1a(xF, x3, _Status, _Ins, Outs) -->
- error(Outs, "unexpected system byte").
-byte1a(xF, x4, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte1a(xF, x5, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte1a(xF, x6, Status, Ins, Outs) -->
- put(Outs, sys(tune)),
- byte1(Status, Ins, Outs).
-byte1a(xF, x7, _Status, _Ins, Outs) -->
- error(Outs, "unexpected system byte").
-byte1a(xF, x8, Status, Ins, Outs) -->
- put(Outs, rt(clk)),
- byte1(Status, Ins, Outs).
-byte1a(xF, x9, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte1a(xF, xA, Status, Ins, Outs) -->
- put(Outs, rt(start)),
- byte1(Status, Ins, Outs).
-byte1a(xF, xB, Status, Ins, Outs) -->
- put(Outs, rt(cont)),
- byte1(Status, Ins, Outs).
-byte1a(xF, xC, Status, Ins, Outs) -->
- put(Outs, rt(stop)),
- byte1(Status, Ins, Outs).
-byte1a(xF, xD, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte1a(xF, xE, Status, Ins, Outs) -->
- put(Outs, rt(sense)),
- byte1(Status, Ins, Outs).
-byte1a(xF, xF, Status, Ins, Outs) -->
- put(Outs, rt(reset)),
- byte1(Status, Ins, Outs).
-
-:- pred byte1b(status, byte, stream(byte), stream(message),
- io__state, io__state).
-:- mode byte1b(in, in, in, in, di, uo) is det.
-
-byte1b(none, _Byte, Ins, Outs) -->
- byte0(none, Ins, Outs).
-byte1b(status(one(Kind), Chan), Byte, Ins, Outs) -->
+:- pred byte1a(hex::in, hex::in, status::in, stream(byte)::in,
+ stream(message)::in, io::di, io::uo) is det.
+
+byte1a(x0, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x0, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x1, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x1, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x2, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x2, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x3, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x3, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x4, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x4, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x5, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x5, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x6, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x6, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x7, LSN, Status, Ins, Outs, !IO) :-
+ hex2byte(x7, LSN, Byte),
+ byte1b(Status, Byte, Ins, Outs, !IO).
+byte1a(x8, _LSN, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte1a(x9, _LSN, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte1a(xA, _LSN, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte1a(xB, _LSN, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte1a(xC, _LSN, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte1a(xD, _LSN, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte1a(xE, _LSN, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte1a(xF, x0, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte1a(xF, x1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte1a(xF, x2, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte1a(xF, x3, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte1a(xF, x4, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte1a(xF, x5, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte1a(xF, x6, Status, Ins, Outs, !IO) :-
+ put(Outs, sys(tune), !IO),
+ byte1(Status, Ins, Outs, !IO).
+byte1a(xF, x7, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte1a(xF, x8, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(clk), !IO),
+ byte1(Status, Ins, Outs, !IO).
+byte1a(xF, x9, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte1a(xF, xA, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(start), !IO),
+ byte1(Status, Ins, Outs, !IO).
+byte1a(xF, xB, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(cont), !IO),
+ byte1(Status, Ins, Outs, !IO).
+byte1a(xF, xC, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(stop), !IO),
+ byte1(Status, Ins, Outs, !IO).
+byte1a(xF, xD, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte1a(xF, xE, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(sense), !IO),
+ byte1(Status, Ins, Outs, !IO).
+byte1a(xF, xF, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(reset), !IO),
+ byte1(Status, Ins, Outs, !IO).
+
+:- pred byte1b(status::in, byte::in, stream(byte)::in, stream(message)::in,
+ io::di, io::uo) is det.
+
+byte1b(none, _Byte, Ins, Outs, !IO) :-
+ byte0(none, Ins, Outs, !IO).
+byte1b(status(one(Kind), Chan), Byte, Ins, Outs, !IO) :-
(
- { Kind = pc },
- { Msg = pc(Chan, Byte) }
+ Kind = pc,
+ Msg = pc(Chan, Byte)
;
- { Kind = cp },
- { Msg = cp(Chan, Byte) }
+ Kind = cp,
+ Msg = cp(Chan, Byte)
),
- put(Outs, Msg),
- byte0(status(one(Kind), Chan), Ins, Outs).
-byte1b(status(two(Kind), Chan), Byte1, Ins, Outs) -->
- byte2(status(two(Kind), Chan), Byte1, Ins, Outs).
-
-:- pred byte2(status, byte, stream(byte), stream(message),
- io__state, io__state).
-:- mode byte2(in, in, in, in, di, uo) is det.
-
-byte2(Status, Byte1, Ins, Outs) -->
- get(Ins, Res0),
- (
- { Res0 = end },
- error(Outs, "unexpected end of input")
- ;
- { Res0 = error(Err) },
- error(Outs, Err)
- ;
- { Res0 = ok(Byte2) },
- { byte2hex(Byte2, MSN2, LSN2) },
- byte2a(MSN2, LSN2, Byte1, Status, Ins, Outs)
+ put(Outs, Msg, !IO),
+ byte0(status(one(Kind), Chan), Ins, Outs, !IO).
+byte1b(status(two(Kind), Chan), Byte1, Ins, Outs, !IO) :-
+ byte2(status(two(Kind), Chan), Byte1, Ins, Outs, !IO).
+
+:- pred byte2(status::in, byte::in, stream(byte)::in, stream(message)::in,
+ io::di, io::uo) is det.
+
+byte2(Status, Byte1, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
+ (
+ Res0 = end,
+ error(Outs, "unexpected end of input", !IO)
+ ;
+ Res0 = error(Err),
+ error(Outs, Err, !IO)
+ ;
+ Res0 = ok(Byte2),
+ byte2hex(Byte2, MSN2, LSN2),
+ byte2a(MSN2, LSN2, Byte1, Status, Ins, Outs, !IO)
).
-:- pred byte2a(hex, hex, byte, status, stream(byte), stream(message),
- io__state, io__state).
-:- mode byte2a(in, in, in, in, in, in, di, uo) is det.
-
-byte2a(x0, LSN, Byte1, Status, Ins, Outs) -->
- { hex2byte(x0, LSN, Byte2) },
- byte2b(Status, Byte1, Byte2, Ins, Outs).
-byte2a(x1, LSN, Byte1, Status, Ins, Outs) -->
- { hex2byte(x1, LSN, Byte2) },
- byte2b(Status, Byte1, Byte2, Ins, Outs).
-byte2a(x2, LSN, Byte1, Status, Ins, Outs) -->
- { hex2byte(x2, LSN, Byte2) },
- byte2b(Status, Byte1, Byte2, Ins, Outs).
-byte2a(x3, LSN, Byte1, Status, Ins, Outs) -->
- { hex2byte(x3, LSN, Byte2) },
- byte2b(Status, Byte1, Byte2, Ins, Outs).
-byte2a(x4, LSN, Byte1, Status, Ins, Outs) -->
- { hex2byte(x4, LSN, Byte2) },
- byte2b(Status, Byte1, Byte2, Ins, Outs).
-byte2a(x5, LSN, Byte1, Status, Ins, Outs) -->
- { hex2byte(x5, LSN, Byte2) },
- byte2b(Status, Byte1, Byte2, Ins, Outs).
-byte2a(x6, LSN, Byte1, Status, Ins, Outs) -->
- { hex2byte(x6, LSN, Byte2) },
- byte2b(Status, Byte1, Byte2, Ins, Outs).
-byte2a(x7, LSN, Byte1, Status, Ins, Outs) -->
- { hex2byte(x7, LSN, Byte2) },
- byte2b(Status, Byte1, Byte2, Ins, Outs).
-byte2a(x8, _LSN, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "unexpected status byte").
-byte2a(x9, _LSN, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "unexpected status byte").
-byte2a(xA, _LSN, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "unexpected status byte").
-byte2a(xB, _LSN, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "unexpected status byte").
-byte2a(xC, _LSN, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "unexpected status byte").
-byte2a(xD, _LSN, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "unexpected status byte").
-byte2a(xE, _LSN, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "unexpected status byte").
-byte2a(xF, x0, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "unexpected system byte").
-byte2a(xF, x1, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte2a(xF, x2, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "unexpected system byte").
-byte2a(xF, x3, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "unexpected system byte").
-byte2a(xF, x4, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte2a(xF, x5, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte2a(xF, x6, Byte1, Status, Ins, Outs) -->
- put(Outs, sys(tune)),
- byte2(Status, Byte1, Ins, Outs).
-byte2a(xF, x7, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "unexpected system byte").
-byte2a(xF, x8, Byte1, Status, Ins, Outs) -->
- put(Outs, rt(clk)),
- byte2(Status, Byte1, Ins, Outs).
-byte2a(xF, x9, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte2a(xF, xA, Byte1, Status, Ins, Outs) -->
- put(Outs, rt(start)),
- byte2(Status, Byte1, Ins, Outs).
-byte2a(xF, xB, Byte1, Status, Ins, Outs) -->
- put(Outs, rt(cont)),
- byte2(Status, Byte1, Ins, Outs).
-byte2a(xF, xC, Byte1, Status, Ins, Outs) -->
- put(Outs, rt(stop)),
- byte2(Status, Byte1, Ins, Outs).
-byte2a(xF, xD, _Byte1, _Status, _Ins, Outs) -->
- error(Outs, "undefined system byte").
-byte2a(xF, xE, Byte1, Status, Ins, Outs) -->
- put(Outs, rt(sense)),
- byte2(Status, Byte1, Ins, Outs).
-byte2a(xF, xF, Byte1, Status, Ins, Outs) -->
- put(Outs, rt(reset)),
- byte2(Status, Byte1, Ins, Outs).
-
-:- pred byte2b(status, byte, byte, stream(byte), stream(message),
- io__state, io__state).
-:- mode byte2b(in, in, in, in, in, di, uo) is det.
-
-byte2b(none, _Byte1, _Byte2, Ins, Outs) -->
- byte0(none, Ins, Outs).
-byte2b(status(one(_), _Chan), _Byte1, _Byte2, _Ins, Outs) -->
- error(Outs, "internal error").
-byte2b(status(two(Kind), Chan), Byte1, Byte2, Ins, Outs) -->
- (
- { Kind = off },
- { Msg = off(Chan, Byte1, Byte2) }
+:- pred byte2a(hex::in, hex::in, byte::in, status::in, stream(byte)::in,
+ stream(message)::in, io::di, io::uo) is det.
+
+byte2a(x0, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x0, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x1, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x1, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x2, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x2, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x3, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x3, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x4, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x4, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x5, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x5, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x6, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x6, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x7, LSN, Byte1, Status, Ins, Outs, !IO) :-
+ hex2byte(x7, LSN, Byte2),
+ byte2b(Status, Byte1, Byte2, Ins, Outs, !IO).
+byte2a(x8, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte2a(x9, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte2a(xA, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte2a(xB, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte2a(xC, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte2a(xD, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte2a(xE, _LSN, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected status byte", !IO).
+byte2a(xF, x0, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte2a(xF, x1, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte2a(xF, x2, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte2a(xF, x3, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte2a(xF, x4, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte2a(xF, x5, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte2a(xF, x6, Byte1, Status, Ins, Outs, !IO) :-
+ put(Outs, sys(tune), !IO),
+ byte2(Status, Byte1, Ins, Outs, !IO).
+byte2a(xF, x7, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "unexpected system byte", !IO).
+byte2a(xF, x8, Byte1, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(clk), !IO),
+ byte2(Status, Byte1, Ins, Outs, !IO).
+byte2a(xF, x9, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte2a(xF, xA, Byte1, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(start), !IO),
+ byte2(Status, Byte1, Ins, Outs, !IO).
+byte2a(xF, xB, Byte1, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(cont), !IO),
+ byte2(Status, Byte1, Ins, Outs, !IO).
+byte2a(xF, xC, Byte1, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(stop), !IO),
+ byte2(Status, Byte1, Ins, Outs, !IO).
+byte2a(xF, xD, _Byte1, _Status, _Ins, Outs, !IO) :-
+ error(Outs, "undefined system byte", !IO).
+byte2a(xF, xE, Byte1, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(sense), !IO),
+ byte2(Status, Byte1, Ins, Outs, !IO).
+byte2a(xF, xF, Byte1, Status, Ins, Outs, !IO) :-
+ put(Outs, rt(reset), !IO),
+ byte2(Status, Byte1, Ins, Outs, !IO).
+
+:- pred byte2b(status::in, byte::in, byte::in, stream(byte)::in,
+ stream(message)::in, io::di, io::uo) is det.
+
+byte2b(none, _Byte1, _Byte2, Ins, Outs, !IO) :-
+ byte0(none, Ins, Outs, !IO).
+byte2b(status(one(_), _Chan), _Byte1, _Byte2, _Ins, Outs, !IO) :-
+ error(Outs, "internal error", !IO).
+byte2b(status(two(Kind), Chan), Byte1, Byte2, Ins, Outs, !IO) :-
+ (
+ Kind = off,
+ Msg = off(Chan, Byte1, Byte2)
;
- { Kind = on },
- { Msg = on(Chan, Byte1, Byte2) }
+ Kind = on,
+ Msg = on(Chan, Byte1, Byte2)
;
- { Kind = kp },
- { Msg = kp(Chan, Byte1, Byte2) }
+ Kind = kp,
+ Msg = kp(Chan, Byte1, Byte2)
;
- { Kind = cc },
- ( {
+ Kind = cc,
+ (
+ (
Byte1 = 122,
- ( Byte2 = 0 ->
- OnOrOff = off
- ;
- OnOrOff = on
- ),
+ OnOrOff = ( Byte2 = 0 -> off ; on ),
Msg0 = mm(Chan, local(OnOrOff))
;
Byte1 = 123,
@@ -517,280 +525,276 @@
;
Byte1 = 127,
Msg0 = mm(Chan, poly)
- } ->
- { Msg = Msg0 }
+ )
+ ->
+ Msg = Msg0
;
- { Msg = cc(Chan, Byte1, Byte2) }
+ Msg = cc(Chan, Byte1, Byte2)
)
;
- { Kind = pw },
- { Val = (Byte1 /\ 0x7F) \/ ((Byte2 /\ 0x7F) << 7) },
- { Msg = pw(Chan, Val) }
+ Kind = pw,
+ Val = (Byte1 /\ 0x7F) \/ ((Byte2 /\ 0x7F) << 7),
+ Msg = pw(Chan, Val)
),
- put(Outs, Msg),
- byte0(status(two(Kind), Chan), Ins, Outs).
+ put(Outs, Msg, !IO),
+ byte0(status(two(Kind), Chan), Ins, Outs, !IO).
-:- pred sysex0(status, stream(byte), stream(message), io__state, io__state).
-:- mode sysex0(in, in, in, di, uo) is det.
+:- pred sysex0(status::in, stream(byte)::in, stream(message)::in,
+ io::di, io::uo) is det.
-sysex0(Status, Ins, Outs) -->
- sysex1([], Status, Ins, Outs).
+sysex0(Status, Ins, Outs, !IO) :-
+ sysex1([], Status, Ins, Outs, !IO).
-:- pred sysex1(list(byte), status, stream(byte), stream(message),
- io__state, io__state).
-:- mode sysex1(in, in, in, in, di, uo) is det.
+:- pred sysex1(list(byte)::in, status::in, stream(byte)::in,
+ stream(message)::in, io::di, io::uo) is det.
-sysex1(Bytes0, Status, Ins, Outs) -->
- get(Ins, Res0),
+sysex1(Bytes0, Status, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
(
- { Res0 = end },
- error(Outs, "unexpected end of input")
+ Res0 = end,
+ error(Outs, "unexpected end of input", !IO)
;
- { Res0 = error(Err) },
- error(Outs, Err)
+ Res0 = error(Err),
+ error(Outs, Err, !IO)
;
- { Res0 = ok(Byte) },
- ( { Byte >= 0, Byte =< 127 } ->
- sysex1([Byte|Bytes0], Status, Ins, Outs)
+ Res0 = ok(Byte),
+ ( Byte >= 0, Byte =< 127 ->
+ sysex1([Byte|Bytes0], Status, Ins, Outs, !IO)
;
- { reverse(Bytes0, Bytes) },
- put(Outs, sys(sysex(Bytes))),
- ( { Byte = 0xF7 } ->
- byte0(Status, Ins, Outs)
+ list.reverse(Bytes0, Bytes),
+ put(Outs, sys(sysex(Bytes)), !IO),
+ ( Byte = 0xF7 ->
+ byte0(Status, Ins, Outs, !IO)
;
- { byte2hex(Byte, MSN, LSN) },
- byte0a(MSN, LSN, Status, Ins, Outs)
+ byte2hex(Byte, MSN, LSN),
+ byte0a(MSN, LSN, Status, Ins, Outs, !IO)
)
)
).
-:- pred pos0(status, stream(byte), stream(message), io__state, io__state).
-:- mode pos0(in, in, in, di, uo) is det.
+:- pred pos0(status::in, stream(byte)::in, stream(message)::in,
+ io::di, io::uo) is det.
-pos0(Status, Ins, Outs) -->
- get(Ins, Res0),
+pos0(Status, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
(
- { Res0 = end },
- error(Outs, "unexpected end of input")
+ Res0 = end,
+ error(Outs, "unexpected end of input", !IO)
;
- { Res0 = error(Err) },
- error(Outs, Err)
+ Res0 = error(Err),
+ error(Outs, Err, !IO)
;
- { Res0 = ok(Byte) },
- pos1(Byte, Status, Ins, Outs)
+ Res0 = ok(Byte),
+ pos1(Byte, Status, Ins, Outs, !IO)
).
-:- pred pos1(byte, status, stream(byte), stream(message), io__state, io__state).
-:- mode pos1(in, in, in, in, di, uo) is det.
+:- pred pos1(byte::in, status::in, stream(byte)::in, stream(message)::in,
+ io::di, io::uo) is det.
-pos1(Byte1, Status, Ins, Outs) -->
- get(Ins, Res0),
+pos1(Byte1, Status, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
(
- { Res0 = end },
- error(Outs, "unexpected end of input")
+ Res0 = end,
+ error(Outs, "unexpected end of input", !IO)
;
- { Res0 = error(Err) },
- error(Outs, Err)
- ;
- { Res0 = ok(Byte2) },
- { Val = (Byte1 /\ 0x7F) \/ ((Byte2 /\ 0x7F) << 7) },
- put(Outs, sys(pos(Val))),
- byte0(Status, Ins, Outs)
+ Res0 = error(Err),
+ error(Outs, Err, !IO)
+ ;
+ Res0 = ok(Byte2),
+ Val = (Byte1 /\ 0x7F) \/ ((Byte2 /\ 0x7F) << 7),
+ put(Outs, sys(pos(Val)), !IO),
+ byte0(Status, Ins, Outs, !IO)
).
-:- pred sel0(status, stream(byte), stream(message), io__state, io__state).
-:- mode sel0(in, in, in, di, uo) is det.
+:- pred sel0(status::in, stream(byte)::in, stream(message)::in,
+ io::di, io::uo) is det.
-sel0(Status, Ins, Outs) -->
- get(Ins, Res0),
+sel0(Status, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
(
- { Res0 = end },
- error(Outs, "unexpected end of input")
+ Res0 = end,
+ error(Outs, "unexpected end of input", !IO)
;
- { Res0 = error(Err) },
- error(Outs, Err)
+ Res0 = error(Err),
+ error(Outs, Err, !IO)
;
- { Res0 = ok(Byte) },
- put(Outs, sys(sel(Byte))),
- byte0(Status, Ins, Outs)
+ Res0 = ok(Byte),
+ put(Outs, sys(sel(Byte)), !IO),
+ byte0(Status, Ins, Outs, !IO)
).
-%------------------------------------------------------------------------------%
-%------------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
-write_midi(Ins, Outs) -->
- write_midi(none, Ins, Outs).
+write_midi(Ins, Outs, !IO) :-
+ write_midi(none, Ins, Outs, !IO).
-:- pred write_midi(status, stream(message), stream(byte), io__state, io__state).
-:- mode write_midi(in, in, in, di, uo) is det.
+:- pred write_midi(status::in, stream(message)::in, stream(byte)::in,
+ io::di, io::uo) is det.
-write_midi(Status, Ins, Outs) -->
- get(Ins, Res0),
+write_midi(Status, Ins, Outs, !IO) :-
+ get(Ins, Res0, !IO),
(
- { Res0 = end },
- end(Outs)
+ Res0 = end,
+ end(Outs, !IO)
;
- { Res0 = error(Msg) },
- error(Outs, Msg)
+ Res0 = error(Msg),
+ error(Outs, Msg, !IO)
;
- { Res0 = ok(Msg) },
- write_midi(Msg, Status, Ins, Outs)
+ Res0 = ok(Msg),
+ write_midi(Msg, Status, Ins, Outs, !IO)
).
-:- pred write_midi(message, status, stream(message), stream(byte),
- io__state, io__state).
-:- mode write_midi(in, in, in, in, di, uo) is det.
-
-write_midi(off(Chan, Note, Vel), Status0, Ins, Outs) -->
- { Status1 = status(two(off), Chan) },
- write_two(Status0, Status1, Note, Vel, Ins, Outs).
-write_midi(on(Chan, Note, Vel), Status0, Ins, Outs) -->
- { Status1 = status(two(on), Chan) },
- write_two(Status0, Status1, Note, Vel, Ins, Outs).
-write_midi(kp(Chan, Note, Press), Status0, Ins, Outs) -->
- { Status1 = status(two(kp), Chan) },
- write_two(Status0, Status1, Note, Press, Ins, Outs).
-write_midi(cc(Chan, Ctrl, Val), Status0, Ins, Outs) -->
- { Status1 = status(two(cc), Chan) },
- write_two(Status0, Status1, Ctrl, Val, Ins, Outs).
-write_midi(pc(Chan, Prog), Status0, Ins, Outs) -->
- { Status1 = status(one(pc), Chan) },
- write_one(Status0, Status1, Prog, Ins, Outs).
-write_midi(cp(Chan, Press), Status0, Ins, Outs) -->
- { Status1 = status(one(cp), Chan) },
- write_one(Status0, Status1, Press, Ins, Outs).
-write_midi(pw(Chan, Val), Status0, Ins, Outs) -->
- { Status1 = status(two(pw), Chan) },
- { Byte1 = Val /\ 0x7F },
- { Byte2 = (Val >> 7) /\ 0x7F },
- write_two(Status0, Status1, Byte1, Byte2, Ins, Outs).
-write_midi(mm(Chan, Mode), Status0, Ins, Outs) -->
- { Status1 = status(two(cc), Chan) },
- (
- { Mode = local(off) },
- { Byte1 = 122, Byte2 = 0 }
- ;
- { Mode = local(on) },
- { Byte1 = 122, Byte2 = 127 }
- ;
- { Mode = ano },
- { Byte1 = 123, Byte2 = 0 }
- ;
- { Mode = omni(off) },
- { Byte1 = 124, Byte2 = 0 }
+:- pred write_midi(message::in, status::in, stream(message)::in,
+ stream(byte)::in, io::di, io::uo) is det.
+
+write_midi(off(Chan, Note, Vel), Status0, Ins, Outs, !IO) :-
+ Status1 = status(two(off), Chan),
+ write_two(Status0, Status1, Note, Vel, Ins, Outs, !IO).
+write_midi(on(Chan, Note, Vel), Status0, Ins, Outs, !IO) :-
+ Status1 = status(two(on), Chan),
+ write_two(Status0, Status1, Note, Vel, Ins, Outs, !IO).
+write_midi(kp(Chan, Note, Press), Status0, Ins, Outs, !IO) :-
+ Status1 = status(two(kp), Chan),
+ write_two(Status0, Status1, Note, Press, Ins, Outs, !IO).
+write_midi(cc(Chan, Ctrl, Val), Status0, Ins, Outs, !IO) :-
+ Status1 = status(two(cc), Chan),
+ write_two(Status0, Status1, Ctrl, Val, Ins, Outs, !IO).
+write_midi(pc(Chan, Prog), Status0, Ins, Outs, !IO) :-
+ Status1 = status(one(pc), Chan),
+ write_one(Status0, Status1, Prog, Ins, Outs, !IO).
+write_midi(cp(Chan, Press), Status0, Ins, Outs, !IO) :-
+ Status1 = status(one(cp), Chan),
+ write_one(Status0, Status1, Press, Ins, Outs, !IO).
+write_midi(pw(Chan, Val), Status0, Ins, Outs, !IO) :-
+ Status1 = status(two(pw), Chan),
+ Byte1 = Val /\ 0x7F,
+ Byte2 = (Val >> 7) /\ 0x7F,
+ write_two(Status0, Status1, Byte1, Byte2, Ins, Outs, !IO).
+write_midi(mm(Chan, Mode), Status0, Ins, Outs, !IO) :-
+ Status1 = status(two(cc), Chan),
+ (
+ Mode = local(off),
+ Byte1 = 122, Byte2 = 0
+ ;
+ Mode = local(on),
+ Byte1 = 122, Byte2 = 127
+ ;
+ Mode = ano,
+ Byte1 = 123, Byte2 = 0
+ ;
+ Mode = omni(off),
+ Byte1 = 124, Byte2 = 0
;
- { Mode = omni(on) },
- { Byte1 = 125, Byte2 = 0 }
+ Mode = omni(on),
+ Byte1 = 125, Byte2 = 0
;
- { Mode = mono(N) },
- { Byte1 = 126, Byte2 = N /\ 0x7F }
+ Mode = mono(N),
+ Byte1 = 126, Byte2 = N /\ 0x7F
;
- { Mode = poly },
- { Byte1 = 127, Byte2 = 0 }
+ Mode = poly,
+ Byte1 = 127, Byte2 = 0
),
- write_two(Status0, Status1, Byte1, Byte2, Ins, Outs).
-write_midi(sys(sysex(Bytes)), Status, Ins, Outs) -->
- put(Outs, 0xF0),
- foldl((pred(Byte::in, di, uo) is det -->
- ( { Byte >= 0, Byte =< 127 } ->
- put(Outs, Byte)
+ write_two(Status0, Status1, Byte1, Byte2, Ins, Outs, !IO).
+write_midi(sys(sysex(Bytes)), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xF0, !IO),
+ PutByte = (pred(Byte::in, !.IO::di, !:IO::uo) is det :-
+ ( Byte >= 0, Byte =< 127 ->
+ put(Outs, Byte, !IO)
;
- error(Outs, "sysex data byte out of range")
+ error(Outs, "sysex data byte out of range", !IO)
)
- ), Bytes),
- put(Outs, 0xF7),
- write_midi(Status, Ins, Outs).
-write_midi(sys(pos(Pos)), Status, Ins, Outs) -->
- put(Outs, 0xF2),
- { Byte1 = Pos /\ 0x7F },
- { Byte2 = (Pos >> 7) /\ 0x7F },
- put(Outs, Byte1),
- put(Outs, Byte2),
- write_midi(Status, Ins, Outs).
-write_midi(sys(sel(Sel)), Status, Ins, Outs) -->
- put(Outs, 0xF3),
- put(Outs, Sel),
- write_midi(Status, Ins, Outs).
-write_midi(sys(tune), Status, Ins, Outs) -->
- put(Outs, 0xF6),
- write_midi(Status, Ins, Outs).
-write_midi(rt(clk), Status, Ins, Outs) -->
- put(Outs, 0xF8),
- write_midi(Status, Ins, Outs).
-write_midi(rt(start), Status, Ins, Outs) -->
- put(Outs, 0xFA),
- write_midi(Status, Ins, Outs).
-write_midi(rt(cont), Status, Ins, Outs) -->
- put(Outs, 0xFB),
- write_midi(Status, Ins, Outs).
-write_midi(rt(stop), Status, Ins, Outs) -->
- put(Outs, 0xFC),
- write_midi(Status, Ins, Outs).
-write_midi(rt(sense), Status, Ins, Outs) -->
- put(Outs, 0xFE),
- write_midi(Status, Ins, Outs).
-write_midi(rt(reset), Status, Ins, Outs) -->
- put(Outs, 0xFF),
- write_midi(Status, Ins, Outs).
-
-:- pred write_one(status, status, byte, stream(message), stream(byte),
- io__state, io__state).
-:- mode write_one(in, in, in, in, in, di, uo) is det.
-
-write_one(Status0, Status1, Byte1, Ins, Outs) -->
- ( { Status0 = Status1 } ->
- { Status = Status0 }
- ;
- { Status = Status1 },
- ( { status(Status, Byte) } ->
- put(Outs, Byte)
+ ),
+ list.foldl(PutByte, Bytes, !IO),
+ put(Outs, 0xF7, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(sys(pos(Pos)), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xF2, !IO),
+ Byte1 = Pos /\ 0x7F,
+ Byte2 = (Pos >> 7) /\ 0x7F,
+ put(Outs, Byte1, !IO),
+ put(Outs, Byte2, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(sys(sel(Sel)), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xF3, !IO),
+ put(Outs, Sel, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(sys(tune), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xF6, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(rt(clk), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xF8, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(rt(start), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xFA, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(rt(cont), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xFB, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(rt(stop), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xFC, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(rt(sense), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xFE, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+write_midi(rt(reset), Status, Ins, Outs, !IO) :-
+ put(Outs, 0xFF, !IO),
+ write_midi(Status, Ins, Outs, !IO).
+
+:- pred write_one(status::in, status::in, byte::in, stream(message)::in,
+ stream(byte)::in, io::di, io::uo) is det.
+
+write_one(Status0, Status1, Byte1, Ins, Outs, !IO) :-
+ ( Status0 = Status1 ->
+ Status = Status0
+ ;
+ Status = Status1,
+ ( status(Status, Byte) ->
+ put(Outs, Byte, !IO)
;
- error(Outs, "invalid channel")
+ error(Outs, "invalid channel", !IO)
)
),
- ( { Byte1 >= 0, Byte1 =< 127 } ->
- put(Outs, Byte1)
+ ( Byte1 >= 0, Byte1 =< 127 ->
+ put(Outs, Byte1, !IO)
;
- error(Outs, "invalid data byte")
+ error(Outs, "invalid data byte", !IO)
),
- write_midi(Status, Ins, Outs).
+ write_midi(Status, Ins, Outs, !IO).
-:- pred write_two(status, status, byte, byte, stream(message), stream(byte),
- io__state, io__state).
-:- mode write_two(in, in, in, in, in, in, di, uo) is det.
+:- pred write_two(status::in, status::in, byte::in, byte::in,
+ stream(message)::in, stream(byte)::in, io::di, io::uo) is det.
-write_two(Status0, Status1, Byte1, Byte2, Ins, Outs) -->
- ( { Status0 = Status1 } ->
- { Status = Status0 }
+write_two(Status0, Status1, Byte1, Byte2, Ins, Outs, !IO) :-
+ ( Status0 = Status1 ->
+ Status = Status0
;
- { Status = Status1 },
- ( { status(Status, Byte) } ->
- put(Outs, Byte)
+ Status = Status1,
+ ( status(Status, Byte) ->
+ put(Outs, Byte, !IO)
;
- error(Outs, "invalid channel")
+ error(Outs, "invalid channel", !IO)
)
),
- ( { Byte1 >= 0, Byte1 =< 127 } ->
- put(Outs, Byte1)
+ ( Byte1 >= 0, Byte1 =< 127 ->
+ put(Outs, Byte1, !IO)
;
- error(Outs, "invalid data byte")
+ error(Outs, "invalid data byte", !IO)
),
- ( { Byte2 >= 0, Byte2 =< 127 } ->
- put(Outs, Byte2)
+ ( Byte2 >= 0, Byte2 =< 127 ->
+ put(Outs, Byte2, !IO)
;
- error(Outs, "invalid data byte")
+ error(Outs, "invalid data byte", !IO)
),
- write_midi(Status, Ins, Outs).
+ write_midi(Status, Ins, Outs, !IO).
-:- pred status(status, byte).
-:- mode status(in, out) is semidet.
+:- pred status(status::in, byte::out) is semidet.
status(none, _) :-
error("status: no status").
status(status(Kind, Chan), Byte) :-
Chan >= 0, Chan =< 15,
- (
- Kind = two(off), Nib = 0x80
+ ( Kind = two(off), Nib = 0x80
; Kind = two(on), Nib = 0x90
; Kind = two(kp), Nib = 0xA0
; Kind = two(cc), Nib = 0xB0
@@ -800,11 +804,10 @@
),
Byte = Nib \/ Chan.
-%------------------------------------------------------------------------------%
-%------------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
-:- pred byte2hex(int, hex, hex).
-:- mode byte2hex(in, out, out) is det.
+:- pred byte2hex(int::in, hex::out, hex::out) is det.
byte2hex(Byte, MSN, LSN) :-
(
@@ -817,8 +820,7 @@
error("byte2hex: conversion failed!")
).
-:- pred hex2byte(hex, hex, int).
-:- mode hex2byte(in, in, out) is det.
+:- pred hex2byte(hex::in, hex::in, int::out) is det.
hex2byte(MSN, LSN, Byte) :-
nibble2hex(A, MSN),
@@ -846,3 +848,5 @@
nibble2hex(0xE, xE).
nibble2hex(0xF, xF).
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: midimon.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/concurrency/midimon.m,v
retrieving revision 1.2
diff -u -b -r1.2 midimon.m
--- midimon.m 30 Jul 2004 07:03:45 -0000 1.2
+++ midimon.m 20 Apr 2006 05:40:36 -0000
@@ -1,106 +1,122 @@
+%----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+
:- module midimon.
:- interface.
-
:- import_module io.
-:- pred main(io__state, io__state).
-:- mode main(di, uo) is cc_multi.
+:- pred main(io::di, io::uo) is cc_multi.
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
:- implementation.
+:- import_module global.
:- import_module midi.
-:- import_module global, stream, spawn.
-:- import_module bool, getopt, int, list, require, std_util, string.
+:- import_module spawn.
+:- import_module stream.
-main -->
- io__command_line_arguments(Args0),
- { process_options(
- option_ops(short_option, long_option, option_defaults),
- Args0, _Args, MOpts) },
- (
- { MOpts = ok(Opts) },
- { lookup_bool_option(Opts, help, Help) },
- ( { Help = yes } ->
- help
- ;
- { lookup_maybe_string_option(Opts, input, MInfile) },
- open_input(MInfile, InFileOpened),
- (
- { InFileOpened = yes },
- new(Bytes0),
- new(Messages),
- spawn((pred(di, uo) is cc_multi -->
- read_midi(Bytes0, Messages)
- )),
- spawn((pred(di, uo) is cc_multi -->
- print_messages(Messages)
- )),
- read_input(Bytes0)
+:- import_module bool.
+:- import_module char.
+:- import_module getopt.
+:- import_module int.
+:- import_module list.
+:- import_module maybe.
+:- import_module require.
+:- import_module string.
+
+%----------------------------------------------------------------------------%
+
+main(!IO) :-
+ io.command_line_arguments(Args0, !IO),
+ process_options(
+ option_ops_multi(short_option, long_option, option_defaults),
+ Args0, _Args, MOpts),
+ (
+ MOpts = ok(Opts),
+ lookup_bool_option(Opts, help, Help),
+ (
+ Help = yes,
+ help(!IO)
+ ;
+ Help = no,
+ lookup_maybe_string_option(Opts, input, MInfile),
+ open_input(MInfile, InFileOpened, !IO),
+ (
+ InFileOpened = yes,
+ new(Bytes0, !IO),
+ new(Messages, !IO),
+ spawn((pred(!.IO::di, !:IO::uo) is cc_multi :-
+ read_midi(Bytes0, Messages, !IO)
+ ), !IO),
+ spawn((pred(!.IO::di, !:IO::uo) is cc_multi :-
+ print_messages(Messages, !IO)
+ ), !IO),
+ read_input(Bytes0, !IO)
;
- { InFileOpened = no }
+ InFileOpened = no
)
)
;
- { MOpts = error(Msg) },
- stderr_stream(StdErr),
- format(StdErr, "%s\n", [s(Msg)])
+ MOpts = error(Msg),
+ io.stderr_stream(StdErr, !IO),
+ io.format(StdErr, "%s\n", [s(Msg)], !IO)
).
-:- pred open_input(maybe(string), bool, io__state, io__state).
-:- mode open_input(in, out, di, uo) is det.
+:- pred open_input(maybe(string)::in, bool::out, io::di, io::uo) is det.
-open_input(no, Opened) -->
- see_binary("/dev/midi", Res),
+open_input(no, Opened, !IO) :-
+ io.see_binary("/dev/midi", Res, !IO),
(
- { Res = ok },
- { Opened = yes }
+ Res = ok,
+ Opened = yes
;
- { Res = error(Err) },
- { error_message(Err, Msg) },
- stderr_stream(StdErr),
- format(StdErr, "error opening `/dev/midi': %s\n", [s(Msg)]),
- { Opened = no }
+ Res = error(Err),
+ io.error_message(Err, Msg),
+ io.stderr_stream(StdErr, !IO),
+ io.format(StdErr, "error opening `/dev/midi': %s\n", [s(Msg)], !IO),
+ Opened = no
).
-open_input(yes(FileName), Opened) -->
- ( { FileName = "-" } ->
+open_input(yes(FileName), Opened, !IO) :-
+ ( FileName = "-" ->
% use stdin
- { Opened = yes }
+ Opened = yes
;
- see_binary(FileName, Res),
+ io.see_binary(FileName, Res, !IO),
(
- { Res = ok },
- { Opened = yes }
+ Res = ok,
+ Opened = yes
;
- { Res = error(Err) },
- { error_message(Err, Msg) },
- stderr_stream(StdErr),
- format(StdErr, "error opening `%s': %s\n",
- [s(FileName), s(Msg)]),
- { Opened = no }
+ Res = error(Err),
+ io.error_message(Err, Msg),
+ io.stderr_stream(StdErr, !IO),
+ io.format(StdErr, "error opening `%s': %s\n",
+ [s(FileName), s(Msg)], !IO),
+ Opened = no
)
).
-:- pred read_input(stream(byte), io__state, io__state).
-:- mode read_input(in, di, uo) is det.
+:- pred read_input(stream(byte)::in, io::di, io::uo) is det.
-read_input(Stream) -->
- io__read_byte(Res0),
+read_input(Stream, !IO) :-
+ io.read_byte(Res0, !IO),
(
- { Res0 = eof },
- end(Stream)
+ Res0 = eof,
+ end(Stream, !IO)
+ ;
+ Res0 = error(Err),
+ io.error_message(Err, Msg),
+ error(Stream, Msg, !IO)
;
- { Res0 = error(Err) },
- { io__error_message(Err, Msg) },
- error(Stream, Msg)
- ;
- { Res0 = ok(Byte) },
- put(Stream, Byte),
- read_input(Stream)
+ Res0 = ok(Byte),
+ put(Stream, Byte, !IO),
+ read_input(Stream, !IO)
).
-:- pred print_messages(stream(message), io__state, io__state).
-:- mode print_messages(in, di, uo) is det.
+:- pred print_messages(stream(message)::in, io::di, io::uo) is det.
print_messages(Stream) -->
get(Stream, Res0),
@@ -115,45 +131,41 @@
write_string(Msg), nl
).
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
:- type option_table == option_table(option).
:- type maybe_option_table == maybe_option_table(option).
% The master list of options.
-
+ %
:- type option
---> help
- ; input
- .
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
+ ; input.
:- pred long_option(string::in, option::out) is semidet.
+
long_option("help", help).
long_option("input-file", input).
-:- pred short_option(character::in, option::out) is semidet.
+:- pred short_option(char::in, option::out) is semidet.
+
short_option('h', help).
short_option('i', input).
-:- pred option_defaults(option :: out, option_data :: out) is nondet.
-option_defaults(Opt, Data) :-
- semidet_succeed,
- option_defaults0(Opt, Data).
-
-:- pred option_defaults0(option :: out, option_data :: out) is multi.
-option_defaults0(help, bool(no)).
-option_defaults0(input, maybe_string(no)).
+:- pred option_defaults(option::out, option_data::out) is multi.
+
+option_defaults(help, bool(no)).
+option_defaults(input, maybe_string(no)).
-:- pred help(io__state, io__state).
-:- mode help(di, uo) is det.
+:- pred help(io::di, io::uo) is det.
-help -->
- write_strings([
+help(!IO) :-
+ io.write_strings([
"usage: midimon [--help|-h] [--input-file|-i <filename>]\n",
" --help|-h print this help message.\n",
" --input-file|-i <file> read from <file> (default is /dev/midi).\n"
- ]).
+ ], !IO).
%-----------------------------------------------------------------------------%
-
+%-----------------------------------------------------------------------------%
Index: mutvar.m
===================================================================
RCS file: mutvar.m
diff -N mutvar.m
--- mutvar.m 29 May 2001 08:51:57 -0000 1.3
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,137 +0,0 @@
-%---------------------------------------------------------------------------%
-% Copyright (C) 2000-2001 The University of Melbourne.
-% This file may only be copied under the terms of the GNU Library General
-% Public License - see the file COPYING.LIB
-%---------------------------------------------------------------------------%
-%
-% Main author: petdr, fjh
-% Stability: low.
-%
-% This module provides a Mercury version of Haskell mutable variables.
-% A mutable variable (mutvar) is a refencence to a mutable location which
-% can either contain a value of type T or be empty.
-%
-% Access to a mutvar is thread-safe and can be used to synchronize
-% between different threads.
-%
-% XXX This module is now obsolete in the sense that programmers are
-% encouraged to migrate to using mvar.m which is identical in all
-% respects other than its name and corresponding change of name of
-% the exported type. This was done to avoid confusion with
-% store__mutvar and to better reflect the Haskell origins of the mvar
-% data type.
-%
-%---------------------------------------------------------------------------%
-
-:- module mutvar.
-
-:- interface.
-
-:- import_module io.
-
-:- type mutvar(T).
-
- % Create an empty mutvar.
-:- pred mutvar__init(mutvar(T)::out, io__state::di, io__state::uo) is det.
-:- pragma obsolete(mutvar__init/3).
-
- % Take the contents of the mutvar out leaving the mutvar empty.
- % If the mutvar is empty, block until some thread fills the
- % mutvar.
-:- pred mutvar__take(mutvar(T)::in, T::out,
- io__state::di, io__state::uo) is det.
-:- pragma obsolete(mutvar__take/4).
-
- % Place the value of type T into an empty mutvar. If the
- % mutvar is full block until it becomes empty.
-:- pred mutvar__put(mutvar(T)::in, T::in,
- io__state::di, io__state::uo) is det.
-:- pragma obsolete(mutvar__put/4).
-
-%---------------------------------------------------------------------------%
-%---------------------------------------------------------------------------%
-
-:- implementation.
-
-:- import_module semaphore.
-
-:- type mutvar(T)
- ---> mutvar(
- semaphore, % full
- semaphore, % empty
- ref(T) % data
- ).
-
-:- pragma promise_pure(mutvar__init/3).
-mutvar__init(mutvar(Full, Empty, Ref)) -->
- semaphore__new(Full),
- semaphore__new(Empty),
-
- { impure new_ref(Ref) },
-
- % Initially a mutvar starts empty.
- semaphore__signal(Empty).
-
-:- pragma promise_pure(mutvar__take/4).
-mutvar__take(mutvar(Full, Empty, Ref), Data) -->
- semaphore__wait(Full),
- { impure get_ref(Ref, Data) },
- semaphore__signal(Empty).
-
-:- pragma promise_pure(mutvar__put/4).
-mutvar__put(mutvar(Full, Empty, Ref), Data) -->
- semaphore__wait(Empty),
- { impure set_ref(Ref, Data) },
- semaphore__signal(Full).
-
-%---------------------------------------------------------------------------%
-%---------------------------------------------------------------------------%
-
-% A non-backtrackably destructively modifiable reference type
-
-%%% :- interface.
-
-:- type ref(T).
-
-% Create an empty ref location.
-:- impure pred new_ref(ref(T)).
-:- mode new_ref(out) is det.
-
-% Get the value currently referred to by a reference.
-:- impure pred get_ref(ref(T), T) is det.
-:- mode get_ref(in, uo) is det. % XXX this is a work-around
-
-% destructively modify a reference to refer to a new object.
-:- impure pred set_ref(ref(T), T) is det.
-:- mode set_ref(in, in) is det.
-
-%%% :- implementation.
-
-% This type is implemented in C.
-:- type ref(T) ---> ref(c_pointer).
-
-:- pragma inline(new_ref/1).
-:- pragma c_code(new_ref(Ref::out),
- [will_not_call_mercury, thread_safe],
-"
- incr_hp_msg(Ref, 1, MR_PROC_LABEL, ""mutvar:ref/1"");
- *(MR_Word *) Ref = NULL;
-").
-
-:- pragma inline(get_ref/2).
-:- pragma c_code(get_ref(Ref::in, X::uo),
- [will_not_call_mercury, thread_safe],
-"
- X = *(MR_Word *) Ref;
- *(MR_Word *) Ref = NULL;
-").
-
-:- pragma inline(set_ref/2).
-:- pragma c_code(set_ref(Ref::in, X::in),
- [will_not_call_mercury, thread_safe],
-"
- *(MR_Word *) Ref = (MR_Word) X;
-").
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
Index: mvar.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/concurrency/mvar.m,v
retrieving revision 1.6
diff -u -b -r1.6 mvar.m
--- mvar.m 28 Feb 2003 14:45:44 -0000 1.6
+++ mvar.m 20 Apr 2006 05:06:07 -0000
@@ -1,50 +1,57 @@
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
% Copyright (C) 2000-2003 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
%
-% Main author: petdr, fjh
+% File: mvar.m.
+% Main author: petdr, fjh.
% Stability: low.
%
-% This module provides a Mercury version of Haskell mutable variables.
-% A mutable variable (mvar) is a refencence to a mutable location which
-% can either contain a value of type T or be empty.
+% This module provides a Mercury version of Haskell mutable variables. A
+% mutable variable (mvar) is a reference to a mutable location which can
+% either contain a value of type T or be empty.
%
-% Access to a mvar is thread-safe and can be used to synchronize
-% between different threads.
+% Access to a mvar is thread-safe and can be used to synchronize between
+% different threads.
%
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- module mvar.
-
:- interface.
:- import_module io.
+%-----------------------------------------------------------------------------%
+
:- type mvar(T).
% Create an empty mvar.
-:- pred mvar__init(mvar(T)::out, io__state::di, io__state::uo) is det.
+ %
+:- pred mvar.init(mvar(T)::out, io::di, io::uo) is det.
% Take the contents of the mvar out leaving the mvar empty.
- % If the mvar is empty, block until some thread fills the
- % mvar.
-:- pred mvar__take(mvar(T)::in, T::out,
- io__state::di, io__state::uo) is det.
-
- % Place the value of type T into an empty mvar. If the
- % mvar is full block until it becomes empty.
-:- pred mvar__put(mvar(T)::in, T::in,
- io__state::di, io__state::uo) is det.
+ % If the mvar is empty, block until some thread fills the mvar.
+ %
+:- pred mvar.take(mvar(T)::in, T::out, io::di, io::uo) is det.
+
+ % Place the value of type T into an empty mvar.
+ % If the mvar is full block until it becomes empty.
+ %
+:- pred mvar.put(mvar(T)::in, T::in, io::di, io::uo) is det.
-%---------------------------------------------------------------------------%
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- implementation.
:- import_module semaphore.
+%-----------------------------------------------------------------------------%
+
:- type mvar(T)
---> mvar(
semaphore, % full
@@ -52,27 +59,24 @@
ref(T) % data
).
-:- pragma promise_pure(mvar__init/3).
-mvar__init(mvar(Full, Empty, Ref)) -->
- semaphore__new(Full),
- semaphore__new(Empty),
-
- { impure new_ref(Ref) },
-
- % Initially a mvar starts empty.
- semaphore__signal(Empty).
-
-:- pragma promise_pure(mvar__take/4).
-mvar__take(mvar(Full, Empty, Ref), Data) -->
- semaphore__wait(Full),
- { impure get_ref(Ref, Data) },
- semaphore__signal(Empty).
-
-:- pragma promise_pure(mvar__put/4).
-mvar__put(mvar(Full, Empty, Ref), Data) -->
- semaphore__wait(Empty),
- { impure set_ref(Ref, Data) },
- semaphore__signal(Full).
+:- pragma promise_pure(mvar.init/3).
+mvar.init(mvar(Full, Empty, Ref), !IO) :-
+ semaphore.new(Full, !IO),
+ semaphore.new(Empty, !IO),
+ impure new_ref(Ref),
+ semaphore.signal(Empty, !IO). % Initially a mvar starts empty.
+
+:- pragma promise_pure(mvar.take/4).
+mvar.take(mvar(Full, Empty, Ref), Data, !IO) :-
+ semaphore.wait(Full, !IO),
+ impure get_ref(Ref, Data),
+ semaphore.signal(Empty, !IO).
+
+:- pragma promise_pure(mvar.put/4).
+mvar.put(mvar(Full, Empty, Ref), Data, !IO) :-
+ semaphore.wait(Empty, !IO),
+ impure set_ref(Ref, Data),
+ semaphore.signal(Full, !IO).
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
@@ -83,22 +87,22 @@
:- type ref(T).
-% Create an empty ref location.
-:- impure pred new_ref(ref(T)).
-:- mode new_ref(out) is det.
-
-% Get the value currently referred to by a reference.
-:- impure pred get_ref(ref(T), T) is det.
-:- mode get_ref(in, uo) is det. % XXX this is a work-around
-
-% destructively modify a reference to refer to a new object.
-:- impure pred set_ref(ref(T), T) is det.
-:- mode set_ref(in, in) is det.
+ % Create an empty ref location.
+ %
+:- impure pred new_ref(ref(T)::out) is det.
+
+ % Get the value currently referred to by a reference.
+ %
+:- impure pred get_ref(ref(T)::in, T::uo) is det.
+
+ % Destructively modify a reference to refer to a new object.
+ %
+:- impure pred set_ref(ref(T)::in, T::in) is det.
%%% :- implementation.
-% This type is implemented in C.
-:- type ref(T).
+ % This type is implemented in C.
+ %
:- pragma foreign_type(c, ref(T), "MR_Word").
:- pragma foreign_type(il, ref(T), "class [mvar__csharp_code]ME_Reference").
@@ -107,41 +111,53 @@
public object val;
}
").
+
:- pragma inline(new_ref/1).
-:- pragma c_code(new_ref(Ref::out),
+:- pragma foreign_proc("C",
+ new_ref(Ref::out),
[will_not_call_mercury, thread_safe],
"
- MR_incr_hp_msg(Ref, 1, MR_PROC_LABEL, ""mvar:ref/1"");
+ MR_incr_hp_msg(Ref, 1, MR_PROC_LABEL, ""mvar.ref/1"");
*(MR_Word *) Ref = (MR_Word) NULL;
").
-:- pragma foreign_proc("C#", new_ref(Ref::out),
- [will_not_call_mercury, thread_safe], "
+
+:- pragma foreign_proc("C#",
+ new_ref(Ref::out),
+ [will_not_call_mercury, thread_safe],
+"
Ref = new ME_Reference();
Ref.val = null;
").
-
:- pragma inline(get_ref/2).
-:- pragma c_code(get_ref(Ref::in, X::uo),
+:- pragma foreign_proc("C",
+ get_ref(Ref::in, X::uo),
[will_not_call_mercury, thread_safe],
"
X = *(MR_Word *) Ref;
*(MR_Word *) Ref = (MR_Word) NULL;
").
-:- pragma foreign_proc("C#", get_ref(Ref::in, X::uo),
- [will_not_call_mercury, thread_safe], "
+
+:- pragma foreign_proc("C#",
+ get_ref(Ref::in, X::uo),
+ [will_not_call_mercury, thread_safe],
+"
X = Ref.val;
Ref.val = null;
").
:- pragma inline(set_ref/2).
-:- pragma c_code(set_ref(Ref::in, X::in),
+:- pragma foreign_proc("C",
+ set_ref(Ref::in, X::in),
[will_not_call_mercury, thread_safe],
"
*(MR_Word *) Ref = (MR_Word) X;
").
-:- pragma foreign_proc("C#", set_ref(Ref::in, X::in),
- [will_not_call_mercury, thread_safe], "
+
+:- pragma foreign_proc("C#",
+ set_ref(Ref::in, X::in),
+ [will_not_call_mercury, thread_safe],
+"
Ref.val = X;
").
Index: philo.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/concurrency/philo.m,v
retrieving revision 1.1
diff -u -b -r1.1 philo.m
--- philo.m 29 Feb 2000 22:37:14 -0000 1.1
+++ philo.m 20 Apr 2006 04:56:15 -0000
@@ -1,27 +1,43 @@
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
% Copyright (C) 2000 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
%
-% Main author: conway
+% File: philo.m.
+% Main author: conway.
%
% The classic "Dining Philosophers" problem, to show how to use the basic
% coroutining primitives.
%
-%---------------------------------------------------------------------------%
-:- module philo.
+%-----------------------------------------------------------------------------%
+:- module philo.
:- interface.
:- import_module io.
-:- pred main(io__state::di, io__state::uo) is cc_multi.
+%-----------------------------------------------------------------------------%
+
+:- pred main(io::di, io::uo) is cc_multi.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module spawn, global, semaphore.
-:- import_module bool, list, require, string.
+:- import_module global.
+:- import_module semaphore.
+:- import_module spawn.
+
+:- import_module bool.
+:- import_module list.
+:- import_module require.
+:- import_module string.
+
+%-----------------------------------------------------------------------------%
:- type forks
---> forks(bool, bool, bool, bool, bool).
@@ -31,44 +47,43 @@
; aristotle
; descartes
; russell
- ; sartre
- .
+ ; sartre.
-main -->
- new(Lock), signal(Lock),
- new(forks(yes, yes, yes, yes, yes), ForkGlob),
- spawn(philosopher(plato, Lock, ForkGlob)),
- spawn(philosopher(aristotle, Lock, ForkGlob)),
- spawn(philosopher(descartes, Lock, ForkGlob)),
- spawn(philosopher(russell, Lock, ForkGlob)),
- philosopher(sartre, Lock, ForkGlob).
-
-:- pred philosopher(philosopher, semaphore, global(forks),
- io__state, io__state).
-:- mode philosopher(in, in, in, di, uo) is cc_multi.
-
-philosopher(Who, Lock, ForkGlob) -->
- { name(Who, Name) },
- io__format("%s is thinking.\n", [s(Name)]),
- wait(Lock),
- get(ForkGlob, Forks0),
- ( { forks(Who, Forks0, Forks1) } ->
- set(ForkGlob, Forks1),
- signal(Lock),
- io__format("%s is eating.\n", [s(Name)]),
- wait(Lock),
- get(ForkGlob, Forks2),
- ( { forks(Who, Forks3, Forks2) } ->
- set(ForkGlob, Forks3),
- signal(Lock)
+main(!IO) :-
+ new(Lock, !IO),
+ signal(Lock, !IO),
+ new(forks(yes, yes, yes, yes, yes), ForkGlob, !IO),
+ spawn(philosopher(plato, Lock, ForkGlob), !IO),
+ spawn(philosopher(aristotle, Lock, ForkGlob), !IO),
+ spawn(philosopher(descartes, Lock, ForkGlob), !IO),
+ spawn(philosopher(russell, Lock, ForkGlob), !IO),
+ philosopher(sartre, Lock, ForkGlob, !IO).
+
+:- pred philosopher(philosopher::in, semaphore::in, global(forks)::in,
+ io::di, io::uo) is cc_multi.
+
+philosopher(Who, Lock, ForkGlob, !IO) :-
+ name(Who, Name),
+ io.format("%s is thinking.\n", [s(Name)], !IO),
+ wait(Lock, !IO),
+ get(ForkGlob, Forks0, !IO),
+ ( forks(Who, Forks0, Forks1) ->
+ set(ForkGlob, Forks1, !IO),
+ signal(Lock, !IO),
+ io.format("%s is eating.\n", [s(Name)], !IO),
+ wait(Lock, !IO),
+ get(ForkGlob, Forks2, !IO),
+ ( forks(Who, Forks3, Forks2) ->
+ set(ForkGlob, Forks3, !IO),
+ signal(Lock, !IO)
;
- { error("all forked up") }
+ error("all forked up")
)
;
% Our 2 forks were not available
- signal(Lock)
+ signal(Lock, !IO)
),
- philosopher(Who, Lock, ForkGlob).
+ philosopher(Who, Lock, ForkGlob, !IO).
:- pred forks(philosopher, forks, forks).
:- mode forks(in, in, out) is semidet.
@@ -80,12 +95,13 @@
forks(russell, forks(A, B, C, yes, yes), forks(A, B, C, no, no)).
forks(sartre, forks(yes, B, C, D, yes), forks(no, B, C, D, no)).
-:- pred name(philosopher, string).
-:- mode name(in, out) is det.
+:- pred name(philosopher::in, string::out) is det.
-name(plato , "Plato").
-name(aristotle , "Aristotle").
-name(descartes , "Descartes").
-name(russell , "Russell").
-name(sartre , "Sartre").
+name(plato, "Plato").
+name(aristotle, "Aristotle").
+name(descartes, "Descartes").
+name(russell, "Russell").
+name(sartre, "Sartre").
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: philo2.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/concurrency/philo2.m,v
retrieving revision 1.7
diff -u -b -r1.7 philo2.m
--- philo2.m 3 Mar 2003 14:16:52 -0000 1.7
+++ philo2.m 20 Apr 2006 05:14:29 -0000
@@ -1,27 +1,43 @@
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
% Copyright (C) 2000-2003 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
%
+% File: philo2.m.
% Main author: petdr (based on code by conway)
%
% The classic "Dining Philosophers" problem, to show how to use mvars
% to do coroutining.
%
+%-----------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
-:- module philo2.
+:- module philo2.
:- interface.
:- import_module io.
-:- pred main(io__state::di, io__state::uo) is cc_multi.
+%---------------------------------------------------------------------------%
+
+:- pred main(io::di, io::uo) is cc_multi.
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
:- implementation.
-:- import_module mvar, spawn.
-:- import_module bool, list, require, string.
+:- import_module mvar.
+:- import_module spawn.
+
+:- import_module bool.
+:- import_module list.
+:- import_module require.
+:- import_module string.
+
+%---------------------------------------------------------------------------%
:- type forks
---> forks(bool, bool, bool, bool, bool).
@@ -31,44 +47,42 @@
; aristotle
; descartes
; russell
- ; sartre
- .
+ ; sartre.
-main -->
- mvar__init(ForkGlob),
- mvar__put(ForkGlob, forks(yes, yes, yes, yes, yes)),
- spawn(philosopher(plato, ForkGlob)),
- spawn(philosopher(aristotle, ForkGlob)),
- spawn(philosopher(descartes, ForkGlob)),
- spawn(philosopher(russell, ForkGlob)),
- philosopher(sartre, ForkGlob).
-
-:- pred philosopher(philosopher, mvar(forks),
- io__state, io__state).
-:- mode philosopher(in, in, di, uo) is cc_multi.
-
-philosopher(Who, ForkGlob) -->
- io__flush_output,
- { name(Who, Name) },
- io__format("%s is thinking.\n", [s(Name)]),
- rand_sleep(5),
- mvar__take(ForkGlob, Forks0),
- io__format("%s is attempting to eat.\n", [s(Name)]),
- ( { forks(Who, Forks0, Forks1) } ->
- mvar__put(ForkGlob, Forks1),
- io__format("%s is eating.\n", [s(Name)]),
- rand_sleep(10),
- mvar__take(ForkGlob, Forks2),
- ( { forks(Who, Forks3, Forks2) } ->
- mvar__put(ForkGlob, Forks3)
+main(!IO) :-
+ mvar.init(ForkGlob, !IO),
+ mvar.put(ForkGlob, forks(yes, yes, yes, yes, yes), !IO),
+ spawn(philosopher(plato, ForkGlob), !IO),
+ spawn(philosopher(aristotle, ForkGlob), !IO),
+ spawn(philosopher(descartes, ForkGlob), !IO),
+ spawn(philosopher(russell, ForkGlob), !IO),
+ philosopher(sartre, ForkGlob, !IO).
+
+:- pred philosopher(philosopher::in, mvar(forks)::in, io::di, io::uo)
+ is cc_multi.
+
+philosopher(Who, ForkGlob, !IO) :-
+ io.flush_output(!IO),
+ name(Who, Name),
+ io.format("%s is thinking.\n", [s(Name)], !IO),
+ rand_sleep(5, !IO),
+ mvar.take(ForkGlob, Forks0, !IO),
+ io.format("%s is attempting to eat.\n", [s(Name)], !IO),
+ ( forks(Who, Forks0, Forks1) ->
+ mvar.put(ForkGlob, Forks1, !IO),
+ io.format("%s is eating.\n", [s(Name)], !IO),
+ rand_sleep(10, !IO),
+ mvar.take(ForkGlob, Forks2, !IO),
+ ( forks(Who, Forks3, Forks2) ->
+ mvar.put(ForkGlob, Forks3, !IO)
;
- { error("all forked up") }
+ error("all forked up")
)
;
% Our 2 forks were not available
- mvar__put(ForkGlob, Forks0)
+ mvar.put(ForkGlob, Forks0, !IO)
),
- philosopher(Who, ForkGlob).
+ philosopher(Who, ForkGlob, !IO).
:- pred forks(philosopher, forks, forks).
:- mode forks(in, in, out) is semidet.
@@ -80,30 +94,38 @@
forks(russell, forks(A, B, C, yes, yes), forks(A, B, C, no, no)).
forks(sartre, forks(yes, B, C, D, yes), forks(no, B, C, D, no)).
-:- pred name(philosopher, string).
-:- mode name(in, out) is det.
+:- pred name(philosopher::in, string::out) is det.
-name(plato , "Plato").
-name(aristotle , "Aristotle").
-name(descartes , "Descartes").
-name(russell , "Russell").
-name(sartre , "Sartre").
+name(plato, "Plato").
+name(aristotle, "Aristotle").
+name(descartes, "Descartes").
+name(russell, "Russell").
+name(sartre, "Sartre").
:- pragma foreign_code("C#", "
public static System.Random rng = new System.Random();
").
-:- pred rand_sleep(int::in, io__state::di, io__state::uo) is det.
-:- pragma c_code(rand_sleep(Int::in, IO0::di, IO::uo),
- [thread_safe, will_not_call_mercury], "{
+:- pred rand_sleep(int::in, io::di, io::uo) is det.
+
+:- pragma foreign_proc("C",
+ rand_sleep(Int::in, IO0::di, IO::uo),
+ [promise_pure, thread_safe, will_not_call_mercury],
+"
#ifdef _MSC_VER
Sleep(1000 * (rand() % Int));
#else
sleep((rand() % Int));
#endif
IO = IO0;
-}").
-:- pragma foreign_proc("C#", rand_sleep(Int::in, _IO0::di, _IO::uo),
- [thread_safe, will_not_call_mercury, promise_pure], "{
+").
+
+:- pragma foreign_proc("C#",
+ rand_sleep(Int::in, _IO0::di, _IO::uo),
+ [promise_pure, thread_safe, will_not_call_mercury],
+"
System.Threading.Thread.Sleep(rng.Next(Int) * 1000);
-}").
+").
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
Index: philo3.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/concurrency/philo3.m,v
retrieving revision 1.4
diff -u -b -r1.4 philo3.m
--- philo3.m 3 Mar 2003 14:16:52 -0000 1.4
+++ philo3.m 20 Apr 2006 05:16:35 -0000
@@ -1,4 +1,4 @@
-%------------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
% philo3.m
% Copyright (C) 2001-2002 Ralph Becket <rbeck at microsoft.com>
% Mon May 14 14:32:29 BST 2001
@@ -8,92 +8,98 @@
% WHATEVER LICENCE IS DEEMED APPROPRIATE BY THE PROJECT
% MANAGEMENT.
%
-% The dining philosophers using semaphores. The philosophers
-% acquire forks such that even numbered philosophers pick up
-% left then right whereas odd numbered philosophers pick up
-% right then left. This is guaranteed not to lead to deadlock.
+% The dining philosophers using semaphores. The philosophers acquire forks
+% such that even numbered philosophers pick up left then right whereas odd
+% numbered philosophers pick up right then left. This is guaranteed not to
+% lead to deadlock.
%
-%------------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- module philo3.
-
:- interface.
:- import_module io.
+:- pred main(io::di, io::uo) is cc_multi.
-
-:- pred main(io__state::di, io__state::uo) is cc_multi.
-
-%------------------------------------------------------------------------------%
-%------------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module string, list.
-:- import_module semaphore, spawn.
+:- import_module semaphore.
+:- import_module spawn.
+
+:- import_module list.
+:- import_module string.
-%------------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
-main -->
- semaphore__new(Fork0), semaphore__signal(Fork0),
- semaphore__new(Fork1), semaphore__signal(Fork1),
- semaphore__new(Fork2), semaphore__signal(Fork2),
- semaphore__new(Fork3), semaphore__signal(Fork3),
- semaphore__new(Fork4), semaphore__signal(Fork4),
- spawn(philosopher("Plato", 0, Fork0, 1, Fork1)),
- spawn(philosopher("Aristotle", 2, Fork2, 1, Fork1)),
- spawn(philosopher("Descartes", 2, Fork2, 3, Fork3)),
- spawn(philosopher("Calvin", 4, Fork4, 3, Fork3)),
- philosopher("Hobbes", 4, Fork4, 0, Fork0).
-
-%------------------------------------------------------------------------------%
-
-:- pred philosopher(string,int,semaphore,int,semaphore,io__state,io__state).
-:- mode philosopher(in, in, in, in, in, di, uo) is cc_multi.
-
-philosopher(Name, A, ForkA, B, ForkB) -->
-
- io__format("%s is thinking\n", [s(Name)]),
- yield,
- rand_sleep(10),
-
- semaphore__wait(ForkA),
- io__format("%s has acquired fork %d\n", [s(Name), i(A)]),
- semaphore__wait(ForkB),
- io__format("%s has acquired fork %d\n", [s(Name), i(B)]),
-
- io__format("%s is eating\n", [s(Name)]),
- yield,
- rand_sleep(5),
-
- io__format("%s relinquishes fork %d\n", [s(Name), i(B)]),
- semaphore__signal(ForkB),
- io__format("%s relinquishes fork %d\n", [s(Name), i(A)]),
- semaphore__signal(ForkA),
+main(!IO) :-
+ semaphore.new(Fork0, !IO), semaphore.signal(Fork0, !IO),
+ semaphore.new(Fork1, !IO), semaphore.signal(Fork1, !IO),
+ semaphore.new(Fork2, !IO), semaphore.signal(Fork2, !IO),
+ semaphore.new(Fork3, !IO), semaphore.signal(Fork3, !IO),
+ semaphore.new(Fork4, !IO), semaphore.signal(Fork4, !IO),
+ spawn(philosopher("Plato", 0, Fork0, 1, Fork1), !IO),
+ spawn(philosopher("Aristotle", 2, Fork2, 1, Fork1), !IO),
+ spawn(philosopher("Descartes", 2, Fork2, 3, Fork3), !IO),
+ spawn(philosopher("Calvin", 4, Fork4, 3, Fork3), !IO),
+ philosopher("Hobbes", 4, Fork4, 0, Fork0, !IO).
+
+%-----------------------------------------------------------------------------%
+
+:- pred philosopher(string::in, int::in, semaphore::in, int::in,
+ semaphore::in, io::di, io::uo) is cc_multi.
+
+philosopher(Name, A, ForkA, B, ForkB, !IO) :-
+
+ io.format("%s is thinking\n", [s(Name)], !IO),
+ yield(!IO),
+ rand_sleep(10, !IO),
+
+ semaphore.wait(ForkA, !IO),
+ io.format("%s has acquired fork %d\n", [s(Name), i(A)], !IO),
+ semaphore.wait(ForkB, !IO),
+ io.format("%s has acquired fork %d\n", [s(Name), i(B)], !IO),
+
+ io.format("%s is eating\n", [s(Name)], !IO),
+ yield(!IO),
+ rand_sleep(5, !IO),
+
+ io.format("%s relinquishes fork %d\n", [s(Name), i(B)], !IO),
+ semaphore__signal(ForkB, !IO),
+ io.format("%s relinquishes fork %d\n", [s(Name), i(A)], !IO),
+ semaphore.signal(ForkA, !IO),
- philosopher(Name, A, ForkA, B, ForkB).
+ philosopher(Name, A, ForkA, B, ForkB, !IO).
-%------------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- pragma foreign_code("C#", "
public static System.Random rng = new System.Random();
").
-:- pred rand_sleep(int::in, io__state::di, io__state::uo) is det.
-:- pragma c_code(rand_sleep(Int::in, IO0::di, IO::uo),
- [thread_safe, will_not_call_mercury], "{
+:- pred rand_sleep(int::in, io::di, io::uo) is det.
+:- pragma foreign_proc("C",
+ rand_sleep(Int::in, IO0::di, IO::uo),
+ [promise_pure, thread_safe, will_not_call_mercury],
+"
#ifdef _MSC_VER
Sleep(1000 * (rand() % Int));
#else
sleep((rand() % Int));
#endif
IO = IO0;
-}").
-:- pragma foreign_proc("C#", rand_sleep(Int::in, _IO0::di, _IO::uo),
- [thread_safe, will_not_call_mercury, promise_pure], "{
+").
+
+:- pragma foreign_proc("C#",
+ rand_sleep(Int::in, _IO0::di, _IO::uo),
+ [promise_pure, thread_safe, will_not_call_mercury],
+"
System.Threading.Thread.Sleep(rng.Next(Int) * 1000);
-}").
+").
-%------------------------------------------------------------------------------%
-%------------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: semaphore.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/concurrency/semaphore.m,v
retrieving revision 1.14
diff -u -b -r1.14 semaphore.m
--- semaphore.m 24 Nov 2004 15:31:33 -0000 1.14
+++ semaphore.m 20 Apr 2006 04:34:17 -0000
@@ -1,9 +1,12 @@
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
% Copyright (C) 2000-2001,2003-2004 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
%
+% File: semaphore.m.
% Main author: conway
% Stability: medium.
%
@@ -13,48 +16,50 @@
% The operations in this module are no-ops in the hlc grades which don't
% contain a .par component.
%
-%---------------------------------------------------------------------------%
-:- module semaphore.
+%-----------------------------------------------------------------------------%
+:- module semaphore.
:- interface.
-:- import_module bool, io.
+:- import_module bool.
+:- import_module io.
+
+%-----------------------------------------------------------------------------%
:- type semaphore.
-:- pragma foreign_type(c, semaphore, "ME_Semaphore *").
-:- pragma foreign_type(il, semaphore,
- "class [semaphore__csharp_code]ME_Semaphore").
- % new(Sem, IO0, IO) creates a new semaphore `Sem' with its counter
+ % new(Sem, !IO) creates a new semaphore `Sem' with it's counter
% initialized to 0.
-:- pred semaphore__new(semaphore, io__state, io__state).
-:- mode semaphore__new(out, di, uo) is det.
+ %
+:- pred semaphore.new(semaphore::out, io::di, io::uo) is det.
- % wait(Sem, IO0, IO) blocks until the counter associated with `Sem'
+ % wait(Sem, !IO) blocks until the counter associated with `Sem'
% becomes greater than 0, whereupon it wakes, decrements the
% counter and returns.
-:- pred semaphore__wait(semaphore, io__state, io__state).
-:- mode semaphore__wait(in, di, uo) is det.
+ %
+:- pred semaphore.wait(semaphore::in, io::di, io::uo) is det.
- % try_wait(Sem, Succ, IO0, IO) is the same as wait/3, except that
+ % try_wait(Sem, Succ, !IO) is the same as wait/3, except that
% instead of blocking, it binds `Succ' to a boolean indicating
% whether the call succeeded in obtaining the semaphore or not.
-:- pred semaphore__try_wait(semaphore, bool, io__state, io__state).
-:- mode semaphore__try_wait(in, out, di, uo) is det.
+ %
+:- pred semaphore.try_wait(semaphore::in, bool::out, io::di, io::uo) is det.
- % signal(Sem, IO0, IO) increments the counter associated with `Sem'
+ % signal(Sem, !IO) increments the counter associated with `Sem'
% and if the resulting counter has a value greater than 0, it wakes
% one or more coroutines that are waiting on this semaphore (if
% any).
-:- pred semaphore__signal(semaphore, io__state, io__state).
-:- mode semaphore__signal(in, di, uo) is det.
+ %
+:- pred semaphore.signal(semaphore::in, io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
-%---------------------------------------------------------------------------%
:- implementation.
-:- import_module std_util.
+%-----------------------------------------------------------------------------%
-:- pragma c_header_code("
+:- pragma foreign_decl("C", "
#include <stdio.h>
#include ""mercury_context.h""
#include ""mercury_thread.h""
@@ -80,14 +85,22 @@
}
").
-:- pragma c_header_code("
+:- pragma foreign_type(c, semaphore, "ME_Semaphore *").
+:- pragma foreign_type(il, semaphore,
+ "class [semaphore__csharp_code]ME_Semaphore").
+
+:- pragma foreign_decl("C", "
#ifdef MR_CONSERVATIVE_GC
void ME_finalize_semaphore(GC_PTR obj, GC_PTR cd);
#endif
").
-:- pragma c_code(semaphore__new(Semaphore::out, IO0::di, IO::uo),
- [will_not_call_mercury, thread_safe], "{
+%-----------------------------------------------------------------------------%
+
+:- pragma foreign_proc("C",
+ new(Semaphore::out, IO0::di, IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
MR_Word sem_mem;
ME_Semaphore *sem;
@@ -116,14 +129,17 @@
Semaphore = sem;
IO = IO0;
-}").
-:- pragma foreign_proc("C#", semaphore__new(Semaphore::out, _IO0::di, _IO::uo),
- [will_not_call_mercury, thread_safe, promise_pure], "{
+").
+
+:- pragma foreign_proc("C#",
+ new(Semaphore::out, _IO0::di, _IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
Semaphore = new ME_Semaphore();
Semaphore.count = 0;
-}").
+").
-:- pragma c_code("
+:- pragma foreign_code("C", "
#ifdef MR_CONSERVATIVE_GC
void
ME_finalize_semaphore(GC_PTR obj, GC_PTR cd)
@@ -144,13 +160,17 @@
#endif
").
- % because semaphore__signal has a local label, we may get
+ % Because semaphore.signal has a local label, we may get
% C compilation errors if inlining leads to multiple copies
% of this code.
+ %
% XXX get rid of this limitation at some stage.
-:- pragma no_inline(semaphore__signal/3).
-:- pragma c_code(semaphore__signal(Semaphore::in, IO0::di, IO::uo),
- [will_not_call_mercury, thread_safe], "{
+ %
+:- pragma no_inline(semaphore.signal/3).
+:- pragma foreign_proc("C",
+ signal(Semaphore::in, IO0::di, IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
ME_Semaphore *sem;
#ifndef MR_HIGHLEVEL_CODE
MR_Context *ctxt;
@@ -190,23 +210,30 @@
MR_SIGNAL(&(sem->cond));
#endif
IO = IO0;
-}").
-:- pragma foreign_proc("C#", signal(Semaphore::in, _IO0::di, _IO::uo),
- [will_not_call_mercury, thread_safe, promise_pure], "{
+").
+
+:- pragma foreign_proc("C#",
+ signal(Semaphore::in, _IO0::di, _IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
System.Threading.Monitor.Enter(Semaphore);
Semaphore.count++;
// XXX I think we only need to do a Pulse.
System.Threading.Monitor.PulseAll(Semaphore);
System.Threading.Monitor.Exit(Semaphore);
-}").
+").
- % because semaphore__wait has a local label, we may get
+ % Because semaphore__wait has a local label, we may get
% C compilation errors if inlining leads to multiple copies
% of this code.
+ %
% XXX get rid of this limitation at some stage.
+ %
:- pragma no_inline(semaphore__wait/3).
-:- pragma c_code(semaphore__wait(Semaphore::in, IO0::di, IO::uo),
- [will_not_call_mercury, thread_safe], "{
+:- pragma foreign_proc("C",
+ wait(Semaphore::in, IO0::di, IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
ME_Semaphore *sem;
#ifndef MR_HIGHLEVEL_CODE
MR_Context *ctxt;
@@ -240,9 +267,12 @@
MR_UNLOCK(&(sem->lock), ""semaphore__wait"");
#endif
IO = IO0;
-}").
-:- pragma foreign_proc("C#", wait(Semaphore::in, _IO0::di, _IO::uo),
- [will_not_call_mercury, thread_safe, promise_pure], "{
+").
+
+:- pragma foreign_proc("C#",
+ wait(Semaphore::in, _IO0::di, _IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
System.Threading.Monitor.Enter(Semaphore);
while (Semaphore.count <= 0) {
@@ -252,39 +282,38 @@
Semaphore.count--;
System.Threading.Monitor.Exit(Semaphore);
-}").
-
-semaphore__try_wait(Sem, Res) -->
- semaphore__try_wait0(Sem, Res0),
- ( { Res0 = 0 } ->
- { Res = yes }
- ;
- { Res = no }
- ).
-
-:- pred semaphore__try_wait0(semaphore, int, io__state, io__state).
-:- mode semaphore__try_wait0(in, out, di, uo) is det.
+").
-:- pragma c_code(semaphore__try_wait0(Semaphore::in, Res::out, IO0::di, IO::uo),
- [will_not_call_mercury, thread_safe], "{
+semaphore.try_wait(Sem, Res, !IO) :-
+ try_wait_2(Sem, Res0, !IO),
+ Res = ( Res0 = 0 -> yes ; no ).
+
+:- pred try_wait_2(semaphore::in, int::out, io::di, io::uo) is det.
+
+:- pragma foreign_proc("C",
+ try_wait_2(Semaphore::in, Res::out, IO0::di, IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
ME_Semaphore *sem;
sem = (ME_Semaphore *) Semaphore;
- MR_LOCK(&(sem->lock), ""semaphore__try_wait"");
+ MR_LOCK(&(sem->lock), ""semaphore.try_wait"");
if (sem->count > 0) {
sem->count--;
- MR_UNLOCK(&(sem->lock), ""semaphore__try_wait"");
+ MR_UNLOCK(&(sem->lock), ""semaphore.try_wait"");
Res = 0;
} else {
- MR_UNLOCK(&(sem->lock), ""semaphore__try_wait"");
+ MR_UNLOCK(&(sem->lock), ""semaphore.try_wait"");
Res = 1;
}
IO = IO0;
-}").
+").
+
:- pragma foreign_proc("C#",
- try_wait0(Semaphore::in, Res::out, _IO0::di, _IO::uo),
- [will_not_call_mercury, thread_safe, promise_pure], "{
+ try_wait_2(Semaphore::in, Res::out, _IO0::di, _IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
if (System.Threading.Monitor.TryEnter(Semaphore)) {
if (Semaphore.count > 0) {
Semaphore.count--;
@@ -297,4 +326,7 @@
} else {
Res = 1;
}
-}").
+").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: spawn.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/concurrency/spawn.m,v
retrieving revision 1.13
diff -u -b -r1.13 spawn.m
--- spawn.m 30 Jul 2004 15:01:12 -0000 1.13
+++ spawn.m 20 Apr 2006 03:49:28 -0000
@@ -1,43 +1,52 @@
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
% Copyright (C) 2000-2001,2003-2004 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
%
-% Main author: conway
+% File: spawn.m.
+% Main author: conway.
% Stability: medium.
%
% This module provides `spawn/3' which is the primitive for starting the
-% concurrent execution of a goal. The term `concurrent' here is refering
+% concurrent execution of a goal. The term `concurrent' here is referring
% to threads, not parallel execution, though the latter is possible by
% compiling in one of the *.par grades (e.g. asm_fast.gc.par or hlc.gc.par).
%
-%---------------------------------------------------------------------------%
-:- module spawn.
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+:- module spawn.
:- interface.
:- import_module io.
+%-----------------------------------------------------------------------------%
+
% spawn(Closure, IO0, IO) is true iff IO0 denotes a list of I/O
% transactions that is an interleaving of those performed by `Closure'
% and those contained in IO - the list of transactions performed by
% the continuation of spawn.
-:- pred spawn(pred(io__state, io__state), io__state, io__state).
+ %
+:- pred spawn(pred(io, io), io, io).
:- mode spawn(pred(di, uo) is cc_multi, di, uo) is cc_multi.
% yield(IO0, IO) is logically equivalent to (IO = IO0) but
% operationally, yields the mercury engine to some other thread
% if one exists.
- % This is not yet implemented in the hlc.par.gc grade.
-:- pred yield(io__state, io__state).
-:- mode yield(di, uo) is det.
+ %
+ % NOTE: this is not yet implemented in the hlc.par.gc grade.
+ %
+:- pred yield(io::di, io::uo) is det.
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
:- implementation.
-:- pragma c_header_code("
+:- pragma foreign_decl("C", "
#if defined(MR_HIGHLEVEL_CODE) && !defined(MR_THREAD_SAFE)
#error The spawn module requires either hlc.par.gc grade or a non-hlc grade.
#endif
@@ -46,8 +55,10 @@
").
:- pragma no_inline(spawn/3).
-:- pragma c_code(spawn(Goal::(pred(di, uo) is cc_multi), IO0::di, IO::uo),
- [will_not_call_mercury, thread_safe], "{
+:- pragma foreign_proc("C",
+ spawn(Goal::(pred(di, uo) is cc_multi), IO0::di, IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
#ifndef MR_HIGHLEVEL_CODE
MR_Context *ctxt;
ctxt = MR_create_context(""spawn"", NULL);
@@ -68,10 +79,12 @@
ME_create_thread(ME_thread_wrapper, (void *) Goal);
#endif
IO = IO0;
-}").
+").
+
:- pragma foreign_proc("C#",
spawn(Goal::(pred(di, uo) is cc_multi), _IO0::di, _IO::uo),
- [will_not_call_mercury, thread_safe, promise_pure], "{
+ [promise_pure, will_not_call_mercury, thread_safe],
+"{
System.Threading.Thread t;
MercuryThread mt = new MercuryThread(Goal);
@@ -81,8 +94,9 @@
}").
:- pragma no_inline(yield/2).
-:- pragma c_code(yield(IO0::di, IO::uo),
- [will_not_call_mercury, thread_safe], "{
+:- pragma foreign_proc("C",
+ yield(IO0::di, IO::uo),
+ [promise_pure, will_not_call_mercury, thread_safe], "{
/* yield() */
#ifndef MR_HIGHLEVEL_CODE
MR_save_context(MR_ENGINE(MR_eng_this_context));
@@ -95,17 +109,18 @@
IO = IO0;
}").
-yield --> [].
-:- pred call_back_to_mercury(pred(io__state, io__state), io__state, io__state).
+yield(!IO).
+
+:- pred call_back_to_mercury(pred(io, io), io, io).
:- mode call_back_to_mercury(pred(di, uo) is cc_multi, di, uo) is cc_multi.
:- pragma export(call_back_to_mercury(pred(di, uo) is cc_multi, di, uo),
"call_back_to_mercury_cc_multi").
-call_back_to_mercury(Goal) -->
- call(Goal).
+call_back_to_mercury(Goal, !IO) :-
+ Goal(!IO).
-:- pragma c_header_code("
+:- pragma foreign_decl("C", "
#ifdef MR_HIGHLEVEL_CODE
#include <pthread.h>
@@ -114,7 +129,7 @@
#endif
").
-:- pragma c_code("
+:- pragma foreign_code("C", "
#ifdef MR_HIGHLEVEL_CODE
int ME_create_thread(void *(*func)(void *), void *arg)
{
@@ -156,3 +171,6 @@
}
}
").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: stream.m
===================================================================
RCS file: /home/mercury1/repository/mercury/extras/concurrency/stream.m,v
retrieving revision 1.1
diff -u -b -r1.1 stream.m
--- stream.m 29 Feb 2000 22:37:15 -0000 1.1
+++ stream.m 20 Apr 2006 04:50:09 -0000
@@ -1,59 +1,71 @@
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
% Copyright (C) 2000 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
-%---------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
%
-% Main author: conway
+% File: stream.m.
+% Main author: conway.
% Stability: medium.
%
% This module implements a simple concurrent data-stream.
%
-%---------------------------------------------------------------------------%
-:- module stream.
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+:- module stream.
:- interface.
:- import_module io.
+%-----------------------------------------------------------------------------%
+
:- type stream(T).
-:- type stream__result(T)
+:- type stream.result(T)
---> end
; error(string)
- ; ok(T)
- .
+ ; ok(T).
- % new(Stream, IO0, IO) creates a new data stream `Stream'.
-:- pred new(stream(T), io__state, io__state).
-:- mode new(out, di, uo) is det.
+ % new(Stream, !IO) creates a new data stream `Stream'.
+ %
+:- pred new(stream(T)::out, io::di, io::uo) is det.
- % get(Stream, Result, IO0, IO) blocks until a message appears
+ % get(Stream, Result, !IO) blocks until a message appears
% on the data stream `Stream'. When a message arrives, `Result' is
% bound to the value of the message.
-:- pred get(stream(T), stream__result(T), io__state, io__state).
-:- mode get(in, out, di, uo) is det.
+ %
+:- pred get(stream(T)::in, stream.result(T)::out, io::di, io::uo) is det.
- % put(Stream, Thing, IO0, IO) adds `Thing' to the end of the stream
+ % put(Stream, Thing, !IO) adds `Thing' to the end of the stream
% `Stream', waking a call to get/4 if necessary.
-:- pred put(stream(T), T, io__state, io__state).
-:- mode put(in, in, di, uo) is det.
+ %
+:- pred put(stream(T)::in, T::in, io::di, io::uo) is det.
- % end(Stream, IO0, IO) puts an end-of-stream marker on the stream
+ % end(Stream, !IO) puts an end-of-stream marker on the stream
% `Stream', waking a call to get/4 if necessary.
-:- pred end(stream(T), io__state, io__state).
-:- mode end(in, di, uo) is det.
+ %
+:- pred end(stream(T)::in, io::di, io::uo) is det.
- % error(Stream, IO0, IO) puts an error message on the stream
+ % error(Stream, !IO) puts an error message on the stream
% `Stream', waking a call to get/4 if necessary.
-:- pred error(stream(T), string, io__state, io__state).
-:- mode error(in, in, di, uo) is det.
+ %
+:- pred error(stream(T)::in, string::in, io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
-%---------------------------------------------------------------------------%
:- implementation.
-:- import_module queue, require.
-:- import_module global, semaphore.
+:- import_module global.
+:- import_module semaphore.
+
+:- import_module queue.
+:- import_module require.
+
+%-----------------------------------------------------------------------------%
:- type stream(T)
---> stream(
@@ -62,52 +74,56 @@
semaphore
).
-:- type stream0(T) == queue(stream__result(T)).
+:- type stream0(T) == queue(stream.result(T)).
-new(Stream) -->
- { queue__init(Queue) },
- new(Queue, QueueGlob),
- new(Lock), signal(Lock),
- new(Semaphore),
- { Stream = stream(Lock, QueueGlob, Semaphore) }.
-
-put(Stream, Thing) -->
- { Stream = stream(Lock, QueueGlob, Semaphore) },
- wait(Lock),
- get(QueueGlob, Queue0),
- { queue__put(Queue0, ok(Thing), Queue) },
- set(QueueGlob, Queue),
- signal(Lock),
- signal(Semaphore).
-
-end(Stream) -->
- { Stream = stream(Lock, QueueGlob, Semaphore) },
- wait(Lock),
- get(QueueGlob, Queue0),
- { queue__put(Queue0, end, Queue) },
- set(QueueGlob, Queue),
- signal(Lock),
- signal(Semaphore).
-
-error(Stream, Msg) -->
- { Stream = stream(Lock, QueueGlob, Semaphore) },
- wait(Lock),
- get(QueueGlob, Queue0),
- { queue__put(Queue0, error(Msg), Queue) },
- set(QueueGlob, Queue),
- signal(Lock),
- signal(Semaphore).
-
-get(Stream, Thing) -->
- { Stream = stream(Lock, QueueGlob, Semaphore) },
- wait(Semaphore),
- wait(Lock),
- get(QueueGlob, Queue0),
- ( { queue__get(Queue0, Thing0, Queue) } ->
- { Thing = Thing0 },
- set(QueueGlob, Queue)
+new(Stream, !IO) :-
+ queue.init(Queue),
+ new(Queue, QueueGlob, !IO),
+ new(Lock, !IO),
+ signal(Lock, !IO),
+ new(Semaphore, !IO),
+ Stream = stream(Lock, QueueGlob, Semaphore).
+
+put(Stream, Thing, !IO) :-
+ Stream = stream(Lock, QueueGlob, Semaphore),
+ wait(Lock, !IO),
+ get(QueueGlob, Queue0, !IO),
+ queue.put(Queue0, ok(Thing), Queue),
+ set(QueueGlob, Queue, !IO),
+ signal(Lock, !IO),
+ signal(Semaphore, !IO).
+
+end(Stream, !IO) :-
+ Stream = stream(Lock, QueueGlob, Semaphore),
+ wait(Lock, !IO),
+ get(QueueGlob, Queue0, !IO),
+ queue.put(Queue0, end, Queue),
+ set(QueueGlob, Queue, !IO),
+ signal(Lock, !IO),
+ signal(Semaphore, !IO).
+
+error(Stream, Msg, !IO) :-
+ Stream = stream(Lock, QueueGlob, Semaphore),
+ wait(Lock, !IO),
+ get(QueueGlob, Queue0, !IO),
+ queue.put(Queue0, error(Msg), Queue),
+ set(QueueGlob, Queue, !IO),
+ signal(Lock, !IO),
+ signal(Semaphore, !IO).
+
+get(Stream, Thing, !IO) :-
+ Stream = stream(Lock, QueueGlob, Semaphore),
+ wait(Semaphore, !IO),
+ wait(Lock, !IO),
+ get(QueueGlob, Queue0, !IO),
+ ( queue.get(Queue0, Thing0, Queue) ->
+ Thing = Thing0,
+ set(QueueGlob, Queue, !IO)
;
- { error("stream: queue and semaphore out of sync") }
+ error("stream.get/4: queue and semaphore out of sync")
),
- signal(Lock).
+ signal(Lock, !IO).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list