$include(subsys.inc)

/*****************************************************************************
*
*	MODULE NAME:	demo  (note: module name should always be the same as
*								 the source file name without the extension)
*
*	DESCRIPTION:	This is the main program module. It also contains three
*					procedures which handle various forms of screen i/o:
*				    write$read, prompt$and$wait, clear$screen
*
******************************************************************************/

demo:	DO;

$include(:rmx:inc/rmxplm.ext)
$include(:rmx:inc/common.lit)
$include(:rmx:inc/error.lit)
$include(:rmx:inc/nstexh.lit)
$include(:rmx:inc/tscrn.lit)
$include(:rmx:inc/iaiors.lit)
$include(:rmx:inc/io.lit)
$include(strng.ext)
$include(convrt.ext)

$if r_32
$else
	DECLARE	WORD_16			LITERALLY	'WORD',
			WORD_32			LITERALLY	'DWORD',
			SIZE$OF$WORD	LITERALLY	'WORD_16';
$endif

DECLARE version(*)			BYTE DATA ('program_version_number=V4.0',
									   'program_name=iRMX PL/M EXAMPLE',0);

DECLARE co$conn				CONNECTION$TOKEN,
		ci$conn				CONNECTION$TOKEN;
DECLARE read$mbx			MAILBOX$TOKEN,
		write$mbx			MAILBOX$TOKEN,
		mail$box 			MAILBOX$TOKEN,
		pool$tkn 			TOKEN;
DECLARE semaphore			SEMAPHORE$TOKEN,
		task				TASK$TOKEN,
		buff$tkn			TOKEN,
		buffer		BASED	buff$tkn	BYTE;
DECLARE	message$1(*)		BYTE DATA
							  (CR,LF,LF,
							   'Welcome to the PL/M Demo Program!',CR,LF,LF,
							   'At the prompt you will be ',
							   'given 60 seconds to hit any key.',CR,LF,
							   'If you do not hit a key ',
							   'the demo will continue anyway.',CR,LF,
							   'You may hit an ''E'' if you ',
							   'wish to exit the program.',CR,LF,LF,LF,LF),
		message$2(*)		BYTE DATA
							  (CR,LF,'Please hit a key which will be ',
							   'forwarded to task2 for processing.',CR,LF),
		message$3(*)		BYTE DATA
							  (CR,LF,LF,'This concludes the PL/M Demo Program.',
							   CR,LF,LF,
							   'This demo now exits by generating an ',
							   'internal error.',
							   CR,LF,LF,LF,LF);
DECLARE i					BYTE,
		read$flag			BOOLEAN,
		term$atts			TERMINAL$ATTRIBUTES$STRUCTURE,
		iors$tkn			IORS$TOKEN,
		a$iors		BASED	iors$tkn	A$IORS$STRUCTURE;
DECLARE status				WORD,
		units				WORD,
		actual				SIZE$OF$WORD,
		bytes$writ 			SIZE$OF$WORD;

$EJECT
/*   external procedures   */

set$exception:	PROCEDURE(except$mode) EXTERNAL;

	DECLARE except$mode		BYTE;

END set$exception;

error$check:	PROCEDURE(number,test$status) EXTERNAL;

	DECLARE number			WORD,
			test$status		WORD;

END error$check;

create$buf$pool: PROCEDURE(max_bufs, init_num_bufs, attrs, size, status_ptr) 
                 TOKEN EXTERNAL;

	DECLARE			/* Parameters */

		max_bufs        WORD,       
		init_num_bufs   WORD,       
		attrs           WORD,       
		size            SIZE$OF$WORD,       
		status_ptr      POINTER;    
		
end create$buf$pool;


task2:	PROCEDURE EXTERNAL;
END task2;


$subtitle('write$read')
/****************************************************************************
*
*   PROC NAME:		write$read
*
*	DESCRIPTION:	a function that outputs a message to the console and
*					waits for a character to be input from the keyboard
*
*	CALL:			buffer=write$read(msg$ptr,msg$size,time$limit,status$ptr);
*
*	INPUTS:			msg$ptr		a pointer to a message (series of bytes) to 
*								be output to the console
*					msg$size	a byte which contains the size of the message
*								pointed to by msg$ptr
*					time$limit	a word containing the number of clock intervals
*								you are willing to wait for a character to be
*								input
*
*	OUTPUTS:		status$ptr	a pointer to a word where the status for the
*								wait$io system call will be returned
*
*	RETURNS:		buffer		a byte which contains a character received
*								from the keyboard when this procedure is called
*								in read mode (read$flag is true)
*
*	system calls:	a$write,wait$io,a$read
*
****************************************************************************/


