OpenVMS Source Code Demos

BASIC_Peek_Demo.bas

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 compiler switch "/LINES". This has been
	!	known to add 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_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 compile 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.