



		    adjust_cutoff_.pl1              07/13/88  1120.1r w 07/13/88  0940.0       34884



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


adjust_cutoff_:
     procedure (bv_pdtep, bv_time_now);

/* ADJUST_CUTOFF_ - program to fix up absolute cutoff. */

/****^  HISTORY COMMENTS:
  1) change(86-02-01,Gilcrease), approve(86-03-27,MCR7369),
     audit(86-06-20,LJAdams), install(86-06-30,MR12.0-1081):
     Dummy hcom for first comment. Modified 750702 by PG to correct operation
     when called more than once with same time.
  2) change(86-03-27,Gilcrease), approve(86-03-27,MCR7369),
     audit(86-06-20,LJAdams), install(86-06-30,MR12.0-1081):
        Add increment of one week for weekly cutoffs SCP 6250.
                                                   END HISTORY COMMENTS */


/* parameters */

dcl (bv_pdtep ptr,
     bv_time_now fixed bin (71)) parameter;

/* automatic */

dcl (pdtep, pdtp) ptr,
    (mm, dd, yy) fixed bin,
     time_of_day fixed bin (71),			/* placeholder only */
     day_of_week fixed bin,				/* .. */
     time_zone char (3) aligned,			/* .. */
     time_now fixed bin (71);

/* internal static */

dcl  NEVER fixed bin (71) int static options (constant) init /* This date is 12/31/99 2359. */
    (1011000110010110011001001110100110111010100100000000b); /* .. if Multics last this long we will have to fix */
dcl  bigfloat float bin int static options (constant) init (1e37);

dcl (static_mm, static_dd, static_yy) fixed bin int static,
     oldtime fixed bin (71) int static init (-1);

/* entries */

dcl  decode_clock_value_ entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71),
     fixed bin, char (3) aligned),
     datebin_$revert entry (fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71));

/* include files */

%include user_attributes;
%include pdt;


/* program */

	pdtep = bv_pdtep;
	time_now = bv_time_now;

	if time_now > user.absolute_cutoff then do;	/* have we past the cutoff date? */
	     if user.absolute_cutoff = 0 then do;	/* special case. old-style segment, thing never set */
		user.absolute_cutoff = NEVER;		/* Default shd be open, never, never */
		if user.absolute_limit = 0e0 then user.absolute_limit = bigfloat;
		return;
	     end;
	     if user.absolute_increm = 0 then return;	/* 0 = never */

	     if oldtime ^= time_now then do;		/* optimize common case for up_pdt_ */
		oldtime = time_now;
		call decode_clock_value_ (time_now, static_mm, static_dd, static_yy, time_of_day, day_of_week, time_zone);
	     end;

	     mm = static_mm;
	     dd = static_dd;
	     yy = static_yy;

	     if user.absolute_increm = 1 then do;	/* 1 = daily */
		dd = dd + 1;
	     end;
	     else if user.absolute_increm = 2 then do;	/* 2 = monthly */
		mm = mm + 1;
		dd = 1;
	     end;
	     else if user.absolute_increm = 3 then do;	/* 3 = yearly */
		yy = yy + 1;
	     end;
	     else if user.absolute_increm = 4 then do;	/* 4 = calendar yr */
		mm = 1;
		dd = 1;
		yy = yy + 1;
	     end;
	     else if user.absolute_increm = 5 then do;	/* 5 = year starting July 1 */
		dd = 1;
		if mm ^< 7 then yy = yy + 1;
		mm = 7;
	     end;
	     else if user.absolute_increm = 6 then do;	/* 6 = weekly */
		dd = dd + 7;
	     end;
	     else return;				/* garbage increment code */

	     call datebin_$revert (mm, dd, yy, 0, 0, 0, user.absolute_cutoff);
	     user.absolute_spent = 0e0;		/* reset spending since we changed the cutoff date */
	end;

	return;

     end;




		    cv_pmf.rd                       06/30/86  1432.8rew 06/30/86  1430.0      485739



/* **************************************************************
   *                                                            *
   * Copyright, (C) Honeywell Information Systems Inc., 1982    *
   *                                                            *
   * Copyright, (C) Massachusetts Institute of Technology, 1982 *
   *                                                            *
   * Copyright (c) 1972 by Massachusetts Institute of           *
   * Technology and Honeywell Information Systems, Inc.         *
   *                                                            *
   ************************************************************** */





/* HISTORY COMMENTS:
  1) change(86-05-20,Gilcrease), approve(86-05-22,MCR7369),
     audit(86-06-23,LJAdams), install(86-06-30,MR12.0-1081):
               Allow weekly cutoffs. SCP6250.
                                                   END HISTORY COMMENTS */


/* CV_PMF - Compile a Project Master File (PMF) into a Project Definition Table (PDT).

   See AK-51 for an explanation of the contents of the PMF.
   See AN-66 for an explanation of the format of the PDT.

   THVV April 74
   Modified 750717 by PG to fix bug 001 (pathnames with $ were being diagnosed)
   Modified by THVV and TAC for Priority Scheduler parameters, June 1975
   Modified by REMullen to merge THVV,TAC,PG changes, July 1975
   Modified May 1976 by T. Casey to add per_user cutoff warning thresholds.
   Modified May 1978 by T. Casey to add pdir_quota.
   Modified November 1978 by T. Casey for MR7.0 to add new absentee control parameters.
   Modified October 1979 by T. Casey for MR8.0 for process preservation control parameters.
   Modified December 1981 by E. N. Kittlitz for bugfixes, User_warn controls.
   Modified January 1982 by BIM for author changes.
   Modified July 1982 by E. N. Kittlitz for [severity] and pmf suffix.
   Modified September 1982 by E. N. Kittlitz for default ring.
   Modified November 1982 by J. I. Schiller to correctly parse dollar values.
   Modified 1984-07-05 BIM for authorization ranges.
   Modified 1984-07-25 BIM for checks against live pdt sate.
   Modified 1984-09-14 BIM to check for current version of  live pdt sate
            and NOT use sate authorization as default user authorization.
   Modified 1984-11-20 BIM Fix "Authorization:" statement.
*/

/*++

BEGIN
	/ Projectid : <any-token> ;	/ LEX(2) set_project_name LEX(2)			/ head \
	/			/ ERROR(2)					/ RETURN \

head	/ Grace : <decimal-integer> ;	/ LEX(2) [default.bump_grace = token.Nvalue] LEX(2) 	/ head \
	/ Attributes :		/ LEX(2) PUSH(head) PUSH(assign_default_attributes)	/ attrsub \
	/ Initproc : <path_name> , direct ;
				/ LEX(2) set_ip_ss (default.initial_procedure,default.uflags.ip_given,default.ip_len)
				  LEX(4) [default.dont_call_init_admin = "1"b]		/ head \
	/ Initproc : <path_name> ;	/ LEX(2) set_ip_ss (default.initial_procedure,default.uflags.ip_given,default.ip_len)
				  LEX(2) [default.dont_call_init_admin = "0"b]		/ head \
	/ Initproc : <any-token> ;	/ LEX(2) ERROR(22) LEX(2)				/ head \
	/ Subsystem : <path_name> ;	/ LEX(2) set_ip_ss (default_subsystem,default.uflags.ss_given, default.ss_len)
				  LEX(2)						/ head \
	/ Subsystem : <any-token> ;	/ LEX(2) ERROR(22) LEX(2)				/ head \
	/ Homedir : <path_name> ;	/ LEX(2) [call set_string ("Homedir", default.home_dir, token_value)] LEX(2) / head \
	/ Homedir : <any-token> ;	/ LEX(2) ERROR(22) LEX(2)				/ head \
	/ Outer_module : <path_name> ; / LEX(2) [call set_string ("Outer_module", default.outer_module, token_value)] LEX(2)	/ head \
	/ Outer_module : <any-token> ; / LEX(2) ERROR(22) LEX(2)				/ head \
	/ Lot_size : <decimal-integer> , own ; / LEX(2) [default.lot_size = -token.Nvalue] LEX(4) / head \
	/ Lot_size : <decimal-integer> , stack ; / LEX(2) [default.lot_size = token.Nvalue] LEX(4) / head \
	/ Lot_size : <decimal-integer> ; / LEX(2) [default.lot_size = token.Nvalue] LEX(2)	/ head \
	/ Kst_size : <decimal-integer> ; / LEX(2) [default.kst_size = token.Nvalue] LEX(2)	/ head \
 	/ Cls_size : <decimal-integer> , stack ; / LEX(2) [default.cls_size = -token.Nvalue] LEX(4) / head \
	/ Cls_size : <decimal-integer> , own ; / LEX(2) [default.cls_size = token.Nvalue] LEX(4)	/ head \
	/ Cls_size : <decimal-integer> ; / LEX(2) [default.cls_size = token.Nvalue] LEX(2)	/ head \
	/ Pdir_quota : <decimal-integer> ; / LEX(2) [default.pdir_quota = token.Nvalue] LEX(2)	/ head \
	/ Max_foreground : <decimal-integer> ; / LEX(2) [default.max_foreground = token.Nvalue] LEX(2) / head \
	/ Max_background : <decimal-integer> ; / LEX(2) [default.max_background = token.Nvalue] LEX(2) / head \
	/ Abs_foreground_cpu_limit : <decimal-integer> ;
				/ LEX(2) [default.abs_foreground_cpu_limit = token.Nvalue] LEX(2) / head \
	/ Cutoff :		/ LEX(2) PUSH(head) PUSH(default_cutoff)		/ number \
	/ Limit :			/ LEX(2) PUSH(head) PUSH(default_monthlim)		/ number \
	/ Shift_limit :		/ LEX(2) PUSH(head) [x = 1]				/ default_shiftlims \
	/ User_warn_days : <decimal-integer> ; / LEX(2) [default.user_warn_days = token.Nvalue] LEX(2)	/ head \
	/ User_warn_percent : <decimal-integer> ; / LEX(2) [default.user_warn_pct = token.Nvalue] LEX(2)	/ head \
	/ User_warn_dollars :		/ LEX(2) PUSH(head) PUSH(default_user_warn_doll)		/ number \
	/ Warn_days : <decimal-integer> ; / LEX(2) [default.warn_days = token.Nvalue] LEX(2)	/ head \
	/ Warn_percent : <decimal-integer> ; / LEX(2) [default.warn_pct = token.Nvalue] LEX(2)	/ head \
	/ Warn_dollars :		/ LEX(2) PUSH(head) PUSH(default_warn_doll)		/ number \
	/ Ring : <onetoseven> , <onetoseven> , <onetoseven> ; / LEX (2) [default.low_ring = token.Nvalue] LEX (2)
					[default.high_ring = token.Nvalue] LEX (2)
					[default.default_ring = token.Nvalue] LEX (2) 	/ head \
	/ Ring : <onetoseven> , <onetoseven> ; / LEX(2) [default.low_ring = token.Nvalue] 
					[default.default_ring = token.Nvalue] LEX(2)
					[default.high_ring = token.Nvalue] LEX (2)	/ head \
	/ Ring : <onetoseven> ;	 / LEX(2) [default.low_ring = token.Nvalue]
					[default.default_ring = token.Nvalue]
					[default.high_ring = token.Nvalue] LEX(2)	/ head \
	/ Authorization : <authorization_string> ;
				/ LEX(2) [default.user_authorization = authorization_value] 
				         check_default_authorization
				         LEX(2)
										/ head \
	/ Authorization : <any-token> ;
				/ LEX(2) ERROR(25) LEX(2)				/ head \
	/ Group : <any-token>;	/ LEX(2) [call set_string ("Group", Default_Group, token_value)] LEX(2)/ head \
	/ personid :		/						/ user \
	/ Grace			/						/ error_23_in_head \
	/ Attributes		/						/ error_23_in_head \
	/ Initproc		/						/ error_23_in_head \
	/ Homedir			/						/ error_23_in_head \
	/ Outer_module		/						/ error_23_in_head \
	/ Lot_size		/						/ error_23_in_head \
	/ Kst_size		/						/ error_23_in_head \
	/ Cls_size		/						/ error_23_in_head \
	/ Pdir_quota		/						/ error_23_in_head \
	/ Max_foreground		/						/ error_23_in_head \
	/ Max_background		/						/ error_23_in_head \
	/ Abs_foreground_cpu_limit	/						/ error_23_in_head \
	/ Cutoff			/						/ error_23_in_head \
	/ Limit			/						/ error_23_in_head \
	/ Shift_limit		/						/ error_23_in_head \
	/ User_warn_days		/						/ error_23_in_head \
	/ User_warn_percent		/						/ error_23_in_head \
	/ User_warn_dollars		/						/ error_23_in_head \
	/ Warn_days		/						/ error_23_in_head \
	/ Warn_percent		/						/ error_23_in_head \
	/ Warn_dollars		/						/ error_23_in_head \
	/ Ring			/						/ error_23_in_head \
	/ Audit			/						/ error_23_in_head \
	/ Authorization		/						/ error_23_in_head \
	/ Group			/						/ error_23_in_head \
	/ personid		/						/ error_23_in_head \
	/ Accountid		/ ERROR(29) NEXT_STMT				/ head \
	/ <any-token>		/ ERROR(1) NEXT_STMT				/ head \
	/ <no-token>		/ ERROR(5)			 		/ RETURN \

error_23_in_head
	/			/ ERROR (23) NEXT_STMT				/ head \

user	/ end ;	<no-token>	/ close					/ RETURN \
	/ end ;   <any-token>	/ ERROR (35) close				/ RETURN \
	/ personid : * ;		/ LEX(3) close open_anon LEX				/ user \
	/ personid : <any-token> ;	/ LEX(2) close open LEX(2)				/ user \
	/ password : <any-token> ;	/ LEX(2) [call set_string ("password", user.password, token_value)] LEX(2)/ user \
	/ ring : <onetoseven> , <onetoseven> , <onetoseven> ;	/ LEX (2) [user.low_ring = token.Nvalue] LEX (2)
					[user.high_ring = token.Nvalue] LEX (2)
					[user.default_ring = token.Nvalue] LEX (2) 	/ user \
	/ ring : <onetoseven> , <onetoseven> ; / LEX(2) [user.low_ring = token.Nvalue] 
					[user.default_ring = token.Nvalue] LEX(2)
					[user.high_ring = token.Nvalue] LEX(2)		/ user \
	/ ring : <onetoseven> ;	 / LEX(2) [user.low_ring = token.Nvalue]
					[user.default_ring = token.Nvalue]
					[user.high_ring = token.Nvalue] LEX(2)		/ user \
	/ initproc : <path_name> , direct ;
				/ LEX(2)  set_ip_ss (user.initial_procedure, user.uflags.ip_given, user.ip_len)
				  LEX(4) [user.dont_call_init_admin = "1"b]		/ user \
	/ initproc : <path_name> ;	/ LEX(2)  set_ip_ss (user.initial_procedure, user.uflags.ip_given, user.ip_len)
				  LEX(2) [user.dont_call_init_admin = "0"b]		/ user \
	/ initproc : <any-token> ;	/ LEX(2) ERROR(22) LEX(2)				/ user \
	/ subsystem : <path_name> ;	/ LEX(2) set_ip_ss (user_subsystem, user.uflags.ss_given, user.ss_len)
				  LEX(2)						/ user \
	/ subsystem: <any-token> ;	/ LEX(2) ERROR(22) LEX(2)				/ user \
	/ homedir : <path_name> ;	/ LEX(2) [call set_string ("homedir", user.home_dir, token_value)] LEX(2)/ user \
	/ homedir : <any-token> ;	/ LEX(2) ERROR(22) LEX(2)				/ user \
	/ outer_module : <path_name> ; / LEX(2) [call set_string ("outer_module", user.outer_module, token_value)] LEX(2)/ user \
	/ outer_module : <any-token> ; / LEX(2) ERROR(22) LEX(2)				/ user \
	/ lot_size : <decimal-integer> , own ; / LEX(2) [user.lot_size = -token.Nvalue] LEX(4)	/ user \
	/ lot_size : <decimal-integer> , stack ; / LEX(2) [user.lot_size = token.Nvalue] LEX(4)	/ user \
	/ lot_size : <decimal-integer> ; / LEX(2) [user.lot_size = token.Nvalue] LEX(2)		/ user \
	/ kst_size : <decimal-integer> ; / LEX(2) [user.kst_size = token.Nvalue] LEX(2)		/ user \
	/ cls_size : <decimal-integer> , stack ; / LEX(2) [user.cls_size = -token.Nvalue] LEX(4)	/ user \
	/ cls_size : <decimal-integer> , own ; / LEX(2) [user.cls_size = token.Nvalue] LEX(4)	/ user \
	/ cls_size : <decimal-integer> ; / LEX(2) [user.cls_size = token.Nvalue] LEX(2)		/ user \
	/ pdir_quota : <decimal-integer> ; / LEX(2) [user.pdir_quota = token.Nvalue] LEX(2)	/ user \
	/ max_foreground : <decimal-integer> ; / LEX(2) [user.max_foreground = token.Nvalue] LEX(2)	/ user \
	/ max_background : <decimal-integer> ; / LEX(2) [user.max_background = token.Nvalue] LEX(2)	/ user \
	/ abs_foreground_cpu_limit : <decimal-integer> ;
				/ LEX(2) [user.abs_foreground_cpu_limit = token.Nvalue] LEX(2) / user \
	/ cutoff :		/ LEX(2) PUSH(user) PUSH(cutoff)			/ number \
	/ grace : <decimal-integer> ;	/ LEX(2) [user.bump_grace = token.Nvalue] LEX(2)		/ user \
	/ attributes :		/ LEX(2) PUSH(user) PUSH(assign_user_attributes)		/ attrsub \
	/ limit :			/ LEX(2) PUSH(user) PUSH(monthlim)			/ number \
	/ shift_limit :		/ LEX(2) PUSH(user) [x = 1]				/ shiftlims \
	/ user_warn_days : <decimal-integer> ; / LEX(2) [user.user_warn_days = token.Nvalue] LEX(2)/ user \
	/ user_warn_percent : <decimal-integer> ; / LEX(2) [user.user_warn_pct = token.Nvalue] LEX(2)/ user \
	/ user_warn_dollars :		/ LEX(2) PUSH(user) PUSH(user_warn_doll)	/ number \
	/ warn_days : <decimal-integer> ; / LEX(2) [user.warn_days = token.Nvalue] LEX(2)	/ user \
	/ warn_percent : <decimal-integer> ; / LEX(2) [user.warn_pct = token.Nvalue] LEX(2)	/ user \
	/ warn_dollars :		/ LEX(2) PUSH(user) PUSH(warn_doll)			/ number \
	/ authorization : <authorization_string> ;
				/ LEX(2) [user.user_authorization = authorization_value]
				  check_user_authorization
				  LEX(2)
										/ user \
	/ authorization : <any-token> ; / LEX(2) ERROR(25) LEX(2)				/ user \
	/ group : <any-token> ;	/ LEX(2) [call set_string ("group", user.group, token_value)] LEX(2)	/ user \
	/ Grace : <decimal-integer> ;	/ LEX(2) [default.bump_grace = token.Nvalue] LEX(2) 	/ user \
	/ Attributes :		/ LEX(2) PUSH(user) PUSH(assign_default_attributes)	/ attrsub \
	/ Initproc : <path_name> , direct ;
				/ LEX(2) set_ip_ss (default.initial_procedure,default.uflags.ip_given,default.ip_len)
				  LEX(4) [default.dont_call_init_admin = "1"b]		/ user \
	/ Initproc : <path_name> ;	/ LEX(2) set_ip_ss (default.initial_procedure,default.uflags.ip_given,default.ip_len)
				  LEX(2) [default.dont_call_init_admin = "0"b]		/ user \
	/ Initproc : <any-token> ;	/ LEX(2) ERROR(22) LEX(2)				/ user \
	/ Subsystem : <path_name> ;	/ LEX(2) 	set_ip_ss (default_subsystem, default.uflags.ss_given, default.ss_len)
				  LEX(2)						/ user \
	/ Subsystem : <any-token> ;	/ LEX(2) ERROR(22) LEX(2)				/ user \
	/ Homedir : <path_name> ;	/ LEX(2) [call set_string ("Homedir", default.home_dir, token_value)] LEX(2)	/ user \
	/ Homedir : <any-token> ;	/ LEX(2) ERROR(22) LEX(2)				/ user \
	/ Outer_module : <path_name> ; / LEX(2) [call set_string ("Outer_module", default.outer_module, token_value)] LEX(2)	/ user \
	/ Outer_module : <any-token> ; / LEX(2) ERROR(22) LEX(2)				/ user \
	/ Lot_size : <decimal-integer> , own ; / LEX(2) [default.lot_size = -token.Nvalue] LEX(4) / user \
	/ Lot_size : <decimal-integer> , stack ; / LEX(2) [default.lot_size = token.Nvalue] LEX(4) / user \
	/ Lot_size : <decimal-integer> ; / LEX(2) [default.lot_size = token.Nvalue] LEX(2)	/ user \
	/ Kst_size : <decimal-integer> ; / LEX(2) [default.kst_size = token.Nvalue] LEX(2)	/ user \
 	/ Cls_size : <decimal-integer> , stack ; / LEX(2) [default.cls_size = -token.Nvalue] LEX(4) / user \
	/ Cls_size : <decimal-integer> , own ; / LEX(2) [default.cls_size = token.Nvalue] LEX(4)	/ user \
	/ Cls_size : <decimal-integer> ; / LEX(2) [default.cls_size = token.Nvalue] LEX(2)	/ user \
	/ Cutoff :		/ LEX(2) PUSH(user) PUSH(default_cutoff)		/ number \
	/ Limit :			/ LEX(2) PUSH(user) PUSH(default_monthlim)		/ number \
	/ Shift_limit :		/ LEX(2) PUSH(user) [x = 1]				/ default_shiftlims \
	/ User_warn_days : <decimal-integer> ; / LEX(2) [default.user_warn_days = token.Nvalue] LEX(2)/ user \
	/ User_warn_percent : <decimal-integer> ; / LEX(2) [default.user_warn_pct = token.Nvalue] LEX(2)/ user \
	/ User_warn_dollars :		/ LEX(2) PUSH(user) PUSH(default_user_warn_doll)	/ number \
	/ Warn_days : <decimal-integer> ; / LEX(2) [default.warn_days = token.Nvalue] LEX(2)	/ user \
	/ Warn_percent : <decimal-integer> ; / LEX(2) [default.warn_pct = token.Nvalue] LEX(2)	/ user \
	/ Warn_dollars :		/ LEX(2) PUSH(user) PUSH(default_warn_doll)		/ number \
	/ Ring : <onetoseven> , <onetoseven> , <onetoseven> ;	/ LEX (2) [default.low_ring = token.Nvalue] LEX (2)
					[default.high_ring = token.Nvalue] LEX (2)
					[default.default_ring = token.Nvalue] LEX (2)	/ user \
	/ Ring : <onetoseven> , <onetoseven> ;
				/ LEX(2) [default.low_ring = token.Nvalue] 
				         [default.default_ring = token.Nvalue] LEX(2)
				         [default.high_ring = token.Nvalue] LEX(2)	/ user \
	/ Ring : <onetoseven> ;	/ LEX(2) [default.low_ring = token.Nvalue]
				         [default.default_ring = token.Nvalue]
				         [default.high_ring = token.Nvalue] LEX(2)	/ user \
	/ Authorization : <authorization_string> ;
				/ LEX(2) [default.user_authorization = authorization_value] LEX(2)
										/ user \
	/ Authorization : <any-token> ;
				/ LEX(2) ERROR(25) LEX(2)				/ user \
	/ Group : <any-token> ;	/ LEX(2) [call set_string ("Group", Default_Group, token_value)] LEX(2)/ user \
	/ Grace			/						/ error_23_in_user \
	/ Attributes		/						/ error_23_in_user \
	/ Initproc		/						/ error_23_in_user \
	/ Subsystem		/						/ error_23_in_user \
	/ Homedir			/						/ error_23_in_user \
	/ Outer_module		/						/ error_23_in_user \
	/ Lot_size		/						/ error_23_in_user \
	/ Kst_size		/						/ error_23_in_user \
	/ Cls_size		/						/ error_23_in_user \
	/ Pdir_quota		/						/ error_23_in_user \
	/ Max_foreground		/						/ error_23_in_user \
	/ Max_background		/						/ error_23_in_user \
	/ Abs_foreground_cpu_limit	/						/ error_23_in_user \
	/ Cutoff			/						/ error_23_in_user \
	/ Limit			/						/ error_23_in_user \
	/ Shift_limit		/						/ error_23_in_user \
	/ User_warn_days		/						/ error_23_in_user \
	/ User_warn_percent		/						/ error_23_in_user \
	/ User_warn_dollars		/						/ error_23_in_user \
	/ Warn_days		/						/ error_23_in_user \
	/ Warn_percent		/						/ error_23_in_user \
	/ Warn_dollars		/						/ error_23_in_user \
	/ Ring			/						/ error_23_in_user \
	/ Audit			/						/ error_23_in_user \
	/ Authorization		/						/ error_23_in_user \
	/ Group			/						/ error_23_in_user \
	/ end			/						/ error_23_in_user \
	/ personid		/						/ error_23_in_user \
	/ ring			/						/ error_23_in_user \
	/ initproc		/						/ error_23_in_user \
	/ subsystem		/						/ error_23_in_user \
	/ homedir			/						/ error_23_in_user \
	/ outer_module		/						/ error_23_in_user \
	/ lot_size		/						/ error_23_in_user \
	/ kst_size		/						/ error_23_in_user \
	/ cls_size		/						/ error_23_in_user \
	/ pdir_quota		/						/ error_23_in_user \
	/ max_foreground		/						/ error_23_in_user \
	/ max_background		/						/ error_23_in_user \
	/ abs_foreground_cpu_limit	/						/ error_23_in_user \
	/ cutoff			/						/ error_23_in_user \
	/ grace			/						/ error_23_in_user \
	/ attributes		/						/ error_23_in_user \
	/ limit			/						/ error_23_in_user \
	/ shift_limit		/						/ error_23_in_user \
	/ user_warn_days		/						/ error_23_in_user \
	/ user_warn_percent		/						/ error_23_in_user \
	/ user_warn_dollars		/						/ error_23_in_user \
	/ warn_days		/						/ error_23_in_user \
	/ warn_percent		/						/ error_23_in_user \
	/ warn_dollars		/						/ error_23_in_user \
	/ authorization		/						/ error_23_in_user \
	/ group			/						/ error_23_in_user \
	/ Accountid		/ ERROR(29) NEXT_STMT				/ user \
	/ accountid		/ ERROR(29) NEXT_STMT				/ user \
	/ <any-token>		/ ERROR(3) NEXT_STMT				/ user \
	/ <no-token>		/ ERROR(5) close					/ RETURN \

error_23_in_user
	/			/ ERROR (23) NEXT_STMT				/ user \

attrsub	/			/ [sx = ON; string(ats(ON)) = ""b; string(ats(OFF)) = ""b]	/ \
attloop	/ ;			/ LEX						/ STACK_POP \
	/ none			/ LEX						/ gobble_semi \
	/ null			/ LEX						/ gobble_semi \
	/ ^			/ LEX [sx = 1 - sx]					/ \
	/ administrator		/ LEX [ats (sx).administrator = "1"b]			/ atts \
	/ admin			/ LEX [ats (sx).administrator = "1"b]			/ atts \
	/ primary_line		/ LEX [ats (sx).primary_line = "1"b]			/ atts \
	/ nobump			/ LEX [ats (sx).nobump = "1"b]			/ atts \
	/ guaranteed_login		/ LEX [ats (sx).guaranteed_login = "1"b]		/ atts \
	/ guar			/ LEX [ats (sx).guaranteed_login = "1"b]		/ atts \
	/ anonymous		/ LEX [ats (sx).anonymous = "1"b]			/ atts \
	/ anon			/ LEX [ats (sx).anonymous = "1"b]			/ atts \
	/ nopreempt		/ LEX [ats (sx).nopreempt = "1"b]			/ atts \
	/ nolist			/ LEX [ats (sx).nolist = "1"b]			/ atts \
	/ dialok			/ LEX [ats (sx).dialok = "1"b]			/ atts \
	/ dial			/ LEX [ats (sx).dialok = "1"b]			/ atts \
	/ multip			/ LEX [ats (sx).multip = "1"b]			/ atts \
	/ multi_login		/ LEX [ats (sx).multip = "1"b]			/ atts \
	/ preempting		/ LEX [ats (sx).bumping = "1"b]			/ atts \
	/ bumping			/ LEX [ats (sx).bumping = "1"b]			/ atts \
	/ brief			/ LEX [ats (sx).brief = "1"b]				/ atts \
	/ vinitproc		/ LEX [ats (sx).vinitproc = "1"b]			/ atts \
	/ v_process_overseer	/ LEX [ats (sx).vinitproc = "1"b]			/ atts \
	/ vhomedir		/ LEX [ats (sx).vhomedir = "1"b]			/ atts \
	/ v_home_dir		/ LEX [ats (sx).vhomedir = "1"b]			/ atts \
	/ nostartup		/ LEX [ats (sx).nostartup = "1"b]			/ atts \
	/ no_start_up		/ LEX [ats (sx).nostartup = "1"b]			/ atts \
	/ no_secondary		/ LEX [ats (sx).sb_ok = "1"b]				/ atts \
	/ no_sec			/ LEX [ats (sx).sb_ok = "1"b]				/ atts \
	/ no_primary		/ LEX [ats (sx).pm_ok = "1"b]				/ atts \
	/ no_prime		/ LEX [ats (sx).pm_ok = "1"b]				/ atts \
	/ no_edit_only		/ LEX [ats (sx).eo_ok = "1"b]				/ atts \
	/ no_eo			/ LEX [ats (sx).eo_ok = "1"b]				/ atts \
	/ op_login		/ LEX [ats (sx).daemon = "1"b]			/ atts \
	/ daemon			/ LEX [ats (sx).daemon = "1"b]			/ atts \
	/ v_outer_module		/ ERROR(33) LEX					/ atts \
 	/ vdim			/ ERROR(33) LEX					/ atts \
	/ no_warning		/ LEX [ats (sx).no_warning = "1"b]			/ atts \
	/ nowarn			/ LEX [ats (sx).no_warning = "1"b]			/ atts \
	/ igroup			/ LEX [ats (sx).igroup = "1"b]			/ atts \
	/ save_pdir		/ LEX [ats (sx).save_pdir = "1"b]			/ atts \
	/ disconnect_ok		/ LEX [ats (sx).disconnect_ok = "1"b]			/ atts \
	/ save_on_disconnect	/ LEX [ats (sx).save_on_disconnect = "1"b]		/ atts \
	/ save			/ LEX [ats (sx).save_on_disconnect = "1"b]		/ atts \
	/ <any-token>		/ ERROR(4) NEXT_STMT				/ STACK_POP \
	/ <no-token>		/ ERROR(5)					/ RETURN \

atts	/ ,			/ LEX [sx = ON]					/ attloop \
gobble_semi
	/ ;			/ LEX						/ STACK_POP \
	/ <any-token>		/ ERROR(4) NEXT_STMT				/ STACK_POP \
	/ <no-token>		/ ERROR(5)					/ RETURN \

assign_default_attributes
	/			/ [string (default.at) = string (ats (ON)) & ^string (ats (OFF))]
										/ STACK_POP \

assign_user_attributes
	/			/ [string (user.at) = string (default.at) | string (ats (ON))]
				  [string (user.at) = string (user.at) & ^string (ats (OFF))]
										/ STACK_POP \

number	/			/ [t = 0]						/ \
          / <floating_number>           / cv_float_ (token_value, (0), t) LEX			/ STACK_POP \
	/ <decimal-integer>		/ [t = 1e0*token.Nvalue] LEX				/ STACK_POP \
	/ open			/ [t = BIGFLO] LEX					/ STACK_POP \
	/ <any-token>		/ ERROR(6) NEXT_STMT LEX(-1)				/ STACK_POP \
	/ <no-token>		/ ERROR(5)					/ RETURN \

default_monthlim	/ ;		/ LEX [default.dollar_limit = t]			/ STACK_POP \
	/ <any-token>		/ ERROR(7) NEXT_STMT				/ STACK_POP \
	/ <no-token>		/ ERROR(5)					/ RETURN \

monthlim	/ ;			/ LEX [user.dollar_limit = t]				/ STACK_POP \
	/ <any-token>		/ ERROR(7) NEXT_STMT				/ STACK_POP \
	/ <no-token>		/ ERROR(5)					/ RETURN \

default_cutoff	/ ;		/ LEX [default.absolute_limit = t]			/ STACK_POP \
	/ ,			/ LEX PUSH(get_default_increment) PUSH(check_date) 	/ concatenate_date \
	/			/ ERROR(8) NEXT_STMT				/ STACK_POP \

cutoff	/ ;			/ LEX [user.absolute_limit = t]			/ STACK_POP \
	/ ,			/ LEX PUSH(get_increment) PUSH(check_date) 		/ concatenate_date \
	/			/ ERROR(8) NEXT_STMT				/ STACK_POP \

get_default_increment
	/ ;			/ [default.absolute_limit = t]
				  [default.absolute_cutoff = time] LEX			/ STACK_POP \
	/ , <increment> ;		/ [default.absolute_limit = t]
				  [default.absolute_cutoff = time]
				  [default.absolute_increm = x] LEX(3)			/ STACK_POP \
	/			/ ERROR(8) NEXT_STMT				/ STACK_POP \

get_increment
	/ ;			/ [user.absolute_limit = t]
				  [user.absolute_cutoff = time] LEX			/ STACK_POP \
	/ , <increment> ;		/ [user.absolute_limit = t]
				  [user.absolute_cutoff = time]
				  [user.absolute_increm = x] LEX(3)			/ STACK_POP \
	/			/ ERROR(8) NEXT_STMT				/ STACK_POP \

concatenate_date
	/			/ [date_string = ""]				/ \
date_loop / ;			/						/ STACK_POP \
	/ ,			/						/ STACK_POP \
	/ <any-token>		/ [date_string = date_string || token_value || " "] LEX	/ date_loop \
	/ <no-token>		/ ERROR(8)					/ STACK_POP \

check_date
	/ <okdate>		/ 						/ STACK_POP \
	/			/ ERROR(28)			 		/ STACK_POP \

default_shiftlims	/ ;		/ LEX [default.shift_limit(x) = t]			/ STACK_POP \
	/ ,			/ LEX [default.shift_limit(x) = t] bump_x		/ default_shiftlims \
	/			/ PUSH(default_shiftlims)				/ number \


shiftlims	/ ;			/ LEX [user.shift_limit(x) = t]			/ STACK_POP \
	/ ,			/ LEX [user.shift_limit(x) = t] bump_x			/ shiftlims \
	/			/ PUSH(shiftlims)					/ number \

default_warn_doll	/ ;		/ LEX [default.warn_dollars = t]			/ STACK_POP \
	/ <any-token>		/ ERROR(7) NEXT_STMT				/ STACK_POP \
	/ <no-token>		/ ERROR(5)					/ RETURN \

warn_doll	/ ;			/ LEX [user.warn_dollars = t]				/ STACK_POP \
	/ <any-token>		/ ERROR(7) NEXT_STMT				/ STACK_POP \
	/ <no-token>		/ ERROR(5)					/ RETURN \

default_user_warn_doll	/ ;	/ LEX [default.user_warn_dollars = t]			/ STACK_POP \
	/ <any-token>		/ ERROR(7) NEXT_STMT				/ STACK_POP \
	/ <no-token>		/ ERROR(5)					/ RETURN \

user_warn_doll/ ;			/ LEX [user.user_warn_dollars = t]			/ STACK_POP \
	/ <any-token>		/ ERROR(7) NEXT_STMT				/ STACK_POP \
	/ <no-token>		/ ERROR(5)					/ RETURN \


   ++*/

