%sbttl 'Commom macros and data for PSDI BLISS programs'
!
!			  COPYRIGHT (c) 1980 BY
!		Project Software & Development, Inc.
!
! This software is furnished under a license and may be used and  copied
! only  in  accordance  with  the  terms  of  such  license and with the
! inclusion of the above copyright notice.  This software or  any  other
! copies  thereof may not be provided or otherwise made available to any
! other person.  No title to and ownership of  the  software  is  hereby
! transferred.
!
! The information in this software is subject to change  without  notice
! and  should  not  be  construed  as  a commitment by PROJECT SOFTWARE
! AND DEVELOPMENT, INC.
!
! PROJECT SOFTWARE assumes no responsibility for the use or  reliability  
! of its software on equipment which is not supplied by PROJECT SOFTWARE.
!

!++
! FACILITY: PSDI VAX/VMS
!
! ABSTRACT: This file contains common macros for PSDI BLISS programs
!
!
! ENVIRONMENT: VMS v2.0
!
! AUTHOR: M. Erik Husby	, CREATION DATE: January 1981
!
! MODIFIED BY:
!
! meh 19-mar-1981, : VERSION 2
! 01	- Added keyword macros STS$VALUE and STS$MATCH as given in the
!		BLISS manaul.
! MEH 24-apr-1981, : VERSION 3
! 01	- Added PERFORM macro to execute and test status returns of 
!		system services. Signals errors.
! MEH 27-apr-1981, : VERSION 4
! 01	- Added DYNAMIC_DESCRIPTOR to allocate and initialize a dynamic
!	string descriptor.
! MEH 5-may-1981, : VERSION 5
! 01	- Added additional fields to the io status block for terminal IO
! MEH 7-may-1981, : VERSION 6
! 01	- Added LITERAL_LIST macro to make generating lists of literals easy.
! MEH 19-nov-1981, : VERSION 7
! 01	- Added tparse_args macro.
! meh 17-dec-1981, :VERSION 8
! 01	- Added DELTA_SECONDS macro.
! meh 19-jan-1982, : version 9
! 01	- Added MASK_LIST macro to make generating lists of masks easy.
! meh 18-jan-1983, : VERSION 10
! 01	- Changed allocate_string to make it a vector of bytes.
! gaf 21-mar-1984, : VERSION 11
! 01	- Added RMS_Macros to perform rms operation with a controled status
!	  block (similar to perform).
! MEH, 23-Apr-1984, : VERSION 12
! 01	- Added fao_put macro.
!--

!
! TABLE OF CONTENTS:
!

!
!
! MACROS:
!
!	Create a literal for VMS delta times in seconds.
macro
	delta_seconds(n)=
		uplit(-10*1000*1000*n,-1) %;
!
!	Define the I/O status block fields
!
field
	iosb_field	=	set
				iosb_w_status	= [0,0,16,1],
				iosb_w_count	= [0,16,16,0],
				iosb_l_devsts	= [1,0,32,0],
				iosb_b_terminator=[1,0,8,0],
				iosb_b_terminator2=[1,8,8,0],
				iosb_w_termsize	= [1,16,16,0]
				tes;
macro
!
!	calculate boolean value of x
!
	bool(x)		=	((x) and 1 ) %,
!
!	Define i/o status block
!
	io_status_block	= block[2] field(iosb_field) %,
!
!	Allocate a string
!
	allocate_string(l) =	vector[l,byte] %,
!
!	Allocate and initialize a string 
!
	string[]	=	vector[ch$allocation(%charcount(%remaining))]
				initial(byte(%remaining)) %,
!
!	Form and intialize a string descriptor of length 'l' and
!	pointer to string 'n'
!
	descriptor(n,l)	=	block[dsc$c_s_bln,byte] 
				%if %null(l) %then
					initial(word(0),
				%else
					initial(word(l),
				%fi
					byte(dsc$k_dtype_t,dsc$k_class_s),
				%if %null(n) %then
					long(0))
				%else
					long(n))
				%fi %,
!
!	Form a reference to a descriptor
!
	ref_descriptor(rd)	=
		map rd : ref block[dsc$c_s_bln,byte]; %,
