PNOTICE_gcos.alm 11/14/89 1100.2r w 11/14/89 1100.1 3555 dec 1 "version 1 structure dec 2 "no. of pnotices dec 3 "no. of STIs dec 156 "lgth of all pnotices + no. of pnotices acc "Copyright, (C) Honeywell Information Systems Inc., 1989" acc "Copyright (c) 1989 by Massachusetts Institute of Technology and Honeywell Information Systems, Inc." aci "C1GBEM0B0000" aci "C2GBEM0B0000" aci "C3GBEM0B0000" end  gcos.pl1 12/11/84 1357.5rew 12/10/84 1035.9 319680 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos: gc: proc; /* This procedure is invoked when a user types the "gcos" command. It interprets all of the command arguments, setting switches and storing values in external static variables, and it verifies the existence of the input segment(s). It then calls gcos_gein_, which processes the gcos job deck and runs the job. */ %page; /* Author: T. CASEY MAR 1973 Change: T. CASEY OCT 1973 FEB 1974 APR 1974 MAY 1974 AUG 1974 Change: D. KAYDEN FEB 1975 Change: M. R. JORDAN JUN 1976 To process "-smc" control argument. Change: Mel Wilson MAR 1979 For gtss interface and -ident option. Change: Mel Wilson OCT 1979 For gtss ring_bracket compatibility. Change: Dave Ward MAY 1981 DBS entry, source reorganized. Change: Scott Akers DEC 1981 Fix "-syot_dir" control_arg. Change "expand_path_" to "expand_pathname_." 2.5 FEB 1982 Add "-block" control_arg. Change: Ron Barstad 2.5 Sep 1982 Fix usage statement to be only 1 line Change: Ron Barstad 3.0 Feb 1983 Change version to "3.0" for 4JS3 Change: Ron Barstad 3.1 83-02-15 Add init for $param vaules to "" Fix bug: was not processing past first -param value! missplaced label end_arg_loop Allow non-control args to start with "-" by adding -string arg Allow null "" param after -param. Change: Ron Barstad 3.2 83-04-28 Delete long gcos$dbs usage message Update spawn & task versions Make default buffer size 4096, remove workspace.acs check Declared some undeclared builtins Change: Ron Barstad 3.3 83-08-02 Added activity_card_num to ext static Change: Ron Barstad 3.4 83-08-10 Added 4js3 control cards */ %page; me = "gcos (4.0)"; goto gcos_common; spawn: entry; temp_spawnflag = "1"b; me = "gcos$spawn (4.0)"; goto gcos_common; task: entry; temp_taskflag = "1"b; me = "gcos$task (4.0)"; goto gcos_common; dbs: entry; call cu_$arg_ptr (i, pp, lp, code); call gcos_dbs; goto exit_gcos; gcos_common: on condition (cleanup) begin; simulator_already_active = "0"b; end; if simulator_already_active then do; call com_err_ ( 0 , me , "job already active, you must complete it (""start"")" ||"^/or terminate it (""release"") before starting another one." ); goto fatal_error; end; call initialize_routine; /* Do all the init stuff. */ call process_args; /* Now, dink around with the args. */ /* NOW ALL ARGUMENTS HAVE BEEN PROCESSED - SEE IF THERE WERE ANY PROBLEMS */ if ^job_deck then do; /* If job deck pathname not given, complain. */ call com_err_ (error_table_$noarg, me, "No job deck pathname given."); goto fatal_error; end; if expecting then do; /* If we were waiting for something, complain. */ call com_err_ (error_table_$noarg, me, "^/Could not find expected argument after ""^a"" ", targ); goto fatal_error; end; /* check for job deck segment pathname to be used as job id */ if id_jd | gcos_ext_stat_$job_id = "" then do; /* default, if not specified */ /* get rid of ".gcos" appendage, if it's there */ i = index (jd_ename, ".gcos"); /* look for .gcos */ if i = 0 then /* if not there */ i = length (rtrim (jd_ename))+1; if i > 19 /* If job ID longer than 18 characters, */ then do; /* truncate it and warn user. */ i = 19; /* 19 since i-1 is used below */ call com_err_ (0, me, "Job ID too long. Using first 18 chracters" || " (""^a"")", (substr (jd_ename, 1, 18))); end; gcos_ext_stat_$job_id = substr (jd_ename, 1, i-1); end; /* end of id_jd do group */ /* SET SYSOUT OPTIONS */ if dpo_given then gcos_ext_stat_$save_data.dprint = "1"b; /* if dprint (or dpunch) options given */ else gcos_ext_stat_$dpo = "-dl"; /* the default is delete */ if dpno_given then gcos_ext_stat_$save_data.dpunch = "1"b; /* then dprint (or dpunch) is implied */ else gcos_ext_stat_$dpno = "-dl"; /* the default is delete */ if gcos_ext_stat_$save_data.dprint then gcos_ext_stat_$save_data.list = "1"b; /* if dprint (or dpunch) to be done */ if gcos_ext_stat_$save_data.dpunch then gcos_ext_stat_$save_data.raw = "1"b; /* then conversion from bcd is implied */ /* see if defaults are to be used */ if ^hold_given then do; /* set defaults, if not told to skip it */ if ^gcos_ext_stat_$save_data.raw then /* if nothing said about punch files */ gcos_ext_stat_$save_data.raw, gcos_ext_stat_$save_data.dpunch = "1"b; /* the default is convert and punch */ if ^gcos_ext_stat_$save_data.list then /* if nothing said about print files */ gcos_ext_stat_$save_data.list, gcos_ext_stat_$save_data.dprint = "1"b; /* the default is convert and print */ end; /* end of set defaults do group */ gcos_ext_stat_$dpno = gcos_ext_stat_$dpno || " -raw"; /* raw option always used, since any other way would produce garbage on the cards */ /* FUSSY WARNING MESSAGES */ if gcos_ext_stat_$save_data.gcos then if gcos_ext_stat_$save_data.no_canonicalize then do; warning_return = ignored_ncan; err_msg = "-no_canonicalize ignored - valid only for ascii job deck segment"; com_err_inconsistent: call com_err_ (0, me, "Warning:" || err_msg); goto warning_return; end; ignored_ncan: if gcos_ext_stat_$save_data.gcos then if gcos_ext_stat_$save_data.truncate then do; warning_return = ignored_truncate; err_msg = "-truncate ignored - valid only for ascii job deck segment"; goto com_err_inconsistent; end; ignored_truncate: /* END OF ARGUMENT LIST PROCESSING */ /* for debugging arg list processing */ if gcos_ext_stat_$stop_code = 1 then do; call ioa_ ("Results of arg list processing:"); call ioa_ ("gcos_ext_stat_$save_data.flgs: ^12.3b", unspec (gcos_ext_stat_$save_data.flgs)); call ioa_ ("job id: ^a", gcos_ext_stat_$job_id); call ioa_ ("temp_dir: ^a", gcos_ext_stat_$temp_dir); call ioa_ ("input seg: ^a", gcos_ext_stat_$input_segment_path); call ioa_ ("jd_ename: ^a", jd_ename); call ioa_ ("dprint options: ^a", gcos_ext_stat_$dpo); call ioa_ ("dpunch options: ^a", gcos_ext_stat_$dpno); call ioa_ ("pdir: ^a", gcos_ext_stat_$pdir); call ioa_ ("save_dir: ^a", gcos_ext_stat_$save_dir); call ioa_ ("nargs: ^d", nargs); call ioa_ ("DB:"); call db; /* to allow looking at others */ /* .q to get out of db */ goto fatal_error; /* to get any necessary cleaning up done */ end; gcos_ext_stat_$abort_return = fatal_error; /* set up abort nonlocal goto */ gcos_ext_stat_$validation_level = get_ring_ (); /* set up ring numbers for created branches */ if gcos_ext_stat_$save_data.gtssflag & (gcos_ext_stat_$validation_level < 4) then do; gcos_ext_stat_$dir_rings (1) = gcos_ext_stat_$validation_level; gcos_ext_stat_$dir_rings (2), gcos_ext_stat_$dir_rings (3) , gcos_ext_stat_$seg_rings (*) = 4; end; else gcos_ext_stat_$dir_rings (*), gcos_ext_stat_$seg_rings (*) = gcos_ext_stat_$validation_level; call gcos_gein_ ; /* go read job deck and run job */ fatal_error: /* if an abort occurs, control returns here via a nonlocal transfer to gcos_ext_stat_$abort_return, causing the stack to be cleaned up, and cleanup handlers to be invoked */ simulator_already_active = "0"b; /* allow simulator to be invoked again */ exit_gcos: ; return; %page; gcos_dbs: proc; /* Process argument(s) to switch debug switches. */ do i = 1 by 1; call cu_$arg_ptr (i, pp, lp, code); if code ^= 0 then do; if i<2 then call print_dbs_usage; goto fatal_error; end; if targ = "-print" | targ = "-pr" then do; do j = 1 to hbound (dbs_names, 1); call ioa_ ( "^3i. ^[ ON^;OFF^] ^a" , j , dbsv (j) , dbs_names (j) ); end; end; else do; if lp<2 then targ_fc, tl = length (targ); /* Use whole targ. */ else do; /* Examine for leading "^" and comma. */ if substr (targ, 1, 1) = "^" then targ_fc = 2; /* Start with 2nd character of targ, exclude "^". */ else targ_fc = 1; /* Start with 1st character of targ. */ tl = index (substr (targ, targ_fc), ","); if tl = 0 then /* No comma in argument string. */ tl = length (targ) - targ_fc + 1; /* Use the whole available string. */ else /* There is a comma. */ tl = tl - 1; /* Use the available string up to the comma. */ end; do j = 1 to hbound (dbs_names, 1); if substr (targ, targ_fc, tl) = dbs_names (j) then do; dbsv (j) = (targ_fc = 1); /* Locate the portion of "targ" after the first comma. */ if (targ_fc+tl) > length (targ) then do; /* There is none. */ ta_fc = 1; /* Let 1st character be at one, */ ta_ln = 0; /* but the length is zero (to allow substring). */ end; else do; /* Ther is a comma. */ ta_fc = targ_fc+tl+1; /* Location of 1st character after comma. */ ta_ln = length (targ) - ta_fc +1; /* Number of character. */ end; if substr (targ, targ_fc, tl) = "filecode" then call gcos_mme_inos_$inos_trace_filecode (substr (targ, ta_fc, ta_ln)); else if substr (targ, targ_fc, tl) = "trace_mme" then call gcos_process_mme_$mme_trace (substr (targ, ta_fc, ta_ln)); else if substr (targ, targ_fc, tl) = "stop_mme" then call gcos_process_mme_$mme_stop (substr (targ, ta_fc, ta_ln)); goto dbs_next; end; end; call com_err_ ( /* Report dbs arg error. */ 0 , "gcos$dbs" , "Arg ^i ""^a"" unknown. Need -print (-pr) or switch name." , i , substr (targ, targ_fc, tl) ); dbs_next: ; end; end; return; end gcos_dbs; %page; print_dbs_usage: proc; /* Prints gcos_dbs usage message. */ call gcos_print_call_ ( "Usage: gcos$dbs arg ..." /* DON'T PRINT THIS: , "args:" , " -print, -pr|Print names of switches." , " name or ^name|Switch name value from following:" , "|attach_file" , "|open_file" , "|msf_test" , "|dollar" , "|nondollar" , "|filecode{,-print,file-code[DEFAULT all codes]}" , "|mme_inos_trace" , "|mme_inos_stop" , "|mme_call" , "|trace_mme{,-print,-all[DEFAULT],-on[DEFAULT],-off,-clear,mme#|mme-name}" , "|stop_mme{,-print,-all[DEFAULT],-on[DEFAULT],-off,-clear,mme#|mme-name}" */ ); return; end print_dbs_usage; %page; initialize_routine: proc; /* Perform initialization */ /* INITIALIZE EXTERNAL STATICS USED IN ARGUMENT PROCESSING */ simulator_already_active = "1"b; query_info.yes_or_no_sw = "1"b; expecting = "0"b; literal_string = "0"b; buffsize_next = "0"b; string (gcos_ext_stat_$dbs) = string (dbsv); save_data.activity_no = 0; gcos_ext_stat_$incode, gcos_ext_stat_$gf = 0; gcos_ext_stat_$last_mme = 0; gcos_ext_stat_$ldrss = 0; gcos_ext_stat_$max_activities = 63; gcos_ext_stat_$save_data.param = ""; gcos_ext_stat_$tape_buffer_size = 4096; save_data.sqindex = 1; unspec (gcos_ext_stat_$save_data.flgs) = (72)"0"b; /* zero out gcos_ext_stat_$save_data before argument processing */ gcos_ext_stat_$job_id = ""; /* must be initialized to blanks so we can tell whether to set it to default after all args processed */ gcos_ext_stat_$er , gcos_ext_stat_$gcos_slave_area_seg , gcos_ext_stat_$patchfile_ptr , gcos_ext_stat_$pch , gcos_ext_stat_$prt , gcos_ext_stat_$rs , gcos_ext_stat_$saveseg_ptr , gcos_ext_stat_$sig_ptr , gcos_ext_stat_$temp_seg_ptr = null (); gcos_ext_stat_$system_free_pointer = get_system_free_area_ (); /* get pointer to free area for allocating things in */ gcos_ext_stat_$save_data.spawnflag = temp_spawnflag; /* set entry point gcos_ext_stat_$save_data */ gcos_ext_stat_$save_data.gtssflag = temp_spawnflag; gcos_ext_stat_$save_data.taskflag = temp_taskflag; /* GET PROCESS, WORKING AND DEFAULT WORKING DIRECTORY PATHNAMES FOR USE IN FILE NAMES */ gcos_ext_stat_$temp_dir, /* temp_dir = pdir, by default */ gcos_ext_stat_$pdir = rtrim (get_pdir_ ()); /* put it in ext static varying string */ save_data.syot_dir, /* syot_dir and save_dir = wdir, by default */ gcos_ext_stat_$save_dir = rtrim (get_wdir_ ()); /* put in ext static varying string */ save_data.pathname_prefix = rtrim (get_default_wdir_ ()) ; /* pathname_prefix = default_wdir_ by default */ save_data.skip_umc = "1"b ; return; end initialize_routine; %page; print_call: proc; /* Display on caller's terminal the calling sequence. */ call gcos_print_call_ ( "Usage: gcos JOB_DECK_PATH {-control_args}" /* , "" , "job_deck_path|Pathname of JCL file, can be a Multics segment or GCOS file" ||" regulated by control argument and suffix." , "" , "control_args:" , " -gcos, -gc|Job deck segment is in gcos file format (not required if pathname ends in "".gcos"")." , " -ascii, -aci|Job deck segment is Multics ascii format (to override "".gcos"")." , " -nosave, -nosv|Do not save (make restartable) any activities (in a resumed job)." , " -hold, -hd|Do not perform default conversion and output of sysout files (needed only when some sysout files are to be left in gcos bcd format, since any" ||" of -ls -dp -dpo (or -raw -dpn -dpno) override the defaults for print (punch) files.)." , " -list, -ls|Translate sysout print files to Multics ascii." , " -brief, -bf|Do not print any except fatal error messages on the terminal." , " -long, -lg|Duplicate certain lines from the execution report on the terminal." , " -debug, -db|Give user option of calling debug before aborting job." , " -no_bar,|Do not run slave program in BAR mode (used for debugging.)." , " -nobar, -nb" , " -no_canonicalize,|Do not canonicalize (ascii) job deck segment - it is already" ||" in canonical form (no tabs, and all fields in right columns)." , " -nocan, -no" , " -job_id ID,|ID, used in output file names." , " -id ID" , " ID from:" , " |Job id given as character string (max 18 char)." , " -unique|Use shriekname (result of unique_chars_) as job id." , " -jd_seg, -jd|Use entry name of job deck segment as job id." , "" , " -stop n|Debugging: print results, call db, then return, at stopping point n." , " -temp_dir TD,|TD ispathname of ""gcos pool"" directory, to be used for temporary files." , " -tp TD" , " -syot_dir, -sd|Pathname of ""gcos pool"" directory, to be used for sysout files." , " -smc|Pathname of directory to be used as the gcos SMC in processing prmfl cards." , " -raw|Convert sysout punch files from bcd." , " -dprint, -dp|Dprint -delete converted sysout print files (implies -list)." , " -dpunch, -dpn|Dpunch -delete -raw converted sysout punch files (implies -raw)." , " -dprint_options O,|O are options to use in dprint call (implies -dprint)." , " -dpo O" , " -dpunch_options O,|O are options to use in dpunch call (implies -dpunch)." , " -dpno O" , " -userlib|Allow use of libraries other than the installed ones. (see gcos_gein_)." , " -truncate,|Truncate without warning any ascii input lines longer than 80 characters." , " -tnc, -tc" , " -continue, -ctu|Continue executing job when nonfatal erros occur." , " -lower_case,|Translate BCD sysout and print files to lower case ASCII" ||" (the default is uppercase ASCII, simulating the appearance of BCD printer output)." , " -lc" , " -gtss|Update gtss_user_state_ during execution." , " -ident|Use $ident fields for print & punch banners." , " -block N, -bk N|Specify tape buffer size. (Default = 4096)" */ ); return; end print_call; %page; process_args: proc; /* Process the arguments. */ /* PROCESS ARGUMENT LIST */ call cu_$arg_count (nargs, code); /* get number of arguments */ if code ^= 0 then do; call com_err_ ( /* arg count failed. */ code , "gcos" ); return; end; if nargs = 0 then do; /* if no args, complain */ usage: ; call com_err_ ( /* Print the USAGE msgs. */ error_table_$noarg , me ); call print_call; /* call print_dbs_usage; */ goto fatal_error; end; do i = 1 to nargs; /* process all arguments in this loop */ call cu_$arg_ptr (i, pp, lp, code); /* get pointer to, and length of, argument */ /* targ is declared char(lp) based(pp) */ if code ^= 0 then do; /* if something wrong with it */ call com_err_ (code, me, targ); /* complain, print the arg, if it's there */ goto usage; /* and then go print the usage message */ end; /* NOW, WHAT DO WE HAVE, AND WHAT DO WE NEED? */ /* special handling of -string arg: following arg is NOT a control arg */ if ^literal_string /* can have "-string -string" */ then if (targ = "-string" | targ = "-str") then do; literal_string = "1"b; goto end_arg_loop; end; /* determine type arg we have */ num_arg = cv_dec_check_ (targ, code); /* in case it is numeric */ if lp = 0 then control = "0"b; else if (substr (targ, 1, 1) = "-" & ^literal_string) then do; control = "1"b; processing_params = "0"b; /* no more params */ end; else control = "0"b; /* process substitution parameters for gcos JCL */ if processing_params then do; if i-param_base > hbound (save_data.param, 1) then do; call com_err_ (error_table_$too_many_args, "gcos" , "Maximum number of -parameter arguments is ^d." , hbound (save_data.param, 1)); return; end; if literal_string then param_base = param_base +1; save_data.param (i-param_base) = targ; literal_string = "0"b; goto end_arg_loop; end; /* it is a control arg or a value following one */ if expecting then do; /* if we were expecting a value after a control arg */ /* then see if this is it */ if temp_dir_next then do; if control then do; /* if not a pathname, complain */ err_msg = "(pathname, between -temp_dir and ^a)"; com_err_noarg: call com_err_ (error_table_$noarg, me, err_msg, targ); if print_usage then goto usage; /* optionally, print the usage message */ goto fatal_error; /* otherwise, quit */ end; /* get the directory pathname */ get_dir: ; /* come here from syot_dir */ call expand_pathname_ ((substr (targ, 1, lp)), fullname, ename, code); if code ^= 0 then goto ex_error; call hcs_$status_minf ((fullname), (ename), chase, type, bit_count, code); if code ^= 0 then goto in_error; /* make sure it is a directory */ if type ^= 2 | bit_count ^= 0 then do; call com_err_ (0, me, "expected directory path is that of a ^a:^/^a>^a", type_name (type), fullname, ename); goto fatal_error; end; /* put pathname back together and save it in external static */ itemp = index (fullname, " "); if itemp = 0 then itemp = 169; jtemp = index (ename, " "); if jtemp = 0 then jtemp = 33; fullname = substr (fullname, 1, itemp-1) || ">" || substr (ename, 1, jtemp-1); itemp = itemp + jtemp - 1; /* length of full pathname */ if temp_dir_next then gcos_ext_stat_$save_dir , gcos_ext_stat_$temp_dir = substr (fullname, 1, itemp); else if syot_dir_next then save_data.syot_dir = substr (fullname, 1, itemp); else save_data.pathname_prefix = substr (fullname, 1, itemp) ; syot_dir_next, smc_next , expecting, temp_dir_next = "0"b; /* turn off , expecting switches */ end; else if syot_dir_next then do; if control then do; err_msg = "(pathname, between -syot_dir and ^a)"; goto com_err_noarg; end; goto get_dir; /* share code with temp_dir */ end; else if smc_next then do ; save_data.skip_umc = "0"b ; if control then do ; /* must be a string */ err_msg = "(pathname, between -smc and ^a)" ; goto com_err_noarg ; end ; else goto get_dir ; end ; else if stop_code_next then do; /* if stop code expected, save it */ if code ^= 0 then do; /* if it was non numeric, complain */ err_msg = "(numeric, between -stop and ^a)"; goto com_err_noarg; end; /* end of non numeric stop code do group */ gcos_ext_stat_$stop_code = num_arg; expecting, stop_code_next = "0"b; /* turn off expecting switches */ end; else if buffsize_next then do; if ^valid_buffsize (targ) then goto fatal_error; /* Bail out if buffer size not legal. Error was reported by valid_buffsize. */ buffsize_next = "0"b; expecting = "0"b; end; else if dpo_next then do; gcos_ext_stat_$dpo = targ; /* copy without checking validity */ expecting, dpo_next = "0"b; /* turn off expecting switches */ dpo_given = "1"b; /* remember that we read it */ end; else if dpno_next then do; gcos_ext_stat_$dpno = targ; /* copy without checking validity */ expecting, dpno_next = "0"b; /* turn off expecting switches */ dpno_given = "1"b; /* remember that we read it */ end; else if job_id_next then do; if ^control then do; /* must be a string */ /* impose limit of 18 characters on id (14 more chars max in entry names) */ if lp > 18 then do; lp = 18; /* this cuts end off targ */ /* ***** ***** TEMPORARY FIX TO PREVENT DAEMON JOBS FROM COMPLAINING VIA com_err_ ***** REMOVE WHEN DAEMON IS FIXED TO SUPPLY 18 CHAR JOB ID. TAC, 6 JUNE 74 ***** */ if substr (targ, 7, 1) = "!" then goto ignored_string_end; err_msg = targ; /* this puts first 18 chars of targ in err_msg */ warning_return = ignored_string_end; /* come back here */ com_err_id_too_long: call com_err_ (0, me, "job id too long; using first 18 characters: ^a", err_msg); goto warning_return; /* continue processing */ end; /* end too long do group */ ignored_string_end: gcos_ext_stat_$job_id = targ; end; /* end of job id = string do group */ else if targ = "-unique" then do; /* unique job id wanted */ gcos_ext_stat_$job_id = unique_chars_ ("0"b); end; /* end of -unique do group */ else if targ = "-jd" | targ = "-jd_seg" then do; /* jd seg name wanted as job id */ id_jd = "1"b; /* might not have jd seg path yet. remember to use it later */ end; /* end of -jd do group */ /* NOTE* WE CAN NEVER USE THE SNUMB AS THE JOB ID (UNLESS THE DAEMON GIVES IT TO US AS -id ) SINCE WE HAVE TO USE IT IN FILE PATHNAMES BEFORE WE START READING THE JOB DECK TO GET THE SNUMB CARD */ else do; /* control arg after -id. complain */ err_msg = "(job id, between -job_id and ^a)"; goto com_err_noarg; end; expecting, job_id_next = "0"b; /* turn off expecting switches */ end; else do; /* should never get here */ err_msg = "ERROR IN GCOS. Flags not reset properly."; goto com_err_noarg; end; /* end of ERROR IN GCOS do group */ end; else if control then do; /* if a control arg */ if targ = "-gc" | targ = "-gcos" then gcos_ext_stat_$save_data.gcos = "1"b; else if targ = "-nosv" | targ = "-nosave" then gcos_ext_stat_$save_data.nosave = "1"b; else if targ = "-hd" | targ = "-hold" then hold_given = "1"b; else if targ = "-ls" | targ = "-list" then gcos_ext_stat_$save_data.list = "1"b; else if targ = "-bf" | targ = "-brief" then gcos_ext_stat_$save_data.brief = "1"b; else if targ = "-lg" | targ = "-long" then gcos_ext_stat_$save_data.long = "1"b; else if targ = "-db" | targ = "-debug" then gcos_ext_stat_$save_data.debug = "1"b; else if targ = "-nb" | targ = "-nobar" | targ = "-no_bar" then gcos_ext_stat_$save_data.no_bar = "1"b; else if targ = "-tnc" | targ = "-tc" | targ = "-truncate" then gcos_ext_stat_$save_data.truncate = "1"b; else if targ = "-ctu" | targ = "-continue" then gcos_ext_stat_$save_data.continue = "1"b; else if targ = "-userlib" then gcos_ext_stat_$save_data.userlib = "1"b; else if targ = "-no" | targ = "-no_canonicalize" | targ = "-nocan" then gcos_ext_stat_$save_data.no_canonicalize = "1"b; else if targ = "-aci" | targ = "-ascii" then do; ascii_given = "1"b; gcos_ext_stat_$save_data.gcos = "0"b; end; else if targ = "-id" | targ = "-job_id" then expecting, job_id_next = "1"b; else if targ = "-stop" then expecting, stop_code_next = "1"b; else if targ = "-td" | targ = "-temp_dir" then expecting, temp_dir_next = "1"b; else if targ = "-sd" | targ = "-syot_dir" then expecting, syot_dir_next = "1"b; else if targ = "-raw" then gcos_ext_stat_$save_data.raw = "1"b; else if targ = "-dp" | targ = "-dprint" then gcos_ext_stat_$save_data.dprint = "1"b; else if targ = "-dpn" | targ = "-dpunch" then gcos_ext_stat_$save_data.dpunch = "1"b; else if targ = "-dpo" | targ = "-dprint_options" then expecting, dpo_next = "1"b; else if targ = "-dpno" | targ = "-dpunch_options" then expecting, dpno_next = "1"b; else if targ = "-lc" | targ = "-lower_case" then gcos_ext_stat_$save_data.lower_case = "1"b; else if targ = "-unique" then do; /* unique not after job id - complain */ unexpected_id: /* can come here from below, too */ err_msg = "immediately following -job_id"; call com_err_ (0, me, "-unique out of place - only allowed following -job_id"); goto fatal_error; end; else if targ = "-jd" | targ = "-jd_seg" then goto unexpected_id; /* -jd not after -id so complain */ else if targ = "-smc" then expecting, smc_next = "1"b ; else if (targ = "-parameter" | targ = "-pm" | targ = "-param") then do; processing_params = "1"b; param_base = i; end; else if targ = "-gtss" then gcos_ext_stat_$save_data.gtssflag = "1"b; else if targ = "-ident" then gcos_ext_stat_$save_data.identflag = "1"b; else if targ = "-block" | targ = "-bk" then expecting, buffsize_next = "1"b; else do; /* complain about unrecognized control argument */ call com_err_ (error_table_$badopt, me, targ); goto fatal_error; end; end; /* IT MUST BE A PATHNAME. DO WE WANT ONE? */ /* since we were not expecting anything special, it is either the job deck pathname, or an error */ else if ^job_deck then do; /* if job deck pathname not read yet, this must be it */ job_deck = "1"b; /* remember that we read it */ call expand_pathname_ ((substr (targ, 1, lp)), fullname, ename, code); if code ^= 0 then do; /* if unable to expand... */ ex_error: call com_err_ (code, me, targ); /* print error and */ goto fatal_error; /* exit stage left */ end; jd_ename = ename; /* save entry name for possible use in job id */ /* See if the segment is there */ call hcs_$status_minf ((fullname), (ename), chase, type, bit_count, code); if code ^= 0 then do; /* if any problem */ in_error: call com_err_ (code, me, "^a>^a", fullname, ename); /* print error msg and */ goto fatal_error; /* exit stage rear */ end; if bit_count = 0 then do; /* put out error msg if zero length segment */ call com_err_ (0, me, "zero length job deck segment: ^a>^a", fullname, ename); goto fatal_error; end; /* if it looks OK, save its pathname for later use */ itemp = index (fullname, " "); /* find first blank */ if itemp = 0 then itemp = 169; /* if none, 168 char dirname */ gcos_ext_stat_$input_segment_path = substr (fullname, 1, itemp-1)||">"; itemp = index (ename, " "); /* find end */ if itemp = 0 then itemp = 33; gcos_ext_stat_$input_segment_path = gcos_ext_stat_$input_segment_path||substr (ename, 1, itemp-1); /* if segment has suffix ".gcos", then it is in gcos file format, as gotten from the gcos daemon, gcos utility, or IMCV tape */ if ^ascii_given then /* (unless told to ignore .gcos by -ascii) */ if lp > length (".gcos") then if substr (targ, lp-length (".gcos")+1, length (".gcos")) = ".gcos" then gcos_ext_stat_$save_data.gcos = "1"b; end; /* end processing of job deck pathname */ else do; /* complain about unrecognized NON-control argument */ call com_err_ (0, me, "Unidentified non-control argument: ^a", targ); goto usage; /* and go print usage message */ end; literal_string = "0"b; /* just once */ end_arg_loop: ; end; return; end process_args; %page; valid_buffsize: proc (charbuffsize) returns (bit(1)); /* Check buffer size for validity, report errors if it's not kosher. Set gcos_ext_stat_$tape_buffer_size if it's O.K. */ dcl charbuffsize char (*) parm; dcl buffsize fixed bin (35); code = 0; buffsize = cv_dec_check_ (ltrim (rtrim (charbuffsize)), code); if buffsize < 1 | buffsize > 4096 | code ^= 0 then do; code = error_table_$bad_conversion; call com_err_ (code, me, "Could not use ""^a"" as buffer size." || "^/Permissible values are 1 <= buffsize <= 4096^/^/", ltrim (rtrim (charbuffsize))); goto exit_valid_buffsize; end; gcos_ext_stat_$tape_buffer_size = buffsize; exit_valid_buffsize: ; return (code = 0); end valid_buffsize; %page; /* Variables for gcos: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl bit_count fixed bin(24) /* length of input segment in bits */; dcl buffsize_next bit (1); dcl chase fixed bin(1) init (1); dcl cleanup condition; dcl code fixed bin(35) /* return param. for passing error codes */; dcl com_err_ entry options(variable); dcl cu_$arg_count entry (fixed bin, fixed bin(35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)); dcl cv_dec_check_ entry (char(*), fixed bin(35)) returns (fixed bin); dcl db entry options(variable); dcl dbsv (36)bit(1)static int init((36)(1)"0"b); dcl ename char (32) /* holds entry name of input seg */; dcl error_table_$badopt fixed bin(35) ext static; dcl error_table_$bad_conversion fixed bin(35) ext static; dcl error_table_$big_ws_req fixed bin(35) ext static; dcl error_table_$noarg fixed bin(35) ext static; dcl error_table_$too_many_args fixed bin(35) ext static; dcl err_msg char(100) varying /* varying error message, to save com_err_ calls */; dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); dcl fullname char(168) /* holds pathname of input seg */; dcl gcos_gein_ entry; dcl gcos_mme_inos_$inos_trace_filecode entry(char(*)); dcl gcos_process_mme_$mme_stop entry(char(*)); dcl gcos_process_mme_$mme_trace entry(char(*)); dcl gcos_print_call_ entry options(variable); dcl get_default_wdir_ entry returns (char(168) aligned); dcl get_pdir_ entry returns (char(168) aligned); dcl get_ring_ entry returns (fixed bin(3)); dcl get_system_free_area_ entry returns (ptr); dcl get_wdir_ entry returns (char(168) aligned); dcl hbound builtin; dcl i fixed bin(17); dcl index builtin; dcl ioa_ entry options(variable); dcl j fixed bin(24); dcl jd_ename char(32) /* to hold job deck entry name for possible -id -jd */; dcl length builtin; dcl literal_string bit(1); /* allow non control args to start with - */ dcl ltrim builtin; dcl me char(16) /* command name, for error messages */; dcl null builtin; dcl rtrim builtin; dcl send_message_ entry (char(*), char(*), char(*), fixed bin(35)); dcl simulator_already_active bit (1) aligned int static init ("0"b); dcl size builtin; dcl string builtin; dcl substr builtin; dcl targ_fc fixed bin(24); dcl ta_fc fixed bin(24); dcl ta_ln fixed bin; dcl tl fixed bin(24); dcl type fixed bin(2) /* entry type returned by status_minf calls */; dcl unique_chars_ entry (bit (*)) returns (char(15)); dcl unspec builtin; dcl warning_return label local /* to continue after warning messages */; dcl type_name (0:2) char(8) int static init ( "link", "segment", "msf"); dcl 1 statbuff automatic aligned like status_branch.short; dcl lp fixed bin(21), /* length of argument */ pp ptr, /* pointer to argument */ targ char(lp) based (pp); /* argument from command line */ dcl (print_usage, /* switch on to print usage message */ control, /* switch on if arg begins with "-" */ expecting, /* switch on if specific argument expected next */ stop_code_next, /* switch on when stop code expected next */ dpo_next, /* switch on when dprint options expected next */ dpno_next, /* switch on when dpunch options expected next */ job_id_next, /* switch on when job id expected next */ temp_dir_next, /* switch on when temp dir expected next */ syot_dir_next, /* switch on when syot dir expected next */ smc_next, /* switch on when ssmc dir expected next */ id_jd, /* switch on when jd seg name wanted as job id */ job_deck, /* switch on when job deck path read */ hold_given, /* switch on if hold option read */ processing_params, /* switch on if -parameter control argument has been encountered */ dpo_given, /* switch on if dpo option read */ dpno_given, /* switch on if dpno option given */ temp_spawnflag, /* switch on if entry via gcos$spawn */ temp_taskflag, /* switch on if entry via gcos$task */ ascii_given) /* switch on if -ascii given */ bit (1) init ("0"b); /* switches initially off */ dcl (nargs, /* number of arguments */ num_arg, /* place to put converted numeric argument */ param_base, /* argument number of the -parameter control argument */ jtemp, itemp) /* temporary */ fixed bin(17)init (0); dcl hcs_$status_ entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)); dcl hcs_$status_minf entry (char(*) aligned, char(*) aligned, fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35)); %page; %include gcos_ext_stat_; %page; %include query_info; %page; %include gcos_dbs_names; %page; %include status_structures; end gcos;  gcos_abort_.pl1 09/09/83 1400.3rew 09/09/83 1006.7 29655 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* * THIS PROCEDURE IS CALLED WITH A TWO CHARACTER ABORT CODE (RATHER THAN A * MULTICS ERROR TABLE CODE). IT WILL PRINT THE ABORT CODE AND THE NAME OF * THE CALLING PROCEDURE. IF ANY ADDITIONAL ARGUMENTS ARE PRESENT, IT WILL * REFORMAT THE ARG LIST TO DELETE THE FIRST ARGUMENT, AND THEN CALL ioa_ * TO PRINT THE ADDITIONAL ARGUMENTS. THEN IT WILL CALL gcos_error_ WITH * AN ERROR TABLE CODE OF 9999. gcos_error_ WILL ABORT THE JOB. * * WRITTEN BY DICK SNYDER IN 1971 * MODIFIED BY T. CASEY NOVEMBER 1973 * */ gcos_abort_: proc (code); dcl code char (*); dcl (i, ii) fixed bin(18); dcl (j, offset) fixed bin(24); dcl name char (j) aligned based (z); 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 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) aligned; /* if we declare these pointers as pointers, pointer registers will be used to move them, and faults will occur if any are invalid pointers */ dcl p pointer; dcl cu_$stack_frame_ptr ext entry (pointer); dcl cu_$arg_list_ptr entry (pointer); dcl cu_$gen_call ext entry (entry, pointer); dcl ioa_ ext entry options (variable); dcl pl1_frame_$name ext entry (ptr, ptr, fixed bin(24)); dcl gcos_error_ ext entry (fixed bin(24)); dcl z pointer; dcl (divide, fixed, rel, substr, unspec) builtin; 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 */ out: 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 go to skip; /* 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 = i-2; do j = divide (ii+4, 2, 18, 0) to ii; /* 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 */ skip: call gcos_error_ (9999); return; /* just in case */ end;  gcos_attach_file_.pl1 09/09/83 1400.3rew 09/09/83 1006.7 156510 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* This module will attach a file and associate it with a fib. The fib is assumed to have been initialized by a call to gcos_open_file_. The parameter is a pointer to the fib defining the file. For a perm file, fib.pathnm is the full pathname (168 characters) of a file to be associated with the fib. Otherwise, a scratch file will be created. This file will be created in the sysout directory if the file is print or punch. Otherwise, it will be created in the temporary directory. (The sysout directory is, by default, the working directory, and the temporary directory, the process directory. The user can set them to any other directories, such as a pool directory reserved for short term storage of vary large output files.) If the file size has not been specified in fib.size, it will be set to 3840 words (one GCOS link). The file will be set to the rewound position. */ %page; /* Author: Dick Snyder Dec 15, 1970 Change: T. Casey Apr 1973, Feb 1974 Change: D. Kayden May 1974, Jul 1974, Jan 1975, Mar 1975 Change: R.H. Morrison Jun 1975 Change: M. R. Jordan Sep 1976 Change: Mel Wilson Oct 1979 for gtss compatibility, Jan 1980 for gtss 2.4 Change: S.C. Akers Aug 1981 Clean up format Dec 1981 Fix sysout bug. Put printer & punch files in SYSOUT directory, not SAVE directory. FEB 1982 Add tape-buffer size checking, and pass buffer size to tape DIM. Change: R. Barstad Oct 1982 Provide concurrent access control for IDS2 files Channge: R. Barstad Nov 1982 Fix format of actid for console msgs */ %page; gcos_attach_file_: proc (fp); dcl a_code fixed bin(35) parm; dcl fp ptr parm; fibptr = fp; reattachsw = "0"b; if fib.console | fib.null then goto done; /* this device does not get attached */ if fib.stream ^= "" then file_id = fib.stream; /* file id is provided by caller */ else do i = 1 to hbound (save_data.fibs, 1); /* otherwise use file code for file id */ if fct.fibptr (i) = fibptr then do; /* find first file code for this file */ file_id = fct.filecode (i); goto set_actid; end; end; /* a match must always be found */ set_actid: ; if save_data.activity_no = 0 | substr (file_id, 6) ^= "" then actid = ""; /* don't put actid with syspunch, etc. */ else if substr (save_data.actid, 7, 1) = "0" then /* activity no. < 10 */ actid = "a" || substr (save_data.actid, 8, 1); /* yes - remove leading zero */ else actid = "a" || substr (save_data.actid, 7, 2); /* ascii activity number */ if length (actid) > 0 then name = actid || "_" || file_id; /* now construct stream name */ else name = file_id; fib.stream = name; /* save stream name */ if fib.perm then goto attch; /* perm file has a complete pathname already specified */ if fib.tape then goto attach_tape; /* CONSTRUCT A PATHNAME FOR THE FILE Put print and punch files in a permanent directory so that they can be printed or punched at a later date without disappearing with the process directory when the user is logged out Put other files in a temporary directory (might be process directory or a "pool" directory) */ if fib.print | fib.punch then fib.pathnm = save_data.syot_dir; /* Find the SYSOUT directory. */ else if substr (fib.disp, 1, 1) then fib.pathnm = gcos_ext_stat_$save_dir; else fib.pathnm = gcos_ext_stat_$temp_dir; /* CONSTRUCT ENTRY NAME OF THE FORM: .a.<+filecode> where the < and > are part of the description - not part of the entry name, and was determined during command argument processing; is the current activity number (omitted if act. no. = 0); <+filecode> is the filecode, with *'s replaced by +'s. (or a name placed in fib.pathnm by the caller) */ fib.pathnm = rtrim (fib.pathnm) || ">" || rtrim (gcos_ext_stat_$job_id) || "." || actid || translate (file_id, "+", "*") ; /* Attach file */ attch: ; if gcos_ext_stat_$save_data.gtssflag then /* create the new entry, setting ring brackets */ if fib.perm | fib.print | fib.punch then do; call expand_pathname_ ((fib.pathnm), dir_name, entryname, code); if code ^= 0 then do; err_msg = "from expand_pathname_ ^a"; goto error_rtrn; end; call user_info_ (persid, projid, acct); call hcs_$append_branchx (dir_name, entryname, 01010b, gcos_ext_stat_$seg_rings , "*." || rtrim (projid) || ".*", 0b, 0b, 0, code); if (code ^= 0) & (code ^= error_table_$namedup) & (code ^= error_table_$incorrect_access) then do; err_msg = "from hcs_$append_branchx ^a"; goto error_rtrn; end; /* do gtss allocation */ if fib.perm & (fib.plud ^= "435453"b3) then do; call gcos_verify_tss_access_ (dir_name, entryname, fib.read || fib.write || "0000"b , null (), fib.forced_acl_flag, gcs_status_bits); if gcs_status.status = "4003"b3 then do; code = error_table_$notalloc; err_msg = "No permission on ^a ."; goto error_rtrn; end; else if gcs_status.status ^= "4000"b3 then do; err_msg = "Error verifying access on ^a ."; goto error_rtrn; end; /* FOLLOWING CODE BLOCKED FOR 9.0. Provides concurrent access control. call get_lock_id_ (lock_id); call random_$set_seed (fixed (substr (bit(clock (), 72), 38, 35), 35, 0)); alloc_count = 0; alloc_start_blocked = clock (); try_allocation:; call gtss_mcfc_$open (dir_name, entryname, fib.read||fib.write, lock_id, fib.unique_file_id , addr (gcs_status), code); if gcs_status.status = "4004"b3 then do; / * file busy * / alloc_count = alloc_count + 1; if mod (alloc_count, 5) = 0 then do; call date_time_ (alloc_start_blocked, ascii_time); call ioa_ ("Allocation of ^a>^a blocked since ^a, for ^i attempts." , dir_name, entryname, ascii_time, alloc_count); end; call random_$normal (flt_delay); call timer_manager_$sleep (fixed (flt_delay*10.0, 71, 0)+61, "11"b); / * wait 60 seconds average * / gcs_status.status = "4000"b3; goto try_allocation; end; else if code ^= 0 then do; err_msg = "from gtss_mcfc_$open ^a"; goto error_rtrn; end; */ end; end; /* check for IDS2 file */ if fib.perm & fib.type /* random */ then do; call expand_pathname_ ((fib.pathnm), dir_name, entryname, code); if code ^= 0 then do; err_msg = "from expand_pathname_ ^a"; goto error_rtrn; end; /* check for IDS2 file being initialized in Q2UTIL activity */ if gcos_ext_stat_$activity_name = "q2util" then do; call gcos_ids2_concur_$create_control(dir_name,entryname,code); if code = error_table_$namedup | code = error_table_$segknown then goto try_allocation; if code ^= 0 then do; err_msg = "from gcos_ids2_concur_$create_control ^a"; goto error_rtrn; end; end; else /* check if this IDS2 file has an extrinsic id */ if gcos_ids2_concur_$have_xid(dir_name,entryname,code) then do; if code ^= 0 then do; err_msg = "from gcos_ids2_concur_$have_xid ^a"; goto error_rtrn; end; try_allocation: alloc_count = 0; ascii_snumb = substr(gcos_ext_stat_$save_data.actid,1,5); try_alloc_again: call gcos_ids2_concur_$allocate (dir_name, entryname, fib.read, fib.write, busy_status,code); if code^=0 then do; err_msg = "from gcos_ids2_concur_$allocate ^a"; goto error_rtrn; end; if busy_status /* busy */ then do; alloc_count = alloc_count +1; if mod(alloc_count,5) = 0 then do; call date_time_(clock(), ascii_date_time); ascii_time = substr(ascii_date_time, 11,6); call ioa_("*S^5a NEEDS ^2a PRMFL @ ^a", ascii_snumb, file_id, ascii_time); end; call timer_manager_$sleep(50, "11"b); goto try_alloc_again; end; end; end; if fib.read & ^fib.write then mode = "r"; else mode = "rw"; call ios_$attach (name, "file", fib.pathnm, mode, status); /* attach */ if code ^= 0 then do; err_msg = "from ios_$attach ^a"; goto error_rtrn; end; call ios_$setsize (name, 36, status); /* set elsize to one word */ if code ^= 0 then do; /* fatal error */ err_msg = "from ios_$setsize ^a"; goto error_rtrn; end; if reattachsw then goto reattach_position; if fib.perm then do; /* for permanent files only, determine actual file size */ call ios_$tell (name, "last", "first", fib.last, status); /* get last pointer for fib */ if code ^= 0 then do; /* fatal error */ err_msg = "from ios_$tell last first ^a"; goto error_rtrn; end; fib.size = divide (fib.last+319, 320, 17, 0) * 320; /* round size up to multiple of 320 */ end; if fib.size = 0 then fib.size = 3840; /* if file still has no size, give it one link */ if ^fib.perm then do; /* truncate all temporary files */ call ios_$seek (name, "last", "first", 0, status); if code ^= 0 then do; /* fatal error */ err_msg = "from ios_$seek last first ^a"; goto error_rtrn; end; fib.last = 0; end; if dbs_attach_file then call ioa_ ("gcos_attach_file_ stream=^a, file=^a", fib.stream, fib.pathnm); goto done; %page; attach_tape: ; if fib.serial_no = (5)"20"b3 /* 5 BCD spaces. */ | fib.serial_no = (5)"11"b3 /* 5 BCD 9's */ then do; /* => scratch tape. */ scratch = "1"b; label = "scratch"; end; else do; /* => Specific reel designated. */ scratch = "0"b; label = (5)"X"; /* Set initially to length 5. */ call gcos_cv_gebcd_ascii_ ( /* Convert BCD reel number to ascii. */ addr (fib.serial_no) , 5 , addrel (addr (label), 1) ); end; if fib.tracks = "01"b then label = label||",7track"; /* 7 track tape requested */ else if fib.tracks = "10"b then label = label||",9track"; /* 9 track tape requested */ /* else use installation default */ label = label || ",blk=" || ltrim (char (gcos_ext_stat_$tape_buffer_size)); do j = 1 to hbound (dens, 1) ; if fib.density = dens (j) then do ; label = label||",den="; label = label||dens_string (j); goto determine_mode ; end ; end ; determine_mode: ; if fib.write then mode = "rw"; /* attach with ring */ else mode = "r"; /* attach with no ring */ call ios_$attach ((name), tape_module, (label), mode, status); if code ^= 0 then /* attach error */ call gcos_error_ (code, "tape attach error: label = ^a", label); if scratch then do; call ios_$order ((name), "rewind", null, status); call ios_$write ((name), addr (tape_label), 0, 14, nwr, status); call ios_$order ((name), "rewind", null, status); end; if dbs_attach_file then call ioa_ ("gcos_attach_file_ stream=^a, tape=^a", name, label); done: ; fib.attached = "1"b; /* attachment is complete */ return; %page; error_rtrn: ; /* Come here on all errors from ios_ */ if reattachsw then goto reattach_return; call gcos_error_ (code, err_msg, fib.pathnm); /* pass error code on */ return; %page; reattach: entry (fp, a_code); /* called by gcos_save_$restart */ fibptr = fp; if fib.console | fib.null then goto reattach_return; reattachsw = "1"b; name = fib.stream; goto attch; reattach_position: ; if fib.last > 0 then do; /* if file was non-null, see if it exists */ call ios_$tell (name, "last", "first", l, status); if code = 0 then if l = 0 then /* this means file is lost */ code = 1; /* fake an error code */ if code ^= 0 then do; /* real or fake error code */ err_msg = "from ios_$tell last first ^a"; goto reattach_return; end; end; call ios_$seek (name, "read", "first", fib.current, status); if code ^= 0 then do; err_msg = "from ios_$seek read first ^a"; goto reattach_return; end; if mode = "rw" then call ios_$seek (name, "write", "first", fib.current, status); if code ^= 0 then err_msg = "from ios_$seek write first ^a"; reattach_return: ; a_code = code; if code ^= 0 & ^gcos_ext_stat_$save_data.brief then call com_err_ (code, "gcos_attach_file", err_msg, fib.pathnm); return; %page; /* Variables for gcos_attach_file_: */ /* IDENTIFIER ATTRIBUTES */ dcl acct char; dcl actid char(3) var; dcl addr builtin; dcl addrel builtin; dcl alloc_count fixed bin(24) /* count of allocation delays for a file */; dcl ascii_date_time char(24); dcl ascii_time char(6); dcl ascii_snumb char(5); dcl busy_status bit(1); dcl char builtin; dcl clock builtin; dcl com_err_ entry options (variable); dcl date_time_ entry (fixed bin(71), char(*)); dcl dens (5) bit(4) int static options(constant) init("0001"b, "0010"b, "0100"b, "1001"b, "1100"b); dcl dens_string (5) char(4) int static options(constant) init("200", "556", "800", "1600", "6250"); dcl dir_name char(168); dcl divide builtin; dcl entryname char(32); dcl error_table_$incorrect_access fixed bin(35)ext; dcl error_table_$namedup fixed bin(35)ext; dcl error_table_$notalloc fixed bin(35)ext; dcl error_table_$segknown fixed bin(35) ext static; dcl err_msg char(100) varying; dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); dcl file_id char(8) /* temp */; dcl gcos_cv_gebcd_ascii_ ext entry (ptr, fixed bin(24), ptr); dcl gcos_error_ ext entry options (variable); dcl gcos_ids2_concur_$allocate entry (char(*), char(*), bit(1), bit(1), bit(1), fixed bin (35)); dcl gcos_ids2_concur_$create_control entry (char(*), char(*), fixed bin(35)); dcl gcos_ids2_concur_$have_xid entry (char(*), char(*), fixed bin(35)) returns (bit(1)); dcl gcos_verify_tss_access_ entry (char(*), char(*), bit(6), ptr, bit(1) unal, bit(72)); dcl gcs_status_bits bit(72) based (addr (gcs_status)); dcl hbound builtin; dcl hcs_$append_branchx entry (char(*), char(*), fixed bin(5), (3) fixed bin(3), char(*), fixed bin(1), fixed bin(1), fixed bin(24), fixed bin(35)); dcl ioa_ ext entry options (variable); dcl l fixed bin(21); dcl label char(40)varying aligned; dcl length builtin; dcl ltrim builtin; dcl mod builtin; dcl mode char(2); dcl name char(8); dcl null builtin; dcl nwr fixed bin(21); dcl persid char; dcl projid char(9); dcl reattachsw bit(1) /* reattach entry switch */; dcl rtrim builtin; dcl scratch bit(1) /* scratch tape flag */; dcl substr builtin; dcl tape_module char(5) int static options(constant) init("nstd_"); dcl timer_manager_$sleep entry (fixed bin(71), bit(2)); dcl translate builtin; dcl user_info_ entry (char(*), char(*), char(*)); dcl (i,j)fixed bin(24); dcl 1 tape_label aligned int static options(constant), 2 identifier (2)bit(36) init("272520200600"b3, "002022634320"b3), /* "GE 600 BTL " */ 2 installation bit(36) init("272562202020"b3), /* "ges " */ 2 rsn bit(36) init((6)"20"b3), /* " " */ 2 fsn bit(36) init((6)"20"b3), /* " " */ 2 rlsn bit(36) init("202000000001"b3), 2 crdate bit(36) init("0"b), 2 rdays bit(36) init("0"b), 2 filename bit(72) init("0"b), 2 data (4)bit(36) init((4) (6)"20"b3); dcl 1 gcs_status, 2 status bit(12) unal init("4000"b3), 2 pad1 bit(60) unal; /* variables for gtss concurrency control -- commented out dcl alloc_start_blocked fixed bin(71) / * time of entering blocked state on file allocation * /; dcl fixed builtin; dcl flt_delay float bin (27); dcl get_lock_id_ entry (bit(36) aligned); dcl gtss_mcfc_$open entry (char(*), char(*), bit(6), bit(36) aligned, bit(36) aligned, ptr, fixed bin(35)); dcl index builtin; dcl lock_id bit(36) aligned; dcl random_$normal entry (float bin (27)); dcl random_$set_seed entry (fixed bin(35)); */ %page; %include gcos_ext_stat_; %page; %include gcos_dbs_names; %page; %include gcos_dcl_ios_; end gcos_attach_file_;  gcos_build_pathname_.pl1 12/11/84 1357.5rew 12/10/84 1036.0 35235 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ******************************************************************************************* ******************************************************************************************* * * * Written by M. R. Jordan, October 1977 * Modified: Ron Barstad 83-08-02 Added "_" as a valid fms name char. * Modified: Ron Barstad 84-02-21 Fixed fence check for userid * ******************************************************************************************* ******************************************************************************************* */ %page; gcos_build_pathname_: proc (a_cfdesc_ptr, buf_ptr, dir_name, entry_name, fms_code); cfdesc_ptr = a_cfdesc_ptr; /* Initialize any data items needed. */ fms_code = (72)"0"b; fms_return_code_ptr = addr (fms_code); fms_return_code.termination_indicator = "1"b; %page; /* Now start to build the pathname. First we must get the proper prefix for the user's current mode of operation. */ pathname = save_data.pathname_prefix; if cfdesc_name = (72)"1"b then do; if (^save_data.skip_umc) & gcos_ext_stat_$userid = "" then call gcos_mme_bort_$system (gcos_et_$unimp_mme, "A $ USERID card is necessary if UMC substitution is to be performed by the system."); else name = gcos_ext_stat_$userid; end; else call bcd_to_ascii_ (cfdesc_name, name); if verify (rtrim (name), VALID_FMS_CHARS) ^= 0 then do ; bad_char: code = gcos_et_$fms_bad_cfdesc; fms_return_code.bad_name_loc = rel (cfdesc_ptr); report_error: call gcos_fms_error_ (code, buf_ptr, fms_code); return; end; if ^save_data.skip_umc then pathname = pathname || ">" || rtrim (name); %page; /* At this point we are ready to process the catalog/filename description past the umc name. We must continuously check for the fence (a word equal to minus one) and for an out of bounds condition. */ cfdesc_ptr = addrel (cfdesc_ptr, 4); do while (fence ^= (36)"1"b); call bcd_to_ascii_ (cfdesc_name, name); if verify (rtrim (name), VALID_FMS_CHARS) ^= 0 then goto bad_char ; pathname = pathname || ">" || rtrim (name); cfdesc_ptr = addrel (cfdesc_ptr, 4); end; %page; call expand_pathname_ ((pathname), dir_name, entry_name, code); if code ^= 0 then call gcos_mme_bort_$system (code, """^a"" - attempting to build a Multics pathname from a GCOS catalog/filename description", pathname); return; %page; dcl VALID_FMS_CHARS char (39) static internal options (constant) init (".-0123456789_abcdefghijklmnopqrstuvwxyz"); dcl a_cfdesc_ptr ptr; dcl addrel builtin; dcl bcd_to_ascii_ entry (bit (*), char (*)); dcl buf_ptr ptr; dcl cfdesc_name bit (72) based (cfdesc_ptr); dcl cfdesc_ptr ptr; dcl code fixed bin(35); dcl dir_name char (*); dcl entry_name char (*); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin(35)); dcl fence bit (36) aligned based (cfdesc_ptr); dcl fms_code bit (72) aligned; dcl gcos_et_$fms_bad_cfdesc fixed bin(35) ext; dcl gcos_et_$unimp_mme fixed bin(35) ext; dcl gcos_fms_error_ entry (fixed bin(35), ptr, bit (72) aligned); dcl gcos_mme_bort_$system entry options (variable); dcl name char (12); dcl pathname char (256) varying; dcl rel builtin; dcl rtrim builtin; dcl verify builtin; %page; %include gcos_ext_stat_; %page; %include gcos_fms_return_code_; end gcos_build_pathname_;  gcos_cc_abort_.pl1 09/09/83 1400.3rew 09/09/83 1006.7 19377 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_cc_abort_: proc; /* This procedure processes the $ ABORT card. When this card is encountered, we set up to put UTILITY directive cards onto U*, and continue processing until a terminator is found, at which time we run the activity. If the activity aborts, gcos_run_activity_ will build a MME GECALL UTILITY in the slave prefix, and transfer control to it, with U* being there and waiting for it. We turn on gcos_ext_stat_$save_data.abort_card to tell the rest of the simulator that the $ ABORT card was encountered. If PSW bit 1 is off, we turn on bit 12 so the slave program can look to see if a $ ABORT card was encountered. We use gcos_ext_stat_$save_data.abort_card rather than PSw bit 12 to decide whether to run UTILITY after an abort, and we will only do so in an EXECUTE activity. It is not clear to us whether this is correct: should the slave program be able to create a U* file and turn on bit 12 (in its wrapup, for example) to force an abort subactivity even though there was no $ ABORT card? is it true that abort subactivities are only run in EXECUTE activities, or are they run in all but FORTY and GMAP activities? and what is done if a $ ABORT card is encountered in an illegal context? WRITTEN BY T. CASEY DECEMBER 1973 MODIFIED BY T. CASEY FEBRUARY 1974 */ %include gcos_ext_stat_; dcl (addr, substr) builtin; gcos_ext_stat_$nongcos = "u*"; gcos_ext_stat_$save_data.abort_card = "1"b; if ^substr (save_data.psw, 2, 1) then /* if bit 1 off */ substr (save_data.psw, 13, 1) = "1"b; /* turn on bit 12 */ return; end gcos_cc_abort_;  gcos_cc_activity_cards_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 123975 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_cc_activity_cards_: proc (card, indx, gcos_record); /* This procedure is called whenever an activity definition card (e.g. $ execute, $ fortran) is encountered. A structure is selected from an array of structures in gcos_control_tables_. The information in this structure is used to direct the setting of activity dependent variables such as psw bits, execute flag, time, line, and storage limits etc. Files needed for the activity are opened, as specified in the structure. Once the common processing is completed, specific routines are executed for each card type. Finally, the operands of the card are processed and a return is made to the caller. The format of an activity defining card is as follows. CONTROL CARD: activity definition FORMAT: $ activ arg1,arg2,arg3,...argn FIELDS: arg1-argn: any of the parameters allowed for this type of activity card. Parameters are deck, ndeck, comdk, ncomdk, etc. See the GCOS III manual for description of parameters for each activity card type Author: DICK SNYDER AUGUST 24,1970 Change: T.CASEY DECEMBER 1972, SEPTEMBER 1973, DECEMBER 1973, FEBRUARY 1974, AUGUST 1974 Change: D. KAYDEN MAY 1974 Change: R.H. MORRISON MAY 1975 Change: M. R. Jordan, August 1977 Change: Dave Ward 06/17/81 Reorganized. Change: Ron Barstad 82-11-16 Fixed format of actid for console msgs Change: Ron Barstad 83-08-02 Added activity_card_number initialization Added support for 4js3 new cards */ dcl card char(80) parm /* card image */; dcl gcos_record char(*) parm /* bcd card image, ovarlayed by char(*) variable */; dcl indx fixed bin(24)parm /* offset in cardtable where card type was found */; unspec (zeros) = "0"b; /* init zeros */ gcos_ext_stat_$save_data.activ = "1"b; /* indicate that activity is being defined */ j, save_data.activity_no = save_data.activity_no + 1; /* Increment activity number. */ pic = j; substr (save_data.actid, 7, 2) = pic; if ^gcos_ext_stat_$save_data.nosave then /* if save then/restart */ restart_control.na_hold = "0"b; /* default activity restart option is "REST" */ if save_data.activity_no >= save_data.last_execute_act_no then substr (save_data.psw, 6, 1) = "0"b; gcos_ext_stat_$save_data.this_act_abort, gcos_ext_stat_$save_data.dstar, gcos_ext_stat_$save_data.write_etc = "0"b; /* clear gcos_ext_stat_$save_data used for this card */ gcos_ext_stat_$activity_card_num = gcos_ext_stat_$card_num; /* Activity cards will now be processed using the activity descriptions */ /* found in segment gcos_control_tables_. See gcos_control_tables_.alm for description. */ actptr = addr (gcos_control_tables_$activity_table); /* addr of base of table */ actptr = addrel (actptr, (indx-gcos_control_tables_$exc_offset)*3); /* compute address of activity */ /* description associated with this activity */ gcos_ext_stat_$nongcos = ""; gcos_ext_stat_$default_nondollar = substr (nondolr, 1, 2); /* get the default nondollar filecode */ gcos_ext_stat_$nondollar = ""; /* blank out nondollar file code */ /* it gets set to the default the first time nondollar cards are found outside a $ DATA deck */ /* Compute address of variable information block */ actptr = pointer (addr (gcos_control_tables_$), vib_offset); gcos_ext_stat_$activity_name = vib.activity; /* save activity name */ substr (save_data.psw, 1, 5) = substr (vib.psw, 1, 5); /* set psw bits 0-4 */ substr (save_data.psw, 7, 12) = substr (vib.psw, 7, 12); /* set psw bits 6-17 */ /* Set time, storage, and sysout line limits */ /* ADD CODE TO SET time AND sysout LIMITS TO min(JOB LIMIT,vib.whatever) */ gcos_ext_stat_$time_limit = vib.time; gcos_ext_stat_$storage_limit = vib.storage; gcos_ext_stat_$sysout_limit = vib.sysout; gcos_ext_stat_$sysout_lines = 0; op_ofs = vib.op_ofs; /* Record options info. */ op_len = vib.op_len; gcos_ext_stat_$ldrss = 0; /* set loader shared storage to 0 */ /* Loop to open files required by this activity */ actptr = addrel (actptr, 5); /* bump ptr to variable info */ do while (vib_file.filecode ^= zeros); /* do until find 00 */ if substr (control, 5, 1) then /* sysout file */ call gcos_open_file_$sysout (vib_file.filecode, "0"b); else do; if substr (control, 1, 1) then /* flag says to use a lud */ lud = vib_file.filecode || "$"; /* create a lud from the filecode */ else lud = ""; call gcos_open_file_ (vib_file.filecode, lud, fibptr, present); /* Set indicators in fib based on settings of control bits in vib */ fib.read = "1"b; if substr (control, 2, 1) then fib.disp = "10"b; fib.write = substr (control, 3, 1); fib.type = substr (control, 4, 1); if ^present then fib.size = fixed (substr (control, 13, 6)) * 3840; end; actptr = addrel (actptr, 1); /* Locate next file code */ end; call gcos_open_file_$sysout ("p*", "0"b); /* open p* */ call gcos_open_file_ ("t*", "ty1", fibptr, present); /* open t* with unique lud */ fib.console = "1"b; fib.disp = "10"b; go to wrapup (indx-gcos_control_tables_$exc_offset); /* Finish up the processing of a $ EXECUTE card. */ wrapup (0): /* EXECUTE */ call gcos_open_file_ ("", "b*$", fibptr, present); /* open b* */ if present then do; /* but only if already there */ call gcos_open_file_ ("b*", "b*$", fibptr, present); /* call again with filecode */ fib.disp = "01"b; /* set disp = "R" */ end; else fib.used = "0"b; /* otherwise forget it */ do i = 1 to hbound (save_data.fibs, 1); if fct.filecode (i) = "" then go to rs_hit; /* locate available entry */ end; rs_hit: fct.filecode (i) = "r*"; /* change its file code */ fct.sysout (i) = "0"b; fibptr = gcos_ext_stat_$rs; fct.fibptr (i) = fibptr; fib.gein = "1"b; call gcos_write_$ptr (gcos_ext_stat_$rs, execute, "10000000"b); /* write $ execute */ gcos_ext_stat_$nongcos = "r*"; /* indicate where nongcos dollar cards go */ call gcos_open_file_ ("", "", fibptr, present); /* set up a new r* file for next geload */ gcos_ext_stat_$rs = fibptr; /* save pointer to fib */ fib.stream = "rstar"; fib.disp = "10"b; go to evaluate; /* go evaluate options */ /* Finish up the language control cards. */ wrapup (9): /* FORTRAN */ wrapup (10): /* PL1 */ wrapup (11): /* COBOL */ wrapup (12): /* GMAP */ wrapup (13): /* 355MAP */ wrapup (14): /* ALGOL */ wrapup (15): /* FORTA */ wrapup (16): /* FORTY */ wrapup (17): /* JOVIAL */ wrapup (18): /* ASM66 */ wrapup (19): /* CBL74 */ wrapup (20): /* CBL68 */ wrapup (21): /* MALT */ wrapup (22): /* ILANG */ wrapup (23): /* IDS */ wrapup (24): /* IDS2 */ wrapup (25): /* 4TRAN */ wrapup (26): /* G3EDIT */ wrapup (27): /* FORT77 */ wrapup (28): /* FORTX */ wrapup (29): /* CIDS2 */ wrapup (30): /* RPG2 */ call gcos_write_$ptr (gcos_ext_stat_$rs, source, "10000000"b); /* write $ source */ go to evaluate; /* go evaluate options */ /* Finish up the processing of the $ PROGRAM card. */ wrapup (2): /* PROGRAM */ call gcos_get_cc_field_ (card, field, rtrn); /* get name of prog to be loaded */ if rtrn ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "Program name missing.^/^a^2x^a", gcos_ext_stat_$card_num, card); /* abort if no field */ gcos_ext_stat_$activity_name = field; /* put prog name in as activity to be run */ go to evaluate; /* go evaluate options */ /* Finish the processing of the $ FILEDIT card. */ wrapup (4): /* FILEDIT */ /* write the filedit card on F* and make provision for a following etc card to be written there, too */ call gcos_write_$record ("f*", gcos_record, (8)"0"b); gcos_ext_stat_$save_data.write_etc = "1"b; /* remember to write any etc card on F* */ gcos_ext_stat_$etc_filecode = "f*"; gcos_ext_stat_$save_data.dstar = "1"b; /* lie, to prevent stranger option from causing card to be written on d* also */ goto evaluate; /* all done */ /* Finish up then CONVER card (BMC). */ wrapup (3): /* CONVER */ gcos_ext_stat_$nongcos = "mc"; go to evaluate; /* Finish up the $ UTILITY card. */ wrapup (6): /* UTILITY */ gcos_ext_stat_$nongcos = "u*"; go to evaluate; /* Finish the processing of $ 355SIM or $ SYSEDIT cards. */ wrapup (1): /* 355SIM */ wrapup (5): /* SYSEDIT */ wrapup (7): /* UTL2 */ wrapup (8): /* CONVRT */ /* Come here to evaluate options on card */ /* Calculate address of and number of entries in option table from */ /* saved info. */ evaluate: ; j = divide (op_len, 3, 17); /* Determine number of entries. */ actptr = pointer (addr (gcos_control_tables_$), op_ofs); /* Location of options table. */ eval_loop: ; call gcos_get_cc_field_ (card, field, rtrn); /* get field from card */ if rtrn = END_OF_CARD then do; /* quit if end of card */ gcos_ext_stat_$save_data.dstar, gcos_ext_stat_$save_data.write_etc = "0"b; /* turn off switches when finished with card */ return; end; if rtrn = NULL_FIELD then go to eval_loop; /* continue if null field */ do i = 1 to j; if field = optab (i).option_type then do; if optab (i).idx = 1 then save_data.psw = save_data.psw | optab (i).bits; /* Set bits ON. */ else save_data.psw = save_data.psw & ^(optab (i).bits || (18)"0"b); /* Set bits OFF. */ goto eval_loop; end; /* if field matches type, go process */ end; /* Save/restart options */ if ^gcos_ext_stat_$save_data.nosave then do; if field = "nrest" then restart_control.na_hold = "1"b; /* no activity restart */ else if field = "njrest" then restart_control.nj_restart = "1"b; /* no job restart */ else if field = "jrest" then restart_control.nj_restart = "0"b; /* restart job */ else if field = "rest" then restart_control.na_hold = "0"b; /* restart activity */ else goto unknown_option; goto eval_loop; end; unknown_option: ; /* unknown option causes card to be written on d* file */ if ^gcos_ext_stat_$save_data.dstar then do; /* if we did not already write it, do so */ gcos_ext_stat_$save_data.dstar = "1"b; /* remember that we are going to write it */ gcos_ext_stat_$etc_filecode = "d*"; /* and also tell get_cc_field to write any etc cards on d* */ gcos_ext_stat_$save_data.write_etc = "1"b; /* truncate trailing words of blanks, as gcos does for the d* file */ i = 13; /* 13th word of record (12th word of data) is cols 67-72 */ trunc_loop: ; if gcos_record_word (i) = six_bcd_blanks then do; /* if word is blank */ i = i - 1; /* truncate the word */ goto trunc_loop; /* and go look at the previous word */ end; i = (i-1)*4; /* compute length of char(*) overlay for what is left of the card (the -1 gets rid of the rcw - it has wrong length now) */ /* gcos_write_ will create d* and set its disp to release for us */ call gcos_write_$bcd ("d*", substr (gcos_record, 5, i), "10000000"b); end; goto eval_loop; %page; /* Variables for gcos_cc_activity_cards_: */ /* IDENTIFIER ATTRIBUTES */ dcl actptr ptr; dcl addr builtin; dcl addrel builtin; dcl divide builtin; dcl END_OF_CARD fixed bin(24)static internal options (constant) init (2); dcl execute char(80) int static options(constant) init ("$"||(6)" "||"execute"); dcl field char(6) /* return paramater from gcos_get_cc_field_ */; dcl fixed builtin; dcl gcos_error_ entry options (variable); dcl gcos_et_$cc_missing_field fixed bin(35) ext; dcl gcos_get_cc_field_ ext entry (char(80), char(*), fixed bin); dcl gcos_open_file_ ext entry (char(*), char(*), ptr, bit(1)); dcl gcos_open_file_$sysout ext entry (char(*), bit(1)); dcl gcos_record_word (13) bit(36) based (addr (gcos_record)) /* overlay for bcd card image */; dcl gcos_write_$bcd ext entry (char(*), char(*), bit(8)); dcl gcos_write_$ptr ext entry (ptr, char(*), bit(8)); dcl gcos_write_$record ext entry (char(*), char(*), bit(8)); dcl i fixed bin(24); dcl j fixed bin(24); dcl lud char(3) /* holds a logical unit designator */; dcl NULL_FIELD fixed bin(24)static internal options (constant) init (1); dcl op_len fixed bin(18)unsigned; dcl op_ofs fixed bin(18)unsigned; dcl pic pic "99"; dcl pointer builtin; dcl present bit(1) /* file present flag */; dcl rtrn fixed bin(17); dcl six_bcd_blanks bit(36) int static init ((6)"20"b3 ) ; dcl size builtin; dcl source char(80) int static options(constant) init ("$"||(6)" "||"source"); dcl substr builtin; dcl unspec builtin; dcl zeros char(2) /* holds 16 0 bits */; %page; %include gcos_restart_control_; %page; %include gcos_control_tables_; %page; %include gcos_ext_stat_; %page; %include gcos_contrl_tables_data; end gcos_cc_activity_cards_;  gcos_cc_data_.pl1 12/11/84 1357.5rew 12/10/84 1036.0 73008 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_cc_data_: proc (card); /* ***************************************************************************************** ******************************************************************************************* * * * G C O S $ D A T A C A R D P R O C E S S I N G * * * This procedure handles the processing of the $ DATA card. This card has the * following format: * * $ DATA FC,Options * * Where FC is a two character file code and options are as follows: * * C_K_S_U_M_ Binary checksums will be checked. * NCKSUM No checksums will be checked. * COPY All $ control cards will be copied * up to a $ ENDCOPY card. * N_C_O_P_Y_ No $ control cards will be copied. * TAKEc Card decks not punched by GE punches * will be read. Any invalid punches will * be replaced by the character following * the TAKE (c). * SEQ Check sequence and delete activity if error. * The COPY option overrides SEQ. * CKSEQ Check sequence and flag errors but don't * delete activity. The COPY option overrides CKSEQ. * N_S_E_Q_ No sequence check. * ENDFC Match this $ DATA card with corresponding $ ENDCOPY. * IBMF IBM Fortran set * IBMC IBM Cobol set * IBMEL IBM Extended Language set (029 keypunch codes) * IBMPL PL/I set * GE225 Model G-225 set * * NOTE: If no options are specified, the underlined options * will be in effect. * * CAUTION: The following options are the only ones implemented currently: * COPY, NCOPY, CKSUM, NCKSUM, ENDFC, and NSEQ. * Other options are recognized, and a warning message is issued. * * WRITTEN BY DICK SNYDER JANUARY 8,1971 * MODIFIED BY T.CASEY DECEMBER 1972, DECEMBER 1973 * MODIFIED BY R.H. MORRISON ON APRIL 5, 1974 * MODIFIED BY D. KAYDEN APRIL 1974 * Modified by M. R. Jordan, April 1977 to process ENDFC option * Modified by M. R. Jordan, August 1977 to process incode specifications. * Change: Dave Ward 07/28/81 Allow period in name (By Dick Hemes) * Change: Ron Barstad 84-11-19 Added # and $ as valid file code chars * ********************************************************************************************* ****************************************************************************************** */ dcl END_OF_CARD fixed bin(24)init (2) static int options (constant); dcl NULL_FIELD fixed bin(24)init (1) static int options (constant); dcl addr builtin; dcl card char (80); /* input card image */ dcl field char (6); /* holder for field */ dcl gcos_error_ ext entry options (variable); dcl gcos_et_$cc_bad_fc fixed bin(35) ext; dcl gcos_et_$cc_bad_field fixed bin(35) ext; dcl gcos_get_cc_field_ ext entry (char (*), char (6), fixed bin(24)); dcl gcos_write_to_er_ entry options (variable); dcl result fixed bin(24); /* result from gcos_get_cc_field_ */ dcl substr builtin; dcl verify builtin; /* Begin processing the $ DATA control card. If the user has specified a DATA file outside an activity let him know about our ignoring it. */ if ^gcos_ext_stat_$save_data.activ then do; call gcos_write_to_er_ ( "Warning: The following $ DATA card is outside an activity definition. It is being ignored.^/^a^2x^a", gcos_ext_stat_$card_num, card); return; end; /* Get the file code from the $ DATA card. If there is no file code, let the user know about our assumption of the file code i*. */ call gcos_get_cc_field_ (card, field, result); if result ^= 0 then do; field = "i*"; call gcos_write_to_er_ ("Warning: i* used as default for data.^/^a^2x^a", gcos_ext_stat_$card_num, card); end; /* Make sure the file code value is good (i.e., meets all of the requirements for a good file code). Then save the file code for gcos_gein_ to use. */ if verify (substr (field, 1, 2), "abcdefghijklmnopqrstuvwxyz0123456789.*#$") ^= 0 then call gcos_error_ (gcos_et_$cc_bad_fc, "File code characters must be alphanumeric or .*#$ ""^a""^/^a^2x^a", field, gcos_ext_stat_$card_num, card); if substr (field, 3) = " " then ; else if substr (field, 3) ^= "s" then call gcos_error_ (gcos_et_$cc_bad_fc, "Disposition must be ""s"". ""^a""^/^a^2x^a", field, gcos_ext_stat_$card_num, card); else if verify (substr (field, 2, 1), "0123456789.*#$") ^= 0 then call gcos_error_ (gcos_et_$cc_bad_fc, "Second file code character must be numeric or * when s disposition is specified. ""^a""^/""^a^4x^a""", field, gcos_ext_stat_$card_num, card); else do; call gcos_error_ (0, "The saving of DATA files is not yet supported by the Multics GCOS Environment Simulator.^/^a^2x^a", gcos_ext_stat_$card_num, card); end; gcos_ext_stat_$nondollar = substr (field, 1, 2); gcos_ext_stat_$save_data.nondollar = "1"b; /* If no options appear then quit now. Otherwise, initialize things and continue processing. */ gcos_ext_stat_$save_data.copy, gcos_ext_stat_$save_data.cksum, gcos_ext_stat_$save_data.endfc = "0"b; gcos_ext_stat_$incode = 0; if result = END_OF_CARD then return; /* Now process the optins on the $ DATA card one at a time. */ get: call gcos_get_cc_field_ (card, field, result); if result = END_OF_CARD then do; if gcos_ext_stat_$save_data.endfc then if ^gcos_ext_stat_$save_data.copy then call gcos_error_ (gcos_et_$cc_bad_field, "The ENDFC option requires the COPY option.^/^a^2x^a", gcos_ext_stat_$card_num, card); if gcos_ext_stat_$incode ^= 0 then if ^gcos_ext_stat_$save_data.copy then call gcos_error_ (gcos_et_$cc_bad_field, "Incode specifications require the COPY option.^/^a^2x^a", gcos_ext_stat_$card_num, card); return; end; if result = NULL_FIELD then go to get; /* For COPY simply set the flag to say watch for a $ ENDCOPY card. */ if field = "copy" then do; gcos_ext_stat_$save_data.copy = "1"b; go to get; end; /* For ENDFC we need to set the flag and remember the file code. */ if field = "endfc" then do; gcos_ext_stat_$endfc = gcos_ext_stat_$nondollar; gcos_ext_stat_$save_data.endfc = "1"b; goto get; end; /* The CKSUM and NCOPY options are defaults so we need to do very little. */ if field = "cksum" then do; gcos_ext_stat_$save_data.cksum = "0"b; goto get; end; if field = "ncopy" then do; gcos_ext_stat_$save_data.copy = "0"b; goto get; end; /* For NCKSUM mark no checksum checking. */ if field = "ncksum" then do; gcos_ext_stat_$save_data.cksum = "1"b; go to get; end; /* Process incode specifications. */ if field = "ibmf" then do; gcos_ext_stat_$incode = 1; goto get; end; if field = "ibmc" then do; gcos_ext_stat_$incode = 2; goto get; end; if field = "ibmel" then do; gcos_ext_stat_$incode = 3; goto get; end; /* The following processing is of options we recognize but do not support. */ if field = "seq" | field = "nseq" | field = "ckseq" | substr (field, 1, 4) = "take" | field = "ge225" | field = "ibmpl" then do; call gcos_write_to_er_ ("Warning: ""^a"" is an unimplemented option on $ DATA cards.^/^a^2x^a", field, gcos_ext_stat_$card_num, card); go to get; end; /* We have found an unrecognized option. Abort processing. */ call gcos_error_ (gcos_et_$cc_bad_field, """^a""^/^a^2x^a", field, gcos_ext_stat_$card_num, card); %include gcos_ext_stat_; end gcos_cc_data_;  gcos_cc_directive_cards_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 50355 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ******************************************************************************************** ******************************************************************************************** * * * PROCESS ASSORTED DIRECTIVE CARDS * * * This module processes assorted directive cards for BMC (CONVER), * FILEDIT (the editor), the loader, and UTILITY. This processing * includes recognizing these control cards outside the activities * for which they are meaningful and warning the user. If the cards * are found in the proper context, they are written to the proper * file and processing is terminated. * * * The following control cards are processed within: * * * $ COMPILE * $ COPY * $ DELETE * $ DUMP * $ ENDEDIT * $ ENDLD * $ FFILE * $ FORM * $ FUTIL * $ INCLUDE * $ INPUT * $ LIST * $ MODIFY * $ MULTI * $ OUTPUT * $ PATCH * $ QUTIL * $ SEQ * $ SETSQ * $ SYSLD * * * Written by T. Casey, November 1973 * Modified by D. Kayden, April 1974 * Modified by M. R. Jordan, July 1977 * * ******************************************************************************************** ******************************************************************************************** */ gcos_cc_directive_cards_: proc (card, indx, gcos_record); dcl card char (80); /* ascii card image */ dcl indx fixed bin(24); /* position in card table - not used here */ dcl gcos_record char (*); /* bcd card image overlayed by char (*) variable */ dcl gcos_write_$record ext entry (char (*), char (*), bit (8)); dcl gcos_write_to_er_ options (variable); dcl fc char (2); /* temp for holding file code value */ dcl addr builtin; /* Process FILEDIT directives. Note that we should never get one of these directives if the user has a good input file. FILEDIT directives should only appear on *C. */ cc_editor: entry (card, indx, gcos_record); call gcos_write_to_er_ ( "Warning: The following FILEDIT directive appears out of place. It will be ignored.^/^a^2x^a", gcos_ext_stat_$card_num, card); return; /* Process SYSEDIT directives. Note that we should never get one of these directives if the user has a good input file. SYSEDIT directives should only appear on *C. */ cc_sysedit: entry (card, indx, gcos_record); call gcos_write_to_er_ ( "Warning: The following SYSEDIT directive appears out of place. It will be ignored.^/^a^2x^a", gcos_ext_stat_$card_num, card); return; /* Process SCED directives. Note that we should never get one of these directives if the user has a good input file. SCED directives should only appear on *C. */ cc_sced: entry (card, indx, gcos_record); call gcos_write_to_er_ ( "Warning: The following SCED (*C editor) directive appears out of place. It will be ignored.^/^a^2x^a", gcos_ext_stat_$card_num, card); return; /* Process BMC (CONVER) directives. */ cc_bmc: entry (card, indx, gcos_record); if gcos_ext_stat_$activity_name ^= "conver" then do; call gcos_write_to_er_ ( "Warning: The following BMC (CONVER) directive appears out of place. It will be ignored.^/^a^2x^a", gcos_ext_stat_$card_num, card); return; end; else go to write_it; /* Process a $ FFILE control card. */ cc_ffile: entry (card, indx, gcos_record); if gcos_ext_stat_$activity_name ^= "utilit" & gcos_ext_stat_$activity_name ^= "geload" then do; call gcos_write_to_er_ ( "Warning: The following $ FFILE card appears out of place. It will be ignored.^/^a^2x^a", gcos_ext_stat_$card_num, card); return; end; go to write_it; /* Process a $ DUMP control card. */ cc_dump: entry (card, indx, gcos_record); if gcos_ext_stat_$activity_name ^= "geload" then do; call gcos_write_to_er_ ( "Warning: The following $ DUMP card appears out of place. It will be ignored.^/^a^2x^a", gcos_ext_stat_$card_num, card); return; end; gcos_ext_stat_$save_data.nondollar = "1"b; gcos_ext_stat_$nondollar = "r*"; /* nondollar cards may follow this card */ go to write_it; /* Process a UTILITY directive card. */ cc_utility: entry (card, indx, gcos_record); if gcos_ext_stat_$activity_name ^= "utilit" then do; call gcos_write_to_er_ ( "Warning: The following UTILITY directive appears out of place. It will be ignored.^/^a^2x^a", gcos_ext_stat_$card_num, card); return; end; else goto write_it; /* The following code is used by all entries in this module. It will write the $ card to the proper file and get things set up for a $ ETC card following. */ write_it: fc = gcos_ext_stat_$nongcos; call gcos_write_$record (fc, gcos_record, (8)"0"b); /* Now get things set up for a $ ETC card following this card. */ gcos_ext_stat_$save_data.write_etc = "1"b; /* in case it is continued */ gcos_ext_stat_$etc_filecode = fc; return; %include gcos_ext_stat_; end gcos_cc_directive_cards_;  gcos_cc_endjob_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 98766 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* *************************************************************************************** ***************************************************************************************** * * * $ E N D J O B C A R D P R O C E S S O R * * * This procedure processes $ ENDJOB cards which have the following format: * * * CONTROL CARD: ENDJOB * * * FORMAT: $ ENDJOB * * * FIELDS: none * * This procedure writes termination messages on console and execution report; * finishes writing (and outputs) the execution report, sysout, print, and punch * files; closes all files; and terminates the simulation via a nonlocal GOTO * to a label in procedure gcos_gein_, thus cleaning up the stack. * * This procedure is called: * * 1) when a $ ENDJOB card is encountered by gcos_gein_; * * 2) when the job is to be terminated for any reason other than a $ ENDJOB card, * (provided that it has not already been called once - thus an error in * this procedure or one that it calls cannot cause an infinite loop). * * * ***************************************************************************************** *************************************************************************************** */ %page; /* * * WRITTEN BY DICK SNYDER SEP 70 * MODIFIED BY T.CASEY DEC 72 * OCT 73 * APR 74 * AUG 74 * MODIFIED BY D. KAYDEN APR 74 * FEB 75 * MODIFIED BY R.H. MORRISON MAY 75 * MODIFIED BY S.C. AKERS DEC 81 Change \014 to %page; Modified: Ron Barstad 82-11-00 Fix format of EOJ console msg Modified: Ron Barstad 83-04-28 Print EOJ only if not abort and before dprint queued message */ %page; gcos_cc_endjob_: proc (card); gcos_ext_stat_$save_data.endjob = "1"b; /* remember that this procedure has been called in this job, and therefore should not be called again after any fault or error */ er = gcos_ext_stat_$er; /* copy fib pointer for speed */ sysprint_stream = gcos_ext_stat_$prt -> fib.stream; /* copy stream names for speed */ er_stream = er -> fib.stream; /* job accounting */ call gcos_time_convert_ ((clock_ ())-gcos_ext_stat_$job_real_time, rtt.time); /* get real time for job */ call gcos_write_$ptr (er, string (rtt), "11111100"b); /* write on execution report */ call hcs_$get_usage_values (k, cptime, k); /* get current cputime */ call gcos_time_convert_ (cptime-gcos_ext_stat_$job_cpu_time, ptt.time); /* get cp time for job */ call gcos_write_$ptr (er, string (ptt), "11111100"b); /* put on execution report */ call gcos_write_$ptr (er, eoj, "11111100"b); /* end job on execution report */ call gcos_write_$ptr (er, "", (8)"0"b); /* eof on execution report */ /* Append execution report to sysout print collector file. First, though, write an ASCII record on that file, flagging the start of the execution report, force out the block containing that record, find the offset in the file of the next block (which will be the first block of the execution report), and write that offset, and the snumb of the job, into a record at the beginning of the sysout print collector file, that was written there earlier, to reserve space for this information. This facilitates printing the file in a GCOS-like format, by gcos_sysprint. */ call gcos_write_$record_ptr (gcos_ext_stat_$prt, endrecord, (8)"0"b); /* write "start ex rpt" */ call gcos_write_$force_ptr (gcos_ext_stat_$prt); /* force out the block */ call ios_$tell (sysprint_stream, "write", "first", ex_rpt_offset, status); /* get offset of next block */ if code ^= 0 then do; error_entry = "tell"; p_error: error_stream = sysprint_stream; ios_error: call gcos_error_ (code, "from ios_$^a ^a", error_entry, error_stream); end; call ios_$seek (sysprint_stream, "write", "first", 4, status); /* seek to word 4 (counting from zero) 0=bcw,1=rcw,2=newline,3=rec1,4=offset */ if code ^= 0 then do; seek_error: error_entry = "seek"; goto p_error; end; first_record_subset.er_offset = ex_rpt_offset; /* put in offset of first block */ first_record_subset.snumb = substr (save_data.actid, 1, 5); /* put in snumb */ call ios_$write (sysprint_stream, addr (first_record_subset), 0, 3, j, status); /* write 3 words */ if code ^= 0 then do; error_entry = "write"; goto p_error; end; call ios_$seek (sysprint_stream, "write", "first", ex_rpt_offset, status); /* seek write pointer back to first block */ if code ^= 0 then goto seek_error; call ios_$seek (er_stream, "read", "first", 0, status); /* seek read pointer to start of file */ if code ^= 0 then do; error_entry = "seek"; er_error: error_stream = er_stream; goto ios_error; end; eofsw = ""b; do while (^eofsw); /* read 'til eof on execution report */ call ios_$read (er_stream, addr (buffer), 0, 320, j, status); /* read exec. report block */ if code ^= 0 then do; error_entry = "read"; goto er_error; end; eofsw = substr (status, 46, 1); /* save eof switch returned by ios_$read */ call gcos_write_$block_ptr (gcos_ext_stat_$prt, buffer); /* write block on sysout print collector */ /* we use gcos_write_$block_ptr instead of ios_$write, here, because the former puts the correct bsn into the bcw before writing, thus avoiding bsn errors while reading it back */ end; /* end of do-while group */ /* we fall thru here when we hit eof */ er -> fib.print = "0"b; /* reset so close_file_ will not queue it for sysout */ /* avoid writing EOF on an otherwise empty sysout punch collector file */ if gcos_ext_stat_$pch -> fib.buffer ^= null then /* if file not empty */ call gcos_write_$record_ptr (gcos_ext_stat_$pch, "", (8)"0"b); /* write EOF on it */ if ^gcos_ext_stat_$save_data.nosave then /* if save/restart specified */ call gcos_restart_$save; /* save restart data */ restart: entry; /* entry for restart */ if ^gcos_ext_stat_$save_data.brief & ^gcos_ext_stat_$save_data.this_act_abort then do; /* print end of job message on terminal, unless user said -brief */ call date_time_ ((clock_ ()), holdtime); /* get date and time */ call ioa_ (" *EOJ ^a @^a", save_data.actid, substr (holdtime, 11, 6)); end; /* queue sysout and close files */ fibptr = addr (save_data.fibs); /* close all remaining files */ do i = 1 to hbound (save_data.fibs, 1); if ^fib.used then go to not_used; fib.disp = "01"b; /* force file to be released */ call gcos_close_file_ (fibptr); not_used: fibptr = addrel (fibptr, size (fib)); end; call ios_$detach ("glib", "", "", status); /* now detach the software libraries */ if gcos_ext_stat_$save_data.userlib then call ios_$detach ("slib", "", "", status); call gcos_sysout_writer_; /* dispose of all files which are */ /* queued in the sysout queue */ call hcs_$truncate_seg (gcos_ext_stat_$gcos_slave_area_seg, 0, code); /* truncate slave segment */ call ios_$detach ("gcos_job_stream_", "", "", status); /* in case it was a msf */ call delete_$path (string (gcos_ext_stat_$save_dir), gcos_ext_stat_$job_id || ".job_deck", "000100"b, "gcos", code); if ^gcos_ext_stat_$save_data.nosave then call delete_$path (string (gcos_ext_stat_$save_dir), gcos_ext_stat_$job_id || ".save_data", "000100"b, "gcos", code); /* get rid of it */ goto gcos_ext_stat_$normal_return; /* revert stack and return to gcos_gein_ */ %page; /* D E C L A R A T I O N S */ %include gcos_ext_stat_; /* External Entries */ dcl (ios_$read, ios_$write) ext entry (char (*) aligned, ptr, fixed bin(24), fixed bin(24), fixed bin(24), bit (72) aligned); dcl size builtin; dcl (ios_$seek, ios_$tell) ext entry (char (*) aligned, char (*), char (*), fixed bin(24), bit (72) aligned); dcl ios_$detach ext entry (char (*) aligned, char (*), char (*), bit (72) aligned); dcl clock_ ext entry returns (fixed bin(71)); dcl ioa_ ext entry options (variable); dcl gcos_time_convert_ ext entry (fixed bin(71), char (19)); dcl gcos_write_$ptr ext entry (ptr, char (*), bit (8)); dcl gcos_write_$record_ptr ext entry (ptr, char (*), bit (8)); dcl gcos_write_$block_ptr ext entry (ptr, char (*)); dcl gcos_write_$force_ptr ext entry (ptr); dcl hcs_$get_usage_values ext entry (fixed bin(24), fixed bin(71), fixed bin(24)); dcl hcs_$truncate_seg ext entry (pointer, fixed bin(24), fixed bin(35)); dcl date_time_ ext entry (fixed bin(71), char (*)); dcl gcos_close_file_ ext entry (pointer); dcl gcos_sysout_writer_ ext entry; dcl gcos_error_ ext entry options (variable); dcl delete_$path ext entry (char (*) aligned, char (*) aligned, bit (6), char (*), fixed bin(35)); dcl gcos_restart_$save ext entry; /* restart procedures */ /* Work Variables */ dcl endrecord char (20) based (addr (end_record)); dcl 1 end_record aligned int static, 2 rcw bit (36) init ("000000000000000100000000000011111100"b), /* length=4,media=3,report=74 */ 2 newline_word bit (36) init ("111111000001000000000000000000000000"b), /* 7701 */ 2 end_message char (12) init ("start ex rpt"); dcl 1 first_record_subset aligned, 2 er_offset fixed bin(24)aligned, 2 snumb char (5), 2 pad char (3); dcl buffer char (1280); /* 320 words */ dcl ex_rpt_offset fixed bin(24); dcl status bit (72) aligned; dcl code fixed bin(35) based (addr (status)); dcl error_entry char (32); dcl error_stream char (32); dcl eofsw bit (1) aligned; dcl er pointer; /* local for fib pointer of execution report */ dcl er_stream char (8) aligned; /* for stream name of execution report */ dcl sysprint_stream char (8) aligned; /* stream name of sysprint file */ dcl card char (80); /* input card */ dcl (i, j) fixed bin(24); /* temp */ dcl k fixed bin(24); /* temp */ dcl cptime fixed bin(71); /* cpu usage */ dcl holdtime char (24); /* date and time */ dcl 1 rtt int static, 2 msg char (18) init ("real time total = "), 2 time char (19), 2 nls char (4) init (" "); dcl (addr, addrel, null, string, substr) builtin; dcl 1 ptt int static, 2 msg char (23) init ("processor time total = "), 2 time char (19), 2 nls char (2) init (" "); dcl eoj char (12) int static init ("end-of-job "); end gcos_cc_endjob_;  gcos_cc_file_cards_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 202023 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ****************************************************************************************** ******************************************************************************************* * * * G C O S F I L E C A R D P R O C E S S I N G * * * This is the main driving module for the processing of the various gcos file * assignment control cards. Cards processed by this module are the following: * * $ PRINT FC,LUD * $ PUNCH FC,LUD * $ READ (dummy entry - not really implemented ) * $ DISK FC,LUD,ACCESS * $ MASS FC,LUD,ACCESS * $ FILE FC,LUD,ACCESS * $ DRUM FC,LUD,ACCESS * $ TAPE FC,LUD,MULTIREEL,SERIAL NO,SEQ NO,FILE NAME,CLASS,DENSITY * $ PRMFL FC,ACC,MODE,PATH * $ PRMFL FC/LUD,ACC,MODE,PATH * $ DAC FC * $ SYSOUT FC * * * CONTROL CARD FIELDS * * FC FILE CODE * * LUD LOGICAL UNIT DESIGNATOR * Channel letter * followed by a channel number * 1-99 followed by the disposition * and optional abort disposition * (R=release,S=save,D=dismount, * P=purge and release, * C=continue,or blank = R). * * ACCESS FILE LENGTH AND ACCESS * Length of file in 3840 word * links followed by "l" or "r". * "l" stands for linked or sequential files * and "r" stands for random access files. * * MULTIREEL Any non-blank character used to denote a second tape. * (This is referred to as the secondary logical unit * designator in the fib.) * * SERIAL-NO Serial number of first tape * * SEQ-NO The number to the reel within a given file at * which processing is to begin. * * FILE-NAME An external name given to the file. Used in giving * mounting instructions to the operator. * DENSITY Tape density for MPC driven tape units. * * ACC FILE PERMISSION * Letters w,r,a,x, or e for the type * of access to be given to the file (write, read, * append or execute. Multiple access codes are * separated by slashs. * * MODE FILE ACCESS * The letter "l" or "r", indicating linked or random, as described above . * * PATH FILE PATHNAME * Full or partial pathname or GCOS file string of the file to be * associated with the filecode. * * * WRITTEN BY DICK SNYDER DECEMBER 7, 1970 * MODIFIED BY T. CASEY DECEMBER 1973, JUNE 1974 * MODIFIED BY D. KAYDEN APRIL 1974, JULY 1974, DECEMBER 1974, MARCH 1975 * Change: Dave Ward 07/28/81 Allow period in name (By Dick Hemes) * Modified: Ron Barstad 83-05-12 Improve test for path running over cc 72 * Modified: Ron Barstad 83-08-02 Added 6250 tape den as per GCOS * * ******************************************************************************************** ****************************************************************************************** */ gcos_cc_file_cards_: proc (card); /* D E C L A R A T I O N S */ %include gcos_ext_stat_; /* External Entries */ dcl gcos_cv_ascii_gebcd_ ext entry (ptr, fixed bin(24), ptr, fixed bin(24)); dcl gcos_open_file_ ext entry (char (*), char (*), ptr, bit (1)); dcl gcos_open_file_$sysout ext entry (char (*), bit (1)); dcl gcos_get_cc_field_ ext entry (char (80), char (*), fixed bin(24)); dcl gcos_get_cc_field_$asis entry (char (80), char (*), fixed bin(24)); dcl gcos_error_ ext entry options (variable); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin(35)); dcl gcos_interpret_file_string_ entry (char (*) varying, char (*), fixed bin(24), char (80)); dcl ioa_ entry options (variable); dcl gcos_write_to_er_ entry options (variable); dcl gcos_et_$cc_unimp fixed bin(35) ext; dcl gcos_et_$cc_bad_field fixed bin(35) ext; dcl gcos_et_$cc_missing_field fixed bin(35) ext; dcl gcos_et_$cc_bad_fc fixed bin(35) ext; dcl gcos_et_$cc_bad_lud fixed bin(35) ext; /* Work Variables */ dcl card char (80); /* input card image */ dcl message char (50); dcl dac_sw bit (1); dcl present bit (1); dcl (null_file, type_file, file_file) bit (1) init ("0"b); dcl fc char (2); /* file code */ dcl lud char (6) init (" "); /* logical unit designator */ dcl disp char (1) ; /* normal disposition */ dcl adisp char (1) ; /* abort disposition */ dcl cfdesc_field char (50); dcl field char (6); /* holder for a field from a card */ dcl tape_name char (12); dcl tape_serial_number char (5); dcl prmfl_fc_field char (8); dcl temp_tracks bit (2); /* temporary for fib.tracks */ dcl (i, j, k, digit, cp) fixed bin(24); /* temps */ dcl code fixed bin(35); dcl result fixed bin(24); /* holds result code from gcos_get_cc_field_ */ dcl abs bit (72) aligned; /* an aligned string for xlation */ dcl x char (1); /* temp */ dcl path char (200) ; /* holds pathname of permanent file */ dcl prmfl_path char (168*2) varying ; /* to hold the path or file string before we know which it is */ dcl path_type fixed bin(24); /* 0=dont know; 1=path;2=file string */ dcl etc_next_sw bit (1) aligned ; /* if path continued on etc card */ dcl dirname char (168); dcl ename char (32); dcl DENS_CHARS (6) char (5) static internal options (constant) init ("den2", "den5", "den8", "den9", "den16", "den62"); dcl DENS_BITS (6) bit (4) static internal options (constant) init ("0001"b, "0010"b, "0100"b, "0000"b, "1001"b, "1100"b); dcl END_OF_CARD fixed bin(24)static internal options (constant) init (2); dcl MULTICS_PATHNAME fixed bin(24)static internal options (constant) init (1); dcl GCOS_CFDESC fixed bin(24)static internal options (constant) init (2); dcl 1 PERM (18) aligned static internal options (constant), 2 NAME char (8) init ("r", "w", "a", "e", "x", "rec", "r/c", "w/c", "q", "t", "t/c", "c", "l", "r/w/c", "r/a", "r/w", "a/r", "w/r"), 2 READ bit (1) init ("1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b), 2 WRITE bit (1) init ("0"b, "1"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b), 2 SUPPORTED bit (1) init ("1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b); dcl (addr, fixed, index, length, null, substr, unspec, verify) builtin; cc_read: entry (card); call gcos_error_ (gcos_et_$cc_unimp, "^/^a^2x^a", gcos_ext_stat_$card_num, card); cc_print: entry (card); call Open_File; /* set up fib */ fib.print = "1"b; /* indicate printfile */ return; cc_punch: entry (card); call Open_File; /* set up fib */ fib.punch = "1"b; /* indicate punch file */ fib.write = "1"b; return; cc_file: entry (card); file_file = "1"b; call Open_File; /* set up fib */ if null_file then return; cp = 1; /* init scan counter */ call gcos_get_cc_field_ (card, field, result); /* get access field */ if result ^= 0 then fib.size = 3840; else do; j = 0; /* clear accumulator */ loop: i = fixed (unspec (substr (field, cp, 1)), 17); /* get next col in numeric form */ if i >= 48 then if i <= 57 then do; /* ascii numeral ? */ cp = cp+1; /* advance col indicator */ j = j*10+i-48; /* shift accumulator */ go to loop; /* see if any more digits */ end; if j ^= 0 then fib.size = 3840*j; /* set specified no. of links */ else do; call gcos_write_to_er_ ("Warning: File size specified is zero. Assuming 1 link.^/^a^2x^a", gcos_ext_stat_$card_num, card); fib.size = 3840; end; if substr (field, cp) = "r" then /* random file ? */ fib.type = "1"b; /* yes...indicate such */ else if substr (field, cp) = "l" then; else call gcos_write_to_er_ ( "Warning: Unknown access mode ""^a"" specified. Assuming ""l"".^/^a^2x^a", substr (field, cp), gcos_ext_stat_$card_num, card); end; /* at this point some test should be made for NEW or OLD in the next field */ fib.read, fib.write = "1"b; /* turn on indicators */ return; cc_tape7: entry (card); temp_tracks = "01"b; /* indicates 7 track */ goto tape_common; cc_tape9: entry (card); temp_tracks = "10"b; /* indicates 9 track */ goto tape_common; cc_tape: entry (card); /* GCOS default is 7track tape; Multics default is installation dependent, and is often 9track, with NO 7track drives installed in the system. /* temp_tracks = "01"b; */ tape_common: call Open_File; /* set up fib */ fib.tape = "1"b; /* indicate tape */ fib.tracks = temp_tracks; /* save tape type requested */ fib.serial_no = (5)"010000"b; /* blank(bcd) serial no */ fib.tape_name = (12)"010000"b; /* and tape name */ fib.seq_no = 1; /* default reel sequence number */ if index (card, " -noring") = 0 & /* see if "no ring" option is present */ index (card, " -nr") = 0 then fib.write = "1"b; /* default is to use a ring */ /* For now, the secondary logical unit designator will be ignored since */ /* multi-reel files won't be needed for awhile. */ call gcos_get_cc_field_ (card, field, result); /* skip slud */ call gcos_get_cc_field_ (card, tape_serial_number, result); /* get serial no. */ if result = END_OF_CARD then return; /* done if end of card */ if result = 0 then do; call gcos_cv_ascii_gebcd_ (addr (tape_serial_number), 5, addr (abs), i); /* convert serial no to bcd */ fib.serial_no = substr (abs, 1, 30); /* fill in fib with returned value */ end; /* Come here to extract reel sequence number */ call gcos_get_cc_field_ (card, field, result); /* get it */ if result = END_OF_CARD then return; /* done if end of card */ if result = 0 then do; /* if null field, go get tape name */ i = index (field, " ")-1; /* get length of seq_no */ if i < 0 then i = length (field); k = 0; /* init accumulator */ do j = 1 to i; /* loop to convert char string to binary */ digit = index ("0123456789", substr (field, j, 1)); /* look up digit */ if digit = 0 then call gcos_error_ (gcos_et_$cc_bad_field, """^a""^/^a^2x^a", field, gcos_ext_stat_$card_num, card); k = k*10+digit-1; /* add to accumulator */ end; fib.seq_no = k; /* store in fib */ end; /* Come here to extract tape name */ call gcos_get_cc_field_ (card, tape_name, result); /* get name */ if result = END_OF_CARD then return; /* done if end of card */ if result = 0 then do; call gcos_cv_ascii_gebcd_ (addr (tape_name), 12, addr (abs), i); /* convert to bcd */ fib.tape_name = abs; /* move to fib */ end; fib.density = "1111"b; /* set density default */ call gcos_get_cc_field_ (card, field, result); /* skip class field */ if result = END_OF_CARD then return; call gcos_get_cc_field_ (card, field, result); /* get density field */ if result ^= 0 then return; /* done if not there */ do i = lbound (DENS_CHARS, 1) to hbound (DENS_CHARS, 1); if field = DENS_CHARS (i) then do; fib.density = DENS_BITS (i); return; /* that's all */ end; end; call gcos_error_ (gcos_et_$cc_bad_field, "Illegal density specification.^/^a^2x^a""", gcos_ext_stat_$card_num, card); cc_type: entry (card); type_file = "1"b; call Open_File; return; cc_dac: entry (card); dac_sw = "1"b; /* share code with cc_sysout */ go to sysout_open; cc_sysout: entry (card); dac_sw = "0"b; sysout_open: ; if ^gcos_ext_stat_$save_data.activ then call gcos_write_to_er_ ( "Warning: The following $ SYSOUT control card has been found outside an activity definition and is being ignored.^/^a^2x^a", gcos_ext_stat_$card_num, card); call gcos_get_cc_field_ (card, field, result); if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "File code missing.^/^a^2x^a", gcos_ext_stat_$card_num, card); fc = substr (field, 1, length (fc)); if verify (fc, "0123456789.abcdefghijklmnopqrstuvwxyz*") ^= 0 | fc = "00" then call gcos_error_ (gcos_et_$cc_bad_fc, """^a""^/^a^2x^a", fc, gcos_ext_stat_$card_num, card); call gcos_open_file_$sysout (field, dac_sw); return; cc_prmfl: entry (card); /* Pick up the filecode and open the file */ call gcos_get_cc_field_ (card, prmfl_fc_field, result); if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "File code missing.^/^a^2x^a", gcos_ext_stat_$card_num, card); fc = substr (prmfl_fc_field, 1, 2); /* pick up filecode */ if verify (fc, "0123456789.abcdefghijklmnopqrstuvwxyz*") ^= 0 | fc = "00" then call gcos_error_ (gcos_et_$cc_bad_fc, """^a"" is not a valid file code.^/^a^2x^a", fc, gcos_ext_stat_$card_num, card); x = substr (prmfl_fc_field, 3, 1); /* must be blank or slash */ if x ^= " " then if x ^= "/" then call gcos_error_ (gcos_et_$cc_bad_fc, "^a^2x^a", gcos_ext_stat_$card_num, card); /* If FC/LUD was given, process the LUD */ if x = "/" then lud = substr (prmfl_fc_field, 4); call Open_Prmfl; /* get a fib and decode lud */ fib.perm = "1"b; /* Set access bits from permit field. */ call gcos_get_cc_field_ (card, field, result); if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "Access field missing from $ PRMFL card.^/^a^2x^a", gcos_ext_stat_$card_num, card); do i = lbound (PERM, 1) to hbound (PERM, 1); if PERM (i).NAME = field then do; if ^PERM (i).SUPPORTED then call gcos_error_ (gcos_et_$cc_bad_field, "Unsupported access mode. ""^a""^/^a^2x^a", field, gcos_ext_stat_$card_num, card); fib.write = PERM (i).WRITE; fib.read = PERM (i).READ; goto permissions_done; end; end; call gcos_error_ (gcos_et_$cc_bad_field, "Unrecognized permission ""^a"".^/^a^2x^a", field, gcos_ext_stat_$card_num, card); permissions_done: call gcos_get_cc_field_ (card, field, result); if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "An access mode is required.^/^a^2x^a", gcos_ext_stat_$card_num, card); if substr (field, 2, 1) ^= " " then call gcos_error_ (gcos_et_$cc_bad_field, """^a"" is not a valid access mode.^/^a^2x^a", field, gcos_ext_stat_$card_num, card); if substr (field, 1, 1) = "r" then fib.type = "1"b; /* turn on random bit */ else if substr (field, 1, 1) = "l" then fib.type = "0"b; /* turn off random bit */ else if substr (field, 1, 1) = "s" then fib.type = "0"b; /* same as "l" */ else call gcos_error_ (gcos_et_$cc_bad_field, "Access not ""r"", ""s"", or ""l"".^/^a^2x^a", gcos_ext_stat_$card_num, card); /* Process pathname field of the card. Here we deviate from the gcos format of: catalog1$password1/...catalogn$passwordn/filename$password and allow full or partial Multics pathnames to be supplied as an alternative. Continuation of the pathname via a $ etc card is possible by following a > or / with a blank. */ path_type = 0; prmfl_path = ""; get_path: call gcos_get_cc_field_$asis (card, cfdesc_field, result); if result ^= 0 then do; if etc_next_sw then call gcos_error_ (gcos_et_$cc_missing_field, "A $ ETC card is in error or missing at card number ^a.", gcos_ext_stat_$card_num); else call gcos_error_ (gcos_et_$cc_missing_field, "^a^2x^a", gcos_ext_stat_$card_num, card); end; i = index (cfdesc_field, " ")-1; /* find the end */ if (i < 0) | (index(substr(card,16,73-15)," ")=0) then do; call gcos_write_to_er_ ("Warning: Check for a pathname or catalog/filename description overflow into column 73.^a^2x^a", gcos_ext_stat_$card_num, card); if ^gcos_ext_stat_$save_data.brief then call ioa_ ("Warning: Check for a pathname or catalog/filename description overflow into column 73.^/^a^2x^a", gcos_ext_stat_$card_num, card); i = length (cfdesc_field); end; x = substr (cfdesc_field, i, 1); /* look at last character */ if x = ">" then do; /* if continued Multics pathname */ etc_next_sw = "1"b; /* remember continuation */ if path_type = GCOS_CFDESC then call gcos_error_ (gcos_et_$cc_bad_field, "Terminator on this $ ETC card is incompatable with the previous card.^/^a^2x^a", gcos_ext_stat_$card_num, card); path_type = MULTICS_PATHNAME; /* remember its a pathname */ end; else if x = "/" then do; /* if continued GCOS file string */ etc_next_sw = "1"b; /* remember continuation */ if path_type = MULTICS_PATHNAME then call gcos_error_ (gcos_et_$cc_bad_field, "Terminator on this $ ETC card is incompatable with the previous card.^/^a^2x^a", gcos_ext_stat_$card_num, card); path_type = GCOS_CFDESC; /* remember its a file string */ end; else etc_next_sw = "0"b; if length (prmfl_path) >= 168*2 then call gcos_error_ (gcos_et_$cc_bad_field, "Pathname or Catalog/Filename description is too long. ""^a""^/^a^2x^a", prmfl_path, gcos_ext_stat_$card_num, card); prmfl_path = prmfl_path || substr (cfdesc_field, 1, i); /* save (partial?) pathname */ if etc_next_sw then do; /* if continuation was indicated */ gcos_ext_stat_$gf = 3; /* fool gcos_get_cc_cfdesc_field_ into reading a $ ETC card */ goto get_path; /* and go call it */ end; if path_type = 0 then do; /* if we don't know what kind of path it is we will have to figure it out heuristically */ i = index (prmfl_path, "/"); /* a file string must have at least one slash */ if i = 0 then path_type = MULTICS_PATHNAME; /* if it doesn't, it has to be a pathname */ else do; /* otherwise, we are still not sure, since a pathname could contain a slash */ i = search (prmfl_path, "<>"); /* see if it has a < or > in it */ if i = 0 then path_type = GCOS_CFDESC; /* if not, assume a file string */ else /* but if it does, Multics is going to treat it as a pathname */ path_type = MULTICS_PATHNAME; /* even if the user intended it to be a file string */ end; end; if path_type = GCOS_CFDESC then call gcos_interpret_file_string_ (prmfl_path, path, k, card); else path = prmfl_path; /* Path holds pathname of file at this point */ call expand_pathname_ (path, dirname, ename, code); if code ^= 0 then call gcos_error_ (code, """^a""^/^a^2x^a", path, gcos_ext_stat_$card_num, card); if dirname = ">" then fib.pathnm = ">" || ename; else fib.pathnm = rtrim (dirname) || ">" || ename; exit: return; /* no more to do */ /* I N T E R N A L P R O C E D U R E S */ /* get file code and lud from control card */ Open_File: proc; call gcos_get_cc_field_ (card, field, result); /* get file code from card */ if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "File code missing.^/^a^2x^a", gcos_ext_stat_$card_num, card); fc = substr (field, 1, length (fc)); /* save file code */ if fc = "00" | verify (fc, ".abcdefghijklmnopqrstuvwxyz0123456789*") ^= 0 then call gcos_error_ (gcos_et_$cc_bad_fc, """^a""^/^a^2x^a", fc, gcos_ext_stat_$card_num, card); /* Process logical unit designator */ lud = ""; call gcos_get_cc_field_ (card, field, result); /* get logical unit designator */ if result = 0 then do; /* if no lud supplied, use defaults */ if field = "null" & file_file then null_file = "1"b; else lud = field; end; /* Get a fib and process the logical unit designator and disposition */ Open_Prmfl: entry; if ^gcos_ext_stat_$save_data.activ then do; call gcos_write_to_er_ ( "Warning: The following file card has been found outside an activity and is being ignored.^/^a^2x^a", gcos_ext_stat_$card_num, card); goto exit; end; disp, adisp = ""; if lud ^= " " then do; /* check for no lud specified */ if substr (lud, 6, 1) ^= " " then call gcos_error_ (gcos_et_$cc_bad_lud, """^a""^/^a^2x^a", lud, gcos_ext_stat_$card_num, card); if verify (substr (lud, 1, 1), "abcdefghijklmnopqrstuvwxyz0123456789") ^= 0 then call gcos_error_ (gcos_et_$cc_bad_lud, "The first character of a LUD must be alphanumeric. ""^a""^/^a^2x^a", lud, gcos_ext_stat_$card_num, card); cp = verify (substr (lud, 2), "01234567890*")-1; /* separate dispositiin from lud */ if cp = 0 then call gcos_error_ (gcos_et_$cc_bad_lud, "Device name LUDs are not supported by the Multics GCOS Environment. ""^a""^/^a^2x^a", lud, gcos_ext_stat_$card_num, card); disp = substr (lud, cp+2, 1); if cp+3 < length (lud) then adisp = substr (lud, cp+3, 1); lud = substr (lud, 1, cp+1); end; if type_file then do; /* $ TYPE card */ lud = "ty1"; /* "ty1" is always present for t* */ disp, adisp = "s"; end; call gcos_open_file_ (fc, lud, fibptr, present); if null_file then do; /* is this $ FILE FC,NULL ? */ fib.null = "1"b; goto exit; /* bypass setting of type and access */ end; fib.disp = decode_disp (disp); /* decode normal disposition */ if adisp ^= " " then /* abort disposition present ? */ fib.adisp = decode_disp (adisp); /* yes - decode it */ else fib.adisp = fib.disp; /* no - make it the same as the normal disposition */ if present then go to exit; /* do not set other attributes for an existing file */ return; decode_disp: proc (dsp) returns (bit (2)); dcl dsp char (1); decode_disp: if dsp = " " then return ("01"b); /* blank = release */ if dsp = "r" then return ("01"b); /* R = release */ if dsp = "s" then return ("10"b); /* S = save */ if dsp = "c" then return ("11"b); /* C = continue */ if dsp = "d" then return ("00"b); /* D = dismount */ if dsp = "p" then do; /* P = purge */ fib.purge = "1"b; return ("01"b); end; call gcos_write_to_er_ ( "Warning: ""^a"" is a bad disposition character. A disposition of ""r"" is being assumed.", dsp); return ("01"b); end decode_disp; end Open_File; end gcos_cc_file_cards_;  gcos_cc_goto_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 69102 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_cc_goto_: proc (card); /* This procedure processes the $ GOTO, $ IF, and $ WHEN cards. If the Operator is true, or for $ GOTO, always, the Label to be transferred to is saved in gcos_ext_stat_$sought_label, and gcos_ext_stat_$save_data.seeking is set to "1"b; for $ WHEN, gcos_ext_stat_$save_data.seeking_terminator is also set to "1"b, so that gein will not go past the end of an activity looking for the label. For $ GOTO and $ IF, a Label of ENDJOB causes an immediate call to gcos_cc_endjob_ from this procedure, which exits via a non-local goto, rather than returning here. For $ IF ABORT, gcos_ext_stat_$save_data.this_act_abort is tested, and if it is "1"b, gcos_cc_misc_cards_$cc_break is called to reset the PSW and abort switches, before the search for the specified Label is begun. WRITTEN BY T. CASEY, DECEMBER 1973 MODIFIED BY R.H. MORRISON, SEPTEMBER 1974, JULY 14, 1975 Modified by M. R. Jordan, August 1977 */ dcl NL char (1) init (" "); /* newline character */ dcl addr builtin; dcl bool builtin; dcl card char (80); dcl field char (66); /* returned field from get_cc_field_ */ dcl gcos_cc_endjob_ ext entry; dcl gcos_cc_misc_cards_$cc_break ext entry; dcl gcos_error_ ext entry options (variable); dcl gcos_et_$cc_bad_field fixed bin(35) ext; dcl gcos_et_$cc_missing_field fixed bin(35) ext; dcl gcos_get_cc_field_ ext entry (char (80), char (*), fixed bin(24)); dcl gcos_write_to_er_ entry options (variable); dcl index builtin; dcl result fixed bin(24); dcl substr builtin; dcl var_msg char (j) based (addr (err_msg)); /* variable length overlay */ /* Process a $ GOTO control card. */ /* Come here from $ IF and $ WHEN as well, to get label field */ get_label: call gcos_get_cc_field_ (card, field, result); /* see if it's ok */ if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "Label field missing.^/^a^2x^a", gcos_ext_stat_$card_num, card); /* ENDJOB? */ if ^gcos_ext_stat_$save_data.seeking_terminator then /* if not $ WHEN card */ if field = "endjob" then /* it could legally be ENDJOB */ call gcos_cc_endjob_; /* if it is, end the job */ /* set up to look for the label in the rest of the job deck */ gcos_ext_stat_$sought_label = substr (field, 1, length (gcos_ext_stat_$sought_label)); gcos_ext_stat_$save_data.seeking = "1"b; call gcos_write_to_er_ ("Note:^-$ card is true; sw=^w; skipping to ""^a"".^/^a^2x^a", save_data.psw, field, gcos_ext_stat_$card_num, card); return; /* Process a $ IF control card. */ cc_if: entry (card); if operator () then goto get_label; /* operator is an internal procedure, that returns its value as a function. If the operator is true, it will return "1"b, otherwise "0"b */ return; /* it must not have been true */ /* Process a $ WHEN control card. */ cc_when: entry (card); if ^operator () then return; /* evaluate operator and return if false */ gcos_ext_stat_$save_data.seeking_terminator = "1"b; goto get_label; /* The following is an internal procedure to evaluate the operator expression. */ operator: proc returns (bit (1)); dcl (term_flag, elem_flag, not_flag, elem_val, psw_val) bit (1); dcl (plus_indx, star_indx, not_indx) fixed bin(24); dcl code fixed bin(35); dcl term char (52); dcl elem char (3); dcl ex_or bit (4) init ("0110"b); dcl cv_dec_check_ entry (char(*), fixed bin(35)) returns(fixed bin(35)); dcl psw_pos fixed bin(35); dcl field char (72-15-1); call gcos_get_cc_field_ (card, field, result); if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "Operator field missing.^/^a^2x^a", gcos_ext_stat_$card_num, card); if field = "abort" then do; /* see if activity aborted */ if gcos_ext_stat_$save_data.this_act_abort then do; /* if it did */ call gcos_cc_misc_cards_$cc_break; /* reset psw and abort gcos_ext_stat_$save_data */ return ("1"b); /* tell main procedure that the operator is true */ end; return ("0"b); /* no abort - operator is false */ end; /* evaluate operator expression */ next_term: plus_indx = index (field, "+"); /* find next infix "+" operator */ if plus_indx = 0 then do; term_flag = "0"b; /* reset flag to indicate no more terms in field */ term = substr (field, 1, length (term)); /* field has only one term */ end; else do; term_flag = "1"b; /* set flag for more terms */ term = substr (field, 1, plus_indx-1); /* extract current field */ if plus_indx = length (field) then call gcos_error_ (gcos_et_$cc_bad_field, "Illegal expression.^/^a^2x^a", gcos_ext_stat_$card_num, card); field = substr (field, plus_indx+1); /* remaining terms in field */ end; next_elem: star_indx = index (term, "*"); /* find next infix "*" operator */ if star_indx = 0 then do; elem_flag = "0"b; /* reset flag to indicate no more elements in current term */ elem = substr (term, 1, length (elem)); /* term has only one element */ end; else do; elem_flag = "1"b; /* set flag for more elements */ elem = substr (term, 1, star_indx-1); /* extract current element */ if star_indx = length (term) then call gcos_error_ (gcos_et_$cc_bad_field, "Illegal expression.^/^a^2x^a", gcos_ext_stat_$card_num, card); term = substr (term, star_indx+1); /* leave remaining elements in term */ end; /* evaluate element */ not_indx = index (elem, "/"); /* see if element is complemented */ if not_indx = 0 then not_flag = "0"b; /* reset flag, element not complemented */ else if not_indx = 1 then do; not_flag = "1"b; /* element is complemented */ elem = substr (elem, 2); /* get rid of "/" */ end; else call gcos_error_ (gcos_et_$cc_bad_field, "Illegal switch word bit specification. ""^a""^/^a^2x^a", elem, gcos_ext_stat_$card_num, card); psw_pos = cv_dec_check_ (elem, code); /* convert character string element to numeric */ if code ^= 0 then call gcos_error_ (gcos_et_$cc_bad_field, "Illegal switch word bit specification. ""^a""^/^a^2x^a", elem, gcos_ext_stat_$card_num, card); if psw_pos > 35 | psw_pos < 0 then /* bad */ call gcos_error_ (gcos_et_$cc_bad_field, "Switch word bit specification must be 0 through 35. ""^a""^/^a^2x^a", elem, gcos_ext_stat_$card_num, card); psw_val = substr (save_data.psw, psw_pos+1, 1); /* psw bit value */ elem_val = bool (psw_val, not_flag, ex_or); /* logical value of term so far */ /* decide where to go */ if elem_val & ^elem_flag then goto return_1; /* some term is true */ if ^elem_val & ^term_flag then goto return_0; /* no term is true */ if elem_val & elem_flag then goto next_elem; /* this element is true, test next element */ if ^elem_val & term_flag then goto next_term; /* this element not true, test next term */ return_0: return ("0"b); /* return operator is false */ return_1: return ("1"b); /* return operator is true */ end operator; %include gcos_ext_stat_; end gcos_cc_goto_;  gcos_cc_ident_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 28494 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* **************************************************************************************** ****************************************************************************************** * * * * $ I D E N T C A R D P R O C E S S O R * * * This procedure processes $ ident cards. The identification information is * used to build banners for c* and p* (punch and printer files). The format * of an ident card is as described below: * * * * CONTROL CARD: IDENT * * * FORMAT: $ IDENT Account_no.,Identification * * * FIELDS: * * Account no.: * * The account number is an installation dependent field and is ignored currently * * Columns 16-72 are saved in save_data.ident, for use by other programs. * Those columns get converted to BCD and placed in the slave prefix, * by gcos_run_activity_. * * * * WRITTEN BY DICK SNYDER AUGUST 19,1970 * MODIFIED BY T.CASEY DECEMBER 1972 * MODIFIED BY R.H. MORRISON ON 15 MARCH l974 * Modified by M. R. Jordan, August 1977 * Modified by Mel Wilson, March 1979 to set output headers from $ident information. * * ****************************************************************************************** **************************************************************************************** */ gcos_cc_ident_: proc (card); dcl addr builtin; dcl card char (80); /* input card image */ dcl comma_nb fixed bin(24); dcl substr builtin; gcos_ext_stat_$save_data.save_data.ident = substr (card, 16, 57); /* save ident information */ /** set up dprint/dpunch destination info from $ident, if requested */ if gcos_ext_stat_$save_data.identflag & ^gcos_ext_stat_$save_data.flgs.ident then do; comma_nb = index (substr (card, 16, 57), ","); if comma_nb ^= 0 then do; if index (gcos_ext_stat_$dpo, "-ds") = 0 then gcos_ext_stat_$dpo = rtrim (gcos_ext_stat_$dpo) || " -ds """ || substr (card, comma_nb + 16, 9) || """"; if index (gcos_ext_stat_$dpno, "-ds") = 0 then gcos_ext_stat_$dpno = rtrim (gcos_ext_stat_$dpno) || " -ds """ || substr (card, comma_nb + 16, 9) || """"; end; end; gcos_ext_stat_$save_data.flgs.ident = "1"b; /* indicate that ident processed */ return; %include gcos_ext_stat_; end gcos_cc_ident_;  gcos_cc_incode_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 26406 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ********************************************************************** ************************************************************************ * * * $ INCODE CARD PROCESSING * * This procedure processes $ INCODE cards in the following format: * * $ INCODE type * * where type is the code type to be translated into bcd. Currently, * this module takes three types, ibmf, ibmc, and ibmel. The * actual implementation of this card is done in gcos_incode_ which will do * the actual translation. All that is done in this module is to set some * translation directing switches in external static. * * * WRITTEN BY DICK SNYDER DECEMBER 20,1971 * MODIFIED BY T.CASEY DECEMBER 1972 * MODIFIED BY D.KAYDEN JANUARY 1975 * Modified by M. R. Jordan, August 1977 * ************************************************************************ ********************************************************************** */ gcos_cc_incode_: proc (card); dcl card char (80); dcl gcos_error_ ext entry options (variable); dcl gcos_et_$cc_bad_field fixed bin(35) ext; dcl gcos_et_$cc_missing_field fixed bin(35) ext; dcl gcos_get_cc_field_ ext entry (char (80), char (*), fixed bin(24)); dcl result fixed bin(24); dcl type char (6); /* Process a $ INCODE control card. First get the incode specification (type) from the control card. */ call gcos_get_cc_field_ (card, type, result); /* get translation type */ if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "Missing incode specification.^/^a^2x^a", gcos_ext_stat_$card_num, card); /* Now process the incode type. If it is unsupported, say so. If it is unrecognized abort the processing of the job. */ if type = "ibmf" then gcos_ext_stat_$incode = 1; else if type = "ibmc" then gcos_ext_stat_$incode = 2; else if type = "ibmel" then gcos_ext_stat_$incode = 3; else if type = "reset" then gcos_ext_stat_$incode = 0; else if type = "ge225" | type = "ibmpl" then call gcos_error_ (gcos_et_$cc_bad_field, "An unsupported incode specification has been encountered. ""^a""^/^a^2x^a", type, gcos_ext_stat_$card_num, card); else call gcos_error_ (gcos_et_$cc_bad_field, "Unrecognized incode specification. ""^a""^/^a^2x^a", type, gcos_ext_stat_$card_num, card); return; %include gcos_ext_stat_; end gcos_cc_incode_;  gcos_cc_limits_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 61200 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* ***************************************************************************************** ******************************************************************************************* * * * P R O C E S S $ L I M I T S C A R D * * * The $ LIMITS card is used to modify the following standard activity limits: * * Time--activity time limit expressed in hundredths of an hour * * Storage1--max core required. Given in number of words required or * in the form nk where k = 1024 words and n is a multiple. * * Storage2--loader shared storage. Given same way as storage1 * * Sysout limit--number of sysout print lines allowed. * * If this card is encountered before the first activity defining * card, the time and sysout limits will be saved in special * variables, and applied to the whole job, while any other non null * values on the card will be effectively ignored (since the variables * they are stored in will be overwritten with standard values * when the first activity defining card is processed). * * WRITTEN BY DICK SNYDER JANUARY 11,1971 * MODIFIED BY T. CASEY FEBRUARY 1974 * MODIFIED BY D. KAYDEN JUNE 1974 * Modified by M. R. Jordan, August 1977 * * ******************************************************************************************** ****************************************************************************************** */ gcos_cc_limits_: proc (card); dcl END_OF_CARD fixed bin(24)static internal options (constant) init (2); dcl NULL_FIELD fixed bin(24)static internal options (constant) init (1); dcl accum fixed bin(24); /* temp */ dcl addr builtin; dcl card char (80); /* input card image */ dcl cp fixed bin(24); /* card col position */ dcl divide builtin; dcl fixed builtin; dcl gcos_error_ ext entry options (variable); dcl gcos_et_$cc_bad_field fixed bin(35) ext; dcl gcos_get_cc_field_ ext entry (char (80), char (*), fixed bin(24)); dcl nsw bit (1) aligned init ("0"b); /* control switch */ dcl psw bit (1) aligned init ("0"b); dcl result fixed bin(24); /* result from getnum */ dcl substr builtin; dcl sw bit (1) aligned init ("0"b); /* control switch */ dcl unspec builtin; call getnum; /* get time limit field */ if result = 0 then do; /* null field...try next field */ if accum > 999 then accum = 999; /* max activity = 9.99 hours */ accum = 36*accum; /* convert time limit to secs */ if save_data.activity_no = 0 then /* if activity 1 has not been defined yet */ save_data.job_time_limit = accum; /* this is the job time limit */ else gcos_ext_stat_$time_limit = accum; /* else this is the activity limit */ end; sw = "1"b; /* enable "k option" */ call getnum; /* get storage 1 field */ if result = 0 then /* null...try next field */ gcos_ext_stat_$storage_limit = /* save storage limit */ divide (accum+1023, 1024, 17, 0) * 1024; /* rounding up to a multiple of 1024 */ nsw = "1"b; /* enable negative value for loader space */ call getnum; /* get storage 2 field */ if result = 0 then /* null...try next field */ gcos_ext_stat_$ldrss = accum; /* save value */ psw = "1"b; nsw = "0"b; /* disable negative value */ call getnum; /* get line limit */ if result = 0 then do; /* exit if null field */ if save_data.activity_no = 0 then /* if activity 0 has not been defined yet then */ save_data.job_sysout_limit = accum; /* this is the job sysout limit */ else gcos_ext_stat_$sysout_limit = accum; /* else this is the activity sysout limit */ end; exit: return; /* that's it */ getnum: proc (); /* Internal procedure to extract a numeric field from a $ LIMITS card. This procedure has implicit inputs...sw and nsw. If sw is a 1, the field may legally contain a "k" which will cause the preceeding numeric portion of the field to be multiplied by 1024. If nsw = "1"b, negative values are allowed. The numeric field is accumulated in "accum". In addition, the result of the field extraction is returned in result. If the field was non-null , result is set to 0. If the field was null, result is set to 1. If the end of the card was reached, this procedure will not return. */ dcl field char (12); dcl negative bit (1) aligned init ("0"b); /* to remember a minus sign */ dcl i fixed bin(24); /* temp */ call gcos_get_cc_field_ (card, field, result); if result = NULL_FIELD then return; /* null field */ if result = END_OF_CARD then go to exit; /* end of card */ cp = 1; /* init field position */ accum = 0; /* clear accumulator */ if psw then /* if p string allowed in sysout limits ... */ if substr (field, 1, 1) = "p" then do; psw = "0"b; cp = 2; end; if nsw then /* if negative value allowed */ if substr (field, 1, 1) = "-" then do; /* minus sign? */ nsw = "0"b; /* only one allowed in a field */ negative = "1"b; /* remember it */ cp = 2; /* go get next digit */ end; next: i = fixed (unspec (substr (field, cp, 1)), 17)-48; /* pick up char */ if i >= 0 & i <= 9 then do; /* numeric? */ accum = accum*10+i; /* add bcd digit to accumulator */ bump: cp = cp+1; /* skip to next digit */ go to next; /* go get it */ end; if sw then if substr (field, cp, 1) = "k" then do; accum = accum*1024; /* multiply accum by 1k */ cp = cp+1; /* "k" must be followed by a terminator */ end; if substr (field, cp, 1) ^= " " then /* blank terminator */ call gcos_error_ (gcos_et_$cc_bad_field, "Bad character in numeric field. ""^a""^/^a^2x^a", substr (field, cp, 1), gcos_ext_stat_$card_num, card); if negative then accum = -accum; /* was there a minus sign? */ return; /* exit */ end getnum; %include gcos_ext_stat_; end gcos_cc_limits_;  gcos_cc_loader_cards_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 21312 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ***************************************************************************************** ****************************************************************************************** * * * G E L OA D C O N T R O L C A R D P R O C E S S I N G * * * This procedure writes the various loader control cards on the R* file. * It also sets up R* to receive nondollar cards for $ OBJECT. * cards, for OBJECT. * * The cards processed by this procedure are the following: * * $ OPTION $ LIBRARY $ LOWLOAD * $ USE $ ENTRY $ NOLIB * $ EQUATE $ RELCOM $ SOURCE * $ NLOAD $ OBJECT $ DKEND * $ LINK * * * WRITTEN BY DICK SNYDER NOVEMBER 16,1970 * MODIFIED BY T.CASEY DECEMBER 1972, DECEMBER 1973 * MODIFIED BY D. KAYDEN APRIL 1974 * ******************************************************************************************* **************************************************************************************** */ gcos_cc_loader_cards_: proc (card, indx, gcos_record); /* D E C L A R A T I O N S */ %include gcos_ext_stat_; dcl gcos_write_$record_ptr ext entry (ptr, char (*), bit (8)); dcl card char (80); /* ascii card image */ dcl indx fixed bin(24); /* position in cardtable - not used here */ dcl gcos_record char (*); /* bcd card image, overlayed by char(*) variable */ dcl addr builtin; write: call gcos_write_$record_ptr (gcos_ext_stat_$rs, gcos_record, (8)"0"b); /* write card on r* */ return; /* that's all there is to do */ cc_object: entry (card, indx, gcos_record); gcos_ext_stat_$save_data.nondollar = "1"b; /* tell gein to expect nondollar cards */ gcos_ext_stat_$nondollar = ""; /* and to put them on geload R* collector file */ go to write; end gcos_cc_loader_cards_;  gcos_cc_misc_cards_.pl1 12/11/84 1357.5rew 12/10/84 1036.0 48105 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gcos_cc_misc_cards_: proc; /* * THIS PROCEDURE IS USED TO HANDLE SEVERAL CARDS THAT REQUIRE LITTLE OR NO * PROCESSING IN THIS PASS OF THE SIMULATOR * * WRITTEN BY T. CASEY NOVEMBER 1973 * MODIFIED BY T. CASEY FEBRUARY 1974 * Modified by M. R. Jordan, October 1977 * Modified: Ron Barstad 83-08-03 Added "." and "_" as valid fms characters * Modified: Ron Barstad 84-02-21 Fixed length of userid if no password * */ dcl FMS_VALID_CHARS char (65) static internal options (constant) init (".-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"); dcl (index, rtrim, verify) builtin; dcl card char (80); /* ascii card image */ dcl field char (5); dcl gcos_error_ entry options (variable); dcl gcos_et_$cc_bad_field fixed bin(35) ext; dcl gcos_et_$cc_missing_field fixed bin(35) ext; dcl gcos_et_$cc_unimp fixed bin(35) ext; dcl gcos_get_cc_field_ entry (char (80), char (*), fixed bin(24)); dcl gcos_record char (*); /* bcd card image, overlayed by char (*) variable */ dcl gcos_write_$record ext entry (char (*), char (*), bit (8)); dcl gcos_write_to_er_ ext entry options (variable); dcl i fixed bin(24); dcl indx fixed bin(24); /* position in card table - not used here */ dcl ioa_ ext entry options (variable); dcl length builtin; dcl result fixed bin(24); dcl substr builtin; dcl userid_field char (25); /* These cards get printed on operators console (user's console, for Multics) at the time the activity is run */ cc_msg2: cc_comment: entry (card); call ioa_ ("^a", substr (card, 8, 72)); /* print the card */ return; /* These cards are acted upon in earlier passes, and are ignored in this pass */ cc_msg1: cc_msg3: entry; /* do nothing */ return; cc_userid: entry (card); call gcos_get_cc_field_ (card, userid_field, result); if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "Userid missing.^/^a^2x^a", gcos_ext_stat_$card_num, card); i = index (userid_field, "$")-1; if i < 0 then i = length (rtrim(userid_field)); if i > 12 then call gcos_error_ (gcos_et_$cc_bad_field, "Userid longer than 12 characters.^/^a^2x^a", gcos_ext_stat_$card_num, card); if i <= 1 then call gcos_error_ (gcos_et_$cc_bad_field, "Userid missing.^/^a^2x^a", gcos_ext_stat_$card_num, card); if verify (substr (userid_field, 1, i-1), FMS_VALID_CHARS) ^= 0 then call gcos_error_ (gcos_et_$cc_bad_field, "Illegal charater(s) in userid.^/^a^2x^a", gcos_ext_stat_$card_num, card); gcos_ext_stat_$userid = substr (userid_field, 1, i); return; /* The $ BREAK card resets the abort flag, and psw bit 5, to allow executions to be run after an abort */ cc_break: entry; if gcos_ext_stat_$save_data.prev_act_abort then do; /* if an abort occurred */ gcos_ext_stat_$save_data.prev_act_abort = "0"b; /* turn off abort flag */ /* and set PSW bit 5 */ if save_data.activity_no /* if the next activity */ < save_data.last_execute_act_no /* is before the last execution activity */ then save_data.psw = save_data.psw | "000001"b; /* then turn on psw bit 5 */ end; return; /* The etc card might be a continuation of a card that the simulator writes on a file without interpreting. If so, we will write it on the same file. If not, the etc card is out of place - a nonfatal error */ cc_etc: entry (card, indx, gcos_record); if gcos_ext_stat_$save_data.write_etc then do; /* if previous card was written on a file */ call gcos_write_$record (gcos_ext_stat_$etc_filecode, gcos_record, (8)"0"b); return; end; /* else fall thru to the out-of-place-card processing, which follows */ /* The following cards have showed up out of context, or we would not be here */ cc_alter: cc_endcopy: entry (card); call gcos_write_to_er_ ("Warning: The following $ card has been encountered out of context. It will be ignored.^/^a^2x^a", gcos_ext_stat_$card_num, card); /* gcos_error_ does not return */ if gcos_ext_stat_$save_data.long then /* print warning if -long was given */ call ioa_ ("Warning: The following $ card has been encountered out of context. It will be ignored.^/^a^2x^a", gcos_ext_stat_$card_num, card); return; cc_need: entry (card); call gcos_get_cc_field_ (card, field, result); if result ^= 0 then call gcos_error_ (gcos_et_$cc_missing_field, "^a^2x^a", gcos_ext_stat_$card_num, card); if field = "any" then return; if substr (field, 1, 3) = "sys" then call gcos_error_ (gcos_et_$cc_unimp, "Only $ NEED ANY is allowed.^/^a^2x^a", gcos_ext_stat_$card_num, card); else call gcos_error_ (gcos_et_$cc_bad_field, """^a""^/^a^2x^a", field, gcos_ext_stat_$card_num, card); %include gcos_ext_stat_; end gcos_cc_misc_cards_;  gcos_cc_param_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 29556 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ******************************************************************************************** ******************************************************************************************** * * * PROCESS $ PARAM CONTROL CARD * * * This module processes the $ PARAM control card. This control card may * be used to supply replacement parameters in a job stack. It may also be * used to replace parameter descriptions supplied using the -ag control * argument to the gcos command. * * * Written by M. R. Jordan, July 1977 * Modified: * Ron Barstad 3.1 02/16/83 Fixed illegal $Param ioa, field was missing * * ******************************************************************************************** ******************************************************************************************** */ gcos_cc_param_: proc (card); dcl i fixed bin(24); dcl result fixed bin(24); dcl card char (80); dcl field char (72-15); dcl END_OF_CARD fixed bin(24)static internal options (constant) init (2); dcl gcos_get_cc_field_$no_param entry (char (80), char (*), fixed bin(24)); dcl rtrim builtin; dcl hbound builtin; dcl gcos_error_ entry options (variable); dcl search builtin; dcl gcos_et_$cc_bad_field fixed bin(35) ext; /* Initialize a few values and prepare to prcoess all supplied fields. */ result = 0; i = 1; /* Now loop through all supplied fields. Replace the param(i) value only when a non-null field is encountered. This allows selective replacement of arguments supplied via -ag. */ do while (result ^= END_OF_CARD); call gcos_get_cc_field_$no_param (card, field, result); if result ^= END_OF_CARD then do; /* if this is a valid field then ... */ call Set_Param (); /* set the value. */ i = i+1; /* increment the param index */ end; end; return; Set_Param: proc (); /* Make sure we don't already have all the parameters we can handle. */ if i > hbound (save_data.param, 1) then call gcos_error_ (gcos_et_$cc_bad_field, "Maximum number of parameters exceeded. Maximum is ^d.^/^a^2x^a", hbound (save_data.param, 1), gcos_ext_stat_$card_num, card); /* Make sure the parameter consists of valid characters only. */ if search (field, "$/#") ^= 0 then call gcos_error_ (gcos_et_$cc_bad_field, "Illegal $ PARAM card field. ""^a""^/^a^2x^a", field, gcos_ext_stat_$card_num, card); /* The parameter value looks good. Save it if it has not been overridden in the command line by the -ag control argument. */ if save_data.param (i) = "" then save_data.param (i) = rtrim (field); return; end Set_Param; %include gcos_ext_stat_; end gcos_cc_param_;  gcos_cc_set_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 35253 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* *************************************************************************** *************************************************************************** * * * * * Process $ SET Control Card * * * * * * The $ SET control card is used to set or reset bits in the Program * * Switch Word. * * * * * * Written by R. H. Morrison February 22, 1974 * * Modified by R.H. Morrison April 4,1974 * * Modified by M. R. Jordan, August 1977 * * * * *************************************************************************** ************************************************************************ */ gcos_cc_set_: proc (card); dcl END_OF_CARD fixed bin(24)static internal options (constant) init (2); dcl card char (80); dcl code fixed bin(35); dcl cv_dec_check_ entry (char (*), fixed bin(35)) returns (fixed bin(35)); dcl field char (3); /* returned field has 1,2, or 3 characters */ dcl gcos_error_ ext entry options (variable); dcl gcos_et_$cc_bad_field fixed bin(35) ext; dcl gcos_et_$cc_missing_field fixed bin(35) ext; dcl gcos_get_cc_field_ ext entry (char (80), char (*), fixed bin(24)); dcl gcos_write_to_er_ entry options (variable); dcl nfield fixed bin(24); /* converted value of field */ dcl result fixed bin(24); /* returned result code; 0,1,or 2 */ dcl sr_flag fixed bin(24); /* set psw bit = 0, reset psw bit = 1 */ dcl substr builtin; dcl swit bit (36); /* image of Program Switch Word */ swit = save_data.psw; /* load image of ProgramSwitch Word */ result = 0; do while (result ^= END_OF_CARD); call gcos_get_cc_field_ (card, field, result); /* get next field on $ SET card */ if result = 0 then do; /* check if first field character is "/" */ if substr (field, 1, 1) = "/" then do; /* field specifies reset the bit */ sr_flag = 1; /* set the flag */ field = substr (field, 2); /* get rid of the "/" */ end; else sr_flag = 0; nfield = cv_dec_check_ (field, code); if code ^= 0 then call gcos_error_ (gcos_et_$cc_bad_field, "Illegal switch word bit specification. ""^a""^/^a^2x^a", field, gcos_ext_stat_$card_num, card); if nfield > 35 | nfield < 0 then call gcos_error_ (gcos_et_$cc_bad_field, "Switch word bit specification must be 0 through 35. ""^a""^/^a^2x^a", field, gcos_ext_stat_$card_num, card); if nfield = 5 then call gcos_write_to_er_ ( "Warning: Switch word bit 5 should mot be modified using $ SET.^/^a^2x^a", gcos_ext_stat_$card_num, card); if sr_flag = 0 then substr (swit, nfield+1, 1) = "1"b; /* set the bit */ else substr (swit, nfield+1, 1) = "0"b; /* else reset the bit */ end; end; save_data.psw = swit; /* update psw */ return; %include gcos_ext_stat_; end gcos_cc_set_;  gcos_cc_snumb_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 32049 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ***************************************************************************************** ******************************************************************************************* * * * * $ S N U M B C A R D P R O C E S S O R * * * This routine processes $ snumb cards which have the following format: * * * CONTROL CARD: SNUMB * * * FORMAT: $ SNUMB Job_Identifier,Urgency * * * FIELDS: Job Identifier: * * One to five characters used to identify job. Must not be * blank or 00000. * * Urgency: * * A number from 1 to 63 which represents the relative * importance of the job. * * COMMENTS: Must be the first card of the job. * Urgency field is currently ignored. * * * * * WRITTEN BY DICK SNYDER AUGUST 18,1970 * MODIFIED BY T.CASEY DECEMBER 1972 * Modified by M. R. Jordan, August 1977 * Modified by R. Barstad Nov 1982 Fix format of actid for console messages * * ******************************************************************************************** ****************************************************************************************** */ gcos_cc_snumb_: proc (card); dcl ZEROS char (5) static internal options (constant) init ("00000"); dcl addr builtin; dcl card char (80); /* card image of snumb card */ dcl gcos_error_ ext entry options (variable); dcl gcos_et_$cc_bad_card fixed bin(35) ext; dcl gcos_et_$cc_bad_field fixed bin(35) ext; dcl gcos_et_$cc_missing_field fixed bin(35) ext; dcl i fixed bin(24); /* temp */ dcl search builtin; dcl substr builtin; dcl verify builtin; /* Make sure this is the only $ SNUMB card. */ if gcos_ext_stat_$save_data.snumb then call gcos_error_ (gcos_et_$cc_bad_card, "Only one $ SNUMB card is allowed per job.^/^a^2x^a", gcos_ext_stat_$card_num, card); gcos_ext_stat_$save_data.snumb = "1"b; /* indicate that snumb processed */ /* Save the activity number (initialized to 01) and snumb (from the card). */ i = search (substr (card, 16, 5), " ,")-1; if i < 0 then i = 5; if i = 0 then call gcos_error_ (gcos_et_$cc_missing_field, "The snumb is missing from the follwing $ SNUMB card:^/^a^2x^a", gcos_ext_stat_$card_num, card); if substr (card, 16, i) = substr (ZEROS, 1, i) then /* snumb value cannot be zeros */ call gcos_error_ (gcos_et_$cc_bad_field, "Illegal snumb value. ""^a""^/^a^2x^a", substr (card, 16, i), gcos_ext_stat_$card_num, card); if verify (substr (card, 16, i), "0123456789ABCDEFGHIJKMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") ^= 0 then call gcos_error_ (gcos_et_$cc_bad_field, "Illegal snumb value. ""^a""^/^a^2x^a", substr (card, 16, i), gcos_ext_stat_$card_num, card); save_data.actid = substr (card, 16, i); /* save activity no and accnt i.d. */ substr(save_data.actid,6,3) = "-01"; return; /* that's all there is to do */ %include gcos_ext_stat_; end gcos_cc_snumb_;  gcos_cc_update_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 21987 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ***************************************************************************************** ****************************************************************************************** * * * P R O C E S S $ U P D A T E C A R D * * The $ UPDATE control card is used when supplying alter input to a compiler * or assembler. The nondollar filecode will be set to A*. * In addition, bit 9 of the psw and gcos_ext_stat_$save_data.nondollar are turned on. * * * WRITTEN BY DICK SNYDER JANUARY 11,1971 * MODIFIED BY T.CASEY DECEMBER 1972, DECEMBER 1973 * MODIFIED BY D. KAYDEN APRIL 1974 * Modified by M. R. Jordan, August 1977 * ******************************************************************************************* ***************************************************************************************** */ gcos_cc_update_: proc (card, indx, gcos_record); dcl addr builtin; dcl card char (80); /* ascii card image */ dcl gcos_record char (*); /* bcd card image overlayed by char(*) variable */ dcl gcos_write_$record ext entry (char (*), char (*), bit (8)); dcl gcos_write_to_er_ entry options (variable); dcl indx fixed bin(24); /* position in cardtable - not used here */ dcl substr builtin; if ^gcos_ext_stat_$save_data.activ then do; /* ignore if not defining an activity */ call gcos_write_to_er_ ( "Warning: The following $ UPDATE card is outside an activity definition. It is being ignored.^/^a^2x^a", gcos_ext_stat_$card_num, card); return; end; gcos_ext_stat_$save_data.nondollar = "1"b; /* tell gein to expect nondollar cards */ gcos_ext_stat_$nondollar = "a*"; /* and to put them on A* */ substr (save_data.psw, 10, 1) = "1"b; /* set update bit in psw */ call gcos_write_$record ("a*", gcos_record, (8)"0"b); /* put card on A* */ return; %include gcos_ext_stat_; end gcos_cc_update_;  gcos_check_for_mme_.alm 09/09/83 1400.3rew 09/09/83 1006.8 17496 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" " When a gcos activity is set up to be run, the signal pointer in " " the users' stack is set to point to this procedure. Thus on the " " occurence of a fault this procedure rather than signal_ is invoked." " This procedure then checks to see if the fault was caused by a " " gcos mme. If so, it transfers control to the gcos mme handler. " " If not, it transfers control to signal_. The condition mechanism " " search for gcos mmes is thus bypassed. " " " " Written by Peter M. Haber 8/22/72 " " Modified by T. Casey June 1973 " Modified by D. Kayden December 1974 " Change: Dave Ward 07/30/81 gcos_mme_processor_ " changed to gcos_process_mme_ " " """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" " " name gcos_check_for_mme_ entry gcos_check_for_mme_ " " include mc " gcos_check_for_mme_: eppbp ap|2,* pointer to fault name lda bp|0 load fault name ldq bp|1 cmpaq gc_mme compare to "mme1" tnz |[sig_ptr],* " eppbp ap|4,* pointer to machine conditions eppbp bp|0,* ldx0 bp|mc.scu.ppr.psr_word load psr word anx0 scu.ppr.psr_mask,du isolate psr cmpx0 |[gcos_slave_area_seg] check segment number tnz |[sig_ptr],* tra |[gcos_process_mme_] real gcos mme, transfer to gcos mme handler " " even gc_mme: acc "mme1" " " " end  gcos_cleanup_files_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 64224 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_cleanup_files_: proc; /* This procedure is called by gcos_run_activity_ after an activity terminates. It examines all the fibs and disposes of them according to the settings of of their indicators. The filecode table is also cleared. Author: DICK SNYDER SEPTEMBER 10,1970 Change: T.CASEY DECEMBER 1972, APRIL 1974, JUNE 1974 Change: D. KAYDEN APRIL 1974 Change: M. R. Jordan, October 1977 Change: Dave Ward 09/12/81 structured. */ er = gcos_ext_stat_$er; call ioa_$rs ("^20xfc d type #reqs^7xip^7xfp^7xis^7xfs^5xi/o stream", msg, k); call gcos_write_$ptr (er, nl, "11111100"b); call gcos_write_$ptr (er, var_msg, "11111100"b); call gcos_write_$ptr (er, nl, "11111100"b); /* Check for files released by MME GERELS */ do i = 1 to released_fibs.nrf; fibptr = addr (released_fib (i)); fc = substr (fib.pathnm, 1, 2); call display ("0"b); end; /* The following loop disposes of fibs according to the settings of the various indicators. */ do i = 1 to hbound (save_data.fibs, 1); fibptr = addr (save_data.fibs (i)); /* get fib address */ if ^fib.used then go to next_fib; /* skip if fib unused */ if fibptr = gcos_ext_stat_$prt then go to next_fib; /* skip simulapor files */ if fibptr = gcos_ext_stat_$pch then go to next_fib; if fibptr = gcos_ext_stat_$rs then go to next_fib; if fibptr = er then go to next_fib; fc = "00"; /* initialize file code */ do j = 1 to hbound (fct, 1); /* locate a file code for this file */ if fct.filecode (j) ^= "" then if ^fct.sysout (j) then if fct.fibptr (j) = fibptr then do; fc = fct.filecode (j); /* save the file code */ go to hit; end; end; hit: ; if fib.console then if fc = "t*" then go to close; /* don't display console t* */ if fc = "00" then if fib.plud = "435453"b3 then go to close; /* l* library */ if gcos_ext_stat_$save_data.this_act_abort then fib.disp = fib.adisp; /* use abort dispositions */ call display ("0"b); /* display file status */ do j = 1 to (j-1), (j+1) to hbound (fct, 1); /* look for additional fc's on file */ if fct.fibptr (j) = fibptr then do; fc = fct.filecode (j); /* save the file code */ call display ("1"b); end; end; fib.gein = "0"b; /* clear in case file gets saved */ fib.iocount = 0; /* reset in case file gets saved */ close: ; call gcos_close_file_ (fibptr); /* let gcos_close_file_ dispose of file appropriately */ next_fib: ; end; /* Clear the file code table */ do i = 1 to hbound (fct, 1); if fct.sysout (i) then do; if fct.dac (i) then dev_type = " DAC"; else dev_type = "SYOUT"; fc = translate (fct.filecode (i), "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz"); call ioa_$rs ("^20x^a ^a", msg, k, fc, dev_type); call gcos_write_$ascii_ptr (er, var_msg, "11111100"b); end; fct.filecode (i) = ""; /* clear file code */ fct.sysout (i) = "0"b; /* clear the sysout flag */ fct.fibptr (i) = null (); /* null() the fib pointer */ end; call gcos_write_$ptr (er, nl, "11111100"b); /* Write end of activity record on sysout print collector file */ call gcos_write_$record_ptr (gcos_ext_stat_$prt, addr (end_record) -> char20, (8)"0"b); call gcos_write_$force_ptr (gcos_ext_stat_$prt); return; %page; display: proc (short); dcl short bit (1) parm; if short = "0"b then do; if fib.tape then dev_type = " TAPE"; else if fib.print then dev_type = " PRNT"; else if fib.console then dev_type = " TYPE"; else if fib.null then dev_type = " NULL"; else dev_type = " DISK"; disp = dsp (fixed (fib.disp)); if fib.gein then gein = "*"; else if fib.perm then gein = "P"; else gein = " "; if fib.type then rand = "R"; else rand = " "; end; fc = translate (fc, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz"); if (dev_type = " DISK") & (short = "0"b) then call ioa_$rs ("^20x^a ^a^a ^1a^9d^9d^9d^9d^9d^1a^4x^a", msg, k, fc, disp, dev_type, gein, fib.iocount, divide (fib.init_posit, 320, 17, 0), divide (fib.current, 320, 17, 0), divide (fib.init_size, 320, 17, 0), divide (fib.size, 320, 17, 0), rand, fib.stream); else call ioa_$rs ("^20x^a ^a^a ^9d^41x^a", msg, k, fc, disp, dev_type, fib.iocount, fib.stream); call gcos_write_$ascii_ptr (er, var_msg, "11111100"b); return; end display; %page; /* Variables for gcos_cleanup_files_: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl addrel builtin; dcl char20 char(20)based; dcl dev_type char(5); dcl disp char(1); dcl divide builtin; dcl dsp (0:3) char(1) static int options(constant) init ("D", "R", "S", "C"); dcl er ptr; dcl fc char(2); dcl fixed builtin; dcl gcos_close_file_ ext entry (ptr); dcl gcos_write_$ascii_ptr ext entry (ptr, char(*), bit(8)); dcl gcos_write_$force_ptr ext entry (ptr); dcl gcos_write_$ptr ext entry (ptr, char(*), bit(8)); dcl gcos_write_$record_ptr ext entry (ptr, char(*), bit(8)); dcl gein char(1); dcl i fixed bin(24); dcl ioa_$rs entry() options(variable); dcl ioa_$rsnnl entry() options(variable); dcl j fixed bin(24); dcl k fixed bin(24); dcl msg char(100); dcl null builtin; dcl rand char(1); dcl size builtin; dcl substr builtin; dcl system_free_area area based (gcos_ext_stat_$system_free_pointer); dcl translate builtin; dcl var_msg char(k) based (addr (msg)); dcl nl char(1) static int options(constant)init (" "); /* The end_record structure following is written on the sysout print collector file at the end of each activity, so that gcos_sysprint will know to stop reading the file, and sort and translate the reports for the activity */ dcl 1 end_record int static options(constant) aligned, 2 rcw bit(36) init ("000004000374"b3) /* length=4, media code=3 (bcd print), report code= 74 */ , 2 newline_word bit(36) init ("770100000000"b3) /* the 7701 (bcd newline) prevents gcos_sys_xlate_ from trying to translate the rest of the record from bcd */ , 2 end_message char(12) init ("end activity") /* Ascii characters in BCD record is intential */ ; %page; %include gcos_ext_stat_; %page; %include gcos_fibs; end gcos_cleanup_files_;  gcos_close_file_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 60417 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_close_file_: proc (fp); /* This procedure is called with a pointer to the file info block of the file to be closed. The disposition of the file is checked. If is is save, no action is taken. If it is continue and the file is a tape, a set file protect command is issued and the tape is rewound. If the disposition of the file is release or dismount, the file is detached. If the file is a scratch file, it is also deleted. If it is a print or a punch file, its pathname is paced in the sysout queue. Author: DICK SNYDER SEPTEMBER 21, 1970 Change: T.CASEY DECEMBER 1972, OCTOBER 1973, AUGUST 1974 Change: D. KAYDEN APRIL 1974, JULY 1974, MARCH 1975, JUNE 1975 Change: Dave Ward 09/13/81 structured. Change: R. Barstad 11/03/82 IDS2 concurrency control on detach */ dcl fp ptr parm; fibptr = fp; if substr (fib.disp, 1, 1) then do; /* disp = save */ if fib.tape then /* tape */ if fib.disp = "11"b then do; /* with C disposition? */ call ios_$order ((fib.stream), "protect", null, status); /* set file to protected */ if code ^= 0 then do; /* fatal error */ err_msg = "from ios_$order protect ^a"; error_rtrn: ; call gcos_error_ (code, err_msg, fib.pathnm); return; end; call ios_$order ((fib.stream), "rewind", null, status); /* rewind tape */ if code ^= 0 then do; /* fatal error */ err_msg = "from ios_$order rewind ^a"; go to error_rtrn; end; fib.disp = "10"b; /* set file protect need not be done again */ end; return; /* saved file - do not detach */ end; if ^fib.attached then go to wipe; /* stream never attached */ if fib.console then go to wipe; /* no attachment exists for a typewriter console either */ if fib.null then go to wipe; /* no attachment exists for a null file */ if fib.tape then go to detach; call expand_path_ (addr (fib.pathnm), 168, /* break pathname up */ addr (pname), addr (ename), code); /* into entry and directory name */ if code ^= 0 then go to path_error; /* fatal error ? */ if fib.perm then go to detach; /* permanent disk file */ if fib.print | fib.punch then do; if fib.current = 0 then if fib.buffer = null /* see if anything was written on the file */ then go to detach; /* if not, ignore it */ /* File is ready to be printed or punched. Add pathname of file to sysout */ /* queue. There is room for 10 files. */ save_data.sysout_queue (save_data.sqindex) = ename; /* copy entry name to queue */ /* set media code of sysout file */ if fib.print then save_data.sysout_queue_media (save_data.sqindex) = 3; else save_data.sysout_queue_media (save_data.sqindex) = 1; save_data.sqindex = save_data.sqindex + 1; /* bump free entry index */ end; else delete = "1"b; /* file is scratch - remember to delete it */ detach: ; call ios_$detach ((fib.stream), "", "", status); /* detach */ if code ^= 0 then if code ^= error_table_$ioname_not_found then do; /* fatal error ? */ err_msg = "from ios_$detach ^a"; go to error_rtrn; end; /* deallocate IDS2 file */ if fib.perm & fib.type /* random */ then if gcos_ids2_concur_$have_xid(pname,ename,code) then do; call gcos_ids2_concur_$deallocate(pname,ename,fib.read, fib.write,code); if code ^= 0 then do; err_msg = "from gcos_ids2_concur_$deallocate ^a"; goto error_rtrn; end; end; if delete then do; if gcos_ext_stat_$save_data.debug then /* if user is interactive and wants questions */ delete_switches = "27"b3 ; /* noforce,question,nodirs,segs,links,chase */ else delete_switches = "07"b3 ; /* noforce,noquestion,nodirs,segs,links,chase */ call delete_$path (pname, ename, delete_switches, "gcos", code); if code ^= 0 then /* if anything wrong */ if code ^= error_table_$noentry then do; /* anything but file never having been written on, that is */ if ^gcos_ext_stat_$save_data.continue then /* unless -continue argument given, */ if ^gcos_ext_stat_$save_data.endjob then do; /* or already aborting */ path_error: ; err_msg = "attempting to delete ^a"; /* bomb out */ go to error_rtrn; end; if ^gcos_ext_stat_$save_data.brief then /* if user did not say -brief, print warning */ call com_err_ (code, "gcos_close_file_", "attempting to delete ^a", fib.pathnm); end; end; /* Remove buffer. */ wipe: ; fib.used = "0"b; /* set unused */ if fib.buffer_indx > 0 then buffer_in_use (fib.buffer_indx) = "0"b; fib.buffer_indx = 0; fib.buffer = null; /* set buffer null */ return; %page; /* Variables for gcos_close_file_: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl code fixed bin(35) based (addr (status)) /* error rtrn code */; dcl com_err_ ext entry options (variable); dcl delete bit (1) init ("0"b); dcl delete_$path ext entry (char (*), char (*), bit (6), char (*), fixed bin(35)); dcl delete_switches bit (6); dcl ename char (32) /* entry name of a file */; dcl error_table_$ioname_not_found ext static fixed bin(35) /* error code for no attach */; dcl error_table_$noentry ext static fixed bin(35) /* error code for no entry */; dcl err_msg char (60) var; dcl expand_path_ ext entry (pointer, fixed bin(24), pointer, pointer, fixed bin(35)); dcl gcos_error_ ext entry options (variable); dcl gcos_ids2_concur_$deallocate ext entry (char(*), char(*), bit(1), bit(1), fixed bin (35)); dcl gcos_ids2_concur_$have_xid ext entry (char(*), char(*), fixed bin(35)) returns (bit(1)); dcl ios_$detach ext entry (char (*) aligned, char (*), char (*), bit (72) aligned); dcl ios_$order ext entry (char (*) aligned, char (*), ptr, bit (72) aligned); dcl null builtin; dcl pname char (168) /* path name of a file */; dcl status bit (72) aligned /* ios_ status */; dcl substr builtin; dcl endoutput char (33) int static init (" ***end of output*** "); %page; %include gcos_fibs; %page; %include gcos_ext_stat_; end gcos_close_file_;  gcos_control_tables_.alm 09/09/83 1400.3rew 09/09/83 1006.8 153369 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** name gcos_control_tables_ " " This program provides the "gcos_control_tables_" data base " (Multics object) for the GCOS batch simulator ("gcos" " command). The data base defines the $ control cards " recognized by the simulator, the control card options and " what file cards are provided for activity control cards. " " This data base is referenced using the " "gcos_control_table_$X" external variables, where "X" is any " of the following segdefs. " segdef cardtable segdef activity_table segdef tablelen segdef totallen segdef filecard_count segdef comp_offset segdef exc_offset segdef nonact segdef tabstops " " Author: Dick Snyder August 25,1970 " Change: T. Casey June 1973, Sept 73, Dec 73, Feb 74, Mar 74, Aug 74 " Change: D. Kayden April 1974 " Change: R.H. Morrison October 1974, July 14, 1975, September 19,1975 " Change: R.H. Morrison Jan 30, 1976 " Change: M. R. Jordan August 1977 Rewritten. " Change: Dave Ward 02/11/81 Reorganized. Documented macro args. IDS2. " Change: Ron Barstad 83-08-09 Brought up to 4JS3 functionality " define arg1 " define arg1,arg2,...,arg8 " arg1 name of $ card. " arg2 (optional) name of library module [default: arg1]. " arg3 one or more names (parenthesized if >1) default options. " arg4 file code of source. " arg5 execution time (hundredths of CPU hours). " arg6 memory size (in K 1024 word increments). " arg7 limit of number print lines (thousands of lines). " arg8 name of tabulation table. macro define maclist off use cards aci "&1 ",8 ine &K,1 use fibs vfd 18/0,18/&u aci "&4 ",4 vfd 36/((&8-tabtable)/10) use vibs &p: null aci "&=&2,&[&1&;&2&] ",8 vfd 18/&(3&=&x,1&[&i&;+&i&]&),18/&5*36 vfd 18/&6*1024,18/&7*1000 vfd 18/optab,18/endtab-optab ifend maclist restore &end " file arg1,arg2 " arg1 file code. " arg2 sysout. " file arg1,arg2,arg3 " arg1 file code. " arg2 file length (in links). " arg3 lud, access, organization & retention designators. macro file maclist off vfd &=&2,sysout&[12/sysout,6/0&;12/&(3&=&x,1&[&i&;+&i&]&),6/&2&],a18/&1 maclist restore &end " option arg1,arg2,arg3 " arg1 name of the option (on $ option card). " arg2 set (on) or reset (off). " arg3 BCD name (<=6 characters uppercase). macro option maclist off aci "&1 ",8 vfd 18/&2,18/&3 maclist restore &end " Declarations of local variables. " " file card mnemonics. " bool generate_lud,4000 bool random,0400 bool save,2000 bool sysout,0200 bool write,1000 " " options definition mnemonics " equ set,1 equ reset,2 " bool BCD,000002 bool CLEAR,020000 bool COMDK,004000 bool COPY,000010 bool DEBUG,000100 bool DECK,002000 bool DUMP,400000 bool EXTEND,000002 bool FORM,000010 bool FORT,200000 bool GESAVE,000004 bool LNO,000004 bool LSTIN,000200 bool LSTOU,001000 bool MAP,000040 bool NGMAC,000100 bool ON1,004000 bool ON2,002000 bool ON3,001000 bool ON4,000400 bool ON5,000200 bool ON6,000100 bool OPTZ,000001 bool PURGE,040000 bool STAB,000100 bool SYMTAB,100000 bool UPDATE,000400 bool XREF,100000 " Definitions of $ control cards. " " Purpose: Look up table for gcos to determine what card type it has " read and if that card terminates an activity def'n " and possibly defines a new activity. " " NOTE!!! It is critical that activity definitions preceed non-activity " definitions in the section beginning at label "tad". It is also critical " that the order of activity definitions remain exactly as the order in " "activity_table". Also, there is a table in gcos_cc_activity_cards_ " that must be in the same order as these two tables. " " Also critical are: filecards at beginning of cardtable; " execution activities preceeding compilation activities; " and the endjob card at the end of the table. " " Note too that the number and order of the cards defined is critical. " If ANY are added or deleted then the indexed gotos in gcos_gein_ must " be changed and the declaration changed. " " "OBSOLETE" means only that that the control card is not documented in " the control card manual. The card is still knows to GCOS. " " References: " Control Cards Reference Manual, DD31-01, July 1980 " ALC1 gmap source, specifically the macros "CARD", "STDS", and "PATT". " use cards join /text/cards cardtable: null use fibs join /text/fibs activity_table: null use vibs join /text/vibs " " numbers are index used by gcos_gein_ define print " 1 define punch " 2 define disk " 3 OBSOLETE define disc " 4 OBSOLETE define drum " 5 OBSOLETE define file " 6 define mass " 7 OBSOLETE define prmfl " 8 define data " 9 define tape " 10 define tape7 " 11 define tape9 " 12 define sysout " 13 define remote " 14 define dac " 15 define type " 16 define read " 17 not supported actually " use cards fce: null " " Cards above this point are file cards, which must be written " on R* in an EXECUTE activity. " define snumb " 18 define commen " 19 comment define incode " 20 define etc " 21 define endcop " 22 endcopy define update " 23 define limits " 24 define msg1 " 25 define msg2 " 26 define msg3 " 27 define userid " 28 define alter " 29 define set " 30 define compil " 31 compile define copy " 32 define delete " 33 define endedi " 34 endedit define endld " 35 define ffile " 36 define form " 37 define futil " 38 define includ " 39 include define input " 40 define output " 41 define list " 42 define modify " 43 define multi " 44 define patch " 45 define qutil " 46 define seq " 47 define setsq " 48 define sysld " 49 define when " 50 define abort " 51 define dump " 52 define assem " 53 define change " 54 define get " 55 define getrwd " 56 define need " 57 define setsq1 " 58 define param " 59 " " Loader cards begin at this point. (This is not required by any program, though.) " define option " 60 define librar " 61 library define lowloa " 62 lowload define use " 63 define entry " 64 define nolib " 65 define equate " 66 define link " 67 define relcom " 68 define source " 69 define dkend " 70 define nload " 71 " Cards below this point all terminate activity definitions. " " Those immediately following define execution activities, " which do NOT get run after an abort, OR if psw bit 5 " gets turned off by a preceeding activity. " " WARNING: Changes in the order or number of any of these cards " must be also reflected in the wrapup table in gcos_cc_activity_cards_. " use cards tad: null " 72 define execut,geload,,i*,5,17,5,dollar_t file l*,,(generate_lud,random,save) file h*,5,write dec 0 " 73 define 355sim,,,*b,8,25,5,dollar_t dec 0 " " Those following define activities that " do NOT get run after aborts only. " " 74 define progra,??????,,i*,5,17,5,dollar_t dec 0 " 75 define conver,,,mc,20,9,1,dollar_t dec 0 " 76 define filedi,,,f*,4,40,10,dollar_t file *z,5,(random,write) file *1,4,write file *4,1,write file *5,3,write file b*,5,write file g*,4,write file a*,3,write file s*,6,write file c*,sysout dec 0 " 77 define sysedi,,,s*,5,33,10,dollar_t file l*,,(generate_lud,random,save) dec 0 " 78 define utilit,,,u*,3,11,10,dollar_t dec 0 " 79 define utl2,,,*u,3,35,10,dollar_t dec 0 " 80 OBSOLETE define convrt,conver,,mc,20,9,1,dollar_t dec 0 " 80.1 " define lodlib,,LISTIN,i*,5,16,5,dollar_t " file sc,5,(random,write) " dec 0 " 80.2 " define objlib,,LISTIN,i*,5,50,5,dollar_t " file sc,5,(random,write) " dec 0 " 80.3 " define srclib,,LISTIN,i*,5,65,5,dollar_t " file sc,5,(random,write) " dec 0 " The following cards define compilation activities, " which DO get run after an abort. " " WARNING: If it is necessary to move any activity cards from one section " of this table to the other, there are THREE other tables which must " be changed, to keep the entries in the same order. They are: " 1) activity_table, in this procedure (done automagically by file macro) " 2) the wrapup table in gcos_cc_activity_cards_ " 3) the indexed goto cc(i) in gcos_gein_.pl1 " use cards comp: null " 81 define fortra,fortx,(FORT,LSTIN,FORM,LNO,BCD),s*,5,27,12,fortran_t file *1,4,write file b*,3,(generate_lud,save,write) file c*,sysout file k*,sysout dec 0 " 82 define pl1,,(FORT,LSTIN),s*,15,90,12,pl1_t file b*,3,(generate_lud,save,write) file *1,3,write file *2,1,write file 3*,1,write file g*,4,write file c*,sysout file k*,sysout dec 0 " 83 define cobol,,(DECK,LSTIN),s*,15,33,20,cobol_t file g*,4,write file *1,4,write file *2,1,write file *3,15,(random,write) file *6,10,(random,write) file b*,2,(generate_lud,save,write) file c*,sysout file k*,sysout dec 0 " 84 define gmap,,(FORT,DECK,LSTOU),g*,4,25,10,gmap_t file *1,4,write file b*,2,(generate_lud,save,write) file c*,sysout file k*,sysout dec 0 " 85 define 355map,,(DECK,LSTOU),g*,4,32,10,gmap_t file *1,4,write file b*,2,(generate_lud,save,write) file *b,2,write file c*,sysout file k*,sysout dec 0 " 86 define algol,,(DECK,LSTIN),s*,8,28,10,pl1_t file *1,4,write file b*,2,(generate_lud,save,write) file c*,sysout file k*,sysout dec 0 " 87 OBSOLETE define forta,forty,(FORT,LSTIN,DECK,FORM,LNO,BCD),s*,5,25,12,fortran_t file *1,4,write file b*,2,(generate_lud,save,write) file g*,4,write file c*,sysout file k*,sysout dec 0 " 88 define forty,fortx,(FORT,LSTIN,FORM,LNO,BCD),s*,5,27,12,fortran_t file *1,4,write file b*,3,(generate_lud,save,write) file c*,sysout file k*,sysout dec 0 " 89 define jovial,,(DECK,LSTIN),s*,8,29,10,pl1_t file *1,4,write file *2,1,write file b*,2,(generate_lud,save,write) file c*,sysout file k*,sysout dec 0 " 90 OBSOLETE define asm66,,(DECK,LSTOU),s*,8,75,10,pl1_t file *1,2,write file *2,2,write file *3,5,(random,write) file b*,2,(generate_lud,save,write) file c*,sysout file k*,sysout dec 0 " 91 define cbl74,,LSTIN,s*,15,62,20,cobol_t file g*,8,write file *1,1,write file *2,3,write file *3,5,(random,write) file 4*,1,write file 5*,8,write file b*,2,(generate_lud,save,write) file c*,sysout file k*,sysout dec 0 " 92 define cbl68,,(DECK,LSTIN),s*,15,33,20,cobol_t " 92 OBSOLETE file g*,4,write file *1,4,write file *2,1,write file *3,15,(random,write) file *6,10,(random,write) file b*,2,(generate_lud,save,write) file c*,sysout file k*,sysout dec 0 " 93 OBSOLETE define malt,,LSTOU,s*,8,55,10,pl1_t file *1,2,write file *2,2,write file *3,5,(random,write) file b*,2,(generate_lud,save,write) file c*,sysout file k*,sysout dec 0 " 94 OBSOLETE define ilang,,LSTIN,s*,16,45,10,pl1_t file *1,5,write file *2,5,write file *3,1,write file *4,1,write file *5,1,write file *6,1,write file *7,2,write file b*,3,(generate_lud,save,write) file c*,sysout file k*,sysout dec 0 " 95 define ids,,(DECK,LSTIN),*s,15,33,20,cobol_t file s*,6,write file g*,4,write file *1,4,write file *2,1,write file *3,15,(random,write) file b*,2,(generate_lud,save,write) file c*,sysout file k*,sysout dec 0 " 96 define ids2,,,s*,5,54,10,cobol_t file 1*,22,(random,write) file 2*,10,(random,write) file 3*,10,(random,write) file 4*,44,(random,write) file 5*,1,(random,write) file 6*,10,(random,write) file c*,sysout dec 0 " 97 OBSOLETE define 4tran,,(DECK,LSTIN),s*,4,32,3,fortran_t file g*,4,write file *1,4,write file *2,1,write file b*,2,(generate_lud,save,write) file c*,sysout file k*,sysout dec 0 " 98 OBSOLETE define g3edit,,,i*,4,44,10,dollar_t dec 0 " 99 define fort77,,(FORT,LSTIN,LNO,FORM),s*,5,36,12,fortran_t file *1,8,write file b*,6,(generate_lud,save,write) file c*,sysout file k*,sysout dec 0 " 100 define fortx,,(FORT,LSTIN,LNO,FORM,BCD),s*,5,30,12,fortran_t file b*,3,(generate_lud,save,write) file *1,4,write file c*,sysout file k*,sysout dec 0 " 101 define cids2,,,s*,5,64,10,cobol_t file 1*,22,(random,write) file 2*,10,(random,write) file 3*,10,(random,write) file 4*,10,(random,write) file 6*,10,(random,write) file c*,sysout dec 0 " 102 define rpg2,,(LSTIN,MAP),s*,5,25,5,cobol_t file b*,3,(generate_lud,save,write) file *1,5,write file *2,5,write file 3*,5,write file 6*,5,write file c*,sysout file k*,sysout dec 0 " Cards below this point still terminate activity definitions " but they don't define new activities as do those above starting " at label "tad". " use cards tad2: null define ident " 103 define object " 104 define break " 105 define goto " 106 define if " 107 define endjob " 108 use cards cte: null " end of cardtable " Purpose: list of unimplemented control cards, so the simulator can " distinguish, in its error messages, between unimplemented cards " and typing mistakes. define 1401si " 109 OBSOLETE define 167pk " 110 OBSOLETE define 170pk " 111 define 180pk " 112 define 181pk " 113 define 190pk " 114 define 191pk " 115 define 225sim " 116 OBSOLETE define 310pk " 117 define 400pk " 118 define 44sim " 119 OBSOLETE define 450pk " 120 define 94optn " 121 OBSOLETE define 94prt " 122 OBSOLETE define 94sim " 123 OBSOLETE define 94syso " 124 OBSOLETE define ascii " 125 define dspk " 126 OBSOLETE define enx " 127 define extedi " 128 extedit define extend " 129 define filsys " 130 define ntape " 131 define perm " 132 OBSOLETE define pptp " 133 define pptr " 134 define privit " 135 privity define produc " 136 OBSOLETE define reladd " 137 define report " 138 define reptl " 139 define reptr " 140 define s2prog " 141 define sysnam " 142 sysname define tape27 " 143 define tape29 " 144 define filgp " 145 define lodlib " 146 define objlib " 147 define pps " 148 define ppsrpt " 149 define psm " 150 define srclib " 151 " use cards tte: null " Lengths of tables. " " Purpose: defines number of entries in cardtable " (and also the offset in total cardtable at which the unimplemented cards start.) tablelen: vfd 36/(cte-cardtable)/2 " " Purpose: define number of entries in total cardtable " (including the unimplemented cards) totallen: vfd 36/(tte-cardtable)/2 " " Purpose: holds count of filecards in first section of cardtable, " which must be written on R* in an EXECUTE activity. filecard_count: vfd 36/(fce-cardtable)/2 " " Purpose: holds offset in cardtable where compilation activities " (that DO get run after aborts) begin. comp_offset: vfd 36/(comp-cardtable)/2+1 " " Purpose: defines offset in cardtable where activity terminating " cards begin. exc_offset:vfd 36/(tad-cardtable)/2+1 " " Purpose: defines offset in cardtable where cards which terminate activities " without defining new activities begin. nonact: vfd 36/(tad2-cardtable)/2+1 " Purpose: tabstops for canonicalizing the cards of various types. tabstops: dec 6 tabstops.count " (number of 10-word tabstop sets which follow) tabtable: null dollar_t: dec 8,16,32,73,0,0,0,0,0,0 tab(0) dollar cards data_t: dec 0,0,0,0,0,0,0,0,0,0 tab(1) data cards gmap_t: dec 8,16,32,73,0,0,0,0,0,0 tab(2) gmap cards fortran_t:dec 7,73,0,0,0,0,0,0,0,0 tab(3) fortran cards pl1_t: dec 10,20,30,40,50,60,70,0,0,0 tab(4) pl1 cards cobol_t: dec 8,12,73,0,0,0,0,0,0,0 tab(5) cobol cards " Definition of options. " " Activity card option lookup table. This table contains the name of " each legal option for each type of activity defining card. The format " of each entry in the table is as follows: " " words 1&2--option name " word3 upper--index into xfer vector in gcos_cc_activity_cards_ " word3 lower--psw bit settings optab: null option ascii,reset,BCD option bcd,set,BCD option clear,set,CLEAR option comdk,set,COMDK option copy,set,COPY option debug,set,DEBUG option deck,set,DECK option dump,set,DUMP option form,set,FORM option gesave,set,GESAVE option gmac,reset,NGMAC option lno,set,LNO option lstin,set,LSTIN option lstou,set,LSTOU option map,set,MAP option nclear,reset,CLEAR option ncomdk,reset,COMDK option ncopy,reset,COPY option ndebug,reset,DEBUG option ndeck,reset,DECK option ndump,reset,DUMP option nform,reset,FORM option ngmac,set,NGMAC option nlno,reset,LNO option nlstin,reset,LSTIN option nlstou,reset,LSTOU option nomap,reset,MAP option noptz,reset,OPTZ option npurge,reset,PURGE option nstab,reset,STAB option nsymta,reset,SYMTAB option nxec,set,000040 option nxref,reset,XREF option on1,set,ON1 option on2,set,ON2 option on3,set,ON3 option on4,set,ON4 option on5,set,ON5 option on6,set,ON6 option optz,set,OPTZ option purge,set,PURGE option stab,set,STAB option symtab,set,SYMTAB option xref,set,XREF endtab: null " end  gcos_cv_ascii_gebcd_.alm 09/09/83 1400.3rew 09/09/83 1006.8 42111 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" " " " " T R A N S L A T E A S C I I T O B C D " " " This routine takes four parameters. Parameter 1 is a pointer " to a string of ASCII characters. Parameter 2 is the length " of that string. Parameter 3 is a pointer to the receiving " field for the translated BCD output. Parameter 4 is a count " of the number of BCD characters placed in the receiving field. " For the main entry, this is always equal to parameter 2. This " return argument is only used so that existing programs that " call this entry need not be changed immediately. When all routines " that call this entry have been changed to ignore this parameter, " this entry can be changed to stop returning it. " " For the gcos_cv_printline_gebcd_ entry, the count returned in parameter " 4 may not equal the count of ASCII characters input. " Certain special ASCII characters are recognized and converted " to printer control information. Newline characters are converted " to octal 7701 (skip one line). If n contiguous newlines are found, " then a control sequence of 77n is produced (skip n lines). If new " page characters are encountered, they are converted to 7720 octal " (skip to head of form). " " For the gcos_cv_ascii_gebcd_check_ entry, parameter 4 is the character " number of the first character in the input string that could not be " converted to bcd. If no such charcters are found, parameter 4 is zero. " " " WRITTEN BY DICK SNYDER AUGUST 12,1970 " Modified by Dick Snyder 10/31/72 to add $ incode processing " MODIFIED BY T. CASEY JUNE 1974 " REWRITTEN BY D. KAYDEN DECEMBER 1974 " MODIFIED BY R.H. MORRISON 5/19/76 " " """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" name gcos_cv_ascii_gebcd_ entry gcos_cv_ascii_gebcd_ entry gcos_cv_ascii_gebcd_check_ entry gcos_cv_printline_gebcd_ gcos_cv_ascii_gebcd_: eppbp ap|2,* bp -> input data eppbp bp|0,* lda ap|4,* a = length sta ap|8,* store output string length eppbb ap|6,* bb -> output buffer eppbb bb|0,* join: mvt (pr,rl),(pr,rl) desc9a bp|0,al desc6a bb|0,al arg table short_return gcos_cv_ascii_gebcd_check_: eppbp ap|2,* eppbp bp|0,* bp -> input data lda ap|4,* a = length eppbb ap|6,* bb -> output buffer eppbb bb|0,* tct (pr,rl) desc9a bp|0,al arg tctable arg bb|0 stz ap|8,* ttn join no illegal chars found lda bb|0 ana -1,dl ada 1,dl move count from last good to first bad char sta ap|8,* store error code short_return gcos_cv_printline_gebcd_: save eppbp ap|2,* bp -> input data eppbp bp|0,* lxl7 ap|4,* eppbb ap|6,* bb -> output buffer eppbb bb|0,* stz tally zero output character count scm (pr,rl),(du),mask(016) desc9a bp|0,x7 arg 0 arg tally ldq tally tze ttf mvt (pr,rl),(pr,rl) desc9a bp|0,ql desc6a bb|0,ql arg table ttn ret ttf: stz count pull: mlr (pr,ql),(pr),fill(0) desc9a bp|0,1 desc9a temp,4 lda temp cmpa =o012000,du tnz not_nl aos count adq 1,dl cmpq ap|4,* tmi pull put_nl: lda count als 24 ana =o007700,du ora =o770000,du sta NL eppbp NL tra put_cc not_nl: szn count tnz put_nl cmpa =o014000,du tnz ret eppbp NP put_cc: ldq tally mlr (pr),(pr,ql) desc6a bp|0,2 desc6a bb|0,2 adq 2,dl ret: stq ap|8,* return table: oct 020020020020 oct 020020020020 oct 020020020020 oct 020020020020 oct 020020020020 oct 020020020020 oct 020020020020 oct 020020020020 oct 020077076013 oct 053074032057 oct 035055054060 oct 073052033061 oct 000001002003 oct 004005006007 oct 010011015056 oct 036075016017 oct 014021022023 oct 024025026027 oct 030031041042 oct 043044045046 oct 047050051062 oct 063064065066 oct 067070071012 oct 037034040072 oct 057021022023 oct 024025026027 oct 030031041042 oct 043044045046 oct 047050051062 oct 063064065066 oct 067070071012 oct 040034020020 tctable: dec -1,-1,-1,-1,-1,-1,-1,-1 dec 0,0,0,0,0,0,0,0 dec 0,0,0,0,0,0,0,0 dec 0,0,0,0,0,0,0 vfd 9/0,9/0,9/1,9/1 NP: oct 772000000000 temp NL,temp,tally,count end  gcos_error_.pl1 11/05/86 1601.3r w 11/04/86 1042.4 38070 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ******************************************************************************************** ******************************************************************************************** * * * G C O S E R R O R * * * This procedure is called to report any fatal job error to the user. * The procedure takes a status code as the first argument and an ioa_ * control string and arguments follow. * * * Rewritten by M. R. Jordan, August 1977 * ******************************************************************************************** ******************************************************************************************** */ gcos_error_: procedure (a_code); dcl NL char (1) static internal options (constant) init (" "); dcl a_code fixed bin(35); dcl addr builtin; dcl arg_list_ptr ptr; dcl callers_sp ptr; dcl com_err_ entry options (variable); dcl convert_status_code_ entry (fixed bin(35), char (8) aligned, char (100) aligned); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$stack_frame_ptr entry () returns (ptr); dcl db entry (); dcl gcos_cc_endjob_ entry (); dcl gcos_et_$fatal_error fixed bin(35) ext; dcl gcos_write_to_er_ entry options (variable); dcl ioa_$general_rs entry (ptr, fixed bin(24), fixed bin(24), char (*), fixed bin(24), bit (1), bit (1)); dcl ioa_$ioa_stream entry options (variable); dcl long_message char (100) aligned; dcl message char (256) varying; dcl name char (name_len) based (name_ptr); dcl name_len fixed bin(24); dcl name_ptr ptr; dcl pl1_frame_$name entry (ptr, ptr, fixed bin(24)); dcl rtn_string char (256); dcl rtn_string_len fixed bin(24); dcl rtrim builtin; dcl short_message char (8) aligned; dcl substr builtin; /* If debugging then tell the user who done it ... */ if gcos_ext_stat_$save_data.debug then do; sp = cu_$stack_frame_ptr (); callers_sp = stack_frame.prev_sp; call pl1_frame_$name (callers_sp, name_ptr, name_len); message = NL || "From " || name; end; else message = ""; /* Get the message for the specific error from the error table. */ if a_code ^= 0 then do; call convert_status_code_ (a_code, short_message, long_message); if long_message ^= "" then message = message || NL || rtrim (long_message); end; /* Get the ioa_ part of the error message. */ call cu_$arg_list_ptr (arg_list_ptr); call ioa_$general_rs (arg_list_ptr, 2, 3, rtn_string, rtn_string_len, "0"b, "1"b); if rtn_string_len ^= 0 then if substr (rtn_string, 1, rtn_string_len) ^= "" then message = message || NL || substr (rtn_string, 1, rtn_string_len); /* Let the user know that there is a problem. */ call com_err_ (gcos_et_$fatal_error, "gcos_error_", "^a", message); /* Output the message on the execution report and tell the user we're aborting. */ call convert_status_code_ (gcos_et_$fatal_error, short_message, long_message); call gcos_write_to_er_ ("gcos_error_: ^a^a", long_message, message); call ioa_$ioa_stream ("error_output", "Aborting GCOS job."); /* If the user is debugging the simulator, then stop for a moment. */ if gcos_ext_stat_$save_data.debug then do; call ioa_$ioa_stream ("error_output", "CALLING DEBUG"); call db (); end; /* Now try to terminate gracefully ... If we have started to process the ENDJOB card we must have real trouble (we cannot produce the SYSOUT). */ if gcos_ext_stat_$save_data.endjob then do; call com_err_ (0, "gcos_error_", "Unable to produce SYSOUT."); goto gcos_ext_stat_$abort_return; end; call gcos_cc_endjob_ (); return; %include gcos_ext_stat_; %include stack_frame; end gcos_error_;  gcos_et_.alm 11/05/86 1601.3r w 11/04/86 1038.8 83484 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " G C O S E N V I R O N M E N T E R R O R T A B L E " " Error Table for the GCOS Environment. " " Created: M. R. Jordan 08/01/77 " Changed: Dave Ward 05/22/81 multirecord codes. " Changed: Scott C. Akers 02/22/82 Tape data exceeds buffer size. " " maclist off include et_macros et gcos_et_ ec no_reason,GCOS0000, (no reason specified) ec cant_load_ssa,GCOS0001, (cannot load ssa module) ec ssa_mod_cksm_err,GCOS0002, (ssa module cheksum error) ec cant_find_ssa_mod,GCOS0003, (cannot find ssa module) ec dchln_preselected,GCOS0004, (dchln preselected) ec out_of_time,GCOS0005, (i8-run time exhausted) ec bad_mme_in_cc,GCOS0006, (i2-improper mme in c.c) ec geendc_not_in_cc,GCOS0007, (i6-geendc but not in cc.) ec pri_mailbox_err,GCOS0008, (primary mailbox error) ec connect_or_ti_err,GCOS0009, (connect or t.i. error) ec ioc_data_service_err,GCOS0010, (ioc data-service error) ec ioc_mem_addr_flt,GCOS0011, (ioc memory address fault) ec ioc_not_master_mode,GCOS0012, (ioc not master mode flt.) ec mem_parity_in_io,GCOS0013, (memory parity during i/o) ec ioc_not_ctl_proc,GCOS0014, (ioc not ctl. proc. fault) ec ioc_mem_protect,GCOS0015, (ioc mem. protect fault) ec mem_time_out_in_io,GCOS0016, (memory time-out in i/o) ec other_mem_ioc_err,GCOS0017, (other ioc-memory error) ec mem_addr_flt,GCOS0018, (f0-memory address fault) ec bad_mme_addr,GCOS0019, (i1-improper mme address) ec fault_tag_flt,GCOS0020, (f1-fault tag fault) ec command_flt,GCOS0021, (f2-command fault) ec derail_flt,GCOS0022, (f3-derail fault) ec lockup_flt,GCOS0023, (f4-lockup fault) ec mem_parity_flt,GCOS0024, (f6-memory parity fault) ec illegal_procedure,GCOS0025, (f7-undefined op. fault) ec over_or_under_flow,GCOS0026, (f9-overflow/underflow) ec divide_check_flt,GCOS0027, (i0-divide check fault) ec op_not_complete_flt,GCOS0028, (f8-op not complete fault) ec io_oob,GCOS0029, (i/o out of memory bounds) ec fc_not_defined,GCOS0030, (i3-file code not defined) ec no_inos_file_ptr,GCOS0031, (i5-no geinos filepointer) ec access_beyond_file,GCOS0032, (i7-access beyond file) ec bad_status_ret_ptr,GCOS0033, (k2-bad status ret. ptr.) ec invalid_file_ptr,GCOS0034, (k3-invalid file pointer) ec invalid_dcw_ptr,GCOS0035, (k4-invalid dcw pointer) ec bad_cc_ptr,GCOS0036, (k5-bad courtesy call ptr) ec bad_io_cmnd_file,GCOS0037, (k6-bad i/o command-file) ec two_tdcws,GCOS0038, (k7-two successive tdcws) ec invalid_io_for_device,GCOS0039, (k1-invalid i/o on device) ec operator_term_rqst,GCOS0040, (x2-operator term request) ec operator_kill_rqst,GCOS0041, (x2-operator kill request) ec io_lim_call_save,GCOS0042, (m4/n4-i/o lim. call/save) ec io_err_call_save,GCOS0043, (m6/n7-i/o err. call/save) ec no_call_file_pat,GCOS0044, (m5-no pat for call file) ec bad_call_save_device,GCOS0045, (m1/n5-bad dev. call/save) ec non_rndm_call_file,GCOS0046, (non-random gecall file) ec save_file_full,GCOS0047, (n8-gesave file is full) ec call_rstr_cksm,GCOS0048, (m6-call/rstr checksum) ec low_rstr_origin_used,GCOS0049, (low gerstr origin used) ec zero_save_word_cnt,GCOS0050, (n4-zero gesave word ct.) ec call_name_missing,GCOS0051, (m2/m3-call name missing) ec call_out_of_file_span,GCOS0052, (n8-call out of file span) ec bad_gcos_call,GCOS0053, (improper gecos call) ec zero_fc_to_more,GCOS0054, (gemore - zero filecode) ec bad_more_param,GCOS0055, (m0-bad gemore parameter) ec pat_full_from_more,GCOS0056, (no room in pat - gemore) ec not_mass_store_more,GCOS0057, (m7-not disc/drum gemore) ec bad_rout_op_code,GCOS0058, (r1-bad gerout op. code) ec pat_full_from_rout,GCOS0059, (r4-gerout pat exhausted) ec rmt_term_rec_size,GCOS0060, (rmt terminal record size) ec bad_rmt_station_id,GCOS0061, (undef remote station id) ec bad_rout_pgm_id,GCOS0062, (invalid gerout prog. id) ec output_limit_exceeded,GCOS0063, (0>-output limit exceeded) ec syot_rec_size_err,GCOS0064, (sysout record size error) ec syot_seek_err,GCOS0065, (sysout seek error) ec syot_alloc_err,GCOS0066, (sysout allocation error) ec bad_syot_status_ptr,GCOS0067, (01-bad syot status ptr.) ec bad_syot_buffer_ptr,GCOS0068, (01-bad syot buffer ptr.) ec syot_buffer_too_high,GCOS0069, (01-syot buffer > limits) ec irrecoverable_io_err,GCOS0070, (ep-irrecoverable i/o err) ec bad_seek_dcw,GCOS0071, (k4-invalid seek dcw i/o) ec bad_syot_media_code,GCOS0072, (bad gesyot media code) ec cannot_rollback,GCOS0073, (n3-rollback not possible) ec tss_requested_term,GCOS0074, (tss requested term) ec duplicate_file_more,GCOS0075, (gemore duplicate file) ec bad_io_sct_ptr,GCOS0076, (invalid i/o sct pointer) ec impermissible_perm_write,GCOS0077, (impermissible perm write) ec impermissible_perm_read,GCOS0078, (impermissible perm read) ec ids_rec_too_long,GCOS0079, (d2-ids record too long) ec out_of_syot_stor,GCOS0080, (sysout storage exhausted) ec bad_mme_param,GCOS0081, (invalid mme parameter) ec lost_extra_ssa_contents,GCOS0082, (lost extra ssa contents) ec aloc_deleted_job,GCOS0083, (j3-aloc deleted job) ec bad_news_buf_addr,GCOS0084, (bad buffer addr - genews) ec guessing_prmfl_more,GCOS0085, (guessing on prmfl gemore) ec no_userid_prmfl_more,GCOS0086, (no userid - prmfl gemore) ec oper_stop_rqst,GCOS0087, (x2-operator stop request) ec cannot_move_job,GCOS0088, (cannot move job in core) ec enexpected_pcw,GCOS0089, (iom chan unexpected pcw) ec improper_instr,GCOS0090, (iom chan improper instr.) ec iom_chan_bad_dcw,GCOS0091, (iom chan improper dcw) ec iom_cent_lpw_tro,GCOS0092, (iom cent lpw tally rnout) ec iom_cent_two_tdcws,GCOS0093, (iom cent two tdcws) ec iom_cent_bndry_err,GCOS0094, (iom cent boundary error) ec iom_cent_4bar_viol,GCOS0095, (iom cent 4-bar violation) ec iom_cent_idcw_res_mode,GCOS0096, (iom cent idcw res mode) ec iom_cent_char_dis,GCOS0097, (iom cent char pos/sz dis) ec bad_backdoor_fc,GCOS0098, (backdoor f.c. unknown) ec bad_backdoor_file,GCOS0099, (invalid file to backdoor) ec ids_addr_oob,GCOS0100, (ids address out of bound) ec secur_scc_invalid,GCOS0101, (secur-scc invalid) ec file_alloc_err,GCOS0102, (file allocation error) ec scc_invld_for_user,GCOS0103, (secur-scc inval for user) ec scc_invld_for_line,GCOS0104, (secur-scc inval for line) ec duplicate_report,GCOS0105, (secur-duplicate report) ec invalid_dcw_string,GCOS0106, (secur-invalid dcw string) ec invalid_fnc_code,GCOS0107, (secur-invalid funct code) ec no_links_for_swap_file,GCOS0108, (no links for swap file) ec data_access_sys_abrt,GCOS0109, (data access system abort) ec fms_protect_fail,GCOS0110, (fms protection failure) ec bss_mem_bndry_err,GCOS0111, (bss main mem boundry err) ec bss_no_sys_respnse,GCOS0112, (bss no system response) ec bss_connect_halt,GCOS0113, (bss connect halt) ec isp_sys_term,GCOS0114, (isp system termination) ec bad_eis_data,GCOS0115, (illegal eis data) ec io_channel_deactivated,GCOS0116, (i/o channel deactivated) ec user_abort_request,GCOS0117, (user abort request) ec cache_parity_flt,GCOS0118, (f5-cache parity fault) ec bad_rels_rqst,GCOS0119, (invalid mme gerels reqst) ec unimp_mme,unimpmme, (The specified MME is not supported by the Multics GCOS Environment.) ec fatal_error,fatalerr, (A fatal error has occured. The current job is being terminated.) ec cc_bad_fc,badfc, (Illegal file code value specified.) ec cc_bad_field,badfield, (Bad control card field.) ec cc_field_too_long,toolong, (Control card field too long.) ec cc_missing_fc,missfc, (No file code value specified.) ec cc_bad_lud,badlud, (Illegal Logical Unit Designator (LUD) specified.) ec cc_unimp,unimpcc, (The specified $ control card is not supported by the Multics GCOS Environment.) ec cc_missing_field,misfield, (A required control card field is either missing or null.) ec cc_bad_card,badcard, (An error has occured in processing the following $ control card:) ec too_many_activs,tomnyact, (Too many activities have been specified.) ec no_restart,nrestart, (Job restart not specified.) ec fms_bad_cfdesc,FMS00005, (incorrect catalog/file description) ec fms_perms_denied,FMS00003, (permissions denied) ec non_gcos_fault,badflt, (A fault has occured which is impossible on a GCOS system.) ec no_free_fibs,nofibs, (No free fibs - contact support personel.) ec rel_fibs_exceeded,tmrfib, (Exceeded number of released fibs provided for.) ec record_too_long,toolong, (A record whose length is > 319 words has been encountered.) ec need_multirec,needmr, (Multirecord MME GEINOS needed for linked disk file.) ec bad_multirec,badmr, (Multirecord MME GEINOS block count not same as words requested.) ec request_too_big,bigreq, (Requested data exceeds permitted tape buffer size.) end  gcos_ext_stat_.cds 09/09/83 1400.3rew 09/09/83 1006.8 44271 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ gcos_ext_stat_:proc; /* Generate object for "gcos_ext_stat_" data. Author: Dave Ward 1981 Modified: Ron Barstad 83-07-21 Remove dependency on ted_com, add include file */ /** Initialize cds_args **/ cds_args_ptr=addr(space_for_cds_args); unspec(space_for_cds_args)="0"b; /** Reference structure input to cds to assure it is in runtime table. **/ if addr(gcos_ext_stat_)=null() then ; /** No text section **/ cds_args_ptr -> cds_args.sections (1).p = null (); cds_args_ptr -> cds_args.sections (1).len = 0; cds_args_ptr -> cds_args.sections (1).struct_name = "NO_TEXT"; /** Static section **/ cds_args_ptr -> cds_args.sections (2).p = addr (gcos_ext_stat_); /* Caller's data. */ cds_args_ptr -> cds_args.sections (2).len = size (gcos_ext_stat_); /* No. words in data structure. */ cds_args_ptr -> cds_args.sections (2).struct_name = "gcos_ext_stat_"; cds_args_ptr -> cds_args.seg_name = "gcos_ext_stat_"; /* Entryname of object segment. */ cds_args_ptr -> cds_args.num_exclude_names = 0; /* All level 2 names are entry points. */ cds_args_ptr -> cds_args.exclude_array_ptr = null (); cds_args_ptr -> cds_args.switches.defs_in_link = "0"b; /* Definitions contiguous to text section. */ cds_args_ptr -> cds_args.switches.separate_static = "0"b; /* Static in linkage section (to bind). */ cds_args_ptr -> cds_args.switches.have_text = "0"b; /* No text section. */ cds_args_ptr -> cds_args.switches.have_static = "1"b; /* There is a static section. */ cds_args_ptr -> cds_args.switches.pad = "0"b; /* Must be zeroes (see create_data_segment_). */ call create_data_segment_ (cds_args_ptr, code); if code ^= 0 then call com_err_ (code, "cds_gcos_ext_stat_"); else call com_err_( 0,"gcos_ext_stat_","Object for gcos_ext_stat_ created [^i words].",size(gcos_ext_stat_)); return; %page; /** Data for cds **/ dcl addr builtin; dcl cds_args_ptr ptr init(null()); dcl code fixed bin(35); dcl com_err_ entry options(variable); dcl create_data_segment_ entry(ptr,fixed bin(35)); dcl null builtin; dcl size builtin; dcl unspec builtin; dcl 1 space_for_cds_args aligned like cds_args; %page; /** This data structure must exactly match that of gcos_ext_stat_.incl.pl1 **/ dcl 1 gcos_ext_stat_ aligned, 2 abort_reason char (128) varying, 2 abort_return label, 2 activity_card_num pic "9999", 2 activity_name char(8), 2 activity_start_time fixed bin(71), 2 card_num pic "9999", 2 dbs (36)bit(1), 2 default_nondollar char(2), 2 dir_rings (3) fixed bin(3), 2 dpno char(100) varying, 2 dpo char(100) varying, 2 endfc char(2), 2 er ptr, 2 etc_filecode char(2), 2 gcos_slave_area_seg ptr, 2 gf fixed bin(24), 2 incode fixed bin(24), 2 increment_hold fixed bin(24), 2 initial_cpu_time fixed bin(71), 2 input_segment_path char(168) varying, 2 jcl_warnings fixed bin(24), 2 job_cpu_time fixed bin(71), 2 job_id char(18) varying, 2 job_real_time fixed bin(71), 2 last_mme fixed bin(24), 2 ldrss fixed bin(24), 2 max_activities fixed bin(24), 2 max_mem fixed bin(19), 2 mme_rtrn label, 2 nondollar char(2), 2 nongcos char(2), 2 normal_return label, 2 patchfile_ptr ptr, 2 pathname_prefix char(168)var, 2 pch ptr, 2 pdir char(168) varying, 2 prt ptr, 2 rs ptr, 2 saveseg_ptr ptr, 2 save_dir char(168) varying, 2 seg_rings (3) fixed bin(3), 2 sig_ptr ptr, 2 skip_umc bit(1), 2 snumb bit (30) aligned, 2 sought_label char(8), 2 statistics (3*44) fixed bin(24), 2 stop_code fixed bin(24), 2 storage_limit fixed bin(19), 2 sysout_limit fixed bin(35), 2 sysout_lines fixed bin(35), 2 system_free_pointer ptr, 2 tape_buffer_size fixed bin(35), 2 temp_dir char(168) varying , 2 temp_seg_ptr ptr, 2 termination_code bit (18), 2 time_limit fixed bin(71), 2 userid char(12), 2 validation_level fixed bin(3), 2 courtesy_call_control aligned like gcos_ext_stat_$courtesy_call_control, 2 fct aligned like gcos_ext_stat_$fct, 2 save_data aligned like gcos_ext_stat_$save_data, 2 mc like gcos_ext_stat_$mc, 2 gcos_gtss like gcos_ext_stat_$gcos_gtss; %page; %include gcos_ext_stat_; %page; %include cds_args; end;  gcos_fault_processor_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 120582 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_fault_processor_: proc; /* This procedure handles all faults occurring in a gcos program except the MME. Once the fault cause is interpreted, the gcos slave program prefix fault vector is examined to see if the gcos program has set up a handler for this fault. Each fault vector consists of two words except for lockup. The first word is used to store the instruction counter and indicators at the time of the fault. The second word contains the address of where to go in the gcos program to process the fault. If the location is 0, the program will be aborted. If a fault processing routine is specified, the scu data will be modified to cause control to return to the gcos program at that location. Author: DICK SNYDER OCTOBER 2, 1970 Change: T. CASEY SEPTEMBER 1973, FEBRUARY 1974, APRIL 1974 Change: D. KAYDEN JUNE 1974, DECEMBER 1974 Change: T. CASEY AUGUST 1975 Change: M. R. Jordan, October 1977 Change: Dave Ward 06/03/81 hashed fault name list. Change: Dave Ward 06/03/81 RSW (2) provision. */ cond_info.version = 1; /* expect version 1 of info structure */ call find_condition_info_ (null, addr (cond_info), code); mcp = cond_info.mcptr; /* Location of machine conditions at fault time. */ scup = addr (mc.scu); /* Corresponding SCU data. */ /* Hash the condition name. */ unspec (hv) = cn.l /* Length of condition name, */ ||cn.b (1) /* leftmost character, */ ||cn.b (divide (length (condition_name)+1, 2, 17)) /* middle character, */ ||cn.b (length (condition_name)); /* rightmost character. */ i = THL (mod (hv, hbound (THL, 1)+1)); /* Probe the hash start list. */ if i>0 then /* Name possibly in hash list. */ if condition_name = substr (string (TC), TL (i).fc, TL (i).ln) then do; /* Fault name found. */ if scu.ppr.psr ^= substr (baseno (gcos_ext_stat_$gcos_slave_area_seg), 4, 15) then goto general_abort; /* abort if fault occurred outside gcos segment */ faultv.ic = instruction_counter+1; /* get IC */ faultv.ind = string (scu.ir); /* and I */ goto fault (i); /* handle fault if we want */ end; if condition_name = "simfault_" then goto general_abort; pass_it_on: call continue_to_signal_ (code); /* let's pass it on */ return_to_gcos_code: ; return; %page; /* Come here on a wide class of faults we won't take specific action on */ /* "page" fault. */ fault (10): general_abort: /* to avoid aborting job because of something like a missing segment, or bad access (which Multics normally allows users to recover from) we will ask the user if he wants to abort or let Multics handle it - but only if -db was given */ if gcos_ext_stat_$save_data.debug then do; query_info.yes_or_no_sw = "1"b; call command_query_ ( addr (query_info) , answer , "gcos" , "fault: ^a occurred while running an activity." ||"^/Do you wish to invoke the Multics fault handlers ?" , cond_info.condition_name ); if answer = "yes" then goto pass_it_on; end; abort_code = gcos_et_$non_gcos_fault; /* abort */ goto abrt1; %page; /* derail */ fault (01): abort_code = gcos_et_$derail_flt; /* abort type */ fault_vector = 12; /* vector offset */ goto user_fault; /* see if user has handler for fault */ %page; /* fault tag 1 */ fault (04): abort_code = gcos_et_$fault_tag_flt; /* abort type */ fault_vector = 4; /* vector offset */ goto user_fault; /* see if user has handler */ %page; /* Illegal procedure fault (used for RSW recognition). */ fault (05): ; if baseno (cond_info.loc_ptr) = baseno (gcos_ext_stat_$gcos_slave_area_seg) then /* Fault occured in gcos memory segment. */ if cond_info.loc_ptr -> INS.OPCODE = "231"b3 then /* => RSW instruction. */ if cond_info.loc_ptr -> INS.ADDRESS.r3b = 2 then do; /* Switches selected. */ instruction_counter = instruction_counter+1; /* Increment to instruction after RSW. */ scu.rfi = "1"b; /* Refetch instruction. */ scu.if = "0"b; /* Reset fault indicator. */ /* Set the A register to reflect switch info. */ mc.regs.a = /* (A-reg bits) */ /* (0-3) Port address expansion option: */ (4)"0"b /* (4-5) Reserved for future use: */ || (2)"0"b /* (6-12) Processor fault base address switches: */ || (7)"0"b /* (13-16) L66 peripheral connectability: */ || (4)"0"b /* (17) Future use (must be zero): */ || (1)"1"b /* (18) BCD option installed: */ || (1)"1"b /* (19) DPS type processor: */ || (1)"0"b /* (20) 8K cache option installed: */ || (1)"0"b /* (21) Gear shift model processor: */ || (1)"0"b /* (22) Power pach option installed: */ || (1)"0"b /* (23) VMS-CU option installed - 66B' proc: */ || (1)"0"b /* (24) VMS-VU option installed - 66B proc: */ || (1)"0"b /* (25) Type processor (0) CPL, (1) DPSE-NPL: */ || (1)"0"b /* (26) 6025, 6605 or 6610 type processor: */ || (1)"0"b /* (27) 2K cache option installed: */ || (1)"0"b /* (28) Extended memory option installed: */ || (1)"0"b /* (29-30) cabinet (00) 8/70, (01) 8/52, (10) 862, (11) 846: */ || (2)"0"b /* (31) EIS option installed: */ || (1)"1"b /* (32) (1) slow memory access, (0) fast memory: */ || (1)"0"b /* (33) (1) no instruction overlap, (0) overlap: */ || (1)"0"b /* (34-35) Processor number: */ ||unspec (mc.cpu_type); goto return_to_gcos_code; end; goto illegal_proc; %page; /* MME3 fault. */ fault (02): if gcos_ext_stat_$save_data.debug then goto pass_it_on; /* user must say -db in order to use the debugger */ /* MME4 fault. */ fault (03): /* Illegal modifier. */ fault (06): /* Linkage error. */ fault (07): /* Fault tag 3. */ fault (08): /* Segment fault error. */ fault (09): /* Gate error. */ fault (11): /* Illegal opcode. */ fault (21): illegal_proc: ; abort_code = gcos_et_$illegal_procedure; /* abort type */ fault_vector = 0; /* vector offset */ goto user_fault; /* see if user has handler */ %page; /* attempt to read or write out of partition bounds */ /* Store fault. */ fault (12): /* Out_of_bounds fault. */ fault (20): abort_code = gcos_et_$mem_addr_flt; /* abort type */ fault_vector = 2; /* vector offset */ goto user_fault; /* see if user has handler */ %page; /* overflow */ fault (16): fault_flags = "020000"b3 ; /* turn on bit 22 of accum. fault status */ goto common_flow; %page; /* fixedoverflow */ fault (15): fault_flags = "040000"b3 ; /* turn on bit 21 of accum. fault status */ goto common_flow; %page; /* underflow */ fault (14): fault_flags = "010000"b3 ; /* turn on bit 23 of accum. fault status */ common_flow: abort_code = gcos_et_$over_or_under_flow; /* abort type */ fault_vector = 8; /* vector offset */ goto user_faultx; /* see if user has handler */ %page; /* zero divide */ fault (17): abort_code = gcos_et_$divide_check_flt; /* abort type */ fault_vector = 6; /* vector offset */ fault_flags = "000100"b3 ; /* turn on bit 29 of accum. fault status */ /* Come here with a fault which the gcos user can potentially handle. */ /* "fault_vector" holds the offset from the base of the gcos segment where */ /* the user's fault vector for the particular fault which occurred is located. */ /* If the user has no address specifed to which control should go on a fault */ /* of the type which occurred, "abort_code" holds the type of abort to */ /* be taken. */ /* Put the accumulated fault status into word 25 of prefix */ user_faultx: p = addrel (gcos_ext_stat_$gcos_slave_area_seg, 25); /* get pointer to it */ p -> accum_stat = p -> accum_stat | ((6)"0"b3 || fault_flags); /* or in the gcos_ext_stat_$save_data */ user_fault: prefix_vector (fault_vector) = ic_i; /* copy ic and indicators into fault vector */ if prefix_vector (fault_vector+1) = (36)"0"b then do; /* if user has no handler, abort the job */ abrt: unspec (gcos_ext_stat_$mc) = unspec (mc); /* save fault data for gcos_mme_bort_ */ abrt1: call condition_interpreter_ (null, p, i, 3, mcptr, (condition_name), wcptr, infoptr); call gcos_mme_bort_$system (abort_code); goto return_to_gcos_code; /* just in case */ end; /* Set scu data to cause processor to resume execution at the */ /* second word of the fault vector. This is done by setting the ilc to */ /* the address of that word and turning on "rfi" and "if "in the */ /* scu data, to force the cpu to refetch the instruction from the */ /* word pointed to by the ilc. */ /* Useg instruction in gcos code at 2nd word of fault entry. */ instruction_counter = fault_vector+1; scu.rfi = "1"b; /* Refetch this instruction. */ scu.if = "0"b; /* Turn off indicator indicating instruction caused fault. */ goto return_to_gcos_code; /* goto return_to_gcos_code to the gcos program */ %page; /* HANDLERS FOR FAULTS THAT THE USER'S FAULT VECTOR CAN NOT HANDLE */ /* parity */ fault (13): abort_code = gcos_et_$mem_parity_flt; fault_vector = 6; /* say where to put IC and I */ goto ic_and_i; /* and go do it */ %page; /* op_not_complete */ fault (19): abort_code = gcos_et_$op_not_complete_flt; /* abort */ fault_vector = 4; /* say where to put IC and I */ goto ic_and_i; /* and go do it */ %page; /* lockup */ fault (18): abort_code = gcos_et_$lockup_flt; /* abort */ fault_vector = 2; /* say where to put IC and I */ /* Come here to put IC and I in word 10 and one other word (specified by fault_vector) */ ic_and_i: prefix_vector (10) = ic_i; /* put it into word 10 */ prefix_vector (fault_vector) = ic_i; /* and also word 2, 4, or 6 */ goto abrt; /* and go abort the activity */ %page; timer_runout: entry (mcp_val, fault_name); /* Come here if fault is a timer runout */ dcl fault_name char(*)parm /* fault name from fim */; dcl mcp_val ptr parm; mcp = mcp_val; scup = addr (mc.scu); abort_code = gcos_et_$out_of_time; /* abort */ unspec (gcos_ext_stat_$mc) = unspec (mc); /* save fault data for gcos_mme_bort_ */ abrt2: call gcos_mme_bort_$system (abort_code); goto return_to_gcos_code; /* just in case */ %page; /* Variables for gcos_fault_processor_: */ /* IDENTIFIER ATTRIBUTES */ dcl abort_code fixed bin(35) /* abort code for this fault */; dcl accum_stat bit(36) aligned based /* overlay for accumulated */; dcl addr builtin; dcl addrel builtin; dcl answer char(4) varying; dcl baseno builtin; dcl code fixed bin(35); dcl command_query_ ext entry options (variable); dcl condition_interpreter_ ext entry (ptr, ptr, fixed bin(24), fixed bin(24), ptr, char(*), ptr, ptr); dcl continue_to_signal_ ext entry (fixed bin(35)); dcl divide builtin; dcl fault_flags bit(18) /* gcos_ext_stat_$save_data to set accumulated */; dcl fault_vector fixed bin(24)/* offset from base of gcos segment */; dcl find_condition_info_ ext entry (ptr, ptr, fixed bin(35)); dcl fixed builtin; dcl gcos_et_$derail_flt fixed bin(35) ext; dcl gcos_et_$divide_check_flt fixed bin(35) ext; dcl gcos_et_$fault_tag_flt fixed bin(35) ext; dcl gcos_et_$illegal_procedure fixed bin(35) ext; dcl gcos_et_$lockup_flt fixed bin(35) ext; dcl gcos_et_$mem_addr_flt fixed bin(35) ext; dcl gcos_et_$mem_parity_flt fixed bin(35) ext; dcl gcos_et_$non_gcos_fault fixed bin(35) ext; dcl gcos_et_$op_not_complete_flt fixed bin(35) ext; dcl gcos_et_$out_of_time fixed bin(35) ext; dcl gcos_et_$over_or_under_flow fixed bin(35) ext; dcl gcos_mme_bort_$system ext entry options (variable); dcl hbound builtin; dcl hv fixed bin(35); dcl i fixed bin(24); dcl ic_i bit(36) aligned; dcl instruction_counter fixed bin(18)unsigned unal based(addr(scu.ilc)); dcl length builtin; dcl mod builtin; dcl null builtin; dcl p pointer; dcl prefix_vector (0:13) bit(36) aligned based (gcos_ext_stat_$gcos_slave_area_seg); dcl string builtin; dcl substr builtin; dcl unspec builtin; dcl 1 INS aligned based ,2 ADDRESS unal , 3 fill bit(15)unal , 3 r3b fixed bin(3)unsigned unal ,2 OPCODE bit(10)unal ,2 I bit(1)unal ,2 T bit(1)unal ,2 TAG bit(6)unal ; /* Structure overlays varying string "condition name" to provide formation of hash value. */ dcl 1 cn aligned based(addr(condition_name)) ,2 f bit(27)unal ,2 l bit( 9)unal ,2 b (32)bit(9)unal ; dcl 1 faultv aligned based (addr (ic_i)) /* overlay for ic_i */, 2 ic fixed bin(18)unsigned unaligned /* instruction counter */, 2 ind bit(18) unaligned /* indicators */; %page; dcl 1 cond_info aligned, %include cond_info; %page; %include gcos_fault_names; %page; %include query_info; %page; %include gcos_ext_stat_; end gcos_fault_processor_;  gcos_fms_error_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 27396 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ******************************************************************************************* ******************************************************************************************* * * * Written by M. R. Jordan, October 1977 * ******************************************************************************************* ******************************************************************************************* */ gcos_fms_error_: procedure (fms_ecode, buf_ptr, fms_code); dcl addr builtin; dcl bit36 bit (36) aligned based; dcl buf_ptr ptr; dcl code fixed bin(35); dcl convert_status_code_ entry (fixed bin(35), char (8), char (100)); dcl cv_dec_check_ entry (char (*), fixed bin(35)) returns (fixed bin(35)); dcl fms_buf_ptr ptr; dcl fms_code bit (72) aligned; dcl fms_ecode fixed bin(35); dcl gcos_cv_ascii_gebcd_ entry (ptr, fixed bin(24), ptr, fixed bin(24)); dcl gcos_mme_bort_$system entry options (variable); dcl i fixed bin(24); dcl long_message char (100); dcl reason_code fixed bin(35); dcl rel builtin; dcl short_message char (8); dcl substr builtin; dcl 1 fms_buf aligned based (fms_buf_ptr), 2 pad1 (30) bit (36), 2 dcw, 3 data_loc bit (18) unal, 3 op bit (6) unal, 3 tally bit (12) unal, 2 pad2 (3) bit (36), 2 message bit (30*6) unal; /* Initialize needed data items. */ fms_buf_ptr = buf_ptr; fms_return_code_ptr = addr (fms_code); /* Get the messages associated with the specified fms_ecode value. If the message is not an FMS error message then abort. If it is then prepare to process the message. */ call convert_status_code_ (fms_ecode, short_message, long_message); if substr (short_message, 1, 3) ^= "FMS" then call gcos_mme_bort_$system (fms_ecode, "Bad FMS error code - contact support personnel"); else do; reason_code = cv_dec_check_ (substr (short_message, 4, 5), code); if code ^= 0 then reason_code = 2047; end; /* Now that we have verified the message, put all the data where the user can get to it from his GCOS slave job. */ fms_return_code.reason = substr (addr (reason_code) -> bit36, 26, 11); fms_buf.dcw.data_loc = rel (addr (fms_buf.message)); fms_buf.dcw.tally = "0005"b3; call gcos_cv_ascii_gebcd_ (addr (long_message), 30, addr (fms_buf.message), i); fms_return_code.err_mess_dcw.data_loc = fms_buf.dcw.data_loc; fms_return_code.err_mess_dcw.tally = fms_buf.dcw.tally; return; %include gcos_fms_return_code_; end gcos_fms_error_;  gcos_gein_.pl1 09/09/83 1400.3rew 09/09/83 1006.8 431649 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_gein_: proc; /* This module receives control from the gcos command procedure. It is the "main loop" of the simulator; it controls the running of the entire job. It calls gcos_gein_pass1_ which performs (optional) cannonicalization (on an ASCII segment), copies $ SELECTed files into the job stream, and looks for activity-defining cards in the job. The input file must contain a job deck. It may be either an ASCII segment, as created by one of the Multics editors, or a gcos standard system format file, as created by the gcos daemon from a deck or an IMCV tape. The appendage ".gcos" is one of two ways of identifying the latter type of job deck segment, the other being the -gcos (-gc) control argument. This procedure also initializes all the external static variables in gcos_ext_stat_ which need initialization and it opens a number of gcos files. Once initialization is complete, it reads card images from the job stream file and passes these on to the appropriate processing routines. When all the cards defining an activity have been processed, gcos_run_activity_ will be called to run the activity. Processing will then continue with the cards for subsequent activities. When a $ ENDJOB card is read, its processing routine, gcos_cc_endjob_ will clean up all open files, perform other end-of-job bookkeeping, and then transfer to the label "normal_termination" in this procedure, via a non local goto, thus cleaning up the stack. However, if execution of the simulator (not a gcos activity) is aborted because of some error, control will be passed to the label "fatalerror" in the command procedure, gcos, causing the stack frame for this procedure to be cleaned up, and its cleanup handler, gein_cleanup, to be invoked. */ %page; /* Author: DICK SNYDER AUGUST 4,1970 Change: T.CASEY APRIL 1973, OCTOBER 1973, DECEMBER 1973, FEBRUARY 1974, APRIL 1974, AUGUST 1974 Change: D. KAYDEN MAY 1974, JULY 1974, FEBRUARY 1975 Change: R.H. MORRISON MAY 1975 Change: M. WEAVER JUNE 1975 Change: M. R. Jordan, August 1977 Change: A. N. Kepner, March 1978 to allow courtesy call i/o within cc routines Change: Dave Ward, March 1978 to report $ SNUMB not first jcl card. Change: Mel Wilson, March, 1979 to remove snumb_then_ident check for gtss Change: Dave Ward 08/18/81 cleanup. octal constants. Change: Dave Ward 09/09/81 replaced use of alm vector gcos_cc_caller_ with goto cc. Change: Dave Ward 09/11/81 changed search_rules from allocated to auto. Change: Dave Ward 09/13/81 converted fibs & buffers from allocated space to arrays in a temp segment. Change: Dave Ward 09/17/81 removed fctptr. clock_ to clock. unspec init. Change: Scott C. Akers 12/21/81 Fix bugs wherein GEIN references the wrong directory (syot_dir and save_dir get confused with wdir and each other). Change: Ron Barstad 11/12/82 Add cleanup handler for attached IDS2 files Change: Ron Barstad 12/02/82 Fix bug; $SELECT not writing binary object records to R* Change: Ron Barstad 83-08-02 Add 4JS3 to version message and 4js3 cards. */ %page; /* INITIALIZE THE SIMULATOR - START BY CLEARING THE FILE INFORMATION BLOCKS, AND THEN OPENING THE FILES THAT ARE USED DURING THE WHOLE JOB */ start: ; unspec (save_data.fibs) = "0"b; fct.filecode = ""; /* clear the file code table */ fct.sysout = "0"b; fct.fibptr = null (); on condition (cleanup) call gein_cleanup; /* establish cleanup handler before opening any files */ /* Once per process initialization */ if ^initialized then do; initialized = "1"b; gcos_ext_stat_$gcos_slave_area_seg = null; /* init ptr to gcos seg once per process */ gcos_ext_stat_$max_mem = sys_info$max_seg_size; /* and max memory size */ end; gcos_ext_stat_$save_data.endjob = "1"b; /* Tell gcos_error_ to not call cc_endjob_ if we */ /* abort during init. Instead use gein_cleanup_. */ /* Use the search rules to search for the gcos libraries */ if gcos_ext_stat_$save_data.userlib then do; /* if user wants his own libraries */ /* move "referencing_dir" to end of search rules, to allow user's libraries to be found */ call hcs_$get_search_rules (addr (search_rules)); do i = 1 to search_rules.number while (search_rules.names (i) ^= "referencing_dir"); end; if i < search_rules.number then do; /* if "referencing_dir" was found */ /* and it was not last */ search_rules.names (i) = ""; /* delete it from its present position */ if search_rules.number = 21 then /* if rule structure full */ do j = i to 20; /* move the remaining rules up 1 */ search_rules.names (j) = search_rules.names (j+1); end; else search_rules.number = search_rules.number + 1; /* otherwise, save time */ search_rules.names (search_rules.number) = "referencing_dir"; /* put it last */ end; lib_count = 4; /* allow search for gcos_second_software_ */ end; else lib_count = 3; /* -userlib not given so do not search for second software */ do i = 1 to lib_count; if gcos_ext_stat_$save_data.userlib then call execute_search_rules_$s_r_ptr ( lib_names (i) , "1"b /* (input) return target type & bit count. */ ||"1"b /* (input) return target path. */ ||"1"b /* (input) return primary name on entry. */ || (5)"0"b /* (NOT USED). */ , addr (search_rules) , fullname , ename , type , bit_count , code ); else call execute_search_rules_ ( lib_names (i) , "1"b /* (input) return target type & bit count. */ ||"1"b /* (input) return target path. */ ||"1"b /* (input) return primary name on entry. */ || (5)"0"b /* (NOT USED). */ , fullname , ename , type , bit_count , code ); if code ^= 0 then do; if code = error_table_$noentry then do; if i = 4 then do; /* not error if second software not found */ gcos_ext_stat_$save_data.userlib = "0"b; /* reset so gcos_mme_call_ will not try to use it */ goto cont_init; end; else if i = 2 then do; gcos_ext_stat_$patchfile_ptr = null (); goto end_lib_loop; end; if type = 0 then /* if it was a link */ err_msg = "target of link to system library ^a in ^a"; else err_msg = "system library ^a"; end; else err_msg = "while searching for system library ^a in ^a"; lib_err: ; call com_err_ ( code , "gcos_gein_" , err_msg , lib_names (i) , fullname ); if code ^= error_table_$no_s_permission then do; fatal_error: ; call gein_cleanup; return; end; end; if bit_count = 0 then do; code = 0; err_msg = "zero bit count for system library ^a"; goto lib_err; end; /* make full pathname of library */ lib_path = rtrim (fullname) || ">" || ename; if i = 1 then do; /* save subroutine library pathname */ call gcos_open_file_ ("", "l*$", fibptr, sw); fib.pathnm = lib_path; fib.type = "1"b; /* random file */ fib.read = "1"b; /* read only */ fib.disp = "10"b; /* disposition = save */ fib.perm = "1"b; /* do not delete when detaching */ end; else if i = 2 then do; gcos_ext_stat_$patchfile_ptr = null (); call hcs_$initiate ( fullname , (ename) , "" , 0 , 0 , gcos_ext_stat_$patchfile_ptr , code ); end; else do; call ios_$attach ( lib_streams (i-2) , "file" , lib_path , "r" , status ); if code ^= 0 then do; lib_att_err: ; err_msg = "trying to attach system library ^a"; goto lib_err; end; call ios_$setsize (lib_streams (i-2), 36, status); if code ^= 0 then goto lib_att_err; end; end_lib_loop: ; end; cont_init: ; /* Obtain temporary segment for fibs and buffers. */ call get_temp_segment_ ( "gcos" , gcos_ext_stat_$temp_seg_ptr , code ); if code ^= 0 then do; call com_err_ ( /* Can not obtain temp segment. */ code , "gcos" , "^/Attempting to get temporary segment." ); goto fatal_error; end; /* INITIALIZE MISCELLANEOUS VARIABLES */ gcos_ext_stat_$snumb = "4546452520"b3 ; /* 4546452520 => "NONE" in bcd. */ save_data.actid = " NONE "; gcos_ext_stat_$normal_return = normal_termination; /* set up normal termination nonlocal goto */ gcos_ext_stat_$default_nondollar, gcos_ext_stat_$sought_label, gcos_ext_stat_$abort_reason = ""; unspec (gcos_ext_stat_$statistics) = "0"b; /* 3*mme number word array being zeroed */ /* Indicate that cc_queue is initially empty. */ courtesy_call.next_avail = 1; /* next available empty location */ courtesy_call.next_out = 1; /* next entry to remove from queue */ gcos_ext_stat_$job_real_time = clock (); /* save job start time */ call date_time_ ( gcos_ext_stat_$job_real_time , execution_msg.date_time ); /* put date and time in execution */ /* report header message */ call hcs_$get_usage_values (k, gcos_ext_stat_$job_cpu_time, k); /* get cpu time at start of job */ /* RESTART */ if ^gcos_ext_stat_$save_data.nosave then do; call hcs_$make_seg ( (gcos_ext_stat_$save_dir) , gcos_ext_stat_$job_id || ".save_data" , "" , 11 , gcos_ext_stat_$saveseg_ptr , code ); if gcos_ext_stat_$saveseg_ptr = null then call gcos_error_ ( code , "creating ^a>^a.save_data" , gcos_ext_stat_$save_dir , gcos_ext_stat_$job_id ); if restart_control.saved then do; /* job was interrupted */ call gcos_restart_ (i); /* do restart */ goto restart (i); /* (i) depends on restart options and saved data */ restart (1): ; /* job restart if activity restart failed */ call gein_cleanup; goto start; /* start over from scratch */ end; end; restart (4): ; /* job restart if act. restart not attempted */ save_data.psw = "0"b; /* clear pgm sw. word */ save_data.sqindex = 1; /* init sysout queue index */ save_data.activity_no = 0; /* use activity number of zero in job file pathnames */ /* "Open" the following files */ /* sysprint collector file */ /* syspunch collector file */ /* execution report */ /* geload r* collector file */ do i = 1 to 4; call gcos_open_file_ ("", "", fibptr, sw); /* get a fib */ fib.disp = "10"b; /* set disp = save for each file */ goto fib_init (i); /* goto init rtn */ continue: ; /* init rtns return here */ end; /* Write head of form with report code 74 and header message on execution report */ call gcos_write_$ptr (gcos_ext_stat_$er, FF, "11111100"b); /* write head-of-form */ call gcos_write_$ptr ( gcos_ext_stat_$er , string (execution_msg) , "11111100"b ); /* execution report header */ /* Get information from object or bound segment, and print it on execution report and console, to identify the version of the simulator being used */ gptr = addr (gcos$); /* get address of object or bound segment */ call hcs_$status_mins (gptr, type, bit_count, code); /* get its bit count */ if code ^= 0 then goto skip_version; /* don't abort job - just skip printing version. user might not have s access on the directory */ obj_info.version_number = object_info_version_2; call object_info_$display (gptr, bit_count, addr (obj_info), code); if code ^= 0 then goto skip_version; call date_time_ (obj_info.compile_time, vrsn_msg.date_time); /* format time into message */ call gcos_write_$ptr ( gcos_ext_stat_$er , string (vrsn_msg) , "11111100"b ); /* write it on execution report */ if ^gcos_ext_stat_$save_data.brief then /* and, if user did not say -brief, */ call ioa_$nnl ("GCOS 4JS3 ^a", string (vrsn_msg)); /* on console */ if gcos_ext_stat_$save_data.debug then do; /* for benefit of debugger of simulator, print pathname, author, and whether bound or not */ call hcs_$fs_get_path_name ( gptr , fullname , i , ename , code ); if code ^= 0 then goto skip_version; if obj_info.format.bound then seg_type = "bound"; else seg_type = "compiled"; call ioa_$rs ( "^a>^a ^a by ^a^/" , err_msg , j , fullname , ename , seg_type , obj_info.userid ); if gcos_ext_stat_$save_data.long then /* if user said -long, */ call ioa_$nnl ("^a", err_msg); /* print it on the terminal */ call gcos_write_$ascii_ptr ( gcos_ext_stat_$er , var_msg , "11111100"b ); /* and always on ex rpt, in ASCII */ end; skip_version: ; /* come here on any error getting version information */ gcos_ext_stat_$save_data.endjob = "0"b; /* Initialization complete, reset flag */ pass1: ; call gcos_gein_pass1_; /* go put job stream in shape to run job */ if save_data.last_execute_act_no > 0 then /* if job contains any EXECUTE cards */ save_data.psw = "01"b3 ; /* turn on psw bit 5 */ if ^gcos_ext_stat_$save_data.nosave then do; /* save restart data */ call gcos_write_$force_ptr (gcos_ext_stat_$er); call gcos_restart_$save; end; /* Write header record on sysout print collector file. This record identifies the file as sysout (to be sorted) rather than print (not to be sorted). It also reserves space for the snumb and the offset within the file where the execution report begins, to be put in later */ restart (2): ; call gcos_write_$record_ptr ( gcos_ext_stat_$prt , firstrecord , (8)"0"b ); /* come here for activity restart of first act. */ restart (3): ; /* come here for activity restart */ %page; /* Initialization is now complete. Here begins the main processing loop of GEIN. Cards or line images are read here from the job stream file and then looked up in a table to obtain a pointer to the appropriate processing routine. Some cards are processed in-line, however. */ /* Come here after each card is processed, to read the next card */ loop: ; call gcos_read_card_ (gcos_ptr, gcos_len, card, dollar_sw); /* get card image */ gcos_ext_stat_$gf = 0; /* init sw for gcos_get_cc_field_ rtn */ if ^dollar_sw then goto nondollar; /* if not a dollar card */ /* WE HAVE A $ CONTROL CARD; CHECK FOR VARIOUS SPECIAL CASES BEFORE LOOKING IT UP IN THE TABLE */ dollar_card_count = dollar_card_count+1; card_type = translate (substr (card, 8, 6), LOWER_CASE, UPPER_CASE); /* pick out card type, for faster access */ if gcos_ext_stat_$save_data.copy then do; /* copy $ control cards */ if card_type ^= "endcop" then goto nondollar; /* go write on file */ if gcos_ext_stat_$save_data.endfc then if gcos_ext_stat_$endfc ^= translate (substr (card, 16, 2), LOWER_CASE, UPPER_CASE) then goto nondollar; gcos_ext_stat_$save_data.copy , gcos_ext_stat_$save_data.nondollar , gcos_ext_stat_$save_data.endfc = "0"b; /* turn off sw if endcopy card */ gcos_ext_stat_$nondollar = ""; /* no nondollar file is defined now */ goto loop; /* get another card */ end; if ^gcos_ext_stat_$save_data.brief then /* unless told not to */ if nondollar_cards_skipped > 0 then do; /* warn user of out-of-place nondollar cards that preceeded this one */ call ioa_ ( "^d nondollar cards skipped before:^/^a" , nondollar_cards_skipped , card ); nondollar_cards_skipped = 0; /* reset the count */ end; else if cc_print_sw then call ioa_ ("^a", card); /* print card if requested, for debugging */ if substr (card, 1, 7) ^= "$" then /* possible label card */ goto label_card; /* go see if we are looking for one */ if card_type ^= "etc " then gcos_ext_stat_$save_data.write_etc = "0"b; /* the only way to make sure this switch is not left on too long is to turn it off every time a non-ETC card is read */ if card_type ^= "incode" then if gcos_ext_stat_$save_data.nondollar then do; /* if we were reading nondollar cards */ gcos_ext_stat_$save_data.nondollar = "0"b; /* we aren't any more */ gcos_ext_stat_$nondollar = ""; /* and no nondollar file is defined now */ gcos_ext_stat_$incode = 0; /* turn off any incode processing */ end; /* Look up card in table */ do i = 1 to gcos_control_tables_$tablelen; if card_type = gcos_control_tables_$cardtable (i) then goto found; /* look for card type */ end; /* An unknown card is not an error, in real GCOS */ unknown_card: ; if gcos_ext_stat_$save_data.long then /* if told to do so, warn user of bad $ card */ call ioa_ ( "gcos simulator will ignore the following unknown dollar card:^/^a" , card ); goto loop; found: ; /* come here when card is found in cardtable; "i" is its position in the table, and is used from here on */ /* BEFORE CALLING THE PROCESSOR FOR THIS CARD, CHECK VARIOUS SPECIAL CASES */ if dollar_card_count = 1 then if card_type ^= "snumb" then goto no_snumb; /* FIRST, ARE WE SKIPPING THROUGH THE DECK, LOOKING FOR SOMETHING? */ if gcos_ext_stat_$save_data.seeking then do; /* if we are seeking a label or terminator */ /* "seeking" do group */ if gcos_ext_stat_$sought_label ^= "" then do; /* if we are seeking a label */ /* we already know we do not have one */ /* "seeking label" do group (for GOTO, IF, or WHEN card) */ if i >= gcos_control_tables_$exc_offset then if i < gcos_control_tables_$nonact then do; /* if this is an activity card, */ /* we will delete the activity */ delete_activity: ; /* come here from below to delete activities */ /* of aborts or compilation errors in previous */ /* activities */ gcos_ext_stat_$save_data.this_act_abort = "0"b; /* make sure this switch does not stay on past the end of the aborting activity */ /* Bump the activity number */ save_data.activity_no = save_data.activity_no + 1; /* Write activity deletion messages on console and execution report */ /* format the message */ call ioa_$rs ( "* ^a ACTIVITY -^2d- DELETED" , err_msg , j , card_type , save_data.activity_no ); /* write it on the console, for the benefit of the interactive user */ if gcos_ext_stat_$save_data.long then /* provided he said -long */ call ioa_$nnl ("^a", var_msg); /* and on the execution report */ call gcos_write_$ptr ( gcos_ext_stat_$er , var_msg , "11111100"b ); goto loop; /* go read next card */ end; if i = gcos_control_tables_$tablelen then /* if ENDJOB card, */ goto call_caller; /* then terminate job normally */ goto loop; /* if not from $ WHEN card, or if current card is not a terminator, then keep looking for the label */ end; /* end of "seeking label" do group */ /* So we are just seeking a terminator. We could be skipping an abort subactivity, or skipping a deleted execution activity. In either case, a $ ABORT card is not an acceptable terminator for the search */ if i < gcos_control_tables_$exc_offset then goto loop; /* not a terminator. keep looking for one */ /* it is a terminator - it might be a $ ABORT card, though */ if i = gcos_control_tables_$nonact then goto loop; /* if so keep looking */ /* We found a terminator. Turn off the switches that make us look for one */ gcos_ext_stat_$save_data.seeking, gcos_ext_stat_$save_data.seeking_terminator = "0"b; /* And fall thru to process the terminator */ end; /* end of "seeking" do group */ /* SECOND, WE WILL ENFORCE RESTRICTIONS ON POSITION OF SNUMB AND IDENT CARDS */ if gcos_ext_stat_$save_data.flgs.ident then goto activtst; /* snumb and ident already found ? */ if card_type = "snumb " then goto activtst; /* snumb? */ if ^gcos_ext_stat_$save_data.snumb then goto loop; /* no..if none read yet continue */ /* THIRD, ACTIVITY TERMINATING CARDS NEED SOME SPECIAL HANDLING */ activtst: ; if i >= gcos_control_tables_$exc_offset then do; /* if this card is an activity terminator */ if gcos_ext_stat_$save_data.activ then do; /* and an activity was being defined, run it now */ if ^gcos_ext_stat_$save_data.flgs.ident then goto jobort; /* require $ident before first activity execution */ if ^gcos_ext_stat_$save_data.nosave then restart_control.na_restart = restart_control.na_hold; /* copy activity restart option */ call gcos_run_activity_; if ^gcos_ext_stat_$save_data.nosave then do; /* if user requested save */ call gcos_write_$force_ptr (gcos_ext_stat_$er); call gcos_write_$force_ptr (gcos_ext_stat_$rs); call gcos_write_$force_ptr (gcos_ext_stat_$pch); call gcos_restart_$save; /* save state of simulator at activity end */ end; /* so that we could restart from the beginning of the next activity if we had to */ end; /* Control also comes here to continue after running an activity, or after skipping a deleted activity. */ /* Here, check for two types of activity deletion, before beginning to define the next activity: 1) run only compilations after an abort (and before a $ BREAK) 2) if a compiler turns off psw bit 5, delete all execution activities, until somebody turns it back on. Execution activities are $ EXECUTE and $ 355SIM */ if i >= gcos_control_tables_$comp_offset then goto dont_delete; /* never delete a compilation activity */ if gcos_ext_stat_$save_data.prev_act_abort then goto do_delete; /* after an abort, delete all non-compilation activities */ if i > gcos_control_tables_$exc_offset + 1 then /* if not EXECUTE or 355SIM */ goto dont_delete; /* run regardless of PSW bit 5 */ if substr (save_data.psw, 6, 1) then /* if PSW bit 5 is on */ goto dont_delete; /* then run EXECUTE OR 355SIM */ do_delete: ; gcos_ext_stat_$save_data.seeking , gcos_ext_stat_$save_data.seeking_terminator = "1"b; /* set save_data to look for next terminator card */ goto delete_activity; /* go print message and increment activity number */ dont_delete: ; end; if (gcos_ext_stat_$activity_name = "geload") /* if we are defining an EXECUTE activity */ & (i <= gcos_control_tables_$filecard_count) then do; /* and this is a file card */ call gcos_write_$record ("r*", gcos_record, (8)"0"b); /* write it on R* */ gcos_ext_stat_$save_data.write_etc = "1"b; /* and remember to write its continuation */ gcos_ext_stat_$etc_filecode = "r*"; /* (if any) on R* too */ end; /* FINALLY, CALL THE PROCESSOR FOR THIS CARD */ call_caller: ; goto cc (i); cc (001): ; call gcos_cc_file_cards_$cc_print (card); /* print card */ goto loop; cc (002): ; call gcos_cc_file_cards_$cc_punch (card); /* punch card */ goto loop; cc (004): ; /* disc card */ cc (005): ; /* drum card */ cc (006): ; /* file card */ cc (007): ; /* mass card */ cc (003): ; call gcos_cc_file_cards_$cc_file (card); /* disk card */ goto loop; cc (008): ; call gcos_cc_file_cards_$cc_prmfl (card); /* prmfl card */ goto loop; cc (009): ; call gcos_cc_data_ (card); /* data card */ goto loop; cc (010): ; call gcos_cc_file_cards_$cc_tape (card); /* tape card */ goto loop; cc (011): ; call gcos_cc_file_cards_$cc_tape7 (card); /* tape7 card */ goto loop; cc (012): ; call gcos_cc_file_cards_$cc_tape9 (card); /* tape9 card */ goto loop; cc (013): ; /* sysout card */ cc (014): ; call gcos_cc_file_cards_$cc_sysout (card); /* remote card */ goto loop; cc (015): ; call gcos_cc_file_cards_$cc_dac (card); /* dac card */ goto loop; cc (016): ; call gcos_cc_file_cards_$cc_type (card); /* type card */ goto loop; cc (017): ; call gcos_cc_file_cards_$cc_read (card); /* read card */ goto loop; cc (018): ; call gcos_cc_snumb_ (card); /* snumb card */ goto loop; cc (019): ; call gcos_cc_misc_cards_$cc_comment (card); /* comment card */ goto loop; cc (020): ; call gcos_cc_incode_ (card); /* incode card */ goto loop; cc (021): ; call gcos_cc_misc_cards_$cc_etc (card, i, gcos_record); /* etc card */ goto loop; cc (022): ; call gcos_cc_misc_cards_$cc_endcopy (card); /* endcopy card */ goto loop; cc (023): ; call gcos_cc_update_ (card, i, gcos_record); /* update card */ goto loop; cc (024): ; call gcos_cc_limits_ (card); /* limits card */ goto loop; cc (025): ; call gcos_cc_misc_cards_$cc_msg1 (card); /* msg1 card */ goto loop; cc (026): ; call gcos_cc_misc_cards_$cc_msg2 (card); /* msg2 card */ goto loop; cc (027): ; call gcos_cc_misc_cards_$cc_msg3 (card); /* msg3 card */ goto loop; cc (028): ; call gcos_cc_misc_cards_$cc_userid (card); /* userid card */ goto loop; cc (029): ; call gcos_cc_misc_cards_$cc_alter (card); /* alter card */ goto loop; cc (030): ; call gcos_cc_set_ (card); /* set card */ goto loop; cc (032): ; /* copy card */ cc (033): ; /* delete card */ cc (034): ; /* endedit card */ cc (039): ; /* include card */ cc (042): ; /* list card */ cc (043): ; /* modify card */ cc (045): ; /* patch card */ cc (047): ; /* seq card */ cc (048): ; /* setsq card */ cc (053): ; /* assem card */ cc (055): ; /* get card */ cc (056): ; /* getrwd card */ cc (058): ; /* setsq1 card */ cc (031): ; call gcos_cc_directive_cards_$cc_editor (card, i, gcos_record); /* compile card */ goto loop; cc (036): ; call gcos_cc_directive_cards_$cc_ffile (card, i, gcos_record); /* ffile card */ goto loop; cc (040): ; /* input card */ cc (041): ; /* output card */ cc (044): ; /* multi card */ cc (037): ; call gcos_cc_directive_cards_$cc_bmc (card, i, gcos_record); /* form card */ goto loop; cc (038): ; /* futil card */ cc (046): ; call gcos_cc_directive_cards_$cc_utility (card, i, gcos_record); /* qutil card */ goto loop; cc (035): ; /* endld card */ cc (049): ; call gcos_cc_directive_cards_$cc_sysedit (card, i, gcos_record); /* sysld card */ goto loop; cc (050): ; call gcos_cc_goto_$cc_when (card); /* when card */ goto loop; cc (051): ; call gcos_cc_abort_ (card); /* abort card */ goto loop; cc (052): ; call gcos_cc_directive_cards_$cc_dump (card, i, gcos_record); /* dump card */ goto loop; cc (054): ; call gcos_cc_directive_cards_$cc_sced (card, i, gcos_record); /* change card */ goto loop; cc (057): ; call gcos_cc_misc_cards_$cc_need (card); /* need card */ goto loop; cc (059): ; call gcos_cc_param_ (card); /* param card */ goto loop; cc (061): ; /* library card */ cc (062): ; /* lowload card */ cc (063): ; /* use card */ cc (064): ; /* entry card */ cc (065): ; /* nolib card */ cc (066): ; /* equate card */ cc (067): ; /* link card */ cc (068): ; /* relcom card */ cc (069): ; /* source card */ cc (070): ; /* dkend card */ cc (071): ; /* nload card */ cc (060): ; call gcos_cc_loader_cards_ (card, i, gcos_record); /* option card */ goto loop; cc (104): ; call gcos_cc_loader_cards_$cc_object (card, i, gcos_record); /* object card */ goto loop; cc (073): ; /* 355sim card */ cc (074): ; /* program card */ cc (075): ; /* conver card */ cc (076): ; /* filedit card */ cc (077): ; /* sysedit card */ cc (078): ; /* utility card */ cc (079): ; /* utl2 card */ cc (080): ; /* convrt card */ cc (081): ; /* fortran card */ cc (082): ; /* pl1 card */ cc (083): ; /* cobol card */ cc (084): ; /* gmap card */ cc (085): ; /* 355map card */ cc (086): ; /* algol card */ cc (087): ; /* forta card */ cc (088): ; /* forty card */ cc (089): ; /* jovial card */ cc (090): ; /* asm66 card */ cc (091): ; /* cbl74 card */ cc (092): ; /* cbl68 card */ cc (093): ; /* malt card */ cc (094): ; /* ilang card */ cc (095): ; /* ids card */ cc (096): ; /* ids2 card */ cc (097): ; /* 4tran card */ cc (098): ; /* g3edit card */ cc (099): ; /* fort77 card */ cc (100): ; /* fortx card */ cc (101): ; /* cids2 card */ cc (102): ; /* rpg2 card */ cc (072): ; call gcos_cc_activity_cards_ (card, i, gcos_record); /* execute card */ goto loop; cc (103): ; call gcos_cc_ident_ (card); /* ident card */ goto loop; cc (105): ; call gcos_cc_misc_cards_$cc_break (card); /* break card */ goto loop; cc (106): ; call gcos_cc_goto_ (card); /* goto card */ goto loop; cc (107): ; call gcos_cc_goto_$cc_if (card); /* if card */ goto loop; cc (108): ; call gcos_cc_endjob_ (card); /* endjob card */ goto loop; /* continue processing */ /* Come here to abort job if snumb-ident sequence is not right */ no_snumb: ; call gcos_error_ ( gcos_et_$cc_bad_card , "$ SNUMB must be first control card.^/^a^2x^a" , gcos_ext_stat_$card_num , card ); jobort: ; call gcos_error_ ( gcos_et_$cc_bad_card , "$ IDENT must follow $ SNUMB imediately.^/^a^2x^a" , gcos_ext_stat_$card_num , card ); /* Come here when a nondollar card is read */ nondollar: ; if gcos_ext_stat_$save_data.seeking then goto loop; /* if we are seeking a label or terminator, we skip over all nondollar cards */ gcos_ext_stat_$save_data.write_etc = "0"b; /* the only way to be sure this switch does not get left on too long is to turn it off every time we read a non-etc card */ if gcos_ext_stat_$save_data.nondollar then goto nondl_write; /* skip if already processing nondollar cards */ /* Enforce restriction on position of snumb and ident cards */ if ^gcos_ext_stat_$save_data.snumb then goto loop; /* skip cards before snumb */ if ^gcos_ext_stat_$save_data.flgs.ident then goto jobort; /* abort if cards between snumb and ident */ /* Write the nondollar card on a file (maybe) */ /* we are starting a new nondollar file */ gcos_ext_stat_$nondollar = /* whose filecode will be */ gcos_ext_stat_$default_nondollar; /* the default nondollar filecode */ /* which could be blank if we have already "used it up" */ gcos_ext_stat_$default_nondollar = ""; /* we have used it up now, if not before */ if gcos_ext_stat_$nondollar = "" then do; /* if we had used it up previously */ nondollar_cards_skipped = nondollar_cards_skipped + 1; /* skip over the cards */ goto loop; end; /* otherwise fall thru and write it on the file */ gcos_ext_stat_$save_data.nondollar = "1"b; /* set flag to say processing a data deck */ nondl_write: ; if gcos_ext_stat_$nondollar ^= "" then /* check for writing to geload r* file */ call gcos_write_$record ( gcos_ext_stat_$nondollar , gcos_record , (8)"0"b ); else call gcos_write_$record_ptr ( gcos_ext_stat_$rs , gcos_record , "0"b ); /* write to r* collector file */ goto loop; /* continue */ /* Come here to process possible label cards */ label_card: ; /* columns 2-7 were not completely blank */ /* get label */ do j = 3 to 7 while (substr (card, j, 1) = " "); /* find beginning of label */ end; /* j now points to its first character */ k = index (substr (card, j), " ") - 2; /* get length of label */ if k < 1 then goto unknown_card; /* bad label */ if k > 6 then goto unknown_card; /* bad label */ if substr (card, j+k, 1) ^= ":" then /* if it does not end in colon */ if substr (card, j+k, 1) ^= "." then /* or period */ goto unknown_card; /* bad label */ /* good label */ if ^gcos_ext_stat_$save_data.seeking then goto loop; /* skip it if not looking for anything */ if gcos_ext_stat_$sought_label = "" then goto loop; /* or if not seeking a label */ if substr (card, j, k) ^= /* if the label */ gcos_ext_stat_$sought_label then /* is not the one we sought */ goto loop; /* then keep looking for it */ /* we found it */ gcos_ext_stat_$sought_label = ""; /* so stop looking */ gcos_ext_stat_$save_data.seeking, gcos_ext_stat_$save_data.seeking_terminator = "0"b; goto loop; /* and go get next card to process */ /* Control comes here from gcos_cc_endjob_ via a nonlocal goto, if that procedure was able to complete the termination of the job. */ normal_termination: ; call release_temp; return; %page; /* File information block initialization routines */ /* Fib initialization for syspunch */ fib_init (1): ; gcos_ext_stat_$pch = fibptr; /* save sysout punch collector fib pointer */ fib.stream = "syspunch"; /* file id is "syspunch" */ fib.punch = "1"b; /* punch file */ goto continue; /* return to processing loop */ /* Fib initialization for sysprint */ fib_init (2): ; gcos_ext_stat_$prt = fibptr; /* save sysout print collector fib pointer */ fib.stream = "sysprint"; /* file id is "sysprint" */ fib.print = "1"b; /* print file */ goto continue; /* return to processing loop */ /* Fib initialization for execution report file */ fib_init (3): ; gcos_ext_stat_$er = fibptr; /* save execution report fib pointer */ fib.stream = "exec_rpt"; /* file id is "exec_rpt" */ fib.print = "1"b; /* print file */ goto continue; /* return to processing loop */ /* Fib initialization for geload r* collector file */ fib_init (4): ; gcos_ext_stat_$rs = fibptr; /* save fib pointer */ fib.stream = "rstar"; /* file id is "rstar" */ goto continue; /* return to processing loop */ %page; dollar_print: entry; /* Enter here to set switch to cause control cards to be printed */ cc_print_sw = ^cc_print_sw; /* flip switch */ if cc_print_sw then msg_var = "on"; else msg_var = "off"; call ioa_ ("control card printing turned ^a", msg_var); return; %page; gein_cleanup: proc; /* CLEANUP HANDLER FOR ENTIRE SIMULATOR EXCEPT PASS1 */ do i = 1 to hbound (save_data.fibs, 1); /* go thru all fibs */ fibptr = addr (save_data.fibs (i)); if ^fib.used then goto get_next_fib; /* if unused, skip to next one */ if ^fib.attached then goto get_next_fib; /* file not attached, skip to next */ if fib.console then goto get_next_fib; /* a console device is never really attached */ if fib.null then goto get_next_fib; /* neither is a null file */ call ios_$detach (fib.stream, "", "", status); /* ignore errors */ /* NOTE THAT ALL THE SPECIAL CASE CHECKS FOLLOWING MUST BE REVIEWED, AFTER ANY MAJOR CHANGE TO THE SIMULATOR, TO MAKE CERTAIN THEY ARE STILL VALID. */ if fib.print then goto keep_it; /* don't delete print files */ if fib.punch then goto keep_it; /* ... or punch files */ if fib.tape then goto keep_it; /* nothing to delete here */ call expand_pathname_ ( fib.pathnm , fullname , ename , code ); if code ^= 0 then goto keep_it; /* ignore errors, but don't get into trouble doing it */ if fib.perm then goto keep_it; /* don't delete perm files */ call delete_$path ( fullname , ename , "07"b3 /* noforce,noquestion,nodirs,segs,links,chase */ , "gcos" , code ); /* ignore errors */ keep_it: ; /* Clean up any possible IDS2 locked files */ if fib.perm & fib.type /* rand */ then if gcos_ids2_concur_$have_xid(fullname,ename,code) then call gcos_ids2_concur_$deallocate( fullname,ename,fib.read, fib.write,code); /* Make buffer available. */ if fib.buffer_indx > 0 then do; fib_buffers.buffer_in_use (fib.buffer_indx) = "0"b; fib.buffer_indx = 0; fib.buffer = null (); end; get_next_fib: ; end; /* fall thru when all fibs examined */ call ios_$detach ((lib_streams (1)), "", "", status); /* detach the system libraries */ call ios_$detach ((lib_streams (2)), "", "", status); call ios_$detach ("gcos_job_stream_", "", "", status); /* it could be attached if: 1) we were still in pass1, or 2) it was a msf */ call delete_$path ( string (gcos_ext_stat_$save_dir) , gcos_ext_stat_$job_id || ".job_deck" , "07"b3 , "gcos" , code ); call delete_$path ( string (gcos_ext_stat_$save_dir) , gcos_ext_stat_$job_id || ".save_data" , "07"b3 , "gcos" , code ); if gcos_ext_stat_$gcos_slave_area_seg ^= null then call hcs_$truncate_seg ( gcos_ext_stat_$gcos_slave_area_seg , 0 , code ); if gcos_ext_stat_$temp_seg_ptr ^= null () then do; call release_temp; end; return; end gein_cleanup; %page; release_temp: proc; call release_temp_segment_ ( "gcos" , gcos_ext_stat_$temp_seg_ptr , code ); if code ^= 0 then call com_err_ ( /* Could not release temp segment. */ code , "gcos" , "^/Releasing temp segment (^p)" , gcos_ext_stat_$temp_seg_ptr ); return; end release_temp; %page; /* Variables for gcos_gein_: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl addrel builtin; dcl baseno builtin; dcl bit_count fixed bin(24) /* length of input segment in bits */; dcl card char(80) /* card image returned by gcos_read_card_ */; dcl card_type char(8) aligned /* card type extracted from dollar card image */; dcl cc_print_sw bit(1) int static init ("0"b); dcl char builtin; dcl cleanup condition; dcl clock builtin; dcl code fixed bin(35) based (addr (status)) /* return param. for passing error codes */; dcl com_err_ entry() options(variable); dcl date_time_ ext entry (fixed bin(71), char(*)); dcl delete_$path entry (char(*), char(*), bit(6), char(*), fixed bin(35)); dcl dollar_card_count fixed bin(24)init (0) /* Count of "$" cards. */; dcl dollar_sw bit(1) ; dcl ename char(32) /* holds entry name of input seg */; dcl error_table_$noentry ext fixed bin(35); dcl error_table_$no_s_permission ext fixed bin(35); dcl err_msg char(150) /* for com_err calls */; dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); dcl firstrecord char(60) based (addr (first_record)) /* overlay for 15-word first_record structure */; dcl fullname char(168) /* holds pathname of input seg */; dcl gcos$ ext; dcl gcos_cc_abort_ entry options(variable); dcl gcos_cc_activity_cards_ entry (char(80), fixed bin(24), char(*)); dcl gcos_cc_data_ entry (char(80)); dcl gcos_cc_directive_cards_$cc_bmc entry (char(80), fixed bin(24), char(*)); dcl gcos_cc_directive_cards_$cc_dump entry (char(80), fixed bin(24), char(*)); dcl gcos_cc_directive_cards_$cc_editor entry (char(80), fixed bin(24), char(*)); dcl gcos_cc_directive_cards_$cc_ffile entry (char(80), fixed bin(24), char(*)); dcl gcos_cc_directive_cards_$cc_sced entry (char(80), fixed bin(24), char(*)); dcl gcos_cc_directive_cards_$cc_sysedit entry (char(80), fixed bin(24), char(*)); dcl gcos_cc_directive_cards_$cc_utility entry (char(80), fixed bin(24), char(*)); dcl gcos_cc_endjob_ entry (char(80)); dcl gcos_cc_file_cards_$cc_dac entry (char(80)); dcl gcos_cc_file_cards_$cc_file entry (char(80)); dcl gcos_cc_file_cards_$cc_print entry (char(80)); dcl gcos_cc_file_cards_$cc_prmfl entry (char(80)); dcl gcos_cc_file_cards_$cc_punch entry (char(80)); dcl gcos_cc_file_cards_$cc_read entry (char(80)); dcl gcos_cc_file_cards_$cc_sysout entry (char(80)); dcl gcos_cc_file_cards_$cc_tape entry (char(80)); dcl gcos_cc_file_cards_$cc_tape7 entry (char(80)); dcl gcos_cc_file_cards_$cc_tape9 entry (char(80)); dcl gcos_cc_file_cards_$cc_type entry (char(80)); dcl gcos_cc_goto_ entry (char(80)); dcl gcos_cc_goto_$cc_if entry (char(80)); dcl gcos_cc_goto_$cc_when entry (char(80)); dcl gcos_cc_ident_ entry (char(80)); dcl gcos_cc_incode_ entry (char(80)); dcl gcos_cc_limits_ entry (char(80)); dcl gcos_cc_loader_cards_ entry (char(80), fixed bin(24), char(*)); dcl gcos_cc_loader_cards_$cc_object entry (char(80), fixed bin(24), char(*)); dcl gcos_cc_misc_cards_$cc_alter entry (char(80)); dcl gcos_cc_misc_cards_$cc_break entry options(variable); dcl gcos_cc_misc_cards_$cc_comment entry (char(80)); dcl gcos_cc_misc_cards_$cc_endcopy entry (char(80)); dcl gcos_cc_misc_cards_$cc_etc entry (char(80), fixed bin(24), char(*)); dcl gcos_cc_misc_cards_$cc_msg1 entry options(variable); dcl gcos_cc_misc_cards_$cc_msg2 entry (char(80)); dcl gcos_cc_misc_cards_$cc_msg3 entry options(variable); dcl gcos_cc_misc_cards_$cc_need entry (char(80)); dcl gcos_cc_misc_cards_$cc_userid entry (char(80)); dcl gcos_cc_param_ entry (char(80)); dcl gcos_cc_set_ entry (char(80)); dcl gcos_cc_snumb_ entry (char(80)); dcl gcos_cc_update_ entry (char(80), fixed bin(24), char(*)); dcl gcos_error_ ext entry options (variable); dcl gcos_et_$cc_bad_card fixed bin(35) ext; dcl gcos_gein_pass1_ ext entry; dcl gcos_ids2_concur_$deallocate ext entry (char(*), char(*), bit(1), bit(1), fixed bin(35)); dcl gcos_ids2_concur_$have_xid ext entry (char(*), char(*), fixed bin(35)) returns (bit(1)); dcl gcos_len fixed bin(24); dcl gcos_open_file_ ext entry (char(*), char(*), pointer, bit(1)); dcl gcos_ptr ptr; dcl gcos_read_card_ entry (ptr, fixed bin(24), char(80), bit(1)); dcl gcos_record char(gcos_len) based (gcos_ptr); dcl gcos_restart_ entry (fixed bin(24)); dcl gcos_restart_$save ext entry; dcl gcos_run_activity_ ext entry; dcl gcos_write_$ascii_ptr ext entry (ptr, char(*), bit(8)); dcl gcos_write_$force_ptr ext entry (ptr); dcl gcos_write_$ptr ext entry (ptr, char(*), bit(8)); dcl gcos_write_$record ext entry (char(*), char(*), bit(8)); dcl gcos_write_$record_ptr ext entry (ptr, char(*), bit(8)); dcl get_temp_segment_ entry (char(*), ptr, fixed bin(35)); dcl gptr ptr /* pointer to gcos bound segment, for object_info_ */; dcl hbound builtin; dcl hcs_$fs_get_path_name entry (ptr, char(*), fixed bin(24), char(*), fixed bin(35)); dcl hcs_$get_search_rules ext entry (ptr); dcl hcs_$get_usage_values ext entry (fixed bin(24), fixed bin(71), fixed bin(24)); dcl hcs_$initiate entry (char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr, fixed bin(35)); dcl hcs_$make_seg ext entry (char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35)); dcl hcs_$status_mins ext entry (ptr, fixed bin(2), fixed bin(24), fixed bin(35)); dcl hcs_$truncate_seg ext entry (ptr, fixed bin(24), fixed bin(35)); dcl i fixed bin(24); dcl index builtin; dcl initialized bit(1) internal static init ("0"b); dcl ioa_ entry() options(variable); dcl ioa_$nnl entry() options(variable); dcl ioa_$rs entry() options(variable); dcl ios_$attach ext entry (char(*) aligned, char(*), char(*) aligned, char(*), bit(72) aligned); dcl ios_$detach ext entry (char(*), char(*) aligned, char(*), bit(72) aligned); dcl ios_$setsize ext entry (char(*) aligned, fixed bin(24), bit(72) aligned); dcl j fixed bin(24); dcl k fixed bin(24)/* temp */; dcl lib_count fixed bin(24)/* number of libraries in use (2 or 3) */; dcl lib_path char(168) aligned /* temporary for library pathnames */; dcl lib_streams (2)char(4)aligned int static options(constant)init("glib", "slib") /* software library streams */; dcl LOWER_CASE char(26) static internal options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl msg_var char(4); dcl nondollar_cards_skipped fixed bin(24)init (0) /* to count skipped nondollar cards, for debugging */; dcl null builtin; dcl object_info_$display ext entry (ptr, fixed bin(24), ptr, fixed bin(35)); dcl release_temp_segment_ entry (char(*), ptr, fixed bin(35)); dcl rtrim builtin; dcl seg_type char(8) aligned /* segment type (bound or compiled) */; dcl size builtin; dcl status bit(72) aligned; dcl string builtin; dcl substr builtin; dcl sw bit(1) /* sw set by open. Not used here */; dcl sys_info$max_seg_size ext fixed bin(24)/* 64K or 256K ? */; dcl translate builtin; dcl type fixed bin(2); dcl UPPER_CASE char(26) static internal options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl user_info_$homedir entry (char(*)); dcl var_msg char(j) based (addr (err_msg)) /* variable length overlay for above */; dcl word bit(36) aligned based /* to put bits into a word */; dcl execute_search_rules_ entry ( char(32) , bit(8) aligned , char(168) , char(32) , fixed bin(2) , fixed bin(24) , fixed bin(35) ); dcl execute_search_rules_$s_r_ptr entry ( char(32) , bit(8) aligned , ptr , char(168) , char(32) , fixed bin(2) , fixed bin(24) , fixed bin(35) ); dcl lib_names (4)char(32)int static options(constant) init ( /* names of libraries */ "gcos_library_subroutines_", /* geload l* file */ "gcos_system_patchfile_", /* patch file */ "gcos_system_software_", /* glib file */ "gcos_second_software_"); /* slib file */ dcl 1 execution_msg int static aligned, /* execution report header msg */ 2 part1 char(54) unaligned initial ("EXECUTION REPORT, MULTICS GCOS ENVIRONMENT SIMULATOR "), 2 date_time char(24) unaligned, 2 spacing char(1) unaligned initial (" "); /* newline */ dcl 1 vrsn_msg int static aligned, 2 part1 char(11) unaligned init ("Version of "), 2 date_time char(24) unaligned, 2 spacing char(2) unaligned init (" "); /* two newlines */ dcl 1 first_record int static aligned, /* first record on sysout print collector file */ 2 rcw bit(36) init ("000016000374"b3 ), /* length=14, media code=3 (bcd print), report code=74 */ 2 newline_word bit(36) init ("770100000000"b3 ), /* the 7701 (bcd newline) prevents gcos_sys_xlate_ from trying to translate the stuff that follows */ 2 rec1 char(4) init ("rec1"), /* to verify that this is the sysout header record */ /* NOTE: the ASCII characters in a record whose media code says BCD is deliberate - not an error */ 2 er_offset fixed bin(24)aligned init (0), /* a word in which the offset of the execution report in the sysout file will be written, later, by gcos_cc_endjob_ */ 2 jobs_snumb char(5) init ("NONE "), /* place for gcos_cc_endjob_ to put snumb */ 2 pad1 char(3), /* to pad out to a full word */ 2 pad2 (9) fixed bin(24)aligned /* 9 spare words, making a 14-data-word record */; dcl 1 search_rules aligned , 2 number fixed bin(24) , 2 names (21)char(168)aligned ; dcl FF char(1) static int options(constant)init(" "); %page; %include gcos_fibs; %page; dcl 1 obj_info aligned like object_info; %include object_info; %page; %include gcos_restart_control_; %page; %include gcos_control_tables_; %page; %include gcos_gtss_dcls; %page; %include gcos_ext_stat_; end gcos_gein_;  gcos_gein_pass1_.pl1 09/09/83 1400.3rew 09/09/83 1006.9 417042 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_gein_pass1_: proc; /* This procedure reads thru the input segment, and any $ SELECTed files, performing the following functions: 1) optional canonicalization of ascii segments (conversion of tabs and backspaces to the right number of blanks); 2) copying of $ SELECTed files into the job stream; 3) scanning for $ EXECUTE and $ 355SIM cards, for later PSW bit 5 setting. It writes the job stream file in standard gcos format. This file contains no $ SELECT cards; they are discarded when the $ SELECTed files are copied into the job stream. For each $ control card, the ascii image, as well as the bcd image, is written on the job stream file (with a media code of "0110"b), the ascii image preceeding the bcd image. The $ control cards are written on the execution report at this time. Author: T. CASEY APRIL 1973 Change: T. CASEY NOVEMBER 1973, FEBRUARY 1974, APRIL 1974, JUNE 1974, AUGUST 1974 Change: R.H. MORRISON OCTOBER 1974 Change: D. KAYDEN DECEMBER 1974, MARCH 1975 Change: R.H. MORRISON SEPTEMBER 19, 1975 Change: M. R. Jordan, August 1977 Change: Mel Wilson March 1979 for gtss media codes. Change: Dave Ward 06/21/81 Reorganized. Corrected bug tabulation & alter files. Change: Ron Barstad 83-08-02 Start numbering jcl with 1 instead of 2! Fix card count message to look like GCOS */ write_buffer_ptr = addr (write_buffer); /* status_ptr = addr (status); */ ascii_work_area (*) = (4)"040"b3; ascii_ptr = addr (ascii_work_area); ascii_card_ptr = addrel (ascii_ptr, 1); ascii_len = 20; ascii_record.rcw = ascii_rcw; substr (ascii_report_card, 85, 1) = ascii_newline; write_buffer_ptr = addr (write_buffer); output_word_ptr = addrel (write_buffer_ptr, 1); remaining_output_words = 319; write_buffer_ptr -> bcw.bsn = "000001"b3 ; write_buffer_ptr -> bcw.length = (18)"0"b; save_data.last_execute_act_no, /* initialize activity numbers */ act_no = 0; gcos_ext_stat_$userid = ""; /* stack the main input segment for reading */ stack_level = 0; select_path = gcos_ext_stat_$input_segment_path; select_path_len = length (gcos_ext_stat_$input_segment_path); if gcos_ext_stat_$save_data.gcos then /* input is gcos file */ ascii_sw, canon_sw = "0"b; else do; /* input is ascii segment */ if gcos_ext_stat_$save_data.no_canonicalize then canon_sw = "0"b; else canon_sw = "1"b; ascii_sw = "1"b; end; on condition (cleanup) call pass1_cleanup; /* before we start allocating things */ call stack_selected_file; /* inputs to stack_selected_file include: select_path, select_path_len, ascii_sw, canon_sw */ /* attach gcos_job_stream_file for writing */ js_io_sw = "1"b; /* in case of io error, print path of job stream file */ js_path = gcos_ext_stat_$save_dir || ">" || gcos_ext_stat_$job_id || ".job_deck"; call ios_$attach ("gcos_job_stream_", "file_", js_path, "w", status); if code ^= 0 then do; err_msg = "from ios_$attach ^a w"; goto file_error; end; call ios_$setsize ("gcos_job_stream_", 36, status); if code ^= 0 then do; setsize_err: err_msg = "from ios_$setsize ^a"; goto file_error; end; call ios_$seek ("gcos_job_stream_", "last", "first", 0, status); /* truncate, in case it exists */ if code ^= 0 then do; err_msg = "from ios_$seek ^a"; goto file_error; end; js_io_sw = "0"b; /* in case of io error, print pathname of current input file */ %page; /* Main loop. Read input as long as any remains. */ do while (stack_level > 0); /* (stack level becomes zero at eof on main input seg) */ dollar_sw, eof_sw, select_card = "0"b; call read_current_file; /* outputs of read_current_file include: gcos_ptr,gcos_len,bcd_card_ptr, ascii_ptr,ascii_len,ascii_card_ptr, dollar_sw,eof_sw, card_type */ if eof_sw then /* if end of file, go back to reading the previous file, if there is one */ call unstack_current_file; /* if eof occurred, fall thru to end of read_loop */ else /* not eof */ process_card: do; card_count = card_count + 1; /* count cards */ if stack_level > 1 then selected_card_count = selected_card_count + 1; if dollar_sw then do; /* if this is a dollar card */ if card_type = "endcop" then if endfc = "" | substr (ascii_card, 16, 2) = endfc then copy_sw = "0"b; if substr (ascii_card, 8, 8) = "selectd" then goto process_select_card; /* even if copy_sw is on */ if copy_sw | card_type = "alter" then do; dollar_sw = "0"b; /* pretend its not a dollar card */ goto end_process_dollar_card; end; if card_type = "data" then do; /* check for copy option */ i = index (substr (ascii_card, 18), ",copy"); /* NOTE: Above code does not provide for ",copy" as comment on a data card. */ if i ^= 0 then do; copy_sw = "1"b; i = index (substr (ascii_card, 18), ",endfc"); if i ^= 0 then endfc = substr (ascii_card, 16, 2); else endfc = ""; end; end; if card_type = "select" then do; /* special handling of select cards */ process_select_card: select_card = "1"b; call interpret_select_card; /* outputs from interpret_select_card include: select_path,select_path_len,ascii_sw,canon_sw */ /* stack the selected file for reading */ call stack_selected_file; end; else do; /* Process non-select card. */ if card_type = "userid" then do; /* special handling of $ USERID cards */ gcos_ext_stat_$save_data.userid = "1"b; /* remember it, so prmfiles will be allowed */ in_password = "0"b; if gcos_ptr ^= addr (bcd_work_area) then do; /* can't modify the input file */ overlay_ptr = addr (bcd_work_area); /* get ptr to our work area */ overlay_ptr -> bcd_card_overlay = gcos_ptr -> bcd_card_overlay; /* copy card into it */ gcos_ptr = overlay_ptr; /* make it our working copy */ bcd_card_ptr = addrel (gcos_ptr, 1); end; do i = 16 to 72 /* scan card */ while (substr (ascii_card, i, 1) ^= " "); /* to end of operand field */ if in_password then /* wiping out password */ substr (ascii_card, i, 1) = "#"; else if substr (ascii_card, i, 1) = "$" then /* or looking for start of password */ in_password = "1"b; end; goto job_stream_write; /* go write it on job stream and execution report */ end; do i = 1 to gcos_control_tables_$totallen /* look up card in table */ while (card_type ^= substr (gcos_control_tables_$cardtable (i), 1, 6)); end; if i <= gcos_control_tables_$totallen then /* if not implemented, complain */ if i > gcos_control_tables_$tablelen then do; unimp_sw = "1"b; /* remember it */ if ^gcos_ext_stat_$save_data.brief then do; /* print warning unless told to be quiet */ err_msg = "unimplemented control card read from ^a:^/" || ascii_card; call com_err_ (0, "gcos", err_msg, current_file.pathname); end; end; /* see if it is an activity card */ if i >= gcos_control_tables_$exc_offset then /* if it's not before the first activity card in the table */ if i < gcos_control_tables_$nonact then do; /* and it's not after the last one */ /* then it must be an activity card */ act_no = act_no + 1; /* count activity cards */ /* and complain if too many */ if act_no > gcos_ext_stat_$max_activities then call gcos_error_ ( gcos_et_$too_many_activs , "Maximum number of activities allowed is ^d." , gcos_ext_stat_$max_activities ); /* locate info table entry for this activity */ act_ptr = addr (gcos_control_tables_$activity_table); /* start of table */ act_ptr = addrel (act_ptr, (i-gcos_control_tables_$exc_offset)*3); /* pick up nondollar canonicalization index for this activity */ nondollar_canon_index = act_table_entry.canon_index; /* if execute card, remember to turn on PSW bit 5 for all preceeding activities */ if card_type = "execut" | card_type = "355sim" then save_data.last_execute_act_no = act_no; end; if card_type = "msg1" then /* print msg1 card in pass1 */ call ioa_ ("^a", substr (ascii_card, 8, 73)); job_stream_write: call write_job_stream (ascii_ptr, ascii_len+1); end; print_before_etc: /* come here to print card before reading $ ETC following */ /* TO KEEP $ SELECT CARDS OFF THE EXECUTION REPORT, MOVE THE ABOVE END STATEMEMNT DOWN PAST THE CODE THAT WRITES ON THE EXECUTION REPORT */ /* The following logic puts a $ in column 2 of any dollar cards that were in $ SELECTed files. For the case of selected bcd files, we must make a copy of the bcd image before inserting the $, since otherwise we would be attempting to write into the input file itself, and we probably do not have write permission on it. */ overlay_ptr = gcos_ptr; /* point to image to be written on execution report */ if stack_level > 1 then do; /* if card is from a select file */ /* it needs a double dollar sign */ if gcos_ptr ^= addr (bcd_work_area) then do; /* bcd file. can't write into it */ overlay_ptr = addr (bcd_work_area); /* get pointer to our work area */ overlay_ptr -> bcd_card_overlay = gcos_ptr -> bcd_card_overlay; /* move card into it */ gcos_ptr = overlay_ptr; /* make it the working copy */ bcd_card_ptr = addrel (gcos_ptr, 1); end; bcd_card.column (2) = bcd_dollar; /* put $ in column 2 */ substr (ascii_card, 2, 1) = "$"; /* put it in ASCII copy, also */ end; if i >= gcos_control_tables_$exc_offset & i < gcos_control_tables_$nonact then act_flag = "a"; else act_flag = " "; gcos_ext_stat_$card_num = mod (card_count, 10000); call ioa_$rs ("^a ^1a^a", rtn_string, rtn_string_len, gcos_ext_stat_$card_num, act_flag, substr (ascii_card_record_overlay, 5)); if ^gcos_ext_stat_$save_data.debug then ioa_string = translate (ioa_string, UPPER_CASE, LOWER_CASE); call gcos_write_$ascii_ptr (gcos_ext_stat_$er, ioa_string, "11111100"b); if stack_level > 1 then do; /* if from a select file */ bcd_card.column (2) = bcd_blank; /* wipe out the extra dollar sign */ substr (ascii_card, 2, 1) = " "; /* in both copies */ end; /* END OF WRITE EXECUTION REPORT CODING. MOVE THAT END STATEMENT HERE */ if dbs_dollar then /* FOR DEBUGGING */ call ioa_ (ascii_card); end_process_dollar_card: ; end; /* for all cards (dollar or not) except $ SELECT cards, write the bcd (or binary) image on the job stream file */ if ^select_card then call write_job_stream (gcos_ptr, gcos_len + 1); if dbs_nondollar then /* FOR DEBUGGING */ if ^dollar_sw /* if this was a nondollar card */ then call ioa_ (ascii_card); /* print it */ /* NOTE that read_current_file checks the dbs_nondollar, and gives us the ascii image of nondollar cards, if we need them */ if etc_next_sw then goto etc_label; /* return to read $ ETC card, if one is expected */ /* NOTE: for etc after select cards, the select_card switch stays on, and the etc card does not get written on the job stream file */ end; end; %page; /* fall thru when we hit eof on main input segment */ /* see if job ended in $ ENDJOB card */ if card_type ^= "endjob" then do; /* generate endjob card if needed */ ascii_card = "$ endjob *** GENERATED BY GCOS ***"; gcos_ptr = addr (bcd_work_area); /* set up to get bcd image of it */ bcd_card_ptr = addrel (gcos_ptr, 1); gcos_len = 14; call get_bcd; /* entry point in read_current_file, just after reading ascii line */ goto process_card; /* in main loop, just after call to read_current_file */ end; /* print card count on execution report */ call ioa_$rsnnl ("^2xTotal card count this job = ^6d", err_path, i, card_count); /* length of returned string must be multiple of 4 */ err_num = i + 1; /* err_num = index of first vacant char in string */ /* it must be the first character in a word */ if selected_card_count > 0 then do; overlay_ptr = addr (addr (err_path) -> char_addrel (i)); /* get ptr to first vacant character */ /* ptr may not have a char offset - ioa_$rsnnl wants an aligned string */ call ioa_$rsnnl (" (including ^d from selected files)", bcd_card_overlay, /* convenient based char string, for return arg */ i, selected_card_count); err_num = err_num + i; /* err_num = index of first vacant char in extended line */ end; unspec (substr (err_path, err_num, 4)) = (4)"012"b3; /* append 4 newlines */ /* (skip 3 lines after message) */ err_num = err_num + 3; /* now, err_num is the exact length of the message */ call gcos_write_$ptr (gcos_ext_stat_$er, substr (err_path, 1, err_num), "11111100"b); if unimp_sw then if ^gcos_ext_stat_$save_data.continue then do; if gcos_ext_stat_$save_data.debug then do; query_info.yes_or_no_sw = "1"b; call command_query_ (addr (query_info), answer, "gcos", "unimplemented control cards have been found; do you wish to continue?"); if answer = "yes" then goto unimp_continue; end; call gcos_error_ (0, "unimplemented control cards have been used in this job"); end; unimp_continue: ; /* detach job stream file, see if it grew to a msf, and "open" it for reading in the appropriate way */ /* WRITE EOF RECORD ON IT FIRST */ call write_job_stream (addr (eof_rcw), 1); js_io_sw = "1"b; /* in case of io error, print pathname of job stream file */ call ios_$detach ("gcos_job_stream_", "", "", status); if code ^= 0 then do; detach_err: err_msg = "from ios_$detach ^a"; /* ALL-PURPOSE ERROR MESSAGE PRINTER */ file_error: if restartsw then do; a_code = code; return; end; if js_io_sw then err_path = js_path; else err_path = current_file.pathname; call gcos_error_ (code, err_msg, err_path, err_num); /* job will be aborted, and not return */ end; restart_join: dirname = gcos_ext_stat_$save_dir; ename = gcos_ext_stat_$job_id || ".job_deck"; call hcs_$status_minf (dirname, ename, chase, type, bit_count, code); if code ^= 0 then do; status_minf_err: err_msg = "from hcs_$status_minf ^a"; goto file_error; end; if type = 2 /* if it grew to a msf */ |dbs_msf_test then do; /* or we just want to test the msf logic */ call ios_$attach ("gcos_job_stream_", "file_", js_path, "r", status); if code ^= 0 then do; attach_r_err: err_msg = "from ios_$attach ^a r"; goto file_error; end; call ios_$setsize ("gcos_job_stream_", 36, status); if code ^= 0 then goto setsize_err; save_data.job_deck = null; /* tell rest of gcos it's not a segment */ end; else if type = 1 then do; /* or if it's a segment */ /* initiate it, for faster reading than if it were a msf */ call hcs_$initiate_count (dirname, ename, "", bit_count, 0, save_data.job_deck, code); if save_data.job_deck = null then do; initiate_err: err_msg = "from hcs_$initiate_count ^a"; goto file_error; end; save_data.jd_size = divide (bit_count, 36, 24, 0); /* size in words!!! */ end; else do; /* bad type code */ type_error: code = 0; err_num = type; err_msg = "bad type code from hcs_$status_minf for ^a: ^d"; goto file_error; end; call gcos_read_card_$read_init (restartsw); return; job_stream_restart: entry (a_code); write_buffer_ptr = addr (write_buffer); /* status_ptr = addr (status); */ restartsw = "1"b; a_code = 0; js_path = gcos_ext_stat_$save_dir || ">" || gcos_ext_stat_$job_id || ".job_deck"; go to restart_join; /* END OF MAIN PROCEDURE. DEBUGGING ENTRIES AND INTERNAL PROCEDURES FOLLOW */ %page; %include gcos_canonicalizer; %page; interpret_select_card: proc; dcl ca char (1) aligned; dcl path_type fixed bin(24) init (0); dcl prmfl_path char (250) varying init ("") /* file string is 233 chars max - use 250 to be safe */; pick_up_pathname: /* come here to scan etc cards, too */ etc_next_sw = "0"b; /* off unless we find that path is not complete on this card */ i = index (substr (ascii_card, 16, 57), " "); /* find end of pathname */ if i = 0 then i = 58; /* it gets decremented below */ if i = 1 then do; code = 0; err_msg = "no file given on select card from ^a:^/" || ascii_card; goto file_error; end; i = i - 1; /* get rid of trailing blank */ /* check for possible continuation onto etc card */ ca = substr (ascii_card, i+15, 1); /* pick up last nonblank character */ if ca = ">" then do; etc_next_sw = "1"b; path_type = 1; /* must be Multics pathname */ end; else if ca = "/" then do; etc_next_sw = "1"b; path_type = 2; /* must be GCOS file string */ end; prmfl_path = prmfl_path || substr (ascii_card, 16, i); /* pick up path from this card */ /* if path is continued, finish processing this card, and then go get the etc card */ if etc_next_sw then do; etc_label = select_etc; /* remember where to return */ goto print_before_etc; /* go print on execution report */ select_etc: /* return here */ dollar_sw = "0"b; call read_current_file; /* read etc card */ if dollar_sw then /* it better be an etc card ... */ if card_type = "etc" then goto pick_up_pathname; /* go get rest of path */ /* error if we fall thru - it was not an etc card */ code = 0; err_msg = "expected etc card missing following:^/$ select " || prmfl_path; goto file_error; end; /* now we have the whole thing - do we know its type (pathname or file string) */ if path_type = 0 then do; /* we don't, so figure it out */ j = index (prmfl_path, "/"); /* a file string must have at least one "/" */ if j = 0 then /* if it doesn't */ path_type = 1; /* it has to be a Multics pathname */ else do; /* it has a "/" - could still be a pathname */ j = index (prmfl_path, ">"); /* does it have a ">" */ if j = 0 then /* if it doesn't */ path_type = 2; /* assume a GCOS file string */ else /* but if it does, Multics is going to interpret it as a separator, even if someone made up a GCOS file string containing a ">" in one of its catalog names or the file name, so we could not process it as a file string anyway */ path_type = 1; end; end; if path_type = 2 then call gcos_interpret_file_string_ (prmfl_path, select_path, select_path_len, ascii_card); else do; select_path = prmfl_path; select_path_len = length (prmfl_path); end; /* note that value of i (length of path field on this card) has been preserved */ /* look for -ascii and -nocan in comments field */ i = i + 17; /* move i to first char of comment field */ j = index (substr (ascii_card, i), "-ascii"); /* search whole card image after pathname */ /* i.e. allow -ascii and -no to run past col 72 */ if j ^= 0 then ascii_sw = "1"b; else ascii_sw = "0"b; if ascii_sw then do; j = index (substr (ascii_card, i), "-no"); /* too many ways to spell "no canonicalize..." */ if j = 0 then canon_sw = "1"b; else canon_sw = "0"b; end; return; end interpret_select_card; %page; pass1_cleanup: proc; /* cleanup handler */ do i = stack_level to 1 by -1; current_pointer = stacked_pointers (i); if i <= hbound (stacked_pointers, 1) then /* avoid freeing nonexistent stuff */ if current_pointer ^= null then do; if current_file.msf then call ios_$detach (current_file.stream, "", "", status); /* ignore errors */ else if current_file.init_ptr ^= null then call hcs_$terminate_noname (current_file.init_ptr, code); /* be sure the pointer points into free area */ if baseno (current_pointer) = baseno (gcos_ext_stat_$system_free_pointer) then free current_file in (system_free_area); end; end; call ios_$detach ("gcos_job_stream_", "", "", status); end pass1_cleanup; %page; read_current_file: proc; /* come here to read next line, if this one is null (i.e., just a newline) */ if current_file.eof then /* if no more blocks in file */ if current_file.eob then do; /* and no more lines in this block */ eof_sw = "1"b; /* tell caller */ return; /* and return */ end; if current_file.ascii then do; /* Read an ascii file. */ if current_file.msf then do; /* Read an ascii msf. */ /* Ascii file not blocked. Read 1 line into buffer. Element size is 9 bits (one ascii character). Delimiter is ascii newline character). Read up to 1280 characters only because the buffer holds that many. There must be a newline long before that, if it is a legal line */ call ios_$read (current_file.stream, buffer_ptr, 0, 1280, chars_read, status); if code ^= 0 then do; read_err: err_msg = "from ios_$read ^a"; show_where: err_msg = err_msg || " (after card ^d of job)"; err_num = card_count; goto file_error; end; current_file.eof = substr (unspec (status), 46, 1); /* pick up eof switch from ios */ end; else do; /* Read an ascii segment: current file is segment */ /* simulate ios_$read by moving buffer pointer ahead to next line, and setting chars_read to length of it */ buffer_ptr = current_file.read_ptr; /* read_ptr was saved last time thru here */ chars_read = index (current_segment, ascii_newline); /* current_segment is based on read_ptr, so it includes only lines we haven't read yet */ if chars_read = 0 /* if no newline found */ |chars_read >1280 /* or if it was a long way off */ then chars_read = 1280; /* ios_$read would have returned 1280 chars */ if chars_read > current_file.remaining_len /* but if there are not 1280 chars left */ then chars_read = current_file.remaining_len; /* ios_$read would have returned what was left */ current_file.remaining_len = current_file.remaining_len - chars_read; /* decrement remaining length */ if current_file.remaining_len = 0 then current_file.eof = "1"b; /* if none left, give eof on NEXT call */ current_file.read_ptr = addr (buffer_ptr -> char_addrel (chars_read+1)); /* do addrel in terms of characters */ /* to get pointer to next line, for use in next call */ end; if chars_read = 0 then do; code = 0; err_msg = "zero chars read from ^a"; goto show_where; end; if chars_read = 1280 then if substr (char_buffer, 1280, 1) ^= ascii_newline then do; code = 0; err_msg = "no newline for 1280 characters in ^a"; goto show_where; end; if current_file.needs_canonicalization then call canonicalizer (buffer_ptr, chars_read, ascii_card_ptr, 80); else do; /* check for long lines, wipe out newline, copy line to output card buffer */ if chars_read <= 81 then chars_read = chars_read - 1; /* wipe out newline */ else do; /* line is too long */ if gcos_ext_stat_$save_data.truncate then /* if user said -truncate */ chars_read = 80; /* just ignore the extras */ else do; /* other wise complain */ code = 0; err_num = chars_read; err_msg = "line from ^a is too long (^d characters)^/" || char_buffer; if ^gcos_ext_stat_$save_data.continue then /* this is a nonfatal error */ goto file_error; if ^gcos_ext_stat_$save_data.brief then /* complain unless told to be quiet */ call ioa_ (err_msg, current_file.pathname, err_num); end; end; ascii_card = char_buffer; /* this statement SHOULD blank out the tail end of ascii_card */ end; /* get bcd image of card */ get_bcd: entry; /* place to enter if creating an endjob card */ call gcos_cv_ascii_gebcd_check_ (ascii_card_ptr, 84, bcd_card_ptr, i); if i ^= 0 then do; code = 0; err_num = i; err_msg = "line from ^a contains an illegal character in col. ^d^/" || char_buffer; go to file_error; end; gcos_record.rcw = bcd_rcw; /* put standard rcw in front of bcd card */ if substr (ascii_card, 1, 2) = "$" then do; dollar_sw = "1"b; /* tell caller about dollar card */ card_type = substr (ascii_card, 8, 6); /* and give him its type */ end; end; /* IF WE READ AN ASCII FILE, CONTROL SKIPS OVER THE read_gcos_file BLOCK FOLLOWING, AND RETURNS */ else do; /* current file is in gcos format */ if current_file.eob then do; /* do we need another block? */ if current_file.msf then do; call ios_$read (current_file.stream, buffer_ptr, 0, 320, words_read, status); if code ^= 0 then goto read_err; current_file.eof = substr (unspec (status), 46, 1); /* pick up eof switch from ios_$read */ if ^current_file.eof then /* in the unlikely event that the eof switch is NOT on */ if words_read < 320 then do; /* when we get a short block */ code = 0; /* complain about it */ err_num = words_read; err_msg = "block from ^a contained only ^d words"; goto file_error; end; end; else do; /* current file is a segment */ /* simulate ios_$read by moving pointer */ buffer_ptr = current_file.read_ptr; words_read = min (320, current_file.remaining_len); current_file.remaining_len = current_file.remaining_len - words_read; if current_file.remaining_len = 0 then current_file.eof = "1"b; /* remember to return eof NEXT get block call */ current_file.read_ptr = addrel (current_file.read_ptr, words_read); /* get pointer to next block, for use in next call */ end; /* now get first record in block */ current_file.remaining_block_len = fixed (buffer_ptr -> bcw.length); if current_file.remaining_block_len > 319 /* if block length too long (probably garbage) */ | current_file.remaining_block_len < 1 /* or too short (probably all zeros) */ then do; /* then complain */ code = 0; err_num = current_file.remaining_block_len; err_msg = "illegal block length in bcw from ^a: ^d words"; goto file_error; end; gcos_ptr, current_file.record_ptr = addrel (buffer_ptr, 1); current_file.eob = "0"b; /* don't get another block 'til this one used up */ end; else /* just get next record in current block */ gcos_ptr, current_file.record_ptr = addrel (current_file.record_ptr, fixed (current_file.record_ptr -> rcw.length) + 1); /* move pointer past LAST record, to THIS one; +1 because rcw.length does not include the rcw itself */ /* COMMON CODE FOR NEW BLOCK OR JUST NEXT RECORD */ if gcos_ptr -> rcw.eof = bcd_eof then do; /* if this is an eof record */ eof_sw = "1"b; /* return EOF THIS call */ current_file.eob, current_file.eof = "1"b; /* in case anyone looks */ return; end; bcd_card_ptr = addrel (gcos_ptr, 1); /* get pointer to data words in record */ gcos_len = fixed (gcos_ptr -> rcw.length); /* get length of THIS record */ current_file.remaining_block_len = current_file.remaining_block_len - gcos_len -1; /* -1 since gcos_len does not include the rcw */ if current_file.remaining_block_len < 0 then do; /* should never happen. program bug if it does */ call gcos_error_ (0, "pass1-get next record: block len < 0"); end; if current_file.remaining_block_len = 0 then current_file.eob = "1"b; /* remember to get block NEXT call */ if gcos_ptr -> rcw.media_code = "0010"b | gcos_ptr -> rcw.media_code = "0011"b | gcos_ptr -> rcw.media_code = "0111"b & gcos_ext_stat_$save_data.gtssflag then do; if bcd_card.column (1) = bcd_dollar then /* is it a dollar card ? */ if bcd_card.column (2) = bcd_blank then dollar_sw = "1"b; if gcos_len > 14 then do; call ioa_ ("gcos_gein_pass1_ bcd card > 14 words; using first 14"); gcos_len = 14; end; if dollar_sw /* if this is a dollar card */ |dbs_nondollar then do; /* or we are tracing nondollar cards */ ascii_card = ""; /* blank out card; gcos_cv_gebcd_ascii_ does not blank it */ call gcos_cv_gebcd_ascii_ (bcd_card_ptr, min (80, gcos_len*6), ascii_card_ptr); end; if dollar_sw then /* return type of dollar card */ card_type = substr (ascii_card, 8, 6); end; else if gcos_ptr -> rcw.media_code = "0001"b then do; /* if binary card */ if dbs_nondollar then ascii_card = "..... binary card ....."; /* give them something to print in trace */ end; else do; /* media code not bcd or binary */ code = 0; err_num = fixed (gcos_ptr -> rcw.media_code); /* show the code */ err_msg = "bad media code in record from ^a: ^d"; goto file_error; end; end; return; end read_current_file; %page; stack_selected_file: proc; stack_level = stack_level + 1; /* increment stack level */ if stack_level > hbound (stacked_pointers, 1) then do; code = 0; err_num = stack_level; err_msg = "too many nested $ SELECT cards; ^a contains the ^dth"; goto file_error; end; allocate current_file in (system_free_area) set (stacked_pointers (stack_level)); current_pointer = stacked_pointers (stack_level); current_file.init_ptr = null; current_file.pathname = select_path; current_file.ascii = ascii_sw; current_file.needs_canonicalization = canon_sw; current_file.eof = "0"b; current_file.eob = "1"b; /* to get a new block on first call to read */ if ascii_sw then do; gcos_ptr = addr (bcd_work_area); bcd_card_ptr = addrel (gcos_ptr, 1); gcos_len = 14; end; /* gcos file initialization done below: different for seg and msf */ call expand_path_ (addr (select_path), select_path_len, addr (dirname), addr (ename), code); if code ^= 0 then do; err_msg = "from expand_path_ ^a"; goto file_error; end; current_file.pathname = rtrim (dirname)||">"||rtrim (ename); call hcs_$status_minf (dirname, ename, chase, type, bit_count, code); if code ^= 0 then goto status_minf_err; if type = 2 /* if it it is a directory (msf, we hope) */ | dbs_msf_test then do; /* or if we want to test msf logic with a small job */ if bit_count = 0 then do; /* zero bit count => directory, not msf */ code = 0; err_msg = "attempt to $ SELECT a directory: ^a"; goto file_error; end; current_file.msf = "1"b; current_file.stream = "select"; /* convert stack level to characters, and append to "select" */ i = stack_level; if i > 9 then i = divide (i, 10, 24, 0); substr (current_file.stream, 7, 1) = substr ("123456789", i, 1); if stack_level > 9 then substr (current_file.stream, 8, 1) = substr ("0123456789", 1+mod (stack_level, 10), 1); /* this is better than a call to arith_to_char_ ??? */ call ios_$attach (current_file.stream, "file_", current_file.pathname, "r", status); if code ^= 0 then goto attach_r_err; buffer_ptr = addr (current_file.buffer); if ^ascii_sw then do; /* initializations needed for gcos format msf */ call ios_$setsize (current_file.stream, 36, status); /* set element size to 36 (one word) and delimiter to "none" (by changing element size without defining a new delimiter */ if code ^= 0 then goto setsize_err; end; /* for an ascii file, the file dim defaults are used: - element size = 9 (one ascii character) - delimiter is ascii newline character. */ end; else if type = 1 then do; /* or if it's a segment */ current_file.msf = "0"b; call hcs_$initiate_count (dirname, ename, "", bit_count, 0, current_file.init_ptr, code); if current_file.init_ptr = null then goto initiate_err; if bit_count = 0 then do; code = 0; err_msg = "zero length file $ SELECTed: ^a"; goto file_error; end; if ascii_sw then do; /* initializations needed for ascii segments */ current_file.init_len = divide (bit_count, 9, 24, 0); /* length in characters */ end; else do; /* initializations for gcos format segment */ current_file.init_len = divide (bit_count, 36, 24, 0); /* length in words */ end; /* for both ascii and gcos segments: */ current_file.read_ptr = current_file.init_ptr; /* next block = first block */ current_file.remaining_len = current_file.init_len; end; else goto type_error; /* if bad type code from hcs_$status_minf */ return; end stack_selected_file; %page; unstack_current_file: proc; if current_file.msf then do; call ios_$detach (current_file.stream, "", "", status); if code ^= 0 then goto detach_err; end; else do; call hcs_$terminate_noname (current_file.init_ptr, code); if code ^= 0 then do; err_msg = "from hcs_$terminate_noname ^a"; goto file_error; end; end; free current_file in (system_free_area); stacked_pointers (stack_level) = null; /* the free nulled current_pointer only */ stack_level = stack_level -1; if stack_level > 0 then do; /* if there's a file to resume reading */ /* then set up for reading it, where we left off */ current_pointer = stacked_pointers (stack_level); /* get pointer to info for it */ if current_file.ascii then do; /* re-do some initializations that were not preserved */ gcos_ptr = addr (bcd_work_area); bcd_card_ptr = addrel (gcos_ptr, 1); gcos_len = 14; end; if current_file.msf then buffer_ptr = addr (current_file.buffer); end; return; end unstack_current_file; %page; write_job_stream: proc (word_ptr, word_count); dcl word_count fixed bin(24); dcl word_ptr ptr; if word_count > 319 then do; /* if record bigger than block, complain */ code = 0; err_num = word_count; /* tell them how big it is */ err_msg = "record to be written on ^a is too long: ^d words"; js_io_sw = "1"b; /* print job stream file in error message */ goto file_error; end; if word_count > remaining_output_words then do; /* if no room in block for this record */ write_block: /* write the block */ call ios_$write ("gcos_job_stream_", write_buffer_ptr, 0, 320, words_written, status); if code ^= 0 then do; /* if any problem, complain */ err_msg = "from ios_$write ^a"; js_io_sw = "1"b; goto file_error; end; if words_written ^= 320 then do; /* if whole block not written, complain */ code = 0; err_num = words_written; err_msg = "wrong number of words written on ^a: ^d"; js_io_sw = "1"b; goto file_error; end; /* set block to empty */ remaining_output_words = 319; output_word_ptr = addrel (write_buffer_ptr, 1); write_buffer_ptr -> bcw.bsn = bit (fixed (fixed (write_buffer_ptr -> bcw.bsn)+1, 18)); /* bsn = bsn + 1 */ write_buffer_ptr -> bcw.length = (18)"0"b; /* length = 0 */ end; if last_block then return; /* if we just wrote out the last block, return */ /* append record to block */ write_buffer_ptr -> bcw.length = bit (fixed (fixed (write_buffer_ptr -> bcw.length) + word_count, 18)); /* length = length + word_count */ output_word_ptr -> words = word_ptr -> words; /* move record to write buffer */ output_word_ptr = addrel (output_word_ptr, word_count); /* advance pointer in buffer */ remaining_output_words = remaining_output_words - word_count; if word_count = 1 then do; /* one word record can only be an eof record */ last_block = "1"b; /* remember to quit after writing */ goto write_block; /* and go write the block out */ end; return; dcl last_block bit (1) aligned init ("0"b) /* used only when writing out final block */; dcl words (word_count) bit (36) based; end write_job_stream; %page; /* Variables for gcos_gein_pass1_: */ /* IDENTIFIER ATTRIBUTES */ dcl act_ptr ptr; dcl ascii_card char (80) aligned based (ascii_card_ptr) /* overlay for one line from an ascii file (segment or msf) */; dcl ascii_card_ptr ptr /* init(addrel(ascii_ptr,1)) */; dcl ascii_card_record_overlay char (84) aligned based (ascii_ptr) /* char overlay for ascii record, for gcos_write_$record */; dcl ascii_len fixed bin(24); dcl ascii_ptr ptr /* init(addr(ascii_work_area)) */; dcl ascii_report_card char (85) aligned based (ascii_card_ptr) /* to write on execution report. char 85 is nl */; dcl ascii_work_area (23) bit (36) aligned; dcl a_code fixed bin(35) /* used by restart entry */; dcl bcd_card_overlay char (60) aligned based (overlay_ptr) /* to send 15 word gcos record to gcos_write */; dcl bcd_card_ptr ptr /* always = addrel(gcos_ptr,1) */; dcl bcd_work_area (15) bit (36) aligned; dcl buffer_ptr ptr; dcl chars_read fixed bin(21); dcl char_addrel (1280) char (1) based /* to do addrel in terms of characters */; dcl char_buffer char (chars_read) based (buffer_ptr); dcl command_query_ ext entry options (variable); dcl com_err_ ext entry options (variable); dcl current_pointer ptr init (null) /* pointer to info structure for file currently being read, (equal to stacked_pointers(stack_level) */; dcl current_segment char (current_file.remaining_len) based (current_file.read_ptr); dcl err_msg char (200) varying; dcl err_num fixed bin(24); dcl err_path char (200); dcl expand_path_ ext entry (ptr, fixed bin(24), ptr, ptr, fixed bin(35)); dcl gcos_cv_ascii_gebcd_check_ ext entry (ptr, fixed bin(24), ptr, fixed bin(24)); dcl gcos_cv_gebcd_ascii_ ext entry (ptr, fixed bin(24), ptr); dcl gcos_error_ ext entry options (variable); dcl gcos_et_$cc_bad_field fixed bin(35) ext; dcl gcos_et_$too_many_activs fixed bin(35) ext; dcl gcos_interpret_file_string_ entry (char (*) varying, char (*), fixed bin(24), char (80) aligned); dcl gcos_len fixed bin(24); dcl gcos_ptr ptr /* NOT always = addr(bcd_work_area) - just sometimes */; dcl gcos_read_card_$read_init ext entry (bit (1) aligned); dcl gcos_write_$ascii_ptr entry (ptr, char (*) aligned, bit (8)); dcl gcos_write_$ptr ext entry (ptr, char (*) aligned, bit (8)); dcl gcos_write_$record_ptr ext entry (ptr, char (*) aligned, bit (8)); dcl hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin(24), fixed bin(24), ptr, fixed bin(35)); dcl hcs_$status_minf ext entry (char (*), char (*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35)); dcl hcs_$terminate_noname ext entry (ptr, fixed bin(35)); dcl ioa_ ext entry options (variable); dcl ioa_$rs ext entry options (variable); dcl ioa_$rsnnl ext entry options (variable); dcl output_word_ptr ptr; dcl overlay_ptr ptr; dcl remaining_output_words fixed bin(24); dcl rtrim builtin; dcl SP char(1)static int options(constant)init(" "); dcl stacked_pointers (11) ptr init ((11)null) /* pointers to info structure for the open files */; dcl stack_level fixed bin(24) /* number of input files currently "open" */; dcl system_free_area area based (gcos_ext_stat_$system_free_pointer) /* area to allocate things in */; dcl unspec builtin; dcl words_read fixed bin(21); dcl words_written fixed bin(21); dcl write_buffer (320) bit (36) aligned; dcl write_buffer_ptr ptr ; dcl act_flag char (1); dcl act_no fixed bin(24); dcl addr builtin; dcl addrel builtin; dcl answer char (4) varying; dcl ascii_backspace char (1) int static init (""); dcl ascii_rcw bit (36) aligned int static init ("000024000600"b3); dcl baseno builtin; dcl bcd_blank bit (6) unaligned int static init ("20"b3); dcl bcd_dollar bit (6) unaligned int static init ("53"b3); dcl bcd_eof bit (6) unaligned int static init ("17"b3); dcl bcd_newline_record bit (72) aligned int static init ("0000010003747701"b3); dcl bcd_newline_record_overlay char (8) aligned based (addr (bcd_newline_record)); dcl bcd_number_sign bit (6) unaligned int static init ("13"b3); dcl bcd_rcw bit (36) aligned int static init ("000016000200"b3); dcl bit builtin; dcl bit_count fixed bin(24); dcl card_count fixed bin(24)init(0); dcl card_type char (6); dcl chase fixed bin(1) init (1); dcl cleanup condition; dcl dirname char (168); dcl divide builtin; dcl ename char (32); dcl endfc char (2) /* for endfc option of $ data card */; dcl eof_rcw bit (36) aligned int static init ("000000170000"b3); dcl etc_label label local /* place to return to after printing card before etc */; dcl fixed builtin; dcl hbound builtin; dcl i fixed bin(24); dcl index builtin; dcl ioa_string char (rtn_string_len) aligned based (addr (rtn_string)); dcl j fixed bin(24); dcl js_path char (168); dcl length builtin; dcl LOWER_CASE char (26) static internal options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl max builtin; dcl min builtin; dcl mod builtin; dcl nondollar_canon_index fixed bin(24) /* says which tabs to use for nondollar cards, in the current activity */; dcl null builtin; dcl rtn_string char (256) aligned; dcl rtn_string_len fixed bin(24); dcl selected_card_count fixed bin(24)init(0); dcl select_path char (168); dcl select_path_len fixed bin(24); dcl substr builtin; dcl TAB char (1) int static init (" "); dcl translate builtin; dcl type fixed bin(2); dcl UPPER_CASE char (26) static internal options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl VALID_FMS_CHARS char (38) static internal options (constant) init (".-0123456789abcdefghijklmnopqrstuvwxyz"); dcl ascii_newline char (1) int static init (" "); dcl ( /* switches */ ascii_sw, /* on if file to be stacked is ascii */ canon_sw, /* on if file being stacked needs canonicalization */ dollar_sw, /* on if card read is a dollar card */ eof_sw, /* on if attempt to read card got end of file */ select_card, /* on if this is a select card */ unimp_sw, /* on if any unimplemented card is found in the job */ copy_sw, /* on if in a $ DATA ,,COPY deck */ etc_next_sw, /* on if next card is expected to be etc */ js_io_sw, /* on if doing io on job stream file (selects error message) */ in_password, /* on while blanking out password on $ USERID card */ restartsw /* on if restart entry called */ ) bit (1) aligned init ("0"b); dcl 1 current_file aligned based (current_pointer) /* info structure for open input files new copy allocated each time a $ SELECT card is read, and freed when eof occurs on the $ SELECTed file */ ,2 stream char (8)unal ,2 init_ptr ptr aligned ,2 init_len fixed bin(24) aligned ,2 read_ptr ptr aligned ,2 record_ptr ptr aligned ,2 remaining_len fixed bin(35) aligned ,2 remaining_block_len fixed bin(24) aligned ,2 ascii bit (1) aligned ,2 msf bit (1) aligned ,2 needs_canonicalization bit (1) aligned ,2 eob bit (1) aligned ,2 eof bit (1) aligned ,2 pathname char (200) unal ,2 buffer (320) bit (36) aligned ; dcl 1 ascii_record aligned based (ascii_ptr), 2 rcw bit (36) aligned, 2 data_words (ascii_len) bit (36) aligned; dcl 1 bcd_card aligned based (bcd_card_ptr), 2 column (80) bit (6) unaligned; dcl 1 gcos_record aligned based (gcos_ptr), 2 rcw bit (36) aligned, 2 data_words (gcos_len) bit (36) aligned; dcl 1 bcw aligned based, /* block control word overlay */ 2 bsn bit (18) unaligned, 2 length bit (18) unaligned; dcl 1 rcw aligned based, /* record control word overlay */ 2 length bit (18) unaligned, 2 eof bit (6) unaligned, 2 zeroes bit (2) unaligned, 2 media_code bit (4) unaligned, 2 report_code bit (6) unaligned; dcl 1 act_table_entry based (act_ptr), 2 fill1 fixed bin(24), 2 fill2 char (4), 2 canon_index fixed bin(24); dcl 1 tabstops aligned based (addr (gcos_control_tables_$tabstops)), 2 count fixed bin(24) aligned, 2 tab (0:tabstops.count-1), 3 stop (10) fixed bin(24) aligned; %page; %include gcos_control_tables_; %page; %include query_info; %page; %include gcos_ext_stat_; %page; %include gcos_dbs_names; %page; %include gcos_dcl_ios_; end gcos_gein_pass1_;  gcos_get_bar_.alm 09/09/83 1400.3rew 09/09/83 1006.9 5310 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " declare gcos_get_bar_ entry(bit(36)); " Return BAR register value (left justified, i.e., " bar.base[0-8]||bar.bound[9-17]||garbage[18-35]) " Dave Ward 09/19/80 name gcos_get_bar_ segdef gcos_get_bar_ even gcos_get_bar_: sbar ap|2,* " b(36)<-bar register. short_return end  gcos_get_cc_field_.pl1 09/09/83 1400.3rew 09/09/83 1006.9 81810 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ****************************************************************************************** ******************************************************************************************** * * * * E X T R A C T F I E L D F R O M G E C O S C O N T R O L C A R D * * * * This procedure extracts the next field from a gcos control card. It will * also return a switch called "result". If result is 0 then it means that a field is * being returned in "field". If result is 1, it means that a null field (two * successive commas) was found. If result is a 2, the end of the card has been read. * Getfield allows $ etc cards to be used to extend the operand field of a card. * If a $ ETC card is read, then 1) if gcos_ext_stat_$save_data.write_etc is "1"b then * the bcd image is written on gcos_ext_stat_$etc_filecode (which might * be "d*" for example), and 2) the ascii image will replace the input * argument, card. This works except when it is not decided to write * the card on a file until after the etc card has been read (e.g., a * stranger option on the second card but not the first. We hope this never happens. * * The variable gcos_ext_stat_$gf is used for communication between this * procedure and its callers: a value of 0 (set by the caller) indicates * that a new card has been read, and we should start processing it at * column 16; 1 (set by this procedure) indicates that the same card is being processed * as in the previous call, and we should continue processing at the column where * the field returned then ended; 2 (set by this procedure) indicates * that on the previous call, the field returned was the last one on the card, * and so we should return result=2 on this call; 3 indicates that * we should immediately read a $ ETC card and start processing it in column 16. * * gcos_cc_file_cards_ sets gf=3 to force reading of a $ ETC card, when the pathname * on the PRMFL card ends in > or / (continuation, but not indicated by a comma). * * * WRITTEN BY DICK SNYDER AUGUST 27, 1970 * MODIFIED BY T.CASEY DECEMBER 1972, OCTOBER 1973, FEBRUARY 1974 * MODIFIED BY D.KAYDEN FEBRUARY 1975 * Modified by M. R. Jordan, August 1977 * * ******************************************************************************************** ****************************************************************************************** */ gcos_get_cc_field_: proc (card, field, result); /* D E C L A R A T I O N S */ /* Parameters */ dcl card char (80) aligned; /* input card image */ dcl field char (*); /* returned field */ dcl result fixed bin(24); /* returned result: */ /* 0 = ok */ /* 1 = null field */ /* 2 = end of card */ %include gcos_ext_stat_; /* Work Variables */ dcl gcos_error_ entry options (variable); dcl code fixed bin(35); dcl cv_dec_check_ entry (char (*), fixed bin(35)) returns (fixed bin(35)); dcl gcos_et_$cc_bad_field fixed bin(35) ext; dcl param_num fixed bin(24); dcl posn fixed bin(24)internal static; /* variable to remember scan position */ dcl i fixed bin(24); /* temp */ dcl trans_it bit (1) aligned; dcl use_params bit (1) aligned; dcl gcos_record char (gcos_len) based (gcos_ptr); /* bcd image of etc card */ dcl gcos_len fixed bin(24); dcl gcos_ptr ptr; dcl dollar_sw bit (1) aligned; /* External Entries */ dcl gcos_et_$cc_field_too_long fixed bin(35) ext; dcl gcos_write_$record ext entry (char (*), char (*), bit (8)); dcl gcos_write_to_er_ entry options (variable); dcl gcos_read_card_ ext entry (ptr, fixed bin(24), char (80) aligned, bit (1) aligned); dcl (addr, length, search, substr, translate) builtin; dcl LOWER_CASE char (26) static internal options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl UPPER_CASE char (26) static internal options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); trans_it = "1"b; /* make it lower case */ use_params = "1"b; /* and allow params */ goto continue; asis: entry (card, field, result); trans_it = "0"b; use_params = "0"b; goto continue; no_param: entry (card, field, result); trans_it = "1"b; /* make sure we get lower case */ use_params = "0"b; /* and no parameter expansions */ goto continue; no_fold: entry (card, field, result); trans_it = "0"b; use_params = "1"b; /* allow parameter expansions */ continue: field = " "; /* init return field */ if gcos_ext_stat_$gf = 0 then go to start; /* flag is 0 when new card read */ if gcos_ext_stat_$gf = 1 then go to next; /* middle of card ? */ if gcos_ext_stat_$gf = 2 then do; /* if 2 then end of card */ endcard: result = 2; /* indicate end of card */ return; /* exeunt */ end; /* gf must be 3, as set by last call, when "," was last character on card */ go to getetc; /* go get a $ etc card */ /* Come here if starting on a new card */ start: gcos_ext_stat_$gf = 1; /* indicate middle of card */ posn = 16; /* init position offset */ go to next1; /* Come here if called in middle of card */ next: if posn > 72 then go to getetc; next1: i = search (substr (card, posn, 73-posn), " ,")-1; /* scan for a field delimiter */ if i = 0 then /* if the first char is a delimiter... */ if substr (card, posn, 1) = "," then do; /* and it is a comma... */ result = 1; /* return null field indicator */ posn = posn+1; /* bump card position */ return; end; else /* it must be a space */ if posn = 16 then go to endcard; /* if no commas before delimiter, this is end of card */ else go to getetc; /* otherwise, get $ etc card */ if i < 0 then do; /* if no delimiter found... */ i = 73-posn; /* then field is rest of card */ gcos_ext_stat_$gf = 2; /* and this is the last parameter */ end; else if substr (card, posn+i, 1) = " " then /* if deleimiter was a blank... */ gcos_ext_stat_$gf = 2; /* this is also the last parameter */ if i > length (field) then do; /* field on control card is too long */ call gcos_write_to_er_ ("Warning: Control card field ""^a"" is too long.^/^a^2x^a", substr (card, posn, i), gcos_ext_stat_$card_num, card); end; call Get_Field (); posn = posn + i+1; /* bump card position past field and delimiter */ if trans_it then field = translate (field, LOWER_CASE, UPPER_CASE); result = 0; return; /* done */ /* Come here to read $ etc card */ getetc: call gcos_read_card_ (gcos_ptr, gcos_len, card, dollar_sw); /* get a new card */ if ^dollar_sw | substr (card, 1, 10) ^= "$ etc" then do; /* print warning if not $ etc */ call gcos_write_to_er_ ("Warning: There appears to be a missing $ ETC card before:^/^a^2x^a", gcos_ext_stat_$card_num, card); gcos_ext_stat_$gf = 2; goto endcard; end; if gcos_ext_stat_$save_data.write_etc then /* if caller wants etc cards written on a file */ call gcos_write_$record (gcos_ext_stat_$etc_filecode, gcos_record, (8)"0"b); posn = 16; /* reset position indicator */ go to next1; /* continue processing */ Get_Field: procedure (); if substr (card, posn, 1) = "#" & use_params then do; if i = 1 then do; call gcos_write_to_er_ ( "Warning: A parameter replacement may be in error.^/^a^2x^a", gcos_ext_stat_$card_num, card); field = "#"; end; else if substr (card, posn+1, 1) = "#" then field = substr (card, posn+1, i-1); else do; param_num = cv_dec_check_ (substr (card, posn+1, i-1), code); if code ^= 0 then call gcos_error_ (gcos_et_$cc_bad_field, "Parameter numbers must be decimal constants. ""^a""^/^a^2x^a", substr (card, posn, i), gcos_ext_stat_$card_num, card); if param_num < lbound (save_data.param, 1) | param_num > hbound (save_data.param, 1) then call gcos_error_ (gcos_et_$cc_bad_field, "Parameter number values must be from ^d to ^d.^/^a^2x^a", lbound (save_data.param, 1), hbound (save_data.param, 1), gcos_ext_stat_$card_num, card); if length (save_data.param (param_num)) > length (field) then call gcos_write_to_er_ ( "Warning: Control card field ""^a"" is too long.^/^a^2x^a", save_data.param (param_num), gcos_ext_stat_$card_num, card); field = save_data.param (param_num); end; end; else field = substr (card, posn, i); /* extract field from card */ return; end Get_Field; end gcos_get_cc_field_;  gcos_gtss_update_.pl1 09/09/83 1400.3rew 09/09/83 1006.9 20088 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* * Written ??? * Modified: R. Barstad 11/16/82 Fix actid format for console messages */ gcos_gtss_update_: proc; dcl (activity_val, status_val) fixed bin(24)parm; end_gcos_gtss_update: /* bail_out point for error_processing */ return; %page; status_update: entry (status_val); call setup; job_status (snumb_index) = status_val; return; new_activity: entry (activity_val, status_val); call setup; gtss_snumb_xref_.activity_no (snumb_index) = activity_val; job_status (snumb_index) = status_val; return; %page; setup: proc; if ^initialized then do; call user_info_$homedir (home_path); call hcs_$initiate (home_path, "gtss_user_state_.gtss", "gtss_user_state_", 0, 1, u_state_ptr, c); if u_state_ptr = null () then call ioa_ ("Can't access gtss_user_state_, hcs_$initiate returned ^i.", c); initialized = "1"b; end; if u_state_ptr = null () then goto end_gcos_gtss_update; if snumb_index = 0 then do; do i = 1 to entry_count while (gtss_snumb_xref_.snumb (i) ^= substr (save_data.actid, 1, 5) | job_status (i) = COMPLETE); end; if i <= entry_count then snumb_index = i; else do; call ioa_ ("Can't find snumb ^5a in gtss tables.", substr (save_data.actid, 1, 5)); u_state_ptr = null (); goto end_gcos_gtss_update; end; end; dcl c fixed bin(35); dcl i fixed bin(24); dcl initialized bit int static init ("0"b); end setup; %page; /* Variables for gcos_gtss_update_: */ /* IDENTIFIER ATTRIBUTES */ dcl null builtin; dcl hcs_$initiate entry (char(*), char(*), char(*), fixed bin(1), fixed bin(2), ptr, fixed bin(35) ); dcl ioa_ entry options (variable); dcl user_info_$homedir entry (char(*)); %page; %include gcos_gtss_dcls; %page; %include gcos_ext_stat_; end gcos_gtss_update_;  gcos_ids2_concur_.pl1 04/09/85 1702.5r w 04/08/85 1131.7 132624 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_ids2_concur_: proc; /* IDS 2 concurrency control Provides for control of access of multiple processes to the same IDS2 data bases. Whenever an IDS file is created, a lock control seg will be created for it. When the simulator is asked by the IDS process to allocate an IDS file, the simulator gets the lock control seg and locks other processes out temporarily with set_lock_. The control seg is examined for a valid combination of Gcos access by current processes that will allow the requesting process allocation. If allocation is permitted, this is noted in the control seg, the seg is unlocked and the IDS file is allocated. If allocation is not permitted, the control seg is unlocked and the simulator returns to the IDS process with "file busy". When a file is deallocated, the control seg is locked and the allocation is removed from the record of current allocations in the control seg. When an IDS file is released (deleted) the control seg is also deleted. In a Gcos environment there are basically two allocation types to keep track of. - one writer with no other readers - many readers with no concurrent writer Multiple readers are always ok. There are other esoteric types of allocation, but these two are the ones implemented. The concurrency control is on a file basis rather than per record or per entry. The problem of deadlocks is dealt with by the application. If it has more that one data base then it has to decide what to do if it can't get one of them. There are five entry points to this module. They are: gcos_ids2_concur_$create_control Create an ids2 control segment gcos_ids2_concur_$delete_control Delete ids2 control segment gcos_ids2_concur_$allocate Try allocate ids2 data base gcos_ids2_concur_$deallocate remove allocation lock gcos_ids2_concur_$have_xid returns "1"b if file has ids2 ACL The parameters and returned status are discussed in the comments for each entry. Written: Ron Barstad 10/18/82 */ %page; dcl ids_dir char (168) parameter; /* input */ dcl ids_entry_name char (32) parameter; /* input */ dcl read_access bit (1) parameter; /* input: "1"b if have read access */ dcl write_access bit (1) parameter; /* input: "1"b if have write access */ dcl busy_status bit (1) parameter; /* output: "1"b = busy, "0"b = ok, was allocated */ dcl code fixed bin (35) parameter; /* output */ dcl acl_ptr ptr; dcl addr builtin; dcl adj_bit_count fixed bin (35); dcl adjust_bit_count_ entry (char(168), char(32), bit(1) aligned, fixed bin(35), fixed bin(35)); dcl bit_count fixed bin (24); dcl control_seg_ename char (32); dcl CONTROL_SEG_SUFFIX char (12) internal static options (constant) initial (".CONCURRENCY"); dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)); dcl divide builtin; dcl e_code fixed bin(35); /* local version of code */ dcl error_table_$invalid_lock_reset fixed bin (35) ext static; dcl error_table_$lock_not_locked fixed bin (35) ext static; dcl error_table_$lock_wait_time_exceeded fixed bin (35) ext static; dcl error_table_$locked_by_this_process fixed bin (35) ext static; dcl error_table_$segknown fixed bin (35) ext static; dcl have_ids_acl bit (1); dcl hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$list_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc entry (char(*), char(*), fixed bin(24), fixed bin(35)); dcl lock_control_ptr pointer; dcl max builtin; dcl MAX_READERS fixed bin(17) internal static options(constant) init(1000); dcl null builtin; dcl read_index fixed bin (17); dcl rtrim builtin; dcl set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)); dcl set_lock_$unlock entry (bit (36) aligned, fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl 01 segment_acl (1) aligned, 02 access_name char (32), 02 modes bit (36), 02 xmodes bit (36), 02 acl_status_code fixed bin (35); dcl 01 lock_control_seg_acl (1) aligned, 02 access_name char (32), 02 modes bit (36), 02 xmodes bit (36), 02 acl_status_code fixed bin (35); dcl 01 lock_control_seg aligned based (lock_control_ptr), 02 seg_lock bit (36), 02 write_lock bit (36), 02 number_of_readers fixed bin (24), 02 read_lock (MAX_READERS) bit(36); %page; /* create_control Create the ids concurrency control segment. The ids data base file has just been created or the control segment was not found. parameters: ids_entry_name the name of the ids file - input ids_dir the directory of the ids file - input code the error_table_ status - output result: If all goes well, the seg, .CONCURRENCY will be created and initialized. An ACL is added to the IDS2 file to give it an extrinsic identification for later recognition. */ create_control: entry (ids_dir, ids_entry_name, code); /* add an acl to ids2 file to give it an extrinsic characteristic */ segment_acl.access_name = "*.*.I"; segment_acl.modes = R_ACCESS; segment_acl.xmodes = "0"b; acl_ptr = addr (segment_acl); call hcs_$add_acl_entries (ids_dir, ids_entry_name, acl_ptr, 1, code); if code ^= 0 then goto create_exit; /* create the lock control seg */ control_seg_ename = rtrim (ids_entry_name)||CONTROL_SEG_SUFFIX; call hcs_$make_seg (ids_dir, control_seg_ename, "", RW_ACCESS_BIN, lock_control_ptr, code); if code ^= 0 then goto create_exit; /* add the acl to allow all to read and write */ lock_control_seg_acl.access_name = "*.*.*"; lock_control_seg_acl.modes = RW_ACCESS; lock_control_seg_acl.xmodes = "0"b; acl_ptr = addr (lock_control_seg_acl); call hcs_$add_acl_entries (ids_dir, control_seg_ename, acl_ptr, 1, code); if code ^= 0 then goto create_exit; /* intialize control seg */ lock_control_seg.seg_lock = "0"b; lock_control_seg.write_lock = "0"b; lock_control_seg.number_of_readers = 0; lock_control_seg.read_lock (1) = "0"b; call terminate_file_(lock_control_ptr, 4*36, TERM_FILE_BC | TERM_FILE_TERM, code); create_exit: return; %page; /* delete_control Delete the ids concurrency control segment. The ids data base file has just been deleted. parameters: ids_entry_name the name of the ids file - input ids_dir the directory of the ids file - input code the error_table_ status - output result: If all goes well, the seg, .CONCURRENCY will be deleted. */ delete_control: entry (ids_dir, ids_entry_name, code); control_seg_ename = rtrim (ids_entry_name)||CONTROL_SEG_SUFFIX; call delete_$path (ids_dir, control_seg_ename, "100100"b, "gcos", code); return; %page; /* allocate Allocate, or attempt to allocate, the given ids file through the control seg. parameters: ids_entry_name the name of the ids file - input ids_dir the directory of the ids file - input read_access "1"b if have read access - input write_access "1"b if have write access - input busy_status "0"b if ok, "1"b if busy - output code the error_table_ status - output algorithm: lock the control seg if access_type includes write then if have any readers then busy := true else try write lock if ok then busy := false else busy := true else {read access} if valid write lock exits then busy := true else set another read lock and increment reader count busy := false unlock the control seg result: If the file is available for this allocation type, then status ok is returned, otherwise status busy is returned. */ allocate: entry (ids_dir, ids_entry_name, read_access, write_access, busy_status, code); control_seg_ename = rtrim (ids_entry_name)||CONTROL_SEG_SUFFIX; call hcs_$initiate_count (ids_dir, control_seg_ename, "", bit_count, 0, lock_control_ptr, code); if code ^= 0 then if code ^= error_table_$segknown then goto allocate_exit; /* try to allocate */ busy_status = "0"b; /* assume ok */ call set_lock_$lock (lock_control_seg.seg_lock, 10, code); if code ^= 0 then if code ^= error_table_$invalid_lock_reset then if code ^= error_table_$locked_by_this_process then goto allocate_exit; if write_access then do; /* write access */ if lock_control_seg.number_of_readers >0 then do; call clean_out_dead_locks; if lock_control_seg.number_of_readers /* still */ > 0 then goto alloc_busy_exit; end; call set_lock_$lock (lock_control_seg.write_lock, 0, code); if (code = 0 | code = error_table_$invalid_lock_reset | code = error_table_$locked_by_this_process) then goto alloc_ok_exit; if code = error_table_$lock_wait_time_exceeded then goto alloc_busy_exit; goto alloc_unlock_exit; end; else do; /* read access */ if lock_control_seg.write_lock then do; call set_lock_$lock(lock_control_seg.write_lock, 0, code); /* maybe it's dead, code is irrelevant now */ call set_lock_$unlock(lock_control_seg.write_lock, code); if code ^= 0 then goto alloc_busy_exit; end; do read_index = 1 to MAX_READERS; call set_lock_$lock (lock_control_seg.read_lock (read_index), 0, code); if code = 0 then do; lock_control_seg.number_of_readers = lock_control_seg.number_of_readers + 1; call adjust_bit_count_(ids_dir, control_seg_ename, "0"b, adj_bit_count, code); if code = 0 then goto alloc_ok_exit; goto alloc_unlock_exit; end; if (code = error_table_$invalid_lock_reset | code = error_table_$locked_by_this_process) then goto alloc_ok_exit; end; end; alloc_busy_exit: busy_status = "1"b; /* busy */ alloc_ok_exit: code = 0; alloc_unlock_exit: call set_lock_$unlock (lock_control_seg.seg_lock, e_code); if code = 0 then code = e_code; /* report earliest error */ allocate_exit: return; %page; /* deallocate deallocate the given ids file through the control seg. parameters: ids_entry_name the name of the ids file - input ids_dir the directory of the ids file - input read_access "1"b if have read access - input write_access "1"b if have write access - input code the error_table_ status - output algorithm: lock control seg if access_type includes write access then unlock write lock else for read_lock := first_read_lock to end of segment unlock read lock if ok then exit loop unlock control seg terminate control seg result: If the process id is in the control seg, then the lock is unlocked. */ deallocate: entry (ids_dir, ids_entry_name, read_access, write_access, code); control_seg_ename = rtrim (ids_entry_name)||CONTROL_SEG_SUFFIX; call hcs_$initiate_count (ids_dir, control_seg_ename, "", bit_count, 0, lock_control_ptr, code); if code ^= 0 then if code ^= error_table_$segknown then goto deallocate_exit; /* try to deallocate */ call set_lock_$lock (lock_control_seg.seg_lock, 120, code); if code ^= 0 then if code ^= error_table_$invalid_lock_reset then if code ^= error_table_$locked_by_this_process then goto deallocate_exit; if write_access then do; /* write access */ call set_lock_$unlock (lock_control_seg.write_lock, code); if code ^= 0 then if code ^= error_table_$lock_not_locked then goto dealloc_unlock_exit; end; else /* read access */ do read_index = 1 to (divide(bit_count,36,17)-3); if (lock_control_seg.read_lock(read_index)) then do; call set_lock_$unlock (lock_control_seg.read_lock (read_index), code); if code = 0 then do; lock_control_seg.number_of_readers = lock_control_seg.number_of_readers - 1; call adjust_bit_count_(ids_dir, control_seg_ename, "0"b, adj_bit_count, code); if code ^= 0 then goto dealloc_unlock_exit; bit_count = max(adj_bit_count, 4*36); call hcs_$set_bc(ids_dir, control_seg_ename, bit_count, code); if code ^= 0 then goto dealloc_unlock_exit; goto dealloc_ok_exit; end; end; end; dealloc_ok_exit: code = 0; dealloc_unlock_exit: call set_lock_$unlock(lock_control_seg.seg_lock, e_code); if code = 0 then code = e_code; /* report only earliest error */ call terminate_file_(lock_control_ptr, bit_count, TERM_FILE_TERM,e_code); if code = 0 then code = e_code; deallocate_exit: return; %page; /* have_xid returns "1"b if ids_entry_name has an acl (extrinsic id) identifying it as an IDS2 file */ have_xid: entry (ids_dir, ids_entry_name, code) returns (bit (1)); segment_acl.access_name = "*.*.I"; segment_acl.modes = R_ACCESS; segment_acl.xmodes = "0"b; have_ids_acl = "0"b; /* assume not */ acl_ptr = addr (segment_acl); call hcs_$list_acl (ids_dir, ids_entry_name, null (), null (), acl_ptr, 1, code); if code = 0 & segment_acl (1).acl_status_code = 0 then have_ids_acl = "1"b; return (have_ids_acl); %page; clean_out_dead_locks: proc; /* clean out all dead read processes in lock control seg */ do read_index = 1 to MAX_READERS; if (lock_control_seg.read_lock(read_index )) then do; call set_lock_$lock (lock_control_seg.read_lock(read_index), 0, code); if code = error_table_$invalid_lock_reset then do; lock_control_seg.number_of_readers = lock_control_seg.number_of_readers -1; code = 0; end; if code = 0 then call set_lock_$unlock (lock_control_seg.read_lock (read_index), code); end; end; code = 0; /* code is irrelevant here */ return; end; %page; %include access_mode_values; %include terminate_file; end gcos_ids2_concur_;  gcos_incode_.alm 09/09/83 1400.3rew 09/09/83 1006.9 21816 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" " " " P E R F O R M I N C O D E T R A N S L A T I O N " " " This routine will perform incode translation for a string of bcd " characters. It takes three parameters. Parameter 1 is a pointer to a " bcd string. Parameter 2 is the length of that string (number of bcd " characters). Parameter 3 is a pointer to a receiving field for the " incoded output. " " " WRITTEN BY D. KAYDEN JANUARY 1975 " " """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" name gcos_incode_ entry gcos_incode_ gcos_incode_: eppbp ap|2,* bp->input data eppbp bp|0,* lda ap|4,* a = char count eppbb ap|6,* bb->output buffer eppbb bb|0,* ldq |[incode] q = incode type qls 4 multiply by 16 mvt (pr,rl),(pr,rl) desc6a bp|0,al desc6a bb|0,al arg ibmf-16,ql short_return ibmf: oct 000001002003 oct 004005006007 oct 010011012075 oct 057013016017 oct 020021022023 oct 024025026027 oct 030031060033 oct 055035036037 oct 040041042043 oct 044045046047 oct 050051052053 oct 054055056057 oct 060061062063 oct 064065066067 oct 070071072073 oct 035075076077 ibmc: oct 000001002003 oct 004005006007 oct 010011012075 oct 076013016017 oct 020021022023 oct 024025026027 oct 030031060033 oct 055035036037 oct 040041042043 oct 044045046047 oct 050051052053 oct 054055056057 oct 060061062063 oct 064065066067 oct 070071072073 oct 035075076077 ibmel: oct 000001002003 oct 004005006007 oct 010011015013 oct 014057075076 oct 020021022023 oct 024025026027 oct 030031032033 oct 036035060037 oct 040041042043 oct 044045046047 oct 050051052053 oct 054055056057 oct 060061062063 oct 064065066067 oct 070071020073 oct 074020016017 end  gcos_interpret_file_string_.pl1 09/09/83 1400.3rew 09/09/83 1006.9 54765 /* ************************************************************* * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1974 by Honeywell Information Systems, Inc. * * * ************************************************************* */ /* ************************************************************************** ************************************************************************** * * * This routine receives gcos_cfdesc and returns the corresponding multics_path * and path_len. gcos_cfdesc is the gcos catalog/file description containing * slashes and dollar signs. multics_path is the corresponding Multics absolute pathname. * path_len is the length of the returned multics_path. * * Written by G. Novak Feb. 21,1974 * MODIFIED BY R.H. MORRISON ON APRIL 15, 1974 * MODIFIED BY T. CASEY ON MAY 8, 1974 * MODIFIED BY R.H. MORRISON ON JULY 18,1975 * Modified by M. R. Jordan, September 1976 * Modified: Ron Barstad 83-08-02 Fixed spelling of "pathname" in ioa_ * * ************************************************************************** *********************************************************************** */ gcos_interpret_file_string_: procedure (gcos_cfdesc, a_multics_path, path_len, card); ; dcl LOWER_CASE char (26) static internal options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl card char (80); dcl cv_dec_check_ entry (char (*), fixed bin(35)) returns (fixed bin(35)); dcl gcos_error_ entry options (variable); dcl UPPER_CASE char (26) static internal options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl a_multics_path char (*); dcl addr builtin; dcl cat_len fixed bin(24); dcl cat_start fixed bin(24); dcl cfname char (80) varying; dcl code fixed bin(35); dcl dollar fixed bin(24); dcl err_msg char (150); dcl err_msg_len fixed bin(24); dcl gcos_cfdesc char (*) varying; dcl gcos_et_$cc_bad_field fixed bin(35) ext; dcl gcos_write_$ascii_ptr entry (ptr, char (*), bit (8)); dcl gcos_write_to_er_ entry options (variable); dcl i fixed bin(24); dcl index builtin; dcl ioa_ entry options (variable); dcl ioa_$nnl entry options (variable); dcl ioa_$rs entry options (variable); dcl length builtin; dcl message char (34) static internal init ("invalid GCOS catalog/file string") options (constant); dcl multics_path char (168) varying; dcl param_num fixed bin(24); dcl path_len fixed bin(24); dcl slash fixed bin(24); dcl stop bit (1); dcl substr builtin; dcl var_err_msg char (err_msg_len) based (addr (err_msg)) ; /* Initialize and report the GCOS catalog/file description. */ call ioa_$rs ("Comment: GCOS catalog/file string is ^a", err_msg, err_msg_len, gcos_cfdesc) ; if gcos_ext_stat_$save_data.long then call ioa_$nnl ("^a", var_err_msg) ; call gcos_write_$ascii_ptr (gcos_ext_stat_$er, var_err_msg, "11111100"b) ; /* Get the pathname prefix and, if necessary, the UMC name. */ multics_path = save_data.pathname_prefix ; stop = "0"b ; i = 1 ; call Get_Name_Component () ; if ^save_data.skip_umc then do ; multics_path = multics_path || ">" || cfname ; end ; /* Process the remaining catalog(s)/file(s). */ do while (^stop) ; call Get_Name_Component () ; multics_path = multics_path || ">" || cfname ; end ; /* Report the absolute Multics pathname developed. */ call ioa_$rs ("Comment: Multics pathname is ^a", err_msg, err_msg_len, multics_path) ; if gcos_ext_stat_$save_data.long then call ioa_$nnl ("^a", var_err_msg) ; call gcos_write_$ascii_ptr (gcos_ext_stat_$er, var_err_msg, "11111100"b) ; /* Prepare to return by setting the return values. */ a_multics_path = multics_path ; path_len = length (multics_path) ; exit: return ; Get_Name_Component: procedure () ; cat_start = i ; slash = index (substr (gcos_cfdesc, i), "/") ; dollar = index (substr (gcos_cfdesc, i), "$") ; if slash = 0 then do ; stop = "1"b ; slash = length (gcos_cfdesc)+2-i ; end ; if dollar = 0 then dollar = slash ; if dollar < slash then cat_len = dollar-1 ; else cat_len = slash-1 ; if cat_len = 0 then call gcos_error_ (gcos_et_$cc_bad_field, "Catalog/filename element is null.^/^a^2x^a", gcos_ext_stat_$card_num, card); i = i+slash ; if substr (gcos_cfdesc, cat_start, 1) = "#" then do; if cat_len = 1 then cfname = "#"; else if substr (gcos_cfdesc, cat_start+1, 1) = "#" then cfname = substr (gcos_cfdesc, cat_start+1, cat_len-1); else do; param_num = cv_dec_check_ (substr (gcos_cfdesc, cat_start+1, cat_len-1), code); if code ^= 0 then call gcos_error_ (gcos_et_$cc_bad_field, "Parameter numbers must be decimal constants. ""^a""^/^a^2x^a", substr (gcos_cfdesc, cat_start, cat_len), gcos_ext_stat_$card_num, card); if param_num < lbound (save_data.param, 1) | param_num > hbound (save_data.param, 1) then call gcos_error_ (gcos_et_$cc_bad_field, "Parameter number values must be from ^d to ^d.^/^a^2x^a", lbound (save_data.param, 1), hbound (save_data.param, 1), gcos_ext_stat_$card_num, card); cfname = save_data.param (param_num); end; end; else cfname = substr (gcos_cfdesc, cat_start, cat_len); if length (cfname) > 12 then call gcos_error_ (gcos_et_$cc_bad_field, "Catalog/filename element is longer than 12 characters. ""^a""^/^a^2x^a", cfname, gcos_ext_stat_$card_num, card); cfname = translate (cfname, LOWER_CASE, UPPER_CASE); if verify (cfname, "0123456789abcdefghijklmnopqrstuvwxyz.-") ^= 0 then call gcos_error_ (gcos_et_$cc_bad_field, "Catalog/filename element contains illegal character. ""^a""^/^a^2x^a", cfname, gcos_ext_stat_$card_num, card); return ; end Get_Name_Component ; %include gcos_ext_stat_ ; end gcos_interpret_file_string_ ;  gcos_open_file_.pl1 09/09/83 1400.3rew 09/09/83 1007.1 58248 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_open_file_: proc (filecode, lud, newfib, present); /* This procedure will initialize a fib (file info block) and return a pointer to it. If called with a non-null lud (logical unit designator), a search is made for an existing fib with a matching lud. If a match is found, a pointer to that lud is returned and the "present" argument is set on. If called with a file code, an entry is made in the file code table pointing to the fib. If the file code is already entered in the file code table, it is removed. The sysout entry to this routine places the requested file code in a file code table entry, sets the sysout and dac flags, but does not allocate a fib. INPUT PARAMETERS: = file_code 2 character file code of file to be opened. = lud 2 or 3 character logical unit designator. OUTPUT PARAMETERS: = fibptr pointer to fib assigned to opened file. = present set to 1 if file was already open. Author: DICK SNYDER AUGUST 7, 1970 Change: T. CASEY JULY 1973, FEBRUARY 1974 Change: D. KAYDEN MAY 1974, MARCH 1975 Change: M. R. Jordan, October 1977 Change: Mel Wilson, November 1979 for gtss compatibility Change: Dave Ward 09/13/81 structured. */ dcl dac_sw bit(1)parm /* dac/sysout switch */; dcl filecode char(*)parm /* file code of file to be opened */; dcl lud char(*)parm /* logical unit designator of file */; dcl newfib ptr parm /* returns pointer to found fib */; dcl present bit(1)parm /* set to 1 if file open already */; sysout_call = "0"b; if filecode = "" then goto no_fc; goto common; sysout: entry (filecode, dac_sw); sysout_call = "1"b; common: ; do fctno = 1 to hbound (save_data.fibs, 1); /* search for matching file code */ if fct.filecode (fctno) = filecode then go to fc_hit; end; do fctno = 1 to hbound (save_data.fibs, 1); /* no match on file codes */ if fct.filecode (fctno) = "" then go to set_fc; /* find an unused entry */ end; call gcos_error_ (gcos_et_$no_free_fibs); /* bad news */ fc_hit: ; if fct.sysout (fctno) then go to set_fc; /* check for sysout file code */ fibptr = fct.fibptr (fctno); /* save pointer to fib */ fct.fibptr (fctno) = null (); /* detach file code from fib */ do i = 1 to hbound (save_data.fibs, 1); /* see if this fib has any file codes left */ if fct.filecode (i) ^= "" & ^fct.sysout (i) then if fct.fibptr (i) = fibptr then go to set_fc; /* yes - leave file alone */ end; if ^fib.gein & fib.attached then do; /* if file was saved from a previous activity, */ fib.disp = "10"b; /* then restore its disposition and save it */ go to set_fc; end; if fib.attached then call gcos_close_file_ (fibptr); /* detach if attached */ else fib.used = "0"b; set_fc: ; fct.filecode (fctno) = filecode; if sysout_call then do; fct.sysout (fctno) = "1"b; /* set sysout flag */ fct.dac (fctno) = dac_sw; /* set dac flag from parameter */ return; /* done */ end; fct.sysout (fctno) = "0"b; no_fc: ; if lud ^= "" then do; asc_lud = lud; /* conversion routine requires aligned string */ call gcos_cv_ascii_gebcd_ (addr (asc_lud), length (asc_lud), addr (bcd_lud), i); end; do i = 1 to hbound (save_data.fibs, 1); fibptr = addr (save_data.fibs (i)); if bcd_lud ^= "0"b & fib.used then if fib.plud = bcd_lud then do; /* fib with matching lud found */ newfib = fibptr; /* set return pointer to this fib */ present = "1"b; /* indicate not a new file */ go to lud_hit; end; if ^fib.used & sw then do; /* find an available fib */ sw = "0"b; /* yes. set sw to indicate available fib found */ newfib = fibptr; /* set return pointer to this fib */ end; /* continue search */ end; if sw then call gcos_error_ (gcos_et_$no_free_fibs); /* fatal error if no available fib */ present = "0"b; /* indicate fib newly opened */ fibptr = newfib; /* reset fib pointer to found fib */ string (fib.indicators) = "0"b; /* clear fib.indicators */ fib.disp = "01"b; /* default disp release */ fib.used = "1"b; /* set fib used */ fib.pathnm = " "; /* blank pathname */ fib.unique_file_id = "0"b; /* multics unique segment id for multi-user control */ fib.command_index = 0; /* init for mme_inos_ */ fib.buffer = null (); /* set pointer to null */ fib.size = 0; /* init file size */ fib.init_size = 0; fib.current = 0; /* set file in rewound position */ fib.slud = "0"b; /* clear log.unit desigs */ fib.plud = bcd_lud; fib.stream = " "; /* blank attach name */ lud_hit: ; if filecode ^= "" then fct.fibptr (fctno) = fibptr; /* set fib pointer in file code entry */ if dbs_open_file then do; if lud = "" then call ioa_ ("gcos_open_file_ fc=^a, fibnewfib=^p", filecode, newfib); else call ioa_ ("gcos_open_file_ fc=^a, fibnewfib=^p, lud=^a ^[^;not^] present", filecode, newfib, lud, present); end; return; /* all done */ %page; /* Variables for gcos_open_file_: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl addrel builtin; dcl asc_lud char(3) aligned; dcl bcd_lud bit(18) aligned init ("0"b); dcl fctno fixed bin(17); dcl gcos_close_file_ ext entry (pointer); dcl gcos_cv_ascii_gebcd_ ext entry (ptr, fixed bin(24), ptr, fixed bin); dcl gcos_error_ entry options (variable); dcl gcos_et_$no_free_fibs fixed bin(35) ext; dcl hbound builtin; dcl i fixed bin(17); dcl ioa_ ext entry options (variable); dcl length builtin; dcl null builtin; dcl size builtin; dcl string builtin; dcl sw bit(1) initial ("1"b) /* switch used in fib search */; dcl sysout_call bit(1); %page; %include gcos_ext_stat_; %page; %include gcos_dbs_names; end gcos_open_file_;  gcos_print_call_.pl1 09/09/83 1400.3rew 09/09/83 1007.1 52101 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_print_call_: proc; /* Print the input arguments (strings) on error_output stream with the following considerations: strings containing "|" are justified and information after the "|" are folded under this character, e.g., abc | stuff xxx d | more stuff Author: Dave Ward 06/05/81 (from print_calling_sequence_ 02/02/81). */ ll = get_line_length_$stream ("error_output", code); call cu_$arg_count (na, code); mm = 0; /* Set initial max m. */ /* Obtain parameter information. */ do i = 1 to na while (i <= hbound (a, 1)); call cu_$arg_ptr (i, p (i), l (i), code); if code ^= 0 then do; call com_err_ ( code , "gcos_print_call_" , "Arg ^i" , i ); return; end; /* Measure for | location. */ m (i) = index (argi, "|"); mm = max (mm, m (i)); end; /* Print the strings. */ do i = 1 to (i-1); if (m (i) = 0) | (mm > (ll-5)) then do; /* Either no |, or | too far to the right (a Reagen bar). */ if length (argi) <= ll then /* Not more than ll characters to print. */ call out (argi); else /* More than ll characters to print. */ call fold (argi); end; else do; /* String contains |. */ call out (substr (argi, 1, m (i)-1)); if m (i)m (i) then /* There are characters after the |. */ call pr_rest (after_bar); end; call out (NL); end; fail: ; return; %page; fold: proc (s); /* Output ll characters, break on space, fold remainder. */ dcl s char(*)parm; if length (s) <= ll then do; call out (s); return; end; k = search (reverse (substr (s, 1, ll)), " ,"); if k>0 then do; l = length (rtrim (substr (s, 1, ll-k+1))); if l>0 then do; call out (substr (s, 1, l)); call out (NL); end; l = ll - (k-1) + 1; /* Location 1st character of remainder. */ if (length (s)-l+1)>ll then call fold (substr (s, l)); else do; /* Right justify final piece. */ call out (substr ((100)" ", 1, ll- (length (s)-l+1))); call out (substr (s, l)); end; return; end; /* No blanks in string. */ call out (substr (s, 1, ll)); call out (NL); call fold (substr (s, ll+1)); return; dcl k fixed bin(24); dcl l fixed bin(24); end fold; %page; out: proc (s); /* Print string "s". */ dcl s char(*)parm; call iox_$put_chars ( iox_$error_output , addr (s) , length (s) , code ); if code ^= 0 then do; call com_err_ ( code , "gcos_print_call_" , "String ""^a""" , s ); goto fail; end; return; end out; %page; pr_rest: proc (s); /* Print the string "s" as the rest of the string after |. */ dcl s char(*)parm; call out (" "); l = ll-mm-2; /* Print characters available. */ pl = length (s); if pl <= l then do; /* Not more than ll characters to print. */ call out (s); return; end; /* More than ll characters, print up to ll characters on this line and fold the remainder. */ k = search (reverse (substr (s, 1, l)), " ,"); if k = 0 then do; /* No space or comma found. */ call out (substr (s, 1, l)); fc = l+1; ln = pl-l; if ln<1 then return; end; else do; /* Print up to space. */ call out (rtrim (substr (s, 1, l-k+1))); fc = l-k+2; ln = pl-fc+1; if ln<1 then return; end; call out (NL); call out (substr ((100)" ", 1, mm-1)); call out (" |"); call pr_rest (substr (s, fc, ln)); return; dcl fc fixed bin(24); dcl k fixed bin(24); dcl l fixed bin(24); dcl ln fixed bin(24); dcl pl fixed bin(24); end pr_rest; %page; /* Variables for gcos_print_call_: */ /* IDENTIFIER ATTRIBUTES */ dcl after_bar char(l(i)-m(i))unal based(addr(ari(m(i)+1))) /* i-th argument, characters after |. */; dcl argi char(l(i))unal based(p(i)) /* i-th argument, character string. */; dcl ari (l(i))char(1)unal based(p(i)) /* i-th argument, array of characters. */; dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl cu_$arg_count entry (fixed bin, fixed bin(35)); dcl cu_$arg_ptr entry (fixed bin(24), ptr, fixed bin(21), fixed bin(35)); dcl get_line_length_$stream entry (char(*), fixed bin(35)) returns(fixed bin); dcl hbound builtin; dcl i fixed bin(24); dcl index builtin; dcl iox_$error_output ptr ext static; dcl iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)); dcl ll fixed bin(24); dcl max builtin; dcl min builtin; dcl mm fixed bin(24); dcl na fixed bin(17); dcl reverse builtin; dcl search builtin; dcl substr builtin; dcl NL char(1)static int options(constant)init(" "); dcl 1 a (64)aligned , 2 p ptr , 2 l fixed bin(21) , 2 m fixed bin ; end gcos_print_call_;  gcos_process_mme_.pl1 09/09/83 1400.3rew 09/09/83 1007.1 165834 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_process_mme_: proc (mcp, fault_name, dummy1, dummy2, continue); /* This procedure is called by sct_manager_ when a MME1 condition is raised in the current ring. This procedure will make sure the MME1 is in the GCOS slave segment and then process it. The faulting instruction (MME1) is located in the machine conditions, and is examined for request type (as given in the computed address by a number from 1 to 44). The type is looked up in a table and the appropriate MME handler is called with a ptr to the machine conditions. When the MME handler returns, this procedure will modify the machine conditions to force a transfer to the proper location, skipping over any parameter words that followed the MME, and then it will return, causing the modified machine conditions to be restored and the execution of the slave program to be resumed. */ %page; /* *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* HISTORY *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* Author: DICK SNYDER OCT 1,1970 Change: T. CASEY FEB 1974, AUG 1974 Change: D. KAYDEN MAR 1975 Change: T. CASEY AUG 1975 Change: M. R. Jordan JAN 1977, JUL 1977 Change: A. N. Kepner MAR 1978 To allow courtesy call I/O within cc routines Change: Dave Ward 06/09/81 Reorganized. Debug entries updated. Change: Dave Ward 09/09/81 Replaced use of ALM vector (gcos_call_mme_processor_) with "goto mp." Change: Scott C. Akers 11/28/81 Obtain MME number from even instruction in all cases. Change: Ron Barstad 83-08-04 Added MMEs 41-44 for 4js3 */ %page; /* This procedure is called as a static handler for the condition MME1 in the current ring. After making sure the MME is in the GCOS segment and initializing some data items we can get down to the business at hand - processing the MME. */ debugsw = dbs_stop_mme | dbs_trace_mme | watchsw ; scup = addr (mc.scu); if substr (baseno (gcos_ext_stat_$gcos_slave_area_seg), 4, 15) ^= scu.ppr.psr then do; if gcos_ext_stat_$sig_ptr ^= null () then call cu_$ptr_call (gcos_ext_stat_$sig_ptr, mcp, fault_name, dummy1, dummy2, continue); return; end; else continue = "0"b; unspec (gcos_ext_stat_$mc) = unspec (mc); %page; mme_number = even_instruction.MME_NO; %page; /* Check to see if the MME number is within acceptable range. If not abort the user. */ if mme_number < lbound (MME_NAME, 1) | mme_number > hbound (MME_NAME, 1) then call gcos_mme_bort_$system ( gcos_et_$bad_mme_addr , "^i is not a valid MME number (^i to ^i)." , mme_number , lbound (MME_NAME, 1) , hbound (MME_NAME, 1) ); /* If we are within a courtesy call, verify that this MME is a valid one for courtesy calls. If not, report the system detected error. */ if gcos_ext_stat_$save_data.cc then if ^mme_table (mme_number) then call gcos_mme_bort_$system ( gcos_et_$bad_mme_in_cc , "MME GE^a is not allowed within a courtesy call." , MME_NAME (mme_number) ); /* Now that we are fairly certain that this is a valid MME (in the right range, anyway), we will initialize the increment and call the MME processor routine. If the debug switch is on, tracing information will be displayed. If this is not a supported MME, the entry gcos_mme_bort_$not_imp will be called to report the error to the user. */ increment = 0; if debugsw then call debug_1 (); /* Now call the appropriate MME processor via the transfer vector in gcos_call_mme_processor_. */ goto mp (mme_number); mp(11):; /** MME GEFILS 11 **/ mp(16):; /** MME GESPEC 16 **/ mp(25):; /** MME GEROLL 25 **/ mp(29):; /** MME GEIDSE 29 **/ mp(30):; /** MME .EMM 30 **/ mp(35):; /** MME GENEWS 35 **/ mp(36):; /** MME GESNUM 36 **/ mp(38):; /** MME GESECR 38 **/ mp(39):; /** MME GEXLIT 39 **/ mp(40):; /** MME xxxxxx 40 **/ mp(41):; /** MME xxxxxx 41 **/ mp(42):; /** MME xxxxxx 42 **/ mp(43):; /** MME GMODES 43 **/ mp(44):; /** MME GMODER 44 **/ call gcos_mme_bort_$not_imp (mcp, increment, mme_number); goto return_from_mp; mp( 1):; /** MME GEINOS 1 **/ call gcos_mme_inos_$gcos_mme_inos_ (mcp, increment); goto return_from_mp; mp( 2):; /** MME GEROAD 2 **/ goto return_from_mp; mp( 3):; /** MME GEFADD 3 **/ call gcos_mme_fadd_$gcos_mme_fadd_ (mcp, increment); goto return_from_mp; mp( 4):; /** MME GERELS 4 **/ call gcos_mme_rels_$gcos_mme_rels_ (mcp, increment); goto return_from_mp; mp( 5):; /** MME GESNAP 5 **/ call gcos_mme_snap_$gcos_mme_snap_ (mcp, increment); goto return_from_mp; mp( 6):; /** MME GELAPS 6 **/ call gcos_mme_laps_$gcos_mme_laps_ (mcp, increment); goto return_from_mp; mp( 7):; /** MME GEFINI 7 **/ call gcos_mme_fini_$gcos_mme_fini_ (mcp, increment); goto return_from_mp; mp( 8):; /** MME GEBORT 8 **/ call gcos_mme_bort_$gcos_mme_bort_ (mcp, increment); goto return_from_mp; mp( 9):; /** MME GEMORE 9 **/ call gcos_mme_more_$gcos_mme_more_ (mcp, increment); goto return_from_mp; mp(10):; /** MME GEFCON 10 **/ call gcos_mme_fcon_$gcos_mme_fcon_ (mcp, increment); goto return_from_mp; mp(12):; /** MME GESETS 12 **/ call gcos_mme_sets_$gcos_mme_sets_ (mcp, increment); goto return_from_mp; mp(13):; /** MME GERETS 13 **/ call gcos_mme_rets_$gcos_mme_rets_ (mcp, increment); goto return_from_mp; mp(14):; /** MME GEENDC 14 **/ call gcos_mme_inos_$mme_endc (mcp, increment); goto return_from_mp; mp(15):; /** MME GERELC 15 **/ goto return_from_mp; mp(17):; /** MME GETIME 17 **/ call gcos_mme_time_$gcos_mme_time_ (mcp, increment); goto return_from_mp; mp(18):; /** MME GECALL 18 **/ call gcos_mme_call_$gcos_mme_call_ (mcp, increment); goto return_from_mp; mp(19):; /** MME GESAVE 19 **/ call gcos_mme_save_$gcos_mme_save_ (mcp, increment); goto return_from_mp; mp(20):; /** MME GERSTR 20 **/ call gcos_mme_call_$mme_rstr (mcp, increment); goto return_from_mp; mp(21):; /** MME GEMREL 21 **/ call gcos_mme_mrel_$gcos_mme_mrel_ (mcp, increment); goto return_from_mp; mp(22):; /** MME GESYOT 22 **/ call gcos_mme_syot_$gcos_mme_syot_ (mcp, increment); goto return_from_mp; mp(23):; /** MME GECHEK 23 **/ call gcos_mme_chek_$gcos_mme_chek_ (mcp, increment); goto return_from_mp; mp(24):; /** MME GEROUT 24 **/ call gcos_mme_rout_$gcos_mme_rout_ (mcp, increment); goto return_from_mp; mp(26):; /** MME GEUSER 26 **/ call gcos_mme_user_$gcos_mme_user_ (mcp, increment); goto return_from_mp; mp(27):; /** MME GELOOP 27 **/ call gcos_mme_loop_$gcos_mme_loop_ (mcp, increment); goto return_from_mp; mp(28):; /** MME GEWAKE 28 **/ call gcos_mme_wake_$gcos_mme_wake_ (mcp, increment); goto return_from_mp; mp(31):; /** MME GELBAR 31 **/ call gcos_mme_lbar_$gcos_mme_lbar_ (mcp, increment); goto return_from_mp; mp(32):; /** MME GEFRCE 32 **/ call gcos_mme_frce_$gcos_mme_frce_ (mcp, increment); goto return_from_mp; mp(33):; /** MME GEFSYE 33 **/ call gcos_mme_fsye_$gcos_mme_fsye_ (mcp, increment); goto return_from_mp; mp(34):; /** MME GEPRIO 34 **/ call gcos_mme_prio_$gcos_mme_prio_ (mcp, increment); goto return_from_mp; mp(37):; /** MME GEINFO 37 **/ call gcos_mme_info_$gcos_mme_info_ (mcp, increment); return_from_mp: ; if debugsw then call debug_2 (); /* Now modify the machine conditions to skip the MME and any arguments to it. This is accomplished by modifying the IC (scu.ilc) and forcing the processor to refetch the instruction pair. */ instruction_counter = instruction_counter + increment +1; scu.rfi = "1"b; /* Refetch faulted instruction. */ scu.if = "1"b; /* Turn on indicator that instruction faulted. */ return; %page; mme_trace: entry (arg_string); /* Set MME trace list, and/or display it. */ dcl arg_string char(*)parm; mlp = addr (mme_trace_list); /* Select trace list as the MME list. */ trace_or_stop = "1"b; /* Trace entry. */ goto continue_db; mme_stop: entry (arg_string); /* Set MME stop list, and/or display it. */ mlp = addr (mme_stop_list); /* Select stop list as the MME list. */ trace_or_stop = "0"b; /* Stop entry. */ continue_db: ; on_or_off = "1"b; /* On by default. */ do i = 1 by 1; if next_arg (i, ap, al) then do; /* No more arg_string "arguments". */ if i = 1 then /* There were no arguments => set all values on. */ mme_list = "1"b; dbs_trace_mme = (string (mme_trace_list) ^= "0"b); dbs_stop_mme = (string (mme_stop_list) ^= "0"b); return; end; /* Examine the next argument. */ if arg = "-all" then do; /* Set the whole list to current on or off value. */ mme_list = on_or_off; goto get_arg; end; if arg = "-on" then do; /* Set on or off value to on. */ on_or_off = "1"b; goto get_arg; end; if arg = "-off" then do; /* Set on of off value to off. */ on_or_off = "0"b; goto get_arg; end; if (arg = "-pr") | (arg = "-print") then do; /* Display the list. */ if string (mme_list) = "0"b then /* Whole list is off. */ call ioa_ ("MME ^[trace^;stop^] is off for all MME's.", trace_or_stop); else if (^string (mme_list)) = "0"b then /* Whole list is on. */ call ioa_ ("MME ^[trace^;stop^] is on for all MME's.", trace_or_stop); else do; /* Display specific entries that are on. */ call ioa_ ("MME ^[trace^;stop^] is on for:", trace_or_stop); do j = 1 to hbound (mme_list, 1); if mme_list (j) then call ioa_ ("(^2i) ^a", j, MME_NAME (j)); end; end; goto get_arg; end; if verify (arg, "0123456789") = 0 then do; /* => MME number. */ j = fixed (arg, 17); /* Obtain MME number as binary. */ if j < lbound (mme_list, 1) then do; call com_err_ ( /* Debug trace MME number out of range. */ 0 , "gcos_process_mme_" , "^/Arg ^i, ^i, MME number out of range ^i to ^i." , i , j , lbound (mme_list, 1) , hbound (mme_list, 1) ); goto get_arg; end; goto found_mme_name; end; /* => arg is a MME name (lookup in name table). */ arg_uc = translate ( /* Convert lower to upper case. */ arg , "ABCDEFGHIJKLMNOPQRSTUVWXYZ" , "abcdefghijklmnopqrstuvwxyz" ); do j = lbound (MME_NAME, 1) to hbound (MME_NAME, 1); if arg_uc = MME_NAME (j) then goto found_mme_name; end; call com_err_ ( /* Debug trace MME number out of range. */ 0 , "gcos_process_mme_" , "^/Arg ^i, ""^a"", unknown MME name (^a^( ^a^))." , i , arg , MME_NAME (*) ); goto get_arg; found_mme_name: ; mme_list (j) = on_or_off; get_arg: ; end; %page; watcher: entry (address); dcl address char(*)parm; if address = "" then do; watchsw = "0"b; call ioa_ ("watcher off"); go to debug_return; end; watch_address = cv_oct_check_ (address, code); if code ^= 0 then do; call ioa_ ("bad address"); go to debug_return; end; watchp = null (); watchsw = "1"b; watch_contents = 0; call ioa_ ("watcher on"); debug_return: return; %page; %include gcos_next_arg; %page; debug_1: procedure (); mme_statistics.count (mme_number) = mme_statistics.count (mme_number) + 1; /* bump usage count */ if dbs_stop_mme then if mme_stop_list (mme_number) then goto print_mme; /* print its name and location, whether or not trace is on for it */ if dbs_trace_mme then if mme_trace_list (mme_number) then print_mme: call ioa_ ("MME ^2d GE^a at ^6o", mme_number, MME_NAME (mme_number), fixed (scu.ilc, 18)); if watchsw then do; if watchp = null then watchp = addrel (gcos_ext_stat_$gcos_slave_area_seg, watch_address); if watchee ^= watch_contents then do; watch_contents = watchee; call ioa_ ("loc ^o changed to ^w before MME ^a. last MME was ^a", watch_address, watch_contents, (mme_number), (gcos_ext_stat_$last_mme)); end; end; stopped = "0"b; if dbs_stop_mme then if mme_stop_list (mme_number) then do; call ioa_ ("CALLING DB"); stopped = "1"b; call db; end; initial_cpu_time = virtual_cpu_time_ (); end debug_1; %page; debug_2: procedure (); mme_statistics.total_time (mme_number) = mme_statistics.total_time (mme_number) + virtual_cpu_time_ ()- initial_cpu_time; /* count total time used by a MME */ if watchsw then if watchee ^= watch_contents then do; watch_contents = watchee; call ioa_ ( "loc ^6.3b changed to ^w after MME ^a" , unspec (watch_address) , watch_contents , MME_NAME (mme_number) ); end; if stopped then do; call ioa_ ( "returned from MME ^a processor. CALLING DB" , MME_NAME (mme_number) ); call db; end; gcos_ext_stat_$last_mme = mme_number; end debug_2; %page; /* Variables for gcos_process_mme_: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl addrel builtin; dcl al fixed bin(24); dcl ap ptr; dcl arg char(al)unal based(ap); dcl arg_uc char(100)var; dcl baseno builtin; dcl code fixed bin(35); dcl com_err_ entry() options(variable); dcl continue bit(1) aligned; dcl cu_$ptr_call entry options (variable); dcl cv_dec_check_ entry (char(*), fixed bin(35)) returns (fixed bin(35)); dcl cv_oct_check_ entry (char(*), fixed bin(35)) returns (fixed bin(35)); dcl db entry; dcl debugsw bit(1); dcl dummy1 ptr; dcl dummy2 ptr; dcl fault_name char(*); dcl fixed builtin; dcl gcos_et_$bad_mme_addr fixed bin(35) ext; dcl gcos_et_$bad_mme_in_cc fixed bin(35) ext; dcl gcos_mme_bort_$gcos_mme_bort_ entry (ptr, fixed bin(24)); dcl gcos_mme_bort_$not_imp entry (ptr, fixed bin(24), fixed bin(17)); dcl gcos_mme_bort_$system entry options (variable); dcl gcos_mme_call_$gcos_mme_call_ entry (ptr, fixed bin(24)); dcl gcos_mme_call_$mme_rstr entry (ptr, fixed bin(24)); dcl gcos_mme_chek_$gcos_mme_chek_ entry (ptr, fixed bin(24)); dcl gcos_mme_fadd_$gcos_mme_fadd_ entry (ptr, fixed bin(24)); dcl gcos_mme_fcon_$gcos_mme_fcon_ entry (ptr, fixed bin(24)); dcl gcos_mme_fini_$gcos_mme_fini_ entry (ptr, fixed bin(24)); dcl gcos_mme_frce_$gcos_mme_frce_ entry (ptr, fixed bin(24)); dcl gcos_mme_fsye_$gcos_mme_fsye_ entry (ptr, fixed bin(24)); dcl gcos_mme_info_$gcos_mme_info_ entry (ptr, fixed bin(24)); dcl gcos_mme_inos_$gcos_mme_inos_ entry (ptr, fixed bin(24)); dcl gcos_mme_inos_$mme_endc entry (ptr, fixed bin(24)); dcl gcos_mme_laps_$gcos_mme_laps_ entry (ptr, fixed bin(24)); dcl gcos_mme_lbar_$gcos_mme_lbar_ entry (ptr, fixed bin(24)); dcl gcos_mme_loop_$gcos_mme_loop_ entry (ptr, fixed bin(24)); dcl gcos_mme_more_$gcos_mme_more_ entry (ptr, fixed bin(24)); dcl gcos_mme_mrel_$gcos_mme_mrel_ entry (ptr, fixed bin(24)); dcl gcos_mme_prio_$gcos_mme_prio_ entry (ptr, fixed bin(24)); dcl gcos_mme_rels_$gcos_mme_rels_ entry (ptr, fixed bin(24)); dcl gcos_mme_rets_$gcos_mme_rets_ entry (ptr, fixed bin(24)); dcl gcos_mme_rout_$gcos_mme_rout_ entry (ptr, fixed bin(24)); dcl gcos_mme_save_$gcos_mme_save_ entry (ptr, fixed bin(24)); dcl gcos_mme_sets_$gcos_mme_sets_ entry (ptr, fixed bin(24)); dcl gcos_mme_snap_$gcos_mme_snap_ entry (ptr, fixed bin(24)); dcl gcos_mme_syot_$gcos_mme_syot_ entry (ptr, fixed bin(24)); dcl gcos_mme_time_$gcos_mme_time_ entry (ptr, fixed bin(24)); dcl gcos_mme_user_$gcos_mme_user_ entry (ptr, fixed bin(24)); dcl gcos_mme_wake_$gcos_mme_wake_ entry (ptr, fixed bin(24)); dcl hbound builtin; dcl i fixed bin(24); dcl ia fixed bin(24); dcl increment fixed bin(24); dcl initial_cpu_time fixed bin(71); dcl instruction_counter fixed bin(18)unsigned unal based(addr(scu.ilc)); dcl ioa_ entry options (variable); dcl j fixed bin(24); dcl lbound builtin; dcl mlp ptr; dcl mme_list (44)bit(1)unal based(mlp); dcl mme_number fixed bin(17) /* holds mme type */; dcl mme_stop_list (44) bit(1) unal int static init ((44) (1)"0"b); dcl mme_trace_list (44) bit(1) unal int static init ((44) (1)"0"b); dcl null builtin; dcl on_or_off bit(1); dcl on_sw bit(1) aligned static init ("0"b); dcl previous_instr_ptr ptr; dcl previous_opcode bit(9); dcl state char(3); dcl stopped bit(1) aligned; dcl substr builtin; dcl trace_or_stop bit(1); dcl translate builtin; dcl unspec builtin; dcl verify builtin; dcl virtual_cpu_time_ entry () returns (fixed bin(71)); dcl watchee fixed bin(24)based (watchp); dcl watchp ptr static; dcl watchsw bit(1) static init ("0"b); dcl watch_address fixed bin(24)static; dcl watch_contents fixed bin(35) static; dcl XED bit(9) internal static options (constant) init ("111001111"b); dcl 1 even_instruction aligned based(addr(scu.even_inst)) like machine_instruction; dcl 1 odd_instruction aligned based(addr(scu.odd_inst)) like machine_instruction; dcl 1 machine_instruction aligned based ,2 MME_NO fixed bin(17)unal ,2 OPCODE bit(10)unal ,2 II bit(1)unal /* Interrupt inhibit. */ ,2 A bit(1)unal /* Indirect via pointer register flag. */ ,2 TAG bit(6) /* Instruction address modification. */ ; dcl 1 mme_statistics based (addr (gcos_ext_stat_$statistics)), /* overlay */ 2 total_time (44) fixed bin(71), 2 count (44) fixed bin(17); %page; %include gcos_mme_names; %page; %page; %include gcos_dbs_names; %include gcos_ext_stat_; end gcos_process_mme_;  gcos_read_card_.pl1 09/09/83 1400.3rew 09/09/83 1007.1 68706 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_read_card_: proc (return_gcos_ptr, return_gcos_len, return_ascii_card, return_dollar_sw); /* * This procedure is called to read a card from the gcos job stream file. * * It returns: * 1) a pointer to the (rcw of the) gcos format record (bcd or binary); * 2) the length, in ascii characters, (i.e. 4 times length in words) * of the record, including the rcw. (This is to provide a convenient * interface with gcos_write_, which is called with a char(*) argument, * even when writing a gcos record.) * * * If the card is a $ control card, it returns the ascii image (80 * characters, padded with blanks, and NOT ending in a newline), and a "1"b in * dollar_sw; otherwise, it returns "0"b in dollar_sw, and blanks in the ascii image. * * If end of file occurs on gcos_job_stream_, it calls gcos_error_ to abort the * job: a $ ENDJOB card should end the deck, and no more calls should be made * after that card is read. * * If the job stream file is small enough to be a segment, rather than a msf, it * is initiated, and "read" by moving a pointer through it, instead of * being read by ios_$read, in order to save time. * * Author: T. CASEY APRIL 1973 Change: T. CASEY FEBRUARY 1974 Change: D.KAYDEN MARCH 1975 Change: M. R. Jordan, August 1977 Change: Dave Ward 08/11/81 Reorganized. */ dcl return_gcos_len fixed bin(24)parm /* returned length of gcos record */; dcl return_gcos_ptr ptr parm /* returned pointer to gcos record */; return_dollar_sw = "0"b; /* turn off "this is dollar card" switch */ return_ascii_card = ""; /* and blank out the ascii card image */ save_data.jd_rem_block_len = remaining_block_len; save_data.jd_position = block_position; reread: ; /* come here to read bcd dollar card, if we just read ascii copy of it */ if remaining_block_len = 0 then do; /* if no more records in this block */ /* get next one */ block_position = block_position + 320; if msf then do; /* if this is a msf */ record_ptr = addr (buffer); call ios_$read ("gcos_job_stream_", record_ptr, 0, 320, words_read, status); if code ^= 0 then do; err_msg = "from ios_$read ^a"; read_error: ; call gcos_error_ (code, err_msg, "gcos_job_stream_", err_num); end; end; else do; /* must be a segment */ record_ptr = addrel (save_data.job_deck, block_position); words_read = min (320, save_data.jd_size - block_position); end; if words_read < 320 then do; if words_read = 0 then do; /* but if there are no more blocks to get */ eof_error: ; code = 0; /* should never happen. complain */ err_msg = "end of file on ^a"; goto read_error; end; code = 0; err_num = words_read; err_msg = "ios_$read ^a returned ^d words"; goto read_error; end; /* get first record of block */ remaining_block_len = fixed (bcw.length); /* initialize block length from bcw */ if remaining_block_len > 319 then do; code = 0; err_num = remaining_block_len; err_msg = "block from ^a contained ^d words"; goto read_error; end; record_ptr = addrel (record_ptr, 1); end; /* process record */ if rcw.eof = bcd_eof then goto eof_error; /* should never happen */ record_len = fixed (rcw.length); remaining_block_len = remaining_block_len - record_len - 1; if remaining_block_len < 0 then do; /* should never happen */ code = 0; err_num = remaining_block_len; err_msg = "^a remaining_block_len negative: ^d"; goto read_error; end; if rcw.media_code = "0110"b then do; /* if ascii record */ if return_dollar_sw then do; /* should never happen */ code = 0; err_msg = "two consecutive ascii records from ^a"; goto read_error; end; return_ascii_card = ascii_record.chars; /* copy ascii card into argument from caller */ return_dollar_sw = "1"b; /* remember that we read a dollar card */ record_ptr = addrel (record_ptr, record_len + 1); goto reread; /* go read the bcd image of this card */ end; return_gcos_ptr = record_ptr; /* must be a regular gcos record */ return_gcos_len = (record_len + 1) * 4; record_ptr = addrel (record_ptr, record_len + 1); if gcos_ext_stat_$card_num = 9999 then gcos_ext_stat_$card_num = 0; else gcos_ext_stat_$card_num = gcos_ext_stat_$card_num+1; return; /* normal return */ %page; read_init: entry (restartsw); dcl restartsw bit (1) aligned parm; gcos_ext_stat_$card_num = 0; msf = save_data.job_deck = null; if ^restartsw then do; save_data.jd_position = -320; save_data.jd_rem_block_len = 0; go to init_done; end; /* Restart in process - reposition job stream */ if msf then if save_data.jd_position >= 0 then call ios_$seek ("gcos_job_stream_", "read", "first", save_data.jd_position, status); if save_data.jd_rem_block_len ^= 0 then do; if msf then do; record_ptr = addr (buffer); call ios_$read ("gcos_job_stream_", record_ptr, 0, 320, words_read, status); end; else record_ptr = addrel (save_data.job_deck, save_data.jd_position); record_ptr = addrel (record_ptr, 1 + fixed (bcw.length) - save_data.jd_rem_block_len); end; init_done: ; block_position = save_data.jd_position; remaining_block_len = save_data.jd_rem_block_len; return; %page; /* Variables for gcos_read_card_: */ /* IDENTIFIER ATTRIBUTES */ dcl addr builtin; dcl addrel builtin; dcl bcd_eof bit (6) unaligned int static init ("001111"b); dcl block_position fixed bin(24)int static; dcl buffer (320) bit (36) aligned int static; dcl code fixed bin(35) aligned based (addr (status)); dcl err_msg char (100) aligned; dcl err_num fixed bin(24); dcl fixed builtin; dcl gcos_error_ ext entry options (variable); dcl ios_$read ext entry (char (*), ptr, fixed bin(24), fixed bin(24), fixed bin(24), bit (72) aligned); dcl ios_$seek ext entry (char (*), char (*), char (*), fixed bin(24), bit (72) aligned); dcl min builtin; dcl msf bit (1) aligned int static /* on when file is a msf */; dcl null builtin; dcl record_len fixed bin(24); dcl record_ptr ptr int static; dcl remaining_block_len fixed bin(24)int static; dcl return_ascii_card char (80) parm /* returned ascii image of dollar card */; dcl return_dollar_sw bit (1) parm /* switch on if this is a dollar card */; dcl status bit (72) aligned; dcl words_read fixed bin(24); dcl 1 ascii_record aligned based (record_ptr), 2 rcw bit (36) aligned, 2 chars char (80) unaligned; dcl 1 bcw aligned based (record_ptr), 2 bsn bit (18) unaligned, 2 length bit (18) unaligned; dcl 1 rcw aligned based (record_ptr), 2 length bit (18) unaligned, 2 eof bit (6) unaligned, 2 zeroes bit (2) unaligned, 2 media_code bit (4) unaligned, 2 report_code bit (6) unaligned; %page; %include gcos_ext_stat_; end gcos_read_card_;  gcos_restart_.pl1 09/09/83 1400.3rew 09/09/83 1007.1 67608 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* ********************************************************************# ** * * * Save and Restart Procedure * * * * * * This procedure saves selected data from gcos_ext_stat_ needed * * to restart a GCOS job from the current actvity when a system * * interruption occurs. If an activity restart is specified, * * this procedure restores the necessary data in gcos_ext_stat_. * * * * WRITTEN BY D.A. KAYDEN JANUARY 1975 * * MODIFIED BY D.A. KAYDEN JUNE 1975 * MODIFIED BY R.H. MORRISON JULY 14,1975 * Modified by M. R. Jordan, October 1977 * * ******************************************************************** */ gcos_restart_: proc (n); /* D E C L A R A T I O N S */ %include gcos_ext_stat_; %include gcos_restart_control_; dcl n fixed bin(24)parm; dcl ioa_ ext entry options (variable); dcl size builtin; dcl gcos_attach_file_$reattach ext entry (ptr, fixed bin(35)); dcl gcos_gein_pass1_$job_stream_restart ext entry (fixed bin(35)); dcl gcos_write_$ptr ext entry (ptr, char (*), bit (8)); dcl gcos_write_$force_ptr ext entry (ptr); dcl gcos_error_ ext entry options (variable); dcl gcos_cc_endjob_$restart ext entry; dcl gcos_close_file_ ext entry (pointer); dcl gcos_et_$no_restart fixed bin(35) ext; dcl save_area (size(save_data_entry)) bit (36) aligned based; dcl i fixed bin; dcl code fixed bin(35); dcl 1 flags_copy like flags; dcl no_job_restart bit (1) aligned; dcl NL char (1) int static init (" "); dcl (addr, addrel, null, substr) builtin; /* P R O C E D U R E */ fibptr = addr (save_data.fibs); no_job_restart = "0"b; /* initialize flag */ /* Check for no activity restart */ if restart_control.na_restart /* NREST card option */ | restart_control.cant_do /* can't do activity restart */ then if restart_control.nj_restart /* no job restart - NJREST card option */ | save_data.activity_no = 1 /* no job restart special case */ then do; no_job_restart = "1"b; if ^gcos_ext_stat_$save_data.brief then call ioa_ ("neither activity nor job is restartable"); go to restore; end; else do; n = 4; if ^gcos_ext_stat_$save_data.brief then call ioa_ ("job restarted"); return; end; /* Restore gcos_ext_stat_ */ restore: unspec (flags_copy) = unspec (gcos_ext_stat_$save_data.flgs); /* save the curren flags. */ addr (gcos_ext_stat_$save_data) -> save_area = restart_control.restart_data; /* copy saved data */ flags_copy.snumb = gcos_ext_stat_$save_data.snumb; /* change several current gcos_ext_stat_$save_data to saved values */ flags_copy.ident = gcos_ext_stat_$save_data.flgs.ident; flags_copy.prev_act_abort = gcos_ext_stat_$save_data.prev_act_abort; flags_copy.endjob = gcos_ext_stat_$save_data.endjob; unspec (gcos_ext_stat_$save_data.flgs) = unspec (flags_copy); /* Restore flags. */ fibptr = addr (save_data.fibs); if gcos_ext_stat_$save_data.endjob then go to endjob_restart; /* crashed during endjob processing */ if no_job_restart then go to job_term; /* Activity restart initialization */ do i = 1 to hbound (save_data.fibs, 1); if ^fib.used then go to next_fib; if fib.tape then go to act_fail; /* cannot do activity restart presently if tapes */ /* are saved because we cannot reposition them */ if fib.stream = "sysprint" then gcos_ext_stat_$prt = fibptr; else if fib.stream = "syspunch" then gcos_ext_stat_$pch = fibptr; else if fib.stream = "exec_rpt" then gcos_ext_stat_$er = fibptr; else if fib.stream = "rstar" | substr (fib.stream, 4) = "rstar" then if ^fib.gein then gcos_ext_stat_$rs = fibptr; fib.buffer = null; if fib.attached then do; call gcos_attach_file_$reattach (fibptr, code); if code ^= 0 then go to act_fail; end; next_fib: fibptr = addrel (fibptr, size (fib)); end; call gcos_gein_pass1_$job_stream_restart (code); if code ^= 0 then go to act_fail; /* Activity restart */ call gcos_write_$ptr (gcos_ext_stat_$er, NL, "11111100"b); call gcos_write_$ptr (gcos_ext_stat_$er, "****** system interruption, job restarted here ****** ", "11111100"b); call gcos_write_$ptr (gcos_ext_stat_$er, NL, "11111100"b); call gcos_write_$force_ptr (gcos_ext_stat_$er); if save_data.activity_no = 0 then n = 2; /* restarting at first activity */ else n = 3; /* restarting at later activity */ if ^gcos_ext_stat_$save_data.brief then call ioa_ ("performing activity restart"); return; act_fail: if ^gcos_ext_stat_$save_data.brief then call ioa_ ("activity restart failed, code = ^o", code); job_restart: /* Restart job if card option is JREST; otherwise abort it */ gcos_ext_stat_$save_data.flgs.snumb, gcos_ext_stat_$save_data.flgs.ident, gcos_ext_stat_$save_data.flgs.prev_act_abort, gcos_ext_stat_$save_data.flgs.endjob = "0"b; /* clear gcos_ext_stat_$save_data that may have been set during restart attempt */ if restart_control.nj_restart /* test job restart options */ | save_data.activity_no = 1 then goto job_term; /* terminate job */ else do; /* restart job */ n = 1; if ^gcos_ext_stat_$save_data.brief then call ioa_ ("job restarted"); /* Files that we were able to attach must be detached again - this is done by gcos_gein_ calling gein_cleanup */ return; end; job_term: /* reattach sysout files and terminate job */ do i = 1 to hbound (save_data.fibs, 1); if ^fib.used then go to nextfib; if fib.stream = "sysprint" then gcos_ext_stat_$prt = fibptr; else if fib.stream = "syspunch" then gcos_ext_stat_$pch = fibptr; else if fib.stream = "exec_rpt" then gcos_ext_stat_$er = fibptr; else do; fib.disp = "01"b; call gcos_close_file_ (fibptr); go to nextfib; end; fib.buffer = null; if fib.attached then do; call gcos_attach_file_$reattach (fibptr, code); if code ^= 0 then gcos_ext_stat_$save_data.endjob = "1"b; end; nextfib: fibptr = addrel (fibptr, size (fib)); end; call gcos_write_$ptr (gcos_ext_stat_$er, NL, "11111100"b); call gcos_write_$ptr (gcos_ext_stat_$er, "****** system interruption, job terminated here ****** ", "11111100"b); call gcos_write_$ptr (gcos_ext_stat_$er, NL, "11111100"b); call gcos_write_$force_ptr (gcos_ext_stat_$er); call gcos_error_ (gcos_et_$no_restart); endjob_restart: do i = 1 to hbound (save_data.fibs, 1); /* we must null the buffer pointers */ fib.buffer = null; fibptr = addrel (fibptr, size (fib)); end; if ^gcos_ext_stat_$save_data.brief then call ioa_ ("restarting end of job processing"); call gcos_cc_endjob_$restart; /* does not return here */ /* Entry to save the necessary portions of gcos_ext_stat_ */ save: entry; restart_control.cant_do = "1"b; /* don't try to restart an incomplete save */ restart_control.restart_data = addr (gcos_ext_stat_$save_data) -> save_area; restart_control.saved = "1"b; /* set flag */ restart_control.na_restart = "0"b; /* default card option is REST */ restart_control.cant_do = "0"b; /* save completed */ return; end gcos_restart_;  gcos_restore_regs_.alm 09/09/83 1400.3rew 09/09/83 1007.1 5337 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " declare gcos_restore_regs_ entry(ptr); " Restore registers from 6 word located by ptr. " Dave Ward 09/22/80 name gcos_restore_regs_ segdef gcos_restore_regs_ even gcos_restore_regs_: eppbp ap|2,* " bp->reg save area. lreg bp|0,* " registers<-reg save area. short_return end  gcos_run_activity_.pl1 08/04/87 1725.9r 08/04/87 1541.4 236745 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* **************************************************************************************** ****************************************************************************************** * * * * R U N A G C O S A C T I V I T Y * * * This procedure is called by gcos_gein_ whenever an activity terminating card is read * while an activity is being defined. This procedure will setup to run the activity * specified in gcos_ext_stat_$activity_name. It will receive control when this activity * is completed. At such time, it will clean up, record some accounting information * and return. * * * WRITTEN BY DICK SNYDER SEPTEMBER 10,1970 * MODIFIED BY T. CASEY JUNE 1973, OCTOBER 1973, JANUARY 1974, FEBRUARY 1974, MAY 1974, AUGUST 1974 * MODIFIED BY D. KAYDEN MARCH 1974, APRIL 1974, JUNE 1974, DECEMBER 1974 * MODIFIED BY R.H. MORRISON 75/06/15 * Modified by M. R. Jordan, August 1977 * Modified Ron Barstad 83-11-16 Fix actid format and console msgs * Modified Ron Barstad 83-04-28 Fix precision of time limit divide * change "ACT. TERM." to "NORM TERM" * ****************************************************************************************** **************************************************************************************** */ %page; gcos_run_activity_: proc; if pre_setup_stop_sw then do; call ioa_ ("run_activity_ entered; calling db:"); call db; end; gcos_ext_stat_$save_data.activ = "0"b; /* clear activity being defined sw */ if gcos_ext_stat_$save_data.gtssflag then call gcos_gtss_update_$new_activity (save_data.activity_no, WAIT_PERIPH); /* This loop scans the fibs and does the following things */ /* where indicated: */ /* write eof and rewind gein files */ /* attach unattached files */ /* save initial file size and position */ do i = 1 to hbound (save_data.fibs, 1); if fct.filecode (i) = "" then go to bump; if fct.sysout (i) then go to bump; fibptr = fct.fibptr (i); if fib.gein then do; /* eof and rewind? */ if fib.buffer = null then go to bump; /* bump if no writes done */ call gcos_write_$bcd_ptr (fibptr, "", (8)"0"b); /* write eof */ fib.last = fib.current; call ios_$seek (fib.stream, "read", "first", 0, status); /* reset read ptr */ fib.read = "1"b; /* gein files can only be read */ fib.current = 0; fib.disp = "01"b; /* set disposition to release */ end; if ^fib.attached then call gcos_attach_file_ (fibptr); /* attach file */ fib.init_posit = fib.current; /* save file position */ fib.init_size = fib.size; /* save file size */ bump: end; %page; /* Set up the gcos segment. If it does not exist yet, it will be */ /* created by the file system in the working directory or in the */ /* process directory depending on the control arg. "-nosave". A pointer */ /* to the segment will be kept in internal static so that the seg */ /* need be created only once per process. Once the segment has been */ /* created or located, it is truncated and then its max length */ /* is set to the storage limit for the activity. Thus if the gcos */ /* program attempts to write above its allotted memory, a fault */ /* will occur and the program can be aborted just like in "real" gcos. */ if gcos_ext_stat_$activity_name = "geload" then do; /* activity = "geload" ? */ if gcos_ext_stat_$ldrss ^= 0 then do; /* yes...loader shared stg = 0 ? */ /* If loader shared storage > max for loader, decrease it to this max (22000 octal ) */ /* NOTE that a constant loader size of 9K is built into the code, here */ if gcos_ext_stat_$ldrss > 9*1024 then gcos_ext_stat_$ldrss = 9*1024; /* 9K */ /* Round ldrss down to a multiple of 1K */ i = divide (gcos_ext_stat_$ldrss, 1024, 17, 0); gcos_ext_stat_$ldrss = i*1024; end; /* If ldrss is negative, the above will round its absolute value down to a multiple of 1K. Then, the subtraction below will add its absolute value to the storage limit, which is what is desired when negative loader shared storage is specified */ gcos_ext_stat_$storage_limit = gcos_ext_stat_$storage_limit+9*1024-gcos_ext_stat_$ldrss; /* compute final storage limit */ end; /* Check for storage limit too high */ if gcos_ext_stat_$storage_limit >gcos_ext_stat_$max_mem then /* wants too much core */ call gcos_error_ (0, "slave core limit > max Multics segment size"); gseg = gcos_ext_stat_$gcos_slave_area_seg; if gseg = null then do; call hcs_$make_seg ("", "gcos_slave_area_seg", "", 11, gseg, code); /* create gcos segment */ /* in process directory */ if gseg = null then call gcos_error_ (code, "attempting to create slave segment"); gcos_ext_stat_$gcos_slave_area_seg = gseg; /* save ptr in ext static */ /* Set rewa access on gcos_slave_area_seg */ /* NOTE: eliminate append access ONLY after all existing Multics systems have been upgraded to the version that does not use it */ acla.userid = get_group_id_$tag_star (); /* fill in user id in acl model */ call cu_$level_get (i); /* get validation level */ rb1 = substr (unspec (i), 31, 6); /* put in ring bracket 1 */ rb2, rb3 = substr (unspec (i), 31, 6); /* brackets 2 & 3 = val level */ acla.mode = "01110"b; /* mode = rew */ call hcs_$acl_add (string (gcos_ext_stat_$pdir), "gcos_slave_area_seg", addr (acla), 1, code); /* set acl */ if code ^= 0 then call gcos_error_ (code, "setting access to slave segment"); end; call hcs_$truncate_seg (gseg, 0, code); /* truncate */ /* Set the actual max length limit on the segment */ 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, "setting max length on slave segment"); /* Set up bypass of condition handlers */ on any_other call gcos_fault_processor_; call sct_manager_$get (mme1_sct_index, gcos_ext_stat_$sig_ptr, code); /* check */ call sct_manager_$set (mme1_sct_index, addr (gcos_process_mme_), code); /* check */ /* The stack frame for this procedure stays around during the running of the activity. If it gets cleaned up, we must reset to the normal condition handlers and turn off the timer */ on cleanup begin; call timer_manager_$reset_cpu_call (gcos_fault_processor_$timer_runout); /* abort any timeout */ if gcos_ext_stat_$sig_ptr ^= null /* pointer was diddled */ then do; call sct_manager_$set (mme1_sct_index, gcos_ext_stat_$sig_ptr, code); /* check */ gcos_ext_stat_$sig_ptr = null; /* reinitialize */ end; if gcos_ext_stat_$save_data.rout then call gcos_mme_rout_$rout_cleanup; /* MME GEROUT simulater wants to clean up too */ released_fibs.nrf = 0; /* Empty released fibs array. */ end; on program_interrupt /* to simulate the GCOS equivalent of "QUIT" to stop */ call gcos_mme_rout_$rout_interrupt; /* unwanted typing from the slave program, we use the */ /* Multics "pi" command (user hits QUIT, then types "pi") */ /* CLEAR THE SLAVE PREFIX, THEN START INITIALIZING IT */ zero = "0"b; /* zero out slave prefix */ subact1: /* come here to start running an abort subactivity */ slave_prefix.mme = "000000000000010010000000001000000000"b; /* set up MME GECALL in slave prefix */ /* Translate program name to bcd and put in prefix */ call gcos_cv_ascii_gebcd_ (addr (gcos_ext_stat_$activity_name), 6, addr (slave_prefix.prog), i); if gcos_ext_stat_$save_data.abort_subact then goto subact2; /* skip lots of initialization, if running subactivity */ /* Convert activity number and job number to one word with the following format: */ /* bits 0-5 activity number in binary */ /* bits 6-35 job number in BCD */ /* Save also in ext static for use by MME GESYOT */ /* convert snumb to BCD */ call gcos_cv_ascii_gebcd_ (addr (substr (save_data.actid, 1, 5)), 5, addr (slave_prefix.activid), i); /* now get the activity number and concatenate the BCD snumb onto the end of it */ i = save_data.activity_no; save_data.short_actid, slave_prefix.activid = substr (unspec (i), 31, 6) || substr (slave_prefix.activid, 1, 30); /* Compute relative load limits and put in 37 octal of slave prefix */ /* Has the following format. Bits 0-17 hold lowest allowable address */ /* of activity relative to GELOAD origin. Bits 18-35 hold highest allowable */ /* address to be loaded by GELOAD. */ /* Lower limit = size of GELOAD - loader shared storage */ i = 9*1024-gcos_ext_stat_$ldrss; /* Upper limit = storage limit -1 */ j = gcos_ext_stat_$storage_limit-1; slave_prefix.load_limits = substr (unspec (i), 19, 18)||substr (unspec (j), 19, 18); /* Put ident card info in slave prefix */ call gcos_cv_ascii_gebcd_ (addr (gcos_ext_stat_$save_data.save_data.ident), length (gcos_ext_stat_$save_data.save_data.ident), addr (slave_prefix.ident), i); if gcos_ext_stat_$save_data.taskflag then spa_taskflag = (36) "1"b; /* set gtss drl task flag in spa */ /* Set up label variable in external static so that when the GCOS */ /* program terminates, the handler can return to this procedure */ /* and revert the stack properly. */ gcos_ext_stat_$mme_rtrn = end_activity; if gcos_ext_stat_$save_data.gtssflag then call gcos_gtss_update_$status_update (EXECUTING); /* Put activity start message out to operator */ call hcs_$get_usage_values (k, cputime_start, k); /* get cpu time at activity start */ realtime_start = clock_ (); /* get activity start time */ gcos_ext_stat_$activity_start_time = realtime_start; call date_time_ (realtime_start, holdtime); /* get date and time */ if save_data.activity_no = 1 & ^gcos_ext_stat_$save_data.brief then call ioa_ (" *SRT ^a @^a ^6a (^3d)", save_data.actid, substr (holdtime, 11, 6), gcos_ext_stat_$activity_name, divide(gcos_ext_stat_$time_limit,36,35)); pta.accno, rta.accno = substr (save_data.actid, 7, 2); term_msg = "activity"; /* Format the begin message for the execution report */ subact2: call ioa_$rs ("* ACTY-^2d $CARD #^4a ^6a ^a SW=^w", bannerstring, j, save_data.activity_no, gcos_ext_stat_$activity_card_num, gcos_ext_stat_$activity_name, substr (holdtime, 1, 8), save_data.psw); call gcos_write_$ptr (gcos_ext_stat_$er, var_msg, "11111100"b); /* write it on the execution report */ if gcos_ext_stat_$save_data.long then call ioa_$nnl (var_msg); /* also write it on the console for the interactive user */ /* Set up timeout = current number of cpu seconds process has */ /* been running + time limit. Control goes to fault$timer_runout */ /* if timeout occurs. */ call timer_manager_$cpu_call (gcos_ext_stat_$time_limit, "11"b, gcos_fault_processor_$timer_runout); if ^gcos_ext_stat_$save_data.abort_subact then /* except when continuing, with a subactivity */ gcos_ext_stat_$initial_cpu_time = virtual_cpu_time_ (); if pre_activity_stop_sw then do; call ioa_ ("ready to run activity; calling db:"); call db; end; /* Ready to transfer to gcos segment. Call a program to set BAR and do */ /* a TSS to enter BAR mode. Pass as args the limit part of the BAR */ /* (number of 512 word blocks), and a pointer to 26 in the gcos segment */ /* which is the location of the MME GECALL to get the activity going. */ call gcos_set_slave_ (divide (gcos_ext_stat_$storage_limit, 512, 18, 0), addrel (gseg, 26), (gcos_ext_stat_$save_data.no_bar)); /* Control will return to the top of the next page, via a nonlocal goto, when the slave program gives up control, which it will do for any of the following reasons: 1) MME GEFINI from the slave program, 2) MME GEBORT from the slave program, 3) fault in slave program, of a type which causes an abort, 4) error in one of the mme simulators, of a type which causes an abort. */ %page; /* Control comes here via a nonlocal goto, when the activity terminates */ end_activity: if post_activity_stop_sw then do; call ioa_ ("activity completed; calling db:"); call db; end; call timer_manager_$reset_cpu_call (gcos_fault_processor_$timer_runout); /* turn off timeout */ call hcs_$get_usage_values (k, cputime_finish, k); /* get cpu time used */ /* compute cpu time used in slave program */ cputime_used = cputime_finish - cputime_start; /* CONVERT MICROSECONDS USED TO SECONDS USED - VERIFY THIS THOUGH, hcs_$get_usage_values is not in the MPM any longer, so we can not be sure the value it returns IS microseconds ... */ cputime_used = divide (cputime_used, 1000000, 71, 0); if gcos_ext_stat_$abort_reason ^= "" then do; /* was there an abort in the slave pgm */ /* NOTE: if activity aborted but wrapup did not, abort_reason will be blank when wrapup terminates, and this do group will be skipped after the wrapup */ term_msg = term_msg || " aborted "; if ^gcos_ext_stat_$save_data.wrapup /* if not wrapup */ then if ^gcos_ext_stat_$save_data.abort_subact /* and not subactivity */ then initial_abort_reason = gcos_ext_stat_$abort_reason; /* save the abort reason for the ABT message */ call gcos_write_to_er_ ("^a", gcos_ext_stat_$abort_reason); gcos_ext_stat_$abort_reason = ""; /* clear it, so we can tell if wrapup aborts */ if gcos_ext_stat_$save_data.gtssflag then call gcos_gtss_update_$status_update (TERMINATING); /* Check type of dump desired, set switches, then call dump program */ if substr (save_data.psw, 1, 1) then dump_info = (36)"0"b; /* dump it all */ else dump_info = (29)"0"b || "1"b || (6)"0"b; /* only regs and prefix */ call gcos_mme_snp1_$bord (gcos_ext_stat_$mc.scu (4), dump_info); if gcos_ext_stat_$save_data.wrapup then goto no_wrapup; /* if abort from within wrapup, don't wrapup again */ if slave_prefix.wrapup = "0"b then goto no_wrapup; /* if no wrapup address given */ if fixed (slave_prefix.wrapup) > gcos_ext_stat_$storage_limit then do; /* if wrapup address out of bounds */ call ioa_ ("wrapup address out of bounds"); call gcos_write_$ptr (gcos_ext_stat_$er, "wrapup address out of bounds", "11111100"b); goto no_wrapup; end; /* print psw, etc. before entering wrapup */ call print_term_msg; /* internal procedure */ term_msg = "wrapup"; /* prepare for next message */ /* add 30 seconds to the remainder of the time limit, for the wrapup routine */ gcos_ext_stat_$time_limit = gcos_ext_stat_$time_limit - cputime_used + 30; /* set timer for wrapup */ call timer_manager_$cpu_call (gcos_ext_stat_$time_limit, "11"b, gcos_fault_processor_$timer_runout); gcos_ext_stat_$save_data.wrapup = "1"b; /* remember that we are wrapping up after an abort */ substr (save_data.psw, 1, 1) = "0"b; /* and don't dump if wrapup aborts */ /* Call program to set bar and then transfer via TSS to wrapup address in gcos pgm */ call gcos_set_slave_ (divide (gcos_ext_stat_$storage_limit, 512, 18, 0), addrel (gseg, slave_prefix.wrapup), (gcos_ext_stat_$save_data.no_bar)); /* control returns to "end_activity" above, via a nonlocal goto, when the wrapup terminates */ end; term_msg = term_msg || " terminated "; /* no abort - normal termination */ /* come here if wrapup not to be executed, for any reason (including no abort) */ no_wrapup: /* clean up the slave environment that we established earlier */ call sct_manager_$set (mme1_sct_index, gcos_ext_stat_$sig_ptr, code); /* check */ gcos_ext_stat_$sig_ptr = null; revert program_interrupt; if gcos_ext_stat_$save_data.rout then call gcos_mme_rout_$rout_cleanup; gcos_ext_stat_$save_data.wrapup = "0"b; /* turn off wrapup flag in case it was oh */ call print_term_msg; /* go print message */ /* if an abort subactivity is to be run, we do not want to clean up everything right now, though */ if gcos_ext_stat_$save_data.this_act_abort then /* if this activity aborted */ if gcos_ext_stat_$save_data.abort_card then do; /* and it contained a $ ABORT card */ /* NOTE that we are using our own flag and ignoring psw bit 12 here. This means that: 1) the activity can not turn off bit 12 to prevent the subactivity from running; 2) the activity can not turn on bit 12 to force it to run; it depends only on whether a $ ABORT card was present */ if gcos_ext_stat_$activity_name ^= "geload" /* only after a $ EXECUTE activity */ then goto no_subact; /* is $ ABORT allowed */ gcos_ext_stat_$save_data.abort_subact = "1"b; /* remember that we are running an abort subactivity */ /* add 30 seconds to remainder of time limit, for the subactivity */ gcos_ext_stat_$time_limit = gcos_ext_stat_$time_limit - cputime_used + 30; gcos_ext_stat_$activity_name = "utility"; term_msg = "subactivity"; call date_time_ (clock_ (), holdtime); goto subact1; /* go back to the activity-initializing part of this procedure, and set up to run the subactivity */ end; no_subact: /* terminate the activity and clean up completely */ call gcos_cleanup_files_; /* dispose of files according to settings of fib.indicators */ /* Write real time used on execution report */ realtime_finish = clock_ (); /* get current time */ call gcos_time_convert_ (realtime_finish-realtime_start, rta.time); /* get real time used */ call gcos_write_$ptr (gcos_ext_stat_$er, string (rta), "11111100"b); /* put out real time used msg */ /* Write cpu time used on execution report */ call gcos_time_convert_ (cputime_finish-cputime_start, pta.time); /* get cpu time used */ call gcos_write_$ptr (gcos_ext_stat_$er, string (pta), "11111100"b); /* put msg on execution report */ /* Write activity completion message (either FIN or ABT) on console */ if ^gcos_ext_stat_$save_data.brief then do; call date_time_ (realtime_finish, holdtime); /* format date and time of activity completion */ if gcos_ext_stat_$save_data.this_act_abort then /* put abort message on console */ call ioa_ (" *ABT ^a @^a ^a", save_data.actid, substr (holdtime, 11, 6), initial_abort_reason); /* else call ioa_ (" *FIN ^a @^a", save_data.actid, substr (holdtime, 11, 6)); */ end; post_cleanup: if post_cleanup_stop_sw then do; call ioa_ ("post-activity cleanup completed; calling db:"); call db; end; return; /* INTERNAL PROCEDURE TO PRINT MESSAGES OF THE FORM: * * ACTIVITY * TERMINATED * WRAPUP AT nnnnnn I=nnnnnn SW=nnnnnnnnnnnn * ABORTED * SUBACTIVITY * */ print_term_msg: proc; dcl (xilc, xir) fixed bin(35); /* get pointer to scu data */ scup = addr (gcos_ext_stat_$mc.scu); /* get location counter and indicators into separate full words, to keep ioa_ happy */ xilc = fixed (scu.ilc); xir = fixed (substr (string (scu.ir), 1, 12)); /* format the message */ /* ********** ********** CHANGE TO USE NEW IOA CODES TO GET RID OF FORMAT PROBLEMS */ if term_msg = "activity terminated " then term_msg = "normal termination "; /* what it should be */ call ioa_$rs (" * ^22a at ^6w I=^4w SW=^w", bannerstring, j, term_msg, xilc, xir, save_data.psw); call gcos_write_$ptr (gcos_ext_stat_$er, var_msg, "11111100"b); /* write it on execution report */ if gcos_ext_stat_$save_data.long then call ioa_$nnl (var_msg); /* also write it on console, for interactive user */ return; end print_term_msg; /* D E B U G G I N G E N T R I E S */ pre_setup_stop: presetup: entry; switch_name = "pre_setup_stop"; pre_setup_stop_sw = ^pre_setup_stop_sw; if pre_setup_stop_sw then print_on: switch_state = "on"; else print_off: switch_state = "off"; print_switch: call ioa_ ("^a turned ^a", switch_name, switch_state); return; pre_activity_stop: preact: entry; switch_name = "pre_activity_stop"; pre_activity_stop_sw = ^pre_activity_stop_sw; if pre_activity_stop_sw then goto print_on; else goto print_off; post_activity_stop: postact: entry; switch_name = "post_activity_stop"; post_activity_stop_sw = ^post_activity_stop_sw; if post_activity_stop_sw then goto print_on; else goto print_off; post_cleanup_stop: postclean: entry; switch_name = "post_cleanup_stop"; post_cleanup_stop_sw = ^post_cleanup_stop_sw; if post_cleanup_stop_sw then goto print_on; else goto print_off; %page; /* D E C L A R A T I O N S */ /* External Static */ dcl error_table_$namedup ext static fixed bin(35); /* system error code */ dcl error_table_$segknown ext static fixed bin(35); /* system error code */ /* External Entries */ dcl gcos_attach_file_ ext entry (ptr); dcl gcos_process_mme_ ext entry; /* called at fault time instead of signal_ */ dcl gcos_cleanup_files_ ext entry; dcl gcos_cv_ascii_gebcd_ ext entry (ptr, fixed bin(24), ptr, fixed bin(24)); dcl gcos_mme_snp1_$bord entry (bit (36), bit (36)); dcl gcos_error_ ext entry options (variable); dcl gcos_fault_processor_ ext entry; dcl gcos_fault_processor_$timer_runout ext entry; dcl virtual_cpu_time_ entry () returns (fixed bin(71) aligned); dcl gcos_mme_rout_$rout_cleanup ext entry; dcl gcos_mme_rout_$rout_interrupt ext entry; dcl gcos_set_slave_ ext entry (fixed bin(18), ptr, bit (1) aligned); dcl gcos_time_convert_ ext entry (fixed bin(52), char (19)); dcl gcos_write_$bcd_ptr ext entry (ptr, char (*), bit (8)); dcl gcos_write_$ptr ext entry (ptr, char (*), bit (8)); dcl gcos_write_to_er_ entry options (variable); dcl clock_ ext entry returns (fixed bin(71)); dcl cu_$level_get ext entry (fixed bin(24)); dcl date_time_ ext entry (fixed bin(71), char (*)); dcl db ext entry options (variable); dcl get_group_id_$tag_star ext entry returns (char (32)); dcl hcs_$acl_add ext entry (char (*), char (*), ptr, fixed bin(24), fixed bin(35)); dcl hcs_$get_usage_values ext entry (fixed bin(24), fixed bin(71), fixed bin(24)); dcl hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin(5), ptr, fixed bin(35)); dcl hcs_$set_max_length ext entry (char (*), char (*), fixed bin(19), fixed bin(35)); dcl hcs_$truncate_seg ext entry (pointer, fixed bin(24), fixed bin(35)); dcl ios_$seek ext entry (char (*), char (*), char (*), fixed bin(35), bit (72)); dcl sct_manager_$get entry (fixed bin, ptr, fixed bin(35)); dcl sct_manager_$set entry (fixed bin, ptr, fixed bin(35)); dcl timer_manager_$cpu_call ext entry (fixed bin(71), bit (2), entry); dcl timer_manager_$reset_cpu_call ext entry (entry); dcl (ioa_, ioa_$rs, ioa_$nnl) ext entry options (variable); /* Work Variables */ dcl system_free_area area based (gcos_ext_stat_$system_free_pointer); dcl dump_info bit (36); dcl status bit (72); /* holds return status from ios_ */ dcl bannerstring char (120); /* area to build banner in */ dcl var_msg char (j) based (addr (bannerstring)); /* variable length overlay for above */ dcl term_msg char (24) varying; /* holds "activity terminated", "wrapup aborted", etc. */ dcl initial_abort_reason char (128) varying; /* holds initial abort reason, for ABT message */ dcl (j, i) fixed bin(24); /* temps */ dcl (realtime_start, realtime_finish) fixed bin(71); /* holds time of start,end of activity */ dcl (cputime_start, cputime_finish, cputime_used) fixed bin(71); /* hold cpu time usage figures */ dcl k fixed bin(24); dcl holdtime char (24); /* holds date and time */ dcl code fixed bin(35); /* code returned from calls to hardcore */ dcl gseg pointer; /* temp ptr to gcos seg */ dcl zero bit (2304) based (gseg); /* used to zero slave prefix */ dcl 1 slave_prefix based (gseg), /* slave prefix model */ 2 fault_vector (14) fixed bin(24), 2 fill1 (9) fixed bin(24), 2 goodies, 3 wrapup bit (18) unaligned, /* address of abort wrapup routine */ 3 fill2 bit (18) unaligned, 2 fill3 (2) fixed bin(24), 2 mme bit (36), /* place where MME GECALL is to go */ 2 prog bit (36), /* prog to be loaded for this activity */ 2 fill4 (2) fixed bin(24), 2 activid bit (36), /* activity number and job number */ 2 load_limits bit (36), /* upper and lower load limits */ 2 fill5 (22) fixed bin(24), 2 ident bit (360) /* ident information from ident card (60 BCD characters) */; dcl 1 slave_prefix_alt_1 based (gseg), 2 fill (0:62) bit (36), 2 spa_taskflag bit (36); dcl 1 acla, /* acl model for file system */ 2 userid char (32), 2 pack, 3 mode bit (5), /* access */ 3 reterr bit (13), 3 (rb1, rb2, rb3) bit (6); dcl 1 rta int static, 2 msg char (21) init ("real time activity #"), 2 accno char (2), 2 blanks char (4) init (" "), 2 time char (19), 2 nl char (2) init (" "); dcl 1 pta int static, 2 msg char (26) init ("processor time activity #"), 2 accno char (2), 2 blanks char (4) init (" "), 2 time char (19), 2 nl char (4) init (" "); /* FOR DEBUGGING */ dcl ( pre_setup_stop_sw , pre_activity_stop_sw , post_activity_stop_sw , post_cleanup_stop_sw ) bit (1) aligned int static init ("0"b); dcl switch_name char (32) aligned; dcl switch_state char (4) aligned; dcl (addr, addrel, divide, fixed, null, string, substr, unspec) builtin; dcl (any_other, cleanup, program_interrupt) condition; %page; %include gcos_ext_stat_; %page; %include gcos_gtss_dcls; %page; %include static_handlers; %page; %include gcos_fibs; end gcos_run_activity_;  gcos_set_slave_.alm 11/05/86 1601.3r w 11/04/86 1038.8 19845 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " Provide for setting the BAR register and transfering " into GCOS user code. " " WRITTEN BY DICK SNYDER, JANUARY 31, 1973 for the 6180 " MODIFIED BY T. CASEY, MAY 1974 TO ADD no_bar ENTRY " MODIFIED BY D. KAYDEN DECEMBER 1974, JUNE 1975 " Modified by M. R. Jordan, August 1977 " name gcos_set_slave_ temp temp " entry gcos_set_slave_ " " dcl gcos_set_slave_ entry(new_bar,code,bar_mode); " dcl gcos_set_slave_ entry(fixed bin(18),ptr,bit(1)aligned); " " Set the BAR register to the "new_bar" value. " The right 18 bits are used (9 for bar base and 9 for bar bound). " If "bar_mode" is "0"b execute in bar mode. " Transfer to the code specified by pointer "code". " Note that the pointer "code" word offset (addrel offset) is " in relation to the bar base setting (i.e., bar-base*512+offset) " is the offset into the Multics segment located by pointer code. " "bar_mode" = "1"b implies do a TRA rather than TSS machine " operation, i.e., don't run in bar mode. This nullifies any bar " base setting. " gcos_set_slave_: push sprisp sb|stack_header.bar_mode_sp save sp so signaller can reset " it in case gcos uses adr6 lda ap|2,* get the BAR setting als 18 position it sta temp lbar temp set the BAR eppbp ap|4,* get the ptr eppbp bp|0,* .. stz sp|stack_frame.entry_ptr make stack traces look nice stz sp|stack_frame.entry_ptr+1 szn ap|6,* test no bar switch tmi bp|0 bit on means do tra instead of tss tss bp|0 transfer to the gcos program and set BAR mode " entry load_bar " " dcl gcos_set_slave_$load_bar entry(new_bar); " dcl gcos_set_slave_$load_bar entry(fixed bin(18)); " " Perform just the BAR register setting, "new_bar" treated the " same as for the gcos_set_slave_ entry. " load_bar: push lda ap|2,* get the BAR setting als 18 position it sta temp lbar temp set the BAR return that's it " include stack_header " include stack_frame end  gcos_sysout_writer_.pl1 09/09/83 1400.3rew 09/09/83 1007.1 95328 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_sysout_writer_: proc; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* PROCEDURE TO SEND SYSOUT FILES TO PRINTER OR CARD PUNCH Calls gcos_sysprint and gcos_syspunch commands to translate files from BCD to Multics-usable format (Multics ASCII for printer, RAW mode for punch). Calls dprint and dpunch commands (if necessary) to place converted files on daemon output queues. We use cu_$cp to call these commands. This has two side effects: 1) ABBREV may be used to supply default arguments to these commands (e.g. -he -ds), and 2) the search rule "referencing directory" will not find gcos_sysprint or gcos_syspunch, even if they are in the same directory as the gcos simulator. */ %page; /* WRITTEN BY T. CASEY MAR 73 MODIFIED BY T. CASEY APR 74 AUG 74 MODIFIED BY D. KAYDEN MAR 75 JUN 75 MODIFIED BY R.H. MORRISON JUL 75 MODIFIED BY S.C. AKERS DEC 81 Fix "-syot_dir" ctl_arg so gsp and gspn look in the right place for input, and put the output in the working_dir. */ %page; call initialize_routine; do i = save_data.sqindex-1 to 1 by -1; /* sqindex points to first FREE spot in queue */ converted = "0"b; call build_io_pathnames; /* Build the pathnames for input and output files. */ medium = save_data.sysout_queue_media (i); /* pick up media code */ if medium = 1 /* punch file */ then call process_punch; else if medium = 3 then call process_print; /* print file */ else do; /* must be bad media code */ call com_err_ (0, "gcos", "Bad sysout media code; file not processed:^/^a", in_pathname); goto next_file; end; if ^gcos_ext_stat_$save_data.nosave /* if save/restart is active */ then do; save_data.sqindex = i; /* set sysout queue index so that this entry is not */ /* processed again */ saved_sqindex = i; /* and also saved value of sqindex */ end; if delete then call delete_original; if gcos_ext_stat_$save_data.gtssflag then if not_queued then call gcos_gtss_update_$status_update (OUTPUT_WAITING); else call gcos_gtss_update_$status_update (OUTPUT_COMPLETE); if ^gcos_ext_stat_$save_data.brief /* unless told otherwise, */ & not_queued /* print names of files not queued for daemon output */ then do; if ^printed_heading /* print heading once PER CALL */ then do; call ioa_ ("^/GCOS sysout files NOT queued for daemon output:"); printed_heading = "1"b; end; if ^converted /* Which name to ship to user. */ then call ioa_ (in_pathname); else call ioa_ (out_pathname); end; next_file: ; end; return; %page; build_io_pathnames: proc; /* Build the input and output pathnames. */ in_pathname = save_data.syot_dir ||">" ||rtrim (save_data.sysout_queue (i)); l = length (in_pathname); /* remember pathname length */ out_pathname = rtrim (output_dir) ||">" ||rtrim (save_data.sysout_queue (i)); return; end build_io_pathnames; %page; command_error_handler: proc; /* Does the dirty work when command_error occurs in the syspunch, sysprint, dpunch, or dprint routines. */ on condition (command_error); /* Can't handle it here. */ command_error_switch = "1"b; /* turn on a static switch */ call continue_to_signal_ (code); /* and then go print normal message on terminal */ if code ^= 0 /* can't figure why, but better say something */ then call com_err_ (code, "gcos_sysout_writer_:", "Error while attempting to ""continue_to_signal_ command_error"" "); revert command_error; return; end command_error_handler; %page; delete_original: proc; delete = "0"b; /* turn off delete switch */ call delete_$path (syotdir, /* directory portion of pathname */ (save_data.sysout_queue (i)), /* entry portion of pathname */ "000100"b, /* noforce,noquestion,nodirectories,segments,nolinks,nochase */ "gcos", /* name of caller */ code); /* error code */ if code ^= 0 then call com_err_ (code, "gcos", "while attempting to delete ^a", substr (in_pathname, 1, l)); /* pathname, less .raw or .list suffix */ return; end delete_original; %page; initialize_routine: proc; /* Performs initialization chores. */ delete, not_queued, printed_heading = "0"b; /* Turn off the flags. */ syotdir = save_data.syot_dir; /* Save for "delete" call */ output_dir = get_wdir_ (); /* Where to put the Multics printer and punch files. */ saved_sqindex_offset = fixed (rel (addr (save_data.sqindex))) - fixed (rel (addr (gcos_ext_stat_$save_data))); saved_sqindex_ptr = addrel (addr (restart_control.restart_data), saved_sqindex_offset); return; end initialize_routine; %page; process_print: proc; /* Process a print file. */ not_queued = "1"b; /* switch turned off only if dprint called later */ if gcos_ext_stat_$save_data.list /* If we need to translate from bcd */ then do; /* then call translation command */ out_pathname = out_pathname || ".list"; varline = "gcos_sysprint " || in_pathname || " " || out_pathname; if gcos_ext_stat_$save_data.lower_case then varline = varline || " -lower_case"; line = varline; len = length (varline); command_error_switch = "0"b; on condition (command_error) call command_error_handler; call cu_$cp (addr (line), len, code); revert command_error; if code ^= 0 | command_error_switch then do; /* if any problem */ call com_err_ (code, "gcos_sysout_writer_", "Error in sysout conversion; original not deleted:^/^a", in_pathname); goto next_file; end; delete = "1"b; /* remember to delete original */ converted = "1"b; if gcos_ext_stat_$save_data.dprint /* If we're to print it */ then do; /* then call dprint command */ varline = "dprint " || gcos_ext_stat_$dpo || " " || out_pathname; line = varline; len = length (varline); command_error_switch = "0"b; on condition (command_error) call command_error_handler; call cu_$cp (addr (line), len, code); revert command_error; if code ^= 0 | command_error_switch /* if any problem */ then do; call com_err_ (code, "gcos_sysout_writer_", "^/Error in sysout call; listing file not dprinted or deleted:^/^a", out_pathname); goto next_file; end; not_queued = "0"b; /* file on dprint queue so turn off switch */ end; end; return; end process_print; %page; process_punch: proc; not_queued = "1"b; /* switch turned off only if dpunch called later */ if gcos_ext_stat_$save_data.raw /* If we're to translate from BCD */ then do; /* then call translation command */ out_pathname = out_pathname || ".raw"; /* syspunch so names its output file */ varline = "gcos_syspunch " || in_pathname; line = varline; len = length (varline); command_error_switch = "0"b; on condition (command_error) call command_error_handler; call cu_$cp (addr (line), len, code); revert command_error; if code ^= 0 | command_error_switch then do; /* if any problem, print message and go on to next file */ call com_err_ (code, "gcos_sysout_writer_", "Error in sysout conversion; original not deleted:^/^a", in_pathname); goto next_file; end; delete = "1"b; /* remember to delete the original */ converted = "1"b; if gcos_ext_stat_$save_data.dpunch /* if to be dpunched */ then do; varline = "dpunch " || gcos_ext_stat_$dpno || " " || out_pathname; line = varline; len = length (varline); command_error_switch = "0"b; on condition (command_error) call command_error_handler; call cu_$cp (addr (line), len, code); revert command_error; if code ^= 0 | command_error_switch then do; /* if problem in dpunch */ call com_err_ (code, "gcos_sysout_writer_", "Error in sysout dpunch call; output file will not dpunched or deleted:^/^a", out_pathname); goto next_file; end; not_queued = "0"b; /* file on dpunch queue, so turn off switch */ end; end; return; end process_punch; %page; /* External Entries */ dcl ioa_ ext entry options (variable); dcl size builtin; dcl com_err_ ext entry options (variable); dcl continue_to_signal_ ext entry (fixed bin(35)); dcl cu_$cp ext entry (ptr, fixed bin(24), fixed bin(35)); dcl delete_$path ext entry (char (*), char (*), bit (6), char (*), fixed bin(35)); dcl get_wdir_ entry() returns(char(168)); dcl gcos_restart_$save ext entry; /* Work Variables */ dcl code fixed bin(35); dcl command_error condition; dcl command_error_switch bit (1) aligned int static; dcl converted bit (1); dcl delete bit (1); /* switch on if bcd file to be deleted */ dcl in_pathname char (168) varying; dcl len fixed bin(24); dcl line char (500); /* fixed length version for cu_$cp parameter */ dcl not_queued bit (1); /* switch on if "not queued" message needed for this file */ dcl out_pathname char (168) varying; dcl output_dir char (168); dcl printed_heading bit (1); /* switch on if "not queued" heading already printed */ dcl saved_sqindex fixed bin (24) based (saved_sqindex_ptr); /* sqindex value in save_data */ dcl saved_sqindex_offset fixed bin(24); dcl saved_sqindex_ptr ptr; dcl syotdir char (168); dcl varline char (500) varying; /* place to construct command line for cu_$cp calls */ dcl (addr, addrel, rel, index, length, substr) builtin; dcl (i, j, l, medium) fixed bin(24); %page; %include gcos_ext_stat_; %page; %include gcos_gtss_dcls; %page; %include gcos_restart_control_; end gcos_sysout_writer_;  gcos_time_convert_.pl1 09/09/83 1400.3rew 09/09/83 1007.1 19476 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* **************************************************************************************** ****************************************************************************************** * * * * T I M E C O N V E R S I O N P R O C E D U R E * * * This procedure takes as an input argument a fixed bin(52) representation of * time in microseconds. It converts this value to a character string of length * nineteen which contains the time in minutes, seconds, and tenths * * * WRITTEN BY DICK SNYDER SEPTEMBER 25,1970 * MODIFIED BY T.CASEY DECEMBER 1972 * * ******************************************************************************************* ***************************************************************************************** */ /* */ gcos_time_convert_: proc (timeused, returntime); dcl returntime char (19); /* time returned */ dcl (timeused, timework) fixed bin(52); /* time interval */ dcl digits (0: 9) char (1) internal static init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9"); /* ascii 0-9 */ dcl (i, n) fixed bin(24); dcl v (14) fixed bin(24)int static init ((10)10, 6, 10, 0, 10); /* divide values */ dcl (divide, mod, substr) builtin; returntime = " mins . secs"; /* init return string */ timework = divide (timeused, 100000, 52, 0); /* convert to tenths of secs */ do i = 14, 12 by -1 to 11, 4 by -1 to 1; /* divide loop */ substr (returntime, i, 1) = digits (mod (timework, v (i))); /* grab digit */ timework = divide (timework, v (i), 17, 0); /* reduce time */ end; return; end gcos_time_convert_;  gcos_verify_access_.pl1 09/09/83 1400.3rew 09/09/83 1007.1 22167 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ******************************************************************************************* ******************************************************************************************* * * * Written by M. R. Jordan, October 1977 * ******************************************************************************************* ******************************************************************************************* */ gcos_verify_access_: proc (dirname, ename, fms_perms, buf_ptr, fms_code); dcl buf_ptr ptr; dcl code fixed bin(35); dcl dirname char (*); dcl ename char (*); dcl error_table_$no_s_permission fixed bin(35) ext; dcl fms_code bit (72) aligned; dcl fms_perms bit (6); dcl gcos_et_$fms_bad_cfdesc fixed bin(35) ext; dcl gcos_et_$fms_perms_denied fixed bin(35) ext; dcl gcos_et_$unimp_mme fixed bin(35) ext; dcl gcos_fms_error_ entry (fixed bin(35), ptr, bit (72) aligned); dcl gcos_mme_bort_$system entry options (variable); dcl hcs_$status_ entry (char (*), char (*), fixed bin(1), ptr, ptr, fixed bin(35)); call hcs_$status_ (dirname, ename, 1, addr (status_info_branch), null (), code); if code ^= 0 & code ^= error_table_$no_s_permission then do; call gcos_fms_error_ (gcos_et_$fms_bad_cfdesc, buf_ptr, fms_code); return; end; goto Access (fixed (substr (fms_perms, 1, 2), 2)); Access (0): /* none - error */ call gcos_mme_bort_$system (gcos_et_$unimp_mme, "Request for access other than read, write or read/write are not supported."); Access (1): /* write */ Access (3): /* read/write */ if (status_info_branch.mode & "01010"b) ^= "01010"b then call gcos_fms_error_ (gcos_et_$fms_perms_denied, buf_ptr, fms_code); return; Access (2): /* read */ if ^substr (status_info_branch.mode, 2, 1) then call gcos_fms_error_ (gcos_et_$fms_perms_denied, buf_ptr, fms_code); return; %include status_info_branch; end gcos_verify_access_;  gcos_verify_tss_access_.pl1 09/09/83 1400.3rew 09/09/83 1007.2 143046 /* ************************************************************* * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1979 by Honeywell Information Systems, Inc. * * * ************************************************************* */ gcos_verify_tss_access_: proc (dname, ename, permissions, buf_ptr, forced_acl_flag, fms_code); /* This program attempts to simulate the method in which GCOS propagates permissions thru catalogs. On each catalog created by gtss, the 10-bit permissions word passed to filact is converted to a character string and placed in the person field of an acl. The project field is either "*" for general permissions or an all upper-case project name for specific permissions. The tag field is always "g". On files, filact puts the permissions in a more typical Multics acl with *.*.* for general and *.project.* for specific, project again being all upper case. Because of the way GCOS does things, and because of the way in which we have implemented this on Multics, it is possible that a user may be able to access a file on which he does not have the appropriate Multics access. In such a case, the appropriate access is forced for that individual (person.project.instance), a bit is returned to indicate that this has been done, and at gtss_ios_$close time, a call is made to gtss_verify_access_$check_forced_access who removes that forced access if it is there. Author: Paul W. Benjamin 12/14/79 Changed: Mel Wilson 01/08/80 to handle multi_segment files and to lessen interference between an interactive user and an absentee run Changed: Sandy Bartlet 01/26/80 to allow SysDaemon and SysSfwr unlimited file access Changed: Sandy Bartlet 02/21/80 to fix SysDaemon/SysSfwr unlimited access and to fix so msf will be able to get forced acl Changed: Dave Ward 07/30/81 provided gtss_filat_error_status_ as internal for 9.0. */ dcl (dname, ename) char (*) parm; dcl permissions bit (6) parm; dcl buf_ptr ptr parm; dcl forced_acl_flag bit parm; dcl fms_code bit (72) aligned parm; dcl 1 fms_overlay aligned based (addr (fms_code)), 2 gcos_status bit (12) unal, 2 pad bit (60) unal; forced_acl_flag = "0"b; call user_info_ (person, umc, acct); UMC = translate (umc, "QWERTYUIOPASDFGHJKLZXCVBNM", "qwertyuiopasdfghjklzxcvbnm"); call msf_manager_$open (dname, ename, fcbptr, code); if code ^= 0 then do; gcos_status = gtss_filact_error_status_ (code); return; end; call hcs_$get_author (dname, ename, 1b, originator, code); if code ^= 0 then do; gcos_status = gtss_filact_error_status_ (code); goto bailout; end; originator = before (after (originator, "."), "."); if originator = umc | umc = "SysDaemon" | umc = "SysSfwr" then do; a = empty (); call msf_manager_$acl_list (fcbptr, addr (a), sa_ptr, null (), sa_count, code); if code ^= 0 then do; if code = error_table_$incorrect_access then do; sa_count = 0; end; else do; gcos_status = gtss_filact_error_status_ (code); goto bailout; end; end; found_sp = "1"b; /* give the originator any permissions wanted */ sa_sp = "111"b; goto check_request (bin (permissions)); end; if ^gcos_ext_stat_$skip_umc then /* "-drm smc" in gtss terms */ prefix_level = count ((gcos_ext_stat_$pathname_prefix), ">"); else prefix_level = 2; /* "-drm umc" */ temp_dir = ""; /* trim the leading ">" */ temp_name = after (rtrim (dname), ">"); do i = 1 to prefix_level; /* get the pathname prior to the umc into temp_dir */ temp_dir = temp_dir || ">" || before (temp_name, ">"); temp_name = after (temp_name, ">"); end; do i = 1 to hbound (cat, 1) - 1 while (index (temp_name, ">") ^= 0); /* Find levels betwixt umc and files */ cat_dir (i) = temp_dir; cat_name (i) = before (temp_name, ">"); temp_dir = temp_dir || ">" || before (temp_name, ">"); temp_name = after (temp_name, ">"); end; cat_dir (i) = temp_dir; cat_name (i) = temp_name; cat_num = i; do i = 1 to cat_num; /* Find propagation acls for general and specific at each level. */ a = empty (); call hcs_$list_dir_acl (cat_dir (i), cat_name (i), addr (a), da_ptr, null (), da_count, code); if code ^= 0 then do; if code = error_table_$incorrect_access then da_count = 0; else do; gcos_status = gtss_filact_error_status_ (code); goto bailout; end; end; found_sp, found_gp = "0"b; cat.gp (i), cat.sp (i) = "NONE"; do j = 1 to da_count while (^found_gp | ^found_sp); if index (da_name (j), "."||rtrim (UMC)||".g") ^= 0 then do; cat.sp (i) = substr (da_name (j), 1, 10); found_sp = "1"b; end; else if index (da_name (j), ".*.g") ^= 0 then do; cat.gp (i) = substr (da_name (j), 1, 10); found_gp = "1"b; end; end; end; /* Accumulate permissions through each catalog */ have_sp = "0"b; working_perm = "0"b; do i = 1 to cat_num; if ^have_sp then do; /* no specific perms encountered yet */ if cat.sp (i) ^= "NONE" then do; /* just encountered first specific permissions */ working_perm = bit (cat.sp (i)); /* replace (override) accumulated g.p. */ have_sp = "1"b; /* switch to spec. perm. */ end; else if cat.gp (i) ^= "NONE" then working_perm = working_perm | bit (cat.gp (i)); /* accumulate g.p. */ end; else do; /* have previously switched to specific permissions */ if cat.sp (i) ^= "NONE" then working_perm = bit (cat.sp (i)); /* new s.p. override old */ end; end; found_sp, found_gp, sa_sp, sa_gp = "0"b; a = empty (); /* Look at segment acl */ call msf_manager_$acl_list (fcbptr, addr (a), sa_ptr, null (), sa_count, code); if code ^= 0 then do; if code = error_table_$incorrect_access then sa_count = 0; else do; gcos_status = gtss_filact_error_status_ (code); goto bailout; end; end; do i = 1 to sa_count while (^found_gp | ^found_sp); if sa_name (i) = "*.*.*" then do; sa_gp = substr (sa_modes (i), 1, 3); found_gp = "1"b; end; else if sa_name (i) = "*."||rtrim (UMC)||".*" then do; sa_sp = substr (sa_modes (i), 1, 3); found_sp = "1"b; end; end; goto check_request (bin (permissions)); /* convert gcos to multics access */ check_request (5): check_request (6): check_request (7): check_request (9): check_request (10): check_request (11): check_request (12): check_request (13): check_request (14): check_request (15): check_request (18): check_request (19): check_request (21): check_request (22): check_request (23): check_request (24): check_request (25): check_request (26): check_request (27): check_request (28): check_request (29): check_request (30): check_request (31): check_request (34): check_request (35): check_request (36): check_request (37): check_request (38): check_request (39): check_request (41): check_request (42): check_request (43): check_request (45): check_request (46): check_request (47): check_request (50): check_request (51): check_request (52): check_request (53): check_request (54): check_request (55): check_request (56): check_request (57): check_request (58): check_request (59): check_request (61): check_request (62): check_request (63): gcos_status = "4044"b3; /* Illegal options combination. */ goto bailout; check_request (0): check_request (1): check_request (2): check_request (3): check_request (32): check_request (33): check_request (44): gc_need = "1000000000"b; /* GCOS r, Multics r */ mu_need = "100"b; goto check_end; check_request (4): gc_need = "0001000000"b; /* GCOS e, Multics r */ mu_need = "100"b; goto check_end; check_request (8): gc_need = "0010000000"b; /* GCOS a, Multics r */ mu_need = "100"b; goto check_end; check_request (16): check_request (17): check_request (20): check_request (48): check_request (49): gc_need = "0100000000"b; /* GCOS w, Multics rw */ mu_need = "101"b; goto check_end; check_request (40): gc_need = "1010000000"b; /* GCOS ra, Multics r */ mu_need = "100"b; goto check_end; check_request (60): gc_need = "0000000001"b; /* GCOS x, Multics rw */ mu_need = "101"b; check_end: /* Check requested permissions vs accumulated permissions */ if found_sp then do; /* honour specific perms on file */ if (^mu_need | sa_sp) ^= "111"b then goto permission_denied; end; else if have_sp then do; /* honour specific perms on containing catalog */ if (^gc_need | working_perm) ^= (10)"1"b then goto permission_denied; end; else if ((^mu_need | sa_gp) ^= "111"b) & ((^gc_need | working_perm) ^= (10)"1"b) then goto permission_denied; /* no general permissions */ /* HAVE accumulated enough permissions thru catalogs. */ do i = 1 to sa_count; /* check for relevant acl on file */ call match_star_name_ (get_group_id_ (), sa_name (i), code); if code = 0 then goto found_acl_match; end; goto force_access; /* no matching acl - go force what we want */ found_acl_match: if (^mu_need | substr (sa_modes (i), 1, 3)) ^= "111"b then goto force_access; permission_granted: gcos_status = "4000"b3; /* Successful. */ bailout: call msf_manager_$close (fcbptr); return; permission_denied: call gcos_fms_error_ (gcos_et_$fms_perms_denied, buf_ptr, fms_code); /* Permissions denied. */ goto bailout; force_access: force_name, force_dir_name = get_group_id_ (); force_modes = mu_need; force_dir_modes = "111"b; call hcs_$add_dir_acl_entries (dname, ename, addr (force_dir_acl), 1, code); if code ^= 0 then if code ^= error_table_$nondirseg then do; gcos_status = gtss_filact_error_status_ (code); goto bailout; end; call msf_manager_$acl_add (fcbptr, addr (force_acl), 1, code); if code ^= 0 then do; gcos_status = gtss_filact_error_status_ (code); goto bailout; end; forced_acl_flag = "1"b; goto permission_granted; check_forced_access: entry (dname, ename, forced_acl_flag); /* Remove forced acl, if set. */ if forced_acl_flag then do; dl_name, force_dir_name = get_group_id_ (); force_dir_modes = "111"b; call hcs_$add_dir_acl_entries (dname, ename, addr (force_dir_acl), 1, code); call msf_manager_$open (dname, ename, fcbptr, code); if code ^= 0 then return; call msf_manager_$acl_delete (fcbptr, addr (dl_array), 1, code); call msf_manager_$close (fcbptr); call hcs_$delete_dir_acl_entries (dname, ename, addr (dl_array), 1, code); end; return; count: proc (in_string, target) returns (fixed bin); dcl (in_string, target) char (*) parm; j = 1; k = 0; do while (index (substr (in_string, j), target) ^= 0); j = j + index (substr (in_string, j), target) + length (target) - 1; k = k + 1; end; return (k); dcl (j, k) fixed bin(24); dcl (after, index, length, substr) builtin; end count; %page; /* FOLLOWING PROCEDURE IS FROM gtss MODULES. INCLUDED AS AN INTERNAL PROCEDURE TO RESOLVE EXTERNAL REFERENCES FOR RELEASE 9.0. IN THE FUTURE THIS SHOULD BE MADE AVAILABLE TO BOTH SIMULATORS (dbw 07/30/81). */ gtss_filact_error_status_: proc (code) returns (bit (12)); dcl code fixed bin (35); if code = 0 then return ("4000"b3); /* no error */ if code = error_table_$bad_ring_brackets | code = error_table_$incorrect_access | code = error_table_$moderr | code = error_table_$no_s_permission | code = error_table_$no_info then return ("4003"b3); /* permissions denied */ if code = error_table_$dirseg | code = error_table_$no_dir | code = error_table_$noentry | code = error_table_$nondirseg | code = error_table_$not_seg_type | code = error_table_$notadir then return ("4005"b3); /* incorrect cat/file description */ if code = error_table_$namedup | code = error_table_$segnamedup then return ("4011"b3); /* duplicate name */ if code = error_table_$logical_volume_not_connected | code = error_table_$pvid_not_found then return ("4025"b3); /* requested entry not on-line */ return ("4047"b3); /* unaccountable error */ dcl ( error_table_$bad_ring_brackets, error_table_$dirseg, error_table_$incorrect_access, error_table_$logical_volume_not_connected, error_table_$moderr, error_table_$namedup, error_table_$no_dir, error_table_$no_info, error_table_$no_s_permission, error_table_$noentry, error_table_$nondirseg, error_table_$not_seg_type, error_table_$notadir, error_table_$segnamedup, error_table_$pvid_not_found ) ext static fixed bin (35); end gtss_filact_error_status_; dcl a area (1000) ; dcl acct char (32); dcl 1 cat (10), 2 cat_dir char (168), 2 cat_name char (32), 2 gp char (10), 2 sp char (10); dcl cat_num fixed; dcl code fixed bin(35); dcl 1 da_array (da_count) based (da_ptr), 2 da_name char (32), 2 da_modes bit (36), 2 da_code fixed bin(35); dcl da_count fixed bin(24); dcl da_ptr ptr; dcl 1 dl_array, 2 dl_name char (32), 2 dl_code fixed bin(35); dcl drm_len fixed; dcl exclude bit (1); dcl fcbptr ptr init (null ()); dcl 1 force_acl, 2 force_name char (32), 2 force_modes bit (36), 2 mbz bit (36) init ("0"b), 2 force_code fixed bin(35); dcl 1 force_dir_acl, 2 force_dir_name char (32), 2 force_dir_modes bit (36), 2 force_dir_code fixed bin(35); dcl (found_gp, found_sp) bit (1); dcl gc_need bit (10); dcl gp_result bit (10); dcl have_sp bit; dcl (i, j) fixed bin(24); dcl mu_need bit (3); dcl originator char (32); dcl person char (22); dcl prefix_level fixed bin(24); dcl 1 sa_array (sa_count) based (sa_ptr), 2 sa_name char (32), 2 sa_modes bit (36), 2 sa_pad bit (36), 2 sa_code fixed bin(35); dcl sa_count fixed bin(24); dcl sa_gp bit (3); dcl sa_ptr ptr; dcl sa_sp bit (3); dcl sp_result bit (10); dcl temp_dir char (168) varying; dcl temp_name char (168) varying; dcl (umc, UMC) char (9); dcl working_perm bit (10); dcl gcos_fms_error_ entry (fixed bin(35), ptr, bit (72) aligned); dcl gcos_mme_bort_$system entry options (variable); dcl ( gcos_et_$fms_bad_cfdesc, gcos_et_$fms_perms_denied, gcos_et_$unimp_mme ) fixed bin(35) ext; %include gcos_ext_stat_; dcl (error_table_$incorrect_access, error_table_$nondirseg ) fixed bin(35) ext; dcl get_group_id_ entry returns (char (32)); dcl hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin(24), fixed bin(35)); dcl hcs_$delete_acl_entries entry (char (*), char (*), ptr, fixed bin(24), fixed bin(35)); dcl hcs_$delete_dir_acl_entries entry (char (*), char (*), ptr, fixed bin(24), fixed bin(35)); dcl hcs_$get_author entry (char (*), char (*), fixed bin(1), char (*), fixed bin(35)); dcl hcs_$list_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin(24), fixed bin(35)); dcl hcs_$list_dir_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin(24), fixed bin(35)); dcl match_star_name_ entry (char (*), char (*), fixed bin(35)); dcl msf_manager_$acl_add entry (ptr, ptr, fixed bin(24), fixed bin(35)); dcl msf_manager_$acl_delete entry (ptr, ptr, fixed bin(24), fixed bin(35)); dcl msf_manager_$acl_list entry (ptr, ptr, ptr, ptr, fixed bin(24), fixed bin(35)); dcl msf_manager_$close entry (ptr); dcl msf_manager_$open entry (char (*), char (*), ptr, fixed bin(35)); dcl user_info_ entry (char (*), char (*), char (*)); dcl (after, before, bin, bit, empty, index, null, rtrim, substr, translate) builtin; end gcos_verify_tss_access_;  gcos_write_.pl1 09/09/83 1400.3rew 09/09/83 1007.2 187056 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ gcos_write_: proc (filecode, record, reportcode); /* * This procedure is called to write a record on a gcos file. * * The main entry point expects an ASCII string, which will be converted to BCD, * and put into a GCOS standard system format record. Certain special ascii * characters are recognized and are converted to printer control information. * Newline characters are converted to octal 7701 (skip one line). If n * contiguous newlines are encountered, then a control sequence of 77n is * produced (skip n lines). Page characters (octal 014) are converted to 7720 * (skip to head of form). Note that gcos_write_ does not actually do this * conversion, but instead, it is done by a subroutine (gcos_cv_printline_gebcd_). * * A search of the filecode table is made to match the filecode to an existing fib. If * no match is found, a file is opened and a fib is built. This is done by * gcos_open_file_, and gcos_attach_file_. This is only done for those * entry points that use the filecode to specify the file. * * Since records are written in GCOS standard format, multiple records are * packed into 320 word blocks. These blocks are written to the specified * files using ios_. * * If the length of * the record to be written is 0, an end of file record will be written. This * is a record with length 0 and the end of file code (170000) in the lower * half of the record header word (the upper half containing the length). * The buffer is then written out. * * * ADDITIONAL ENTRY POINTS: * * $ptr -same as main entry, except that the file is specified by a * fib pointer. * * $force -forces a partially-filled buffer for the specified filecode * to be written out to the file. An empty buffer is not written out. * * $force_ptr -same as $force, except that the file is specified by a * fib pointer. * * $bcd -writes a BCD string onto the given stream, in a GCOS record. * * $bcd_ptr -same as $bcd above, except that the file is specified by * a fib pointer. * * $ascii_ptr -writes a GCOS record, containing the ASCII characters from the * input string. Turns on bit 27 (counting from zero) of the rcw, * if bits 28 and 29 are not both zero, and bit 26 if they are zero, * thus allowing media codes 5, 6, 7, and 8 to be specified. * Pads last word with ASCII pad characters (octal 177). * The file is specified by a pointer to the fib. * * * The above entries all construct a rcw and place it before the data in the record. * * * * The following entries assume the record already starts with a rcw (or bcw, for $block). * * $record -writes gcos record, complete with rcw, without changing * anything in it. reportcode is ignored, but must be supplied * in the call (and should be (8)"0"b). * record should be char(*), with * being 4 times * the word length of the record, including the rcw. * * Since the contents of the record and the rcw are not * examined or changed, but merely copied into the output buffer, * this entry can be used to write more than one record per call, * by overlaying the records with a char(*) argument of the * correct length. This is done by gcos_mme_syot_. * * * $record_ptr -same as $record, except that the file is specified * by a fib pointer. * * $print_bcd_card -writes gcos record, supplied as above, but modifies it as follows: * it assumes it is a bcd card (14 data words in record) and it * puts octal 7701 (bcd newline) into last word, in "columns" 81-82. * It puts reportcode into the rcw that it is passed. reportcode * should begin with "11"b (media code for bcd printlines). * BCD ! (77) and ? (17) are escaped by preceeding them with 7777. * All modifications are made to the copy in the write buffer, * so the copy passed by the caller is preserved. * * $print_bcd_ptr -same as $print_bcd_card except that file is specified * by a pointer to the fib. * * $block -writes a full block (up to 320 words). If there are any records in * the buffer for the given filecode, that buffer is written out first. The * length and serial number are put into the bcw, in the caller's copy of the * block. The block must be passed as a char(*) variable, with * being exactly * 4 times the word length of the block, including the bcw. * * $block_ptr -same as $block, except that the file is specified * by a fib pointer. * * INPUT PARAMETERS: * either: filecode--filecode of file to be written on. * or: fib_ptr--pointer to fib of file to be written on * record--record to be written. * reportcode--8 bits used as: media code (2 bits) and report code (6 bits). * (thus the 4 bit ascii media codes are not presently supported - * EXCEPT for the $ascii_ptr, $record and $record_ptr entries.) * */ %page; /* Author: DICK SNYDER AUGUST 10,1970 Change: T. CASEY JUNE 1973, NOVEMBER 1973, FEBRUARY 1974, APRIL 1974, AUGUST 1974 Change: D. KAYDEN APRIL 1974, JULY 1974, DECEMBER 1974 Change: M. R. Jordan, October 1977 Change: Dave Ward 08/14/81 reorganized. Arrayed form of fibs. */ %page; dcl fib_ptr ptr parm; dcl filecode char(*) parm /* file code of file to be written */; dcl record char(*) parm /* record to be written */; dcl reportcode bit(8) parm /* record type and report code */; /* Come here from all entry points that take filecode (except $force) to look up the fib by filecode, and open the file if the fib is not found */ main: ; /* Look for fib to match file code */ if look_up_filecode () then return; /* internal procedure */ /* Come here from all entries that take a fib pointer (except $force_ptr), to provide a buffer if necessary, and write a record on the file, but bypassing the the opening of the file if the fib is not found; when a fib pointer is specified, the file must be open. */ setbuf: ; call setup; if length (record) = 0 then do; /* Come here if length of record to be written is 0. Write a filemark record (000000170000 octal) in the block if the device is disk or drum. If tape, write an eof followed by a trailer and another eof. */ if ^fib.tape then do; /* if not a tape */ buf (fib.rec_len) = "000000170000"b3; /* put eof mark */ /* in record header (bits 18-23). */ /* Rest of header = 0's */ fib.rec_len = fib.rec_len + 1; /* and increment length of record */ end; call write_fib_block; /* go write the block */ if fib.tape then do; /* writing on tape? */ call ios_$order ((fib.stream), "eof", null, status); /* write eof */ if code ^= 0 then /* all errors fatal */ wr_err: ; call gcos_error_ (code, "^a^/stream=^a", fib.pathnm, fib.stream); trailer.blk_count = block.num -1; /* put no blocks written in trailer */ call ios_$write ((fib.stream), addr (trailer), 0, 14, i, status); /* write eof trailer */ if code ^= 0 then goto wr_err; /* all errors fatal */ call ios_$order ((fib.stream), "eof", null, status); /* write another eof */ if code ^= 0 then goto wr_err; /* all errors fatal */ end; return; end; lenrec = divide (length (record)+3, 4, 17, 0); /* set up for translation of ASCII data to BCD. Subroutine gcos_cv_printline_gebcd_ */ /* will translate the message and move it to the buffer. It will also */ /* transform newlines and newpages into proper BCD escape codes */ inp = addr (record); /* get address of input record */ if ^acisw then /* if we don't want an ASCII record */ if ^bcdsw then do; /* and we don't have a BCD record */ /* if any of the above, copy the input record directly into the buffer, omitting the ASCII to BCD translation */ /* Since we are here, none of the above was true, so translate to BCD */ call gcos_cv_printline_gebcd_ (inp, length (record), addr (temp_buf), i); lenrec = divide (i+5, 6, 17, 0); inp = addr (temp_buf); /* get pointer to the BCD string */ end; print_join: ; if lenrec >= 319 then do; /* test for long record */ code = gcos_et_$record_too_long; goto wr_err; end; if fib.rec_len + lenrec >= 319 then call write_fib_block; /* write current block if new rec won't fit */ rcwp, outp = addr (buf (fib.rec_len)); /* addr of slot in buffer for this record */ if ^gcossw then outp = addrel (outp, 1); /* leave room for rcw, unless its there already */ outstring = instring; /* copy record into buffer */ if gcossw then do; /* if we have a gcos record, with rcw already in it */ lenrec = lenrec - 1; /* don't count the rcw in the length */ /* INCODE PROCESSING: All BCD card images (which may have been originally created by reading cards punched in other than GEBCD card codes) are written onto files by calls to gcos_write_$record. That entry turns on gcossw. Therefore, if gcossw is on and the media code is "10" (BCD card) and gcos_ext_stat_$incode is nonzero, we want to go through the record we just put into the buffer, looking for any of the six characters that can be different, and translate them into the proper GEBCD codes. */ if gcos_ext_stat_$incode ^= 0 then /* If incode translation is in effect */ if rcw.media_code = "0010"b then /* and we have a BCD card */ call gcos_incode_ (addrel (inp, 1), lenrec * 6, addrel (outp, 1)); end; else do; /* Create record header (rcw) consisting of length and record type and reportcode */ rcwp -> word = "0"b; /* clear out the rcw */ rcw.length = lenrec; /* fill in record length */ substr (rcwp -> word, 29, 8) = reportcode; /* fill in media and report codes */ if acisw then do; /* if $ascii entry, fix up several parts of the record */ if rcw.media_code = "0"b then /* if we want ascii media code 8 */ substr (rcw.media_code, 1, 1) = "1"b; /* make it 8 ("1000"b) */ else substr (rcw.media_code, 2, 1) = "1"b; /* else make it 5, 6, or 7 ("01xx"b) */ acipad = mod (length (record), 4); /* see if they partially fill the last word */ if acipad > 0 then /* if last word is only partially filled */ substr (outp -> acistring, length (record)+1, 4-acipad) = substr (pads, 1, 4-acipad); /* fill rest of it with pad (177) chars */ end; end; fib.rec_len = fib.rec_len+lenrec+1; /* compute new length of block */ return; %page; print_bcd_card: entry (filecode, record, reportcode); /* print bcd card image. 7701 is appended to card, and rcw is modified using reportcode argument */ goto print_common; %page; print_bcd_ptr: entry (fib_ptr, record, reportcode); /* print bcd card image, but with fib pointer argument */ fibptr = fib_ptr; print_common: ; call setup; /* EDITP PROCESSING The following code searches the record just written for the BCD characters ! (77) and ? (17), which have special meaning for printed output. In order to be taken literally and just printed, they must be preceeded by the BCD escape sequence, which is two !'s (7777). Since this procedure is called to write all sorts of records on gcos files, some of which will later be printed, and some of which will be read by gcos slave programs, and the escapes are only proper in print files, this code is only entered when the $print_bcd_card entry was used. */ inp = addrel (addr (record), 1); outp = addr (temp_buf); j = 0; do i = 1 to 80; if bcd.char = "17"b3 | /* 17 = "?" */ bcd.char = "77"b3 then do; /* 77 = "!" */ bcd2.chars = "7777"b3 ; /* 7777 = "!!" */ outp = addr (bcd2.next); j = j + 2; end; outp -> bcd.char = bcd.char; inp = addr (bcd.next); outp = addr (outp -> bcd.next); j = j + 1; end; bcd2.chars = "7701"b3 ; /* 7701 = "!1" (bcd newline) */ inp = addr (temp_buf); lenrec = divide (j+7, 6, 17, 0); goto print_join; %page; record_ptr: entry (fib_ptr, record, reportcode); /* write gcos record (as for $record entry) but with fib pointer arg */ gcossw = "1"b; /* full gcos record, rcw included */ /* fall thru to turn on bcdsw */ /* Enter here to write a string which is already in bcd and which */ /* already has newlines and newpages translated to their bcd equivalents */ bcd_ptr: entry (fib_ptr, record, reportcode); bcdsw = "1"b; /* indicate that input is in BCD */ %page; ptr: entry (fib_ptr, record, reportcode); /* do the same as the primary entry, given a fib pointer */ /* Come here from $ascii_ptr entry */ ptr_common: ; fibptr = fib_ptr; goto setbuf; %page; ascii_ptr: entry (fib_ptr, record, reportcode); /* write a record containing the ascii input string, untranslated */ acisw = "1"b; /* remember we entered here */ goto ptr_common; /* go set fib pointer */ %page; record: entry (filecode, record, reportcode); /* write gcos record with no alteration at all. rcw is included in length of char(*) argument */ gcossw = "1"b; /* we have a full gcos record, rcw included */ %page; bcd: entry (filecode, record, reportcode); /* write block of bcd words, and build rcw, but look up fib by filecode */ bcdsw = "1"b; /* input is bcd characters */ goto main; /* go look up filecoe and join main body of program */ %page; block: entry (filecode, record); /* write complete 320 word block */ if look_up_filecode () then return; writing_block: ; call setup; if fib.rec_len > 0 then /* if there is anything in the buffer */ call write_fib_block; /* go write it out first */ blockptr = addr (record); blockptr -> block.num = block.num; /* copy current bsn into bcw of block to be written */ /* Compute word length of block and put it where write_block expects to find it. */ fib.rec_len = blockptr -> block.length; call write_block; /* go write the block */ return; /* that's all */ %page; block_ptr: entry (fib_ptr, record); /* write complete 320 word block, but with fib pointer arg */ fibptr = fib_ptr; goto writing_block; /* Enter here to force out buffer for file specified in filecode. */ /* Do not force if buffer is null or rec_len = 0 which */ /* indicates that buffer was just written out. */ force: entry (filecode); if look_up_filecode () then return; goto force_common; %page; force_ptr: entry (fib_ptr); /* Enter here to force out buffer for file associated with the */ /* fib pointed to by fibptr. */ fibptr = fib_ptr; force_common: ; if fib.buffer ^= null then /* and there is a buffer */ if fib.rec_len ^= 0 then /* and it is not empty */ call write_fib_block; /* write it out */ return; %page; look_up_filecode: proc () returns (bit (1)); /* look up a fib by filecode Return "1"b if file not to be written. */ do i = 1 to hbound (save_data.fibs, 1); if fct.filecode (i) = filecode then do; if fct.sysout (i) then return ("1"b); fibptr = fct.fibptr (i); /* get pointer to fib */ if ^fib.gein then return ("1"b); /* protect user files from simulator */ return ("0"b); end; end; /* No fib found. Create one and a file to match */ call gcos_open_file_ (filecode, "", fibptr, sw); /* initialize a fib for the specified filecode */ fib.gein = "1"b; /* file for slave use - a gein file */ return ("0"b); end look_up_filecode; %page; setup: proc; /* allocate a working buffer if necessary */ if fib.buffer = null then do; /* buffer provided yet? */ k = index (string (fib_buffers.buffer_in_use), "0"b); if k = 0 then do; call gcos_error_ ( /* No buffers available. */ 0 , "Exceeded ^i file buffers provided." , hbound (fib_buffers.buffer_in_use, 1) ); return; end; fib_buffers.buffer_in_use (k) = "1"b; /* Mark buffer in use. */ fib.buffer_indx = k; fib.buffer = addr (fib_buffers.buffer (k)); fib.rec_len = 0; /* block length */ block.num = divide (fib.current, 320, 17, 0) + 1; /* set block serial number */ if ^fib.attached then call gcos_attach_file_ (fibptr); end; return; end setup; %page; write_fib_block: proc; /* write a block onto the file */ blockptr = fib.buffer; /* pointer to the block to be written */ blockptr -> block.length = fib.rec_len; /* put length into bcw */ write_block: entry; /* entry with blockptr already set. */ if fib.tape then write_count = fib.rec_len + 1; /* write only used words in block on tape */ else write_count = 320; /* write max words per block to disk */ fib.rec_len = 0; /* reset block length */ call ios_$write ((fib.stream), blockptr, 0, write_count, i, status); /* write record */ if code ^= 0 then goto wr_err; /* fatal write error */ /* Bump serial number in buffer header (bits 1-17) by one */ block.num = block.num + 1; fib.current = fib.current + write_count; /* bump curr rec no */ if fib.current > fib.size then /* grow file size if necessary */ fib.size = fib.size + 3840; /* grow file one link */ return; /* return from internal procedure */ end write_fib_block; %page; /* Variables for gcos_write_: */ /* IDENTIFIER ATTRIBUTES */ dcl acipad fixed bin(24) /* number of pad chars needed to finish ascii rec */; dcl acistring char(1044480) based; dcl acisw bit(1)init("0"b) /* => $ascii entry. */; dcl addr builtin; dcl addrel builtin; dcl bcdsw bit(1)init("0"b) /* => $bcd entry. */; dcl blockptr ptr; dcl divide builtin; dcl gcossw bit(1)init("0"b) /* => $record entry. */; dcl gcos_attach_file_ ext entry (pointer); dcl gcos_cv_printline_gebcd_ ext entry (ptr, fixed bin(21), ptr, fixed bin(21)); dcl gcos_error_ ext entry options (variable); dcl gcos_et_$record_too_long fixed bin(35) ext; dcl gcos_incode_ ext entry (ptr, fixed bin(24), ptr); dcl gcos_open_file_ ext entry (char(*), char(*), pointer, bit(1)); dcl i fixed bin(21); dcl index builtin; dcl inp ptr; dcl instring (lenrec) fixed bin(24)based (inp) /* input string */; dcl j fixed bin(24); dcl k fixed bin; dcl length builtin; dcl lenrec fixed bin(17) /* length in words of record */; dcl mod builtin; dcl null builtin; dcl outp ptr; dcl outstring (lenrec) fixed bin(24)based (outp) /* output string */; dcl pads char(4) int static init("") /* four ASCII pad (177) chars */; dcl putp ptr; dcl rcwp ptr; dcl substr builtin; dcl sw bit(1) /* switch used in open call */; dcl temp_buf (350) fixed bin(24); dcl word bit(36) aligned based; dcl write_count fixed bin(21) /* no of words to write */; ; dcl 1 block aligned based (fib.buffer), /* overlay for buffer */ 2 num fixed bin(18)unsigned unaligned, /* block number */ 2 length fixed bin(18)unsigned unaligned, /* block length */ 2 buf (0:318) bit(36) /* remainder of block */ ; dcl 1 trailer int static /* model of eof trailer */ , 2 eoftrailer bit(36) init( "202546262020"b3 ) /* bEOFbb */ , 2 blk_count fixed bin(24) init(0) /* block count for file */ , 2 junk (12)bit(36) init((12)(1)"0"b) /* remainder of label record. */ ; dcl 1 rcw aligned based (rcwp), 2 length fixed bin(18)unsigned unaligned, /* record length */ 2 eof bit(6) unaligned, 2 zeros bit(2) unaligned, 2 media_code bit(4) unaligned, 2 report_code bit(6) unaligned; dcl 1 bcd unaligned based (inp), 2 char bit(6) unaligned, 2 next bit(6) unaligned; dcl 1 bcd2 unaligned based (outp), 2 chars bit(12) unaligned, 2 next bit(6) unaligned; %page; %include gcos_fibs; %page; %include gcos_ext_stat_; %page; %include gcos_dcl_ios_; end gcos_write_;  gcos_write_to_er_.pl1 09/09/83 1400.3rew 09/09/83 1007.3 24651 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* ******************************************************************************************** ******************************************************************************************** * * * G C O S W R I T E T O E R * * * This procedure is called to write messages on the execution report * of the executing GCOS job. Its arguments are the same as ioa_. * Multiple line messages are handled and case is preserved. * * * Written by M. R. Jordan, August 1977 * ******************************************************************************************** ******************************************************************************************** */ gcos_write_to_er_: procedure (); dcl NL char (1) static int options (constant) init (" "); dcl arg_list_ptr ptr; dcl cu_$arg_count entry (fixed bin(24)); dcl cu_$arg_list_ptr entry (ptr); dcl gcos_write_$ascii_ptr entry (ptr, char (*), bit (8)); dcl index builtin; dcl ioa_$general_rs entry (ptr, fixed bin(24), fixed bin(24), char (*), fixed bin(24), bit (1), bit (1)); dcl len fixed bin(24); dcl nargs fixed bin(24); dcl rtn_string char (257); dcl rtn_string_len fixed bin(24); dcl start fixed bin(24); dcl substr builtin; /* If called with no arguments, return imediately. */ call cu_$arg_count (nargs); if nargs <= 0 then return; /* Get ready and call ioa_ to format the message. */ call cu_$arg_list_ptr (arg_list_ptr); call ioa_$general_rs (arg_list_ptr, 1, 2, rtn_string, rtn_string_len, "0"b, "1"b); /* If the returned string does not contain any useful information, then just quit. */ if rtn_string_len = 0 then return; if substr (rtn_string, 1, rtn_string_len) = "" then return; /* Now write the message to the execution report one line at a time. */ start = 1; do while (rtn_string_len > 0); len = index (substr (rtn_string, start, rtn_string_len), NL); if len = 0 then len = rtn_string_len; call gcos_write_$ascii_ptr (gcos_ext_stat_$er, substr (rtn_string, start, len), "11111100"b); start = start+len; rtn_string_len = rtn_string_len-len; end; return; %include gcos_ext_stat_; end gcos_write_to_er_; */ ----------------------------------------------------------- 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 */