write$read:	PROCEDURE(msg$ptr,msg$size,time$limit,status$ptr) BYTE;

	DECLARE	msg$ptr			POINTER,
			msg$size		BYTE,
			time$limit		WORD,
			status$ptr		POINTER,
			status			WORD,
			buffer			BYTE;

	CALL rq$a$write	(co$conn, msg$ptr, msg$size, write$mbx, @status);
	CALL error$check(2000,status);
	actual=rq$wait$io (co$conn, write$mbx, INFINITE$WAIT, @status);
	CALL error$check(2010,status);

	/*   read$flag is used to keep track of any outstanding reads. read$flag
		 is equal to true if the read has been successfully completed
		 and false if the read is still outstanding.  */

	IF read$flag THEN
	DO;
		CALL rq$a$read (ci$conn, @buffer, 1, read$mbx, @status);
		CALL error$check(2020,status);
		read$flag = FALSE;
	END;
	actual=rq$wait$io (ci$conn, read$mbx, time$limit, status$ptr);
	IF status = E$OK THEN
		read$flag = TRUE;

/*	if the character received is unprintable ascii, print a question mark */
	IF (buffer < 20h) OR (buffer > 7aH) THEN
		buffer = '?';

	RETURN buffer;

END write$read;
$subtitle('prompt$and$wait')
/****************************************************************************
*
*   PROC NAME:		prompt$and$wait
*
*	DESCRIPTION:	A procedure that writes your input message to the console,
*					builds a prompt string, then calls write$read to output 
*					the string and receive a response. If it receives an 'e'
*					it exits the program. If it receives any other key it
*					returns to the caller. If it doesn't receive any key after
*					60 seconds, it also returns. 
*
*	CALL:			CALL prompt$and$wait(msg$ptr,msg$size);
*
*	INPUTS:			msg$ptr		a pointer to a message (series of bytes) to be
*								output to the console
*					msg$size	a byte which contains the size of the message
*								pointed to by msg$ptr
*
*	SYSTEM CALLS:	a$write,wait$io,exit$io$job
*
****************************************************************************/

prompt$and$wait:	PROCEDURE(msg$ptr,msg$size);

	DECLARE msg$ptr	 		POINTER,
			msg$size		BYTE,
			buffer			BYTE,
			status			WORD,
			i				INTEGER,
			local$string	STRING;
	DECLARE time$limit		LITERALLY '60',
			msg$1(*)		BYTE DATA ('You now have'),
			msg$2(*)		BYTE DATA (' seconds left to hit a key.',CR),
			msg$3(*)		BYTE DATA (LF,'You chose not to hit a ',
									   'key.  We will now continue.',CR,LF);
											
	CALL rq$a$write	(co$conn, msg$ptr, msg$size, write$mbx, @status);
	CALL error$check(1000,status);
	actual=rq$wait$io (co$conn, write$mbx, INFINITE$WAIT, @status);
	CALL error$check(1010,status);

	DO i = time$limit TO 1 BY -1;
		local$string.length = 0;
		CALL concatenate$to$string(@local$string,size(local$string.char),
								   @msg$1,size(msg$1),@status);
		CALL error$check(1020,status);
		CALL convert$decimal(@local$string,size(local$string.char),unsign(i),
							 3,@status);
		CALL error$check(1030,status);
		CALL concatenate$to$string(@local$string,size(local$string.char),
								   @msg$2,size(msg$2),@status);
		CALL error$check(1040,status);
		buffer=write$read(@local$string.char,local$string.length,100,@status);
		IF status = E$OK THEN
		DO;
			IF (actual = 1) AND ((buffer = 'E') OR (buffer = 'e')) THEN
			DO;
				CALL clear$screen;
				CALL rq$exit$io$job (E$OK, NIL, @status);
			END;
			RETURN;
		END;
		IF status <> E$TIME THEN
			CALL error$check(1050,status);
	END;
	CALL rq$a$write (co$conn, @msg$3, size(msg$3), write$mbx, @status);
	CALL error$check(1060,status);
	actual = rq$wait$io (co$conn, write$mbx, INFINITE$WAIT, @status);
	CALL error$check(1070,status);
	
END prompt$and$wait;
$subtitle('clear$screen')
/****************************************************************************
*
*   PROC NAME:		clear$screen
*
*	DESCRIPTION:	A 'quick and dirty' way to clear the screen by sending
*					25 carriage returns and linefeeds to the console. This
*					can be accomplished with more sophisticated coding by
*					using :config:termcap or knowing exactly what model 
*					terminal you will be outputting to.
*
*	CALL:			CALL clear$screen
*
*	SYSTEM CALLS:	c$send$eo$response
*
****************************************************************************/

clear$screen:	PROCEDURE;

	DECLARE i 				WORD,
			cr$lf$str(*)	BYTE DATA (2,CR,LF);
	
			  
	DO i = 1 to 25;
		CALL rq$c$send$eo$response (NIL, 0,	@cr$lf$str, @status);
	END;

