Back
to OpenVMS
Back
to HomeNeil Rieck
Kitchener - Waterloo - Cambridge, Ontario, Canada.
1024 %title "BASIC-PEEK-DEMO" !
%ident "102.1" !
declare string constant k_version = "102.3" , ! &
k_program = "BASIC-PEEK-DEMO" !
!========================================================================================================================
! Title : DEC-BASIC-Peek_Demo_xxx.bas
! Author : Neil Rieck (Kitchener/Waterloo/Cambridge, Ontario, Canada)
! : (http://www3.sympatico.ca/n.rieck) (mailto:n.rieck@sympatico.ca)
! Notes : 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)
! 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
!========================================================================================================================
! 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.
!========================================================================================================================
option type=explicit ! no kid stuff
set no prompt !
my_init: !
!
! Including any BASIC code which employs ERL or RESUME will enforce complier switch "/LINES". This has been
! known to add more human-readable references to the machine code listings. Disabling complier 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_102
! bas/list/machine/optim=level=0 BASIC-PEEK-DEMO_102
! bas/list/machine/optim=level=0/cross/show=all BASIC-PEEK-DEMO_102
! then inspect file BASIC-PEEK-DEMO_102.lis
!
on error goto my_error_trap !
%include "starlet" %from %library "sys$library:basic$starlet" ! system services (and basic$quadword)
!
! 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 ) ! peek long
external word function my_peek_W( long by value ) ! peek word
external byte function my_peek_B( long by value ) ! peek byte
external basic$quadword function my_peek_Q( long by value ) ! peek quad
external long function my_loc( any by ref ) ! experimental
!
external sub dump_long(long , long ) !
external sub dump_word(long , long ) !
external sub dump_byte(long , long , long) !
!
declare long i% , &
ptr% , &
ptr2% , &
length% , &
temp% , &
test% , &
max_subs_rt% , &
string dynamic_str$ , &
junk$
map(xyz)string mapped_str$ = 10 ! a little larger than required
!
! 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
! 2) you may wish to complile with switches "/list/machine" for more information
!
declare long constant k_max_subs = 2 !
declare long constant k_max_size = 5 !
!
map(abc)string fs_array$(k_max_subs) = k_max_size ! fixed string array; subscripts 0->k_max_subs
!
! This array is built at compile-time. The Alpha-BASIC compiler "knows" boundary limits and will
! simulate appropriate conditions when an aaray boundary is exceeded.
!
dim string vs_array_ct$(k_max_subs) ! variable string array; subscripts 0->k_max_subs
!
!=======================================================================
! 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
!-----------------------------------------------------------------------
print "initializing test data" !
test% = 123% !
dynamic_str$ = "HELLO" !
mapped_str$ = "GOOD BYE" !
!
for i% = 0 to k_max_subs !
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 "run-time array init" !
print "subscripts? (enter any number between 2 and 5) "; !
input max_subs_rt% !
use !
max_subs_rt% = 0 !
end when !
select max_subs_rt% !
case 2 to 99 !
case else !
max_subs_rt% = 2 !
end select !
print "-i- last subscript will be: "+ str$(max_subs_rt%) !
yada1: ! find this label in machine code listing
dim string vs_array_rt$(max_subs_rt%) ! 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 max_subs_rt% !
vs_array_rt$(i%) = "VSR"+str$(i%) ! variable string run-time
next i% !
!-----------------------------------------------------------------------
! example #1 (LONG INTEGER)
!-----------------------------------------------------------------------
4096 test1:
print
print "-i-Test-1" !
print "Long Integer=";test% !
ptr% = loc( test% ) ! ptr% is a pointer to a long integer
print "addr ="; ptr% ! display the address
call dump_byte(ptr%, 4, 0) !
print "hack="; my_peek_L( loc(test%) ) ! this is a functional alternative to '1-data-a'
print "-i-end of hack 1. Hit "; !
input junk$ !
!-----------------------------------------------------------------------
! example #2 (DYNAMIC STRING)
!-----------------------------------------------------------------------
8192 test2:
print !
print "-i-Test-2" !
print "Dynamic String=";dynamic_str$ !
ptr% = loc( dynamic_str$ ) ! ptr% is a pointer to string descriptor
print "addr "; ptr% ! display the descriptor address
call dump_word(ptr% , 1) !
call dump_byte(ptr%+2, 2, 0) !
call dump_long(ptr%+4, 1) !
print "a=(length ) "; my_peek_W( ptr% ) ! DATA LENGTH
print "b=(type ) "; my_peek_B( ptr%+2 ) ! DESCRIPTOR TYPE
print "c=(class ) "; my_peek_B( ptr%+3 ) ! DESCRIPTOR CLASS
print "d=(address) "; my_peek_L( ptr%+4 ) ! DATA ADDRESS
!
ptr2% = my_peek_L( ptr%+4 ) ! get the address (again)
length% = my_peek_W( ptr% ) ! get the LENGTH (again)
call dump_byte(ptr2%, length%, 1) !
print "-i-end of hack 2. Hit "; !
input junk$ !
!-----------------------------------------------------------------------
! example #3 (MAPPED STRING)
!-----------------------------------------------------------------------
16384 test3:
print !
print "-i-Test-3" !
print "Mapped String=";mapped_str$ !
ptr% = loc( mapped_str$ ) ! ptr% is a pointer to data
length% = len( mapped_str$ ) ! be sure to check equiv machine code
print "addr "; ptr% ! display the string address
print "length "; length% ! display the string length
call dump_byte(ptr%, 12, 1) !
print "-i-end of hack 3. Hit "; !
input junk$ !
!-----------------------------------------------------------------------
! example #4 (fs array)
!-----------------------------------------------------------------------
16385 test4:
print !
print "-i-Test-4" !
print "fs array (fixed length strings - no descriptors)"
print "array data"
for i% = 0 to k_max_subs !
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_subs) ! be sure to check equiv machine code
ptr% = loc( fs_array$(0) ) ! ptr% is a pointer to string data
length% = len( fs_array$(0) ) ! the compiler knew this value
print "addr-0 "; ptr% ! display the string address
print "length "; length% ! display the max string length
call dump_byte(ptr%, 12%, 1) ! only dump 12 bytes
print "-i-end of hack 4. Hit "; !
input junk$ !
!-----------------------------------------------------------------------
! example #5 (vs array)
!-----------------------------------------------------------------------
16386 test5:
print
print "-i-Test-5" !
print "vs array (compile-time - variable length strings - descriptors)"
print "array data" !
for i% = 0 to k_max_subs !
print " ";i%;" ";vs_array_ct$(i%) !
next i% !
ptr% = loc( vs_array_ct$(0) ) ! ptr% is a pointer to string descriptor
print "addr-0 "; ptr% ! display the descriptor address
call dump_word(ptr% , 1 ) !
call dump_byte(ptr%+2, 2, 0) !
call dump_long(ptr%+4, 1 ) !
print "a=(length ) "; my_peek_W( ptr% ) ! DATA LENGTH
print "b=(type ) "; my_peek_B( ptr%+2 ) ! DESCRIPTOR TYPE
print "c=(class ) "; my_peek_B( ptr%+3 ) ! DESCRIPTOR CLASS
print "d=(address) "; my_peek_L( ptr%+4 ) ! DATA ADDRESS
!
ptr2% = my_peek_L( ptr%+4 ) ! get the address (again)
length% = my_peek_W( ptr% ) ! get the LENGTH (again)
call dump_byte(ptr2%, length%, 1) !
print "hit to continue "; !
input junk$ !
!
ptr% = loc( vs_array_ct$(1) ) ! ptr% is a pointer to string descriptor
print "addr-1 "; ptr% ! display the descriptor address
call dump_word(ptr% , 1 ) !
call dump_byte(ptr%+2, 2, 0) !
call dump_long(ptr%+4, 1 ) !
print "a=(length ) "; my_peek_W( ptr% ) ! DATA LENGTH
print "b=(type ) "; my_peek_B( ptr%+2 ) ! DESCRIPTOR TYPE
print "c=(class ) "; my_peek_B( ptr%+3 ) ! DESCRIPTOR CLASS
print "d=(address) "; my_peek_L( ptr%+4 ) ! DATA ADDRESS
!
ptr2% = my_peek_L( ptr%+4 ) ! get the address (again)
length% = my_peek_W( ptr% ) ! get the LENGTH (again)
call dump_byte(ptr2%, length%, 1) !
!
print "-i-end of hack 5. Hit "; !
input junk$ !
!-----------------------------------------------------------------------
! example #6 (vs array)
!-----------------------------------------------------------------------
%include "$dscdef" %from %library "sys$library:basic$starlet" ! descriptor stuff
record switcheroo
variant
case
group one !
basic$quadword my_quad !
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 ! definied 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 <<<" !
print "vs array (run-time - variable length strings - descriptors)"
print "array data" !
for i% = 0 to max_subs_rt% !
print " ";i%;" ";vs_array_rt$(i%) !
next i% !
ptr% = my_loc( vs_array_rt$() ) ! here, ptr% is a pointer to array descriptor (maybe not)
print "addr "; ptr% ! display the descriptor address
ptr% = loc( vs_array_rt$(0) ) ! ptr% is a pointer to string descriptor
print "addr-0 "; ptr% ! display the descriptor address
call dump_word(ptr% , 1 ) !
call dump_byte(ptr%+2, 2, 0) !
call dump_long(ptr%+4, 1 ) !
print "a=(length ) "; my_peek_W( ptr% ) ! DATA LENGTH
print "b=(type ) "; my_peek_B( ptr%+2 ) ! DESCRIPTOR TYPE
print "c=(class ) "; my_peek_B( ptr%+3 ) ! DESCRIPTOR CLASS
print "d=(address) "; my_peek_L( ptr%+4 ) ! DATA ADDRESS
!
print "-i-Test-6a <<<" !
ptr2% = my_peek_L( ptr%+4 ) ! get the address (again)
length% = my_peek_W( ptr% ) ! get the LENGTH (again)
call dump_byte(ptr2%, length%, 1) !
print "hit to continue "; !
input junk$ !
!
! use a different technique to pull the next string
!
print "-i-Test-6b <<<" !
ptr% = loc( vs_array_rt$(1) ) ! ptr% is a pointer to string descriptor
my_dsc::my_quad = my_peek_Q( ptr% ) ! 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 little bug in module $dscdef in sys$library:basic$starlet the
! technique shown above in Test-6b is preferable to this one.
!
print "-i-Test-6c <<<" !
ptr% = loc( vs_array_rt$(2) ) ! ptr% is a pointer to string descriptor
my_dsc::my_quad = my_peek_Q( ptr% ) ! stuff our switcheroo
ptr2% = my_dsc::DSC$A_POINTER ! using DSCDEF1
!~~~ length% = my_dsc::DSC$W_LENGTH x using DSCDEF1 oops, this should work but will not compile
length% = my_dsc::DSC$W_MAXSTRLEN ! using DSCDEF1 oops, this should not work but does
call dump_byte(ptr2%, length%, 1) !
!
print "-i-end of hack 6. Hit "; !
input junk$ !
!
goto fini
!-----------------------------------------------------------------------
! common error trap
!-----------------------------------------------------------------------
my_error_trap:
print
print "====================="
print "-e- common error trap"
print "====================="
print "-e- error : "; err
print "-e- text : "; ert$(err)
print "-e- line : "; erl
print "-e- module: "; ern$
print "====================="
resume fini !
!-----------------------------------------------------------------------
! adios
!-----------------------------------------------------------------------
31000 fini: !
print "Adios..." !
end !
!###########################################################################
!
! External functions
!
!-----------------------------------------------------------------------
! peek L(ong)
!-----------------------------------------------------------------------
32000 function long my_peek_L(long incomming by ref) ! long function receives long address
option type=explicit !
my_peek_L = incomming ! exit with this value
end function !
!-----------------------------------------------------------------------
! peek W(ord)
!-----------------------------------------------------------------------
32010 function word my_peek_W(word incomming by ref) ! word function receives word address
option type=explicit !
my_peek_W = incomming ! exit with this value
end function !
!-----------------------------------------------------------------------
! peek B(yte)
!-----------------------------------------------------------------------
32020 function byte my_peek_B(byte incomming by ref) ! byte function receives byte address
option type=explicit !
my_peek_B = incomming ! exit with this value
end function !
!-----------------------------------------------------------------------
! peek Q/uadword
!-----------------------------------------------------------------------
32030 function basic$quadword my_peek_Q(basic$quadword incomming 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 = incomming ! 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 incomming by value) ! this function receives an address
option type=explicit !
my_loc = incomming ! exit with this value
end function !
!-----------------------------------------------------------------------
! dump long data
!-----------------------------------------------------------------------
32050 sub dump_long(long ptr%, 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% = ptr% + i% !
print using " ########## = ##########";temp%;my_peek_L(temp%) !
next i% !
end sub !
!-----------------------------------------------------------------------
! dump_word
!-----------------------------------------------------------------------
32060 sub dump_word(long ptr%, 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% = ptr% + i% !
print using " ########## = ##########";temp%;my_peek_W(temp%) !
next i% !
end sub !
!-----------------------------------------------------------------------
! dump_byte (with ASCII display)
!-----------------------------------------------------------------------
32070 sub dump_byte(long ptr%, 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% = ptr% + 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 !
Back
to OpenVMS
Back
to Home
Neil Rieck
Kitchener - Waterloo -
Cambridge, Ontario, Canada.