!
!	Form a local block and descriptor
!
	local_descriptor(ld,l) =
		local ld : block[l,byte],
			%name(ld,'_desc') : block[dsc$c_s_bln,byte]; %,
!
!	Initialize a local string descriptor
!
	init_descriptor(ld,l) =
		%name(ld,'_desc')[dsc$b_dtype]=dsc$k_dtype_t;
		%name(ld,'_desc')[dsc$b_class]=dsc$k_class_s;
		%name(ld,'_desc')[dsc$w_length]=l;
		%name(ld,'_desc')[dsc$a_pointer]=ld;
		%,
!
!	Form a static string descriptor
!
	static_descriptor[] =
		uplit(%charcount(%remaining),uplit byte(%remaining))%;
!
!	Form a dynamic string descriptor
macro
	dynamic_descriptor=
		block[dsc$c_d_bln,byte] initial(word(0),byte(dsc$k_dtype_t,
						dsc$k_class_d),long(0))
			%;
!
!	Flag bits
!	macro to define a flag bit mask and bitvector index;
!	given a bit position.
macro
	flag(n,p) =
		literal %name(n,'_m') = 1^p ;
		literal %name(n,'_v') = p;
		%;
!
!	Keyword macro to form a STS value.
!	Usage is:
!	literal sts_value= sts$value(code=error_code);
!	Recommended usage is with the shared error messages described
!	in the $SHRDEF section of STARLET.REQ.
!
keywordmacro sts$value(code,
			severity=sts$k_severe,
			facility_specific=0,
			facility_number=0,	! An arbitray default
			customer_def=0) =
		(severity and 7) or
		(code and (1^13-1))^3 or
		(if facility_specific eql 0 then 0 else sts$m_fac_sp ) or
		(facility_number and (1^12-1))^16 or
		(if customer_def eql 0 then 0 else sts$m_cust_def )
		%;
!
!	Macro to create messages codes using the shared messages
!	Taken from DELMSG.REQ on the system microfiche.
!	Usage is:
!		$shr_messages(msg_,3,
!			(badlogic,severe),
!			(closein,warning),...);
!	To create literals of the form MSG_BADLOGIC, MSG_CLOSEIN...
!	They then can be used in $PUTMSG provided a facility name is provided.
macro
    $shr_messages(facility_name,facility_code)=
	LITERAL
	shr$msg_ids(facility_name,facility_code,%remaining); %,
    shr$msg_ids(facility_name,facility_code)[value]=
	shr$msg_calc(facility_name,facility_code,%remove(value) )%,
    shr$msg_calc(facility_name,facility_code,msg_id,severity)=
	%name(facility_name,msg_id)=%name('SHR$_',msg_id)+facility_code*65536+
		%if %declared(%name('STS$K_',severity) )
		%then %name('STS$K_',severity)
		%else severity %fi %;
!
!	Macro to compare to two condition values.
!	Usage is:
!	if sts$match(a,b) then matched else not_matched
!
macro sts$match(a,b)=
	begin
	local qqqqa : block[1], qqqqb : block[1];
	qqqqa=(a);qqqqb=(b);
	if not (.qqqqa[sts$v_fac_sp] or .qqqqb[sts$v_fac_sp]) then
		.qqqqa[sts$v_code] eql .qqqqb[sts$v_code]
	else
		.qqqqa[sts$v_cond_id] eql .qqqqb[sts$v_cond_id]
	end %;
!
!	Macro to PERFORM a system service and signal errors.
!
macro perform(command)=
	begin
	local qqqqstatus;
	if not ( qqqqstatus=command) then signal(.qqqqstatus);
	end %;
!
!	Macro to generate a list of literals
!	Given a prefix, it will generate a set of literals of the form
!	'prefix'c_'literal_name'=n
!	where n will vary by one begining with 'm'.
!
!	Example: Literal lit_list(io_,one,two,three);
!	will generate
!	LITERAL IO_c_ONE=1,IO_c_TWO=2,IO_c_THREE=2;
macro lit_list(lit_prefix)[lit_name]=
	%name(lit_prefix,'c_',lit_name)=%count+1
	%;