END clear$screen;


$subtitle('main program code')
/****************************************************************************
*
*	The main program does not actually 'do' anything. However it does serve
*	an important function. The code shown here demonstrates a number of
*	useful concepts and illustrates the proper use of many iRMX system
*	calls. 
*
****************************************************************************/


CALL set$exception(NO$EXCEPTIONS);

co$conn=rq$s$create$file (@(4,':CO:'),
						  @status);
CALL error$check(100,status);
ci$conn=rq$s$attach$file (@(4,':CI:'),
						  @status);
CALL error$check(110,status);
CALL rq$s$open (co$conn, WRITE$ONLY, 0,	@status);
CALL error$check(120,status);
CALL rq$s$open (ci$conn, READ$ONLY,	0, @status);
CALL error$check(130,status);
write$mbx=rq$create$mailbox (FIFO$QUEUING, @status);
CALL error$check(140,status);
read$mbx=rq$create$mailbox (FIFO$QUEUING, @status);
CALL error$check(150,status);

/*	Set term$atts.num$words	before trying to get term$atts. To get all 
    attributes set term$atts.num$words equal to size(term$atts)/2 - 2. */

term$atts.num$words = 1;
CALL rq$a$special (ci$conn, SPECIAL$GET$TERM$DATA, @term$atts, read$mbx,
				   @status);
CALL error$check(160,status);
iors$tkn=rq$receive$message (read$mbx, INFINITE$WAIT, NIL, @status);
CALL error$check(170,status);
CALL error$check(180,a$iors.status);
CALL rq$delete$segment (iors$tkn, @status);
CALL error$check(190,status);

/* 		Set the terminal attributes to accept one character from the key-
		board and turn echo off.  */
			   
term$atts.connection$flags = ((term$atts.connection$flags AND
							  (NOT C$MASK$LINE$EDIT)) OR 1) OR 
							  C$MASK$ECHO;
CALL RQ$S$SPECIAL (ci$conn, SPECIAL$SET$TERM$DATA, @term$atts, NIL, @status);
CALL error$check(200,status);
read$flag = TRUE;
CALL clear$screen;

CALL rq$c$send$co$response(NIL,0,@(25,'iRMX PL/M Example, V4.0',CR,LF),@status);
CALL prompt$and$wait(@message$1,SIZE(message$1));
mailbox = rq$create$mailbox (FIFO$QUEUING, @status);
CALL error$check(210,status);

CALL rq$catalog$object (CALLER,	mail$box, @(3,'MBX'), @status);
CALL error$check(220,status);
semaphore = rq$create$semaphore (0, 3, FIFO$QUEUING, @status);
CALL error$check(230,status);
CALL rq$catalog$object (CALLER,	semaphore, @(9,'SEMAPHORE'), @status);
CALL error$check(240,status);
pool$tkn = create$buf$pool(18,18,0,SIZE(buffer),@status);
CALL error$check(250,status);
CALL rq$catalog$object (CALLER,	pool$tkn, @(6,'BUFFER'), @status);
CALL error$check(260,status);

/*            By including the line $compact(exports task2) in the subsys.inc
			  file, task2 is forced to be compiled as compact model and
			  it therefore creates its own data segment. It also prevents
			  us from getting a warning when we use @task2 as the pointer
			  to the starting address for the new task.					  */

task = rq$create$task ((rq$get$priority (CALLER,@status) - 1), @task2,
					   selector$of(NIL), NIL, 1024, 0, @status);
CALL error$check(270,status);
CALL rq$catalog$object (CALLER,	task, @(5,'TASK2'),	@status);
CALL error$check(280,status);
CALL clear$screen;
DO i = 1 to 3;
	buff$tkn = rq$request$buffer(pool$tkn,size(buffer),@status);
	CALL error$check(290,status);
	buffer = write$read(@message$2,SIZE(message$2),INFINITE$WAIT,@status);
	CALL error$check(300,status);

/* 			  A semaphore is being passed as
			  the exchange to which the response should be sent.		 */

	CALL rq$send$message (mail$box, buff$tkn, semaphore, @status);
	CALL error$check(310,status);
END;

/*	 Now wait for three responses to ensure that the other task has 
     processed the data.		*/

units = rq$receive$units (semaphore, 3, INFINITE$WAIT, @status);
CALL error$check(320,status);
bytes$writ = rq$s$write$move (co$conn, @message$3, size(message$3), @status);
CALL error$check(330,status);								 			  

/*   This call was purposely coded with an error to show you how the 
	 error$check routine actually works. Your error is reported on the console
	 with the information needed to know what error occurred and exactly
	 which line in your program was responsible for the error. All
	 further processing of your program is then terminated.	   */

CALL error$check(340,E$SUPPORT);

END demo;