/* format: style4 */
cv_pmf: procedure;

/* automatic */

dcl  (APstmt, APtoken, areap, pdtep, pdtp, pmfp) ptr;

dcl  1 default aligned like user;
dcl  1 ats (0:1) aligned like user.at;			/* ats (0) - ON bits, ats (1) - OFF bits */

dcl  authorization_value (2) bit (72) aligned;
dcl  access_ceiling bit (72) aligned;
dcl  argc fixed bin;
dcl  argx fixed bin;
dcl  created_table_segment bit (1) aligned;
dcl  date_string char (64) varying;
dcl  dn char (168);
dcl  (supplied_en, pmf_en, pdt_en) char (32);
dcl  (i, n) fixed bin;
dcl  (time, time_now) fixed bin (71);
dcl  bitc fixed bin (24);
dcl  ap ptr;
dcl  al fixed bin (21);
dcl  ec fixed bin (35);
dcl  code fixed bin (35);
dcl  Default_Group char (8) aligned;
dcl  length_of_project_name fixed bin;
dcl  t float bin;
dcl  x fixed bin;
dcl  sx fixed bin;					/* "state index" - whether attribute bit is ON or OFF */
dcl  have_anon bit (1) init ("0"b);
dcl  (default_subsystem, user_subsystem) char (64) aligned; /* put off packing initproc and subsystem together until
						   closing user entry */
dcl  fb35 fixed bin (35);
dcl  (satp, satep) pointer;
dcl  old_pdtp pointer;
dcl  can_check_old_pdt bit (1) aligned init ("0"b);
dcl  project_dir_acc bit (72) aligned;
dcl  project_dir_acc_name char (200);

/* based */

dcl  bchr char (al) unal based (ap);

/* builtin */

declare  (addr, addwordno, bool, character, clock, collate, dimension, divide, index, length, max, null, 
         rtrim, string, substr, verify) builtin;

/* conditions */

declare  cleanup condition;

/* entries */

dcl  aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  convert_access_class_$to_string_short entry (bit (72) aligned, character (*), fixed binary (35));
dcl  convert_access_class_$to_string_range_short entry ((2) bit (72) aligned, character (*),
	fixed binary (35));
dcl  convert_access_class_$from_string_range entry ((2) bit (72) aligned, char (*), fixed bin (35));
dcl  system_info_$access_ceiling entry (bit (72) aligned);
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_float_ entry (char (*), fixed bin (35), float bin (27));
dcl  get_wdir_ entry () returns (char (168) aligned);
dcl  get_group_id_ entry () returns (char (32) aligned);
dcl  hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
dcl  hcs_$get_access_class entry (char (*), char (*), bit (72) aligned, fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  com_err_$suppress_name entry () options (variable);
dcl  lex_error_ entry options (variable);
dcl  lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*), bit (*),
	char (*) var, char (*) var, char (*) var, char (*) var);
dcl  lex_string_$lex entry (ptr, fixed bin, fixed bin, ptr, bit (*), char (*), char (*), char (*), char (*), char (*),
	char (*) var, char (*) var, char (*) var, char (*) var, ptr, ptr, fixed bin (35));
dcl  suffixed_name_$new_suffix entry (char (*), char (*), char (*), char (32), fixed bin (35));
dcl  translator_temp_$get_segment entry (char (*), ptr, fixed bin (35));
dcl  translator_temp_$release_all_segments entry (ptr, fixed bin (35));
dcl  hcs_$delentry_seg entry (ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35));
dcl  pathname_ entry (char (*), char (*)) returns (char (168));

/* internal static */

dcl  ON fixed bin initial (0) internal static;
dcl  OFF fixed bin initial (1) internal static;
dcl  first bit (1) initial ("1"b) internal static;
dcl  BIGFLO float bin init (1e37) internal static;
dcl  NEVER fixed bin (71) init			/* This date is 12/31/99 2359. */
	(1011000110010110011001001110100110111010100100000000b) internal static; /* .. if Multics last this long we will have to fix */
dcl  LEGAL char (70) aligned init
	("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'_-^`~ ") internal static;
dcl  my_name char (6) initial ("cv_pmf") internal static;
dcl  (LEXDLM, LEXCTL) char (128) var internal static;
dcl  BREAKS char (128) var internal static;
dcl  IGBREAKS char (128) var internal static;
dcl  LIVE_PDT_DIR char (168) int static options (constant) init (">system_control_1>pdt");

/* external static */

dcl  (error_table_$translation_failed,
     error_table_$badopt,
     error_table_$noentry,
     error_table_$too_many_args,
     error_table_$zero_length_seg,
     error_table_$noarg,
     error_table_$bad_conversion) fixed bin (35) external static;

dcl  cv_pmf_severity_ fixed bin (35) external init (0);

%page;
%include access_mode_values;
%page;
%include pdt;
%page;
%include sat;
%page;
%include terminate_file;
%page;
%include user_attributes;
%page;
/* program */

	dn, supplied_en, pmf_en, pdt_en = "";

	pmfp = null;				/* Initialize for cleanup handler */
	pdtp = null;				/* .. */
	areap = null;				/* .. */
	old_pdtp = null ();
	created_table_segment = ""b;

	on cleanup begin;
		call clean_up;
		cv_pmf_severity_ = 5;
	     end;

	call cu_$arg_count (argc, ec);
	if ec ^= 0 then do;
	     call com_err_ (ec, my_name);
	     go to severity_5_failure;
	end;

	if argc = 0 then do;
give_usage:    call com_err_$suppress_name (ec, my_name, "Usage: cv_pmf PMF (-brief|-bf|-long|-lg)");
	     go to severity_5_failure;
	end;

	do argx = 1 to argc;
	     call cu_$arg_ptr (argx, ap, al, ec);
	     if ec ^= 0 then do;
argument_error:
		call com_err_ (ec, my_name, "^a", bchr);
		go to severity_5_failure;
	     end;
	     if character (bchr, 1) ^= "-" then do;
		if supplied_en ^= ""
		then do;
		     call com_err_ (error_table_$too_many_args, my_name, "Only one pathname may be given. ^a was the second.", bchr);
		     go to severity_5_failure;
		end;

		call expand_pathname_ (bchr, dn, supplied_en, ec);
		if ec ^= 0 then do;
path_error:
		     call com_err_ (ec, my_name, "^a", bchr);
		     go to severity_5_failure;
		end;
		call expand_pathname_$add_suffix (bchr, "pmf", dn, pmf_en, ec);
		if ec ^= 0 then go to path_error;

		call suffixed_name_$new_suffix (supplied_en, "pmf", "pdt", pdt_en, ec); /* if we get this far, how can we fail? */
		if ec ^= 0			/* still, let's have a look */
		then go to path_error;

	     end;					/* Pathname case */
	     else if bchr = "-bf" then SERROR_CONTROL = "01"b;
	     else if bchr = "-brief" then SERROR_CONTROL = "01"b;
	     else if bchr = "-long" | bchr = "-lg" then SERROR_CONTROL = "10"b;
	     else if bchr = "-severity" | bchr = "-sv" then do;
		if argx >= argc then do;
		     call com_err_ (error_table_$noarg, my_name, "After ""^a"".", bchr);
		     go to severity_5_failure;
		end;
		argx = argx + 1;
		call cu_$arg_ptr (argx, ap, al, ec);
		fb35 = cv_dec_check_ (bchr, ec);
		if ec ^= 0 | fb35 < 0 | fb35 > 5 then do;
		     call com_err_ (error_table_$bad_conversion, my_name,
			"Severity must be an integer in the range 0 - 5, not ""^a"".", bchr);
		     go to severity_5_failure;
		end;
		MIN_PRINT_SEVERITY = fb35;
	     end;
	     else do;
		ec = error_table_$badopt;
		go to argument_error;
	     end;
	end;					/* argument processing */

	if supplied_en = "" then go to give_usage;

	call system_info_$access_ceiling (access_ceiling);
	time_now = clock ();

	call initiate_file_ (dn, pmf_en, R_ACCESS, pmfp, bitc, ec);
	if ec = error_table_$noentry
	then if pmf_en ^= supplied_en
	     then do;
		call initiate_file_ (dn, supplied_en, R_ACCESS, pmfp, bitc, ec);
		if ec = 0
		then do;
		     call com_err_ (0, my_name, "converting ^a. Please type ""help cv_pmf.changes"".",
			pathname_ (dn, supplied_en));
		     pmf_en = supplied_en;
		end;
	     end;
	if ec ^= 0
	then do;
pmf_error:
	     call com_err_ (ec, my_name, "^a.", pathname_ (dn, pmf_en));
	     go to severity_5_failure;
	end;

	n = divide (bitc + 8, 9, 24, 0);
	if n = 0 then do;
	     ec = error_table_$zero_length_seg;
	     go to pmf_error;
	end;
	dn = get_wdir_ ();
	call hcs_$make_seg (dn, pdt_en, "", 1010b, pdtp, ec);
	created_table_segment = (ec = 0);
	if pdtp = null then do;
pdt_error:
	     call com_err_ (ec, my_name, "^a", pathname_ (dn, pdt_en));
	     go to severity_5_failure;
	end;

	call hcs_$truncate_seg (pdtp, 0, ec);
	if ec ^= 0 then go to pdt_error;

	pdt.author.proc_group_id = get_group_id_ ();	/* Initialize the header of the new pdt */
	pdt.author.table = "PDT";
	pdt.author.w_dir = substr (dn, 1, length (pdt.author.w_dir));
	pdt.author.lock = ""b;
	pdt.author.last_install_time = 0;
	pdt.version = PDT_version;
	pdt.max_size = 1019;

	pdtep = addr (pdt.user (1));			/* Zero the defaults.. */
	default = user;				/* .. the lazy way */
	pdtep = addr (default);			/* Set up pdtep to point at the defaults. */
	default.person_id = "";			/* Initialize defaults. */
	default.password = " ";
	default.initial_procedure = "process_overseer_";
	default.ip_len = 17;			/* number of chars in initproc name */
	default.uflags.ip_given = "1"b;
	default.outer_module = "";			/* dft outer module will be supplied by ans svc */
	default.group = "";
	default.dollar_charge = 0e0;
	default.last_login_unit = " ";

	user.interactive.charge (*) = 0e0b;
	user.absentee.charge (*) = 0e0b;
	user.iod.charge (*) = 0e0b;
	user.devices (*) = 0e0b;

	default.absolute_limit, default.dollar_limit = BIGFLO;
	default.absolute_spent = 0e0;
	default.absolute_cutoff = NEVER;
	default.user_warn_days = 10;
	default.user_warn_pct = 10;
	default.user_warn_dollars = 10e0;
	default.warn_days = 10;
	default.warn_pct = 10;
	default.warn_dollars = 10e0;
	default.bump_grace = 2880;
	default.low_ring, default.default_ring = 4;
	default.high_ring = 5;
	do i = 0 to 7;
	     default.shift_limit (i) = BIGFLO;
	end;
	default.home_dir = "";
	default.user_authorization = ""b;		/* system low by default */
	Default_Group = "";

	call translator_temp_$get_segment (my_name, areap, code);
	if areap = null then do;
	     call com_err_ (code, my_name, "While making a temporary segment in the process directory.");
	     go to severity_5_failure;
	end;

	if first then do;
	     BREAKS = substr (collate (), 1, 8) || substr (collate (), 10, 24) || "()*,:;^";
	     IGBREAKS = substr (collate (), 1, 8) || substr (collate (), 10, 24);
	     call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, BREAKS, IGBREAKS, LEXDLM, LEXCTL);
	     first = "0"b;
	end;

	call lex_string_$lex (pmfp, n, 0, areap, "100"b,
	     """", """", "/*", "*/", ";", BREAKS, IGBREAKS,
	     LEXDLM, LEXCTL, APstmt, APtoken, ec);

	Pthis_token = APtoken;
	call SEMANTIC_ANALYSIS ();
	pdt.project_dir = ">user_dir_dir>" || pdt.project_name;

abort:	if MERROR_SEVERITY > 2 then do;
	     call com_err_ (error_table_$translation_failed, my_name, pmf_en);
	     if created_table_segment then bitc = -1;	/* delete it */
	     else bitc = 0;
	end;
	else bitc = (PDT_header_lth + PDT_entry_lth * pdt.current_size) * 36;
	if bitc >= 0 then do;			/* if not deleting it */
	     call terminate_file_ (pdtp, bitc, TERM_FILE_TRUNC_BC_TERM, ec);
	     if ec ^= 0 then do;
		call com_err_ (ec, my_name, "Unable to set bitcount on ^a to ^d.", pathname_ (dn, pdt_en), bitc);
		go to severity_5_failure;
	     end;
	end;

	cv_pmf_severity_ = MERROR_SEVERITY;
	call clean_up;
	return;

severity_5_failure:
	call clean_up;
	cv_pmf_severity_ = 5;
	return;

%page;
clean_up:
     procedure;

	if pmfp ^= null
	then call terminate_file_ (pmfp, (0), TERM_FILE_TERM, (0));

	if old_pdtp ^= null
	then call terminate_file_ (old_pdtp, (0), TERM_FILE_TERM, (0));

	if pdtp ^= null				/* delete or truncate */
	then if created_table_segment
	     then do;
		call hcs_$delentry_seg (pdtp, (0));
		pdtp = null;
	     end;
	     else call terminate_file_ (pdtp, 0, TERM_FILE_TRUNC_BC_TERM, (0));

	if areap ^= null
	then call translator_temp_$release_all_segments (areap, (0));

     end clean_up;

/* SYNTAX FUNCTIONS */

path_name: proc () returns (bit (1) aligned);
dcl  ec fixed bin (35);
dcl  dn char (168);
dcl  en char (32);

	call expand_pathname_ (token_value, dn, en, ec);
	if ec ^= 0 then return ("0"b);
	else return ("1"b);

     end path_name;

