adjust_cutoff_.pl1 12/11/99 1832.9re 12/11/99 1815.0 34074 /****^ *********************************************************** * * * 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. 3) change(99-06-23,Haggett): Y2K 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 (4418064000000000); 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 12/11/99 1832.9re 12/11/99 1826.9 484668 /* ************************************************************** * * * 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 : ; / LEX(2) set_project_name LEX(2) / head \ / / ERROR(2) / RETURN \ head / Grace : ; / LEX(2) [default.bump_grace = token.Nvalue] LEX(2) / head \ / Attributes : / LEX(2) PUSH(head) PUSH(assign_default_attributes) / attrsub \ / Initproc : , 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 : ; / 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 : ; / LEX(2) ERROR(22) LEX(2) / head \ / Subsystem : ; / LEX(2) set_ip_ss (default_subsystem,default.uflags.ss_given, default.ss_len) LEX(2) / head \ / Subsystem : ; / LEX(2) ERROR(22) LEX(2) / head \ / Homedir : ; / LEX(2) [call set_string ("Homedir", default.home_dir, token_value)] LEX(2) / head \ / Homedir : ; / LEX(2) ERROR(22) LEX(2) / head \ / Outer_module : ; / LEX(2) [call set_string ("Outer_module", default.outer_module, token_value)] LEX(2) / head \ / Outer_module : ; / LEX(2) ERROR(22) LEX(2) / head \ / Lot_size : , own ; / LEX(2) [default.lot_size = -token.Nvalue] LEX(4) / head \ / Lot_size : , stack ; / LEX(2) [default.lot_size = token.Nvalue] LEX(4) / head \ / Lot_size : ; / LEX(2) [default.lot_size = token.Nvalue] LEX(2) / head \ / Kst_size : ; / LEX(2) [default.kst_size = token.Nvalue] LEX(2) / head \ / Cls_size : , stack ; / LEX(2) [default.cls_size = -token.Nvalue] LEX(4) / head \ / Cls_size : , own ; / LEX(2) [default.cls_size = token.Nvalue] LEX(4) / head \ / Cls_size : ; / LEX(2) [default.cls_size = token.Nvalue] LEX(2) / head \ / Pdir_quota : ; / LEX(2) [default.pdir_quota = token.Nvalue] LEX(2) / head \ / Max_foreground : ; / LEX(2) [default.max_foreground = token.Nvalue] LEX(2) / head \ / Max_background : ; / LEX(2) [default.max_background = token.Nvalue] LEX(2) / head \ / Abs_foreground_cpu_limit : ; / 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 : ; / LEX(2) [default.user_warn_days = token.Nvalue] LEX(2) / head \ / User_warn_percent : ; / 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 : ; / LEX(2) [default.warn_days = token.Nvalue] LEX(2) / head \ / Warn_percent : ; / LEX(2) [default.warn_pct = token.Nvalue] LEX(2) / head \ / Warn_dollars : / LEX(2) PUSH(head) PUSH(default_warn_doll) / number \ / Ring : , , ; / 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 : , ; / LEX(2) [default.low_ring = token.Nvalue] [default.default_ring = token.Nvalue] LEX(2) [default.high_ring = token.Nvalue] LEX (2) / head \ / Ring : ; / LEX(2) [default.low_ring = token.Nvalue] [default.default_ring = token.Nvalue] [default.high_ring = token.Nvalue] LEX(2) / head \ / Authorization : ; / LEX(2) [default.user_authorization = authorization_value] check_default_authorization LEX(2) / head \ / Authorization : ; / LEX(2) ERROR(25) LEX(2) / head \ / Group : ; / 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 \ / / ERROR(1) NEXT_STMT / head \ / / ERROR(5) / RETURN \ error_23_in_head / / ERROR (23) NEXT_STMT / head \ user / end ; / close / RETURN \ / end ; / ERROR (35) close / RETURN \ / personid : * ; / LEX(3) close open_anon LEX / user \ / personid : ; / LEX(2) close open LEX(2) / user \ / password : ; / LEX(2) [call set_string ("password", user.password, token_value)] LEX(2)/ user \ / ring : , , ; / 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 : , ; / LEX(2) [user.low_ring = token.Nvalue] [user.default_ring = token.Nvalue] LEX(2) [user.high_ring = token.Nvalue] LEX(2) / user \ / ring : ; / LEX(2) [user.low_ring = token.Nvalue] [user.default_ring = token.Nvalue] [user.high_ring = token.Nvalue] LEX(2) / user \ / initproc : , 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 : ; / 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 : ; / LEX(2) ERROR(22) LEX(2) / user \ / subsystem : ; / LEX(2) set_ip_ss (user_subsystem, user.uflags.ss_given, user.ss_len) LEX(2) / user \ / subsystem: ; / LEX(2) ERROR(22) LEX(2) / user \ / homedir : ; / LEX(2) [call set_string ("homedir", user.home_dir, token_value)] LEX(2)/ user \ / homedir : ; / LEX(2) ERROR(22) LEX(2) / user \ / outer_module : ; / LEX(2) [call set_string ("outer_module", user.outer_module, token_value)] LEX(2)/ user \ / outer_module : ; / LEX(2) ERROR(22) LEX(2) / user \ / lot_size : , own ; / LEX(2) [user.lot_size = -token.Nvalue] LEX(4) / user \ / lot_size : , stack ; / LEX(2) [user.lot_size = token.Nvalue] LEX(4) / user \ / lot_size : ; / LEX(2) [user.lot_size = token.Nvalue] LEX(2) / user \ / kst_size : ; / LEX(2) [user.kst_size = token.Nvalue] LEX(2) / user \ / cls_size : , stack ; / LEX(2) [user.cls_size = -token.Nvalue] LEX(4) / user \ / cls_size : , own ; / LEX(2) [user.cls_size = token.Nvalue] LEX(4) / user \ / cls_size : ; / LEX(2) [user.cls_size = token.Nvalue] LEX(2) / user \ / pdir_quota : ; / LEX(2) [user.pdir_quota = token.Nvalue] LEX(2) / user \ / max_foreground : ; / LEX(2) [user.max_foreground = token.Nvalue] LEX(2) / user \ / max_background : ; / LEX(2) [user.max_background = token.Nvalue] LEX(2) / user \ / abs_foreground_cpu_limit : ; / LEX(2) [user.abs_foreground_cpu_limit = token.Nvalue] LEX(2) / user \ / cutoff : / LEX(2) PUSH(user) PUSH(cutoff) / number \ / grace : ; / 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 : ; / LEX(2) [user.user_warn_days = token.Nvalue] LEX(2)/ user \ / user_warn_percent : ; / 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 : ; / LEX(2) [user.warn_days = token.Nvalue] LEX(2) / user \ / warn_percent : ; / LEX(2) [user.warn_pct = token.Nvalue] LEX(2) / user \ / warn_dollars : / LEX(2) PUSH(user) PUSH(warn_doll) / number \ / authorization : ; / LEX(2) [user.user_authorization = authorization_value] check_user_authorization LEX(2) / user \ / authorization : ; / LEX(2) ERROR(25) LEX(2) / user \ / group : ; / LEX(2) [call set_string ("group", user.group, token_value)] LEX(2) / user \ / Grace : ; / LEX(2) [default.bump_grace = token.Nvalue] LEX(2) / user \ / Attributes : / LEX(2) PUSH(user) PUSH(assign_default_attributes) / attrsub \ / Initproc : , 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 : ; / 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 : ; / LEX(2) ERROR(22) LEX(2) / user \ / Subsystem : ; / LEX(2) set_ip_ss (default_subsystem, default.uflags.ss_given, default.ss_len) LEX(2) / user \ / Subsystem : ; / LEX(2) ERROR(22) LEX(2) / user \ / Homedir : ; / LEX(2) [call set_string ("Homedir", default.home_dir, token_value)] LEX(2) / user \ / Homedir : ; / LEX(2) ERROR(22) LEX(2) / user \ / Outer_module : ; / LEX(2) [call set_string ("Outer_module", default.outer_module, token_value)] LEX(2) / user \ / Outer_module : ; / LEX(2) ERROR(22) LEX(2) / user \ / Lot_size : , own ; / LEX(2) [default.lot_size = -token.Nvalue] LEX(4) / user \ / Lot_size : , stack ; / LEX(2) [default.lot_size = token.Nvalue] LEX(4) / user \ / Lot_size : ; / LEX(2) [default.lot_size = token.Nvalue] LEX(2) / user \ / Kst_size : ; / LEX(2) [default.kst_size = token.Nvalue] LEX(2) / user \ / Cls_size : , stack ; / LEX(2) [default.cls_size = -token.Nvalue] LEX(4) / user \ / Cls_size : , own ; / LEX(2) [default.cls_size = token.Nvalue] LEX(4) / user \ / Cls_size : ; / 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 : ; / LEX(2) [default.user_warn_days = token.Nvalue] LEX(2)/ user \ / User_warn_percent : ; / 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 : ; / LEX(2) [default.warn_days = token.Nvalue] LEX(2) / user \ / Warn_percent : ; / LEX(2) [default.warn_pct = token.Nvalue] LEX(2) / user \ / Warn_dollars : / LEX(2) PUSH(user) PUSH(default_warn_doll) / number \ / Ring : , , ; / 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 : , ; / LEX(2) [default.low_ring = token.Nvalue] [default.default_ring = token.Nvalue] LEX(2) [default.high_ring = token.Nvalue] LEX(2) / user \ / Ring : ; / LEX(2) [default.low_ring = token.Nvalue] [default.default_ring = token.Nvalue] [default.high_ring = token.Nvalue] LEX(2) / user \ / Authorization : ; / LEX(2) [default.user_authorization = authorization_value] LEX(2) / user \ / Authorization : ; / LEX(2) ERROR(25) LEX(2) / user \ / Group : ; / 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 \ / / ERROR(3) NEXT_STMT / user \ / / 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 \ / / ERROR(4) NEXT_STMT / STACK_POP \ / / ERROR(5) / RETURN \ atts / , / LEX [sx = ON] / attloop \ gobble_semi / ; / LEX / STACK_POP \ / / ERROR(4) NEXT_STMT / STACK_POP \ / / 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] / \ / / cv_float_ (token_value, (0), t) LEX / STACK_POP \ / / [t = 1e0*token.Nvalue] LEX / STACK_POP \ / open / [t = BIGFLO] LEX / STACK_POP \ / / ERROR(6) NEXT_STMT LEX(-1) / STACK_POP \ / / ERROR(5) / RETURN \ default_monthlim / ; / LEX [default.dollar_limit = t] / STACK_POP \ / / ERROR(7) NEXT_STMT / STACK_POP \ / / ERROR(5) / RETURN \ monthlim / ; / LEX [user.dollar_limit = t] / STACK_POP \ / / ERROR(7) NEXT_STMT / STACK_POP \ / / 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 \ / , ; / [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 \ / , ; / [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 \ / / [date_string = date_string || token_value || " "] LEX / date_loop \ / / ERROR(8) / STACK_POP \ check_date / / / 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 \ / / ERROR(7) NEXT_STMT / STACK_POP \ / / ERROR(5) / RETURN \ warn_doll / ; / LEX [user.warn_dollars = t] / STACK_POP \ / / ERROR(7) NEXT_STMT / STACK_POP \ / / ERROR(5) / RETURN \ default_user_warn_doll / ; / LEX [default.user_warn_dollars = t] / STACK_POP \ / / ERROR(7) NEXT_STMT / STACK_POP \ / / ERROR(5) / RETURN \ user_warn_doll/ ; / LEX [user.user_warn_dollars = t] / STACK_POP \ / / ERROR(7) NEXT_STMT / STACK_POP \ / / 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 (4418064000000000) static options (constant); 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,,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 12/11/99 1832.9re 12/11/99 1815.0 101898 /****^ *********************************************************** * * * 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 when there are no authorized groups in -long output. (phx16057) 2) change(99-06-23,Haggett): Y2K 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 (4418064000000000) options (constant); 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:^-^[^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 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 12/11/99 1832.9re 12/11/99 1815.0 166104 /****^ *********************************************************** * * * 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. 3) change(99-06-23,Haggett): Y2K 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 (18); dcl datstng char (26); dcl datstr char (10); 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_$format entry (char(*), fixed binary(71), char(*), char(*)) returns(char(250) varying); 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; %page; DATE_TIME: procedure (p_clock, p_dt_str); dcl p_clock fixed binary (71) parameter; dcl p_dt_str char (*) parameter; p_dt_str = date_time_$format ("^9999yc-^my-^dm ^Hd^99v.9MH ^xxxxza^xxxda.", p_clock, "", ""); return; end DATE_TIME; end print_pdt;  proj_usage_report.pl1 12/11/99 1832.9re 12/11/99 1815.0 135720 /****^ *********************************************************** * * * 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). 4) change(99-06-23,Haggett): Y2K END HISTORY COMMENTS */ dcl OPEN float bin int static options (constant) init (1e37); dcl NEVER fixed bin (71) int static options (constant) init (4418064000000000); 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