OpenVMS Source-Code Demos

TWO_TIMER_DEMO.BAS

1000	%title "two_timer_demo_xxx"						!
	%ident                      "version_101.1"				! <<<---+
	declare string constant k_version = "101.1"			,	! <<<---+				&
				k_program = "two_timer_demo"			!
	!=======================================================================
	! title  : timer_demo_xxx.bas
	! author : Neil Rieck ( http://www3.sympatico.ca/n.rieck/ )
	! created: 2004.01.01
	!=======================================================================
	option type = explicit							! no kid stuff...
	set no prompt								!
	!
	!	system declarations
	!
	%include "starlet"      %from %library "sys$library:basic$starlet"	! system services
	%include "$ssdef"       %from %library "sys$library:basic$starlet"	! ss$
	%include "lib$routines" %from %library "sys$library:basic$starlet"	! lib$
	!
	!	home brewed functions
	!
	external long   function get_timer_bit_vector(long)			! required for used with SYS$WFLOR
	!
	declare	long	rc%						,	! return code				&
			timer_event_flag%				,	! timer event flag			&
			timer_ef_state%					,	! timer event flag state		&
			tcp_event_flag%					,	! tcp event flag			&
			tcp_ef_state%					,	! tcp event flag state			&
			mask%						,	! required for sys$wflor		&
			junk%						,	!					&
	basic$QuadWord	DeltaQuad						! for sys$bintim etc.
	!
	!=======================================================================
	!	main
	!=======================================================================
	main:
	margin #0, 132								! width for the log file
	print k_program +"_"+ k_version						!
	print string$(len(k_program +"_"+ k_version), asc("="))			! underline (how will this optimize?)
	!
	!	<<< get some event flags for later >>>
	!
	if tcp_event_flag% = 0 then						! if not yet allocated
	    rc% = lib$get_EF( tcp_event_flag% )					! get an event flag
	    if ((rc% and 7%) <> 1) then						!
		print "lib$get_EF-1 rc: ";str$(rc%)				!
		goto rc_exit							!
	    end if								!
	end if									!
	!
	if timer_event_flag% = 0 then						! if not yet allocated
	    rc% = lib$get_EF( timer_event_flag% )				! get another event flag
	    if ((rc% and 7%) <> 1) then						!
		print "lib$get_EF-2 rc: ";str$(rc%)				!
		goto rc_exit							!
	    end if								!
	end if									!
	!
	!	<<< arm a timer to expire 'x' time from now >>>
	!
	print "-i- arming timer-1 (timer) for 10 seconds from now"		!
	declare string constant	k_delay010 = "0 00:00:10"			! set delay time 10 seconds from now
	rc% = sys$bintim(k_delay010, DeltaQuad )				! init delta time ('x' time from now)
	print "-e- sys$bintim rc: "+ str$(rc%) if ((rc% and 1%) <> 1%)		!
	rc% = sys$setimr(timer_event_flag%,DeltaQuad by ref,,,)			! now use it to schedule a wake up
	print "-e- sys$setimr rc: "+ str$(rc%) if ((rc% and 1%) <> 1%)		!
	!
	!	<<< use a second timer to simulate some sort of TCP timeout >
	!
	print "-i- arming timer-2 (fake tcp) for 20 seconds from now"		!
	declare string constant	k_delay020 = "0 00:00:20"			! set delay time 20 seconds from now
	rc% = sys$bintim(k_delay020, DeltaQuad )				! init delta time ('x' time from now)
	print "-e- sys$bintim rc: "+ str$(rc%) if ((rc% and 1%) <> 1%)		!
	rc% = sys$setimr(tcp_event_flag%,DeltaQuad by ref,,,)			! now use it to schedule a wake up
	print "-e- sys$setimr rc: "+ str$(rc%) if ((rc% and 1%) <> 1%)		!
	!
	! note: for the SYS$WFLOR call to work, both event flags must be in the same event flag cluster.
	!	The first parameter is only used to determine which event flag cluster to test.
	!	The second parameter (mask) contains bits representing event flags within that cluster
	!
	mask% =			get_timer_bit_vector(  tcp_event_flag%)		! insert vector 1 into mask
	mask% = mask% or	get_timer_bit_vector(timer_event_flag%)		! insert vector 2 into mask
	!
	!	<<< wait for either the 'TCP event flag' or the 'TIMER event flag' to change state >>>
	!
	print "-i- waiting for event flag "+ str$(tcp_event_flag%) +" or event flag "+ str$(timer_event_flag%)
	!
	rc% = sys$wflor( tcp_event_flag%, mask%)				! wait for a response from one of two flags
	print "-e- sys$waitfr rc: "+ str$(rc%) if ((rc% and 1%) <> 1%)		!
	!
	!	<<< cancel all timer requests (if any) >>>
	!
	print "-i- Calling $CanTim"						!
	rc% = sys$cantim(,)							! cancel all timer requests
	print "-e- sys$cantim rc: "+ str$(rc%) if ((rc% and 1%) <> 1%)		!
	!
	!	which event flag is set? TCP or TIMER?
	!
	rc% = sys$readEF(tcp_event_flag%, junk%)				! test TCP event flag
	select rc%								!
	    case SS$_WASCLR							!
		tcp_ef_state% = 0						!
	    case SS$_WASSET							!
		tcp_ef_state% = 1						!
	    case else								!
		print "-e- sys$readef-tcp rc: "+ str$(rc%)			!
		tcp_ef_state% = 0						!
	end select								!
	print "-i- TCP EF State  : ";str$(tcp_ef_state%)			!
	!
	rc% = sys$readEF(timer_event_flag%, junk%)				! test TIMER event flag
	select rc%								!
	    case SS$_WASCLR							!
		timer_ef_state% = 0						!
	    case SS$_WASSET							!
		timer_ef_state% = 1						!
	    case else								!
		print "-e- sys$readef-timer rc: "+ str$(rc%)			!
		timer_ef_state% = 0						!
	end select								!
	print "-i- Timer EF State: ";str$(timer_ef_state%)			!
	!
	!	at this point either the TCP-EF or the TIMER-EF should be set
	!
	if (timer_ef_state% = 1)	and					! if the TIMER-EF is set		&
	   (  tcp_ef_state% = 0)						! and the TCP-EF is clear
	then									! then something timed out
	    print "-i-the tcp event timed out (so do something)"		!
	end if									!
	!
	!	here is an alternate way to test all bits quickly
	!
	junk% = (timer_ef_state% * 2) + tcp_ef_state%				! produce a weighted number
	select junk%								!
	    case 0								!
		print "no event flags (something went wrong)"			!
	    case 1								!
		print "tcp event only (timer event cancelled)"			!
	    case 2								!
		print "timer event only (tcp timed out)"			!
	    case 3								!
		print "both timer + tcp events (this is possible)"		!
	end select								!

	!====================================================================================================
	!	<<< adios... >>>
	!====================================================================================================
	fini:
	rc% = 1									! vms -s-
 	!
	!	rc% must be set up b4 this point (and must not be changed)
	!
	rc_exit:
30000	end program rc%								!
	!#######################################################################
	!
	!	<<< external functions >>>
	!
	!======================================================================
	!	get timer bit vector
	!	(see OpenVMS system systevices documentation for "sys$wflor")
	!
	!	notes:	cluster	event flags
	!		0	00- 31
	!		1	32- 63
	!		2	64- 95
	!		3	96-127
	!======================================================================
31040	function long get_timer_bit_vector(long event_flag)
	option type = explicit
	declare long temp
	!
	select event_flag
	    case <= 31
		temp = event_flag
	    case <= 63
		temp = event_flag - 32
	    case <= 95
		temp = event_flag - 64
	    case else
		temp = event_flag -96
	end select
	!
	select temp								! this code will avoid an integer overflow
	    case 31								! need to set bit #31
!					 33222222222211111111110000000000
!					 10987654321098765432109876543210
		get_timer_bit_vector = B"10000000000000000000000000000000"L	! so return this
	    case else								!
		get_timer_bit_vector = (2% ^ temp)				! else return this
	end select
	!
	end function								! get_timer_bit_vector
	!
	!#######################################################################

Back to OpenVMS
Back to OpenVMS Demo Index
Back to Home
Neil Rieck
Kitchener - Waterloo - Cambridge, Ontario, Canada.