onetoseven: proc () returns (bit (1) aligned);
dcl  i fixed bin;

	if token.Lvalue ^= 1 then return ("0"b);
	i = index ("1234567", token_value);
	if i = 0 then return ("0"b);
	token.Nvalue = i;
	return ("1"b);

     end onetoseven;

floating_number: proc () returns (bit (1) aligned);
dcl  ec fixed bin (35);
dcl  foo float bin;

	if verify (token_value, "0123456789.-") ^= 0 then
	     return ("0"b);
	call cv_float_ (token_value, ec, foo);
	if ec ^= 0 then return ("0"b);
	else return ("1"b);

     end floating_number;

okdate: proc () returns (bit (1) aligned);
dcl  ec fixed bin (35);

	if date_string = "now" then do;
	     time = time_now;
	     return ("1"b);
	end;
	if date_string = "open" then go to x1;
	if date_string = "never" then do;
x1:	     time = NEVER;
	     return ("1"b);
	end;
	call convert_date_to_binary_ ((date_string), time, ec);
	if ec ^= 0 then return ("0"b);
	return ("1"b);

     end okdate;

increment: proc () returns (bit (1) aligned);

	if token_value = "never" then x = 0;
	else if token_value = "yearly" then x = 3;
	else if token_value = "daily" then x = 1;
	else if token_value = "monthly" then x = 2;
	else if token_value = "cyear" then x = 4;
	else if token_value = "fyear" then x = 5;
	else if token_value = "weekly" then x = 6;
	else return ("0"b);
	return ("1"b);

     end increment;

authorization_string:
     procedure () returns (bit (1) aligned);

	call convert_access_class_$from_string_range (authorization_value, token_value, code);
	return (code = 0);

     end authorization_string;

check_default_authorization:
     procedure;

declare  temp_string char (200);

	/*** First check complete disjunction */

	if ^can_check_old_pdt then return;
	call convert_access_class_$to_string_range_short (project.project_authorization, temp_string, (0));
	if ^aim_check_$greater_or_equal (default.user_authorization (2), project.project_authorization (1))
	     | ^aim_check_$greater_or_equal (project.project_authorization (2), default.user_authorization (1))
	then do;
	     call error_in_general (38, temp_string, ""); /* completely disjoint */
	     return;
	end;

	if aim_check_$greater (default.user_authorization (2), project.project_authorization (2))
	then call error_in_general (39, temp_string, ""); /* may not be able to log in */
	if aim_check_$greater (project.project_authorization (1), default.user_authorization (1))
	then call error_in_general (40, temp_string, "");
	return;
     end check_default_authorization;

check_user_authorization:
     procedure;

declare  temp_string char (200);

	/*** First check complete disjunction */

	if ^can_check_old_pdt then return;
	call convert_access_class_$to_string_range_short (project.project_authorization, temp_string, (0));

	if ^aim_check_$greater_or_equal (user.user_authorization (2), project.project_authorization (1))
	     | ^aim_check_$greater_or_equal (project.project_authorization (2), user.user_authorization (1))
	then do;
	     call error_in_person (41, temp_string);	/* completely disjoint */
	     return;
	end;

	if aim_check_$greater (user.user_authorization (2), project.project_authorization (2))
	then call error_in_person (42, temp_string);	/* may not be able to log in */
	if aim_check_$greater (project.project_authorization (1), user.user_authorization (1))
	then call error_in_person (43, temp_string);
	return;

     end check_user_authorization;

/* SEMANTIC FUNCTIONS */

set_project_name:
     procedure;

	pdt.project_name = token_value;
	length_of_project_name = length (token_value);

	if verify (token_value, LEGAL) ^= 0
	then call ERROR (21);
	else if index (substr (LEGAL, 1, 36), substr (token_value, 1, 1)) = 0
	then call ERROR (21);

	if length (token_value) > PDT_project_name_length
	then do;
	     call ERROR (24);			/* Project name > 9 characters */
	     length_of_project_name = PDT_project_name_length;
	end;

	call find_old_pdt;
	return;
     end set_project_name;


set_ip_ss: proc (ip_ss, ip_ss_given, ip_ss_len);
dcl  ip_ss char (64) aligned;
dcl  ip_ss_given bit (1) unaligned;
dcl  ip_ss_len fixed bin (17) unaligned;

/* check the 64 character limit */

	if token.Lvalue > 64 then do;
	     call ERROR (31);
	     return;
	end;

/* copy the string and its length, and turn on the switch that says it was given */

	ip_ss = token_value;
	ip_ss_len = token.Lvalue;
	ip_ss_given = "1"b;

	return;

     end set_ip_ss;


set_string: proc (keyword, field, value);
dcl  keyword char (*);
dcl  field char (*) aligned;
dcl  value char (*);

	if length (value) <= length (field) then
	     field = value;
	else if error_control_table (34).severity >= MIN_PRINT_SEVERITY then
	     call lex_error_ (34, SERROR_PRINTED (34), (error_control_table (34).severity),
		MERROR_SEVERITY, null, Pthis_token, SERROR_CONTROL, (error_control_table (34).message),
		(error_control_table (34).brief_message), keyword, length (field));
	else do;
	     MERROR_SEVERITY = max (MERROR_SEVERITY, error_control_table (34).severity);
	     SERROR_PRINTED (34) = "1"b;
	end;
     end;

bump_x: proc;

	if x = 0 then do;
	     call ERROR (7);			/* Error in limit */
	     call NEXT_STMT;			/* Get to next statement. */
	     Ptoken, Pthis_token = Pthis_token -> token.Plast;
						/* Back up so will find semicolon */
	     return;
	end;
	x = x + 1;
	if x = 8 then x = 0;

     end bump_x;

open: proc;

dcl  i fixed bin;
dcl  p ptr;

	if pdt.current_size = pdt.max_size then do;
	     call ERROR (9);
	     go to abort;
	end;

	if token.Lvalue > PDT_person_id_length
	then call ERROR (26);

	if verify (token_value, LEGAL) ^= 0
	then call ERROR (10);
	else if index (substr (LEGAL, 11, 26), substr (token_value, 1, 1)) = 0
	then call ERROR (11);

/* now check to see whether or not personid is unique in table */

	do i = 1 to pdt.current_size;
	     p = addr (pdt.user (i));			/* get pointer to next entry */
	     if token_value = p -> user.person_id
	     then call ERROR (13);
	end;

	pdt.current_size, pdt.n_users = pdt.n_users + 1;
	pdtep = addr (pdt.user (pdt.n_users));
	user = default;
	user_subsystem = default_subsystem;
	user.state = 1;
	user.person_id = token_value;

     end open;

open_anon: proc;

	if pdt.current_size = pdt.max_size then do;
	     call ERROR (9);
	     go to abort;
	end;

	if have_anon
	then call ERROR (12);

	have_anon = "1"b;
	pdt.current_size, pdt.n_users = pdt.n_users + 1;
	pdtep = addr (pdt.user (pdt.n_users));
	user = default;
	user_subsystem = default_subsystem;
	user.state = 1;
	user.person_id = "*";
	user.home_dir = "";				/* Default does not apply */
	user.initial_procedure = "";			/* .. without a warning */

     end open_anon;

close: proc;

dcl  ec fixed bin (35);
dcl  (hdd, hddd) char (168);
dcl  (hdde, hde) char (32);

	if user.ip_len + user.ss_len > 64 then
	     call ERROR (32);
	else substr (user.initial_procedure, user.ip_len + 1, user.ss_len) =
		substr (user_subsystem, 1, user.ss_len);

	if pdt.current_size = 0 then return;

	if user.person_id = "*" then do;
	     if user.home_dir = "" then do;
		call ERROR (14);
		user.home_dir = ">user_dir_dir>" || pdt.project_name;
	     end;
	     if user.password = "" then call ERROR (15);

	     if user.initial_procedure = "" then do;
		call ERROR (16);
		user.initial_procedure = default.initial_procedure;
		user.dont_call_init_admin = default.dont_call_init_admin;
	     end;
	end;
	else do;					/* Normal user. */
	     if user.password ^= "" then do;
		call error_in_person (27, "");
		user.password = "";
	     end;

	     if user.home_dir = ""
	     then user.home_dir = ">user_dir_dir>" ||
		     substr (pdt.project_name, 1, length_of_project_name) ||
		     ">" || user.person_id;
	end;

	if user.low_ring > user.high_ring |
	     user.low_ring > user.default_ring |
	     user.default_ring > user.high_ring |
	     user.low_ring < 1 |
	     user.high_ring > 7
	then call error_in_person (37, "");

	if substr (user.home_dir, 1, 1) ^= ">"
	     & substr (user.home_dir, 1, 5) ^= "[pd]>"
	then call error_in_person (17, (user.home_dir));
	else do;
	     call expand_pathname_ ((user.home_dir), (dn), (supplied_en), ec);
	     if ec ^= 0 then
		call error_in_person (18, (user.home_dir));
	end;

	user.at.eo_ok = ^(user.at.eo_ok);
	user.at.sb_ok = ^(user.at.sb_ok);
	user.at.pm_ok = ^(user.at.pm_ok);

/* if both bits off */
	if bool (user.at.pm_ok, user.at.sb_ok, "1000"b) then
	     call error_in_person (19, "");

	if user.bumping then
	     if ^user.pm_ok then
		call error_in_person (20, "");

	if user.at.igroup then
	     if user.group = "" then
		if Default_Group = "" then do;
		     call error_in_person (30, "");
		     user.at.igroup = "0"b;
		end;
		else user.group = Default_Group;

	if user.group ^= "" then user.at.igroup = "1"b;

	if user.at.save_on_disconnect then		/* as documented in MAM Project, setting default of -save */
	     user.at.disconnect_ok = "1"b;		/* implies giving permission for -save */

/* the following call to adjust_cutoff_ has been commented out.  The reason
   is that if we allow the installation process to adjust_cutoff_, then
   it is possible for a project administrator to change to a finer cutoff gradation,
   and cause the users spending against cutoff to be reset at table installation time.
   e.g. to put user with absolute cutoff of $400 dollars into $20 daily cutoff,
   specify "cutoff: 20,<yesterday>,daily;"
   If the adjust_cutoff_ in cv_pmf_ remains, the users absolute spent (spent against cutoff)
   will not be reset until the next cutoff date occurs.  In above example, if
   user had spent more than $20 when the cutoff was 'never', the user would not
   be able to log in until the day following pdt installation.
   If someone decides it's a bad idea to support this, put the call back in!
   MEANWHILE, let's at least give a warning if the date is in the past... */

/* 	     call adjust_cutoff_ (pdtep, time_now);	/* fixup cutoff dates */

	if user.absolute_increm > 0 then		/* not absolute cutoff */
	     if user.absolute_cutoff < time_now then	/* at a time in the past */
		call error_in_person (36, "");


	call expand_pathname_ ((user.home_dir), hdd, hde, code);
	if code = 0 then do;
	     call hcs_$status_minf (hdd, hde, (1), (0), (0), code);
	     call expand_pathname_ (hdd, hddd, hdde, (0));
	     call hcs_$get_access_class (hddd, hdde, project_dir_acc, code);
	     if code ^= 0 then project_dir_acc = ""b;
	     if code = error_table_$noentry then do;
		if aim_check_$greater (user.user_authorization (1), project_dir_acc)
		then do;
		     project_dir_acc_name = "";
		     call convert_access_class_$to_string_short (project_dir_acc, project_dir_acc_name, (0));
		     call error_in_person (44, project_dir_acc_name);
		end;
	     end;
	end;

	return;
     end close;

error_in_person:
     procedure (bv_errorx, bv_string);

/* parameters */

dcl  (bv_errorx fixed bin,
     bv_first_string char (*),
     bv_string char (*)) parameter;

/* automatic */

dcl  ex fixed bin;
dcl  first_string char (500);

/* program */

	first_string = user.person_id;
	go to common;

error_in_general:
     entry (bv_errorx, bv_first_string, bv_string);

	first_string = bv_first_string;

common:
	ex = bv_errorx;
	if error_control_table (ex).severity >= MIN_PRINT_SEVERITY then
	     call lex_error_ (ex, SERROR_PRINTED (ex), (error_control_table (ex).severity),
		MERROR_SEVERITY, null, Pthis_token, SERROR_CONTROL, (error_control_table (ex).message),
		(error_control_table (ex).brief_message), first_string, bv_string);
	else do;
	     MERROR_SEVERITY = max (MERROR_SEVERITY, error_control_table (ex).severity);
	     SERROR_PRINTED (ex) = "1"b;
	end;

     end error_in_person;

find_old_pdt:
     procedure;

	call initiate_file_ (LIVE_PDT_DIR, rtrim (pdt.project_name) || ".pdt", R_ACCESS, old_pdtp, (0), code);
	if code ^= 0 then return;			/* can_check_old_pdt still = 0 */

	if old_pdtp -> pdt.sat_version ^= SAT_version
	then do;
	     call terminate_file_ (old_pdtp, (0), TERM_FILE_TERM, (0));
	     return; /* can_check_old_pdt still equals 0 */
	end; 
	can_check_old_pdt = "1"b;

	satep = addwordno (addr (old_pdtp -> pdt.satentry), -24); /* magic amount of PDT abstracted from front */
	return;
     end find_old_pdt;


%page;
dcl  1 error_control_table (44) aligned int static options (constant),
       2 severity fixed bin (17) unal init (
	  (8) 3,					/* 1-8 */
	  3,					/* 9 */
	  3,					/* 10 */
	  1,					/* 11 */
	  (2) 3,					/* 12-13 */
	  (3) 1,					/* 14-16 */
	  (2) 3,					/* 17-18 */
	  (2) 1,					/* 19-20 */
	  (6) 3,					/* 21-26 */
	  1,					/* 27 */
	  3,					/* 28 */
	  (2) 1,					/* 29-30 */
	  (2) 3,					/* 31-32 */
	  1,					/* 33 */
	  (2) 3,					/* 34-35 */
	  1,					/* 36 */
	  3,					/* 37 */
	  (7) 1),					/* 38-44 */
       2 Soutput_stmt bit (1) unaligned initial (
	  (4) (1)"1"b,				/* 1-4 */
	  "0"b,					/* 5 */
	  (8) (1)"1"b,				/* 6-13 */
	  (3) (1)"0"b,				/* 14-16 */
	  (10) (1)"1"b,				/* 17-26 */
	  "0"b,					/* 27 */
	  (2) (1)"1"b,				/* 28-29 */
	  "0"b,					/* 30 */
	  "1"b,					/* 31 */
	  (2) (1)"1"b,				/* 32-33 */
	  "1"b,					/* 34 */
	  "0"b,					/* 35 */
	  "0"b,					/* 36 */
	  "0"b,					/* 37 */
	  (6) (1)"1"b,				/* 38-43 */
	  "0"b),					/* 44 */
       2 message char (100) var init
	  ("Unrecognizable statement.",		/* 1 */
	  "PMF does not begin with a valid ""Projectid"" statement.", /* 2 */
	  "Unrecognizable statement.",		/* 3 */
	  "Unknown attribute ""^a"".",		/* 4 */
	  "Premature end of PMF encountered.",		/* 5 */
	  "Invalid item encountered where number expected: ""^a"".", /* 6 */
	  "Invalid item encountered in limit: ""^a"".",	/* 7 */
	  "Invalid format for cutoff specification.",	/* 8 */
	  "Too many users declared in PMF. Maximum is 1019.", /* 9 */
	  "Invalid letter in personid ""^a"".",		/* 10 */
	  "Personid ""^a"" does not begin with a capital letter.", /* 11 */
	  "Only one anonymous user may be specifed in a PMF.", /* 12 */
	  "Personid ""^a"" is specified more than once in the PMF.", /* 13 */
	  "Anonymous user had no ""homedir"" statement; assuming project directory.", /* 14 */
	  "Anonymous user has no password specified.",	/* 15 */
	  "Anonymous user has no initial procedure specified.", /* 16 */
	  "Home directory for user ""^a"" does not begin with "">"" or ""[pd]>"": ^a.", /* 17 */
	  "Home directory for user ""^a"" has illegal syntax: ^a.", /* 18 */
	  "User ""^a"" has both ""no_primary"" and ""no_secondary"" and will be unable to log in.", /* 19 */
	  "User ""^a"" has ""preempting"" and ""no_primary"" attributes.", /* 20 */
	  "Syntax error in project identifier.",	/* 21 */
	  "Invalid specification of path name.",	/* 22 */
	  "Syntax error in ""^a"" statement.",		/* 23 */
	  "Project name ""^a"" is longer than the limit of 9 characters.", /* 24 */
	  "Unable to convert authorization string ""^a"".", /* 25 */
	  "User name ""^a"" is longer than the limit of 22 characters.", /* 26 */
	  "Personid ""^a"" has a password that will be ignored.", /* 27 */
	  "Invalid date/time in cutoff statement.",	/* 28 */
	  "The ^a statement is obsolete and has been ignored.", /* 29 */
	  "Personid ""^a"" has ""igroup"" but no group specified.", /* 30 */
	  "Pathname of initial procedure or subsystem > 64 characters:^/^a", /* 31 */
	  "Sum of initial procedure and subsystem lengths > 64 characters, in preceding user entry (or header)", /* 32 */
	  "The ""^a"" attribute is obsolete and has been ignored.", /* 33 */
	  "The maximum length of the ""^a"" field is ^d.",/* 34 */
	  "Text follows logical end of PMF.",		/* 35 */
	  "Incremental cutoff is in the past. Spending against cutoff will be reset at user's next login.", /* 36 */
	  "Bad ring order. ""ring: low, high {,default};"" must have values 1 <= low <= default <= high <= 7.", /* 37 */
	  "Default authorization range is disjoint from project authorization range ^a.",
	  "Default max authorization is out of project range ^a.",
	  "Default min authorization is out of project range ^a.",
	  "User ^a authorization range is disjoint from project authorization range ^a.",
	  "User ^a max authorization is out of project range ^a.",
	  "User ^a min authorization is out of project range ^a.",
             "User ^a will need an upgraded home dir, which you must create manually."),

       2 brief_message char (20) var init (
	  (3) (1)"",				/* 1-3 */
	  "^a",					/* 4 */
	  "",					/* 5 */
	  (2) (1)"^a",				/* 6-7 */
	  (2) (1)"",				/* 8-9 */
	  (2) (1)"^a",				/* 10-11 */
	  "",					/* 12 */
	  "^a",					/* 13 */
	  (3) (1)"",				/* 14-16 */
	  (2) (1)"^a bad homedir ^a",			/* 17-18 */
	  (2) (1)"^a",				/* 19-20 */
	  (3) (1)"",				/* 21-23 */
	  (4) (1)"^a",				/* 24-27 */
	  "Invalid date/time",			/* 28 */
	  "",					/* 29 */
	  "^a",					/* 30 */
	  "^a",					/* 31 */
	  "",					/* 32 */
	  "^a",					/* 33 */
	  "",					/* 34 */
	  "",					/* 35 */
	  "",					/* 36 */
	  "",					/* 37 */
	  (3) (0)"",				/* 38-43 */
	  "^a",
	  "^a",
	  "^a",
	  "^a");


/* ======================================================== */




		    display_account_status.pl1      08/29/88  0940.1rew 08/29/88  0856.4      102510



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(87-08-14,Hartogs), approve(88-08-15,MCR7969),
     audit(88-08-04,Lippard), install(88-08-29,MR12.2-1093):
     Changed to display <none> when there are no authorized groups in -long
     output. (phx16057)
                                                   END HISTORY COMMENTS */


/*  DISPLAY_ACCOUNT_STATUS - command to print the contents of the various account files
   that have been copied into the PDT.

   USAGE:   display_account_status {project_name} {control_args}
   -brief,-bf -no_header,-nhe and -long,-lg are accepted
*/

/*
   Initial coding June 1977 by John Gintell
   Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures. (UNCA)
   Modified Apr 1980 by J. N. R. Barnecut to print requistion amount. (UNCA)
   Modified March 1981 by John Gintell for MCR 4851
   Modified June 1981 by E. N. Kittlitz for multiple rate structures.
   Modified 1984-08-27 BIM for login auth ranges, projfile/reqfile versions.
   Modified 1984-12-14 by EJ Sharpe for new audit flags
*/

display_account_status: das: procedure;



/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

dcl  ctr fixed bin init (0);
dcl  authorization_string char (500);
dcl  audit_string char (256);
dcl  disk_price float bin;
dcl  disk_chg float bin (63);
dcl  dum (0:7) float bin;
dcl (an, nargs) fixed bin;
dcl  rs_name char (32);
dcl  attr varying char (512);
dcl (pdt_dir, pdt_path) char (168) aligned;
dcl  projname char (9);
dcl  namexx char (24);
dcl  accxx char (32);
dcl  datestr char (16) aligned;
dcl  date_string char (24) aligned;
dcl  sel_name char (32) aligned init ("");
dcl  pdt_name char (32) aligned;
dcl (i, slng) fixed bin;
dcl  code fixed bin (35);
dcl  no_header bit (1) init (""b);
dcl  brief bit (1) init (""b);
dcl  pmf bit (1) init (""b);
dcl  long bit (1) init (""b);
dcl (argp, pdtep, pdtp) ptr;
dcl (pp, qp, satp, satep) ptr;
dcl (projp, reqp) ptr;
dcl  max_rs_number fixed bin;

dcl 1 req based (reqp) aligned,
    2 entry like reqfile.reqfiletab;
dcl 1 proj based (projp),
    2 entry like projfile.projfiletab;

/* DECLARATION OF INTERNAL STATIC */

dcl  NEVER fixed bin (71) int static init		/* This date is 12/31/99 2359. */
    (1011000110010110011001001110100110111010100100000000b); /* .. if Multics last this long we will have to fix */

dcl  myname static char (22) init ("display_account_status") options (constant);

/* DECLARATION OF BASED STRUCTURES */

dcl  arg char (slng) unaligned based (argp);


/* DECLARATION OF BUILTIN FUNCTIONS */

dcl (addr, addrel, clock, divide, length, max, null, search, substr, rtrim, unspec) builtin;

/* DECLARATION OF EXTERNAL ENTRIES */

dcl  expand_pathname_ entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35));
dcl  format_attributes_ entry (ptr, char (*) var);
dcl  convert_access_audit_flags_$to_string entry (bit (36) aligned, char (*), fixed bin (35));
dcl  convert_access_class_$to_string_range entry ( (2) bit (72) aligned, character (*), fixed binary (35));
dcl  user_info_ entry (char (*), char (*), char (*));
dcl  date_time_ entry (fixed bin (71), char (*) aligned);
dcl  com_err_ entry options (variable);
dcl  ioa_ entry options (variable);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  system_info_$max_rs_number entry (fixed bin);
dcl  system_info_$prices_rs ext entry
    (fixed bin, (0: 7) float bin, (0: 7) float bin, (0: 7) float bin, (0: 7) float bin, float bin, float bin);
dcl  system_info_$rs_name ext entry (fixed bin, char (*), fixed bin (35));

/* DECLARATION OF EXTERNAL STATIC */

dcl  error_table_$entlong fixed bin(35) ext static;

%include pdt;
%include reqfile;
%include projfile;
%include sat;
%include user_attributes;

/* LOCATE AND INITIALIZE A PDT */

	call system_info_$max_rs_number (max_rs_number);

	pdt_path = "";				/* keep ERR from crapping out */
	call cu_$arg_count (nargs, code);
	if code ^= 0 then go to ERR;

	an = 1;

	if nargs ^= 0 then do;
	     call cu_$arg_ptr (1, argp, slng, code);	/* get 1st arg: name of pdt */
	     if substr (arg, 1, 1) ^= "-" then do;
		pdt_path = arg;
		if substr (pdt_path, max (slng-3, 1), 4) ^= ".pdt" then do;
		     pdt_path = rtrim (pdt_path) || ".pdt";
		end;
		an = 2;
	     end;
	     else call get_default_project;
	end;
	else call get_default_project;

	if search (pdt_path, "><") ^= 0 then do;
	     call expand_pathname_ (pdt_path, pdt_dir, pdt_name, code);
	     if code ^= 0 then do;
