gcos_mme_bort_.pl1 09/09/83 1404.1rew 09/09/83 1007.3 109548 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ******************************************************************************** ******************************************************************************** * * * M M E G E B O R T * * MME GEBORT is used to abort the execution of the current slave activity * by the user. The abort code passed in the Q register is used in messages * displayed on the execution report and at the users terminal. * * This module also processes requests from the GES system to abort the * slave activity. These requests are handled by .mbrt1,3 in real GCOS. * This entry (gcos_mme_bort_$system) is called passing some system defined * error code (from gcos_et_). The short message associated with this error * code is the GCOS system abort number which is to be placed in the * slave prefix. * * After the processing of the appropriate abort request, gcos_mme_bort_ will * fill in the proper words in the slave prefix and return to gcos_run_activity_ * by way of a non-local goto through gcos_ext_stat_$mme_rtrn. * * CALLING SEQUENCE: * * MME GEBORT * * C(Q) 24-35 BCD abort code * * * WRITTEN BY DICK SNYDER, 1971. * MODIFIED BY T. CASEY - DECEMBER 1973, MARCH 1974, AUGUST 1974. * Modified by M. R. Jordan, January 1977, August 1977 * Modified by S. C. Akers, December 1981. Change \014 to %page; * Fix bug to stuff abort reason * and address of faulting instruction * in Word 13 (octal) of slave prefix. * ******************************************************************************** ******************************************************************************** */ %page; gcos_mme_bort_: procedure (mcp, increment); /* The data item gcos_ext_stat_$termination_code is of special importance in that it tells the user what type of abort (system or user) and exactly which abort he got. This information is typicaly used in a wrapup routine to make decisions. The data item is declared as a bit(18). The following assignments are made within it: 0-3 MBZ 4-5 =1 system abort; =2 user abort 6-17 system abort number or user abort code (BCD) */ %page; /* This entry will be called as a result of a MME GEBORT in a slave activity. After extracting the abort code from the Q register, a message will be printed at the users terminal and wrapup will be looked into. */ substr (abort_code, 1, 1) = xlate (fixed (substr (mc.regs.q, 25, 6), 7)); substr (abort_code, 2, 1) = xlate (fixed (substr (mc.regs.q, 31, 6), 6)); /* Set the termination code to reflect the specified abort code and the fact that this is a GEBORT rather than a fault. */ substr (gcos_ext_stat_$termination_code, 1, 6) = "000010"b; substr (gcos_ext_stat_$termination_code, 7, 12) = substr (mc.regs.q, 25, 12); /* Now print a message at the users terminal and continue. */ gcos_ext_stat_$abort_reason = "Users " || abort_code || " MME GEBORT."; call ioa_$ioa_stream ("error_output", "^a", gcos_ext_stat_$abort_reason); goto continue_termination; %page; /* The following entry provides for system termination of the slave activity due to a system detected error. This entry expects a code from the gcos_et_ (or any valid error table code) as its first argument. The remaining arguments are passed to ioa_ for printing. */ %page; system: entry (abort_ecode); ecode = abort_ecode; system_error: ; /* Prepare the termination code value from the information given in the gcos error table (gcos_et_). */ call get_abort_info (); substr (gcos_ext_stat_$termination_code, 1, 6) = "000001"b; substr (gcos_ext_stat_$termination_code, 7, 12) = substr (addr (abort_number) -> bit36, 25, 12); /* Now prepare the message for the user to tell him what went wrong. The message consists of the long message from the gcos_et_ and an additional message formatted from the remaining arguments passed to gcos_mme_bort_$system. */ call ioa_$ioa_stream ("error_output", "^a", long_message); call cu_$arg_count (nargs); if nargs > 1 then do; call cu_$arg_list_ptr (arg_list_ptr); call ioa_$general_rs (arg_list_ptr, 2, 3, rtn_string, rtn_string_len, "0"b, "0"b); if rtn_string_len > 0 then if substr (rtn_string, 1, rtn_string_len) ^= "" then call ioa_$ioa_stream ("error_output", "^a", substr (rtn_string, 1, rtn_string_len)); end; /* Now pass the abort message on to gcos_run_activity_ by continuing. */ gcos_ext_stat_$abort_reason = rtrim (long_message); goto continue_termination; %page; abort_number: entry (abort_ecode, return_code); ecode = abort_ecode; call get_abort_info (); return_code = abort_number; return; %page; continue_termination:; /* Set up pointers needed later. */ scup = addr (gcos_ext_stat_$mc.scu); /* Initialize the proper locations in the slave prefix. Some of the values to be set are offset by 1 if the most recent termination occured during wrapup. */ slave_prefix_ptr = gcos_ext_stat_$gcos_slave_area_seg; slave_prefix.word_30 = (36)"0"b; slave_prefix.words_60_thru_65 = (216)"0"b; if gcos_ext_stat_$save_data.wrapup then slave_prefix_ptr = addrel (slave_prefix_ptr, 1); slave_prefix.termination_info = gcos_ext_stat_$termination_code; slave_prefix.ic_and_i = addr (scu.ilc) -> bit36; slave_prefix.ic_value = scu.ilc; /* Now if the user has specified the -debug control argument, do it. */ if gcos_ext_stat_$save_data.debug then do; call ioa_$ioa_stream ("error_output", "CALLING DEBUG:"); call db; end; /* Prepare to return to gcos_run_activity by setting the activity abort flag and the "run only compilations till next $ BREAK" flag. Bit 5 of the program switch word gets reset and the abort code is passed back to gcos_run_activity. */ gcos_ext_stat_$save_data.this_act_abort = "1"b; gcos_ext_stat_$save_data.prev_act_abort = "1"b; substr (save_data.psw, 6, 1) = "0"b; goto gcos_ext_stat_$mme_rtrn; %page; /* This entry is called to inform the user of a bad MME number in his program. This is an i1 system abort. */ not_imp: entry (mcp, increment, mme_number); if mme_number = 0 then call gcos_mme_bort_$system (gcos_et_$unimp_mme, "0 is not a valid MME number."); else call gcos_mme_bort_$system (gcos_et_$unimp_mme, "GE^a", MME_NAME (mme_number)); %page; /* This entry process run-time "system" detected fatal errors. The calling sequence is essentially options(variable), but the first argument must be a char(2) for the abort code. Other arguments that follow are passed to ioa_ to be printed. */ simulator: entry (code); abort_code = code; call cu_$stack_frame_ptr (p); p = backp; /* get caller's frame */ unspec (offset) = (18)"0"b||substr (rel (ret), 1, 18); call pl1_frame_$name (p, z, j); /* get caller name */ call ioa_ ("Abort ^a from ^a at ^o ", code, name, offset); call cu_$arg_list_ptr (p); /* get ptr to my arg list */ ii, i = arg_count; /* get no of args */ if i = 2 then goto continue_termination; /* only one arg */ ii, i = i-2; /* decrement arg count */ arg_count = i; /* put new count in arg list */ i = descriptor_count; /* get no. of descriptors */ if i ^= 0 then do; /* adjust descriptors and count if necessary */ descriptor_count = fixed (i-2, 18); do j = divide (ii+4, 2, 18, 0) to ii+2; /* shift descriptors left one to */ /* wipe out descriptor for arg 1 (abort cause) */ arg_pointers (j) = arg_pointers (j+1); end; end; else ii = divide (ii, 2, 18, 0); /* no descriptors so adjust move variable */ do j = 1 to ii; arg_pointers (j) = arg_pointers (j+1); /* move arg pointers */ end; call cu_$gen_call (ioa_, p); /* let ioa_ print out any other info */ gcos_ext_stat_$termination_code = "000001000000000000"b; gcos_ext_stat_$abort_reason = abort_code; goto continue_termination; dcl 1 arg_list aligned based (p), 2 arg_count fixed bin(17) unaligned, 2 display bit (18) unaligned, 2 descriptor_count fixed bin(17) unaligned, 2 fill bit (18) unaligned, 2 arg_pointers (1) fixed bin(71); dcl code char (*); dcl cu_$gen_call ext entry (entry, pointer); dcl cu_$stack_frame_ptr ext entry (pointer); dcl divide builtin; dcl 1 frame based (p), 2 ab (4) fixed bin(24), 2 lp pointer, 2 sp pointer, 2 regs (8) fixed bin(24), 2 backp pointer, 2 nxt pointer, 2 ret pointer; dcl i fixed bin(24); dcl ii fixed bin(24); dcl j fixed bin(24); dcl name char (j) aligned based (z); dcl offset fixed bin(24); dcl p pointer; dcl pl1_frame_$name ext entry (ptr, ptr, fixed bin(24)); dcl rel builtin; dcl unspec builtin; dcl z pointer; %page; get_abort_info: procedure (); /* This internal procedure obtains the short_message, long_message, and abort_number given the ecode value passed to the gcos_mme_bort_ entry point that has been called. To begin with, using the convert_status_code_ subroutine get the message for this code value. */ call convert_status_code_ (ecode, short_message, long_message); /* Prepare the abort number from the ecode value. */ if substr (short_message, 1, 4) = "GCOS" then do ; abort_number = cv_dec_check_ (substr (short_message, 5, 4), ecode); if ecode ^= 0 then abort_number = 0; end; else abort_number = 0; return; end get_abort_info; %page; dcl abort_code char (2); /* the ASCII abort code */ dcl abort_ecode fixed bin(35); /* error code value for system aborts */ dcl abort_number fixed bin(24); /* GCOS system abort number */ dcl null builtin; dcl addr builtin; dcl addrel builtin; dcl arg_list_ptr ptr; /* ptr to the system entry points arg list */ dcl bit36 bit (36) based; /* a based word for bit manipulation */ dcl convert_status_code_ entry (fixed bin(35), char (8) aligned, char (100) aligned); dcl cu_$arg_count entry (fixed bin(24)); dcl cu_$arg_list_ptr entry (ptr); dcl cv_dec_check_ entry (char (*), fixed bin(35)) returns (fixed bin(35)); dcl db ext entry; dcl ecode fixed bin(35); /* local error code value */ dcl fixed builtin; dcl gcos_et_$unimp_mme fixed bin(35) ext; dcl gcos_mme_bort_$system entry options (variable); dcl increment fixed bin(24); /* number of arg words to this MME */ dcl ioa_ ext entry options (variable); dcl ioa_$ioa_stream entry options (variable); dcl ioa_$general_rs entry (ptr, fixed bin(24), fixed bin(24), char (*), fixed bin(24), bit (1), bit (1)); dcl long_message char (100) aligned; /* long message for ecode */ dcl mme_number fixed bin(24); /* the MME number for non-implemented MMEs */ dcl nargs fixed bin(24); dcl return_code fixed bin(24); /* returned abort number for return_abort_number entry */ dcl rtn_string char (256); /* output string for ioa_$general_rs */ dcl rtn_string_len fixed bin(24); /* output string length from ioa_$general_rs */ dcl rtrim builtin; dcl short_message char (8) aligned; /* short message for ecode */ dcl 1 slave_prefix aligned based (slave_prefix_ptr), 2 filler_1 (11) bit (36), 2 ic_value bit (18) unal, 2 termination_info bit (18) unal, 2 filler_2 (6) bit (36), 2 ic_and_i bit (36), 2 filler_3 (5) bit (36), 2 word_30 bit (36), 2 filler_4 (23) bit (36), 2 words_60_thru_65 bit (216); dcl slave_prefix_ptr ptr; /* ptr to slave jobs prefix */ dcl substr builtin; %page; %include gcos_ext_stat_; %page; %include gcos_mme_names; %page; %include gcos_xlate_bcd_ascii_; %page; %include query_info; end gcos_mme_bort_;  gcos_mme_call_.pl1 09/09/83 1404.1rew 09/09/83 1007.3 221130 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_mme_call_: proc (mcp, increment); /* * MME GECALL is used to load programs into memory. The programs may be either relocatable * or absolute. Note, if dynamic library ** present, it is searched first. * * MME GERSTR restores data saved by MME GESAVE. The data is read from the file * whose filecode is in the q reqister. The calling sequence is the same as that * shown for MME GECALL. * * CALLING SEQUENCE: * * MME GECALL * BCI 1,XXXXXX BCD PROGRAM NAME * ZERO L(FIRST WORD),L(ERR RTRN) PLACE TO BEGIN LOADING * ZERO L(TRANSFER),0 PLACE TO XFER CONTROL TO * (IF 0, GO TO PLACE SPECIFIED * IN THE PROGRAM'S DIRECTORY) * * RETURNS: * * C(A) 0-17 LOADING ORIGIN * C(A) 18-35 NUMBER OF WORDS LOADED * C(Q) 0-17 TRANSFER ADDRESS IN PGM DIR. * * On error returns the C(Q) 18-35 contains the error code. * * _c_o_d_e _r_e_a_s_o_n * * 30 i3-file code not defined * 42 m4/n4-i/o lim. call/save * 43 m6/n7-i/o err. call/save * 46 non-random gecall file * 48 m6-call/rstr checksum * 51 m2/m3-call name missing * Author: DICK SNYDER OCTOBER 26, 1970 Change: T. CASEY OCTOBER 1973, FEBRUARY 1974, AUGUST 1974 Change: D. KAYDEN APRIL 1974, JULY 1974, APRIL 1975 Change: M. R. Jordan, September 1977 Change: Dave Ward 05/29/81 made FB precision adequate. */ scup = addr (mc.scu); /* init pointer to scu data */ i = instruction_counter+1; /* get parameter loc'n */ callp = addrel (gcos_ext_stat_$gcos_slave_area_seg, i); /* build ptr to parameters */ /* see if the dynamic library ** exists. if it does, search */ /* it first before the regular library. */ do i = 1 to hbound (save_data.fibs, 1); if fct.filecode (i) = "**" then if ^fct.sysout (i) then do; dylibsw = "1"b; /* remember that we are searching dynamic lib */ fc_join: ; fibptr = fct.fibptr (i); /* come here from mme_rstr entry point */ fib.iocount = fib.iocount + 1; if ^fib.type then do; if gecall.error_return_loc ^= (18)"0"b then call Error (gcos_et_$non_rndm_call_file); else call gcos_mme_bort_$system (gcos_et_$non_rndm_call_file); end; load_at = fib.stream; /* get stream to load from */ goto search_lib; end; end; srch_gs: ; /* come here after searching ** file, if one was there */ dylibsw = "0"b; /* searching regular lib now */ load_at = "glib"; /* search standard system library */ search_lib: if first_lib then do; /* initialize if not done previously */ first_lib = "0"b; statp = addr (st); /* init pointer to ios status */ scup = addr (mc.scu); /* init pointer to scu data */ i = instruction_counter+1; /* get parameter loc'n */ callp = addrel (gcos_ext_stat_$gcos_slave_area_seg, i); /* build ptr to parameters */ if dbs_mme_call then do; /* print gecall name if trace is on */ call gcos_cv_gebcd_ascii_ ( addr (gecall.prog_name) , 6 , addr (ascii_gecall_name) ); /* translate call name to ascii */ call ioa_ ("mme gecall ^a", ascii_gecall_name); end; end; seek_save, k = 0; /* init file offsets */ %page; /* Read catalog record and search for program to be loaded */ /* **************N O T E********************************************************* * * The catalog for the simulator library, gcos_system_software_, is not * the same as the catalog for a random system loadable file produced by * SYSEDIT, and commonly used as a dynamic library (** file). * This routine presently handles both types. Note that it would be * inefficient for the simulator to utilize a sector oriented catalog * for its primary software library. In fact, after GCOS is booted, it * does not use the catalogs contained in its primary software libraries. * It uses one linear directory that it has built from the disjoint disk * catalogs of its primary libraries. The catalog formats of the GCOS * and the GCOS simulator primary libraries should be of no concern * to users of either system. * * See the GCOS PLM (AN77) for a detailed description of the differences * in format between a random system loadable file (a dynamic library), the * simulator library, and a tape system loadable file (from which the * simulator library is produced). * **************N O T E******************************************************* */ prefp = addr (buffer); /* init buffer pointer */ call ios_$seek (load_at, "read", "first", 0, st); /* seek to start of file */ if status.code ^= 0 then do; /* error ? */ message = "from ios_$seek to start of file"; io_abort: ; if status.code ^= 0 then call check_fs_errcode_ (status.code, "xxxxxxxx", longerror); /* get error message */ call gcos_cv_gebcd_ascii_ (addr (gecall.prog_name), 6, addr (ascii_gecall_name)); /* get call name in ascii */ if gecall.error_return_loc ^= (18)"0"b then call Error (gcos_et_$io_err_call_save); else call gcos_mme_bort_$system (gcos_et_$io_err_call_save, "on ^a; looking for ^a^/^a^/^a", load_at, ascii_gecall_name, longerror, message); end; read: ; call ios_$read (load_at, prefp, 0, 1000, j, st); /* read catalog */ if status.code ^= 0 then do; message = "from ios_$read first catalog block"; goto io_abort; /* error ? */ end; if gcatblk.avail_ptr ^= 1 then go to sim_cat; /* determine catalog type */ gcatsw = "1"b; /* GCOS standard catalog type */ gcat_loop: ; do i = 1 to 15; /* search entries on this block */ if gcatblk.element (i) = gecall.prog_name then do; seek_save = gcatblk.address (i)*64; go to readp; end; end; /* not found - is there another block ? */ if gcatblk.next_cat = 0 then go to next_lib; /* if not, search next library */ call ios_$seek (load_at, "read", "first", gcatblk.next_cat*64, st); if status.code ^= 0 then do; message = "from ios_$seek to next random catalog block"; goto io_abort; end; call ios_$read (load_at, prefp, 0, 64, j, st); /* read in next catalog block */ if status.code ^= 0 then do; message = "from ios_$read random catalog block"; goto io_abort; end; go to gcat_loop; /* now go scan it */ sim_cat: ; gcatsw = "0"b; do i = 1 to catblk.no_ent; /* loop for no. of entries in cat */ if catblk.element (i) = gecall.prog_name then do; /* hit ? */ seek_save = catblk.address (i); go to readp; end; end; next_lib: ; if rstr_switch then goto not_found; /* search only one file for mme gerstr */ if dylibsw then go to srch_gs; /* no hit on dynamic lib, try regular */ if ^seclibsw then do; /* but only if we have not searched it yet */ seclibsw = "1"b; /* remember that we have */ if gcos_ext_stat_$save_data.userlib then do; /* -userlib arg enables use of this feature */ load_at = "slib"; /* search secondary library */ go to search_lib; end; end; not_found: ; call gcos_cv_gebcd_ascii_ (addr (gecall.prog_name), 6, addr (ascii_gecall_name)); /* convert call name to ascii */ if gecall.error_return_loc ^= (18)"0"b then call Error (gcos_et_$call_name_missing); else call gcos_mme_bort_$system (gcos_et_$call_name_missing, """^a""", ascii_gecall_name); %page; /* Come here when entry found. Seek to and read preface record */ readp: ; call ios_$seek (load_at, "read", "first", seek_save, st); /* seek */ if status.code ^= 0 then do; message = "from ios_$seek to preface record"; goto io_abort; /* abort if error */ end; call ios_$read (load_at, prefp, 0, 64, j, st); /* read preface rcrd */ if status.code ^= 0 then do; message = "from ios_$read preface record"; goto io_abort; /* abort if error */ end; /* compute no of dcws in preface */ first_loc = gcos_ext_stat_$storage_limit; last_loc = -1; do ndcw = 1 to 58 while (substr (preface.dcws (ndcw), 22, 3) ^= "000"b); dcwp = addr (preface.dcws (ndcw)); first_loc = min (first_loc, fixed (dcw_model.data_addr, 18)); last_loc = max (last_loc, fixed (dcw_model.data_addr, 18)+fixed (dcw_model.count, 12)-1); end; dcwp = addr (preface.dcws (ndcw)); first_loc = min (first_loc, fixed (dcw_model.data_addr, 18)); last_loc = max (last_loc, fixed (dcw_model.data_addr, 18)+fixed (dcw_model.count, 12)-1); pgm_text_length = last_loc-first_loc+1; reloc_len = fixed (preface.reloc_words); /* save no. of relocation words */ load_origin = fixed (preface.origin); /* save origin */ pgm_length = fixed (preface.data_words); /* save pgm length */ if gcatsw then do; reloc_len = reloc_len*64; /* for a GCOS catalog, convert blocks to words */ pgm_length = pgm_length*64; seek_save = seek_save + 64; /* and program starts in next block */ end; else seek_save = seek_save+6+ndcw; /* for a simulator catalog, program immediately follows */ transfer_addr = fixed (preface.entry); /* save entry point */ load_increment = 0; /* init load increment */ if gecall.origin ^= (18)"0"b then do; /* did slave specify an origin ? */ if load_origin > 131072 then /* relocatable overlay ? */ load_increment = fixed (gecall.origin); else load_increment = fixed (gecall.origin)-load_origin; /* set up new load increment */ load_origin = fixed (gecall.origin); /* use user specified origin */ transfer_addr = transfer_addr+load_increment; /* new transfer address */ end; /* In the following test, load_origin + pgm_text_length > storage_limit is the same as load_origin + pgm_text_length -1 >= storage_limit. A storage_limit of nnnK means that the program can legitimately address 0 to nnnK-1. */ if load_origin + pgm_text_length > gcos_ext_stat_$storage_limit then do; /* will pgm_text fit ? */ if gecall.error_return_loc ^= (18)"0"b then call Error (gcos_et_$io_lim_call_save); else call gcos_mme_bort_$system (gcos_et_$io_lim_call_save); end; mc.regs.q = substr (unspec (transfer_addr), 19, 18)||substr (mc.regs.q, 19, 18); /* Use user specified transfer address if present */ if gecall.xfer_addr ^= (18)"0"b then transfer_addr = fixed (gecall.xfer_addr); call ios_$seek (load_at, "read", "first", seek_save, st); /* seek to read data record */ if status.code ^= 0 | status.eof then do; if status.code = 0 then longerror = "end of file"; message = "from ios_$seek to first dat block"; goto io_abort; end; %page; first_loc = first_loc-1024+load_increment; /* Loop to read data records into gcos segment */ xfer_total = 0; /* clear xfer total */ do i = 1 to ndcw; /* loop to process dcws */ dcwp = addr (preface.dcws (i)); /* get pointer to a dcw */ j = fixed (dcw_model.count); /* grab xfer count */ if j = 0 then j = 4096; /* count of 0 = 4096 */ xfer_total = xfer_total + j; /* total up words to xfer */ end; call ios_$read (load_at, gcos_ext_stat_$gcos_slave_area_seg, (first_loc), xfer_total, k, st); /* read data record */ if status.code ^= 0 | xfer_total ^= k then do; if status.code = 0 then longerror = "data words read ^= total of dcw counts"; message = "from ios_$read data blocks"; goto io_abort; /* error ? */ end; /* Calculate checksum and compare with that in preface block */ if preface.data_check ^= 0 then do; /* don't do if checksum = 0 */ ptr = addrel (gcos_ext_stat_$gcos_slave_area_seg, first_loc); /* get ptr to first loc loaded */ accum = 0; /* clear accumulator */ do i = 1 to xfer_total; accum = accum + fixed (checker (i)); /* add a word */ if accum > 68719476735 then do; /* carry into second word ? */ accum = accum - 68719476736 + 1; /* add carry to low end of no. */ end; end; if substr (unspec (accum), 37, 36) ^= unspec (preface.data_check) then do; /* error */ if gecall.error_return_loc ^= (18)"0"b then call Error (gcos_et_$call_rstr_cksm); else call gcos_mme_bort_$system (gcos_et_$call_rstr_cksm); end; end; %page; /* If this is an absolute program, go turn control back to the user */ if reloc_len = 0 then go to start_pgm; if load_increment = 0 then go to start_pgm; /* no relocation to do */ /* Must change load increment before relocating program. The load increment */ /* is usually off by 102 octal in the preface record. Actually, the */ /* preface record is off by 400102 but the extra 400000 is really just a */ /* flag to indicate that the program is relocatable. */ /* The 102 octal consists of the slave area prefix, which is 100 octal words long, followed by two words immediately after it, reserved by the loader for communication between overlay modules. Thus it represents the difference between giving the load increment relative to the beginning of the program and giving it relative to the beginning of the slave area. */ if fixed (preface.origin) > 131072 then load_increment = load_increment+131072-fixed (preface.origin); /* fix load increment */ if gcatsw then do; /* for a GCOS catalog, move to beginning of next block */ call ios_$seek (load_at, "read", "first", seek_save+pgm_length, st); if status.code ^= 0 then do; message = "from ios_$seek to first random relocation block"; goto io_abort; end; end; rd_rel: ; call ios_$read (load_at, prefp, 0, 1000, j, st); /* read reloc record */ if status.code ^= 0 then do; message = "from ios_$read relocation block"; goto io_abort; end; size = min (reloc_len, 1000); /* can only relocate 18000 words per read */ reloc_len = reloc_len-1000; size = min (size*36, pgm_text_length*2); do i = 1 to size; if reloc_bits (i) then do; /* reloc bit on? */ fb18 = fixed (gcos_reloc.half_wd (i)); /* pull the half word */ fb18 = fb18 + load_increment; /* increment it */ gcos_reloc.half_wd (i) = bit (fb18); /* put it back */ end; end; if reloc_len > 0 then go to rd_rel; /* more relocation bits ? */ %page; /* Come here when relocation finished */ start_pgm: ; /* return load origin and pgm length in A */ call Apply_Patches (); mc.regs.a = substr (unspec (load_origin), 19, 18)||substr (unspec (pgm_text_length), 19, 18); /* Set "increment" to force xfer to location specified in transfer address */ /* when control is returned to the user. */ increment = transfer_addr - instruction_counter - 1; /* compute offset from current instruction */ exit_gecall: return; /* go start program */ %page; mme_rstr: entry (mcp, increment); rstr_switch = "1"b; /* remember we entered here */ scup = addr (mc.scu); /* init pointer to scu data */ callp = addrel (gcos_ext_stat_$gcos_slave_area_seg, instruction_counter+1); /* build ptr to parameters */ call gcos_cv_gebcd_ascii_ (addr (mc.regs.q), 6, addr (fc)); /* get file code in ascii */ do i = 1 to hbound (save_data.fibs, 1); /* look for file code */ if fct.filecode (i) = substr (fc, 5, 2) then if ^fct.sysout (i) then do; goto fc_join; end; end; /* if gecall.error_return_loc ^= (18)"0"b then call Error (gcos_et_$fc_not_defined); else call gcos_mme_bort_$system (gcos_et_$fc_not_defined, """^a""", substr (fc, 5, 2)); */ call gcos_mme_bort_$system (gcos_et_$fc_not_defined, """^a""", substr (fc, 5, 2)); %page; Apply_Patches: proc (); if gcos_ext_stat_$patchfile_ptr = null () then return; module_name = gecall.prog_name; call Get_Module_Name_Index (); if module_name_index ^= 0 then do; patch_ptr = ptr (gcos_ext_stat_$patchfile_ptr, patch_file.module (module_name_index).first_patch_offset); number_of_patches = patch_file.module (module_name_index).number_of_patches; do i = 1 to number_of_patches; if patch (i).location > gcos_ext_stat_$storage_limit then do; end; word_ptr = ptr (gcos_ext_stat_$gcos_slave_area_seg, patch (i).location); if dbs_mme_call then call ioa_ ( "before ^w; after ^w^[^-NO CHANGE^]" , word , patch (i).content , (word = patch (i).content) ); word = patch (i).content; end; end; else if dbs_mme_call then call ioa_ ("no patches"); return; Get_Module_Name_Index: proc (); dcl divide builtin; dcl floor builtin; dcl l fixed bin(24); dcl u fixed bin(24); l = 1; u = patch_file.number_of_names; do while (u >= l); module_name_index = floor (divide ((l+u), 2, 17)); if module_name < patch_file.module (module_name_index).name then u = module_name_index-1; else if module_name > patch_file.module (module_name_index).name then l = module_name_index+1; else return; end; module_name_index = 0; return; end Get_Module_Name_Index; dcl i fixed bin(24); dcl module_name bit (36); dcl module_name_index fixed bin(24); dcl null builtin; dcl number_of_patches fixed bin(24); dcl patch_ptr ptr; dcl ptr builtin; dcl word fixed bin(35) based (word_ptr); dcl word_ptr ptr; dcl 1 patch (number_of_patches) aligned based (patch_ptr), 2 location fixed bin(17), 2 content fixed bin(35); dcl 1 patch_file aligned based (gcos_ext_stat_$patchfile_ptr), 2 version fixed bin(24), 2 number_of_names fixed bin(24), 2 module (130560), 3 name bit (36), 3 first_patch_offset bit (18) unal, 3 number_of_patches fixed bin(17) unal; end Apply_Patches; %page; Error: proc (code); call gcos_mme_bort_$abort_number (code, abort_number); mc.regs.q = unspec (abort_number); return_loc = fixed (gecall.error_return_loc, 18, 0); gecall.error_return_loc = (18)"0"b; increment = return_loc-instruction_counter-1; goto exit_gecall; dcl abort_number fixed bin(35); dcl code fixed bin(35); dcl return_loc fixed bin(18); end Error; %page; /* Variables for gcos_mme_call_: */ /* IDENTIFIER ATTRIBUTES */ dcl accum fixed bin(71) /* checksum accumulator */; dcl addr builtin; dcl addrel builtin; dcl ascii_gecall_name char (6) /* for printing in trace or error messages */; dcl bit builtin; dcl buffer bit (36000) /* preface and relocation blk buffer */; dcl callp pointer; dcl checker (pgm_length) bit (36) aligned based (ptr) /* overlay for computing chksum */; dcl check_fs_errcode_ ext entry (fixed bin(24), char (8), char (100)); dcl dcwp pointer; dcl dylibsw bit (1) aligned init ("0"b) /* on if searching dynamic library (**) */; dcl fb18 fixed bin(18) /* need full 18 bits for address arithmetic */; dcl fc char (6); dcl first_lib bit (1) aligned init ("1"b) /* on until initialzation done */; dcl first_loc fixed bin(18); dcl fixed builtin; dcl gcatsw bit (1) /* 0=simulator catalog, 1=gcos format catalog */; dcl gcos_cv_gebcd_ascii_ ext entry (pointer, fixed bin(24), pointer); dcl gcos_et_$call_name_missing fixed bin(35) ext; dcl gcos_et_$call_rstr_cksm fixed bin(35) ext; dcl gcos_et_$fc_not_defined fixed bin(35) ext; dcl gcos_et_$io_err_call_save fixed bin(35) ext; dcl gcos_et_$io_lim_call_save fixed bin(35) ext; dcl gcos_et_$non_rndm_call_file fixed bin(35) ext; dcl gcos_mme_bort_$abort_number entry (fixed bin(35), fixed bin(35)); dcl gcos_mme_bort_$system entry options (variable); dcl i fixed bin(24); dcl increment fixed bin(24) /* number of parameter words to skip */; dcl instruction_counter fixed bin(18)unsigned unal based(addr(scu.ilc)); dcl ioa_ ext entry options (variable); dcl ios_$read ext entry (char (*) aligned, pointer, fixed bin(24), fixed bin(24), fixed bin(24), bit (72) aligned); dcl ios_$seek ext entry (char (*) aligned, char (*), char (*), fixed bin(24), bit (72) aligned); dcl j fixed bin(24); dcl k fixed bin(24); dcl last_loc fixed bin(18); dcl load_at char (8) aligned /* holds attach name of file to load from */; dcl load_increment fixed bin(24); dcl load_origin fixed bin(24); dcl longerror char (100); dcl max builtin; dcl message char (60); dcl min builtin; dcl ndcw fixed bin(24); dcl pgm_length fixed bin(24); dcl pgm_text_length fixed bin(18); dcl prefp pointer; dcl ptr pointer; dcl reloc_bits (36000) bit(1)unaligned based (prefp) /* overlay for relocation record */; dcl reloc_len fixed bin(24); dcl rstr_switch bit (1) aligned init ("0"b) /* on if entered at mme_rstr */; dcl seclibsw bit (1) aligned init ("0"b) /* on if searching secondary library */; dcl seek_save fixed bin(24) /* holds seek offset */; dcl size fixed bin(24) /* size of pgm overlay arrays */; dcl st bit (72) aligned /* ios status */; dcl state char (4); dcl statp pointer; dcl substr builtin; dcl transfer_addr fixed bin(24); dcl unspec builtin; dcl xfer_total fixed bin(24) /* used to hold total no. words to xfer */; dcl 1 status aligned based (statp), /* overlay for ios_ status */ 2 code fixed bin(24), /* standard error code */ 2 fill bit (9) unaligned, 2 eof bit (1) unaligned /* eof bit */ ; dcl 1 gecall aligned based (callp), /* overlay for gecall parameters */ 2 prog_name bit (36) unaligned, /* bcd pgm name */ 2 origin bit (18) unaligned, /* place to begin loading */ 2 error_return_loc bit (18) unaligned, 2 xfer_addr bit (18) unaligned /* transfer address */ ; dcl 1 preface aligned based (prefp), /* model of preface record - 64 words max */ 2 data_check fixed bin(24), /* checksum of following data words */ 2 rel_check fixed bin(24), /* checksum of following reloc. words */ 2 rel_abs fixed bin(24), /* 0=absolute|^0=relocatable */ 2 name bit (36) unaligned, /* name of pgm */ 2 entry bit (18) unaligned, /* entry address */ 2 origin bit (18) unaligned, /* origin */ 2 reloc_words bit (18) unaligned, /* no. of relocation words */ 2 data_words bit (18) unaligned, /* no. of data words */ 2 dcws (ndcw) bit (36) unaligned /* dcw(s) - max of 58 - to load following data records */ ; dcl 1 dcw_model aligned based (dcwp), /* model of dcw */ 2 data_addr bit (18) unaligned, 2 zero bit (3) unaligned, 2 action bit (3) unaligned, 2 count bit (12) unaligned /* number of words to xfer */ ; dcl 1 gcos_reloc aligned based (ptr), /* overlay for each half word */ 2 half_wd (131072) bit (18) unaligned; /* of the loaded program */ dcl 1 catblk aligned based (prefp), /* catalog image */ 2 nxt fixed bin(24), /* pointer to next cat blk */ 2 no_ent fixed bin(24), /* no. of entries in this cat blk */ 2 elblock (499), /* room for 499 entries */ 3 element bit (36) unaligned, /* prog name */ 3 address fixed bin(24) /* offset in file of preface rcrd */ ; dcl 1 gcatblk aligned based (prefp), /* catalog image for gcos format catalog */ 2 avail_ptr fixed bin(18)unsigned unaligned, 2 next_cat fixed bin(18)unsigned unaligned, 2 pad bit (36), 2 elblock (15), 3 element bit (36), 3 length fixed bin(18)unsigned unaligned, 3 address fixed bin(18)unsigned unaligned, 3 pad bit (72); %page; %include gcos_ext_stat_; %page; %include gcos_dbs_names; end gcos_mme_call_;  gcos_mme_chek_.pl1 09/09/83 1404.1rew 09/09/83 1007.3 21960 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ******************************************************************************************** ******************************************************************************************** * * * M M E G E C H E K * * * MME GECHEK initiates a checkpoint dump and sets up bookkeeping to enable * the program requesting the MME GECHEK to be later rolled back (via MME GEROLL) * to the last checkpoint taken. * * * CALLING SEQUENCE * * MME GECHEK * return * * * C(word 14) 0-17 location of rollback special processing routine * * * For programs using File and Record Control: * * C(Q) 0-17 checkpoint FCB location * C(Q) 18-35 MBZ * * * or for programs not using File and Record Control: * * C(Q) 0-5 MBZ * C(Q) 6-17 file code of the checkpoint file * C(Q) 18 MBZ * C(Q) 19 =1 * C(Q) 20-35 MBZ * * * on return from the MME: * * C(Q) 0-17 location+1 of the last MME GECHEK * C(Q) 18-35 error code (always zero) * * * Modified by M. R. Jordan, April 1977 * ******************************************************************************************** ******************************************************************************************** */ gcos_mme_chek_: proc (mcp, increment); dcl addr builtin; dcl bit36 bit (36) aligned based; dcl fixed builtin; dcl increment fixed bin(18); dcl return_loc fixed bin(18); dcl substr builtin; /* This MME is not supported. Simply return to the slave job as if we had taken the checkpoint. */ /* Initialize the increment and scu data pointer. Then set up the Q register to look like we just did the GECHEK and return. */ increment = 1; scup = addr (mc.scu); return_loc = fixed (scu.ilc, 18)+1; mc.q = substr (addr (return_loc) -> bit36, 19, 18) || (18)"0"b; return; %include mc; end gcos_mme_chek_;  gcos_mme_fadd_.pl1 09/09/83 1404.1rew 09/09/83 1007.3 30528 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_mme_fadd_: proc (mcpp, increment); /* MME GEFADD is used to obtain physical addresses for use in operator messages. Since physical addresses are meaningless in this environment, a random bit pattern is returned in the A and Q registers. This mme is also used to find out if a file exists, so it is important to return nonzero values when the file does exist. Author: DICK SNYDER FEBRUARY 21,1972 Change: T. CASEY NOVEMBER 1973 Change: D. KAYDEN APRIL 1974, DECEMBER 1974 Change: R.H. MORRISON JAN. 29, 1976 Change: Dave Ward 09/02/81 density history 2 bits (not 3). Tape density 6250. Revised source. */ dcl increment fixed bin(24)parm; dcl mcpp ptr parm; mcp = mcpp; increment = 0; substr (fc, 1, 1) = xlate (q_ovl.fc_bcd1); /* put ascii equivalent in fc */ substr (fc, 2, 1) = xlate (q_ovl.fc_bcd2); if fc = " " then go to not_found; do i = 1 to hbound (save_data.fibs, 1); /* see if file named fc exists */ if fct.filecode (i) = fc then go to found; end; not_found: ; mc.regs.a, mc.regs.q = "0"b; /* not found, return zeroes */ return; found: ; if fct.sysout (i) then go to not_found; fibptr = fct.fibptr (i); mc.regs.a = "0"b; substr (mc.regs.a, 7, 3) = fib.disp; /* put in disposition code */ if fib.print then substr (mc.regs.a, 1, 6) = "25"b3 ; /* device code = 25 (prt300 */ else if fib.tape then do; if fib.tracks = "01"b then substr (mc.regs.a, 1, 6) = "13"b3 ; /* dev. code = 13 (mth500 - 7 trk) */ else substr (mc.regs.a, 1, 6) = "14"b3 ; /* dev. code = 14 (mth500 - 9 trk) */ substr (mc.regs.a, 10, 19) = "0100000000001000010"b; /* set density capability (200, 556, 800, 1600 or 6250) and high and low defaults (800 & 556) */ substr (mc.regs.a, 29, 4) = fib.density; /* set density from $ tape card */ substr (mc.regs.a, 33, 2) = fib.dens_hist; end; else do; substr (mc.regs.a, 1, 6) = "61"b3 ; /* device code = 61 (dsu191) */ substr (mc.regs.a, 19, 1) = "1"b; /* size given in llinks */ substr (mc.regs.a, 20, 1) = fib.type; /* random file indicator */ substr (mc.regs.a, 21, 1) = fib.perm; /* permanent file indicator */ i = divide (fib.size, 320, 24, 0); /* get size in llinks */ if i <= 16383 then a_ovl.llinks = i; end; mc.regs.q = "000116160000"b3 ; return; %page; /* Variables for gcos_mme_fadd_: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl divide builtin; dcl fc char(2)aligned; dcl i fixed bin(24); dcl substr builtin; dcl unspec builtin; dcl 1 q_ovl aligned based(addr(mc.regs.q)) , 2 fill bit(24)unal , 2 fc_bcd1 fixed bin(6)unsigned unal , 2 fc_bcd2 fixed bin(6)unsigned unal ; dcl 1 a_ovl aligned based(addr(mc.regs.a)) , 2 fill bit(22)unal , 2 llinks fixed bin(14)unsigned unal ; %page; %include gcos_ext_stat_; %page; %include gcos_xlate_bcd_ascii_; end gcos_mme_fadd_;  gcos_mme_fcon_.pl1 09/09/83 1404.1rew 09/09/83 1007.3 51651 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_mme_fcon_: proc (mcpp, increment); /* * MME GEFCON is used by GEFRC to obtain information about a particular file. This * information is placed in the file control block or file control blocks if * several are linked together. The address of the first file control block is found * in the caller's Q register. * * Author: DICK SNYDER OCTOBER 26, 1970 Change: D. KAYDEN APRIL 1974, JULY 1974, AUGUST 1974, JANUARY 1975 Change: R.H.MORRISON MARCH 2, 1976 Change: M. R. Jordan, October 1977 Change: Dave Ward 09/14/81 arrayed fib usage. */ dcl increment fixed bin(24)parm /* no. of param words to skip */; dcl mcpp ptr parm; mcp = mcpp; increment = 0; /* => no arguments to MME. */ j = fixed (substr (mc.regs.q, 1, 18)); /* get fcb offset */ loop: ; if j >= gcos_ext_stat_$storage_limit then return; /* out of bounds ? */ if j < 8 then return; fcbp = addrel (gcos_ext_stat_$gcos_slave_area_seg, j-8); /* get ptr to -8 in fcb */ i = fixed (substr (fcb.filecode, 1, 6)); /* pick up first letter of bcd filecode */ substr (fc, 1, 1) = xlate (i); /* put ascii equiv. in fc */ i = fixed (substr (fcb.filecode, 7, 6)); /* get second bcd letter */ substr (fc, 2, 1) = xlate (i); /* put ascii equivalent in */ do i = 1 to hbound (save_data.fibs, 1); if fct.filecode (i) = fc then do; fibptr = fct (i).fibptr; if substr (mc.regs.q, 19, 2) ^= "00"b then do; /* alternate function requested */ if ^fib.tape then return; if substr (mc.regs.q, 19, 1) then /* set serial number in fib */ fib.serial_no = substr (fcb.file_size, 1, 30); else fib.density = substr (mc.regs.q, 33, 4); /* set new tape density in fib */ return; end; fcb.file_present = "1"b; /* indicate file present */ string (fcb.group) = "0"b; /* clear */ if fct.sysout (i) then goto sysout; fibptr = fct.fibptr (i); /* get pointer to fib */ fcb.dev_add = fib.plud; /* copy log. unit info */ if fib.tape then goto tape; /* tape ? */ if fib.console then goto console; if fib.print then goto printer; if fib.reader then goto reader; fcb.dev_type = "0110"b; /* device is 64 word sector disk */ fcb.random = fib.type; /* copy random indicator */ llinks = divide (fib.size, 320, 23, 0); if llinks > 16383 then fcb.file_size = unspec (llinks) | "400000000000"b3; else do; b = mod (llinks-1, 12)+1; c = b+divide (llinks+11, 12, 23, 0)-1; fcb.file_size = unspec (bc); end; goto next_fcb; /* get next fcb */ tape: ; fcb.dev_type = "0010"b; if fib.tracks = "01"b then fcb.random = "0"b; /* 7 track tape */ else fcb.random = "1"b; /* 9 track tape or default */ fcb.file_size = fib.serial_no; /* plug in serial no */ fcb.reel_seq_no = substr (unspec (fib.seq_no), 10, 9); /* plug in sequence no */ if fib.disp = "11"b | fib.disp = "00"b then fcb.int_cntrl = "1"b; /* set special bit */ goto next_fcb; /* get next fcb */ console: ; fcb.dev_type = "1101"b; goto next_fcb; printer: ; fcb.dev_type = "1010"b; goto next_fcb; reader: ; fcb.dev_type = "1000"b; goto next_fcb; sysout: ; if fct.dac (i) then goto dac; fcb.sysout = "1"b; goto next_fcb; dac: ; fcb.dev_type = "0111"b; goto next_fcb; end; end; next_fcb: ; j = fixed (fcb.fcbptr); /* get next fcb address */ if j = 0 then return; /* no more ? */ if j = fixed (substr (mc.regs.q, 1, 18)) then return; /* end of loop ? */ goto loop; /* no...process more */ %page; /* Variables for gcos_mme_fcon_: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl addrel builtin; dcl divide builtin; dcl fc char(2) /* holder for file code */; dcl fcbp ptr /* pointer to fcb */; dcl fixed builtin; dcl i fixed bin(24); dcl j fixed bin(24); dcl llinks fixed bin(23); dcl mod builtin; dcl string builtin; dcl substr builtin; dcl temp bit(12) aligned /* holder for bcd filecode */; dcl unspec builtin; dcl 1 bc aligned, 2 b fixed bin(17)unaligned, 2 c fixed bin(17)unaligned; dcl 1 fcb aligned based (fcbp), /* fcb model */ /* -8 */ 2 fill1 bit(27) unaligned, 2 reel_seq_no bit(9) unaligned, /* tape reel sequence no */ /* -7 */ 2 file_size bit(36) unaligned, /* for disk - file size */ /* for tape - file serial number */ /* -6 */ 2 fill2 bit(36) unaligned, /* -5 */ 2 fill3 bit(18) unaligned, 2 file_present bit(1) unaligned, 2 fill4 bit(10) unaligned, 2 int_cntrl bit(1) unaligned, /* bit used if tape */ 2 fill5 bit(6) unaligned, /* -4 */ 2 pat bit(18) unaligned, 2 zero1 bit(6) unaligned, 2 filecode bit(12) unaligned, /* -3 */ 2 fill6 bit(36), /* -2 */ 2 fill7 bit(36), /* -1 */ 2 fcbptr bit(18) unaligned, 2 dev_add bit(18) unaligned, /* 0 */ 2 fill8 bit(24) unaligned, 2 group unaligned, 3 random bit(1) unaligned, 3 sysout bit(1) unaligned, 3 dev_type bit(4) unaligned, 3 zero2 bit(6) unaligned; %page; %include gcos_ext_stat_; %page; %include gcos_xlate_bcd_ascii_; end gcos_mme_fcon_;  gcos_mme_fini_.pl1 09/09/83 1404.1rew 09/09/83 1007.3 14967 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ***************************************************************************************** ******************************************************************************************* * * * M M E G E F I N I * * * MME GEFINI is the standard method of bringing an activity to a successful completion. * Control goes back to gcos_run_activity by transferring to an external static label * variable which is set to point to the cleanup procedures in gcos_run_activity. * * * WRITTEN BY DICK SNYDER OCTOBER 15,1970 * MODIFIED BY D. KAYDEN APRIL 1974 * * ******************************************************************************************* ****************************************************************************************** */ gcos_mme_fini_: proc (faultp, increment); /* D E C L A R A T I O N S */ %include gcos_ext_stat_; /* Work Variables */ dcl faultp pointer; /* unused input parameter */ dcl increment fixed bin(24); /* ditto */ /* P R O C E D U R E */ go to gcos_ext_stat_$mme_rtrn; /* return to gein */ end gcos_mme_fini_;  gcos_mme_frce_.pl1 09/09/83 1404.1rew 09/09/83 1007.4 87084 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ******************************************************************************************** ******************************************************************************************** * * * M M E G E F R C E * * * MME GEFRCE is used to produce ISP abort messages or perform * UFAS label processing. * * * CALLING SEQUENCE * * MME GEFRCE * ZERO Function,Abort_message_number * ZERO Parameter_list_ptr,Number_of_ptrs_in_list * return * * For function < 0 ISP abort processing is invoked. Function ^= -1 is in error. * * * For Function >= 0 unimplemented label processing is called. This always * results in an abort of the slave job. * * * Written by M. R. Jordan, August 1977 * ******************************************************************************************** ******************************************************************************************** */ gcos_mme_frce_: procedure (mcp, increment); dcl BAD_FUNCTION_CODE char (48) static internal options (constant) init ("invalid function code specified for 'mme gefrce'"); dcl BAD_MESSAGE_NUMBER char (31) static internal options (constant) init ("undefined error message number "); dcl BAD_PARAM_LOC char (38) static internal options (constant) init ("invalid 'mme gefrce' parameter address"); dcl addr builtin; dcl addrel builtin; dcl fb35 fixed bin(35) aligned based; dcl divide builtin; dcl fixed builtin; dcl function fixed bin(24); dcl gcos_cv_gebcd_ascii_ entry (ptr, fixed bin(24), ptr); dcl gcos_et_$bad_mme_param fixed bin(35) ext; dcl gcos_et_$isp_sys_term fixed bin(35) ext; dcl gcos_et_$unimp_mme fixed bin(35) ext; dcl gcos_mme_bort_$system entry options (variable); dcl gseg_ptr ptr; dcl hbound builtin; dcl i fixed bin(24); dcl increment fixed bin(18); dcl ioa_$rsnnl entry options (variable); dcl last_loc fixed bin(18); dcl lbound builtin; dcl length builtin; dcl message char (128) varying; dcl message_num fixed bin(24); dcl min builtin; dcl mme_arg_ptr ptr; dcl param (3) character (48) varying; dcl param_len fixed bin(24); dcl param_list_len fixed bin(24); dcl param_list_loc fixed bin(18); dcl param_list_ptr ptr; dcl param_loc fixed bin(18); dcl param_pic picture "999999"; dcl param_ptr ptr; dcl storage_limit fixed bin(18); dcl substr builtin; dcl temp_param char (48); /* The following declaration is the argument list to the MME for ISP abort processing. */ dcl 1 mme_args aligned based (mme_arg_ptr), 2 function fixed bin(17) unal, 2 message_num fixed bin(17) unal, 2 param_list_loc bit (18) unal, 2 param_list_len fixed bin(17) unal; /* The following is the parameter list used in ISP abort processing. */ dcl 1 param_list (param_list_len) aligned based (param_list_ptr), 2 param_loc bit (18) unal, 2 param_len fixed bin(17) unal; /* The following are message texts and number of parameters expected. */ dcl 1 MESSAGE (0:33) aligned static internal options (constant), 2 TEXT char (48) init ( "^a", "file code '^a' is already open", "not enough memory to open data file '^a'", "file code '^a' requested but not present", "file code '^a' is not random", "key outside of record area for data file '^a'", "file '^a' record size ^6o > 1024 words", "file '^a' record size ^6o+3 >page size ^6o", "descriptor card file '^a' content error", "data file '^a' key size = 0", "index file '^a' and data file '^a' do not match", "protection error on file code '^a'", "data file '^a' is not open", "file code '^a' is not a data file", "data file '^a' was not opened by 'nopen'", "index file '^a' is too small", "journalization requested - journal file missing", "unrecoverable i/o error on file code '^a'", "page ^6o out of range of data file '^a'", "unable to locate required key in index file '^a'", "data file '^a' was not opened by 'iopen'", "not enough memory to run journal restore", "contents of journal tape file 't1' are not valid", "descriptor card file '.x' content error", "more than 20 data file codes specified", "unrecoverable read error on journal tape 't1'", "invalid file code for additional data file", "file code 'in' or 'ot' must be present for xutil", "file '^a' is not a valid isp index file", "no records have been stored in file '^a'", "file '^a' is not a valid isp data file", ".qpbg buffer is too small", "file '^a' page size discrepancy between isp/fms", "xckptp not taken before xrolbp executed"), 2 NUM_PARAMS fixed bin(24)init ((6)1, 2, 3, (10)1, 2, (2)1, (7)0, (3)1, 0, (2)1); /* Do some initialization and make sure the first argument word to the MME is accessable. */ gseg_ptr = gcos_ext_stat_$gcos_slave_area_seg; storage_limit = gcos_ext_stat_$storage_limit; scup = addr (mc.scu); if fixed (scu.ilc, 18)+1 >= storage_limit then call gcos_mme_bort_$system (gcos_et_$bad_mme_param, "MME GEFRCE parameter word is outside slave limits."); /* Determine the function requested and attempt to process it. */ mme_arg_ptr = addrel (gseg_ptr, fixed (scu.ilc, 18)+1); function = mme_args.function; if function >= 0 then call UFAS_Label_Processing (); else call ISP_Abort_Processing (); return; UFAS_Label_Processing: procedure (); increment = 1; call gcos_mme_bort_$system (gcos_et_$unimp_mme, "MME GEFRCE does not support UFAS calls."); return; end UFAS_Label_Processing; /* This internal procedure controls the simulation of the ISP abort processing subfunction of MME GEFRCE. Assumtions are as follows: (1) function < 0; (2) mme_arg_ptr is valid. */ ISP_Abort_Processing: procedure (); /* Initialize the number of parameters and make sure they're accessable. */ increment = 2; if fixed (scu.ilc, 18)+2 >= storage_limit then call gcos_mme_bort_$system (gcos_et_$bad_mme_param, "MME GEFRCE parameter word is outside slave limits."); /* Make sure the function is -1. If its not, use the precanned message to say so. */ if function = -1 then do ; /* Get the necessary items from the parameter list. */ message_num = mme_args.message_num; param_list_loc = fixed (mme_args.param_list_loc, 18); param_list_len = mme_args.param_list_len; /* Initialize the parameters. */ do i = 1 to hbound (param, 1); param (i) = ""; end; /* Make sure the parameter list is entirely accessable. */ if param_list_len+param_list_loc > storage_limit then message = BAD_PARAM_LOC; /* If the message number is bad, say so. Otherwise, get the proper message. */ else if message_num > hbound (MESSAGE, 1) | message_num < lbound (MESSAGE, 1) then do; param_pic = message_num; message = BAD_MESSAGE_NUMBER || param_pic; end; else call Get_Message (); end; else message = BAD_FUNCTION_CODE; /* ... at last ... abort the user. */ call gcos_mme_bort_$system (gcos_et_$isp_sys_term, "^a^/", message); return; end ISP_Abort_Processing; /* This internal procedure gets the 'message' text. Editing of parameters is also performed. Assumtions are as follows: (1) param(*) = ""; (2) message_num is valid; (3) param_list_loc+param_list_len-1 is a valid location. */ Get_Message: procedure (); /* If parameters exist, process them. */ if param_list_len ^= 0 then do; /* After obtaining a pointer to the parameter list, process those needed and present. */ param_list_ptr = addrel (gseg_ptr, param_list_loc); do i = 1 to min (MESSAGE (message_num).NUM_PARAMS, param_list_len); param_loc = fixed (param_list (i).param_loc, 18); param_len = param_list (i).param_len; /* If the length is negative we use only one word. Otherwise, calculate how many we will need. */ if param_len <= 0 then last_loc = param_loc; else do; param_len = min (param_len, 48); last_loc = param_loc+divide (param_len+5, 6, 18, 0)-1; end; /* If the last word needed is not accessable complain. */ if last_loc >= storage_limit then do; message = BAD_PARAM_LOC; return; end; param_ptr = addrel (gseg_ptr, param_loc); /* If param_len < 0, use the rightmost -param_len digits from the integer at location aram_loc. */ if param_len < 0 then do; param_len = min (-param_len, 6); param_pic = param_ptr -> fb35; param (i) = substr (param_pic, length (param_pic)+1-param_len, param_len); end; /* Otherwise, use the first param_len characters (GBCD). */ else if param_len > 0 then do; call gcos_cv_gebcd_ascii_ (param_ptr, param_len, addr (temp_param)); param (i) = substr (temp_param, 1, param_len); end; end; end; /* Now format the text for the message. */ call ioa_$rsnnl (MESSAGE (message_num).TEXT, message, 0, param); return; end Get_Message; %include gcos_ext_stat_; end gcos_mme_frce_;  gcos_mme_fsye_.pl1 09/09/83 1404.1rew 09/09/83 1007.4 87876 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* **************************************************************************************** ****************************************************************************************** * * * * M M E G E F S Y E * * * This procedure processes the file system mme, mme gefsye. * Currently, creating, deleting, and purging a file, and * creating a catalog are the only calls accepted. * * * WRITTEN: D. Kayden MAR 75 * CHANGED: S.C. Akers NOV 81 Use gcos_build_pathname_ * to expand pathnames instead * of doing it internally. * Changed: R. Barstad Nov 1982 delete IDS2 concurrency * lock control seg if exists * * ****************************************************************************************** **************************************************************************************** */ %page; gcos_mme_fsye_: proc (mcp, increment); %page; /* P R O C E D U R E */ increment = 2; scup = addr (mcp -> mc.scu); gseg = gcos_ext_stat_$gcos_slave_area_seg; ap1 = addrel (gseg, fixed (scu.ilc)+1); ap2 = addrel (gseg, fixed (arglst1.al2)); rap = addrel (gseg, fixed (arglst2.ra)); return.code = "1"b; fnc = fixed (arglst1.fn); if fnc > 22 then go to err2; if fnc_map (fnc) = 0 then go to err2; /* illegal or unimplemented function */ /* Get the pathname of catalog/file description */ nameptr = addr (name); CSEQ_ptr = addrel (gseg, fixed (scu.ilc,18)); call gcos_build_pathname_ (nameptr, addrel (gseg, BUFFER), dirname, entryname, status); dirlen = length (rtrim (dirname)); if dirlen = 0 then go to err1; /* operations in UMC not allowed */ pname = rtrim (dirname) ||">" ||entryname; go to fnc_proc (fnc_map (fnc)); /* process specific function */ fnc_proc (1): /* create catalog request */ dirsw = 1; mode = 01011b; /* access = sma */ bitcount = 0; go to create_entry; fnc_proc (2): /* create file request */ op = addrel (gseg, fixed (arglst2.opt)); /* get pointer to options area */ if opt.nonstruct | opt.userinfo then go to err4; /* illegal file characteristics */ if opt.spec_perms ^= (36) "1"b then go to err4; /* specific permissions not handled */ bitcount = fixed (opt.initial_size) * 36 * 320; if ^opt.llsize then bitcount = bitcount * 12; dirsw = 0; mode = 01010b; /* access = rw */ create_entry: call modefn; /* get mode and access name */ call hcs_$append_branchx (dirname, entryname, mode, ring_br, access_name, dirsw, 0, bitcount, code); if code ^= 0 then go to err3; if fnc = 2 then go to exit; /* done if create catalog */ if opt.ids & opt.attrib_present then do; entryname = substr (pname, dirlen+2) || ".ids_attributes"; call hcs_$make_seg (dirname, entryname, "", 01010b, attribptr, code); if attribptr = null then go to err3; attributes = opt.attrib; end; go to exit; fnc_proc (3): /* delete or purge file request */ call delete_$path (dirname, entryname, "000100"b, "gcos_mme_fsye_", code); if code ^= 0 then go to err5; call gcos_ids2_concur_$delete_control(dirname,entryname,code); /* just try to delete, if can't --code bad-- don't care */ entryname = substr (pname, dirlen+2) || ".ids_attributes"; call delete_$path (dirname, entryname, "000100"b, "gcos_mme_fsye_", code); exit: return; modefn: proc; access_name = get_group_id_$tag_star (); ring_br = fixed (cu_$level_get (), 6); return; end modefn; /* Error returns */ err1: return.code = "100000111101"b; msg = "operations on the UMC not allowed"; go to err_common; err2: return.code = "100000111101"b; /* 4075 = illegal gefsye function */ msg = "illegal or unimplemented function"; go to err_common; err3: return.code = "100000111111"b; /* 4077 = cannot create entry */ go to get_msg; err4: return.code = "100000111110"b; /* 4076 = illegal file characteristics */ msg = "unimplemented file options"; go to err_common; err5: return.code = "100001000100"b; /* 4104 = unable to delete entry */ get_msg: call convert_status_code_ (code, "xxxxxxxx", msg1); msg = msg1; /* move char (100) to char (102) */ err_common: return.messaddr = arglst1.buf; call gcos_cv_ascii_gebcd_ (addr (msg), length (msg), addrel (gseg, fixed (arglst1.buf)), i); return.messlen = divide (length (msg), 6, 17, 0); return; %page; /* External Entries */ dcl convert_status_code_ ext entry (fixed bin(35), char (8), char (100)); dcl cu_$level_get ext entry returns (fixed bin(24)); dcl cv_oct_ entry (char (*), fixed bin(35)); dcl date_time_$fstime ext entry (fixed bin(35), char (13)); dcl delete_$path ext entry (char (*), char (*), bit (6), char (*), fixed bin(35)); dcl expand_path_ entry (ptr, fixed bin(24), ptr, ptr, fixed bin(35)); dcl gcos_build_pathname_ ext entry (ptr, ptr, char(*), char (*), bit (72) aligned); dcl gcos_cv_ascii_gebcd_ ext entry (ptr, fixed bin(24), ptr, fixed bin(24)); dcl gcos_cv_gebcd_ascii_ ext entry (ptr, fixed bin(24), ptr); dcl gcos_ids2_concur_$delete_control ext entry (char(*),char(*),fixed bin(35)); dcl get_group_id_$tag_star ext entry returns (char (32) aligned); dcl get_default_wdir_ ext entry returns (char (168)); dcl hcs_$append_branchx ext entry (char (*), char (*), fixed bin(5), (3) fixed bin(6), char (*), fixed bin(1), fixed bin(1), fixed bin(24), fixed bin(35)); dcl hcs_$chname_file ext entry (char (*), char (*), char (*), char (*), fixed bin(35)); dcl hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin(24), fixed bin(2), ptr, fixed bin(35)); dcl hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin(5), ptr, fixed bin(35)); /* Work Variables */ dcl access_name char (32); dcl bitcount fixed bin(24); dcl bitmode bit (5) aligned; dcl code fixed bin(35); dcl CSEQ_ptr ptr; dcl date char (13); dcl dirname char (168); dcl dirsw fixed bin(1); dcl ecount fixed; dcl entryname char (32); dcl increment fixed bin; /* number of argument words to skip over */ dcl msg char (102); dcl msg1 char (100); dcl mode fixed bin(5); dcl name char (32); dcl pname char (168) varying; dcl ring_br (3) fixed bin(6); dcl status bit (72) aligned; dcl (dirlen, fnc, i, j, k) fixed bin(24); dcl word bit (36) aligned based; dcl (ap1, ap2, attribptr, cdp, gseg, nameptr, nnp, op, pp, rap, radp, sp) ptr; /* Structures and overlays */ dcl 1 arglst1 aligned based (ap1), /* structure for the arg list following the mme */ 2 ccal bit (18) unal, /* 0 or courtesy call address */ 2 al2 bit (18) unal, /* location of arg list 2 */ 2 fn bit (18) unal, /* function code */ 2 buf bit (18) unal; /* working buffer address */ dcl 1 arglst2 aligned based (ap2), /* structure for the main argument list */ 2 ra bit (18) unal, /* address of the return area */ 2 pad1 bit (18) unal, 2 catdesc bit (18) unal, /* address of the cataog description */ 2 perms bit (18) unal, /* address of the permissions word */ 2 opt bit (18) unal, /* address of the options area */ 2 newname bit (18) unal; /* address of the newname for modify functions */ dcl 1 opt aligned based (op), /* the options area */ 2 contig bit (1) unal, /* file must be contiguous */ 2 rand bit (1) unal, /* define file as random */ 2 tss bit (1) unal, /* file is tss-created */ 2 ids bit (1) unal, /* file is IDS */ 2 llsize bit (1) unal, /* file sizes specified in llinks */ 2 nonstruct bit (1) unal, /* file on tape or nonstructured disk pack */ 2 pad bit (1) unal, 2 attrib_present bit (1) unal, /* attributes present */ 2 userinfo bit (1) unal, /* user specified information present */ 2 pad1 bit (4) unal, 2 protect bit (1) unal, /* protection options specified */ 2 pad2 bit (22) unal, 2 initial_size bit (18) unal, /* initial file size */ 2 max_size bit (18) unal, /* maximum file size (zero if unlimited) */ 2 spec_perms bit (36) unal, /* specific permissions */ 2 attrib bit (180) unal; /* attributes for IDS files */ dcl attributes bit (180) aligned based (attribptr); /* MME GEFSYE Calling Sequence */ dcl 1 CALL_SEQ aligned based (CSEQ_ptr), 2 CC bit (18) unaligned, 2 ARGLIST bit (18) unaligned, 2 FUNCTION bit (18) unaligned, 2 BUFFER fixed bin (18) unaligned unsigned; dcl 1 return aligned based (rap), /* return area for error indicators */ 2 code bit (12) unal, /* error code or zero */ 2 pad bit (24) unal, 2 messaddr bit (18) unal, /* address of error message */ 2 messlen fixed bin(17) unal; /* length of error message (in words) */ dcl fnc_map (22) fixed bin(24)aligned int static init ( /* map gefsye function codes to processors */ 0, /* 1 = unimplemented */ 1, /* 2 = ccreat */ 2, /* 3 = fcreat */ (5) 0, /* 4 to 8 = unimplemented */ 3, /* 9 = freles */ (12) 0, /* 10 to 21 = unimplemented */ 3); /* 22 = fpurge */ dcl (addr, addrel, bit, divide, fixed, index, length, null, substr, unspec) builtin; %page; %include gcos_ext_stat_; end gcos_mme_fsye_;  gcos_mme_info_.pl1 12/11/84 1358.2rew 12/10/84 1036.5 105174 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_mme_info_: proc (mcpp, increment); /* * MME GEINFO allows a slave program to access specific information outside the * program's normal Base Address Register (BAR) limits. Either or both of the * following functions may be requested: * * * 1. Information from the upper slave service area (SSA) of the user * program can be copied to a buffer provided by the user. * ***NOTE: this function is _n_o_t supported*** * * 2. A List Pointer Word (LPW) can be supplied to allow one or more single * units of information to be placed in the slave program's core memory. * * * CALLING SEQUENCE * * MME GEINFO * ZERO Buffer_end,Number_of_words * ZERO LPW,Size_of_list * * * WHERE: * * Buffer_end address+1 of the end of a buffer storage area * Number_of_words size of the storage area * LPW Address of first word of list of directives to be processed * Size_of_list Number of words of list directives * * * The format of the list of directives is as follows: * * * ZERO Address,Option * ZERO Address,Option * . . . * . . . * ZERO Address,Option * * * Address is the location at which the requested data word is to be stored. * Option is the option number (See code below for values). * * Author: ? Change: M. R. Jordan, October 1977 Change: Dave Ward 07/28/81 Reorganized. 4S1 notice. Removed arg list restriction (By Dick Hemes) Change: Ron Barstad 83-09-29 Changed software release "4S1" to "4S3". Added options 16 and 17 for 4js3. Change: Ron Barstad 84-02-21 Allow move from SSA if only 2 words since is BCD userid */ dcl increment fixed bin(24)parm; dcl mcpp ptr parm; mcp = mcpp; /* Get set up for the MME processing. */ increment = 2; scup = addr (mc.scu); storage_limit = gcos_ext_stat_$storage_limit; gseg_ptr = gcos_ext_stat_$gcos_slave_area_seg; /* Verify that the entire MME argument list is in addressable memory. */ mme_arg_list_loc = fixed (scu.ilc, 18)+1; if mme_arg_list_loc+2 >= storage_limit then call gcos_mme_bort_$system ( /* Bad mme address. */ gcos_et_$bad_mme_addr , "MME GEINFO argument list is not entirely in slave limits." ); mme_arg_list_ptr = addrel (gseg_ptr, mme_arg_list_loc); /* Is the user asking for any SSA words to be copied? If so we must complain at this point since we cannot satisfy such a request. */ if mme_arg_list.number_of_words ^= (18)"0"b /* User has given an SSA Copy request */ then if /* See if we can bypass because it's redundant */ mme_arg_list.buffer_end ^= mme_arg_list.lpw | /* If SSA copy word just dup's the option word, we can */ mme_arg_list.number_of_words ^= mme_arg_list.lpw_size then /* If any of these checks fail, we can't bypass */ if fixed(mme_arg_list.number_of_words, 18) ^= 2 then /* there is ONE exception */ do; call gcos_mme_bort_$system ( /* Unimplemented MME. */ gcos_et_$unimp_mme , "MME GEINFO cannot copy SSA words to user buffer." ); end; else do; /* Move the 2 word BCD userid (.SUID) to user buffer */ data_word_loc = fixed (mme_arg_list.buffer_end, 18); if data_word_loc > storage_limit then call gcos_mme_bort_$system ( /* Bad mme address. */ gcos_et_$bad_mme_addr , "MME GEINFO buffer end is not within slave limits." ); data_word_ptr = addrel (gseg_ptr, data_word_loc-2); call gcos_cv_ascii_gebcd_ (addr(gcos_ext_stat_$userid),12, data_word_ptr, i); return; end; /* Now that we seem to have a valid request for a list of directives to be processed, let's see if the list is any good. */ arg_list_loc = fixed (mme_arg_list.lpw, 18); size_of_list = fixed (mme_arg_list.lpw_size, 18); if arg_list_loc+size_of_list > storage_limit then call gcos_mme_bort_$system ( /* Bad mme address. */ gcos_et_$bad_mme_addr , "MME GEINFO directive list is not entirely within slave limits." ); if size_of_list = 0 then return; arg_list_ptr = addrel (gseg_ptr, arg_list_loc); /* Now process the entire list of directives. */ do arg_list_index = 1 to size_of_list; /* Verify the validity of the data word location specified by the user in the directive list. This address must be within the slave limits or we must inform the user that he has sinned. */ data_word_loc = fixed (arg_list.address (arg_list_index), 18); if data_word_loc >= storage_limit then call gcos_mme_bort_$system ( /* Bad mme address. */ gcos_et_$bad_mme_addr , "MME GEINFO directive word data location is outside slave limits." ); data_word_ptr = addrel (gseg_ptr, data_word_loc); /* Now extract the option number specified, verify it and prepare to process it. */ option_number = fixed (arg_list.option (arg_list_index), 18); if option_number > hbound (opt, 1) then call gcos_mme_bort_$system ( /* Bad mme address (option number). */ gcos_et_$bad_mme_addr , "MME GEINFO directive word option number is bad." ); goto opt (option_number); %page; /* Processor time remaining (copy of .SALT) */ opt (1): fixed_data_word = Convert_Time (gcos_ext_stat_$time_limit-virtual_cpu_time_ ()+gcos_ext_stat_$initial_cpu_time); goto option_loop; /* SYSOUT lines remaining (calculated from .SSYOT 0-17 - .SSYOT 18-35) */ opt (2): fixed_data_word = gcos_ext_stat_$sysout_limit-gcos_ext_stat_$sysout_lines; goto option_loop; /* Channel time remaining (copy of .SACHT) */ opt (3): fixed_data_word = 0; go to option_loop; /* Processor time used (copy of .SPRT) */ opt (4): fixed_data_word = Convert_Time (virtual_cpu_time_ ()-gcos_ext_stat_$initial_cpu_time); goto option_loop; /* SYSOUT lines used (from .SSYOT 18-35) */ opt (5): fixed_data_word = gcos_ext_stat_$sysout_lines; goto option_loop; /* Channel time used (copy of .STCHT) */ opt (6): fixed_data_word = 0; goto option_loop; /* Time-of-day start of activity (copy of .START) */ opt (7): fixed_data_word = Convert_Time (gcos_ext_stat_$activity_start_time); goto option_loop; /* Program state word (copy of .STATE) */ opt (8): data_word = "400000000000"b3; goto option_loop; /* Job urgency (from .SURG 18-23 aligned to bits 30-35) */ opt (9): fixed_data_word = 10; go to option_loop; /* Configuration data (copy of .CRFIG) This word says: Series 60 or 6000; IOM; IOM #0 configured; CPU #0 configured; CPU #0 has EIS; and Datanet 355/6600 on system. */ opt (10): data_word = "100010001000100000001000000000000001"b; goto option_loop; /* BCD time in hours-minutes-seconds (formatted as hhmmss) */ opt (11): call date_time_ (clock (), date_string); date_string = substr (date_string, 1, 2) || substr (date_string, 4, 2) || substr (date_string, 7, 2); call gcos_cv_ascii_gebcd_ (addr (date_string), 6, addr (data_word), i); goto option_loop; /* Program number from SNUMB */ opt (12): if substr (data_word, 1, 30) = gcos_ext_stat_$snumb then substr (data_word, 31, 6) = "12"b3; else substr (data_word, 31, 6) = "00"b3; goto option_loop; /* Software release number (copy of .CRSR) */ opt (13): data_word = "046203202020"b3; /* "4S3" in BCD */ goto option_loop; /* System default number of lines per printed page (copy of .CRPSZ) */ opt (14): upper_half_data_word = 55; goto option_loop; /* Julian date (copy of .CRJCD) */ opt (15): fixed_data_word = Julian_Date (); goto option_loop; /* Shared system number (.CRSSN) */ opt (16): fixed_data_word = 0; goto option_loop; /* Startup option word (copy of .CROPT) This word says: ASCII printer available, FORTX, 800 & 1600 bpi, 800 bpi low-den and 1600 high-den. */ opt (17): data_word = "010100000000000000100000001001000100"b; option_loop: ; end; /* Now that we have finished with the list of directives, return to the caller. */ return; %page; Convert_Time: proc (multime) returns (fixed bin (35)); dcl multime fixed bin(71)parm; gcostime = divide (multime, 1000, 29)*64; return (gcostime); dcl gcostime fixed bin(35); end Convert_Time; %page; Julian_Date: proc () returns (fixed bin (24)); call date_time_ (clock (), date_string); call convert_date_to_binary_ (date_string||" midnight", midnight, code); substr (date_string, 1, 5) = "01/01"; call convert_date_to_binary_ (date_string||" midnight", start_year, code); call convert_date_to_binary_$relative ("1day", tomorrow, midnight, code); daysworth = tomorrow-midnight; julian_date = divide ((midnight-start_year), daysworth, 34)+1; return (julian_date); dcl code fixed bin(35); dcl convert_date_to_binary_ entry (char (*), fixed bin(71), fixed bin(35)); dcl convert_date_to_binary_$relative entry (char (*), fixed bin(71), fixed bin(71), fixed bin(35)); dcl daysworth fixed bin(71); dcl julian_date fixed bin(24); dcl midnight fixed bin(71); dcl start_year fixed bin(71); dcl tomorrow fixed bin(71); end Julian_Date; %page; /* Variables for gcos_mme_info_: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl addrel builtin; dcl arg_list_index fixed bin(24); dcl arg_list_loc fixed bin(24); dcl arg_list_ptr ptr; dcl clock builtin; dcl data_word bit (36) aligned based (data_word_ptr); dcl data_word_loc fixed bin(24); dcl data_word_ptr ptr; dcl date_string char (8); dcl date_time_ entry (fixed bin(71), char (*)); dcl divide builtin; dcl fixed builtin; dcl fixed_data_word fixed bin(35) aligned based (data_word_ptr); dcl gcos_cv_ascii_gebcd_ entry (ptr, fixed bin(24), ptr, fixed bin(24)); dcl gcos_et_$bad_mme_addr fixed bin(35) ext; dcl gcos_et_$unimp_mme fixed bin(35) ext; dcl gcos_mme_bort_$system entry options (variable); dcl gseg_ptr ptr; dcl hbound builtin; dcl i fixed bin(24); dcl mme_arg_list_loc fixed bin(24); dcl mme_arg_list_ptr ptr; dcl option_number fixed bin(24); dcl size_of_list fixed bin(24); dcl storage_limit fixed bin(18); dcl substr builtin; dcl upper_half_data_word fixed bin(17) unal based (data_word_ptr); dcl virtual_cpu_time_ entry () returns (fixed bin(71)); dcl 1 arg_list (size_of_list) aligned based (arg_list_ptr), 2 address bit (18) unal, 2 option bit (18) unal; dcl 1 mme_arg_list aligned based (mme_arg_list_ptr), 2 buffer_end bit (18) unal, 2 number_of_words bit (18) unal, 2 lpw bit (18) unal, 2 lpw_size bit (18) unal; %page; %include gcos_ext_stat_; end gcos_mme_info_;  gcos_mme_inos_.pl1 09/09/83 1404.1rew 09/09/83 1007.6 539451 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_mme_inos_: proc (mcpp, increment); /* * This procedure processes the I/O MME, GEINOS. The GEINOS calling sequence(s) are: * Also contains code to process the GEENDC MME. * * MME GEINOS * OPERATION WORD * IDENTIFICATION WORD * RETURN WORD * * or..... * * MME GEINOS * OPERATION WORD 1 * IDENTIFICATION WORD 1 * OPERATION WORD 2 * IDENTIFICATION WORD 2 * RETURN WORD * * where: * * OPERATION WORD FORMAT = * * BITS USE * 0-5 Device Command [cc] (See values below) * 6-17 Zeros * 18-22 IOC Command [ii] * 23 Zero * 24-29 Control * 30-35 Count [nn] * * Operation word (GMAP oct implementation): * 8 16 * oct cc0000ii00nn * * IDENTIFICATION WORD FORMAT = * * BITS USE * 00-17 File Control Block Pointer * 18-35 Dcw List Pointer * * RETURN WORD FORMAT = * * BITS USE * 0-17 Status Return Pointer * 18-35 Courtesy Call Address * * DCW FORMAT * * BITS USE * 0-17 Data Address * 18-20 Zero * 21 Character tally flag. * 22-23 Action Code (See values below) * 24-35 Count (value of zero indicates count of 4096) * * DCW ACTION CODES * * CODE MEANING * 00 (IOTD) Transfer and Disconnect (this is last DCW in list) * 01 (IOTP) Transfer and Continue (with next DCW in list) * 10 (TDCW) Skip to New DCW List (whose address is in Data Address) * 11 (IONTP) Skip Data Transfer (skip words and continue with next DCW in list) * * OPERATION WORD DEVICE COMMANDS [cc] * * CODE MEANING * * 00 Request Status * * 03 Read Typewriter * 04 Read Tape Decimal * 05 Read Tape Binary * * 13 Write (then Read) Typewriter * 14 Write Tape Decimal * (and Write Filemark Decimal, when IOC command = "00100"b) * 15 Write Tape Binary * (and Write Filemark, when IOC command = "00100"b) * * 25 Read * * 30 Write Printer Edited * 31 Write * * 34 Seek * * 40 Reset Status * * 41 Set 6250 Density * 42 Set 800 Density * 43 Set 556 Density * 44 Forward Space Record * 45 Forward Space to Filemark * 46 Backspace Record * 47 Backspace to Filemark * * 54 Erase * 55 Write EOF * * 60 Set High Density * 61 Set Low Density * 64 Set 200 Density * 65 Set 1600 Density * * 70 Rewind * 72 Rewind and Unload * * */ %page; /* Author: DICK SNYDER OCTOBER 7, 1970 Change: T. CASEY, OCTOBER 1973, DECEMBER 1973, AUGUST 1974 Change: D. KAYDEN, MARCH 1974, APRIL 1974, JULY 1974, DECEMBER 1974, MARCH 1975 Change: R.H. MORRISON FEB 2, 1976 Change: M. R. Jordan, September 1976 Change: A. N. Kepner, March 1978 to allow courtesy call i/o within cc routines Change: Dave Ward 05/20/81 multirecord read/write disk, various bugs. Change: Dave Ward 09/02/81 Removed use of cmd_word variable. Change: Dave Ward 09/02/81 provided tape density 6250. Change: Dave Ward 09/16/81 removed use of init (except for constant). Change: Scott C. Akers 12/23/81 Fix bugs which arise when dealing with discontiguous DCWs and stuff. Change: Ron Barstad 01/27/83 Rewrite tape status checking. The old version was checking tally residues and IOM Central statuses, mistaking them for handler status. Change: Ron Barstad 83-07-01 Fix bug in writting multi-records to a non-randon file Change: Ron Barstad 83-08-03 Fix courtesy call queue to work like GCOS */ %page; dcl increment fixed bin (24)parm; /* number of words MME processor must skip over */ dcl mcpp ptr parm /* pointer to machine conditions. */; mcp = mcpp; increment = 3; /* init parameter skip number */ gseg = gcos_ext_stat_$gcos_slave_area_seg; /* pointer to slave program */ storlimit = gcos_ext_stat_$storage_limit; /* slave core boundary */ trace_or_stopsw = dbs_mme_inos_trace | dbs_mme_inos_stop; scup = addr (mc.scu); /* get ptr to scu data */ i = instruction_counter + 2; /* get offset of first id word */ idptr = addrel (gseg, i); /* build pointer to id word */ if id_word.filep >= storlimit then /* file control block ptr */ call gcos_mme_bort_$system ( gcos_et_$invalid_file_ptr , "File code pointer in GEINOS sequence is outside slave limits." ); workp = addrel (gseg, id_word.filep); /* get pointer to fcb */ substr (fc, 1, 1) = xlate (fixed (substr (file_code_word.fcode, 1, 6))); /* translate file code */ substr (fc, 2, 1) = xlate (fixed (substr (file_code_word.fcode, 7, 6))); /* to ascii */ if fc = " " /* a blank file code is illegal */ then call gcos_mme_bort_$system (gcos_et_$fc_not_defined, "Blank file code is illegal."); call init_routine; /* Initialize variables. */ /* Now we see if we have a legal file code. The variable "j" gets set. */ if fc = "*t" | fc = "t/" | fc = "/t" /* See if it's the operator's console. */ then fc = "t*"; if ^match_fc () /* If we didn't find a match, we bail out. */ then call gcos_mme_bort_$system (gcos_et_$fc_not_defined, """^a""", fc); if fct.sysout (j) then /* abort if sysout file */ call gcos_mme_bort_$system ( gcos_et_$fc_not_defined , "File code ""^a"" is assigned to SYSOUT." , fc ); fibptr = fct.fibptr (j); /* copy pointer to fib */ call process_request; /* Go do the dirty work. */ %page; com_proc (01): ; /* disk or drum seek */ seeksw = "1"b; /* Indicate seek has been performed. */ if fib.type = random_file then do; /* (no seek necessary for sequential file) */ if dcw_offset >= storlimit then /* dcw addr OOB? */ call gcos_mme_bort_$system ( gcos_et_$invalid_dcw_ptr , "DCW is outside slave limits." ); dcwptr = addrel (gseg, dcw_offset); /* get address of dcw */ if dcw.data_addr >= storlimit /* data address OOB? */ | dcw.count ^= 1 then /* count not 1 ? */ call gcos_mme_bort_$system ( gcos_et_$bad_seek_dcw , "DCW address field is outside slave limits or DCW word count is not 1." ); i = addrel (gseg, dcw.data_addr) -> seek_address; /* grab seek address */ fib.current = i*64; /* multiply by block size */ if trace_or_stopsw then call ioa_ ("seek ^w", i); end; bump: ; increment = increment + 2; /* prepare for following command */ idptr = addrel (idptr, 2); /* get ptr to new id word */ call process_request; /* Do the next command. */ %page; com_proc (02): ; /* read disk continuous */ if fib.read = "0"b then do; /* Reads are not allowed on this file. */ if fib.null then do; /* If this a null file */ substr (slave_status, 3, 4) = "1111"b; /* return eof status. */ goto return_stat; end; call gcos_mme_bort_$system ( gcos_et_$impermissible_perm_read , "No read permission on file ""^a""." , fc ); end; if fib.order = write_file then do; /* If last i/o request was a write, then */ fib.order = read_file; /* we must bring ios_'s seek pointers together */ goto seek; end; if fib.type = random_file then do; /* Seek only if file is random. */ seek: ; if seeksw = "0"b then /* read or write must be preceded by a seek */ call gcos_mme_bort_$system ( gcos_et_$bad_io_cmnd_file , "Disk ^[read^;write^] without a seek on file ""^a""." , fib.order = read_file , fc ); call do_seek; end; if fib.type ^= random_file then /* Linked file. */ call check_multirecord_request (mr); goto loop; com_proc (03): ; /* write disk continuous */ if fib.write = "0"b then do; /* write not allowed ? */ if fib.null then goto return_stat; /* is this a null file ? */ call gcos_mme_bort_$system ( gcos_et_$impermissible_perm_write , "No write access to file ""^a""." , fc ); end; if fib.order = read_file then do; /* if last i/o request was a read, then */ fib.order = write_file; /* we must bring ios_'s seek pointers together */ goto seek; end; if fib.type = random_file then goto seek; call check_multirecord_request (mr); /* transfer to loop. */ %page; /* Read and write processing. */ loop: ; /* Call a subroutine which examines the dcw list and returns the number of contiguous words to transmit (count), the address to transmit from/to (where), and an indicator saying whether there are more dcws to be processed (continue). */ call get_dcw; if fib.type = linked_file then do; /* Linked file on disk. */ if fib.order = read_file then /* sequential file read */ if fib.current >= fib.last then do; /* check for end of valid data */ substr (slave_status, 3, 4) = "1111"b; /* set eof status */ wc_residue = count; da_residue = where; goto return_stat; end; if mr = "0"b then /* Not a multirecord request. */ if (count + total_count) > 320 then do; /* About to exceed 1 block. */ wc_residue = count + total_count - 320; continue = "0"b; count = max (0, 320 - total_count); /* Adjust count to finish to 1 block. */ end; end; fib.current = fib.current + count; /* Calculate next position in the file. */ if fib.current > fib.size then goto disk_eof; /* will i/o go over eof ? */ /* If get_dcw returns a where value of -1, this means that a skip DCW (IONTP) has been encountered. In this case, the proper pointer will be advanced by the value in count, an the next DCW is obtained. */ if where = -1 then do; /* => Skip DCW (IONTP). */ if fib.type = linked_file then if fib.order = write_file then do; /* Fill block with zeroes. */ if count < 1 then nelemt = 0; else call ios_$write ( fib.stream , addr (z320) , 0 /* offset to 1st word of z320. */ , count /* Number words to write. */ , nelemt /* (output) number of words written. */ , status ); goto complete; end; if count > 0 then call do_seek; end; else do; /* Data movement DCW (IOTP or IOTD). */ issue: ; if fib.order = write_file then call ios_$write ( fib.stream , gseg , where , count , nelemt , status ); else call ios_$read ( fib.stream , gseg , where , count , nelemt , status ); complete: ; total_count = total_count + nelemt; /* Update count total. */ if fib.tape then goto tape_stat; if code ^= 0 then do; fail_loop: ; call gcos_mme_bort_$system ( code , "Fatal ^[read^;write^] error on ^[random^;linked^] file ""^a""." , fib.order = read_file , fib.type = random_file , fc ); end; if fib.order = write_file then fib.last = max (fib.last, fib.current); /* update last pointer */ da_residue = where + count; end; if continue then goto loop; /* Complete the i/o operation. */ if fib.type = linked_file then /* Final positioning. */ if mr = "0"b then /* Not multirecord request. */ if total_count < 320 then do; fib.current = fib.current + (320 - total_count); if fib.order = write_file then do; /* Fill block with zeroes. */ call ios_$write ( fib.stream , addr (z320) , 0 /* 1st word of z320. */ , 320-total_count /* Number words to write. */ , nelemt /* (output) number of words written. */ , status ); if code ^= 0 then goto fail_loop; if fib.order = write_file then fib.last = max (fib.last, fib.current); /* update last pointer */ end; else /* => linked file read. Position to block. */ call do_seek; end; goto return_stat; %page; com_proc (04): ; /* rewind disk/drum */ if fib.print then goto return_stat; /* temporary fix until sysout is working */ if fib.null then goto return_stat; /* is this a null file ? */ fib.current = 0; /* reset position */ goto disk_posit; %page; com_proc (05): ; /* backspace disk/drum */ bksp_sw = "1"b; /* remember backspace */ bksp_share: ; if fib.type = random_file then /* abort if random */ call gcos_mme_bort_$system ( gcos_et_$bad_io_cmnd_file , "Attempt to backspace/forward space random file ""^a""." , fc ); if fib.null then goto return_stat; /* is this a null file ? */ j = op_word.count; if j = 0 then j = 64; /* zero count means 64 */ j = 320*j; if bksp_sw then j = -j; fib.current = fib.current + j; if fib.current < 0 then fib.current = 0; /* allow for backspace too far */ if fib.current > fib.size then do; /* check for end of file */ disk_eof: ; if fib.type = random_file then /* end of file on a random file */ call gcos_mme_bort_$system ( gcos_et_$access_beyond_file , "Positioning to ^i on random file ""^a"" exceeds size ^i." , fib.current , fc , fib.size ); substr (slave_status, 3, 4) = "1111"b; /* Is this the proper status ? */ rec_ct_residue = divide (fib.current - fib.size, 320, 17, 0); substr (slave_status, 31, 6) = substr (unspec (rec_ct_residue), 31, 6); fib.current = fib.size; end; disk_posit: ; call do_seek; goto return_stat; /* process status */ %page; com_proc (06): ; /* forward space disc/drum */ bksp_sw = "0"b; /* remember forward space */ goto bksp_share; /* now go share backspace code */ %page; com_proc (07): ; /* reset status for disk/drum */ goto return_stat; %page; com_proc (08): ; /* request status for disk/drum */ goto return_stat; %page; com_proc (09): ; /* read tape binary */ error_retry = "0"b; total_read = 0; /* Haven't read anything first time through. */ fib.order = read_file; /* indicate read to be done */ if fib.mode ^= "00"b then do; fib.mode = "00"b; order = "binary"; call ios_$order (fib.stream, order, null, status); end; more_dcws = "1"b; do while (more_dcws); call next_dcw_ptr (output_ptr, transfer_count, more_dcws); call ios_$read (fib.stream, output_ptr, 0, transfer_count, nelemt, status); total_read = total_read + nelemt; da_residue = dcw.data_addr + nelemt; wc_residue = transfer_count - nelemt; end; goto tape_status; %page; com_proc (10): ; /* write tape binary */ fib.order = write_file; /* indicate write to be done */ if fib.mode = "00"b then goto mode_set; /* mode already binary? */ fib.mode = "00"b; /* set mode to binary */ order = "binary"; /* set up to change mode */ mode_order: ; call ios_$order (fib.stream, order, null, status); /* change tape mode */ mode_set: ; call get_dcw; /* get dcw */ error_retry = "0"b; /* not doing error recovery */ if where >= 0 then if continue = "0"b then goto issue; /* avoid overhead of extra buffering if possible */ sc_ga = "1"b; /* remember for possible error recovery */ if fib.buffer = null then fib.buffer = addr (tapebuffer); if fib.order = read_file then do; sc_read: ; call ios_$read (fib.stream, fib.buffer, 0, 1632, nelemt, status); call adjust_buffer (fib.buffer); call scatter_input (fib.buffer); /* send any data to slave, even if tape error */ end; else do; /* Write tape. */ posit = 0; /* init fib.buffer position */ ga_loop: ; if where >= 0 /* skip dcw ? */ then do; ibuffptr = addrel (fib.buffer, posit); /* pointer to intermediate fib.buffer */ sbuffptr = addrel (gseg, where); /* pointer to slave fib.buffer */ internal_buffer = slave_buffer; /* move data */ posit = posit + count; /* adjust intermediate fib.buffer position */ end; if continue /* more to do ? */ then do; call get_dcw; goto ga_loop; end; da_residue = where + count; /* data address residue */ wc_residue = 0; /* word count residue */ call ios_$write (fib.stream, fib.buffer, 0, posit, nelemt, status); /* write gathered output */ end; goto tape_status; /* done - now process status */ %page; com_proc (11): ; /* read tape nine */ fib.order = read_file; /* indicate read to be done */ asa9_common: ; if fib.mode = "10"b then goto mode_set; /* already in asa9 mode? */ fib.mode = "10"b; /* set mode to decimal */ order = "nine"; /* prepare to make order call */ goto mode_order; %page; com_proc (12): ; /* write tape nine */ fib.order = write_file; /* indicate write to be done */ goto asa9_common; %page; com_proc (13): ; /* rewind */ order = "rewind"; goto order_call; %page; com_proc (14): ; /* write eof */ order = "eof"; goto order_call; %page; com_proc (15): ; /* forward space file */ order = "forward_file"; goto order_call; %page; com_proc (16): ; /* backspace file */ order = "backspace_file"; goto order_call; %page; com_proc (17): ; /* forward space record */ order = "forward_record"; goto order_loop; %page; com_proc (18): ; /* backspace record */ order = "back"; order_loop: ; i = op_word.count; /* pick up skip count */ if i = 0 then i = 64; /* count of 0 means 64 */ do j = 1 to i; /* loop to skip */ call ios_$order (fib.stream, order, null, status); /* issue a skip order */ if code ^= 0 then do; /* stop if any problems */ rec_ct_residue = i-j; /* compute count of no of skips left */ goto tape_status; end; end; goto tape_status; /* process status */ %page; com_proc (19): ; /* write file mark binary */ goto com_proc (14); %page; com_proc (20): ; /* write file mark decimal */ goto com_proc (14); %page; com_proc (21): ; /* erase */ order = "erase"; goto order_call; %page; com_proc (22): ; /* rewind and unload */ order = "unload"; goto order_call; %page; com_proc (23): ; /* set high density */ order = "high"; density_history = "01"b ; goto tape_high_low; %page; com_proc (24): ; /* set low density */ order = "low"; density_history = "00"b ; tape_high_low: ; if fib.density = "0000"b then goto set_density; /* means "as is" */ if fib.density = "1111"b then do; /* use system default densities */ if order = "high" then order = default_high; else order = default_low; goto set_density; end; if fib.density = "0010"b then goto com_proc (26); if fib.density = "0100"b then goto com_proc (27); if fib.density = "1001"b then goto com_proc (28); if fib.density = "1100"b then goto com_proc (41); %page; com_proc (25): ; /* set 200 density */ order = "d200"; density_history = "10"b ; goto set_density; %page; com_proc (26): ; /* set 556 density */ order = "d556"; density_history = "00"b ; goto set_density; %page; com_proc (27): ; /* set 800 density */ order = "d800"; density_history = "01"b ; goto set_density; %page; com_proc (28): ; /* set 1600 density */ order = "d1600"; density_history = "11"b ; set_density: ; call ios_$order (fib.stream, order, null, status); if code = 0 then fib.dens_hist = density_history; /* change history bits only if order was successful */ goto tape_status; %page; com_proc (41): ; /* set 6250 density */ order = "d6250"; density_history = "00"b ; goto set_density; %page; com_proc (29): ; /* reset status */ order = "reset_status"; override = 1; order_call: ; call ios_$order (fib.stream, order, null, status); goto tape_status; %page; com_proc (30): ; /* request status */ call ios_$order (fib.stream, "request_status", addr (slave_status), status); override = 1; goto tape_status; %page; com_proc (31): ; /* read tape bcd */ fib.order = read_file; /* indicate read to be done */ bcd_common: ; if fib.mode = "01"b then goto mode_set; /* already in bcd mode? */ fib.mode = "01"b; /* set mode to bcd */ order = "bcd"; /* prepare to make order call */ goto mode_order; %page; com_proc (32): ; /* write tape bcd */ fib.order = write_file; /* indicate write to be done */ goto bcd_common; %page; com_proc (33): ; /* write printer edited */ n = 1; write_prt: ; do i = 1 to n; get_prt_dcw: ; call get_dcw; if where < 0 then goto get_prt_dcw; /* skip dcw ? */ if count > 27 then do; if count = 4096 then goto print_skip; count = 27; end; j = count*4; /* compute length of char */ /* string overlay */ call gcos_write_$bcd_ptr (fibptr, addrel (gseg, where) -> record, "11111100"b); /* put on file */ print_skip: ; if continue then goto get_prt_dcw; end; goto return_stat; /* return good status */ %page; com_proc (34): ; /* write printer edited continuous */ n = op_word.count; /* get record count */ if n = 0 then n = 64; goto write_prt; %page; com_proc (35): ; /* reset status */ goto return_stat; %page; com_proc (36): ; /* request status */ goto return_stat; %page; com_proc (37): ; /* write console */ ascii_index = 0; /* init line index for possible multi-dcw list */ type_loop: ; /* come here for all dcws after the first */ call get_dcw; /* analyze dcw */ if where = -1 then goto type_loop; /* if this dcw said skip data, do it */ workp = addrel (gseg, where); /* get pointer to string to write */ do i = 1 to count*6; if bcd_string (i) = "77"b3 then do; /* escape */ i = i+1; if bcd_string (i) = "77"b3 then do; /* escape */ i = i+1; if bcd_string (i) = "77"b3 then char = "!"; else if bcd_string (i) = "17"b3 then char = "?"; else if bcd_string (i) = "20"b3 then do; substr (ascii_string, ascii_index, 3) = "/b"; ascii_index = ascii_index + 3; goto skip_fill; end; else do; substr (slave_status, 3, 10) = "0011010000"b; /* incorrect format */ goto type_it; /* send the good part */ end; goto end_loop; end; j = fixed (bcd_string (i)); /* get carriage control char */ if j < 32 then unspec (char) = "012"b3; /* put newline in string */ else unspec (char) = "011"b3; /* put tab in string */ goto end_loop; end; if bcd_string (i) = "17"b3 then goto skip_fill; /* if not fill char */ char = xlate (fixed (bcd_string (i))); /* put ascii equivalent in string */ end_loop: ; ascii_index = ascii_index+1; /* increment ascii output string index */ substr (ascii_string, ascii_index, 1) = char; /* stuff char into string */ skip_fill: ; if ascii_index > 129 then goto type_it; /* check for too much output */ end; if continue then goto type_loop; /* if more dcws, go process them */ type_it: ; if ascii_index > 0 then /* type line and test for write-then-read */ call ios_$write_ptr (addr (ascii_string), 0, ascii_index); /* print output */ if op_word.count = 2 then goto bump; /* test for write then read */ goto return_stat; /* go return status */ %page; com_proc (38): ; /* read console */ call get_dcw; /* analyze dcw */ call ios_$read_ptr (addr (ascii_string), 132, i); /* read a line from tty */ i = i - 1; /* strip off NL */ if i > 0 then /* check for null response */ call gcos_cv_ascii_gebcd_ (addr (ascii_string), i, addr (mybuf), i); /* convert to bcd */ /* don't attempt to convert null string */ nelemt = divide (i+5, 6, 17, 0); /* compute word and character residues */ cc_residue = mod (i, 6); call scatter_input (addr (mybuf)); goto return_stat; %page; com_proc (39): ; /* reset status */ goto return_stat; %page; com_proc (40): ; /* request status */ goto return_stat; %page; tape_stat: ; if fib.order = read_file then call adjust_buffer (addrel (gseg, where)); /* adjust fib.buffer on input */ wc_residue = count - nelemt; da_residue = where + nelemt; tape_status: ; if ^substr (unspec (status), 1, 1) /* Are we expected to interpret /* a Multics error code? */ then do; if code = 0 then go to return_stat; /* everything ok */ else call gcos_mme_bort_$system (code, "fc=""^a""", fc); end; substr (slave_status, 1, 12) = "10"b ||substr (unspec (status), 27, 10); /* copy major/minor status */ substr (slave_status, 31, 6) = substr (unspec (rec_ct_residue), 31, 6); /* copy any residue from skip op */ if trace_or_stopsw then call ioa_ ("status:^-^w", slave_status); major_status = substr (unspec (status), 27, 4); /* Get major and minor status */ minor_status = substr (unspec (status), 31, 6); if major_status = "0000"b /* Device Ready */ | major_status = "0100"b /* EOF */ then goto return_stat; if major_status = "1001"b /* Device busy */ & minor_status = "000000"b /* Command Accepted */ then goto return_stat; if ^error_retry then /* if not already attempting error recovery, */ fib.error_retry = fib.error_retry + 1; /* then count tape errors */ call make_stat_ptr; /* we need pointer to status words */ if override = 0 then if substr (sw1, 1, 33) = (33)"1"b then /* error recovery override requested */ override = - (addr (sw1) -> fb35); /* remember type */ if override = 1 /* normal status override */ | override = 5 /* override all except mpc statuses */ then go to return_tape_stat; if major_status = "0001"b /* Device Busy */ | major_status = "0010"b /* Device Attention */ then goto epabort; if major_status = "0101"b /* Command Reject */ then do; if (minor_status & "001000"b) = "001000"b /* Tape on Load Point */ then goto return_tape_stat; else goto epabort; /* Other cmd rejects are illegal */ end; if major_status ^= "0011"b then go to epabort; /* If not Data Alert, abort */ if (minor_status & "000011"b) = "000011"b /* Bit During Erase */ then goto epabort; if override = 3 then goto return_tape_stat; /* override case 2 */ if (minor_status & "000010"b) = "000010"b /* Blank Tape on Read */ | (minor_status & "100000"b) = "100000"b /* End of Tape */ then goto return_tape_stat; if (minor_status & "000001"b) = "000001"b /* Transfer Timing Alert */ | (minor_status & "000100"b) = "000100"b /* Transmission Parity Alert */ then goto epabort; /* We must have a parity error of some type */ if override = 2 then go to return_tape_stat; /* override parity errors */ if ^error_retry then retry_count = 11; error_retry = "1"b; /* set switch to indicate we are processing error */ retry_count = retry_count-1; /* decrement retry attempt count */ if retry_count = 0 then go to epabort; /* abort if we still have */ /* parity error after 10 retries */ slave_status = "400000000000"b3; /* reinitialize status for retry */ if override ^= 4 then /* check for bypass noise check */ if fib.order = read_file then if nelemt < 4 then if nelemt > 0 then /* noise record */ if sc_ga then goto sc_read; else goto issue; call ios_$order (fib.stream, "back", null, status); /* backspace tape */ if fib.order = write_file then if retry_count ^= 10 then /* on a write, retry same spot once */ call ios_$order (fib.stream, "erase", null, status); /* then erase bad spot on tape */ if sc_ga = "0"b then goto issue; else if fib.order = write_file then do; /* write gathered output */ call ios_$write (fib.stream, fib.buffer, 0, posit, nelemt, status); goto tape_status; /* done - now process status */ end; else goto sc_read; epabort: ; call gcos_mme_bort_$system ( gcos_et_$irrecoverable_io_err , "Fatal tape I/O error on file ""^a"". Status = ^w." , fc , slave_status ); %page; return_stat: ; call make_stat_ptr; return_tape_stat: ; sw1 = slave_status; /* move status into slave */ sw2 = "0"b; substr (sw2, 1, 18) = substr (unspec (da_residue), 19, 18); /* and data address residues */ if cc_residue ^= 0 then /* check for character residue */ substr (sw2, 19, 3) = substr (unspec (cc_residue), 34, 3); /* we have some */ substr (sw2, 22, 1) = (fib.order = read_file); /* Last order was a read. */ substr (sw2, 23, 2) = type_dcw; /* Type of last DCW. */ substr (sw2, 25, 12) = substr (unspec (wc_residue), 25, 12); /* return word count */ if trace_or_stopsw then call ioa_ ("status ^w ^w", sw1, sw2); fib.iocount = fib.iocount + 1; /* count I/O requests completed */ if return_word.courtesy_call = 0 then return; /* done if no courtesy call */ if gcos_ext_stat_$save_data.cc then do; /* Already in courtesy call */ /* Check courtesy call queue for overflow */ new_next_avail = mod (courtesy_call.next_avail, hbound (courtesy_call.queue, 1))+1; if courtesy_call.next_out = new_next_avail then call gcos_mme_bort_$system ( gcos_et_$bad_mme_in_cc , "Maximum of ^i simultaneous outstanding courtesy calls has been exceeded." , hbound (courtesy_call.queue, 1)-1 ); /* Add cc address to queue */ courtesy_call.queue (courtesy_call.next_avail) = return_word.courtesy_call; courtesy_call.next_avail = new_next_avail; end; else do; /* Not in courtesy call yet. */ gcos_ext_stat_$save_data.cc = "1"b; /* indicate that courtesy call in progress */ /* Save machine conditions and increment value for return to the caller of */ /* MME GEINOS when the MME GEENDC is executed. Put courtesy call address */ /* in increment to cause control to go to courtesy call routine. */ gcos_ext_stat_$increment_hold = increment; /* save increment */ courtesy_call.hold = courtesy_call_conditions.save_space; /* save MME GEINOS conditions */ i = return_word.courtesy_call; /* get courtesy call address */ j = instruction_counter; /* get loc of MME GEINOS */ increment = i-j-1; /* compute increment value to cause control to go to cc rtn */ end; return; /* go */ %page; mme_endc: entry (mcpp, increment); /* MME GEENDC. Processing consists of restoring The machine conditions that existed at the time of the MME GEINOS */ if gcos_ext_stat_$save_data.cc = "0"b then call gcos_mme_bort_$system ( gcos_et_$geendc_not_in_cc , "A MME GEENDC has been executed outside of a courtesy call." ); mcp = mcpp; if courtesy_call.next_out = courtesy_call.next_avail then do; /* cc queue empty */ gcos_ext_stat_$save_data.cc = "0"b; /* unset courtesy call in progress flag */ increment = gcos_ext_stat_$increment_hold; /* set old increment */ /* Restoration of slave program registers at time of courtesy call */ mc_save_ptr = addr (courtesy_call.hold); mcp -> mc_save_data.pr_regs = mc_save_data.pr_regs; mcp -> mc_save_data.s_regs = mc_save_data.s_regs; mcp -> mc_save_data.ici_regs = mc_save_data.ici_regs; mcp -> mc_save_data.pl_regs = mc_save_data.pl_regs; end; else do; /* cc routine still waiting. */ /* remove cc address from queue */ scup = addr (mc.scu); /* get ptr to scu data */ increment = /* Set increment to return to courtesy code return. */ courtesy_call.queue (courtesy_call.next_out) - instruction_counter -1 ; courtesy_call.next_out = mod (courtesy_call.next_out, hbound (courtesy_call.queue, 1))+1; end; return; %page; inos_trace_filecode: entry (arg_string); /* Set file code values to trace. */ dcl arg_string char(*)parm; do k = 1 by 1; if next_arg (k, argp, arglen) then return; dbs_filecode = "1"b; if (arg = "-pr") | (arg = "-print") then do; /* Display which files being traced. */ if trace_index < 1 then call ioa_ ("No files being traced."); else do i = 1 to trace_index; call ioa_ ("^3i. ^a", i, trace_array (i)); end; end; else do; if trace_index >= hbound (trace_array, 1) then call ioa_ ("ONLY ^i ALLOWED, ^a not entered.", hbound (trace_array, 1), arg); else do; trace_index = trace_index + 1; /* set table size */ trace_array (trace_index) = /* Record file code (lower case) to trace. */ translate ( arg , "abcdefghijklmnopqrstuvwxyz" , "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ); end; end; end; return; %page; adjust_buffer: proc (bp); /* for a fib.buffer just read from tape, determine if Multics has given us one word too much */ dcl bp ptr parm; if nelemt >= 4 then if bcw.blk_size = (nelemt - 2) then if addrel (bp, nelemt - 1) -> word = "0"b then nelemt = nelemt - 1; return; dcl word aligned bit(36) based; dcl 1 bcw aligned based (bp), 2 bsn fixed bin (18)unsigned unal, 2 blk_size fixed bin (18)unsigned unal; end adjust_buffer; %page; check_multirecord_request: proc (m); /* Set "m" to "1"b if the MME GEINOS operation word specifies a multirecord request, and verify that the sum of the DCW list count of words to move and/or skip is consistent with the operation word block count. Set "m" to "0"b if the operation is not multirecord. */ dcl m bit(1)parm; if op_word.ioc_com ^= multirecord_com then do; m = "0"b; return; end; t = 0; /* Total of DCW's words. */ d = dcw_offset; get_ptr: ; if d >= storlimit then /* dcw ptr legal ? */ call gcos_mme_bort_$system ( gcos_et_$invalid_dcw_ptr , "DCW (at ^6.3b oct) is outside slave limits (^6.3b)." , addr (d) -> r18 , addr (storlimit) -> r18 ); dcwptr = addrel (gseg, d); /* get ptr to dcw list */ if dcw.action = TDCW then do; /* Transfer DCW. */ d = dcw.data_addr; /* get new address */ goto get_ptr; /* continue */ end; if dcw.count = 0 then t = t+4096; else t = t+dcw.count; d = d + 1; /* bump to next dcw */ if dcw.action ^= IOTD then goto get_ptr; /* iontp or iotp - check next dcw */ nb = op_word.count; if nb = 0 then nb = 64; /* (gcos convention). */ if t ^= (320*nb) then call gcos_mme_bort_$system ( gcos_et_$bad_multirec , "Multirecord ^[read^;write^] on file ""^a""." ||"^/Requesting ^i blocks (^i words) but ^i specified in" ||" MME GEINOS command (at memory ^6.3b)." , fib.order = read_file , fc , nb , count , op_word.count , scu.ilc ); m = "1"b; return; dcl d fixed bin (24); dcl nb fixed bin (24); dcl t fixed bin (24); end check_multirecord_request; %page; debug_proc: proc (); /* Display filecode debugging. */ if trace_index = 0 then goto trace; do i = 1 to trace_index; if trace_array (i) = fc then goto trace; end; return; trace: ; if dbs_mme_inos_trace then do; call ioa_ ( "^a order ^w ^a (at ^6.3b)" , fc , op_word , type_op (op_word.dev_com) , rel (opptr) ); end; if dbs_mme_inos_stop then do; call ioa_ ("CALLING db:"); call db; end; return; end debug_proc; %page; do_seek: proc; /* position file at fib.current */ if fib.current > fib.last then do; call ios_$seek (fib.stream, "last", "first", fib.current, status); if code ^= 0 then call gcos_mme_bort_$system ( code , "I/O error seek extending file ""^a"" to position ^i." , fc , fib.current ); end; if fib.order = write_file then seek_pointer = "write"; /* seek the write pointer */ else seek_pointer = "read"; /* seek the read pointer */ call ios_$seek (fib.stream, seek_pointer, "first", fib.current, status); /* do seek */ if code ^= 0 then call gcos_mme_bort_$system ( code , "I/O error seeking to ^i on file ""^a""." , fib.current , fc ); return; end do_seek; %page; get_cmd_tbl_entry: proc; if fib.tape /* tape? */ then do; fib.command_count = index.printer - index.tape; /* get command table length */ fib.command_index = index.tape; /* get command table address */ end; else if fib.print /* printer? */ then do; fib.command_count = index.typewriter - index.printer; /* get command table length */ fib.command_index = index.printer; /* get command table address */ end; else if fib.console /* typewriter? */ then do; fib.command_count = index.next - index.typewriter; /* get command table length */ fib.command_index = index.typewriter; /* get command table address */ end; /* If none of the above, the device type is disk (or punch simulated as a disk). */ else do; fib.command_count = index.tape - index.disk; /* get command table length */ fib.command_index = index.disk; /* get command table address */ end; return; end get_cmd_tbl_entry; %page; get_dcw: proc; /* Return "count" with total number of contiguous words specified by DCW's, "where" to the memory location, and "continue" to "1"b if there are more DCW's to be processed. The format of the DCW, and the meanings of the action codes, are described in the comments at the beginning of the external procedure, gcos_mme_inos_. */ count = 0; successive_tdcws = 0; get_ptr: ; if dcw_offset >= storlimit then /* dcw ptr legal ? */ call gcos_mme_bort_$system ( gcos_et_$invalid_dcw_ptr , "DCW (at ^6.3b oct) is outside slave limits (^6.3b)." , addr (dcw_offset) -> r18 , addr (storlimit) -> r18 ); dcwptr = addrel (gseg, dcw_offset); /* get ptr to dcw list */ if trace_or_stopsw then call ioa_ ( "dcw (^[IOTD^;IOTP^;TDCW^;IONTP^]) ^w" , fixed (dcw.action, 2)+1 , dcw ); if dcw.action = TDCW then do; /* Transfer DCW. */ successive_tdcws = successive_tdcws+1; if successive_tdcws>1 then call gcos_mme_bort_$system ( /* 2 successive TDCW's. */ gcos_et_$two_tdcws , "File ""^a""" , fc ); dcw_offset = dcw.data_addr; /* get new address */ goto get_ptr; /* continue */ end; successive_tdcws = 0; /* Reset count. */ if dcw.action = IONTP then do; /* Skip and continue. */ continue = "1"b; /* indicate more to do */ if count ^= 0 then return; /* Exit perform previous DCW's, return to "get_dcw" for skip. */ if dcw.count = 0 then count = 4096; /* grab skip count */ else count = dcw.count; /* (count of 0 = 4096) */ type_dcw = IONTP; dcw_offset = dcw_offset + 1; /* bump over dcw */ where = -1; /* indicate medium skip to caller */ return; /* Exit to process skip. */ end; /* => IOTD or IOTP form of DCW. */ if dcw.count = 0 then holdcount = 4096; /* count of 0 = 4096 */ else holdcount = dcw.count; if count = 0 then /* first dcw processed this call ? */ where = dcw.data_addr; /* yes...get transfer start location */ else if (where + count) ^= dcw.data_addr then do; /* new dcw contiguous ? */ continue = "1"b; /* indicate more dcws to process */ return; /* exit */ end; count = count + holdcount; /* bump total transfer count */ dcw_offset = dcw_offset + 1; /* bump to next dcw */ type_dcw = IOTP; if dcw.action = IOTP then goto get_ptr; /* iotp - check next dcw */ type_dcw = IOTD; continue = "0"b; /* iotd dcw */ return; dcl holdcount fixed bin (24); dcl successive_tdcws fixed bin (24); end get_dcw; %page; init_routine: proc; seeksw, sc_ga, mr, type_dcw = "0"b; unspec (status) = "0"b; slave_status = "400000000000"b3; cc_residue, da_residue, nelemt, override, total_count, wc_residue = 0; argp, dcwptr, ibuffptr, mc_save_ptr, opptr, sbuffptr, sptr, swptr = null (); i = 0; return; end init_routine; %page; make_stat_ptr: proc; /* obtain pointer to status words and check return_word address fields */ if return_word.status_return >= storlimit then /* legal status return */ call gcos_mme_bort_$system ( gcos_et_$bad_status_ret_ptr , "Status return address in I/O sequence is outside slave limits." ); if return_word.courtesy_call >= storlimit then /* legal courtesy call */ call gcos_mme_bort_$system ( gcos_et_$bad_cc_ptr , "Courtesy call address in I/O sequence is outside slave limits." ); if return_word.status_return = 0 /* program doesn't want status */ then do; swptr = addr (scratch_status); /* so fake a return area */ scratch_status = "0"b; end; else swptr = addrel (gseg, return_word.status_return); /* get address of status words */ return; end make_stat_ptr; %page; match_fc: proc () returns (bit (1)); /* Find a file code in the FC table. */ do j = 1 to hbound (save_data.fibs, 1); /* Search file code table for match */ if fct.filecode (j) = fc /* Set MATCH flag if match. */ then return ("1"b); end; return ("0"b); end match_fc; %page; next_dcw_ptr: proc (data_ptr, how_many, continuation); /* Check the DCW list and return the buffer pointer, transfer count, and a flag indicating whether this was the last DCW in the list. If the DCW is a transfer DCW (TDCW), then we go to the next list and start looking there, returning only when we find an I/O DCW. We also check the buffer pointer for legality. If it is out of range, we don't return to the caller, but instead bail out through the MME GEBORT escape-hatch. Ditto for 2 successive TDCWs. */ dcl data_ptr pointer parm; dcl how_many fixed bin (21) parm; dcl continuation bit (1) parm; successive_tdcws = 0; if dcw_offset >= storlimit then call gcos_mme_bort_$system (gcos_et_$invalid_dcw_ptr, "DCW (at ^6.3b oct) is outside slave limits (^6.3b).", addr (dcw_offset) -> r18, addr (storlimit) -> r18); dcwptr = addrel (gseg, dcw_offset); if trace_or_stopsw then call ioa_ ("dcw (^[IOTD^;IOTP^;TDCW^;IONTP^]) ^w", fixed (dcw.action, 2) + 1, dcw); if dcw.action = TDCW then do; dcw_offset = dcw.data_addr; dcwptr = addrel (gseg, dcw_offset); if dcw.action = TDCW then call gcos_mme_bort_$system (gcos_et_$two_tdcws, "While accessing file code ""^a""", fc); end; if dcw.data_addr = 0 /* Gotta provide an address SOMEHOW! */ | dcw.action = IONTP then data_ptr = addr (tapebuffer); /* If nothing else, round-file it. */ else data_ptr = addrel (gseg, data_addr); if dcw.count = 0 then how_many = 4096; /* Can't just do nuthin'. */ else how_many = dcw.count; if how_many > gcos_ext_stat_$tape_buffer_size then call gcos_mme_bort_$system (gcos_et_$request_too_big, "gcos_mme_inos_", "^/Request was ^i, buffer size is ^i words (decimal).", how_many, gcos_ext_stat_$tape_buffer_size); continuation = (dcw.action ^= IOTD); /* Gotta tell him there's more. */ dcw_offset = dcw_offset + 1; /* Bump over this one. */ return; end next_dcw_ptr; %page; process_request: proc; /* Process the GEINOS command. */ opptr = addrel (idptr, -1); /* build pointer to operation word */ sptr = addrel (idptr, 1); /* build pointer to return word */ dcw_offset = id_word.dcwp; /* get dcw list pointer */ if trace_or_stopsw then call debug_proc (); if fib.command_index = 0 /* Get pointer to proper command table entry. */ then call get_cmd_tbl_entry; /* Look up command in the command table specified in fib.command. Table length is specified by fib.command_count. */ do i = fib.command_index to fib.command_index + fib.command_count; if substr (io (i).command, 1, 6) = op_word.dev_com /* are device and */ & substr (io (i).command, 19, 5) = op_word.ioc_com /* IOC command valid? */ then goto com_proc (io (i).process); /* go to processing rtn */ end; /* no...continue */ call gcos_mme_bort_$system (gcos_et_$bad_io_cmnd_file, "This MME GEINOS command is not supported:" ||"^/file code=""^a"", command=^w (^a), memory offset=^6.3b", fc, unspec (op_word), type_op (op_word.dev_com), scu.ilc); end process_request; %page; scatter_input: proc (bp); /* move data from fib.buffer pointed to by bp to (possibly) multiple buffers in slave program, according to dcw list */ dcl bp ptr parm; posit, wc_residue = 0; sc_loop: ; if nelemt < count then do; wc_residue = wc_residue + count - nelemt; if nelemt = 0 then goto sc_res; count = nelemt; end; if where = -1 then goto sc_skip; /* no-transfer and proceed */ ibuffptr = addrel (bp, posit); /* move from our fib.buffer */ sbuffptr = addrel (gseg, where); /* into slave fib.buffer */ slave_buffer = internal_buffer; sc_skip: ; nelemt = nelemt - count; posit = posit + count; da_residue = where + count; sc_res: ; if continue = "0"b then return; call get_dcw; goto sc_loop; end scatter_input; %page; type_op: proc (op)returns (char (*)); /* Return string specifying type of mme inos operation word. */ dcl op bit(6)unal parm; do i = 1 to hbound (device_cmd, 1); if op = device_cmd (i) then return (rtrim (name_cmd (i))); end; return ("UNKNOWN DEVICE COMMAND"); dcl i fixed bin (24); dcl 1 operation_word_values (27)static int options(constant) ,2 device_cmd bit(6)init( "00"b3 /* Request Status */ , "03"b3 /* Read Typewriter */ , "04"b3 /* Read Tape Decimal */ , "05"b3 /* Read Tape Binary */ , "13"b3 /* Write (then Read) Typewriter */ , "14"b3 /* Write Tape Decimal */ , "15"b3 /* Write Tape Binary */ , "25"b3 /* Read */ , "30"b3 /* Write Printer Edited */ , "31"b3 /* Write */ , "34"b3 /* Seek */ , "40"b3 /* Reset Status */ , "41"b3 /* Set 6250 Density */ , "42"b3 /* Set 800 Density */ , "43"b3 /* Set 556 Density */ , "44"b3 /* Forward Space Record */ , "45"b3 /* Forward Space to Filemark */ , "46"b3 /* Backspace Record */ , "47"b3 /* Backspace to Filemark */ , "54"b3 /* Erase */ , "55"b3 /* Write EOF */ , "60"b3 /* Set High Density */ , "61"b3 /* Set Low Density */ , "64"b3 /* Set 200 Density */ , "65"b3 /* Set 1600 Density */ , "70"b3 /* Rewind */ , "72"b3 /* Rewind and Unload */ ) ,2 name_cmd char(28)init( /* 00"b3*/ "Request Status" , /* 03"b3*/ "Read Typewriter" , /* 04"b3*/ "Read Tape Decimal" , /* 05"b3*/ "Read Tape Binary" , /* 13"b3*/ "Write (then Read) Typewriter" , /* 14"b3*/ "Write Tape Decimal" , /* 15"b3*/ "Write Tape Binary" , /* 25"b3*/ "Read" , /* 30"b3*/ "Write Printer Edited" , /* 31"b3*/ "Write" , /* 34"b3*/ "Seek" , /* 40"b3*/ "Reset Status" , /* 41"b3*/ "Set 6250 Density" , /* 42"b3*/ "Set 800 Density" , /* 43"b3*/ "Set 556 Density" , /* 44"b3*/ "Forward Space Record" , /* 45"b3*/ "Forward Space to Filemark" , /* 46"b3*/ "Backspace Record" , /* 47"b3*/ "Backspace to Filemark" , /* 54"b3*/ "Erase" , /* 55"b3*/ "Write EOF" , /* 60"b3*/ "Set High Density" , /* 61"b3*/ "Set Low Density" , /* 64"b3*/ "Set 200 Density" , /* 65"b3*/ "Set 1600 Density" , /* 70"b3*/ "Rewind" , /* 72"b3*/ "Rewind and Unload" ); end type_op; %page; %include gcos_next_arg; %page; /* Variables for gcos_mme_inos_: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl addrel builtin; dcl arg char(arglen) based (argp); dcl arglen fixed bin (24); dcl argp ptr; dcl ascii_index fixed bin (21); dcl ascii_string char(132); dcl bcd_string (count*6) bit(6) unal based (workp); dcl bksp_sw bit(1); dcl cc_residue fixed bin (24); dcl char char aligned; dcl continue bit(1) /* parameter from get_dcw */; dcl count fixed bin (21); dcl da_residue fixed bin (24); dcl db ext entry; dcl dcwptr ptr; dcl dcw_offset fixed bin (24) /* slave offset of current dcw */; dcl default_high char(5) int static options (constant) init ("d1600") /* system default high density */; dcl default_low char(4) int static options (constant) init ("d556") /* system default low density */; dcl density_history bit(2) aligned; dcl divide builtin; dcl error_retry bit(1) aligned /* 1 = processing parity error */; dcl fb35 fixed bin (35) based; dcl fc char(2) /* file code from file control block */; dcl fixed builtin; dcl gcos_cv_ascii_gebcd_ ext entry (ptr, fixed bin (21), ptr, fixed bin (21)); dcl gcos_et_$access_beyond_file fixed bin (35) ext; dcl gcos_et_$bad_cc_ptr fixed bin (35) ext; dcl gcos_et_$bad_io_cmnd_file fixed bin (35) ext; dcl gcos_et_$bad_mme_in_cc fixed bin (35) ext; dcl gcos_et_$bad_multirec fixed bin (35) ext static; dcl gcos_et_$bad_seek_dcw fixed bin (35) ext; dcl gcos_et_$bad_status_ret_ptr fixed bin (35) ext; dcl gcos_et_$fc_not_defined fixed bin (35) ext; dcl gcos_et_$geendc_not_in_cc fixed bin (35) ext; dcl gcos_et_$impermissible_perm_read fixed bin (35) ext; dcl gcos_et_$impermissible_perm_write fixed bin (35) ext; dcl gcos_et_$invalid_dcw_ptr fixed bin (35) ext; dcl gcos_et_$invalid_file_ptr fixed bin (35) ext; dcl gcos_et_$irrecoverable_io_err fixed bin (35) ext; dcl gcos_et_$need_multirec fixed bin (35) ext static; dcl gcos_et_$request_too_big fixed bin (35) ext static; dcl gcos_et_$two_tdcws fixed bin (35) ext static; dcl gcos_mme_bort_$system ext entry options (variable); dcl gcos_write_$bcd_ptr ext entry (ptr, char(*), bit(8)); dcl gseg ptr; dcl hbound builtin; dcl i fixed bin (21); dcl ibuffptr ptr; dcl idptr ptr; dcl instruction_counter fixed bin (18)unsigned unal based(addr(scu.ilc)); dcl internal_buffer (count) fixed bin (35) based (ibuffptr); dcl ioa_ ext entry options (variable); dcl j fixed bin (24); dcl k fixed bin (24); dcl major_status bit (4) aligned; dcl max builtin; dcl mc_save_ptr ptr; dcl minor_status bit (6) aligned; dcl mod builtin; dcl more_dcws bit (1); dcl mr bit(1) /* "1"b => multirecord request. */; dcl multirecord_com bit(5)static int options(constant)init("00011"b); dcl mybuf (160) bit(6) unal; dcl n fixed bin (24); dcl nelemt fixed bin (21); dcl new_next_avail fixed bin (24); dcl null builtin; dcl opptr ptr; dcl order char(20) /* holds order type */; dcl output_ptr pointer; dcl override fixed bin (24); dcl posit fixed bin (21); dcl record char(j) based /* overlay for bcd record */; dcl rec_ct_residue fixed bin (24)/* holds no of unskipped records */; dcl rel builtin; dcl retry_count fixed bin (24)/* number of attempts left in which */; dcl sbuffptr ptr; dcl scratch_status bit(72) aligned /* temp */; dcl sc_ga bit(1); dcl seeksw bit(1) /* sw controlling disk or drum seeks */; dcl seek_address fixed bin (24)based /* user seek address for disk or drum */; dcl seek_pointer char(5) /* holds name of pointer to seek */; dcl slave_buffer (count) fixed bin (35) based (sbuffptr); dcl slave_status bit(36) aligned; dcl sptr ptr; dcl storlimit fixed bin (19) /* slave core boundary */; dcl substr builtin; dcl successive_tdcws fixed bin; dcl swptr ptr; dcl tapebuffer (4096) bit(36) aligned; dcl total_count fixed bin (24); dcl total_read fixed bin (36); dcl trace_array (20) char(4) int static; dcl trace_index fixed bin (24) static int init(0); dcl trace_or_stopsw bit(1) static int init ("0"b); dcl transfer_count fixed bin (21); dcl translate builtin; dcl type_dcw bit(2); dcl unspec builtin; dcl wc_residue fixed bin (24); dcl where fixed bin (21); dcl workp ptr; dcl z320 (320)bit(36)static int options(constant)init((320)(36)"0"b); dcl 1 courtesy_call_conditions like save_machine_conditions based (mcp); dcl ( IOTD init("00"b) , IOTP init("01"b) , TDCW init("10"b) , IONTP init("11"b) ) bit(2)static internal options(constant); dcl 1 w aligned based , 2 l18 bit(18)unal , 2 r18 bit(18)unal ; %page; dcl 1 op_word aligned based (opptr), /* model of operation word */ 2 dev_com bit(6) unal, /* device command */ 2 zero1 bit(12) unal, /* zeros */ 2 ioc_com bit(5) unal, /* ioc command */ 2 zero2 bit(1) unal, /* zero */ 2 control bit(6) unal, /* control */ 2 count fixed bin (6)unsigned unal /* count */; dcl 1 id_word aligned based (idptr), /* model of identification word */ 2 filep fixed bin (18)unsigned unal, /* file control block pointer */ 2 dcwp fixed bin (18)unsigned unal /* dcw list pointer */; dcl 1 file_code_word aligned based (workp), /* model of file code word */ 2 fill bit(24) unal, 2 fcode bit(12) unal /* file code in bcd */; dcl 1 return_word aligned based (sptr), /* model of status return word */ 2 status_return fixed bin (18)unsigned unal, /* pointer to return words */ 2 courtesy_call fixed bin (18)unsigned unal /* pointer to courtesy call rtn */; dcl 1 stat_words aligned based (swptr), /* model of status words */ 2 sw1 bit(36) aligned, /* word 1 */ 2 sw2 bit(36) aligned /* word 2 */; dcl 1 dcw aligned based (dcwptr), /* dcw model */ 2 data_addr fixed bin (18)unsigned unal, /* data address */ 2 zero bit(3) unal, /* fill */ 2 chr_tally bit(1) unal, /* character tally indicator. */ 2 action bit(2) unal, /* action */ 2 count fixed bin (12)unsigned unal /* word count for transfer */; dcl 1 mc_save_data based (mc_save_ptr), (2 pr_regs (16), 2 s_regs (8), 2 scu_0_3 (4), 2 ici_regs, 2 scu_5_7 (3), 2 software_data (8), 2 pl_regs (8)) fixed bin (35); %page; /* I/O Simulation Tables */ /* Command Tables: */ /* */ /* The command tables contain the possible legal commands for each device */ /* type. Each command table entry contains the command and the command */ /* processor address. */ /* Table of indices into io_commands list to separate MME GEINOS command word sublists for various devices. */ dcl 1 index static int options(constant), 2 ( disk init(01), tape init(11), printer init(36), typewriter init(40), next init(44) ) fixed bin (24); dcl 1 io (43) internal static options (constant), 2 command bit (36) init ( /* Disk commands: */ /* 1 */ "340000000002"b3 /* 34 - seek disk address */ , /* 2 */ "250000002400"b3 /* 25 - read disk continuous */ , /* 3 */ "250000060000"b3 /* 25 - multirecord disk read. */ , /* 4 */ "310000002400"b3 /* 31 - write disk continuous */ , /* 5 */ "310000060000"b3 /* 31 - multirecord disk write. */ , /* 6 */ "700000020001"b3 /* 70 - rewind */ , /* 7 */ "460000020001"b3 /* 46 - backspace record(s) */ , /* 8 */ "440000020001"b3 /* 44 - forward space record(s) */ , /* 9 */ "400000020001"b3 /* 40 - reset status */ , /* 10 */ "000000020001"b3 /* 00 - request status */ /* Tape commands: */ , /* 11 */ "050000000000"b3 /* 05 - read tape binary */ , /* 12 */ "150000000000"b3 /* 15 - write tape binary */ , /* 13 */ "030000000000"b3 /* 03 - read tape nine */ , /* 14 */ "130000000000"b3 /* 13 - write tape nine */ , /* 15 */ "700000020001"b3 /* 70 - rewind */ , /* 16 */ "550000020001"b3 /* 55 - write eof */ , /* 17 */ "450000020001"b3 /* 45 - forward space to file mark */ , /* 18 */ "470000020001"b3 /* 47 - backspace to file mark */ , /* 19 */ "440000020001"b3 /* 44 - forward space one record */ , /* 20 */ "460000020001"b3 /* 46 - backspace one record */ , /* 21 */ "150000100000"b3 /* 15 - write file mark */ , /* 22 */ "140000100000"b3 /* 14 - write file mark decimal */ , /* 23 */ "540000020001"b3 /* 54 - erase */ , /* 24 */ "720000020001"b3 /* 72 - rewind and unload */ , /* 25 */ "600000020001"b3 /* 60 - set high density */ , /* 26 */ "610000020001"b3 /* 61 - set low density */ , /* 27 */ "640000020001"b3 /* 64 - set 200 density */ , /* 28 */ "430000020001"b3 /* 43 - set 556 density */ , /* 29 */ "420000020001"b3 /* 42 - set 800 density */ , /* 30 */ "650000020001"b3 /* 65 - set 1600 density */ , /* 31 */ "410000020001"b3 /* 41 - set 6520 density */ , /* 32 */ "400000020001"b3 /* 40 - reset status */ , /* 33 */ "000000020001"b3 /* 00 - request status */ , /* 34 */ "040000000000"b3 /* 04 - read tape bcd */ , /* 35 */ "140000000000"b3 /* 14 - write tape bcd */ /* Printer commands: */ , /* 36 */ "300000000000"b3 /* 30 - write printer edited */ , /* 37 */ "300000060001"b3 /* 30 - write printer edited continuous */ , /* 38 */ "400000020001"b3 /* 40 - reset status */ , /* 39 */ "000000020001"b3 /* 00 - request status */ /* Typewriter commands: */ , /* 40 */ "130000000000"b3 /* 13 - write or write then read */ , /* 41 */ "030000000000"b3 /* 03 - read */ , /* 42 */ "400000020001"b3 /* 40 - reset status */ , /* 43 */ "000000020001"b3 /* 00 - request status */ ), /* Corresponding indices to labeled array location to processing routine. */ 2 process fixed bin (24)init ( /* Disk commands: */ 1 /* 34 - seek disk address */ , 2 /* 25 - read disk continuous */ , 2 /* 25 - multirecord disk read */ , 3 /* 31 - write disk continuous */ , 3 /* 31 - multirecord disk write. */ , 4 /* 70 - rewind */ , 5 /* 46 - backspace record(s) */ , 6 /* 44 - forward space record(s) */ , 7 /* 40 - reset status */ , 8 /* 00 - request status */ /* Tape commands: */ , 9 /* 05 - read tape binary */ , 10 /* 15 - write tape binary */ , 11 /* 03 - read tape nine */ , 12 /* 13 - write tape nine */ , 13 /* 70 - rewind */ , 14 /* 55 - write eof */ , 15 /* 45 - forward space to file mark */ , 16 /* 47 - backspace to file mark */ , 17 /* 44 - forward space one record */ , 18 /* 46 - backspace one record */ , 19 /* 15 - write file mark */ , 20 /* 14 - write file mark decimal */ , 21 /* 54 - erase */ , 22 /* 72 - rewind and unload */ , 23 /* 60 - set high density */ , 24 /* 61 - set low density */ , 25 /* 64 - set 200 density */ , 26 /* 43 - set 556 density */ , 27 /* 42 - set 800 density */ , 28 /* 65 - set 1600 density */ , 41 /* 41 - set 6520 density */ , 29 /* 40 - reset status */ , 30 /* 00 - request status */ , 31 /* 04 - read tape bcd */ , 32 /* 14 - write tape bcd */ /* Printer commands: */ , 33 /* 30 - write printer edited */ , 34 /* 30 - write printer edited continuous */ , 35 /* 40 - reset status */ , 36 /* 00 - request status */ /* Typewriter commands: */ , 37 /* 13 - write or write then read */ , 38 /* 03 - read */ , 39 /* 40 - reset status */ , 40 /* 00 - request status */ ); %page; %include gcos_dcl_ios_; %page; %include gcos_xlate_bcd_ascii_; %page; %include gcos_ext_stat_; %page; %include gcos_dbs_names; end gcos_mme_inos_;  gcos_mme_laps_.pl1 09/09/83 1404.1rew 09/09/83 1007.6 15642 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ------------------------------------------------------------------- */ /* */ /* Simulation of GCOS mme which returns CPU time in 64ths of a */ /* milli-second. The init_timer entry is called by */ /* gcos_run_activity at the beginning of each activity to */ /* remember the CPU timer at the beginning of the activity */ /* */ /* Written by Peter M. Haber 8/16/72 */ /* Modified by M. R. Jordan, October 1977 */ /* */ /* ------------------------------------------------------------------- */ gcos_mme_laps_: proc (mcp, increment); dcl binary builtin; dcl bit builtin; dcl cpu_time fixed bin(71) aligned; /* cpu time since activity started */ dcl divide builtin; dcl increment fixed bin(24)aligned; /* number of paramenter words to skip over */ dcl virtual_cpu_time_ ext entry returns (fixed bin(71) aligned); increment = 0; /* no parameter words to skip over */ cpu_time = virtual_cpu_time_ () - gcos_ext_stat_$initial_cpu_time; /* get cpu time for activity */ mc.regs.q = bit (binary (divide (cpu_time, 1000, 35, 0)*64, 36), 36); /* put time in q register in 64ths of a second */ return; %include gcos_ext_stat_; end gcos_mme_laps_;  gcos_mme_lbar_.pl1 09/09/83 1404.1rew 09/09/83 1007.6 37719 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_mme_lbar_: proc (mcpp, incr); /* Process MME GELBAR for gcos batch simulator. (See DD19C, Rev. 0, GENERAL COMPREHENSIVE OPERATING SUPERVISOR, page 4-20 for description of function). Author: Dave Ward 09/10/80 [my 1st mme handler] */ dcl incr fixed bin(24)parm /* (output) number parameter words following mme. */; dcl mcpp ptr parm /* (input) pointer to machine conditions structure. */; mcp = mcpp; /* Assign to local variable (for execution efficiency). */ gseg = gcos_ext_stat_$gcos_slave_area_seg; /* Set pointer to gcos user's slave prefix area. */ lbar_parm_ptr = addrel (gseg, a_reg.loc1); /* Get pointer to LOC1. */ w21 = mc.regs.q; /* Save Q register. */ w22 = "0"b; /* MORE timer register. */ string (w31) = unspec (lbar_parm.bar); /* Save new BAR register value. */ w31.b19 = "0"b; string (w31.b30_35) = "0"b; mr = gcos_ext_stat_$mme_rtrn; /* Save current location to return after MME. */ gcos_ext_stat_$mme_rtrn = to_me; /* Reset return to return to me. */ bb = "0"b; /* Running in bar mode. */ call gcos_get_bar_ (old_bar); call gcos_set_slave_ ( (lbar_parm.bar) /* New BAR value. */ , addrel (gseg, lbar_parm.ic) /* Pointer to gcos code to execute. */ , bb /* ^bar bit. */ ); to_me: ; /* Come here when gcos caller concludes (MME GEFINI). */ call gcos_restore_regs_ (addrel (gseg, lbar_parm.loc2)); gcos_ext_stat_$mme_rtrn = mr; /* Reset to label in effect at entry to procedure. */ if w23 = "0"b then /* Terminate gcos user. */ goto mr; w22 = lbar_parm.ic || lbar_parm.i; w21fb = w21fb - 0; /* MORE */ if fault | timer_runout then do; dcl (fault,timer_runout) bit(1)static int options(constant)init("0"b); w31.b19 = "1"b; string (w31.b30_35) = "77"b3; end; bro = (18)"0"b||substr (old_bar, 1, 18); /* BAR restore value (right justified). */ /* Continue gcos caller (at his slave prefix cell 23-octal). */ call gcos_set_slave_ ( bar_reset , addrel (gseg, "000023"b3) , bb ); /* Variables for gcos_mme_lbar_: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl addrel builtin; dcl bar_reset fixed bin(18); dcl bb bit(1)aligned; dcl bro bit(36)based(addr(bar_reset)); dcl gcos_get_bar_ entry(bit(36)); dcl gcos_restore_regs_ entry(ptr); dcl gcos_set_slave_ entry(fixed bin(18),ptr,bit(1)aligned); dcl gseg ptr; dcl lbar_parm_ptr ptr; dcl mr label auto variable; dcl old_bar bit(36); dcl reg_move bit (36 * 8) based aligned; dcl unspec builtin; dcl w21fb fixed bin(35)based(addr(spp.w21)); dcl 1 a_reg aligned based(addr(mc.regs.a)) , 2 loc1 fixed bin(18)unsigned unal , 2 not_used bit(18)unal; dcl 1 lbar_parm aligned based(lbar_parm_ptr) , 2 bar fixed bin(18)unsigned unal /* new bar value. */ , 2 loc2 fixed bin(18)unsigned unal /* offset to program registers storage. */ , 2 ic bit(18)unal /* new IC offset (from new bar). */ , 2 i bit(18)unal /* indicator register. */ ; dcl 1 bar_reg aligned based(addr(lbar_parm.bar)) , 2 base fixed bin(9)unsigned unal , 2 bound fixed bin(9)unsigned unal ; /* Gcos memory slave program prefix (at BAR.BASE) */ dcl 1 spp aligned based(gseg) , 3 w00_20 (00:16)bit(36) , 3 w21 bit(36) , 3 w22 bit(36) , 3 w23 bit(36) , 3 w24_30 (20:24)bit(36) , 3 w31 , 4 b00_18 (00:18)bit(1)unal , 4 b19 bit(1)unal , 4 b20_29 (20:29)bit(1)unal , 4 b30_35 (30:35)bit(1)unal , 3 w32_100 (26:64)bit(36) ; %include gcos_ext_stat_; end gcos_mme_lbar_;  gcos_mme_loop_.pl1 09/09/83 1404.1rew 09/09/83 1007.6 17190 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* *************************************************************************** *************************************************************************** * * * * * mme geloop * * * * * * This mme is not implemented. It is ignored. * * * * * * Written by R. H. Morrison February 22, 1974 * * Modified by R.H. Morrison April 4, 1974 * * Modified by M. R. Jordan, October 1977 * * * * *************************************************************************** *************************************************************************** */ gcos_mme_loop_: proc (faultp, increment); dcl faultp pointer; /* unused input parameter */ dcl increment fixed bin(24); /* number of mme parameters */ increment = 0; /* one mme parameter */ return; %include gcos_ext_stat_; end gcos_mme_loop_;  gcos_mme_more_.pl1 09/09/83 1404.1rew 09/09/83 1007.6 105273 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_mme_more_: proc (mcp, increment); /* * MME GEMORE is used to obtain an additional tape handler, additional * links (3840 word blocks), more memory, or to allow allocation of * new files. The user must be prepared to accept a denial return * if the request cannot be satisified. * * * CALLING SEQUENCE * * MME GEMORE * ZERO A,B * denial return * success return * * C(Q) 0-17 ptr. to cfdesc (A=4-6) or random indicator (A=2) * C(Q) 18-23 requested permissions (A=4-6) * C(Q) 24-35 file code (A=1-6) * * A = 0 for more memory B = no of 1K blocks wanted * A = 1 for 7 track tape B = tape status * A = 2 for new links or file B = no of links desired * A = 3 for 9 track tape B = tape status * A = 4 for cataloged files B = ptr. to 355 wd. buffer * accessed in created * mode. * A = 5 for cataloged files B = ptr. to 355 wd. buffer * accessed as random. * A = 6 for cataloged files B = ptr. to 355 wd. buffer * accessed as sequential. * * Author: DICK SNYDER JUNE 8, 1971 Change: T. CASEY OCTOBER 1973 Change: D. KAYDEN APRIL 1974, JULY 1974, JANUARY 1975 Change: M. R. Jordan, January 1977 Change: Dave Ward 07/28/81 A=7 case (By Dick Hemes) */ /* Initialize all needed values and verify the action code (A) to ensure that this is a good call. */ gseg_ptr = gcos_ext_stat_$gcos_slave_area_seg; increment = 2; storage_limit = gcos_ext_stat_$storage_limit; scup = addr (mc.scu); if fixed (scu.ilc, 18)+1 >= storage_limit then call gcos_mme_bort_$system (gcos_et_$bad_mme_param, "MME GEMORE parameter word is outside slave limits."); param_ptr = addrel (gseg_ptr, fixed (scu.ilc, 18)+1); A = param.a; B = param.b; if A > 7 then do; ecode = gcos_et_$bad_more_param; abort: call gcos_mme_bort_$system (ecode); end; %page; /* Now that we are sure this is a somewhat valid request (i.e. 0<=A<=7), let's see if its for memory. If so, then process the request. At this point: A =0 B number of 1K (1024 word) blocks of memory requested (max is 64K) */ if A = 0 then do; if B = 0 then return ; if B > 64 then goto failure ; if gcos_ext_stat_$storage_limit+B*1024 > gcos_ext_stat_$max_mem then go to failure; gcos_ext_stat_$storage_limit = gcos_ext_stat_$storage_limit+B*1024; call gcos_set_slave_$load_bar (divide (gcos_ext_stat_$storage_limit, 512, 17, 0)); call hcs_$set_max_length (string (gcos_ext_stat_$pdir), "gcos_slave_area_seg", gcos_ext_stat_$storage_limit, code); if code ^= 0 then call gcos_error_ (code); return; end; %page; /* This request is for some file (i.e. not memory). Lets get the file code and see if the file exists already. When we know this we can decide what to do to process the request. */ if substr (mc.regs.q, 25, 12) = (12)"0"b then do ; ecode = gcos_et_$zero_fc_to_more; goto abort; end ; if A = 7 then goto failure; /* => file catenation. Treat as EOF. */ substr (fc, 1, 1) = xlate (fixed (substr (mc.regs.q, 25, 6), 6)); substr (fc, 2, 1) = xlate (fixed (substr (mc.regs.q, 31, 6), 6)); do fct_index = 1 to hbound (save_data.fibs, 1); if fct.filecode (fct_index) = fc then go to hit; end; goto action (A); %page; /* Process a request for accessing an existing permanent file. At this point: A =4 - access the file in whichever mode it was created A =5 - access the file as a random file A =6 - access the file as a sequentail file B location of a 355 word buffer for FMS C(Q) 0-17 location of catalog/filename block C(Q) 18-23 requested permisssions C(Q) 24-35 file code (guaranteed unused at this point) */ action (4): action (5): action (6): /* ?? */ cfdesc_loc = fixed (substr (mc.regs.q, 1, 18), 18); if cfdesc_loc >= storage_limit then call gcos_mme_bort_$system (gcos_et_$bad_mme_param, "Catalog/filename description is outside slave limits."); do word_index = cfdesc_loc+4 to min (cfdesc_loc+38, storage_limit-1) by 4; if addrel (gseg_ptr, word_index) -> bit36 = (36)"1"b then goto fence_hit; end; call gcos_mme_bort_$system (gcos_et_$bad_mme_param, "Catalog/filename description fence not found."); fence_hit: ; if B < 64 | B +354 >= storage_limit then call gcos_mme_bort_$system (gcos_et_$bad_mme_param, "FMS buffer location < 64 or outside slave limits."); /* ?? */ call gcos_build_pathname_ (addrel (gseg_ptr, cfdesc_loc), addrel (gseg_ptr, B), dir_name, entry_name, st); if substr (st, 2, 11) ^= (11)"0"b then do; fms_failure: ; mc.regs.q = substr (st, 1, 36); goto failure; end; call gcos_verify_access_ (dir_name, entry_name, substr (mc.regs.q, 19, 6), addrel (gseg_ptr, B), st); if substr (st, 2, 11) ^= (11)"0"b then goto fms_failure; /* Open the file with no LUD and fill in the appropriate fib entries. */ call gcos_open_file_ (fc, "", fibptr, ""b) ; if rtrim (dir_name) = ">" then fib.pathnm = ">" || entry_name; else fib.pathnm = rtrim (dir_name) || ">" || entry_name; fib.read = substr (mcp -> mc.regs.q, 19, 1); fib.write = substr (mcp -> mc.regs.q, 20, 1); fib.perm = "1"b; if A = 5 then fib.type = "1"b ; goto attach; %page; /* Process a request for an additional tape drive. At this point: A =1 for 7 track; =3 for 9 track B if non-zero then a tape must be mounted (=0 use any scratch) C(Q) 0-17 location of reel # word (only if non-zero) C(Q) 20-23 density specification (see fib declaration for possible values) C(Q) 24-35 file code (guaranteed unused at this point) */ action (1): action (3): /* Open the file with no LUD. */ /* should make sure a handler is available first */ call gcos_open_file_ (fc, "", fibptr, "0"b) ; /* Now that we have a drive, set up the fib. */ fib.tape = "1"b; if A = 1 then fib.tracks = "01"b; else fib.tracks = "10"b; reel_no_loc = fixed (substr (mc.regs.q, 1, 18), 18); B = fixed (substr (addr (B) -> bit36, 36, 1), 1); if B ^= 0 & reel_no_loc ^= 0 then fib.serial_no = addrel (gseg_ptr, reel_no_loc) -> bit30; else fib.serial_no = (5)"001001"b; fib.tape_name = (12)"010000"b; fib.density = substr (mc.regs.q, 21, 4); if fib.density = "0111"b then fib.density = "0000"b; goto attach ; %page; /* Process a request for a _n_e_w temporary mass storage file. Set access for both read and write and get the size from the mme calling sequence. At this point: A =2 B size of requested file in links (if 0 then request is for a null file) C(Q) 17 random file indicator (actually if C(Q)0-17 ^= 0 then random) C(Q) 24-35 file code (guaranteed unused at this point) */ action (2): /* Open the file with no LUD and fill in the fib. */ call gcos_open_file_ (fc, "", fibptr, "0"b) ; fib.read, fib.write = "1"b; fib.type = (substr (mc.regs.q, 1, 18) ^= (18)"0"b); fib.size = B*3840; if fib.size = 0 then fib.null = "1"b ; /* We now have the file ready and the fib filled in so lets attach it. */ attach: ; call gcos_attach_file_ (fibptr); return; /* At this point we have failed to satisfy the users _v_a_l_i_d request. We will now return to the denial return point. */ failure: ; increment = 1 ; return ; %page; /* Process a request for more space on an _e_x_i_s_t_i_n_g mass storage file. Make sure that this is a request for a mass storage file. If it is, then get the specified number of links. If the number specified is 0 and the file is a permanent file then we will choose the growth rate. At this point: A any value 1-6 (only 2 is valid) B # of links to be added (if 0 & file is permanent then use 1 llink) C(Q) 24-35 file code (guaranteed to be in use at this point) */ hit: ; /* If this is not a mass storage request (A=2) then complain. */ if A ^= 2 then do ; ecode = gcos_et_$duplicate_file_more; goto abort ; end; /* We cannot grow a SYSOUT file. */ if fct.sysout (fct_index) then do; ecode = gcos_et_$duplicate_file_more; goto abort; end ; /* Nor can we grow files assigned to printer, tape or the operators console. */ fibptr = fct.fibptr (fct_index); if fib.print | fib.console | fib.tape then do; ecode = gcos_et_$not_mass_store_more; go to abort; end; /* A growth request for a null file is always successful. */ if fib.null then return ; /* Calculate the new file size. */ num_words = B*3840; if num_words = 0 then if fib.perm then num_words = 320; fib.size = fib.size+num_words; return; %page; /* Variables for gcos_mme_more_: */ /* IDENTIFIER ATTRIBUTES */ dcl A fixed bin(18) /* A field from MME sequence */; dcl addr builtin; dcl addrel builtin; dcl B fixed bin(18) /* B field from MME sequence */; dcl bit30 bit(30)based; dcl bit36 bit(36) aligned based /* General purpose bit string. */; dcl cfdesc_loc fixed bin(18); dcl code fixed bin(35) based (addr (st)); dcl dir_name char(168) /* the directory name for a prmfl request */; dcl divide builtin; dcl ecode fixed bin(35); dcl entry_name char(32) /* the entry name for a prmfl request */; dcl fc char(2) /* the file code if this is a file request */; dcl fct_index fixed bin(24) /* index used in searching the file code table */; dcl fixed builtin; dcl gcos_attach_file_ entry (ptr); dcl gcos_build_pathname_ entry (ptr, ptr, char(*), char(*), bit(72) aligned); dcl gcos_error_ entry options (variable); dcl gcos_et_$bad_mme_param fixed bin(35) ext; dcl gcos_et_$bad_more_param fixed bin(35) ext; dcl gcos_et_$duplicate_file_more fixed bin(35) ext; dcl gcos_et_$not_mass_store_more fixed bin(35) ext; dcl gcos_et_$zero_fc_to_more fixed bin(35) ext; dcl gcos_mme_bort_$system entry options (variable); dcl gcos_open_file_ entry (char(*), char(*), ptr, bit(1)); dcl gcos_set_slave_$load_bar entry (fixed bin(17)); dcl gcos_verify_access_ entry (char(*), char(*), bit(6), ptr, bit(72) aligned); dcl gseg_ptr ptr; dcl hcs_$set_max_length entry (char(*), char(*), fixed bin(19), fixed bin(35)); dcl increment fixed bin(18) /* IC increment for return to slave activity */; dcl index builtin; dcl num_words fixed bin(35); dcl param_ptr ptr /* ptr to word after MME (for A B fields) */; dcl reel_no_loc fixed bin(18) /* location of the reel # word in the gcos_slave_area_seg */; dcl rtrim builtin; dcl st bit(72) aligned /* status return string */; dcl storage_limit fixed bin(18); dcl string builtin; dcl substr builtin; dcl word_index fixed bin(18); dcl 1 param aligned based (param_ptr), /* structure for accessing the A B fields */ 2 a fixed bin(18)unsigned unal, 2 b fixed bin(18)unsigned unal; %page; %include gcos_ext_stat_; %page; %include gcos_xlate_bcd_ascii_; end gcos_mme_more_;  gcos_mme_mrel_.pl1 09/09/83 1404.1rew 09/09/83 1007.6 44676 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ******************************************************************************************** ******************************************************************************************** * * * M M E G E M R E L * * * MME GEMREL is used to deallocate a specified amount of memory from a requesting * program's total assigned memory. Actual memory deallocation is in multiples of 1024 * words. Memory may be released from either the upper bound or the lower bound or * both. Lower memory release will cause address relocation. * * CALLING SEQUENCE: * * MME GEMREL * * C(A) 0-17 return address relative to the new base address * C(Q) 0-17 number of words of lower memory to release * C(Q) 18-35 number of words of upper memory to release * * * WRITTEN BY DICK SNYDER, NOVEMBER 18,1970 * MODIFIED BY T. CASEY, OCTOBER 1973 * MODIFIED BY D. KAYDEN, MAY 1974 * Modified by M. R. Jordan, January 1977 * * ******************************************************************************************** ******************************************************************************************** */ gcos_mme_mrel_: procedure (mcp, increment); dcl addr builtin; dcl addrel builtin; dcl code fixed bin(35); /* error code from called support routines */ dcl divide builtin; dcl fixed builtin; dcl gcos_error_ entry options (variable); dcl gcos_et_$bad_mme_addr fixed bin(35) ext; dcl gcos_mme_bort_$system entry options (variable); dcl gcos_set_slave_$load_bar entry (fixed bin(18)); dcl gseg char (length_in_bytes) based; /* gcos_slave are segment mask */ dcl hcs_$set_max_length_seg entry (ptr, fixed bin(19), fixed bin(35)); dcl hcs_$truncate_seg entry (ptr, fixed bin(19), fixed bin(35)); dcl increment fixed bin(18); /* number of arguments to this MME */ dcl length_in_bytes fixed bin(20); /* length of the GCOS job segment in bytes */ dcl lower fixed bin(18); /* number of words to release on the low end */ dcl new_storage_limit fixed bin(18); /* new slave storage limit */ dcl substr builtin; dcl upper fixed bin(18); /* number of words to release on the upper end */ dcl word bit (36) aligned ; /* a one word mask */ /* First initialize the pointer to the SCU data. Then determine how much memory is to be released from the upper and lower ends. */ scup = addr (mc.scu); word = (36)"0"b; substr (word, 19, 8) = substr (mc.regs.q, 1, 8); lower = fixed (word, 18); substr (word, 19, 8) = substr (mc.regs.q, 19, 8); upper = fixed (word, 18); /* Calculate the new memory size as the old size minus the total amount released. There must be at least 1K to continue. */ new_storage_limit = gcos_ext_stat_$storage_limit-upper-lower; if new_storage_limit < 1024 then call gcos_mme_bort_$system (gcos_et_$bad_mme_addr, "Less than 1K memory remaining."); /* Now that we have the new memory limit, save it and load the BAR with it. */ gcos_ext_stat_$storage_limit = new_storage_limit; call gcos_set_slave_$load_bar (divide (gcos_ext_stat_$storage_limit, 512, 9, 0)); /* Now, if there is any memory released on the low end, we will move everything down by "lower" words so that we can avoid any base value other than zero in the BAR. This will allow execution with the -no_bar argument to allow the user to user debug. */ if lower ^= 0 then do; length_in_bytes = new_storage_limit * 4 ; gcos_ext_stat_$gcos_slave_area_seg -> gseg = addrel (gcos_ext_stat_$gcos_slave_area_seg, lower) -> gseg; end ; /* Now truncate the gcos_slave_area_seg to the new size. */ call hcs_$truncate_seg (gcos_ext_stat_$gcos_slave_area_seg, gcos_ext_stat_$storage_limit, code); if code ^= 0 then call gcos_error_ (code, "Unable to truncate gcos_slave_area_seg."); call hcs_$set_max_length_seg (gcos_ext_stat_$gcos_slave_area_seg, gcos_ext_stat_$storage_limit, code); if code ^= 0 then call gcos_error_ (code, "Unable to set max length of gcos_slave_area_seg."); /* Now caculate the proper offset to be applied to scu.ilc to get the user back to the location specified in AU. To do so we take the desired location minus the ilc value minus a fudge factor of one. */ increment = fixed (substr (mc.regs.a, 1, 18), 18)-fixed (scu.ilc, 18)-1; return; %include gcos_ext_stat_; end gcos_mme_mrel_;  gcos_mme_prio_.pl1 09/09/83 1404.1rew 09/09/83 1007.6 7578 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_mme_prio_: proc (mcp, increment); /* Handler for the geprio mme. It does nothing but return to the caller. */ dcl mcp ptr; /* Machine conditions ptr. */ dcl increment fixed; /* No. of args. passed to this mme. */ increment = 0; /* Indicate no args. passed to this mme. */ return; end gcos_mme_prio_;  gcos_mme_rels_.pl1 09/09/83 1404.1rew 09/09/83 1007.6 70839 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_mme_rels_: proc (mcp, increment); /* * MME GERELS is used to deallocate peripherals from a program. In addition, it may be * used to alter the disposition code. The calling sequence is as follows: * * MME GERELS * ZERO No of files in upper half. Alter flag in lower half. * If flag = 0,following words hold filecodes of * files to be deallocated: * * BCI 1,0000F1 * BCI 1,0000F2 * etc * * * If flag = 1,following words hold filecodes * preceeded by new disposition code: * * BCI 1,000SF1 * BCI 1,000RF2 * * * WRITTEN BY DICK SNYDER JANUARY 18,1971 * WRITTEN BY D. KAYDEN APRIL 1974 * MODIFIED BY R.H. MORRISON MAY 1975 * Modified by Mel Wilson, November 1979 to clear released fct & fib entries, preventing erroneous re-allocation */ scup = addr (mc.scu); /* get addr of scu data */ i = instruction_counter+1; /* get offset of first parma */ wordp = addrel (gcos_ext_stat_$gcos_slave_area_seg, i); /* point to param 1 */ cnt = fixed (word.upper); /* get file count */ if word.lower = "0"b then alter = "0"b; /* set disp alter flag */ else alter = "1"b; if i+cnt >= gcos_ext_stat_$storage_limit then call gcos_mme_bort_$system (gcos_et_$bad_rels_rqst, "File code list is not completely within slave limits."); do j = 1 to cnt; /* loop to process files */ wordp = addrel (wordp, 1); /* bump pointer to next param word */ substr (fc, 1, 1) = xlate (fixed (word1.ch5, 6)); /* get 1st filecode character in ascii */ substr (fc, 2, 1) = xlate (fixed (word1.ch6, 6)); /* get 2nd filecode character in ascii */ /* Look up file code in file code table for match */ do fct_index = 1 to hbound (save_data.fibs, 1); if fc = fct.filecode (fct_index) then go to hit; /* match ? */ end; go to bump; /* no hit...ignore this one */ hit: ; if fct.sysout (fct_index) then go to bump; /* sysout file - same as no hit */ fibptr = fct.fibptr (fct_index); if ^alter then do; /* Release files request */ space_to_release = fixed (word.upper); /* check for partial release */ if space_to_release = 0 | fib.print | fib.punch | fib.read | fib.tape | fib.console then do; /* total release */ released_fibs.nrf = released_fibs.nrf+1; if released_fibs.nrf > hbound (released_fib, 1) then call gcos_mme_bort_$system ( /* Exceeded number released fibs. */ gcos_et_$rel_fibs_exceeded , "Over ^i fibs released." , hbound (released_fib, 1) ); saved_fib_ptr = addr (released_fib (released_fibs.nrf)); unspec (saved_fib_ptr -> fib) = unspec (fib); /* copy fib data */ substr (saved_fib_ptr -> fib.pathnm, 1, 2) = fc; /* stick in the file code */ call gcos_close_file_ (fibptr); fib.stream, fib.pathnm = ""; /* clear names from fib */ fct (fct_index).filecode = ""; /* clear feleased fct entry */ fct (fct_index).fibptr = null (); if ^gcos_ext_stat_$save_data.nosave then do; /* save/restart */ temp_file = ^(fib.perm | fib.print | fib.punch | fib.reader | fib.tape | fib.console); if temp_file & ^substr (fib.disp, 1, 1) then restart_control.cant_do = "1"b; /* can't do because temp_file not saved */ end; end; else do; /* partial release */ fib.size = fib.size - 3840 * space_to_release; if fib.size <= 0 then fib.size = 3840; /* be sure something is left */ if fib.last > fib.size then do; fib.last = fib.size; call ios_$seek ((fib.stream), "last", "first", fib.last, status); if code ^= 0 then call gcos_mme_bort_$system (code, "attempting to truncate mass storage file ""^a""", fc); end; end; end; else do; /* Come here if disposition is to be altered. If the disposition is being */ /* set to save or continue, check for an existing nonzero plud in the fib. */ /* If the plud is zero, set it = to the filecode. By this means, a file */ /* may be created by MME GEMORE, set to S dispositon by MME GERELS and */ /* referred to in a subsequent activity by using the original file code as */ /* as the LUD in a file assignment card. */ dis = word1.ch4; /* get new displacement */ check = "0"b; /* turn off check switch */ if dis = "51"b3 then fib.disp = "01"b; /* R */ else if dis = "24"b3 then fib.disp = "00"b; /* D */ else if dis = "62"b3 then do; /* S */ fib.disp = "10"b; check = "1"b; /* remember to check plud */ end; else if dis = "23"b3 then do; /* C */ fib.disp = "11"b; check = "1"b; /* remember to check plud */ end; else if dis = "47"b3 then fib.purge = "1"b; /* P */ else if dis = "43"b3 then fib.purge = "0"b; /* L */ else if dis = "44"b3 then do; /* M */ if word1.ch3 = "51"b3 then fib.type = "1"b; /* R = random */ else fib.type = "0"b; /* otherwise linked */ end; else call gcos_mme_bort_$system (gcos_et_$bad_rels_rqst, "Bad disposition specified in request for file code ""^a"".", fc); if check then do; /* check plud if C or S disp */ if fib.plud ^= "0"b then go to bump; /* fib.plud already assigned */ if verify (substr (fc, 2, 1), "*0123456789") ^= 0 then call gcos_mme_bort_$system (gcos_et_$bad_rels_rqst, "Cannot make LUD from file code without * or digit as second character. ""^a""", fc); fib.plud = substr (word.lower, 7, 12); /* put filecode in as plud */ end; end; bump: ; end; increment = 1+cnt; /* compute no of param words to skip */ return; %page; /* Variables for gcos_mme_rels_: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl addrel builtin; dcl alter bit (1) /* switch to control disp change */; dcl check bit (1) /* switch */; dcl cnt fixed bin(24); dcl dis bit (6) /* holder for dispositon char */; dcl fc char (2) /* holder for ascii filecode */; dcl fct_index fixed bin(24); dcl fixed builtin; dcl gcos_close_file_ ext entry (ptr); dcl gcos_et_$bad_rels_rqst fixed bin(35) ext; dcl gcos_et_$rel_fibs_exceeded fixed bin(35) ext static; dcl gcos_mme_bort_$system entry options (variable); dcl i fixed bin(24); dcl increment fixed bin(24)/* no.param words to skip over */; dcl instruction_counter fixed bin(18)unsigned unal based(addr(scu.ilc)); dcl j fixed bin(24); dcl null builtin; dcl saved_fib_ptr ptr; dcl size builtin; dcl space_to_release fixed bin(18); dcl substr builtin; dcl temp_file bit (1) aligned /* flag for temporary file */; dcl verify builtin; dcl wordp pointer; dcl 1 word aligned based (wordp), /* model of a word */ 2 upper bit (18) unaligned, 2 lower bit (18) unaligned; dcl 1 word1 aligned based (wordp), 2 ch1 bit (6) unaligned, 2 ch2 bit (6) unaligned, 2 ch3 bit (6) unaligned, 2 ch4 bit (6) unaligned, 2 ch5 bit (6) unaligned, 2 ch6 bit (6) unaligned; %page; %include gcos_ext_stat_; %page; %include gcos_restart_control_; %page; %include gcos_xlate_bcd_ascii_; %page; %include gcos_dcl_ios_; %page; %include gcos_fibs; end gcos_mme_rels_;  gcos_mme_rets_.pl1 09/09/83 1404.1rew 09/09/83 1007.6 15489 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_mme_rets_: proc (mcp, increment); /* *************************************************************************************** ***************************************************************************************** * * * M M E G E R E T S * * * MME GERETS is used to unset bits in the program switch word according to corresponding * bits in the Q-register. For each bit position of the Q that contains a 1, * the corresponding bit of the switch word is set to 0. For ecah bit position of * the Q that contains a 0, the corresponding bit of the switch word is not changed. * The resultant setting of the switch word is returned in the Q-register. * * * Author: DICK SNYDER NOVEMBER 6,1970 * Change: Dave Ward 06/01/81 gcos_ext_stat_. * * ****************************************************************************************** **************************************************************************************** */ %page; increment = 0; /* no parameter words */ save_data.psw = save_data.psw & ^mc.regs.q; /* and negated into psw */ mc.regs.q = save_data.psw; /* return new psw */ return; /* exit */ %page; /* Variables for gcos_mme_rets_: */ /* IDENTIFIER ATTRIBUTES */ dcl increment fixed bin(24); /* number of param words */; %page; %include gcos_ext_stat_; end gcos_mme_rets_;  gcos_mme_rout_.pl1 09/09/83 1404.1rew 09/09/83 1007.6 155340 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ******************************************************************************************* ******************************************************************************************* * * * M M E G E R O U T * * MME GEROUT enables a user program to send output to and receive input * from a remote terminal and to request terminal type. * * The following operations are implemented - * * 3 (octal) - Direct Access Output * 4 (octal) - Direct Access Output, Then Input * 5 (octal) - User Program Inquiry to Terminal * 6 (octal) - Program Requests Terminal Type * 17 (octal) - Program Requests Line Disconnect * 20 (octal) - Direct Access Current Line Status * * All operations not implemented fall into the categories of paper tape * manipulation or line switching. * * Output is written to the stream "user_output" and input is read from * the stream "user_input". Data is translated to and from the Multics * standard data format. This allows the stream names to be associated * with any type of device. The edited i/o mode is used for output to * suppress escape printing. * * A terminal break is simulated by a QUIT followed by the command * "program_interrupt". * * Direct access is established (if not already) on any correct call with * operation code 3, 4, or 5. * * WRITTEN BY DAVID KAYDEN JANUARY 1974 * Modified by M. R. Jordan, October 1977 * Modified by A. N. Kepner, March 1978 to allow courtesy call i/o within cc routines * ******************************************************************************************* ****************************************************************************************** */ gcos_mme_rout_: proc (mcp, increment); /* D E C L A R A T I O N S */ %include gcos_ext_stat_; /* External Entries */ dcl continue_to_signal_ ext entry (fixed bin(35)); dcl gcos_et_$bad_cc_ptr fixed bin(35) ext; dcl gcos_et_$bad_mme_in_cc fixed bin(35) ext; dcl gcos_et_$bad_rmt_station_id fixed bin(35) ext; dcl gcos_et_$bad_rout_op_code fixed bin(35) ext; dcl gcos_et_$bad_rout_pgm_id fixed bin(35) ext; dcl gcos_et_$bad_status_ret_ptr fixed bin(35) ext; dcl gcos_et_$invalid_dcw_ptr fixed bin(35) ext; dcl gcos_et_$rmt_term_rec_size fixed bin(35) ext; dcl gcos_mme_bort_$system ext entry options (variable); dcl ioa_ ext entry options (variable); dcl ios_$changemode entry (char (*), char (*), char (*), bit (72) aligned); dcl ios_$read_ptr ext entry (pointer, fixed bin(24), fixed bin(24)); dcl ios_$write_ptr ext entry (pointer, fixed bin(24), fixed bin(24)); /* Work Variables */ dcl increment fixed bin(24); /* number of words in mme request */ dcl 1 gerout_word aligned based (opptr), /* model of word following mme */ 2 buffp bit (18) unaligned, /* buffer pointer */ 2 op bit (6) unaligned, /* operation code of request */ 2 id bit (12) unaligned; /* terminal id of request */ dcl 1 gerout_word_ aligned based (opptr), /* gerout word overlay for op = 20 */ 2 term_type bit (6) unaligned, /* terminal type field */ 2 pad bit (30) unaligned; dcl 1 output_buffer aligned based (buffptr), /* model of output buffer */ 2 word_count bit (18) unaligned, /* number of words to send */ 2 inputp bit (18) unaligned, /* input buffer location */ 2 char_count bit (18) unaligned, /* output character count */ 2 control_bits bit (18) unaligned, /* output control bits */ 2 data (1280) bit (9) unaligned; /* output character data */ dcl 1 input_buffer aligned based (inptr), /* model of input buffer */ 2 char_count bit (18) unaligned, /* input character count */ 2 control_bits bit (18) unaligned, /* input control bits */ 2 data (1280) bit (9) unaligned; /* input character data */ dcl 1 return_word aligned based (sptr), /* model of return word */ 2 status_return bit (18) unaligned, /* status word pointer */ 2 courtesy_call bit (18) unaligned; /* pointer to courtesy call rtn. */ dcl 1 status_word aligned based (statptr), /* model of status word */ 2 pad bit (30) unaligned, /* unused portion of word */ 2 wait bit (1) unaligned, /* line waiting to connect to pgm. */ 2 idle bit (1) unaligned, /* terminal is idle */ 2 busy bit (1) unaligned, /* terminal is involved in I/O */ 2 complete bit (1) unaligned, /* I/O transmission is complete */ 2 disconnected bit (1) unaligned, /* terminal is not connected */ 2 break bit (1) unaligned; /* operator sent BREAK (quit key) */ dcl inquiry_name bit (36) aligned based (nameptr); /* program inquiry identification */ dcl 1 table (2) aligned internal static, /* tabled inquiry requests - 2 allowed */ 2 name bit (36) aligned, /* inquiry name of request */ 2 routptr ptr; /* pointer to inquiry request mme */ dcl (buffptr, inptr, gseg, opptr, nameptr, sptr, statptr) ptr; dcl 1 courtesy_call_conditions like save_machine_conditions based (mcp); dcl code fixed bin(35); dcl iosbuf (1297) bit (9); dcl new_next_avail fixed bin(24); dcl scratch_word bit (36) aligned; dcl slave_limit fixed bin(19); dcl status bit (72) aligned; dcl (i, j, k) fixed bin(24); /* Internal Static Variables */ dcl dac_id bit (12) aligned internal static; /* line id of current direct access */ dcl ackno_break bit (1) internal static; dcl old_mode char (128) internal static; dcl skip bit (1) internal static; dcl skip_loc label internal static; /* Constants */ dcl CR bit (9) internal static init ("015"b3 ); dcl LF bit (9) internal static init ("012"b3 ); dcl NULL bit (9) internal static init ("177"b3 ); dcl zero_word bit (36) aligned internal static init ((36)"0"b); dcl (addr, addrel, fixed, substr, unspec) builtin; /* P R O C E D U R E */ if ^gcos_ext_stat_$save_data.rout then do; /* once per activity initialization */ dac_id = (12)"0"b; /* not in direct access now */ table.name (1) = zero_word; /* and no requests tabled */ table.name (2) = zero_word; ackno_break = "0"b; skip = "0"b; call ios_$changemode ("user_output", "edited", old_mode, status); gcos_ext_stat_$save_data.rout = "1"b; /* initialization complete */ end; gseg = gcos_ext_stat_$gcos_slave_area_seg; /* get local pointer to slave area */ slave_limit = gcos_ext_stat_$storage_limit; /* copy slave storage limit, too */ increment = 2; /* initialize parameter length */ scup = addr (mc.scu); /* get pointer to scu data */ i = fixed (scu.ilc)+1; /* get offset of first parameter word */ opptr = addrel (gseg, i); k = fixed (gerout_word.op); /* extract operation code */ if k = 5 then go to inquiry; /* remote inquiry requested */ if gerout_word.id = (12)"0"b then go to err75; /* zero terminal id is illegal */ if k = 6 then go to terminal_type; /* program requests terminal type */ if k ^= 3 then /* check remaining implemented codes */ if k ^= 4 then if k ^= 15 then /* if no match then operation is */ if k ^= 16 then go to err72; /* undefined or not implemented */ /* not implemented */ sptr = addrel (opptr, 1); /* return word follows operation word */ if fixed (return_word.status_return) >= slave_limit then go to err41; if fixed (return_word.courtesy_call) >= slave_limit then go to err44; statptr = addr (scratch_word); /* allows no status word pointer */ if return_word.status_return ^= (18)"0"b then statptr = addrel (gseg, return_word.status_return); unspec (status_word) = zero_word; /* clear status word */ if k = 3 then go to in_out; /* output only request */ if k = 4 then go to in_out; /* output then input request */ if k = 15 then go to disconnect; /* disconnect request */ /* terminal status request */ if dac_id ^= gerout_word.id then do; /* if program uses a different id, then */ disc: status_word.disconnected = "1"b; /* tell him line is disconnected */ return; end; if ackno_break then do; /* if a "break" has occurred */ status_word.break = "1"b; /* then acknowledge it */ ackno_break = "0"b; end; else status_word.idle = "1"b; /* otherwise, the line is idle */ go to type; /* get the terminal type, too */ /* terminal type request */ terminal_type: if dac_id ^= gerout_word.id then do; /* if id does not match, then */ increment = 1; /* take disconnect return */ return; end; type: term_type = "04"b3 ; /* if id matches, then terminal type */ return; /* is teleprinter */ /* line disconnect request */ disconnect: status_word.disconnected = "1"b; /* status is always disconnected */ if dac_id ^= gerout_word.id then go to cc_check; /* if not connected to this id, then */ /* nothing to do */ dac_id = (12)"0"b; ackno_break = "0"b; /* partial reinitialization */ if ^gcos_ext_stat_$save_data.brief then call ioa_ ("direct access disconnect"); do i = 1, 2; /* now check for tabled request */ if table.name (i) ^= zero_word then do; /* tabled entry found */ table.name (i) = zero_word; /* clear table entry */ opptr = table.routptr (i); /* point to remembered inquiry mme */ dac_id = (2)"22"b3 ; /* set new terminal id */ gerout_word.id = dac_id; /* tell program the terminal id */ if ^gcos_ext_stat_$save_data.brief then call ioa_ ("direct access established"); /* this could be removed if not wanted */ go to cc_check; end; end; go to cc_check; /* nothing found - not in direct access */ /* remote inquiry request */ inquiry: nameptr = addrel (opptr, 1); /* set pointer to inquiry name */ if inquiry_name = zero_word then go to err76; /* zero inquiry name is illegal */ if dac_id = (12)"0"b then do; /* if not already in direct access, */ /* then establish it */ dac_id = (2)"21"b3 ; /* set terminal id */ inq1: gerout_word.id = dac_id; /* tell program the terminal id */ if ^gcos_ext_stat_$save_data.brief then call ioa_ ("direct access established"); /* this could be removed if not wanted */ return; end; /* request must be tabled */ do i = 1, 2; /* check against tabled inquiries */ if table.name (i) ^= zero_word then do; if inquiry_name = table.name (i) then /* check for same name already in table */ if table.routptr (i) = opptr then return; /* if so, location of mme must match */ else go to err76; /* otherwise abort */ if table.routptr (i) = opptr then go to err76; /* different names at the same */ end; /* location is also illegal */ end; do i = 1, 2; /* now attempt to table the request */ if table.name (i) = zero_word then do; /* found a slot */ table.name (i) = inquiry_name; /* save inquiry name */ table.routptr (i) = opptr; /* and mme location */ return; end; end; go to err76; /* table is full */ /* output or output - input request */ in_out: if dac_id = (12)"0"b then dac_id = gerout_word.id; /* connect by terminal id match */ if dac_id ^= gerout_word.id then go to disc; /* i/o request to wrong terminal id */ i = fixed (gerout_word.buffp); /* get address of output buffer */ if i > slave_limit then go to err43; buffptr = addrel (gseg, i); /* pointer to output buffer */ j = fixed (output_buffer.char_count); /* output character count */ if j > 1296 then go to err74; /* is buffer size too big (GCOS limit) */ if (fixed (output_buffer.word_count)-1)*4 < j then go to err74; /* check word count */ if k = 4 then if fixed (output_buffer.inputp) + 324 > slave_limit then go to err74; /* check input buffer against limits */ do i = 1 to j; /* copy output buffer */ iosbuf (i) = output_buffer.data (i); end; skip_loc = return_break; /* save stack frame for nonlocal transfer */ skip = "1"b; /* indicate i/o in progress */ if ackno_break then do; /* was there a previous break */ return_break: skip = "0"b; /* then skip i/o */ status_word.break = "1"b; /* acknowledge break */ ackno_break = "0"b; /* acknowledgement done */ go to cc_check; end; do i = 1 to j; /* convert GCOS buffer to Multics */ if iosbuf (i) = LF then do; /* remove initial line feed, if there */ iosbuf (i) = NULL; /* replace it with a null character */ go to append_lf; end; if iosbuf (i) ^= CR then /* stop search for line feed on first */ if iosbuf (i) ^= NULL then go to append_lf; /* printable character */ end; append_lf: if k = 3 then do; /* now append a "new line" to the end */ j = j + 1; /* if this is output only */ iosbuf (j) = LF; end; call ios_$write_ptr (addr (iosbuf), 0, j); /* send output to "user_output" */ if k = 3 then go to io_done; /* if output only, then skip input */ inptr = addrel (gseg, output_buffer.inputp); /* get pointer to input buffer */ call ios_$read_ptr (addr (input_buffer.data), 1296, j); /* read from user_input */ if input_buffer.data (j) = LF then /* there should be a line feed on end */ input_buffer.data (j) = CR; /* so replace it with carriage return */ input_buffer.char_count = substr (unspec (j), 19, 18); /* record input character count */ io_done: skip = "0"b; /* i/o complete */ status_word.complete = "1"b; /* normal status to program */ cc_check: if return_word.courtesy_call = (18)"0"b then return; /* check for user courtesy call */ if gcos_ext_stat_$save_data.cc then do; /* Already in courtesy call */ /* Check courtesy call queue for overflow */ new_next_avail = mod (courtesy_call.next_avail, hbound (courtesy_call.queue, 1))+1; if courtesy_call.next_out = new_next_avail then call gcos_mme_bort_$system (gcos_et_$bad_mme_in_cc, "Maximum of ^i simultaneous outstanding courtesy calls has been exceeded.", hbound (courtesy_call.queue, 1)-1); /* Add cc address to queue */ courtesy_call.queue (courtesy_call.next_avail) = fixed (return_word.courtesy_call); courtesy_call.next_avail = new_next_avail; end; else do; /* Not in courtesy call yet. */ gcos_ext_stat_$save_data.cc = "1"b; /* indicate that courtesy call in progress */ /* Save machine conditions and increment value for return to the caller of */ /* MME GEINOS when the MME GEENDC is executed. Put courtesy call address */ /* in increment to cause control to go to courtesy call routine. */ gcos_ext_stat_$increment_hold = increment; /* save increment */ courtesy_call.hold = courtesy_call_conditions.save_space; /* save MME GEINOS conditions */ i = fixed (return_word.courtesy_call); /* get courtesy call address */ j = fixed (scu.ilc); /* get loc of MME GEINOS */ increment = i-j-1; /* compute increment value to cause control to go to cc rtn */ end; return; /* error messages */ /* standard GCOS error messages are used */ err41: code = gcos_et_$bad_status_ret_ptr; go to abort; err43: code = gcos_et_$invalid_dcw_ptr; go to abort; err44: code = gcos_et_$bad_cc_ptr; go to abort; err72: code = gcos_et_$bad_rout_op_code; go to abort; err74: code = gcos_et_$rmt_term_rec_size; go to abort; err75: code = gcos_et_$bad_rmt_station_id; go to abort; err76: code = gcos_et_$bad_rout_pgm_id; abort: call gcos_mme_bort_$system (code); /* process a terminal break */ /* (simulated by a QUIT followed by the command "program_interrupt") */ rout_interrupt: entry (); if gcos_ext_stat_$save_data.rout & dac_id ^= (12)"0"b then do; /* are we in direct access */ if skip then go to skip_loc; /* if i/o in progress - abort it */ ackno_break = "1"b; /* otherwise remember break */ return; /* and tell program later */ end; call continue_to_signal_ (code); /* not in direct access now */ return; /* so pretend we didn't set handler */ /* restore "user_output" edited/normal mode after an activity */ rout_cleanup: entry (); call ios_$changemode ("user_output", old_mode, "", status); /* restore edited/normal mode */ old_mode = ""; /* prevent mode from being reset twice */ gcos_ext_stat_$save_data.rout = "0"b; /* reset direct access flag */ return; end gcos_mme_rout_;  gcos_mme_save_.pl1 09/09/83 1404.1rew 09/09/83 1007.6 89865 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_mme_save_: proc (mcp, increment); /* MME GESAVE is used to write out a program in system loadable format (loadable by a MME GECALL). CALLING SEQUENCE: MME GESAVE BCI 1,XXXXXX BCD PROGRAM NAME ZERO L(FIRST WORD),NO OF WORDS FIRST WORD AND NUMBER OF WORDS TO SAVE ZERO XFER ADDR,LOAD INCREMENT PLACE TO GO WHEN RELOADED,NUMBER TO BE SUBTRACTED FROM LOC OF FIRST WORD AND XFER ADDR WHEN RELOADED RETURN IN ADDITION, THE Q REQ MUST CONTAIN THE FILE CODE OF THE FILE ON WHICH THE SAVE IS TO BE DONE. THIS FILE MUST BE RANDOM DRUM OR DISK. Q upper can also contain an error return location. Author: DICK SNYDER OCTOBER 9,1971 Change: D. KAYDEN APRIL 1974 Change: M. R. Jordan, October 1977 Change: Dave Ward 06/30/81 Revised instituted, fixed bin(24)unsigned instituted, bugs corrected. */ scup = addr (mc.scu); /* get addr of scu data */ i = instruction_counter+1; /* offset to MME GECALL parameter location. */ callp = addrel (gcos_ext_stat_$gcos_slave_area_seg, i); /* get pointer to params */ call gcos_cv_gebcd_ascii_ (addr (mc.regs.q), 6, addr (fc)); /* get file code in ascii */ do i = 1 to hbound (save_data.fibs, 1); if fct.filecode (i) = substr (fc, 5, 2) then go to hit; /* look for file */ end; message = "No device assigned to file code ""^a""."; ecode = gcos_et_$bad_call_save_device; die: ; if substr (mc.regs.q, 1, 18) ^= (18)"0"b then do; return_code: ; increment = q_reg_left_half + instruction_counter; fb35 = gcos_mme_bort_$abort_number (ecode); q_reg_right_half = addr (fb35) -> word.r18; return; end; else call gcos_mme_bort_$system (ecode, message, substr (fc, 5, 2)); hit: if fct.sysout (i) then go to not_rand; fibptr = fct.fibptr (i); fib.iocount = fib.iocount + 1; if ^fib.type then do; /* not random disk */ not_rand: message = "File code ""^a"" is not assigned to a random mass-storage file."; ecode = gcos_et_$bad_call_save_device; goto die; end; if (gesave.first+gesave.count) > gcos_ext_stat_$storage_limit then do; ecode = gcos_et_$io_lim_call_save; message = ""; goto die; end; if gesave.count = 0 then do; ecode = gcos_et_$zero_save_word_cnt; message = ""; goto die; end; if substr (save_data.psw, 16, 1) then do; /* first time save on this file */ call ios_$seek (fib.stream, "last", "first", 1000, status); /* seek just after catalog */ if code ^= 0 then do; /* ios error? */ ioerror: call check_fs_errcode_ (code, "xxxxxxxx", longerror); /* get error message equivalent to code */ if substr (mc.regs.q, 1, 18) ^= (18)"0"b then goto return_code; else call gcos_mme_bort_$system (code, "file code=""^a""^/^a", substr (fc, 5, 2), longerror); end; call ios_$seek (fib.stream, "write", "first", 1000, status); /* seek write also */ if code ^= 0 then go to ioerror; end; preface.name = gesave.prog_name; /* set up preface data */ preface.rel_check, preface.rel_abs = 0; preface.reloc_words = 0; preface.entry = gesave.xfer_addr - gesave.load_incr; preface.origin = gesave.first - gesave.load_incr; preface.data_words = gesave.count; /* Calculate checksum. */ checker_ptr = addrel (gcos_ext_stat_$gcos_slave_area_seg, gesave.first); /* point at it */ accum = 0; do i = 1 to gesave.count; accum = accum + checker (i); if accum > 68719476735 then /* test for 36 bit overflow */ accum = accum-68719476736+1; /* preform end around carry and add */ end; preface.data_check = substr (unspec (accum), 37, 36); /* Save checksum. */ add = gesave.first - gesave.load_incr; cnt = gesave.count; ndcw = 0; loop: ; ndcw = ndcw+1; preface.dcws (ndcw).data_addr = add + 1024; if cnt <= 4096 then do; /* last one */ if cnt = 4096 then preface.dcws (ndcw).count = 0; else preface.dcws (ndcw).count = cnt; preface.dcws (ndcw).action = "0"b; /* indicate that this is last dcw */ go to done; /* fini */ end; preface.dcws (ndcw).count = 0; /* max count of 4096 */ cnt = cnt-4096; /* subtract this from count */ preface.dcws (ndcw).data_addr = add +1024; add = add+4096; /* kick up address */ preface.dcws (ndcw).action = "001"b; /* this isn't the last */ go to loop; /* so do more */ done: call ios_$tell (fib.stream, "write", "first", seek_save, status); /* find out where preface will go */ if code ^= 0 then go to ioerror; call ios_$write (fib.stream, addr (preface), 0, 6+ndcw, i, status); /* write out preface */ j = gesave.count; /* get count of words to write */ if code ^= 0 then go to ioerror; /* io error, die */ fib.last = seek_save + 6 + ndcw + j; /* update end of valid data */ call ios_$write (fib.stream, checker_ptr, 0, j, i, status); /* write out prog */ if code ^= 0 then go to ioerror; /* die */ /* Fill in the catalog. */ call ios_$seek (fib.stream, "read", "first", 0, status); /* set up to read catalog */ if code ^= 0 then go to ioerror; /* oops */ call ios_$read (fib.stream, addr (catblk), 0, 1000, i, status); /* read catalog */ if code ^= 0 then go to ioerror; if substr (save_data.psw, 16, 1) then catblk.no_ent = 0; /* init catalog if first time */ substr (save_data.psw, 16, 1) = "0"b; /* turn off flag */ i, catblk.no_ent = catblk.no_ent+1; /* bump no of entries */ catblk.elblock (i).element = gesave.prog_name; /* put name in catalog */ catblk.elblock (i).address = seek_save; /* put in seek address */ /* Write out the catalog. */ call ios_$seek (fib.stream, "write", "first", 0, status); /* seek to start of file */ if code ^= 0 then go to ioerror; /* lose */ call ios_$write (fib.stream, addr (catblk), 0, 1000, i, status); /* write out catalog */ if code ^= 0 then go to ioerror; call ios_$seek (fib.stream, "write", "last", 0, status); /* reset write pointer */ if code ^= 0 then go to ioerror; increment = 3; /* skip 3 param words */ return; %page; /* Variables for gcos_mme_save_: */ /* IDENTIFIER ATTRIBUTES */ dcl accum fixed bin(71) /* accumulator for checksum */; dcl add fixed bin(24); dcl addr builtin; dcl addrel builtin; dcl bit builtin; dcl callp ptr; dcl checker (gesave.count) fixed bin(36)unsigned unal based (checker_ptr) /* overlay for computing chksum */; dcl checker_ptr ptr; dcl check_fs_errcode_ entry (fixed bin(35), char(8) aligned, char(100) aligned); dcl cnt fixed bin(24); dcl ecode fixed bin(35); dcl fb35 fixed bin(35); dcl fc char (6); dcl fixed builtin; dcl gcos_cv_gebcd_ascii_ ext entry (pointer, fixed bin(24), pointer); dcl gcos_et_$bad_call_save_device fixed bin(35) ext; dcl gcos_et_$io_lim_call_save fixed bin(35) ext; dcl gcos_et_$zero_save_word_cnt fixed bin(35) ext; dcl gcos_mme_bort_$abort_number entry (fixed bin(35)) returns (fixed bin); dcl gcos_mme_bort_$system entry options(variable); dcl i fixed bin(21); dcl increment fixed bin(24); dcl instruction_counter fixed bin(18)unsigned unal based(addr(scu.ilc)); dcl ioa_ entry() options(variable); dcl j fixed bin(21); dcl k fixed bin(24); dcl longerror char (100)aligned; dcl message char (62); dcl ndcw fixed bin(24); dcl prog_name char (6); dcl seek_save fixed bin(21); dcl substr builtin; dcl unspec builtin; dcl 1 word aligned based ,2 l18 bit(18)unal ,2 r18 bit(18)unal ; dcl 1 q_register aligned based(addr(mc.regs.q)) ,2 q_reg_left_half fixed bin(18)unsigned unal ,2 q_reg_right_half bit(18)unal ; dcl 1 gesave aligned based (callp), /* overlay for gesave parameters */ 2 prog_name bit(36) unal, /* name under whcih file to be saved */ 2 first fixed bin(18)unsigned unal, /* addr of first word to be saved */ 2 count fixed bin(18)unsigned unal, /* no. of words to be saved */ 2 xfer_addr fixed bin(18)unsigned unal, /* transfer address */ 2 load_incr fixed bin(18)unsigned unal /* loading increment */ ; dcl 1 preface aligned, /* model of preface record */ 2 data_check bit(36), /* checksum of following data words */ 2 rel_check fixed bin(24), /* checksum of following reloc. words */ 2 rel_abs fixed bin(24), /* 0=absolute|^0=relocatable */ 2 name bit(36) unal, /* name of pgm */ 2 entry fixed bin(18)unsigned unal, /* entry address */ 2 origin fixed bin(18)unsigned unal, /* origin */ 2 reloc_words fixed bin(18)unsigned unal, /* no. of relocation words */ 2 data_words fixed bin(18)unsigned unal, /* no. of data words */ 2 dcws (64) like dcw_model /* dcw(s) to load following data records */ ; dcl 1 dcw_model aligned based, /* model of dcw */ 2 data_addr fixed bin(18)unsigned unal, 2 zero bit(3) unal, 2 action bit(3) unal, 2 count fixed bin(12)unsigned unal; /* number of words to xfer */ dcl 1 catblk aligned, 2 nxt fixed bin(24), /* pointer to next calalog block */ 2 no_ent fixed bin(24), /* number of entries in catalog */ 2 elblock (499), /* room for 499 entries */ 3 element bit(36) unal, /* prog name */ 3 address fixed bin(24) /* offset in file of preface data */ ; %page; %include gcos_dcl_ios_; %page; %include gcos_ext_stat_; end gcos_mme_save_;  gcos_mme_sets_.pl1 09/09/83 1404.1rew 09/09/83 1007.6 15327 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_mme_sets_: proc (mcp, increment); /* *************************************************************************************** ***************************************************************************************** * * * M M E G E S E T S * * * MME GESETS is used to set bits in the program switch word according to corresponding * bits in the Q-register. For each bit position of the Q that contains a 1, * the corresponding bit of the switch word is set to 1. For ecah bit position of * the Q that contains a 0, the corresponding bit of the switch word is not changed. * The resultant setting of the switch word is returned in the Q-register. * * *Author: DICK SNYDER OCTOBER 16,1970 * Change: Dave Ward 06/01/81 gcos_ext_stat_. * * ****************************************************************************************** **************************************************************************************** */ %page; increment = 0; /* no parameter words */ save_data.psw = save_data.psw | mc.regs.q; /* or q into psw */ mc.regs.q = save_data.psw; /* return new psw */ return; /* exit */ %page; /* Variables for gcos_mme_sets_: */ /* IDENTIFIER ATTRIBUTES */ dcl increment fixed bin(24)/* number of param words */; %page; %include gcos_ext_stat_; end gcos_mme_sets_;  gcos_mme_snap_.pl1 09/09/83 1404.1rew 09/09/83 1007.6 20331 /* ************************************************************* * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1974 by Honeywell Information Systems, Inc. * * * ************************************************************* */ /* *************************************************************************** *************************************************************************** * * * * * mme gesnap * * * * * * This mme performs panel and slave core area snaps of gcos programs. * * * * * * Written by R. H. Morrison February 22, 1974 * * Modified by R.H. Morrison on April 8, 1974 * * Modified by R.H. Morrison on February 11,1975 * * * * * *************************************************************************** ************************************************************************ */ gcos_mme_snap_: proc (faultp, increment); /* **** DECLARATIONS **** */ dcl gcos_mme_snp1_ ext entry; dcl faultp pointer; /* unused input parameter */ dcl increment fixed bin(24); /* number of mme parameters */ dcl gcos_write_$ptr ext entry (ptr, char (*), bit (8)); /* **** PROCEDURE **** */ increment = 1; /* one mme parameter */ call gcos_mme_snp1_; /* take the snap (no arguments required) */ return; end gcos_mme_snap_;  gcos_mme_snp1_.alm 09/09/83 1404.1rew 09/09/83 1007.6 373680 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " ************************************************************* " * * " * * " * copyright (c) 1974 by honeywell information systems, inc. * " * * " * * " ************************************************************* " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " gcos_mme_snp1_ " " " " This procedure is a conversion of the GCOS SR1/G SSA module .MSNP1 " " from gmap to alm pure procedure. " " " " There are three entry points to this procedure: " " " " 1. gcos_mme_snp1_:- This entry processes a slave program MME " " GESNAP. It requires no arguments. " " " " 2. binpt:- This entry is used to snap the slave prefix of " " aborting programs. It requires three arguments: " " arg1 is a full word containing the absolute location to print " " in its upper, and the number of words to print in its lower. " " arg2 is a full word containing the absolute location to snap " " in its upper, and the number of words to snap in its lower. " " arg3 is a full word containing bias to apply to address " " for snap in its upper, and 3 bcd characters to print with the " " first line of output in its lower (m ,s , ). " " " " 3. bord:- This entry is used to snap registers and memory of " " aborting programs. It requires two arguments: " " arg1 is a full word containing the ic&ir to print. " " arg2 is a full word which has the same format as the MME " " GESNAP parameter. " " " " Written by R.H. Morrison December, 1974 " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " name gcos_mme_snp1_ entry gcos_mme_snp1_,bord,binpt include mc " " gcos_mme_snp1_: push spriap sp|0 save ap ldq 0,dl change transfer to ep1 stq mod lda 0,dl set a & q registers ldq 0,dl tra xinit1 " ttl cd600j3.265 gecos sr1/g 740704snp1 " cpr g,1968,1969,1970 " cpr h,1971,1972 " .entry snp1,xend,,(gesnip,binpt,bord),ssa " ttls g e s n a p bp: null stx1 prea bp05: null eax3 0,qu save location of first word to " be dumped. eaq 0,ql store # words to dump in stq wdcnt word count. cana -1,dl are there any words to be moved? tze bp20 nope eax1 0,au put location of data to be moved in x1. ldx2 lp|bufad1 x2 = 1st location in output buffer ana -1,dl isolate # of words to move bp10: ldq pr3|0,1 start move. stq lp|0,2 adlx1 1,du bump move indices. adlx2 1,du sbla 1,dl decrement # words to move. tnz bp10 continue moving. bp20: stx3 mo10a store location of next word to dump. tsx1 comp go find first equal line. tra bp30 no equal lines. tra comp20 lines not equal, continue search. ldx4 comp20a first equal line-loc. in comp 20. sblx4 mo10a calculate # words to move. sta wdcnt restore wdcnt to new value. tsx1 output go output the words. ldx0 =o542020,du set up to print * with next line. sxl0 mo30a tsx1 comp now we skip all equal lines. tra bp50 less than 17 words left to print. tra 2,ic unequal lines found. tra comp20 equal lines found, keep going sta wdcnt restore word count. ldx3 comp20a pick up loc. of unequal line. tra bp20 bp30: ldx4 wdcnt pick up # of words to print. tsx1 output output last of line. pre: ldx1 prea tnz 0,1 came from eis register dump routine flush: tsx1 write flush the buffer xit: null return return to calling procedure bp50: eax3 8,3 bump loc. of line by 8 to get past " equal line. eax4 -8,au # words left to x4. stx3 mo10a store loc. of last line(s) to print. tra bp30+1 " this routine determines " how many words to be printed " will fit in the current " buffer and calls the " move routine to put them " in the buffer. whenever the " buffer is found to be full, " the write routine is called " to empty the buffer. " upon entry " x2-next available loc. in lp|bufr. " x4-number of words to move. output:stx1 op20a save x1 for return. eax0 bufnd see if all words to be moved stx2 op05a fit in buffer. allow for 2 sblx0 op05a extra words. last loc in buffer- " first available loc to store in. tmi op50 nothing fits. stx0 op15a op10: cmpx4 op15a will all words fit? trc op30 no- see if any fit eaa 0,4 # words to au. tsx1 move go setup sysout record. op20: ldx1 op20a tra 0,1 op30: cmpx0 9,du will at least 8 words fit? tnc op50 no-go flush buffer. eax0 -1,0 set number of words to move anx0 =o777770,du to a multiple of 8. stx0 op40a save so as to reduce total words. eaa 0,0 tsx1 move set up sysout record. op40: sblx4 op40a reduce total words to move by ldx0 =o202020,du # words just moved. stx3 mo10a initialize move rout. with start of " next line. sxl0 mo30a set print character to blank. op50: tsx1 write go flush the buffer. tra output+1 " this routine sets up the sysout " (gefrc) record control words " for n lines of "binary" " print words. it then moves " the prescribed words to the " buffer. " upon entry " x2-next available loc in bufr. " au-# words to move " mo10a-initialize with loc of " first word to move " mo20a-initialize with bias to " apply to printed location. " mo30a-initialized with character " to print with first loc. " e.i. m,s,* or blank. move: eaq 1,au construct first gefrc control orq =o70374,dl word. stq lp|0,2 mo10: ldx3 mo10a set x3 to first word to move " set up second sysout control " word. location, print character mo20: eaq 0,3 apply bias to location adlq mo20a mo30: orq mo30a or in print character stq lp|1,2 eax2 2,2 set x2 to "move to" location. mo40: arl 8 shift # word to move into position eax0 256+512,al and "or" in a and b bits for repeat cana -1,dl test for partial 256 word block tnz mo50 move it mo60: sbla 1,du decrement number of full blocks tmi 0,1 exit odd mo50: rpdx 0,1 move last of words ldq pr3|0,3 stq lp|0,2 tra mo60 " this routine compares one line " (8 words to print in memory dump) " with the next line and " exits 1 when the lines are " not equal. when the lines are " equal it exits 2. if there " are only 2 lines (16 words) or " less to be processed this " routine exits 0. when at " least one comparison takes place, " comp20a contains the first loc. " of the second line of the " current pair. " upon entry: " wdcnt contains # word still to " be processed. " x3 contains location for first line. comp: lda wdcnt pick up number of words to process. comp10:cmpa 17,du is there less than 17 words. tnc 0,1 yes, exit 0. eax4 8,3 location of next line to x4. eaa -8,au reduce count by 8. stx4 comp20a save it for use later. odd rpd 8,1,tnz compare lines for equality ldq pr3|0,3 cmpq pr3|0,4 tnz 1,1 lines are not equal, exit 1. tra 2,1 lines are equal, exit 2. comp20:ldx3 comp20a location of next line to x3. tra comp10 " " write output routine " this routine calls sysout " entry point 1 for sysout on " p* or entry point 5 for " writing to the execution report. " upon entry " x1 - used for return. " x2 - contains next avail loc in bufr. " x4-contains a count that must be saved " upon exit " x2-must contain next avail loc in lp|bufr " x4-must be preserved throughout. write: stx1 writxa convert to print line format and write ldx0 lp|bufad dev # words for dcw stx0 wr10a write routine sblx2 wr10a dev words sxl2 lp|bufr-1 eaa -1,2 now generate block control word. ora =o060000,dl this is for output to execution report sta lp|bufr " develope address portion of dcw. sblx0 lp|.crlal,6 stx0 lp|bufr-1 stx4 wr20a tsx1 gwrite convert to print line format lxl1 bsn set block serial number stx1 lp|pbufr aos bsn lda desc2i descriptor word for block arl 18 shift out size eaq 1,4 new size qls 2 times 4 for ascii pseudo char. count lls 18 shift back to a reg. sta desc2 put in argument list call |[block_ptr](arglst) ldx4 wr20a writx: ldx1 writxa restore x1 ldx2 lp|bufad1 tra 0,1 ckore: null ldaq lp|.stemp,5 get ic+i and dump parameter canq =o400000,dl do we want registers only tze snpc no-user wants core also tra flush go write registers and exit snpc: null anq =o777777077777 mask out panel/slew info ldx3 =o622020,du dump label lcx1 lp|.crlal,6 ldx0 lp|.crlal,6 snps: null lda lp|.salim,5 get slave memory limits ana =o776,du isolate # of words als 9 sbla 1,dl "******* " au is last avail mem location, al is all ones. this will override " any word count in the lower half of lp|.stemp+1 which is used in a " comparison very shortly. stx0 snpmsa to absolutize starting address stx1 mo20a relativize dump locations sxl3 mo30a dump label canq -1,dl is word count zero tnz 2,ic orq -1,dl yes-set count to max stq lp|.stemp+1,5 save dump parameter cmpa lp|.stemp+1,5 compare 1st address with last avail trc 3,ic ok eax0 0 stx0 lp|.stemp+1,5 anq -1,dl isolate word count stq lp|.stemp+2,5 save it ldq lp|.stemp+1,5 now we calculate last word qrl 18 to be dumped in lower half asq lp|.stemp+2,5 of lp|.stemp+2 arl 18 last avail mem loc to al sbla lp|.stemp+2,5 is last word to be dumped greater tpl 3,ic no-parameter ok asa lp|.stemp+1,5 clip word count in parameter aos lp|.stemp+1,5 so as to fit in avail memory ldq lp|.stemp+1,5 pick up parameter snpms: adlq snpmsa absolutize eaa 0 tra bp05 ckeis: null ldq lp|.creis are there eis registers to be snapped orsq mo20a yes - set print location to zero lcx1 mo20a stx1 mo20a set print loc to zero orq 24,dl # words in reg storage eax1 rcw odd rpd 7,1 lda 0,1 sta lp|0,2 lda 0,du epp3 lp|0 tsx1 bp epp3 |[gcos_slave_area_seg],* lda rcw era 7,du set word count to one sta lp|0,2 lda =o770300,du slew code sta lp|1,2 store slew info in output buffer adlx2 2,du eax1 0 stx1 prea tra ckore rcw: vfd 18/6,o18/374 bci /*pointer registers & eis info*!2/ snp: null ep1 lda lp|.sstke get ic&i of mme adla 1,du ana =o777777777577 set indicator to slave sta lp|icir snp1: null lda lp|icir sta lp|.sstke ldq lp|.crlal,6 adlq lp|icir address of mme added to qu ldq pr3|0,qu pick up mme parameter staq lp|.stemp,5 ana =o77,dl isolate bits used by gecos ersa lp|icir turn them off for printing ir eax1 .sreg absolute register pointer snp7: stx1 span4a store register pointer panel: null lda lp|.salim+1 base address register sta lp|icir+1 store it ldx1 =o770100,du "*** q still contains dump parameter canq =o100000,dl do we slew t-o-p tnz 2,ic yes stx1 snp5a no-slew one line ldx2 lp|bufad1 pointer to output buffer lda =o374,dl device and media code stx2 span6a save record header sta lp|0,2 adlx2 1,du bump to first word lda snp5a slew code tsx1 span5+1 snp5: vfd o18/772000,18/0 "*** q still contains dump parameter canq =o200000,dl do we dump registers tnz ckore no snpx: lxl1 mod is this ep3 cmpx1 2,du tnz snp4 no - don't dump even/odd pair tsx1 span ein: vfd 18/icir-.sreg+2,o12/2531,1/0,5/31 oin: vfd 18/icir-.sreg+3,o12/4631,1/0,5/31 shift: oct 011717171717 eax1 icr tra span5 snp4: tsx1 span icr: vfd 18/icir-.sreg,o12/3123,1/0,5/30 irr: vfd 18/icir-.sreg,o12/3151,1/1,5/30 bar: vfd 18/icir-.sreg+1,o12/2221,1/0,5/30 vfd 18/6,o12/2551,1/0,5/12 er vfd 18/4,o12/2151,1/0,5/31 ar vfd 18/5,o12/5051,1/0,5/31 qr vfd 18/7,o12/6351,1/0,5/7 tr oct 770100000000 tsx1 span vfd 18/0,o12/6700,1/0,5/30 x0 vfd 18/0,o12/6701,1/1,5/30 x1 vfd 18/1,o12/6702,1/0,5/30 x2 vfd 18/1,o12/6703,1/1,5/30 x3 vfd 18/2,o12/6704,1/0,5/30 x4 vfd 18/2,o12/6705,1/1,5/30 x5 vfd 18/3,o12/6706,1/0,5/30 x6 vfd 18/3,o12/6707,1/1,5/30 x7 oct 770300000000 tra ckeis " " panel dump " span: lda =o374,dl put out device and media code. stx2 span6a save record header sta lp|0,2 adlx2 1,du bump to first word span5: lda 0,1 pick up parameter eax4 0,al test if slew code only. tze span1 yes, exit cmpx4 =o171717,du tze 1,1 span4: eaq 0,au no, pick up register contents adlq span4a ldq lp|0,qu ana =o777700,dl isolate bcd name cmpa =o255100,dl is this register er? tnz 2,ic no- qrl 1 yes-align it octally. ora =o202017000020 format sta lp|0,2 store register name adlx2 1,du bump storage canx4 1,du test if bits 0-17 tze 2,ic are to be converted tsx3 scon2 yes, convert, store canx4 =o40,du test if only 18-35 are convert tze 2,ic no qls 18 yes fetch to high end anx4 =o36,du isolate shift for counting lda =o011717171717 rest of characters and fill arl 0,4 shift character control tsx3 scon3 convert rest of register adlx1 1,du bump to next parameter tra span5 back for next one span1:sta lp|0,2 end of line, close record sblx2 span6a record header span6: ldx4 span6a store record length to buffer stx2 lp|0,4 adlx2 1,du increment to point at next adlx2 span6a tra 1,1 " scon2: lda 1,dl convert register 36 bits scon3: als 3 convert 36 or less lls 3 tnc -2,ic keep going till 1 bit goes thru sign sta lp|0,2 store converted register adlx2 1,du tra 0,3 exit "******************************************************************************* "******************************************************************************* "*** ep 1: process mme gesnap " calling sequence: " mme gesnap " vfd 18/a,2/p,1/s,15/n " where a = starting location of snapshot " p = panel indicator " 00= dump panel, eis registers, and memory " 01= no registers-memory only " 10= panel and eis registers only " s = slew control " 0= slew 1 line before snap " 1= slew t-o-p before snap " n = number of words to be snapped " 0= all the prg's allocated memory starting " at location ' a ' will be snapped "*** gesnip:null tra xinit1 go initialize "***: ep 2: used to snap the ssa/slave prefix of aborting programs " au = absolute loc of lines to print " al = # of words to print " qu = absolute loc to snap " ql = # words to snap " x1 = bias to apply to address for snap " x2 = 3 bcd characters to print with first " line of output(m ,s , or ) "***: binpt: null push spriap sp|0 save ap ldq 1,dl change xfer to ep2 stq mod lda ap|2,* get arguments ldq ap|4,* ldx1 ap|6,* lxl2 ap|6,* tra xinit1 go initialize " " "***: ep 3: used to snap registers and memory of aborting programs " ar = ic+i to print " qr = dump parameter-same as mme parameter " x1 = absolute pointer to register storage "***: bord: null push spriap sp|0 save ap ldq 2,dl change xfer tp ep3 stq mod lda ap|2,* get arguments ldq ap|4,* eax1 .sreg xinit1:null ldx5 0,du lower address of slave program (simulated) ldx6 0,du program number (simulated) ldx7 0,du processor number (simulated) staq lp|.stemp+8 sreg lp|savreg pinit: null initialize procedure " " zero temporary storage " stz workt eaa arglst first temporary location sta workt eaa workt last temporary location sbla workt length of temporary storage area arl 8 ldx2 0,du eax0 0,al rptx 0,1 stz arglst,2 " " construct argument list for call to gcos_write_ " lda =o000004000004 arg. count and code ldq =o000004,du descriptor count staq sp|arglst epp2 |[prt] fib pointer spri2 sp|arglst+2 epp2 lp|pbufr record pointer spri2 sp|arglst+4 epp2 desc1 descriptor 1 spri2 sp|arglst+6 epp2 desc2 descriptor 2 spri2 sp|arglst+8 epp3 |[gcos_slave_area_seg],* set pointer tra mfalt desc1: oct 464000000000 desc2i: oct 524000002400 mfalt: null " store bar & set .salim sbar lp|.salim+1 save base address register setting ldx5 0,du zero lower to be sure sxl5 lp|.salim+1 lda lp|.salim+1 sta lp|.salim arl 9 eax5 lp|.salim,*au sxl5 lp|.salim " get ic & i epp2 |[mc] ldq pr2|mc.scu.ilc_word adlq 1,dl mark registers stored stq lp|.sstke save " get machine registers ldx2 0,du ldx3 0,du odd rpd 8,1 ldq pr2|mc.regs,2 stq lp|.sreg,3 " get pointer registers ldx2 0,du ldx3 0,du odd rpd 16,1 ldq pr2|mc.prs,2 stq lp|eisbf,3 " get eis info ldx2 0,du ldx3 16,du odd rpd 8,1 ldq pr2|mc.eis_info,2 stq lp|eisbf,3 " get even and odd instructions ldq pr2|scu.even_inst_word stq lp|icir+2 ldq pr2|scu.odd_inst_word stq lp|icir+3 " xsnp1: ldq =o202020,dl stq mo30a ldq snp5 stq snp5a tra syot bp06: null sblx1 lp|savreg+5 create print bias stx1 mo20a to be applied to print address sxl2 mo30a save m/s label tra bp05 syot: null eaa bufr sta lp|bufad adla 1,du sta lp|bufad1 eaa pbfnd sta lp|endbuf eaa bufr sta lp|bufr-1 eaa eisbf sta lp|.creis xinix: null lreg lp|savreg xfer: lxl4 mod tra *+1,4 tra snp ep # 1 tra bp06 ep # 2 nopr: nop 0,du bord1: null ep # 3 staq lp|.stemp,5 save ic+i:dump parameter sta lp|icir ic+i for printing stx1 span4a save absolute register pointer eax1 0,au instruction at ic is the odd cana =o200,dl is it master or slave tnz contd master adlx1 lp|.crlal,6 slave absolutize it stx1 sizea lda lp|.salim,5 ana =o776,du program bound als 9 sbla 1,du last legal address adla lp|.crlal,6 absolutize it size: cmpa sizea is snap legal tnc panel no, dump panel only contd: null lca =o201,dl ansa lp|.stemp,5 turn off master mode bit tra panel " " This routine converts the dump record format to print line format " and moves therecords to the print buffer (pbufr). " This routine is a modification of the write and dump routines " of the GCOS SR1/G program GEOT. " gwrite: null stx1 wtrsk save return location eax2 bufr set x2 for block control word eax4 pbufr set x4 for expansion & print buffer stx4 talls initialize output buffer (pbufr) tally eax0 bufr set end of buffer limit adlx0 lp|0,2 number of words from record control word stx0 nwdpr writb: null lxl1 lp|0,2 x1 = lower of l.r. cont-wd cmpx1 =o060000,du tze cdump control for dump cmpx1 =o070374,du tze dump dump record writr: anx1 =o007700,du cmpx1 =o000300,du tze writh if m/c = 3, accept record tra writc ignore other m/c's writh: null q.ar: null lda =o000777,du mask out all but last nine bits of word ora =o007777,dl count, media code, and report from ansa lp|0,2 GFRC control word ldx0 lp|0,2 eaa 1,0 move logical record to print buffer als 10 eax0 768,au eax3 0,2 ldx4 talls odd rpdx 0,1 lda lp|0,3 from bufr sta lp|0,4 to pbufr stx4 talls writc: adlx2 lp|0,2 advance x2 to last word of record writq: adlx2 1,du advance x2 to next l.r. sxl2 nwdpr save l.r. pointer in case of continue cmpx2 nwdpr trc writd skip if we finished buffer tra writb repeat if more writd: null eax0 pbufr develop block length stx0 workt eax4 -1,4 sblx4 workt sxl4 lp|pbufr set length in block control word ldx1 wtrsk return address ldx5 0,du ldx7 0,du tra 0,1 return to caller cdump: stz lp|0,2 skip to first logical record stz lp|0,4 zero output block control word adlx4 1,du bump tally stx4 talls tra writc dump: null ldx0 talls adlx0 20,du cmpx0 lp|endbuf trc writd dump4: null dump0: eax5 0,2 x5 = beginning of logical record ldq lp|1,2 beginning address/line i.d. lda lp|1,5 save address for next line ana -1,du ora =o202020,dl sta lp|1,5 lda =o777777,du asa lp|0,5 now only binary data wd count adlx2 2,du first binary data word dump1: lda 21,du ora =o374,dl build control word for 21 word line sta lp|0,4 stx4 lrcw save location of rcw adlx4 1,du ldx0 5,du convert and store line address lda 0,du als 3 lls 3 sblx0 1,du tpl *-3 sta lp|0,4 adlx4 1,du orq =o202020,dl trailing blanks after line i.d. stq lp|0,4 store line i.d. and 3 blanks adlx4 1,du ldx0 5,du set shift count-1 ldx1 lp|0,5 set x1 for words/line tze dump2 none if length = 0 cmpx1 8,du tnc dump3 = exact if <= 8 ldx1 8,du = 8 if more in record dump3: ldx7 11,du ldq lp|0,2 als 3 lls 3 sblx0 1,du tpl *+4 ldx0 5,du sta lp|0,4 store expanded word adlx4 1,du sblx7 1,du tpl dump3+2 adlx2 1,du sblx1 1,du tze dump2 exit tmi dump2 exit ldq =o202000,du add two trailing blanks after each expanded lls 6 data word sblx0 1,du lls 6 sblx0 1,du tpl dump3 ldx0 5,du sta lp|0,4 adlx4 1,du tra dump3 dump2: null ldq =o770101010101 lls 6 sblx0 1,du tpl *-2 sta lp|0,4 store slew characters adlx4 1,du stx4 talls dumpa: null ldx1 lp|0,5 no. of binary words in l.r. sblx1 8,du tze dump7 end of l.r. tmi dump6 last line was partial stx1 lp|0,5 ldq lp|1,5 adlq 8,du stq lp|1,5 dumpb: null eax0 0,4 next address in expansion buffer adlx0 20,du cmpx0 lp|endbuf tnc dump1 tra writd quick fix dump6: eax0 -1,4 correction to rcw for partial record sblx0 lrcw ldx7 lrcw stx0 lp|0,7 record length to rcw dump7: eax0 0,4 adlx0 20,du cmpx0 lp|endbuf has buffer been filled tnc writq+1 no sxl2 nwdpr cmpx2 nwdpr has 120 wd buffer been exhausted trc writd yes - write it out tra writd quick fix txtnd: null " " Temporary " tempd arglst(5) temp desc2 temp prea temp op05a temp op15a temp op20a temp op40a temp mo10a temp mo20a temp mo30a temp comp20a temp wdcnt temp wr10a temp wr20a temp writxa temp snpmsa temp snp5a temp span4a temp span6a temp sizea temp wtrsk temp nwdpr temp talls temp lrcw temp bsn temp workt temp mod use intstat join /link/intstat icir: bss ,4 ic+ir,bar,eibf,oibf bufad: bss ,1 bufad1: bss ,1 endbuf: bss ,1 odd bss ,1 bufr: bss ,120 bufnd: null pbufr: bss ,320 pbfnd: null eisbf: bss ,24 eight savrgu: bss ,8 savreg: bss ,8 " " GCOS data base " eight segdef ssa ssa: null bss .sstke,8 eight bss .sreg,8 bss .salim,2 even bss .stemp,10 .crlal: dec 0 .creis: bss ,1 even .crmsz: zero 0,500 xend: null end  gcos_mme_syot_.pl1 09/09/83 1404.1rew 09/09/83 1007.7 102870 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ******************************************************************************************** ******************************************************************************************** * * * M M E G E S Y O T * * * MME GESYOT is used to transmit output records to the SYSOUT collector media * for subsequent printing or punching. SYSOUT collects these records, which may * constitute several different reports for each concurrent activity. * * * CALLING SEQUENCE * * MME GESYOT * ZERO FCB,0 * return * * where FCB is the location (word 0) of the file control block for the file * containing to records to be transmitted. FCB+2 contains the DCW location. * The DCW contains the buffer location and length. * * * or to request backdoor file processing: * * MME GESYOT * BCI 1,000FC * BCI 1,AAAAAB * denial return * normal return * * where FC is the file code of the users mass storage file; * AAAAA is the banner string used to identify the output; * and B is the type of output (1=punch,2=bcd print,3=ascii print). * * * WRITTEN BY DICK SNYDER NOVEMBER 30, 1970 * RETYPED BY T.CASEY DECEMBER 1972 * MODIFIED BY T.CASEY DECEMBER 1972, MAY 1974 * MODIFIED BY D. KAYDEN MARCH 1974, APRIL 1974, AUGUST 1974 * Modified by M. R. Jordan, April 1977 * Modified by S. C. Akers December 1981 Change \014 to %page * ******************************************************************************************** ******************************************************************************************** */ gcos_mme_syot_: proc (mcp, increment); %page; dcl addr builtin; dcl addrel builtin; dcl bit36 bit (36) aligned based; dcl block_end fixed bin(24); dcl buffer_size fixed bin(24); dcl dcw_loc fixed bin(24); dcl dcw_ptr ptr; dcl execution_report_flag bit (1) aligned init ("0"b); dcl fc char (2); dcl fcb_loc fixed bin(24); dcl fcword_ptr ptr; dcl file_ptr ptr; dcl fixed builtin; dcl gcos_et_$bad_syot_buffer_ptr fixed bin(35) ext; dcl gcos_et_$bad_syot_media_code fixed bin(35) ext; dcl gcos_et_$bad_syot_status_ptr fixed bin(35) ext; dcl gcos_et_$no_reason fixed bin(35) ext; dcl gcos_et_$output_limit_exceeded fixed bin(35) ext; dcl gcos_et_$syot_alloc_err fixed bin(35) ext; dcl gcos_et_$syot_buffer_too_high fixed bin(35) ext; dcl gcos_et_$syot_rec_size_err fixed bin(35) ext; dcl gcos_mme_bort_$system entry options (variable); dcl gcos_write_$record_ptr ext entry (ptr, char (*), bit (8)); dcl gseg_ptr ptr; dcl i fixed bin(24); dcl increment fixed bin(24); dcl last_file_ptr ptr; dcl null builtin; dcl rcw_loc fixed bin(24); dcl rcw_ptr ptr; dcl rec_len fixed bin(24); dcl record_string char (record_string_len) based (record_string_ptr); dcl record_string_len fixed bin(20); dcl record_string_ptr ptr; dcl storage_limit fixed bin(24); dcl substr builtin; dcl total_rec_len fixed bin(24); %page; dcl 1 dcw aligned based (dcw_ptr), 2 address bit (18) unaligned, 2 fill bit (6) unaligned, 2 count bit (12) unaligned; dcl 1 fcword aligned based (fcword_ptr), 2 pad bit (24) unaligned, 2 fc1 bit (6) unaligned, 2 fc2 bit (6) unaligned; dcl 1 rcw aligned based (rcw_ptr), 2 record_len fixed bin(17) unaligned, 2 processed bit (1) unaligned, 2 control bit (5) unaligned, 2 media_code bit (6) unaligned, 2 report_code bit (6) unaligned; dcl 1 word aligned based, 2 upper bit (18) unaligned, 2 lower bit (18) unaligned; %page; /* Make sure we have SYSOUT limits left. */ if gcos_ext_stat_$sysout_lines > gcos_ext_stat_$sysout_limit then do; call gcos_mme_bort_$system (gcos_et_$output_limit_exceeded); gcos_ext_stat_$sysout_limit = gcos_ext_stat_$sysout_limit+10000; end; /* Now that we know we have the SYSOUT limits to proceed, initialize some needed data items and continue. */ increment = 1; gseg_ptr = gcos_ext_stat_$gcos_slave_area_seg; storage_limit = gcos_ext_stat_$storage_limit; scup = addr (mc.scu); /* Get the FCB location from the first word after the MME. If the FCB location is zero, this is a request for a "backdoor" file print. We do not support this, so return the status to say no backdoor file allocated. */ fcb_loc = fixed (addrel (gseg_ptr, fixed (scu.ilc, 18)+1) -> word.upper, 18); if fcb_loc = 0 then do; mc.a = (33)"0"b || "101"b; increment = 2; return; end; /* Validate the location of word -3 of the FCB. If good then zero the word, as it is used later for a status return; */ if fcb_loc - 3 >= storage_limit then call gcos_mme_bort_$system (gcos_et_$bad_syot_status_ptr, "MME GESYOT status return word is outside slave limits."); addrel (gseg_ptr, fcb_loc-3) -> bit36 = (36)"0"b; /* Now we must get the file code from the FCB and look it up in the file code table. If the file code is "00" or " ", however, we know it is to go on the execution report. Also, if the file code is not found in the file code table the output is to be put on the execution report. */ if fcb_loc-4 >= storage_limit then call gcos_mme_bort_$system (gcos_et_$no_reason, "MME GESYOT file code word is outside slave limits."); fcword_ptr = addrel (gseg_ptr, fcb_loc-4); substr (fc, 1, 1) = xlate (fixed (fc1, 6)); substr (fc, 2, 1) = xlate (fixed (fc2, 6)); if fc ^= "00" & fc ^= " " then do; do i = 1 to hbound (save_data.fibs, 1); if fct.filecode (i) = fc then do; if fct.sysout (i) & ^fct.dac (i) then go to hit; call gcos_mme_bort_$system (gcos_et_$syot_alloc_err, "MME GESYOT file ^a is not assigned to SYSOUT.", fc); end; end; end; execution_report_flag = "1"b; /* Verify the locations of the DCW word, and buffer. Also check the buffer size. If the buffer is empty (size = 0) then don't waste any time on this request. */ hit: ; dcw_loc = fixed (addrel (gseg_ptr, fcb_loc+2) -> word.lower, 18); if dcw_loc >= storage_limit then call gcos_mme_bort_$system (gcos_et_$bad_syot_buffer_ptr, "MME GESYOT buffer is outside slave limits."); dcw_ptr = addrel (gseg_ptr, dcw_loc); buffer_size = fixed (dcw.count, 12); if buffer_size > 320 then call gcos_mme_bort_$system (gcos_et_$syot_rec_size_err, "MME GESYOT buffer length is greater than 320 words."); if buffer_size = 0 then go to return_stat; block_end = fixed (dcw.address, 18) + buffer_size; if block_end >= storage_limit then call gcos_mme_bort_$system (gcos_et_$syot_buffer_too_high, "MME GESYOT buffer not entirely within slave limits."); /* Now we can process the data buffer passed by the slave job. But first let's initialize some data items. */ last_file_ptr = null; /* NOTE: The GCOS SYSOUT module assumes that the buffer is located two words beyond the DCW word. This assumption is duplicated in the following statement. */ rcw_loc = dcw_loc + 2 + 2; /* Position to the next record in the buffer and verify it's length. */ next: ; rcw_ptr = addrel (gseg_ptr, rcw_loc); /* move pointer to rcw of next record */ rec_len = rcw.record_len; if rec_len > 320 then call gcos_mme_bort_$system (gcos_et_$syot_rec_size_err, "MME GESYOT Record Control Word (RCW) specifies record length greater than 320 words."); /* Now see if the record is to be processed. Check the bit that tells us it has already been processed and check for zero media code or record length. */ if rcw.processed | rcw.media_code = "00"b3 | rec_len = 0 then do; call write; last_file_ptr = null; go to bump; end; /* Process the special media codes for COBOL-74. These records have some information in the first two characters that must be done away with. These are media codes 9 and 13. */ if rcw.media_code = "11"b3 then do; substr (addrel (rcw_ptr, 1) -> bit36, 1, 12) = "1717"b3; rcw.media_code = "03"b3; end; else if rcw.media_code = "15"b3 then do; substr (addrel (rcw_ptr, 1) -> bit36, 1, 18) = "177177"b3; rcw.media_code = "07"b3; end; /* If this data is to be put on the execution report, then do so. Only one record will be processed from the buffer. */ if execution_report_flag then do; last_file_ptr = gcos_ext_stat_$er; record_string_ptr = rcw_ptr; total_rec_len = rec_len + 1; call write; go to return_stat; end; /* Verify the media code of the record. It must be print or punch. If a bad media code is encountered, abort the slave job. Print media codes are 3 and 7, punch media codes are 1, 2, and 10. */ if fixed (rcw.media_code, 6, 0) < 11 then goto media (fixed (rcw.media_code, 6, 0)); else goto bad_media; media (1): ; media (2): ; media (10): ; file_ptr = gcos_ext_stat_$pch; goto media_ok; media (3): ; media (7): ; file_ptr = gcos_ext_stat_$prt; goto media_ok; media (0): ; media (4): ; media (5): ; media (6): ; media (8): ; media (9): ; bad_media: ; call gcos_mme_bort_$system (gcos_et_$bad_syot_media_code, "MME GESYOT media code not print or punch."); media_ok: ; /* If this record has the same destination as the last record, then simply add it to the accumulated length. If not, write it and start a new accumulation. Make sure we count the lines/cards produced to enforce SYSOUT limits. */ if last_file_ptr = file_ptr then total_rec_len = total_rec_len+rec_len+1; else do; call write; last_file_ptr = file_ptr; record_string_ptr = rcw_ptr; total_rec_len = rec_len + 1; end; gcos_ext_stat_$sysout_lines = gcos_ext_stat_$sysout_lines + 1; /* After marking the record as processed, calculate the new RCW location and see if we are, finished with the current buffer. If we are, make sure all records have been written to the collection file. */ bump: ; rcw.processed = "1"b; rcw_loc = rcw_loc + rec_len + 1; if rcw_loc < block_end then go to next; call write; /* At this point we are ready to return to the slave job. Make sure we mark the status work to show a termination status with no errors. */ return_stat: ; addrel (gseg_ptr, fcb_loc-3) -> bit36 = "400000000000"b3; return; %page; /* The write procedure acctually writes the accumulated records to the proper collection file for later processing by gcos_sysprint or gcos_syspunch. */ write: proc; /* Check first to see if we have anything to write... If not, then simply exit. */ if last_file_ptr ^= null then do; record_string_len = total_rec_len * 4; call gcos_write_$record_ptr (last_file_ptr, record_string, "0"b); end; return; end write; %page; %include gcos_ext_stat_; %page; %page; %include gcos_xlate_bcd_ascii_; end gcos_mme_syot_;  gcos_mme_time_.pl1 09/09/83 1404.1rew 09/09/83 1007.7 27999 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_mme_time_: proc (mcp, increment); /* ***************************************************************************************** ******************************************************************************************* * * * M M E G E T I M E * * * MME GETIME provides the requesting program with the date and time of day. Results * are returned in the following manner: * * C(A) 0-11 month (BCD digits) * C(A) 12-23 day (BCD) * C(A) 24-35 year (BCD) * * C(Q) 0-35 time of day (1/64 milliseconds past midnight) * * Author: DICK SNYDER NOVEMBER 10,1970 * Change: T. CASEY SEPTEMBER 1973 TO RETURN LOCAL TIME INSTEAD OF E.S.T. * Change: Dave Ward 05/29/81 appropiate FP precision. * ******************************************************************************************* ***************************************************************************************** */ increment = 0; /* no param words to skip */ time = clock (); /* get current time */ call date_time_ (time, date_time); /* get ascii date and time */ /* Build string of ascii date with out the slashes and convert to bcd */ substr (temp, 1, 2) = substr (date_time, 1, 2); /* get month */ substr (temp, 3, 2) = substr (date_time, 4, 2); /* get day */ substr (temp, 5, 2) = substr (date_time, 7, 2); /* get year */ call gcos_cv_ascii_gebcd_ (addr (temp), 6, addr (mc.regs.a), 6); /* put bcd in user's a reg */ call decode_clock_value_ (time, m, d, y, i, w, z); /* just to get time since midnight local time, in microseconds, into i */ i = divide (i, 1000, 71, 0); /* convert to msecs */ addr (mc.regs.q) -> mc64ths = i*64; /* convert to 64ths of a msec */ return; %page; /* Variables for gcos_mme_time_: */ /* IDENTIFIER ATTRIBUTES */ dcl clock builtin; dcl d fixed bin(24); dcl date_time char (24) /* ascii date and time */; dcl date_time_ ext entry (fixed bin(71), char (*)); dcl decode_clock_value_ entry (fixed bin(71), fixed bin(24), fixed bin(24), fixed bin(24), fixed bin(71), fixed bin(24), char(3)); dcl gcos_cv_ascii_gebcd_ ext entry (pointer, fixed bin(24), pointer, fixed bin); dcl i fixed bin(71) /* temp */; dcl increment fixed bin(24)/* no of param words to skip */; dcl m fixed bin(24); dcl mc64ths fixed bin(35)based; dcl temp char (6) aligned /* temp */; dcl time fixed bin(71) /* time in microseconds */; dcl w fixed bin(24); dcl y fixed bin(24); dcl z char (3); %page; %include mc; end gcos_mme_time_;  gcos_mme_user_.pl1 09/09/83 1404.1rew 09/09/83 1007.7 19449 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_mme_user_: proc (mcp, increment); dcl code fixed bin(35); dcl gcos_et_$unimp_mme fixed bin(35) ext; dcl gcos_mme_bort_$system entry options (variable); dcl handler_known bit (1) aligned int static init ("0"b); dcl hcs_$make_ptr ext entry (ptr, char (*), char (*), ptr, fixed bin(35)); dcl increment fixed bin(24); /* No. of args. passed to this mme. */ dcl mme_geuser ext entry (ptr, fixed bin(24)); /* name of user's handler is different from that of this proc */ dcl null builtin; dcl ret_ptr ptr ; if handler_known then do; /* if he terminated it after it was previously initiated in this process, he is sophisticated enough to handle the linkage fault without our help */ call_handler: call mme_geuser (mcp, increment); return; end; ret_ptr = null; /* try to find mme_geuser in the search rules, to avoid giving the average gcos user a linkage fault */ call hcs_$make_ptr (null, "mme_geuser", "", ret_ptr, code); /* code might be error_table_$segknown , so check pointer instead */ if ret_ptr ^= null then do; handler_known = "1"b; /* don't come this way again, in this process */ goto call_handler; end; if gcos_ext_stat_$save_data.debug then /* if he said "-db" he is no average user */ goto call_handler; /* so go give him a linkage fault */ /* fall thru to tell user about missing handler, and abort job */ increment = 0; /* Indicate no args. passed to this mme. */ call gcos_mme_bort_$system (gcos_et_$unimp_mme, "No procedure supplied for MME GEUSER."); return; %include gcos_ext_stat_; end gcos_mme_user_;  gcos_mme_wake_.pl1 09/09/83 1404.1rew 09/09/83 1007.7 7578 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_mme_wake_: proc (mcp, increment); /* Handler for the gewake mme. It does nothing but return to the caller. */ dcl mcp ptr; /* Machine conditions ptr. */ dcl increment fixed; /* No. of args. passed to this mme. */ increment = 0; /* Indicate no args. passed to this mme. */ return; end gcos_mme_wake_; */ ----------------------------------------------------------- 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 */