OpenVMS Source-Code Demos

MEM_QUE_DEMO

1000	!==============================================================================================================
	! file   : mem_que_demo_100.bas
	! author : Neil Rieck			( http://neilrieck.net/ )
	!          Waterloo, Ontario, Canada.
	! notes  : 1) platform: OpenVMS-8.4 Alpha (also works on Itanium)
	!			HP-BASIC-1.7 for OpenVMS Alpha
	!	   2) build:	bas	basic_mem_que_demo_100
	!			link	basic_mem_que_demo_100
	!	   3) this program demos these 32-bit library calls:
	!		LIB$INSQHI (Inserts queue entry at head)
	!		LIB$INSQTI (Inserts queue entry at tail)
	!		LIB$REMQHI (Removes queue entry at head)
	!		LIB$REMQTI (Removes queue entry at tail)
	!	   4) 64-bit variants end in 'Q' (can't be used with BASIC)
	!	   5) these routines began life as VAX instructions in the CISC world but became library routines
	!		in the RISC world (Alpha and Itanium)
	!	   6) this demo creates a new COMMON every time the program is run. In order to use this queue for
	!		interprocess communication it would need to be placed in a system-shared global region. Also,
	!		you might replace the COMMON (or MAP) with dynamically allocated data via LIB$GET_VM
	! history:
	! ver who when   what
	! --- --- ------ ----------------------------------------------------------------------------------------------
	! 100 NSR 151024 1. original effort
	!     NSR 151031 2. found some spare time to finish this demo
	!     NSR 151130 3. added a tiny bit of code to demo an error exit to DCL
	!==============================================================================================================
	option type=explicit							! no kid stuff
	set no prompt								!
	declare string constant k_program = "mem_que_demo_100.3"		!
	!
	%include "lib$routines" %from %library "sys$library:basic$starlet"      ! lib$
	%include "$libdef"      %from %library "sys$library:basic$starlet"      ! eg. lib$_normal
	!
	!-----------------------------------------------------------------------
	!	for this BASIC hack to work...
	!		1) we must pass the data by value
	!		2) we must receive the data by reference
	!	eg. we must lie while hoping future compliers and linkers never check the parameter list
	!
	!	This is one good reason why programmers should migrate to C/C++ which has built-in support for pointers
	!-----------------------------------------------------------------------
	external sub vr_hack(long by value)					!
	!
	!#######################################################################
	!	define a record which will represent one queue entry
	!
	! notes:
	! 0) Caveat: a declaration identical to this one must also exist in subprogram vr_hack()
	! 1) This queue entry can represent anything you want provided it begins with two longs
	! 2) For this demo I have only used BASIC variables but a real-world app would allocate dynamic memory from pool
	!    then store pointers to it
	! 3) In a real-world app the linked-list would beed to be placed in a globally shared common so it would survive
	!    after the inserting program (or retrieval program) exits
	! 4) For proper octaword alignment make sure the total size is evenly divisible by 8
	!
	record que_rec								!
	    long   fwd_link							! forward link		4	4
	    long   bwd_link							! backward link		4	8
	    long   payload_in_use						! 0=free, 1=busy	4	12
	    long   payload_phase						! whatever		4	16
	    string payload_msg	= 20						! whatever		20	36
	    string padding	= 4						!			4	40
	end record								! note: 40/8 = 5.0
	!
	common (retreval)							!				&
	    que_rec	one_entry						! need this for retrieval
	!#######################################################################
	!
	!	because everthing in my programs is properly declared,
	!	I need this little doohickey to satisfy compiler type-checking
	!
	record twoway								! a type-casting tool
	    variant								!
		case								!
		    group one							!
			basic$quadword	my$bqw					! basic quad word (system calls)
		    end group							!
		case								!
		    group two							!
			quad		my$quad					! basic language
		    end group							!
		case								!
		    group three							!
			long		my$long0				!
			long		my$long1				!
		    end group							!
	    end variant								!
	end record								!
	!
	common (dllqueue)							! doubly linked list		&
	    twoway	qheader(0)			,			! need 1 item (0..0)		&
	    long	my$address						!
	!
	declare long constant qentry_max = 99					!
	common (fakedata)							!				&
	    que_rec	qentry(qentry_max)					! need 100 items (0..99)	&
	!
	declare	long	rc		,					&
			i		,					&
			j		,					&
			temp_last	,					&
			baserr		,					&
			phase		,					&
			phase_first	,					&
			phase_last	,					&
			yada		,					&
			junk		,					&
			choice		,					&
		string	d$		,					&
			temp$		,					&
			msg$		,					&
			misc$
	declare long constant temp_max = 26					! stuff to read from DATA
	declare string  temp$(temp_max)						!
	!
	!=======================================================================
	!	main
	!=======================================================================
	main:
	print
	print "-i-pgm: "+ k_program
	print "-i-menu:"
	print "   1 = HEAD INSERT ONLY"
	print "   2 = TAIL INSERT ONLY"
	print "   3 = HEAD then TAIL"
	when error in
	    input "-i-choice? (1-3, default=1) ";junk
	    choice = integer(junk)
	use
	    choice = 0								! oops
	end when
	select choice								!
	    case 3								!
		phase_first = 1							!
		phase_last  = 2							!
	    case 2								!
		phase_first = 2							!
		phase_last  = 2							!
	    case else								! default to choice 1
		phase_first = 1							!
		phase_last  = 1							!
		choice = 1
	end select
	!
	print
	print "-i-populating temp data array with test data (choice:";choice;")"
	when error in								!
	    temp_last = 0							!
	    while 1								!
		read d$								!
		temp_last = temp_last + 1					!
		temp$(temp_last) = d$						!
	    next								!
	use									!
	   baserr = err								!
	end when								!
	select baserr								!
	    case 57								! ?Out of data
		print "-i-read:";temp_last;"static test items"			!
	    case else								!
		print "-e-error:";baserr;"during data read"			!
	end select								!
	!
	!	now pass the test data to the dll-queue
	!
	phase = phase_first							!
	insert_loop:
	print "-i-storing in dll-queue (phase:";phase;")"
	for i = 1 to temp_last				! grab some test data
	    msg$ = temp$(i)				! grab some data to process
	    print "-i-insert: "+msg$
	    for j = 0 to qentry_max						! look for an empty spot to store the data
		!
		!	caveat: this method is not 'thread safe' (but this is just a demo)
		!
		if  qentry(j)::payload_in_use = 0 then				! if this entry is available
		    qentry(j)::payload_in_use = 1				! then mark it otherwise
		    qentry(j)::payload_phase  = phase				! just some data
		    qentry(j)::payload_msg    = msg$				! just some data
		    if phase = 1 then						!
			misc$ = "insqhi"					! HEAD INSERT
			rc = lib$insqhi ( qentry(j)::fwd_link, qheader(0)::my$bqw )
		    else							!
			misc$ = "insqti"					! TAIL INSERT
			rc = lib$insqti ( qentry(j)::fwd_link, qheader(0)::my$bqw )
		    end if							!
		    if (rc and 7%)<>1% then					! should never encounter an error here
			print "-e-lib$";misc$;"-status:";rc			!
			goto rc_fini						!
		    else							!
			print "-i-lib$";misc$;"-status:";rc	if rc <> 1	!
		    end if							!
		    goto insert_done						!
		end if								!
	    next j								!
	    insert_done:							!
	next i									!
	!
	!	optionally do another insert
	!
	if phase < phase_last then						!
	   phase = phase + 1							!
	   goto insert_loop 							!
	end if									!
	!
	!	now read the test data by dequeuing
	!
	print
	print "-i-reading queue (from tail)"
	sleep 2
	junk = 0
	while 1									!
	    rc = lib$remqti ( qheader(0)::my$bqw by ref, my$address by ref )	!
	    select rc								!
		case lib$_quewasemp						! not sure why this is an error
		    goto fini							!
		case else							!
		    if (rc and 7%)<>1% then					!
			print "-e-lib$remqti-status:";rc			!
			goto rc_fini						!
		    end if							!
	    end select								!
	    junk = junk + 1
	    print "-------------------"
	    print "data: item count   :";junk
	    call vr_hack(my$address by value)					! pass address by value
	    !
	    !	vr_hack() will have populated these varibles
	    !
	    print "data: payload phase:"; one_entry::payload_phase
	    print "data: payload msg  : "; one_entry::payload_msg
	next
	goto fini								! this will never be used
	!