ERR:		call com_err_ (code, myname, "^a", pdt_path);
		return;
	     end;
	end;
	else if length(rtrim(pdt_path)) > length(pdt_name) then do;
	     call com_err_ (error_table_$entlong, myname, "^a", pdt_path);
	     return;
	end;
	else do;
	     pdt_name = substr(pdt_path,1,length(pdt_name));
	     pdt_dir = ">system_control_1>pdt";
	end;

	call hcs_$initiate (pdt_dir, pdt_name, "", 0, 0, pdtp, code);
	if pdtp = null then do;
	     call com_err_ (code, myname, "^a>^a", pdt_dir, pdt_name);
	     return;
	end;

	if pdt.projfile_version ^= PROJFILE_VERSION & pdt.reqfile_version ^= REQFILE_VERSION & pdt.sat_version ^= SAT_version then do;
	     call com_err_ ((0), myname, "PDT not in proper format.");
	     goto TERM;
	end;

	do an = an to nargs;
	     call cu_$arg_ptr (an, argp, slng, code);	/* get next arg:  a control arg */
	     if arg = "-brief" | arg = "-bf" then no_header, brief = "1"b;
	     else if arg = "-long" | arg = "-lg" then long = "1"b;
	     else if arg = "-no_header" | arg = "-nhe" then no_header = "1"b;
	     else do;
		call com_err_ (0, myname, "Unrecognized control argument - ^a", arg);
		go to TERM;
	     end;
	end;

	projp = addr (pdt.projentry);
	reqp = addr (pdt.reqentry);
	satep = addrel (addr (pdt.satentry), -24);	/* satentry is missing first 24 words */

	call system_info_$prices_rs ((pdt.rs_number), dum, dum, dum, dum, disk_price, dum (0));
	if max_rs_number > 0 then do;
	     call system_info_$rs_name ((pdt.rs_number), rs_name, code);
	     if code ^= 0 then call com_err_ (code, myname,
		"Rate structure ^d for project ^a.  Default rates will be used", pdt.rs_number, pdt_name);
	end;
	disk_chg = disk_price * proj.disk_psec;

	if ^no_header then do;
	     call date_time_ ((clock ()), datestr);
	     call ioa_ ("^/^2-^28a^3x^20a^/", pdt_name, datestr);
	     call date_time_ (pdt.date_reqfile_copied, datestr);
	     call ioa_ ("^2-Account information copied ^4x^a^/", datestr);
	     call ioa_ ("Projectid:^10x^a;", pdt.project_name);
	end;

	if brief then do;
	     call ioa_ ("month-to-date charges:  total: $^.2f, disk: $^.2f, misc: $^.2f",
		req.chg_mo, disk_chg, proj.misc_charges);
	end;
	else do;
	     if long then do;
		call ioa_ ("^/REQFILE");
		call ioa_ (" account:^-^-^a", req.mitacct);
		call ioa_ (" reqno:^-^-^a", req.reqno);
		if max_rs_number > 0 then
		     call ioa_ (" rate structure:^-^a", rs_name);
		call ioa_ (" qflag:^-^-^a", fudge0 ((req.qflag)));
		call ioa_ (" date on:^-^-^a", cv_time (req.qdn));
		call ioa_ (" date off:^-^a", cv_time (req.qdf));
		call ioa_ (" billing name:^-^a", req.billing_name);
		call ioa_ (" billing addr:^-^a", req.billing_addr);
	     end;
	     call ioa_ (" charge this month:^-$ ^12.2f", req.chg_mo);
	     call ioa_ (" charge this req:^-$ ^12.2f", req.chg_tr);
	     call ioa_ (" req amount:^-$ ^12.2f^41tbalance:^-^[OPEN^s^;$ ^.2f^]", req.req_amt, req.req_amt = 0, req.req_amt -req.chg_tr -req.chg_mo);
	     call ioa_ (" cutoff date:^-^a", cv_time (req.cutoff));
	     if long then do;
		call ioa_ ("^/PROJFILE");
		call ioa_ (" title:^-^-^a", proj.title);
		call ioa_ (" investigator:^-^a", proj.inv);
		call ioa_ (" inv address:^-^a", proj.inv_addr);
		call ioa_ (" supervisor:^-^a", proj.sup);
		call ioa_ (" sup addr:^-^a", proj.sup_addr);
		call ioa_ (" sup phone:^-^a", proj.sup_phone);
		call ioa_ (" date on:^-^-^a", cv_time (proj.on));
		call ioa_ (" date off:^-^a", cv_time (proj.off));
	     end;
	     call ioa_ (" disk page-months:^-^d,  $ ^.2f", divide (proj.disk_psec, 60*60*24*30, 35, 0), disk_chg);
	     call ioa_ (" disk quota:^-^d", proj.disk_quota);
	     call ioa_ (" disk use:^-^d", proj.disk_use);
	     call ioa_ (" dir disk use:^-^d", proj.dir_disk_use);
	     call ioa_ (" misc charges:^-$ ^.2f", proj.misc_charges);
	     call ioa_ (" # misc charges:^-^d", proj.n_misc);
	     if long then do;
		call ioa_ ("^/SAT");
		call format_attributes_ (addr (project.at), attr);
		call ioa_ (" attributes:^-^a", attr);
		do i = 1 to 4;
		     if project.userid (i) ^= "" then call ioa_ (" administrator:^-^a", project.userid (i));
		end;
		call ioa_ (" ring:^2-^d,^d", project.min_ring, project.max_ring);
		if project.alias ^= "" then call ioa_ (" alias:^2-^a", project.alias);
		call ioa_ (" default group:^-^a", fudge0 (project.group));
		call ioa_ (" authorized groups:^-^[<none>^3s^;^a^[^s^;, ^a^]",
		     fudge0(project.groups(1)) = "", 
		     fudge0(project.groups(1)), 
		     fudge0(project.groups(2)) = "",
		     fudge0(project.groups(2)));
		call ioa_ (" max grace:^-^d", project.grace_max);
		if project.audit ^= ""b then do;
		     call convert_access_audit_flags_$to_string (project.audit, audit_string, code);
		     if code ^= 0 then call com_err_ (code, myname, "Cannot convert audit string");
		     else call ioa_ (" audit flags:^-^a", audit_string);
		end;
		if project.project_authorization (1) | project.project_authorization (2) ^= ""b then do;
		     call convert_access_class_$to_string_range (project.project_authorization, authorization_string, code);
		     if code ^= 0 then authorization_string = "unknown";
		     call ioa_ (" authorization:^-^a", authorization_string);
		end;
		call ioa_ (" days to cutoff:^-^d", project.days_to_cutoff);
		call ioa_ (" percent balance:^-^d%", project.pct_balance);
		call ioa_ (" dollars to cutoff:^-$ ^.2f", project.dollars_to_cutoff);
		call ioa_ ("");
	     end;
	end;
TERM:	call hcs_$terminate_noname (pdtp, code);
	return;

get_default_project: proc;
	     call user_info_ (namexx, projname, accxx);
	     pdt_path = rtrim (projname) || ".pdt";
	end get_default_project;

cv_time:	proc (time) returns (char (24) aligned);

dcl  time fixed bin (71);

	     if time = 0 then return ("");
	     if time = NEVER then return ("");
	     call date_time_ (time, date_string);

	     return (date_string);
	end cv_time;

fudge0:	proc (input) returns (char (*));

dcl  input char (*);
	     if unspec (input) = ""b then return ("");
	     else return (input);
	end fudge0;


     end display_account_status;




		    flt_bin_sort_.pl1               11/04/82  1949.0rew 11/04/82  1608.8       25929



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


flt_bin_sort_: proc (v, x, n);

/* Singleton sort - from Max Smith */

dcl  v (*) float bin,				/* input array of strings to sort */
     x (*) fixed bin,				/* index array which will be filled in */
     n fixed bin;					/* number of items to sort */

dcl  (i, j, k, l, m) fixed bin,
     q fixed bin,
     xi fixed bin,
     xj fixed bin,
    (vxi, vxj) float bin,
     xk fixed bin,
     vxk float bin,
     xl fixed bin,
     xq fixed bin,
     vxq float bin;

dcl  stacki (18) fixed bin,
     stackj (18) fixed bin,
     cut fixed bin int static init (12);

	i, m = 1;
	j = n;
	go to test;

sloop:	k = i;
	l = j;
	q = divide (i+j, 2, 17, 0);
	xi = x (i);
	vxi = v (xi);
	xj = x (j);
	vxj = v (xj);
	xq = x (q);
	vxq = v (xq);
	if vxq < vxi then
	if vxj < vxi then
	if vxq < vxj then do;			/* vxq < vxj < vxi */
	     x (i) = xq;
	     x (q) = xj;
	     x (j) = xi;
	     vxq = vxj;
	end;
	else do;					/* vxj <= vxq < vxi */
	     x (i) = xj;
	     x (j) = xi;
	end;
	else do;					/* vxq < vxi <= vxj */
	     x (i) = xq;
	     x (q) = xi;
	     vxq = vxi;
	end;
	else if vxj < vxq then
	if vxi < vxj then do;			/* vxi < vxj < vxq */
	     x (q) = xj;
	     x (j) = xq;
	     vxq = vxj;
	end;
	else do;					/* vxj <= vxi <= vxq */
	     x (q) = xi;
	     x (i) = xj;				/* warning: x(q) before x(i) so q=i works */
	     x (j) = xq;
	     vxq = vxi;
	end;

/* here, v(x(i)) <= vxq <= v(x(j)) */

lloop:	l = l - 1;
	xl = x (l);
	if v (xl) > vxq then go to lloop;
kloop:	k = k + 1;
	xk = x (k);
	if v (xk) < vxq then go to kloop;

/* here, v(x(l)) <= vxq <= v(x(k)) */

	if k <= l then do;
	     x (k) = xl;
	     x (l) = xk;
	     go to lloop;
	end;
	if l - i > j - k then do;
	     stacki (m) = k;
	     stackj (m) = j;
	     j = l;
	end;
	else do;
	     stacki (m) = i;
	     stackj (m) = l;
	     i = k;
	end;
	m = m + 1;

test:	if j-i > cut then go to sloop;
	if i = 1 then if i < j then go to sloop;
	do i = i + 1 by 1 while (i <= j);
	     k = i;
	     xk = x (k);
	     vxk = v (xk);
bubble:	     l = k - 1;
	     xl = x (l);
	     if v (xl) <= vxk then go to ok;
	     x (k) = xl;
	     x (l) = xk;
	     k = l;
	     go to bubble;
ok:	end;
	m = m - 1;
	if m = 0 then do;
		xj=divide(n,2,17,0);
		do i = 1 to xj;
		xk= x(i);
		x(i)=x(n+1-i);
		x(n+1-i)=xk;
		end;
	    return;
	     end;
	i = stacki (m);
	j = stackj (m);
	go to test;

     end flt_bin_sort_;




		    format_attributes_.pl1          07/13/88  1120.1r w 07/13/88  0940.2       43308



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */

/* format: style4 */
format_attributes_: proc (input_attribute_ptr, output_attribute_string);

/* Written October 1979 by T. Casey to merge the old format_attributes_ and lookup_attribute_
   subroutines and centralize the mapping between attribute names and bits in the attributes word. */


/****^  HISTORY COMMENTS:
  1) change(87-04-20,GDixon), approve(87-07-13,MCR7741),
     audit(87-07-16,Brunelle), install(87-08-04,MR12.1-1055):
     Eliminate use of attribute_names.incl.pl1, in favor of a similar array
     placed directly in user_attributes.incl.pl1.
                                                   END HISTORY COMMENTS */


/* DECLARATIONS */

/* Parameters */

/* format_attributes_ parameters */

dcl  input_attribute_ptr ptr;				/* ptr to input attributes word to be formatted */
dcl  output_attribute_string char (*) varying;		/* output string to return names of attributes that are on */

/* lookup_attribute_ parameters */

dcl  input_attribute_name char (*);			/* name of single attribute to be looked up */
dcl  output_attribute_ptr ptr;			/* ptr to output attributes word in which we're to
						   turn on the bit corresponding to input_attribute_name */
dcl  output_code fixed bin (35);			/* error code, set if input_attribute_name is invalid */

/* Automatic */

dcl  atp ptr;					/* ptr to attributes word */
dcl  attr_word bit (36);				/* place to copy the input attributes word */
dcl  i fixed bin;					/* do loop index */
dcl  vstr char (300) varying;				/* place to build output string for format_attributes_ */

/* Builtin */

dcl  (addr, hbound, length, rtrim, substr) builtin;

/* Based structures  */


dcl  b36 bit (36) aligned based (atp);			/* alternate way to access attributes word */

%page;
/* MAIN ENTRY POINT format_attributes_: proc (input_attribute_ptr, output_attribute_string); */

	attr_word = input_attribute_ptr -> b36;		/* copy attributes word into temporary */
	atp = addr (attr_word);			/* point our working pointer at the temporary */
						/* flip the secondary, primary, and edit_only bits, since
						   the names are no_secondary, no_primary, and no_edit_only */
	atp -> user_attributes.sb_ok = ^atp -> user_attributes.sb_ok;
	atp -> user_attributes.pm_ok = ^atp -> user_attributes.pm_ok;
	atp -> user_attributes.eo_ok = ^atp -> user_attributes.eo_ok;
	atp -> user_attributes.vdim = ""b;		/* don't print vdim because it's obsolete */
	vstr = "";				/* start with empty string */

	do i = 1 to hbound (USER_ATTRIBUTE_NAMES, 1);	/* look at all the bits whose names we know */
	     if substr (b36, i, 1) then do;		/* if the bit is on */
		vstr = vstr || rtrim (USER_ATTRIBUTE_NAMES (i));
						/* add its name to the string, followed by comma-space */
		vstr = vstr || ", ";		/* separate concatenation statements produce better code */
	     end;
	end;

	i = length (vstr);
	if i > 0 then do;				/* if any of the bits were on */
	     vstr = substr (vstr, 1, i - 2);		/* chop off the trailing comma-space */
	     vstr = vstr || ";";			/* and replace it with a semicolon */
	end;
	else vstr = rtrim (USER_ATTRIBUTE_NAMES (0));	/* should be "none" */

	output_attribute_string = vstr;		/* copy string into return argument */

	return;

lookup_attribute_: entry (input_attribute_name, output_attribute_ptr, output_code);

	atp = output_attribute_ptr;			/* copy ptr to attributes word */
	output_code = 0;				/* assume there will be no error */

	if input_attribute_name = "" then return;	/* avoid match on a null alternate name */

	do i = 0 to hbound (USER_ATTRIBUTE_NAMES, 1)	/* search list of names */
	     while (input_attribute_name ^= USER_ATTRIBUTE_NAMES (i)
						/* until we find a match with a primary name */
	     & input_attribute_name ^= ALT_USER_ATTRIBUTE_NAMES (i));
						/* or with an alternate name */
	end;

	if i > hbound (USER_ATTRIBUTE_NAMES, 1) then output_code = 1;
						/* tell caller if name was invalid */
	else if i > 0 then				/* if name was other than "null" or "none" */
	     substr (b36, i, 1) = "1"b;		/* turn on the bit corresponding to that attribute */

	return;
%page;
%include user_attributes;


     end format_attributes_;




		    idsort_.pl1                     11/04/82  1949.0rew 11/04/82  1608.8       25101



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


idsort_: proc (v, x, n);

/* Singleton sort - from Max Smith */

dcl  v (*) char (32) aligned,				/* input array of strings to sort */
     x (*) fixed bin,				/* index array which will be filled in */
     n fixed bin;					/* number of items to sort */

dcl  (i, j, k, l, m) fixed bin,
     q fixed bin,
     xi fixed bin,
     xj fixed bin,
    (vxi, vxj) char (32) aligned,
     xk fixed bin,
     vxk char (32) aligned,
     xl fixed bin,
     xq fixed bin,
     vxq char (32) aligned;

dcl  stacki (18) fixed bin,
     stackj (18) fixed bin,
     cut fixed bin int static init (12);

	i, m = 1;
	j = n;
	go to test;

sloop:	k = i;
	l = j;
	q = divide (i+j, 2, 17, 0);
	xi = x (i);
	vxi = v (xi);
	xj = x (j);
	vxj = v (xj);
	xq = x (q);
	vxq = v (xq);
	if vxq < vxi then
	if vxj < vxi then
	if vxq < vxj then do;			/* vxq < vxj < vxi */
	     x (i) = xq;
	     x (q) = xj;
	     x (j) = xi;
	     vxq = vxj;
	end;
	else do;					/* vxj <= vxq < vxi */
	     x (i) = xj;
	     x (j) = xi;
	end;
	else do;					/* vxq < vxi <= vxj */
	     x (i) = xq;
	     x (q) = xi;
	     vxq = vxi;
	end;
	else if vxj < vxq then
	if vxi < vxj then do;			/* vxi < vxj < vxq */
	     x (q) = xj;
	     x (j) = xq;
	     vxq = vxj;
	end;
	else do;					/* vxj <= vxi <= vxq */
	     x (q) = xi;
	     x (i) = xj;				/* warning: x(q) before x(i) so q=i works */
	     x (j) = xq;
	     vxq = vxi;
	end;

/* here, v(x(i)) <= vxq <= v(x(j)) */

lloop:	l = l - 1;
	xl = x (l);
	if v (xl) > vxq then go to lloop;
kloop:	k = k + 1;
	xk = x (k);
	if v (xk) < vxq then go to kloop;

/* here, v(x(l)) <= vxq <= v(x(k)) */

	if k <= l then do;
	     x (k) = xl;
	     x (l) = xk;
	     go to lloop;
	end;
	if l - i > j - k then do;
	     stacki (m) = k;
	     stackj (m) = j;
	     j = l;
	end;
	else do;
	     stacki (m) = i;
	     stackj (m) = l;
	     i = k;
	end;
	m = m + 1;

test:	if j-i > cut then go to sloop;
	if i = 1 then if i < j then go to sloop;
	do i = i + 1 by 1 while (i <= j);
	     k = i;
	     xk = x (k);
	     vxk = v (xk);
bubble:	     l = k - 1;
	     xl = x (l);
	     if v (xl) <= vxk then go to ok;
	     x (k) = xl;
	     x (l) = xk;
	     k = l;
	     go to bubble;
ok:	end;
	m = m - 1;
	if m = 0 then return;
	i = stacki (m);
	j = stackj (m);
	go to test;

     end idsort_;




		    lex_error_.pl1                  11/04/82  1949.0rew 11/04/82  1625.6       78660



/* ***************************************************************
   *                                                             *
   * Copyright, (C) Honeywell Information Systems Inc., 1982     *
   *                                                             *
   * Copyright (c) 1975 by Massachusetts Institute of Technology *
   *                                                             *
   * Copyright (c) 1972 by Massachusetts Institute of            *
   * Technology and Honeywell Information Systems, Inc.          *
   *                                                             *
   *************************************************************** */




/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* N__a_m_e:  lex_error_							*/
/*									*/
/*      This procedure is used by compilers generated by the reduction_compiler.	*/
/* It outputs specially-formatted error messages on the error_output stream.		*/
/*									*/
/* E__n_t_r_y:	 lex_error_							*/
/*									*/
/*      Given an error number, an error-message-already-printed switch, an error severity, */
/* a maximum error severity encountered so far, a pointer to a lex_string_ statement	*/
/* descriptor, an error message (ioa_ control string), a brief error message (a shorter	*/
/* ioa_ control string), and optional arguments to be substituted into the error messages, */
/* this procedure writes out a herald describing the error number and severity,		*/
/* the statement and line number of the source statement in error, the text of the error	*/
/* message (into which optional arguments have been substituted), and the source	*/
/* statement.  The error message and source statement are marked as having been printed	*/
/* and if severity > max_severity, max_severity is boosted to the value of severity.	*/
/* If an attempt is made to print this error message again (ie, the error reoccurs), then	*/
/* a brief form of the message is printed instead.  (This brief form may be as brief as	*/
/* a null character string.)  If an attempt is made to print the source statement in	*/
/* another error message, printing is suppressed.					*/
/*									*/
/* U__s_a_g_e									*/
/*									*/
/*      declare lex_error_ entry options (variable);				*/
/*									*/
/*      call lex_error_ (error_number, Serror_printed, severity, max_severity, Pstmt,	*/
/*		     Ptoken, S, message, brief_msg, arg1_, ... , arg_n);		*/
/*									*/
/* 1) error_number (fixed bin)	number of the error in error_control_table.	*/
/* 2) Serror_printed (bit(1) unal)	switch indicating whether the error message	*/
/*				has been printed.  This will be updated.	*/
/* 3) severity (fixed bin)		severity of this error.			*/
/* 4) max_severity (fixed bin)	severity of the highest-severity error so far.	*/
/*				This will be updated.			*/
/* 5) Pstmt (ptr)			ptr to lex_string_ type statement descriptor of	*/
/*				statement to be output after error message.	*/
/* 6) Ptoken (ptr)			ptr to lex_string_ type token descriptor of token	*/
/*				appearing in line which is in error.  Line number	*/
/*				of this token will be used in error message if	*/
/*				Pstmt is null.				*/

/* 7) S (bit(*))			control bits:				*/
/*				  substr(S,1,1) = on if brief message are never	*/
/*					        to be used.			*/
/*				  substr(S,2,1) = on if brief message are always	*/
/*					        used, even when long message	*/
/*					        has never been printed.	*/
/* 8) message (char(*) varying)	text of the error message, an ioa_ control string. */
/* 9) brief_msg (char(*) varying)	text of the brief error message.		*/
/* 10) arg_i			substitution arguments for replacing ioa_ control	*/
/*				arguments in the error message.		*/
/*									*/
/* N__o_t_e_s									*/
/*									*/
/*      The severity numbers cause the error message to preceded by one of the following	*/
/* heralds:								*/
/*	0 = COMMENT		- this is a comment.			*/
/*	1 = WARNING		- a possible error has been detected.  The	*/
/*				  compiler will still generate an object segment.	*/
/*	2 = ERROR			- a probable error has been detected.  The	*/
/*				  compiler will still generate an object segment.	*/
/*	3 = FATAL ERROR		- an error has been detected which is so severe 	*/
/*				  that no object segment will be generated.	*/
/*	4 = TRANSLATOR ERROR	- an error has been detected in the operation of	*/
/*				  the compiler or translator.  No object segment	*/
/*				  will be generated.			*/
/*									*/
/*      Error messages are of the form:						*/
/*	FATAL ERROR _e_r_r_o_r__n_u_m_b_e_r, SEVERITY _s_e_v_e_r_i_t_y IN STATEMENT _n of LINE _m		*/
/*	_t_e_x_t__o_f__e_r_r_o_r__m_e_s_s_a_g_e						*/
/*	SOURCE:								*/
/*	_s_o_u_r_c_e__s_t_a_t_e_m_e_n_t							*/
/*									*/
/* If only one statement appears in line _m, then "STATEMENT _n OF" is omitted.		*/
/*									*/
/* S__t_a_t_u_s									*/
/*									*/
/* 0) Created:  April, 1974 by G. C. Dixon					*/
/* 1) Modified: August, 1981 by M. R. Jordan to recover gracefully when severity is bad	*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


lex_error_: procedure (Nerror, SERROR_PRINTED, severity, max_severity, Pstmt, Ptoken, Scontrol,
	     message, brief);

dcl  Nerror fixed bin,				/* Number of the error which was detected. (In)	*/
     SERROR_PRINTED bit (1) unaligned,			/* on if error message text has been printed.	*/
     severity fixed bin (17),				/* severity of this error.			*/
     max_severity fixed bin,				/* severity of highest-severity error so far.	*/
						/*	Pstmt			ptr,		/* ptr to a lex_string_ statement descriptor.	*/
						/*	Ptoken			ptr,		/* ptr to a lex_string_ token descriptor.	*/
     Scontrol bit (*),				/* control bits (see above).			*/
     message char (*) varying,			/* long error message.			*/
     brief char (*) varying;				/* short error message.			*/

dcl  Lmsg fixed bin,
     1 S aligned,					/* overlay for Scontrol.			*/
     2 always_long bit (1) unal,			/*   always use long error message.		*/
     2 always_brief bit (1) unal,			/*   always use brief error message.		*/
     msg char (256) aligned;

dcl (addr, fixed, max, min, null, string)
     builtin;

dcl  cu_$arg_list_ptr entry returns (ptr),
     ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*) aligned, fixed bin,
     bit (1) aligned, bit (1) aligned),
     ioa_$ioa_stream entry options (variable),
     ioa_$ioa_stream_nnl entry options (variable),
     iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35)),
     iox_$error_output ptr ext static;

dcl  herald (-1:4) char (16) aligned int static init (
     "TRANSLATOR ERROR", "COMMENT", "WARNING", "ERROR", "FATAL ERROR", "TRANSLATOR ERROR");