macro mask_list(mask_prefix)[mask_name]=
	%name(mask_prefix,'m_',mask_name)=1^(%count+1)-1^%count
	%;
!
!	For tparse action routines
!
macro
	tparse_args	=	builtin ap;
				map ap : ref block [,byte];
				%;
! 
! RMS ROUTINES
!
!	ld - name of string for local descriptor
!	fab_blk - file access block to retrieve name string
!	nam_blk - name block to retrieve resultant name string if found
macro
	rms_file_desc(ld, fab_blk, nam_blk)  = 

		local_descriptor(ld,132);
		init_descriptor(ld,132);

		if .nam_blk[nam$b_rsl] neq 0
		then  begin
			%name(ld,'_desc')[dsc$w_length]=.nam_blk[nam$b_rsl];
			%name(ld,'_desc')[dsc$a_pointer]=.nam_blk[nam$l_rsa];
		      end
		else if .nam_blk[nam$b_esl] neq 0
		then  begin
			%name(ld,'_desc')[dsc$w_length]=.nam_blk[nam$b_esl];
			%name(ld,'_desc')[dsc$a_pointer]=.nam_blk[nam$l_esa];
		      end
		else begin
			%name(ld,'_desc')[dsc$w_length]=.fab_blk[fab$b_fns];
			%name(ld,'_desc')[dsc$a_pointer]=.fab_blk[fab$l_fna];
		      end;
		%;

! issue rms $put and check status
! rab_blk = record access block of file
! rms_error = name string of facility name type error, $shr_message
!
macro	rms_put(rab_blk, rms_error)=
	begin
	if not $rms_ok($put(rab=rab_blk))
	then
	    signal_stop(rms_error, 0,
		.rab_blk[rab$l_sts], .rab_blk[rab$l_stv]);
	end %;
! macro
! 
! issue rms $delete and check status
! rab_blk = record access block of file
! rms_error = name string of facility name type error, $shr_message
!
macro	rms_delete(rab_blk, rms_error)=
	begin
	if not $rms_ok($delete(rab=rab_blk))
	then
	    signal(rms_error, 0,
		.rab_blk[rab$l_sts], .rab_blk[rab$l_stv]);
	end %;
! macro
! 
! issue rms $get and check status
! rab_blk = record access block of file
! rms_error = name string of facility name type error, $shr_message
!
macro	rms_get(rab_blk, rms_error)=
	begin
	if not $rms_ok($get(rab=rab_blk))
	then
	    signal_stop(rms_error, 0,
		.rab_blk[rab$l_sts], .rab_blk[rab$l_stv]);
	end %;
! 
! issue rms $connect and check status
! rab_blk = record access block of file
! rms_error = name string of facility name type error, $shr_message
!
macro	rms_connect(rab_blk, rms_error)=
	begin
	if $connect(rab=rab_blk) neq rms$_normal
	then
	    signal_stop(rms_error, 0,
		.rab_blk[rab$l_sts], .rab_blk[rab$l_stv]);
	end %;
! 
! issue rms $update and check status
! rab_blk = record access block of file
! rms_error = name string of facility name type error, $shr_message
!
macro	rms_update(rab_blk, rms_error)=
	begin
	if $update(rab=rab_blk) neq rms$_normal
	then
	    signal_stop(rms_error, 0,
		.rab_blk[rab$l_sts], .rab_blk[rab$l_stv]);
	end %;
