change_kst_attributes.pl1 11/15/82 1851.4rew 11/15/82 1518.3 37719 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ change_kst_attributes: cka: proc; /* Written 03/31/76 by R. Bratt This procedure allows users to easily call hardcore to set attributes in their ksts. It attempts to use hphcs_$set_kst_attributes first. If the caller lacks hphcs_ access then phcs_$set_kst_attributes is called. */ dcl ap ptr, al fixed bin, i fixed bin (17), terminate bit (1) aligned, value bit (1) aligned, segno fixed bin (17), segptr ptr, args fixed bin, arg char (al) based (ap), dname char (168), ename char (32), code fixed bin (35); dcl linkage_error condition; dcl error_table_$badopt ext fixed bin (35); dcl 1 ka aligned like kst_attributes; dcl cu_$arg_count entry returns (fixed bin), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), (ioa_, com_err_) entry options (variable), cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin), expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)), (hcs_$initiate, phcs_$initiate) entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), (phcs_$set_kst_attributes, hphcs_$set_kst_attributes) entry (fixed bin (17), ptr, fixed bin (35)); /* */ i = 2; terminate = "0"b; call cu_$arg_ptr (1, ap, al, code); if code ^= 0 then do; complain: call ioa_ ("USAGE: change_kst_attributes name|segno "); return; end; segno = cv_oct_check_ (arg, code); if code ^= 0 then do; if arg = "-name" | arg = "-nm" then do; i = 3; call cu_$arg_ptr (2, ap, al, code); if code ^= 0 then go to complain; end; call expand_path_ (ap, al, addr (dname), addr (ename), code); if code ^= 0 then call abort (code, ""); call hcs_$initiate (dname, ename, "", 0, 1, segptr, code); if segptr = null () then do; call phcs_$initiate (dname, ename, "", 0, 1, segptr, code); if segptr = null () then call abort (code, ""); end; else terminate = (code ^= 0); segno = binary (baseno (segptr), 18); end; unspec (ka) = "0"b; args = cu_$arg_count (); do i = i to args; call cu_$arg_ptr (i, ap, al, (0)); if substr (arg, 1, 1) = "^" then do; value = "0"b; ap = addr (substr (arg, 2)); al = al -1; end; else value = "1"b; if arg = "tpd" then do; ka.set.tpd = "1"b; ka.value.tpd = value; end; else if arg = "tms" then do; ka.set.tms = "1"b; ka.value.tms = value; end; else if arg = "tus" then do; ka.set.tus = "1"b; ka.value.tus = value; end; else if arg = "allow_deactivate" then do; ka.set.explicit_deactivate_ok = "1"b; ka.value.explicit_deactivate_ok = value; end; else if arg = "allow_write" then do; ka.set.allow_write = "1"b; ka.value.allow_write = value; end; else if arg = "audit" then do; ka.set.audit = "1"b; ka.value.audit = value; end; else call abort (error_table_$badopt, arg); end; on linkage_error begin; revert linkage_error; call phcs_$set_kst_attributes (segno, addr (ka), code); go to check; end; call hphcs_$set_kst_attributes (segno, addr (ka), code); check: if terminate then call hcs_$terminate_noname (segptr, (0)); if code ^= 0 then call abort (code, ""); return; abort: proc (code, msg); dcl code fixed bin (35), msg char (*); call com_err_ (code, "change_kst_attributes", msg); go to return_to_caller; end abort; return_to_caller: return; /* */ %include kst_attributes; end change_kst_attributes; deactivate_seg.pl1 02/29/84 0814.0rew 02/29/84 0812.0 44739 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ deactivate_seg: proc (); /* Written April 1, 1976 by R. Bratt for testing of demand deactivate Added -force control argument, for hphcs_, 04/21/81, W. Olin Sibert Fixed error msg. 1/23/84 C Spitzer */ dcl (argno, nargs) fixed bin; dcl code fixed bin (35); dcl ap ptr; dcl al fixed bin (21); dcl arg char (al) based (ap); dcl segno fixed bin (17); dcl segptr ptr; dcl dname char (168); dcl ename char (32); dcl force_sw bit (1) aligned; dcl terminate_sw bit (1) aligned; dcl uid bit (36) aligned; dcl error_table_$badopt fixed bin (35) external static; dcl error_table_$noarg fixed bin (35) external static; dcl error_table_$too_many_args fixed bin (35) external static; 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 com_err_ entry options (variable); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$get_uid_seg entry (pointer, bit (36) aligned, 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 hphcs_$deactivate entry (bit (36) aligned, fixed bin (35)); dcl pathname_ entry (char(*), char(*)) returns(char(168)); dcl phcs_$deactivate entry (ptr, fixed bin (35)); dcl phcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl WHOAMI char (32) internal static options (constant) init ("deactivate_seg"); dcl (cleanup, linkage_error) condition; dcl (baseptr, char, null) builtin; /* */ segno = -1; dname = ""; terminate_sw = "0"b; force_sw = "0"b; call cu_$arg_count (nargs, code); if code ^= 0 then do; call com_err_ (code, WHOAMI); MAIN_RETURN: return; end; do argno = 1 to nargs; call cu_$arg_ptr (argno, ap, al, (0)); if (arg = "-force") | (arg = "-fc") then force_sw = "1"b; else if (char (arg, 1) = "-") then do; call com_err_ (error_table_$badopt, WHOAMI, "^a", arg); goto MAIN_RETURN; end; else do; /* segno or pathname */ if (segno >= 0) | (dname ^= "") then do; code = error_table_$too_many_args; goto USAGE; end; segno = cv_oct_check_ (arg, code); if code ^= 0 then do; /* Not a segno, try a pathname */ call expand_pathname_ (arg, dname, ename, code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "^a", arg); goto MAIN_RETURN; end; else segno = -1; /* reset to default */ end; end; end; /* of argument loop */ if (segno = -1) & (dname = "") then do; code = error_table_$noarg; USAGE: call com_err_ (code, WHOAMI, "^/Usage:^-^a segno|pathname {-force}", WHOAMI); goto MAIN_RETURN; end; /* */ on condition (linkage_error) begin; call com_err_ (0, WHOAMI, "This procedure requires privileged access: phcs_^[, hphcs_^].", force_sw); goto MAIN_RETURN; end; on condition (cleanup) begin; if terminate_sw then if segptr ^= null () then call hcs_$terminate_noname (segptr, (0)); segptr = null (); end; if (dname ^= "") then do; /* must initiate it first */ call hcs_$initiate (dname, ename, "", 0, 1, segptr, code); if segptr = null () then /* A directory, maybe? */ call phcs_$initiate (dname, ename, "", 0, 0, segptr, code); else terminate_sw = "1"b; if segptr = null () then do; /* If still null, give up */ PATH_ERROR: call com_err_ (code, WHOAMI, "^a^[>^]^a", dname, (dname ^= ">"), ename); goto MAIN_RETURN; end; call hcs_$get_uid_seg (segptr, uid, code); if code ^= 0 then goto PATH_ERROR; end; else do; /* Otherwise, just get the UID */ segptr = baseptr (segno); call hcs_$get_uid_seg (segptr, uid, code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Segment ^o", segno); goto MAIN_RETURN; end; end; if force_sw then /* Highly privileged */ call hphcs_$deactivate (uid, code); else call phcs_$deactivate (segptr, code); if code ^= 0 then /* Mention it */ call com_err_ (code, WHOAMI, "Deactivating ^[^o^;^s^a^]", (segno >= 0), segno, pathname_ (dname, ename)); if terminate_sw then call hcs_$terminate_noname (segptr, (0)); goto MAIN_RETURN; /* All done */ end deactivate_seg; send_ips.pl1 08/27/84 1443.8rew 08/22/84 1220.5 56223 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style5 */ /* DESCRIPTION: Command to send IPS signals or ipc_ wakeups, to help fix system problems. */ /* HISTORY: Written by T. Casey, May 1978. Modified: 09/01/78 by T. Casey: Fix bugs and improve the error messages. 05/01/80 by T. Casey: Make it match MCR 4051 and fix a bug. 07/15/84 by R. Michael Tague: IPS signal names have been lengthened, so signal_arg was changed to a char (32) varying instead of char(8). */ send_ips: proc; dcl (ppid, pips, pmsg) ptr; dcl (lpid, lips, lmsg) fixed bin; dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl proc_id char (lpid) based (ppid); dcl ips_name char (lips) based (pips); dcl msg_arg char (lmsg) based (pmsg); dcl hphcs_$ips_wakeup entry (bit (36) aligned, char (*)); dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)); dcl event fixed bin (71) init (0); dcl ev_msg char (8) based (addr (event)); dcl rqargs fixed bin; dcl evaci bit (1) aligned; dcl evchn fixed bin (71); dcl code fixed bin (35); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl b36 bit (36) aligned; dcl fb35 fixed bin (35); dcl (addr, length, max, min, substr, unspec, verify) builtin; dcl (ioa_, com_err_) entry options (variable); dcl me char (12); dcl i fixed bin; dcl signal_arg char (32) varying; dcl convert_ipc_code_ entry (fixed bin (35)); dcl linkage_error condition; me = "send_ips"; rqargs = 2; /* send_ips wants 2 args */ send_common: evaci = "1"b; /* assume message (or ips name) is ascii */ call cu_$arg_count (i); if i ^= rqargs /* if wrong number of arguments */ &^(rqargs = 3 & i = 2) /* (other than omission of the optional 3rd arg to send_wakeup) */ then do; /* print a usage message */ if rqargs = 2 then call com_err_ (0, me, "Usage: send_ips process_id ips_name"); else call com_err_ (0, me, "Usage: send_wakeup process_id event_channel {event_message}"); return; end; /* Pick up first 2 args: process id and ips name or event channel */ call cu_$arg_ptr (1, ppid, lpid, code); fb35 = cv_oct_check_ (proc_id, code); if code ^= 0 then do; call com_err_ (0, me, """^a"" (process_id) is non-octal (digit ^d)", proc_id, code); return; end; b36 = unspec (fb35); call cu_$arg_ptr (2, pips, lips, (0)); signal_arg = ips_name; /* copy the ips name into a temp for printing */ /* If send_wakeup entry point, pick up optional event message (arg 3) and convert the event channel (arg 2) */ if rqargs = 3 then do; call cu_$arg_ptr (3, pmsg, lmsg, code); /* check for optional event message argument */ if code = 0 then do; /* if argument there, see if it is ASCII or octal */ event = cv_dbl_oct_check (msg_arg, code); /* try octal first */ if code ^= 0 then do; /* not octal; could be ASCII */ if length (msg_arg) > 8 then do; /* but it must be <= 8 chars */ call com_err_ (0, me, """^a"" is an invalid event message (non-octal (digit ^d) and > 8 chars)", msg_arg, code); return; end; ev_msg = msg_arg; /* copy ascii event msg into string overlay of fb(71) event msg */ signal_arg = msg_arg; /* also copy it into temp for printing */ end; else evaci = ""b; /* remember that event message was octal */ end; /* end event message (3rd arg) given */ else evaci = ""b; /* no message was given; we will send octal zeros */ evchn = cv_dbl_oct_check (ips_name, code); /* convert event channel (2nd arg) to fixed bin */ if code ^= 0 then do; call com_err_ (0, me, """^a"" (event_channel) is non-octal (digit ^d)", ips_name, code); return; end; end; /* Print args, send the signal, and print "sent it" message */ call ioa_ ("^a: sending ^[^a^s^;^s^.3b^] to ^.3b^[ (^.3b)^]", me, evaci, signal_arg, unspec (event), unspec (b36), (rqargs = 3), unspec (evchn)); code = 0; if rqargs = 2 then do; on linkage_error begin; call com_err_ (0, me, "Unable to send ips signal; process lacks re access to the hphcs_ gate."); goto RETURN; end; call hphcs_$ips_wakeup (b36, (ips_name)); /* pass by value for allignment */ revert linkage_error; end; else do; call hcs_$wakeup (b36, evchn, event, code); if code ^= 0 then do; call convert_ipc_code_ (code); call com_err_ (code, me, "(from hcs_$wakeup)"); end; end; if code = 0 then call ioa_ ("^a: sent it.", me); RETURN: return; /* Entry point to send and ipc_ wakeup */ send_wakeup: entry; me = "send_wakeup"; rqargs = 3; /* this entry point can have 3 arguments */ goto send_common; cv_dbl_oct_check: proc (dbloct, code) returns (fixed bin (71)); /* to convert a double length (24 digit) octal number */ dcl dbloct char (*); dcl code fixed bin (35); dcl fb71 fixed bin (71); dcl fb35 (2) fixed bin (35) based (addr (fb71)); dcl i fixed bin; code = verify (dbloct, "01234567"); /* verify that it contains only octal digits */ if code ^= 0 then return (0); i = length (dbloct); /* and is no longer than 24 digits */ if i > 24 then do; code = 25; return (0); end; fb71 = 0; /* zero the return value */ if i > 12 then /* if more than 12 digits, convert upper half */ fb35 (1) = cv_oct_check_ (substr (dbloct, 1, i-12), code); if code ^= 0 then return (0); fb35 (2) = cv_oct_check_ (substr (dbloct, max (1, i-11), min (i, 12)), code); /* convert lower half */ if code ^= 0 then do; code = code + i - 12; /* say which digit is bad, counting from start of string */ return (0); end; return (fb71); end cv_dbl_oct_check; end send_ips; set_system_search_rules.pl1 11/15/82 1851.4rew 11/15/82 1518.5 56457 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ set_system_search_rules: proc; /* set_system_search_rules - set default search rules and define search rule keywords. Usage: set_system_search_rules path The file path contains lines defining search rules. Each line has a search spec followed by one or more tags separated by commas. The search spec may be: . an absolute pathname . initiated_segments . referencing_dir . working_dir . process_dir . home_dir The tags are up to 32 characters long. They define keywords which user processes specify to refer to groups of directories. Thus if the user process specifies the single rule "default", all rules tagged with "default" will be inserted in the search spec. Recursion is forbidden. To duplicate the system default default rules use a file like this: initiated_segments, default referencing_dir, default working_dir, default >system_library_standard, default, system_libraries >system_library_unbundled, default, system_libraries >system_library_1, default, system_libraries >system_library_tools, default, system_libraries Written by THVV 7/76 */ /* Modified by S.E. Barr 1/77 to correct search rule structure; allow blank lines and comments without commas. */ xsp = addr (temp); /* Initialization. Find input structure for hardcore */ unspec (temp) = "0"b; dft_sr_arg.ntags = 0; dft_sr_arg.nrules = 0; call cu_$arg_ptr (1, ap, al, ec); /* Argument is path name */ if ec ^= 0 then do; call com_err_ (ec, "set_system_search_rules", "Usage: set_system_search_rules path"); return; end; call expand_path_ (ap, al, addr (dn), addr (en), ec); if ec ^= 0 then do; call com_err_ (ec, "set_system_search_rules", "^a", bchr); return; end; call hcs_$initiate_count (dn, en, "", bitc, 1, segp, ec); if segp = null then do; call com_err_ (ec, "set_system_search_rules", "^a>^a", dn, en); return; end; k = 1; /* K points at beginning of current line */ N = divide (bitc, 9, 24, 0); do while (k <= N); /* Do one line at a time */ j = index (substr (bcs, k), NL); /* Find end of line */ if j = 0 then k = N+1; /* Force end of loop */ else do; if substr (bcs, k, 1) = "*" then; /* Comment if star in col 1 */ else do; m = index (substr (bcs, k, j), ","); /* Separate dir name from tags */ if m = 0 then call com_err_ (0, "set_system_search_rules", "No comma, line ignored: ^a", substr (bcs, k, j)); else do; mm = verify (substr (bcs, k, m-1), WHITE_SPACE) -1; /* Press off leading blanks */ rule = substr (bcs, k+mm, m-1-mm); if rule = "" then; /* Skip blank lines */ else if substr (rule, 1, 1) = ">" /* Check rule validity */ | rule = "initiated_segments" | rule = "referencing_dir" | rule = "process_dir" | rule = "home_dir" | rule = "working_dir" then do; dft_sr_arg.nrules = dft_sr_arg.nrules + 1; /* Make room for rule */ if dft_sr_arg.nrules > hbound (dft_sr_arg.rules, 1) then do; call com_err_ (0, "set_system_search_rules", "too many rules: ^a", rule); return; end; dft_sr_arg.rules (dft_sr_arg.nrules).name = rule; /* Store it */ do while (substr (bcs, k+m, j-m) ^= ""); kk = index (substr (bcs, k+m, j-m), ","); /* Find end of tag */ if kk = 0 then kk = j-m; mm = verify (substr (bcs, k+m, kk-1), " ") - 1; tag = substr (bcs, k+m+mm, kk-1-mm); do bitx = 1 to dft_sr_arg.ntags while (dft_sr_arg.tags (bitx).name ^= tag); end; if bitx > dft_sr_arg.ntags then do; /* New tag */ dft_sr_arg.ntags = bitx; if dft_sr_arg.ntags > hbound (dft_sr_arg.tags, 1) then do; call com_err_ (0, "set_system_search_rules", "Too many tags: ^a in rule ^a", tag, rule); return; end; dft_sr_arg.tags (bitx).name = tag; substr (dft_sr_arg.tags (bitx).flag, bitx, 1) = "1"b; if tag = "default" then default_found = "1"b; end; substr (dft_sr_arg.rules (dft_sr_arg.nrules).flag, bitx, 1) = "1"b; m = m+kk; /* Step over tag and comma */ end; end; else do; /* Bad rule */ call com_err_ (0, "set_system_search_rules", "Illegal rule ^a", rule); return; end; end; end; end; k = k + j; /* Step over line and NL */ end; call hcs_$terminate_noname (segp, ec); /* Done with input */ if ^default_found then do; /* System dont work right without a default */ call com_err_ (0, "set_system_search_rules", "No rules tagged ""default"" found in ^a>^a", dn, en); return; end; call initializer_gate_$set_sr (addr (temp), ec); /* Crunch */ if ec ^= 0 then call com_err_ (ec, "set_system_search_rules", ""); return; /* All done */ dcl ec fixed bin (35); dcl (i, j, k, N, kk, mm, m) fixed bin; dcl segp ptr; dcl bcs char (N) aligned based (segp); dcl rule char (168); dcl tag char (32); dcl ap ptr, al fixed bin, bchr char (al) based (ap); dcl default_found bit (1) init ("0"b); dcl NL char (1) static options (constant) init (" "); dcl WHITE_SPACE char (2) int static options (constant) init (" "); /* tab blank */ dcl bitx fixed bin; dcl bitc fixed bin (24); dcl dn char (168); dcl en char (32); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl com_err_ entry options (variable); dcl initializer_gate_$set_sr entry (ptr, fixed bin (35)); dcl null builtin; dcl 1 temp aligned like dft_sr_arg; %include system_dft_sr; end set_system_search_rules; set_x25_packet_threshold.pl1 12/21/83 0919.0rew 12/21/83 0918.3 19638 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style4,delnl,insnl,^ifthendo */ set_x25_packet_threshold: procedure (); /* highly-privileged command for setting minimum size of X.25 "long packets". A long packet is one that is not output as long as there are short packets queued. */ /* Written July 1983 by Robert Coren */ dcl code fixed bin (35); dcl n_args fixed bin; dcl chan_name char (32); dcl packet_size fixed bin (35); dcl argp pointer; dcl argl fixed bin (21); dcl arg char (argl) based (argp); 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 com_err_ entry () options (variable); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl hphcs_$tty_control entry (char (*), char (*), pointer, fixed bin (35)); dcl CMD_NAME char (24) internal static options (constant) init ("set_x25_packet_threshold"); dcl error_table_$wrong_no_of_args fixed bin (35) external static; dcl addr builtin; %page; call cu_$arg_count (n_args, code); if code ^= 0 then do; call com_err_ (code, CMD_NAME); return; end; if n_args ^= 2 then do; call com_err_ (error_table_$wrong_no_of_args, CMD_NAME, "^/Usage: ^a channel_name packet_size", CMD_NAME); return; end; call cu_$arg_ptr (1, argp, argl, code); chan_name = arg; call cu_$arg_ptr (2, argp, argl, code); packet_size = cv_dec_check_ (arg, code); if code ^= 0 then do; call com_err_ (0, CMD_NAME, "^a is not a valid packet size.", arg); return; end; if packet_size < 2 then do; call com_err_ (0, CMD_NAME, "pakcet threshold must be at least 2."); return; end; call hphcs_$tty_control (chan_name, "set_long_packet_threshold", addr (packet_size), code); if code ^= 0 then call com_err_ (code, CMD_NAME); return; end set_x25_packet_threshold; wire_pages.pl1 11/15/82 1851.4rew 11/15/82 1518.8 51201 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* WIRE_PAGES/UNWIRE_PAGES - Commands to interface to ring-0 segment wiring primitive. Written 770210 by PG for Xerox/CMU Benchmarks. Modified 770407 by PG for installation. */ wire_pages: procedure options (variable); /* automatic */ dcl arg_len fixed bin (21), arg_no fixed bin, arg_ptr ptr, bitcount fixed bin (24), code fixed bin (35), dname char (168), ename char (32), first_page fixed bin (18), my_name char (12), n_pages fixed bin (18), 1 oi aligned like object_info, seg_ptr ptr, text_flag bit (1) aligned, wire_flag bit (1) aligned; /* based */ dcl arg_string char (arg_len) based (arg_ptr); /* builtins */ dcl (addr, divide, null, substr) builtin; /* conditions */ dcl cleanup condition; /* entries */ dcl com_err_ entry options (variable), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hphcs_$user_wire entry (ptr, bit (1) aligned, fixed bin (18), fixed bin (18), fixed bin (35)), object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); /* external static */ dcl (error_table_$badopt fixed bin (35), error_table_$wrong_no_of_args fixed bin (35), sys_info$page_size fixed bin (18)) external static; /* include files */ %include object_info; /* program */ wire_flag = "1"b; /* wire the seg down */ my_name = "wire_pages"; go to join; unwire_pages: entry options (variable); wire_flag = "0"b; /* unwire the seg */ my_name = "unwire_pages"; join: call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code ^= 0 then do; if wire_flag then call com_err_ (code, my_name, "Usage: wire_pages path {first_page n_pages} {-text}"); else call com_err_ (code, my_name, "Usage: unwire_pages path"); return; end; call expand_pathname_ (arg_string, dname, ename, code); if code ^= 0 then do; call com_err_ (code, my_name, "^a", arg_string); return; end; first_page = 0; /* set defaults */ n_pages = -1; /* to cover whole segment */ seg_ptr = null; text_flag = "0"b; /* default is to wire whole seg */ on cleanup call clean_up; arg_no = 2; call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code); if wire_flag & (code = 0) /* any args for wire_pages? */ then do; if substr (arg_string, 1, 1) = "-" then if arg_string = "-text" then text_flag = "1"b; else do; call com_err_ (error_table_$badopt, my_name, "^a", arg_string); return; end; else do; /* User has specified first_page... */ first_page = cv_num_ (arg_string, code); if code ^= 0 then return; arg_no = arg_no + 1; call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (0, my_name, "If first_page is given, n_pages must be given."); return; end; n_pages = cv_num_ (arg_string, code); if code ^= 0 then return; /* message already printed */ end; arg_no = arg_no + 1; call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code); /* see if any more args... */ end; if code = 0 then do; call com_err_ (error_table_$wrong_no_of_args, my_name, ""); return; end; call hcs_$initiate_count (dname, ename, "", bitcount, 0, seg_ptr, code); if seg_ptr = null then do; call com_err_ (code, my_name, "^a>^a", dname, ename); return; end; if text_flag then do; oi.version_number = object_info_version_2; call object_info_$brief (seg_ptr, bitcount, addr (oi), code); if code ^= 0 then do; call com_err_ (code, my_name, "Unable to determine length of text section of ^a>^a", dname, ename); call clean_up; return; end; first_page = 0; n_pages = divide (oi.tlng + sys_info$page_size - 1, sys_info$page_size, 18, 0); end; call hphcs_$user_wire (seg_ptr, wire_flag, first_page, n_pages, code); if code ^= 0 then call com_err_ (code, my_name, "Cannot ^[wire^;unwire^] ^a>^a", wire_flag, dname, ename); call clean_up; return; clean_up: procedure; call hcs_$terminate_noname (seg_ptr, code); end clean_up; cv_num_: procedure (bv_arg_string, bv_code) returns (fixed bin (18)); /* parameters */ dcl (bv_arg_string char (*), bv_code fixed bin (35)) parameter; /* automatic */ dcl num fixed bin (18); /* builtins */ dcl (length, substr) builtin; /* entries */ dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)), cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); /* program */ if substr (bv_arg_string, length (bv_arg_string), 1) = "." then num = cv_dec_check_ (substr (bv_arg_string, 1, length (bv_arg_string) - 1), bv_code); else num = cv_oct_check_ (bv_arg_string, bv_code); if bv_code ^= 0 then call com_err_ (0, my_name, "Non-^[decimal^;octal^] digit in position ^d of ""^a"".", (substr (bv_arg_string, length (bv_arg_string), 1) = "."), bv_code, bv_arg_string); return (num); end cv_num_; end /* wire_pages */; 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