%include lex_descriptors_;

	call ioa_$ioa_stream_nnl ("error_output", "^/^a ^d, SEVERITY ^d", herald (min (4, max (-1, severity))),
	     Nerror, fixed (severity, 35));

	if Pstmt ^= null then do;
	     if stmt.Istmt_in_line > 1 then
		call ioa_$ioa_stream ("error_output", " IN STATEMENT ^d OF LINE ^d",
		fixed (stmt.Istmt_in_line, 35), fixed (stmt.line_no, 35));
	     else if stmt.Pnext ^= null then
		if stmt.Pnext -> stmt.Istmt_in_line > 1 then
		     call ioa_$ioa_stream ("error_output", " IN STATEMENT ^d OF LINE ^d",
		     fixed (stmt.Istmt_in_line, 35), fixed (stmt.line_no, 35));
		else
		call ioa_$ioa_stream ("error_output", " IN LINE ^d", fixed (stmt.line_no, 35));
	     else
	     call ioa_$ioa_stream ("error_output", " IN LINE ^d", fixed (stmt.line_no, 35));
	end;
	else if Ptoken ^= null then
	     call ioa_$ioa_stream ("error_output", " IN LINE ^d", fixed (token.line_no, 35));
	else
	call ioa_$ioa_stream ("error_output", "");

	string (S) = Scontrol;			/* copy control bits to aligned structure.	*/
	if (SERROR_PRINTED | S.always_brief) & ^S.always_long then
	     if brief = "" then;
	     else do;
		call ioa_$general_rs (cu_$arg_list_ptr (), 9, 10, msg, Lmsg, "0"b, "1"b);
		call iox_$put_chars (iox_$error_output, addr (msg), Lmsg, 0);
	     end;
	else do;
	     SERROR_PRINTED = "1"b;
	     call ioa_$general_rs (cu_$arg_list_ptr (), 8, 10, msg, Lmsg, "0"b, "1"b);
	     call iox_$put_chars (iox_$error_output, addr (msg), Lmsg, 0);
	end;

	if Pstmt ^= null then do;
	     stmt.error_in_stmt = "1"b;
	     if stmt.output_in_err_msg then;
	     else do;
		stmt.output_in_err_msg = "1"b;
		call ioa_$ioa_stream ("error_output", "SOURCE:");
		call iox_$put_chars (iox_$error_output, (stmt.Pvalue), (stmt.Lvalue), 0);
		call ioa_$ioa_stream ("error_output", "");
	     end;
	end;

	if severity > max_severity then
	     max_severity = severity;

     end lex_error_;




		    lex_string_.pl1                 11/01/84  0929.3rew 11/01/84  0857.7      334188