!
! issue rms $open, check status and wait if file locked
! rab_blk = record access block of file
! nam_blk = name access block of file
! rms_error = name string of facility name type error, $shr_message
! wait_time = number of seconds to wait before trying to open again.
! wait_max = total maximum time to waited while trying to open.
!	     (e.i. wait_time = 2, wait_max = 6, 3 attempts to open.
! 
Macro	rms_wopen(fab_blk, nam_blk, rms_error, wait_time, wait_max)=
	Begin
	
	local
	    qqqqstatus,

	    qqqqtime : initial(%if %null(wait_time) %then 2
					%else wait_time %fi),
	    qqqqmax : initial(%if %null(wait_max) %then .qqqqtime*2
					%else wait_max %fi),
	    qqqqseconds : vector[2] initial(-10*1000*1000*.qqqqtime,-1),

	    wait_count : initial(.qqqqtime);


	qqqqstatus=$open(fab=fab_blk);
	While .qqqqstatus eql rms$_flk and .wait_count leq .qqqqmax Do
	    Begin
		$setimr(efn=1,daytim=qqqqseconds);
		$waitfr(efn=1);
		wait_count=.wait_count+.qqqqtime;
		qqqqstatus=$open(fab=fab_blk);
	    end;

	if .qqqqstatus neq rms$_normal
	then
	    begin
		rms_file_desc(file, fab_blk, nam_blk);
		signal_stop(rms_error, 1 , file_desc,
			.fab_blk[fab$l_sts], .fab_blk[fab$l_stv]);
	    end;
	end %;
!
! issue rms $open and check status
! rab_blk = record access block of file
! nam_blk = name access block of file
! rms_error = name string of facility name type error, $shr_message
! 
macro	rms_open(fab_blk, nam_blk, rms_error)=
	begin
	if $open(fab=fab_blk) neq rms$_normal
	then
	    begin
		rms_file_desc(file, fab_blk, nam_blk);
	 	signal_stop(rms_error, 1 , file_desc,
		.fab_blk[fab$l_sts], .fab_blk[fab$l_stv]);
    	    end;
	end %;

! issue rms $create and check status
! rab_blk = record access block of file
! nam_blk = name access block of file
! rms_error = name string of facility name type error, $shr_message
! 
macro	rms_create(fab_blk, nam_blk, rms_error)=
	begin
	    Local qqqqstatus;

	qqqqstatus=$create(fab=fab_blk);
	if .qqqqstatus neq rms$_normal and .qqqqstatus neq rms$_created
	then
	    begin
		rms_file_desc(file, fab_blk, nam_blk);
		signal_stop(rms_error, 1 , file_desc,
		.fab_blk[fab$l_sts], .fab_blk[fab$l_stv]);
	    end;
	end %;

! display rms message status
! rab_blk = record access block of file
! nam_blk = name access block of file
! rms_message = name string of facility name type, $shr_message
! 
macro	rms_notify(fab_blk, nam_blk, rms_message)=
	begin
	if not .fab_blk[fab$l_dev or dev$m_rec] ! device block structured
	then
	    begin
		rms_file_desc(file, fab_blk, nam_blk);
		signal(rms_message, 1, file_desc);
	    end;
	end %;
! 
! issue rms $rewind and check status
! rab_blk = record access block of file
! rms_error = name string of facility name type error, $shr_message
!
macro	rms_rewind(rab_blk, rms_error)=
	begin
	if $rewind(rab=rab_blk) neq rms$_normal
	then
	    signal_stop(rms_error, 0,
		.rab_blk[rab$l_sts], .rab_blk[rab$l_stv]);
	end %;
! 
! 
Macro
    Fao_Put(format,args,act_rtn)=	!Format a string and display it
    ! 
    ! Format: passed to $fao as is.
    ! Args: passed to $fao with parenthesises removed.
    ! act_rtn: optional action routine, if not given, Lib$put_output is used.
    ! 
    ! Examples:
    ! 	fao_put($descriptor('The time is !%T'),0);
    ! Will write to Sys$output using Lib$put_output.
    ! 
    !   fao_put($descriptor('The values are !UL and !UL'),(.a,.b),write_out);
    ! Will format the string and pass the descriptor to Write_Out for 
    ! actual output. Write_out should return Ss$_normal if all is ok, otherwise
    ! an error code which will be signaled.
    ! 
	Begin
	Local_Descriptor(line,132);	!Space to store the result
	Init_Descriptor(line,132);
	perform($fao(format,
	    line_desc[Dsc$w_length],
	    line_desc,
	    %Remove(args)
	    ));
	%If %Null(act_rtn)
	    %then
	    begin
	    external routine Lib$put_output : addressing_mode(general);
	    perform(Lib$put_output(line_desc));
	    end;
	%else
	    perform(act_rtn(line_desc));
	%FI
	End
	%;
!
!	End of PSDI.REQ