OpenVMS Source Code Demos
BASIC_PEEK_DEMO
1024 %title "BASIC-PEEK-DEMO" ! never change this line number :-)
%ident "105.3" !
declare string constant k_version = "105.3" , ! &
k_program = "BASIC-PEEK-DEMO" !
!========================================================================================================================
! Title : DEC-BASIC-Peek_Demo_xxx.bas
! Author : Neil Rieck (Waterloo, Ontario, Canada)
! : (https://neilrieck.net) (mailto:n.rieck@bell.net)
! Notes : 1) This program allows DEC-BASIC to peek at a memory location in a way similar to DEC-C
! (the difference being that DEC-C can do it without the creation of an external function)
! 2) Compile this program with cli switches "/list/machine" then look for the BASIC line numbers
! converted to hex
! History:
! ver who when what
! --- --- ------ --------------------------------------------------------------------------------------------------------
! 100 NSR 001022 1. original program
! 101 NSR 070629 1. cleanup for publishing to public domain
! 102 NSR 110409 1. added three dump routines
! 2. added a demo for a fixed string array
! NSR 110410 3. added a demo for variable string arrays
! 103 NSR 130105 1. another cleanup
! 104 NSR 141001 1. added a few lines of code to foil compiler optimization
! 105 NSR 170520 1. added code to peek at a 2-dimension array (created at run-time)
! NSR 170521 2. added code to peek at 1 and 3 dimension arrays (created at run-time)
! 3. wrote a function to peek at an array descriptor (DSC$K_CLASS_NCA)
!========================================================================================================================
! 32-bit Descriptor Prototype (from dump of sys$library:BASIC$STARLET.TLB)
!
! Each class of 32-bit descriptor consists of at least 2 longwords in the following format:
!
! +-------+-------+---------------+
! | CLASS | DTYPE | LENGTH | :Descriptor
! +-------+-------+---------------+
! | POINTER |
! +-------------------------------+
!
! DSC$W_LENGTH A one-word field specific to the descriptor
! <0,15:0> class/* typically a 16-bit (unsigned) length.
!
! DSC$B_DTYPE A one-byte atomic data type code
! <0,23:16>
!
! DSC$B_CLASS A one-byte descriptor class code (see below)
! <0,31:24>
!
! DSC$A_POINTER A longword pointing to the first byte of the
! <1,31:0> data element described.
!========================================================================================================================
! Enabling either "when error use" or "on error" trapping (and including any BASIC code which references ERL)
! has been known to add more code, and therefore, more human-readable references to the machine code listings.
! Disabling compiler optimization will stop the compiler from unrolling loops (and other stuff) as well as
! leaving target labels in the machine code listings.
! Try any one of these commands just for fun:
! bas/list/machine/nooptim BASIC-PEEK-DEMO_105
! bas/list/machine/optim=level=0 BASIC-PEEK-DEMO_105
! bas/list/machine/optim=level=0/cross/show=all BASIC-PEEK-DEMO_105
! then inspect file BASIC-PEEK-DEMO_105.lis
!========================================================================================================================
option type=explicit ! no kid stuff
set no prompt ! no '?' after input prompt
%include "starlet" %from %library "sys$library:basic$starlet" ! system services (and basic$quadword)
%include "$dscdef" %from %library "sys$library:basic$starlet" ! mostly descriptor constants
%include "$iledef" %from %library "sys$library:basic$starlet" ! Item List Entry structures
!
on error goto my_error_trap !
!
! note: for this little trick to work, we must...
!
! 1. declare LONG BY VALUE passing mechanisms here (we are passing 32-bit addresses)
! 2. declare BY REF passing mechanisms in the receiving functions
!
external long function my_peek_L( long by value ) !
external word function my_peek_W( long by value ) !
external byte function my_peek_B( long by value ) !
external basic$quadword function my_peek_Q( long by value ) !
external long function my_loc( any by ref ) !
external DSCDEF6 function my_array_details (any by desc ) !
!
external sub dump_long(long , long ) !
external sub dump_word(long , long ) !
external sub dump_byte(long , long , long) !
!
declare long i% , &
ptr1 , &
ptr2 , &
length , &
temp , &
test123 , &
last_subscr , &
x ,y ,z , &
x2,y2,z2 , &
subtest , &
junk , &
string dynamic_str$ , &
junk$ , &
default$ !
map(m1)string mapped_str$ = 10 ! a little larger than required
map(m2)long mapped_long% !
!
! support for: fixed-string array
! variable string array
!
! note: 1) the BASIC view of how these arrays are data-filled, then referenced, appears identical
! but the binary code behind it is totally different. For example, a mapped string produces
! a descriptor. Some people assume (falsely) that a mapped long will produce a long
! descriptor.
! 2) you may wish to compile with switches "/list/machine" for more information
!
declare long constant k_max_subscr = 2 !
declare long constant k_max_size = 5 !
!
map(m3)string fs_array$(k_max_subscr) = k_max_size ! fixed string array; subscripts 0->k_max_subscr
!
! This array is built at compile-time. The Alpha-BASIC compiler "knows" boundary limits (because
! I used a constant) and will simulate appropriate conditions when an array boundary is exceeded.
!
dim string vs_array_ct$(k_max_subscr) ! variable string array; subscripts 0->k_max_subscr
!
!=======================================================================
! main
!=======================================================================
2048 main:
print k_program +"_"+ k_version !
print string$(len(k_program +"_"+ k_version), asc("=")) ! what will the optimizer do with this?
!
!-----------------------------------------------------------------------
! initialize test data (for most tests)
!-----------------------------------------------------------------------
print "-i-initializing test data" !
test123 = 123% ! stand-alone long
mapped_long% = 124% ! mapped long
dynamic_str$ = "HELLO" !
!
for i% = 0 to k_max_subscr !
fs_array$(i%) = "FS"+str$(i%) ! fixed string array
vs_array_ct$(i%) = "VSC"+str$(i%) ! variable string compile-time
next i% !
!
! This array is built at run-time and behaves the way you would expect
! The whole purpose of this code is to do something the compiler can't ever optimize
!
yada0: ! find this label in machine code listing
when error in !
Print "-i-run-time array init" !
print "last subscript? (enter any number between 2 and 5) ";!
input last_subscr !
use !
last_subscr = 0 !
end when !
select last_subscr !
case 2 to 99 !
case else !
last_subscr = 2 !
end select !
print "-i-last subscript will be: "+ str$(last_subscr) !
yada1: ! find this label in machine code listing
dim string vs_array_rt$(last_subscr) ! create array at run time
yada2: ! find this label in machine code listing
!
! now load the array with data
!
print "initializing test data (continue)" !
for i% = 0 to last_subscr !
vs_array_rt$(i%) = "VSR"+str$(i%) ! variable string run-time
next i% !
!-----------------------------------------------------------------------
! example #1 (LONG INTEGER)
!-----------------------------------------------------------------------
4096 test1:
print
print "-i-Test-1 "+ string$(65,asc("#")) !
print "Long Integer=";test123 !
ptr1 = loc( test123 ) ! ptr1 is a pointer to a long integer
print "addr ="; ptr1 ! display the address
call dump_byte(ptr1, 4, 0) ! 4-bytes (32-bit long)
print "hack="; my_peek_L( loc(test123) ) !
print "-i-end of hack 1. Hit <enter>"; !
input junk$ !
!-----------------------------------------------------------------------
! example #1b (MAPPED INTEGER)
!-----------------------------------------------------------------------
test1b:
print
print "-i-Test-1b" !
print "Mapped Integer=";mapped_long% !
ptr1 = loc( mapped_long% ) ! ptr1
print "addr ="; ptr1 ! display the address
call dump_byte(ptr1, 4, 0) ! 4-bytes (32-bit long)
print "hack="; my_peek_L( loc(mapped_long%) ) !
print "-i-end of hack 1b. Hit <enter>"; !
input junk$ !
!-----------------------------------------------------------------------
! example #2 (DYNAMIC STRING)
!-----------------------------------------------------------------------
8192 test2:
print !
print "-i-Test-2 "+ string$(65,asc("#")) !
print "Dynamic String=";dynamic_str$ !
ptr1 = loc( dynamic_str$ ) ! ptr1 is a pointer to string descriptor
print "addr "; ptr1 ! display the descriptor address
call dump_word(ptr1 , 1) !
call dump_byte(ptr1+2, 2, 0) !
call dump_long(ptr1+4, 1) !
print "a=(length ) "; my_peek_W( ptr1 ) ! DATA LENGTH
print "b=(type ) "; my_peek_B( ptr1+2 ) ! DESCRIPTOR TYPE
print "c=(class ) "; my_peek_B( ptr1+3 ) ! DESCRIPTOR CLASS
print "d=(address) "; my_peek_L( ptr1+4 ) ! DATA ADDRESS
!
ptr2 = my_peek_L( ptr1+4 ) ! get the address (again)
length = my_peek_W( ptr1 ) ! get the LENGTH (again)
call dump_byte(ptr2, length, 1) !
print "-i-end of hack 2. Hit <enter>"; !
input junk$ !
!-----------------------------------------------------------------------
! example #3 (MAPPED STRING)
!-----------------------------------------------------------------------
16384 test3:
print
print "-i-Test-3 "+ string$(65,asc("#")) !
mapped_str$ = "GOOD BYE" !
print "Mapped String=";mapped_str$ !
print "-?-enter some text or just hit <enter> for the default"; ! -+- foil compiler optimization
input junk$ ! -+
mapped_str$ = junk$ if edit$(junk$ ,2) <> "" ! -+
ptr1 = loc( mapped_str$ ) ! ptr1 is a pointer to data
length = len( mapped_str$ ) ! be sure to check equiv machine code
print "addr "; ptr1 ! display the string address
print "length "; length ! display the string length
call dump_byte(ptr1, length, 1) !
print "-i-end of hack 3. Hit <enter>"; !
input junk$ !
!-----------------------------------------------------------------------
! example #4 (fs array)
!-----------------------------------------------------------------------
16385 test4:
print !
print "-i-Test-4 "+ string$(65,asc("#")) !
print "fs array (fixed length strings - no descriptors)"
print "array data"
for i% = 0 to k_max_subscr !
print " ";i%;" ";fs_array$(i%) !
next i% !
print "declared max size: "+ str$(k_max_size) ! be sure to check equiv machine code
print "declared max subs: "+ str$(k_max_subscr) ! be sure to check equiv machine code
ptr1 = loc( fs_array$(0) ) ! ptr1 is a pointer to string data
length = len( fs_array$(0) ) ! the compiler knew this value
print "addr-0 "; ptr1 ! display the string address
print "length "; length ! display the max string length
call dump_byte(ptr1, length, 1) !
print "-i-end of hack 4. Hit <enter>"; !
input junk$ !
!-----------------------------------------------------------------------
! example #5 (vs array)
!-----------------------------------------------------------------------
16386 test5:
print
print "-i-Test-5 "+ string$(65,asc("#")) !
print "vs array (compile-time - variable length strings - descriptors)"
print "array data" !
for i% = 0 to k_max_subscr !
print " ";i%;" ";vs_array_ct$(i%) !
next i% !
ptr1 = loc( vs_array_ct$(0) ) ! ptr1 is a pointer to string descriptor
print "addr-0 "; ptr1 ! display the descriptor address
call dump_word(ptr1 , 1 ) !
call dump_byte(ptr1+2, 2, 0) !
call dump_long(ptr1+4, 1 ) !
print "a=(length ) "; my_peek_W( ptr1 ) ! DATA LENGTH
print "b=(type ) "; my_peek_B( ptr1+2 ) ! DESCRIPTOR TYPE
print "c=(class ) "; my_peek_B( ptr1+3 ) ! DESCRIPTOR CLASS
print "d=(address) "; my_peek_L( ptr1+4 ) ! DATA ADDRESS
!
ptr2 = my_peek_L( ptr1+4 ) ! get the address (again)
length = my_peek_W( ptr1 ) ! get the LENGTH (again)
call dump_byte(ptr2, length, 1) !
print "hit <enter> to continue "; !
input junk$ !
!
ptr1 = loc( vs_array_ct$(1) ) ! ptr1 is a pointer to string descriptor
print "addr-1 "; ptr1 ! display the descriptor address
call dump_word(ptr1 , 1 ) !
call dump_byte(ptr1+2, 2, 0) !
call dump_long(ptr1+4, 1 ) !
print "a=(length ) "; my_peek_W( ptr1 ) ! DATA LENGTH
print "b=(type ) "; my_peek_B( ptr1+2 ) ! DESCRIPTOR TYPE
print "c=(class ) "; my_peek_B( ptr1+3 ) ! DESCRIPTOR CLASS
print "d=(address) "; my_peek_L( ptr1+4 ) ! DATA ADDRESS
!
ptr2 = my_peek_L( ptr1+4 ) ! get the address (again)
length = my_peek_W( ptr1 ) ! get the LENGTH (again)
call dump_byte(ptr2, length, 1) !
!
print "-i-end of hack 5. Hit <enter>"; !
input junk$ !
!-----------------------------------------------------------------------
! example #6 (vs array)
!-----------------------------------------------------------------------
record switcheroo
variant
case
group one !
basic$quadword my_quad ! unsigned quad word (system calls)
end group !
case !
group two !
word my_len !
byte my_typ !
byte my_class !
long my_addr !
end group
case
group three !
DSCDEF1 my_descriptor ! defined in $dscdef in sys$library:basic$starlet
end group !
end variant !
end record !
!
declare switcheroo my_dsc ! declare a variable to match the new record
!
16387 test6:
print
print "-i-Test-6 "+ string$(65,asc("#")) !
print "vs array (run-time - variable length strings - descriptors)"
print "array data" !
for i% = 0 to last_subscr !
print " ";i%;" ";vs_array_rt$(i%) !
next i% !
ptr1 = my_loc( vs_array_rt$() ) ! here, ptr1 is a pointer to array descriptor (maybe not)
print "addr "; ptr1 ! display the descriptor address
ptr1 = loc( vs_array_rt$(0) ) ! ptr1 is a pointer to string descriptor
print "addr-0 "; ptr1 ! display the descriptor address
call dump_word(ptr1 , 1 ) !
call dump_byte(ptr1+2, 2, 0) !
call dump_long(ptr1+4, 1 ) !
print "a=(length ) "; my_peek_W( ptr1 ) ! DATA LENGTH
print "b=(type ) "; my_peek_B( ptr1+2 ) ! DESCRIPTOR TYPE
print "c=(class ) "; my_peek_B( ptr1+3 ) ! DESCRIPTOR CLASS
print "d=(address) "; my_peek_L( ptr1+4 ) ! DATA ADDRESS
!
print
print "-i-Test-6a "+ string$(65,asc("#")) !
ptr2 = my_peek_L( ptr1+4 ) ! get the address (again)
length = my_peek_W( ptr1 ) ! get the LENGTH (again)
call dump_byte(ptr2, length, 1) !
print "hit <enter> to continue "; !
input junk$ !
!
! use a different technique to pull the next string
!
print
print "-i-Test-6b "+ string$(65,asc("#")) !
ptr1 = loc( vs_array_rt$(1) ) ! ptr1 is a pointer to string descriptor
my_dsc::my_quad = my_peek_Q( ptr1 ) ! stuff our switcheroo
ptr2 = my_dsc::my_addr !
length = my_dsc::my_len !
call dump_byte(ptr2, length, 1) !
!
! use a different technique to pull the next string
!
! note: I did this to show it is possible to write code by reverse-engineering (hacking) the STARLET library.
! But since there appears to be a tiny bug in module $dscdef in sys$library:basic$starlet the
! technique shown above in Test-6b is preferable to this one.
!
print
print "-i-Test-6c "+ string$(65,asc("#")) !
ptr1 = loc( vs_array_rt$(2) ) ! ptr1 is a pointer to string descriptor
my_dsc::my_quad = my_peek_Q( ptr1 ) ! stuff our switcheroo
ptr2 = my_dsc::DSC$A_POINTER ! using DSCDEF1
!~~~ length = my_dsc::DSC$W_LENGTH x using DSCDEF1; this should work but will not compile
length = my_dsc::DSC$W_MAXSTRLEN ! using DSCDEF1; this should not work but does
call dump_byte(ptr2, length, 1) !
!
print "-i-end of hack 6. Hit <enter>"; !
input junk$ !
!=======================================================================
! OpenVMS String Array Notes:
!
! 1) It appears that when BASIC declares a run-time array of strings with dimensions of 2x3, then OpenVMS declares a
! contiguous list of 3x4+1=13 string descriptors with the last one only containing nulls which signifies "no-more"
! 2) When you pass an array by of strings reference (I like to use "any by reference") the compiler passes the address of
! the first descriptor
! 3) Excerpt from: HP BASIC for OpenVMS Reference Manual (January 2005)
! When passing an entire array by descriptor, VAX BASIC creates a DSC$K_CLASS_A descriptor; I64 BASIC/Alpha BASIC
! creates a DSC$K_CLASS_NCA descriptor. For most BASIC applications, this is not noticeable because both the calling
! program and the called subprogram use NCA descriptors. However, a program that relies on individual descriptor
! fields may have to be modified to work with descriptors produced by I64 BASIC/Alpha BASIC. For more information
! about DSC$K_CLASS_A and DSC$K_CLASS_NCA descriptors, see the OpenVMS Calling Standard.
!
! 0 1 2 3
! +--------
! 0 | d d d d
! 1 | d d d d
! 2 | d d d d <-- demo(2,3)
! | d <-- internal end-of-list marker
!
!=======================================================================
! array of 1-dimension
!=======================================================================
test71:
print
print "-i-Test-71 "+ string$(65,asc("#")) !
subtest = 1 !
x2 = last_subscr !
sleep 1
!
test71_reentry_point: ! spaghetti zone :-)
print "-i-beginning subtest:";subtest !
select subtest !
case 1 ! only populate array on first pass
dim string array71(x2) !
for x = 0 to x2 !
array71(x) = "x:"+str$(x) !
next x !
case 2 !
array71(1) = "this is a test" ! change one location to something longer
case 3 !
x2 = 0 !
dim string array71(x2) !
case 4 !
mat array71 = nul$ !
case else !
goto test71_done
end select !
print "-i-note: declared dimensions are ";x2 !
print "-i-note: actual dimensions are ";x2+1 !
sleep 1
declare DSCDEF6 hack !
hack = my_array_details( array71() ) ! just fooling around
!~~~ ptr1 = loc( array71() ) x compiler throws: %BASIC-E-ENTARRNOT
!~~~ ptr1 = loc( array71(0)) x works on Itanium (provides addr of 1st descriptor)
ptr1 = my_loc( array71() ) ! my custom alternate (provides addr of 1st descriptor)
print "addr "; ptr1 ! display 1st descriptor address
call dump_byte(ptr1, (x2+1+1)*8, 1) ! just hacking (part 1)
print "-----------"
if subtest=1 then
junk = (x2+1+1)*8
print "----------- start of before" ! let's see about 50 bytes before
call dump_byte(ptr1-junk, junk, 1) ! just hacking (part 2)
print "----------- end of before" !
end if
!
get71_next:
print "a=(length ) "; my_peek_W( ptr1 ) ! DATA LENGTH
print "b=(type ) "; my_peek_B( ptr1+2 ) ! DESCRIPTOR TYPE
print "c=(class ) "; my_peek_B( ptr1+3 ) ! DESCRIPTOR CLASS
print "d=(address) "; my_peek_L( ptr1+4 ) ! DATA ADDRESS
my_dsc::my_quad = my_peek_Q( ptr1 ) ! stuff our switcheroo
length = my_dsc::DSC$W_MAXSTRLEN ! using DSCDEF1; this should not work but does
ptr2 = my_peek_L( ptr1+4 ) ! prep to extract
if ptr2 <> 0 then !
call dump_byte(ptr2, length, 1) !
print "-i-advancing address by 8-bytes" !
ptr1 = ptr1 + 8 ! advance 8-bytes
goto get71_next !
else
print "-i-address is null so done"
end if !
!
print string$(50,asc("-")) !
subtest = subtest + 1 !
goto test71_reentry_point !
test71_done:
!
print "-i-end of hack 71. Hit <enter>"; !
input junk$ !
!=======================================================================
! array of 2-dimensions
!=======================================================================
test72:
print
print "-i-Test-72 "+ string$(65,asc("#")) !
x2 = last_subscr !
y2 = last_subscr + 1 !
!
! BASIC traditionally declares array dimensions from zero to declared value
!
print "-i-note: declared dimensions are ";x2;"x";y2 !
print "-i-note: actual dimensions are ";x2+1;"x";y2+1 !
sleep 1
dim string array72(x2,y2) !
hack = my_array_details( array72(,) ) ! just fooling around
ptr1 = my_loc( array72(,) ) !
print "addr "; ptr1 ! display the descriptor address
for x = 0 to x2 !
for y = 0 to y2 !
array72(x, y) = "data-x:"+str$(x)+";y:"+str$(y)
next y !
next x !
!~~~ ptr1 = loc( array72(,) ) x this will not work
ptr1 = my_loc( array72(,) ) !
print "addr "; ptr1 ! display the descriptor address
call dump_byte(ptr1,(((x2+1)*(y2+1)+1)*8), 1) ! just hacking
print "------"
call dump_word(ptr1 , 1 ) !
call dump_byte(ptr1+2, 2, 0) !
call dump_long(ptr1+4, 1 ) !
print "a=(length ) "; my_peek_W( ptr1 ) ! DATA LENGTH
print "b=(type ) "; my_peek_B( ptr1+2 ) ! DESCRIPTOR TYPE
print "c=(class ) "; my_peek_B( ptr1+3 ) ! DESCRIPTOR CLASS
print "d=(address) "; my_peek_L( ptr1+4 ) ! DATA ADDRESS
print "------"
ptr2 = my_peek_L( ptr1+4 ) !
length = my_dsc::DSC$W_MAXSTRLEN ! using DSCDEF1; this should not work but does
call dump_byte(ptr2, length, 1) !
!
print "-i-end of hack 72. Hit <enter>"; !
input junk$ !
!=======================================================================
! array of 3-dimensions
!=======================================================================
test73:
print
print "-i-Test-73 "+ string$(65,asc("#")) !
x2 = last_subscr !
y2 = last_subscr + 1 !
z2 = last_subscr + 2 !
!
! BASIC traditionally declares array dimensions from zero to declared value
!
print "-i-note: declared dimensions are ";x2;"x";y2;"x";z2 !
print "-i-note: actual dimensions are ";x2+1;"x";y2+1;"x";z2+1
sleep 1
dim string array73(x2,y2,z2) !
hack = my_array_details( array73(,,) ) ! just fooling around
ptr1 = loc( array73(0,0,0) ) !
print ptr1
ptr1 = my_loc( array73(,,) ) !
print ptr1
print "addr "; ptr1 ! display the descriptor address
for x = 0 to x2 !
for y = 0 to y2 !
for z = 0 to z2 !
array73(x,y,z) = "x:"+str$(x)+";y:"+str$(y)+";z:"+str$(z)
next z
next y !
next x !
!~~~ ptr1 = loc( array73(,,) ) x this will not work
ptr1 = my_loc( array73(,,) ) !
print "addr "; ptr1 ! display the descriptor address
call dump_byte(ptr1,(((x2+1)*(y2+1)*(z2+1)+1)*8) , 1) ! just hacking
print "------"
call dump_word(ptr1 , 1 ) !
call dump_byte(ptr1+2, 2, 0) !
call dump_long(ptr1+4, 1 ) !
print "a=(length ) "; my_peek_W( ptr1 ) ! DATA LENGTH
print "b=(type ) "; my_peek_B( ptr1+2 ) ! DESCRIPTOR TYPE
print "c=(class ) "; my_peek_B( ptr1+3 ) ! DESCRIPTOR CLASS
print "d=(address) "; my_peek_L( ptr1+4 ) ! DATA ADDRESS
print "------"
ptr2 = my_peek_L( ptr1+4 ) !
length = my_dsc::DSC$W_MAXSTRLEN ! using DSCDEF1; this should not work but does
call dump_byte(ptr2, length, 1) !
!
print "-i-end of hack 73. Hit <enter>"; !
input junk$ !
!
goto fini
!-----------------------------------------------------------------------
! common error trap
!-----------------------------------------------------------------------
my_error_trap:
print
print "==============================="
print " common error trap"
print "==============================="
print "-i-error : "; err
print "-e-text : "; ert$(err)
print "-i-line : "; erl
print "-i-module: "; ern$
print "==============================="
resume fini !
!=======================================================================
! adios
!=======================================================================
31000 fini: !
print "Adios..." !
end program 1 ! VMS-s-
!#######################################################################
!
! External functions
!
!-----------------------------------------------------------------------
! peek L(ong)
!-----------------------------------------------------------------------
32000 function long my_peek_L(long incoming by ref) ! long function receives long address
option type=explicit !
my_peek_L = incoming ! exit with this value
end function !
!-----------------------------------------------------------------------
! peek W(ord)
!-----------------------------------------------------------------------
32010 function word my_peek_W(word incoming by ref) ! word function receives word address
option type=explicit !
my_peek_W = incoming ! exit with this value
end function !
!-----------------------------------------------------------------------
! peek B(yte)
!-----------------------------------------------------------------------
32020 function byte my_peek_B(byte incoming by ref) ! byte function receives byte address
option type=explicit !
my_peek_B = incoming ! exit with this value
end function !
!-----------------------------------------------------------------------
! peek Q/uadword
!-----------------------------------------------------------------------
32030 function basic$quadword my_peek_Q(basic$quadword incoming by ref) ! byte function receives quad address
option type=explicit !
%include "starlet" %from %library "sys$library:basic$starlet" ! system services (and basic$quadword)
my_peek_Q = incoming ! exit with this value
end function !
!-----------------------------------------------------------------------
! my_loc
!
! This function was needed to get around a compiler restriction with Alpha-BASIC-3.7 on OpenVMS-8.4
! I'm do not know if the restriction existed with earlier Alpha BASIC compilers
!-----------------------------------------------------------------------
32040 function long my_loc(long incoming by value) ! this function receives an address
option type=explicit !
!
my_loc = incoming ! exit with this value
end function !
!-----------------------------------------------------------------------
! my_array_details
!-----------------------------------------------------------------------
32041 function DSCDEF6 my_array_details(DSCDEF6 incoming)
option type=explicit
%include "$dscdef" %from %library "sys$library:basic$starlet" ! mostly descriptor constants
!
print "-i-DSC$L_V0 ";incoming::DSC$L_V0 ! addr
print "-i-DSC$L_S1 ";incoming::DSC$L_S1
print "-i-DSC$L_S2 ";incoming::DSC$L_S2
!
my_array_details = incoming ! pass the whole thing back
end function !
!-----------------------------------------------------------------------
! dump long data
!-----------------------------------------------------------------------
32050 sub dump_long(long ptr1, long count%) !
option type=explicit !
!
external long function my_peek_L( long by value ) !
declare long i%, temp !
print "Long Peek:" !
for i% = 0 to (count%*4 -1) step 4 !
temp = ptr1 + i% !
print using " ########## = ##########";temp;my_peek_L(temp) !
next i% !
end sub !
!-----------------------------------------------------------------------
! dump_word
!-----------------------------------------------------------------------
32060 sub dump_word(long ptr1, long count%) !
option type=explicit !
external long function my_peek_W( long by value ) !
declare long i%, temp !
print "Word Peek:" !
for i% = 0 to (count%*2 -1) step 2 !
temp = ptr1 + i% !
print using " ########## = ##########";temp;my_peek_W(temp) !
next i% !
end sub !
!-----------------------------------------------------------------------
! dump_byte (with ASCII display)
!-----------------------------------------------------------------------
32070 sub dump_byte(long ptr1, long count%, long extra%) !
option type=explicit !
external byte function my_peek_B( long by value ) !
declare long i%, temp, eightbit%, sevenbit% !
declare string a$ !
print "Byte Peek:" !
for i% = 0 to count% - 1 !
temp = ptr1 + i% !
eightbit% = my_peek_B(temp) !
if extra% = 1 then !
if eightbit% >= 128 then !
sevenbit% = eightbit% - 128 !
else !
sevenbit% = eightbit% !
end if !
select sevenbit% !
case < 32, 127 !
a$ = "." !
case else !
a$ = chr$(sevenbit%) !
end select !
a$ = " = "+ a$ !
else !
a$ = "" !
end if !
print using " ########## = ########## 'LLLLL";temp;eightbit%; a$ !
next i% !
end sub !