/* ***************************************************************
   *                                                             *
   * Copyright, (C) Honeywell Information Systems Inc., 1982     *
   *                                                             *
   * Copyright (c) 1975 by Massachusetts Institute of Technology *
   *                                                             *
   *************************************************************** */


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Name:  lex_string_							*/
	/*									*/
	/*    This procedure implements the scanning function for reduction_compiler translators. */
	/*									*/
	/* Status:								*/
	/* 1) Modified:  September 8, 1984 by G. C. Dixon: fix reference thru unset pointer	*/
	/*    (phx18140); change to remove compilation warnings.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

lex_string_:
	procedure	(APstr, ALstr, Parea, AS,
		 Aquote_open, Aquote_close, Acomment_open, Acomment_close, Astmt_delim, breaks,
		 ignored_breaks, lex_delims, lex_control_chars, APstmt, APtoken, code);

     dcl						/*	PARAMETERS			*/
	APstr			ptr,		/* ptr to characters to be ignored, followed by	*/
						/* string to be lexed. (In)			*/
	ALstr			fixed bin(21),	/* length of string to be lexed. (In)		*/
	ALstr_ignore		fixed bin(21),	/* number of characters to be ignored,		*/
						/* prior to the string. (In)			*/
	Parea			ptr,		/* ptr to temporary segment in which tokens are	*/
						/* to be created.  The temporary segment must be	*/
						/* one created by translator_temp_. (In)	*/
	AS			bit(*),		/* control switches (see S and Signore). (In)	*/
	Aquote_open		char(*),		/* opening delimiter of quoted strings. (In)	*/
	Aquote_close		char(*),		/* closing delimiter of quoted strings. (In)	*/
	Acomment_open		char(*),		/* delimiter of comment's beginning. (In)	*/
	Acomment_close		char(*),		/* delimiter of comment's ending. (In)		*/
	Astmt_delim		char(*),		/* delimiter of statement's ending. (In)	*/
	breaks			char(*) var aligned,/* list of break characters. (In)		*/
	ignored_breaks		char(*) var aligned,/* chars in the break list for which no output	*/
						/* token is to be created. (In)		*/
	lex_delims		char(*) var aligned,/* string of all possible lexical delimiter chars.*/
						/* (In)					*/
	lex_control_chars		char(*) var aligned,/* string of control chars (1/lex_delim-char).(In)*/
	APstmt			ptr,		/* ptr to chain of statement descriptors. (Out)	*/
	APtoken			ptr,		/* ptr to chain of token descriptors. (Out)	*/
	code			fixed bin(35);	/* a status code. (Out)			*/

     dcl						/*	AUTOMATIC VARIABLES			*/
	Lquote_copy		fixed bin(21),	/* length of copy of a quoted string with	*/
						/* doubled quotes removed.			*/
	Lquote_incr		fixed bin(21),	/* length of part of quoted string between 2	*/
						/* doubled quotes.				*/
	Lquote_str		fixed bin(21),	/* length of entire quoted string.		*/
	Lstr			fixed bin(21),	/* length of unlexed part of string. (in chars)	*/
	Lstr_search		fixed bin(21),	/* length of unlexed string beyond false delim.	*/
	Ndoubled_quotes		fixed bin,	/* number of doubled quotes in quoted string.	*/
	Nlines			fixed bin(21),	/* number of lines lexed so far.		*/
	Nstmt			fixed bin,	/* number stmts lexed so far in line being parsed.*/
	Ntokens_in_stmt		fixed bin,	/* number of tokens in statement when last 	*/
						/* comment was lexed (or, if stmts aren't being	*/
						/* output, then total number of tokens lexed).	*/
	Pquote_copy		ptr,		/* ptr to copy of quoted string.		*/
	Pquote_str		ptr,		/* ptr to quoted string.			*/
	Pstr			ptr,		/* ptr to unlexed part of string.		*/
	Pstr_search		ptr,		/* ptr to unlexed string beyond false delim.	*/
	Sarg			bit(36) aligned,	/* aligned fixed-length copy of AS.		*/
	1 Snew_line		aligned,
	  2 quote_open		bit(1),		/* on if open quote delimiter contains new-line.	*/
	  2 quote_close		bit(1),		/* on if close quote delimiter contains new-line.	*/
	  2 comm_open		bit(1),		/* on if comment open delim contains new-line.	*/
	  2 comm_close		bit(1),		/* on if comment close delim contains new-line.	*/
	  2 stmt_delim		bit(1),		/* on if stmt delim contains new-line.		*/
	Sreuse_token		bit(1) aligned init ("0"b),
						/* on if a token was unmade, and can be reused.	*/
	ch			char(1) aligned,	/* a character temp.			*/
	comment_close		char(4) varying aligned,
	comment_open		char(4) varying aligned,
						/* aligned fixed-length copy of Acomment_open.	*/
	delim_control_char		char(1) aligned,	/* a break control character (see delim).	*/
	doubled_quote		char(8) varying aligned,
						/* representation of quoting delimiter within a	*/
						/* quoted string.				*/
						/* aligned fixed-length copy of Acomment_close.	*/
	i			fixed bin(21),	/* string index.				*/
	j			fixed bin,	/* string index.				*/
	k			fixed bin(21),	/* string index.				*/
	l			fixed bin(21),	/* string index.				*/
	quote_close		char(4) varying aligned,
						/* aligned fixed-length copy of Aquote_close.	*/
	quote_open		char(4) varying aligned,
						/* aligned fixed-length copy of Aquote_open.	*/
	spec_lex_control_chars	char(36) varying aligned,
						/* control chars for delimiters in next variable.	*/
	spec_lex_delims		char(36) varying aligned,
						/* delimiter characters: 1st char of quote, stmt,	*/
						/* comment-open and comment-close delimiters.	*/
	stmt_delim		char(4) varying aligned;
						/* aligned fixed-length copy of stmt_delim.	*/

     dcl						/*	BASED VARIABLES			*/
	1 S			unaligned based (addr (Sarg)),
						/* input argument switches for lex_string_.	*/
	  2 output_stmts		bit(1),		/* on if stmt descriptors are to be output.	*/
	  2 output_comments		bit(1),		/* on if comment tokens are to be output.	*/
	  2 retain_doubled_quotes	bit(1),		/* on if doubled quoting delimiters within a	*/
						/* quoted string are to be retained instead of	*/
						/* being converted to single quotes.		*/
	  2 equate_comment_close_stmt_delim		/* on if comment_close and stmt delims are equal,	*/
				bit(1),		/* and if a comment_close delim is also to be	*/
						/* treated as a stmt delim.			*/
	1 Signore			unaligned based (addr (Sarg)),
						/* input argument switches for init_lex_delims 	*/
	  2 quote			bit(1),		/* on if quoting delimiters are not to be output	*/
						/* as tokens.				*/
	  2 stmt			bit(1),		/* on if statement delimiters are not to be	*/
						/* output as tokens.			*/
	1 delim			unaligned based (addr (delim_control_char)),
						/* switches overlaying delimiter control chars.	*/
	  2 white_space,				/* switch on if char cannot appear at beginning	*/
	    3 S			bit(1),		/* of a stmt (ie, stmt adjusted to exclude char).	*/
	  2 new_line,				/* switch on if delimiter char is a new-line.	*/
	    3 S			bit(1),
	  2 comment_open,				/* switch on if delimiter char is 1st char	*/
	    3 S			bit(1),		/* of a comment-open delimiter.		*/
	  2 quote_open,				/* switch on if delimiter char is 1st char	*/
	    3 S			bit(1),		/* of an open quote delimiter.		*/
	    3 Signore		bit(1),		/* on if quoting delimiter is not to be output	*/
						/* as a token.				*/
	  2 stmt,					/* switch on if delimiter char is 1st char	*/
	    3 S			bit(1),		/* of a statement delimiter.			*/
	    3 Signore		bit(1),		/* on if statement delimiter is not to be output	*/
						/* as a token.				*/
	  2 break,
	    3 S			bit(1),		/* switch on if delimiter char is a break.	*/
	    3 Signore		bit(1),		/* on if break char is not to be output as a token*/
	first_str_char		char(1) based (Pstr),
						/* first char of unparsed remainder of string.	*/
	quote_copy		char(Lquote_copy) based (Pquote_copy),
						/* copy of quoted string in which doubled quotes	*/
						/* have been converted to single quotes.	*/
	quote_copy_array (Lquote_copy)
				char(1) based (Pquote_copy),
						/* array overlaying quote_copy.		*/
	quote_str			char(Lquote_str) based (Pquote_str),
						/* the original quoted string.		*/
	quote_str_array (Lquote_str)	char(1) based (Pquote_str),
						/* array overlaying quote_str.		*/
	str			char(Lstr) based (Pstr),
						/* remainder of string to be lexed.		*/
	str_array (Lstr)		char(1) based (Pstr),
						/* remainder of string to be lexed, as an array.	*/
	str_search		char(Lstr_search) based (Pstr_search);
						/* remainder of string to be lexed beyond a false	*/
						/*   delimiter.				*/

	%include lex_descriptors_;

     dcl						/*	BUILTIN FUNCTIONS			*/
	(addr, collate, copy, index, length, min, null, search, size, string, substr)
				builtin;

     dcl						/*	STATIC VARIABLES			*/
	NL			char(1) aligned int static init ("
"),
	NP			char(1) aligned int static init (""),
         (error_table_$no_stmt_delim,
	error_table_$unbalanced_quotes,
	error_table_$zero_length_seg)	fixed bin(35) ext static,
	max_Lvalue		fixed bin(18) int static init (262143);
						/* 2**18 - 1;  the largest value which can be	*/
						/* stored in a fixed bin(18) number.		*/

	Nlines = 1;				/* Perform initialization for old entry point.	*/
	Pstr = APstr;
	Lstr = ALstr;
	go to init;


lex:	entry    (APstr, ALstr, ALstr_ignore, Parea, AS,
		Aquote_open, Aquote_close, Acomment_open, Acomment_close, Astmt_delim, breaks,
		ignored_breaks, lex_delims, lex_control_chars, APstmt, APtoken, code);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*							*/
	/* PRE-INITIALIZATION:					*/
	/*							*/
	/*  1) Count the number of <new-line> characters in the lines to be	*/
	/*     ignored, so we can put correct line numbers into the tokens.	*/
	/*							*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	Nlines = 1;
	Pstr = APstr;
	Lstr = ALstr_ignore;
	do while (Lstr > 0);
	     i = index(str,NL);
	     if i = 0 then do;
		Pstr = addr(str_array(Lstr+1));
		Lstr = 0;
		end;
	     else do;
		Nlines = Nlines + 1;
		Pstr = addr(str_array(i+1));
		Lstr = Lstr - i;
		end;
	     end;
	Lstr = ALstr;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*							*/
	/* INITIALIZATION:						*/
	/*							*/
	/*  1) Copy arguments.					*/
	/*  2) If creating statement (stmt) descriptors, as well as token	*/
	/*     descriptors, create the first stmt descriptor.		*/
	/*  3) Set switches if quoting, comment-open, comment-close, or stmt	*/
	/*     delimiters contains a new-line character.			*/
	/*							*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

init:	Sarg = AS;
	S.output_comments = S.output_comments & S.output_stmts;
	quote_open = Aquote_open;
	quote_close = Aquote_close;
	doubled_quote = quote_close;
	doubled_quote = doubled_quote || quote_close;
	comment_open = Acomment_open;
	comment_close = Acomment_close;
	stmt_delim = Astmt_delim;

	if S.output_stmts & (length(stmt_delim) > 0) then do;
		/* stmt descriptors being output.			*/
	     Pstmt = allocate (Parea, size(stmt));
	     stmt.version = 1;
	     stmt.size = size(stmt);
	     stmt.Pnext = null;
	     stmt.Plast = null;
	     stmt.Pvalue = Pstr;
	     stmt.Lvalue = Lstr;
		/* Length of stmt will be computed by subtracting characters*/
		/* remaining in string being lexed (str) after last token	*/
		/* of stmt is lexed from chars in str before first token	*/
		/* of stmt is lexed.  stmt_ subroutine does computation.	*/
	     stmt.Pfirst_token = null;
	     stmt.Plast_token = null;
	     stmt.Ntokens = 0;
		/* token_ subroutine fills in last 3 values.		*/
	     stmt.Puser = null;
	     stmt.semant_type = 0;
	     stmt.Pcomments = null;
	     stmt.line_no = Nlines;
	     stmt.Istmt_in_line = 1;
	     string(stmt.group2.S) = "0"b;
	     APstmt = Pstmt;
	     end;
	else do;	/* No stmt descriptors being output.			*/
	     APstmt = null;
	     Ntokens_in_stmt = 0;
	     end;
		/* str has not yet ended with a stmt delimiter.		*/
	APtoken = null;
	code = 0;

	string(Snew_line) = "0"b;
	if length(quote_open) > 0 then
	     if index(quote_open,NL) > 0 then
		Snew_line.quote_open = "1"b;
	if length(quote_close) > 0 then
	     if index(quote_close,NL) > 0 then
		Snew_line.quote_close = "1"b;
	if length(comment_open) > 0 then
	     if index(comment_open,NL) > 0 then
		Snew_line.comm_open = "1"b;
	if length(comment_close) > 0 then
	     if index(comment_close,NL) > 0 then
		Snew_line.comm_close = "1"b;
	if length(stmt_delim) > 0 then
	     if index(stmt_delim,NL) > 0 then
		Snew_line.stmt_delim = "1"b;
	if S.equate_comment_close_stmt_delim then
	     if comment_close = stmt_delim then
		if length(stmt_delim) > 0 then;
		else S.equate_comment_close_stmt_delim = "0"b;
	     else S.equate_comment_close_stmt_delim = "0"b;
		/* Begin lexing the first line.			*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*							*/
	/* PERFORM LEXICAL ANALYSIS:					*/
	/*							*/
	/*  1) str overlays only the characters at the end of the input	*/
	/*     which remain to be lexed.  The address and length of		*/
	/*     str are adjusted after each token is lexed to cause str to	*/
	/*     overlay only the unlexed characters of interest to the lexer.	*/
	/*  2) str is repeatedly lexed for tokens until it is exhausted.	*/
	/*  3) Lexing is performed by searching for lexical delimiters in str.*/
	/*  4) For each lexical delimiter found, the following is done:	*/
	/*     a) If the delimiter is not at the very beginning of str, then	*/
	/*	a token preceeds it.  Create a descriptor for this token.	*/
	/*     b) Access the control character for the found delimiter.  This	*/
	/*	character is a group of bits (see delim) which specify	*/
	/*	what type of delimiter was found, and whether or not the	*/
	/*	delimiter should be ignored or should be represented by a	*/
	/*	token.  Delimiter types include: quoting char, comment	*/
	/*	opening char, comment closing char, and stmt delimiter, or	*/
	/*	a regular break character or new-line character.		*/
	/*     c)	If the delimiter is a new-line char, increment the line	*/
	/*	counter.  If the new-line occurs at the beginning of a stmt,*/
	/*	update stmt descriptors line-no-of-stmt value.		*/
	/*     d) If delimiter is a quoting char (or 1st char of a multi-char	*/
	/*	quoting delimiter), then process the quoted string and the	*/
	/*	trailing quoting character(s).			*/
	/*     e) If delimiter is a comment opening char (or 1st char of a	*/
	/*	multi-char comment opening delimiter), then process the	*/
	/*	comment, including the comment closing character(s).	*/
	/*     f) If the delimiter is a stmt termination delimiter, then	*/
	/*	perform stmt termination functions and new stmt initiation	*/
	/*	functions, creating a token for stmt terminator if req'd.	*/
	/*     g) If the delimiter is a regular break, create a token for it	*/
	/*	unless it is to be ignored.  If an ignored break is a	*/
	/*	white-space char and it appears at the beginning of a stmt,	*/
	/*	exclude it from the body of the stmt.			*/
	/*  5) If no more delimiters are found but some part of str remains,	*/
	/*     it is considered to be a token;  build a token descriptor.	*/
	/*							*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

LEX:
	do while (Lstr > 0);
	     i = search(str, lex_delims);
RE_LEX:	     if i = 0 then do;
		/* No more delimiters, but some of str left.  It's a token.	*/
		call token_(Pstr, Lstr);
		Lstr = 0;
		go to END_LEX;
		end;

	     if i > 1 then do;
		/* Token appears before delimiter.			*/
		call token_(Pstr, i-1);
		Pstr = addr(str_array(i));
		Lstr = Lstr - (i-1);
		/* Adjust str to overlay part of str beyond token.	*/
		end;

	     delim_control_char = substr(lex_control_chars, index(lex_delims, first_str_char), 1);

	     if delim.quote_open.S then
		if length(quote_open) = 1 then do;
		     call quote_;
		     go to END_LEX;
		     end;
		else if Lstr >= length(quote_open) then
		     if substr(str,1,length(quote_open)) = quote_open then do;
			call quote_;
			go to END_LEX;
			end;

	     if delim.comment_open.S then
		if length(comment_open) = 1 then do;
		     call comment_;
		     go to END_LEX;
		     end;
		else if Lstr >= length(comment_open) then
		     if substr(str,1,length(comment_open)) = comment_open then do;
			call comment_;
			go to END_LEX;
			end;

	     if delim.stmt.S then
		if length(stmt_delim) = 1 then do;
		     call stmt_;
		     go to END_LEX;
		     end;
		else if Lstr >= length(stmt_delim) then
		     if substr(str,1,length(stmt_delim)) = stmt_delim then do;
			call stmt_;
			go to END_LEX;
			end;

	     if delim.new_line.S then do;
		Nlines = Nlines + 1;
		if S.output_stmts then
		     if stmt.Pvalue = Pstr then do;
			stmt.line_no = stmt.line_no + 1;
			stmt.Istmt_in_line = 1;
			end;
		end;

	     if delim.white_space.S then
		if S.output_stmts then
		     if stmt.Pvalue = Pstr then do;
			stmt.Pvalue = addr(str_array(2));
			stmt.Lvalue = stmt.Lvalue - 1;
			end;

	     if delim.break.S then do;
		if delim.break.Signore then;
		else
		     call token_(Pstr, 1);
		if Lstr = 1 then
		/* avoid performing substr beyond end of str.		*/
		     Lstr = 0;
		else do;
		     Pstr = addr(str_array(2));
		     Lstr = Lstr - 1;
		     end;
		go to END_LEX;
		end;

		/* The break character which was found is not a real 	*/
		/* delimiter, but is just the first character of a comment,	*/
		/* quoting, or statement delimiter.  Ignore it.		*/
	     if i > 1 then call unmake_token_;
		/* get rid of any token thought to precede the break.	*/
	     Pstr_search = addr(str_array(i+1));
	     Lstr_search = Lstr - i;
	     k = search(str_search,lex_delims) + i;
	     if k = i then
		i = 0;
	     else
		i = k;
	     go to RE_LEX;

END_LEX:
	     end LEX;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*							*/
	/* TERMINATION:						*/
	/*							*/
	/*  1) If stmt's are being delimited but string being lexed did not	*/
	/*     end with a stmt delimiter, return an error code.		*/
	/*     If it did end with a stmt delimiter, get rid of the last stmt	*/
	/*     descriptor (the newest one which is empty), and make the stmt	*/
	/*     descriptor for the stmt containing the last stmt delimiter be	*/
	/*     the last stmt descriptor.				*/
	/*  2) Return ptr-to/length-of unused portion of output storage area.	*/
	/*							*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	if length(stmt_delim) > 0 then
	     if APtoken = null then do;
		code = error_table_$zero_length_seg;
		if S.output_stmts then
		     APstmt = null;
		end;
	     else if token.S.end_of_stmt then
		if S.output_stmts then do;
		     Pstmt = stmt.Plast;
		     stmt.Pnext = null;
		     end;
		else;
	     else
		code = error_table_$no_stmt_delim;
	else if APtoken = null then
	     code = error_table_$zero_length_seg;

	return;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*							*/
	/* COMMENTS:						*/
	/*							*/
	/*  1) Process comments in three parts:  the comment opening	*/
	/*     delimiter;  the comment;  the comment closing delimiter.	*/
	/*  2) Skip over the comment opening delimiter.			*/
	/*  3) If comments are being output, create a token for the comment.	*/
	/*  4) Increment line counter for any new-line chars in comment.	*/
	/*  5) Skip over the comment closing delimiter.			*/
	/*  6) If the string being lexed ends with a comment, and no closing	*/
	/*     delimiter is found for the comment, ignore this condition.	*/
	/*							*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

comment_:
	proc;

	if Lstr = length(comment_open) then do;
		/* str exhausted in mid-comment. That's OK.		*/
	     Lstr = 0;
	     return;
	     end;
	else do;
	     Pstr = addr(str_array(length(comment_open)+1));
	     Lstr = Lstr - length(comment_open);
	     if Snew_line.comm_open then
		Nlines = Nlines + 1;
	     end;

	k = index (str, comment_close);

	if k = 0 then do;
		/* remainder of str is the comment.  No comment close delim.*/
	     if S.output_comments then
		call comment_token_(Pstr, Lstr);
	     Lstr = 0;
	     return;
	     end;

	if S.output_comments then
	     call comment_token_(Pstr, k-1);

	k = k-1;
	do while (k > 0);
	     Pstr_search = Pstr;
	     Lstr_search = k;
	     j = index(str_search,NL);
	     if j = 0 then
		j = k;
	     else
		Nlines = Nlines + 1;
	     Pstr = addr(str_array(j+1));
	     Lstr = Lstr - j;
	     k = k - j;
	     end;
	if S.equate_comment_close_stmt_delim then;
	else if Lstr = length(comment_close) then
		/* lexing comment close delim exhausts str.		*/
	     Lstr = 0;
	else do;
	     Pstr = addr(str_array(length(comment_close)+1));
	     Lstr = Lstr - length(comment_close);
	     if Snew_line.comm_close then
		Nlines = Nlines + 1;
	     end;
	if S.output_stmts then
	     if stmt.Ntokens = 0 then do;
		stmt.Pvalue = Pstr;
		stmt.Lvalue = Lstr;
		stmt.line_no = Nlines;
		stmt.Istmt_in_line = 1;
		end;

	end comment_;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*							*/
	/* COMMENT DESCRIPTORS:					*/
	/*							*/
	/*  1) Allocate a new token descriptor; chain it onto stmt descr.	*/
	/*  2) Set flags indicating position of comment relative to beginning	*/
	/*     of stmt and relative to the previous comment in this stmt.	*/
	/*							*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

comment_token_:
	proc     (P, L);

     dcl
	P			ptr,		/* ptr to comment.	*/
	L			fixed bin(21);	/* length of comment*/

	if stmt.Pcomments = null then do;
	     Pcomment = allocate (Parea, size(comment));
	     stmt.Pcomments = Pcomment;
	     comment.Plast = null;
	     string(comment.S) = "0"b;
	     Ntokens_in_stmt = stmt.Ntokens;
	     end;
	else do;
	     comment.Pnext = allocate (Parea, size(comment));
	     comment.Pnext -> comment.Plast = comment.Pnext;
	     Pcomment = comment.Pnext;
	     string(comment.S) = "0"b;
	     if Ntokens_in_stmt = stmt.Ntokens then
		comment.S.contiguous = "1"b;
	     Ntokens_in_stmt = stmt.Ntokens;
	     end;
	comment.version = 1;
	comment.size = size(comment);
	comment.Pnext = null;
	comment.Pvalue = P;
	comment.Lvalue = min(max_Lvalue,L);
	comment.line_no = Nlines;
	if stmt.Ntokens = 0 then
	     comment.S.before_stmt = "1"b;

	end comment_token_;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*							*/
	/* QUOTED STRINGS:						*/
	/*							*/
	/*  1) Process quoted strings in three parts:  open quoting delim;	*/
	/*     quoted string;  close quoting delimiter.			*/
	/*  2) If quoting delimiters are not being ignored, create a token	*/
	/*     for the begin quoting delim.				*/
	/*  3) Search for the end of the quoted string, taking into account	*/
	/*     doubled quoting delimiters appearing in the string which	*/
	/*     represent occurrences of the quoting delimiter in the string.	*/
	/*     If the end quoting delim is not found, return an error code and*/
	/*     assume that the remainder of str is the quoted string.	*/
	/*  4) If doubled quoting delimiters appear within the quoted string	*/
	/*     and doubled quotes are _n_o_t being retained, copy the quoted	*/
	/*     string, translating doubled quotes into the single quote	*/
	/*     representation they should have in an unquoted string.	*/
	/*  5) Create a token representing the quoted string (or its copy).	*/
	/*  6) Increment the line counter for any new-line chars which appear	*/
	/*     in the quoted string.					*/
	/*  6) If quoting delimiters are not being ignored, create a token	*/
	/*     for the end quoting delim.				*/
	/*							*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

quote_:
	proc;

	if delim.quote_open.Signore then;
	else
	     call token_(Pstr, length(quote_open));
	if Lstr = length(quote_open) then do;
	     /* begin quote delim appears at end of str.			*/
	     Lstr = 0;
	     code = error_table_$unbalanced_quotes;
	     return;
	     end;
	else do;
	     Pstr = addr(str_array(length(quote_open)+1));
	     Lstr = Lstr - length(quote_open);
	     if Snew_line.quote_open then
		Nlines = Nlines + 1;
	     end;

	k = index(str,quote_close);
	if k = 0 then do;
	     call token_(Pstr, Lstr);
	     token.S.quoted_string = "1"b;
	     Lstr = 0;
	     code = error_table_$unbalanced_quotes;
	     return;
	     end;

	l = index(str,doubled_quote);

	if l ^= k then do;
		/* No doubled quoting delims appear in the quoted string.	*/
	     k = k-1;
	     call token_(Pstr, k);
	     token.S.quoted_string = "1"b;
	     do while (k > 0);
		Pstr_search = Pstr;
		Lstr_search = k;
		j = index(str_search,NL);
		if j = 0 then
		     j = k;
		else
		     Nlines = Nlines + 1;
		Pstr = addr(str_array(j+1));
		Lstr = Lstr - j;
		k = k - j;
		end;
	     end;
	else do;
		/* Doubled quotes were found within the quoted string.	*/
		/*  1) Compute length of quoted string, including doubled	*/
		/*     quotes.					*/
		/*  2) Count number of doubled quotes as length is computed.*/
		/*  3) Unless doubled quotes are to be retained, copy the	*/
		/*     quoted string, translating double to single quotes.	*/
		/*  4) Create a token for the quoted string (or its copy).	*/
	     Pquote_str = Pstr;
	     Lquote_str = 0;
	     Ndoubled_quotes = 0;

	     do while (l = k);
		/* Do until end of quoted string is found.		*/
		Lquote_incr = (l-1) + length(doubled_quote);
		Lquote_str = Lquote_str + Lquote_incr;
		Ndoubled_quotes = Ndoubled_quotes + 1;
		if Lstr = Lquote_incr then do;
		     Lstr = 0;
		     code = error_table_$unbalanced_quotes;
		     go to DONE_QUOTING;
		     end;
		Pstr = addr(str_array(Lquote_incr+1));
		Lstr = Lstr - Lquote_incr;

		k = index(str, quote_close);
		if k = 0 then do;
		     Lquote_str = Lquote_str + Lstr;
		     Lstr = 0;
		     code = error_table_$unbalanced_quotes;
		     go to DONE_QUOTING;
		     end;

		l = index(str,doubled_quote);
		end;

	     Lquote_str = Lquote_str + (k-1);
	     Pstr = addr(str_array(k));
	     Lstr = Lstr - (k-1);

DONE_QUOTING:
	     if S.retain_doubled_quotes then do;
		Pquote_copy = Pquote_str;
		Lquote_copy = Lquote_str;
		end;
	     else do;
	          Lquote_copy = Lquote_str - (Ndoubled_quotes * length(quote_close));
		Pquote_copy = allocate (Parea, size(quote_copy));
	          Lquote_copy = 0;
	     
	          do while (Lquote_str > 0);
	               k = index(quote_str, quote_close);
	               if k = 0 then do;
	                    Lquote_copy = Lquote_copy + Lquote_str;
	                    substr(quote_copy, Lquote_copy-Lquote_str+1) = quote_str;
	                    Lquote_str = 0;
	                    end;
	               else do;
	                    Lquote_copy = Lquote_copy + k;
	                    substr(quote_copy, Lquote_copy-(k-1)) = quote_str;
	                    Pquote_str = addr(quote_str_array(k+2));
	                    Lquote_str = Lquote_str - (k+1);
	                    end;
	               end;
		end;
	     
	     call token_(Pquote_copy,Lquote_copy);
	     token.S.quoted_string = "1"b;
	     token.S.quotes_in_string = "1"b;
	     token.S.quotes_doubled = S.retain_doubled_quotes;
	     do while (Lquote_copy > 0);
		j = index(quote_copy,NL);
		if j = 0 then
		     j = Lquote_copy;
		else
		     Nlines = Nlines + 1;
		if Lquote_copy > j then
		     Pquote_copy = addr(quote_copy_array(j+1));
		Lquote_copy = Lquote_copy - j;
		end;
	     if Lstr = 0 then
		return;
	     end;

	if delim.quote_open.Signore then;
	else
	     call token_(Pstr,length(quote_close));
	if Lstr = length(quote_close) then
	     Lstr = 0;
	else do;
	     Pstr = addr(str_array(length(quote_close)+1));
	     Lstr = Lstr - length(quote_close);
	     if Snew_line.quote_close then
		Nlines = Nlines + 1;
	     end;

	end quote_;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*							*/
	/* STATEMENT DESCRIPTORS:					*/
	/*							*/
	/*  1) If stmt delims are not being ignored, create a stmt delim token*/
	/*  2) If stmt descriptors are being output, fill in remaining values	*/
	/*     for current stmt, and create next stmt descriptor.  Otherwise,	*/
	/*     reset count of tokens in stmt so tokens will have good count.	*/
	/*							*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

stmt_:
	proc;

	if delim.stmt.Signore then;
	else
	     call token_(Pstr,length(stmt_delim));
	if APtoken ^= null then
	     token.S.end_of_stmt = "1"b;

	if Lstr = length(stmt_delim) then
	     Lstr = 0;
	else do;
	     Pstr = addr(str_array(length(stmt_delim)+1));
	     Lstr = Lstr - length(stmt_delim);
	     if Snew_line.stmt_delim then
		Nlines = Nlines + 1;
	     end;

	if S.output_stmts then do;
	     stmt.Lvalue = min(max_Lvalue, stmt.Lvalue - Lstr);
	     if stmt.line_no = Nlines then
		Nstmt = stmt.Istmt_in_line + 1;
	     else
		Nstmt = 1;
	     stmt.Pnext = allocate (Parea, size(stmt));
	     stmt.Pnext -> stmt.Plast = Pstmt;
	     Pstmt = stmt.Pnext;
	     stmt.version = 1;
	     stmt.size = size(stmt);
	     stmt.Pnext = null;
	     stmt.Pvalue = Pstr;
	     stmt.Lvalue = Lstr;
	     stmt.Pfirst_token = null;
	     stmt.Plast_token = null;
	     stmt.Puser = null;
	     stmt.Pcomments = null;
	     stmt.Ntokens = 0;
	     stmt.semant_type = 0;
	     stmt.line_no = Nlines;
	     stmt.Istmt_in_line = Nstmt;
	     string(stmt.group2.S) = "0"b;
	     end;

	else
	     Ntokens_in_stmt = 0;

	end stmt_;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*							*/
	/* TOKEN DESCRIPTORS:					*/
	/*							*/
	/*  1) Allocate a new token descriptor, chained onto previous one.	*/
	/*     If a used token already exists, reuse it.			*/
	/*  2) Fill in the token descriptor from input arguments.		*/
	/*  3) If stmt descriptors are being output, fill in token's stmt	*/
	/*     position information and stmt descriptor's token information.	*/
	/*  4) If this is the first token, fill in argument ptr to token chain*/
	/*							*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

token_:
	proc     (P, L);

     dcl
	P			ptr,		/* ptr to token.	*/
	L			fixed bin(21);	/* length of token.	*/

	if Sreuse_token then Sreuse_token = "0"b;
	else
	     if APtoken = null then do;
	          Ptoken = allocate (Parea, size(token));
	          token.Plast = null;
	          APtoken = Ptoken;
	          end;
	     else do;
	          token.Pnext = allocate (Parea, size(token));
	          token.Pnext -> token.Plast = Ptoken;
	          Ptoken = token.Pnext;
	          end;
	token.version = 1;
	token.size = size(token);
	token.Pnext = null;
	token.Pvalue = P;
	token.Lvalue = min(max_Lvalue,L);
	token.Nvalue = 0;
	string(token.S) = "0"b;

	if S.output_stmts then do;
	     token.Pstmt = Pstmt;
	     stmt.Ntokens = stmt.Ntokens + 1;
	     token.Itoken_in_stmt = stmt.Ntokens;
	     stmt.Plast_token = Ptoken;
	     if stmt.Pfirst_token = null then
		stmt.Pfirst_token = Ptoken;
	     end;
	else do;
	     token.Pstmt = null;
	     Ntokens_in_stmt = Ntokens_in_stmt + 1;
	     token.Itoken_in_stmt = Ntokens_in_stmt;
	     end;

	token.Psemant = null;
	token.line_no = Nlines;

	end token_;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*							*/
	/* DELETING THE LAST TOKEN WHICH WAS CREATED:			*/
	/*							*/
	/* 1) Set a flag indicating that the last token descriptor is to be	*/
	/*    reused in the next call to token_.			*/
	/* 2) Adjust the bounds of the string to include the last token.	*/
	/* 3) Adjust token counts in statement descriptor or temp. counter.	*/
	/*							*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

unmake_token_:	procedure;

	Sreuse_token = "1"b;
	Pstr = token.Pvalue;
	Lstr = Lstr + token.Lvalue;
	if S.output_stmts then do;
	     stmt.Ntokens = stmt.Ntokens - 1;
	     if stmt.Plast_token = stmt.Pfirst_token then do;
		stmt.Pfirst_token = null;
		stmt.Plast_token  = null;
		end;
	     else stmt.Plast_token  = token.Plast;
	     end;
	else Ntokens_in_stmt = Ntokens_in_stmt - 1;

	end unmake_token_;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*							*/
	/* INITIALIZE LEX DELIMITERS:					*/
	/*							*/
	/*  1) Input includes the quote delimiters, comment-open delimiter,	*/
	/*     comment-close delimiter, stmt delimiter, break characters,	*/
	/*     ignored break characters, and switches indicating whether	*/
	/*     quote delimiters and stmt delimiters are to be ignored.	*/
	/*  2) Create a lex_delims character string consisting of the first	*/
	/*     character of the quote delimiter, comment-open delimiter,	*/
	/*     stmt delimiter, along with a new-line char and the other	*/
	/*     white-space chars (all ASCII control chars except BS & HT),	*/
	/*     and each of the user-specified break characters.		*/
	/*  3) For each character in lex_delims, create a corresponding char	*/
	/*     in lex_control_chars specifying what type of the lex_delim	*/
	/*     character is.  (Each character of lex_control_chars can be	*/
	/*     overlaid by the delim bit string structure.)		*/
	/*							*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

init_lex_delims:
	entry    (Aquote_open, Aquote_close, Acomment_open, Acomment_close, Astmt_delim, AS,
		breaks, ignored_breaks, lex_delims, lex_control_chars);

	quote_open = Aquote_open;
	comment_open = Acomment_open;
	stmt_delim = Astmt_delim;
	Sarg = AS;

	lex_delims = "";
	lex_control_chars = "";
	spec_lex_delims = "";
	spec_lex_control_chars = "";

	if length(quote_open) > 0 then do;
	     ch = substr(quote_open,1,1);
	     spec_lex_delims = ch;
	     string(delim) = "0"b;
	     delim.quote_open.S = "1"b;
	     delim.quote_open.Signore = Signore.quote;
	     spec_lex_control_chars = delim_control_char;
	     end;

	if length(comment_open) > 0 then do;
	     ch = substr(comment_open,1,1);
	     if length(spec_lex_delims) > 0 then
		i = index(spec_lex_delims,ch);
	     else
		i = 0;
	     if i > 0 then
		delim_control_char = substr(spec_lex_control_chars,i,1);
	     else do;
		spec_lex_delims = spec_lex_delims || ch;
		string(delim) = "0"b;
		end;
	     delim.comment_open.S = "1"b;
	     if i > 0 then
		substr(spec_lex_control_chars,i,1) = delim_control_char;
	     else
		spec_lex_control_chars = spec_lex_control_chars || delim_control_char;
	     end;

	if length(stmt_delim) > 0 then do;
	     ch = substr(stmt_delim,1,1);
	     if length(spec_lex_delims) > 0 then
		i = index(spec_lex_delims,ch);
	     else
		i = 0;
	     if i > 0 then
		delim_control_char = substr(spec_lex_control_chars,i,1);
	     else do;
		spec_lex_delims = spec_lex_delims || ch;
		string(delim) = "0"b;
		end;
	     delim.stmt.S = "1"b;
	     delim.stmt.Signore = Signore.stmt;
	     if i > 0 then
		substr(spec_lex_control_chars,i,1) = delim_control_char;
	     else
		spec_lex_control_chars = spec_lex_control_chars || delim_control_char;
	     end;

	do k = 1 to length(breaks);
	     ch = substr(breaks,k,1);
	     if length(spec_lex_delims) > 0 then
		i = index(spec_lex_delims,ch);
	     else
		i = 0;
	     if i > 0 then
		delim_control_char = substr(spec_lex_control_chars,i,1);
	     else do;
		lex_delims = lex_delims || ch;
		string(delim) = "0"b;
		end;
	     delim.break.S = "1"b;
	     l = index(ignored_breaks,ch);
	     if l > 0 then
		delim.break.Signore = "1"b;
	     if i > 0 then
		substr(spec_lex_control_chars,i,1) = delim_control_char;
	     else
		lex_control_chars = lex_control_chars || delim_control_char;
	     end;

	lex_delims = lex_delims || spec_lex_delims;
	lex_control_chars = lex_control_chars || spec_lex_control_chars;

	i = index(lex_delims, NL);
	if i > 0 then do;
	     delim_control_char = substr(lex_control_chars,i,1);
	     if delim.break.Signore then do;
		delim.white_space.S = "1"b;
		delim.new_line.S = "1"b;
		substr(lex_control_chars,i,1) = delim_control_char;
		end;
	     end;
	i = index(lex_delims, NP);
	if i > 0 then do;
	     delim_control_char = substr(lex_control_chars,i,1);
	     if delim.break.Signore then do;
		delim.white_space.S = "1"b;
		substr(lex_control_chars,i,1) = delim_control_char;
		end;
	     end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


%include translator_temp_alloc;

	end lex_string_;




		    not_ascii_.pl1                  11/04/82  1949.0rew 11/04/82  1608.8       10629



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


not_ascii_:	procedure(string, value);

declare	string char(*) aligned, value bit(1) aligned;
declare	(oct, i, lng) fixed bin;
declare	p pointer;
declare	1 x aligned based(p),
	2 y char(3) unaligned,
	2 sym char(1) unaligned;




	lng = length(string);
	oct = 0;
	p = addr(oct);
	value = "1"b;			/* preset to NOT ASCII */
	do i=1 to lng;
	     sym = substr(string, i, 1);	/* get a character */
	     if oct = 1000b then goto loop;			/* backspace */
	     if oct > 011111b then if oct < 1111011b then goto loop;	/* acceptable ASCII characters */
	     return;			/* error return "NOT ASCII */
loop:
	end;
	value = "0"b;			/* OK return, YES ASCII */
	return;

end	not_ascii_;




		    pdt_counter_check.pl1           07/13/88  1120.1r w 07/13/88  0940.2      122517



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


pdt_counter_check: proc;

/* Command to go thru pdt entries, checking the various process counters for correctness
   and consistency. (They can get inconsistent because of answering service bugs, or faults during
   logins and logouts, caused by hardware problems, damaged segments, etc.)

   WARNING:
   This command provides an alternative to patching system tables with debug.
   While it does contain some knowledge about proper and consistent values for
   the counters, it is capable of making things worse if it is misused. It is
   strongly recommended that a Honeywell representative be consulted before
   using this command with the -reset or -query arguments.

   USAGE: pdt_counter_check {-ctl_args}

   Action: (only one of the following):
   *	-check	just print messages about errors (DEFAULT)
   *	-query	ask if bad counters should be reset, after each error message
   *	-reset	reset bad counters automatically

   Verbosity: (default is to print only when counters are clearly wrong,
   *           and not print nonzero counters that could be right or wrong).
   *	-print_non_zero, -print_nonzero, -pnz
   *		print all nonzero counters

   Person and Project (default is all persons and all projects):
   *	-user Person_id  just check pdt entries belonging to this person
   *	-project Project just check this project's pdt entries

   Where to find SAT and PDTs:
   *	-sat_dir PATH    default >sc1
   *	-pdt_dir PATH    default >sc1>pdt

   Coded January 1980 by Tom Casey.
   Modified march 3, 1980 by Tom Casey to add -pnz and warning in usage comments.

*/

/* DECLARATIONS */

/* Automatic */

/* binary */
dcl  code fixed bin (35);
dcl (argl, argno, nargs) fixed bin;
dcl (active_projects, checked_projects, pdt_entries, active_users, error_count, now_in_error_count) fixed bin init (0);
dcl (pdtx, satx) fixed bin;

/* bit */
dcl (project_found, user_found) bit (1) aligned init (""b);
dcl (check_sw, query_sw, reset_sw, user_sw, project_sw, pnz_sw) bit (1) aligned init (""b);
dcl  reset_negative bit (1) aligned;

/* char */
dcl  ename char (32);
dcl  pdt_dir char (168) init (">sc1>pdt");
dcl  sat_dir char (168) init (">sc1");
dcl  project_name char (9) init ("");
dcl  user_name char (22) init ("");
dcl  pers char (22) varying init ("");
dcl  proj char (9) varying init ("");

/* ptr */
dcl (argp, pdtp, pdtep, satp, satep) ptr init (null);

/* Based */

dcl  arg char (argl) based (argp);

/* Builtin and Condition */

dcl (addr, null, rtrim, substr) builtin;
dcl  cleanup condition;

/* Entries */

dcl  absolute_pathname_ entry (char (*), char (*), fixed bin (35)); /* inpath,outpath,code */
dcl  com_err_ entry options (variable);
dcl  command_query_ entry options (variable);		/* qi_ptr,answer c*v, caller c*, ioa_ctl_string c*, ioa_args */
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_ entry options (variable);

/* External static */

dcl  error_table_$badopt ext fixed bin (35);
dcl  error_table_$noarg ext fixed bin (35);

/* Internal Static */

dcl  me char (17) int static options (constant) init ("pdt_counter_check");

/* Include files */

%page;
%include pdt;
%page;
%include query_info;
%page;
%include sat;
%page;
%include user_attributes;

/* PROCEDURE */

/* Process Arguments */

	call cu_$arg_count (nargs);

	do argno = 1 to nargs;

	     call get_arg;
	     if substr (arg, 1, 1) ^= "-" then do;
		call com_err_ (0, me,
		     "Unknown argument: ""^a""; all args must be preceded by an identifying control arg.", arg);
		return;
	     end;
	     if arg = "-check" | arg = "-ck" then
		check_sw = "1"b;
	     else if arg = "-query" then
		query_sw = "1"b;
	     else if arg = "-reset" then
		reset_sw = "1"b;
	     else if arg = "-pnz" | arg = "-print_nonzero" | arg = "-print_non_zero" then
		pnz_sw = "1"b;
	     else if arg = "-user" then do;
		call get_next_arg;
		if argl > 22 then do;
		     call com_err_ (0, me, "User name ""^a"" too long (max 22 chars)", arg);
		     return;
		end;
		user_name = arg;
		user_sw = "1"b;
	     end;
	     else if arg = "-project" then do;
		call get_next_arg;
		if argl > 9 then do;
		     call com_err_ (0, me, "Project name ""^a"" too long (max 9 chars)", arg);
		     return;
		end;
		project_name = arg;
		project_sw = "1"b;
	     end;
	     else if arg = "-sat_dir" then do;
		call get_next_arg;
		call absolute_pathname_ ((arg), sat_dir, code);
		if code ^= 0 then do;
path_error:	     call com_err_ (code, me, arg);
		     return;
		end;
	     end;
	     else if arg = "-pdt_dir" then do;
		call get_next_arg;
		call absolute_pathname_ (arg, pdt_dir, code);
		if code ^= 0 then goto path_error;
	     end;
	     else do;
		call com_err_ (error_table_$badopt, me, arg);
		return;
	     end;
	end;					/* end loop thru args */

/* Check for legal combinations of args */

	if (reset_sw & (query_sw | check_sw))
	| (query_sw &check_sw) then do;
	     call com_err_ (0, me, "Only one of -reset, -query, and -check bay be given.");
	     return;
	end;

/* Initialize, and initiate segments */

	on cleanup begin;
	     if satp ^= null then
		call hcs_$terminate_noname (satp, (0));
	     if pdtp ^= null then
		call hcs_$terminate_noname (pdtp, (0));
	end;

	call hcs_$initiate (sat_dir, "sat", "", 0, 0, satp, code);
	if satp = null then do;
	     call com_err_ (code, me, "^a>sat", sat_dir);
	     return;
	end;

/* Loop thru PDTs */

	do satx = 1 to sat.current_size
		while (^project_found);
	     satep = addr (sat.project (satx));

	     proj = rtrim (project.project_id);
	     if project_sw then
		if project_name = proj then
		     project_found = "1"b;

	     if project.state = 1			/* if project is active */
	     & (project_found | ^project_sw) then do;	/* and we want to check it */
		active_projects = active_projects + 1;
		ename = proj || ".pdt";
		call hcs_$initiate (pdt_dir, ename, "", 0, 0, pdtp, code);
		if pdtp = null then
		     call com_err_ (code, me, "^a>^a", pdt_dir, ename);
		else do;
		     checked_projects = checked_projects + 1;
		     call check_project;
		     call hcs_$terminate_noname (pdtp, code);
		     if code ^= 0 then
			call com_err_ (code, me, "^a>^a", pdt_dir, ename);
		end;				/* end pdt initiated successfully */
	     end;					/* end project is active */
	end;					/* end loop thru SAT */

/* Print summary of what was done */

	if ^project_sw then				/* if not doing just one project */
	     call ioa_
	     ("^a: ^d SAT entries, ^d active projects, ^d PDTs, ^d PDT entries, ^d active users, ^d with bad counters",
	     me, sat.current_size, active_projects, checked_projects, pdt_entries, active_users, error_count);

	else if active_projects = 0 then		/* if we didn't find the specified project */
	     call com_err_ (0, me, "Project ""^a"" ^[inactive^;not in SAT^].", project_name, project_found);

	else call ioa_ ("^a: ^a project: ^d PDT entries, ^d active users, ^d with bad counters.",
	     me, project_name, pdt_entries, active_users, error_count);

	if user_sw & ^user_found then			/* if specified user wasn't found */
	     call com_err_ (0, me, "User ""^a"" not found in ^[any^s^;^a^] project.",
	     user_name, (^project_sw), project_name);

	if now_in_error_count > 0 then
	     call ioa_ ("^a: ^d projects had sum of now_in's > project.n_users", me, now_in_error_count);


/* Clean up and return */

	call hcs_$terminate_noname (satp, code);
	if code ^= 0 then
	     call com_err_ (code, me, "^a>sat", sat_dir);

nonlocal_return_label:
	return;

/* Internal Procedures  */

check_negative: proc (num, name) returns (fixed bin);

dcl  num fixed bin;
dcl  name char (*);
dcl  retval fixed bin;

	     reset_negative = ""b;
	     retval = num;

	     if retval < 0 then do;			/* negative value is always an error */
		call ioa_ ("^a: ^[project^x^s^;^a.^]^a ^a is negative (^d)", me, (pers = ""), pers, proj, name, num);
		if reset (retval, name) then do;
		     retval = 0;
		     reset_negative = "1"b;		/* tell caller to reset the real variable */
		end;				/* we can't, because num is passed by value */
	     end;					/* end it is negative */

	     return (retval);

	end check_negative;

check_project: proc;

/* declarations */

dcl  zero_now_in bit (1) aligned;
dcl  sigma_now_in fixed bin;
dcl (nusers, nowin, nfg, nbg, nint, ndisc) fixed bin;
dcl  user_on_project bit (1) aligned init (""b);

/* initialize */

	     sigma_now_in = 0;
	     nusers = check_negative ((project.n_users), "n_users");
	     if reset_negative then
		project.n_users = nusers;
	     if pnz_sw then				/* if user wants to see all nonzero values */
		if nusers ^= 0 then
		     call ioa_ ("^a: project ^a n_users = ^d", me, proj, nusers);
	     if nusers = 0 | user_sw then		/* if no users on project logged in, or just checking one user */
		zero_now_in = "1"b;			/* than it's ok to zero the users' now_in counters */
	     else zero_now_in = ""b;			/* otherwise, we dare not zero the now_in counters */

/* loop thru users */

	     do pdtx = 1 to pdt.current_size
		     while (^user_on_project);	/* exit loop if we hit specified user's pdt entry */
		pdtep = addr (pdt.user (pdtx));
		pers = rtrim (user.person_id);
		pdt_entries = pdt_entries + 1;

		if user_sw then			/* if a user name was specified */
		     if pers = user_name then		/* and this PDT entry belongs to that user */
			user_on_project = "1"b;	/* remember to exit the loop */

		if user.state = 1			/* if user is active */
		& (user_on_project | ^user_sw) then do; /* and we want to check him */
		     active_users = active_users + 1;
		     nowin = check_negative ((user.now_in), "now_in");
		     if reset_negative then
			user.now_in = nowin;

		     sigma_now_in = sigma_now_in + nowin;

		     if now_in > 0 then		/* if user.now_in is > 0 */
			if zero_now_in then		/* and it's ok to reset it */
			     if reset (nowin, "now_in") then /* and user said -reset or -query and "yes" */
				nowin, user.now_in = 0; /* reset it */

		     nfg = check_negative ((user.n_foreground), "n_foreground");
		     if reset_negative then
			user.n_foreground = nfg;
		     nbg = check_negative ((user.n_background), "n_background");
		     if reset_negative then
			user.n_background = nbg;

		     if nfg + nbg ^= nowin then do;
			call ioa_ ("^a: ^a.^a n_foreground + n_background (^d+^d) ^= now_in (^d)",
			     me, pers, proj, nfg, nbg, nowin);

			if nowin = 0 then do;	/* if nowin is zero, it's ok to zero nfg and nbg */
			     if reset (nfg, "n_foreground") then
				nfg, user.n_foreground = 0;
			     if reset (nbg, "n_background") then
				nbg, user.n_background = 0;
			end;
		     end;				/* end nfg+nbg ^= nowin */

		     nint = check_negative ((user.n_interactive), "n_interactive");
		     if reset_negative then
			ndisc, user.n_interactive = 0;
		     ndisc = check_negative ((user.n_disconnected), "n_disconnected");

		     if nint > nfg then do;		/* n_interactive shouldn't be > n_foreground */
			call ioa_ ("^a: ^a.^a n_interactive (^d) > n_foreground (^d)",
			     me, pers, proj, nint, nfg);
			if reset (nint, "n_interactive") then
			     nint, user.n_interactive = nfg;
		     end;

		     if ndisc > nint then do;		/* n_disconnected shouldn't be > n_interactive */
			call ioa_ ("^a: ^a.^a n_disconnected (^d) > n_interactive (^d)",
			     me, pers, proj, ndisc, nint);
		     end;

		     if pnz_sw then			/* if user wants to see all nonzero values */
			if (nowin ^= 0 | nfg ^= 0 | nbg ^= 0 | nint ^= 0 | ndisc ^= 0) then
			     call ioa_ ("^a: ^a.^a nowin=^d nfg=^d nbg=^d nint=^d ndisc=^d",
			     me, pers, proj, nowin, nfg, nbg, nint, ndisc);

		end;				/* end user is active */

		else if user_on_project then
		     call ioa_ ("^a: user ^a deleted from project ^a", me, pers, proj);

	     end;					/* end loop thru pdt */

	     if sigma_now_in > project.n_users then do;	/* if users' now_in counters add up to more than
						   project's counter of logged in users */
		now_in_error_count = now_in_error_count + 1; /* count these occurrences for the summary */
		call ioa_ ("^a: ^a project: sum of now_in's (^d) > project.n_users (^d)",
		     me, proj, sigma_now_in, project.n_users);
	     end;

	     if user_on_project then user_found = "1"b;	/* remember that specified user was on at least one project */

	     return;

	end check_project;

get_next_arg: proc;

	     argno = argno + 1;

	     if argno > nargs then do;
		call com_err_ (error_table_$noarg, me, "after ^a", arg);
		goto nonlocal_return_label;
	     end;

get_arg:	     entry;

	     call cu_$arg_ptr (argno, argp, argl, code);
	     if code ^= 0 then do;
		call com_err_ (code, me);
		goto nonlocal_return_label;
	     end;

	     return;

	end get_next_arg;

reset:	proc (num, name) returns (bit (1) aligned);

dcl  num fixed bin;
dcl  name char (*);

	     if reset_sw then return ("1"b);
	     if query_sw then do;

/* TO BE WRITTEN */

		return (""b);
	     end;

	     return (""b);

	end reset;

     end pdt_counter_check;




		    print_pdt.pl1                   07/13/88  1120.1r w 07/13/88  0940.2      163413



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


/* PRINT_PDT - procedure to print the contents of the binary Project Definition Table
   which was created by the procedure CV_PMF

   Initial coding by Michael J. Spier, September 10, 1969		 */


/****^  HISTORY COMMENTS:
  1) change(86-01-01,Gilcrease), approve(86-03-27,MCR7369),
     audit(86-06-20,LJAdams), install(86-06-30,MR12.0-1081):
               To make old comments good to history_comment modified by Eleanor
     Stone 04/13/70 at 12:54 Janice B. Phillipps -- modified 02/22/72 to allow
     output from print_pdt to be used as input to cv_pmf. . -- modified
     05/25/72 to provide long and brief modes. . -- modified 06/09/72 to search
     for "sel_name". . -- modified 04/01/73 to print new charging info on 6180
     (virtual cpu and memory units). Modified 740823 by PG for authorizations.
     Modified June 1975 by T. Casey, for per-user load_control group Modified
     Nov 1975 by T. Casey for subsystem and initproc packed into same string
     Modified May 1976 by T. Casey to print the per-user cutoff warning
     thresholds. Modified May 1977 by John Gintell to implement -pmf, make
     output look reasonable and cleanup program. Modified May 1978 by T. Casey
     to print pdir_quota. Modified November 1978 by T. Casey for MR7.0 to print
     new absentee control parameters. Modified November 1979 by T. Casey for
     MR8.0 to print process preservation parameters. Modified Feb 1980 by M. B.
     Armstrong to implement multiple rate structures. (UNCA) Modified May 1980
     by R. McDonald  to include page charges. (UNCA) Modified June 1981 by E.
     N. Kittlitz for UNCA changes. Modified December 1981 by E. N. Kittlitz for
     user_warn controls. Modified September 1982 by E. N. Kittlitz for
     default_ring. Modified 1984-07-05 BIM for authorization range.
  2) change(86-02-26,Gilcrease), approve(86-03-27,MCR7369),
     audit(86-06-20,LJAdams), install(86-06-30,MR12.0-1081):
               Put weekly displays in for SCP 6250.
                                                   END HISTORY COMMENTS */


/* format: style4 */
print_pdt: procedure;


dcl  bigfloat float bin internal static init (1e37);
dcl  NEVER fixed bin (71) int static init		/* This date is 12/31/99 2359. */
	(1011000110010110011001001110100110111010100100000000b); /* .. if Multics last this long we will have to fix */
dcl  MILLION fixed bin (35) internal static init (1000000);
dcl  three_asterisks char (3) int static init ("***");

dcl  error_table_$badopt fixed bin ext;


/* DECLARATION OF AUTOMATIC STORAGE VARIABLES */

dcl  ctr fixed bin init (0);
dcl  access_ceiling bit (72) aligned,
     authorization_string char (500);
dcl  rs_name char (32);
dcl  max_rs_number fixed bin;
dcl  temp float bin;
dcl  an fixed bin;
dcl  (pdt_dir, pdt_path) char (168) aligned;
dcl  datestr char (16) aligned;
dcl  datstng char (24) aligned;
dcl  datstr char (8) aligned;
dcl  sel_name char (32) aligned init ("");
dcl  pdt_name char (32) aligned;
dcl  (i, ii, iii, slng) fixed bin;
dcl  code fixed bin (35);
dcl  no_header bit (1) init (""b);
dcl  brief bit (1) init (""b);
dcl  pmf bit (1) init (""b);
dcl  long bit (1) init (""b);
dcl  non_zero_limit bit (1);
dcl  (argp, pdtp, pdtep) ptr;
dcl  attr char (512) varying;
dcl  limit_string char (10) varying;
dcl  char32 char (32);
dcl  default_home_dir char (64);
dcl  len fixed bin (17);
dcl  strng10 char (64) aligned;


/* DECLARATION OF BASED STRUCTURES */

dcl  arg char (slng) unaligned based (argp);


/* DECLARATION OF BUILTIN FUNCTIONS */

dcl  (addr, clock, divide, float, length, mod, max, null, substr, string, rtrim) builtin;

/* DECLARATION OF EXTERNAL ENTRIES */

dcl  expand_pathname_ entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35));
dcl  system_info_$access_ceiling entry (bit (72) aligned);
dcl  system_info_$max_rs_number entry (fixed bin);
dcl  system_info_$rs_name entry (fixed bin, char (*), fixed bin (35));
dcl  convert_access_class_$to_string_range_short entry ((2) bit (72) aligned, char (*), fixed bin (35));
dcl  format_attributes_ entry (ptr, char (*) var);
dcl  date_time_ entry (fixed bin (71), char (*) aligned);
dcl  com_err_ entry options (variable);
dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cu_$arg_count entry returns (fixed bin);
dcl  hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
	fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ttt_info_$decode_type entry (fixed bin, char (*), fixed bin (35));

