OpenVMS Source Code Demos
MEM_QUE_DEMO
1000 !==============================================================================================================
! file : mem_que_demo_100.bas
! author : Neil Rieck ( https://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 compilers 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 ! unsigned quad word (system calls)
end group !
case !
group two !
quad my$quad ! signed quad word (native basic)
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 compilers 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