20000	DATA "Apple","BSD","Chip","Dynamic"
	!
	!	note: rc must be set before this point
	!
31000	rc_fini:								!
	print "-e-using error exit"						!
	goto common_fini							!
	!
32000	fini:									!
	print "-i-using normal exit"						!
	rc = 1									! VMS-S
	!
	common_fini:								!
    %let %exitcode=1								! 0=simple exit; 1=fancy exit
    %if  %exitcode=0 %then							! simple exit
	print "-i-program exiting with code:";rc				!
    %else									! fancy exit
	!						 01234567
	declare string constant k_error_prefixes =	"wseif???"		! warn, success, error, info, fatal
	print "-";mid$(k_error_prefixes,(rc and 7%)+1,1);"-";"program exiting with code:";rc
    %end %if
	end program rc								! rc becomes $STATUS in DCL
	!=======================================================================
	! vr_hack()
	!	for this BASIC hack to work...
	!		1) we must pass the data by value
	!		2) we must receive the data by reference
	!	eg. we must lie while hoping future compliers and linkers never check the parameter list
	!	This is one good example why programmers should migrate to C/C++
	!=======================================================================
32100	sub vr_hack(que_rec temp by ref)					!
	!
	! 0) Caveat: a declaration identical to this one must also exist in main
	! 1) This queue entry can represent anything you want provided it begins with two longs
	! 2) For this demo I have only used BASIC variables but a real-world app would allocate dynamic memory from pool
	!    then store pointers to it
	! 3) In a real-world app the linked-list would beed to be placed in a globally shared common so it would survive
	!    after the inserting program (or retrieval program) exits
	! 4) For proper octaword alignment make sure the total size is evenly divisible by 8
	!
	record que_rec								!
	    long   fwd_link							! forward link		4	4
	    long   bwd_link							! backward link		4	8
	    long   payload_in_use						! 0=free, 1=busy	4	12
	    long   payload_phase						! whatever		4	16
	    string payload_msg	= 20						! whatever		20	36
	    string padding	= 4						!			4	40
	end record								! note: 40/8 = 5.0
	!
	common (retreval)							!				&
	    que_rec	one_entry						! need this for retrieval
	!------------------------------------------------------------------------
	!
	!	copy data back to main
	!
	one_entry::payload_in_use	= temp::payload_in_use
	one_entry::payload_phase	= temp::payload_phase
	one_entry::payload_msg		= temp::payload_msg
	one_entry::fwd_link		= temp::fwd_link
	one_entry::bwd_link		= temp::bwd_link
	!
	!	prep for future use in this demo
	!	note:	In real world usage the data package would not have been placed in either a COMMON or MAP
	!		It would have been created via LIB$GET_VM so we would be calling LIB$FREE_VM at this point
	!
	temp::fwd_link			= 0
	temp::bwd_link			= 0
	temp::payload_in_use		= 0					! do this last
	!------------------------------------------------------------------------
	end sub