%include user_attributes;
%include pdt;

/* LOCATE AND INITIALIZE A PDT */


	call system_info_$max_rs_number (max_rs_number);

	call cu_$arg_ptr (1, argp, slng, code);		/* get 1st arg: name of pdt */
	if code ^= 0 then do;
	     call com_err_ (code, "print_pdt", "");
	     return;
	end;

	pdt_path = arg;
	if substr (pdt_path, max (slng - 3, 1), 4) ^= ".pdt" then do;
	     pdt_path = rtrim (pdt_path) || ".pdt";
	end;

	if substr (pdt_path, 1, 1) = ">" | substr (pdt_path, 1, 1) = "<" then do;
	     call expand_pathname_ (pdt_path, pdt_dir, pdt_name, code);
	     if code ^= 0 then do;
		call com_err_ (code, "print_pdt", pdt_path);
		return;
	     end;
	end;
	else do;
	     pdt_name = substr (pdt_path, 1, length (pdt_name));
	     pdt_dir = ">sc1>pdt";
	end;

	call hcs_$initiate (pdt_dir, pdt_name, "", 0, 0, pdtp, code);
	if pdtp = null then do;
	     call com_err_ (code, "print_pdt", "^a>^a", pdt_dir, pdt_name);
	     return;
	end;

	call system_info_$access_ceiling (access_ceiling);

	do an = 2 to cu_$arg_count ();
	     call cu_$arg_ptr (an, argp, slng, code);	/* get next arg: a name in a pdt or a control arg */
	     if substr (arg, 1, 1) = "-" then do;	/* control option? */
		if arg = "-brief" | arg = "-bf" then no_header, brief = "1"b;
		else if arg = "-long" | arg = "-lg" then long = "1"b;
		else if arg = "-pmf" then pmf, brief = "1"b;
		else if arg = "-no_header" | arg = "-nhe" then no_header = "1"b;
		else do;
		     call com_err_ (error_table_$badopt, "print_pdt", """^a""", arg);
		     goto TERM;
		end;
	     end;
	     else do;
		sel_name = arg;
		no_header = "1"b;
	     end;

	end;

	if ^no_header then do;
	     call date_time_ ((clock ()), datestr);
	     if ^pmf then call ioa_ ("^/^-^-^28a^3x^20a^/", pdt_name, datestr);
	     call ioa_ ("Projectid:^12x^a;", pdt.project_name);
	     if ^pmf then call ioa_ ("process_group_id:^5x^a;", pdt.author.proc_group_id);
	     if ^pmf then call ioa_ ("table:^16x^a;", pdt.author.table);
	     if ^pmf then call ioa_ ("w_dir:^16x^a;", pdt.author.w_dir);
	     if ^pmf then call ioa_ ("max_size:^13x^d;", pdt.max_size);
	     if ^pmf then call ioa_ ("current_size:^9x^d;", pdt.current_size);
	     if ^pmf then call ioa_ ("version:^14x^d;", pdt.version);
	     if ^pmf then call ioa_ ("n_users:^14x^d;", pdt.n_users);
	     if ^pmf then call ioa_ ("project_dir:^10x^a;", pdt.project_dir);
	     if ^pmf & max_rs_number > 0 then do;
		call system_info_$rs_name ((pdt.rs_number), rs_name, code); /* get rate structure name */
		call ioa_ ("rate_structure:^7x^a (^d);", rs_name, pdt.rs_number);
	     end;
	end;

/* P R I N T    U S E R    E N T R I E S   */

	do i = 1 to pdt.current_size;
	     pdtep = addr (pdt.user (i));
	     if user.state ^= 0 then do;
		if pmf & user.state ^= 1 then go to SKIP;
		if sel_name ^= "" then if sel_name ^= user.person_id then go to SKIP;
		ctr = ctr + 1;
		call ioa_ ("^/^/personid:^13x^a;", user.person_id);
		if ^brief then call ioa_ (" state:^15x^1d;", user.state);
		if ^brief then call ioa_ (" now_in:^14x^d;", user.now_in);
		if ^brief & user.n_foreground ^= 0 then
		     call ioa_ (" n_foreground:^23t^d;", user.n_foreground);
		if ^brief & user.n_background ^= 0 then
		     call ioa_ (" n_background:^23t^d;", user.n_background);
		if ^brief & user.n_interactive ^= 0 then
		     call ioa_ (" n_interactive:^23t^d", user.n_interactive);
		if ^brief & user.n_disconnected ^= 0 then
		     call ioa_ (" n_disconnected:^23t^d", user.n_disconnected);
		if user.password ^= "" then call ioa_ (" password:^10x^8a;", user.password);
		call format_attributes_ (addr (user.at), attr);
		if brief & string (user.at) = "000000000000001110"b then ;
		else call ioa_ (" attributes:^10x^a", attr);

		if user.uflags.ip_given then		/* if initproc is in new format */
		     ii = user.ip_len;		/* pick up its length */
		else ii = 64;			/* if old format, it occupies the whole string */
		call ioa_$rsnnl ("^a", strng10, iii, substr (user.initial_procedure, 1, ii));
		if user.uflags.dont_call_init_admin then strng10 = rtrim (strng10) || ", direct";
		if brief & strng10 = "process_overseer_" then ;
		else call ioa_ (" initproc:^12x^a;", strng10);

		if user.uflags.ss_given then
		     call ioa_ (" subsystem:^11x^a;", substr (user.initial_procedure, user.ip_len + 1, user.ss_len));

		default_home_dir = ">user_dir_dir>" || rtrim (pdt.project_name) || ">" || user.person_id;
		if brief & user.home_dir = default_home_dir then ;
		else call ioa_ (" homedir:^13x^a;", user.home_dir);
		if brief & user.bump_grace = 2880 then ;
		else call ioa_ (" grace:^15x^d;", user.bump_grace);
		if brief & user.low_ring = 4 & user.high_ring = 5 then ;
		else call ioa_ (" ring:^16x^1d, ^1d, ^1d;", user.low_ring, user.high_ring, user.default_ring);
		if user.at.igroup then
		     call ioa_ (" group:^15x^a;", user.group);
		if user.pdir_quota ^= 0 then
		     call ioa_ (" pdir_quota:^10x^d;", user.pdir_quota);
		if brief & user.max_foreground = 0 then ;
		else call ioa_ (" max_foreground:^23t^d;", user.max_foreground);
		if brief & user.max_background = 0 then ;
		else call ioa_ (" max_background:^23t^d;", user.max_background);
		if brief & user.abs_foreground_cpu_limit = 0 then ;
		else call ioa_ (" abs_foreground_cpu_limit:^23t^d;", user.abs_foreground_cpu_limit);
		if user.lot_size ^= 0 then		/* skip if dft value */
		     if user.lot_size < 0 then call ioa_ (" lot_size:^12x^d, own;", -user.lot_size);
		     else call ioa_ ("lot_size:^13x^d;", user.lot_size);
		if user.kst_size ^= 0 then call ioa_ (" kst_size:^12x^d;", user.kst_size);
		if user.cls_size ^= 0 then
		     if user.cls_size < 0 then call ioa_ (" cls_size:^12x^d, stack;", -user.cls_size);
		     else call ioa_ (" cls_size:^12x^d;", user.cls_size);

		if user.outer_module ^= "" then call ioa_ (" outer_module:^8x^a;", user.outer_module);

		if (user.user_authorization (1) | user.user_authorization (2)) ^= ""b /* we would like to compare to project min, ... */
		then do;
		     call convert_access_class_$to_string_range_short (user.user_authorization, authorization_string, code);
		     if code ^= 0
		     then authorization_string = "unknown";

		     if authorization_string ^= "system_low" & authorization_string ^= ""
		     then call ioa_ (" authorization:^7x""^a"";", authorization_string);
		end;
		if user.dollar_limit = bigfloat then do;
		     if ^brief then call ioa_ (" limit:^15xopen;");
		end;
		else call ioa_ (" limit:^15x^.2f;", user.dollar_limit);

		attr = "shift_limit:        ";
		non_zero_limit = ""b;
		do ii = 1 to 7, 0;
		     if user.shift_limit (ii) = bigfloat
		     then attr = attr || " open,";
		     else do;
			call ioa_$rsnnl (" ^.2f,", limit_string, len, user.shift_limit (ii));
			attr = attr || limit_string;
			non_zero_limit = "1"b;
		     end;
		end;
		substr (attr, length (attr), 1) = ";";
		if brief & ^non_zero_limit then ;
		else call ioa_ (" ^a", attr);

		if user.absolute_limit = bigfloat & user.absolute_cutoff = NEVER then ;
		else do;
		     if user.absolute_limit = bigfloat then attr = "cutoff:              open,";
		     else call ioa_$rsnnl ("cutoff:^14x^.2f,", attr, len, user.absolute_limit);
		     if user.absolute_cutoff = NEVER then attr = attr || " open,";
		     else do;
			call date_time_ (user.absolute_cutoff, datstr);
			attr = attr || " " || datstr || ",";
		     end;
		     if user.absolute_increm = 0 then do;
			len = length (attr);
			substr (attr, len, 1) = ";";
		     end;
		     else if user.absolute_increm = 1 then attr = attr || " daily;";
		     else if user.absolute_increm = 2 then attr = attr || " monthly;";
		     else if user.absolute_increm = 3 then attr = attr || " yearly;";
		     else if user.absolute_increm = 4 then attr = attr || " cyear;";
		     else if user.absolute_increm = 5 then attr = attr || " fyear;";
		     else if user.absolute_increm = 6 then attr = attr || "weekly;";
		     call ioa_ (" ^a", attr);
		end;

		if brief & user.user_warn_dollars = 10e0 then ;
		else call ioa_ (" user_warn_dollars:^3x^.2f;", user.user_warn_dollars);
		if brief & user.user_warn_pct = 10 then ;
		else call ioa_ (" user_warn_percent:^3x^d;", user.user_warn_pct);
		if brief & user.user_warn_days = 10 then ;
		else call ioa_ (" user_warn_days:^6x^d;", user.user_warn_days);

		if brief & user.warn_dollars = 10e0 then ;
		else call ioa_ (" warn_dollars:^8x^.2f;", user.warn_dollars);
		if brief & user.warn_pct = 10 then ;
		else call ioa_ (" warn_percent:^8x^d;", user.warn_pct);
		if brief & user.warn_days = 10 then ;
		else call ioa_ (" warn_days:^11x^d;", user.warn_days);


		if ^pmf then call ioa_ (" dollar_charge:^7x$^.2f;", user.dollar_charge);

		if ^long then go to SKIP;
		call ioa_ (" absolute_spent:^6x$^.2f;", user.absolute_spent);
		call date_time_ (user.daton, datstng);
		call ioa_ (" date_on:^13x^24a;", datstng);
		call date_time_ (user.datof, datstng);
		call ioa_ (" date_off:^12x^24a;", datstng);
		call date_time_ (user.last_login_time, datstng);
		call ioa_ (" last_login_time:^5x^24a;", datstng);
		if user.last_login_time ^= 0 then do;
		     call ioa_ (" last_login_unit:^5x^a;", user.last_login_unit);
		     call ttt_info_$decode_type ((user.last_login_type), char32, code);
		     call ioa_ (" last_login_type:^5x^a;", char32);
		end;
		call date_time_ (user.time_last_bump, datstng);
		call ioa_ (" time_last_bump:^6x^24a;", datstng);
		call date_time_ (user.last_update, datstng);
		call ioa_ (" last_update:^9x^24a;", datstng);
		call ioa_ (" logins:^14x^d;", user.logins);
		call ioa_ (" crashes:^13x^d;", user.crashes);

/* P r i n t   i n t e r a c t i v e   u s a g e   */

		temp = 0e0;
		do ii = 0 to 7;
		     temp = temp + user.interactive (ii).charge;
		end;
		if temp = 0e0 then do;
		     call ioa_ ("^/Interactive Usage:^2xnone");
		end;
		else do;
		     call ioa_ ("^/Interactive Usage:  $^.2f", temp);
		     call ioa_ ("^/shift^2x$charge^5xvcpu^6xmemory*K^6xconnect^4xterminal i/o");
		     do ii = 1 to 7, 0;
			if user.interactive (ii).charge = 0e0 then ; /* if zero charge, don't print */
			else call ioa_ ("^1d^4x^8.2f^1x^9a^4x^10.1f^4x^9a^6x^10.1f",
				ii, user.interactive (ii).charge,
				cv_time (user.interactive (ii).cpu), float (user.interactive (ii).core / 1e6),
				cv_time (user.interactive (ii).connect),
				float (user.interactive (ii).io_ops / 1e3));
		     end;
		end;

/* P r i n t   a b s e n t e e    u s a g e    */

		temp = 0e0;
		do ii = 1 to 4;
		     temp = temp + user.absentee (ii).charge;
		end;
		if temp = 0e0 then do;
		     call ioa_ ("^/Absentee Usage:^5xnone");
		end;
		else do;
		     call ioa_ ("^/Absentee Usage:     $^.2f", temp);
		     call ioa_ ("^/queue^2x$charge^6xjobs^10xvcpu^5xmemory*K");
		     do ii = 1 to 4;
			if user.absentee (ii).charge = 0e0 then ;
			else call ioa_ ("^1d^4x^8.2f^7x^4d^5x^9a^3x^10.1f^24x", ii, user.absentee (ii).charge,
				user.absentee (ii).jobs, cv_time (user.absentee (ii).cpu),
				float (user.absentee (ii).memory / 1e6));
		     end;
		end;

/*  P r i n t    i o  d a e m o n    u s a g e    */

		temp = 0e0;
		do ii = 1 to 4;
		     temp = temp + user.iod (ii).charge;
		end;
		if temp = 0e0 then do;
		     call ioa_ ("^/IO Daemon Usage:^4xnone");
		end;
		else do;
		     call ioa_ ("^/IO Daemon Usage:    $^.2f", temp);
		     call ioa_ ("^/queue^2x$charge^3xpieces^7xpages^9xlines");
		     do ii = 1 to 4;
			if user.iod (ii).charge = 0e0 then ;
			else call ioa_ ("^1d^4x^8.2f^10d^12d^14d",
				ii, user.iod (ii).charge, user.iod (ii).pieces,
				user.iod (ii).pages, user.iod (ii).lines);
		     end;
		end;
	     end;
SKIP:	end;

	if pmf & ^no_header then call ioa_ ("^/^/end;");

	if sel_name ^= "" & ctr = 0 then do;
	     call com_err_ (0, "print_pdt", "^a not found in ^a.", sel_name, pdt_name);
	end;

TERM:	call hcs_$terminate_noname (pdtp, code);
	return;

cv_time: procedure (time) returns (char (9) aligned);

/* procedure to convert from fixed bin (71) to a nice formatted string of hrs:mins:secs */

/* automatic */

dcl  time fixed bin (71);
dcl  hours fixed bin;
dcl  minutes fixed bin;
dcl  seconds fixed bin;

/* builtins */

dcl  (unspec) builtin;

/* pictures */

dcl  1 time_string aligned,
       2 hours picture "zz9" unaligned,
       2 colon1 char (1) unaligned,
       2 minutes picture "99" unaligned,
       2 colon2 char (1) unaligned,
       2 seconds picture "99" unaligned;

	seconds = float (time, 63) / float (MILLION);
	minutes = divide (seconds, 60, 35, 0);
	seconds = mod (seconds, 60);			/* get rid of the remainder */
	hours = divide (minutes, 60, 35, 0);
	minutes = mod (minutes, 60);			/* get rid of the remainder */

	time_string.colon1 = ":";
	time_string.colon2 = ":";

	if hours < 1000				/* don't die if junque */
	then time_string.hours = hours;
	else unspec (time_string.hours) = unspec (three_asterisks); /* can't say unspec of a constant any more. progress ... */
	time_string.minutes = minutes;
	time_string.seconds = seconds;

	return (string (time_string));
     end;

     end print_pdt;




		    proj_usage_report.pl1           08/29/88  0940.1rew 08/29/88  0859.7      135369



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


proj_usage_report:
pur:
     procedure;

/* PROJ_USAGE_REPORT - Print a month-to-date usage report for a project from the PDT */


/****^  HISTORY COMMENTS:
  1) change(86-01-01,Gilcrease), approve(86-03-27,MCR7369),
     audit(86-06-20,LJAdams), install(86-06-30,MR12.0-1081):
     To make old comments acceptible to history_comment
      Modified Jan 11, 1977 by John Gintell to:
        add -sort fraction_used , add subtotal, fix minor bugs,
        improve output format, and cleanup program
      Modified June 1979 by C. Hornig to:
        print absolute spending and device charges.
      Modified Feb 1980 by M. B. Armstrong to:
        implement multiple rate structures. (UNCA)
      Modified by R. McDonald May 1980 to:
        include page charges (UNCA)
      Modified October 1980 by C. Hornig for:
        time zone problems and -user
      Modified June 1981 by E. N. Kittlitz for:
        UNCA rate-structures, page charging
  2) change(86-02-26,Gilcrease), approve(86-03-27,MCR7369),
     audit(86-06-20,LJAdams), install(86-06-30,MR12.0-1081):
        Add weekly to display array. SCP 6250.
  3) change(87-08-10,GDixon), approve(88-08-15,MCR7969),
     audit(88-08-03,Lippard), install(88-08-29),MR12.2-1093):
     Correct functioning of -user (phx13898, phx15772, phx17001).
                                                   END HISTORY COMMENTS */



dcl  OPEN float bin int static options (constant) init (1e37);
dcl  NEVER fixed bin (71) int static options (constant) init (3124151940000000);
dcl  MILLION fixed bin (35) internal static options (constant) init (1000000);
dcl  cutinc (0:6) character (8) internal static options (constant)
     init ("", ",daily", ",monthly", ",yearly", ",cyear", ",fyear", ",weekly");

dcl  en char (32);
dcl  pdtp ptr;					/* ptr to pdt */
dcl  pdtep ptr;					/* ptr to user entry in pdt */
dcl  nzsw bit (1) aligned;
dcl  flag char (1) aligned;				/* star if user deleted */
dcl  limv char (8) aligned;				/* limit value */
dcl  x (1019) char (32) aligned;			/* sort array */
dcl  y (1019) fixed bin;
dcl  yy (1019) fixed bin;				/* to allow -nz option */
dcl  z (1019) float bin;
dcl  rs_name char (32);
dcl  sort_sw fixed bin;
dcl  brief bit (1);
dcl  no_header bit (1);
dcl  total bit (1);
dcl  user_sw bit (1) aligned;
dcl  long bit (1);
dcl  rev bit (1);
dcl  sc fixed bin;
dcl (user_count, print_count) fixed bin;
dcl  addamt float bin;
dcl  time_string char (24) aligned;
dcl (subtotal_limit, subtotal_nolimit) float bin;		/* subtotals */
dcl  cuttime character (8) aligned;
dcl (h, i, m) fixed bin;
dcl 1 dvt (16) aligned,
    2 name character (8),
    2 price (0:7) float bin;
dcl (begini, endi, incr) fixed bin;
dcl  ap ptr;
dcl  al fixed bin (21);
dcl  ec fixed bin (35);
dcl  con fixed bin (71);
dcl (tempi, tempa, tempio, tempdev) float bin;
dcl  arg_count fixed bin;
dcl  max_rs_number fixed bin;

dcl 1 total_user aligned like user;

dcl  bchr char (al) unaligned based (ap);

dcl (addr, clock, divide, mod, null, rtrim, substr, unspec) builtin;

dcl  error_table_$badopt fixed bin ext;

dcl  user_info_ entry (char (*), char (*), char (*));
dcl  system_info_$device_prices_rs entry (fixed bin, fixed bin, pointer);
dcl  system_info_$rs_name entry (fixed bin, char (*), fixed bin (35));
dcl  idsort_ entry ((*) char (32) aligned, (*) fixed bin, fixed bin);
dcl  flt_bin_sort_ entry ((*) float bin, (*) fixed bin, fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  date_time_ entry (fixed bin (71), char (*) aligned);
dcl  com_err_ entry options (variable);
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  system_info_$max_rs_number entry (fixed bin);

dcl  dirname char (168) static internal init (">system_control_dir>pdt");
%page;
	call system_info_$max_rs_number (max_rs_number);

	sort_sw = 1;
	user_sw, nzsw, brief, long, no_header, total, rev = "0"b;
	sc, user_count = 0;
	en = "";

	call cu_$arg_count (arg_count, ec);
	if ec ^= 0 then do;
bad_arg_code:
	     call com_err_ (ec, "proj_usage_report");
	     return;
	end;
	do i = 1 to arg_count;
	     call cu_$arg_ptr (i, ap, al, ec);
	     if ec ^= 0 then go to bad_arg_code;
	     if /* case */ substr (bchr, 1, 1) ^= "-"
	     then if ^user_sw then do;
		     if en ^= "" then do;
			call com_err_ (0, "proj_usage_report", "Only one project may be specified.");
			return;
		     end;
		     en = bchr || ".pdt";
		end;
		else do;
		     user_count = user_count + 1;
(subrg):
		     x (user_count) = bchr;
		end;
	     else if bchr = "-nz" then nzsw = "1"b;
	     else if bchr = "-user" then do;
		user_sw = "1"b;
		yy (*) = 0;
	     end;
	     else if bchr = "-sort" then do;
		i = i + 1;
		sc = sc + 1;
		call cu_$arg_ptr (i, ap, al, ec);
		if ec ^= 0 then do;
		     call com_err_ (0, "proj_usage_report", "Sort type did not follow -sort control argument.");
VALID:
		     call ioa_ ("Valid types are: use, rem, limit, name, or fraction_used.");
		     return;
		end;
		sort_sw = 0;
		if /* case */ bchr = "name" then sort_sw = 1;
		else if bchr = "use" then sort_sw = 2;
		else if bchr = "rem" then sort_sw = 3;
		else if bchr = "limit" then sort_sw = 4;
		else if bchr = "fraction_used" then sort_sw = 5;
		else do;
		     call com_err_ (0, "proj_usage_report", "Sort type not recognized. ""^a""", bchr);
		     goto VALID;			/* print message and return */
		end;
	     end;
	     else if bchr = "-brief" | bchr = "-bf" then no_header, brief = "1"b;
	     else if bchr = "-no_header" | bchr = "-nhe" then no_header = "1"b;
	     else if bchr = "-total" | bchr = "-tt" then total = "1"b;
	     else if bchr = "-long" | bchr = "-lg" then long = "1"b;
	     else if bchr = "-reverse" | bchr = "-rev" then rev = "1"b;
	     else if bchr = "-pathname" | bchr = "-pn" then do;
		i = i + 1;
		call cu_$arg_ptr (i, ap, al, ec);
		if ec ^= 0 then do;
		     call com_err_ (0, "proj_usage_report", "pathname argument did not follow control argument");
		     return;
		end;
		call expand_pathname_$add_suffix (bchr, "pdt", dirname, en, ec);
		if ec ^= 0 then do;
		     call com_err_ (ec, "proj_usage_report", bchr);
		     return;
		end;
	     end;
	     else do;
		call com_err_ (error_table_$badopt, "proj_usage_report", """^a""", bchr);
		return;
	     end;
	end;

	if sc > 1 then do;
	     call com_err_ (0, "proj_usage_report", "More than one instance of sort control argument.");
	     return;
	end;

	if en = "" then do;
	     call user_info_ ((""), en, (""));
	     en = rtrim (en) || ".pdt";
	end;

	call hcs_$initiate (dirname, en, "", 0, 1, pdtp, ec);
	if pdtp = null () then do;
	     call com_err_ (ec, "proj_usage_report", "^a>^a", dirname, en);
	     return;
	end;

	if ^no_header then do;
	     call date_time_ (clock (), time_string);
	     if max_rs_number > 0 then do;
		call system_info_$rs_name ((pdt.rs_number), rs_name, ec);
		if ec ^= 0 then call com_err_ (ec, "proj_usage_report", "For rate structure ^d.  Contact your system administrator.", pdt.rs_number);
	     end;
	     call ioa_ ("^5x^a PROJECT USAGE REPORT -- ^a^[^/^5xRate Structure -- ^a^;^s^]^/", pdt.project_name, time_string, (max_rs_number > 0), rs_name);
	     call ioa_ (
		" User^19xCharge^4xLimit Logins Interact: Connect; Absentee; IO Daemon; Device; Absolute Spending^/");
	end;

	if ^brief then call system_info_$device_prices_rs ((pdt.rs_number), i, addr (dvt));

	m = 0;					/* initialize count */
	do i = 1 to pdt.current_size;
	     pdtep = addr (pdt.user (i));
	     if (user.state ^= 0) & ((user.dollar_charge ^= 0e0) | ^nzsw) then do;
		if user_sw then do;
		     do m = 1 to user_count;
			if user.person_id = x (m) then goto got_user;
		     end;
		     goto next_user;
		end;
		else do;
		     user_count, m = user_count + 1;
		     x (m) = user.person_id;
		end;

got_user:
		if /* case */ sort_sw = 2 then z (m) = user.dollar_charge;
		else if sort_sw = 3
		then if user.dollar_limit > OPEN
		     then z (m) = OPEN - user.dollar_charge;
		     else z (m) = user.dollar_limit - user.dollar_charge;
		else if sort_sw = 4 then z (m) = user.dollar_limit;
		else if sort_sw = 5 then z (m) = user.dollar_charge / user.dollar_limit;

		y (m) = i;
		yy (m) = m;
	     end;
next_user:
	end;

          m = user_count;
	if m > 1 then
	     if sort_sw = 1
	     then call idsort_ (x, yy, m);
	     else call flt_bin_sort_ (z, yy, m);

	if rev then do;
	     begini = m;
	     endi = 1;
	     incr = -1;
	end;
	else do;
	     begini = 1;
	     endi = m;
	     incr = 1;
	end;

	unspec (total_user) = ""b;
	total_user.state = 1;
	total_user.absolute_limit = OPEN;
	total_user.absolute_cutoff = NEVER;
	total_user.shift_limit = OPEN;
	total_user.dollar_limit = OPEN;
	print_count = 0;
	subtotal_limit, subtotal_nolimit = 0e0;

	do i = begini to endi by incr;
	     if yy (i) > 0 then do;
		print_count = print_count + 1;
		pdtep = addr (pdt.user (y (yy (i))));
		if ^total then call display_user;

		if user.dollar_limit < OPEN
		then subtotal_limit = subtotal_limit + user.dollar_charge;
		else subtotal_nolimit = subtotal_nolimit + user.dollar_charge;
		total_user.logins = total_user.logins + user.logins;
		total_user.interactive = total_user.interactive + user.interactive;
		total_user.absentee = total_user.absentee + user.absentee;
		total_user.iod = total_user.iod + user.iod;
		total_user.devices = total_user.devices + user.devices;
	     end;
	end;

	if print_count ^= 1 then do;
	     call ioa_ ("");
	     if subtotal_limit ^= 0e0 & subtotal_nolimit ^= 0e0
	     then call ioa_ ("SUBTOTAL  (with limit)    $^8.2f", subtotal_limit);

	     call ioa_$rsnnl ("TOTAL (^d users)", total_user.person_id, (0), print_count);
	     total_user.dollar_charge = subtotal_limit + subtotal_nolimit;
	     pdtep = addr (total_user);
	     call display_user;
	end;

	call hcs_$terminate_noname (pdtp, ec);
	return;
%page;
cv_time:
	procedure (time) returns (char (10) aligned);

/* procedure to convert from fixed bin (71) to a nice formatted string of hrs: mins: secs */

dcl  time fixed bin (71);
dcl  j fixed bin;
dcl  hours fixed bin;
dcl  minutes fixed bin;
dcl  seconds fixed bin;
dcl  answer char (10) aligned;


	     seconds = divide (time, MILLION, 35, 0);
	     minutes = divide (seconds, 60, 35, 0);
	     seconds = mod (seconds, 60);		/* get rid of the remainder */
	     hours = divide (minutes, 60, 35, 0);
	     minutes = mod (minutes, 60);		/* get rid of the remainder */

	     call ioa_$rsnnl ("^4d:^2d:^2d", answer, j, hours, minutes, seconds);
	     if substr (answer, 6, 1) = " " then substr (answer, 6, 1) = "0";
	     if substr (answer, 9, 1) = " " then substr (answer, 9, 1) = "0";

	     return (answer);
	end cv_time;


cv_limit:
	procedure (limit, lim, amt);

/* procedure to convert a float bin $limit into either the string, "open", if $limit is >= 1e37,
   or to convert a float bin $limit into an integer $limit  */


dcl  limit float bin;
dcl  lim char (8) aligned;
dcl  amt float bin;
dcl  jj fixed bin;


	     if limit >= OPEN then do;
		lim = "    open";
		amt = 0e0;
	     end;
	     else do;
		call ioa_$rsnnl ("^8.2f", lim, jj, limit);
		amt = limit;
	     end;
	     return;
	end cv_limit;
%page;
display_user:
	procedure;
	     if user.state ^= 0 then do;
		if user.state = 2
		then flag = "*";
		else flag = "";
		if user.now_in > 0 then flag = ">";
		call cv_limit (user.dollar_limit, limv, addamt);
		if brief
		then if limv = "    open" then limv = (8)" ";

		tempi, tempa, tempdev, tempio = 0e0;
		con = 0;
		do h = 0 to 7;
		     tempi = tempi + user.interactive (h).charge;
		     con = con + user.interactive (h).connect;
		end;
		do h = 1 to 4;
		     tempa = tempa + user.absentee (h).charge;
		     tempio = tempio + user.iod (h).charge;
		end;
		do h = 1 to 16;
		     tempdev = tempdev + user.devices (h);
		end;

		if user.absolute_cutoff = NEVER
		then cuttime = "NEVER";
		else call date_time_ (user.absolute_cutoff, cuttime);

		if brief
		then call ioa_ ("^1a^20a $^8.2f ^8a", flag, user.person_id, user.dollar_charge, limv);
		else do;
		     if long then call ioa_ ("");
		     call ioa_ (
			"^1a^20a ^8.2f ^8a ^5d ^8.2f ^10a ^8.2f ^8.2f ^8.2f^[ ^9.2f^;^s^]^[/^.2f^;^s^]^[,^a^;^s^]^a",
			flag, user.person_id, user.dollar_charge, limv, user.logins, tempi, cv_time (con), tempa, tempio,
			tempdev, (user.absolute_spent > 0e0 | user.absolute_limit < OPEN), user.absolute_spent,
			(user.absolute_limit < OPEN), user.absolute_limit, (cuttime ^= "NEVER"), cuttime,
			cutinc (user.absolute_increm));
		end;

		if long then do;
		     do h = 0 to 7;
			if user.interactive (h).charge ^= 0e0 | user.interactive (h).cpu ^= 0
			| user.interactive (h).core ^= 0 | user.interactive (h).connect ^= 0
			| user.interactive (h).io_ops ^= 0
			then call ioa_ (
			     "^-Shift ^d Interactive:^32t^8.2f; CPU = ^8a; KMU = ^6.1f; Connect = ^8a;^[ IO = ^9d;^;^s^]"
			     , h, user.interactive (h).charge, cv_time (user.interactive (h).cpu),
			     user.interactive (h).core / 1e6, cv_time (user.interactive (h).connect),
			     (user.interactive (h).io_ops ^= 0), user.interactive (h).io_ops);
		     end;
		     do h = 1 to 4;
			if user.absentee (h).charge ^= 0e0 | user.absentee (h).jobs ^= 0 | user.absentee (h).cpu ^= 0
			| user.absentee (h).memory ^= 0
			then call ioa_ ("^-Queue ^d Absentee:^32t^8.2f; CPU = ^8a; KMU = ^6.1f; Jobs = ^4d;", h,
			     user.absentee (h).charge, cv_time (user.absentee (h).cpu),
			     user.absentee (h).memory / 1e6, user.absentee (h).jobs);
		     end;
		     do h = 1 to 4;
			if user.iod (h).charge ^= 0e0 | user.iod (h).pieces ^= 0 |
			user.iod (h).pages ^= 0 | user.iod (h).lines ^= 0
			then call ioa_ ("^-Queue ^d IO Daemon:^32t^8.2f; ^6d Pieces, ^5d Pages, ^8d Lines;", h,
			     user.iod (h).charge, user.iod (h).pieces,
			     user.iod (h).pages, user.iod (h).lines);
		     end;
		     do h = 1 to 16;
			if user.devices (h) ^= 0e0
			then call ioa_ ("^-Device ^a^32t^8.2f", dvt (h).name, user.devices (h));
		     end;
		end;
	     end;
	end display_user;
%page;
%include user_attributes;
%include pdt;

     end proj_usage_report;




		    translator_temp_.pl1            11/04/82  1949.0rew 11/04/82  1625.8       62037



/* ***************************************************************
   *                                                             *
   * Copyright, (C) Honeywell Information Systems Inc., 1981     *
   *                                                             *
   * Copyright (c) 1975 by Massachusetts Institute of Technology *
   *                                                             *
   * Copyright (c) 1972 by Massachusetts Institute of            *
   * Technology and Honeywell Information Systems, Inc.          *
   *                                                             *
   *************************************************************** */




	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* N__a_m_e: translator_temp_							*/
	/*									*/
	/*      This subroutine performs very fast, no_freeing-style storage allocations	*/
	/* (similar to those of alloc_ in a no-freeing area).  Its advantage over alloc_ or the	*/
	/* PL/I allocate operator is that it has an associated include file containing an	*/
	/* allocation procedure which is quicker to execute that a PL/I allocate statement.	*/
	/*									*/
	/*      Historically, this routine was written before the PL/I allocate operator	*/
	/* existed (ie, all PL/I allocate statements were implemented as subroutine calls to the	*/
	/* external alloc_ subroutine), and before no-freeing areas were known to alloc_.  Given	*/
	/* that several programs use it, we must continue to support it.			*/
	/*									*/
	/* S__t_a_t_u_s									*/
	/*									*/
	/* 0) Created by:  G. C. Dixon  in  January, 1975					*/
	/* 1) Modified by: G. C. Dixon  in  February, 1981 - use get_temp_segment_ to obtain	*/
	/*    temporary segments, rather than teco's get_temp_seg_ subroutine.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


translator_temp_:
	procedure;

     dcl	program_id		char(*) aligned,	/* Name of program wanting temporary segs. (In)	*/
	APseg			ptr,		/* ptr to the temporary segment. (In/Out)	*/
	code			fixed bin(35),	/* a status code. (Out)			*/
	APold_seg			ptr,		/* ptr to a previously-obtained temp seg. (In)	*/
	Nwords			fixed bin;	/* number of words to be allocated from temp seg.	*/
						/* (In)					*/

     dcl	Pnext_seg			ptr,		/* temp pointers.				*/
	Pprev_seg			ptr,
	Pseg			ptr;

     dcl						/*		based variables		*/
	1 seg			aligned based (Pseg),
						/* header of the temporary segment.		*/
	  2 Pfirst_temp_seg		ptr unal,		/*   ptr to first temp seg of a group.		*/
	  2 Ofree			fixed bin(35),	/*   offset of next free word in temp seg.	*/
	  2 Lfree			fixed bin(35),	/*   length of remaining free space in temp seg.	*/
	  2 Pprev_temp_seg		ptr unal,		/*   ptr to immediately previous temp seg of group*/
	  2 Pnext_temp_seg		ptr unal,		/*   ptr to next temp seg of group.		*/
	  2 pad1 (3)		fixed bin(35),
	  2 seg_type		char(16),		/*   set to "translator_temp_" for dumping id.	*/
	  2 pad2 (4)		fixed bin(35),
	  2 program_id		char(32);		/*   program name to be passed to 		*/
						/*     release_temp_segment_.			*/

     dcl (null, size)		builtin;

     dcl						/*		entries			*/
	get_temp_segment_		entry (char(*) aligned, ptr, fixed bin(35)),
	release_temp_segment_	entry (char(*) aligned, ptr, fixed bin(35));

     dcl						/*		static variables		*/
	sys_info$max_seg_size	fixed bin(35) ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_segment:	entry (program_id, APseg, code);	/* get ptr to first temporary segment associated 	*/
						/*   with this invocation of named program.	*/

	call get_temp_segment_ (program_id, Pseg, code);
	if Pseg ^= null then do;			/* create a temp seg in process directory.	*/
	     seg.Pfirst_temp_seg = Pseg;
	     seg.Ofree = size(seg);
	     seg.Lfree = sys_info$max_seg_size - size(seg);
	     seg.Pprev_temp_seg = null;
	     seg.Pnext_temp_seg = null;
	     seg.pad1(*) = 0;
	     seg.seg_type = "translator_temp_";
	     seg.pad2(*) = 0;
	     seg.program_id = program_id;
	     end;
	APseg = Pseg;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


get_next_segment:
	entry (APold_seg, APseg, code);		/* get subsequent temporary segments associated	*/
						/*   with this temp segment group.		*/

	do Pseg = APold_seg repeat seg.Pnext_temp_seg	/* find last temp seg in chained list.		*/
	   while (seg.Pnext_temp_seg ^= null);
	     end;
	Pprev_seg = Pseg;
	call get_temp_segment_ (seg.program_id, Pseg, code);
	if Pseg ^= null then do;
	     seg.Pfirst_temp_seg = Pprev_seg -> seg.Pfirst_temp_seg;
	     seg.Ofree = size(seg);
	     seg.Lfree = sys_info$max_seg_size - size(seg);
	     seg.Pprev_temp_seg = Pprev_seg;
	     seg.Pnext_temp_seg = null;
	     seg.pad1(*) = 0;
	     seg.seg_type = "translator_temp_";
	     seg.pad2(*) = 0;
	     seg.program_id = Pprev_seg->seg.program_id;
	     Pprev_seg->seg.Pnext_temp_seg = Pseg;
	     end;
	APseg = Pseg;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


release_segment:
	entry (APseg, code);			/* release a single one of the temporary segments	*/
						/*   associated with this temp seg group.	*/

	Pseg = APseg;
	Pprev_seg = seg.Pprev_temp_seg;		/* unchain this temp seg from previous in group.	*/
	if Pprev_seg ^= null then
	     Pprev_seg -> seg.Pnext_temp_seg = seg.Pnext_temp_seg;
	Pnext_seg = seg.Pnext_temp_seg;		/* unchain this temp seg from next in group.	*/
	if Pnext_seg ^= null then
	     Pnext_seg -> seg.Pprev_temp_seg = seg.Pprev_temp_seg;

	call release_temp_segment_ (seg.program_id, APseg, code);
	if code = 0 then APseg = null;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

release_all_segments:
	entry (APseg, code);			/* release all of the temporary segments	*/
						/*   associated with this temp seg group.	*/

	do Pseg = APseg->seg.Pfirst_temp_seg repeat Pnext_seg
	   while (Pseg ^= null);
	     Pnext_seg = seg.Pnext_temp_seg;
	     call release_temp_segment_ (seg.program_id, Pseg, code);
	     if code ^= 0 then return;
	     end;
	APseg = null;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


allocate:	entry (APseg, Nwords) returns (ptr);		/* allocate space in one of the temp segs.	*/

	return (allocate (APseg, Nwords));

%include translator_temp_alloc;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	end translator_temp_;




		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
